diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -15,24 +15,28 @@ cabal: [ "3.4" , "3.6" + , "3.8" ] ghc: - [ "8.6" - , "8.8" + [ "8.8" , "8.10" , "9.0" + , "9.2" ] + exclude: + - cabal: "3.4" + ghc: "9.2" steps: - - uses: actions/checkout@v2 + - uses: actions/checkout@v3 with: submodules: 'recursive' - - uses: haskell/actions/setup@v1 + - uses: haskell/actions/setup@v2 with: ghc-version: ${{ matrix.ghc }} cabal-version: ${{ matrix.cabal }} - name: Cache - uses: actions/cache@v1 + uses: actions/cache@v3 env: cache-name: cache-cabal with: @@ -52,5 +56,5 @@ cabal build --only-dependencies - name: Build run: cabal build - - name: Run all enabled tests - run: cabal test --test-option=--color --test-show-details=streaming + - name: Run spec test + run: cabal test --test-option=--color --test-show-details=streaming spec diff --git a/.gitmodules b/.gitmodules --- a/.gitmodules +++ b/.gitmodules @@ -1,6 +1,7 @@ [submodule "cabal"] path = cabal url = https://github.com/gentoo-haskell/cabal.git + branch = 3.8 [submodule "hackage-security"] path = hackage-security url = https://github.com/gentoo-haskell/hackage-security.git diff --git a/cabal/.arcconfig b/cabal/.arcconfig deleted file mode 100644 --- a/cabal/.arcconfig +++ /dev/null @@ -1,4 +0,0 @@ -{ - "repository.callsign" : "CABAL", - "phabricator.uri" : "https://phabricator.haskell.org" -} diff --git a/cabal/.docker/validate-7.10.3.dockerfile b/cabal/.docker/validate-7.10.3.dockerfile deleted file mode 100644 --- a/cabal/.docker/validate-7.10.3.dockerfile +++ /dev/null @@ -1,78 +0,0 @@ -FROM phadej/ghc:7.10.3-bionic - -# Install cabal-plan -RUN mkdir -p /root/.cabal/bin && \ - curl -L https://github.com/haskell-hvr/cabal-plan/releases/download/v0.6.2.0/cabal-plan-0.6.2.0-x86_64-linux.xz > cabal-plan.xz && \ - echo "de73600b1836d3f55e32d80385acc055fd97f60eaa0ab68a755302685f5d81bc cabal-plan.xz" | sha256sum -c - && \ - xz -d < cabal-plan.xz > /root/.cabal/bin/cabal-plan && \ - rm -f cabal-plan.xz && \ - chmod a+x /root/.cabal/bin/cabal-plan - -# Install cabal-env -RUN curl -sL https://github.com/phadej/cabal-extras/releases/download/preview-20191225/cabal-env-snapshot-20191225-x86_64-linux.xz > cabal-env.xz && \ - echo "1b567d529c5f627fd8c956e57ae8f0d9f11ee66d6db34b7fb0cb1c370b4edf01 cabal-env.xz" | sha256sum -c - && \ - xz -d < cabal-env.xz > $HOME/.cabal/bin/cabal-env && \ - rm -f cabal-env.xz && \ - chmod a+x $HOME/.cabal/bin/cabal-env - - -# Update index -RUN cabal v2-update --index-state="2020-06-12T23:36:15Z" - -# We install happy, so it's in the store; we (hopefully) don't use it directly. -RUN cabal v2-install happy --constraint 'happy ^>=1.19.12' - -# Install some other dependencies -# Remove $HOME/.ghc so there aren't any environments -RUN cabal v2-install -w ghc-7.10.3 --lib \ - Cabal \ - aeson \ - async \ - base-compat \ - base16-bytestring \ - base64-bytestring \ - cryptohash-sha256 \ - Diff \ - echo \ - ed25519 \ - edit-distance \ - HTTP \ - lukko \ - network \ - optparse-applicative \ - pretty-show \ - regex-compat-tdfa \ - regex-posix \ - regex-tdfa \ - rere \ - statistics \ - tar \ - tasty \ - tasty-golden \ - tasty-hunit \ - tasty-quickcheck \ - tree-diff \ - void \ - zlib \ - resolv \ - parsec \ - text \ - --constraint="rere -rere-cfg" \ - --constraint="these -assoc" \ - --constraint="bytestring installed" \ - --constraint="binary installed" \ - --constraint="containers installed" \ - --constraint="deepseq installed" \ - --constraint="directory installed" \ - --constraint="filepath installed" \ - --constraint="pretty installed" \ - --constraint="process installed" \ - --constraint="time installed" \ - --constraint="unix installed" \ - --constraint="transformers installed" \ - && rm -rf $HOME/.ghc - -# Validate -WORKDIR /build -COPY . /build -RUN sh ./validate.sh -w ghc-7.10.3 -v diff --git a/cabal/.docker/validate-7.6.3.dockerfile b/cabal/.docker/validate-7.6.3.dockerfile deleted file mode 100644 --- a/cabal/.docker/validate-7.6.3.dockerfile +++ /dev/null @@ -1,79 +0,0 @@ -FROM phadej/ghc:7.6.3-xenial - -# Install cabal-plan -RUN mkdir -p /root/.cabal/bin && \ - curl -L https://github.com/haskell-hvr/cabal-plan/releases/download/v0.6.2.0/cabal-plan-0.6.2.0-x86_64-linux.xz > cabal-plan.xz && \ - echo "de73600b1836d3f55e32d80385acc055fd97f60eaa0ab68a755302685f5d81bc cabal-plan.xz" | sha256sum -c - && \ - xz -d < cabal-plan.xz > /root/.cabal/bin/cabal-plan && \ - rm -f cabal-plan.xz && \ - chmod a+x /root/.cabal/bin/cabal-plan - -# Install cabal-env -RUN curl -sL https://github.com/phadej/cabal-extras/releases/download/preview-20191225/cabal-env-snapshot-20191225-x86_64-linux.xz > cabal-env.xz && \ - echo "1b567d529c5f627fd8c956e57ae8f0d9f11ee66d6db34b7fb0cb1c370b4edf01 cabal-env.xz" | sha256sum -c - && \ - xz -d < cabal-env.xz > $HOME/.cabal/bin/cabal-env && \ - rm -f cabal-env.xz && \ - chmod a+x $HOME/.cabal/bin/cabal-env - -# We need newer compiler, to install cabal-plan -RUN apt-get update -RUN apt-get install -y ghc-7.6.3-dyn - -# Update index -RUN cabal v2-update --index-state="2020-06-12T23:36:15Z" - -# We install happy, so it's in the store; we (hopefully) don't use it directly. -RUN cabal v2-install happy --constraint 'happy ^>=1.19.12' - -# Install some other dependencies -# Remove $HOME/.ghc so there aren't any environments -RUN cabal v2-install -w ghc-7.6.3 --lib \ - Cabal \ - aeson \ - async \ - base-compat \ - base16-bytestring \ - base64-bytestring \ - cryptohash-sha256 \ - Diff \ - echo \ - ed25519 \ - edit-distance \ - HTTP \ - lukko \ - network \ - optparse-applicative \ - pretty-show \ - regex-compat-tdfa \ - regex-posix \ - regex-tdfa \ - rere \ - statistics \ - tar \ - tasty \ - tasty-golden \ - tasty-hunit \ - tasty-quickcheck \ - tree-diff \ - void \ - zlib \ - parsec \ - text \ - --constraint="rere -rere-cfg" \ - --constraint="these -assoc" \ - --constraint="bytestring installed" \ - --constraint="binary installed" \ - --constraint="containers installed" \ - --constraint="deepseq installed" \ - --constraint="directory installed" \ - --constraint="filepath installed" \ - --constraint="pretty installed" \ - --constraint="process installed" \ - --constraint="time installed" \ - --constraint="unix installed" \ - && rm -rf $HOME/.ghc - -# Validate -WORKDIR /build -COPY . /build -RUN sh ./validate.sh --lib-only -w ghc-7.6.3 -v diff --git a/cabal/.docker/validate-7.8.4.dockerfile b/cabal/.docker/validate-7.8.4.dockerfile deleted file mode 100644 --- a/cabal/.docker/validate-7.8.4.dockerfile +++ /dev/null @@ -1,80 +0,0 @@ -FROM phadej/ghc:7.8.4-xenial - -# Install cabal-plan -RUN mkdir -p /root/.cabal/bin && \ - curl -L https://github.com/haskell-hvr/cabal-plan/releases/download/v0.6.2.0/cabal-plan-0.6.2.0-x86_64-linux.xz > cabal-plan.xz && \ - echo "de73600b1836d3f55e32d80385acc055fd97f60eaa0ab68a755302685f5d81bc cabal-plan.xz" | sha256sum -c - && \ - xz -d < cabal-plan.xz > /root/.cabal/bin/cabal-plan && \ - rm -f cabal-plan.xz && \ - chmod a+x /root/.cabal/bin/cabal-plan - -# Install cabal-env -RUN curl -sL https://github.com/phadej/cabal-extras/releases/download/preview-20191225/cabal-env-snapshot-20191225-x86_64-linux.xz > cabal-env.xz && \ - echo "1b567d529c5f627fd8c956e57ae8f0d9f11ee66d6db34b7fb0cb1c370b4edf01 cabal-env.xz" | sha256sum -c - && \ - xz -d < cabal-env.xz > $HOME/.cabal/bin/cabal-env && \ - rm -f cabal-env.xz && \ - chmod a+x $HOME/.cabal/bin/cabal-env - -# We need newer compiler, to install cabal-plan -RUN apt-get update -RUN apt-get install -y ghc-7.8.4-dyn - -# Update index -RUN cabal v2-update --index-state="2020-06-12T23:36:15Z" - -# We install happy, so it's in the store; we (hopefully) don't use it directly. -RUN cabal v2-install happy --constraint 'happy ^>=1.19.12' - -# Install some other dependencies -# Remove $HOME/.ghc so there aren't any environments -RUN cabal v2-install -w ghc-7.8.4 --lib \ - Cabal \ - aeson \ - async \ - base-compat \ - base16-bytestring \ - base64-bytestring \ - cryptohash-sha256 \ - Diff \ - echo \ - ed25519 \ - edit-distance \ - HTTP \ - lukko \ - network \ - optparse-applicative \ - pretty-show \ - regex-compat-tdfa \ - regex-posix \ - regex-tdfa \ - rere \ - statistics \ - tar \ - tasty \ - tasty-golden \ - tasty-hunit \ - tasty-quickcheck \ - tree-diff \ - void \ - zlib \ - parsec \ - text \ - --constraint="rere -rere-cfg" \ - --constraint="these -assoc" \ - --constraint="bytestring installed" \ - --constraint="binary installed" \ - --constraint="containers installed" \ - --constraint="deepseq installed" \ - --constraint="directory installed" \ - --constraint="filepath installed" \ - --constraint="pretty installed" \ - --constraint="process installed" \ - --constraint="time installed" \ - --constraint="unix installed" \ - --constraint="transformers installed" \ - && rm -rf $HOME/.ghc - -# Validate -WORKDIR /build -COPY . /build -RUN sh ./validate.sh --lib-only -w ghc-7.8.4 -v diff --git a/cabal/.docker/validate-8.0.2.dockerfile b/cabal/.docker/validate-8.0.2.dockerfile deleted file mode 100644 --- a/cabal/.docker/validate-8.0.2.dockerfile +++ /dev/null @@ -1,69 +0,0 @@ -FROM phadej/ghc:8.0.2-bionic - -# Install cabal-plan -RUN mkdir -p /root/.cabal/bin && \ - curl -L https://github.com/haskell-hvr/cabal-plan/releases/download/v0.6.2.0/cabal-plan-0.6.2.0-x86_64-linux.xz > cabal-plan.xz && \ - echo "de73600b1836d3f55e32d80385acc055fd97f60eaa0ab68a755302685f5d81bc cabal-plan.xz" | sha256sum -c - && \ - xz -d < cabal-plan.xz > /root/.cabal/bin/cabal-plan && \ - rm -f cabal-plan.xz && \ - chmod a+x /root/.cabal/bin/cabal-plan - - -# Update index -RUN cabal v2-update --index-state="2020-06-12T23:36:15Z" - -# We install happy, so it's in the store; we (hopefully) don't use it directly. -RUN cabal v2-install happy --constraint 'happy ^>=1.19.12' - -# Install some other dependencies -# Remove $HOME/.ghc so there aren't any environments -RUN cabal v2-install -w ghc-8.0.2 --lib \ - Cabal \ - aeson \ - async \ - base-compat \ - base16-bytestring \ - base64-bytestring \ - cryptohash-sha256 \ - Diff \ - echo \ - ed25519 \ - edit-distance \ - HTTP \ - lukko \ - network \ - optparse-applicative \ - pretty-show \ - regex-compat-tdfa \ - regex-posix \ - regex-tdfa \ - rere \ - statistics \ - tar \ - tasty \ - tasty-golden \ - tasty-hunit \ - tasty-quickcheck \ - tree-diff \ - void \ - zlib \ - resolv \ - --constraint="rere -rere-cfg" \ - --constraint="these -assoc" \ - --constraint="bytestring installed" \ - --constraint="binary installed" \ - --constraint="containers installed" \ - --constraint="deepseq installed" \ - --constraint="directory installed" \ - --constraint="filepath installed" \ - --constraint="pretty installed" \ - --constraint="process installed" \ - --constraint="time installed" \ - --constraint="unix installed" \ - --constraint="transformers installed" \ - && rm -rf $HOME/.ghc - -# Validate -WORKDIR /build -COPY . /build -RUN sh ./validate.sh -w ghc-8.0.2 -v diff --git a/cabal/.docker/validate-8.10.1.dockerfile b/cabal/.docker/validate-8.10.1.dockerfile deleted file mode 100644 --- a/cabal/.docker/validate-8.10.1.dockerfile +++ /dev/null @@ -1,76 +0,0 @@ -FROM phadej/ghc:8.10.1-bionic - -# Install cabal-plan -RUN mkdir -p /root/.cabal/bin && \ - curl -L https://github.com/haskell-hvr/cabal-plan/releases/download/v0.6.2.0/cabal-plan-0.6.2.0-x86_64-linux.xz > cabal-plan.xz && \ - echo "de73600b1836d3f55e32d80385acc055fd97f60eaa0ab68a755302685f5d81bc cabal-plan.xz" | sha256sum -c - && \ - xz -d < cabal-plan.xz > /root/.cabal/bin/cabal-plan && \ - rm -f cabal-plan.xz && \ - chmod a+x /root/.cabal/bin/cabal-plan - -# Install cabal-env -RUN curl -sL https://github.com/phadej/cabal-extras/releases/download/preview-20191225/cabal-env-snapshot-20191225-x86_64-linux.xz > cabal-env.xz && \ - echo "1b567d529c5f627fd8c956e57ae8f0d9f11ee66d6db34b7fb0cb1c370b4edf01 cabal-env.xz" | sha256sum -c - && \ - xz -d < cabal-env.xz > $HOME/.cabal/bin/cabal-env && \ - rm -f cabal-env.xz && \ - chmod a+x $HOME/.cabal/bin/cabal-env - - -# Update index -RUN cabal v2-update --index-state="2020-06-12T23:36:15Z" - -# We install happy, so it's in the store; we (hopefully) don't use it directly. -RUN cabal v2-install happy --constraint 'happy ^>=1.19.12' - -# Install some other dependencies -# Remove $HOME/.ghc so there aren't any environments -RUN cabal v2-install -w ghc-8.10.1 --lib \ - Cabal \ - aeson \ - async \ - base-compat \ - base16-bytestring \ - base64-bytestring \ - cryptohash-sha256 \ - Diff \ - echo \ - ed25519 \ - edit-distance \ - HTTP \ - lukko \ - network \ - optparse-applicative \ - pretty-show \ - regex-compat-tdfa \ - regex-posix \ - regex-tdfa \ - rere \ - statistics \ - tar \ - tasty \ - tasty-golden \ - tasty-hunit \ - tasty-quickcheck \ - tree-diff \ - void \ - zlib \ - resolv \ - --constraint="rere -rere-cfg" \ - --constraint="these -assoc" \ - --constraint="bytestring installed" \ - --constraint="binary installed" \ - --constraint="containers installed" \ - --constraint="deepseq installed" \ - --constraint="directory installed" \ - --constraint="filepath installed" \ - --constraint="pretty installed" \ - --constraint="process installed" \ - --constraint="time installed" \ - --constraint="unix installed" \ - --constraint="transformers installed" \ - && rm -rf $HOME/.ghc - -# Validate -WORKDIR /build -COPY . /build -RUN sh ./validate.sh -w ghc-8.10.1 -v diff --git a/cabal/.docker/validate-8.10.4.dockerfile b/cabal/.docker/validate-8.10.4.dockerfile new file mode 100644 --- /dev/null +++ b/cabal/.docker/validate-8.10.4.dockerfile @@ -0,0 +1,76 @@ +FROM phadej/ghc:8.10.4-bionic + +# Install cabal-plan +RUN mkdir -p /root/.cabal/bin && \ + curl -L https://github.com/haskell-hvr/cabal-plan/releases/download/v0.6.2.0/cabal-plan-0.6.2.0-x86_64-linux.xz > cabal-plan.xz && \ + echo "de73600b1836d3f55e32d80385acc055fd97f60eaa0ab68a755302685f5d81bc cabal-plan.xz" | sha256sum -c - && \ + xz -d < cabal-plan.xz > /root/.cabal/bin/cabal-plan && \ + rm -f cabal-plan.xz && \ + chmod a+x /root/.cabal/bin/cabal-plan + +# Install cabal-env +RUN curl -sL https://github.com/phadej/cabal-extras/releases/download/preview-20191225/cabal-env-snapshot-20191225-x86_64-linux.xz > cabal-env.xz && \ + echo "1b567d529c5f627fd8c956e57ae8f0d9f11ee66d6db34b7fb0cb1c370b4edf01 cabal-env.xz" | sha256sum -c - && \ + xz -d < cabal-env.xz > $HOME/.cabal/bin/cabal-env && \ + rm -f cabal-env.xz && \ + chmod a+x $HOME/.cabal/bin/cabal-env + + +# Update index +RUN cabal v2-update --index-state="2020-06-12T23:36:15Z" + +# We install happy, so it's in the store; we (hopefully) don't use it directly. +RUN cabal v2-install happy --constraint 'happy ^>=1.19.12' + +# Install some other dependencies +# Remove $HOME/.ghc so there aren't any environments +RUN cabal v2-install -w ghc-8.10.4 --lib \ + Cabal \ + aeson \ + async \ + base-compat \ + base16-bytestring \ + base64-bytestring \ + cryptohash-sha256 \ + Diff \ + echo \ + ed25519 \ + edit-distance \ + HTTP \ + lukko \ + network \ + optparse-applicative \ + pretty-show \ + regex-compat-tdfa \ + regex-posix \ + regex-tdfa \ + rere \ + statistics \ + tar \ + tasty \ + tasty-golden \ + tasty-hunit \ + tasty-quickcheck \ + tree-diff \ + void \ + zlib \ + resolv \ + --constraint="rere -rere-cfg" \ + --constraint="these -assoc" \ + --constraint="bytestring installed" \ + --constraint="binary installed" \ + --constraint="containers installed" \ + --constraint="deepseq installed" \ + --constraint="directory installed" \ + --constraint="filepath installed" \ + --constraint="pretty installed" \ + --constraint="process installed" \ + --constraint="time installed" \ + --constraint="unix installed" \ + --constraint="transformers installed" \ + && rm -rf $HOME/.ghc + +# Validate +WORKDIR /build +COPY . /build +RUN sh ./validate.sh -w ghc-8.10.4 -v diff --git a/cabal/.docker/validate-8.8.3.dockerfile b/cabal/.docker/validate-8.8.3.dockerfile deleted file mode 100644 --- a/cabal/.docker/validate-8.8.3.dockerfile +++ /dev/null @@ -1,76 +0,0 @@ -FROM phadej/ghc:8.8.3-bionic - -# Install cabal-plan -RUN mkdir -p /root/.cabal/bin && \ - curl -L https://github.com/haskell-hvr/cabal-plan/releases/download/v0.6.2.0/cabal-plan-0.6.2.0-x86_64-linux.xz > cabal-plan.xz && \ - echo "de73600b1836d3f55e32d80385acc055fd97f60eaa0ab68a755302685f5d81bc cabal-plan.xz" | sha256sum -c - && \ - xz -d < cabal-plan.xz > /root/.cabal/bin/cabal-plan && \ - rm -f cabal-plan.xz && \ - chmod a+x /root/.cabal/bin/cabal-plan - -# Install cabal-env -RUN curl -sL https://github.com/phadej/cabal-extras/releases/download/preview-20191225/cabal-env-snapshot-20191225-x86_64-linux.xz > cabal-env.xz && \ - echo "1b567d529c5f627fd8c956e57ae8f0d9f11ee66d6db34b7fb0cb1c370b4edf01 cabal-env.xz" | sha256sum -c - && \ - xz -d < cabal-env.xz > $HOME/.cabal/bin/cabal-env && \ - rm -f cabal-env.xz && \ - chmod a+x $HOME/.cabal/bin/cabal-env - - -# Update index -RUN cabal v2-update --index-state="2020-06-12T23:36:15Z" - -# We install happy, so it's in the store; we (hopefully) don't use it directly. -RUN cabal v2-install happy --constraint 'happy ^>=1.19.12' - -# Install some other dependencies -# Remove $HOME/.ghc so there aren't any environments -RUN cabal v2-install -w ghc-8.8.3 --lib \ - Cabal \ - aeson \ - async \ - base-compat \ - base16-bytestring \ - base64-bytestring \ - cryptohash-sha256 \ - Diff \ - echo \ - ed25519 \ - edit-distance \ - HTTP \ - lukko \ - network \ - optparse-applicative \ - pretty-show \ - regex-compat-tdfa \ - regex-posix \ - regex-tdfa \ - rere \ - statistics \ - tar \ - tasty \ - tasty-golden \ - tasty-hunit \ - tasty-quickcheck \ - tree-diff \ - void \ - zlib \ - resolv \ - --constraint="rere -rere-cfg" \ - --constraint="these -assoc" \ - --constraint="bytestring installed" \ - --constraint="binary installed" \ - --constraint="containers installed" \ - --constraint="deepseq installed" \ - --constraint="directory installed" \ - --constraint="filepath installed" \ - --constraint="pretty installed" \ - --constraint="process installed" \ - --constraint="time installed" \ - --constraint="unix installed" \ - --constraint="transformers installed" \ - && rm -rf $HOME/.ghc - -# Validate -WORKDIR /build -COPY . /build -RUN sh ./validate.sh --doctest --solver-benchmarks --complete-hackage -w ghc-8.8.3 -v diff --git a/cabal/.docker/validate-8.8.4.dockerfile b/cabal/.docker/validate-8.8.4.dockerfile new file mode 100644 --- /dev/null +++ b/cabal/.docker/validate-8.8.4.dockerfile @@ -0,0 +1,76 @@ +FROM phadej/ghc:8.8.4-bionic + +# Install cabal-plan +RUN mkdir -p /root/.cabal/bin && \ + curl -L https://github.com/haskell-hvr/cabal-plan/releases/download/v0.6.2.0/cabal-plan-0.6.2.0-x86_64-linux.xz > cabal-plan.xz && \ + echo "de73600b1836d3f55e32d80385acc055fd97f60eaa0ab68a755302685f5d81bc cabal-plan.xz" | sha256sum -c - && \ + xz -d < cabal-plan.xz > /root/.cabal/bin/cabal-plan && \ + rm -f cabal-plan.xz && \ + chmod a+x /root/.cabal/bin/cabal-plan + +# Install cabal-env +RUN curl -sL https://github.com/phadej/cabal-extras/releases/download/preview-20191225/cabal-env-snapshot-20191225-x86_64-linux.xz > cabal-env.xz && \ + echo "1b567d529c5f627fd8c956e57ae8f0d9f11ee66d6db34b7fb0cb1c370b4edf01 cabal-env.xz" | sha256sum -c - && \ + xz -d < cabal-env.xz > $HOME/.cabal/bin/cabal-env && \ + rm -f cabal-env.xz && \ + chmod a+x $HOME/.cabal/bin/cabal-env + + +# Update index +RUN cabal v2-update --index-state="2020-06-12T23:36:15Z" + +# We install happy, so it's in the store; we (hopefully) don't use it directly. +RUN cabal v2-install happy --constraint 'happy ^>=1.19.12' + +# Install some other dependencies +# Remove $HOME/.ghc so there aren't any environments +RUN cabal v2-install -w ghc-8.8.4 --lib \ + Cabal \ + aeson \ + async \ + base-compat \ + base16-bytestring \ + base64-bytestring \ + cryptohash-sha256 \ + Diff \ + echo \ + ed25519 \ + edit-distance \ + HTTP \ + lukko \ + network \ + optparse-applicative \ + pretty-show \ + regex-compat-tdfa \ + regex-posix \ + regex-tdfa \ + rere \ + statistics \ + tar \ + tasty \ + tasty-golden \ + tasty-hunit \ + tasty-quickcheck \ + tree-diff \ + void \ + zlib \ + resolv \ + --constraint="rere -rere-cfg" \ + --constraint="these -assoc" \ + --constraint="bytestring installed" \ + --constraint="binary installed" \ + --constraint="containers installed" \ + --constraint="deepseq installed" \ + --constraint="directory installed" \ + --constraint="filepath installed" \ + --constraint="pretty installed" \ + --constraint="process installed" \ + --constraint="time installed" \ + --constraint="unix installed" \ + --constraint="transformers installed" \ + && rm -rf $HOME/.ghc + +# Validate +WORKDIR /build +COPY . /build +RUN sh ./validate.sh --doctest --solver-benchmarks --complete-hackage -w ghc-8.8.4 -v diff --git a/cabal/.ghci b/cabal/.ghci deleted file mode 100644 --- a/cabal/.ghci +++ /dev/null @@ -1,2 +0,0 @@ -:set -icabal-install -icabal-install/main -:load Main diff --git a/cabal/.ghcid b/cabal/.ghcid deleted file mode 100644 --- a/cabal/.ghcid +++ /dev/null @@ -1,1 +0,0 @@ ---command "ghci -j4 +RTS -A128m" diff --git a/cabal/.git-blame-ignore-revs b/cabal/.git-blame-ignore-revs new file mode 100644 --- /dev/null +++ b/cabal/.git-blame-ignore-revs @@ -0,0 +1,32 @@ +# 2022 +######################################## + +# Make Cabal-syntax package +a64b9aea0839cd7183dfae1e94455b870a3d5812 + +# 2020 Summer +######################################## + +# Move tests/ dir to cabal-install/fixtures +74ca6b96c859f2cb6c540cc19ebcc17c878390ea + +# Move doc/ to the top-level of the repository +2cb296d28fe24993fbe309b1d59fbd9be074ca6e + +# Move Cabal sources into Cabal/src +3cd9fded57805ab19ee15474051ec87c7d87cd39 + +# Move cabal-install source to src/ +0d0c00951c40394929623fdf3eddca220e7b2214 + +# Make cabal-install-solver package +b0333ec5b73ba8f7a18223b203d999b38c75281d + +# 2016 +######################################## + +# Revert the 'hs-source-dirs: src' change. +002d709ee5ffa739076b2ac303eb1afaa03ed87c + +# Move source files under 'src/'. +52d506bb4e25489f40cb5eb594dda5595aeb93ed diff --git a/cabal/.github/PULL_REQUEST_TEMPLATE.md b/cabal/.github/PULL_REQUEST_TEMPLATE.md --- a/cabal/.github/PULL_REQUEST_TEMPLATE.md +++ b/cabal/.github/PULL_REQUEST_TEMPLATE.md @@ -3,7 +3,7 @@ Please include the following checklist in your PR: * [ ] Patches conform to the [coding conventions](https://github.com/haskell/cabal/blob/master/CONTRIBUTING.md#conventions). -* [ ] Any changes that could be relevant to users have been recorded in the changelog (add file to `changelog.d` directory). +* [ ] Any changes that could be relevant to users [have been recorded in the changelog](https://github.com/haskell/cabal/blob/master/CONTRIBUTING.md#changelog). * [ ] The documentation has been updated, if necessary. Please also shortly describe how you tested your change. Bonus points for added tests! diff --git a/cabal/.github/mergify.yml b/cabal/.github/mergify.yml new file mode 100644 --- /dev/null +++ b/cabal/.github/mergify.yml @@ -0,0 +1,29 @@ +pull_request_rules: + # rebase+merge strategy + - actions: + queue: + name: default + # Merge into master with a merge commit + method: merge + # Update the pr branch with rebase, so the history is clean + update_method: rebase + name: Put pull requests in the rebase+merge queue + conditions: + - label=merge me + - '#approved-reviews-by>=2' + # merge+squash strategy + - actions: + queue: + name: default + method: squash + # both update methods get absorbed by the squash, so we use the most + # reliable + update_method: merge + name: Put pull requests in the squash+merge queue + conditions: + - label=squash+merge me + - '#approved-reviews-by>=2' + +queue_rules: + - name: default + conditions: [] diff --git a/cabal/.github/workflows/artifacts.yml b/cabal/.github/workflows/artifacts.yml deleted file mode 100644 --- a/cabal/.github/workflows/artifacts.yml +++ /dev/null @@ -1,136 +0,0 @@ -name: Artifacts -on: - push: - branches: - - master - - "3.2" - pull_request: - branches: - - master - release: - types: - - created - -jobs: - artifact-linux: - name: Artifact on Linux - runs-on: ubuntu-18.04 - container: - # Older Ubuntu for older glibc - image: phadej/ghc:8.6.5-xenial - steps: - - name: Set PATH - run: | - echo "::add-path::$HOME/.cabal/bin" - - name: Update Hackage index - run: cabal v2-update - - uses: actions/checkout@v2 - - name: Release project - run: | - cp cabal.project.release cabal.project - rm -rf cabal.project.local cabal.project.freeze - - name: Build - run: | - cabal v2-build cabal-install:exe:cabal - cp $(find dist-newstyle -type f -executable -name cabal) cabal.exe - - name: Smoke test - run: | - ./cabal.exe --version - - name: Prepare for upload - run: xz -c < cabal.exe > cabal-artifact.xz - - uses: actions/upload-artifact@v1 - with: - name: cabal-linux-x86_64.xz - path: cabal-artifact.xz - - artifact-macos: - name: Artifact on macOS - runs-on: macos-latest - steps: - - name: Install GHC - run: | - cd $(mktemp -d) - curl -sLO "https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-apple-darwin.tar.xz" - tar -xJf ghc-*.tar.xz - cd ghc-* - ./configure --prefix=/opt/ghc/8.6.5 - sudo make install - - name: Install Cabal - run: | - cd $(mktemp -d) - curl -sLO https://downloads.haskell.org/~cabal/cabal-install-3.0.0.0/cabal-install-3.0.0.0-x86_64-apple-darwin17.7.0.tar.xz - tar -xJf cabal-install-*.tar.xz - sudo mkdir -p /opt/cabal/3.0/bin - sudo cp cabal /opt/cabal/3.0/bin/cabal - sudo chmod 755 /opt/cabal/3.0/bin/cabal - - name: Set PATH - run: | - echo "::add-path::/opt/ghc/8.6.5/bin" - echo "::add-path::/opt/cabal/3.0/bin" - echo "::add-path::$HOME/.cabal/bin" - - name: Update Hackage index - run: cabal v2-update - - uses: actions/checkout@v2 - - name: Release project - run: | - cp cabal.project.release cabal.project - rm -rf cabal.project.local cabal.project.freeze - - name: Build - run: | - cabal v2-build cabal-install:exe:cabal - # macOS find doesn't know -executable - cp $(find dist-newstyle -type f -name cabal) cabal.exe - - name: Smoke test - run: | - ./cabal.exe --version - - name: Prepare for upload - run: xz -c < cabal.exe > cabal-artifact.xz - - uses: actions/upload-artifact@v1 - with: - name: cabal-macos-x86_64.xz - path: cabal-artifact.xz - - artifact-windows: - name: Artifact on Windows - runs-on: windows-latest - steps: - - name: Install Cabal - run: choco install -fy cabal --version 3.0.0.0 - - name: Install GHC - run: | - choco uninstall -y ghc - choco install -y ghc --version 8.6.5 - - name: Set PATH - run: | - [Environment]::GetEnvironmentVariable("Path") - Write-Host "::add-path::C:\ProgramData\chocolatey\lib\cabal\tools\cabal-3.0.0.0" - Write-Host "::add-path::C:\ProgramData\chocolatey\lib\ghc\tools\ghc-8.6.5\bin" - - name: Print versions - run: | - ghc --version - cabal --version - cabal user-config init -a "http-transport: plain-http" -a "store-dir: C:\SR" -f -v3 - - name: Update Hackage index - run: cabal v2-update - - uses: actions/checkout@v2 - - name: Release project - shell: bash - run: | - cp cabal.project.release cabal.project - rm -rf cabal.project.local cabal.project.freeze - - name: Build - shell: bash - run: | - cabal v2-build cabal-install:exe:cabal - cp dist-newstyle/build/x86_64-windows/ghc-8.6.5/cabal-install-3.3.0.0/x/cabal/build/cabal/cabal.exe cabal.exe - - name: Smoke test - shell: bash - run: | - ./cabal.exe --version - - name: Prepare for upload - shell: bash - run: xz -c < cabal.exe > cabal-artifact.xz - - uses: actions/upload-artifact@v1 - with: - name: cabal-windows-x86_64.xz - path: cabal-artifact.xz diff --git a/cabal/.github/workflows/bootstrap.yml b/cabal/.github/workflows/bootstrap.yml --- a/cabal/.github/workflows/bootstrap.yml +++ b/cabal/.github/workflows/bootstrap.yml @@ -1,64 +1,45 @@ -# This file is auto-generated -# -# To regenerate it run -# -# make github-actions -# name: Bootstrap + +# See: https://docs.github.com/en/actions/reference/workflow-syntax-for-github-actions#concurrency. +concurrency: + group: ${{ github.ref }}-${{ github.workflow }} + cancel-in-progress: true + on: push: branches: - master - - "3.2" pull_request: - branches: - - master release: types: - created jobs: - boostrap-linux: - name: Bootstrap on Linux - runs-on: ubuntu-18.04 + bootstrap: + strategy: + matrix: + os: [ubuntu-latest] + ghc: ["8.6.5", "8.8.4", "8.10.7", "9.0.2", "9.2.3"] + include: + - os: macos-latest + ghc: "9.2.3" + name: Bootstrap ${{ matrix.os }} ghc-${{ matrix.ghc }} + runs-on: ${{ matrix.os }} steps: - - name: Set PATH - run: | - echo "::add-path::/opt/ghc/8.6.5/bin" - uses: actions/checkout@v2 - - name: bootstrap.sh - env: - EXTRA_CONFIGURE_OPTS: "" - run: | - cd cabal-install - sh ./bootstrap.sh --no-doc - - name: Smoke test + - name: bootstrap.py run: | - $HOME/.cabal/bin/cabal --version + GHC_VERSION=${{ matrix.ghc }} + ghcup config set cache true + ghcup install ghc $GHC_VERSION + # We use linux dependencies also on macos + python3 bootstrap/bootstrap.py -w $(ghcup whereis ghc $GHC_VERSION) -d bootstrap/linux-$GHC_VERSION.json - boostrap-macos: - name: Bootstrap on macOS - runs-on: macos-latest - steps: - - name: Install GHC - run: | - cd $(mktemp -d) - curl -sLO "https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-apple-darwin.tar.xz" - tar -xJf ghc-*.tar.xz - cd ghc-* - ./configure --prefix=/opt/ghc/8.6.5 - sudo make install - - name: Set PATH - run: | - echo "::add-path::/opt/ghc/8.6.5/bin" - echo "::add-path::$HOME/.cabal/bin" - - uses: actions/checkout@v2 - - name: bootstrap.sh - env: - EXTRA_CONFIGURE_OPTS: "" - run: | - cd cabal-install - sh ./bootstrap.sh --no-doc - name: Smoke test run: | - $HOME/.cabal/bin/cabal --version + _build/bin/cabal --version + + - uses: actions/upload-artifact@v2 + with: + name: cabal-${{ matrix.os }}-${{ matrix.ghc }}-bootstrapped + path: _build/artifacts/* diff --git a/cabal/.github/workflows/changelogs.yml b/cabal/.github/workflows/changelogs.yml new file mode 100644 --- /dev/null +++ b/cabal/.github/workflows/changelogs.yml @@ -0,0 +1,58 @@ +name: Assorted + +on: + push: + branches: + - master + paths: + - 'changelog.d/*' + - '.github/workflows/changelogs.yml' + pull_request: + paths: + - 'changelog.d/*' + - '.github/workflows/changelogs.yml' + release: + types: + - created + +defaults: + run: + shell: bash + +jobs: + build: + name: Changelogs + runs-on: ubuntu-latest + + steps: + - name: Set PATH + # https://docs.github.com/en/free-pro-team@latest/actions/reference/workflow-commands-for-github-actions#adding-a-system-path + run: | + echo "$HOME/.cabal/bin" >> $GITHUB_PATH + - uses: actions/cache@v1 + with: + path: ~/.cabal/store + key: linux-store-changelogs + - name: ghcup + run: | + ghcup config set cache true + ghcup install ghc 8.10.7 + ghcup set ghc 8.10.7 + # GHC 8.10.7 needed due to https://github.com/phadej/changelog-d/pull/2 + - name: Update Hackage index + run: cabal v2-update + # Cannot install it from tarball due to + # https://github.com/haskell/cabal/issues/7360 + - uses: actions/checkout@v3 + with: + repository: "phadej/changelog-d" + path: "changelog-d" + - name: Install changelog-d + run: | + pushd changelog-d + cabal v2-install + popd + - uses: actions/checkout@v3 + - name: Run changelog-d + run: | + changelog-d changelog.d diff --git a/cabal/.github/workflows/linux.yml b/cabal/.github/workflows/linux.yml deleted file mode 100644 --- a/cabal/.github/workflows/linux.yml +++ /dev/null @@ -1,497 +0,0 @@ -# This file is auto-generated -# -# To regenerate it run -# -# make github-actions -# -name: Linux -on: - push: - branches: - - master - - "3.2" - pull_request: - branches: - - master - release: - types: - - created - -jobs: - validate-8_10_1: - name: validate.sh ghc-8.10.1 - runs-on: ubuntu-18.04 - needs: validate-8_8_3 - container: - image: phadej/ghc:8.10.1-bionic - steps: - - name: System info - run: | - uname -a - # https://help.github.com/en/actions/automating-your-workflow-with-github-actions/development-tools-for-github-actions#add-a-system-path-add-path - - name: Set PATH - run: | - echo "::add-path::$HOME/.cabal/bin" - - name: Install cabal-plan - run: | - mkdir -p $HOME/.cabal/bin - curl -sL https://github.com/haskell-hvr/cabal-plan/releases/download/v0.6.2.0/cabal-plan-0.6.2.0-x86_64-linux.xz > cabal-plan.xz - echo "de73600b1836d3f55e32d80385acc055fd97f60eaa0ab68a755302685f5d81bc cabal-plan.xz" | sha256sum -c - - xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan - rm -f cabal-plan.xz - chmod a+x $HOME/.cabal/bin/cabal-plan - - name: Update Hackage index - run: cabal v2-update - # https://github.com/actions/checkout/issues/170 - # - uses: actions/checkout@v2 - - name: Checkout - run: | - echo $GITHUB_REF $GITHUB_SHA - git clone --depth 1 https://github.com/$GITHUB_REPOSITORY.git . - git fetch origin $GITHUB_SHA:temporary-ci-branch - git checkout $GITHUB_SHA || (git fetch && git checkout $GITHUB_SHA) - - name: Validate print-config - run: sh validate.sh -j 2 -w ghc-8.10.1 -v -s print-config - - name: Validate print-tool-versions - run: sh validate.sh -j 2 -w ghc-8.10.1 -v -s print-tool-versions - - name: Validate make-cabal-install-dev - run: sh validate.sh -j 2 -w ghc-8.10.1 -v -s make-cabal-install-dev - - name: Validate build - run: sh validate.sh -j 2 -w ghc-8.10.1 -v -s build - - name: Validate lib-tests - run: sh validate.sh -j 2 -w ghc-8.10.1 -v -s lib-tests - - name: Validate lib-suite - run: sh validate.sh -j 2 -w ghc-8.10.1 -v -s lib-suite - - name: Validate cli-tests - run: sh validate.sh -j 2 -w ghc-8.10.1 -v -s cli-tests - - name: Validate cli-suite - run: sh validate.sh -j 2 -w ghc-8.10.1 -v -s cli-suite - validate-8_8_3: - name: validate.sh ghc-8.8.3 - runs-on: ubuntu-18.04 - container: - image: phadej/ghc:8.8.3-bionic - steps: - - name: System info - run: | - uname -a - # https://help.github.com/en/actions/automating-your-workflow-with-github-actions/development-tools-for-github-actions#add-a-system-path-add-path - - name: Set PATH - run: | - echo "::add-path::$HOME/.cabal/bin" - - name: Install cabal-plan - run: | - mkdir -p $HOME/.cabal/bin - curl -sL https://github.com/haskell-hvr/cabal-plan/releases/download/v0.6.2.0/cabal-plan-0.6.2.0-x86_64-linux.xz > cabal-plan.xz - echo "de73600b1836d3f55e32d80385acc055fd97f60eaa0ab68a755302685f5d81bc cabal-plan.xz" | sha256sum -c - - xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan - rm -f cabal-plan.xz - chmod a+x $HOME/.cabal/bin/cabal-plan - - name: Update Hackage index - run: cabal v2-update - # https://github.com/actions/checkout/issues/170 - # - uses: actions/checkout@v2 - - name: Checkout - run: | - echo $GITHUB_REF $GITHUB_SHA - git clone --depth 1 https://github.com/$GITHUB_REPOSITORY.git . - git fetch origin $GITHUB_SHA:temporary-ci-branch - git checkout $GITHUB_SHA || (git fetch && git checkout $GITHUB_SHA) - - name: Validate print-config - run: sh validate.sh -j 2 -w ghc-8.8.3 -v --solver-benchmarks -s print-config - - name: Validate print-tool-versions - run: sh validate.sh -j 2 -w ghc-8.8.3 -v --solver-benchmarks -s print-tool-versions - - name: Validate make-cabal-install-dev - run: sh validate.sh -j 2 -w ghc-8.8.3 -v --solver-benchmarks -s make-cabal-install-dev - - name: Validate build - run: sh validate.sh -j 2 -w ghc-8.8.3 -v --solver-benchmarks -s build - - name: Validate lib-tests - run: sh validate.sh -j 2 -w ghc-8.8.3 -v --solver-benchmarks -s lib-tests - - name: Validate lib-suite - run: sh validate.sh -j 2 -w ghc-8.8.3 -v --solver-benchmarks -s lib-suite - - name: Validate cli-tests - run: sh validate.sh -j 2 -w ghc-8.8.3 -v --solver-benchmarks -s cli-tests - - name: Validate cli-suite - run: sh validate.sh -j 2 -w ghc-8.8.3 -v --solver-benchmarks -s cli-suite - validate-8_6_5: - name: validate.sh ghc-8.6.5 - runs-on: ubuntu-18.04 - needs: validate-8_8_3 - container: - image: phadej/ghc:8.6.5-bionic - steps: - - name: System info - run: | - uname -a - # https://help.github.com/en/actions/automating-your-workflow-with-github-actions/development-tools-for-github-actions#add-a-system-path-add-path - - name: Set PATH - run: | - echo "::add-path::$HOME/.cabal/bin" - - name: Install cabal-plan - run: | - mkdir -p $HOME/.cabal/bin - curl -sL https://github.com/haskell-hvr/cabal-plan/releases/download/v0.6.2.0/cabal-plan-0.6.2.0-x86_64-linux.xz > cabal-plan.xz - echo "de73600b1836d3f55e32d80385acc055fd97f60eaa0ab68a755302685f5d81bc cabal-plan.xz" | sha256sum -c - - xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan - rm -f cabal-plan.xz - chmod a+x $HOME/.cabal/bin/cabal-plan - - name: Update Hackage index - run: cabal v2-update - # https://github.com/actions/checkout/issues/170 - # - uses: actions/checkout@v2 - - name: Checkout - run: | - echo $GITHUB_REF $GITHUB_SHA - git clone --depth 1 https://github.com/$GITHUB_REPOSITORY.git . - git fetch origin $GITHUB_SHA:temporary-ci-branch - git checkout $GITHUB_SHA || (git fetch && git checkout $GITHUB_SHA) - - name: Validate print-config - run: sh validate.sh -j 2 -w ghc-8.6.5 -v --complete-hackage-tests -s print-config - - name: Validate print-tool-versions - run: sh validate.sh -j 2 -w ghc-8.6.5 -v --complete-hackage-tests -s print-tool-versions - - name: Validate make-cabal-install-dev - run: sh validate.sh -j 2 -w ghc-8.6.5 -v --complete-hackage-tests -s make-cabal-install-dev - - name: Validate build - run: sh validate.sh -j 2 -w ghc-8.6.5 -v --complete-hackage-tests -s build - - name: Validate lib-tests - run: sh validate.sh -j 2 -w ghc-8.6.5 -v --complete-hackage-tests -s lib-tests - - name: Validate lib-suite - run: sh validate.sh -j 2 -w ghc-8.6.5 -v --complete-hackage-tests -s lib-suite - - name: Validate cli-tests - run: sh validate.sh -j 2 -w ghc-8.6.5 -v --complete-hackage-tests -s cli-tests - - name: Validate cli-suite - run: sh validate.sh -j 2 -w ghc-8.6.5 -v --complete-hackage-tests -s cli-suite - validate-8_4_4: - name: validate.sh ghc-8.4.4 - runs-on: ubuntu-18.04 - needs: validate-8_8_3 - container: - image: phadej/ghc:8.4.4-bionic - steps: - - name: System info - run: | - uname -a - # https://help.github.com/en/actions/automating-your-workflow-with-github-actions/development-tools-for-github-actions#add-a-system-path-add-path - - name: Set PATH - run: | - echo "::add-path::$HOME/.cabal/bin" - - name: Install cabal-plan - run: | - mkdir -p $HOME/.cabal/bin - curl -sL https://github.com/haskell-hvr/cabal-plan/releases/download/v0.6.2.0/cabal-plan-0.6.2.0-x86_64-linux.xz > cabal-plan.xz - echo "de73600b1836d3f55e32d80385acc055fd97f60eaa0ab68a755302685f5d81bc cabal-plan.xz" | sha256sum -c - - xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan - rm -f cabal-plan.xz - chmod a+x $HOME/.cabal/bin/cabal-plan - - name: Update Hackage index - run: cabal v2-update - # https://github.com/actions/checkout/issues/170 - # - uses: actions/checkout@v2 - - name: Checkout - run: | - echo $GITHUB_REF $GITHUB_SHA - git clone --depth 1 https://github.com/$GITHUB_REPOSITORY.git . - git fetch origin $GITHUB_SHA:temporary-ci-branch - git checkout $GITHUB_SHA || (git fetch && git checkout $GITHUB_SHA) - - name: Validate print-config - run: sh validate.sh -j 2 -w ghc-8.4.4 -v -s print-config - - name: Validate print-tool-versions - run: sh validate.sh -j 2 -w ghc-8.4.4 -v -s print-tool-versions - - name: Validate make-cabal-install-dev - run: sh validate.sh -j 2 -w ghc-8.4.4 -v -s make-cabal-install-dev - - name: Validate build - run: sh validate.sh -j 2 -w ghc-8.4.4 -v -s build - - name: Validate lib-tests - run: sh validate.sh -j 2 -w ghc-8.4.4 -v -s lib-tests - - name: Validate lib-suite - run: sh validate.sh -j 2 -w ghc-8.4.4 -v -s lib-suite - - name: Validate cli-tests - run: sh validate.sh -j 2 -w ghc-8.4.4 -v -s cli-tests - - name: Validate cli-suite - run: sh validate.sh -j 2 -w ghc-8.4.4 -v -s cli-suite - validate-8_2_2: - name: validate.sh ghc-8.2.2 - runs-on: ubuntu-18.04 - needs: validate-8_8_3 - container: - image: phadej/ghc:8.2.2-bionic - steps: - - name: System info - run: | - uname -a - # https://help.github.com/en/actions/automating-your-workflow-with-github-actions/development-tools-for-github-actions#add-a-system-path-add-path - - name: Set PATH - run: | - echo "::add-path::$HOME/.cabal/bin" - - name: Install cabal-plan - run: | - mkdir -p $HOME/.cabal/bin - curl -sL https://github.com/haskell-hvr/cabal-plan/releases/download/v0.6.2.0/cabal-plan-0.6.2.0-x86_64-linux.xz > cabal-plan.xz - echo "de73600b1836d3f55e32d80385acc055fd97f60eaa0ab68a755302685f5d81bc cabal-plan.xz" | sha256sum -c - - xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan - rm -f cabal-plan.xz - chmod a+x $HOME/.cabal/bin/cabal-plan - - name: Update Hackage index - run: cabal v2-update - # https://github.com/actions/checkout/issues/170 - # - uses: actions/checkout@v2 - - name: Checkout - run: | - echo $GITHUB_REF $GITHUB_SHA - git clone --depth 1 https://github.com/$GITHUB_REPOSITORY.git . - git fetch origin $GITHUB_SHA:temporary-ci-branch - git checkout $GITHUB_SHA || (git fetch && git checkout $GITHUB_SHA) - - name: Validate print-config - run: sh validate.sh -j 2 -w ghc-8.2.2 -v -s print-config - - name: Validate print-tool-versions - run: sh validate.sh -j 2 -w ghc-8.2.2 -v -s print-tool-versions - - name: Validate make-cabal-install-dev - run: sh validate.sh -j 2 -w ghc-8.2.2 -v -s make-cabal-install-dev - - name: Validate build - run: sh validate.sh -j 2 -w ghc-8.2.2 -v -s build - - name: Validate lib-tests - run: sh validate.sh -j 2 -w ghc-8.2.2 -v -s lib-tests - - name: Validate lib-suite - run: sh validate.sh -j 2 -w ghc-8.2.2 -v -s lib-suite - - name: Validate cli-tests - run: sh validate.sh -j 2 -w ghc-8.2.2 -v -s cli-tests - - name: Validate cli-suite - run: sh validate.sh -j 2 -w ghc-8.2.2 -v -s cli-suite - validate-8_0_2: - name: validate.sh ghc-8.0.2 - runs-on: ubuntu-18.04 - needs: validate-8_8_3 - container: - image: phadej/ghc:8.0.2-bionic - steps: - - name: System info - run: | - uname -a - # https://help.github.com/en/actions/automating-your-workflow-with-github-actions/development-tools-for-github-actions#add-a-system-path-add-path - - name: Set PATH - run: | - echo "::add-path::$HOME/.cabal/bin" - - name: Install cabal-plan - run: | - mkdir -p $HOME/.cabal/bin - curl -sL https://github.com/haskell-hvr/cabal-plan/releases/download/v0.6.2.0/cabal-plan-0.6.2.0-x86_64-linux.xz > cabal-plan.xz - echo "de73600b1836d3f55e32d80385acc055fd97f60eaa0ab68a755302685f5d81bc cabal-plan.xz" | sha256sum -c - - xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan - rm -f cabal-plan.xz - chmod a+x $HOME/.cabal/bin/cabal-plan - - name: Update Hackage index - run: cabal v2-update - # https://github.com/actions/checkout/issues/170 - # - uses: actions/checkout@v2 - - name: Checkout - run: | - echo $GITHUB_REF $GITHUB_SHA - git clone --depth 1 https://github.com/$GITHUB_REPOSITORY.git . - git fetch origin $GITHUB_SHA:temporary-ci-branch - git checkout $GITHUB_SHA || (git fetch && git checkout $GITHUB_SHA) - - name: Validate print-config - run: sh validate.sh -j 2 -w ghc-8.0.2 -v -s print-config - - name: Validate print-tool-versions - run: sh validate.sh -j 2 -w ghc-8.0.2 -v -s print-tool-versions - - name: Validate make-cabal-install-dev - run: sh validate.sh -j 2 -w ghc-8.0.2 -v -s make-cabal-install-dev - - name: Validate build - run: sh validate.sh -j 2 -w ghc-8.0.2 -v -s build - - name: Validate lib-tests - run: sh validate.sh -j 2 -w ghc-8.0.2 -v -s lib-tests - - name: Validate lib-suite - run: sh validate.sh -j 2 -w ghc-8.0.2 -v -s lib-suite - - name: Validate cli-tests - run: sh validate.sh -j 2 -w ghc-8.0.2 -v -s cli-tests - - name: Validate cli-suite - run: sh validate.sh -j 2 -w ghc-8.0.2 -v -s cli-suite - validate-7_10_3: - name: validate.sh ghc-7.10.3 - runs-on: ubuntu-18.04 - needs: validate-8_8_3 - container: - image: phadej/ghc:7.10.3-bionic - steps: - - name: System info - run: | - uname -a - # https://help.github.com/en/actions/automating-your-workflow-with-github-actions/development-tools-for-github-actions#add-a-system-path-add-path - - name: Set PATH - run: | - echo "::add-path::$HOME/.cabal/bin" - - name: Install cabal-plan - run: | - mkdir -p $HOME/.cabal/bin - curl -sL https://github.com/haskell-hvr/cabal-plan/releases/download/v0.6.2.0/cabal-plan-0.6.2.0-x86_64-linux.xz > cabal-plan.xz - echo "de73600b1836d3f55e32d80385acc055fd97f60eaa0ab68a755302685f5d81bc cabal-plan.xz" | sha256sum -c - - xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan - rm -f cabal-plan.xz - chmod a+x $HOME/.cabal/bin/cabal-plan - - name: Update Hackage index - run: cabal v2-update - # https://github.com/actions/checkout/issues/170 - # - uses: actions/checkout@v2 - - name: Checkout - run: | - echo $GITHUB_REF $GITHUB_SHA - git clone --depth 1 https://github.com/$GITHUB_REPOSITORY.git . - git fetch origin $GITHUB_SHA:temporary-ci-branch - git checkout $GITHUB_SHA || (git fetch && git checkout $GITHUB_SHA) - - name: Validate print-config - run: sh validate.sh -j 2 -w ghc-7.10.3 -v -s print-config - - name: Validate print-tool-versions - run: sh validate.sh -j 2 -w ghc-7.10.3 -v -s print-tool-versions - - name: Validate make-cabal-install-dev - run: sh validate.sh -j 2 -w ghc-7.10.3 -v -s make-cabal-install-dev - - name: Validate build - run: sh validate.sh -j 2 -w ghc-7.10.3 -v -s build - - name: Validate lib-tests - run: sh validate.sh -j 2 -w ghc-7.10.3 -v -s lib-tests - - name: Validate lib-suite - run: sh validate.sh -j 2 -w ghc-7.10.3 -v -s lib-suite - - name: Validate cli-tests - run: sh validate.sh -j 2 -w ghc-7.10.3 -v -s cli-tests - - name: Validate cli-suite - run: sh validate.sh -j 2 -w ghc-7.10.3 -v -s cli-suite - validate-7_8_4: - name: validate.sh ghc-7.8.4 - runs-on: ubuntu-18.04 - needs: validate-8_8_3 - container: - image: phadej/ghc:7.8.4-bionic - steps: - - name: System info - run: | - uname -a - # https://help.github.com/en/actions/automating-your-workflow-with-github-actions/development-tools-for-github-actions#add-a-system-path-add-path - - name: Set PATH - run: | - echo "::add-path::$HOME/.cabal/bin" - - name: Install cabal-plan - run: | - mkdir -p $HOME/.cabal/bin - curl -sL https://github.com/haskell-hvr/cabal-plan/releases/download/v0.6.2.0/cabal-plan-0.6.2.0-x86_64-linux.xz > cabal-plan.xz - echo "de73600b1836d3f55e32d80385acc055fd97f60eaa0ab68a755302685f5d81bc cabal-plan.xz" | sha256sum -c - - xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan - rm -f cabal-plan.xz - chmod a+x $HOME/.cabal/bin/cabal-plan - - name: Update Hackage index - run: cabal v2-update - # https://github.com/actions/checkout/issues/170 - # - uses: actions/checkout@v2 - - name: Checkout - run: | - echo $GITHUB_REF $GITHUB_SHA - git clone --depth 1 https://github.com/$GITHUB_REPOSITORY.git . - git fetch origin $GITHUB_SHA:temporary-ci-branch - git checkout $GITHUB_SHA || (git fetch && git checkout $GITHUB_SHA) - - name: Validate print-config - run: sh validate.sh -j 2 -w ghc-7.8.4 -v --lib-only -s print-config - - name: Validate print-tool-versions - run: sh validate.sh -j 2 -w ghc-7.8.4 -v --lib-only -s print-tool-versions - - name: Validate build - run: sh validate.sh -j 2 -w ghc-7.8.4 -v --lib-only -s build - - name: Validate lib-tests - run: sh validate.sh -j 2 -w ghc-7.8.4 -v --lib-only -s lib-tests - - name: Validate lib-suite - run: sh validate.sh -j 2 -w ghc-7.8.4 -v --lib-only -s lib-suite - validate-7_6_3: - name: validate.sh ghc-7.6.3 - runs-on: ubuntu-18.04 - needs: validate-8_8_3 - container: - image: phadej/ghc:7.6.3-xenial - steps: - - name: System info - run: | - uname -a - # https://help.github.com/en/actions/automating-your-workflow-with-github-actions/development-tools-for-github-actions#add-a-system-path-add-path - - name: Set PATH - run: | - echo "::add-path::$HOME/.cabal/bin" - - name: Install cabal-plan - run: | - mkdir -p $HOME/.cabal/bin - curl -sL https://github.com/haskell-hvr/cabal-plan/releases/download/v0.6.2.0/cabal-plan-0.6.2.0-x86_64-linux.xz > cabal-plan.xz - echo "de73600b1836d3f55e32d80385acc055fd97f60eaa0ab68a755302685f5d81bc cabal-plan.xz" | sha256sum -c - - xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan - rm -f cabal-plan.xz - chmod a+x $HOME/.cabal/bin/cabal-plan - - name: apt-get update - run: apt-get update - - name: Install dynamic libraries - run: apt-get install -y ghc-7.6.3-dyn - - name: Update Hackage index - run: cabal v2-update - # https://github.com/actions/checkout/issues/170 - # - uses: actions/checkout@v2 - - name: Checkout - run: | - echo $GITHUB_REF $GITHUB_SHA - git clone --depth 1 https://github.com/$GITHUB_REPOSITORY.git . - git fetch origin $GITHUB_SHA:temporary-ci-branch - git checkout $GITHUB_SHA || (git fetch && git checkout $GITHUB_SHA) - - name: Validate print-config - run: sh validate.sh -j 2 -w ghc-7.6.3 -v --lib-only -s print-config - - name: Validate print-tool-versions - run: sh validate.sh -j 2 -w ghc-7.6.3 -v --lib-only -s print-tool-versions - - name: Validate build - run: sh validate.sh -j 2 -w ghc-7.6.3 -v --lib-only -s build - - name: Validate lib-tests - run: sh validate.sh -j 2 -w ghc-7.6.3 -v --lib-only -s lib-tests - - name: Validate lib-suite - run: sh validate.sh -j 2 -w ghc-7.6.3 -v --lib-only -s lib-suite - validate-8_8_3-old: - name: validate.sh old GHCs - runs-on: ubuntu-18.04 - needs: validate-8_8_3 - container: - image: phadej/ghc:8.8.3-xenial - steps: - - name: System info - run: | - uname -a - # https://help.github.com/en/actions/automating-your-workflow-with-github-actions/development-tools-for-github-actions#add-a-system-path-add-path - - name: Set PATH - run: | - echo "::add-path::$HOME/.cabal/bin" - - name: Install cabal-plan - run: | - mkdir -p $HOME/.cabal/bin - curl -sL https://github.com/haskell-hvr/cabal-plan/releases/download/v0.6.2.0/cabal-plan-0.6.2.0-x86_64-linux.xz > cabal-plan.xz - echo "de73600b1836d3f55e32d80385acc055fd97f60eaa0ab68a755302685f5d81bc cabal-plan.xz" | sha256sum -c - - xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan - rm -f cabal-plan.xz - chmod a+x $HOME/.cabal/bin/cabal-plan - - name: apt-get update - run: apt-get update - - name: Install dynamic libraries - run: apt-get install -y ghc-8.8.3-dyn - - name: Install extra compilers - run: apt-get install -y ghc-7.0.4-dyn ghc-7.2.2-dyn ghc-7.4.2-dyn - - name: Update Hackage index - run: cabal v2-update - # https://github.com/actions/checkout/issues/170 - # - uses: actions/checkout@v2 - - name: Checkout - run: | - echo $GITHUB_REF $GITHUB_SHA - git clone --depth 1 https://github.com/$GITHUB_REPOSITORY.git . - git fetch origin $GITHUB_SHA:temporary-ci-branch - git checkout $GITHUB_SHA || (git fetch && git checkout $GITHUB_SHA) - - name: Validate print-config - run: sh validate.sh -j 2 -w ghc-8.8.3 -v --lib-only -s print-config - - name: Validate print-tool-versions - run: sh validate.sh -j 2 -w ghc-8.8.3 -v --lib-only -s print-tool-versions - - name: Validate build - run: sh validate.sh -j 2 -w ghc-8.8.3 -v --lib-only -s build - - name: Validate lib-tests - run: sh validate.sh -j 2 -w ghc-8.8.3 -v --lib-only -s lib-tests - - name: Validate lib-suite - run: sh validate.sh -j 2 -w ghc-8.8.3 -v --lib-only -s lib-suite - - name: Validate lib-suite-extras --extra-hc /opt/ghc/7.0.4/bin/ghc-7.0.4 - run: sh validate.sh -j 2 -w ghc-8.8.3 -v --lib-only -s lib-suite-extras --extra-hc /opt/ghc/7.0.4/bin/ghc-7.0.4 - - name: Validate lib-suite-extras --extra-hc /opt/ghc/7.2.2/bin/ghc-7.2.2 - run: sh validate.sh -j 2 -w ghc-8.8.3 -v --lib-only -s lib-suite-extras --extra-hc /opt/ghc/7.2.2/bin/ghc-7.2.2 - - name: Validate lib-suite-extras --extra-hc /opt/ghc/7.4.2/bin/ghc-7.4.2 - run: sh validate.sh -j 2 -w ghc-8.8.3 -v --lib-only -s lib-suite-extras --extra-hc /opt/ghc/7.4.2/bin/ghc-7.4.2 diff --git a/cabal/.github/workflows/macos.yml b/cabal/.github/workflows/macos.yml deleted file mode 100644 --- a/cabal/.github/workflows/macos.yml +++ /dev/null @@ -1,129 +0,0 @@ -# This file is auto-generated -# -# To regenerate it run -# -# make github-actions -# -name: MacOS -on: - push: - branches: - - master - - "3.2" - pull_request: - branches: - - master - release: - types: - - created - -jobs: - validate-macos-8_8_3: - name: validate.sh macos ghc-8.8.3 - runs-on: macos-latest - steps: - - name: System info - run: | - uname -a - - name: Install Autotools - run: | - brew install automake - - name: Install GHC - run: | - cd $(mktemp -d) - curl -sLO https://downloads.haskell.org/~ghc/8.8.3/ghc-8.8.3-x86_64-apple-darwin.tar.xz - tar -xJf ghc-*.tar.xz - cd ghc-* - ./configure --prefix=/opt/ghc/8.8.3 - sudo make install - - name: Install Cabal - run: | - cd $(mktemp -d) - curl -sLO https://downloads.haskell.org/~cabal/cabal-install-3.0.0.0/cabal-install-3.0.0.0-x86_64-apple-darwin17.7.0.tar.xz - tar -xJf cabal-install-*.tar.xz - sudo mkdir -p /opt/cabal/3.0/bin - sudo cp cabal /opt/cabal/3.0/bin/cabal - sudo chmod 755 /opt/cabal/3.0/bin/cabal - - name: Set PATH - run: | - echo "::add-path::/opt/ghc/8.8.3/bin" - echo "::add-path::/opt/cabal/3.0/bin" - echo "::add-path::$HOME/.cabal/bin" - - name: Update Hackage index - run: cabal v2-update - - name: Install cabal-plan - run: | - cd $(mktemp -d) - cabal v2-install cabal-plan --constraint='cabal-plan ^>=0.6.2.0' --constraint='aeson +fast' - - uses: actions/checkout@v2 - - name: Validate print-config - run: sh validate.sh -j 2 -w ghc-8.8.3 -v -s print-config - - name: Validate print-tool-versions - run: sh validate.sh -j 2 -w ghc-8.8.3 -v -s print-tool-versions - - name: Validate make-cabal-install-dev - run: sh validate.sh -j 2 -w ghc-8.8.3 -v -s make-cabal-install-dev - - name: Validate build - run: sh validate.sh -j 2 -w ghc-8.8.3 -v -s build - - name: Validate lib-tests - run: sh validate.sh -j 2 -w ghc-8.8.3 -v -s lib-tests - - name: Validate lib-suite - run: sh validate.sh -j 2 -w ghc-8.8.3 -v -s lib-suite - - name: Validate cli-tests - run: sh validate.sh -j 2 -w ghc-8.8.3 -v -s cli-tests - - name: Validate cli-suite - run: sh validate.sh -j 2 -w ghc-8.8.3 -v -s cli-suite - validate-macos-8_6_5: - name: validate.sh macos ghc-8.6.5 - runs-on: macos-latest - needs: validate-macos-8_8_3 - steps: - - name: System info - run: | - uname -a - - name: Install Autotools - run: | - brew install automake - - name: Install GHC - run: | - cd $(mktemp -d) - curl -sLO https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-apple-darwin.tar.xz - tar -xJf ghc-*.tar.xz - cd ghc-* - ./configure --prefix=/opt/ghc/8.6.5 - sudo make install - - name: Install Cabal - run: | - cd $(mktemp -d) - curl -sLO https://downloads.haskell.org/~cabal/cabal-install-3.0.0.0/cabal-install-3.0.0.0-x86_64-apple-darwin17.7.0.tar.xz - tar -xJf cabal-install-*.tar.xz - sudo mkdir -p /opt/cabal/3.0/bin - sudo cp cabal /opt/cabal/3.0/bin/cabal - sudo chmod 755 /opt/cabal/3.0/bin/cabal - - name: Set PATH - run: | - echo "::add-path::/opt/ghc/8.6.5/bin" - echo "::add-path::/opt/cabal/3.0/bin" - echo "::add-path::$HOME/.cabal/bin" - - name: Update Hackage index - run: cabal v2-update - - name: Install cabal-plan - run: | - cd $(mktemp -d) - cabal v2-install cabal-plan --constraint='cabal-plan ^>=0.6.2.0' --constraint='aeson +fast' - - uses: actions/checkout@v2 - - name: Validate print-config - run: sh validate.sh -j 2 -w ghc-8.6.5 -v -s print-config - - name: Validate print-tool-versions - run: sh validate.sh -j 2 -w ghc-8.6.5 -v -s print-tool-versions - - name: Validate make-cabal-install-dev - run: sh validate.sh -j 2 -w ghc-8.6.5 -v -s make-cabal-install-dev - - name: Validate build - run: sh validate.sh -j 2 -w ghc-8.6.5 -v -s build - - name: Validate lib-tests - run: sh validate.sh -j 2 -w ghc-8.6.5 -v -s lib-tests - - name: Validate lib-suite - run: sh validate.sh -j 2 -w ghc-8.6.5 -v -s lib-suite - - name: Validate cli-tests - run: sh validate.sh -j 2 -w ghc-8.6.5 -v -s cli-tests - - name: Validate cli-suite - run: sh validate.sh -j 2 -w ghc-8.6.5 -v -s cli-suite diff --git a/cabal/.github/workflows/quick-jobs.yml b/cabal/.github/workflows/quick-jobs.yml --- a/cabal/.github/workflows/quick-jobs.yml +++ b/cabal/.github/workflows/quick-jobs.yml @@ -1,18 +1,15 @@ -# This file is auto-generated -# -# To regenerate it run -# -# make github-actions -# name: Quick jobs + +# See: https://docs.github.com/en/actions/reference/workflow-syntax-for-github-actions#concurrency. +concurrency: + group: ${{ github.ref }}-${{ github.workflow }} + cancel-in-progress: true + on: push: branches: - master - - "3.2" pull_request: - branches: - - master release: types: - created @@ -20,44 +17,43 @@ jobs: meta: name: Meta checks - runs-on: ubuntu-18.04 + runs-on: ubuntu-latest # This job is not run in a container, any recent GHC should be fine steps: - name: Set PATH + # https://docs.github.com/en/free-pro-team@latest/actions/reference/workflow-commands-for-github-actions#adding-a-system-path run: | - echo "::add-path::$HOME/.cabal/bin" - echo "::add-path::/opt/cabal/3.2/bin" - echo "::add-path::/opt/ghc/8.6.5/bin" + echo "$HOME/.cabal/bin" >> $GITHUB_PATH - uses: actions/cache@v1 with: path: ~/.cabal/store key: linux-store-meta + - name: ghcup + run: | + ghcup config set cache true + ghcup install ghc recommended + ghcup set ghc recommended - name: Update Hackage index run: cabal v2-update - name: Install alex - run: cabal v2-install alex + run: cabal v2-install alex --constraint='alex ==3.2.6' - uses: actions/checkout@v2 - name: Regenerate files run: | - make lexer - make gen-extra-source-files - make spdx - make templates - make github-actions - make cabal-install-cabal + make -B lexer + make -B spdx + make -B templates - name: Check that diff is clean run: | git status > /dev/null git diff-files -p --exit-code doctest: name: Doctest Cabal - runs-on: ubuntu-18.04 + runs-on: ubuntu-latest steps: - name: Set PATH run: | - echo "::add-path::$HOME/.cabal/bin" - echo "::add-path::/opt/cabal/3.2/bin" - echo "::add-path::/opt/ghc/8.6.5/bin" + echo "$HOME/.cabal/bin" >> $GITHUB_PATH - name: Install cabal-env run: | mkdir -p $HOME/.cabal/bin @@ -70,6 +66,11 @@ with: path: ~/.cabal/store key: linux-store-doctest + - name: ghcup + run: | + ghcup config set cache true + ghcup install ghc 8.10.7 + ghcup set ghc 8.10.7 - name: Update Hackage index run: cabal v2-update - name: Install doctest diff --git a/cabal/.github/workflows/users-guide.yml b/cabal/.github/workflows/users-guide.yml new file mode 100644 --- /dev/null +++ b/cabal/.github/workflows/users-guide.yml @@ -0,0 +1,79 @@ +# Adapted from agda/agda/.github/workflows/user-manual.yml by Andreas, 2021-09-11 + +name: Assorted + +# See: https://docs.github.com/en/actions/reference/workflow-syntax-for-github-actions#concurrency. +concurrency: + group: ${{ github.ref }}-${{ github.workflow }} + cancel-in-progress: true + +on: + push: + branches: + - master + paths: + - 'doc/Makefile' + - 'doc/pyproject.toml' + - 'doc/requirements.in' + - 'doc/requirements.txt' + - 'doc/*.inc' + - 'doc/*.py' + - 'doc/*.rst' + - 'doc/**/*.json' + - '.github/workflows/users-guide.yml' + pull_request: + paths: + - 'doc/Makefile' + - 'doc/pyproject.toml' + - 'doc/requirements.in' + - 'doc/requirements.txt' + - 'doc/*.inc' + - 'doc/*.py' + - 'doc/*.rst' + - 'doc/**/*.json' + - '.github/workflows/users-guide.yml' + release: + types: + - created + +defaults: + run: + shell: bash + +jobs: + build: + name: Users guide + runs-on: ubuntu-latest + strategy: + matrix: + python-version: [3.7] + + steps: + - uses: actions/checkout@v2 + with: + submodules: recursive + + - name: Set up Python ${{ matrix.python-version }} + uses: actions/setup-python@v2 + with: + python-version: ${{ matrix.python-version }} + + # Subsumed by make users-guide + # - name: Install dependencies + # run: | + # pip install -r doc/requirements.txt + + - name: Build User's Guide in HTML + run: | + make SPHINX_HTML_OUTDIR=html users-guide + + - uses: actions/upload-artifact@v2 + with: + name: users-guide-html + path: html/ + + - name: Check security of requirements.txt + env: + SKJOLD_GITHUB_API_TOKEN: ${{ secrets.GITHUB_TOKEN }} + run: | + make -C doc check-requirements diff --git a/cabal/.github/workflows/validate.yml b/cabal/.github/workflows/validate.yml new file mode 100644 --- /dev/null +++ b/cabal/.github/workflows/validate.yml @@ -0,0 +1,297 @@ +name: Validate + +# We use bash as default even in windows +# to try keep the workflow as uniform as possible +defaults: + run: + shell: bash + +# See: https://docs.github.com/en/actions/reference/workflow-syntax-for-github-actions#concurrency. +concurrency: + group: ${{ github.ref }}-${{ github.workflow }} + cancel-in-progress: true + +on: + push: + branches: + - master + pull_request: + release: + types: + - created + +env: + # We choose a stable ghc version across all os's + # which will be used to do the next release + GHC_FOR_RELEASE: '9.2.3' + # Ideally we should use the version about to be released for hackage tests and benchmarks + GHC_FOR_SOLVER_BENCHMARKS: '9.2.3' + GHC_FOR_COMPLETE_HACKAGE_TESTS: '9.2.3' + COMMON_FLAGS: '-j 2 -v' + +jobs: + validate: + name: Validate ${{ matrix.os }} ghc-${{ matrix.ghc }} + runs-on: ${{ matrix.os }} + outputs: + GHC_FOR_RELEASE: ${{ format('["{0}"]', env.GHC_FOR_RELEASE) }} + strategy: + matrix: + os: ["ubuntu-latest", "macos-latest", "windows-latest"] + ghc: ["9.2.3", "9.0.2", "8.10.7", "8.8.4", "8.6.5", "8.4.4"] + exclude: + # corrupts GHA cache or the fabric of reality itself, see https://github.com/haskell/cabal/issues/8356 + - os: "windows-latest" + ghc: "8.10.7" + # lot of segfaults caused by ghc bugs + - os: "windows-latest" + ghc: "8.8.4" + - os: "windows-latest" + ghc: "8.4.4" + + steps: + + - uses: actions/checkout@v2 + + - uses: haskell/actions/setup@v1 + id: setup-haskell + with: + ghc-version: ${{ matrix.ghc }} + cabal-version: latest # default, keeping for visibility + + # See the following link for a breakdown of the following step + # https://github.com/haskell/actions/issues/7#issuecomment-745697160 + - uses: actions/cache@v2 + with: + # validate.sh uses a special build dir + path: | + ${{ steps.setup-haskell.outputs.cabal-store }} + dist-* + key: ${{ runner.os }}-${{ matrix.ghc }}-20220419-${{ github.sha }} + restore-keys: ${{ runner.os }}-${{ matrix.ghc }}-20220419- + + - name: Work around git problem https://bugs.launchpad.net/ubuntu/+source/git/+bug/1993586 (cabal PR #8546) + run: | + git config --global protocol.file.allow always + + # The '+exe' constraint below is important, otherwise cabal-install + # might decide to build the library but not the executable which is + # what we need. + - name: Install cabal-plan + run: | + cd $(mktemp -d) + cabal install cabal-plan --constraint='cabal-plan +exe' + echo "$HOME/.cabal/bin" >> $GITHUB_PATH + + # The tool is not essential to the rest of the test suite. If + # hackage-repo-tool is not present, any test that requires it will + # be skipped. + # We want to keep this in the loop but we don't want to fail if + # hackage-repo-tool breaks or fails to support a newer GHC version. + - name: Install hackage-repo-tool + continue-on-error: true + run: | + cd $(mktemp -d) + cabal install hackage-repo-tool + + # Needed by cabal-testsuite/PackageTests/Configure/setup.test.hs + - name: Install Autotools + if: runner.os == 'macOS' + run: | + brew install automake + + - name: Set validate inputs + run: | + FLAGS="${{ env.COMMON_FLAGS }}" + if [[ "${{ matrix.cli }}" == "false" ]]; then + FLAGS="$FLAGS --lib-only" + fi + if [[ ${{ matrix.ghc }} == ${{ env.GHC_FOR_SOLVER_BENCHMARKS }} ]]; then + FLAGS="$FLAGS --solver-benchmarks" + fi + if [[ ${{ matrix.ghc }} == ${{ env.GHC_FOR_COMPLETE_HACKAGE_TESTS }} ]]; then + FLAGS="$FLAGS --complete-hackage-tests" + fi + echo "FLAGS=$FLAGS" >> $GITHUB_ENV + + - name: Validate print-config + run: sh validate.sh $FLAGS -s print-config + + - name: Validate print-tool-versions + run: sh validate.sh $FLAGS -s print-tool-versions + + - name: Validate build + run: sh validate.sh $FLAGS -s build + + - name: Tar cabal head executable + if: matrix.cli != 'false' && matrix.ghc == env.GHC_FOR_RELEASE + run: | + CABAL_EXEC=$(cabal-plan list-bin --builddir=dist-newstyle-validate-ghc-${{ matrix.ghc }} cabal-install:exe:cabal) + # We have to tar the executable to preserve executable permissions + # see https://github.com/actions/upload-artifact/issues/38 + if [[ ${{ runner.os }} == 'Windows' ]]; then + # `cabal-plan` gives us a windows path but tar needs the posix one + CABAL_EXEC=$(cygpath $CABAL_EXEC) + fi + if [[ "${{ runner.os }}" == "macOS" ]]; then + # Workaround to avoid bsdtar corrupts the executable + # so executing it after untar throws `cannot execute binary file` + # see https://github.com/actions/virtual-environments/issues/2619#issuecomment-788397841 + sudo /usr/sbin/purge + fi + tar -cvf cabal-head.tar -C $(dirname "$CABAL_EXEC") $(basename "$CABAL_EXEC") + echo "CABAL_EXEC_TAR=cabal-head.tar" >> $GITHUB_ENV + + # We upload the cabal executable built with the ghc used in the release for: + # - Reuse it in the dogfooding job (although we could use the cached build dir) + # - Make it available in the workflow to make easier testing it locally + - name: Upload cabal-install executable to workflow artifacts + if: matrix.cli != 'false' && matrix.ghc == env.GHC_FOR_RELEASE + uses: actions/upload-artifact@v2 + with: + name: cabal-${{ runner.os }}-${{ matrix.ghc }} + path: ${{ env.CABAL_EXEC_TAR }} + + - name: Validate lib-tests + env: + # `rawSystemStdInOut reports text decoding errors` + # test does not find ghc without the full path in windows + GHCPATH: ${{ steps.setup-haskell.outputs.ghc-exe }} + run: sh validate.sh $FLAGS -s lib-tests + + - name: Validate lib-suite + run: sh validate.sh $FLAGS -s lib-suite + + - name: Validate cli-tests + if: matrix.cli != 'false' + run: sh validate.sh $FLAGS -s cli-tests + + - name: Validate cli-suite + if: matrix.cli != 'false' + run: sh validate.sh $FLAGS -s cli-suite + + validate-old-ghcs: + name: Validate old ghcs ${{ matrix.extra-ghc }} + runs-on: ubuntu-latest + needs: validate + # This job needs an older ubuntu (16.04) cause + # the required old ghcs using the `-dyn` flavour + # are not installable from ppa/hvr in newer ones + # see https://github.com/haskell/cabal/issues/8011 + container: + image: phadej/ghc:8.8.4-xenial + + strategy: + matrix: + # Newer ghc versions than 8.8.4 have to be installed with ghcup cause + # they are not available in ppa/hvr. The ghcup installation + # needs `sudo` which is not available in the xenial container + ghc: ["8.8.4"] + extra-ghc: ["7.10.3", "7.8.4", "7.6.3", "7.4.2", "7.2.2", "7.0.4"] + + steps: + + # We can't use actions/checkout with the xenial docker container + # cause it does not work with the git version included in it, see: + # https://github.com/actions/checkout/issues/170 + # https://github.com/actions/checkout/issues/295 + # - uses: actions/checkout@v2 + - name: Checkout + run: | + echo $GITHUB_REF $GITHUB_SHA + git clone --depth 1 https://github.com/$GITHUB_REPOSITORY.git . + git fetch origin $GITHUB_SHA:temporary-ci-branch + git checkout $GITHUB_SHA || (git fetch && git checkout $GITHUB_SHA) + + - name: Install extra compiler + run: | + apt-get update + apt-get install -y ghc-${{ matrix.extra-ghc }}-dyn + + - uses: haskell/actions/setup@v1 + id: setup-haskell + with: + ghc-version: ${{ matrix.ghc }} + + # As we are reusing the cached build dir from the previous step + # the generated artifacts are available here, + # including the cabal executable and the test suite + - uses: actions/cache@v2 + with: + path: | + ${{ steps.setup-haskell.outputs.cabal-store }} + dist-* + key: ${{ runner.os }}-${{ matrix.ghc }}-20220419-${{ github.sha }} + restore-keys: ${{ runner.os }}-${{ matrix.ghc }}-20220419- + + - name: Install cabal-plan + run: | + cd $(mktemp -d) + cabal install cabal-plan --constraint='cabal-plan +exe' + echo "$HOME/.cabal/bin" >> $GITHUB_PATH + + - name: Validate build + run: sh validate.sh ${{ env.COMMON_FLAGS }} -s build + + - name: "Validate lib-suite-extras --extra-hc ghc-${{ matrix.extra-ghc }}" + env: + EXTRA_GHC: "/opt/ghc/${{ matrix.extra-ghc }}/bin/ghc-${{ matrix.extra-ghc }}" + run: sh validate.sh ${{ env.COMMON_FLAGS }} --lib-only -s lib-suite-extras --extra-hc ${{ env.EXTRA_GHC }} + + # The previous jobs use a released version of cabal to build cabal HEAD itself + # This one uses the cabal HEAD generated executable in the previous step + # to build itself again, as sanity check + dogfooding: + name: Dogfooding ${{ matrix.os }} ghc-${{ matrix.ghc }} + runs-on: ${{ matrix.os }} + needs: validate + strategy: + matrix: + os: ["ubuntu-latest", "macos-latest", "windows-latest"] + # We only use one ghc version the used one for the next release (defined at top of the workflow) + # We need to build an array dynamically to inject the appropiate env var in a previous job, + # see https://docs.github.com/en/actions/learn-github-actions/expressions#fromjson + ghc: ${{ fromJSON (needs.validate.outputs.GHC_FOR_RELEASE) }} + + steps: + - uses: actions/checkout@v2 + + - uses: haskell/actions/setup@v1 + id: setup-haskell + with: + ghc-version: ${{ matrix.ghc }} + cabal-version: latest # default, we are not using it in this job + + - name: Download cabal executable from workflow artifacts + uses: actions/download-artifact@v2 + with: + name: cabal-${{ runner.os }}-${{ matrix.ghc }} + path: cabal-head + + - name: Untar the cabal executable + run: tar -xf ./cabal-head/cabal-head.tar -C ./cabal-head + + - name: print-config using cabal HEAD + run: sh validate.sh ${{ env.COMMON_FLAGS }} --with-cabal ./cabal-head/cabal -s print-config + + # We dont use cache to force a build with a fresh store dir and build dir + # This way we check cabal can build all its dependencies + - name: Build using cabal HEAD + run: sh validate.sh ${{ env.COMMON_FLAGS }} --with-cabal ./cabal-head/cabal -s build + + # We use this job as a summary of the workflow + # It will fail if any of the previous jobs does it + # This way we can use it exclusively in branch protection rules + # and abstract away the concrete jobs of the workflow, including their names + validate-post-job: + if: always() + name: Validate post job + runs-on: ubuntu-latest + # IMPORTANT! Any job added to the workflow should be added here too + needs: [validate, validate-old-ghcs, dogfooding] + + steps: + - run: | + echo "jobs info: ${{ toJSON(needs) }}" + - if: contains(needs.*.result, 'failure') || contains(needs.*.result, 'cancelled') + run: exit 1 diff --git a/cabal/.github/workflows/windows.yml b/cabal/.github/workflows/windows.yml deleted file mode 100644 --- a/cabal/.github/workflows/windows.yml +++ /dev/null @@ -1,76 +0,0 @@ -# This file is auto-generated -# -# To regenerate it run -# -# make github-actions -# -name: Windows -on: - push: - branches: - - master - - "3.2" - pull_request: - branches: - - master - release: - types: - - created - -jobs: - - test-windows-8_6_5: - name: test ghc-8.6.5 - runs-on: windows-latest - steps: - - name: Install Cabal - run: choco install -fy cabal --version 3.2.0.0 - - name: Install GHC - run: | - choco uninstall -y ghc --all-versions - choco install -y ghc --version 8.6.5 - - name: Set PATH - run: | - [Environment]::GetEnvironmentVariable("Path") - Write-Host "::add-path::C:\ProgramData\Chocolatey\lib\cabal\tools\cabal-3.2.0.0" - Write-Host "::add-path::C:\ProgramData\Chocolatey\lib\ghc\tools\ghc-8.6.5\bin" - [Environment]::GetEnvironmentVariable("Path") - - name: Print versions - run: | - [Environment]::GetEnvironmentVariable("Path") - cabal --version - ghc --version - cabal user-config init -a "http-transport: plain-http" -a "store-dir: C:\SR" -f -v3 - - uses: actions/cache@v1 - with: - path: C:\SR - key: windows-store-meta - - name: Update Hackage index - run: cabal v2-update - - uses: actions/checkout@v2 - - name: make cabal-install-dev - run: cp cabal-install/cabal-install.cabal.dev cabal-install/cabal-install.cabal - # We cannot ask for all dependencies, but we can for Cabal. - - name: cabal v2-build Cabal --only-dependencies - run: cabal v2-build Cabal --only-dependencies - - name: cabal v2-build - run: cabal v2-build all - - name: cabal-install memory-usage-tests - run: | - cd cabal-install - cabal v2-run cabal-install:memory-usage-tests - - name: cabal-install solver-quickcheck - run: | - cd cabal-install - cabal v2-run cabal-install:solver-quickcheck - - name: cabal-install integration-tests2 - run: | - cd cabal-install - cabal v2-run cabal-install:integration-tests2 - - name: cabal-install unit-tests - run: | - cd cabal-install - cabal v2-run cabal-install:unit-tests -- --pattern "! (/FileMonitor/ || /VCS/ || /Get/)" - - name: cabal-tests - # Using only one job, -j1, to fail less. - run: cabal v2-run cabal-tests -- -j1 --with-cabal=dist-newstyle\build\x86_64-windows\ghc-8.6.5\cabal-install-3.3.0.0\x\cabal\build\cabal\cabal.exe diff --git a/cabal/.gitignore b/cabal/.gitignore --- a/cabal/.gitignore +++ b/cabal/.gitignore @@ -1,4 +1,3 @@ -# trivial gitignore file .cabal-sandbox/ cabal.sandbox.config cabal.project.local @@ -15,9 +14,9 @@ register.sh ./cabal.config cabal-tests.log +bootstrap/*.plan.json /Cabal/dist/ -/Cabal/.python-sphinx-virtualenv/ /Cabal/tests/Setup /Cabal/Setup /Cabal/source-file-list @@ -26,7 +25,14 @@ /cabal-install/Setup /cabal-install/source-file-list +.stylish-haskell.yaml +.stylish-haskell.yml +.ghci +.ghcid +# Output of release and bootstrap +_build + # editor temp files *# @@ -59,8 +65,20 @@ # test files register.sh +# windows test artifacts +cabal-testsuite/**/*.exe +cabal-testsuite/**/*.bat + # python artifacts from documentation builds *.pyc +.python-sphinx-virtualenv/ +/doc/.skjold_cache/ # macOS folder metadata .DS_Store + +# benchmarks +bench.html + +# Emacs +.projectile diff --git a/cabal/.gitlab-ci.yml b/cabal/.gitlab-ci.yml new file mode 100644 --- /dev/null +++ b/cabal/.gitlab-ci.yml @@ -0,0 +1,166 @@ +stages: + - build + +# Used for ci setup in the gitlab mirror of the project: +# https://gitlab.haskell.org/haskell/haskell-language-server/-/pipelines +variables: + # Commit of ghc/ci-images repository from which to pull Docker images + DOCKER_REV: "4ed1a4f27828ba96a34662dc954335e29b470cd2" + + GHC_VERSION: 9.2.3 + CABAL_INSTALL_VERSION: 3.6.2.0 + +workflow: + rules: + - if: $CI_COMMIT_TAG + when: always + # Triggered if you start it from the gitlab web ui + - if: '$CI_PIPELINE_SOURCE == "web"' + when: always + - when: never + +.build: + stage: build + script: + - bash .gitlab/ci.sh + artifacts: + expire_in: 2 week + paths: + - out/* + +build-aarch64-linux-deb10: + extends: .build + tags: + - aarch64-linux + image: "registry.gitlab.haskell.org/ghc/ci-images/aarch64-linux-deb10:$DOCKER_REV" + variables: + TARBALL_ARCHIVE_SUFFIX: aarch64-linux-deb10 + TARBALL_EXT: tar.xz + ADD_CABAL_ARGS: "" + # this permits building pre-releases that are not on Hackage + CABAL_INSTALL_VERSION: 3.4.0.0 + +build-armv7-linux-deb10: + extends: .build + tags: + - armv7-linux + image: "registry.gitlab.haskell.org/ghc/ci-images/armv7-linux-deb10:$DOCKER_REV" + variables: + TARBALL_ARCHIVE_SUFFIX: armv7-linux-deb1 + TARBALL_EXT: tar.xz + ADD_CABAL_ARGS: "" + # this permits building pre-releases that are not on Hackage + CABAL_INSTALL_VERSION: 3.4.0.0 + retry: 2 + +build-x86_64-linux: + extends: .build + tags: + - x86_64-linux + image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb10:$DOCKER_REV" + variables: + TARBALL_ARCHIVE_SUFFIX: x86_64-linux-deb10 + TARBALL_EXT: tar.xz + ADD_CABAL_ARGS: "--enable-split-sections" + # this permits building pre-releases that are not on Hackage + CABAL_INSTALL_VERSION: 3.4.0.0 + +build-x86_64-linux-alpine: + extends: .build + tags: + - x86_64-linux + before_script: + # for cabal build + - sudo apk add --no-cache zlib zlib-dev zlib-static + image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-alpine3_12:$DOCKER_REV" + variables: + TARBALL_ARCHIVE_SUFFIX: x86_64-linux-alpine + TARBALL_EXT: tar.xz + ADD_CABAL_ARGS: "--enable-split-sections --enable-executable-static" + # this permits building pre-releases that are not on Hackage + CABAL_INSTALL_VERSION: 3.4.0.0 + +build-i386-linux-alpine: + extends: .build + tags: + - x86_64-linux + image: "i386/alpine:3.12" + before_script: + # for GHC + - apk add --no-cache bash curl gcc g++ binutils binutils-gold bsd-compat-headers gmp-dev ncurses-dev libffi-dev make xz tar perl + # for cabal build + - apk add --no-cache zlib zlib-dev zlib-static + variables: + TARBALL_ARCHIVE_SUFFIX: i386-linux-alpine + TARBALL_EXT: tar.xz + ADD_CABAL_ARGS: "--enable-split-sections --enable-executable-static" + # this permits building pre-releases that are not on Hackage + CABAL_INSTALL_VERSION: 3.4.0.0 + +build-x86_64-freebsd12: + extends: .build + tags: + - x86_64-freebsd12 + variables: + TARBALL_ARCHIVE_SUFFIX: x86_64-freebsd12 + TARBALL_EXT: tar.xz + ADD_CABAL_ARGS: "--enable-split-sections" + # this permits building pre-releases that are not on Hackage + CABAL_INSTALL_VERSION: 3.4.0.0 + +build-x86_64-darwin: + extends: .build + tags: + - x86_64-darwin + variables: + TARBALL_ARCHIVE_SUFFIX: x86_64-darwin + TARBALL_EXT: tar.xz + ADD_CABAL_ARGS: "" + # this permits building pre-releases that are not on Hackage + CABAL_INSTALL_VERSION: 3.4.0.0 + +build-aarch64-darwin: + stage: build + tags: + - aarch64-darwin-m1 + before_script: + - export HOMEBREW_CHANGE_ARCH_TO_ARM=1 + - arch -arm64 /bin/bash ./.gitlab/brew.sh llvm autoconf automake coreutils make tree + # C_INCLUDE_PATH: https://gitlab.haskell.org/ghc/ghc/-/issues/20592 + script: | + export PATH="$CI_PROJECT_DIR/.brew/opt/llvm/bin:$CI_PROJECT_DIR/.brew/bin:$CI_PROJECT_DIR/.brew/sbin:$PATH" + export CC=$CI_PROJECT_DIR/.brew/opt/llvm/bin/clang + export CXX=$CI_PROJECT_DIR/.brew/opt/llvm/bin/clang++ + export LD=ld + export AR=$CI_PROJECT_DIR/.brew/opt/llvm/bin/llvm-ar + export RANLIB=$CI_PROJECT_DIR/.brew/opt/llvm/bin/llvm-ranlib + export C_INCLUDE_PATH="`xcrun --show-sdk-path`/usr/include/ffi" + arch -arm64 /bin/bash ./.gitlab/ci.sh + after_script: + - rm -Rf /private/tmp/.brew_tmp + variables: + MACOSX_DEPLOYMENT_TARGET: "10.7" + TARBALL_ARCHIVE_SUFFIX: aarch64-darwin + TARBALL_EXT: tar.xz + ADD_CABAL_ARGS: "" + # this permits building pre-releases that are not on Hackage + CABAL_INSTALL_VERSION: 3.4.0.0 + artifacts: + expire_in: 2 week + paths: + - out/* + +build-x86_64-windows: + extends: .build + script: + - $env:CHERE_INVOKING = "yes" + - bash '-lc' "ADD_CABAL_ARGS=$env:ADD_CABAL_ARGS GHC_VERSION=$env:GHC_VERSION CABAL_INSTALL_VERSION=$CABAL_INSTALL_VERSION .gitlab/ci.sh" + tags: + - new-x86_64-windows + variables: + TARBALL_ARCHIVE_SUFFIX: x86_64-windows + TARBALL_EXT: zip + ADD_CABAL_ARGS: "" + # this permits building pre-releases that are not on Hackage + CABAL_INSTALL_VERSION: 3.4.0.0 + retry: 2 diff --git a/cabal/.gitlab/brew.sh b/cabal/.gitlab/brew.sh new file mode 100644 --- /dev/null +++ b/cabal/.gitlab/brew.sh @@ -0,0 +1,19 @@ +#!/usr/bin/env bash + +set -Eeuxo pipefail + +# Install brew locally in the project dir. Packages will also be installed here. +[ -e "$CI_PROJECT_DIR/.brew" ] || git clone --depth=1 https://github.com/Homebrew/brew $CI_PROJECT_DIR/.brew +export PATH="$CI_PROJECT_DIR/.brew/bin:$CI_PROJECT_DIR/.brew/sbin:$PATH" + +# make sure to not pollute the machine with temp files etc +mkdir -p $CI_PROJECT_DIR/.brew_cache +export HOMEBREW_CACHE=$CI_PROJECT_DIR/.brew_cache +mkdir -p $CI_PROJECT_DIR/.brew_logs +export HOMEBREW_LOGS=$CI_PROJECT_DIR/.brew_logs +mkdir -p /private/tmp/.brew_tmp +export HOMEBREW_TEMP=/private/tmp/.brew_tmp + +# update and install packages +brew update +brew install ${1+"$@"} diff --git a/cabal/.gitlab/ci.sh b/cabal/.gitlab/ci.sh new file mode 100644 --- /dev/null +++ b/cabal/.gitlab/ci.sh @@ -0,0 +1,84 @@ +#!/usr/bin/env bash + +set -Eeuxo pipefail + +source "$CI_PROJECT_DIR/.gitlab/common.sh" + +export GHCUP_INSTALL_BASE_PREFIX="$CI_PROJECT_DIR/toolchain" +export CABAL_DIR="$CI_PROJECT_DIR/cabal" + +case "$(uname)" in + MSYS_*|MINGW*) + export CABAL_DIR="$(cygpath -w "$CABAL_DIR")" + GHCUP_BINDIR="${GHCUP_INSTALL_BASE_PREFIX}/ghcup/bin" + EXE_EXT=".exe" + ;; + *) + GHCUP_BINDIR="${GHCUP_INSTALL_BASE_PREFIX}/.ghcup/bin" + EXE_EXT="" + ;; +esac + +mkdir -p "$CABAL_DIR" +mkdir -p "$GHCUP_BINDIR" +export PATH="$GHCUP_BINDIR:$PATH" + +export BOOTSTRAP_HASKELL_NONINTERACTIVE=1 +export BOOTSTRAP_HASKELL_GHC_VERSION=$GHC_VERSION +export BOOTSTRAP_HASKELL_CABAL_VERSION=$CABAL_INSTALL_VERSION +export BOOTSTRAP_HASKELL_VERBOSE=1 +export BOOTSTRAP_HASKELL_ADJUST_CABAL_CONFIG=yes + +# for some reason the subshell doesn't pick up the arm64 environment on darwin +# and starts installing x86_64 GHC +case "$(uname -s)" in + "Darwin"|"darwin") + case "$(/usr/bin/arch)" in + aarch64|arm64|armv8l) + curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | arch -arm64 /bin/bash + ;; + *) + curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh + ;; + esac + ;; + *) + curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh + ;; +esac + +# https://github.com/haskell/cabal/issues/7313#issuecomment-811851884 +if [ "$(getconf LONG_BIT)" == "32" ] ; then + echo 'constraints: lukko -ofd-locking' >> cabal.project.release.local +fi + +args=( + -w "ghc-$GHC_VERSION" + --disable-profiling + --enable-executable-stripping + --project-file=cabal.project.release + ${ADD_CABAL_ARGS} +) + +run cabal v2-build ${args[@]} cabal-install + +mkdir "$CI_PROJECT_DIR/out" +cp "$(cabal list-bin ${args[@]} cabal-install:exe:cabal)" "$CI_PROJECT_DIR/out/cabal$EXE_EXT" +cp dist-newstyle/cache/plan.json "$CI_PROJECT_DIR/out/plan.json" +cd "$CI_PROJECT_DIR/out/" + +# create tarball/zip +TARBALL_PREFIX="cabal-install-$("$CI_PROJECT_DIR/out/cabal" --numeric-version)" +case "${TARBALL_EXT}" in + zip) + zip "${TARBALL_PREFIX}-${TARBALL_ARCHIVE_SUFFIX}.${TARBALL_EXT}" "cabal${EXE_EXT}" plan.json + ;; + tar.xz) + tar caf "${TARBALL_PREFIX}-${TARBALL_ARCHIVE_SUFFIX}.${TARBALL_EXT}" "cabal${EXE_EXT}" plan.json + ;; + *) + fail "Unknown TARBALL_EXT: ${TARBALL_EXT}" + ;; +esac + +rm cabal plan.json diff --git a/cabal/.gitlab/common.sh b/cabal/.gitlab/common.sh new file mode 100644 --- /dev/null +++ b/cabal/.gitlab/common.sh @@ -0,0 +1,49 @@ +# Common bash utilities +# ---------------------- + +# Colors +BLACK="0;30" +GRAY="1;30" +RED="0;31" +LT_RED="1;31" +BROWN="0;33" +LT_BROWN="1;33" +GREEN="0;32" +LT_GREEN="1;32" +BLUE="0;34" +LT_BLUE="1;34" +PURPLE="0;35" +LT_PURPLE="1;35" +CYAN="0;36" +LT_CYAN="1;36" +WHITE="1;37" +LT_GRAY="0;37" + +# GitLab Pipelines log section delimiters +# https://gitlab.com/gitlab-org/gitlab-foss/issues/14664 +start_section() { + name="$1" + echo -e "section_start:$(date +%s):$name\015\033[0K" +} + +end_section() { + name="$1" + echo -e "section_end:$(date +%s):$name\015\033[0K" +} + +echo_color() { + local color="$1" + local msg="$2" + echo -e "\033[${color}m${msg}\033[0m" +} + +error() { echo_color "${RED}" "$1"; } +warn() { echo_color "${LT_BROWN}" "$1"; } +info() { echo_color "${LT_BLUE}" "$1"; } + +fail() { error "error: $1"; exit 1; } + +function run() { + info "Running $*..." + "$@" || ( error "$* failed"; return 1; ) +} diff --git a/cabal/.mention-bot b/cabal/.mention-bot deleted file mode 100644 --- a/cabal/.mention-bot +++ /dev/null @@ -1,6 +0,0 @@ -{ - "userBlacklist": [ - "BardurArantsson" - , "SyntaxPolice" - ] -} diff --git a/cabal/.projectile b/cabal/.projectile deleted file mode 100644 --- a/cabal/.projectile +++ /dev/null diff --git a/cabal/.readthedocs.yml b/cabal/.readthedocs.yml --- a/cabal/.readthedocs.yml +++ b/cabal/.readthedocs.yml @@ -1,9 +1,9 @@ version: 2 sphinx: - configuration: Cabal/doc/conf.py + configuration: doc/conf.py python: version: 3.7 install: - - requirements: Cabal/doc/requirements.txt + - requirements: doc/requirements.txt diff --git a/cabal/CONTRIBUTING.md b/cabal/CONTRIBUTING.md --- a/cabal/CONTRIBUTING.md +++ b/cabal/CONTRIBUTING.md @@ -8,9 +8,9 @@ that you have a sufficiently recent cabal-install (see above), it is sufficient to run: -~~~~ +``` cabal v2-build cabal -~~~~ +``` To build a local, development copy of cabal-install. The location of your build products will vary depending on which version of @@ -20,60 +20,29 @@ Here are some other useful variations on the commands: -~~~~ +``` cabal v2-build Cabal # build library only -cabal v2-build Cabal:unit-tests # build Cabal's unit test suite +cabal v2-build Cabal-tests:unit-tests # build Cabal's unit test suite cabal v2-build cabal-tests # etc... -~~~~ - -**Dogfooding HEAD.** -Many of the core developers of Cabal dogfood `cabal-install` HEAD -when doing development on Cabal. This helps us identify bugs -which were missed by the test suite and easily experiment with new -features. - -The recommended workflow in this case is slightly different: you will -maintain two Cabal source trees: your production tree (built with a -released version of Cabal) which always tracks `master` and which you -update only when you want to move to a new version of Cabal to dogfood, -and your development tree (built with your production Cabal) that you -actually do development on. - -In more detail, suppose you have checkouts of Cabal at `~/cabal-prod` -and `~/cabal-dev`, and you have a release copy of cabal installed at -`/opt/cabal/2.4/bin/cabal`. First, build your production tree: - -~~~~ -cd ~/cabal-prod -/opt/cabal/2.4/bin/cabal v2-build cabal -~~~~ - -This will produce a cabal binary (see also: [Where are my build products?](http://cabal.readthedocs.io/en/latest/nix-local-build.html#where-are-my-build-products) -). Add this binary to your PATH, -and then use it to build your development copy: - -~~~~ -cd ~/cabal-dev -cabal v2-build cabal -~~~~ +``` Running tests ------------- -**Using Travis and AppVeyor.** +**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 -continuous integration service on Travis and AppVeyor will build and -test your code. Title your PR with WIP so we know that it does not need +continuous integration service on Github Actions builds and +tests your code. Title your PR with WIP so we know that it does not need code review. -Some tips for using Travis effectively: +Some tips for using Github Actions effectively: -* Travis builds take a long time. Use them when you are pretty +* Github Actions builds take a long time. Use them when you are pretty sure everything is OK; otherwise, try to run relevant tests locally first. -* Watch over your jobs on the [Travis website](http://travis-ci.org). +* Watch over your jobs on the [Github Actions website](http://github.org/haskell/cabal/actions). If you know a build of yours is going to fail (because one job has already failed), be nice to others and cancel the rest of the jobs, so that other commits on the build queue can be processed. @@ -97,17 +66,12 @@ a specific operating system? If so, try reproducing the problem on the specific configuration. -4. Is the test failing on a Travis per-GHC build - ([for example](https://travis-ci.org/haskell-pushbot/cabal-binaries/builds/208128401))? +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 Travis that are being + the precise binaries that were built by Github Actions that are being tested. If you have an Ubuntu system, you can download the binaries and run them directly. -5. Is the test failing on AppVeyor? Consider logging in via - Remote Desktop to the build VM: - https://www.appveyor.com/docs/how-to/rdp-to-build-worker/ - If none of these let you reproduce, there might be some race condition or continuous integration breakage; please file a bug. @@ -127,7 +91,7 @@ There are also other test suites: -* `Cabal:unit-tests` are small, quick-running unit tests +* `Cabal-tests:unit-tests` are small, quick-running unit tests on small pieces of functionality in Cabal. If you are working on some utility functions in the Cabal library you should run this test suite. @@ -137,16 +101,18 @@ on some utility functions in cabal-install you should run this test suite. -* `cabal-install:solver-quickcheck` are QuickCheck tests on - cabal-install's dependency solver. If you are working - on the solver you should run this test suite. +* `cabal-install:long-tests` are QuickCheck tests on + cabal-install's dependency solver, VCS, and file monitoring code. + If you are working on the solver you should run this test suite. * `cabal-install:integration-tests2` are integration tests on some top-level API functions inside the `cabal-install` source code. For these test executables, `-p` which applies a regex filter to the test -names. +names. When running `cabal-install` test suites, one need only use `cabal test` or +`cabal run ` in order to test locally. + Conventions ----------- @@ -164,10 +130,6 @@ * If you do something tricky or non-obvious, add a comment. -* If your commit only touches comments, you can use `[ci skip]` - anywhere in the body of the commit message to avoid needlessly - triggering the build bots. - * For local imports (Cabal module importing Cabal module), import lists are NOT required (although you may use them at your discretion.) For third-party and standard library imports, please use either qualified imports @@ -221,6 +183,52 @@ [guide]: https://github.com/tibbe/haskell-style-guide/blob/master/haskell-style.md +Changelog +--------- + +When opening a pull request, you should write a changelog entry +(or more in case of multiple independent changes). +This is done by adding files in the `changelog.d` directory. + +The files follow a simple key-value format similar to the one for .cabal files. + +Here's an exhaustive example: + +```cabal +synopsis: Add feature xyz +packages: cabal-install +prs: #0000 +issues: #0000 #0000 +significance: significant + +description: { + +- Detail number 1 +- Detail number 2 + +} +``` + +Only the `synopsis` field is actually required, but you should also set the others where applicable. + +| Field | Description | +| ----- | ----------- | +| `synopsis` | Brief description of the change. Often just the pr title. | +| `description` | Longer description, with a list of sub-changes. Not needed for small/atomic changes. | +| `packages` | Packages affected by the change (`cabal-install`, `Cabal`...). Omit if it's an overarching or non-package change. | +| `prs` | Space-separated hash-prefixed pull request numbers containing the change (usually just one). | +| `issues` | Space-separated hash-prefixed issue numbers that the change fixes/closes/affects. | +| `significance` | Set to `significant` if the change is significant, that is if it warrants being put near the top of the changelog. | + +You can find a large number of real-world examples of changelog files +[here](https://github.com/haskell/cabal/tree/bc83de27569fda22dbe1e10be1a921bebf4d3430/changelog.d). + +At release time, the entries will be merged with +[this tool](https://github.com/phadej/changelog-d). + +In addition, if you're changing the .cabal file format specification you should +add an entry in `doc/file-format-changelog.rst`. + Communicating ------------- @@ -231,15 +239,17 @@ * For more organizational concerns, the [mailing list](http://www.haskell.org/mailman/listinfo/cabal-devel) is used. -* Many developers idle on `#hackage` on `irc.freenode.net` ([archives](http://ircbrowse.net/browse/hackage)). `#ghc` ([archives](http://ircbrowse.net/browse/ghc)) is also a decently good bet. +* Many developers idle on `#hackage` on [`irc.libera.chat`](https://libera.chat). The `#ghc` channel is also a decently good bet. + * 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:libera.chat 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, @23Skidoo, @rthomas, @tibbe and @dcoutts have access to -`haskell.org/cabal`, and @davean is the point of contact for getting +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. API Documentation diff --git a/cabal/Cabal-QuickCheck/Cabal-QuickCheck.cabal b/cabal/Cabal-QuickCheck/Cabal-QuickCheck.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-QuickCheck/Cabal-QuickCheck.cabal @@ -0,0 +1,22 @@ +cabal-version: 2.2 +name: Cabal-QuickCheck +version: 3.8.1.0 +synopsis: QuickCheck instances for types in Cabal +category: Testing +description: + Provides QuickCheck Arbitrary instances for some types in Cabal + +library + default-language: Haskell2010 + hs-source-dirs: src + ghc-options: -Wall + build-depends: + , base + , bytestring + , Cabal ^>=3.8.0.0 + , Cabal-syntax ^>=3.8.0.0 + , QuickCheck ^>=2.13.2 || ^>=2.14 + + exposed-modules: + Test.QuickCheck.GenericArbitrary + Test.QuickCheck.Instances.Cabal diff --git a/cabal/Cabal-QuickCheck/src/Test/QuickCheck/GenericArbitrary.hs b/cabal/Cabal-QuickCheck/src/Test/QuickCheck/GenericArbitrary.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-QuickCheck/src/Test/QuickCheck/GenericArbitrary.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} +module Test.QuickCheck.GenericArbitrary ( + genericArbitrary, + GArbitrary, +) where + +import GHC.Generics +import Test.QuickCheck + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative (pure, (<$>), (<*>)) +#endif + +-- Generic arbitrary for non-recursive types +genericArbitrary :: (Generic a, GArbitrary (Rep a)) => Gen a +genericArbitrary = fmap to garbitrary + +class GArbitrary f where + garbitrary :: Gen (f ()) + +class GArbitrarySum f where + garbitrarySum :: [Gen (f ())] + +class GArbitraryProd f where + garbitraryProd :: Gen (f ()) + +instance (GArbitrarySum f, i ~ D) => GArbitrary (M1 i c f) where + garbitrary = fmap M1 (oneof garbitrarySum) + +instance (GArbitraryProd f, i ~ C) => GArbitrarySum (M1 i c f) where + garbitrarySum = [fmap M1 garbitraryProd] + +instance (GArbitrarySum f, GArbitrarySum g) => GArbitrarySum (f :+: g) where + garbitrarySum = map (fmap L1) garbitrarySum ++ map (fmap R1) garbitrarySum + +instance (GArbitraryProd f, i ~ S) => GArbitraryProd (M1 i c f) where + garbitraryProd = fmap M1 garbitraryProd + +instance GArbitraryProd U1 where + garbitraryProd = pure U1 + +instance (GArbitraryProd f, GArbitraryProd g) => GArbitraryProd (f :*: g) where + garbitraryProd = (:*:) <$> garbitraryProd <*> garbitraryProd + +instance (Arbitrary a) => GArbitraryProd (K1 i a) where + garbitraryProd = fmap K1 arbitrary diff --git a/cabal/Cabal-QuickCheck/src/Test/QuickCheck/Instances/Cabal.hs b/cabal/Cabal-QuickCheck/src/Test/QuickCheck/Instances/Cabal.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-QuickCheck/src/Test/QuickCheck/Instances/Cabal.hs @@ -0,0 +1,533 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Test.QuickCheck.Instances.Cabal () where + +import Control.Applicative (liftA2) +import Data.Bits (shiftR) +import Data.Char (isAlphaNum, isDigit) +import Data.List (intercalate) +import Data.List.NonEmpty (NonEmpty (..)) +import Distribution.Utils.Generic (lowercase) +import Test.QuickCheck + +#if MIN_VERSION_base(4,8,0) +import Data.Bits (countLeadingZeros, finiteBitSize, shiftL) +#else +import Data.Bits (popCount) +#endif + +import Distribution.CabalSpecVersion +import Distribution.Compat.NonEmptySet (NonEmptySet) +import Distribution.Compiler +import Distribution.FieldGrammar.Newtypes +import Distribution.ModuleName +import Distribution.Simple.Compiler (DebugInfoLevel (..), OptimisationLevel (..), PackageDB (..), ProfDetailLevel (..), knownProfDetailLevels) +import Distribution.Simple.Flag (Flag (..)) +import Distribution.Simple.InstallDirs +import Distribution.Simple.Setup (HaddockTarget (..), TestShowDetails (..), DumpBuildInfo) +import Distribution.SPDX +import Distribution.System +import Distribution.Types.Dependency +import Distribution.Types.Flag (FlagAssignment, FlagName, mkFlagAssignment, mkFlagName, unFlagAssignment) +import Distribution.Types.IncludeRenaming +import Distribution.Types.LibraryName +import Distribution.Types.LibraryVisibility +import Distribution.Types.Mixin +import Distribution.Types.ModuleRenaming +import Distribution.Types.PackageId +import Distribution.Types.PackageName +import Distribution.Types.PackageVersionConstraint +import Distribution.Types.PkgconfigVersion +import Distribution.Types.PkgconfigVersionRange +import Distribution.Types.SourceRepo +import Distribution.Types.UnqualComponentName +import Distribution.Types.VersionRange.Internal +import Distribution.Utils.NubList +import Distribution.Verbosity +import Distribution.Version + +import Test.QuickCheck.GenericArbitrary + +import qualified Data.ByteString.Char8 as BS8 +import qualified Distribution.Compat.NonEmptySet as NES + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative (pure, (<$>), (<*>)) +#endif + +------------------------------------------------------------------------------- +-- CabalSpecVersion +------------------------------------------------------------------------------- + +instance Arbitrary CabalSpecVersion where + arbitrary = arbitraryBoundedEnum + +instance Arbitrary SpecVersion where + arbitrary = fmap SpecVersion arbitrary + +------------------------------------------------------------------------------- +-- PackageName and PackageIdentifier +------------------------------------------------------------------------------- + +instance Arbitrary PackageName where + arbitrary = mkPackageName . intercalate "-" <$> shortListOf1 2 nameComponent + where + nameComponent = shortListOf1 5 (elements packageChars) + `suchThat` (not . all isDigit) + packageChars = filter isAlphaNum ['\0'..'\127'] + +instance Arbitrary PackageIdentifier where + arbitrary = PackageIdentifier <$> arbitrary <*> arbitrary + + shrink (PackageIdentifier pn vr) = uncurry PackageIdentifier <$> shrink (pn, vr) + +------------------------------------------------------------------------------- +-- Version +------------------------------------------------------------------------------- + +-- | Does *NOT* generate 'nullVersion' +instance Arbitrary Version where + arbitrary = do + branch <- smallListOf1 $ + frequency [(3, return 0) + ,(3, return 1) + ,(2, return 2) + ,(2, return 3) + ,(1, return 0xfffd) + ,(1, return 0xfffe) -- max fitting into packed W64 + ,(1, return 0xffff) + ,(1, return 999999998) + ,(1, return 999999999) + ,(1, return 0x10000)] + return (mkVersion branch) + where + smallListOf1 = scale (\n -> min 6 (n `div` 3)) . listOf1 + + shrink ver = [ mkVersion ns | ns <- shrink (versionNumbers ver) + , not (null ns) ] + +instance Arbitrary VersionRange where + arbitrary = sized $ \n -> chooseInt (0, n) >>= verRangeExp . intSqrt + where + verRangeExp n + | n > 0 = oneof + [ recurse unionVersionRanges n + , recurse intersectVersionRanges n + ] + | otherwise = oneof + [ return anyVersion + , fmap thisVersion arbitrary + , fmap laterVersion arbitrary + , fmap orLaterVersion arbitrary + , fmap orLaterVersion' arbitrary + , fmap earlierVersion arbitrary + , fmap orEarlierVersion arbitrary + , fmap orEarlierVersion' arbitrary + , fmap withinVersion arbitraryV + , fmap majorBoundVersion arbitrary + ] + + recurse mk n = do + k <- chooseInt (0, n - 1) + liftA2 mk (verRangeExp k) (verRangeExp (n - k - 1)) + + arbitraryV :: Gen Version + arbitraryV = arbitrary `suchThat` \v -> all (< 999999999) (versionNumbers v) + + orLaterVersion' v = + unionVersionRanges (LaterVersion v) (ThisVersion v) + orEarlierVersion' v = + unionVersionRanges (EarlierVersion v) (ThisVersion v) + + shrink (ThisVersion v) = map ThisVersion (shrink v) + shrink (LaterVersion v) = map LaterVersion (shrink v) + shrink (EarlierVersion v) = map EarlierVersion (shrink v) + shrink (OrLaterVersion v) = LaterVersion v : map OrLaterVersion (shrink v) + shrink (OrEarlierVersion v) = EarlierVersion v : map OrEarlierVersion (shrink v) + shrink (MajorBoundVersion v) = map MajorBoundVersion (shrink v) + shrink (UnionVersionRanges a b) = a : b : map (uncurry UnionVersionRanges) (shrink (a, b)) + shrink (IntersectVersionRanges a b) = a : b : map (uncurry IntersectVersionRanges) (shrink (a, b)) + +instance Arbitrary VersionIntervals where + arbitrary = fmap toVersionIntervals arbitrary + +instance Arbitrary Bound where + arbitrary = elements [ExclusiveBound, InclusiveBound] + +------------------------------------------------------------------------------- +-- Backpack +------------------------------------------------------------------------------- + +instance Arbitrary Mixin where + arbitrary = normaliseMixin <$> genericArbitrary + shrink = fmap normaliseMixin . genericShrink + +instance Arbitrary IncludeRenaming where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary ModuleRenaming where + arbitrary = genericArbitrary + shrink = genericShrink + +------------------------------------------------------------------------------- +-- +------------------------------------------------------------------------------- + +instance Arbitrary LibraryVisibility where + arbitrary = elements [LibraryVisibilityPrivate, LibraryVisibilityPublic] + + shrink LibraryVisibilityPublic = [LibraryVisibilityPrivate] + shrink LibraryVisibilityPrivate = [] + +------------------------------------------------------------------------------- +-- ModuleName +------------------------------------------------------------------------------- + +instance Arbitrary ModuleName where + arbitrary = fromString . intercalate "." <$> shortListOf1 4 comp where + comp = (:) <$> elements upper <*> shortListOf1 10 (elements moduleChar) + upper = ['A'..'Z'] + moduleChar = [ c | c <- ['\0' .. '\255'], isAlphaNum c || c `elem` "_'" ] + +------------------------------------------------------------------------------- +-- Dependency +------------------------------------------------------------------------------- + +instance Arbitrary Dependency where + arbitrary = mkDependency + <$> arbitrary + <*> arbitrary + <*> (arbitrary `suchThat` const True) -- should be (not . null) + + shrink (Dependency pn vr lb) = + [ mkDependency pn' vr' lb' + | (pn', vr', lb') <- shrink (pn, vr, lb) + ] + +------------------------------------------------------------------------------- +-- PackageVersionConstraint +------------------------------------------------------------------------------- + +instance Arbitrary PackageVersionConstraint where + arbitrary = PackageVersionConstraint + <$> arbitrary + <*> arbitrary + + shrink (PackageVersionConstraint pn vr) = + [ PackageVersionConstraint pn' vr' + | (pn', vr') <- shrink (pn, vr) + ] + +------------------------------------------------------------------------------- +-- System +------------------------------------------------------------------------------- + +instance Arbitrary OS where + arbitrary = elements knownOSs + +instance Arbitrary Arch where + arbitrary = elements knownArches + +instance Arbitrary Platform where + arbitrary = Platform <$> arbitrary <*> arbitrary + +------------------------------------------------------------------------------- +-- Various names +------------------------------------------------------------------------------- + +instance Arbitrary UnqualComponentName where + -- same rules as package names + arbitrary = packageNameToUnqualComponentName <$> arbitrary + +instance Arbitrary LibraryName where + arbitrary = oneof + [ LSubLibName <$> arbitrary + , pure LMainLibName + ] + + shrink (LSubLibName _) = [LMainLibName] + shrink _ = [] + +------------------------------------------------------------------------------- +-- option flags +------------------------------------------------------------------------------- + +instance Arbitrary a => Arbitrary (Flag a) where + arbitrary = arbitrary1 + + shrink NoFlag = [] + shrink (Flag x) = NoFlag : [ Flag x' | x' <- shrink x ] + +instance Arbitrary1 Flag where + liftArbitrary genA = sized $ \sz -> + if sz <= 0 + then pure NoFlag + else frequency [ (1, pure NoFlag) + , (3, Flag <$> genA) ] + +------------------------------------------------------------------------------- +-- GPD flags +------------------------------------------------------------------------------- + +instance Arbitrary FlagName where + arbitrary = mkFlagName <$> frequency + [ (20, flagident) + -- special nasty cases + , (1, pure "none") + , (1, pure "any") + ] + where + flagident = lowercase <$> shortListOf1 5 (elements flagChars) + `suchThat` (("-" /=) . take 1) + flagChars = "-_" ++ ['a'..'z'] + +instance Arbitrary FlagAssignment where + arbitrary = mkFlagAssignment <$> arbitrary + shrink x = mkFlagAssignment <$> shrink (unFlagAssignment x) + +------------------------------------------------------------------------------- +-- Verbosity +------------------------------------------------------------------------------- + +instance Arbitrary Verbosity where + arbitrary = do + v <- elements [minBound..maxBound] + -- verbose markoutput is left out on purpose + flags <- listOf $ elements + [ verboseCallSite + , verboseCallStack + , verboseNoWrap + , verboseTimestamp + , verboseStderr + ] + return (foldr ($) v flags) + +------------------------------------------------------------------------------- +-- SourceRepo +------------------------------------------------------------------------------- + +instance Arbitrary RepoType where + arbitrary = elements (KnownRepoType <$> knownRepoTypes) + +instance Arbitrary RepoKind where + arbitrary = elements [RepoHead, RepoThis] + +------------------------------------------------------------------------------- +-- SPDX +------------------------------------------------------------------------------- + +instance Arbitrary LicenseId where + arbitrary = elements $ licenseIdList currentLicenseListVersion + +instance Arbitrary LicenseExceptionId where + arbitrary = elements $ licenseExceptionIdList currentLicenseListVersion + +currentLicenseListVersion :: LicenseListVersion +currentLicenseListVersion = cabalSpecVersionToSPDXListVersion cabalSpecLatest + +instance Arbitrary LicenseRef where + arbitrary = mkLicenseRef' <$> ids' <*> ids + where + ids = listOf1 $ elements $ ['a'..'z'] ++ ['A' .. 'Z'] ++ ['0'..'9'] ++ "_-" + ids' = oneof [ pure Nothing, Just <$> ids ] + +instance Arbitrary SimpleLicenseExpression where + arbitrary = oneof + [ ELicenseId <$> arbitrary + , ELicenseIdPlus <$> arbitrary + , ELicenseRef <$> arbitrary + ] + +instance Arbitrary LicenseExpression where + arbitrary = sized arb + where + arb n + | n <= 0 = ELicense <$> arbitrary <*> pure Nothing + | otherwise = oneof + [ ELicense <$> arbitrary <*> arbitrary + , EAnd <$> arbA <*> arbB + , EOr <$> arbA <*> arbB + ] + where + m = n `div` 2 + arbA = arb m + arbB = arb (n - m) + + shrink (EAnd a b) = a : b : map (uncurry EAnd) (shrink (a, b)) + shrink (EOr a b) = a : b : map (uncurry EOr) (shrink (a, b)) + shrink _ = [] + +------------------------------------------------------------------------------- +-- Compiler +------------------------------------------------------------------------------- + +instance Arbitrary CompilerFlavor where + arbitrary = elements knownCompilerFlavors + +instance Arbitrary CompilerId where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary ProfDetailLevel where + arbitrary = elements [ d | (_,_,d) <- knownProfDetailLevels ] + +instance Arbitrary OptimisationLevel where + arbitrary = elements [minBound..maxBound] + +instance Arbitrary DebugInfoLevel where + arbitrary = elements [minBound..maxBound] + +------------------------------------------------------------------------------- +-- NonEmptySet +------------------------------------------------------------------------------- + +instance (Arbitrary a, Ord a) => Arbitrary (NonEmptySet a) where + arbitrary = mk <$> arbitrary <*> arbitrary where + mk x xs = NES.fromNonEmpty (x :| xs) + + shrink nes = case NES.toNonEmpty nes of + x :| xs -> map mk (shrink (x, xs)) + where + mk (x,xs) = NES.fromNonEmpty (x :| xs) + +------------------------------------------------------------------------------- +-- NubList +------------------------------------------------------------------------------- + +instance (Arbitrary a, Ord a) => Arbitrary (NubList a) where + arbitrary = toNubList <$> arbitrary + shrink xs = [ toNubList [] | (not . null) (fromNubList xs) ] + -- try empty, otherwise don't shrink as it can loop + +------------------------------------------------------------------------------- +-- InstallDirs +------------------------------------------------------------------------------- + +instance Arbitrary a => Arbitrary (InstallDirs a) where + arbitrary = InstallDirs + <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary -- 4 + <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary -- 8 + <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary -- 12 + <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary -- 16 + +instance Arbitrary PathTemplate where + arbitrary = toPathTemplate <$> arbitraryShortToken + shrink t = [ toPathTemplate s + | s <- shrink (fromPathTemplate t) + , not (null s) ] + +------------------------------------------------------------------------------- +-- Pkgconfig +------------------------------------------------------------------------------- + +instance Arbitrary PkgconfigVersion where + arbitrary = PkgconfigVersion . BS8.pack . dropDash . concat <$> listOf1 elems where + elems = frequency + [ (2, pure ".") + , (1, pure "-") + , (5, listOf1 $ elements ['0' .. '9']) + , (1, listOf1 $ elements ['A' .. 'Z']) + , (1, listOf1 $ elements ['a' .. 'z']) + ] + + -- disallow versions starting with dash + dropDash = notEmpty . dropWhile (== '-') + notEmpty x + | null x = "0" + | otherwise = x + +instance Arbitrary PkgconfigVersionRange where + arbitrary = sized $ \n -> chooseInt (0, n) >>= verRangeExp . intSqrt + where + verRangeExp n + | n > 0 = oneof + [ recurse PcUnionVersionRanges n + , recurse PcIntersectVersionRanges n + ] + | otherwise = oneof + [ return PcAnyVersion + , fmap PcThisVersion arbitrary + , fmap PcLaterVersion arbitrary + , fmap PcOrLaterVersion arbitrary + , fmap orLaterVersion' arbitrary + , fmap PcEarlierVersion arbitrary + , fmap PcOrEarlierVersion arbitrary + , fmap orEarlierVersion' arbitrary + ] + + recurse mk n = do + k <- chooseInt (0, n - 1) + liftA2 mk (verRangeExp k) (verRangeExp (n - k - 1)) + + orLaterVersion' v = + PcUnionVersionRanges (PcLaterVersion v) (PcThisVersion v) + orEarlierVersion' v = + PcUnionVersionRanges (PcEarlierVersion v) (PcThisVersion v) + +------------------------------------------------------------------------------- +-- Setup +------------------------------------------------------------------------------- + +instance Arbitrary HaddockTarget where + arbitrary = elements [ForHackage, ForDevelopment] + +instance Arbitrary TestShowDetails where + arbitrary = arbitraryBoundedEnum + +------------------------------------------------------------------------------- +-- PackageDB +------------------------------------------------------------------------------- + +instance Arbitrary PackageDB where + arbitrary = oneof [ pure GlobalPackageDB + , pure UserPackageDB + , SpecificPackageDB <$> arbitraryShortPath + ] + +------------------------------------------------------------------------------- +-- DumpBuildInfo +------------------------------------------------------------------------------- + +instance Arbitrary DumpBuildInfo where + arbitrary = arbitraryBoundedEnum + +------------------------------------------------------------------------------- +-- Helpers +------------------------------------------------------------------------------- + +shortListOf1 :: Int -> Gen a -> Gen [a] +shortListOf1 bound gen = sized $ \n -> do + k <- choose (1, 1 `max` ((n `div` 2) `min` bound)) + vectorOf k gen + +arbitraryShortToken :: Gen String +arbitraryShortToken = arbitraryShortStringWithout "{}[]" + +arbitraryShortPath :: Gen String +arbitraryShortPath = arbitraryShortStringWithout "{}[]," + +arbitraryShortStringWithout :: String -> Gen String +arbitraryShortStringWithout excludeChars = + shortListOf1 5 $ elements [c | c <- ['#' .. '~' ], c `notElem` excludeChars ] + +-- | +intSqrt :: Int -> Int +intSqrt 0 = 0 +intSqrt 1 = 1 +intSqrt n = case compare n 0 of + LT -> 0 -- whatever + EQ -> 0 + GT -> iter (iter guess) -- two iterations give good results + where + iter :: Int -> Int + iter 0 = 0 + iter x = shiftR (x + n `div` x) 1 + + guess :: Int +#if MIN_VERSION_base(4,8,0) + guess = shiftR n (shiftL (finiteBitSize n - countLeadingZeros n) 1) +#else + guess = shiftR n (shiftR (popCount n) 1) +#endif diff --git a/cabal/Cabal-described/Cabal-described.cabal b/cabal/Cabal-described/Cabal-described.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-described/Cabal-described.cabal @@ -0,0 +1,27 @@ +cabal-version: 2.2 +name: Cabal-described +version: 3.8.1.0 +synopsis: Described functionality for types in Cabal +category: Testing, Parsec +description: Provides rere bindings + +library + default-language: Haskell2010 + hs-source-dirs: src + ghc-options: -Wall + build-depends: + , base + , Cabal ^>=3.8.0.0 + , Cabal-syntax ^>=3.8.0.0 + , containers + , pretty + , QuickCheck + , rere >=0.1 && <0.3 + , tasty + , tasty-quickcheck + , transformers + + exposed-modules: + Distribution.Described + Distribution.Utils.CharSet + Distribution.Utils.GrammarRegex diff --git a/cabal/Cabal-described/src/Distribution/Described.hs b/cabal/Cabal-described/src/Distribution/Described.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-described/src/Distribution/Described.hs @@ -0,0 +1,577 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Distribution.Described ( + Described (..), + describeDoc, + -- * Regular expressions + GrammarRegex (..), + reEps, + reChar, + reChars, + reMunchCS, + reMunch1CS, + -- * Variables + reVar0, + reVar1, + -- * Special expressions + reDot, + reComma, + reSpacedComma, + reHsString, + reUnqualComponent, + -- * + describeFlagAssignmentNonEmpty, + -- * Lists + reSpacedList, + reCommaList, + reCommaNonEmpty, + reOptCommaList, + -- * Character Sets + csChar, + csAlpha, + csAlphaNum, + csUpper, + csNotSpace, + csNotSpaceOrComma, + -- * tasty + testDescribed, + ) where + +import Prelude + (Bool (..), Char, Either (..), Enum (..), Eq (..), Ord (..), Show (..), String, elem, fmap, foldr, id, map, maybe, otherwise, return, undefined, ($), + (.)) + +import Data.Functor.Identity (Identity (..)) +import Data.Maybe (fromMaybe) +import Data.Proxy (Proxy (..)) +import Data.String (IsString (..)) +import Data.Typeable (Typeable, typeOf) +import Data.Void (Void, vacuous) +import Test.QuickCheck (Arbitrary (..), Property, counterexample) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) + +import Distribution.Compat.Semigroup (Semigroup (..)) +import Distribution.Parsec (Parsec, eitherParsec) +import Distribution.Pretty (Pretty, prettyShow) + +import qualified Distribution.Utils.CharSet as CS +import qualified RERE as RE +import qualified RERE.CharSet as RE +import qualified Text.PrettyPrint as PP + +import Distribution.Utils.GrammarRegex + +-- Types +import Distribution.Compat.Newtype +import Distribution.Compiler (CompilerFlavor, CompilerId, knownCompilerFlavors) +import Distribution.FieldGrammar.Newtypes +import Distribution.ModuleName (ModuleName) +import Distribution.System (Arch, OS, knownArches, knownOSs) +import Distribution.Types.AbiDependency (AbiDependency) +import Distribution.Types.AbiHash (AbiHash) +import Distribution.Types.BenchmarkType (BenchmarkType) +import Distribution.Types.BuildType (BuildType) +import Distribution.Types.Dependency (Dependency) +import Distribution.Types.ExecutableScope (ExecutableScope) +import Distribution.Types.ExeDependency (ExeDependency) +import Distribution.Types.ExposedModule (ExposedModule) +import Distribution.Types.Flag (FlagAssignment, FlagName) +import Distribution.Types.ForeignLib (LibVersionInfo) +import Distribution.Types.ForeignLibOption (ForeignLibOption) +import Distribution.Types.ForeignLibType (ForeignLibType) +import Distribution.Types.IncludeRenaming (IncludeRenaming) +import Distribution.Types.LegacyExeDependency (LegacyExeDependency) +import Distribution.Types.LibraryVisibility (LibraryVisibility) +import Distribution.Types.Mixin (Mixin) +import Distribution.Types.ModuleReexport (ModuleReexport) +import Distribution.Types.ModuleRenaming (ModuleRenaming) +import Distribution.Types.MungedPackageName (MungedPackageName) +import Distribution.Types.PackageId (PackageIdentifier) +import Distribution.Types.PackageName (PackageName) +import Distribution.Types.PackageVersionConstraint (PackageVersionConstraint) +import Distribution.Types.PkgconfigDependency (PkgconfigDependency) +import Distribution.Types.SourceRepo (RepoType) +import Distribution.Types.TestType (TestType) +import Distribution.Types.UnitId (UnitId) +import Distribution.Types.UnqualComponentName (UnqualComponentName) +import Distribution.Verbosity (Verbosity) +import Distribution.Version (Version, VersionRange) +import Language.Haskell.Extension (Extension, Language) + +-- | Class describing the pretty/parsec format of a. +class (Pretty a, Parsec a) => Described a where + -- | A pretty document of "regex" describing the field format + describe :: proxy a -> GrammarRegex void + +-- | Pretty-print description. +-- +-- >>> describeDoc ([] :: [Bool]) +-- \left\{ \mathop{\mathord{``}\mathtt{True}\mathord{"}}\mid\mathop{\mathord{``}\mathtt{False}\mathord{"}} \right\} +-- +describeDoc :: Described a => proxy a -> PP.Doc +describeDoc p = regexDoc (describe p) + +instance Described Bool where + describe _ = REUnion ["True", "False"] + +instance Described a => Described (Identity a) where + describe _ = describe ([] :: [a]) + +------------------------------------------------------------------------------- +-- Lists +------------------------------------------------------------------------------ + +reSpacedList :: GrammarRegex a -> GrammarRegex a +reSpacedList = REMunch RESpaces1 + +reCommaList :: GrammarRegex a -> GrammarRegex a +reCommaList = RECommaList + +reCommaNonEmpty :: GrammarRegex a -> GrammarRegex a +reCommaNonEmpty = RECommaNonEmpty + +reOptCommaList :: GrammarRegex a -> GrammarRegex a +reOptCommaList = REOptCommaList + +------------------------------------------------------------------------------- +-- Specific grammars +------------------------------------------------------------------------------- + +reHsString :: GrammarRegex a +reHsString = RENamed "hs-string" impl where + impl = reChar '"' <> REMunch reEps (REUnion [strChar, escChar]) <> reChar '"' + strChar = RECharSet $ CS.difference CS.universe (CS.fromList "\"\\") + + escChar = REUnion + [ "\\&" + , "\\\\" + , REUnion ["\\n", RENamed "escapes" "\\n"] -- TODO + , "\\" <> RECharSet "0123456789" + , "\\o" <> RECharSet "01234567" + , "\\x" <> RECharSet "0123456789abcdefABCDEF" + , REUnion ["\\^@", RENamed "control" "\\^@"] -- TODO + , REUnion ["\\NUL", RENamed "ascii" "\\NUL"] -- TODO + ] + +reUnqualComponent :: GrammarRegex a +reUnqualComponent = RENamed "unqual-name" $ + REMunch1 (reChar '-') component + where + component + = REMunch reEps (RECharSet csAlphaNum) + -- currently the parser accepts "csAlphaNum `difference` "0123456789" + -- which is larger set than CS.alpha + -- + -- Hackage rejects non ANSI names, so it's not so relevant. + <> RECharSet CS.alpha + <> REMunch reEps (RECharSet csAlphaNum) + +reDot :: GrammarRegex a +reDot = reChar '.' + +reComma :: GrammarRegex a +reComma = reChar ',' + +reSpacedComma :: GrammarRegex a +reSpacedComma = RESpaces <> reComma <> RESpaces + +------------------------------------------------------------------------------- +-- Character sets +------------------------------------------------------------------------------- + +csChar :: Char -> CS.CharSet +csChar = CS.singleton + +csAlpha :: CS.CharSet +csAlpha = CS.alpha + +csAlphaNum :: CS.CharSet +csAlphaNum = CS.alphanum + +csUpper :: CS.CharSet +csUpper = CS.upper + +csNotSpace :: CS.CharSet +csNotSpace = CS.difference CS.universe $ CS.singleton ' ' + +csNotSpaceOrComma :: CS.CharSet +csNotSpaceOrComma = CS.difference csNotSpace $ CS.singleton ',' + +------------------------------------------------------------------------------- +-- Special +------------------------------------------------------------------------------- + +describeFlagAssignmentNonEmpty :: GrammarRegex void +describeFlagAssignmentNonEmpty = REMunch1 RESpaces1 $ + REUnion [fromString "+", fromString "-"] <> describe (Proxy :: Proxy FlagName) + +------------------------------------------------------------------------------- +-- Conversion +------------------------------------------------------------------------------- + +convert :: GrammarRegex Void -> RE.RE Void +convert = go id . vacuous where + go :: Ord b => (a -> b) -> GrammarRegex a -> RE.RE b + go f (REAppend rs) = foldr (\r acc -> go f r <> acc) RE.Eps rs + go f (REUnion rs) = foldr (\r acc -> go f r RE.\/ acc) RE.Null rs + go _ (RECharSet cs) = RE.Ch (convertCS cs) + go _ (REString str) = RE.string_ str + + go f (REMunch sep r) = RE.Eps RE.\/ r' <> RE.star_ (sep' <> r') where + sep' = go f sep + r' = go f r + go f (REMunch1 sep r) = r' <> RE.star_ (sep' <> r') where + sep' = go f sep + r' = go f r + go f (REMunchR n sep r) + | n <= 0 = RE.Eps + | otherwise = RE.Eps RE.\/ r' <> go' (pred n) + where + sep' = go f sep + r' = go f r + + go' m | m <= 0 = RE.Eps + | otherwise = RE.Eps RE.\/ sep' <> r' <> go' (pred m) + + go f (REOpt r) = RE.Eps RE.\/ go f r + + go f (REVar a) = RE.Var (f a) + go f (RENamed _ r) = go f r + go f (RERec n r) = RE.fix_ (fromString n) + (go (maybe RE.B (RE.F . f)) r) + + go _ RESpaces = RE.Eps RE.\/ RE.ch_ ' ' RE.\/ " " RE.\/ "\n" + go _ RESpaces1 = RE.ch_ ' ' RE.\/ " " RE.\/ "\n" + + go f (RECommaList r) = go f (expandedCommaList r) + go f (RECommaNonEmpty r)= go f (expandedCommaNonEmpty r) + go f (REOptCommaList r) = go f (expandedOptCommaList r) + + go _ RETodo = RE.Null + +expandedCommaList :: GrammarRegex a -> GrammarRegex a +expandedCommaList = REUnion . expandedCommaList' + +expandedCommaNonEmpty :: GrammarRegex a -> GrammarRegex a +expandedCommaNonEmpty r = REUnion + [ REMunch1 reSpacedComma r + , reComma <> RESpaces <> REMunch1 reSpacedComma r + , REMunch1 reSpacedComma r <> RESpaces <> reComma + ] + +expandedCommaList' :: GrammarRegex a -> [GrammarRegex a] +expandedCommaList' r = + [ REMunch reSpacedComma r + , reComma <> RESpaces <> REMunch1 reSpacedComma r + , REMunch1 reSpacedComma r <> RESpaces <> reComma + ] + +expandedOptCommaList :: GrammarRegex a -> GrammarRegex a +expandedOptCommaList r = REUnion $ reSpacedList r : expandedCommaList' r + +convertCS :: CS.CharSet -> RE.CharSet +convertCS = RE.fromIntervalList . CS.toIntervalList + +------------------------------------------------------------------------------- +-- tasty +------------------------------------------------------------------------------- + +testDescribed + :: forall a. (Arbitrary a, Described a, Typeable a, Eq a, Show a) + => Proxy a + -> TestTree +testDescribed _ = testGroup name + [ testProperty "parsec" propParsec + , testProperty "pretty" propPretty + , testProperty "roundtrip" propRoundtrip + ] + where + name = show (typeOf (undefined :: a)) + + propParsec :: Ex a -> Property + propParsec (Example str) = counterexample (show res) $ case res of + Right _ -> True + Left _ -> False + where + res :: Either String a + res = eitherParsec str + + rr :: RE.RE Void + rr = convert $ describe (Proxy :: Proxy a) + + propPretty :: a -> Property + propPretty x = counterexample str $ RE.matchR rr str + where + str = prettyShow x + + propRoundtrip :: a -> Property + propRoundtrip x = counterexample (show (res, str)) $ case res of + Right y -> x == y + Left _ -> False + where + str = prettyShow x + res = eitherParsec str + +newtype Ex a = Example String + deriving (Show) + +instance Described a => Arbitrary (Ex a) where + arbitrary + = fmap Example + $ fromMaybe (return "") + $ RE.generate 10 5 + $ convert $ describe (Proxy :: Proxy a) + + shrink (Example s) + | '\n' `elem` s = [ Example $ map (\c -> if c == '\n' then ' ' else c) s ] + | otherwise = [] + +------------------------------------------------------------------------------- +-- Instances +------------------------------------------------------------------------------- + +instance Described AbiDependency where + describe _ = + describe (Proxy :: Proxy UnitId) <> + reChar '=' <> + describe (Proxy :: Proxy AbiHash) + +instance Described AbiHash where + describe _ = reMunchCS csAlphaNum + +instance Described Arch where + describe _ = REUnion + [ fromString (prettyShow arch) + | arch <- knownArches + ] + +instance Described BenchmarkType where + describe _ = "exitcode-stdio-1.0" + +instance Described BuildType where + describe _ = REUnion ["Simple","Configure","Custom","Make","Default"] + +instance Described CompilerFlavor where + describe _ = REUnion + [ fromString (prettyShow c) + | c <- knownCompilerFlavors + ] + +instance Described CompilerId where + describe _ = + describe (Proxy :: Proxy CompilerFlavor) + <> fromString "-" + <> describe (Proxy :: Proxy Version) + +instance Described Dependency where + describe _ = REAppend + [ RENamed "pkg-name" (describe (Proxy :: Proxy PackageName)) + , REOpt $ + reChar ':' + <> REUnion + [ reUnqualComponent + , REAppend + [ reChar '{' + , RESpaces + -- no leading or trailing comma + , REMunch1 reSpacedComma reUnqualComponent + , RESpaces + , reChar '}' + ] + ] + + , REOpt $ RESpaces <> vr + ] + where + vr = RENamed "version-range" (describe (Proxy :: Proxy VersionRange)) + +instance Described ExecutableScope where + describe _ = REUnion ["public","private"] + +instance Described ExeDependency where + describe _ = RETodo + +instance Described ExposedModule where + describe _ = RETodo + +instance Described Extension where + describe _ = RETodo + +instance Described FlagAssignment where + describe _ = REMunch RESpaces1 $ + REUnion [fromString "+", fromString "-"] <> describe (Proxy :: Proxy FlagName) + +instance Described FlagName where + describe _ = lead <> rest where + lead = RECharSet $ csAlphaNum <> fromString "_" + rest = reMunchCS $ csAlphaNum <> fromString "_-" + +instance Described ForeignLibOption where + describe _ = "standalone" + +instance Described ForeignLibType where + describe _ = REUnion ["native-shared","native-static"] + +instance Described IncludeRenaming where + describe _ = mr <> REOpt (RESpaces <> "requires" <> RESpaces1 <> mr) + where + mr = describe (Proxy :: Proxy ModuleRenaming) + +instance Described Language where + describe _ = REUnion ["Haskell98", "Haskell2010"] + +instance Described LegacyExeDependency where + describe _ = RETodo + +instance Described LibraryVisibility where + describe _ = REUnion ["public","private"] + +instance Described LibVersionInfo where + describe _ = reDigits <> REOpt (reChar ':' <> reDigits <> REOpt (reChar ':' <> reDigits)) where + reDigits = reChars ['0'..'9'] + +instance Described Mixin where + describe _ = + RENamed "package-name" (describe (Proxy :: Proxy PackageName)) <> + REOpt (reChar ':' <> RENamed "library-name" (describe (Proxy :: Proxy UnqualComponentName))) <> + REOpt (RESpaces1 <> describe (Proxy :: Proxy IncludeRenaming)) + +instance Described ModuleName where + describe _ = REMunch1 (reChar '.') component where + component = RECharSet csUpper <> REMunch reEps (REUnion [RECharSet csAlphaNum, RECharSet (fromString "_'")]) + +instance Described ModuleReexport where + describe _ = RETodo + +instance Described ModuleRenaming where + describe _ = REUnion + [ reEps + , "hiding" <> RESpaces <> bp (REMunch reSpacedComma mn) + , bp (REMunch reSpacedComma entry) + ] + where + bp r = "(" <> RESpaces <> r <> RESpaces <> ")" + mn = RENamed "module-name" $ describe (Proxy :: Proxy ModuleName) + + entry = mn <> REOpt (RESpaces1 <> "as" <> RESpaces1 <> mn) + +instance Described MungedPackageName where + describe _ = RETodo + +instance Described OS where + describe _ = REUnion + [ fromString (prettyShow os) + | os <- knownOSs + ] + +instance Described PackageIdentifier where + describe _ = describe (Proxy :: Proxy PackageName) <> fromString "-" <> describe (Proxy :: Proxy Version) + +instance Described PackageName where + describe _ = reUnqualComponent + +instance Described PackageVersionConstraint where + describe _ = describe (Proxy :: Proxy PackageName) <> REUnion + [ fromString "-" <> describe (Proxy :: Proxy Version) + , RESpaces <> describe (Proxy :: Proxy VersionRange) + ] + +instance Described PkgconfigDependency where + describe _ = RETodo + +instance Described RepoType where + describe _ = reMunch1CS $ csAlphaNum <> csChar '_' <> csChar '-' + +instance Described TestType where + describe _ = REUnion ["exitcode-stdio-1.0", "detailed-0.9"] + +instance Described Verbosity where + describe _ = REUnion + [ REUnion ["0", "1", "2", "3"] + , REUnion ["silent", "normal", "verbose", "debug", "deafening"] + <> REMunch reEps (RESpaces <> "+" <> + -- markoutput is left out on purpose + REUnion ["callsite", "callstack", "nowrap", "timestamp", "stderr", "stdout" ]) + ] + +instance Described Version where + describe _ = REMunch1 reDot reDigits where + reDigits = REUnion + [ reChar '0' + , reChars ['1'..'9'] <> REMunchR 8 reEps (reChars ['0'..'9']) + ] + +instance Described VersionRange where + describe _ = RERec "version-range" $ REUnion + [ "==" <> RESpaces <> ver + , ">" <> RESpaces <> ver + , "<" <> RESpaces <> ver + , "<=" <> RESpaces <> ver + , ">=" <> RESpaces <> ver + , "^>=" <> RESpaces <> ver + + -- ==0.1.* + , "==" <> RESpaces <> wildVer + + , reVar0 <> RESpaces <> "||" <> RESpaces <> reVar0 + , reVar0 <> RESpaces <> "&&" <> RESpaces <> reVar0 + , "(" <> RESpaces <> reVar0 <> RESpaces <> ")" + + -- == { 0.1.2 } + -- silly haddock: ^>= { 0.1.2, 3.4.5 } + , "==" <> RESpaces <> verSet + , "^>=" <> RESpaces <> verSet + ] + where + ver' = describe (Proxy :: Proxy Version) + ver = RENamed "version" ver' + wildVer = ver' <> ".*" + verSet = "{" <> RESpaces <> REMunch1 reSpacedComma ver <> RESpaces <> "}" + +instance Described UnitId where + describe _ = reMunch1CS $ csAlphaNum <> csChar '-' <> csChar '_' <> csChar '.' <> csChar '+' + +instance Described UnqualComponentName where + describe _ = reUnqualComponent + +------------------------------------------------------------------------------- +-- Instances: Newtypes +------------------------------------------------------------------------------- + +class Sep sep => DescribeSep sep where + describeSep :: Proxy sep -> GrammarRegex a -> GrammarRegex a + +instance DescribeSep CommaVCat where describeSep _ = reCommaList +instance DescribeSep CommaFSep where describeSep _ = reCommaList +instance DescribeSep VCat where describeSep _ = reCommaList +instance DescribeSep FSep where describeSep _ = reOptCommaList +instance DescribeSep NoCommaFSep where describeSep _ = reSpacedList + +instance (Newtype a b, DescribeSep sep, Described b) => Described (List sep b a) where + describe _ = describeSep (Proxy :: Proxy sep) (describe (Proxy :: Proxy b)) + +instance (Newtype a b, Ord a, DescribeSep sep, Described b) => Described (Set' sep b a) where + describe _ = describeSep (Proxy :: Proxy sep) (describe (Proxy :: Proxy b)) + +instance Described Token where + describe _ = REUnion [reHsString, reMunch1CS csNotSpaceOrComma] + +instance Described Token' where + describe _ = REUnion [reHsString, reMunch1CS csNotSpace] + +instance Described a => Described (MQuoted a) where + -- TODO: this is simplification + describe _ = describe ([] :: [a]) + +instance Described SpecVersion where + describe _ = "3.4" -- :) + +instance Described SpecLicense where + describe _ = RETodo + +instance Described TestedWith where + describe _ = RETodo + +instance Described FilePathNT where + describe _ = describe ([] :: [Token]) diff --git a/cabal/Cabal-described/src/Distribution/Utils/CharSet.hs b/cabal/Cabal-described/src/Distribution/Utils/CharSet.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-described/src/Distribution/Utils/CharSet.hs @@ -0,0 +1,242 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +-- | Sets of characters. +-- +-- Using this is more efficient than 'RE.Type.Alt':ng individual characters. +module Distribution.Utils.CharSet ( + -- * Set of characters + CharSet, + -- * Construction + empty, + universe, + singleton, + insert, + union, + intersection, + complement, + difference, + -- * Query + size, + null, + member, + -- * Conversions + fromList, + toList, + fromIntervalList, + toIntervalList, + -- * Special lists + alpha, + alphanum, + upper, + ) where + +import Data.Char (chr, isAlpha, isAlphaNum, isUpper, ord) +import Data.List (foldl', sortBy) +import Data.Monoid (Monoid (..)) +import Data.String (IsString (..)) +import Distribution.Compat.Semigroup (Semigroup (..)) +import Prelude + (Bool (..), Bounded (..), Char, Enum (..), Eq (..), Int, Maybe (..), Num (..), Ord (..), Show (..), String, concatMap, flip, fst, otherwise, showParen, + showString, uncurry, ($), (.)) + +#if MIN_VERSION_containers(0,5,0) +import qualified Data.IntMap.Strict as IM +#else +import qualified Data.IntMap as IM +#endif + +-- | A set of 'Char's. +-- +-- We use range set, which works great with 'Char'. +newtype CharSet = CS { unCS :: IM.IntMap Int } + deriving (Eq, Ord) + +instance IsString CharSet where + fromString = fromList + +instance Show CharSet where + showsPrec d cs + | size cs < 20 + = showsPrec d (toList cs) + | otherwise + = showParen (d > 10) + $ showString "CS " + . showsPrec 11 (unCS cs) + +instance Semigroup CharSet where + (<>) = union + +instance Monoid CharSet where + mempty = empty + mappend = (<>) + +-- | Empty character set. +empty :: CharSet +empty = CS IM.empty + +-- | universe +universe :: CharSet +universe = CS $ IM.singleton 0 0x10ffff + +-- | Check whether 'CharSet' is 'empty'. +null :: CharSet -> Bool +null (CS cs) = IM.null cs + +-- | Size of 'CharSet' +-- +-- >>> size $ fromIntervalList [('a','f'), ('0','9')] +-- 16 +-- +-- >>> length $ toList $ fromIntervalList [('a','f'), ('0','9')] +-- 16 +-- +size :: CharSet -> Int +size (CS m) = foldl' (\ !acc (lo, hi) -> acc + (hi - lo) + 1) 0 (IM.toList m) + +-- | Singleton character set. +singleton :: Char -> CharSet +singleton c = CS (IM.singleton (ord c) (ord c)) + +-- | Test whether character is in the set. +member :: Char -> CharSet -> Bool +#if MIN_VERSION_containers(0,5,0) +member c (CS m) = case IM.lookupLE i m of + Nothing -> False + Just (_, hi) -> i <= hi + where +#else +member c (CS m) = go (IM.toList m) + where + go [] = False + go ((x,y):zs) = (x <= i && i <= y) || go zs +#endif + i = ord c + +-- | Insert 'Char' into 'CharSet'. +insert :: Char -> CharSet -> CharSet +insert c (CS m) = normalise (IM.insert (ord c) (ord c) m) + +-- | Union of two 'CharSet's. +union :: CharSet -> CharSet -> CharSet +union (CS xs) (CS ys) = normalise (IM.unionWith max xs ys) + +-- | Intersection of two 'CharSet's +intersection :: CharSet -> CharSet -> CharSet +intersection (CS xs) (CS ys) = CS $ + IM.fromList (intersectRangeList (IM.toList xs) (IM.toList ys)) + +-- | Compute the intersection. +intersectRangeList :: Ord a => [(a, a)] -> [(a, a)] -> [(a, a)] +intersectRangeList aset@((x,y):as) bset@((u,v):bs) + | y < u = intersectRangeList as bset + | v < x = intersectRangeList aset bs + | y < v = (max x u, y) : intersectRangeList as bset + | otherwise = (max x u, v) : intersectRangeList aset bs +intersectRangeList _ [] = [] +intersectRangeList [] _ = [] + +-- | Complement of a CharSet +complement :: CharSet -> CharSet +complement (CS xs) = CS $ IM.fromList $ complementRangeList (IM.toList xs) + +-- | Compute the complement intersected with @[x,)@ assuming @x [(Int, Int)] -> [(Int, Int)] +complementRangeList' x ((u,v):s) = (x,pred u) : complementRangeList'' v s +complementRangeList' x [] = [(x,0x10ffff)] + +-- | Compute the complement intersected with @(x,)@. +complementRangeList'' :: Int -> [(Int, Int)] -> [(Int, Int)] +complementRangeList'' x s + | x == 0x10ffff = [] + | otherwise = complementRangeList' (succ x) s + +-- | Compute the complement. +-- +-- Note: we treat Ints as codepoints, i.e minBound is 0, and maxBound is 0x10ffff +complementRangeList :: [(Int, Int)] -> [(Int, Int)] +complementRangeList s@((x,y):s') + | x == 0 = complementRangeList'' y s' + | otherwise = complementRangeList' 0 s +complementRangeList [] = [(0, 0x10ffff)] + +-- | Difference of two 'CharSet's. +difference :: CharSet -> CharSet -> CharSet +difference xs ys = intersection xs (complement ys) + +-- | Make 'CharSet' from a list of characters, i.e. 'String'. +fromList :: String -> CharSet +fromList = normalise . foldl' (\ acc c -> IM.insert (ord c) (ord c) acc) IM.empty + +-- | Convert 'CharSet' to a list of characters i.e. 'String'. +toList :: CharSet -> String +toList = concatMap (uncurry enumFromTo) . toIntervalList + +-- | Convert to interval list +-- +-- >>> toIntervalList $ union "01234" "56789" +-- [('0','9')] +-- +toIntervalList :: CharSet -> [(Char, Char)] +toIntervalList (CS m) = [ (chr lo, chr hi) | (lo, hi) <- IM.toList m ] + +-- | Convert from interval pairs. +-- +-- >>> fromIntervalList [] +-- "" +-- +-- >>> fromIntervalList [('a','f'), ('0','9')] +-- "0123456789abcdef" +-- +-- >>> fromIntervalList [('Z','A')] +-- "" +-- +fromIntervalList :: [(Char,Char)] -> CharSet +fromIntervalList xs = normalise' $ sortBy (\a b -> compare (fst a) (fst b)) + [ (ord lo, ord hi) + | (lo, hi) <- xs + , lo <= hi + ] + +------------------------------------------------------------------------------- +-- Normalisation +------------------------------------------------------------------------------- + +normalise :: IM.IntMap Int -> CharSet +normalise = normalise'. IM.toList + +normalise' :: [(Int,Int)] -> CharSet +normalise' = CS . IM.fromList . go where + go :: [(Int,Int)] -> [(Int,Int)] + go [] = [] + go ((x,y):zs) = go' x y zs + + go' :: Int -> Int -> [(Int, Int)] -> [(Int, Int)] + go' lo hi [] = [(lo, hi)] + go' lo hi ws0@((u,v):ws) + | u <= succ hi = go' lo (max v hi) ws + | otherwise = (lo,hi) : go ws0 + +------------------------------------------------------------------------------- +-- Alpha Numeric character list +------------------------------------------------------------------------------- + +-- Computing this takes some time, +-- but they are not used in-non testing in Cabal's normal operation. + +-- | Note: this set varies depending on @base@ version. +-- +alpha :: CharSet +alpha = foldl' (flip insert) empty [ c | c <- [ minBound .. maxBound ], isAlpha c ] +{-# NOINLINE alpha #-} + +-- | Note: this set varies depending on @base@ version. +-- +alphanum :: CharSet +alphanum = foldl' (flip insert) empty [ c | c <- [ minBound .. maxBound ], isAlphaNum c ] +{-# NOINLINE alphanum #-} + +-- | Note: this set varies depending on @base@ version. +-- +upper :: CharSet +upper = foldl' (flip insert) empty [ c | c <- [ minBound .. maxBound ], isUpper c ] +{-# NOINLINE upper #-} diff --git a/cabal/Cabal-described/src/Distribution/Utils/GrammarRegex.hs b/cabal/Cabal-described/src/Distribution/Utils/GrammarRegex.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-described/src/Distribution/Utils/GrammarRegex.hs @@ -0,0 +1,215 @@ +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Distribution.Utils.GrammarRegex ( + -- * Regular expressions + GrammarRegex (..), + reEps, + reChar, + reChars, + reMunchCS, + reMunch1CS, + -- * Variables + reVar0, + reVar1, + -- * Pretty-printing + regexDoc, + ) where + +import Data.Char (isAlphaNum, isControl, ord) +import Data.Foldable (Foldable) +import Data.Maybe (fromMaybe) +import Data.Monoid (Monoid (..)) +import Data.String (IsString (..)) +import Data.Traversable (Traversable) +import Data.Void (Void, vacuous) +import Distribution.Compat.Semigroup (Semigroup (..)) +import Prelude (Bool (..), Char, Eq (..), Functor, Int, Maybe (..), Ord (..), Show, String, fmap, length, map, otherwise, ($), (++), (.)) + +import qualified Distribution.Utils.CharSet as CS +import qualified Text.PrettyPrint as PP + +(<<>>) :: PP.Doc -> PP.Doc -> PP.Doc +(<<>>) = (PP.<>) + +------------------------------------------------------------------------------- +-- GrammarRegex +------------------------------------------------------------------------------- + +-- | Recursive regular expressions tuned for 'Described' use-case. +data GrammarRegex a + = REAppend [GrammarRegex a] -- ^ append @ab@ + | REUnion [GrammarRegex a] -- ^ union @a|b@ + + -- repetition + | REMunch (GrammarRegex a) (GrammarRegex a) -- ^ star @a*@, with a separator + | REMunch1 (GrammarRegex a) (GrammarRegex a) -- ^ plus @a+@, with a separator + | REMunchR Int (GrammarRegex a) (GrammarRegex a) -- ^ 1-n, with a separator + | REOpt (GrammarRegex a) -- ^ optional @r?@ + + | REString String -- ^ literal string @abcd@ + | RECharSet CS.CharSet -- ^ charset @[:alnum:]@ + | REVar a -- ^ variable + | RENamed String (GrammarRegex a) -- ^ named expression + | RERec String (GrammarRegex (Maybe a)) -- ^ recursive expressions + + -- cabal syntax specifics + | RESpaces -- ^ zero-or-more spaces + | RESpaces1 -- ^ one-or-more spaces + | RECommaList (GrammarRegex a) -- ^ comma list (note, leading or trailing commas) + | RECommaNonEmpty (GrammarRegex a) -- ^ comma non-empty list (note, leading or trailing commas) + | REOptCommaList (GrammarRegex a) -- ^ opt comma list + + | RETodo -- ^ unspecified + deriving (Eq, Ord, Show, Functor, Foldable, Traversable) + +------------------------------------------------------------------------------- +-- Instances +------------------------------------------------------------------------------- + +instance IsString (GrammarRegex a) where + fromString = REString + +instance Semigroup (GrammarRegex a) where + x <> y = REAppend (unAppend x ++ unAppend y) where + unAppend (REAppend rs) = rs + unAppend r = [r] + +instance Monoid (GrammarRegex a) where + mempty = REAppend [] + mappend = (<>) + +------------------------------------------------------------------------------- +-- Smart constructors +------------------------------------------------------------------------------- + +reEps :: GrammarRegex a +reEps = REAppend [] + +reChar :: Char -> GrammarRegex a +reChar = RECharSet . CS.singleton + +reChars :: [Char] -> GrammarRegex a +reChars = RECharSet . CS.fromList + +reMunch1CS :: CS.CharSet -> GrammarRegex a +reMunch1CS = REMunch1 reEps . RECharSet + +reMunchCS :: CS.CharSet -> GrammarRegex a +reMunchCS = REMunch reEps . RECharSet + +------------------------------------------------------------------------------- +-- Variables +------------------------------------------------------------------------------- + +reVar0 :: GrammarRegex (Maybe a) +reVar0 = REVar Nothing + +reVar1 :: GrammarRegex (Maybe (Maybe a)) +reVar1 = REVar (Just Nothing) + +------------------------------------------------------------------------------- +-- Pretty-printing +------------------------------------------------------------------------------- + +-- | +-- +-- >>> regexDoc $ REString "True" +-- \mathop{\mathord{``}\mathtt{True}\mathord{"}} +-- +-- Note: we don't simplify regexps yet: +-- +-- >>> regexDoc $ REString "foo" <> REString "bar" +-- \mathop{\mathord{``}\mathtt{foo}\mathord{"}}\mathop{\mathord{``}\mathtt{bar}\mathord{"}} +-- +regexDoc :: GrammarRegex Void -> PP.Doc +regexDoc = go 0 . vacuous where + go :: Int -> GrammarRegex PP.Doc -> PP.Doc + go _ (REAppend []) = "" + go d (REAppend rs) = parensIf (d > 2) $ PP.hcat (map (go 2) rs) + go d (REUnion [r]) = go d r + go _ (REUnion rs) = PP.hsep + [ "\\left\\{" + , if length rs < 4 + then PP.hcat (PP.punctuate (PP.text "\\mid") (map (go 0) rs)) + else "\\begin{gathered}" <<>> + PP.hcat (PP.punctuate "\\\\" (map (go 0) rs)) <<>> + "\\end{gathered}" + , "\\right\\}" ] + + go d (REMunch sep r) = parensIf (d > 3) $ + PP.text "{" <<>> go 4 r <<>> PP.text "}^\\ast_{" <<>> go 4 sep <<>> PP.text "}" + go d (REMunch1 sep r) = parensIf (d > 3) $ + PP.text "{" <<>> go 4 r <<>> PP.text "}^+_{" <<>> go 4 sep <<>> PP.text "}" + go d (REMunchR n sep r) = parensIf (d > 3) $ + PP.text "{" <<>> go 4 r <<>> PP.text "}^{\\in [0\\ldots" <<>> PP.int n <<>> "]}_{" <<>> go 4 sep <<>> PP.text "}" + go d (REOpt r) = parensIf (d > 3) $ + PP.text "{" <<>> go 4 r <<>> PP.text "}^?" + + go _ (REString s) = PP.text "\\mathop{\\mathord{``}\\mathtt{" <<>> PP.hcat (map charDoc s) <<>> PP.text "}\\mathord{\"}}" + go _ (RECharSet cs) = charsetDoc cs + + go _ RESpaces = "\\circ" + go _ RESpaces1 = "\\bullet" + + go _ (RECommaList r) = + "\\mathrm{commalist}" <<>> go 4 r + go _ (RECommaNonEmpty r) = + "\\mathrm{commanonempty}" <<>> go 4 r + go _ (REOptCommaList r) = + "\\mathrm{optcommalist}" <<>> go 4 r + + go _ (REVar a) = a + go _ (RENamed n _) = terminalDoc n + go d (RERec n r) = parensIf (d > 0) $ + "\\mathbf{fix}\\;" <<>> n' <<>> "\\;\\mathbf{in}\\;" <<>> + go 0 (fmap (fromMaybe n') r) + where + n' = terminalDoc n + + go _ RETodo = PP.text "\\mathsf{\\color{red}{TODO}}" + + parensIf :: Bool -> PP.Doc -> PP.Doc + parensIf True d = PP.text "\\left(" <<>> d <<>> PP.text "\\right)" + parensIf False d = d + +terminalDoc :: String -> PP.Doc +terminalDoc s = PP.text "\\mathop{\\mathit{" <<>> PP.hcat (map charDoc s) <<>> PP.text "}}" + +charDoc :: Char -> PP.Doc +charDoc ' ' = PP.text "\\ " +charDoc '{' = PP.text "\\{" +charDoc '}' = PP.text "\\}" +charDoc '\\' = PP.text "\\text{\\\\}" +charDoc c + | isAlphaNum c = PP.char c + | isControl c = PP.int (ord c) -- TODO: some syntax + | otherwise = PP.text ("\\text{" ++ c : "}") + +inquotes :: PP.Doc -> PP.Doc +inquotes d = "\\mathop{\\mathord{``}" <<>> d <<>> "\\mathord{\"}}" + +mathtt :: PP.Doc -> PP.Doc +mathtt d = "\\mathtt{" <<>> d <<>> "}" + +charsetDoc :: CS.CharSet -> PP.Doc +charsetDoc acs + | acs == CS.alpha = terminalDoc "alpha" + | acs == CS.alphanum = terminalDoc "alpha-num" + | acs == CS.upper = terminalDoc "upper" +charsetDoc acs = case CS.toIntervalList acs of + [] -> "\\emptyset" + [(x,y)] | x == y -> inquotes $ mathtt $ charDoc x + rs + | CS.size acs <= CS.size notAcs + -> PP.brackets $ PP.hcat $ map rangeDoc rs + | otherwise + -> PP.braces $ PP.brackets (PP.hcat $ map rangeDoc (CS.toIntervalList notAcs)) <<>> PP.text "^c" + where + notAcs = CS.complement acs + + rangeDoc :: (Char, Char) -> PP.Doc + rangeDoc (x, y) | x == y = inquotes (mathtt $ charDoc x) + | otherwise = inquotes (mathtt $ charDoc x) <<>> PP.text "\\cdots" <<>> inquotes (mathtt $ charDoc y) diff --git a/cabal/Cabal-syntax/Cabal-syntax.cabal b/cabal/Cabal-syntax/Cabal-syntax.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/Cabal-syntax.cabal @@ -0,0 +1,226 @@ +cabal-version: 1.22 +name: Cabal-syntax +version: 3.8.1.0 +copyright: 2003-2022, Cabal Development Team (see AUTHORS file) +license: BSD3 +license-file: LICENSE +author: Cabal Development Team +maintainer: cabal-devel@haskell.org +homepage: http://www.haskell.org/cabal/ +bug-reports: https://github.com/haskell/cabal/issues +synopsis: A library for working with .cabal files +description: + This library provides tools for reading and manipulating the .cabal file + format. +category: Distribution +build-type: Simple + +extra-source-files: + README.md ChangeLog.md + +source-repository head + type: git + location: https://github.com/haskell/cabal/ + subdir: Cabal-syntax + +library + default-language: Haskell2010 + hs-source-dirs: src + + build-depends: + array >= 0.4.0.1 && < 0.6, + base >= 4.6 && < 5, + binary >= 0.7 && < 0.9, + bytestring >= 0.10.0.0 && < 0.12, + containers >= 0.5.0.0 && < 0.7, + deepseq >= 1.3.0.1 && < 1.5, + directory >= 1.2 && < 1.4, + filepath >= 1.3.0.1 && < 1.5, + mtl >= 2.1 && < 2.3, + parsec >= 3.1.13.0 && < 3.2, + pretty >= 1.1.1 && < 1.2, + text (>= 1.2.3.0 && < 1.3) || (>= 2.0 && < 2.1), + time >= 1.4.0.1 && < 1.13, + -- transformers-0.4.0.0 doesn't have record syntax e.g. for Identity + -- See also https://github.com/ekmett/transformers-compat/issues/35 + transformers (>= 0.3 && < 0.4) || (>=0.4.1.0 && <0.6) + + if os(windows) + build-depends: Win32 >= 2.3.0.0 && < 2.14 + else + build-depends: unix >= 2.6.0.0 && < 2.8 + + ghc-options: -Wall -fno-ignore-asserts -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates + + if impl(ghc >= 8.0) + ghc-options: -Wcompat -Wnoncanonical-monad-instances + + if impl(ghc >= 8.0) && impl(ghc < 8.8) + ghc-options: -Wnoncanonical-monadfail-instances + + exposed-modules: + Distribution.Backpack + Distribution.CabalSpecVersion + Distribution.Compat.Binary + Distribution.Compat.CharParsing + Distribution.Compat.DList + Distribution.Compat.Exception + Distribution.Compat.Graph + Distribution.Compat.Lens + Distribution.Compat.MonadFail + Distribution.Compat.Newtype + Distribution.Compat.NonEmptySet + Distribution.Compat.Parsing + Distribution.Compat.Prelude + Distribution.Compat.Semigroup + Distribution.Compat.Typeable + Distribution.Compiler + Distribution.FieldGrammar + Distribution.FieldGrammar.Class + Distribution.FieldGrammar.FieldDescrs + Distribution.FieldGrammar.Newtypes + Distribution.FieldGrammar.Parsec + Distribution.FieldGrammar.Pretty + Distribution.Fields + Distribution.Fields.ConfVar + Distribution.Fields.Field + Distribution.Fields.Lexer + Distribution.Fields.LexerMonad + Distribution.Fields.ParseResult + Distribution.Fields.Parser + Distribution.Fields.Pretty + Distribution.InstalledPackageInfo + Distribution.License + Distribution.ModuleName + Distribution.Package + Distribution.PackageDescription + Distribution.PackageDescription.Configuration + Distribution.PackageDescription.FieldGrammar + Distribution.PackageDescription.Parsec + Distribution.PackageDescription.PrettyPrint + Distribution.PackageDescription.Quirks + Distribution.PackageDescription.Utils + Distribution.Parsec + Distribution.Parsec.Error + Distribution.Parsec.FieldLineStream + Distribution.Parsec.Position + Distribution.Parsec.Warning + Distribution.Pretty + Distribution.SPDX + Distribution.SPDX.License + Distribution.SPDX.LicenseExceptionId + Distribution.SPDX.LicenseExpression + Distribution.SPDX.LicenseId + Distribution.SPDX.LicenseListVersion + Distribution.SPDX.LicenseReference + Distribution.System + Distribution.Text + Distribution.Types.AbiDependency + Distribution.Types.AbiHash + Distribution.Types.Benchmark + Distribution.Types.Benchmark.Lens + Distribution.Types.BenchmarkInterface + Distribution.Types.BenchmarkType + Distribution.Types.BuildInfo + Distribution.Types.BuildInfo.Lens + Distribution.Types.BuildType + Distribution.Types.Component + Distribution.Types.ComponentId + Distribution.Types.ComponentName + Distribution.Types.ComponentRequestedSpec + Distribution.Types.CondTree + Distribution.Types.Condition + Distribution.Types.ConfVar + Distribution.Types.Dependency + Distribution.Types.DependencyMap + Distribution.Types.ExeDependency + Distribution.Types.Executable + Distribution.Types.Executable.Lens + Distribution.Types.ExecutableScope + Distribution.Types.ExposedModule + Distribution.Types.Flag + Distribution.Types.ForeignLib + Distribution.Types.ForeignLib.Lens + Distribution.Types.ForeignLibOption + Distribution.Types.ForeignLibType + Distribution.Types.GenericPackageDescription + Distribution.Types.GenericPackageDescription.Lens + Distribution.Types.HookedBuildInfo + Distribution.Types.IncludeRenaming + Distribution.Types.InstalledPackageInfo + Distribution.Types.InstalledPackageInfo.Lens + Distribution.Types.InstalledPackageInfo.FieldGrammar + Distribution.Types.LegacyExeDependency + Distribution.Types.Lens + Distribution.Types.Library + Distribution.Types.Library.Lens + Distribution.Types.LibraryName + Distribution.Types.LibraryVisibility + Distribution.Types.Mixin + Distribution.Types.Module + Distribution.Types.ModuleReexport + Distribution.Types.ModuleRenaming + Distribution.Types.MungedPackageId + Distribution.Types.MungedPackageName + Distribution.Types.PackageDescription + Distribution.Types.PackageDescription.Lens + Distribution.Types.PackageId + Distribution.Types.PackageId.Lens + Distribution.Types.PackageName + Distribution.Types.PackageVersionConstraint + Distribution.Types.PkgconfigDependency + Distribution.Types.PkgconfigName + Distribution.Types.PkgconfigVersion + Distribution.Types.PkgconfigVersionRange + Distribution.Types.SetupBuildInfo + Distribution.Types.SetupBuildInfo.Lens + Distribution.Types.SourceRepo + Distribution.Types.SourceRepo.Lens + Distribution.Types.TestSuite + Distribution.Types.TestSuite.Lens + Distribution.Types.TestSuiteInterface + Distribution.Types.TestType + Distribution.Types.UnitId + Distribution.Types.UnqualComponentName + Distribution.Types.Version + Distribution.Types.VersionInterval + Distribution.Types.VersionInterval.Legacy + Distribution.Types.VersionRange + Distribution.Types.VersionRange.Internal + Distribution.Utils.Base62 + Distribution.Utils.Generic + Distribution.Utils.MD5 + Distribution.Utils.Path + Distribution.Utils.ShortText + Distribution.Utils.String + Distribution.Utils.Structured + Distribution.Version + Language.Haskell.Extension + + other-extensions: + BangPatterns + CPP + DefaultSignatures + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + ExistentialQuantification + FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving + ImplicitParams + KindSignatures + NondecreasingIndentation + OverloadedStrings + PatternSynonyms + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + Trustworthy + TypeFamilies + TypeOperators + TypeSynonymInstances + UndecidableInstances diff --git a/cabal/Cabal-syntax/ChangeLog.md b/cabal/Cabal-syntax/ChangeLog.md new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/ChangeLog.md @@ -0,0 +1,1 @@ +Please see https://hackage.haskell.org/package/Cabal/changelog diff --git a/cabal/Cabal-syntax/LICENSE b/cabal/Cabal-syntax/LICENSE new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/LICENSE @@ -0,0 +1,34 @@ +Copyright (c) 2003-2022, Cabal Development Team. +See the AUTHORS file for the full list of copyright holders. + +See */LICENSE for the copyright holders of the subcomponents. + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/cabal/Cabal-syntax/README.md b/cabal/Cabal-syntax/README.md new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/README.md @@ -0,0 +1,67 @@ +The Cabal-syntax package +======================== + +See the [Cabal web site] for more information. + +The `Cabal-syntax` package defines the syntax of the `.cabal` file format +and provides tools for parsing `.cabal` files. + +More information +================ + +Please see the [Cabal web site] for the [user guide] and [API +documentation]. There is additional information available on the +[development wiki]. + +[user guide]: http://www.haskell.org/cabal/users-guide +[API documentation]: http://www.haskell.org/cabal/release/cabal-latest/doc/API/Cabal/Distribution-Simple.html +[development wiki]: https://github.com/haskell/cabal/wiki + + +Bugs +==== + +Please report bugs and feature requests to Cabal's [bug tracker]. + + +Your help +--------- + +To help Cabal's development, it is enormously helpful to know from +Cabal's users what their most pressing problems are with Cabal and +[Hackage]. You may have a favourite Cabal bug or limitation. Look at +Cabal's [bug tracker]. Ensure that the problem is reported there and +adequately described. Comment on the issue to report how much of a +problem the bug is for you. Subscribe to the issue's notifications to +discuss requirements and keep informed on progress. For feature +requests, it is helpful if there is a description of how you would +expect to interact with the new feature. + +[Hackage]: http://hackage.haskell.org + + +Source code +=========== + +You can get the master development branch using: + + $ git clone https://github.com/haskell/cabal.git + + +Credits +======= + +See the `AUTHORS` file. + +Authors of the [original Cabal +specification](https://www.haskell.org/cabal/proposal/pkg-spec.pdf): + +- Isaac Jones +- Simon Marlow +- Ross Patterson +- Simon Peyton Jones +- Malcolm Wallace + + +[bug tracker]: https://github.com/haskell/cabal/issues +[Cabal web site]: http://www.haskell.org/cabal/ diff --git a/cabal/Cabal-syntax/Setup.hs b/cabal/Cabal-syntax/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main :: IO () +main = defaultMain diff --git a/cabal/Cabal-syntax/src/Distribution/Backpack.hs b/cabal/Cabal-syntax/src/Distribution/Backpack.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Backpack.hs @@ -0,0 +1,269 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RankNTypes #-} + +-- | This module defines the core data types for Backpack. For more +-- details, see: +-- +-- + +module Distribution.Backpack ( + -- * OpenUnitId + OpenUnitId(..), + openUnitIdFreeHoles, + mkOpenUnitId, + + -- * DefUnitId + DefUnitId, + unDefUnitId, + mkDefUnitId, + + -- * OpenModule + OpenModule(..), + openModuleFreeHoles, + + -- * OpenModuleSubst + OpenModuleSubst, + dispOpenModuleSubst, + dispOpenModuleSubstEntry, + parsecOpenModuleSubst, + parsecOpenModuleSubstEntry, + openModuleSubstFreeHoles, + + -- * Conversions to 'UnitId' + abstractUnitId, + hashModuleSubst, +) where + +import Distribution.Compat.Prelude hiding (mod) +import Distribution.Parsec +import Distribution.Pretty +import Prelude () +import Text.PrettyPrint (hcat) + +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as Disp + +import Distribution.ModuleName +import Distribution.Types.ComponentId +import Distribution.Types.Module +import Distribution.Types.UnitId +import Distribution.Utils.Base62 + +import qualified Data.Map as Map +import qualified Data.Set as Set + +----------------------------------------------------------------------- +-- OpenUnitId + +-- | An 'OpenUnitId' describes a (possibly partially) instantiated +-- Backpack component, with a description of how the holes are filled +-- in. Unlike 'OpenUnitId', the 'ModuleSubst' is kept in a structured +-- form that allows for substitution (which fills in holes.) This form +-- of unit cannot be installed. It must first be converted to a +-- 'UnitId'. +-- +-- In the absence of Backpack, there are no holes to fill, so any such +-- component always has an empty module substitution; thus we can lossily +-- represent it as a 'DefiniteUnitId uid'. +-- +-- For a source component using Backpack, however, there is more +-- structure as components may be parametrized over some signatures, and +-- these \"holes\" may be partially or wholly filled. +-- +-- OpenUnitId plays an important role when we are mix-in linking, +-- and is recorded to the installed packaged database for indefinite +-- packages; however, for compiled packages that are fully instantiated, +-- we instantiate 'OpenUnitId' into 'UnitId'. +-- +-- For more details see the Backpack spec +-- +-- + +data OpenUnitId + -- | Identifies a component which may have some unfilled holes; + -- specifying its 'ComponentId' and its 'OpenModuleSubst'. + -- TODO: Invariant that 'OpenModuleSubst' is non-empty? + -- See also the Text instance. + = IndefFullUnitId ComponentId OpenModuleSubst + -- | Identifies a fully instantiated component, which has + -- been compiled and abbreviated as a hash. The embedded 'UnitId' + -- MUST NOT be for an indefinite component; an 'OpenUnitId' + -- is guaranteed not to have any holes. + | DefiniteUnitId DefUnitId + deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) +-- TODO: cache holes? + +instance Binary OpenUnitId +instance Structured OpenUnitId +instance NFData OpenUnitId where + rnf (IndefFullUnitId cid subst) = rnf cid `seq` rnf subst + rnf (DefiniteUnitId uid) = rnf uid + +instance Pretty OpenUnitId where + pretty (IndefFullUnitId cid insts) + -- TODO: arguably a smart constructor to enforce invariant would be + -- better + | Map.null insts = pretty cid + | otherwise = pretty cid <<>> Disp.brackets (dispOpenModuleSubst insts) + pretty (DefiniteUnitId uid) = pretty uid + +-- | +-- +-- >>> eitherParsec "foobar" :: Either String OpenUnitId +--Right (DefiniteUnitId (DefUnitId {unDefUnitId = UnitId "foobar"})) +-- +-- >>> eitherParsec "foo[Str=text-1.2.3:Data.Text.Text]" :: Either String OpenUnitId +-- Right (IndefFullUnitId (ComponentId "foo") (fromList [(ModuleName "Str",OpenModule (DefiniteUnitId (DefUnitId {unDefUnitId = UnitId "text-1.2.3"})) (ModuleName "Data.Text.Text"))])) +-- +instance Parsec OpenUnitId where + parsec = P.try parseOpenUnitId <|> fmap DefiniteUnitId parsec + where + parseOpenUnitId = do + cid <- parsec + insts <- P.between (P.char '[') (P.char ']') + parsecOpenModuleSubst + return (IndefFullUnitId cid insts) + +-- | Get the set of holes ('ModuleVar') embedded in a 'UnitId'. +openUnitIdFreeHoles :: OpenUnitId -> Set ModuleName +openUnitIdFreeHoles (IndefFullUnitId _ insts) = openModuleSubstFreeHoles insts +openUnitIdFreeHoles _ = Set.empty + +-- | Safe constructor from a UnitId. The only way to do this safely +-- is if the instantiation is provided. +mkOpenUnitId :: UnitId -> ComponentId -> OpenModuleSubst -> OpenUnitId +mkOpenUnitId uid cid insts = + if Set.null (openModuleSubstFreeHoles insts) + then DefiniteUnitId (unsafeMkDefUnitId uid) -- invariant holds! + else IndefFullUnitId cid insts + +----------------------------------------------------------------------- +-- DefUnitId + +-- | Create a 'DefUnitId' from a 'ComponentId' and an instantiation +-- with no holes. +mkDefUnitId :: ComponentId -> Map ModuleName Module -> DefUnitId +mkDefUnitId cid insts = + unsafeMkDefUnitId (mkUnitId + (unComponentId cid ++ maybe "" ("+"++) (hashModuleSubst insts))) + -- impose invariant! + +----------------------------------------------------------------------- +-- OpenModule + +-- | Unlike a 'Module', an 'OpenModule' is either an ordinary +-- module from some unit, OR an 'OpenModuleVar', representing a +-- hole that needs to be filled in. Substitutions are over +-- module variables. +data OpenModule + = OpenModule OpenUnitId ModuleName + | OpenModuleVar ModuleName + deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) + +instance Binary OpenModule +instance Structured OpenModule + +instance NFData OpenModule where + rnf (OpenModule uid mod_name) = rnf uid `seq` rnf mod_name + rnf (OpenModuleVar mod_name) = rnf mod_name + +instance Pretty OpenModule where + pretty (OpenModule uid mod_name) = + hcat [pretty uid, Disp.text ":", pretty mod_name] + pretty (OpenModuleVar mod_name) = + hcat [Disp.char '<', pretty mod_name, Disp.char '>'] + +-- | +-- +-- >>> eitherParsec "Includes2-0.1.0.0-inplace-mysql:Database.MySQL" :: Either String OpenModule +-- Right (OpenModule (DefiniteUnitId (DefUnitId {unDefUnitId = UnitId "Includes2-0.1.0.0-inplace-mysql"})) (ModuleName "Database.MySQL")) +-- +instance Parsec OpenModule where + parsec = parsecModuleVar <|> parsecOpenModule + where + parsecOpenModule = do + uid <- parsec + _ <- P.char ':' + mod_name <- parsec + return (OpenModule uid mod_name) + + parsecModuleVar = do + _ <- P.char '<' + mod_name <- parsec + _ <- P.char '>' + return (OpenModuleVar mod_name) + +-- | Get the set of holes ('ModuleVar') embedded in a 'Module'. +openModuleFreeHoles :: OpenModule -> Set ModuleName +openModuleFreeHoles (OpenModuleVar mod_name) = Set.singleton mod_name +openModuleFreeHoles (OpenModule uid _n) = openUnitIdFreeHoles uid + +----------------------------------------------------------------------- +-- OpenModuleSubst + +-- | An explicit substitution on modules. +-- +-- NB: These substitutions are NOT idempotent, for example, a +-- valid substitution is (A -> B, B -> A). +type OpenModuleSubst = Map ModuleName OpenModule + +-- | Pretty-print the entries of a module substitution, suitable +-- for embedding into a 'OpenUnitId' or passing to GHC via @--instantiate-with@. +dispOpenModuleSubst :: OpenModuleSubst -> Disp.Doc +dispOpenModuleSubst subst + = Disp.hcat + . Disp.punctuate Disp.comma + $ map dispOpenModuleSubstEntry (Map.toAscList subst) + +-- | Pretty-print a single entry of a module substitution. +dispOpenModuleSubstEntry :: (ModuleName, OpenModule) -> Disp.Doc +dispOpenModuleSubstEntry (k, v) = pretty k <<>> Disp.char '=' <<>> pretty v + +-- | Inverse to 'dispModSubst'. +-- +-- @since 2.2 +parsecOpenModuleSubst :: CabalParsing m => m OpenModuleSubst +parsecOpenModuleSubst = fmap Map.fromList + . flip P.sepBy (P.char ',') + $ parsecOpenModuleSubstEntry + +-- | Inverse to 'dispModSubstEntry'. +-- +-- @since 2.2 +parsecOpenModuleSubstEntry :: CabalParsing m => m (ModuleName, OpenModule) +parsecOpenModuleSubstEntry = + do k <- parsec + _ <- P.char '=' + v <- parsec + return (k, v) + +-- | Get the set of holes ('ModuleVar') embedded in a 'OpenModuleSubst'. +-- This is NOT the domain of the substitution. +openModuleSubstFreeHoles :: OpenModuleSubst -> Set ModuleName +openModuleSubstFreeHoles insts = Set.unions (map openModuleFreeHoles (Map.elems insts)) + +----------------------------------------------------------------------- +-- Conversions to UnitId + +-- | When typechecking, we don't demand that a freshly instantiated +-- 'IndefFullUnitId' be compiled; instead, we just depend on the +-- installed indefinite unit installed at the 'ComponentId'. +abstractUnitId :: OpenUnitId -> UnitId +abstractUnitId (DefiniteUnitId def_uid) = unDefUnitId def_uid +abstractUnitId (IndefFullUnitId cid _) = newSimpleUnitId cid + +-- | Take a module substitution and hash it into a string suitable for +-- 'UnitId'. Note that since this takes 'Module', not 'OpenModule', +-- you are responsible for recursively converting 'OpenModule' +-- into 'Module'. See also "Distribution.Backpack.ReadyComponent". +hashModuleSubst :: Map ModuleName Module -> Maybe String +hashModuleSubst subst + | Map.null subst = Nothing + | otherwise = + Just . hashToBase62 $ + concat [ prettyShow mod_name ++ "=" ++ prettyShow m ++ "\n" + | (mod_name, m) <- Map.toList subst] diff --git a/cabal/Cabal-syntax/src/Distribution/CabalSpecVersion.hs b/cabal/Cabal-syntax/src/Distribution/CabalSpecVersion.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/CabalSpecVersion.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +module Distribution.CabalSpecVersion where + +import Prelude () +import Distribution.Compat.Prelude + +-- | Different Cabal-the-spec versions. +-- +-- We branch based on this at least in the parser. +-- +data CabalSpecVersion + = CabalSpecV1_0 -- ^ this is older than 'CabalSpecV1_2' + | CabalSpecV1_2 -- ^ new syntax (sections) + | CabalSpecV1_4 + | CabalSpecV1_6 + | CabalSpecV1_8 + | CabalSpecV1_10 + | CabalSpecV1_12 + -- 1.16 -- 1.14: no changes + | CabalSpecV1_18 + | CabalSpecV1_20 + | CabalSpecV1_22 + | CabalSpecV1_24 + | CabalSpecV2_0 + | CabalSpecV2_2 + | CabalSpecV2_4 + | CabalSpecV3_0 + -- 3.2: no changes + | CabalSpecV3_4 + | CabalSpecV3_6 + | CabalSpecV3_8 + deriving (Eq, Ord, Show, Read, Enum, Bounded, Typeable, Data, Generic) + +instance Binary CabalSpecVersion +instance Structured CabalSpecVersion +instance NFData CabalSpecVersion where rnf = genericRnf + +-- | Show cabal spec version, but not the way in the .cabal files +-- +-- @since 3.0.0.0 +showCabalSpecVersion :: CabalSpecVersion -> String +showCabalSpecVersion CabalSpecV3_8 = "3.8" +showCabalSpecVersion CabalSpecV3_6 = "3.6" +showCabalSpecVersion CabalSpecV3_4 = "3.4" +showCabalSpecVersion CabalSpecV3_0 = "3.0" +showCabalSpecVersion CabalSpecV2_4 = "2.4" +showCabalSpecVersion CabalSpecV2_2 = "2.2" +showCabalSpecVersion CabalSpecV2_0 = "2.0" +showCabalSpecVersion CabalSpecV1_24 = "1.24" +showCabalSpecVersion CabalSpecV1_22 = "1.22" +showCabalSpecVersion CabalSpecV1_20 = "1.20" +showCabalSpecVersion CabalSpecV1_18 = "1.18" +showCabalSpecVersion CabalSpecV1_12 = "1.12" +showCabalSpecVersion CabalSpecV1_10 = "1.10" +showCabalSpecVersion CabalSpecV1_8 = "1.8" +showCabalSpecVersion CabalSpecV1_6 = "1.6" +showCabalSpecVersion CabalSpecV1_4 = "1.4" +showCabalSpecVersion CabalSpecV1_2 = "1.2" +showCabalSpecVersion CabalSpecV1_0 = "1.0" + +cabalSpecLatest :: CabalSpecVersion +cabalSpecLatest = CabalSpecV3_8 + +-- | Parse 'CabalSpecVersion' from version digits. +-- +-- It may fail if for recent versions the version is not exact. +-- +cabalSpecFromVersionDigits :: [Int] -> Maybe CabalSpecVersion +cabalSpecFromVersionDigits v + | v == [3,8] = Just CabalSpecV3_8 + | v == [3,6] = Just CabalSpecV3_6 + | v == [3,4] = Just CabalSpecV3_4 + | v == [3,0] = Just CabalSpecV3_0 + | v == [2,4] = Just CabalSpecV2_4 + | v == [2,2] = Just CabalSpecV2_2 + | v == [2,0] = Just CabalSpecV2_0 + | v >= [1,25] = Nothing + | v >= [1,23] = Just CabalSpecV1_24 + | v >= [1,21] = Just CabalSpecV1_22 + | v >= [1,19] = Just CabalSpecV1_20 + | v >= [1,17] = Just CabalSpecV1_18 + | v >= [1,11] = Just CabalSpecV1_12 + | v >= [1,9] = Just CabalSpecV1_10 + | v >= [1,7] = Just CabalSpecV1_8 + | v >= [1,5] = Just CabalSpecV1_6 + | v >= [1,3] = Just CabalSpecV1_4 + | v >= [1,1] = Just CabalSpecV1_2 + | otherwise = Just CabalSpecV1_0 + +-- | @since 3.4.0.0 +cabalSpecToVersionDigits :: CabalSpecVersion -> [Int] +cabalSpecToVersionDigits CabalSpecV3_8 = [3,8] +cabalSpecToVersionDigits CabalSpecV3_6 = [3,6] +cabalSpecToVersionDigits CabalSpecV3_4 = [3,4] +cabalSpecToVersionDigits CabalSpecV3_0 = [3,0] +cabalSpecToVersionDigits CabalSpecV2_4 = [2,4] +cabalSpecToVersionDigits CabalSpecV2_2 = [2,2] +cabalSpecToVersionDigits CabalSpecV2_0 = [2,0] +cabalSpecToVersionDigits CabalSpecV1_24 = [1,24] +cabalSpecToVersionDigits CabalSpecV1_22 = [1,22] +cabalSpecToVersionDigits CabalSpecV1_20 = [1,20] +cabalSpecToVersionDigits CabalSpecV1_18 = [1,18] +cabalSpecToVersionDigits CabalSpecV1_12 = [1,12] +cabalSpecToVersionDigits CabalSpecV1_10 = [1,10] +cabalSpecToVersionDigits CabalSpecV1_8 = [1,8] +cabalSpecToVersionDigits CabalSpecV1_6 = [1,6] +cabalSpecToVersionDigits CabalSpecV1_4 = [1,4] +cabalSpecToVersionDigits CabalSpecV1_2 = [1,2] +cabalSpecToVersionDigits CabalSpecV1_0 = [1,0] + +-- | What is the minimum Cabal library version which knows how handle +-- this spec version. +-- +-- /Note:/ this is a point where we could decouple cabal-spec and Cabal +-- versions, if we ever want that. +-- +-- >>> cabalSpecMinimumLibraryVersion CabalSpecV3_0 +-- [2,5] +-- +-- >>> cabalSpecMinimumLibraryVersion CabalSpecV2_4 +-- [2,3] +-- +-- @since 3.4.0.0 +cabalSpecMinimumLibraryVersion :: CabalSpecVersion -> [Int] +cabalSpecMinimumLibraryVersion CabalSpecV1_0 = [1,0] +cabalSpecMinimumLibraryVersion csv = case cabalSpecToVersionDigits (pred csv) of + [x,y] -> [x, y+1] + xs -> xs + +specHasCommonStanzas :: CabalSpecVersion -> HasCommonStanzas +specHasCommonStanzas v = + if v >= CabalSpecV2_2 + then HasCommonStanzas + else NoCommonStanzas + +specHasElif :: CabalSpecVersion -> HasElif +specHasElif v = + if v >= CabalSpecV2_2 + then HasElif + else NoElif + +------------------------------------------------------------------------------- +-- Booleans +------------------------------------------------------------------------------- + +-- IDEA: make some kind of tagged booleans? +data HasElif = HasElif | NoElif + deriving (Eq, Show) + +data HasCommonStanzas = HasCommonStanzas | NoCommonStanzas + deriving (Eq, Show) + +data HasGlobstar = HasGlobstar | NoGlobstar diff --git a/cabal/Cabal-syntax/src/Distribution/Compat/Binary.hs b/cabal/Cabal-syntax/src/Distribution/Compat/Binary.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Compat/Binary.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE PatternSynonyms #-} + +module Distribution.Compat.Binary + ( decodeOrFailIO + , decodeFileOrFail' + , module Data.Binary + ) where + +import Control.Exception (ErrorCall (..), catch, evaluate) +import Data.ByteString.Lazy (ByteString) + +import Data.Binary + +-- | Lazily reconstruct a value previously written to a file. +decodeFileOrFail' :: Binary a => FilePath -> IO (Either String a) +decodeFileOrFail' f = either (Left . snd) Right `fmap` decodeFileOrFail f + +decodeOrFailIO :: Binary a => ByteString -> IO (Either String a) +decodeOrFailIO bs = + catch (evaluate (decode bs) >>= return . Right) handler + where + handler (ErrorCallWithLocation str _) = return $ Left str diff --git a/cabal/Cabal-syntax/src/Distribution/Compat/CharParsing.hs b/cabal/Cabal-syntax/src/Distribution/Compat/CharParsing.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Compat/CharParsing.hs @@ -0,0 +1,357 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fspec-constr -fspec-constr-count=8 #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Compat.CharParsing +-- Copyright : (c) Edward Kmett 2011 +-- License : BSD3 +-- +-- Maintainer : ekmett@gmail.com +-- Stability : experimental +-- Portability : non-portable +-- +-- Parsers for character streams +-- +-- Originally in @parsers@ package. +-- +----------------------------------------------------------------------------- +module Distribution.Compat.CharParsing + ( + -- * Combinators + oneOf -- :: CharParsing m => [Char] -> m Char + , noneOf -- :: CharParsing m => [Char] -> m Char + , spaces -- :: CharParsing m => m () + , space -- :: CharParsing m => m Char + , newline -- :: CharParsing m => m Char + , tab -- :: CharParsing m => m Char + , upper -- :: CharParsing m => m Char + , lower -- :: CharParsing m => m Char + , alphaNum -- :: CharParsing m => m Char + , letter -- :: CharParsing m => m Char + , digit -- :: CharParsing m => m Char + , hexDigit -- :: CharParsing m => m Char + , octDigit -- :: CharParsing m => m Char + , satisfyRange -- :: CharParsing m => Char -> Char -> m Char + -- * Class + , CharParsing(..) + -- * Cabal additions + , integral + , signedIntegral + , munch1 + , munch + , skipSpaces1 + , module Distribution.Compat.Parsing + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.State.Lazy as Lazy +import Control.Monad.Trans.State.Strict as Strict +import Control.Monad.Trans.Writer.Lazy as Lazy +import Control.Monad.Trans.Writer.Strict as Strict +import Control.Monad.Trans.RWS.Lazy as Lazy +import Control.Monad.Trans.RWS.Strict as Strict +import Control.Monad.Trans.Reader (ReaderT (..)) +import Control.Monad.Trans.Identity (IdentityT (..)) +import Data.Char +import Data.Text (Text, unpack) + +import qualified Text.Parsec as Parsec + +import Distribution.Compat.Parsing + +-- | @oneOf cs@ succeeds if the current character is in the supplied +-- list of characters @cs@. Returns the parsed character. See also +-- 'satisfy'. +-- +-- > vowel = oneOf "aeiou" +oneOf :: CharParsing m => [Char] -> m Char +oneOf xs = satisfy (\c -> c `elem` xs) +{-# INLINE oneOf #-} + +-- | As the dual of 'oneOf', @noneOf cs@ succeeds if the current +-- character is /not/ in the supplied list of characters @cs@. Returns the +-- parsed character. +-- +-- > consonant = noneOf "aeiou" +noneOf :: CharParsing m => [Char] -> m Char +noneOf xs = satisfy (\c -> c `notElem` xs) +{-# INLINE noneOf #-} + +-- | Skips /zero/ or more white space characters. See also 'skipMany'. +spaces :: CharParsing m => m () +spaces = skipMany space "white space" +{-# INLINE spaces #-} + +-- | Parses a white space character (any character which satisfies 'isSpace') +-- Returns the parsed character. +space :: CharParsing m => m Char +space = satisfy isSpace "space" +{-# INLINE space #-} + +-- | Parses a newline character (\'\\n\'). Returns a newline character. +newline :: CharParsing m => m Char +newline = char '\n' "new-line" +{-# INLINE newline #-} + +-- | Parses a tab character (\'\\t\'). Returns a tab character. +tab :: CharParsing m => m Char +tab = char '\t' "tab" +{-# INLINE tab #-} + +-- | Parses an upper case letter. Returns the parsed character. +upper :: CharParsing m => m Char +upper = satisfy isUpper "uppercase letter" +{-# INLINE upper #-} + +-- | Parses a lower case character. Returns the parsed character. +lower :: CharParsing m => m Char +lower = satisfy isLower "lowercase letter" +{-# INLINE lower #-} + +-- | Parses a letter or digit. Returns the parsed character. +alphaNum :: CharParsing m => m Char +alphaNum = satisfy isAlphaNum "letter or digit" +{-# INLINE alphaNum #-} + +-- | Parses a letter (an upper case or lower case character). Returns the +-- parsed character. +letter :: CharParsing m => m Char +letter = satisfy isAlpha "letter" +{-# INLINE letter #-} + +-- | Parses a digit. Returns the parsed character. +digit :: CharParsing m => m Char +digit = satisfy isDigit "digit" +{-# INLINE digit #-} + +-- | Parses a hexadecimal digit (a digit or a letter between \'a\' and +-- \'f\' or \'A\' and \'F\'). Returns the parsed character. +hexDigit :: CharParsing m => m Char +hexDigit = satisfy isHexDigit "hexadecimal digit" +{-# INLINE hexDigit #-} + +-- | Parses an octal digit (a character between \'0\' and \'7\'). Returns +-- the parsed character. +octDigit :: CharParsing m => m Char +octDigit = satisfy isOctDigit "octal digit" +{-# INLINE octDigit #-} + +satisfyRange :: CharParsing m => Char -> Char -> m Char +satisfyRange a z = satisfy (\c -> c >= a && c <= z) +{-# INLINE satisfyRange #-} + +-- | Additional functionality needed to parse character streams. +class Parsing m => CharParsing m where + -- | Parse a single character of the input, with UTF-8 decoding + satisfy :: (Char -> Bool) -> m Char + + -- | @char c@ parses a single character @c@. Returns the parsed + -- character (i.e. @c@). + -- + -- /e.g./ + -- + -- @semiColon = 'char' ';'@ + char :: Char -> m Char + char c = satisfy (c ==) show [c] + {-# INLINE char #-} + + -- | @notChar c@ parses any single character other than @c@. Returns the parsed + -- character. + notChar :: Char -> m Char + notChar c = satisfy (c /=) + {-# INLINE notChar #-} + + -- | This parser succeeds for any character. Returns the parsed character. + anyChar :: m Char + anyChar = satisfy (const True) + {-# INLINE anyChar #-} + + -- | @string s@ parses a sequence of characters given by @s@. Returns + -- the parsed string (i.e. @s@). + -- + -- > divOrMod = string "div" + -- > <|> string "mod" + string :: String -> m String + string s = s <$ try (traverse_ char s) show s + {-# INLINE string #-} + + -- | @text t@ parses a sequence of characters determined by the text @t@ Returns + -- the parsed text fragment (i.e. @t@). + -- + -- Using @OverloadedStrings@: + -- + -- > divOrMod = text "div" + -- > <|> text "mod" + text :: Text -> m Text + text t = t <$ string (unpack t) + {-# INLINE text #-} + +instance (CharParsing m, MonadPlus m) => CharParsing (Lazy.StateT s m) where + satisfy = lift . satisfy + {-# INLINE satisfy #-} + char = lift . char + {-# INLINE char #-} + notChar = lift . notChar + {-# INLINE notChar #-} + anyChar = lift anyChar + {-# INLINE anyChar #-} + string = lift . string + {-# INLINE string #-} + text = lift . text + {-# INLINE text #-} + +instance (CharParsing m, MonadPlus m) => CharParsing (Strict.StateT s m) where + satisfy = lift . satisfy + {-# INLINE satisfy #-} + char = lift . char + {-# INLINE char #-} + notChar = lift . notChar + {-# INLINE notChar #-} + anyChar = lift anyChar + {-# INLINE anyChar #-} + string = lift . string + {-# INLINE string #-} + text = lift . text + {-# INLINE text #-} + +instance (CharParsing m, MonadPlus m) => CharParsing (ReaderT e m) where + satisfy = lift . satisfy + {-# INLINE satisfy #-} + char = lift . char + {-# INLINE char #-} + notChar = lift . notChar + {-# INLINE notChar #-} + anyChar = lift anyChar + {-# INLINE anyChar #-} + string = lift . string + {-# INLINE string #-} + text = lift . text + {-# INLINE text #-} + +instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Strict.WriterT w m) where + satisfy = lift . satisfy + {-# INLINE satisfy #-} + char = lift . char + {-# INLINE char #-} + notChar = lift . notChar + {-# INLINE notChar #-} + anyChar = lift anyChar + {-# INLINE anyChar #-} + string = lift . string + {-# INLINE string #-} + text = lift . text + {-# INLINE text #-} + +instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Lazy.WriterT w m) where + satisfy = lift . satisfy + {-# INLINE satisfy #-} + char = lift . char + {-# INLINE char #-} + notChar = lift . notChar + {-# INLINE notChar #-} + anyChar = lift anyChar + {-# INLINE anyChar #-} + string = lift . string + {-# INLINE string #-} + text = lift . text + {-# INLINE text #-} + +instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Lazy.RWST r w s m) where + satisfy = lift . satisfy + {-# INLINE satisfy #-} + char = lift . char + {-# INLINE char #-} + notChar = lift . notChar + {-# INLINE notChar #-} + anyChar = lift anyChar + {-# INLINE anyChar #-} + string = lift . string + {-# INLINE string #-} + text = lift . text + {-# INLINE text #-} + +instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Strict.RWST r w s m) where + satisfy = lift . satisfy + {-# INLINE satisfy #-} + char = lift . char + {-# INLINE char #-} + notChar = lift . notChar + {-# INLINE notChar #-} + anyChar = lift anyChar + {-# INLINE anyChar #-} + string = lift . string + {-# INLINE string #-} + text = lift . text + {-# INLINE text #-} + +instance (CharParsing m, MonadPlus m) => CharParsing (IdentityT m) where + satisfy = lift . satisfy + {-# INLINE satisfy #-} + char = lift . char + {-# INLINE char #-} + notChar = lift . notChar + {-# INLINE notChar #-} + anyChar = lift anyChar + {-# INLINE anyChar #-} + string = lift . string + {-# INLINE string #-} + text = lift . text + {-# INLINE text #-} + +instance Parsec.Stream s m Char => CharParsing (Parsec.ParsecT s u m) where + satisfy = Parsec.satisfy + char = Parsec.char + notChar c = Parsec.satisfy (/= c) + anyChar = Parsec.anyChar + string = Parsec.string + +------------------------------------------------------------------------------- +-- Our additions +------------------------------------------------------------------------------- + +integral :: (CharParsing m, Integral a) => m a +integral = toNumber <$> some d "integral" + where + toNumber = foldl' (\a b -> a * 10 + b) 0 + d = f <$> satisfyRange '0' '9' + f '0' = 0 + f '1' = 1 + f '2' = 2 + f '3' = 3 + f '4' = 4 + f '5' = 5 + f '6' = 6 + f '7' = 7 + f '8' = 8 + f '9' = 9 + f _ = error "panic! integral" +{-# INLINE integral #-} + +-- | Accepts negative (starting with @-@) and positive (without sign) integral +-- numbers. +-- +-- @since 3.4.0.0 +signedIntegral :: (CharParsing m, Integral a) => m a +signedIntegral = negate <$ char '-' <*> integral <|> integral +{-# INLINE signedIntegral #-} + +-- | Greedily munch characters while predicate holds. +-- Require at least one character. +munch1 :: CharParsing m => (Char -> Bool) -> m String +munch1 = some . satisfy +{-# INLINE munch1 #-} + +-- | Greedily munch characters while predicate holds. +-- Always succeeds. +munch :: CharParsing m => (Char -> Bool) -> m String +munch = many . satisfy +{-# INLINE munch #-} + +skipSpaces1 :: CharParsing m => m () +skipSpaces1 = skipSome space +{-# INLINE skipSpaces1 #-} diff --git a/cabal/Cabal-syntax/src/Distribution/Compat/DList.hs b/cabal/Cabal-syntax/src/Distribution/Compat/DList.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Compat/DList.hs @@ -0,0 +1,53 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Compat.DList +-- Copyright : (c) Ben Gamari 2015-2019 +-- License : BSD3 +-- +-- Maintainer : cabal-dev@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- A very simple difference list. +module Distribution.Compat.DList ( + DList, + runDList, + empty, + singleton, + fromList, + toList, + snoc, +) where + +import Prelude () +import Distribution.Compat.Prelude hiding (toList, empty) + +-- | Difference list. +newtype DList a = DList ([a] -> [a]) + +runDList :: DList a -> [a] +runDList (DList run) = run [] + +-- | Make 'DList' containing single element. +singleton :: a -> DList a +singleton a = DList (a:) + +-- | @since 3.4.0.0 +empty :: DList a +empty = DList id + +fromList :: [a] -> DList a +fromList as = DList (as ++) + +toList :: DList a -> [a] +toList = runDList + +snoc :: DList a -> a -> DList a +snoc xs x = xs <> singleton x + +instance Monoid (DList a) where + mempty = empty + mappend = (<>) + +instance Semigroup (DList a) where + DList a <> DList b = DList (a . b) diff --git a/cabal/Cabal-syntax/src/Distribution/Compat/Exception.hs b/cabal/Cabal-syntax/src/Distribution/Compat/Exception.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Compat/Exception.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE CPP #-} +module Distribution.Compat.Exception ( + catchIO, + catchExit, + tryIO, + displayException, + ) where + +import System.Exit +import qualified Control.Exception as Exception +import Control.Exception (displayException) + +-- | Try 'IOException'. +tryIO :: IO a -> IO (Either Exception.IOException a) +tryIO = Exception.try + +-- | Catch 'IOException'. +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +catchIO = Exception.catch + +-- | Catch 'ExitCode' +catchExit :: IO a -> (ExitCode -> IO a) -> IO a +catchExit = Exception.catch diff --git a/cabal/Cabal-syntax/src/Distribution/Compat/Graph.hs b/cabal/Cabal-syntax/src/Distribution/Compat/Graph.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Compat/Graph.hs @@ -0,0 +1,409 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Compat.Graph +-- Copyright : (c) Edward Z. Yang 2016 +-- License : BSD3 +-- +-- Maintainer : cabal-dev@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- A data type representing directed graphs, backed by "Data.Graph". +-- It is strict in the node type. +-- +-- This is an alternative interface to "Data.Graph". In this interface, +-- nodes (identified by the 'IsNode' type class) are associated with a +-- key and record the keys of their neighbors. This interface is more +-- convenient than 'Data.Graph.Graph', which requires vertices to be +-- explicitly handled by integer indexes. +-- +-- The current implementation has somewhat peculiar performance +-- characteristics. The asymptotics of all map-like operations mirror +-- their counterparts in "Data.Map". However, to perform a graph +-- operation, we first must build the "Data.Graph" representation, an +-- operation that takes /O(V + E log V)/. However, this operation can +-- be amortized across all queries on that particular graph. +-- +-- Some nodes may be broken, i.e., refer to neighbors which are not +-- stored in the graph. In our graph algorithms, we transparently +-- ignore such edges; however, you can easily query for the broken +-- vertices of a graph using 'broken' (and should, e.g., to ensure that +-- a closure of a graph is well-formed.) It's possible to take a closed +-- subset of a broken graph and get a well-formed graph. +-- +----------------------------------------------------------------------------- + +module Distribution.Compat.Graph ( + -- * Graph type + Graph, + IsNode(..), + -- * Query + null, + size, + member, + lookup, + -- * Construction + empty, + insert, + deleteKey, + deleteLookup, + -- * Combine + unionLeft, + unionRight, + -- * Graph algorithms + stronglyConnComp, + SCC(..), + cycles, + broken, + neighbors, + revNeighbors, + closure, + revClosure, + topSort, + revTopSort, + -- * Conversions + -- ** Maps + toMap, + -- ** Lists + fromDistinctList, + toList, + keys, + -- ** Sets + keysSet, + -- ** Graphs + toGraph, + -- * Node type + Node(..), + nodeValue, +) where + +import Distribution.Compat.Prelude hiding (empty, lookup, null, toList) +import Prelude () + +import Data.Array ((!)) +import Data.Graph (SCC (..)) +import Distribution.Utils.Structured (Structure (..), Structured (..)) + +import qualified Data.Array as Array +import qualified Data.Foldable as Foldable +import qualified Data.Graph as G +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified Data.Tree as Tree +import qualified Distribution.Compat.Prelude as Prelude + +-- | A graph of nodes @a@. The nodes are expected to have instance +-- of class 'IsNode'. +data Graph a + = Graph { + graphMap :: !(Map (Key a) a), + -- Lazily cached graph representation + graphForward :: G.Graph, + graphAdjoint :: G.Graph, + graphVertexToNode :: G.Vertex -> a, + graphKeyToVertex :: Key a -> Maybe G.Vertex, + graphBroken :: [(a, [Key a])] + } + deriving (Typeable) + +-- NB: Not a Functor! (or Traversable), because you need +-- to restrict Key a ~ Key b. We provide our own mapping +-- functions. + +-- General strategy is most operations are deferred to the +-- Map representation. + +instance Show a => Show (Graph a) where + show = show . toList + +instance (IsNode a, Read a, Show (Key a)) => Read (Graph a) where + readsPrec d s = map (\(a,r) -> (fromDistinctList a, r)) (readsPrec d s) + +instance (IsNode a, Binary a, Show (Key a)) => Binary (Graph a) where + put x = put (toList x) + get = fmap fromDistinctList get + +instance Structured a => Structured (Graph a) where + structure p = Nominal (typeRep p) 0 "Graph" [structure (Proxy :: Proxy a)] + +instance (Eq (Key a), Eq a) => Eq (Graph a) where + g1 == g2 = graphMap g1 == graphMap g2 + +instance Foldable.Foldable Graph where + fold = Foldable.fold . graphMap + foldr f z = Foldable.foldr f z . graphMap + foldl f z = Foldable.foldl f z . graphMap + foldMap f = Foldable.foldMap f . graphMap + foldl' f z = Foldable.foldl' f z . graphMap + foldr' f z = Foldable.foldr' f z . graphMap +#ifdef MIN_VERSION_base +#if MIN_VERSION_base(4,8,0) + length = Foldable.length . graphMap + null = Foldable.null . graphMap + toList = Foldable.toList . graphMap + elem x = Foldable.elem x . graphMap + maximum = Foldable.maximum . graphMap + minimum = Foldable.minimum . graphMap + sum = Foldable.sum . graphMap + product = Foldable.product . graphMap +#endif +#endif + +instance (NFData a, NFData (Key a)) => NFData (Graph a) where + rnf Graph { + graphMap = m, + graphForward = gf, + graphAdjoint = ga, + graphVertexToNode = vtn, + graphKeyToVertex = ktv, + graphBroken = b + } = gf `seq` ga `seq` vtn `seq` ktv `seq` b `seq` rnf m + +-- TODO: Data instance? + +-- | The 'IsNode' class is used for datatypes which represent directed +-- graph nodes. A node of type @a@ is associated with some unique key of +-- type @'Key' a@; given a node we can determine its key ('nodeKey') +-- and the keys of its neighbors ('nodeNeighbors'). +class Ord (Key a) => IsNode a where + type Key a + nodeKey :: a -> Key a + nodeNeighbors :: a -> [Key a] + +instance (IsNode a, IsNode b, Key a ~ Key b) => IsNode (Either a b) where + type Key (Either a b) = Key a + nodeKey (Left x) = nodeKey x + nodeKey (Right x) = nodeKey x + nodeNeighbors (Left x) = nodeNeighbors x + nodeNeighbors (Right x) = nodeNeighbors x + +-- | A simple, trivial data type which admits an 'IsNode' instance. +data Node k a = N a k [k] + deriving (Show, Eq) + +-- | Get the value from a 'Node'. +nodeValue :: Node k a -> a +nodeValue (N a _ _) = a + +instance Functor (Node k) where + fmap f (N a k ks) = N (f a) k ks + +instance Ord k => IsNode (Node k a) where + type Key (Node k a) = k + nodeKey (N _ k _) = k + nodeNeighbors (N _ _ ks) = ks + +-- TODO: Maybe introduce a typeclass for items which just +-- keys (so, Key associated type, and nodeKey method). But +-- I didn't need it here, so I didn't introduce it. + +-- Query + +-- | /O(1)/. Is the graph empty? +null :: Graph a -> Bool +null = Map.null . toMap + +-- | /O(1)/. The number of nodes in the graph. +size :: Graph a -> Int +size = Map.size . toMap + +-- | /O(log V)/. Check if the key is in the graph. +member :: IsNode a => Key a -> Graph a -> Bool +member k g = Map.member k (toMap g) + +-- | /O(log V)/. Lookup the node at a key in the graph. +lookup :: IsNode a => Key a -> Graph a -> Maybe a +lookup k g = Map.lookup k (toMap g) + +-- Construction + +-- | /O(1)/. The empty graph. +empty :: IsNode a => Graph a +empty = fromMap Map.empty + +-- | /O(log V)/. Insert a node into a graph. +insert :: IsNode a => a -> Graph a -> Graph a +insert !n g = fromMap (Map.insert (nodeKey n) n (toMap g)) + +-- | /O(log V)/. Delete the node at a key from the graph. +deleteKey :: IsNode a => Key a -> Graph a -> Graph a +deleteKey k g = fromMap (Map.delete k (toMap g)) + +-- | /O(log V)/. Lookup and delete. This function returns the deleted +-- value if it existed. +deleteLookup :: IsNode a => Key a -> Graph a -> (Maybe a, Graph a) +deleteLookup k g = + let (r, m') = Map.updateLookupWithKey (\_ _ -> Nothing) k (toMap g) + in (r, fromMap m') + +-- Combining + +-- | /O(V + V')/. Right-biased union, preferring entries +-- from the second map when conflicts occur. +-- @'nodeKey' x = 'nodeKey' (f x)@. +unionRight :: IsNode a => Graph a -> Graph a -> Graph a +unionRight g g' = fromMap (Map.union (toMap g') (toMap g)) + +-- | /O(V + V')/. Left-biased union, preferring entries from +-- the first map when conflicts occur. +unionLeft :: IsNode a => Graph a -> Graph a -> Graph a +unionLeft = flip unionRight + +-- Graph-like operations + +-- | /Ω(V + E)/. Compute the strongly connected components of a graph. +-- Requires amortized construction of graph. +stronglyConnComp :: Graph a -> [SCC a] +stronglyConnComp g = map decode forest + where + forest = G.scc (graphForward g) + decode (Tree.Node v []) + | mentions_itself v = CyclicSCC [graphVertexToNode g v] + | otherwise = AcyclicSCC (graphVertexToNode g v) + decode other = CyclicSCC (dec other []) + where dec (Tree.Node v ts) vs + = graphVertexToNode g v : foldr dec vs ts + mentions_itself v = v `elem` (graphForward g ! v) +-- Implementation copied from 'stronglyConnCompR' in 'Data.Graph'. + +-- | /Ω(V + E)/. Compute the cycles of a graph. +-- Requires amortized construction of graph. +cycles :: Graph a -> [[a]] +cycles g = [ vs | CyclicSCC vs <- stronglyConnComp g ] + +-- | /O(1)/. Return a list of nodes paired with their broken +-- neighbors (i.e., neighbor keys which are not in the graph). +-- Requires amortized construction of graph. +broken :: Graph a -> [(a, [Key a])] +broken g = graphBroken g + +-- | Lookup the immediate neighbors from a key in the graph. +-- Requires amortized construction of graph. +neighbors :: Graph a -> Key a -> Maybe [a] +neighbors g k = do + v <- graphKeyToVertex g k + return (map (graphVertexToNode g) (graphForward g ! v)) + +-- | Lookup the immediate reverse neighbors from a key in the graph. +-- Requires amortized construction of graph. +revNeighbors :: Graph a -> Key a -> Maybe [a] +revNeighbors g k = do + v <- graphKeyToVertex g k + return (map (graphVertexToNode g) (graphAdjoint g ! v)) + +-- | Compute the subgraph which is the closure of some set of keys. +-- Returns @Nothing@ if one (or more) keys are not present in +-- the graph. +-- Requires amortized construction of graph. +closure :: Graph a -> [Key a] -> Maybe [a] +closure g ks = do + vs <- traverse (graphKeyToVertex g) ks + return (decodeVertexForest g (G.dfs (graphForward g) vs)) + +-- | Compute the reverse closure of a graph from some set +-- of keys. Returns @Nothing@ if one (or more) keys are not present in +-- the graph. +-- Requires amortized construction of graph. +revClosure :: Graph a -> [Key a] -> Maybe [a] +revClosure g ks = do + vs <- traverse (graphKeyToVertex g) ks + return (decodeVertexForest g (G.dfs (graphAdjoint g) vs)) + +flattenForest :: Tree.Forest a -> [a] +flattenForest = concatMap Tree.flatten + +decodeVertexForest :: Graph a -> Tree.Forest G.Vertex -> [a] +decodeVertexForest g = map (graphVertexToNode g) . flattenForest + +-- | Topologically sort the nodes of a graph. +-- Requires amortized construction of graph. +topSort :: Graph a -> [a] +topSort g = map (graphVertexToNode g) $ G.topSort (graphForward g) + +-- | Reverse topologically sort the nodes of a graph. +-- Requires amortized construction of graph. +revTopSort :: Graph a -> [a] +revTopSort g = map (graphVertexToNode g) $ G.topSort (graphAdjoint g) + +-- Conversions + +-- | /O(1)/. Convert a map from keys to nodes into a graph. +-- The map must satisfy the invariant that +-- @'fromMap' m == 'fromList' ('Data.Map.elems' m)@; +-- if you can't fulfill this invariant use @'fromList' ('Data.Map.elems' m)@ +-- instead. The values of the map are assumed to already +-- be in WHNF. +fromMap :: IsNode a => Map (Key a) a -> Graph a +fromMap m + = Graph { graphMap = m + -- These are lazily computed! + , graphForward = g + , graphAdjoint = G.transposeG g + , graphVertexToNode = vertex_to_node + , graphKeyToVertex = key_to_vertex + , graphBroken = broke + } + where + try_key_to_vertex k = maybe (Left k) Right (key_to_vertex k) + + (brokenEdges, edges) + = unzip + $ [ partitionEithers (map try_key_to_vertex (nodeNeighbors n)) + | n <- ns ] + broke = filter (not . Prelude.null . snd) (zip ns brokenEdges) + + g = Array.listArray bounds edges + + ns = Map.elems m -- sorted ascending + vertices = zip (map nodeKey ns) [0..] + vertex_map = Map.fromAscList vertices + key_to_vertex k = Map.lookup k vertex_map + + vertex_to_node vertex = nodeTable ! vertex + + nodeTable = Array.listArray bounds ns + bounds = (0, Map.size m - 1) + +-- | /O(V log V)/. Convert a list of nodes (with distinct keys) into a graph. +fromDistinctList :: (IsNode a, Show (Key a)) => [a] -> Graph a +fromDistinctList = fromMap + . Map.fromListWith (\_ -> duplicateError) + . map (\n -> n `seq` (nodeKey n, n)) + where + duplicateError n = error $ "Graph.fromDistinctList: duplicate key: " + ++ show (nodeKey n) + +-- Map-like operations + +-- | /O(V)/. Convert a graph into a list of nodes. +toList :: Graph a -> [a] +toList g = Map.elems (toMap g) + +-- | /O(V)/. Convert a graph into a list of keys. +keys :: Graph a -> [Key a] +keys g = Map.keys (toMap g) + +-- | /O(V)/. Convert a graph into a set of keys. +keysSet :: Graph a -> Set.Set (Key a) +keysSet g = Map.keysSet (toMap g) + +-- | /O(1)/. Convert a graph into a map from keys to nodes. +-- The resulting map @m@ is guaranteed to have the property that +-- @'Prelude.all' (\(k,n) -> k == 'nodeKey' n) ('Data.Map.toList' m)@. +toMap :: Graph a -> Map (Key a) a +toMap = graphMap + +-- Graph-like operations + +-- | /O(1)/. Convert a graph into a 'Data.Graph.Graph'. +-- Requires amortized construction of graph. +toGraph :: Graph a -> (G.Graph, G.Vertex -> a, Key a -> Maybe G.Vertex) +toGraph g = (graphForward g, graphVertexToNode g, graphKeyToVertex g) diff --git a/cabal/Cabal-syntax/src/Distribution/Compat/Lens.hs b/cabal/Cabal-syntax/src/Distribution/Compat/Lens.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Compat/Lens.hs @@ -0,0 +1,262 @@ +{-# LANGUAGE RankNTypes #-} +-- | This module provides very basic lens functionality, without extra dependencies. +-- +-- For the documentation of the combinators see package. +-- This module uses the same vocabulary. +module Distribution.Compat.Lens ( + -- * Types + Lens, + Lens', + Traversal, + Traversal', + -- ** LensLike + LensLike, + LensLike', + -- ** rank-1 types + Getting, + AGetter, + ASetter, + ALens, + ALens', + -- * Getter + view, + use, + getting, + -- * Setter + set, + over, + -- * Fold + toDListOf, + toListOf, + toSetOf, + -- * Lens + cloneLens, + aview, + -- * Common lenses + _1, _2, + -- * Operators + (&), + (^.), + (.~), (?~), (%~), + (.=), (?=), (%=), + (^#), + (#~), (#%~), + -- * Internal Comonads + Pretext (..), + -- * Cabal developer info + -- $development + ) where + +import Prelude() +import Distribution.Compat.Prelude + +import Control.Monad.State.Class (MonadState (..), gets, modify) + +import qualified Distribution.Compat.DList as DList +import qualified Data.Set as Set + +------------------------------------------------------------------------------- +-- Types +------------------------------------------------------------------------------- + +type LensLike f s t a b = (a -> f b) -> s -> f t +type LensLike' f s a = (a -> f a) -> s -> f s + +type Lens s t a b = forall f. Functor f => LensLike f s t a b +type Traversal s t a b = forall f. Applicative f => LensLike f s t a b + +type Lens' s a = Lens s s a a +type Traversal' s a = Traversal s s a a + +type Getting r s a = LensLike (Const r) s s a a + +type AGetter s a = LensLike (Const a) s s a a -- this doesn't exist in 'lens' +type ASetter s t a b = LensLike Identity s t a b +type ALens s t a b = LensLike (Pretext a b) s t a b + +type ALens' s a = ALens s s a a + +------------------------------------------------------------------------------- +-- Getter +------------------------------------------------------------------------------- + +view :: Getting a s a -> s -> a +view l s = getConst (l Const s) +{-# INLINE view #-} + +use :: MonadState s m => Getting a s a -> m a +use l = gets (view l) +{-# INLINE use #-} + +-- | @since 2.4 +-- +-- >>> (3 :: Int) ^. getting (+2) . getting show +-- "5" +getting :: (s -> a) -> Getting r s a +getting k f = Const . getConst . f . k +{-# INLINE getting #-} + +------------------------------------------------------------------------------- +-- Setter +------------------------------------------------------------------------------- + +set :: ASetter s t a b -> b -> s -> t +set l x = over l (const x) + +over :: ASetter s t a b -> (a -> b) -> s -> t +over l f s = runIdentity (l (\x -> Identity (f x)) s) + +------------------------------------------------------------------------------- +-- Fold +------------------------------------------------------------------------------- + +toDListOf :: Getting (DList.DList a) s a -> s -> DList.DList a +toDListOf l s = getConst (l (\x -> Const (DList.singleton x)) s) + +toListOf :: Getting (DList.DList a) s a -> s -> [a] +toListOf l = DList.runDList . toDListOf l + +toSetOf :: Getting (Set.Set a) s a -> s -> Set.Set a +toSetOf l s = getConst (l (\x -> Const (Set.singleton x)) s) + +------------------------------------------------------------------------------- +-- Lens +------------------------------------------------------------------------------- + +aview :: ALens s t a b -> s -> a +aview l = pretextPos . l pretextSell +{-# INLINE aview #-} + +{- +lens :: (s -> a) -> (s -> a -> s) -> Lens' s a +lens sa sbt afb s = sbt s <$> afb (sa s) +-} + +------------------------------------------------------------------------------- +-- Common +------------------------------------------------------------------------------- + +_1 :: Lens (a, c) (b, c) a b +_1 f (a, c) = flip (,) c <$> f a + +_2 :: Lens (c, a) (c, b) a b +_2 f (c, a) = (,) c <$> f a + +------------------------------------------------------------------------------- +-- Operators +------------------------------------------------------------------------------- + +-- | '&' is a reverse application operator +(&) :: a -> (a -> b) -> b +(&) = flip ($) +{-# INLINE (&) #-} +infixl 1 & + +infixl 8 ^., ^# +infixr 4 .~, %~, ?~ +infixr 4 #~, #%~ +infixr 4 .=, %=, ?= + +(^.) :: s -> Getting a s a -> a +s ^. l = getConst (l Const s) +{-# INLINE (^.) #-} + +(.~) :: ASetter s t a b -> b -> s -> t +(.~) = set +{-# INLINE (.~) #-} + +(?~) :: ASetter s t a (Maybe b) -> b -> s -> t +l ?~ b = set l (Just b) +{-# INLINE (?~) #-} + +(%~) :: ASetter s t a b -> (a -> b) -> s -> t +(%~) = over +{-# INLINE (%~) #-} + +(.=) :: MonadState s m => ASetter s s a b -> b -> m () +l .= b = modify (l .~ b) +{-# INLINE (.=) #-} + +(?=) :: MonadState s m => ASetter s s a (Maybe b) -> b -> m () +l ?= b = modify (l ?~ b) +{-# INLINE (?=) #-} + +(%=) :: MonadState s m => ASetter s s a b -> (a -> b) -> m () +l %= f = modify (l %~ f) +{-# INLINE (%=) #-} + +(^#) :: s -> ALens s t a b -> a +s ^# l = aview l s + +(#~) :: ALens s t a b -> b -> s -> t +(#~) l b s = pretextPeek b (l pretextSell s) +{-# INLINE (#~) #-} + +(#%~) :: ALens s t a b -> (a -> b) -> s -> t +(#%~) l f s = pretextPeeks f (l pretextSell s) +{-# INLINE (#%~) #-} + +pretextSell :: a -> Pretext a b b +pretextSell a = Pretext (\afb -> afb a) +{-# INLINE pretextSell #-} + +pretextPeeks :: (a -> b) -> Pretext a b t -> t +pretextPeeks f (Pretext m) = runIdentity $ m (\x -> Identity (f x)) +{-# INLINE pretextPeeks #-} + +pretextPeek :: b -> Pretext a b t -> t +pretextPeek b (Pretext m) = runIdentity $ m (\_ -> Identity b) +{-# INLINE pretextPeek #-} + +pretextPos :: Pretext a b t -> a +pretextPos (Pretext m) = getConst (m Const) +{-# INLINE pretextPos #-} + +cloneLens :: Functor f => ALens s t a b -> LensLike f s t a b +cloneLens l f s = runPretext (l pretextSell s) f +{-# INLINE cloneLens #-} + +------------------------------------------------------------------------------- +-- Comonads +------------------------------------------------------------------------------- + +-- | @lens@ variant is also parametrised by profunctor. +data Pretext a b t = Pretext { runPretext :: forall f. Functor f => (a -> f b) -> f t } + +instance Functor (Pretext a b) where + fmap f (Pretext pretext) = Pretext (\afb -> fmap f (pretext afb)) + +------------------------------------------------------------------------------- +-- Documentation +------------------------------------------------------------------------------- + +-- $development +-- +-- We cannot depend on @template-haskell@, because Cabal is a boot library. +-- This fact makes defining optics a manual task. Here is a small recipe to +-- make the process less tedious. +-- +-- First start a repl +-- +-- > cabal new-repl Cabal-tests:hackage-tests +-- +-- Because @--extra-package@ isn't yet implemented, we use a test-suite +-- with @generics-sop@ dependency. +-- +-- In the repl, we load a helper script: +-- +-- > :l ../generics-sop-lens.hs +-- +-- Now we are set up to derive lenses! +-- +-- > :m +Distribution.Types.SourceRepo +-- > putStr $ genericLenses (Proxy :: Proxy SourceRepo) +-- +-- @ +-- repoKind :: Lens' SourceRepo RepoKind +-- repoKind f s = fmap (\\x -> s { T.repoKind = x }) (f (T.repoKind s)) +-- \{-# INLINE repoKind #-\} +-- ... +-- @ +-- +-- /Note:/ You may need to adjust type-aliases, e.g. `String` to `FilePath`. diff --git a/cabal/Cabal-syntax/src/Distribution/Compat/MonadFail.hs b/cabal/Cabal-syntax/src/Distribution/Compat/MonadFail.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Compat/MonadFail.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE CPP #-} + +-- | Compatibility layer for "Control.Monad.Fail" +module Distribution.Compat.MonadFail ( Control.Monad.Fail.MonadFail(fail) ) where +import Control.Monad.Fail diff --git a/cabal/Cabal-syntax/src/Distribution/Compat/Newtype.hs b/cabal/Cabal-syntax/src/Distribution/Compat/Newtype.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Compat/Newtype.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +-- | Per Conor McBride, the 'Newtype' typeclass represents the packing and +-- unpacking of a newtype, and allows you to operate under that newtype with +-- functions such as 'ala'. +module Distribution.Compat.Newtype ( + Newtype (..), + ala, + alaf, + pack', + unpack', + ) where + +import Data.Functor.Identity (Identity (..)) +import Data.Monoid (Sum (..), Product (..), Endo (..)) + +#if MIN_VERSION_base(4,7,0) +import Data.Coerce (coerce, Coercible) +#else +import Unsafe.Coerce (unsafeCoerce) +#endif + +-- | The @FunctionalDependencies@ version of 'Newtype' type-class. +-- +-- Since Cabal-3.0 class arguments are in a different order than in @newtype@ package. +-- This change is to allow usage with @DeriveAnyClass@ (and @DerivingStrategies@, in GHC-8.2). +-- Unfortunately one has to repeat inner type. +-- +-- @ +-- newtype New = New Old +-- deriving anyclass (Newtype Old) +-- @ +-- +-- Another approach would be to use @TypeFamilies@ (and possibly +-- compute inner type using "GHC.Generics"), but we think @FunctionalDependencies@ +-- version gives cleaner type signatures. +-- +class Newtype o n | n -> o where + pack :: o -> n +#if MIN_VERSION_base(4,7,0) + default pack :: Coercible o n => o -> n + pack = coerce +#else + default pack :: o -> n + pack = unsafeCoerce +#endif + + unpack :: n -> o +#if MIN_VERSION_base(4,7,0) + default unpack :: Coercible n o => n -> o + unpack = coerce +#else + default unpack :: n -> o + unpack = unsafeCoerce +#endif + +instance Newtype a (Identity a) +instance Newtype a (Sum a) +instance Newtype a (Product a) +instance Newtype (a -> a) (Endo a) + +-- | +-- +-- >>> ala Sum foldMap [1, 2, 3, 4 :: Int] +-- 10 +-- +-- /Note:/ the user supplied function for the newtype is /ignored/. +-- +-- >>> ala (Sum . (+1)) foldMap [1, 2, 3, 4 :: Int] +-- 10 +ala :: (Newtype o n, Newtype o' n') => (o -> n) -> ((o -> n) -> b -> n') -> (b -> o') +ala pa hof = alaf pa hof id + +-- | +-- +-- >>> alaf Sum foldMap length ["cabal", "install"] +-- 12 +-- +-- /Note:/ as with 'ala', the user supplied function for the newtype is /ignored/. +alaf :: (Newtype o n, Newtype o' n') => (o -> n) -> ((a -> n) -> b -> n') -> (a -> o) -> (b -> o') +alaf _ hof f = unpack . hof (pack . f) + +-- | Variant of 'pack', which takes a phantom type. +pack' :: Newtype o n => (o -> n) -> o -> n +pack' _ = pack + +-- | Variant of 'unpack', which takes a phantom type. +unpack' :: Newtype o n => (o -> n) -> n -> o +unpack' _ = unpack diff --git a/cabal/Cabal-syntax/src/Distribution/Compat/NonEmptySet.hs b/cabal/Cabal-syntax/src/Distribution/Compat/NonEmptySet.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Compat/NonEmptySet.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +module Distribution.Compat.NonEmptySet ( + NonEmptySet, + -- * Construction + singleton, + -- * Insertion + insert, + -- * Deletion + delete, + -- * Conversions + toNonEmpty, + fromNonEmpty, + toList, + toSet, + -- * Query + member, + -- * Map + map, +) where + +import Prelude (Bool (..), Eq, Maybe (..), Ord (..), Read, Show (..), String, error, otherwise, return, showParen, showString, ($), (++), (.)) + +import Control.DeepSeq (NFData (..)) +import Data.Data (Data) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Semigroup (Semigroup (..)) +import Data.Typeable (Typeable) + +import qualified Data.Foldable as F +import qualified Data.Set as Set + +import Distribution.Compat.Binary (Binary (..)) +import Distribution.Utils.Structured + +#if MIN_VERSION_binary(0,6,0) +import Control.Applicative (empty) +#else +import Control.Monad (fail) +#endif + +-- | @since 3.4.0.0 +newtype NonEmptySet a = NES (Set.Set a) + deriving (Eq, Ord, Typeable, Data, Read) + +------------------------------------------------------------------------------- +-- Instances +------------------------------------------------------------------------------- + +instance Show a => Show (NonEmptySet a) where + showsPrec d s = showParen (d > 10) + $ showString "fromNonEmpty " + . showsPrec 11 (toNonEmpty s) + +instance Binary a => Binary (NonEmptySet a) where + put (NES s) = put s + get = do + xs <- get + if Set.null xs +#if MIN_VERSION_binary(0,6,0) + then empty +#else + then fail "NonEmptySet: empty" +#endif + else return (NES xs) + +instance Structured a => Structured (NonEmptySet a) where + structure = containerStructure + +instance NFData a => NFData (NonEmptySet a) where + rnf (NES x) = rnf x + +-- | Note: there aren't @Monoid@ instance. +instance Ord a => Semigroup (NonEmptySet a) where + NES x <> NES y = NES (Set.union x y) + +instance F.Foldable NonEmptySet where + foldMap f (NES s) = F.foldMap f s + foldr f z (NES s) = F.foldr f z s + +#if MIN_VERSION_base(4,8,0) + toList = toList + null _ = False + length (NES s) = F.length s +#endif + +------------------------------------------------------------------------------- +-- Constructors +------------------------------------------------------------------------------- + +singleton :: a -> NonEmptySet a +singleton = NES . Set.singleton + +------------------------------------------------------------------------------- +-- Insertion +------------------------------------------------------------------------------- + +insert :: Ord a => a -> NonEmptySet a -> NonEmptySet a +insert x (NES xs) = NES (Set.insert x xs) + +------------------------------------------------------------------------------- +-- Deletion +------------------------------------------------------------------------------- + +delete :: Ord a => a -> NonEmptySet a -> Maybe (NonEmptySet a) +delete x (NES xs) + | Set.null res = Nothing + | otherwise = Just (NES xs) + where + res = Set.delete x xs + +------------------------------------------------------------------------------- +-- Conversions +------------------------------------------------------------------------------- + +fromNonEmpty :: Ord a => NonEmpty a -> NonEmptySet a +fromNonEmpty (x :| xs) = NES (Set.fromList (x : xs)) + +toNonEmpty :: NonEmptySet a -> NonEmpty a +toNonEmpty (NES s) = case Set.toList s of + [] -> panic "toNonEmpty" + x:xs -> x :| xs + +toList :: NonEmptySet a -> [a] +toList (NES s) = Set.toList s + +toSet :: NonEmptySet a -> Set.Set a +toSet (NES s) = s + +------------------------------------------------------------------------------- +-- Query +------------------------------------------------------------------------------- + +member :: Ord a => a -> NonEmptySet a -> Bool +member x (NES xs) = Set.member x xs + +------------------------------------------------------------------------------- +-- Map +------------------------------------------------------------------------------- + +map + :: ( Ord b +#if !MIN_VERSION_containers(0,5,2) + , Ord a +#endif + ) + => (a -> b) -> NonEmptySet a -> NonEmptySet b +map f (NES x) = NES (Set.map f x) + +------------------------------------------------------------------------------- +-- Internal +------------------------------------------------------------------------------- + +panic :: String -> a +panic msg = error $ "NonEmptySet invariant violated: " ++ msg diff --git a/cabal/Cabal-syntax/src/Distribution/Compat/Parsing.hs b/cabal/Cabal-syntax/src/Distribution/Compat/Parsing.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Compat/Parsing.hs @@ -0,0 +1,362 @@ +{-# LANGUAGE GADTs, UndecidableInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Compat.Parsing +-- Copyright : (c) Edward Kmett 2011-2012 +-- License : BSD3 +-- +-- Maintainer : ekmett@gmail.com +-- Stability : experimental +-- Portability : non-portable +-- +-- Alternative parser combinators. +-- +-- Originally in @parsers@ package. +-- +----------------------------------------------------------------------------- +module Distribution.Compat.Parsing + ( + -- * Parsing Combinators + choice + , option + , optional -- from Control.Applicative, parsec optionMaybe + , skipOptional -- parsec optional + , between + , some -- from Control.Applicative, parsec many1 + , many -- from Control.Applicative + , sepBy + , sepByNonEmpty + , sepEndByNonEmpty + , sepEndBy + , endByNonEmpty + , endBy + , count + , chainl + , chainr + , chainl1 + , chainr1 + , manyTill + -- * Parsing Class + , Parsing(..) + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import Control.Applicative ((<**>), optional) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.State.Lazy as Lazy +import Control.Monad.Trans.State.Strict as Strict +import Control.Monad.Trans.Writer.Lazy as Lazy +import Control.Monad.Trans.Writer.Strict as Strict +import Control.Monad.Trans.RWS.Lazy as Lazy +import Control.Monad.Trans.RWS.Strict as Strict +import Control.Monad.Trans.Reader (ReaderT (..)) +import Control.Monad.Trans.Identity (IdentityT (..)) +import Data.Foldable (asum) + +import qualified Data.List.NonEmpty as NE +import qualified Text.Parsec as Parsec + +-- | @choice ps@ tries to apply the parsers in the list @ps@ in order, +-- until one of them succeeds. Returns the value of the succeeding +-- parser. +choice :: Alternative m => [m a] -> m a +choice = asum +{-# INLINE choice #-} + +-- | @option x p@ tries to apply parser @p@. If @p@ fails without +-- consuming input, it returns the value @x@, otherwise the value +-- returned by @p@. +-- +-- > priority = option 0 (digitToInt <$> digit) +option :: Alternative m => a -> m a -> m a +option x p = p <|> pure x +{-# INLINE option #-} + +-- | @skipOptional p@ tries to apply parser @p@. It will parse @p@ or nothing. +-- It only fails if @p@ fails after consuming input. It discards the result +-- of @p@. (Plays the role of parsec's optional, which conflicts with Applicative's optional) +skipOptional :: Alternative m => m a -> m () +skipOptional p = (() <$ p) <|> pure () +{-# INLINE skipOptional #-} + +-- | @between open close p@ parses @open@, followed by @p@ and @close@. +-- Returns the value returned by @p@. +-- +-- > braces = between (symbol "{") (symbol "}") +between :: Applicative m => m bra -> m ket -> m a -> m a +between bra ket p = bra *> p <* ket +{-# INLINE between #-} + +-- | @sepBy p sep@ parses /zero/ or more occurrences of @p@, separated +-- by @sep@. Returns a list of values returned by @p@. +-- +-- > commaSep p = p `sepBy` (symbol ",") +sepBy :: Alternative m => m a -> m sep -> m [a] +sepBy p sep = toList <$> sepByNonEmpty p sep <|> pure [] +{-# INLINE sepBy #-} + +-- | @sepByNonEmpty p sep@ parses /one/ or more occurrences of @p@, separated +-- by @sep@. Returns a non-empty list of values returned by @p@. +sepByNonEmpty :: Alternative m => m a -> m sep -> m (NonEmpty a) +sepByNonEmpty p sep = (:|) <$> p <*> many (sep *> p) +{-# INLINE sepByNonEmpty #-} + +-- | @sepEndByNonEmpty p sep@ parses /one/ or more occurrences of @p@, +-- separated and optionally ended by @sep@. Returns a non-empty list of values +-- returned by @p@. +sepEndByNonEmpty :: Alternative m => m a -> m sep -> m (NonEmpty a) +sepEndByNonEmpty p sep = (:|) <$> p <*> ((sep *> sepEndBy p sep) <|> pure []) + +-- | @sepEndBy p sep@ parses /zero/ or more occurrences of @p@, +-- separated and optionally ended by @sep@, ie. haskell style +-- statements. Returns a list of values returned by @p@. +-- +-- > haskellStatements = haskellStatement `sepEndBy` semi +sepEndBy :: Alternative m => m a -> m sep -> m [a] +sepEndBy p sep = toList <$> sepEndByNonEmpty p sep <|> pure [] +{-# INLINE sepEndBy #-} + +-- | @endByNonEmpty p sep@ parses /one/ or more occurrences of @p@, separated +-- and ended by @sep@. Returns a non-empty list of values returned by @p@. +endByNonEmpty :: Alternative m => m a -> m sep -> m (NonEmpty a) +endByNonEmpty p sep = NE.some1 (p <* sep) +{-# INLINE endByNonEmpty #-} + +-- | @endBy p sep@ parses /zero/ or more occurrences of @p@, separated +-- and ended by @sep@. Returns a list of values returned by @p@. +-- +-- > cStatements = cStatement `endBy` semi +endBy :: Alternative m => m a -> m sep -> m [a] +endBy p sep = many (p <* sep) +{-# INLINE endBy #-} + +-- | @count n p@ parses @n@ occurrences of @p@. If @n@ is smaller or +-- equal to zero, the parser equals to @return []@. Returns a list of +-- @n@ values returned by @p@. +count :: Applicative m => Int -> m a -> m [a] +count n p | n <= 0 = pure [] + | otherwise = sequenceA (replicate n p) +{-# INLINE count #-} + +-- | @chainr p op x@ parses /zero/ or more occurrences of @p@, +-- separated by @op@ Returns a value obtained by a /right/ associative +-- application of all functions returned by @op@ to the values returned +-- by @p@. If there are no occurrences of @p@, the value @x@ is +-- returned. +chainr :: Alternative m => m a -> m (a -> a -> a) -> a -> m a +chainr p op x = chainr1 p op <|> pure x +{-# INLINE chainr #-} + +-- | @chainl p op x@ parses /zero/ or more occurrences of @p@, +-- separated by @op@. Returns a value obtained by a /left/ associative +-- application of all functions returned by @op@ to the values returned +-- by @p@. If there are zero occurrences of @p@, the value @x@ is +-- returned. +chainl :: Alternative m => m a -> m (a -> a -> a) -> a -> m a +chainl p op x = chainl1 p op <|> pure x +{-# INLINE chainl #-} + +-- | @chainl1 p op x@ parses /one/ or more occurrences of @p@, +-- separated by @op@ Returns a value obtained by a /left/ associative +-- application of all functions returned by @op@ to the values returned +-- by @p@. . This parser can for example be used to eliminate left +-- recursion which typically occurs in expression grammars. +-- +-- > expr = term `chainl1` addop +-- > term = factor `chainl1` mulop +-- > factor = parens expr <|> integer +-- > +-- > mulop = (*) <$ symbol "*" +-- > <|> div <$ symbol "/" +-- > +-- > addop = (+) <$ symbol "+" +-- > <|> (-) <$ symbol "-" +chainl1 :: Alternative m => m a -> m (a -> a -> a) -> m a +chainl1 p op = scan where + scan = p <**> rst + rst = (\f y g x -> g (f x y)) <$> op <*> p <*> rst <|> pure id +{-# INLINE chainl1 #-} + +-- | @chainr1 p op x@ parses /one/ or more occurrences of @p@, +-- separated by @op@ Returns a value obtained by a /right/ associative +-- application of all functions returned by @op@ to the values returned +-- by @p@. +chainr1 :: Alternative m => m a -> m (a -> a -> a) -> m a +chainr1 p op = scan where + scan = p <**> rst + rst = (flip <$> op <*> scan) <|> pure id +{-# INLINE chainr1 #-} + +-- | @manyTill p end@ applies parser @p@ /zero/ or more times until +-- parser @end@ succeeds. Returns the list of values returned by @p@. +-- This parser can be used to scan comments: +-- +-- > simpleComment = do{ string "")) +-- > } +-- +-- Note the overlapping parsers @anyChar@ and @string \"-->\"@, and +-- therefore the use of the 'try' combinator. +manyTill :: Alternative m => m a -> m end -> m [a] +manyTill p end = go where go = ([] <$ end) <|> ((:) <$> p <*> go) +{-# INLINE manyTill #-} + +infixr 0 + +-- | Additional functionality needed to describe parsers independent of input type. +class Alternative m => Parsing m where + -- | Take a parser that may consume input, and on failure, go back to + -- where we started and fail as if we didn't consume input. + try :: m a -> m a + + -- | Give a parser a name + () :: m a -> String -> m a + + -- | A version of many that discards its input. Specialized because it + -- can often be implemented more cheaply. + skipMany :: m a -> m () + skipMany p = () <$ many p + {-# INLINE skipMany #-} + + -- | @skipSome p@ applies the parser @p@ /one/ or more times, skipping + -- its result. (aka skipMany1 in parsec) + skipSome :: m a -> m () + skipSome p = p *> skipMany p + {-# INLINE skipSome #-} + + -- | Used to emit an error on an unexpected token + unexpected :: String -> m a + + -- | This parser only succeeds at the end of the input. This is not a + -- primitive parser but it is defined using 'notFollowedBy'. + -- + -- > eof = notFollowedBy anyChar "end of input" + eof :: m () + + -- | @notFollowedBy p@ only succeeds when parser @p@ fails. This parser + -- does not consume any input. This parser can be used to implement the + -- \'longest match\' rule. For example, when recognizing keywords (for + -- example @let@), we want to make sure that a keyword is not followed + -- by a legal identifier character, in which case the keyword is + -- actually an identifier (for example @lets@). We can program this + -- behaviour as follows: + -- + -- > keywordLet = try $ string "let" <* notFollowedBy alphaNum + notFollowedBy :: Show a => m a -> m () + +instance (Parsing m, MonadPlus m) => Parsing (Lazy.StateT s m) where + try (Lazy.StateT m) = Lazy.StateT $ try . m + {-# INLINE try #-} + Lazy.StateT m l = Lazy.StateT $ \s -> m s l + {-# INLINE () #-} + unexpected = lift . unexpected + {-# INLINE unexpected #-} + eof = lift eof + {-# INLINE eof #-} + notFollowedBy (Lazy.StateT m) = Lazy.StateT + $ \s -> notFollowedBy (fst <$> m s) >> return ((),s) + {-# INLINE notFollowedBy #-} + +instance (Parsing m, MonadPlus m) => Parsing (Strict.StateT s m) where + try (Strict.StateT m) = Strict.StateT $ try . m + {-# INLINE try #-} + Strict.StateT m l = Strict.StateT $ \s -> m s l + {-# INLINE () #-} + unexpected = lift . unexpected + {-# INLINE unexpected #-} + eof = lift eof + {-# INLINE eof #-} + notFollowedBy (Strict.StateT m) = Strict.StateT + $ \s -> notFollowedBy (fst <$> m s) >> return ((),s) + {-# INLINE notFollowedBy #-} + +instance (Parsing m, MonadPlus m) => Parsing (ReaderT e m) where + try (ReaderT m) = ReaderT $ try . m + {-# INLINE try #-} + ReaderT m l = ReaderT $ \e -> m e l + {-# INLINE () #-} + skipMany (ReaderT m) = ReaderT $ skipMany . m + {-# INLINE skipMany #-} + unexpected = lift . unexpected + {-# INLINE unexpected #-} + eof = lift eof + {-# INLINE eof #-} + notFollowedBy (ReaderT m) = ReaderT $ notFollowedBy . m + {-# INLINE notFollowedBy #-} + +instance (Parsing m, MonadPlus m, Monoid w) => Parsing (Strict.WriterT w m) where + try (Strict.WriterT m) = Strict.WriterT $ try m + {-# INLINE try #-} + Strict.WriterT m l = Strict.WriterT (m l) + {-# INLINE () #-} + unexpected = lift . unexpected + {-# INLINE unexpected #-} + eof = lift eof + {-# INLINE eof #-} + notFollowedBy (Strict.WriterT m) = Strict.WriterT + $ notFollowedBy (fst <$> m) >>= \x -> return (x, mempty) + {-# INLINE notFollowedBy #-} + +instance (Parsing m, MonadPlus m, Monoid w) => Parsing (Lazy.WriterT w m) where + try (Lazy.WriterT m) = Lazy.WriterT $ try m + {-# INLINE try #-} + Lazy.WriterT m l = Lazy.WriterT (m l) + {-# INLINE () #-} + unexpected = lift . unexpected + {-# INLINE unexpected #-} + eof = lift eof + {-# INLINE eof #-} + notFollowedBy (Lazy.WriterT m) = Lazy.WriterT + $ notFollowedBy (fst <$> m) >>= \x -> return (x, mempty) + {-# INLINE notFollowedBy #-} + +instance (Parsing m, MonadPlus m, Monoid w) => Parsing (Lazy.RWST r w s m) where + try (Lazy.RWST m) = Lazy.RWST $ \r s -> try (m r s) + {-# INLINE try #-} + Lazy.RWST m l = Lazy.RWST $ \r s -> m r s l + {-# INLINE () #-} + unexpected = lift . unexpected + {-# INLINE unexpected #-} + eof = lift eof + {-# INLINE eof #-} + notFollowedBy (Lazy.RWST m) = Lazy.RWST + $ \r s -> notFollowedBy ((\(a,_,_) -> a) <$> m r s) >>= \x -> return (x, s, mempty) + {-# INLINE notFollowedBy #-} + +instance (Parsing m, MonadPlus m, Monoid w) => Parsing (Strict.RWST r w s m) where + try (Strict.RWST m) = Strict.RWST $ \r s -> try (m r s) + {-# INLINE try #-} + Strict.RWST m l = Strict.RWST $ \r s -> m r s l + {-# INLINE () #-} + unexpected = lift . unexpected + {-# INLINE unexpected #-} + eof = lift eof + {-# INLINE eof #-} + notFollowedBy (Strict.RWST m) = Strict.RWST + $ \r s -> notFollowedBy ((\(a,_,_) -> a) <$> m r s) >>= \x -> return (x, s, mempty) + {-# INLINE notFollowedBy #-} + +instance (Parsing m, Monad m) => Parsing (IdentityT m) where + try = IdentityT . try . runIdentityT + {-# INLINE try #-} + IdentityT m l = IdentityT (m l) + {-# INLINE () #-} + skipMany = IdentityT . skipMany . runIdentityT + {-# INLINE skipMany #-} + unexpected = lift . unexpected + {-# INLINE unexpected #-} + eof = lift eof + {-# INLINE eof #-} + notFollowedBy (IdentityT m) = IdentityT $ notFollowedBy m + {-# INLINE notFollowedBy #-} + +instance (Parsec.Stream s m t, Show t) => Parsing (Parsec.ParsecT s u m) where + try = Parsec.try + () = (Parsec.) + skipMany = Parsec.skipMany + skipSome = Parsec.skipMany1 + unexpected = Parsec.unexpected + eof = Parsec.eof + notFollowedBy = Parsec.notFollowedBy diff --git a/cabal/Cabal-syntax/src/Distribution/Compat/Prelude.hs b/cabal/Cabal-syntax/src/Distribution/Compat/Prelude.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Compat/Prelude.hs @@ -0,0 +1,288 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeOperators #-} + +#ifdef MIN_VERSION_base +#define MINVER_base_411 MIN_VERSION_base(4,11,0) +#else +#define MINVER_base_411 (__GLASGOW_HASKELL__ >= 804) +#endif + +-- | This module does two things: +-- +-- * Acts as a compatibility layer, like @base-compat@. +-- +-- * Provides commonly used imports. +module Distribution.Compat.Prelude ( + -- * Prelude + -- + -- Prelude is re-exported, following is hidden: + module BasePrelude, + + -- * Common type-classes + Semigroup (..), + gmappend, gmempty, + Typeable, TypeRep, typeRep, + Data, + Generic, + NFData (..), genericRnf, + Binary (..), + Structured, + Alternative (..), + MonadPlus (..), + IsString (..), + + -- * Some types + Map, + Set, + NonEmptySet, + Identity (..), + Proxy (..), + Const (..), + Void, + + -- * Data.Either + partitionEithers, + + -- * Data.Maybe + catMaybes, mapMaybe, + fromMaybe, + maybeToList, listToMaybe, + isNothing, isJust, + + -- * Data.List + unfoldr, + isPrefixOf, isSuffixOf, + intercalate, intersperse, + sort, sortBy, + nub, nubBy, + partition, + dropWhileEnd, + + -- * Data.List.NonEmpty + NonEmpty((:|)), nonEmpty, foldl1, foldr1, + head, tail, last, init, + + -- * Data.Foldable + Foldable, foldMap, foldr, + null, length, + find, foldl', + traverse_, for_, + any, all, + toList, + + -- * Data.Traversable + Traversable, traverse, sequenceA, + for, + + -- * Data.Function + on, + + -- * Data.Ord + comparing, + + -- * Control.Arrow + first, + + -- * Control.Monad + liftM, liftM2, + unless, when, + ap, void, + foldM, filterM, + join, guard, + + -- * Control.Exception + catch, throwIO, evaluate, + Exception (..), IOException, SomeException (..), + tryIO, catchIO, catchExit, + + -- * Control.DeepSeq + deepseq, force, + + -- * Data.Char + isSpace, isDigit, isUpper, isAlpha, isAlphaNum, + chr, ord, + toLower, toUpper, + + -- * Data.Void + absurd, vacuous, + + -- * Data.Word & Data.Int + Word, + Word8, Word16, Word32, Word64, + Int8, Int16, Int32, Int64, + + -- * Text.PrettyPrint + (<<>>), (Disp.<+>), + + -- * System.Exit + ExitCode (..), + exitWith, exitSuccess, exitFailure, + + -- * Text.Read + readMaybe, + + -- * Debug.Trace (as deprecated functions) + trace, traceShow, traceShowId, + ) where + +-- We also could hide few partial function +import Prelude as BasePrelude hiding + ( mapM, mapM_, sequence, null, length, foldr, any, all, head, tail, last, init + -- partial functions + , read + , foldr1, foldl1 +#if MINVER_base_411 + -- As of base 4.11.0.0 Prelude exports part of Semigroup(..). + -- Hide this so we instead rely on Distribution.Compat.Semigroup. + , Semigroup(..) +#endif + , Word + -- We hide them, as we import only some members + , Traversable, traverse, sequenceA + , Foldable, foldMap + ) + +-- AMP +import Data.Foldable + ( Foldable(toList), + length, + null, + Foldable(foldMap, foldr), + all, + any, + find, + foldl', + for_, + traverse_ ) +import Data.Traversable (Traversable (sequenceA, traverse), for) + +import qualified Data.Foldable + +-- Extra exports +import Control.Applicative (Alternative (..), Const(..)) +import Control.Arrow (first) +import Control.DeepSeq (NFData (..), deepseq, force) +import Control.Exception (Exception (..), IOException, SomeException (..), catch, evaluate, throwIO) +import Control.Monad (MonadPlus (..), ap, filterM, foldM, guard, join, liftM, liftM2, unless, void, when) +import Data.Char (chr, isAlpha, isAlphaNum, isDigit, isSpace, isUpper, ord, toLower, toUpper) +import Data.Data (Data) +import Data.Either (partitionEithers) +import Data.Function (on) +import Data.Functor.Identity (Identity (..)) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.List (dropWhileEnd, intercalate, intersperse, isPrefixOf, isSuffixOf, nub, nubBy, partition, sort, sortBy, unfoldr) +import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty, head, init, last, tail) +import Data.Map (Map) +import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, listToMaybe, mapMaybe, maybeToList) +import Data.Ord (comparing) +import Data.Proxy (Proxy (..)) +import Data.Set (Set) +import Data.String (IsString (..)) +import Data.Void (Void, absurd, vacuous) +import Data.Word (Word, Word16, Word32, Word64, Word8) +import Distribution.Compat.Binary (Binary (..)) +import Distribution.Compat.Semigroup (Semigroup (..), gmappend, gmempty) +import Distribution.Compat.Typeable (TypeRep, Typeable, typeRep) +import GHC.Generics ((:*:) ((:*:)), (:+:) (L1, R1), Generic, K1 (unK1), M1 (unM1), Rep (..), U1 (U1), V1) +import System.Exit (ExitCode (..), exitFailure, exitSuccess, exitWith) +import Text.Read (readMaybe) + +import qualified Text.PrettyPrint as Disp + +import Distribution.Compat.Exception +import Distribution.Compat.NonEmptySet (NonEmptySet) +import Distribution.Utils.Structured (Structured) + +import qualified Debug.Trace + +-- | New name for 'Text.PrettyPrint.<>' +(<<>>) :: Disp.Doc -> Disp.Doc -> Disp.Doc +(<<>>) = (Disp.<>) + +-- | "GHC.Generics"-based 'rnf' implementation +-- +-- This is needed in order to support @deepseq < 1.4@ which didn't +-- have a 'Generic'-based default 'rnf' implementation yet. +-- +-- In order to define instances, use e.g. +-- +-- > instance NFData MyType where rnf = genericRnf +-- +-- The implementation has been taken from @deepseq-1.4.2@'s default +-- 'rnf' implementation. +genericRnf :: (Generic a, GNFData (Rep a)) => a -> () +genericRnf = grnf . from + +-- | Hidden internal type-class +class GNFData f where + grnf :: f a -> () + +instance GNFData V1 where + grnf = error "Control.DeepSeq.rnf: uninhabited type" + +instance GNFData U1 where + grnf U1 = () + +instance NFData a => GNFData (K1 i a) where + grnf = rnf . unK1 + {-# INLINEABLE grnf #-} + +instance GNFData a => GNFData (M1 i c a) where + grnf = grnf . unM1 + {-# INLINEABLE grnf #-} + +instance (GNFData a, GNFData b) => GNFData (a :*: b) where + grnf (x :*: y) = grnf x `seq` grnf y + {-# INLINEABLE grnf #-} + +instance (GNFData a, GNFData b) => GNFData (a :+: b) where + grnf (L1 x) = grnf x + grnf (R1 x) = grnf x + {-# INLINEABLE grnf #-} + + +-- TODO: if we want foldr1/foldl1 to work on more than NonEmpty, we +-- can define a local typeclass 'Foldable1', e.g. +-- +-- @ +-- class Foldable f => Foldable1 f +-- +-- instance Foldable1 NonEmpty +-- +-- foldr1 :: Foldable1 t => (a -> a -> a) -> t a -> a +-- foldr1 = Data.Foldable.foldr1 +-- +-- foldl1 :: Foldable1 t => (a -> a -> a) -> t a -> a +-- foldl1 = Data.Foldable.foldl1 +-- @ +-- + +{-# INLINE foldr1 #-} +foldr1 :: (a -> a -> a) -> NonEmpty a -> a +foldr1 = Data.Foldable.foldr1 + +{-# INLINE foldl1 #-} +foldl1 :: (a -> a -> a) -> NonEmpty a -> a +foldl1 = Data.Foldable.foldl1 + +------------------------------------------------------------------------------- +-- Trace +------------------------------------------------------------------------------- + +-- Functions from Debug.Trace +-- but with DEPRECATED pragma, so -Werror will scream on them. + +trace :: String -> a -> a +trace = Debug.Trace.trace +{-# DEPRECATED trace "Don't leave me in the code" #-} + +traceShowId :: Show a => a -> a +traceShowId x = Debug.Trace.traceShow x x +{-# DEPRECATED traceShowId "Don't leave me in the code" #-} + +traceShow :: Show a => a -> b -> b +traceShow = Debug.Trace.traceShow +{-# DEPRECATED traceShow "Don't leave me in the code" #-} diff --git a/cabal/Cabal-syntax/src/Distribution/Compat/Semigroup.hs b/cabal/Cabal-syntax/src/Distribution/Compat/Semigroup.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Compat/Semigroup.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeOperators #-} + +-- | Compatibility layer for "Data.Semigroup" +module Distribution.Compat.Semigroup + ( Semigroup((<>)) + , Mon.Monoid(..) + , All(..) + , Any(..) + + , First'(..) + , Last'(..) + + , Option'(..) + + , gmappend + , gmempty + ) where + +import Distribution.Compat.Binary (Binary) +import Distribution.Utils.Structured (Structured) +import Data.Typeable (Typeable) + +import GHC.Generics +-- Data.Semigroup is available since GHC 8.0/base-4.9 in `base` +-- for older GHC/base, it's provided by `semigroups` +import Data.Semigroup +import qualified Data.Monoid as Mon + + +-- | A copy of 'Data.Semigroup.First'. +newtype First' a = First' { getFirst' :: a } + deriving (Eq, Ord, Show) + +instance Semigroup (First' a) where + a <> _ = a + +-- | A copy of 'Data.Semigroup.Last'. +newtype Last' a = Last' { getLast' :: a } + deriving (Eq, Ord, Read, Show, Generic, Binary, Typeable) + +instance Structured a => Structured (Last' a) + +instance Semigroup (Last' a) where + _ <> b = b + +instance Functor Last' where + fmap f (Last' x) = Last' (f x) + +-- | A wrapper around 'Maybe', providing the 'Semigroup' and 'Monoid' instances +-- implemented for 'Maybe' since @base-4.11@. +newtype Option' a = Option' { getOption' :: Maybe a } + deriving (Eq, Ord, Read, Show, Binary, Generic, Functor, Typeable) + +instance Structured a => Structured (Option' a) + +instance Semigroup a => Semigroup (Option' a) where + Option' (Just a) <> Option' (Just b) = Option' (Just (a <> b)) + Option' Nothing <> b = b + a <> Option' Nothing = a + +instance Semigroup a => Monoid (Option' a) where + mempty = Option' Nothing + mappend = (<>) + +------------------------------------------------------------------------------- +------------------------------------------------------------------------------- +-- Stolen from Edward Kmett's BSD3-licensed `semigroups` package + +-- | Generically generate a 'Semigroup' ('<>') operation for any type +-- implementing 'Generic'. This operation will append two values +-- by point-wise appending their component fields. It is only defined +-- for product types. +-- +-- @ +-- 'gmappend' a ('gmappend' b c) = 'gmappend' ('gmappend' a b) c +-- @ +gmappend :: (Generic a, GSemigroup (Rep a)) => a -> a -> a +gmappend x y = to (gmappend' (from x) (from y)) + +class GSemigroup f where + gmappend' :: f p -> f p -> f p + +instance Semigroup a => GSemigroup (K1 i a) where + gmappend' (K1 x) (K1 y) = K1 (x <> y) + +instance GSemigroup f => GSemigroup (M1 i c f) where + gmappend' (M1 x) (M1 y) = M1 (gmappend' x y) + +instance (GSemigroup f, GSemigroup g) => GSemigroup (f :*: g) where + gmappend' (x1 :*: x2) (y1 :*: y2) = gmappend' x1 y1 :*: gmappend' x2 y2 + +-- | Generically generate a 'Monoid' 'mempty' for any product-like type +-- implementing 'Generic'. +-- +-- It is only defined for product types. +-- +-- @ +-- 'gmappend' 'gmempty' a = a = 'gmappend' a 'gmempty' +-- @ + +gmempty :: (Generic a, GMonoid (Rep a)) => a +gmempty = to gmempty' + +class GSemigroup f => GMonoid f where + gmempty' :: f p + +instance (Semigroup a, Monoid a) => GMonoid (K1 i a) where + gmempty' = K1 mempty + +instance GMonoid f => GMonoid (M1 i c f) where + gmempty' = M1 gmempty' + +instance (GMonoid f, GMonoid g) => GMonoid (f :*: g) where + gmempty' = gmempty' :*: gmempty' diff --git a/cabal/Cabal-syntax/src/Distribution/Compat/Typeable.hs b/cabal/Cabal-syntax/src/Distribution/Compat/Typeable.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Compat/Typeable.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Distribution.Compat.Typeable ( + Typeable, + TypeRep, + typeRep, + ) where + +#if MIN_VERSION_base(4,7,0) +import Data.Typeable (Typeable, TypeRep, typeRep) +#else +import Data.Typeable (Typeable, TypeRep, typeOf) +#endif + +#if !MIN_VERSION_base(4,7,0) +typeRep :: forall a proxy. Typeable a => proxy a -> TypeRep +typeRep _ = typeOf (undefined :: a) +#endif diff --git a/cabal/Cabal-syntax/src/Distribution/Compiler.hs b/cabal/Cabal-syntax/src/Distribution/Compiler.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Compiler.hs @@ -0,0 +1,223 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Compiler +-- Copyright : Isaac Jones 2003-2004 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This has an enumeration of the various compilers that Cabal knows about. It +-- also specifies the default compiler. Sadly you'll often see code that does +-- case analysis on this compiler flavour enumeration like: +-- +-- > case compilerFlavor comp of +-- > GHC -> GHC.getInstalledPackages verbosity packageDb progdb +-- +-- Obviously it would be better to use the proper 'Compiler' abstraction +-- because that would keep all the compiler-specific code together. +-- Unfortunately we cannot make this change yet without breaking the +-- 'UserHooks' api, which would break all custom @Setup.hs@ files, so for the +-- moment we just have to live with this deficiency. If you're interested, see +-- ticket #57. + +module Distribution.Compiler ( + -- * Compiler flavor + CompilerFlavor(..), + buildCompilerId, + buildCompilerFlavor, + defaultCompilerFlavor, + classifyCompilerFlavor, + knownCompilerFlavors, + + -- * Per compiler flavor + PerCompilerFlavor (..), + perCompilerFlavorToList, + + -- * Compiler id + CompilerId(..), + + -- * Compiler info + CompilerInfo(..), + unknownCompilerInfo, + AbiTag(..), abiTagString + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import Language.Haskell.Extension + +import Distribution.Version (Version, mkVersion', nullVersion) + +import qualified System.Info (compilerName, compilerVersion) +import Distribution.Parsec (Parsec (..)) +import Distribution.Pretty (Pretty (..), prettyShow) +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as Disp + +data CompilerFlavor = + GHC | GHCJS | NHC | YHC | Hugs | HBC | Helium | JHC | LHC | UHC | Eta + | HaskellSuite String -- string is the id of the actual compiler + | OtherCompiler String + deriving (Generic, Show, Read, Eq, Ord, Typeable, Data) + +instance Binary CompilerFlavor +instance Structured CompilerFlavor +instance NFData CompilerFlavor where rnf = genericRnf + +knownCompilerFlavors :: [CompilerFlavor] +knownCompilerFlavors = + [GHC, GHCJS, NHC, YHC, Hugs, HBC, Helium, JHC, LHC, UHC, Eta] + +instance Pretty CompilerFlavor where + pretty (OtherCompiler name) = Disp.text name + pretty (HaskellSuite name) = Disp.text name + pretty NHC = Disp.text "nhc98" + pretty other = Disp.text (lowercase (show other)) + +instance Parsec CompilerFlavor where + parsec = classifyCompilerFlavor <$> component + where + component = do + cs <- P.munch1 isAlphaNum + if all isDigit cs then fail "all digits compiler name" else return cs + +classifyCompilerFlavor :: String -> CompilerFlavor +classifyCompilerFlavor s = + fromMaybe (OtherCompiler s) $ lookup (lowercase s) compilerMap + where + compilerMap = [ (lowercase (prettyShow compiler), compiler) + | compiler <- knownCompilerFlavors ] + +buildCompilerFlavor :: CompilerFlavor +buildCompilerFlavor = classifyCompilerFlavor System.Info.compilerName + +buildCompilerVersion :: Version +buildCompilerVersion = mkVersion' System.Info.compilerVersion + +buildCompilerId :: CompilerId +buildCompilerId = CompilerId buildCompilerFlavor buildCompilerVersion + +-- | The default compiler flavour to pick when compiling stuff. This defaults +-- to the compiler used to build the Cabal lib. +-- +-- However if it's not a recognised compiler then it's 'Nothing' and the user +-- will have to specify which compiler they want. +-- +defaultCompilerFlavor :: Maybe CompilerFlavor +defaultCompilerFlavor = case buildCompilerFlavor of + OtherCompiler _ -> Nothing + _ -> Just buildCompilerFlavor + +------------------------------------------------------------------------------- +-- Per compiler data +------------------------------------------------------------------------------- + +-- | 'PerCompilerFlavor' carries only info per GHC and GHCJS +-- +-- Cabal parses only @ghc-options@ and @ghcjs-options@, others are omitted. +-- +data PerCompilerFlavor v = PerCompilerFlavor v v + deriving (Generic, Show, Read, Eq, Typeable, Data, Functor, Foldable + , Traversable) + +instance Binary a => Binary (PerCompilerFlavor a) +instance Structured a => Structured (PerCompilerFlavor a) +instance NFData a => NFData (PerCompilerFlavor a) + +perCompilerFlavorToList :: PerCompilerFlavor v -> [(CompilerFlavor, v)] +perCompilerFlavorToList (PerCompilerFlavor a b) = [(GHC, a), (GHCJS, b)] + +instance Semigroup a => Semigroup (PerCompilerFlavor a) where + PerCompilerFlavor a b <> PerCompilerFlavor a' b' = PerCompilerFlavor + (a <> a') (b <> b') + +instance (Semigroup a, Monoid a) => Monoid (PerCompilerFlavor a) where + mempty = PerCompilerFlavor mempty mempty + mappend = (<>) + +-- ------------------------------------------------------------ +-- * Compiler Id +-- ------------------------------------------------------------ + +data CompilerId = CompilerId CompilerFlavor Version + deriving (Eq, Generic, Ord, Read, Show, Typeable) + +instance Binary CompilerId +instance Structured CompilerId +instance NFData CompilerId where rnf = genericRnf + +instance Pretty CompilerId where + pretty (CompilerId f v) + | v == nullVersion = pretty f + | otherwise = pretty f <<>> Disp.char '-' <<>> pretty v + +instance Parsec CompilerId where + parsec = do + flavour <- parsec + version <- (P.char '-' >> parsec) <|> return nullVersion + return (CompilerId flavour version) + +lowercase :: String -> String +lowercase = map toLower + +-- ------------------------------------------------------------ +-- * Compiler Info +-- ------------------------------------------------------------ + +-- | Compiler information used for resolving configurations. Some +-- fields can be set to Nothing to indicate that the information is +-- unknown. + +data CompilerInfo = CompilerInfo { + compilerInfoId :: CompilerId, + -- ^ Compiler flavour and version. + compilerInfoAbiTag :: AbiTag, + -- ^ Tag for distinguishing incompatible ABI's on the same + -- architecture/os. + compilerInfoCompat :: Maybe [CompilerId], + -- ^ Other implementations that this compiler claims to be + -- compatible with, if known. + compilerInfoLanguages :: Maybe [Language], + -- ^ Supported language standards, if known. + compilerInfoExtensions :: Maybe [Extension] + -- ^ Supported extensions, if known. + } + deriving (Generic, Show, Read) + +instance Binary CompilerInfo + +data AbiTag + = NoAbiTag + | AbiTag String + deriving (Eq, Generic, Show, Read, Typeable) + +instance Binary AbiTag +instance Structured AbiTag + +instance Pretty AbiTag where + pretty NoAbiTag = Disp.empty + pretty (AbiTag tag) = Disp.text tag + +instance Parsec AbiTag where + parsec = do + tag <- P.munch (\c -> isAlphaNum c || c == '_') + if null tag then return NoAbiTag else return (AbiTag tag) + +abiTagString :: AbiTag -> String +abiTagString NoAbiTag = "" +abiTagString (AbiTag tag) = tag + +-- | Make a CompilerInfo of which only the known information is its CompilerId, +-- its AbiTag and that it does not claim to be compatible with other +-- compiler id's. +unknownCompilerInfo :: CompilerId -> AbiTag -> CompilerInfo +unknownCompilerInfo compilerId abiTag = + CompilerInfo compilerId abiTag (Just []) Nothing Nothing diff --git a/cabal/Cabal-syntax/src/Distribution/FieldGrammar.hs b/cabal/Cabal-syntax/src/Distribution/FieldGrammar.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/FieldGrammar.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | This module provides a way to specify a grammar of @.cabal@ -like files. +module Distribution.FieldGrammar ( + -- * Field grammar type + FieldGrammar (..), + uniqueField, + optionalField, + optionalFieldDef, + monoidalField, + -- * Concrete grammar implementations + ParsecFieldGrammar, + ParsecFieldGrammar', + parseFieldGrammar, + fieldGrammarKnownFieldList, + PrettyFieldGrammar, + PrettyFieldGrammar', + prettyFieldGrammar, + -- * Auxiliary + (^^^), + Section(..), + Fields, + partitionFields, + takeFields, + runFieldParser, + runFieldParser', + defaultFreeTextFieldDefST, + -- * Newtypes + module Distribution.FieldGrammar.Newtypes, + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import qualified Data.Map.Strict as Map + +import Distribution.FieldGrammar.Class +import Distribution.FieldGrammar.Newtypes +import Distribution.FieldGrammar.Parsec +import Distribution.FieldGrammar.Pretty +import Distribution.Fields.Field +import Distribution.Utils.Generic (spanMaybe) + +type ParsecFieldGrammar' a = ParsecFieldGrammar a a +type PrettyFieldGrammar' a = PrettyFieldGrammar a a + +infixl 5 ^^^ + +-- | Reverse function application which binds tighter than '<$>' and '<*>'. +-- Useful for refining grammar specification. +-- +-- @ +-- \<*\> 'monoidalFieldAla' "extensions" (alaList' FSep MQuoted) oldExtensions +-- ^^^ 'deprecatedSince' [1,12] "Please use 'default-extensions' or 'other-extensions' fields." +-- @ +(^^^) :: a -> (a -> b) -> b +x ^^^ f = f x + +-- | Partitioning state +data PS ann = PS (Fields ann) [Section ann] [[Section ann]] + +-- | Partition field list into field map and groups of sections. +partitionFields :: [Field ann] -> (Fields ann, [[Section ann]]) +partitionFields = finalize . foldl' f (PS mempty mempty mempty) + where + finalize :: PS ann -> (Fields ann, [[Section ann]]) + finalize (PS fs s ss) + | null s = (fs, reverse ss) + | otherwise = (fs, reverse (reverse s : ss)) + + f :: PS ann -> Field ann -> PS ann + f (PS fs s ss) (Field (Name ann name) fss) = + PS (Map.insertWith (flip (++)) name [MkNamelessField ann fss] fs) [] ss' + where + ss' | null s = ss + | otherwise = reverse s : ss + f (PS fs s ss) (Section name sargs sfields) = + PS fs (MkSection name sargs sfields : s) ss + +-- | Take all fields from the front. +takeFields :: [Field ann] -> (Fields ann, [Field ann]) +takeFields = finalize . spanMaybe match + where + finalize (fs, rest) = (Map.fromListWith (flip (++)) fs, rest) + + match (Field (Name ann name) fs) = Just (name, [MkNamelessField ann fs]) + match _ = Nothing diff --git a/cabal/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs b/cabal/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableSuperClasses #-} +module Distribution.FieldGrammar.Class ( + FieldGrammar (..), + uniqueField, + optionalField, + optionalFieldDef, + monoidalField, + defaultFreeTextFieldDefST, +) where + +import Distribution.Compat.Lens +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.CabalSpecVersion (CabalSpecVersion) +import Distribution.Compat.Newtype (Newtype) +import Distribution.FieldGrammar.Newtypes +import Distribution.Fields.Field +import Distribution.Utils.ShortText + +-- | 'FieldGrammar' is parametrised by +-- +-- * @s@ which is a structure we are parsing. We need this to provide prettyprinter +-- functionality +-- +-- * @a@ type of the field. +-- +-- /Note:/ We'd like to have @forall s. Applicative (f s)@ context. +-- +class + ( c SpecVersion, c TestedWith, c SpecLicense, c Token, c Token', c FilePathNT + ) + => FieldGrammar c g | g -> c + where + -- | Unfocus, zoom out, /blur/ 'FieldGrammar'. + blurFieldGrammar :: ALens' a b -> g b d -> g a d + + -- | Field which should be defined, exactly once. + uniqueFieldAla + :: (c b, Newtype a b) + => FieldName -- ^ field name + -> (a -> b) -- ^ 'Newtype' pack + -> ALens' s a -- ^ lens into the field + -> g s a + + -- | Boolean field with a default value. + booleanFieldDef + :: FieldName -- ^ field name + -> ALens' s Bool -- ^ lens into the field + -> Bool -- ^ default + -> g s Bool + + -- | Optional field. + optionalFieldAla + :: (c b, Newtype a b) + => FieldName -- ^ field name + -> (a -> b) -- ^ 'pack' + -> ALens' s (Maybe a) -- ^ lens into the field + -> g s (Maybe a) + + -- | Optional field with default value. + optionalFieldDefAla + :: (c b, Newtype a b, Eq a) + => FieldName -- ^ field name + -> (a -> b) -- ^ 'Newtype' pack + -> ALens' s a -- ^ @'Lens'' s a@: lens into the field + -> a -- ^ default value + -> g s a + + -- | Free text field is essentially 'optionalFieldDefAla` with @""@ + -- as the default and "accept everything" parser. + -- + -- @since 3.0.0.0 + freeTextField + :: FieldName + -> ALens' s (Maybe String) -- ^ lens into the field + -> g s (Maybe String) + + -- | Free text field is essentially 'optionalFieldDefAla` with @""@ + -- as the default and "accept everything" parser. + -- + -- @since 3.0.0.0 + freeTextFieldDef + :: FieldName + -> ALens' s String -- ^ lens into the field + -> g s String + + -- | @since 3.2.0.0 + freeTextFieldDefST + :: FieldName + -> ALens' s ShortText -- ^ lens into the field + -> g s ShortText + + -- | Monoidal field. + -- + -- Values are combined with 'mappend'. + -- + -- /Note:/ 'optionalFieldAla' is a @monoidalField@ with 'Last' monoid. + -- + monoidalFieldAla + :: (c b, Monoid a, Newtype a b) + => FieldName -- ^ field name + -> (a -> b) -- ^ 'pack' + -> ALens' s a -- ^ lens into the field + -> g s a + + -- | Parser matching all fields with a name starting with a prefix. + prefixedFields + :: FieldName -- ^ field name prefix + -> ALens' s [(String, String)] -- ^ lens into the field + -> g s [(String, String)] + + -- | Known field, which we don't parse, nor pretty print. + knownField :: FieldName -> g s () + + -- | Field which is parsed but not pretty printed. + hiddenField :: g s a -> g s a + + -- | Deprecated since + deprecatedSince + :: CabalSpecVersion -- ^ version + -> String -- ^ deprecation message + -> g s a + -> g s a + + -- | Removed in. If we encounter removed field, parsing fails. + removedIn + :: CabalSpecVersion -- ^ version + -> String -- ^ removal message + -> g s a + -> g s a + + -- | Annotate field with since spec-version. + availableSince + :: CabalSpecVersion -- ^ spec version + -> a -- ^ default value + -> g s a + -> g s a + + -- | Annotate field with since spec-version. + -- This is used to recognise, but warn about the field. + -- It is used to process @other-extensions@ field. + -- + -- Default implementation is to not warn. + -- + -- @since 3.4.0.0 + availableSinceWarn + :: CabalSpecVersion -- ^ spec version + -> g s a + -> g s a + availableSinceWarn _ = id + +-- | Field which can be defined at most once. +uniqueField + :: (FieldGrammar c g, c (Identity a)) + => FieldName -- ^ field name + -> ALens' s a -- ^ lens into the field + -> g s a +uniqueField fn l = uniqueFieldAla fn Identity l + +-- | Field which can be defined at most once. +optionalField + :: (FieldGrammar c g, c (Identity a)) + => FieldName -- ^ field name + -> ALens' s (Maybe a) -- ^ lens into the field + -> g s (Maybe a) +optionalField fn l = optionalFieldAla fn Identity l + +-- | Optional field with default value. +optionalFieldDef + :: (FieldGrammar c g, Functor (g s), c (Identity a), Eq a) + => FieldName -- ^ field name + -> ALens' s a -- ^ @'Lens'' s a@: lens into the field + -> a -- ^ default value + -> g s a +optionalFieldDef fn l x = optionalFieldDefAla fn Identity l x + +-- | Field which can be define multiple times, and the results are @mappend@ed. +monoidalField + :: (FieldGrammar c g, c (Identity a), Monoid a) + => FieldName -- ^ field name + -> ALens' s a -- ^ lens into the field + -> g s a +monoidalField fn l = monoidalFieldAla fn Identity l + +-- | Default implementation for 'freeTextFieldDefST'. +defaultFreeTextFieldDefST + :: (Functor (g s), FieldGrammar c g) + => FieldName + -> ALens' s ShortText -- ^ lens into the field + -> g s ShortText +defaultFreeTextFieldDefST fn l = + toShortText <$> freeTextFieldDef fn (cloneLens l . st) + where + st :: Lens' ShortText String + st f s = toShortText <$> f (fromShortText s) diff --git a/cabal/Cabal-syntax/src/Distribution/FieldGrammar/FieldDescrs.hs b/cabal/Cabal-syntax/src/Distribution/FieldGrammar/FieldDescrs.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/FieldGrammar/FieldDescrs.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoMonoLocalBinds #-} +module Distribution.FieldGrammar.FieldDescrs ( + FieldDescrs, + fieldDescrPretty, + fieldDescrParse, + fieldDescrsToList, + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Compat.Lens (aview, cloneLens) +import Distribution.Utils.String (trim) +import Distribution.Compat.Newtype +import Distribution.FieldGrammar +import Distribution.Pretty (Pretty (..), showFreeText) + +import qualified Data.Map as Map +import qualified Distribution.Compat.CharParsing as C +import qualified Distribution.Fields as P +import qualified Distribution.Parsec as P +import qualified Text.PrettyPrint as Disp + +-- strict pair +data SP s = SP + { pPretty :: !(s -> Disp.Doc) + , pParse :: !(forall m. P.CabalParsing m => s -> m s) + } + +-- | A collection of field parsers and pretty-printers. +newtype FieldDescrs s a = F { runF :: Map P.FieldName (SP s) } + deriving (Functor) + +instance Applicative (FieldDescrs s) where + pure _ = F mempty + f <*> x = F (mappend (runF f) (runF x)) + +singletonF :: P.FieldName -> (s -> Disp.Doc) -> (forall m. P.CabalParsing m => s -> m s) -> FieldDescrs s a +singletonF fn f g = F $ Map.singleton fn (SP f g) + +-- | Lookup a field value pretty-printer. +fieldDescrPretty :: FieldDescrs s a -> P.FieldName -> Maybe (s -> Disp.Doc) +fieldDescrPretty (F m) fn = pPretty <$> Map.lookup fn m + +-- | Lookup a field value parser. +fieldDescrParse :: P.CabalParsing m => FieldDescrs s a -> P.FieldName -> Maybe (s -> m s) +fieldDescrParse (F m) fn = (\f -> pParse f) <$> Map.lookup fn m + +fieldDescrsToList + :: P.CabalParsing m + => FieldDescrs s a + -> [(P.FieldName, s -> Disp.Doc, s -> m s)] +fieldDescrsToList = map mk . Map.toList . runF where + mk (name, SP ppr parse) = (name, ppr, parse) + +-- | /Note:/ default values are printed. +instance FieldGrammar ParsecPretty FieldDescrs where + blurFieldGrammar l (F m) = F (fmap blur m) where + blur (SP f g) = SP (f . aview l) (cloneLens l g) + + booleanFieldDef fn l _def = singletonF fn f g where + f s = Disp.text (show (aview l s)) + g s = cloneLens l (const P.parsec) s + -- Note: eta expansion is needed for RankNTypes type-checking to work. + + uniqueFieldAla fn _pack l = singletonF fn f g where + f s = pretty (pack' _pack (aview l s)) + g s = cloneLens l (const (unpack' _pack <$> P.parsec)) s + + optionalFieldAla fn _pack l = singletonF fn f g where + f s = maybe mempty (pretty . pack' _pack) (aview l s) + g s = cloneLens l (const (Just . unpack' _pack <$> P.parsec)) s + + optionalFieldDefAla fn _pack l _def = singletonF fn f g where + f s = pretty (pack' _pack (aview l s)) + g s = cloneLens l (const (unpack' _pack <$> P.parsec)) s + + freeTextField fn l = singletonF fn f g where + f s = maybe mempty showFreeText (aview l s) + g s = cloneLens l (const (Just <$> parsecFreeText)) s + + freeTextFieldDef fn l = singletonF fn f g where + f s = showFreeText (aview l s) + g s = cloneLens l (const parsecFreeText) s + + freeTextFieldDefST = defaultFreeTextFieldDefST + + monoidalFieldAla fn _pack l = singletonF fn f g where + f s = pretty (pack' _pack (aview l s)) + g s = cloneLens l (\x -> mappend x . unpack' _pack <$> P.parsec) s + + prefixedFields _fnPfx _l = F mempty + knownField _ = pure () + deprecatedSince _ _ x = x + removedIn _ _ x = x + availableSince _ _ = id + hiddenField _ = F mempty + +parsecFreeText :: P.CabalParsing m => m String +parsecFreeText = dropDotLines <$ C.spaces <*> many C.anyChar + where + -- Example package with dot lines + -- http://hackage.haskell.org/package/copilot-cbmc-0.1/copilot-cbmc.cabal + dropDotLines "." = "." + dropDotLines x = intercalate "\n" . map dotToEmpty . lines $ x + + dotToEmpty x | trim' x == "." = "" + dotToEmpty x = trim x + + trim' :: String -> String + trim' = dropWhileEnd (`elem` (" \t" :: String)) + + +class (P.Parsec a, Pretty a) => ParsecPretty a +instance (P.Parsec a, Pretty a) => ParsecPretty a diff --git a/cabal/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs b/cabal/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs @@ -0,0 +1,393 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | This module provides @newtype@ wrappers to be used with "Distribution.FieldGrammar". +module Distribution.FieldGrammar.Newtypes ( + -- * List + alaList, + alaList', + -- ** Modifiers + CommaVCat (..), + CommaFSep (..), + VCat (..), + FSep (..), + NoCommaFSep (..), + Sep (..), + -- ** Type + List, + -- ** Set + alaSet, + alaSet', + Set', + -- ** NonEmpty + alaNonEmpty, + alaNonEmpty', + NonEmpty', + -- * Version & License + SpecVersion (..), + TestedWith (..), + SpecLicense (..), + -- * Identifiers + Token (..), + Token' (..), + MQuoted (..), + FilePathNT (..), + ) where + +import Distribution.Compat.Newtype +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.CabalSpecVersion +import Distribution.Compiler (CompilerFlavor) +import Distribution.License (License) +import Distribution.Parsec +import Distribution.Pretty +import Distribution.Version + (LowerBound (..), Version, VersionInterval (..), VersionRange, VersionRangeF (..), anyVersion, asVersionIntervals, cataVersionRange, mkVersion, + version0, versionNumbers) +import Text.PrettyPrint (Doc, comma, fsep, punctuate, text, vcat) + +import qualified Data.List.NonEmpty as NE +import qualified Data.Set as Set +import qualified Distribution.Compat.CharParsing as P +import qualified Distribution.SPDX as SPDX + +-- | Vertical list with commas. Displayed with 'vcat' +data CommaVCat = CommaVCat + +-- | Paragraph fill list with commas. Displayed with 'fsep' +data CommaFSep = CommaFSep + +-- | Vertical list with optional commas. Displayed with 'vcat'. +data VCat = VCat + +-- | Paragraph fill list with optional commas. Displayed with 'fsep'. +data FSep = FSep + +-- | Paragraph fill list without commas. Displayed with 'fsep'. +data NoCommaFSep = NoCommaFSep + +class Sep sep where + prettySep :: Proxy sep -> [Doc] -> Doc + + parseSep :: CabalParsing m => Proxy sep -> m a -> m [a] + parseSepNE :: CabalParsing m => Proxy sep -> m a -> m (NonEmpty a) + +instance Sep CommaVCat where + prettySep _ = vcat . punctuate comma + parseSep _ p = do + v <- askCabalSpecVersion + if v >= CabalSpecV2_2 then parsecLeadingCommaList p else parsecCommaList p + parseSepNE _ p = do + v <- askCabalSpecVersion + if v >= CabalSpecV2_2 then parsecLeadingCommaNonEmpty p else parsecCommaNonEmpty p +instance Sep CommaFSep where + prettySep _ = fsep . punctuate comma + parseSep _ p = do + v <- askCabalSpecVersion + if v >= CabalSpecV2_2 then parsecLeadingCommaList p else parsecCommaList p + parseSepNE _ p = do + v <- askCabalSpecVersion + if v >= CabalSpecV2_2 then parsecLeadingCommaNonEmpty p else parsecCommaNonEmpty p +instance Sep VCat where + prettySep _ = vcat + parseSep _ p = do + v <- askCabalSpecVersion + if v >= CabalSpecV3_0 then parsecLeadingOptCommaList p else parsecOptCommaList p + parseSepNE _ p = NE.some1 (p <* P.spaces) +instance Sep FSep where + prettySep _ = fsep + parseSep _ p = do + v <- askCabalSpecVersion + if v >= CabalSpecV3_0 then parsecLeadingOptCommaList p else parsecOptCommaList p + parseSepNE _ p = NE.some1 (p <* P.spaces) +instance Sep NoCommaFSep where + prettySep _ = fsep + parseSep _ p = many (p <* P.spaces) + parseSepNE _ p = NE.some1 (p <* P.spaces) + +-- | List separated with optional commas. Displayed with @sep@, arguments of +-- type @a@ are parsed and pretty-printed as @b@. +newtype List sep b a = List { _getList :: [a] } + +-- | 'alaList' and 'alaList'' are simply 'List', with additional phantom +-- arguments to constrain the resulting type +-- +-- >>> :t alaList VCat +-- alaList VCat :: [a] -> List VCat (Identity a) a +-- +-- >>> :t alaList' FSep Token +-- alaList' FSep Token :: [String] -> List FSep Token String +-- +alaList :: sep -> [a] -> List sep (Identity a) a +alaList _ = List + +-- | More general version of 'alaList'. +alaList' :: sep -> (a -> b) -> [a] -> List sep b a +alaList' _ _ = List + +instance Newtype [a] (List sep wrapper a) + +instance (Newtype a b, Sep sep, Parsec b) => Parsec (List sep b a) where + parsec = pack . map (unpack :: b -> a) <$> parseSep (Proxy :: Proxy sep) parsec + +instance (Newtype a b, Sep sep, Pretty b) => Pretty (List sep b a) where + pretty = prettySep (Proxy :: Proxy sep) . map (pretty . (pack :: a -> b)) . unpack + +-- +-- | Like 'List', but for 'Set'. +-- +-- @since 3.2.0.0 +newtype Set' sep b a = Set' { _getSet :: Set a } + +-- | 'alaSet' and 'alaSet'' are simply 'Set'' constructor, with additional phantom +-- arguments to constrain the resulting type +-- +-- >>> :t alaSet VCat +-- alaSet VCat :: Set a -> Set' VCat (Identity a) a +-- +-- >>> :t alaSet' FSep Token +-- alaSet' FSep Token :: Set String -> Set' FSep Token String +-- +-- >>> unpack' (alaSet' FSep Token) <$> eitherParsec "foo bar foo" +-- Right (fromList ["bar","foo"]) +-- +-- @since 3.2.0.0 +alaSet :: sep -> Set a -> Set' sep (Identity a) a +alaSet _ = Set' + +-- | More general version of 'alaSet'. +-- +-- @since 3.2.0.0 +alaSet' :: sep -> (a -> b) -> Set a -> Set' sep b a +alaSet' _ _ = Set' + +instance Newtype (Set a) (Set' sep wrapper a) + +instance (Newtype a b, Ord a, Sep sep, Parsec b) => Parsec (Set' sep b a) where + parsec = pack . Set.fromList . map (unpack :: b -> a) <$> parseSep (Proxy :: Proxy sep) parsec + +instance (Newtype a b, Sep sep, Pretty b) => Pretty (Set' sep b a) where + pretty = prettySep (Proxy :: Proxy sep) . map (pretty . (pack :: a -> b)) . Set.toList . unpack + +-- +-- | Like 'List', but for 'NonEmpty'. +-- +-- @since 3.2.0.0 +newtype NonEmpty' sep b a = NonEmpty' { _getNonEmpty :: NonEmpty a } + +-- | 'alaNonEmpty' and 'alaNonEmpty'' are simply 'NonEmpty'' constructor, with additional phantom +-- arguments to constrain the resulting type +-- +-- >>> :t alaNonEmpty VCat +-- alaNonEmpty VCat :: NonEmpty a -> NonEmpty' VCat (Identity a) a +-- +-- >>> unpack' (alaNonEmpty' FSep Token) <$> eitherParsec "foo bar foo" +-- Right ("foo" :| ["bar","foo"]) +-- +-- @since 3.2.0.0 +alaNonEmpty :: sep -> NonEmpty a -> NonEmpty' sep (Identity a) a +alaNonEmpty _ = NonEmpty' + +-- | More general version of 'alaNonEmpty'. +-- +-- @since 3.2.0.0 +alaNonEmpty' :: sep -> (a -> b) -> NonEmpty a -> NonEmpty' sep b a +alaNonEmpty' _ _ = NonEmpty' + +instance Newtype (NonEmpty a) (NonEmpty' sep wrapper a) + +instance (Newtype a b, Sep sep, Parsec b) => Parsec (NonEmpty' sep b a) where + parsec = pack . fmap (unpack :: b -> a) <$> parseSepNE (Proxy :: Proxy sep) parsec + +instance (Newtype a b, Sep sep, Pretty b) => Pretty (NonEmpty' sep b a) where + pretty = prettySep (Proxy :: Proxy sep) . map (pretty . (pack :: a -> b)) . NE.toList . unpack + +------------------------------------------------------------------------------- +-- Identifiers +------------------------------------------------------------------------------- + +-- | Haskell string or @[^ ,]+@ +newtype Token = Token { getToken :: String } + +instance Newtype String Token + +instance Parsec Token where + parsec = pack <$> parsecToken + +instance Pretty Token where + pretty = showToken . unpack + +-- | Haskell string or @[^ ]+@ +newtype Token' = Token' { getToken' :: String } + +instance Newtype String Token' + +instance Parsec Token' where + parsec = pack <$> parsecToken' + +instance Pretty Token' where + pretty = showToken . unpack + +-- | Either @"quoted"@ or @un-quoted@. +newtype MQuoted a = MQuoted { getMQuoted :: a } + +instance Newtype a (MQuoted a) + +instance Parsec a => Parsec (MQuoted a) where + parsec = pack <$> parsecMaybeQuoted parsec + +instance Pretty a => Pretty (MQuoted a) where + pretty = pretty . unpack + +-- | Filepath are parsed as 'Token'. +newtype FilePathNT = FilePathNT { getFilePathNT :: String } + +instance Newtype String FilePathNT + +instance Parsec FilePathNT where + parsec = do + token <- parsecToken + if null token + then P.unexpected "empty FilePath" + else return (FilePathNT token) + +instance Pretty FilePathNT where + pretty = showFilePath . unpack + +------------------------------------------------------------------------------- +-- SpecVersion +------------------------------------------------------------------------------- + +-- | Version range or just version, i.e. @cabal-version@ field. +-- +-- There are few things to consider: +-- +-- * Starting with 2.2 the cabal-version field should be the first field in the +-- file and only exact version is accepted. Therefore if we get e.g. +-- @>= 2.2@, we fail. +-- See +-- +-- We have this newtype, as writing Parsec and Pretty instances +-- for CabalSpecVersion would cause cycle in modules: +-- Version -> CabalSpecVersion -> Parsec -> ... +-- +newtype SpecVersion = SpecVersion { getSpecVersion :: CabalSpecVersion } + deriving (Eq, Show) -- instances needed for tests + +instance Newtype CabalSpecVersion SpecVersion + +instance Parsec SpecVersion where + parsec = do + e <- parsecSpecVersion + let ver :: Version + ver = either id specVersionFromRange e + + digits :: [Int] + digits = versionNumbers ver + + case cabalSpecFromVersionDigits digits of + Nothing -> fail $ "Unknown cabal spec version specified: " ++ prettyShow ver + Just csv -> do + -- Check some warnings: + case e of + -- example: cabal-version: 1.10 + -- should be cabal-version: >=1.10 + Left _v | csv < CabalSpecV1_12 -> parsecWarning PWTSpecVersion $ concat + [ "With 1.10 or earlier, the 'cabal-version' field must use " + , "range syntax rather than a simple version number. Use " + , "'cabal-version: >= " ++ prettyShow ver ++ "'." + ] + + -- example: cabal-version: >=1.12 + -- should be cabal-version: 1.12 + Right _vr | csv >= CabalSpecV1_12 -> parsecWarning PWTSpecVersion $ concat + [ "Packages with 'cabal-version: 1.12' or later should specify a " + , "specific version of the Cabal spec of the form " + , "'cabal-version: x.y'. " + , "Use 'cabal-version: " ++ prettyShow ver ++ "'." + ] + + -- example: cabal-version: >=1.10 && <1.12 + -- should be cabal-version: >=1.10 + Right vr | csv < CabalSpecV1_12 + , not (simpleSpecVersionRangeSyntax vr) -> parsecWarning PWTSpecVersion $ concat + [ "It is recommended that the 'cabal-version' field only specify a " + , "version range of the form '>= x.y' for older cabal versions. Use " + , "'cabal-version: >= " ++ prettyShow ver ++ "'. " + , "Tools based on Cabal 1.10 and later will ignore upper bounds." + ] + + -- otherwise no warnings + _ -> pure () + + return (pack csv) + where + parsecSpecVersion = Left <$> parsec <|> Right <$> range + + range = do + vr <- parsec + if specVersionFromRange vr >= mkVersion [2,1] + then fail "cabal-version higher than 2.2 cannot be specified as a range. See https://github.com/haskell/cabal/issues/4899" + else return vr + + specVersionFromRange :: VersionRange -> Version + specVersionFromRange versionRange = case asVersionIntervals versionRange of + [] -> version0 + VersionInterval (LowerBound version _) _ : _ -> version + + simpleSpecVersionRangeSyntax = cataVersionRange alg where + alg (OrLaterVersionF _) = True + alg _ = False + + +instance Pretty SpecVersion where + pretty (SpecVersion csv) + | csv >= CabalSpecV1_12 = text (showCabalSpecVersion csv) + | otherwise = text ">=" <<>> text (showCabalSpecVersion csv) + +------------------------------------------------------------------------------- +-- SpecLicense +------------------------------------------------------------------------------- + +-- | SPDX License expression or legacy license +newtype SpecLicense = SpecLicense { getSpecLicense :: Either SPDX.License License } + deriving (Show, Eq) + +instance Newtype (Either SPDX.License License) SpecLicense + +instance Parsec SpecLicense where + parsec = do + v <- askCabalSpecVersion + if v >= CabalSpecV2_2 + then SpecLicense . Left <$> parsec + else SpecLicense . Right <$> parsec + +instance Pretty SpecLicense where + pretty = either pretty pretty . unpack + +------------------------------------------------------------------------------- +-- TestedWith +------------------------------------------------------------------------------- + +-- | Version range or just version +newtype TestedWith = TestedWith { getTestedWith :: (CompilerFlavor, VersionRange) } + +instance Newtype (CompilerFlavor, VersionRange) TestedWith + +instance Parsec TestedWith where + parsec = pack <$> parsecTestedWith + +instance Pretty TestedWith where + pretty x = case unpack x of + (compiler, vr) -> pretty compiler <+> pretty vr + +parsecTestedWith :: CabalParsing m => m (CompilerFlavor, VersionRange) +parsecTestedWith = do + name <- lexemeParsec + ver <- parsec <|> pure anyVersion + return (name, ver) diff --git a/cabal/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs b/cabal/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs @@ -0,0 +1,434 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | This module provides a 'FieldGrammarParser', one way to parse +-- @.cabal@ -like files. +-- +-- Fields can be specified multiple times in the .cabal files. The order of +-- such entries is important, but the mutual ordering of different fields is +-- not.Also conditional sections are considered after non-conditional data. +-- The example of this silent-commutation quirk is the fact that +-- +-- @ +-- buildable: True +-- if os(linux) +-- buildable: False +-- @ +-- +-- and +-- +-- @ +-- if os(linux) +-- buildable: False +-- buildable: True +-- @ +-- +-- behave the same! This is the limitation of 'GeneralPackageDescription' +-- structure. +-- +-- So we transform the list of fields @['Field' ann]@ into +-- a map of grouped ordinary fields and a list of lists of sections: +-- @'Fields' ann = 'Map' 'FieldName' ['NamelessField' ann]@ and @[['Section' ann]]@. +-- +-- We need list of list of sections, because we need to distinguish situations +-- where there are fields in between. For example +-- +-- @ +-- if flag(bytestring-lt-0_10_4) +-- build-depends: bytestring < 0.10.4 +-- +-- default-language: Haskell2020 +-- +-- else +-- build-depends: bytestring >= 0.10.4 +-- +-- @ +-- +-- is obviously invalid specification. +-- +-- We can parse 'Fields' like we parse @aeson@ objects, yet we use +-- slightly higher-level API, so we can process unspecified fields, +-- to report unknown fields and save custom @x-fields@. +-- +module Distribution.FieldGrammar.Parsec ( + ParsecFieldGrammar, + parseFieldGrammar, + fieldGrammarKnownFieldList, + -- * Auxiliary + Fields, + NamelessField (..), + namelessFieldAnn, + Section (..), + runFieldParser, + runFieldParser', + fieldLinesToStream, + ) where + +import Distribution.Compat.Newtype +import Distribution.Compat.Prelude +import Distribution.Utils.Generic (fromUTF8BS) +import Distribution.Utils.String (trim) +import Prelude () + +import qualified Data.ByteString as BS +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified Distribution.Utils.ShortText as ShortText +import qualified Text.Parsec as P +import qualified Text.Parsec.Error as P + +import Distribution.CabalSpecVersion +import Distribution.FieldGrammar.Class +import Distribution.Fields.Field +import Distribution.Fields.ParseResult +import Distribution.Parsec +import Distribution.Parsec.FieldLineStream +import Distribution.Parsec.Position (positionCol, positionRow) + +------------------------------------------------------------------------------- +-- Auxiliary types +------------------------------------------------------------------------------- + +type Fields ann = Map FieldName [NamelessField ann] + +-- | Single field, without name, but with its annotation. +data NamelessField ann = MkNamelessField !ann [FieldLine ann] + deriving (Eq, Show, Functor) + +namelessFieldAnn :: NamelessField ann -> ann +namelessFieldAnn (MkNamelessField ann _) = ann + +-- | The 'Section' constructor of 'Field'. +data Section ann = MkSection !(Name ann) [SectionArg ann] [Field ann] + deriving (Eq, Show, Functor) + +------------------------------------------------------------------------------- +-- ParsecFieldGrammar +------------------------------------------------------------------------------- + +data ParsecFieldGrammar s a = ParsecFG + { fieldGrammarKnownFields :: !(Set FieldName) + , fieldGrammarKnownPrefixes :: !(Set FieldName) + , fieldGrammarParser :: !(CabalSpecVersion -> Fields Position -> ParseResult a) + } + deriving (Functor) + +parseFieldGrammar :: CabalSpecVersion -> Fields Position -> ParsecFieldGrammar s a -> ParseResult a +parseFieldGrammar v fields grammar = do + for_ (Map.toList (Map.filterWithKey isUnknownField fields)) $ \(name, nfields) -> + for_ nfields $ \(MkNamelessField pos _) -> + parseWarning pos PWTUnknownField $ "Unknown field: " ++ show name + -- TODO: fields allowed in this section + + -- parse + fieldGrammarParser grammar v fields + + where + isUnknownField k _ = not $ + k `Set.member` fieldGrammarKnownFields grammar + || any (`BS.isPrefixOf` k) (fieldGrammarKnownPrefixes grammar) + +fieldGrammarKnownFieldList :: ParsecFieldGrammar s a -> [FieldName] +fieldGrammarKnownFieldList = Set.toList . fieldGrammarKnownFields + +instance Applicative (ParsecFieldGrammar s) where + pure x = ParsecFG mempty mempty (\_ _ -> pure x) + {-# INLINE pure #-} + + ParsecFG f f' f'' <*> ParsecFG x x' x'' = ParsecFG + (mappend f x) + (mappend f' x') + (\v fields -> f'' v fields <*> x'' v fields) + {-# INLINE (<*>) #-} + +warnMultipleSingularFields :: FieldName -> [NamelessField Position] -> ParseResult () +warnMultipleSingularFields _ [] = pure () +warnMultipleSingularFields fn (x : xs) = do + let pos = namelessFieldAnn x + poss = map namelessFieldAnn xs + parseWarning pos PWTMultipleSingularField $ + "The field " <> show fn <> " is specified more than once at positions " ++ intercalate ", " (map showPos (pos : poss)) + +instance FieldGrammar Parsec ParsecFieldGrammar where + blurFieldGrammar _ (ParsecFG s s' parser) = ParsecFG s s' parser + + uniqueFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser + where + parser v fields = case Map.lookup fn fields of + Nothing -> parseFatalFailure zeroPos $ show fn ++ " field missing" + Just [] -> parseFatalFailure zeroPos $ show fn ++ " field missing" + Just [x] -> parseOne v x + Just xs@(_:y:ys) -> do + warnMultipleSingularFields fn xs + NE.last <$> traverse (parseOne v) (y:|ys) + + parseOne v (MkNamelessField pos fls) = + unpack' _pack <$> runFieldParser pos parsec v fls + + booleanFieldDef fn _extract def = ParsecFG (Set.singleton fn) Set.empty parser + where + parser v fields = case Map.lookup fn fields of + Nothing -> pure def + Just [] -> pure def + Just [x] -> parseOne v x + Just xs@(_:y:ys) -> do + warnMultipleSingularFields fn xs + NE.last <$> traverse (parseOne v) (y:|ys) + + parseOne v (MkNamelessField pos fls) = runFieldParser pos parsec v fls + + optionalFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser + where + parser v fields = case Map.lookup fn fields of + Nothing -> pure Nothing + Just [] -> pure Nothing + Just [x] -> parseOne v x + Just xs@(_:y:ys) -> do + warnMultipleSingularFields fn xs + NE.last <$> traverse (parseOne v) (y:|ys) + + parseOne v (MkNamelessField pos fls) + | null fls = pure Nothing + | otherwise = Just . unpack' _pack <$> runFieldParser pos parsec v fls + + optionalFieldDefAla fn _pack _extract def = ParsecFG (Set.singleton fn) Set.empty parser + where + parser v fields = case Map.lookup fn fields of + Nothing -> pure def + Just [] -> pure def + Just [x] -> parseOne v x + Just xs@(_:y:ys) -> do + warnMultipleSingularFields fn xs + NE.last <$> traverse (parseOne v) (y:|ys) + + parseOne v (MkNamelessField pos fls) + | null fls = pure def + | otherwise = unpack' _pack <$> runFieldParser pos parsec v fls + + freeTextField fn _ = ParsecFG (Set.singleton fn) Set.empty parser where + parser v fields = case Map.lookup fn fields of + Nothing -> pure Nothing + Just [] -> pure Nothing + Just [x] -> parseOne v x + Just xs@(_:y:ys) -> do + warnMultipleSingularFields fn xs + NE.last <$> traverse (parseOne v) (y:|ys) + + parseOne v (MkNamelessField pos fls) + | null fls = pure Nothing + | v >= CabalSpecV3_0 = pure (Just (fieldlinesToFreeText3 pos fls)) + | otherwise = pure (Just (fieldlinesToFreeText fls)) + + freeTextFieldDef fn _ = ParsecFG (Set.singleton fn) Set.empty parser where + parser v fields = case Map.lookup fn fields of + Nothing -> pure "" + Just [] -> pure "" + Just [x] -> parseOne v x + Just xs@(_:y:ys) -> do + warnMultipleSingularFields fn xs + NE.last <$> traverse (parseOne v) (y:|ys) + + parseOne v (MkNamelessField pos fls) + | null fls = pure "" + | v >= CabalSpecV3_0 = pure (fieldlinesToFreeText3 pos fls) + | otherwise = pure (fieldlinesToFreeText fls) + + -- freeTextFieldDefST = defaultFreeTextFieldDefST + freeTextFieldDefST fn _ = ParsecFG (Set.singleton fn) Set.empty parser where + parser v fields = case Map.lookup fn fields of + Nothing -> pure mempty + Just [] -> pure mempty + Just [x] -> parseOne v x + Just xs@(_:y:ys) -> do + warnMultipleSingularFields fn xs + NE.last <$> traverse (parseOne v) (y:|ys) + + parseOne v (MkNamelessField pos fls) = case fls of + [] -> pure mempty + [FieldLine _ bs] -> pure (ShortText.unsafeFromUTF8BS bs) + _ | v >= CabalSpecV3_0 -> pure (ShortText.toShortText $ fieldlinesToFreeText3 pos fls) + | otherwise -> pure (ShortText.toShortText $ fieldlinesToFreeText fls) + + monoidalFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser + where + parser v fields = case Map.lookup fn fields of + Nothing -> pure mempty + Just xs -> foldMap (unpack' _pack) <$> traverse (parseOne v) xs + + parseOne v (MkNamelessField pos fls) = runFieldParser pos parsec v fls + + prefixedFields fnPfx _extract = ParsecFG mempty (Set.singleton fnPfx) (\_ fs -> pure (parser fs)) + where + parser :: Fields Position -> [(String, String)] + parser values = reorder $ concatMap convert $ filter match $ Map.toList values + + match (fn, _) = fnPfx `BS.isPrefixOf` fn + convert (fn, fields) = + [ (pos, (fromUTF8BS fn, trim $ fromUTF8BS $ fieldlinesToBS fls)) + | MkNamelessField pos fls <- fields + ] + -- hack: recover the order of prefixed fields + reorder = map snd . sortBy (comparing fst) + + availableSince vs def (ParsecFG names prefixes parser) = ParsecFG names prefixes parser' + where + parser' v values + | v >= vs = parser v values + | otherwise = do + let unknownFields = Map.intersection values $ Map.fromSet (const ()) names + for_ (Map.toList unknownFields) $ \(name, fields) -> + for_ fields $ \(MkNamelessField pos _) -> + parseWarning pos PWTUnknownField $ + "The field " <> show name <> " is available only since the Cabal specification version " ++ showCabalSpecVersion vs ++ ". This field will be ignored." + + pure def + + availableSinceWarn vs (ParsecFG names prefixes parser) = ParsecFG names prefixes parser' + where + parser' v values + | v >= vs = parser v values + | otherwise = do + let unknownFields = Map.intersection values $ Map.fromSet (const ()) names + for_ (Map.toList unknownFields) $ \(name, fields) -> + for_ fields $ \(MkNamelessField pos _) -> + parseWarning pos PWTUnknownField $ + "The field " <> show name <> " is available only since the Cabal specification version " ++ showCabalSpecVersion vs ++ "." + + parser v values + + + -- todo we know about this field + deprecatedSince vs msg (ParsecFG names prefixes parser) = ParsecFG names prefixes parser' + where + parser' v values + | v >= vs = do + let deprecatedFields = Map.intersection values $ Map.fromSet (const ()) names + for_ (Map.toList deprecatedFields) $ \(name, fields) -> + for_ fields $ \(MkNamelessField pos _) -> + parseWarning pos PWTDeprecatedField $ + "The field " <> show name <> " is deprecated in the Cabal specification version " ++ showCabalSpecVersion vs ++ ". " ++ msg + + parser v values + + | otherwise = parser v values + + removedIn vs msg (ParsecFG names prefixes parser) = ParsecFG names prefixes parser' where + parser' v values + | v >= vs = do + let msg' = if null msg then "" else ' ' : msg + let unknownFields = Map.intersection values $ Map.fromSet (const ()) names + let namePos = + [ (name, pos) + | (name, fields) <- Map.toList unknownFields + , MkNamelessField pos _ <- fields + ] + + let makeMsg name = "The field " <> show name <> " is removed in the Cabal specification version " ++ showCabalSpecVersion vs ++ "." ++ msg' + + case namePos of + -- no fields => proceed (with empty values, to be sure) + [] -> parser v mempty + + -- if there's single field: fail fatally with it + ((name, pos) : rest) -> do + for_ rest $ \(name', pos') -> parseFailure pos' $ makeMsg name' + parseFatalFailure pos $ makeMsg name + + | otherwise = parser v values + + knownField fn = ParsecFG (Set.singleton fn) Set.empty (\_ _ -> pure ()) + + hiddenField = id + +------------------------------------------------------------------------------- +-- Parsec +------------------------------------------------------------------------------- + +runFieldParser' :: [Position] -> ParsecParser a -> CabalSpecVersion -> FieldLineStream -> ParseResult a +runFieldParser' inputPoss p v str = case P.runParser p' [] "" str of + Right (pok, ws) -> do + traverse_ (\(PWarning t pos w) -> parseWarning (mapPosition pos) t w) ws + pure pok + Left err -> do + let ppos = P.errorPos err + let epos = mapPosition $ Position (P.sourceLine ppos) (P.sourceColumn ppos) + + let msg = P.showErrorMessages + "or" "unknown parse error" "expecting" "unexpected" "end of input" + (P.errorMessages err) + parseFatalFailure epos $ msg ++ "\n" + where + p' = (,) <$ P.spaces <*> unPP p v <* P.spaces <* P.eof <*> P.getState + + -- Positions start from 1:1, not 0:0 + mapPosition (Position prow pcol) = go (prow - 1) inputPoss where + go _ [] = zeroPos + go _ [Position row col] = Position row (col + pcol - 1) + go n (Position row col:_) | n <= 0 = Position row (col + pcol - 1) + go n (_:ps) = go (n - 1) ps + +runFieldParser :: Position -> ParsecParser a -> CabalSpecVersion -> [FieldLine Position] -> ParseResult a +runFieldParser pp p v ls = runFieldParser' poss p v (fieldLinesToStream ls) + where + poss = map (\(FieldLine pos _) -> pos) ls ++ [pp] -- add "default" position + +fieldlinesToBS :: [FieldLine ann] -> BS.ByteString +fieldlinesToBS = BS.intercalate "\n" . map (\(FieldLine _ bs) -> bs) + +-- Example package with dot lines +-- http://hackage.haskell.org/package/copilot-cbmc-0.1/copilot-cbmc.cabal +fieldlinesToFreeText :: [FieldLine ann] -> String +fieldlinesToFreeText [FieldLine _ "."] = "." +fieldlinesToFreeText fls = intercalate "\n" (map go fls) + where + go (FieldLine _ bs) + | s == "." = "" + | otherwise = s + where + s = trim (fromUTF8BS bs) + +fieldlinesToFreeText3 :: Position -> [FieldLine Position] -> String +fieldlinesToFreeText3 _ [] = "" +fieldlinesToFreeText3 _ [FieldLine _ bs] = fromUTF8BS bs +fieldlinesToFreeText3 pos (FieldLine pos1 bs1 : fls2@(FieldLine pos2 _ : _)) + -- if first line is on the same line with field name: + -- the indentation level is either + -- 1. the indentation of left most line in rest fields + -- 2. the indentation of the first line + -- whichever is leftmost + | positionRow pos == positionRow pos1 = concat + $ fromUTF8BS bs1 + : mealy (mk mcol1) pos1 fls2 + + -- otherwise, also indent the first line + | otherwise = concat + $ replicate (positionCol pos1 - mcol2) ' ' + : fromUTF8BS bs1 + : mealy (mk mcol2) pos1 fls2 + + where + mcol1 = foldl' (\a b -> min a $ positionCol $ fieldLineAnn b) (min (positionCol pos1) (positionCol pos2)) fls2 + mcol2 = foldl' (\a b -> min a $ positionCol $ fieldLineAnn b) (positionCol pos1) fls2 + + mk :: Int -> Position -> FieldLine Position -> (Position, String) + mk col p (FieldLine q bs) = + ( q + , replicate newlines '\n' + ++ replicate indent ' ' + ++ fromUTF8BS bs + ) + where + newlines = positionRow q - positionRow p + indent = positionCol q - col + +mealy :: (s -> a -> (s, b)) -> s -> [a] -> [b] +mealy f = go where + go _ [] = [] + go s (x : xs) = let ~(s', y) = f s x in y : go s' xs + +fieldLinesToStream :: [FieldLine ann] -> FieldLineStream +fieldLinesToStream [] = fieldLineStreamEnd +fieldLinesToStream [FieldLine _ bs] = FLSLast bs +fieldLinesToStream (FieldLine _ bs : fs) = FLSCons bs (fieldLinesToStream fs) diff --git a/cabal/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs b/cabal/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Distribution.FieldGrammar.Pretty ( + PrettyFieldGrammar, + prettyFieldGrammar, + ) where + +import Distribution.CabalSpecVersion +import Distribution.Compat.Lens +import Distribution.Compat.Newtype +import Distribution.Compat.Prelude +import Distribution.Fields.Field (FieldName) +import Distribution.Fields.Pretty (PrettyField (..)) +import Distribution.Pretty (Pretty (..), showFreeText, showFreeTextV3) +import Distribution.Utils.Generic (toUTF8BS) +import Prelude () +import Text.PrettyPrint (Doc) +import qualified Text.PrettyPrint as PP + +import Distribution.FieldGrammar.Class + +newtype PrettyFieldGrammar s a = PrettyFG + { fieldGrammarPretty :: CabalSpecVersion -> s -> [PrettyField ()] + } + deriving (Functor) + +instance Applicative (PrettyFieldGrammar s) where + pure _ = PrettyFG (\_ _ -> mempty) + PrettyFG f <*> PrettyFG x = PrettyFG (\v s -> f v s <> x v s) + +-- | We can use 'PrettyFieldGrammar' to pp print the @s@. +-- +-- /Note:/ there is not trailing @($+$ text "")@. +prettyFieldGrammar :: CabalSpecVersion -> PrettyFieldGrammar s a -> s -> [PrettyField ()] +prettyFieldGrammar = flip fieldGrammarPretty + +instance FieldGrammar Pretty PrettyFieldGrammar where + blurFieldGrammar f (PrettyFG pp) = PrettyFG (\v -> pp v . aview f) + + uniqueFieldAla fn _pack l = PrettyFG $ \_v s -> + ppField fn (pretty (pack' _pack (aview l s))) + + booleanFieldDef fn l def = PrettyFG pp + where + pp _v s + | b == def = mempty + | otherwise = ppField fn (PP.text (show b)) + where + b = aview l s + + optionalFieldAla fn _pack l = PrettyFG pp + where + pp v s = case aview l s of + Nothing -> mempty + Just a -> ppField fn (prettyVersioned v (pack' _pack a)) + + optionalFieldDefAla fn _pack l def = PrettyFG pp + where + pp v s + | x == def = mempty + | otherwise = ppField fn (prettyVersioned v (pack' _pack x)) + where + x = aview l s + + freeTextField fn l = PrettyFG pp where + pp v s = maybe mempty (ppField fn . showFT) (aview l s) where + showFT | v >= CabalSpecV3_0 = showFreeTextV3 + | otherwise = showFreeText + + -- it's ok to just show, as showFreeText of empty string is empty. + freeTextFieldDef fn l = PrettyFG pp where + pp v s = ppField fn (showFT (aview l s)) where + showFT | v >= CabalSpecV3_0 = showFreeTextV3 + | otherwise = showFreeText + + freeTextFieldDefST = defaultFreeTextFieldDefST + + monoidalFieldAla fn _pack l = PrettyFG pp + where + pp v s = ppField fn (prettyVersioned v (pack' _pack (aview l s))) + + prefixedFields _fnPfx l = PrettyFG (\_ -> pp . aview l) + where + pp xs = + -- always print the field, even its Doc is empty. + -- i.e. don't use ppField + [ PrettyField () (toUTF8BS n) $ PP.vcat $ map PP.text $ lines s + | (n, s) <- xs + -- fnPfx `isPrefixOf` n + ] + + knownField _ = pure () + deprecatedSince _ _ x = x + -- TODO: as PrettyFieldGrammar isn't aware of cabal-version: we output the field + -- this doesn't affect roundtrip as `removedIn` fields cannot be parsed + -- so invalid documents can be only manually constructed. + removedIn _ _ x = x + availableSince _ _ = id + hiddenField _ = PrettyFG (\_ -> mempty) + +ppField :: FieldName -> Doc -> [PrettyField ()] +ppField name fielddoc + | PP.isEmpty fielddoc = [] + | otherwise = [ PrettyField () name fielddoc ] diff --git a/cabal/Cabal-syntax/src/Distribution/Fields.hs b/cabal/Cabal-syntax/src/Distribution/Fields.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Fields.hs @@ -0,0 +1,42 @@ +-- | Utilities to work with @.cabal@ like file structure. +module Distribution.Fields ( + -- * Types + Field(..), + Name(..), + FieldLine(..), + SectionArg(..), + FieldName, + -- * Grammar and parsing + -- + -- See "Distribution.Fields.Parser" for grammar. + readFields, + readFields', + -- ** ParseResult + ParseResult, + runParseResult, + parseWarning, + parseWarnings, + parseFailure, + parseFatalFailure, + -- ** Warnings + PWarnType (..), + PWarning (..), + showPWarning, + -- ** Errors + PError (..), + showPError, + -- * Pretty printing + CommentPosition (..), + PrettyField (..), + showFields, + -- ** Transformation from Field + genericFromParsecFields, + fromParsecFields, + ) where + +import Distribution.Fields.Field +import Distribution.Fields.Parser +import Distribution.Fields.ParseResult +import Distribution.Fields.Pretty +import Distribution.Parsec.Error +import Distribution.Parsec.Warning diff --git a/cabal/Cabal-syntax/src/Distribution/Fields/ConfVar.hs b/cabal/Cabal-syntax/src/Distribution/Fields/ConfVar.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Fields/ConfVar.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoMonoLocalBinds #-} +module Distribution.Fields.ConfVar (parseConditionConfVar, parseConditionConfVarFromClause) where + +import Distribution.Compat.CharParsing (char, integral) +import Distribution.Compat.Prelude +import Distribution.Fields.Field (SectionArg (..), Field(..)) +import Distribution.Fields.ParseResult +import Distribution.Parsec (Parsec (..), Position (..), runParsecParser) +import Distribution.Parsec.FieldLineStream (fieldLineStreamFromBS) +import Distribution.Types.Condition +import Distribution.Types.ConfVar (ConfVar (..)) +import Distribution.Fields.Parser (readFields) +import Distribution.Version + (anyVersion, earlierVersion, intersectVersionRanges, laterVersion, majorBoundVersion, + mkVersion, noVersion, orEarlierVersion, orLaterVersion, thisVersion, unionVersionRanges, + withinVersion) +import Prelude () + +import qualified Text.Parsec as P +import qualified Text.Parsec.Pos as P +import qualified Text.Parsec.Error as P +import qualified Data.ByteString.Char8 as B8 + +parseConditionConfVarFromClause :: B8.ByteString -> Either P.ParseError (Condition ConfVar) +parseConditionConfVarFromClause x = readFields x >>= \r -> case r of + (Section _ xs _ : _ ) -> P.runParser (parser <* P.eof) () "" xs + _ -> Left $ P.newErrorMessage (P.Message "No fields in clause") (P.initialPos "") + +-- | Parse @'Condition' 'ConfVar'@ from section arguments provided by parsec +-- based outline parser. +parseConditionConfVar :: [SectionArg Position] -> ParseResult (Condition ConfVar) +parseConditionConfVar args = + -- The name of the input file is irrelevant, as we reformat the error message. + case P.runParser (parser <* P.eof) () "" args of + Right x -> pure x + Left err -> do + -- Mangle the position to the actual one + let ppos = P.errorPos err + let epos = Position (P.sourceLine ppos) (P.sourceColumn ppos) + let msg = P.showErrorMessages + "or" "unknown parse error" "expecting" "unexpected" "end of input" + (P.errorMessages err) + parseFailure epos msg + pure $ Lit True + +type Parser = P.Parsec [SectionArg Position] () + +sepByNonEmpty :: Parser a -> Parser sep -> Parser (NonEmpty a) +sepByNonEmpty p sep = (:|) <$> p <*> many (sep *> p) + +parser :: Parser (Condition ConfVar) +parser = condOr + where + condOr = sepByNonEmpty condAnd (oper "||") >>= return . foldl1 COr + condAnd = sepByNonEmpty cond (oper "&&") >>= return . foldl1 CAnd + cond = P.choice + [ boolLiteral, parens condOr, notCond, osCond, archCond, flagCond, implCond ] + + notCond = CNot <$ oper "!" <*> cond + + boolLiteral = Lit <$> boolLiteral' + osCond = Var . OS <$ string "os" <*> parens fromParsec + flagCond = Var . PackageFlag <$ string "flag" <*> parens fromParsec + archCond = Var . Arch <$ string "arch" <*> parens fromParsec + implCond = Var <$ string "impl" <*> parens implCond' + + implCond' = Impl + <$> fromParsec + <*> P.option anyVersion versionRange + + version = fromParsec + versionStar = mkVersion <$> fromParsec' versionStar' <* oper "*" + versionStar' = some (integral <* char '.') + + versionRange = expr + where + expr = foldl1 unionVersionRanges <$> sepByNonEmpty term (oper "||") + term = foldl1 intersectVersionRanges <$> sepByNonEmpty factor (oper "&&") + + factor = P.choice + $ parens expr + : parseAnyVersion + : parseNoVersion + : parseWildcardRange + : map parseRangeOp rangeOps + + parseAnyVersion = anyVersion <$ string "-any" + parseNoVersion = noVersion <$ string "-none" + + parseWildcardRange = P.try $ withinVersion <$ oper "==" <*> versionStar + + parseRangeOp (s,f) = P.try (f <$ oper s <*> version) + rangeOps = [ ("<", earlierVersion), + ("<=", orEarlierVersion), + (">", laterVersion), + (">=", orLaterVersion), + ("^>=", majorBoundVersion), + ("==", thisVersion) ] + + -- Number token can have many dots in it: SecArgNum (Position 65 15) "7.6.1" + identBS = tokenPrim $ \t -> case t of + SecArgName _ s -> Just s + _ -> Nothing + + boolLiteral' = tokenPrim $ \t -> case t of + SecArgName _ s + | s == "True" -> Just True + | s == "true" -> Just True + | s == "False" -> Just False + | s == "false" -> Just False + _ -> Nothing + + string s = tokenPrim $ \t -> case t of + SecArgName _ s' | s == s' -> Just () + _ -> Nothing + + oper o = tokenPrim $ \t -> case t of + SecArgOther _ o' | o == o' -> Just () + _ -> Nothing + + parens = P.between (oper "(") (oper ")") + + tokenPrim = P.tokenPrim prettySectionArg updatePosition + -- TODO: check where the errors are reported + updatePosition x _ _ = x + prettySectionArg = show + + fromParsec :: Parsec a => Parser a + fromParsec = fromParsec' parsec + + fromParsec' p = do + bs <- identBS + let fls = fieldLineStreamFromBS bs + either (fail . show) pure (runParsecParser p "" fls) diff --git a/cabal/Cabal-syntax/src/Distribution/Fields/Field.hs b/cabal/Cabal-syntax/src/Distribution/Fields/Field.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Fields/Field.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +-- | Cabal-like file AST types: 'Field', 'Section' etc +-- +-- These types are parametrized by an annotation. +module Distribution.Fields.Field ( + -- * Cabal file + Field (..), + fieldName, + fieldAnn, + fieldUniverse, + FieldLine (..), + fieldLineAnn, + fieldLineBS, + SectionArg (..), + sectionArgAnn, + -- * Name + FieldName, + Name (..), + mkName, + getName, + nameAnn, + -- * Conversions to String + sectionArgsToString, + fieldLinesToString, + ) where + +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as B +import qualified Data.Char as Char +import Distribution.Compat.Prelude +import Distribution.Pretty (showTokenStr) +import Distribution.Utils.Generic (fromUTF8BS) +import Prelude () + + +------------------------------------------------------------------------------- +-- Cabal file +------------------------------------------------------------------------------- + +-- | A Cabal-like file consists of a series of fields (@foo: bar@) and sections (@library ...@). +data Field ann + = Field !(Name ann) [FieldLine ann] + | Section !(Name ann) [SectionArg ann] [Field ann] + deriving (Eq, Show, Functor, Foldable, Traversable) + +-- | Section of field name +fieldName :: Field ann -> Name ann +fieldName (Field n _ ) = n +fieldName (Section n _ _) = n + +fieldAnn :: Field ann -> ann +fieldAnn = nameAnn . fieldName + +-- | All transitive descendants of 'Field', including itself. +-- +-- /Note:/ the resulting list is never empty. +-- +fieldUniverse :: Field ann -> [Field ann] +fieldUniverse f@(Section _ _ fs) = f : concatMap fieldUniverse fs +fieldUniverse f@(Field _ _) = [f] + +-- | A line of text representing the value of a field from a Cabal file. +-- A field may contain multiple lines. +-- +-- /Invariant:/ 'ByteString' has no newlines. +data FieldLine ann = FieldLine !ann !ByteString + deriving (Eq, Show, Functor, Foldable, Traversable) + +-- | @since 3.0.0.0 +fieldLineAnn :: FieldLine ann -> ann +fieldLineAnn (FieldLine ann _) = ann + +-- | @since 3.0.0.0 +fieldLineBS :: FieldLine ann -> ByteString +fieldLineBS (FieldLine _ bs) = bs + +-- | Section arguments, e.g. name of the library +data SectionArg ann + = SecArgName !ann !ByteString + -- ^ identifier, or something which looks like number. Also many dot numbers, i.e. "7.6.3" + | SecArgStr !ann !ByteString + -- ^ quoted string + | SecArgOther !ann !ByteString + -- ^ everything else, mm. operators (e.g. in if-section conditionals) + deriving (Eq, Show, Functor, Foldable, Traversable) + +-- | Extract annotation from 'SectionArg'. +sectionArgAnn :: SectionArg ann -> ann +sectionArgAnn (SecArgName ann _) = ann +sectionArgAnn (SecArgStr ann _) = ann +sectionArgAnn (SecArgOther ann _) = ann + +------------------------------------------------------------------------------- +-- Name +------------------------------------------------------------------------------- + +type FieldName = ByteString + +-- | A field name. +-- +-- /Invariant/: 'ByteString' is lower-case ASCII. +data Name ann = Name !ann !FieldName + deriving (Eq, Show, Functor, Foldable, Traversable) + +mkName :: ann -> FieldName -> Name ann +mkName ann bs = Name ann (B.map Char.toLower bs) + +getName :: Name ann -> FieldName +getName (Name _ bs) = bs + +nameAnn :: Name ann -> ann +nameAnn (Name ann _) = ann + +------------------------------------------------------------------------------- +-- To Strings +------------------------------------------------------------------------------- + +-- | +-- +-- @since 3.6.0.0 +sectionArgsToString :: [SectionArg ann] -> String +sectionArgsToString = unwords . map toStr where + toStr :: SectionArg ann -> String + toStr (SecArgName _ bs) = showTokenStr (fromUTF8BS bs) + toStr (SecArgStr _ bs) = showTokenStr (fromUTF8BS bs) + toStr (SecArgOther _ bs) = fromUTF8BS bs + +-- | Convert @['FieldLine']@ into String. +-- +-- /Note:/ this doesn't preserve indentation or empty lines, +-- as the annotations (e.g. positions) are ignored. +-- +-- @since 3.6.0.0 +fieldLinesToString :: [FieldLine ann] -> String +fieldLinesToString = + -- intercalate to avoid trailing newline. + intercalate "\n" . map toStr + where + toStr (FieldLine _ bs) = fromUTF8BS bs diff --git a/cabal/Cabal-syntax/src/Distribution/Fields/Lexer.hs b/cabal/Cabal-syntax/src/Distribution/Fields/Lexer.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Fields/Lexer.hs @@ -0,0 +1,496 @@ +{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} +{-# LANGUAGE CPP,MagicHash #-} +{-# LINE 1 "templates/Lexer.x" #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Fields.Lexer +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Lexer for the cabal files. +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +#ifdef CABAL_PARSEC_DEBUG +{-# LANGUAGE PatternGuards #-} +#endif +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +module Distribution.Fields.Lexer + (ltest, lexToken, Token(..), LToken(..) + ,bol_section, in_section, in_field_layout, in_field_braces + ,mkLexState) where + +-- [Note: bootstrapping parsec parser] +-- +-- We manually produce the `Lexer.hs` file from `boot/Lexer.x` (make lexer) +-- because bootstrapping cabal-install would be otherwise tricky. +-- Alex is (atm) tricky package to build, cabal-install has some magic +-- to move bundled generated files in place, so rather we don't depend +-- on it before we can build it ourselves. +-- Therefore there is one thing less to worry in bootstrap.sh, which is a win. +-- +-- See also https://github.com/haskell/cabal/issues/4633 +-- + +import Prelude () +import qualified Prelude as Prelude +import Distribution.Compat.Prelude + +import Distribution.Fields.LexerMonad +import Distribution.Parsec.Position (Position (..), incPos, retPos) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B.Char8 +import qualified Data.Word as Word + +#ifdef CABAL_PARSEC_DEBUG +import Debug.Trace +import qualified Data.Vector as V +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Encoding.Error as T +#endif + +#if __GLASGOW_HASKELL__ >= 603 +#include "ghcconfig.h" +#elif defined(__GLASGOW_HASKELL__) +#include "config.h" +#endif +#if __GLASGOW_HASKELL__ >= 503 +import Data.Array +#else +import Array +#endif +#if __GLASGOW_HASKELL__ >= 503 +import Data.Array.Base (unsafeAt) +import GHC.Exts +#else +import GlaExts +#endif +alex_tab_size :: Int +alex_tab_size = 8 +alex_base :: AlexAddr +alex_base = AlexA# + "\x12\xff\xff\xff\xf9\xff\xff\xff\xfb\xff\xff\xff\x01\x00\x00\x00\x2f\x00\x00\x00\x50\x00\x00\x00\xd0\x00\x00\x00\x48\xff\xff\xff\xdc\xff\xff\xff\x51\xff\xff\xff\x6d\xff\xff\xff\x6f\xff\xff\xff\x50\x01\x00\x00\x74\x01\x00\x00\x70\xff\xff\xff\x68\x00\x00\x00\x09\x00\x00\x00\x00\x00\x00\x00\x07\x00\x00\x00\xa3\x01\x00\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x00\x00\xd1\x01\x00\x00\xfb\x01\x00\x00\x7b\x02\x00\x00\xfb\x02\x00\x00\x00\x00\x00\x00\x7b\x03\x00\x00\x7d\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x6d\x00\x00\x00\x6b\x00\x00\x00\xfc\x03\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x6f\x00\x00\x00\x1c\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00"# + +alex_table :: AlexAddr +alex_table = AlexA# + "\x00\x00\x09\x00\x0f\x00\x11\x00\x02\x00\x11\x00\x12\x00\x00\x00\x12\x00\x13\x00\x03\x00\x11\x00\x07\x00\x10\x00\x12\x00\x25\x00\x14\x00\x11\x00\x10\x00\x11\x00\x14\x00\x11\x00\x12\x00\x23\x00\x12\x00\x0f\x00\x28\x00\x02\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x08\x00\x10\x00\x00\x00\x14\x00\x00\x00\x00\x00\x08\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2a\x00\x2e\x00\xff\xff\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x28\x00\xff\xff\xff\xff\x29\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x0f\x00\x11\x00\x17\x00\x26\x00\x12\x00\x25\x00\x11\x00\x2a\x00\x00\x00\x12\x00\x00\x00\x15\x00\x00\x00\x16\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0f\x00\x00\x00\x17\x00\x26\x00\x00\x00\x25\x00\x00\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x00\x00\x2d\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x0e\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x17\x00\x23\x00\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x17\x00\x1e\x00\x0d\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x1f\x00\x1f\x00\x1e\x00\x1e\x00\x1e\x00\x19\x00\x1a\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x1f\x00\x1e\x00\x1f\x00\x1e\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x21\x00\x1e\x00\x22\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x1d\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x1c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x0c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1e\x00\xff\xff\x1e\x00\x1e\x00\x1e\x00\x1e\x00\xff\xff\xff\xff\xff\xff\x1e\x00\x1e\x00\x1e\x00\x18\x00\x1a\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x1e\x00\xff\xff\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x1e\x00\xff\xff\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1e\x00\xff\xff\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\xff\xff\xff\xff\x1e\x00\x1e\x00\x1e\x00\x1a\x00\x1a\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x1e\x00\xff\xff\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x1e\x00\xff\xff\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x1c\x00\x1e\x00\x00\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x1e\x00\x00\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1e\x00\xff\xff\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +alex_check :: AlexAddr +alex_check = AlexA# + "\xff\xff\xef\x00\x09\x00\x0a\x00\x09\x00\x0a\x00\x0d\x00\xbf\x00\x0d\x00\x2d\x00\x09\x00\x0a\x00\xbb\x00\xa0\x00\x0d\x00\xa0\x00\xa0\x00\x0a\x00\x09\x00\x0a\x00\x09\x00\x0a\x00\x0d\x00\x0a\x00\x0d\x00\x20\x00\x0a\x00\x20\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x00\xff\xff\x2d\x00\x20\x00\xff\xff\x20\x00\xff\xff\xff\xff\x2d\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x09\x00\x0a\x00\x09\x00\x09\x00\x0d\x00\x09\x00\x0a\x00\x09\x00\xff\xff\x0d\x00\xff\xff\x7b\x00\xff\xff\x7d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\x20\x00\x20\x00\xff\xff\x20\x00\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\xff\xff\x7d\x00\xff\xff\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc2\x00\xff\xff\xc2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc2\x00\xff\xff\xc2\x00\xff\xff\x7f\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc2\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xc2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\xff\xff\xff\xff\x22\x00\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\xff\xff\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x5c\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7f\x00\x5c\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\xff\xff\xff\xff\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x7f\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\xff\xff\xff\xff\x22\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x7f\x00\x7e\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\xff\xff\x7d\x00\xff\xff\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +alex_deflt :: AlexAddr +alex_deflt = AlexA# + "\xff\xff\xff\xff\xff\xff\xff\xff\x2b\x00\x27\x00\x1b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0d\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x00\xff\xff\xff\xff\xff\xff\xff\xff\x18\x00\x1b\x00\x1b\x00\x1b\x00\xff\xff\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\x2b\x00\xff\xff\xff\xff\xff\xff\xff\xff"# + +alex_accept = listArray (0 :: Int, 47) + [ AlexAcc 29 + , AlexAcc 28 + , AlexAcc 27 + , AlexAcc 26 + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAcc 25 + , AlexAcc 24 + , AlexAccSkip + , AlexAcc 23 + , AlexAcc 22 + , AlexAcc 21 + , AlexAccSkip + , AlexAccSkip + , AlexAcc 20 + , AlexAcc 19 + , AlexAcc 18 + , AlexAcc 17 + , AlexAcc 16 + , AlexAcc 15 + , AlexAcc 14 + , AlexAcc 13 + , AlexAcc 12 + , AlexAcc 11 + , AlexAcc 10 + , AlexAcc 9 + , AlexAcc 8 + , AlexAccSkip + , AlexAcc 7 + , AlexAcc 6 + , AlexAcc 5 + , AlexAccSkip + , AlexAcc 4 + , AlexAcc 3 + , AlexAcc 2 + , AlexAcc 1 + , AlexAcc 0 + ] + +alex_actions = array (0 :: Int, 30) + [ (29,alex_action_0) + , (28,alex_action_20) + , (27,alex_action_16) + , (26,alex_action_3) + , (25,alex_action_1) + , (24,alex_action_1) + , (23,alex_action_3) + , (22,alex_action_4) + , (21,alex_action_5) + , (20,alex_action_8) + , (19,alex_action_8) + , (18,alex_action_8) + , (17,alex_action_9) + , (16,alex_action_9) + , (15,alex_action_10) + , (14,alex_action_11) + , (13,alex_action_12) + , (12,alex_action_13) + , (11,alex_action_14) + , (10,alex_action_15) + , (9,alex_action_15) + , (8,alex_action_16) + , (7,alex_action_18) + , (6,alex_action_19) + , (5,alex_action_19) + , (4,alex_action_22) + , (3,alex_action_23) + , (2,alex_action_24) + , (1,alex_action_25) + , (0,alex_action_25) + ] + +{-# LINE 151 "templates/Lexer.x" #-} + +-- | Tokens of outer cabal file structure. Field values are treated opaquely. +data Token = TokSym !ByteString -- ^ Haskell-like identifier, number or operator + | TokStr !ByteString -- ^ String in quotes + | TokOther !ByteString -- ^ Operators and parens + | Indent !Int -- ^ Indentation token + | TokFieldLine !ByteString -- ^ Lines after @:@ + | Colon + | OpenBrace + | CloseBrace + | EOF + | LexicalError InputStream --TODO: add separate string lexical error + deriving Show + +data LToken = L !Position !Token + deriving Show + +toki :: (ByteString -> Token) -> Position -> Int -> ByteString -> Lex LToken +toki t pos len input = return $! L pos (t (B.take len input)) + +tok :: Token -> Position -> Int -> ByteString -> Lex LToken +tok t pos _len _input = return $! L pos t + +checkLeadingWhitespace :: Int -> ByteString -> Lex Int +checkLeadingWhitespace len bs + | B.any (== 9) (B.take len bs) = do + addWarning LexWarningTab + checkWhitespace len bs + | otherwise = checkWhitespace len bs + +checkWhitespace :: Int -> ByteString -> Lex Int +checkWhitespace len bs + | B.any (== 194) (B.take len bs) = do + addWarning LexWarningNBSP + return $ len - B.count 194 (B.take len bs) + | otherwise = return len + +-- ----------------------------------------------------------------------------- +-- The input type + +type AlexInput = InputStream + +alexInputPrevChar :: AlexInput -> Char +alexInputPrevChar _ = error "alexInputPrevChar not used" + +alexGetByte :: AlexInput -> Maybe (Word.Word8,AlexInput) +alexGetByte = B.uncons + +lexicalError :: Position -> InputStream -> Lex LToken +lexicalError pos inp = do + setInput B.empty + return $! L pos (LexicalError inp) + +lexToken :: Lex LToken +lexToken = do + pos <- getPos + inp <- getInput + st <- getStartCode + case alexScan inp st of + AlexEOF -> return (L pos EOF) + AlexError inp' -> + let !len_bytes = B.length inp - B.length inp' in + --FIXME: we want len_chars here really + -- need to decode utf8 up to this point + lexicalError (incPos len_bytes pos) inp' + AlexSkip inp' len_chars -> do + checkPosition pos inp inp' len_chars + adjustPos (incPos len_chars) + setInput inp' + lexToken + AlexToken inp' len_chars action -> do + checkPosition pos inp inp' len_chars + adjustPos (incPos len_chars) + setInput inp' + let !len_bytes = B.length inp - B.length inp' + t <- action pos len_bytes inp + --traceShow t $ return tok + return t + +checkPosition :: Position -> ByteString -> ByteString -> Int -> Lex () +#ifdef CABAL_PARSEC_DEBUG +checkPosition pos@(Position lineno colno) inp inp' len_chars = do + text_lines <- getDbgText + let len_bytes = B.length inp - B.length inp' + pos_txt | lineno-1 < V.length text_lines = T.take len_chars (T.drop (colno-1) (text_lines V.! (lineno-1))) + | otherwise = T.empty + real_txt = B.take len_bytes inp + when (pos_txt /= T.decodeUtf8 real_txt) $ + traceShow (pos, pos_txt, T.decodeUtf8 real_txt) $ + traceShow (take 3 (V.toList text_lines)) $ return () + where + getDbgText = Lex $ \s@LexState{ dbgText = txt } -> LexResult s txt +#else +checkPosition _ _ _ _ = return () +#endif + +lexAll :: Lex [LToken] +lexAll = do + t <- lexToken + case t of + L _ EOF -> return [t] + _ -> do ts <- lexAll + return (t : ts) + +ltest :: Int -> String -> Prelude.IO () +ltest code s = + let (ws, xs) = execLexer (setStartCode code >> lexAll) (B.Char8.pack s) + in traverse_ print ws >> traverse_ print xs + +mkLexState :: ByteString -> LexState +mkLexState input = LexState + { curPos = Position 1 1 + , curInput = input + , curCode = 0 + , warnings = [] +#ifdef CABAL_PARSEC_DEBUG + , dbgText = V.fromList . lines' . T.decodeUtf8With T.lenientDecode $ input +#endif + } + +#ifdef CABAL_PARSEC_DEBUG +lines' :: T.Text -> [T.Text] +lines' s1 + | T.null s1 = [] + | otherwise = case T.break (\c -> c == '\r' || c == '\n') s1 of + (l, s2) | Just (c,s3) <- T.uncons s2 + -> case T.uncons s3 of + Just ('\n', s4) | c == '\r' -> l `T.snoc` '\r' `T.snoc` '\n' : lines' s4 + _ -> l `T.snoc` c : lines' s3 + + | otherwise + -> [l] +#endif + +bol_field_braces,bol_field_layout,bol_section,in_field_braces,in_field_layout,in_section :: Int +bol_field_braces = 1 +bol_field_layout = 2 +bol_section = 3 +in_field_braces = 4 +in_field_layout = 5 +in_section = 6 +alex_action_0 = \_ len _ -> do + when (len /= 0) $ addWarning LexWarningBOM + setStartCode bol_section + lexToken + +alex_action_1 = \_pos len inp -> checkWhitespace len inp >> adjustPos retPos >> lexToken +alex_action_3 = \pos len inp -> checkLeadingWhitespace len inp >> + if B.length inp == len + then return (L pos EOF) + else setStartCode in_section + >> return (L pos (Indent len)) +alex_action_4 = tok OpenBrace +alex_action_5 = tok CloseBrace +alex_action_8 = toki TokSym +alex_action_9 = \pos len inp -> return $! L pos (TokStr (B.take (len - 2) (B.tail inp))) +alex_action_10 = toki TokOther +alex_action_11 = toki TokOther +alex_action_12 = tok Colon +alex_action_13 = tok OpenBrace +alex_action_14 = tok CloseBrace +alex_action_15 = \_ _ _ -> adjustPos retPos >> setStartCode bol_section >> lexToken +alex_action_16 = \pos len inp -> checkLeadingWhitespace len inp >>= \len' -> + if B.length inp == len + then return (L pos EOF) + else setStartCode in_field_layout + >> return (L pos (Indent len')) +alex_action_18 = toki TokFieldLine +alex_action_19 = \_ _ _ -> adjustPos retPos >> setStartCode bol_field_layout >> lexToken +alex_action_20 = \_ _ _ -> setStartCode in_field_braces >> lexToken +alex_action_22 = toki TokFieldLine +alex_action_23 = tok OpenBrace +alex_action_24 = tok CloseBrace +alex_action_25 = \_ _ _ -> adjustPos retPos >> setStartCode bol_field_braces >> lexToken +{-# LINE 1 "templates/GenericTemplate.hs" #-} +-- ----------------------------------------------------------------------------- +-- ALEX TEMPLATE +-- +-- This code is in the PUBLIC DOMAIN; you may copy it freely and use +-- it for any purpose whatsoever. + +-- ----------------------------------------------------------------------------- +-- INTERNALS and main scanner engine + +-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. +#if __GLASGOW_HASKELL__ > 706 +#define GTE(n,m) (tagToEnum# (n >=# m)) +#define EQ(n,m) (tagToEnum# (n ==# m)) +#else +#define GTE(n,m) (n >=# m) +#define EQ(n,m) (n ==# m) +#endif + +data AlexAddr = AlexA# Addr# +-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. +#if __GLASGOW_HASKELL__ < 503 +uncheckedShiftL# = shiftL# +#endif + +{-# INLINE alexIndexInt16OffAddr #-} +alexIndexInt16OffAddr :: AlexAddr -> Int# -> Int# +alexIndexInt16OffAddr (AlexA# arr) off = +#ifdef WORDS_BIGENDIAN + narrow16Int# i + where + i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) + high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + low = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 2# +#else +#if __GLASGOW_HASKELL__ >= 901 + int16ToInt# +#endif + (indexInt16OffAddr# arr off) +#endif + +{-# INLINE alexIndexInt32OffAddr #-} +alexIndexInt32OffAddr :: AlexAddr -> Int# -> Int# +alexIndexInt32OffAddr (AlexA# arr) off = +#ifdef WORDS_BIGENDIAN + narrow32Int# i + where + i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#` + (b2 `uncheckedShiftL#` 16#) `or#` + (b1 `uncheckedShiftL#` 8#) `or#` b0) + b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#))) + b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#))) + b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + b0 = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 4# +#else +#if __GLASGOW_HASKELL__ >= 901 + int32ToInt# +#endif + (indexInt32OffAddr# arr off) +#endif + +#if __GLASGOW_HASKELL__ < 503 +quickIndex arr i = arr ! i +#else +-- GHC >= 503, unsafeAt is available from Data.Array.Base. +quickIndex = unsafeAt +#endif + +-- ----------------------------------------------------------------------------- +-- Main lexing routines + +data AlexReturn a + = AlexEOF + | AlexError !AlexInput + | AlexSkip !AlexInput !Int + | AlexToken !AlexInput !Int a + +-- alexScan :: AlexInput -> StartCode -> AlexReturn a +alexScan input__ (I# (sc)) + = alexScanUser undefined input__ (I# (sc)) + +alexScanUser user__ input__ (I# (sc)) + = case alex_scan_tkn user__ input__ 0# input__ sc AlexNone of + (AlexNone, input__') -> + case alexGetByte input__ of + Nothing -> + + AlexEOF + Just _ -> + + AlexError input__' + + (AlexLastSkip input__'' len, _) -> + + AlexSkip input__'' len + + (AlexLastAcc k input__''' len, _) -> + + AlexToken input__''' len (alex_actions ! k) + +-- Push the input through the DFA, remembering the most recent accepting +-- state it encountered. + +alex_scan_tkn user__ orig_input len input__ s last_acc = + input__ `seq` -- strict in the input + let + new_acc = (check_accs (alex_accept `quickIndex` (I# (s)))) + in + new_acc `seq` + case alexGetByte input__ of + Nothing -> (new_acc, input__) + Just (c, new_input) -> + + case fromIntegral c of { (I# (ord_c)) -> + let + base = alexIndexInt32OffAddr alex_base s + offset = (base +# ord_c) + check = alexIndexInt16OffAddr alex_check offset + + new_s = if GTE(offset,0#) && EQ(check,ord_c) + then alexIndexInt16OffAddr alex_table offset + else alexIndexInt16OffAddr alex_deflt s + in + case new_s of + -1# -> (new_acc, input__) + -- on an error, we want to keep the input *before* the + -- character that failed, not after. + _ -> alex_scan_tkn user__ orig_input (if c < 0x80 || c >= 0xC0 then (len +# 1#) else len) + -- note that the length is increased ONLY if this is the 1st byte in a char encoding) + new_input new_s new_acc + } + where + check_accs (AlexAccNone) = last_acc + check_accs (AlexAcc a ) = AlexLastAcc a input__ (I# (len)) + check_accs (AlexAccSkip) = AlexLastSkip input__ (I# (len)) + +data AlexLastAcc + = AlexNone + | AlexLastAcc !Int !AlexInput !Int + | AlexLastSkip !AlexInput !Int + +data AlexAcc user + = AlexAccNone + | AlexAcc Int + | AlexAccSkip + diff --git a/cabal/Cabal-syntax/src/Distribution/Fields/LexerMonad.hs b/cabal/Cabal-syntax/src/Distribution/Fields/LexerMonad.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Fields/LexerMonad.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Fields.LexerMonad +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +module Distribution.Fields.LexerMonad ( + InputStream, + LexState(..), + LexResult(..), + + Lex(..), + execLexer, + + getPos, + setPos, + adjustPos, + + getInput, + setInput, + + getStartCode, + setStartCode, + + LexWarning(..), + LexWarningType(..), + addWarning, + toPWarnings, + + ) where + +import qualified Data.ByteString as B +import qualified Data.List.NonEmpty as NE +import Distribution.Compat.Prelude +import Distribution.Parsec.Position (Position (..), showPos) +import Distribution.Parsec.Warning (PWarnType (..), PWarning (..)) +import Prelude () + +import qualified Data.Map.Strict as Map + +#ifdef CABAL_PARSEC_DEBUG +-- testing only: +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Vector as V +#endif + +-- simple state monad +newtype Lex a = Lex { unLex :: LexState -> LexResult a } + +instance Functor Lex where + fmap = liftM + +instance Applicative Lex where + pure = returnLex + (<*>) = ap + +instance Monad Lex where + return = pure + (>>=) = thenLex + +data LexResult a = LexResult {-# UNPACK #-} !LexState a + +data LexWarningType + = LexWarningNBSP -- ^ Encountered non breaking space + | LexWarningBOM -- ^ BOM at the start of the cabal file + | LexWarningTab -- ^ Leading tags + deriving (Eq, Ord, Show) + +data LexWarning = LexWarning !LexWarningType + {-# UNPACK #-} !Position + deriving (Show) + +toPWarnings :: [LexWarning] -> [PWarning] +toPWarnings + = map (uncurry toWarning) + . Map.toList + . Map.fromListWith (<>) + . map (\(LexWarning t p) -> (t, pure p)) + where + toWarning LexWarningBOM poss = + PWarning PWTLexBOM (NE.head poss) "Byte-order mark found at the beginning of the file" + toWarning LexWarningNBSP poss = + PWarning PWTLexNBSP (NE.head poss) $ "Non breaking spaces at " ++ intercalate ", " (NE.toList $ fmap showPos poss) + toWarning LexWarningTab poss = + PWarning PWTLexTab (NE.head poss) $ "Tabs used as indentation at " ++ intercalate ", " (NE.toList $ fmap showPos poss) + +data LexState = LexState { + curPos :: {-# UNPACK #-} !Position, -- ^ position at current input location + curInput :: {-# UNPACK #-} !InputStream, -- ^ the current input + curCode :: {-# UNPACK #-} !StartCode, -- ^ lexer code + warnings :: [LexWarning] +#ifdef CABAL_PARSEC_DEBUG + , dbgText :: V.Vector T.Text -- ^ input lines, to print pretty debug info +#endif + } --TODO: check if we should cache the first token + -- since it looks like parsec's uncons can be called many times on the same input + +type StartCode = Int -- ^ An @alex@ lexer start code +type InputStream = B.ByteString + + + +-- | Execute the given lexer on the supplied input stream. +execLexer :: Lex a -> InputStream -> ([LexWarning], a) +execLexer (Lex lexer) input = + case lexer initialState of + LexResult LexState{ warnings = ws } result -> (ws, result) + where + initialState = LexState + -- TODO: add 'startPosition' + { curPos = Position 1 1 + , curInput = input + , curCode = 0 + , warnings = [] +#ifdef CABAL_PARSEC_DEBUG + , dbgText = V.fromList . T.lines . T.decodeUtf8 $ input +#endif + } + +{-# INLINE returnLex #-} +returnLex :: a -> Lex a +returnLex a = Lex $ \s -> LexResult s a + +{-# INLINE thenLex #-} +thenLex :: Lex a -> (a -> Lex b) -> Lex b +(Lex m) `thenLex` k = Lex $ \s -> case m s of LexResult s' a -> (unLex (k a)) s' + +setPos :: Position -> Lex () +setPos pos = Lex $ \s -> LexResult s{ curPos = pos } () + +getPos :: Lex Position +getPos = Lex $ \s@LexState{ curPos = pos } -> LexResult s pos + +adjustPos :: (Position -> Position) -> Lex () +adjustPos f = Lex $ \s@LexState{ curPos = pos } -> LexResult s{ curPos = f pos } () + +getInput :: Lex InputStream +getInput = Lex $ \s@LexState{ curInput = i } -> LexResult s i + +setInput :: InputStream -> Lex () +setInput i = Lex $ \s -> LexResult s{ curInput = i } () + +getStartCode :: Lex Int +getStartCode = Lex $ \s@LexState{ curCode = c } -> LexResult s c + +setStartCode :: Int -> Lex () +setStartCode c = Lex $ \s -> LexResult s{ curCode = c } () + +-- | Add warning at the current position +addWarning :: LexWarningType -> Lex () +addWarning wt = Lex $ \s@LexState{ curPos = pos, warnings = ws } -> + LexResult s{ warnings = LexWarning wt pos : ws } () diff --git a/cabal/Cabal-syntax/src/Distribution/Fields/ParseResult.hs b/cabal/Cabal-syntax/src/Distribution/Fields/ParseResult.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Fields/ParseResult.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +-- | A parse result type for parsers from AST to Haskell types. +module Distribution.Fields.ParseResult ( + ParseResult, + runParseResult, + recoverWith, + parseWarning, + parseWarnings, + parseFailure, + parseFatalFailure, + parseFatalFailure', + getCabalSpecVersion, + setCabalSpecVersion, + withoutWarnings, + ) where + +import Distribution.Parsec.Error (PError (..)) +import Distribution.Parsec.Position (Position (..), zeroPos) +import Distribution.Parsec.Warning (PWarnType (..), PWarning (..)) +import Distribution.Version (Version) +import Prelude () + +-- liftA2 is not in base <4.10, hence we need to only import it explicitly when we're on >=4.10 +-- +-- Additionally, since liftA2 will be exported from Prelude starting with ~4.18, we should hide +-- it from Prelude and get it from Control.Applicative to be backwards compatible and avoid warnings +#if MIN_VERSION_base(4,10,0) +import Distribution.Compat.Prelude hiding (Applicative(..)) +import Control.Applicative (Applicative (..)) +#else +import Distribution.Compat.Prelude +#endif + +-- | A monad with failure and accumulating errors and warnings. +newtype ParseResult a = PR + { unPR + :: forall r. PRState + -> (PRState -> r) -- failure, but we were able to recover a new-style spec-version declaration + -> (PRState -> a -> r) -- success + -> r + } + +-- Note: we have version here, as we could get any version. +data PRState = PRState ![PWarning] ![PError] !(Maybe Version) + +emptyPRState :: PRState +emptyPRState = PRState [] [] Nothing + +-- | Forget 'ParseResult's warnings. +-- +-- @since 3.4.0.0 +withoutWarnings :: ParseResult a -> ParseResult a +withoutWarnings m = PR $ \s failure success -> + unPR m s failure $ \ !s1 -> success (s1 `withWarningsOf` s) + where + withWarningsOf (PRState _ e v) (PRState w _ _) = PRState w e v + +-- | Destruct a 'ParseResult' into the emitted warnings and either +-- a successful value or +-- list of errors and possibly recovered a spec-version declaration. +runParseResult :: ParseResult a -> ([PWarning], Either (Maybe Version, NonEmpty PError) a) +runParseResult pr = unPR pr emptyPRState failure success + where + failure (PRState warns [] v) = (warns, Left (v, PError zeroPos "panic" :| [])) + failure (PRState warns (err:errs) v) = (warns, Left (v, err :| errs)) where + success (PRState warns [] _) x = (warns, Right x) + -- If there are any errors, don't return the result + success (PRState warns (err:errs) v) _ = (warns, Left (v, err :| errs)) + +instance Functor ParseResult where + fmap f (PR pr) = PR $ \ !s failure success -> + pr s failure $ \ !s' a -> + success s' (f a) + {-# INLINE fmap #-} + +instance Applicative ParseResult where + pure x = PR $ \ !s _ success -> success s x + {-# INLINE pure #-} + + f <*> x = PR $ \ !s0 failure success -> + unPR f s0 failure $ \ !s1 f' -> + unPR x s1 failure $ \ !s2 x' -> + success s2 (f' x') + {-# INLINE (<*>) #-} + + x *> y = PR $ \ !s0 failure success -> + unPR x s0 failure $ \ !s1 _ -> + unPR y s1 failure success + {-# INLINE (*>) #-} + + x <* y = PR $ \ !s0 failure success -> + unPR x s0 failure $ \ !s1 x' -> + unPR y s1 failure $ \ !s2 _ -> + success s2 x' + {-# INLINE (<*) #-} + +#if MIN_VERSION_base(4,10,0) + liftA2 f x y = PR $ \ !s0 failure success -> + unPR x s0 failure $ \ !s1 x' -> + unPR y s1 failure $ \ !s2 y' -> + success s2 (f x' y') + {-# INLINE liftA2 #-} +#endif + +instance Monad ParseResult where + return = pure + (>>) = (*>) + + m >>= k = PR $ \ !s failure success -> + unPR m s failure $ \ !s' a -> + unPR (k a) s' failure success + {-# INLINE (>>=) #-} + +-- | "Recover" the parse result, so we can proceed parsing. +-- 'runParseResult' will still result in 'Nothing', if there are recorded errors. +recoverWith :: ParseResult a -> a -> ParseResult a +recoverWith (PR pr) x = PR $ \ !s _failure success -> + pr s (\ !s' -> success s' x) success + +-- | Set cabal spec version. +setCabalSpecVersion :: Maybe Version -> ParseResult () +setCabalSpecVersion v = PR $ \(PRState warns errs _) _failure success -> + success (PRState warns errs v) () + +-- | Get cabal spec version. +getCabalSpecVersion :: ParseResult (Maybe Version) +getCabalSpecVersion = PR $ \s@(PRState _ _ v) _failure success -> + success s v + +-- | Add a warning. This doesn't fail the parsing process. +parseWarning :: Position -> PWarnType -> String -> ParseResult () +parseWarning pos t msg = PR $ \(PRState warns errs v) _failure success -> + success (PRState (PWarning t pos msg : warns) errs v) () + +-- | Add multiple warnings at once. +parseWarnings :: [PWarning] -> ParseResult () +parseWarnings newWarns = PR $ \(PRState warns errs v) _failure success -> + success (PRState (newWarns ++ warns) errs v) () + +-- | Add an error, but not fail the parser yet. +-- +-- For fatal failure use 'parseFatalFailure' +parseFailure :: Position -> String -> ParseResult () +parseFailure pos msg = PR $ \(PRState warns errs v) _failure success -> + success (PRState warns (PError pos msg : errs) v) () + +-- | Add an fatal error. +parseFatalFailure :: Position -> String -> ParseResult a +parseFatalFailure pos msg = PR $ \(PRState warns errs v) failure _success -> + failure (PRState warns (PError pos msg : errs) v) + +-- | A 'mzero'. +parseFatalFailure' :: ParseResult a +parseFatalFailure' = PR pr + where + pr (PRState warns [] v) failure _success = failure (PRState warns [err] v) + pr s failure _success = failure s + + err = PError zeroPos "Unknown fatal error" diff --git a/cabal/Cabal-syntax/src/Distribution/Fields/Parser.hs b/cabal/Cabal-syntax/src/Distribution/Fields/Parser.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Fields/Parser.hs @@ -0,0 +1,377 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Fields.Parser +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +module Distribution.Fields.Parser ( + -- * Types + Field(..), + Name(..), + FieldLine(..), + SectionArg(..), + -- * Grammar and parsing + -- $grammar + readFields, + readFields', +#ifdef CABAL_PARSEC_DEBUG + -- * Internal + parseFile, + parseStr, + parseBS, +#endif + ) where + +import qualified Data.ByteString.Char8 as B8 +import Data.Functor.Identity +import Distribution.Compat.Prelude +import Distribution.Fields.Field +import Distribution.Fields.Lexer +import Distribution.Fields.LexerMonad + (LexResult (..), LexState (..), LexWarning (..), unLex) +import Distribution.Parsec.Position (Position (..)) +import Prelude () +import Text.Parsec.Combinator hiding (eof, notFollowedBy) +import Text.Parsec.Error +import Text.Parsec.Pos +import Text.Parsec.Prim hiding (many, (<|>)) + +#ifdef CABAL_PARSEC_DEBUG +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Encoding.Error as T +#endif + +-- | The 'LexState'' (with a prime) is an instance of parsec's 'Stream' +-- wrapped around lexer's 'LexState' (without a prime) +data LexState' = LexState' !LexState (LToken, LexState') + +mkLexState' :: LexState -> LexState' +mkLexState' st = LexState' st + (case unLex lexToken st of LexResult st' tok -> (tok, mkLexState' st')) + +type Parser a = ParsecT LexState' () Identity a + +instance Stream LexState' Identity LToken where + uncons (LexState' _ (tok, st')) = + case tok of + L _ EOF -> return Nothing + _ -> return (Just (tok, st')) + +-- | Get lexer warnings accumulated so far +getLexerWarnings :: Parser [LexWarning] +getLexerWarnings = do + LexState' (LexState { warnings = ws }) _ <- getInput + return ws + +-- | Set Alex code i.e. the mode "state" lexer is in. +setLexerMode :: Int -> Parser () +setLexerMode code = do + LexState' ls _ <- getInput + setInput $! mkLexState' ls { curCode = code } + +getToken :: (Token -> Maybe a) -> Parser a +getToken getTok = getTokenWithPos (\(L _ t) -> getTok t) + +getTokenWithPos :: (LToken -> Maybe a) -> Parser a +getTokenWithPos getTok = tokenPrim (\(L _ t) -> describeToken t) updatePos getTok + where + updatePos :: SourcePos -> LToken -> LexState' -> SourcePos + updatePos pos (L (Position col line) _) _ = newPos (sourceName pos) col line + +describeToken :: Token -> String +describeToken t = case t of + TokSym s -> "symbol " ++ show s + TokStr s -> "string " ++ show s + TokOther s -> "operator " ++ show s + Indent _ -> "new line" + TokFieldLine _ -> "field content" + Colon -> "\":\"" + OpenBrace -> "\"{\"" + CloseBrace -> "\"}\"" +-- SemiColon -> "\";\"" + EOF -> "end of file" + LexicalError is -> "character in input " ++ show (B8.head is) + +tokSym :: Parser (Name Position) +tokSym', tokStr, tokOther :: Parser (SectionArg Position) +tokIndent :: Parser Int +tokColon, tokOpenBrace, tokCloseBrace :: Parser () +tokFieldLine :: Parser (FieldLine Position) + +tokSym = getTokenWithPos $ \t -> case t of L pos (TokSym x) -> Just (mkName pos x); _ -> Nothing +tokSym' = getTokenWithPos $ \t -> case t of L pos (TokSym x) -> Just (SecArgName pos x); _ -> Nothing +tokStr = getTokenWithPos $ \t -> case t of L pos (TokStr x) -> Just (SecArgStr pos x); _ -> Nothing +tokOther = getTokenWithPos $ \t -> case t of L pos (TokOther x) -> Just (SecArgOther pos x); _ -> Nothing +tokIndent = getToken $ \t -> case t of Indent x -> Just x; _ -> Nothing +tokColon = getToken $ \t -> case t of Colon -> Just (); _ -> Nothing +tokOpenBrace = getToken $ \t -> case t of OpenBrace -> Just (); _ -> Nothing +tokCloseBrace = getToken $ \t -> case t of CloseBrace -> Just (); _ -> Nothing +tokFieldLine = getTokenWithPos $ \t -> case t of L pos (TokFieldLine s) -> Just (FieldLine pos s); _ -> Nothing + +colon, openBrace, closeBrace :: Parser () + +sectionArg :: Parser (SectionArg Position) +sectionArg = tokSym' <|> tokStr <|> tokOther "section parameter" + +fieldSecName :: Parser (Name Position) +fieldSecName = tokSym "field or section name" + +colon = tokColon "\":\"" +openBrace = tokOpenBrace "\"{\"" +closeBrace = tokCloseBrace "\"}\"" + +fieldContent :: Parser (FieldLine Position) +fieldContent = tokFieldLine "field contents" + +newtype IndentLevel = IndentLevel Int + +zeroIndentLevel :: IndentLevel +zeroIndentLevel = IndentLevel 0 + +incIndentLevel :: IndentLevel -> IndentLevel +incIndentLevel (IndentLevel i) = IndentLevel (succ i) + +indentOfAtLeast :: IndentLevel -> Parser IndentLevel +indentOfAtLeast (IndentLevel i) = try $ do + j <- tokIndent + guard (j >= i) "indentation of at least " ++ show i + return (IndentLevel j) + + +newtype LexerMode = LexerMode Int + +inLexerMode :: LexerMode -> Parser p -> Parser p +inLexerMode (LexerMode mode) p = + do setLexerMode mode; x <- p; setLexerMode in_section; return x + + +----------------------- +-- Cabal file grammar +-- + +-- $grammar +-- +-- @ +-- CabalStyleFile ::= SecElems +-- +-- SecElems ::= SecElem* '\\n'? +-- SecElem ::= '\\n' SecElemLayout | SecElemBraces +-- SecElemLayout ::= FieldLayout | FieldBraces | SectionLayout | SectionBraces +-- SecElemBraces ::= FieldInline | FieldBraces | SectionBraces +-- FieldLayout ::= name ':' line? ('\\n' line)* +-- FieldBraces ::= name ':' '\\n'? '{' content '}' +-- FieldInline ::= name ':' content +-- SectionLayout ::= name arg* SecElems +-- SectionBraces ::= name arg* '\\n'? '{' SecElems '}' +-- @ +-- +-- and the same thing but left factored... +-- +-- @ +-- SecElems ::= SecElem* +-- SecElem ::= '\\n' name SecElemLayout +-- | name SecElemBraces +-- SecElemLayout ::= ':' FieldLayoutOrBraces +-- | arg* SectionLayoutOrBraces +-- FieldLayoutOrBraces ::= '\\n'? '{' content '}' +-- | line? ('\\n' line)* +-- SectionLayoutOrBraces ::= '\\n'? '{' SecElems '\\n'? '}' +-- | SecElems +-- SecElemBraces ::= ':' FieldInlineOrBraces +-- | arg* '\\n'? '{' SecElems '\\n'? '}' +-- FieldInlineOrBraces ::= '\\n'? '{' content '}' +-- | content +-- @ +-- +-- Note how we have several productions with the sequence: +-- +-- > '\\n'? '{' +-- +-- That is, an optional newline (and indent) followed by a @{@ token. +-- In the @SectionLayoutOrBraces@ case you can see that this makes it +-- not fully left factored (because @SecElems@ can start with a @\\n@). +-- Fully left factoring here would be ugly, and though we could use a +-- lookahead of two tokens to resolve the alternatives, we can't +-- conveniently use Parsec's 'try' here to get a lookahead of only two. +-- So instead we deal with this case in the lexer by making a line +-- where the first non-space is @{@ lex as just the @{@ token, without +-- the usual indent token. Then in the parser we can resolve everything +-- with just one token of lookahead and so without using 'try'. + +-- Top level of a file using cabal syntax +-- +cabalStyleFile :: Parser [Field Position] +cabalStyleFile = do es <- elements zeroIndentLevel + eof + return es + +-- Elements that live at the top level or inside a section, i.e. fields +-- and sections content +-- +-- elements ::= element* +elements :: IndentLevel -> Parser [Field Position] +elements ilevel = many (element ilevel) + +-- An individual element, ie a field or a section. These can either use +-- layout style or braces style. For layout style then it must start on +-- a line on its own (so that we know its indentation level). +-- +-- element ::= '\\n' name elementInLayoutContext +-- | name elementInNonLayoutContext +element :: IndentLevel -> Parser (Field Position) +element ilevel = + (do ilevel' <- indentOfAtLeast ilevel + name <- fieldSecName + elementInLayoutContext (incIndentLevel ilevel') name) + <|> (do name <- fieldSecName + elementInNonLayoutContext name) + +-- An element (field or section) that is valid in a layout context. +-- In a layout context we can have fields and sections that themselves +-- either use layout style or that use braces style. +-- +-- elementInLayoutContext ::= ':' fieldLayoutOrBraces +-- | arg* sectionLayoutOrBraces +elementInLayoutContext :: IndentLevel -> Name Position -> Parser (Field Position) +elementInLayoutContext ilevel name = + (do colon; fieldLayoutOrBraces ilevel name) + <|> (do args <- many sectionArg + elems <- sectionLayoutOrBraces ilevel + return (Section name args elems)) + +-- An element (field or section) that is valid in a non-layout context. +-- In a non-layout context we can have only have fields and sections that +-- themselves use braces style, or inline style fields. +-- +-- elementInNonLayoutContext ::= ':' FieldInlineOrBraces +-- | arg* '\\n'? '{' elements '\\n'? '}' +elementInNonLayoutContext :: Name Position -> Parser (Field Position) +elementInNonLayoutContext name = + (do colon; fieldInlineOrBraces name) + <|> (do args <- many sectionArg + openBrace + elems <- elements zeroIndentLevel + optional tokIndent + closeBrace + return (Section name args elems)) + +-- The body of a field, using either layout style or braces style. +-- +-- fieldLayoutOrBraces ::= '\\n'? '{' content '}' +-- | line? ('\\n' line)* +fieldLayoutOrBraces :: IndentLevel -> Name Position -> Parser (Field Position) +fieldLayoutOrBraces ilevel name = braces <|> fieldLayout + where + braces = do + openBrace + ls <- inLexerMode (LexerMode in_field_braces) (many fieldContent) + closeBrace + return (Field name ls) + fieldLayout = inLexerMode (LexerMode in_field_layout) $ do + l <- optionMaybe fieldContent + ls <- many (do _ <- indentOfAtLeast ilevel; fieldContent) + return $ case l of + Nothing -> Field name ls + Just l' -> Field name (l' : ls) + +-- The body of a section, using either layout style or braces style. +-- +-- sectionLayoutOrBraces ::= '\\n'? '{' elements \\n? '}' +-- | elements +sectionLayoutOrBraces :: IndentLevel -> Parser [Field Position] +sectionLayoutOrBraces ilevel = + (do openBrace + elems <- elements zeroIndentLevel + optional tokIndent + closeBrace + return elems) + <|> (elements ilevel) + +-- The body of a field, using either inline style or braces. +-- +-- fieldInlineOrBraces ::= '\\n'? '{' content '}' +-- | content +fieldInlineOrBraces :: Name Position -> Parser (Field Position) +fieldInlineOrBraces name = + (do openBrace + ls <- inLexerMode (LexerMode in_field_braces) (many fieldContent) + closeBrace + return (Field name ls)) + <|> (do ls <- inLexerMode (LexerMode in_field_braces) (option [] (fmap (\l -> [l]) fieldContent)) + return (Field name ls)) + + +-- | Parse cabal style 'B8.ByteString' into list of 'Field's, i.e. the cabal AST. +readFields :: B8.ByteString -> Either ParseError [Field Position] +readFields s = fmap fst (readFields' s) + +-- | Like 'readFields' but also return lexer warnings +readFields' :: B8.ByteString -> Either ParseError ([Field Position], [LexWarning]) +readFields' s = do + parse parser "the input" lexSt + where + parser = do + fields <- cabalStyleFile + ws <- getLexerWarnings + pure (fields, ws) + + lexSt = mkLexState' (mkLexState s) + +#ifdef CABAL_PARSEC_DEBUG +parseTest' :: Show a => Parsec LexState' () a -> SourceName -> B8.ByteString -> IO () +parseTest' p fname s = + case parse p fname (lexSt s) of + Left err -> putStrLn (formatError s err) + + Right x -> print x + where + lexSt = mkLexState' . mkLexState + +parseFile :: Show a => Parser a -> FilePath -> IO () +parseFile p f = B8.readFile f >>= \s -> parseTest' p f s + +parseStr :: Show a => Parser a -> String -> IO () +parseStr p = parseBS p . B8.pack + +parseBS :: Show a => Parser a -> B8.ByteString -> IO () +parseBS p = parseTest' p "" + +formatError :: B8.ByteString -> ParseError -> String +formatError input perr = + unlines + [ "Parse error "++ show (errorPos perr) ++ ":" + , errLine + , indicator ++ errmsg ] + where + pos = errorPos perr + ls = lines' (T.decodeUtf8With T.lenientDecode input) + errLine = T.unpack (ls !! (sourceLine pos - 1)) + indicator = replicate (sourceColumn pos) ' ' ++ "^" + errmsg = showErrorMessages "or" "unknown parse error" + "expecting" "unexpected" "end of file" + (errorMessages perr) + +-- | Handles windows/osx/unix line breaks uniformly +lines' :: T.Text -> [T.Text] +lines' s1 + | T.null s1 = [] + | otherwise = case T.break (\c -> c == '\r' || c == '\n') s1 of + (l, s2) | Just (c,s3) <- T.uncons s2 + -> case T.uncons s3 of + Just ('\n', s4) | c == '\r' -> l : lines' s4 + _ -> l : lines' s3 + | otherwise -> [l] +#endif + +eof :: Parser () +eof = notFollowedBy anyToken "end of file" + where + notFollowedBy :: Parser LToken -> Parser () + notFollowedBy p = try ( (do L _ t <- try p; unexpected (describeToken t)) + <|> return ()) diff --git a/cabal/Cabal-syntax/src/Distribution/Fields/Pretty.hs b/cabal/Cabal-syntax/src/Distribution/Fields/Pretty.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Fields/Pretty.hs @@ -0,0 +1,206 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE LambdaCase #-} +-- | Cabal-like file AST types: 'Field', 'Section' etc, +-- +-- This (intermediate) data type is used for pretty-printing. +-- +-- @since 3.0.0.0 +-- +module Distribution.Fields.Pretty ( + -- * Fields + CommentPosition (..), + PrettyField (..), + showFields, + showFields', + -- * Transformation from 'P.Field' + fromParsecFields, + genericFromParsecFields, + prettyFieldLines, + prettySectionArgs, + ) where + +import Distribution.Compat.Prelude +import Distribution.Pretty (showToken) +import Prelude () + +import Distribution.Fields.Field (FieldName) +import Distribution.Utils.Generic (fromUTF8BS) + +import qualified Distribution.Fields.Parser as P + +import qualified Data.ByteString as BS +import qualified Text.PrettyPrint as PP + +-- | This type is used to discern when a comment block should go +-- before or after a cabal-like file field, otherwise it would +-- be hardcoded to a single position. It is often used in +-- conjunction with @PrettyField@. +data CommentPosition = CommentBefore [String] | CommentAfter [String] | NoComment + +data PrettyField ann + = PrettyField ann FieldName PP.Doc + | PrettySection ann FieldName [PP.Doc] [PrettyField ann] + | PrettyEmpty + deriving (Functor, Foldable, Traversable) + +-- | Prettyprint a list of fields. +-- +-- Note: the first argument should return 'String's without newlines +-- and properly prefixes (with @--@) to count as comments. +-- This unsafety is left in place so one could generate empty lines +-- between comment lines. +-- +showFields :: (ann -> CommentPosition) -> [PrettyField ann] -> String +showFields rann = showFields' rann (const id) 4 + +-- | 'showFields' with user specified indentation. +showFields' + :: (ann -> CommentPosition) + -- ^ Convert an annotation to lined to preceed the field or section. + -> (ann -> [String] -> [String]) + -- ^ Post-process non-annotation produced lines. + -> Int + -- ^ Indentation level. + -> [PrettyField ann] + -- ^ Fields/sections to show. + -> String +showFields' rann post n = unlines . renderFields (Opts rann indent post) + where + -- few hardcoded, "unrolled" variants. + indent | n == 4 = indent4 + | n == 2 = indent2 + | otherwise = (replicate (max n 1) ' ' ++) + + indent4 :: String -> String + indent4 [] = [] + indent4 xs = ' ' : ' ' : ' ' : ' ' : xs + + indent2 :: String -> String + indent2 [] = [] + indent2 xs = ' ' : ' ' : xs + +data Opts ann = Opts + { _optAnnotation :: ann -> CommentPosition + , _optIndent :: String -> String + , _optPostprocess :: ann -> [String] -> [String] + } + +renderFields :: Opts ann -> [PrettyField ann] -> [String] +renderFields opts fields = flattenBlocks blocks + where + len = maxNameLength 0 fields + blocks = filter (not . null . _contentsBlock) -- empty blocks cause extra newlines #8236 + $ map (renderField opts len) fields + + maxNameLength !acc [] = acc + maxNameLength !acc (PrettyField _ name _ : rest) = maxNameLength (max acc (BS.length name)) rest + maxNameLength !acc (PrettySection {} : rest) = maxNameLength acc rest + maxNameLength !acc (PrettyEmpty : rest) = maxNameLength acc rest + +-- | Block of lines with flags for optional blank lines before and after +data Block = Block + { _beforeBlock :: Margin + , _afterBlock :: Margin + , _contentsBlock :: [String] + } + +data Margin = Margin | NoMargin + deriving Eq + +-- | Collapse margins, any margin = margin +instance Semigroup Margin where + NoMargin <> NoMargin = NoMargin + _ <> _ = Margin + +flattenBlocks :: [Block] -> [String] +flattenBlocks = go0 where + go0 [] = [] + go0 (Block _before after strs : blocks) = strs ++ go after blocks + + go _surr' [] = [] + go surr' (Block before after strs : blocks) = ins $ strs ++ go after blocks where + ins | surr' <> before == Margin = ("" :) + | otherwise = id + +renderField :: Opts ann -> Int -> PrettyField ann -> Block +renderField (Opts rann indent post) fw (PrettyField ann name doc) = + Block before after content + where + content = case comments of + CommentBefore cs -> cs ++ post ann lines' + CommentAfter cs -> post ann lines' ++ cs + NoComment -> post ann lines' + comments = rann ann + before = case comments of + CommentBefore [] -> NoMargin + CommentAfter [] -> NoMargin + NoComment -> NoMargin + _ -> Margin + + (lines', after) = case lines narrow of + [] -> ([ name' ++ ":" ], NoMargin) + [singleLine] | length singleLine < 60 + -> ([ name' ++ ": " ++ replicate (fw - length name') ' ' ++ narrow ], NoMargin) + _ -> ((name' ++ ":") : map indent (lines (PP.render doc)), Margin) + + name' = fromUTF8BS name + narrow = PP.renderStyle narrowStyle doc + + narrowStyle :: PP.Style + narrowStyle = PP.style { PP.lineLength = PP.lineLength PP.style - fw } + +renderField opts@(Opts rann indent post) _ (PrettySection ann name args fields) = Block Margin Margin $ + + attachComments + (post ann [ PP.render $ PP.hsep $ PP.text (fromUTF8BS name) : args ]) + ++ + map indent (renderFields opts fields) + where + attachComments content = case rann ann of + CommentBefore cs -> cs ++ content + CommentAfter cs -> content ++ cs + NoComment -> content + +renderField _ _ PrettyEmpty = Block NoMargin NoMargin mempty + +------------------------------------------------------------------------------- +-- Transform from Parsec.Field +------------------------------------------------------------------------------- + +genericFromParsecFields + :: Applicative f + => (FieldName -> [P.FieldLine ann] -> f PP.Doc) -- ^ transform field contents + -> (FieldName -> [P.SectionArg ann] -> f [PP.Doc]) -- ^ transform section arguments + -> [P.Field ann] + -> f [PrettyField ann] +genericFromParsecFields f g = goMany where + goMany = traverse go + + go (P.Field (P.Name ann name) fls) = PrettyField ann name <$> f name fls + go (P.Section (P.Name ann name) secargs fs) = PrettySection ann name <$> g name secargs <*> goMany fs + +-- | Used in 'fromParsecFields'. +prettyFieldLines :: FieldName -> [P.FieldLine ann] -> PP.Doc +prettyFieldLines _ fls = PP.vcat + [ PP.text $ fromUTF8BS bs + | P.FieldLine _ bs <- fls + ] + +-- | Used in 'fromParsecFields'. +prettySectionArgs :: FieldName -> [P.SectionArg ann] -> [PP.Doc] +prettySectionArgs _ = map $ \case + P.SecArgName _ bs -> showToken $ fromUTF8BS bs + P.SecArgStr _ bs -> showToken $ fromUTF8BS bs + P.SecArgOther _ bs -> PP.text $ fromUTF8BS bs + +-- | Simple variant of 'genericFromParsecField' +fromParsecFields :: [P.Field ann] -> [PrettyField ann] +fromParsecFields = runIdentity . genericFromParsecFields + (Identity .: prettyFieldLines) + (Identity .: prettySectionArgs) + where + (.:) :: (a -> b) -> (c -> d -> a) -> (c -> d -> b) + (f .: g) x y = f (g x y) diff --git a/cabal/Cabal-syntax/src/Distribution/InstalledPackageInfo.hs b/cabal/Cabal-syntax/src/Distribution/InstalledPackageInfo.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/InstalledPackageInfo.hs @@ -0,0 +1,146 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.InstalledPackageInfo +-- Copyright : (c) The University of Glasgow 2004 +-- +-- Maintainer : libraries@haskell.org +-- Portability : portable +-- +-- This is the information about an /installed/ package that +-- is communicated to the @ghc-pkg@ program in order to register +-- a package. @ghc-pkg@ now consumes this package format (as of version +-- 6.4). This is specific to GHC at the moment. +-- +-- The @.cabal@ file format is for describing a package that is not yet +-- installed. It has a lot of flexibility, like conditionals and dependency +-- ranges. As such, that format is not at all suitable for describing a package +-- that has already been built and installed. By the time we get to that stage, +-- we have resolved all conditionals and resolved dependency version +-- constraints to exact versions of dependent packages. So, this module defines +-- the 'InstalledPackageInfo' data structure that contains all the info we keep +-- about an installed package. There is a parser and pretty printer. The +-- textual format is rather simpler than the @.cabal@ format: there are no +-- sections, for example. + +-- This module is meant to be local-only to Distribution... + +module Distribution.InstalledPackageInfo ( + InstalledPackageInfo(..), + installedComponentId, + installedOpenUnitId, + sourceComponentName, + requiredSignatures, + ExposedModule(..), + AbiDependency(..), + emptyInstalledPackageInfo, + parseInstalledPackageInfo, + showInstalledPackageInfo, + showFullInstalledPackageInfo, + showInstalledPackageInfoField, + showSimpleInstalledPackageInfoField, + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Backpack +import Distribution.CabalSpecVersion (cabalSpecLatest) +import Distribution.FieldGrammar +import Distribution.FieldGrammar.FieldDescrs +import Distribution.Fields.Pretty +import Distribution.ModuleName +import Distribution.Package hiding (installedUnitId) +import Distribution.Types.ComponentName +import Distribution.Utils.Generic (toUTF8BS) + +import Data.ByteString (ByteString) + +import qualified Data.Map as Map +import qualified Distribution.Fields as P +import qualified Text.PrettyPrint as Disp + +import Distribution.Types.InstalledPackageInfo +import Distribution.Types.InstalledPackageInfo.FieldGrammar + +-- $setup +-- >>> :set -XOverloadedStrings + +installedComponentId :: InstalledPackageInfo -> ComponentId +installedComponentId ipi = + case unComponentId (installedComponentId_ ipi) of + "" -> mkComponentId (unUnitId (installedUnitId ipi)) + _ -> installedComponentId_ ipi + +-- | Get the indefinite unit identity representing this package. +-- This IS NOT guaranteed to give you a substitution; for +-- instantiated packages you will get @DefiniteUnitId (installedUnitId ipi)@. +-- For indefinite libraries, however, you will correctly get +-- an @OpenUnitId@ with the appropriate 'OpenModuleSubst'. +installedOpenUnitId :: InstalledPackageInfo -> OpenUnitId +installedOpenUnitId ipi + = mkOpenUnitId (installedUnitId ipi) (installedComponentId ipi) (Map.fromList (instantiatedWith ipi)) + +-- | Returns the set of module names which need to be filled for +-- an indefinite package, or the empty set if the package is definite. +requiredSignatures :: InstalledPackageInfo -> Set ModuleName +requiredSignatures ipi = openModuleSubstFreeHoles (Map.fromList (instantiatedWith ipi)) + +-- ----------------------------------------------------------------------------- +-- Munging + +sourceComponentName :: InstalledPackageInfo -> ComponentName +sourceComponentName = CLibName . sourceLibName + +-- ----------------------------------------------------------------------------- +-- Parsing + +-- | Return either errors, or IPI with list of warnings +parseInstalledPackageInfo + :: ByteString + -> Either (NonEmpty String) ([String], InstalledPackageInfo) +parseInstalledPackageInfo s = case P.readFields s of + Left err -> Left (show err :| []) + Right fs -> case partitionFields fs of + (fs', _) -> case P.runParseResult $ parseFieldGrammar cabalSpecLatest fs' ipiFieldGrammar of + (ws, Right x) -> x `deepseq` Right (ws', x) where + ws' = [ P.showPWarning "" w + | w@(P.PWarning wt _ _) <- ws + -- filter out warnings about experimental features + , wt /= P.PWTExperimental + ] + (_, Left (_, errs)) -> Left errs' where + errs' = fmap (P.showPError "") errs + +-- ----------------------------------------------------------------------------- +-- Pretty-printing + +-- | Pretty print 'InstalledPackageInfo'. +-- +-- @pkgRoot@ isn't printed, as ghc-pkg prints it manually (as GHC-8.4). +showInstalledPackageInfo :: InstalledPackageInfo -> String +showInstalledPackageInfo ipi = + showFullInstalledPackageInfo ipi { pkgRoot = Nothing } + +-- | The variant of 'showInstalledPackageInfo' which outputs @pkgroot@ field too. +showFullInstalledPackageInfo :: InstalledPackageInfo -> String +showFullInstalledPackageInfo = P.showFields (const NoComment) . prettyFieldGrammar cabalSpecLatest ipiFieldGrammar + +-- | +-- +-- >>> let ipi = emptyInstalledPackageInfo { maintainer = "Tester" } +-- >>> fmap ($ ipi) $ showInstalledPackageInfoField "maintainer" +-- Just "maintainer: Tester" +showInstalledPackageInfoField :: String -> Maybe (InstalledPackageInfo -> String) +showInstalledPackageInfoField fn = + fmap (\g -> Disp.render . ppField fn . g) $ fieldDescrPretty ipiFieldGrammar (toUTF8BS fn) + +showSimpleInstalledPackageInfoField :: String -> Maybe (InstalledPackageInfo -> String) +showSimpleInstalledPackageInfoField fn = + fmap (Disp.renderStyle myStyle .) $ fieldDescrPretty ipiFieldGrammar (toUTF8BS fn) + where + myStyle = Disp.style { Disp.mode = Disp.LeftMode } + +ppField :: String -> Disp.Doc -> Disp.Doc +ppField name fielddoc + | Disp.isEmpty fielddoc = mempty + | otherwise = Disp.text name <<>> Disp.colon Disp.<+> fielddoc diff --git a/cabal/Cabal-syntax/src/Distribution/License.hs b/cabal/Cabal-syntax/src/Distribution/License.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/License.hs @@ -0,0 +1,252 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.License +-- Description : The License data type. +-- Copyright : Isaac Jones 2003-2005 +-- Duncan Coutts 2008 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Package descriptions contain fields for specifying the name of a software +-- license and the name of the file containing the text of that license. While +-- package authors may choose any license they like, Cabal provides an +-- enumeration of a small set of common free and open source software licenses. +-- This is done so that Hackage can recognise licenses, so that tools can detect +-- , +-- and to deter +-- . +-- +-- It is recommended that all package authors use the @license-file@ or +-- @license-files@ fields in their package descriptions. Further information +-- about these fields can be found in the +-- . +-- +-- = Additional resources +-- +-- The following websites provide information about free and open source +-- software licenses: +-- +-- * +-- +-- * +-- +-- = Disclaimer +-- +-- The descriptions of software licenses provided by this documentation are +-- intended for informational purposes only and in no way constitute legal +-- advice. Please read the text of the licenses and consult a lawyer for any +-- advice regarding software licensing. + +module Distribution.License ( + License(..), + knownLicenses, + licenseToSPDX, + licenseFromSPDX, + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Parsec +import Distribution.Pretty +import Distribution.Version + +import qualified Distribution.Compat.CharParsing as P +import qualified Data.Map.Strict as Map +import qualified Distribution.SPDX as SPDX +import qualified Text.PrettyPrint as Disp + +-- | Indicates the license under which a package's source code is released. +-- Versions of the licenses not listed here will be rejected by Hackage and +-- cause @cabal check@ to issue a warning. +data License = + -- TODO: * remove BSD4 + + -- | GNU General Public License, + -- or + -- . + GPL (Maybe Version) + + -- | . + | AGPL (Maybe Version) + + -- | GNU Lesser General Public License, + -- or + -- . + | LGPL (Maybe Version) + + -- | . + | BSD2 + + -- | . + | BSD3 + + -- | . + -- This license has not been approved by the OSI and is incompatible with + -- the GNU GPL. It is provided for historical reasons and should be avoided. + | BSD4 + + -- | . + | MIT + + -- | + | ISC + + -- | . + | MPL Version + + -- | . + | Apache (Maybe Version) + + -- | The author of a package disclaims any copyright to its source code and + -- dedicates it to the public domain. This is not a software license. Please + -- note that it is not possible to dedicate works to the public domain in + -- every jurisdiction, nor is a work that is in the public domain in one + -- jurisdiction necessarily in the public domain elsewhere. + | PublicDomain + + -- | Explicitly 'All Rights Reserved', eg for proprietary software. The + -- package may not be legally modified or redistributed by anyone but the + -- rightsholder. + | AllRightsReserved + + -- | No license specified which legally defaults to 'All Rights Reserved'. + -- The package may not be legally modified or redistributed by anyone but + -- the rightsholder. + | UnspecifiedLicense + + -- | Any other software license. + | OtherLicense + + -- | Indicates an erroneous license name. + | UnknownLicense String + deriving (Generic, Read, Show, Eq, Typeable, Data) + +instance Binary License +instance Structured License +instance NFData License where rnf = genericRnf + +-- | The list of all currently recognised licenses. +knownLicenses :: [License] +knownLicenses = [ GPL unversioned, GPL (version [2]), GPL (version [3]) + , LGPL unversioned, LGPL (version [2, 1]), LGPL (version [3]) + , AGPL unversioned, AGPL (version [3]) + , BSD2, BSD3, MIT, ISC + , MPL (mkVersion [2, 0]) + , Apache unversioned, Apache (version [2, 0]) + , PublicDomain, AllRightsReserved, OtherLicense] + where + unversioned = Nothing + version = Just . mkVersion + +-- | Convert old 'License' to SPDX 'SPDX.License'. +-- Non-SPDX licenses are converted to 'SPDX.LicenseRef'. +-- +-- @since 2.2.0.0 +licenseToSPDX :: License -> SPDX.License +licenseToSPDX l = case l of + GPL v | v == version [2] -> spdx SPDX.GPL_2_0_only + GPL v | v == version [3] -> spdx SPDX.GPL_3_0_only + LGPL v | v == version [2,1] -> spdx SPDX.LGPL_2_1_only + LGPL v | v == version [3] -> spdx SPDX.LGPL_3_0_only + AGPL v | v == version [3] -> spdx SPDX.AGPL_3_0_only + BSD2 -> spdx SPDX.BSD_2_Clause + BSD3 -> spdx SPDX.BSD_3_Clause + BSD4 -> spdx SPDX.BSD_4_Clause + MIT -> spdx SPDX.MIT + ISC -> spdx SPDX.ISC + MPL v | v == mkVersion [2,0] -> spdx SPDX.MPL_2_0 + Apache v | v == version [2,0] -> spdx SPDX.Apache_2_0 + AllRightsReserved -> SPDX.NONE + UnspecifiedLicense -> SPDX.NONE + OtherLicense -> ref (SPDX.mkLicenseRef' Nothing "OtherLicense") + PublicDomain -> ref (SPDX.mkLicenseRef' Nothing "PublicDomain") + UnknownLicense str -> ref (SPDX.mkLicenseRef' Nothing str) + _ -> ref (SPDX.mkLicenseRef' Nothing $ prettyShow l) + where + version = Just . mkVersion + spdx = SPDX.License . SPDX.simpleLicenseExpression + ref r = SPDX.License $ SPDX.ELicense (SPDX.ELicenseRef r) Nothing + +-- | Convert 'SPDX.License' to 'License', +-- +-- This is lossy conversion. We try our best. +-- +-- >>> licenseFromSPDX . licenseToSPDX $ BSD3 +-- BSD3 +-- +-- >>> licenseFromSPDX . licenseToSPDX $ GPL (Just (mkVersion [3])) +-- GPL (Just (mkVersion [3])) +-- +-- >>> licenseFromSPDX . licenseToSPDX $ PublicDomain +-- UnknownLicense "LicenseRefPublicDomain" +-- +-- >>> licenseFromSPDX $ SPDX.License $ SPDX.simpleLicenseExpression SPDX.EUPL_1_1 +-- UnknownLicense "EUPL-1.1" +-- +-- >>> licenseFromSPDX . licenseToSPDX $ AllRightsReserved +-- AllRightsReserved +-- +-- >>> licenseFromSPDX <$> simpleParsec "BSD-3-Clause OR GPL-3.0-only" +-- Just (UnknownLicense "BSD3ClauseORGPL30only") +-- +-- @since 2.2.0.0 +licenseFromSPDX :: SPDX.License -> License +licenseFromSPDX SPDX.NONE = AllRightsReserved +licenseFromSPDX l = + fromMaybe (mungle $ prettyShow l) $ Map.lookup l m + where + m :: Map.Map SPDX.License License + m = Map.fromList $ filter (isSimple . fst ) $ + map (\x -> (licenseToSPDX x, x)) knownLicenses + + isSimple (SPDX.License (SPDX.ELicense (SPDX.ELicenseId _) Nothing)) = True + isSimple _ = False + + mungle name = fromMaybe (UnknownLicense (mapMaybe mangle name)) (simpleParsec name) + + mangle c + | isAlphaNum c = Just c + | otherwise = Nothing + +instance Pretty License where + pretty (GPL version) = Disp.text "GPL" <<>> dispOptVersion version + pretty (LGPL version) = Disp.text "LGPL" <<>> dispOptVersion version + pretty (AGPL version) = Disp.text "AGPL" <<>> dispOptVersion version + pretty (MPL version) = Disp.text "MPL" <<>> dispVersion version + pretty (Apache version) = Disp.text "Apache" <<>> dispOptVersion version + pretty (UnknownLicense other) = Disp.text other + pretty other = Disp.text (show other) + +instance Parsec License where + parsec = do + name <- P.munch1 isAlphaNum + version <- P.optional (P.char '-' *> parsec) + return $! case (name, version :: Maybe Version) of + ("GPL", _ ) -> GPL version + ("LGPL", _ ) -> LGPL version + ("AGPL", _ ) -> AGPL version + ("BSD2", Nothing) -> BSD2 + ("BSD3", Nothing) -> BSD3 + ("BSD4", Nothing) -> BSD4 + ("ISC", Nothing) -> ISC + ("MIT", Nothing) -> MIT + ("MPL", Just version') -> MPL version' + ("Apache", _ ) -> Apache version + ("PublicDomain", Nothing) -> PublicDomain + ("AllRightsReserved", Nothing) -> AllRightsReserved + ("OtherLicense", Nothing) -> OtherLicense + _ -> UnknownLicense $ name ++ + maybe "" (('-':) . prettyShow) version + +dispOptVersion :: Maybe Version -> Disp.Doc +dispOptVersion Nothing = Disp.empty +dispOptVersion (Just v) = dispVersion v + +dispVersion :: Version -> Disp.Doc +dispVersion v = Disp.char '-' <<>> pretty v diff --git a/cabal/Cabal-syntax/src/Distribution/ModuleName.hs b/cabal/Cabal-syntax/src/Distribution/ModuleName.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/ModuleName.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ScopedTypeVariables #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.ModuleName +-- Copyright : Duncan Coutts 2008 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Data type for Haskell module names. + +module Distribution.ModuleName ( + ModuleName, + fromString, + fromComponents, + components, + toFilePath, + main, + -- * Internal + validModuleComponent, + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Parsec +import Distribution.Pretty +import Distribution.Utils.ShortText (ShortText, fromShortText, toShortText) +import System.FilePath (pathSeparator) + +import qualified Distribution.Compat.CharParsing as P +import qualified Distribution.Compat.DList as DList +import qualified Text.PrettyPrint as Disp + +-- | A valid Haskell module name. +-- +newtype ModuleName = ModuleName ShortText + deriving (Eq, Generic, Ord, Read, Show, Typeable, Data) + +unModuleName :: ModuleName -> String +unModuleName (ModuleName s) = fromShortText s + +instance Binary ModuleName +instance Structured ModuleName + +instance NFData ModuleName where + rnf (ModuleName ms) = rnf ms + +instance Pretty ModuleName where + pretty = Disp.text . unModuleName + +instance Parsec ModuleName where + parsec = parsecModuleName + +parsecModuleName :: forall m. CabalParsing m => m ModuleName +parsecModuleName = state0 DList.empty where + upper :: m Char + !upper = P.satisfy isUpper + + ch :: m Char + !ch = P.satisfy (\c -> validModuleChar c || c == '.') + + alt :: m ModuleName -> m ModuleName -> m ModuleName + !alt = (<|>) + + state0 :: DList.DList Char -> m ModuleName + state0 acc = do + c <- upper + state1 (DList.snoc acc c) + + state1 :: DList.DList Char -> m ModuleName + state1 acc = state1' acc `alt` return (fromString (DList.toList acc)) + + state1' :: DList.DList Char -> m ModuleName + state1' acc = do + c <- ch + case c of + '.' -> state0 (DList.snoc acc c) + _ -> state1 (DList.snoc acc c) + +validModuleChar :: Char -> Bool +validModuleChar c = isAlphaNum c || c == '_' || c == '\'' + +validModuleComponent :: String -> Bool +validModuleComponent [] = False +validModuleComponent (c:cs) = isUpper c && all validModuleChar cs + +-- | Construct a 'ModuleName' from a valid module name 'String'. +-- +-- This is just a convenience function intended for valid module strings. It is +-- an error if it is used with a string that is not a valid module name. If you +-- are parsing user input then use 'Distribution.Text.simpleParse' instead. +-- +instance IsString ModuleName where + fromString = ModuleName . toShortText + +-- | Construct a 'ModuleName' from valid module components, i.e. parts +-- separated by dots. +fromComponents :: [String] -> ModuleName +fromComponents comps = fromString (intercalate "." comps) +{-# DEPRECATED fromComponents "Exists for cabal-install only" #-} + +-- | The module name @Main@. +-- +main :: ModuleName +main = ModuleName (fromString "Main") + +-- | The individual components of a hierarchical module name. For example +-- +-- > components (fromString "A.B.C") = ["A", "B", "C"] +-- +components :: ModuleName -> [String] +components mn = split (unModuleName mn) + where + split cs = case break (=='.') cs of + (chunk,[]) -> chunk : [] + (chunk,_:rest) -> chunk : split rest + +-- | Convert a module name to a file path, but without any file extension. +-- For example: +-- +-- > toFilePath (fromString "A.B.C") = "A/B/C" +-- +toFilePath :: ModuleName -> FilePath +toFilePath = map f . unModuleName where + f '.' = pathSeparator + f c = c diff --git a/cabal/Cabal-syntax/src/Distribution/Package.hs b/cabal/Cabal-syntax/src/Distribution/Package.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Package.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Package +-- Copyright : Isaac Jones 2003-2004 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Defines a package identifier along with a parser and pretty printer for it. +-- 'PackageIdentifier's consist of a name and an exact version. It also defines +-- a 'Dependency' data type. A dependency is a package name and a version +-- range, like @\"foo >= 1.2 && < 2\"@. + +module Distribution.Package + ( module Distribution.Types.AbiHash + , module Distribution.Types.ComponentId + , module Distribution.Types.PackageId + , module Distribution.Types.UnitId + , module Distribution.Types.Module + , module Distribution.Types.PackageName + , module Distribution.Types.PkgconfigName + , module Distribution.Types.Dependency + , Package(..), packageName, packageVersion + , HasMungedPackageId(..), mungedName', mungedVersion' + , HasUnitId(..) + , PackageInstalled(..) + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Version + ( Version ) + +import Distribution.Types.AbiHash +import Distribution.Types.ComponentId +import Distribution.Types.Dependency +import Distribution.Types.MungedPackageId +import Distribution.Types.PackageId +import Distribution.Types.UnitId +import Distribution.Types.Module +import Distribution.Types.MungedPackageName +import Distribution.Types.PackageName +import Distribution.Types.PkgconfigName + +-- | Class of things that have a 'PackageIdentifier' +-- +-- Types in this class are all notions of a package. This allows us to have +-- different types for the different phases that packages go though, from +-- simple name\/id, package description, configured or installed packages. +-- +-- Not all kinds of packages can be uniquely identified by a +-- 'PackageIdentifier'. In particular, installed packages cannot, there may be +-- many installed instances of the same source package. +-- +class Package pkg where + packageId :: pkg -> PackageIdentifier + +mungedName' :: HasMungedPackageId pkg => pkg -> MungedPackageName +mungedName' = mungedName . mungedId + +mungedVersion' :: HasMungedPackageId munged => munged -> Version +mungedVersion' = mungedVersion . mungedId + +class HasMungedPackageId pkg where + mungedId :: pkg -> MungedPackageId + +instance Package PackageIdentifier where + packageId = id + +packageName :: Package pkg => pkg -> PackageName +packageName = pkgName . packageId + +packageVersion :: Package pkg => pkg -> Version +packageVersion = pkgVersion . packageId + +instance HasMungedPackageId MungedPackageId where + mungedId = id + +-- | Packages that have an installed unit ID +class Package pkg => HasUnitId pkg where + installedUnitId :: pkg -> UnitId + +-- | Class of installed packages. +-- +-- The primary data type which is an instance of this package is +-- 'InstalledPackageInfo', but when we are doing install plans in Cabal install +-- we may have other, installed package-like things which contain more metadata. +-- Installed packages have exact dependencies 'installedDepends'. +class (HasUnitId pkg) => PackageInstalled pkg where + installedDepends :: pkg -> [UnitId] diff --git a/cabal/Cabal-syntax/src/Distribution/PackageDescription.hs b/cabal/Cabal-syntax/src/Distribution/PackageDescription.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/PackageDescription.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NoMonoLocalBinds #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.PackageDescription +-- Copyright : Isaac Jones 2003-2005 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Backwards compatibility reexport of most things you need to know +-- about @.cabal@ files. + +module Distribution.PackageDescription ( + -- * PD and GPD + module Distribution.Types.PackageDescription, + module Distribution.Types.GenericPackageDescription, + -- * Components + module Distribution.Types.ComponentName, + -- ** Library + module Distribution.Types.Library, + module Distribution.Types.LibraryName, + module Distribution.Types.LibraryVisibility, + -- ** Executable + module Distribution.Types.Executable, + module Distribution.Types.ExecutableScope, + -- ** TestSuite + module Distribution.Types.TestSuite, + module Distribution.Types.TestType, + module Distribution.Types.TestSuiteInterface, + -- ** Benchmark + module Distribution.Types.Benchmark, + module Distribution.Types.BenchmarkType, + module Distribution.Types.BenchmarkInterface, + -- ** Foreign library + module Distribution.Types.ForeignLib, + module Distribution.Types.ForeignLibType, + module Distribution.Types.ForeignLibOption, + -- * BuildInfo + module Distribution.Types.BuildType, + module Distribution.Types.BuildInfo, + module Distribution.Types.HookedBuildInfo, + module Distribution.Types.SetupBuildInfo, + -- * Flags + module Distribution.Types.Flag, + -- * Identifiers + module Distribution.Types.PackageId, + module Distribution.Types.PackageName, + module Distribution.Types.UnqualComponentName, + -- * Pkgconfig + module Distribution.Types.PkgconfigName, + module Distribution.Types.PkgconfigVersion, + module Distribution.Types.PkgconfigVersionRange, + -- * Dependencies + module Distribution.Types.Dependency, + module Distribution.Types.ExeDependency, + module Distribution.Types.LegacyExeDependency, + module Distribution.Types.PkgconfigDependency, + -- * Condition trees + module Distribution.Types.CondTree, + module Distribution.Types.Condition, + module Distribution.Types.ConfVar, + -- * Mixin + module Distribution.Types.IncludeRenaming, + module Distribution.Types.Mixin, + module Distribution.Types.ModuleReexport, + module Distribution.Types.ModuleRenaming, + -- * Source repository + module Distribution.Types.SourceRepo, + ) where + +import Prelude () +--import Distribution.Compat.Prelude + +import Distribution.Types.Benchmark +import Distribution.Types.BenchmarkInterface +import Distribution.Types.BenchmarkType +import Distribution.Types.BuildInfo +import Distribution.Types.BuildType +import Distribution.Types.ComponentName +import Distribution.Types.Condition +import Distribution.Types.CondTree +import Distribution.Types.ConfVar +import Distribution.Types.Dependency +import Distribution.Types.Executable +import Distribution.Types.ExecutableScope +import Distribution.Types.ExeDependency +import Distribution.Types.Flag +import Distribution.Types.ForeignLib +import Distribution.Types.ForeignLibOption +import Distribution.Types.ForeignLibType +import Distribution.Types.GenericPackageDescription +import Distribution.Types.HookedBuildInfo +import Distribution.Types.IncludeRenaming +import Distribution.Types.LegacyExeDependency +import Distribution.Types.Library +import Distribution.Types.LibraryName +import Distribution.Types.LibraryVisibility +import Distribution.Types.Mixin +import Distribution.Types.ModuleReexport +import Distribution.Types.ModuleRenaming +import Distribution.Types.PackageDescription +import Distribution.Types.PackageId +import Distribution.Types.PackageName +import Distribution.Types.PkgconfigDependency +import Distribution.Types.PkgconfigName +import Distribution.Types.PkgconfigVersion +import Distribution.Types.PkgconfigVersionRange +import Distribution.Types.SetupBuildInfo +import Distribution.Types.SourceRepo +import Distribution.Types.TestSuite +import Distribution.Types.TestSuiteInterface +import Distribution.Types.TestType +import Distribution.Types.UnqualComponentName diff --git a/cabal/Cabal-syntax/src/Distribution/PackageDescription/Configuration.hs b/cabal/Cabal-syntax/src/Distribution/PackageDescription/Configuration.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/PackageDescription/Configuration.hs @@ -0,0 +1,602 @@ +-- -fno-warn-deprecations for use of Map.foldWithKey +{-# OPTIONS_GHC -fno-warn-deprecations #-} +{-# LANGUAGE NoMonoLocalBinds #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.PackageDescription.Configuration +-- Copyright : Thomas Schilling, 2007 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is about the cabal configurations feature. It exports +-- 'finalizePD' and 'flattenPackageDescription' which are +-- functions for converting 'GenericPackageDescription's down to +-- 'PackageDescription's. It has code for working with the tree of conditions +-- and resolving or flattening conditions. + +module Distribution.PackageDescription.Configuration ( + finalizePD, + flattenPackageDescription, + + -- Utils + parseCondition, + freeVars, + extractCondition, + extractConditions, + addBuildableCondition, + mapCondTree, + mapTreeData, + mapTreeConds, + mapTreeConstrs, + transformAllBuildInfos, + transformAllBuildDepends, + transformAllBuildDependsN, + simplifyWithSysParams + ) where + +import Distribution.Compat.Prelude +import Prelude () + +-- lens +import qualified Distribution.Types.BuildInfo.Lens as L +import qualified Distribution.Types.GenericPackageDescription.Lens as L +import qualified Distribution.Types.PackageDescription.Lens as L +import qualified Distribution.Types.SetupBuildInfo.Lens as L + +import Distribution.Compat.CharParsing hiding (char) +import qualified Distribution.Compat.CharParsing as P +import Distribution.Compat.Lens +import Distribution.Compiler +import Distribution.PackageDescription +import Distribution.PackageDescription.Utils +import Distribution.Parsec +import Distribution.Pretty +import Distribution.System +import Distribution.Types.Component +import Distribution.Utils.Path +import Distribution.Types.ComponentRequestedSpec +import Distribution.Types.DependencyMap +import Distribution.Types.PackageVersionConstraint +import Distribution.Utils.Generic +import Distribution.Version + +import qualified Data.Map.Lazy as Map +import Data.Tree (Tree (Node)) + +------------------------------------------------------------------------------ + +-- | Simplify a configuration condition using the OS and arch names. Returns +-- the names of all the flags occurring in the condition. +simplifyWithSysParams :: OS -> Arch -> CompilerInfo -> Condition ConfVar + -> (Condition FlagName, [FlagName]) +simplifyWithSysParams os arch cinfo cond = (cond', flags) + where + (cond', flags) = simplifyCondition cond interp + interp (OS os') = Right $ os' == os + interp (Arch arch') = Right $ arch' == arch + interp (Impl comp vr) + | matchImpl (compilerInfoId cinfo) = Right True + | otherwise = case compilerInfoCompat cinfo of + -- fixme: treat Nothing as unknown, rather than empty list once we + -- support partial resolution of system parameters + Nothing -> Right False + Just compat -> Right (any matchImpl compat) + where + matchImpl (CompilerId c v) = comp == c && v `withinRange` vr + interp (PackageFlag f) = Left f + +-- TODO: Add instances and check +-- +-- prop_sC_idempotent cond a o = cond' == cond'' +-- where +-- cond' = simplifyCondition cond a o +-- cond'' = simplifyCondition cond' a o +-- +-- prop_sC_noLits cond a o = isLit res || not (hasLits res) +-- where +-- res = simplifyCondition cond a o +-- hasLits (Lit _) = True +-- hasLits (CNot c) = hasLits c +-- hasLits (COr l r) = hasLits l || hasLits r +-- hasLits (CAnd l r) = hasLits l || hasLits r +-- hasLits _ = False +-- + +-- | Parse a configuration condition from a string. +parseCondition :: CabalParsing m => m (Condition ConfVar) +parseCondition = condOr + where + condOr = sepByNonEmpty condAnd (oper "||") >>= return . foldl1 COr + condAnd = sepByNonEmpty cond (oper "&&")>>= return . foldl1 CAnd + -- TODO: try? + cond = sp >> (boolLiteral <|> inparens condOr <|> notCond <|> osCond + <|> archCond <|> flagCond <|> implCond ) + inparens = between (P.char '(' >> sp) (sp >> P.char ')' >> sp) + notCond = P.char '!' >> sp >> cond >>= return . CNot + osCond = string "os" >> sp >> inparens osIdent >>= return . Var + archCond = string "arch" >> sp >> inparens archIdent >>= return . Var + flagCond = string "flag" >> sp >> inparens flagIdent >>= return . Var + implCond = string "impl" >> sp >> inparens implIdent >>= return . Var + boolLiteral = fmap Lit parsec + archIdent = fmap Arch parsec + osIdent = fmap OS parsec + flagIdent = fmap (PackageFlag . mkFlagName . lowercase) (munch1 isIdentChar) + isIdentChar c = isAlphaNum c || c == '_' || c == '-' + oper s = sp >> string s >> sp + sp = spaces + implIdent = do i <- parsec + vr <- sp >> option anyVersion parsec + return $ Impl i vr + +------------------------------------------------------------------------------ + +-- | Result of dependency test. Isomorphic to @Maybe d@ but renamed for +-- clarity. +data DepTestRslt d = DepOk | MissingDeps d + +instance Semigroup d => Monoid (DepTestRslt d) where + mempty = DepOk + mappend = (<>) + +instance Semigroup d => Semigroup (DepTestRslt d) where + DepOk <> x = x + x <> DepOk = x + (MissingDeps d) <> (MissingDeps d') = MissingDeps (d <> d') + + +-- | Try to find a flag assignment that satisfies the constraints of all trees. +-- +-- Returns either the missing dependencies, or a tuple containing the +-- resulting data, the associated dependencies, and the chosen flag +-- assignments. +-- +-- In case of failure, the union of the dependencies that led to backtracking +-- on all branches is returned. +-- [TODO: Could also be specified with a function argument.] +-- +-- TODO: The current algorithm is rather naive. A better approach would be to: +-- +-- * Rule out possible paths, by taking a look at the associated dependencies. +-- +-- * Infer the required values for the conditions of these paths, and +-- calculate the required domains for the variables used in these +-- conditions. Then picking a flag assignment would be linear (I guess). +-- +-- This would require some sort of SAT solving, though, thus it's not +-- implemented unless we really need it. +-- +resolveWithFlags :: + [(FlagName,[Bool])] + -- ^ Domain for each flag name, will be tested in order. + -> ComponentRequestedSpec + -> OS -- ^ OS where the installed artifacts will run (host OS) + -> Arch -- ^ Arch where the installed artifacts will run (host Arch) + -> CompilerInfo -- ^ Compiler information + -> [PackageVersionConstraint] -- ^ Additional constraints + -> [CondTree ConfVar [Dependency] PDTagged] + -> ([Dependency] -> DepTestRslt [Dependency]) -- ^ Dependency test function. + -> Either [Dependency] (TargetSet PDTagged, FlagAssignment) + -- ^ Either the missing dependencies (error case), or a pair of + -- (set of build targets with dependencies, chosen flag assignments) +resolveWithFlags dom enabled os arch impl constrs trees checkDeps = + either (Left . fromDepMapUnion) Right $ explore (build mempty dom) + where + -- simplify trees by (partially) evaluating all conditions and converting + -- dependencies to dependency maps. + simplifiedTrees :: [CondTree FlagName DependencyMap PDTagged] + simplifiedTrees = map ( mapTreeConstrs toDepMap -- convert to maps + . addBuildableConditionPDTagged + . mapTreeConds (fst . simplifyWithSysParams os arch impl)) + trees + + -- @explore@ searches a tree of assignments, backtracking whenever a flag + -- introduces a dependency that cannot be satisfied. If there is no + -- solution, @explore@ returns the union of all dependencies that caused + -- it to backtrack. Since the tree is constructed lazily, we avoid some + -- computation overhead in the successful case. + explore :: Tree FlagAssignment + -> Either DepMapUnion (TargetSet PDTagged, FlagAssignment) + explore (Node flags ts) = + let targetSet = TargetSet $ flip map simplifiedTrees $ + -- apply additional constraints to all dependencies + first (`constrainBy` constrs) . + simplifyCondTree (env flags) + deps = overallDependencies enabled targetSet + in case checkDeps (fromDepMap deps) of + DepOk | null ts -> Right (targetSet, flags) + | otherwise -> tryAll $ map explore ts + MissingDeps mds -> Left (toDepMapUnion mds) + + -- Builds a tree of all possible flag assignments. Internal nodes + -- have only partial assignments. + build :: FlagAssignment -> [(FlagName, [Bool])] -> Tree FlagAssignment + build assigned [] = Node assigned [] + build assigned ((fn, vals) : unassigned) = + Node assigned $ map (\v -> build (insertFlagAssignment fn v assigned) unassigned) vals + + tryAll :: [Either DepMapUnion a] -> Either DepMapUnion a + tryAll = foldr mp mz + + -- special version of `mplus' for our local purposes + mp :: Either DepMapUnion a -> Either DepMapUnion a -> Either DepMapUnion a + mp m@(Right _) _ = m + mp _ m@(Right _) = m + mp (Left xs) (Left ys) = Left (xs <> ys) + + -- `mzero' + mz :: Either DepMapUnion a + mz = Left (DepMapUnion Map.empty) + + env :: FlagAssignment -> FlagName -> Either FlagName Bool + env flags flag = (maybe (Left flag) Right . lookupFlagAssignment flag) flags + +-- | Transforms a 'CondTree' by putting the input under the "then" branch of a +-- conditional that is True when Buildable is True. If 'addBuildableCondition' +-- can determine that Buildable is always True, it returns the input unchanged. +-- If Buildable is always False, it returns the empty 'CondTree'. +addBuildableCondition :: (Eq v, Monoid a, Monoid c) => (a -> BuildInfo) + -> CondTree v c a + -> CondTree v c a +addBuildableCondition getInfo t = + case extractCondition (buildable . getInfo) t of + Lit True -> t + Lit False -> CondNode mempty mempty [] + c -> CondNode mempty mempty [condIfThen c t] + +-- | This is a special version of 'addBuildableCondition' for the 'PDTagged' +-- type. +-- +-- It is not simply a specialisation. It is more complicated than it +-- ought to be because of the way the 'PDTagged' monoid instance works. The +-- @mempty = 'PDNull'@ forgets the component type, which has the effect of +-- completely deleting components that are not buildable. +-- +-- See for more details. +-- +addBuildableConditionPDTagged :: (Eq v, Monoid c) => + CondTree v c PDTagged + -> CondTree v c PDTagged +addBuildableConditionPDTagged t = + case extractCondition (buildable . getInfo) t of + Lit True -> t + Lit False -> deleteConstraints t + c -> CondNode mempty mempty [condIfThenElse c t (deleteConstraints t)] + where + deleteConstraints = mapTreeConstrs (const mempty) + + getInfo :: PDTagged -> BuildInfo + getInfo (Lib l) = libBuildInfo l + getInfo (SubComp _ c) = componentBuildInfo c + getInfo PDNull = mempty + + +-- Note: extracting buildable conditions. +-- -------------------------------------- +-- +-- If the conditions in a cond tree lead to Buildable being set to False, then +-- none of the dependencies for this cond tree should actually be taken into +-- account. On the other hand, some of the flags may only be decided in the +-- solver, so we cannot necessarily make the decision whether a component is +-- Buildable or not prior to solving. +-- +-- What we are doing here is to partially evaluate a condition tree in order to +-- extract the condition under which Buildable is True. The predicate determines +-- whether data under a 'CondTree' is buildable. + +-- | Extract conditions matched by the given predicate from all cond trees in a +-- 'GenericPackageDescription'. +extractConditions :: (BuildInfo -> Bool) -> GenericPackageDescription + -> [Condition ConfVar] +extractConditions f gpkg = + concat [ + extractCondition (f . libBuildInfo) <$> maybeToList (condLibrary gpkg) + , extractCondition (f . libBuildInfo) . snd <$> condSubLibraries gpkg + , extractCondition (f . buildInfo) . snd <$> condExecutables gpkg + , extractCondition (f . testBuildInfo) . snd <$> condTestSuites gpkg + , extractCondition (f . benchmarkBuildInfo) . snd <$> condBenchmarks gpkg + ] + + +-- | A map of package constraints that combines version ranges using 'unionVersionRanges'. +newtype DepMapUnion = DepMapUnion { unDepMapUnion :: Map PackageName (VersionRange, NonEmptySet LibraryName) } + +instance Semigroup DepMapUnion where + DepMapUnion x <> DepMapUnion y = DepMapUnion $ + Map.unionWith unionVersionRanges' x y + +unionVersionRanges' + :: (VersionRange, NonEmptySet LibraryName) + -> (VersionRange, NonEmptySet LibraryName) + -> (VersionRange, NonEmptySet LibraryName) +unionVersionRanges' (vr, cs) (vr', cs') = (unionVersionRanges vr vr', cs <> cs') + +toDepMapUnion :: [Dependency] -> DepMapUnion +toDepMapUnion ds = + DepMapUnion $ Map.fromListWith unionVersionRanges' [ (p,(vr,cs)) | Dependency p vr cs <- ds ] + + +fromDepMapUnion :: DepMapUnion -> [Dependency] +fromDepMapUnion m = [ Dependency p vr cs | (p,(vr,cs)) <- Map.toList (unDepMapUnion m) ] + +freeVars :: CondTree ConfVar c a -> [FlagName] +freeVars t = [ f | PackageFlag f <- freeVars' t ] + where + freeVars' (CondNode _ _ ifs) = concatMap compfv ifs + compfv (CondBranch c ct mct) = condfv c ++ freeVars' ct ++ maybe [] freeVars' mct + condfv c = case c of + Var v -> [v] + Lit _ -> [] + CNot c' -> condfv c' + COr c1 c2 -> condfv c1 ++ condfv c2 + CAnd c1 c2 -> condfv c1 ++ condfv c2 + + +------------------------------------------------------------------------------ + +-- | A set of targets with their package dependencies +newtype TargetSet a = TargetSet [(DependencyMap, a)] + +-- | Combine the target-specific dependencies in a TargetSet to give the +-- dependencies for the package as a whole. +overallDependencies :: ComponentRequestedSpec -> TargetSet PDTagged -> DependencyMap +overallDependencies enabled (TargetSet targets) = mconcat depss + where + (depss, _) = unzip $ filter (removeDisabledSections . snd) targets + removeDisabledSections :: PDTagged -> Bool + -- UGH. The embedded componentName in the 'Component's here is + -- BLANK. I don't know whose fault this is but I'll use the tag + -- instead. -- ezyang + removeDisabledSections (Lib _) = componentNameRequested + enabled + (CLibName LMainLibName) + removeDisabledSections (SubComp t c) + -- Do NOT use componentName + = componentNameRequested enabled + $ case c of + CLib _ -> CLibName (LSubLibName t) + CFLib _ -> CFLibName t + CExe _ -> CExeName t + CTest _ -> CTestName t + CBench _ -> CBenchName t + removeDisabledSections PDNull = True + +-- | Collect up the targets in a TargetSet of tagged targets, storing the +-- dependencies as we go. +flattenTaggedTargets :: TargetSet PDTagged -> (Maybe Library, [(UnqualComponentName, Component)]) +flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, []) targets where + untag (depMap, pdTagged) accum = case (pdTagged, accum) of + (Lib _, (Just _, _)) -> userBug "Only one library expected" + (Lib l, (Nothing, comps)) -> (Just $ redoBD l, comps) + (SubComp n c, (mb_lib, comps)) + | any ((== n) . fst) comps -> + userBug $ "There exist several components with the same name: '" ++ prettyShow n ++ "'" + | otherwise -> (mb_lib, (n, redoBD c) : comps) + (PDNull, x) -> x -- actually this should not happen, but let's be liberal + where + redoBD :: L.HasBuildInfo a => a -> a + redoBD = set L.targetBuildDepends $ fromDepMap depMap + +------------------------------------------------------------------------------ +-- Convert GenericPackageDescription to PackageDescription +-- + +data PDTagged = Lib Library + | SubComp UnqualComponentName Component + | PDNull + deriving Show + +instance Monoid PDTagged where + mempty = PDNull + mappend = (<>) + +instance Semigroup PDTagged where + PDNull <> x = x + x <> PDNull = x + Lib l <> Lib l' = Lib (l <> l') + SubComp n x <> SubComp n' x' | n == n' = SubComp n (x <> x') + _ <> _ = cabalBug "Cannot combine incompatible tags" + +-- | Create a package description with all configurations resolved. +-- +-- This function takes a `GenericPackageDescription` and several environment +-- parameters and tries to generate `PackageDescription` by finding a flag +-- assignment that result in satisfiable dependencies. +-- +-- It takes as inputs a not necessarily complete specifications of flags +-- assignments, an optional package index as well as platform parameters. If +-- some flags are not assigned explicitly, this function will try to pick an +-- assignment that causes this function to succeed. The package index is +-- optional since on some platforms we cannot determine which packages have +-- been installed before. When no package index is supplied, every dependency +-- is assumed to be satisfiable, therefore all not explicitly assigned flags +-- will get their default values. +-- +-- This function will fail if it cannot find a flag assignment that leads to +-- satisfiable dependencies. (It will not try alternative assignments for +-- explicitly specified flags.) In case of failure it will return the missing +-- dependencies that it encountered when trying different flag assignments. +-- On success, it will return the package description and the full flag +-- assignment chosen. +-- +-- Note that this drops any stanzas which have @buildable: False@. While +-- this is arguably the right thing to do, it means we give bad error +-- messages in some situations, see #3858. +-- +finalizePD :: + FlagAssignment -- ^ Explicitly specified flag assignments + -> ComponentRequestedSpec + -> (Dependency -> Bool) -- ^ Is a given dependency satisfiable from the set of + -- available packages? If this is unknown then use + -- True. + -> Platform -- ^ The 'Arch' and 'OS' + -> CompilerInfo -- ^ Compiler information + -> [PackageVersionConstraint] -- ^ Additional constraints + -> GenericPackageDescription + -> Either [Dependency] + (PackageDescription, FlagAssignment) + -- ^ Either missing dependencies or the resolved package + -- description along with the flag assignments chosen. +finalizePD userflags enabled satisfyDep + (Platform arch os) impl constraints + (GenericPackageDescription pkg _ver flags mb_lib0 sub_libs0 flibs0 exes0 tests0 bms0) = do + (targetSet, flagVals) <- + resolveWithFlags flagChoices enabled os arch impl constraints condTrees check + let + (mb_lib, comps) = flattenTaggedTargets targetSet + mb_lib' = fmap libFillInDefaults mb_lib + comps' = flip map comps $ \(n,c) -> foldComponent + (\l -> CLib (libFillInDefaults l) { libName = LSubLibName n + , libExposed = False }) + (\l -> CFLib (flibFillInDefaults l) { foreignLibName = n }) + (\e -> CExe (exeFillInDefaults e) { exeName = n }) + (\t -> CTest (testFillInDefaults t) { testName = n }) + (\b -> CBench (benchFillInDefaults b) { benchmarkName = n }) + c + (sub_libs', flibs', exes', tests', bms') = partitionComponents comps' + return ( pkg { library = mb_lib' + , subLibraries = sub_libs' + , foreignLibs = flibs' + , executables = exes' + , testSuites = tests' + , benchmarks = bms' + } + , flagVals ) + where + -- Combine lib, exes, and tests into one list of @CondTree@s with tagged data + condTrees = maybeToList (fmap (mapTreeData Lib) mb_lib0) + ++ map (\(name,tree) -> mapTreeData (SubComp name . CLib) tree) sub_libs0 + ++ map (\(name,tree) -> mapTreeData (SubComp name . CFLib) tree) flibs0 + ++ map (\(name,tree) -> mapTreeData (SubComp name . CExe) tree) exes0 + ++ map (\(name,tree) -> mapTreeData (SubComp name . CTest) tree) tests0 + ++ map (\(name,tree) -> mapTreeData (SubComp name . CBench) tree) bms0 + + flagChoices = map (\(MkPackageFlag n _ d manual) -> (n, d2c manual n d)) flags + d2c manual n b = case lookupFlagAssignment n userflags of + Just val -> [val] + Nothing + | manual -> [b] + | otherwise -> [b, not b] + --flagDefaults = map (\(n,x:_) -> (n,x)) flagChoices + check ds = let missingDeps = filter (not . satisfyDep) ds + in if null missingDeps + then DepOk + else MissingDeps missingDeps + +{- +let tst_p = (CondNode [1::Int] [Distribution.Package.Dependency "a" AnyVersion] []) +let tst_p2 = (CondNode [1::Int] [Distribution.Package.Dependency "a" (EarlierVersion (Version [1,0] [])), Distribution.Package.Dependency "a" (LaterVersion (Version [2,0] []))] []) + +let p_index = Distribution.Simple.PackageIndex.fromList [Distribution.Package.PackageIdentifier "a" (Version [0,5] []), Distribution.Package.PackageIdentifier "a" (Version [2,5] [])] +let look = not . null . Distribution.Simple.PackageIndex.lookupDependency p_index +let looks ds = mconcat $ map (\d -> if look d then DepOk else MissingDeps [d]) ds +resolveWithFlags [] Distribution.System.Linux Distribution.System.I386 (Distribution.Compiler.GHC,Version [6,8,2] []) [tst_p] looks ===> Right ... +resolveWithFlags [] Distribution.System.Linux Distribution.System.I386 (Distribution.Compiler.GHC,Version [6,8,2] []) [tst_p2] looks ===> Left ... +-} + +-- | Flatten a generic package description by ignoring all conditions and just +-- join the field descriptors into on package description. Note, however, +-- that this may lead to inconsistent field values, since all values are +-- joined into one field, which may not be possible in the original package +-- description, due to the use of exclusive choices (if ... else ...). +-- +-- TODO: One particularly tricky case is defaulting. In the original package +-- description, e.g., the source directory might either be the default or a +-- certain, explicitly set path. Since defaults are filled in only after the +-- package has been resolved and when no explicit value has been set, the +-- default path will be missing from the package description returned by this +-- function. +flattenPackageDescription :: GenericPackageDescription -> PackageDescription +flattenPackageDescription + (GenericPackageDescription pkg _ _ mlib0 sub_libs0 flibs0 exes0 tests0 bms0) = + pkg { library = mlib + , subLibraries = reverse sub_libs + , foreignLibs = reverse flibs + , executables = reverse exes + , testSuites = reverse tests + , benchmarks = reverse bms + } + where + mlib = f <$> mlib0 + where f lib = (libFillInDefaults . fst . ignoreConditions $ lib) { libName = LMainLibName } + sub_libs = flattenLib <$> sub_libs0 + flibs = flattenFLib <$> flibs0 + exes = flattenExe <$> exes0 + tests = flattenTst <$> tests0 + bms = flattenBm <$> bms0 + flattenLib (n, t) = libFillInDefaults $ (fst $ ignoreConditions t) + { libName = LSubLibName n, libExposed = False } + flattenFLib (n, t) = flibFillInDefaults $ (fst $ ignoreConditions t) + { foreignLibName = n } + flattenExe (n, t) = exeFillInDefaults $ (fst $ ignoreConditions t) + { exeName = n } + flattenTst (n, t) = testFillInDefaults $ (fst $ ignoreConditions t) + { testName = n } + flattenBm (n, t) = benchFillInDefaults $ (fst $ ignoreConditions t) + { benchmarkName = n } + +-- This is in fact rather a hack. The original version just overrode the +-- default values, however, when adding conditions we had to switch to a +-- modifier-based approach. There, nothing is ever overwritten, but only +-- joined together. +-- +-- This is the cleanest way i could think of, that doesn't require +-- changing all field parsing functions to return modifiers instead. +libFillInDefaults :: Library -> Library +libFillInDefaults lib@(Library { libBuildInfo = bi }) = + lib { libBuildInfo = biFillInDefaults bi } + +flibFillInDefaults :: ForeignLib -> ForeignLib +flibFillInDefaults flib@(ForeignLib { foreignLibBuildInfo = bi }) = + flib { foreignLibBuildInfo = biFillInDefaults bi } + +exeFillInDefaults :: Executable -> Executable +exeFillInDefaults exe@(Executable { buildInfo = bi }) = + exe { buildInfo = biFillInDefaults bi } + +testFillInDefaults :: TestSuite -> TestSuite +testFillInDefaults tst@(TestSuite { testBuildInfo = bi }) = + tst { testBuildInfo = biFillInDefaults bi } + +benchFillInDefaults :: Benchmark -> Benchmark +benchFillInDefaults bm@(Benchmark { benchmarkBuildInfo = bi }) = + bm { benchmarkBuildInfo = biFillInDefaults bi } + +biFillInDefaults :: BuildInfo -> BuildInfo +biFillInDefaults bi = + if null (hsSourceDirs bi) + then bi { hsSourceDirs = [sameDirectory] } + else bi + +-- Walk a 'GenericPackageDescription' and apply @onBuildInfo@/@onSetupBuildInfo@ +-- to all nested 'BuildInfo'/'SetupBuildInfo' values. +transformAllBuildInfos :: (BuildInfo -> BuildInfo) + -> (SetupBuildInfo -> SetupBuildInfo) + -> GenericPackageDescription + -> GenericPackageDescription +transformAllBuildInfos onBuildInfo onSetupBuildInfo = + over L.traverseBuildInfos onBuildInfo + . over (L.packageDescription . L.setupBuildInfo . traverse) onSetupBuildInfo + +-- | Walk a 'GenericPackageDescription' and apply @f@ to all nested +-- @build-depends@ fields. +transformAllBuildDepends :: (Dependency -> Dependency) + -> GenericPackageDescription + -> GenericPackageDescription +transformAllBuildDepends f = + over (L.traverseBuildInfos . L.targetBuildDepends . traverse) f + . over (L.packageDescription . L.setupBuildInfo . traverse . L.setupDepends . traverse) f + -- cannot be point-free as normal because of higher rank + . over (\f' -> L.allCondTrees $ traverseCondTreeC f') (map f) + +-- | Walk a 'GenericPackageDescription' and apply @f@ to all nested +-- @build-depends@ fields. +transformAllBuildDependsN :: ([Dependency] -> [Dependency]) + -> GenericPackageDescription + -> GenericPackageDescription +transformAllBuildDependsN f = + over (L.traverseBuildInfos . L.targetBuildDepends) f + . over (L.packageDescription . L.setupBuildInfo . traverse . L.setupDepends) f + -- cannot be point-free as normal because of higher rank + . over (\f' -> L.allCondTrees $ traverseCondTreeC f') f diff --git a/cabal/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/cabal/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -0,0 +1,822 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +-- | 'GenericPackageDescription' Field descriptions +module Distribution.PackageDescription.FieldGrammar ( + -- * Package description + packageDescriptionFieldGrammar, + -- * Library + libraryFieldGrammar, + -- * Foreign library + foreignLibFieldGrammar, + -- * Executable + executableFieldGrammar, + -- * Test suite + TestSuiteStanza (..), + testSuiteFieldGrammar, + validateTestSuite, + unvalidateTestSuite, + -- ** Lenses + testStanzaTestType, + testStanzaMainIs, + testStanzaTestModule, + testStanzaBuildInfo, + -- * Benchmark + BenchmarkStanza (..), + benchmarkFieldGrammar, + validateBenchmark, + unvalidateBenchmark, + -- * Field grammars + formatDependencyList, + formatExposedModules, + formatExtraSourceFiles, + formatHsSourceDirs, + formatMixinList, + formatOtherExtensions, + formatOtherModules, + -- ** Lenses + benchmarkStanzaBenchmarkType, + benchmarkStanzaMainIs, + benchmarkStanzaBenchmarkModule, + benchmarkStanzaBuildInfo, + -- * Flag + flagFieldGrammar, + -- * Source repository + sourceRepoFieldGrammar, + -- * Setup build info + setupBInfoFieldGrammar, + -- * Component build info + buildInfoFieldGrammar, + ) where + + +import Distribution.Compat.Lens +import Distribution.Compat.Prelude +import Language.Haskell.Extension +import Prelude () + +import Distribution.CabalSpecVersion +import Distribution.Compat.Newtype (Newtype, pack', unpack') +import Distribution.Compiler (CompilerFlavor (..), PerCompilerFlavor (..)) +import Distribution.FieldGrammar +import Distribution.Fields +import Distribution.ModuleName (ModuleName) +import Distribution.Package +import Distribution.PackageDescription +import Distribution.Parsec +import Distribution.Pretty (Pretty (..), prettyShow, showToken) +import Distribution.Utils.Path +import Distribution.Version (Version, VersionRange) + +import qualified Data.ByteString.Char8 as BS8 +import qualified Distribution.Compat.CharParsing as P +import qualified Distribution.SPDX as SPDX +import qualified Distribution.Types.Lens as L + +------------------------------------------------------------------------------- +-- PackageDescription +------------------------------------------------------------------------------- + +packageDescriptionFieldGrammar + :: ( FieldGrammar c g, Applicative (g PackageDescription), Applicative (g PackageIdentifier) + , c (Identity BuildType) + , c (Identity PackageName) + , c (Identity Version) + , c (List FSep FilePathNT String) + , c (List FSep CompatFilePath String) + , c (List FSep (Identity (SymbolicPath PackageDir LicenseFile)) (SymbolicPath PackageDir LicenseFile)) + , c (List FSep TestedWith (CompilerFlavor, VersionRange)) + , c (List VCat FilePathNT String) + , c FilePathNT + , c CompatLicenseFile + , c CompatFilePath + , c SpecLicense + , c SpecVersion + ) + => g PackageDescription PackageDescription +packageDescriptionFieldGrammar = PackageDescription + <$> optionalFieldDefAla "cabal-version" SpecVersion L.specVersion CabalSpecV1_0 + <*> blurFieldGrammar L.package packageIdentifierGrammar + <*> optionalFieldDefAla "license" SpecLicense L.licenseRaw (Left SPDX.NONE) + <*> licenseFilesGrammar + <*> freeTextFieldDefST "copyright" L.copyright + <*> freeTextFieldDefST "maintainer" L.maintainer + <*> freeTextFieldDefST "author" L.author + <*> freeTextFieldDefST "stability" L.stability + <*> monoidalFieldAla "tested-with" (alaList' FSep TestedWith) L.testedWith + <*> freeTextFieldDefST "homepage" L.homepage + <*> freeTextFieldDefST "package-url" L.pkgUrl + <*> freeTextFieldDefST "bug-reports" L.bugReports + <*> pure [] -- source-repos are stanza + <*> freeTextFieldDefST "synopsis" L.synopsis + <*> freeTextFieldDefST "description" L.description + <*> freeTextFieldDefST "category" L.category + <*> prefixedFields "x-" L.customFieldsPD + <*> optionalField "build-type" L.buildTypeRaw + <*> pure Nothing -- custom-setup + -- components + <*> pure Nothing -- lib + <*> pure [] -- sub libs + <*> pure [] -- executables + <*> pure [] -- foreign libs + <*> pure [] -- test suites + <*> pure [] -- benchmarks + -- * Files + <*> monoidalFieldAla "data-files" (alaList' VCat FilePathNT) L.dataFiles + <*> optionalFieldDefAla "data-dir" CompatFilePath L.dataDir "." + ^^^ fmap (\x -> if null x then "." else x) -- map empty directories to "." + <*> monoidalFieldAla "extra-source-files" formatExtraSourceFiles L.extraSrcFiles + <*> monoidalFieldAla "extra-tmp-files" (alaList' VCat FilePathNT) L.extraTmpFiles + <*> monoidalFieldAla "extra-doc-files" (alaList' VCat FilePathNT) L.extraDocFiles + where + packageIdentifierGrammar = PackageIdentifier + <$> uniqueField "name" L.pkgName + <*> uniqueField "version" L.pkgVersion + + licenseFilesGrammar = (++) + -- TODO: neither field is deprecated + -- should we pretty print license-file if there's single license file + -- and license-files when more + <$> monoidalFieldAla "license-file" CompatLicenseFile L.licenseFiles + <*> monoidalFieldAla "license-files" (alaList FSep) L.licenseFiles + ^^^ hiddenField + +------------------------------------------------------------------------------- +-- Library +------------------------------------------------------------------------------- + +libraryFieldGrammar + :: ( FieldGrammar c g, Applicative (g Library), Applicative (g BuildInfo) + , c (Identity LibraryVisibility) + , c (List CommaFSep (Identity ExeDependency) ExeDependency) + , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) + , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) + , c (List CommaVCat (Identity Dependency) Dependency) + , c (List CommaVCat (Identity Mixin) Mixin) + , c (List CommaVCat (Identity ModuleReexport) ModuleReexport) + , c (List FSep (MQuoted Extension) Extension) + , c (List FSep (MQuoted Language) Language) + , c (List FSep FilePathNT String) + , c (List FSep Token String) + , c (List NoCommaFSep Token' String) + , c (List VCat (MQuoted ModuleName) ModuleName) + , c (List VCat FilePathNT String) + , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir)) + , c (List VCat Token String) + , c (MQuoted Language) + ) + => LibraryName + -> g Library Library +libraryFieldGrammar n = Library n + <$> monoidalFieldAla "exposed-modules" formatExposedModules L.exposedModules + <*> monoidalFieldAla "reexported-modules" (alaList CommaVCat) L.reexportedModules + <*> monoidalFieldAla "signatures" (alaList' VCat MQuoted) L.signatures + ^^^ availableSince CabalSpecV2_0 [] + <*> booleanFieldDef "exposed" L.libExposed True + <*> visibilityField + <*> blurFieldGrammar L.libBuildInfo buildInfoFieldGrammar + where + visibilityField = case n of + -- nameless/"main" libraries are public + LMainLibName -> pure LibraryVisibilityPublic + -- named libraries have the field + LSubLibName _ -> + optionalFieldDef "visibility" L.libVisibility LibraryVisibilityPrivate + ^^^ availableSince CabalSpecV3_0 LibraryVisibilityPrivate + +{-# SPECIALIZE libraryFieldGrammar :: LibraryName -> ParsecFieldGrammar' Library #-} +{-# SPECIALIZE libraryFieldGrammar :: LibraryName -> PrettyFieldGrammar' Library #-} + +------------------------------------------------------------------------------- +-- Foreign library +------------------------------------------------------------------------------- + +foreignLibFieldGrammar + :: ( FieldGrammar c g, Applicative (g ForeignLib), Applicative (g BuildInfo) + , c (Identity ForeignLibType) + , c (Identity LibVersionInfo) + , c (Identity Version) + , c (List CommaFSep (Identity ExeDependency) ExeDependency) + , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) + , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) + , c (List CommaVCat (Identity Dependency) Dependency) + , c (List CommaVCat (Identity Mixin) Mixin) + , c (List FSep (Identity ForeignLibOption) ForeignLibOption) + , c (List FSep (MQuoted Extension) Extension) + , c (List FSep (MQuoted Language) Language) + , c (List FSep FilePathNT String) + , c (List FSep Token String) + , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir)) + , c (List NoCommaFSep Token' String) + , c (List VCat (MQuoted ModuleName) ModuleName) + , c (List VCat FilePathNT String), c (List VCat Token String) + , c (MQuoted Language) + ) + => UnqualComponentName -> g ForeignLib ForeignLib +foreignLibFieldGrammar n = ForeignLib n + <$> optionalFieldDef "type" L.foreignLibType ForeignLibTypeUnknown + <*> monoidalFieldAla "options" (alaList FSep) L.foreignLibOptions + <*> blurFieldGrammar L.foreignLibBuildInfo buildInfoFieldGrammar + <*> optionalField "lib-version-info" L.foreignLibVersionInfo + <*> optionalField "lib-version-linux" L.foreignLibVersionLinux + <*> monoidalFieldAla "mod-def-file" (alaList' FSep FilePathNT) L.foreignLibModDefFile +{-# SPECIALIZE foreignLibFieldGrammar :: UnqualComponentName -> ParsecFieldGrammar' ForeignLib #-} +{-# SPECIALIZE foreignLibFieldGrammar :: UnqualComponentName -> PrettyFieldGrammar' ForeignLib #-} + +------------------------------------------------------------------------------- +-- Executable +------------------------------------------------------------------------------- + +executableFieldGrammar + :: ( FieldGrammar c g, Applicative (g Executable), Applicative (g BuildInfo) + , c (Identity ExecutableScope) + , c (List CommaFSep (Identity ExeDependency) ExeDependency) + , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) + , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) + , c (List CommaVCat (Identity Dependency) Dependency) + , c (List CommaVCat (Identity Mixin) Mixin) + , c (List FSep (MQuoted Extension) Extension) + , c (List FSep (MQuoted Language) Language) + , c (List FSep FilePathNT String) + , c (List FSep Token String) + , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir)) + , c (List NoCommaFSep Token' String) + , c (List VCat (MQuoted ModuleName) ModuleName) + , c (List VCat FilePathNT String) + , c (List VCat Token String) + , c (MQuoted Language) + ) + => UnqualComponentName -> g Executable Executable +executableFieldGrammar n = Executable n + -- main-is is optional as conditional blocks don't have it + <$> optionalFieldDefAla "main-is" FilePathNT L.modulePath "" + <*> optionalFieldDef "scope" L.exeScope ExecutablePublic + ^^^ availableSince CabalSpecV2_0 ExecutablePublic + <*> blurFieldGrammar L.buildInfo buildInfoFieldGrammar +{-# SPECIALIZE executableFieldGrammar :: UnqualComponentName -> ParsecFieldGrammar' Executable #-} +{-# SPECIALIZE executableFieldGrammar :: UnqualComponentName -> PrettyFieldGrammar' Executable #-} + +------------------------------------------------------------------------------- +-- TestSuite +------------------------------------------------------------------------------- + +-- | An intermediate type just used for parsing the test-suite stanza. +-- After validation it is converted into the proper 'TestSuite' type. +data TestSuiteStanza = TestSuiteStanza + { _testStanzaTestType :: Maybe TestType + , _testStanzaMainIs :: Maybe FilePath + , _testStanzaTestModule :: Maybe ModuleName + , _testStanzaBuildInfo :: BuildInfo + , _testStanzaCodeGenerators :: [String] + } + +instance L.HasBuildInfo TestSuiteStanza where + buildInfo = testStanzaBuildInfo + +testStanzaTestType :: Lens' TestSuiteStanza (Maybe TestType) +testStanzaTestType f s = fmap (\x -> s { _testStanzaTestType = x }) (f (_testStanzaTestType s)) +{-# INLINE testStanzaTestType #-} + +testStanzaMainIs :: Lens' TestSuiteStanza (Maybe FilePath) +testStanzaMainIs f s = fmap (\x -> s { _testStanzaMainIs = x }) (f (_testStanzaMainIs s)) +{-# INLINE testStanzaMainIs #-} + +testStanzaTestModule :: Lens' TestSuiteStanza (Maybe ModuleName) +testStanzaTestModule f s = fmap (\x -> s { _testStanzaTestModule = x }) (f (_testStanzaTestModule s)) +{-# INLINE testStanzaTestModule #-} + +testStanzaBuildInfo :: Lens' TestSuiteStanza BuildInfo +testStanzaBuildInfo f s = fmap (\x -> s { _testStanzaBuildInfo = x }) (f (_testStanzaBuildInfo s)) +{-# INLINE testStanzaBuildInfo #-} + +testStanzaCodeGenerators :: Lens' TestSuiteStanza [String] +testStanzaCodeGenerators f s = fmap (\x -> s { _testStanzaCodeGenerators = x }) (f (_testStanzaCodeGenerators s)) +{-# INLINE testStanzaCodeGenerators #-} + +testSuiteFieldGrammar + :: ( FieldGrammar c g, Applicative (g TestSuiteStanza), Applicative (g BuildInfo) + , c (Identity ModuleName) + , c (Identity TestType) + , c (List CommaFSep (Identity ExeDependency) ExeDependency) + , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) + , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) + , c (List CommaFSep Token String) + , c (List CommaVCat (Identity Dependency) Dependency) + , c (List CommaVCat (Identity Mixin) Mixin) + , c (List FSep (MQuoted Extension) Extension) + , c (List FSep (MQuoted Language) Language) + , c (List FSep FilePathNT String) + , c (List FSep Token String) + , c (List NoCommaFSep Token' String) + , c (List VCat (MQuoted ModuleName) ModuleName) + , c (List VCat FilePathNT String) + , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir)) + , c (List VCat Token String) + , c (MQuoted Language) + ) + => g TestSuiteStanza TestSuiteStanza +testSuiteFieldGrammar = TestSuiteStanza + <$> optionalField "type" testStanzaTestType + <*> optionalFieldAla "main-is" FilePathNT testStanzaMainIs + <*> optionalField "test-module" testStanzaTestModule + <*> blurFieldGrammar testStanzaBuildInfo buildInfoFieldGrammar + <*> monoidalFieldAla "code-generators" (alaList' CommaFSep Token) testStanzaCodeGenerators + ^^^ availableSince CabalSpecV3_8 [] + +validateTestSuite :: CabalSpecVersion -> Position -> TestSuiteStanza -> ParseResult TestSuite +validateTestSuite cabalSpecVersion pos stanza = case testSuiteType of + Nothing -> pure basicTestSuite + + Just tt@(TestTypeUnknown _ _) -> + pure basicTestSuite + { testInterface = TestSuiteUnsupported tt } + + Just tt | tt `notElem` knownTestTypes -> + pure basicTestSuite + { testInterface = TestSuiteUnsupported tt } + + Just tt@(TestTypeExe ver) -> case _testStanzaMainIs stanza of + Nothing -> do + parseFailure pos (missingField "main-is" tt) + pure emptyTestSuite + Just file -> do + when (isJust (_testStanzaTestModule stanza)) $ + parseWarning pos PWTExtraBenchmarkModule (extraField "test-module" tt) + pure basicTestSuite + { testInterface = TestSuiteExeV10 ver file } + + Just tt@(TestTypeLib ver) -> case _testStanzaTestModule stanza of + Nothing -> do + parseFailure pos (missingField "test-module" tt) + pure emptyTestSuite + Just module_ -> do + when (isJust (_testStanzaMainIs stanza)) $ + parseWarning pos PWTExtraMainIs (extraField "main-is" tt) + pure basicTestSuite + { testInterface = TestSuiteLibV09 ver module_ } + + where + testSuiteType = _testStanzaTestType stanza <|> do + guard (cabalSpecVersion >= CabalSpecV3_8) + + testTypeExe <$ _testStanzaMainIs stanza + <|> testTypeLib <$ _testStanzaTestModule stanza + + missingField name tt = "The '" ++ name ++ "' field is required for the " + ++ prettyShow tt ++ " test suite type." + + extraField name tt = "The '" ++ name ++ "' field is not used for the '" + ++ prettyShow tt ++ "' test suite type." + basicTestSuite = + emptyTestSuite { + testBuildInfo = _testStanzaBuildInfo stanza + , testCodeGenerators = _testStanzaCodeGenerators stanza + } + +unvalidateTestSuite :: TestSuite -> TestSuiteStanza +unvalidateTestSuite t = TestSuiteStanza + { _testStanzaTestType = ty + , _testStanzaMainIs = ma + , _testStanzaTestModule = mo + , _testStanzaBuildInfo = testBuildInfo t + , _testStanzaCodeGenerators = testCodeGenerators t + } + where + (ty, ma, mo) = case testInterface t of + TestSuiteExeV10 ver file -> (Just $ TestTypeExe ver, Just file, Nothing) + TestSuiteLibV09 ver modu -> (Just $ TestTypeLib ver, Nothing, Just modu) + _ -> (Nothing, Nothing, Nothing) + +------------------------------------------------------------------------------- +-- Benchmark +------------------------------------------------------------------------------- + +-- | An intermediate type just used for parsing the benchmark stanza. +-- After validation it is converted into the proper 'Benchmark' type. +data BenchmarkStanza = BenchmarkStanza + { _benchmarkStanzaBenchmarkType :: Maybe BenchmarkType + , _benchmarkStanzaMainIs :: Maybe FilePath + , _benchmarkStanzaBenchmarkModule :: Maybe ModuleName + , _benchmarkStanzaBuildInfo :: BuildInfo + } + +instance L.HasBuildInfo BenchmarkStanza where + buildInfo = benchmarkStanzaBuildInfo + +benchmarkStanzaBenchmarkType :: Lens' BenchmarkStanza (Maybe BenchmarkType) +benchmarkStanzaBenchmarkType f s = fmap (\x -> s { _benchmarkStanzaBenchmarkType = x }) (f (_benchmarkStanzaBenchmarkType s)) +{-# INLINE benchmarkStanzaBenchmarkType #-} + +benchmarkStanzaMainIs :: Lens' BenchmarkStanza (Maybe FilePath) +benchmarkStanzaMainIs f s = fmap (\x -> s { _benchmarkStanzaMainIs = x }) (f (_benchmarkStanzaMainIs s)) +{-# INLINE benchmarkStanzaMainIs #-} + +benchmarkStanzaBenchmarkModule :: Lens' BenchmarkStanza (Maybe ModuleName) +benchmarkStanzaBenchmarkModule f s = fmap (\x -> s { _benchmarkStanzaBenchmarkModule = x }) (f (_benchmarkStanzaBenchmarkModule s)) +{-# INLINE benchmarkStanzaBenchmarkModule #-} + +benchmarkStanzaBuildInfo :: Lens' BenchmarkStanza BuildInfo +benchmarkStanzaBuildInfo f s = fmap (\x -> s { _benchmarkStanzaBuildInfo = x }) (f (_benchmarkStanzaBuildInfo s)) +{-# INLINE benchmarkStanzaBuildInfo #-} + +benchmarkFieldGrammar + :: ( FieldGrammar c g, Applicative (g BenchmarkStanza), Applicative (g BuildInfo) + , c (Identity BenchmarkType) + , c (Identity ModuleName) + , c (List CommaFSep (Identity ExeDependency) ExeDependency) + , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) + , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) + , c (List CommaVCat (Identity Dependency) Dependency) + , c (List CommaVCat (Identity Mixin) Mixin) + , c (List FSep (MQuoted Extension) Extension) + , c (List FSep (MQuoted Language) Language) + , c (List FSep FilePathNT String) + , c (List FSep Token String) + , c (List NoCommaFSep Token' String) + , c (List VCat (MQuoted ModuleName) ModuleName) + , c (List VCat FilePathNT String) + , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir)) + , c (List VCat Token String) + , c (MQuoted Language) + ) + => g BenchmarkStanza BenchmarkStanza +benchmarkFieldGrammar = BenchmarkStanza + <$> optionalField "type" benchmarkStanzaBenchmarkType + <*> optionalFieldAla "main-is" FilePathNT benchmarkStanzaMainIs + <*> optionalField "benchmark-module" benchmarkStanzaBenchmarkModule + <*> blurFieldGrammar benchmarkStanzaBuildInfo buildInfoFieldGrammar + +validateBenchmark :: CabalSpecVersion -> Position -> BenchmarkStanza -> ParseResult Benchmark +validateBenchmark cabalSpecVersion pos stanza = case benchmarkStanzaType of + Nothing -> pure emptyBenchmark + { benchmarkBuildInfo = _benchmarkStanzaBuildInfo stanza } + + Just tt@(BenchmarkTypeUnknown _ _) -> pure emptyBenchmark + { benchmarkInterface = BenchmarkUnsupported tt + , benchmarkBuildInfo = _benchmarkStanzaBuildInfo stanza + } + + Just tt | tt `notElem` knownBenchmarkTypes -> pure emptyBenchmark + { benchmarkInterface = BenchmarkUnsupported tt + , benchmarkBuildInfo = _benchmarkStanzaBuildInfo stanza + } + + Just tt@(BenchmarkTypeExe ver) -> case _benchmarkStanzaMainIs stanza of + Nothing -> do + parseFailure pos (missingField "main-is" tt) + pure emptyBenchmark + Just file -> do + when (isJust (_benchmarkStanzaBenchmarkModule stanza)) $ + parseWarning pos PWTExtraBenchmarkModule (extraField "benchmark-module" tt) + pure emptyBenchmark + { benchmarkInterface = BenchmarkExeV10 ver file + , benchmarkBuildInfo = _benchmarkStanzaBuildInfo stanza + } + + where + benchmarkStanzaType = _benchmarkStanzaBenchmarkType stanza <|> do + guard (cabalSpecVersion >= CabalSpecV3_8) + + benchmarkTypeExe <$ _benchmarkStanzaMainIs stanza + + missingField name tt = "The '" ++ name ++ "' field is required for the " + ++ prettyShow tt ++ " benchmark type." + + extraField name tt = "The '" ++ name ++ "' field is not used for the '" + ++ prettyShow tt ++ "' benchmark type." + +unvalidateBenchmark :: Benchmark -> BenchmarkStanza +unvalidateBenchmark b = BenchmarkStanza + { _benchmarkStanzaBenchmarkType = ty + , _benchmarkStanzaMainIs = ma + , _benchmarkStanzaBenchmarkModule = mo + , _benchmarkStanzaBuildInfo = benchmarkBuildInfo b + } + where + (ty, ma, mo) = case benchmarkInterface b of + BenchmarkExeV10 ver "" -> (Just $ BenchmarkTypeExe ver, Nothing, Nothing) + BenchmarkExeV10 ver ma' -> (Just $ BenchmarkTypeExe ver, Just ma', Nothing) + _ -> (Nothing, Nothing, Nothing) + +------------------------------------------------------------------------------- +-- Build info +------------------------------------------------------------------------------- + +buildInfoFieldGrammar + :: ( FieldGrammar c g, Applicative (g BuildInfo) + , c (List CommaFSep (Identity ExeDependency) ExeDependency) + , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) + , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) + , c (List CommaVCat (Identity Dependency) Dependency) + , c (List CommaVCat (Identity Mixin) Mixin) + , c (List FSep (MQuoted Extension) Extension) + , c (List FSep (MQuoted Language) Language) + , c (List FSep FilePathNT String) + , c (List FSep Token String) + , c (List NoCommaFSep Token' String) + , c (List VCat (MQuoted ModuleName) ModuleName) + , c (List VCat FilePathNT String) + , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir)) + , c (List VCat Token String) + , c (MQuoted Language) + ) + => g BuildInfo BuildInfo +buildInfoFieldGrammar = BuildInfo + <$> booleanFieldDef "buildable" L.buildable True + <*> monoidalFieldAla "build-tools" (alaList CommaFSep) L.buildTools + ^^^ deprecatedSince CabalSpecV2_0 + "Please use 'build-tool-depends' field" + ^^^ removedIn CabalSpecV3_0 + "Please use 'build-tool-depends' field." + <*> monoidalFieldAla "build-tool-depends" (alaList CommaFSep) L.buildToolDepends + -- {- ^^^ availableSince [2,0] [] -} + -- here, we explicitly want to recognise build-tool-depends for all Cabal files + -- as otherwise cabal new-build cannot really work. + -- + -- I.e. we don't want trigger unknown field warning + <*> monoidalFieldAla "cpp-options" (alaList' NoCommaFSep Token') L.cppOptions + <*> monoidalFieldAla "asm-options" (alaList' NoCommaFSep Token') L.asmOptions + ^^^ availableSince CabalSpecV3_0 [] + <*> monoidalFieldAla "cmm-options" (alaList' NoCommaFSep Token') L.cmmOptions + ^^^ availableSince CabalSpecV3_0 [] + <*> monoidalFieldAla "cc-options" (alaList' NoCommaFSep Token') L.ccOptions + <*> monoidalFieldAla "cxx-options" (alaList' NoCommaFSep Token') L.cxxOptions + ^^^ availableSince CabalSpecV2_2 [] + <*> monoidalFieldAla "ld-options" (alaList' NoCommaFSep Token') L.ldOptions + <*> monoidalFieldAla "hsc2hs-options" (alaList' NoCommaFSep Token') L.hsc2hsOptions + ^^^ availableSince CabalSpecV3_6 [] + <*> monoidalFieldAla "pkgconfig-depends" (alaList CommaFSep) L.pkgconfigDepends + <*> monoidalFieldAla "frameworks" (alaList' FSep Token) L.frameworks + <*> monoidalFieldAla "extra-framework-dirs" (alaList' FSep FilePathNT) L.extraFrameworkDirs + <*> monoidalFieldAla "asm-sources" (alaList' VCat FilePathNT) L.asmSources + ^^^ availableSince CabalSpecV3_0 [] + <*> monoidalFieldAla "cmm-sources" (alaList' VCat FilePathNT) L.cmmSources + ^^^ availableSince CabalSpecV3_0 [] + <*> monoidalFieldAla "c-sources" (alaList' VCat FilePathNT) L.cSources + <*> monoidalFieldAla "cxx-sources" (alaList' VCat FilePathNT) L.cxxSources + ^^^ availableSince CabalSpecV2_2 [] + <*> monoidalFieldAla "js-sources" (alaList' VCat FilePathNT) L.jsSources + <*> hsSourceDirsGrammar + <*> monoidalFieldAla "other-modules" formatOtherModules L.otherModules + <*> monoidalFieldAla "virtual-modules" (alaList' VCat MQuoted) L.virtualModules + ^^^ availableSince CabalSpecV2_2 [] + <*> monoidalFieldAla "autogen-modules" (alaList' VCat MQuoted) L.autogenModules + ^^^ availableSince CabalSpecV2_0 [] + <*> optionalFieldAla "default-language" MQuoted L.defaultLanguage + ^^^ availableSince CabalSpecV1_10 Nothing + <*> monoidalFieldAla "other-languages" (alaList' FSep MQuoted) L.otherLanguages + ^^^ availableSince CabalSpecV1_10 [] + <*> monoidalFieldAla "default-extensions" (alaList' FSep MQuoted) L.defaultExtensions + ^^^ availableSince CabalSpecV1_10 [] + <*> monoidalFieldAla "other-extensions" formatOtherExtensions L.otherExtensions + ^^^ availableSinceWarn CabalSpecV1_10 + <*> monoidalFieldAla "extensions" (alaList' FSep MQuoted) L.oldExtensions + ^^^ deprecatedSince CabalSpecV1_12 + "Please use 'default-extensions' or 'other-extensions' fields." + ^^^ removedIn CabalSpecV3_0 + "Please use 'default-extensions' or 'other-extensions' fields." + <*> monoidalFieldAla "extra-libraries" (alaList' VCat Token) L.extraLibs + <*> monoidalFieldAla "extra-libraries-static" (alaList' VCat Token) L.extraLibsStatic + ^^^ availableSince CabalSpecV3_8 [] + <*> monoidalFieldAla "extra-ghci-libraries" (alaList' VCat Token) L.extraGHCiLibs + <*> monoidalFieldAla "extra-bundled-libraries" (alaList' VCat Token) L.extraBundledLibs + <*> monoidalFieldAla "extra-library-flavours" (alaList' VCat Token) L.extraLibFlavours + <*> monoidalFieldAla "extra-dynamic-library-flavours" (alaList' VCat Token) L.extraDynLibFlavours + ^^^ availableSince CabalSpecV3_0 [] + <*> monoidalFieldAla "extra-lib-dirs" (alaList' FSep FilePathNT) L.extraLibDirs + <*> monoidalFieldAla "extra-lib-dirs-static" (alaList' FSep FilePathNT) L.extraLibDirsStatic + ^^^ availableSince CabalSpecV3_8 [] + <*> monoidalFieldAla "include-dirs" (alaList' FSep FilePathNT) L.includeDirs + <*> monoidalFieldAla "includes" (alaList' FSep FilePathNT) L.includes + <*> monoidalFieldAla "autogen-includes" (alaList' FSep FilePathNT) L.autogenIncludes + ^^^ availableSince CabalSpecV3_0 [] + <*> monoidalFieldAla "install-includes" (alaList' FSep FilePathNT) L.installIncludes + <*> optionsFieldGrammar + <*> profOptionsFieldGrammar + <*> sharedOptionsFieldGrammar + <*> pure mempty -- static-options ??? + <*> prefixedFields "x-" L.customFieldsBI + <*> monoidalFieldAla "build-depends" formatDependencyList L.targetBuildDepends + <*> monoidalFieldAla "mixins" formatMixinList L.mixins + ^^^ availableSince CabalSpecV2_0 [] +{-# SPECIALIZE buildInfoFieldGrammar :: ParsecFieldGrammar' BuildInfo #-} +{-# SPECIALIZE buildInfoFieldGrammar :: PrettyFieldGrammar' BuildInfo #-} + +hsSourceDirsGrammar + :: ( FieldGrammar c g, Applicative (g BuildInfo) + , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir)) + ) + => g BuildInfo [SymbolicPath PackageDir SourceDir] +hsSourceDirsGrammar = (++) + <$> monoidalFieldAla "hs-source-dirs" formatHsSourceDirs L.hsSourceDirs + <*> monoidalFieldAla "hs-source-dir" (alaList FSep) wrongLens + --- https://github.com/haskell/cabal/commit/49e3cdae3bdf21b017ccd42e66670ca402e22b44 + ^^^ deprecatedSince CabalSpecV1_2 "Please use 'hs-source-dirs'" + ^^^ removedIn CabalSpecV3_0 "Please use 'hs-source-dirs' field." + where + -- TODO: make pretty printer aware of CabalSpecVersion + wrongLens :: Functor f => LensLike' f BuildInfo [SymbolicPath PackageDir SourceDir] + wrongLens f bi = (\fps -> set L.hsSourceDirs fps bi) <$> f [] + +optionsFieldGrammar + :: (FieldGrammar c g, Applicative (g BuildInfo), c (List NoCommaFSep Token' String)) + => g BuildInfo (PerCompilerFlavor [String]) +optionsFieldGrammar = PerCompilerFlavor + <$> monoidalFieldAla "ghc-options" (alaList' NoCommaFSep Token') (extract GHC) + <*> monoidalFieldAla "ghcjs-options" (alaList' NoCommaFSep Token') (extract GHCJS) + -- NOTE: Hugs, NHC and JHC are not supported anymore, but these + -- fields are kept around so that we can still parse legacy .cabal + -- files that have them. + <* knownField "jhc-options" + <* knownField "hugs-options" + <* knownField "nhc98-options" + where + extract :: CompilerFlavor -> ALens' BuildInfo [String] + extract flavor = L.options . lookupLens flavor + +profOptionsFieldGrammar + :: (FieldGrammar c g, Applicative (g BuildInfo), c (List NoCommaFSep Token' String)) + => g BuildInfo (PerCompilerFlavor [String]) +profOptionsFieldGrammar = PerCompilerFlavor + <$> monoidalFieldAla "ghc-prof-options" (alaList' NoCommaFSep Token') (extract GHC) + <*> monoidalFieldAla "ghcjs-prof-options" (alaList' NoCommaFSep Token') (extract GHCJS) + where + extract :: CompilerFlavor -> ALens' BuildInfo [String] + extract flavor = L.profOptions . lookupLens flavor + +sharedOptionsFieldGrammar + :: (FieldGrammar c g, Applicative (g BuildInfo), c (List NoCommaFSep Token' String)) + => g BuildInfo (PerCompilerFlavor [String]) +sharedOptionsFieldGrammar = PerCompilerFlavor + <$> monoidalFieldAla "ghc-shared-options" (alaList' NoCommaFSep Token') (extract GHC) + <*> monoidalFieldAla "ghcjs-shared-options" (alaList' NoCommaFSep Token') (extract GHCJS) + where + extract :: CompilerFlavor -> ALens' BuildInfo [String] + extract flavor = L.sharedOptions . lookupLens flavor + +lookupLens :: (Functor f, Monoid v) => CompilerFlavor -> LensLike' f (PerCompilerFlavor v) v +lookupLens k f p@(PerCompilerFlavor ghc ghcjs) + | k == GHC = (\n -> PerCompilerFlavor n ghcjs) <$> f ghc + | k == GHCJS = (\n -> PerCompilerFlavor ghc n) <$> f ghcjs + | otherwise = p <$ f mempty + +------------------------------------------------------------------------------- +-- Flag +------------------------------------------------------------------------------- + +flagFieldGrammar + :: (FieldGrammar c g, Applicative (g PackageFlag)) + => FlagName -> g PackageFlag PackageFlag +flagFieldGrammar name = MkPackageFlag name + <$> freeTextFieldDef "description" L.flagDescription + <*> booleanFieldDef "default" L.flagDefault True + <*> booleanFieldDef "manual" L.flagManual False +{-# SPECIALIZE flagFieldGrammar :: FlagName -> ParsecFieldGrammar' PackageFlag #-} +{-# SPECIALIZE flagFieldGrammar :: FlagName -> PrettyFieldGrammar' PackageFlag #-} + +------------------------------------------------------------------------------- +-- SourceRepo +------------------------------------------------------------------------------- + +sourceRepoFieldGrammar + :: (FieldGrammar c g, Applicative (g SourceRepo), c (Identity RepoType), c Token, c FilePathNT) + => RepoKind -> g SourceRepo SourceRepo +sourceRepoFieldGrammar kind = SourceRepo kind + <$> optionalField "type" L.repoType + <*> freeTextField "location" L.repoLocation + <*> optionalFieldAla "module" Token L.repoModule + <*> optionalFieldAla "branch" Token L.repoBranch + <*> optionalFieldAla "tag" Token L.repoTag + <*> optionalFieldAla "subdir" FilePathNT L.repoSubdir +{-# SPECIALIZE sourceRepoFieldGrammar :: RepoKind -> ParsecFieldGrammar' SourceRepo #-} +{-# SPECIALIZE sourceRepoFieldGrammar :: RepoKind -> PrettyFieldGrammar' SourceRepo #-} + +------------------------------------------------------------------------------- +-- SetupBuildInfo +------------------------------------------------------------------------------- + +setupBInfoFieldGrammar + :: (FieldGrammar c g, Functor (g SetupBuildInfo), c (List CommaVCat (Identity Dependency) Dependency)) + => Bool -> g SetupBuildInfo SetupBuildInfo +setupBInfoFieldGrammar def = flip SetupBuildInfo def + <$> monoidalFieldAla "setup-depends" (alaList CommaVCat) L.setupDepends +{-# SPECIALIZE setupBInfoFieldGrammar :: Bool -> ParsecFieldGrammar' SetupBuildInfo #-} +{-# SPECIALIZE setupBInfoFieldGrammar :: Bool -> PrettyFieldGrammar' SetupBuildInfo #-} + +------------------------------------------------------------------------------- +-- Define how field values should be formatted for 'pretty'. +------------------------------------------------------------------------------- + +formatDependencyList :: [Dependency] -> List CommaVCat (Identity Dependency) Dependency +formatDependencyList = alaList CommaVCat + +formatMixinList :: [Mixin] -> List CommaVCat (Identity Mixin) Mixin +formatMixinList = alaList CommaVCat + +formatExtraSourceFiles :: [FilePath] -> List VCat FilePathNT FilePath +formatExtraSourceFiles = alaList' VCat FilePathNT + +formatExposedModules :: [ModuleName] -> List VCat (MQuoted ModuleName) ModuleName +formatExposedModules = alaList' VCat MQuoted + +formatHsSourceDirs :: [SymbolicPath PackageDir SourceDir] -> List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir) +formatHsSourceDirs = alaList FSep + +formatOtherExtensions :: [Extension] -> List FSep (MQuoted Extension) Extension +formatOtherExtensions = alaList' FSep MQuoted + +formatOtherModules :: [ModuleName] -> List VCat (MQuoted ModuleName) ModuleName +formatOtherModules = alaList' VCat MQuoted + +------------------------------------------------------------------------------- +-- newtypes +------------------------------------------------------------------------------- + +-- | Compat FilePath accepts empty file path, +-- but issues a warning. +-- +-- There are simply too many (~1200) package definition files +-- +-- @ +-- license-file: "" +-- @ +-- +-- and +-- +-- @ +-- data-dir: "" +-- @ +-- +-- across Hackage to outrule them completely. +-- I suspect some of them are generated (e.g. formatted) by machine. +-- +newtype CompatFilePath = CompatFilePath { getCompatFilePath :: FilePath } -- TODO: Change to use SymPath + +instance Newtype String CompatFilePath + +instance Parsec CompatFilePath where + parsec = do + token <- parsecToken + if null token + then do + parsecWarning PWTEmptyFilePath "empty FilePath" + return (CompatFilePath "") + else return (CompatFilePath token) + +instance Pretty CompatFilePath where + pretty = showToken . getCompatFilePath + +newtype CompatLicenseFile = CompatLicenseFile { getCompatLicenseFile :: [SymbolicPath PackageDir LicenseFile] } + +instance Newtype [SymbolicPath PackageDir LicenseFile] CompatLicenseFile + +-- TODO +instance Parsec CompatLicenseFile where + parsec = emptyToken <|> CompatLicenseFile . unpack' (alaList FSep) <$> parsec + where + emptyToken = P.try $ do + token <- parsecToken + if null token + then return (CompatLicenseFile []) + else P.unexpected "non-empty-token" + +instance Pretty CompatLicenseFile where + pretty = pretty . pack' (alaList FSep) . getCompatLicenseFile + +------------------------------------------------------------------------------- +-- vim syntax definitions +------------------------------------------------------------------------------- + +-- | '_syntaxFieldNames' and '_syntaxExtensions' +-- are for generating VIM syntax file definitions. +-- +_syntaxFieldNames :: IO () +_syntaxFieldNames = sequence_ + [ BS8.putStrLn $ " \\ " <> n + | n <- nub $ sort $ mconcat + [ fieldGrammarKnownFieldList packageDescriptionFieldGrammar + , fieldGrammarKnownFieldList $ libraryFieldGrammar LMainLibName + , fieldGrammarKnownFieldList $ executableFieldGrammar "exe" + , fieldGrammarKnownFieldList $ foreignLibFieldGrammar "flib" + , fieldGrammarKnownFieldList testSuiteFieldGrammar + , fieldGrammarKnownFieldList benchmarkFieldGrammar + , fieldGrammarKnownFieldList $ flagFieldGrammar (error "flagname") + , fieldGrammarKnownFieldList $ sourceRepoFieldGrammar (error "repokind") + , fieldGrammarKnownFieldList $ setupBInfoFieldGrammar True + ] + ] + +_syntaxExtensions :: IO () +_syntaxExtensions = sequence_ + [ putStrLn $ " \\ " <> e + | e <- ["Safe","Trustworthy","Unsafe"] + ++ es + ++ map ("No"++) es + ] + where + es = nub $ sort + [ prettyShow e + | e <- [ minBound .. maxBound ] + , e `notElem` [Safe,Unsafe,Trustworthy] + ] diff --git a/cabal/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs b/cabal/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs @@ -0,0 +1,980 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.PackageDescription.Parsec +-- Copyright : Isaac Jones 2003-2005 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This defined parsers and partial pretty printers for the @.cabal@ format. + +module Distribution.PackageDescription.Parsec ( + -- * Package descriptions + parseGenericPackageDescription, + parseGenericPackageDescriptionMaybe, + + -- ** Parsing + ParseResult, + runParseResult, + + -- * New-style spec-version + scanSpecVersion, + + -- ** Supplementary build information + parseHookedBuildInfo, + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Control.Monad.State.Strict (StateT, execStateT) +import Control.Monad.Trans.Class (lift) +import Distribution.CabalSpecVersion +import Distribution.Compat.Lens +import Distribution.FieldGrammar +import Distribution.FieldGrammar.Parsec (NamelessField (..)) +import Distribution.Fields.ConfVar (parseConditionConfVar) +import Distribution.Fields.Field (FieldName, getName) +import Distribution.Fields.LexerMonad (LexWarning, toPWarnings) +import Distribution.Fields.Parser +import Distribution.Fields.ParseResult +import Distribution.PackageDescription +import Distribution.PackageDescription.Configuration (freeVars, transformAllBuildInfos) +import Distribution.PackageDescription.FieldGrammar +import Distribution.PackageDescription.Quirks (patchQuirks) +import Distribution.Parsec (parsec, simpleParsecBS) +import Distribution.Parsec.FieldLineStream (fieldLineStreamFromBS) +import Distribution.Parsec.Position (Position (..), zeroPos) +import Distribution.Parsec.Warning (PWarnType (..)) +import Distribution.Pretty (prettyShow) +import Distribution.Utils.Generic (breakMaybe, fromUTF8BS, toUTF8BS, unfoldrM, validateUTF8) +import Distribution.Version (Version, mkVersion, versionNumbers) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified Distribution.Compat.Newtype as Newtype +import qualified Distribution.Compat.NonEmptySet as NES +import qualified Distribution.Types.BuildInfo.Lens as L +import qualified Distribution.Types.Executable.Lens as L +import qualified Distribution.Types.ForeignLib.Lens as L +import qualified Distribution.Types.GenericPackageDescription.Lens as L +import qualified Distribution.Types.PackageDescription.Lens as L +import qualified Distribution.Types.SetupBuildInfo.Lens as L +import qualified Text.Parsec as P + +------------------------------------------------------------------------------ +-- | Parses the given file into a 'GenericPackageDescription'. +-- +-- In Cabal 1.2 the syntax for package descriptions was changed to a format +-- with sections and possibly indented property descriptions. +-- +parseGenericPackageDescription :: BS.ByteString -> ParseResult GenericPackageDescription +parseGenericPackageDescription bs = do + -- set scanned version + setCabalSpecVersion ver + + csv <- case ver of + -- if we get too new version, fail right away + Just v -> case cabalSpecFromVersionDigits (versionNumbers v) of + Just csv -> return (Just csv) + Nothing -> parseFatalFailure zeroPos $ + "Unsupported cabal-version " ++ prettyShow v ++ ". See https://github.com/haskell/cabal/issues/4899." + _ -> pure Nothing + + case readFields' bs'' of + Right (fs, lexWarnings) -> do + when patched $ + parseWarning zeroPos PWTQuirkyCabalFile "Legacy cabal file" + -- UTF8 is validated in a prepass step, afterwards parsing is lenient. + parseGenericPackageDescription' csv lexWarnings invalidUtf8 fs + -- TODO: better marshalling of errors + Left perr -> parseFatalFailure pos (show perr) where + ppos = P.errorPos perr + pos = Position (P.sourceLine ppos) (P.sourceColumn ppos) + where + (patched, bs') = patchQuirks bs + ver = scanSpecVersion bs' + + invalidUtf8 = validateUTF8 bs' + + -- if there are invalid utf8 characters, we make the bytestring valid. + bs'' = case invalidUtf8 of + Nothing -> bs' + Just _ -> toUTF8BS (fromUTF8BS bs') + + +-- | 'Maybe' variant of 'parseGenericPackageDescription' +parseGenericPackageDescriptionMaybe :: BS.ByteString -> Maybe GenericPackageDescription +parseGenericPackageDescriptionMaybe = + either (const Nothing) Just . snd . runParseResult . parseGenericPackageDescription + +fieldlinesToBS :: [FieldLine ann] -> BS.ByteString +fieldlinesToBS = BS.intercalate "\n" . map (\(FieldLine _ bs) -> bs) + +-- Monad in which sections are parsed +type SectionParser = StateT SectionS ParseResult + +-- | State of section parser +data SectionS = SectionS + { _stateGpd :: !GenericPackageDescription + , _stateCommonStanzas :: !(Map String CondTreeBuildInfo) + } + +stateGpd :: Lens' SectionS GenericPackageDescription +stateGpd f (SectionS gpd cs) = (\x -> SectionS x cs) <$> f gpd +{-# INLINE stateGpd #-} + +stateCommonStanzas :: Lens' SectionS (Map String CondTreeBuildInfo) +stateCommonStanzas f (SectionS gpd cs) = SectionS gpd <$> f cs +{-# INLINE stateCommonStanzas #-} + +-- Note [Accumulating parser] +-- +-- This parser has two "states": +-- * first we parse fields of PackageDescription +-- * then we parse sections (libraries, executables, etc) +parseGenericPackageDescription' + :: Maybe CabalSpecVersion + -> [LexWarning] + -> Maybe Int + -> [Field Position] + -> ParseResult GenericPackageDescription +parseGenericPackageDescription' scannedVer lexWarnings utf8WarnPos fs = do + parseWarnings (toPWarnings lexWarnings) + for_ utf8WarnPos $ \pos -> + parseWarning zeroPos PWTUTF $ "UTF8 encoding problem at byte offset " ++ show pos + let (syntax, fs') = sectionizeFields fs + let (fields, sectionFields) = takeFields fs' + + -- cabal-version + specVer <- case scannedVer of + Just v -> return v + Nothing -> case Map.lookup "cabal-version" fields >>= safeLast of + Nothing -> return CabalSpecV1_0 + Just (MkNamelessField pos fls) -> do + -- version will be parsed twice, therefore we parse without warnings. + v <- withoutWarnings $ + Newtype.unpack' SpecVersion <$> + -- Use version with || and && but before addition of ^>= and removal of -any + runFieldParser pos parsec CabalSpecV1_24 fls + + -- if it were at the beginning, scanner would found it + when (v >= CabalSpecV2_2) $ parseFailure pos $ + "cabal-version should be at the beginning of the file starting with spec version 2.2. " ++ + "See https://github.com/haskell/cabal/issues/4899" + + return v + + -- reset cabal version, it might not be set + let specVer' = mkVersion (cabalSpecToVersionDigits specVer) + setCabalSpecVersion (Just specVer') + + -- Package description + pd <- parseFieldGrammar specVer fields packageDescriptionFieldGrammar + + -- Check that scanned and parsed versions match. + unless (specVer == specVersion pd) $ parseFailure zeroPos $ + "Scanned and parsed cabal-versions don't match " ++ + prettyShow (SpecVersion specVer) ++ " /= " ++ prettyShow (SpecVersion (specVersion pd)) + + maybeWarnCabalVersion syntax pd + + -- Sections + let gpd = emptyGenericPackageDescription + & L.packageDescription .~ pd + gpd1 <- view stateGpd <$> execStateT (goSections specVer sectionFields) (SectionS gpd Map.empty) + + let gpd2 = postProcessInternalDeps specVer gpd1 + checkForUndefinedFlags gpd2 + checkForUndefinedCustomSetup gpd2 + -- See nothunks test, without this deepseq we get (at least): + -- Thunk in ThunkInfo {thunkContext = ["PackageIdentifier","PackageDescription","GenericPackageDescription"]} + -- + -- TODO: re-benchmark, whether `deepseq` is important (both cabal-benchmarks and solver-benchmarks) + -- TODO: remove the need for deepseq if `deepseq` in fact matters + -- NOTE: IIRC it does affect (maximal) memory usage, which causes less GC pressure + gpd2 `deepseq` return gpd2 + where + safeLast :: [a] -> Maybe a + safeLast = listToMaybe . reverse + + newSyntaxVersion :: CabalSpecVersion + newSyntaxVersion = CabalSpecV1_2 + + maybeWarnCabalVersion :: Syntax -> PackageDescription -> ParseResult () + maybeWarnCabalVersion syntax pkg + | syntax == NewSyntax && specVersion pkg < newSyntaxVersion + = parseWarning zeroPos PWTNewSyntax $ + "A package using section syntax must specify at least\n" + ++ "'cabal-version: >= 1.2'." + + maybeWarnCabalVersion syntax pkg + | syntax == OldSyntax && specVersion pkg >= newSyntaxVersion + = parseWarning zeroPos PWTOldSyntax $ + "A package using 'cabal-version: " + ++ prettyShow (SpecVersion (specVersion pkg)) + ++ "' must use section syntax. See the Cabal user guide for details." + + maybeWarnCabalVersion _ _ = return () + +goSections :: CabalSpecVersion -> [Field Position] -> SectionParser () +goSections specVer = traverse_ process + where + process (Field (Name pos name) _) = + lift $ parseWarning pos PWTTrailingFields $ + "Ignoring trailing fields after sections: " ++ show name + process (Section name args secFields) = + parseSection name args secFields + + snoc x xs = xs ++ [x] + + hasCommonStanzas = specHasCommonStanzas specVer + + -- we need signature, because this is polymorphic, but not-closed + parseCondTree' + :: L.HasBuildInfo a + => ParsecFieldGrammar' a -- ^ grammar + -> (BuildInfo -> a) + -> Map String CondTreeBuildInfo -- ^ common stanzas + -> [Field Position] + -> ParseResult (CondTree ConfVar [Dependency] a) + parseCondTree' = parseCondTreeWithCommonStanzas specVer + + parseSection :: Name Position -> [SectionArg Position] -> [Field Position] -> SectionParser () + parseSection (Name pos name) args fields + | hasCommonStanzas == NoCommonStanzas, name == "common" = lift $ do + parseWarning pos PWTUnknownSection $ "Ignoring section: common. You should set cabal-version: 2.2 or larger to use common stanzas." + + | name == "common" = do + commonStanzas <- use stateCommonStanzas + name' <- lift $ parseCommonName pos args + biTree <- lift $ parseCondTree' buildInfoFieldGrammar id commonStanzas fields + + case Map.lookup name' commonStanzas of + Nothing -> stateCommonStanzas .= Map.insert name' biTree commonStanzas + Just _ -> lift $ parseFailure pos $ + "Duplicate common stanza: " ++ name' + + | name == "library" && null args = do + prev <- use $ stateGpd . L.condLibrary + when (isJust prev) $ lift $ parseFailure pos $ + "Multiple main libraries; have you forgotten to specify a name for an internal library?" + + commonStanzas <- use stateCommonStanzas + let name'' = LMainLibName + lib <- lift $ parseCondTree' (libraryFieldGrammar name'') (libraryFromBuildInfo name'') commonStanzas fields + -- + -- TODO check that not set + stateGpd . L.condLibrary ?= lib + + -- Sublibraries + -- TODO: check cabal-version + | name == "library" = do + commonStanzas <- use stateCommonStanzas + name' <- parseUnqualComponentName pos args + let name'' = LSubLibName name' + lib <- lift $ parseCondTree' (libraryFieldGrammar name'') (libraryFromBuildInfo name'') commonStanzas fields + -- TODO check duplicate name here? + stateGpd . L.condSubLibraries %= snoc (name', lib) + + -- TODO: check cabal-version + | name == "foreign-library" = do + commonStanzas <- use stateCommonStanzas + name' <- parseUnqualComponentName pos args + flib <- lift $ parseCondTree' (foreignLibFieldGrammar name') (fromBuildInfo' name') commonStanzas fields + + let hasType ts = foreignLibType ts /= foreignLibType mempty + unless (onAllBranches hasType flib) $ lift $ parseFailure pos $ concat + [ "Foreign library " ++ show (prettyShow name') + , " is missing required field \"type\" or the field " + , "is not present in all conditional branches. The " + , "available test types are: " + , intercalate ", " (map prettyShow knownForeignLibTypes) + ] + + -- TODO check duplicate name here? + stateGpd . L.condForeignLibs %= snoc (name', flib) + + | name == "executable" = do + commonStanzas <- use stateCommonStanzas + name' <- parseUnqualComponentName pos args + exe <- lift $ parseCondTree' (executableFieldGrammar name') (fromBuildInfo' name') commonStanzas fields + -- TODO check duplicate name here? + stateGpd . L.condExecutables %= snoc (name', exe) + + | name == "test-suite" = do + commonStanzas <- use stateCommonStanzas + name' <- parseUnqualComponentName pos args + testStanza <- lift $ parseCondTree' testSuiteFieldGrammar (fromBuildInfo' name') commonStanzas fields + testSuite <- lift $ traverse (validateTestSuite specVer pos) testStanza + + let hasType ts = testInterface ts /= testInterface mempty + unless (onAllBranches hasType testSuite) $ lift $ parseFailure pos $ concat + [ "Test suite " ++ show (prettyShow name') + + , concat $ case specVer of + v | v >= CabalSpecV3_8 -> + [ " is missing required field \"main-is\" or the field " + , "is not present in all conditional branches." + ] + _ -> + [ " is missing required field \"type\" or the field " + , "is not present in all conditional branches. The " + , "available test types are: " + , intercalate ", " (map prettyShow knownTestTypes) + ] + ] + + -- TODO check duplicate name here? + stateGpd . L.condTestSuites %= snoc (name', testSuite) + + | name == "benchmark" = do + commonStanzas <- use stateCommonStanzas + name' <- parseUnqualComponentName pos args + benchStanza <- lift $ parseCondTree' benchmarkFieldGrammar (fromBuildInfo' name') commonStanzas fields + bench <- lift $ traverse (validateBenchmark specVer pos) benchStanza + + let hasType ts = benchmarkInterface ts /= benchmarkInterface mempty + unless (onAllBranches hasType bench) $ lift $ parseFailure pos $ concat + [ "Benchmark " ++ show (prettyShow name') + , concat $ case specVer of + v | v >= CabalSpecV3_8 -> + [ " is missing required field \"main-is\" or the field " + , "is not present in all conditional branches." + ] + _ -> + [ " is missing required field \"type\" or the field " + , "is not present in all conditional branches. The " + , "available benchmark types are: " + , intercalate ", " (map prettyShow knownBenchmarkTypes) + ] + ] + + -- TODO check duplicate name here? + stateGpd . L.condBenchmarks %= snoc (name', bench) + + | name == "flag" = do + name' <- parseNameBS pos args + name'' <- lift $ runFieldParser' [pos] parsec specVer (fieldLineStreamFromBS name') `recoverWith` mkFlagName "" + flag <- lift $ parseFields specVer fields (flagFieldGrammar name'') + -- Check default flag + stateGpd . L.genPackageFlags %= snoc flag + + | name == "custom-setup" && null args = do + sbi <- lift $ parseFields specVer fields (setupBInfoFieldGrammar False) + stateGpd . L.packageDescription . L.setupBuildInfo ?= sbi + + | name == "source-repository" = do + kind <- lift $ case args of + [SecArgName spos secName] -> + runFieldParser' [spos] parsec specVer (fieldLineStreamFromBS secName) `recoverWith` RepoHead + [] -> do + parseFailure pos "'source-repository' requires exactly one argument" + pure RepoHead + _ -> do + parseFailure pos $ "Invalid source-repository kind " ++ show args + pure RepoHead + + sr <- lift $ parseFields specVer fields (sourceRepoFieldGrammar kind) + stateGpd . L.packageDescription . L.sourceRepos %= snoc sr + + | otherwise = lift $ + parseWarning pos PWTUnknownSection $ "Ignoring section: " ++ show name + +parseName :: Position -> [SectionArg Position] -> SectionParser String +parseName pos args = fromUTF8BS <$> parseNameBS pos args + +parseNameBS :: Position -> [SectionArg Position] -> SectionParser BS.ByteString +-- TODO: use strict parser +parseNameBS pos args = case args of + [SecArgName _pos secName] -> + pure secName + [SecArgStr _pos secName] -> + pure secName + [] -> do + lift $ parseFailure pos "name required" + pure "" + _ -> do + -- TODO: pretty print args + lift $ parseFailure pos $ "Invalid name " ++ show args + pure "" + +parseCommonName :: Position -> [SectionArg Position] -> ParseResult String +parseCommonName pos args = case args of + [SecArgName _pos secName] -> + pure $ fromUTF8BS secName + [SecArgStr _pos secName] -> + pure $ fromUTF8BS secName + [] -> do + parseFailure pos $ "name required" + pure "" + _ -> do + -- TODO: pretty print args + parseFailure pos $ "Invalid name " ++ show args + pure "" + +-- TODO: avoid conversion to 'String'. +parseUnqualComponentName :: Position -> [SectionArg Position] -> SectionParser UnqualComponentName +parseUnqualComponentName pos args = mkUnqualComponentName <$> parseName pos args + +-- | Parse a non-recursive list of fields. +parseFields + :: CabalSpecVersion + -> [Field Position] -- ^ fields to be parsed + -> ParsecFieldGrammar' a + -> ParseResult a +parseFields v fields grammar = do + let (fs0, ss) = partitionFields fields + traverse_ (traverse_ warnInvalidSubsection) ss + parseFieldGrammar v fs0 grammar + +warnInvalidSubsection :: Section Position -> ParseResult () +warnInvalidSubsection (MkSection (Name pos name) _ _) = + void $ parseFailure pos $ "invalid subsection " ++ show name + +parseCondTree + :: forall a. L.HasBuildInfo a + => CabalSpecVersion + -> HasElif -- ^ accept @elif@ + -> ParsecFieldGrammar' a -- ^ grammar + -> Map String CondTreeBuildInfo -- ^ common stanzas + -> (BuildInfo -> a) -- ^ constructor from buildInfo + -> (a -> [Dependency]) -- ^ condition extractor + -> [Field Position] + -> ParseResult (CondTree ConfVar [Dependency] a) +parseCondTree v hasElif grammar commonStanzas fromBuildInfo cond = go + where + go fields0 = do + (fields, endo) <- + if v >= CabalSpecV3_0 + then processImports v fromBuildInfo commonStanzas fields0 + else traverse (warnImport v) fields0 >>= \fields1 -> return (catMaybes fields1, id) + + let (fs, ss) = partitionFields fields + x <- parseFieldGrammar v fs grammar + branches <- concat <$> traverse parseIfs ss + return $ endo $ CondNode x (cond x) branches + + parseIfs :: [Section Position] -> ParseResult [CondBranch ConfVar [Dependency] a] + parseIfs [] = return [] + parseIfs (MkSection (Name _ name) test fields : sections) | name == "if" = do + test' <- parseConditionConfVar test + fields' <- go fields + (elseFields, sections') <- parseElseIfs sections + return (CondBranch test' fields' elseFields : sections') + parseIfs (MkSection (Name pos name) _ _ : sections) = do + parseWarning pos PWTInvalidSubsection $ "invalid subsection " ++ show name + parseIfs sections + + parseElseIfs + :: [Section Position] + -> ParseResult (Maybe (CondTree ConfVar [Dependency] a), [CondBranch ConfVar [Dependency] a]) + parseElseIfs [] = return (Nothing, []) + parseElseIfs (MkSection (Name pos name) args fields : sections) | name == "else" = do + unless (null args) $ + parseFailure pos $ "`else` section has section arguments " ++ show args + elseFields <- go fields + sections' <- parseIfs sections + return (Just elseFields, sections') + + parseElseIfs (MkSection (Name _ name) test fields : sections) | hasElif == HasElif, name == "elif" = do + test' <- parseConditionConfVar test + fields' <- go fields + (elseFields, sections') <- parseElseIfs sections + -- we parse an empty 'Fields', to get empty value for a node + a <- parseFieldGrammar v mempty grammar + return (Just $ CondNode a (cond a) [CondBranch test' fields' elseFields], sections') + + parseElseIfs (MkSection (Name pos name) _ _ : sections) | name == "elif" = do + parseWarning pos PWTInvalidSubsection $ "invalid subsection \"elif\". You should set cabal-version: 2.2 or larger to use elif-conditionals." + (,) Nothing <$> parseIfs sections + + parseElseIfs sections = (,) Nothing <$> parseIfs sections + +{- Note [Accumulating parser] + +Note: Outdated a bit + +In there parser, @'FieldDescr' a@ is transformed into @Map FieldName (a -> +FieldParser a)@. The weird value is used because we accumulate structure of +@a@ by folding over the fields. There are various reasons for that: + +* Almost all fields are optional + +* This is simple approach so declarative bi-directional format (parsing and +printing) of structure could be specified (list of @'FieldDescr' a@) + +* There are surface syntax fields corresponding to single field in the file: + @license-file@ and @license-files@ + +* This is quite safe approach. + +When/if we re-implement the parser to support formatting preservging roundtrip +with new AST, this all need to be rewritten. +-} + +------------------------------------------------------------------------------- +-- Common stanzas +------------------------------------------------------------------------------- + +-- $commonStanzas +-- +-- [Note: Common stanzas] +-- +-- In Cabal 2.2 we support simple common stanzas: +-- +-- * Commons stanzas define 'BuildInfo' +-- +-- * import "fields" can only occur at top of other stanzas (think: imports) +-- +-- In particular __there aren't__ +-- +-- * implicit stanzas +-- +-- * More specific common stanzas (executable, test-suite). +-- +-- +-- The approach uses the fact that 'BuildInfo' is a 'Monoid': +-- +-- @ +-- mergeCommonStanza' :: HasBuildInfo comp => BuildInfo -> comp -> comp +-- mergeCommonStanza' bi = over L.BuildInfo (bi <>) +-- @ +-- +-- Real 'mergeCommonStanza' is more complicated as we have to deal with +-- conditional trees. +-- +-- The approach is simple, and have good properties: +-- +-- * Common stanzas are parsed exactly once, even if not-used. Thus we report errors in them. +-- +type CondTreeBuildInfo = CondTree ConfVar [Dependency] BuildInfo + +-- | Create @a@ from 'BuildInfo'. +-- This class is used to implement common stanza parsing. +-- +-- Law: @view buildInfo . fromBuildInfo = id@ +-- +-- This takes name, as 'FieldGrammar's take names too. +class L.HasBuildInfo a => FromBuildInfo a where + fromBuildInfo' :: UnqualComponentName -> BuildInfo -> a + +libraryFromBuildInfo :: LibraryName -> BuildInfo -> Library +libraryFromBuildInfo n bi = emptyLibrary + { libName = n + , libVisibility = case n of + LMainLibName -> LibraryVisibilityPublic + LSubLibName _ -> LibraryVisibilityPrivate + , libBuildInfo = bi + } + +instance FromBuildInfo BuildInfo where fromBuildInfo' _ = id +instance FromBuildInfo ForeignLib where fromBuildInfo' n bi = set L.foreignLibName n $ set L.buildInfo bi emptyForeignLib +instance FromBuildInfo Executable where fromBuildInfo' n bi = set L.exeName n $ set L.buildInfo bi emptyExecutable + +instance FromBuildInfo TestSuiteStanza where + fromBuildInfo' _ bi = TestSuiteStanza Nothing Nothing Nothing bi [] + +instance FromBuildInfo BenchmarkStanza where + fromBuildInfo' _ bi = BenchmarkStanza Nothing Nothing Nothing bi + +parseCondTreeWithCommonStanzas + :: forall a. L.HasBuildInfo a + => CabalSpecVersion + -> ParsecFieldGrammar' a -- ^ grammar + -> (BuildInfo -> a) -- ^ construct fromBuildInfo + -> Map String CondTreeBuildInfo -- ^ common stanzas + -> [Field Position] + -> ParseResult (CondTree ConfVar [Dependency] a) +parseCondTreeWithCommonStanzas v grammar fromBuildInfo commonStanzas fields = do + (fields', endo) <- processImports v fromBuildInfo commonStanzas fields + x <- parseCondTree v hasElif grammar commonStanzas fromBuildInfo (view L.targetBuildDepends) fields' + return (endo x) + where + hasElif = specHasElif v + +processImports + :: forall a. L.HasBuildInfo a + => CabalSpecVersion + -> (BuildInfo -> a) -- ^ construct fromBuildInfo + -> Map String CondTreeBuildInfo -- ^ common stanzas + -> [Field Position] + -> ParseResult ([Field Position], CondTree ConfVar [Dependency] a -> CondTree ConfVar [Dependency] a) +processImports v fromBuildInfo commonStanzas = go [] + where + hasCommonStanzas = specHasCommonStanzas v + + getList' :: List CommaFSep Token String -> [String] + getList' = Newtype.unpack + + go acc (Field (Name pos name) _ : fields) | name == "import", hasCommonStanzas == NoCommonStanzas = do + parseWarning pos PWTUnknownField "Unknown field: import. You should set cabal-version: 2.2 or larger to use common stanzas" + go acc fields + -- supported: + go acc (Field (Name pos name) fls : fields) | name == "import" = do + names <- getList' <$> runFieldParser pos parsec v fls + names' <- for names $ \commonName -> + case Map.lookup commonName commonStanzas of + Nothing -> do + parseFailure pos $ "Undefined common stanza imported: " ++ commonName + pure Nothing + Just commonTree -> + pure (Just commonTree) + + go (acc ++ catMaybes names') fields + + -- parse actual CondTree + go acc fields = do + fields' <- catMaybes <$> traverse (warnImport v) fields + pure $ (fields', \x -> foldr (mergeCommonStanza fromBuildInfo) x acc) + +-- | Warn on "import" fields, also map to Maybe, so errorneous fields can be filtered +warnImport :: CabalSpecVersion -> Field Position -> ParseResult (Maybe (Field Position)) +warnImport v (Field (Name pos name) _) | name == "import" = do + if specHasCommonStanzas v == NoCommonStanzas + then parseWarning pos PWTUnknownField "Unknown field: import. You should set cabal-version: 2.2 or larger to use common stanzas" + else parseWarning pos PWTUnknownField "Unknown field: import. Common stanza imports should be at the top of the enclosing section" + return Nothing +warnImport _ f = pure (Just f) + +mergeCommonStanza + :: L.HasBuildInfo a + => (BuildInfo -> a) + -> CondTree ConfVar [Dependency] BuildInfo + -> CondTree ConfVar [Dependency] a + -> CondTree ConfVar [Dependency] a +mergeCommonStanza fromBuildInfo (CondNode bi _ bis) (CondNode x _ cs) = + CondNode x' (x' ^. L.targetBuildDepends) cs' + where + -- new value is old value with buildInfo field _prepended_. + x' = x & L.buildInfo %~ (bi <>) + + -- tree components are appended together. + cs' = map (fmap fromBuildInfo) bis ++ cs + +------------------------------------------------------------------------------- +-- Branches +------------------------------------------------------------------------------- + +-- Check that a property holds on all branches of a condition tree +onAllBranches :: forall v c a. Monoid a => (a -> Bool) -> CondTree v c a -> Bool +onAllBranches p = go mempty + where + -- If the current level of the tree satisfies the property, then we are + -- done. If not, then one of the conditional branches below the current node + -- must satisfy it. Each node may have multiple immediate children; we only + -- one need one to satisfy the property because the configure step uses + -- 'mappend' to join together the results of flag resolution. + go :: a -> CondTree v c a -> Bool + go acc ct = let acc' = acc `mappend` condTreeData ct + in p acc' || any (goBranch acc') (condTreeComponents ct) + + -- Both the 'true' and the 'false' block must satisfy the property. + goBranch :: a -> CondBranch v c a -> Bool + goBranch _ (CondBranch _ _ Nothing) = False + goBranch acc (CondBranch _ t (Just e)) = go acc t && go acc e + +------------------------------------------------------------------------------- +-- Post parsing checks +------------------------------------------------------------------------------- + +-- | Check that we +-- +-- * don't use undefined flags (very bad) +-- * define flags which are unused (just bad) +-- +checkForUndefinedFlags :: GenericPackageDescription -> ParseResult () +checkForUndefinedFlags gpd = do + let definedFlags, usedFlags :: Set.Set FlagName + definedFlags = toSetOf (L.genPackageFlags . traverse . getting flagName) gpd + usedFlags = getConst $ L.allCondTrees f gpd + + -- Note: we can check for defined, but unused flags here too. + unless (usedFlags `Set.isSubsetOf` definedFlags) $ parseFailure zeroPos $ + "These flags are used without having been defined: " ++ + intercalate ", " [ unFlagName fn | fn <- Set.toList $ usedFlags `Set.difference` definedFlags ] + where + f :: CondTree ConfVar c a -> Const (Set.Set FlagName) (CondTree ConfVar c a) + f ct = Const (Set.fromList (freeVars ct)) + +-- | Since @cabal-version: 1.24@ one can specify @custom-setup@. +-- Let us require it. +-- +checkForUndefinedCustomSetup :: GenericPackageDescription -> ParseResult () +checkForUndefinedCustomSetup gpd = do + let pd = packageDescription gpd + let csv = specVersion pd + + when (buildType pd == Custom && isNothing (setupBuildInfo pd)) $ + when (csv >= CabalSpecV1_24) $ parseFailure zeroPos $ + "Since cabal-version: 1.24 specifying custom-setup section is mandatory" + +------------------------------------------------------------------------------- +-- Post processing of internal dependencies +------------------------------------------------------------------------------- + +-- Note [Dependencies on sublibraries] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- This is solution to https://github.com/haskell/cabal/issues/6083 +-- +-- Before 'cabal-version: 3.0' we didn't have a syntax specially +-- for referring to internal libraries. Internal library names +-- shadowed the outside ones. +-- +-- Since 'cabal-version: 3.0' we have ability to write +-- +-- build-depends: some-package:its-sub-lib >=1.2.3 +-- +-- This allows us to refer also to local packages by `this-package:sublib`. +-- So since 'cabal-version: 3.4' to refer to *any* +-- sublibrary we must use the two part syntax. Here's small table: +-- +-- | pre-3.4 | 3.4 and after | +-- ------------------|---------------------|-------------------------------| +-- pkg-name | may refer to sublib | always refers to external pkg | +-- pkg-name:sublib | refers to sublib | refers to sublib | +-- pkg-name:pkg-name | may refer to sublib | always refers to external pkg | +-- +-- In pre-3.4 case, if a package 'this-pkg' has a sublibrary 'pkg-name', +-- all dependency definitions will refer to that sublirary. +-- +-- In 3.4 and after case, 'pkg-name' will always refer to external package, +-- and to use internal library you have to say 'this-pkg:pkg-name'. +-- +-- In summary, In 3.4 and after, the internal names don't shadow, +-- as there is an explicit syntax to refer to them, +-- i.e. what you write is what you get; +-- For pre-3.4 we post-process the file. +-- +-- Similarly, we process mixins. +-- See https://github.com/haskell/cabal/issues/6281 +-- + +postProcessInternalDeps :: CabalSpecVersion -> GenericPackageDescription -> GenericPackageDescription +postProcessInternalDeps specVer gpd + | specVer >= CabalSpecV3_4 = gpd + | otherwise = transformAllBuildInfos transformBI transformSBI gpd + where + transformBI :: BuildInfo -> BuildInfo + transformBI + = over L.targetBuildDepends (concatMap transformD) + . over L.mixins (map transformM) + + transformSBI :: SetupBuildInfo -> SetupBuildInfo + transformSBI = over L.setupDepends (concatMap transformD) + + transformD :: Dependency -> [Dependency] + transformD (Dependency pn vr ln) + | uqn `Set.member` internalLibs + , LMainLibName `NES.member` ln + = case NES.delete LMainLibName ln of + Nothing -> [dep] + Just ln' -> [dep, Dependency pn vr ln'] + where + uqn = packageNameToUnqualComponentName pn + dep = Dependency thisPn vr (NES.singleton (LSubLibName uqn)) + + transformD d = [d] + + transformM :: Mixin -> Mixin + transformM (Mixin pn LMainLibName incl) + | uqn `Set.member` internalLibs + = mkMixin thisPn (LSubLibName uqn) incl + where + uqn = packageNameToUnqualComponentName pn + + transformM m = m + + thisPn :: PackageName + thisPn = pkgName (package (packageDescription gpd)) + + internalLibs :: Set UnqualComponentName + internalLibs = Set.fromList + [ n + | (n, _) <- condSubLibraries gpd + ] + +------------------------------------------------------------------------------- +-- Old syntax +------------------------------------------------------------------------------- + +-- TODO: move to own module + +-- | "Sectionize" an old-style Cabal file. A sectionized file has: +-- +-- * all global fields at the beginning, followed by +-- +-- * all flag declarations, followed by +-- +-- * an optional library section, and an arbitrary number of executable +-- sections (in any order). +-- +-- The current implementation just gathers all library-specific fields +-- in a library section and wraps all executable stanzas in an executable +-- section. +sectionizeFields :: [Field ann] -> (Syntax, [Field ann]) +sectionizeFields fs = case classifyFields fs of + Just fields -> (OldSyntax, convert fields) + Nothing -> (NewSyntax, fs) + where + -- return 'Just' if all fields are simple fields + classifyFields :: [Field ann] -> Maybe [(Name ann, [FieldLine ann])] + classifyFields = traverse f + where + f (Field name fieldlines) = Just (name, fieldlines) + f _ = Nothing + + trim = BS.dropWhile isSpace' . BS.reverse . BS.dropWhile isSpace' . BS.reverse + isSpace' = (== 32) + + convert :: [(Name ann, [FieldLine ann])] -> [Field ann] + convert fields = + let + toField (name, ls) = Field name ls + -- "build-depends" is a local field now. To be backwards + -- compatible, we still allow it as a global field in old-style + -- package description files and translate it to a local field by + -- adding it to every non-empty section + (hdr0, exes0) = break ((=="executable") . getName . fst) fields + (hdr, libfs0) = partition (not . (`elem` libFieldNames) . getName . fst) hdr0 + + (deps, libfs) = partition ((== "build-depends") . getName . fst) + libfs0 + + exes = unfoldr toExe exes0 + toExe [] = Nothing + toExe ((Name pos n, ls) : r) + | n == "executable" = + let (efs, r') = break ((== "executable") . getName . fst) r + in Just (Section (Name pos "executable") [SecArgName pos $ trim $ fieldlinesToBS ls] (map toField $ deps ++ efs), r') + toExe _ = error "unexpected input to 'toExe'" + + lib = case libfs of + [] -> [] + ((Name pos _, _) : _) -> + [Section (Name pos "library") [] (map toField $ deps ++ libfs)] + + in map toField hdr ++ lib ++ exes + +-- | See 'sectionizeFields'. +data Syntax = OldSyntax | NewSyntax + deriving (Eq, Show) + +-- TODO: +libFieldNames :: [FieldName] +libFieldNames = fieldGrammarKnownFieldList (libraryFieldGrammar LMainLibName) + +------------------------------------------------------------------------------- +-- Supplementary build information +------------------------------------------------------------------------------- + +parseHookedBuildInfo :: BS.ByteString -> ParseResult HookedBuildInfo +parseHookedBuildInfo bs = case readFields' bs of + Right (fs, lexWarnings) -> do + parseHookedBuildInfo' lexWarnings fs + -- TODO: better marshalling of errors + Left perr -> parseFatalFailure zeroPos (show perr) + +parseHookedBuildInfo' + :: [LexWarning] + -> [Field Position] + -> ParseResult HookedBuildInfo +parseHookedBuildInfo' lexWarnings fs = do + parseWarnings (toPWarnings lexWarnings) + (mLibFields, exes) <- stanzas fs + mLib <- parseLib mLibFields + biExes <- traverse parseExe exes + return (mLib, biExes) + where + parseLib :: Fields Position -> ParseResult (Maybe BuildInfo) + parseLib fields + | Map.null fields = pure Nothing + | otherwise = Just <$> parseFieldGrammar cabalSpecLatest fields buildInfoFieldGrammar + + parseExe :: (UnqualComponentName, Fields Position) -> ParseResult (UnqualComponentName, BuildInfo) + parseExe (n, fields) = do + bi <- parseFieldGrammar cabalSpecLatest fields buildInfoFieldGrammar + pure (n, bi) + + stanzas :: [Field Position] -> ParseResult (Fields Position, [(UnqualComponentName, Fields Position)]) + stanzas fields = do + let (hdr0, exes0) = breakMaybe isExecutableField fields + hdr <- toFields hdr0 + exes <- unfoldrM (traverse toExe) exes0 + pure (hdr, exes) + + toFields :: [Field Position] -> ParseResult (Fields Position) + toFields fields = do + let (fields', ss) = partitionFields fields + traverse_ (traverse_ warnInvalidSubsection) ss + pure fields' + + toExe + :: ([FieldLine Position], [Field Position]) + -> ParseResult ((UnqualComponentName, Fields Position), Maybe ([FieldLine Position], [Field Position])) + toExe (fss, fields) = do + name <- runFieldParser zeroPos parsec cabalSpecLatest fss + let (hdr0, rest) = breakMaybe isExecutableField fields + hdr <- toFields hdr0 + pure ((name, hdr), rest) + + isExecutableField (Field (Name _ name) fss) + | name == "executable" = Just fss + | otherwise = Nothing + isExecutableField _ = Nothing + +------------------------------------------------------------------------------- +-- Scan of spec version +------------------------------------------------------------------------------- + +-- | Quickly scan new-style spec-version +-- +-- A new-style spec-version declaration begins the .cabal file and +-- follow the following case-insensitive grammar (expressed in +-- RFC5234 ABNF): +-- +-- @ +-- newstyle-spec-version-decl = "cabal-version" *WS ":" *WS newstyle-pec-version *WS +-- +-- spec-version = NUM "." NUM [ "." NUM ] +-- +-- NUM = DIGIT0 / DIGITP 1*DIGIT0 +-- DIGIT0 = %x30-39 +-- DIGITP = %x31-39 +-- WS = %20 +-- @ +-- +scanSpecVersion :: BS.ByteString -> Maybe Version +scanSpecVersion bs = do + fstline':_ <- pure (BS8.lines bs) + + -- parse + -- normalise: remove all whitespace, convert to lower-case + let fstline = BS.map toLowerW8 $ BS.filter (/= 0x20) fstline' + ["cabal-version",vers] <- pure (BS8.split ':' fstline) + + -- parse + -- + -- This is currently more tolerant regarding leading 0 digits. + -- + ver <- simpleParsecBS vers + guard $ case versionNumbers ver of + [_,_] -> True + [_,_,_] -> True + _ -> False + + pure ver + where + -- | Translate ['A'..'Z'] to ['a'..'z'] + toLowerW8 :: Word8 -> Word8 + toLowerW8 w | 0x40 < w && w < 0x5b = w+0x20 + | otherwise = w diff --git a/cabal/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs b/cabal/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs @@ -0,0 +1,282 @@ +{-# LANGUAGE OverloadedStrings #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.PackageDescription.PrettyPrint +-- Copyright : Jürgen Nicklisch-Franken 2010 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Pretty printing for cabal files +-- +----------------------------------------------------------------------------- + +module Distribution.PackageDescription.PrettyPrint ( + -- * Generic package descriptions + writeGenericPackageDescription, + showGenericPackageDescription, + ppGenericPackageDescription, + + -- * Package descriptions + writePackageDescription, + showPackageDescription, + + -- ** Supplementary build information + writeHookedBuildInfo, + showHookedBuildInfo, +) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.CabalSpecVersion +import Distribution.Fields.Pretty +import Distribution.Compat.Lens +import Distribution.PackageDescription +import Distribution.Pretty +import Distribution.FieldGrammar (PrettyFieldGrammar', prettyFieldGrammar) +import Distribution.PackageDescription.Configuration (transformAllBuildInfos) +import Distribution.PackageDescription.FieldGrammar + (benchmarkFieldGrammar, buildInfoFieldGrammar, executableFieldGrammar, flagFieldGrammar, foreignLibFieldGrammar, libraryFieldGrammar, + packageDescriptionFieldGrammar, setupBInfoFieldGrammar, sourceRepoFieldGrammar, testSuiteFieldGrammar) +import Distribution.Utils.Generic (writeFileAtomic, writeUTF8File) + +import qualified Distribution.PackageDescription.FieldGrammar as FG +import qualified Distribution.Types.BuildInfo.Lens as L +import qualified Distribution.Types.SetupBuildInfo.Lens as L + +import Text.PrettyPrint (Doc, char, hsep, parens, text) + +import qualified Data.ByteString.Lazy.Char8 as BS.Char8 +import qualified Distribution.Compat.NonEmptySet as NES + +-- | Writes a .cabal file from a generic package description +writeGenericPackageDescription :: FilePath -> GenericPackageDescription -> IO () +writeGenericPackageDescription fpath pkg = writeUTF8File fpath (showGenericPackageDescription pkg) + +-- | Writes a generic package description to a string +showGenericPackageDescription :: GenericPackageDescription -> String +showGenericPackageDescription gpd = showFields (const NoComment) $ ppGenericPackageDescription v gpd + where + v = specVersion $ packageDescription gpd + +-- | Convert a generic package description to 'PrettyField's. +ppGenericPackageDescription :: CabalSpecVersion -> GenericPackageDescription -> [PrettyField ()] +ppGenericPackageDescription v gpd0 = concat + [ ppPackageDescription v (packageDescription gpd) + , ppSetupBInfo v (setupBuildInfo (packageDescription gpd)) + , ppGenPackageFlags v (genPackageFlags gpd) + , ppCondLibrary v (condLibrary gpd) + , ppCondSubLibraries v (condSubLibraries gpd) + , ppCondForeignLibs v (condForeignLibs gpd) + , ppCondExecutables v (condExecutables gpd) + , ppCondTestSuites v (condTestSuites gpd) + , ppCondBenchmarks v (condBenchmarks gpd) + ] + where + gpd = preProcessInternalDeps (specVersion (packageDescription gpd0)) gpd0 + + +ppPackageDescription :: CabalSpecVersion -> PackageDescription -> [PrettyField ()] +ppPackageDescription v pd = + prettyFieldGrammar v packageDescriptionFieldGrammar pd + ++ ppSourceRepos v (sourceRepos pd) + +ppSourceRepos :: CabalSpecVersion -> [SourceRepo] -> [PrettyField ()] +ppSourceRepos = map . ppSourceRepo + +ppSourceRepo :: CabalSpecVersion -> SourceRepo -> PrettyField () +ppSourceRepo v repo = PrettySection () "source-repository" [pretty kind] $ + prettyFieldGrammar v (sourceRepoFieldGrammar kind) repo + where + kind = repoKind repo + +ppSetupBInfo :: CabalSpecVersion -> Maybe SetupBuildInfo -> [PrettyField ()] +ppSetupBInfo _ Nothing = mempty +ppSetupBInfo v (Just sbi) + | defaultSetupDepends sbi = mempty + | otherwise = pure $ PrettySection () "custom-setup" [] $ + prettyFieldGrammar v (setupBInfoFieldGrammar False) sbi + +ppGenPackageFlags :: CabalSpecVersion -> [PackageFlag] -> [PrettyField ()] +ppGenPackageFlags = map . ppFlag + +ppFlag :: CabalSpecVersion -> PackageFlag -> PrettyField () +ppFlag v flag@(MkPackageFlag name _ _ _) = PrettySection () "flag" [ppFlagName name] $ + prettyFieldGrammar v (flagFieldGrammar name) flag + +ppCondTree2 :: CabalSpecVersion -> PrettyFieldGrammar' s -> CondTree ConfVar [Dependency] s -> [PrettyField ()] +ppCondTree2 v grammar = go + where + -- TODO: recognise elif opportunities + go (CondNode it _ ifs) = + prettyFieldGrammar v grammar it ++ + concatMap ppIf ifs + + ppIf (CondBranch c thenTree Nothing) +-- | isEmpty thenDoc = mempty + | otherwise = [ppIfCondition c thenDoc] + where + thenDoc = go thenTree + + ppIf (CondBranch c thenTree (Just elseTree)) = + -- See #6193 + [ ppIfCondition c (go thenTree) + , PrettySection () "else" [] (go elseTree) + ] + +ppCondLibrary :: CabalSpecVersion -> Maybe (CondTree ConfVar [Dependency] Library) -> [PrettyField ()] +ppCondLibrary _ Nothing = mempty +ppCondLibrary v (Just condTree) = pure $ PrettySection () "library" [] $ + ppCondTree2 v (libraryFieldGrammar LMainLibName) condTree + +ppCondSubLibraries :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] Library)] -> [PrettyField ()] +ppCondSubLibraries v libs = + [ PrettySection () "library" [pretty n] + $ ppCondTree2 v (libraryFieldGrammar $ LSubLibName n) condTree + | (n, condTree) <- libs + ] + +ppCondForeignLibs :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)] -> [PrettyField ()] +ppCondForeignLibs v flibs = + [ PrettySection () "foreign-library" [pretty n] + $ ppCondTree2 v (foreignLibFieldGrammar n) condTree + | (n, condTree) <- flibs + ] + +ppCondExecutables :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] Executable)] -> [PrettyField ()] +ppCondExecutables v exes = + [ PrettySection () "executable" [pretty n] + $ ppCondTree2 v (executableFieldGrammar n) condTree + | (n, condTree) <- exes + ] + +ppCondTestSuites :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)] -> [PrettyField ()] +ppCondTestSuites v suites = + [ PrettySection () "test-suite" [pretty n] + $ ppCondTree2 v testSuiteFieldGrammar (fmap FG.unvalidateTestSuite condTree) + | (n, condTree) <- suites + ] + +ppCondBenchmarks :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)] -> [PrettyField ()] +ppCondBenchmarks v suites = + [ PrettySection () "benchmark" [pretty n] + $ ppCondTree2 v benchmarkFieldGrammar (fmap FG.unvalidateBenchmark condTree) + | (n, condTree) <- suites + ] + +ppCondition :: Condition ConfVar -> Doc +ppCondition (Var x) = ppConfVar x +ppCondition (Lit b) = text (show b) +ppCondition (CNot c) = char '!' <<>> (ppCondition c) +ppCondition (COr c1 c2) = parens (hsep [ppCondition c1, text "||" + <+> ppCondition c2]) +ppCondition (CAnd c1 c2) = parens (hsep [ppCondition c1, text "&&" + <+> ppCondition c2]) +ppConfVar :: ConfVar -> Doc +ppConfVar (OS os) = text "os" <<>> parens (pretty os) +ppConfVar (Arch arch) = text "arch" <<>> parens (pretty arch) +ppConfVar (PackageFlag name) = text "flag" <<>> parens (ppFlagName name) +ppConfVar (Impl c v) = text "impl" <<>> parens (pretty c <+> pretty v) + +ppFlagName :: FlagName -> Doc +ppFlagName = text . unFlagName + +ppIfCondition :: Condition ConfVar -> [PrettyField ()] -> PrettyField () +ppIfCondition c = PrettySection () "if" [ppCondition c] + +-- | @since 2.0.0.2 +writePackageDescription :: FilePath -> PackageDescription -> IO () +writePackageDescription fpath pkg = writeUTF8File fpath (showPackageDescription pkg) + +--TODO: make this use section syntax +-- add equivalent for GenericPackageDescription + +-- | @since 2.0.0.2 +showPackageDescription :: PackageDescription -> String +showPackageDescription = showGenericPackageDescription . pdToGpd + +pdToGpd :: PackageDescription -> GenericPackageDescription +pdToGpd pd = GenericPackageDescription + { packageDescription = pd + , gpdScannedVersion = Nothing + , genPackageFlags = [] + , condLibrary = mkCondTree <$> library pd + , condSubLibraries = mkCondTreeL <$> subLibraries pd + , condForeignLibs = mkCondTree' foreignLibName <$> foreignLibs pd + , condExecutables = mkCondTree' exeName <$> executables pd + , condTestSuites = mkCondTree' testName <$> testSuites pd + , condBenchmarks = mkCondTree' benchmarkName <$> benchmarks pd + } + where + -- We set CondTree's [Dependency] to an empty list, as it + -- is not pretty printed anyway. + mkCondTree x = CondNode x [] [] + mkCondTreeL l = (fromMaybe (mkUnqualComponentName "") (libraryNameString (libName l)), CondNode l [] []) + + mkCondTree' + :: (a -> UnqualComponentName) + -> a -> (UnqualComponentName, CondTree ConfVar [Dependency] a) + mkCondTree' f x = (f x, CondNode x [] []) + +------------------------------------------------------------------------------- +-- Internal libs +------------------------------------------------------------------------------- + +-- See Note [Dependencies on sublibraries] in Distribution.PackageDescription.Parsec +-- +preProcessInternalDeps :: CabalSpecVersion -> GenericPackageDescription -> GenericPackageDescription +preProcessInternalDeps specVer gpd + | specVer >= CabalSpecV3_4 = gpd + | otherwise = transformAllBuildInfos transformBI transformSBI gpd + where + transformBI :: BuildInfo -> BuildInfo + transformBI + = over L.targetBuildDepends (concatMap transformD) + . over L.mixins (map transformM) + + transformSBI :: SetupBuildInfo -> SetupBuildInfo + transformSBI = over L.setupDepends (concatMap transformD) + + transformD :: Dependency -> [Dependency] + transformD (Dependency pn vr ln) + | pn == thisPn + = if LMainLibName `NES.member` ln + then Dependency thisPn vr mainLibSet : sublibs + else sublibs + where + sublibs = + [ Dependency (unqualComponentNameToPackageName uqn) vr mainLibSet + | LSubLibName uqn <- NES.toList ln + ] + + transformD d = [d] + + transformM :: Mixin -> Mixin + transformM (Mixin pn (LSubLibName uqn) inc) + | pn == thisPn + = mkMixin (unqualComponentNameToPackageName uqn) LMainLibName inc + transformM m = m + + thisPn :: PackageName + thisPn = pkgName (package (packageDescription gpd)) + +------------------------------------------------------------------------------- +-- HookedBuildInfo +------------------------------------------------------------------------------- + +-- | @since 2.0.0.2 +writeHookedBuildInfo :: FilePath -> HookedBuildInfo -> IO () +writeHookedBuildInfo fpath = writeFileAtomic fpath . BS.Char8.pack + . showHookedBuildInfo + +-- | @since 2.0.0.2 +showHookedBuildInfo :: HookedBuildInfo -> String +showHookedBuildInfo (mb_lib_bi, ex_bis) = showFields (const NoComment) $ + maybe mempty (prettyFieldGrammar cabalSpecLatest buildInfoFieldGrammar) mb_lib_bi ++ + [ PrettySection () "executable:" [pretty name] + $ prettyFieldGrammar cabalSpecLatest buildInfoFieldGrammar bi + | (name, bi) <- ex_bis + ] diff --git a/cabal/Cabal-syntax/src/Distribution/PackageDescription/Quirks.hs b/cabal/Cabal-syntax/src/Distribution/PackageDescription/Quirks.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/PackageDescription/Quirks.hs @@ -0,0 +1,340 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +-- | +-- +-- @since 2.2.0.0 +module Distribution.PackageDescription.Quirks (patchQuirks) where + +import Distribution.Compat.Prelude +import Distribution.Utils.MD5 +import GHC.Fingerprint (Fingerprint (..)) +import Prelude () + +import qualified Data.ByteString as BS +import qualified Data.Map as Map + +-- | Patch legacy @.cabal@ file contents to allow parsec parser to accept +-- all of Hackage. +-- +-- Bool part of the result tells whether the output is modified. +-- +-- @since 2.2.0.0 +patchQuirks :: BS.ByteString -> (Bool, BS.ByteString) +patchQuirks bs = case Map.lookup (BS.take 256 bs, md5 bs) patches of + Nothing -> (False, bs) + Just (post, f) + | post /= md5 output -> (False, bs) + | otherwise -> (True, output) + where + output = f bs + +-- | 'patches' contains first 256 bytes, pre- and post-fingerprints and a patch function. +patches :: Map.Map (BS.ByteString, Fingerprint) (Fingerprint, BS.ByteString -> BS.ByteString) +patches = Map.fromList + -- http://hackage.haskell.org/package/unicode-transforms-0.3.3 + -- other-modules: . + -- ReadP assumed dot is empty line + [ mk "-- This file has been generated from package.yaml by hpack version 0.17.0.\n--\n-- see: https://github.com/sol/hpack\n\nname: unicode-transforms\nversion: 0.3.3\nsynopsis: Unicode normalization\ndescription: Fast Unic" + (Fingerprint 15958160436627155571 10318709190730872881) + (Fingerprint 11008465475756725834 13815629925116264363) + (bsRemove " other-modules:\n .\n") -- TODO: remove traling \n to test structural-diff + -- http://hackage.haskell.org/package/DSTM-0.1.2 + -- http://hackage.haskell.org/package/DSTM-0.1.1 + -- http://hackage.haskell.org/package/DSTM-0.1 + -- Other Modules: no dash + -- ReadP parsed as section + , mk "Name: DSTM\nVersion: 0.1.2\nCopyright: (c) 2010, Frank Kupke\nLicense: LGPL\nLicense-File: LICENSE\nAuthor: Frank Kupke\nMaintainer: frk@informatik.uni-kiel.de\nCabal-Version: >= 1.2.3\nStability: provisional\nSynopsis: A framework for using STM within distributed " + (Fingerprint 6919263071548559054 9050746360708965827) + (Fingerprint 17015177514298962556 11943164891661867280) + (bsReplace "Other modules:" "-- ") + , mk "Name: DSTM\nVersion: 0.1.1\nCopyright: (c) 2010, Frank Kupke\nLicense: LGPL\nLicense-File: LICENSE\nAuthor: Frank Kupke\nMaintainer: frk@informatik.uni-kiel.de\nCabal-Version: >= 1.2.3\nStability: provisional\nSynopsis: A framework for using STM within distributed " + (Fingerprint 17313105789069667153 9610429408495338584) + (Fingerprint 17250946493484671738 17629939328766863497) + (bsReplace "Other modules:" "-- ") + , mk "Name: DSTM\nVersion: 0.1\nCopyright: (c) 2010, Frank Kupke\nLicense: LGPL\nLicense-File: LICENSE\nAuthor: Frank Kupke\nMaintainer: frk@informatik.uni-kiel.de\nCabal-Version: >= 1.2.3\nStability: provisional\nSynopsis: A framework for using STM within distributed sy" + (Fingerprint 10502599650530614586 16424112934471063115) + (Fingerprint 13562014713536696107 17899511905611879358) + (bsReplace "Other modules:" "-- ") + -- http://hackage.haskell.org/package/control-monad-exception-mtl-0.10.3 + , mk "name: control-monad-exception-mtl\nversion: 0.10.3\nCabal-Version: >= 1.10\nbuild-type: Simple\nlicense: PublicDomain\nauthor: Pepe Iborra\nmaintainer: pepeiborra@gmail.com\nhomepage: http://pepeiborra.github.com/control-monad-exception\nsynopsis: MTL instances f" + (Fingerprint 18274748422558568404 4043538769550834851) + (Fingerprint 11395257416101232635 4303318131190196308) + (bsReplace " default- extensions:" "unknown-section") + -- http://hackage.haskell.org/package/vacuum-opengl-0.0 + -- \DEL character + , mk "Name: vacuum-opengl\nVersion: 0.0\nSynopsis: Visualize live Haskell data structures using vacuum, graphviz and OpenGL.\nDescription: \DELVisualize live Haskell data structures using vacuum, graphviz and OpenGL.\n " + (Fingerprint 5946760521961682577 16933361639326309422) + (Fingerprint 14034745101467101555 14024175957788447824) + (bsRemove "\DEL") + , mk "Name: vacuum-opengl\nVersion: 0.0.1\nSynopsis: Visualize live Haskell data structures using vacuum, graphviz and OpenGL.\nDescription: \DELVisualize live Haskell data structures using vacuum, graphviz and OpenGL.\n " + (Fingerprint 10790950110330119503 1309560249972452700) + (Fingerprint 1565743557025952928 13645502325715033593) + (bsRemove "\DEL") + -- http://hackage.haskell.org/package/ixset-1.0.4 + -- {- comments -} + , mk "Name: ixset\nVersion: 1.0.4\nSynopsis: Efficient relational queries on Haskell sets.\nDescription:\n Create and query sets that are indexed by multiple indices.\nLicense: BSD3\nLicense-file: COPYING\nAut" + (Fingerprint 11886092342440414185 4150518943472101551) + (Fingerprint 5731367240051983879 17473925006273577821) + (bsRemoveStarting "{-") + -- : after section + -- http://hackage.haskell.org/package/ds-kanren + , mk "name: ds-kanren\nversion: 0.2.0.0\nsynopsis: A subset of the miniKanren language\ndescription:\n ds-kanren is an implementation of the language.\n .\n == What's in ds-kanren?\n .\n ['dis" + (Fingerprint 2804006762382336875 9677726932108735838) + (Fingerprint 9830506174094917897 12812107316777006473) + (bsReplace "Test-Suite test-unify:" "Test-Suite \"test-unify:\"" . bsReplace "Test-Suite test-list-ops:" "Test-Suite \"test-list-ops:\"") + , mk "name: ds-kanren\nversion: 0.2.0.1\nsynopsis: A subset of the miniKanren language\ndescription:\n ds-kanren is an implementation of the language.\n\nlicense: MIT\nlicense-file: " + (Fingerprint 9130259649220396193 2155671144384738932) + (Fingerprint 1847988234352024240 4597789823227580457) + (bsReplace "Test-Suite test-unify:" "Test-Suite \"test-unify:\"" . bsReplace "Test-Suite test-list-ops:" "Test-Suite \"test-list-ops:\"") + , mk "name: metric\nversion: 0.1.4\nsynopsis: Metric spaces.\nlicense: MIT\nlicense-file: LICENSE\nauthor: Vikram Verma\nmaintainer: me@vikramverma.com\ncategory: Data\nbuild-type:" + (Fingerprint 6150019278861565482 3066802658031228162) + (Fingerprint 9124826020564520548 15629704249829132420) + (bsReplace "test-suite metric-tests:" "test-suite \"metric-tests:\"") + , mk "name: metric\nversion: 0.2.0\nsynopsis: Metric spaces.\nlicense: MIT\nlicense-file: LICENSE\nauthor: Vikram Verma\nmaintainer: me@vikramverma.com\ncategory: Data\nbuild-type:" + (Fingerprint 4639805967994715694 7859317050376284551) + (Fingerprint 5566222290622325231 873197212916959151) + (bsReplace "test-suite metric-tests:" "test-suite \"metric-tests:\"") + , mk "name: phasechange\ncategory: Data\nversion: 0.1\nauthor: G\195\161bor Lehel\nmaintainer: G\195\161bor Lehel \nhomepage: http://github.com/glehel/phasechange\ncopyright: Copyright (C) 2012 G\195\161bor Lehel\nlicense: " + (Fingerprint 10546509771395401582 245508422312751943) + (Fingerprint 5169853482576003304 7247091607933993833) + (bsReplace "impl(ghc >= 7.4):" "erroneous-section" . bsReplace "impl(ghc >= 7.6):" "erroneous-section") + , mk "Name: smartword\nSynopsis: Web based flash card for Word Smart I and II vocabularies\nVersion: 0.0.0.5\nHomepage: http://kyagrd.dyndns.org/~kyagrd/project/smartword/\nCategory: Web,Education\nLicense: " + (Fingerprint 7803544783533485151 10807347873998191750) + (Fingerprint 1665635316718752601 16212378357991151549) + (bsReplace "build depends:" "--") + , mk "name: shelltestrunner\n-- sync with README.md, ANNOUNCE:\nversion: 1.3\ncategory: Testing\nsynopsis: A tool for testing command-line programs.\ndescription:\n shelltestrunner is a cross-platform tool for testing command-line\n program" + (Fingerprint 4403237110790078829 15392625961066653722) + (Fingerprint 10218887328390239431 4644205837817510221) + (bsReplace "other modules:" "--") + -- &&! + -- http://hackage.haskell.org/package/hblas-0.3.0.0 + , mk "-- Initial hblas.cabal generated by cabal init. For further \n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP) \n-- " + (Fingerprint 8570120150072467041 18315524331351505945) + (Fingerprint 10838007242302656005 16026440017674974175) + (bsReplace "&&!" "&& !") + , mk "-- Initial hblas.cabal generated by cabal init. For further \n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP) \n-- " + (Fingerprint 5262875856214215155 10846626274067555320) + (Fingerprint 3022954285783401045 13395975869915955260) + (bsReplace "&&!" "&& !") + , mk "-- Initial hblas.cabal generated by cabal init. For further \n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP) \n-- " + (Fingerprint 54222628930951453 5526514916844166577) + (Fingerprint 1749630806887010665 8607076506606977549) + (bsReplace "&&!" "&& !") + , mk "-- Initial hblas.cabal generated by cabal init. For further\n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP)\n-- fo" + (Fingerprint 6817250511240350300 15278852712000783849) + (Fingerprint 15757717081429529536 15542551865099640223) + (bsReplace "&&!" "&& !") + , mk "-- Initial hblas.cabal generated by cabal init. For further\n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP)\n-- fo" + (Fingerprint 8310050400349211976 201317952074418615) + (Fingerprint 10283381191257209624 4231947623042413334) + (bsReplace "&&!" "&& !") + , mk "-- Initial hblas.cabal generated by cabal init. For further\n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP)\n-- fo" + (Fingerprint 7010988292906098371 11591884496857936132) + (Fingerprint 6158672440010710301 6419743768695725095) + (bsReplace "&&!" "&& !") + , mk "-- Initial hblas.cabal generated by cabal init. For further\r\n-- documentation, see http://haskell.org/cabal/users-guide/\r\n\r\n-- The name of the package.\r\nname: hblas\r\n\r\n-- The package version. See the Haskell package versioning policy (PVP)" + (Fingerprint 2076850805659055833 16615160726215879467) + (Fingerprint 10634706281258477722 5285812379517916984) + (bsReplace "&&!" "&& !") + , mk "-- Initial hblas.cabal generated by cabal init. For further\r\n-- documentation, see http://haskell.org/cabal/users-guide/\r\n\r\n-- The name of the package.\r\nname: hblas\r\n\r\n-- The package version. See the Haskell package versioning policy (PVP)" + (Fingerprint 11850020631622781099 11956481969231030830) + (Fingerprint 13702868780337762025 13383526367149067158) + (bsReplace "&&!" "&& !") + , mk "-- Initial hblas.cabal generated by cabal init. For further\n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP)\n-- fo" + (Fingerprint 13690322768477779172 19704059263540994) + (Fingerprint 11189374824645442376 8363528115442591078) + (bsReplace "&&!" "&& !") + -- flag used, but not defined + , mk "name: brainheck\nversion: 0.1.0.2\nsynopsis: Brainh*ck interpreter in haskell\ndescription: Brainh*ck interpreter written in haskell and taking advantage of many prominent libraries\nhomepage: https://gi" + (Fingerprint 6910727116443152200 15401634478524888973) + (Fingerprint 16551412117098094368 16260377389127603629) + (bsReplace "flag(llvm-fast)" "False") + , mk "name: brainheck\r\nversion: 0.1.0.2\r\nx-revision: 1\r\nsynopsis: Brainh*ck interpreter in haskell\r\ndescription: Brainh*ck interpreter written in haskell and taking advantage of many prominent libraries\r\nhomepage: " + (Fingerprint 14320987921316832277 10031098243571536929) + (Fingerprint 7959395602414037224 13279941216182213050) + (bsReplace "flag(llvm-fast)" "False") + , mk "name: brainheck\r\nversion: 0.1.0.2\r\nx-revision: 2\r\nsynopsis: Brainh*ck interpreter in haskell\r\ndescription: Brainh*ck interpreter written in haskell and taking advantage of many prominent libraries\r\nhomepage: " + (Fingerprint 3809078390223299128 10796026010775813741) + (Fingerprint 1127231189459220796 12088367524333209349) + (bsReplace "flag(llvm-fast)" "False") + , mk "name: brainheck\r\nversion: 0.1.0.2\r\nx-revision: 3\r\nsynopsis: Brainh*ck interpreter in haskell\r\ndescription: Brainh*ck interpreter written in haskell and taking advantage of many prominent libraries\r\nhomepage: " + (Fingerprint 13860013038089410950 12479824176801390651) + (Fingerprint 4687484721703340391 8013395164515771785) + (bsReplace "flag(llvm-fast)" "False") + , mk "name: wordchoice\nversion: 0.1.0.1\nsynopsis: Get word counts and distributions\ndescription: A command line tool to compute the word distribution from various types of document, converting to text with pandoc.\nho" + (Fingerprint 16215911397419608203 15594928482155652475) + (Fingerprint 15120681510314491047 2666192399775157359) + (bsReplace "flag(llvm-fast)" "False") + , mk "name: wordchoice\r\nversion: 0.1.0.1\r\nx-revision: 1\r\nsynopsis: Get word counts and distributions\r\ndescription: A command line tool to compute the word distribution from various types of document, converting to te" + (Fingerprint 16593139224723441188 4052919014346212001) + (Fingerprint 3577381082410411593 11481899387780544641) + (bsReplace "flag(llvm-fast)" "False") + , mk "name: wordchoice\nversion: 0.1.0.2\nsynopsis: Get word counts and distributions\ndescription: A command line tool to compute the word distribution from various types of document, converting to text with pandoc.\nho" + (Fingerprint 9321301260802539374 1316392715016096607) + (Fingerprint 3784628652257760949 12662640594755291035) + (bsReplace "flag(llvm-fast)" "False") + , mk "name: wordchoice\r\nversion: 0.1.0.2\r\nx-revision: 1\r\nsynopsis: Get word counts and distributions\r\ndescription: A command line tool to compute the word distribution from various types of document, converting to te" + (Fingerprint 2546901804824433337 2059732715322561176) + (Fingerprint 8082068680348326500 615008613291421947) + (bsReplace "flag(llvm-fast)" "False") + , mk "name: wordchoice\nversion: 0.1.0.3\nsynopsis: Get word counts and distributions\ndescription: A command line tool to compute the word distribution from various types of document, converting to text with pandoc.\nho" + (Fingerprint 2282380737467965407 12457554753171662424) + (Fingerprint 17324757216926991616 17172911843227482125) + (bsReplace "flag(llvm-fast)" "False") + , mk "name: wordchoice\r\nversion: 0.1.0.3\r\nx-revision: 1\r\nsynopsis: Get word counts and distributions\r\ndescription: A command line tool to compute the word distribution from various types of document, converting to te" + (Fingerprint 12907988890480595481 11078473638628359710) + (Fingerprint 13246185333368731848 4663060731847518614) + (bsReplace "flag(llvm-fast)" "False") + , mk "name: hw-prim-bits\nversion: 0.1.0.0\nsynopsis: Primitive support for bit manipulation\ndescription: Please see README.md\nhomepage: https://github.com/githubuser/hw-prim-bits#readme\nlicense: " + (Fingerprint 12386777729082870356 17414156731912743711) + (Fingerprint 3452290353395041602 14102887112483033720) + (bsReplace "flag(sse42)" "False") + , mk "name: hw-prim-bits\nversion: 0.1.0.1\nsynopsis: Primitive support for bit manipulation\ndescription: Please see README.md\nhomepage: https://github.com/githubuser/hw-prim-bits#readme\nlicen" + (Fingerprint 6870520675313101180 14553457351296240636) + (Fingerprint 12481021059537696455 14711088786769892762) + (bsReplace "flag(sse42)" "False") + -- leading zeros in version digits + -- https://github.com/haskell-infra/hackage-trustees/issues/128 + -- https://github.com/haskell/cabal/issues/5092 + -- https://github.com/haskell/cabal/issues/5138 + , mk "name: Sit\nversion: 0.2017.02.26\nbuild-type: Simple\ncabal-version: >= 1.8\nlicense: OtherLicense\nlicense-file: LICENSE\nauthor: Anonymous\nmaintainer: Anonymous\nhomepage: NONE\ncategory: Dependent" + (Fingerprint 8458530898096910998 3228538743646501413) + (Fingerprint 14470502514907936793 17514354054641875371) + (bsReplace "0.2017.02.26" "0.2017.2.26") + , mk "name: Sit\nversion: 0.2017.05.01\nbuild-type: Simple\ncabal-version: >= 1.8\nlicense: OtherLicense\nlicense-file: LICENSE\nauthor: Andreas Abel \nmaintainer: Andreas Abel \n" + (Fingerprint 1450130849535097473 11742099607098860444) + (Fingerprint 16679762943850814021 4253724355613883542) + (bsReplace "0.2017.05.01" "0.2017.5.1") + , mk "name: Sit\nversion: 0.2017.05.02\nbuild-type: Simple\ncabal-version: >= 1.8\nlicense: OtherLicense\nlicense-file: LICENSE\nauthor: Andreas Abel \nmaintainer: Andreas Abel \n" + (Fingerprint 297248532398492441 17322625167861324800) + (Fingerprint 634812045126693280 1755581866539318862) + (bsReplace "0.2017.05.02" "0.2017.5.2") + , mk "name: Sit\nversion: 0.2017.5.02\nx-revision: 1\n-- x-revision:1 see https://github.com/haskell-infra/hackage-trustees/issues/128\nbuild-type: Simple\ncabal-version: >= 1.8\nlicense: OtherLicense\nlicense-file: LICENSE\nauthor: " + (Fingerprint 3697869560530373941 3942982281026987312) + (Fingerprint 14344526114710295386 16386400353475114712) + (bsReplace "0.2017.5.02" "0.2017.5.2") + , mk "name: MiniAgda\nversion: 0.2017.02.18\nbuild-type: Simple\ncabal-version: >= 1.22\nlicense: OtherLicense\nlicense-file: LICENSE\nauthor: Andreas Abel and Karl Mehltretter\nmaintainer: Andreas Abel =1.8\nbuild-type: Simple\nlicense: GPL\nlicense-file: /home/palo/dev/haskell-workspace/playground/reheat/gpl-3.0.txt\ncopyright: GPL\nmaintainer: Ingolf Wagner \nstability: experimental\nhomepage: h" + (Fingerprint 9155400339287317061 14812953666990892802) + (Fingerprint 7687053346032173923 15384472501136606592) + (bsReplace "/home/palo/dev/haskell-workspace/playground/reheat/gpl-3.0.txt" "") + , mk "name: reheat\nversion: 0.1.5\ncabal-version: >=1.8\nbuild-type: Simple\nlicense: GPL\nlicense-file: /home/palo/dev/haskell-workspace/playground/reheat/gpl-3.0.txt\ncopyright: GPL\nmaintainer: Ingolf Wagner \nstability: experimental\nhomepage: h" + (Fingerprint 2984391146441073709 11728234882049907993) + (Fingerprint 12058479081855347701 14017937756688869826) + (bsReplace "/home/palo/dev/haskell-workspace/playground/reheat/gpl-3.0.txt" "") + ] + where + mk a b c d = ((a, b), (c, d)) + +-- | Helper to create entries in patches +_makePatchKey :: FilePath -> (BS.ByteString -> BS.ByteString) -> IO () +_makePatchKey fp transform = do + contents <- BS.readFile fp + let output = transform contents + let Fingerprint hi lo = md5 contents + let Fingerprint hi' lo' = md5 output + putStrLn + $ showString " , mk " + . shows (BS.take 256 contents) + . showString "\n (Fingerprint " + . shows hi + . showString " " + . shows lo + . showString ")\n (Fingerprint " + . shows hi' + . showString " " + . shows lo' + . showString ")" + $ "" + +------------------------------------------------------------------------------- +-- Patch helpers +------------------------------------------------------------------------------- + +bsRemove + :: BS.ByteString -- ^ needle + -> BS.ByteString -> BS.ByteString +bsRemove needle haystack = case BS.breakSubstring needle haystack of + (h, t) -> BS.append h (BS.drop (BS.length needle) t) + +bsReplace + :: BS.ByteString -- ^ needle + -> BS.ByteString -- ^ replacement + -> BS.ByteString -> BS.ByteString +bsReplace needle repl haystack = case BS.breakSubstring needle haystack of + (h, t) + | not (BS.null t) -> BS.append h (BS.append repl (BS.drop (BS.length needle) t)) + | otherwise -> haystack + +bsRemoveStarting + :: BS.ByteString -- ^ needle + -> BS.ByteString -> BS.ByteString +bsRemoveStarting needle haystack = case BS.breakSubstring needle haystack of + (h, _) -> h diff --git a/cabal/Cabal-syntax/src/Distribution/PackageDescription/Utils.hs b/cabal/Cabal-syntax/src/Distribution/PackageDescription/Utils.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/PackageDescription/Utils.hs @@ -0,0 +1,23 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.PackageDescription.Utils +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Common utils used by modules under Distribution.PackageDescription.*. + +module Distribution.PackageDescription.Utils ( + cabalBug, userBug + ) where + +-- ---------------------------------------------------------------------------- +-- Exception and logging utils + +userBug :: String -> a +userBug msg = error $ msg ++ ". This is a bug in your .cabal file." + +cabalBug :: String -> a +cabalBug msg = error $ msg ++ ". This is possibly a bug in Cabal.\n" + ++ "Please report it to the developers: " + ++ "https://github.com/haskell/cabal/issues/new" diff --git a/cabal/Cabal-syntax/src/Distribution/Parsec.hs b/cabal/Cabal-syntax/src/Distribution/Parsec.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Parsec.hs @@ -0,0 +1,524 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Distribution.Parsec ( + Parsec(..), + ParsecParser (..), + runParsecParser, + runParsecParser', + simpleParsec, + simpleParsecBS, + simpleParsec', + simpleParsecW', + lexemeParsec, + eitherParsec, + explicitEitherParsec, + explicitEitherParsec', + -- * CabalParsing and diagnostics + CabalParsing (..), + -- ** Warnings + PWarnType (..), + PWarning (..), + showPWarning, + -- ** Errors + PError (..), + showPError, + -- * Position + Position (..), + incPos, + retPos, + showPos, + zeroPos, + -- * Utilities + parsecToken, + parsecToken', + parsecFilePath, + parsecQuoted, + parsecMaybeQuoted, + parsecCommaList, + parsecCommaNonEmpty, + parsecLeadingCommaList, + parsecLeadingCommaNonEmpty, + parsecOptCommaList, + parsecLeadingOptCommaList, + parsecStandard, + parsecUnqualComponentName, + ) where + +import Data.ByteString (ByteString) +import Data.Char (digitToInt, intToDigit) +import Data.List (transpose) +import Distribution.CabalSpecVersion +import Distribution.Compat.Prelude +import Distribution.Parsec.Error (PError (..), showPError) +import Distribution.Parsec.FieldLineStream (FieldLineStream, fieldLineStreamFromBS, fieldLineStreamFromString) +import Distribution.Parsec.Position (Position (..), incPos, retPos, showPos, zeroPos) +import Distribution.Parsec.Warning (PWarnType (..), PWarning (..), showPWarning) +import Numeric (showIntAtBase) +import Prelude () + +import qualified Distribution.Compat.CharParsing as P +import qualified Distribution.Compat.DList as DList +import qualified Distribution.Compat.MonadFail as Fail +import qualified Text.Parsec as Parsec + +------------------------------------------------------------------------------- +-- Class +------------------------------------------------------------------------------- + +-- | Class for parsing with @parsec@. Mainly used for @.cabal@ file fields. +-- +-- For parsing @.cabal@ like file structure, see "Distribution.Fields". +-- +class Parsec a where + parsec :: CabalParsing m => m a + +-- | Parsing class which +-- +-- * can report Cabal parser warnings. +-- +-- * knows @cabal-version@ we work with +-- +class (P.CharParsing m, MonadPlus m, Fail.MonadFail m) => CabalParsing m where + parsecWarning :: PWarnType -> String -> m () + + parsecHaskellString :: m String + parsecHaskellString = stringLiteral + + askCabalSpecVersion :: m CabalSpecVersion + +-- | 'parsec' /could/ consume trailing spaces, this function /will/ consume. +lexemeParsec :: (CabalParsing m, Parsec a) => m a +lexemeParsec = parsec <* P.spaces + +newtype ParsecParser a = PP { unPP + :: CabalSpecVersion -> Parsec.Parsec FieldLineStream [PWarning] a + } + +liftParsec :: Parsec.Parsec FieldLineStream [PWarning] a -> ParsecParser a +liftParsec p = PP $ \_ -> p + +instance Functor ParsecParser where + fmap f p = PP $ \v -> fmap f (unPP p v) + {-# INLINE fmap #-} + + x <$ p = PP $ \v -> x <$ unPP p v + {-# INLINE (<$) #-} + +instance Applicative ParsecParser where + pure = liftParsec . pure + {-# INLINE pure #-} + + f <*> x = PP $ \v -> unPP f v <*> unPP x v + {-# INLINE (<*>) #-} + f *> x = PP $ \v -> unPP f v *> unPP x v + {-# INLINE (*>) #-} + f <* x = PP $ \v -> unPP f v <* unPP x v + {-# INLINE (<*) #-} + +instance Alternative ParsecParser where + empty = liftParsec empty + + a <|> b = PP $ \v -> unPP a v <|> unPP b v + {-# INLINE (<|>) #-} + + many p = PP $ \v -> many (unPP p v) + {-# INLINE many #-} + + some p = PP $ \v -> some (unPP p v) + {-# INLINE some #-} + +instance Monad ParsecParser where + return = pure + + m >>= k = PP $ \v -> unPP m v >>= \x -> unPP (k x) v + {-# INLINE (>>=) #-} + (>>) = (*>) + {-# INLINE (>>) #-} + +#if !(MIN_VERSION_base(4,13,0)) + fail = Fail.fail +#endif + +instance MonadPlus ParsecParser where + mzero = empty + mplus = (<|>) + +instance Fail.MonadFail ParsecParser where + fail = P.unexpected + +instance P.Parsing ParsecParser where + try p = PP $ \v -> P.try (unPP p v) + p d = PP $ \v -> unPP p v P. d + skipMany p = PP $ \v -> P.skipMany (unPP p v) + skipSome p = PP $ \v -> P.skipSome (unPP p v) + unexpected = liftParsec . P.unexpected + eof = liftParsec P.eof + notFollowedBy p = PP $ \v -> P.notFollowedBy (unPP p v) + +instance P.CharParsing ParsecParser where + satisfy = liftParsec . P.satisfy + char = liftParsec . P.char + notChar = liftParsec . P.notChar + anyChar = liftParsec P.anyChar + string = liftParsec . P.string + +instance CabalParsing ParsecParser where + parsecWarning t w = liftParsec $ do + spos <- Parsec.getPosition + Parsec.modifyState + (PWarning t (Position (Parsec.sourceLine spos) (Parsec.sourceColumn spos)) w :) + askCabalSpecVersion = PP pure + +-- | Parse a 'String' with 'lexemeParsec'. +simpleParsec :: Parsec a => String -> Maybe a +simpleParsec + = either (const Nothing) Just + . runParsecParser lexemeParsec "" + . fieldLineStreamFromString + +-- | Like 'simpleParsec' but for 'ByteString' +simpleParsecBS :: Parsec a => ByteString -> Maybe a +simpleParsecBS + = either (const Nothing) Just + . runParsecParser lexemeParsec "" + . fieldLineStreamFromBS + +-- | Parse a 'String' with 'lexemeParsec' using specific 'CabalSpecVersion'. +-- +-- @since 3.4.0.0 +simpleParsec' :: Parsec a => CabalSpecVersion -> String -> Maybe a +simpleParsec' spec + = either (const Nothing) Just + . runParsecParser' spec lexemeParsec "" + . fieldLineStreamFromString + +-- | Parse a 'String' with 'lexemeParsec' using specific 'CabalSpecVersion'. +-- Fail if there are any warnings. +-- +-- @since 3.4.0.0 +simpleParsecW' :: Parsec a => CabalSpecVersion -> String -> Maybe a +simpleParsecW' spec + = either (const Nothing) (\(x, ws) -> if null ws then Just x else Nothing) + . runParsecParser' spec ((,) <$> lexemeParsec <*> liftParsec Parsec.getState) "" + . fieldLineStreamFromString + +-- | Parse a 'String' with 'lexemeParsec'. +eitherParsec :: Parsec a => String -> Either String a +eitherParsec = explicitEitherParsec parsec + +-- | Parse a 'String' with given 'ParsecParser'. Trailing whitespace is accepted. +explicitEitherParsec :: ParsecParser a -> String -> Either String a +explicitEitherParsec parser + = either (Left . show) Right + . runParsecParser (parser <* P.spaces) "" + . fieldLineStreamFromString + +-- | Parse a 'String' with given 'ParsecParser' and 'CabalSpecVersion'. Trailing whitespace is accepted. +-- See 'explicitEitherParsec'. +-- +-- @since 3.4.0.0 +-- +explicitEitherParsec' :: CabalSpecVersion -> ParsecParser a -> String -> Either String a +explicitEitherParsec' spec parser + = either (Left . show) Right + . runParsecParser' spec (parser <* P.spaces) "" + . fieldLineStreamFromString + +-- | Run 'ParsecParser' with 'cabalSpecLatest'. +runParsecParser :: ParsecParser a -> FilePath -> FieldLineStream -> Either Parsec.ParseError a +runParsecParser = runParsecParser' cabalSpecLatest + +-- | Like 'runParsecParser' but lets specify 'CabalSpecVersion' used. +-- +-- @since 3.0.0.0 +-- +runParsecParser' :: CabalSpecVersion -> ParsecParser a -> FilePath -> FieldLineStream -> Either Parsec.ParseError a +runParsecParser' v p n = Parsec.runParser (unPP p v <* P.eof) [] n + +instance Parsec a => Parsec (Identity a) where + parsec = Identity <$> parsec + +instance Parsec Bool where + parsec = P.munch1 isAlpha >>= postprocess + where + postprocess str + | str == "True" = pure True + | str == "False" = pure False + | lstr == "true" = parsecWarning PWTBoolCase caseWarning *> pure True + | lstr == "false" = parsecWarning PWTBoolCase caseWarning *> pure False + | otherwise = fail $ "Not a boolean: " ++ str + where + lstr = map toLower str + caseWarning = + "Boolean values are case sensitive, use 'True' or 'False'." + +-- | @[^ ,]@ +parsecToken :: CabalParsing m => m String +parsecToken = parsecHaskellString <|> ((P.munch1 (\x -> not (isSpace x) && x /= ',') P. "identifier" ) >>= checkNotDoubleDash) + +-- | @[^ ]@ +parsecToken' :: CabalParsing m => m String +parsecToken' = parsecHaskellString <|> ((P.munch1 (not . isSpace) P. "token") >>= checkNotDoubleDash) + +checkNotDoubleDash :: CabalParsing m => String -> m String +checkNotDoubleDash s = do + when (s == "--") $ parsecWarning PWTDoubleDash $ unwords + [ "Double-dash token found." + , "Note: there are no end-of-line comments in .cabal files, only whole line comments." + , "Use \"--\" (quoted double dash) to silence this warning, if you actually want -- token" + ] + + return s + +parsecFilePath :: CabalParsing m => m FilePath +parsecFilePath = parsecToken + +-- | Parse a benchmark/test-suite types. +parsecStandard :: (CabalParsing m, Parsec ver) => (ver -> String -> a) -> m a +parsecStandard f = do + cs <- some $ P.try (component <* P.char '-') + ver <- parsec + let name = map toLower (intercalate "-" cs) + return $! f ver name + where + component = do + cs <- P.munch1 isAlphaNum + if all isDigit cs then fail "all digit component" else return cs + -- each component must contain an alphabetic character, to avoid + -- ambiguity in identifiers like foo-1 (the 1 is the version number). + +parsecCommaList :: CabalParsing m => m a -> m [a] +parsecCommaList p = P.sepBy (p <* P.spaces) (P.char ',' *> P.spaces P. "comma") + +parsecCommaNonEmpty :: CabalParsing m => m a -> m (NonEmpty a) +parsecCommaNonEmpty p = P.sepByNonEmpty (p <* P.spaces) (P.char ',' *> P.spaces P. "comma") + +-- | Like 'parsecCommaList' but accept leading or trailing comma. +-- +-- @ +-- p (comma p)* -- p `sepBy` comma +-- (comma p)* -- leading comma +-- (p comma)* -- trailing comma +-- @ +parsecLeadingCommaList :: CabalParsing m => m a -> m [a] +parsecLeadingCommaList p = do + c <- P.optional comma + case c of + Nothing -> toList <$> P.sepEndByNonEmpty lp comma <|> pure [] + Just _ -> toList <$> P.sepByNonEmpty lp comma + where + lp = p <* P.spaces + comma = P.char ',' *> P.spaces P. "comma" + +-- | +-- +-- @since 3.4.0.0 +parsecLeadingCommaNonEmpty :: CabalParsing m => m a -> m (NonEmpty a) +parsecLeadingCommaNonEmpty p = do + c <- P.optional comma + case c of + Nothing -> P.sepEndByNonEmpty lp comma + Just _ -> P.sepByNonEmpty lp comma + where + lp = p <* P.spaces + comma = P.char ',' *> P.spaces P. "comma" + +parsecOptCommaList :: CabalParsing m => m a -> m [a] +parsecOptCommaList p = P.sepBy (p <* P.spaces) (P.optional comma) + where + comma = P.char ',' *> P.spaces + +-- | Like 'parsecOptCommaList' but +-- +-- * require all or none commas +-- * accept leading or trailing comma. +-- +-- @ +-- p (comma p)* -- p `sepBy` comma +-- (comma p)* -- leading comma +-- (p comma)* -- trailing comma +-- p* -- no commas: many p +-- @ +-- +-- @since 3.0.0.0 +-- +parsecLeadingOptCommaList :: CabalParsing m => m a -> m [a] +parsecLeadingOptCommaList p = do + c <- P.optional comma + case c of + Nothing -> sepEndBy1Start <|> pure [] + Just _ -> toList <$> P.sepByNonEmpty lp comma + where + lp = p <* P.spaces + comma = P.char ',' *> P.spaces P. "comma" + + sepEndBy1Start = do + x <- lp + c <- P.optional comma + case c of + Nothing -> (x :) <$> many lp + Just _ -> (x :) <$> P.sepEndBy lp comma + +-- | Content isn't unquoted +parsecQuoted :: CabalParsing m => m a -> m a +parsecQuoted = P.between (P.char '"') (P.char '"') + +-- | @parsecMaybeQuoted p = 'parsecQuoted' p <|> p@. +parsecMaybeQuoted :: CabalParsing m => m a -> m a +parsecMaybeQuoted p = parsecQuoted p <|> p + +parsecUnqualComponentName :: forall m. CabalParsing m => m String +parsecUnqualComponentName = state0 DList.empty where + -- + -- using @kleene@ package we can easily see that + -- we need only two states to recognize + -- unqual-component-name + -- + -- Compare with declarative + -- 'Distribution.FieldGrammar.Described.reUnqualComponent'. + -- + -- @ + -- import Kleene + -- import Kleene.Internal.Pretty + -- import Algebra.Lattice + -- import Data.Char + -- + -- import qualified Data.RangeSet.Map as RSet + -- + -- main = do + -- -- this is an approximation, to get an idea. + -- let component :: RE Char + -- component = star alphaNum <> alpha <> star alphaNum + -- + -- alphaNum = alpha \/ num + -- alpha = unions $ map char ['a'..'z'] + -- num = unions $ map char ['0'..'9'] + -- + -- re :: RE Char + -- re = component <> star (char '-' <> component) + -- + -- putPretty re + -- putPretty $ fromTM re + -- @ + + state0 :: DList.DList Char -> m String + state0 acc = do + c <- ch -- <|> fail ("Invalid component, after " ++ DList.toList acc) + case () of + _ | isDigit c -> state0 (DList.snoc acc c) + | isAlphaNum c -> state1 (DList.snoc acc c) + | c == '-' -> fail ("Empty component, after " ++ DList.toList acc) + | otherwise -> fail ("Internal error, after " ++ DList.toList acc) + + state1 :: DList.DList Char -> m String + state1 acc = state1' acc `alt` return (DList.toList acc) + + state1' :: DList.DList Char -> m String + state1' acc = do + c <- ch + case () of + _ | isAlphaNum c -> state1 (DList.snoc acc c) + | c == '-' -> state0 (DList.snoc acc c) + | otherwise -> fail ("Internal error, after " ++ DList.toList acc) + + ch :: m Char + !ch = P.satisfy (\c -> isAlphaNum c || c == '-') + + alt :: m String -> m String -> m String + !alt = (<|>) + +stringLiteral :: forall m. P.CharParsing m => m String +stringLiteral = lit where + lit :: m String + lit = foldr (maybe id (:)) "" + <$> P.between (P.char '"') (P.char '"' P. "end of string") (many stringChar) + P. "string" + + stringChar :: m (Maybe Char) + stringChar = Just <$> stringLetter + <|> stringEscape + P. "string character" + + stringLetter :: m Char + stringLetter = P.satisfy (\c -> (c /= '"') && (c /= '\\') && (c > '\026')) + + stringEscape :: m (Maybe Char) + stringEscape = P.char '\\' *> esc where + esc :: m (Maybe Char) + esc = Nothing <$ escapeGap + <|> Nothing <$ escapeEmpty + <|> Just <$> escapeCode + + escapeEmpty, escapeGap :: m Char + escapeEmpty = P.char '&' + escapeGap = P.skipSpaces1 *> (P.char '\\' P. "end of string gap") + +escapeCode :: forall m. P.CharParsing m => m Char +escapeCode = (charEsc <|> charNum <|> charAscii <|> charControl) P. "escape code" + where + charControl, charNum :: m Char + charControl = (\c -> toEnum (fromEnum c - fromEnum '@')) <$> (P.char '^' *> (P.upper <|> P.char '@')) + charNum = toEnum <$> num + where + num :: m Int + num = bounded 10 maxchar + <|> (P.char 'o' *> bounded 8 maxchar) + <|> (P.char 'x' *> bounded 16 maxchar) + maxchar = fromEnum (maxBound :: Char) + + bounded :: Int -> Int -> m Int + bounded base bnd = foldl' (\x d -> base * x + digitToInt d) 0 + <$> bounded' (take base thedigits) (map digitToInt $ showIntAtBase base intToDigit bnd "") + where + thedigits :: [m Char] + thedigits = map P.char ['0'..'9'] ++ map P.oneOf (transpose [['A'..'F'],['a'..'f']]) + + toomuch :: m a + toomuch = P.unexpected "out-of-range numeric escape sequence" + + bounded', bounded'' :: [m Char] -> [Int] -> m [Char] + bounded' dps@(zero:_) bds = P.skipSome zero *> ([] <$ P.notFollowedBy (P.choice dps) <|> bounded'' dps bds) + <|> bounded'' dps bds + bounded' [] _ = error "bounded called with base 0" + bounded'' dps [] = [] <$ P.notFollowedBy (P.choice dps) <|> toomuch + bounded'' dps (bd : bds) = let anyd :: m Char + anyd = P.choice dps + + nomore :: m () + nomore = P.notFollowedBy anyd <|> toomuch + + (low, ex, high) = case splitAt bd dps of + (low', ex' : high') -> (low', ex', high') + (_, _) -> error "escapeCode: Logic error" + in ((:) <$> P.choice low <*> atMost (length bds) anyd) <* nomore + <|> ((:) <$> ex <*> ([] <$ nomore <|> bounded'' dps bds)) + <|> if not (null bds) + then (:) <$> P.choice high <*> atMost (length bds - 1) anyd <* nomore + else empty + atMost n p | n <= 0 = pure [] + | otherwise = ((:) <$> p <*> atMost (n - 1) p) <|> pure [] + + charEsc :: m Char + charEsc = P.choice $ parseEsc <$> escMap + + parseEsc (c,code) = code <$ P.char c + escMap = zip "abfnrtv\\\"\'" "\a\b\f\n\r\t\v\\\"\'" + + charAscii :: m Char + charAscii = P.choice $ parseAscii <$> asciiMap + + parseAscii (asc,code) = P.try $ code <$ P.string asc + asciiMap = zip (ascii3codes ++ ascii2codes) (ascii3 ++ ascii2) + ascii2codes, ascii3codes :: [String] + ascii2codes = [ "BS","HT","LF","VT","FF","CR","SO" + , "SI","EM","FS","GS","RS","US","SP"] + ascii3codes = ["NUL","SOH","STX","ETX","EOT","ENQ","ACK" + ,"BEL","DLE","DC1","DC2","DC3","DC4","NAK" + ,"SYN","ETB","CAN","SUB","ESC","DEL"] + ascii2, ascii3 :: String + ascii2 = "\BS\HT\LF\VT\FF\CR\SO\SI\EM\FS\GS\RS\US\SP" + ascii3 = "\NUL\SOH\STX\ETX\EOT\ENQ\ACK\BEL\DLE\DC1\DC2\DC3\DC4\NAK\SYN\ETB\CAN\SUB\ESC\DEL" diff --git a/cabal/Cabal-syntax/src/Distribution/Parsec/Error.hs b/cabal/Cabal-syntax/src/Distribution/Parsec/Error.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Parsec/Error.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Parsec.Error ( + PError (..), + showPError, + ) where + +import Distribution.Compat.Prelude +import Distribution.Parsec.Position +import Prelude () +import System.FilePath (normalise) + +-- | Parser error. +data PError = PError Position String + deriving (Show, Generic) + +instance Binary PError +instance NFData PError where rnf = genericRnf + +showPError :: FilePath -> PError -> String +showPError fpath (PError pos msg) = + normalise fpath ++ ":" ++ showPos pos ++ ": " ++ msg diff --git a/cabal/Cabal-syntax/src/Distribution/Parsec/FieldLineStream.hs b/cabal/Cabal-syntax/src/Distribution/Parsec/FieldLineStream.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Parsec/FieldLineStream.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wall -Werror #-} +module Distribution.Parsec.FieldLineStream ( + FieldLineStream (..), + fieldLineStreamFromString, + fieldLineStreamFromBS, + fieldLineStreamEnd, + ) where + +import Data.Bits +import Data.ByteString (ByteString) +import Distribution.Compat.Prelude +import Distribution.Utils.Generic (toUTF8BS) +import Prelude () + +import qualified Data.ByteString as BS +import qualified Text.Parsec as Parsec + +-- | This is essentially a lazy bytestring, but chunks are glued with newline @\'\\n\'@. +data FieldLineStream + = FLSLast !ByteString + | FLSCons {-# UNPACK #-} !ByteString FieldLineStream + deriving Show + +fieldLineStreamEnd :: FieldLineStream +fieldLineStreamEnd = FLSLast mempty + +-- | Convert 'String' to 'FieldLineStream'. +-- +-- /Note:/ inefficient! +fieldLineStreamFromString :: String -> FieldLineStream +fieldLineStreamFromString = FLSLast . toUTF8BS + +fieldLineStreamFromBS :: ByteString -> FieldLineStream +fieldLineStreamFromBS = FLSLast + +instance Monad m => Parsec.Stream FieldLineStream m Char where + uncons (FLSLast bs) = return $ case BS.uncons bs of + Nothing -> Nothing + Just (c, bs') -> Just (unconsChar c bs' (\bs'' -> FLSLast bs'') fieldLineStreamEnd) + + uncons (FLSCons bs s) = return $ case BS.uncons bs of + -- as lines are glued with '\n', we return '\n' here! + Nothing -> Just ('\n', s) + Just (c, bs') -> Just (unconsChar c bs' (\bs'' -> FLSCons bs'' s) s) + +-- Based on implementation 'decodeStringUtf8' +unconsChar :: forall a. Word8 -> ByteString -> (ByteString -> a) -> a -> (Char, a) +unconsChar c0 bs0 f next + | c0 <= 0x7F = (chr (fromIntegral c0), f bs0) + | c0 <= 0xBF = (replacementChar, f bs0) + | c0 <= 0xDF = twoBytes + | c0 <= 0xEF = moreBytes 3 0x800 bs0 (fromIntegral $ c0 .&. 0xF) + | c0 <= 0xF7 = moreBytes 4 0x10000 bs0 (fromIntegral $ c0 .&. 0x7) + | c0 <= 0xFB = moreBytes 5 0x200000 bs0 (fromIntegral $ c0 .&. 0x3) + | c0 <= 0xFD = moreBytes 6 0x4000000 bs0 (fromIntegral $ c0 .&. 0x1) + | otherwise = error $ "not implemented " ++ show c0 + where + twoBytes = case BS.uncons bs0 of + Nothing -> (replacementChar, next) + Just (c1, bs1) + | c1 .&. 0xC0 == 0x80 -> + if d >= 0x80 + then (chr d, f bs1) + else (replacementChar, f bs1) + | otherwise -> (replacementChar, f bs1) + where + d = (fromIntegral (c0 .&. 0x1F) `shiftL` 6) .|. fromIntegral (c1 .&. 0x3F) + + moreBytes :: Int -> Int -> ByteString -> Int -> (Char, a) + moreBytes 1 overlong bs' acc + | overlong <= acc, acc <= 0x10FFFF, acc < 0xD800 || 0xDFFF < acc + = (chr acc, f bs') + | otherwise + = (replacementChar, f bs') + + moreBytes byteCount overlong bs' acc = case BS.uncons bs' of + Nothing -> (replacementChar, f bs') + Just (cn, bs1) + | cn .&. 0xC0 == 0x80 -> moreBytes + (byteCount-1) + overlong + bs1 + ((acc `shiftL` 6) .|. fromIntegral cn .&. 0x3F) + | otherwise -> (replacementChar, f bs1) + +replacementChar :: Char +replacementChar = '\xfffd' diff --git a/cabal/Cabal-syntax/src/Distribution/Parsec/Position.hs b/cabal/Cabal-syntax/src/Distribution/Parsec/Position.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Parsec/Position.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Parsec.Position ( + Position (..), + incPos, + retPos, + showPos, + zeroPos, + positionCol, + positionRow, + ) where + +import Distribution.Compat.Prelude +import Prelude () + +-- | 1-indexed row and column positions in a file. +data Position = Position + {-# UNPACK #-} !Int -- row + {-# UNPACK #-} !Int -- column + deriving (Eq, Ord, Show, Generic) + +instance Binary Position +instance NFData Position where rnf = genericRnf + +-- | Shift position by n columns to the right. +incPos :: Int -> Position -> Position +incPos n (Position row col) = Position row (col + n) + +-- | Shift position to beginning of next row. +retPos :: Position -> Position +retPos (Position row _col) = Position (row + 1) 1 + +showPos :: Position -> String +showPos (Position row col) = show row ++ ":" ++ show col + +zeroPos :: Position +zeroPos = Position 0 0 + +-- | @since 3.0.0.0 +positionCol :: Position -> Int +positionCol (Position _ c) = c + +-- | @since 3.0.0.0 +positionRow :: Position -> Int +positionRow (Position r _) = r diff --git a/cabal/Cabal-syntax/src/Distribution/Parsec/Warning.hs b/cabal/Cabal-syntax/src/Distribution/Parsec/Warning.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Parsec/Warning.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Parsec.Warning ( + PWarning (..), + PWarnType (..), + showPWarning, + ) where + +import Distribution.Compat.Prelude +import Distribution.Parsec.Position +import Prelude () +import System.FilePath (normalise) + +-- | Type of parser warning. We do classify warnings. +-- +-- Different application may decide not to show some, or have fatal behaviour on others +data PWarnType + = PWTOther -- ^ Unclassified warning + | PWTUTF -- ^ Invalid UTF encoding + | PWTBoolCase -- ^ @true@ or @false@, not @True@ or @False@ + | PWTVersionTag -- ^ there are version with tags + | PWTNewSyntax -- ^ New syntax used, but no @cabal-version: >= 1.2@ specified + | PWTOldSyntax -- ^ Old syntax used, and @cabal-version >= 1.2@ specified + | PWTDeprecatedField + | PWTInvalidSubsection + | PWTUnknownField + | PWTUnknownSection + | PWTTrailingFields + | PWTExtraMainIs -- ^ extra main-is field + | PWTExtraTestModule -- ^ extra test-module field + | PWTExtraBenchmarkModule -- ^ extra benchmark-module field + | PWTLexNBSP + | PWTLexBOM + | PWTLexTab + | PWTQuirkyCabalFile -- ^ legacy cabal file that we know how to patch + | PWTDoubleDash -- ^ Double dash token, most likely it's a mistake - it's not a comment + | PWTMultipleSingularField -- ^ e.g. name or version should be specified only once. + | PWTBuildTypeDefault -- ^ Workaround for derive-package having build-type: Default. See . + + | PWTVersionOperator -- ^ Version operators used (without cabal-version: 1.8) + | PWTVersionWildcard -- ^ Version wildcard used (without cabal-version: 1.6) + + | PWTSpecVersion -- ^ Warnings about cabal-version format. + + | PWTEmptyFilePath -- ^ Empty filepath, i.e. literally "" + + | PWTExperimental -- ^ Experimental feature + deriving (Eq, Ord, Show, Enum, Bounded, Generic) + +instance Binary PWarnType +instance NFData PWarnType where rnf = genericRnf + +-- | Parser warning. +data PWarning = PWarning !PWarnType !Position String + deriving (Show, Generic) + +instance Binary PWarning +instance NFData PWarning where rnf = genericRnf + +showPWarning :: FilePath -> PWarning -> String +showPWarning fpath (PWarning _ pos msg) = + normalise fpath ++ ":" ++ showPos pos ++ ": " ++ msg diff --git a/cabal/Cabal-syntax/src/Distribution/Pretty.hs b/cabal/Cabal-syntax/src/Distribution/Pretty.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Pretty.hs @@ -0,0 +1,110 @@ +module Distribution.Pretty ( + Pretty (..), + prettyShow, + defaultStyle, + flatStyle, + -- * Utilities + showFilePath, + showToken, + showTokenStr, + showFreeText, + showFreeTextV3, + -- * Deprecated + Separator, + ) where + +import Distribution.CabalSpecVersion +import Distribution.Compat.Prelude +import Prelude () + +import qualified Text.PrettyPrint as PP + +class Pretty a where + pretty :: a -> PP.Doc + + prettyVersioned :: CabalSpecVersion -> a -> PP.Doc + prettyVersioned _ = pretty + +-- | @since 3.4.0.0 +instance Pretty PP.Doc where + pretty = id + +instance Pretty Bool where + pretty = PP.text . show + +instance Pretty Int where + pretty = PP.text . show + +instance Pretty a => Pretty (Identity a) where + pretty = pretty . runIdentity + +prettyShow :: Pretty a => a -> String +prettyShow = PP.renderStyle defaultStyle . pretty + +-- | The default rendering style used in Cabal for console +-- output. It has a fixed page width and adds line breaks +-- automatically. +defaultStyle :: PP.Style +defaultStyle = PP.Style { PP.mode = PP.PageMode + , PP.lineLength = 79 + , PP.ribbonsPerLine = 1.0 + } + +-- | A style for rendering all on one line. +flatStyle :: PP.Style +flatStyle = PP.Style { PP.mode = PP.LeftMode + , PP.lineLength = err "lineLength" + , PP.ribbonsPerLine = err "ribbonsPerLine" + } + where + err x = error ("flatStyle: tried to access " ++ x ++ " in LeftMode. " ++ + "This should never happen and indicates a bug in Cabal.") + +------------------------------------------------------------------------------- +-- Utilities +------------------------------------------------------------------------------- + +-- TODO: remove when ReadP parser is gone. +type Separator = [PP.Doc] -> PP.Doc + +showFilePath :: FilePath -> PP.Doc +showFilePath = showToken + +showToken :: String -> PP.Doc +showToken = PP.text . showTokenStr + +showTokenStr :: String -> String +showTokenStr str + -- if token looks like a comment (starts with --), print it in quotes + | "--" `isPrefixOf` str = show str + -- also if token ends with a colon (e.g. executable name), print it in quotes + | ":" `isSuffixOf` str = show str + | not (any dodgy str) && not (null str) = str + | otherwise = show str + where + dodgy c = isSpace c || c == ',' + + +-- | Pretty-print free-format text, ensuring that it is vertically aligned, +-- and with blank lines replaced by dots for correct re-parsing. +showFreeText :: String -> PP.Doc +showFreeText "" = mempty +showFreeText s = PP.vcat [ PP.text (if null l then "." else l) | l <- lines_ s ] + +-- | Pretty-print free-format text. +-- Since @cabal-version: 3.0@ we don't replace blank lines with dots. +-- +-- @since 3.0.0.0 +showFreeTextV3 :: String -> PP.Doc +showFreeTextV3 "" = mempty +showFreeTextV3 s = PP.vcat [ PP.text l | l <- lines_ s ] + +-- | 'lines_' breaks a string up into a list of strings at newline +-- characters. The resulting strings do not contain newlines. +lines_ :: String -> [String] +lines_ [] = [""] +lines_ s = + let (l, s') = break (== '\n') s + in l : case s' of + [] -> [] + (_:s'') -> lines_ s'' diff --git a/cabal/Cabal-syntax/src/Distribution/SPDX.hs b/cabal/Cabal-syntax/src/Distribution/SPDX.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/SPDX.hs @@ -0,0 +1,40 @@ +-- | This module implements SPDX specification version 2.1 with a version 3.0 license list. +-- +-- Specification is available on +module Distribution.SPDX ( + -- * License + License (..), + -- * License expression + LicenseExpression (..), + SimpleLicenseExpression (..), + simpleLicenseExpression, + -- * License identifier + LicenseId (..), + licenseId, + licenseName, + licenseIsOsiApproved, + mkLicenseId, + licenseIdList, + -- * License exception + LicenseExceptionId (..), + licenseExceptionId, + licenseExceptionName, + mkLicenseExceptionId, + licenseExceptionIdList, + -- * License reference + LicenseRef, + licenseRef, + licenseDocumentRef, + mkLicenseRef, + mkLicenseRef', + -- * License list version + LicenseListVersion (..), + cabalSpecVersionToSPDXListVersion, + ) where + +import Distribution.SPDX.LicenseExceptionId +import Distribution.SPDX.License +import Distribution.SPDX.LicenseId +import Distribution.SPDX.LicenseExpression +import Distribution.SPDX.LicenseReference +import Distribution.SPDX.LicenseListVersion diff --git a/cabal/Cabal-syntax/src/Distribution/SPDX/License.hs b/cabal/Cabal-syntax/src/Distribution/SPDX/License.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/SPDX/License.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +module Distribution.SPDX.License ( + License (..), + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Pretty +import Distribution.Parsec +import Distribution.SPDX.LicenseExpression + +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as Disp + +-- | Declared license. +-- See [section 3.15 of SPDX Specification 2.1](https://spdx.org/spdx-specification-21-web-version#h.1hmsyys) +-- +-- /Note:/ the NOASSERTION case is omitted. +-- +-- Old 'License' can be migrated using following rules: +-- +-- * @AllRightsReserved@ and @UnspecifiedLicense@ to 'NONE'. +-- No license specified which legally defaults to /All Rights Reserved/. +-- The package may not be legally modified or redistributed by anyone but +-- the rightsholder. +-- +-- * @OtherLicense@ can be converted to 'LicenseRef' pointing to the file +-- in the package. +-- +-- * @UnknownLicense@ i.e. other licenses of the form @name-x.y@, should be +-- covered by SPDX license list, otherwise use 'LicenseRef'. +-- +-- * @PublicDomain@ isn't covered. Consider using CC0. +-- See +-- for more information. +-- +data License + = NONE + -- ^ if the package contains no license information whatsoever; or + | License LicenseExpression + -- ^ A valid SPDX License Expression as defined in Appendix IV. + deriving (Show, Read, Eq, Ord, Typeable, Data, Generic) + +instance Binary License +instance Structured License + +instance NFData License where + rnf NONE = () + rnf (License l) = rnf l + +instance Pretty License where + pretty NONE = Disp.text "NONE" + pretty (License l) = pretty l + +-- | +-- >>> eitherParsec "BSD-3-Clause AND MIT" :: Either String License +-- Right (License (EAnd (ELicense (ELicenseId BSD_3_Clause) Nothing) (ELicense (ELicenseId MIT) Nothing))) +-- +-- >>> eitherParsec "NONE" :: Either String License +-- Right NONE +-- +instance Parsec License where + parsec = NONE <$ P.try (P.string "NONE") <|> License <$> parsec diff --git a/cabal/Cabal-syntax/src/Distribution/SPDX/LicenseExceptionId.hs b/cabal/Cabal-syntax/src/Distribution/SPDX/LicenseExceptionId.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/SPDX/LicenseExceptionId.hs @@ -0,0 +1,338 @@ +-- This file is generated. See Makefile's spdx rule +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +module Distribution.SPDX.LicenseExceptionId ( + LicenseExceptionId (..), + licenseExceptionId, + licenseExceptionName, + mkLicenseExceptionId, + licenseExceptionIdList, + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Compat.Lens (set) +import Distribution.Pretty +import Distribution.Parsec +import Distribution.Utils.Generic (isAsciiAlphaNum) +import Distribution.Utils.Structured (Structured (..), nominalStructure, typeVersion) +import Distribution.SPDX.LicenseListVersion + +import qualified Data.Binary.Get as Binary +import qualified Data.Binary.Put as Binary +import qualified Data.Map.Strict as Map +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as Disp + +------------------------------------------------------------------------------- +-- LicenseExceptionId +------------------------------------------------------------------------------- + +-- | SPDX License Exceptions identifiers list v3.16 +data LicenseExceptionId + = DS389_exception -- ^ @389-exception@, 389 Directory Server Exception + | Autoconf_exception_2_0 -- ^ @Autoconf-exception-2.0@, Autoconf exception 2.0 + | Autoconf_exception_3_0 -- ^ @Autoconf-exception-3.0@, Autoconf exception 3.0 + | Bison_exception_2_2 -- ^ @Bison-exception-2.2@, Bison exception 2.2 + | Bootloader_exception -- ^ @Bootloader-exception@, Bootloader Distribution Exception + | Classpath_exception_2_0 -- ^ @Classpath-exception-2.0@, Classpath exception 2.0 + | CLISP_exception_2_0 -- ^ @CLISP-exception-2.0@, CLISP exception 2.0 + | DigiRule_FOSS_exception -- ^ @DigiRule-FOSS-exception@, DigiRule FOSS License Exception + | ECos_exception_2_0 -- ^ @eCos-exception-2.0@, eCos exception 2.0 + | Fawkes_Runtime_exception -- ^ @Fawkes-Runtime-exception@, Fawkes Runtime Exception + | FLTK_exception -- ^ @FLTK-exception@, FLTK exception + | Font_exception_2_0 -- ^ @Font-exception-2.0@, Font exception 2.0 + | Freertos_exception_2_0 -- ^ @freertos-exception-2.0@, FreeRTOS Exception 2.0 + | GCC_exception_2_0 -- ^ @GCC-exception-2.0@, GCC Runtime Library exception 2.0 + | GCC_exception_3_1 -- ^ @GCC-exception-3.1@, GCC Runtime Library exception 3.1 + | Gnu_javamail_exception -- ^ @gnu-javamail-exception@, GNU JavaMail exception + | GPL_3_0_linking_exception -- ^ @GPL-3.0-linking-exception@, GPL-3.0 Linking Exception, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | GPL_3_0_linking_source_exception -- ^ @GPL-3.0-linking-source-exception@, GPL-3.0 Linking Exception (with Corresponding Source), SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | GPL_CC_1_0 -- ^ @GPL-CC-1.0@, GPL Cooperation Commitment 1.0, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | I2p_gpl_java_exception -- ^ @i2p-gpl-java-exception@, i2p GPL+Java Exception + | LGPL_3_0_linking_exception -- ^ @LGPL-3.0-linking-exception@, LGPL-3.0 Linking Exception, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | Libtool_exception -- ^ @Libtool-exception@, Libtool Exception + | Linux_syscall_note -- ^ @Linux-syscall-note@, Linux Syscall Note + | LLVM_exception -- ^ @LLVM-exception@, LLVM Exception, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | LZMA_exception -- ^ @LZMA-exception@, LZMA exception + | Mif_exception -- ^ @mif-exception@, Macros and Inline Functions Exception + | Nokia_Qt_exception_1_1 -- ^ @Nokia-Qt-exception-1.1@, Nokia Qt LGPL exception 1.1, SPDX License List 3.0, SPDX License List 3.2 + | OCaml_LGPL_linking_exception -- ^ @OCaml-LGPL-linking-exception@, OCaml LGPL Linking Exception, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | OCCT_exception_1_0 -- ^ @OCCT-exception-1.0@, Open CASCADE Exception 1.0 + | OpenJDK_assembly_exception_1_0 -- ^ @OpenJDK-assembly-exception-1.0@, OpenJDK Assembly exception 1.0, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | Openvpn_openssl_exception -- ^ @openvpn-openssl-exception@, OpenVPN OpenSSL Exception + | PS_or_PDF_font_exception_20170817 -- ^ @PS-or-PDF-font-exception-20170817@, PS/PDF font exception (2017-08-17), SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | Qt_GPL_exception_1_0 -- ^ @Qt-GPL-exception-1.0@, Qt GPL exception 1.0, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | Qt_LGPL_exception_1_1 -- ^ @Qt-LGPL-exception-1.1@, Qt LGPL exception 1.1, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | Qwt_exception_1_0 -- ^ @Qwt-exception-1.0@, Qwt exception 1.0 + | SHL_2_0 -- ^ @SHL-2.0@, Solderpad Hardware License v2.0, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | SHL_2_1 -- ^ @SHL-2.1@, Solderpad Hardware License v2.1, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | Swift_exception -- ^ @Swift-exception@, Swift Exception, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | U_boot_exception_2_0 -- ^ @u-boot-exception-2.0@, U-Boot exception 2.0 + | Universal_FOSS_exception_1_0 -- ^ @Universal-FOSS-exception-1.0@, Universal FOSS Exception, Version 1.0, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | WxWindows_exception_3_1 -- ^ @WxWindows-exception-3.1@, WxWindows Library Exception 3.1 + deriving (Eq, Ord, Enum, Bounded, Show, Read, Typeable, Data, Generic) + +instance Binary LicenseExceptionId where + put = Binary.putWord8 . fromIntegral . fromEnum + get = do + i <- Binary.getWord8 + if i > fromIntegral (fromEnum (maxBound :: LicenseExceptionId)) + then fail "Too large LicenseExceptionId tag" + else return (toEnum (fromIntegral i)) + +-- note: remember to bump version each time the definition changes +instance Structured LicenseExceptionId where + structure p = set typeVersion 306 $ nominalStructure p + +instance Pretty LicenseExceptionId where + pretty = Disp.text . licenseExceptionId + +instance Parsec LicenseExceptionId where + parsec = do + n <- some $ P.satisfy $ \c -> isAsciiAlphaNum c || c == '-' || c == '.' + v <- askCabalSpecVersion + maybe (fail $ "Unknown SPDX license exception identifier: " ++ n) return $ + mkLicenseExceptionId (cabalSpecVersionToSPDXListVersion v) n + +instance NFData LicenseExceptionId where + rnf l = l `seq` () + +------------------------------------------------------------------------------- +-- License Data +------------------------------------------------------------------------------- + +-- | License SPDX identifier, e.g. @"BSD-3-Clause"@. +licenseExceptionId :: LicenseExceptionId -> String +licenseExceptionId DS389_exception = "389-exception" +licenseExceptionId Autoconf_exception_2_0 = "Autoconf-exception-2.0" +licenseExceptionId Autoconf_exception_3_0 = "Autoconf-exception-3.0" +licenseExceptionId Bison_exception_2_2 = "Bison-exception-2.2" +licenseExceptionId Bootloader_exception = "Bootloader-exception" +licenseExceptionId Classpath_exception_2_0 = "Classpath-exception-2.0" +licenseExceptionId CLISP_exception_2_0 = "CLISP-exception-2.0" +licenseExceptionId DigiRule_FOSS_exception = "DigiRule-FOSS-exception" +licenseExceptionId ECos_exception_2_0 = "eCos-exception-2.0" +licenseExceptionId Fawkes_Runtime_exception = "Fawkes-Runtime-exception" +licenseExceptionId FLTK_exception = "FLTK-exception" +licenseExceptionId Font_exception_2_0 = "Font-exception-2.0" +licenseExceptionId Freertos_exception_2_0 = "freertos-exception-2.0" +licenseExceptionId GCC_exception_2_0 = "GCC-exception-2.0" +licenseExceptionId GCC_exception_3_1 = "GCC-exception-3.1" +licenseExceptionId Gnu_javamail_exception = "gnu-javamail-exception" +licenseExceptionId GPL_3_0_linking_exception = "GPL-3.0-linking-exception" +licenseExceptionId GPL_3_0_linking_source_exception = "GPL-3.0-linking-source-exception" +licenseExceptionId GPL_CC_1_0 = "GPL-CC-1.0" +licenseExceptionId I2p_gpl_java_exception = "i2p-gpl-java-exception" +licenseExceptionId LGPL_3_0_linking_exception = "LGPL-3.0-linking-exception" +licenseExceptionId Libtool_exception = "Libtool-exception" +licenseExceptionId Linux_syscall_note = "Linux-syscall-note" +licenseExceptionId LLVM_exception = "LLVM-exception" +licenseExceptionId LZMA_exception = "LZMA-exception" +licenseExceptionId Mif_exception = "mif-exception" +licenseExceptionId Nokia_Qt_exception_1_1 = "Nokia-Qt-exception-1.1" +licenseExceptionId OCaml_LGPL_linking_exception = "OCaml-LGPL-linking-exception" +licenseExceptionId OCCT_exception_1_0 = "OCCT-exception-1.0" +licenseExceptionId OpenJDK_assembly_exception_1_0 = "OpenJDK-assembly-exception-1.0" +licenseExceptionId Openvpn_openssl_exception = "openvpn-openssl-exception" +licenseExceptionId PS_or_PDF_font_exception_20170817 = "PS-or-PDF-font-exception-20170817" +licenseExceptionId Qt_GPL_exception_1_0 = "Qt-GPL-exception-1.0" +licenseExceptionId Qt_LGPL_exception_1_1 = "Qt-LGPL-exception-1.1" +licenseExceptionId Qwt_exception_1_0 = "Qwt-exception-1.0" +licenseExceptionId SHL_2_0 = "SHL-2.0" +licenseExceptionId SHL_2_1 = "SHL-2.1" +licenseExceptionId Swift_exception = "Swift-exception" +licenseExceptionId U_boot_exception_2_0 = "u-boot-exception-2.0" +licenseExceptionId Universal_FOSS_exception_1_0 = "Universal-FOSS-exception-1.0" +licenseExceptionId WxWindows_exception_3_1 = "WxWindows-exception-3.1" + +-- | License name, e.g. @"GNU General Public License v2.0 only"@ +licenseExceptionName :: LicenseExceptionId -> String +licenseExceptionName DS389_exception = "389 Directory Server Exception" +licenseExceptionName Autoconf_exception_2_0 = "Autoconf exception 2.0" +licenseExceptionName Autoconf_exception_3_0 = "Autoconf exception 3.0" +licenseExceptionName Bison_exception_2_2 = "Bison exception 2.2" +licenseExceptionName Bootloader_exception = "Bootloader Distribution Exception" +licenseExceptionName Classpath_exception_2_0 = "Classpath exception 2.0" +licenseExceptionName CLISP_exception_2_0 = "CLISP exception 2.0" +licenseExceptionName DigiRule_FOSS_exception = "DigiRule FOSS License Exception" +licenseExceptionName ECos_exception_2_0 = "eCos exception 2.0" +licenseExceptionName Fawkes_Runtime_exception = "Fawkes Runtime Exception" +licenseExceptionName FLTK_exception = "FLTK exception" +licenseExceptionName Font_exception_2_0 = "Font exception 2.0" +licenseExceptionName Freertos_exception_2_0 = "FreeRTOS Exception 2.0" +licenseExceptionName GCC_exception_2_0 = "GCC Runtime Library exception 2.0" +licenseExceptionName GCC_exception_3_1 = "GCC Runtime Library exception 3.1" +licenseExceptionName Gnu_javamail_exception = "GNU JavaMail exception" +licenseExceptionName GPL_3_0_linking_exception = "GPL-3.0 Linking Exception" +licenseExceptionName GPL_3_0_linking_source_exception = "GPL-3.0 Linking Exception (with Corresponding Source)" +licenseExceptionName GPL_CC_1_0 = "GPL Cooperation Commitment 1.0" +licenseExceptionName I2p_gpl_java_exception = "i2p GPL+Java Exception" +licenseExceptionName LGPL_3_0_linking_exception = "LGPL-3.0 Linking Exception" +licenseExceptionName Libtool_exception = "Libtool Exception" +licenseExceptionName Linux_syscall_note = "Linux Syscall Note" +licenseExceptionName LLVM_exception = "LLVM Exception" +licenseExceptionName LZMA_exception = "LZMA exception" +licenseExceptionName Mif_exception = "Macros and Inline Functions Exception" +licenseExceptionName Nokia_Qt_exception_1_1 = "Nokia Qt LGPL exception 1.1" +licenseExceptionName OCaml_LGPL_linking_exception = "OCaml LGPL Linking Exception" +licenseExceptionName OCCT_exception_1_0 = "Open CASCADE Exception 1.0" +licenseExceptionName OpenJDK_assembly_exception_1_0 = "OpenJDK Assembly exception 1.0" +licenseExceptionName Openvpn_openssl_exception = "OpenVPN OpenSSL Exception" +licenseExceptionName PS_or_PDF_font_exception_20170817 = "PS/PDF font exception (2017-08-17)" +licenseExceptionName Qt_GPL_exception_1_0 = "Qt GPL exception 1.0" +licenseExceptionName Qt_LGPL_exception_1_1 = "Qt LGPL exception 1.1" +licenseExceptionName Qwt_exception_1_0 = "Qwt exception 1.0" +licenseExceptionName SHL_2_0 = "Solderpad Hardware License v2.0" +licenseExceptionName SHL_2_1 = "Solderpad Hardware License v2.1" +licenseExceptionName Swift_exception = "Swift Exception" +licenseExceptionName U_boot_exception_2_0 = "U-Boot exception 2.0" +licenseExceptionName Universal_FOSS_exception_1_0 = "Universal FOSS Exception, Version 1.0" +licenseExceptionName WxWindows_exception_3_1 = "WxWindows Library Exception 3.1" + +------------------------------------------------------------------------------- +-- Creation +------------------------------------------------------------------------------- + +licenseExceptionIdList :: LicenseListVersion -> [LicenseExceptionId] +licenseExceptionIdList LicenseListVersion_3_0 = + [ Nokia_Qt_exception_1_1 + ] + ++ bulkOfLicenses +licenseExceptionIdList LicenseListVersion_3_2 = + [ LLVM_exception + , Nokia_Qt_exception_1_1 + , OpenJDK_assembly_exception_1_0 + , PS_or_PDF_font_exception_20170817 + , Qt_GPL_exception_1_0 + , Qt_LGPL_exception_1_1 + ] + ++ bulkOfLicenses +licenseExceptionIdList LicenseListVersion_3_6 = + [ GPL_CC_1_0 + , LLVM_exception + , OCaml_LGPL_linking_exception + , OpenJDK_assembly_exception_1_0 + , PS_or_PDF_font_exception_20170817 + , Qt_GPL_exception_1_0 + , Qt_LGPL_exception_1_1 + , Swift_exception + , Universal_FOSS_exception_1_0 + ] + ++ bulkOfLicenses +licenseExceptionIdList LicenseListVersion_3_9 = + [ GPL_3_0_linking_exception + , GPL_3_0_linking_source_exception + , GPL_CC_1_0 + , LGPL_3_0_linking_exception + , LLVM_exception + , OCaml_LGPL_linking_exception + , OpenJDK_assembly_exception_1_0 + , PS_or_PDF_font_exception_20170817 + , Qt_GPL_exception_1_0 + , Qt_LGPL_exception_1_1 + , SHL_2_0 + , SHL_2_1 + , Swift_exception + , Universal_FOSS_exception_1_0 + ] + ++ bulkOfLicenses +licenseExceptionIdList LicenseListVersion_3_10 = + [ GPL_3_0_linking_exception + , GPL_3_0_linking_source_exception + , GPL_CC_1_0 + , LGPL_3_0_linking_exception + , LLVM_exception + , OCaml_LGPL_linking_exception + , OpenJDK_assembly_exception_1_0 + , PS_or_PDF_font_exception_20170817 + , Qt_GPL_exception_1_0 + , Qt_LGPL_exception_1_1 + , SHL_2_0 + , SHL_2_1 + , Swift_exception + , Universal_FOSS_exception_1_0 + ] + ++ bulkOfLicenses +licenseExceptionIdList LicenseListVersion_3_16 = + [ GPL_3_0_linking_exception + , GPL_3_0_linking_source_exception + , GPL_CC_1_0 + , LGPL_3_0_linking_exception + , LLVM_exception + , OCaml_LGPL_linking_exception + , OpenJDK_assembly_exception_1_0 + , PS_or_PDF_font_exception_20170817 + , Qt_GPL_exception_1_0 + , Qt_LGPL_exception_1_1 + , SHL_2_0 + , SHL_2_1 + , Swift_exception + , Universal_FOSS_exception_1_0 + ] + ++ bulkOfLicenses + +-- | Create a 'LicenseExceptionId' from a 'String'. +mkLicenseExceptionId :: LicenseListVersion -> String -> Maybe LicenseExceptionId +mkLicenseExceptionId LicenseListVersion_3_0 s = Map.lookup s stringLookup_3_0 +mkLicenseExceptionId LicenseListVersion_3_2 s = Map.lookup s stringLookup_3_2 +mkLicenseExceptionId LicenseListVersion_3_6 s = Map.lookup s stringLookup_3_6 +mkLicenseExceptionId LicenseListVersion_3_9 s = Map.lookup s stringLookup_3_9 +mkLicenseExceptionId LicenseListVersion_3_10 s = Map.lookup s stringLookup_3_10 +mkLicenseExceptionId LicenseListVersion_3_16 s = Map.lookup s stringLookup_3_16 + +stringLookup_3_0 :: Map String LicenseExceptionId +stringLookup_3_0 = Map.fromList $ map (\i -> (licenseExceptionId i, i)) $ + licenseExceptionIdList LicenseListVersion_3_0 + +stringLookup_3_2 :: Map String LicenseExceptionId +stringLookup_3_2 = Map.fromList $ map (\i -> (licenseExceptionId i, i)) $ + licenseExceptionIdList LicenseListVersion_3_2 + +stringLookup_3_6 :: Map String LicenseExceptionId +stringLookup_3_6 = Map.fromList $ map (\i -> (licenseExceptionId i, i)) $ + licenseExceptionIdList LicenseListVersion_3_6 + +stringLookup_3_9 :: Map String LicenseExceptionId +stringLookup_3_9 = Map.fromList $ map (\i -> (licenseExceptionId i, i)) $ + licenseExceptionIdList LicenseListVersion_3_9 + +stringLookup_3_10 :: Map String LicenseExceptionId +stringLookup_3_10 = Map.fromList $ map (\i -> (licenseExceptionId i, i)) $ + licenseExceptionIdList LicenseListVersion_3_10 + +stringLookup_3_16 :: Map String LicenseExceptionId +stringLookup_3_16 = Map.fromList $ map (\i -> (licenseExceptionId i, i)) $ + licenseExceptionIdList LicenseListVersion_3_16 + +-- | License exceptions in all SPDX License lists +bulkOfLicenses :: [LicenseExceptionId] +bulkOfLicenses = + [ DS389_exception + , Autoconf_exception_2_0 + , Autoconf_exception_3_0 + , Bison_exception_2_2 + , Bootloader_exception + , Classpath_exception_2_0 + , CLISP_exception_2_0 + , DigiRule_FOSS_exception + , ECos_exception_2_0 + , Fawkes_Runtime_exception + , FLTK_exception + , Font_exception_2_0 + , Freertos_exception_2_0 + , GCC_exception_2_0 + , GCC_exception_3_1 + , Gnu_javamail_exception + , I2p_gpl_java_exception + , Libtool_exception + , Linux_syscall_note + , LZMA_exception + , Mif_exception + , OCCT_exception_1_0 + , Openvpn_openssl_exception + , Qwt_exception_1_0 + , U_boot_exception_2_0 + , WxWindows_exception_3_1 + ] diff --git a/cabal/Cabal-syntax/src/Distribution/SPDX/LicenseExpression.hs b/cabal/Cabal-syntax/src/Distribution/SPDX/LicenseExpression.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/SPDX/LicenseExpression.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +module Distribution.SPDX.LicenseExpression ( + LicenseExpression (..), + SimpleLicenseExpression (..), + simpleLicenseExpression, + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Parsec +import Distribution.Pretty +import Distribution.SPDX.LicenseExceptionId +import Distribution.SPDX.LicenseId +import Distribution.SPDX.LicenseListVersion +import Distribution.SPDX.LicenseReference +import Distribution.Utils.Generic (isAsciiAlphaNum) + +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as Disp + +-- | SPDX License Expression. +-- +-- @ +-- idstring = 1*(ALPHA \/ DIGIT \/ "-" \/ "." ) +-- license id = \ +-- license exception id = \ +-- license ref = [\"DocumentRef-"1*(idstring)":"]\"LicenseRef-"1*(idstring) +-- +-- simple expression = license id \/ license id"+" \/ license ref +-- +-- compound expression = 1*1(simple expression \/ +-- simple expression \"WITH" license exception id \/ +-- compound expression \"AND" compound expression \/ +-- compound expression \"OR" compound expression ) \/ +-- "(" compound expression ")" ) +-- +-- license expression = 1*1(simple expression / compound expression) +-- @ +data LicenseExpression + = ELicense !SimpleLicenseExpression !(Maybe LicenseExceptionId) + | EAnd !LicenseExpression !LicenseExpression + | EOr !LicenseExpression !LicenseExpression + deriving (Show, Read, Eq, Ord, Typeable, Data, Generic) + +-- | Simple License Expressions. +data SimpleLicenseExpression + = ELicenseId LicenseId + -- ^ An SPDX License List Short Form Identifier. For example: @GPL-2.0-only@ + | ELicenseIdPlus LicenseId + -- ^ An SPDX License List Short Form Identifier with a unary"+" operator suffix to represent the current version of the license or any later version. For example: @GPL-2.0+@ + | ELicenseRef LicenseRef + -- ^ A SPDX user defined license reference: For example: @LicenseRef-23@, @LicenseRef-MIT-Style-1@, or @DocumentRef-spdx-tool-1.2:LicenseRef-MIT-Style-2@ + deriving (Show, Read, Eq, Ord, Typeable, Data, Generic) + +simpleLicenseExpression :: LicenseId -> LicenseExpression +simpleLicenseExpression i = ELicense (ELicenseId i) Nothing + +instance Binary LicenseExpression +instance Binary SimpleLicenseExpression +instance Structured SimpleLicenseExpression +instance Structured LicenseExpression + +instance Pretty LicenseExpression where + pretty = go 0 + where + go :: Int -> LicenseExpression -> Disp.Doc + go _ (ELicense lic exc) = + let doc = pretty lic + in maybe id (\e d -> d <+> Disp.text "WITH" <+> pretty e) exc doc + go d (EAnd e1 e2) = parens (d < 0) $ go 0 e1 <+> Disp.text "AND" <+> go 0 e2 + go d (EOr e1 e2) = parens (d < 1) $ go 1 e1 <+> Disp.text "OR" <+> go 1 e2 + + + parens False doc = doc + parens True doc = Disp.parens doc + +instance Pretty SimpleLicenseExpression where + pretty (ELicenseId i) = pretty i + pretty (ELicenseIdPlus i) = pretty i <<>> Disp.char '+' + pretty (ELicenseRef r) = pretty r + +instance Parsec SimpleLicenseExpression where + parsec = idstring >>= simple where + simple n + | Just l <- "LicenseRef-" `isPrefixOfMaybe` n = + maybe (fail $ "Incorrect LicenseRef format: " ++ n) (return . ELicenseRef) $ mkLicenseRef Nothing l + | Just d <- "DocumentRef-" `isPrefixOfMaybe` n = do + _ <- P.string ":LicenseRef-" + l <- idstring + maybe (fail $ "Incorrect LicenseRef format:" ++ n) (return . ELicenseRef) $ mkLicenseRef (Just d) l + | otherwise = do + v <- askCabalSpecVersion + l <- maybe (fail $ "Unknown SPDX license identifier: '" ++ n ++ "' " ++ licenseIdMigrationMessage n) return $ + mkLicenseId (cabalSpecVersionToSPDXListVersion v) n + orLater <- isJust <$> P.optional (P.char '+') + if orLater + then return (ELicenseIdPlus l) + else return (ELicenseId l) + +idstring :: P.CharParsing m => m String +idstring = P.munch1 $ \c -> isAsciiAlphaNum c || c == '-' || c == '.' + +-- returns suffix part +isPrefixOfMaybe :: Eq a => [a] -> [a] -> Maybe [a] +isPrefixOfMaybe pfx s + | pfx `isPrefixOf` s = Just (drop (length pfx) s) + | otherwise = Nothing + +instance Parsec LicenseExpression where + parsec = expr + where + expr = compoundOr + + simple = do + s <- parsec + exc <- exception + return $ ELicense s exc + + exception = P.optional $ P.try (spaces1 *> P.string "WITH" *> spaces1) *> parsec + + compoundOr = do + x <- compoundAnd + l <- P.optional $ P.try (spaces1 *> P.string "OR" *> spaces1) *> compoundOr + return $ maybe id (flip EOr) l x + + compoundAnd = do + x <- compound + l <- P.optional $ P.try (spaces1 *> P.string "AND" *> spaces1) *> compoundAnd + return $ maybe id (flip EAnd) l x + + compound = braces <|> simple + + -- NOTE: we require that there's a space around AND & OR operators, + -- i.e. @(MIT)AND(MIT)@ will cause parse-error. + braces = do + _ <- P.char '(' + _ <- P.spaces + x <- expr + _ <- P.char ')' + return x + + spaces1 = P.space *> P.spaces + +-- notes: +-- +-- There MUST NOT be whitespace between a license­id and any following "+".  This supports easy parsing and +-- backwards compatibility.  There MUST be whitespace on either side of the operator "WITH".  There MUST be +-- whitespace and/or parentheses on either side of the operators "AND" and "OR". +-- +-- We handle that by having greedy 'idstring' parser, so MITAND would parse as invalid license identifier. + +instance NFData LicenseExpression where + rnf (ELicense s e) = rnf s `seq` rnf e + rnf (EAnd x y) = rnf x `seq` rnf y + rnf (EOr x y) = rnf x `seq` rnf y + +instance NFData SimpleLicenseExpression where + rnf (ELicenseId i) = rnf i + rnf (ELicenseIdPlus i) = rnf i + rnf (ELicenseRef r) = rnf r diff --git a/cabal/Cabal-syntax/src/Distribution/SPDX/LicenseId.hs b/cabal/Cabal-syntax/src/Distribution/SPDX/LicenseId.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/SPDX/LicenseId.hs @@ -0,0 +1,2432 @@ +-- This file is generated. See Makefile's spdx rule +{-# LANGUAGE DeriveDataTypeable #-} +module Distribution.SPDX.LicenseId ( + LicenseId (..), + licenseId, + licenseName, + licenseIsOsiApproved, + licenseIsFsfLibre, + mkLicenseId, + licenseIdList, + -- * Helpers + licenseIdMigrationMessage, + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Compat.Lens (set) +import Distribution.Pretty +import Distribution.Parsec +import Distribution.Utils.Generic (isAsciiAlphaNum) +import Distribution.Utils.Structured (Structured (..), nominalStructure, typeVersion) +import Distribution.SPDX.LicenseListVersion + +import qualified Data.Binary.Get as Binary +import qualified Data.Binary.Put as Binary +import qualified Data.Map.Strict as Map +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as Disp + +------------------------------------------------------------------------------- +-- LicenseId +------------------------------------------------------------------------------- + +-- | SPDX License identifiers list v3.16 +data LicenseId + = NullBSD -- ^ @0BSD@, BSD Zero Clause License + | AAL -- ^ @AAL@, Attribution Assurance License + | Abstyles -- ^ @Abstyles@, Abstyles License + | Adobe_2006 -- ^ @Adobe-2006@, Adobe Systems Incorporated Source Code License Agreement + | Adobe_Glyph -- ^ @Adobe-Glyph@, Adobe Glyph List License + | ADSL -- ^ @ADSL@, Amazon Digital Services License + | AFL_1_1 -- ^ @AFL-1.1@, Academic Free License v1.1 + | AFL_1_2 -- ^ @AFL-1.2@, Academic Free License v1.2 + | AFL_2_0 -- ^ @AFL-2.0@, Academic Free License v2.0 + | AFL_2_1 -- ^ @AFL-2.1@, Academic Free License v2.1 + | AFL_3_0 -- ^ @AFL-3.0@, Academic Free License v3.0 + | Afmparse -- ^ @Afmparse@, Afmparse License + | AGPL_1_0 -- ^ @AGPL-1.0@, Affero General Public License v1.0, SPDX License List 3.0 + | AGPL_1_0_only -- ^ @AGPL-1.0-only@, Affero General Public License v1.0 only, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | AGPL_1_0_or_later -- ^ @AGPL-1.0-or-later@, Affero General Public License v1.0 or later, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | AGPL_3_0_only -- ^ @AGPL-3.0-only@, GNU Affero General Public License v3.0 only + | AGPL_3_0_or_later -- ^ @AGPL-3.0-or-later@, GNU Affero General Public License v3.0 or later + | Aladdin -- ^ @Aladdin@, Aladdin Free Public License + | AMDPLPA -- ^ @AMDPLPA@, AMD's plpa_map.c License + | AML -- ^ @AML@, Apple MIT License + | AMPAS -- ^ @AMPAS@, Academy of Motion Picture Arts and Sciences BSD + | ANTLR_PD_fallback -- ^ @ANTLR-PD-fallback@, ANTLR Software Rights Notice with license fallback, SPDX License List 3.16 + | ANTLR_PD -- ^ @ANTLR-PD@, ANTLR Software Rights Notice + | Apache_1_0 -- ^ @Apache-1.0@, Apache License 1.0 + | Apache_1_1 -- ^ @Apache-1.1@, Apache License 1.1 + | Apache_2_0 -- ^ @Apache-2.0@, Apache License 2.0 + | APAFML -- ^ @APAFML@, Adobe Postscript AFM License + | APL_1_0 -- ^ @APL-1.0@, Adaptive Public License 1.0 + | App_s2p -- ^ @App-s2p@, App::s2p License, SPDX License List 3.16 + | APSL_1_0 -- ^ @APSL-1.0@, Apple Public Source License 1.0 + | APSL_1_1 -- ^ @APSL-1.1@, Apple Public Source License 1.1 + | APSL_1_2 -- ^ @APSL-1.2@, Apple Public Source License 1.2 + | APSL_2_0 -- ^ @APSL-2.0@, Apple Public Source License 2.0 + | Artistic_1_0_cl8 -- ^ @Artistic-1.0-cl8@, Artistic License 1.0 w/clause 8 + | Artistic_1_0_Perl -- ^ @Artistic-1.0-Perl@, Artistic License 1.0 (Perl) + | Artistic_1_0 -- ^ @Artistic-1.0@, Artistic License 1.0 + | Artistic_2_0 -- ^ @Artistic-2.0@, Artistic License 2.0 + | Bahyph -- ^ @Bahyph@, Bahyph License + | Barr -- ^ @Barr@, Barr License + | Beerware -- ^ @Beerware@, Beerware License + | BitTorrent_1_0 -- ^ @BitTorrent-1.0@, BitTorrent Open Source License v1.0 + | BitTorrent_1_1 -- ^ @BitTorrent-1.1@, BitTorrent Open Source License v1.1 + | Blessing -- ^ @blessing@, SQLite Blessing, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | BlueOak_1_0_0 -- ^ @BlueOak-1.0.0@, Blue Oak Model License 1.0.0, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | Borceux -- ^ @Borceux@, Borceux license + | BSD_1_Clause -- ^ @BSD-1-Clause@, BSD 1-Clause License + | BSD_2_Clause_FreeBSD -- ^ @BSD-2-Clause-FreeBSD@, BSD 2-Clause FreeBSD License, SPDX License List 3.0, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9 + | BSD_2_Clause_NetBSD -- ^ @BSD-2-Clause-NetBSD@, BSD 2-Clause NetBSD License, SPDX License List 3.0, SPDX License List 3.2, SPDX License List 3.6 + | BSD_2_Clause_Patent -- ^ @BSD-2-Clause-Patent@, BSD-2-Clause Plus Patent License + | BSD_2_Clause_Views -- ^ @BSD-2-Clause-Views@, BSD 2-Clause with views sentence, SPDX License List 3.10, SPDX License List 3.16 + | BSD_2_Clause -- ^ @BSD-2-Clause@, BSD 2-Clause "Simplified" License + | BSD_3_Clause_Attribution -- ^ @BSD-3-Clause-Attribution@, BSD with attribution + | BSD_3_Clause_Clear -- ^ @BSD-3-Clause-Clear@, BSD 3-Clause Clear License + | BSD_3_Clause_LBNL -- ^ @BSD-3-Clause-LBNL@, Lawrence Berkeley National Labs BSD variant license + | BSD_3_Clause_Modification -- ^ @BSD-3-Clause-Modification@, BSD 3-Clause Modification, SPDX License List 3.16 + | BSD_3_Clause_No_Military_License -- ^ @BSD-3-Clause-No-Military-License@, BSD 3-Clause No Military License, SPDX License List 3.16 + | BSD_3_Clause_No_Nuclear_License_2014 -- ^ @BSD-3-Clause-No-Nuclear-License-2014@, BSD 3-Clause No Nuclear License 2014 + | BSD_3_Clause_No_Nuclear_License -- ^ @BSD-3-Clause-No-Nuclear-License@, BSD 3-Clause No Nuclear License + | BSD_3_Clause_No_Nuclear_Warranty -- ^ @BSD-3-Clause-No-Nuclear-Warranty@, BSD 3-Clause No Nuclear Warranty + | BSD_3_Clause_Open_MPI -- ^ @BSD-3-Clause-Open-MPI@, BSD 3-Clause Open MPI variant, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | BSD_3_Clause -- ^ @BSD-3-Clause@, BSD 3-Clause "New" or "Revised" License + | BSD_4_Clause_Shortened -- ^ @BSD-4-Clause-Shortened@, BSD 4 Clause Shortened, SPDX License List 3.16 + | BSD_4_Clause_UC -- ^ @BSD-4-Clause-UC@, BSD-4-Clause (University of California-Specific) + | BSD_4_Clause -- ^ @BSD-4-Clause@, BSD 4-Clause "Original" or "Old" License + | BSD_Protection -- ^ @BSD-Protection@, BSD Protection License + | BSD_Source_Code -- ^ @BSD-Source-Code@, BSD Source Code Attribution + | BSL_1_0 -- ^ @BSL-1.0@, Boost Software License 1.0 + | Bzip2_1_0_5 -- ^ @bzip2-1.0.5@, bzip2 and libbzip2 License v1.0.5, SPDX License List 3.0, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 + | BUSL_1_1 -- ^ @BUSL-1.1@, Business Source License 1.1, SPDX License List 3.16 + | Bzip2_1_0_6 -- ^ @bzip2-1.0.6@, bzip2 and libbzip2 License v1.0.6 + | C_UDA_1_0 -- ^ @C-UDA-1.0@, Computational Use of Data Agreement v1.0, SPDX License List 3.16 + | CAL_1_0_Combined_Work_Exception -- ^ @CAL-1.0-Combined-Work-Exception@, Cryptographic Autonomy License 1.0 (Combined Work Exception), SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | CAL_1_0 -- ^ @CAL-1.0@, Cryptographic Autonomy License 1.0, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | Caldera -- ^ @Caldera@, Caldera License + | CATOSL_1_1 -- ^ @CATOSL-1.1@, Computer Associates Trusted Open Source License 1.1 + | CC_BY_1_0 -- ^ @CC-BY-1.0@, Creative Commons Attribution 1.0 Generic + | CC_BY_2_0 -- ^ @CC-BY-2.0@, Creative Commons Attribution 2.0 Generic + | CC_BY_2_5_AU -- ^ @CC-BY-2.5-AU@, Creative Commons Attribution 2.5 Australia, SPDX License List 3.16 + | CC_BY_2_5 -- ^ @CC-BY-2.5@, Creative Commons Attribution 2.5 Generic + | CC_BY_3_0_AT -- ^ @CC-BY-3.0-AT@, Creative Commons Attribution 3.0 Austria, SPDX License List 3.10, SPDX License List 3.16 + | CC_BY_3_0_DE -- ^ @CC-BY-3.0-DE@, Creative Commons Attribution 3.0 Germany, SPDX License List 3.16 + | CC_BY_3_0_NL -- ^ @CC-BY-3.0-NL@, Creative Commons Attribution 3.0 Netherlands, SPDX License List 3.16 + | CC_BY_3_0_US -- ^ @CC-BY-3.0-US@, Creative Commons Attribution 3.0 United States, SPDX License List 3.16 + | CC_BY_3_0 -- ^ @CC-BY-3.0@, Creative Commons Attribution 3.0 Unported + | CC_BY_4_0 -- ^ @CC-BY-4.0@, Creative Commons Attribution 4.0 International + | CC_BY_NC_1_0 -- ^ @CC-BY-NC-1.0@, Creative Commons Attribution Non Commercial 1.0 Generic + | CC_BY_NC_2_0 -- ^ @CC-BY-NC-2.0@, Creative Commons Attribution Non Commercial 2.0 Generic + | CC_BY_NC_2_5 -- ^ @CC-BY-NC-2.5@, Creative Commons Attribution Non Commercial 2.5 Generic + | CC_BY_NC_3_0_DE -- ^ @CC-BY-NC-3.0-DE@, Creative Commons Attribution Non Commercial 3.0 Germany, SPDX License List 3.16 + | CC_BY_NC_3_0 -- ^ @CC-BY-NC-3.0@, Creative Commons Attribution Non Commercial 3.0 Unported + | CC_BY_NC_4_0 -- ^ @CC-BY-NC-4.0@, Creative Commons Attribution Non Commercial 4.0 International + | CC_BY_NC_ND_1_0 -- ^ @CC-BY-NC-ND-1.0@, Creative Commons Attribution Non Commercial No Derivatives 1.0 Generic + | CC_BY_NC_ND_2_0 -- ^ @CC-BY-NC-ND-2.0@, Creative Commons Attribution Non Commercial No Derivatives 2.0 Generic + | CC_BY_NC_ND_2_5 -- ^ @CC-BY-NC-ND-2.5@, Creative Commons Attribution Non Commercial No Derivatives 2.5 Generic + | CC_BY_NC_ND_3_0_DE -- ^ @CC-BY-NC-ND-3.0-DE@, Creative Commons Attribution Non Commercial No Derivatives 3.0 Germany, SPDX License List 3.16 + | CC_BY_NC_ND_3_0_IGO -- ^ @CC-BY-NC-ND-3.0-IGO@, Creative Commons Attribution Non Commercial No Derivatives 3.0 IGO, SPDX License List 3.10, SPDX License List 3.16 + | CC_BY_NC_ND_3_0 -- ^ @CC-BY-NC-ND-3.0@, Creative Commons Attribution Non Commercial No Derivatives 3.0 Unported + | CC_BY_NC_ND_4_0 -- ^ @CC-BY-NC-ND-4.0@, Creative Commons Attribution Non Commercial No Derivatives 4.0 International + | CC_BY_NC_SA_1_0 -- ^ @CC-BY-NC-SA-1.0@, Creative Commons Attribution Non Commercial Share Alike 1.0 Generic + | CC_BY_NC_SA_2_0_FR -- ^ @CC-BY-NC-SA-2.0-FR@, Creative Commons Attribution-NonCommercial-ShareAlike 2.0 France, SPDX License List 3.16 + | CC_BY_NC_SA_2_0_UK -- ^ @CC-BY-NC-SA-2.0-UK@, Creative Commons Attribution Non Commercial Share Alike 2.0 England and Wales, SPDX License List 3.16 + | CC_BY_NC_SA_2_0 -- ^ @CC-BY-NC-SA-2.0@, Creative Commons Attribution Non Commercial Share Alike 2.0 Generic + | CC_BY_NC_SA_2_5 -- ^ @CC-BY-NC-SA-2.5@, Creative Commons Attribution Non Commercial Share Alike 2.5 Generic + | CC_BY_NC_SA_3_0_DE -- ^ @CC-BY-NC-SA-3.0-DE@, Creative Commons Attribution Non Commercial Share Alike 3.0 Germany, SPDX License List 3.16 + | CC_BY_NC_SA_3_0_IGO -- ^ @CC-BY-NC-SA-3.0-IGO@, Creative Commons Attribution Non Commercial Share Alike 3.0 IGO, SPDX License List 3.16 + | CC_BY_NC_SA_3_0 -- ^ @CC-BY-NC-SA-3.0@, Creative Commons Attribution Non Commercial Share Alike 3.0 Unported + | CC_BY_NC_SA_4_0 -- ^ @CC-BY-NC-SA-4.0@, Creative Commons Attribution Non Commercial Share Alike 4.0 International + | CC_BY_ND_1_0 -- ^ @CC-BY-ND-1.0@, Creative Commons Attribution No Derivatives 1.0 Generic + | CC_BY_ND_2_0 -- ^ @CC-BY-ND-2.0@, Creative Commons Attribution No Derivatives 2.0 Generic + | CC_BY_ND_2_5 -- ^ @CC-BY-ND-2.5@, Creative Commons Attribution No Derivatives 2.5 Generic + | CC_BY_ND_3_0_DE -- ^ @CC-BY-ND-3.0-DE@, Creative Commons Attribution No Derivatives 3.0 Germany, SPDX License List 3.16 + | CC_BY_ND_3_0 -- ^ @CC-BY-ND-3.0@, Creative Commons Attribution No Derivatives 3.0 Unported + | CC_BY_ND_4_0 -- ^ @CC-BY-ND-4.0@, Creative Commons Attribution No Derivatives 4.0 International + | CC_BY_SA_1_0 -- ^ @CC-BY-SA-1.0@, Creative Commons Attribution Share Alike 1.0 Generic + | CC_BY_SA_2_0_UK -- ^ @CC-BY-SA-2.0-UK@, Creative Commons Attribution Share Alike 2.0 England and Wales, SPDX License List 3.16 + | CC_BY_SA_2_0 -- ^ @CC-BY-SA-2.0@, Creative Commons Attribution Share Alike 2.0 Generic + | CC_BY_SA_2_1_JP -- ^ @CC-BY-SA-2.1-JP@, Creative Commons Attribution Share Alike 2.1 Japan, SPDX License List 3.16 + | CC_BY_SA_2_5 -- ^ @CC-BY-SA-2.5@, Creative Commons Attribution Share Alike 2.5 Generic + | CC_BY_SA_3_0_AT -- ^ @CC-BY-SA-3.0-AT@, Creative Commons Attribution Share Alike 3.0 Austria, SPDX License List 3.10, SPDX License List 3.16 + | CC_BY_SA_3_0_DE -- ^ @CC-BY-SA-3.0-DE@, Creative Commons Attribution Share Alike 3.0 Germany, SPDX License List 3.16 + | CC_BY_SA_3_0 -- ^ @CC-BY-SA-3.0@, Creative Commons Attribution Share Alike 3.0 Unported + | CC_BY_SA_4_0 -- ^ @CC-BY-SA-4.0@, Creative Commons Attribution Share Alike 4.0 International + | CC_PDDC -- ^ @CC-PDDC@, Creative Commons Public Domain Dedication and Certification, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | CC0_1_0 -- ^ @CC0-1.0@, Creative Commons Zero v1.0 Universal + | CDDL_1_0 -- ^ @CDDL-1.0@, Common Development and Distribution License 1.0 + | CDDL_1_1 -- ^ @CDDL-1.1@, Common Development and Distribution License 1.1 + | CDL_1_0 -- ^ @CDL-1.0@, Common Documentation License 1.0, SPDX License List 3.16 + | CDLA_Permissive_1_0 -- ^ @CDLA-Permissive-1.0@, Community Data License Agreement Permissive 1.0 + | CDLA_Permissive_2_0 -- ^ @CDLA-Permissive-2.0@, Community Data License Agreement Permissive 2.0, SPDX License List 3.16 + | CDLA_Sharing_1_0 -- ^ @CDLA-Sharing-1.0@, Community Data License Agreement Sharing 1.0 + | CECILL_1_0 -- ^ @CECILL-1.0@, CeCILL Free Software License Agreement v1.0 + | CECILL_1_1 -- ^ @CECILL-1.1@, CeCILL Free Software License Agreement v1.1 + | CECILL_2_0 -- ^ @CECILL-2.0@, CeCILL Free Software License Agreement v2.0 + | CECILL_2_1 -- ^ @CECILL-2.1@, CeCILL Free Software License Agreement v2.1 + | CECILL_B -- ^ @CECILL-B@, CeCILL-B Free Software License Agreement + | CECILL_C -- ^ @CECILL-C@, CeCILL-C Free Software License Agreement + | CERN_OHL_1_1 -- ^ @CERN-OHL-1.1@, CERN Open Hardware Licence v1.1, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | CERN_OHL_1_2 -- ^ @CERN-OHL-1.2@, CERN Open Hardware Licence v1.2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | CERN_OHL_P_2_0 -- ^ @CERN-OHL-P-2.0@, CERN Open Hardware Licence Version 2 - Permissive, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | CERN_OHL_S_2_0 -- ^ @CERN-OHL-S-2.0@, CERN Open Hardware Licence Version 2 - Strongly Reciprocal, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | CERN_OHL_W_2_0 -- ^ @CERN-OHL-W-2.0@, CERN Open Hardware Licence Version 2 - Weakly Reciprocal, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | ClArtistic -- ^ @ClArtistic@, Clarified Artistic License + | CNRI_Jython -- ^ @CNRI-Jython@, CNRI Jython License + | CNRI_Python_GPL_Compatible -- ^ @CNRI-Python-GPL-Compatible@, CNRI Python Open Source GPL Compatible License Agreement + | CNRI_Python -- ^ @CNRI-Python@, CNRI Python License + | COIL_1_0 -- ^ @COIL-1.0@, Copyfree Open Innovation License, SPDX License List 3.16 + | Community_Spec_1_0 -- ^ @Community-Spec-1.0@, Community Specification License 1.0, SPDX License List 3.16 + | Condor_1_1 -- ^ @Condor-1.1@, Condor Public License v1.1 + | Copyleft_next_0_3_0 -- ^ @copyleft-next-0.3.0@, copyleft-next 0.3.0, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | Copyleft_next_0_3_1 -- ^ @copyleft-next-0.3.1@, copyleft-next 0.3.1, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | CPAL_1_0 -- ^ @CPAL-1.0@, Common Public Attribution License 1.0 + | CPL_1_0 -- ^ @CPL-1.0@, Common Public License 1.0 + | CPOL_1_02 -- ^ @CPOL-1.02@, Code Project Open License 1.02 + | Crossword -- ^ @Crossword@, Crossword License + | CrystalStacker -- ^ @CrystalStacker@, CrystalStacker License + | CUA_OPL_1_0 -- ^ @CUA-OPL-1.0@, CUA Office Public License v1.0 + | Cube -- ^ @Cube@, Cube License + | Curl -- ^ @curl@, curl License + | D_FSL_1_0 -- ^ @D-FSL-1.0@, Deutsche Freie Software Lizenz + | Diffmark -- ^ @diffmark@, diffmark license + | DL_DE_BY_2_0 -- ^ @DL-DE-BY-2.0@, Data licence Germany – attribution – version 2.0, SPDX License List 3.16 + | DOC -- ^ @DOC@, DOC License + | Dotseqn -- ^ @Dotseqn@, Dotseqn License + | DRL_1_0 -- ^ @DRL-1.0@, Detection Rule License 1.0, SPDX License List 3.16 + | DSDP -- ^ @DSDP@, DSDP License + | Dvipdfm -- ^ @dvipdfm@, dvipdfm License + | ECL_1_0 -- ^ @ECL-1.0@, Educational Community License v1.0 + | ECL_2_0 -- ^ @ECL-2.0@, Educational Community License v2.0 + | EFL_1_0 -- ^ @EFL-1.0@, Eiffel Forum License v1.0 + | EFL_2_0 -- ^ @EFL-2.0@, Eiffel Forum License v2.0 + | EGenix -- ^ @eGenix@, eGenix.com Public License 1.1.0 + | Elastic_2_0 -- ^ @Elastic-2.0@, Elastic License 2.0, SPDX License List 3.16 + | Entessa -- ^ @Entessa@, Entessa Public License v1.0 + | EPICS -- ^ @EPICS@, EPICS Open License, SPDX License List 3.10, SPDX License List 3.16 + | EPL_1_0 -- ^ @EPL-1.0@, Eclipse Public License 1.0 + | EPL_2_0 -- ^ @EPL-2.0@, Eclipse Public License 2.0 + | ErlPL_1_1 -- ^ @ErlPL-1.1@, Erlang Public License v1.1 + | Etalab_2_0 -- ^ @etalab-2.0@, Etalab Open License 2.0, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | EUDatagrid -- ^ @EUDatagrid@, EU DataGrid Software License + | EUPL_1_0 -- ^ @EUPL-1.0@, European Union Public License 1.0 + | EUPL_1_1 -- ^ @EUPL-1.1@, European Union Public License 1.1 + | EUPL_1_2 -- ^ @EUPL-1.2@, European Union Public License 1.2 + | Eurosym -- ^ @Eurosym@, Eurosym License + | Fair -- ^ @Fair@, Fair License + | FDK_AAC -- ^ @FDK-AAC@, Fraunhofer FDK AAC Codec Library, SPDX License List 3.16 + | Frameworx_1_0 -- ^ @Frameworx-1.0@, Frameworx Open License 1.0 + | FreeBSD_DOC -- ^ @FreeBSD-DOC@, FreeBSD Documentation License, SPDX License List 3.16 + | FreeImage -- ^ @FreeImage@, FreeImage Public License v1.0 + | FSFAP -- ^ @FSFAP@, FSF All Permissive License + | FSFULLR -- ^ @FSFULLR@, FSF Unlimited License (with License Retention) + | FSFUL -- ^ @FSFUL@, FSF Unlimited License + | FTL -- ^ @FTL@, Freetype Project License + | GD -- ^ @GD@, GD License, SPDX License List 3.16 + | GFDL_1_1_invariants_only -- ^ @GFDL-1.1-invariants-only@, GNU Free Documentation License v1.1 only - invariants, SPDX License List 3.10, SPDX License List 3.16 + | GFDL_1_1_invariants_or_later -- ^ @GFDL-1.1-invariants-or-later@, GNU Free Documentation License v1.1 or later - invariants, SPDX License List 3.10, SPDX License List 3.16 + | GFDL_1_1_no_invariants_only -- ^ @GFDL-1.1-no-invariants-only@, GNU Free Documentation License v1.1 only - no invariants, SPDX License List 3.10, SPDX License List 3.16 + | GFDL_1_1_no_invariants_or_later -- ^ @GFDL-1.1-no-invariants-or-later@, GNU Free Documentation License v1.1 or later - no invariants, SPDX License List 3.10, SPDX License List 3.16 + | GFDL_1_1_only -- ^ @GFDL-1.1-only@, GNU Free Documentation License v1.1 only + | GFDL_1_1_or_later -- ^ @GFDL-1.1-or-later@, GNU Free Documentation License v1.1 or later + | GFDL_1_2_invariants_only -- ^ @GFDL-1.2-invariants-only@, GNU Free Documentation License v1.2 only - invariants, SPDX License List 3.10, SPDX License List 3.16 + | GFDL_1_2_invariants_or_later -- ^ @GFDL-1.2-invariants-or-later@, GNU Free Documentation License v1.2 or later - invariants, SPDX License List 3.10, SPDX License List 3.16 + | GFDL_1_2_no_invariants_only -- ^ @GFDL-1.2-no-invariants-only@, GNU Free Documentation License v1.2 only - no invariants, SPDX License List 3.10, SPDX License List 3.16 + | GFDL_1_2_no_invariants_or_later -- ^ @GFDL-1.2-no-invariants-or-later@, GNU Free Documentation License v1.2 or later - no invariants, SPDX License List 3.10, SPDX License List 3.16 + | GFDL_1_2_only -- ^ @GFDL-1.2-only@, GNU Free Documentation License v1.2 only + | GFDL_1_2_or_later -- ^ @GFDL-1.2-or-later@, GNU Free Documentation License v1.2 or later + | GFDL_1_3_invariants_only -- ^ @GFDL-1.3-invariants-only@, GNU Free Documentation License v1.3 only - invariants, SPDX License List 3.10, SPDX License List 3.16 + | GFDL_1_3_invariants_or_later -- ^ @GFDL-1.3-invariants-or-later@, GNU Free Documentation License v1.3 or later - invariants, SPDX License List 3.10, SPDX License List 3.16 + | GFDL_1_3_no_invariants_only -- ^ @GFDL-1.3-no-invariants-only@, GNU Free Documentation License v1.3 only - no invariants, SPDX License List 3.10, SPDX License List 3.16 + | GFDL_1_3_no_invariants_or_later -- ^ @GFDL-1.3-no-invariants-or-later@, GNU Free Documentation License v1.3 or later - no invariants, SPDX License List 3.10, SPDX License List 3.16 + | GFDL_1_3_only -- ^ @GFDL-1.3-only@, GNU Free Documentation License v1.3 only + | GFDL_1_3_or_later -- ^ @GFDL-1.3-or-later@, GNU Free Documentation License v1.3 or later + | Giftware -- ^ @Giftware@, Giftware License + | GL2PS -- ^ @GL2PS@, GL2PS License + | Glide -- ^ @Glide@, 3dfx Glide License + | Glulxe -- ^ @Glulxe@, Glulxe License + | GLWTPL -- ^ @GLWTPL@, Good Luck With That Public License, SPDX License List 3.10, SPDX License List 3.16 + | Gnuplot -- ^ @gnuplot@, gnuplot License + | GPL_1_0_only -- ^ @GPL-1.0-only@, GNU General Public License v1.0 only + | GPL_1_0_or_later -- ^ @GPL-1.0-or-later@, GNU General Public License v1.0 or later + | GPL_2_0_only -- ^ @GPL-2.0-only@, GNU General Public License v2.0 only + | GPL_2_0_or_later -- ^ @GPL-2.0-or-later@, GNU General Public License v2.0 or later + | GPL_3_0_only -- ^ @GPL-3.0-only@, GNU General Public License v3.0 only + | GPL_3_0_or_later -- ^ @GPL-3.0-or-later@, GNU General Public License v3.0 or later + | GSOAP_1_3b -- ^ @gSOAP-1.3b@, gSOAP Public License v1.3b + | HaskellReport -- ^ @HaskellReport@, Haskell Language Report License + | Hippocratic_2_1 -- ^ @Hippocratic-2.1@, Hippocratic License 2.1, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | HPND_sell_variant -- ^ @HPND-sell-variant@, Historical Permission Notice and Disclaimer - sell variant, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | HPND -- ^ @HPND@, Historical Permission Notice and Disclaimer + | HTMLTIDY -- ^ @HTMLTIDY@, HTML Tidy License, SPDX License List 3.16 + | IBM_pibs -- ^ @IBM-pibs@, IBM PowerPC Initialization and Boot Software + | ICU -- ^ @ICU@, ICU License + | IJG -- ^ @IJG@, Independent JPEG Group License + | ImageMagick -- ^ @ImageMagick@, ImageMagick License + | IMatix -- ^ @iMatix@, iMatix Standard Function Library Agreement + | Imlib2 -- ^ @Imlib2@, Imlib2 License + | Info_ZIP -- ^ @Info-ZIP@, Info-ZIP License + | Intel_ACPI -- ^ @Intel-ACPI@, Intel ACPI Software License Agreement + | Intel -- ^ @Intel@, Intel Open Source License + | Interbase_1_0 -- ^ @Interbase-1.0@, Interbase Public License v1.0 + | IPA -- ^ @IPA@, IPA Font License + | IPL_1_0 -- ^ @IPL-1.0@, IBM Public License v1.0 + | ISC -- ^ @ISC@, ISC License + | Jam -- ^ @Jam@, Jam License, SPDX License List 3.16 + | JasPer_2_0 -- ^ @JasPer-2.0@, JasPer License + | JPNIC -- ^ @JPNIC@, Japan Network Information Center License, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | JSON -- ^ @JSON@, JSON License + | LAL_1_2 -- ^ @LAL-1.2@, Licence Art Libre 1.2 + | LAL_1_3 -- ^ @LAL-1.3@, Licence Art Libre 1.3 + | Latex2e -- ^ @Latex2e@, Latex2e License + | Leptonica -- ^ @Leptonica@, Leptonica License + | LGPL_2_0_only -- ^ @LGPL-2.0-only@, GNU Library General Public License v2 only + | LGPL_2_0_or_later -- ^ @LGPL-2.0-or-later@, GNU Library General Public License v2 or later + | LGPL_2_1_only -- ^ @LGPL-2.1-only@, GNU Lesser General Public License v2.1 only + | LGPL_2_1_or_later -- ^ @LGPL-2.1-or-later@, GNU Lesser General Public License v2.1 or later + | LGPL_3_0_only -- ^ @LGPL-3.0-only@, GNU Lesser General Public License v3.0 only + | LGPL_3_0_or_later -- ^ @LGPL-3.0-or-later@, GNU Lesser General Public License v3.0 or later + | LGPLLR -- ^ @LGPLLR@, Lesser General Public License For Linguistic Resources + | Libpng_2_0 -- ^ @libpng-2.0@, PNG Reference Library version 2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | Libpng -- ^ @Libpng@, libpng License + | Libselinux_1_0 -- ^ @libselinux-1.0@, libselinux public domain notice, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | Libtiff -- ^ @libtiff@, libtiff License + | LiLiQ_P_1_1 -- ^ @LiLiQ-P-1.1@, Licence Libre du Québec – Permissive version 1.1 + | LiLiQ_R_1_1 -- ^ @LiLiQ-R-1.1@, Licence Libre du Québec – Réciprocité version 1.1 + | LiLiQ_Rplus_1_1 -- ^ @LiLiQ-Rplus-1.1@, Licence Libre du Québec – Réciprocité forte version 1.1 + | Linux_man_pages_copyleft -- ^ @Linux-man-pages-copyleft@, Linux man-pages Copyleft, SPDX License List 3.16 + | Linux_OpenIB -- ^ @Linux-OpenIB@, Linux Kernel Variant of OpenIB.org license, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | LPL_1_02 -- ^ @LPL-1.02@, Lucent Public License v1.02 + | LPL_1_0 -- ^ @LPL-1.0@, Lucent Public License Version 1.0 + | LPPL_1_0 -- ^ @LPPL-1.0@, LaTeX Project Public License v1.0 + | LPPL_1_1 -- ^ @LPPL-1.1@, LaTeX Project Public License v1.1 + | LPPL_1_2 -- ^ @LPPL-1.2@, LaTeX Project Public License v1.2 + | LPPL_1_3a -- ^ @LPPL-1.3a@, LaTeX Project Public License v1.3a + | LPPL_1_3c -- ^ @LPPL-1.3c@, LaTeX Project Public License v1.3c + | MakeIndex -- ^ @MakeIndex@, MakeIndex License + | MirOS -- ^ @MirOS@, The MirOS Licence + | MIT_0 -- ^ @MIT-0@, MIT No Attribution, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | MIT_advertising -- ^ @MIT-advertising@, Enlightenment License (e16) + | MIT_CMU -- ^ @MIT-CMU@, CMU License + | MIT_enna -- ^ @MIT-enna@, enna License + | MIT_feh -- ^ @MIT-feh@, feh License + | MIT_Modern_Variant -- ^ @MIT-Modern-Variant@, MIT License Modern Variant, SPDX License List 3.16 + | MIT_open_group -- ^ @MIT-open-group@, MIT Open Group variant, SPDX License List 3.16 + | MITNFA -- ^ @MITNFA@, MIT +no-false-attribs license + | MIT -- ^ @MIT@, MIT License + | Motosoto -- ^ @Motosoto@, Motosoto License + | Mpich2 -- ^ @mpich2@, mpich2 License + | MPL_1_0 -- ^ @MPL-1.0@, Mozilla Public License 1.0 + | MPL_1_1 -- ^ @MPL-1.1@, Mozilla Public License 1.1 + | MPL_2_0_no_copyleft_exception -- ^ @MPL-2.0-no-copyleft-exception@, Mozilla Public License 2.0 (no copyleft exception) + | MPL_2_0 -- ^ @MPL-2.0@, Mozilla Public License 2.0 + | MS_PL -- ^ @MS-PL@, Microsoft Public License + | MS_RL -- ^ @MS-RL@, Microsoft Reciprocal License + | MTLL -- ^ @MTLL@, Matrix Template Library License + | MulanPSL_1_0 -- ^ @MulanPSL-1.0@, Mulan Permissive Software License, Version 1, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | MulanPSL_2_0 -- ^ @MulanPSL-2.0@, Mulan Permissive Software License, Version 2, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | Multics -- ^ @Multics@, Multics License + | Mup -- ^ @Mup@, Mup License + | NAIST_2003 -- ^ @NAIST-2003@, Nara Institute of Science and Technology License (2003), SPDX License List 3.16 + | NASA_1_3 -- ^ @NASA-1.3@, NASA Open Source Agreement 1.3 + | Naumen -- ^ @Naumen@, Naumen Public License + | NBPL_1_0 -- ^ @NBPL-1.0@, Net Boolean Public License v1 + | NCGL_UK_2_0 -- ^ @NCGL-UK-2.0@, Non-Commercial Government Licence, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | NCSA -- ^ @NCSA@, University of Illinois/NCSA Open Source License + | Net_SNMP -- ^ @Net-SNMP@, Net-SNMP License + | NetCDF -- ^ @NetCDF@, NetCDF license + | Newsletr -- ^ @Newsletr@, Newsletr License + | NGPL -- ^ @NGPL@, Nethack General Public License + | NIST_PD_fallback -- ^ @NIST-PD-fallback@, NIST Public Domain Notice with license fallback, SPDX License List 3.10, SPDX License List 3.16 + | NIST_PD -- ^ @NIST-PD@, NIST Public Domain Notice, SPDX License List 3.10, SPDX License List 3.16 + | NLOD_1_0 -- ^ @NLOD-1.0@, Norwegian Licence for Open Government Data (NLOD) 1.0 + | NLOD_2_0 -- ^ @NLOD-2.0@, Norwegian Licence for Open Government Data (NLOD) 2.0, SPDX License List 3.16 + | NLPL -- ^ @NLPL@, No Limit Public License + | Nokia -- ^ @Nokia@, Nokia Open Source License + | NOSL -- ^ @NOSL@, Netizen Open Source License + | Noweb -- ^ @Noweb@, Noweb License + | NPL_1_0 -- ^ @NPL-1.0@, Netscape Public License v1.0 + | NPL_1_1 -- ^ @NPL-1.1@, Netscape Public License v1.1 + | NPOSL_3_0 -- ^ @NPOSL-3.0@, Non-Profit Open Software License 3.0 + | NRL -- ^ @NRL@, NRL License + | NTP_0 -- ^ @NTP-0@, NTP No Attribution, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | NTP -- ^ @NTP@, NTP License + | O_UDA_1_0 -- ^ @O-UDA-1.0@, Open Use of Data Agreement v1.0, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | OCCT_PL -- ^ @OCCT-PL@, Open CASCADE Technology Public License + | OCLC_2_0 -- ^ @OCLC-2.0@, OCLC Research Public License 2.0 + | ODbL_1_0 -- ^ @ODbL-1.0@, Open Data Commons Open Database License v1.0 + | ODC_By_1_0 -- ^ @ODC-By-1.0@, Open Data Commons Attribution License v1.0, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | OFL_1_0_no_RFN -- ^ @OFL-1.0-no-RFN@, SIL Open Font License 1.0 with no Reserved Font Name, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | OFL_1_0_RFN -- ^ @OFL-1.0-RFN@, SIL Open Font License 1.0 with Reserved Font Name, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | OFL_1_0 -- ^ @OFL-1.0@, SIL Open Font License 1.0 + | OFL_1_1_no_RFN -- ^ @OFL-1.1-no-RFN@, SIL Open Font License 1.1 with no Reserved Font Name, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | OFL_1_1_RFN -- ^ @OFL-1.1-RFN@, SIL Open Font License 1.1 with Reserved Font Name, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | OFL_1_1 -- ^ @OFL-1.1@, SIL Open Font License 1.1 + | OGC_1_0 -- ^ @OGC-1.0@, OGC Software License, Version 1.0, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | OGDL_Taiwan_1_0 -- ^ @OGDL-Taiwan-1.0@, Taiwan Open Government Data License, version 1.0, SPDX License List 3.16 + | OGL_Canada_2_0 -- ^ @OGL-Canada-2.0@, Open Government Licence - Canada, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | OGL_UK_1_0 -- ^ @OGL-UK-1.0@, Open Government Licence v1.0, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | OGL_UK_2_0 -- ^ @OGL-UK-2.0@, Open Government Licence v2.0, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | OGL_UK_3_0 -- ^ @OGL-UK-3.0@, Open Government Licence v3.0, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | OGTSL -- ^ @OGTSL@, Open Group Test Suite License + | OLDAP_1_1 -- ^ @OLDAP-1.1@, Open LDAP Public License v1.1 + | OLDAP_1_2 -- ^ @OLDAP-1.2@, Open LDAP Public License v1.2 + | OLDAP_1_3 -- ^ @OLDAP-1.3@, Open LDAP Public License v1.3 + | OLDAP_1_4 -- ^ @OLDAP-1.4@, Open LDAP Public License v1.4 + | OLDAP_2_0_1 -- ^ @OLDAP-2.0.1@, Open LDAP Public License v2.0.1 + | OLDAP_2_0 -- ^ @OLDAP-2.0@, Open LDAP Public License v2.0 (or possibly 2.0A and 2.0B) + | OLDAP_2_1 -- ^ @OLDAP-2.1@, Open LDAP Public License v2.1 + | OLDAP_2_2_1 -- ^ @OLDAP-2.2.1@, Open LDAP Public License v2.2.1 + | OLDAP_2_2_2 -- ^ @OLDAP-2.2.2@, Open LDAP Public License 2.2.2 + | OLDAP_2_2 -- ^ @OLDAP-2.2@, Open LDAP Public License v2.2 + | OLDAP_2_3 -- ^ @OLDAP-2.3@, Open LDAP Public License v2.3 + | OLDAP_2_4 -- ^ @OLDAP-2.4@, Open LDAP Public License v2.4 + | OLDAP_2_5 -- ^ @OLDAP-2.5@, Open LDAP Public License v2.5 + | OLDAP_2_6 -- ^ @OLDAP-2.6@, Open LDAP Public License v2.6 + | OLDAP_2_7 -- ^ @OLDAP-2.7@, Open LDAP Public License v2.7 + | OLDAP_2_8 -- ^ @OLDAP-2.8@, Open LDAP Public License v2.8 + | OML -- ^ @OML@, Open Market License + | OpenSSL -- ^ @OpenSSL@, OpenSSL License + | OPL_1_0 -- ^ @OPL-1.0@, Open Public License v1.0 + | OPUBL_1_0 -- ^ @OPUBL-1.0@, Open Publication License v1.0, SPDX License List 3.16 + | OSET_PL_2_1 -- ^ @OSET-PL-2.1@, OSET Public License version 2.1 + | OSL_1_0 -- ^ @OSL-1.0@, Open Software License 1.0 + | OSL_1_1 -- ^ @OSL-1.1@, Open Software License 1.1 + | OSL_2_0 -- ^ @OSL-2.0@, Open Software License 2.0 + | OSL_2_1 -- ^ @OSL-2.1@, Open Software License 2.1 + | OSL_3_0 -- ^ @OSL-3.0@, Open Software License 3.0 + | Parity_6_0_0 -- ^ @Parity-6.0.0@, The Parity Public License 6.0.0, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | Parity_7_0_0 -- ^ @Parity-7.0.0@, The Parity Public License 7.0.0, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | PDDL_1_0 -- ^ @PDDL-1.0@, Open Data Commons Public Domain Dedication & License 1.0 + | PHP_3_01 -- ^ @PHP-3.01@, PHP License v3.01 + | PHP_3_0 -- ^ @PHP-3.0@, PHP License v3.0 + | Plexus -- ^ @Plexus@, Plexus Classworlds License + | PolyForm_Noncommercial_1_0_0 -- ^ @PolyForm-Noncommercial-1.0.0@, PolyForm Noncommercial License 1.0.0, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | PolyForm_Small_Business_1_0_0 -- ^ @PolyForm-Small-Business-1.0.0@, PolyForm Small Business License 1.0.0, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | PostgreSQL -- ^ @PostgreSQL@, PostgreSQL License + | PSF_2_0 -- ^ @PSF-2.0@, Python Software Foundation License 2.0, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | Psfrag -- ^ @psfrag@, psfrag License + | Psutils -- ^ @psutils@, psutils License + | Python_2_0 -- ^ @Python-2.0@, Python License 2.0 + | Qhull -- ^ @Qhull@, Qhull License + | QPL_1_0 -- ^ @QPL-1.0@, Q Public License 1.0 + | Rdisc -- ^ @Rdisc@, Rdisc License + | RHeCos_1_1 -- ^ @RHeCos-1.1@, Red Hat eCos Public License v1.1 + | RPL_1_1 -- ^ @RPL-1.1@, Reciprocal Public License 1.1 + | RPL_1_5 -- ^ @RPL-1.5@, Reciprocal Public License 1.5 + | RPSL_1_0 -- ^ @RPSL-1.0@, RealNetworks Public Source License v1.0 + | RSA_MD -- ^ @RSA-MD@, RSA Message-Digest License + | RSCPL -- ^ @RSCPL@, Ricoh Source Code Public License + | Ruby -- ^ @Ruby@, Ruby License + | SAX_PD -- ^ @SAX-PD@, Sax Public Domain Notice + | Saxpath -- ^ @Saxpath@, Saxpath License + | SCEA -- ^ @SCEA@, SCEA Shared Source License + | SchemeReport -- ^ @SchemeReport@, Scheme Language Report License, SPDX License List 3.16 + | Sendmail_8_23 -- ^ @Sendmail-8.23@, Sendmail License 8.23, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | Sendmail -- ^ @Sendmail@, Sendmail License + | SGI_B_1_0 -- ^ @SGI-B-1.0@, SGI Free Software License B v1.0 + | SGI_B_1_1 -- ^ @SGI-B-1.1@, SGI Free Software License B v1.1 + | SGI_B_2_0 -- ^ @SGI-B-2.0@, SGI Free Software License B v2.0 + | SHL_0_51 -- ^ @SHL-0.51@, Solderpad Hardware License, Version 0.51, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | SHL_0_5 -- ^ @SHL-0.5@, Solderpad Hardware License v0.5, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | SimPL_2_0 -- ^ @SimPL-2.0@, Simple Public License 2.0 + | SISSL_1_2 -- ^ @SISSL-1.2@, Sun Industry Standards Source License v1.2 + | SISSL -- ^ @SISSL@, Sun Industry Standards Source License v1.1 + | Sleepycat -- ^ @Sleepycat@, Sleepycat License + | SMLNJ -- ^ @SMLNJ@, Standard ML of New Jersey License + | SMPPL -- ^ @SMPPL@, Secure Messaging Protocol Public License + | SNIA -- ^ @SNIA@, SNIA Public License 1.1 + | Spencer_86 -- ^ @Spencer-86@, Spencer License 86 + | Spencer_94 -- ^ @Spencer-94@, Spencer License 94 + | Spencer_99 -- ^ @Spencer-99@, Spencer License 99 + | SPL_1_0 -- ^ @SPL-1.0@, Sun Public License v1.0 + | SSH_OpenSSH -- ^ @SSH-OpenSSH@, SSH OpenSSH license, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | SSH_short -- ^ @SSH-short@, SSH short notice, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | SSPL_1_0 -- ^ @SSPL-1.0@, Server Side Public License, v 1, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | SugarCRM_1_1_3 -- ^ @SugarCRM-1.1.3@, SugarCRM Public License v1.1.3 + | SWL -- ^ @SWL@, Scheme Widget Library (SWL) Software License Agreement + | TAPR_OHL_1_0 -- ^ @TAPR-OHL-1.0@, TAPR Open Hardware License v1.0, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | TCL -- ^ @TCL@, TCL/TK License + | TCP_wrappers -- ^ @TCP-wrappers@, TCP Wrappers License + | TMate -- ^ @TMate@, TMate Open Source License + | TORQUE_1_1 -- ^ @TORQUE-1.1@, TORQUE v2.5+ Software License v1.1 + | TOSL -- ^ @TOSL@, Trusster Open Source License + | TU_Berlin_1_0 -- ^ @TU-Berlin-1.0@, Technische Universitaet Berlin License 1.0, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | TU_Berlin_2_0 -- ^ @TU-Berlin-2.0@, Technische Universitaet Berlin License 2.0, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | UCL_1_0 -- ^ @UCL-1.0@, Upstream Compatibility License v1.0, SPDX License List 3.9, SPDX License List 3.10, SPDX License List 3.16 + | Unicode_DFS_2015 -- ^ @Unicode-DFS-2015@, Unicode License Agreement - Data Files and Software (2015) + | Unicode_DFS_2016 -- ^ @Unicode-DFS-2016@, Unicode License Agreement - Data Files and Software (2016) + | Unicode_TOU -- ^ @Unicode-TOU@, Unicode Terms of Use + | Unlicense -- ^ @Unlicense@, The Unlicense + | UPL_1_0 -- ^ @UPL-1.0@, Universal Permissive License v1.0 + | Vim -- ^ @Vim@, Vim License + | VOSTROM -- ^ @VOSTROM@, VOSTROM Public License for Open Source + | VSL_1_0 -- ^ @VSL-1.0@, Vovida Software License v1.0 + | W3C_19980720 -- ^ @W3C-19980720@, W3C Software Notice and License (1998-07-20) + | W3C_20150513 -- ^ @W3C-20150513@, W3C Software Notice and Document License (2015-05-13) + | W3C -- ^ @W3C@, W3C Software Notice and License (2002-12-31) + | Watcom_1_0 -- ^ @Watcom-1.0@, Sybase Open Watcom Public License 1.0 + | Wsuipa -- ^ @Wsuipa@, Wsuipa License + | WTFPL -- ^ @WTFPL@, Do What The F*ck You Want To Public License + | X11_distribute_modifications_variant -- ^ @X11-distribute-modifications-variant@, X11 License Distribution Modification Variant, SPDX License List 3.16 + | X11 -- ^ @X11@, X11 License + | Xerox -- ^ @Xerox@, Xerox License + | XFree86_1_1 -- ^ @XFree86-1.1@, XFree86 License 1.1 + | Xinetd -- ^ @xinetd@, xinetd License + | Xnet -- ^ @Xnet@, X.Net License + | Xpp -- ^ @xpp@, XPP License + | XSkat -- ^ @XSkat@, XSkat License + | YPL_1_0 -- ^ @YPL-1.0@, Yahoo! Public License v1.0 + | YPL_1_1 -- ^ @YPL-1.1@, Yahoo! Public License v1.1 + | Zed -- ^ @Zed@, Zed License + | Zend_2_0 -- ^ @Zend-2.0@, Zend License v2.0 + | Zimbra_1_3 -- ^ @Zimbra-1.3@, Zimbra Public License v1.3 + | Zimbra_1_4 -- ^ @Zimbra-1.4@, Zimbra Public License v1.4 + | Zlib_acknowledgement -- ^ @zlib-acknowledgement@, zlib/libpng License with Acknowledgement + | Zlib -- ^ @Zlib@, zlib License + | ZPL_1_1 -- ^ @ZPL-1.1@, Zope Public License 1.1 + | ZPL_2_0 -- ^ @ZPL-2.0@, Zope Public License 2.0 + | ZPL_2_1 -- ^ @ZPL-2.1@, Zope Public License 2.1 + deriving (Eq, Ord, Enum, Bounded, Show, Read, Typeable, Data) + +instance Binary LicenseId where + -- Word16 is encoded in big endianess + -- https://github.com/kolmodin/binary/blob/master/src/Data/Binary/Class.hs#L220-LL227 + put = Binary.putWord16be . fromIntegral . fromEnum + get = do + i <- Binary.getWord16be + if i > fromIntegral (fromEnum (maxBound :: LicenseId)) + then fail "Too large LicenseId tag" + else return (toEnum (fromIntegral i)) + +-- note: remember to bump version each time the definition changes +instance Structured LicenseId where + structure p = set typeVersion 306 $ nominalStructure p + +instance Pretty LicenseId where + pretty = Disp.text . licenseId + +-- | +-- >>> eitherParsec "BSD-3-Clause" :: Either String LicenseId +-- Right BSD_3_Clause +-- +-- >>> eitherParsec "BSD3" :: Either String LicenseId +-- Left "...Unknown SPDX license identifier: 'BSD3' Do you mean BSD-3-Clause?" +-- +instance Parsec LicenseId where + parsec = do + n <- some $ P.satisfy $ \c -> isAsciiAlphaNum c || c == '-' || c == '.' + v <- askCabalSpecVersion + maybe (fail $ "Unknown SPDX license identifier: '" ++ n ++ "' " ++ licenseIdMigrationMessage n) return $ + mkLicenseId (cabalSpecVersionToSPDXListVersion v) n + +instance NFData LicenseId where + rnf l = l `seq` () + +-- | Help message for migrating from non-SPDX license identifiers. +-- +-- Old 'License' is almost SPDX, except for 'BSD2', 'BSD3'. This function +-- suggests SPDX variant: +-- +-- >>> licenseIdMigrationMessage "BSD3" +-- "Do you mean BSD-3-Clause?" +-- +-- Also 'OtherLicense', 'AllRightsReserved', and 'PublicDomain' aren't +-- valid SPDX identifiers +-- +-- >>> traverse_ (print . licenseIdMigrationMessage) [ "OtherLicense", "AllRightsReserved", "PublicDomain" ] +-- "SPDX license list contains plenty of licenses. See https://spdx.org/licenses/. Also they can be combined into complex expressions with AND and OR." +-- "You can use NONE as a value of license field." +-- "Public Domain is a complex matter. See https://wiki.spdx.org/view/Legal_Team/Decisions/Dealing_with_Public_Domain_within_SPDX_Files. Consider using a proper license." +-- +-- SPDX License list version 3.0 introduced "-only" and "-or-later" variants for GNU family of licenses. +-- See +-- >>> licenseIdMigrationMessage "GPL-2.0" +-- "SPDX license list 3.0 deprecated suffixless variants of GNU family of licenses. Use GPL-2.0-only or GPL-2.0-or-later." +-- +-- For other common licenses their old license format coincides with the SPDX identifiers: +-- +-- >>> traverse eitherParsec ["GPL-2.0-only", "GPL-3.0-only", "LGPL-2.1-only", "MIT", "ISC", "MPL-2.0", "Apache-2.0"] :: Either String [LicenseId] +-- Right [GPL_2_0_only,GPL_3_0_only,LGPL_2_1_only,MIT,ISC,MPL_2_0,Apache_2_0] +-- +licenseIdMigrationMessage :: String -> String +licenseIdMigrationMessage = go where + go l | gnuVariant l = "SPDX license list 3.0 deprecated suffixless variants of GNU family of licenses. Use " ++ l ++ "-only or " ++ l ++ "-or-later." + go "BSD3" = "Do you mean BSD-3-Clause?" + go "BSD2" = "Do you mean BSD-2-Clause?" + go "AllRightsReserved" = "You can use NONE as a value of license field." + go "OtherLicense" = "SPDX license list contains plenty of licenses. See https://spdx.org/licenses/. Also they can be combined into complex expressions with AND and OR." + go "PublicDomain" = "Public Domain is a complex matter. See https://wiki.spdx.org/view/Legal_Team/Decisions/Dealing_with_Public_Domain_within_SPDX_Files. Consider using a proper license." + + -- otherwise, we don't know + go _ = "" + + gnuVariant = flip elem ["GPL-2.0", "GPL-3.0", "LGPL-2.1", "LGPL-3.0", "AGPL-3.0" ] + +------------------------------------------------------------------------------- +-- License Data +------------------------------------------------------------------------------- + +-- | License SPDX identifier, e.g. @"BSD-3-Clause"@. +licenseId :: LicenseId -> String +licenseId NullBSD = "0BSD" +licenseId AAL = "AAL" +licenseId Abstyles = "Abstyles" +licenseId Adobe_2006 = "Adobe-2006" +licenseId Adobe_Glyph = "Adobe-Glyph" +licenseId ADSL = "ADSL" +licenseId AFL_1_1 = "AFL-1.1" +licenseId AFL_1_2 = "AFL-1.2" +licenseId AFL_2_0 = "AFL-2.0" +licenseId AFL_2_1 = "AFL-2.1" +licenseId AFL_3_0 = "AFL-3.0" +licenseId Afmparse = "Afmparse" +licenseId AGPL_1_0 = "AGPL-1.0" +licenseId AGPL_1_0_only = "AGPL-1.0-only" +licenseId AGPL_1_0_or_later = "AGPL-1.0-or-later" +licenseId AGPL_3_0_only = "AGPL-3.0-only" +licenseId AGPL_3_0_or_later = "AGPL-3.0-or-later" +licenseId Aladdin = "Aladdin" +licenseId AMDPLPA = "AMDPLPA" +licenseId AML = "AML" +licenseId AMPAS = "AMPAS" +licenseId ANTLR_PD_fallback = "ANTLR-PD-fallback" +licenseId ANTLR_PD = "ANTLR-PD" +licenseId Apache_1_0 = "Apache-1.0" +licenseId Apache_1_1 = "Apache-1.1" +licenseId Apache_2_0 = "Apache-2.0" +licenseId APAFML = "APAFML" +licenseId APL_1_0 = "APL-1.0" +licenseId App_s2p = "App-s2p" +licenseId APSL_1_0 = "APSL-1.0" +licenseId APSL_1_1 = "APSL-1.1" +licenseId APSL_1_2 = "APSL-1.2" +licenseId APSL_2_0 = "APSL-2.0" +licenseId Artistic_1_0_cl8 = "Artistic-1.0-cl8" +licenseId Artistic_1_0_Perl = "Artistic-1.0-Perl" +licenseId Artistic_1_0 = "Artistic-1.0" +licenseId Artistic_2_0 = "Artistic-2.0" +licenseId Bahyph = "Bahyph" +licenseId Barr = "Barr" +licenseId Beerware = "Beerware" +licenseId BitTorrent_1_0 = "BitTorrent-1.0" +licenseId BitTorrent_1_1 = "BitTorrent-1.1" +licenseId Blessing = "blessing" +licenseId BlueOak_1_0_0 = "BlueOak-1.0.0" +licenseId Borceux = "Borceux" +licenseId BSD_1_Clause = "BSD-1-Clause" +licenseId BSD_2_Clause_FreeBSD = "BSD-2-Clause-FreeBSD" +licenseId BSD_2_Clause_NetBSD = "BSD-2-Clause-NetBSD" +licenseId BSD_2_Clause_Patent = "BSD-2-Clause-Patent" +licenseId BSD_2_Clause_Views = "BSD-2-Clause-Views" +licenseId BSD_2_Clause = "BSD-2-Clause" +licenseId BSD_3_Clause_Attribution = "BSD-3-Clause-Attribution" +licenseId BSD_3_Clause_Clear = "BSD-3-Clause-Clear" +licenseId BSD_3_Clause_LBNL = "BSD-3-Clause-LBNL" +licenseId BSD_3_Clause_Modification = "BSD-3-Clause-Modification" +licenseId BSD_3_Clause_No_Military_License = "BSD-3-Clause-No-Military-License" +licenseId BSD_3_Clause_No_Nuclear_License_2014 = "BSD-3-Clause-No-Nuclear-License-2014" +licenseId BSD_3_Clause_No_Nuclear_License = "BSD-3-Clause-No-Nuclear-License" +licenseId BSD_3_Clause_No_Nuclear_Warranty = "BSD-3-Clause-No-Nuclear-Warranty" +licenseId BSD_3_Clause_Open_MPI = "BSD-3-Clause-Open-MPI" +licenseId BSD_3_Clause = "BSD-3-Clause" +licenseId BSD_4_Clause_Shortened = "BSD-4-Clause-Shortened" +licenseId BSD_4_Clause_UC = "BSD-4-Clause-UC" +licenseId BSD_4_Clause = "BSD-4-Clause" +licenseId BSD_Protection = "BSD-Protection" +licenseId BSD_Source_Code = "BSD-Source-Code" +licenseId BSL_1_0 = "BSL-1.0" +licenseId Bzip2_1_0_5 = "bzip2-1.0.5" +licenseId BUSL_1_1 = "BUSL-1.1" +licenseId Bzip2_1_0_6 = "bzip2-1.0.6" +licenseId C_UDA_1_0 = "C-UDA-1.0" +licenseId CAL_1_0_Combined_Work_Exception = "CAL-1.0-Combined-Work-Exception" +licenseId CAL_1_0 = "CAL-1.0" +licenseId Caldera = "Caldera" +licenseId CATOSL_1_1 = "CATOSL-1.1" +licenseId CC_BY_1_0 = "CC-BY-1.0" +licenseId CC_BY_2_0 = "CC-BY-2.0" +licenseId CC_BY_2_5_AU = "CC-BY-2.5-AU" +licenseId CC_BY_2_5 = "CC-BY-2.5" +licenseId CC_BY_3_0_AT = "CC-BY-3.0-AT" +licenseId CC_BY_3_0_DE = "CC-BY-3.0-DE" +licenseId CC_BY_3_0_NL = "CC-BY-3.0-NL" +licenseId CC_BY_3_0_US = "CC-BY-3.0-US" +licenseId CC_BY_3_0 = "CC-BY-3.0" +licenseId CC_BY_4_0 = "CC-BY-4.0" +licenseId CC_BY_NC_1_0 = "CC-BY-NC-1.0" +licenseId CC_BY_NC_2_0 = "CC-BY-NC-2.0" +licenseId CC_BY_NC_2_5 = "CC-BY-NC-2.5" +licenseId CC_BY_NC_3_0_DE = "CC-BY-NC-3.0-DE" +licenseId CC_BY_NC_3_0 = "CC-BY-NC-3.0" +licenseId CC_BY_NC_4_0 = "CC-BY-NC-4.0" +licenseId CC_BY_NC_ND_1_0 = "CC-BY-NC-ND-1.0" +licenseId CC_BY_NC_ND_2_0 = "CC-BY-NC-ND-2.0" +licenseId CC_BY_NC_ND_2_5 = "CC-BY-NC-ND-2.5" +licenseId CC_BY_NC_ND_3_0_DE = "CC-BY-NC-ND-3.0-DE" +licenseId CC_BY_NC_ND_3_0_IGO = "CC-BY-NC-ND-3.0-IGO" +licenseId CC_BY_NC_ND_3_0 = "CC-BY-NC-ND-3.0" +licenseId CC_BY_NC_ND_4_0 = "CC-BY-NC-ND-4.0" +licenseId CC_BY_NC_SA_1_0 = "CC-BY-NC-SA-1.0" +licenseId CC_BY_NC_SA_2_0_FR = "CC-BY-NC-SA-2.0-FR" +licenseId CC_BY_NC_SA_2_0_UK = "CC-BY-NC-SA-2.0-UK" +licenseId CC_BY_NC_SA_2_0 = "CC-BY-NC-SA-2.0" +licenseId CC_BY_NC_SA_2_5 = "CC-BY-NC-SA-2.5" +licenseId CC_BY_NC_SA_3_0_DE = "CC-BY-NC-SA-3.0-DE" +licenseId CC_BY_NC_SA_3_0_IGO = "CC-BY-NC-SA-3.0-IGO" +licenseId CC_BY_NC_SA_3_0 = "CC-BY-NC-SA-3.0" +licenseId CC_BY_NC_SA_4_0 = "CC-BY-NC-SA-4.0" +licenseId CC_BY_ND_1_0 = "CC-BY-ND-1.0" +licenseId CC_BY_ND_2_0 = "CC-BY-ND-2.0" +licenseId CC_BY_ND_2_5 = "CC-BY-ND-2.5" +licenseId CC_BY_ND_3_0_DE = "CC-BY-ND-3.0-DE" +licenseId CC_BY_ND_3_0 = "CC-BY-ND-3.0" +licenseId CC_BY_ND_4_0 = "CC-BY-ND-4.0" +licenseId CC_BY_SA_1_0 = "CC-BY-SA-1.0" +licenseId CC_BY_SA_2_0_UK = "CC-BY-SA-2.0-UK" +licenseId CC_BY_SA_2_0 = "CC-BY-SA-2.0" +licenseId CC_BY_SA_2_1_JP = "CC-BY-SA-2.1-JP" +licenseId CC_BY_SA_2_5 = "CC-BY-SA-2.5" +licenseId CC_BY_SA_3_0_AT = "CC-BY-SA-3.0-AT" +licenseId CC_BY_SA_3_0_DE = "CC-BY-SA-3.0-DE" +licenseId CC_BY_SA_3_0 = "CC-BY-SA-3.0" +licenseId CC_BY_SA_4_0 = "CC-BY-SA-4.0" +licenseId CC_PDDC = "CC-PDDC" +licenseId CC0_1_0 = "CC0-1.0" +licenseId CDDL_1_0 = "CDDL-1.0" +licenseId CDDL_1_1 = "CDDL-1.1" +licenseId CDL_1_0 = "CDL-1.0" +licenseId CDLA_Permissive_1_0 = "CDLA-Permissive-1.0" +licenseId CDLA_Permissive_2_0 = "CDLA-Permissive-2.0" +licenseId CDLA_Sharing_1_0 = "CDLA-Sharing-1.0" +licenseId CECILL_1_0 = "CECILL-1.0" +licenseId CECILL_1_1 = "CECILL-1.1" +licenseId CECILL_2_0 = "CECILL-2.0" +licenseId CECILL_2_1 = "CECILL-2.1" +licenseId CECILL_B = "CECILL-B" +licenseId CECILL_C = "CECILL-C" +licenseId CERN_OHL_1_1 = "CERN-OHL-1.1" +licenseId CERN_OHL_1_2 = "CERN-OHL-1.2" +licenseId CERN_OHL_P_2_0 = "CERN-OHL-P-2.0" +licenseId CERN_OHL_S_2_0 = "CERN-OHL-S-2.0" +licenseId CERN_OHL_W_2_0 = "CERN-OHL-W-2.0" +licenseId ClArtistic = "ClArtistic" +licenseId CNRI_Jython = "CNRI-Jython" +licenseId CNRI_Python_GPL_Compatible = "CNRI-Python-GPL-Compatible" +licenseId CNRI_Python = "CNRI-Python" +licenseId COIL_1_0 = "COIL-1.0" +licenseId Community_Spec_1_0 = "Community-Spec-1.0" +licenseId Condor_1_1 = "Condor-1.1" +licenseId Copyleft_next_0_3_0 = "copyleft-next-0.3.0" +licenseId Copyleft_next_0_3_1 = "copyleft-next-0.3.1" +licenseId CPAL_1_0 = "CPAL-1.0" +licenseId CPL_1_0 = "CPL-1.0" +licenseId CPOL_1_02 = "CPOL-1.02" +licenseId Crossword = "Crossword" +licenseId CrystalStacker = "CrystalStacker" +licenseId CUA_OPL_1_0 = "CUA-OPL-1.0" +licenseId Cube = "Cube" +licenseId Curl = "curl" +licenseId D_FSL_1_0 = "D-FSL-1.0" +licenseId Diffmark = "diffmark" +licenseId DL_DE_BY_2_0 = "DL-DE-BY-2.0" +licenseId DOC = "DOC" +licenseId Dotseqn = "Dotseqn" +licenseId DRL_1_0 = "DRL-1.0" +licenseId DSDP = "DSDP" +licenseId Dvipdfm = "dvipdfm" +licenseId ECL_1_0 = "ECL-1.0" +licenseId ECL_2_0 = "ECL-2.0" +licenseId EFL_1_0 = "EFL-1.0" +licenseId EFL_2_0 = "EFL-2.0" +licenseId EGenix = "eGenix" +licenseId Elastic_2_0 = "Elastic-2.0" +licenseId Entessa = "Entessa" +licenseId EPICS = "EPICS" +licenseId EPL_1_0 = "EPL-1.0" +licenseId EPL_2_0 = "EPL-2.0" +licenseId ErlPL_1_1 = "ErlPL-1.1" +licenseId Etalab_2_0 = "etalab-2.0" +licenseId EUDatagrid = "EUDatagrid" +licenseId EUPL_1_0 = "EUPL-1.0" +licenseId EUPL_1_1 = "EUPL-1.1" +licenseId EUPL_1_2 = "EUPL-1.2" +licenseId Eurosym = "Eurosym" +licenseId Fair = "Fair" +licenseId FDK_AAC = "FDK-AAC" +licenseId Frameworx_1_0 = "Frameworx-1.0" +licenseId FreeBSD_DOC = "FreeBSD-DOC" +licenseId FreeImage = "FreeImage" +licenseId FSFAP = "FSFAP" +licenseId FSFULLR = "FSFULLR" +licenseId FSFUL = "FSFUL" +licenseId FTL = "FTL" +licenseId GD = "GD" +licenseId GFDL_1_1_invariants_only = "GFDL-1.1-invariants-only" +licenseId GFDL_1_1_invariants_or_later = "GFDL-1.1-invariants-or-later" +licenseId GFDL_1_1_no_invariants_only = "GFDL-1.1-no-invariants-only" +licenseId GFDL_1_1_no_invariants_or_later = "GFDL-1.1-no-invariants-or-later" +licenseId GFDL_1_1_only = "GFDL-1.1-only" +licenseId GFDL_1_1_or_later = "GFDL-1.1-or-later" +licenseId GFDL_1_2_invariants_only = "GFDL-1.2-invariants-only" +licenseId GFDL_1_2_invariants_or_later = "GFDL-1.2-invariants-or-later" +licenseId GFDL_1_2_no_invariants_only = "GFDL-1.2-no-invariants-only" +licenseId GFDL_1_2_no_invariants_or_later = "GFDL-1.2-no-invariants-or-later" +licenseId GFDL_1_2_only = "GFDL-1.2-only" +licenseId GFDL_1_2_or_later = "GFDL-1.2-or-later" +licenseId GFDL_1_3_invariants_only = "GFDL-1.3-invariants-only" +licenseId GFDL_1_3_invariants_or_later = "GFDL-1.3-invariants-or-later" +licenseId GFDL_1_3_no_invariants_only = "GFDL-1.3-no-invariants-only" +licenseId GFDL_1_3_no_invariants_or_later = "GFDL-1.3-no-invariants-or-later" +licenseId GFDL_1_3_only = "GFDL-1.3-only" +licenseId GFDL_1_3_or_later = "GFDL-1.3-or-later" +licenseId Giftware = "Giftware" +licenseId GL2PS = "GL2PS" +licenseId Glide = "Glide" +licenseId Glulxe = "Glulxe" +licenseId GLWTPL = "GLWTPL" +licenseId Gnuplot = "gnuplot" +licenseId GPL_1_0_only = "GPL-1.0-only" +licenseId GPL_1_0_or_later = "GPL-1.0-or-later" +licenseId GPL_2_0_only = "GPL-2.0-only" +licenseId GPL_2_0_or_later = "GPL-2.0-or-later" +licenseId GPL_3_0_only = "GPL-3.0-only" +licenseId GPL_3_0_or_later = "GPL-3.0-or-later" +licenseId GSOAP_1_3b = "gSOAP-1.3b" +licenseId HaskellReport = "HaskellReport" +licenseId Hippocratic_2_1 = "Hippocratic-2.1" +licenseId HPND_sell_variant = "HPND-sell-variant" +licenseId HPND = "HPND" +licenseId HTMLTIDY = "HTMLTIDY" +licenseId IBM_pibs = "IBM-pibs" +licenseId ICU = "ICU" +licenseId IJG = "IJG" +licenseId ImageMagick = "ImageMagick" +licenseId IMatix = "iMatix" +licenseId Imlib2 = "Imlib2" +licenseId Info_ZIP = "Info-ZIP" +licenseId Intel_ACPI = "Intel-ACPI" +licenseId Intel = "Intel" +licenseId Interbase_1_0 = "Interbase-1.0" +licenseId IPA = "IPA" +licenseId IPL_1_0 = "IPL-1.0" +licenseId ISC = "ISC" +licenseId Jam = "Jam" +licenseId JasPer_2_0 = "JasPer-2.0" +licenseId JPNIC = "JPNIC" +licenseId JSON = "JSON" +licenseId LAL_1_2 = "LAL-1.2" +licenseId LAL_1_3 = "LAL-1.3" +licenseId Latex2e = "Latex2e" +licenseId Leptonica = "Leptonica" +licenseId LGPL_2_0_only = "LGPL-2.0-only" +licenseId LGPL_2_0_or_later = "LGPL-2.0-or-later" +licenseId LGPL_2_1_only = "LGPL-2.1-only" +licenseId LGPL_2_1_or_later = "LGPL-2.1-or-later" +licenseId LGPL_3_0_only = "LGPL-3.0-only" +licenseId LGPL_3_0_or_later = "LGPL-3.0-or-later" +licenseId LGPLLR = "LGPLLR" +licenseId Libpng_2_0 = "libpng-2.0" +licenseId Libpng = "Libpng" +licenseId Libselinux_1_0 = "libselinux-1.0" +licenseId Libtiff = "libtiff" +licenseId LiLiQ_P_1_1 = "LiLiQ-P-1.1" +licenseId LiLiQ_R_1_1 = "LiLiQ-R-1.1" +licenseId LiLiQ_Rplus_1_1 = "LiLiQ-Rplus-1.1" +licenseId Linux_man_pages_copyleft = "Linux-man-pages-copyleft" +licenseId Linux_OpenIB = "Linux-OpenIB" +licenseId LPL_1_02 = "LPL-1.02" +licenseId LPL_1_0 = "LPL-1.0" +licenseId LPPL_1_0 = "LPPL-1.0" +licenseId LPPL_1_1 = "LPPL-1.1" +licenseId LPPL_1_2 = "LPPL-1.2" +licenseId LPPL_1_3a = "LPPL-1.3a" +licenseId LPPL_1_3c = "LPPL-1.3c" +licenseId MakeIndex = "MakeIndex" +licenseId MirOS = "MirOS" +licenseId MIT_0 = "MIT-0" +licenseId MIT_advertising = "MIT-advertising" +licenseId MIT_CMU = "MIT-CMU" +licenseId MIT_enna = "MIT-enna" +licenseId MIT_feh = "MIT-feh" +licenseId MIT_Modern_Variant = "MIT-Modern-Variant" +licenseId MIT_open_group = "MIT-open-group" +licenseId MITNFA = "MITNFA" +licenseId MIT = "MIT" +licenseId Motosoto = "Motosoto" +licenseId Mpich2 = "mpich2" +licenseId MPL_1_0 = "MPL-1.0" +licenseId MPL_1_1 = "MPL-1.1" +licenseId MPL_2_0_no_copyleft_exception = "MPL-2.0-no-copyleft-exception" +licenseId MPL_2_0 = "MPL-2.0" +licenseId MS_PL = "MS-PL" +licenseId MS_RL = "MS-RL" +licenseId MTLL = "MTLL" +licenseId MulanPSL_1_0 = "MulanPSL-1.0" +licenseId MulanPSL_2_0 = "MulanPSL-2.0" +licenseId Multics = "Multics" +licenseId Mup = "Mup" +licenseId NAIST_2003 = "NAIST-2003" +licenseId NASA_1_3 = "NASA-1.3" +licenseId Naumen = "Naumen" +licenseId NBPL_1_0 = "NBPL-1.0" +licenseId NCGL_UK_2_0 = "NCGL-UK-2.0" +licenseId NCSA = "NCSA" +licenseId Net_SNMP = "Net-SNMP" +licenseId NetCDF = "NetCDF" +licenseId Newsletr = "Newsletr" +licenseId NGPL = "NGPL" +licenseId NIST_PD_fallback = "NIST-PD-fallback" +licenseId NIST_PD = "NIST-PD" +licenseId NLOD_1_0 = "NLOD-1.0" +licenseId NLOD_2_0 = "NLOD-2.0" +licenseId NLPL = "NLPL" +licenseId Nokia = "Nokia" +licenseId NOSL = "NOSL" +licenseId Noweb = "Noweb" +licenseId NPL_1_0 = "NPL-1.0" +licenseId NPL_1_1 = "NPL-1.1" +licenseId NPOSL_3_0 = "NPOSL-3.0" +licenseId NRL = "NRL" +licenseId NTP_0 = "NTP-0" +licenseId NTP = "NTP" +licenseId O_UDA_1_0 = "O-UDA-1.0" +licenseId OCCT_PL = "OCCT-PL" +licenseId OCLC_2_0 = "OCLC-2.0" +licenseId ODbL_1_0 = "ODbL-1.0" +licenseId ODC_By_1_0 = "ODC-By-1.0" +licenseId OFL_1_0_no_RFN = "OFL-1.0-no-RFN" +licenseId OFL_1_0_RFN = "OFL-1.0-RFN" +licenseId OFL_1_0 = "OFL-1.0" +licenseId OFL_1_1_no_RFN = "OFL-1.1-no-RFN" +licenseId OFL_1_1_RFN = "OFL-1.1-RFN" +licenseId OFL_1_1 = "OFL-1.1" +licenseId OGC_1_0 = "OGC-1.0" +licenseId OGDL_Taiwan_1_0 = "OGDL-Taiwan-1.0" +licenseId OGL_Canada_2_0 = "OGL-Canada-2.0" +licenseId OGL_UK_1_0 = "OGL-UK-1.0" +licenseId OGL_UK_2_0 = "OGL-UK-2.0" +licenseId OGL_UK_3_0 = "OGL-UK-3.0" +licenseId OGTSL = "OGTSL" +licenseId OLDAP_1_1 = "OLDAP-1.1" +licenseId OLDAP_1_2 = "OLDAP-1.2" +licenseId OLDAP_1_3 = "OLDAP-1.3" +licenseId OLDAP_1_4 = "OLDAP-1.4" +licenseId OLDAP_2_0_1 = "OLDAP-2.0.1" +licenseId OLDAP_2_0 = "OLDAP-2.0" +licenseId OLDAP_2_1 = "OLDAP-2.1" +licenseId OLDAP_2_2_1 = "OLDAP-2.2.1" +licenseId OLDAP_2_2_2 = "OLDAP-2.2.2" +licenseId OLDAP_2_2 = "OLDAP-2.2" +licenseId OLDAP_2_3 = "OLDAP-2.3" +licenseId OLDAP_2_4 = "OLDAP-2.4" +licenseId OLDAP_2_5 = "OLDAP-2.5" +licenseId OLDAP_2_6 = "OLDAP-2.6" +licenseId OLDAP_2_7 = "OLDAP-2.7" +licenseId OLDAP_2_8 = "OLDAP-2.8" +licenseId OML = "OML" +licenseId OpenSSL = "OpenSSL" +licenseId OPL_1_0 = "OPL-1.0" +licenseId OPUBL_1_0 = "OPUBL-1.0" +licenseId OSET_PL_2_1 = "OSET-PL-2.1" +licenseId OSL_1_0 = "OSL-1.0" +licenseId OSL_1_1 = "OSL-1.1" +licenseId OSL_2_0 = "OSL-2.0" +licenseId OSL_2_1 = "OSL-2.1" +licenseId OSL_3_0 = "OSL-3.0" +licenseId Parity_6_0_0 = "Parity-6.0.0" +licenseId Parity_7_0_0 = "Parity-7.0.0" +licenseId PDDL_1_0 = "PDDL-1.0" +licenseId PHP_3_01 = "PHP-3.01" +licenseId PHP_3_0 = "PHP-3.0" +licenseId Plexus = "Plexus" +licenseId PolyForm_Noncommercial_1_0_0 = "PolyForm-Noncommercial-1.0.0" +licenseId PolyForm_Small_Business_1_0_0 = "PolyForm-Small-Business-1.0.0" +licenseId PostgreSQL = "PostgreSQL" +licenseId PSF_2_0 = "PSF-2.0" +licenseId Psfrag = "psfrag" +licenseId Psutils = "psutils" +licenseId Python_2_0 = "Python-2.0" +licenseId Qhull = "Qhull" +licenseId QPL_1_0 = "QPL-1.0" +licenseId Rdisc = "Rdisc" +licenseId RHeCos_1_1 = "RHeCos-1.1" +licenseId RPL_1_1 = "RPL-1.1" +licenseId RPL_1_5 = "RPL-1.5" +licenseId RPSL_1_0 = "RPSL-1.0" +licenseId RSA_MD = "RSA-MD" +licenseId RSCPL = "RSCPL" +licenseId Ruby = "Ruby" +licenseId SAX_PD = "SAX-PD" +licenseId Saxpath = "Saxpath" +licenseId SCEA = "SCEA" +licenseId SchemeReport = "SchemeReport" +licenseId Sendmail_8_23 = "Sendmail-8.23" +licenseId Sendmail = "Sendmail" +licenseId SGI_B_1_0 = "SGI-B-1.0" +licenseId SGI_B_1_1 = "SGI-B-1.1" +licenseId SGI_B_2_0 = "SGI-B-2.0" +licenseId SHL_0_51 = "SHL-0.51" +licenseId SHL_0_5 = "SHL-0.5" +licenseId SimPL_2_0 = "SimPL-2.0" +licenseId SISSL_1_2 = "SISSL-1.2" +licenseId SISSL = "SISSL" +licenseId Sleepycat = "Sleepycat" +licenseId SMLNJ = "SMLNJ" +licenseId SMPPL = "SMPPL" +licenseId SNIA = "SNIA" +licenseId Spencer_86 = "Spencer-86" +licenseId Spencer_94 = "Spencer-94" +licenseId Spencer_99 = "Spencer-99" +licenseId SPL_1_0 = "SPL-1.0" +licenseId SSH_OpenSSH = "SSH-OpenSSH" +licenseId SSH_short = "SSH-short" +licenseId SSPL_1_0 = "SSPL-1.0" +licenseId SugarCRM_1_1_3 = "SugarCRM-1.1.3" +licenseId SWL = "SWL" +licenseId TAPR_OHL_1_0 = "TAPR-OHL-1.0" +licenseId TCL = "TCL" +licenseId TCP_wrappers = "TCP-wrappers" +licenseId TMate = "TMate" +licenseId TORQUE_1_1 = "TORQUE-1.1" +licenseId TOSL = "TOSL" +licenseId TU_Berlin_1_0 = "TU-Berlin-1.0" +licenseId TU_Berlin_2_0 = "TU-Berlin-2.0" +licenseId UCL_1_0 = "UCL-1.0" +licenseId Unicode_DFS_2015 = "Unicode-DFS-2015" +licenseId Unicode_DFS_2016 = "Unicode-DFS-2016" +licenseId Unicode_TOU = "Unicode-TOU" +licenseId Unlicense = "Unlicense" +licenseId UPL_1_0 = "UPL-1.0" +licenseId Vim = "Vim" +licenseId VOSTROM = "VOSTROM" +licenseId VSL_1_0 = "VSL-1.0" +licenseId W3C_19980720 = "W3C-19980720" +licenseId W3C_20150513 = "W3C-20150513" +licenseId W3C = "W3C" +licenseId Watcom_1_0 = "Watcom-1.0" +licenseId Wsuipa = "Wsuipa" +licenseId WTFPL = "WTFPL" +licenseId X11_distribute_modifications_variant = "X11-distribute-modifications-variant" +licenseId X11 = "X11" +licenseId Xerox = "Xerox" +licenseId XFree86_1_1 = "XFree86-1.1" +licenseId Xinetd = "xinetd" +licenseId Xnet = "Xnet" +licenseId Xpp = "xpp" +licenseId XSkat = "XSkat" +licenseId YPL_1_0 = "YPL-1.0" +licenseId YPL_1_1 = "YPL-1.1" +licenseId Zed = "Zed" +licenseId Zend_2_0 = "Zend-2.0" +licenseId Zimbra_1_3 = "Zimbra-1.3" +licenseId Zimbra_1_4 = "Zimbra-1.4" +licenseId Zlib_acknowledgement = "zlib-acknowledgement" +licenseId Zlib = "Zlib" +licenseId ZPL_1_1 = "ZPL-1.1" +licenseId ZPL_2_0 = "ZPL-2.0" +licenseId ZPL_2_1 = "ZPL-2.1" + +-- | License name, e.g. @"GNU General Public License v2.0 only"@ +licenseName :: LicenseId -> String +licenseName NullBSD = "BSD Zero Clause License" +licenseName AAL = "Attribution Assurance License" +licenseName Abstyles = "Abstyles License" +licenseName Adobe_2006 = "Adobe Systems Incorporated Source Code License Agreement" +licenseName Adobe_Glyph = "Adobe Glyph List License" +licenseName ADSL = "Amazon Digital Services License" +licenseName AFL_1_1 = "Academic Free License v1.1" +licenseName AFL_1_2 = "Academic Free License v1.2" +licenseName AFL_2_0 = "Academic Free License v2.0" +licenseName AFL_2_1 = "Academic Free License v2.1" +licenseName AFL_3_0 = "Academic Free License v3.0" +licenseName Afmparse = "Afmparse License" +licenseName AGPL_1_0 = "Affero General Public License v1.0" +licenseName AGPL_1_0_only = "Affero General Public License v1.0 only" +licenseName AGPL_1_0_or_later = "Affero General Public License v1.0 or later" +licenseName AGPL_3_0_only = "GNU Affero General Public License v3.0 only" +licenseName AGPL_3_0_or_later = "GNU Affero General Public License v3.0 or later" +licenseName Aladdin = "Aladdin Free Public License" +licenseName AMDPLPA = "AMD's plpa_map.c License" +licenseName AML = "Apple MIT License" +licenseName AMPAS = "Academy of Motion Picture Arts and Sciences BSD" +licenseName ANTLR_PD_fallback = "ANTLR Software Rights Notice with license fallback" +licenseName ANTLR_PD = "ANTLR Software Rights Notice" +licenseName Apache_1_0 = "Apache License 1.0" +licenseName Apache_1_1 = "Apache License 1.1" +licenseName Apache_2_0 = "Apache License 2.0" +licenseName APAFML = "Adobe Postscript AFM License" +licenseName APL_1_0 = "Adaptive Public License 1.0" +licenseName App_s2p = "App::s2p License" +licenseName APSL_1_0 = "Apple Public Source License 1.0" +licenseName APSL_1_1 = "Apple Public Source License 1.1" +licenseName APSL_1_2 = "Apple Public Source License 1.2" +licenseName APSL_2_0 = "Apple Public Source License 2.0" +licenseName Artistic_1_0_cl8 = "Artistic License 1.0 w/clause 8" +licenseName Artistic_1_0_Perl = "Artistic License 1.0 (Perl)" +licenseName Artistic_1_0 = "Artistic License 1.0" +licenseName Artistic_2_0 = "Artistic License 2.0" +licenseName Bahyph = "Bahyph License" +licenseName Barr = "Barr License" +licenseName Beerware = "Beerware License" +licenseName BitTorrent_1_0 = "BitTorrent Open Source License v1.0" +licenseName BitTorrent_1_1 = "BitTorrent Open Source License v1.1" +licenseName Blessing = "SQLite Blessing" +licenseName BlueOak_1_0_0 = "Blue Oak Model License 1.0.0" +licenseName Borceux = "Borceux license" +licenseName BSD_1_Clause = "BSD 1-Clause License" +licenseName BSD_2_Clause_FreeBSD = "BSD 2-Clause FreeBSD License" +licenseName BSD_2_Clause_NetBSD = "BSD 2-Clause NetBSD License" +licenseName BSD_2_Clause_Patent = "BSD-2-Clause Plus Patent License" +licenseName BSD_2_Clause_Views = "BSD 2-Clause with views sentence" +licenseName BSD_2_Clause = "BSD 2-Clause \"Simplified\" License" +licenseName BSD_3_Clause_Attribution = "BSD with attribution" +licenseName BSD_3_Clause_Clear = "BSD 3-Clause Clear License" +licenseName BSD_3_Clause_LBNL = "Lawrence Berkeley National Labs BSD variant license" +licenseName BSD_3_Clause_Modification = "BSD 3-Clause Modification" +licenseName BSD_3_Clause_No_Military_License = "BSD 3-Clause No Military License" +licenseName BSD_3_Clause_No_Nuclear_License_2014 = "BSD 3-Clause No Nuclear License 2014" +licenseName BSD_3_Clause_No_Nuclear_License = "BSD 3-Clause No Nuclear License" +licenseName BSD_3_Clause_No_Nuclear_Warranty = "BSD 3-Clause No Nuclear Warranty" +licenseName BSD_3_Clause_Open_MPI = "BSD 3-Clause Open MPI variant" +licenseName BSD_3_Clause = "BSD 3-Clause \"New\" or \"Revised\" License" +licenseName BSD_4_Clause_Shortened = "BSD 4 Clause Shortened" +licenseName BSD_4_Clause_UC = "BSD-4-Clause (University of California-Specific)" +licenseName BSD_4_Clause = "BSD 4-Clause \"Original\" or \"Old\" License" +licenseName BSD_Protection = "BSD Protection License" +licenseName BSD_Source_Code = "BSD Source Code Attribution" +licenseName BSL_1_0 = "Boost Software License 1.0" +licenseName Bzip2_1_0_5 = "bzip2 and libbzip2 License v1.0.5" +licenseName BUSL_1_1 = "Business Source License 1.1" +licenseName Bzip2_1_0_6 = "bzip2 and libbzip2 License v1.0.6" +licenseName C_UDA_1_0 = "Computational Use of Data Agreement v1.0" +licenseName CAL_1_0_Combined_Work_Exception = "Cryptographic Autonomy License 1.0 (Combined Work Exception)" +licenseName CAL_1_0 = "Cryptographic Autonomy License 1.0" +licenseName Caldera = "Caldera License" +licenseName CATOSL_1_1 = "Computer Associates Trusted Open Source License 1.1" +licenseName CC_BY_1_0 = "Creative Commons Attribution 1.0 Generic" +licenseName CC_BY_2_0 = "Creative Commons Attribution 2.0 Generic" +licenseName CC_BY_2_5_AU = "Creative Commons Attribution 2.5 Australia" +licenseName CC_BY_2_5 = "Creative Commons Attribution 2.5 Generic" +licenseName CC_BY_3_0_AT = "Creative Commons Attribution 3.0 Austria" +licenseName CC_BY_3_0_DE = "Creative Commons Attribution 3.0 Germany" +licenseName CC_BY_3_0_NL = "Creative Commons Attribution 3.0 Netherlands" +licenseName CC_BY_3_0_US = "Creative Commons Attribution 3.0 United States" +licenseName CC_BY_3_0 = "Creative Commons Attribution 3.0 Unported" +licenseName CC_BY_4_0 = "Creative Commons Attribution 4.0 International" +licenseName CC_BY_NC_1_0 = "Creative Commons Attribution Non Commercial 1.0 Generic" +licenseName CC_BY_NC_2_0 = "Creative Commons Attribution Non Commercial 2.0 Generic" +licenseName CC_BY_NC_2_5 = "Creative Commons Attribution Non Commercial 2.5 Generic" +licenseName CC_BY_NC_3_0_DE = "Creative Commons Attribution Non Commercial 3.0 Germany" +licenseName CC_BY_NC_3_0 = "Creative Commons Attribution Non Commercial 3.0 Unported" +licenseName CC_BY_NC_4_0 = "Creative Commons Attribution Non Commercial 4.0 International" +licenseName CC_BY_NC_ND_1_0 = "Creative Commons Attribution Non Commercial No Derivatives 1.0 Generic" +licenseName CC_BY_NC_ND_2_0 = "Creative Commons Attribution Non Commercial No Derivatives 2.0 Generic" +licenseName CC_BY_NC_ND_2_5 = "Creative Commons Attribution Non Commercial No Derivatives 2.5 Generic" +licenseName CC_BY_NC_ND_3_0_DE = "Creative Commons Attribution Non Commercial No Derivatives 3.0 Germany" +licenseName CC_BY_NC_ND_3_0_IGO = "Creative Commons Attribution Non Commercial No Derivatives 3.0 IGO" +licenseName CC_BY_NC_ND_3_0 = "Creative Commons Attribution Non Commercial No Derivatives 3.0 Unported" +licenseName CC_BY_NC_ND_4_0 = "Creative Commons Attribution Non Commercial No Derivatives 4.0 International" +licenseName CC_BY_NC_SA_1_0 = "Creative Commons Attribution Non Commercial Share Alike 1.0 Generic" +licenseName CC_BY_NC_SA_2_0_FR = "Creative Commons Attribution-NonCommercial-ShareAlike 2.0 France" +licenseName CC_BY_NC_SA_2_0_UK = "Creative Commons Attribution Non Commercial Share Alike 2.0 England and Wales" +licenseName CC_BY_NC_SA_2_0 = "Creative Commons Attribution Non Commercial Share Alike 2.0 Generic" +licenseName CC_BY_NC_SA_2_5 = "Creative Commons Attribution Non Commercial Share Alike 2.5 Generic" +licenseName CC_BY_NC_SA_3_0_DE = "Creative Commons Attribution Non Commercial Share Alike 3.0 Germany" +licenseName CC_BY_NC_SA_3_0_IGO = "Creative Commons Attribution Non Commercial Share Alike 3.0 IGO" +licenseName CC_BY_NC_SA_3_0 = "Creative Commons Attribution Non Commercial Share Alike 3.0 Unported" +licenseName CC_BY_NC_SA_4_0 = "Creative Commons Attribution Non Commercial Share Alike 4.0 International" +licenseName CC_BY_ND_1_0 = "Creative Commons Attribution No Derivatives 1.0 Generic" +licenseName CC_BY_ND_2_0 = "Creative Commons Attribution No Derivatives 2.0 Generic" +licenseName CC_BY_ND_2_5 = "Creative Commons Attribution No Derivatives 2.5 Generic" +licenseName CC_BY_ND_3_0_DE = "Creative Commons Attribution No Derivatives 3.0 Germany" +licenseName CC_BY_ND_3_0 = "Creative Commons Attribution No Derivatives 3.0 Unported" +licenseName CC_BY_ND_4_0 = "Creative Commons Attribution No Derivatives 4.0 International" +licenseName CC_BY_SA_1_0 = "Creative Commons Attribution Share Alike 1.0 Generic" +licenseName CC_BY_SA_2_0_UK = "Creative Commons Attribution Share Alike 2.0 England and Wales" +licenseName CC_BY_SA_2_0 = "Creative Commons Attribution Share Alike 2.0 Generic" +licenseName CC_BY_SA_2_1_JP = "Creative Commons Attribution Share Alike 2.1 Japan" +licenseName CC_BY_SA_2_5 = "Creative Commons Attribution Share Alike 2.5 Generic" +licenseName CC_BY_SA_3_0_AT = "Creative Commons Attribution Share Alike 3.0 Austria" +licenseName CC_BY_SA_3_0_DE = "Creative Commons Attribution Share Alike 3.0 Germany" +licenseName CC_BY_SA_3_0 = "Creative Commons Attribution Share Alike 3.0 Unported" +licenseName CC_BY_SA_4_0 = "Creative Commons Attribution Share Alike 4.0 International" +licenseName CC_PDDC = "Creative Commons Public Domain Dedication and Certification" +licenseName CC0_1_0 = "Creative Commons Zero v1.0 Universal" +licenseName CDDL_1_0 = "Common Development and Distribution License 1.0" +licenseName CDDL_1_1 = "Common Development and Distribution License 1.1" +licenseName CDL_1_0 = "Common Documentation License 1.0" +licenseName CDLA_Permissive_1_0 = "Community Data License Agreement Permissive 1.0" +licenseName CDLA_Permissive_2_0 = "Community Data License Agreement Permissive 2.0" +licenseName CDLA_Sharing_1_0 = "Community Data License Agreement Sharing 1.0" +licenseName CECILL_1_0 = "CeCILL Free Software License Agreement v1.0" +licenseName CECILL_1_1 = "CeCILL Free Software License Agreement v1.1" +licenseName CECILL_2_0 = "CeCILL Free Software License Agreement v2.0" +licenseName CECILL_2_1 = "CeCILL Free Software License Agreement v2.1" +licenseName CECILL_B = "CeCILL-B Free Software License Agreement" +licenseName CECILL_C = "CeCILL-C Free Software License Agreement" +licenseName CERN_OHL_1_1 = "CERN Open Hardware Licence v1.1" +licenseName CERN_OHL_1_2 = "CERN Open Hardware Licence v1.2" +licenseName CERN_OHL_P_2_0 = "CERN Open Hardware Licence Version 2 - Permissive" +licenseName CERN_OHL_S_2_0 = "CERN Open Hardware Licence Version 2 - Strongly Reciprocal" +licenseName CERN_OHL_W_2_0 = "CERN Open Hardware Licence Version 2 - Weakly Reciprocal" +licenseName ClArtistic = "Clarified Artistic License" +licenseName CNRI_Jython = "CNRI Jython License" +licenseName CNRI_Python_GPL_Compatible = "CNRI Python Open Source GPL Compatible License Agreement" +licenseName CNRI_Python = "CNRI Python License" +licenseName COIL_1_0 = "Copyfree Open Innovation License" +licenseName Community_Spec_1_0 = "Community Specification License 1.0" +licenseName Condor_1_1 = "Condor Public License v1.1" +licenseName Copyleft_next_0_3_0 = "copyleft-next 0.3.0" +licenseName Copyleft_next_0_3_1 = "copyleft-next 0.3.1" +licenseName CPAL_1_0 = "Common Public Attribution License 1.0" +licenseName CPL_1_0 = "Common Public License 1.0" +licenseName CPOL_1_02 = "Code Project Open License 1.02" +licenseName Crossword = "Crossword License" +licenseName CrystalStacker = "CrystalStacker License" +licenseName CUA_OPL_1_0 = "CUA Office Public License v1.0" +licenseName Cube = "Cube License" +licenseName Curl = "curl License" +licenseName D_FSL_1_0 = "Deutsche Freie Software Lizenz" +licenseName Diffmark = "diffmark license" +licenseName DL_DE_BY_2_0 = "Data licence Germany \8211 attribution \8211 version 2.0" +licenseName DOC = "DOC License" +licenseName Dotseqn = "Dotseqn License" +licenseName DRL_1_0 = "Detection Rule License 1.0" +licenseName DSDP = "DSDP License" +licenseName Dvipdfm = "dvipdfm License" +licenseName ECL_1_0 = "Educational Community License v1.0" +licenseName ECL_2_0 = "Educational Community License v2.0" +licenseName EFL_1_0 = "Eiffel Forum License v1.0" +licenseName EFL_2_0 = "Eiffel Forum License v2.0" +licenseName EGenix = "eGenix.com Public License 1.1.0" +licenseName Elastic_2_0 = "Elastic License 2.0" +licenseName Entessa = "Entessa Public License v1.0" +licenseName EPICS = "EPICS Open License" +licenseName EPL_1_0 = "Eclipse Public License 1.0" +licenseName EPL_2_0 = "Eclipse Public License 2.0" +licenseName ErlPL_1_1 = "Erlang Public License v1.1" +licenseName Etalab_2_0 = "Etalab Open License 2.0" +licenseName EUDatagrid = "EU DataGrid Software License" +licenseName EUPL_1_0 = "European Union Public License 1.0" +licenseName EUPL_1_1 = "European Union Public License 1.1" +licenseName EUPL_1_2 = "European Union Public License 1.2" +licenseName Eurosym = "Eurosym License" +licenseName Fair = "Fair License" +licenseName FDK_AAC = "Fraunhofer FDK AAC Codec Library" +licenseName Frameworx_1_0 = "Frameworx Open License 1.0" +licenseName FreeBSD_DOC = "FreeBSD Documentation License" +licenseName FreeImage = "FreeImage Public License v1.0" +licenseName FSFAP = "FSF All Permissive License" +licenseName FSFULLR = "FSF Unlimited License (with License Retention)" +licenseName FSFUL = "FSF Unlimited License" +licenseName FTL = "Freetype Project License" +licenseName GD = "GD License" +licenseName GFDL_1_1_invariants_only = "GNU Free Documentation License v1.1 only - invariants" +licenseName GFDL_1_1_invariants_or_later = "GNU Free Documentation License v1.1 or later - invariants" +licenseName GFDL_1_1_no_invariants_only = "GNU Free Documentation License v1.1 only - no invariants" +licenseName GFDL_1_1_no_invariants_or_later = "GNU Free Documentation License v1.1 or later - no invariants" +licenseName GFDL_1_1_only = "GNU Free Documentation License v1.1 only" +licenseName GFDL_1_1_or_later = "GNU Free Documentation License v1.1 or later" +licenseName GFDL_1_2_invariants_only = "GNU Free Documentation License v1.2 only - invariants" +licenseName GFDL_1_2_invariants_or_later = "GNU Free Documentation License v1.2 or later - invariants" +licenseName GFDL_1_2_no_invariants_only = "GNU Free Documentation License v1.2 only - no invariants" +licenseName GFDL_1_2_no_invariants_or_later = "GNU Free Documentation License v1.2 or later - no invariants" +licenseName GFDL_1_2_only = "GNU Free Documentation License v1.2 only" +licenseName GFDL_1_2_or_later = "GNU Free Documentation License v1.2 or later" +licenseName GFDL_1_3_invariants_only = "GNU Free Documentation License v1.3 only - invariants" +licenseName GFDL_1_3_invariants_or_later = "GNU Free Documentation License v1.3 or later - invariants" +licenseName GFDL_1_3_no_invariants_only = "GNU Free Documentation License v1.3 only - no invariants" +licenseName GFDL_1_3_no_invariants_or_later = "GNU Free Documentation License v1.3 or later - no invariants" +licenseName GFDL_1_3_only = "GNU Free Documentation License v1.3 only" +licenseName GFDL_1_3_or_later = "GNU Free Documentation License v1.3 or later" +licenseName Giftware = "Giftware License" +licenseName GL2PS = "GL2PS License" +licenseName Glide = "3dfx Glide License" +licenseName Glulxe = "Glulxe License" +licenseName GLWTPL = "Good Luck With That Public License" +licenseName Gnuplot = "gnuplot License" +licenseName GPL_1_0_only = "GNU General Public License v1.0 only" +licenseName GPL_1_0_or_later = "GNU General Public License v1.0 or later" +licenseName GPL_2_0_only = "GNU General Public License v2.0 only" +licenseName GPL_2_0_or_later = "GNU General Public License v2.0 or later" +licenseName GPL_3_0_only = "GNU General Public License v3.0 only" +licenseName GPL_3_0_or_later = "GNU General Public License v3.0 or later" +licenseName GSOAP_1_3b = "gSOAP Public License v1.3b" +licenseName HaskellReport = "Haskell Language Report License" +licenseName Hippocratic_2_1 = "Hippocratic License 2.1" +licenseName HPND_sell_variant = "Historical Permission Notice and Disclaimer - sell variant" +licenseName HPND = "Historical Permission Notice and Disclaimer" +licenseName HTMLTIDY = "HTML Tidy License" +licenseName IBM_pibs = "IBM PowerPC Initialization and Boot Software" +licenseName ICU = "ICU License" +licenseName IJG = "Independent JPEG Group License" +licenseName ImageMagick = "ImageMagick License" +licenseName IMatix = "iMatix Standard Function Library Agreement" +licenseName Imlib2 = "Imlib2 License" +licenseName Info_ZIP = "Info-ZIP License" +licenseName Intel_ACPI = "Intel ACPI Software License Agreement" +licenseName Intel = "Intel Open Source License" +licenseName Interbase_1_0 = "Interbase Public License v1.0" +licenseName IPA = "IPA Font License" +licenseName IPL_1_0 = "IBM Public License v1.0" +licenseName ISC = "ISC License" +licenseName Jam = "Jam License" +licenseName JasPer_2_0 = "JasPer License" +licenseName JPNIC = "Japan Network Information Center License" +licenseName JSON = "JSON License" +licenseName LAL_1_2 = "Licence Art Libre 1.2" +licenseName LAL_1_3 = "Licence Art Libre 1.3" +licenseName Latex2e = "Latex2e License" +licenseName Leptonica = "Leptonica License" +licenseName LGPL_2_0_only = "GNU Library General Public License v2 only" +licenseName LGPL_2_0_or_later = "GNU Library General Public License v2 or later" +licenseName LGPL_2_1_only = "GNU Lesser General Public License v2.1 only" +licenseName LGPL_2_1_or_later = "GNU Lesser General Public License v2.1 or later" +licenseName LGPL_3_0_only = "GNU Lesser General Public License v3.0 only" +licenseName LGPL_3_0_or_later = "GNU Lesser General Public License v3.0 or later" +licenseName LGPLLR = "Lesser General Public License For Linguistic Resources" +licenseName Libpng_2_0 = "PNG Reference Library version 2" +licenseName Libpng = "libpng License" +licenseName Libselinux_1_0 = "libselinux public domain notice" +licenseName Libtiff = "libtiff License" +licenseName LiLiQ_P_1_1 = "Licence Libre du Qu\233bec \8211 Permissive version 1.1" +licenseName LiLiQ_R_1_1 = "Licence Libre du Qu\233bec \8211 R\233ciprocit\233 version 1.1" +licenseName LiLiQ_Rplus_1_1 = "Licence Libre du Qu\233bec \8211 R\233ciprocit\233 forte version 1.1" +licenseName Linux_man_pages_copyleft = "Linux man-pages Copyleft" +licenseName Linux_OpenIB = "Linux Kernel Variant of OpenIB.org license" +licenseName LPL_1_02 = "Lucent Public License v1.02" +licenseName LPL_1_0 = "Lucent Public License Version 1.0" +licenseName LPPL_1_0 = "LaTeX Project Public License v1.0" +licenseName LPPL_1_1 = "LaTeX Project Public License v1.1" +licenseName LPPL_1_2 = "LaTeX Project Public License v1.2" +licenseName LPPL_1_3a = "LaTeX Project Public License v1.3a" +licenseName LPPL_1_3c = "LaTeX Project Public License v1.3c" +licenseName MakeIndex = "MakeIndex License" +licenseName MirOS = "The MirOS Licence" +licenseName MIT_0 = "MIT No Attribution" +licenseName MIT_advertising = "Enlightenment License (e16)" +licenseName MIT_CMU = "CMU License" +licenseName MIT_enna = "enna License" +licenseName MIT_feh = "feh License" +licenseName MIT_Modern_Variant = "MIT License Modern Variant" +licenseName MIT_open_group = "MIT Open Group variant" +licenseName MITNFA = "MIT +no-false-attribs license" +licenseName MIT = "MIT License" +licenseName Motosoto = "Motosoto License" +licenseName Mpich2 = "mpich2 License" +licenseName MPL_1_0 = "Mozilla Public License 1.0" +licenseName MPL_1_1 = "Mozilla Public License 1.1" +licenseName MPL_2_0_no_copyleft_exception = "Mozilla Public License 2.0 (no copyleft exception)" +licenseName MPL_2_0 = "Mozilla Public License 2.0" +licenseName MS_PL = "Microsoft Public License" +licenseName MS_RL = "Microsoft Reciprocal License" +licenseName MTLL = "Matrix Template Library License" +licenseName MulanPSL_1_0 = "Mulan Permissive Software License, Version 1" +licenseName MulanPSL_2_0 = "Mulan Permissive Software License, Version 2" +licenseName Multics = "Multics License" +licenseName Mup = "Mup License" +licenseName NAIST_2003 = "Nara Institute of Science and Technology License (2003)" +licenseName NASA_1_3 = "NASA Open Source Agreement 1.3" +licenseName Naumen = "Naumen Public License" +licenseName NBPL_1_0 = "Net Boolean Public License v1" +licenseName NCGL_UK_2_0 = "Non-Commercial Government Licence" +licenseName NCSA = "University of Illinois/NCSA Open Source License" +licenseName Net_SNMP = "Net-SNMP License" +licenseName NetCDF = "NetCDF license" +licenseName Newsletr = "Newsletr License" +licenseName NGPL = "Nethack General Public License" +licenseName NIST_PD_fallback = "NIST Public Domain Notice with license fallback" +licenseName NIST_PD = "NIST Public Domain Notice" +licenseName NLOD_1_0 = "Norwegian Licence for Open Government Data (NLOD) 1.0" +licenseName NLOD_2_0 = "Norwegian Licence for Open Government Data (NLOD) 2.0" +licenseName NLPL = "No Limit Public License" +licenseName Nokia = "Nokia Open Source License" +licenseName NOSL = "Netizen Open Source License" +licenseName Noweb = "Noweb License" +licenseName NPL_1_0 = "Netscape Public License v1.0" +licenseName NPL_1_1 = "Netscape Public License v1.1" +licenseName NPOSL_3_0 = "Non-Profit Open Software License 3.0" +licenseName NRL = "NRL License" +licenseName NTP_0 = "NTP No Attribution" +licenseName NTP = "NTP License" +licenseName O_UDA_1_0 = "Open Use of Data Agreement v1.0" +licenseName OCCT_PL = "Open CASCADE Technology Public License" +licenseName OCLC_2_0 = "OCLC Research Public License 2.0" +licenseName ODbL_1_0 = "Open Data Commons Open Database License v1.0" +licenseName ODC_By_1_0 = "Open Data Commons Attribution License v1.0" +licenseName OFL_1_0_no_RFN = "SIL Open Font License 1.0 with no Reserved Font Name" +licenseName OFL_1_0_RFN = "SIL Open Font License 1.0 with Reserved Font Name" +licenseName OFL_1_0 = "SIL Open Font License 1.0" +licenseName OFL_1_1_no_RFN = "SIL Open Font License 1.1 with no Reserved Font Name" +licenseName OFL_1_1_RFN = "SIL Open Font License 1.1 with Reserved Font Name" +licenseName OFL_1_1 = "SIL Open Font License 1.1" +licenseName OGC_1_0 = "OGC Software License, Version 1.0" +licenseName OGDL_Taiwan_1_0 = "Taiwan Open Government Data License, version 1.0" +licenseName OGL_Canada_2_0 = "Open Government Licence - Canada" +licenseName OGL_UK_1_0 = "Open Government Licence v1.0" +licenseName OGL_UK_2_0 = "Open Government Licence v2.0" +licenseName OGL_UK_3_0 = "Open Government Licence v3.0" +licenseName OGTSL = "Open Group Test Suite License" +licenseName OLDAP_1_1 = "Open LDAP Public License v1.1" +licenseName OLDAP_1_2 = "Open LDAP Public License v1.2" +licenseName OLDAP_1_3 = "Open LDAP Public License v1.3" +licenseName OLDAP_1_4 = "Open LDAP Public License v1.4" +licenseName OLDAP_2_0_1 = "Open LDAP Public License v2.0.1" +licenseName OLDAP_2_0 = "Open LDAP Public License v2.0 (or possibly 2.0A and 2.0B)" +licenseName OLDAP_2_1 = "Open LDAP Public License v2.1" +licenseName OLDAP_2_2_1 = "Open LDAP Public License v2.2.1" +licenseName OLDAP_2_2_2 = "Open LDAP Public License 2.2.2" +licenseName OLDAP_2_2 = "Open LDAP Public License v2.2" +licenseName OLDAP_2_3 = "Open LDAP Public License v2.3" +licenseName OLDAP_2_4 = "Open LDAP Public License v2.4" +licenseName OLDAP_2_5 = "Open LDAP Public License v2.5" +licenseName OLDAP_2_6 = "Open LDAP Public License v2.6" +licenseName OLDAP_2_7 = "Open LDAP Public License v2.7" +licenseName OLDAP_2_8 = "Open LDAP Public License v2.8" +licenseName OML = "Open Market License" +licenseName OpenSSL = "OpenSSL License" +licenseName OPL_1_0 = "Open Public License v1.0" +licenseName OPUBL_1_0 = "Open Publication License v1.0" +licenseName OSET_PL_2_1 = "OSET Public License version 2.1" +licenseName OSL_1_0 = "Open Software License 1.0" +licenseName OSL_1_1 = "Open Software License 1.1" +licenseName OSL_2_0 = "Open Software License 2.0" +licenseName OSL_2_1 = "Open Software License 2.1" +licenseName OSL_3_0 = "Open Software License 3.0" +licenseName Parity_6_0_0 = "The Parity Public License 6.0.0" +licenseName Parity_7_0_0 = "The Parity Public License 7.0.0" +licenseName PDDL_1_0 = "Open Data Commons Public Domain Dedication & License 1.0" +licenseName PHP_3_01 = "PHP License v3.01" +licenseName PHP_3_0 = "PHP License v3.0" +licenseName Plexus = "Plexus Classworlds License" +licenseName PolyForm_Noncommercial_1_0_0 = "PolyForm Noncommercial License 1.0.0" +licenseName PolyForm_Small_Business_1_0_0 = "PolyForm Small Business License 1.0.0" +licenseName PostgreSQL = "PostgreSQL License" +licenseName PSF_2_0 = "Python Software Foundation License 2.0" +licenseName Psfrag = "psfrag License" +licenseName Psutils = "psutils License" +licenseName Python_2_0 = "Python License 2.0" +licenseName Qhull = "Qhull License" +licenseName QPL_1_0 = "Q Public License 1.0" +licenseName Rdisc = "Rdisc License" +licenseName RHeCos_1_1 = "Red Hat eCos Public License v1.1" +licenseName RPL_1_1 = "Reciprocal Public License 1.1" +licenseName RPL_1_5 = "Reciprocal Public License 1.5" +licenseName RPSL_1_0 = "RealNetworks Public Source License v1.0" +licenseName RSA_MD = "RSA Message-Digest License" +licenseName RSCPL = "Ricoh Source Code Public License" +licenseName Ruby = "Ruby License" +licenseName SAX_PD = "Sax Public Domain Notice" +licenseName Saxpath = "Saxpath License" +licenseName SCEA = "SCEA Shared Source License" +licenseName SchemeReport = "Scheme Language Report License" +licenseName Sendmail_8_23 = "Sendmail License 8.23" +licenseName Sendmail = "Sendmail License" +licenseName SGI_B_1_0 = "SGI Free Software License B v1.0" +licenseName SGI_B_1_1 = "SGI Free Software License B v1.1" +licenseName SGI_B_2_0 = "SGI Free Software License B v2.0" +licenseName SHL_0_51 = "Solderpad Hardware License, Version 0.51" +licenseName SHL_0_5 = "Solderpad Hardware License v0.5" +licenseName SimPL_2_0 = "Simple Public License 2.0" +licenseName SISSL_1_2 = "Sun Industry Standards Source License v1.2" +licenseName SISSL = "Sun Industry Standards Source License v1.1" +licenseName Sleepycat = "Sleepycat License" +licenseName SMLNJ = "Standard ML of New Jersey License" +licenseName SMPPL = "Secure Messaging Protocol Public License" +licenseName SNIA = "SNIA Public License 1.1" +licenseName Spencer_86 = "Spencer License 86" +licenseName Spencer_94 = "Spencer License 94" +licenseName Spencer_99 = "Spencer License 99" +licenseName SPL_1_0 = "Sun Public License v1.0" +licenseName SSH_OpenSSH = "SSH OpenSSH license" +licenseName SSH_short = "SSH short notice" +licenseName SSPL_1_0 = "Server Side Public License, v 1" +licenseName SugarCRM_1_1_3 = "SugarCRM Public License v1.1.3" +licenseName SWL = "Scheme Widget Library (SWL) Software License Agreement" +licenseName TAPR_OHL_1_0 = "TAPR Open Hardware License v1.0" +licenseName TCL = "TCL/TK License" +licenseName TCP_wrappers = "TCP Wrappers License" +licenseName TMate = "TMate Open Source License" +licenseName TORQUE_1_1 = "TORQUE v2.5+ Software License v1.1" +licenseName TOSL = "Trusster Open Source License" +licenseName TU_Berlin_1_0 = "Technische Universitaet Berlin License 1.0" +licenseName TU_Berlin_2_0 = "Technische Universitaet Berlin License 2.0" +licenseName UCL_1_0 = "Upstream Compatibility License v1.0" +licenseName Unicode_DFS_2015 = "Unicode License Agreement - Data Files and Software (2015)" +licenseName Unicode_DFS_2016 = "Unicode License Agreement - Data Files and Software (2016)" +licenseName Unicode_TOU = "Unicode Terms of Use" +licenseName Unlicense = "The Unlicense" +licenseName UPL_1_0 = "Universal Permissive License v1.0" +licenseName Vim = "Vim License" +licenseName VOSTROM = "VOSTROM Public License for Open Source" +licenseName VSL_1_0 = "Vovida Software License v1.0" +licenseName W3C_19980720 = "W3C Software Notice and License (1998-07-20)" +licenseName W3C_20150513 = "W3C Software Notice and Document License (2015-05-13)" +licenseName W3C = "W3C Software Notice and License (2002-12-31)" +licenseName Watcom_1_0 = "Sybase Open Watcom Public License 1.0" +licenseName Wsuipa = "Wsuipa License" +licenseName WTFPL = "Do What The F*ck You Want To Public License" +licenseName X11_distribute_modifications_variant = "X11 License Distribution Modification Variant" +licenseName X11 = "X11 License" +licenseName Xerox = "Xerox License" +licenseName XFree86_1_1 = "XFree86 License 1.1" +licenseName Xinetd = "xinetd License" +licenseName Xnet = "X.Net License" +licenseName Xpp = "XPP License" +licenseName XSkat = "XSkat License" +licenseName YPL_1_0 = "Yahoo! Public License v1.0" +licenseName YPL_1_1 = "Yahoo! Public License v1.1" +licenseName Zed = "Zed License" +licenseName Zend_2_0 = "Zend License v2.0" +licenseName Zimbra_1_3 = "Zimbra Public License v1.3" +licenseName Zimbra_1_4 = "Zimbra Public License v1.4" +licenseName Zlib_acknowledgement = "zlib/libpng License with Acknowledgement" +licenseName Zlib = "zlib License" +licenseName ZPL_1_1 = "Zope Public License 1.1" +licenseName ZPL_2_0 = "Zope Public License 2.0" +licenseName ZPL_2_1 = "Zope Public License 2.1" + +-- | Whether the license is approved by Open Source Initiative (OSI). +-- +-- See . +licenseIsOsiApproved :: LicenseId -> Bool +licenseIsOsiApproved NullBSD = True +licenseIsOsiApproved AAL = True +licenseIsOsiApproved AFL_1_1 = True +licenseIsOsiApproved AFL_1_2 = True +licenseIsOsiApproved AFL_2_0 = True +licenseIsOsiApproved AFL_2_1 = True +licenseIsOsiApproved AFL_3_0 = True +licenseIsOsiApproved AGPL_3_0_only = True +licenseIsOsiApproved AGPL_3_0_or_later = True +licenseIsOsiApproved Apache_1_1 = True +licenseIsOsiApproved Apache_2_0 = True +licenseIsOsiApproved APL_1_0 = True +licenseIsOsiApproved APSL_1_0 = True +licenseIsOsiApproved APSL_1_1 = True +licenseIsOsiApproved APSL_1_2 = True +licenseIsOsiApproved APSL_2_0 = True +licenseIsOsiApproved Artistic_1_0_cl8 = True +licenseIsOsiApproved Artistic_1_0_Perl = True +licenseIsOsiApproved Artistic_1_0 = True +licenseIsOsiApproved Artistic_2_0 = True +licenseIsOsiApproved BSD_1_Clause = True +licenseIsOsiApproved BSD_2_Clause_Patent = True +licenseIsOsiApproved BSD_2_Clause = True +licenseIsOsiApproved BSD_3_Clause_LBNL = True +licenseIsOsiApproved BSD_3_Clause = True +licenseIsOsiApproved BSL_1_0 = True +licenseIsOsiApproved CAL_1_0_Combined_Work_Exception = True +licenseIsOsiApproved CAL_1_0 = True +licenseIsOsiApproved CATOSL_1_1 = True +licenseIsOsiApproved CDDL_1_0 = True +licenseIsOsiApproved CECILL_2_1 = True +licenseIsOsiApproved CERN_OHL_P_2_0 = True +licenseIsOsiApproved CERN_OHL_S_2_0 = True +licenseIsOsiApproved CERN_OHL_W_2_0 = True +licenseIsOsiApproved CNRI_Python = True +licenseIsOsiApproved CPAL_1_0 = True +licenseIsOsiApproved CPL_1_0 = True +licenseIsOsiApproved CUA_OPL_1_0 = True +licenseIsOsiApproved ECL_1_0 = True +licenseIsOsiApproved ECL_2_0 = True +licenseIsOsiApproved EFL_1_0 = True +licenseIsOsiApproved EFL_2_0 = True +licenseIsOsiApproved Entessa = True +licenseIsOsiApproved EPL_1_0 = True +licenseIsOsiApproved EPL_2_0 = True +licenseIsOsiApproved EUDatagrid = True +licenseIsOsiApproved EUPL_1_1 = True +licenseIsOsiApproved EUPL_1_2 = True +licenseIsOsiApproved Fair = True +licenseIsOsiApproved Frameworx_1_0 = True +licenseIsOsiApproved GPL_2_0_only = True +licenseIsOsiApproved GPL_2_0_or_later = True +licenseIsOsiApproved GPL_3_0_only = True +licenseIsOsiApproved GPL_3_0_or_later = True +licenseIsOsiApproved HPND = True +licenseIsOsiApproved Intel = True +licenseIsOsiApproved IPA = True +licenseIsOsiApproved IPL_1_0 = True +licenseIsOsiApproved ISC = True +licenseIsOsiApproved LGPL_2_0_only = True +licenseIsOsiApproved LGPL_2_0_or_later = True +licenseIsOsiApproved LGPL_2_1_only = True +licenseIsOsiApproved LGPL_2_1_or_later = True +licenseIsOsiApproved LGPL_3_0_only = True +licenseIsOsiApproved LGPL_3_0_or_later = True +licenseIsOsiApproved LiLiQ_P_1_1 = True +licenseIsOsiApproved LiLiQ_R_1_1 = True +licenseIsOsiApproved LiLiQ_Rplus_1_1 = True +licenseIsOsiApproved LPL_1_02 = True +licenseIsOsiApproved LPL_1_0 = True +licenseIsOsiApproved LPPL_1_3c = True +licenseIsOsiApproved MirOS = True +licenseIsOsiApproved MIT_0 = True +licenseIsOsiApproved MIT_Modern_Variant = True +licenseIsOsiApproved MIT = True +licenseIsOsiApproved Motosoto = True +licenseIsOsiApproved MPL_1_0 = True +licenseIsOsiApproved MPL_1_1 = True +licenseIsOsiApproved MPL_2_0_no_copyleft_exception = True +licenseIsOsiApproved MPL_2_0 = True +licenseIsOsiApproved MS_PL = True +licenseIsOsiApproved MS_RL = True +licenseIsOsiApproved MulanPSL_2_0 = True +licenseIsOsiApproved Multics = True +licenseIsOsiApproved NASA_1_3 = True +licenseIsOsiApproved Naumen = True +licenseIsOsiApproved NCSA = True +licenseIsOsiApproved NGPL = True +licenseIsOsiApproved Nokia = True +licenseIsOsiApproved NPOSL_3_0 = True +licenseIsOsiApproved NTP = True +licenseIsOsiApproved OCLC_2_0 = True +licenseIsOsiApproved OFL_1_1_no_RFN = True +licenseIsOsiApproved OFL_1_1_RFN = True +licenseIsOsiApproved OFL_1_1 = True +licenseIsOsiApproved OGTSL = True +licenseIsOsiApproved OLDAP_2_8 = True +licenseIsOsiApproved OSET_PL_2_1 = True +licenseIsOsiApproved OSL_1_0 = True +licenseIsOsiApproved OSL_2_0 = True +licenseIsOsiApproved OSL_2_1 = True +licenseIsOsiApproved OSL_3_0 = True +licenseIsOsiApproved PHP_3_01 = True +licenseIsOsiApproved PHP_3_0 = True +licenseIsOsiApproved PostgreSQL = True +licenseIsOsiApproved Python_2_0 = True +licenseIsOsiApproved QPL_1_0 = True +licenseIsOsiApproved RPL_1_1 = True +licenseIsOsiApproved RPL_1_5 = True +licenseIsOsiApproved RPSL_1_0 = True +licenseIsOsiApproved RSCPL = True +licenseIsOsiApproved SimPL_2_0 = True +licenseIsOsiApproved SISSL = True +licenseIsOsiApproved Sleepycat = True +licenseIsOsiApproved SPL_1_0 = True +licenseIsOsiApproved UCL_1_0 = True +licenseIsOsiApproved Unicode_DFS_2016 = True +licenseIsOsiApproved Unlicense = True +licenseIsOsiApproved UPL_1_0 = True +licenseIsOsiApproved VSL_1_0 = True +licenseIsOsiApproved W3C = True +licenseIsOsiApproved Watcom_1_0 = True +licenseIsOsiApproved Xnet = True +licenseIsOsiApproved Zlib = True +licenseIsOsiApproved ZPL_2_0 = True +licenseIsOsiApproved ZPL_2_1 = True +licenseIsOsiApproved _ = False + +-- | Whether the license is considered libre by Free Software Foundation (FSF). +-- +-- See +-- +-- @since 3.4.0.0 +-- +licenseIsFsfLibre :: LicenseId -> Bool +licenseIsFsfLibre AFL_1_1 = True +licenseIsFsfLibre AFL_1_2 = True +licenseIsFsfLibre AFL_2_0 = True +licenseIsFsfLibre AFL_2_1 = True +licenseIsFsfLibre AFL_3_0 = True +licenseIsFsfLibre AGPL_1_0 = True +licenseIsFsfLibre AGPL_3_0_only = True +licenseIsFsfLibre AGPL_3_0_or_later = True +licenseIsFsfLibre Apache_1_0 = True +licenseIsFsfLibre Apache_1_1 = True +licenseIsFsfLibre Apache_2_0 = True +licenseIsFsfLibre APSL_2_0 = True +licenseIsFsfLibre Artistic_2_0 = True +licenseIsFsfLibre BitTorrent_1_1 = True +licenseIsFsfLibre BSD_2_Clause_FreeBSD = True +licenseIsFsfLibre BSD_2_Clause = True +licenseIsFsfLibre BSD_3_Clause_Clear = True +licenseIsFsfLibre BSD_3_Clause = True +licenseIsFsfLibre BSD_4_Clause = True +licenseIsFsfLibre BSL_1_0 = True +licenseIsFsfLibre CC_BY_4_0 = True +licenseIsFsfLibre CC_BY_SA_4_0 = True +licenseIsFsfLibre CC0_1_0 = True +licenseIsFsfLibre CDDL_1_0 = True +licenseIsFsfLibre CECILL_2_0 = True +licenseIsFsfLibre CECILL_B = True +licenseIsFsfLibre CECILL_C = True +licenseIsFsfLibre ClArtistic = True +licenseIsFsfLibre Condor_1_1 = True +licenseIsFsfLibre CPAL_1_0 = True +licenseIsFsfLibre CPL_1_0 = True +licenseIsFsfLibre ECL_2_0 = True +licenseIsFsfLibre EFL_2_0 = True +licenseIsFsfLibre EPL_1_0 = True +licenseIsFsfLibre EPL_2_0 = True +licenseIsFsfLibre EUDatagrid = True +licenseIsFsfLibre EUPL_1_1 = True +licenseIsFsfLibre EUPL_1_2 = True +licenseIsFsfLibre FSFAP = True +licenseIsFsfLibre FTL = True +licenseIsFsfLibre GFDL_1_1_only = True +licenseIsFsfLibre GFDL_1_1_or_later = True +licenseIsFsfLibre GFDL_1_2_only = True +licenseIsFsfLibre GFDL_1_2_or_later = True +licenseIsFsfLibre GFDL_1_3_only = True +licenseIsFsfLibre GFDL_1_3_or_later = True +licenseIsFsfLibre Gnuplot = True +licenseIsFsfLibre GPL_2_0_only = True +licenseIsFsfLibre GPL_2_0_or_later = True +licenseIsFsfLibre GPL_3_0_only = True +licenseIsFsfLibre GPL_3_0_or_later = True +licenseIsFsfLibre HPND = True +licenseIsFsfLibre IJG = True +licenseIsFsfLibre IMatix = True +licenseIsFsfLibre Imlib2 = True +licenseIsFsfLibre Intel = True +licenseIsFsfLibre IPA = True +licenseIsFsfLibre IPL_1_0 = True +licenseIsFsfLibre ISC = True +licenseIsFsfLibre LGPL_2_1_only = True +licenseIsFsfLibre LGPL_2_1_or_later = True +licenseIsFsfLibre LGPL_3_0_only = True +licenseIsFsfLibre LGPL_3_0_or_later = True +licenseIsFsfLibre LPL_1_02 = True +licenseIsFsfLibre LPPL_1_2 = True +licenseIsFsfLibre LPPL_1_3a = True +licenseIsFsfLibre MIT = True +licenseIsFsfLibre MPL_1_1 = True +licenseIsFsfLibre MPL_2_0 = True +licenseIsFsfLibre MS_PL = True +licenseIsFsfLibre MS_RL = True +licenseIsFsfLibre NCSA = True +licenseIsFsfLibre Nokia = True +licenseIsFsfLibre NOSL = True +licenseIsFsfLibre NPL_1_0 = True +licenseIsFsfLibre NPL_1_1 = True +licenseIsFsfLibre ODbL_1_0 = True +licenseIsFsfLibre OFL_1_0 = True +licenseIsFsfLibre OFL_1_1 = True +licenseIsFsfLibre OLDAP_2_3 = True +licenseIsFsfLibre OLDAP_2_7 = True +licenseIsFsfLibre OpenSSL = True +licenseIsFsfLibre OSL_1_0 = True +licenseIsFsfLibre OSL_1_1 = True +licenseIsFsfLibre OSL_2_0 = True +licenseIsFsfLibre OSL_2_1 = True +licenseIsFsfLibre OSL_3_0 = True +licenseIsFsfLibre PHP_3_01 = True +licenseIsFsfLibre Python_2_0 = True +licenseIsFsfLibre QPL_1_0 = True +licenseIsFsfLibre RPSL_1_0 = True +licenseIsFsfLibre Ruby = True +licenseIsFsfLibre SGI_B_2_0 = True +licenseIsFsfLibre SISSL = True +licenseIsFsfLibre Sleepycat = True +licenseIsFsfLibre SMLNJ = True +licenseIsFsfLibre SPL_1_0 = True +licenseIsFsfLibre Unlicense = True +licenseIsFsfLibre UPL_1_0 = True +licenseIsFsfLibre Vim = True +licenseIsFsfLibre W3C = True +licenseIsFsfLibre WTFPL = True +licenseIsFsfLibre X11 = True +licenseIsFsfLibre XFree86_1_1 = True +licenseIsFsfLibre Xinetd = True +licenseIsFsfLibre YPL_1_1 = True +licenseIsFsfLibre Zend_2_0 = True +licenseIsFsfLibre Zimbra_1_3 = True +licenseIsFsfLibre Zlib = True +licenseIsFsfLibre ZPL_2_0 = True +licenseIsFsfLibre ZPL_2_1 = True +licenseIsFsfLibre _ = False + +------------------------------------------------------------------------------- +-- Creation +------------------------------------------------------------------------------- + +licenseIdList :: LicenseListVersion -> [LicenseId] +licenseIdList LicenseListVersion_3_0 = + [ AGPL_1_0 + , BSD_2_Clause_FreeBSD + , BSD_2_Clause_NetBSD + , Bzip2_1_0_5 + ] + ++ bulkOfLicenses +licenseIdList LicenseListVersion_3_2 = + [ AGPL_1_0_only + , AGPL_1_0_or_later + , BSD_2_Clause_FreeBSD + , BSD_2_Clause_NetBSD + , Bzip2_1_0_5 + , Linux_OpenIB + , MIT_0 + , ODC_By_1_0 + , TU_Berlin_1_0 + , TU_Berlin_2_0 + ] + ++ bulkOfLicenses +licenseIdList LicenseListVersion_3_6 = + [ AGPL_1_0_only + , AGPL_1_0_or_later + , Blessing + , BlueOak_1_0_0 + , BSD_2_Clause_FreeBSD + , BSD_2_Clause_NetBSD + , BSD_3_Clause_Open_MPI + , Bzip2_1_0_5 + , CC_PDDC + , CERN_OHL_1_1 + , CERN_OHL_1_2 + , Copyleft_next_0_3_0 + , Copyleft_next_0_3_1 + , HPND_sell_variant + , JPNIC + , Libpng_2_0 + , Linux_OpenIB + , MIT_0 + , ODC_By_1_0 + , OGL_UK_1_0 + , OGL_UK_2_0 + , OGL_UK_3_0 + , Parity_6_0_0 + , Sendmail_8_23 + , SHL_0_51 + , SHL_0_5 + , SSPL_1_0 + , TAPR_OHL_1_0 + , TU_Berlin_1_0 + , TU_Berlin_2_0 + ] + ++ bulkOfLicenses +licenseIdList LicenseListVersion_3_9 = + [ AGPL_1_0_only + , AGPL_1_0_or_later + , Blessing + , BlueOak_1_0_0 + , BSD_2_Clause_FreeBSD + , BSD_3_Clause_Open_MPI + , Bzip2_1_0_5 + , CAL_1_0_Combined_Work_Exception + , CAL_1_0 + , CC_PDDC + , CERN_OHL_1_1 + , CERN_OHL_1_2 + , CERN_OHL_P_2_0 + , CERN_OHL_S_2_0 + , CERN_OHL_W_2_0 + , Copyleft_next_0_3_0 + , Copyleft_next_0_3_1 + , Etalab_2_0 + , Hippocratic_2_1 + , HPND_sell_variant + , JPNIC + , Libpng_2_0 + , Libselinux_1_0 + , Linux_OpenIB + , MIT_0 + , MulanPSL_1_0 + , MulanPSL_2_0 + , NCGL_UK_2_0 + , NTP_0 + , O_UDA_1_0 + , ODC_By_1_0 + , OFL_1_0_no_RFN + , OFL_1_0_RFN + , OFL_1_1_no_RFN + , OFL_1_1_RFN + , OGC_1_0 + , OGL_Canada_2_0 + , OGL_UK_1_0 + , OGL_UK_2_0 + , OGL_UK_3_0 + , Parity_6_0_0 + , Parity_7_0_0 + , PolyForm_Noncommercial_1_0_0 + , PolyForm_Small_Business_1_0_0 + , PSF_2_0 + , Sendmail_8_23 + , SHL_0_51 + , SHL_0_5 + , SSH_OpenSSH + , SSH_short + , SSPL_1_0 + , TAPR_OHL_1_0 + , TU_Berlin_1_0 + , TU_Berlin_2_0 + , UCL_1_0 + ] + ++ bulkOfLicenses +licenseIdList LicenseListVersion_3_10 = + [ AGPL_1_0_only + , AGPL_1_0_or_later + , Blessing + , BlueOak_1_0_0 + , BSD_2_Clause_Views + , BSD_3_Clause_Open_MPI + , Bzip2_1_0_5 + , CAL_1_0_Combined_Work_Exception + , CAL_1_0 + , CC_BY_3_0_AT + , CC_BY_NC_ND_3_0_IGO + , CC_BY_SA_3_0_AT + , CC_PDDC + , CERN_OHL_1_1 + , CERN_OHL_1_2 + , CERN_OHL_P_2_0 + , CERN_OHL_S_2_0 + , CERN_OHL_W_2_0 + , Copyleft_next_0_3_0 + , Copyleft_next_0_3_1 + , EPICS + , Etalab_2_0 + , GFDL_1_1_invariants_only + , GFDL_1_1_invariants_or_later + , GFDL_1_1_no_invariants_only + , GFDL_1_1_no_invariants_or_later + , GFDL_1_2_invariants_only + , GFDL_1_2_invariants_or_later + , GFDL_1_2_no_invariants_only + , GFDL_1_2_no_invariants_or_later + , GFDL_1_3_invariants_only + , GFDL_1_3_invariants_or_later + , GFDL_1_3_no_invariants_only + , GFDL_1_3_no_invariants_or_later + , GLWTPL + , Hippocratic_2_1 + , HPND_sell_variant + , JPNIC + , Libpng_2_0 + , Libselinux_1_0 + , Linux_OpenIB + , MIT_0 + , MulanPSL_1_0 + , MulanPSL_2_0 + , NCGL_UK_2_0 + , NIST_PD_fallback + , NIST_PD + , NTP_0 + , O_UDA_1_0 + , ODC_By_1_0 + , OFL_1_0_no_RFN + , OFL_1_0_RFN + , OFL_1_1_no_RFN + , OFL_1_1_RFN + , OGC_1_0 + , OGL_Canada_2_0 + , OGL_UK_1_0 + , OGL_UK_2_0 + , OGL_UK_3_0 + , Parity_6_0_0 + , Parity_7_0_0 + , PolyForm_Noncommercial_1_0_0 + , PolyForm_Small_Business_1_0_0 + , PSF_2_0 + , Sendmail_8_23 + , SHL_0_51 + , SHL_0_5 + , SSH_OpenSSH + , SSH_short + , SSPL_1_0 + , TAPR_OHL_1_0 + , TU_Berlin_1_0 + , TU_Berlin_2_0 + , UCL_1_0 + ] + ++ bulkOfLicenses +licenseIdList LicenseListVersion_3_16 = + [ AGPL_1_0_only + , AGPL_1_0_or_later + , ANTLR_PD_fallback + , App_s2p + , Blessing + , BlueOak_1_0_0 + , BSD_2_Clause_Views + , BSD_3_Clause_Modification + , BSD_3_Clause_No_Military_License + , BSD_3_Clause_Open_MPI + , BSD_4_Clause_Shortened + , BUSL_1_1 + , C_UDA_1_0 + , CAL_1_0_Combined_Work_Exception + , CAL_1_0 + , CC_BY_2_5_AU + , CC_BY_3_0_AT + , CC_BY_3_0_DE + , CC_BY_3_0_NL + , CC_BY_3_0_US + , CC_BY_NC_3_0_DE + , CC_BY_NC_ND_3_0_DE + , CC_BY_NC_ND_3_0_IGO + , CC_BY_NC_SA_2_0_FR + , CC_BY_NC_SA_2_0_UK + , CC_BY_NC_SA_3_0_DE + , CC_BY_NC_SA_3_0_IGO + , CC_BY_ND_3_0_DE + , CC_BY_SA_2_0_UK + , CC_BY_SA_2_1_JP + , CC_BY_SA_3_0_AT + , CC_BY_SA_3_0_DE + , CC_PDDC + , CDL_1_0 + , CDLA_Permissive_2_0 + , CERN_OHL_1_1 + , CERN_OHL_1_2 + , CERN_OHL_P_2_0 + , CERN_OHL_S_2_0 + , CERN_OHL_W_2_0 + , COIL_1_0 + , Community_Spec_1_0 + , Copyleft_next_0_3_0 + , Copyleft_next_0_3_1 + , DL_DE_BY_2_0 + , DRL_1_0 + , Elastic_2_0 + , EPICS + , Etalab_2_0 + , FDK_AAC + , FreeBSD_DOC + , GD + , GFDL_1_1_invariants_only + , GFDL_1_1_invariants_or_later + , GFDL_1_1_no_invariants_only + , GFDL_1_1_no_invariants_or_later + , GFDL_1_2_invariants_only + , GFDL_1_2_invariants_or_later + , GFDL_1_2_no_invariants_only + , GFDL_1_2_no_invariants_or_later + , GFDL_1_3_invariants_only + , GFDL_1_3_invariants_or_later + , GFDL_1_3_no_invariants_only + , GFDL_1_3_no_invariants_or_later + , GLWTPL + , Hippocratic_2_1 + , HPND_sell_variant + , HTMLTIDY + , Jam + , JPNIC + , Libpng_2_0 + , Libselinux_1_0 + , Linux_man_pages_copyleft + , Linux_OpenIB + , MIT_0 + , MIT_Modern_Variant + , MIT_open_group + , MulanPSL_1_0 + , MulanPSL_2_0 + , NAIST_2003 + , NCGL_UK_2_0 + , NIST_PD_fallback + , NIST_PD + , NLOD_2_0 + , NTP_0 + , O_UDA_1_0 + , ODC_By_1_0 + , OFL_1_0_no_RFN + , OFL_1_0_RFN + , OFL_1_1_no_RFN + , OFL_1_1_RFN + , OGC_1_0 + , OGDL_Taiwan_1_0 + , OGL_Canada_2_0 + , OGL_UK_1_0 + , OGL_UK_2_0 + , OGL_UK_3_0 + , OPUBL_1_0 + , Parity_6_0_0 + , Parity_7_0_0 + , PolyForm_Noncommercial_1_0_0 + , PolyForm_Small_Business_1_0_0 + , PSF_2_0 + , SchemeReport + , Sendmail_8_23 + , SHL_0_51 + , SHL_0_5 + , SSH_OpenSSH + , SSH_short + , SSPL_1_0 + , TAPR_OHL_1_0 + , TU_Berlin_1_0 + , TU_Berlin_2_0 + , UCL_1_0 + , X11_distribute_modifications_variant + ] + ++ bulkOfLicenses + +-- | Create a 'LicenseId' from a 'String'. +mkLicenseId :: LicenseListVersion -> String -> Maybe LicenseId +mkLicenseId LicenseListVersion_3_0 s = Map.lookup s stringLookup_3_0 +mkLicenseId LicenseListVersion_3_2 s = Map.lookup s stringLookup_3_2 +mkLicenseId LicenseListVersion_3_6 s = Map.lookup s stringLookup_3_6 +mkLicenseId LicenseListVersion_3_9 s = Map.lookup s stringLookup_3_9 +mkLicenseId LicenseListVersion_3_10 s = Map.lookup s stringLookup_3_10 +mkLicenseId LicenseListVersion_3_16 s = Map.lookup s stringLookup_3_16 + +stringLookup_3_0 :: Map String LicenseId +stringLookup_3_0 = Map.fromList $ map (\i -> (licenseId i, i)) $ + licenseIdList LicenseListVersion_3_0 + +stringLookup_3_2 :: Map String LicenseId +stringLookup_3_2 = Map.fromList $ map (\i -> (licenseId i, i)) $ + licenseIdList LicenseListVersion_3_2 + +stringLookup_3_6 :: Map String LicenseId +stringLookup_3_6 = Map.fromList $ map (\i -> (licenseId i, i)) $ + licenseIdList LicenseListVersion_3_6 + +stringLookup_3_9 :: Map String LicenseId +stringLookup_3_9 = Map.fromList $ map (\i -> (licenseId i, i)) $ + licenseIdList LicenseListVersion_3_9 + +stringLookup_3_10 :: Map String LicenseId +stringLookup_3_10 = Map.fromList $ map (\i -> (licenseId i, i)) $ + licenseIdList LicenseListVersion_3_10 + +stringLookup_3_16 :: Map String LicenseId +stringLookup_3_16 = Map.fromList $ map (\i -> (licenseId i, i)) $ + licenseIdList LicenseListVersion_3_16 + +-- | Licenses in all SPDX License lists +bulkOfLicenses :: [LicenseId] +bulkOfLicenses = + [ NullBSD + , AAL + , Abstyles + , Adobe_2006 + , Adobe_Glyph + , ADSL + , AFL_1_1 + , AFL_1_2 + , AFL_2_0 + , AFL_2_1 + , AFL_3_0 + , Afmparse + , AGPL_3_0_only + , AGPL_3_0_or_later + , Aladdin + , AMDPLPA + , AML + , AMPAS + , ANTLR_PD + , Apache_1_0 + , Apache_1_1 + , Apache_2_0 + , APAFML + , APL_1_0 + , APSL_1_0 + , APSL_1_1 + , APSL_1_2 + , APSL_2_0 + , Artistic_1_0_cl8 + , Artistic_1_0_Perl + , Artistic_1_0 + , Artistic_2_0 + , Bahyph + , Barr + , Beerware + , BitTorrent_1_0 + , BitTorrent_1_1 + , Borceux + , BSD_1_Clause + , BSD_2_Clause_Patent + , BSD_2_Clause + , BSD_3_Clause_Attribution + , BSD_3_Clause_Clear + , BSD_3_Clause_LBNL + , BSD_3_Clause_No_Nuclear_License_2014 + , BSD_3_Clause_No_Nuclear_License + , BSD_3_Clause_No_Nuclear_Warranty + , BSD_3_Clause + , BSD_4_Clause_UC + , BSD_4_Clause + , BSD_Protection + , BSD_Source_Code + , BSL_1_0 + , Bzip2_1_0_6 + , Caldera + , CATOSL_1_1 + , CC_BY_1_0 + , CC_BY_2_0 + , CC_BY_2_5 + , CC_BY_3_0 + , CC_BY_4_0 + , CC_BY_NC_1_0 + , CC_BY_NC_2_0 + , CC_BY_NC_2_5 + , CC_BY_NC_3_0 + , CC_BY_NC_4_0 + , CC_BY_NC_ND_1_0 + , CC_BY_NC_ND_2_0 + , CC_BY_NC_ND_2_5 + , CC_BY_NC_ND_3_0 + , CC_BY_NC_ND_4_0 + , CC_BY_NC_SA_1_0 + , CC_BY_NC_SA_2_0 + , CC_BY_NC_SA_2_5 + , CC_BY_NC_SA_3_0 + , CC_BY_NC_SA_4_0 + , CC_BY_ND_1_0 + , CC_BY_ND_2_0 + , CC_BY_ND_2_5 + , CC_BY_ND_3_0 + , CC_BY_ND_4_0 + , CC_BY_SA_1_0 + , CC_BY_SA_2_0 + , CC_BY_SA_2_5 + , CC_BY_SA_3_0 + , CC_BY_SA_4_0 + , CC0_1_0 + , CDDL_1_0 + , CDDL_1_1 + , CDLA_Permissive_1_0 + , CDLA_Sharing_1_0 + , CECILL_1_0 + , CECILL_1_1 + , CECILL_2_0 + , CECILL_2_1 + , CECILL_B + , CECILL_C + , ClArtistic + , CNRI_Jython + , CNRI_Python_GPL_Compatible + , CNRI_Python + , Condor_1_1 + , CPAL_1_0 + , CPL_1_0 + , CPOL_1_02 + , Crossword + , CrystalStacker + , CUA_OPL_1_0 + , Cube + , Curl + , D_FSL_1_0 + , Diffmark + , DOC + , Dotseqn + , DSDP + , Dvipdfm + , ECL_1_0 + , ECL_2_0 + , EFL_1_0 + , EFL_2_0 + , EGenix + , Entessa + , EPL_1_0 + , EPL_2_0 + , ErlPL_1_1 + , EUDatagrid + , EUPL_1_0 + , EUPL_1_1 + , EUPL_1_2 + , Eurosym + , Fair + , Frameworx_1_0 + , FreeImage + , FSFAP + , FSFULLR + , FSFUL + , FTL + , GFDL_1_1_only + , GFDL_1_1_or_later + , GFDL_1_2_only + , GFDL_1_2_or_later + , GFDL_1_3_only + , GFDL_1_3_or_later + , Giftware + , GL2PS + , Glide + , Glulxe + , Gnuplot + , GPL_1_0_only + , GPL_1_0_or_later + , GPL_2_0_only + , GPL_2_0_or_later + , GPL_3_0_only + , GPL_3_0_or_later + , GSOAP_1_3b + , HaskellReport + , HPND + , IBM_pibs + , ICU + , IJG + , ImageMagick + , IMatix + , Imlib2 + , Info_ZIP + , Intel_ACPI + , Intel + , Interbase_1_0 + , IPA + , IPL_1_0 + , ISC + , JasPer_2_0 + , JSON + , LAL_1_2 + , LAL_1_3 + , Latex2e + , Leptonica + , LGPL_2_0_only + , LGPL_2_0_or_later + , LGPL_2_1_only + , LGPL_2_1_or_later + , LGPL_3_0_only + , LGPL_3_0_or_later + , LGPLLR + , Libpng + , Libtiff + , LiLiQ_P_1_1 + , LiLiQ_R_1_1 + , LiLiQ_Rplus_1_1 + , LPL_1_02 + , LPL_1_0 + , LPPL_1_0 + , LPPL_1_1 + , LPPL_1_2 + , LPPL_1_3a + , LPPL_1_3c + , MakeIndex + , MirOS + , MIT_advertising + , MIT_CMU + , MIT_enna + , MIT_feh + , MITNFA + , MIT + , Motosoto + , Mpich2 + , MPL_1_0 + , MPL_1_1 + , MPL_2_0_no_copyleft_exception + , MPL_2_0 + , MS_PL + , MS_RL + , MTLL + , Multics + , Mup + , NASA_1_3 + , Naumen + , NBPL_1_0 + , NCSA + , Net_SNMP + , NetCDF + , Newsletr + , NGPL + , NLOD_1_0 + , NLPL + , Nokia + , NOSL + , Noweb + , NPL_1_0 + , NPL_1_1 + , NPOSL_3_0 + , NRL + , NTP + , OCCT_PL + , OCLC_2_0 + , ODbL_1_0 + , OFL_1_0 + , OFL_1_1 + , OGTSL + , OLDAP_1_1 + , OLDAP_1_2 + , OLDAP_1_3 + , OLDAP_1_4 + , OLDAP_2_0_1 + , OLDAP_2_0 + , OLDAP_2_1 + , OLDAP_2_2_1 + , OLDAP_2_2_2 + , OLDAP_2_2 + , OLDAP_2_3 + , OLDAP_2_4 + , OLDAP_2_5 + , OLDAP_2_6 + , OLDAP_2_7 + , OLDAP_2_8 + , OML + , OpenSSL + , OPL_1_0 + , OSET_PL_2_1 + , OSL_1_0 + , OSL_1_1 + , OSL_2_0 + , OSL_2_1 + , OSL_3_0 + , PDDL_1_0 + , PHP_3_01 + , PHP_3_0 + , Plexus + , PostgreSQL + , Psfrag + , Psutils + , Python_2_0 + , Qhull + , QPL_1_0 + , Rdisc + , RHeCos_1_1 + , RPL_1_1 + , RPL_1_5 + , RPSL_1_0 + , RSA_MD + , RSCPL + , Ruby + , SAX_PD + , Saxpath + , SCEA + , Sendmail + , SGI_B_1_0 + , SGI_B_1_1 + , SGI_B_2_0 + , SimPL_2_0 + , SISSL_1_2 + , SISSL + , Sleepycat + , SMLNJ + , SMPPL + , SNIA + , Spencer_86 + , Spencer_94 + , Spencer_99 + , SPL_1_0 + , SugarCRM_1_1_3 + , SWL + , TCL + , TCP_wrappers + , TMate + , TORQUE_1_1 + , TOSL + , Unicode_DFS_2015 + , Unicode_DFS_2016 + , Unicode_TOU + , Unlicense + , UPL_1_0 + , Vim + , VOSTROM + , VSL_1_0 + , W3C_19980720 + , W3C_20150513 + , W3C + , Watcom_1_0 + , Wsuipa + , WTFPL + , X11 + , Xerox + , XFree86_1_1 + , Xinetd + , Xnet + , Xpp + , XSkat + , YPL_1_0 + , YPL_1_1 + , Zed + , Zend_2_0 + , Zimbra_1_3 + , Zimbra_1_4 + , Zlib_acknowledgement + , Zlib + , ZPL_1_1 + , ZPL_2_0 + , ZPL_2_1 + ] diff --git a/cabal/Cabal-syntax/src/Distribution/SPDX/LicenseListVersion.hs b/cabal/Cabal-syntax/src/Distribution/SPDX/LicenseListVersion.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/SPDX/LicenseListVersion.hs @@ -0,0 +1,24 @@ +module Distribution.SPDX.LicenseListVersion ( + LicenseListVersion (..), + cabalSpecVersionToSPDXListVersion, + ) where + +import Distribution.CabalSpecVersion + +-- | SPDX License List version @Cabal@ is aware of. +data LicenseListVersion + = LicenseListVersion_3_0 + | LicenseListVersion_3_2 + | LicenseListVersion_3_6 + | LicenseListVersion_3_9 + | LicenseListVersion_3_10 + | LicenseListVersion_3_16 + deriving (Eq, Ord, Show, Enum, Bounded) + +cabalSpecVersionToSPDXListVersion :: CabalSpecVersion -> LicenseListVersion +cabalSpecVersionToSPDXListVersion CabalSpecV3_8 = LicenseListVersion_3_16 +cabalSpecVersionToSPDXListVersion CabalSpecV3_6 = LicenseListVersion_3_10 +cabalSpecVersionToSPDXListVersion CabalSpecV3_4 = LicenseListVersion_3_9 +cabalSpecVersionToSPDXListVersion CabalSpecV3_0 = LicenseListVersion_3_6 +cabalSpecVersionToSPDXListVersion CabalSpecV2_4 = LicenseListVersion_3_2 +cabalSpecVersionToSPDXListVersion _ = LicenseListVersion_3_0 diff --git a/cabal/Cabal-syntax/src/Distribution/SPDX/LicenseReference.hs b/cabal/Cabal-syntax/src/Distribution/SPDX/LicenseReference.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/SPDX/LicenseReference.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +module Distribution.SPDX.LicenseReference ( + LicenseRef, + licenseRef, + licenseDocumentRef, + mkLicenseRef, + mkLicenseRef', + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Utils.Generic (isAsciiAlphaNum) +import Distribution.Pretty +import Distribution.Parsec + +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as Disp + +-- | A user defined license reference denoted by @LicenseRef-[idstring]@ (for a license not on the SPDX License List); +data LicenseRef = LicenseRef + { _lrDocument :: !(Maybe String) + , _lrLicense :: !String + } + deriving (Show, Read, Eq, Ord, Typeable, Data, Generic) + +-- | License reference. +licenseRef :: LicenseRef -> String +licenseRef = _lrLicense + +-- | Document reference. +licenseDocumentRef :: LicenseRef -> Maybe String +licenseDocumentRef = _lrDocument + +instance Binary LicenseRef +instance Structured LicenseRef + +instance NFData LicenseRef where + rnf (LicenseRef d l) = rnf d `seq` rnf l + +instance Pretty LicenseRef where + pretty (LicenseRef Nothing l) = Disp.text "LicenseRef-" <<>> Disp.text l + pretty (LicenseRef (Just d) l) = + Disp.text "DocumentRef-" <<>> Disp.text d <<>> Disp.char ':' <<>> Disp.text "LicenseRef-" <<>> Disp.text l + +instance Parsec LicenseRef where + parsec = name <|> doc + where + name = do + _ <- P.string "LicenseRef-" + n <- some $ P.satisfy $ \c -> isAsciiAlphaNum c || c == '-' || c == '.' + pure (LicenseRef Nothing n) + + doc = do + _ <- P.string "DocumentRef-" + d <- some $ P.satisfy $ \c -> isAsciiAlphaNum c || c == '-' || c == '.' + _ <- P.char ':' + _ <- P.string "LicenseRef-" + n <- some $ P.satisfy $ \c -> isAsciiAlphaNum c || c == '-' || c == '.' + pure (LicenseRef (Just d) n) + +-- | Create 'LicenseRef' from optional document ref and name. +mkLicenseRef :: Maybe String -> String -> Maybe LicenseRef +mkLicenseRef d l = do + d' <- traverse checkIdString d + l' <- checkIdString l + pure (LicenseRef d' l') + where + checkIdString s + | all (\c -> isAsciiAlphaNum c || c == '-' || c == '.') s = Just s + | otherwise = Nothing + +-- | Like 'mkLicenseRef' but convert invalid characters into @-@. +mkLicenseRef' :: Maybe String -> String -> LicenseRef +mkLicenseRef' d l = LicenseRef (fmap f d) (f l) + where + f = map g + g c | isAsciiAlphaNum c || c == '-' || c == '.' = c + | otherwise = '-' diff --git a/cabal/Cabal-syntax/src/Distribution/System.hs b/cabal/Cabal-syntax/src/Distribution/System.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/System.hs @@ -0,0 +1,284 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.System +-- Copyright : Duncan Coutts 2007-2008 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Cabal often needs to do slightly different things on specific platforms. You +-- probably know about the 'System.Info.os' however using that is very +-- inconvenient because it is a string and different Haskell implementations +-- do not agree on using the same strings for the same platforms! (In +-- particular see the controversy over \"windows\" vs \"mingw32\"). So to make it +-- more consistent and easy to use we have an 'OS' enumeration. +-- +module Distribution.System ( + -- * Operating System + OS(..), + buildOS, + + -- * Machine Architecture + Arch(..), + buildArch, + + -- * Platform is a pair of arch and OS + Platform(..), + buildPlatform, + platformFromTriple, + + -- * Internal + knownOSs, + knownArches, + + -- * Classification + ClassificationStrictness (..), + classifyOS, + classifyArch, + ) where + +import Prelude () +import Distribution.Compat.Prelude hiding (Applicative(..)) +import Control.Applicative (Applicative(..)) + +#if !MIN_VERSION_base(4,10,0) +import Control.Applicative (liftA2) +#endif + +import qualified System.Info (os, arch) +import Distribution.Utils.Generic (lowercase) + +import Distribution.Parsec +import Distribution.Pretty + +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as Disp + +-- | How strict to be when classifying strings into the 'OS' and 'Arch' enums. +-- +-- The reason we have multiple ways to do the classification is because there +-- are two situations where we need to do it. +-- +-- For parsing OS and arch names in .cabal files we really want everyone to be +-- referring to the same or arch by the same name. Variety is not a virtue +-- in this case. We don't mind about case though. +-- +-- For the System.Info.os\/arch different Haskell implementations use different +-- names for the same or\/arch. Also they tend to distinguish versions of an +-- OS\/arch which we just don't care about. +-- +-- The 'Compat' classification allows us to recognise aliases that are already +-- in common use but it allows us to distinguish them from the canonical name +-- which enables us to warn about such deprecated aliases. +-- +data ClassificationStrictness = Permissive | Compat | Strict + +-- ------------------------------------------------------------ +-- * Operating System +-- ------------------------------------------------------------ + +-- | These are the known OS names: Linux, Windows, OSX +-- ,FreeBSD, OpenBSD, NetBSD, DragonFly +-- ,Solaris, AIX, HPUX, IRIX +-- ,HaLVM ,Hurd ,IOS, Android, Ghcjs, Wasi +-- +-- The following aliases can also be used:, +-- * Windows aliases: mingw32, win32, cygwin32 +-- * OSX alias: darwin +-- * Hurd alias: gnu +-- * FreeBSD alias: kfreebsdgnu +-- * Solaris alias: solaris2 +-- +data OS = Linux | Windows | OSX -- tier 1 desktop OSs + | FreeBSD | OpenBSD | NetBSD -- other free Unix OSs + | DragonFly + | Solaris | AIX | HPUX | IRIX -- ageing Unix OSs + | HaLVM -- bare metal / VMs / hypervisors + | Hurd -- GNU's microkernel + | IOS | Android -- mobile OSs + | Ghcjs + | Wasi + | OtherOS String + deriving (Eq, Generic, Ord, Show, Read, Typeable, Data) + +instance Binary OS +instance Structured OS +instance NFData OS where rnf = genericRnf + +knownOSs :: [OS] +knownOSs = [Linux, Windows, OSX + ,FreeBSD, OpenBSD, NetBSD, DragonFly + ,Solaris, AIX, HPUX, IRIX + ,HaLVM + ,Hurd + ,IOS, Android + ,Ghcjs + ,Wasi] + +osAliases :: ClassificationStrictness -> OS -> [String] +osAliases Permissive Windows = ["mingw32", "win32", "cygwin32"] +osAliases Compat Windows = ["mingw32", "win32"] +osAliases _ OSX = ["darwin"] +osAliases _ Hurd = ["gnu"] +osAliases Permissive FreeBSD = ["kfreebsdgnu"] +osAliases Compat FreeBSD = ["kfreebsdgnu"] +osAliases Permissive Solaris = ["solaris2"] +osAliases Compat Solaris = ["solaris2"] +osAliases Permissive Android = ["linux-android", "linux-androideabi", "linux-androideabihf"] +osAliases Compat Android = ["linux-android"] +osAliases _ _ = [] + +instance Pretty OS where + pretty (OtherOS name) = Disp.text name + pretty other = Disp.text (lowercase (show other)) + +instance Parsec OS where + parsec = classifyOS Compat <$> parsecIdent + + + +classifyOS :: ClassificationStrictness -> String -> OS +classifyOS strictness s = + fromMaybe (OtherOS s) $ lookup (lowercase s) osMap + where + osMap = [ (name, os) + | os <- knownOSs + , name <- prettyShow os : osAliases strictness os ] + +buildOS :: OS +buildOS = classifyOS Permissive System.Info.os + +-- ------------------------------------------------------------ +-- * Machine Architecture +-- ------------------------------------------------------------ + +-- | These are the known Arches: I386, X86_64, PPC, PPC64, Sparc, +-- Arm, AArch64, Mips, SH, IA64, S390, S390X, Alpha, Hppa, Rs6000, +-- M68k, Vax, JavaScript and Wasm32. +-- +-- The following aliases can also be used: +-- * PPC alias: powerpc +-- * PPC64 alias : powerpc64, powerpc64le +-- * Sparc aliases: sparc64, sun4 +-- * Mips aliases: mipsel, mipseb +-- * Arm aliases: armeb, armel +-- * AArch64 aliases: arm64 +-- +data Arch = I386 | X86_64 | PPC | PPC64 | Sparc + | Arm | AArch64 | Mips | SH + | IA64 | S390 | S390X + | Alpha | Hppa | Rs6000 + | M68k | Vax + | JavaScript + | Wasm32 + | OtherArch String + deriving (Eq, Generic, Ord, Show, Read, Typeable, Data) + +instance Binary Arch +instance Structured Arch +instance NFData Arch where rnf = genericRnf + +knownArches :: [Arch] +knownArches = [I386, X86_64, PPC, PPC64, Sparc + ,Arm, AArch64, Mips, SH + ,IA64, S390, S390X + ,Alpha, Hppa, Rs6000 + ,M68k, Vax + ,JavaScript + ,Wasm32] + +archAliases :: ClassificationStrictness -> Arch -> [String] +archAliases Strict _ = [] +archAliases Compat _ = [] +archAliases _ PPC = ["powerpc"] +archAliases _ PPC64 = ["powerpc64", "powerpc64le"] +archAliases _ Sparc = ["sparc64", "sun4"] +archAliases _ Mips = ["mipsel", "mipseb"] +archAliases _ Arm = ["armeb", "armel"] +archAliases _ AArch64 = ["arm64"] +archAliases _ _ = [] + +instance Pretty Arch where + pretty (OtherArch name) = Disp.text name + pretty other = Disp.text (lowercase (show other)) + +instance Parsec Arch where + parsec = classifyArch Strict <$> parsecIdent + +classifyArch :: ClassificationStrictness -> String -> Arch +classifyArch strictness s = + fromMaybe (OtherArch s) $ lookup (lowercase s) archMap + where + archMap = [ (name, arch) + | arch <- knownArches + , name <- prettyShow arch : archAliases strictness arch ] + +buildArch :: Arch +buildArch = classifyArch Permissive System.Info.arch + +-- ------------------------------------------------------------ +-- * Platform +-- ------------------------------------------------------------ + +data Platform = Platform Arch OS + deriving (Eq, Generic, Ord, Show, Read, Typeable, Data) + +instance Binary Platform +instance Structured Platform +instance NFData Platform where rnf = genericRnf + +instance Pretty Platform where + pretty (Platform arch os) = pretty arch <<>> Disp.char '-' <<>> pretty os + +instance Parsec Platform where + -- TODO: there are ambiguous platforms like: `arch-word-os` + -- which could be parsed as + -- * Platform "arch-word" "os" + -- * Platform "arch" "word-os" + -- We could support that preferring variants 'OtherOS' or 'OtherArch' + -- + -- For now we split into arch and os parts on the first dash. + parsec = do + arch <- parsecDashlessArch + _ <- P.char '-' + os <- parsec + return (Platform arch os) + where + parsecDashlessArch = classifyArch Strict <$> dashlessIdent + + dashlessIdent = liftA2 (:) firstChar rest + where + firstChar = P.satisfy isAlpha + rest = P.munch (\c -> isAlphaNum c || c == '_') + +-- | The platform Cabal was compiled on. In most cases, +-- @LocalBuildInfo.hostPlatform@ should be used instead (the platform we're +-- targeting). +buildPlatform :: Platform +buildPlatform = Platform buildArch buildOS + +-- Utils: + +parsecIdent :: CabalParsing m => m String +parsecIdent = (:) <$> firstChar <*> rest + where + firstChar = P.satisfy isAlpha + rest = P.munch (\c -> isAlphaNum c || c == '_' || c == '-') + +platformFromTriple :: String -> Maybe Platform +platformFromTriple triple = + either (const Nothing) Just $ explicitEitherParsec parseTriple triple + where parseWord = P.munch1 (\c -> isAlphaNum c || c == '_') + parseTriple = do + arch <- fmap (classifyArch Permissive) parseWord + _ <- P.char '-' + _ <- parseWord -- Skip vendor + _ <- P.char '-' + os <- fmap (classifyOS Permissive) parsecIdent -- OS may have hyphens, like + -- 'nto-qnx' + return $ Platform arch os diff --git a/cabal/Cabal-syntax/src/Distribution/Text.hs b/cabal/Cabal-syntax/src/Distribution/Text.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Text.hs @@ -0,0 +1,12 @@ +-- Since @3.0@ this is a compat module. +module Distribution.Text (display, simpleParse) where +{- {-# DEPRECATED "Use Distribution.Parsec or Distribution.Pretty" #-} -} + +import Distribution.Pretty +import Distribution.Parsec + +display :: Pretty a => a -> String +display = prettyShow + +simpleParse :: Parsec a => String -> Maybe a +simpleParse = simpleParsec diff --git a/cabal/Cabal-syntax/src/Distribution/Types/AbiDependency.hs b/cabal/Cabal-syntax/src/Distribution/Types/AbiDependency.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/AbiDependency.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Types.AbiDependency where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Parsec +import Distribution.Pretty + +import qualified Distribution.Compat.CharParsing as P +import qualified Distribution.Package as Package +import qualified Text.PrettyPrint as Disp + +-- | An ABI dependency is a dependency on a library which also +-- records the ABI hash ('abiHash') of the library it depends +-- on. +-- +-- The primary utility of this is to enable an extra sanity when +-- GHC loads libraries: it can check if the dependency has a matching +-- ABI and if not, refuse to load this library. This information +-- is critical if we are shadowing libraries; differences in the +-- ABI hash let us know what packages get shadowed by the new version +-- of a package. +data AbiDependency = AbiDependency { + depUnitId :: Package.UnitId, + depAbiHash :: Package.AbiHash + } + deriving (Eq, Generic, Read, Show, Typeable) + +instance Pretty AbiDependency where + pretty (AbiDependency uid abi) = + pretty uid <<>> Disp.char '=' <<>> pretty abi + +instance Parsec AbiDependency where + parsec = do + uid <- parsec + _ <- P.char '=' + abi <- parsec + return (AbiDependency uid abi) + +instance Binary AbiDependency +instance Structured AbiDependency +instance NFData AbiDependency where rnf = genericRnf diff --git a/cabal/Cabal-syntax/src/Distribution/Types/AbiHash.hs b/cabal/Cabal-syntax/src/Distribution/Types/AbiHash.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/AbiHash.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Distribution.Types.AbiHash + ( AbiHash, unAbiHash, mkAbiHash + ) where + +import Prelude () +import Distribution.Compat.Prelude +import Distribution.Utils.ShortText + +import qualified Distribution.Compat.CharParsing as P +import Distribution.Pretty +import Distribution.Parsec + +import Text.PrettyPrint (text) + +-- | ABI Hashes +-- +-- Use 'mkAbiHash' and 'unAbiHash' to convert from/to a +-- 'String'. +-- +-- This type is opaque since @Cabal-2.0@ +-- +-- @since 2.0.0.2 +newtype AbiHash = AbiHash ShortText + deriving (Eq, Show, Read, Generic, Typeable) + +-- | Construct a 'AbiHash' from a 'String' +-- +-- 'mkAbiHash' is the inverse to 'unAbiHash' +-- +-- Note: No validations are performed to ensure that the resulting +-- 'AbiHash' is valid +-- +-- @since 2.0.0.2 +unAbiHash :: AbiHash -> String +unAbiHash (AbiHash h) = fromShortText h + +-- | Convert 'AbiHash' to 'String' +-- +-- @since 2.0.0.2 +mkAbiHash :: String -> AbiHash +mkAbiHash = AbiHash . toShortText + +-- | 'mkAbiHash' +-- +-- @since 2.0.0.2 +instance IsString AbiHash where + fromString = mkAbiHash + +instance Binary AbiHash +instance Structured AbiHash +instance NFData AbiHash where rnf = genericRnf + +instance Pretty AbiHash where + pretty = text . unAbiHash + +instance Parsec AbiHash where + parsec = fmap mkAbiHash (P.munch isAlphaNum) diff --git a/cabal/Cabal-syntax/src/Distribution/Types/Benchmark.hs b/cabal/Cabal-syntax/src/Distribution/Types/Benchmark.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/Benchmark.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NoMonoLocalBinds #-} + +module Distribution.Types.Benchmark ( + Benchmark(..), + emptyBenchmark, + benchmarkType, + benchmarkModules, + benchmarkModulesAutogen +) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Types.BuildInfo +import Distribution.Types.BenchmarkType +import Distribution.Types.BenchmarkInterface +import Distribution.Types.UnqualComponentName + +import Distribution.ModuleName + +import qualified Distribution.Types.BuildInfo.Lens as L + +-- | A \"benchmark\" stanza in a cabal file. +-- +data Benchmark = Benchmark { + benchmarkName :: UnqualComponentName, + benchmarkInterface :: BenchmarkInterface, + benchmarkBuildInfo :: BuildInfo + } + deriving (Generic, Show, Read, Eq, Typeable, Data) + +instance Binary Benchmark +instance Structured Benchmark +instance NFData Benchmark where rnf = genericRnf + +instance L.HasBuildInfo Benchmark where + buildInfo f (Benchmark x1 x2 x3) = fmap (\y1 -> Benchmark x1 x2 y1) (f x3) + +instance Monoid Benchmark where + mempty = Benchmark { + benchmarkName = mempty, + benchmarkInterface = mempty, + benchmarkBuildInfo = mempty + } + mappend = (<>) + +instance Semigroup Benchmark where + a <> b = Benchmark { + benchmarkName = combine' benchmarkName, + benchmarkInterface = combine benchmarkInterface, + benchmarkBuildInfo = combine benchmarkBuildInfo + } + where combine field = field a `mappend` field b + combine' field = case ( unUnqualComponentName $ field a + , unUnqualComponentName $ field b) of + ("", _) -> field b + (_, "") -> field a + (x, y) -> error $ "Ambiguous values for test field: '" + ++ x ++ "' and '" ++ y ++ "'" + +emptyBenchmark :: Benchmark +emptyBenchmark = mempty + +benchmarkType :: Benchmark -> BenchmarkType +benchmarkType benchmark = case benchmarkInterface benchmark of + BenchmarkExeV10 ver _ -> BenchmarkTypeExe ver + BenchmarkUnsupported benchmarktype -> benchmarktype + +-- | Get all the module names from a benchmark. +benchmarkModules :: Benchmark -> [ModuleName] +benchmarkModules benchmark = otherModules (benchmarkBuildInfo benchmark) + +-- | Get all the auto generated module names from a benchmark. +-- This are a subset of 'benchmarkModules'. +benchmarkModulesAutogen :: Benchmark -> [ModuleName] +benchmarkModulesAutogen benchmark = autogenModules (benchmarkBuildInfo benchmark) diff --git a/cabal/Cabal-syntax/src/Distribution/Types/Benchmark/Lens.hs b/cabal/Cabal-syntax/src/Distribution/Types/Benchmark/Lens.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/Benchmark/Lens.hs @@ -0,0 +1,27 @@ +module Distribution.Types.Benchmark.Lens ( + Benchmark, + module Distribution.Types.Benchmark.Lens, + ) where + +import Distribution.Compat.Lens +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Types.Benchmark (Benchmark) +import Distribution.Types.BenchmarkInterface (BenchmarkInterface) +import Distribution.Types.BuildInfo (BuildInfo) +import Distribution.Types.UnqualComponentName (UnqualComponentName) + +import qualified Distribution.Types.Benchmark as T + +benchmarkName :: Lens' Benchmark UnqualComponentName +benchmarkName f s = fmap (\x -> s { T.benchmarkName = x }) (f (T.benchmarkName s)) +{-# INLINE benchmarkName #-} + +benchmarkInterface :: Lens' Benchmark BenchmarkInterface +benchmarkInterface f s = fmap (\x -> s { T.benchmarkInterface = x }) (f (T.benchmarkInterface s)) +{-# INLINE benchmarkInterface #-} + +benchmarkBuildInfo :: Lens' Benchmark BuildInfo +benchmarkBuildInfo f s = fmap (\x -> s { T.benchmarkBuildInfo = x }) (f (T.benchmarkBuildInfo s)) +{-# INLINE benchmarkBuildInfo #-} diff --git a/cabal/Cabal-syntax/src/Distribution/Types/BenchmarkInterface.hs b/cabal/Cabal-syntax/src/Distribution/Types/BenchmarkInterface.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/BenchmarkInterface.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +module Distribution.Types.BenchmarkInterface ( + BenchmarkInterface(..), +) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Types.BenchmarkType +import Distribution.Version + +-- | The benchmark interfaces that are currently defined. +-- +-- More interfaces may be defined in future, either new revisions or +-- totally new interfaces. +-- +data BenchmarkInterface = + + -- | Benchmark interface \"exitcode-stdio-1.0\". The benchmark + -- takes the form of an executable. It returns a zero exit code + -- for success, non-zero for failure. The stdout and stderr + -- channels may be logged. It takes no command line parameters + -- and nothing on stdin. + -- + BenchmarkExeV10 Version FilePath + + -- | A benchmark that does not conform to one of the above + -- interfaces for the given reason (e.g. unknown benchmark type). + -- + | BenchmarkUnsupported BenchmarkType + deriving (Eq, Generic, Read, Show, Typeable, Data) + +instance Binary BenchmarkInterface +instance Structured BenchmarkInterface +instance NFData BenchmarkInterface where rnf = genericRnf + +instance Monoid BenchmarkInterface where + mempty = BenchmarkUnsupported (BenchmarkTypeUnknown mempty nullVersion) + mappend = (<>) + +instance Semigroup BenchmarkInterface where + a <> (BenchmarkUnsupported _) = a + _ <> b = b diff --git a/cabal/Cabal-syntax/src/Distribution/Types/BenchmarkType.hs b/cabal/Cabal-syntax/src/Distribution/Types/BenchmarkType.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/BenchmarkType.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module Distribution.Types.BenchmarkType ( + BenchmarkType(..), + knownBenchmarkTypes, + benchmarkTypeExe, +) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Parsec +import Distribution.Pretty +import Distribution.Version +import Text.PrettyPrint (char, text) + +-- | The \"benchmark-type\" field in the benchmark stanza. +-- +data BenchmarkType = BenchmarkTypeExe Version + -- ^ \"type: exitcode-stdio-x.y\" + | BenchmarkTypeUnknown String Version + -- ^ Some unknown benchmark type e.g. \"type: foo\" + deriving (Generic, Show, Read, Eq, Typeable, Data) + +instance Binary BenchmarkType +instance Structured BenchmarkType +instance NFData BenchmarkType where rnf = genericRnf + +knownBenchmarkTypes :: [BenchmarkType] +knownBenchmarkTypes = [ benchmarkTypeExe ] + +benchmarkTypeExe :: BenchmarkType +benchmarkTypeExe = BenchmarkTypeExe (mkVersion [1,0]) + +instance Pretty BenchmarkType where + pretty (BenchmarkTypeExe ver) = text "exitcode-stdio-" <<>> pretty ver + pretty (BenchmarkTypeUnknown name ver) = text name <<>> char '-' <<>> pretty ver + +instance Parsec BenchmarkType where + parsec = parsecStandard $ \ver name -> case name of + "exitcode-stdio" -> BenchmarkTypeExe ver + _ -> BenchmarkTypeUnknown name ver diff --git a/cabal/Cabal-syntax/src/Distribution/Types/BuildInfo.hs b/cabal/Cabal-syntax/src/Distribution/Types/BuildInfo.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/BuildInfo.hs @@ -0,0 +1,273 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NoMonoLocalBinds #-} + +module Distribution.Types.BuildInfo ( + BuildInfo(..), + + emptyBuildInfo, + allLanguages, + allExtensions, + usedExtensions, + usesTemplateHaskellOrQQ, + + hcOptions, + hcProfOptions, + hcSharedOptions, + hcStaticOptions, +) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Types.Mixin +import Distribution.Types.Dependency +import Distribution.Types.ExeDependency +import Distribution.Types.LegacyExeDependency +import Distribution.Types.PkgconfigDependency +import Distribution.Utils.Path + +import Distribution.ModuleName +import Distribution.Compiler +import Language.Haskell.Extension + +-- Consider refactoring into executable and library versions. +data BuildInfo = BuildInfo { + -- | component is buildable here + buildable :: Bool, + -- | Tools needed to build this bit. + -- + -- This is a legacy field that 'buildToolDepends' largely supersedes. + -- + -- Unless use are very sure what you are doing, use the functions in + -- "Distribution.Simple.BuildToolDepends" rather than accessing this + -- field directly. + buildTools :: [LegacyExeDependency], + -- | Haskell tools needed to build this bit + -- + -- This field is better than 'buildTools' because it allows one to + -- precisely specify an executable in a package. + -- + -- Unless use are very sure what you are doing, use the functions in + -- "Distribution.Simple.BuildToolDepends" rather than accessing this + -- field directly. + buildToolDepends :: [ExeDependency], + cppOptions :: [String], -- ^ options for pre-processing Haskell code + asmOptions :: [String], -- ^ options for assembler + cmmOptions :: [String], -- ^ options for C-- compiler + ccOptions :: [String], -- ^ options for C compiler + cxxOptions :: [String], -- ^ options for C++ compiler + ldOptions :: [String], -- ^ options for linker + hsc2hsOptions :: [String], -- ^ options for hsc2hs + pkgconfigDepends :: [PkgconfigDependency], -- ^ pkg-config packages that are used + frameworks :: [String], -- ^support frameworks for Mac OS X + extraFrameworkDirs:: [String], -- ^ extra locations to find frameworks. + asmSources :: [FilePath], -- ^ Assembly files. + cmmSources :: [FilePath], -- ^ C-- files. + cSources :: [FilePath], + cxxSources :: [FilePath], + jsSources :: [FilePath], + hsSourceDirs :: [SymbolicPath PackageDir SourceDir], -- ^ where to look for the Haskell module hierarchy + otherModules :: [ModuleName], -- ^ non-exposed or non-main modules + virtualModules :: [ModuleName], -- ^ exposed modules that do not have a source file (e.g. @GHC.Prim@ from @ghc-prim@ package) + autogenModules :: [ModuleName], -- ^ not present on sdist, Paths_* or user-generated with a custom Setup.hs + + defaultLanguage :: Maybe Language,-- ^ language used when not explicitly specified + otherLanguages :: [Language], -- ^ other languages used within the package + defaultExtensions :: [Extension], -- ^ language extensions used by all modules + otherExtensions :: [Extension], -- ^ other language extensions used within the package + oldExtensions :: [Extension], -- ^ the old extensions field, treated same as 'defaultExtensions' + + extraLibs :: [String], -- ^ what libraries to link with when compiling a program that uses your package + extraLibsStatic :: [String], -- ^ what libraries to link with when compiling a program fully statically that uses your package + extraGHCiLibs :: [String], -- ^ if present, overrides extraLibs when package is loaded with GHCi. + extraBundledLibs :: [String], -- ^ if present, adds libs to hs-libraries, which become part of the package. + -- Example 1: the Cffi library shipping with the rts, alongside the HSrts-1.0.a,.o,... + -- Example 2: a library that is being built by a foreign tool (e.g. rust) + -- and copied and registered together with this library. The + -- logic on how this library is built will have to be encoded in a + -- custom Setup for now. Otherwise cabal would need to learn how to + -- call arbitrary library builders. + extraLibFlavours :: [String], -- ^ Hidden Flag. This set of strings, will be appended to all libraries when + -- copying. E.g. [libHS_ | flavour <- extraLibFlavours]. This + -- should only be needed in very specific cases, e.g. the `rts` package, where + -- there are multiple copies of slightly differently built libs. + extraDynLibFlavours :: [String], -- ^ Hidden Flag. This set of strings will be appended to all /dynamic/ + -- libraries when copying. This is particularly useful with the `rts` package, + -- where we want different dynamic flavours of the RTS library to be installed. + extraLibDirs :: [String], + extraLibDirsStatic :: [String], + includeDirs :: [FilePath], -- ^directories to find .h files + includes :: [FilePath], -- ^ The .h files to be found in includeDirs + autogenIncludes :: [FilePath], -- ^ The .h files to be generated (e.g. by @autoconf@) + installIncludes :: [FilePath], -- ^ .h files to install with the package + options :: PerCompilerFlavor [String], + profOptions :: PerCompilerFlavor [String], + sharedOptions :: PerCompilerFlavor [String], + staticOptions :: PerCompilerFlavor [String], + customFieldsBI :: [(String,String)], -- ^Custom fields starting + -- with x-, stored in a + -- simple assoc-list. + targetBuildDepends :: [Dependency], -- ^ Dependencies specific to a library or executable target + mixins :: [Mixin] + } + deriving (Generic, Show, Read, Eq, Typeable, Data) + +instance Binary BuildInfo +instance Structured BuildInfo +instance NFData BuildInfo where rnf = genericRnf + +instance Monoid BuildInfo where + mempty = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = mempty, + profOptions = mempty, + sharedOptions = mempty, + staticOptions = mempty, + customFieldsBI = [], + targetBuildDepends = [], + mixins = [] + } + mappend = (<>) + +instance Semigroup BuildInfo where + a <> b = BuildInfo { + buildable = buildable a && buildable b, + buildTools = combine buildTools, + buildToolDepends = combine buildToolDepends, + cppOptions = combine cppOptions, + asmOptions = combine asmOptions, + cmmOptions = combine cmmOptions, + ccOptions = combine ccOptions, + cxxOptions = combine cxxOptions, + ldOptions = combine ldOptions, + hsc2hsOptions = combine hsc2hsOptions, + pkgconfigDepends = combine pkgconfigDepends, + frameworks = combineNub frameworks, + extraFrameworkDirs = combineNub extraFrameworkDirs, + asmSources = combineNub asmSources, + cmmSources = combineNub cmmSources, + cSources = combineNub cSources, + cxxSources = combineNub cxxSources, + jsSources = combineNub jsSources, + hsSourceDirs = combineNub hsSourceDirs, + otherModules = combineNub otherModules, + virtualModules = combineNub virtualModules, + autogenModules = combineNub autogenModules, + defaultLanguage = combineMby defaultLanguage, + otherLanguages = combineNub otherLanguages, + defaultExtensions = combineNub defaultExtensions, + otherExtensions = combineNub otherExtensions, + oldExtensions = combineNub oldExtensions, + extraLibs = combine extraLibs, + extraLibsStatic = combine extraLibsStatic, + extraGHCiLibs = combine extraGHCiLibs, + extraBundledLibs = combine extraBundledLibs, + extraLibFlavours = combine extraLibFlavours, + extraDynLibFlavours = combine extraDynLibFlavours, + extraLibDirs = combineNub extraLibDirs, + extraLibDirsStatic = combineNub extraLibDirsStatic, + includeDirs = combineNub includeDirs, + includes = combineNub includes, + autogenIncludes = combineNub autogenIncludes, + installIncludes = combineNub installIncludes, + options = combine options, + profOptions = combine profOptions, + sharedOptions = combine sharedOptions, + staticOptions = combine staticOptions, + customFieldsBI = combine customFieldsBI, + targetBuildDepends = combineNub targetBuildDepends, + mixins = combine mixins + } + where + combine field = field a `mappend` field b + combineNub field = nub (combine field) + combineMby field = field b `mplus` field a + +emptyBuildInfo :: BuildInfo +emptyBuildInfo = mempty + +-- | The 'Language's used by this component +-- +allLanguages :: BuildInfo -> [Language] +allLanguages bi = maybeToList (defaultLanguage bi) + ++ otherLanguages bi + +-- | The 'Extension's that are used somewhere by this component +-- +allExtensions :: BuildInfo -> [Extension] +allExtensions bi = usedExtensions bi + ++ otherExtensions bi + +-- | The 'Extensions' that are used by all modules in this component +-- +usedExtensions :: BuildInfo -> [Extension] +usedExtensions bi = oldExtensions bi + ++ defaultExtensions bi + +-- | Whether any modules in this component use Template Haskell or +-- Quasi Quotes +usesTemplateHaskellOrQQ :: BuildInfo -> Bool +usesTemplateHaskellOrQQ bi = any p (allExtensions bi) + where + p ex = ex `elem` + [EnableExtension TemplateHaskell, EnableExtension QuasiQuotes] + +-- |Select options for a particular Haskell compiler. +hcOptions :: CompilerFlavor -> BuildInfo -> [String] +hcOptions = lookupHcOptions options + +hcProfOptions :: CompilerFlavor -> BuildInfo -> [String] +hcProfOptions = lookupHcOptions profOptions + +hcSharedOptions :: CompilerFlavor -> BuildInfo -> [String] +hcSharedOptions = lookupHcOptions sharedOptions + +hcStaticOptions :: CompilerFlavor -> BuildInfo -> [String] +hcStaticOptions = lookupHcOptions staticOptions + +lookupHcOptions :: (BuildInfo -> PerCompilerFlavor [String]) + -> CompilerFlavor -> BuildInfo -> [String] +lookupHcOptions f hc bi = case f bi of + PerCompilerFlavor ghc ghcjs + | hc == GHC -> ghc + | hc == GHCJS -> ghcjs + | otherwise -> mempty diff --git a/cabal/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs b/cabal/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs @@ -0,0 +1,356 @@ +module Distribution.Types.BuildInfo.Lens ( + BuildInfo, + HasBuildInfo (..), + HasBuildInfos (..), + ) where + +import Distribution.Compat.Lens +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Compiler (PerCompilerFlavor) +import Distribution.ModuleName (ModuleName) +import Distribution.Types.BuildInfo (BuildInfo) +import Distribution.Types.Dependency (Dependency) +import Distribution.Types.ExeDependency (ExeDependency) +import Distribution.Types.LegacyExeDependency (LegacyExeDependency) +import Distribution.Types.Mixin (Mixin) +import Distribution.Types.PkgconfigDependency (PkgconfigDependency) +import Distribution.Utils.Path +import Language.Haskell.Extension (Extension, Language) + +import qualified Distribution.Types.BuildInfo as T + +-- | Classy lenses for 'BuildInfo'. +class HasBuildInfo a where + buildInfo :: Lens' a BuildInfo + + buildable :: Lens' a Bool + buildable = buildInfo . buildable + {-# INLINE buildable #-} + + buildTools :: Lens' a [LegacyExeDependency] + buildTools = buildInfo . buildTools + {-# INLINE buildTools #-} + + buildToolDepends :: Lens' a [ExeDependency] + buildToolDepends = buildInfo . buildToolDepends + {-# INLINE buildToolDepends #-} + + cppOptions :: Lens' a [String] + cppOptions = buildInfo . cppOptions + {-# INLINE cppOptions #-} + + asmOptions :: Lens' a [String] + asmOptions = buildInfo . asmOptions + {-# INLINE asmOptions #-} + + cmmOptions :: Lens' a [String] + cmmOptions = buildInfo . cmmOptions + {-# INLINE cmmOptions #-} + + ccOptions :: Lens' a [String] + ccOptions = buildInfo . ccOptions + {-# INLINE ccOptions #-} + + cxxOptions :: Lens' a [String] + cxxOptions = buildInfo . cxxOptions + {-# INLINE cxxOptions #-} + + ldOptions :: Lens' a [String] + ldOptions = buildInfo . ldOptions + {-# INLINE ldOptions #-} + + hsc2hsOptions :: Lens' a [String] + hsc2hsOptions = buildInfo . hsc2hsOptions + {-# INLINE hsc2hsOptions #-} + + pkgconfigDepends :: Lens' a [PkgconfigDependency] + pkgconfigDepends = buildInfo . pkgconfigDepends + {-# INLINE pkgconfigDepends #-} + + frameworks :: Lens' a [String] + frameworks = buildInfo . frameworks + {-# INLINE frameworks #-} + + extraFrameworkDirs :: Lens' a [String] + extraFrameworkDirs = buildInfo . extraFrameworkDirs + {-# INLINE extraFrameworkDirs #-} + + asmSources :: Lens' a [FilePath] + asmSources = buildInfo . asmSources + {-# INLINE asmSources #-} + + cmmSources :: Lens' a [FilePath] + cmmSources = buildInfo . cmmSources + {-# INLINE cmmSources #-} + + cSources :: Lens' a [FilePath] + cSources = buildInfo . cSources + {-# INLINE cSources #-} + + cxxSources :: Lens' a [FilePath] + cxxSources = buildInfo . cxxSources + {-# INLINE cxxSources #-} + + jsSources :: Lens' a [FilePath] + jsSources = buildInfo . jsSources + {-# INLINE jsSources #-} + + hsSourceDirs :: Lens' a [SymbolicPath PackageDir SourceDir] + hsSourceDirs = buildInfo . hsSourceDirs + {-# INLINE hsSourceDirs #-} + + otherModules :: Lens' a [ModuleName] + otherModules = buildInfo . otherModules + {-# INLINE otherModules #-} + + virtualModules :: Lens' a [ModuleName] + virtualModules = buildInfo . virtualModules + {-# INLINE virtualModules #-} + + autogenModules :: Lens' a [ModuleName] + autogenModules = buildInfo . autogenModules + {-# INLINE autogenModules #-} + + defaultLanguage :: Lens' a (Maybe Language) + defaultLanguage = buildInfo . defaultLanguage + {-# INLINE defaultLanguage #-} + + otherLanguages :: Lens' a [Language] + otherLanguages = buildInfo . otherLanguages + {-# INLINE otherLanguages #-} + + defaultExtensions :: Lens' a [Extension] + defaultExtensions = buildInfo . defaultExtensions + {-# INLINE defaultExtensions #-} + + otherExtensions :: Lens' a [Extension] + otherExtensions = buildInfo . otherExtensions + {-# INLINE otherExtensions #-} + + oldExtensions :: Lens' a [Extension] + oldExtensions = buildInfo . oldExtensions + {-# INLINE oldExtensions #-} + + extraLibs :: Lens' a [String] + extraLibs = buildInfo . extraLibs + {-# INLINE extraLibs #-} + + extraLibsStatic :: Lens' a [String] + extraLibsStatic = buildInfo . extraLibsStatic + {-# INLINE extraLibsStatic #-} + + extraGHCiLibs :: Lens' a [String] + extraGHCiLibs = buildInfo . extraGHCiLibs + {-# INLINE extraGHCiLibs #-} + + extraBundledLibs :: Lens' a [String] + extraBundledLibs = buildInfo . extraBundledLibs + {-# INLINE extraBundledLibs #-} + + extraLibFlavours :: Lens' a [String] + extraLibFlavours = buildInfo . extraLibFlavours + {-# INLINE extraLibFlavours #-} + + extraDynLibFlavours :: Lens' a [String] + extraDynLibFlavours = buildInfo . extraDynLibFlavours + {-# INLINE extraDynLibFlavours #-} + + extraLibDirs :: Lens' a [String] + extraLibDirs = buildInfo . extraLibDirs + {-# INLINE extraLibDirs #-} + + extraLibDirsStatic :: Lens' a [String] + extraLibDirsStatic = buildInfo . extraLibDirsStatic + {-# INLINE extraLibDirsStatic #-} + + includeDirs :: Lens' a [FilePath] + includeDirs = buildInfo . includeDirs + {-# INLINE includeDirs #-} + + includes :: Lens' a [FilePath] + includes = buildInfo . includes + {-# INLINE includes #-} + + autogenIncludes :: Lens' a [FilePath] + autogenIncludes = buildInfo . autogenIncludes + {-# INLINE autogenIncludes #-} + + installIncludes :: Lens' a [FilePath] + installIncludes = buildInfo . installIncludes + {-# INLINE installIncludes #-} + + options :: Lens' a (PerCompilerFlavor [String]) + options = buildInfo . options + {-# INLINE options #-} + + profOptions :: Lens' a (PerCompilerFlavor [String]) + profOptions = buildInfo . profOptions + {-# INLINE profOptions #-} + + sharedOptions :: Lens' a (PerCompilerFlavor [String]) + sharedOptions = buildInfo . sharedOptions + {-# INLINE sharedOptions #-} + + staticOptions :: Lens' a (PerCompilerFlavor [String]) + staticOptions = buildInfo . staticOptions + {-# INLINE staticOptions #-} + + customFieldsBI :: Lens' a [(String,String)] + customFieldsBI = buildInfo . customFieldsBI + {-# INLINE customFieldsBI #-} + + targetBuildDepends :: Lens' a [Dependency] + targetBuildDepends = buildInfo . targetBuildDepends + {-# INLINE targetBuildDepends #-} + + mixins :: Lens' a [Mixin] + mixins = buildInfo . mixins + {-# INLINE mixins #-} + + +instance HasBuildInfo BuildInfo where + buildInfo = id + {-# INLINE buildInfo #-} + + buildable f s = fmap (\x -> s { T.buildable = x }) (f (T.buildable s)) + {-# INLINE buildable #-} + + buildTools f s = fmap (\x -> s { T.buildTools = x }) (f (T.buildTools s)) + {-# INLINE buildTools #-} + + buildToolDepends f s = fmap (\x -> s { T.buildToolDepends = x }) (f (T.buildToolDepends s)) + {-# INLINE buildToolDepends #-} + + cppOptions f s = fmap (\x -> s { T.cppOptions = x }) (f (T.cppOptions s)) + {-# INLINE cppOptions #-} + + asmOptions f s = fmap (\x -> s { T.asmOptions = x }) (f (T.asmOptions s)) + {-# INLINE asmOptions #-} + + cmmOptions f s = fmap (\x -> s { T.cmmOptions = x }) (f (T.cmmOptions s)) + {-# INLINE cmmOptions #-} + + ccOptions f s = fmap (\x -> s { T.ccOptions = x }) (f (T.ccOptions s)) + {-# INLINE ccOptions #-} + + cxxOptions f s = fmap (\x -> s { T.cxxOptions = x }) (f (T.cxxOptions s)) + {-# INLINE cxxOptions #-} + + ldOptions f s = fmap (\x -> s { T.ldOptions = x }) (f (T.ldOptions s)) + {-# INLINE ldOptions #-} + + hsc2hsOptions f s = fmap (\x -> s { T.hsc2hsOptions = x }) (f (T.hsc2hsOptions s)) + {-# INLINE hsc2hsOptions #-} + + pkgconfigDepends f s = fmap (\x -> s { T.pkgconfigDepends = x }) (f (T.pkgconfigDepends s)) + {-# INLINE pkgconfigDepends #-} + + frameworks f s = fmap (\x -> s { T.frameworks = x }) (f (T.frameworks s)) + {-# INLINE frameworks #-} + + extraFrameworkDirs f s = fmap (\x -> s { T.extraFrameworkDirs = x }) (f (T.extraFrameworkDirs s)) + {-# INLINE extraFrameworkDirs #-} + + asmSources f s = fmap (\x -> s { T.asmSources = x }) (f (T.asmSources s)) + {-# INLINE asmSources #-} + + cmmSources f s = fmap (\x -> s { T.cmmSources = x }) (f (T.cmmSources s)) + {-# INLINE cmmSources #-} + + cSources f s = fmap (\x -> s { T.cSources = x }) (f (T.cSources s)) + {-# INLINE cSources #-} + + cxxSources f s = fmap (\x -> s { T.cSources = x }) (f (T.cxxSources s)) + {-# INLINE cxxSources #-} + + jsSources f s = fmap (\x -> s { T.jsSources = x }) (f (T.jsSources s)) + {-# INLINE jsSources #-} + + hsSourceDirs f s = fmap (\x -> s { T.hsSourceDirs = x }) (f (T.hsSourceDirs s)) + {-# INLINE hsSourceDirs #-} + + otherModules f s = fmap (\x -> s { T.otherModules = x }) (f (T.otherModules s)) + {-# INLINE otherModules #-} + + virtualModules f s = fmap (\x -> s { T.virtualModules = x }) (f (T.virtualModules s)) + {-# INLINE virtualModules #-} + + autogenModules f s = fmap (\x -> s { T.autogenModules = x }) (f (T.autogenModules s)) + {-# INLINE autogenModules #-} + + defaultLanguage f s = fmap (\x -> s { T.defaultLanguage = x }) (f (T.defaultLanguage s)) + {-# INLINE defaultLanguage #-} + + otherLanguages f s = fmap (\x -> s { T.otherLanguages = x }) (f (T.otherLanguages s)) + {-# INLINE otherLanguages #-} + + defaultExtensions f s = fmap (\x -> s { T.defaultExtensions = x }) (f (T.defaultExtensions s)) + {-# INLINE defaultExtensions #-} + + otherExtensions f s = fmap (\x -> s { T.otherExtensions = x }) (f (T.otherExtensions s)) + {-# INLINE otherExtensions #-} + + oldExtensions f s = fmap (\x -> s { T.oldExtensions = x }) (f (T.oldExtensions s)) + {-# INLINE oldExtensions #-} + + extraLibs f s = fmap (\x -> s { T.extraLibs = x }) (f (T.extraLibs s)) + {-# INLINE extraLibs #-} + + extraLibsStatic f s = fmap (\x -> s { T.extraLibsStatic = x}) (f (T.extraLibsStatic s)) + {-# INLINE extraLibsStatic #-} + + extraGHCiLibs f s = fmap (\x -> s { T.extraGHCiLibs = x }) (f (T.extraGHCiLibs s)) + {-# INLINE extraGHCiLibs #-} + + extraBundledLibs f s = fmap (\x -> s { T.extraBundledLibs = x }) (f (T.extraBundledLibs s)) + {-# INLINE extraBundledLibs #-} + + extraLibFlavours f s = fmap (\x -> s { T.extraLibFlavours = x }) (f (T.extraLibFlavours s)) + {-# INLINE extraLibFlavours #-} + + extraDynLibFlavours f s = fmap (\x -> s { T.extraDynLibFlavours = x}) (f (T.extraDynLibFlavours s)) + {-# INLINE extraDynLibFlavours #-} + + extraLibDirs f s = fmap (\x -> s { T.extraLibDirs = x }) (f (T.extraLibDirs s)) + {-# INLINE extraLibDirs #-} + + extraLibDirsStatic f s = fmap (\x -> s { T.extraLibDirsStatic = x}) (f (T.extraLibDirsStatic s)) + {-# INLINE extraLibDirsStatic #-} + + includeDirs f s = fmap (\x -> s { T.includeDirs = x }) (f (T.includeDirs s)) + {-# INLINE includeDirs #-} + + includes f s = fmap (\x -> s { T.includes = x }) (f (T.includes s)) + {-# INLINE includes #-} + + autogenIncludes f s = fmap (\x -> s { T.autogenIncludes = x }) (f (T.autogenIncludes s)) + {-# INLINE autogenIncludes #-} + + installIncludes f s = fmap (\x -> s { T.installIncludes = x }) (f (T.installIncludes s)) + {-# INLINE installIncludes #-} + + options f s = fmap (\x -> s { T.options = x }) (f (T.options s)) + {-# INLINE options #-} + + profOptions f s = fmap (\x -> s { T.profOptions = x }) (f (T.profOptions s)) + {-# INLINE profOptions #-} + + sharedOptions f s = fmap (\x -> s { T.sharedOptions = x }) (f (T.sharedOptions s)) + {-# INLINE sharedOptions #-} + + staticOptions f s = fmap (\x -> s { T.staticOptions = x }) (f (T.staticOptions s)) + {-# INLINE staticOptions #-} + + customFieldsBI f s = fmap (\x -> s { T.customFieldsBI = x }) (f (T.customFieldsBI s)) + {-# INLINE customFieldsBI #-} + + targetBuildDepends f s = fmap (\x -> s { T.targetBuildDepends = x }) (f (T.targetBuildDepends s)) + {-# INLINE targetBuildDepends #-} + + mixins f s = fmap (\x -> s { T.mixins = x }) (f (T.mixins s)) + {-# INLINE mixins #-} + +class HasBuildInfos a where + traverseBuildInfos :: Traversal' a BuildInfo diff --git a/cabal/Cabal-syntax/src/Distribution/Types/BuildType.hs b/cabal/Cabal-syntax/src/Distribution/Types/BuildType.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/BuildType.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module Distribution.Types.BuildType ( + BuildType(..), + knownBuildTypes, +) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.CabalSpecVersion (CabalSpecVersion (..)) +import Distribution.Pretty +import Distribution.Parsec + +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as Disp + +-- | The type of build system used by this package. +data BuildType + = Simple -- ^ calls @Distribution.Simple.defaultMain@ + | Configure -- ^ calls @Distribution.Simple.defaultMainWithHooks defaultUserHooks@, + -- which invokes @configure@ to generate additional build + -- information used by later phases. + | Make -- ^ calls @Distribution.Make.defaultMain@ + | Custom -- ^ uses user-supplied @Setup.hs@ or @Setup.lhs@ (default) + deriving (Generic, Show, Read, Eq, Typeable, Data) + +instance Binary BuildType +instance Structured BuildType +instance NFData BuildType where rnf = genericRnf + +knownBuildTypes :: [BuildType] +knownBuildTypes = [Simple, Configure, Make, Custom] + +instance Pretty BuildType where + pretty = Disp.text . show + +instance Parsec BuildType where + parsec = do + name <- P.munch1 isAlphaNum + case name of + "Simple" -> return Simple + "Configure" -> return Configure + "Custom" -> return Custom + "Make" -> return Make + "Default" -> do + v <- askCabalSpecVersion + if v <= CabalSpecV1_18 -- oldest version needing this, based on hackage-tests + then do + parsecWarning PWTBuildTypeDefault "build-type: Default is parsed as Custom for legacy reasons. See https://github.com/haskell/cabal/issues/5020" + return Custom + else fail ("unknown build-type: '" ++ name ++ "'") + _ -> fail ("unknown build-type: '" ++ name ++ "'") diff --git a/cabal/Cabal-syntax/src/Distribution/Types/Component.hs b/cabal/Cabal-syntax/src/Distribution/Types/Component.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/Component.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Distribution.Types.Component ( + Component(..), + foldComponent, + componentBuildInfo, + componentBuildable, + componentName, + partitionComponents, +) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Types.Library +import Distribution.Types.ForeignLib +import Distribution.Types.Executable +import Distribution.Types.TestSuite +import Distribution.Types.Benchmark + +import Distribution.Types.ComponentName +import Distribution.Types.BuildInfo + +import qualified Distribution.Types.BuildInfo.Lens as L + +data Component = CLib Library + | CFLib ForeignLib + | CExe Executable + | CTest TestSuite + | CBench Benchmark + deriving (Show, Eq, Read) + +instance Semigroup Component where + CLib l <> CLib l' = CLib (l <> l') + CFLib l <> CFLib l' = CFLib (l <> l') + CExe e <> CExe e' = CExe (e <> e') + CTest t <> CTest t' = CTest (t <> t') + CBench b <> CBench b' = CBench (b <> b') + _ <> _ = error "Cannot merge Component" + +instance L.HasBuildInfo Component where + buildInfo f (CLib l) = CLib <$> L.buildInfo f l + buildInfo f (CFLib l) = CFLib <$> L.buildInfo f l + buildInfo f (CExe e) = CExe <$> L.buildInfo f e + buildInfo f (CTest t) = CTest <$> L.buildInfo f t + buildInfo f (CBench b) = CBench <$> L.buildInfo f b + +foldComponent :: (Library -> a) + -> (ForeignLib -> a) + -> (Executable -> a) + -> (TestSuite -> a) + -> (Benchmark -> a) + -> Component + -> a +foldComponent f _ _ _ _ (CLib lib) = f lib +foldComponent _ f _ _ _ (CFLib flib)= f flib +foldComponent _ _ f _ _ (CExe exe) = f exe +foldComponent _ _ _ f _ (CTest tst) = f tst +foldComponent _ _ _ _ f (CBench bch) = f bch + +componentBuildInfo :: Component -> BuildInfo +componentBuildInfo = + foldComponent libBuildInfo foreignLibBuildInfo buildInfo testBuildInfo benchmarkBuildInfo + +-- | Is a component buildable (i.e., not marked with @buildable: False@)? +-- See also this note in +-- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components". +-- +-- @since 2.0.0.2 +-- +componentBuildable :: Component -> Bool +componentBuildable = buildable . componentBuildInfo + +componentName :: Component -> ComponentName +componentName = + foldComponent (CLibName . libName) + (CFLibName . foreignLibName) + (CExeName . exeName) + (CTestName . testName) + (CBenchName . benchmarkName) + +partitionComponents + :: [Component] + -> ([Library], [ForeignLib], [Executable], [TestSuite], [Benchmark]) +partitionComponents = foldr (foldComponent fa fb fc fd fe) ([],[],[],[],[]) + where + fa x ~(a,b,c,d,e) = (x:a,b,c,d,e) + fb x ~(a,b,c,d,e) = (a,x:b,c,d,e) + fc x ~(a,b,c,d,e) = (a,b,x:c,d,e) + fd x ~(a,b,c,d,e) = (a,b,c,x:d,e) + fe x ~(a,b,c,d,e) = (a,b,c,d,x:e) diff --git a/cabal/Cabal-syntax/src/Distribution/Types/ComponentId.hs b/cabal/Cabal-syntax/src/Distribution/Types/ComponentId.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/ComponentId.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Distribution.Types.ComponentId + ( ComponentId, unComponentId, mkComponentId + ) where + +import Prelude () +import Distribution.Compat.Prelude +import Distribution.Utils.ShortText + +import Distribution.Pretty +import Distribution.Parsec + +import qualified Distribution.Compat.CharParsing as P +import Text.PrettyPrint (text) + +-- | A 'ComponentId' uniquely identifies the transitive source +-- code closure of a component (i.e. libraries, executables). +-- +-- For non-Backpack components, this corresponds one to one with +-- the 'UnitId', which serves as the basis for install paths, +-- linker symbols, etc. +-- +-- Use 'mkComponentId' and 'unComponentId' to convert from/to a +-- 'String'. +-- +-- This type is opaque since @Cabal-2.0@ +-- +-- @since 2.0.0.2 +newtype ComponentId = ComponentId ShortText + deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) + +-- | Construct a 'ComponentId' from a 'String' +-- +-- 'mkComponentId' is the inverse to 'unComponentId' +-- +-- Note: No validations are performed to ensure that the resulting +-- 'ComponentId' is valid +-- +-- @since 2.0.0.2 +mkComponentId :: String -> ComponentId +mkComponentId = ComponentId . toShortText + +-- | Convert 'ComponentId' to 'String' +-- +-- @since 2.0.0.2 +unComponentId :: ComponentId -> String +unComponentId (ComponentId s) = fromShortText s + +-- | 'mkComponentId' +-- +-- @since 2.0.0.2 +instance IsString ComponentId where + fromString = mkComponentId + +instance Binary ComponentId +instance Structured ComponentId + +instance Pretty ComponentId where + pretty = text . unComponentId + +instance Parsec ComponentId where + parsec = mkComponentId `fmap` P.munch1 abi_char + where abi_char c = isAlphaNum c || c `elem` "-_." + +instance NFData ComponentId where + rnf = rnf . unComponentId diff --git a/cabal/Cabal-syntax/src/Distribution/Types/ComponentName.hs b/cabal/Cabal-syntax/src/Distribution/Types/ComponentName.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/ComponentName.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +module Distribution.Types.ComponentName ( + ComponentName(..), + showComponentName, + componentNameStanza, + componentNameString, + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Types.UnqualComponentName +import Distribution.Types.LibraryName +import Distribution.Pretty +import Distribution.Parsec + +import qualified Text.PrettyPrint as Disp +import qualified Distribution.Compat.CharParsing as P + +-- Libraries live in a separate namespace, so must distinguish +data ComponentName = CLibName LibraryName + | CFLibName UnqualComponentName + | CExeName UnqualComponentName + | CTestName UnqualComponentName + | CBenchName UnqualComponentName + deriving (Eq, Generic, Ord, Read, Show, Typeable) + +instance Binary ComponentName +instance Structured ComponentName + +-- Build-target-ish syntax +instance Pretty ComponentName where + pretty (CLibName lib) = prettyLibraryNameComponent lib + pretty (CFLibName str) = Disp.text "flib:" <<>> pretty str + pretty (CExeName str) = Disp.text "exe:" <<>> pretty str + pretty (CTestName str) = Disp.text "test:" <<>> pretty str + pretty (CBenchName str) = Disp.text "bench:" <<>> pretty str + +instance Parsec ComponentName where + -- note: this works as lib/flib/... all start with different character! + parsec = parseComposite <|> parseLib + where + parseLib = CLibName <$> parsecLibraryNameComponent + parseComposite = do + ctor <- P.choice + [ P.string "flib:" >> return CFLibName + , P.string "exe:" >> return CExeName + , P.string "bench:" >> return CBenchName + , P.string "test:" >> return CTestName + ] + ctor <$> parsec + +showComponentName :: ComponentName -> String +showComponentName (CLibName lib) = showLibraryName lib +showComponentName (CFLibName name) = "foreign library '" ++ prettyShow name ++ "'" +showComponentName (CExeName name) = "executable '" ++ prettyShow name ++ "'" +showComponentName (CTestName name) = "test suite '" ++ prettyShow name ++ "'" +showComponentName (CBenchName name) = "benchmark '" ++ prettyShow name ++ "'" + +componentNameStanza :: ComponentName -> String +componentNameStanza (CLibName lib) = libraryNameStanza lib +componentNameStanza (CFLibName name) = "foreign-library " ++ prettyShow name +componentNameStanza (CExeName name) = "executable " ++ prettyShow name +componentNameStanza (CTestName name) = "test-suite " ++ prettyShow name +componentNameStanza (CBenchName name) = "benchmark " ++ prettyShow name + +-- | This gets the underlying unqualified component name. In fact, it is +-- guaranteed to uniquely identify a component, returning +-- @Nothing@ if the 'ComponentName' was for the public +-- library. +componentNameString :: ComponentName -> Maybe UnqualComponentName +componentNameString (CLibName lib) = libraryNameString lib +componentNameString (CFLibName n) = Just n +componentNameString (CExeName n) = Just n +componentNameString (CTestName n) = Just n +componentNameString (CBenchName n) = Just n diff --git a/cabal/Cabal-syntax/src/Distribution/Types/ComponentRequestedSpec.hs b/cabal/Cabal-syntax/src/Distribution/Types/ComponentRequestedSpec.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/ComponentRequestedSpec.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Types.ComponentRequestedSpec ( + -- $buildable_vs_enabled_components + + ComponentRequestedSpec(..), + ComponentDisabledReason(..), + + defaultComponentRequestedSpec, + componentNameRequested, + + componentEnabled, + componentDisabledReason, +) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Types.Component -- TODO: maybe remove me? +import Distribution.Types.ComponentName + +import Distribution.Pretty (prettyShow) + +-- $buildable_vs_enabled_components +-- #buildable_vs_enabled_components# +-- +-- = Note: Buildable versus requested versus enabled components +-- What's the difference between a buildable component (ala +-- 'componentBuildable'), a requested component +-- (ala 'componentNameRequested'), and an enabled component (ala +-- 'componentEnabled')? +-- +-- A component is __buildable__ if, after resolving flags and +-- conditionals, there is no @buildable: False@ property in it. +-- This is a /static/ property that arises from the +-- Cabal file and the package description flattening; once we have +-- a 'PackageDescription' buildability is known. +-- +-- A component is __requested__ if a user specified, via a +-- the flags and arguments passed to configure, that it should be +-- built. E.g., @--enable-tests@ or @--enable-benchmarks@ request +-- all tests and benchmarks, if they are provided. What is requested +-- can be read off directly from 'ComponentRequestedSpec'. A requested +-- component is not always buildable; e.g., a user may @--enable-tests@ +-- but one of the test suites may have @buildable: False@. +-- +-- A component is __enabled__ if it is BOTH buildable +-- and requested. Once we have a 'LocalBuildInfo', whether or not a +-- component is enabled is known. +-- +-- Generally speaking, most Cabal API code cares if a component +-- is enabled. (For example, if you want to run a preprocessor on each +-- component prior to building them, you want to run this on each +-- /enabled/ component.) +-- +-- Note that post-configuration, you will generally not see a +-- non-buildable 'Component'. This is because 'flattenPD' will drop +-- any such components from 'PackageDescription'. See #3858 for +-- an example where this causes problems. + +-- | Describes what components are enabled by user-interaction. +-- See also this note in +-- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components". +-- +-- @since 2.0.0.2 +data ComponentRequestedSpec + = ComponentRequestedSpec { testsRequested :: Bool + , benchmarksRequested :: Bool } + | OneComponentRequestedSpec ComponentName + deriving (Generic, Read, Show, Eq, Typeable) + +instance Binary ComponentRequestedSpec +instance Structured ComponentRequestedSpec + +-- | The default set of enabled components. Historically tests and +-- benchmarks are NOT enabled by default. +-- +-- @since 2.0.0.2 +defaultComponentRequestedSpec :: ComponentRequestedSpec +defaultComponentRequestedSpec = ComponentRequestedSpec False False + +-- | Is this component enabled? See also this note in +-- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components". +-- +-- @since 2.0.0.2 +componentEnabled :: ComponentRequestedSpec -> Component -> Bool +componentEnabled enabled = isNothing . componentDisabledReason enabled + +-- | Is this component name enabled? See also this note in +-- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components". +-- +-- @since 2.0.0.2 +componentNameRequested :: ComponentRequestedSpec -> ComponentName -> Bool +componentNameRequested enabled = isNothing . componentNameNotRequestedReason enabled + +-- | Is this component disabled, and if so, why? +-- +-- @since 2.0.0.2 +componentDisabledReason :: ComponentRequestedSpec -> Component + -> Maybe ComponentDisabledReason +componentDisabledReason enabled comp + | not (componentBuildable comp) = Just DisabledComponent + | otherwise = componentNameNotRequestedReason enabled (componentName comp) + +-- | Is this component name disabled, and if so, why? +-- +-- @since 2.0.0.2 +componentNameNotRequestedReason :: ComponentRequestedSpec -> ComponentName + -> Maybe ComponentDisabledReason +componentNameNotRequestedReason + ComponentRequestedSpec{ testsRequested = False } (CTestName _) + = Just DisabledAllTests +componentNameNotRequestedReason + ComponentRequestedSpec{ benchmarksRequested = False } (CBenchName _) + = Just DisabledAllBenchmarks +componentNameNotRequestedReason ComponentRequestedSpec{} _ = Nothing +componentNameNotRequestedReason (OneComponentRequestedSpec cname) c + | c == cname = Nothing + | otherwise = Just (DisabledAllButOne (prettyShow cname)) + +-- | A reason explaining why a component is disabled. +-- +-- @since 2.0.0.2 +data ComponentDisabledReason = DisabledComponent + | DisabledAllTests + | DisabledAllBenchmarks + | DisabledAllButOne String diff --git a/cabal/Cabal-syntax/src/Distribution/Types/CondTree.hs b/cabal/Cabal-syntax/src/Distribution/Types/CondTree.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/CondTree.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Distribution.Types.CondTree ( + CondTree(..), + CondBranch(..), + condIfThen, + condIfThenElse, + foldCondTree, + mapCondTree, + mapTreeConstrs, + mapTreeConds, + mapTreeData, + traverseCondTreeV, + traverseCondBranchV, + traverseCondTreeC, + traverseCondBranchC, + extractCondition, + simplifyCondTree, + ignoreConditions, +) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Types.Condition + +import qualified Distribution.Compat.Lens as L + + +-- | A 'CondTree' is used to represent the conditional structure of +-- a Cabal file, reflecting a syntax element subject to constraints, +-- and then any number of sub-elements which may be enabled subject +-- to some condition. Both @a@ and @c@ are usually 'Monoid's. +-- +-- To be more concrete, consider the following fragment of a @Cabal@ +-- file: +-- +-- @ +-- build-depends: base >= 4.0 +-- if flag(extra) +-- build-depends: base >= 4.2 +-- @ +-- +-- One way to represent this is to have @'CondTree' 'ConfVar' +-- ['Dependency'] 'BuildInfo'@. Here, 'condTreeData' represents +-- the actual fields which are not behind any conditional, while +-- 'condTreeComponents' recursively records any further fields +-- which are behind a conditional. 'condTreeConstraints' records +-- the constraints (in this case, @base >= 4.0@) which would +-- be applied if you use this syntax; in general, this is +-- derived off of 'targetBuildInfo' (perhaps a good refactoring +-- would be to convert this into an opaque type, with a smart +-- constructor that pre-computes the dependencies.) +-- +data CondTree v c a = CondNode + { condTreeData :: a + , condTreeConstraints :: c + , condTreeComponents :: [CondBranch v c a] + } + deriving (Show, Eq, Typeable, Data, Generic, Functor, Foldable, Traversable) + +instance (Binary v, Binary c, Binary a) => Binary (CondTree v c a) +instance (Structured v, Structured c, Structured a) => Structured (CondTree v c a) +instance (NFData v, NFData c, NFData a) => NFData (CondTree v c a) where rnf = genericRnf + +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 c, Monoid a, Monoid c) => Monoid (CondTree v c a) where + mappend = (<>) + mempty = CondNode mempty 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 + { condBranchCondition :: Condition v + , condBranchIfTrue :: CondTree v c a + , condBranchIfFalse :: Maybe (CondTree v c a) + } + deriving (Show, Eq, Typeable, Data, Generic, Functor, Traversable) + +-- This instance is written by hand because GHC 8.0.1/8.0.2 infinite +-- loops when trying to derive it with optimizations. See +-- https://gitlab.haskell.org/ghc/ghc/-/issues/13056 +instance Foldable (CondBranch v c) where + foldMap f (CondBranch _ c Nothing) = foldMap f c + foldMap f (CondBranch _ c (Just a)) = foldMap f c `mappend` foldMap f a + +instance (Binary v, Binary c, Binary a) => Binary (CondBranch v c a) +instance (Structured v, Structured c, Structured a) => Structured (CondBranch v c a) +instance (NFData v, NFData c, NFData a) => NFData (CondBranch v c a) where rnf = genericRnf + +condIfThen :: Condition v -> CondTree v c a -> CondBranch v c a +condIfThen c t = CondBranch c t Nothing + +condIfThenElse :: Condition v -> CondTree v c a -> CondTree v c a -> CondBranch v c a +condIfThenElse c t e = CondBranch c t (Just e) + +mapCondTree :: (a -> b) -> (c -> d) -> (Condition v -> Condition w) + -> CondTree v c a -> CondTree w d b +mapCondTree fa fc fcnd (CondNode a c ifs) = + CondNode (fa a) (fc c) (map g ifs) + where + g (CondBranch cnd t me) + = CondBranch (fcnd cnd) + (mapCondTree fa fc fcnd t) + (fmap (mapCondTree fa fc fcnd) me) + +mapTreeConstrs :: (c -> d) -> CondTree v c a -> CondTree v d a +mapTreeConstrs f = mapCondTree id f id + +mapTreeConds :: (Condition v -> Condition w) -> CondTree v c a -> CondTree w c a +mapTreeConds f = mapCondTree id id f + +mapTreeData :: (a -> b) -> CondTree v c a -> CondTree v c b +mapTreeData f = mapCondTree f id id + +-- | @@Traversal@@ for the variables +traverseCondTreeV :: L.Traversal (CondTree v c a) (CondTree w c a) v w +traverseCondTreeV f (CondNode a c ifs) = + CondNode a c <$> traverse (traverseCondBranchV f) ifs + +-- | @@Traversal@@ for the variables +traverseCondBranchV :: L.Traversal (CondBranch v c a) (CondBranch w c a) v w +traverseCondBranchV f (CondBranch cnd t me) = CondBranch + <$> traverse f cnd + <*> traverseCondTreeV f t + <*> traverse (traverseCondTreeV f) me + +-- | @@Traversal@@ for the aggregated constraints +traverseCondTreeC :: L.Traversal (CondTree v c a) (CondTree v d a) c d +traverseCondTreeC f (CondNode a c ifs) = + CondNode a <$> f c <*> traverse (traverseCondBranchC f) ifs + +-- | @@Traversal@@ for the aggregated constraints +traverseCondBranchC :: L.Traversal (CondBranch v c a) (CondBranch v d a) c d +traverseCondBranchC f (CondBranch cnd t me) = CondBranch cnd + <$> traverseCondTreeC f t + <*> traverse (traverseCondTreeC f) me + + +-- | Extract the condition matched by the given predicate from a cond tree. +-- +-- We use this mainly for extracting buildable conditions (see the Note in +-- Distribution.PackageDescription.Configuration), but the function is in fact +-- more general. +extractCondition :: Eq v => (a -> Bool) -> CondTree v c a -> Condition v +extractCondition p = go + where + go (CondNode x _ cs) | not (p x) = Lit False + | otherwise = goList cs + + goList [] = Lit True + goList (CondBranch c t e : cs) = + let + ct = go t + ce = maybe (Lit True) go e + in + ((c `cAnd` ct) `cOr` (CNot c `cAnd` ce)) `cAnd` goList cs + +-- | Flattens a CondTree using a partial flag assignment. When a condition +-- cannot be evaluated, both branches are ignored. +simplifyCondTree :: (Semigroup a, Semigroup d) => + (v -> Either v Bool) + -> CondTree v d a + -> (d, a) +simplifyCondTree env (CondNode a d ifs) = + foldl (<>) (d, a) $ mapMaybe simplifyIf ifs + where + simplifyIf (CondBranch cnd t me) = + case simplifyCondition cnd env of + (Lit True, _) -> Just $ simplifyCondTree env t + (Lit False, _) -> fmap (simplifyCondTree env) me + _ -> Nothing + +-- | Flatten a CondTree. This will resolve the CondTree by taking all +-- possible paths into account. Note that since branches represent exclusive +-- choices this may not result in a \"sane\" result. +ignoreConditions :: (Semigroup a, Semigroup c) => CondTree v c a -> (a, c) +ignoreConditions (CondNode a c ifs) = foldl (<>) (a, c) $ concatMap f ifs + where f (CondBranch _ t me) = ignoreConditions t + : maybeToList (fmap ignoreConditions me) + + +-- | 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 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 + goBranch acc (CondBranch _ t mt) = mergeInclusive acc (maybe (goTree t) (mergeExclusive (goTree t) . goTree) mt) diff --git a/cabal/Cabal-syntax/src/Distribution/Types/Condition.hs b/cabal/Cabal-syntax/src/Distribution/Types/Condition.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/Condition.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +module Distribution.Types.Condition ( + Condition(..), + cNot, + cAnd, + cOr, + simplifyCondition, +) where + +import Prelude () +import Distribution.Compat.Prelude + +-- | A boolean expression parameterized over the variable type used. +data Condition c = Var c + | Lit Bool + | CNot (Condition c) + | COr (Condition c) (Condition c) + | CAnd (Condition c) (Condition c) + deriving (Show, Eq, Typeable, Data, Generic) + +-- | Boolean negation of a 'Condition' value. +cNot :: Condition a -> Condition a +cNot (Lit b) = Lit (not b) +cNot (CNot c) = c +cNot c = CNot c + +-- | Boolean AND of two 'Condtion' values. +cAnd :: Condition a -> Condition a -> Condition a +cAnd (Lit False) _ = Lit False +cAnd _ (Lit False) = Lit False +cAnd (Lit True) x = x +cAnd x (Lit True) = x +cAnd x y = CAnd x y + +-- | Boolean OR of two 'Condition' values. +cOr :: Eq v => Condition v -> Condition v -> Condition v +cOr (Lit True) _ = Lit True +cOr _ (Lit True) = Lit True +cOr (Lit False) x = x +cOr x (Lit False) = x +cOr c (CNot d) + | c == d = Lit True +cOr (CNot c) d + | c == d = Lit True +cOr x y = COr x y + +instance Functor Condition where + f `fmap` Var c = Var (f c) + _ `fmap` Lit c = Lit c + f `fmap` CNot c = CNot (fmap f c) + f `fmap` COr c d = COr (fmap f c) (fmap f d) + f `fmap` CAnd c d = CAnd (fmap f c) (fmap f d) + +instance Foldable Condition where + f `foldMap` Var c = f c + _ `foldMap` Lit _ = mempty + f `foldMap` CNot c = foldMap f c + f `foldMap` COr c d = foldMap f c `mappend` foldMap f d + f `foldMap` CAnd c d = foldMap f c `mappend` foldMap f d + +instance Traversable Condition where + f `traverse` Var c = Var `fmap` f c + _ `traverse` Lit c = pure $ Lit c + f `traverse` CNot c = CNot `fmap` traverse f c + f `traverse` COr c d = COr `fmap` traverse f c <*> traverse f d + f `traverse` CAnd c d = CAnd `fmap` traverse f c <*> traverse f d + +instance Applicative Condition where + pure = Var + (<*>) = ap + +instance Monad Condition where + return = pure + -- Terminating cases + (>>=) (Lit x) _ = Lit x + (>>=) (Var x) f = f x + -- Recursing cases + (>>=) (CNot x ) f = CNot (x >>= f) + (>>=) (COr x y) f = COr (x >>= f) (y >>= f) + (>>=) (CAnd x y) f = CAnd (x >>= f) (y >>= f) + +instance Monoid (Condition a) where + mempty = Lit False + mappend = (<>) + +instance Semigroup (Condition a) where + (<>) = COr + +instance Alternative Condition where + empty = mempty + (<|>) = mappend + +instance MonadPlus Condition where + mzero = mempty + mplus = mappend + +instance Binary c => Binary (Condition c) +instance Structured c => Structured (Condition c) +instance NFData c => NFData (Condition c) where rnf = genericRnf + +-- | Simplify the condition and return its free variables. +simplifyCondition :: Condition c + -> (c -> Either d Bool) -- ^ (partial) variable assignment + -> (Condition d, [d]) +simplifyCondition cond i = fv . walk $ cond + where + walk cnd = case cnd of + Var v -> either Var Lit (i v) + Lit b -> Lit b + CNot c -> case walk c of + Lit True -> Lit False + Lit False -> Lit True + c' -> CNot c' + COr c d -> case (walk c, walk d) of + (Lit False, d') -> d' + (Lit True, _) -> Lit True + (c', Lit False) -> c' + (_, Lit True) -> Lit True + (c',d') -> COr c' d' + CAnd c d -> case (walk c, walk d) of + (Lit False, _) -> Lit False + (Lit True, d') -> d' + (_, Lit False) -> Lit False + (c', Lit True) -> c' + (c',d') -> CAnd c' d' + -- gather free vars + fv c = (c, fv' c) + fv' c = case c of + Var v -> [v] + Lit _ -> [] + CNot c' -> fv' c' + COr c1 c2 -> fv' c1 ++ fv' c2 + CAnd c1 c2 -> fv' c1 ++ fv' c2 diff --git a/cabal/Cabal-syntax/src/Distribution/Types/ConfVar.hs b/cabal/Cabal-syntax/src/Distribution/Types/ConfVar.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/ConfVar.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Types.ConfVar ( + ConfVar(..), + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Types.Flag +import Distribution.Types.VersionRange +import Distribution.Compiler +import Distribution.System + +-- | A @ConfVar@ represents the variable type used. +data ConfVar = OS OS + | Arch Arch + | PackageFlag FlagName + | Impl CompilerFlavor VersionRange + deriving (Eq, Show, Typeable, Data, Generic) + +instance Binary ConfVar +instance Structured ConfVar + +instance NFData ConfVar where rnf = genericRnf diff --git a/cabal/Cabal-syntax/src/Distribution/Types/Dependency.hs b/cabal/Cabal-syntax/src/Distribution/Types/Dependency.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/Dependency.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Types.Dependency + ( Dependency(..) + , mkDependency + , depPkgName + , depVerRange + , depLibraries + , simplifyDependency + , mainLibSet + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Types.VersionRange (isAnyVersionLight) +import Distribution.Version (VersionRange, anyVersion, simplifyVersionRange) + +import Distribution.CabalSpecVersion +import Distribution.Compat.CharParsing (char, spaces) +import Distribution.Compat.Parsing (between, option) +import Distribution.Parsec +import Distribution.Pretty +import Distribution.Types.LibraryName +import Distribution.Types.PackageName +import Distribution.Types.UnqualComponentName + +import qualified Distribution.Compat.NonEmptySet as NES +import qualified Text.PrettyPrint as PP + +-- | Describes a dependency on a source package (API) +-- +-- /Invariant:/ package name does not appear as 'LSubLibName' in +-- set of library names. +-- +-- /Note:/ 'Dependency' is not an instance of 'Ord', and so it cannot be used +-- in 'Set' or as the key to a 'Map'. For these and similar use cases see +-- 'DependencyMap'. +-- +data Dependency = Dependency + PackageName + VersionRange + (NonEmptySet LibraryName) + -- ^ The set of libraries required from the package. + -- Only the selected libraries will be built. + -- It does not affect the cabal-install solver yet. + deriving (Generic, Read, Show, Eq, Typeable, Data) + +depPkgName :: Dependency -> PackageName +depPkgName (Dependency pn _ _) = pn + +depVerRange :: Dependency -> VersionRange +depVerRange (Dependency _ vr _) = vr + +depLibraries :: Dependency -> NonEmptySet LibraryName +depLibraries (Dependency _ _ cs) = cs + +-- | Smart constructor of 'Dependency'. +-- +-- If 'PackageName' is appears as 'LSubLibName' in a set of sublibraries, +-- it is automatically converted to 'LMainLibName'. +-- +-- @since 3.4.0.0 +-- +mkDependency :: PackageName -> VersionRange -> NonEmptySet LibraryName -> Dependency +mkDependency pn vr lb = Dependency pn vr (NES.map conv lb) + where + pn' = packageNameToUnqualComponentName pn + + conv l@LMainLibName = l + conv l@(LSubLibName ln) | ln == pn' = LMainLibName + | otherwise = l + +instance Binary Dependency +instance Structured Dependency +instance NFData Dependency where rnf = genericRnf + +-- | +-- +-- >>> prettyShow $ Dependency "pkg" anyVersion mainLibSet +-- "pkg" +-- +-- >>> prettyShow $ Dependency "pkg" anyVersion $ NES.insert (LSubLibName "sublib") mainLibSet +-- "pkg:{pkg, sublib}" +-- +-- >>> prettyShow $ Dependency "pkg" anyVersion $ NES.singleton (LSubLibName "sublib") +-- "pkg:sublib" +-- +-- >>> prettyShow $ Dependency "pkg" anyVersion $ NES.insert (LSubLibName "sublib-b") $ NES.singleton (LSubLibName "sublib-a") +-- "pkg:{sublib-a, sublib-b}" +-- +instance Pretty Dependency where + pretty (Dependency name ver sublibs) = withSubLibs (pretty name) <+> pver + where + -- TODO: change to isAnyVersion after #6736 + pver | isAnyVersionLight ver = PP.empty + | otherwise = pretty ver + + withSubLibs doc = case NES.toList sublibs of + [LMainLibName] -> doc + [LSubLibName uq] -> doc <<>> PP.colon <<>> pretty uq + _ -> doc <<>> PP.colon <<>> PP.braces prettySublibs + + prettySublibs = PP.hsep $ PP.punctuate PP.comma $ prettySublib <$> NES.toList sublibs + + prettySublib LMainLibName = PP.text $ unPackageName name + prettySublib (LSubLibName un) = PP.text $ unUnqualComponentName un + +-- | +-- +-- >>> simpleParsec "mylib:sub" :: Maybe Dependency +-- Just (Dependency (PackageName "mylib") (OrLaterVersion (mkVersion [0])) (fromNonEmpty (LSubLibName (UnqualComponentName "sub") :| []))) +-- +-- >>> simpleParsec "mylib:{sub1,sub2}" :: Maybe Dependency +-- Just (Dependency (PackageName "mylib") (OrLaterVersion (mkVersion [0])) (fromNonEmpty (LSubLibName (UnqualComponentName "sub1") :| [LSubLibName (UnqualComponentName "sub2")]))) +-- +-- >>> simpleParsec "mylib:{ sub1 , sub2 }" :: Maybe Dependency +-- Just (Dependency (PackageName "mylib") (OrLaterVersion (mkVersion [0])) (fromNonEmpty (LSubLibName (UnqualComponentName "sub1") :| [LSubLibName (UnqualComponentName "sub2")]))) +-- +-- >>> simpleParsec "mylib:{ sub1 , sub2 } ^>= 42" :: Maybe Dependency +-- Just (Dependency (PackageName "mylib") (MajorBoundVersion (mkVersion [42])) (fromNonEmpty (LSubLibName (UnqualComponentName "sub1") :| [LSubLibName (UnqualComponentName "sub2")]))) +-- +-- >>> simpleParsec "mylib:{ } ^>= 42" :: Maybe Dependency +-- Nothing +-- +-- >>> traverse_ print (map simpleParsec ["mylib:mylib", "mylib:{mylib}", "mylib:{mylib,sublib}" ] :: [Maybe Dependency]) +-- Just (Dependency (PackageName "mylib") (OrLaterVersion (mkVersion [0])) (fromNonEmpty (LMainLibName :| []))) +-- Just (Dependency (PackageName "mylib") (OrLaterVersion (mkVersion [0])) (fromNonEmpty (LMainLibName :| []))) +-- Just (Dependency (PackageName "mylib") (OrLaterVersion (mkVersion [0])) (fromNonEmpty (LMainLibName :| [LSubLibName (UnqualComponentName "sublib")]))) +-- +-- Spaces around colon are not allowed: +-- +-- >>> map simpleParsec ["mylib: sub", "mylib :sub", "mylib: {sub1,sub2}", "mylib :{sub1,sub2}"] :: [Maybe Dependency] +-- [Nothing,Nothing,Nothing,Nothing] +-- +-- Sublibrary syntax is accepted since @cabal-version: 3.0@ +-- +-- >>> map (`simpleParsec'` "mylib:sub") [CabalSpecV2_4, CabalSpecV3_0] :: [Maybe Dependency] +-- [Nothing,Just (Dependency (PackageName "mylib") (OrLaterVersion (mkVersion [0])) (fromNonEmpty (LSubLibName (UnqualComponentName "sub") :| [])))] +-- +instance Parsec Dependency where + parsec = do + name <- parsec + + libs <- option mainLibSet $ do + _ <- char ':' + versionGuardMultilibs + NES.singleton <$> parseLib <|> parseMultipleLibs + + spaces -- https://github.com/haskell/cabal/issues/5846 + + ver <- parsec <|> pure anyVersion + return $ mkDependency name ver libs + where + parseLib = LSubLibName <$> parsec + parseMultipleLibs = between + (char '{' *> spaces) + (spaces *> char '}') + (NES.fromNonEmpty <$> parsecCommaNonEmpty parseLib) + +versionGuardMultilibs :: CabalParsing m => m () +versionGuardMultilibs = do + csv <- askCabalSpecVersion + when (csv < CabalSpecV3_0) $ fail $ unwords + [ "Sublibrary dependency syntax used." + , "To use this syntax the package needs to specify at least 'cabal-version: 3.0'." + , "Alternatively, if you are depending on an internal library, you can write" + , "directly the library name as it were a package." + ] + +-- | Library set with main library. +-- +-- @since 3.4.0.0 +mainLibSet :: NonEmptySet LibraryName +mainLibSet = NES.singleton LMainLibName + +-- | Simplify the 'VersionRange' expression in a 'Dependency'. +-- See 'simplifyVersionRange'. +-- +simplifyDependency :: Dependency -> Dependency +simplifyDependency (Dependency name range comps) = + Dependency name (simplifyVersionRange range) comps diff --git a/cabal/Cabal-syntax/src/Distribution/Types/DependencyMap.hs b/cabal/Cabal-syntax/src/Distribution/Types/DependencyMap.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/DependencyMap.hs @@ -0,0 +1,57 @@ +module Distribution.Types.DependencyMap ( + DependencyMap, + toDepMap, + fromDepMap, + constrainBy, +) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Types.Dependency +import Distribution.Types.LibraryName +import Distribution.Types.PackageName +import Distribution.Types.PackageVersionConstraint +import Distribution.Version + +import qualified Data.Map.Lazy as Map + +-- | A map of dependencies. Newtyped since the default monoid instance is not +-- appropriate. The monoid instance uses 'intersectVersionRanges'. +newtype DependencyMap = DependencyMap { unDependencyMap :: Map PackageName (VersionRange, NonEmptySet LibraryName) } + deriving (Show, Read, Eq) + +instance Monoid DependencyMap where + mempty = DependencyMap Map.empty + mappend = (<>) + +instance Semigroup DependencyMap where + (DependencyMap a) <> (DependencyMap b) = + DependencyMap (Map.unionWith intersectVersionRangesAndJoinComponents a b) + +intersectVersionRangesAndJoinComponents :: (VersionRange, NonEmptySet LibraryName) + -> (VersionRange, NonEmptySet LibraryName) + -> (VersionRange, NonEmptySet LibraryName) +intersectVersionRangesAndJoinComponents (va, ca) (vb, cb) = + (intersectVersionRanges va vb, ca <> cb) + +toDepMap :: [Dependency] -> DependencyMap +toDepMap ds = + DependencyMap $ Map.fromListWith intersectVersionRangesAndJoinComponents [ (p,(vr,cs)) | Dependency p vr cs <- ds ] + +fromDepMap :: DependencyMap -> [Dependency] +fromDepMap m = [ Dependency p vr cs | (p,(vr,cs)) <- Map.toList (unDependencyMap m) ] + +-- Apply extra constraints to a dependency map. +-- Combines dependencies where the result will only contain keys from the left +-- (first) map. If a key also exists in the right map, both constraints will +-- be intersected. +constrainBy + :: DependencyMap + -> [PackageVersionConstraint] + -> DependencyMap +constrainBy = foldl' tightenConstraint where + tightenConstraint (DependencyMap l) (PackageVersionConstraint pn vr) = DependencyMap $ + case Map.lookup pn l of + Nothing -> l + Just (vr', cs) -> Map.insert pn (intersectVersionRanges vr' vr, cs) l diff --git a/cabal/Cabal-syntax/src/Distribution/Types/ExeDependency.hs b/cabal/Cabal-syntax/src/Distribution/Types/ExeDependency.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/ExeDependency.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Types.ExeDependency + ( ExeDependency(..) + , qualifiedExeName + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Parsec +import Distribution.Pretty +import Distribution.Types.ComponentName +import Distribution.Types.PackageName +import Distribution.Types.UnqualComponentName +import Distribution.Version (VersionRange, anyVersion, isAnyVersion) + +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as PP + +-- | Describes a dependency on an executable from a package +-- +data ExeDependency = ExeDependency + PackageName + UnqualComponentName -- name of executable component of package + VersionRange + deriving (Generic, Read, Show, Eq, Typeable, Data) + +instance Binary ExeDependency +instance Structured ExeDependency +instance NFData ExeDependency where rnf = genericRnf + +instance Pretty ExeDependency where + pretty (ExeDependency name exe ver) = + pretty name <<>> PP.colon <<>> pretty exe PP.<+> pver + where + pver | isAnyVersion ver = PP.empty + | otherwise = pretty ver + +-- | +-- +-- Examples +-- +-- >>> simpleParsec "happy:happy" :: Maybe ExeDependency +-- Just (ExeDependency (PackageName "happy") (UnqualComponentName "happy") (OrLaterVersion (mkVersion [0]))) +-- +-- >>> simpleParsec "happy:happy >= 1.19.12" :: Maybe ExeDependency +-- Just (ExeDependency (PackageName "happy") (UnqualComponentName "happy") (OrLaterVersion (mkVersion [1,19,12]))) +-- +-- >>> simpleParsec "happy:happy>=1.19.12" :: Maybe ExeDependency +-- Just (ExeDependency (PackageName "happy") (UnqualComponentName "happy") (OrLaterVersion (mkVersion [1,19,12]))) +-- +-- >>> simpleParsec "happy : happy >= 1.19.12" :: Maybe ExeDependency +-- Nothing +-- +-- >>> simpleParsec "happy: happy >= 1.19.12" :: Maybe ExeDependency +-- Nothing +-- +-- >>> simpleParsec "happy :happy >= 1.19.12" :: Maybe ExeDependency +-- Nothing +-- +instance Parsec ExeDependency where + parsec = do + name <- parsec + _ <- P.char ':' + exe <- lexemeParsec + ver <- parsec <|> pure anyVersion + return (ExeDependency name exe ver) + +qualifiedExeName :: ExeDependency -> ComponentName +qualifiedExeName (ExeDependency _ ucn _) = CExeName ucn diff --git a/cabal/Cabal-syntax/src/Distribution/Types/Executable.hs b/cabal/Cabal-syntax/src/Distribution/Types/Executable.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/Executable.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NoMonoLocalBinds #-} + +module Distribution.Types.Executable ( + Executable(..), + emptyExecutable, + exeModules, + exeModulesAutogen +) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Types.BuildInfo +import Distribution.Types.UnqualComponentName +import Distribution.Types.ExecutableScope +import Distribution.ModuleName + +import qualified Distribution.Types.BuildInfo.Lens as L + +data Executable = Executable { + exeName :: UnqualComponentName, + modulePath :: FilePath, + exeScope :: ExecutableScope, + buildInfo :: BuildInfo + } + deriving (Generic, Show, Read, Eq, Typeable, Data) + +instance L.HasBuildInfo Executable where + buildInfo f l = (\x -> l { buildInfo = x }) <$> f (buildInfo l) + +instance Binary Executable +instance Structured Executable +instance NFData Executable where rnf = genericRnf + +instance Monoid Executable where + mempty = gmempty + mappend = (<>) + +instance Semigroup Executable where + a <> b = Executable{ + exeName = combine' exeName, + modulePath = combine modulePath, + exeScope = combine exeScope, + buildInfo = combine buildInfo + } + where combine field = field a `mappend` field b + combine' field = case ( unUnqualComponentName $ field a + , unUnqualComponentName $ field b) of + ("", _) -> field b + (_, "") -> field a + (x, y) -> error $ "Ambiguous values for executable field: '" + ++ x ++ "' and '" ++ y ++ "'" + +emptyExecutable :: Executable +emptyExecutable = mempty + +-- | Get all the module names from an exe +exeModules :: Executable -> [ModuleName] +exeModules exe = otherModules (buildInfo exe) + +-- | Get all the auto generated module names from an exe +-- This are a subset of 'exeModules'. +exeModulesAutogen :: Executable -> [ModuleName] +exeModulesAutogen exe = autogenModules (buildInfo exe) diff --git a/cabal/Cabal-syntax/src/Distribution/Types/Executable/Lens.hs b/cabal/Cabal-syntax/src/Distribution/Types/Executable/Lens.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/Executable/Lens.hs @@ -0,0 +1,31 @@ +module Distribution.Types.Executable.Lens ( + Executable, + module Distribution.Types.Executable.Lens, + ) where + +import Distribution.Compat.Lens +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Types.BuildInfo (BuildInfo) +import Distribution.Types.Executable (Executable) +import Distribution.Types.ExecutableScope (ExecutableScope) +import Distribution.Types.UnqualComponentName (UnqualComponentName) + +import qualified Distribution.Types.Executable as T + +exeName :: Lens' Executable UnqualComponentName +exeName f s = fmap (\x -> s { T.exeName = x }) (f (T.exeName s)) +{-# INLINE exeName #-} + +modulePath :: Lens' Executable String +modulePath f s = fmap (\x -> s { T.modulePath = x }) (f (T.modulePath s)) +{-# INLINE modulePath #-} + +exeScope :: Lens' Executable ExecutableScope +exeScope f s = fmap (\x -> s { T.exeScope = x }) (f (T.exeScope s)) +{-# INLINE exeScope #-} + +exeBuildInfo :: Lens' Executable BuildInfo +exeBuildInfo f s = fmap (\x -> s { T.buildInfo = x }) (f (T.buildInfo s)) +{-# INLINE exeBuildInfo #-} diff --git a/cabal/Cabal-syntax/src/Distribution/Types/ExecutableScope.hs b/cabal/Cabal-syntax/src/Distribution/Types/ExecutableScope.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/ExecutableScope.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module Distribution.Types.ExecutableScope ( + ExecutableScope(..), +) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Pretty +import Distribution.Parsec + +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as Disp + +data ExecutableScope = ExecutablePublic + | ExecutablePrivate + deriving (Generic, Show, Read, Eq, Typeable, Data) + +instance Pretty ExecutableScope where + pretty ExecutablePublic = Disp.text "public" + pretty ExecutablePrivate = Disp.text "private" + +instance Parsec ExecutableScope where + parsec = P.try pub <|> pri where + pub = ExecutablePublic <$ P.string "public" + pri = ExecutablePrivate <$ P.string "private" + +instance Binary ExecutableScope +instance Structured ExecutableScope +instance NFData ExecutableScope where rnf = genericRnf + +-- | 'Any' like semigroup, where 'ExecutablePrivate' is 'Any True' +instance Semigroup ExecutableScope where + ExecutablePublic <> x = x + x@ExecutablePrivate <> _ = x + +-- | 'mempty' = 'ExecutablePublic' +instance Monoid ExecutableScope where + mempty = ExecutablePublic + mappend = (<>) diff --git a/cabal/Cabal-syntax/src/Distribution/Types/ExposedModule.hs b/cabal/Cabal-syntax/src/Distribution/Types/ExposedModule.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/ExposedModule.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Types.ExposedModule where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Backpack +import Distribution.ModuleName +import Distribution.Parsec +import Distribution.Pretty + +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as Disp + +data ExposedModule + = ExposedModule { + exposedName :: ModuleName, + exposedReexport :: Maybe OpenModule + } + deriving (Eq, Generic, Read, Show, Typeable) + +instance Pretty ExposedModule where + pretty (ExposedModule m reexport) = + Disp.hsep [ pretty m + , case reexport of + Just m' -> Disp.hsep [Disp.text "from", pretty m'] + Nothing -> Disp.empty + ] + +instance Parsec ExposedModule where + parsec = do + m <- parsecMaybeQuoted parsec + P.spaces + + reexport <- P.optional $ do + _ <- P.string "from" + P.skipSpaces1 + parsec + + return (ExposedModule m reexport) + +instance Binary ExposedModule +instance Structured ExposedModule +instance NFData ExposedModule where rnf = genericRnf diff --git a/cabal/Cabal-syntax/src/Distribution/Types/Flag.hs b/cabal/Cabal-syntax/src/Distribution/Types/Flag.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/Flag.hs @@ -0,0 +1,369 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Distribution.Types.Flag ( + -- * Package flag + PackageFlag(..), + emptyFlag, + -- * Flag name + FlagName, + mkFlagName, + unFlagName, + -- * Flag assignment + FlagAssignment, + mkFlagAssignment, + unFlagAssignment, + lookupFlagAssignment, + insertFlagAssignment, + diffFlagAssignment, + findDuplicateFlagAssignments, + nullFlagAssignment, + showFlagValue, + dispFlagAssignment, + showFlagAssignment, + parsecFlagAssignment, + parsecFlagAssignmentNonEmpty, + -- ** Legacy formats + legacyShowFlagAssignment, + legacyShowFlagAssignment', + legacyParsecFlagAssignment, + ) where + +import Prelude () +import Distribution.Compat.Prelude +import Distribution.Utils.ShortText +import Distribution.Utils.Generic (lowercase) + +import Distribution.Parsec +import Distribution.Pretty + +import qualified Data.Map as Map +import qualified Text.PrettyPrint as Disp +import qualified Distribution.Compat.CharParsing as P + +-- ----------------------------------------------------------------------------- +-- The Flag' type + +-- | A flag can represent a feature to be included, or a way of linking +-- a target against its dependencies, or in fact whatever you can think of. +data PackageFlag = MkPackageFlag + { flagName :: FlagName + , flagDescription :: String + , flagDefault :: Bool + , flagManual :: Bool + } + deriving (Show, Eq, Typeable, Data, Generic) + +instance Binary PackageFlag +instance Structured PackageFlag +instance NFData PackageFlag where rnf = genericRnf + +-- | A 'PackageFlag' initialized with default parameters. +emptyFlag :: FlagName -> PackageFlag +emptyFlag name = MkPackageFlag + { flagName = name + , flagDescription = "" + , flagDefault = True + , flagManual = False + } + +-- | A 'FlagName' is the name of a user-defined configuration flag +-- +-- Use 'mkFlagName' and 'unFlagName' to convert from/to a 'String'. +-- +-- This type is opaque since @Cabal-2.0@ +-- +-- @since 2.0.0.2 +newtype FlagName = FlagName ShortText + deriving (Eq, Generic, Ord, Show, Read, Typeable, Data, NFData) + +-- | Construct a 'FlagName' from a 'String' +-- +-- 'mkFlagName' is the inverse to 'unFlagName' +-- +-- Note: No validations are performed to ensure that the resulting +-- 'FlagName' is valid +-- +-- @since 2.0.0.2 +mkFlagName :: String -> FlagName +mkFlagName = FlagName . toShortText + +-- | 'mkFlagName' +-- +-- @since 2.0.0.2 +instance IsString FlagName where + fromString = mkFlagName + +-- | Convert 'FlagName' to 'String' +-- +-- @since 2.0.0.2 +unFlagName :: FlagName -> String +unFlagName (FlagName s) = fromShortText s + +instance Binary FlagName +instance Structured FlagName + +instance Pretty FlagName where + pretty = Disp.text . unFlagName + +instance Parsec FlagName where + -- Note: we don't check that FlagName doesn't have leading dash, + -- cabal check will do that. + parsec = mkFlagName . lowercase <$> parsec' + where + parsec' = (:) <$> lead <*> rest + lead = P.satisfy (\c -> isAlphaNum c || c == '_') + rest = P.munch (\c -> isAlphaNum c || c == '_' || c == '-') + +-- | A 'FlagAssignment' is a total or partial mapping of 'FlagName's to +-- 'Bool' flag values. It represents the flags chosen by the user or +-- discovered during configuration. For example @--flags=foo --flags=-bar@ +-- becomes @[("foo", True), ("bar", False)]@ +-- +-- TODO: Why we record the multiplicity of the flag? +-- +newtype FlagAssignment + = FlagAssignment { getFlagAssignment :: Map.Map FlagName (Int, Bool) } + deriving (Binary, Generic, NFData, Typeable) + +instance Structured FlagAssignment + +instance Eq FlagAssignment where + (==) (FlagAssignment m1) (FlagAssignment m2) + = fmap snd m1 == fmap snd m2 + +instance Ord FlagAssignment where + compare (FlagAssignment m1) (FlagAssignment m2) + = fmap snd m1 `compare` fmap snd m2 + +-- | Combines pairs of values contained in the 'FlagAssignment' Map. +-- +-- The last flag specified takes precedence, and we record the number +-- of times we have seen the flag. +-- +combineFlagValues :: (Int, Bool) -> (Int, Bool) -> (Int, Bool) +combineFlagValues (c1, _) (c2, b2) = (c1 + c2, b2) + +-- The 'Semigroup' instance currently is right-biased. +-- +-- If duplicate flags are specified, we want the last flag specified to +-- take precedence and we want to know how many times the flag has been +-- specified so that we have the option of warning the user about +-- supplying duplicate flags. +instance Semigroup FlagAssignment where + (<>) (FlagAssignment m1) (FlagAssignment m2) + = FlagAssignment (Map.unionWith combineFlagValues m1 m2) + +instance Monoid FlagAssignment where + mempty = FlagAssignment Map.empty + mappend = (<>) + +-- | Construct a 'FlagAssignment' from a list of flag/value pairs. +-- +-- If duplicate flags occur in the input list, the later entries +-- in the list will take precedence. +-- +-- @since 2.2.0 +mkFlagAssignment :: [(FlagName, Bool)] -> FlagAssignment +mkFlagAssignment = + FlagAssignment . + Map.fromListWith (flip combineFlagValues) . fmap (fmap (\b -> (1, b))) + +-- | Deconstruct a 'FlagAssignment' into a list of flag/value pairs. +-- +-- @ 'null' ('findDuplicateFlagAssignments' fa) ==> ('mkFlagAssignment' . 'unFlagAssignment') fa == fa @ +-- +-- @since 2.2.0 +unFlagAssignment :: FlagAssignment -> [(FlagName, Bool)] +unFlagAssignment = fmap (fmap snd) . Map.toList . getFlagAssignment + +-- | Test whether 'FlagAssignment' is empty. +-- +-- @since 2.2.0 +nullFlagAssignment :: FlagAssignment -> Bool +nullFlagAssignment = Map.null . getFlagAssignment + +-- | Lookup the value for a flag +-- +-- Returns 'Nothing' if the flag isn't contained in the 'FlagAssignment'. +-- +-- @since 2.2.0 +lookupFlagAssignment :: FlagName -> FlagAssignment -> Maybe Bool +lookupFlagAssignment fn = fmap snd . Map.lookup fn . getFlagAssignment + +-- | Insert or update the boolean value of a flag. +-- +-- If the flag is already present in the 'FlagAssigment', the +-- value will be updated and the fact that multiple values have +-- been provided for that flag will be recorded so that a +-- warning can be generated later on. +-- +-- @since 2.2.0 +insertFlagAssignment :: FlagName -> Bool -> FlagAssignment -> FlagAssignment +-- TODO: this currently just shadows prior values for an existing +-- flag; rather than enforcing uniqueness at construction, it's +-- verified later on via `D.C.Dependency.configuredPackageProblems` +insertFlagAssignment flag val = + FlagAssignment . + Map.insertWith (flip combineFlagValues) flag (1, val) . getFlagAssignment + +-- | Remove all flag-assignments from the first 'FlagAssignment' that +-- are contained in the second 'FlagAssignment' +-- +-- NB/TODO: This currently only removes flag assignments which also +-- match the value assignment! We should review the code which uses +-- this operation to figure out if this it's not enough to only +-- compare the flagnames without the values. +-- +-- @since 2.2.0 +diffFlagAssignment :: FlagAssignment -> FlagAssignment -> FlagAssignment +diffFlagAssignment fa1 fa2 = FlagAssignment + (Map.difference (getFlagAssignment fa1) (getFlagAssignment fa2)) + +-- | Find the 'FlagName's that have been listed more than once. +-- +-- @since 2.2.0 +findDuplicateFlagAssignments :: FlagAssignment -> [FlagName] +findDuplicateFlagAssignments = + Map.keys . Map.filter ((> 1) . fst) . getFlagAssignment + +-- | @since 2.2.0 +instance Read FlagAssignment where + readsPrec p s = [ (FlagAssignment x, rest) | (x,rest) <- readsPrec p s ] + +-- | @since 2.2.0 +instance Show FlagAssignment where + showsPrec p (FlagAssignment xs) = showsPrec p xs + +-- | String representation of a flag-value pair. +showFlagValue :: (FlagName, Bool) -> String +showFlagValue (f, True) = '+' : unFlagName f +showFlagValue (f, False) = '-' : unFlagName f + +-- | @since 3.4.0.0 +instance Pretty FlagAssignment where + pretty = dispFlagAssignment + +-- | +-- +-- >>> simpleParsec "" :: Maybe FlagAssignment +-- Just (fromList []) +-- +-- >>> simpleParsec "+foo -bar" :: Maybe FlagAssignment +-- Just (fromList [(FlagName "bar",(1,False)),(FlagName "foo",(1,True))]) +-- +-- >>> simpleParsec "-none -any" :: Maybe FlagAssignment +-- Just (fromList [(FlagName "any",(1,False)),(FlagName "none",(1,False))]) +-- +-- >>> simpleParsec "+foo -foo +foo +foo" :: Maybe FlagAssignment +-- Just (fromList [(FlagName "foo",(4,True))]) +-- +-- >>> simpleParsec "+foo -bar baz" :: Maybe FlagAssignment +-- Nothing +-- +-- Issue #7279 was fixed in Cabal-3.8 +-- +-- >>> explicitEitherParsec (parsecCommaList parsec) "+foo , -bar" :: Either String [FlagAssignment] +-- Right [fromList [(FlagName "foo",(1,True))],fromList [(FlagName "bar",(1,False))]] +-- +-- >>> explicitEitherParsec (parsecCommaList parsecFlagAssignmentNonEmpty) "+foo , -bar" :: Either String [FlagAssignment] +-- Right [fromList [(FlagName "foo",(1,True))],fromList [(FlagName "bar",(1,False))]] +-- +-- >>> simpleParsec "+foo+foo" :: Maybe FlagAssignment +-- Nothing +-- +-- @since 3.4.0.0 +-- +instance Parsec FlagAssignment where + parsec = parsecFlagAssignment + +-- | Pretty-prints a flag assignment. +dispFlagAssignment :: FlagAssignment -> Disp.Doc +dispFlagAssignment = Disp.hsep . map (Disp.text . showFlagValue) . unFlagAssignment + + + +-- | Parses a flag assignment. +parsecFlagAssignment :: CabalParsing m => m FlagAssignment +parsecFlagAssignment = mkFlagAssignment <$> sepByEnding (onFlag <|> offFlag) P.skipSpaces1 + where + onFlag = do + _ <- P.char '+' + f <- parsec + return (f, True) + offFlag = do + _ <- P.char '-' + f <- parsec + return (f, False) + + sepByEnding :: CabalParsing m => m a -> m b -> m [a] + sepByEnding p sep = afterSeparator where + element = (:) <$> p <*> afterElement + afterElement = sep *> afterSeparator <|> pure [] + afterSeparator = element <|> pure [] + +-- | Parse a non-empty flag assignment +-- +-- The flags have to explicitly start with minus or plus. +-- +-- @since 3.4.0.0 +parsecFlagAssignmentNonEmpty :: CabalParsing m => m FlagAssignment +parsecFlagAssignmentNonEmpty = mkFlagAssignment <$> sepByEnding1 (onFlag <|> offFlag) P.skipSpaces1 + where + onFlag = do + _ <- P.char '+' + f <- parsec + return (f, True) + offFlag = do + _ <- P.char '-' + f <- parsec + return (f, False) + + sepByEnding1 :: CabalParsing m => m a -> m b -> m [a] + sepByEnding1 p sep = element where + element = (:) <$> p <*> afterElement + afterElement = sep *> afterSeparator <|> pure [] + afterSeparator = element <|> pure [] + +-- | Show flag assignment. +-- +-- @since 3.4.0.0 +showFlagAssignment :: FlagAssignment -> String +showFlagAssignment = prettyShow . dispFlagAssignment + +------------------------------------------------------------------------------- +-- Legacy: without requiring + +------------------------------------------------------------------------------- + +-- | We need this as far as we support custom setups older than 2.2.0.0 +-- +-- @since 3.4.0.0 +legacyShowFlagAssignment :: FlagAssignment -> String +legacyShowFlagAssignment = + prettyShow . Disp.hsep . map Disp.text . legacyShowFlagAssignment' + +-- | @since 3.4.0.0 +legacyShowFlagAssignment' :: FlagAssignment -> [String] +legacyShowFlagAssignment' = map legacyShowFlagValue . unFlagAssignment + +-- | @since 3.4.0.0 +legacyShowFlagValue :: (FlagName, Bool) -> String +legacyShowFlagValue (f, True) = unFlagName f +legacyShowFlagValue (f, False) = '-' : unFlagName f + +-- | +-- We need this as far as we support custom setups older than 2.2.0.0 +-- +-- @since 3.4.0.0 +legacyParsecFlagAssignment :: CabalParsing m => m FlagAssignment +legacyParsecFlagAssignment = mkFlagAssignment <$> + P.sepBy (onFlag <|> offFlag) P.skipSpaces1 + where + onFlag = do + _ <- P.optional (P.char '+') + f <- parsec + return (f, True) + offFlag = do + _ <- P.char '-' + f <- parsec + return (f, False) diff --git a/cabal/Cabal-syntax/src/Distribution/Types/ForeignLib.hs b/cabal/Cabal-syntax/src/Distribution/Types/ForeignLib.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/ForeignLib.hs @@ -0,0 +1,200 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NoMonoLocalBinds #-} + +module Distribution.Types.ForeignLib( + ForeignLib(..), + emptyForeignLib, + foreignLibModules, + foreignLibIsShared, + foreignLibVersion, + + LibVersionInfo, + mkLibVersionInfo, + libVersionInfoCRA, + libVersionNumber, + libVersionNumberShow, + libVersionMajor +) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.ModuleName +import Distribution.Parsec +import Distribution.Pretty +import Distribution.System +import Distribution.Types.BuildInfo +import Distribution.Types.ForeignLibOption +import Distribution.Types.ForeignLibType +import Distribution.Types.UnqualComponentName +import Distribution.Version + +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as Disp +import qualified Text.Read as Read + +import qualified Distribution.Types.BuildInfo.Lens as L + +-- | A foreign library stanza is like a library stanza, except that +-- the built code is intended for consumption by a non-Haskell client. +data ForeignLib = ForeignLib { + -- | Name of the foreign library + foreignLibName :: UnqualComponentName + -- | What kind of foreign library is this (static or dynamic). + , foreignLibType :: ForeignLibType + -- | What options apply to this foreign library (e.g., are we + -- merging in all foreign dependencies.) + , foreignLibOptions :: [ForeignLibOption] + -- | Build information for this foreign library. + , foreignLibBuildInfo :: BuildInfo + -- | Libtool-style version-info data to compute library version. + -- Refer to the libtool documentation on the + -- current:revision:age versioning scheme. + , foreignLibVersionInfo :: Maybe LibVersionInfo + -- | Linux library version + , foreignLibVersionLinux :: Maybe Version + + -- | (Windows-specific) module definition files + -- + -- This is a list rather than a maybe field so that we can flatten + -- the condition trees (for instance, when creating an sdist) + , foreignLibModDefFile :: [FilePath] + } + deriving (Generic, Show, Read, Eq, Typeable, Data) + +data LibVersionInfo = LibVersionInfo Int Int Int deriving (Data, Eq, Generic, Typeable) + +instance Ord LibVersionInfo where + LibVersionInfo c r _ `compare` LibVersionInfo c' r' _ = + case c `compare` c' of + EQ -> r `compare` r' + e -> e + +instance Show LibVersionInfo where + showsPrec d (LibVersionInfo c r a) = showParen (d > 10) + $ showString "mkLibVersionInfo " + . showsPrec 11 (c,r,a) + +instance Read LibVersionInfo where + readPrec = Read.parens $ do + Read.Ident "mkLibVersionInfo" <- Read.lexP + t <- Read.step Read.readPrec + return (mkLibVersionInfo t) + +instance Binary LibVersionInfo +instance Structured LibVersionInfo +instance NFData LibVersionInfo where rnf = genericRnf + +instance Pretty LibVersionInfo where + pretty (LibVersionInfo c r a) + = Disp.hcat $ Disp.punctuate (Disp.char ':') $ map Disp.int [c,r,a] + +instance Parsec LibVersionInfo where + parsec = do + c <- P.integral + (r, a) <- P.option (0,0) $ do + _ <- P.char ':' + r <- P.integral + a <- P.option 0 $ do + _ <- P.char ':' + P.integral + return (r,a) + return $ mkLibVersionInfo (c,r,a) + +-- | Construct 'LibVersionInfo' from @(current, revision, age)@ +-- numbers. +-- +-- For instance, @mkLibVersionInfo (3,0,0)@ constructs a +-- 'LibVersionInfo' representing the version-info @3:0:0@. +-- +-- All version components must be non-negative. +mkLibVersionInfo :: (Int, Int, Int) -> LibVersionInfo +mkLibVersionInfo (c,r,a) = LibVersionInfo c r a + +-- | From a given 'LibVersionInfo', extract the @(current, revision, +-- age)@ numbers. +libVersionInfoCRA :: LibVersionInfo -> (Int, Int, Int) +libVersionInfoCRA (LibVersionInfo c r a) = (c,r,a) + +-- | Given a version-info field, produce a @major.minor.build@ version +libVersionNumber :: LibVersionInfo -> (Int, Int, Int) +libVersionNumber (LibVersionInfo c r a) = (c-a , a , r) + +-- | Given a version-info field, return @"major.minor.build"@ as a +-- 'String' +libVersionNumberShow :: LibVersionInfo -> String +libVersionNumberShow v = + let (major, minor, build) = libVersionNumber v + in show major ++ "." ++ show minor ++ "." ++ show build + +-- | Return the @major@ version of a version-info field. +libVersionMajor :: LibVersionInfo -> Int +libVersionMajor (LibVersionInfo c _ a) = c-a + +instance L.HasBuildInfo ForeignLib where + buildInfo f l = (\x -> l { foreignLibBuildInfo = x }) <$> f (foreignLibBuildInfo l) + +instance Binary ForeignLib +instance Structured ForeignLib +instance NFData ForeignLib where rnf = genericRnf + +instance Semigroup ForeignLib where + a <> b = ForeignLib { + foreignLibName = combine' foreignLibName + , foreignLibType = combine foreignLibType + , foreignLibOptions = combine foreignLibOptions + , foreignLibBuildInfo = combine foreignLibBuildInfo + , foreignLibVersionInfo = combine'' foreignLibVersionInfo + , foreignLibVersionLinux = combine'' foreignLibVersionLinux + , foreignLibModDefFile = combine foreignLibModDefFile + } + where combine field = field a `mappend` field b + combine' field = case ( unUnqualComponentName $ field a + , unUnqualComponentName $ field b) of + ("", _) -> field b + (_, "") -> field a + (x, y) -> error $ "Ambiguous values for executable field: '" + ++ x ++ "' and '" ++ y ++ "'" + combine'' field = field b + +instance Monoid ForeignLib where + mempty = ForeignLib { + foreignLibName = mempty + , foreignLibType = ForeignLibTypeUnknown + , foreignLibOptions = [] + , foreignLibBuildInfo = mempty + , foreignLibVersionInfo = Nothing + , foreignLibVersionLinux = Nothing + , foreignLibModDefFile = [] + } + mappend = (<>) + +-- | An empty foreign library. +emptyForeignLib :: ForeignLib +emptyForeignLib = mempty + +-- | Modules defined by a foreign library. +foreignLibModules :: ForeignLib -> [ModuleName] +foreignLibModules = otherModules . foreignLibBuildInfo + +-- | Is the foreign library shared? +foreignLibIsShared :: ForeignLib -> Bool +foreignLibIsShared = foreignLibTypeIsShared . foreignLibType + +-- | Get a version number for a foreign library. +-- If we're on Linux, and a Linux version is specified, use that. +-- If we're on Linux, and libtool-style version-info is specified, translate +-- that field into appropriate version numbers. +-- Otherwise, this feature is unsupported so we don't return any version data. +foreignLibVersion :: ForeignLib -> OS -> [Int] +foreignLibVersion flib Linux = + case foreignLibVersionLinux flib of + Just v -> versionNumbers v + Nothing -> + case foreignLibVersionInfo flib of + Just v' -> + let (major, minor, build) = libVersionNumber v' + in [major, minor, build] + Nothing -> [] +foreignLibVersion _ _ = [] diff --git a/cabal/Cabal-syntax/src/Distribution/Types/ForeignLib/Lens.hs b/cabal/Cabal-syntax/src/Distribution/Types/ForeignLib/Lens.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/ForeignLib/Lens.hs @@ -0,0 +1,45 @@ +module Distribution.Types.ForeignLib.Lens ( + ForeignLib, + module Distribution.Types.ForeignLib.Lens, + ) where + +import Distribution.Compat.Lens +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Types.BuildInfo (BuildInfo) +import Distribution.Types.ForeignLib (ForeignLib, LibVersionInfo) +import Distribution.Types.ForeignLibOption (ForeignLibOption) +import Distribution.Types.ForeignLibType (ForeignLibType) +import Distribution.Types.UnqualComponentName (UnqualComponentName) +import Distribution.Version (Version) + +import qualified Distribution.Types.ForeignLib as T + +foreignLibName :: Lens' ForeignLib UnqualComponentName +foreignLibName f s = fmap (\x -> s { T.foreignLibName = x }) (f (T.foreignLibName s)) +{-# INLINE foreignLibName #-} + +foreignLibType :: Lens' ForeignLib ForeignLibType +foreignLibType f s = fmap (\x -> s { T.foreignLibType = x }) (f (T.foreignLibType s)) +{-# INLINE foreignLibType #-} + +foreignLibOptions :: Lens' ForeignLib [ForeignLibOption] +foreignLibOptions f s = fmap (\x -> s { T.foreignLibOptions = x }) (f (T.foreignLibOptions s)) +{-# INLINE foreignLibOptions #-} + +foreignLibBuildInfo :: Lens' ForeignLib BuildInfo +foreignLibBuildInfo f s = fmap (\x -> s { T.foreignLibBuildInfo = x }) (f (T.foreignLibBuildInfo s)) +{-# INLINE foreignLibBuildInfo #-} + +foreignLibVersionInfo :: Lens' ForeignLib (Maybe LibVersionInfo) +foreignLibVersionInfo f s = fmap (\x -> s { T.foreignLibVersionInfo = x }) (f (T.foreignLibVersionInfo s)) +{-# INLINE foreignLibVersionInfo #-} + +foreignLibVersionLinux :: Lens' ForeignLib (Maybe Version) +foreignLibVersionLinux f s = fmap (\x -> s { T.foreignLibVersionLinux = x }) (f (T.foreignLibVersionLinux s)) +{-# INLINE foreignLibVersionLinux #-} + +foreignLibModDefFile :: Lens' ForeignLib [FilePath] +foreignLibModDefFile f s = fmap (\x -> s { T.foreignLibModDefFile = x }) (f (T.foreignLibModDefFile s)) +{-# INLINE foreignLibModDefFile #-} diff --git a/cabal/Cabal-syntax/src/Distribution/Types/ForeignLibOption.hs b/cabal/Cabal-syntax/src/Distribution/Types/ForeignLibOption.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/ForeignLibOption.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module Distribution.Types.ForeignLibOption( + ForeignLibOption(..) +) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Pretty +import Distribution.Parsec + +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as Disp + +data ForeignLibOption = + -- | Merge in all dependent libraries (i.e., use + -- @ghc -shared -static@ rather than just record + -- the dependencies, ala @ghc -shared -dynamic@). + -- This option is compulsory on Windows and unsupported + -- on other platforms. + ForeignLibStandalone + deriving (Generic, Show, Read, Eq, Typeable, Data) + +instance Pretty ForeignLibOption where + pretty ForeignLibStandalone = Disp.text "standalone" + +instance Parsec ForeignLibOption where + parsec = do + name <- P.munch1 (\c -> isAlphaNum c || c == '-') + case name of + "standalone" -> return ForeignLibStandalone + _ -> fail "unrecognized foreign-library option" + +instance Binary ForeignLibOption +instance Structured ForeignLibOption +instance NFData ForeignLibOption where rnf = genericRnf diff --git a/cabal/Cabal-syntax/src/Distribution/Types/ForeignLibType.hs b/cabal/Cabal-syntax/src/Distribution/Types/ForeignLibType.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/ForeignLibType.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module Distribution.Types.ForeignLibType( + ForeignLibType(..), + knownForeignLibTypes, + foreignLibTypeIsShared, +) where + +import Prelude () +import Distribution.Compat.Prelude +import Distribution.PackageDescription.Utils + +import Distribution.Pretty +import Distribution.Parsec + +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as Disp + +-- | What kind of foreign library is to be built? +data ForeignLibType = + -- | A native shared library (@.so@ on Linux, @.dylib@ on OSX, or + -- @.dll@ on Windows). + ForeignLibNativeShared + -- | A native static library (not currently supported.) + | ForeignLibNativeStatic + -- TODO: Maybe this should record a string? + | ForeignLibTypeUnknown + deriving (Generic, Show, Read, Eq, Typeable, Data) + +instance Pretty ForeignLibType where + pretty ForeignLibNativeShared = Disp.text "native-shared" + pretty ForeignLibNativeStatic = Disp.text "native-static" + pretty ForeignLibTypeUnknown = Disp.text "unknown" + +instance Parsec ForeignLibType where + parsec = do + name <- P.munch1 (\c -> isAlphaNum c || c == '-') + return $ case name of + "native-shared" -> ForeignLibNativeShared + "native-static" -> ForeignLibNativeStatic + _ -> ForeignLibTypeUnknown + +instance Binary ForeignLibType +instance Structured ForeignLibType +instance NFData ForeignLibType where rnf = genericRnf + +instance Semigroup ForeignLibType where + ForeignLibTypeUnknown <> b = b + a <> ForeignLibTypeUnknown = a + _ <> _ = error "Ambiguous foreign library type" + +instance Monoid ForeignLibType where + mempty = ForeignLibTypeUnknown + mappend = (<>) + +knownForeignLibTypes :: [ForeignLibType] +knownForeignLibTypes = [ + ForeignLibNativeShared + , ForeignLibNativeStatic + ] + +foreignLibTypeIsShared :: ForeignLibType -> Bool +foreignLibTypeIsShared t = + case t of + ForeignLibNativeShared -> True + ForeignLibNativeStatic -> False + ForeignLibTypeUnknown -> cabalBug "Unknown foreign library type" diff --git a/cabal/Cabal-syntax/src/Distribution/Types/GenericPackageDescription.hs b/cabal/Cabal-syntax/src/Distribution/Types/GenericPackageDescription.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/GenericPackageDescription.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Distribution.Types.GenericPackageDescription ( + GenericPackageDescription(..), + emptyGenericPackageDescription, +) where + +import Prelude () +import Distribution.Compat.Prelude + +-- lens +import Distribution.Compat.Lens as L +import qualified Distribution.Types.BuildInfo.Lens as L + +import Distribution.Types.PackageDescription + +import Distribution.Types.Benchmark +import Distribution.Types.CondTree +import Distribution.Types.ConfVar +import Distribution.Types.Dependency +import Distribution.Types.Executable +import Distribution.Types.Flag +import Distribution.Types.ForeignLib +import Distribution.Types.Library +import Distribution.Types.TestSuite +import Distribution.Types.UnqualComponentName +import Distribution.Package +import Distribution.Version + +-- --------------------------------------------------------------------------- +-- The 'GenericPackageDescription' type + +data GenericPackageDescription = + GenericPackageDescription + { packageDescription :: PackageDescription + , gpdScannedVersion :: Maybe Version + -- ^ This is a version as specified in source. + -- We populate this field in index reading for dummy GPDs, + -- only when GPD reading failed, but scanning haven't. + -- + -- Cabal-the-library never produces GPDs with Just as gpdScannedVersion. + -- + -- Perfectly, PackageIndex should have sum type, so we don't need to + -- have dummy GPDs. + , genPackageFlags :: [PackageFlag] + , condLibrary :: Maybe (CondTree ConfVar [Dependency] Library) + , condSubLibraries :: [( UnqualComponentName + , CondTree ConfVar [Dependency] Library )] + , condForeignLibs :: [( UnqualComponentName + , CondTree ConfVar [Dependency] ForeignLib )] + , condExecutables :: [( UnqualComponentName + , CondTree ConfVar [Dependency] Executable )] + , condTestSuites :: [( UnqualComponentName + , CondTree ConfVar [Dependency] TestSuite )] + , condBenchmarks :: [( UnqualComponentName + , CondTree ConfVar [Dependency] Benchmark )] + } + deriving (Show, Eq, Typeable, Data, Generic) + +instance Package GenericPackageDescription where + packageId = packageId . packageDescription + +instance Binary GenericPackageDescription +instance Structured GenericPackageDescription +instance NFData GenericPackageDescription where rnf = genericRnf + +emptyGenericPackageDescription :: GenericPackageDescription +emptyGenericPackageDescription = GenericPackageDescription emptyPackageDescription Nothing [] Nothing [] [] [] [] [] + +-- ----------------------------------------------------------------------------- +-- Traversal Instances + +instance L.HasBuildInfos GenericPackageDescription where + traverseBuildInfos f (GenericPackageDescription p v a1 x1 x2 x3 x4 x5 x6) = + GenericPackageDescription + <$> L.traverseBuildInfos f p + <*> pure v + <*> pure a1 + <*> (traverse . traverseCondTreeBuildInfo) f x1 + <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x2 + <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x3 + <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x4 + <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x5 + <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x6 + where + +-- We use this traversal to keep [Dependency] field in CondTree up to date. +traverseCondTreeBuildInfo + :: forall f comp v. (Applicative f, L.HasBuildInfo comp) + => LensLike' f (CondTree v [Dependency] comp) L.BuildInfo +traverseCondTreeBuildInfo g = node where + mkCondNode :: comp -> [CondBranch v [Dependency] comp] -> CondTree v [Dependency] comp + mkCondNode comp branches = CondNode comp (view L.targetBuildDepends comp) branches + + node (CondNode comp _ branches) = mkCondNode + <$> L.buildInfo g comp + <*> traverse branch branches + + branch (CondBranch v x y) = CondBranch v + <$> node x + <*> traverse node y diff --git a/cabal/Cabal-syntax/src/Distribution/Types/GenericPackageDescription/Lens.hs b/cabal/Cabal-syntax/src/Distribution/Types/GenericPackageDescription/Lens.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/GenericPackageDescription/Lens.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE Rank2Types #-} +module Distribution.Types.GenericPackageDescription.Lens ( + GenericPackageDescription, + PackageFlag, + FlagName, + ConfVar (..), + module Distribution.Types.GenericPackageDescription.Lens, + ) where + +import Prelude() +import Distribution.Compat.Prelude +import Distribution.Compat.Lens + +import qualified Distribution.Types.GenericPackageDescription as T + +-- We import types from their packages, so we can remove unused imports +-- and have wider inter-module dependency graph +import Distribution.Types.CondTree (CondTree) +import Distribution.Types.Dependency (Dependency) +import Distribution.Types.Executable (Executable) +import Distribution.Types.PackageDescription (PackageDescription) +import Distribution.Types.Benchmark (Benchmark) +import Distribution.Types.ForeignLib (ForeignLib) +import Distribution.Types.GenericPackageDescription (GenericPackageDescription(GenericPackageDescription) ) +import Distribution.Types.Flag (PackageFlag(MkPackageFlag), FlagName) +import Distribution.Types.ConfVar (ConfVar (..)) +import Distribution.Types.Library (Library) +import Distribution.Types.TestSuite (TestSuite) +import Distribution.Types.UnqualComponentName (UnqualComponentName) +import Distribution.System (Arch, OS) +import Distribution.Compiler (CompilerFlavor) +import Distribution.Version (Version, VersionRange) + +------------------------------------------------------------------------------- +-- GenericPackageDescription +------------------------------------------------------------------------------- + +packageDescription :: Lens' GenericPackageDescription PackageDescription +packageDescription f s = fmap (\x -> s { T.packageDescription = x }) (f (T.packageDescription s)) +{-# INLINE packageDescription #-} + +gpdScannedVersion :: Lens' GenericPackageDescription (Maybe Version) +gpdScannedVersion f s = fmap (\x -> s { T.gpdScannedVersion = x }) (f (T.gpdScannedVersion s)) +{-# INLINE gpdScannedVersion #-} + +genPackageFlags :: Lens' GenericPackageDescription [PackageFlag] +genPackageFlags f s = fmap (\x -> s { T.genPackageFlags = x }) (f (T.genPackageFlags s)) +{-# INLINE genPackageFlags #-} + +condLibrary :: Lens' GenericPackageDescription (Maybe (CondTree ConfVar [Dependency] Library)) +condLibrary f s = fmap (\x -> s { T.condLibrary = x }) (f (T.condLibrary s)) +{-# INLINE condLibrary #-} + +condSubLibraries :: Lens' GenericPackageDescription [(UnqualComponentName,(CondTree ConfVar [Dependency] Library))] +condSubLibraries f s = fmap (\x -> s { T.condSubLibraries = x }) (f (T.condSubLibraries s)) +{-# INLINE condSubLibraries #-} + +condForeignLibs :: Lens' GenericPackageDescription [(UnqualComponentName,(CondTree ConfVar [Dependency] ForeignLib))] +condForeignLibs f s = fmap (\x -> s { T.condForeignLibs = x }) (f (T.condForeignLibs s)) +{-# INLINE condForeignLibs #-} + +condExecutables :: Lens' GenericPackageDescription [(UnqualComponentName,(CondTree ConfVar [Dependency] Executable))] +condExecutables f s = fmap (\x -> s { T.condExecutables = x }) (f (T.condExecutables s)) +{-# INLINE condExecutables #-} + +condTestSuites :: Lens' GenericPackageDescription [(UnqualComponentName,(CondTree ConfVar [Dependency] TestSuite))] +condTestSuites f s = fmap (\x -> s { T.condTestSuites = x }) (f (T.condTestSuites s)) +{-# INLINE condTestSuites #-} + +condBenchmarks :: Lens' GenericPackageDescription [(UnqualComponentName,(CondTree ConfVar [Dependency] Benchmark))] +condBenchmarks f s = fmap (\x -> s { T.condBenchmarks = x }) (f (T.condBenchmarks s)) +{-# INLINE condBenchmarks #-} + +allCondTrees + :: Applicative f + => (forall a. CondTree ConfVar [Dependency] a + -> f (CondTree ConfVar [Dependency] a)) + -> GenericPackageDescription + -> f GenericPackageDescription +allCondTrees f (GenericPackageDescription p v a1 x1 x2 x3 x4 x5 x6) = + GenericPackageDescription + <$> pure p + <*> pure v + <*> pure a1 + <*> traverse f x1 + <*> (traverse . _2) f x2 + <*> (traverse . _2) f x3 + <*> (traverse . _2) f x4 + <*> (traverse . _2) f x5 + <*> (traverse . _2) f x6 + + +------------------------------------------------------------------------------- +-- Flag +------------------------------------------------------------------------------- + +flagName :: Lens' PackageFlag FlagName +flagName f (MkPackageFlag x1 x2 x3 x4) = fmap (\y1 -> MkPackageFlag y1 x2 x3 x4) (f x1) +{-# INLINE flagName #-} + +flagDescription :: Lens' PackageFlag String +flagDescription f (MkPackageFlag x1 x2 x3 x4) = fmap (\y1 -> MkPackageFlag x1 y1 x3 x4) (f x2) +{-# INLINE flagDescription #-} + +flagDefault :: Lens' PackageFlag Bool +flagDefault f (MkPackageFlag x1 x2 x3 x4) = fmap (\y1 -> MkPackageFlag x1 x2 y1 x4) (f x3) +{-# INLINE flagDefault #-} + +flagManual :: Lens' PackageFlag Bool +flagManual f (MkPackageFlag x1 x2 x3 x4) = fmap (\y1 -> MkPackageFlag x1 x2 x3 y1) (f x4) +{-# INLINE flagManual #-} + +------------------------------------------------------------------------------- +-- ConfVar +------------------------------------------------------------------------------- + +_OS :: Traversal' ConfVar OS +_OS f (OS os) = OS <$> f os +_OS _ x = pure x + +_Arch :: Traversal' ConfVar Arch +_Arch f (Arch arch) = Arch <$> f arch +_Arch _ x = pure x + +_PackageFlag :: Traversal' ConfVar FlagName +_PackageFlag f (PackageFlag flag) = PackageFlag <$> f flag +_PackageFlag _ x = pure x + +_Impl :: Traversal' ConfVar (CompilerFlavor, VersionRange) +_Impl f (Impl cf vr) = uncurry Impl <$> f (cf, vr) +_Impl _ x = pure x diff --git a/cabal/Cabal-syntax/src/Distribution/Types/HookedBuildInfo.hs b/cabal/Cabal-syntax/src/Distribution/Types/HookedBuildInfo.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/HookedBuildInfo.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +module Distribution.Types.HookedBuildInfo ( + HookedBuildInfo, + emptyHookedBuildInfo, + ) where + +-- import Distribution.Compat.Prelude +import Distribution.Types.BuildInfo +import Distribution.Types.UnqualComponentName + +-- | 'HookedBuildInfo' is mechanism that hooks can use to +-- override the 'BuildInfo's inside packages. One example +-- use-case (which is used in core libraries today) is as +-- a way of passing flags which are computed by a configure +-- script into Cabal. In this case, the autoconf build type adds +-- hooks to read in a textual 'HookedBuildInfo' format prior +-- to doing any operations. +-- +-- Quite honestly, this mechanism is a massive hack since we shouldn't +-- be editing the 'PackageDescription' data structure (it's easy +-- to assume that this data structure shouldn't change and +-- run into bugs, see for example 1c20a6328579af9e37677d507e2e9836ef70ab9d). +-- But it's a bit convenient, because there isn't another data +-- structure that allows adding extra 'BuildInfo' style things. +-- +-- In any case, a lot of care has to be taken to make sure the +-- 'HookedBuildInfo' is applied to the 'PackageDescription'. In +-- general this process occurs in "Distribution.Simple", which is +-- responsible for orchestrating the hooks mechanism. The +-- general strategy: +-- +-- 1. We run the pre-hook, which produces a 'HookedBuildInfo' +-- (e.g., in the Autoconf case, it reads it out from a file). +-- 2. We sanity-check the hooked build info with +-- 'sanityCheckHookedBuildInfo'. +-- 3. We update our 'PackageDescription' (either freshly read +-- or cached from 'LocalBuildInfo') with 'updatePackageDescription'. +-- +-- In principle, we are also supposed to update the copy of +-- the 'PackageDescription' stored in 'LocalBuildInfo' +-- at 'localPkgDescr'. Unfortunately, in practice, there +-- are lots of Custom setup scripts which fail to update +-- 'localPkgDescr' so you really shouldn't rely on it. +-- It's not DEPRECATED because there are legitimate uses +-- for it, but... yeah. Sharp knife. See +-- +-- for more information on the issue. +-- +-- It is not well-specified whether or not a 'HookedBuildInfo' applied +-- at configure time is persistent to the 'LocalBuildInfo'. The +-- fact that 'HookedBuildInfo' is passed to 'confHook' MIGHT SUGGEST +-- that the 'HookedBuildInfo' is applied at this time, but actually +-- since 9317b67e6122ab14e53f81b573bd0ecb388eca5a it has been ONLY used +-- to create a modified package description that we check for problems: +-- it is never actually saved to the LBI. Since 'HookedBuildInfo' is +-- applied monoidally to the existing build infos (and it is not an +-- idempotent monoid), it could break things to save it, since we +-- are obligated to apply any new 'HookedBuildInfo' and then we'd +-- get the effect twice. But this does mean we have to re-apply +-- it every time. Hey, it's more flexibility. +type HookedBuildInfo = (Maybe BuildInfo, [(UnqualComponentName, BuildInfo)]) + +emptyHookedBuildInfo :: HookedBuildInfo +emptyHookedBuildInfo = (Nothing, []) diff --git a/cabal/Cabal-syntax/src/Distribution/Types/IncludeRenaming.hs b/cabal/Cabal-syntax/src/Distribution/Types/IncludeRenaming.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/IncludeRenaming.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +module Distribution.Types.IncludeRenaming ( + IncludeRenaming(..), + defaultIncludeRenaming, + isDefaultIncludeRenaming, +) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Types.ModuleRenaming + +import qualified Distribution.Compat.CharParsing as P +import Distribution.Parsec +import Distribution.Pretty +import Text.PrettyPrint (text) +import qualified Text.PrettyPrint as Disp + +-- --------------------------------------------------------------------------- +-- Module renaming + +-- | A renaming on an include: (provides renaming, requires renaming) +data IncludeRenaming + = IncludeRenaming { + includeProvidesRn :: ModuleRenaming, + includeRequiresRn :: ModuleRenaming + } + deriving (Show, Read, Eq, Ord, Typeable, Data, Generic) + +instance Binary IncludeRenaming +instance Structured IncludeRenaming + +instance NFData IncludeRenaming where rnf = genericRnf + +-- | The 'defaultIncludeRenaming' applied when you only @build-depends@ +-- on a package. +defaultIncludeRenaming :: IncludeRenaming +defaultIncludeRenaming = IncludeRenaming defaultRenaming defaultRenaming + +-- | Is an 'IncludeRenaming' the default one? +isDefaultIncludeRenaming :: IncludeRenaming -> Bool +isDefaultIncludeRenaming (IncludeRenaming p r) = isDefaultRenaming p && isDefaultRenaming r + +instance Pretty IncludeRenaming where + pretty (IncludeRenaming prov_rn req_rn) = + pretty prov_rn + <+> (if isDefaultRenaming req_rn + then Disp.empty + else text "requires" <+> pretty req_rn) + +instance Parsec IncludeRenaming where + parsec = do + prov_rn <- parsec + req_rn <- P.option defaultRenaming $ P.try $ do + P.spaces -- no need to be space + _ <- P.string "requires" + P.spaces + parsec + -- Requirements don't really care if they're mentioned + -- or not (since you can't thin a requirement.) But + -- we have a little hack in Configure to combine + -- the provisions and requirements together before passing + -- them to GHC, and so the most neutral choice for a requirement + -- is for the "with" field to be False, so we correctly + -- thin provisions. + return (IncludeRenaming prov_rn req_rn) diff --git a/cabal/Cabal-syntax/src/Distribution/Types/InstalledPackageInfo.hs b/cabal/Cabal-syntax/src/Distribution/Types/InstalledPackageInfo.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/InstalledPackageInfo.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +module Distribution.Types.InstalledPackageInfo ( + InstalledPackageInfo (..), + emptyInstalledPackageInfo, + mungedPackageId, + mungedPackageName, + AbiDependency (..), + ExposedModule (..), + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Backpack +import Distribution.Compat.Graph (IsNode (..)) +import Distribution.License +import Distribution.ModuleName +import Distribution.Package hiding (installedUnitId) +import Distribution.Types.AbiDependency +import Distribution.Types.ExposedModule +import Distribution.Types.LibraryName +import Distribution.Types.LibraryVisibility +import Distribution.Types.MungedPackageId +import Distribution.Types.MungedPackageName +import Distribution.Version (nullVersion) +import Distribution.Utils.ShortText (ShortText) + +import qualified Distribution.Package as Package +import qualified Distribution.SPDX as SPDX + +-- ----------------------------------------------------------------------------- +-- The InstalledPackageInfo type + +-- For BC reasons, we continue to name this record an InstalledPackageInfo; +-- but it would more accurately be called an InstalledUnitInfo with Backpack +data InstalledPackageInfo + = InstalledPackageInfo { + -- these parts (sourcePackageId, installedUnitId) are + -- exactly the same as PackageDescription + sourcePackageId :: PackageId, + sourceLibName :: LibraryName, + installedComponentId_ :: ComponentId, + libVisibility :: LibraryVisibility, + installedUnitId :: UnitId, + -- INVARIANT: if this package is definite, OpenModule's + -- OpenUnitId directly records UnitId. If it is + -- indefinite, OpenModule is always an OpenModuleVar + -- with the same ModuleName as the key. + instantiatedWith :: [(ModuleName, OpenModule)], + compatPackageKey :: String, + license :: Either SPDX.License License, + copyright :: !ShortText, + maintainer :: !ShortText, + author :: !ShortText, + stability :: !ShortText, + homepage :: !ShortText, + pkgUrl :: !ShortText, + synopsis :: !ShortText, + description :: !ShortText, + category :: !ShortText, + -- these parts are required by an installed package only: + abiHash :: AbiHash, + indefinite :: Bool, + exposed :: Bool, + -- INVARIANT: if the package is definite, OpenModule's + -- OpenUnitId directly records UnitId. + exposedModules :: [ExposedModule], + hiddenModules :: [ModuleName], + trusted :: Bool, + importDirs :: [FilePath], + libraryDirs :: [FilePath], + libraryDirsStatic :: [FilePath], + libraryDynDirs :: [FilePath], -- ^ overrides 'libraryDirs' + dataDir :: FilePath, + hsLibraries :: [String], + extraLibraries :: [String], + extraLibrariesStatic :: [String], + extraGHCiLibraries:: [String], -- overrides extraLibraries for GHCi + includeDirs :: [FilePath], + includes :: [String], + -- INVARIANT: if the package is definite, UnitId is NOT + -- a ComponentId of an indefinite package + depends :: [UnitId], + abiDepends :: [AbiDependency], + ccOptions :: [String], + cxxOptions :: [String], + ldOptions :: [String], + frameworkDirs :: [FilePath], + frameworks :: [String], + haddockInterfaces :: [FilePath], + haddockHTMLs :: [FilePath], + pkgRoot :: Maybe FilePath + } + deriving (Eq, Generic, Typeable, Read, Show) + +instance Binary InstalledPackageInfo +instance Structured InstalledPackageInfo + +instance NFData InstalledPackageInfo where rnf = genericRnf + +instance Package.HasMungedPackageId InstalledPackageInfo where + mungedId = mungedPackageId + +instance Package.Package InstalledPackageInfo where + packageId = sourcePackageId + +instance Package.HasUnitId InstalledPackageInfo where + installedUnitId = installedUnitId + +instance Package.PackageInstalled InstalledPackageInfo where + installedDepends = depends + +instance IsNode InstalledPackageInfo where + type Key InstalledPackageInfo = UnitId + nodeKey = installedUnitId + nodeNeighbors = depends + +mungedPackageId :: InstalledPackageInfo -> MungedPackageId +mungedPackageId ipi = + MungedPackageId (mungedPackageName ipi) (packageVersion ipi) + +-- | Returns the munged package name, which we write into @name@ for +-- compatibility with old versions of GHC. +mungedPackageName :: InstalledPackageInfo -> MungedPackageName +mungedPackageName ipi = MungedPackageName (packageName ipi) (sourceLibName ipi) + +emptyInstalledPackageInfo :: InstalledPackageInfo +emptyInstalledPackageInfo + = InstalledPackageInfo { + sourcePackageId = PackageIdentifier (mkPackageName "") nullVersion, + sourceLibName = LMainLibName, + installedComponentId_ = mkComponentId "", + installedUnitId = mkUnitId "", + instantiatedWith = [], + compatPackageKey = "", + license = Left SPDX.NONE, + copyright = "", + maintainer = "", + author = "", + stability = "", + homepage = "", + pkgUrl = "", + synopsis = "", + description = "", + category = "", + abiHash = mkAbiHash "", + indefinite = False, + exposed = False, + exposedModules = [], + hiddenModules = [], + trusted = False, + importDirs = [], + libraryDirs = [], + libraryDirsStatic = [], + libraryDynDirs = [], + dataDir = "", + hsLibraries = [], + extraLibraries = [], + extraLibrariesStatic = [], + extraGHCiLibraries= [], + includeDirs = [], + includes = [], + depends = [], + abiDepends = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + frameworkDirs = [], + frameworks = [], + haddockInterfaces = [], + haddockHTMLs = [], + pkgRoot = Nothing, + libVisibility = LibraryVisibilityPrivate + } diff --git a/cabal/Cabal-syntax/src/Distribution/Types/InstalledPackageInfo/FieldGrammar.hs b/cabal/Cabal-syntax/src/Distribution/Types/InstalledPackageInfo/FieldGrammar.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/InstalledPackageInfo/FieldGrammar.hs @@ -0,0 +1,319 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Distribution.Types.InstalledPackageInfo.FieldGrammar ( + ipiFieldGrammar, + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Backpack +import Distribution.CabalSpecVersion +import Distribution.Compat.Lens (Lens', (&), (.~)) +import Distribution.Compat.Newtype +import Distribution.FieldGrammar +import Distribution.FieldGrammar.FieldDescrs +import Distribution.License +import Distribution.ModuleName +import Distribution.Package +import Distribution.Parsec +import Distribution.Pretty +import Distribution.Types.LibraryName +import Distribution.Types.LibraryVisibility +import Distribution.Types.MungedPackageName +import Distribution.Types.UnqualComponentName +import Distribution.Version + +import qualified Data.Char as Char +import qualified Data.Map as Map +import qualified Distribution.Compat.CharParsing as P +import qualified Distribution.SPDX as SPDX +import qualified Text.PrettyPrint as Disp + +import Distribution.Types.InstalledPackageInfo + +import qualified Distribution.Types.InstalledPackageInfo.Lens as L +import qualified Distribution.Types.PackageId.Lens as L + +-- Note: GHC goes nuts and inlines everything, +-- One can see e.g. in -ddump-simpl-stats: +-- +-- 34886 KnownBranch +-- 8197 wild1_ixF0 +-- +-- https://gitlab.haskell.org/ghc/ghc/-/issues/13253 might be the cause. +-- +-- The workaround is to prevent GHC optimising the code: +infixl 4 <@> +(<@>) :: Applicative f => f (a -> b) -> f a -> f b +f <@> x = f <*> x +{-# NOINLINE (<@>) #-} + +ipiFieldGrammar + :: ( FieldGrammar c g, Applicative (g InstalledPackageInfo), Applicative (g Basic) + , c (Identity AbiHash) + , c (Identity LibraryVisibility) + , c (Identity PackageName) + , c (Identity UnitId) + , c (Identity UnqualComponentName) + , c (List FSep (Identity AbiDependency) AbiDependency) + , c (List FSep (Identity UnitId) UnitId) + , c (List FSep (MQuoted ModuleName) ModuleName) + , c (List FSep FilePathNT String) + , c (List FSep Token String) + , c (MQuoted MungedPackageName) + , c (MQuoted Version) + , c CompatPackageKey + , c ExposedModules + , c InstWith + , c SpecLicenseLenient + ) + => g InstalledPackageInfo InstalledPackageInfo +ipiFieldGrammar = mkInstalledPackageInfo + -- Deprecated fields + <$> monoidalFieldAla "hugs-options" (alaList' FSep Token) unitedList + --- https://github.com/haskell/cabal/commit/40f3601e17024f07e0da8e64d3dd390177ce908b + ^^^ deprecatedSince CabalSpecV1_22 "hugs isn't supported anymore" + -- Very basic fields: name, version, package-name, lib-name and visibility + <@> blurFieldGrammar basic basicFieldGrammar + -- Basic fields + <@> optionalFieldDef "id" L.installedUnitId (mkUnitId "") + <@> optionalFieldDefAla "instantiated-with" InstWith L.instantiatedWith [] + <@> optionalFieldDefAla "key" CompatPackageKey L.compatPackageKey "" + <@> optionalFieldDefAla "license" SpecLicenseLenient L.license (Left SPDX.NONE) + <@> freeTextFieldDefST "copyright" L.copyright + <@> freeTextFieldDefST "maintainer" L.maintainer + <@> freeTextFieldDefST "author" L.author + <@> freeTextFieldDefST "stability" L.stability + <@> freeTextFieldDefST "homepage" L.homepage + <@> freeTextFieldDefST "package-url" L.pkgUrl + <@> freeTextFieldDefST "synopsis" L.synopsis + <@> freeTextFieldDefST "description" L.description + <@> freeTextFieldDefST "category" L.category + -- Installed fields + <@> optionalFieldDef "abi" L.abiHash (mkAbiHash "") + <@> booleanFieldDef "indefinite" L.indefinite False + <@> booleanFieldDef "exposed" L.exposed False + <@> monoidalFieldAla "exposed-modules" ExposedModules L.exposedModules + <@> monoidalFieldAla "hidden-modules" (alaList' FSep MQuoted) L.hiddenModules + <@> booleanFieldDef "trusted" L.trusted False + <@> monoidalFieldAla "import-dirs" (alaList' FSep FilePathNT) L.importDirs + <@> monoidalFieldAla "library-dirs" (alaList' FSep FilePathNT) L.libraryDirs + <@> monoidalFieldAla "library-dirs-static" (alaList' FSep FilePathNT) L.libraryDirsStatic + <@> monoidalFieldAla "dynamic-library-dirs" (alaList' FSep FilePathNT) L.libraryDynDirs + <@> optionalFieldDefAla "data-dir" FilePathNT L.dataDir "" + <@> monoidalFieldAla "hs-libraries" (alaList' FSep Token) L.hsLibraries + <@> monoidalFieldAla "extra-libraries" (alaList' FSep Token) L.extraLibraries + <@> monoidalFieldAla "extra-libraries-static" (alaList' FSep Token) L.extraLibrariesStatic + <@> monoidalFieldAla "extra-ghci-libraries" (alaList' FSep Token) L.extraGHCiLibraries + <@> monoidalFieldAla "include-dirs" (alaList' FSep FilePathNT) L.includeDirs + <@> monoidalFieldAla "includes" (alaList' FSep FilePathNT) L.includes + <@> monoidalFieldAla "depends" (alaList FSep) L.depends + <@> monoidalFieldAla "abi-depends" (alaList FSep) L.abiDepends + <@> monoidalFieldAla "cc-options" (alaList' FSep Token) L.ccOptions + <@> monoidalFieldAla "cxx-options" (alaList' FSep Token) L.cxxOptions + <@> monoidalFieldAla "ld-options" (alaList' FSep Token) L.ldOptions + <@> monoidalFieldAla "framework-dirs" (alaList' FSep FilePathNT) L.frameworkDirs + <@> monoidalFieldAla "frameworks" (alaList' FSep Token) L.frameworks + <@> monoidalFieldAla "haddock-interfaces" (alaList' FSep FilePathNT) L.haddockInterfaces + <@> monoidalFieldAla "haddock-html" (alaList' FSep FilePathNT) L.haddockHTMLs + <@> optionalFieldAla "pkgroot" FilePathNT L.pkgRoot + where + mkInstalledPackageInfo _ Basic {..} = InstalledPackageInfo + -- _basicPkgName is not used + -- setMaybePackageId says it can be no-op. + (PackageIdentifier pn _basicVersion) + (combineLibraryName ln _basicLibName) + (mkComponentId "") -- installedComponentId_, not in use + _basicLibVisibility + where + MungedPackageName pn ln = _basicName +{-# SPECIALIZE ipiFieldGrammar :: FieldDescrs InstalledPackageInfo InstalledPackageInfo #-} +{-# SPECIALIZE ipiFieldGrammar :: ParsecFieldGrammar InstalledPackageInfo InstalledPackageInfo #-} +{-# SPECIALIZE ipiFieldGrammar :: PrettyFieldGrammar InstalledPackageInfo InstalledPackageInfo #-} + +-- (forall b. [b]) ~ () +unitedList :: Lens' a [b] +unitedList f s = s <$ f [] + +------------------------------------------------------------------------------- +-- Helper functions +------------------------------------------------------------------------------- + +-- | Combine 'LibraryName'. in parsing we prefer value coming +-- from munged @name@ field over the @lib-name@. +-- +-- /Should/ be irrelevant. +combineLibraryName :: LibraryName -> LibraryName -> LibraryName +combineLibraryName l@(LSubLibName _) _ = l +combineLibraryName _ l = l + +-- To maintain backwards-compatibility, we accept both comma/non-comma +-- separated variants of this field. You SHOULD use the comma syntax if you +-- use any new functions, although actually it's unambiguous due to a quirk +-- of the fact that modules must start with capital letters. + +showExposedModules :: [ExposedModule] -> Disp.Doc +showExposedModules xs + | all isExposedModule xs = Disp.fsep (map pretty xs) + | otherwise = Disp.fsep (Disp.punctuate Disp.comma (map pretty xs)) + where isExposedModule (ExposedModule _ Nothing) = True + isExposedModule _ = False + +-- | Setter for the @package-name@ field. It should be acceptable for this +-- to be a no-op. +setMaybePackageName :: Maybe PackageName -> InstalledPackageInfo -> InstalledPackageInfo +setMaybePackageName Nothing ipi = ipi +setMaybePackageName (Just pn) ipi = ipi + { sourcePackageId = (sourcePackageId ipi) {pkgName=pn} + } + +setMungedPackageName :: MungedPackageName -> InstalledPackageInfo -> InstalledPackageInfo +setMungedPackageName (MungedPackageName pn ln) ipi = ipi + { sourcePackageId = (sourcePackageId ipi) {pkgName=pn} + , sourceLibName = ln + } + +--- | Returns @Just@ if the @name@ field of the IPI record would not contain +--- the package name verbatim. This helps us avoid writing @package-name@ +--- when it's redundant. +maybePackageName :: InstalledPackageInfo -> Maybe PackageName +maybePackageName ipi = case sourceLibName ipi of + LMainLibName -> Nothing + LSubLibName _ -> Just (packageName ipi) + +------------------------------------------------------------------------------- +-- Auxiliary types +------------------------------------------------------------------------------- + +newtype ExposedModules = ExposedModules { getExposedModules :: [ExposedModule] } + +instance Newtype [ExposedModule] ExposedModules + +instance Parsec ExposedModules where + parsec = ExposedModules <$> parsecOptCommaList parsec + +instance Pretty ExposedModules where + pretty = showExposedModules . getExposedModules + +newtype CompatPackageKey = CompatPackageKey { getCompatPackageKey :: String } + +instance Newtype String CompatPackageKey + +instance Pretty CompatPackageKey where + pretty = Disp.text . getCompatPackageKey + +instance Parsec CompatPackageKey where + parsec = CompatPackageKey <$> P.munch1 uid_char where + uid_char c = Char.isAlphaNum c || c `elem` ("-_.=[],:<>+" :: String) + +newtype InstWith = InstWith { getInstWith :: [(ModuleName,OpenModule)] } + +instance Newtype [(ModuleName, OpenModule)] InstWith + +instance Pretty InstWith where + pretty = dispOpenModuleSubst . Map.fromList . getInstWith + +instance Parsec InstWith where + parsec = InstWith . Map.toList <$> parsecOpenModuleSubst + +-- | SPDX License expression or legacy license. Lenient parser, accepts either. +newtype SpecLicenseLenient = SpecLicenseLenient { getSpecLicenseLenient :: Either SPDX.License License } + +instance Newtype (Either SPDX.License License) SpecLicenseLenient + +instance Parsec SpecLicenseLenient where + parsec = fmap SpecLicenseLenient $ Left <$> P.try parsec <|> Right <$> parsec + +instance Pretty SpecLicenseLenient where + pretty = either pretty pretty . getSpecLicenseLenient + +------------------------------------------------------------------------------- +-- Basic fields +------------------------------------------------------------------------------- + +-- | This type is used to mangle fields as +-- in serialised textual representation +-- to the actual 'InstalledPackageInfo' fields. +data Basic = Basic + { _basicName :: MungedPackageName + , _basicVersion :: Version + , _basicPkgName :: Maybe PackageName + , _basicLibName :: LibraryName + , _basicLibVisibility :: LibraryVisibility + } + +basic :: Lens' InstalledPackageInfo Basic +basic f ipi = g <$> f b + where + b = Basic + (mungedPackageName ipi) + (packageVersion ipi) + (maybePackageName ipi) + (sourceLibName ipi) + (libVisibility ipi) + + g (Basic n v pn ln lv) = ipi + & setMungedPackageName n + & L.sourcePackageId . L.pkgVersion .~ v + & setMaybePackageName pn + & L.sourceLibName .~ ln + & L.libVisibility .~ lv + +basicName :: Lens' Basic MungedPackageName +basicName f b = (\x -> b { _basicName = x }) <$> f (_basicName b) +{-# INLINE basicName #-} + +basicVersion :: Lens' Basic Version +basicVersion f b = (\x -> b { _basicVersion = x }) <$> f (_basicVersion b) +{-# INLINE basicVersion #-} + +basicPkgName :: Lens' Basic (Maybe PackageName) +basicPkgName f b = (\x -> b { _basicPkgName = x }) <$> f (_basicPkgName b) +{-# INLINE basicPkgName #-} + +basicLibName :: Lens' Basic (Maybe UnqualComponentName) +basicLibName f b = (\x -> b { _basicLibName = maybeToLibraryName x }) <$> + f (libraryNameString (_basicLibName b)) +{-# INLINE basicLibName #-} + +basicLibVisibility :: Lens' Basic LibraryVisibility +basicLibVisibility f b = (\x -> b { _basicLibVisibility = x }) <$> + f (_basicLibVisibility b) +{-# INLINE basicLibVisibility #-} + +basicFieldGrammar + :: ( FieldGrammar c g, Applicative (g Basic) + , c (Identity LibraryVisibility) + , c (Identity PackageName) + , c (Identity UnqualComponentName) + , c (MQuoted MungedPackageName) + , c (MQuoted Version) + ) + => g Basic Basic +basicFieldGrammar = mkBasic + <$> optionalFieldDefAla "name" MQuoted basicName (mungedPackageName emptyInstalledPackageInfo) + <*> optionalFieldDefAla "version" MQuoted basicVersion nullVersion + <*> optionalField "package-name" basicPkgName + <*> optionalField "lib-name" basicLibName + <*> optionalFieldDef "visibility" basicLibVisibility LibraryVisibilityPrivate + where + mkBasic n v pn ln lv = Basic n v pn ln' lv' + where + ln' = maybe LMainLibName LSubLibName ln + -- Older GHCs (<8.8) always report installed libraries as private + -- because their ghc-pkg builds with an older Cabal. + -- So we always set LibraryVisibilityPublic for main (unnamed) libs. + -- This can be removed once we stop supporting GHC<8.8, at the + -- condition that we keep marking main libraries as public when + -- registering them. + lv' = if + let MungedPackageName _ mln = n in + -- We need to check both because on ghc<8.2 ln' will always + -- be LMainLibName + ln' == LMainLibName && mln == LMainLibName + then LibraryVisibilityPublic + else lv diff --git a/cabal/Cabal-syntax/src/Distribution/Types/InstalledPackageInfo/Lens.hs b/cabal/Cabal-syntax/src/Distribution/Types/InstalledPackageInfo/Lens.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/InstalledPackageInfo/Lens.hs @@ -0,0 +1,198 @@ +module Distribution.Types.InstalledPackageInfo.Lens ( + InstalledPackageInfo, + module Distribution.Types.InstalledPackageInfo.Lens + ) where + +import Distribution.Compat.Lens +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Backpack (OpenModule) +import Distribution.License (License) +import Distribution.ModuleName (ModuleName) +import Distribution.Package (AbiHash, ComponentId, PackageIdentifier, UnitId) +import Distribution.Types.InstalledPackageInfo (AbiDependency, ExposedModule, InstalledPackageInfo) +import Distribution.Types.LibraryName (LibraryName) +import Distribution.Types.LibraryVisibility (LibraryVisibility) +import Distribution.Utils.ShortText (ShortText) + + +import qualified Distribution.SPDX as SPDX +import qualified Distribution.Types.InstalledPackageInfo as T + +sourcePackageId :: Lens' InstalledPackageInfo PackageIdentifier +sourcePackageId f s = fmap (\x -> s { T.sourcePackageId = x }) (f (T.sourcePackageId s)) +{-# INLINE sourcePackageId #-} + +installedUnitId :: Lens' InstalledPackageInfo UnitId +installedUnitId f s = fmap (\x -> s { T.installedUnitId = x }) (f (T.installedUnitId s)) +{-# INLINE installedUnitId #-} + +installedComponentId_ :: Lens' InstalledPackageInfo ComponentId +installedComponentId_ f s = fmap (\x -> s { T.installedComponentId_ = x }) (f (T.installedComponentId_ s)) +{-# INLINE installedComponentId_ #-} + +instantiatedWith :: Lens' InstalledPackageInfo [(ModuleName,OpenModule)] +instantiatedWith f s = fmap (\x -> s { T.instantiatedWith = x }) (f (T.instantiatedWith s)) +{-# INLINE instantiatedWith #-} + +sourceLibName :: Lens' InstalledPackageInfo LibraryName +sourceLibName f s = fmap (\x -> s { T.sourceLibName = x }) (f (T.sourceLibName s)) +{-# INLINE sourceLibName #-} + +compatPackageKey :: Lens' InstalledPackageInfo String +compatPackageKey f s = fmap (\x -> s { T.compatPackageKey = x }) (f (T.compatPackageKey s)) +{-# INLINE compatPackageKey #-} + +license :: Lens' InstalledPackageInfo (Either SPDX.License License) +license f s = fmap (\x -> s { T.license = x }) (f (T.license s)) +{-# INLINE license #-} + +copyright :: Lens' InstalledPackageInfo ShortText +copyright f s = fmap (\x -> s { T.copyright = x }) (f (T.copyright s)) +{-# INLINE copyright #-} + +maintainer :: Lens' InstalledPackageInfo ShortText +maintainer f s = fmap (\x -> s { T.maintainer = x }) (f (T.maintainer s)) +{-# INLINE maintainer #-} + +author :: Lens' InstalledPackageInfo ShortText +author f s = fmap (\x -> s { T.author = x }) (f (T.author s)) +{-# INLINE author #-} + +stability :: Lens' InstalledPackageInfo ShortText +stability f s = fmap (\x -> s { T.stability = x }) (f (T.stability s)) +{-# INLINE stability #-} + +homepage :: Lens' InstalledPackageInfo ShortText +homepage f s = fmap (\x -> s { T.homepage = x }) (f (T.homepage s)) +{-# INLINE homepage #-} + +pkgUrl :: Lens' InstalledPackageInfo ShortText +pkgUrl f s = fmap (\x -> s { T.pkgUrl = x }) (f (T.pkgUrl s)) +{-# INLINE pkgUrl #-} + +synopsis :: Lens' InstalledPackageInfo ShortText +synopsis f s = fmap (\x -> s { T.synopsis = x }) (f (T.synopsis s)) +{-# INLINE synopsis #-} + +description :: Lens' InstalledPackageInfo ShortText +description f s = fmap (\x -> s { T.description = x }) (f (T.description s)) +{-# INLINE description #-} + +category :: Lens' InstalledPackageInfo ShortText +category f s = fmap (\x -> s { T.category = x }) (f (T.category s)) +{-# INLINE category #-} + +abiHash :: Lens' InstalledPackageInfo AbiHash +abiHash f s = fmap (\x -> s { T.abiHash = x }) (f (T.abiHash s)) +{-# INLINE abiHash #-} + +indefinite :: Lens' InstalledPackageInfo Bool +indefinite f s = fmap (\x -> s { T.indefinite = x }) (f (T.indefinite s)) +{-# INLINE indefinite #-} + +exposed :: Lens' InstalledPackageInfo Bool +exposed f s = fmap (\x -> s { T.exposed = x }) (f (T.exposed s)) +{-# INLINE exposed #-} + +exposedModules :: Lens' InstalledPackageInfo [ExposedModule] +exposedModules f s = fmap (\x -> s { T.exposedModules = x }) (f (T.exposedModules s)) +{-# INLINE exposedModules #-} + +hiddenModules :: Lens' InstalledPackageInfo [ModuleName] +hiddenModules f s = fmap (\x -> s { T.hiddenModules = x }) (f (T.hiddenModules s)) +{-# INLINE hiddenModules #-} + +trusted :: Lens' InstalledPackageInfo Bool +trusted f s = fmap (\x -> s { T.trusted = x }) (f (T.trusted s)) +{-# INLINE trusted #-} + +importDirs :: Lens' InstalledPackageInfo [FilePath] +importDirs f s = fmap (\x -> s { T.importDirs = x }) (f (T.importDirs s)) +{-# INLINE importDirs #-} + +libraryDirs :: Lens' InstalledPackageInfo [FilePath] +libraryDirs f s = fmap (\x -> s { T.libraryDirs = x }) (f (T.libraryDirs s)) +{-# INLINE libraryDirs #-} + +libraryDirsStatic :: Lens' InstalledPackageInfo [FilePath] +libraryDirsStatic f s = fmap (\x -> s { T.libraryDirsStatic = x }) (f (T.libraryDirsStatic s)) +{-# INLINE libraryDirsStatic #-} + +libraryDynDirs :: Lens' InstalledPackageInfo [FilePath] +libraryDynDirs f s = fmap (\x -> s { T.libraryDynDirs = x }) (f (T.libraryDynDirs s)) +{-# INLINE libraryDynDirs #-} + +dataDir :: Lens' InstalledPackageInfo FilePath +dataDir f s = fmap (\x -> s { T.dataDir = x }) (f (T.dataDir s)) +{-# INLINE dataDir #-} + +hsLibraries :: Lens' InstalledPackageInfo [String] +hsLibraries f s = fmap (\x -> s { T.hsLibraries = x }) (f (T.hsLibraries s)) +{-# INLINE hsLibraries #-} + +extraLibraries :: Lens' InstalledPackageInfo [String] +extraLibraries f s = fmap (\x -> s { T.extraLibraries = x }) (f (T.extraLibraries s)) +{-# INLINE extraLibraries #-} + +extraLibrariesStatic :: Lens' InstalledPackageInfo [String] +extraLibrariesStatic f s = fmap (\x -> s { T.extraLibrariesStatic = x }) (f (T.extraLibrariesStatic s)) +{-# INLINE extraLibrariesStatic #-} + +extraGHCiLibraries :: Lens' InstalledPackageInfo [String] +extraGHCiLibraries f s = fmap (\x -> s { T.extraGHCiLibraries = x }) (f (T.extraGHCiLibraries s)) +{-# INLINE extraGHCiLibraries #-} + +includeDirs :: Lens' InstalledPackageInfo [FilePath] +includeDirs f s = fmap (\x -> s { T.includeDirs = x }) (f (T.includeDirs s)) +{-# INLINE includeDirs #-} + +includes :: Lens' InstalledPackageInfo [String] +includes f s = fmap (\x -> s { T.includes = x }) (f (T.includes s)) +{-# INLINE includes #-} + +depends :: Lens' InstalledPackageInfo [UnitId] +depends f s = fmap (\x -> s { T.depends = x }) (f (T.depends s)) +{-# INLINE depends #-} + +abiDepends :: Lens' InstalledPackageInfo [AbiDependency] +abiDepends f s = fmap (\x -> s { T.abiDepends = x }) (f (T.abiDepends s)) +{-# INLINE abiDepends #-} + +ccOptions :: Lens' InstalledPackageInfo [String] +ccOptions f s = fmap (\x -> s { T.ccOptions = x }) (f (T.ccOptions s)) +{-# INLINE ccOptions #-} + +cxxOptions :: Lens' InstalledPackageInfo [String] +cxxOptions f s = fmap (\x -> s { T.cxxOptions = x }) (f (T.cxxOptions s)) +{-# INLINE cxxOptions #-} + +ldOptions :: Lens' InstalledPackageInfo [String] +ldOptions f s = fmap (\x -> s { T.ldOptions = x }) (f (T.ldOptions s)) +{-# INLINE ldOptions #-} + +frameworkDirs :: Lens' InstalledPackageInfo [FilePath] +frameworkDirs f s = fmap (\x -> s { T.frameworkDirs = x }) (f (T.frameworkDirs s)) +{-# INLINE frameworkDirs #-} + +frameworks :: Lens' InstalledPackageInfo [String] +frameworks f s = fmap (\x -> s { T.frameworks = x }) (f (T.frameworks s)) +{-# INLINE frameworks #-} + +haddockInterfaces :: Lens' InstalledPackageInfo [FilePath] +haddockInterfaces f s = fmap (\x -> s { T.haddockInterfaces = x }) (f (T.haddockInterfaces s)) +{-# INLINE haddockInterfaces #-} + +haddockHTMLs :: Lens' InstalledPackageInfo [FilePath] +haddockHTMLs f s = fmap (\x -> s { T.haddockHTMLs = x }) (f (T.haddockHTMLs s)) +{-# INLINE haddockHTMLs #-} + +pkgRoot :: Lens' InstalledPackageInfo (Maybe FilePath) +pkgRoot f s = fmap (\x -> s { T.pkgRoot = x }) (f (T.pkgRoot s)) +{-# INLINE pkgRoot #-} + +libVisibility :: Lens' InstalledPackageInfo LibraryVisibility +libVisibility f s = fmap (\x -> s { T.libVisibility = x }) (f (T.libVisibility s)) +{-# INLINE libVisibility #-} + diff --git a/cabal/Cabal-syntax/src/Distribution/Types/LegacyExeDependency.hs b/cabal/Cabal-syntax/src/Distribution/Types/LegacyExeDependency.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/LegacyExeDependency.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Types.LegacyExeDependency + ( LegacyExeDependency(..) + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Parsec +import Distribution.Pretty +import Distribution.Version (VersionRange, anyVersion) + +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as Disp + +-- | Describes a legacy `build-tools`-style dependency on an executable +-- +-- It is "legacy" because we do not know what the build-tool referred to. It +-- could refer to a pkg-config executable (PkgconfigName), or an internal +-- executable (UnqualComponentName). Thus the name is stringly typed. +-- +-- @since 2.0.0.2 +data LegacyExeDependency = LegacyExeDependency + String + VersionRange + deriving (Generic, Read, Show, Eq, Typeable, Data) + +instance Binary LegacyExeDependency +instance Structured LegacyExeDependency +instance NFData LegacyExeDependency where rnf = genericRnf + +instance Pretty LegacyExeDependency where + pretty (LegacyExeDependency name ver) = + Disp.text name <+> pretty ver + +instance Parsec LegacyExeDependency where + parsec = do + name <- parsecMaybeQuoted nameP + P.spaces + verRange <- parsecMaybeQuoted parsec <|> pure anyVersion + pure $ LegacyExeDependency name verRange + where + nameP = intercalate "-" <$> toList <$> P.sepByNonEmpty component (P.char '-') + component = do + cs <- P.munch1 (\c -> isAlphaNum c || c == '+' || c == '_') + if all isDigit cs then fail "invalid component" else return cs diff --git a/cabal/Cabal-syntax/src/Distribution/Types/Lens.hs b/cabal/Cabal-syntax/src/Distribution/Types/Lens.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/Lens.hs @@ -0,0 +1,25 @@ +module Distribution.Types.Lens ( + module Distribution.Types.Benchmark.Lens, + module Distribution.Types.BuildInfo.Lens, + module Distribution.Types.Executable.Lens, + module Distribution.Types.ForeignLib.Lens, + module Distribution.Types.GenericPackageDescription.Lens, + module Distribution.Types.Library.Lens, + module Distribution.Types.PackageDescription.Lens, + module Distribution.Types.PackageId.Lens, + module Distribution.Types.SetupBuildInfo.Lens, + module Distribution.Types.SourceRepo.Lens, + module Distribution.Types.TestSuite.Lens, + ) where + +import Distribution.Types.Benchmark.Lens +import Distribution.Types.BuildInfo.Lens +import Distribution.Types.Executable.Lens +import Distribution.Types.ForeignLib.Lens +import Distribution.Types.GenericPackageDescription.Lens +import Distribution.Types.Library.Lens +import Distribution.Types.PackageDescription.Lens +import Distribution.Types.PackageId.Lens +import Distribution.Types.SetupBuildInfo.Lens +import Distribution.Types.SourceRepo.Lens +import Distribution.Types.TestSuite.Lens diff --git a/cabal/Cabal-syntax/src/Distribution/Types/Library.hs b/cabal/Cabal-syntax/src/Distribution/Types/Library.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/Library.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NoMonoLocalBinds #-} + +module Distribution.Types.Library ( + Library(..), + emptyLibrary, + explicitLibModules, + libModulesAutogen, +) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.ModuleName +import Distribution.Types.BuildInfo +import Distribution.Types.LibraryVisibility +import Distribution.Types.ModuleReexport +import Distribution.Types.LibraryName + +import qualified Distribution.Types.BuildInfo.Lens as L + +data Library = Library + { libName :: LibraryName + , exposedModules :: [ModuleName] + , reexportedModules :: [ModuleReexport] + , signatures :: [ModuleName] -- ^ What sigs need implementations? + , libExposed :: Bool -- ^ Is the lib to be exposed by default? (i.e. whether its modules available in GHCi for example) + , libVisibility :: LibraryVisibility -- ^ Whether this multilib can be dependent from outside. + , libBuildInfo :: BuildInfo + } + deriving (Generic, Show, Eq, Read, Typeable, Data) + +instance L.HasBuildInfo Library where + buildInfo f l = (\x -> l { libBuildInfo = x }) <$> f (libBuildInfo l) + +instance Binary Library +instance Structured Library +instance NFData Library where rnf = genericRnf + +emptyLibrary :: Library +emptyLibrary = Library + { libName = LMainLibName + , exposedModules = mempty + , reexportedModules = mempty + , signatures = mempty + , libExposed = True + , libVisibility = mempty + , libBuildInfo = mempty + } + +-- | This instance is not good. +-- +-- We need it for 'PackageDescription.Configuration.addBuildableCondition'. +-- More correct method would be some kind of "create empty clone". +-- +-- More concretely, 'addBuildableCondition' will make `libVisibility = False` +-- libraries when `buildable: false`. This may cause problems. +-- +instance Monoid Library where + mempty = emptyLibrary + mappend = (<>) + +instance Semigroup Library where + a <> b = Library + { libName = combineLibraryName (libName a) (libName b) + , exposedModules = combine exposedModules + , reexportedModules = combine reexportedModules + , signatures = combine signatures + , libExposed = libExposed a && libExposed b -- so False propagates + , libVisibility = combine libVisibility + , libBuildInfo = combine libBuildInfo + } + where combine field = field a `mappend` field b + +-- | Get all the module names from the library (exposed and internal modules) +-- which are explicitly listed in the package description which would +-- need to be compiled. (This does not include reexports, which +-- do not need to be compiled.) This may not include all modules for which +-- GHC generated interface files (i.e., implicit modules.) +explicitLibModules :: Library -> [ModuleName] +explicitLibModules lib = exposedModules lib + ++ otherModules (libBuildInfo lib) + ++ signatures lib + +-- | Get all the auto generated module names from the library, exposed or not. +-- This are a subset of 'libModules'. +libModulesAutogen :: Library -> [ModuleName] +libModulesAutogen lib = autogenModules (libBuildInfo lib) + +-- | Combine 'LibraryName'. in parsing we prefer value coming +-- from munged @name@ field over the @lib-name@. +-- +-- /Should/ be irrelevant. +combineLibraryName :: LibraryName -> LibraryName -> LibraryName +combineLibraryName l@(LSubLibName _) _ = l +combineLibraryName _ l = l diff --git a/cabal/Cabal-syntax/src/Distribution/Types/Library/Lens.hs b/cabal/Cabal-syntax/src/Distribution/Types/Library/Lens.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/Library/Lens.hs @@ -0,0 +1,45 @@ +module Distribution.Types.Library.Lens ( + Library, + module Distribution.Types.Library.Lens, + ) where + +import Distribution.Compat.Lens +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.ModuleName (ModuleName) +import Distribution.Types.BuildInfo (BuildInfo) +import Distribution.Types.Library (Library) +import Distribution.Types.LibraryName (LibraryName) +import Distribution.Types.LibraryVisibility (LibraryVisibility) +import Distribution.Types.ModuleReexport (ModuleReexport) + +import qualified Distribution.Types.Library as T + +libName :: Lens' Library LibraryName +libName f s = fmap (\x -> s { T.libName = x }) (f (T.libName s)) +{-# INLINE libName #-} + +exposedModules :: Lens' Library [ModuleName] +exposedModules f s = fmap (\x -> s { T.exposedModules = x }) (f (T.exposedModules s)) +{-# INLINE exposedModules #-} + +reexportedModules :: Lens' Library [ModuleReexport] +reexportedModules f s = fmap (\x -> s { T.reexportedModules = x }) (f (T.reexportedModules s)) +{-# INLINE reexportedModules #-} + +signatures :: Lens' Library [ModuleName] +signatures f s = fmap (\x -> s { T.signatures = x }) (f (T.signatures s)) +{-# INLINE signatures #-} + +libExposed :: Lens' Library Bool +libExposed f s = fmap (\x -> s { T.libExposed = x }) (f (T.libExposed s)) +{-# INLINE libExposed #-} + +libVisibility :: Lens' Library LibraryVisibility +libVisibility f s = fmap (\x -> s { T.libVisibility = x }) (f (T.libVisibility s)) +{-# INLINE libVisibility #-} + +libBuildInfo :: Lens' Library BuildInfo +libBuildInfo f s = fmap (\x -> s { T.libBuildInfo = x }) (f (T.libBuildInfo s)) +{-# INLINE libBuildInfo #-} diff --git a/cabal/Cabal-syntax/src/Distribution/Types/LibraryName.hs b/cabal/Cabal-syntax/src/Distribution/Types/LibraryName.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/LibraryName.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +module Distribution.Types.LibraryName ( + LibraryName(..), + defaultLibName, + maybeToLibraryName, + showLibraryName, + libraryNameStanza, + libraryNameString, + -- * Pretty & Parse + prettyLibraryNameComponent, + parsecLibraryNameComponent, + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Types.UnqualComponentName +import Distribution.Pretty +import Distribution.Parsec + +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as Disp + +data LibraryName = LMainLibName + | LSubLibName UnqualComponentName + deriving (Eq, Generic, Ord, Read, Show, Typeable, Data) + +instance Binary LibraryName +instance Structured LibraryName +instance NFData LibraryName where rnf = genericRnf + +-- | Pretty print 'LibraryName' in build-target-ish syntax. +-- +-- /Note:/ there are no 'Pretty' or 'Parsec' instances, +-- as there's other way to represent 'LibraryName', namely as bare +-- 'UnqualComponentName'. +prettyLibraryNameComponent :: LibraryName -> Disp.Doc +prettyLibraryNameComponent LMainLibName = Disp.text "lib" +prettyLibraryNameComponent (LSubLibName str) = Disp.text "lib:" <<>> pretty str + +parsecLibraryNameComponent :: CabalParsing m => m LibraryName +parsecLibraryNameComponent = do + _ <- P.string "lib" + parseComposite <|> parseSingle + where + parseSingle = return LMainLibName + parseComposite = do + _ <- P.char ':' + LSubLibName <$> parsec + +defaultLibName :: LibraryName +defaultLibName = LMainLibName + +showLibraryName :: LibraryName -> String +showLibraryName LMainLibName = "library" +showLibraryName (LSubLibName name) = "library '" ++ prettyShow name ++ "'" + +libraryNameStanza :: LibraryName -> String +libraryNameStanza LMainLibName = "library" +libraryNameStanza (LSubLibName name) = "library " ++ prettyShow name + +libraryNameString :: LibraryName -> Maybe UnqualComponentName +libraryNameString LMainLibName = Nothing +libraryNameString (LSubLibName n) = Just n + +-- | Convert the 'UnqualComponentName' of a library into a +-- 'LibraryName'. +maybeToLibraryName :: Maybe UnqualComponentName -> LibraryName +maybeToLibraryName Nothing = LMainLibName +maybeToLibraryName (Just n) = LSubLibName n + diff --git a/cabal/Cabal-syntax/src/Distribution/Types/LibraryVisibility.hs b/cabal/Cabal-syntax/src/Distribution/Types/LibraryVisibility.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/LibraryVisibility.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module Distribution.Types.LibraryVisibility( + LibraryVisibility(..), +) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Parsec +import Distribution.Pretty + +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as Disp + +-- | Multi-lib visibility +-- +-- @since 3.0.0.0 +-- +data LibraryVisibility + -- | Can be depenendent from other packages + = LibraryVisibilityPublic + -- | Internal library, default + | LibraryVisibilityPrivate + deriving (Generic, Show, Read, Eq, Typeable, Data) + +instance Pretty LibraryVisibility where + pretty LibraryVisibilityPublic = Disp.text "public" + pretty LibraryVisibilityPrivate = Disp.text "private" + +instance Parsec LibraryVisibility where + parsec = do + name <- P.munch1 isAlpha + case name of + "public" -> return LibraryVisibilityPublic + "private" -> return LibraryVisibilityPrivate + _ -> fail $ "Unknown visibility: " ++ name + +instance Binary LibraryVisibility +instance Structured LibraryVisibility +instance NFData LibraryVisibility where rnf = genericRnf + +instance Semigroup LibraryVisibility where + LibraryVisibilityPrivate <> LibraryVisibilityPrivate = LibraryVisibilityPrivate + _ <> _ = LibraryVisibilityPublic + +instance Monoid LibraryVisibility where + mempty = LibraryVisibilityPrivate + mappend = (<>) diff --git a/cabal/Cabal-syntax/src/Distribution/Types/Mixin.hs b/cabal/Cabal-syntax/src/Distribution/Types/Mixin.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/Mixin.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +module Distribution.Types.Mixin ( + Mixin(..), + mkMixin, + normaliseMixin, +) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.CabalSpecVersion +import Distribution.Parsec +import Distribution.Pretty +import Distribution.Types.IncludeRenaming +import Distribution.Types.LibraryName +import Distribution.Types.PackageName +import Distribution.Types.UnqualComponentName + +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as PP + +-- | +-- +-- /Invariant:/ if 'mixinLibraryName' is 'LSubLibName', it's not +-- the same as 'mixinPackageName'. In other words, +-- the same invariant as 'Dependency' has. +-- +data Mixin = Mixin { mixinPackageName :: PackageName + , mixinLibraryName :: LibraryName + , mixinIncludeRenaming :: IncludeRenaming } + deriving (Show, Read, Eq, Ord, Typeable, Data, Generic) + +instance Binary Mixin +instance Structured Mixin + +instance NFData Mixin where rnf = genericRnf + +instance Pretty Mixin where + pretty (Mixin pn LMainLibName incl) = pretty pn <+> pretty incl + pretty (Mixin pn (LSubLibName ln) incl) = pretty pn <<>> PP.colon <<>> pretty ln <+> pretty incl + +-- | +-- +-- >>> simpleParsec "mylib" :: Maybe Mixin +-- Just (Mixin {mixinPackageName = PackageName "mylib", mixinLibraryName = LMainLibName, mixinIncludeRenaming = IncludeRenaming {includeProvidesRn = DefaultRenaming, includeRequiresRn = DefaultRenaming}}) +-- +-- >>> simpleParsec "thatlib:sublib" :: Maybe Mixin +-- Just (Mixin {mixinPackageName = PackageName "thatlib", mixinLibraryName = LSubLibName (UnqualComponentName "sublib"), mixinIncludeRenaming = IncludeRenaming {includeProvidesRn = DefaultRenaming, includeRequiresRn = DefaultRenaming}}) +-- +-- >>> simpleParsec "thatlib:thatlib" :: Maybe Mixin +-- Just (Mixin {mixinPackageName = PackageName "thatlib", mixinLibraryName = LMainLibName, mixinIncludeRenaming = IncludeRenaming {includeProvidesRn = DefaultRenaming, includeRequiresRn = DefaultRenaming}}) +-- +-- Sublibrary syntax is accepted since @cabal-version: 3.4@. +-- +-- >>> map (`simpleParsec'` "mylib:sub") [CabalSpecV3_0, CabalSpecV3_4] :: [Maybe Mixin] +-- [Nothing,Just (Mixin {mixinPackageName = PackageName "mylib", mixinLibraryName = LSubLibName (UnqualComponentName "sub"), mixinIncludeRenaming = IncludeRenaming {includeProvidesRn = DefaultRenaming, includeRequiresRn = DefaultRenaming}})] +-- +instance Parsec Mixin where + parsec = do + pn <- parsec + ln <- P.option LMainLibName $ do + _ <- P.char ':' + versionGuardMultilibs + LSubLibName <$> parsec + P.spaces + incl <- parsec + return (mkMixin pn ln incl) + where + +versionGuardMultilibs :: CabalParsing m => m () +versionGuardMultilibs = do + csv <- askCabalSpecVersion + when (csv < CabalSpecV3_4) $ fail $ unwords + [ "Sublibrary mixin syntax used." + , "To use this syntax the package needs to specify at least 'cabal-version: 3.4'." + ] + +-- | Smart constructor of 'Mixin', enforces invariant. +-- +-- @since 3.4.0.0 +mkMixin :: PackageName -> LibraryName -> IncludeRenaming -> Mixin +mkMixin pn (LSubLibName uqn) incl + | packageNameToUnqualComponentName pn == uqn + = Mixin pn LMainLibName incl +mkMixin pn ln incl + = Mixin pn ln incl + +-- | Restore invariant +normaliseMixin :: Mixin -> Mixin +normaliseMixin (Mixin pn ln incl) = mkMixin pn ln incl diff --git a/cabal/Cabal-syntax/src/Distribution/Types/Module.hs b/cabal/Cabal-syntax/src/Distribution/Types/Module.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/Module.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Distribution.Types.Module + ( Module(..) + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as Disp +import Distribution.Pretty +import Distribution.Parsec +import Distribution.Types.UnitId +import Distribution.ModuleName + +-- | A module identity uniquely identifies a Haskell module by +-- qualifying a 'ModuleName' with the 'UnitId' which defined +-- it. This type distinguishes between two packages +-- which provide a module with the same name, or a module +-- from the same package compiled with different dependencies. +-- There are a few cases where Cabal needs to know about +-- module identities, e.g., when writing out reexported modules in +-- the 'InstalledPackageInfo'. +data Module = + Module DefUnitId ModuleName + deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) + +instance Binary Module +instance Structured Module + +instance Pretty Module where + pretty (Module uid mod_name) = + pretty uid <<>> Disp.text ":" <<>> pretty mod_name + +instance Parsec Module where + parsec = do + uid <- parsec + _ <- P.char ':' + mod_name <- parsec + return (Module uid mod_name) + +instance NFData Module where + rnf (Module uid mod_name) = rnf uid `seq` rnf mod_name diff --git a/cabal/Cabal-syntax/src/Distribution/Types/ModuleReexport.hs b/cabal/Cabal-syntax/src/Distribution/Types/ModuleReexport.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/ModuleReexport.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +module Distribution.Types.ModuleReexport ( + ModuleReexport(..) +) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.ModuleName +import Distribution.Parsec +import Distribution.Pretty +import Distribution.Types.PackageName + +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as Disp + +-- ----------------------------------------------------------------------------- +-- Module re-exports + +data ModuleReexport = ModuleReexport { + moduleReexportOriginalPackage :: Maybe PackageName, + moduleReexportOriginalName :: ModuleName, + moduleReexportName :: ModuleName + } + deriving (Eq, Generic, Read, Show, Typeable, Data) + +instance Binary ModuleReexport +instance Structured ModuleReexport +instance NFData ModuleReexport where rnf = genericRnf + +instance Pretty ModuleReexport where + pretty (ModuleReexport mpkgname origname newname) = + maybe Disp.empty (\pkgname -> pretty pkgname <<>> Disp.char ':') mpkgname + <<>> pretty origname + <+> if newname == origname + then Disp.empty + else Disp.text "as" <+> pretty newname + +instance Parsec ModuleReexport where + parsec = do + mpkgname <- P.optional (P.try $ parsec <* P.char ':') + origname <- parsec + newname <- P.option origname $ P.try $ do + P.spaces + _ <- P.string "as" + P.spaces + parsec + return (ModuleReexport mpkgname origname newname) diff --git a/cabal/Cabal-syntax/src/Distribution/Types/ModuleRenaming.hs b/cabal/Cabal-syntax/src/Distribution/Types/ModuleRenaming.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/ModuleRenaming.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE NoMonoLocalBinds #-} + +module Distribution.Types.ModuleRenaming ( + ModuleRenaming(..), + interpModuleRenaming, + defaultRenaming, + isDefaultRenaming, +) where + +import Distribution.CabalSpecVersion +import Distribution.Compat.Prelude hiding (empty) +import Prelude () + +import Distribution.ModuleName +import Distribution.Parsec +import Distribution.Pretty + +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Distribution.Compat.CharParsing as P +import Text.PrettyPrint (hsep, parens, punctuate, text, comma) + +-- | Renaming applied to the modules provided by a package. +-- The boolean indicates whether or not to also include all of the +-- original names of modules. Thus, @ModuleRenaming False []@ is +-- "don't expose any modules, and @ModuleRenaming True [("Data.Bool", "Bool")]@ +-- is, "expose all modules, but also expose @Data.Bool@ as @Bool@". +-- If a renaming is omitted you get the 'DefaultRenaming'. +-- +-- (NB: This is a list not a map so that we can preserve order.) +-- +data ModuleRenaming + -- | A module renaming/thinning; e.g., @(A as B, C as C)@ + -- brings @B@ and @C@ into scope. + = ModuleRenaming [(ModuleName, ModuleName)] + -- | The default renaming, bringing all exported modules + -- into scope. + | DefaultRenaming + -- | Hiding renaming, e.g., @hiding (A, B)@, bringing all + -- exported modules into scope except the hidden ones. + | HidingRenaming [ModuleName] + deriving (Show, Read, Eq, Ord, Typeable, Data, Generic) + +-- | Interpret a 'ModuleRenaming' as a partial map from 'ModuleName' +-- to 'ModuleName'. For efficiency, you should partially apply it +-- with 'ModuleRenaming' and then reuse it. +interpModuleRenaming :: ModuleRenaming -> ModuleName -> Maybe ModuleName +interpModuleRenaming DefaultRenaming = Just +interpModuleRenaming (ModuleRenaming rns) = + let m = Map.fromList rns + in \k -> Map.lookup k m +interpModuleRenaming (HidingRenaming hs) = + let s = Set.fromList hs + in \k -> if k `Set.member` s then Nothing else Just k + +-- | The default renaming, if something is specified in @build-depends@ +-- only. +defaultRenaming :: ModuleRenaming +defaultRenaming = DefaultRenaming + +-- | Tests if its the default renaming; we can use a more compact syntax +-- in 'Distribution.Types.IncludeRenaming.IncludeRenaming' in this case. +isDefaultRenaming :: ModuleRenaming -> Bool +isDefaultRenaming DefaultRenaming = True +isDefaultRenaming _ = False + + + +instance Binary ModuleRenaming where +instance Structured ModuleRenaming where + +instance NFData ModuleRenaming where rnf = genericRnf + +-- NB: parentheses are mandatory, because later we may extend this syntax +-- to allow "hiding (A, B)" or other modifier words. +instance Pretty ModuleRenaming where + pretty DefaultRenaming = mempty + pretty (HidingRenaming hides) + = text "hiding" <+> parens (hsep (punctuate comma (map pretty hides))) + pretty (ModuleRenaming rns) + = parens . hsep $ punctuate comma (map dispEntry rns) + where dispEntry (orig, new) + | orig == new = pretty orig + | otherwise = pretty orig <+> text "as" <+> pretty new + +instance Parsec ModuleRenaming where + parsec = do + csv <- askCabalSpecVersion + if csv >= CabalSpecV3_0 + then moduleRenamingParsec parensLax lexemeParsec + else moduleRenamingParsec parensStrict parsec + where + -- For cabal spec versions < 3.0 white spaces were not skipped + -- after the '(' and ')' tokens in the mixin field. This + -- parser checks the cabal file version and does the correct + -- skipping of spaces. + parensLax p = P.between (P.char '(' >> P.spaces) (P.char ')' >> P.spaces) p + parensStrict p = P.between (P.char '(' >> warnSpaces) (P.char ')') p + + warnSpaces = P.optional $ + P.space *> fail "space after parenthesis, use cabal-version: 3.0 or higher" + +moduleRenamingParsec + :: CabalParsing m + => (forall a. m a -> m a) -- ^ between parens + -> m ModuleName -- ^ module name parser + -> m ModuleRenaming +moduleRenamingParsec bp mn = + -- NB: try not necessary as the first token is obvious + P.choice [ parseRename, parseHiding, return DefaultRenaming ] + where + cma = P.char ',' >> P.spaces + parseRename = do + rns <- bp parseList + P.spaces + return (ModuleRenaming rns) + parseHiding = do + _ <- P.string "hiding" + P.spaces -- space isn't strictly required as next is an open paren + hides <- bp (P.sepBy mn cma) + return (HidingRenaming hides) + parseList = + P.sepBy parseEntry cma + parseEntry = do + orig <- parsec + P.spaces + P.option (orig, orig) $ do + _ <- P.string "as" + P.skipSpaces1 -- require space after "as" + new <- parsec + P.spaces + return (orig, new) diff --git a/cabal/Cabal-syntax/src/Distribution/Types/MungedPackageId.hs b/cabal/Cabal-syntax/src/Distribution/Types/MungedPackageId.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/MungedPackageId.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Types.MungedPackageId + ( MungedPackageId(..) + , computeCompatPackageId + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Parsec +import Distribution.Pretty +import Distribution.Types.LibraryName +import Distribution.Types.MungedPackageName +import Distribution.Types.PackageId +import Distribution.Version (Version, nullVersion) + +import qualified Text.PrettyPrint as Disp + +-- | A simple pair of a 'MungedPackageName' and 'Version'. 'MungedPackageName' is to +-- 'MungedPackageId' as 'PackageName' is to 'PackageId'. See 'MungedPackageName' for more +-- info. +data MungedPackageId + = MungedPackageId { + -- | The combined package and component name. see documentation for + -- 'MungedPackageName'. + mungedName :: MungedPackageName, + -- | The version of this package / component, eg 1.2 + mungedVersion :: Version + } + deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) + +instance Binary MungedPackageId +instance Structured MungedPackageId + +-- | +-- +-- >>> prettyShow $ MungedPackageId (MungedPackageName "servant" LMainLibName) (mkVersion [1,2,3]) +-- "servant-1.2.3" +-- +-- >>> prettyShow $ MungedPackageId (MungedPackageName "servant" (LSubLibName "lackey")) (mkVersion [0,1,2]) +-- "z-servant-z-lackey-0.1.2" +-- +instance Pretty MungedPackageId where + pretty (MungedPackageId n v) + | v == nullVersion = pretty n -- if no version, don't show version. + | otherwise = pretty n <<>> Disp.char '-' <<>> pretty v + +-- | +-- +-- >>> simpleParsec "foo-bar-0" :: Maybe MungedPackageId +-- Just (MungedPackageId {mungedName = MungedPackageName (PackageName "foo-bar") LMainLibName, mungedVersion = mkVersion [0]}) +-- +-- >>> simpleParsec "foo-bar" :: Maybe MungedPackageId +-- Just (MungedPackageId {mungedName = MungedPackageName (PackageName "foo-bar") LMainLibName, mungedVersion = mkVersion []}) +-- +-- >>> simpleParsec "z-foo-bar-z-baz-0" :: Maybe MungedPackageId +-- Just (MungedPackageId {mungedName = MungedPackageName (PackageName "foo-bar") (LSubLibName (UnqualComponentName "baz")), mungedVersion = mkVersion [0]}) +-- +-- >>> simpleParsec "foo-bar-0-0" :: Maybe MungedPackageId +-- Nothing +-- +-- >>> simpleParsec "foo-bar.0" :: Maybe MungedPackageId +-- Nothing +-- +-- >>> simpleParsec "foo-bar.4-2" :: Maybe MungedPackageId +-- Nothing +-- +instance Parsec MungedPackageId where + parsec = do + PackageIdentifier pn v <- parsec + return $ MungedPackageId (decodeCompatPackageName pn) v + +instance NFData MungedPackageId where + rnf (MungedPackageId name version) = rnf name `seq` rnf version + +computeCompatPackageId :: PackageId -> LibraryName -> MungedPackageId +computeCompatPackageId (PackageIdentifier pn vr) ln = + MungedPackageId (MungedPackageName pn ln) vr + +-- $setup +-- >>> :seti -XOverloadedStrings +-- >>> import Distribution.Types.Version diff --git a/cabal/Cabal-syntax/src/Distribution/Types/MungedPackageName.hs b/cabal/Cabal-syntax/src/Distribution/Types/MungedPackageName.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/MungedPackageName.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Types.MungedPackageName + ( MungedPackageName (..) + , decodeCompatPackageName + , encodeCompatPackageName + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Parsec +import Distribution.Pretty +import Distribution.Types.LibraryName +import Distribution.Types.PackageName +import Distribution.Types.UnqualComponentName + +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as Disp + +-- | A combination of a package and component name used in various legacy +-- interfaces, chiefly bundled with a version as 'MungedPackageId'. It's generally +-- better to use a 'UnitId' to opaquely refer to some compilation/packing unit, +-- but that doesn't always work, e.g. where a "name" is needed, in which case +-- this can be used as a fallback. +-- +-- Use 'mkMungedPackageName' and 'unMungedPackageName' to convert from/to a 'String'. +-- +-- In @3.0.0.0@ representation was changed from opaque (string) to semantic representation. +-- +-- @since 2.0.0.2 +-- +data MungedPackageName = MungedPackageName !PackageName !LibraryName + deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) + +instance Binary MungedPackageName +instance Structured MungedPackageName +instance NFData MungedPackageName where rnf = genericRnf + +-- | Computes the package name for a library. If this is the public +-- library, it will just be the original package name; otherwise, +-- it will be a munged package name recording the original package +-- name as well as the name of the internal library. +-- +-- A lot of tooling in the Haskell ecosystem assumes that if something +-- is installed to the package database with the package name 'foo', +-- then it actually is an entry for the (only public) library in package +-- 'foo'. With internal packages, this is not necessarily true: +-- a public library as well as arbitrarily many internal libraries may +-- come from the same package. To prevent tools from getting confused +-- in this case, the package name of these internal libraries is munged +-- so that they do not conflict the public library proper. A particular +-- case where this matters is ghc-pkg: if we don't munge the package +-- name, the inplace registration will OVERRIDE a different internal +-- library. +-- +-- We munge into a reserved namespace, "z-", and encode both the +-- component name and the package name of an internal library using the +-- following format: +-- +-- compat-pkg-name ::= "z-" package-name "-z-" library-name +-- +-- where package-name and library-name have "-" ( "z" + ) "-" +-- segments encoded by adding an extra "z". +-- +-- When we have the public library, the compat-pkg-name is just the +-- package-name, no surprises there! +-- +-- >>> prettyShow $ MungedPackageName "servant" LMainLibName +-- "servant" +-- +-- >>> prettyShow $ MungedPackageName "servant" (LSubLibName "lackey") +-- "z-servant-z-lackey" +-- +instance Pretty MungedPackageName where + -- First handle the cases where we can just use the original 'PackageName'. + -- This is for the PRIMARY library, and it is non-Backpack, or the + -- indefinite package for us. + pretty = Disp.text . encodeCompatPackageName' + +-- | +-- +-- >>> simpleParsec "servant" :: Maybe MungedPackageName +-- Just (MungedPackageName (PackageName "servant") LMainLibName) +-- +-- >>> simpleParsec "z-servant-z-lackey" :: Maybe MungedPackageName +-- Just (MungedPackageName (PackageName "servant") (LSubLibName (UnqualComponentName "lackey"))) +-- +-- >>> simpleParsec "z-servant-zz" :: Maybe MungedPackageName +-- Just (MungedPackageName (PackageName "z-servant-zz") LMainLibName) +-- +instance Parsec MungedPackageName where + parsec = decodeCompatPackageName' <$> parsecUnqualComponentName + +------------------------------------------------------------------------------- +-- ZDashCode conversions +------------------------------------------------------------------------------- + +-- | Intended for internal use only +-- +-- >>> decodeCompatPackageName "z-servant-z-lackey" +-- MungedPackageName (PackageName "servant") (LSubLibName (UnqualComponentName "lackey")) +-- +decodeCompatPackageName :: PackageName -> MungedPackageName +decodeCompatPackageName = decodeCompatPackageName' . unPackageName + +-- | Intended for internal use only +-- +-- >>> encodeCompatPackageName $ MungedPackageName "servant" (LSubLibName "lackey") +-- PackageName "z-servant-z-lackey" +-- +-- This is used in @cabal-install@ in the Solver. +-- May become obsolete as solver moves to per-component solving. +-- +encodeCompatPackageName :: MungedPackageName -> PackageName +encodeCompatPackageName = mkPackageName . encodeCompatPackageName' + +decodeCompatPackageName' :: String -> MungedPackageName +decodeCompatPackageName' m = + case m of + 'z':'-':rest | Right [pn, cn] <- explicitEitherParsec parseZDashCode rest + -> MungedPackageName (mkPackageName pn) (LSubLibName (mkUnqualComponentName cn)) + s -> MungedPackageName (mkPackageName s) LMainLibName + +encodeCompatPackageName' :: MungedPackageName -> String +encodeCompatPackageName' (MungedPackageName pn LMainLibName) = unPackageName pn +encodeCompatPackageName' (MungedPackageName pn (LSubLibName uqn)) = + "z-" ++ zdashcode (unPackageName pn) ++ + "-z-" ++ zdashcode (unUnqualComponentName uqn) + +zdashcode :: String -> String +zdashcode s = go s (Nothing :: Maybe Int) [] + where go [] _ r = reverse r + go ('-':z) (Just n) r | n > 0 = go z (Just 0) ('-':'z':r) + go ('-':z) _ r = go z (Just 0) ('-':r) + go ('z':z) (Just n) r = go z (Just (n+1)) ('z':r) + go (c:z) _ r = go z Nothing (c:r) + +parseZDashCode :: CabalParsing m => m [String] +parseZDashCode = do + ns <- toList <$> P.sepByNonEmpty (some (P.satisfy (/= '-'))) (P.char '-') + return (go ns) + where + go ns = case break (=="z") ns of + (_, []) -> [paste ns] + (as, "z":bs) -> paste as : go bs + _ -> error "parseZDashCode: go" + unZ :: String -> String + unZ "" = error "parseZDashCode: unZ" + unZ r@('z':zs) | all (=='z') zs = zs + | otherwise = r + unZ r = r + paste :: [String] -> String + paste = intercalate "-" . map unZ + +-- $setup +-- >>> :seti -XOverloadedStrings diff --git a/cabal/Cabal-syntax/src/Distribution/Types/PackageDescription.hs b/cabal/Cabal-syntax/src/Distribution/Types/PackageDescription.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/PackageDescription.hs @@ -0,0 +1,457 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Types.PackageDescription +-- Copyright : Isaac Jones 2003-2005 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This defines the data structure for the @.cabal@ file format. There are +-- several parts to this structure. It has top level info and then 'Library', +-- 'Executable', 'TestSuite', and 'Benchmark' sections each of which have +-- associated 'BuildInfo' data that's used to build the library, exe, test, or +-- benchmark. To further complicate things there is both a 'PackageDescription' +-- and a 'GenericPackageDescription'. This distinction relates to cabal +-- configurations. When we initially read a @.cabal@ file we get a +-- 'GenericPackageDescription' which has all the conditional sections. +-- Before actually building a package we have to decide +-- on each conditional. Once we've done that we get a 'PackageDescription'. +-- It was done this way initially to avoid breaking too much stuff when the +-- feature was introduced. It could probably do with being rationalised at some +-- point to make it simpler. + +module Distribution.Types.PackageDescription ( + PackageDescription(..), + license, + license', + buildType, + emptyPackageDescription, + hasPublicLib, + hasLibs, + allLibraries, + withLib, + hasExes, + withExe, + hasTests, + withTest, + hasBenchmarks, + withBenchmark, + hasForeignLibs, + withForeignLib, + allBuildInfo, + enabledBuildInfos, + allBuildDepends, + enabledBuildDepends, + updatePackageDescription, + pkgComponents, + pkgBuildableComponents, + enabledComponents, + lookupComponent, + getComponent, + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import Control.Monad ((<=<)) + +-- lens +import qualified Distribution.Types.BuildInfo.Lens as L +import Distribution.Types.Library +import Distribution.Types.TestSuite +import Distribution.Types.Executable +import Distribution.Types.Benchmark +import Distribution.Types.ForeignLib + +import Distribution.Types.Component +import Distribution.Types.ComponentRequestedSpec +import Distribution.Types.Dependency +import Distribution.Types.PackageId +import Distribution.Types.ComponentName +import Distribution.Types.PackageName +import Distribution.Types.UnqualComponentName +import Distribution.Types.SetupBuildInfo +import Distribution.Types.BuildInfo +import Distribution.Types.BuildType +import Distribution.Types.SourceRepo +import Distribution.Types.HookedBuildInfo + +import Distribution.CabalSpecVersion +import Distribution.Compiler +import Distribution.License +import Distribution.Package +import Distribution.Version +import Distribution.Utils.Path +import Distribution.Utils.ShortText + +import qualified Distribution.SPDX as SPDX + +-- ----------------------------------------------------------------------------- +-- The PackageDescription type + +-- | This data type is the internal representation of the file @pkg.cabal@. +-- It contains two kinds of information about the package: information +-- which is needed for all packages, such as the package name and version, and +-- information which is needed for the simple build system only, such as +-- the compiler options and library name. +-- +data PackageDescription + = PackageDescription { + -- the following are required by all packages: + + -- | The version of the Cabal spec that this package description uses. + specVersion :: CabalSpecVersion, + package :: PackageIdentifier, + licenseRaw :: Either SPDX.License License, + licenseFiles :: [SymbolicPath PackageDir LicenseFile], + copyright :: !ShortText, + maintainer :: !ShortText, + author :: !ShortText, + stability :: !ShortText, + testedWith :: [(CompilerFlavor,VersionRange)], + homepage :: !ShortText, + pkgUrl :: !ShortText, + bugReports :: !ShortText, + sourceRepos :: [SourceRepo], + synopsis :: !ShortText, -- ^A one-line summary of this package + description :: !ShortText, -- ^A more verbose description of this package + category :: !ShortText, + customFieldsPD :: [(String,String)], -- ^Custom fields starting + -- with x-, stored in a + -- simple assoc-list. + + -- | The original @build-type@ value as parsed from the + -- @.cabal@ file without defaulting. See also 'buildType'. + -- + -- @since 2.2 + buildTypeRaw :: Maybe BuildType, + setupBuildInfo :: Maybe SetupBuildInfo, + -- components + library :: Maybe Library, + subLibraries :: [Library], + executables :: [Executable], + foreignLibs :: [ForeignLib], + testSuites :: [TestSuite], + benchmarks :: [Benchmark], + -- files + dataFiles :: [FilePath], + dataDir :: FilePath, + extraSrcFiles :: [FilePath], + extraTmpFiles :: [FilePath], + extraDocFiles :: [FilePath] + } + deriving (Generic, Show, Read, Eq, Typeable, Data) + +instance Binary PackageDescription +instance Structured PackageDescription + +instance NFData PackageDescription where rnf = genericRnf + +instance Package PackageDescription where + packageId = package + +-- | The SPDX 'LicenseExpression' of the package. +-- +-- @since 2.2.0.0 +license :: PackageDescription -> SPDX.License +license = license' . licenseRaw + +-- | See 'license'. +-- +-- @since 2.2.0.0 +license' :: Either SPDX.License License -> SPDX.License +license' = either id licenseToSPDX + +-- | The effective @build-type@ after applying defaulting rules. +-- +-- The original @build-type@ value parsed is stored in the +-- 'buildTypeRaw' field. However, the @build-type@ field is optional +-- and can therefore be empty in which case we need to compute the +-- /effective/ @build-type@. This function implements the following +-- defaulting rules: +-- +-- * For @cabal-version:2.0@ and below, default to the @Custom@ +-- build-type unconditionally. +-- +-- * Otherwise, if a @custom-setup@ stanza is defined, default to +-- the @Custom@ build-type; else default to @Simple@ build-type. +-- +-- @since 2.2 +buildType :: PackageDescription -> BuildType +buildType pkg + | specVersion pkg >= CabalSpecV2_2 + = fromMaybe newDefault (buildTypeRaw pkg) + | otherwise -- cabal-version < 2.1 + = fromMaybe Custom (buildTypeRaw pkg) + where + newDefault | isNothing (setupBuildInfo pkg) = Simple + | otherwise = Custom + +emptyPackageDescription :: PackageDescription +emptyPackageDescription + = PackageDescription { + package = PackageIdentifier (mkPackageName "") + nullVersion, + licenseRaw = Right UnspecifiedLicense, -- TODO: + licenseFiles = [], + specVersion = CabalSpecV1_0, + buildTypeRaw = Nothing, + copyright = mempty, + maintainer = mempty, + author = mempty, + stability = mempty, + testedWith = [], + homepage = mempty, + pkgUrl = mempty, + bugReports = mempty, + sourceRepos = [], + synopsis = mempty, + description = mempty, + category = mempty, + customFieldsPD = [], + setupBuildInfo = Nothing, + library = Nothing, + subLibraries = [], + foreignLibs = [], + executables = [], + testSuites = [], + benchmarks = [], + dataFiles = [], + dataDir = ".", + extraSrcFiles = [], + extraTmpFiles = [], + extraDocFiles = [] + } + +-- --------------------------------------------------------------------------- +-- The Library type + +-- | Does this package have a buildable PUBLIC library? +hasPublicLib :: PackageDescription -> Bool +hasPublicLib p = + case library p of + Just lib -> buildable (libBuildInfo lib) + Nothing -> False + +-- | Does this package have any libraries? +hasLibs :: PackageDescription -> Bool +hasLibs p = any (buildable . libBuildInfo) (allLibraries p) + +allLibraries :: PackageDescription -> [Library] +allLibraries p = maybeToList (library p) ++ subLibraries p + +-- | If the package description has a buildable library section, +-- call the given function with the library build info as argument. +-- You probably want 'withLibLBI' if you have a 'LocalBuildInfo', +-- see the note in +-- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components" +-- for more information. +withLib :: PackageDescription -> (Library -> IO ()) -> IO () +withLib pkg_descr f = + sequence_ [f lib | lib <- allLibraries pkg_descr, buildable (libBuildInfo lib)] + +-- --------------------------------------------------------------------------- +-- The Executable type + +-- |does this package have any executables? +hasExes :: PackageDescription -> Bool +hasExes p = any (buildable . buildInfo) (executables p) + +-- | Perform the action on each buildable 'Executable' in the package +-- description. You probably want 'withExeLBI' if you have a +-- 'LocalBuildInfo', see the note in +-- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components" +-- for more information. +withExe :: PackageDescription -> (Executable -> IO ()) -> IO () +withExe pkg_descr f = + sequence_ [f exe | exe <- executables pkg_descr, buildable (buildInfo exe)] + +-- --------------------------------------------------------------------------- +-- The TestSuite type + +-- | Does this package have any test suites? +hasTests :: PackageDescription -> Bool +hasTests = any (buildable . testBuildInfo) . testSuites + +-- | Perform an action on each buildable 'TestSuite' in a package. +-- You probably want 'withTestLBI' if you have a 'LocalBuildInfo', see the note in +-- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components" +-- for more information. + +withTest :: PackageDescription -> (TestSuite -> IO ()) -> IO () +withTest pkg_descr f = + sequence_ [ f test | test <- testSuites pkg_descr, buildable (testBuildInfo test) ] + +-- --------------------------------------------------------------------------- +-- The Benchmark type + +-- | Does this package have any benchmarks? +hasBenchmarks :: PackageDescription -> Bool +hasBenchmarks = any (buildable . benchmarkBuildInfo) . benchmarks + +-- | Perform an action on each buildable 'Benchmark' in a package. +-- You probably want 'withBenchLBI' if you have a 'LocalBuildInfo', see the note in +-- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components" +-- for more information. + +withBenchmark :: PackageDescription -> (Benchmark -> IO ()) -> IO () +withBenchmark pkg_descr f = + sequence_ [f bench | bench <- benchmarks pkg_descr, buildable (benchmarkBuildInfo bench)] + +-- --------------------------------------------------------------------------- +-- The ForeignLib type + +-- | Does this package have any foreign libraries? +hasForeignLibs :: PackageDescription -> Bool +hasForeignLibs p = any (buildable . foreignLibBuildInfo) (foreignLibs p) + +-- | Perform the action on each buildable 'ForeignLib' in the package +-- description. +withForeignLib :: PackageDescription -> (ForeignLib -> IO ()) -> IO () +withForeignLib pkg_descr f = + sequence_ [ f flib + | flib <- foreignLibs pkg_descr + , buildable (foreignLibBuildInfo flib) + ] + +-- --------------------------------------------------------------------------- +-- The BuildInfo type + +-- | All 'BuildInfo' in the 'PackageDescription': +-- libraries, executables, test-suites and benchmarks. +-- +-- Useful for implementing package checks. +allBuildInfo :: PackageDescription -> [BuildInfo] +allBuildInfo pkg_descr = [ bi | lib <- allLibraries pkg_descr + , let bi = libBuildInfo lib ] + ++ [ bi | flib <- foreignLibs pkg_descr + , let bi = foreignLibBuildInfo flib ] + ++ [ bi | exe <- executables pkg_descr + , let bi = buildInfo exe ] + ++ [ bi | tst <- testSuites pkg_descr + , let bi = testBuildInfo tst ] + ++ [ bi | tst <- benchmarks pkg_descr + , let bi = benchmarkBuildInfo tst ] + +-- | Return all of the 'BuildInfo's of enabled components, i.e., all of +-- the ones that would be built if you run @./Setup build@. +enabledBuildInfos :: PackageDescription -> ComponentRequestedSpec -> [BuildInfo] +enabledBuildInfos pkg enabled = + [ componentBuildInfo comp + | comp <- enabledComponents pkg enabled ] + + +-- ------------------------------------------------------------ +-- * Utils +-- ------------------------------------------------------------ + +-- | Get the combined build-depends entries of all components. +allBuildDepends :: PackageDescription -> [Dependency] +allBuildDepends = targetBuildDepends <=< allBuildInfo + +-- | Get the combined build-depends entries of all enabled components, per the +-- given request spec. +enabledBuildDepends :: PackageDescription -> ComponentRequestedSpec -> [Dependency] +enabledBuildDepends spec pd = targetBuildDepends =<< enabledBuildInfos spec pd + + +updatePackageDescription :: HookedBuildInfo -> PackageDescription -> PackageDescription +updatePackageDescription (mb_lib_bi, exe_bi) p + = p{ executables = updateExecutables exe_bi (executables p) + , library = updateLibrary mb_lib_bi (library p) } + where + updateLibrary :: Maybe BuildInfo -> Maybe Library -> Maybe Library + updateLibrary (Just bi) (Just lib) = Just (lib{libBuildInfo = bi `mappend` libBuildInfo lib}) + updateLibrary Nothing mb_lib = mb_lib + updateLibrary (Just _) Nothing = Nothing + + updateExecutables :: [(UnqualComponentName, BuildInfo)] -- ^[(exeName, new buildinfo)] + -> [Executable] -- ^list of executables to update + -> [Executable] -- ^list with exeNames updated + updateExecutables exe_bi' executables' = foldr updateExecutable executables' exe_bi' + + updateExecutable :: (UnqualComponentName, BuildInfo) -- ^(exeName, new buildinfo) + -> [Executable] -- ^list of executables to update + -> [Executable] -- ^list with exeName updated + updateExecutable _ [] = [] + updateExecutable exe_bi'@(name,bi) (exe:exes) + | exeName exe == name = exe{buildInfo = bi `mappend` buildInfo exe} : exes + | otherwise = exe : updateExecutable exe_bi' exes + +-- ----------------------------------------------------------------------------- +-- Source-representation of buildable components + +-- | All the components in the package. +-- +pkgComponents :: PackageDescription -> [Component] +pkgComponents pkg = + [ CLib lib | lib <- allLibraries pkg ] + ++ [ CFLib flib | flib <- foreignLibs pkg ] + ++ [ CExe exe | exe <- executables pkg ] + ++ [ CTest tst | tst <- testSuites pkg ] + ++ [ CBench bm | bm <- benchmarks pkg ] + +-- | A list of all components in the package that are buildable, +-- i.e., were not marked with @buildable: False@. This does NOT +-- indicate if we are actually going to build the component, +-- see 'enabledComponents' instead. +-- +-- @since 2.0.0.2 +-- +pkgBuildableComponents :: PackageDescription -> [Component] +pkgBuildableComponents = filter componentBuildable . pkgComponents + +-- | A list of all components in the package that are enabled. +-- +-- @since 2.0.0.2 +-- +enabledComponents :: PackageDescription -> ComponentRequestedSpec -> [Component] +enabledComponents pkg enabled = filter (componentEnabled enabled) $ pkgBuildableComponents pkg + +lookupComponent :: PackageDescription -> ComponentName -> Maybe Component +lookupComponent pkg (CLibName name) = + fmap CLib $ find ((name ==) . libName) (allLibraries pkg) +lookupComponent pkg (CFLibName name) = + fmap CFLib $ find ((name ==) . foreignLibName) (foreignLibs pkg) +lookupComponent pkg (CExeName name) = + fmap CExe $ find ((name ==) . exeName) (executables pkg) +lookupComponent pkg (CTestName name) = + fmap CTest $ find ((name ==) . testName) (testSuites pkg) +lookupComponent pkg (CBenchName name) = + fmap CBench $ find ((name ==) . benchmarkName) (benchmarks pkg) + +getComponent :: PackageDescription -> ComponentName -> Component +getComponent pkg cname = + case lookupComponent pkg cname of + Just cpnt -> cpnt + Nothing -> missingComponent + where + missingComponent = + error $ "internal error: the package description contains no " + ++ "component corresponding to " ++ show cname + +-- ----------------------------------------------------------------------------- +-- Traversal Instances + +instance L.HasBuildInfos PackageDescription where + traverseBuildInfos f (PackageDescription a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 + x1 x2 x3 x4 x5 x6 + a20 a21 a22 a23 a24) = + PackageDescription a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 + <$> (traverse . L.buildInfo) f x1 -- library + <*> (traverse . L.buildInfo) f x2 -- sub libraries + <*> (traverse . L.buildInfo) f x3 -- executables + <*> (traverse . L.buildInfo) f x4 -- foreign libs + <*> (traverse . L.buildInfo) f x5 -- test suites + <*> (traverse . L.buildInfo) f x6 -- benchmarks + <*> pure a20 -- data files + <*> pure a21 -- data dir + <*> pure a22 -- extra src files + <*> pure a23 -- extra temp files + <*> pure a24 -- extra doc files diff --git a/cabal/Cabal-syntax/src/Distribution/Types/PackageDescription/Lens.hs b/cabal/Cabal-syntax/src/Distribution/Types/PackageDescription/Lens.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/PackageDescription/Lens.hs @@ -0,0 +1,221 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +module Distribution.Types.PackageDescription.Lens ( + PackageDescription, + module Distribution.Types.PackageDescription.Lens, + ) where + +import Distribution.Compat.Lens +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.CabalSpecVersion (CabalSpecVersion) +import Distribution.Compiler (CompilerFlavor) +import Distribution.License (License) +import Distribution.ModuleName (ModuleName) +import Distribution.Types.Benchmark (Benchmark, benchmarkModules) +import Distribution.Types.Benchmark.Lens (benchmarkBuildInfo, benchmarkName) +import Distribution.Types.BuildInfo (BuildInfo) +import Distribution.Types.BuildType (BuildType) +import Distribution.Types.ComponentName (ComponentName (..)) +import Distribution.Types.Executable (Executable, exeModules) +import Distribution.Types.Executable.Lens (exeBuildInfo, exeName) +import Distribution.Types.ForeignLib (ForeignLib, foreignLibModules) +import Distribution.Types.ForeignLib.Lens (foreignLibBuildInfo, foreignLibName) +import Distribution.Types.Library (Library, explicitLibModules) +import Distribution.Types.Library.Lens (libBuildInfo, libName) +import Distribution.Types.PackageDescription (PackageDescription) +import Distribution.Types.PackageId (PackageIdentifier) +import Distribution.Types.SetupBuildInfo (SetupBuildInfo) +import Distribution.Types.SourceRepo (SourceRepo) +import Distribution.Types.TestSuite (TestSuite, testModules) +import Distribution.Types.TestSuite.Lens (testBuildInfo, testName) +import Distribution.Utils.Path (LicenseFile, PackageDir, SymbolicPath) +import Distribution.Utils.ShortText (ShortText) +import Distribution.Version (VersionRange) + +import qualified Distribution.SPDX as SPDX +import qualified Distribution.Types.PackageDescription as T + +package :: Lens' PackageDescription PackageIdentifier +package f s = fmap (\x -> s { T.package = x }) (f (T.package s)) +{-# INLINE package #-} + +licenseRaw :: Lens' PackageDescription (Either SPDX.License License) +licenseRaw f s = fmap (\x -> s { T.licenseRaw = x }) (f (T.licenseRaw s)) +{-# INLINE licenseRaw #-} + +licenseFiles :: Lens' PackageDescription [SymbolicPath PackageDir LicenseFile] +licenseFiles f s = fmap (\x -> s { T.licenseFiles = x }) (f (T.licenseFiles s)) +{-# INLINE licenseFiles #-} + +copyright :: Lens' PackageDescription ShortText +copyright f s = fmap (\x -> s { T.copyright = x }) (f (T.copyright s)) +{-# INLINE copyright #-} + +maintainer :: Lens' PackageDescription ShortText +maintainer f s = fmap (\x -> s { T.maintainer = x }) (f (T.maintainer s)) +{-# INLINE maintainer #-} + +author :: Lens' PackageDescription ShortText +author f s = fmap (\x -> s { T.author = x }) (f (T.author s)) +{-# INLINE author #-} + +stability :: Lens' PackageDescription ShortText +stability f s = fmap (\x -> s { T.stability = x }) (f (T.stability s)) +{-# INLINE stability #-} + +testedWith :: Lens' PackageDescription [(CompilerFlavor,VersionRange)] +testedWith f s = fmap (\x -> s { T.testedWith = x }) (f (T.testedWith s)) +{-# INLINE testedWith #-} + +homepage :: Lens' PackageDescription ShortText +homepage f s = fmap (\x -> s { T.homepage = x }) (f (T.homepage s)) +{-# INLINE homepage #-} + +pkgUrl :: Lens' PackageDescription ShortText +pkgUrl f s = fmap (\x -> s { T.pkgUrl = x }) (f (T.pkgUrl s)) +{-# INLINE pkgUrl #-} + +bugReports :: Lens' PackageDescription ShortText +bugReports f s = fmap (\x -> s { T.bugReports = x }) (f (T.bugReports s)) +{-# INLINE bugReports #-} + +sourceRepos :: Lens' PackageDescription [SourceRepo] +sourceRepos f s = fmap (\x -> s { T.sourceRepos = x }) (f (T.sourceRepos s)) +{-# INLINE sourceRepos #-} + +synopsis :: Lens' PackageDescription ShortText +synopsis f s = fmap (\x -> s { T.synopsis = x }) (f (T.synopsis s)) +{-# INLINE synopsis #-} + +description :: Lens' PackageDescription ShortText +description f s = fmap (\x -> s { T.description = x }) (f (T.description s)) +{-# INLINE description #-} + +category :: Lens' PackageDescription ShortText +category f s = fmap (\x -> s { T.category = x }) (f (T.category s)) +{-# INLINE category #-} + +customFieldsPD :: Lens' PackageDescription [(String,String)] +customFieldsPD f s = fmap (\x -> s { T.customFieldsPD = x }) (f (T.customFieldsPD s)) +{-# INLINE customFieldsPD #-} + +specVersion :: Lens' PackageDescription CabalSpecVersion +specVersion f s = fmap (\x -> s { T.specVersion = x }) (f (T.specVersion s)) +{-# INLINE specVersion #-} + +buildTypeRaw :: Lens' PackageDescription (Maybe BuildType) +buildTypeRaw f s = fmap (\x -> s { T.buildTypeRaw = x }) (f (T.buildTypeRaw s)) +{-# INLINE buildTypeRaw #-} + +setupBuildInfo :: Lens' PackageDescription (Maybe SetupBuildInfo) +setupBuildInfo f s = fmap (\x -> s { T.setupBuildInfo = x }) (f (T.setupBuildInfo s)) +{-# INLINE setupBuildInfo #-} + +library :: Lens' PackageDescription (Maybe Library) +library f s = fmap (\x -> s { T.library = x }) (f (T.library s)) +{-# INLINE library #-} + +subLibraries :: Lens' PackageDescription [Library] +subLibraries f s = fmap (\x -> s { T.subLibraries = x }) (f (T.subLibraries s)) +{-# INLINE subLibraries #-} + +executables :: Lens' PackageDescription [Executable] +executables f s = fmap (\x -> s { T.executables = x }) (f (T.executables s)) +{-# INLINE executables #-} + +foreignLibs :: Lens' PackageDescription [ForeignLib] +foreignLibs f s = fmap (\x -> s { T.foreignLibs = x }) (f (T.foreignLibs s)) +{-# INLINE foreignLibs #-} + +testSuites :: Lens' PackageDescription [TestSuite] +testSuites f s = fmap (\x -> s { T.testSuites = x }) (f (T.testSuites s)) +{-# INLINE testSuites #-} + +benchmarks :: Lens' PackageDescription [Benchmark] +benchmarks f s = fmap (\x -> s { T.benchmarks = x }) (f (T.benchmarks s)) +{-# INLINE benchmarks #-} + +dataFiles :: Lens' PackageDescription [FilePath] +dataFiles f s = fmap (\x -> s { T.dataFiles = x }) (f (T.dataFiles s)) +{-# INLINE dataFiles #-} + +dataDir :: Lens' PackageDescription FilePath +dataDir f s = fmap (\x -> s { T.dataDir = x }) (f (T.dataDir s)) +{-# INLINE dataDir #-} + +extraSrcFiles :: Lens' PackageDescription [String] +extraSrcFiles f s = fmap (\x -> s { T.extraSrcFiles = x }) (f (T.extraSrcFiles s)) +{-# INLINE extraSrcFiles #-} + +extraTmpFiles :: Lens' PackageDescription [String] +extraTmpFiles f s = fmap (\x -> s { T.extraTmpFiles = x }) (f (T.extraTmpFiles s)) +{-# INLINE extraTmpFiles #-} + +extraDocFiles :: Lens' PackageDescription [String] +extraDocFiles f s = fmap (\x -> s { T.extraDocFiles = x }) (f (T.extraDocFiles s)) +{-# INLINE extraDocFiles #-} + +-- | @since 3.0.0.0 +allLibraries :: Traversal' PackageDescription Library +allLibraries f pd = mk <$> traverse f (T.library pd) <*> traverse f (T.subLibraries pd) + where + mk l ls = pd { T.library = l, T.subLibraries = ls } + +-- | @since 2.4 +componentModules :: Monoid r => ComponentName -> Getting r PackageDescription [ModuleName] +componentModules cname = case cname of + CLibName name -> + componentModules' name allLibraries libName explicitLibModules + CFLibName name -> + componentModules' name (foreignLibs . traverse) foreignLibName foreignLibModules + CExeName name -> + componentModules' name (executables . traverse) exeName exeModules + CTestName name -> + componentModules' name (testSuites . traverse) testName testModules + CBenchName name -> + componentModules' name (benchmarks . traverse) benchmarkName benchmarkModules + where + componentModules' + :: (Eq name, Monoid r) + => name + -> Traversal' PackageDescription a + -> Lens' a name + -> (a -> [ModuleName]) + -> Getting r PackageDescription [ModuleName] + componentModules' name pdL nameL modules = + pdL + . filtered ((== name) . view nameL) + . getting modules + + filtered :: (a -> Bool) -> Traversal' a a + filtered p f s = if p s then f s else pure s + +-- | @since 2.4 +componentBuildInfo :: ComponentName -> Traversal' PackageDescription BuildInfo +componentBuildInfo cname = case cname of + CLibName name -> + componentBuildInfo' name allLibraries libName libBuildInfo + CFLibName name -> + componentBuildInfo' name (foreignLibs . traverse) foreignLibName foreignLibBuildInfo + CExeName name -> + componentBuildInfo' name (executables . traverse) exeName exeBuildInfo + CTestName name -> + componentBuildInfo' name (testSuites . traverse) testName testBuildInfo + CBenchName name -> + componentBuildInfo' name (benchmarks . traverse) benchmarkName benchmarkBuildInfo + where + componentBuildInfo' :: Eq name + => name + -> Traversal' PackageDescription a + -> Lens' a name + -> Traversal' a BuildInfo + -> Traversal' PackageDescription BuildInfo + componentBuildInfo' name pdL nameL biL = + pdL + . filtered ((== name) . view nameL) + . biL + + filtered :: (a -> Bool) -> Traversal' a a + filtered p f s = if p s then f s else pure s diff --git a/cabal/Cabal-syntax/src/Distribution/Types/PackageId.hs b/cabal/Cabal-syntax/src/Distribution/Types/PackageId.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/PackageId.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Types.PackageId + ( PackageIdentifier(..) + , PackageId + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Parsec (Parsec (..), simpleParsec) +import Distribution.Pretty +import Distribution.Types.PackageName +import Distribution.Version (Version, nullVersion) + +import qualified Data.List.NonEmpty as NE +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as Disp + +-- | Type alias so we can use the shorter name PackageId. +type PackageId = PackageIdentifier + +-- | The name and version of a package. +data PackageIdentifier + = PackageIdentifier { + pkgName :: PackageName, -- ^The name of this package, eg. foo + pkgVersion :: Version -- ^the version of this package, eg 1.2 + } + deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) + +instance Binary PackageIdentifier +instance Structured PackageIdentifier + +instance Pretty PackageIdentifier where + pretty (PackageIdentifier n v) + | v == nullVersion = pretty n -- if no version, don't show version. + | otherwise = pretty n <<>> Disp.char '-' <<>> pretty v + +-- | +-- +-- >>> simpleParsec "foo-bar-0" :: Maybe PackageIdentifier +-- Just (PackageIdentifier {pkgName = PackageName "foo-bar", pkgVersion = mkVersion [0]}) +-- +-- >>> simpleParsec "foo-bar" :: Maybe PackageIdentifier +-- Just (PackageIdentifier {pkgName = PackageName "foo-bar", pkgVersion = mkVersion []}) +-- +-- /Note:/ Stricter than 'Text' instance +-- +-- >>> simpleParsec "foo-bar-0-0" :: Maybe PackageIdentifier +-- Nothing +-- +-- >>> simpleParsec "foo-bar.0" :: Maybe PackageIdentifier +-- Nothing +-- +-- >>> simpleParsec "foo-bar.4-2" :: Maybe PackageIdentifier +-- Nothing +-- +-- >>> simpleParsec "1.2.3" :: Maybe PackageIdentifier +-- Nothing +-- +instance Parsec PackageIdentifier where + parsec = do + xs' <- P.sepByNonEmpty component (P.char '-') + (v, xs) <- case simpleParsec (NE.last xs') of + Nothing -> return (nullVersion, toList xs') -- all components are version + Just v -> return (v, NE.init xs') + if not (null xs) && all (\c -> all (/= '.') c && not (all isDigit c)) xs + then return $ PackageIdentifier (mkPackageName (intercalate "-" xs)) v + else fail "all digits or a dot in a portion of package name" + where + component = P.munch1 (\c -> isAlphaNum c || c == '.') + +instance NFData PackageIdentifier where + rnf (PackageIdentifier name version) = rnf name `seq` rnf version diff --git a/cabal/Cabal-syntax/src/Distribution/Types/PackageId/Lens.hs b/cabal/Cabal-syntax/src/Distribution/Types/PackageId/Lens.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/PackageId/Lens.hs @@ -0,0 +1,22 @@ +module Distribution.Types.PackageId.Lens ( + PackageIdentifier, + module Distribution.Types.PackageId.Lens, + ) where + +import Distribution.Compat.Lens +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Types.PackageId (PackageIdentifier) +import Distribution.Types.PackageName (PackageName) +import Distribution.Version (Version) + +import qualified Distribution.Types.PackageId as T + +pkgName :: Lens' PackageIdentifier PackageName +pkgName f s = fmap (\x -> s { T.pkgName = x }) (f (T.pkgName s)) +{-# INLINE pkgName #-} + +pkgVersion :: Lens' PackageIdentifier Version +pkgVersion f s = fmap (\x -> s { T.pkgVersion = x }) (f (T.pkgVersion s)) +{-# INLINE pkgVersion #-} diff --git a/cabal/Cabal-syntax/src/Distribution/Types/PackageName.hs b/cabal/Cabal-syntax/src/Distribution/Types/PackageName.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/PackageName.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Types.PackageName + ( PackageName + , unPackageName, mkPackageName + , unPackageNameST, mkPackageNameST + ) where + +import Prelude () +import Distribution.Compat.Prelude +import Distribution.Utils.ShortText + +import qualified Text.PrettyPrint as Disp +import Distribution.Pretty +import Distribution.Parsec + +-- | A package name. +-- +-- Use 'mkPackageName' and 'unPackageName' to convert from/to a +-- 'String'. +-- +-- This type is opaque since @Cabal-2.0@ +-- +-- @since 2.0.0.2 +newtype PackageName = PackageName ShortText + deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) + +-- | Convert 'PackageName' to 'String' +unPackageName :: PackageName -> String +unPackageName (PackageName s) = fromShortText s + +-- | @since 3.4.0.0 +unPackageNameST :: PackageName -> ShortText +unPackageNameST (PackageName s) = s + +-- | Construct a 'PackageName' from a 'String' +-- +-- 'mkPackageName' is the inverse to 'unPackageName' +-- +-- Note: No validations are performed to ensure that the resulting +-- 'PackageName' is valid +-- +-- @since 2.0.0.2 +mkPackageName :: String -> PackageName +mkPackageName = PackageName . toShortText + +-- | Construct a 'PackageName' from a 'ShortText' +-- +-- Note: No validations are performed to ensure that the resulting +-- 'PackageName' is valid +-- +-- @since 3.4.0.0 +mkPackageNameST :: ShortText -> PackageName +mkPackageNameST = PackageName + +-- | 'mkPackageName' +-- +-- @since 2.0.0.2 +instance IsString PackageName where + fromString = mkPackageName + +instance Binary PackageName +instance Structured PackageName + +instance Pretty PackageName where + pretty = Disp.text . unPackageName + +instance Parsec PackageName where + parsec = mkPackageName <$> parsecUnqualComponentName + +instance NFData PackageName where + rnf (PackageName pkg) = rnf pkg diff --git a/cabal/Cabal-syntax/src/Distribution/Types/PackageVersionConstraint.hs b/cabal/Cabal-syntax/src/Distribution/Types/PackageVersionConstraint.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/PackageVersionConstraint.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Types.PackageVersionConstraint ( + PackageVersionConstraint(..), + thisPackageVersionConstraint, + simplifyPackageVersionConstraint, +) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Parsec +import Distribution.Pretty +import Distribution.Types.PackageId +import Distribution.Types.PackageName +import Distribution.Types.Version +import Distribution.Types.VersionRange.Internal +import Distribution.Version (simplifyVersionRange) + +import qualified Distribution.Compat.CharParsing as P + +-- | A version constraint on a package. Different from 'ExeDependency' and +-- 'Dependency' since it does not specify the need for a component, not even +-- the main library. +-- There are a few places in the codebase where 'Dependency' was used where +-- 'PackageVersionConstraint' is not used instead (#5570). +data PackageVersionConstraint = PackageVersionConstraint PackageName VersionRange + deriving (Generic, Read, Show, Eq, Typeable, Data) + +instance Binary PackageVersionConstraint +instance Structured PackageVersionConstraint +instance NFData PackageVersionConstraint where rnf = genericRnf + +instance Pretty PackageVersionConstraint where + -- Cannot do: PackageVersionConstraint have to be parseable + -- as Dependency, due roundtrip problems. (e.g. talking to old ./Setup). + -- + -- pretty (PackageVersionConstraint name (ThisVersion ver)) = + -- pretty (PackageIdentifier name ver) + pretty (PackageVersionConstraint name ver) = + pretty name <+> pretty ver + +-- | +-- +-- >>> simpleParsec "foo" :: Maybe PackageVersionConstraint +-- Just (PackageVersionConstraint (PackageName "foo") (OrLaterVersion (mkVersion [0]))) +-- +-- >>> simpleParsec "foo >=2.0" :: Maybe PackageVersionConstraint +-- Just (PackageVersionConstraint (PackageName "foo") (OrLaterVersion (mkVersion [2,0]))) +-- +-- >>> simpleParsec "foo-2.0" :: Maybe PackageVersionConstraint +-- Just (PackageVersionConstraint (PackageName "foo") (ThisVersion (mkVersion [2,0]))) +-- +instance Parsec PackageVersionConstraint where + parsec = do + PackageIdentifier name ver <- parsec + if ver == nullVersion + then do + P.spaces + vr <- parsec <|> return anyVersion + P.spaces + return (PackageVersionConstraint name vr) + else + pure (PackageVersionConstraint name (thisVersion ver)) + +-- | @since 3.4.0.0 +thisPackageVersionConstraint :: PackageIdentifier -> PackageVersionConstraint +thisPackageVersionConstraint (PackageIdentifier pn vr) = + PackageVersionConstraint pn (thisVersion vr) + +-- | @since 3.4.0.0 +simplifyPackageVersionConstraint :: PackageVersionConstraint -> PackageVersionConstraint +simplifyPackageVersionConstraint (PackageVersionConstraint pn vr) = + PackageVersionConstraint pn (simplifyVersionRange vr) diff --git a/cabal/Cabal-syntax/src/Distribution/Types/PkgconfigDependency.hs b/cabal/Cabal-syntax/src/Distribution/Types/PkgconfigDependency.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/PkgconfigDependency.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Types.PkgconfigDependency + ( PkgconfigDependency(..) + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Types.PkgconfigName +import Distribution.Types.PkgconfigVersionRange + +import Distribution.Parsec +import Distribution.Pretty + +import qualified Distribution.Compat.CharParsing as P + +-- | Describes a dependency on a pkg-config library +-- +-- @since 2.0.0.2 +data PkgconfigDependency = PkgconfigDependency + PkgconfigName + PkgconfigVersionRange + deriving (Generic, Read, Show, Eq, Typeable, Data) + +instance Binary PkgconfigDependency +instance Structured PkgconfigDependency +instance NFData PkgconfigDependency where rnf = genericRnf + +instance Pretty PkgconfigDependency where + pretty (PkgconfigDependency name PcAnyVersion) = pretty name + pretty (PkgconfigDependency name ver) = pretty name <+> pretty ver + +instance Parsec PkgconfigDependency where + parsec = do + name <- parsec + P.spaces + verRange <- parsec <|> pure anyPkgconfigVersion + pure $ PkgconfigDependency name verRange diff --git a/cabal/Cabal-syntax/src/Distribution/Types/PkgconfigName.hs b/cabal/Cabal-syntax/src/Distribution/Types/PkgconfigName.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/PkgconfigName.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Types.PkgconfigName + ( PkgconfigName, unPkgconfigName, mkPkgconfigName + ) where + +import Prelude () +import Distribution.Compat.Prelude +import Distribution.Utils.ShortText + +import Distribution.Pretty +import Distribution.Parsec + +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as Disp + +-- | A pkg-config library name +-- +-- This is parsed as any valid argument to the pkg-config utility. +-- +-- @since 2.0.0.2 +newtype PkgconfigName = PkgconfigName ShortText + deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) + +-- | Convert 'PkgconfigName' to 'String' +-- +-- @since 2.0.0.2 +unPkgconfigName :: PkgconfigName -> String +unPkgconfigName (PkgconfigName s) = fromShortText s + +-- | Construct a 'PkgconfigName' from a 'String' +-- +-- 'mkPkgconfigName' is the inverse to 'unPkgconfigName' +-- +-- Note: No validations are performed to ensure that the resulting +-- 'PkgconfigName' is valid +-- +-- @since 2.0.0.2 +mkPkgconfigName :: String -> PkgconfigName +mkPkgconfigName = PkgconfigName . toShortText + +-- | 'mkPkgconfigName' +-- +-- @since 2.0.0.2 +instance IsString PkgconfigName where + fromString = mkPkgconfigName + +instance Binary PkgconfigName +instance Structured PkgconfigName + +-- pkg-config allows versions and other letters in package names, eg +-- "gtk+-2.0" is a valid pkg-config package _name_. It then has a package +-- version number like 2.10.13 +instance Pretty PkgconfigName where + pretty = Disp.text . unPkgconfigName + +instance Parsec PkgconfigName where + parsec = mkPkgconfigName <$> P.munch1 isNameChar where + -- https://gitlab.haskell.org/ghc/ghc/issues/17752 + isNameChar '-' = True + isNameChar '_' = True + isNameChar '.' = True + isNameChar '+' = True + isNameChar c = isAlphaNum c + +instance NFData PkgconfigName where + rnf (PkgconfigName pkg) = rnf pkg diff --git a/cabal/Cabal-syntax/src/Distribution/Types/PkgconfigVersion.hs b/cabal/Cabal-syntax/src/Distribution/Types/PkgconfigVersion.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/PkgconfigVersion.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +-- @since 3.0 +module Distribution.Types.PkgconfigVersion ( + PkgconfigVersion (..), + rpmvercmp, + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Parsec +import Distribution.Pretty +import Distribution.Utils.Generic (isAsciiAlphaNum) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as PP + +-- | @pkg-config@ versions. +-- +-- In fact, this can be arbitrary 'BS.ByteString', +-- but 'Parsec' instance is a little pickier. +-- +-- @since 3.0 +newtype PkgconfigVersion = PkgconfigVersion BS.ByteString + deriving (Generic, Read, Show, Typeable, Data) + +instance Eq PkgconfigVersion where + PkgconfigVersion a == PkgconfigVersion b = rpmvercmp a b == EQ + +instance Ord PkgconfigVersion where + PkgconfigVersion a `compare` PkgconfigVersion b = rpmvercmp a b + +instance Binary PkgconfigVersion +instance Structured PkgconfigVersion +instance NFData PkgconfigVersion where rnf = genericRnf + +instance Pretty PkgconfigVersion where + pretty (PkgconfigVersion bs) = PP.text (BS8.unpack bs) + +-- | +-- +-- >>> simpleParsec "1.0.2n" :: Maybe PkgconfigVersion +-- Just (PkgconfigVersion "1.0.2n") +-- +-- >>> simpleParsec "0.3.5+ds" :: Maybe PkgconfigVersion +-- Nothing +-- +instance Parsec PkgconfigVersion where + parsec = PkgconfigVersion . BS8.pack <$> P.munch1 predicate where + predicate c = isAsciiAlphaNum c || c == '.' || c == '-' + +------------------------------------------------------------------------------- +-- rmpvercmp - pure Haskell implementation +------------------------------------------------------------------------------- + +-- | Compare two version strings as @pkg-config@ would compare them. +-- +-- @since 3.0 +rpmvercmp :: BS.ByteString -> BS.ByteString -> Ordering +rpmvercmp a b = go0 (BS.unpack a) (BS.unpack b) + where + go0 :: [Word8] -> [Word8] -> Ordering + -- if there is _any_ trailing "garbage", it seems to affect result + -- https://github.com/haskell/cabal/issues/6805 + go0 [] [] = EQ + go0 [] _ = LT + go0 _ [] = GT + go0 xs ys = go1 (dropNonAlnum8 xs) (dropNonAlnum8 ys) + + go1 :: [Word8] -> [Word8] -> Ordering + go1 [] [] = EQ + go1 [] _ = LT + go1 _ [] = GT + go1 xs@(x:_) ys + | isDigit8 x = + let (xs1, xs2) = span isDigit8 xs + (ys1, ys2) = span isDigit8 ys + -- numeric segments are always newer than alpha segments + in if null ys1 + then GT + else compareInt xs1 ys1 <> go0 xs2 ys2 + + -- isAlpha + | otherwise = + let (xs1, xs2) = span isAlpha8 xs + (ys1, ys2) = span isAlpha8 ys + in if null ys1 + then LT + else compareStr xs1 ys1 <> go0 xs2 ys2 + +-- compare as numbers +compareInt :: [Word8] -> [Word8] -> Ordering +compareInt xs ys = + -- whichever number has more digits wins + compare (length xs') (length ys') <> + -- equal length: use per character compare, "strcmp" + compare xs' ys' + where + -- drop leading zeros + xs' = dropWhile (== 0x30) xs + ys' = dropWhile (== 0x30) ys + +-- strcmp +compareStr :: [Word8] -> [Word8] -> Ordering +compareStr = compare + +dropNonAlnum8 :: [Word8] -> [Word8] +dropNonAlnum8 = dropWhile (\w -> not (isDigit8 w || isAlpha8 w)) + +isDigit8 :: Word8 -> Bool +isDigit8 w = 0x30 <= w && w <= 0x39 + +isAlpha8 :: Word8 -> Bool +isAlpha8 w = (0x41 <= w && w <= 0x5A) || (0x61 <= w && w <= 0x7A) + + diff --git a/cabal/Cabal-syntax/src/Distribution/Types/PkgconfigVersionRange.hs b/cabal/Cabal-syntax/src/Distribution/Types/PkgconfigVersionRange.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/PkgconfigVersionRange.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Types.PkgconfigVersionRange ( + PkgconfigVersionRange (..), + anyPkgconfigVersion, + isAnyPkgconfigVersion, + withinPkgconfigVersionRange, + -- * Internal + versionToPkgconfigVersion, + versionRangeToPkgconfigVersionRange, + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.CabalSpecVersion +import Distribution.Parsec +import Distribution.Pretty +import Distribution.Types.PkgconfigVersion +import Distribution.Types.Version +import Distribution.Types.VersionInterval +import Distribution.Types.VersionRange + +import qualified Data.ByteString.Char8 as BS8 +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as PP + +-- | @since 3.0 +data PkgconfigVersionRange + = PcAnyVersion + | PcThisVersion PkgconfigVersion -- = version + | PcLaterVersion PkgconfigVersion -- > version (NB. not >=) + | PcEarlierVersion PkgconfigVersion -- < version + | PcOrLaterVersion PkgconfigVersion -- >= version + | PcOrEarlierVersion PkgconfigVersion -- =< version + | PcUnionVersionRanges PkgconfigVersionRange PkgconfigVersionRange + | PcIntersectVersionRanges PkgconfigVersionRange PkgconfigVersionRange + deriving (Generic, Read, Show, Eq, Typeable, Data) + +instance Binary PkgconfigVersionRange +instance Structured PkgconfigVersionRange +instance NFData PkgconfigVersionRange where rnf = genericRnf + +instance Pretty PkgconfigVersionRange where + pretty = pp 0 where + pp :: Int -> PkgconfigVersionRange -> PP.Doc + pp _ PcAnyVersion = PP.text "-any" + pp _ (PcThisVersion v) = PP.text "==" <<>> pretty v + pp _ (PcLaterVersion v) = PP.text ">" <<>> pretty v + pp _ (PcEarlierVersion v) = PP.text "<" <<>> pretty v + pp _ (PcOrLaterVersion v) = PP.text ">=" <<>> pretty v + pp _ (PcOrEarlierVersion v) = PP.text "<=" <<>> pretty v + + pp d (PcUnionVersionRanges v u) = parens (d >= 1) $ + pp 1 v PP.<+> PP.text "||" PP.<+> pp 0 u + pp d (PcIntersectVersionRanges v u) = parens (d >= 2) $ + pp 2 v PP.<+> PP.text "&&" PP.<+> pp 1 u + + parens True = PP.parens + parens False = id + +instance Parsec PkgconfigVersionRange where + -- note: the wildcard is used in some places, e.g + -- http://hackage.haskell.org/package/bindings-libzip-0.10.1/bindings-libzip.cabal + -- + -- however, in the presence of alphanumerics etc. lax version parser, + -- wildcard is ill-specified + + parsec = do + csv <- askCabalSpecVersion + if csv >= CabalSpecV3_0 + then pkgconfigParser + else versionRangeToPkgconfigVersionRange <$> versionRangeParser P.integral csv + +-- "modern" parser of @pkg-config@ package versions. +pkgconfigParser :: CabalParsing m => m PkgconfigVersionRange +pkgconfigParser = P.spaces >> expr where + -- every parser here eats trailing space + expr = do + ts <- term `P.sepByNonEmpty` (P.string "||" >> P.spaces) + return $ foldr1 PcUnionVersionRanges ts + + term = do + fs <- factor `P.sepByNonEmpty` (P.string "&&" >> P.spaces) + return $ foldr1 PcIntersectVersionRanges fs + + factor = parens expr <|> prim + + prim = do + op <- P.munch1 isOpChar P. "operator" + case op of + "-" -> anyPkgconfigVersion <$ (P.string "any" *> P.spaces) + + "==" -> afterOp PcThisVersion + ">" -> afterOp PcLaterVersion + "<" -> afterOp PcEarlierVersion + ">=" -> afterOp PcOrLaterVersion + "<=" -> afterOp PcOrEarlierVersion + + _ -> P.unexpected $ "Unknown version operator " ++ show op + + -- https://gitlab.haskell.org/ghc/ghc/issues/17752 + isOpChar '<' = True + isOpChar '=' = True + isOpChar '>' = True + isOpChar '^' = True + isOpChar '-' = True + isOpChar _ = False + + afterOp f = do + P.spaces + v <- parsec + P.spaces + return (f v) + + parens = P.between + ((P.char '(' P. "opening paren") >> P.spaces) + (P.char ')' >> P.spaces) + +anyPkgconfigVersion :: PkgconfigVersionRange +anyPkgconfigVersion = PcAnyVersion + +-- | TODO: this is not precise, but used only to prettify output. +isAnyPkgconfigVersion :: PkgconfigVersionRange -> Bool +isAnyPkgconfigVersion = (== PcAnyVersion) + +withinPkgconfigVersionRange :: PkgconfigVersion -> PkgconfigVersionRange -> Bool +withinPkgconfigVersionRange v = go where + go PcAnyVersion = True + go (PcThisVersion u) = v == u + go (PcLaterVersion u) = v > u + go (PcEarlierVersion u) = v < u + go (PcOrLaterVersion u) = v >= u + go (PcOrEarlierVersion u) = v <= u + go (PcUnionVersionRanges a b) = go a || go b + go (PcIntersectVersionRanges a b) = go a && go b + +------------------------------------------------------------------------------- +-- Conversion +------------------------------------------------------------------------------- + +versionToPkgconfigVersion :: Version -> PkgconfigVersion +versionToPkgconfigVersion = PkgconfigVersion . BS8.pack . prettyShow + +versionRangeToPkgconfigVersionRange :: VersionRange -> PkgconfigVersionRange +versionRangeToPkgconfigVersionRange vr + | isAnyVersion vr + = PcAnyVersion + | otherwise + = case asVersionIntervals vr of + [] -> PcEarlierVersion (PkgconfigVersion (BS8.pack "0")) + (i:is) -> foldl (\r j -> PcUnionVersionRanges r (conv j)) (conv i) is + where + conv (VersionInterval (LowerBound v b) NoUpperBound) = convL v b + conv (VersionInterval (LowerBound v b) (UpperBound u c)) = PcIntersectVersionRanges (convL v b) (convU u c) + + convL v ExclusiveBound = PcLaterVersion (versionToPkgconfigVersion v) + convL v InclusiveBound = PcOrLaterVersion (versionToPkgconfigVersion v) + + convU v ExclusiveBound = PcEarlierVersion (versionToPkgconfigVersion v) + convU v InclusiveBound = PcOrEarlierVersion (versionToPkgconfigVersion v) diff --git a/cabal/Cabal-syntax/src/Distribution/Types/SetupBuildInfo.hs b/cabal/Cabal-syntax/src/Distribution/Types/SetupBuildInfo.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/SetupBuildInfo.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +module Distribution.Types.SetupBuildInfo ( + SetupBuildInfo(..) +) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Types.Dependency + +-- --------------------------------------------------------------------------- +-- The SetupBuildInfo type + +-- One can see this as a very cut-down version of BuildInfo below. +-- To keep things simple for tools that compile Setup.hs we limit the +-- options authors can specify to just Haskell package dependencies. + +data SetupBuildInfo = SetupBuildInfo + { setupDepends :: [Dependency] + , defaultSetupDepends :: Bool + -- ^ Is this a default 'custom-setup' section added by the cabal-install + -- code (as opposed to user-provided)? This field is only used + -- internally, and doesn't correspond to anything in the .cabal + -- file. See #3199. + } + deriving (Generic, Show, Eq, Read, Typeable, Data) + +instance Binary SetupBuildInfo +instance Structured SetupBuildInfo +instance NFData SetupBuildInfo where rnf = genericRnf + +instance Monoid SetupBuildInfo where + mempty = SetupBuildInfo [] False + mappend = (<>) + +instance Semigroup SetupBuildInfo where + a <> b = SetupBuildInfo + (setupDepends a <> setupDepends b) + (defaultSetupDepends a || defaultSetupDepends b) diff --git a/cabal/Cabal-syntax/src/Distribution/Types/SetupBuildInfo/Lens.hs b/cabal/Cabal-syntax/src/Distribution/Types/SetupBuildInfo/Lens.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/SetupBuildInfo/Lens.hs @@ -0,0 +1,21 @@ +module Distribution.Types.SetupBuildInfo.Lens ( + SetupBuildInfo, + module Distribution.Types.SetupBuildInfo.Lens, + ) where + +import Distribution.Compat.Lens +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Types.Dependency (Dependency) +import Distribution.Types.SetupBuildInfo (SetupBuildInfo) + +import qualified Distribution.Types.SetupBuildInfo as T + +setupDepends :: Lens' SetupBuildInfo [Dependency] +setupDepends f s = fmap (\x -> s { T.setupDepends = x }) (f (T.setupDepends s)) +{-# INLINE setupDepends #-} + +defaultSetupDepends :: Lens' SetupBuildInfo Bool +defaultSetupDepends f s = fmap (\x -> s { T.defaultSetupDepends = x }) (f (T.defaultSetupDepends s)) +{-# INLINE defaultSetupDepends #-} diff --git a/cabal/Cabal-syntax/src/Distribution/Types/SourceRepo.hs b/cabal/Cabal-syntax/src/Distribution/Types/SourceRepo.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/SourceRepo.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +module Distribution.Types.SourceRepo ( + SourceRepo(..), + RepoKind(..), + RepoType(..), + KnownRepoType (..), + knownRepoTypes, + emptySourceRepo, + classifyRepoType, + classifyRepoKind, + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Utils.Generic (lowercase) + +import Distribution.Pretty +import Distribution.Parsec + +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as Disp +import qualified Data.Map.Strict as M + +-- ------------------------------------------------------------ +-- * Source repos +-- ------------------------------------------------------------ + +-- | Information about the source revision control system for a package. +-- +-- When specifying a repo it is useful to know the meaning or intention of the +-- information as doing so enables automation. There are two obvious common +-- purposes: one is to find the repo for the latest development version, the +-- other is to find the repo for this specific release. The 'ReopKind' +-- specifies which one we mean (or another custom one). +-- +-- A package can specify one or the other kind or both. Most will specify just +-- a head repo but some may want to specify a repo to reconstruct the sources +-- for this package release. +-- +-- The required information is the 'RepoType' which tells us if it's using +-- 'Darcs', 'Git' for example. The 'repoLocation' and other details are +-- interpreted according to the repo type. +-- +data SourceRepo = SourceRepo { + -- | The kind of repo. This field is required. + repoKind :: RepoKind, + + -- | The type of the source repository system for this repo, eg 'Darcs' or + -- 'Git'. This field is required. + repoType :: Maybe RepoType, + + -- | The location of the repository. For most 'RepoType's this is a URL. + -- This field is required. + repoLocation :: Maybe String, + + -- | 'CVS' can put multiple \"modules\" on one server and requires a + -- module name in addition to the location to identify a particular repo. + -- Logically this is part of the location but unfortunately has to be + -- specified separately. This field is required for the 'CVS' 'RepoType' and + -- should not be given otherwise. + repoModule :: Maybe String, + + -- | The name or identifier of the branch, if any. Many source control + -- systems have the notion of multiple branches in a repo that exist in the + -- same location. For example 'Git' and 'CVS' use this while systems like + -- 'Darcs' use different locations for different branches. This field is + -- optional but should be used if necessary to identify the sources, + -- especially for the 'RepoThis' repo kind. + repoBranch :: Maybe String, + + -- | The tag identify a particular state of the repository. This should be + -- given for the 'RepoThis' repo kind and not for 'RepoHead' kind. + -- + repoTag :: Maybe String, + + -- | Some repositories contain multiple projects in different subdirectories + -- This field specifies the subdirectory where this packages sources can be + -- found, eg the subdirectory containing the @.cabal@ file. It is interpreted + -- relative to the root of the repository. This field is optional. If not + -- given the default is \".\" ie no subdirectory. + repoSubdir :: Maybe FilePath +} + deriving (Eq, Ord, Generic, Read, Show, Typeable, Data) + +emptySourceRepo :: RepoKind -> SourceRepo +emptySourceRepo kind = SourceRepo + { repoKind = kind + , repoType = Nothing + , repoLocation = Nothing + , repoModule = Nothing + , repoBranch = Nothing + , repoTag = Nothing + , repoSubdir = Nothing + } + +instance Binary SourceRepo +instance Structured SourceRepo +instance NFData SourceRepo where rnf = genericRnf + +-- | What this repo info is for, what it represents. +-- +data RepoKind = + -- | The repository for the \"head\" or development version of the project. + -- This repo is where we should track the latest development activity or + -- the usual repo people should get to contribute patches. + RepoHead + + -- | The repository containing the sources for this exact package version + -- or release. For this kind of repo a tag should be given to give enough + -- information to re-create the exact sources. + | RepoThis + + | RepoKindUnknown String + deriving (Eq, Generic, Ord, Read, Show, Typeable, Data) + +instance Binary RepoKind +instance Structured RepoKind +instance NFData RepoKind where rnf = genericRnf + +-- | An enumeration of common source control systems. The fields used in the +-- 'SourceRepo' depend on the type of repo. The tools and methods used to +-- obtain and track the repo depend on the repo type. +-- +data KnownRepoType = Darcs | Git | SVN | CVS + | Mercurial | GnuArch | Bazaar | Monotone + | Pijul -- ^ @since 3.4.0.0 + deriving (Eq, Generic, Ord, Read, Show, Typeable, Data, Enum, Bounded) + +instance Binary KnownRepoType +instance Structured KnownRepoType +instance NFData KnownRepoType where rnf = genericRnf + +instance Parsec KnownRepoType where + parsec = do + str <- P.munch1 isIdent + maybe + (P.unexpected $ "Could not parse KnownRepoType from " ++ str) + return + (M.lookup str knownRepoTypeMap) + +instance Pretty KnownRepoType where + pretty = Disp.text . lowercase . show + +data RepoType = KnownRepoType KnownRepoType + | OtherRepoType String + deriving (Eq, Generic, Ord, Read, Show, Typeable, Data) + +instance Binary RepoType +instance Structured RepoType +instance NFData RepoType where rnf = genericRnf + +knownRepoTypes :: [KnownRepoType] +knownRepoTypes = [minBound .. maxBound] + +repoTypeAliases :: KnownRepoType -> [String] +repoTypeAliases Bazaar = ["bzr"] +repoTypeAliases Mercurial = ["hg"] +repoTypeAliases GnuArch = ["arch"] +repoTypeAliases _ = [] + +instance Pretty RepoKind where + pretty RepoHead = Disp.text "head" + pretty RepoThis = Disp.text "this" + pretty (RepoKindUnknown other) = Disp.text other + +instance Parsec RepoKind where + parsec = classifyRepoKind <$> P.munch1 isIdent + +classifyRepoKind :: String -> RepoKind +classifyRepoKind name = case lowercase name of + "head" -> RepoHead + "this" -> RepoThis + _ -> RepoKindUnknown name + +instance Parsec RepoType where + parsec = classifyRepoType <$> P.munch1 isIdent + +instance Pretty RepoType where + pretty (OtherRepoType other) = Disp.text other + pretty (KnownRepoType t) = pretty t + +classifyRepoType :: String -> RepoType +classifyRepoType s = + maybe + (OtherRepoType s) + KnownRepoType + (M.lookup (lowercase s) knownRepoTypeMap) + +knownRepoTypeMap :: Map String KnownRepoType +knownRepoTypeMap = + M.fromList + [ (name, repoType') + | repoType' <- knownRepoTypes + , name <- prettyShow repoType' : repoTypeAliases repoType' + ] + +isIdent :: Char -> Bool +isIdent c = isAlphaNum c || c == '_' || c == '-' diff --git a/cabal/Cabal-syntax/src/Distribution/Types/SourceRepo/Lens.hs b/cabal/Cabal-syntax/src/Distribution/Types/SourceRepo/Lens.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/SourceRepo/Lens.hs @@ -0,0 +1,39 @@ +module Distribution.Types.SourceRepo.Lens ( + T.SourceRepo, + module Distribution.Types.SourceRepo.Lens, + ) where + +import Prelude() +import Distribution.Compat.Prelude +import Distribution.Compat.Lens + +import Distribution.Types.SourceRepo (SourceRepo, RepoKind, RepoType) +import qualified Distribution.Types.SourceRepo as T + +repoKind :: Lens' SourceRepo RepoKind +repoKind f s = fmap (\x -> s { T.repoKind = x }) (f (T.repoKind s)) +{-# INLINE repoKind #-} + +repoType :: Lens' SourceRepo (Maybe RepoType) +repoType f s = fmap (\x -> s { T.repoType = x }) (f (T.repoType s)) +{-# INLINE repoType #-} + +repoLocation :: Lens' SourceRepo (Maybe String) +repoLocation f s = fmap (\x -> s { T.repoLocation = x }) (f (T.repoLocation s)) +{-# INLINE repoLocation #-} + +repoModule :: Lens' SourceRepo (Maybe String) +repoModule f s = fmap (\x -> s { T.repoModule = x }) (f (T.repoModule s)) +{-# INLINE repoModule #-} + +repoBranch :: Lens' SourceRepo (Maybe String) +repoBranch f s = fmap (\x -> s { T.repoBranch = x }) (f (T.repoBranch s)) +{-# INLINE repoBranch #-} + +repoTag :: Lens' SourceRepo (Maybe String) +repoTag f s = fmap (\x -> s { T.repoTag = x }) (f (T.repoTag s)) +{-# INLINE repoTag #-} + +repoSubdir :: Lens' SourceRepo (Maybe FilePath) +repoSubdir f s = fmap (\x -> s { T.repoSubdir = x }) (f (T.repoSubdir s)) +{-# INLINE repoSubdir #-} diff --git a/cabal/Cabal-syntax/src/Distribution/Types/TestSuite.hs b/cabal/Cabal-syntax/src/Distribution/Types/TestSuite.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/TestSuite.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NoMonoLocalBinds #-} + +module Distribution.Types.TestSuite ( + TestSuite(..), + emptyTestSuite, + testType, + testModules, + testModulesAutogen +) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Types.BuildInfo +import Distribution.Types.TestType +import Distribution.Types.TestSuiteInterface +import Distribution.Types.UnqualComponentName + +import Distribution.ModuleName + +import qualified Distribution.Types.BuildInfo.Lens as L + +-- | A \"test-suite\" stanza in a cabal file. +-- +data TestSuite = TestSuite { + testName :: UnqualComponentName, + testInterface :: TestSuiteInterface, + testBuildInfo :: BuildInfo, + testCodeGenerators :: [String] + } + deriving (Generic, Show, Read, Eq, Typeable, Data) + +instance L.HasBuildInfo TestSuite where + buildInfo f l = (\x -> l { testBuildInfo = x }) <$> f (testBuildInfo l) + +instance Binary TestSuite +instance Structured TestSuite + +instance NFData TestSuite where rnf = genericRnf + +instance Monoid TestSuite where + mempty = TestSuite { + testName = mempty, + testInterface = mempty, + testBuildInfo = mempty, + testCodeGenerators = mempty + } + mappend = (<>) + +instance Semigroup TestSuite where + a <> b = TestSuite { + testName = combine' testName, + testInterface = combine testInterface, + testBuildInfo = combine testBuildInfo, + testCodeGenerators = combine testCodeGenerators + } + where combine field = field a `mappend` field b + combine' field = case ( unUnqualComponentName $ field a + , unUnqualComponentName $ field b) of + ("", _) -> field b + (_, "") -> field a + (x, y) -> error $ "Ambiguous values for test field: '" + ++ x ++ "' and '" ++ y ++ "'" + +emptyTestSuite :: TestSuite +emptyTestSuite = mempty + + +testType :: TestSuite -> TestType +testType test = case testInterface test of + TestSuiteExeV10 ver _ -> TestTypeExe ver + TestSuiteLibV09 ver _ -> TestTypeLib ver + TestSuiteUnsupported testtype -> testtype + +-- | Get all the module names from a test suite. +testModules :: TestSuite -> [ModuleName] +testModules test = (case testInterface test of + TestSuiteLibV09 _ m -> [m] + _ -> []) + ++ otherModules (testBuildInfo test) + +-- | Get all the auto generated module names from a test suite. +-- This are a subset of 'testModules'. +testModulesAutogen :: TestSuite -> [ModuleName] +testModulesAutogen test = autogenModules (testBuildInfo test) diff --git a/cabal/Cabal-syntax/src/Distribution/Types/TestSuite/Lens.hs b/cabal/Cabal-syntax/src/Distribution/Types/TestSuite/Lens.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/TestSuite/Lens.hs @@ -0,0 +1,27 @@ +module Distribution.Types.TestSuite.Lens ( + TestSuite, + module Distribution.Types.TestSuite.Lens, + ) where + +import Distribution.Compat.Lens +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Types.BuildInfo (BuildInfo) +import Distribution.Types.TestSuite (TestSuite) +import Distribution.Types.TestSuiteInterface (TestSuiteInterface) +import Distribution.Types.UnqualComponentName (UnqualComponentName) + +import qualified Distribution.Types.TestSuite as T + +testName :: Lens' TestSuite UnqualComponentName +testName f s = fmap (\x -> s { T.testName = x }) (f (T.testName s)) +{-# INLINE testName #-} + +testInterface :: Lens' TestSuite TestSuiteInterface +testInterface f s = fmap (\x -> s { T.testInterface = x }) (f (T.testInterface s)) +{-# INLINE testInterface #-} + +testBuildInfo :: Lens' TestSuite BuildInfo +testBuildInfo f s = fmap (\x -> s { T.testBuildInfo = x }) (f (T.testBuildInfo s)) +{-# INLINE testBuildInfo #-} diff --git a/cabal/Cabal-syntax/src/Distribution/Types/TestSuiteInterface.hs b/cabal/Cabal-syntax/src/Distribution/Types/TestSuiteInterface.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/TestSuiteInterface.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +module Distribution.Types.TestSuiteInterface ( + TestSuiteInterface(..), +) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Types.TestType +import Distribution.ModuleName +import Distribution.Version + +-- | The test suite interfaces that are currently defined. +-- +-- More interfaces may be defined in future, either new revisions or totally +-- new interfaces. +-- +data TestSuiteInterface = + + -- | Test interface \"exitcode-stdio-1.0\". The test-suite takes the form + -- of an executable. It returns a zero exit code for success, non-zero for + -- failure. The stdout and stderr channels may be logged. It takes no + -- command line parameters and nothing on stdin. + -- + TestSuiteExeV10 Version FilePath + + -- | Test interface \"detailed-0.9\". The test-suite takes the form of a + -- library containing a designated module that exports \"tests :: [Test]\". + -- + | TestSuiteLibV09 Version ModuleName + + -- | A test suite that does not conform to one of the above interfaces for + -- the given reason (e.g. unknown test type). + -- + | TestSuiteUnsupported TestType + deriving (Eq, Generic, Read, Show, Typeable, Data) + +instance Binary TestSuiteInterface +instance Structured TestSuiteInterface + +instance NFData TestSuiteInterface where rnf = genericRnf + +instance Monoid TestSuiteInterface where + mempty = TestSuiteUnsupported (TestTypeUnknown mempty nullVersion) + mappend = (<>) + +instance Semigroup TestSuiteInterface where + a <> (TestSuiteUnsupported _) = a + _ <> b = b diff --git a/cabal/Cabal-syntax/src/Distribution/Types/TestType.hs b/cabal/Cabal-syntax/src/Distribution/Types/TestType.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/TestType.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module Distribution.Types.TestType ( + TestType(..), + knownTestTypes, + testTypeExe, + testTypeLib, +) where + +import Distribution.Compat.Prelude +import Distribution.Version +import Prelude () + +import Distribution.Parsec +import Distribution.Pretty +import Text.PrettyPrint (char, text) + +-- | The \"test-type\" field in the test suite stanza. +-- +data TestType = TestTypeExe Version -- ^ \"type: exitcode-stdio-x.y\" + | TestTypeLib Version -- ^ \"type: detailed-x.y\" + | TestTypeUnknown String Version -- ^ Some unknown test type e.g. \"type: foo\" + deriving (Generic, Show, Read, Eq, Typeable, Data) + +instance Binary TestType +instance Structured TestType + +instance NFData TestType where rnf = genericRnf + +knownTestTypes :: [TestType] +knownTestTypes = [ testTypeExe + , testTypeLib + ] + +testTypeExe :: TestType +testTypeExe = TestTypeExe (mkVersion [1,0]) + +testTypeLib :: TestType +testTypeLib = TestTypeLib (mkVersion [0,9]) + +instance Pretty TestType where + pretty (TestTypeExe ver) = text "exitcode-stdio-" <<>> pretty ver + pretty (TestTypeLib ver) = text "detailed-" <<>> pretty ver + pretty (TestTypeUnknown name ver) = text name <<>> char '-' <<>> pretty ver + +instance Parsec TestType where + parsec = parsecStandard $ \ver name -> case name of + "exitcode-stdio" -> TestTypeExe ver + "detailed" -> TestTypeLib ver + _ -> TestTypeUnknown name ver diff --git a/cabal/Cabal-syntax/src/Distribution/Types/UnitId.hs b/cabal/Cabal-syntax/src/Distribution/Types/UnitId.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/UnitId.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleContexts #-} + +module Distribution.Types.UnitId + ( UnitId, unUnitId, mkUnitId + , DefUnitId + , unsafeMkDefUnitId + , unDefUnitId + , newSimpleUnitId + , mkLegacyUnitId + , getHSLibraryName + ) where + +import Prelude () +import Distribution.Compat.Prelude +import Distribution.Utils.ShortText + +import qualified Distribution.Compat.CharParsing as P +import Distribution.Pretty +import Distribution.Parsec +import Distribution.Types.ComponentId +import Distribution.Types.PackageId + +import Text.PrettyPrint (text) + +-- | A unit identifier identifies a (possibly instantiated) +-- package/component that can be installed the installed package +-- database. There are several types of components that can be +-- installed: +-- +-- * A traditional library with no holes, so that 'unitIdHash' +-- is @Nothing@. In the absence of Backpack, 'UnitId' +-- is the same as a 'ComponentId'. +-- +-- * An indefinite, Backpack library with holes. In this case, +-- 'unitIdHash' is still @Nothing@, but in the install, +-- there are only interfaces, no compiled objects. +-- +-- * An instantiated Backpack library with all the holes +-- filled in. 'unitIdHash' is a @Just@ a hash of the +-- instantiating mapping. +-- +-- A unit is a component plus the additional information on how the +-- holes are filled in. Thus there is a one to many relationship: for a +-- particular component there are many different ways of filling in the +-- holes, and each different combination is a unit (and has a separate +-- 'UnitId'). +-- +-- 'UnitId' is distinct from 'OpenUnitId', in that it is always +-- installed, whereas 'OpenUnitId' are intermediate unit identities +-- that arise during mixin linking, and don't necessarily correspond +-- to any actually installed unit. Since the mapping is not actually +-- recorded in a 'UnitId', you can't actually substitute over them +-- (but you can substitute over 'OpenUnitId'). See also +-- "Distribution.Backpack.FullUnitId" for a mechanism for expanding an +-- instantiated 'UnitId' to retrieve its mapping. +-- +-- Backwards compatibility note: if you need to get the string +-- representation of a UnitId to pass, e.g., as a @-package-id@ +-- flag, use the 'display' function, which will work on all +-- versions of Cabal. +-- +newtype UnitId = UnitId ShortText + deriving (Generic, Read, Show, Eq, Ord, Typeable, Data, NFData) + +instance Binary UnitId +instance Structured UnitId + +-- | The textual format for 'UnitId' coincides with the format +-- GHC accepts for @-package-id@. +-- +instance Pretty UnitId where + pretty = text . unUnitId + +-- | The textual format for 'UnitId' coincides with the format +-- GHC accepts for @-package-id@. +-- +instance Parsec UnitId where + parsec = mkUnitId <$> P.munch1 isUnitChar where + -- https://gitlab.haskell.org/ghc/ghc/issues/17752 + isUnitChar '-' = True + isUnitChar '_' = True + isUnitChar '.' = True + isUnitChar '+' = True + isUnitChar c = isAlphaNum c + +-- | If you need backwards compatibility, consider using 'display' +-- instead, which is supported by all versions of Cabal. +-- +unUnitId :: UnitId -> String +unUnitId (UnitId s) = fromShortText s + +mkUnitId :: String -> UnitId +mkUnitId = UnitId . toShortText + +-- | 'mkUnitId' +-- +-- @since 2.0.0.2 +instance IsString UnitId where + fromString = mkUnitId + +-- | Create a unit identity with no associated hash directly +-- from a 'ComponentId'. +newSimpleUnitId :: ComponentId -> UnitId +newSimpleUnitId = mkUnitId . unComponentId + +-- | Make an old-style UnitId from a package identifier. +-- Assumed to be for the public library +mkLegacyUnitId :: PackageId -> UnitId +mkLegacyUnitId = newSimpleUnitId . mkComponentId . prettyShow + +-- | Returns library name prefixed with HS, suitable for filenames +getHSLibraryName :: UnitId -> String +getHSLibraryName uid = "HS" ++ prettyShow uid + +-- | A 'UnitId' for a definite package. The 'DefUnitId' invariant says +-- that a 'UnitId' identified this way is definite; i.e., it has no +-- unfilled holes. +newtype DefUnitId = DefUnitId { unDefUnitId :: UnitId } + deriving (Generic, Read, Show, Eq, Ord, Typeable, Data, Binary, NFData, Pretty) + +instance Structured DefUnitId + +-- Workaround for a GHC 8.0.1 bug, see +-- https://github.com/haskell/cabal/issues/4793#issuecomment-334258288 +instance Parsec DefUnitId where + parsec = DefUnitId <$> parsec + +-- | Unsafely create a 'DefUnitId' from a 'UnitId'. Your responsibility +-- is to ensure that the 'DefUnitId' invariant holds. +unsafeMkDefUnitId :: UnitId -> DefUnitId +unsafeMkDefUnitId = DefUnitId diff --git a/cabal/Cabal-syntax/src/Distribution/Types/UnqualComponentName.hs b/cabal/Cabal-syntax/src/Distribution/Types/UnqualComponentName.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/UnqualComponentName.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Distribution.Types.UnqualComponentName + ( UnqualComponentName, unUnqualComponentName, unUnqualComponentNameST, mkUnqualComponentName + , packageNameToUnqualComponentName, unqualComponentNameToPackageName + ) where + +import Distribution.Compat.Prelude +import Distribution.Utils.ShortText +import Prelude () + +import Distribution.Parsec +import Distribution.Pretty +import Distribution.Types.PackageName + +-- | An unqualified component name, for any kind of component. +-- +-- This is distinguished from a 'ComponentName' and 'ComponentId'. The former +-- also states which of a library, executable, etc the name refers too. The +-- later uniquely identifiers a component and its closure. +-- +-- @since 2.0.0.2 +newtype UnqualComponentName = UnqualComponentName ShortText + deriving (Generic, Read, Show, Eq, Ord, Typeable, Data, + Semigroup, Monoid) -- TODO: bad enabler of bad monoids + +-- | Convert 'UnqualComponentName' to 'String' +-- +-- @since 2.0.0.2 +unUnqualComponentName :: UnqualComponentName -> String +unUnqualComponentName (UnqualComponentName s) = fromShortText s + +-- | @since 3.4.0.0 +unUnqualComponentNameST :: UnqualComponentName -> ShortText +unUnqualComponentNameST (UnqualComponentName s) = s + +-- | Construct a 'UnqualComponentName' from a 'String' +-- +-- 'mkUnqualComponentName' is the inverse to 'unUnqualComponentName' +-- +-- Note: No validations are performed to ensure that the resulting +-- 'UnqualComponentName' is valid +-- +-- @since 2.0.0.2 +mkUnqualComponentName :: String -> UnqualComponentName +mkUnqualComponentName = UnqualComponentName . toShortText + +-- | 'mkUnqualComponentName' +-- +-- @since 2.0.0.2 +instance IsString UnqualComponentName where + fromString = mkUnqualComponentName + +instance Binary UnqualComponentName +instance Structured UnqualComponentName + +instance Pretty UnqualComponentName where + pretty = showToken . unUnqualComponentName + +instance Parsec UnqualComponentName where + parsec = mkUnqualComponentName <$> parsecUnqualComponentName + +instance NFData UnqualComponentName where + rnf (UnqualComponentName pkg) = rnf pkg + +-- TODO avoid String round trip with these PackageName <-> +-- UnqualComponentName converters. + +-- | Converts a package name to an unqualified component name +-- +-- Useful in legacy situations where a package name may refer to an internal +-- component, if one is defined with that name. +-- +-- 2018-12-21: These "legacy" situations are not legacy. +-- We can @build-depends@ on the internal library. However +-- Now dependency contains @Set LibraryName@, and we should use that. +-- +-- @since 2.0.0.2 +packageNameToUnqualComponentName :: PackageName -> UnqualComponentName +packageNameToUnqualComponentName = UnqualComponentName . unPackageNameST + +-- | Converts an unqualified component name to a package name +-- +-- `packageNameToUnqualComponentName` is the inverse of +-- `unqualComponentNameToPackageName`. +-- +-- Useful in legacy situations where a package name may refer to an internal +-- component, if one is defined with that name. +-- +-- @since 2.0.0.2 +unqualComponentNameToPackageName :: UnqualComponentName -> PackageName +unqualComponentNameToPackageName = mkPackageNameST . unUnqualComponentNameST diff --git a/cabal/Cabal-syntax/src/Distribution/Types/Version.hs b/cabal/Cabal-syntax/src/Distribution/Types/Version.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/Version.hs @@ -0,0 +1,242 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Types.Version ( + -- * Package versions + Version, + mkVersion, + mkVersion', + versionNumbers, + nullVersion, + alterVersion, + version0, + + -- * Internal + validVersion, + versionDigitParser, + ) where + +import Data.Bits (shiftL, shiftR, (.&.), (.|.)) +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Parsec +import Distribution.Pretty + +import qualified Data.Version as Base +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as Disp +import qualified Text.Read as Read + +-- | A 'Version' represents the version of a software entity. +-- +-- Instances of 'Eq' and 'Ord' are provided, which gives exact +-- equality and lexicographic ordering of the version number +-- components (i.e. 2.1 > 2.0, 1.2.3 > 1.2.2, etc.). +-- +-- This type is opaque and distinct from the 'Base.Version' type in +-- "Data.Version" since @Cabal-2.0@. The difference extends to the +-- 'Binary' instance using a different (and more compact) encoding. +-- +-- @since 2.0.0.2 +data Version = PV0 {-# UNPACK #-} !Word64 + | PV1 !Int [Int] + -- NOTE: If a version fits into the packed Word64 + -- representation (i.e. at most four version components + -- which all fall into the [0..0xfffe] range), then PV0 + -- MUST be used. This is essential for the 'Eq' instance + -- to work. + deriving (Data,Eq,Generic,Typeable) + +instance Ord Version where + compare (PV0 x) (PV0 y) = compare x y + compare (PV1 x xs) (PV1 y ys) = case compare x y of + EQ -> compare xs ys + c -> c + compare (PV0 w) (PV1 y ys) = case compare x y of + EQ -> compare [x2,x3,x4] ys + c -> c + where + x = fromIntegral ((w `shiftR` 48) .&. 0xffff) - 1 + x2 = fromIntegral ((w `shiftR` 32) .&. 0xffff) - 1 + x3 = fromIntegral ((w `shiftR` 16) .&. 0xffff) - 1 + x4 = fromIntegral (w .&. 0xffff) - 1 + compare (PV1 x xs) (PV0 w) = case compare x y of + EQ -> compare xs [y2,y3,y4] + c -> c + where + y = fromIntegral ((w `shiftR` 48) .&. 0xffff) - 1 + y2 = fromIntegral ((w `shiftR` 32) .&. 0xffff) - 1 + y3 = fromIntegral ((w `shiftR` 16) .&. 0xffff) - 1 + y4 = fromIntegral (w .&. 0xffff) - 1 + +instance Show Version where + showsPrec d v = showParen (d > 10) + $ showString "mkVersion " + . showsPrec 11 (versionNumbers v) + +instance Read Version where + readPrec = Read.parens $ do + Read.Ident "mkVersion" <- Read.lexP + v <- Read.step Read.readPrec + return (mkVersion v) + +instance Binary Version +instance Structured Version + +instance NFData Version where + rnf (PV0 _) = () + rnf (PV1 _ ns) = rnf ns + +instance Pretty Version where + pretty ver + = Disp.hcat (Disp.punctuate (Disp.char '.') + (map Disp.int $ versionNumbers ver)) + +instance Parsec Version where + parsec = mkVersion <$> toList <$> P.sepByNonEmpty versionDigitParser (P.char '.') <* tags + where + tags = do + ts <- many $ P.char '-' *> some (P.satisfy isAlphaNum) + case ts of + [] -> pure () + (_ : _) -> parsecWarning PWTVersionTag "version with tags" + +-- | An integral without leading zeroes. +-- +-- @since 3.0 +versionDigitParser :: CabalParsing m => m Int +versionDigitParser = (some d >>= toNumber) P. "version digit (integral without leading zeroes)" + where + toNumber :: CabalParsing m => [Int] -> m Int + toNumber [0] = return 0 + toNumber (0:_) = P.unexpected "Version digit with leading zero" + toNumber xs + -- 10^9 = 1000000000 + -- 2^30 = 1073741824 + -- + -- GHC Int is at least 32 bits, so 2^31-1 is the 'maxBound'. + | length xs > 9 = P.unexpected "At most 9 numbers are allowed per version number part" + | otherwise = return $ foldl' (\a b -> a * 10 + b) 0 xs + + d :: P.CharParsing m => m Int + d = f <$> P.satisfyRange '0' '9' + f c = ord c - ord '0' + +-- | Construct 'Version' from list of version number components. +-- +-- For instance, @mkVersion [3,2,1]@ constructs a 'Version' +-- representing the version @3.2.1@. +-- +-- All version components must be non-negative. @mkVersion []@ +-- currently represents the special /null/ version; see also 'nullVersion'. +-- +-- @since 2.0.0.2 +mkVersion :: [Int] -> Version +-- TODO: add validity check; disallow 'mkVersion []' (we have +-- 'nullVersion' for that) +mkVersion [] = nullVersion +mkVersion (v1:[]) + | inWord16VerRep1 v1 = PV0 (mkWord64VerRep1 v1) + | otherwise = PV1 v1 [] + where + inWord16VerRep1 x1 = inWord16 (x1 .|. (x1+1)) + mkWord64VerRep1 y1 = mkWord64VerRep (y1+1) 0 0 0 + +mkVersion (v1:vs@(v2:[])) + | inWord16VerRep2 v1 v2 = PV0 (mkWord64VerRep2 v1 v2) + | otherwise = PV1 v1 vs + where + inWord16VerRep2 x1 x2 = inWord16 (x1 .|. (x1+1) + .|. x2 .|. (x2+1)) + mkWord64VerRep2 y1 y2 = mkWord64VerRep (y1+1) (y2+1) 0 0 + +mkVersion (v1:vs@(v2:v3:[])) + | inWord16VerRep3 v1 v2 v3 = PV0 (mkWord64VerRep3 v1 v2 v3) + | otherwise = PV1 v1 vs + where + inWord16VerRep3 x1 x2 x3 = inWord16 (x1 .|. (x1+1) + .|. x2 .|. (x2+1) + .|. x3 .|. (x3+1)) + mkWord64VerRep3 y1 y2 y3 = mkWord64VerRep (y1+1) (y2+1) (y3+1) 0 + +mkVersion (v1:vs@(v2:v3:v4:[])) + | inWord16VerRep4 v1 v2 v3 v4 = PV0 (mkWord64VerRep4 v1 v2 v3 v4) + | otherwise = PV1 v1 vs + where + inWord16VerRep4 x1 x2 x3 x4 = inWord16 (x1 .|. (x1+1) + .|. x2 .|. (x2+1) + .|. x3 .|. (x3+1) + .|. x4 .|. (x4+1)) + mkWord64VerRep4 y1 y2 y3 y4 = mkWord64VerRep (y1+1) (y2+1) (y3+1) (y4+1) + +mkVersion (v1:vs) = PV1 v1 vs + +-- | Version 0. A lower bound of 'Version'. +-- +-- @since 2.2 +version0 :: Version +version0 = mkVersion [0] + +{-# INLINE mkWord64VerRep #-} +mkWord64VerRep :: Int -> Int -> Int -> Int -> Word64 +mkWord64VerRep v1 v2 v3 v4 = + (fromIntegral v1 `shiftL` 48) + .|. (fromIntegral v2 `shiftL` 32) + .|. (fromIntegral v3 `shiftL` 16) + .|. fromIntegral v4 + +{-# INLINE inWord16 #-} +inWord16 :: Int -> Bool +inWord16 x = (fromIntegral x :: Word) <= 0xffff + +-- | Variant of 'mkVersion' which converts a "Data.Version" +-- 'Base.Version' into Cabal's 'Version' type. +-- +-- @since 2.0.0.2 +mkVersion' :: Base.Version -> Version +mkVersion' = mkVersion . Base.versionBranch + +-- | Unpack 'Version' into list of version number components. +-- +-- This is the inverse to 'mkVersion', so the following holds: +-- +-- > (versionNumbers . mkVersion) vs == vs +-- +-- @since 2.0.0.2 +versionNumbers :: Version -> [Int] +versionNumbers (PV1 n ns) = n:ns +versionNumbers (PV0 w) + | v1 < 0 = [] + | v2 < 0 = [v1] + | v3 < 0 = [v1,v2] + | v4 < 0 = [v1,v2,v3] + | otherwise = [v1,v2,v3,v4] + where + v1 = fromIntegral ((w `shiftR` 48) .&. 0xffff) - 1 + v2 = fromIntegral ((w `shiftR` 32) .&. 0xffff) - 1 + v3 = fromIntegral ((w `shiftR` 16) .&. 0xffff) - 1 + v4 = fromIntegral (w .&. 0xffff) - 1 + + +-- | Constant representing the special /null/ 'Version' +-- +-- The 'nullVersion' compares (via 'Ord') as less than every proper +-- 'Version' value. +-- +-- @since 2.0.0.2 +nullVersion :: Version +-- TODO: at some point, 'mkVersion' may disallow creating /null/ +-- 'Version's +nullVersion = PV0 0 + +-- | Apply function to list of version number components +-- +-- > alterVersion f == mkVersion . f . versionNumbers +-- +-- @since 2.0.0.2 +alterVersion :: ([Int] -> [Int]) -> Version -> Version +alterVersion f = mkVersion . f . versionNumbers + +-- internal helper +validVersion :: Version -> Bool +validVersion v = v /= nullVersion && all (>=0) (versionNumbers v) diff --git a/cabal/Cabal-syntax/src/Distribution/Types/VersionInterval.hs b/cabal/Cabal-syntax/src/Distribution/Types/VersionInterval.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/VersionInterval.hs @@ -0,0 +1,351 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} + +-- | This module implements a view of a 'VersionRange' as a finite +-- list of separated version intervals. +-- +-- In conversion from and to 'VersionRange' it makes some effort to +-- preserve the caret operator @^>=x.y@. This constraint a priori +-- specifies the same interval as @==x.y.*@, but indicates that newer +-- versions could be acceptable (@allow-newer: ^@). +-- +module Distribution.Types.VersionInterval ( + -- * Version intervals + VersionIntervals, + unVersionIntervals, + + -- * Conversions + toVersionIntervals, + fromVersionIntervals, + + -- ** Normalisation + normaliseVersionRange2, + + -- * Relaxation + relaxLastInterval, + relaxHeadInterval, + + -- * Version intervals view + asVersionIntervals, + VersionInterval (..), + LowerBound(..), + UpperBound(..), + Bound(..), + + -- * Invariants + invariantVersionIntervals, + ) where + +import Control.Applicative (liftA2) +import Control.Exception (assert) +import Distribution.Compat.Prelude hiding (Applicative(..)) +import Prelude () + +import Distribution.Types.Version +import Distribution.Types.VersionRange.Internal + +-- To test this module, and to run version range normalisation benchmarks: +-- +-- cabal run Cabal-tests:unit-tests -- -p Distribution.Version +-- cabal run cabal-benchmarks -- -o bench.html normaliseVersionRange + +------------------------------------------------------------------------------- +-- Data +------------------------------------------------------------------------------- + +-- | A complementary representation of a 'VersionRange'. Instead of a boolean +-- version predicate it uses an increasing sequence of non-overlapping, +-- non-empty intervals. +-- +-- The key point is that this representation gives a canonical representation +-- for the semantics of 'VersionRange's. This makes it easier to check things +-- like whether a version range is empty, covers all versions, or requires a +-- certain minimum or maximum version. It also makes it easy to check equality +-- or containment. It also makes it easier to identify \'simple\' version +-- predicates for translation into foreign packaging systems that do not +-- support complex version range expressions. +-- +newtype VersionIntervals = VersionIntervals [VersionInterval] + deriving (Eq, Show, Typeable) + +-- | Inspect the list of version intervals. +-- +unVersionIntervals :: VersionIntervals -> [VersionInterval] +unVersionIntervals (VersionIntervals is) = is + +data VersionInterval = VersionInterval !LowerBound !UpperBound deriving (Eq, Show) +data LowerBound = LowerBound !Version !Bound deriving (Eq, Show) +data UpperBound = NoUpperBound | UpperBound !Version !Bound deriving (Eq, Show) +data Bound = ExclusiveBound | InclusiveBound deriving (Eq, Show) + +zeroLowerBound :: LowerBound +zeroLowerBound = LowerBound version0 InclusiveBound + +isVersion0 :: Version -> Bool +isVersion0 = (==) version0 + +------------------------------------------------------------------------------- +-- Stage1 +------------------------------------------------------------------------------- + +stage1 :: VersionRange -> [VersionInterval] +stage1 = cataVersionRange alg where + -- version range leafs transform into singleton intervals + alg (ThisVersionF v) = [VersionInterval (LowerBound v InclusiveBound) (UpperBound v InclusiveBound)] + alg (LaterVersionF v) = [VersionInterval (LowerBound v ExclusiveBound) NoUpperBound] + alg (OrLaterVersionF v) = [VersionInterval (LowerBound v InclusiveBound) NoUpperBound] + alg (EarlierVersionF v) + | isVersion0 v = [] + | otherwise = [VersionInterval zeroLowerBound (UpperBound v ExclusiveBound)] + alg (OrEarlierVersionF v) = [VersionInterval zeroLowerBound (UpperBound v InclusiveBound)] + + -- ^>= version-range's upper bound should be MajorBound + alg (MajorBoundVersionF v) = [VersionInterval (LowerBound v InclusiveBound) (UpperBound (majorUpperBound v) ExclusiveBound)] + + -- union: just merge the version intervals + alg (UnionVersionRangesF v1 v2) = v1 ++ v2 + + -- intersection: pairwise intersect. Strip empty intervals. Sort to restore the invariant. + alg (IntersectVersionRangesF v1 v2) = mapMaybe nonEmptyInterval $ liftA2 intersectInterval (stage2and3 v1) (stage2and3 v2) + +-- | Check that interval is non-empty +nonEmptyInterval :: VersionInterval -> Maybe VersionInterval +nonEmptyInterval i | nonEmptyVI i = Just i +nonEmptyInterval _ = Nothing + +------------------------------------------------------------------------------- +-- Stage2 +------------------------------------------------------------------------------- + +stage2 :: [VersionInterval] -> [VersionInterval] +stage2 = sortBy lowerboundCmp + +lowerboundCmp :: VersionInterval -> VersionInterval -> Ordering +lowerboundCmp (VersionInterval (LowerBound v vb) _) (VersionInterval (LowerBound u ub) _) = + compare v u `mappend` compareBound vb ub + where + compareBound :: Bound -> Bound -> Ordering + compareBound InclusiveBound InclusiveBound = EQ + compareBound InclusiveBound ExclusiveBound = LT + compareBound ExclusiveBound InclusiveBound = GT + compareBound ExclusiveBound ExclusiveBound = EQ + +------------------------------------------------------------------------------- +-- Postprocess +------------------------------------------------------------------------------- + +-- | Post-processing takes a list of ordered version intervals, +-- but possibly overlapping, and creates 'VersionIntervals'. +-- +postprocess :: [VersionInterval] -> VersionIntervals +postprocess = checkInvariant . VersionIntervals . stage2and3 + +stage2and3 :: [VersionInterval] -> [VersionInterval] +stage2and3 = stage3 . stage2 + +stage3 :: [VersionInterval] -> [VersionInterval] +stage3 [] = [] +stage3 (VersionInterval lb ub : rest) = stage3go lb ub rest + +stage3go :: LowerBound -> UpperBound -> [VersionInterval] -> [VersionInterval] +stage3go !lb NoUpperBound _ = [VersionInterval lb NoUpperBound] +stage3go !lb !ub [] = [VersionInterval lb ub] +stage3go !lb !ub (VersionInterval lb' ub' : rest') + | doesNotTouch ub lb' = VersionInterval lb ub : stage3go lb' ub' rest' + | otherwise = stage3go lb (unionUpper ub ub') rest' + +------------------------------------------------------------------------------- +-- Intersections +------------------------------------------------------------------------------- + +intersectInterval :: VersionInterval -> VersionInterval -> VersionInterval +intersectInterval (VersionInterval lv uv) (VersionInterval lu uu) = + VersionInterval (intersectLower lv lu) (intersectUpper uv uu) + +intersectLower :: LowerBound -> LowerBound -> LowerBound +intersectLower (LowerBound v vb) (LowerBound u ub) = case compare v u of + EQ -> LowerBound v (intersectBound vb ub) + LT -> LowerBound u ub + GT -> LowerBound v vb + +intersectUpper :: UpperBound -> UpperBound -> UpperBound +intersectUpper NoUpperBound b = b +intersectUpper b NoUpperBound = b +intersectUpper (UpperBound v vb) (UpperBound u ub) = case compare v u of + EQ -> UpperBound v (intersectBound vb ub) + LT -> UpperBound v vb + GT -> UpperBound u ub + +intersectBound :: Bound -> Bound -> Bound +intersectBound InclusiveBound InclusiveBound = InclusiveBound +intersectBound _ _ = ExclusiveBound + +------------------------------------------------------------------------------- +-- Unions +------------------------------------------------------------------------------- + +unionUpper :: UpperBound -> UpperBound -> UpperBound +unionUpper NoUpperBound _ = NoUpperBound +unionUpper _ NoUpperBound = NoUpperBound +unionUpper (UpperBound v vb) (UpperBound u ub) = case compare v u of + EQ -> UpperBound v (unionBound vb ub) + LT -> UpperBound u ub + GT -> UpperBound v vb + +unionBound :: Bound -> Bound -> Bound +unionBound ExclusiveBound ExclusiveBound = ExclusiveBound +unionBound _ _ = InclusiveBound + +------------------------------------------------------------------------------- +-- VersionRange +------------------------------------------------------------------------------- + +-- | View a 'VersionRange' as a union of intervals. +-- +-- This provides a canonical view of the semantics of a 'VersionRange' as +-- opposed to the syntax of the expression used to define it. For the syntactic +-- view use 'foldVersionRange'. +-- +-- Each interval is non-empty. The sequence is in increasing order and no +-- intervals overlap or touch. Therefore only the first and last can be +-- unbounded. The sequence can be empty if the range is empty +-- (e.g. a range expression like @< 1 && > 2@). +-- +-- Other checks are trivial to implement using this view. For example: +-- +-- > isNoVersion vr | [] <- asVersionIntervals vr = True +-- > | otherwise = False +-- +-- > isSpecificVersion vr +-- > | [(LowerBound v InclusiveBound +-- > ,UpperBound v' InclusiveBound)] <- asVersionIntervals vr +-- > , v == v' = Just v +-- > | otherwise = Nothing +-- +asVersionIntervals :: VersionRange -> [VersionInterval] +asVersionIntervals = unVersionIntervals . toVersionIntervals + +------------------------------------------------------------------------------- +-- Helpers +------------------------------------------------------------------------------- + +-- | Check an upper bound does not intersect, or even touch a lower bound: +-- +-- @ +-- ---| or ---) but not ---] or ---) or ---] +-- |--- (--- (--- [--- [--- +-- @ +-- +doesNotTouch :: UpperBound -> LowerBound -> Bool +doesNotTouch NoUpperBound _ = False +doesNotTouch (UpperBound u ub) (LowerBound l lb) = + (u < l) || (u == l && ub == ExclusiveBound && lb == ExclusiveBound) + +------------------------------------------------------------------------------- +-- Invariants +------------------------------------------------------------------------------- + +-- | 'VersionIntervals' invariant: +-- +-- * all intervals are valid (lower bound is less then upper bound, i.e. non-empty) +-- * intervals doesn't touch each other (distinct) +-- +invariantVersionIntervals :: VersionIntervals -> Bool +invariantVersionIntervals (VersionIntervals intervals) = + all validInterval intervals && + all doesNotTouch' adjacentIntervals + where + doesNotTouch' :: (VersionInterval, VersionInterval) -> Bool + doesNotTouch' (VersionInterval _ u, VersionInterval l' _) = doesNotTouch u l' + + adjacentIntervals :: [(VersionInterval, VersionInterval)] + adjacentIntervals = case intervals of + [] -> [] + (_:tl) -> zip intervals tl + +checkInvariant :: VersionIntervals -> VersionIntervals +checkInvariant is = assert (invariantVersionIntervals is) is +{-# INLINE checkInvariant #-} + +validInterval :: VersionInterval -> Bool +validInterval i@(VersionInterval l u) = validLower l && validUpper u && nonEmptyVI i + where + validLower (LowerBound v _) = validVersion v + validUpper NoUpperBound = True + validUpper (UpperBound v _) = validVersion v + +-- Check an interval is non-empty +-- +nonEmptyVI :: VersionInterval -> Bool +nonEmptyVI (VersionInterval _ NoUpperBound) = True +nonEmptyVI (VersionInterval (LowerBound l lb) (UpperBound u ub)) = + (l < u) || (l == u && lb == InclusiveBound && ub == InclusiveBound) + +------------------------------------------------------------------------------- +-- Conversions +------------------------------------------------------------------------------- + +-- | Convert a 'VersionRange' to a sequence of version intervals. +-- +toVersionIntervals :: VersionRange -> VersionIntervals +toVersionIntervals = postprocess . stage1 + +-- | Convert a 'VersionIntervals' value back into a 'VersionRange' expression +-- representing the version intervals. +-- +fromVersionIntervals :: VersionIntervals -> VersionRange +fromVersionIntervals (VersionIntervals []) = noVersion +fromVersionIntervals (VersionIntervals (x:xs)) = foldr1 unionVersionRanges (fmap intervalToVersionRange (x:|xs)) + +intervalToVersionRange :: VersionInterval -> VersionRange +intervalToVersionRange (VersionInterval (LowerBound v vb) upper') = case upper' of + NoUpperBound + -> lowerBound + + UpperBound u ub + | vb == InclusiveBound + , ub == InclusiveBound + , v == u + -> thisVersion v + + UpperBound u ub -> withLowerBound (makeUpperBound u ub) + where + lowerBound :: VersionRange + lowerBound = case vb of + InclusiveBound -> orLaterVersion v + ExclusiveBound -> laterVersion v + + withLowerBound :: VersionRange -> VersionRange + withLowerBound vr + | isVersion0 v, vb == InclusiveBound = vr + | otherwise = intersectVersionRanges lowerBound vr + + makeUpperBound :: Version -> Bound -> VersionRange + makeUpperBound u InclusiveBound = orEarlierVersion u + makeUpperBound u ExclusiveBound = earlierVersion u + +------------------------------------------------------------------------------- +-- Normalisation +------------------------------------------------------------------------------- + +-- | Since @Cabal-3.6@ this function.. TODO +-- +normaliseVersionRange2 :: VersionRange -> VersionRange +normaliseVersionRange2 = fromVersionIntervals . toVersionIntervals + +------------------------------------------------------------------------------- +-- Relaxation +------------------------------------------------------------------------------- + +relaxLastInterval :: VersionIntervals -> VersionIntervals +relaxLastInterval (VersionIntervals xs) = VersionIntervals (relaxLastInterval' xs) + where + relaxLastInterval' [] = [] + relaxLastInterval' [VersionInterval l _] = [VersionInterval l NoUpperBound] + relaxLastInterval' (i:is) = i : relaxLastInterval' is + +relaxHeadInterval :: VersionIntervals -> VersionIntervals +relaxHeadInterval (VersionIntervals xs) = VersionIntervals (relaxHeadInterval' xs) + where + relaxHeadInterval' [] = [] + relaxHeadInterval' (VersionInterval _ u : is) = VersionInterval zeroLowerBound u : is diff --git a/cabal/Cabal-syntax/src/Distribution/Types/VersionInterval/Legacy.hs b/cabal/Cabal-syntax/src/Distribution/Types/VersionInterval/Legacy.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/VersionInterval/Legacy.hs @@ -0,0 +1,489 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +-- | This module implements a view of a 'VersionRange' as a finite +-- list of separated version intervals and provides the Boolean +-- algebra operations union, intersection, and complement. +-- +-- It interprets the caret operator @^>=x.y@ as simply @==x.y.*@. +-- Until @Cabal < 3.6@, this module was called "Distribution.Types.VersionInterval". +-- The current module "Distribution.Types.VersionInterval" (refurbished since +-- @Cabal >= 3.6@) makes some effort to preserve the caret operator, +-- but so far does not expose the Boolean algebra structure. +-- +module Distribution.Types.VersionInterval.Legacy ( + -- * Version intervals + VersionIntervals, + toVersionIntervals, + fromVersionIntervals, + withinIntervals, + versionIntervals, + mkVersionIntervals, + unionVersionIntervals, + intersectVersionIntervals, + invertVersionIntervals, + relaxLastInterval, + relaxHeadInterval, + + -- * Version intervals view + asVersionIntervals, + VersionInterval, + LowerBound(..), + UpperBound(..), + Bound(..), + ) where + +import Prelude () +import Distribution.Compat.Prelude +import Control.Exception (assert) + +import Distribution.Types.Version +import Distribution.Types.VersionRange.Internal + +-- NonEmpty +import qualified Prelude (foldr1) + +------------------------------------------------------------------------------- +-- VersionRange +------------------------------------------------------------------------------- + +-- | View a 'VersionRange' as a sequence of separated intervals. +-- +-- This provides a canonical view of the semantics of a 'VersionRange' as +-- opposed to the syntax of the expression used to define it. For the syntactic +-- view use 'foldVersionRange'. +-- +-- /Canonical/ means that two semantically equal ranges translate to the /same/ +-- @['VersionInterval']@, thus its 'Eq' instance can decide semantical equality +-- of ranges. +-- +-- In the returned sequence, each interval is non-empty. +-- The sequence is in increasing order and the intervals are separated, i.e., they +-- neither overlap nor touch. Therefore only the first and last interval can be +-- unbounded. The sequence can be empty if the range is empty +-- (e.g. a range expression like @> 2 && < 1@). +-- +-- Other checks are trivial to implement using this view. For example: +-- +-- > isNoVersion vr | [] <- asVersionIntervals vr = True +-- > | otherwise = False +-- +-- > isSpecificVersion vr +-- > | [(LowerBound v InclusiveBound +-- > ,UpperBound v' InclusiveBound)] <- asVersionIntervals vr +-- > , v == v' = Just v +-- > | otherwise = Nothing +-- +asVersionIntervals :: VersionRange -> [VersionInterval] +asVersionIntervals = versionIntervals . toVersionIntervals + + +------------------------------------------------------------------------------- +-- VersionInterval +------------------------------------------------------------------------------- + +-- | A complementary representation of a 'VersionRange', +-- using an increasing sequence of separated (i.e., non-overlapping, non-touching) +-- non-empty intervals. +-- The represented range is the union of these intervals, meaning +-- that the empty sequence denotes the empty range. +-- +-- As ranges form a Boolean algebra, we can compute union, +-- intersection, and complement. These operations are all linear in +-- the size of the input, thanks to the ordered representation. +-- +-- The interval-sequence representation gives a canonical representation +-- for the semantics of 'VersionRange's. This makes it easier to check things +-- like whether a version range is empty, covers all versions, or requires a +-- certain minimum or maximum version. It also makes it easy to check equality (just '==') +-- or containment. It also makes it easier to identify \'simple\' version +-- predicates for translation into foreign packaging systems that do not +-- support complex version range expressions. +-- +newtype VersionIntervals = VersionIntervals [VersionInterval] + deriving (Eq, Show, Typeable) + +-- | Inspect the list of version intervals. +-- +versionIntervals :: VersionIntervals -> [VersionInterval] +versionIntervals (VersionIntervals is) = is + +-- | Version intervals with exclusive or inclusive bounds, in all combinations: +-- +-- 1. \( (lb,ub) \) meaning \( lb < \_ < ub \). +-- 2. \( (lb,ub] \) meaning \( lb < \_ ≤ ub \). +-- 3. \( [lb,ub) \) meaning \( lb ≤ \_ < ub \). +-- 4. \( [lb,ub] \) meaning \( lb ≤ \_ < ub \). +-- +-- The upper bound can also be missing, meaning "\( ..,∞) \)". +-- +type VersionInterval = (LowerBound, UpperBound) + +data LowerBound + = LowerBound Version !Bound -- ^ Either exclusive @(v,..@ or inclusive @[v,..@. + deriving (Eq, Show) + +data UpperBound + = NoUpperBound -- ^ @..,∞)@ + | UpperBound Version !Bound -- ^ Either exclusive @..,v)@ or inclusive @..,v]@. + deriving (Eq, Show) + +data Bound + = ExclusiveBound -- ^ @(v,..@ if used as lower bound, @..,v)@ if used as upper bound. + | InclusiveBound -- ^ @[v,..@ if used as lower bound, @..,v]@ if used as upper bound. + deriving (Eq, Show) + +-- | @[0,..@. +minLowerBound :: LowerBound +minLowerBound = LowerBound (mkVersion [0]) InclusiveBound + +isVersion0 :: Version -> Bool +isVersion0 = (==) version0 + +-- | @lb1 <= lb2@ holds iff interval @lb1..@ is contained in interval @lb2..@. +-- +instance Ord LowerBound where + LowerBound ver bound <= LowerBound ver' bound' = case compare ver ver' of + LT -> True + EQ -> not (bound == ExclusiveBound && bound' == InclusiveBound) + GT -> False + +-- | @ub1 <= ub2@ holds iff interval @0..ub1@ is contained in interval @0..ub2@. +-- +instance Ord UpperBound where + _ <= NoUpperBound = True + NoUpperBound <= UpperBound _ _ = False + UpperBound ver bound <= UpperBound ver' bound' = case compare ver ver' of + LT -> True + EQ -> not (bound == InclusiveBound && bound' == ExclusiveBound) + GT -> False + +-- | Check that the sequence is ordered, +-- adjacent intervals are separated (do not overlap), +-- an no interval is empty (which would be a redundant entry). +-- +invariant :: VersionIntervals -> Bool +invariant (VersionIntervals intervals) = all validInterval intervals + && all doesNotTouch' adjacentIntervals + where + doesNotTouch' :: (VersionInterval, VersionInterval) -> Bool + doesNotTouch' ((_,u), (l',_)) = doesNotTouch u l' + + -- adjacentIntervals = zip intervals (tail intervals) + adjacentIntervals :: [(VersionInterval, VersionInterval)] + adjacentIntervals = case intervals of + [] -> [] + (_:tl) -> zip intervals tl + +-- | The partial identity function, erroring out on illformed 'VersionIntervals'. +-- +checkInvariant :: VersionIntervals -> VersionIntervals +checkInvariant is = assert (invariant is) is + +-- | Directly construct a 'VersionIntervals' from a list of intervals. +-- +mkVersionIntervals :: [VersionInterval] -> VersionIntervals +mkVersionIntervals intervals + | invariant (VersionIntervals intervals) = VersionIntervals intervals + | otherwise + = checkInvariant + . foldl' (flip insertInterval) (VersionIntervals []) + . filter validInterval + $ intervals + +-- | Add an interval to the sequence, fusing with existing intervals if necessary. +-- +insertInterval :: VersionInterval -> VersionIntervals -> VersionIntervals +insertInterval i is = unionVersionIntervals (VersionIntervals [i]) is + +-- | A valid interval is non-empty. +-- +validInterval :: (LowerBound, UpperBound) -> Bool +validInterval i@(l, u) = validLower l && validUpper u && nonEmptyVI i + where + validLower (LowerBound v _) = validVersion v + validUpper NoUpperBound = True + validUpper (UpperBound v _) = validVersion v + +-- | Check that an interval is non-empty. +-- +nonEmptyVI :: VersionInterval -> Bool +nonEmptyVI (_, NoUpperBound ) = True +nonEmptyVI (LowerBound l lb, UpperBound u ub) = + (l < u) || (l == u && lb == InclusiveBound && ub == InclusiveBound) + +-- | Check an upper bound does not intersect, or even touch a lower bound: +-- +-- @ +-- +-- ---| or ---) but not ---] or ---) or ---] +-- |--- (--- (--- [--- [--- +-- +-- @ +doesNotTouch :: UpperBound -> LowerBound -> Bool +doesNotTouch NoUpperBound _ = False +doesNotTouch (UpperBound u ub) (LowerBound l lb) = + u < l + || (u == l && ub == ExclusiveBound && lb == ExclusiveBound) + +-- | Check an upper bound does not intersect a lower bound: +-- +-- @ +-- +-- ---| or ---) or ---] or ---) but not ---] +-- |--- (--- (--- [--- [--- +-- +-- @ +-- +doesNotIntersect :: UpperBound -> LowerBound -> Bool +doesNotIntersect NoUpperBound _ = False +doesNotIntersect (UpperBound u ub) (LowerBound l lb) = + u < l + || (u == l && not (ub == InclusiveBound && lb == InclusiveBound)) + +-- | Test if a version falls within the version intervals. +-- +-- It exists mostly for completeness and testing. It satisfies the following +-- properties: +-- +-- > withinIntervals v (toVersionIntervals vr) = withinRange v vr +-- > withinIntervals v ivs = withinRange v (fromVersionIntervals ivs) +-- +withinIntervals :: Version -> VersionIntervals -> Bool +withinIntervals v (VersionIntervals intervals) = any withinInterval intervals + where + withinInterval (lowerBound, upperBound) = withinLower lowerBound + && withinUpper upperBound + withinLower (LowerBound v' ExclusiveBound) = v' < v + withinLower (LowerBound v' InclusiveBound) = v' <= v + + withinUpper NoUpperBound = True + withinUpper (UpperBound v' ExclusiveBound) = v' > v + withinUpper (UpperBound v' InclusiveBound) = v' >= v + +-- | Convert a 'VersionRange' to a sequence of version intervals. +-- +toVersionIntervals :: VersionRange -> VersionIntervals +toVersionIntervals = cataVersionRange alg where + -- @== v@ + alg (ThisVersionF v) = chkIvl (LowerBound v InclusiveBound, UpperBound v InclusiveBound) + -- @> v@ + alg (LaterVersionF v) = chkIvl (LowerBound v ExclusiveBound, NoUpperBound) + -- @>= v@ + alg (OrLaterVersionF v) = chkIvl (LowerBound v InclusiveBound, NoUpperBound) + -- @< v@ + alg (EarlierVersionF v) + | isVersion0 v = VersionIntervals [] + | otherwise = chkIvl (minLowerBound, UpperBound v ExclusiveBound) + -- @<= v@ + alg (OrEarlierVersionF v) = chkIvl (minLowerBound, UpperBound v InclusiveBound) + -- @^>= v@ + alg (MajorBoundVersionF v) = chkIvl (LowerBound v InclusiveBound, UpperBound (majorUpperBound v) ExclusiveBound) + -- @r || r'@ + alg (UnionVersionRangesF v1 v2) = unionVersionIntervals v1 v2 + -- @r && r'@ + alg (IntersectVersionRangesF v1 v2) = intersectVersionIntervals v1 v2 + + chkIvl interval = checkInvariant (VersionIntervals [interval]) + +-- | Convert a 'VersionIntervals' value back into a 'VersionRange' expression +-- representing the version intervals. +-- +fromVersionIntervals :: VersionIntervals -> VersionRange +fromVersionIntervals (VersionIntervals []) = noVersion +fromVersionIntervals (VersionIntervals intervals) = + Prelude.foldr1 unionVersionRanges [ interval l u | (l, u) <- intervals ] + + where + interval (LowerBound v InclusiveBound) + (UpperBound v' InclusiveBound) | v == v' + = thisVersion v + interval l u = lowerBound l `intersectVersionRanges'` upperBound u + + lowerBound (LowerBound v InclusiveBound) + | isVersion0 v = Nothing + | otherwise = Just (orLaterVersion v) + lowerBound (LowerBound v ExclusiveBound) = Just (laterVersion v) + + upperBound NoUpperBound = Nothing + upperBound (UpperBound v InclusiveBound) = Just (orEarlierVersion v) + upperBound (UpperBound v ExclusiveBound) = Just (earlierVersion v) + + intersectVersionRanges' Nothing Nothing = anyVersion + intersectVersionRanges' (Just vr) Nothing = vr + intersectVersionRanges' Nothing (Just vr) = vr + intersectVersionRanges' (Just vr) (Just vr') = intersectVersionRanges vr vr' + +-- | Union two interval sequences, fusing intervals where necessary. +-- Computed \( O(n+m) \) time, resulting in sequence of length \( ≤ n+m \). +-- +unionVersionIntervals :: VersionIntervals -> VersionIntervals + -> VersionIntervals +unionVersionIntervals (VersionIntervals is0) (VersionIntervals is'0) = + checkInvariant (VersionIntervals (union is0 is'0)) + where + union is [] = is + union [] is' = is' + union (i:is) (i':is') = case unionInterval i i' of + + -- @i < i'@ and separated: keep @i@. + Left Nothing -> i : union is (i' :is') + + -- @i'' = i ∪ i'@ and @i@ ends first: drop @i@, replace @i'@ by @i''@. + Left (Just i'') -> union is (i'':is') + + -- @i' < i@ and separated: keep @i'@. + Right Nothing -> i' : union (i :is) is' + + -- @i'' = i ∪ i'@ and @i'@ ends first: drop @i'@, replace @i@ by @i''@. + Right (Just i'') -> union (i'':is) is' + +-- | Given two version intervals @i1@ and @i2@, return one of the following: +-- +-- [@Left Nothing@] when @i1 < i2@ and the intervals are separated. +-- [@Right Nothing@] when @i2 < i1@ and the intervals are separated. +-- [@Left (i1 \/ i2)@] when @ub(i1) <= ub(i2)@ and the intervals are not separated. +-- [@Right (i1 \/ i2)@] when @ub(i2) < ub(i1)@ and the intervals are not separated. +-- +-- Herein, @i < i'@ means that the whole of the interval @i@ is strictly left of the whole of @i'@, +-- and @ub(i)@ returns the right boundary of interval @i@ which could be inclusive or exclusive. +-- +unionInterval :: VersionInterval -> VersionInterval + -> Either (Maybe VersionInterval) (Maybe VersionInterval) +unionInterval (lower , upper ) (lower', upper') + + -- Non-intersecting intervals with the left interval ending first + | upper `doesNotTouch` lower' = Left Nothing + + -- Non-intersecting intervals with the right interval first + | upper' `doesNotTouch` lower = Right Nothing + + -- Complete or partial overlap, with the left interval ending first + | upper <= upper' = lowerBound `seq` + Left (Just (lowerBound, upper')) + + -- Complete or partial overlap, with the left interval ending first + | otherwise = lowerBound `seq` + Right (Just (lowerBound, upper)) + where + lowerBound = min lower lower' + +-- | The intersection \( is \cap is' \) of two interval sequences \( is \) and \( is' \) +-- of lengths \( n \) and \( m \), resp., +-- satisfies the specification \( is ∩ is' = \{ i ∩ i' \mid i ∈ is, i' ∈ is' \} \). +-- Thanks to the ordered representation of intervals it can be computed in \( O(n+m) \) +-- (rather than the naive \( O(nm) \). +-- +-- The length of \( is \cap is' \) is \( ≤ \min(n,m) \). +-- +intersectVersionIntervals :: VersionIntervals -> VersionIntervals + -> VersionIntervals +intersectVersionIntervals (VersionIntervals is0) (VersionIntervals is'0) = + checkInvariant (VersionIntervals (intersect is0 is'0)) + where + intersect _ [] = [] + intersect [] _ = [] + intersect (i:is) (i':is') = case intersectInterval i i' of + + -- @i < i'@: throw out @i@ + Left Nothing -> intersect is (i':is') + + -- @i'' = i /\ i'@ and @i@ ends first: replace @i@ by @i''@. + Left (Just i'') -> i'' : intersect is (i':is') + + -- @i' < i@: throw out @i'@ + Right Nothing -> intersect (i:is) is' + + -- @i'' = i /\ i'@ and @i'@ ends first: replace @i'@ by @i''@. + Right (Just i'') -> i'' : intersect (i:is) is' + +-- | Given two version intervals @i1@ and @i2@, return one of the following: +-- +-- [@Left Nothing@] when @i1 < i2@. +-- [@Right Nothing@] when @i2 < i1@. +-- [@Left (i1 /\ i2)@] when @ub(i1) <= ub(i2)@. +-- [@Right (i1 /\ i2)@] when @ub(i2) < ub(i1)@. +-- +-- Herein, @i < i'@ means that the whole of the interval @i@ is strictly left of the whole of @i'@, +-- and @ub(i)@ returns the right boundary of interval @i@ which could be inclusive or exclusive. +-- +intersectInterval :: VersionInterval -> VersionInterval + -> Either (Maybe VersionInterval) (Maybe VersionInterval) +intersectInterval (lower , upper ) (lower', upper') + + -- Non-intersecting intervals with the left interval ending first + | upper `doesNotIntersect` lower' = Left Nothing + + -- Non-intersecting intervals with the right interval first + | upper' `doesNotIntersect` lower = Right Nothing + + -- Complete or partial overlap, with the left interval ending first + | upper <= upper' = lowerBound `seq` + Left (Just (lowerBound, upper)) + + -- Complete or partial overlap, with the right interval ending first + | otherwise = lowerBound `seq` + Right (Just (lowerBound, upper')) + where + lowerBound = max lower lower' + +-- | Compute the complement. +-- \( O(n) \). +invertVersionIntervals :: VersionIntervals + -> VersionIntervals +invertVersionIntervals (VersionIntervals xs) = + case xs of + -- Empty interval set + [] -> VersionIntervals [(noLowerBound, NoUpperBound)] + -- Interval with no lower bound + ((lb, ub) : more) | lb == noLowerBound -> + VersionIntervals $ invertVersionIntervals' ub more + -- Interval with a lower bound + ((lb, ub) : more) -> + VersionIntervals $ (noLowerBound, invertLowerBound lb) + : invertVersionIntervals' ub more + where + -- Invert subsequent version intervals given the upper bound of + -- the intervals already inverted. + invertVersionIntervals' :: UpperBound + -> [(LowerBound, UpperBound)] + -> [(LowerBound, UpperBound)] + invertVersionIntervals' NoUpperBound [] = [] + invertVersionIntervals' ub0 [] = [(invertUpperBound ub0, NoUpperBound)] + invertVersionIntervals' ub0 [(lb, NoUpperBound)] = + [(invertUpperBound ub0, invertLowerBound lb)] + invertVersionIntervals' ub0 ((lb, ub1) : more) = + (invertUpperBound ub0, invertLowerBound lb) + : invertVersionIntervals' ub1 more + + invertLowerBound :: LowerBound -> UpperBound + invertLowerBound (LowerBound v b) = UpperBound v (invertBound b) + + invertUpperBound :: UpperBound -> LowerBound + invertUpperBound (UpperBound v b) = LowerBound v (invertBound b) + invertUpperBound NoUpperBound = error "NoUpperBound: unexpected" + + invertBound :: Bound -> Bound + invertBound ExclusiveBound = InclusiveBound + invertBound InclusiveBound = ExclusiveBound + + noLowerBound :: LowerBound + noLowerBound = LowerBound (mkVersion [0]) InclusiveBound + +-- | Remove the last upper bound, enlarging the range. +-- But empty ranges stay empty. +-- \( O(n) \). +relaxLastInterval :: VersionIntervals -> VersionIntervals +relaxLastInterval (VersionIntervals xs) = VersionIntervals (relaxLastInterval' xs) + where + relaxLastInterval' [] = [] + relaxLastInterval' [(l,_)] = [(l, NoUpperBound)] + relaxLastInterval' (i:is) = i : relaxLastInterval' is + +-- | Remove the first lower bound (i.e, make it \( [0 \). +-- Empty ranges stay empty. +-- \( O(1) \). +relaxHeadInterval :: VersionIntervals -> VersionIntervals +relaxHeadInterval (VersionIntervals xs) = VersionIntervals (relaxHeadInterval' xs) + where + relaxHeadInterval' [] = [] + relaxHeadInterval' ((_,u):is) = (minLowerBound,u) : is diff --git a/cabal/Cabal-syntax/src/Distribution/Types/VersionRange.hs b/cabal/Cabal-syntax/src/Distribution/Types/VersionRange.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/VersionRange.hs @@ -0,0 +1,180 @@ +module Distribution.Types.VersionRange ( + -- * Version ranges + VersionRange, + + -- ** Constructing + anyVersion, noVersion, + thisVersion, notThisVersion, + laterVersion, earlierVersion, + orLaterVersion, orEarlierVersion, + unionVersionRanges, intersectVersionRanges, + withinVersion, + majorBoundVersion, + + -- ** Inspection + -- + -- See "Distribution.Version" for more utilities. + withinRange, + foldVersionRange, + normaliseVersionRange, + stripParensVersionRange, + hasUpperBound, + hasLowerBound, + + -- ** Cata & ana + VersionRangeF (..), + cataVersionRange, + anaVersionRange, + hyloVersionRange, + projectVersionRange, + embedVersionRange, + + -- ** Utilities + isAnyVersion, + isAnyVersionLight, + wildcardUpperBound, + majorUpperBound, + isWildcardRange, + versionRangeParser, + ) where + +import Distribution.Compat.Prelude +import Distribution.Types.Version +import Distribution.Types.VersionInterval +import Distribution.Types.VersionRange.Internal +import Prelude () + +-- | Fold over the basic syntactic structure of a 'VersionRange'. +-- +-- This provides a syntactic view of the expression defining the version range. +-- The syntactic sugar @\">= v\"@, @\"<= v\"@ and @\"== v.*\"@ is presented +-- in terms of the other basic syntax. +-- +-- For a semantic view use 'asVersionIntervals'. +-- +foldVersionRange :: a -- ^ @\"-any\"@ version + -> (Version -> a) -- ^ @\"== v\"@ + -> (Version -> a) -- ^ @\"> v\"@ + -> (Version -> a) -- ^ @\"< v\"@ + -> (a -> a -> a) -- ^ @\"_ || _\"@ union + -> (a -> a -> a) -- ^ @\"_ && _\"@ intersection + -> VersionRange -> a +foldVersionRange _any this later earlier union intersect = fold + where + fold = cataVersionRange alg + + alg (ThisVersionF v) = this v + alg (LaterVersionF v) = later v + alg (OrLaterVersionF v) = union (this v) (later v) + alg (EarlierVersionF v) = earlier v + alg (OrEarlierVersionF v) = union (this v) (earlier v) + alg (MajorBoundVersionF v) = fold (majorBound v) + alg (UnionVersionRangesF v1 v2) = union v1 v2 + alg (IntersectVersionRangesF v1 v2) = intersect v1 v2 + + majorBound v = intersectVersionRanges + (orLaterVersion v) + (earlierVersion (majorUpperBound v)) + +-- | Normalise 'VersionRange'. +-- +-- In particular collapse @(== v || > v)@ into @>= v@, and so on. +normaliseVersionRange :: VersionRange -> VersionRange +normaliseVersionRange = hyloVersionRange embed projectVersionRange + where + -- == v || > v, > v || == v ==> >= v + embed (UnionVersionRangesF (ThisVersion v) (LaterVersion v')) | v == v' = + orLaterVersion v + embed (UnionVersionRangesF (LaterVersion v) (ThisVersion v')) | v == v' = + orLaterVersion v + + -- == v || < v, < v || == v ==> <= v + embed (UnionVersionRangesF (ThisVersion v) (EarlierVersion v')) | v == v' = + orEarlierVersion v + embed (UnionVersionRangesF (EarlierVersion v) (ThisVersion v')) | v == v' = + orEarlierVersion v + + -- otherwise embed normally + embed vr = embedVersionRange vr + +-- | Remove 'VersionRangeParens' constructors. +-- +-- Since version 3.4 this function is 'id', there aren't 'VersionRangeParens' constructor in 'VersionRange' anymore. +-- +-- @since 2.2 +stripParensVersionRange :: VersionRange -> VersionRange +stripParensVersionRange = id + +-- | Does this version fall within the given range? +-- +-- This is the evaluation function for the 'VersionRange' type. +-- +withinRange :: Version -> VersionRange -> Bool +withinRange v = foldVersionRange + True + (\v' -> v == v') + (\v' -> v > v') + (\v' -> v < v') + (||) + (&&) + +-- | Does this 'VersionRange' place any restriction on the 'Version' or is it +-- in fact equivalent to 'AnyVersion'. +-- +-- Note this is a semantic check, not simply a syntactic check. So for example +-- the following is @True@ (for all @v@). +-- +-- > isAnyVersion (EarlierVersion v `UnionVersionRanges` orLaterVersion v) +-- +isAnyVersion :: VersionRange -> Bool +isAnyVersion vr = case asVersionIntervals vr of + [VersionInterval (LowerBound v InclusiveBound) NoUpperBound] -> v == version0 + _ -> False + +-- A fast and non-precise version of 'isAnyVersion', +-- returns 'True' only for @>= 0@ 'VersionRange's. +-- +-- /Do not use/. The "VersionIntervals don't destroy MajorBoundVersion" +-- https://github.com/haskell/cabal/pull/6736 pull-request +-- will change 'simplifyVersionRange' to properly preserve semantics. +-- Then we can use it to normalise 'VersionRange's in tests. +-- +isAnyVersionLight :: VersionRange -> Bool +isAnyVersionLight (OrLaterVersion v) = v == version0 +isAnyVersionLight _vr = False + +---------------------------- +-- Wildcard range utilities +-- + + +isWildcardRange :: Version -> Version -> Bool +isWildcardRange ver1 ver2 = check (versionNumbers ver1) (versionNumbers ver2) + where check (n:[]) (m:[]) | n+1 == m = True + check (n:ns) (m:ms) | n == m = check ns ms + check _ _ = False + +-- | Does the version range have an upper bound? +-- +-- @since 1.24.0.0 +hasUpperBound :: VersionRange -> Bool +hasUpperBound = foldVersionRange + False + (const True) + (const False) + (const True) + (&&) (||) + +-- | Does the version range have an explicit lower bound? +-- +-- Note: this function only considers the user-specified lower bounds, but not +-- the implicit >=0 lower bound. +-- +-- @since 1.24.0.0 +hasLowerBound :: VersionRange -> Bool +hasLowerBound = foldVersionRange + False + (const True) + (const True) + (const False) + (&&) (||) diff --git a/cabal/Cabal-syntax/src/Distribution/Types/VersionRange/Internal.hs b/cabal/Cabal-syntax/src/Distribution/Types/VersionRange/Internal.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Types/VersionRange/Internal.hs @@ -0,0 +1,536 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | The only purpose of this module is to prevent the export of +-- 'VersionRange' constructors from +-- "Distribution.Types.VersionRange". To avoid creating orphan +-- instances, a lot of related code had to be moved here too. + +module Distribution.Types.VersionRange.Internal + ( VersionRange(..) + , anyVersion, noVersion + , thisVersion, notThisVersion + , laterVersion, earlierVersion + , orLaterVersion, orEarlierVersion + , unionVersionRanges, intersectVersionRanges + , withinVersion + , majorBoundVersion + + , VersionRangeF(..) + , projectVersionRange + , embedVersionRange + , cataVersionRange + , anaVersionRange + , hyloVersionRange + , versionRangeParser + + , majorUpperBound + , wildcardUpperBound + ) where + +import Distribution.Compat.Prelude +import Distribution.Types.Version +import Prelude () + +import Distribution.CabalSpecVersion +import Distribution.Parsec +import Distribution.Pretty +import Distribution.Utils.Generic (unsnoc) + +import qualified Distribution.Compat.CharParsing as P +import qualified Distribution.Compat.DList as DList +import qualified Text.PrettyPrint as Disp + +data VersionRange + = ThisVersion Version -- = version + | LaterVersion Version -- > version (NB. not >=) + | OrLaterVersion Version -- >= version + | EarlierVersion Version -- < version + | OrEarlierVersion Version -- <= version + | MajorBoundVersion Version -- @^>= ver@ (same as >= ver && < MAJ(ver)+1) + | UnionVersionRanges VersionRange VersionRange + | IntersectVersionRanges VersionRange VersionRange + deriving ( Data, Eq, Generic, Read, Show, Typeable ) + +instance Binary VersionRange +instance Structured VersionRange +instance NFData VersionRange where rnf = genericRnf + +-- | The version range @-any@. That is, a version range containing all +-- versions. +-- +-- > withinRange v anyVersion = True +-- +anyVersion :: VersionRange +anyVersion = OrLaterVersion (mkVersion [0]) + +-- | The empty version range @-none@, that is a version range containing no versions. +-- +-- This can be constructed using any unsatisfiable version range expression, +-- for example @< 0@. +-- +-- > withinRange v noVersion = False +-- +noVersion :: VersionRange +noVersion = EarlierVersion (mkVersion [0]) + +-- | The version range @== v@. +-- +-- > withinRange v' (thisVersion v) = v' == v +-- +thisVersion :: Version -> VersionRange +thisVersion = ThisVersion + +-- | The version range @/= v@. +-- +-- > withinRange v' (notThisVersion v) = v' /= v +-- +notThisVersion :: Version -> VersionRange +notThisVersion v = UnionVersionRanges (EarlierVersion v) (LaterVersion v) + +-- | The version range @> v@. +-- +-- > withinRange v' (laterVersion v) = v' > v +-- +laterVersion :: Version -> VersionRange +laterVersion = LaterVersion + +-- | The version range @>= v@. +-- +-- > withinRange v' (orLaterVersion v) = v' >= v +-- +orLaterVersion :: Version -> VersionRange +orLaterVersion = OrLaterVersion + +-- | The version range @< v@. +-- +-- > withinRange v' (earlierVersion v) = v' < v +-- +earlierVersion :: Version -> VersionRange +earlierVersion = EarlierVersion + +-- | The version range @<= v@. +-- +-- > withinRange v' (orEarlierVersion v) = v' <= v +-- +orEarlierVersion :: Version -> VersionRange +orEarlierVersion = OrEarlierVersion + +-- | The version range @vr1 || vr2@. +-- +-- > withinRange v' (unionVersionRanges vr1 vr2) +-- > = withinRange v' vr1 || withinRange v' vr2 +-- +unionVersionRanges :: VersionRange -> VersionRange -> VersionRange +unionVersionRanges = UnionVersionRanges + +-- | The version range @vr1 && vr2@. +-- +-- > withinRange v' (intersectVersionRanges vr1 vr2) +-- > = withinRange v' vr1 && withinRange v' vr2 +-- +intersectVersionRanges :: VersionRange -> VersionRange -> VersionRange +intersectVersionRanges = IntersectVersionRanges + +-- | The version range @== v.*@. +-- +-- For example, for version @1.2@, the version range @== 1.2.*@ is the same as +-- @>= 1.2 && < 1.3@. +-- +-- > withinRange v' (withinVersion v) = v' >= v && v' < upper v +-- > where +-- > upper (Version lower t) = Version (init lower ++ [last lower + 1]) t +-- +withinVersion :: Version -> VersionRange +withinVersion v = intersectVersionRanges + (orLaterVersion v) + (earlierVersion (wildcardUpperBound v)) + +-- | The version range @^>= v@. +-- +-- For example, for version @1.2.3.4@, the version range @^>= 1.2.3.4@ +-- is the same as @>= 1.2.3.4 && < 1.3@. +-- +-- Note that @^>= 1@ is equivalent to @>= 1 && < 1.1@. +-- +-- @since 2.0.0.2 +majorBoundVersion :: Version -> VersionRange +majorBoundVersion = MajorBoundVersion + + +-- | F-Algebra of 'VersionRange'. See 'cataVersionRange'. +-- +-- @since 2.2 +data VersionRangeF a + = ThisVersionF Version -- ^ @== version@. + | LaterVersionF Version -- ^ @> version@. NB: not @>=@ + | OrLaterVersionF Version -- ^ @>= version@. + | EarlierVersionF Version -- ^ @< version@. + | OrEarlierVersionF Version -- ^ @<= version@. + | MajorBoundVersionF Version -- ^ @^>= version@, same as @>= version && < MAJ(version)+1@. + | UnionVersionRangesF a a -- ^ @||@. + | IntersectVersionRangesF a a -- ^ @&&@. + deriving ( Data, Eq, Generic, Read, Show, Typeable + , Functor, Foldable, Traversable ) + +-- | Generic destructor for 'VersionRange'. +-- +-- @since 2.2 +projectVersionRange :: VersionRange -> VersionRangeF VersionRange +projectVersionRange (ThisVersion v) = ThisVersionF v +projectVersionRange (LaterVersion v) = LaterVersionF v +projectVersionRange (OrLaterVersion v) = OrLaterVersionF v +projectVersionRange (EarlierVersion v) = EarlierVersionF v +projectVersionRange (OrEarlierVersion v) = OrEarlierVersionF v +projectVersionRange (MajorBoundVersion v) = MajorBoundVersionF v +projectVersionRange (UnionVersionRanges a b) = UnionVersionRangesF a b +projectVersionRange (IntersectVersionRanges a b) = IntersectVersionRangesF a b + +-- | Fold 'VersionRange'. +-- +-- @since 2.2 +cataVersionRange :: (VersionRangeF a -> a) -> VersionRange -> a +cataVersionRange f = c where c = f . fmap c . projectVersionRange + +-- | Generic constructor for 'VersionRange'. +-- +-- @since 2.2 +embedVersionRange :: VersionRangeF VersionRange -> VersionRange +embedVersionRange (ThisVersionF v) = ThisVersion v +embedVersionRange (LaterVersionF v) = LaterVersion v +embedVersionRange (OrLaterVersionF v) = OrLaterVersion v +embedVersionRange (EarlierVersionF v) = EarlierVersion v +embedVersionRange (OrEarlierVersionF v) = OrEarlierVersion v +embedVersionRange (MajorBoundVersionF v) = MajorBoundVersion v +embedVersionRange (UnionVersionRangesF a b) = UnionVersionRanges a b +embedVersionRange (IntersectVersionRangesF a b) = IntersectVersionRanges a b + +-- | Unfold 'VersionRange'. +-- +-- @since 2.2 +anaVersionRange :: (a -> VersionRangeF a) -> a -> VersionRange +anaVersionRange g = a where a = embedVersionRange . fmap a . g + +-- | Refold 'VersionRange'. +-- +-- @since 2.2 +hyloVersionRange :: (VersionRangeF VersionRange -> VersionRange) + -> (VersionRange -> VersionRangeF VersionRange) + -> VersionRange -> VersionRange +hyloVersionRange f g = h where h = f . fmap h . g + +------------------------------------------------------------------------------- +-- Parsec & Pretty +------------------------------------------------------------------------------- + +-- | +-- +-- >>> fmap pretty (simpleParsec' CabalSpecV1_6 "== 3.2.*" :: Maybe VersionRange) +-- Just >=3.2 && <3.3 +-- +-- >>> fmap (prettyVersioned CabalSpecV1_6) (simpleParsec' CabalSpecV1_6 "== 3.2.*" :: Maybe VersionRange) +-- Just ==3.2.* +-- +-- >>> fmap pretty (simpleParsec' CabalSpecV1_6 "-any" :: Maybe VersionRange) +-- Just >=0 +-- +-- >>> fmap (prettyVersioned CabalSpecV1_6) (simpleParsec' CabalSpecV1_6 "-any" :: Maybe VersionRange) +-- Just >=0 +-- +instance Pretty VersionRange where + pretty = prettyVersioned cabalSpecLatest + + prettyVersioned csv + | csv > CabalSpecV1_6 = prettyVersionRange + | otherwise = prettyVersionRange16 + +prettyVersionRange :: VersionRange -> Disp.Doc +prettyVersionRange vr = cataVersionRange alg vr 0 + where + alg :: VersionRangeF (Int -> Disp.Doc) -> Int -> Disp.Doc + alg (ThisVersionF v) _ = Disp.text "==" <<>> pretty v + alg (LaterVersionF v) _ = Disp.text ">" <<>> pretty v + alg (OrLaterVersionF v) _ = Disp.text ">=" <<>> pretty v + alg (EarlierVersionF v) _ = Disp.text "<" <<>> pretty v + alg (OrEarlierVersionF v) _ = Disp.text "<=" <<>> pretty v + alg (MajorBoundVersionF v) _ = Disp.text "^>=" <<>> pretty v + alg (UnionVersionRangesF r1 r2) d = parens (d > 0) + $ r1 1 <+> Disp.text "||" <+> r2 0 + alg (IntersectVersionRangesF r1 r2) d = parens (d > 1) + $ r1 2 <+> Disp.text "&&" <+> r2 1 + + parens True = Disp.parens + parens False = id + +-- | Don't use && and || operators. If possible. +prettyVersionRange16 :: VersionRange -> Disp.Doc +prettyVersionRange16 (IntersectVersionRanges (OrLaterVersion v) (EarlierVersion u)) + | u == wildcardUpperBound v + = Disp.text "==" <<>> dispWild v + where + dispWild ver = + Disp.hcat (Disp.punctuate (Disp.char '.') + (map Disp.int $ versionNumbers ver)) + <<>> Disp.text ".*" + +prettyVersionRange16 vr = prettyVersionRange vr + +-- | +-- +-- >>> simpleParsec "^>= 3.4" :: Maybe VersionRange +-- Just (MajorBoundVersion (mkVersion [3,4])) +-- +-- Small history: +-- +-- @-any@ and @-none@ removed in 3.4 +-- Use @>=0@ and @<0@ instead. +-- +-- >>> map (`simpleParsec'` "-none") [CabalSpecV3_0, CabalSpecV3_4] :: [Maybe VersionRange] +-- [Just (EarlierVersion (mkVersion [0])),Nothing] +-- +-- Set operations are introduced in 3.0 +-- +-- >>> map (`simpleParsec'` "^>= { 1.2 , 1.3 }") [CabalSpecV2_4, CabalSpecV3_0] :: [Maybe VersionRange] +-- [Nothing,Just (UnionVersionRanges (MajorBoundVersion (mkVersion [1,2])) (MajorBoundVersion (mkVersion [1,3])))] +-- +-- @^>=@ is introduced in 2.0 +-- +-- >>> map (`simpleParsec'` "^>=1.2") [CabalSpecV1_24, CabalSpecV2_0] :: [Maybe VersionRange] +-- [Nothing,Just (MajorBoundVersion (mkVersion [1,2]))] +-- +-- @-none@ is introduced in 1.22 +-- +-- >>> map (`simpleParsec'` "-none") [CabalSpecV1_20, CabalSpecV1_22] :: [Maybe VersionRange] +-- [Nothing,Just (EarlierVersion (mkVersion [0]))] +-- +-- Operators are introduced in 1.8. Issues only a warning. +-- +-- >>> map (`simpleParsecW'` "== 1 || ==2") [CabalSpecV1_6, CabalSpecV1_8] :: [Maybe VersionRange] +-- [Nothing,Just (UnionVersionRanges (ThisVersion (mkVersion [1])) (ThisVersion (mkVersion [2])))] +-- +-- Wild-version ranges are introduced in 1.6. Issues only a warning. +-- +-- >>> map (`simpleParsecW'` "== 1.2.*") [CabalSpecV1_4, CabalSpecV1_6] :: [Maybe VersionRange] +-- [Nothing,Just (IntersectVersionRanges (OrLaterVersion (mkVersion [1,2])) (EarlierVersion (mkVersion [1,3])))] +-- +instance Parsec VersionRange where + parsec = askCabalSpecVersion >>= versionRangeParser versionDigitParser + +-- | 'VersionRange' parser parametrised by version digit parser. +-- +-- - 'versionDigitParser' is used for all 'VersionRange'. +-- - 'P.integral' is used for backward-compat @pkgconfig-depends@ +-- versions, 'PkgConfigVersionRange'. +-- +-- @since 3.0 +versionRangeParser :: forall m. CabalParsing m => m Int -> CabalSpecVersion -> m VersionRange +versionRangeParser digitParser csv = expr + where + expr = do P.spaces + t <- term + P.spaces + (do _ <- P.string "||" + checkOp + P.spaces + e <- expr + return (unionVersionRanges t e) + <|> + return t) + term = do f <- factor + P.spaces + (do _ <- P.string "&&" + checkOp + P.spaces + t <- term + return (intersectVersionRanges f t) + <|> + return f) + factor = parens expr <|> prim + + prim = do + op <- P.munch1 isOpChar P. "operator" + case op of + "-" -> anyVersion <$ P.string "any" <|> P.string "none" *> noVersion' + + "==" -> do + P.spaces + (do (wild, v) <- verOrWild + checkWild wild + pure $ (if wild then withinVersion else thisVersion) v + <|> + (verSet' thisVersion =<< verSet)) + + "^>=" -> do + P.spaces + (do (wild, v) <- verOrWild + when wild $ P.unexpected $ + "wild-card version after ^>= operator" + majorBoundVersion' v + <|> + (verSet' majorBoundVersion =<< verSet)) + + _ -> do + P.spaces + (wild, v) <- verOrWild + when wild $ P.unexpected $ + "wild-card version after non-== operator: " ++ show op + case op of + ">=" -> pure $ orLaterVersion v + "<" -> pure $ earlierVersion v + "<=" -> pure $ orEarlierVersion v + ">" -> pure $ laterVersion v + _ -> fail $ "Unknown version operator " ++ show op + + -- Cannot be warning + -- On 2020-03-16 there was around 27400 files on Hackage failing to parse due this + -- For example https://hackage.haskell.org/package/haxr-3000.0.0/haxr.cabal + -- + checkOp = when (csv < CabalSpecV1_8) $ + parsecWarning PWTVersionOperator $ unwords + [ "version operators used." + , "To use version operators the package needs to specify at least 'cabal-version: >= 1.8'." + ] + + -- Cannot be warning + -- On 2020-03-16 there was 46 files on Hackage failing to parse due this + -- For example https://hackage.haskell.org/package/derive-0.1.2/derive.cabal + -- + checkWild False = pure () + checkWild True = when (csv < CabalSpecV1_6) $ + parsecWarning PWTVersionWildcard $ unwords + [ "Wildcard syntax used." + , "To use version wildcards the package needs to specify at least 'cabal-version: >= 1.6'." + ] + + -- https://gitlab.haskell.org/ghc/ghc/issues/17752 + isOpChar '<' = True + isOpChar '=' = True + isOpChar '>' = True + isOpChar '^' = True + isOpChar '-' = csv < CabalSpecV3_4 + -- https://github.com/haskell/cabal/issues/6589 + -- Unfortunately we have must not consume the dash, + -- as otherwise following parts may not be parsed. + -- + -- i.e. we cannot fail here with good error. + isOpChar _ = False + + -- -none version range is available since 1.22 + noVersion' = + if csv >= CabalSpecV1_22 + then pure noVersion + else fail $ unwords + [ "-none version range used." + , "To use this syntax the package needs to specify at least 'cabal-version: 1.22'." + , "Alternatively, if broader compatibility is important then use" + , "<0 or other empty range." + ] + + -- ^>= is available since 2.0 + majorBoundVersion' v = + if csv >= CabalSpecV2_0 + then pure $ majorBoundVersion v + else fail $ unwords + [ "major bounded version syntax (caret, ^>=) used." + , "To use this syntax the package need to specify at least 'cabal-version: 2.0'." + , "Alternatively, if broader compatibility is important then use:" + , prettyShow $ eliminateMajorBoundSyntax $ majorBoundVersion v + ] + where + eliminateMajorBoundSyntax = hyloVersionRange embed projectVersionRange + embed (MajorBoundVersionF u) = intersectVersionRanges + (orLaterVersion u) (earlierVersion (majorUpperBound u)) + embed vr = embedVersionRange vr + + -- version set notation (e.g. "== { 0.0.1.0, 0.0.2.0, 0.1.0.0 }") + verSet' op vs = + if csv >= CabalSpecV3_0 + then pure $ foldr1 unionVersionRanges (fmap op vs) + else fail $ unwords + [ "version set syntax used." + , "To use this syntax the package needs to specify at least 'cabal-version: 3.0'." + , "Alternatively, if broader compatibility is important then use" + , "a series of single version constraints joined with the || operator:" + , prettyShow (foldr1 unionVersionRanges (fmap op vs)) + ] + + verSet :: CabalParsing m => m (NonEmpty Version) + verSet = do + _ <- P.char '{' + P.spaces + vs <- P.sepByNonEmpty (verPlain <* P.spaces) (P.char ',' *> P.spaces) + _ <- P.char '}' + pure vs + + -- a plain version without tags or wildcards + verPlain :: CabalParsing m => m Version + verPlain = mkVersion <$> toList <$> P.sepByNonEmpty digitParser (P.char '.') + + -- either wildcard or normal version + verOrWild :: CabalParsing m => m (Bool, Version) + verOrWild = do + x <- digitParser + verLoop (DList.singleton x) + + -- trailing: wildcard (.y.*) or normal version (optional tags) (.y.z-tag) + verLoop :: CabalParsing m => DList.DList Int -> m (Bool, Version) + verLoop acc = verLoop' acc + <|> (tags *> pure (False, mkVersion (DList.toList acc))) + + verLoop' :: CabalParsing m => DList.DList Int -> m (Bool, Version) + verLoop' acc = do + _ <- P.char '.' + let digit = digitParser >>= verLoop . DList.snoc acc + let wild = (True, mkVersion (DList.toList acc)) <$ P.char '*' + digit <|> wild + + parens p = P.between + ((P.char '(' P. "opening paren") >> P.spaces) + (P.char ')' >> P.spaces) + $ do + a <- p + P.spaces + return a + + tags :: CabalParsing m => m () + tags = do + ts <- many $ P.char '-' *> some (P.satisfy isAlphaNum) + case ts of + [] -> pure () + (_ : _) -> parsecWarning PWTVersionTag "version with tags" + + +---------------------------- +-- Wildcard range utilities +-- + +-- | Compute next greater major version to be used as upper bound. +-- +-- Example: @0.4.1@ produces the version @0.5@ which then can be used +-- to construct a range @>= 0.4.1 && < 0.5@ +-- +-- @since 2.2 +majorUpperBound :: Version -> Version +majorUpperBound = alterVersion $ \numbers -> case numbers of + [] -> [0,1] -- should not happen + [m1] -> [m1,1] -- e.g. version '1' + (m1:m2:_) -> [m1,m2+1] + +-- | Increment the last version number. +-- +-- Example: For @1.2@ this returns @1.3@ +-- so that it can be used as upper bound when resolving @== 1.2.*@. +-- For @0.4.1@ it returns @0.4.2@. +-- +-- @since 2.2 +wildcardUpperBound :: Version -> Version +wildcardUpperBound = alterVersion $ + \lowerBound -> case unsnoc lowerBound of + Nothing -> [] + Just (xs, x) -> xs ++ [x + 1] diff --git a/cabal/Cabal-syntax/src/Distribution/Utils/Base62.hs b/cabal/Cabal-syntax/src/Distribution/Utils/Base62.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Utils/Base62.hs @@ -0,0 +1,22 @@ + +-- | Implementation of base-62 encoding, which we use when computing hashes +-- for fully instantiated unit ids. +module Distribution.Utils.Base62 (hashToBase62) where + +import GHC.Fingerprint ( Fingerprint(..), fingerprintString ) +import Numeric ( showIntAtBase ) +import Data.Char ( chr ) + +-- | Hash a string using GHC's fingerprinting algorithm (a 128-bit +-- MD5 hash) and then encode the resulting hash in base 62. +hashToBase62 :: String -> String +hashToBase62 s = showFingerprint $ fingerprintString s + where + showIntAtBase62 x = showIntAtBase 62 representBase62 x "" + representBase62 x + | x < 10 = chr (48 + x) + | x < 36 = chr (65 + x - 10) + | x < 62 = chr (97 + x - 36) + | otherwise = '@' + showFingerprint (Fingerprint a b) = showIntAtBase62 a ++ showIntAtBase62 b + diff --git a/cabal/Cabal-syntax/src/Distribution/Utils/Generic.hs b/cabal/Cabal-syntax/src/Distribution/Utils/Generic.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Utils/Generic.hs @@ -0,0 +1,576 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE BangPatterns #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Utils.Generic +-- Copyright : Isaac Jones, Simon Marlow 2003-2004 +-- License : BSD3 +-- portions Copyright (c) 2007, Galois Inc. +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- A large and somewhat miscellaneous collection of utility functions used +-- throughout the rest of the Cabal lib and in other tools that use the Cabal +-- lib like @cabal-install@. It has a very simple set of logging actions. It +-- has low level functions for running programs, a bunch of wrappers for +-- various directory and file functions that do extra logging. + +module Distribution.Utils.Generic ( + -- * reading and writing files safely + withFileContents, + writeFileAtomic, + + -- * Unicode + + -- ** Conversions + fromUTF8BS, + fromUTF8LBS, + + toUTF8BS, + toUTF8LBS, + + validateUTF8, + + -- ** File I/O + readUTF8File, + withUTF8FileContents, + writeUTF8File, + + -- ** BOM + ignoreBOM, + + -- ** Misc + normaliseLineEndings, + + -- * generic utils + dropWhileEndLE, + takeWhileEndLE, + equating, + comparing, + isInfixOf, + intercalate, + lowercase, + isAscii, + isAsciiAlpha, + isAsciiAlphaNum, + listUnion, + listUnionRight, + ordNub, + ordNubBy, + ordNubRight, + safeHead, + safeTail, + safeLast, + safeInit, + unintersperse, + wrapText, + wrapLine, + unfoldrM, + spanMaybe, + breakMaybe, + unsnoc, + unsnocNE, + + -- * Triples + fstOf3, + sndOf3, + trdOf3, + + -- * FilePath stuff + isAbsoluteOnAnyPlatform, + isRelativeOnAnyPlatform, + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Utils.String + +import Data.Bits ((.&.), (.|.), shiftL) +import Data.List + ( isInfixOf ) +import qualified Data.Set as Set +import qualified Data.ByteString as SBS +import qualified Data.ByteString.Lazy as LBS + +import System.Directory + ( removeFile, renameFile ) +import System.FilePath + ( (<.>), splitFileName ) +import System.IO + ( withFile, withBinaryFile + , openBinaryTempFileWithDefaultPermissions + , IOMode(ReadMode), hGetContents, hClose ) +import qualified Control.Exception as Exception + +-- ----------------------------------------------------------------------------- +-- Helper functions + +-- | Wraps text to the default line width. Existing newlines are preserved. +wrapText :: String -> String +wrapText = unlines + . map (intercalate "\n" + . map unwords + . wrapLine 79 + . words) + . lines + +-- | Wraps a list of words to a list of lines of words of a particular width. +wrapLine :: Int -> [String] -> [[String]] +wrapLine width = wrap 0 [] + where wrap :: Int -> [String] -> [String] -> [[String]] + wrap 0 [] (w:ws) + | length w + 1 > width + = wrap (length w) [w] ws + wrap col line (w:ws) + | col + length w + 1 > width + = reverse line : wrap 0 [] (w:ws) + wrap col line (w:ws) + = let col' = col + length w + 1 + in wrap col' (w:line) ws + wrap _ [] [] = [] + wrap _ line [] = [reverse line] + +----------------------------------- +-- Safely reading and writing files + +-- | Gets the contents of a file, but guarantee that it gets closed. +-- +-- The file is read lazily but if it is not fully consumed by the action then +-- the remaining input is truncated and the file is closed. +-- +withFileContents :: FilePath -> (String -> IO a) -> IO a +withFileContents name action = + withFile name ReadMode + (\hnd -> hGetContents hnd >>= action) + +-- | Writes a file atomically. +-- +-- The file is either written successfully or an IO exception is raised and +-- the original file is left unchanged. +-- +-- On windows it is not possible to delete a file that is open by a process. +-- This case will give an IO exception but the atomic property is not affected. +-- +writeFileAtomic :: FilePath -> LBS.ByteString -> IO () +writeFileAtomic targetPath content = do + let (targetDir, targetFile) = splitFileName targetPath + Exception.bracketOnError + (openBinaryTempFileWithDefaultPermissions targetDir $ targetFile <.> "tmp") + (\(tmpPath, handle) -> hClose handle >> removeFile tmpPath) + (\(tmpPath, handle) -> do + LBS.hPut handle content + hClose handle + renameFile tmpPath targetPath) + +-- ------------------------------------------------------------ +-- * Unicode stuff +-- ------------------------------------------------------------ + +-- | Decode 'String' from UTF8-encoded 'BS.ByteString' +-- +-- Invalid data in the UTF8 stream (this includes code-points @U+D800@ +-- through @U+DFFF@) will be decoded as the replacement character (@U+FFFD@). +-- +fromUTF8BS :: SBS.ByteString -> String +fromUTF8BS = decodeStringUtf8 . SBS.unpack + +-- | Variant of 'fromUTF8BS' for lazy 'BS.ByteString's +-- +fromUTF8LBS :: LBS.ByteString -> String +fromUTF8LBS = decodeStringUtf8 . LBS.unpack + +-- | Encode 'String' to UTF8-encoded 'SBS.ByteString' +-- +-- Code-points in the @U+D800@-@U+DFFF@ range will be encoded +-- as the replacement character (i.e. @U+FFFD@). +-- +toUTF8BS :: String -> SBS.ByteString +toUTF8BS = SBS.pack . encodeStringUtf8 + +-- | Variant of 'toUTF8BS' for lazy 'BS.ByteString's +-- +toUTF8LBS :: String -> LBS.ByteString +toUTF8LBS = LBS.pack . encodeStringUtf8 + +-- | Check that strict 'ByteString' is valid UTF8. Returns 'Just offset' if it's not. +validateUTF8 :: SBS.ByteString -> Maybe Int +validateUTF8 = go 0 where + go off bs = case SBS.uncons bs of + Nothing -> Nothing + Just (c, bs') + | c <= 0x7F -> go (off + 1) bs' + | c <= 0xBF -> Just off + | c <= 0xDF -> twoBytes off c bs' + | c <= 0xEF -> moreBytes off 3 0x800 bs' (fromIntegral $ c .&. 0xF) + | c <= 0xF7 -> moreBytes off 4 0x10000 bs' (fromIntegral $ c .&. 0x7) + | c <= 0xFB -> moreBytes off 5 0x200000 bs' (fromIntegral $ c .&. 0x3) + | c <= 0xFD -> moreBytes off 6 0x4000000 bs' (fromIntegral $ c .&. 0x1) + | otherwise -> Just off + + twoBytes off c0 bs = case SBS.uncons bs of + Nothing -> Just off + Just (c1, bs') + | c1 .&. 0xC0 == 0x80 -> + if d >= (0x80 :: Int) + then go (off + 2) bs' + else Just off + | otherwise -> Just off + where + d = (fromIntegral (c0 .&. 0x1F) `shiftL` 6) .|. fromIntegral (c1 .&. 0x3F) + + moreBytes :: Int -> Int -> Int -> SBS.ByteString -> Int -> Maybe Int + moreBytes off 1 overlong cs' acc + | overlong <= acc, acc <= 0x10FFFF, acc < 0xD800 || 0xDFFF < acc + = go (off + 1) cs' + + | otherwise + = Just off + + moreBytes off byteCount overlong bs acc = case SBS.uncons bs of + Just (cn, bs') | cn .&. 0xC0 == 0x80 -> + moreBytes (off + 1) (byteCount-1) overlong bs' ((acc `shiftL` 6) .|. fromIntegral cn .&. 0x3F) + _ -> Just off + + +-- | Ignore a Unicode byte order mark (BOM) at the beginning of the input +-- +ignoreBOM :: String -> String +ignoreBOM ('\xFEFF':string) = string +ignoreBOM string = string + +-- | Reads a UTF8 encoded text file as a Unicode String +-- +-- Reads lazily using ordinary 'readFile'. +-- +readUTF8File :: FilePath -> IO String +readUTF8File f = (ignoreBOM . fromUTF8LBS) <$> LBS.readFile f + +-- | Reads a UTF8 encoded text file as a Unicode String +-- +-- Same behaviour as 'withFileContents'. +-- +withUTF8FileContents :: FilePath -> (String -> IO a) -> IO a +withUTF8FileContents name action = + withBinaryFile name ReadMode + (\hnd -> LBS.hGetContents hnd >>= action . ignoreBOM . fromUTF8LBS) + +-- | Writes a Unicode String as a UTF8 encoded text file. +-- +-- Uses 'writeFileAtomic', so provides the same guarantees. +-- +writeUTF8File :: FilePath -> String -> IO () +writeUTF8File path = writeFileAtomic path . toUTF8LBS + +-- | Fix different systems silly line ending conventions +normaliseLineEndings :: String -> String +normaliseLineEndings [] = [] +normaliseLineEndings ('\r':'\n':s) = '\n' : normaliseLineEndings s -- windows +normaliseLineEndings ('\r':s) = '\n' : normaliseLineEndings s -- old OS X +normaliseLineEndings ( c :s) = c : normaliseLineEndings s + +-- ------------------------------------------------------------ +-- * Common utils +-- ------------------------------------------------------------ + +-- | @dropWhileEndLE p@ is equivalent to @reverse . dropWhile p . reverse@, but +-- quite a bit faster. The difference between "Data.List.dropWhileEnd" and this +-- version is that the one in "Data.List" is strict in elements, but spine-lazy, +-- while this one is spine-strict but lazy in elements. That's what @LE@ stands +-- for - "lazy in elements". +-- +-- Example: +-- +-- >>> safeTail $ Data.List.dropWhileEnd (<3) [undefined, 5, 4, 3, 2, 1] +-- *** Exception: Prelude.undefined +-- ... +-- +-- >>> safeTail $ dropWhileEndLE (<3) [undefined, 5, 4, 3, 2, 1] +-- [5,4,3] +-- +-- >>> take 3 $ Data.List.dropWhileEnd (<3) [5, 4, 3, 2, 1, undefined] +-- [5,4,3] +-- +-- >>> take 3 $ dropWhileEndLE (<3) [5, 4, 3, 2, 1, undefined] +-- *** Exception: Prelude.undefined +-- ... +-- +dropWhileEndLE :: (a -> Bool) -> [a] -> [a] +dropWhileEndLE p = foldr (\x r -> if null r && p x then [] else x:r) [] + +-- | @takeWhileEndLE p@ is equivalent to @reverse . takeWhile p . reverse@, but +-- is usually faster (as well as being easier to read). +takeWhileEndLE :: (a -> Bool) -> [a] -> [a] +takeWhileEndLE p = fst . foldr go ([], False) + where + go x (rest, done) + | not done && p x = (x:rest, False) + | otherwise = (rest, True) + +-- | Like 'Data.List.nub', but has @O(n log n)@ complexity instead of +-- @O(n^2)@. Code for 'ordNub' and 'listUnion' taken from Niklas Hambüchen's +-- package. +ordNub :: Ord a => [a] -> [a] +ordNub = ordNubBy id + +-- | Like 'ordNub' and 'Data.List.nubBy'. Selects a key for each element and +-- takes the nub based on that key. +ordNubBy :: Ord b => (a -> b) -> [a] -> [a] +ordNubBy f l = go Set.empty l + where + go !_ [] = [] + go !s (x:xs) + | y `Set.member` s = go s xs + | otherwise = let !s' = Set.insert y s + in x : go s' xs + where + y = f x + +-- | Like "Data.List.union", but has @O(n log n)@ complexity instead of +-- @O(n^2)@. +listUnion :: (Ord a) => [a] -> [a] -> [a] +listUnion a b = a ++ ordNub (filter (`Set.notMember` aSet) b) + where + aSet = Set.fromList a + +-- | A right-biased version of 'ordNub'. +-- +-- Example: +-- +-- >>> ordNub [1,2,1] :: [Int] +-- [1,2] +-- +-- >>> ordNubRight [1,2,1] :: [Int] +-- [2,1] +-- +ordNubRight :: (Ord a) => [a] -> [a] +ordNubRight = fst . foldr go ([], Set.empty) + where + go x p@(l, s) = if x `Set.member` s then p + else (x:l, Set.insert x s) + +-- | A right-biased version of 'listUnion'. +-- +-- Example: +-- +-- >>> listUnion [1,2,3,4,3] [2,1,1] +-- [1,2,3,4,3] +-- +-- >>> listUnionRight [1,2,3,4,3] [2,1,1] +-- [4,3,2,1,1] +-- +listUnionRight :: (Ord a) => [a] -> [a] -> [a] +listUnionRight a b = ordNubRight (filter (`Set.notMember` bSet) a) ++ b + where + bSet = Set.fromList b + +-- | A total variant of 'head'. +-- +-- @since 3.2.0.0 +safeHead :: [a] -> Maybe a +safeHead [] = Nothing +safeHead (x:_) = Just x + +-- | A total variant of 'tail'. +-- +-- @since 3.2.0.0 +safeTail :: [a] -> [a] +safeTail [] = [] +safeTail (_:xs) = xs + +-- | A total variant of 'last'. +-- +-- @since 3.2.0.0 +safeLast :: [a] -> Maybe a +safeLast [] = Nothing +safeLast (x:xs) = Just (foldl (\_ a -> a) x xs) + +-- | A total variant of 'init'. +-- +-- @since 3.2.0.0 +safeInit :: [a] -> [a] +safeInit [] = [] +safeInit [_] = [] +safeInit (x:xs) = x : safeInit xs + +equating :: Eq a => (b -> a) -> b -> b -> Bool +equating p x y = p x == p y + +-- | Lower case string +-- +-- >>> lowercase "Foobar" +-- "foobar" +lowercase :: String -> String +lowercase = map toLower + +-- | Ascii characters +isAscii :: Char -> Bool +isAscii c = fromEnum c < 0x80 + +-- | Ascii letters. +isAsciiAlpha :: Char -> Bool +isAsciiAlpha c = ('a' <= c && c <= 'z') + || ('A' <= c && c <= 'Z') + +-- | Ascii letters and digits. +-- +-- >>> isAsciiAlphaNum 'a' +-- True +-- +-- >>> isAsciiAlphaNum 'ä' +-- False +-- +isAsciiAlphaNum :: Char -> Bool +isAsciiAlphaNum c = isAscii c && isAlphaNum c + +unintersperse :: Char -> String -> [String] +unintersperse mark = unfoldr unintersperse1 where + unintersperse1 str + | null str = Nothing + | otherwise = + let (this, rest) = break (== mark) str in + Just (this, safeTail rest) + +-- | Like 'break', but with 'Maybe' predicate +-- +-- >>> breakMaybe (readMaybe :: String -> Maybe Int) ["foo", "bar", "1", "2", "quu"] +-- (["foo","bar"],Just (1,["2","quu"])) +-- +-- >>> breakMaybe (readMaybe :: String -> Maybe Int) ["foo", "bar"] +-- (["foo","bar"],Nothing) +-- +-- @since 2.2 +-- +breakMaybe :: (a -> Maybe b) -> [a] -> ([a], Maybe (b, [a])) +breakMaybe f = go id where + go !acc [] = (acc [], Nothing) + go !acc (x:xs) = case f x of + Nothing -> go (acc . (x:)) xs + Just b -> (acc [], Just (b, xs)) + +-- | Like 'span' but with 'Maybe' predicate +-- +-- >>> spanMaybe listToMaybe [[1,2],[3],[],[4,5],[6,7]] +-- ([1,3],[[],[4,5],[6,7]]) +-- +-- >>> spanMaybe (readMaybe :: String -> Maybe Int) ["1", "2", "foo"] +-- ([1,2],["foo"]) +-- +-- @since 2.2 +-- +spanMaybe :: (a -> Maybe b) -> [a] -> ([b],[a]) +spanMaybe _ xs@[] = ([], xs) +spanMaybe p xs@(x:xs') = case p x of + Just y -> let (ys, zs) = spanMaybe p xs' in (y : ys, zs) + Nothing -> ([], xs) + +-- | 'unfoldr' with monadic action. +-- +-- >>> take 5 $ unfoldrM (\b r -> Just (r + b, b + 1)) (1 :: Int) 2 +-- [3,4,5,6,7] +-- +-- @since 2.2 +-- +unfoldrM :: Monad m => (b -> m (Maybe (a, b))) -> b -> m [a] +unfoldrM f = go where + go b = do + m <- f b + case m of + Nothing -> return [] + Just (a, b') -> liftM (a :) (go b') + +-- | The opposite of 'snoc', which is the reverse of 'cons' +-- +-- Example: +-- +-- >>> unsnoc [1, 2, 3] +-- Just ([1,2],3) +-- +-- >>> unsnoc [] +-- Nothing +-- +-- @since 3.2.0.0 +-- +unsnoc :: [a] -> Maybe ([a], a) +unsnoc [] = Nothing +unsnoc (x:xs) = Just (unsnocNE (x :| xs)) + +-- | Like 'unsnoc', but for 'NonEmpty' so without the 'Maybe' +-- +-- Example: +-- +-- >>> unsnocNE (1 :| [2, 3]) +-- ([1,2],3) +-- +-- >>> unsnocNE (1 :| []) +-- ([],1) +-- +-- @since 3.2.0.0 +-- +unsnocNE :: NonEmpty a -> ([a], a) +unsnocNE (x:|xs) = go x xs where + go y [] = ([], y) + go y (z:zs) = let ~(ws, w) = go z zs in (y : ws, w) + +------------------------------------------------------------------------------- +-- Triples +------------------------------------------------------------------------------- + +-- | @since 3.4.0.0 +fstOf3 :: (a,b,c) -> a +fstOf3 (a,_,_) = a + +-- | @since 3.4.0.0 +sndOf3 :: (a,b,c) -> b +sndOf3 (_,b,_) = b + +-- | @since 3.4.0.0 +trdOf3 :: (a,b,c) -> c +trdOf3 (_,_,c) = c + +-- ------------------------------------------------------------ +-- * FilePath stuff +-- ------------------------------------------------------------ + +-- | 'isAbsoluteOnAnyPlatform' and 'isRelativeOnAnyPlatform' are like +-- 'System.FilePath.isAbsolute' and 'System.FilePath.isRelative' but have +-- platform independent heuristics. +-- The System.FilePath exists in two versions, Windows and Posix. The two +-- versions don't agree on what is a relative path and we don't know if we're +-- given Windows or Posix paths. +-- This results in false positives when running on Posix and inspecting +-- Windows paths, like the hackage server does. +-- System.FilePath.Posix.isAbsolute \"C:\\hello\" == False +-- System.FilePath.Windows.isAbsolute \"/hello\" == False +-- This means that we would treat paths that start with \"/\" to be absolute. +-- On Posix they are indeed absolute, while on Windows they are not. +-- +-- The portable versions should be used when we might deal with paths that +-- are from another OS than the host OS. For example, the Hackage Server +-- deals with both Windows and Posix paths while performing the +-- PackageDescription checks. In contrast, when we run 'cabal configure' we +-- do expect the paths to be correct for our OS and we should not have to use +-- the platform independent heuristics. +isAbsoluteOnAnyPlatform :: FilePath -> Bool +-- C:\\directory +isAbsoluteOnAnyPlatform (drive:':':'\\':_) = isAlpha drive +isAbsoluteOnAnyPlatform (drive:':':'/':_) = isAlpha drive +-- UNC +isAbsoluteOnAnyPlatform ('\\':'\\':_) = True +-- Posix root +isAbsoluteOnAnyPlatform ('/':_) = True +isAbsoluteOnAnyPlatform _ = False + +-- | @isRelativeOnAnyPlatform = not . 'isAbsoluteOnAnyPlatform'@ +isRelativeOnAnyPlatform :: FilePath -> Bool +isRelativeOnAnyPlatform = not . isAbsoluteOnAnyPlatform + +-- $setup +-- >>> import Data.Maybe +-- >>> import Text.Read diff --git a/cabal/Cabal-syntax/src/Distribution/Utils/MD5.hs b/cabal/Cabal-syntax/src/Distribution/Utils/MD5.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Utils/MD5.hs @@ -0,0 +1,79 @@ +module Distribution.Utils.MD5 ( + MD5, + showMD5, + md5, + -- * Helpers + md5FromInteger, + -- * Binary + binaryPutMD5, + binaryGetMD5, + ) where + +import Data.Binary (Get, Put) +import Data.Binary.Get (getWord64le) +import Data.Binary.Put (putWord64le) +import Data.Bits (complement, shiftR, (.&.)) +import Foreign.Ptr (castPtr) +import GHC.Fingerprint (Fingerprint (..), fingerprintData) +import Numeric (showHex) +import System.IO.Unsafe (unsafeDupablePerformIO) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Unsafe as BS + +type MD5 = Fingerprint + +-- | Show 'MD5' in human readable form +-- +-- >>> showMD5 (Fingerprint 123 456) +-- "000000000000007b00000000000001c8" +-- +-- >>> showMD5 $ md5 $ BS.pack [0..127] +-- "37eff01866ba3f538421b30b7cbefcac" +-- +-- @since 3.2.0.0 +showMD5 :: MD5 -> String +showMD5 (Fingerprint a b) = pad a' ++ pad b' where + a' = showHex a "" + b' = showHex b "" + pad s = replicate (16 - length s) '0' ++ s + +-- | @since 3.2.0.0 +md5 :: BS.ByteString -> MD5 +md5 bs = unsafeDupablePerformIO $ BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> + fingerprintData (castPtr ptr) len + +-- | @since 3.2.0.0 +binaryPutMD5 :: MD5 -> Put +binaryPutMD5 (Fingerprint a b) = do + putWord64le a + putWord64le b + +-- | @since 3.2.0.0 +binaryGetMD5 :: Get MD5 +binaryGetMD5 = do + a <- getWord64le + b <- getWord64le + return (Fingerprint a b) + +-- | +-- +-- >>> showMD5 $ md5FromInteger 0x37eff01866ba3f538421b30b7cbefcac +-- "37eff01866ba3f538421b30b7cbefcac" +-- +-- Note: the input is truncated: +-- +-- >>> showMD5 $ md5FromInteger 0x1230000037eff01866ba3f538421b30b7cbefcac +-- "37eff01866ba3f538421b30b7cbefcac" +-- +-- Yet, negative numbers are not a problem... +-- +-- >>> showMD5 $ md5FromInteger (-1) +-- "ffffffffffffffffffffffffffffffff" +-- +-- @since 3.4.0.0 +md5FromInteger :: Integer -> MD5 +md5FromInteger i = Fingerprint hi lo where + mask = complement 0 + lo = mask .&. fromInteger i + hi = mask .&. fromInteger (i `shiftR` 64) diff --git a/cabal/Cabal-syntax/src/Distribution/Utils/Path.hs b/cabal/Cabal-syntax/src/Distribution/Utils/Path.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Utils/Path.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} +module Distribution.Utils.Path ( + -- * Symbolic path + SymbolicPath, + getSymbolicPath, + sameDirectory, + unsafeMakeSymbolicPath, + -- * Path ends + PackageDir, + SourceDir, + LicenseFile, + IsDir, +) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Parsec +import Distribution.Pretty +import Distribution.Utils.Generic (isAbsoluteOnAnyPlatform) + +import qualified Distribution.Compat.CharParsing as P +-- import qualified Text.PrettyPrint as Disp + +------------------------------------------------------------------------------- +-- * SymbolicPath +------------------------------------------------------------------------------- + +-- | Symbolic paths. +-- +-- These paths are system independent and relative. +-- They are *symbolic* which means we cannot perform any 'IO' +-- until we interpret them. +-- +newtype SymbolicPath from to = SymbolicPath FilePath + deriving (Generic, Show, Read, Eq, Ord, Typeable, Data) + +instance Binary (SymbolicPath from to) +instance (Typeable from, Typeable to) => Structured (SymbolicPath from to) +instance NFData (SymbolicPath from to) where rnf = genericRnf + +-- | Extract underlying 'FilePath'. +-- +-- Avoid using this in new code. +-- +getSymbolicPath :: SymbolicPath from to -> FilePath +getSymbolicPath (SymbolicPath p) = p + +sameDirectory :: (IsDir from, IsDir to) => SymbolicPath from to +sameDirectory = SymbolicPath "." + +-- | Make 'SymbolicPath' without performing any checks. +unsafeMakeSymbolicPath :: FilePath -> SymbolicPath from to +unsafeMakeSymbolicPath = SymbolicPath + +------------------------------------------------------------------------------- +-- ** Parsing and pretty printing +------------------------------------------------------------------------------- + +instance Parsec (SymbolicPath from to) where + parsec = do + token <- parsecToken + if null token then P.unexpected "empty FilePath" + else if isAbsoluteOnAnyPlatform token then P.unexpected "absolute FilePath" + else return (SymbolicPath token) -- TODO: normalise + +instance Pretty (SymbolicPath from to) where + pretty = showFilePath . getSymbolicPath + +------------------------------------------------------------------------------- +-- * Composition +------------------------------------------------------------------------------- + +-- TODO +-- infixr 5 +-- +-- -- | Path composition +-- -- +-- -- We don't reuse @@ name to not clash with "System.FilePath". +-- -- +-- () :: path a b -> path b c -> path a c + +------------------------------------------------------------------------------- +-- * Path ends +------------------------------------------------------------------------------- + +-- | Class telling that index is for directories. +class IsDir dir + +data PackageDir deriving (Typeable) +data SourceDir deriving (Typeable) + +data LicenseFile deriving (Typeable) + +-- These instances needs to be derived standalone at least on GHC-7.6 +deriving instance Data PackageDir +deriving instance Data SourceDir +deriving instance Data LicenseFile + +instance IsDir PackageDir +instance IsDir SourceDir diff --git a/cabal/Cabal-syntax/src/Distribution/Utils/ShortText.hs b/cabal/Cabal-syntax/src/Distribution/Utils/ShortText.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Utils/ShortText.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +-- | Compact representation of short 'Strings' +-- +-- This module is designed to be import qualifeid +-- +-- @ +-- import Distribution.Utils.ShortText (ShortText) +-- import qualified Distribution.Utils.ShortText as ShortText +-- @ +module Distribution.Utils.ShortText + ( -- * 'ShortText' type + ShortText + , toShortText + , fromShortText + , unsafeFromUTF8BS + + -- * Operations + , null + , length + + -- * internal utilities + , decodeStringUtf8 + , encodeStringUtf8 + ) where + +import Distribution.Compat.Prelude hiding (length, null) +import Prelude () + +import Distribution.Utils.String (decodeStringUtf8, encodeStringUtf8) +import Distribution.Utils.Structured (Structured (..), nominalStructure) + +#if defined(MIN_VERSION_bytestring) +# if MIN_VERSION_bytestring(0,10,4) +# define HAVE_SHORTBYTESTRING 1 +# endif +#endif + +-- Hack for GHC bootstrapping +-- +-- Currently (as of GHC 8.1), GHC bootstraps Cabal by building +-- binary and Cabal in one giant ghc --make command. This +-- means no MIN_VERSION_binary macro is available. +-- +-- We could try to cleverly figure something out in this case, +-- but there is a better plan: just use the unoptimized version +-- of the Binary instance. We're not going to use it for anything +-- real in any case. +-- +-- WARNING: Don't use MIN_VERSION_binary to smooth over a BC-break! +-- +#ifndef MIN_VERSION_binary +#define MIN_VERSION_binary(x, y, z) 0 +#endif + +import qualified Data.ByteString as BS +import qualified Data.List as List + +#if HAVE_SHORTBYTESTRING +import qualified Data.ByteString.Short as BS.Short +#else +import Distribution.Utils.Generic (fromUTF8BS) +#endif + +-- | Construct 'ShortText' from 'String' +toShortText :: String -> ShortText + +-- | Convert 'ShortText' to 'String' +fromShortText :: ShortText -> String + +-- | Convert from UTF-8 encoded strict 'ByteString'. +-- +-- @since 3.2.0.0 +unsafeFromUTF8BS :: BS.ByteString -> ShortText + +-- | Text whether 'ShortText' is empty. +-- +-- @since 3.2.0.0 +null :: ShortText -> Bool + +-- | Compact representation of short 'Strings' +-- +-- The data is stored internally as UTF8 in an +-- 'BS.Short.ShortByteString' when compiled against @bytestring >= +-- 0.10.4@, and otherwise the fallback is to use plain old non-compat +-- '[Char]'. +-- +-- Note: This type is for internal uses (such as e.g. 'PackageName') +-- and shall not be exposed in Cabal's API +-- +-- @since 2.0.0.2 +#if HAVE_SHORTBYTESTRING +newtype ShortText = ST { unST :: BS.Short.ShortByteString } + deriving (Eq,Ord,Generic,Data,Typeable) + +# if MIN_VERSION_binary(0,8,1) +instance Binary ShortText where + put = put . unST + get = fmap ST get +# else +instance Binary ShortText where + put = put . BS.Short.fromShort . unST + get = fmap (ST . BS.Short.toShort) get +# endif + + +toShortText = ST . BS.Short.pack . encodeStringUtf8 + +fromShortText = decodeStringUtf8 . BS.Short.unpack . unST + +unsafeFromUTF8BS = ST . BS.Short.toShort + +null = BS.Short.null . unST +#else +newtype ShortText = ST { unST :: String } + deriving (Eq,Ord,Generic,Data,Typeable) + +instance Binary ShortText where + put = put . encodeStringUtf8 . unST + get = fmap (ST . decodeStringUtf8) get + +toShortText = ST + +fromShortText = unST + +unsafeFromUTF8BS = ST . fromUTF8BS + +null = List.null . unST +#endif + +instance Structured ShortText where structure = nominalStructure + +instance NFData ShortText where + rnf = rnf . unST + +instance Show ShortText where + show = show . fromShortText + +instance Read ShortText where + readsPrec p = map (first toShortText) . readsPrec p + +instance Semigroup ShortText where + ST a <> ST b = ST (mappend a b) + +instance Monoid ShortText where + mempty = ST mempty + mappend = (<>) + +instance IsString ShortText where + fromString = toShortText + +-- | /O(n)/. Length in characters. /Slow/ as converts to string. +-- +-- @since 3.2.0.0 +length :: ShortText -> Int +length = List.length . fromShortText +-- Note: avoid using it, we use it @cabal check@ implementation, where it's ok. diff --git a/cabal/Cabal-syntax/src/Distribution/Utils/String.hs b/cabal/Cabal-syntax/src/Distribution/Utils/String.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Utils/String.hs @@ -0,0 +1,100 @@ +module Distribution.Utils.String + ( -- * Encode to/from UTF8 + decodeStringUtf8 + , encodeStringUtf8 + , trim + ) where + +import Data.Word +import Data.Bits +import Data.Char (chr,ord) +import Data.List (dropWhileEnd) +import GHC.Unicode (isSpace) + +-- | Decode 'String' from UTF8-encoded octets. +-- +-- Invalid data in the UTF8 stream (this includes code-points @U+D800@ +-- through @U+DFFF@) will be decoded as the replacement character (@U+FFFD@). +-- +-- See also 'encodeStringUtf8' +decodeStringUtf8 :: [Word8] -> String +decodeStringUtf8 = go + where + go :: [Word8] -> String + go [] = [] + go (c : cs) + | c <= 0x7F = chr (fromIntegral c) : go cs + | c <= 0xBF = replacementChar : go cs + | c <= 0xDF = twoBytes c cs + | c <= 0xEF = moreBytes 3 0x800 cs (fromIntegral $ c .&. 0xF) + | c <= 0xF7 = moreBytes 4 0x10000 cs (fromIntegral $ c .&. 0x7) + | c <= 0xFB = moreBytes 5 0x200000 cs (fromIntegral $ c .&. 0x3) + | c <= 0xFD = moreBytes 6 0x4000000 cs (fromIntegral $ c .&. 0x1) + | otherwise = replacementChar : go cs + + twoBytes :: Word8 -> [Word8] -> String + twoBytes c0 (c1:cs') + | c1 .&. 0xC0 == 0x80 + = let d = (fromIntegral (c0 .&. 0x1F) `shiftL` 6) + .|. fromIntegral (c1 .&. 0x3F) + in if d >= 0x80 + then chr d : go cs' + else replacementChar : go cs' + twoBytes _ cs' = replacementChar : go cs' + + moreBytes :: Int -> Int -> [Word8] -> Int -> [Char] + moreBytes 1 overlong cs' acc + | overlong <= acc, acc <= 0x10FFFF, acc < 0xD800 || 0xDFFF < acc + = chr acc : go cs' + + | otherwise + = replacementChar : go cs' + + moreBytes byteCount overlong (cn:cs') acc + | cn .&. 0xC0 == 0x80 + = moreBytes (byteCount-1) overlong cs' + ((acc `shiftL` 6) .|. fromIntegral cn .&. 0x3F) + + moreBytes _ _ cs' _ + = replacementChar : go cs' + + replacementChar = '\xfffd' + + +-- | Encode 'String' to a list of UTF8-encoded octets +-- +-- Code-points in the @U+D800@-@U+DFFF@ range will be encoded +-- as the replacement character (i.e. @U+FFFD@). +-- +-- See also 'decodeUtf8' +encodeStringUtf8 :: String -> [Word8] +encodeStringUtf8 [] = [] +encodeStringUtf8 (c:cs) + | c <= '\x07F' = w8 + : encodeStringUtf8 cs + | c <= '\x7FF' = (0xC0 .|. w8ShiftR 6 ) + : (0x80 .|. (w8 .&. 0x3F)) + : encodeStringUtf8 cs + | c <= '\xD7FF'= (0xE0 .|. w8ShiftR 12 ) + : (0x80 .|. (w8ShiftR 6 .&. 0x3F)) + : (0x80 .|. (w8 .&. 0x3F)) + : encodeStringUtf8 cs + | c <= '\xDFFF'= 0xEF : 0xBF : 0xBD -- U+FFFD + : encodeStringUtf8 cs + | c <= '\xFFFF'= (0xE0 .|. w8ShiftR 12 ) + : (0x80 .|. (w8ShiftR 6 .&. 0x3F)) + : (0x80 .|. (w8 .&. 0x3F)) + : encodeStringUtf8 cs + | otherwise = (0xf0 .|. w8ShiftR 18 ) + : (0x80 .|. (w8ShiftR 12 .&. 0x3F)) + : (0x80 .|. (w8ShiftR 6 .&. 0x3F)) + : (0x80 .|. (w8 .&. 0x3F)) + : encodeStringUtf8 cs + where + w8 = fromIntegral (ord c) :: Word8 + w8ShiftR :: Int -> Word8 + w8ShiftR = fromIntegral . shiftR (ord c) + +-- @since 3.8.0.0 +trim :: String -> String +trim = dropWhile isSpace . dropWhileEnd isSpace diff --git a/cabal/Cabal-syntax/src/Distribution/Utils/Structured.hs b/cabal/Cabal-syntax/src/Distribution/Utils/Structured.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Utils/Structured.hs @@ -0,0 +1,434 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeInType #-} +-- | +-- +-- Copyright: (c) 2019 Oleg Grenrus +-- +-- Structurally tag binary serialisation stream. +-- Useful when most 'Binary' instances are 'Generic' derived. +-- +-- Say you have a data type +-- +-- @ +-- data Record = Record +-- { _recordFields :: HM.HashMap Text (Integer, ByteString) +-- , _recordEnabled :: Bool +-- } +-- deriving (Eq, Show, Generic) +-- +-- instance 'Binary' Record +-- instance 'Structured' Record +-- @ +-- +-- then you can serialise and deserialise @Record@ values with a structure tag by simply +-- +-- @ +-- 'structuredEncode' record :: 'LBS.ByteString' +-- 'structuredDecode' lbs :: IO Record +-- @ +-- +-- If structure of @Record@ changes in between, deserialisation will fail early. +-- +-- Technically, 'Structured' is not related to 'Binary', and may +-- be useful in other uses. +-- +module Distribution.Utils.Structured ( + -- * Encoding and decoding + -- | These functions operate like @binary@'s counterparts, + -- but the serialised version has a structure hash in front. + structuredEncode, + structuredEncodeFile, + structuredDecode, + structuredDecodeOrFailIO, + structuredDecodeFileOrFail, + -- * Structured class + Structured (structure), + MD5, + structureHash, + structureBuilder, + genericStructure, + GStructured, + nominalStructure, + containerStructure, + -- * Structure type + Structure (..), + Tag (..), + TypeName, + ConstructorName, + TypeVersion, + SopStructure, + hashStructure, + typeVersion, + typeName, + ) where + +import Data.Int (Int16, Int32, Int64, Int8) +import Data.List.NonEmpty (NonEmpty) +import Data.Proxy (Proxy (..)) +import Data.Ratio (Ratio) +import Data.Word (Word, Word16, Word32, Word64, Word8) + +import qualified Control.Monad.Trans.State.Strict as State + +import Control.Exception (ErrorCall (..), catch, evaluate) + +import GHC.Generics + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +#if MIN_VERSION_bytestring(0,10,4) +import qualified Data.ByteString.Builder as Builder +#else +import qualified Data.ByteString.Lazy.Builder as Builder +#endif +import qualified Data.IntMap as IM +import qualified Data.IntSet as IS +import qualified Data.Map as Map +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT +import qualified Data.Time as Time +import qualified Distribution.Compat.Binary as Binary + +#ifdef MIN_VERSION_aeson +import qualified Data.Aeson as Aeson +#endif + +import Data.Kind (Type) + +import Distribution.Compat.Typeable (Typeable, TypeRep, typeRep) +import Distribution.Utils.MD5 + +import Data.Monoid (mconcat) + +import qualified Data.Semigroup +import qualified Data.Foldable + + +------------------------------------------------------------------------------- +-- Types +------------------------------------------------------------------------------- + +type TypeName = String +type ConstructorName = String + +-- | A semantic version of a data type. Usually 0. +type TypeVersion = Word32 + +-- | Structure of a datatype. +-- +-- It can be infinite, as far as 'TypeRep's involved are finite. +-- (e.g. polymorphic recursion might cause troubles). +-- +data Structure + = Nominal !TypeRep !TypeVersion TypeName [Structure] -- ^ nominal, yet can be parametrised by other structures. + | Newtype !TypeRep !TypeVersion TypeName Structure -- ^ a newtype wrapper + | Structure !TypeRep !TypeVersion TypeName SopStructure -- ^ sum-of-products structure + deriving (Eq, Ord, Show, Generic) + +type SopStructure = [(ConstructorName, [Structure])] + +-- | A MD5 hash digest of 'Structure'. +hashStructure :: Structure -> MD5 +hashStructure = md5 . LBS.toStrict . Builder.toLazyByteString . structureBuilder + +-- | A van-Laarhoven lens into 'TypeVersion' of 'Structure' +-- +-- @ +-- 'typeVersion' :: Lens' 'Structure' 'TypeVersion' +-- @ +typeVersion :: Functor f => (TypeVersion -> f TypeVersion) -> Structure -> f Structure +typeVersion f (Nominal t v n s) = fmap (\v' -> Nominal t v' n s) (f v) +typeVersion f (Newtype t v n s) = fmap (\v' -> Newtype t v' n s) (f v) +typeVersion f (Structure t v n s) = fmap (\v' -> Structure t v' n s) (f v) + +-- | A van-Laarhoven lens into 'TypeName' of 'Structure' +-- +-- @ +-- 'typeName' :: Lens' 'Structure' 'TypeName' +-- @ +typeName :: Functor f => (TypeName -> f TypeName) -> Structure -> f Structure +typeName f (Nominal t v n s) = fmap (\n' -> Nominal t v n' s) (f n) +typeName f (Newtype t v n s) = fmap (\n' -> Newtype t v n' s) (f n) +typeName f (Structure t v n s) = fmap (\n' -> Structure t v n' s) (f n) + +------------------------------------------------------------------------------- +-- Builder +------------------------------------------------------------------------------- + +-- | Flatten 'Structure' into something we can calculate hash of. +-- +-- As 'Structure' can be potentially infinite. For mutually recursive types, +-- we keep track of 'TypeRep's, and put just 'TypeRep' name when it's occurred +-- another time. +structureBuilder :: Structure -> Builder.Builder +structureBuilder s0 = State.evalState (go s0) Map.empty where + go :: Structure -> State.State (Map.Map String (NonEmpty TypeRep)) Builder.Builder + go (Nominal t v n s) = withTypeRep t $ do + s' <- traverse go s + return $ mconcat $ Builder.word8 1 : Builder.word32LE v : Builder.stringUtf8 n : s' + + go (Newtype t v n s) = withTypeRep t $ do + s' <- go s + return $ mconcat [Builder.word8 2, Builder.word32LE v, Builder.stringUtf8 n, s'] + + go (Structure t v n s) = withTypeRep t $ do + s' <- goSop s + return $ mconcat [Builder.word8 3, Builder.word32LE v, Builder.stringUtf8 n, s'] + + withTypeRep t k = do + acc <- State.get + case insert t acc of + Nothing -> return $ mconcat [ Builder.word8 0, Builder.stringUtf8 (show t) ] + Just acc' -> do + State.put acc' + k + + goSop :: SopStructure -> State.State (Map.Map String (NonEmpty TypeRep)) Builder.Builder + goSop sop = do + parts <- traverse part sop + return $ mconcat parts + + part (cn, s) = do + s' <- traverse go s + return $ Data.Monoid.mconcat [ Builder.stringUtf8 cn, mconcat s' ] + + insert :: TypeRep -> Map.Map String (NonEmpty TypeRep) -> Maybe (Map.Map String (NonEmpty TypeRep)) + insert tr m = case Map.lookup trShown m of + Nothing -> inserted + Just ne | tr `Data.Foldable.elem` ne -> Nothing + | otherwise -> inserted + where + inserted = Just (Map.insertWith (Data.Semigroup.<>) trShown (pure tr) m) + trShown = show tr + +------------------------------------------------------------------------------- +-- Classes +------------------------------------------------------------------------------- + +-- | Class of types with a known 'Structure'. +-- +-- For regular data types 'Structured' can be derived generically. +-- +-- @ +-- data Record = Record { a :: Int, b :: Bool, c :: [Char] } deriving ('Generic') +-- instance 'Structured' Record +-- @ +-- +-- @since 3.2.0.0 +-- +class Typeable a => Structured a where + structure :: Proxy a -> Structure + default structure :: (Generic a, GStructured (Rep a)) => Proxy a -> Structure + structure = genericStructure + + -- This member is hidden. It's there to precalc + structureHash' :: Tagged a MD5 + structureHash' = Tagged (hashStructure (structure (Proxy :: Proxy a))) + +-- private Tagged +newtype Tagged a b = Tagged { untag :: b } + +-- | Semantically @'hashStructure' . 'structure'@. +structureHash :: forall a. Structured a => Proxy a -> MD5 +structureHash _ = untag (structureHash' :: Tagged a MD5) + +------------------------------------------------------------------------------- +-- Functions +------------------------------------------------------------------------------- + +-- | Structured 'Binary.encode'. +-- Encode a value to using binary serialisation to a lazy 'LBS.ByteString'. +-- Encoding starts with 16 byte large structure hash. +structuredEncode + :: forall a. (Binary.Binary a, Structured a) + => a -> LBS.ByteString +structuredEncode x = Binary.encode (Tag :: Tag a, x) + +-- | Lazily serialise a value to a file +structuredEncodeFile :: (Binary.Binary a, Structured a) => FilePath -> a -> IO () +structuredEncodeFile f = LBS.writeFile f . structuredEncode + +-- | Structured 'Binary.decode'. +-- Decode a value from a lazy 'LBS.ByteString', reconstructing the original structure. +-- Throws pure exception on invalid inputs. +structuredDecode + :: forall a. (Binary.Binary a, Structured a) + => LBS.ByteString -> a +structuredDecode lbs = snd (Binary.decode lbs :: (Tag a, a)) + +structuredDecodeOrFailIO :: (Binary.Binary a, Structured a) => LBS.ByteString -> IO (Either String a) +structuredDecodeOrFailIO bs = + catch (evaluate (structuredDecode bs) >>= return . Right) handler + where + handler (ErrorCallWithLocation str _) = return $ Left str + +-- | Lazily reconstruct a value previously written to a file. +structuredDecodeFileOrFail :: (Binary.Binary a, Structured a) => FilePath -> IO (Either String a) +structuredDecodeFileOrFail f = structuredDecodeOrFailIO =<< LBS.readFile f + +------------------------------------------------------------------------------- +-- Helper data +------------------------------------------------------------------------------- + +data Tag a = Tag + +instance Structured a => Binary.Binary (Tag a) where + get = do + actual <- binaryGetMD5 + if actual == expected + then return Tag + else fail $ concat + [ "Non-matching structured hashes: " + , showMD5 actual + , "; expected: " + , showMD5 expected + ] + where + expected = untag (structureHash' :: Tagged a MD5) + + put _ = binaryPutMD5 expected + where + expected = untag (structureHash' :: Tagged a MD5) + +------------------------------------------------------------------------------- +-- Smart constructors +------------------------------------------------------------------------------- + +-- | Use 'Typeable' to infer name +nominalStructure :: Typeable a => Proxy a -> Structure +nominalStructure p = Nominal tr 0 (show tr) [] where + tr = typeRep p + +containerStructure :: forall f a. (Typeable f, Structured a) => Proxy (f a) -> Structure +containerStructure _ = Nominal faTypeRep 0 (show fTypeRep) + [ structure (Proxy :: Proxy a) + ] + where + fTypeRep = typeRep (Proxy :: Proxy f) + faTypeRep = typeRep (Proxy :: Proxy (f a)) + +------------------------------------------------------------------------------- +-- Generic +------------------------------------------------------------------------------- + +-- | Derive 'structure' genrically. +genericStructure :: forall a. (Typeable a, Generic a, GStructured (Rep a)) => Proxy a -> Structure +genericStructure _ = gstructured (typeRep (Proxy :: Proxy a)) (Proxy :: Proxy (Rep a)) 0 + +-- | Used to implement 'genericStructure'. +class GStructured (f :: Type -> Type) where + gstructured :: TypeRep -> Proxy f -> TypeVersion -> Structure + +instance (i ~ D, Datatype c, GStructuredSum f) => GStructured (M1 i c f) where + gstructured tr _ v = case sop of + [(_, [s])] | isNewtype p -> Newtype tr v name s + _ -> Structure tr v name sop + where + p = undefined :: M1 i c f () + name = datatypeName p + sop = gstructuredSum (Proxy :: Proxy f) [] + +class GStructuredSum (f :: Type -> Type) where + gstructuredSum :: Proxy f -> SopStructure -> SopStructure + +instance (i ~ C, Constructor c, GStructuredProd f) => GStructuredSum (M1 i c f) where + gstructuredSum _ xs = (name, prod) : xs + where + name = conName (undefined :: M1 i c f ()) + prod = gstructuredProd (Proxy :: Proxy f) [] + +instance (GStructuredSum f, GStructuredSum g) => GStructuredSum (f :+: g) where + gstructuredSum _ xs + = gstructuredSum (Proxy :: Proxy f) + $ gstructuredSum (Proxy :: Proxy g) xs + +instance GStructuredSum V1 where + gstructuredSum _ = id + +class GStructuredProd (f :: Type -> Type) where + gstructuredProd :: Proxy f -> [Structure] -> [Structure] + +instance (i ~ S, GStructuredProd f) => GStructuredProd (M1 i c f) where + gstructuredProd _ = gstructuredProd (Proxy :: Proxy f) + +instance Structured c => GStructuredProd (K1 i c) where + gstructuredProd _ xs = structure (Proxy :: Proxy c) : xs + +instance GStructuredProd U1 where + gstructuredProd _ = id + +instance (GStructuredProd f, GStructuredProd g) => GStructuredProd (f :*: g) where + gstructuredProd _ xs + = gstructuredProd (Proxy :: Proxy f) + $ gstructuredProd (Proxy :: Proxy g) xs + +------------------------------------------------------------------------------- +-- instances +------------------------------------------------------------------------------- + +instance Structured () +instance Structured Bool +instance Structured Ordering + +instance Structured Char where structure = nominalStructure +instance Structured Int where structure = nominalStructure +instance Structured Integer where structure = nominalStructure + +instance Structured Data.Word.Word where structure = nominalStructure + +instance Structured Int8 where structure = nominalStructure +instance Structured Int16 where structure = nominalStructure +instance Structured Int32 where structure = nominalStructure +instance Structured Int64 where structure = nominalStructure + +instance Structured Word8 where structure = nominalStructure +instance Structured Word16 where structure = nominalStructure +instance Structured Word32 where structure = nominalStructure +instance Structured Word64 where structure = nominalStructure + +instance Structured Float where structure = nominalStructure +instance Structured Double where structure = nominalStructure + +instance Structured a => Structured (Maybe a) +instance (Structured a, Structured b) => Structured (Either a b) +instance Structured a => Structured (Ratio a) where structure = containerStructure +instance Structured a => Structured [a] where structure = containerStructure +instance Structured a => Structured (NonEmpty a) where structure = containerStructure + +instance (Structured a1, Structured a2) => Structured (a1, a2) +instance (Structured a1, Structured a2, Structured a3) => Structured (a1, a2, a3) +instance (Structured a1, Structured a2, Structured a3, Structured a4) => Structured (a1, a2, a3, a4) +instance (Structured a1, Structured a2, Structured a3, Structured a4, Structured a5) => Structured (a1, a2, a3, a4, a5) +instance (Structured a1, Structured a2, Structured a3, Structured a4, Structured a5, Structured a6) => Structured (a1, a2, a3, a4, a5, a6) +instance (Structured a1, Structured a2, Structured a3, Structured a4, Structured a5, Structured a6, Structured a7) => Structured (a1, a2, a3, a4, a5, a6, a7) + +instance Structured BS.ByteString where structure = nominalStructure +instance Structured LBS.ByteString where structure = nominalStructure + +instance Structured T.Text where structure = nominalStructure +instance Structured LT.Text where structure = nominalStructure + +instance (Structured k, Structured v) => Structured (Map.Map k v) where structure _ = Nominal (typeRep (Proxy :: Proxy (Map.Map k v))) 0 "Map" [ structure (Proxy :: Proxy k), structure (Proxy :: Proxy v) ] +instance (Structured k) => Structured (Set.Set k) where structure = containerStructure +instance (Structured v) => Structured (IM.IntMap v) where structure = containerStructure +instance Structured IS.IntSet where structure = nominalStructure +instance (Structured v) => Structured (Seq.Seq v) where structure = containerStructure + +instance Structured Time.UTCTime where structure = nominalStructure +instance Structured Time.DiffTime where structure = nominalStructure +instance Structured Time.UniversalTime where structure = nominalStructure +instance Structured Time.NominalDiffTime where structure = nominalStructure +instance Structured Time.Day where structure = nominalStructure +instance Structured Time.TimeZone where structure = nominalStructure +instance Structured Time.TimeOfDay where structure = nominalStructure +instance Structured Time.LocalTime where structure = nominalStructure diff --git a/cabal/Cabal-syntax/src/Distribution/Version.hs b/cabal/Cabal-syntax/src/Distribution/Version.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Distribution/Version.hs @@ -0,0 +1,185 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Version +-- Copyright : Isaac Jones, Simon Marlow 2003-2004 +-- Duncan Coutts 2008 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Exports the 'Version' type along with a parser and pretty printer. A version +-- is something like @\"1.3.3\"@. It also defines the 'VersionRange' data +-- types. Version ranges are like @\">= 1.2 && < 2\"@. + +module Distribution.Version ( + -- * Package versions + Version, + version0, + mkVersion, + mkVersion', + versionNumbers, + nullVersion, + alterVersion, + + -- * Version ranges + VersionRange, + + -- ** Constructing + anyVersion, noVersion, + thisVersion, notThisVersion, + laterVersion, earlierVersion, + orLaterVersion, orEarlierVersion, + unionVersionRanges, intersectVersionRanges, + withinVersion, + majorBoundVersion, + + -- ** Inspection + withinRange, + isAnyVersion, + isNoVersion, + isSpecificVersion, + simplifyVersionRange, + foldVersionRange, + normaliseVersionRange, + stripParensVersionRange, + hasUpperBound, + hasLowerBound, + + -- ** Cata & ana + VersionRangeF (..), + cataVersionRange, + anaVersionRange, + hyloVersionRange, + projectVersionRange, + embedVersionRange, + + -- ** Utilities + wildcardUpperBound, + majorUpperBound, + + -- ** Modification + removeUpperBound, + removeLowerBound, + transformCaret, + transformCaretUpper, + transformCaretLower, + + -- * Version intervals view + asVersionIntervals, + VersionInterval(..), + LowerBound(..), + UpperBound(..), + Bound(..), + + -- ** 'VersionIntervals' abstract type + -- | The 'VersionIntervals' type and the accompanying functions are exposed + -- primarily for completeness and testing purposes. In practice + -- 'asVersionIntervals' is the main function to use to + -- view a 'VersionRange' as a bunch of 'VersionInterval's. + -- + VersionIntervals, + toVersionIntervals, + fromVersionIntervals, + unVersionIntervals, + + ) where + +import Distribution.Types.Version +import Distribution.Types.VersionRange +import Distribution.Types.VersionInterval + +------------------------------------------------------------------------------- +-- Utilities on VersionRange requiring VersionInterval +------------------------------------------------------------------------------- + +-- | This is the converse of 'isAnyVersion'. It check if the version range is +-- empty, if there is no possible version that satisfies the version range. +-- +-- For example this is @True@ (for all @v@): +-- +-- > isNoVersion (EarlierVersion v `IntersectVersionRanges` LaterVersion v) +-- +isNoVersion :: VersionRange -> Bool +isNoVersion vr = case asVersionIntervals vr of + [] -> True + _ -> False + +-- | Is this version range in fact just a specific version? +-- +-- For example the version range @\">= 3 && <= 3\"@ contains only the version +-- @3@. +-- +isSpecificVersion :: VersionRange -> Maybe Version +isSpecificVersion vr = case asVersionIntervals vr of + [VersionInterval (LowerBound v InclusiveBound) (UpperBound v' InclusiveBound)] + | v == v' -> Just v + _ -> Nothing + +------------------------------------------------------------------------------- +-- Transformations +------------------------------------------------------------------------------- + +-- | Simplify a 'VersionRange' expression. For non-empty version ranges +-- this produces a canonical form. Empty or inconsistent version ranges +-- are left as-is because that provides more information. +-- +-- If you need a canonical form use +-- @fromVersionIntervals . toVersionIntervals@ +-- +-- It satisfies the following properties: +-- +-- > withinRange v (simplifyVersionRange r) = withinRange v r +-- +-- > withinRange v r = withinRange v r' +-- > ==> simplifyVersionRange r = simplifyVersionRange r' +-- > || isNoVersion r +-- > || isNoVersion r' +-- +simplifyVersionRange :: VersionRange -> VersionRange +simplifyVersionRange vr + -- If the version range is inconsistent then we just return the + -- original since that has more information than ">1 && < 1", which + -- is the canonical inconsistent version range. + | null (unVersionIntervals vi) = vr + | otherwise = fromVersionIntervals vi + where + vi = toVersionIntervals vr + +-- | Given a version range, remove the highest upper bound. Example: @(>= 1 && < +-- 3) || (>= 4 && < 5)@ is converted to @(>= 1 && < 3) || (>= 4)@. +removeUpperBound :: VersionRange -> VersionRange +removeUpperBound = fromVersionIntervals . relaxLastInterval . toVersionIntervals + +-- | Given a version range, remove the lowest lower bound. +-- Example: @(>= 1 && < 3) || (>= 4 && < 5)@ is converted to +-- @(>= 0 && < 3) || (>= 4 && < 5)@. +removeLowerBound :: VersionRange -> VersionRange +removeLowerBound = fromVersionIntervals . relaxHeadInterval . toVersionIntervals + +-- | Rewrite @^>= x.y.z@ into @>= x.y.z && < x.(y+1)@ +-- +-- @since 3.6.0.0 +-- +transformCaret :: VersionRange -> VersionRange +transformCaret = hyloVersionRange embed projectVersionRange where + embed (MajorBoundVersionF v) = orLaterVersion v `intersectVersionRanges` earlierVersion (majorUpperBound v) + embed vr = embedVersionRange vr + +-- | Rewrite @^>= x.y.z@ into @>= x.y.z@ +-- +-- @since 3.6.0.0 +-- +transformCaretUpper :: VersionRange -> VersionRange +transformCaretUpper = hyloVersionRange embed projectVersionRange where + embed (MajorBoundVersionF v) = orLaterVersion v + embed vr = embedVersionRange vr + +-- | Rewrite @^>= x.y.z@ into @ VersionRange +transformCaretLower = hyloVersionRange embed projectVersionRange where + embed (MajorBoundVersionF v) = earlierVersion (majorUpperBound v) + embed vr = embedVersionRange vr diff --git a/cabal/Cabal-syntax/src/Language/Haskell/Extension.hs b/cabal/Cabal-syntax/src/Language/Haskell/Extension.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-syntax/src/Language/Haskell/Extension.hs @@ -0,0 +1,951 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Language.Haskell.Extension +-- Copyright : Isaac Jones 2003-2004 +-- License : BSD3 +-- +-- Maintainer : libraries@haskell.org +-- Portability : portable +-- +-- Haskell language dialects and extensions + +module Language.Haskell.Extension ( + Language(..), + knownLanguages, + classifyLanguage, + + Extension(..), + KnownExtension(..), + deprecatedExtensions, + classifyExtension, + knownExtensions + ) where + +import qualified Prelude (head) +import Distribution.Compat.Prelude + +import Data.Array (Array, accumArray, bounds, Ix(inRange), (!)) + +import Distribution.Parsec +import Distribution.Pretty + +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as Disp + +-- ------------------------------------------------------------ +-- * Language +-- ------------------------------------------------------------ + +-- | This represents a Haskell language dialect. +-- +-- Language 'Extension's are interpreted relative to one of these base +-- languages. +-- +data Language = + + -- | The Haskell 98 language as defined by the Haskell 98 report. + -- + Haskell98 + + -- | The Haskell 2010 language as defined by the Haskell 2010 report. + -- + | Haskell2010 + + -- | The GHC2021 collection of language extensions. + -- + | GHC2021 + + -- | An unknown language, identified by its name. + | UnknownLanguage String + deriving (Generic, Show, Read, Eq, Typeable, Data) + +instance Binary Language +instance Structured Language + +instance NFData Language where rnf = genericRnf + +-- | List of known (supported) languages for GHC +knownLanguages :: [Language] +knownLanguages = [Haskell98, Haskell2010, GHC2021] + +instance Pretty Language where + pretty (UnknownLanguage other) = Disp.text other + pretty other = Disp.text (show other) + +instance Parsec Language where + parsec = classifyLanguage <$> P.munch1 isAlphaNum + +classifyLanguage :: String -> Language +classifyLanguage = \str -> case lookup str langTable of + Just lang -> lang + Nothing -> UnknownLanguage str + where + langTable = [ (show lang, lang) + | lang <- knownLanguages ] + +-- ------------------------------------------------------------ +-- * Extension +-- ------------------------------------------------------------ + +-- Note: if you add a new 'KnownExtension': +-- +-- * also add it to the Distribution.Simple.X.languageExtensions lists +-- (where X is each compiler: GHC, UHC, HaskellSuite) +-- +-- | This represents language extensions beyond a base 'Language' definition +-- (such as 'Haskell98') that are supported by some implementations, usually +-- in some special mode. +-- +-- Where applicable, references are given to an implementation's +-- official documentation. + +data Extension = + -- | Enable a known extension + EnableExtension KnownExtension + + -- | Disable a known extension + | DisableExtension KnownExtension + + -- | An unknown extension, identified by the name of its @LANGUAGE@ + -- pragma. + | UnknownExtension String + + deriving (Generic, Show, Read, Eq, Ord, Typeable, Data) + +instance Binary Extension +instance Structured Extension + +instance NFData Extension where rnf = genericRnf + +data KnownExtension = + + -- | Allow overlapping class instances, provided there is a unique + -- most specific instance for each use. + -- + -- * + OverlappingInstances + + -- | Ignore structural rules guaranteeing the termination of class + -- instance resolution. Termination is guaranteed by a fixed-depth + -- recursion stack, and compilation may fail if this depth is + -- exceeded. + -- + -- * + | UndecidableInstances + + -- | Implies 'OverlappingInstances'. Allow the implementation to + -- choose an instance even when it is possible that further + -- instantiation of types will lead to a more specific instance + -- being applicable. + -- + -- * + | IncoherentInstances + + -- | /(deprecated)/ Deprecated in favour of 'RecursiveDo'. + -- + -- Old description: Allow recursive bindings in @do@ blocks, using + -- the @rec@ keyword. See also 'RecursiveDo'. + | DoRec + + -- | Allow recursive bindings in @do@ blocks, using the @rec@ + -- keyword, or @mdo@, a variant of @do@. + -- + -- * + | RecursiveDo + + -- | Provide syntax for writing list comprehensions which iterate + -- over several lists together, like the 'zipWith' family of + -- functions. + -- + -- * + | ParallelListComp + + -- | Allow multiple parameters in a type class. + -- + -- * + | MultiParamTypeClasses + + -- | Enable the dreaded monomorphism restriction. + -- + -- * + | MonomorphismRestriction + + -- | Allow a specification attached to a multi-parameter type class + -- which indicates that some parameters are entirely determined by + -- others. The implementation will check that this property holds + -- for the declared instances, and will use this property to reduce + -- ambiguity in instance resolution. + -- + -- * + | FunctionalDependencies + + -- | /(deprecated)/ A synonym for 'RankNTypes'. + -- + -- Old description: Like 'RankNTypes' but does not allow a + -- higher-rank type to itself appear on the left of a function + -- arrow. + -- + -- * + | Rank2Types + + -- | Allow a universally-quantified type to occur on the left of a + -- function arrow. + -- + -- * + | RankNTypes + + -- | /(deprecated)/ A synonym for 'RankNTypes'. + -- + -- Old description: Allow data constructors to have polymorphic + -- arguments. Unlike 'RankNTypes', does not allow this for ordinary + -- functions. + -- + -- * + | PolymorphicComponents + + -- | Allow existentially-quantified data constructors. + -- + -- * + | ExistentialQuantification + + -- | Cause a type variable in a signature, which has an explicit + -- @forall@ quantifier, to scope over the definition of the + -- accompanying value declaration. + -- + -- * + | ScopedTypeVariables + + -- | Deprecated, use 'ScopedTypeVariables' instead. + | PatternSignatures + + -- | Enable implicit function parameters with dynamic scope. + -- + -- * + | ImplicitParams + + -- | Relax some restrictions on the form of the context of a type + -- signature. + -- + -- * + | FlexibleContexts + + -- | Relax some restrictions on the form of the context of an + -- instance declaration. + -- + -- * + | FlexibleInstances + + -- | Allow data type declarations with no constructors. + -- + -- * + | EmptyDataDecls + + -- | Run the C preprocessor on Haskell source code. + -- + -- * + | CPP + + -- | Allow an explicit kind signature giving the kind of types over + -- which a type variable ranges. + -- + -- * + | KindSignatures + + -- | Enable a form of pattern which forces evaluation before an + -- attempted match, and a form of strict @let@/@where@ binding. + -- + -- * + | BangPatterns + + -- | Allow type synonyms in instance heads. + -- + -- * + | TypeSynonymInstances + + -- | Enable Template Haskell, a system for compile-time + -- metaprogramming. + -- + -- * + | TemplateHaskell + + -- | Enable the Foreign Function Interface. In GHC, implements the + -- standard Haskell 98 Foreign Function Interface Addendum, plus + -- some GHC-specific extensions. + -- + -- * + | ForeignFunctionInterface + + -- | Enable arrow notation. + -- + -- * + | Arrows + + -- | /(deprecated)/ Enable generic type classes, with default instances defined in + -- terms of the algebraic structure of a type. + -- + -- * + | Generics + + -- | Enable the implicit importing of the module "Prelude". When + -- disabled, when desugaring certain built-in syntax into ordinary + -- identifiers, use whatever is in scope rather than the "Prelude" + -- -- version. + -- + -- * + | ImplicitPrelude + + -- | Enable syntax for implicitly binding local names corresponding + -- to the field names of a record. Puns bind specific names, unlike + -- 'RecordWildCards'. + -- + -- * + | NamedFieldPuns + + -- | Enable a form of guard which matches a pattern and binds + -- variables. + -- + -- * + | PatternGuards + + -- | Allow a type declared with @newtype@ to use @deriving@ for any + -- class with an instance for the underlying type. + -- + -- * + | GeneralizedNewtypeDeriving + + -- Synonym for GeneralizedNewtypeDeriving added in GHC 8.6.1. + | GeneralisedNewtypeDeriving + + -- | Enable the \"Trex\" extensible records system. + -- + -- * + | ExtensibleRecords + + -- | Enable type synonyms which are transparent in some definitions + -- and opaque elsewhere, as a way of implementing abstract + -- datatypes. + -- + -- * + | RestrictedTypeSynonyms + + -- | Enable an alternate syntax for string literals, + -- with string templating. + -- + -- * + | HereDocuments + + -- | Allow the character @#@ as a postfix modifier on identifiers. + -- Also enables literal syntax for unboxed values. + -- + -- * + | MagicHash + + -- | Allow data types and type synonyms which are indexed by types, + -- i.e. ad-hoc polymorphism for types. + -- + -- * + | TypeFamilies + + -- | Allow a standalone declaration which invokes the type class + -- @deriving@ mechanism. + -- + -- * + | StandaloneDeriving + + -- | Allow certain Unicode characters to stand for certain ASCII + -- character sequences, e.g. keywords and punctuation. + -- + -- * + | UnicodeSyntax + + -- | Allow the use of unboxed types as foreign types, e.g. in + -- @foreign import@ and @foreign export@. + -- + -- * + | UnliftedFFITypes + + -- | Enable interruptible FFI. + -- + -- * + | InterruptibleFFI + + -- | Allow use of CAPI FFI calling convention (@foreign import capi@). + -- + -- * + | CApiFFI + + -- | Defer validity checking of types until after expanding type + -- synonyms, relaxing the constraints on how synonyms may be used. + -- + -- * + | LiberalTypeSynonyms + + -- | Allow the name of a type constructor, type class, or type + -- variable to be an infix operator. + -- * + | TypeOperators + + -- | Enable syntax for implicitly binding local names corresponding + -- to the field names of a record. A wildcard binds all unmentioned + -- names, unlike 'NamedFieldPuns'. + -- + -- * + | RecordWildCards + + -- | Deprecated, use 'NamedFieldPuns' instead. + | RecordPuns + + -- | Allow a record field name to be disambiguated by the type of + -- the record it's in. + -- + -- * + | DisambiguateRecordFields + + -- | Enable traditional record syntax (as supported by Haskell 98) + -- + -- * + | TraditionalRecordSyntax + + -- | Enable overloading of string literals using a type class, much + -- like integer literals. + -- + -- * + | OverloadedStrings + + -- | Enable generalized algebraic data types, in which type + -- variables may be instantiated on a per-constructor basis. Implies + -- 'GADTSyntax'. + -- + -- * + | GADTs + + -- | Enable GADT syntax for declaring ordinary algebraic datatypes. + -- + -- * + | GADTSyntax + + -- | /(deprecated)/ Has no effect. + -- + -- Old description: Make pattern bindings monomorphic. + -- + -- * + | MonoPatBinds + + -- | Relax the requirements on mutually-recursive polymorphic + -- functions. + -- + -- * + | RelaxedPolyRec + + -- | Allow default instantiation of polymorphic types in more + -- situations. + -- + -- * + | ExtendedDefaultRules + + -- | Enable unboxed tuples. + -- + -- * + | UnboxedTuples + + -- | Enable @deriving@ for classes 'Data.Typeable.Typeable' and + -- 'Data.Generics.Data'. + -- + -- * + | DeriveDataTypeable + + -- | Enable @deriving@ for 'GHC.Generics.Generic' and 'GHC.Generics.Generic1'. + -- + -- * + | DeriveGeneric + + -- | Enable support for default signatures. + -- + -- * + | DefaultSignatures + + -- | Allow type signatures to be specified in instance declarations. + -- + -- * + | InstanceSigs + + -- | Allow a class method's type to place additional constraints on + -- a class type variable. + -- + -- * + | ConstrainedClassMethods + + -- | Allow imports to be qualified by the package name the module is + -- intended to be imported from, e.g. + -- + -- > import "network" Network.Socket + -- + -- * + | PackageImports + + -- | /(deprecated)/ Allow a type variable to be instantiated at a + -- polymorphic type. + -- + -- * + | ImpredicativeTypes + + -- | /(deprecated)/ Change the syntax for qualified infix operators. + -- + -- * + | NewQualifiedOperators + + -- | Relax the interpretation of left operator sections to allow + -- unary postfix operators. + -- + -- * + | PostfixOperators + + -- | Enable quasi-quotation, a mechanism for defining new concrete + -- syntax for expressions and patterns. + -- + -- * + | QuasiQuotes + + -- | Enable generalized list comprehensions, supporting operations + -- such as sorting and grouping. + -- + -- * + | TransformListComp + + -- | Enable monad comprehensions, which generalise the list + -- comprehension syntax to work for any monad. + -- + -- * + | MonadComprehensions + + -- | Enable view patterns, which match a value by applying a + -- function and matching on the result. + -- + -- * + | ViewPatterns + + -- | Allow concrete XML syntax to be used in expressions and patterns, + -- as per the Haskell Server Pages extension language: + -- . The ideas behind it are + -- discussed in the paper \"Haskell Server Pages through Dynamic Loading\" + -- by Niklas Broberg, from Haskell Workshop '05. + | XmlSyntax + + -- | Allow regular pattern matching over lists, as discussed in the + -- paper \"Regular Expression Patterns\" by Niklas Broberg, Andreas Farre + -- and Josef Svenningsson, from ICFP '04. + | RegularPatterns + + -- | Enable the use of tuple sections, e.g. @(, True)@ desugars into + -- @\x -> (x, True)@. + -- + -- * + | TupleSections + + -- | Allow GHC primops, written in C--, to be imported into a Haskell + -- file. + | GHCForeignImportPrim + + -- | Support for patterns of the form @n + k@, where @k@ is an + -- integer literal. + -- + -- * + | NPlusKPatterns + + -- | Improve the layout rule when @if@ expressions are used in a @do@ + -- block. + | DoAndIfThenElse + + -- | Enable support for multi-way @if@-expressions. + -- + -- * + | MultiWayIf + + -- | Enable support lambda-@case@ expressions. + -- + -- * + | LambdaCase + + -- | Makes much of the Haskell sugar be desugared into calls to the + -- function with a particular name that is in scope. + -- + -- * + | RebindableSyntax + + -- | Make @forall@ a keyword in types, which can be used to give the + -- generalisation explicitly. + -- + -- * + | ExplicitForAll + + -- | Allow contexts to be put on datatypes, e.g. the @Eq a@ in + -- @data Eq a => Set a = NilSet | ConsSet a (Set a)@. + -- + -- * + | DatatypeContexts + + -- | Local (@let@ and @where@) bindings are monomorphic. + -- + -- * + | MonoLocalBinds + + -- | Enable @deriving@ for the 'Data.Functor.Functor' class. + -- + -- * + | DeriveFunctor + + -- | Enable @deriving@ for the 'Data.Traversable.Traversable' class. + -- + -- * + | DeriveTraversable + + -- | Enable @deriving@ for the 'Data.Foldable.Foldable' class. + -- + -- * + | DeriveFoldable + + -- | Enable non-decreasing indentation for @do@ blocks. + -- + -- * + | NondecreasingIndentation + + -- | Allow imports to be qualified with a safe keyword that requires + -- the imported module be trusted as according to the Safe Haskell + -- definition of trust. + -- + -- > import safe Network.Socket + -- + -- * + | SafeImports + + -- | Compile a module in the Safe, Safe Haskell mode -- a restricted + -- form of the Haskell language to ensure type safety. + -- + -- * + | Safe + + -- | Compile a module in the Trustworthy, Safe Haskell mode -- no + -- restrictions apply but the module is marked as trusted as long as + -- the package the module resides in is trusted. + -- + -- * + | Trustworthy + + -- | Compile a module in the Unsafe, Safe Haskell mode so that + -- modules compiled using Safe, Safe Haskell mode can't import it. + -- + -- * + | Unsafe + + -- | Allow type class/implicit parameter/equality constraints to be + -- used as types with the special kind constraint. Also generalise + -- the @(ctxt => ty)@ syntax so that any type of kind constraint can + -- occur before the arrow. + -- + -- * + | ConstraintKinds + + -- | Enable kind polymorphism. + -- + -- * + | PolyKinds + + -- | Enable datatype promotion. + -- + -- * + | DataKinds + + -- | Enable parallel arrays syntax (@[:@, @:]@) for /Data Parallel Haskell/. + -- + -- * + | ParallelArrays + + -- | Enable explicit role annotations, like in (@type role Foo representational representational@). + -- + -- * + | RoleAnnotations + + -- | Enable overloading of list literals, arithmetic sequences and + -- list patterns using the 'IsList' type class. + -- + -- * + | OverloadedLists + + -- | Enable case expressions that have no alternatives. Also applies to lambda-case expressions if they are enabled. + -- + -- * + | EmptyCase + + -- | /(deprecated)/ Deprecated in favour of 'DeriveDataTypeable'. + -- + -- Old description: Triggers the generation of derived 'Typeable' + -- instances for every datatype and type class declaration. + -- + -- * + | AutoDeriveTypeable + + -- | Desugars negative literals directly (without using negate). + -- + -- * + | NegativeLiterals + + -- | Allow the use of binary integer literal syntax (e.g. @0b11001001@ to denote @201@). + -- + -- * + | BinaryLiterals + + -- | Allow the use of floating literal syntax for all instances of 'Num', including 'Int' and 'Integer'. + -- + -- * + | NumDecimals + + -- | Enable support for type classes with no type parameter. + -- + -- * + | NullaryTypeClasses + + -- | Enable explicit namespaces in module import/export lists. + -- + -- * + | ExplicitNamespaces + + -- | Allow the user to write ambiguous types, and the type inference engine to infer them. + -- + -- * + | AllowAmbiguousTypes + + -- | Enable @foreign import javascript@. + | JavaScriptFFI + + -- | Allow giving names to and abstracting over patterns. + -- + -- * + | PatternSynonyms + + -- | Allow anonymous placeholders (underscore) inside type signatures. The + -- type inference engine will generate a message describing the type inferred + -- at the hole's location. + -- + -- * + | PartialTypeSignatures + + -- | Allow named placeholders written with a leading underscore inside type + -- signatures. Wildcards with the same name unify to the same type. + -- + -- * + | NamedWildCards + + -- | Enable @deriving@ for any class. + -- + -- * + | DeriveAnyClass + + -- | Enable @deriving@ for the 'Language.Haskell.TH.Syntax.Lift' class. + -- + -- * + | DeriveLift + + -- | Enable support for 'static pointers' (and the @static@ + -- keyword) to refer to globally stable names, even across + -- different programs. + -- + -- * + | StaticPointers + + -- | Switches data type declarations to be strict by default (as if + -- they had a bang using @BangPatterns@), and allow opt-in field + -- laziness using @~@. + -- + -- * + | StrictData + + -- | Switches all pattern bindings to be strict by default (as if + -- they had a bang using @BangPatterns@), ordinary patterns are + -- recovered using @~@. Implies @StrictData@. + -- + -- * + | Strict + + -- | Allows @do@-notation for types that are @'Applicative'@ as well + -- as @'Monad'@. When enabled, desugaring @do@ notation tries to use + -- @(<*>)@ and @'fmap'@ and @'join'@ as far as possible. + | ApplicativeDo + + -- | Allow records to use duplicated field labels for accessors. + | DuplicateRecordFields + + -- | Enable explicit type applications with the syntax @id \@Int@. + | TypeApplications + + -- | Dissolve the distinction between types and kinds, allowing the compiler + -- to reason about kind equality and therefore enabling GADTs to be promoted + -- to the type-level. + | TypeInType + + -- | Allow recursive (and therefore undecidable) super-class relationships. + | UndecidableSuperClasses + + -- | A temporary extension to help library authors check if their + -- code will compile with the new planned desugaring of fail. + | MonadFailDesugaring + + -- | A subset of @TemplateHaskell@ including only quoting. + | TemplateHaskellQuotes + + -- | Allows use of the @#label@ syntax. + | OverloadedLabels + + -- | Allow functional dependency annotations on type families to declare them + -- as injective. + | TypeFamilyDependencies + + -- | Allow multiple @deriving@ clauses, each optionally qualified with a + -- /strategy/. + | DerivingStrategies + + -- | Enable deriving instances via types of the same runtime representation. + -- Implies 'DerivingStrategies'. + | DerivingVia + + -- | Enable the use of unboxed sum syntax. + | UnboxedSums + + -- | Allow use of hexadecimal literal notation for floating-point values. + | HexFloatLiterals + + -- | Allow @do@ blocks etc. in argument position. + | BlockArguments + + -- | Allow use of underscores in numeric literals. + | NumericUnderscores + + -- | Allow @forall@ in constraints. + | QuantifiedConstraints + + -- | Have @*@ refer to @Type@. + | StarIsType + + -- | Liberalises deriving to provide instances for empty data types. + -- + -- * + | EmptyDataDeriving + + -- | Enable detection of complete user-supplied kind signatures. + | CUSKs + + -- | Allows the syntax @import M qualified@. + | ImportQualifiedPost + + -- | Allow the use of standalone kind signatures. + | StandaloneKindSignatures + + -- | Enable unlifted newtypes. + | UnliftedNewtypes + + -- | Use whitespace to determine whether the minus sign stands for negation or subtraction. + | LexicalNegation + + -- | Enable qualified do-notation desugaring. + | QualifiedDo + + -- | Enable linear types. + | LinearTypes + + -- | Enable the generation of selector functions corresponding to record fields. + | FieldSelectors + + -- | Enable the use of record dot-accessor and updater syntax + | OverloadedRecordDot + + -- | Provides record @.@ syntax in record updates, e.g. @x {foo.bar = 1}@. + -- + -- * + | OverloadedRecordUpdate + + -- | Enable data types for which an unlifted or levity-polymorphic result kind is inferred. + | UnliftedDatatypes + + -- | Undocumented parsing-related extensions introduced in GHC 7.0. + | AlternativeLayoutRule + + -- | Undocumented parsing-related extensions introduced in GHC 7.0. + | AlternativeLayoutRuleTransitional + + -- | Undocumented parsing-related extensions introduced in GHC 7.2. + | RelaxedLayout + + deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded, Typeable, Data) + +instance Binary KnownExtension +instance Structured KnownExtension + +instance NFData KnownExtension where rnf = genericRnf + +-- | Extensions that have been deprecated, possibly paired with another +-- extension that replaces it. +-- +deprecatedExtensions :: [(Extension, Maybe Extension)] +deprecatedExtensions = + [ (EnableExtension RecordPuns, Just (EnableExtension NamedFieldPuns)) + , (EnableExtension PatternSignatures, Just (EnableExtension ScopedTypeVariables)) + ] +-- NOTE: when adding deprecated extensions that have new alternatives +-- we must be careful to make sure that the deprecation messages are +-- valid. We must not recommend aliases that cannot be used with older +-- compilers, perhaps by adding support in Cabal to translate the new +-- name to the old one for older compilers. Otherwise we are in danger +-- of the scenario in ticket #689. + +instance Pretty Extension where + pretty (UnknownExtension other) = Disp.text other + pretty (EnableExtension ke) = Disp.text (show ke) + pretty (DisableExtension ke) = Disp.text ("No" ++ show ke) + +instance Parsec Extension where + parsec = classifyExtension <$> P.munch1 isAlphaNum + +instance Pretty KnownExtension where + pretty ke = Disp.text (show ke) + +classifyExtension :: String -> Extension +classifyExtension string + = case classifyKnownExtension string of + Just ext -> EnableExtension ext + Nothing -> + case string of + 'N':'o':string' -> + case classifyKnownExtension string' of + Just ext -> DisableExtension ext + Nothing -> UnknownExtension string + _ -> UnknownExtension string + +-- | 'read' for 'KnownExtension's is really really slow so for the Text +-- instance +-- what we do is make a simple table indexed off the first letter in the +-- extension name. The extension names actually cover the range @'A'-'Z'@ +-- pretty densely and the biggest bucket is 7 so it's not too bad. We just do +-- a linear search within each bucket. +-- +-- This gives an order of magnitude improvement in parsing speed, and it'll +-- also allow us to do case insensitive matches in future if we prefer. +-- +classifyKnownExtension :: String -> Maybe KnownExtension +classifyKnownExtension "" = Nothing +classifyKnownExtension string@(c : _) + | inRange (bounds knownExtensionTable) c + = lookup string (knownExtensionTable ! c) + | otherwise = Nothing + +knownExtensionTable :: Array Char [(String, KnownExtension)] +knownExtensionTable = + accumArray (flip (:)) [] ('A', 'Z') + [ (Prelude.head str, (str, extension)) -- assume KnownExtension's Show returns a non-empty string + | extension <- [toEnum 0 ..] + , let str = show extension ] + +knownExtensions :: [KnownExtension] +knownExtensions = [minBound .. maxBound] diff --git a/cabal/Cabal-tests/Cabal-tests.cabal b/cabal/Cabal-tests/Cabal-tests.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/Cabal-tests.cabal @@ -0,0 +1,206 @@ +cabal-version: 2.2 +name: Cabal-tests +version: 3 +copyright: 2003-2022, Cabal Development Team (see AUTHORS file) +license: BSD-3-Clause +license-file: LICENSE +author: Cabal Development Team +maintainer: cabal-devel@haskell.org +homepage: http://www.haskell.org/cabal/ +bug-reports: https://github.com/haskell/cabal/issues +synopsis: Tests for Cabal library +description: The tests are external for development flows convenience. +category: Distribution +build-type: Simple + +source-repository head + type: git + location: https://github.com/haskell/cabal/ + subdir: Cabal-tests + +-- Small, fast running tests. +test-suite unit-tests + type: exitcode-stdio-1.0 + hs-source-dirs: tests + other-modules: + Test.Laws + Test.QuickCheck.Utils + UnitTests.Distribution.CabalSpecVersion + UnitTests.Distribution.Compat.Graph + UnitTests.Distribution.Compat.Time + UnitTests.Distribution.Described + UnitTests.Distribution.PkgconfigVersion + UnitTests.Distribution.Simple.Command + UnitTests.Distribution.Simple.Glob + UnitTests.Distribution.Simple.Program.GHC + UnitTests.Distribution.Simple.Program.Internal + UnitTests.Distribution.Simple.Utils + UnitTests.Distribution.SPDX + UnitTests.Distribution.System + UnitTests.Distribution.Types.GenericPackageDescription + UnitTests.Distribution.Utils.CharSet + UnitTests.Distribution.Utils.Generic + UnitTests.Distribution.Utils.Json + UnitTests.Distribution.Utils.NubList + UnitTests.Distribution.Utils.ShortText + UnitTests.Distribution.Utils.Structured + UnitTests.Distribution.Version + UnitTests.Orphans + + main-is: UnitTests.hs + build-depends: + array + , async >=2.2.2 && <2.3 + , base >=0 && <5 + , binary + , bytestring + , Cabal + , Cabal-described + , Cabal-syntax + , Cabal-QuickCheck + , containers + , deepseq + , Diff >=0.4 && <0.5 + , directory + , filepath + , integer-logarithms >=1.0.2 && <1.1 + , pretty + , QuickCheck >=2.14 && <2.15 + , rere >=0.1 && <0.3 + , tagged + , tasty >=1.2.3 && <1.5 + , tasty-hunit + , tasty-quickcheck + , temporary + , text + , transformers + + ghc-options: -Wall + default-language: Haskell2010 + +test-suite parser-tests + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: ParserTests.hs + build-depends: + base + , base-compat >=0.11.0 && <0.13 + , bytestring + , Cabal-syntax + , Cabal-tree-diff + , Diff >=0.4 && <0.5 + , directory + , filepath + , tasty >=1.2.3 && <1.5 + , tasty-golden >=2.3.1.1 && <2.4 + , tasty-hunit + , tasty-quickcheck + , tree-diff >=0.1 && <0.3 + + ghc-options: -Wall + default-language: Haskell2010 + +test-suite check-tests + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: CheckTests.hs + build-depends: + base + , bytestring + , Cabal + , Cabal-syntax + , Diff >=0.4 && <0.5 + , directory + , filepath + , tasty >=1.2.3 && <1.5 + , tasty-expected-failure + , tasty-golden >=2.3.1.1 && <2.4 + + ghc-options: -Wall + default-language: Haskell2010 + +test-suite custom-setup-tests + type: exitcode-stdio-1.0 + hs-source-dirs: tests/custom-setup + main-is: CustomSetupTests.hs + other-modules: + CabalDoctestSetup + IdrisSetup + + build-depends: + base + , Cabal + , Cabal-syntax + , directory + , filepath + , process + + default-language: Haskell2010 + +test-suite hackage-tests + type: exitcode-stdio-1.0 + main-is: HackageTests.hs + + + hs-source-dirs: tests + build-depends: + base + , bytestring + , Cabal + , Cabal-syntax + , Cabal-tree-diff + , containers + , deepseq + , directory + , filepath + + build-depends: + base-compat >=0.11.0 && <0.13 + , base-orphans >=0.6 && <0.9 + , clock >=0.8 && <0.9 + , optparse-applicative >=0.13.2.0 && <0.17 + , stm >=2.4.5.0 && <2.6 + , tar >=0.5.0.3 && <0.6 + , tree-diff >=0.1 && <0.3 + + ghc-options: -Wall -rtsopts -threaded + default-extensions: CPP + default-language: Haskell2010 + +test-suite rpmvercmp + type: exitcode-stdio-1.0 + main-is: RPMVerCmp.hs + hs-source-dirs: tests + build-depends: + base + , bytestring + , Cabal-syntax + + build-depends: + QuickCheck + , tasty >=1.2.3 && <1.5 + , tasty-hunit + , tasty-quickcheck + + c-sources: tests/cbits/rpmvercmp.c + cc-options: -Wall + ghc-options: -Wall + default-language: Haskell2010 + +test-suite no-thunks-test + default-language: Haskell2010 + ghc-options: -Wall + type: exitcode-stdio-1.0 + main-is: NoThunks.hs + hs-source-dirs: tests + build-depends: + base + , bytestring + , Cabal-syntax + , tasty >=1.2.3 && <1.5 + , tasty-hunit + + -- this is test is buildable on old GHCs + -- but it doesn't do anything. + if impl(ghc >=8.6) + build-depends: nothunks >=0.1.1.0 && <0.2 diff --git a/cabal/Cabal-tests/LICENSE b/cabal/Cabal-tests/LICENSE new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/LICENSE @@ -0,0 +1,34 @@ +Copyright (c) 2003-2022, Cabal Development Team. +See the AUTHORS file for the full list of copyright holders. + +See */LICENSE for the copyright holders of the subcomponents. + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/cabal/Cabal-tests/tests/CheckTests.hs b/cabal/Cabal-tests/tests/CheckTests.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/CheckTests.hs @@ -0,0 +1,104 @@ +module Main + ( main + ) where + +import Test.Tasty +import Test.Tasty.ExpectedFailure +import Test.Tasty.Golden.Advanced (goldenTest) + +import Data.Algorithm.Diff (PolyDiff (..), getGroupedDiff) +import Distribution.Fields (runParseResult) +import Distribution.PackageDescription.Check (checkPackage) +import Distribution.PackageDescription.Parsec (parseGenericPackageDescription) +import Distribution.Parsec +import Distribution.Utils.Generic (fromUTF8BS, toUTF8BS) +import System.Directory (setCurrentDirectory) +import System.Environment (getArgs, withArgs) +import System.FilePath (replaceExtension, ()) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.List.NonEmpty as NE + +tests :: TestTree +tests = checkTests + +------------------------------------------------------------------------------- +-- Regressions +------------------------------------------------------------------------------- + +checkTests :: TestTree +checkTests = testGroup "regressions" + [ checkTest "nothing-unicode.cabal" + , checkTest "haddock-api-2.18.1-check.cabal" + , checkTest "issue-774.cabal" + , checkTest "extensions-paths-5054.cabal" + , checkTest "pre-1.6-glob.cabal" + , checkTest "pre-2.4-globstar.cabal" + , checkTest "bad-glob-syntax.cabal" + , checkTest "globstar-literal.cabal" + , checkTest "pre-3.8-globstar-literal.cabal" + , checkTest "cc-options-with-optimization.cabal" + , checkTest "cxx-options-with-optimization.cabal" + , checkTest "ghc-option-j.cabal" + , checkTest "multiple-libs-2.cabal" + , checkTest "assoc-cpp-options.cabal" + , checkTest "public-multilib-1.cabal" + , checkTest "public-multilib-2.cabal" + , checkTest "issue-6288-a.cabal" + , checkTest "issue-6288-b.cabal" + , checkTest "issue-6288-c.cabal" + , checkTest "issue-6288-d.cabal" + , checkTest "issue-6288-e.cabal" + , checkTest "issue-6288-f.cabal" + , checkTest "denormalised-paths.cabal" + , checkTest "issue-7776-a.cabal" + , checkTest "issue-7776-b.cabal" + , checkTest "issue-7776-c.cabal" + ] + +checkTest :: FilePath -> TestTree +checkTest fp = cabalGoldenTest fp correct $ do + contents <- BS.readFile input + let res = parseGenericPackageDescription contents + let (ws, x) = runParseResult res + + return $ toUTF8BS $ case x of + Right gpd -> + -- Note: parser warnings are reported by `cabal check`, but not by + -- D.PD.Check functionality. + unlines (map (showPWarning fp) ws) ++ + unlines (map show (checkPackage gpd Nothing)) + Left (_, errs) -> unlines $ map (("ERROR: " ++) . showPError fp) $ NE.toList errs + where + input = "tests" "ParserTests" "regressions" fp + correct = replaceExtension input "check" + +------------------------------------------------------------------------------- +-- Main +------------------------------------------------------------------------------- + +main :: IO () +main = do + args <- getArgs + case args of + ("--cwd" : cwd : args') -> do + setCurrentDirectory cwd + withArgs args' $ defaultMain tests + _ -> defaultMain tests + +cabalGoldenTest :: TestName -> FilePath -> IO BS.ByteString -> TestTree +cabalGoldenTest name ref act = goldenTest name (BS.readFile ref) act cmp upd + where + upd = BS.writeFile ref + cmp x y | x == y = return Nothing + cmp x y = return $ Just $ unlines $ + concatMap f (getGroupedDiff (BS8.lines x) (BS8.lines y)) + where + f (First xs) = map (cons3 '-' . fromUTF8BS) xs + f (Second ys) = map (cons3 '+' . fromUTF8BS) ys + -- we print unchanged lines too. It shouldn't be a problem while we have + -- reasonably small examples + f (Both xs _) = map (cons3 ' ' . fromUTF8BS) xs + -- we add three characters, so the changed lines are easier to spot + cons3 c cs = c : c : c : ' ' : cs diff --git a/cabal/Cabal-tests/tests/HackageTests.hs b/cabal/Cabal-tests/tests/HackageTests.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/HackageTests.hs @@ -0,0 +1,430 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +#if !MIN_VERSION_deepseq(1,4,0) +{-# OPTIONS_GHC -fno-warn-orphans #-} +#endif + +module Main where + +import Distribution.Compat.Semigroup +import Prelude () +import Prelude.Compat + +import Control.Applicative (many, (<**>), (<|>)) +import Control.DeepSeq (NFData (..), force) +import Control.Exception (evaluate) +import Control.Monad (join, unless, when) +import Data.Foldable (traverse_) +import Data.List (isPrefixOf, isSuffixOf) +import Data.Maybe (mapMaybe) +import Data.Monoid (Sum (..)) +import Distribution.PackageDescription.Check (PackageCheck (..), checkPackage) +import Distribution.PackageDescription.PrettyPrint (showGenericPackageDescription) +import Distribution.PackageDescription.Quirks (patchQuirks) +import Distribution.Simple.Utils (fromUTF8BS, toUTF8BS) +import Numeric (showFFloat) +import System.Directory (getAppUserDataDirectory) +import System.Environment (lookupEnv) +import System.Exit (exitFailure) +import System.FilePath (()) + +import Data.Orphans () + +import qualified Codec.Archive.Tar as Tar +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Lazy as BSL +import qualified Distribution.Fields.Parser as Parsec +import qualified Distribution.Fields.Pretty as PP +import qualified Distribution.PackageDescription.Parsec as Parsec +import qualified Distribution.Parsec as Parsec +import qualified Options.Applicative as O +import qualified System.Clock as Clock + +import Distribution.Compat.Lens +import qualified Distribution.Types.GenericPackageDescription.Lens as L +import qualified Distribution.Types.PackageDescription.Lens as L + +-- import Distribution.Types.BuildInfo (BuildInfo (cppOptions)) +-- import qualified Distribution.Types.BuildInfo.Lens as L + +#ifdef MIN_VERSION_tree_diff +import Data.TreeDiff (ediff) +import Data.TreeDiff.Instances.Cabal () +import Data.TreeDiff.Pretty (ansiWlEditExprCompact) +#endif + +------------------------------------------------------------------------------- +-- parseIndex: Index traversal +------------------------------------------------------------------------------- + +parseIndex :: (Monoid a, NFData a) => (FilePath -> Bool) + -> (FilePath -> B.ByteString -> IO a) -> IO a +parseIndex predicate action = do + cabalDir <- getCabalDir + configPath <- getCabalConfigPath cabalDir + cfg <- B.readFile configPath + cfgFields <- either (fail . show) pure $ Parsec.readFields cfg + let repos = reposFromConfig cfgFields + repoCache = case lookupInConfig "remote-repo-cache" cfgFields of + [] -> cabalDir "packages" -- Default + (rrc : _) -> rrc -- User-specified + tarName repo = repoCache repo "01-index.tar" + mconcat <$> traverse (parseIndex' predicate action . tarName) repos + where + getCabalDir = do + mx <- lookupEnv "CABAL_DIR" + case mx of + Just x -> return x + Nothing -> getAppUserDataDirectory "cabal" + getCabalConfigPath cabalDir = do + mx <- lookupEnv "CABAL_CONFIG" + case mx of + Just x -> return x + Nothing -> return (cabalDir "config") + + +parseIndex' + :: (Monoid a, NFData a) + => (FilePath -> Bool) + -> (FilePath -> B.ByteString -> IO a) -> FilePath -> IO a +parseIndex' predicate action path = do + putStrLn $ "Reading index from: " ++ path + contents <- BSL.readFile path + let entries = Tar.read contents + entries' = Tar.foldEntries cons [] (error . show) entries + foldIO f entries' + + where + cons entry entries + | predicate (Tar.entryPath entry) = entry : entries + | otherwise = entries + + f entry = case Tar.entryContent entry of + Tar.NormalFile contents _ + | ".cabal" `isSuffixOf` fpath -> do + bs <- evaluate (BSL.toStrict contents) + res <- action fpath bs + evaluate (force res) + | otherwise -> + return mempty + Tar.Directory -> return mempty + _ -> putStrLn ("Unknown content in " ++ fpath) + >> return mempty + where + fpath = Tar.entryPath entry + +------------------------------------------------------------------------------- +-- readFields tests: very fast test for 'readFields' - first step of parser +------------------------------------------------------------------------------- + +readFieldTest :: FilePath -> B.ByteString -> IO () +readFieldTest fpath bs = case Parsec.readFields bs' of + Right _ -> return () + Left err -> do + putStrLn fpath + print err + exitFailure + where + (_, bs') = patchQuirks bs + +------------------------------------------------------------------------------- +-- Parsec test: whether we can parse everything +------------------------------------------------------------------------------- + +parseParsecTest :: Bool -> FilePath -> B.ByteString -> IO ParsecResult +parseParsecTest keepGoing fpath bs = do + let (warnings, result) = Parsec.runParseResult $ + Parsec.parseGenericPackageDescription bs + + let w | null warnings = 0 + | otherwise = 1 + + case result of + Right gpd -> do + forEachGPD fpath bs gpd + return (ParsecResult 1 w 0) + + Left (_, errors) | keepGoing -> do + traverse_ (putStrLn . Parsec.showPError fpath) errors + return (ParsecResult 1 w 1) + | otherwise -> do + traverse_ (putStrLn . Parsec.showPError fpath) errors + exitFailure + +-- | A hook to make queries on Hackage +forEachGPD :: FilePath -> B8.ByteString -> L.GenericPackageDescription -> IO () +forEachGPD _ _ _ = return () + +------------------------------------------------------------------------------- +-- ParsecResult +------------------------------------------------------------------------------- + +data ParsecResult = ParsecResult !Int !Int !Int + deriving (Eq, Show) + +instance Semigroup ParsecResult where + ParsecResult x y z <> ParsecResult u v w = ParsecResult (x + u) (y + v) (z + w) + +instance Monoid ParsecResult where + mempty = ParsecResult 0 0 0 + mappend = (<>) + +instance NFData ParsecResult where + rnf (ParsecResult _ _ _) = () + +------------------------------------------------------------------------------- +-- Check test +------------------------------------------------------------------------------- + +parseCheckTest :: FilePath -> B.ByteString -> IO CheckResult +parseCheckTest fpath bs = do + let (warnings, parsec) = Parsec.runParseResult $ + Parsec.parseGenericPackageDescription bs + case parsec of + Right gpd -> do + let checks = checkPackage gpd Nothing + let w [] = 0 + w _ = 1 + + -- Look into invalid cpp options + -- _ <- L.traverseBuildInfos checkCppFlags gpd + + -- one for file, many checks + return (CheckResult 1 (w warnings) 0 0 0 0 0 0 <> foldMap toCheckResult checks) + Left (_, errors) -> do + traverse_ (putStrLn . Parsec.showPError fpath) errors + exitFailure + +-- checkCppFlags :: BuildInfo -> IO BuildInfo +-- checkCppFlags bi = do +-- for_ (cppOptions bi) $ \opt -> +-- unless (any (`isPrefixOf` opt) ["-D", "-U", "-I"]) $ +-- putStrLn opt +-- +-- return bi + +data CheckResult = CheckResult !Int !Int !Int !Int !Int !Int !Int !Int + +instance NFData CheckResult where + rnf !_ = () + +instance Semigroup CheckResult where + CheckResult n w a b c d e f <> CheckResult n' w' a' b' c' d' e' f' = + CheckResult (n + n') (w + w') (a + a') (b + b') (c + c') (d + d') (e + e') (f + f') + +instance Monoid CheckResult where + mempty = CheckResult 0 0 0 0 0 0 0 0 + mappend = (<>) + +toCheckResult :: PackageCheck -> CheckResult +toCheckResult PackageBuildImpossible {} = CheckResult 0 0 1 1 0 0 0 0 +toCheckResult PackageBuildWarning {} = CheckResult 0 0 1 0 1 0 0 0 +toCheckResult PackageDistSuspicious {} = CheckResult 0 0 1 0 0 1 0 0 +toCheckResult PackageDistSuspiciousWarn {} = CheckResult 0 0 1 0 0 0 1 0 +toCheckResult PackageDistInexcusable {} = CheckResult 0 0 1 0 0 0 0 1 + +------------------------------------------------------------------------------- +-- Roundtrip test +------------------------------------------------------------------------------- + +roundtripTest :: Bool -> FilePath -> B.ByteString -> IO (Sum Int) +roundtripTest testFieldsTransform fpath bs = do + x0 <- parse "1st" bs + let bs' = showGenericPackageDescription x0 + y0 <- parse "2nd" (toUTF8BS bs') + + -- strip description, there are format variations + let y = y0 & L.packageDescription . L.description .~ mempty + let x = x0 & L.packageDescription . L.description .~ mempty + + assertEqual' bs' x y + + -- fromParsecField, "shallow" parser/pretty roundtrip + when testFieldsTransform $ + if checkUTF8 patchedBs + then do + parsecFields <- assertRight $ Parsec.readFields patchedBs + let prettyFields = PP.fromParsecFields parsecFields + let bs'' = PP.showFields (return PP.NoComment) prettyFields + z0 <- parse "3rd" (toUTF8BS bs'') + + -- note: we compare "raw" GPDs, on purpose; stricter equality + assertEqual' bs'' x0 z0 + else + putStrLn $ fpath ++ " : looks like invalid UTF8" + + return (Sum 1) + where + patchedBs = snd (patchQuirks bs) + + checkUTF8 bs' = replacementChar `notElem` fromUTF8BS bs' where + replacementChar = '\xfffd' + + + assertRight (Right x) = return x + assertRight (Left err) = do + putStrLn fpath + print err + exitFailure + + assertEqual' bs' x y = unless (x == y || fpath == "ixset/1.0.4/ixset.cabal") $ do + putStrLn fpath +#ifdef MIN_VERSION_tree_diff + putStrLn "====== tree-diff:" + print $ ansiWlEditExprCompact $ ediff x y +#else + putStrLn "<<<<<<" + print x + putStrLn "======" + print y + putStrLn ">>>>>>" +#endif + putStrLn "====== contents:" + putStrLn bs' + exitFailure + + parse phase c = do + let (_, x') = Parsec.runParseResult $ + Parsec.parseGenericPackageDescription c + case x' of + Right gpd -> pure gpd + Left (_, errs) -> do + putStrLn $ fpath ++ " " ++ phase + traverse_ print errs + B.putStr c + fail "parse error" + +------------------------------------------------------------------------------- +-- Main +------------------------------------------------------------------------------- + +main :: IO () +main = join (O.execParser opts) + where + opts = O.info (optsP <**> O.helper) $ mconcat + [ O.fullDesc + , O.progDesc "tests using Hackage's index" + ] + + optsP = subparser + [ command "read-fields" readFieldsP + "Parse outer format (to '[Field]', TODO: apply Quirks)" + , command "parsec" parsecP "Parse GPD with parsec" + , command "roundtrip" roundtripP "parse . pretty . parse = parse" + , command "check" checkP "Check GPD" + ] <|> pure defaultA + + defaultA = do + putStrLn "Default action: parsec k" + parsecA (mkPredicate ["k"]) False + + readFieldsP = readFieldsA <$> prefixP + readFieldsA pfx = parseIndex pfx readFieldTest + + parsecP = parsecA <$> prefixP <*> keepGoingP + keepGoingP = + O.flag' True (O.long "keep-going") <|> + O.flag' False (O.long "no-keep-going") <|> + pure False + + parsecA pfx keepGoing = do + begin <- Clock.getTime Clock.Monotonic + ParsecResult n w f <- parseIndex pfx (parseParsecTest keepGoing) + end <- Clock.getTime Clock.Monotonic + let diff = Clock.toNanoSecs $ Clock.diffTimeSpec end begin + + putStrLn $ show n ++ " files processed" + putStrLn $ show w ++ " files contained warnings" + putStrLn $ show f ++ " files failed to parse" + putStrLn $ showFFloat (Just 6) (fromInteger diff / 1e9 :: Double) " seconds elapsed" + putStrLn $ showFFloat (Just 6) (fromInteger diff / 1e6 / fromIntegral n :: Double) " milliseconds per file" + + roundtripP = roundtripA <$> prefixP <*> testFieldsP + roundtripA pfx testFieldsTransform = do + Sum n <- parseIndex pfx (roundtripTest testFieldsTransform) + putStrLn $ show n ++ " files processed" + + checkP = checkA <$> prefixP + checkA pfx = do + CheckResult n w x a b c d e <- parseIndex pfx parseCheckTest + putStrLn $ show n ++ " files processed" + putStrLn $ show w ++ " files have lexer/parser warnings" + putStrLn $ show x ++ " files have check warnings" + putStrLn $ show a ++ " build impossible" + putStrLn $ show b ++ " build warning" + putStrLn $ show c ++ " build dist suspicious" + putStrLn $ show d ++ " build dist suspicious warning" + putStrLn $ show e ++ " build dist inexcusable" + + prefixP = fmap mkPredicate $ many $ O.strArgument $ mconcat + [ O.metavar "PREFIX" + , O.help "Check only files starting with a prefix" + ] + + testFieldsP = O.switch $ mconcat + [ O.long "fields-transform" + , O.help "Test also 'showFields . fromParsecFields . readFields' transform" + ] + + mkPredicate [] = const True + mkPredicate pfxs = \n -> any (`isPrefixOf` n) pfxs + + command name p desc = O.command name + (O.info (p <**> O.helper) (O.progDesc desc)) + subparser = O.subparser . mconcat + +------------------------------------------------------------------------------- +-- Index shuffling +------------------------------------------------------------------------------- + +-- TODO: Use 'Cabal' for this? +reposFromConfig :: [Parsec.Field ann] -> [String] +reposFromConfig fields = takeWhile (/= ':') <$> mapMaybe f fields + where + f (Parsec.Field (Parsec.Name _ name) fieldLines) + | B8.unpack name == "remote-repo" = + Just $ fieldLinesToString fieldLines + f (Parsec.Section (Parsec.Name _ name) + [Parsec.SecArgName _ secName] _fieldLines) + | B8.unpack name == "repository" = + Just $ B8.unpack secName + f _ = Nothing + +-- | Looks up the given key in the cabal configuration file +lookupInConfig :: String -> [Parsec.Field ann] -> [String] +lookupInConfig key = mapMaybe f + where + f (Parsec.Field (Parsec.Name _ name) fieldLines) + | B8.unpack name == key = + Just $ fieldLinesToString fieldLines + f _ = Nothing + +fieldLinesToString :: [Parsec.FieldLine ann] -> String +fieldLinesToString fieldLines = + B8.unpack $ B.concat $ bsFromFieldLine <$> fieldLines + where + bsFromFieldLine (Parsec.FieldLine _ bs) = bs + +------------------------------------------------------------------------------- +-- Utilities +------------------------------------------------------------------------------- + +-- | We assume that monoid is commutative. +-- +-- First we chunk input (as single cabal file is little work) +foldIO :: forall a m. (Monoid m, NFData m) => (a -> IO m) -> [a] -> IO m +foldIO f = go mempty where + go !acc [] = acc + go !acc (x:xs) = go (mappend acc (f x)) xs + +------------------------------------------------------------------------------- +-- Orphans +------------------------------------------------------------------------------- + +#if !MIN_VERSION_deepseq(1,4,0) +instance NFData a => NFData (Sum a) where + rnf (Sum a) = rnf a +#endif diff --git a/cabal/Cabal-tests/tests/NoThunks.hs b/cabal/Cabal-tests/tests/NoThunks.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/NoThunks.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE CPP #-} +#if !(__GLASGOW_HASKELL__ >= 806 && defined(MIN_VERSION_nothunks)) +module Main (main) where +main :: IO () +main = putStrLn "Old GHC, no nothunks" +#else + +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -Wno-orphans #-} +module Main (main) where + +import Control.Applicative ((<|>)) +import Data.Foldable (toList) +import Data.Proxy (Proxy (..)) +import Data.Typeable (Typeable, typeRep) +import Distribution.CabalSpecVersion (CabalSpecVersion) +import Distribution.Compat.NonEmptySet (NonEmptySet) +import Distribution.Compiler (CompilerFlavor, PerCompilerFlavor) +import Distribution.Fields (runParseResult) +import Distribution.ModuleName (ModuleName) +import Distribution.PackageDescription.Parsec (parseGenericPackageDescription) +import Distribution.SPDX (License, LicenseExceptionId, LicenseExpression, LicenseId, LicenseRef, SimpleLicenseExpression) +import Distribution.System (Arch, OS) +import Distribution.Utils.Path (SymbolicPath) +import Distribution.Utils.ShortText (ShortText) +import Distribution.Version (Version, VersionRange) +import Language.Haskell.Extension (Extension, KnownExtension, Language) +import NoThunks.Class (NoThunks (..), OnlyCheckWhnf (..), noThunksInValues) +import Test.Tasty (defaultMain, testGroup) +import Test.Tasty.HUnit (assertFailure, testCase) + +import Distribution.PackageDescription + +import qualified Data.ByteString as BS +import qualified Distribution.License as License + +main :: IO () +main = defaultMain $ testGroup "nothunks" + [ testCase "parsing Cabal.cabal" noThunksParse + ] + +noThunksParse :: IO () +noThunksParse = do + bs <- BS.readFile "Cabal/Cabal.cabal" <|> BS.readFile "../Cabal/Cabal.cabal" + let res = parseGenericPackageDescription bs + gpd <- either (assertFailure . show) return $ snd $ + runParseResult res + + noThunks [] gpd >>= \case + -- ok + Nothing -> return () + + -- found thunk + Just info -> assertFailure $ "Thunk in " ++ show info + +------------------------------------------------------------------------------- +-- NoThunks instances +------------------------------------------------------------------------------- + +instance NoThunks Arch +instance NoThunks Benchmark +instance NoThunks BenchmarkInterface +instance NoThunks BenchmarkType +instance NoThunks BuildInfo +instance NoThunks BuildType +instance NoThunks CabalSpecVersion +instance NoThunks CompilerFlavor +instance NoThunks ConfVar +instance NoThunks Dependency +instance NoThunks Executable +instance NoThunks ExecutableScope +instance NoThunks FlagName +instance NoThunks ForeignLib +instance NoThunks ForeignLibOption +instance NoThunks ModuleReexport +instance NoThunks LibraryVisibility +instance NoThunks ForeignLibType +instance NoThunks GenericPackageDescription +instance NoThunks KnownRepoType +instance NoThunks Library +instance NoThunks LibraryName +instance NoThunks Mixin +instance NoThunks License +instance NoThunks License.License +instance NoThunks LicenseExpression +instance NoThunks LicenseRef +instance NoThunks ModuleName +instance NoThunks OS +instance NoThunks PackageDescription +instance NoThunks PackageFlag +instance NoThunks PackageIdentifier +instance NoThunks PackageName +instance NoThunks LegacyExeDependency +instance NoThunks ExeDependency +instance NoThunks PkgconfigName +instance NoThunks PkgconfigDependency +instance NoThunks PkgconfigVersion +instance NoThunks PkgconfigVersionRange +instance NoThunks LibVersionInfo +instance NoThunks RepoKind +instance NoThunks RepoType +instance NoThunks Extension +instance NoThunks Language +instance NoThunks SetupBuildInfo +instance NoThunks SimpleLicenseExpression +instance NoThunks KnownExtension +instance NoThunks SourceRepo +instance NoThunks IncludeRenaming +instance NoThunks ModuleRenaming +instance NoThunks TestSuite +instance NoThunks TestSuiteInterface +instance NoThunks TestType +instance NoThunks UnqualComponentName +instance NoThunks Version +instance NoThunks VersionRange + +instance NoThunks ShortText where + +instance NoThunks a => NoThunks (PerCompilerFlavor a) + +instance (Typeable a, Typeable b) => NoThunks (SymbolicPath a b) + +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 c) => NoThunks (Condition c) + +------------------------------------------------------------------------------- +-- NoThunks helpers +------------------------------------------------------------------------------- + +newtype CheckFoldableNamed f a = CheckFoldableNamed (f a) + +instance (NoThunks a, Foldable f, Typeable f) => NoThunks (CheckFoldableNamed f a) where + showTypeOf _ = show (typeRep (Proxy :: Proxy f)) + wNoThunks ctxt (CheckFoldableNamed xs) = noThunksInValues ctxt (toList xs) + +#endif diff --git a/cabal/Cabal-tests/tests/ParserTests.hs b/cabal/Cabal-tests/tests/ParserTests.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests.hs @@ -0,0 +1,378 @@ +{-# LANGUAGE CPP #-} +module Main + ( main + ) where + +import Prelude () +import Prelude.Compat + +import Test.Tasty +import Test.Tasty.Golden.Advanced (goldenTest) +import Test.Tasty.HUnit + +import Control.Monad (unless, void) +import Data.Algorithm.Diff (PolyDiff (..), getGroupedDiff) +import Data.Maybe (isNothing) +import Distribution.Fields (runParseResult) +import Distribution.PackageDescription (GenericPackageDescription) +import Distribution.PackageDescription.Parsec (parseGenericPackageDescription) +import Distribution.PackageDescription.PrettyPrint (showGenericPackageDescription) +import Distribution.Parsec (PWarnType (..), PWarning (..), showPError, showPWarning) +import Distribution.Pretty (prettyShow) +import Distribution.Utils.Generic (fromUTF8BS, toUTF8BS) +import System.Directory (setCurrentDirectory) +import System.Environment (getArgs, withArgs) +import System.FilePath (replaceExtension, ()) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.List.NonEmpty as NE + +import qualified Distribution.InstalledPackageInfo as IPI + +#ifdef MIN_VERSION_tree_diff +import Data.TreeDiff (ansiWlEditExpr, ediff, toExpr) +import Data.TreeDiff.Golden (ediffGolden) +import Data.TreeDiff.Instances.Cabal () +#endif + +tests :: TestTree +tests = testGroup "parsec tests" + [ regressionTests + , warningTests + , errorTests + , ipiTests + ] + +------------------------------------------------------------------------------- +-- Warnings +------------------------------------------------------------------------------- + +-- Verify that we trigger warnings +warningTests :: TestTree +warningTests = testGroup "warnings triggered" + [ warningTest PWTLexBOM "bom.cabal" + , warningTest PWTLexNBSP "nbsp.cabal" + , warningTest PWTLexTab "tab.cabal" + , warningTest PWTUTF "utf8.cabal" + , warningTest PWTBoolCase "bool.cabal" + , warningTest PWTVersionTag "versiontag.cabal" + , warningTest PWTNewSyntax "newsyntax.cabal" + , warningTest PWTOldSyntax "oldsyntax.cabal" + , warningTest PWTDeprecatedField "deprecatedfield.cabal" + , warningTest PWTInvalidSubsection "subsection.cabal" + , warningTest PWTUnknownField "unknownfield.cabal" + , warningTest PWTUnknownSection "unknownsection.cabal" + , warningTest PWTTrailingFields "trailingfield.cabal" + , warningTest PWTDoubleDash "doubledash.cabal" + , warningTest PWTMultipleSingularField "multiplesingular.cabal" + , warningTest PWTVersionWildcard "wildcard.cabal" + , warningTest PWTVersionOperator "operator.cabal" + , warningTest PWTSpecVersion "specversion-a.cabal" + , warningTest PWTSpecVersion "specversion-b.cabal" + , warningTest PWTSpecVersion "specversion-c.cabal" + -- TODO: not implemented yet + -- , warningTest PWTExtraTestModule "extratestmodule.cabal" + ] + +warningTest :: PWarnType -> FilePath -> TestTree +warningTest wt fp = testCase (show wt) $ do + contents <- BS.readFile $ "tests" "ParserTests" "warnings" fp + + let res = parseGenericPackageDescription contents + let (warns, x) = runParseResult res + + assertBool ("should parse successfully: " ++ show x) $ isRight x + + case warns of + [PWarning wt' _ _] -> assertEqual "warning type" wt wt' + [] -> assertFailure "got no warnings" + _ -> assertFailure $ "got multiple warnings: " ++ show warns + where + isRight (Right _) = True + isRight _ = False + +------------------------------------------------------------------------------- +-- Errors +------------------------------------------------------------------------------- + +errorTests :: TestTree +errorTests = testGroup "errors" + [ errorTest "common1.cabal" + , errorTest "common2.cabal" + , errorTest "common3.cabal" + , errorTest "leading-comma.cabal" + , errorTest "leading-comma-2.cabal" + , errorTest "leading-comma-2b.cabal" + , errorTest "leading-comma-2c.cabal" + , errorTest "range-ge-wild.cabal" + , errorTest "forward-compat.cabal" + , errorTest "forward-compat2.cabal" + , errorTest "forward-compat3.cabal" + , errorTest "issue-5055.cabal" + , errorTest "issue-5055-2.cabal" + , errorTest "noVersion.cabal" + , errorTest "noVersion2.cabal" + , errorTest "multiple-libs.cabal" + , errorTest "spdx-1.cabal" + , errorTest "spdx-2.cabal" + , errorTest "spdx-3.cabal" + , errorTest "removed-fields.cabal" + , errorTest "version-sets-1.cabal" + , errorTest "version-sets-2.cabal" + , errorTest "version-sets-3.cabal" + , errorTest "version-sets-4.cabal" + , errorTest "undefined-flag.cabal" + , errorTest "mixin-1.cabal" + , errorTest "mixin-2.cabal" + , errorTest "libpq1.cabal" + , errorTest "libpq2.cabal" + , errorTest "MiniAgda.cabal" + , errorTest "big-version.cabal" + , errorTest "anynone.cabal" + ] + +errorTest :: FilePath -> TestTree +errorTest fp = cabalGoldenTest fp correct $ do + contents <- BS.readFile input + let res = parseGenericPackageDescription contents + let (_, x) = runParseResult res + + return $ toUTF8BS $ case x of + Right gpd -> + "UNXPECTED SUCCESS\n" ++ + showGenericPackageDescription gpd + Left (v, errs) -> + unlines $ ("VERSION: " ++ show v) : map (showPError fp) (NE.toList errs) + where + input = "tests" "ParserTests" "errors" fp + correct = replaceExtension input "errors" + +------------------------------------------------------------------------------- +-- Regressions +------------------------------------------------------------------------------- + +regressionTests :: TestTree +regressionTests = testGroup "regressions" + [ regressionTest "encoding-0.8.cabal" + , regressionTest "Octree-0.5.cabal" + , regressionTest "nothing-unicode.cabal" + , regressionTest "multiple-libs-2.cabal" + , regressionTest "issue-774.cabal" + , regressionTest "generics-sop.cabal" + , regressionTest "elif.cabal" + , regressionTest "elif2.cabal" + , regressionTest "shake.cabal" + , regressionTest "common.cabal" + , regressionTest "common2.cabal" + , regressionTest "common3.cabal" + , regressionTest "common-conditional.cabal" + , regressionTest "leading-comma.cabal" + , regressionTest "leading-comma-2.cabal" + , regressionTest "wl-pprint-indef.cabal" + , regressionTest "th-lift-instances.cabal" + , regressionTest "issue-5055.cabal" + , regressionTest "issue-6083-pkg-pkg.cabal" + , regressionTest "issue-6083-a.cabal" + , regressionTest "issue-6083-b.cabal" + , regressionTest "issue-6083-c.cabal" + , regressionTest "noVersion.cabal" + , regressionTest "spdx-1.cabal" + , regressionTest "spdx-2.cabal" + , regressionTest "spdx-3.cabal" + , regressionTest "hidden-main-lib.cabal" + , regressionTest "jaeger-flamegraph.cabal" + , regressionTest "version-sets.cabal" + , regressionTest "mixin-1.cabal" + , regressionTest "mixin-2.cabal" + , regressionTest "mixin-3.cabal" + , regressionTest "libpq1.cabal" + , regressionTest "libpq2.cabal" + , regressionTest "issue-5846.cabal" + , regressionTest "indentation.cabal" + , regressionTest "indentation2.cabal" + , regressionTest "indentation3.cabal" + , regressionTest "big-version.cabal" + , regressionTest "anynone.cabal" + , regressionTest "monad-param.cabal" + , regressionTest "hasktorch.cabal" + ] + +regressionTest :: FilePath -> TestTree +regressionTest fp = testGroup fp + [ formatGoldenTest fp + , formatRoundTripTest fp +#ifdef MIN_VERSION_tree_diff + , treeDiffGoldenTest fp +#endif + ] + +formatGoldenTest :: FilePath -> TestTree +formatGoldenTest fp = cabalGoldenTest "format" correct $ do + contents <- BS.readFile input + let res = parseGenericPackageDescription contents + let (warns, x) = runParseResult res + + return $ toUTF8BS $ case x of + Right gpd -> + unlines (map (showPWarning fp) warns) + ++ showGenericPackageDescription gpd + Left (csv, errs) -> + unlines $ + "ERROR" : + maybe "unknown-version" prettyShow csv : + map (showPError fp) (NE.toList errs) + where + input = "tests" "ParserTests" "regressions" fp + correct = replaceExtension input "format" + +#ifdef MIN_VERSION_tree_diff +treeDiffGoldenTest :: FilePath -> TestTree +treeDiffGoldenTest fp = ediffGolden goldenTest "expr" exprFile $ do + contents <- BS.readFile input + let res = parseGenericPackageDescription contents + let (_, x) = runParseResult res + case x of + Right gpd -> pure (toExpr gpd) + Left (_, errs) -> fail $ unlines $ "ERROR" : map (showPError fp) (NE.toList errs) + where + input = "tests" "ParserTests" "regressions" fp + exprFile = replaceExtension input "expr" +#endif + +formatRoundTripTest :: FilePath -> TestTree +formatRoundTripTest fp = testCase "roundtrip" $ do + contents <- BS.readFile input + x <- parse contents + let contents' = showGenericPackageDescription x + y <- parse (toUTF8BS contents') + -- previously we mangled licenses a bit + let y' = y + unless (x == y') $ +#ifdef MIN_VERSION_tree_diff + assertFailure $ unlines + [ "re-parsed doesn't match" + , show $ ansiWlEditExpr $ ediff x y + ] +#else + assertFailure $ unlines + [ "re-parsed doesn't match" + , "expected" + , show x + , "actual" + , show y + ] +#endif + where + parse :: BS.ByteString -> IO GenericPackageDescription + parse c = do + let (_, x') = runParseResult $ parseGenericPackageDescription c + case x' of + Right gpd -> pure gpd + Left (_, errs) -> do + void $ assertFailure $ unlines (map (showPError fp) $ NE.toList errs) + fail "failure" + input = "tests" "ParserTests" "regressions" fp + +------------------------------------------------------------------------------- +-- InstalledPackageInfo regressions +------------------------------------------------------------------------------- + +ipiTests :: TestTree +ipiTests = testGroup "ipis" + [ ipiTest "transformers.cabal" + , ipiTest "Includes2.cabal" + , ipiTest "issue-2276-ghc-9885.cabal" + , ipiTest "internal-preprocessor-test.cabal" + ] + +ipiTest :: FilePath -> TestTree +ipiTest fp = testGroup fp $ +#ifdef MIN_VERSION_tree_diff + [ ipiTreeDiffGoldenTest fp ] ++ +#endif + [ ipiFormatGoldenTest fp + , ipiFormatRoundTripTest fp + ] + +ipiFormatGoldenTest :: FilePath -> TestTree +ipiFormatGoldenTest fp = cabalGoldenTest "format" correct $ do + contents <- BS.readFile input + let res = IPI.parseInstalledPackageInfo contents + return $ toUTF8BS $ case res of + Left err -> "ERROR " ++ show err + Right (ws, ipi) -> + unlines ws ++ IPI.showInstalledPackageInfo ipi + where + input = "tests" "ParserTests" "ipi" fp + correct = replaceExtension input "format" + +#ifdef MIN_VERSION_tree_diff +ipiTreeDiffGoldenTest :: FilePath -> TestTree +ipiTreeDiffGoldenTest fp = ediffGolden goldenTest "expr" exprFile $ do + contents <- BS.readFile input + let res = IPI.parseInstalledPackageInfo contents + case res of + Left err -> fail $ "ERROR " ++ show err + Right (_ws, ipi) -> pure (toExpr ipi) + where + input = "tests" "ParserTests" "ipi" fp + exprFile = replaceExtension input "expr" +#endif + +ipiFormatRoundTripTest :: FilePath -> TestTree +ipiFormatRoundTripTest fp = testCase "roundtrip" $ do + contents <- BS.readFile input + x <- parse contents + let contents' = IPI.showInstalledPackageInfo x + y <- parse (toUTF8BS contents') + + -- ghc-pkg prints pkgroot itself, based on cli arguments! + let x' = x { IPI.pkgRoot = Nothing } + let y' = y + assertBool "pkgRoot isn't shown" (isNothing (IPI.pkgRoot y)) + assertEqual "re-parsed doesn't match" x' y' + + -- Complete round-trip + let contents2 = IPI.showFullInstalledPackageInfo x + z <- parse (toUTF8BS contents2) + assertEqual "re-parsed doesn't match" x z + + where + parse :: BS.ByteString -> IO IPI.InstalledPackageInfo + parse c = do + case IPI.parseInstalledPackageInfo c of + Right (_, ipi) -> return ipi + Left err -> do + void $ assertFailure $ show err + fail "failure" + input = "tests" "ParserTests" "ipi" fp + +------------------------------------------------------------------------------- +-- Main +------------------------------------------------------------------------------- + +main :: IO () +main = do + args <- getArgs + case args of + ("--cwd" : cwd : args') -> do + setCurrentDirectory cwd + withArgs args' $ defaultMain tests + _ -> defaultMain tests + +cabalGoldenTest :: TestName -> FilePath -> IO BS.ByteString -> TestTree +cabalGoldenTest name ref act = goldenTest name (BS.readFile ref) act cmp upd + where + upd = BS.writeFile ref + cmp x y | x == y = return Nothing + cmp x y = return $ Just $ unlines $ + concatMap f (getGroupedDiff (BS8.lines x) (BS8.lines y)) + where + f (First xs) = map (cons3 '-' . fromUTF8BS) xs + f (Second ys) = map (cons3 '+' . fromUTF8BS) ys + -- we print unchanged lines too. It shouldn't be a problem while we have + -- reasonably small examples + f (Both xs _) = map (cons3 ' ' . fromUTF8BS) xs + -- we add three characters, so the changed lines are easier to spot + cons3 c cs = c : c : c : ' ' : cs diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/MiniAgda.cabal b/cabal/Cabal-tests/tests/ParserTests/errors/MiniAgda.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/MiniAgda.cabal @@ -0,0 +1,89 @@ +name: MiniAgda +version: 0.2017.02.18 +build-type: Simple +cabal-version: 1.22 +license: OtherLicense +license-file: LICENSE +author: Andreas Abel and Karl Mehltretter +maintainer: Andreas Abel +homepage: http://www.tcs.ifi.lmu.de/~abel/miniagda/ +bug-reports: https://github.com/andreasabel/miniagda/issues +category: Dependent types +synopsis: A toy dependently typed programming language with type-based termination. +description: + MiniAgda is a tiny dependently-typed programming language in the style + of Agda. It serves as a laboratory to test potential additions to the + language and type system of Agda. MiniAgda's termination checker is a + fusion of sized types and size-change termination and supports + coinduction. Equality incorporates eta-expansion at record and + singleton types. Function arguments can be declared as static; such + arguments are discarded during equality checking and compilation. + + Recent features include bounded size quantification and destructor + patterns for a more general handling of coinduction. + +tested-with: GHC == 7.6.3 + GHC == 7.8.4 + GHC == 7.10.3 + GHC == 8.0.1 + +extra-source-files: Makefile + +data-files: test/succeed/Makefile + test/succeed/*.ma + test/fail/Makefile + test/fail/*.ma + test/fail/*.err + test/fail/adm/*.ma + test/fail/adm/*.err + lib/*.ma +source-repository head + type: git + location: https://github.com/andreasabel/miniagda + +executable miniagda + hs-source-dirs: src + build-depends: array >= 0.3 && < 0.6, + base >= 4.6 && < 4.11, + containers >= 0.3 && < 0.6, + haskell-src-exts >= 1.17 && < 1.18, + mtl >= 2.2.0.1 && < 2.3, + pretty >= 1.0 && < 1.2 + build-tools: happy >= 1.15 && < 2, + alex >= 3.0 && < 4 + default-language: Haskell98 + default-extensions: CPP + MultiParamTypeClasses + TypeSynonymInstances + FlexibleInstances + FlexibleContexts + GeneralizedNewtypeDeriving + NoMonomorphismRestriction + PatternGuards + TupleSections + NamedFieldPuns + main-is: Main.hs + other-modules: Abstract + Collection + Concrete + Eval + Extract + HsSyntax + Lexer + Main + Parser + Polarity + PrettyTCM + ScopeChecker + Semiring + SparseMatrix + TCM + Termination + ToHaskell + Tokens + TraceError + TreeShapedOrder + TypeChecker + Util + Value + Warshall diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/MiniAgda.errors b/cabal/Cabal-tests/tests/ParserTests/errors/MiniAgda.errors new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/MiniAgda.errors @@ -0,0 +1,4 @@ +VERSION: Just (mkVersion [1,22]) +MiniAgda.cabal:2:27: +unexpected Version digit with leading zero + diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/anynone.cabal b/cabal/Cabal-tests/tests/ParserTests/errors/anynone.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/anynone.cabal @@ -0,0 +1,10 @@ +cabal-version: 3.4 +name: anynone +version: 0 +synopsis: The -any none demo +build-type: Simple + +library + default-language: Haskell2010 + exposed-modules: AnyNone + build-depends: base -any diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/anynone.errors b/cabal/Cabal-tests/tests/ParserTests/errors/anynone.errors new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/anynone.errors @@ -0,0 +1,5 @@ +VERSION: Just (mkVersion [3,4]) +anynone.cabal:10:26: +unexpected '-' +expecting space, white space, opening paren, operator, comma or end of input + diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/big-version.cabal b/cabal/Cabal-tests/tests/ParserTests/errors/big-version.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/big-version.cabal @@ -0,0 +1,7 @@ +cabal-version: 3.0 +name: big-version +-- 10 digits +version: 1234567890 + +library + default-language: Haskell2010 diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/big-version.errors b/cabal/Cabal-tests/tests/ParserTests/errors/big-version.errors new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/big-version.errors @@ -0,0 +1,4 @@ +VERSION: Just (mkVersion [3,0]) +big-version.cabal:4:32: +unexpected At most 9 numbers are allowed per version number part + diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/common1.cabal b/cabal/Cabal-tests/tests/ParserTests/errors/common1.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/common1.cabal @@ -0,0 +1,29 @@ +cabal-version: 2.2 +name: common +version: 0 +synopsis: Common-stanza demo demo +build-type: Simple + +source-repository head + Type: git + Location: https://github.com/hvr/-.git + +common windows + if os(windows) + build-depends: Win32 + +-- Non-existing common stanza +common deps + import: windo + build-depends: + base >=4.10 && <4.11, + containers + +library + import: deps + + default-language: Haskell2010 + exposed-modules: ElseIf + + build-depends: + ghc-prim diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/common1.errors b/cabal/Cabal-tests/tests/ParserTests/errors/common1.errors new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/common1.errors @@ -0,0 +1,2 @@ +VERSION: Just (mkVersion [2,2]) +common1.cabal:17:3: Undefined common stanza imported: windo diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/common2.cabal b/cabal/Cabal-tests/tests/ParserTests/errors/common2.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/common2.cabal @@ -0,0 +1,29 @@ +cabal-version: 2.2 +name: common +version: 0 +synopsis: Common-stanza demo demo +build-type: Simple + +source-repository head + Type: git + Location: https://github.com/hvr/-.git + +-- Used before use +common deps + import: windows + build-depends: + base >=4.10 && <4.11, + containers + +common windows + if os(windows) + build-depends: Win32 + +library + import: deps + + default-language: Haskell2010 + exposed-modules: ElseIf + + build-depends: + ghc-prim diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/common2.errors b/cabal/Cabal-tests/tests/ParserTests/errors/common2.errors new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/common2.errors @@ -0,0 +1,2 @@ +VERSION: Just (mkVersion [2,2]) +common2.cabal:13:3: Undefined common stanza imported: windows diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/common3.cabal b/cabal/Cabal-tests/tests/ParserTests/errors/common3.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/common3.cabal @@ -0,0 +1,31 @@ +cabal-version: 2.2 +name: common +version: 0 +synopsis: Common-stanza demo demo +build-type: Simple + +source-repository head + Type: git + Location: https://github.com/hvr/-.git + +common windows + if os(windows) + build-depends: Win32 + +common deps + import: windows + build-depends: + base >=4.10 && <4.11, + containers + +-- Duplicate +common deps + +library + import: deps + + default-language: Haskell2010 + exposed-modules: ElseIf + + build-depends: + ghc-prim diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/common3.errors b/cabal/Cabal-tests/tests/ParserTests/errors/common3.errors new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/common3.errors @@ -0,0 +1,2 @@ +VERSION: Just (mkVersion [2,2]) +common3.cabal:22:1: Duplicate common stanza: deps diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/forward-compat.cabal b/cabal/Cabal-tests/tests/ParserTests/errors/forward-compat.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/forward-compat.cabal @@ -0,0 +1,4 @@ +cabal-version: 99999.9 +name: future +============ +Lexically completely changed future diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/forward-compat.errors b/cabal/Cabal-tests/tests/ParserTests/errors/forward-compat.errors new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/forward-compat.errors @@ -0,0 +1,2 @@ +VERSION: Just (mkVersion [99999,9]) +forward-compat.cabal:0:0: Unsupported cabal-version 99999.9. See https://github.com/haskell/cabal/issues/4899. diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/forward-compat2.cabal b/cabal/Cabal-tests/tests/ParserTests/errors/forward-compat2.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/forward-compat2.cabal @@ -0,0 +1,16 @@ +name: common +version: 0 +synopsis: Common-stanza demo demo +build-type: Simple +cabal-version: 2.2 + +source-repository head + Type: git + Location: https://github.com/hvr/-.git + +library + default-language: Haskell2010 + exposed-modules: ElseIf + + build-depends: + ghc-prim diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/forward-compat2.errors b/cabal/Cabal-tests/tests/ParserTests/errors/forward-compat2.errors new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/forward-compat2.errors @@ -0,0 +1,2 @@ +VERSION: Just (mkVersion [2,2]) +forward-compat2.cabal:5:1: cabal-version should be at the beginning of the file starting with spec version 2.2. See https://github.com/haskell/cabal/issues/4899 diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/forward-compat3.cabal b/cabal/Cabal-tests/tests/ParserTests/errors/forward-compat3.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/forward-compat3.cabal @@ -0,0 +1,16 @@ +cabal-version: 99999.99 +name: forward-compat +version: 0 +synopsis: Forward compat, too new cabal-version: we fail. +build-type: Simple + +source-repository head + Type: git + Location: https://github.com/hvr/-.git + +library + default-language: Haskell2010 + exposed-modules: ElseIf + + build-depends: + ghc-prim diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/forward-compat3.errors b/cabal/Cabal-tests/tests/ParserTests/errors/forward-compat3.errors new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/forward-compat3.errors @@ -0,0 +1,2 @@ +VERSION: Just (mkVersion [99999,99]) +forward-compat3.cabal:0:0: Unsupported cabal-version 99999.99. See https://github.com/haskell/cabal/issues/4899. diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/issue-5055-2.cabal b/cabal/Cabal-tests/tests/ParserTests/errors/issue-5055-2.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/issue-5055-2.cabal @@ -0,0 +1,25 @@ +name: issue +version: 5055 +synopsis: no type in all branches +description: no type in all branches. +license: BSD3 +category: Test +build-type: Simple +cabal-version: 2.0 + +executable flag-test-exe + main-is: FirstMain.hs + build-depends: base >= 4.8 && < 5 + default-language: Haskell2010 + +test-suite flag-cabal-test + -- TODO: fix so `type` can be on the top level + build-depends: base >= 4.8 && < 5 + default-language: Haskell2010 + + if os(windows) + main-is: FirstMain.hs + type: exitcode-stdio-1.0 + else: + main-is: SecondMain.hs + type: exitcode-stdio-1.0 diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/issue-5055-2.errors b/cabal/Cabal-tests/tests/ParserTests/errors/issue-5055-2.errors new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/issue-5055-2.errors @@ -0,0 +1,2 @@ +VERSION: Just (mkVersion [2,0]) +issue-5055-2.cabal:15:1: Test suite "flag-cabal-test" is missing required field "type" or the field is not present in all conditional branches. The available test types are: exitcode-stdio-1.0, detailed-0.9 diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/issue-5055.cabal b/cabal/Cabal-tests/tests/ParserTests/errors/issue-5055.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/issue-5055.cabal @@ -0,0 +1,21 @@ +name: issue +version: 5055 +synopsis: no type in all branches +description: no type in all branches. +license: BSD3 +category: Test +build-type: Simple +cabal-version: 2.0 + +executable flag-test-exe + main-is: FirstMain.hs + build-depends: base >= 4.8 && < 5 + default-language: Haskell2010 + +test-suite flag-cabal-test + build-depends: base >= 4.8 && < 5 + default-language: Haskell2010 + + if os(windows) + main-is: FirstMain.hs + type: exitcode-stdio-1.0 diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/issue-5055.errors b/cabal/Cabal-tests/tests/ParserTests/errors/issue-5055.errors new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/issue-5055.errors @@ -0,0 +1,2 @@ +VERSION: Just (mkVersion [2,0]) +issue-5055.cabal:15:1: Test suite "flag-cabal-test" is missing required field "type" or the field is not present in all conditional branches. The available test types are: exitcode-stdio-1.0, detailed-0.9 diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/leading-comma-2.cabal b/cabal/Cabal-tests/tests/ParserTests/errors/leading-comma-2.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/leading-comma-2.cabal @@ -0,0 +1,23 @@ +cabal-version: 2.4 +-- too small cabal-version + +name: leading-comma +version: 0 +synopsis: leading comma, trailing comma, or ordinary +build-type: Simple + +library + default-language: Haskell2010 + exposed-modules: + , LeadingComma + , LeadingComma + + build-depends: base, containers + + build-depends: + deepseq, + transformers, + + build-depends: + , filepath + , directory diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/leading-comma-2.errors b/cabal/Cabal-tests/tests/ParserTests/errors/leading-comma-2.errors new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/leading-comma-2.errors @@ -0,0 +1,5 @@ +VERSION: Just (mkVersion [2,4]) +leading-comma-2.cabal:12:5: +unexpected ',' +expecting white space, "\"" or end of input + diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/leading-comma-2b.cabal b/cabal/Cabal-tests/tests/ParserTests/errors/leading-comma-2b.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/leading-comma-2b.cabal @@ -0,0 +1,23 @@ +cabal-version: 2.4 +-- too small cabal-version + +name: leading-comma +version: 0 +synopsis: leading comma, trailing comma, or ordinary +build-type: Simple + +library + default-language: Haskell2010 + exposed-modules: + TrailingComma, + TrailingComma2, + + build-depends: base, containers + + build-depends: + deepseq, + transformers, + + build-depends: + , filepath + , directory diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/leading-comma-2b.errors b/cabal/Cabal-tests/tests/ParserTests/errors/leading-comma-2b.errors new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/leading-comma-2b.errors @@ -0,0 +1,5 @@ +VERSION: Just (mkVersion [2,4]) +leading-comma-2b.cabal:13:20: +unexpected end of input +expecting white space or "\"" + diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/leading-comma-2c.cabal b/cabal/Cabal-tests/tests/ParserTests/errors/leading-comma-2c.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/leading-comma-2c.cabal @@ -0,0 +1,21 @@ +cabal-version: 3.0 +name: leading-comma +version: 0 +synopsis: leading comma, trailing comma, or ordinary +build-type: Simple + +library + default-language: Haskell2010 + exposed-modules: + LeadingComma, MixedComma NoComma + + + build-depends: base, containers + + build-depends: + deepseq, + transformers, + + build-depends: + , filepath + , directory diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/leading-comma-2c.errors b/cabal/Cabal-tests/tests/ParserTests/errors/leading-comma-2c.errors new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/leading-comma-2c.errors @@ -0,0 +1,5 @@ +VERSION: Just (mkVersion [3,0]) +leading-comma-2c.cabal:10:30: +unexpected 'N' +expecting space, comma, white space or end of input + diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/leading-comma.cabal b/cabal/Cabal-tests/tests/ParserTests/errors/leading-comma.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/leading-comma.cabal @@ -0,0 +1,20 @@ +name: leading-comma +version: 0 +synopsis: leading comma, trailing comma, or ordinary +build-type: Simple +-- too small cabal-version +cabal-version: 2.0 + +library + default-language: Haskell2010 + exposed-modules: LeadingComma + + build-depends: base, containers + + build-depends: + deepseq, + transformers, + + build-depends: + , filepath + , directory diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/leading-comma.errors b/cabal/Cabal-tests/tests/ParserTests/errors/leading-comma.errors new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/leading-comma.errors @@ -0,0 +1,5 @@ +VERSION: Just (mkVersion [2,0]) +leading-comma.cabal:16:18: +unexpected end of input +expecting white space + diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/libpq1.cabal b/cabal/Cabal-tests/tests/ParserTests/errors/libpq1.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/libpq1.cabal @@ -0,0 +1,81 @@ +Name: postgresql-libpq +Version: 0.9.4.2 +Synopsis: low-level binding to libpq + +Description: This is a binding to libpq: the C application + programmer's interface to PostgreSQL. libpq is a + set of library functions that allow client + programs to pass queries to the PostgreSQL + backend server and to receive the results of + these queries. + +Homepage: https://github.com/phadej/postgresql-libpq +License: BSD3 +License-file: LICENSE +Author: Grant Monroe, Leon P Smith, Joey Adams +Maintainer: Oleg Grenrus +Copyright: (c) 2010 Grant Monroe + (c) 2011 Leon P Smith +Category: Database +Build-type: Custom +Extra-source-files: cbits/noticehandlers.h +Cabal-version: >=1.8 +Tested-with: + GHC==7.0.4, + GHC==7.2.2, + GHC==7.4.2, + GHC==7.6.3, + GHC==7.8.4, + GHC==7.10.3, + GHC==8.0.2, + GHC==8.2.2, + GHC==8.4.3, + GHC==8.6.1 + +extra-source-files: + CHANGELOG.md + +Custom-setup + setup-depends: + base >= 4.3 && <5, Cabal >= 1.10 && <2.5 + +-- If true, use pkg-config, otherwise use the pg_config based build +-- configuration +Flag use-pkg-config + default: False + manual: True + +Library + hs-source-dirs: src + c-sources: cbits/noticehandlers.c + include-dirs: cbits + Exposed-modules: Database.PostgreSQL.LibPQ + Database.PostgreSQL.LibPQ.Internal + Build-depends: base >=4.3 && <4.13 + , bytestring >=0.9.1.0 && <0.11 + + if !os(windows) + Build-depends: unix >=2.4.2.0 && <2.8 + + if os(windows) + Build-depends: Win32 >=2.2.0.2 && <2.7 + + GHC-Options: -Wall + + if flag(use-pkg-config) + Pkgconfig-depends: libpq ==9.3h + else + if os(windows) + -- Due to https://sourceware.org/bugzilla/show_bug.cgi?id=22948, + -- if we specify pq instead of libpq, then ld might link against + -- libpq.dll directly, which can lead to segfaults. As a temporary hack, + -- we force ld to link against the libpq.lib import library directly + -- by specifying libpq here. + Extra-Libraries: libpq + else + Extra-Libraries: pq + if os(openbsd) + Extra-Libraries: crypto ssl + + -- Other-modules: + Build-tools: hsc2hs diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/libpq1.errors b/cabal/Cabal-tests/tests/ParserTests/errors/libpq1.errors new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/libpq1.errors @@ -0,0 +1,5 @@ +VERSION: Just (mkVersion [1,8]) +libpq1.cabal:66:37: +unexpected 'h' +expecting ".", "-", white space, "&&", "||", comma or end of input + diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/libpq2.cabal b/cabal/Cabal-tests/tests/ParserTests/errors/libpq2.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/libpq2.cabal @@ -0,0 +1,81 @@ +Cabal-version: 3.0 +Name: postgresql-libpq +Version: 0.9.4.2 +Synopsis: low-level binding to libpq + +Description: This is a binding to libpq: the C application + programmer's interface to PostgreSQL. libpq is a + set of library functions that allow client + programs to pass queries to the PostgreSQL + backend server and to receive the results of + these queries. + +Homepage: https://github.com/phadej/postgresql-libpq +License: BSD-3-Clause +License-file: LICENSE +Author: Grant Monroe, Leon P Smith, Joey Adams +Maintainer: Oleg Grenrus +Copyright: (c) 2010 Grant Monroe + (c) 2011 Leon P Smith +Category: Database +Build-type: Custom +Extra-source-files: cbits/noticehandlers.h +Tested-with: + GHC==7.0.4, + GHC==7.2.2, + GHC==7.4.2, + GHC==7.6.3, + GHC==7.8.4, + GHC==7.10.3, + GHC==8.0.2, + GHC==8.2.2, + GHC==8.4.3, + GHC==8.6.1 + +extra-source-files: + CHANGELOG.md + +Custom-setup + setup-depends: + base >= 4.3 && <5, Cabal >= 1.10 && <2.5 + +-- If true, use pkg-config, otherwise use the pg_config based build +-- configuration +Flag use-pkg-config + default: False + manual: True + +Library + hs-source-dirs: src + c-sources: cbits/noticehandlers.c + include-dirs: cbits + Exposed-modules: Database.PostgreSQL.LibPQ + Database.PostgreSQL.LibPQ.Internal + Build-depends: base >=4.3 && <4.13 + , bytestring >=0.9.1.0 && <0.11 + + if !os(windows) + Build-depends: unix >=2.4.2.0 && <2.8 + + if os(windows) + Build-depends: Win32 >=2.2.0.2 && <2.7 + + GHC-Options: -Wall + + if flag(use-pkg-config) + Pkgconfig-depends: libpq >=9.* + else + if os(windows) + -- Due to https://sourceware.org/bugzilla/show_bug.cgi?id=22948, + -- if we specify pq instead of libpq, then ld might link against + -- libpq.dll directly, which can lead to segfaults. As a temporary hack, + -- we force ld to link against the libpq.lib import library directly + -- by specifying libpq here. + Extra-Libraries: libpq + else + Extra-Libraries: pq + if os(openbsd) + Extra-Libraries: crypto ssl + + -- Other-modules: + Build-tools-depends: hsc2hs:hsc2hs diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/libpq2.errors b/cabal/Cabal-tests/tests/ParserTests/errors/libpq2.errors new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/libpq2.errors @@ -0,0 +1,5 @@ +VERSION: Just (mkVersion [3,0]) +libpq2.cabal:66:36: +unexpected '*' +expecting white space, "&&", "||", comma or end of input + diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/mixin-1.cabal b/cabal/Cabal-tests/tests/ParserTests/errors/mixin-1.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/mixin-1.cabal @@ -0,0 +1,15 @@ +cabal-version: 2.4 +name: mixin +version: 0 + +-- mixin field: +-- in 2.2 we got leading/trailing commas +-- in 3.0 we got lax space parsing +-- +-- This should fail +executable str-example + main-is: Main.hs + build-depends: base, str-string, str-bytestring + mixins: str-string ( Str as Str.String ), + str-bytestring ( Str as Str.ByteString ), + hs-source-dirs: str-example diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/mixin-1.errors b/cabal/Cabal-tests/tests/ParserTests/errors/mixin-1.errors new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/mixin-1.errors @@ -0,0 +1,4 @@ +VERSION: Just (mkVersion [2,4]) +mixin-1.cabal:13:41: +unexpected space after parenthesis, use cabal-version: 3.0 or higher + diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/mixin-2.cabal b/cabal/Cabal-tests/tests/ParserTests/errors/mixin-2.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/mixin-2.cabal @@ -0,0 +1,14 @@ +cabal-version: 2.2 +name: mixin +version: 0 + +-- mixin field: +-- in 2.2 we got leading/trailing commas +-- in 2.2 we got lax space parsing +-- +-- This should fail +executable str-example + main-is: Main.hs + build-depends: base, str-string, str-bytestring + mixins: str-string hiding ( Foo ) + hs-source-dirs: str-example diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/mixin-2.errors b/cabal/Cabal-tests/tests/ParserTests/errors/mixin-2.errors new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/mixin-2.errors @@ -0,0 +1,4 @@ +VERSION: Just (mkVersion [2,2]) +mixin-2.cabal:13:48: +unexpected space after parenthesis, use cabal-version: 3.0 or higher + diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/multiple-libs.cabal b/cabal/Cabal-tests/tests/ParserTests/errors/multiple-libs.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/multiple-libs.cabal @@ -0,0 +1,14 @@ +name: multipleLibs +version: 0 +synopsis: multiple main/nameless libs +build-type: Simple +cabal-version: 1.20 + +library + default-language: Haskell2010 + exposed-modules: ElseIf + build-depends: base + +library + default-language: Haskell2010 + exposed-modules: ElseIf diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/multiple-libs.errors b/cabal/Cabal-tests/tests/ParserTests/errors/multiple-libs.errors new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/multiple-libs.errors @@ -0,0 +1,2 @@ +VERSION: Just (mkVersion [1,20]) +multiple-libs.cabal:12:1: Multiple main libraries; have you forgotten to specify a name for an internal library? diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/noVersion.cabal b/cabal/Cabal-tests/tests/ParserTests/errors/noVersion.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/noVersion.cabal @@ -0,0 +1,10 @@ +name: noVersion +version: 0 +synopsis: -none in build-depends +build-type: Simple +cabal-version: 1.20 + +library + default-language: Haskell2010 + exposed-modules: ElseIf + build-depends: bad-package -none diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/noVersion.errors b/cabal/Cabal-tests/tests/ParserTests/errors/noVersion.errors new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/noVersion.errors @@ -0,0 +1,4 @@ +VERSION: Just (mkVersion [1,20]) +noVersion.cabal:10:38: +unexpected -none version range used. To use this syntax the package needs to specify at least 'cabal-version: 1.22'. Alternatively, if broader compatibility is important then use <0 or other empty range. + diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/noVersion2.cabal b/cabal/Cabal-tests/tests/ParserTests/errors/noVersion2.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/noVersion2.cabal @@ -0,0 +1,10 @@ +name: noVersion +version: 0 +synopsis: ^>= in build-depends +build-type: Simple +cabal-version: 1.20 + +library + default-language: Haskell2010 + exposed-modules: ElseIf + build-depends: bad-package ^>= 2.0 diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/noVersion2.errors b/cabal/Cabal-tests/tests/ParserTests/errors/noVersion2.errors new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/noVersion2.errors @@ -0,0 +1,5 @@ +VERSION: Just (mkVersion [1,20]) +noVersion2.cabal:10:40: +unexpected major bounded version syntax (caret, ^>=) used. To use this syntax the package need to specify at least 'cabal-version: 2.0'. Alternatively, if broader compatibility is important then use: >=2.0 && <2.1 +expecting "." or "-" + diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/range-ge-wild.cabal b/cabal/Cabal-tests/tests/ParserTests/errors/range-ge-wild.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/range-ge-wild.cabal @@ -0,0 +1,10 @@ +name: range-ge-wild +version: 0 +synopsis: Wild range after non-== op +build-type: Simple +cabal-version: >=1.10 + +library + build-depends: + -- comment, to check that position is right + base >= 4.* diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/range-ge-wild.errors b/cabal/Cabal-tests/tests/ParserTests/errors/range-ge-wild.errors new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/range-ge-wild.errors @@ -0,0 +1,4 @@ +VERSION: Just (mkVersion [1,10]) +range-ge-wild.cabal:10:16: +unexpected wild-card version after non-== operator: ">=" + diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/removed-fields.cabal b/cabal/Cabal-tests/tests/ParserTests/errors/removed-fields.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/removed-fields.cabal @@ -0,0 +1,14 @@ +cabal-version: 3.0 +name: removed-fields +version: 0 +synopsis: some fields are removed +build-type: Simple + +library + default-language: Haskell2010 + exposed-modules: RemovedFields + + build-depends: base, containers + + extensions: CPP + extensions: DeriveFunctor diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/removed-fields.errors b/cabal/Cabal-tests/tests/ParserTests/errors/removed-fields.errors new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/removed-fields.errors @@ -0,0 +1,3 @@ +VERSION: Just (mkVersion [3,0]) +removed-fields.cabal:13:3: The field "extensions" is removed in the Cabal specification version 3.0. Please use 'default-extensions' or 'other-extensions' fields. +removed-fields.cabal:14:3: The field "extensions" is removed in the Cabal specification version 3.0. Please use 'default-extensions' or 'other-extensions' fields. diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/spdx-1.cabal b/cabal/Cabal-tests/tests/ParserTests/errors/spdx-1.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/spdx-1.cabal @@ -0,0 +1,9 @@ +cabal-version: 2.2 +name: spdx +version: 0 +synopsis: testing positive parsing of spdx identifiers +build-type: Simple +license: BSD3 + +library + default-language: Haskell2010 diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/spdx-1.errors b/cabal/Cabal-tests/tests/ParserTests/errors/spdx-1.errors new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/spdx-1.errors @@ -0,0 +1,4 @@ +VERSION: Just (mkVersion [2,2]) +spdx-1.cabal:6:26: +unexpected Unknown SPDX license identifier: 'BSD3' Do you mean BSD-3-Clause? + diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/spdx-2.cabal b/cabal/Cabal-tests/tests/ParserTests/errors/spdx-2.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/spdx-2.cabal @@ -0,0 +1,9 @@ +cabal-version: 2.4 +name: spdx +version: 0 +synopsis: testing positive parsing of spdx identifiers +build-type: Simple +license: AGPL-1.0 + +library + default-language: Haskell2010 diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/spdx-2.errors b/cabal/Cabal-tests/tests/ParserTests/errors/spdx-2.errors new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/spdx-2.errors @@ -0,0 +1,4 @@ +VERSION: Just (mkVersion [2,4]) +spdx-2.cabal:6:30: +unexpected Unknown SPDX license identifier: 'AGPL-1.0' + diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/spdx-3.cabal b/cabal/Cabal-tests/tests/ParserTests/errors/spdx-3.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/spdx-3.cabal @@ -0,0 +1,9 @@ +cabal-version: 2.2 +name: spdx +version: 0 +synopsis: testing positive parsing of spdx identifiers +build-type: Simple +license: AGPL-1.0-only + +library + default-language: Haskell2010 diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/spdx-3.errors b/cabal/Cabal-tests/tests/ParserTests/errors/spdx-3.errors new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/spdx-3.errors @@ -0,0 +1,4 @@ +VERSION: Just (mkVersion [2,2]) +spdx-3.cabal:6:35: +unexpected Unknown SPDX license identifier: 'AGPL-1.0-only' + diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/undefined-flag.cabal b/cabal/Cabal-tests/tests/ParserTests/errors/undefined-flag.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/undefined-flag.cabal @@ -0,0 +1,26 @@ +name: hpython-test-common +version: 0.1.0.0 +-- synopsis: +-- description: +license: BSD3 +license-file: LICENSE +author: Isaac Elliott +maintainer: isaace71295@gmail.com +-- copyright: +category: Testing +build-type: Simple +extra-source-files: CHANGELOG.md +cabal-version: >=1.10 + +library + exposed-modules: Helpers + build-depends: base >=4.11 && <5 + hs-source-dirs: src + ghc-options: -Wall + -Wincomplete-patterns + -Wincomplete-record-updates + -Wunused-imports + -fno-warn-name-shadowing + if flag(development) + ghc-options: -Werror + default-language: Haskell2010 diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/undefined-flag.errors b/cabal/Cabal-tests/tests/ParserTests/errors/undefined-flag.errors new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/undefined-flag.errors @@ -0,0 +1,2 @@ +VERSION: Just (mkVersion [1,10]) +undefined-flag.cabal:0:0: These flags are used without having been defined: development diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/version-sets-1.cabal b/cabal/Cabal-tests/tests/ParserTests/errors/version-sets-1.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/version-sets-1.cabal @@ -0,0 +1,8 @@ +cabal-version: 3.0 +name: version-sets +version: 0 +synopsis: version set notation + +library + default-language: Haskell2010 + build-depends: network == { } diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/version-sets-1.errors b/cabal/Cabal-tests/tests/ParserTests/errors/version-sets-1.errors new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/version-sets-1.errors @@ -0,0 +1,5 @@ +VERSION: Just (mkVersion [3,0]) +version-sets-1.cabal:8:31: +unexpected "}" +expecting space or version digit (integral without leading zeroes) + diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/version-sets-2.cabal b/cabal/Cabal-tests/tests/ParserTests/errors/version-sets-2.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/version-sets-2.cabal @@ -0,0 +1,8 @@ +cabal-version: 3.0 +name: version-sets +version: 0 +synopsis: version set notation + +library + default-language: Haskell2010 + build-depends: network >= { 2.8.0.0 } diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/version-sets-2.errors b/cabal/Cabal-tests/tests/ParserTests/errors/version-sets-2.errors new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/version-sets-2.errors @@ -0,0 +1,5 @@ +VERSION: Just (mkVersion [3,0]) +version-sets-2.cabal:8:29: +unexpected "{" +expecting space or version digit (integral without leading zeroes) + diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/version-sets-3.cabal b/cabal/Cabal-tests/tests/ParserTests/errors/version-sets-3.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/version-sets-3.cabal @@ -0,0 +1,8 @@ +cabal-version: 3.0 +name: version-sets +version: 0 +synopsis: version set notation + +library + default-language: Haskell2010 + build-depends: network == { 2.8.0.0, } diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/version-sets-3.errors b/cabal/Cabal-tests/tests/ParserTests/errors/version-sets-3.errors new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/version-sets-3.errors @@ -0,0 +1,5 @@ +VERSION: Just (mkVersion [3,0]) +version-sets-3.cabal:8:40: +unexpected "}" +expecting space or version digit (integral without leading zeroes) + diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/version-sets-4.cabal b/cabal/Cabal-tests/tests/ParserTests/errors/version-sets-4.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/version-sets-4.cabal @@ -0,0 +1,8 @@ +cabal-version: 3.0 +name: version-sets +version: 0 +synopsis: version set notation + +library + default-language: Haskell2010 + build-depends: network == { 2.8.* } diff --git a/cabal/Cabal-tests/tests/ParserTests/errors/version-sets-4.errors b/cabal/Cabal-tests/tests/ParserTests/errors/version-sets-4.errors new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/errors/version-sets-4.errors @@ -0,0 +1,5 @@ +VERSION: Just (mkVersion [3,0]) +version-sets-4.cabal:8:35: +unexpected "*" +expecting version digit (integral without leading zeroes) + diff --git a/cabal/Cabal-tests/tests/ParserTests/ipi/Includes2.cabal b/cabal/Cabal-tests/tests/ParserTests/ipi/Includes2.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/ipi/Includes2.cabal @@ -0,0 +1,27 @@ +name: z-Includes2-z-mylib +version: 0.1.0.0 +id: Includes2-0.1.0.0-inplace-mylib+3gY9SyjX86dBypHcOaev1n +instantiated-with: Database=Includes2-0.1.0.0-inplace-mysql:Database.MySQL +package-name: Includes2 +lib-name: mylib +key: Includes2-0.1.0.0-inplace-mylib+3gY9SyjX86dBypHcOaev1n +license: BSD3 +maintainer: ezyang@cs.stanford.edu +author: Edward Z. Yang +exposed: False +indefinite: False +exposed-modules: + Mine +abi: inplace +trusted: False +import-dirs: /home/travis/build/haskell/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal.dist/work/./dist/build/x86_64-linux/ghc-8.2.2/Includes2-0.1.0.0/l/mylib/Includes2-0.1.0.0-inplace-mylib+3gY9SyjX86dBypHcOaev1n/build/Includes2-0.1.0.0-inplace-mylib+3gY9SyjX86dBypHcOaev1n +library-dirs: /home/travis/build/haskell/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal.dist/work/./dist/build/x86_64-linux/ghc-8.2.2/Includes2-0.1.0.0/l/mylib/Includes2-0.1.0.0-inplace-mylib+3gY9SyjX86dBypHcOaev1n/build/Includes2-0.1.0.0-inplace-mylib+3gY9SyjX86dBypHcOaev1n +dynamic-library-dirs: /home/travis/build/haskell/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal.dist/work/./dist/build/x86_64-linux/ghc-8.2.2/Includes2-0.1.0.0/l/mylib/Includes2-0.1.0.0-inplace-mylib+3gY9SyjX86dBypHcOaev1n/build/Includes2-0.1.0.0-inplace-mylib+3gY9SyjX86dBypHcOaev1n +data-dir: /home/travis/build/haskell/cabal/cabal-testsuite/PackageTests/Backpack/Includes2 +hs-libraries: HSIncludes2-0.1.0.0-inplace-mylib+3gY9SyjX86dBypHcOaev1n +depends: + base-4.10.1.0 Includes2-0.1.0.0-inplace-mysql +abi-depends: base-4.10.1.0=35a7f6be752ee4f7385cb5bf28677879 + Includes2-0.1.0.0-inplace-mysql=inplace +haddock-interfaces: /home/travis/build/haskell/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal.dist/work/./dist/build/x86_64-linux/ghc-8.2.2/Includes2-0.1.0.0/l/mylib/Includes2-0.1.0.0-inplace-mylib+3gY9SyjX86dBypHcOaev1n/doc/html/Includes2/Includes2.haddock +haddock-html: /home/travis/build/haskell/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal.dist/work/./dist/build/x86_64-linux/ghc-8.2.2/Includes2-0.1.0.0/l/mylib/Includes2-0.1.0.0-inplace-mylib+3gY9SyjX86dBypHcOaev1n/doc/html/Includes2 diff --git a/cabal/Cabal-tests/tests/ParserTests/ipi/Includes2.expr b/cabal/Cabal-tests/tests/ParserTests/ipi/Includes2.expr new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/ipi/Includes2.expr @@ -0,0 +1,92 @@ +InstalledPackageInfo { + sourcePackageId = + PackageIdentifier { + pkgName = PackageName + "Includes2", + pkgVersion = mkVersion + [0, 1, 0, 0]}, + sourceLibName = LSubLibName + (UnqualComponentName "mylib"), + installedComponentId_ = + ComponentId "", + libVisibility = + LibraryVisibilityPrivate, + installedUnitId = UnitId + "Includes2-0.1.0.0-inplace-mylib+3gY9SyjX86dBypHcOaev1n", + instantiatedWith = [ + _×_ + (ModuleName "Database") + (OpenModule + (DefiniteUnitId + (DefUnitId + (UnitId + "Includes2-0.1.0.0-inplace-mysql"))) + (ModuleName "Database.MySQL"))], + compatPackageKey = + "Includes2-0.1.0.0-inplace-mylib+3gY9SyjX86dBypHcOaev1n", + license = Right BSD3, + copyright = "", + maintainer = + "ezyang@cs.stanford.edu", + author = "Edward Z. Yang", + stability = "", + homepage = "", + pkgUrl = "", + synopsis = "", + description = "", + category = "", + abiHash = AbiHash "inplace", + indefinite = False, + exposed = False, + exposedModules = [ + ExposedModule { + exposedName = ModuleName "Mine", + exposedReexport = Nothing}], + hiddenModules = [], + trusted = False, + importDirs = + [ + "/home/travis/build/haskell/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal.dist/work/./dist/build/x86_64-linux/ghc-8.2.2/Includes2-0.1.0.0/l/mylib/Includes2-0.1.0.0-inplace-mylib+3gY9SyjX86dBypHcOaev1n/build/Includes2-0.1.0.0-inplace-mylib+3gY9SyjX86dBypHcOaev1n"], + libraryDirs = + [ + "/home/travis/build/haskell/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal.dist/work/./dist/build/x86_64-linux/ghc-8.2.2/Includes2-0.1.0.0/l/mylib/Includes2-0.1.0.0-inplace-mylib+3gY9SyjX86dBypHcOaev1n/build/Includes2-0.1.0.0-inplace-mylib+3gY9SyjX86dBypHcOaev1n"], + libraryDirsStatic = [], + libraryDynDirs = + [ + "/home/travis/build/haskell/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal.dist/work/./dist/build/x86_64-linux/ghc-8.2.2/Includes2-0.1.0.0/l/mylib/Includes2-0.1.0.0-inplace-mylib+3gY9SyjX86dBypHcOaev1n/build/Includes2-0.1.0.0-inplace-mylib+3gY9SyjX86dBypHcOaev1n"], + dataDir = + "/home/travis/build/haskell/cabal/cabal-testsuite/PackageTests/Backpack/Includes2", + hsLibraries = [ + "HSIncludes2-0.1.0.0-inplace-mylib+3gY9SyjX86dBypHcOaev1n"], + extraLibraries = [], + extraLibrariesStatic = [], + extraGHCiLibraries = [], + includeDirs = [], + includes = [], + depends = [ + UnitId "base-4.10.1.0", + UnitId + "Includes2-0.1.0.0-inplace-mysql"], + abiDepends = [ + AbiDependency { + depUnitId = UnitId + "base-4.10.1.0", + depAbiHash = AbiHash + "35a7f6be752ee4f7385cb5bf28677879"}, + AbiDependency { + depUnitId = UnitId + "Includes2-0.1.0.0-inplace-mysql", + depAbiHash = AbiHash + "inplace"}], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + frameworkDirs = [], + frameworks = [], + haddockInterfaces = + [ + "/home/travis/build/haskell/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal.dist/work/./dist/build/x86_64-linux/ghc-8.2.2/Includes2-0.1.0.0/l/mylib/Includes2-0.1.0.0-inplace-mylib+3gY9SyjX86dBypHcOaev1n/doc/html/Includes2/Includes2.haddock"], + haddockHTMLs = + [ + "/home/travis/build/haskell/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal.dist/work/./dist/build/x86_64-linux/ghc-8.2.2/Includes2-0.1.0.0/l/mylib/Includes2-0.1.0.0-inplace-mylib+3gY9SyjX86dBypHcOaev1n/doc/html/Includes2"], + pkgRoot = Nothing} diff --git a/cabal/Cabal-tests/tests/ParserTests/ipi/Includes2.format b/cabal/Cabal-tests/tests/ParserTests/ipi/Includes2.format new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/ipi/Includes2.format @@ -0,0 +1,35 @@ +name: z-Includes2-z-mylib +version: 0.1.0.0 +package-name: Includes2 +lib-name: mylib +id: Includes2-0.1.0.0-inplace-mylib+3gY9SyjX86dBypHcOaev1n +instantiated-with: Database=Includes2-0.1.0.0-inplace-mysql:Database.MySQL +key: Includes2-0.1.0.0-inplace-mylib+3gY9SyjX86dBypHcOaev1n +license: BSD3 +maintainer: ezyang@cs.stanford.edu +author: Edward Z. Yang +abi: inplace +exposed-modules: Mine +import-dirs: + /home/travis/build/haskell/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal.dist/work/./dist/build/x86_64-linux/ghc-8.2.2/Includes2-0.1.0.0/l/mylib/Includes2-0.1.0.0-inplace-mylib+3gY9SyjX86dBypHcOaev1n/build/Includes2-0.1.0.0-inplace-mylib+3gY9SyjX86dBypHcOaev1n + +library-dirs: + /home/travis/build/haskell/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal.dist/work/./dist/build/x86_64-linux/ghc-8.2.2/Includes2-0.1.0.0/l/mylib/Includes2-0.1.0.0-inplace-mylib+3gY9SyjX86dBypHcOaev1n/build/Includes2-0.1.0.0-inplace-mylib+3gY9SyjX86dBypHcOaev1n + +dynamic-library-dirs: + /home/travis/build/haskell/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal.dist/work/./dist/build/x86_64-linux/ghc-8.2.2/Includes2-0.1.0.0/l/mylib/Includes2-0.1.0.0-inplace-mylib+3gY9SyjX86dBypHcOaev1n/build/Includes2-0.1.0.0-inplace-mylib+3gY9SyjX86dBypHcOaev1n + +data-dir: + /home/travis/build/haskell/cabal/cabal-testsuite/PackageTests/Backpack/Includes2 + +hs-libraries: HSIncludes2-0.1.0.0-inplace-mylib+3gY9SyjX86dBypHcOaev1n +depends: base-4.10.1.0 Includes2-0.1.0.0-inplace-mysql +abi-depends: + base-4.10.1.0=35a7f6be752ee4f7385cb5bf28677879 + Includes2-0.1.0.0-inplace-mysql=inplace + +haddock-interfaces: + /home/travis/build/haskell/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal.dist/work/./dist/build/x86_64-linux/ghc-8.2.2/Includes2-0.1.0.0/l/mylib/Includes2-0.1.0.0-inplace-mylib+3gY9SyjX86dBypHcOaev1n/doc/html/Includes2/Includes2.haddock + +haddock-html: + /home/travis/build/haskell/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal.dist/work/./dist/build/x86_64-linux/ghc-8.2.2/Includes2-0.1.0.0/l/mylib/Includes2-0.1.0.0-inplace-mylib+3gY9SyjX86dBypHcOaev1n/doc/html/Includes2 diff --git a/cabal/Cabal-tests/tests/ParserTests/ipi/internal-preprocessor-test.cabal b/cabal/Cabal-tests/tests/ParserTests/ipi/internal-preprocessor-test.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/ipi/internal-preprocessor-test.cabal @@ -0,0 +1,26 @@ +name: internal-preprocessor-test +version: 0.1.0.0 +id: internal-preprocessor-test-0.1.0.0 +key: internal-preprocessor-test-0.1.0.0 +license: GPL-3 +maintainer: mikhail.glushenkov@gmail.com +synopsis: Internal custom preprocessor example. +description: + See https://github.com/haskell/cabal/issues/1541#issuecomment-30155513 +category: Testing +author: Mikhail Glushenkov +exposed: True +exposed-modules: + A +trusted: False +import-dirs: /home/ogre/Documents/other-haskell/cabal/cabal-testsuite/PackageTests/CustomPreProcess/setup.dist/work/dist/build +library-dirs: /home/ogre/Documents/other-haskell/cabal/cabal-testsuite/PackageTests/CustomPreProcess/setup.dist/work/dist/build + /home/ogre/Documents/other-haskell/cabal/cabal-testsuite/PackageTests/CustomPreProcess/setup.dist/work/dist/build +data-dir: /home/ogre/Documents/other-haskell/cabal/cabal-testsuite/PackageTests/CustomPreProcess +hs-libraries: HSinternal-preprocessor-test-0.1.0.0 +depends: + base-4.8.2.0-0d6d1084fbc041e1cded9228e80e264d +haddock-interfaces: /home/ogre/Documents/other-haskell/cabal/cabal-testsuite/PackageTests/CustomPreProcess/setup.dist/work/dist/doc/html/internal-preprocessor-test/internal-preprocessor-test.haddock +haddock-html: /home/ogre/Documents/other-haskell/cabal/cabal-testsuite/PackageTests/CustomPreProcess/setup.dist/work/dist/doc/html/internal-preprocessor-test +pkgroot: "/home/ogre/Documents/other-haskell/cabal/cabal-testsuite/PackageTests/CustomPreProcess/setup.dist/work/dist" + diff --git a/cabal/Cabal-tests/tests/ParserTests/ipi/internal-preprocessor-test.expr b/cabal/Cabal-tests/tests/ParserTests/ipi/internal-preprocessor-test.expr new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/ipi/internal-preprocessor-test.expr @@ -0,0 +1,76 @@ +InstalledPackageInfo { + sourcePackageId = + PackageIdentifier { + pkgName = PackageName + "internal-preprocessor-test", + pkgVersion = mkVersion + [0, 1, 0, 0]}, + sourceLibName = LMainLibName, + installedComponentId_ = + ComponentId "", + libVisibility = + LibraryVisibilityPublic, + installedUnitId = UnitId + "internal-preprocessor-test-0.1.0.0", + instantiatedWith = [], + compatPackageKey = + "internal-preprocessor-test-0.1.0.0", + license = Right + (GPL (Just (mkVersion [3]))), + copyright = "", + maintainer = + "mikhail.glushenkov@gmail.com", + author = "Mikhail Glushenkov", + stability = "", + homepage = "", + pkgUrl = "", + synopsis = + "Internal custom preprocessor example.", + description = + "See https://github.com/haskell/cabal/issues/1541#issuecomment-30155513", + category = "Testing", + abiHash = AbiHash "", + indefinite = False, + exposed = True, + exposedModules = [ + ExposedModule { + exposedName = ModuleName "A", + exposedReexport = Nothing}], + hiddenModules = [], + trusted = False, + importDirs = + [ + "/home/ogre/Documents/other-haskell/cabal/cabal-testsuite/PackageTests/CustomPreProcess/setup.dist/work/dist/build"], + libraryDirs = + [ + "/home/ogre/Documents/other-haskell/cabal/cabal-testsuite/PackageTests/CustomPreProcess/setup.dist/work/dist/build", + "/home/ogre/Documents/other-haskell/cabal/cabal-testsuite/PackageTests/CustomPreProcess/setup.dist/work/dist/build"], + libraryDirsStatic = [], + libraryDynDirs = [], + dataDir = + "/home/ogre/Documents/other-haskell/cabal/cabal-testsuite/PackageTests/CustomPreProcess", + hsLibraries = [ + "HSinternal-preprocessor-test-0.1.0.0"], + extraLibraries = [], + extraLibrariesStatic = [], + extraGHCiLibraries = [], + includeDirs = [], + includes = [], + depends = [ + UnitId + "base-4.8.2.0-0d6d1084fbc041e1cded9228e80e264d"], + abiDepends = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + frameworkDirs = [], + frameworks = [], + haddockInterfaces = + [ + "/home/ogre/Documents/other-haskell/cabal/cabal-testsuite/PackageTests/CustomPreProcess/setup.dist/work/dist/doc/html/internal-preprocessor-test/internal-preprocessor-test.haddock"], + haddockHTMLs = + [ + "/home/ogre/Documents/other-haskell/cabal/cabal-testsuite/PackageTests/CustomPreProcess/setup.dist/work/dist/doc/html/internal-preprocessor-test"], + pkgRoot = + Just + "/home/ogre/Documents/other-haskell/cabal/cabal-testsuite/PackageTests/CustomPreProcess/setup.dist/work/dist"} diff --git a/cabal/Cabal-tests/tests/ParserTests/ipi/internal-preprocessor-test.format b/cabal/Cabal-tests/tests/ParserTests/ipi/internal-preprocessor-test.format new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/ipi/internal-preprocessor-test.format @@ -0,0 +1,32 @@ +name: internal-preprocessor-test +version: 0.1.0.0 +visibility: public +id: internal-preprocessor-test-0.1.0.0 +key: internal-preprocessor-test-0.1.0.0 +license: GPL-3 +maintainer: mikhail.glushenkov@gmail.com +author: Mikhail Glushenkov +synopsis: Internal custom preprocessor example. +description: + See https://github.com/haskell/cabal/issues/1541#issuecomment-30155513 + +category: Testing +exposed: True +exposed-modules: A +import-dirs: + /home/ogre/Documents/other-haskell/cabal/cabal-testsuite/PackageTests/CustomPreProcess/setup.dist/work/dist/build + +library-dirs: + /home/ogre/Documents/other-haskell/cabal/cabal-testsuite/PackageTests/CustomPreProcess/setup.dist/work/dist/build + /home/ogre/Documents/other-haskell/cabal/cabal-testsuite/PackageTests/CustomPreProcess/setup.dist/work/dist/build + +data-dir: + /home/ogre/Documents/other-haskell/cabal/cabal-testsuite/PackageTests/CustomPreProcess + +hs-libraries: HSinternal-preprocessor-test-0.1.0.0 +depends: base-4.8.2.0-0d6d1084fbc041e1cded9228e80e264d +haddock-interfaces: + /home/ogre/Documents/other-haskell/cabal/cabal-testsuite/PackageTests/CustomPreProcess/setup.dist/work/dist/doc/html/internal-preprocessor-test/internal-preprocessor-test.haddock + +haddock-html: + /home/ogre/Documents/other-haskell/cabal/cabal-testsuite/PackageTests/CustomPreProcess/setup.dist/work/dist/doc/html/internal-preprocessor-test diff --git a/cabal/Cabal-tests/tests/ParserTests/ipi/issue-2276-ghc-9885.cabal b/cabal/Cabal-tests/tests/ParserTests/ipi/issue-2276-ghc-9885.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/ipi/issue-2276-ghc-9885.cabal @@ -0,0 +1,175 @@ +name: transformers +version: 0.5.2.0 +id: transformers-0.5.2.0 +key: transformers-0.5.2.0 +license: BSD3 +maintainer: Ross Paterson +synopsis: Concrete functor and monad transformers +description: + A portable library of functor and monad transformers, inspired by + the paper \"Functional Programming with Overloading and Higher-Order + Polymorphism\", by Mark P Jones, + in /Advanced School of Functional Programming/, 1995 + (). + . + This package contains: + . + * the monad transformer class (in "Control.Monad.Trans.Class") + and IO monad class (in "Control.Monad.IO.Class") + . + * concrete functor and monad transformers, each with associated + operations and functions to lift operations associated with other + transformers. + . + The package can be used on its own in portable Haskell code, in + which case operations need to be manually lifted through transformer + stacks (see "Control.Monad.Trans.Class" for some examples). + Alternatively, it can be used with the non-portable monad classes in + the @mtl@ or @monads-tf@ packages, which automatically lift operations + introduced by monad transformers through other transformers. +category: Control +author: Andy Gill, Ross Paterson +exposed: True +indefinite: False +exposed-modules: + Control.Applicative.Backwards Control.Applicative.Lift + Control.Monad.Signatures Control.Monad.Trans.Class + Control.Monad.Trans.Cont Control.Monad.Trans.Error + Control.Monad.Trans.Except Control.Monad.Trans.Identity + Control.Monad.Trans.List Control.Monad.Trans.Maybe + Control.Monad.Trans.RWS Control.Monad.Trans.RWS.Lazy + Control.Monad.Trans.RWS.Strict Control.Monad.Trans.Reader + Control.Monad.Trans.State Control.Monad.Trans.State.Lazy + Control.Monad.Trans.State.Strict Control.Monad.Trans.Writer + Control.Monad.Trans.Writer.Lazy Control.Monad.Trans.Writer.Strict + Data.Functor.Constant Data.Functor.Reverse +abi: e04579c0363c9229351d1a0b394bf2d5 +trusted: False +import-dirs: /opt/ghc/8.2.2/lib/ghc-8.2.2/transformers-0.5.2.0 +library-dirs: /opt/ghc/8.2.2/lib/ghc-8.2.2/transformers-0.5.2.0 +dynamic-library-dirs: /opt/ghc/8.2.2/lib/ghc-8.2.2/transformers-0.5.2.0 +data-dir: /opt/ghc/8.2.2/share/x86_64-linux-ghc-8.2.2/transformers-0.5.2.0 +hs-libraries: HStransformers-0.5.2.0 +depends: + base-4.10.1.0 +abi-depends: base-4.10.1.0=35a7f6be752ee4f7385cb5bf28677879 +haddock-interfaces: /opt/ghc/8.2.2/share/doc/ghc-8.2.2/html/libraries/transformers-0.5.2.0/transformers.haddock +haddock-html: /opt/ghc/8.2.2/share/doc/ghc-8.2.2/html/libraries/transformers-0.5.2.0 +ld-options: -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm diff --git a/cabal/Cabal-tests/tests/ParserTests/ipi/issue-2276-ghc-9885.expr b/cabal/Cabal-tests/tests/ParserTests/ipi/issue-2276-ghc-9885.expr new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/ipi/issue-2276-ghc-9885.expr @@ -0,0 +1,2184 @@ +InstalledPackageInfo { + sourcePackageId = + PackageIdentifier { + pkgName = PackageName + "transformers", + pkgVersion = mkVersion + [0, 5, 2, 0]}, + sourceLibName = LMainLibName, + installedComponentId_ = + ComponentId "", + libVisibility = + LibraryVisibilityPublic, + installedUnitId = UnitId + "transformers-0.5.2.0", + instantiatedWith = [], + compatPackageKey = + "transformers-0.5.2.0", + license = Right BSD3, + copyright = "", + maintainer = + "Ross Paterson ", + author = + "Andy Gill, Ross Paterson", + stability = "", + homepage = "", + pkgUrl = "", + synopsis = + "Concrete functor and monad transformers", + description = + concat + [ + "A portable library of functor and monad transformers, inspired by\n", + "the paper \\\"Functional Programming with Overloading and Higher-Order\n", + "Polymorphism\\\", by Mark P Jones,\n", + "in /Advanced School of Functional Programming/, 1995\n", + "().\n", + ".\n", + "This package contains:\n", + ".\n", + "* the monad transformer class (in \"Control.Monad.Trans.Class\")\n", + "and IO monad class (in \"Control.Monad.IO.Class\")\n", + ".\n", + "* concrete functor and monad transformers, each with associated\n", + "operations and functions to lift operations associated with other\n", + "transformers.\n", + ".\n", + "The package can be used on its own in portable Haskell code, in\n", + "which case operations need to be manually lifted through transformer\n", + "stacks (see \"Control.Monad.Trans.Class\" for some examples).\n", + "Alternatively, it can be used with the non-portable monad classes in\n", + "the @mtl@ or @monads-tf@ packages, which automatically lift operations\n", + "introduced by monad transformers through other transformers."], + category = "Control", + abiHash = AbiHash + "e04579c0363c9229351d1a0b394bf2d5", + indefinite = False, + exposed = True, + exposedModules = [ + ExposedModule { + exposedName = ModuleName + "Control.Applicative.Backwards", + exposedReexport = Nothing}, + ExposedModule { + exposedName = ModuleName + "Control.Applicative.Lift", + exposedReexport = Nothing}, + ExposedModule { + exposedName = ModuleName + "Control.Monad.Signatures", + exposedReexport = Nothing}, + ExposedModule { + exposedName = ModuleName + "Control.Monad.Trans.Class", + exposedReexport = Nothing}, + ExposedModule { + exposedName = ModuleName + "Control.Monad.Trans.Cont", + exposedReexport = Nothing}, + ExposedModule { + exposedName = ModuleName + "Control.Monad.Trans.Error", + exposedReexport = Nothing}, + ExposedModule { + exposedName = ModuleName + "Control.Monad.Trans.Except", + exposedReexport = Nothing}, + ExposedModule { + exposedName = ModuleName + "Control.Monad.Trans.Identity", + exposedReexport = Nothing}, + ExposedModule { + exposedName = ModuleName + "Control.Monad.Trans.List", + exposedReexport = Nothing}, + ExposedModule { + exposedName = ModuleName + "Control.Monad.Trans.Maybe", + exposedReexport = Nothing}, + ExposedModule { + exposedName = ModuleName + "Control.Monad.Trans.RWS", + exposedReexport = Nothing}, + ExposedModule { + exposedName = ModuleName + "Control.Monad.Trans.RWS.Lazy", + exposedReexport = Nothing}, + ExposedModule { + exposedName = ModuleName + "Control.Monad.Trans.RWS.Strict", + exposedReexport = Nothing}, + ExposedModule { + exposedName = ModuleName + "Control.Monad.Trans.Reader", + exposedReexport = Nothing}, + ExposedModule { + exposedName = ModuleName + "Control.Monad.Trans.State", + exposedReexport = Nothing}, + ExposedModule { + exposedName = ModuleName + "Control.Monad.Trans.State.Lazy", + exposedReexport = Nothing}, + ExposedModule { + exposedName = ModuleName + "Control.Monad.Trans.State.Strict", + exposedReexport = Nothing}, + ExposedModule { + exposedName = ModuleName + "Control.Monad.Trans.Writer", + exposedReexport = Nothing}, + ExposedModule { + exposedName = ModuleName + "Control.Monad.Trans.Writer.Lazy", + exposedReexport = Nothing}, + ExposedModule { + exposedName = ModuleName + "Control.Monad.Trans.Writer.Strict", + exposedReexport = Nothing}, + ExposedModule { + exposedName = ModuleName + "Data.Functor.Constant", + exposedReexport = Nothing}, + ExposedModule { + exposedName = ModuleName + "Data.Functor.Reverse", + exposedReexport = Nothing}], + hiddenModules = [], + trusted = False, + importDirs = [ + "/opt/ghc/8.2.2/lib/ghc-8.2.2/transformers-0.5.2.0"], + libraryDirs = [ + "/opt/ghc/8.2.2/lib/ghc-8.2.2/transformers-0.5.2.0"], + libraryDirsStatic = [], + libraryDynDirs = [ + "/opt/ghc/8.2.2/lib/ghc-8.2.2/transformers-0.5.2.0"], + dataDir = + "/opt/ghc/8.2.2/share/x86_64-linux-ghc-8.2.2/transformers-0.5.2.0", + hsLibraries = [ + "HStransformers-0.5.2.0"], + extraLibraries = [], + extraLibrariesStatic = [], + extraGHCiLibraries = [], + includeDirs = [], + includes = [], + depends = [ + UnitId "base-4.10.1.0"], + abiDepends = [ + AbiDependency { + depUnitId = UnitId + "base-4.10.1.0", + depAbiHash = AbiHash + "35a7f6be752ee4f7385cb5bf28677879"}], + ccOptions = [], + cxxOptions = [], + ldOptions = [ + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm", + "-lm"], + frameworkDirs = [], + frameworks = [], + haddockInterfaces = + [ + "/opt/ghc/8.2.2/share/doc/ghc-8.2.2/html/libraries/transformers-0.5.2.0/transformers.haddock"], + haddockHTMLs = [ + "/opt/ghc/8.2.2/share/doc/ghc-8.2.2/html/libraries/transformers-0.5.2.0"], + pkgRoot = Nothing} diff --git a/cabal/Cabal-tests/tests/ParserTests/ipi/issue-2276-ghc-9885.format b/cabal/Cabal-tests/tests/ParserTests/ipi/issue-2276-ghc-9885.format new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/ipi/issue-2276-ghc-9885.format @@ -0,0 +1,182 @@ +name: transformers +version: 0.5.2.0 +visibility: public +id: transformers-0.5.2.0 +key: transformers-0.5.2.0 +license: BSD3 +maintainer: Ross Paterson +author: Andy Gill, Ross Paterson +synopsis: Concrete functor and monad transformers +description: + A portable library of functor and monad transformers, inspired by + the paper \"Functional Programming with Overloading and Higher-Order + Polymorphism\", by Mark P Jones, + in /Advanced School of Functional Programming/, 1995 + (). + . + This package contains: + . + * the monad transformer class (in "Control.Monad.Trans.Class") + and IO monad class (in "Control.Monad.IO.Class") + . + * concrete functor and monad transformers, each with associated + operations and functions to lift operations associated with other + transformers. + . + The package can be used on its own in portable Haskell code, in + which case operations need to be manually lifted through transformer + stacks (see "Control.Monad.Trans.Class" for some examples). + Alternatively, it can be used with the non-portable monad classes in + the @mtl@ or @monads-tf@ packages, which automatically lift operations + introduced by monad transformers through other transformers. + +category: Control +abi: e04579c0363c9229351d1a0b394bf2d5 +exposed: True +exposed-modules: + Control.Applicative.Backwards Control.Applicative.Lift + Control.Monad.Signatures Control.Monad.Trans.Class + Control.Monad.Trans.Cont Control.Monad.Trans.Error + Control.Monad.Trans.Except Control.Monad.Trans.Identity + Control.Monad.Trans.List Control.Monad.Trans.Maybe + Control.Monad.Trans.RWS Control.Monad.Trans.RWS.Lazy + Control.Monad.Trans.RWS.Strict Control.Monad.Trans.Reader + Control.Monad.Trans.State Control.Monad.Trans.State.Lazy + Control.Monad.Trans.State.Strict Control.Monad.Trans.Writer + Control.Monad.Trans.Writer.Lazy Control.Monad.Trans.Writer.Strict + Data.Functor.Constant Data.Functor.Reverse + +import-dirs: /opt/ghc/8.2.2/lib/ghc-8.2.2/transformers-0.5.2.0 +library-dirs: /opt/ghc/8.2.2/lib/ghc-8.2.2/transformers-0.5.2.0 +dynamic-library-dirs: /opt/ghc/8.2.2/lib/ghc-8.2.2/transformers-0.5.2.0 +data-dir: + /opt/ghc/8.2.2/share/x86_64-linux-ghc-8.2.2/transformers-0.5.2.0 + +hs-libraries: HStransformers-0.5.2.0 +depends: base-4.10.1.0 +abi-depends: base-4.10.1.0=35a7f6be752ee4f7385cb5bf28677879 +ld-options: + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm -lm + +haddock-interfaces: + /opt/ghc/8.2.2/share/doc/ghc-8.2.2/html/libraries/transformers-0.5.2.0/transformers.haddock + +haddock-html: + /opt/ghc/8.2.2/share/doc/ghc-8.2.2/html/libraries/transformers-0.5.2.0 diff --git a/cabal/Cabal-tests/tests/ParserTests/ipi/transformers.cabal b/cabal/Cabal-tests/tests/ParserTests/ipi/transformers.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/ipi/transformers.cabal @@ -0,0 +1,59 @@ +name: transformers +version: 0.5.2.0 +id: transformers-0.5.2.0 +key: transformers-0.5.2.0 +license: BSD3 +maintainer: Ross Paterson +synopsis: Concrete functor and monad transformers +description: + A portable library of functor and monad transformers, inspired by + the paper \"Functional Programming with Overloading and Higher-Order + Polymorphism\", by Mark P Jones, + in /Advanced School of Functional Programming/, 1995 + (). + . + This package contains: + . + * the monad transformer class (in "Control.Monad.Trans.Class") + and IO monad class (in "Control.Monad.IO.Class") + . + * concrete functor and monad transformers, each with associated + operations and functions to lift operations associated with other + transformers. + . + The package can be used on its own in portable Haskell code, in + which case operations need to be manually lifted through transformer + stacks (see "Control.Monad.Trans.Class" for some examples). + Alternatively, it can be used with the non-portable monad classes in + the @mtl@ or @monads-tf@ packages, which automatically lift operations + introduced by monad transformers through other transformers. +category: Control +author: Andy Gill, Ross Paterson +exposed: True +indefinite: False +exposed-modules: + Control.Applicative.Backwards Control.Applicative.Lift + Control.Monad.Signatures Control.Monad.Trans.Class + Control.Monad.Trans.Cont Control.Monad.Trans.Error + Control.Monad.Trans.Except Control.Monad.Trans.Identity + Control.Monad.Trans.List Control.Monad.Trans.Maybe + Control.Monad.Trans.RWS Control.Monad.Trans.RWS.Lazy + Control.Monad.Trans.RWS.Strict Control.Monad.Trans.Reader + Control.Monad.Trans.State Control.Monad.Trans.State.Lazy + Control.Monad.Trans.State.Strict Control.Monad.Trans.Writer + Control.Monad.Trans.Writer.Lazy Control.Monad.Trans.Writer.Strict + Data.Functor.Constant Data.Functor.Reverse +abi: e04579c0363c9229351d1a0b394bf2d5 +trusted: False +import-dirs: /opt/ghc/8.2.2/lib/ghc-8.2.2/transformers-0.5.2.0 +library-dirs: /opt/ghc/8.2.2/lib/ghc-8.2.2/transformers-0.5.2.0 +dynamic-library-dirs: /opt/ghc/8.2.2/lib/ghc-8.2.2/transformers-0.5.2.0 +data-dir: /opt/ghc/8.2.2/share/x86_64-linux-ghc-8.2.2/transformers-0.5.2.0 +hs-libraries: HStransformers-0.5.2.0 +depends: + base-4.10.1.0 +abi-depends: base-4.10.1.0=35a7f6be752ee4f7385cb5bf28677879 +haddock-interfaces: /opt/ghc/8.2.2/share/doc/ghc-8.2.2/html/libraries/transformers-0.5.2.0/transformers.haddock +haddock-html: /opt/ghc/8.2.2/share/doc/ghc-8.2.2/html/libraries/transformers-0.5.2.0 +pkgroot: "/opt/ghc/8.2.2/lib/ghc-8.2.2" + diff --git a/cabal/Cabal-tests/tests/ParserTests/ipi/transformers.expr b/cabal/Cabal-tests/tests/ParserTests/ipi/transformers.expr new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/ipi/transformers.expr @@ -0,0 +1,184 @@ +InstalledPackageInfo { + sourcePackageId = + PackageIdentifier { + pkgName = PackageName + "transformers", + pkgVersion = mkVersion + [0, 5, 2, 0]}, + sourceLibName = LMainLibName, + installedComponentId_ = + ComponentId "", + libVisibility = + LibraryVisibilityPublic, + installedUnitId = UnitId + "transformers-0.5.2.0", + instantiatedWith = [], + compatPackageKey = + "transformers-0.5.2.0", + license = Right BSD3, + copyright = "", + maintainer = + "Ross Paterson ", + author = + "Andy Gill, Ross Paterson", + stability = "", + homepage = "", + pkgUrl = "", + synopsis = + "Concrete functor and monad transformers", + description = + concat + [ + "A portable library of functor and monad transformers, inspired by\n", + "the paper \\\"Functional Programming with Overloading and Higher-Order\n", + "Polymorphism\\\", by Mark P Jones,\n", + "in /Advanced School of Functional Programming/, 1995\n", + "().\n", + ".\n", + "This package contains:\n", + ".\n", + "* the monad transformer class (in \"Control.Monad.Trans.Class\")\n", + "and IO monad class (in \"Control.Monad.IO.Class\")\n", + ".\n", + "* concrete functor and monad transformers, each with associated\n", + "operations and functions to lift operations associated with other\n", + "transformers.\n", + ".\n", + "The package can be used on its own in portable Haskell code, in\n", + "which case operations need to be manually lifted through transformer\n", + "stacks (see \"Control.Monad.Trans.Class\" for some examples).\n", + "Alternatively, it can be used with the non-portable monad classes in\n", + "the @mtl@ or @monads-tf@ packages, which automatically lift operations\n", + "introduced by monad transformers through other transformers."], + category = "Control", + abiHash = AbiHash + "e04579c0363c9229351d1a0b394bf2d5", + indefinite = False, + exposed = True, + exposedModules = [ + ExposedModule { + exposedName = ModuleName + "Control.Applicative.Backwards", + exposedReexport = Nothing}, + ExposedModule { + exposedName = ModuleName + "Control.Applicative.Lift", + exposedReexport = Nothing}, + ExposedModule { + exposedName = ModuleName + "Control.Monad.Signatures", + exposedReexport = Nothing}, + ExposedModule { + exposedName = ModuleName + "Control.Monad.Trans.Class", + exposedReexport = Nothing}, + ExposedModule { + exposedName = ModuleName + "Control.Monad.Trans.Cont", + exposedReexport = Nothing}, + ExposedModule { + exposedName = ModuleName + "Control.Monad.Trans.Error", + exposedReexport = Nothing}, + ExposedModule { + exposedName = ModuleName + "Control.Monad.Trans.Except", + exposedReexport = Nothing}, + ExposedModule { + exposedName = ModuleName + "Control.Monad.Trans.Identity", + exposedReexport = Nothing}, + ExposedModule { + exposedName = ModuleName + "Control.Monad.Trans.List", + exposedReexport = Nothing}, + ExposedModule { + exposedName = ModuleName + "Control.Monad.Trans.Maybe", + exposedReexport = Nothing}, + ExposedModule { + exposedName = ModuleName + "Control.Monad.Trans.RWS", + exposedReexport = Nothing}, + ExposedModule { + exposedName = ModuleName + "Control.Monad.Trans.RWS.Lazy", + exposedReexport = Nothing}, + ExposedModule { + exposedName = ModuleName + "Control.Monad.Trans.RWS.Strict", + exposedReexport = Nothing}, + ExposedModule { + exposedName = ModuleName + "Control.Monad.Trans.Reader", + exposedReexport = Nothing}, + ExposedModule { + exposedName = ModuleName + "Control.Monad.Trans.State", + exposedReexport = Nothing}, + ExposedModule { + exposedName = ModuleName + "Control.Monad.Trans.State.Lazy", + exposedReexport = Nothing}, + ExposedModule { + exposedName = ModuleName + "Control.Monad.Trans.State.Strict", + exposedReexport = Nothing}, + ExposedModule { + exposedName = ModuleName + "Control.Monad.Trans.Writer", + exposedReexport = Nothing}, + ExposedModule { + exposedName = ModuleName + "Control.Monad.Trans.Writer.Lazy", + exposedReexport = Nothing}, + ExposedModule { + exposedName = ModuleName + "Control.Monad.Trans.Writer.Strict", + exposedReexport = Nothing}, + ExposedModule { + exposedName = ModuleName + "Data.Functor.Constant", + exposedReexport = Nothing}, + ExposedModule { + exposedName = ModuleName + "Data.Functor.Reverse", + exposedReexport = Nothing}], + hiddenModules = [], + trusted = False, + importDirs = [ + "/opt/ghc/8.2.2/lib/ghc-8.2.2/transformers-0.5.2.0"], + libraryDirs = [ + "/opt/ghc/8.2.2/lib/ghc-8.2.2/transformers-0.5.2.0"], + libraryDirsStatic = [], + libraryDynDirs = [ + "/opt/ghc/8.2.2/lib/ghc-8.2.2/transformers-0.5.2.0"], + dataDir = + "/opt/ghc/8.2.2/share/x86_64-linux-ghc-8.2.2/transformers-0.5.2.0", + hsLibraries = [ + "HStransformers-0.5.2.0"], + extraLibraries = [], + extraLibrariesStatic = [], + extraGHCiLibraries = [], + includeDirs = [], + includes = [], + depends = [ + UnitId "base-4.10.1.0"], + abiDepends = [ + AbiDependency { + depUnitId = UnitId + "base-4.10.1.0", + depAbiHash = AbiHash + "35a7f6be752ee4f7385cb5bf28677879"}], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + frameworkDirs = [], + frameworks = [], + haddockInterfaces = + [ + "/opt/ghc/8.2.2/share/doc/ghc-8.2.2/html/libraries/transformers-0.5.2.0/transformers.haddock"], + haddockHTMLs = [ + "/opt/ghc/8.2.2/share/doc/ghc-8.2.2/html/libraries/transformers-0.5.2.0"], + pkgRoot = Just + "/opt/ghc/8.2.2/lib/ghc-8.2.2"} diff --git a/cabal/Cabal-tests/tests/ParserTests/ipi/transformers.format b/cabal/Cabal-tests/tests/ParserTests/ipi/transformers.format new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/ipi/transformers.format @@ -0,0 +1,62 @@ +name: transformers +version: 0.5.2.0 +visibility: public +id: transformers-0.5.2.0 +key: transformers-0.5.2.0 +license: BSD3 +maintainer: Ross Paterson +author: Andy Gill, Ross Paterson +synopsis: Concrete functor and monad transformers +description: + A portable library of functor and monad transformers, inspired by + the paper \"Functional Programming with Overloading and Higher-Order + Polymorphism\", by Mark P Jones, + in /Advanced School of Functional Programming/, 1995 + (). + . + This package contains: + . + * the monad transformer class (in "Control.Monad.Trans.Class") + and IO monad class (in "Control.Monad.IO.Class") + . + * concrete functor and monad transformers, each with associated + operations and functions to lift operations associated with other + transformers. + . + The package can be used on its own in portable Haskell code, in + which case operations need to be manually lifted through transformer + stacks (see "Control.Monad.Trans.Class" for some examples). + Alternatively, it can be used with the non-portable monad classes in + the @mtl@ or @monads-tf@ packages, which automatically lift operations + introduced by monad transformers through other transformers. + +category: Control +abi: e04579c0363c9229351d1a0b394bf2d5 +exposed: True +exposed-modules: + Control.Applicative.Backwards Control.Applicative.Lift + Control.Monad.Signatures Control.Monad.Trans.Class + Control.Monad.Trans.Cont Control.Monad.Trans.Error + Control.Monad.Trans.Except Control.Monad.Trans.Identity + Control.Monad.Trans.List Control.Monad.Trans.Maybe + Control.Monad.Trans.RWS Control.Monad.Trans.RWS.Lazy + Control.Monad.Trans.RWS.Strict Control.Monad.Trans.Reader + Control.Monad.Trans.State Control.Monad.Trans.State.Lazy + Control.Monad.Trans.State.Strict Control.Monad.Trans.Writer + Control.Monad.Trans.Writer.Lazy Control.Monad.Trans.Writer.Strict + Data.Functor.Constant Data.Functor.Reverse + +import-dirs: /opt/ghc/8.2.2/lib/ghc-8.2.2/transformers-0.5.2.0 +library-dirs: /opt/ghc/8.2.2/lib/ghc-8.2.2/transformers-0.5.2.0 +dynamic-library-dirs: /opt/ghc/8.2.2/lib/ghc-8.2.2/transformers-0.5.2.0 +data-dir: + /opt/ghc/8.2.2/share/x86_64-linux-ghc-8.2.2/transformers-0.5.2.0 + +hs-libraries: HStransformers-0.5.2.0 +depends: base-4.10.1.0 +abi-depends: base-4.10.1.0=35a7f6be752ee4f7385cb5bf28677879 +haddock-interfaces: + /opt/ghc/8.2.2/share/doc/ghc-8.2.2/html/libraries/transformers-0.5.2.0/transformers.haddock + +haddock-html: + /opt/ghc/8.2.2/share/doc/ghc-8.2.2/html/libraries/transformers-0.5.2.0 diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/Octree-0.5.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/Octree-0.5.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/Octree-0.5.cabal @@ -0,0 +1,44 @@ +name: Octree +version: 0.5 +stability: beta +homepage: https://github.com/mgajda/octree +package-url: http://hackage.haskell.org/package/octree +synopsis: Simple unbalanced Octree for storing data about 3D points +description: Octree data structure is relatively shallow data structure for space partitioning. +category: Data +license: BSD3 +license-file: LICENSE + +author: Michal J. Gajda +copyright: Copyright by Michal J. Gajda '2012 +maintainer: mjgajda@googlemail.com +bug-reports: mailto:mjgajda@googlemail.com + + +build-type: Simple +cabal-version: >=1.8 +tested-with: GHC==7.0.4,GHC==7.4.1,GHC==7.4.2,GHC==7.6.0 + +source-repository head + type: git + location: git@github.com:mgajda/octree.git + +Library + build-depends: base>=4.0 && < 4.7, AC-Vector >= 2.3.0, QuickCheck >= 2.4.0 + exposed-modules: Data.Octree + other-modules: Data.Octree.Internal + exposed: True + extensions: ScopedTypeVariables + +Test-suite test_Octree + Type: exitcode-stdio-1.0 + Build-depends: base>=4.0 && < 4.7, AC-Vector >= 2.3.0, QuickCheck >= 2.4.0 + Main-is: tests/test_Octree.hs + +Test-suite readme +  type: exitcode-stdio-1.0 + -- We have a symlink: README.lhs -> README.md +  main-is: README.lhs + Build-depends: base>=4.0 && < 4.7, AC-Vector >= 2.3.0, QuickCheck >= 2.4.0, markdown-unlit +  ghc-options: -pgmL markdown-unlit + diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/Octree-0.5.expr b/cabal/Cabal-tests/tests/ParserTests/regressions/Octree-0.5.expr new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/Octree-0.5.expr @@ -0,0 +1,393 @@ +GenericPackageDescription { + packageDescription = + PackageDescription { + specVersion = CabalSpecV1_8, + package = PackageIdentifier { + pkgName = PackageName "Octree", + pkgVersion = mkVersion [0, 5]}, + licenseRaw = Right BSD3, + licenseFiles = [ + SymbolicPath "LICENSE"], + copyright = + "Copyright by Michal J. Gajda '2012", + maintainer = + "mjgajda@googlemail.com", + author = "Michal J. Gajda", + stability = "beta", + testedWith = [ + _×_ + GHC + (ThisVersion + (mkVersion [7, 0, 4])), + _×_ + GHC + (ThisVersion + (mkVersion [7, 4, 1])), + _×_ + GHC + (ThisVersion + (mkVersion [7, 4, 2])), + _×_ + GHC + (ThisVersion + (mkVersion [7, 6, 0]))], + homepage = + "https://github.com/mgajda/octree", + pkgUrl = + "http://hackage.haskell.org/package/octree", + bugReports = + "mailto:mjgajda@googlemail.com", + sourceRepos = [ + SourceRepo { + repoKind = RepoHead, + repoType = Just + (KnownRepoType Git), + repoLocation = Just + "git@github.com:mgajda/octree.git", + repoModule = Nothing, + repoBranch = Nothing, + repoTag = Nothing, + repoSubdir = Nothing}], + synopsis = + "Simple unbalanced Octree for storing data about 3D points", + description = + "Octree data structure is relatively shallow data structure for space partitioning.", + category = "Data", + customFieldsPD = [], + buildTypeRaw = Just Simple, + setupBuildInfo = Nothing, + library = Nothing, + subLibraries = [], + executables = [], + foreignLibs = [], + testSuites = [], + benchmarks = [], + dataFiles = [], + dataDir = ".", + extraSrcFiles = [], + extraTmpFiles = [], + extraDocFiles = []}, + gpdScannedVersion = Nothing, + genPackageFlags = [], + condLibrary = Just + CondNode { + condTreeData = Library { + libName = LMainLibName, + exposedModules = [ + ModuleName "Data.Octree"], + reexportedModules = [], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPublic, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [ + ModuleName + "Data.Octree.Internal"], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [ + EnableExtension + ScopedTypeVariables], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + 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], + 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 = [], + condExecutables = [], + condTestSuites = [ + _×_ + (UnqualComponentName + "test_Octree") + CondNode { + condTreeData = TestSuite { + testName = UnqualComponentName + "", + testInterface = TestSuiteExeV10 + (mkVersion [1, 0]) + "tests/test_Octree.hs", + testBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + 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], + 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") + CondNode { + condTreeData = TestSuite { + testName = UnqualComponentName + "", + testInterface = TestSuiteExeV10 + (mkVersion [1, 0]) + "README.lhs", + testBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + ["-pgmL", "markdown-unlit"] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + 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], + 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/Cabal-tests/tests/ParserTests/regressions/Octree-0.5.format b/cabal/Cabal-tests/tests/ParserTests/regressions/Octree-0.5.format new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/Octree-0.5.format @@ -0,0 +1,51 @@ +Octree-0.5.cabal:39:3: Non breaking spaces at 39:3, 41:3, 43:3 +cabal-version: >=1.8 +name: Octree +version: 0.5 +license: BSD3 +license-file: LICENSE +copyright: Copyright by Michal J. Gajda '2012 +maintainer: mjgajda@googlemail.com +author: Michal J. Gajda +stability: beta +tested-with: ghc ==7.0.4 ghc ==7.4.1 ghc ==7.4.2 ghc ==7.6.0 +homepage: https://github.com/mgajda/octree +package-url: http://hackage.haskell.org/package/octree +bug-reports: mailto:mjgajda@googlemail.com +synopsis: Simple unbalanced Octree for storing data about 3D points +description: + Octree data structure is relatively shallow data structure for space partitioning. + +category: Data +build-type: Simple + +source-repository head + type: git + location: git@github.com:mgajda/octree.git + +library + exposed-modules: Data.Octree + other-modules: Data.Octree.Internal + extensions: ScopedTypeVariables + build-depends: + base >=4.0 && <4.7, + AC-Vector >=2.3.0, + QuickCheck >=2.4.0 + +test-suite test_Octree + type: exitcode-stdio-1.0 + main-is: tests/test_Octree.hs + build-depends: + base >=4.0 && <4.7, + AC-Vector >=2.3.0, + QuickCheck >=2.4.0 + +test-suite readme + type: exitcode-stdio-1.0 + main-is: README.lhs + ghc-options: -pgmL markdown-unlit + build-depends: + base >=4.0 && <4.7, + AC-Vector >=2.3.0, + QuickCheck >=2.4.0, + markdown-unlit diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/anynone.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/anynone.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/anynone.cabal @@ -0,0 +1,10 @@ +cabal-version: 3.0 +name: anynone +version: 0 +synopsis: The -any none demo +build-type: Simple + +library + default-language: Haskell2010 + exposed-modules: AnyNone + build-depends: base -any diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/anynone.expr b/cabal/Cabal-tests/tests/ParserTests/regressions/anynone.expr new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/anynone.expr @@ -0,0 +1,117 @@ +GenericPackageDescription { + packageDescription = + PackageDescription { + specVersion = CabalSpecV3_0, + package = PackageIdentifier { + pkgName = PackageName "anynone", + pkgVersion = mkVersion [0]}, + licenseRaw = Left NONE, + licenseFiles = [], + copyright = "", + maintainer = "", + author = "", + stability = "", + testedWith = [], + homepage = "", + pkgUrl = "", + bugReports = "", + sourceRepos = [], + synopsis = "The -any none demo", + description = "", + category = "", + customFieldsPD = [], + buildTypeRaw = Just Simple, + setupBuildInfo = Nothing, + library = Nothing, + subLibraries = [], + executables = [], + foreignLibs = [], + testSuites = [], + benchmarks = [], + dataFiles = [], + dataDir = ".", + extraSrcFiles = [], + extraTmpFiles = [], + extraDocFiles = []}, + gpdScannedVersion = Nothing, + genPackageFlags = [], + condLibrary = Just + CondNode { + condTreeData = Library { + libName = LMainLibName, + exposedModules = [ + ModuleName "AnyNone"], + reexportedModules = [], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPublic, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Just + Haskell2010, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + Dependency + (PackageName "base") + (OrLaterVersion (mkVersion [0])) + mainLibSet], + mixins = []}}, + condTreeConstraints = [ + Dependency + (PackageName "base") + (OrLaterVersion (mkVersion [0])) + mainLibSet], + condTreeComponents = []}, + condSubLibraries = [], + condForeignLibs = [], + condExecutables = [], + condTestSuites = [], + condBenchmarks = []} diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/anynone.format b/cabal/Cabal-tests/tests/ParserTests/regressions/anynone.format new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/anynone.format @@ -0,0 +1,10 @@ +cabal-version: 3.0 +name: anynone +version: 0 +synopsis: The -any none demo +build-type: Simple + +library + exposed-modules: AnyNone + default-language: Haskell2010 + build-depends: base diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/assoc-cpp-options.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/assoc-cpp-options.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/assoc-cpp-options.cabal @@ -0,0 +1,48 @@ +cabal-version: 1.12 +name: assoc +version: 1.1 +license: BSD3 +license-file: LICENSE +synopsis: swap and assoc: Symmetric and Semigroupy Bifunctors +category: Data +description: + Provides generalisations of + @swap :: (a,b) -> (b,a)@ and + @assoc :: ((a,b),c) -> (a,(b,c))@ + to + @Bifunctor@s supporting similar operations (e.g. @Either@, @These@). + +author: Oleg Grenrus +maintainer: Oleg Grenrus +build-type: Simple +tested-with: + GHC ==7.0.4 + || ==7.2.2 + || ==7.4.2 + || ==7.6.3 + || ==7.8.4 + || ==7.10.3 + || ==8.0.2 + || ==8.2.2 + || ==8.4.4 + || ==8.6.5 + || ==8.8.1 + +source-repository head + type: git + location: https://github.com/phadej/assoc.git + +library + default-language: Haskell2010 + hs-source-dirs: src + build-depends: + base >=4.3 && <4.13 + , bifunctors >=5.5.4 && <5.6 + + cpp-options: -traditional + + exposed-modules: + Data.Bifunctor.Assoc + Data.Bifunctor.Swap + + other-extensions: TypeFamilies diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/assoc-cpp-options.check b/cabal/Cabal-tests/tests/ParserTests/regressions/assoc-cpp-options.check new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/assoc-cpp-options.check @@ -0,0 +1,1 @@ +'cpp-options: -traditional' is not a portable C-preprocessor flag. diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/bad-glob-syntax.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/bad-glob-syntax.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/bad-glob-syntax.cabal @@ -0,0 +1,16 @@ +cabal-version: 2.2 +name: bad-glob-syntax +version: 0 +extra-source-files: + foo/blah-*.hs + foo/*/bar +license: BSD-3-Clause +synopsis: no +description: none +category: Test +maintainer: none + +library + default-language: Haskell2010 + exposed-modules: + Foo diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/bad-glob-syntax.check b/cabal/Cabal-tests/tests/ParserTests/regressions/bad-glob-syntax.check new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/bad-glob-syntax.check @@ -0,0 +1,2 @@ +In the 'extra-source-files' field: invalid file glob 'foo/blah-*.hs'. Wildcards '*' may only totally replace the file's base name, not only parts of it. +In the 'extra-source-files' field: invalid file glob 'foo/*/bar'. A wildcard '**' is only allowed as the final parent directory. Stars must not otherwise appear in the parent directories. diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/big-version.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/big-version.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/big-version.cabal @@ -0,0 +1,7 @@ +cabal-version: 3.0 +name: big-version +-- 9 digits +version: 123456789 + +library + default-language: Haskell2010 diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/big-version.expr b/cabal/Cabal-tests/tests/ParserTests/regressions/big-version.expr new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/big-version.expr @@ -0,0 +1,110 @@ +GenericPackageDescription { + packageDescription = + PackageDescription { + specVersion = CabalSpecV3_0, + package = PackageIdentifier { + pkgName = PackageName + "big-version", + pkgVersion = mkVersion + [123456789]}, + licenseRaw = Left NONE, + licenseFiles = [], + copyright = "", + maintainer = "", + author = "", + stability = "", + testedWith = [], + homepage = "", + pkgUrl = "", + bugReports = "", + sourceRepos = [], + synopsis = "", + description = "", + category = "", + customFieldsPD = [], + buildTypeRaw = Nothing, + setupBuildInfo = Nothing, + library = Nothing, + subLibraries = [], + executables = [], + foreignLibs = [], + testSuites = [], + benchmarks = [], + dataFiles = [], + dataDir = ".", + extraSrcFiles = [], + extraTmpFiles = [], + extraDocFiles = []}, + gpdScannedVersion = Nothing, + genPackageFlags = [], + condLibrary = Just + CondNode { + condTreeData = Library { + libName = LMainLibName, + exposedModules = [], + reexportedModules = [], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPublic, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Just + Haskell2010, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [], + mixins = []}}, + condTreeConstraints = [], + condTreeComponents = []}, + condSubLibraries = [], + condForeignLibs = [], + condExecutables = [], + condTestSuites = [], + condBenchmarks = []} diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/big-version.format b/cabal/Cabal-tests/tests/ParserTests/regressions/big-version.format new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/big-version.format @@ -0,0 +1,6 @@ +cabal-version: 3.0 +name: big-version +version: 123456789 + +library + default-language: Haskell2010 diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/cc-options-with-optimization.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/cc-options-with-optimization.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/cc-options-with-optimization.cabal @@ -0,0 +1,15 @@ +cabal-version: 2.2 +category: test +description: test a build check involving C++-options field +license: BSD-3-Clause +maintainer: me@example.com +name: cxx-options-with-optimization +synopsis: test a build check +version: 1 + +library + build-depends: base >= 4.9 && <4.10 + cc-options: -O2 + default-language: Haskell2010 + exposed-modules: Prelude + hs-source-dirs: . diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/cc-options-with-optimization.check b/cabal/Cabal-tests/tests/ParserTests/regressions/cc-options-with-optimization.check new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/cc-options-with-optimization.check @@ -0,0 +1,1 @@ +'cc-options: -O[n]' is generally not needed. When building with optimisations Cabal automatically adds '-O2' for C code. Setting it yourself interferes with the --disable-optimization flag. diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/common-conditional.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/common-conditional.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/common-conditional.cabal @@ -0,0 +1,49 @@ +cabal-version: 3.0 +name: common-conditional +version: 0 +synopsis: Common-stanza demo demo +build-type: Simple + +source-repository head + Type: git + Location: https://github.com/hvr/-.git + +flag foo + manual: True + default: True + +common win-dows + if os(windows) + build-depends: Win32 + +common deps + import: win-dows + buildable: True + build-depends: + base >=4.10 && <4.11, + containers + +library + if flag(foo) + import: deps + + default-language: Haskell2010 + exposed-modules: ElseIf + + build-depends: + ghc-prim + +test-suite tests + -- buildable fields verify that we don't have duplicate field warnings + buildable: True + if os(windows) + buildable: False + + if flag(foo) + import: deps, win-dows + + type: exitcode-stdio-1.0 + main-is: Tests.hs + + build-depends: + HUnit diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/common-conditional.expr b/cabal/Cabal-tests/tests/ParserTests/regressions/common-conditional.expr new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/common-conditional.expr @@ -0,0 +1,691 @@ +GenericPackageDescription { + packageDescription = + PackageDescription { + specVersion = CabalSpecV3_0, + package = PackageIdentifier { + pkgName = PackageName + "common-conditional", + pkgVersion = mkVersion [0]}, + licenseRaw = Left NONE, + licenseFiles = [], + copyright = "", + maintainer = "", + author = "", + stability = "", + testedWith = [], + homepage = "", + pkgUrl = "", + bugReports = "", + sourceRepos = [ + SourceRepo { + repoKind = RepoHead, + repoType = Just + (KnownRepoType Git), + repoLocation = Just + "https://github.com/hvr/-.git", + repoModule = Nothing, + repoBranch = Nothing, + repoTag = Nothing, + repoSubdir = Nothing}], + synopsis = + "Common-stanza demo demo", + description = "", + category = "", + customFieldsPD = [], + buildTypeRaw = Just Simple, + setupBuildInfo = Nothing, + library = Nothing, + subLibraries = [], + executables = [], + foreignLibs = [], + testSuites = [], + benchmarks = [], + dataFiles = [], + dataDir = ".", + extraSrcFiles = [], + extraTmpFiles = [], + extraDocFiles = []}, + gpdScannedVersion = Nothing, + genPackageFlags = [ + MkPackageFlag { + flagName = FlagName "foo", + flagDescription = "", + flagDefault = True, + flagManual = True}], + condLibrary = Just + CondNode { + condTreeData = Library { + libName = LMainLibName, + exposedModules = [ + ModuleName "ElseIf"], + reexportedModules = [], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPublic, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Just + Haskell2010, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + Dependency + (PackageName "ghc-prim") + (OrLaterVersion (mkVersion [0])) + mainLibSet], + mixins = []}}, + condTreeConstraints = [ + Dependency + (PackageName "ghc-prim") + (OrLaterVersion (mkVersion [0])) + mainLibSet], + condTreeComponents = [ + CondBranch { + condBranchCondition = + `Var (PackageFlag (FlagName "foo"))`, + condBranchIfTrue = CondNode { + condTreeData = Library { + libName = LMainLibName, + exposedModules = [], + reexportedModules = [], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPublic, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + Dependency + (PackageName "base") + (IntersectVersionRanges + (OrLaterVersion + (mkVersion [4, 10])) + (EarlierVersion + (mkVersion [4, 11]))) + mainLibSet, + Dependency + (PackageName "containers") + (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 = + `Var (OS Windows)`, + condBranchIfTrue = CondNode { + condTreeData = Library { + libName = LMainLibName, + exposedModules = [], + reexportedModules = [], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPublic, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + Dependency + (PackageName "Win32") + (OrLaterVersion (mkVersion [0])) + mainLibSet], + mixins = []}}, + condTreeConstraints = [ + Dependency + (PackageName "Win32") + (OrLaterVersion (mkVersion [0])) + mainLibSet], + condTreeComponents = []}, + condBranchIfFalse = Nothing}]}, + condBranchIfFalse = Nothing}]}, + condSubLibraries = [], + condForeignLibs = [], + condExecutables = [], + condTestSuites = [ + _×_ + (UnqualComponentName "tests") + CondNode { + condTreeData = TestSuite { + testName = UnqualComponentName + "", + testInterface = TestSuiteExeV10 + (mkVersion [1, 0]) + "Tests.hs", + testBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + Dependency + (PackageName "HUnit") + (OrLaterVersion (mkVersion [0])) + mainLibSet], + mixins = []}, + testCodeGenerators = []}, + condTreeConstraints = [ + Dependency + (PackageName "HUnit") + (OrLaterVersion (mkVersion [0])) + mainLibSet], + condTreeComponents = [ + CondBranch { + condBranchCondition = + `Var (OS Windows)`, + condBranchIfTrue = CondNode { + condTreeData = TestSuite { + testName = UnqualComponentName + "", + testInterface = + TestSuiteUnsupported + (TestTypeUnknown + "" + (mkVersion [])), + testBuildInfo = BuildInfo { + buildable = False, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [], + mixins = []}, + testCodeGenerators = []}, + condTreeConstraints = [], + condTreeComponents = []}, + condBranchIfFalse = Nothing}, + CondBranch { + condBranchCondition = + `Var (PackageFlag (FlagName "foo"))`, + condBranchIfTrue = CondNode { + condTreeData = TestSuite { + testName = UnqualComponentName + "", + testInterface = + TestSuiteUnsupported + (TestTypeUnknown + "" + (mkVersion [])), + testBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + Dependency + (PackageName "base") + (IntersectVersionRanges + (OrLaterVersion + (mkVersion [4, 10])) + (EarlierVersion + (mkVersion [4, 11]))) + mainLibSet, + Dependency + (PackageName "containers") + (OrLaterVersion (mkVersion [0])) + 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 = + `Var (OS Windows)`, + condBranchIfTrue = CondNode { + condTreeData = TestSuite { + testName = UnqualComponentName + "", + testInterface = + TestSuiteUnsupported + (TestTypeUnknown + "" + (mkVersion [])), + testBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + Dependency + (PackageName "Win32") + (OrLaterVersion (mkVersion [0])) + mainLibSet], + mixins = []}, + testCodeGenerators = []}, + condTreeConstraints = [ + Dependency + (PackageName "Win32") + (OrLaterVersion (mkVersion [0])) + mainLibSet], + condTreeComponents = []}, + condBranchIfFalse = Nothing}, + CondBranch { + condBranchCondition = + `Var (OS Windows)`, + condBranchIfTrue = CondNode { + condTreeData = TestSuite { + testName = UnqualComponentName + "", + testInterface = + TestSuiteUnsupported + (TestTypeUnknown + "" + (mkVersion [])), + testBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + Dependency + (PackageName "Win32") + (OrLaterVersion (mkVersion [0])) + mainLibSet], + mixins = []}, + testCodeGenerators = []}, + condTreeConstraints = [ + Dependency + (PackageName "Win32") + (OrLaterVersion (mkVersion [0])) + mainLibSet], + condTreeComponents = []}, + condBranchIfFalse = Nothing}]}, + condBranchIfFalse = Nothing}]}], + condBenchmarks = []} diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/common-conditional.format b/cabal/Cabal-tests/tests/ParserTests/regressions/common-conditional.format new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/common-conditional.format @@ -0,0 +1,44 @@ +cabal-version: 3.0 +name: common-conditional +version: 0 +synopsis: Common-stanza demo demo +build-type: Simple + +source-repository head + type: git + location: https://github.com/hvr/-.git + +flag foo + manual: True + +library + exposed-modules: ElseIf + default-language: Haskell2010 + build-depends: ghc-prim + + if flag(foo) + build-depends: + base >=4.10 && <4.11, + containers + + if os(windows) + build-depends: Win32 + +test-suite tests + type: exitcode-stdio-1.0 + main-is: Tests.hs + build-depends: HUnit + + if os(windows) + buildable: False + + if flag(foo) + build-depends: + base >=4.10 && <4.11, + containers + + if os(windows) + build-depends: Win32 + + if os(windows) + build-depends: Win32 diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/common.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/common.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/common.cabal @@ -0,0 +1,35 @@ +name: common +version: 0 +x-revision: 1 +synopsis: Common-stanza demo demo +build-type: Simple +cabal-version: >=1.10 +-- note: empty field +x-follows-version-policy: + +source-repository head + Type: git + Location: https://github.com/hvr/-.git + +common deps + build-depends: + base >=4.10 && <4.11, + containers + +library + import: deps + + default-language: Haskell2010 + exposed-modules: "ElseIf" + + build-depends: + ghc-prim + +test-suite tests + import: deps + + type: exitcode-stdio-1.0 + main-is: Tests.hs + + build-depends: + HUnit diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/common.expr b/cabal/Cabal-tests/tests/ParserTests/regressions/common.expr new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/common.expr @@ -0,0 +1,205 @@ +GenericPackageDescription { + packageDescription = + PackageDescription { + specVersion = CabalSpecV1_10, + package = PackageIdentifier { + pkgName = PackageName "common", + pkgVersion = mkVersion [0]}, + licenseRaw = Left NONE, + licenseFiles = [], + copyright = "", + maintainer = "", + author = "", + stability = "", + testedWith = [], + homepage = "", + pkgUrl = "", + bugReports = "", + sourceRepos = [ + SourceRepo { + repoKind = RepoHead, + repoType = Just + (KnownRepoType Git), + repoLocation = Just + "https://github.com/hvr/-.git", + repoModule = Nothing, + repoBranch = Nothing, + repoTag = Nothing, + repoSubdir = Nothing}], + synopsis = + "Common-stanza demo demo", + description = "", + category = "", + customFieldsPD = [ + _×_ "x-revision" "1", + _×_ + "x-follows-version-policy" + ""], + buildTypeRaw = Just Simple, + setupBuildInfo = Nothing, + library = Nothing, + subLibraries = [], + executables = [], + foreignLibs = [], + testSuites = [], + benchmarks = [], + dataFiles = [], + dataDir = ".", + extraSrcFiles = [], + extraTmpFiles = [], + extraDocFiles = []}, + gpdScannedVersion = Nothing, + genPackageFlags = [], + condLibrary = Just + CondNode { + condTreeData = Library { + libName = LMainLibName, + exposedModules = [ + ModuleName "ElseIf"], + reexportedModules = [], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPublic, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Just + Haskell2010, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + Dependency + (PackageName "ghc-prim") + (OrLaterVersion (mkVersion [0])) + mainLibSet], + mixins = []}}, + condTreeConstraints = [ + Dependency + (PackageName "ghc-prim") + (OrLaterVersion (mkVersion [0])) + mainLibSet], + condTreeComponents = []}, + condSubLibraries = [], + condForeignLibs = [], + condExecutables = [], + condTestSuites = [ + _×_ + (UnqualComponentName "tests") + CondNode { + condTreeData = TestSuite { + testName = UnqualComponentName + "", + testInterface = TestSuiteExeV10 + (mkVersion [1, 0]) + "Tests.hs", + testBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + Dependency + (PackageName "HUnit") + (OrLaterVersion (mkVersion [0])) + mainLibSet], + mixins = []}, + testCodeGenerators = []}, + condTreeConstraints = [ + Dependency + (PackageName "HUnit") + (OrLaterVersion (mkVersion [0])) + mainLibSet], + condTreeComponents = []}], + condBenchmarks = []} diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/common.format b/cabal/Cabal-tests/tests/ParserTests/regressions/common.format new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/common.format @@ -0,0 +1,24 @@ +common.cabal:29:3: Unknown field: import. You should set cabal-version: 2.2 or larger to use common stanzas +common.cabal:20:3: Unknown field: import. You should set cabal-version: 2.2 or larger to use common stanzas +common.cabal:14:1: Ignoring section: common. You should set cabal-version: 2.2 or larger to use common stanzas. +cabal-version: >=1.10 +name: common +version: 0 +synopsis: Common-stanza demo demo +x-revision: 1 +x-follows-version-policy: +build-type: Simple + +source-repository head + type: git + location: https://github.com/hvr/-.git + +library + exposed-modules: ElseIf + default-language: Haskell2010 + build-depends: ghc-prim + +test-suite tests + type: exitcode-stdio-1.0 + main-is: Tests.hs + build-depends: HUnit diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/common2.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/common2.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/common2.cabal @@ -0,0 +1,53 @@ +cabal-version: 2.2 +name: common +version: 0 +synopsis: Common-stanza demo demo +build-type: Simple + +source-repository head + Type: git + Location: https://github.com/hvr/-.git + +common win-dows + if os(windows) + build-depends: Win32 + +common deps + import: win-dows + buildable: True + build-depends: + base >=4.10 && <4.11, + containers + +library + import: deps + + default-language: Haskell2010 + exposed-modules: ElseIf + + build-depends: + ghc-prim + +-- .expr should show libVisible: False +library internal + import: deps + + default-language: Haskell2010 + exposed-modules: ElseIf2 + + build-depends: + ghc-prim + +test-suite tests + import: deps, win-dows + + -- buildable fields verify that we don't have duplicate field warnings + buildable: True + if os(windows) + buildable: False + + type: exitcode-stdio-1.0 + main-is: Tests.hs + + build-depends: + HUnit diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/common2.expr b/cabal/Cabal-tests/tests/ParserTests/regressions/common2.expr new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/common2.expr @@ -0,0 +1,728 @@ +GenericPackageDescription { + packageDescription = + PackageDescription { + specVersion = CabalSpecV2_2, + package = PackageIdentifier { + pkgName = PackageName "common", + pkgVersion = mkVersion [0]}, + licenseRaw = Left NONE, + licenseFiles = [], + copyright = "", + maintainer = "", + author = "", + stability = "", + testedWith = [], + homepage = "", + pkgUrl = "", + bugReports = "", + sourceRepos = [ + SourceRepo { + repoKind = RepoHead, + repoType = Just + (KnownRepoType Git), + repoLocation = Just + "https://github.com/hvr/-.git", + repoModule = Nothing, + repoBranch = Nothing, + repoTag = Nothing, + repoSubdir = Nothing}], + synopsis = + "Common-stanza demo demo", + description = "", + category = "", + customFieldsPD = [], + buildTypeRaw = Just Simple, + setupBuildInfo = Nothing, + library = Nothing, + subLibraries = [], + executables = [], + foreignLibs = [], + testSuites = [], + benchmarks = [], + dataFiles = [], + dataDir = ".", + extraSrcFiles = [], + extraTmpFiles = [], + extraDocFiles = []}, + gpdScannedVersion = Nothing, + genPackageFlags = [], + condLibrary = Just + CondNode { + condTreeData = Library { + libName = LMainLibName, + exposedModules = [ + ModuleName "ElseIf"], + reexportedModules = [], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPublic, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Just + Haskell2010, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + 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], + 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 = + `Var (OS Windows)`, + condBranchIfTrue = CondNode { + condTreeData = Library { + libName = LMainLibName, + exposedModules = [], + reexportedModules = [], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPublic, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + Dependency + (PackageName "Win32") + (OrLaterVersion (mkVersion [0])) + mainLibSet], + mixins = []}}, + condTreeConstraints = [ + Dependency + (PackageName "Win32") + (OrLaterVersion (mkVersion [0])) + mainLibSet], + condTreeComponents = []}, + condBranchIfFalse = Nothing}]}, + condSubLibraries = [ + _×_ + (UnqualComponentName "internal") + CondNode { + condTreeData = Library { + libName = LSubLibName + (UnqualComponentName + "internal"), + exposedModules = [ + ModuleName "ElseIf2"], + reexportedModules = [], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPrivate, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Just + Haskell2010, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + 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], + 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 = + `Var (OS Windows)`, + condBranchIfTrue = CondNode { + condTreeData = Library { + libName = LSubLibName + (UnqualComponentName + "internal"), + exposedModules = [], + reexportedModules = [], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPrivate, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + Dependency + (PackageName "Win32") + (OrLaterVersion (mkVersion [0])) + mainLibSet], + mixins = []}}, + condTreeConstraints = [ + Dependency + (PackageName "Win32") + (OrLaterVersion (mkVersion [0])) + mainLibSet], + condTreeComponents = []}, + condBranchIfFalse = Nothing}]}], + condForeignLibs = [], + condExecutables = [], + condTestSuites = [ + _×_ + (UnqualComponentName "tests") + CondNode { + condTreeData = TestSuite { + testName = UnqualComponentName + "", + testInterface = TestSuiteExeV10 + (mkVersion [1, 0]) + "Tests.hs", + testBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + 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], + 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 = + `Var (OS Windows)`, + condBranchIfTrue = CondNode { + condTreeData = TestSuite { + testName = UnqualComponentName + "", + testInterface = + TestSuiteUnsupported + (TestTypeUnknown + "" + (mkVersion [])), + testBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + Dependency + (PackageName "Win32") + (OrLaterVersion (mkVersion [0])) + mainLibSet], + mixins = []}, + testCodeGenerators = []}, + condTreeConstraints = [ + Dependency + (PackageName "Win32") + (OrLaterVersion (mkVersion [0])) + mainLibSet], + condTreeComponents = []}, + condBranchIfFalse = Nothing}, + CondBranch { + condBranchCondition = + `Var (OS Windows)`, + condBranchIfTrue = CondNode { + condTreeData = TestSuite { + testName = UnqualComponentName + "", + testInterface = + TestSuiteUnsupported + (TestTypeUnknown + "" + (mkVersion [])), + testBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + Dependency + (PackageName "Win32") + (OrLaterVersion (mkVersion [0])) + mainLibSet], + mixins = []}, + testCodeGenerators = []}, + condTreeConstraints = [ + Dependency + (PackageName "Win32") + (OrLaterVersion (mkVersion [0])) + mainLibSet], + condTreeComponents = []}, + condBranchIfFalse = Nothing}, + CondBranch { + condBranchCondition = + `Var (OS Windows)`, + condBranchIfTrue = CondNode { + condTreeData = TestSuite { + testName = UnqualComponentName + "", + testInterface = + TestSuiteUnsupported + (TestTypeUnknown + "" + (mkVersion [])), + testBuildInfo = BuildInfo { + buildable = False, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [], + mixins = []}, + testCodeGenerators = []}, + condTreeConstraints = [], + condTreeComponents = []}, + condBranchIfFalse = Nothing}]}], + condBenchmarks = []} diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/common2.format b/cabal/Cabal-tests/tests/ParserTests/regressions/common2.format new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/common2.format @@ -0,0 +1,48 @@ +cabal-version: 2.2 +name: common +version: 0 +synopsis: Common-stanza demo demo +build-type: Simple + +source-repository head + type: git + location: https://github.com/hvr/-.git + +library + exposed-modules: ElseIf + default-language: Haskell2010 + build-depends: + base >=4.10 && <4.11, + containers, + ghc-prim + + if os(windows) + build-depends: Win32 + +library internal + exposed-modules: ElseIf2 + default-language: Haskell2010 + build-depends: + base >=4.10 && <4.11, + containers, + ghc-prim + + if os(windows) + build-depends: Win32 + +test-suite tests + type: exitcode-stdio-1.0 + main-is: Tests.hs + build-depends: + base >=4.10 && <4.11, + containers, + HUnit + + if os(windows) + build-depends: Win32 + + if os(windows) + build-depends: Win32 + + if os(windows) + buildable: False diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/common3.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/common3.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/common3.cabal @@ -0,0 +1,36 @@ +cabal-version: 2.2 +name: common +version: 0 +x-revision: 1 +synopsis: Common-stanza demo demo +build-type: Simple +-- note: empty field +x-follows-version-policy: + +source-repository head + Type: git + Location: https://github.com/hvr/-.git + +common deps + build-depends: + base >=4.10 && <4.11, + containers + +library + default-language: Haskell2010 + exposed-modules: "ElseIf" + + -- not first: will be omitted and generate warning + import: deps + + build-depends: + ghc-prim + +test-suite tests + import: deps + + type: exitcode-stdio-1.0 + main-is: Tests.hs + + build-depends: + HUnit diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/common3.expr b/cabal/Cabal-tests/tests/ParserTests/regressions/common3.expr new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/common3.expr @@ -0,0 +1,229 @@ +GenericPackageDescription { + packageDescription = + PackageDescription { + specVersion = CabalSpecV2_2, + package = PackageIdentifier { + pkgName = PackageName "common", + pkgVersion = mkVersion [0]}, + licenseRaw = Left NONE, + licenseFiles = [], + copyright = "", + maintainer = "", + author = "", + stability = "", + testedWith = [], + homepage = "", + pkgUrl = "", + bugReports = "", + sourceRepos = [ + SourceRepo { + repoKind = RepoHead, + repoType = Just + (KnownRepoType Git), + repoLocation = Just + "https://github.com/hvr/-.git", + repoModule = Nothing, + repoBranch = Nothing, + repoTag = Nothing, + repoSubdir = Nothing}], + synopsis = + "Common-stanza demo demo", + description = "", + category = "", + customFieldsPD = [ + _×_ "x-revision" "1", + _×_ + "x-follows-version-policy" + ""], + buildTypeRaw = Just Simple, + setupBuildInfo = Nothing, + library = Nothing, + subLibraries = [], + executables = [], + foreignLibs = [], + testSuites = [], + benchmarks = [], + dataFiles = [], + dataDir = ".", + extraSrcFiles = [], + extraTmpFiles = [], + extraDocFiles = []}, + gpdScannedVersion = Nothing, + genPackageFlags = [], + condLibrary = Just + CondNode { + condTreeData = Library { + libName = LMainLibName, + exposedModules = [ + ModuleName "ElseIf"], + reexportedModules = [], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPublic, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Just + Haskell2010, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + Dependency + (PackageName "ghc-prim") + (OrLaterVersion (mkVersion [0])) + mainLibSet], + mixins = []}}, + condTreeConstraints = [ + Dependency + (PackageName "ghc-prim") + (OrLaterVersion (mkVersion [0])) + mainLibSet], + condTreeComponents = []}, + condSubLibraries = [], + condForeignLibs = [], + condExecutables = [], + condTestSuites = [ + _×_ + (UnqualComponentName "tests") + CondNode { + condTreeData = TestSuite { + testName = UnqualComponentName + "", + testInterface = TestSuiteExeV10 + (mkVersion [1, 0]) + "Tests.hs", + testBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + 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], + 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/Cabal-tests/tests/ParserTests/regressions/common3.format b/cabal/Cabal-tests/tests/ParserTests/regressions/common3.format new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/common3.format @@ -0,0 +1,25 @@ +common3.cabal:24:3: Unknown field: import. Common stanza imports should be at the top of the enclosing section +cabal-version: 2.2 +name: common +version: 0 +synopsis: Common-stanza demo demo +x-revision: 1 +x-follows-version-policy: +build-type: Simple + +source-repository head + type: git + location: https://github.com/hvr/-.git + +library + exposed-modules: ElseIf + default-language: Haskell2010 + build-depends: ghc-prim + +test-suite tests + type: exitcode-stdio-1.0 + main-is: Tests.hs + build-depends: + base >=4.10 && <4.11, + containers, + HUnit diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/cxx-options-with-optimization.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/cxx-options-with-optimization.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/cxx-options-with-optimization.cabal @@ -0,0 +1,15 @@ +cabal-version: 2.2 +category: test +description: test a build check involving C++-options field +license: BSD-3-Clause +maintainer: me@example.com +name: cxx-options-with-optimization +synopsis: test a build check +version: 1 + +library + build-depends: base >= 4.9 && <4.10 + cxx-options: -O2 + default-language: Haskell2010 + exposed-modules: Prelude + hs-source-dirs: . diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/cxx-options-with-optimization.check b/cabal/Cabal-tests/tests/ParserTests/regressions/cxx-options-with-optimization.check new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/cxx-options-with-optimization.check @@ -0,0 +1,1 @@ +'cxx-options: -O[n]' is generally not needed. When building with optimisations Cabal automatically adds '-O2' for C++ code. Setting it yourself interferes with the --disable-optimization flag. diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/denormalised-paths.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/denormalised-paths.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/denormalised-paths.cabal @@ -0,0 +1,78 @@ +cabal-version: 2.4 +name: assoc +version: 1.1 +license: BSD-3-Clause +license-files: LICENSE LICENSE2/ . +synopsis: swap and assoc: Symmetric and Semigroupy Bifunctors +category: Data +description: + Provides generalisations of + @swap :: (a,b) -> (b,a)@ and + @assoc :: ((a,b),c) -> (a,(b,c))@ + to + @Bifunctor@s supporting similar operations (e.g. @Either@, @These@). + +author: Oleg Grenrus +maintainer: Oleg Grenrus +build-type: Simple +tested-with: + GHC ==7.0.4 + || ==7.2.2 + || ==7.4.2 + || ==7.6.3 + || ==7.8.4 + || ==7.10.3 + || ==8.0.2 + || ==8.2.2 + || ==8.4.4 + || ==8.6.5 + || ==8.8.1 + +extra-source-files: + -- this is fine + files/**/*.md + -- collection of invalid paths + files/**/*.txt/ + files/../foo.txt + files/<>/*.txt + +source-repository head + type: git + location: https://github.com/phadej/assoc.git + subdir: ./. + +source-repository this + type: git + location: https://github.com/phadej/assoc.git + tag: v1.1 + subdir: foo/ + +library + default-language: Haskell2010 + build-depends: + base >=4.3 && <4.13 + , bifunctors >=5.5.4 && <5.6 + + exposed-modules: + Data.Bifunctor.Assoc + Data.Bifunctor.Swap + + -- this is fine + hs-source-dirs: src/ + + -- collection of invalid sources + hs-source-dirs: src/. + hs-source-dirs: src/../src + hs-source-dirs: src/../../assoc/src + -- this is forbidden by a parser + -- hs-source-dirs: C:/foo/bar + hs-source-dirs: C:foo/bar + hs-source-dirs: ||s + -- this is forbidden by a parser + -- hs-source-dirs: /var/secret/source + + -- this is the only case catched by Cabal-3.0.2.0 + hs-source-dirs: ../../assoc/src + + -- globs not allowed in field + c-sources: c/**/*.c diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/denormalised-paths.check b/cabal/Cabal-tests/tests/ParserTests/regressions/denormalised-paths.check new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/denormalised-paths.check @@ -0,0 +1,11 @@ +The 'subdir' field of a source-repository is not a good relative path: "trailing same directory segment: ." +The paths 'files/<>/*.txt', 'c/**/*.c', 'C:foo/bar', '||s' are invalid on Windows, which would cause portability problems for this package. Windows file names cannot contain any of the characters ":*?<>|" and there a few reserved names including "aux", "nul", "con", "prn", "com1-9", "lpt1-9" and "clock$". +'hs-source-dirs: ../../assoc/src' is a relative path outside of the source tree. This will not work when generating a tarball with 'sdist'. +'extra-source-files: files/**/*.txt/' is not a good relative path: "trailing slash" +'extra-source-files: files/../foo.txt' is not a good relative path: "parent directory segment: .." +'license-file: LICENSE2/' is not a good relative path: "trailing slash" +'license-file: .' is not a good relative path: "trailing dot segment" +'hs-source-dirs: src/.' is not a good relative path: "trailing same directory segment: ." +'hs-source-dirs: src/../src' is not a good relative path: "parent directory segment: .." +'hs-source-dirs: src/../../assoc/src' is not a good relative path: "parent directory segment: .." +'hs-source-dirs: ../../assoc/src' is not a good relative path: "parent directory segment: .." diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/elif.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/elif.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/elif.cabal @@ -0,0 +1,20 @@ +name: elif +version: 0 +synopsis: The elif demo +build-type: Simple +cabal-version: >=1.10 + +source-repository head + Type: git + Location: https://github.com/hvr/-.git + +library + default-language: Haskell2010 + exposed-modules: ElseIf + + if os(linux) + build-depends: unix + elif os(windows) + build-depends: Win32 + else + buildable: False diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/elif.expr b/cabal/Cabal-tests/tests/ParserTests/regressions/elif.expr new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/elif.expr @@ -0,0 +1,184 @@ +GenericPackageDescription + {condBenchmarks = [], + condExecutables = [], + condForeignLibs = [], + condLibrary = Just + CondNode + {condTreeComponents = [CondBranch + {condBranchCondition = `Var (OS Linux)`, + condBranchIfFalse = Nothing, + condBranchIfTrue = CondNode + {condTreeComponents = [], + condTreeConstraints = [Dependency + (PackageName + "unix") + (OrLaterVersion + (mkVersion + [0])) + mainLibSet], + condTreeData = Library + {exposedModules = [], + libBuildInfo = BuildInfo + {asmOptions = [], + asmSources = [], + autogenIncludes = [], + autogenModules = [], + buildToolDepends = [], + buildTools = [], + buildable = True, + cSources = [], + ccOptions = [], + cmmOptions = [], + cmmSources = [], + cppOptions = [], + customFieldsBI = [], + cxxOptions = [], + cxxSources = [], + defaultExtensions = [], + defaultLanguage = Nothing, + extraBundledLibs = [], + extraDynLibFlavours = [], + extraFrameworkDirs = [], + extraGHCiLibs = [], + extraLibDirs = [], + extraLibDirsStatic = [], + extraLibFlavours = [], + extraLibs = [], + extraLibsStatic = [], + frameworks = [], + hsSourceDirs = [], + hsc2hsOptions = [], + includeDirs = [], + includes = [], + installIncludes = [], + jsSources = [], + ldOptions = [], + mixins = [], + oldExtensions = [], + options = PerCompilerFlavor + [] + [], + otherExtensions = [], + otherLanguages = [], + otherModules = [], + pkgconfigDepends = [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = PerCompilerFlavor + [] + [], + staticOptions = PerCompilerFlavor + [] + [], + targetBuildDepends = [Dependency + (PackageName + "unix") + (OrLaterVersion + (mkVersion + [0])) + mainLibSet], + virtualModules = []}, + libExposed = True, + libName = LMainLibName, + libVisibility = LibraryVisibilityPublic, + reexportedModules = [], + signatures = []}}}], + condTreeConstraints = [], + condTreeData = Library + {exposedModules = [ModuleName "ElseIf"], + libBuildInfo = BuildInfo + {asmOptions = [], + asmSources = [], + autogenIncludes = [], + autogenModules = [], + buildToolDepends = [], + buildTools = [], + buildable = True, + cSources = [], + ccOptions = [], + cmmOptions = [], + cmmSources = [], + cppOptions = [], + customFieldsBI = [], + cxxOptions = [], + cxxSources = [], + defaultExtensions = [], + defaultLanguage = Just Haskell2010, + extraBundledLibs = [], + extraDynLibFlavours = [], + extraFrameworkDirs = [], + extraGHCiLibs = [], + extraLibDirs = [], + extraLibDirsStatic = [], + extraLibFlavours = [], + extraLibs = [], + extraLibsStatic = [], + frameworks = [], + hsSourceDirs = [], + hsc2hsOptions = [], + includeDirs = [], + includes = [], + installIncludes = [], + jsSources = [], + ldOptions = [], + mixins = [], + oldExtensions = [], + options = PerCompilerFlavor [] [], + otherExtensions = [], + otherLanguages = [], + otherModules = [], + pkgconfigDepends = [], + profOptions = PerCompilerFlavor [] [], + sharedOptions = PerCompilerFlavor [] [], + staticOptions = PerCompilerFlavor [] [], + targetBuildDepends = [], + virtualModules = []}, + libExposed = True, + libName = LMainLibName, + libVisibility = LibraryVisibilityPublic, + reexportedModules = [], + signatures = []}}, + condSubLibraries = [], + condTestSuites = [], + genPackageFlags = [], + gpdScannedVersion = Nothing, + packageDescription = PackageDescription + {author = "", + benchmarks = [], + bugReports = "", + buildTypeRaw = Just Simple, + category = "", + copyright = "", + customFieldsPD = [], + dataDir = ".", + dataFiles = [], + description = "", + executables = [], + extraDocFiles = [], + extraSrcFiles = [], + extraTmpFiles = [], + foreignLibs = [], + homepage = "", + library = Nothing, + licenseFiles = [], + licenseRaw = Left NONE, + maintainer = "", + package = PackageIdentifier + {pkgName = PackageName "elif", pkgVersion = mkVersion [0]}, + pkgUrl = "", + setupBuildInfo = Nothing, + sourceRepos = [SourceRepo + {repoBranch = Nothing, + repoKind = RepoHead, + repoLocation = Just "https://github.com/hvr/-.git", + repoModule = Nothing, + repoSubdir = Nothing, + repoTag = Nothing, + repoType = Just (KnownRepoType Git)}], + specVersion = CabalSpecV1_10, + stability = "", + subLibraries = [], + synopsis = "The elif demo", + testSuites = [], + testedWith = []}} diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/elif.format b/cabal/Cabal-tests/tests/ParserTests/regressions/elif.format new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/elif.format @@ -0,0 +1,18 @@ +elif.cabal:19:3: invalid subsection "else" +elif.cabal:17:3: invalid subsection "elif". You should set cabal-version: 2.2 or larger to use elif-conditionals. +cabal-version: >=1.10 +name: elif +version: 0 +synopsis: The elif demo +build-type: Simple + +source-repository head + type: git + location: https://github.com/hvr/-.git + +library + exposed-modules: ElseIf + default-language: Haskell2010 + + if os(linux) + build-depends: unix diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/elif2.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/elif2.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/elif2.cabal @@ -0,0 +1,20 @@ +cabal-version: 2.2 +name: elif +version: 0 +synopsis: The elif demo +build-type: Simple + +source-repository head + Type: git + Location: https://github.com/hvr/-.git + +library + default-language: Haskell2010 + exposed-modules: ElseIf + + if os(linux) + build-depends: unix + elif os(windows) + build-depends: Win32 + else + buildable: False diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/elif2.expr b/cabal/Cabal-tests/tests/ParserTests/regressions/elif2.expr new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/elif2.expr @@ -0,0 +1,393 @@ +GenericPackageDescription + {condBenchmarks = [], + condExecutables = [], + condForeignLibs = [], + condLibrary = Just + CondNode + {condTreeComponents = [CondBranch + {condBranchCondition = `Var (OS Linux)`, + condBranchIfFalse = Just + CondNode + {condTreeComponents = [CondBranch + {condBranchCondition = `Var (OS Windows)`, + condBranchIfFalse = Just + CondNode + {condTreeComponents = [], + condTreeConstraints = [], + condTreeData = Library + {exposedModules = [], + libBuildInfo = BuildInfo + {asmOptions = [], + asmSources = [], + autogenIncludes = [], + autogenModules = [], + buildToolDepends = [], + buildTools = [], + buildable = False, + cSources = [], + ccOptions = [], + cmmOptions = [], + cmmSources = [], + cppOptions = [], + customFieldsBI = [], + cxxOptions = [], + cxxSources = [], + defaultExtensions = [], + defaultLanguage = Nothing, + extraBundledLibs = [], + extraDynLibFlavours = [], + extraFrameworkDirs = [], + extraGHCiLibs = [], + extraLibDirs = [], + extraLibDirsStatic = [], + extraLibFlavours = [], + extraLibs = [], + extraLibsStatic = [], + frameworks = [], + hsSourceDirs = [], + hsc2hsOptions = [], + includeDirs = [], + includes = [], + installIncludes = [], + jsSources = [], + ldOptions = [], + mixins = [], + oldExtensions = [], + options = PerCompilerFlavor + [] + [], + otherExtensions = [], + otherLanguages = [], + otherModules = [], + pkgconfigDepends = [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = PerCompilerFlavor + [] + [], + staticOptions = PerCompilerFlavor + [] + [], + targetBuildDepends = [], + virtualModules = []}, + libExposed = True, + libName = LMainLibName, + libVisibility = LibraryVisibilityPublic, + reexportedModules = [], + signatures = []}}, + condBranchIfTrue = CondNode + {condTreeComponents = [], + condTreeConstraints = [Dependency + (PackageName + "Win32") + (OrLaterVersion + (mkVersion + [0])) + mainLibSet], + condTreeData = Library + {exposedModules = [], + libBuildInfo = BuildInfo + {asmOptions = [], + asmSources = [], + autogenIncludes = [], + autogenModules = [], + buildToolDepends = [], + buildTools = [], + buildable = True, + cSources = [], + ccOptions = [], + cmmOptions = [], + cmmSources = [], + cppOptions = [], + customFieldsBI = [], + cxxOptions = [], + cxxSources = [], + defaultExtensions = [], + defaultLanguage = Nothing, + extraBundledLibs = [], + extraDynLibFlavours = [], + extraFrameworkDirs = [], + extraGHCiLibs = [], + extraLibDirs = [], + extraLibDirsStatic = [], + extraLibFlavours = [], + extraLibs = [], + extraLibsStatic = [], + frameworks = [], + hsSourceDirs = [], + hsc2hsOptions = [], + includeDirs = [], + includes = [], + installIncludes = [], + jsSources = [], + ldOptions = [], + mixins = [], + oldExtensions = [], + options = PerCompilerFlavor + [] + [], + otherExtensions = [], + otherLanguages = [], + otherModules = [], + pkgconfigDepends = [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = PerCompilerFlavor + [] + [], + staticOptions = PerCompilerFlavor + [] + [], + targetBuildDepends = [Dependency + (PackageName + "Win32") + (OrLaterVersion + (mkVersion + [0])) + mainLibSet], + virtualModules = []}, + libExposed = True, + libName = LMainLibName, + libVisibility = LibraryVisibilityPublic, + reexportedModules = [], + signatures = []}}}], + condTreeConstraints = [], + condTreeData = Library + {exposedModules = [], + libBuildInfo = BuildInfo + {asmOptions = [], + asmSources = [], + autogenIncludes = [], + autogenModules = [], + buildToolDepends = [], + buildTools = [], + buildable = True, + cSources = [], + ccOptions = [], + cmmOptions = [], + cmmSources = [], + cppOptions = [], + customFieldsBI = [], + cxxOptions = [], + cxxSources = [], + defaultExtensions = [], + defaultLanguage = Nothing, + extraBundledLibs = [], + extraDynLibFlavours = [], + extraFrameworkDirs = [], + extraGHCiLibs = [], + extraLibDirs = [], + extraLibDirsStatic = [], + extraLibFlavours = [], + extraLibs = [], + extraLibsStatic = [], + frameworks = [], + hsSourceDirs = [], + hsc2hsOptions = [], + includeDirs = [], + includes = [], + installIncludes = [], + jsSources = [], + ldOptions = [], + mixins = [], + oldExtensions = [], + options = PerCompilerFlavor + [] + [], + otherExtensions = [], + otherLanguages = [], + otherModules = [], + pkgconfigDepends = [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = PerCompilerFlavor + [] + [], + staticOptions = PerCompilerFlavor + [] + [], + targetBuildDepends = [], + virtualModules = []}, + libExposed = True, + libName = LMainLibName, + libVisibility = LibraryVisibilityPublic, + reexportedModules = [], + signatures = []}}, + condBranchIfTrue = CondNode + {condTreeComponents = [], + condTreeConstraints = [Dependency + (PackageName + "unix") + (OrLaterVersion + (mkVersion + [0])) + mainLibSet], + condTreeData = Library + {exposedModules = [], + libBuildInfo = BuildInfo + {asmOptions = [], + asmSources = [], + autogenIncludes = [], + autogenModules = [], + buildToolDepends = [], + buildTools = [], + buildable = True, + cSources = [], + ccOptions = [], + cmmOptions = [], + cmmSources = [], + cppOptions = [], + customFieldsBI = [], + cxxOptions = [], + cxxSources = [], + defaultExtensions = [], + defaultLanguage = Nothing, + extraBundledLibs = [], + extraDynLibFlavours = [], + extraFrameworkDirs = [], + extraGHCiLibs = [], + extraLibDirs = [], + extraLibDirsStatic = [], + extraLibFlavours = [], + extraLibs = [], + extraLibsStatic = [], + frameworks = [], + hsSourceDirs = [], + hsc2hsOptions = [], + includeDirs = [], + includes = [], + installIncludes = [], + jsSources = [], + ldOptions = [], + mixins = [], + oldExtensions = [], + options = PerCompilerFlavor + [] + [], + otherExtensions = [], + otherLanguages = [], + otherModules = [], + pkgconfigDepends = [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = PerCompilerFlavor + [] + [], + staticOptions = PerCompilerFlavor + [] + [], + targetBuildDepends = [Dependency + (PackageName + "unix") + (OrLaterVersion + (mkVersion + [0])) + mainLibSet], + virtualModules = []}, + libExposed = True, + libName = LMainLibName, + libVisibility = LibraryVisibilityPublic, + reexportedModules = [], + signatures = []}}}], + condTreeConstraints = [], + condTreeData = Library + {exposedModules = [ModuleName "ElseIf"], + libBuildInfo = BuildInfo + {asmOptions = [], + asmSources = [], + autogenIncludes = [], + autogenModules = [], + buildToolDepends = [], + buildTools = [], + buildable = True, + cSources = [], + ccOptions = [], + cmmOptions = [], + cmmSources = [], + cppOptions = [], + customFieldsBI = [], + cxxOptions = [], + cxxSources = [], + defaultExtensions = [], + defaultLanguage = Just Haskell2010, + extraBundledLibs = [], + extraDynLibFlavours = [], + extraFrameworkDirs = [], + extraGHCiLibs = [], + extraLibDirs = [], + extraLibDirsStatic = [], + extraLibFlavours = [], + extraLibs = [], + extraLibsStatic = [], + frameworks = [], + hsSourceDirs = [], + hsc2hsOptions = [], + includeDirs = [], + includes = [], + installIncludes = [], + jsSources = [], + ldOptions = [], + mixins = [], + oldExtensions = [], + options = PerCompilerFlavor [] [], + otherExtensions = [], + otherLanguages = [], + otherModules = [], + pkgconfigDepends = [], + profOptions = PerCompilerFlavor [] [], + sharedOptions = PerCompilerFlavor [] [], + staticOptions = PerCompilerFlavor [] [], + targetBuildDepends = [], + virtualModules = []}, + libExposed = True, + libName = LMainLibName, + libVisibility = LibraryVisibilityPublic, + reexportedModules = [], + signatures = []}}, + condSubLibraries = [], + condTestSuites = [], + genPackageFlags = [], + gpdScannedVersion = Nothing, + packageDescription = PackageDescription + {author = "", + benchmarks = [], + bugReports = "", + buildTypeRaw = Just Simple, + category = "", + copyright = "", + customFieldsPD = [], + dataDir = ".", + dataFiles = [], + description = "", + executables = [], + extraDocFiles = [], + extraSrcFiles = [], + extraTmpFiles = [], + foreignLibs = [], + homepage = "", + library = Nothing, + licenseFiles = [], + licenseRaw = Left NONE, + maintainer = "", + package = PackageIdentifier + {pkgName = PackageName "elif", pkgVersion = mkVersion [0]}, + pkgUrl = "", + setupBuildInfo = Nothing, + sourceRepos = [SourceRepo + {repoBranch = Nothing, + repoKind = RepoHead, + repoLocation = Just "https://github.com/hvr/-.git", + repoModule = Nothing, + repoSubdir = Nothing, + repoTag = Nothing, + repoType = Just (KnownRepoType Git)}], + specVersion = CabalSpecV2_2, + stability = "", + subLibraries = [], + synopsis = "The elif demo", + testSuites = [], + testedWith = []}} diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/elif2.format b/cabal/Cabal-tests/tests/ParserTests/regressions/elif2.format new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/elif2.format @@ -0,0 +1,23 @@ +cabal-version: 2.2 +name: elif +version: 0 +synopsis: The elif demo +build-type: Simple + +source-repository head + type: git + location: https://github.com/hvr/-.git + +library + exposed-modules: ElseIf + default-language: Haskell2010 + + if os(linux) + build-depends: unix + + else + if os(windows) + build-depends: Win32 + + else + buildable: False diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/encoding-0.8.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/encoding-0.8.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/encoding-0.8.cabal @@ -0,0 +1,24 @@ +Name: encoding-wrong +Name: encoding +Version: 0.8 +cabal-version: >=1.12 +-- double-dash files +extra-source-files: + -- this is comment + README.md "--" + "--" + +custom-setup + setup-depends: + base < 5, + ghc-prim + +Library + -- version range round trip is better + build-depends: base (> 4.4 || == 4.4) + + Exposed-Modules: + Data.Encoding + + -- options with spaces + GHC-Options: -Wall -O2 -threaded -rtsopts "-with-rtsopts=-N1 -A64m" diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/encoding-0.8.expr b/cabal/Cabal-tests/tests/ParserTests/regressions/encoding-0.8.expr new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/encoding-0.8.expr @@ -0,0 +1,130 @@ +GenericPackageDescription + {condBenchmarks = [], + condExecutables = [], + condForeignLibs = [], + condLibrary = Just + CondNode + {condTreeComponents = [], + condTreeConstraints = [Dependency + (PackageName "base") + (UnionVersionRanges + (LaterVersion (mkVersion [4, 4])) + (ThisVersion (mkVersion [4, 4]))) + mainLibSet], + condTreeData = Library + {exposedModules = [ModuleName "Data.Encoding"], + libBuildInfo = BuildInfo + {asmOptions = [], + asmSources = [], + autogenIncludes = [], + autogenModules = [], + buildToolDepends = [], + buildTools = [], + buildable = True, + cSources = [], + ccOptions = [], + cmmOptions = [], + cmmSources = [], + cppOptions = [], + customFieldsBI = [], + cxxOptions = [], + cxxSources = [], + defaultExtensions = [], + defaultLanguage = Nothing, + extraBundledLibs = [], + extraDynLibFlavours = [], + extraFrameworkDirs = [], + extraGHCiLibs = [], + extraLibDirs = [], + extraLibDirsStatic = [], + extraLibFlavours = [], + extraLibs = [], + extraLibsStatic = [], + frameworks = [], + hsSourceDirs = [], + hsc2hsOptions = [], + includeDirs = [], + includes = [], + installIncludes = [], + jsSources = [], + ldOptions = [], + mixins = [], + oldExtensions = [], + options = PerCompilerFlavor + ["-Wall", + "-O2", + "-threaded", + "-rtsopts", + "-with-rtsopts=-N1 -A64m"] + [], + otherExtensions = [], + otherLanguages = [], + otherModules = [], + pkgconfigDepends = [], + profOptions = PerCompilerFlavor [] [], + sharedOptions = PerCompilerFlavor [] [], + staticOptions = PerCompilerFlavor [] [], + targetBuildDepends = [Dependency + (PackageName + "base") + (UnionVersionRanges + (LaterVersion + (mkVersion + [4, 4])) + (ThisVersion + (mkVersion + [4, 4]))) + mainLibSet], + virtualModules = []}, + libExposed = True, + libName = LMainLibName, + libVisibility = LibraryVisibilityPublic, + reexportedModules = [], + signatures = []}}, + condSubLibraries = [], + condTestSuites = [], + genPackageFlags = [], + gpdScannedVersion = Nothing, + packageDescription = PackageDescription + {author = "", + benchmarks = [], + bugReports = "", + buildTypeRaw = Nothing, + category = "", + copyright = "", + customFieldsPD = [], + dataDir = ".", + dataFiles = [], + description = "", + executables = [], + extraDocFiles = [], + extraSrcFiles = ["README.md", "--", "--"], + extraTmpFiles = [], + foreignLibs = [], + homepage = "", + library = Nothing, + licenseFiles = [], + licenseRaw = Left NONE, + maintainer = "", + package = PackageIdentifier + {pkgName = PackageName "encoding", + pkgVersion = mkVersion [0, 8]}, + pkgUrl = "", + setupBuildInfo = Just + SetupBuildInfo + {defaultSetupDepends = False, + setupDepends = [Dependency + (PackageName "base") + (EarlierVersion (mkVersion [5])) + mainLibSet, + Dependency + (PackageName "ghc-prim") + (OrLaterVersion (mkVersion [0])) + mainLibSet]}, + sourceRepos = [], + specVersion = CabalSpecV1_12, + stability = "", + subLibraries = [], + synopsis = "", + testSuites = [], + testedWith = []}} diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/encoding-0.8.format b/cabal/Cabal-tests/tests/ParserTests/regressions/encoding-0.8.format new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/encoding-0.8.format @@ -0,0 +1,19 @@ +encoding-0.8.cabal:1:1: The field "name" is specified more than once at positions 1:1, 2:1 +encoding-0.8.cabal:4:22: Packages with 'cabal-version: 1.12' or later should specify a specific version of the Cabal spec of the form 'cabal-version: x.y'. Use 'cabal-version: 1.12'. +cabal-version: 1.12 +name: encoding +version: 0.8 +extra-source-files: + README.md + "--" + "--" + +custom-setup + setup-depends: + base <5, + ghc-prim + +library + exposed-modules: Data.Encoding + ghc-options: -Wall -O2 -threaded -rtsopts "-with-rtsopts=-N1 -A64m" + build-depends: base >4.4 || ==4.4 diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/extensions-paths-5054.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/extensions-paths-5054.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/extensions-paths-5054.cabal @@ -0,0 +1,39 @@ +name: extensions-paths +version: 5054 +category: Test +maintainer: Oleg Grenrus +license: BSD3 +license-file: LICENSe +synopsis: Paths_pkg module + "bad" extensions + old cabal +description: + Only cabal-version: 2.2 or later will build Paths_pkg ok with + + * RebindableSyntax and + + * OverloadedLists or OverloadedStrings + + `fromList` or `fromString` will be out-of-scope when compiling Paths_ module. + + Other extensions (like NoImplicitPrelude) were handled before +build-type: Simple +cabal-version: 1.12 + +library + default-language: Haskell2010 + exposed-modules: Issue Paths_extensions_paths + default-extensions: + RebindableSyntax + OverloadedStrings + +test-suite tests + default-language: Haskell2010 + main-is: Test.hs + type: exitcode-stdio-1.0 + if os(linux) + other-modules: Paths_extensions_paths + else + buildable: False + + default-extensions: + OverloadedLists + RebindableSyntax diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/extensions-paths-5054.check b/cabal/Cabal-tests/tests/ParserTests/regressions/extensions-paths-5054.check new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/extensions-paths-5054.check @@ -0,0 +1,1 @@ +Packages using RebindableSyntax with OverloadedStrings or OverloadedLists in default-extensions, in conjunction with the autogenerated module Paths_*, are known to cause compile failures with Cabal < 2.2. To use these default-extensions with a Paths_* autogen module, specify at least 'cabal-version: 2.2'. diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/generics-sop.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/generics-sop.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/generics-sop.cabal @@ -0,0 +1,128 @@ +name: generics-sop +version: 0.3.1.0 +synopsis: Generic Programming using True Sums of Products +description: + A library to support the definition of generic functions. + Datatypes are viewed in a uniform, structured way: + the choice between constructors is represented using an n-ary + sum, and the arguments of each constructor are represented using + an n-ary product. + . + The module "Generics.SOP" is the main module of this library and contains + more detailed documentation. + . + Examples of using this library are provided by the following + packages: + . + * @@ basic examples, + . + * @@ generic pretty printing, + . + * @@ generically computed lenses, + . + * @@ generic JSON conversions. + . + A detailed description of the ideas behind this library is provided by + the paper: + . + * Edsko de Vries and Andres Löh. + . + Workshop on Generic Programming (WGP) 2014. + . +license: BSD3 +license-file: LICENSE +author: Edsko de Vries , Andres Löh +maintainer: andres@well-typed.com +category: Generics +build-type: Custom +cabal-version: >=1.10 +extra-source-files: CHANGELOG.md +tested-with: GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1, GHC == 8.0.2, GHC == 8.2.1, GHC == 8.3.* + +custom-setup + setup-depends: + base, + Cabal, + cabal-doctest >= 1.0.2 && <1.1 + +source-repository head + type: git + location: https://github.com/well-typed/generics-sop + +library + exposed-modules: Generics.SOP + Generics.SOP.GGP + Generics.SOP.TH + Generics.SOP.Dict + Generics.SOP.Type.Metadata + -- exposed via Generics.SOP: + Generics.SOP.BasicFunctors + Generics.SOP.Classes + Generics.SOP.Constraint + Generics.SOP.Instances + Generics.SOP.Metadata + Generics.SOP.NP + Generics.SOP.NS + Generics.SOP.Universe + Generics.SOP.Sing + build-depends: base >= 4.7 && < 5, + template-haskell >= 2.8 && < 2.13, + ghc-prim >= 0.3 && < 0.6, + deepseq >= 1.3 && < 1.5 + if !impl (ghc >= 7.8) + build-depends: tagged >= 0.7 && < 0.9 + if !impl (ghc >= 8.0) + build-depends: transformers-compat >= 0.3 && < 0.6, + transformers >= 0.3 && < 0.6 + + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + default-extensions: CPP + ScopedTypeVariables + TypeFamilies + RankNTypes + TypeOperators + GADTs + ConstraintKinds + MultiParamTypeClasses + TypeSynonymInstances + FlexibleInstances + FlexibleContexts + DeriveFunctor + DeriveFoldable + DeriveTraversable + DefaultSignatures + KindSignatures + DataKinds + FunctionalDependencies + if impl (ghc >= 7.8) + default-extensions: AutoDeriveTypeable + other-extensions: OverloadedStrings + PolyKinds + UndecidableInstances + TemplateHaskell + DeriveGeneric + StandaloneDeriving + if impl (ghc < 7.10) + other-extensions: OverlappingInstances + +test-suite doctests + type: exitcode-stdio-1.0 + main-is: doctests.hs + x-doctest-options: --preserve-it + hs-source-dirs: test + default-language: Haskell2010 + build-depends: base, + doctest >= 0.13 && <0.14 + ghc-options: -Wall -threaded + +test-suite generics-sop-examples + type: exitcode-stdio-1.0 + main-is: Example.hs + other-modules: HTransExample + hs-source-dirs: test + default-language: Haskell2010 + ghc-options: -Wall + build-depends: base >= 4.6 && < 5, + generics-sop diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/generics-sop.expr b/cabal/Cabal-tests/tests/ParserTests/regressions/generics-sop.expr new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/generics-sop.expr @@ -0,0 +1,833 @@ +GenericPackageDescription { + packageDescription = + PackageDescription { + specVersion = CabalSpecV1_10, + package = PackageIdentifier { + pkgName = PackageName + "generics-sop", + pkgVersion = mkVersion + [0, 3, 1, 0]}, + licenseRaw = Right BSD3, + licenseFiles = [ + SymbolicPath "LICENSE"], + copyright = "", + maintainer = + "andres@well-typed.com", + author = + "Edsko de Vries , Andres L\246h ", + stability = "", + testedWith = [ + _×_ + GHC + (ThisVersion + (mkVersion [7, 8, 4])), + _×_ + GHC + (ThisVersion + (mkVersion [7, 10, 3])), + _×_ + GHC + (ThisVersion + (mkVersion [8, 0, 1])), + _×_ + GHC + (ThisVersion + (mkVersion [8, 0, 2])), + _×_ + GHC + (ThisVersion + (mkVersion [8, 2, 1])), + _×_ + GHC + (IntersectVersionRanges + (OrLaterVersion + (mkVersion [8, 3])) + (EarlierVersion + (mkVersion [8, 4])))], + homepage = "", + pkgUrl = "", + bugReports = "", + sourceRepos = [ + SourceRepo { + repoKind = RepoHead, + repoType = Just + (KnownRepoType Git), + repoLocation = Just + "https://github.com/well-typed/generics-sop", + repoModule = Nothing, + repoBranch = Nothing, + repoTag = Nothing, + repoSubdir = Nothing}], + synopsis = + "Generic Programming using True Sums of Products", + description = + concat + [ + "A library to support the definition of generic functions.\n", + "Datatypes are viewed in a uniform, structured way:\n", + "the choice between constructors is represented using an n-ary\n", + "sum, and the arguments of each constructor are represented using\n", + "an n-ary product.\n", + "\n", + "The module \"Generics.SOP\" is the main module of this library and contains\n", + "more detailed documentation.\n", + "\n", + "Examples of using this library are provided by the following\n", + "packages:\n", + "\n", + "* @@ basic examples,\n", + "\n", + "* @@ generic pretty printing,\n", + "\n", + "* @@ generically computed lenses,\n", + "\n", + "* @@ generic JSON conversions.\n", + "\n", + "A detailed description of the ideas behind this library is provided by\n", + "the paper:\n", + "\n", + "* Edsko de Vries and Andres L\246h.\n", + ".\n", + "Workshop on Generic Programming (WGP) 2014.\n"], + category = "Generics", + customFieldsPD = [], + buildTypeRaw = Just Custom, + setupBuildInfo = Just + SetupBuildInfo { + setupDepends = [ + Dependency + (PackageName "base") + (OrLaterVersion (mkVersion [0])) + mainLibSet, + Dependency + (PackageName "Cabal") + (OrLaterVersion (mkVersion [0])) + mainLibSet, + Dependency + (PackageName "cabal-doctest") + (IntersectVersionRanges + (OrLaterVersion + (mkVersion [1, 0, 2])) + (EarlierVersion + (mkVersion [1, 1]))) + mainLibSet], + defaultSetupDepends = False}, + library = Nothing, + subLibraries = [], + executables = [], + foreignLibs = [], + testSuites = [], + benchmarks = [], + dataFiles = [], + dataDir = ".", + extraSrcFiles = [ + "CHANGELOG.md"], + extraTmpFiles = [], + extraDocFiles = []}, + gpdScannedVersion = Nothing, + genPackageFlags = [], + condLibrary = Just + CondNode { + condTreeData = Library { + libName = LMainLibName, + exposedModules = [ + ModuleName "Generics.SOP", + ModuleName "Generics.SOP.GGP", + ModuleName "Generics.SOP.TH", + ModuleName "Generics.SOP.Dict", + ModuleName + "Generics.SOP.Type.Metadata", + ModuleName + "Generics.SOP.BasicFunctors", + ModuleName + "Generics.SOP.Classes", + ModuleName + "Generics.SOP.Constraint", + ModuleName + "Generics.SOP.Instances", + ModuleName + "Generics.SOP.Metadata", + ModuleName "Generics.SOP.NP", + ModuleName "Generics.SOP.NS", + ModuleName + "Generics.SOP.Universe", + ModuleName "Generics.SOP.Sing"], + reexportedModules = [], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPublic, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [ + SymbolicPath "src"], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Just + Haskell2010, + otherLanguages = [], + defaultExtensions = [ + EnableExtension CPP, + EnableExtension + ScopedTypeVariables, + EnableExtension TypeFamilies, + EnableExtension RankNTypes, + EnableExtension TypeOperators, + EnableExtension GADTs, + EnableExtension ConstraintKinds, + EnableExtension + MultiParamTypeClasses, + EnableExtension + TypeSynonymInstances, + EnableExtension + FlexibleInstances, + EnableExtension + FlexibleContexts, + EnableExtension DeriveFunctor, + EnableExtension DeriveFoldable, + EnableExtension + DeriveTraversable, + EnableExtension + DefaultSignatures, + EnableExtension KindSignatures, + EnableExtension DataKinds, + EnableExtension + FunctionalDependencies], + otherExtensions = [ + EnableExtension + OverloadedStrings, + EnableExtension PolyKinds, + EnableExtension + UndecidableInstances, + EnableExtension TemplateHaskell, + EnableExtension DeriveGeneric, + EnableExtension + StandaloneDeriving], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + ["-Wall"] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + 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], + 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 = + `CNot (Var (Impl GHC (OrLaterVersion (mkVersion [7,8]))))`, + condBranchIfTrue = CondNode { + condTreeData = Library { + libName = LMainLibName, + exposedModules = [], + reexportedModules = [], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPublic, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + Dependency + (PackageName "tagged") + (IntersectVersionRanges + (OrLaterVersion + (mkVersion [0, 7])) + (EarlierVersion + (mkVersion [0, 9]))) + mainLibSet], + mixins = []}}, + condTreeConstraints = [ + Dependency + (PackageName "tagged") + (IntersectVersionRanges + (OrLaterVersion + (mkVersion [0, 7])) + (EarlierVersion + (mkVersion [0, 9]))) + mainLibSet], + condTreeComponents = []}, + condBranchIfFalse = Nothing}, + CondBranch { + condBranchCondition = + `CNot (Var (Impl GHC (OrLaterVersion (mkVersion [8,0]))))`, + condBranchIfTrue = CondNode { + condTreeData = Library { + libName = LMainLibName, + exposedModules = [], + reexportedModules = [], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPublic, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + 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], + 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 { + condBranchCondition = + `Var (Impl GHC (OrLaterVersion (mkVersion [7,8])))`, + condBranchIfTrue = CondNode { + condTreeData = Library { + libName = LMainLibName, + exposedModules = [], + reexportedModules = [], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPublic, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [ + EnableExtension + AutoDeriveTypeable], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [], + mixins = []}}, + condTreeConstraints = [], + condTreeComponents = []}, + condBranchIfFalse = Nothing}, + CondBranch { + condBranchCondition = + `Var (Impl GHC (EarlierVersion (mkVersion [7,10])))`, + condBranchIfTrue = CondNode { + condTreeData = Library { + libName = LMainLibName, + exposedModules = [], + reexportedModules = [], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPublic, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [ + EnableExtension + OverlappingInstances], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [], + mixins = []}}, + condTreeConstraints = [], + condTreeComponents = []}, + condBranchIfFalse = Nothing}]}, + condSubLibraries = [], + condForeignLibs = [], + condExecutables = [], + condTestSuites = [ + _×_ + (UnqualComponentName "doctests") + CondNode { + condTreeData = TestSuite { + testName = UnqualComponentName + "", + testInterface = TestSuiteExeV10 + (mkVersion [1, 0]) + "doctests.hs", + testBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [ + SymbolicPath "test"], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Just + Haskell2010, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + ["-Wall", "-threaded"] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [ + _×_ + "x-doctest-options" + "--preserve-it"], + targetBuildDepends = [ + Dependency + (PackageName "base") + (OrLaterVersion (mkVersion [0])) + mainLibSet, + Dependency + (PackageName "doctest") + (IntersectVersionRanges + (OrLaterVersion + (mkVersion [0, 13])) + (EarlierVersion + (mkVersion [0, 14]))) + 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 + "generics-sop-examples") + CondNode { + condTreeData = TestSuite { + testName = UnqualComponentName + "", + testInterface = TestSuiteExeV10 + (mkVersion [1, 0]) + "Example.hs", + testBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [ + SymbolicPath "test"], + otherModules = [ + ModuleName "HTransExample"], + virtualModules = [], + autogenModules = [], + defaultLanguage = Just + Haskell2010, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + ["-Wall"] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + Dependency + (PackageName "base") + (IntersectVersionRanges + (OrLaterVersion + (mkVersion [4, 6])) + (EarlierVersion + (mkVersion [5]))) + mainLibSet, + Dependency + (PackageName "generics-sop") + (OrLaterVersion (mkVersion [0])) + 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/Cabal-tests/tests/ParserTests/regressions/generics-sop.format b/cabal/Cabal-tests/tests/ParserTests/regressions/generics-sop.format new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/generics-sop.format @@ -0,0 +1,129 @@ +cabal-version: >=1.10 +name: generics-sop +version: 0.3.1.0 +license: BSD3 +license-file: LICENSE +maintainer: andres@well-typed.com +author: + Edsko de Vries , Andres Löh + +tested-with: + ghc ==7.8.4 ghc ==7.10.3 ghc ==8.0.1 ghc ==8.0.2 ghc ==8.2.1 + ghc >=8.3 && <8.4 + +synopsis: Generic Programming using True Sums of Products +description: + A library to support the definition of generic functions. + Datatypes are viewed in a uniform, structured way: + the choice between constructors is represented using an n-ary + sum, and the arguments of each constructor are represented using + an n-ary product. + . + The module "Generics.SOP" is the main module of this library and contains + more detailed documentation. + . + Examples of using this library are provided by the following + packages: + . + * @@ basic examples, + . + * @@ generic pretty printing, + . + * @@ generically computed lenses, + . + * @@ generic JSON conversions. + . + A detailed description of the ideas behind this library is provided by + the paper: + . + * Edsko de Vries and Andres Löh. + . + Workshop on Generic Programming (WGP) 2014. + . + +category: Generics +build-type: Custom +extra-source-files: CHANGELOG.md + +source-repository head + type: git + location: https://github.com/well-typed/generics-sop + +custom-setup + setup-depends: + base, + Cabal, + cabal-doctest >=1.0.2 && <1.1 + +library + exposed-modules: + Generics.SOP + Generics.SOP.GGP + Generics.SOP.TH + Generics.SOP.Dict + Generics.SOP.Type.Metadata + Generics.SOP.BasicFunctors + Generics.SOP.Classes + Generics.SOP.Constraint + Generics.SOP.Instances + Generics.SOP.Metadata + Generics.SOP.NP + Generics.SOP.NS + Generics.SOP.Universe + Generics.SOP.Sing + + hs-source-dirs: src + default-language: Haskell2010 + default-extensions: + CPP ScopedTypeVariables TypeFamilies RankNTypes TypeOperators GADTs + ConstraintKinds MultiParamTypeClasses TypeSynonymInstances + FlexibleInstances FlexibleContexts DeriveFunctor DeriveFoldable + DeriveTraversable DefaultSignatures KindSignatures DataKinds + FunctionalDependencies + + other-extensions: + OverloadedStrings PolyKinds UndecidableInstances TemplateHaskell + DeriveGeneric StandaloneDeriving + + ghc-options: -Wall + build-depends: + base >=4.7 && <5, + template-haskell >=2.8 && <2.13, + ghc-prim >=0.3 && <0.6, + deepseq >=1.3 && <1.5 + + if !impl(ghc >=7.8) + build-depends: tagged >=0.7 && <0.9 + + if !impl(ghc >=8.0) + build-depends: + transformers-compat >=0.3 && <0.6, + transformers >=0.3 && <0.6 + + if impl(ghc >=7.8) + default-extensions: AutoDeriveTypeable + + if impl(ghc <7.10) + other-extensions: OverlappingInstances + +test-suite doctests + type: exitcode-stdio-1.0 + main-is: doctests.hs + hs-source-dirs: test + default-language: Haskell2010 + ghc-options: -Wall -threaded + x-doctest-options: --preserve-it + build-depends: + base, + doctest >=0.13 && <0.14 + +test-suite generics-sop-examples + type: exitcode-stdio-1.0 + main-is: Example.hs + hs-source-dirs: test + other-modules: HTransExample + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + base >=4.6 && <5, + generics-sop diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/ghc-option-j.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/ghc-option-j.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/ghc-option-j.cabal @@ -0,0 +1,18 @@ +cabal-version: 2.2 +name: ghc-option-j +version: 0 +license: BSD-2-Clause +synopsis: Test +description: Testy test. +maintainer: none +category: none + +library + exposed-modules: Foo + ghc-options: -Wall -j -Wno-all + default-language: Haskell2010 + +executable foo + main-is: Main.hs + ghc-shared-options: -Wall -j2 -Wno-all + default-language: Haskell2010 diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/ghc-option-j.check b/cabal/Cabal-tests/tests/ParserTests/regressions/ghc-option-j.check new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/ghc-option-j.check @@ -0,0 +1,2 @@ +'ghc-options: -j[N]' can make sense for specific user's setup, but it is not appropriate for a distributed package. Alternatively, if you want to use this, make it conditional based on a Cabal configuration flag (with 'manual: True' and 'default: False') and enable that flag during development. +'ghc-shared-options: -j[N]' can make sense for specific user's setup, but it is not appropriate for a distributed package. Alternatively, if you want to use this, make it conditional based on a Cabal configuration flag (with 'manual: True' and 'default: False') and enable that flag during development. diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/globstar-literal.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/globstar-literal.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/globstar-literal.cabal @@ -0,0 +1,16 @@ +cabal-version: 3.8 +name: globstar-literal +version: 0 +extra-source-files: + foo/**/bar + +license: BSD-3-Clause +synopsis: no +description: none +category: Test +maintainer: none + +library + default-language: Haskell2010 + exposed-modules: + Foo diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/globstar-literal.check b/cabal/Cabal-tests/tests/ParserTests/regressions/globstar-literal.check new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/globstar-literal.check diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/haddock-api-2.18.1-check.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/haddock-api-2.18.1-check.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/haddock-api-2.18.1-check.cabal @@ -0,0 +1,147 @@ +name: haddock-api +version: 2.18.1 +synopsis: A documentation-generation tool for Haskell libraries +description: Haddock is a documentation-generation tool for Haskell + libraries +license: BSD3 +license-file: LICENSE +author: Simon Marlow, David Waern +maintainer: Alex Biehl , Simon Hengel , Mateusz Kowalczyk +homepage: http://www.haskell.org/haddock/ +bug-reports: https://github.com/haskell/haddock/issues +copyright: (c) Simon Marlow, David Waern +category: Documentation +build-type: Simple +cabal-version: >= 1.10 + +extra-source-files: + CHANGES.md + +data-dir: + resources +data-files: + html/solarized.css + html/haddock-util.js + html/highlight.js + html/Classic.theme/haskell_icon.gif + html/Classic.theme/minus.gif + html/Classic.theme/plus.gif + html/Classic.theme/xhaddock.css + html/Ocean.std-theme/hslogo-16.png + html/Ocean.std-theme/minus.gif + html/Ocean.std-theme/ocean.css + html/Ocean.std-theme/plus.gif + html/Ocean.std-theme/synopsis.png + latex/haddock.sty + +library + default-language: Haskell2010 + + -- this package typically supports only single major versions + build-depends: base ^>= 4.10.0 + , Cabal ^>= 2.0.0 + , ghc ^>= 8.2 + , ghc-paths ^>= 0.1.0.9 + , haddock-library == 1.4.4.* + , xhtml ^>= 3000.2.2 + + -- Versions for the dependencies below are transitively pinned by + -- the non-reinstallable `ghc` package and hence need no version + -- bounds + build-depends: array + , bytestring + , containers + , deepseq + , directory + , filepath + , ghc-boot + , transformers + + hs-source-dirs: src + + ghc-options: -funbox-strict-fields -Wall -fwarn-tabs -O2 + ghc-options: -Wall + if impl(ghc >= 8.0) + ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances + + exposed-modules: + Documentation.Haddock + + other-modules: + Haddock + Haddock.Interface + Haddock.Interface.Rename + Haddock.Interface.Create + Haddock.Interface.AttachInstances + Haddock.Interface.LexParseRn + Haddock.Interface.ParseModuleHeader + Haddock.Interface.Specialize + Haddock.Parser + Haddock.Utils + Haddock.Backends.Xhtml + Haddock.Backends.Xhtml.Decl + Haddock.Backends.Xhtml.DocMarkup + Haddock.Backends.Xhtml.Layout + Haddock.Backends.Xhtml.Names + Haddock.Backends.Xhtml.Themes + Haddock.Backends.Xhtml.Types + Haddock.Backends.Xhtml.Utils + Haddock.Backends.LaTeX + Haddock.Backends.HaddockDB + Haddock.Backends.Hoogle + Haddock.Backends.Hyperlinker + Haddock.Backends.Hyperlinker.Ast + Haddock.Backends.Hyperlinker.Parser + Haddock.Backends.Hyperlinker.Renderer + Haddock.Backends.Hyperlinker.Types + Haddock.Backends.Hyperlinker.Utils + Haddock.ModuleTree + Haddock.Types + Haddock.Doc + Haddock.Version + Haddock.InterfaceFile + Haddock.Options + Haddock.GhcUtils + Haddock.Syb + Haddock.Convert + Paths_haddock_api + + autogen-modules: + Paths_haddock_api + +test-suite spec + type: exitcode-stdio-1.0 + default-language: Haskell2010 + main-is: Spec.hs + ghc-options: -Wall + + hs-source-dirs: + test + , src + + -- NB: We only use a small subset of lib:haddock-api here, which + -- explains why this component has a smaller build-depends set + other-modules: + Haddock.Backends.Hyperlinker.ParserSpec + Haddock.Backends.Hyperlinker.Parser + Haddock.Backends.Hyperlinker.Types + + build-depends: + ghc ^>= 8.2 + , hspec ^>= 2.4.4 + , QuickCheck ^>= 2.10 + + -- Versions for the dependencies below are transitively pinned by + -- the non-reinstallable `ghc` package and hence need no version + -- bounds + build-depends: + base + , containers + + build-tool-depends: + hspec-discover:hspec-discover ^>= 2.4.4 + +source-repository head + type: git + subdir: haddock-api + location: https://github.com/haskell/haddock.git diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/haddock-api-2.18.1-check.check b/cabal/Cabal-tests/tests/ParserTests/regressions/haddock-api-2.18.1-check.check new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/haddock-api-2.18.1-check.check @@ -0,0 +1,4 @@ +ERROR: haddock-api-2.18.1-check.cabal:41:44: +unexpected major bounded version syntax (caret, ^>=) used. To use this syntax the package need to specify at least 'cabal-version: 2.0'. Alternatively, if broader compatibility is important then use: >=4.10.0 && <4.11 +expecting "." or "-" + diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/hasktorch.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/hasktorch.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/hasktorch.cabal @@ -0,0 +1,558 @@ +cabal-version: 2.2 +-- ================================================================ -- +-- ======== This cabal file has been modified from dhall ========== -- +-- ======== This constitutes the 0.0.1.0 release. ========== -- +-- ======== Dhall can generate this file, but will never ========== -- +-- ======== be able to upload to hackage. For more, see: ========== -- +-- ==== https://github.com/haskell/hackage-server/issues/795 ====== -- +-- ================================================================ -- +name: hasktorch +version: 0.0.1.0 +license: BSD-3-Clause +maintainer: Sam Stites , Austin Huang - cipher:ROT13 +author: Hasktorch dev team +homepage: https://github.com/hasktorch/hasktorch#readme +bug-reports: https://github.com/hasktorch/hasktorch/issues +synopsis: Torch for tensors and neural networks in Haskell +description: + Hasktorch is a library for tensors and neural networks in Haskell. It is an independent open source community project which leverages the core C libraries shared by Torch and PyTorch. This library leverages @cabal v2-build@ and @backpack@. *Note that this project is in early development and should only be used by contributing developers. Expect substantial changes to the library API as it evolves. Contributions and PRs are welcome (see details on github).* +category: Tensors, Machine Learning, AI +build-type: Simple + +source-repository head + type: git + location: https://github.com/hasktorch/hasktorch + +flag cuda + description: + build with THC support + default: False + +flag lite + description: + only build with Double and Long support + default: False + +library + exposed-modules: + Torch.Core.Exceptions + Torch.Core.Random + Torch.Core.LogAdd + reexported-modules: Torch.Types.Numeric, + Torch.Long, + Torch.Long.Dynamic, + Torch.Long.Storage, + Torch.Double, + Torch.Double.Dynamic, + Torch.Double.Storage, + Torch.Double.NN, + Torch.Double.NN.Activation, + Torch.Double.NN.Backprop, + Torch.Double.NN.Conv1d, + Torch.Double.NN.Conv2d, + Torch.Double.NN.Criterion, + Torch.Double.NN.Layers, + Torch.Double.NN.Linear, + Torch.Double.NN.Math, + Torch.Double.NN.Padding, + Torch.Double.NN.Pooling, + Torch.Double.NN.Sampling, + Torch.Double.Dynamic.NN, + Torch.Double.Dynamic.NN.Activation, + Torch.Double.Dynamic.NN.Pooling, + Torch.Double.Dynamic.NN.Criterion + hs-source-dirs: utils + default-language: Haskell2010 + default-extensions: LambdaCase DataKinds TypeFamilies + TypeSynonymInstances ScopedTypeVariables FlexibleContexts CPP + build-depends: + base (==4.7 || >4.7) && <5, + -- containers ==0.5.10 || >0.5.10, + -- deepseq ==1.3.0 || >1.3.0, + dimensions ==1.0 || >1.0, + -- managed (==1.0.0 || >1.0.0) && <1.1, + -- microlens ==0.4.8 || >0.4.8, + -- numeric-limits ==0.1.0 || >0.1.0, + safe-exceptions ==0.1.0 || >0.1.0, + singletons ==2.2 || >2.2, + text ==1.2.2 || >1.2.2, + -- typelits-witnesses ==0.2.3 || >0.2.3, + hasktorch-cpu -any, + hasktorch-ffi-th (==0.0.1 || >0.0.1) && <0.0.2, + hasktorch-types-th (==0.0.1 || >0.0.1) && <0.0.2 + + -- <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><> -- + -- BEGIN EDITS + -- <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><> -- + if !flag(lite) + reexported-modules: + Torch.Byte, + Torch.Byte.Dynamic, + Torch.Byte.Storage, + Torch.Char, + Torch.Char.Dynamic, + Torch.Char.Storage, + Torch.Short, + Torch.Short.Dynamic, + Torch.Short.Storage, + Torch.Int, + Torch.Int.Dynamic, + Torch.Int.Storage, + Torch.Float, + Torch.Float.Dynamic, + Torch.Float.Storage + + if flag(cuda) + build-depends: + hasktorch-gpu -any + reexported-modules: + Torch.Cuda.Long, + Torch.Cuda.Long.Dynamic, + Torch.Cuda.Long.Storage, + Torch.Cuda.Double, + Torch.Cuda.Double.Dynamic, + Torch.Cuda.Double.Storage, + Torch.Cuda.Double.NN, + Torch.Cuda.Double.NN.Activation, + Torch.Cuda.Double.NN.Backprop, + Torch.Cuda.Double.NN.Conv1d, + Torch.Cuda.Double.NN.Conv2d, + Torch.Cuda.Double.NN.Criterion, + Torch.Cuda.Double.NN.Layers, + Torch.Cuda.Double.NN.Linear, + Torch.Cuda.Double.NN.Math, + Torch.Cuda.Double.NN.Padding, + Torch.Cuda.Double.NN.Pooling, + Torch.Cuda.Double.NN.Sampling, + Torch.Cuda.Double.Dynamic.NN, + Torch.Cuda.Double.Dynamic.NN.Activation, + Torch.Cuda.Double.Dynamic.NN.Pooling, + Torch.Cuda.Double.Dynamic.NN.Criterion + if !flag(lite) + reexported-modules: + Torch.Cuda.Byte, + Torch.Cuda.Byte.Dynamic, + Torch.Cuda.Byte.Storage, + Torch.Cuda.Char, + Torch.Cuda.Char.Dynamic, + Torch.Cuda.Char.Storage, + Torch.Cuda.Short, + Torch.Cuda.Short.Dynamic, + Torch.Cuda.Short.Storage, + Torch.Cuda.Int, + Torch.Cuda.Int.Dynamic, + Torch.Cuda.Int.Storage, + Torch.Cuda.Float, + Torch.Cuda.Float.Dynamic, + Torch.Cuda.Float.Storage + -- <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><> -- + -- END EDITS + -- <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><> -- + +library hasktorch-cpu + exposed-modules: + Torch.Long + Torch.Long.Dynamic + Torch.Long.Storage + Torch.Double + Torch.Double.Dynamic + Torch.Double.Storage + reexported-modules: Torch.Double.NN, + Torch.Double.NN.Activation, + Torch.Double.NN.Backprop, + Torch.Double.NN.Conv1d, + Torch.Double.NN.Conv2d, + Torch.Double.NN.Criterion, + Torch.Double.NN.Layers, + Torch.Double.NN.Linear, + Torch.Double.NN.Math, + Torch.Double.NN.Padding, + Torch.Double.NN.Pooling, + Torch.Double.NN.Sampling, + Torch.Double.Dynamic.NN, + Torch.Double.Dynamic.NN.Activation, + Torch.Double.Dynamic.NN.Pooling, + Torch.Double.Dynamic.NN.Criterion, + Torch.Float.NN, + Torch.Float.NN.Activation, + Torch.Float.NN.Backprop, + Torch.Float.NN.Conv1d, + Torch.Float.NN.Conv2d, + Torch.Float.NN.Criterion, + Torch.Float.NN.Layers, + Torch.Float.NN.Linear, + Torch.Float.NN.Math, + Torch.Float.NN.Padding, + Torch.Float.NN.Pooling, + Torch.Float.NN.Sampling, + Torch.Float.Dynamic.NN, + Torch.Float.Dynamic.NN.Activation, + Torch.Float.Dynamic.NN.Pooling, + Torch.Float.Dynamic.NN.Criterion + hs-source-dirs: utils src + other-modules: + Torch.Core.Exceptions + Torch.Core.Random + Torch.Core.LogAdd + default-language: Haskell2010 + default-extensions: LambdaCase DataKinds TypeFamilies + TypeSynonymInstances ScopedTypeVariables FlexibleContexts CPP + build-depends: + base (==4.7 || >4.7) && <5, + hasktorch-types-th (==0.0.1 || >0.0.1) && <0.0.2, + -- containers ==0.5.10 || >0.5.10, + -- deepseq ==1.3.0 || >1.3.0, + dimensions ==1.0 || >1.0, + hasktorch-ffi-th (==0.0.1 || >0.0.1) && <0.0.2, + hasktorch-types-th (==0.0.1 || >0.0.1) && <0.0.2, + -- managed (==1.0.0 || >1.0.0) && <1.1, + -- microlens ==0.4.8 || >0.4.8, + -- numeric-limits ==0.1.0 || >0.1.0, + safe-exceptions ==0.1.0 || >0.1.0, + singletons ==2.2 || >2.2, + text ==1.2.2 || >1.2.2, + -- typelits-witnesses ==0.2.3 || >0.2.3, + hasktorch-indef-floating -any, + hasktorch-indef-signed -any + mixins: hasktorch-indef-signed (Torch.Indef.Storage as Torch.Indef.Long.Storage, Torch.Indef.Storage.Copy as Torch.Indef.Long.Storage.Copy, Torch.Indef.Static.Tensor as Torch.Indef.Long.Tensor, Torch.Indef.Static.Tensor.Copy as Torch.Indef.Long.Tensor.Copy, Torch.Indef.Static.Tensor.Index as Torch.Indef.Long.Tensor.Index, Torch.Indef.Static.Tensor.Masked as Torch.Indef.Long.Tensor.Masked, Torch.Indef.Static.Tensor.Math as Torch.Indef.Long.Tensor.Math, Torch.Indef.Static.Tensor.Math.Compare as Torch.Indef.Long.Tensor.Math.Compare, Torch.Indef.Static.Tensor.Math.CompareT as Torch.Indef.Long.Tensor.Math.CompareT, Torch.Indef.Static.Tensor.Math.Pairwise as Torch.Indef.Long.Tensor.Math.Pairwise, Torch.Indef.Static.Tensor.Math.Pointwise as Torch.Indef.Long.Tensor.Math.Pointwise, Torch.Indef.Static.Tensor.Math.Reduce as Torch.Indef.Long.Tensor.Math.Reduce, Torch.Indef.Static.Tensor.Math.Scan as Torch.Indef.Long.Tensor.Math.Scan, Torch.Indef.Static.Tensor.Mode as Torch.Indef.Long.Tensor.Mode, Torch.Indef.Static.Tensor.ScatterGather as Torch.Indef.Long.Tensor.ScatterGather, Torch.Indef.Static.Tensor.Sort as Torch.Indef.Long.Tensor.Sort, Torch.Indef.Static.Tensor.TopK as Torch.Indef.Long.Tensor.TopK, Torch.Indef.Dynamic.Tensor as Torch.Indef.Long.Dynamic.Tensor, Torch.Indef.Dynamic.Tensor.Copy as Torch.Indef.Long.Dynamic.Tensor.Copy, Torch.Indef.Dynamic.Tensor.Index as Torch.Indef.Long.Dynamic.Tensor.Index, Torch.Indef.Dynamic.Tensor.Masked as Torch.Indef.Long.Dynamic.Tensor.Masked, Torch.Indef.Dynamic.Tensor.Math as Torch.Indef.Long.Dynamic.Tensor.Math, Torch.Indef.Dynamic.Tensor.Math.Compare as Torch.Indef.Long.Dynamic.Tensor.Math.Compare, Torch.Indef.Dynamic.Tensor.Math.CompareT as Torch.Indef.Long.Dynamic.Tensor.Math.CompareT, Torch.Indef.Dynamic.Tensor.Math.Pairwise as Torch.Indef.Long.Dynamic.Tensor.Math.Pairwise, Torch.Indef.Dynamic.Tensor.Math.Pointwise as Torch.Indef.Long.Dynamic.Tensor.Math.Pointwise, Torch.Indef.Dynamic.Tensor.Math.Reduce as Torch.Indef.Long.Dynamic.Tensor.Math.Reduce, Torch.Indef.Dynamic.Tensor.Math.Scan as Torch.Indef.Long.Dynamic.Tensor.Math.Scan, Torch.Indef.Dynamic.Tensor.Mode as Torch.Indef.Long.Dynamic.Tensor.Mode, Torch.Indef.Dynamic.Tensor.ScatterGather as Torch.Indef.Long.Dynamic.Tensor.ScatterGather, Torch.Indef.Dynamic.Tensor.Sort as Torch.Indef.Long.Dynamic.Tensor.Sort, Torch.Indef.Dynamic.Tensor.TopK as Torch.Indef.Long.Dynamic.Tensor.TopK, Torch.Indef.Types as Torch.Long.Types, Torch.Indef.Index as Torch.Long.Index, Torch.Indef.Mask as Torch.Long.Mask, Torch.Indef.Static.Tensor.Math.Pointwise.Signed as Torch.Indef.Long.Tensor.Math.Pointwise.Signed, Torch.Indef.Dynamic.Tensor.Math.Pointwise.Signed as Torch.Indef.Long.Dynamic.Tensor.Math.Pointwise.Signed) requires (Torch.Sig.Index.Tensor as Torch.FFI.TH.Long.Tensor, Torch.Sig.Index.TensorFree as Torch.FFI.TH.Long.FreeTensor, Torch.Sig.Mask.Tensor as Torch.FFI.TH.Byte.Tensor, Torch.Sig.Mask.TensorFree as Torch.FFI.TH.Byte.FreeTensor, Torch.Sig.Mask.MathReduce as Torch.FFI.TH.Byte.TensorMath, Torch.Sig.State as Torch.Types.TH, Torch.Sig.Types.Global as Torch.Types.TH, Torch.Sig.Types as Torch.Types.TH.Long, Torch.Sig.Storage as Torch.FFI.TH.Long.Storage, Torch.Sig.Storage.Copy as Torch.FFI.TH.Long.StorageCopy, Torch.Sig.Storage.Memory as Torch.FFI.TH.Long.FreeStorage, Torch.Sig.Tensor as Torch.FFI.TH.Long.Tensor, Torch.Sig.Tensor.Copy as Torch.FFI.TH.Long.TensorCopy, Torch.Sig.Tensor.Memory as Torch.FFI.TH.Long.FreeTensor, Torch.Sig.Tensor.Index as Torch.FFI.TH.Long.TensorMath, Torch.Sig.Tensor.Masked as Torch.FFI.TH.Long.TensorMath, Torch.Sig.Tensor.Math as Torch.FFI.TH.Long.TensorMath, Torch.Sig.Tensor.Math.Compare as Torch.FFI.TH.Long.TensorMath, Torch.Sig.Tensor.Math.CompareT as Torch.FFI.TH.Long.TensorMath, Torch.Sig.Tensor.Math.Pairwise as Torch.FFI.TH.Long.TensorMath, Torch.Sig.Tensor.Math.Pointwise as Torch.FFI.TH.Long.TensorMath, Torch.Sig.Tensor.Math.Reduce as Torch.FFI.TH.Long.TensorMath, Torch.Sig.Tensor.Math.Scan as Torch.FFI.TH.Long.TensorMath, Torch.Sig.Tensor.Mode as Torch.FFI.TH.Long.TensorMath, Torch.Sig.Tensor.ScatterGather as Torch.FFI.TH.Long.TensorMath, Torch.Sig.Tensor.Sort as Torch.FFI.TH.Long.TensorMath, Torch.Sig.Tensor.TopK as Torch.FFI.TH.Long.TensorMath, Torch.Sig.Tensor.Math.Pointwise.Signed as Torch.FFI.TH.Long.TensorMath), + hasktorch-indef-floating (Torch.Indef.Storage as Torch.Indef.Double.Storage, Torch.Indef.Storage.Copy as Torch.Indef.Double.Storage.Copy, Torch.Indef.Static.Tensor as Torch.Indef.Double.Tensor, Torch.Indef.Static.Tensor.Copy as Torch.Indef.Double.Tensor.Copy, Torch.Indef.Static.Tensor.Index as Torch.Indef.Double.Tensor.Index, Torch.Indef.Static.Tensor.Masked as Torch.Indef.Double.Tensor.Masked, Torch.Indef.Static.Tensor.Math as Torch.Indef.Double.Tensor.Math, Torch.Indef.Static.Tensor.Math.Compare as Torch.Indef.Double.Tensor.Math.Compare, Torch.Indef.Static.Tensor.Math.CompareT as Torch.Indef.Double.Tensor.Math.CompareT, Torch.Indef.Static.Tensor.Math.Pairwise as Torch.Indef.Double.Tensor.Math.Pairwise, Torch.Indef.Static.Tensor.Math.Pointwise as Torch.Indef.Double.Tensor.Math.Pointwise, Torch.Indef.Static.Tensor.Math.Reduce as Torch.Indef.Double.Tensor.Math.Reduce, Torch.Indef.Static.Tensor.Math.Scan as Torch.Indef.Double.Tensor.Math.Scan, Torch.Indef.Static.Tensor.Mode as Torch.Indef.Double.Tensor.Mode, Torch.Indef.Static.Tensor.ScatterGather as Torch.Indef.Double.Tensor.ScatterGather, Torch.Indef.Static.Tensor.Sort as Torch.Indef.Double.Tensor.Sort, Torch.Indef.Static.Tensor.TopK as Torch.Indef.Double.Tensor.TopK, Torch.Indef.Dynamic.Tensor as Torch.Indef.Double.Dynamic.Tensor, Torch.Indef.Dynamic.Tensor.Copy as Torch.Indef.Double.Dynamic.Tensor.Copy, Torch.Indef.Dynamic.Tensor.Index as Torch.Indef.Double.Dynamic.Tensor.Index, Torch.Indef.Dynamic.Tensor.Masked as Torch.Indef.Double.Dynamic.Tensor.Masked, Torch.Indef.Dynamic.Tensor.Math as Torch.Indef.Double.Dynamic.Tensor.Math, Torch.Indef.Dynamic.Tensor.Math.Compare as Torch.Indef.Double.Dynamic.Tensor.Math.Compare, Torch.Indef.Dynamic.Tensor.Math.CompareT as Torch.Indef.Double.Dynamic.Tensor.Math.CompareT, Torch.Indef.Dynamic.Tensor.Math.Pairwise as Torch.Indef.Double.Dynamic.Tensor.Math.Pairwise, Torch.Indef.Dynamic.Tensor.Math.Pointwise as Torch.Indef.Double.Dynamic.Tensor.Math.Pointwise, Torch.Indef.Dynamic.Tensor.Math.Reduce as Torch.Indef.Double.Dynamic.Tensor.Math.Reduce, Torch.Indef.Dynamic.Tensor.Math.Scan as Torch.Indef.Double.Dynamic.Tensor.Math.Scan, Torch.Indef.Dynamic.Tensor.Mode as Torch.Indef.Double.Dynamic.Tensor.Mode, Torch.Indef.Dynamic.Tensor.ScatterGather as Torch.Indef.Double.Dynamic.Tensor.ScatterGather, Torch.Indef.Dynamic.Tensor.Sort as Torch.Indef.Double.Dynamic.Tensor.Sort, Torch.Indef.Dynamic.Tensor.TopK as Torch.Indef.Double.Dynamic.Tensor.TopK, Torch.Indef.Types as Torch.Double.Types, Torch.Indef.Index as Torch.Double.Index, Torch.Indef.Mask as Torch.Double.Mask, Torch.Indef.Static.Tensor.Math.Pointwise.Signed as Torch.Indef.Double.Tensor.Math.Pointwise.Signed, Torch.Indef.Dynamic.Tensor.Math.Pointwise.Signed as Torch.Indef.Double.Dynamic.Tensor.Math.Pointwise.Signed, Torch.Indef.Dynamic.Tensor.Math.Blas as Torch.Indef.Double.Dynamic.Tensor.Math.Blas, Torch.Indef.Dynamic.Tensor.Math.Lapack as Torch.Indef.Double.Dynamic.Tensor.Math.Lapack, Torch.Indef.Dynamic.Tensor.Math.Pointwise.Floating as Torch.Indef.Double.Dynamic.Tensor.Math.Pointwise.Floating, Torch.Indef.Dynamic.Tensor.Math.Reduce.Floating as Torch.Indef.Double.Dynamic.Tensor.Math.Reduce.Floating, Torch.Indef.Dynamic.Tensor.Math.Floating as Torch.Indef.Double.Dynamic.Tensor.Math.Floating, Torch.Indef.Static.Tensor.Math.Blas as Torch.Indef.Double.Tensor.Math.Blas, Torch.Indef.Static.Tensor.Math.Lapack as Torch.Indef.Double.Tensor.Math.Lapack, Torch.Indef.Static.Tensor.Math.Pointwise.Floating as Torch.Indef.Double.Tensor.Math.Pointwise.Floating, Torch.Indef.Static.Tensor.Math.Reduce.Floating as Torch.Indef.Double.Tensor.Math.Reduce.Floating, Torch.Indef.Static.Tensor.Math.Floating as Torch.Indef.Double.Tensor.Math.Floating, Torch.Indef.Static.Tensor.Random.TH as Torch.Indef.Double.Tensor.Random.TH, Torch.Indef.Static.Tensor.Math.Random.TH as Torch.Indef.Double.Tensor.Math.Random.TH, Torch.Indef.Dynamic.Tensor.Random.TH as Torch.Indef.Double.Dynamic.Tensor.Random.TH, Torch.Indef.Dynamic.Tensor.Math.Random.TH as Torch.Indef.Double.Dynamic.Tensor.Math.Random.TH, Torch.Undefined.Tensor.Random.THC as Torch.Undefined.Double.Tensor.Random.THC, Torch.Indef.Storage as Torch.Indef.Double.Storage, Torch.Indef.Storage.Copy as Torch.Indef.Double.Storage.Copy, Torch.Indef.Static.Tensor as Torch.Indef.Double.Tensor, Torch.Indef.Static.Tensor.Copy as Torch.Indef.Double.Tensor.Copy, Torch.Indef.Static.Tensor.Index as Torch.Indef.Double.Tensor.Index, Torch.Indef.Static.Tensor.Masked as Torch.Indef.Double.Tensor.Masked, Torch.Indef.Static.Tensor.Math as Torch.Indef.Double.Tensor.Math, Torch.Indef.Static.Tensor.Math.Compare as Torch.Indef.Double.Tensor.Math.Compare, Torch.Indef.Static.Tensor.Math.CompareT as Torch.Indef.Double.Tensor.Math.CompareT, Torch.Indef.Static.Tensor.Math.Pairwise as Torch.Indef.Double.Tensor.Math.Pairwise, Torch.Indef.Static.Tensor.Math.Pointwise as Torch.Indef.Double.Tensor.Math.Pointwise, Torch.Indef.Static.Tensor.Math.Reduce as Torch.Indef.Double.Tensor.Math.Reduce, Torch.Indef.Static.Tensor.Math.Scan as Torch.Indef.Double.Tensor.Math.Scan, Torch.Indef.Static.Tensor.Mode as Torch.Indef.Double.Tensor.Mode, Torch.Indef.Static.Tensor.ScatterGather as Torch.Indef.Double.Tensor.ScatterGather, Torch.Indef.Static.Tensor.Sort as Torch.Indef.Double.Tensor.Sort, Torch.Indef.Static.Tensor.TopK as Torch.Indef.Double.Tensor.TopK, Torch.Indef.Dynamic.Tensor as Torch.Indef.Double.Dynamic.Tensor, Torch.Indef.Dynamic.Tensor.Copy as Torch.Indef.Double.Dynamic.Tensor.Copy, Torch.Indef.Dynamic.Tensor.Index as Torch.Indef.Double.Dynamic.Tensor.Index, Torch.Indef.Dynamic.Tensor.Masked as Torch.Indef.Double.Dynamic.Tensor.Masked, Torch.Indef.Dynamic.Tensor.Math as Torch.Indef.Double.Dynamic.Tensor.Math, Torch.Indef.Dynamic.Tensor.Math.Compare as Torch.Indef.Double.Dynamic.Tensor.Math.Compare, Torch.Indef.Dynamic.Tensor.Math.CompareT as Torch.Indef.Double.Dynamic.Tensor.Math.CompareT, Torch.Indef.Dynamic.Tensor.Math.Pairwise as Torch.Indef.Double.Dynamic.Tensor.Math.Pairwise, Torch.Indef.Dynamic.Tensor.Math.Pointwise as Torch.Indef.Double.Dynamic.Tensor.Math.Pointwise, Torch.Indef.Dynamic.Tensor.Math.Reduce as Torch.Indef.Double.Dynamic.Tensor.Math.Reduce, Torch.Indef.Dynamic.Tensor.Math.Scan as Torch.Indef.Double.Dynamic.Tensor.Math.Scan, Torch.Indef.Dynamic.Tensor.Mode as Torch.Indef.Double.Dynamic.Tensor.Mode, Torch.Indef.Dynamic.Tensor.ScatterGather as Torch.Indef.Double.Dynamic.Tensor.ScatterGather, Torch.Indef.Dynamic.Tensor.Sort as Torch.Indef.Double.Dynamic.Tensor.Sort, Torch.Indef.Dynamic.Tensor.TopK as Torch.Indef.Double.Dynamic.Tensor.TopK, Torch.Indef.Types as Torch.Double.Types, Torch.Indef.Index as Torch.Double.Index, Torch.Indef.Mask as Torch.Double.Mask, Torch.Indef.Static.Tensor.Math.Pointwise.Signed as Torch.Indef.Double.Tensor.Math.Pointwise.Signed, Torch.Indef.Dynamic.Tensor.Math.Pointwise.Signed as Torch.Indef.Double.Dynamic.Tensor.Math.Pointwise.Signed, Torch.Indef.Dynamic.NN as Torch.Double.Dynamic.NN, Torch.Indef.Dynamic.NN.Activation as Torch.Double.Dynamic.NN.Activation, Torch.Indef.Dynamic.NN.Pooling as Torch.Double.Dynamic.NN.Pooling, Torch.Indef.Dynamic.NN.Criterion as Torch.Double.Dynamic.NN.Criterion, Torch.Indef.Static.NN as Torch.Double.NN, Torch.Indef.Static.NN as Torch.Double.NN, Torch.Indef.Static.NN.Activation as Torch.Double.NN.Activation, Torch.Indef.Static.NN.Backprop as Torch.Double.NN.Backprop, Torch.Indef.Static.NN.Conv1d as Torch.Double.NN.Conv1d, Torch.Indef.Static.NN.Conv2d as Torch.Double.NN.Conv2d, Torch.Indef.Static.NN.Criterion as Torch.Double.NN.Criterion, Torch.Indef.Static.NN.Layers as Torch.Double.NN.Layers, Torch.Indef.Static.NN.Linear as Torch.Double.NN.Linear, Torch.Indef.Static.NN.Math as Torch.Double.NN.Math, Torch.Indef.Static.NN.Padding as Torch.Double.NN.Padding, Torch.Indef.Static.NN.Pooling as Torch.Double.NN.Pooling, Torch.Indef.Static.NN.Sampling as Torch.Double.NN.Sampling) requires (Torch.Sig.Index.Tensor as Torch.FFI.TH.Long.Tensor, Torch.Sig.Index.TensorFree as Torch.FFI.TH.Long.FreeTensor, Torch.Sig.Mask.Tensor as Torch.FFI.TH.Byte.Tensor, Torch.Sig.Mask.TensorFree as Torch.FFI.TH.Byte.FreeTensor, Torch.Sig.Mask.MathReduce as Torch.FFI.TH.Byte.TensorMath, Torch.Sig.State as Torch.Types.TH, Torch.Sig.Types.Global as Torch.Types.TH, Torch.Sig.Types as Torch.Types.TH.Double, Torch.Sig.Storage as Torch.FFI.TH.Double.Storage, Torch.Sig.Storage.Copy as Torch.FFI.TH.Double.StorageCopy, Torch.Sig.Storage.Memory as Torch.FFI.TH.Double.FreeStorage, Torch.Sig.Tensor as Torch.FFI.TH.Double.Tensor, Torch.Sig.Tensor.Copy as Torch.FFI.TH.Double.TensorCopy, Torch.Sig.Tensor.Memory as Torch.FFI.TH.Double.FreeTensor, Torch.Sig.Tensor.Index as Torch.FFI.TH.Double.TensorMath, Torch.Sig.Tensor.Masked as Torch.FFI.TH.Double.TensorMath, Torch.Sig.Tensor.Math as Torch.FFI.TH.Double.TensorMath, Torch.Sig.Tensor.Math.Compare as Torch.FFI.TH.Double.TensorMath, Torch.Sig.Tensor.Math.CompareT as Torch.FFI.TH.Double.TensorMath, Torch.Sig.Tensor.Math.Pairwise as Torch.FFI.TH.Double.TensorMath, Torch.Sig.Tensor.Math.Pointwise as Torch.FFI.TH.Double.TensorMath, Torch.Sig.Tensor.Math.Reduce as Torch.FFI.TH.Double.TensorMath, Torch.Sig.Tensor.Math.Scan as Torch.FFI.TH.Double.TensorMath, Torch.Sig.Tensor.Mode as Torch.FFI.TH.Double.TensorMath, Torch.Sig.Tensor.ScatterGather as Torch.FFI.TH.Double.TensorMath, Torch.Sig.Tensor.Sort as Torch.FFI.TH.Double.TensorMath, Torch.Sig.Tensor.TopK as Torch.FFI.TH.Double.TensorMath, Torch.Sig.Tensor.Math.Pointwise.Signed as Torch.FFI.TH.Double.TensorMath, Torch.Sig.Tensor.Math.Pointwise.Floating as Torch.FFI.TH.Double.TensorMath, Torch.Sig.Tensor.Math.Reduce.Floating as Torch.FFI.TH.Double.TensorMath, Torch.Sig.Tensor.Math.Floating as Torch.FFI.TH.Double.TensorMath, Torch.Sig.Tensor.Math.Blas as Torch.FFI.TH.Double.TensorMath, Torch.Sig.Tensor.Math.Lapack as Torch.FFI.TH.Double.TensorLapack, Torch.Sig.NN as Torch.FFI.TH.NN.Double, Torch.Sig.Types.NN as Torch.Types.TH, Torch.Sig.Tensor.Math.Random.TH as Torch.FFI.TH.Double.TensorMath, Torch.Sig.Tensor.Random.TH as Torch.FFI.TH.Double.TensorRandom, Torch.Sig.Tensor.Random.THC as Torch.Undefined.Double.Tensor.Random.THC) + + if flag(lite) + else + exposed-modules: + Torch.Byte + Torch.Byte.Dynamic + Torch.Byte.Storage + Torch.Char + Torch.Char.Dynamic + Torch.Char.Storage + Torch.Short + Torch.Short.Dynamic + Torch.Short.Storage + Torch.Int + Torch.Int.Dynamic + Torch.Int.Storage + Torch.Float + Torch.Float.Dynamic + Torch.Float.Storage + build-depends: + hasktorch-indef-unsigned -any + mixins: hasktorch-indef-unsigned (Torch.Indef.Storage as Torch.Indef.Byte.Storage, Torch.Indef.Storage.Copy as Torch.Indef.Byte.Storage.Copy, Torch.Indef.Static.Tensor as Torch.Indef.Byte.Tensor, Torch.Indef.Static.Tensor.Copy as Torch.Indef.Byte.Tensor.Copy, Torch.Indef.Static.Tensor.Index as Torch.Indef.Byte.Tensor.Index, Torch.Indef.Static.Tensor.Masked as Torch.Indef.Byte.Tensor.Masked, Torch.Indef.Static.Tensor.Math as Torch.Indef.Byte.Tensor.Math, Torch.Indef.Static.Tensor.Math.Compare as Torch.Indef.Byte.Tensor.Math.Compare, Torch.Indef.Static.Tensor.Math.CompareT as Torch.Indef.Byte.Tensor.Math.CompareT, Torch.Indef.Static.Tensor.Math.Pairwise as Torch.Indef.Byte.Tensor.Math.Pairwise, Torch.Indef.Static.Tensor.Math.Pointwise as Torch.Indef.Byte.Tensor.Math.Pointwise, Torch.Indef.Static.Tensor.Math.Reduce as Torch.Indef.Byte.Tensor.Math.Reduce, Torch.Indef.Static.Tensor.Math.Scan as Torch.Indef.Byte.Tensor.Math.Scan, Torch.Indef.Static.Tensor.Mode as Torch.Indef.Byte.Tensor.Mode, Torch.Indef.Static.Tensor.ScatterGather as Torch.Indef.Byte.Tensor.ScatterGather, Torch.Indef.Static.Tensor.Sort as Torch.Indef.Byte.Tensor.Sort, Torch.Indef.Static.Tensor.TopK as Torch.Indef.Byte.Tensor.TopK, Torch.Indef.Dynamic.Tensor as Torch.Indef.Byte.Dynamic.Tensor, Torch.Indef.Dynamic.Tensor.Copy as Torch.Indef.Byte.Dynamic.Tensor.Copy, Torch.Indef.Dynamic.Tensor.Index as Torch.Indef.Byte.Dynamic.Tensor.Index, Torch.Indef.Dynamic.Tensor.Masked as Torch.Indef.Byte.Dynamic.Tensor.Masked, Torch.Indef.Dynamic.Tensor.Math as Torch.Indef.Byte.Dynamic.Tensor.Math, Torch.Indef.Dynamic.Tensor.Math.Compare as Torch.Indef.Byte.Dynamic.Tensor.Math.Compare, Torch.Indef.Dynamic.Tensor.Math.CompareT as Torch.Indef.Byte.Dynamic.Tensor.Math.CompareT, Torch.Indef.Dynamic.Tensor.Math.Pairwise as Torch.Indef.Byte.Dynamic.Tensor.Math.Pairwise, Torch.Indef.Dynamic.Tensor.Math.Pointwise as Torch.Indef.Byte.Dynamic.Tensor.Math.Pointwise, Torch.Indef.Dynamic.Tensor.Math.Reduce as Torch.Indef.Byte.Dynamic.Tensor.Math.Reduce, Torch.Indef.Dynamic.Tensor.Math.Scan as Torch.Indef.Byte.Dynamic.Tensor.Math.Scan, Torch.Indef.Dynamic.Tensor.Mode as Torch.Indef.Byte.Dynamic.Tensor.Mode, Torch.Indef.Dynamic.Tensor.ScatterGather as Torch.Indef.Byte.Dynamic.Tensor.ScatterGather, Torch.Indef.Dynamic.Tensor.Sort as Torch.Indef.Byte.Dynamic.Tensor.Sort, Torch.Indef.Dynamic.Tensor.TopK as Torch.Indef.Byte.Dynamic.Tensor.TopK, Torch.Indef.Types as Torch.Byte.Types, Torch.Indef.Index as Torch.Byte.Index, Torch.Indef.Mask as Torch.Byte.Mask) requires (Torch.Sig.Index.Tensor as Torch.FFI.TH.Long.Tensor, Torch.Sig.Index.TensorFree as Torch.FFI.TH.Long.FreeTensor, Torch.Sig.Mask.Tensor as Torch.FFI.TH.Byte.Tensor, Torch.Sig.Mask.TensorFree as Torch.FFI.TH.Byte.FreeTensor, Torch.Sig.Mask.MathReduce as Torch.FFI.TH.Byte.TensorMath, Torch.Sig.State as Torch.Types.TH, Torch.Sig.Types.Global as Torch.Types.TH, Torch.Sig.Types as Torch.Types.TH.Byte, Torch.Sig.Storage as Torch.FFI.TH.Byte.Storage, Torch.Sig.Storage.Copy as Torch.FFI.TH.Byte.StorageCopy, Torch.Sig.Storage.Memory as Torch.FFI.TH.Byte.FreeStorage, Torch.Sig.Tensor as Torch.FFI.TH.Byte.Tensor, Torch.Sig.Tensor.Copy as Torch.FFI.TH.Byte.TensorCopy, Torch.Sig.Tensor.Memory as Torch.FFI.TH.Byte.FreeTensor, Torch.Sig.Tensor.Index as Torch.FFI.TH.Byte.TensorMath, Torch.Sig.Tensor.Masked as Torch.FFI.TH.Byte.TensorMath, Torch.Sig.Tensor.Math as Torch.FFI.TH.Byte.TensorMath, Torch.Sig.Tensor.Math.Compare as Torch.FFI.TH.Byte.TensorMath, Torch.Sig.Tensor.Math.CompareT as Torch.FFI.TH.Byte.TensorMath, Torch.Sig.Tensor.Math.Pairwise as Torch.FFI.TH.Byte.TensorMath, Torch.Sig.Tensor.Math.Pointwise as Torch.FFI.TH.Byte.TensorMath, Torch.Sig.Tensor.Math.Reduce as Torch.FFI.TH.Byte.TensorMath, Torch.Sig.Tensor.Math.Scan as Torch.FFI.TH.Byte.TensorMath, Torch.Sig.Tensor.Mode as Torch.FFI.TH.Byte.TensorMath, Torch.Sig.Tensor.ScatterGather as Torch.FFI.TH.Byte.TensorMath, Torch.Sig.Tensor.Sort as Torch.FFI.TH.Byte.TensorMath, Torch.Sig.Tensor.TopK as Torch.FFI.TH.Byte.TensorMath), + hasktorch-indef-unsigned (Torch.Indef.Storage as Torch.Indef.Char.Storage, Torch.Indef.Storage.Copy as Torch.Indef.Char.Storage.Copy, Torch.Indef.Static.Tensor as Torch.Indef.Char.Tensor, Torch.Indef.Static.Tensor.Copy as Torch.Indef.Char.Tensor.Copy, Torch.Indef.Static.Tensor.Index as Torch.Indef.Char.Tensor.Index, Torch.Indef.Static.Tensor.Masked as Torch.Indef.Char.Tensor.Masked, Torch.Indef.Static.Tensor.Math as Torch.Indef.Char.Tensor.Math, Torch.Indef.Static.Tensor.Math.Compare as Torch.Indef.Char.Tensor.Math.Compare, Torch.Indef.Static.Tensor.Math.CompareT as Torch.Indef.Char.Tensor.Math.CompareT, Torch.Indef.Static.Tensor.Math.Pairwise as Torch.Indef.Char.Tensor.Math.Pairwise, Torch.Indef.Static.Tensor.Math.Pointwise as Torch.Indef.Char.Tensor.Math.Pointwise, Torch.Indef.Static.Tensor.Math.Reduce as Torch.Indef.Char.Tensor.Math.Reduce, Torch.Indef.Static.Tensor.Math.Scan as Torch.Indef.Char.Tensor.Math.Scan, Torch.Indef.Static.Tensor.Mode as Torch.Indef.Char.Tensor.Mode, Torch.Indef.Static.Tensor.ScatterGather as Torch.Indef.Char.Tensor.ScatterGather, Torch.Indef.Static.Tensor.Sort as Torch.Indef.Char.Tensor.Sort, Torch.Indef.Static.Tensor.TopK as Torch.Indef.Char.Tensor.TopK, Torch.Indef.Dynamic.Tensor as Torch.Indef.Char.Dynamic.Tensor, Torch.Indef.Dynamic.Tensor.Copy as Torch.Indef.Char.Dynamic.Tensor.Copy, Torch.Indef.Dynamic.Tensor.Index as Torch.Indef.Char.Dynamic.Tensor.Index, Torch.Indef.Dynamic.Tensor.Masked as Torch.Indef.Char.Dynamic.Tensor.Masked, Torch.Indef.Dynamic.Tensor.Math as Torch.Indef.Char.Dynamic.Tensor.Math, Torch.Indef.Dynamic.Tensor.Math.Compare as Torch.Indef.Char.Dynamic.Tensor.Math.Compare, Torch.Indef.Dynamic.Tensor.Math.CompareT as Torch.Indef.Char.Dynamic.Tensor.Math.CompareT, Torch.Indef.Dynamic.Tensor.Math.Pairwise as Torch.Indef.Char.Dynamic.Tensor.Math.Pairwise, Torch.Indef.Dynamic.Tensor.Math.Pointwise as Torch.Indef.Char.Dynamic.Tensor.Math.Pointwise, Torch.Indef.Dynamic.Tensor.Math.Reduce as Torch.Indef.Char.Dynamic.Tensor.Math.Reduce, Torch.Indef.Dynamic.Tensor.Math.Scan as Torch.Indef.Char.Dynamic.Tensor.Math.Scan, Torch.Indef.Dynamic.Tensor.Mode as Torch.Indef.Char.Dynamic.Tensor.Mode, Torch.Indef.Dynamic.Tensor.ScatterGather as Torch.Indef.Char.Dynamic.Tensor.ScatterGather, Torch.Indef.Dynamic.Tensor.Sort as Torch.Indef.Char.Dynamic.Tensor.Sort, Torch.Indef.Dynamic.Tensor.TopK as Torch.Indef.Char.Dynamic.Tensor.TopK, Torch.Indef.Types as Torch.Char.Types, Torch.Indef.Index as Torch.Char.Index, Torch.Indef.Mask as Torch.Char.Mask) requires (Torch.Sig.Index.Tensor as Torch.FFI.TH.Long.Tensor, Torch.Sig.Index.TensorFree as Torch.FFI.TH.Long.FreeTensor, Torch.Sig.Mask.Tensor as Torch.FFI.TH.Byte.Tensor, Torch.Sig.Mask.TensorFree as Torch.FFI.TH.Byte.FreeTensor, Torch.Sig.Mask.MathReduce as Torch.FFI.TH.Byte.TensorMath, Torch.Sig.State as Torch.Types.TH, Torch.Sig.Types.Global as Torch.Types.TH, Torch.Sig.Types as Torch.Types.TH.Char, Torch.Sig.Storage as Torch.FFI.TH.Char.Storage, Torch.Sig.Storage.Copy as Torch.FFI.TH.Char.StorageCopy, Torch.Sig.Storage.Memory as Torch.FFI.TH.Char.FreeStorage, Torch.Sig.Tensor as Torch.FFI.TH.Char.Tensor, Torch.Sig.Tensor.Copy as Torch.FFI.TH.Char.TensorCopy, Torch.Sig.Tensor.Memory as Torch.FFI.TH.Char.FreeTensor, Torch.Sig.Tensor.Index as Torch.FFI.TH.Char.TensorMath, Torch.Sig.Tensor.Masked as Torch.FFI.TH.Char.TensorMath, Torch.Sig.Tensor.Math as Torch.FFI.TH.Char.TensorMath, Torch.Sig.Tensor.Math.Compare as Torch.FFI.TH.Char.TensorMath, Torch.Sig.Tensor.Math.CompareT as Torch.FFI.TH.Char.TensorMath, Torch.Sig.Tensor.Math.Pairwise as Torch.FFI.TH.Char.TensorMath, Torch.Sig.Tensor.Math.Pointwise as Torch.FFI.TH.Char.TensorMath, Torch.Sig.Tensor.Math.Reduce as Torch.FFI.TH.Char.TensorMath, Torch.Sig.Tensor.Math.Scan as Torch.FFI.TH.Char.TensorMath, Torch.Sig.Tensor.Mode as Torch.FFI.TH.Char.TensorMath, Torch.Sig.Tensor.ScatterGather as Torch.FFI.TH.Char.TensorMath, Torch.Sig.Tensor.Sort as Torch.FFI.TH.Char.TensorMath, Torch.Sig.Tensor.TopK as Torch.FFI.TH.Char.TensorMath), + hasktorch-indef-signed (Torch.Indef.Storage as Torch.Indef.Short.Storage, Torch.Indef.Storage.Copy as Torch.Indef.Short.Storage.Copy, Torch.Indef.Static.Tensor as Torch.Indef.Short.Tensor, Torch.Indef.Static.Tensor.Copy as Torch.Indef.Short.Tensor.Copy, Torch.Indef.Static.Tensor.Index as Torch.Indef.Short.Tensor.Index, Torch.Indef.Static.Tensor.Masked as Torch.Indef.Short.Tensor.Masked, Torch.Indef.Static.Tensor.Math as Torch.Indef.Short.Tensor.Math, Torch.Indef.Static.Tensor.Math.Compare as Torch.Indef.Short.Tensor.Math.Compare, Torch.Indef.Static.Tensor.Math.CompareT as Torch.Indef.Short.Tensor.Math.CompareT, Torch.Indef.Static.Tensor.Math.Pairwise as Torch.Indef.Short.Tensor.Math.Pairwise, Torch.Indef.Static.Tensor.Math.Pointwise as Torch.Indef.Short.Tensor.Math.Pointwise, Torch.Indef.Static.Tensor.Math.Reduce as Torch.Indef.Short.Tensor.Math.Reduce, Torch.Indef.Static.Tensor.Math.Scan as Torch.Indef.Short.Tensor.Math.Scan, Torch.Indef.Static.Tensor.Mode as Torch.Indef.Short.Tensor.Mode, Torch.Indef.Static.Tensor.ScatterGather as Torch.Indef.Short.Tensor.ScatterGather, Torch.Indef.Static.Tensor.Sort as Torch.Indef.Short.Tensor.Sort, Torch.Indef.Static.Tensor.TopK as Torch.Indef.Short.Tensor.TopK, Torch.Indef.Dynamic.Tensor as Torch.Indef.Short.Dynamic.Tensor, Torch.Indef.Dynamic.Tensor.Copy as Torch.Indef.Short.Dynamic.Tensor.Copy, Torch.Indef.Dynamic.Tensor.Index as Torch.Indef.Short.Dynamic.Tensor.Index, Torch.Indef.Dynamic.Tensor.Masked as Torch.Indef.Short.Dynamic.Tensor.Masked, Torch.Indef.Dynamic.Tensor.Math as Torch.Indef.Short.Dynamic.Tensor.Math, Torch.Indef.Dynamic.Tensor.Math.Compare as Torch.Indef.Short.Dynamic.Tensor.Math.Compare, Torch.Indef.Dynamic.Tensor.Math.CompareT as Torch.Indef.Short.Dynamic.Tensor.Math.CompareT, Torch.Indef.Dynamic.Tensor.Math.Pairwise as Torch.Indef.Short.Dynamic.Tensor.Math.Pairwise, Torch.Indef.Dynamic.Tensor.Math.Pointwise as Torch.Indef.Short.Dynamic.Tensor.Math.Pointwise, Torch.Indef.Dynamic.Tensor.Math.Reduce as Torch.Indef.Short.Dynamic.Tensor.Math.Reduce, Torch.Indef.Dynamic.Tensor.Math.Scan as Torch.Indef.Short.Dynamic.Tensor.Math.Scan, Torch.Indef.Dynamic.Tensor.Mode as Torch.Indef.Short.Dynamic.Tensor.Mode, Torch.Indef.Dynamic.Tensor.ScatterGather as Torch.Indef.Short.Dynamic.Tensor.ScatterGather, Torch.Indef.Dynamic.Tensor.Sort as Torch.Indef.Short.Dynamic.Tensor.Sort, Torch.Indef.Dynamic.Tensor.TopK as Torch.Indef.Short.Dynamic.Tensor.TopK, Torch.Indef.Types as Torch.Short.Types, Torch.Indef.Index as Torch.Short.Index, Torch.Indef.Mask as Torch.Short.Mask, Torch.Indef.Static.Tensor.Math.Pointwise.Signed as Torch.Indef.Short.Tensor.Math.Pointwise.Signed, Torch.Indef.Dynamic.Tensor.Math.Pointwise.Signed as Torch.Indef.Short.Dynamic.Tensor.Math.Pointwise.Signed) requires (Torch.Sig.Index.Tensor as Torch.FFI.TH.Long.Tensor, Torch.Sig.Index.TensorFree as Torch.FFI.TH.Long.FreeTensor, Torch.Sig.Mask.Tensor as Torch.FFI.TH.Byte.Tensor, Torch.Sig.Mask.TensorFree as Torch.FFI.TH.Byte.FreeTensor, Torch.Sig.Mask.MathReduce as Torch.FFI.TH.Byte.TensorMath, Torch.Sig.State as Torch.Types.TH, Torch.Sig.Types.Global as Torch.Types.TH, Torch.Sig.Types as Torch.Types.TH.Short, Torch.Sig.Storage as Torch.FFI.TH.Short.Storage, Torch.Sig.Storage.Copy as Torch.FFI.TH.Short.StorageCopy, Torch.Sig.Storage.Memory as Torch.FFI.TH.Short.FreeStorage, Torch.Sig.Tensor as Torch.FFI.TH.Short.Tensor, Torch.Sig.Tensor.Copy as Torch.FFI.TH.Short.TensorCopy, Torch.Sig.Tensor.Memory as Torch.FFI.TH.Short.FreeTensor, Torch.Sig.Tensor.Index as Torch.FFI.TH.Short.TensorMath, Torch.Sig.Tensor.Masked as Torch.FFI.TH.Short.TensorMath, Torch.Sig.Tensor.Math as Torch.FFI.TH.Short.TensorMath, Torch.Sig.Tensor.Math.Compare as Torch.FFI.TH.Short.TensorMath, Torch.Sig.Tensor.Math.CompareT as Torch.FFI.TH.Short.TensorMath, Torch.Sig.Tensor.Math.Pairwise as Torch.FFI.TH.Short.TensorMath, Torch.Sig.Tensor.Math.Pointwise as Torch.FFI.TH.Short.TensorMath, Torch.Sig.Tensor.Math.Reduce as Torch.FFI.TH.Short.TensorMath, Torch.Sig.Tensor.Math.Scan as Torch.FFI.TH.Short.TensorMath, Torch.Sig.Tensor.Mode as Torch.FFI.TH.Short.TensorMath, Torch.Sig.Tensor.ScatterGather as Torch.FFI.TH.Short.TensorMath, Torch.Sig.Tensor.Sort as Torch.FFI.TH.Short.TensorMath, Torch.Sig.Tensor.TopK as Torch.FFI.TH.Short.TensorMath, Torch.Sig.Tensor.Math.Pointwise.Signed as Torch.FFI.TH.Short.TensorMath), + hasktorch-indef-signed (Torch.Indef.Storage as Torch.Indef.Int.Storage, Torch.Indef.Storage.Copy as Torch.Indef.Int.Storage.Copy, Torch.Indef.Static.Tensor as Torch.Indef.Int.Tensor, Torch.Indef.Static.Tensor.Copy as Torch.Indef.Int.Tensor.Copy, Torch.Indef.Static.Tensor.Index as Torch.Indef.Int.Tensor.Index, Torch.Indef.Static.Tensor.Masked as Torch.Indef.Int.Tensor.Masked, Torch.Indef.Static.Tensor.Math as Torch.Indef.Int.Tensor.Math, Torch.Indef.Static.Tensor.Math.Compare as Torch.Indef.Int.Tensor.Math.Compare, Torch.Indef.Static.Tensor.Math.CompareT as Torch.Indef.Int.Tensor.Math.CompareT, Torch.Indef.Static.Tensor.Math.Pairwise as Torch.Indef.Int.Tensor.Math.Pairwise, Torch.Indef.Static.Tensor.Math.Pointwise as Torch.Indef.Int.Tensor.Math.Pointwise, Torch.Indef.Static.Tensor.Math.Reduce as Torch.Indef.Int.Tensor.Math.Reduce, Torch.Indef.Static.Tensor.Math.Scan as Torch.Indef.Int.Tensor.Math.Scan, Torch.Indef.Static.Tensor.Mode as Torch.Indef.Int.Tensor.Mode, Torch.Indef.Static.Tensor.ScatterGather as Torch.Indef.Int.Tensor.ScatterGather, Torch.Indef.Static.Tensor.Sort as Torch.Indef.Int.Tensor.Sort, Torch.Indef.Static.Tensor.TopK as Torch.Indef.Int.Tensor.TopK, Torch.Indef.Dynamic.Tensor as Torch.Indef.Int.Dynamic.Tensor, Torch.Indef.Dynamic.Tensor.Copy as Torch.Indef.Int.Dynamic.Tensor.Copy, Torch.Indef.Dynamic.Tensor.Index as Torch.Indef.Int.Dynamic.Tensor.Index, Torch.Indef.Dynamic.Tensor.Masked as Torch.Indef.Int.Dynamic.Tensor.Masked, Torch.Indef.Dynamic.Tensor.Math as Torch.Indef.Int.Dynamic.Tensor.Math, Torch.Indef.Dynamic.Tensor.Math.Compare as Torch.Indef.Int.Dynamic.Tensor.Math.Compare, Torch.Indef.Dynamic.Tensor.Math.CompareT as Torch.Indef.Int.Dynamic.Tensor.Math.CompareT, Torch.Indef.Dynamic.Tensor.Math.Pairwise as Torch.Indef.Int.Dynamic.Tensor.Math.Pairwise, Torch.Indef.Dynamic.Tensor.Math.Pointwise as Torch.Indef.Int.Dynamic.Tensor.Math.Pointwise, Torch.Indef.Dynamic.Tensor.Math.Reduce as Torch.Indef.Int.Dynamic.Tensor.Math.Reduce, Torch.Indef.Dynamic.Tensor.Math.Scan as Torch.Indef.Int.Dynamic.Tensor.Math.Scan, Torch.Indef.Dynamic.Tensor.Mode as Torch.Indef.Int.Dynamic.Tensor.Mode, Torch.Indef.Dynamic.Tensor.ScatterGather as Torch.Indef.Int.Dynamic.Tensor.ScatterGather, Torch.Indef.Dynamic.Tensor.Sort as Torch.Indef.Int.Dynamic.Tensor.Sort, Torch.Indef.Dynamic.Tensor.TopK as Torch.Indef.Int.Dynamic.Tensor.TopK, Torch.Indef.Types as Torch.Int.Types, Torch.Indef.Index as Torch.Int.Index, Torch.Indef.Mask as Torch.Int.Mask, Torch.Indef.Static.Tensor.Math.Pointwise.Signed as Torch.Indef.Int.Tensor.Math.Pointwise.Signed, Torch.Indef.Dynamic.Tensor.Math.Pointwise.Signed as Torch.Indef.Int.Dynamic.Tensor.Math.Pointwise.Signed) requires (Torch.Sig.Index.Tensor as Torch.FFI.TH.Long.Tensor, Torch.Sig.Index.TensorFree as Torch.FFI.TH.Long.FreeTensor, Torch.Sig.Mask.Tensor as Torch.FFI.TH.Byte.Tensor, Torch.Sig.Mask.TensorFree as Torch.FFI.TH.Byte.FreeTensor, Torch.Sig.Mask.MathReduce as Torch.FFI.TH.Byte.TensorMath, Torch.Sig.State as Torch.Types.TH, Torch.Sig.Types.Global as Torch.Types.TH, Torch.Sig.Types as Torch.Types.TH.Int, Torch.Sig.Storage as Torch.FFI.TH.Int.Storage, Torch.Sig.Storage.Copy as Torch.FFI.TH.Int.StorageCopy, Torch.Sig.Storage.Memory as Torch.FFI.TH.Int.FreeStorage, Torch.Sig.Tensor as Torch.FFI.TH.Int.Tensor, Torch.Sig.Tensor.Copy as Torch.FFI.TH.Int.TensorCopy, Torch.Sig.Tensor.Memory as Torch.FFI.TH.Int.FreeTensor, Torch.Sig.Tensor.Index as Torch.FFI.TH.Int.TensorMath, Torch.Sig.Tensor.Masked as Torch.FFI.TH.Int.TensorMath, Torch.Sig.Tensor.Math as Torch.FFI.TH.Int.TensorMath, Torch.Sig.Tensor.Math.Compare as Torch.FFI.TH.Int.TensorMath, Torch.Sig.Tensor.Math.CompareT as Torch.FFI.TH.Int.TensorMath, Torch.Sig.Tensor.Math.Pairwise as Torch.FFI.TH.Int.TensorMath, Torch.Sig.Tensor.Math.Pointwise as Torch.FFI.TH.Int.TensorMath, Torch.Sig.Tensor.Math.Reduce as Torch.FFI.TH.Int.TensorMath, Torch.Sig.Tensor.Math.Scan as Torch.FFI.TH.Int.TensorMath, Torch.Sig.Tensor.Mode as Torch.FFI.TH.Int.TensorMath, Torch.Sig.Tensor.ScatterGather as Torch.FFI.TH.Int.TensorMath, Torch.Sig.Tensor.Sort as Torch.FFI.TH.Int.TensorMath, Torch.Sig.Tensor.TopK as Torch.FFI.TH.Int.TensorMath, Torch.Sig.Tensor.Math.Pointwise.Signed as Torch.FFI.TH.Int.TensorMath), + hasktorch-indef-floating (Torch.Indef.Storage as Torch.Indef.Float.Storage, Torch.Indef.Storage.Copy as Torch.Indef.Float.Storage.Copy, Torch.Indef.Static.Tensor as Torch.Indef.Float.Tensor, Torch.Indef.Static.Tensor.Copy as Torch.Indef.Float.Tensor.Copy, Torch.Indef.Static.Tensor.Index as Torch.Indef.Float.Tensor.Index, Torch.Indef.Static.Tensor.Masked as Torch.Indef.Float.Tensor.Masked, Torch.Indef.Static.Tensor.Math as Torch.Indef.Float.Tensor.Math, Torch.Indef.Static.Tensor.Math.Compare as Torch.Indef.Float.Tensor.Math.Compare, Torch.Indef.Static.Tensor.Math.CompareT as Torch.Indef.Float.Tensor.Math.CompareT, Torch.Indef.Static.Tensor.Math.Pairwise as Torch.Indef.Float.Tensor.Math.Pairwise, Torch.Indef.Static.Tensor.Math.Pointwise as Torch.Indef.Float.Tensor.Math.Pointwise, Torch.Indef.Static.Tensor.Math.Reduce as Torch.Indef.Float.Tensor.Math.Reduce, Torch.Indef.Static.Tensor.Math.Scan as Torch.Indef.Float.Tensor.Math.Scan, Torch.Indef.Static.Tensor.Mode as Torch.Indef.Float.Tensor.Mode, Torch.Indef.Static.Tensor.ScatterGather as Torch.Indef.Float.Tensor.ScatterGather, Torch.Indef.Static.Tensor.Sort as Torch.Indef.Float.Tensor.Sort, Torch.Indef.Static.Tensor.TopK as Torch.Indef.Float.Tensor.TopK, Torch.Indef.Dynamic.Tensor as Torch.Indef.Float.Dynamic.Tensor, Torch.Indef.Dynamic.Tensor.Copy as Torch.Indef.Float.Dynamic.Tensor.Copy, Torch.Indef.Dynamic.Tensor.Index as Torch.Indef.Float.Dynamic.Tensor.Index, Torch.Indef.Dynamic.Tensor.Masked as Torch.Indef.Float.Dynamic.Tensor.Masked, Torch.Indef.Dynamic.Tensor.Math as Torch.Indef.Float.Dynamic.Tensor.Math, Torch.Indef.Dynamic.Tensor.Math.Compare as Torch.Indef.Float.Dynamic.Tensor.Math.Compare, Torch.Indef.Dynamic.Tensor.Math.CompareT as Torch.Indef.Float.Dynamic.Tensor.Math.CompareT, Torch.Indef.Dynamic.Tensor.Math.Pairwise as Torch.Indef.Float.Dynamic.Tensor.Math.Pairwise, Torch.Indef.Dynamic.Tensor.Math.Pointwise as Torch.Indef.Float.Dynamic.Tensor.Math.Pointwise, Torch.Indef.Dynamic.Tensor.Math.Reduce as Torch.Indef.Float.Dynamic.Tensor.Math.Reduce, Torch.Indef.Dynamic.Tensor.Math.Scan as Torch.Indef.Float.Dynamic.Tensor.Math.Scan, Torch.Indef.Dynamic.Tensor.Mode as Torch.Indef.Float.Dynamic.Tensor.Mode, Torch.Indef.Dynamic.Tensor.ScatterGather as Torch.Indef.Float.Dynamic.Tensor.ScatterGather, Torch.Indef.Dynamic.Tensor.Sort as Torch.Indef.Float.Dynamic.Tensor.Sort, Torch.Indef.Dynamic.Tensor.TopK as Torch.Indef.Float.Dynamic.Tensor.TopK, Torch.Indef.Types as Torch.Float.Types, Torch.Indef.Index as Torch.Float.Index, Torch.Indef.Mask as Torch.Float.Mask, Torch.Indef.Static.Tensor.Math.Pointwise.Signed as Torch.Indef.Float.Tensor.Math.Pointwise.Signed, Torch.Indef.Dynamic.Tensor.Math.Pointwise.Signed as Torch.Indef.Float.Dynamic.Tensor.Math.Pointwise.Signed, Torch.Indef.Dynamic.Tensor.Math.Blas as Torch.Indef.Float.Dynamic.Tensor.Math.Blas, Torch.Indef.Dynamic.Tensor.Math.Lapack as Torch.Indef.Float.Dynamic.Tensor.Math.Lapack, Torch.Indef.Dynamic.Tensor.Math.Pointwise.Floating as Torch.Indef.Float.Dynamic.Tensor.Math.Pointwise.Floating, Torch.Indef.Dynamic.Tensor.Math.Reduce.Floating as Torch.Indef.Float.Dynamic.Tensor.Math.Reduce.Floating, Torch.Indef.Dynamic.Tensor.Math.Floating as Torch.Indef.Float.Dynamic.Tensor.Math.Floating, Torch.Indef.Static.Tensor.Math.Blas as Torch.Indef.Float.Tensor.Math.Blas, Torch.Indef.Static.Tensor.Math.Lapack as Torch.Indef.Float.Tensor.Math.Lapack, Torch.Indef.Static.Tensor.Math.Pointwise.Floating as Torch.Indef.Float.Tensor.Math.Pointwise.Floating, Torch.Indef.Static.Tensor.Math.Reduce.Floating as Torch.Indef.Float.Tensor.Math.Reduce.Floating, Torch.Indef.Static.Tensor.Math.Floating as Torch.Indef.Float.Tensor.Math.Floating, Torch.Indef.Static.Tensor.Random.TH as Torch.Indef.Float.Tensor.Random.TH, Torch.Indef.Static.Tensor.Math.Random.TH as Torch.Indef.Float.Tensor.Math.Random.TH, Torch.Indef.Dynamic.Tensor.Random.TH as Torch.Indef.Float.Dynamic.Tensor.Random.TH, Torch.Indef.Dynamic.Tensor.Math.Random.TH as Torch.Indef.Float.Dynamic.Tensor.Math.Random.TH, Torch.Undefined.Tensor.Random.THC as Torch.Undefined.Float.Tensor.Random.THC, Torch.Indef.Storage as Torch.Indef.Float.Storage, Torch.Indef.Storage.Copy as Torch.Indef.Float.Storage.Copy, Torch.Indef.Static.Tensor as Torch.Indef.Float.Tensor, Torch.Indef.Static.Tensor.Copy as Torch.Indef.Float.Tensor.Copy, Torch.Indef.Static.Tensor.Index as Torch.Indef.Float.Tensor.Index, Torch.Indef.Static.Tensor.Masked as Torch.Indef.Float.Tensor.Masked, Torch.Indef.Static.Tensor.Math as Torch.Indef.Float.Tensor.Math, Torch.Indef.Static.Tensor.Math.Compare as Torch.Indef.Float.Tensor.Math.Compare, Torch.Indef.Static.Tensor.Math.CompareT as Torch.Indef.Float.Tensor.Math.CompareT, Torch.Indef.Static.Tensor.Math.Pairwise as Torch.Indef.Float.Tensor.Math.Pairwise, Torch.Indef.Static.Tensor.Math.Pointwise as Torch.Indef.Float.Tensor.Math.Pointwise, Torch.Indef.Static.Tensor.Math.Reduce as Torch.Indef.Float.Tensor.Math.Reduce, Torch.Indef.Static.Tensor.Math.Scan as Torch.Indef.Float.Tensor.Math.Scan, Torch.Indef.Static.Tensor.Mode as Torch.Indef.Float.Tensor.Mode, Torch.Indef.Static.Tensor.ScatterGather as Torch.Indef.Float.Tensor.ScatterGather, Torch.Indef.Static.Tensor.Sort as Torch.Indef.Float.Tensor.Sort, Torch.Indef.Static.Tensor.TopK as Torch.Indef.Float.Tensor.TopK, Torch.Indef.Dynamic.Tensor as Torch.Indef.Float.Dynamic.Tensor, Torch.Indef.Dynamic.Tensor.Copy as Torch.Indef.Float.Dynamic.Tensor.Copy, Torch.Indef.Dynamic.Tensor.Index as Torch.Indef.Float.Dynamic.Tensor.Index, Torch.Indef.Dynamic.Tensor.Masked as Torch.Indef.Float.Dynamic.Tensor.Masked, Torch.Indef.Dynamic.Tensor.Math as Torch.Indef.Float.Dynamic.Tensor.Math, Torch.Indef.Dynamic.Tensor.Math.Compare as Torch.Indef.Float.Dynamic.Tensor.Math.Compare, Torch.Indef.Dynamic.Tensor.Math.CompareT as Torch.Indef.Float.Dynamic.Tensor.Math.CompareT, Torch.Indef.Dynamic.Tensor.Math.Pairwise as Torch.Indef.Float.Dynamic.Tensor.Math.Pairwise, Torch.Indef.Dynamic.Tensor.Math.Pointwise as Torch.Indef.Float.Dynamic.Tensor.Math.Pointwise, Torch.Indef.Dynamic.Tensor.Math.Reduce as Torch.Indef.Float.Dynamic.Tensor.Math.Reduce, Torch.Indef.Dynamic.Tensor.Math.Scan as Torch.Indef.Float.Dynamic.Tensor.Math.Scan, Torch.Indef.Dynamic.Tensor.Mode as Torch.Indef.Float.Dynamic.Tensor.Mode, Torch.Indef.Dynamic.Tensor.ScatterGather as Torch.Indef.Float.Dynamic.Tensor.ScatterGather, Torch.Indef.Dynamic.Tensor.Sort as Torch.Indef.Float.Dynamic.Tensor.Sort, Torch.Indef.Dynamic.Tensor.TopK as Torch.Indef.Float.Dynamic.Tensor.TopK, Torch.Indef.Types as Torch.Float.Types, Torch.Indef.Index as Torch.Float.Index, Torch.Indef.Mask as Torch.Float.Mask, Torch.Indef.Static.Tensor.Math.Pointwise.Signed as Torch.Indef.Float.Tensor.Math.Pointwise.Signed, Torch.Indef.Dynamic.Tensor.Math.Pointwise.Signed as Torch.Indef.Float.Dynamic.Tensor.Math.Pointwise.Signed, Torch.Indef.Dynamic.NN as Torch.Float.Dynamic.NN, Torch.Indef.Dynamic.NN.Activation as Torch.Float.Dynamic.NN.Activation, Torch.Indef.Dynamic.NN.Pooling as Torch.Float.Dynamic.NN.Pooling, Torch.Indef.Dynamic.NN.Criterion as Torch.Float.Dynamic.NN.Criterion, Torch.Indef.Static.NN as Torch.Float.NN, Torch.Indef.Static.NN as Torch.Float.NN, Torch.Indef.Static.NN.Activation as Torch.Float.NN.Activation, Torch.Indef.Static.NN.Backprop as Torch.Float.NN.Backprop, Torch.Indef.Static.NN.Conv1d as Torch.Float.NN.Conv1d, Torch.Indef.Static.NN.Conv2d as Torch.Float.NN.Conv2d, Torch.Indef.Static.NN.Criterion as Torch.Float.NN.Criterion, Torch.Indef.Static.NN.Layers as Torch.Float.NN.Layers, Torch.Indef.Static.NN.Linear as Torch.Float.NN.Linear, Torch.Indef.Static.NN.Math as Torch.Float.NN.Math, Torch.Indef.Static.NN.Padding as Torch.Float.NN.Padding, Torch.Indef.Static.NN.Pooling as Torch.Float.NN.Pooling, Torch.Indef.Static.NN.Sampling as Torch.Float.NN.Sampling) requires (Torch.Sig.Index.Tensor as Torch.FFI.TH.Long.Tensor, Torch.Sig.Index.TensorFree as Torch.FFI.TH.Long.FreeTensor, Torch.Sig.Mask.Tensor as Torch.FFI.TH.Byte.Tensor, Torch.Sig.Mask.TensorFree as Torch.FFI.TH.Byte.FreeTensor, Torch.Sig.Mask.MathReduce as Torch.FFI.TH.Byte.TensorMath, Torch.Sig.State as Torch.Types.TH, Torch.Sig.Types.Global as Torch.Types.TH, Torch.Sig.Types as Torch.Types.TH.Float, Torch.Sig.Storage as Torch.FFI.TH.Float.Storage, Torch.Sig.Storage.Copy as Torch.FFI.TH.Float.StorageCopy, Torch.Sig.Storage.Memory as Torch.FFI.TH.Float.FreeStorage, Torch.Sig.Tensor as Torch.FFI.TH.Float.Tensor, Torch.Sig.Tensor.Copy as Torch.FFI.TH.Float.TensorCopy, Torch.Sig.Tensor.Memory as Torch.FFI.TH.Float.FreeTensor, Torch.Sig.Tensor.Index as Torch.FFI.TH.Float.TensorMath, Torch.Sig.Tensor.Masked as Torch.FFI.TH.Float.TensorMath, Torch.Sig.Tensor.Math as Torch.FFI.TH.Float.TensorMath, Torch.Sig.Tensor.Math.Compare as Torch.FFI.TH.Float.TensorMath, Torch.Sig.Tensor.Math.CompareT as Torch.FFI.TH.Float.TensorMath, Torch.Sig.Tensor.Math.Pairwise as Torch.FFI.TH.Float.TensorMath, Torch.Sig.Tensor.Math.Pointwise as Torch.FFI.TH.Float.TensorMath, Torch.Sig.Tensor.Math.Reduce as Torch.FFI.TH.Float.TensorMath, Torch.Sig.Tensor.Math.Scan as Torch.FFI.TH.Float.TensorMath, Torch.Sig.Tensor.Mode as Torch.FFI.TH.Float.TensorMath, Torch.Sig.Tensor.ScatterGather as Torch.FFI.TH.Float.TensorMath, Torch.Sig.Tensor.Sort as Torch.FFI.TH.Float.TensorMath, Torch.Sig.Tensor.TopK as Torch.FFI.TH.Float.TensorMath, Torch.Sig.Tensor.Math.Pointwise.Signed as Torch.FFI.TH.Float.TensorMath, Torch.Sig.Tensor.Math.Pointwise.Floating as Torch.FFI.TH.Float.TensorMath, Torch.Sig.Tensor.Math.Reduce.Floating as Torch.FFI.TH.Float.TensorMath, Torch.Sig.Tensor.Math.Floating as Torch.FFI.TH.Float.TensorMath, Torch.Sig.Tensor.Math.Blas as Torch.FFI.TH.Float.TensorMath, Torch.Sig.Tensor.Math.Lapack as Torch.FFI.TH.Float.TensorLapack, Torch.Sig.NN as Torch.FFI.TH.NN.Float, Torch.Sig.Types.NN as Torch.Types.TH, Torch.Sig.Tensor.Math.Random.TH as Torch.FFI.TH.Float.TensorMath, Torch.Sig.Tensor.Random.TH as Torch.FFI.TH.Float.TensorRandom, Torch.Sig.Tensor.Random.THC as Torch.Undefined.Float.Tensor.Random.THC) + +library hasktorch-gpu + exposed-modules: + Torch.Cuda.Long + Torch.Cuda.Long.Dynamic + Torch.Cuda.Long.Storage + Torch.Cuda.Double + Torch.Cuda.Double.Dynamic + Torch.Cuda.Double.Storage + reexported-modules: Torch.Cuda.Double.NN, + Torch.Cuda.Double.NN.Activation, + Torch.Cuda.Double.NN.Backprop, + Torch.Cuda.Double.NN.Conv1d, + Torch.Cuda.Double.NN.Conv2d, + Torch.Cuda.Double.NN.Criterion, + Torch.Cuda.Double.NN.Layers, + Torch.Cuda.Double.NN.Linear, + Torch.Cuda.Double.NN.Math, + Torch.Cuda.Double.NN.Padding, + Torch.Cuda.Double.NN.Pooling, + Torch.Cuda.Double.NN.Sampling, + Torch.Cuda.Double.Dynamic.NN, + Torch.Cuda.Double.Dynamic.NN.Activation, + Torch.Cuda.Double.Dynamic.NN.Pooling, + Torch.Cuda.Double.Dynamic.NN.Criterion + cpp-options: -DCUDA -DHASKTORCH_INTERNAL_CUDA + hs-source-dirs: utils src + other-modules: + Torch.Core.Exceptions + Torch.Core.Random + Torch.Core.LogAdd + default-language: Haskell2010 + default-extensions: LambdaCase DataKinds TypeFamilies + TypeSynonymInstances ScopedTypeVariables FlexibleContexts CPP + build-depends: + base (==4.7 || >4.7) && <5, + hasktorch-types-th (==0.0.1 || >0.0.1) && <0.0.2, + -- containers ==0.5.10 || >0.5.10, + -- deepseq ==1.3.0 || >1.3.0, + dimensions ==1.0 || >1.0, + hasktorch-ffi-th (==0.0.1 || >0.0.1) && <0.0.2, + hasktorch-types-th (==0.0.1 || >0.0.1) && <0.0.2, + -- managed (==1.0.0 || >1.0.0) && <1.1, + -- microlens ==0.4.8 || >0.4.8, + -- numeric-limits ==0.1.0 || >0.1.0, + safe-exceptions ==0.1.0 || >0.1.0, + singletons ==2.2 || >2.2, + text ==1.2.2 || >1.2.2, + -- typelits-witnesses ==0.2.3 || >0.2.3, + hasktorch-indef-floating -any, + hasktorch-indef-signed -any, + hasktorch-ffi-thc (==0.0.1 || >0.0.1) && <0.0.2, + hasktorch-types-thc (==0.0.1 || >0.0.1) && <0.0.2 + mixins: hasktorch-indef-signed (Torch.Indef.Storage as Torch.Indef.Cuda.Long.Storage, Torch.Indef.Storage.Copy as Torch.Indef.Cuda.Long.Storage.Copy, Torch.Indef.Static.Tensor as Torch.Indef.Cuda.Long.Tensor, Torch.Indef.Static.Tensor.Copy as Torch.Indef.Cuda.Long.Tensor.Copy, Torch.Indef.Static.Tensor.Index as Torch.Indef.Cuda.Long.Tensor.Index, Torch.Indef.Static.Tensor.Masked as Torch.Indef.Cuda.Long.Tensor.Masked, Torch.Indef.Static.Tensor.Math as Torch.Indef.Cuda.Long.Tensor.Math, Torch.Indef.Static.Tensor.Math.Compare as Torch.Indef.Cuda.Long.Tensor.Math.Compare, Torch.Indef.Static.Tensor.Math.CompareT as Torch.Indef.Cuda.Long.Tensor.Math.CompareT, Torch.Indef.Static.Tensor.Math.Pairwise as Torch.Indef.Cuda.Long.Tensor.Math.Pairwise, Torch.Indef.Static.Tensor.Math.Pointwise as Torch.Indef.Cuda.Long.Tensor.Math.Pointwise, Torch.Indef.Static.Tensor.Math.Reduce as Torch.Indef.Cuda.Long.Tensor.Math.Reduce, Torch.Indef.Static.Tensor.Math.Scan as Torch.Indef.Cuda.Long.Tensor.Math.Scan, Torch.Indef.Static.Tensor.Mode as Torch.Indef.Cuda.Long.Tensor.Mode, Torch.Indef.Static.Tensor.ScatterGather as Torch.Indef.Cuda.Long.Tensor.ScatterGather, Torch.Indef.Static.Tensor.Sort as Torch.Indef.Cuda.Long.Tensor.Sort, Torch.Indef.Static.Tensor.TopK as Torch.Indef.Cuda.Long.Tensor.TopK, Torch.Indef.Dynamic.Tensor as Torch.Indef.Cuda.Long.Dynamic.Tensor, Torch.Indef.Dynamic.Tensor.Copy as Torch.Indef.Cuda.Long.Dynamic.Tensor.Copy, Torch.Indef.Dynamic.Tensor.Index as Torch.Indef.Cuda.Long.Dynamic.Tensor.Index, Torch.Indef.Dynamic.Tensor.Masked as Torch.Indef.Cuda.Long.Dynamic.Tensor.Masked, Torch.Indef.Dynamic.Tensor.Math as Torch.Indef.Cuda.Long.Dynamic.Tensor.Math, Torch.Indef.Dynamic.Tensor.Math.Compare as Torch.Indef.Cuda.Long.Dynamic.Tensor.Math.Compare, Torch.Indef.Dynamic.Tensor.Math.CompareT as Torch.Indef.Cuda.Long.Dynamic.Tensor.Math.CompareT, Torch.Indef.Dynamic.Tensor.Math.Pairwise as Torch.Indef.Cuda.Long.Dynamic.Tensor.Math.Pairwise, Torch.Indef.Dynamic.Tensor.Math.Pointwise as Torch.Indef.Cuda.Long.Dynamic.Tensor.Math.Pointwise, Torch.Indef.Dynamic.Tensor.Math.Reduce as Torch.Indef.Cuda.Long.Dynamic.Tensor.Math.Reduce, Torch.Indef.Dynamic.Tensor.Math.Scan as Torch.Indef.Cuda.Long.Dynamic.Tensor.Math.Scan, Torch.Indef.Dynamic.Tensor.Mode as Torch.Indef.Cuda.Long.Dynamic.Tensor.Mode, Torch.Indef.Dynamic.Tensor.ScatterGather as Torch.Indef.Cuda.Long.Dynamic.Tensor.ScatterGather, Torch.Indef.Dynamic.Tensor.Sort as Torch.Indef.Cuda.Long.Dynamic.Tensor.Sort, Torch.Indef.Dynamic.Tensor.TopK as Torch.Indef.Cuda.Long.Dynamic.Tensor.TopK, Torch.Indef.Types as Torch.Cuda.Long.Types, Torch.Indef.Index as Torch.Cuda.Long.Index, Torch.Indef.Mask as Torch.Cuda.Long.Mask, Torch.Indef.Static.Tensor.Math.Pointwise.Signed as Torch.Indef.Cuda.Long.Tensor.Math.Pointwise.Signed, Torch.Indef.Dynamic.Tensor.Math.Pointwise.Signed as Torch.Indef.Cuda.Long.Dynamic.Tensor.Math.Pointwise.Signed) requires (Torch.Sig.Index.Tensor as Torch.FFI.THC.Long.Tensor, Torch.Sig.Index.TensorFree as Torch.FFI.THC.Long.Tensor, Torch.Sig.Mask.Tensor as Torch.FFI.THC.Byte.Tensor, Torch.Sig.Mask.TensorFree as Torch.FFI.THC.Byte.Tensor, Torch.Sig.Mask.MathReduce as Torch.FFI.THC.Byte.TensorMathReduce, Torch.Sig.State as Torch.FFI.THC.State, Torch.Sig.Types.Global as Torch.Types.THC, Torch.Sig.Types as Torch.Types.THC.Long, Torch.Sig.Storage as Torch.FFI.THC.Long.Storage, Torch.Sig.Storage.Copy as Torch.FFI.THC.Long.StorageCopy, Torch.Sig.Storage.Memory as Torch.FFI.THC.Long.Storage, Torch.Sig.Tensor as Torch.FFI.THC.Long.Tensor, Torch.Sig.Tensor.Copy as Torch.FFI.THC.Long.TensorCopy, Torch.Sig.Tensor.Memory as Torch.FFI.THC.Long.Tensor, Torch.Sig.Tensor.Index as Torch.FFI.THC.Long.TensorIndex, Torch.Sig.Tensor.Masked as Torch.FFI.THC.Long.TensorMasked, Torch.Sig.Tensor.Math as Torch.FFI.THC.Long.TensorMath, Torch.Sig.Tensor.Math.Compare as Torch.FFI.THC.Long.TensorMathCompare, Torch.Sig.Tensor.Math.CompareT as Torch.FFI.THC.Long.TensorMathCompareT, Torch.Sig.Tensor.Math.Pairwise as Torch.FFI.THC.Long.TensorMathPairwise, Torch.Sig.Tensor.Math.Pointwise as Torch.FFI.THC.Long.TensorMathPointwise, Torch.Sig.Tensor.Math.Reduce as Torch.FFI.THC.Long.TensorMathReduce, Torch.Sig.Tensor.Math.Scan as Torch.FFI.THC.Long.TensorMathScan, Torch.Sig.Tensor.Mode as Torch.FFI.THC.Long.TensorMode, Torch.Sig.Tensor.ScatterGather as Torch.FFI.THC.Long.TensorScatterGather, Torch.Sig.Tensor.Sort as Torch.FFI.THC.Long.TensorSort, Torch.Sig.Tensor.TopK as Torch.FFI.THC.Long.TensorTopK, Torch.Sig.Tensor.Math.Pointwise.Signed as Torch.FFI.THC.Long.TensorMathPointwise), + hasktorch-indef-floating (Torch.Indef.Storage as Torch.Indef.Cuda.Double.Storage, Torch.Indef.Storage.Copy as Torch.Indef.Cuda.Double.Storage.Copy, Torch.Indef.Static.Tensor as Torch.Indef.Cuda.Double.Tensor, Torch.Indef.Static.Tensor.Copy as Torch.Indef.Cuda.Double.Tensor.Copy, Torch.Indef.Static.Tensor.Index as Torch.Indef.Cuda.Double.Tensor.Index, Torch.Indef.Static.Tensor.Masked as Torch.Indef.Cuda.Double.Tensor.Masked, Torch.Indef.Static.Tensor.Math as Torch.Indef.Cuda.Double.Tensor.Math, Torch.Indef.Static.Tensor.Math.Compare as Torch.Indef.Cuda.Double.Tensor.Math.Compare, Torch.Indef.Static.Tensor.Math.CompareT as Torch.Indef.Cuda.Double.Tensor.Math.CompareT, Torch.Indef.Static.Tensor.Math.Pairwise as Torch.Indef.Cuda.Double.Tensor.Math.Pairwise, Torch.Indef.Static.Tensor.Math.Pointwise as Torch.Indef.Cuda.Double.Tensor.Math.Pointwise, Torch.Indef.Static.Tensor.Math.Reduce as Torch.Indef.Cuda.Double.Tensor.Math.Reduce, Torch.Indef.Static.Tensor.Math.Scan as Torch.Indef.Cuda.Double.Tensor.Math.Scan, Torch.Indef.Static.Tensor.Mode as Torch.Indef.Cuda.Double.Tensor.Mode, Torch.Indef.Static.Tensor.ScatterGather as Torch.Indef.Cuda.Double.Tensor.ScatterGather, Torch.Indef.Static.Tensor.Sort as Torch.Indef.Cuda.Double.Tensor.Sort, Torch.Indef.Static.Tensor.TopK as Torch.Indef.Cuda.Double.Tensor.TopK, Torch.Indef.Dynamic.Tensor as Torch.Indef.Cuda.Double.Dynamic.Tensor, Torch.Indef.Dynamic.Tensor.Copy as Torch.Indef.Cuda.Double.Dynamic.Tensor.Copy, Torch.Indef.Dynamic.Tensor.Index as Torch.Indef.Cuda.Double.Dynamic.Tensor.Index, Torch.Indef.Dynamic.Tensor.Masked as Torch.Indef.Cuda.Double.Dynamic.Tensor.Masked, Torch.Indef.Dynamic.Tensor.Math as Torch.Indef.Cuda.Double.Dynamic.Tensor.Math, Torch.Indef.Dynamic.Tensor.Math.Compare as Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.Compare, Torch.Indef.Dynamic.Tensor.Math.CompareT as Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.CompareT, Torch.Indef.Dynamic.Tensor.Math.Pairwise as Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.Pairwise, Torch.Indef.Dynamic.Tensor.Math.Pointwise as Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.Pointwise, Torch.Indef.Dynamic.Tensor.Math.Reduce as Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.Reduce, Torch.Indef.Dynamic.Tensor.Math.Scan as Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.Scan, Torch.Indef.Dynamic.Tensor.Mode as Torch.Indef.Cuda.Double.Dynamic.Tensor.Mode, Torch.Indef.Dynamic.Tensor.ScatterGather as Torch.Indef.Cuda.Double.Dynamic.Tensor.ScatterGather, Torch.Indef.Dynamic.Tensor.Sort as Torch.Indef.Cuda.Double.Dynamic.Tensor.Sort, Torch.Indef.Dynamic.Tensor.TopK as Torch.Indef.Cuda.Double.Dynamic.Tensor.TopK, Torch.Indef.Types as Torch.Cuda.Double.Types, Torch.Indef.Index as Torch.Cuda.Double.Index, Torch.Indef.Mask as Torch.Cuda.Double.Mask, Torch.Indef.Static.Tensor.Math.Pointwise.Signed as Torch.Indef.Cuda.Double.Tensor.Math.Pointwise.Signed, Torch.Indef.Dynamic.Tensor.Math.Pointwise.Signed as Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.Pointwise.Signed, Torch.Indef.Dynamic.Tensor.Math.Blas as Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.Blas, Torch.Indef.Dynamic.Tensor.Math.Lapack as Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.Lapack, Torch.Indef.Dynamic.Tensor.Math.Pointwise.Floating as Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.Pointwise.Floating, Torch.Indef.Dynamic.Tensor.Math.Reduce.Floating as Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.Reduce.Floating, Torch.Indef.Dynamic.Tensor.Math.Floating as Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.Floating, Torch.Indef.Static.Tensor.Math.Blas as Torch.Indef.Cuda.Double.Tensor.Math.Blas, Torch.Indef.Static.Tensor.Math.Lapack as Torch.Indef.Cuda.Double.Tensor.Math.Lapack, Torch.Indef.Static.Tensor.Math.Pointwise.Floating as Torch.Indef.Cuda.Double.Tensor.Math.Pointwise.Floating, Torch.Indef.Static.Tensor.Math.Reduce.Floating as Torch.Indef.Cuda.Double.Tensor.Math.Reduce.Floating, Torch.Indef.Static.Tensor.Math.Floating as Torch.Indef.Cuda.Double.Tensor.Math.Floating, Torch.Undefined.Tensor.Random.TH as Torch.Undefined.Cuda.Double.Tensor.Random.TH, Torch.Undefined.Tensor.Math.Random.TH as Torch.Undefined.Cuda.Double.Tensor.Math.Random.TH, Torch.Indef.Static.Tensor.Random.THC as Torch.Indef.Cuda.Double.Tensor.Random.THC, Torch.Indef.Dynamic.Tensor.Random.THC as Torch.Indef.Cuda.Double.Dynamic.Tensor.Random.THC, Torch.Indef.Storage as Torch.Indef.Cuda.Double.Storage, Torch.Indef.Storage.Copy as Torch.Indef.Cuda.Double.Storage.Copy, Torch.Indef.Static.Tensor as Torch.Indef.Cuda.Double.Tensor, Torch.Indef.Static.Tensor.Copy as Torch.Indef.Cuda.Double.Tensor.Copy, Torch.Indef.Static.Tensor.Index as Torch.Indef.Cuda.Double.Tensor.Index, Torch.Indef.Static.Tensor.Masked as Torch.Indef.Cuda.Double.Tensor.Masked, Torch.Indef.Static.Tensor.Math as Torch.Indef.Cuda.Double.Tensor.Math, Torch.Indef.Static.Tensor.Math.Compare as Torch.Indef.Cuda.Double.Tensor.Math.Compare, Torch.Indef.Static.Tensor.Math.CompareT as Torch.Indef.Cuda.Double.Tensor.Math.CompareT, Torch.Indef.Static.Tensor.Math.Pairwise as Torch.Indef.Cuda.Double.Tensor.Math.Pairwise, Torch.Indef.Static.Tensor.Math.Pointwise as Torch.Indef.Cuda.Double.Tensor.Math.Pointwise, Torch.Indef.Static.Tensor.Math.Reduce as Torch.Indef.Cuda.Double.Tensor.Math.Reduce, Torch.Indef.Static.Tensor.Math.Scan as Torch.Indef.Cuda.Double.Tensor.Math.Scan, Torch.Indef.Static.Tensor.Mode as Torch.Indef.Cuda.Double.Tensor.Mode, Torch.Indef.Static.Tensor.ScatterGather as Torch.Indef.Cuda.Double.Tensor.ScatterGather, Torch.Indef.Static.Tensor.Sort as Torch.Indef.Cuda.Double.Tensor.Sort, Torch.Indef.Static.Tensor.TopK as Torch.Indef.Cuda.Double.Tensor.TopK, Torch.Indef.Dynamic.Tensor as Torch.Indef.Cuda.Double.Dynamic.Tensor, Torch.Indef.Dynamic.Tensor.Copy as Torch.Indef.Cuda.Double.Dynamic.Tensor.Copy, Torch.Indef.Dynamic.Tensor.Index as Torch.Indef.Cuda.Double.Dynamic.Tensor.Index, Torch.Indef.Dynamic.Tensor.Masked as Torch.Indef.Cuda.Double.Dynamic.Tensor.Masked, Torch.Indef.Dynamic.Tensor.Math as Torch.Indef.Cuda.Double.Dynamic.Tensor.Math, Torch.Indef.Dynamic.Tensor.Math.Compare as Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.Compare, Torch.Indef.Dynamic.Tensor.Math.CompareT as Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.CompareT, Torch.Indef.Dynamic.Tensor.Math.Pairwise as Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.Pairwise, Torch.Indef.Dynamic.Tensor.Math.Pointwise as Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.Pointwise, Torch.Indef.Dynamic.Tensor.Math.Reduce as Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.Reduce, Torch.Indef.Dynamic.Tensor.Math.Scan as Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.Scan, Torch.Indef.Dynamic.Tensor.Mode as Torch.Indef.Cuda.Double.Dynamic.Tensor.Mode, Torch.Indef.Dynamic.Tensor.ScatterGather as Torch.Indef.Cuda.Double.Dynamic.Tensor.ScatterGather, Torch.Indef.Dynamic.Tensor.Sort as Torch.Indef.Cuda.Double.Dynamic.Tensor.Sort, Torch.Indef.Dynamic.Tensor.TopK as Torch.Indef.Cuda.Double.Dynamic.Tensor.TopK, Torch.Indef.Types as Torch.Cuda.Double.Types, Torch.Indef.Index as Torch.Cuda.Double.Index, Torch.Indef.Mask as Torch.Cuda.Double.Mask, Torch.Indef.Static.Tensor.Math.Pointwise.Signed as Torch.Indef.Cuda.Double.Tensor.Math.Pointwise.Signed, Torch.Indef.Dynamic.Tensor.Math.Pointwise.Signed as Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.Pointwise.Signed, Torch.Indef.Dynamic.NN as Torch.Cuda.Double.Dynamic.NN, Torch.Indef.Dynamic.NN.Activation as Torch.Cuda.Double.Dynamic.NN.Activation, Torch.Indef.Dynamic.NN.Pooling as Torch.Cuda.Double.Dynamic.NN.Pooling, Torch.Indef.Dynamic.NN.Criterion as Torch.Cuda.Double.Dynamic.NN.Criterion, Torch.Indef.Static.NN as Torch.Cuda.Double.NN, Torch.Indef.Static.NN as Torch.Cuda.Double.NN, Torch.Indef.Static.NN.Activation as Torch.Cuda.Double.NN.Activation, Torch.Indef.Static.NN.Backprop as Torch.Cuda.Double.NN.Backprop, Torch.Indef.Static.NN.Conv1d as Torch.Cuda.Double.NN.Conv1d, Torch.Indef.Static.NN.Conv2d as Torch.Cuda.Double.NN.Conv2d, Torch.Indef.Static.NN.Criterion as Torch.Cuda.Double.NN.Criterion, Torch.Indef.Static.NN.Layers as Torch.Cuda.Double.NN.Layers, Torch.Indef.Static.NN.Linear as Torch.Cuda.Double.NN.Linear, Torch.Indef.Static.NN.Math as Torch.Cuda.Double.NN.Math, Torch.Indef.Static.NN.Padding as Torch.Cuda.Double.NN.Padding, Torch.Indef.Static.NN.Pooling as Torch.Cuda.Double.NN.Pooling, Torch.Indef.Static.NN.Sampling as Torch.Cuda.Double.NN.Sampling) requires (Torch.Sig.Index.Tensor as Torch.FFI.THC.Long.Tensor, Torch.Sig.Index.TensorFree as Torch.FFI.THC.Long.Tensor, Torch.Sig.Mask.Tensor as Torch.FFI.THC.Byte.Tensor, Torch.Sig.Mask.TensorFree as Torch.FFI.THC.Byte.Tensor, Torch.Sig.Mask.MathReduce as Torch.FFI.THC.Byte.TensorMathReduce, Torch.Sig.State as Torch.FFI.THC.State, Torch.Sig.Types.Global as Torch.Types.THC, Torch.Sig.Types as Torch.Types.THC.Double, Torch.Sig.Storage as Torch.FFI.THC.Double.Storage, Torch.Sig.Storage.Copy as Torch.FFI.THC.Double.StorageCopy, Torch.Sig.Storage.Memory as Torch.FFI.THC.Double.Storage, Torch.Sig.Tensor as Torch.FFI.THC.Double.Tensor, Torch.Sig.Tensor.Copy as Torch.FFI.THC.Double.TensorCopy, Torch.Sig.Tensor.Memory as Torch.FFI.THC.Double.Tensor, Torch.Sig.Tensor.Index as Torch.FFI.THC.Double.TensorIndex, Torch.Sig.Tensor.Masked as Torch.FFI.THC.Double.TensorMasked, Torch.Sig.Tensor.Math as Torch.FFI.THC.Double.TensorMath, Torch.Sig.Tensor.Math.Compare as Torch.FFI.THC.Double.TensorMathCompare, Torch.Sig.Tensor.Math.CompareT as Torch.FFI.THC.Double.TensorMathCompareT, Torch.Sig.Tensor.Math.Pairwise as Torch.FFI.THC.Double.TensorMathPairwise, Torch.Sig.Tensor.Math.Pointwise as Torch.FFI.THC.Double.TensorMathPointwise, Torch.Sig.Tensor.Math.Reduce as Torch.FFI.THC.Double.TensorMathReduce, Torch.Sig.Tensor.Math.Scan as Torch.FFI.THC.Double.TensorMathScan, Torch.Sig.Tensor.Mode as Torch.FFI.THC.Double.TensorMode, Torch.Sig.Tensor.ScatterGather as Torch.FFI.THC.Double.TensorScatterGather, Torch.Sig.Tensor.Sort as Torch.FFI.THC.Double.TensorSort, Torch.Sig.Tensor.TopK as Torch.FFI.THC.Double.TensorTopK, Torch.Sig.Tensor.Math.Pointwise.Signed as Torch.FFI.THC.Double.TensorMathPointwise, Torch.Sig.Tensor.Math.Pointwise.Floating as Torch.FFI.THC.Double.TensorMathPointwise, Torch.Sig.Tensor.Math.Reduce.Floating as Torch.FFI.THC.Double.TensorMathReduce, Torch.Sig.Tensor.Math.Floating as Torch.FFI.THC.Double.TensorMath, Torch.Sig.Tensor.Math.Blas as Torch.FFI.THC.Double.TensorMathBlas, Torch.Sig.Tensor.Math.Lapack as Torch.FFI.THC.Double.TensorMathMagma, Torch.Sig.NN as Torch.FFI.THC.NN.Double, Torch.Sig.Types.NN as Torch.Types.THC, Torch.Sig.Tensor.Math.Random.TH as Torch.Undefined.Cuda.Double.Tensor.Math.Random.TH, Torch.Sig.Tensor.Random.TH as Torch.Undefined.Cuda.Double.Tensor.Random.TH, Torch.Sig.Tensor.Random.THC as Torch.FFI.THC.Double.TensorRandom) + + if flag(lite) + else + exposed-modules: + Torch.Cuda.Byte + Torch.Cuda.Byte.Dynamic + Torch.Cuda.Byte.Storage + Torch.Cuda.Char + Torch.Cuda.Char.Dynamic + Torch.Cuda.Char.Storage + Torch.Cuda.Short + Torch.Cuda.Short.Dynamic + Torch.Cuda.Short.Storage + Torch.Cuda.Int + Torch.Cuda.Int.Dynamic + Torch.Cuda.Int.Storage + build-depends: + hasktorch-indef-unsigned -any + mixins: hasktorch-indef-unsigned (Torch.Indef.Storage as Torch.Indef.Cuda.Byte.Storage, Torch.Indef.Storage.Copy as Torch.Indef.Cuda.Byte.Storage.Copy, Torch.Indef.Static.Tensor as Torch.Indef.Cuda.Byte.Tensor, Torch.Indef.Static.Tensor.Copy as Torch.Indef.Cuda.Byte.Tensor.Copy, Torch.Indef.Static.Tensor.Index as Torch.Indef.Cuda.Byte.Tensor.Index, Torch.Indef.Static.Tensor.Masked as Torch.Indef.Cuda.Byte.Tensor.Masked, Torch.Indef.Static.Tensor.Math as Torch.Indef.Cuda.Byte.Tensor.Math, Torch.Indef.Static.Tensor.Math.Compare as Torch.Indef.Cuda.Byte.Tensor.Math.Compare, Torch.Indef.Static.Tensor.Math.CompareT as Torch.Indef.Cuda.Byte.Tensor.Math.CompareT, Torch.Indef.Static.Tensor.Math.Pairwise as Torch.Indef.Cuda.Byte.Tensor.Math.Pairwise, Torch.Indef.Static.Tensor.Math.Pointwise as Torch.Indef.Cuda.Byte.Tensor.Math.Pointwise, Torch.Indef.Static.Tensor.Math.Reduce as Torch.Indef.Cuda.Byte.Tensor.Math.Reduce, Torch.Indef.Static.Tensor.Math.Scan as Torch.Indef.Cuda.Byte.Tensor.Math.Scan, Torch.Indef.Static.Tensor.Mode as Torch.Indef.Cuda.Byte.Tensor.Mode, Torch.Indef.Static.Tensor.ScatterGather as Torch.Indef.Cuda.Byte.Tensor.ScatterGather, Torch.Indef.Static.Tensor.Sort as Torch.Indef.Cuda.Byte.Tensor.Sort, Torch.Indef.Static.Tensor.TopK as Torch.Indef.Cuda.Byte.Tensor.TopK, Torch.Indef.Dynamic.Tensor as Torch.Indef.Cuda.Byte.Dynamic.Tensor, Torch.Indef.Dynamic.Tensor.Copy as Torch.Indef.Cuda.Byte.Dynamic.Tensor.Copy, Torch.Indef.Dynamic.Tensor.Index as Torch.Indef.Cuda.Byte.Dynamic.Tensor.Index, Torch.Indef.Dynamic.Tensor.Masked as Torch.Indef.Cuda.Byte.Dynamic.Tensor.Masked, Torch.Indef.Dynamic.Tensor.Math as Torch.Indef.Cuda.Byte.Dynamic.Tensor.Math, Torch.Indef.Dynamic.Tensor.Math.Compare as Torch.Indef.Cuda.Byte.Dynamic.Tensor.Math.Compare, Torch.Indef.Dynamic.Tensor.Math.CompareT as Torch.Indef.Cuda.Byte.Dynamic.Tensor.Math.CompareT, Torch.Indef.Dynamic.Tensor.Math.Pairwise as Torch.Indef.Cuda.Byte.Dynamic.Tensor.Math.Pairwise, Torch.Indef.Dynamic.Tensor.Math.Pointwise as Torch.Indef.Cuda.Byte.Dynamic.Tensor.Math.Pointwise, Torch.Indef.Dynamic.Tensor.Math.Reduce as Torch.Indef.Cuda.Byte.Dynamic.Tensor.Math.Reduce, Torch.Indef.Dynamic.Tensor.Math.Scan as Torch.Indef.Cuda.Byte.Dynamic.Tensor.Math.Scan, Torch.Indef.Dynamic.Tensor.Mode as Torch.Indef.Cuda.Byte.Dynamic.Tensor.Mode, Torch.Indef.Dynamic.Tensor.ScatterGather as Torch.Indef.Cuda.Byte.Dynamic.Tensor.ScatterGather, Torch.Indef.Dynamic.Tensor.Sort as Torch.Indef.Cuda.Byte.Dynamic.Tensor.Sort, Torch.Indef.Dynamic.Tensor.TopK as Torch.Indef.Cuda.Byte.Dynamic.Tensor.TopK, Torch.Indef.Types as Torch.Cuda.Byte.Types, Torch.Indef.Index as Torch.Cuda.Byte.Index, Torch.Indef.Mask as Torch.Cuda.Byte.Mask) requires (Torch.Sig.Index.Tensor as Torch.FFI.THC.Long.Tensor, Torch.Sig.Index.TensorFree as Torch.FFI.THC.Long.Tensor, Torch.Sig.Mask.Tensor as Torch.FFI.THC.Byte.Tensor, Torch.Sig.Mask.TensorFree as Torch.FFI.THC.Byte.Tensor, Torch.Sig.Mask.MathReduce as Torch.FFI.THC.Byte.TensorMathReduce, Torch.Sig.State as Torch.FFI.THC.State, Torch.Sig.Types.Global as Torch.Types.THC, Torch.Sig.Types as Torch.Types.THC.Byte, Torch.Sig.Storage as Torch.FFI.THC.Byte.Storage, Torch.Sig.Storage.Copy as Torch.FFI.THC.Byte.StorageCopy, Torch.Sig.Storage.Memory as Torch.FFI.THC.Byte.Storage, Torch.Sig.Tensor as Torch.FFI.THC.Byte.Tensor, Torch.Sig.Tensor.Copy as Torch.FFI.THC.Byte.TensorCopy, Torch.Sig.Tensor.Memory as Torch.FFI.THC.Byte.Tensor, Torch.Sig.Tensor.Index as Torch.FFI.THC.Byte.TensorIndex, Torch.Sig.Tensor.Masked as Torch.FFI.THC.Byte.TensorMasked, Torch.Sig.Tensor.Math as Torch.FFI.THC.Byte.TensorMath, Torch.Sig.Tensor.Math.Compare as Torch.FFI.THC.Byte.TensorMathCompare, Torch.Sig.Tensor.Math.CompareT as Torch.FFI.THC.Byte.TensorMathCompareT, Torch.Sig.Tensor.Math.Pairwise as Torch.FFI.THC.Byte.TensorMathPairwise, Torch.Sig.Tensor.Math.Pointwise as Torch.FFI.THC.Byte.TensorMathPointwise, Torch.Sig.Tensor.Math.Reduce as Torch.FFI.THC.Byte.TensorMathReduce, Torch.Sig.Tensor.Math.Scan as Torch.FFI.THC.Byte.TensorMathScan, Torch.Sig.Tensor.Mode as Torch.FFI.THC.Byte.TensorMode, Torch.Sig.Tensor.ScatterGather as Torch.FFI.THC.Byte.TensorScatterGather, Torch.Sig.Tensor.Sort as Torch.FFI.THC.Byte.TensorSort, Torch.Sig.Tensor.TopK as Torch.FFI.THC.Byte.TensorTopK), + hasktorch-indef-unsigned (Torch.Indef.Storage as Torch.Indef.Cuda.Char.Storage, Torch.Indef.Storage.Copy as Torch.Indef.Cuda.Char.Storage.Copy, Torch.Indef.Static.Tensor as Torch.Indef.Cuda.Char.Tensor, Torch.Indef.Static.Tensor.Copy as Torch.Indef.Cuda.Char.Tensor.Copy, Torch.Indef.Static.Tensor.Index as Torch.Indef.Cuda.Char.Tensor.Index, Torch.Indef.Static.Tensor.Masked as Torch.Indef.Cuda.Char.Tensor.Masked, Torch.Indef.Static.Tensor.Math as Torch.Indef.Cuda.Char.Tensor.Math, Torch.Indef.Static.Tensor.Math.Compare as Torch.Indef.Cuda.Char.Tensor.Math.Compare, Torch.Indef.Static.Tensor.Math.CompareT as Torch.Indef.Cuda.Char.Tensor.Math.CompareT, Torch.Indef.Static.Tensor.Math.Pairwise as Torch.Indef.Cuda.Char.Tensor.Math.Pairwise, Torch.Indef.Static.Tensor.Math.Pointwise as Torch.Indef.Cuda.Char.Tensor.Math.Pointwise, Torch.Indef.Static.Tensor.Math.Reduce as Torch.Indef.Cuda.Char.Tensor.Math.Reduce, Torch.Indef.Static.Tensor.Math.Scan as Torch.Indef.Cuda.Char.Tensor.Math.Scan, Torch.Indef.Static.Tensor.Mode as Torch.Indef.Cuda.Char.Tensor.Mode, Torch.Indef.Static.Tensor.ScatterGather as Torch.Indef.Cuda.Char.Tensor.ScatterGather, Torch.Indef.Static.Tensor.Sort as Torch.Indef.Cuda.Char.Tensor.Sort, Torch.Indef.Static.Tensor.TopK as Torch.Indef.Cuda.Char.Tensor.TopK, Torch.Indef.Dynamic.Tensor as Torch.Indef.Cuda.Char.Dynamic.Tensor, Torch.Indef.Dynamic.Tensor.Copy as Torch.Indef.Cuda.Char.Dynamic.Tensor.Copy, Torch.Indef.Dynamic.Tensor.Index as Torch.Indef.Cuda.Char.Dynamic.Tensor.Index, Torch.Indef.Dynamic.Tensor.Masked as Torch.Indef.Cuda.Char.Dynamic.Tensor.Masked, Torch.Indef.Dynamic.Tensor.Math as Torch.Indef.Cuda.Char.Dynamic.Tensor.Math, Torch.Indef.Dynamic.Tensor.Math.Compare as Torch.Indef.Cuda.Char.Dynamic.Tensor.Math.Compare, Torch.Indef.Dynamic.Tensor.Math.CompareT as Torch.Indef.Cuda.Char.Dynamic.Tensor.Math.CompareT, Torch.Indef.Dynamic.Tensor.Math.Pairwise as Torch.Indef.Cuda.Char.Dynamic.Tensor.Math.Pairwise, Torch.Indef.Dynamic.Tensor.Math.Pointwise as Torch.Indef.Cuda.Char.Dynamic.Tensor.Math.Pointwise, Torch.Indef.Dynamic.Tensor.Math.Reduce as Torch.Indef.Cuda.Char.Dynamic.Tensor.Math.Reduce, Torch.Indef.Dynamic.Tensor.Math.Scan as Torch.Indef.Cuda.Char.Dynamic.Tensor.Math.Scan, Torch.Indef.Dynamic.Tensor.Mode as Torch.Indef.Cuda.Char.Dynamic.Tensor.Mode, Torch.Indef.Dynamic.Tensor.ScatterGather as Torch.Indef.Cuda.Char.Dynamic.Tensor.ScatterGather, Torch.Indef.Dynamic.Tensor.Sort as Torch.Indef.Cuda.Char.Dynamic.Tensor.Sort, Torch.Indef.Dynamic.Tensor.TopK as Torch.Indef.Cuda.Char.Dynamic.Tensor.TopK, Torch.Indef.Types as Torch.Cuda.Char.Types, Torch.Indef.Index as Torch.Cuda.Char.Index, Torch.Indef.Mask as Torch.Cuda.Char.Mask) requires (Torch.Sig.Index.Tensor as Torch.FFI.THC.Long.Tensor, Torch.Sig.Index.TensorFree as Torch.FFI.THC.Long.Tensor, Torch.Sig.Mask.Tensor as Torch.FFI.THC.Byte.Tensor, Torch.Sig.Mask.TensorFree as Torch.FFI.THC.Byte.Tensor, Torch.Sig.Mask.MathReduce as Torch.FFI.THC.Byte.TensorMathReduce, Torch.Sig.State as Torch.FFI.THC.State, Torch.Sig.Types.Global as Torch.Types.THC, Torch.Sig.Types as Torch.Types.THC.Char, Torch.Sig.Storage as Torch.FFI.THC.Char.Storage, Torch.Sig.Storage.Copy as Torch.FFI.THC.Char.StorageCopy, Torch.Sig.Storage.Memory as Torch.FFI.THC.Char.Storage, Torch.Sig.Tensor as Torch.FFI.THC.Char.Tensor, Torch.Sig.Tensor.Copy as Torch.FFI.THC.Char.TensorCopy, Torch.Sig.Tensor.Memory as Torch.FFI.THC.Char.Tensor, Torch.Sig.Tensor.Index as Torch.FFI.THC.Char.TensorIndex, Torch.Sig.Tensor.Masked as Torch.FFI.THC.Char.TensorMasked, Torch.Sig.Tensor.Math as Torch.FFI.THC.Char.TensorMath, Torch.Sig.Tensor.Math.Compare as Torch.FFI.THC.Char.TensorMathCompare, Torch.Sig.Tensor.Math.CompareT as Torch.FFI.THC.Char.TensorMathCompareT, Torch.Sig.Tensor.Math.Pairwise as Torch.FFI.THC.Char.TensorMathPairwise, Torch.Sig.Tensor.Math.Pointwise as Torch.FFI.THC.Char.TensorMathPointwise, Torch.Sig.Tensor.Math.Reduce as Torch.FFI.THC.Char.TensorMathReduce, Torch.Sig.Tensor.Math.Scan as Torch.FFI.THC.Char.TensorMathScan, Torch.Sig.Tensor.Mode as Torch.FFI.THC.Char.TensorMode, Torch.Sig.Tensor.ScatterGather as Torch.FFI.THC.Char.TensorScatterGather, Torch.Sig.Tensor.Sort as Torch.FFI.THC.Char.TensorSort, Torch.Sig.Tensor.TopK as Torch.FFI.THC.Char.TensorTopK), + hasktorch-indef-signed (Torch.Indef.Storage as Torch.Indef.Cuda.Short.Storage, Torch.Indef.Storage.Copy as Torch.Indef.Cuda.Short.Storage.Copy, Torch.Indef.Static.Tensor as Torch.Indef.Cuda.Short.Tensor, Torch.Indef.Static.Tensor.Copy as Torch.Indef.Cuda.Short.Tensor.Copy, Torch.Indef.Static.Tensor.Index as Torch.Indef.Cuda.Short.Tensor.Index, Torch.Indef.Static.Tensor.Masked as Torch.Indef.Cuda.Short.Tensor.Masked, Torch.Indef.Static.Tensor.Math as Torch.Indef.Cuda.Short.Tensor.Math, Torch.Indef.Static.Tensor.Math.Compare as Torch.Indef.Cuda.Short.Tensor.Math.Compare, Torch.Indef.Static.Tensor.Math.CompareT as Torch.Indef.Cuda.Short.Tensor.Math.CompareT, Torch.Indef.Static.Tensor.Math.Pairwise as Torch.Indef.Cuda.Short.Tensor.Math.Pairwise, Torch.Indef.Static.Tensor.Math.Pointwise as Torch.Indef.Cuda.Short.Tensor.Math.Pointwise, Torch.Indef.Static.Tensor.Math.Reduce as Torch.Indef.Cuda.Short.Tensor.Math.Reduce, Torch.Indef.Static.Tensor.Math.Scan as Torch.Indef.Cuda.Short.Tensor.Math.Scan, Torch.Indef.Static.Tensor.Mode as Torch.Indef.Cuda.Short.Tensor.Mode, Torch.Indef.Static.Tensor.ScatterGather as Torch.Indef.Cuda.Short.Tensor.ScatterGather, Torch.Indef.Static.Tensor.Sort as Torch.Indef.Cuda.Short.Tensor.Sort, Torch.Indef.Static.Tensor.TopK as Torch.Indef.Cuda.Short.Tensor.TopK, Torch.Indef.Dynamic.Tensor as Torch.Indef.Cuda.Short.Dynamic.Tensor, Torch.Indef.Dynamic.Tensor.Copy as Torch.Indef.Cuda.Short.Dynamic.Tensor.Copy, Torch.Indef.Dynamic.Tensor.Index as Torch.Indef.Cuda.Short.Dynamic.Tensor.Index, Torch.Indef.Dynamic.Tensor.Masked as Torch.Indef.Cuda.Short.Dynamic.Tensor.Masked, Torch.Indef.Dynamic.Tensor.Math as Torch.Indef.Cuda.Short.Dynamic.Tensor.Math, Torch.Indef.Dynamic.Tensor.Math.Compare as Torch.Indef.Cuda.Short.Dynamic.Tensor.Math.Compare, Torch.Indef.Dynamic.Tensor.Math.CompareT as Torch.Indef.Cuda.Short.Dynamic.Tensor.Math.CompareT, Torch.Indef.Dynamic.Tensor.Math.Pairwise as Torch.Indef.Cuda.Short.Dynamic.Tensor.Math.Pairwise, Torch.Indef.Dynamic.Tensor.Math.Pointwise as Torch.Indef.Cuda.Short.Dynamic.Tensor.Math.Pointwise, Torch.Indef.Dynamic.Tensor.Math.Reduce as Torch.Indef.Cuda.Short.Dynamic.Tensor.Math.Reduce, Torch.Indef.Dynamic.Tensor.Math.Scan as Torch.Indef.Cuda.Short.Dynamic.Tensor.Math.Scan, Torch.Indef.Dynamic.Tensor.Mode as Torch.Indef.Cuda.Short.Dynamic.Tensor.Mode, Torch.Indef.Dynamic.Tensor.ScatterGather as Torch.Indef.Cuda.Short.Dynamic.Tensor.ScatterGather, Torch.Indef.Dynamic.Tensor.Sort as Torch.Indef.Cuda.Short.Dynamic.Tensor.Sort, Torch.Indef.Dynamic.Tensor.TopK as Torch.Indef.Cuda.Short.Dynamic.Tensor.TopK, Torch.Indef.Types as Torch.Cuda.Short.Types, Torch.Indef.Index as Torch.Cuda.Short.Index, Torch.Indef.Mask as Torch.Cuda.Short.Mask, Torch.Indef.Static.Tensor.Math.Pointwise.Signed as Torch.Indef.Cuda.Short.Tensor.Math.Pointwise.Signed, Torch.Indef.Dynamic.Tensor.Math.Pointwise.Signed as Torch.Indef.Cuda.Short.Dynamic.Tensor.Math.Pointwise.Signed) requires (Torch.Sig.Index.Tensor as Torch.FFI.THC.Long.Tensor, Torch.Sig.Index.TensorFree as Torch.FFI.THC.Long.Tensor, Torch.Sig.Mask.Tensor as Torch.FFI.THC.Byte.Tensor, Torch.Sig.Mask.TensorFree as Torch.FFI.THC.Byte.Tensor, Torch.Sig.Mask.MathReduce as Torch.FFI.THC.Byte.TensorMathReduce, Torch.Sig.State as Torch.FFI.THC.State, Torch.Sig.Types.Global as Torch.Types.THC, Torch.Sig.Types as Torch.Types.THC.Short, Torch.Sig.Storage as Torch.FFI.THC.Short.Storage, Torch.Sig.Storage.Copy as Torch.FFI.THC.Short.StorageCopy, Torch.Sig.Storage.Memory as Torch.FFI.THC.Short.Storage, Torch.Sig.Tensor as Torch.FFI.THC.Short.Tensor, Torch.Sig.Tensor.Copy as Torch.FFI.THC.Short.TensorCopy, Torch.Sig.Tensor.Memory as Torch.FFI.THC.Short.Tensor, Torch.Sig.Tensor.Index as Torch.FFI.THC.Short.TensorIndex, Torch.Sig.Tensor.Masked as Torch.FFI.THC.Short.TensorMasked, Torch.Sig.Tensor.Math as Torch.FFI.THC.Short.TensorMath, Torch.Sig.Tensor.Math.Compare as Torch.FFI.THC.Short.TensorMathCompare, Torch.Sig.Tensor.Math.CompareT as Torch.FFI.THC.Short.TensorMathCompareT, Torch.Sig.Tensor.Math.Pairwise as Torch.FFI.THC.Short.TensorMathPairwise, Torch.Sig.Tensor.Math.Pointwise as Torch.FFI.THC.Short.TensorMathPointwise, Torch.Sig.Tensor.Math.Reduce as Torch.FFI.THC.Short.TensorMathReduce, Torch.Sig.Tensor.Math.Scan as Torch.FFI.THC.Short.TensorMathScan, Torch.Sig.Tensor.Mode as Torch.FFI.THC.Short.TensorMode, Torch.Sig.Tensor.ScatterGather as Torch.FFI.THC.Short.TensorScatterGather, Torch.Sig.Tensor.Sort as Torch.FFI.THC.Short.TensorSort, Torch.Sig.Tensor.TopK as Torch.FFI.THC.Short.TensorTopK, Torch.Sig.Tensor.Math.Pointwise.Signed as Torch.FFI.THC.Short.TensorMathPointwise), + hasktorch-indef-signed (Torch.Indef.Storage as Torch.Indef.Cuda.Int.Storage, Torch.Indef.Storage.Copy as Torch.Indef.Cuda.Int.Storage.Copy, Torch.Indef.Static.Tensor as Torch.Indef.Cuda.Int.Tensor, Torch.Indef.Static.Tensor.Copy as Torch.Indef.Cuda.Int.Tensor.Copy, Torch.Indef.Static.Tensor.Index as Torch.Indef.Cuda.Int.Tensor.Index, Torch.Indef.Static.Tensor.Masked as Torch.Indef.Cuda.Int.Tensor.Masked, Torch.Indef.Static.Tensor.Math as Torch.Indef.Cuda.Int.Tensor.Math, Torch.Indef.Static.Tensor.Math.Compare as Torch.Indef.Cuda.Int.Tensor.Math.Compare, Torch.Indef.Static.Tensor.Math.CompareT as Torch.Indef.Cuda.Int.Tensor.Math.CompareT, Torch.Indef.Static.Tensor.Math.Pairwise as Torch.Indef.Cuda.Int.Tensor.Math.Pairwise, Torch.Indef.Static.Tensor.Math.Pointwise as Torch.Indef.Cuda.Int.Tensor.Math.Pointwise, Torch.Indef.Static.Tensor.Math.Reduce as Torch.Indef.Cuda.Int.Tensor.Math.Reduce, Torch.Indef.Static.Tensor.Math.Scan as Torch.Indef.Cuda.Int.Tensor.Math.Scan, Torch.Indef.Static.Tensor.Mode as Torch.Indef.Cuda.Int.Tensor.Mode, Torch.Indef.Static.Tensor.ScatterGather as Torch.Indef.Cuda.Int.Tensor.ScatterGather, Torch.Indef.Static.Tensor.Sort as Torch.Indef.Cuda.Int.Tensor.Sort, Torch.Indef.Static.Tensor.TopK as Torch.Indef.Cuda.Int.Tensor.TopK, Torch.Indef.Dynamic.Tensor as Torch.Indef.Cuda.Int.Dynamic.Tensor, Torch.Indef.Dynamic.Tensor.Copy as Torch.Indef.Cuda.Int.Dynamic.Tensor.Copy, Torch.Indef.Dynamic.Tensor.Index as Torch.Indef.Cuda.Int.Dynamic.Tensor.Index, Torch.Indef.Dynamic.Tensor.Masked as Torch.Indef.Cuda.Int.Dynamic.Tensor.Masked, Torch.Indef.Dynamic.Tensor.Math as Torch.Indef.Cuda.Int.Dynamic.Tensor.Math, Torch.Indef.Dynamic.Tensor.Math.Compare as Torch.Indef.Cuda.Int.Dynamic.Tensor.Math.Compare, Torch.Indef.Dynamic.Tensor.Math.CompareT as Torch.Indef.Cuda.Int.Dynamic.Tensor.Math.CompareT, Torch.Indef.Dynamic.Tensor.Math.Pairwise as Torch.Indef.Cuda.Int.Dynamic.Tensor.Math.Pairwise, Torch.Indef.Dynamic.Tensor.Math.Pointwise as Torch.Indef.Cuda.Int.Dynamic.Tensor.Math.Pointwise, Torch.Indef.Dynamic.Tensor.Math.Reduce as Torch.Indef.Cuda.Int.Dynamic.Tensor.Math.Reduce, Torch.Indef.Dynamic.Tensor.Math.Scan as Torch.Indef.Cuda.Int.Dynamic.Tensor.Math.Scan, Torch.Indef.Dynamic.Tensor.Mode as Torch.Indef.Cuda.Int.Dynamic.Tensor.Mode, Torch.Indef.Dynamic.Tensor.ScatterGather as Torch.Indef.Cuda.Int.Dynamic.Tensor.ScatterGather, Torch.Indef.Dynamic.Tensor.Sort as Torch.Indef.Cuda.Int.Dynamic.Tensor.Sort, Torch.Indef.Dynamic.Tensor.TopK as Torch.Indef.Cuda.Int.Dynamic.Tensor.TopK, Torch.Indef.Types as Torch.Cuda.Int.Types, Torch.Indef.Index as Torch.Cuda.Int.Index, Torch.Indef.Mask as Torch.Cuda.Int.Mask, Torch.Indef.Static.Tensor.Math.Pointwise.Signed as Torch.Indef.Cuda.Int.Tensor.Math.Pointwise.Signed, Torch.Indef.Dynamic.Tensor.Math.Pointwise.Signed as Torch.Indef.Cuda.Int.Dynamic.Tensor.Math.Pointwise.Signed) requires (Torch.Sig.Index.Tensor as Torch.FFI.THC.Long.Tensor, Torch.Sig.Index.TensorFree as Torch.FFI.THC.Long.Tensor, Torch.Sig.Mask.Tensor as Torch.FFI.THC.Byte.Tensor, Torch.Sig.Mask.TensorFree as Torch.FFI.THC.Byte.Tensor, Torch.Sig.Mask.MathReduce as Torch.FFI.THC.Byte.TensorMathReduce, Torch.Sig.State as Torch.FFI.THC.State, Torch.Sig.Types.Global as Torch.Types.THC, Torch.Sig.Types as Torch.Types.THC.Int, Torch.Sig.Storage as Torch.FFI.THC.Int.Storage, Torch.Sig.Storage.Copy as Torch.FFI.THC.Int.StorageCopy, Torch.Sig.Storage.Memory as Torch.FFI.THC.Int.Storage, Torch.Sig.Tensor as Torch.FFI.THC.Int.Tensor, Torch.Sig.Tensor.Copy as Torch.FFI.THC.Int.TensorCopy, Torch.Sig.Tensor.Memory as Torch.FFI.THC.Int.Tensor, Torch.Sig.Tensor.Index as Torch.FFI.THC.Int.TensorIndex, Torch.Sig.Tensor.Masked as Torch.FFI.THC.Int.TensorMasked, Torch.Sig.Tensor.Math as Torch.FFI.THC.Int.TensorMath, Torch.Sig.Tensor.Math.Compare as Torch.FFI.THC.Int.TensorMathCompare, Torch.Sig.Tensor.Math.CompareT as Torch.FFI.THC.Int.TensorMathCompareT, Torch.Sig.Tensor.Math.Pairwise as Torch.FFI.THC.Int.TensorMathPairwise, Torch.Sig.Tensor.Math.Pointwise as Torch.FFI.THC.Int.TensorMathPointwise, Torch.Sig.Tensor.Math.Reduce as Torch.FFI.THC.Int.TensorMathReduce, Torch.Sig.Tensor.Math.Scan as Torch.FFI.THC.Int.TensorMathScan, Torch.Sig.Tensor.Mode as Torch.FFI.THC.Int.TensorMode, Torch.Sig.Tensor.ScatterGather as Torch.FFI.THC.Int.TensorScatterGather, Torch.Sig.Tensor.Sort as Torch.FFI.THC.Int.TensorSort, Torch.Sig.Tensor.TopK as Torch.FFI.THC.Int.TensorTopK, Torch.Sig.Tensor.Math.Pointwise.Signed as Torch.FFI.THC.Int.TensorMathPointwise) + +library hasktorch-indef-unsigned + reexported-modules: Torch.Indef.Index, + Torch.Indef.Mask, + Torch.Indef.Types, + Torch.Indef.Storage, + Torch.Indef.Storage.Copy, + Torch.Indef.Dynamic.Print, + Torch.Indef.Dynamic.Tensor, + Torch.Indef.Dynamic.Tensor.Copy, + Torch.Indef.Dynamic.Tensor.Index, + Torch.Indef.Dynamic.Tensor.Masked, + Torch.Indef.Dynamic.Tensor.Math, + Torch.Indef.Dynamic.Tensor.Math.Compare, + Torch.Indef.Dynamic.Tensor.Math.CompareT, + Torch.Indef.Dynamic.Tensor.Math.Pairwise, + Torch.Indef.Dynamic.Tensor.Math.Pointwise, + Torch.Indef.Dynamic.Tensor.Math.Reduce, + Torch.Indef.Dynamic.Tensor.Math.Scan, + Torch.Indef.Dynamic.Tensor.Mode, + Torch.Indef.Dynamic.Tensor.ScatterGather, + Torch.Indef.Dynamic.Tensor.Sort, + Torch.Indef.Dynamic.Tensor.TopK, + Torch.Indef.Static.Tensor, + Torch.Indef.Static.Tensor.Copy, + Torch.Indef.Static.Tensor.Index, + Torch.Indef.Static.Tensor.Masked, + Torch.Indef.Static.Tensor.Math, + Torch.Indef.Static.Tensor.Math.Compare, + Torch.Indef.Static.Tensor.Math.CompareT, + Torch.Indef.Static.Tensor.Math.Pairwise, + Torch.Indef.Static.Tensor.Math.Pointwise, + Torch.Indef.Static.Tensor.Math.Reduce, + Torch.Indef.Static.Tensor.Math.Scan, + Torch.Indef.Static.Tensor.Mode, + Torch.Indef.Static.Tensor.ScatterGather, + Torch.Indef.Static.Tensor.Sort, + Torch.Indef.Static.Tensor.TopK + default-language: Haskell2010 + build-depends: + base (==4.7 || >4.7) && <5, + hasktorch-signatures-partial (==0.0.1 || >0.0.1) && <0.0.2, + hasktorch-indef -any + mixins: hasktorch-indef requires (Torch.Sig.NN as Torch.Undefined.NN, Torch.Sig.Types.NN as Torch.Undefined.Types.NN, Torch.Sig.Tensor.Math.Blas as Torch.Undefined.Tensor.Math.Blas, Torch.Sig.Tensor.Math.Floating as Torch.Undefined.Tensor.Math.Floating, Torch.Sig.Tensor.Math.Lapack as Torch.Undefined.Tensor.Math.Lapack, Torch.Sig.Tensor.Math.Pointwise.Signed as Torch.Undefined.Tensor.Math.Pointwise.Signed, Torch.Sig.Tensor.Math.Pointwise.Floating as Torch.Undefined.Tensor.Math.Pointwise.Floating, Torch.Sig.Tensor.Math.Reduce.Floating as Torch.Undefined.Tensor.Math.Reduce.Floating, Torch.Sig.Tensor.Math.Random.TH as Torch.Undefined.Tensor.Math.Random.TH, Torch.Sig.Tensor.Random.TH as Torch.Undefined.Tensor.Random.TH, Torch.Sig.Tensor.Random.THC as Torch.Undefined.Tensor.Random.THC) + +library hasktorch-indef-signed + reexported-modules: Torch.Indef.Index, + Torch.Indef.Mask, + Torch.Indef.Types, + Torch.Indef.Storage, + Torch.Indef.Storage.Copy, + Torch.Indef.Dynamic.Print, + Torch.Indef.Dynamic.Tensor, + Torch.Indef.Dynamic.Tensor.Copy, + Torch.Indef.Dynamic.Tensor.Index, + Torch.Indef.Dynamic.Tensor.Masked, + Torch.Indef.Dynamic.Tensor.Math, + Torch.Indef.Dynamic.Tensor.Math.Compare, + Torch.Indef.Dynamic.Tensor.Math.CompareT, + Torch.Indef.Dynamic.Tensor.Math.Pairwise, + Torch.Indef.Dynamic.Tensor.Math.Pointwise, + Torch.Indef.Dynamic.Tensor.Math.Reduce, + Torch.Indef.Dynamic.Tensor.Math.Scan, + Torch.Indef.Dynamic.Tensor.Mode, + Torch.Indef.Dynamic.Tensor.ScatterGather, + Torch.Indef.Dynamic.Tensor.Sort, + Torch.Indef.Dynamic.Tensor.TopK, + Torch.Indef.Static.Tensor, + Torch.Indef.Static.Tensor.Copy, + Torch.Indef.Static.Tensor.Index, + Torch.Indef.Static.Tensor.Masked, + Torch.Indef.Static.Tensor.Math, + Torch.Indef.Static.Tensor.Math.Compare, + Torch.Indef.Static.Tensor.Math.CompareT, + Torch.Indef.Static.Tensor.Math.Pairwise, + Torch.Indef.Static.Tensor.Math.Pointwise, + Torch.Indef.Static.Tensor.Math.Reduce, + Torch.Indef.Static.Tensor.Math.Scan, + Torch.Indef.Static.Tensor.Mode, + Torch.Indef.Static.Tensor.ScatterGather, + Torch.Indef.Static.Tensor.Sort, + Torch.Indef.Static.Tensor.TopK, + Torch.Indef.Static.Tensor.Math.Pointwise.Signed, + Torch.Indef.Dynamic.Tensor.Math.Pointwise.Signed + default-language: Haskell2010 + build-depends: + base (==4.7 || >4.7) && <5, + hasktorch-signatures-partial (==0.0.1 || >0.0.1) && <0.0.2, + hasktorch-indef -any + mixins: hasktorch-indef requires (Torch.Sig.NN as Torch.Undefined.NN, Torch.Sig.Types.NN as Torch.Undefined.Types.NN, Torch.Sig.Tensor.Math.Blas as Torch.Undefined.Tensor.Math.Blas, Torch.Sig.Tensor.Math.Floating as Torch.Undefined.Tensor.Math.Floating, Torch.Sig.Tensor.Math.Lapack as Torch.Undefined.Tensor.Math.Lapack, Torch.Sig.Tensor.Math.Pointwise.Floating as Torch.Undefined.Tensor.Math.Pointwise.Floating, Torch.Sig.Tensor.Math.Reduce.Floating as Torch.Undefined.Tensor.Math.Reduce.Floating, Torch.Sig.Tensor.Math.Random.TH as Torch.Undefined.Tensor.Math.Random.TH, Torch.Sig.Tensor.Random.TH as Torch.Undefined.Tensor.Random.TH, Torch.Sig.Tensor.Random.THC as Torch.Undefined.Tensor.Random.THC) + +library hasktorch-indef-floating + reexported-modules: Torch.Indef.Index, + Torch.Indef.Mask, + Torch.Indef.Types, + Torch.Indef.Storage, + Torch.Indef.Storage.Copy, + Torch.Indef.Dynamic.Print, + Torch.Indef.Dynamic.Tensor, + Torch.Indef.Dynamic.Tensor.Copy, + Torch.Indef.Dynamic.Tensor.Index, + Torch.Indef.Dynamic.Tensor.Masked, + Torch.Indef.Dynamic.Tensor.Math, + Torch.Indef.Dynamic.Tensor.Math.Compare, + Torch.Indef.Dynamic.Tensor.Math.CompareT, + Torch.Indef.Dynamic.Tensor.Math.Pairwise, + Torch.Indef.Dynamic.Tensor.Math.Pointwise, + Torch.Indef.Dynamic.Tensor.Math.Reduce, + Torch.Indef.Dynamic.Tensor.Math.Scan, + Torch.Indef.Dynamic.Tensor.Mode, + Torch.Indef.Dynamic.Tensor.ScatterGather, + Torch.Indef.Dynamic.Tensor.Sort, + Torch.Indef.Dynamic.Tensor.TopK, + Torch.Indef.Static.Tensor, + Torch.Indef.Static.Tensor.Copy, + Torch.Indef.Static.Tensor.Index, + Torch.Indef.Static.Tensor.Masked, + Torch.Indef.Static.Tensor.Math, + Torch.Indef.Static.Tensor.Math.Compare, + Torch.Indef.Static.Tensor.Math.CompareT, + Torch.Indef.Static.Tensor.Math.Pairwise, + Torch.Indef.Static.Tensor.Math.Pointwise, + Torch.Indef.Static.Tensor.Math.Reduce, + Torch.Indef.Static.Tensor.Math.Scan, + Torch.Indef.Static.Tensor.Mode, + Torch.Indef.Static.Tensor.ScatterGather, + Torch.Indef.Static.Tensor.Sort, + Torch.Indef.Static.Tensor.TopK, + Torch.Indef.Static.Tensor.Math.Pointwise.Signed, + Torch.Indef.Dynamic.Tensor.Math.Pointwise.Signed, + Torch.Indef.Dynamic.Tensor.Math.Blas, + Torch.Indef.Dynamic.Tensor.Math.Floating, + Torch.Indef.Dynamic.Tensor.Math.Lapack, + Torch.Indef.Dynamic.Tensor.Math.Pointwise.Floating, + Torch.Indef.Dynamic.Tensor.Math.Reduce.Floating, + Torch.Indef.Dynamic.Tensor.Random.TH, + Torch.Indef.Dynamic.Tensor.Random.THC, + Torch.Indef.Dynamic.Tensor.Math.Random.TH, + Torch.Indef.Static.Tensor.Math.Blas, + Torch.Indef.Static.Tensor.Math.Floating, + Torch.Indef.Static.Tensor.Math.Lapack, + Torch.Indef.Static.Tensor.Math.Pointwise.Floating, + Torch.Indef.Static.Tensor.Math.Reduce.Floating, + Torch.Indef.Static.Tensor.Random.TH, + Torch.Indef.Static.Tensor.Random.THC, + Torch.Indef.Static.Tensor.Math.Random.TH, + Torch.Indef.Dynamic.NN, + Torch.Indef.Dynamic.NN.Activation, + Torch.Indef.Dynamic.NN.Pooling, + Torch.Indef.Dynamic.NN.Criterion, + Torch.Indef.Static.NN, + Torch.Indef.Static.NN.Activation, + Torch.Indef.Static.NN.Backprop, + Torch.Indef.Static.NN.Conv1d, + Torch.Indef.Static.NN.Conv2d, + Torch.Indef.Static.NN.Criterion, + Torch.Indef.Static.NN.Layers, + Torch.Indef.Static.NN.Linear, + Torch.Indef.Static.NN.Math, + Torch.Indef.Static.NN.Padding, + Torch.Indef.Static.NN.Pooling, + Torch.Indef.Static.NN.Sampling, + Torch.Undefined.Tensor.Math.Random.TH, + Torch.Undefined.Tensor.Random.TH, + Torch.Undefined.Tensor.Random.THC + default-language: Haskell2010 + build-depends: + base (==4.7 || >4.7) && <5, + hasktorch-indef -any, + hasktorch-signatures-partial (==0.0.1 || >0.0.1) && <0.0.2 + +executable isdefinite-cpu + main-is: Noop.hs + hs-source-dirs: exe + default-language: Haskell2010 + build-depends: + base (==4.7 || >4.7) && <5, + hasktorch-cpu -any + +executable isdefinite-gpu + main-is: Noop.hs + hs-source-dirs: exe + default-language: Haskell2010 + build-depends: + base (==4.7 || >4.7) && <5, + hasktorch-gpu -any + +executable isdefinite + main-is: Noop.hs + hs-source-dirs: exe + default-language: Haskell2010 + build-depends: + base (==4.7 || >4.7) && <5, + hasktorch -any + +executable memcheck + main-is: Memcheck.hs + hs-source-dirs: exe + default-language: Haskell2010 + build-depends: + base (==4.7 || >4.7) && <5, + hasktorch -any + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: tests + other-modules: + Orphans + MemorySpec + RawLapackSVDSpec + GarbageCollectionSpec + Torch.Prelude.Extras + Torch.Core.LogAddSpec + Torch.Core.RandomSpec + Torch.Static.NN.AbsSpec + Torch.Static.NN.LinearSpec + default-language: Haskell2010 + default-extensions: LambdaCase DataKinds TypeFamilies + TypeSynonymInstances ScopedTypeVariables FlexibleContexts CPP + build-depends: + QuickCheck ==2.11 || >2.11, + backprop ==0.2.5 || >0.2.5, + base (==4.7 || >4.7) && <5, + dimensions ==1.0 || >1.0, + ghc-typelits-natnormalise -any, + hasktorch -any, + hspec ==2.4.4 || >2.4.4, + singletons ==2.2 || >2.2, + -- text ==1.2.2 || >1.2.2, + mtl ==2.2.2 || >2.2.2, + microlens-platform ==0.3.10 || >0.3.10, + monad-loops ==0.4.3 || >0.4.3, + time ==1.8.0 || >1.8.0, + transformers ==0.5.5 || >0.5.5, + generic-lens -any + diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/hasktorch.expr b/cabal/Cabal-tests/tests/ParserTests/regressions/hasktorch.expr new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/hasktorch.expr @@ -0,0 +1,10189 @@ +GenericPackageDescription { + packageDescription = + PackageDescription { + specVersion = CabalSpecV2_2, + package = PackageIdentifier { + pkgName = PackageName + "hasktorch", + pkgVersion = mkVersion + [0, 0, 1, 0]}, + licenseRaw = Left + (License + (ELicense + (ELicenseId BSD_3_Clause) + Nothing)), + licenseFiles = [], + copyright = "", + maintainer = + "Sam Stites , Austin Huang - cipher:ROT13", + author = "Hasktorch dev team", + stability = "", + testedWith = [], + homepage = + "https://github.com/hasktorch/hasktorch#readme", + pkgUrl = "", + bugReports = + "https://github.com/hasktorch/hasktorch/issues", + sourceRepos = [ + SourceRepo { + repoKind = RepoHead, + repoType = Just + (KnownRepoType Git), + repoLocation = Just + "https://github.com/hasktorch/hasktorch", + repoModule = Nothing, + repoBranch = Nothing, + repoTag = Nothing, + repoSubdir = Nothing}], + synopsis = + "Torch for tensors and neural networks in Haskell", + description = + "Hasktorch is a library for tensors and neural networks in Haskell. It is an independent open source community project which leverages the core C libraries shared by Torch and PyTorch. This library leverages @cabal v2-build@ and @backpack@. *Note that this project is in early development and should only be used by contributing developers. Expect substantial changes to the library API as it evolves. Contributions and PRs are welcome (see details on github).*", + category = + "Tensors, Machine Learning, AI", + customFieldsPD = [], + buildTypeRaw = Just Simple, + setupBuildInfo = Nothing, + library = Nothing, + subLibraries = [], + executables = [], + foreignLibs = [], + testSuites = [], + benchmarks = [], + dataFiles = [], + dataDir = ".", + extraSrcFiles = [], + extraTmpFiles = [], + extraDocFiles = []}, + gpdScannedVersion = Nothing, + genPackageFlags = [ + MkPackageFlag { + flagName = FlagName "cuda", + flagDescription = + "build with THC support", + flagDefault = False, + flagManual = False}, + MkPackageFlag { + flagName = FlagName "lite", + flagDescription = + "only build with Double and Long support", + flagDefault = False, + flagManual = False}], + condLibrary = Just + CondNode { + condTreeData = Library { + libName = LMainLibName, + exposedModules = [ + ModuleName + "Torch.Core.Exceptions", + ModuleName "Torch.Core.Random", + ModuleName "Torch.Core.LogAdd"], + reexportedModules = [ + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Types.Numeric", + moduleReexportName = ModuleName + "Torch.Types.Numeric"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName "Torch.Long", + moduleReexportName = ModuleName + "Torch.Long"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName "Torch.Long.Dynamic", + moduleReexportName = ModuleName + "Torch.Long.Dynamic"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName "Torch.Long.Storage", + moduleReexportName = ModuleName + "Torch.Long.Storage"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName "Torch.Double", + moduleReexportName = ModuleName + "Torch.Double"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Double.Dynamic", + moduleReexportName = ModuleName + "Torch.Double.Dynamic"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Double.Storage", + moduleReexportName = ModuleName + "Torch.Double.Storage"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName "Torch.Double.NN", + moduleReexportName = ModuleName + "Torch.Double.NN"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Double.NN.Activation", + moduleReexportName = ModuleName + "Torch.Double.NN.Activation"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Double.NN.Backprop", + moduleReexportName = ModuleName + "Torch.Double.NN.Backprop"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Double.NN.Conv1d", + moduleReexportName = ModuleName + "Torch.Double.NN.Conv1d"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Double.NN.Conv2d", + moduleReexportName = ModuleName + "Torch.Double.NN.Conv2d"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Double.NN.Criterion", + moduleReexportName = ModuleName + "Torch.Double.NN.Criterion"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Double.NN.Layers", + moduleReexportName = ModuleName + "Torch.Double.NN.Layers"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Double.NN.Linear", + moduleReexportName = ModuleName + "Torch.Double.NN.Linear"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Double.NN.Math", + moduleReexportName = ModuleName + "Torch.Double.NN.Math"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Double.NN.Padding", + moduleReexportName = ModuleName + "Torch.Double.NN.Padding"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Double.NN.Pooling", + moduleReexportName = ModuleName + "Torch.Double.NN.Pooling"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Double.NN.Sampling", + moduleReexportName = ModuleName + "Torch.Double.NN.Sampling"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Double.Dynamic.NN", + moduleReexportName = ModuleName + "Torch.Double.Dynamic.NN"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Double.Dynamic.NN.Activation", + moduleReexportName = ModuleName + "Torch.Double.Dynamic.NN.Activation"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Double.Dynamic.NN.Pooling", + moduleReexportName = ModuleName + "Torch.Double.Dynamic.NN.Pooling"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Double.Dynamic.NN.Criterion", + moduleReexportName = ModuleName + "Torch.Double.Dynamic.NN.Criterion"}], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPublic, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [ + SymbolicPath "utils"], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Just + Haskell2010, + otherLanguages = [], + defaultExtensions = [ + EnableExtension LambdaCase, + EnableExtension DataKinds, + EnableExtension TypeFamilies, + EnableExtension + TypeSynonymInstances, + EnableExtension + ScopedTypeVariables, + EnableExtension + FlexibleContexts, + EnableExtension CPP], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + 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], + 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 = + `CNot (Var (PackageFlag (FlagName "lite")))`, + condBranchIfTrue = CondNode { + condTreeData = Library { + libName = LMainLibName, + exposedModules = [], + reexportedModules = [ + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName "Torch.Byte", + moduleReexportName = ModuleName + "Torch.Byte"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName "Torch.Byte.Dynamic", + moduleReexportName = ModuleName + "Torch.Byte.Dynamic"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName "Torch.Byte.Storage", + moduleReexportName = ModuleName + "Torch.Byte.Storage"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName "Torch.Char", + moduleReexportName = ModuleName + "Torch.Char"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName "Torch.Char.Dynamic", + moduleReexportName = ModuleName + "Torch.Char.Dynamic"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName "Torch.Char.Storage", + moduleReexportName = ModuleName + "Torch.Char.Storage"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName "Torch.Short", + moduleReexportName = ModuleName + "Torch.Short"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Short.Dynamic", + moduleReexportName = ModuleName + "Torch.Short.Dynamic"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Short.Storage", + moduleReexportName = ModuleName + "Torch.Short.Storage"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName "Torch.Int", + moduleReexportName = ModuleName + "Torch.Int"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName "Torch.Int.Dynamic", + moduleReexportName = ModuleName + "Torch.Int.Dynamic"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName "Torch.Int.Storage", + moduleReexportName = ModuleName + "Torch.Int.Storage"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName "Torch.Float", + moduleReexportName = ModuleName + "Torch.Float"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Float.Dynamic", + moduleReexportName = ModuleName + "Torch.Float.Dynamic"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Float.Storage", + moduleReexportName = ModuleName + "Torch.Float.Storage"}], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPublic, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [], + mixins = []}}, + condTreeConstraints = [], + condTreeComponents = []}, + condBranchIfFalse = Nothing}, + CondBranch { + condBranchCondition = + `Var (PackageFlag (FlagName "cuda"))`, + condBranchIfTrue = CondNode { + condTreeData = Library { + libName = LMainLibName, + exposedModules = [], + reexportedModules = [ + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName "Torch.Cuda.Long", + moduleReexportName = ModuleName + "Torch.Cuda.Long"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Cuda.Long.Dynamic", + moduleReexportName = ModuleName + "Torch.Cuda.Long.Dynamic"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Cuda.Long.Storage", + moduleReexportName = ModuleName + "Torch.Cuda.Long.Storage"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName "Torch.Cuda.Double", + moduleReexportName = ModuleName + "Torch.Cuda.Double"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Cuda.Double.Dynamic", + moduleReexportName = ModuleName + "Torch.Cuda.Double.Dynamic"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Cuda.Double.Storage", + moduleReexportName = ModuleName + "Torch.Cuda.Double.Storage"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Cuda.Double.NN", + moduleReexportName = ModuleName + "Torch.Cuda.Double.NN"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Cuda.Double.NN.Activation", + moduleReexportName = ModuleName + "Torch.Cuda.Double.NN.Activation"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Cuda.Double.NN.Backprop", + moduleReexportName = ModuleName + "Torch.Cuda.Double.NN.Backprop"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Cuda.Double.NN.Conv1d", + moduleReexportName = ModuleName + "Torch.Cuda.Double.NN.Conv1d"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Cuda.Double.NN.Conv2d", + moduleReexportName = ModuleName + "Torch.Cuda.Double.NN.Conv2d"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Cuda.Double.NN.Criterion", + moduleReexportName = ModuleName + "Torch.Cuda.Double.NN.Criterion"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Cuda.Double.NN.Layers", + moduleReexportName = ModuleName + "Torch.Cuda.Double.NN.Layers"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Cuda.Double.NN.Linear", + moduleReexportName = ModuleName + "Torch.Cuda.Double.NN.Linear"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Cuda.Double.NN.Math", + moduleReexportName = ModuleName + "Torch.Cuda.Double.NN.Math"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Cuda.Double.NN.Padding", + moduleReexportName = ModuleName + "Torch.Cuda.Double.NN.Padding"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Cuda.Double.NN.Pooling", + moduleReexportName = ModuleName + "Torch.Cuda.Double.NN.Pooling"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Cuda.Double.NN.Sampling", + moduleReexportName = ModuleName + "Torch.Cuda.Double.NN.Sampling"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Cuda.Double.Dynamic.NN", + moduleReexportName = ModuleName + "Torch.Cuda.Double.Dynamic.NN"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Cuda.Double.Dynamic.NN.Activation", + moduleReexportName = ModuleName + "Torch.Cuda.Double.Dynamic.NN.Activation"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Cuda.Double.Dynamic.NN.Pooling", + moduleReexportName = ModuleName + "Torch.Cuda.Double.Dynamic.NN.Pooling"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Cuda.Double.Dynamic.NN.Criterion", + moduleReexportName = ModuleName + "Torch.Cuda.Double.Dynamic.NN.Criterion"}], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPublic, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + Dependency + (PackageName "hasktorch") + (OrLaterVersion (mkVersion [0])) + (NonEmptySet.fromNonEmpty + (NE.fromList + [ + LSubLibName + (UnqualComponentName + "hasktorch-gpu")]))], + mixins = []}}, + condTreeConstraints = [ + Dependency + (PackageName "hasktorch") + (OrLaterVersion (mkVersion [0])) + (NonEmptySet.fromNonEmpty + (NE.fromList + [ + LSubLibName + (UnqualComponentName + "hasktorch-gpu")]))], + condTreeComponents = [ + CondBranch { + condBranchCondition = + `CNot (Var (PackageFlag (FlagName "lite")))`, + condBranchIfTrue = CondNode { + condTreeData = Library { + libName = LMainLibName, + exposedModules = [], + reexportedModules = [ + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName "Torch.Cuda.Byte", + moduleReexportName = ModuleName + "Torch.Cuda.Byte"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Cuda.Byte.Dynamic", + moduleReexportName = ModuleName + "Torch.Cuda.Byte.Dynamic"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Cuda.Byte.Storage", + moduleReexportName = ModuleName + "Torch.Cuda.Byte.Storage"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName "Torch.Cuda.Char", + moduleReexportName = ModuleName + "Torch.Cuda.Char"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Cuda.Char.Dynamic", + moduleReexportName = ModuleName + "Torch.Cuda.Char.Dynamic"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Cuda.Char.Storage", + moduleReexportName = ModuleName + "Torch.Cuda.Char.Storage"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName "Torch.Cuda.Short", + moduleReexportName = ModuleName + "Torch.Cuda.Short"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Cuda.Short.Dynamic", + moduleReexportName = ModuleName + "Torch.Cuda.Short.Dynamic"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Cuda.Short.Storage", + moduleReexportName = ModuleName + "Torch.Cuda.Short.Storage"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName "Torch.Cuda.Int", + moduleReexportName = ModuleName + "Torch.Cuda.Int"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Cuda.Int.Dynamic", + moduleReexportName = ModuleName + "Torch.Cuda.Int.Dynamic"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Cuda.Int.Storage", + moduleReexportName = ModuleName + "Torch.Cuda.Int.Storage"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName "Torch.Cuda.Float", + moduleReexportName = ModuleName + "Torch.Cuda.Float"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Cuda.Float.Dynamic", + moduleReexportName = ModuleName + "Torch.Cuda.Float.Dynamic"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Cuda.Float.Storage", + moduleReexportName = ModuleName + "Torch.Cuda.Float.Storage"}], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPublic, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [], + mixins = []}}, + condTreeConstraints = [], + condTreeComponents = []}, + condBranchIfFalse = Nothing}]}, + condBranchIfFalse = Nothing}]}, + condSubLibraries = + [ + _×_ + (UnqualComponentName + "hasktorch-cpu") + CondNode { + condTreeData = + Library { + libName = LSubLibName + (UnqualComponentName + "hasktorch-cpu"), + exposedModules = [ + ModuleName "Torch.Long", + ModuleName "Torch.Long.Dynamic", + ModuleName "Torch.Long.Storage", + ModuleName "Torch.Double", + ModuleName + "Torch.Double.Dynamic", + ModuleName + "Torch.Double.Storage"], + reexportedModules = [ + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName "Torch.Double.NN", + moduleReexportName = ModuleName + "Torch.Double.NN"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Double.NN.Activation", + moduleReexportName = ModuleName + "Torch.Double.NN.Activation"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Double.NN.Backprop", + moduleReexportName = ModuleName + "Torch.Double.NN.Backprop"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Double.NN.Conv1d", + moduleReexportName = ModuleName + "Torch.Double.NN.Conv1d"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Double.NN.Conv2d", + moduleReexportName = ModuleName + "Torch.Double.NN.Conv2d"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Double.NN.Criterion", + moduleReexportName = ModuleName + "Torch.Double.NN.Criterion"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Double.NN.Layers", + moduleReexportName = ModuleName + "Torch.Double.NN.Layers"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Double.NN.Linear", + moduleReexportName = ModuleName + "Torch.Double.NN.Linear"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Double.NN.Math", + moduleReexportName = ModuleName + "Torch.Double.NN.Math"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Double.NN.Padding", + moduleReexportName = ModuleName + "Torch.Double.NN.Padding"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Double.NN.Pooling", + moduleReexportName = ModuleName + "Torch.Double.NN.Pooling"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Double.NN.Sampling", + moduleReexportName = ModuleName + "Torch.Double.NN.Sampling"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Double.Dynamic.NN", + moduleReexportName = ModuleName + "Torch.Double.Dynamic.NN"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Double.Dynamic.NN.Activation", + moduleReexportName = ModuleName + "Torch.Double.Dynamic.NN.Activation"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Double.Dynamic.NN.Pooling", + moduleReexportName = ModuleName + "Torch.Double.Dynamic.NN.Pooling"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Double.Dynamic.NN.Criterion", + moduleReexportName = ModuleName + "Torch.Double.Dynamic.NN.Criterion"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName "Torch.Float.NN", + moduleReexportName = ModuleName + "Torch.Float.NN"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Float.NN.Activation", + moduleReexportName = ModuleName + "Torch.Float.NN.Activation"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Float.NN.Backprop", + moduleReexportName = ModuleName + "Torch.Float.NN.Backprop"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Float.NN.Conv1d", + moduleReexportName = ModuleName + "Torch.Float.NN.Conv1d"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Float.NN.Conv2d", + moduleReexportName = ModuleName + "Torch.Float.NN.Conv2d"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Float.NN.Criterion", + moduleReexportName = ModuleName + "Torch.Float.NN.Criterion"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Float.NN.Layers", + moduleReexportName = ModuleName + "Torch.Float.NN.Layers"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Float.NN.Linear", + moduleReexportName = ModuleName + "Torch.Float.NN.Linear"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Float.NN.Math", + moduleReexportName = ModuleName + "Torch.Float.NN.Math"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Float.NN.Padding", + moduleReexportName = ModuleName + "Torch.Float.NN.Padding"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Float.NN.Pooling", + moduleReexportName = ModuleName + "Torch.Float.NN.Pooling"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Float.NN.Sampling", + moduleReexportName = ModuleName + "Torch.Float.NN.Sampling"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Float.Dynamic.NN", + moduleReexportName = ModuleName + "Torch.Float.Dynamic.NN"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Float.Dynamic.NN.Activation", + moduleReexportName = ModuleName + "Torch.Float.Dynamic.NN.Activation"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Float.Dynamic.NN.Pooling", + moduleReexportName = ModuleName + "Torch.Float.Dynamic.NN.Pooling"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Float.Dynamic.NN.Criterion", + moduleReexportName = ModuleName + "Torch.Float.Dynamic.NN.Criterion"}], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPrivate, + libBuildInfo = + BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [ + SymbolicPath "utils", + SymbolicPath "src"], + otherModules = [ + ModuleName + "Torch.Core.Exceptions", + ModuleName "Torch.Core.Random", + ModuleName "Torch.Core.LogAdd"], + virtualModules = [], + autogenModules = [], + defaultLanguage = Just + Haskell2010, + otherLanguages = [], + defaultExtensions = [ + EnableExtension LambdaCase, + EnableExtension DataKinds, + EnableExtension TypeFamilies, + EnableExtension + TypeSynonymInstances, + EnableExtension + ScopedTypeVariables, + EnableExtension + FlexibleContexts, + EnableExtension CPP], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + 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")]))], + mixins = + [ + Mixin { + mixinPackageName = PackageName + "hasktorch", + mixinLibraryName = LSubLibName + (UnqualComponentName + "hasktorch-indef-signed"), + mixinIncludeRenaming = + IncludeRenaming { + includeProvidesRn = + ModuleRenaming + [ + _×_ + (ModuleName + "Torch.Indef.Storage") + (ModuleName + "Torch.Indef.Long.Storage"), + _×_ + (ModuleName + "Torch.Indef.Storage.Copy") + (ModuleName + "Torch.Indef.Long.Storage.Copy"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor") + (ModuleName + "Torch.Indef.Long.Tensor"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Copy") + (ModuleName + "Torch.Indef.Long.Tensor.Copy"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Index") + (ModuleName + "Torch.Indef.Long.Tensor.Index"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Masked") + (ModuleName + "Torch.Indef.Long.Tensor.Masked"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math") + (ModuleName + "Torch.Indef.Long.Tensor.Math"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Compare") + (ModuleName + "Torch.Indef.Long.Tensor.Math.Compare"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.CompareT") + (ModuleName + "Torch.Indef.Long.Tensor.Math.CompareT"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Pairwise") + (ModuleName + "Torch.Indef.Long.Tensor.Math.Pairwise"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Pointwise") + (ModuleName + "Torch.Indef.Long.Tensor.Math.Pointwise"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Reduce") + (ModuleName + "Torch.Indef.Long.Tensor.Math.Reduce"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Scan") + (ModuleName + "Torch.Indef.Long.Tensor.Math.Scan"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Mode") + (ModuleName + "Torch.Indef.Long.Tensor.Mode"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.ScatterGather") + (ModuleName + "Torch.Indef.Long.Tensor.ScatterGather"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Sort") + (ModuleName + "Torch.Indef.Long.Tensor.Sort"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.TopK") + (ModuleName + "Torch.Indef.Long.Tensor.TopK"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor") + (ModuleName + "Torch.Indef.Long.Dynamic.Tensor"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Copy") + (ModuleName + "Torch.Indef.Long.Dynamic.Tensor.Copy"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Index") + (ModuleName + "Torch.Indef.Long.Dynamic.Tensor.Index"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Masked") + (ModuleName + "Torch.Indef.Long.Dynamic.Tensor.Masked"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math") + (ModuleName + "Torch.Indef.Long.Dynamic.Tensor.Math"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Compare") + (ModuleName + "Torch.Indef.Long.Dynamic.Tensor.Math.Compare"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.CompareT") + (ModuleName + "Torch.Indef.Long.Dynamic.Tensor.Math.CompareT"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pairwise") + (ModuleName + "Torch.Indef.Long.Dynamic.Tensor.Math.Pairwise"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pointwise") + (ModuleName + "Torch.Indef.Long.Dynamic.Tensor.Math.Pointwise"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Reduce") + (ModuleName + "Torch.Indef.Long.Dynamic.Tensor.Math.Reduce"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Scan") + (ModuleName + "Torch.Indef.Long.Dynamic.Tensor.Math.Scan"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Mode") + (ModuleName + "Torch.Indef.Long.Dynamic.Tensor.Mode"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.ScatterGather") + (ModuleName + "Torch.Indef.Long.Dynamic.Tensor.ScatterGather"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Sort") + (ModuleName + "Torch.Indef.Long.Dynamic.Tensor.Sort"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.TopK") + (ModuleName + "Torch.Indef.Long.Dynamic.Tensor.TopK"), + _×_ + (ModuleName "Torch.Indef.Types") + (ModuleName "Torch.Long.Types"), + _×_ + (ModuleName "Torch.Indef.Index") + (ModuleName "Torch.Long.Index"), + _×_ + (ModuleName "Torch.Indef.Mask") + (ModuleName "Torch.Long.Mask"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Pointwise.Signed") + (ModuleName + "Torch.Indef.Long.Tensor.Math.Pointwise.Signed"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pointwise.Signed") + (ModuleName + "Torch.Indef.Long.Dynamic.Tensor.Math.Pointwise.Signed")], + includeRequiresRn = + ModuleRenaming + [ + _×_ + (ModuleName + "Torch.Sig.Index.Tensor") + (ModuleName + "Torch.FFI.TH.Long.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Index.TensorFree") + (ModuleName + "Torch.FFI.TH.Long.FreeTensor"), + _×_ + (ModuleName + "Torch.Sig.Mask.Tensor") + (ModuleName + "Torch.FFI.TH.Byte.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Mask.TensorFree") + (ModuleName + "Torch.FFI.TH.Byte.FreeTensor"), + _×_ + (ModuleName + "Torch.Sig.Mask.MathReduce") + (ModuleName + "Torch.FFI.TH.Byte.TensorMath"), + _×_ + (ModuleName "Torch.Sig.State") + (ModuleName "Torch.Types.TH"), + _×_ + (ModuleName + "Torch.Sig.Types.Global") + (ModuleName "Torch.Types.TH"), + _×_ + (ModuleName "Torch.Sig.Types") + (ModuleName + "Torch.Types.TH.Long"), + _×_ + (ModuleName "Torch.Sig.Storage") + (ModuleName + "Torch.FFI.TH.Long.Storage"), + _×_ + (ModuleName + "Torch.Sig.Storage.Copy") + (ModuleName + "Torch.FFI.TH.Long.StorageCopy"), + _×_ + (ModuleName + "Torch.Sig.Storage.Memory") + (ModuleName + "Torch.FFI.TH.Long.FreeStorage"), + _×_ + (ModuleName "Torch.Sig.Tensor") + (ModuleName + "Torch.FFI.TH.Long.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Copy") + (ModuleName + "Torch.FFI.TH.Long.TensorCopy"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Memory") + (ModuleName + "Torch.FFI.TH.Long.FreeTensor"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Index") + (ModuleName + "Torch.FFI.TH.Long.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Masked") + (ModuleName + "Torch.FFI.TH.Long.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math") + (ModuleName + "Torch.FFI.TH.Long.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Compare") + (ModuleName + "Torch.FFI.TH.Long.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.CompareT") + (ModuleName + "Torch.FFI.TH.Long.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Pairwise") + (ModuleName + "Torch.FFI.TH.Long.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Pointwise") + (ModuleName + "Torch.FFI.TH.Long.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Reduce") + (ModuleName + "Torch.FFI.TH.Long.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Scan") + (ModuleName + "Torch.FFI.TH.Long.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Mode") + (ModuleName + "Torch.FFI.TH.Long.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.ScatterGather") + (ModuleName + "Torch.FFI.TH.Long.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Sort") + (ModuleName + "Torch.FFI.TH.Long.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.TopK") + (ModuleName + "Torch.FFI.TH.Long.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Pointwise.Signed") + (ModuleName + "Torch.FFI.TH.Long.TensorMath")]}}, + Mixin { + mixinPackageName = PackageName + "hasktorch", + mixinLibraryName = LSubLibName + (UnqualComponentName + "hasktorch-indef-floating"), + mixinIncludeRenaming = + IncludeRenaming { + includeProvidesRn = + ModuleRenaming + [ + _×_ + (ModuleName + "Torch.Indef.Storage") + (ModuleName + "Torch.Indef.Double.Storage"), + _×_ + (ModuleName + "Torch.Indef.Storage.Copy") + (ModuleName + "Torch.Indef.Double.Storage.Copy"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor") + (ModuleName + "Torch.Indef.Double.Tensor"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Copy") + (ModuleName + "Torch.Indef.Double.Tensor.Copy"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Index") + (ModuleName + "Torch.Indef.Double.Tensor.Index"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Masked") + (ModuleName + "Torch.Indef.Double.Tensor.Masked"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math") + (ModuleName + "Torch.Indef.Double.Tensor.Math"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Compare") + (ModuleName + "Torch.Indef.Double.Tensor.Math.Compare"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.CompareT") + (ModuleName + "Torch.Indef.Double.Tensor.Math.CompareT"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Pairwise") + (ModuleName + "Torch.Indef.Double.Tensor.Math.Pairwise"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Pointwise") + (ModuleName + "Torch.Indef.Double.Tensor.Math.Pointwise"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Reduce") + (ModuleName + "Torch.Indef.Double.Tensor.Math.Reduce"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Scan") + (ModuleName + "Torch.Indef.Double.Tensor.Math.Scan"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Mode") + (ModuleName + "Torch.Indef.Double.Tensor.Mode"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.ScatterGather") + (ModuleName + "Torch.Indef.Double.Tensor.ScatterGather"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Sort") + (ModuleName + "Torch.Indef.Double.Tensor.Sort"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.TopK") + (ModuleName + "Torch.Indef.Double.Tensor.TopK"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor") + (ModuleName + "Torch.Indef.Double.Dynamic.Tensor"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Copy") + (ModuleName + "Torch.Indef.Double.Dynamic.Tensor.Copy"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Index") + (ModuleName + "Torch.Indef.Double.Dynamic.Tensor.Index"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Masked") + (ModuleName + "Torch.Indef.Double.Dynamic.Tensor.Masked"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math") + (ModuleName + "Torch.Indef.Double.Dynamic.Tensor.Math"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Compare") + (ModuleName + "Torch.Indef.Double.Dynamic.Tensor.Math.Compare"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.CompareT") + (ModuleName + "Torch.Indef.Double.Dynamic.Tensor.Math.CompareT"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pairwise") + (ModuleName + "Torch.Indef.Double.Dynamic.Tensor.Math.Pairwise"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pointwise") + (ModuleName + "Torch.Indef.Double.Dynamic.Tensor.Math.Pointwise"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Reduce") + (ModuleName + "Torch.Indef.Double.Dynamic.Tensor.Math.Reduce"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Scan") + (ModuleName + "Torch.Indef.Double.Dynamic.Tensor.Math.Scan"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Mode") + (ModuleName + "Torch.Indef.Double.Dynamic.Tensor.Mode"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.ScatterGather") + (ModuleName + "Torch.Indef.Double.Dynamic.Tensor.ScatterGather"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Sort") + (ModuleName + "Torch.Indef.Double.Dynamic.Tensor.Sort"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.TopK") + (ModuleName + "Torch.Indef.Double.Dynamic.Tensor.TopK"), + _×_ + (ModuleName "Torch.Indef.Types") + (ModuleName + "Torch.Double.Types"), + _×_ + (ModuleName "Torch.Indef.Index") + (ModuleName + "Torch.Double.Index"), + _×_ + (ModuleName "Torch.Indef.Mask") + (ModuleName + "Torch.Double.Mask"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Pointwise.Signed") + (ModuleName + "Torch.Indef.Double.Tensor.Math.Pointwise.Signed"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pointwise.Signed") + (ModuleName + "Torch.Indef.Double.Dynamic.Tensor.Math.Pointwise.Signed"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Blas") + (ModuleName + "Torch.Indef.Double.Dynamic.Tensor.Math.Blas"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Lapack") + (ModuleName + "Torch.Indef.Double.Dynamic.Tensor.Math.Lapack"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pointwise.Floating") + (ModuleName + "Torch.Indef.Double.Dynamic.Tensor.Math.Pointwise.Floating"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Reduce.Floating") + (ModuleName + "Torch.Indef.Double.Dynamic.Tensor.Math.Reduce.Floating"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Floating") + (ModuleName + "Torch.Indef.Double.Dynamic.Tensor.Math.Floating"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Blas") + (ModuleName + "Torch.Indef.Double.Tensor.Math.Blas"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Lapack") + (ModuleName + "Torch.Indef.Double.Tensor.Math.Lapack"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Pointwise.Floating") + (ModuleName + "Torch.Indef.Double.Tensor.Math.Pointwise.Floating"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Reduce.Floating") + (ModuleName + "Torch.Indef.Double.Tensor.Math.Reduce.Floating"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Floating") + (ModuleName + "Torch.Indef.Double.Tensor.Math.Floating"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Random.TH") + (ModuleName + "Torch.Indef.Double.Tensor.Random.TH"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Random.TH") + (ModuleName + "Torch.Indef.Double.Tensor.Math.Random.TH"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Random.TH") + (ModuleName + "Torch.Indef.Double.Dynamic.Tensor.Random.TH"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Random.TH") + (ModuleName + "Torch.Indef.Double.Dynamic.Tensor.Math.Random.TH"), + _×_ + (ModuleName + "Torch.Undefined.Tensor.Random.THC") + (ModuleName + "Torch.Undefined.Double.Tensor.Random.THC"), + _×_ + (ModuleName + "Torch.Indef.Storage") + (ModuleName + "Torch.Indef.Double.Storage"), + _×_ + (ModuleName + "Torch.Indef.Storage.Copy") + (ModuleName + "Torch.Indef.Double.Storage.Copy"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor") + (ModuleName + "Torch.Indef.Double.Tensor"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Copy") + (ModuleName + "Torch.Indef.Double.Tensor.Copy"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Index") + (ModuleName + "Torch.Indef.Double.Tensor.Index"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Masked") + (ModuleName + "Torch.Indef.Double.Tensor.Masked"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math") + (ModuleName + "Torch.Indef.Double.Tensor.Math"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Compare") + (ModuleName + "Torch.Indef.Double.Tensor.Math.Compare"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.CompareT") + (ModuleName + "Torch.Indef.Double.Tensor.Math.CompareT"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Pairwise") + (ModuleName + "Torch.Indef.Double.Tensor.Math.Pairwise"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Pointwise") + (ModuleName + "Torch.Indef.Double.Tensor.Math.Pointwise"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Reduce") + (ModuleName + "Torch.Indef.Double.Tensor.Math.Reduce"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Scan") + (ModuleName + "Torch.Indef.Double.Tensor.Math.Scan"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Mode") + (ModuleName + "Torch.Indef.Double.Tensor.Mode"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.ScatterGather") + (ModuleName + "Torch.Indef.Double.Tensor.ScatterGather"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Sort") + (ModuleName + "Torch.Indef.Double.Tensor.Sort"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.TopK") + (ModuleName + "Torch.Indef.Double.Tensor.TopK"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor") + (ModuleName + "Torch.Indef.Double.Dynamic.Tensor"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Copy") + (ModuleName + "Torch.Indef.Double.Dynamic.Tensor.Copy"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Index") + (ModuleName + "Torch.Indef.Double.Dynamic.Tensor.Index"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Masked") + (ModuleName + "Torch.Indef.Double.Dynamic.Tensor.Masked"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math") + (ModuleName + "Torch.Indef.Double.Dynamic.Tensor.Math"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Compare") + (ModuleName + "Torch.Indef.Double.Dynamic.Tensor.Math.Compare"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.CompareT") + (ModuleName + "Torch.Indef.Double.Dynamic.Tensor.Math.CompareT"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pairwise") + (ModuleName + "Torch.Indef.Double.Dynamic.Tensor.Math.Pairwise"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pointwise") + (ModuleName + "Torch.Indef.Double.Dynamic.Tensor.Math.Pointwise"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Reduce") + (ModuleName + "Torch.Indef.Double.Dynamic.Tensor.Math.Reduce"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Scan") + (ModuleName + "Torch.Indef.Double.Dynamic.Tensor.Math.Scan"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Mode") + (ModuleName + "Torch.Indef.Double.Dynamic.Tensor.Mode"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.ScatterGather") + (ModuleName + "Torch.Indef.Double.Dynamic.Tensor.ScatterGather"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Sort") + (ModuleName + "Torch.Indef.Double.Dynamic.Tensor.Sort"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.TopK") + (ModuleName + "Torch.Indef.Double.Dynamic.Tensor.TopK"), + _×_ + (ModuleName "Torch.Indef.Types") + (ModuleName + "Torch.Double.Types"), + _×_ + (ModuleName "Torch.Indef.Index") + (ModuleName + "Torch.Double.Index"), + _×_ + (ModuleName "Torch.Indef.Mask") + (ModuleName + "Torch.Double.Mask"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Pointwise.Signed") + (ModuleName + "Torch.Indef.Double.Tensor.Math.Pointwise.Signed"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pointwise.Signed") + (ModuleName + "Torch.Indef.Double.Dynamic.Tensor.Math.Pointwise.Signed"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.NN") + (ModuleName + "Torch.Double.Dynamic.NN"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.NN.Activation") + (ModuleName + "Torch.Double.Dynamic.NN.Activation"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.NN.Pooling") + (ModuleName + "Torch.Double.Dynamic.NN.Pooling"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.NN.Criterion") + (ModuleName + "Torch.Double.Dynamic.NN.Criterion"), + _×_ + (ModuleName + "Torch.Indef.Static.NN") + (ModuleName "Torch.Double.NN"), + _×_ + (ModuleName + "Torch.Indef.Static.NN") + (ModuleName "Torch.Double.NN"), + _×_ + (ModuleName + "Torch.Indef.Static.NN.Activation") + (ModuleName + "Torch.Double.NN.Activation"), + _×_ + (ModuleName + "Torch.Indef.Static.NN.Backprop") + (ModuleName + "Torch.Double.NN.Backprop"), + _×_ + (ModuleName + "Torch.Indef.Static.NN.Conv1d") + (ModuleName + "Torch.Double.NN.Conv1d"), + _×_ + (ModuleName + "Torch.Indef.Static.NN.Conv2d") + (ModuleName + "Torch.Double.NN.Conv2d"), + _×_ + (ModuleName + "Torch.Indef.Static.NN.Criterion") + (ModuleName + "Torch.Double.NN.Criterion"), + _×_ + (ModuleName + "Torch.Indef.Static.NN.Layers") + (ModuleName + "Torch.Double.NN.Layers"), + _×_ + (ModuleName + "Torch.Indef.Static.NN.Linear") + (ModuleName + "Torch.Double.NN.Linear"), + _×_ + (ModuleName + "Torch.Indef.Static.NN.Math") + (ModuleName + "Torch.Double.NN.Math"), + _×_ + (ModuleName + "Torch.Indef.Static.NN.Padding") + (ModuleName + "Torch.Double.NN.Padding"), + _×_ + (ModuleName + "Torch.Indef.Static.NN.Pooling") + (ModuleName + "Torch.Double.NN.Pooling"), + _×_ + (ModuleName + "Torch.Indef.Static.NN.Sampling") + (ModuleName + "Torch.Double.NN.Sampling")], + includeRequiresRn = + ModuleRenaming + [ + _×_ + (ModuleName + "Torch.Sig.Index.Tensor") + (ModuleName + "Torch.FFI.TH.Long.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Index.TensorFree") + (ModuleName + "Torch.FFI.TH.Long.FreeTensor"), + _×_ + (ModuleName + "Torch.Sig.Mask.Tensor") + (ModuleName + "Torch.FFI.TH.Byte.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Mask.TensorFree") + (ModuleName + "Torch.FFI.TH.Byte.FreeTensor"), + _×_ + (ModuleName + "Torch.Sig.Mask.MathReduce") + (ModuleName + "Torch.FFI.TH.Byte.TensorMath"), + _×_ + (ModuleName "Torch.Sig.State") + (ModuleName "Torch.Types.TH"), + _×_ + (ModuleName + "Torch.Sig.Types.Global") + (ModuleName "Torch.Types.TH"), + _×_ + (ModuleName "Torch.Sig.Types") + (ModuleName + "Torch.Types.TH.Double"), + _×_ + (ModuleName "Torch.Sig.Storage") + (ModuleName + "Torch.FFI.TH.Double.Storage"), + _×_ + (ModuleName + "Torch.Sig.Storage.Copy") + (ModuleName + "Torch.FFI.TH.Double.StorageCopy"), + _×_ + (ModuleName + "Torch.Sig.Storage.Memory") + (ModuleName + "Torch.FFI.TH.Double.FreeStorage"), + _×_ + (ModuleName "Torch.Sig.Tensor") + (ModuleName + "Torch.FFI.TH.Double.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Copy") + (ModuleName + "Torch.FFI.TH.Double.TensorCopy"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Memory") + (ModuleName + "Torch.FFI.TH.Double.FreeTensor"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Index") + (ModuleName + "Torch.FFI.TH.Double.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Masked") + (ModuleName + "Torch.FFI.TH.Double.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math") + (ModuleName + "Torch.FFI.TH.Double.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Compare") + (ModuleName + "Torch.FFI.TH.Double.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.CompareT") + (ModuleName + "Torch.FFI.TH.Double.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Pairwise") + (ModuleName + "Torch.FFI.TH.Double.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Pointwise") + (ModuleName + "Torch.FFI.TH.Double.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Reduce") + (ModuleName + "Torch.FFI.TH.Double.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Scan") + (ModuleName + "Torch.FFI.TH.Double.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Mode") + (ModuleName + "Torch.FFI.TH.Double.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.ScatterGather") + (ModuleName + "Torch.FFI.TH.Double.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Sort") + (ModuleName + "Torch.FFI.TH.Double.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.TopK") + (ModuleName + "Torch.FFI.TH.Double.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Pointwise.Signed") + (ModuleName + "Torch.FFI.TH.Double.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Pointwise.Floating") + (ModuleName + "Torch.FFI.TH.Double.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Reduce.Floating") + (ModuleName + "Torch.FFI.TH.Double.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Floating") + (ModuleName + "Torch.FFI.TH.Double.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Blas") + (ModuleName + "Torch.FFI.TH.Double.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Lapack") + (ModuleName + "Torch.FFI.TH.Double.TensorLapack"), + _×_ + (ModuleName "Torch.Sig.NN") + (ModuleName + "Torch.FFI.TH.NN.Double"), + _×_ + (ModuleName + "Torch.Sig.Types.NN") + (ModuleName "Torch.Types.TH"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Random.TH") + (ModuleName + "Torch.FFI.TH.Double.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Random.TH") + (ModuleName + "Torch.FFI.TH.Double.TensorRandom"), + _×_ + (ModuleName + "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 { + condBranchCondition = + `Var (PackageFlag (FlagName "lite"))`, + condBranchIfTrue = CondNode { + condTreeData = Library { + libName = LSubLibName + (UnqualComponentName + "hasktorch-cpu"), + exposedModules = [], + reexportedModules = [], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPrivate, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [], + mixins = []}}, + condTreeConstraints = [], + condTreeComponents = []}, + condBranchIfFalse = + Just + CondNode { + condTreeData = + Library { + libName = LSubLibName + (UnqualComponentName + "hasktorch-cpu"), + exposedModules = [ + ModuleName "Torch.Byte", + ModuleName "Torch.Byte.Dynamic", + ModuleName "Torch.Byte.Storage", + ModuleName "Torch.Char", + ModuleName "Torch.Char.Dynamic", + ModuleName "Torch.Char.Storage", + ModuleName "Torch.Short", + ModuleName + "Torch.Short.Dynamic", + ModuleName + "Torch.Short.Storage", + ModuleName "Torch.Int", + ModuleName "Torch.Int.Dynamic", + ModuleName "Torch.Int.Storage", + ModuleName "Torch.Float", + ModuleName + "Torch.Float.Dynamic", + ModuleName + "Torch.Float.Storage"], + reexportedModules = [], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPrivate, + libBuildInfo = + BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + Dependency + (PackageName "hasktorch") + (OrLaterVersion (mkVersion [0])) + (NonEmptySet.fromNonEmpty + (NE.fromList + [ + LSubLibName + (UnqualComponentName + "hasktorch-indef-unsigned")]))], + mixins = + [ + Mixin { + mixinPackageName = PackageName + "hasktorch", + mixinLibraryName = LSubLibName + (UnqualComponentName + "hasktorch-indef-unsigned"), + mixinIncludeRenaming = + IncludeRenaming { + includeProvidesRn = + ModuleRenaming + [ + _×_ + (ModuleName + "Torch.Indef.Storage") + (ModuleName + "Torch.Indef.Byte.Storage"), + _×_ + (ModuleName + "Torch.Indef.Storage.Copy") + (ModuleName + "Torch.Indef.Byte.Storage.Copy"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor") + (ModuleName + "Torch.Indef.Byte.Tensor"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Copy") + (ModuleName + "Torch.Indef.Byte.Tensor.Copy"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Index") + (ModuleName + "Torch.Indef.Byte.Tensor.Index"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Masked") + (ModuleName + "Torch.Indef.Byte.Tensor.Masked"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math") + (ModuleName + "Torch.Indef.Byte.Tensor.Math"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Compare") + (ModuleName + "Torch.Indef.Byte.Tensor.Math.Compare"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.CompareT") + (ModuleName + "Torch.Indef.Byte.Tensor.Math.CompareT"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Pairwise") + (ModuleName + "Torch.Indef.Byte.Tensor.Math.Pairwise"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Pointwise") + (ModuleName + "Torch.Indef.Byte.Tensor.Math.Pointwise"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Reduce") + (ModuleName + "Torch.Indef.Byte.Tensor.Math.Reduce"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Scan") + (ModuleName + "Torch.Indef.Byte.Tensor.Math.Scan"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Mode") + (ModuleName + "Torch.Indef.Byte.Tensor.Mode"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.ScatterGather") + (ModuleName + "Torch.Indef.Byte.Tensor.ScatterGather"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Sort") + (ModuleName + "Torch.Indef.Byte.Tensor.Sort"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.TopK") + (ModuleName + "Torch.Indef.Byte.Tensor.TopK"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor") + (ModuleName + "Torch.Indef.Byte.Dynamic.Tensor"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Copy") + (ModuleName + "Torch.Indef.Byte.Dynamic.Tensor.Copy"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Index") + (ModuleName + "Torch.Indef.Byte.Dynamic.Tensor.Index"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Masked") + (ModuleName + "Torch.Indef.Byte.Dynamic.Tensor.Masked"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math") + (ModuleName + "Torch.Indef.Byte.Dynamic.Tensor.Math"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Compare") + (ModuleName + "Torch.Indef.Byte.Dynamic.Tensor.Math.Compare"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.CompareT") + (ModuleName + "Torch.Indef.Byte.Dynamic.Tensor.Math.CompareT"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pairwise") + (ModuleName + "Torch.Indef.Byte.Dynamic.Tensor.Math.Pairwise"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pointwise") + (ModuleName + "Torch.Indef.Byte.Dynamic.Tensor.Math.Pointwise"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Reduce") + (ModuleName + "Torch.Indef.Byte.Dynamic.Tensor.Math.Reduce"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Scan") + (ModuleName + "Torch.Indef.Byte.Dynamic.Tensor.Math.Scan"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Mode") + (ModuleName + "Torch.Indef.Byte.Dynamic.Tensor.Mode"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.ScatterGather") + (ModuleName + "Torch.Indef.Byte.Dynamic.Tensor.ScatterGather"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Sort") + (ModuleName + "Torch.Indef.Byte.Dynamic.Tensor.Sort"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.TopK") + (ModuleName + "Torch.Indef.Byte.Dynamic.Tensor.TopK"), + _×_ + (ModuleName "Torch.Indef.Types") + (ModuleName "Torch.Byte.Types"), + _×_ + (ModuleName "Torch.Indef.Index") + (ModuleName "Torch.Byte.Index"), + _×_ + (ModuleName "Torch.Indef.Mask") + (ModuleName "Torch.Byte.Mask")], + includeRequiresRn = + ModuleRenaming + [ + _×_ + (ModuleName + "Torch.Sig.Index.Tensor") + (ModuleName + "Torch.FFI.TH.Long.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Index.TensorFree") + (ModuleName + "Torch.FFI.TH.Long.FreeTensor"), + _×_ + (ModuleName + "Torch.Sig.Mask.Tensor") + (ModuleName + "Torch.FFI.TH.Byte.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Mask.TensorFree") + (ModuleName + "Torch.FFI.TH.Byte.FreeTensor"), + _×_ + (ModuleName + "Torch.Sig.Mask.MathReduce") + (ModuleName + "Torch.FFI.TH.Byte.TensorMath"), + _×_ + (ModuleName "Torch.Sig.State") + (ModuleName "Torch.Types.TH"), + _×_ + (ModuleName + "Torch.Sig.Types.Global") + (ModuleName "Torch.Types.TH"), + _×_ + (ModuleName "Torch.Sig.Types") + (ModuleName + "Torch.Types.TH.Byte"), + _×_ + (ModuleName "Torch.Sig.Storage") + (ModuleName + "Torch.FFI.TH.Byte.Storage"), + _×_ + (ModuleName + "Torch.Sig.Storage.Copy") + (ModuleName + "Torch.FFI.TH.Byte.StorageCopy"), + _×_ + (ModuleName + "Torch.Sig.Storage.Memory") + (ModuleName + "Torch.FFI.TH.Byte.FreeStorage"), + _×_ + (ModuleName "Torch.Sig.Tensor") + (ModuleName + "Torch.FFI.TH.Byte.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Copy") + (ModuleName + "Torch.FFI.TH.Byte.TensorCopy"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Memory") + (ModuleName + "Torch.FFI.TH.Byte.FreeTensor"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Index") + (ModuleName + "Torch.FFI.TH.Byte.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Masked") + (ModuleName + "Torch.FFI.TH.Byte.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math") + (ModuleName + "Torch.FFI.TH.Byte.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Compare") + (ModuleName + "Torch.FFI.TH.Byte.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.CompareT") + (ModuleName + "Torch.FFI.TH.Byte.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Pairwise") + (ModuleName + "Torch.FFI.TH.Byte.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Pointwise") + (ModuleName + "Torch.FFI.TH.Byte.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Reduce") + (ModuleName + "Torch.FFI.TH.Byte.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Scan") + (ModuleName + "Torch.FFI.TH.Byte.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Mode") + (ModuleName + "Torch.FFI.TH.Byte.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.ScatterGather") + (ModuleName + "Torch.FFI.TH.Byte.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Sort") + (ModuleName + "Torch.FFI.TH.Byte.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.TopK") + (ModuleName + "Torch.FFI.TH.Byte.TensorMath")]}}, + Mixin { + mixinPackageName = PackageName + "hasktorch", + mixinLibraryName = LSubLibName + (UnqualComponentName + "hasktorch-indef-unsigned"), + mixinIncludeRenaming = + IncludeRenaming { + includeProvidesRn = + ModuleRenaming + [ + _×_ + (ModuleName + "Torch.Indef.Storage") + (ModuleName + "Torch.Indef.Char.Storage"), + _×_ + (ModuleName + "Torch.Indef.Storage.Copy") + (ModuleName + "Torch.Indef.Char.Storage.Copy"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor") + (ModuleName + "Torch.Indef.Char.Tensor"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Copy") + (ModuleName + "Torch.Indef.Char.Tensor.Copy"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Index") + (ModuleName + "Torch.Indef.Char.Tensor.Index"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Masked") + (ModuleName + "Torch.Indef.Char.Tensor.Masked"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math") + (ModuleName + "Torch.Indef.Char.Tensor.Math"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Compare") + (ModuleName + "Torch.Indef.Char.Tensor.Math.Compare"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.CompareT") + (ModuleName + "Torch.Indef.Char.Tensor.Math.CompareT"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Pairwise") + (ModuleName + "Torch.Indef.Char.Tensor.Math.Pairwise"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Pointwise") + (ModuleName + "Torch.Indef.Char.Tensor.Math.Pointwise"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Reduce") + (ModuleName + "Torch.Indef.Char.Tensor.Math.Reduce"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Scan") + (ModuleName + "Torch.Indef.Char.Tensor.Math.Scan"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Mode") + (ModuleName + "Torch.Indef.Char.Tensor.Mode"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.ScatterGather") + (ModuleName + "Torch.Indef.Char.Tensor.ScatterGather"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Sort") + (ModuleName + "Torch.Indef.Char.Tensor.Sort"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.TopK") + (ModuleName + "Torch.Indef.Char.Tensor.TopK"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor") + (ModuleName + "Torch.Indef.Char.Dynamic.Tensor"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Copy") + (ModuleName + "Torch.Indef.Char.Dynamic.Tensor.Copy"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Index") + (ModuleName + "Torch.Indef.Char.Dynamic.Tensor.Index"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Masked") + (ModuleName + "Torch.Indef.Char.Dynamic.Tensor.Masked"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math") + (ModuleName + "Torch.Indef.Char.Dynamic.Tensor.Math"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Compare") + (ModuleName + "Torch.Indef.Char.Dynamic.Tensor.Math.Compare"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.CompareT") + (ModuleName + "Torch.Indef.Char.Dynamic.Tensor.Math.CompareT"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pairwise") + (ModuleName + "Torch.Indef.Char.Dynamic.Tensor.Math.Pairwise"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pointwise") + (ModuleName + "Torch.Indef.Char.Dynamic.Tensor.Math.Pointwise"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Reduce") + (ModuleName + "Torch.Indef.Char.Dynamic.Tensor.Math.Reduce"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Scan") + (ModuleName + "Torch.Indef.Char.Dynamic.Tensor.Math.Scan"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Mode") + (ModuleName + "Torch.Indef.Char.Dynamic.Tensor.Mode"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.ScatterGather") + (ModuleName + "Torch.Indef.Char.Dynamic.Tensor.ScatterGather"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Sort") + (ModuleName + "Torch.Indef.Char.Dynamic.Tensor.Sort"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.TopK") + (ModuleName + "Torch.Indef.Char.Dynamic.Tensor.TopK"), + _×_ + (ModuleName "Torch.Indef.Types") + (ModuleName "Torch.Char.Types"), + _×_ + (ModuleName "Torch.Indef.Index") + (ModuleName "Torch.Char.Index"), + _×_ + (ModuleName "Torch.Indef.Mask") + (ModuleName "Torch.Char.Mask")], + includeRequiresRn = + ModuleRenaming + [ + _×_ + (ModuleName + "Torch.Sig.Index.Tensor") + (ModuleName + "Torch.FFI.TH.Long.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Index.TensorFree") + (ModuleName + "Torch.FFI.TH.Long.FreeTensor"), + _×_ + (ModuleName + "Torch.Sig.Mask.Tensor") + (ModuleName + "Torch.FFI.TH.Byte.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Mask.TensorFree") + (ModuleName + "Torch.FFI.TH.Byte.FreeTensor"), + _×_ + (ModuleName + "Torch.Sig.Mask.MathReduce") + (ModuleName + "Torch.FFI.TH.Byte.TensorMath"), + _×_ + (ModuleName "Torch.Sig.State") + (ModuleName "Torch.Types.TH"), + _×_ + (ModuleName + "Torch.Sig.Types.Global") + (ModuleName "Torch.Types.TH"), + _×_ + (ModuleName "Torch.Sig.Types") + (ModuleName + "Torch.Types.TH.Char"), + _×_ + (ModuleName "Torch.Sig.Storage") + (ModuleName + "Torch.FFI.TH.Char.Storage"), + _×_ + (ModuleName + "Torch.Sig.Storage.Copy") + (ModuleName + "Torch.FFI.TH.Char.StorageCopy"), + _×_ + (ModuleName + "Torch.Sig.Storage.Memory") + (ModuleName + "Torch.FFI.TH.Char.FreeStorage"), + _×_ + (ModuleName "Torch.Sig.Tensor") + (ModuleName + "Torch.FFI.TH.Char.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Copy") + (ModuleName + "Torch.FFI.TH.Char.TensorCopy"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Memory") + (ModuleName + "Torch.FFI.TH.Char.FreeTensor"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Index") + (ModuleName + "Torch.FFI.TH.Char.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Masked") + (ModuleName + "Torch.FFI.TH.Char.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math") + (ModuleName + "Torch.FFI.TH.Char.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Compare") + (ModuleName + "Torch.FFI.TH.Char.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.CompareT") + (ModuleName + "Torch.FFI.TH.Char.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Pairwise") + (ModuleName + "Torch.FFI.TH.Char.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Pointwise") + (ModuleName + "Torch.FFI.TH.Char.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Reduce") + (ModuleName + "Torch.FFI.TH.Char.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Scan") + (ModuleName + "Torch.FFI.TH.Char.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Mode") + (ModuleName + "Torch.FFI.TH.Char.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.ScatterGather") + (ModuleName + "Torch.FFI.TH.Char.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Sort") + (ModuleName + "Torch.FFI.TH.Char.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.TopK") + (ModuleName + "Torch.FFI.TH.Char.TensorMath")]}}, + Mixin { + mixinPackageName = PackageName + "hasktorch", + mixinLibraryName = LSubLibName + (UnqualComponentName + "hasktorch-indef-signed"), + mixinIncludeRenaming = + IncludeRenaming { + includeProvidesRn = + ModuleRenaming + [ + _×_ + (ModuleName + "Torch.Indef.Storage") + (ModuleName + "Torch.Indef.Short.Storage"), + _×_ + (ModuleName + "Torch.Indef.Storage.Copy") + (ModuleName + "Torch.Indef.Short.Storage.Copy"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor") + (ModuleName + "Torch.Indef.Short.Tensor"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Copy") + (ModuleName + "Torch.Indef.Short.Tensor.Copy"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Index") + (ModuleName + "Torch.Indef.Short.Tensor.Index"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Masked") + (ModuleName + "Torch.Indef.Short.Tensor.Masked"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math") + (ModuleName + "Torch.Indef.Short.Tensor.Math"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Compare") + (ModuleName + "Torch.Indef.Short.Tensor.Math.Compare"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.CompareT") + (ModuleName + "Torch.Indef.Short.Tensor.Math.CompareT"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Pairwise") + (ModuleName + "Torch.Indef.Short.Tensor.Math.Pairwise"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Pointwise") + (ModuleName + "Torch.Indef.Short.Tensor.Math.Pointwise"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Reduce") + (ModuleName + "Torch.Indef.Short.Tensor.Math.Reduce"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Scan") + (ModuleName + "Torch.Indef.Short.Tensor.Math.Scan"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Mode") + (ModuleName + "Torch.Indef.Short.Tensor.Mode"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.ScatterGather") + (ModuleName + "Torch.Indef.Short.Tensor.ScatterGather"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Sort") + (ModuleName + "Torch.Indef.Short.Tensor.Sort"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.TopK") + (ModuleName + "Torch.Indef.Short.Tensor.TopK"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor") + (ModuleName + "Torch.Indef.Short.Dynamic.Tensor"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Copy") + (ModuleName + "Torch.Indef.Short.Dynamic.Tensor.Copy"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Index") + (ModuleName + "Torch.Indef.Short.Dynamic.Tensor.Index"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Masked") + (ModuleName + "Torch.Indef.Short.Dynamic.Tensor.Masked"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math") + (ModuleName + "Torch.Indef.Short.Dynamic.Tensor.Math"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Compare") + (ModuleName + "Torch.Indef.Short.Dynamic.Tensor.Math.Compare"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.CompareT") + (ModuleName + "Torch.Indef.Short.Dynamic.Tensor.Math.CompareT"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pairwise") + (ModuleName + "Torch.Indef.Short.Dynamic.Tensor.Math.Pairwise"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pointwise") + (ModuleName + "Torch.Indef.Short.Dynamic.Tensor.Math.Pointwise"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Reduce") + (ModuleName + "Torch.Indef.Short.Dynamic.Tensor.Math.Reduce"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Scan") + (ModuleName + "Torch.Indef.Short.Dynamic.Tensor.Math.Scan"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Mode") + (ModuleName + "Torch.Indef.Short.Dynamic.Tensor.Mode"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.ScatterGather") + (ModuleName + "Torch.Indef.Short.Dynamic.Tensor.ScatterGather"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Sort") + (ModuleName + "Torch.Indef.Short.Dynamic.Tensor.Sort"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.TopK") + (ModuleName + "Torch.Indef.Short.Dynamic.Tensor.TopK"), + _×_ + (ModuleName "Torch.Indef.Types") + (ModuleName + "Torch.Short.Types"), + _×_ + (ModuleName "Torch.Indef.Index") + (ModuleName + "Torch.Short.Index"), + _×_ + (ModuleName "Torch.Indef.Mask") + (ModuleName "Torch.Short.Mask"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Pointwise.Signed") + (ModuleName + "Torch.Indef.Short.Tensor.Math.Pointwise.Signed"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pointwise.Signed") + (ModuleName + "Torch.Indef.Short.Dynamic.Tensor.Math.Pointwise.Signed")], + includeRequiresRn = + ModuleRenaming + [ + _×_ + (ModuleName + "Torch.Sig.Index.Tensor") + (ModuleName + "Torch.FFI.TH.Long.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Index.TensorFree") + (ModuleName + "Torch.FFI.TH.Long.FreeTensor"), + _×_ + (ModuleName + "Torch.Sig.Mask.Tensor") + (ModuleName + "Torch.FFI.TH.Byte.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Mask.TensorFree") + (ModuleName + "Torch.FFI.TH.Byte.FreeTensor"), + _×_ + (ModuleName + "Torch.Sig.Mask.MathReduce") + (ModuleName + "Torch.FFI.TH.Byte.TensorMath"), + _×_ + (ModuleName "Torch.Sig.State") + (ModuleName "Torch.Types.TH"), + _×_ + (ModuleName + "Torch.Sig.Types.Global") + (ModuleName "Torch.Types.TH"), + _×_ + (ModuleName "Torch.Sig.Types") + (ModuleName + "Torch.Types.TH.Short"), + _×_ + (ModuleName "Torch.Sig.Storage") + (ModuleName + "Torch.FFI.TH.Short.Storage"), + _×_ + (ModuleName + "Torch.Sig.Storage.Copy") + (ModuleName + "Torch.FFI.TH.Short.StorageCopy"), + _×_ + (ModuleName + "Torch.Sig.Storage.Memory") + (ModuleName + "Torch.FFI.TH.Short.FreeStorage"), + _×_ + (ModuleName "Torch.Sig.Tensor") + (ModuleName + "Torch.FFI.TH.Short.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Copy") + (ModuleName + "Torch.FFI.TH.Short.TensorCopy"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Memory") + (ModuleName + "Torch.FFI.TH.Short.FreeTensor"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Index") + (ModuleName + "Torch.FFI.TH.Short.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Masked") + (ModuleName + "Torch.FFI.TH.Short.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math") + (ModuleName + "Torch.FFI.TH.Short.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Compare") + (ModuleName + "Torch.FFI.TH.Short.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.CompareT") + (ModuleName + "Torch.FFI.TH.Short.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Pairwise") + (ModuleName + "Torch.FFI.TH.Short.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Pointwise") + (ModuleName + "Torch.FFI.TH.Short.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Reduce") + (ModuleName + "Torch.FFI.TH.Short.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Scan") + (ModuleName + "Torch.FFI.TH.Short.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Mode") + (ModuleName + "Torch.FFI.TH.Short.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.ScatterGather") + (ModuleName + "Torch.FFI.TH.Short.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Sort") + (ModuleName + "Torch.FFI.TH.Short.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.TopK") + (ModuleName + "Torch.FFI.TH.Short.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Pointwise.Signed") + (ModuleName + "Torch.FFI.TH.Short.TensorMath")]}}, + Mixin { + mixinPackageName = PackageName + "hasktorch", + mixinLibraryName = LSubLibName + (UnqualComponentName + "hasktorch-indef-signed"), + mixinIncludeRenaming = + IncludeRenaming { + includeProvidesRn = + ModuleRenaming + [ + _×_ + (ModuleName + "Torch.Indef.Storage") + (ModuleName + "Torch.Indef.Int.Storage"), + _×_ + (ModuleName + "Torch.Indef.Storage.Copy") + (ModuleName + "Torch.Indef.Int.Storage.Copy"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor") + (ModuleName + "Torch.Indef.Int.Tensor"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Copy") + (ModuleName + "Torch.Indef.Int.Tensor.Copy"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Index") + (ModuleName + "Torch.Indef.Int.Tensor.Index"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Masked") + (ModuleName + "Torch.Indef.Int.Tensor.Masked"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math") + (ModuleName + "Torch.Indef.Int.Tensor.Math"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Compare") + (ModuleName + "Torch.Indef.Int.Tensor.Math.Compare"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.CompareT") + (ModuleName + "Torch.Indef.Int.Tensor.Math.CompareT"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Pairwise") + (ModuleName + "Torch.Indef.Int.Tensor.Math.Pairwise"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Pointwise") + (ModuleName + "Torch.Indef.Int.Tensor.Math.Pointwise"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Reduce") + (ModuleName + "Torch.Indef.Int.Tensor.Math.Reduce"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Scan") + (ModuleName + "Torch.Indef.Int.Tensor.Math.Scan"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Mode") + (ModuleName + "Torch.Indef.Int.Tensor.Mode"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.ScatterGather") + (ModuleName + "Torch.Indef.Int.Tensor.ScatterGather"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Sort") + (ModuleName + "Torch.Indef.Int.Tensor.Sort"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.TopK") + (ModuleName + "Torch.Indef.Int.Tensor.TopK"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor") + (ModuleName + "Torch.Indef.Int.Dynamic.Tensor"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Copy") + (ModuleName + "Torch.Indef.Int.Dynamic.Tensor.Copy"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Index") + (ModuleName + "Torch.Indef.Int.Dynamic.Tensor.Index"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Masked") + (ModuleName + "Torch.Indef.Int.Dynamic.Tensor.Masked"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math") + (ModuleName + "Torch.Indef.Int.Dynamic.Tensor.Math"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Compare") + (ModuleName + "Torch.Indef.Int.Dynamic.Tensor.Math.Compare"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.CompareT") + (ModuleName + "Torch.Indef.Int.Dynamic.Tensor.Math.CompareT"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pairwise") + (ModuleName + "Torch.Indef.Int.Dynamic.Tensor.Math.Pairwise"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pointwise") + (ModuleName + "Torch.Indef.Int.Dynamic.Tensor.Math.Pointwise"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Reduce") + (ModuleName + "Torch.Indef.Int.Dynamic.Tensor.Math.Reduce"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Scan") + (ModuleName + "Torch.Indef.Int.Dynamic.Tensor.Math.Scan"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Mode") + (ModuleName + "Torch.Indef.Int.Dynamic.Tensor.Mode"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.ScatterGather") + (ModuleName + "Torch.Indef.Int.Dynamic.Tensor.ScatterGather"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Sort") + (ModuleName + "Torch.Indef.Int.Dynamic.Tensor.Sort"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.TopK") + (ModuleName + "Torch.Indef.Int.Dynamic.Tensor.TopK"), + _×_ + (ModuleName "Torch.Indef.Types") + (ModuleName "Torch.Int.Types"), + _×_ + (ModuleName "Torch.Indef.Index") + (ModuleName "Torch.Int.Index"), + _×_ + (ModuleName "Torch.Indef.Mask") + (ModuleName "Torch.Int.Mask"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Pointwise.Signed") + (ModuleName + "Torch.Indef.Int.Tensor.Math.Pointwise.Signed"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pointwise.Signed") + (ModuleName + "Torch.Indef.Int.Dynamic.Tensor.Math.Pointwise.Signed")], + includeRequiresRn = + ModuleRenaming + [ + _×_ + (ModuleName + "Torch.Sig.Index.Tensor") + (ModuleName + "Torch.FFI.TH.Long.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Index.TensorFree") + (ModuleName + "Torch.FFI.TH.Long.FreeTensor"), + _×_ + (ModuleName + "Torch.Sig.Mask.Tensor") + (ModuleName + "Torch.FFI.TH.Byte.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Mask.TensorFree") + (ModuleName + "Torch.FFI.TH.Byte.FreeTensor"), + _×_ + (ModuleName + "Torch.Sig.Mask.MathReduce") + (ModuleName + "Torch.FFI.TH.Byte.TensorMath"), + _×_ + (ModuleName "Torch.Sig.State") + (ModuleName "Torch.Types.TH"), + _×_ + (ModuleName + "Torch.Sig.Types.Global") + (ModuleName "Torch.Types.TH"), + _×_ + (ModuleName "Torch.Sig.Types") + (ModuleName + "Torch.Types.TH.Int"), + _×_ + (ModuleName "Torch.Sig.Storage") + (ModuleName + "Torch.FFI.TH.Int.Storage"), + _×_ + (ModuleName + "Torch.Sig.Storage.Copy") + (ModuleName + "Torch.FFI.TH.Int.StorageCopy"), + _×_ + (ModuleName + "Torch.Sig.Storage.Memory") + (ModuleName + "Torch.FFI.TH.Int.FreeStorage"), + _×_ + (ModuleName "Torch.Sig.Tensor") + (ModuleName + "Torch.FFI.TH.Int.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Copy") + (ModuleName + "Torch.FFI.TH.Int.TensorCopy"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Memory") + (ModuleName + "Torch.FFI.TH.Int.FreeTensor"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Index") + (ModuleName + "Torch.FFI.TH.Int.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Masked") + (ModuleName + "Torch.FFI.TH.Int.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math") + (ModuleName + "Torch.FFI.TH.Int.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Compare") + (ModuleName + "Torch.FFI.TH.Int.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.CompareT") + (ModuleName + "Torch.FFI.TH.Int.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Pairwise") + (ModuleName + "Torch.FFI.TH.Int.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Pointwise") + (ModuleName + "Torch.FFI.TH.Int.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Reduce") + (ModuleName + "Torch.FFI.TH.Int.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Scan") + (ModuleName + "Torch.FFI.TH.Int.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Mode") + (ModuleName + "Torch.FFI.TH.Int.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.ScatterGather") + (ModuleName + "Torch.FFI.TH.Int.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Sort") + (ModuleName + "Torch.FFI.TH.Int.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.TopK") + (ModuleName + "Torch.FFI.TH.Int.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Pointwise.Signed") + (ModuleName + "Torch.FFI.TH.Int.TensorMath")]}}, + Mixin { + mixinPackageName = PackageName + "hasktorch", + mixinLibraryName = LSubLibName + (UnqualComponentName + "hasktorch-indef-floating"), + mixinIncludeRenaming = + IncludeRenaming { + includeProvidesRn = + ModuleRenaming + [ + _×_ + (ModuleName + "Torch.Indef.Storage") + (ModuleName + "Torch.Indef.Float.Storage"), + _×_ + (ModuleName + "Torch.Indef.Storage.Copy") + (ModuleName + "Torch.Indef.Float.Storage.Copy"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor") + (ModuleName + "Torch.Indef.Float.Tensor"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Copy") + (ModuleName + "Torch.Indef.Float.Tensor.Copy"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Index") + (ModuleName + "Torch.Indef.Float.Tensor.Index"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Masked") + (ModuleName + "Torch.Indef.Float.Tensor.Masked"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math") + (ModuleName + "Torch.Indef.Float.Tensor.Math"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Compare") + (ModuleName + "Torch.Indef.Float.Tensor.Math.Compare"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.CompareT") + (ModuleName + "Torch.Indef.Float.Tensor.Math.CompareT"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Pairwise") + (ModuleName + "Torch.Indef.Float.Tensor.Math.Pairwise"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Pointwise") + (ModuleName + "Torch.Indef.Float.Tensor.Math.Pointwise"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Reduce") + (ModuleName + "Torch.Indef.Float.Tensor.Math.Reduce"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Scan") + (ModuleName + "Torch.Indef.Float.Tensor.Math.Scan"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Mode") + (ModuleName + "Torch.Indef.Float.Tensor.Mode"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.ScatterGather") + (ModuleName + "Torch.Indef.Float.Tensor.ScatterGather"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Sort") + (ModuleName + "Torch.Indef.Float.Tensor.Sort"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.TopK") + (ModuleName + "Torch.Indef.Float.Tensor.TopK"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor") + (ModuleName + "Torch.Indef.Float.Dynamic.Tensor"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Copy") + (ModuleName + "Torch.Indef.Float.Dynamic.Tensor.Copy"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Index") + (ModuleName + "Torch.Indef.Float.Dynamic.Tensor.Index"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Masked") + (ModuleName + "Torch.Indef.Float.Dynamic.Tensor.Masked"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math") + (ModuleName + "Torch.Indef.Float.Dynamic.Tensor.Math"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Compare") + (ModuleName + "Torch.Indef.Float.Dynamic.Tensor.Math.Compare"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.CompareT") + (ModuleName + "Torch.Indef.Float.Dynamic.Tensor.Math.CompareT"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pairwise") + (ModuleName + "Torch.Indef.Float.Dynamic.Tensor.Math.Pairwise"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pointwise") + (ModuleName + "Torch.Indef.Float.Dynamic.Tensor.Math.Pointwise"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Reduce") + (ModuleName + "Torch.Indef.Float.Dynamic.Tensor.Math.Reduce"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Scan") + (ModuleName + "Torch.Indef.Float.Dynamic.Tensor.Math.Scan"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Mode") + (ModuleName + "Torch.Indef.Float.Dynamic.Tensor.Mode"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.ScatterGather") + (ModuleName + "Torch.Indef.Float.Dynamic.Tensor.ScatterGather"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Sort") + (ModuleName + "Torch.Indef.Float.Dynamic.Tensor.Sort"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.TopK") + (ModuleName + "Torch.Indef.Float.Dynamic.Tensor.TopK"), + _×_ + (ModuleName "Torch.Indef.Types") + (ModuleName + "Torch.Float.Types"), + _×_ + (ModuleName "Torch.Indef.Index") + (ModuleName + "Torch.Float.Index"), + _×_ + (ModuleName "Torch.Indef.Mask") + (ModuleName "Torch.Float.Mask"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Pointwise.Signed") + (ModuleName + "Torch.Indef.Float.Tensor.Math.Pointwise.Signed"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pointwise.Signed") + (ModuleName + "Torch.Indef.Float.Dynamic.Tensor.Math.Pointwise.Signed"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Blas") + (ModuleName + "Torch.Indef.Float.Dynamic.Tensor.Math.Blas"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Lapack") + (ModuleName + "Torch.Indef.Float.Dynamic.Tensor.Math.Lapack"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pointwise.Floating") + (ModuleName + "Torch.Indef.Float.Dynamic.Tensor.Math.Pointwise.Floating"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Reduce.Floating") + (ModuleName + "Torch.Indef.Float.Dynamic.Tensor.Math.Reduce.Floating"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Floating") + (ModuleName + "Torch.Indef.Float.Dynamic.Tensor.Math.Floating"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Blas") + (ModuleName + "Torch.Indef.Float.Tensor.Math.Blas"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Lapack") + (ModuleName + "Torch.Indef.Float.Tensor.Math.Lapack"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Pointwise.Floating") + (ModuleName + "Torch.Indef.Float.Tensor.Math.Pointwise.Floating"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Reduce.Floating") + (ModuleName + "Torch.Indef.Float.Tensor.Math.Reduce.Floating"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Floating") + (ModuleName + "Torch.Indef.Float.Tensor.Math.Floating"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Random.TH") + (ModuleName + "Torch.Indef.Float.Tensor.Random.TH"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Random.TH") + (ModuleName + "Torch.Indef.Float.Tensor.Math.Random.TH"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Random.TH") + (ModuleName + "Torch.Indef.Float.Dynamic.Tensor.Random.TH"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Random.TH") + (ModuleName + "Torch.Indef.Float.Dynamic.Tensor.Math.Random.TH"), + _×_ + (ModuleName + "Torch.Undefined.Tensor.Random.THC") + (ModuleName + "Torch.Undefined.Float.Tensor.Random.THC"), + _×_ + (ModuleName + "Torch.Indef.Storage") + (ModuleName + "Torch.Indef.Float.Storage"), + _×_ + (ModuleName + "Torch.Indef.Storage.Copy") + (ModuleName + "Torch.Indef.Float.Storage.Copy"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor") + (ModuleName + "Torch.Indef.Float.Tensor"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Copy") + (ModuleName + "Torch.Indef.Float.Tensor.Copy"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Index") + (ModuleName + "Torch.Indef.Float.Tensor.Index"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Masked") + (ModuleName + "Torch.Indef.Float.Tensor.Masked"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math") + (ModuleName + "Torch.Indef.Float.Tensor.Math"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Compare") + (ModuleName + "Torch.Indef.Float.Tensor.Math.Compare"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.CompareT") + (ModuleName + "Torch.Indef.Float.Tensor.Math.CompareT"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Pairwise") + (ModuleName + "Torch.Indef.Float.Tensor.Math.Pairwise"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Pointwise") + (ModuleName + "Torch.Indef.Float.Tensor.Math.Pointwise"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Reduce") + (ModuleName + "Torch.Indef.Float.Tensor.Math.Reduce"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Scan") + (ModuleName + "Torch.Indef.Float.Tensor.Math.Scan"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Mode") + (ModuleName + "Torch.Indef.Float.Tensor.Mode"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.ScatterGather") + (ModuleName + "Torch.Indef.Float.Tensor.ScatterGather"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Sort") + (ModuleName + "Torch.Indef.Float.Tensor.Sort"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.TopK") + (ModuleName + "Torch.Indef.Float.Tensor.TopK"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor") + (ModuleName + "Torch.Indef.Float.Dynamic.Tensor"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Copy") + (ModuleName + "Torch.Indef.Float.Dynamic.Tensor.Copy"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Index") + (ModuleName + "Torch.Indef.Float.Dynamic.Tensor.Index"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Masked") + (ModuleName + "Torch.Indef.Float.Dynamic.Tensor.Masked"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math") + (ModuleName + "Torch.Indef.Float.Dynamic.Tensor.Math"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Compare") + (ModuleName + "Torch.Indef.Float.Dynamic.Tensor.Math.Compare"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.CompareT") + (ModuleName + "Torch.Indef.Float.Dynamic.Tensor.Math.CompareT"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pairwise") + (ModuleName + "Torch.Indef.Float.Dynamic.Tensor.Math.Pairwise"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pointwise") + (ModuleName + "Torch.Indef.Float.Dynamic.Tensor.Math.Pointwise"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Reduce") + (ModuleName + "Torch.Indef.Float.Dynamic.Tensor.Math.Reduce"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Scan") + (ModuleName + "Torch.Indef.Float.Dynamic.Tensor.Math.Scan"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Mode") + (ModuleName + "Torch.Indef.Float.Dynamic.Tensor.Mode"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.ScatterGather") + (ModuleName + "Torch.Indef.Float.Dynamic.Tensor.ScatterGather"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Sort") + (ModuleName + "Torch.Indef.Float.Dynamic.Tensor.Sort"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.TopK") + (ModuleName + "Torch.Indef.Float.Dynamic.Tensor.TopK"), + _×_ + (ModuleName "Torch.Indef.Types") + (ModuleName + "Torch.Float.Types"), + _×_ + (ModuleName "Torch.Indef.Index") + (ModuleName + "Torch.Float.Index"), + _×_ + (ModuleName "Torch.Indef.Mask") + (ModuleName "Torch.Float.Mask"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Pointwise.Signed") + (ModuleName + "Torch.Indef.Float.Tensor.Math.Pointwise.Signed"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pointwise.Signed") + (ModuleName + "Torch.Indef.Float.Dynamic.Tensor.Math.Pointwise.Signed"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.NN") + (ModuleName + "Torch.Float.Dynamic.NN"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.NN.Activation") + (ModuleName + "Torch.Float.Dynamic.NN.Activation"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.NN.Pooling") + (ModuleName + "Torch.Float.Dynamic.NN.Pooling"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.NN.Criterion") + (ModuleName + "Torch.Float.Dynamic.NN.Criterion"), + _×_ + (ModuleName + "Torch.Indef.Static.NN") + (ModuleName "Torch.Float.NN"), + _×_ + (ModuleName + "Torch.Indef.Static.NN") + (ModuleName "Torch.Float.NN"), + _×_ + (ModuleName + "Torch.Indef.Static.NN.Activation") + (ModuleName + "Torch.Float.NN.Activation"), + _×_ + (ModuleName + "Torch.Indef.Static.NN.Backprop") + (ModuleName + "Torch.Float.NN.Backprop"), + _×_ + (ModuleName + "Torch.Indef.Static.NN.Conv1d") + (ModuleName + "Torch.Float.NN.Conv1d"), + _×_ + (ModuleName + "Torch.Indef.Static.NN.Conv2d") + (ModuleName + "Torch.Float.NN.Conv2d"), + _×_ + (ModuleName + "Torch.Indef.Static.NN.Criterion") + (ModuleName + "Torch.Float.NN.Criterion"), + _×_ + (ModuleName + "Torch.Indef.Static.NN.Layers") + (ModuleName + "Torch.Float.NN.Layers"), + _×_ + (ModuleName + "Torch.Indef.Static.NN.Linear") + (ModuleName + "Torch.Float.NN.Linear"), + _×_ + (ModuleName + "Torch.Indef.Static.NN.Math") + (ModuleName + "Torch.Float.NN.Math"), + _×_ + (ModuleName + "Torch.Indef.Static.NN.Padding") + (ModuleName + "Torch.Float.NN.Padding"), + _×_ + (ModuleName + "Torch.Indef.Static.NN.Pooling") + (ModuleName + "Torch.Float.NN.Pooling"), + _×_ + (ModuleName + "Torch.Indef.Static.NN.Sampling") + (ModuleName + "Torch.Float.NN.Sampling")], + includeRequiresRn = + ModuleRenaming + [ + _×_ + (ModuleName + "Torch.Sig.Index.Tensor") + (ModuleName + "Torch.FFI.TH.Long.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Index.TensorFree") + (ModuleName + "Torch.FFI.TH.Long.FreeTensor"), + _×_ + (ModuleName + "Torch.Sig.Mask.Tensor") + (ModuleName + "Torch.FFI.TH.Byte.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Mask.TensorFree") + (ModuleName + "Torch.FFI.TH.Byte.FreeTensor"), + _×_ + (ModuleName + "Torch.Sig.Mask.MathReduce") + (ModuleName + "Torch.FFI.TH.Byte.TensorMath"), + _×_ + (ModuleName "Torch.Sig.State") + (ModuleName "Torch.Types.TH"), + _×_ + (ModuleName + "Torch.Sig.Types.Global") + (ModuleName "Torch.Types.TH"), + _×_ + (ModuleName "Torch.Sig.Types") + (ModuleName + "Torch.Types.TH.Float"), + _×_ + (ModuleName "Torch.Sig.Storage") + (ModuleName + "Torch.FFI.TH.Float.Storage"), + _×_ + (ModuleName + "Torch.Sig.Storage.Copy") + (ModuleName + "Torch.FFI.TH.Float.StorageCopy"), + _×_ + (ModuleName + "Torch.Sig.Storage.Memory") + (ModuleName + "Torch.FFI.TH.Float.FreeStorage"), + _×_ + (ModuleName "Torch.Sig.Tensor") + (ModuleName + "Torch.FFI.TH.Float.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Copy") + (ModuleName + "Torch.FFI.TH.Float.TensorCopy"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Memory") + (ModuleName + "Torch.FFI.TH.Float.FreeTensor"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Index") + (ModuleName + "Torch.FFI.TH.Float.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Masked") + (ModuleName + "Torch.FFI.TH.Float.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math") + (ModuleName + "Torch.FFI.TH.Float.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Compare") + (ModuleName + "Torch.FFI.TH.Float.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.CompareT") + (ModuleName + "Torch.FFI.TH.Float.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Pairwise") + (ModuleName + "Torch.FFI.TH.Float.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Pointwise") + (ModuleName + "Torch.FFI.TH.Float.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Reduce") + (ModuleName + "Torch.FFI.TH.Float.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Scan") + (ModuleName + "Torch.FFI.TH.Float.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Mode") + (ModuleName + "Torch.FFI.TH.Float.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.ScatterGather") + (ModuleName + "Torch.FFI.TH.Float.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Sort") + (ModuleName + "Torch.FFI.TH.Float.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.TopK") + (ModuleName + "Torch.FFI.TH.Float.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Pointwise.Signed") + (ModuleName + "Torch.FFI.TH.Float.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Pointwise.Floating") + (ModuleName + "Torch.FFI.TH.Float.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Reduce.Floating") + (ModuleName + "Torch.FFI.TH.Float.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Floating") + (ModuleName + "Torch.FFI.TH.Float.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Blas") + (ModuleName + "Torch.FFI.TH.Float.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Lapack") + (ModuleName + "Torch.FFI.TH.Float.TensorLapack"), + _×_ + (ModuleName "Torch.Sig.NN") + (ModuleName + "Torch.FFI.TH.NN.Float"), + _×_ + (ModuleName + "Torch.Sig.Types.NN") + (ModuleName "Torch.Types.TH"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Random.TH") + (ModuleName + "Torch.FFI.TH.Float.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Random.TH") + (ModuleName + "Torch.FFI.TH.Float.TensorRandom"), + _×_ + (ModuleName + "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 + "hasktorch-gpu") + CondNode { + condTreeData = + Library { + libName = LSubLibName + (UnqualComponentName + "hasktorch-gpu"), + exposedModules = [ + ModuleName "Torch.Cuda.Long", + ModuleName + "Torch.Cuda.Long.Dynamic", + ModuleName + "Torch.Cuda.Long.Storage", + ModuleName "Torch.Cuda.Double", + ModuleName + "Torch.Cuda.Double.Dynamic", + ModuleName + "Torch.Cuda.Double.Storage"], + reexportedModules = [ + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Cuda.Double.NN", + moduleReexportName = ModuleName + "Torch.Cuda.Double.NN"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Cuda.Double.NN.Activation", + moduleReexportName = ModuleName + "Torch.Cuda.Double.NN.Activation"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Cuda.Double.NN.Backprop", + moduleReexportName = ModuleName + "Torch.Cuda.Double.NN.Backprop"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Cuda.Double.NN.Conv1d", + moduleReexportName = ModuleName + "Torch.Cuda.Double.NN.Conv1d"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Cuda.Double.NN.Conv2d", + moduleReexportName = ModuleName + "Torch.Cuda.Double.NN.Conv2d"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Cuda.Double.NN.Criterion", + moduleReexportName = ModuleName + "Torch.Cuda.Double.NN.Criterion"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Cuda.Double.NN.Layers", + moduleReexportName = ModuleName + "Torch.Cuda.Double.NN.Layers"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Cuda.Double.NN.Linear", + moduleReexportName = ModuleName + "Torch.Cuda.Double.NN.Linear"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Cuda.Double.NN.Math", + moduleReexportName = ModuleName + "Torch.Cuda.Double.NN.Math"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Cuda.Double.NN.Padding", + moduleReexportName = ModuleName + "Torch.Cuda.Double.NN.Padding"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Cuda.Double.NN.Pooling", + moduleReexportName = ModuleName + "Torch.Cuda.Double.NN.Pooling"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Cuda.Double.NN.Sampling", + moduleReexportName = ModuleName + "Torch.Cuda.Double.NN.Sampling"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Cuda.Double.Dynamic.NN", + moduleReexportName = ModuleName + "Torch.Cuda.Double.Dynamic.NN"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Cuda.Double.Dynamic.NN.Activation", + moduleReexportName = ModuleName + "Torch.Cuda.Double.Dynamic.NN.Activation"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Cuda.Double.Dynamic.NN.Pooling", + moduleReexportName = ModuleName + "Torch.Cuda.Double.Dynamic.NN.Pooling"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Cuda.Double.Dynamic.NN.Criterion", + moduleReexportName = ModuleName + "Torch.Cuda.Double.Dynamic.NN.Criterion"}], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPrivate, + libBuildInfo = + BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [ + "-DCUDA", + "-DHASKTORCH_INTERNAL_CUDA"], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [ + SymbolicPath "utils", + SymbolicPath "src"], + otherModules = [ + ModuleName + "Torch.Core.Exceptions", + ModuleName "Torch.Core.Random", + ModuleName "Torch.Core.LogAdd"], + virtualModules = [], + autogenModules = [], + defaultLanguage = Just + Haskell2010, + otherLanguages = [], + defaultExtensions = [ + EnableExtension LambdaCase, + EnableExtension DataKinds, + EnableExtension TypeFamilies, + EnableExtension + TypeSynonymInstances, + EnableExtension + ScopedTypeVariables, + EnableExtension + FlexibleContexts, + EnableExtension CPP], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + 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], + mixins = + [ + Mixin { + mixinPackageName = PackageName + "hasktorch", + mixinLibraryName = LSubLibName + (UnqualComponentName + "hasktorch-indef-signed"), + mixinIncludeRenaming = + IncludeRenaming { + includeProvidesRn = + ModuleRenaming + [ + _×_ + (ModuleName + "Torch.Indef.Storage") + (ModuleName + "Torch.Indef.Cuda.Long.Storage"), + _×_ + (ModuleName + "Torch.Indef.Storage.Copy") + (ModuleName + "Torch.Indef.Cuda.Long.Storage.Copy"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor") + (ModuleName + "Torch.Indef.Cuda.Long.Tensor"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Copy") + (ModuleName + "Torch.Indef.Cuda.Long.Tensor.Copy"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Index") + (ModuleName + "Torch.Indef.Cuda.Long.Tensor.Index"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Masked") + (ModuleName + "Torch.Indef.Cuda.Long.Tensor.Masked"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math") + (ModuleName + "Torch.Indef.Cuda.Long.Tensor.Math"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Compare") + (ModuleName + "Torch.Indef.Cuda.Long.Tensor.Math.Compare"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.CompareT") + (ModuleName + "Torch.Indef.Cuda.Long.Tensor.Math.CompareT"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Pairwise") + (ModuleName + "Torch.Indef.Cuda.Long.Tensor.Math.Pairwise"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Pointwise") + (ModuleName + "Torch.Indef.Cuda.Long.Tensor.Math.Pointwise"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Reduce") + (ModuleName + "Torch.Indef.Cuda.Long.Tensor.Math.Reduce"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Scan") + (ModuleName + "Torch.Indef.Cuda.Long.Tensor.Math.Scan"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Mode") + (ModuleName + "Torch.Indef.Cuda.Long.Tensor.Mode"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.ScatterGather") + (ModuleName + "Torch.Indef.Cuda.Long.Tensor.ScatterGather"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Sort") + (ModuleName + "Torch.Indef.Cuda.Long.Tensor.Sort"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.TopK") + (ModuleName + "Torch.Indef.Cuda.Long.Tensor.TopK"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor") + (ModuleName + "Torch.Indef.Cuda.Long.Dynamic.Tensor"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Copy") + (ModuleName + "Torch.Indef.Cuda.Long.Dynamic.Tensor.Copy"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Index") + (ModuleName + "Torch.Indef.Cuda.Long.Dynamic.Tensor.Index"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Masked") + (ModuleName + "Torch.Indef.Cuda.Long.Dynamic.Tensor.Masked"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math") + (ModuleName + "Torch.Indef.Cuda.Long.Dynamic.Tensor.Math"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Compare") + (ModuleName + "Torch.Indef.Cuda.Long.Dynamic.Tensor.Math.Compare"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.CompareT") + (ModuleName + "Torch.Indef.Cuda.Long.Dynamic.Tensor.Math.CompareT"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pairwise") + (ModuleName + "Torch.Indef.Cuda.Long.Dynamic.Tensor.Math.Pairwise"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pointwise") + (ModuleName + "Torch.Indef.Cuda.Long.Dynamic.Tensor.Math.Pointwise"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Reduce") + (ModuleName + "Torch.Indef.Cuda.Long.Dynamic.Tensor.Math.Reduce"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Scan") + (ModuleName + "Torch.Indef.Cuda.Long.Dynamic.Tensor.Math.Scan"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Mode") + (ModuleName + "Torch.Indef.Cuda.Long.Dynamic.Tensor.Mode"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.ScatterGather") + (ModuleName + "Torch.Indef.Cuda.Long.Dynamic.Tensor.ScatterGather"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Sort") + (ModuleName + "Torch.Indef.Cuda.Long.Dynamic.Tensor.Sort"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.TopK") + (ModuleName + "Torch.Indef.Cuda.Long.Dynamic.Tensor.TopK"), + _×_ + (ModuleName "Torch.Indef.Types") + (ModuleName + "Torch.Cuda.Long.Types"), + _×_ + (ModuleName "Torch.Indef.Index") + (ModuleName + "Torch.Cuda.Long.Index"), + _×_ + (ModuleName "Torch.Indef.Mask") + (ModuleName + "Torch.Cuda.Long.Mask"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Pointwise.Signed") + (ModuleName + "Torch.Indef.Cuda.Long.Tensor.Math.Pointwise.Signed"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pointwise.Signed") + (ModuleName + "Torch.Indef.Cuda.Long.Dynamic.Tensor.Math.Pointwise.Signed")], + includeRequiresRn = + ModuleRenaming + [ + _×_ + (ModuleName + "Torch.Sig.Index.Tensor") + (ModuleName + "Torch.FFI.THC.Long.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Index.TensorFree") + (ModuleName + "Torch.FFI.THC.Long.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Mask.Tensor") + (ModuleName + "Torch.FFI.THC.Byte.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Mask.TensorFree") + (ModuleName + "Torch.FFI.THC.Byte.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Mask.MathReduce") + (ModuleName + "Torch.FFI.THC.Byte.TensorMathReduce"), + _×_ + (ModuleName "Torch.Sig.State") + (ModuleName + "Torch.FFI.THC.State"), + _×_ + (ModuleName + "Torch.Sig.Types.Global") + (ModuleName "Torch.Types.THC"), + _×_ + (ModuleName "Torch.Sig.Types") + (ModuleName + "Torch.Types.THC.Long"), + _×_ + (ModuleName "Torch.Sig.Storage") + (ModuleName + "Torch.FFI.THC.Long.Storage"), + _×_ + (ModuleName + "Torch.Sig.Storage.Copy") + (ModuleName + "Torch.FFI.THC.Long.StorageCopy"), + _×_ + (ModuleName + "Torch.Sig.Storage.Memory") + (ModuleName + "Torch.FFI.THC.Long.Storage"), + _×_ + (ModuleName "Torch.Sig.Tensor") + (ModuleName + "Torch.FFI.THC.Long.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Copy") + (ModuleName + "Torch.FFI.THC.Long.TensorCopy"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Memory") + (ModuleName + "Torch.FFI.THC.Long.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Index") + (ModuleName + "Torch.FFI.THC.Long.TensorIndex"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Masked") + (ModuleName + "Torch.FFI.THC.Long.TensorMasked"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math") + (ModuleName + "Torch.FFI.THC.Long.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Compare") + (ModuleName + "Torch.FFI.THC.Long.TensorMathCompare"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.CompareT") + (ModuleName + "Torch.FFI.THC.Long.TensorMathCompareT"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Pairwise") + (ModuleName + "Torch.FFI.THC.Long.TensorMathPairwise"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Pointwise") + (ModuleName + "Torch.FFI.THC.Long.TensorMathPointwise"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Reduce") + (ModuleName + "Torch.FFI.THC.Long.TensorMathReduce"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Scan") + (ModuleName + "Torch.FFI.THC.Long.TensorMathScan"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Mode") + (ModuleName + "Torch.FFI.THC.Long.TensorMode"), + _×_ + (ModuleName + "Torch.Sig.Tensor.ScatterGather") + (ModuleName + "Torch.FFI.THC.Long.TensorScatterGather"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Sort") + (ModuleName + "Torch.FFI.THC.Long.TensorSort"), + _×_ + (ModuleName + "Torch.Sig.Tensor.TopK") + (ModuleName + "Torch.FFI.THC.Long.TensorTopK"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Pointwise.Signed") + (ModuleName + "Torch.FFI.THC.Long.TensorMathPointwise")]}}, + Mixin { + mixinPackageName = PackageName + "hasktorch", + mixinLibraryName = LSubLibName + (UnqualComponentName + "hasktorch-indef-floating"), + mixinIncludeRenaming = + IncludeRenaming { + includeProvidesRn = + ModuleRenaming + [ + _×_ + (ModuleName + "Torch.Indef.Storage") + (ModuleName + "Torch.Indef.Cuda.Double.Storage"), + _×_ + (ModuleName + "Torch.Indef.Storage.Copy") + (ModuleName + "Torch.Indef.Cuda.Double.Storage.Copy"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor") + (ModuleName + "Torch.Indef.Cuda.Double.Tensor"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Copy") + (ModuleName + "Torch.Indef.Cuda.Double.Tensor.Copy"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Index") + (ModuleName + "Torch.Indef.Cuda.Double.Tensor.Index"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Masked") + (ModuleName + "Torch.Indef.Cuda.Double.Tensor.Masked"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math") + (ModuleName + "Torch.Indef.Cuda.Double.Tensor.Math"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Compare") + (ModuleName + "Torch.Indef.Cuda.Double.Tensor.Math.Compare"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.CompareT") + (ModuleName + "Torch.Indef.Cuda.Double.Tensor.Math.CompareT"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Pairwise") + (ModuleName + "Torch.Indef.Cuda.Double.Tensor.Math.Pairwise"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Pointwise") + (ModuleName + "Torch.Indef.Cuda.Double.Tensor.Math.Pointwise"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Reduce") + (ModuleName + "Torch.Indef.Cuda.Double.Tensor.Math.Reduce"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Scan") + (ModuleName + "Torch.Indef.Cuda.Double.Tensor.Math.Scan"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Mode") + (ModuleName + "Torch.Indef.Cuda.Double.Tensor.Mode"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.ScatterGather") + (ModuleName + "Torch.Indef.Cuda.Double.Tensor.ScatterGather"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Sort") + (ModuleName + "Torch.Indef.Cuda.Double.Tensor.Sort"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.TopK") + (ModuleName + "Torch.Indef.Cuda.Double.Tensor.TopK"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor") + (ModuleName + "Torch.Indef.Cuda.Double.Dynamic.Tensor"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Copy") + (ModuleName + "Torch.Indef.Cuda.Double.Dynamic.Tensor.Copy"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Index") + (ModuleName + "Torch.Indef.Cuda.Double.Dynamic.Tensor.Index"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Masked") + (ModuleName + "Torch.Indef.Cuda.Double.Dynamic.Tensor.Masked"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math") + (ModuleName + "Torch.Indef.Cuda.Double.Dynamic.Tensor.Math"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Compare") + (ModuleName + "Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.Compare"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.CompareT") + (ModuleName + "Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.CompareT"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pairwise") + (ModuleName + "Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.Pairwise"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pointwise") + (ModuleName + "Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.Pointwise"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Reduce") + (ModuleName + "Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.Reduce"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Scan") + (ModuleName + "Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.Scan"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Mode") + (ModuleName + "Torch.Indef.Cuda.Double.Dynamic.Tensor.Mode"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.ScatterGather") + (ModuleName + "Torch.Indef.Cuda.Double.Dynamic.Tensor.ScatterGather"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Sort") + (ModuleName + "Torch.Indef.Cuda.Double.Dynamic.Tensor.Sort"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.TopK") + (ModuleName + "Torch.Indef.Cuda.Double.Dynamic.Tensor.TopK"), + _×_ + (ModuleName "Torch.Indef.Types") + (ModuleName + "Torch.Cuda.Double.Types"), + _×_ + (ModuleName "Torch.Indef.Index") + (ModuleName + "Torch.Cuda.Double.Index"), + _×_ + (ModuleName "Torch.Indef.Mask") + (ModuleName + "Torch.Cuda.Double.Mask"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Pointwise.Signed") + (ModuleName + "Torch.Indef.Cuda.Double.Tensor.Math.Pointwise.Signed"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pointwise.Signed") + (ModuleName + "Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.Pointwise.Signed"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Blas") + (ModuleName + "Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.Blas"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Lapack") + (ModuleName + "Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.Lapack"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pointwise.Floating") + (ModuleName + "Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.Pointwise.Floating"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Reduce.Floating") + (ModuleName + "Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.Reduce.Floating"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Floating") + (ModuleName + "Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.Floating"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Blas") + (ModuleName + "Torch.Indef.Cuda.Double.Tensor.Math.Blas"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Lapack") + (ModuleName + "Torch.Indef.Cuda.Double.Tensor.Math.Lapack"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Pointwise.Floating") + (ModuleName + "Torch.Indef.Cuda.Double.Tensor.Math.Pointwise.Floating"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Reduce.Floating") + (ModuleName + "Torch.Indef.Cuda.Double.Tensor.Math.Reduce.Floating"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Floating") + (ModuleName + "Torch.Indef.Cuda.Double.Tensor.Math.Floating"), + _×_ + (ModuleName + "Torch.Undefined.Tensor.Random.TH") + (ModuleName + "Torch.Undefined.Cuda.Double.Tensor.Random.TH"), + _×_ + (ModuleName + "Torch.Undefined.Tensor.Math.Random.TH") + (ModuleName + "Torch.Undefined.Cuda.Double.Tensor.Math.Random.TH"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Random.THC") + (ModuleName + "Torch.Indef.Cuda.Double.Tensor.Random.THC"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Random.THC") + (ModuleName + "Torch.Indef.Cuda.Double.Dynamic.Tensor.Random.THC"), + _×_ + (ModuleName + "Torch.Indef.Storage") + (ModuleName + "Torch.Indef.Cuda.Double.Storage"), + _×_ + (ModuleName + "Torch.Indef.Storage.Copy") + (ModuleName + "Torch.Indef.Cuda.Double.Storage.Copy"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor") + (ModuleName + "Torch.Indef.Cuda.Double.Tensor"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Copy") + (ModuleName + "Torch.Indef.Cuda.Double.Tensor.Copy"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Index") + (ModuleName + "Torch.Indef.Cuda.Double.Tensor.Index"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Masked") + (ModuleName + "Torch.Indef.Cuda.Double.Tensor.Masked"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math") + (ModuleName + "Torch.Indef.Cuda.Double.Tensor.Math"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Compare") + (ModuleName + "Torch.Indef.Cuda.Double.Tensor.Math.Compare"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.CompareT") + (ModuleName + "Torch.Indef.Cuda.Double.Tensor.Math.CompareT"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Pairwise") + (ModuleName + "Torch.Indef.Cuda.Double.Tensor.Math.Pairwise"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Pointwise") + (ModuleName + "Torch.Indef.Cuda.Double.Tensor.Math.Pointwise"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Reduce") + (ModuleName + "Torch.Indef.Cuda.Double.Tensor.Math.Reduce"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Scan") + (ModuleName + "Torch.Indef.Cuda.Double.Tensor.Math.Scan"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Mode") + (ModuleName + "Torch.Indef.Cuda.Double.Tensor.Mode"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.ScatterGather") + (ModuleName + "Torch.Indef.Cuda.Double.Tensor.ScatterGather"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Sort") + (ModuleName + "Torch.Indef.Cuda.Double.Tensor.Sort"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.TopK") + (ModuleName + "Torch.Indef.Cuda.Double.Tensor.TopK"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor") + (ModuleName + "Torch.Indef.Cuda.Double.Dynamic.Tensor"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Copy") + (ModuleName + "Torch.Indef.Cuda.Double.Dynamic.Tensor.Copy"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Index") + (ModuleName + "Torch.Indef.Cuda.Double.Dynamic.Tensor.Index"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Masked") + (ModuleName + "Torch.Indef.Cuda.Double.Dynamic.Tensor.Masked"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math") + (ModuleName + "Torch.Indef.Cuda.Double.Dynamic.Tensor.Math"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Compare") + (ModuleName + "Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.Compare"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.CompareT") + (ModuleName + "Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.CompareT"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pairwise") + (ModuleName + "Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.Pairwise"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pointwise") + (ModuleName + "Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.Pointwise"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Reduce") + (ModuleName + "Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.Reduce"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Scan") + (ModuleName + "Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.Scan"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Mode") + (ModuleName + "Torch.Indef.Cuda.Double.Dynamic.Tensor.Mode"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.ScatterGather") + (ModuleName + "Torch.Indef.Cuda.Double.Dynamic.Tensor.ScatterGather"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Sort") + (ModuleName + "Torch.Indef.Cuda.Double.Dynamic.Tensor.Sort"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.TopK") + (ModuleName + "Torch.Indef.Cuda.Double.Dynamic.Tensor.TopK"), + _×_ + (ModuleName "Torch.Indef.Types") + (ModuleName + "Torch.Cuda.Double.Types"), + _×_ + (ModuleName "Torch.Indef.Index") + (ModuleName + "Torch.Cuda.Double.Index"), + _×_ + (ModuleName "Torch.Indef.Mask") + (ModuleName + "Torch.Cuda.Double.Mask"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Pointwise.Signed") + (ModuleName + "Torch.Indef.Cuda.Double.Tensor.Math.Pointwise.Signed"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pointwise.Signed") + (ModuleName + "Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.Pointwise.Signed"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.NN") + (ModuleName + "Torch.Cuda.Double.Dynamic.NN"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.NN.Activation") + (ModuleName + "Torch.Cuda.Double.Dynamic.NN.Activation"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.NN.Pooling") + (ModuleName + "Torch.Cuda.Double.Dynamic.NN.Pooling"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.NN.Criterion") + (ModuleName + "Torch.Cuda.Double.Dynamic.NN.Criterion"), + _×_ + (ModuleName + "Torch.Indef.Static.NN") + (ModuleName + "Torch.Cuda.Double.NN"), + _×_ + (ModuleName + "Torch.Indef.Static.NN") + (ModuleName + "Torch.Cuda.Double.NN"), + _×_ + (ModuleName + "Torch.Indef.Static.NN.Activation") + (ModuleName + "Torch.Cuda.Double.NN.Activation"), + _×_ + (ModuleName + "Torch.Indef.Static.NN.Backprop") + (ModuleName + "Torch.Cuda.Double.NN.Backprop"), + _×_ + (ModuleName + "Torch.Indef.Static.NN.Conv1d") + (ModuleName + "Torch.Cuda.Double.NN.Conv1d"), + _×_ + (ModuleName + "Torch.Indef.Static.NN.Conv2d") + (ModuleName + "Torch.Cuda.Double.NN.Conv2d"), + _×_ + (ModuleName + "Torch.Indef.Static.NN.Criterion") + (ModuleName + "Torch.Cuda.Double.NN.Criterion"), + _×_ + (ModuleName + "Torch.Indef.Static.NN.Layers") + (ModuleName + "Torch.Cuda.Double.NN.Layers"), + _×_ + (ModuleName + "Torch.Indef.Static.NN.Linear") + (ModuleName + "Torch.Cuda.Double.NN.Linear"), + _×_ + (ModuleName + "Torch.Indef.Static.NN.Math") + (ModuleName + "Torch.Cuda.Double.NN.Math"), + _×_ + (ModuleName + "Torch.Indef.Static.NN.Padding") + (ModuleName + "Torch.Cuda.Double.NN.Padding"), + _×_ + (ModuleName + "Torch.Indef.Static.NN.Pooling") + (ModuleName + "Torch.Cuda.Double.NN.Pooling"), + _×_ + (ModuleName + "Torch.Indef.Static.NN.Sampling") + (ModuleName + "Torch.Cuda.Double.NN.Sampling")], + includeRequiresRn = + ModuleRenaming + [ + _×_ + (ModuleName + "Torch.Sig.Index.Tensor") + (ModuleName + "Torch.FFI.THC.Long.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Index.TensorFree") + (ModuleName + "Torch.FFI.THC.Long.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Mask.Tensor") + (ModuleName + "Torch.FFI.THC.Byte.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Mask.TensorFree") + (ModuleName + "Torch.FFI.THC.Byte.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Mask.MathReduce") + (ModuleName + "Torch.FFI.THC.Byte.TensorMathReduce"), + _×_ + (ModuleName "Torch.Sig.State") + (ModuleName + "Torch.FFI.THC.State"), + _×_ + (ModuleName + "Torch.Sig.Types.Global") + (ModuleName "Torch.Types.THC"), + _×_ + (ModuleName "Torch.Sig.Types") + (ModuleName + "Torch.Types.THC.Double"), + _×_ + (ModuleName "Torch.Sig.Storage") + (ModuleName + "Torch.FFI.THC.Double.Storage"), + _×_ + (ModuleName + "Torch.Sig.Storage.Copy") + (ModuleName + "Torch.FFI.THC.Double.StorageCopy"), + _×_ + (ModuleName + "Torch.Sig.Storage.Memory") + (ModuleName + "Torch.FFI.THC.Double.Storage"), + _×_ + (ModuleName "Torch.Sig.Tensor") + (ModuleName + "Torch.FFI.THC.Double.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Copy") + (ModuleName + "Torch.FFI.THC.Double.TensorCopy"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Memory") + (ModuleName + "Torch.FFI.THC.Double.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Index") + (ModuleName + "Torch.FFI.THC.Double.TensorIndex"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Masked") + (ModuleName + "Torch.FFI.THC.Double.TensorMasked"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math") + (ModuleName + "Torch.FFI.THC.Double.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Compare") + (ModuleName + "Torch.FFI.THC.Double.TensorMathCompare"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.CompareT") + (ModuleName + "Torch.FFI.THC.Double.TensorMathCompareT"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Pairwise") + (ModuleName + "Torch.FFI.THC.Double.TensorMathPairwise"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Pointwise") + (ModuleName + "Torch.FFI.THC.Double.TensorMathPointwise"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Reduce") + (ModuleName + "Torch.FFI.THC.Double.TensorMathReduce"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Scan") + (ModuleName + "Torch.FFI.THC.Double.TensorMathScan"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Mode") + (ModuleName + "Torch.FFI.THC.Double.TensorMode"), + _×_ + (ModuleName + "Torch.Sig.Tensor.ScatterGather") + (ModuleName + "Torch.FFI.THC.Double.TensorScatterGather"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Sort") + (ModuleName + "Torch.FFI.THC.Double.TensorSort"), + _×_ + (ModuleName + "Torch.Sig.Tensor.TopK") + (ModuleName + "Torch.FFI.THC.Double.TensorTopK"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Pointwise.Signed") + (ModuleName + "Torch.FFI.THC.Double.TensorMathPointwise"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Pointwise.Floating") + (ModuleName + "Torch.FFI.THC.Double.TensorMathPointwise"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Reduce.Floating") + (ModuleName + "Torch.FFI.THC.Double.TensorMathReduce"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Floating") + (ModuleName + "Torch.FFI.THC.Double.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Blas") + (ModuleName + "Torch.FFI.THC.Double.TensorMathBlas"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Lapack") + (ModuleName + "Torch.FFI.THC.Double.TensorMathMagma"), + _×_ + (ModuleName "Torch.Sig.NN") + (ModuleName + "Torch.FFI.THC.NN.Double"), + _×_ + (ModuleName + "Torch.Sig.Types.NN") + (ModuleName "Torch.Types.THC"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Random.TH") + (ModuleName + "Torch.Undefined.Cuda.Double.Tensor.Math.Random.TH"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Random.TH") + (ModuleName + "Torch.Undefined.Cuda.Double.Tensor.Random.TH"), + _×_ + (ModuleName + "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 { + condBranchCondition = + `Var (PackageFlag (FlagName "lite"))`, + condBranchIfTrue = CondNode { + condTreeData = Library { + libName = LSubLibName + (UnqualComponentName + "hasktorch-gpu"), + exposedModules = [], + reexportedModules = [], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPrivate, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [], + mixins = []}}, + condTreeConstraints = [], + condTreeComponents = []}, + condBranchIfFalse = + Just + CondNode { + condTreeData = + Library { + libName = LSubLibName + (UnqualComponentName + "hasktorch-gpu"), + exposedModules = [ + ModuleName "Torch.Cuda.Byte", + ModuleName + "Torch.Cuda.Byte.Dynamic", + ModuleName + "Torch.Cuda.Byte.Storage", + ModuleName "Torch.Cuda.Char", + ModuleName + "Torch.Cuda.Char.Dynamic", + ModuleName + "Torch.Cuda.Char.Storage", + ModuleName "Torch.Cuda.Short", + ModuleName + "Torch.Cuda.Short.Dynamic", + ModuleName + "Torch.Cuda.Short.Storage", + ModuleName "Torch.Cuda.Int", + ModuleName + "Torch.Cuda.Int.Dynamic", + ModuleName + "Torch.Cuda.Int.Storage"], + reexportedModules = [], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPrivate, + libBuildInfo = + BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + Dependency + (PackageName "hasktorch") + (OrLaterVersion (mkVersion [0])) + (NonEmptySet.fromNonEmpty + (NE.fromList + [ + LSubLibName + (UnqualComponentName + "hasktorch-indef-unsigned")]))], + mixins = + [ + Mixin { + mixinPackageName = PackageName + "hasktorch", + mixinLibraryName = LSubLibName + (UnqualComponentName + "hasktorch-indef-unsigned"), + mixinIncludeRenaming = + IncludeRenaming { + includeProvidesRn = + ModuleRenaming + [ + _×_ + (ModuleName + "Torch.Indef.Storage") + (ModuleName + "Torch.Indef.Cuda.Byte.Storage"), + _×_ + (ModuleName + "Torch.Indef.Storage.Copy") + (ModuleName + "Torch.Indef.Cuda.Byte.Storage.Copy"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor") + (ModuleName + "Torch.Indef.Cuda.Byte.Tensor"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Copy") + (ModuleName + "Torch.Indef.Cuda.Byte.Tensor.Copy"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Index") + (ModuleName + "Torch.Indef.Cuda.Byte.Tensor.Index"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Masked") + (ModuleName + "Torch.Indef.Cuda.Byte.Tensor.Masked"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math") + (ModuleName + "Torch.Indef.Cuda.Byte.Tensor.Math"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Compare") + (ModuleName + "Torch.Indef.Cuda.Byte.Tensor.Math.Compare"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.CompareT") + (ModuleName + "Torch.Indef.Cuda.Byte.Tensor.Math.CompareT"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Pairwise") + (ModuleName + "Torch.Indef.Cuda.Byte.Tensor.Math.Pairwise"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Pointwise") + (ModuleName + "Torch.Indef.Cuda.Byte.Tensor.Math.Pointwise"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Reduce") + (ModuleName + "Torch.Indef.Cuda.Byte.Tensor.Math.Reduce"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Scan") + (ModuleName + "Torch.Indef.Cuda.Byte.Tensor.Math.Scan"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Mode") + (ModuleName + "Torch.Indef.Cuda.Byte.Tensor.Mode"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.ScatterGather") + (ModuleName + "Torch.Indef.Cuda.Byte.Tensor.ScatterGather"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Sort") + (ModuleName + "Torch.Indef.Cuda.Byte.Tensor.Sort"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.TopK") + (ModuleName + "Torch.Indef.Cuda.Byte.Tensor.TopK"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor") + (ModuleName + "Torch.Indef.Cuda.Byte.Dynamic.Tensor"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Copy") + (ModuleName + "Torch.Indef.Cuda.Byte.Dynamic.Tensor.Copy"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Index") + (ModuleName + "Torch.Indef.Cuda.Byte.Dynamic.Tensor.Index"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Masked") + (ModuleName + "Torch.Indef.Cuda.Byte.Dynamic.Tensor.Masked"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math") + (ModuleName + "Torch.Indef.Cuda.Byte.Dynamic.Tensor.Math"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Compare") + (ModuleName + "Torch.Indef.Cuda.Byte.Dynamic.Tensor.Math.Compare"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.CompareT") + (ModuleName + "Torch.Indef.Cuda.Byte.Dynamic.Tensor.Math.CompareT"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pairwise") + (ModuleName + "Torch.Indef.Cuda.Byte.Dynamic.Tensor.Math.Pairwise"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pointwise") + (ModuleName + "Torch.Indef.Cuda.Byte.Dynamic.Tensor.Math.Pointwise"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Reduce") + (ModuleName + "Torch.Indef.Cuda.Byte.Dynamic.Tensor.Math.Reduce"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Scan") + (ModuleName + "Torch.Indef.Cuda.Byte.Dynamic.Tensor.Math.Scan"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Mode") + (ModuleName + "Torch.Indef.Cuda.Byte.Dynamic.Tensor.Mode"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.ScatterGather") + (ModuleName + "Torch.Indef.Cuda.Byte.Dynamic.Tensor.ScatterGather"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Sort") + (ModuleName + "Torch.Indef.Cuda.Byte.Dynamic.Tensor.Sort"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.TopK") + (ModuleName + "Torch.Indef.Cuda.Byte.Dynamic.Tensor.TopK"), + _×_ + (ModuleName "Torch.Indef.Types") + (ModuleName + "Torch.Cuda.Byte.Types"), + _×_ + (ModuleName "Torch.Indef.Index") + (ModuleName + "Torch.Cuda.Byte.Index"), + _×_ + (ModuleName "Torch.Indef.Mask") + (ModuleName + "Torch.Cuda.Byte.Mask")], + includeRequiresRn = + ModuleRenaming + [ + _×_ + (ModuleName + "Torch.Sig.Index.Tensor") + (ModuleName + "Torch.FFI.THC.Long.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Index.TensorFree") + (ModuleName + "Torch.FFI.THC.Long.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Mask.Tensor") + (ModuleName + "Torch.FFI.THC.Byte.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Mask.TensorFree") + (ModuleName + "Torch.FFI.THC.Byte.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Mask.MathReduce") + (ModuleName + "Torch.FFI.THC.Byte.TensorMathReduce"), + _×_ + (ModuleName "Torch.Sig.State") + (ModuleName + "Torch.FFI.THC.State"), + _×_ + (ModuleName + "Torch.Sig.Types.Global") + (ModuleName "Torch.Types.THC"), + _×_ + (ModuleName "Torch.Sig.Types") + (ModuleName + "Torch.Types.THC.Byte"), + _×_ + (ModuleName "Torch.Sig.Storage") + (ModuleName + "Torch.FFI.THC.Byte.Storage"), + _×_ + (ModuleName + "Torch.Sig.Storage.Copy") + (ModuleName + "Torch.FFI.THC.Byte.StorageCopy"), + _×_ + (ModuleName + "Torch.Sig.Storage.Memory") + (ModuleName + "Torch.FFI.THC.Byte.Storage"), + _×_ + (ModuleName "Torch.Sig.Tensor") + (ModuleName + "Torch.FFI.THC.Byte.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Copy") + (ModuleName + "Torch.FFI.THC.Byte.TensorCopy"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Memory") + (ModuleName + "Torch.FFI.THC.Byte.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Index") + (ModuleName + "Torch.FFI.THC.Byte.TensorIndex"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Masked") + (ModuleName + "Torch.FFI.THC.Byte.TensorMasked"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math") + (ModuleName + "Torch.FFI.THC.Byte.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Compare") + (ModuleName + "Torch.FFI.THC.Byte.TensorMathCompare"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.CompareT") + (ModuleName + "Torch.FFI.THC.Byte.TensorMathCompareT"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Pairwise") + (ModuleName + "Torch.FFI.THC.Byte.TensorMathPairwise"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Pointwise") + (ModuleName + "Torch.FFI.THC.Byte.TensorMathPointwise"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Reduce") + (ModuleName + "Torch.FFI.THC.Byte.TensorMathReduce"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Scan") + (ModuleName + "Torch.FFI.THC.Byte.TensorMathScan"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Mode") + (ModuleName + "Torch.FFI.THC.Byte.TensorMode"), + _×_ + (ModuleName + "Torch.Sig.Tensor.ScatterGather") + (ModuleName + "Torch.FFI.THC.Byte.TensorScatterGather"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Sort") + (ModuleName + "Torch.FFI.THC.Byte.TensorSort"), + _×_ + (ModuleName + "Torch.Sig.Tensor.TopK") + (ModuleName + "Torch.FFI.THC.Byte.TensorTopK")]}}, + Mixin { + mixinPackageName = PackageName + "hasktorch", + mixinLibraryName = LSubLibName + (UnqualComponentName + "hasktorch-indef-unsigned"), + mixinIncludeRenaming = + IncludeRenaming { + includeProvidesRn = + ModuleRenaming + [ + _×_ + (ModuleName + "Torch.Indef.Storage") + (ModuleName + "Torch.Indef.Cuda.Char.Storage"), + _×_ + (ModuleName + "Torch.Indef.Storage.Copy") + (ModuleName + "Torch.Indef.Cuda.Char.Storage.Copy"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor") + (ModuleName + "Torch.Indef.Cuda.Char.Tensor"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Copy") + (ModuleName + "Torch.Indef.Cuda.Char.Tensor.Copy"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Index") + (ModuleName + "Torch.Indef.Cuda.Char.Tensor.Index"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Masked") + (ModuleName + "Torch.Indef.Cuda.Char.Tensor.Masked"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math") + (ModuleName + "Torch.Indef.Cuda.Char.Tensor.Math"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Compare") + (ModuleName + "Torch.Indef.Cuda.Char.Tensor.Math.Compare"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.CompareT") + (ModuleName + "Torch.Indef.Cuda.Char.Tensor.Math.CompareT"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Pairwise") + (ModuleName + "Torch.Indef.Cuda.Char.Tensor.Math.Pairwise"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Pointwise") + (ModuleName + "Torch.Indef.Cuda.Char.Tensor.Math.Pointwise"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Reduce") + (ModuleName + "Torch.Indef.Cuda.Char.Tensor.Math.Reduce"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Scan") + (ModuleName + "Torch.Indef.Cuda.Char.Tensor.Math.Scan"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Mode") + (ModuleName + "Torch.Indef.Cuda.Char.Tensor.Mode"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.ScatterGather") + (ModuleName + "Torch.Indef.Cuda.Char.Tensor.ScatterGather"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Sort") + (ModuleName + "Torch.Indef.Cuda.Char.Tensor.Sort"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.TopK") + (ModuleName + "Torch.Indef.Cuda.Char.Tensor.TopK"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor") + (ModuleName + "Torch.Indef.Cuda.Char.Dynamic.Tensor"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Copy") + (ModuleName + "Torch.Indef.Cuda.Char.Dynamic.Tensor.Copy"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Index") + (ModuleName + "Torch.Indef.Cuda.Char.Dynamic.Tensor.Index"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Masked") + (ModuleName + "Torch.Indef.Cuda.Char.Dynamic.Tensor.Masked"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math") + (ModuleName + "Torch.Indef.Cuda.Char.Dynamic.Tensor.Math"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Compare") + (ModuleName + "Torch.Indef.Cuda.Char.Dynamic.Tensor.Math.Compare"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.CompareT") + (ModuleName + "Torch.Indef.Cuda.Char.Dynamic.Tensor.Math.CompareT"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pairwise") + (ModuleName + "Torch.Indef.Cuda.Char.Dynamic.Tensor.Math.Pairwise"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pointwise") + (ModuleName + "Torch.Indef.Cuda.Char.Dynamic.Tensor.Math.Pointwise"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Reduce") + (ModuleName + "Torch.Indef.Cuda.Char.Dynamic.Tensor.Math.Reduce"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Scan") + (ModuleName + "Torch.Indef.Cuda.Char.Dynamic.Tensor.Math.Scan"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Mode") + (ModuleName + "Torch.Indef.Cuda.Char.Dynamic.Tensor.Mode"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.ScatterGather") + (ModuleName + "Torch.Indef.Cuda.Char.Dynamic.Tensor.ScatterGather"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Sort") + (ModuleName + "Torch.Indef.Cuda.Char.Dynamic.Tensor.Sort"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.TopK") + (ModuleName + "Torch.Indef.Cuda.Char.Dynamic.Tensor.TopK"), + _×_ + (ModuleName "Torch.Indef.Types") + (ModuleName + "Torch.Cuda.Char.Types"), + _×_ + (ModuleName "Torch.Indef.Index") + (ModuleName + "Torch.Cuda.Char.Index"), + _×_ + (ModuleName "Torch.Indef.Mask") + (ModuleName + "Torch.Cuda.Char.Mask")], + includeRequiresRn = + ModuleRenaming + [ + _×_ + (ModuleName + "Torch.Sig.Index.Tensor") + (ModuleName + "Torch.FFI.THC.Long.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Index.TensorFree") + (ModuleName + "Torch.FFI.THC.Long.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Mask.Tensor") + (ModuleName + "Torch.FFI.THC.Byte.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Mask.TensorFree") + (ModuleName + "Torch.FFI.THC.Byte.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Mask.MathReduce") + (ModuleName + "Torch.FFI.THC.Byte.TensorMathReduce"), + _×_ + (ModuleName "Torch.Sig.State") + (ModuleName + "Torch.FFI.THC.State"), + _×_ + (ModuleName + "Torch.Sig.Types.Global") + (ModuleName "Torch.Types.THC"), + _×_ + (ModuleName "Torch.Sig.Types") + (ModuleName + "Torch.Types.THC.Char"), + _×_ + (ModuleName "Torch.Sig.Storage") + (ModuleName + "Torch.FFI.THC.Char.Storage"), + _×_ + (ModuleName + "Torch.Sig.Storage.Copy") + (ModuleName + "Torch.FFI.THC.Char.StorageCopy"), + _×_ + (ModuleName + "Torch.Sig.Storage.Memory") + (ModuleName + "Torch.FFI.THC.Char.Storage"), + _×_ + (ModuleName "Torch.Sig.Tensor") + (ModuleName + "Torch.FFI.THC.Char.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Copy") + (ModuleName + "Torch.FFI.THC.Char.TensorCopy"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Memory") + (ModuleName + "Torch.FFI.THC.Char.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Index") + (ModuleName + "Torch.FFI.THC.Char.TensorIndex"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Masked") + (ModuleName + "Torch.FFI.THC.Char.TensorMasked"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math") + (ModuleName + "Torch.FFI.THC.Char.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Compare") + (ModuleName + "Torch.FFI.THC.Char.TensorMathCompare"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.CompareT") + (ModuleName + "Torch.FFI.THC.Char.TensorMathCompareT"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Pairwise") + (ModuleName + "Torch.FFI.THC.Char.TensorMathPairwise"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Pointwise") + (ModuleName + "Torch.FFI.THC.Char.TensorMathPointwise"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Reduce") + (ModuleName + "Torch.FFI.THC.Char.TensorMathReduce"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Scan") + (ModuleName + "Torch.FFI.THC.Char.TensorMathScan"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Mode") + (ModuleName + "Torch.FFI.THC.Char.TensorMode"), + _×_ + (ModuleName + "Torch.Sig.Tensor.ScatterGather") + (ModuleName + "Torch.FFI.THC.Char.TensorScatterGather"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Sort") + (ModuleName + "Torch.FFI.THC.Char.TensorSort"), + _×_ + (ModuleName + "Torch.Sig.Tensor.TopK") + (ModuleName + "Torch.FFI.THC.Char.TensorTopK")]}}, + Mixin { + mixinPackageName = PackageName + "hasktorch", + mixinLibraryName = LSubLibName + (UnqualComponentName + "hasktorch-indef-signed"), + mixinIncludeRenaming = + IncludeRenaming { + includeProvidesRn = + ModuleRenaming + [ + _×_ + (ModuleName + "Torch.Indef.Storage") + (ModuleName + "Torch.Indef.Cuda.Short.Storage"), + _×_ + (ModuleName + "Torch.Indef.Storage.Copy") + (ModuleName + "Torch.Indef.Cuda.Short.Storage.Copy"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor") + (ModuleName + "Torch.Indef.Cuda.Short.Tensor"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Copy") + (ModuleName + "Torch.Indef.Cuda.Short.Tensor.Copy"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Index") + (ModuleName + "Torch.Indef.Cuda.Short.Tensor.Index"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Masked") + (ModuleName + "Torch.Indef.Cuda.Short.Tensor.Masked"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math") + (ModuleName + "Torch.Indef.Cuda.Short.Tensor.Math"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Compare") + (ModuleName + "Torch.Indef.Cuda.Short.Tensor.Math.Compare"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.CompareT") + (ModuleName + "Torch.Indef.Cuda.Short.Tensor.Math.CompareT"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Pairwise") + (ModuleName + "Torch.Indef.Cuda.Short.Tensor.Math.Pairwise"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Pointwise") + (ModuleName + "Torch.Indef.Cuda.Short.Tensor.Math.Pointwise"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Reduce") + (ModuleName + "Torch.Indef.Cuda.Short.Tensor.Math.Reduce"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Scan") + (ModuleName + "Torch.Indef.Cuda.Short.Tensor.Math.Scan"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Mode") + (ModuleName + "Torch.Indef.Cuda.Short.Tensor.Mode"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.ScatterGather") + (ModuleName + "Torch.Indef.Cuda.Short.Tensor.ScatterGather"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Sort") + (ModuleName + "Torch.Indef.Cuda.Short.Tensor.Sort"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.TopK") + (ModuleName + "Torch.Indef.Cuda.Short.Tensor.TopK"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor") + (ModuleName + "Torch.Indef.Cuda.Short.Dynamic.Tensor"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Copy") + (ModuleName + "Torch.Indef.Cuda.Short.Dynamic.Tensor.Copy"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Index") + (ModuleName + "Torch.Indef.Cuda.Short.Dynamic.Tensor.Index"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Masked") + (ModuleName + "Torch.Indef.Cuda.Short.Dynamic.Tensor.Masked"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math") + (ModuleName + "Torch.Indef.Cuda.Short.Dynamic.Tensor.Math"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Compare") + (ModuleName + "Torch.Indef.Cuda.Short.Dynamic.Tensor.Math.Compare"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.CompareT") + (ModuleName + "Torch.Indef.Cuda.Short.Dynamic.Tensor.Math.CompareT"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pairwise") + (ModuleName + "Torch.Indef.Cuda.Short.Dynamic.Tensor.Math.Pairwise"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pointwise") + (ModuleName + "Torch.Indef.Cuda.Short.Dynamic.Tensor.Math.Pointwise"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Reduce") + (ModuleName + "Torch.Indef.Cuda.Short.Dynamic.Tensor.Math.Reduce"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Scan") + (ModuleName + "Torch.Indef.Cuda.Short.Dynamic.Tensor.Math.Scan"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Mode") + (ModuleName + "Torch.Indef.Cuda.Short.Dynamic.Tensor.Mode"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.ScatterGather") + (ModuleName + "Torch.Indef.Cuda.Short.Dynamic.Tensor.ScatterGather"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Sort") + (ModuleName + "Torch.Indef.Cuda.Short.Dynamic.Tensor.Sort"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.TopK") + (ModuleName + "Torch.Indef.Cuda.Short.Dynamic.Tensor.TopK"), + _×_ + (ModuleName "Torch.Indef.Types") + (ModuleName + "Torch.Cuda.Short.Types"), + _×_ + (ModuleName "Torch.Indef.Index") + (ModuleName + "Torch.Cuda.Short.Index"), + _×_ + (ModuleName "Torch.Indef.Mask") + (ModuleName + "Torch.Cuda.Short.Mask"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Pointwise.Signed") + (ModuleName + "Torch.Indef.Cuda.Short.Tensor.Math.Pointwise.Signed"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pointwise.Signed") + (ModuleName + "Torch.Indef.Cuda.Short.Dynamic.Tensor.Math.Pointwise.Signed")], + includeRequiresRn = + ModuleRenaming + [ + _×_ + (ModuleName + "Torch.Sig.Index.Tensor") + (ModuleName + "Torch.FFI.THC.Long.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Index.TensorFree") + (ModuleName + "Torch.FFI.THC.Long.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Mask.Tensor") + (ModuleName + "Torch.FFI.THC.Byte.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Mask.TensorFree") + (ModuleName + "Torch.FFI.THC.Byte.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Mask.MathReduce") + (ModuleName + "Torch.FFI.THC.Byte.TensorMathReduce"), + _×_ + (ModuleName "Torch.Sig.State") + (ModuleName + "Torch.FFI.THC.State"), + _×_ + (ModuleName + "Torch.Sig.Types.Global") + (ModuleName "Torch.Types.THC"), + _×_ + (ModuleName "Torch.Sig.Types") + (ModuleName + "Torch.Types.THC.Short"), + _×_ + (ModuleName "Torch.Sig.Storage") + (ModuleName + "Torch.FFI.THC.Short.Storage"), + _×_ + (ModuleName + "Torch.Sig.Storage.Copy") + (ModuleName + "Torch.FFI.THC.Short.StorageCopy"), + _×_ + (ModuleName + "Torch.Sig.Storage.Memory") + (ModuleName + "Torch.FFI.THC.Short.Storage"), + _×_ + (ModuleName "Torch.Sig.Tensor") + (ModuleName + "Torch.FFI.THC.Short.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Copy") + (ModuleName + "Torch.FFI.THC.Short.TensorCopy"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Memory") + (ModuleName + "Torch.FFI.THC.Short.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Index") + (ModuleName + "Torch.FFI.THC.Short.TensorIndex"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Masked") + (ModuleName + "Torch.FFI.THC.Short.TensorMasked"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math") + (ModuleName + "Torch.FFI.THC.Short.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Compare") + (ModuleName + "Torch.FFI.THC.Short.TensorMathCompare"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.CompareT") + (ModuleName + "Torch.FFI.THC.Short.TensorMathCompareT"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Pairwise") + (ModuleName + "Torch.FFI.THC.Short.TensorMathPairwise"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Pointwise") + (ModuleName + "Torch.FFI.THC.Short.TensorMathPointwise"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Reduce") + (ModuleName + "Torch.FFI.THC.Short.TensorMathReduce"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Scan") + (ModuleName + "Torch.FFI.THC.Short.TensorMathScan"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Mode") + (ModuleName + "Torch.FFI.THC.Short.TensorMode"), + _×_ + (ModuleName + "Torch.Sig.Tensor.ScatterGather") + (ModuleName + "Torch.FFI.THC.Short.TensorScatterGather"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Sort") + (ModuleName + "Torch.FFI.THC.Short.TensorSort"), + _×_ + (ModuleName + "Torch.Sig.Tensor.TopK") + (ModuleName + "Torch.FFI.THC.Short.TensorTopK"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Pointwise.Signed") + (ModuleName + "Torch.FFI.THC.Short.TensorMathPointwise")]}}, + Mixin { + mixinPackageName = PackageName + "hasktorch", + mixinLibraryName = LSubLibName + (UnqualComponentName + "hasktorch-indef-signed"), + mixinIncludeRenaming = + IncludeRenaming { + includeProvidesRn = + ModuleRenaming + [ + _×_ + (ModuleName + "Torch.Indef.Storage") + (ModuleName + "Torch.Indef.Cuda.Int.Storage"), + _×_ + (ModuleName + "Torch.Indef.Storage.Copy") + (ModuleName + "Torch.Indef.Cuda.Int.Storage.Copy"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor") + (ModuleName + "Torch.Indef.Cuda.Int.Tensor"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Copy") + (ModuleName + "Torch.Indef.Cuda.Int.Tensor.Copy"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Index") + (ModuleName + "Torch.Indef.Cuda.Int.Tensor.Index"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Masked") + (ModuleName + "Torch.Indef.Cuda.Int.Tensor.Masked"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math") + (ModuleName + "Torch.Indef.Cuda.Int.Tensor.Math"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Compare") + (ModuleName + "Torch.Indef.Cuda.Int.Tensor.Math.Compare"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.CompareT") + (ModuleName + "Torch.Indef.Cuda.Int.Tensor.Math.CompareT"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Pairwise") + (ModuleName + "Torch.Indef.Cuda.Int.Tensor.Math.Pairwise"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Pointwise") + (ModuleName + "Torch.Indef.Cuda.Int.Tensor.Math.Pointwise"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Reduce") + (ModuleName + "Torch.Indef.Cuda.Int.Tensor.Math.Reduce"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Scan") + (ModuleName + "Torch.Indef.Cuda.Int.Tensor.Math.Scan"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Mode") + (ModuleName + "Torch.Indef.Cuda.Int.Tensor.Mode"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.ScatterGather") + (ModuleName + "Torch.Indef.Cuda.Int.Tensor.ScatterGather"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Sort") + (ModuleName + "Torch.Indef.Cuda.Int.Tensor.Sort"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.TopK") + (ModuleName + "Torch.Indef.Cuda.Int.Tensor.TopK"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor") + (ModuleName + "Torch.Indef.Cuda.Int.Dynamic.Tensor"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Copy") + (ModuleName + "Torch.Indef.Cuda.Int.Dynamic.Tensor.Copy"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Index") + (ModuleName + "Torch.Indef.Cuda.Int.Dynamic.Tensor.Index"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Masked") + (ModuleName + "Torch.Indef.Cuda.Int.Dynamic.Tensor.Masked"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math") + (ModuleName + "Torch.Indef.Cuda.Int.Dynamic.Tensor.Math"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Compare") + (ModuleName + "Torch.Indef.Cuda.Int.Dynamic.Tensor.Math.Compare"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.CompareT") + (ModuleName + "Torch.Indef.Cuda.Int.Dynamic.Tensor.Math.CompareT"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pairwise") + (ModuleName + "Torch.Indef.Cuda.Int.Dynamic.Tensor.Math.Pairwise"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pointwise") + (ModuleName + "Torch.Indef.Cuda.Int.Dynamic.Tensor.Math.Pointwise"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Reduce") + (ModuleName + "Torch.Indef.Cuda.Int.Dynamic.Tensor.Math.Reduce"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Scan") + (ModuleName + "Torch.Indef.Cuda.Int.Dynamic.Tensor.Math.Scan"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Mode") + (ModuleName + "Torch.Indef.Cuda.Int.Dynamic.Tensor.Mode"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.ScatterGather") + (ModuleName + "Torch.Indef.Cuda.Int.Dynamic.Tensor.ScatterGather"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Sort") + (ModuleName + "Torch.Indef.Cuda.Int.Dynamic.Tensor.Sort"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.TopK") + (ModuleName + "Torch.Indef.Cuda.Int.Dynamic.Tensor.TopK"), + _×_ + (ModuleName "Torch.Indef.Types") + (ModuleName + "Torch.Cuda.Int.Types"), + _×_ + (ModuleName "Torch.Indef.Index") + (ModuleName + "Torch.Cuda.Int.Index"), + _×_ + (ModuleName "Torch.Indef.Mask") + (ModuleName + "Torch.Cuda.Int.Mask"), + _×_ + (ModuleName + "Torch.Indef.Static.Tensor.Math.Pointwise.Signed") + (ModuleName + "Torch.Indef.Cuda.Int.Tensor.Math.Pointwise.Signed"), + _×_ + (ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pointwise.Signed") + (ModuleName + "Torch.Indef.Cuda.Int.Dynamic.Tensor.Math.Pointwise.Signed")], + includeRequiresRn = + ModuleRenaming + [ + _×_ + (ModuleName + "Torch.Sig.Index.Tensor") + (ModuleName + "Torch.FFI.THC.Long.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Index.TensorFree") + (ModuleName + "Torch.FFI.THC.Long.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Mask.Tensor") + (ModuleName + "Torch.FFI.THC.Byte.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Mask.TensorFree") + (ModuleName + "Torch.FFI.THC.Byte.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Mask.MathReduce") + (ModuleName + "Torch.FFI.THC.Byte.TensorMathReduce"), + _×_ + (ModuleName "Torch.Sig.State") + (ModuleName + "Torch.FFI.THC.State"), + _×_ + (ModuleName + "Torch.Sig.Types.Global") + (ModuleName "Torch.Types.THC"), + _×_ + (ModuleName "Torch.Sig.Types") + (ModuleName + "Torch.Types.THC.Int"), + _×_ + (ModuleName "Torch.Sig.Storage") + (ModuleName + "Torch.FFI.THC.Int.Storage"), + _×_ + (ModuleName + "Torch.Sig.Storage.Copy") + (ModuleName + "Torch.FFI.THC.Int.StorageCopy"), + _×_ + (ModuleName + "Torch.Sig.Storage.Memory") + (ModuleName + "Torch.FFI.THC.Int.Storage"), + _×_ + (ModuleName "Torch.Sig.Tensor") + (ModuleName + "Torch.FFI.THC.Int.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Copy") + (ModuleName + "Torch.FFI.THC.Int.TensorCopy"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Memory") + (ModuleName + "Torch.FFI.THC.Int.Tensor"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Index") + (ModuleName + "Torch.FFI.THC.Int.TensorIndex"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Masked") + (ModuleName + "Torch.FFI.THC.Int.TensorMasked"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math") + (ModuleName + "Torch.FFI.THC.Int.TensorMath"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Compare") + (ModuleName + "Torch.FFI.THC.Int.TensorMathCompare"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.CompareT") + (ModuleName + "Torch.FFI.THC.Int.TensorMathCompareT"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Pairwise") + (ModuleName + "Torch.FFI.THC.Int.TensorMathPairwise"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Pointwise") + (ModuleName + "Torch.FFI.THC.Int.TensorMathPointwise"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Reduce") + (ModuleName + "Torch.FFI.THC.Int.TensorMathReduce"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Scan") + (ModuleName + "Torch.FFI.THC.Int.TensorMathScan"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Mode") + (ModuleName + "Torch.FFI.THC.Int.TensorMode"), + _×_ + (ModuleName + "Torch.Sig.Tensor.ScatterGather") + (ModuleName + "Torch.FFI.THC.Int.TensorScatterGather"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Sort") + (ModuleName + "Torch.FFI.THC.Int.TensorSort"), + _×_ + (ModuleName + "Torch.Sig.Tensor.TopK") + (ModuleName + "Torch.FFI.THC.Int.TensorTopK"), + _×_ + (ModuleName + "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 + "hasktorch-indef-unsigned") + CondNode { + condTreeData = Library { + libName = LSubLibName + (UnqualComponentName + "hasktorch-indef-unsigned"), + exposedModules = [], + reexportedModules = [ + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName "Torch.Indef.Index", + moduleReexportName = ModuleName + "Torch.Indef.Index"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName "Torch.Indef.Mask", + moduleReexportName = ModuleName + "Torch.Indef.Mask"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName "Torch.Indef.Types", + moduleReexportName = ModuleName + "Torch.Indef.Types"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Storage", + moduleReexportName = ModuleName + "Torch.Indef.Storage"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Storage.Copy", + moduleReexportName = ModuleName + "Torch.Indef.Storage.Copy"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Print", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Print"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Tensor", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Tensor"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Tensor.Copy", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Tensor.Copy"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Tensor.Index", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Tensor.Index"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Tensor.Masked", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Tensor.Masked"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Tensor.Math", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Tensor.Math"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Compare", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Compare"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Tensor.Math.CompareT", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Tensor.Math.CompareT"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pairwise", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pairwise"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pointwise", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pointwise"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Reduce", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Reduce"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Scan", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Scan"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Tensor.Mode", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Tensor.Mode"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Tensor.ScatterGather", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Tensor.ScatterGather"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Tensor.Sort", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Tensor.Sort"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Tensor.TopK", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Tensor.TopK"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.Tensor", + moduleReexportName = ModuleName + "Torch.Indef.Static.Tensor"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.Tensor.Copy", + moduleReexportName = ModuleName + "Torch.Indef.Static.Tensor.Copy"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.Tensor.Index", + moduleReexportName = ModuleName + "Torch.Indef.Static.Tensor.Index"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.Tensor.Masked", + moduleReexportName = ModuleName + "Torch.Indef.Static.Tensor.Masked"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.Tensor.Math", + moduleReexportName = ModuleName + "Torch.Indef.Static.Tensor.Math"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.Tensor.Math.Compare", + moduleReexportName = ModuleName + "Torch.Indef.Static.Tensor.Math.Compare"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.Tensor.Math.CompareT", + moduleReexportName = ModuleName + "Torch.Indef.Static.Tensor.Math.CompareT"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.Tensor.Math.Pairwise", + moduleReexportName = ModuleName + "Torch.Indef.Static.Tensor.Math.Pairwise"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.Tensor.Math.Pointwise", + moduleReexportName = ModuleName + "Torch.Indef.Static.Tensor.Math.Pointwise"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.Tensor.Math.Reduce", + moduleReexportName = ModuleName + "Torch.Indef.Static.Tensor.Math.Reduce"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.Tensor.Math.Scan", + moduleReexportName = ModuleName + "Torch.Indef.Static.Tensor.Math.Scan"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.Tensor.Mode", + moduleReexportName = ModuleName + "Torch.Indef.Static.Tensor.Mode"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.Tensor.ScatterGather", + moduleReexportName = ModuleName + "Torch.Indef.Static.Tensor.ScatterGather"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.Tensor.Sort", + moduleReexportName = ModuleName + "Torch.Indef.Static.Tensor.Sort"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.Tensor.TopK", + moduleReexportName = ModuleName + "Torch.Indef.Static.Tensor.TopK"}], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPrivate, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Just + Haskell2010, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + 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], + mixins = [ + Mixin { + mixinPackageName = PackageName + "hasktorch-indef", + mixinLibraryName = LMainLibName, + mixinIncludeRenaming = + IncludeRenaming { + includeProvidesRn = + DefaultRenaming, + includeRequiresRn = + ModuleRenaming + [ + _×_ + (ModuleName "Torch.Sig.NN") + (ModuleName + "Torch.Undefined.NN"), + _×_ + (ModuleName + "Torch.Sig.Types.NN") + (ModuleName + "Torch.Undefined.Types.NN"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Blas") + (ModuleName + "Torch.Undefined.Tensor.Math.Blas"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Floating") + (ModuleName + "Torch.Undefined.Tensor.Math.Floating"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Lapack") + (ModuleName + "Torch.Undefined.Tensor.Math.Lapack"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Pointwise.Signed") + (ModuleName + "Torch.Undefined.Tensor.Math.Pointwise.Signed"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Pointwise.Floating") + (ModuleName + "Torch.Undefined.Tensor.Math.Pointwise.Floating"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Reduce.Floating") + (ModuleName + "Torch.Undefined.Tensor.Math.Reduce.Floating"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Random.TH") + (ModuleName + "Torch.Undefined.Tensor.Math.Random.TH"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Random.TH") + (ModuleName + "Torch.Undefined.Tensor.Random.TH"), + _×_ + (ModuleName + "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 + "hasktorch-indef-signed") + CondNode { + condTreeData = Library { + libName = LSubLibName + (UnqualComponentName + "hasktorch-indef-signed"), + exposedModules = [], + reexportedModules = [ + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName "Torch.Indef.Index", + moduleReexportName = ModuleName + "Torch.Indef.Index"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName "Torch.Indef.Mask", + moduleReexportName = ModuleName + "Torch.Indef.Mask"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName "Torch.Indef.Types", + moduleReexportName = ModuleName + "Torch.Indef.Types"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Storage", + moduleReexportName = ModuleName + "Torch.Indef.Storage"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Storage.Copy", + moduleReexportName = ModuleName + "Torch.Indef.Storage.Copy"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Print", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Print"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Tensor", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Tensor"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Tensor.Copy", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Tensor.Copy"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Tensor.Index", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Tensor.Index"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Tensor.Masked", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Tensor.Masked"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Tensor.Math", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Tensor.Math"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Compare", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Compare"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Tensor.Math.CompareT", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Tensor.Math.CompareT"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pairwise", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pairwise"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pointwise", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pointwise"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Reduce", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Reduce"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Scan", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Scan"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Tensor.Mode", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Tensor.Mode"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Tensor.ScatterGather", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Tensor.ScatterGather"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Tensor.Sort", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Tensor.Sort"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Tensor.TopK", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Tensor.TopK"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.Tensor", + moduleReexportName = ModuleName + "Torch.Indef.Static.Tensor"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.Tensor.Copy", + moduleReexportName = ModuleName + "Torch.Indef.Static.Tensor.Copy"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.Tensor.Index", + moduleReexportName = ModuleName + "Torch.Indef.Static.Tensor.Index"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.Tensor.Masked", + moduleReexportName = ModuleName + "Torch.Indef.Static.Tensor.Masked"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.Tensor.Math", + moduleReexportName = ModuleName + "Torch.Indef.Static.Tensor.Math"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.Tensor.Math.Compare", + moduleReexportName = ModuleName + "Torch.Indef.Static.Tensor.Math.Compare"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.Tensor.Math.CompareT", + moduleReexportName = ModuleName + "Torch.Indef.Static.Tensor.Math.CompareT"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.Tensor.Math.Pairwise", + moduleReexportName = ModuleName + "Torch.Indef.Static.Tensor.Math.Pairwise"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.Tensor.Math.Pointwise", + moduleReexportName = ModuleName + "Torch.Indef.Static.Tensor.Math.Pointwise"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.Tensor.Math.Reduce", + moduleReexportName = ModuleName + "Torch.Indef.Static.Tensor.Math.Reduce"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.Tensor.Math.Scan", + moduleReexportName = ModuleName + "Torch.Indef.Static.Tensor.Math.Scan"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.Tensor.Mode", + moduleReexportName = ModuleName + "Torch.Indef.Static.Tensor.Mode"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.Tensor.ScatterGather", + moduleReexportName = ModuleName + "Torch.Indef.Static.Tensor.ScatterGather"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.Tensor.Sort", + moduleReexportName = ModuleName + "Torch.Indef.Static.Tensor.Sort"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.Tensor.TopK", + moduleReexportName = ModuleName + "Torch.Indef.Static.Tensor.TopK"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.Tensor.Math.Pointwise.Signed", + moduleReexportName = ModuleName + "Torch.Indef.Static.Tensor.Math.Pointwise.Signed"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pointwise.Signed", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pointwise.Signed"}], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPrivate, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Just + Haskell2010, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + 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], + mixins = [ + Mixin { + mixinPackageName = PackageName + "hasktorch-indef", + mixinLibraryName = LMainLibName, + mixinIncludeRenaming = + IncludeRenaming { + includeProvidesRn = + DefaultRenaming, + includeRequiresRn = + ModuleRenaming + [ + _×_ + (ModuleName "Torch.Sig.NN") + (ModuleName + "Torch.Undefined.NN"), + _×_ + (ModuleName + "Torch.Sig.Types.NN") + (ModuleName + "Torch.Undefined.Types.NN"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Blas") + (ModuleName + "Torch.Undefined.Tensor.Math.Blas"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Floating") + (ModuleName + "Torch.Undefined.Tensor.Math.Floating"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Lapack") + (ModuleName + "Torch.Undefined.Tensor.Math.Lapack"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Pointwise.Floating") + (ModuleName + "Torch.Undefined.Tensor.Math.Pointwise.Floating"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Reduce.Floating") + (ModuleName + "Torch.Undefined.Tensor.Math.Reduce.Floating"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Math.Random.TH") + (ModuleName + "Torch.Undefined.Tensor.Math.Random.TH"), + _×_ + (ModuleName + "Torch.Sig.Tensor.Random.TH") + (ModuleName + "Torch.Undefined.Tensor.Random.TH"), + _×_ + (ModuleName + "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 + "hasktorch-indef-floating") + CondNode { + condTreeData = Library { + libName = LSubLibName + (UnqualComponentName + "hasktorch-indef-floating"), + exposedModules = [], + reexportedModules = [ + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName "Torch.Indef.Index", + moduleReexportName = ModuleName + "Torch.Indef.Index"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName "Torch.Indef.Mask", + moduleReexportName = ModuleName + "Torch.Indef.Mask"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName "Torch.Indef.Types", + moduleReexportName = ModuleName + "Torch.Indef.Types"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Storage", + moduleReexportName = ModuleName + "Torch.Indef.Storage"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Storage.Copy", + moduleReexportName = ModuleName + "Torch.Indef.Storage.Copy"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Print", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Print"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Tensor", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Tensor"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Tensor.Copy", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Tensor.Copy"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Tensor.Index", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Tensor.Index"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Tensor.Masked", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Tensor.Masked"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Tensor.Math", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Tensor.Math"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Compare", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Compare"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Tensor.Math.CompareT", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Tensor.Math.CompareT"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pairwise", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pairwise"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pointwise", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pointwise"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Reduce", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Reduce"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Scan", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Scan"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Tensor.Mode", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Tensor.Mode"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Tensor.ScatterGather", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Tensor.ScatterGather"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Tensor.Sort", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Tensor.Sort"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Tensor.TopK", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Tensor.TopK"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.Tensor", + moduleReexportName = ModuleName + "Torch.Indef.Static.Tensor"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.Tensor.Copy", + moduleReexportName = ModuleName + "Torch.Indef.Static.Tensor.Copy"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.Tensor.Index", + moduleReexportName = ModuleName + "Torch.Indef.Static.Tensor.Index"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.Tensor.Masked", + moduleReexportName = ModuleName + "Torch.Indef.Static.Tensor.Masked"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.Tensor.Math", + moduleReexportName = ModuleName + "Torch.Indef.Static.Tensor.Math"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.Tensor.Math.Compare", + moduleReexportName = ModuleName + "Torch.Indef.Static.Tensor.Math.Compare"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.Tensor.Math.CompareT", + moduleReexportName = ModuleName + "Torch.Indef.Static.Tensor.Math.CompareT"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.Tensor.Math.Pairwise", + moduleReexportName = ModuleName + "Torch.Indef.Static.Tensor.Math.Pairwise"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.Tensor.Math.Pointwise", + moduleReexportName = ModuleName + "Torch.Indef.Static.Tensor.Math.Pointwise"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.Tensor.Math.Reduce", + moduleReexportName = ModuleName + "Torch.Indef.Static.Tensor.Math.Reduce"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.Tensor.Math.Scan", + moduleReexportName = ModuleName + "Torch.Indef.Static.Tensor.Math.Scan"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.Tensor.Mode", + moduleReexportName = ModuleName + "Torch.Indef.Static.Tensor.Mode"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.Tensor.ScatterGather", + moduleReexportName = ModuleName + "Torch.Indef.Static.Tensor.ScatterGather"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.Tensor.Sort", + moduleReexportName = ModuleName + "Torch.Indef.Static.Tensor.Sort"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.Tensor.TopK", + moduleReexportName = ModuleName + "Torch.Indef.Static.Tensor.TopK"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.Tensor.Math.Pointwise.Signed", + moduleReexportName = ModuleName + "Torch.Indef.Static.Tensor.Math.Pointwise.Signed"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pointwise.Signed", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pointwise.Signed"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Blas", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Blas"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Floating", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Floating"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Lapack", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Lapack"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pointwise.Floating", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Pointwise.Floating"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Reduce.Floating", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Reduce.Floating"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Tensor.Random.TH", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Tensor.Random.TH"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Tensor.Random.THC", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Tensor.Random.THC"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Random.TH", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.Tensor.Math.Random.TH"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.Tensor.Math.Blas", + moduleReexportName = ModuleName + "Torch.Indef.Static.Tensor.Math.Blas"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.Tensor.Math.Floating", + moduleReexportName = ModuleName + "Torch.Indef.Static.Tensor.Math.Floating"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.Tensor.Math.Lapack", + moduleReexportName = ModuleName + "Torch.Indef.Static.Tensor.Math.Lapack"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.Tensor.Math.Pointwise.Floating", + moduleReexportName = ModuleName + "Torch.Indef.Static.Tensor.Math.Pointwise.Floating"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.Tensor.Math.Reduce.Floating", + moduleReexportName = ModuleName + "Torch.Indef.Static.Tensor.Math.Reduce.Floating"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.Tensor.Random.TH", + moduleReexportName = ModuleName + "Torch.Indef.Static.Tensor.Random.TH"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.Tensor.Random.THC", + moduleReexportName = ModuleName + "Torch.Indef.Static.Tensor.Random.THC"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.Tensor.Math.Random.TH", + moduleReexportName = ModuleName + "Torch.Indef.Static.Tensor.Math.Random.TH"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.NN", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.NN"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.NN.Activation", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.NN.Activation"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.NN.Pooling", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.NN.Pooling"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Dynamic.NN.Criterion", + moduleReexportName = ModuleName + "Torch.Indef.Dynamic.NN.Criterion"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.NN", + moduleReexportName = ModuleName + "Torch.Indef.Static.NN"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.NN.Activation", + moduleReexportName = ModuleName + "Torch.Indef.Static.NN.Activation"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.NN.Backprop", + moduleReexportName = ModuleName + "Torch.Indef.Static.NN.Backprop"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.NN.Conv1d", + moduleReexportName = ModuleName + "Torch.Indef.Static.NN.Conv1d"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.NN.Conv2d", + moduleReexportName = ModuleName + "Torch.Indef.Static.NN.Conv2d"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.NN.Criterion", + moduleReexportName = ModuleName + "Torch.Indef.Static.NN.Criterion"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.NN.Layers", + moduleReexportName = ModuleName + "Torch.Indef.Static.NN.Layers"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.NN.Linear", + moduleReexportName = ModuleName + "Torch.Indef.Static.NN.Linear"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.NN.Math", + moduleReexportName = ModuleName + "Torch.Indef.Static.NN.Math"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.NN.Padding", + moduleReexportName = ModuleName + "Torch.Indef.Static.NN.Padding"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.NN.Pooling", + moduleReexportName = ModuleName + "Torch.Indef.Static.NN.Pooling"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Indef.Static.NN.Sampling", + moduleReexportName = ModuleName + "Torch.Indef.Static.NN.Sampling"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Undefined.Tensor.Math.Random.TH", + moduleReexportName = ModuleName + "Torch.Undefined.Tensor.Math.Random.TH"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Undefined.Tensor.Random.TH", + moduleReexportName = ModuleName + "Torch.Undefined.Tensor.Random.TH"}, + ModuleReexport { + moduleReexportOriginalPackage = + Nothing, + moduleReexportOriginalName = + ModuleName + "Torch.Undefined.Tensor.Random.THC", + moduleReexportName = ModuleName + "Torch.Undefined.Tensor.Random.THC"}], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPrivate, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Just + Haskell2010, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + 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], + 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 = [ + _×_ + (UnqualComponentName + "isdefinite-cpu") + CondNode { + condTreeData = Executable { + exeName = UnqualComponentName + "isdefinite-cpu", + modulePath = "Noop.hs", + exeScope = ExecutablePublic, + buildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [ + SymbolicPath "exe"], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Just + Haskell2010, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + 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")]))], + 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 + "isdefinite-gpu") + CondNode { + condTreeData = Executable { + exeName = UnqualComponentName + "isdefinite-gpu", + modulePath = "Noop.hs", + exeScope = ExecutablePublic, + buildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [ + SymbolicPath "exe"], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Just + Haskell2010, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + 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")]))], + 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 + "isdefinite") + CondNode { + condTreeData = Executable { + exeName = UnqualComponentName + "isdefinite", + modulePath = "Noop.hs", + exeScope = ExecutablePublic, + buildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [ + SymbolicPath "exe"], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Just + Haskell2010, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + Dependency + (PackageName "base") + (IntersectVersionRanges + (UnionVersionRanges + (ThisVersion (mkVersion [4, 7])) + (LaterVersion + (mkVersion [4, 7]))) + (EarlierVersion + (mkVersion [5]))) + mainLibSet, + Dependency + (PackageName "hasktorch") + (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") + CondNode { + condTreeData = Executable { + exeName = UnqualComponentName + "memcheck", + modulePath = "Memcheck.hs", + exeScope = ExecutablePublic, + buildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [ + SymbolicPath "exe"], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Just + Haskell2010, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + Dependency + (PackageName "base") + (IntersectVersionRanges + (UnionVersionRanges + (ThisVersion (mkVersion [4, 7])) + (LaterVersion + (mkVersion [4, 7]))) + (EarlierVersion + (mkVersion [5]))) + mainLibSet, + Dependency + (PackageName "hasktorch") + (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 = [ + _×_ + (UnqualComponentName "spec") + CondNode { + condTreeData = TestSuite { + testName = UnqualComponentName + "", + testInterface = TestSuiteExeV10 + (mkVersion [1, 0]) + "Spec.hs", + testBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [ + SymbolicPath "tests"], + otherModules = [ + ModuleName "Orphans", + ModuleName "MemorySpec", + ModuleName "RawLapackSVDSpec", + ModuleName + "GarbageCollectionSpec", + ModuleName + "Torch.Prelude.Extras", + ModuleName + "Torch.Core.LogAddSpec", + ModuleName + "Torch.Core.RandomSpec", + ModuleName + "Torch.Static.NN.AbsSpec", + ModuleName + "Torch.Static.NN.LinearSpec"], + virtualModules = [], + autogenModules = [], + defaultLanguage = Just + Haskell2010, + otherLanguages = [], + defaultExtensions = [ + EnableExtension LambdaCase, + EnableExtension DataKinds, + EnableExtension TypeFamilies, + EnableExtension + TypeSynonymInstances, + EnableExtension + ScopedTypeVariables, + EnableExtension + FlexibleContexts, + EnableExtension CPP], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + 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], + 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/Cabal-tests/tests/ParserTests/regressions/hasktorch.format b/cabal/Cabal-tests/tests/ParserTests/regressions/hasktorch.format new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/hasktorch.format @@ -0,0 +1,565 @@ +cabal-version: 2.2 +name: hasktorch +version: 0.0.1.0 +license: BSD-3-Clause +maintainer: + Sam Stites , Austin Huang - cipher:ROT13 + +author: Hasktorch dev team +homepage: https://github.com/hasktorch/hasktorch#readme +bug-reports: https://github.com/hasktorch/hasktorch/issues +synopsis: Torch for tensors and neural networks in Haskell +description: + Hasktorch is a library for tensors and neural networks in Haskell. It is an independent open source community project which leverages the core C libraries shared by Torch and PyTorch. This library leverages @cabal v2-build@ and @backpack@. *Note that this project is in early development and should only be used by contributing developers. Expect substantial changes to the library API as it evolves. Contributions and PRs are welcome (see details on github).* + +category: Tensors, Machine Learning, AI +build-type: Simple + +source-repository head + type: git + location: https://github.com/hasktorch/hasktorch + +flag cuda + description: build with THC support + default: False + +flag lite + description: only build with Double and Long support + default: False + +library + exposed-modules: + Torch.Core.Exceptions + Torch.Core.Random + Torch.Core.LogAdd + + reexported-modules: + Torch.Types.Numeric, + Torch.Long, + Torch.Long.Dynamic, + Torch.Long.Storage, + Torch.Double, + Torch.Double.Dynamic, + Torch.Double.Storage, + Torch.Double.NN, + Torch.Double.NN.Activation, + Torch.Double.NN.Backprop, + Torch.Double.NN.Conv1d, + Torch.Double.NN.Conv2d, + Torch.Double.NN.Criterion, + Torch.Double.NN.Layers, + Torch.Double.NN.Linear, + Torch.Double.NN.Math, + Torch.Double.NN.Padding, + Torch.Double.NN.Pooling, + Torch.Double.NN.Sampling, + Torch.Double.Dynamic.NN, + Torch.Double.Dynamic.NN.Activation, + Torch.Double.Dynamic.NN.Pooling, + Torch.Double.Dynamic.NN.Criterion + + hs-source-dirs: utils + default-language: Haskell2010 + default-extensions: + LambdaCase DataKinds TypeFamilies TypeSynonymInstances + ScopedTypeVariables FlexibleContexts CPP + + build-depends: + base (==4.7 || >4.7) && <5, + dimensions ==1.0 || >1.0, + safe-exceptions ==0.1.0 || >0.1.0, + singletons ==2.2 || >2.2, + text ==1.2.2 || >1.2.2, + hasktorch-cpu, + hasktorch-ffi-th (==0.0.1 || >0.0.1) && <0.0.2, + hasktorch-types-th (==0.0.1 || >0.0.1) && <0.0.2 + + if !flag(lite) + reexported-modules: + Torch.Byte, + Torch.Byte.Dynamic, + Torch.Byte.Storage, + Torch.Char, + Torch.Char.Dynamic, + Torch.Char.Storage, + Torch.Short, + Torch.Short.Dynamic, + Torch.Short.Storage, + Torch.Int, + Torch.Int.Dynamic, + Torch.Int.Storage, + Torch.Float, + Torch.Float.Dynamic, + Torch.Float.Storage + + if flag(cuda) + reexported-modules: + Torch.Cuda.Long, + Torch.Cuda.Long.Dynamic, + Torch.Cuda.Long.Storage, + Torch.Cuda.Double, + Torch.Cuda.Double.Dynamic, + Torch.Cuda.Double.Storage, + Torch.Cuda.Double.NN, + Torch.Cuda.Double.NN.Activation, + Torch.Cuda.Double.NN.Backprop, + Torch.Cuda.Double.NN.Conv1d, + Torch.Cuda.Double.NN.Conv2d, + Torch.Cuda.Double.NN.Criterion, + Torch.Cuda.Double.NN.Layers, + Torch.Cuda.Double.NN.Linear, + Torch.Cuda.Double.NN.Math, + Torch.Cuda.Double.NN.Padding, + Torch.Cuda.Double.NN.Pooling, + Torch.Cuda.Double.NN.Sampling, + Torch.Cuda.Double.Dynamic.NN, + Torch.Cuda.Double.Dynamic.NN.Activation, + Torch.Cuda.Double.Dynamic.NN.Pooling, + Torch.Cuda.Double.Dynamic.NN.Criterion + + build-depends: hasktorch-gpu + + if !flag(lite) + reexported-modules: + Torch.Cuda.Byte, + Torch.Cuda.Byte.Dynamic, + Torch.Cuda.Byte.Storage, + Torch.Cuda.Char, + Torch.Cuda.Char.Dynamic, + Torch.Cuda.Char.Storage, + Torch.Cuda.Short, + Torch.Cuda.Short.Dynamic, + Torch.Cuda.Short.Storage, + Torch.Cuda.Int, + Torch.Cuda.Int.Dynamic, + Torch.Cuda.Int.Storage, + Torch.Cuda.Float, + Torch.Cuda.Float.Dynamic, + Torch.Cuda.Float.Storage + +library hasktorch-cpu + exposed-modules: + Torch.Long + Torch.Long.Dynamic + Torch.Long.Storage + Torch.Double + Torch.Double.Dynamic + Torch.Double.Storage + + reexported-modules: + Torch.Double.NN, + Torch.Double.NN.Activation, + Torch.Double.NN.Backprop, + Torch.Double.NN.Conv1d, + Torch.Double.NN.Conv2d, + Torch.Double.NN.Criterion, + Torch.Double.NN.Layers, + Torch.Double.NN.Linear, + Torch.Double.NN.Math, + Torch.Double.NN.Padding, + Torch.Double.NN.Pooling, + Torch.Double.NN.Sampling, + Torch.Double.Dynamic.NN, + Torch.Double.Dynamic.NN.Activation, + Torch.Double.Dynamic.NN.Pooling, + Torch.Double.Dynamic.NN.Criterion, + Torch.Float.NN, + Torch.Float.NN.Activation, + Torch.Float.NN.Backprop, + Torch.Float.NN.Conv1d, + Torch.Float.NN.Conv2d, + Torch.Float.NN.Criterion, + Torch.Float.NN.Layers, + Torch.Float.NN.Linear, + Torch.Float.NN.Math, + Torch.Float.NN.Padding, + Torch.Float.NN.Pooling, + Torch.Float.NN.Sampling, + Torch.Float.Dynamic.NN, + Torch.Float.Dynamic.NN.Activation, + Torch.Float.Dynamic.NN.Pooling, + Torch.Float.Dynamic.NN.Criterion + + hs-source-dirs: utils src + other-modules: + Torch.Core.Exceptions + Torch.Core.Random + Torch.Core.LogAdd + + default-language: Haskell2010 + default-extensions: + LambdaCase DataKinds TypeFamilies TypeSynonymInstances + ScopedTypeVariables FlexibleContexts CPP + + build-depends: + base (==4.7 || >4.7) && <5, + hasktorch-types-th (==0.0.1 || >0.0.1) && <0.0.2, + dimensions ==1.0 || >1.0, + hasktorch-ffi-th (==0.0.1 || >0.0.1) && <0.0.2, + hasktorch-types-th (==0.0.1 || >0.0.1) && <0.0.2, + safe-exceptions ==0.1.0 || >0.1.0, + singletons ==2.2 || >2.2, + text ==1.2.2 || >1.2.2, + hasktorch-indef-floating, + hasktorch-indef-signed + + mixins: + hasktorch-indef-signed (Torch.Indef.Storage as Torch.Indef.Long.Storage, Torch.Indef.Storage.Copy as Torch.Indef.Long.Storage.Copy, Torch.Indef.Static.Tensor as Torch.Indef.Long.Tensor, Torch.Indef.Static.Tensor.Copy as Torch.Indef.Long.Tensor.Copy, Torch.Indef.Static.Tensor.Index as Torch.Indef.Long.Tensor.Index, Torch.Indef.Static.Tensor.Masked as Torch.Indef.Long.Tensor.Masked, Torch.Indef.Static.Tensor.Math as Torch.Indef.Long.Tensor.Math, Torch.Indef.Static.Tensor.Math.Compare as Torch.Indef.Long.Tensor.Math.Compare, Torch.Indef.Static.Tensor.Math.CompareT as Torch.Indef.Long.Tensor.Math.CompareT, Torch.Indef.Static.Tensor.Math.Pairwise as Torch.Indef.Long.Tensor.Math.Pairwise, Torch.Indef.Static.Tensor.Math.Pointwise as Torch.Indef.Long.Tensor.Math.Pointwise, Torch.Indef.Static.Tensor.Math.Reduce as Torch.Indef.Long.Tensor.Math.Reduce, Torch.Indef.Static.Tensor.Math.Scan as Torch.Indef.Long.Tensor.Math.Scan, Torch.Indef.Static.Tensor.Mode as Torch.Indef.Long.Tensor.Mode, Torch.Indef.Static.Tensor.ScatterGather as Torch.Indef.Long.Tensor.ScatterGather, Torch.Indef.Static.Tensor.Sort as Torch.Indef.Long.Tensor.Sort, Torch.Indef.Static.Tensor.TopK as Torch.Indef.Long.Tensor.TopK, Torch.Indef.Dynamic.Tensor as Torch.Indef.Long.Dynamic.Tensor, Torch.Indef.Dynamic.Tensor.Copy as Torch.Indef.Long.Dynamic.Tensor.Copy, Torch.Indef.Dynamic.Tensor.Index as Torch.Indef.Long.Dynamic.Tensor.Index, Torch.Indef.Dynamic.Tensor.Masked as Torch.Indef.Long.Dynamic.Tensor.Masked, Torch.Indef.Dynamic.Tensor.Math as Torch.Indef.Long.Dynamic.Tensor.Math, Torch.Indef.Dynamic.Tensor.Math.Compare as Torch.Indef.Long.Dynamic.Tensor.Math.Compare, Torch.Indef.Dynamic.Tensor.Math.CompareT as Torch.Indef.Long.Dynamic.Tensor.Math.CompareT, Torch.Indef.Dynamic.Tensor.Math.Pairwise as Torch.Indef.Long.Dynamic.Tensor.Math.Pairwise, Torch.Indef.Dynamic.Tensor.Math.Pointwise as Torch.Indef.Long.Dynamic.Tensor.Math.Pointwise, Torch.Indef.Dynamic.Tensor.Math.Reduce as Torch.Indef.Long.Dynamic.Tensor.Math.Reduce, Torch.Indef.Dynamic.Tensor.Math.Scan as Torch.Indef.Long.Dynamic.Tensor.Math.Scan, Torch.Indef.Dynamic.Tensor.Mode as Torch.Indef.Long.Dynamic.Tensor.Mode, Torch.Indef.Dynamic.Tensor.ScatterGather as Torch.Indef.Long.Dynamic.Tensor.ScatterGather, Torch.Indef.Dynamic.Tensor.Sort as Torch.Indef.Long.Dynamic.Tensor.Sort, Torch.Indef.Dynamic.Tensor.TopK as Torch.Indef.Long.Dynamic.Tensor.TopK, Torch.Indef.Types as Torch.Long.Types, Torch.Indef.Index as Torch.Long.Index, Torch.Indef.Mask as Torch.Long.Mask, Torch.Indef.Static.Tensor.Math.Pointwise.Signed as Torch.Indef.Long.Tensor.Math.Pointwise.Signed, Torch.Indef.Dynamic.Tensor.Math.Pointwise.Signed as Torch.Indef.Long.Dynamic.Tensor.Math.Pointwise.Signed) requires (Torch.Sig.Index.Tensor as Torch.FFI.TH.Long.Tensor, Torch.Sig.Index.TensorFree as Torch.FFI.TH.Long.FreeTensor, Torch.Sig.Mask.Tensor as Torch.FFI.TH.Byte.Tensor, Torch.Sig.Mask.TensorFree as Torch.FFI.TH.Byte.FreeTensor, Torch.Sig.Mask.MathReduce as Torch.FFI.TH.Byte.TensorMath, Torch.Sig.State as Torch.Types.TH, Torch.Sig.Types.Global as Torch.Types.TH, Torch.Sig.Types as Torch.Types.TH.Long, Torch.Sig.Storage as Torch.FFI.TH.Long.Storage, Torch.Sig.Storage.Copy as Torch.FFI.TH.Long.StorageCopy, Torch.Sig.Storage.Memory as Torch.FFI.TH.Long.FreeStorage, Torch.Sig.Tensor as Torch.FFI.TH.Long.Tensor, Torch.Sig.Tensor.Copy as Torch.FFI.TH.Long.TensorCopy, Torch.Sig.Tensor.Memory as Torch.FFI.TH.Long.FreeTensor, Torch.Sig.Tensor.Index as Torch.FFI.TH.Long.TensorMath, Torch.Sig.Tensor.Masked as Torch.FFI.TH.Long.TensorMath, Torch.Sig.Tensor.Math as Torch.FFI.TH.Long.TensorMath, Torch.Sig.Tensor.Math.Compare as Torch.FFI.TH.Long.TensorMath, Torch.Sig.Tensor.Math.CompareT as Torch.FFI.TH.Long.TensorMath, Torch.Sig.Tensor.Math.Pairwise as Torch.FFI.TH.Long.TensorMath, Torch.Sig.Tensor.Math.Pointwise as Torch.FFI.TH.Long.TensorMath, Torch.Sig.Tensor.Math.Reduce as Torch.FFI.TH.Long.TensorMath, Torch.Sig.Tensor.Math.Scan as Torch.FFI.TH.Long.TensorMath, Torch.Sig.Tensor.Mode as Torch.FFI.TH.Long.TensorMath, Torch.Sig.Tensor.ScatterGather as Torch.FFI.TH.Long.TensorMath, Torch.Sig.Tensor.Sort as Torch.FFI.TH.Long.TensorMath, Torch.Sig.Tensor.TopK as Torch.FFI.TH.Long.TensorMath, Torch.Sig.Tensor.Math.Pointwise.Signed as Torch.FFI.TH.Long.TensorMath), + hasktorch-indef-floating (Torch.Indef.Storage as Torch.Indef.Double.Storage, Torch.Indef.Storage.Copy as Torch.Indef.Double.Storage.Copy, Torch.Indef.Static.Tensor as Torch.Indef.Double.Tensor, Torch.Indef.Static.Tensor.Copy as Torch.Indef.Double.Tensor.Copy, Torch.Indef.Static.Tensor.Index as Torch.Indef.Double.Tensor.Index, Torch.Indef.Static.Tensor.Masked as Torch.Indef.Double.Tensor.Masked, Torch.Indef.Static.Tensor.Math as Torch.Indef.Double.Tensor.Math, Torch.Indef.Static.Tensor.Math.Compare as Torch.Indef.Double.Tensor.Math.Compare, Torch.Indef.Static.Tensor.Math.CompareT as Torch.Indef.Double.Tensor.Math.CompareT, Torch.Indef.Static.Tensor.Math.Pairwise as Torch.Indef.Double.Tensor.Math.Pairwise, Torch.Indef.Static.Tensor.Math.Pointwise as Torch.Indef.Double.Tensor.Math.Pointwise, Torch.Indef.Static.Tensor.Math.Reduce as Torch.Indef.Double.Tensor.Math.Reduce, Torch.Indef.Static.Tensor.Math.Scan as Torch.Indef.Double.Tensor.Math.Scan, Torch.Indef.Static.Tensor.Mode as Torch.Indef.Double.Tensor.Mode, Torch.Indef.Static.Tensor.ScatterGather as Torch.Indef.Double.Tensor.ScatterGather, Torch.Indef.Static.Tensor.Sort as Torch.Indef.Double.Tensor.Sort, Torch.Indef.Static.Tensor.TopK as Torch.Indef.Double.Tensor.TopK, Torch.Indef.Dynamic.Tensor as Torch.Indef.Double.Dynamic.Tensor, Torch.Indef.Dynamic.Tensor.Copy as Torch.Indef.Double.Dynamic.Tensor.Copy, Torch.Indef.Dynamic.Tensor.Index as Torch.Indef.Double.Dynamic.Tensor.Index, Torch.Indef.Dynamic.Tensor.Masked as Torch.Indef.Double.Dynamic.Tensor.Masked, Torch.Indef.Dynamic.Tensor.Math as Torch.Indef.Double.Dynamic.Tensor.Math, Torch.Indef.Dynamic.Tensor.Math.Compare as Torch.Indef.Double.Dynamic.Tensor.Math.Compare, Torch.Indef.Dynamic.Tensor.Math.CompareT as Torch.Indef.Double.Dynamic.Tensor.Math.CompareT, Torch.Indef.Dynamic.Tensor.Math.Pairwise as Torch.Indef.Double.Dynamic.Tensor.Math.Pairwise, Torch.Indef.Dynamic.Tensor.Math.Pointwise as Torch.Indef.Double.Dynamic.Tensor.Math.Pointwise, Torch.Indef.Dynamic.Tensor.Math.Reduce as Torch.Indef.Double.Dynamic.Tensor.Math.Reduce, Torch.Indef.Dynamic.Tensor.Math.Scan as Torch.Indef.Double.Dynamic.Tensor.Math.Scan, Torch.Indef.Dynamic.Tensor.Mode as Torch.Indef.Double.Dynamic.Tensor.Mode, Torch.Indef.Dynamic.Tensor.ScatterGather as Torch.Indef.Double.Dynamic.Tensor.ScatterGather, Torch.Indef.Dynamic.Tensor.Sort as Torch.Indef.Double.Dynamic.Tensor.Sort, Torch.Indef.Dynamic.Tensor.TopK as Torch.Indef.Double.Dynamic.Tensor.TopK, Torch.Indef.Types as Torch.Double.Types, Torch.Indef.Index as Torch.Double.Index, Torch.Indef.Mask as Torch.Double.Mask, Torch.Indef.Static.Tensor.Math.Pointwise.Signed as Torch.Indef.Double.Tensor.Math.Pointwise.Signed, Torch.Indef.Dynamic.Tensor.Math.Pointwise.Signed as Torch.Indef.Double.Dynamic.Tensor.Math.Pointwise.Signed, Torch.Indef.Dynamic.Tensor.Math.Blas as Torch.Indef.Double.Dynamic.Tensor.Math.Blas, Torch.Indef.Dynamic.Tensor.Math.Lapack as Torch.Indef.Double.Dynamic.Tensor.Math.Lapack, Torch.Indef.Dynamic.Tensor.Math.Pointwise.Floating as Torch.Indef.Double.Dynamic.Tensor.Math.Pointwise.Floating, Torch.Indef.Dynamic.Tensor.Math.Reduce.Floating as Torch.Indef.Double.Dynamic.Tensor.Math.Reduce.Floating, Torch.Indef.Dynamic.Tensor.Math.Floating as Torch.Indef.Double.Dynamic.Tensor.Math.Floating, Torch.Indef.Static.Tensor.Math.Blas as Torch.Indef.Double.Tensor.Math.Blas, Torch.Indef.Static.Tensor.Math.Lapack as Torch.Indef.Double.Tensor.Math.Lapack, Torch.Indef.Static.Tensor.Math.Pointwise.Floating as Torch.Indef.Double.Tensor.Math.Pointwise.Floating, Torch.Indef.Static.Tensor.Math.Reduce.Floating as Torch.Indef.Double.Tensor.Math.Reduce.Floating, Torch.Indef.Static.Tensor.Math.Floating as Torch.Indef.Double.Tensor.Math.Floating, Torch.Indef.Static.Tensor.Random.TH as Torch.Indef.Double.Tensor.Random.TH, Torch.Indef.Static.Tensor.Math.Random.TH as Torch.Indef.Double.Tensor.Math.Random.TH, Torch.Indef.Dynamic.Tensor.Random.TH as Torch.Indef.Double.Dynamic.Tensor.Random.TH, Torch.Indef.Dynamic.Tensor.Math.Random.TH as Torch.Indef.Double.Dynamic.Tensor.Math.Random.TH, Torch.Undefined.Tensor.Random.THC as Torch.Undefined.Double.Tensor.Random.THC, Torch.Indef.Storage as Torch.Indef.Double.Storage, Torch.Indef.Storage.Copy as Torch.Indef.Double.Storage.Copy, Torch.Indef.Static.Tensor as Torch.Indef.Double.Tensor, Torch.Indef.Static.Tensor.Copy as Torch.Indef.Double.Tensor.Copy, Torch.Indef.Static.Tensor.Index as Torch.Indef.Double.Tensor.Index, Torch.Indef.Static.Tensor.Masked as Torch.Indef.Double.Tensor.Masked, Torch.Indef.Static.Tensor.Math as Torch.Indef.Double.Tensor.Math, Torch.Indef.Static.Tensor.Math.Compare as Torch.Indef.Double.Tensor.Math.Compare, Torch.Indef.Static.Tensor.Math.CompareT as Torch.Indef.Double.Tensor.Math.CompareT, Torch.Indef.Static.Tensor.Math.Pairwise as Torch.Indef.Double.Tensor.Math.Pairwise, Torch.Indef.Static.Tensor.Math.Pointwise as Torch.Indef.Double.Tensor.Math.Pointwise, Torch.Indef.Static.Tensor.Math.Reduce as Torch.Indef.Double.Tensor.Math.Reduce, Torch.Indef.Static.Tensor.Math.Scan as Torch.Indef.Double.Tensor.Math.Scan, Torch.Indef.Static.Tensor.Mode as Torch.Indef.Double.Tensor.Mode, Torch.Indef.Static.Tensor.ScatterGather as Torch.Indef.Double.Tensor.ScatterGather, Torch.Indef.Static.Tensor.Sort as Torch.Indef.Double.Tensor.Sort, Torch.Indef.Static.Tensor.TopK as Torch.Indef.Double.Tensor.TopK, Torch.Indef.Dynamic.Tensor as Torch.Indef.Double.Dynamic.Tensor, Torch.Indef.Dynamic.Tensor.Copy as Torch.Indef.Double.Dynamic.Tensor.Copy, Torch.Indef.Dynamic.Tensor.Index as Torch.Indef.Double.Dynamic.Tensor.Index, Torch.Indef.Dynamic.Tensor.Masked as Torch.Indef.Double.Dynamic.Tensor.Masked, Torch.Indef.Dynamic.Tensor.Math as Torch.Indef.Double.Dynamic.Tensor.Math, Torch.Indef.Dynamic.Tensor.Math.Compare as Torch.Indef.Double.Dynamic.Tensor.Math.Compare, Torch.Indef.Dynamic.Tensor.Math.CompareT as Torch.Indef.Double.Dynamic.Tensor.Math.CompareT, Torch.Indef.Dynamic.Tensor.Math.Pairwise as Torch.Indef.Double.Dynamic.Tensor.Math.Pairwise, Torch.Indef.Dynamic.Tensor.Math.Pointwise as Torch.Indef.Double.Dynamic.Tensor.Math.Pointwise, Torch.Indef.Dynamic.Tensor.Math.Reduce as Torch.Indef.Double.Dynamic.Tensor.Math.Reduce, Torch.Indef.Dynamic.Tensor.Math.Scan as Torch.Indef.Double.Dynamic.Tensor.Math.Scan, Torch.Indef.Dynamic.Tensor.Mode as Torch.Indef.Double.Dynamic.Tensor.Mode, Torch.Indef.Dynamic.Tensor.ScatterGather as Torch.Indef.Double.Dynamic.Tensor.ScatterGather, Torch.Indef.Dynamic.Tensor.Sort as Torch.Indef.Double.Dynamic.Tensor.Sort, Torch.Indef.Dynamic.Tensor.TopK as Torch.Indef.Double.Dynamic.Tensor.TopK, Torch.Indef.Types as Torch.Double.Types, Torch.Indef.Index as Torch.Double.Index, Torch.Indef.Mask as Torch.Double.Mask, Torch.Indef.Static.Tensor.Math.Pointwise.Signed as Torch.Indef.Double.Tensor.Math.Pointwise.Signed, Torch.Indef.Dynamic.Tensor.Math.Pointwise.Signed as Torch.Indef.Double.Dynamic.Tensor.Math.Pointwise.Signed, Torch.Indef.Dynamic.NN as Torch.Double.Dynamic.NN, Torch.Indef.Dynamic.NN.Activation as Torch.Double.Dynamic.NN.Activation, Torch.Indef.Dynamic.NN.Pooling as Torch.Double.Dynamic.NN.Pooling, Torch.Indef.Dynamic.NN.Criterion as Torch.Double.Dynamic.NN.Criterion, Torch.Indef.Static.NN as Torch.Double.NN, Torch.Indef.Static.NN as Torch.Double.NN, Torch.Indef.Static.NN.Activation as Torch.Double.NN.Activation, Torch.Indef.Static.NN.Backprop as Torch.Double.NN.Backprop, Torch.Indef.Static.NN.Conv1d as Torch.Double.NN.Conv1d, Torch.Indef.Static.NN.Conv2d as Torch.Double.NN.Conv2d, Torch.Indef.Static.NN.Criterion as Torch.Double.NN.Criterion, Torch.Indef.Static.NN.Layers as Torch.Double.NN.Layers, Torch.Indef.Static.NN.Linear as Torch.Double.NN.Linear, Torch.Indef.Static.NN.Math as Torch.Double.NN.Math, Torch.Indef.Static.NN.Padding as Torch.Double.NN.Padding, Torch.Indef.Static.NN.Pooling as Torch.Double.NN.Pooling, Torch.Indef.Static.NN.Sampling as Torch.Double.NN.Sampling) requires (Torch.Sig.Index.Tensor as Torch.FFI.TH.Long.Tensor, Torch.Sig.Index.TensorFree as Torch.FFI.TH.Long.FreeTensor, Torch.Sig.Mask.Tensor as Torch.FFI.TH.Byte.Tensor, Torch.Sig.Mask.TensorFree as Torch.FFI.TH.Byte.FreeTensor, Torch.Sig.Mask.MathReduce as Torch.FFI.TH.Byte.TensorMath, Torch.Sig.State as Torch.Types.TH, Torch.Sig.Types.Global as Torch.Types.TH, Torch.Sig.Types as Torch.Types.TH.Double, Torch.Sig.Storage as Torch.FFI.TH.Double.Storage, Torch.Sig.Storage.Copy as Torch.FFI.TH.Double.StorageCopy, Torch.Sig.Storage.Memory as Torch.FFI.TH.Double.FreeStorage, Torch.Sig.Tensor as Torch.FFI.TH.Double.Tensor, Torch.Sig.Tensor.Copy as Torch.FFI.TH.Double.TensorCopy, Torch.Sig.Tensor.Memory as Torch.FFI.TH.Double.FreeTensor, Torch.Sig.Tensor.Index as Torch.FFI.TH.Double.TensorMath, Torch.Sig.Tensor.Masked as Torch.FFI.TH.Double.TensorMath, Torch.Sig.Tensor.Math as Torch.FFI.TH.Double.TensorMath, Torch.Sig.Tensor.Math.Compare as Torch.FFI.TH.Double.TensorMath, Torch.Sig.Tensor.Math.CompareT as Torch.FFI.TH.Double.TensorMath, Torch.Sig.Tensor.Math.Pairwise as Torch.FFI.TH.Double.TensorMath, Torch.Sig.Tensor.Math.Pointwise as Torch.FFI.TH.Double.TensorMath, Torch.Sig.Tensor.Math.Reduce as Torch.FFI.TH.Double.TensorMath, Torch.Sig.Tensor.Math.Scan as Torch.FFI.TH.Double.TensorMath, Torch.Sig.Tensor.Mode as Torch.FFI.TH.Double.TensorMath, Torch.Sig.Tensor.ScatterGather as Torch.FFI.TH.Double.TensorMath, Torch.Sig.Tensor.Sort as Torch.FFI.TH.Double.TensorMath, Torch.Sig.Tensor.TopK as Torch.FFI.TH.Double.TensorMath, Torch.Sig.Tensor.Math.Pointwise.Signed as Torch.FFI.TH.Double.TensorMath, Torch.Sig.Tensor.Math.Pointwise.Floating as Torch.FFI.TH.Double.TensorMath, Torch.Sig.Tensor.Math.Reduce.Floating as Torch.FFI.TH.Double.TensorMath, Torch.Sig.Tensor.Math.Floating as Torch.FFI.TH.Double.TensorMath, Torch.Sig.Tensor.Math.Blas as Torch.FFI.TH.Double.TensorMath, Torch.Sig.Tensor.Math.Lapack as Torch.FFI.TH.Double.TensorLapack, Torch.Sig.NN as Torch.FFI.TH.NN.Double, Torch.Sig.Types.NN as Torch.Types.TH, Torch.Sig.Tensor.Math.Random.TH as Torch.FFI.TH.Double.TensorMath, Torch.Sig.Tensor.Random.TH as Torch.FFI.TH.Double.TensorRandom, Torch.Sig.Tensor.Random.THC as Torch.Undefined.Double.Tensor.Random.THC) + + if flag(lite) + + else + exposed-modules: + Torch.Byte + Torch.Byte.Dynamic + Torch.Byte.Storage + Torch.Char + Torch.Char.Dynamic + Torch.Char.Storage + Torch.Short + Torch.Short.Dynamic + Torch.Short.Storage + Torch.Int + Torch.Int.Dynamic + Torch.Int.Storage + Torch.Float + Torch.Float.Dynamic + Torch.Float.Storage + + build-depends: hasktorch-indef-unsigned + mixins: + hasktorch-indef-unsigned (Torch.Indef.Storage as Torch.Indef.Byte.Storage, Torch.Indef.Storage.Copy as Torch.Indef.Byte.Storage.Copy, Torch.Indef.Static.Tensor as Torch.Indef.Byte.Tensor, Torch.Indef.Static.Tensor.Copy as Torch.Indef.Byte.Tensor.Copy, Torch.Indef.Static.Tensor.Index as Torch.Indef.Byte.Tensor.Index, Torch.Indef.Static.Tensor.Masked as Torch.Indef.Byte.Tensor.Masked, Torch.Indef.Static.Tensor.Math as Torch.Indef.Byte.Tensor.Math, Torch.Indef.Static.Tensor.Math.Compare as Torch.Indef.Byte.Tensor.Math.Compare, Torch.Indef.Static.Tensor.Math.CompareT as Torch.Indef.Byte.Tensor.Math.CompareT, Torch.Indef.Static.Tensor.Math.Pairwise as Torch.Indef.Byte.Tensor.Math.Pairwise, Torch.Indef.Static.Tensor.Math.Pointwise as Torch.Indef.Byte.Tensor.Math.Pointwise, Torch.Indef.Static.Tensor.Math.Reduce as Torch.Indef.Byte.Tensor.Math.Reduce, Torch.Indef.Static.Tensor.Math.Scan as Torch.Indef.Byte.Tensor.Math.Scan, Torch.Indef.Static.Tensor.Mode as Torch.Indef.Byte.Tensor.Mode, Torch.Indef.Static.Tensor.ScatterGather as Torch.Indef.Byte.Tensor.ScatterGather, Torch.Indef.Static.Tensor.Sort as Torch.Indef.Byte.Tensor.Sort, Torch.Indef.Static.Tensor.TopK as Torch.Indef.Byte.Tensor.TopK, Torch.Indef.Dynamic.Tensor as Torch.Indef.Byte.Dynamic.Tensor, Torch.Indef.Dynamic.Tensor.Copy as Torch.Indef.Byte.Dynamic.Tensor.Copy, Torch.Indef.Dynamic.Tensor.Index as Torch.Indef.Byte.Dynamic.Tensor.Index, Torch.Indef.Dynamic.Tensor.Masked as Torch.Indef.Byte.Dynamic.Tensor.Masked, Torch.Indef.Dynamic.Tensor.Math as Torch.Indef.Byte.Dynamic.Tensor.Math, Torch.Indef.Dynamic.Tensor.Math.Compare as Torch.Indef.Byte.Dynamic.Tensor.Math.Compare, Torch.Indef.Dynamic.Tensor.Math.CompareT as Torch.Indef.Byte.Dynamic.Tensor.Math.CompareT, Torch.Indef.Dynamic.Tensor.Math.Pairwise as Torch.Indef.Byte.Dynamic.Tensor.Math.Pairwise, Torch.Indef.Dynamic.Tensor.Math.Pointwise as Torch.Indef.Byte.Dynamic.Tensor.Math.Pointwise, Torch.Indef.Dynamic.Tensor.Math.Reduce as Torch.Indef.Byte.Dynamic.Tensor.Math.Reduce, Torch.Indef.Dynamic.Tensor.Math.Scan as Torch.Indef.Byte.Dynamic.Tensor.Math.Scan, Torch.Indef.Dynamic.Tensor.Mode as Torch.Indef.Byte.Dynamic.Tensor.Mode, Torch.Indef.Dynamic.Tensor.ScatterGather as Torch.Indef.Byte.Dynamic.Tensor.ScatterGather, Torch.Indef.Dynamic.Tensor.Sort as Torch.Indef.Byte.Dynamic.Tensor.Sort, Torch.Indef.Dynamic.Tensor.TopK as Torch.Indef.Byte.Dynamic.Tensor.TopK, Torch.Indef.Types as Torch.Byte.Types, Torch.Indef.Index as Torch.Byte.Index, Torch.Indef.Mask as Torch.Byte.Mask) requires (Torch.Sig.Index.Tensor as Torch.FFI.TH.Long.Tensor, Torch.Sig.Index.TensorFree as Torch.FFI.TH.Long.FreeTensor, Torch.Sig.Mask.Tensor as Torch.FFI.TH.Byte.Tensor, Torch.Sig.Mask.TensorFree as Torch.FFI.TH.Byte.FreeTensor, Torch.Sig.Mask.MathReduce as Torch.FFI.TH.Byte.TensorMath, Torch.Sig.State as Torch.Types.TH, Torch.Sig.Types.Global as Torch.Types.TH, Torch.Sig.Types as Torch.Types.TH.Byte, Torch.Sig.Storage as Torch.FFI.TH.Byte.Storage, Torch.Sig.Storage.Copy as Torch.FFI.TH.Byte.StorageCopy, Torch.Sig.Storage.Memory as Torch.FFI.TH.Byte.FreeStorage, Torch.Sig.Tensor as Torch.FFI.TH.Byte.Tensor, Torch.Sig.Tensor.Copy as Torch.FFI.TH.Byte.TensorCopy, Torch.Sig.Tensor.Memory as Torch.FFI.TH.Byte.FreeTensor, Torch.Sig.Tensor.Index as Torch.FFI.TH.Byte.TensorMath, Torch.Sig.Tensor.Masked as Torch.FFI.TH.Byte.TensorMath, Torch.Sig.Tensor.Math as Torch.FFI.TH.Byte.TensorMath, Torch.Sig.Tensor.Math.Compare as Torch.FFI.TH.Byte.TensorMath, Torch.Sig.Tensor.Math.CompareT as Torch.FFI.TH.Byte.TensorMath, Torch.Sig.Tensor.Math.Pairwise as Torch.FFI.TH.Byte.TensorMath, Torch.Sig.Tensor.Math.Pointwise as Torch.FFI.TH.Byte.TensorMath, Torch.Sig.Tensor.Math.Reduce as Torch.FFI.TH.Byte.TensorMath, Torch.Sig.Tensor.Math.Scan as Torch.FFI.TH.Byte.TensorMath, Torch.Sig.Tensor.Mode as Torch.FFI.TH.Byte.TensorMath, Torch.Sig.Tensor.ScatterGather as Torch.FFI.TH.Byte.TensorMath, Torch.Sig.Tensor.Sort as Torch.FFI.TH.Byte.TensorMath, Torch.Sig.Tensor.TopK as Torch.FFI.TH.Byte.TensorMath), + hasktorch-indef-unsigned (Torch.Indef.Storage as Torch.Indef.Char.Storage, Torch.Indef.Storage.Copy as Torch.Indef.Char.Storage.Copy, Torch.Indef.Static.Tensor as Torch.Indef.Char.Tensor, Torch.Indef.Static.Tensor.Copy as Torch.Indef.Char.Tensor.Copy, Torch.Indef.Static.Tensor.Index as Torch.Indef.Char.Tensor.Index, Torch.Indef.Static.Tensor.Masked as Torch.Indef.Char.Tensor.Masked, Torch.Indef.Static.Tensor.Math as Torch.Indef.Char.Tensor.Math, Torch.Indef.Static.Tensor.Math.Compare as Torch.Indef.Char.Tensor.Math.Compare, Torch.Indef.Static.Tensor.Math.CompareT as Torch.Indef.Char.Tensor.Math.CompareT, Torch.Indef.Static.Tensor.Math.Pairwise as Torch.Indef.Char.Tensor.Math.Pairwise, Torch.Indef.Static.Tensor.Math.Pointwise as Torch.Indef.Char.Tensor.Math.Pointwise, Torch.Indef.Static.Tensor.Math.Reduce as Torch.Indef.Char.Tensor.Math.Reduce, Torch.Indef.Static.Tensor.Math.Scan as Torch.Indef.Char.Tensor.Math.Scan, Torch.Indef.Static.Tensor.Mode as Torch.Indef.Char.Tensor.Mode, Torch.Indef.Static.Tensor.ScatterGather as Torch.Indef.Char.Tensor.ScatterGather, Torch.Indef.Static.Tensor.Sort as Torch.Indef.Char.Tensor.Sort, Torch.Indef.Static.Tensor.TopK as Torch.Indef.Char.Tensor.TopK, Torch.Indef.Dynamic.Tensor as Torch.Indef.Char.Dynamic.Tensor, Torch.Indef.Dynamic.Tensor.Copy as Torch.Indef.Char.Dynamic.Tensor.Copy, Torch.Indef.Dynamic.Tensor.Index as Torch.Indef.Char.Dynamic.Tensor.Index, Torch.Indef.Dynamic.Tensor.Masked as Torch.Indef.Char.Dynamic.Tensor.Masked, Torch.Indef.Dynamic.Tensor.Math as Torch.Indef.Char.Dynamic.Tensor.Math, Torch.Indef.Dynamic.Tensor.Math.Compare as Torch.Indef.Char.Dynamic.Tensor.Math.Compare, Torch.Indef.Dynamic.Tensor.Math.CompareT as Torch.Indef.Char.Dynamic.Tensor.Math.CompareT, Torch.Indef.Dynamic.Tensor.Math.Pairwise as Torch.Indef.Char.Dynamic.Tensor.Math.Pairwise, Torch.Indef.Dynamic.Tensor.Math.Pointwise as Torch.Indef.Char.Dynamic.Tensor.Math.Pointwise, Torch.Indef.Dynamic.Tensor.Math.Reduce as Torch.Indef.Char.Dynamic.Tensor.Math.Reduce, Torch.Indef.Dynamic.Tensor.Math.Scan as Torch.Indef.Char.Dynamic.Tensor.Math.Scan, Torch.Indef.Dynamic.Tensor.Mode as Torch.Indef.Char.Dynamic.Tensor.Mode, Torch.Indef.Dynamic.Tensor.ScatterGather as Torch.Indef.Char.Dynamic.Tensor.ScatterGather, Torch.Indef.Dynamic.Tensor.Sort as Torch.Indef.Char.Dynamic.Tensor.Sort, Torch.Indef.Dynamic.Tensor.TopK as Torch.Indef.Char.Dynamic.Tensor.TopK, Torch.Indef.Types as Torch.Char.Types, Torch.Indef.Index as Torch.Char.Index, Torch.Indef.Mask as Torch.Char.Mask) requires (Torch.Sig.Index.Tensor as Torch.FFI.TH.Long.Tensor, Torch.Sig.Index.TensorFree as Torch.FFI.TH.Long.FreeTensor, Torch.Sig.Mask.Tensor as Torch.FFI.TH.Byte.Tensor, Torch.Sig.Mask.TensorFree as Torch.FFI.TH.Byte.FreeTensor, Torch.Sig.Mask.MathReduce as Torch.FFI.TH.Byte.TensorMath, Torch.Sig.State as Torch.Types.TH, Torch.Sig.Types.Global as Torch.Types.TH, Torch.Sig.Types as Torch.Types.TH.Char, Torch.Sig.Storage as Torch.FFI.TH.Char.Storage, Torch.Sig.Storage.Copy as Torch.FFI.TH.Char.StorageCopy, Torch.Sig.Storage.Memory as Torch.FFI.TH.Char.FreeStorage, Torch.Sig.Tensor as Torch.FFI.TH.Char.Tensor, Torch.Sig.Tensor.Copy as Torch.FFI.TH.Char.TensorCopy, Torch.Sig.Tensor.Memory as Torch.FFI.TH.Char.FreeTensor, Torch.Sig.Tensor.Index as Torch.FFI.TH.Char.TensorMath, Torch.Sig.Tensor.Masked as Torch.FFI.TH.Char.TensorMath, Torch.Sig.Tensor.Math as Torch.FFI.TH.Char.TensorMath, Torch.Sig.Tensor.Math.Compare as Torch.FFI.TH.Char.TensorMath, Torch.Sig.Tensor.Math.CompareT as Torch.FFI.TH.Char.TensorMath, Torch.Sig.Tensor.Math.Pairwise as Torch.FFI.TH.Char.TensorMath, Torch.Sig.Tensor.Math.Pointwise as Torch.FFI.TH.Char.TensorMath, Torch.Sig.Tensor.Math.Reduce as Torch.FFI.TH.Char.TensorMath, Torch.Sig.Tensor.Math.Scan as Torch.FFI.TH.Char.TensorMath, Torch.Sig.Tensor.Mode as Torch.FFI.TH.Char.TensorMath, Torch.Sig.Tensor.ScatterGather as Torch.FFI.TH.Char.TensorMath, Torch.Sig.Tensor.Sort as Torch.FFI.TH.Char.TensorMath, Torch.Sig.Tensor.TopK as Torch.FFI.TH.Char.TensorMath), + hasktorch-indef-signed (Torch.Indef.Storage as Torch.Indef.Short.Storage, Torch.Indef.Storage.Copy as Torch.Indef.Short.Storage.Copy, Torch.Indef.Static.Tensor as Torch.Indef.Short.Tensor, Torch.Indef.Static.Tensor.Copy as Torch.Indef.Short.Tensor.Copy, Torch.Indef.Static.Tensor.Index as Torch.Indef.Short.Tensor.Index, Torch.Indef.Static.Tensor.Masked as Torch.Indef.Short.Tensor.Masked, Torch.Indef.Static.Tensor.Math as Torch.Indef.Short.Tensor.Math, Torch.Indef.Static.Tensor.Math.Compare as Torch.Indef.Short.Tensor.Math.Compare, Torch.Indef.Static.Tensor.Math.CompareT as Torch.Indef.Short.Tensor.Math.CompareT, Torch.Indef.Static.Tensor.Math.Pairwise as Torch.Indef.Short.Tensor.Math.Pairwise, Torch.Indef.Static.Tensor.Math.Pointwise as Torch.Indef.Short.Tensor.Math.Pointwise, Torch.Indef.Static.Tensor.Math.Reduce as Torch.Indef.Short.Tensor.Math.Reduce, Torch.Indef.Static.Tensor.Math.Scan as Torch.Indef.Short.Tensor.Math.Scan, Torch.Indef.Static.Tensor.Mode as Torch.Indef.Short.Tensor.Mode, Torch.Indef.Static.Tensor.ScatterGather as Torch.Indef.Short.Tensor.ScatterGather, Torch.Indef.Static.Tensor.Sort as Torch.Indef.Short.Tensor.Sort, Torch.Indef.Static.Tensor.TopK as Torch.Indef.Short.Tensor.TopK, Torch.Indef.Dynamic.Tensor as Torch.Indef.Short.Dynamic.Tensor, Torch.Indef.Dynamic.Tensor.Copy as Torch.Indef.Short.Dynamic.Tensor.Copy, Torch.Indef.Dynamic.Tensor.Index as Torch.Indef.Short.Dynamic.Tensor.Index, Torch.Indef.Dynamic.Tensor.Masked as Torch.Indef.Short.Dynamic.Tensor.Masked, Torch.Indef.Dynamic.Tensor.Math as Torch.Indef.Short.Dynamic.Tensor.Math, Torch.Indef.Dynamic.Tensor.Math.Compare as Torch.Indef.Short.Dynamic.Tensor.Math.Compare, Torch.Indef.Dynamic.Tensor.Math.CompareT as Torch.Indef.Short.Dynamic.Tensor.Math.CompareT, Torch.Indef.Dynamic.Tensor.Math.Pairwise as Torch.Indef.Short.Dynamic.Tensor.Math.Pairwise, Torch.Indef.Dynamic.Tensor.Math.Pointwise as Torch.Indef.Short.Dynamic.Tensor.Math.Pointwise, Torch.Indef.Dynamic.Tensor.Math.Reduce as Torch.Indef.Short.Dynamic.Tensor.Math.Reduce, Torch.Indef.Dynamic.Tensor.Math.Scan as Torch.Indef.Short.Dynamic.Tensor.Math.Scan, Torch.Indef.Dynamic.Tensor.Mode as Torch.Indef.Short.Dynamic.Tensor.Mode, Torch.Indef.Dynamic.Tensor.ScatterGather as Torch.Indef.Short.Dynamic.Tensor.ScatterGather, Torch.Indef.Dynamic.Tensor.Sort as Torch.Indef.Short.Dynamic.Tensor.Sort, Torch.Indef.Dynamic.Tensor.TopK as Torch.Indef.Short.Dynamic.Tensor.TopK, Torch.Indef.Types as Torch.Short.Types, Torch.Indef.Index as Torch.Short.Index, Torch.Indef.Mask as Torch.Short.Mask, Torch.Indef.Static.Tensor.Math.Pointwise.Signed as Torch.Indef.Short.Tensor.Math.Pointwise.Signed, Torch.Indef.Dynamic.Tensor.Math.Pointwise.Signed as Torch.Indef.Short.Dynamic.Tensor.Math.Pointwise.Signed) requires (Torch.Sig.Index.Tensor as Torch.FFI.TH.Long.Tensor, Torch.Sig.Index.TensorFree as Torch.FFI.TH.Long.FreeTensor, Torch.Sig.Mask.Tensor as Torch.FFI.TH.Byte.Tensor, Torch.Sig.Mask.TensorFree as Torch.FFI.TH.Byte.FreeTensor, Torch.Sig.Mask.MathReduce as Torch.FFI.TH.Byte.TensorMath, Torch.Sig.State as Torch.Types.TH, Torch.Sig.Types.Global as Torch.Types.TH, Torch.Sig.Types as Torch.Types.TH.Short, Torch.Sig.Storage as Torch.FFI.TH.Short.Storage, Torch.Sig.Storage.Copy as Torch.FFI.TH.Short.StorageCopy, Torch.Sig.Storage.Memory as Torch.FFI.TH.Short.FreeStorage, Torch.Sig.Tensor as Torch.FFI.TH.Short.Tensor, Torch.Sig.Tensor.Copy as Torch.FFI.TH.Short.TensorCopy, Torch.Sig.Tensor.Memory as Torch.FFI.TH.Short.FreeTensor, Torch.Sig.Tensor.Index as Torch.FFI.TH.Short.TensorMath, Torch.Sig.Tensor.Masked as Torch.FFI.TH.Short.TensorMath, Torch.Sig.Tensor.Math as Torch.FFI.TH.Short.TensorMath, Torch.Sig.Tensor.Math.Compare as Torch.FFI.TH.Short.TensorMath, Torch.Sig.Tensor.Math.CompareT as Torch.FFI.TH.Short.TensorMath, Torch.Sig.Tensor.Math.Pairwise as Torch.FFI.TH.Short.TensorMath, Torch.Sig.Tensor.Math.Pointwise as Torch.FFI.TH.Short.TensorMath, Torch.Sig.Tensor.Math.Reduce as Torch.FFI.TH.Short.TensorMath, Torch.Sig.Tensor.Math.Scan as Torch.FFI.TH.Short.TensorMath, Torch.Sig.Tensor.Mode as Torch.FFI.TH.Short.TensorMath, Torch.Sig.Tensor.ScatterGather as Torch.FFI.TH.Short.TensorMath, Torch.Sig.Tensor.Sort as Torch.FFI.TH.Short.TensorMath, Torch.Sig.Tensor.TopK as Torch.FFI.TH.Short.TensorMath, Torch.Sig.Tensor.Math.Pointwise.Signed as Torch.FFI.TH.Short.TensorMath), + hasktorch-indef-signed (Torch.Indef.Storage as Torch.Indef.Int.Storage, Torch.Indef.Storage.Copy as Torch.Indef.Int.Storage.Copy, Torch.Indef.Static.Tensor as Torch.Indef.Int.Tensor, Torch.Indef.Static.Tensor.Copy as Torch.Indef.Int.Tensor.Copy, Torch.Indef.Static.Tensor.Index as Torch.Indef.Int.Tensor.Index, Torch.Indef.Static.Tensor.Masked as Torch.Indef.Int.Tensor.Masked, Torch.Indef.Static.Tensor.Math as Torch.Indef.Int.Tensor.Math, Torch.Indef.Static.Tensor.Math.Compare as Torch.Indef.Int.Tensor.Math.Compare, Torch.Indef.Static.Tensor.Math.CompareT as Torch.Indef.Int.Tensor.Math.CompareT, Torch.Indef.Static.Tensor.Math.Pairwise as Torch.Indef.Int.Tensor.Math.Pairwise, Torch.Indef.Static.Tensor.Math.Pointwise as Torch.Indef.Int.Tensor.Math.Pointwise, Torch.Indef.Static.Tensor.Math.Reduce as Torch.Indef.Int.Tensor.Math.Reduce, Torch.Indef.Static.Tensor.Math.Scan as Torch.Indef.Int.Tensor.Math.Scan, Torch.Indef.Static.Tensor.Mode as Torch.Indef.Int.Tensor.Mode, Torch.Indef.Static.Tensor.ScatterGather as Torch.Indef.Int.Tensor.ScatterGather, Torch.Indef.Static.Tensor.Sort as Torch.Indef.Int.Tensor.Sort, Torch.Indef.Static.Tensor.TopK as Torch.Indef.Int.Tensor.TopK, Torch.Indef.Dynamic.Tensor as Torch.Indef.Int.Dynamic.Tensor, Torch.Indef.Dynamic.Tensor.Copy as Torch.Indef.Int.Dynamic.Tensor.Copy, Torch.Indef.Dynamic.Tensor.Index as Torch.Indef.Int.Dynamic.Tensor.Index, Torch.Indef.Dynamic.Tensor.Masked as Torch.Indef.Int.Dynamic.Tensor.Masked, Torch.Indef.Dynamic.Tensor.Math as Torch.Indef.Int.Dynamic.Tensor.Math, Torch.Indef.Dynamic.Tensor.Math.Compare as Torch.Indef.Int.Dynamic.Tensor.Math.Compare, Torch.Indef.Dynamic.Tensor.Math.CompareT as Torch.Indef.Int.Dynamic.Tensor.Math.CompareT, Torch.Indef.Dynamic.Tensor.Math.Pairwise as Torch.Indef.Int.Dynamic.Tensor.Math.Pairwise, Torch.Indef.Dynamic.Tensor.Math.Pointwise as Torch.Indef.Int.Dynamic.Tensor.Math.Pointwise, Torch.Indef.Dynamic.Tensor.Math.Reduce as Torch.Indef.Int.Dynamic.Tensor.Math.Reduce, Torch.Indef.Dynamic.Tensor.Math.Scan as Torch.Indef.Int.Dynamic.Tensor.Math.Scan, Torch.Indef.Dynamic.Tensor.Mode as Torch.Indef.Int.Dynamic.Tensor.Mode, Torch.Indef.Dynamic.Tensor.ScatterGather as Torch.Indef.Int.Dynamic.Tensor.ScatterGather, Torch.Indef.Dynamic.Tensor.Sort as Torch.Indef.Int.Dynamic.Tensor.Sort, Torch.Indef.Dynamic.Tensor.TopK as Torch.Indef.Int.Dynamic.Tensor.TopK, Torch.Indef.Types as Torch.Int.Types, Torch.Indef.Index as Torch.Int.Index, Torch.Indef.Mask as Torch.Int.Mask, Torch.Indef.Static.Tensor.Math.Pointwise.Signed as Torch.Indef.Int.Tensor.Math.Pointwise.Signed, Torch.Indef.Dynamic.Tensor.Math.Pointwise.Signed as Torch.Indef.Int.Dynamic.Tensor.Math.Pointwise.Signed) requires (Torch.Sig.Index.Tensor as Torch.FFI.TH.Long.Tensor, Torch.Sig.Index.TensorFree as Torch.FFI.TH.Long.FreeTensor, Torch.Sig.Mask.Tensor as Torch.FFI.TH.Byte.Tensor, Torch.Sig.Mask.TensorFree as Torch.FFI.TH.Byte.FreeTensor, Torch.Sig.Mask.MathReduce as Torch.FFI.TH.Byte.TensorMath, Torch.Sig.State as Torch.Types.TH, Torch.Sig.Types.Global as Torch.Types.TH, Torch.Sig.Types as Torch.Types.TH.Int, Torch.Sig.Storage as Torch.FFI.TH.Int.Storage, Torch.Sig.Storage.Copy as Torch.FFI.TH.Int.StorageCopy, Torch.Sig.Storage.Memory as Torch.FFI.TH.Int.FreeStorage, Torch.Sig.Tensor as Torch.FFI.TH.Int.Tensor, Torch.Sig.Tensor.Copy as Torch.FFI.TH.Int.TensorCopy, Torch.Sig.Tensor.Memory as Torch.FFI.TH.Int.FreeTensor, Torch.Sig.Tensor.Index as Torch.FFI.TH.Int.TensorMath, Torch.Sig.Tensor.Masked as Torch.FFI.TH.Int.TensorMath, Torch.Sig.Tensor.Math as Torch.FFI.TH.Int.TensorMath, Torch.Sig.Tensor.Math.Compare as Torch.FFI.TH.Int.TensorMath, Torch.Sig.Tensor.Math.CompareT as Torch.FFI.TH.Int.TensorMath, Torch.Sig.Tensor.Math.Pairwise as Torch.FFI.TH.Int.TensorMath, Torch.Sig.Tensor.Math.Pointwise as Torch.FFI.TH.Int.TensorMath, Torch.Sig.Tensor.Math.Reduce as Torch.FFI.TH.Int.TensorMath, Torch.Sig.Tensor.Math.Scan as Torch.FFI.TH.Int.TensorMath, Torch.Sig.Tensor.Mode as Torch.FFI.TH.Int.TensorMath, Torch.Sig.Tensor.ScatterGather as Torch.FFI.TH.Int.TensorMath, Torch.Sig.Tensor.Sort as Torch.FFI.TH.Int.TensorMath, Torch.Sig.Tensor.TopK as Torch.FFI.TH.Int.TensorMath, Torch.Sig.Tensor.Math.Pointwise.Signed as Torch.FFI.TH.Int.TensorMath), + hasktorch-indef-floating (Torch.Indef.Storage as Torch.Indef.Float.Storage, Torch.Indef.Storage.Copy as Torch.Indef.Float.Storage.Copy, Torch.Indef.Static.Tensor as Torch.Indef.Float.Tensor, Torch.Indef.Static.Tensor.Copy as Torch.Indef.Float.Tensor.Copy, Torch.Indef.Static.Tensor.Index as Torch.Indef.Float.Tensor.Index, Torch.Indef.Static.Tensor.Masked as Torch.Indef.Float.Tensor.Masked, Torch.Indef.Static.Tensor.Math as Torch.Indef.Float.Tensor.Math, Torch.Indef.Static.Tensor.Math.Compare as Torch.Indef.Float.Tensor.Math.Compare, Torch.Indef.Static.Tensor.Math.CompareT as Torch.Indef.Float.Tensor.Math.CompareT, Torch.Indef.Static.Tensor.Math.Pairwise as Torch.Indef.Float.Tensor.Math.Pairwise, Torch.Indef.Static.Tensor.Math.Pointwise as Torch.Indef.Float.Tensor.Math.Pointwise, Torch.Indef.Static.Tensor.Math.Reduce as Torch.Indef.Float.Tensor.Math.Reduce, Torch.Indef.Static.Tensor.Math.Scan as Torch.Indef.Float.Tensor.Math.Scan, Torch.Indef.Static.Tensor.Mode as Torch.Indef.Float.Tensor.Mode, Torch.Indef.Static.Tensor.ScatterGather as Torch.Indef.Float.Tensor.ScatterGather, Torch.Indef.Static.Tensor.Sort as Torch.Indef.Float.Tensor.Sort, Torch.Indef.Static.Tensor.TopK as Torch.Indef.Float.Tensor.TopK, Torch.Indef.Dynamic.Tensor as Torch.Indef.Float.Dynamic.Tensor, Torch.Indef.Dynamic.Tensor.Copy as Torch.Indef.Float.Dynamic.Tensor.Copy, Torch.Indef.Dynamic.Tensor.Index as Torch.Indef.Float.Dynamic.Tensor.Index, Torch.Indef.Dynamic.Tensor.Masked as Torch.Indef.Float.Dynamic.Tensor.Masked, Torch.Indef.Dynamic.Tensor.Math as Torch.Indef.Float.Dynamic.Tensor.Math, Torch.Indef.Dynamic.Tensor.Math.Compare as Torch.Indef.Float.Dynamic.Tensor.Math.Compare, Torch.Indef.Dynamic.Tensor.Math.CompareT as Torch.Indef.Float.Dynamic.Tensor.Math.CompareT, Torch.Indef.Dynamic.Tensor.Math.Pairwise as Torch.Indef.Float.Dynamic.Tensor.Math.Pairwise, Torch.Indef.Dynamic.Tensor.Math.Pointwise as Torch.Indef.Float.Dynamic.Tensor.Math.Pointwise, Torch.Indef.Dynamic.Tensor.Math.Reduce as Torch.Indef.Float.Dynamic.Tensor.Math.Reduce, Torch.Indef.Dynamic.Tensor.Math.Scan as Torch.Indef.Float.Dynamic.Tensor.Math.Scan, Torch.Indef.Dynamic.Tensor.Mode as Torch.Indef.Float.Dynamic.Tensor.Mode, Torch.Indef.Dynamic.Tensor.ScatterGather as Torch.Indef.Float.Dynamic.Tensor.ScatterGather, Torch.Indef.Dynamic.Tensor.Sort as Torch.Indef.Float.Dynamic.Tensor.Sort, Torch.Indef.Dynamic.Tensor.TopK as Torch.Indef.Float.Dynamic.Tensor.TopK, Torch.Indef.Types as Torch.Float.Types, Torch.Indef.Index as Torch.Float.Index, Torch.Indef.Mask as Torch.Float.Mask, Torch.Indef.Static.Tensor.Math.Pointwise.Signed as Torch.Indef.Float.Tensor.Math.Pointwise.Signed, Torch.Indef.Dynamic.Tensor.Math.Pointwise.Signed as Torch.Indef.Float.Dynamic.Tensor.Math.Pointwise.Signed, Torch.Indef.Dynamic.Tensor.Math.Blas as Torch.Indef.Float.Dynamic.Tensor.Math.Blas, Torch.Indef.Dynamic.Tensor.Math.Lapack as Torch.Indef.Float.Dynamic.Tensor.Math.Lapack, Torch.Indef.Dynamic.Tensor.Math.Pointwise.Floating as Torch.Indef.Float.Dynamic.Tensor.Math.Pointwise.Floating, Torch.Indef.Dynamic.Tensor.Math.Reduce.Floating as Torch.Indef.Float.Dynamic.Tensor.Math.Reduce.Floating, Torch.Indef.Dynamic.Tensor.Math.Floating as Torch.Indef.Float.Dynamic.Tensor.Math.Floating, Torch.Indef.Static.Tensor.Math.Blas as Torch.Indef.Float.Tensor.Math.Blas, Torch.Indef.Static.Tensor.Math.Lapack as Torch.Indef.Float.Tensor.Math.Lapack, Torch.Indef.Static.Tensor.Math.Pointwise.Floating as Torch.Indef.Float.Tensor.Math.Pointwise.Floating, Torch.Indef.Static.Tensor.Math.Reduce.Floating as Torch.Indef.Float.Tensor.Math.Reduce.Floating, Torch.Indef.Static.Tensor.Math.Floating as Torch.Indef.Float.Tensor.Math.Floating, Torch.Indef.Static.Tensor.Random.TH as Torch.Indef.Float.Tensor.Random.TH, Torch.Indef.Static.Tensor.Math.Random.TH as Torch.Indef.Float.Tensor.Math.Random.TH, Torch.Indef.Dynamic.Tensor.Random.TH as Torch.Indef.Float.Dynamic.Tensor.Random.TH, Torch.Indef.Dynamic.Tensor.Math.Random.TH as Torch.Indef.Float.Dynamic.Tensor.Math.Random.TH, Torch.Undefined.Tensor.Random.THC as Torch.Undefined.Float.Tensor.Random.THC, Torch.Indef.Storage as Torch.Indef.Float.Storage, Torch.Indef.Storage.Copy as Torch.Indef.Float.Storage.Copy, Torch.Indef.Static.Tensor as Torch.Indef.Float.Tensor, Torch.Indef.Static.Tensor.Copy as Torch.Indef.Float.Tensor.Copy, Torch.Indef.Static.Tensor.Index as Torch.Indef.Float.Tensor.Index, Torch.Indef.Static.Tensor.Masked as Torch.Indef.Float.Tensor.Masked, Torch.Indef.Static.Tensor.Math as Torch.Indef.Float.Tensor.Math, Torch.Indef.Static.Tensor.Math.Compare as Torch.Indef.Float.Tensor.Math.Compare, Torch.Indef.Static.Tensor.Math.CompareT as Torch.Indef.Float.Tensor.Math.CompareT, Torch.Indef.Static.Tensor.Math.Pairwise as Torch.Indef.Float.Tensor.Math.Pairwise, Torch.Indef.Static.Tensor.Math.Pointwise as Torch.Indef.Float.Tensor.Math.Pointwise, Torch.Indef.Static.Tensor.Math.Reduce as Torch.Indef.Float.Tensor.Math.Reduce, Torch.Indef.Static.Tensor.Math.Scan as Torch.Indef.Float.Tensor.Math.Scan, Torch.Indef.Static.Tensor.Mode as Torch.Indef.Float.Tensor.Mode, Torch.Indef.Static.Tensor.ScatterGather as Torch.Indef.Float.Tensor.ScatterGather, Torch.Indef.Static.Tensor.Sort as Torch.Indef.Float.Tensor.Sort, Torch.Indef.Static.Tensor.TopK as Torch.Indef.Float.Tensor.TopK, Torch.Indef.Dynamic.Tensor as Torch.Indef.Float.Dynamic.Tensor, Torch.Indef.Dynamic.Tensor.Copy as Torch.Indef.Float.Dynamic.Tensor.Copy, Torch.Indef.Dynamic.Tensor.Index as Torch.Indef.Float.Dynamic.Tensor.Index, Torch.Indef.Dynamic.Tensor.Masked as Torch.Indef.Float.Dynamic.Tensor.Masked, Torch.Indef.Dynamic.Tensor.Math as Torch.Indef.Float.Dynamic.Tensor.Math, Torch.Indef.Dynamic.Tensor.Math.Compare as Torch.Indef.Float.Dynamic.Tensor.Math.Compare, Torch.Indef.Dynamic.Tensor.Math.CompareT as Torch.Indef.Float.Dynamic.Tensor.Math.CompareT, Torch.Indef.Dynamic.Tensor.Math.Pairwise as Torch.Indef.Float.Dynamic.Tensor.Math.Pairwise, Torch.Indef.Dynamic.Tensor.Math.Pointwise as Torch.Indef.Float.Dynamic.Tensor.Math.Pointwise, Torch.Indef.Dynamic.Tensor.Math.Reduce as Torch.Indef.Float.Dynamic.Tensor.Math.Reduce, Torch.Indef.Dynamic.Tensor.Math.Scan as Torch.Indef.Float.Dynamic.Tensor.Math.Scan, Torch.Indef.Dynamic.Tensor.Mode as Torch.Indef.Float.Dynamic.Tensor.Mode, Torch.Indef.Dynamic.Tensor.ScatterGather as Torch.Indef.Float.Dynamic.Tensor.ScatterGather, Torch.Indef.Dynamic.Tensor.Sort as Torch.Indef.Float.Dynamic.Tensor.Sort, Torch.Indef.Dynamic.Tensor.TopK as Torch.Indef.Float.Dynamic.Tensor.TopK, Torch.Indef.Types as Torch.Float.Types, Torch.Indef.Index as Torch.Float.Index, Torch.Indef.Mask as Torch.Float.Mask, Torch.Indef.Static.Tensor.Math.Pointwise.Signed as Torch.Indef.Float.Tensor.Math.Pointwise.Signed, Torch.Indef.Dynamic.Tensor.Math.Pointwise.Signed as Torch.Indef.Float.Dynamic.Tensor.Math.Pointwise.Signed, Torch.Indef.Dynamic.NN as Torch.Float.Dynamic.NN, Torch.Indef.Dynamic.NN.Activation as Torch.Float.Dynamic.NN.Activation, Torch.Indef.Dynamic.NN.Pooling as Torch.Float.Dynamic.NN.Pooling, Torch.Indef.Dynamic.NN.Criterion as Torch.Float.Dynamic.NN.Criterion, Torch.Indef.Static.NN as Torch.Float.NN, Torch.Indef.Static.NN as Torch.Float.NN, Torch.Indef.Static.NN.Activation as Torch.Float.NN.Activation, Torch.Indef.Static.NN.Backprop as Torch.Float.NN.Backprop, Torch.Indef.Static.NN.Conv1d as Torch.Float.NN.Conv1d, Torch.Indef.Static.NN.Conv2d as Torch.Float.NN.Conv2d, Torch.Indef.Static.NN.Criterion as Torch.Float.NN.Criterion, Torch.Indef.Static.NN.Layers as Torch.Float.NN.Layers, Torch.Indef.Static.NN.Linear as Torch.Float.NN.Linear, Torch.Indef.Static.NN.Math as Torch.Float.NN.Math, Torch.Indef.Static.NN.Padding as Torch.Float.NN.Padding, Torch.Indef.Static.NN.Pooling as Torch.Float.NN.Pooling, Torch.Indef.Static.NN.Sampling as Torch.Float.NN.Sampling) requires (Torch.Sig.Index.Tensor as Torch.FFI.TH.Long.Tensor, Torch.Sig.Index.TensorFree as Torch.FFI.TH.Long.FreeTensor, Torch.Sig.Mask.Tensor as Torch.FFI.TH.Byte.Tensor, Torch.Sig.Mask.TensorFree as Torch.FFI.TH.Byte.FreeTensor, Torch.Sig.Mask.MathReduce as Torch.FFI.TH.Byte.TensorMath, Torch.Sig.State as Torch.Types.TH, Torch.Sig.Types.Global as Torch.Types.TH, Torch.Sig.Types as Torch.Types.TH.Float, Torch.Sig.Storage as Torch.FFI.TH.Float.Storage, Torch.Sig.Storage.Copy as Torch.FFI.TH.Float.StorageCopy, Torch.Sig.Storage.Memory as Torch.FFI.TH.Float.FreeStorage, Torch.Sig.Tensor as Torch.FFI.TH.Float.Tensor, Torch.Sig.Tensor.Copy as Torch.FFI.TH.Float.TensorCopy, Torch.Sig.Tensor.Memory as Torch.FFI.TH.Float.FreeTensor, Torch.Sig.Tensor.Index as Torch.FFI.TH.Float.TensorMath, Torch.Sig.Tensor.Masked as Torch.FFI.TH.Float.TensorMath, Torch.Sig.Tensor.Math as Torch.FFI.TH.Float.TensorMath, Torch.Sig.Tensor.Math.Compare as Torch.FFI.TH.Float.TensorMath, Torch.Sig.Tensor.Math.CompareT as Torch.FFI.TH.Float.TensorMath, Torch.Sig.Tensor.Math.Pairwise as Torch.FFI.TH.Float.TensorMath, Torch.Sig.Tensor.Math.Pointwise as Torch.FFI.TH.Float.TensorMath, Torch.Sig.Tensor.Math.Reduce as Torch.FFI.TH.Float.TensorMath, Torch.Sig.Tensor.Math.Scan as Torch.FFI.TH.Float.TensorMath, Torch.Sig.Tensor.Mode as Torch.FFI.TH.Float.TensorMath, Torch.Sig.Tensor.ScatterGather as Torch.FFI.TH.Float.TensorMath, Torch.Sig.Tensor.Sort as Torch.FFI.TH.Float.TensorMath, Torch.Sig.Tensor.TopK as Torch.FFI.TH.Float.TensorMath, Torch.Sig.Tensor.Math.Pointwise.Signed as Torch.FFI.TH.Float.TensorMath, Torch.Sig.Tensor.Math.Pointwise.Floating as Torch.FFI.TH.Float.TensorMath, Torch.Sig.Tensor.Math.Reduce.Floating as Torch.FFI.TH.Float.TensorMath, Torch.Sig.Tensor.Math.Floating as Torch.FFI.TH.Float.TensorMath, Torch.Sig.Tensor.Math.Blas as Torch.FFI.TH.Float.TensorMath, Torch.Sig.Tensor.Math.Lapack as Torch.FFI.TH.Float.TensorLapack, Torch.Sig.NN as Torch.FFI.TH.NN.Float, Torch.Sig.Types.NN as Torch.Types.TH, Torch.Sig.Tensor.Math.Random.TH as Torch.FFI.TH.Float.TensorMath, Torch.Sig.Tensor.Random.TH as Torch.FFI.TH.Float.TensorRandom, Torch.Sig.Tensor.Random.THC as Torch.Undefined.Float.Tensor.Random.THC) + +library hasktorch-gpu + exposed-modules: + Torch.Cuda.Long + Torch.Cuda.Long.Dynamic + Torch.Cuda.Long.Storage + Torch.Cuda.Double + Torch.Cuda.Double.Dynamic + Torch.Cuda.Double.Storage + + reexported-modules: + Torch.Cuda.Double.NN, + Torch.Cuda.Double.NN.Activation, + Torch.Cuda.Double.NN.Backprop, + Torch.Cuda.Double.NN.Conv1d, + Torch.Cuda.Double.NN.Conv2d, + Torch.Cuda.Double.NN.Criterion, + Torch.Cuda.Double.NN.Layers, + Torch.Cuda.Double.NN.Linear, + Torch.Cuda.Double.NN.Math, + Torch.Cuda.Double.NN.Padding, + Torch.Cuda.Double.NN.Pooling, + Torch.Cuda.Double.NN.Sampling, + Torch.Cuda.Double.Dynamic.NN, + Torch.Cuda.Double.Dynamic.NN.Activation, + Torch.Cuda.Double.Dynamic.NN.Pooling, + Torch.Cuda.Double.Dynamic.NN.Criterion + + cpp-options: -DCUDA -DHASKTORCH_INTERNAL_CUDA + hs-source-dirs: utils src + other-modules: + Torch.Core.Exceptions + Torch.Core.Random + Torch.Core.LogAdd + + default-language: Haskell2010 + default-extensions: + LambdaCase DataKinds TypeFamilies TypeSynonymInstances + ScopedTypeVariables FlexibleContexts CPP + + build-depends: + base (==4.7 || >4.7) && <5, + hasktorch-types-th (==0.0.1 || >0.0.1) && <0.0.2, + dimensions ==1.0 || >1.0, + hasktorch-ffi-th (==0.0.1 || >0.0.1) && <0.0.2, + hasktorch-types-th (==0.0.1 || >0.0.1) && <0.0.2, + safe-exceptions ==0.1.0 || >0.1.0, + singletons ==2.2 || >2.2, + text ==1.2.2 || >1.2.2, + hasktorch-indef-floating, + hasktorch-indef-signed, + hasktorch-ffi-thc (==0.0.1 || >0.0.1) && <0.0.2, + hasktorch-types-thc (==0.0.1 || >0.0.1) && <0.0.2 + + mixins: + hasktorch-indef-signed (Torch.Indef.Storage as Torch.Indef.Cuda.Long.Storage, Torch.Indef.Storage.Copy as Torch.Indef.Cuda.Long.Storage.Copy, Torch.Indef.Static.Tensor as Torch.Indef.Cuda.Long.Tensor, Torch.Indef.Static.Tensor.Copy as Torch.Indef.Cuda.Long.Tensor.Copy, Torch.Indef.Static.Tensor.Index as Torch.Indef.Cuda.Long.Tensor.Index, Torch.Indef.Static.Tensor.Masked as Torch.Indef.Cuda.Long.Tensor.Masked, Torch.Indef.Static.Tensor.Math as Torch.Indef.Cuda.Long.Tensor.Math, Torch.Indef.Static.Tensor.Math.Compare as Torch.Indef.Cuda.Long.Tensor.Math.Compare, Torch.Indef.Static.Tensor.Math.CompareT as Torch.Indef.Cuda.Long.Tensor.Math.CompareT, Torch.Indef.Static.Tensor.Math.Pairwise as Torch.Indef.Cuda.Long.Tensor.Math.Pairwise, Torch.Indef.Static.Tensor.Math.Pointwise as Torch.Indef.Cuda.Long.Tensor.Math.Pointwise, Torch.Indef.Static.Tensor.Math.Reduce as Torch.Indef.Cuda.Long.Tensor.Math.Reduce, Torch.Indef.Static.Tensor.Math.Scan as Torch.Indef.Cuda.Long.Tensor.Math.Scan, Torch.Indef.Static.Tensor.Mode as Torch.Indef.Cuda.Long.Tensor.Mode, Torch.Indef.Static.Tensor.ScatterGather as Torch.Indef.Cuda.Long.Tensor.ScatterGather, Torch.Indef.Static.Tensor.Sort as Torch.Indef.Cuda.Long.Tensor.Sort, Torch.Indef.Static.Tensor.TopK as Torch.Indef.Cuda.Long.Tensor.TopK, Torch.Indef.Dynamic.Tensor as Torch.Indef.Cuda.Long.Dynamic.Tensor, Torch.Indef.Dynamic.Tensor.Copy as Torch.Indef.Cuda.Long.Dynamic.Tensor.Copy, Torch.Indef.Dynamic.Tensor.Index as Torch.Indef.Cuda.Long.Dynamic.Tensor.Index, Torch.Indef.Dynamic.Tensor.Masked as Torch.Indef.Cuda.Long.Dynamic.Tensor.Masked, Torch.Indef.Dynamic.Tensor.Math as Torch.Indef.Cuda.Long.Dynamic.Tensor.Math, Torch.Indef.Dynamic.Tensor.Math.Compare as Torch.Indef.Cuda.Long.Dynamic.Tensor.Math.Compare, Torch.Indef.Dynamic.Tensor.Math.CompareT as Torch.Indef.Cuda.Long.Dynamic.Tensor.Math.CompareT, Torch.Indef.Dynamic.Tensor.Math.Pairwise as Torch.Indef.Cuda.Long.Dynamic.Tensor.Math.Pairwise, Torch.Indef.Dynamic.Tensor.Math.Pointwise as Torch.Indef.Cuda.Long.Dynamic.Tensor.Math.Pointwise, Torch.Indef.Dynamic.Tensor.Math.Reduce as Torch.Indef.Cuda.Long.Dynamic.Tensor.Math.Reduce, Torch.Indef.Dynamic.Tensor.Math.Scan as Torch.Indef.Cuda.Long.Dynamic.Tensor.Math.Scan, Torch.Indef.Dynamic.Tensor.Mode as Torch.Indef.Cuda.Long.Dynamic.Tensor.Mode, Torch.Indef.Dynamic.Tensor.ScatterGather as Torch.Indef.Cuda.Long.Dynamic.Tensor.ScatterGather, Torch.Indef.Dynamic.Tensor.Sort as Torch.Indef.Cuda.Long.Dynamic.Tensor.Sort, Torch.Indef.Dynamic.Tensor.TopK as Torch.Indef.Cuda.Long.Dynamic.Tensor.TopK, Torch.Indef.Types as Torch.Cuda.Long.Types, Torch.Indef.Index as Torch.Cuda.Long.Index, Torch.Indef.Mask as Torch.Cuda.Long.Mask, Torch.Indef.Static.Tensor.Math.Pointwise.Signed as Torch.Indef.Cuda.Long.Tensor.Math.Pointwise.Signed, Torch.Indef.Dynamic.Tensor.Math.Pointwise.Signed as Torch.Indef.Cuda.Long.Dynamic.Tensor.Math.Pointwise.Signed) requires (Torch.Sig.Index.Tensor as Torch.FFI.THC.Long.Tensor, Torch.Sig.Index.TensorFree as Torch.FFI.THC.Long.Tensor, Torch.Sig.Mask.Tensor as Torch.FFI.THC.Byte.Tensor, Torch.Sig.Mask.TensorFree as Torch.FFI.THC.Byte.Tensor, Torch.Sig.Mask.MathReduce as Torch.FFI.THC.Byte.TensorMathReduce, Torch.Sig.State as Torch.FFI.THC.State, Torch.Sig.Types.Global as Torch.Types.THC, Torch.Sig.Types as Torch.Types.THC.Long, Torch.Sig.Storage as Torch.FFI.THC.Long.Storage, Torch.Sig.Storage.Copy as Torch.FFI.THC.Long.StorageCopy, Torch.Sig.Storage.Memory as Torch.FFI.THC.Long.Storage, Torch.Sig.Tensor as Torch.FFI.THC.Long.Tensor, Torch.Sig.Tensor.Copy as Torch.FFI.THC.Long.TensorCopy, Torch.Sig.Tensor.Memory as Torch.FFI.THC.Long.Tensor, Torch.Sig.Tensor.Index as Torch.FFI.THC.Long.TensorIndex, Torch.Sig.Tensor.Masked as Torch.FFI.THC.Long.TensorMasked, Torch.Sig.Tensor.Math as Torch.FFI.THC.Long.TensorMath, Torch.Sig.Tensor.Math.Compare as Torch.FFI.THC.Long.TensorMathCompare, Torch.Sig.Tensor.Math.CompareT as Torch.FFI.THC.Long.TensorMathCompareT, Torch.Sig.Tensor.Math.Pairwise as Torch.FFI.THC.Long.TensorMathPairwise, Torch.Sig.Tensor.Math.Pointwise as Torch.FFI.THC.Long.TensorMathPointwise, Torch.Sig.Tensor.Math.Reduce as Torch.FFI.THC.Long.TensorMathReduce, Torch.Sig.Tensor.Math.Scan as Torch.FFI.THC.Long.TensorMathScan, Torch.Sig.Tensor.Mode as Torch.FFI.THC.Long.TensorMode, Torch.Sig.Tensor.ScatterGather as Torch.FFI.THC.Long.TensorScatterGather, Torch.Sig.Tensor.Sort as Torch.FFI.THC.Long.TensorSort, Torch.Sig.Tensor.TopK as Torch.FFI.THC.Long.TensorTopK, Torch.Sig.Tensor.Math.Pointwise.Signed as Torch.FFI.THC.Long.TensorMathPointwise), + hasktorch-indef-floating (Torch.Indef.Storage as Torch.Indef.Cuda.Double.Storage, Torch.Indef.Storage.Copy as Torch.Indef.Cuda.Double.Storage.Copy, Torch.Indef.Static.Tensor as Torch.Indef.Cuda.Double.Tensor, Torch.Indef.Static.Tensor.Copy as Torch.Indef.Cuda.Double.Tensor.Copy, Torch.Indef.Static.Tensor.Index as Torch.Indef.Cuda.Double.Tensor.Index, Torch.Indef.Static.Tensor.Masked as Torch.Indef.Cuda.Double.Tensor.Masked, Torch.Indef.Static.Tensor.Math as Torch.Indef.Cuda.Double.Tensor.Math, Torch.Indef.Static.Tensor.Math.Compare as Torch.Indef.Cuda.Double.Tensor.Math.Compare, Torch.Indef.Static.Tensor.Math.CompareT as Torch.Indef.Cuda.Double.Tensor.Math.CompareT, Torch.Indef.Static.Tensor.Math.Pairwise as Torch.Indef.Cuda.Double.Tensor.Math.Pairwise, Torch.Indef.Static.Tensor.Math.Pointwise as Torch.Indef.Cuda.Double.Tensor.Math.Pointwise, Torch.Indef.Static.Tensor.Math.Reduce as Torch.Indef.Cuda.Double.Tensor.Math.Reduce, Torch.Indef.Static.Tensor.Math.Scan as Torch.Indef.Cuda.Double.Tensor.Math.Scan, Torch.Indef.Static.Tensor.Mode as Torch.Indef.Cuda.Double.Tensor.Mode, Torch.Indef.Static.Tensor.ScatterGather as Torch.Indef.Cuda.Double.Tensor.ScatterGather, Torch.Indef.Static.Tensor.Sort as Torch.Indef.Cuda.Double.Tensor.Sort, Torch.Indef.Static.Tensor.TopK as Torch.Indef.Cuda.Double.Tensor.TopK, Torch.Indef.Dynamic.Tensor as Torch.Indef.Cuda.Double.Dynamic.Tensor, Torch.Indef.Dynamic.Tensor.Copy as Torch.Indef.Cuda.Double.Dynamic.Tensor.Copy, Torch.Indef.Dynamic.Tensor.Index as Torch.Indef.Cuda.Double.Dynamic.Tensor.Index, Torch.Indef.Dynamic.Tensor.Masked as Torch.Indef.Cuda.Double.Dynamic.Tensor.Masked, Torch.Indef.Dynamic.Tensor.Math as Torch.Indef.Cuda.Double.Dynamic.Tensor.Math, Torch.Indef.Dynamic.Tensor.Math.Compare as Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.Compare, Torch.Indef.Dynamic.Tensor.Math.CompareT as Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.CompareT, Torch.Indef.Dynamic.Tensor.Math.Pairwise as Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.Pairwise, Torch.Indef.Dynamic.Tensor.Math.Pointwise as Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.Pointwise, Torch.Indef.Dynamic.Tensor.Math.Reduce as Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.Reduce, Torch.Indef.Dynamic.Tensor.Math.Scan as Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.Scan, Torch.Indef.Dynamic.Tensor.Mode as Torch.Indef.Cuda.Double.Dynamic.Tensor.Mode, Torch.Indef.Dynamic.Tensor.ScatterGather as Torch.Indef.Cuda.Double.Dynamic.Tensor.ScatterGather, Torch.Indef.Dynamic.Tensor.Sort as Torch.Indef.Cuda.Double.Dynamic.Tensor.Sort, Torch.Indef.Dynamic.Tensor.TopK as Torch.Indef.Cuda.Double.Dynamic.Tensor.TopK, Torch.Indef.Types as Torch.Cuda.Double.Types, Torch.Indef.Index as Torch.Cuda.Double.Index, Torch.Indef.Mask as Torch.Cuda.Double.Mask, Torch.Indef.Static.Tensor.Math.Pointwise.Signed as Torch.Indef.Cuda.Double.Tensor.Math.Pointwise.Signed, Torch.Indef.Dynamic.Tensor.Math.Pointwise.Signed as Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.Pointwise.Signed, Torch.Indef.Dynamic.Tensor.Math.Blas as Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.Blas, Torch.Indef.Dynamic.Tensor.Math.Lapack as Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.Lapack, Torch.Indef.Dynamic.Tensor.Math.Pointwise.Floating as Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.Pointwise.Floating, Torch.Indef.Dynamic.Tensor.Math.Reduce.Floating as Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.Reduce.Floating, Torch.Indef.Dynamic.Tensor.Math.Floating as Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.Floating, Torch.Indef.Static.Tensor.Math.Blas as Torch.Indef.Cuda.Double.Tensor.Math.Blas, Torch.Indef.Static.Tensor.Math.Lapack as Torch.Indef.Cuda.Double.Tensor.Math.Lapack, Torch.Indef.Static.Tensor.Math.Pointwise.Floating as Torch.Indef.Cuda.Double.Tensor.Math.Pointwise.Floating, Torch.Indef.Static.Tensor.Math.Reduce.Floating as Torch.Indef.Cuda.Double.Tensor.Math.Reduce.Floating, Torch.Indef.Static.Tensor.Math.Floating as Torch.Indef.Cuda.Double.Tensor.Math.Floating, Torch.Undefined.Tensor.Random.TH as Torch.Undefined.Cuda.Double.Tensor.Random.TH, Torch.Undefined.Tensor.Math.Random.TH as Torch.Undefined.Cuda.Double.Tensor.Math.Random.TH, Torch.Indef.Static.Tensor.Random.THC as Torch.Indef.Cuda.Double.Tensor.Random.THC, Torch.Indef.Dynamic.Tensor.Random.THC as Torch.Indef.Cuda.Double.Dynamic.Tensor.Random.THC, Torch.Indef.Storage as Torch.Indef.Cuda.Double.Storage, Torch.Indef.Storage.Copy as Torch.Indef.Cuda.Double.Storage.Copy, Torch.Indef.Static.Tensor as Torch.Indef.Cuda.Double.Tensor, Torch.Indef.Static.Tensor.Copy as Torch.Indef.Cuda.Double.Tensor.Copy, Torch.Indef.Static.Tensor.Index as Torch.Indef.Cuda.Double.Tensor.Index, Torch.Indef.Static.Tensor.Masked as Torch.Indef.Cuda.Double.Tensor.Masked, Torch.Indef.Static.Tensor.Math as Torch.Indef.Cuda.Double.Tensor.Math, Torch.Indef.Static.Tensor.Math.Compare as Torch.Indef.Cuda.Double.Tensor.Math.Compare, Torch.Indef.Static.Tensor.Math.CompareT as Torch.Indef.Cuda.Double.Tensor.Math.CompareT, Torch.Indef.Static.Tensor.Math.Pairwise as Torch.Indef.Cuda.Double.Tensor.Math.Pairwise, Torch.Indef.Static.Tensor.Math.Pointwise as Torch.Indef.Cuda.Double.Tensor.Math.Pointwise, Torch.Indef.Static.Tensor.Math.Reduce as Torch.Indef.Cuda.Double.Tensor.Math.Reduce, Torch.Indef.Static.Tensor.Math.Scan as Torch.Indef.Cuda.Double.Tensor.Math.Scan, Torch.Indef.Static.Tensor.Mode as Torch.Indef.Cuda.Double.Tensor.Mode, Torch.Indef.Static.Tensor.ScatterGather as Torch.Indef.Cuda.Double.Tensor.ScatterGather, Torch.Indef.Static.Tensor.Sort as Torch.Indef.Cuda.Double.Tensor.Sort, Torch.Indef.Static.Tensor.TopK as Torch.Indef.Cuda.Double.Tensor.TopK, Torch.Indef.Dynamic.Tensor as Torch.Indef.Cuda.Double.Dynamic.Tensor, Torch.Indef.Dynamic.Tensor.Copy as Torch.Indef.Cuda.Double.Dynamic.Tensor.Copy, Torch.Indef.Dynamic.Tensor.Index as Torch.Indef.Cuda.Double.Dynamic.Tensor.Index, Torch.Indef.Dynamic.Tensor.Masked as Torch.Indef.Cuda.Double.Dynamic.Tensor.Masked, Torch.Indef.Dynamic.Tensor.Math as Torch.Indef.Cuda.Double.Dynamic.Tensor.Math, Torch.Indef.Dynamic.Tensor.Math.Compare as Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.Compare, Torch.Indef.Dynamic.Tensor.Math.CompareT as Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.CompareT, Torch.Indef.Dynamic.Tensor.Math.Pairwise as Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.Pairwise, Torch.Indef.Dynamic.Tensor.Math.Pointwise as Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.Pointwise, Torch.Indef.Dynamic.Tensor.Math.Reduce as Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.Reduce, Torch.Indef.Dynamic.Tensor.Math.Scan as Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.Scan, Torch.Indef.Dynamic.Tensor.Mode as Torch.Indef.Cuda.Double.Dynamic.Tensor.Mode, Torch.Indef.Dynamic.Tensor.ScatterGather as Torch.Indef.Cuda.Double.Dynamic.Tensor.ScatterGather, Torch.Indef.Dynamic.Tensor.Sort as Torch.Indef.Cuda.Double.Dynamic.Tensor.Sort, Torch.Indef.Dynamic.Tensor.TopK as Torch.Indef.Cuda.Double.Dynamic.Tensor.TopK, Torch.Indef.Types as Torch.Cuda.Double.Types, Torch.Indef.Index as Torch.Cuda.Double.Index, Torch.Indef.Mask as Torch.Cuda.Double.Mask, Torch.Indef.Static.Tensor.Math.Pointwise.Signed as Torch.Indef.Cuda.Double.Tensor.Math.Pointwise.Signed, Torch.Indef.Dynamic.Tensor.Math.Pointwise.Signed as Torch.Indef.Cuda.Double.Dynamic.Tensor.Math.Pointwise.Signed, Torch.Indef.Dynamic.NN as Torch.Cuda.Double.Dynamic.NN, Torch.Indef.Dynamic.NN.Activation as Torch.Cuda.Double.Dynamic.NN.Activation, Torch.Indef.Dynamic.NN.Pooling as Torch.Cuda.Double.Dynamic.NN.Pooling, Torch.Indef.Dynamic.NN.Criterion as Torch.Cuda.Double.Dynamic.NN.Criterion, Torch.Indef.Static.NN as Torch.Cuda.Double.NN, Torch.Indef.Static.NN as Torch.Cuda.Double.NN, Torch.Indef.Static.NN.Activation as Torch.Cuda.Double.NN.Activation, Torch.Indef.Static.NN.Backprop as Torch.Cuda.Double.NN.Backprop, Torch.Indef.Static.NN.Conv1d as Torch.Cuda.Double.NN.Conv1d, Torch.Indef.Static.NN.Conv2d as Torch.Cuda.Double.NN.Conv2d, Torch.Indef.Static.NN.Criterion as Torch.Cuda.Double.NN.Criterion, Torch.Indef.Static.NN.Layers as Torch.Cuda.Double.NN.Layers, Torch.Indef.Static.NN.Linear as Torch.Cuda.Double.NN.Linear, Torch.Indef.Static.NN.Math as Torch.Cuda.Double.NN.Math, Torch.Indef.Static.NN.Padding as Torch.Cuda.Double.NN.Padding, Torch.Indef.Static.NN.Pooling as Torch.Cuda.Double.NN.Pooling, Torch.Indef.Static.NN.Sampling as Torch.Cuda.Double.NN.Sampling) requires (Torch.Sig.Index.Tensor as Torch.FFI.THC.Long.Tensor, Torch.Sig.Index.TensorFree as Torch.FFI.THC.Long.Tensor, Torch.Sig.Mask.Tensor as Torch.FFI.THC.Byte.Tensor, Torch.Sig.Mask.TensorFree as Torch.FFI.THC.Byte.Tensor, Torch.Sig.Mask.MathReduce as Torch.FFI.THC.Byte.TensorMathReduce, Torch.Sig.State as Torch.FFI.THC.State, Torch.Sig.Types.Global as Torch.Types.THC, Torch.Sig.Types as Torch.Types.THC.Double, Torch.Sig.Storage as Torch.FFI.THC.Double.Storage, Torch.Sig.Storage.Copy as Torch.FFI.THC.Double.StorageCopy, Torch.Sig.Storage.Memory as Torch.FFI.THC.Double.Storage, Torch.Sig.Tensor as Torch.FFI.THC.Double.Tensor, Torch.Sig.Tensor.Copy as Torch.FFI.THC.Double.TensorCopy, Torch.Sig.Tensor.Memory as Torch.FFI.THC.Double.Tensor, Torch.Sig.Tensor.Index as Torch.FFI.THC.Double.TensorIndex, Torch.Sig.Tensor.Masked as Torch.FFI.THC.Double.TensorMasked, Torch.Sig.Tensor.Math as Torch.FFI.THC.Double.TensorMath, Torch.Sig.Tensor.Math.Compare as Torch.FFI.THC.Double.TensorMathCompare, Torch.Sig.Tensor.Math.CompareT as Torch.FFI.THC.Double.TensorMathCompareT, Torch.Sig.Tensor.Math.Pairwise as Torch.FFI.THC.Double.TensorMathPairwise, Torch.Sig.Tensor.Math.Pointwise as Torch.FFI.THC.Double.TensorMathPointwise, Torch.Sig.Tensor.Math.Reduce as Torch.FFI.THC.Double.TensorMathReduce, Torch.Sig.Tensor.Math.Scan as Torch.FFI.THC.Double.TensorMathScan, Torch.Sig.Tensor.Mode as Torch.FFI.THC.Double.TensorMode, Torch.Sig.Tensor.ScatterGather as Torch.FFI.THC.Double.TensorScatterGather, Torch.Sig.Tensor.Sort as Torch.FFI.THC.Double.TensorSort, Torch.Sig.Tensor.TopK as Torch.FFI.THC.Double.TensorTopK, Torch.Sig.Tensor.Math.Pointwise.Signed as Torch.FFI.THC.Double.TensorMathPointwise, Torch.Sig.Tensor.Math.Pointwise.Floating as Torch.FFI.THC.Double.TensorMathPointwise, Torch.Sig.Tensor.Math.Reduce.Floating as Torch.FFI.THC.Double.TensorMathReduce, Torch.Sig.Tensor.Math.Floating as Torch.FFI.THC.Double.TensorMath, Torch.Sig.Tensor.Math.Blas as Torch.FFI.THC.Double.TensorMathBlas, Torch.Sig.Tensor.Math.Lapack as Torch.FFI.THC.Double.TensorMathMagma, Torch.Sig.NN as Torch.FFI.THC.NN.Double, Torch.Sig.Types.NN as Torch.Types.THC, Torch.Sig.Tensor.Math.Random.TH as Torch.Undefined.Cuda.Double.Tensor.Math.Random.TH, Torch.Sig.Tensor.Random.TH as Torch.Undefined.Cuda.Double.Tensor.Random.TH, Torch.Sig.Tensor.Random.THC as Torch.FFI.THC.Double.TensorRandom) + + if flag(lite) + + else + exposed-modules: + Torch.Cuda.Byte + Torch.Cuda.Byte.Dynamic + Torch.Cuda.Byte.Storage + Torch.Cuda.Char + Torch.Cuda.Char.Dynamic + Torch.Cuda.Char.Storage + Torch.Cuda.Short + Torch.Cuda.Short.Dynamic + Torch.Cuda.Short.Storage + Torch.Cuda.Int + Torch.Cuda.Int.Dynamic + Torch.Cuda.Int.Storage + + build-depends: hasktorch-indef-unsigned + mixins: + hasktorch-indef-unsigned (Torch.Indef.Storage as Torch.Indef.Cuda.Byte.Storage, Torch.Indef.Storage.Copy as Torch.Indef.Cuda.Byte.Storage.Copy, Torch.Indef.Static.Tensor as Torch.Indef.Cuda.Byte.Tensor, Torch.Indef.Static.Tensor.Copy as Torch.Indef.Cuda.Byte.Tensor.Copy, Torch.Indef.Static.Tensor.Index as Torch.Indef.Cuda.Byte.Tensor.Index, Torch.Indef.Static.Tensor.Masked as Torch.Indef.Cuda.Byte.Tensor.Masked, Torch.Indef.Static.Tensor.Math as Torch.Indef.Cuda.Byte.Tensor.Math, Torch.Indef.Static.Tensor.Math.Compare as Torch.Indef.Cuda.Byte.Tensor.Math.Compare, Torch.Indef.Static.Tensor.Math.CompareT as Torch.Indef.Cuda.Byte.Tensor.Math.CompareT, Torch.Indef.Static.Tensor.Math.Pairwise as Torch.Indef.Cuda.Byte.Tensor.Math.Pairwise, Torch.Indef.Static.Tensor.Math.Pointwise as Torch.Indef.Cuda.Byte.Tensor.Math.Pointwise, Torch.Indef.Static.Tensor.Math.Reduce as Torch.Indef.Cuda.Byte.Tensor.Math.Reduce, Torch.Indef.Static.Tensor.Math.Scan as Torch.Indef.Cuda.Byte.Tensor.Math.Scan, Torch.Indef.Static.Tensor.Mode as Torch.Indef.Cuda.Byte.Tensor.Mode, Torch.Indef.Static.Tensor.ScatterGather as Torch.Indef.Cuda.Byte.Tensor.ScatterGather, Torch.Indef.Static.Tensor.Sort as Torch.Indef.Cuda.Byte.Tensor.Sort, Torch.Indef.Static.Tensor.TopK as Torch.Indef.Cuda.Byte.Tensor.TopK, Torch.Indef.Dynamic.Tensor as Torch.Indef.Cuda.Byte.Dynamic.Tensor, Torch.Indef.Dynamic.Tensor.Copy as Torch.Indef.Cuda.Byte.Dynamic.Tensor.Copy, Torch.Indef.Dynamic.Tensor.Index as Torch.Indef.Cuda.Byte.Dynamic.Tensor.Index, Torch.Indef.Dynamic.Tensor.Masked as Torch.Indef.Cuda.Byte.Dynamic.Tensor.Masked, Torch.Indef.Dynamic.Tensor.Math as Torch.Indef.Cuda.Byte.Dynamic.Tensor.Math, Torch.Indef.Dynamic.Tensor.Math.Compare as Torch.Indef.Cuda.Byte.Dynamic.Tensor.Math.Compare, Torch.Indef.Dynamic.Tensor.Math.CompareT as Torch.Indef.Cuda.Byte.Dynamic.Tensor.Math.CompareT, Torch.Indef.Dynamic.Tensor.Math.Pairwise as Torch.Indef.Cuda.Byte.Dynamic.Tensor.Math.Pairwise, Torch.Indef.Dynamic.Tensor.Math.Pointwise as Torch.Indef.Cuda.Byte.Dynamic.Tensor.Math.Pointwise, Torch.Indef.Dynamic.Tensor.Math.Reduce as Torch.Indef.Cuda.Byte.Dynamic.Tensor.Math.Reduce, Torch.Indef.Dynamic.Tensor.Math.Scan as Torch.Indef.Cuda.Byte.Dynamic.Tensor.Math.Scan, Torch.Indef.Dynamic.Tensor.Mode as Torch.Indef.Cuda.Byte.Dynamic.Tensor.Mode, Torch.Indef.Dynamic.Tensor.ScatterGather as Torch.Indef.Cuda.Byte.Dynamic.Tensor.ScatterGather, Torch.Indef.Dynamic.Tensor.Sort as Torch.Indef.Cuda.Byte.Dynamic.Tensor.Sort, Torch.Indef.Dynamic.Tensor.TopK as Torch.Indef.Cuda.Byte.Dynamic.Tensor.TopK, Torch.Indef.Types as Torch.Cuda.Byte.Types, Torch.Indef.Index as Torch.Cuda.Byte.Index, Torch.Indef.Mask as Torch.Cuda.Byte.Mask) requires (Torch.Sig.Index.Tensor as Torch.FFI.THC.Long.Tensor, Torch.Sig.Index.TensorFree as Torch.FFI.THC.Long.Tensor, Torch.Sig.Mask.Tensor as Torch.FFI.THC.Byte.Tensor, Torch.Sig.Mask.TensorFree as Torch.FFI.THC.Byte.Tensor, Torch.Sig.Mask.MathReduce as Torch.FFI.THC.Byte.TensorMathReduce, Torch.Sig.State as Torch.FFI.THC.State, Torch.Sig.Types.Global as Torch.Types.THC, Torch.Sig.Types as Torch.Types.THC.Byte, Torch.Sig.Storage as Torch.FFI.THC.Byte.Storage, Torch.Sig.Storage.Copy as Torch.FFI.THC.Byte.StorageCopy, Torch.Sig.Storage.Memory as Torch.FFI.THC.Byte.Storage, Torch.Sig.Tensor as Torch.FFI.THC.Byte.Tensor, Torch.Sig.Tensor.Copy as Torch.FFI.THC.Byte.TensorCopy, Torch.Sig.Tensor.Memory as Torch.FFI.THC.Byte.Tensor, Torch.Sig.Tensor.Index as Torch.FFI.THC.Byte.TensorIndex, Torch.Sig.Tensor.Masked as Torch.FFI.THC.Byte.TensorMasked, Torch.Sig.Tensor.Math as Torch.FFI.THC.Byte.TensorMath, Torch.Sig.Tensor.Math.Compare as Torch.FFI.THC.Byte.TensorMathCompare, Torch.Sig.Tensor.Math.CompareT as Torch.FFI.THC.Byte.TensorMathCompareT, Torch.Sig.Tensor.Math.Pairwise as Torch.FFI.THC.Byte.TensorMathPairwise, Torch.Sig.Tensor.Math.Pointwise as Torch.FFI.THC.Byte.TensorMathPointwise, Torch.Sig.Tensor.Math.Reduce as Torch.FFI.THC.Byte.TensorMathReduce, Torch.Sig.Tensor.Math.Scan as Torch.FFI.THC.Byte.TensorMathScan, Torch.Sig.Tensor.Mode as Torch.FFI.THC.Byte.TensorMode, Torch.Sig.Tensor.ScatterGather as Torch.FFI.THC.Byte.TensorScatterGather, Torch.Sig.Tensor.Sort as Torch.FFI.THC.Byte.TensorSort, Torch.Sig.Tensor.TopK as Torch.FFI.THC.Byte.TensorTopK), + hasktorch-indef-unsigned (Torch.Indef.Storage as Torch.Indef.Cuda.Char.Storage, Torch.Indef.Storage.Copy as Torch.Indef.Cuda.Char.Storage.Copy, Torch.Indef.Static.Tensor as Torch.Indef.Cuda.Char.Tensor, Torch.Indef.Static.Tensor.Copy as Torch.Indef.Cuda.Char.Tensor.Copy, Torch.Indef.Static.Tensor.Index as Torch.Indef.Cuda.Char.Tensor.Index, Torch.Indef.Static.Tensor.Masked as Torch.Indef.Cuda.Char.Tensor.Masked, Torch.Indef.Static.Tensor.Math as Torch.Indef.Cuda.Char.Tensor.Math, Torch.Indef.Static.Tensor.Math.Compare as Torch.Indef.Cuda.Char.Tensor.Math.Compare, Torch.Indef.Static.Tensor.Math.CompareT as Torch.Indef.Cuda.Char.Tensor.Math.CompareT, Torch.Indef.Static.Tensor.Math.Pairwise as Torch.Indef.Cuda.Char.Tensor.Math.Pairwise, Torch.Indef.Static.Tensor.Math.Pointwise as Torch.Indef.Cuda.Char.Tensor.Math.Pointwise, Torch.Indef.Static.Tensor.Math.Reduce as Torch.Indef.Cuda.Char.Tensor.Math.Reduce, Torch.Indef.Static.Tensor.Math.Scan as Torch.Indef.Cuda.Char.Tensor.Math.Scan, Torch.Indef.Static.Tensor.Mode as Torch.Indef.Cuda.Char.Tensor.Mode, Torch.Indef.Static.Tensor.ScatterGather as Torch.Indef.Cuda.Char.Tensor.ScatterGather, Torch.Indef.Static.Tensor.Sort as Torch.Indef.Cuda.Char.Tensor.Sort, Torch.Indef.Static.Tensor.TopK as Torch.Indef.Cuda.Char.Tensor.TopK, Torch.Indef.Dynamic.Tensor as Torch.Indef.Cuda.Char.Dynamic.Tensor, Torch.Indef.Dynamic.Tensor.Copy as Torch.Indef.Cuda.Char.Dynamic.Tensor.Copy, Torch.Indef.Dynamic.Tensor.Index as Torch.Indef.Cuda.Char.Dynamic.Tensor.Index, Torch.Indef.Dynamic.Tensor.Masked as Torch.Indef.Cuda.Char.Dynamic.Tensor.Masked, Torch.Indef.Dynamic.Tensor.Math as Torch.Indef.Cuda.Char.Dynamic.Tensor.Math, Torch.Indef.Dynamic.Tensor.Math.Compare as Torch.Indef.Cuda.Char.Dynamic.Tensor.Math.Compare, Torch.Indef.Dynamic.Tensor.Math.CompareT as Torch.Indef.Cuda.Char.Dynamic.Tensor.Math.CompareT, Torch.Indef.Dynamic.Tensor.Math.Pairwise as Torch.Indef.Cuda.Char.Dynamic.Tensor.Math.Pairwise, Torch.Indef.Dynamic.Tensor.Math.Pointwise as Torch.Indef.Cuda.Char.Dynamic.Tensor.Math.Pointwise, Torch.Indef.Dynamic.Tensor.Math.Reduce as Torch.Indef.Cuda.Char.Dynamic.Tensor.Math.Reduce, Torch.Indef.Dynamic.Tensor.Math.Scan as Torch.Indef.Cuda.Char.Dynamic.Tensor.Math.Scan, Torch.Indef.Dynamic.Tensor.Mode as Torch.Indef.Cuda.Char.Dynamic.Tensor.Mode, Torch.Indef.Dynamic.Tensor.ScatterGather as Torch.Indef.Cuda.Char.Dynamic.Tensor.ScatterGather, Torch.Indef.Dynamic.Tensor.Sort as Torch.Indef.Cuda.Char.Dynamic.Tensor.Sort, Torch.Indef.Dynamic.Tensor.TopK as Torch.Indef.Cuda.Char.Dynamic.Tensor.TopK, Torch.Indef.Types as Torch.Cuda.Char.Types, Torch.Indef.Index as Torch.Cuda.Char.Index, Torch.Indef.Mask as Torch.Cuda.Char.Mask) requires (Torch.Sig.Index.Tensor as Torch.FFI.THC.Long.Tensor, Torch.Sig.Index.TensorFree as Torch.FFI.THC.Long.Tensor, Torch.Sig.Mask.Tensor as Torch.FFI.THC.Byte.Tensor, Torch.Sig.Mask.TensorFree as Torch.FFI.THC.Byte.Tensor, Torch.Sig.Mask.MathReduce as Torch.FFI.THC.Byte.TensorMathReduce, Torch.Sig.State as Torch.FFI.THC.State, Torch.Sig.Types.Global as Torch.Types.THC, Torch.Sig.Types as Torch.Types.THC.Char, Torch.Sig.Storage as Torch.FFI.THC.Char.Storage, Torch.Sig.Storage.Copy as Torch.FFI.THC.Char.StorageCopy, Torch.Sig.Storage.Memory as Torch.FFI.THC.Char.Storage, Torch.Sig.Tensor as Torch.FFI.THC.Char.Tensor, Torch.Sig.Tensor.Copy as Torch.FFI.THC.Char.TensorCopy, Torch.Sig.Tensor.Memory as Torch.FFI.THC.Char.Tensor, Torch.Sig.Tensor.Index as Torch.FFI.THC.Char.TensorIndex, Torch.Sig.Tensor.Masked as Torch.FFI.THC.Char.TensorMasked, Torch.Sig.Tensor.Math as Torch.FFI.THC.Char.TensorMath, Torch.Sig.Tensor.Math.Compare as Torch.FFI.THC.Char.TensorMathCompare, Torch.Sig.Tensor.Math.CompareT as Torch.FFI.THC.Char.TensorMathCompareT, Torch.Sig.Tensor.Math.Pairwise as Torch.FFI.THC.Char.TensorMathPairwise, Torch.Sig.Tensor.Math.Pointwise as Torch.FFI.THC.Char.TensorMathPointwise, Torch.Sig.Tensor.Math.Reduce as Torch.FFI.THC.Char.TensorMathReduce, Torch.Sig.Tensor.Math.Scan as Torch.FFI.THC.Char.TensorMathScan, Torch.Sig.Tensor.Mode as Torch.FFI.THC.Char.TensorMode, Torch.Sig.Tensor.ScatterGather as Torch.FFI.THC.Char.TensorScatterGather, Torch.Sig.Tensor.Sort as Torch.FFI.THC.Char.TensorSort, Torch.Sig.Tensor.TopK as Torch.FFI.THC.Char.TensorTopK), + hasktorch-indef-signed (Torch.Indef.Storage as Torch.Indef.Cuda.Short.Storage, Torch.Indef.Storage.Copy as Torch.Indef.Cuda.Short.Storage.Copy, Torch.Indef.Static.Tensor as Torch.Indef.Cuda.Short.Tensor, Torch.Indef.Static.Tensor.Copy as Torch.Indef.Cuda.Short.Tensor.Copy, Torch.Indef.Static.Tensor.Index as Torch.Indef.Cuda.Short.Tensor.Index, Torch.Indef.Static.Tensor.Masked as Torch.Indef.Cuda.Short.Tensor.Masked, Torch.Indef.Static.Tensor.Math as Torch.Indef.Cuda.Short.Tensor.Math, Torch.Indef.Static.Tensor.Math.Compare as Torch.Indef.Cuda.Short.Tensor.Math.Compare, Torch.Indef.Static.Tensor.Math.CompareT as Torch.Indef.Cuda.Short.Tensor.Math.CompareT, Torch.Indef.Static.Tensor.Math.Pairwise as Torch.Indef.Cuda.Short.Tensor.Math.Pairwise, Torch.Indef.Static.Tensor.Math.Pointwise as Torch.Indef.Cuda.Short.Tensor.Math.Pointwise, Torch.Indef.Static.Tensor.Math.Reduce as Torch.Indef.Cuda.Short.Tensor.Math.Reduce, Torch.Indef.Static.Tensor.Math.Scan as Torch.Indef.Cuda.Short.Tensor.Math.Scan, Torch.Indef.Static.Tensor.Mode as Torch.Indef.Cuda.Short.Tensor.Mode, Torch.Indef.Static.Tensor.ScatterGather as Torch.Indef.Cuda.Short.Tensor.ScatterGather, Torch.Indef.Static.Tensor.Sort as Torch.Indef.Cuda.Short.Tensor.Sort, Torch.Indef.Static.Tensor.TopK as Torch.Indef.Cuda.Short.Tensor.TopK, Torch.Indef.Dynamic.Tensor as Torch.Indef.Cuda.Short.Dynamic.Tensor, Torch.Indef.Dynamic.Tensor.Copy as Torch.Indef.Cuda.Short.Dynamic.Tensor.Copy, Torch.Indef.Dynamic.Tensor.Index as Torch.Indef.Cuda.Short.Dynamic.Tensor.Index, Torch.Indef.Dynamic.Tensor.Masked as Torch.Indef.Cuda.Short.Dynamic.Tensor.Masked, Torch.Indef.Dynamic.Tensor.Math as Torch.Indef.Cuda.Short.Dynamic.Tensor.Math, Torch.Indef.Dynamic.Tensor.Math.Compare as Torch.Indef.Cuda.Short.Dynamic.Tensor.Math.Compare, Torch.Indef.Dynamic.Tensor.Math.CompareT as Torch.Indef.Cuda.Short.Dynamic.Tensor.Math.CompareT, Torch.Indef.Dynamic.Tensor.Math.Pairwise as Torch.Indef.Cuda.Short.Dynamic.Tensor.Math.Pairwise, Torch.Indef.Dynamic.Tensor.Math.Pointwise as Torch.Indef.Cuda.Short.Dynamic.Tensor.Math.Pointwise, Torch.Indef.Dynamic.Tensor.Math.Reduce as Torch.Indef.Cuda.Short.Dynamic.Tensor.Math.Reduce, Torch.Indef.Dynamic.Tensor.Math.Scan as Torch.Indef.Cuda.Short.Dynamic.Tensor.Math.Scan, Torch.Indef.Dynamic.Tensor.Mode as Torch.Indef.Cuda.Short.Dynamic.Tensor.Mode, Torch.Indef.Dynamic.Tensor.ScatterGather as Torch.Indef.Cuda.Short.Dynamic.Tensor.ScatterGather, Torch.Indef.Dynamic.Tensor.Sort as Torch.Indef.Cuda.Short.Dynamic.Tensor.Sort, Torch.Indef.Dynamic.Tensor.TopK as Torch.Indef.Cuda.Short.Dynamic.Tensor.TopK, Torch.Indef.Types as Torch.Cuda.Short.Types, Torch.Indef.Index as Torch.Cuda.Short.Index, Torch.Indef.Mask as Torch.Cuda.Short.Mask, Torch.Indef.Static.Tensor.Math.Pointwise.Signed as Torch.Indef.Cuda.Short.Tensor.Math.Pointwise.Signed, Torch.Indef.Dynamic.Tensor.Math.Pointwise.Signed as Torch.Indef.Cuda.Short.Dynamic.Tensor.Math.Pointwise.Signed) requires (Torch.Sig.Index.Tensor as Torch.FFI.THC.Long.Tensor, Torch.Sig.Index.TensorFree as Torch.FFI.THC.Long.Tensor, Torch.Sig.Mask.Tensor as Torch.FFI.THC.Byte.Tensor, Torch.Sig.Mask.TensorFree as Torch.FFI.THC.Byte.Tensor, Torch.Sig.Mask.MathReduce as Torch.FFI.THC.Byte.TensorMathReduce, Torch.Sig.State as Torch.FFI.THC.State, Torch.Sig.Types.Global as Torch.Types.THC, Torch.Sig.Types as Torch.Types.THC.Short, Torch.Sig.Storage as Torch.FFI.THC.Short.Storage, Torch.Sig.Storage.Copy as Torch.FFI.THC.Short.StorageCopy, Torch.Sig.Storage.Memory as Torch.FFI.THC.Short.Storage, Torch.Sig.Tensor as Torch.FFI.THC.Short.Tensor, Torch.Sig.Tensor.Copy as Torch.FFI.THC.Short.TensorCopy, Torch.Sig.Tensor.Memory as Torch.FFI.THC.Short.Tensor, Torch.Sig.Tensor.Index as Torch.FFI.THC.Short.TensorIndex, Torch.Sig.Tensor.Masked as Torch.FFI.THC.Short.TensorMasked, Torch.Sig.Tensor.Math as Torch.FFI.THC.Short.TensorMath, Torch.Sig.Tensor.Math.Compare as Torch.FFI.THC.Short.TensorMathCompare, Torch.Sig.Tensor.Math.CompareT as Torch.FFI.THC.Short.TensorMathCompareT, Torch.Sig.Tensor.Math.Pairwise as Torch.FFI.THC.Short.TensorMathPairwise, Torch.Sig.Tensor.Math.Pointwise as Torch.FFI.THC.Short.TensorMathPointwise, Torch.Sig.Tensor.Math.Reduce as Torch.FFI.THC.Short.TensorMathReduce, Torch.Sig.Tensor.Math.Scan as Torch.FFI.THC.Short.TensorMathScan, Torch.Sig.Tensor.Mode as Torch.FFI.THC.Short.TensorMode, Torch.Sig.Tensor.ScatterGather as Torch.FFI.THC.Short.TensorScatterGather, Torch.Sig.Tensor.Sort as Torch.FFI.THC.Short.TensorSort, Torch.Sig.Tensor.TopK as Torch.FFI.THC.Short.TensorTopK, Torch.Sig.Tensor.Math.Pointwise.Signed as Torch.FFI.THC.Short.TensorMathPointwise), + hasktorch-indef-signed (Torch.Indef.Storage as Torch.Indef.Cuda.Int.Storage, Torch.Indef.Storage.Copy as Torch.Indef.Cuda.Int.Storage.Copy, Torch.Indef.Static.Tensor as Torch.Indef.Cuda.Int.Tensor, Torch.Indef.Static.Tensor.Copy as Torch.Indef.Cuda.Int.Tensor.Copy, Torch.Indef.Static.Tensor.Index as Torch.Indef.Cuda.Int.Tensor.Index, Torch.Indef.Static.Tensor.Masked as Torch.Indef.Cuda.Int.Tensor.Masked, Torch.Indef.Static.Tensor.Math as Torch.Indef.Cuda.Int.Tensor.Math, Torch.Indef.Static.Tensor.Math.Compare as Torch.Indef.Cuda.Int.Tensor.Math.Compare, Torch.Indef.Static.Tensor.Math.CompareT as Torch.Indef.Cuda.Int.Tensor.Math.CompareT, Torch.Indef.Static.Tensor.Math.Pairwise as Torch.Indef.Cuda.Int.Tensor.Math.Pairwise, Torch.Indef.Static.Tensor.Math.Pointwise as Torch.Indef.Cuda.Int.Tensor.Math.Pointwise, Torch.Indef.Static.Tensor.Math.Reduce as Torch.Indef.Cuda.Int.Tensor.Math.Reduce, Torch.Indef.Static.Tensor.Math.Scan as Torch.Indef.Cuda.Int.Tensor.Math.Scan, Torch.Indef.Static.Tensor.Mode as Torch.Indef.Cuda.Int.Tensor.Mode, Torch.Indef.Static.Tensor.ScatterGather as Torch.Indef.Cuda.Int.Tensor.ScatterGather, Torch.Indef.Static.Tensor.Sort as Torch.Indef.Cuda.Int.Tensor.Sort, Torch.Indef.Static.Tensor.TopK as Torch.Indef.Cuda.Int.Tensor.TopK, Torch.Indef.Dynamic.Tensor as Torch.Indef.Cuda.Int.Dynamic.Tensor, Torch.Indef.Dynamic.Tensor.Copy as Torch.Indef.Cuda.Int.Dynamic.Tensor.Copy, Torch.Indef.Dynamic.Tensor.Index as Torch.Indef.Cuda.Int.Dynamic.Tensor.Index, Torch.Indef.Dynamic.Tensor.Masked as Torch.Indef.Cuda.Int.Dynamic.Tensor.Masked, Torch.Indef.Dynamic.Tensor.Math as Torch.Indef.Cuda.Int.Dynamic.Tensor.Math, Torch.Indef.Dynamic.Tensor.Math.Compare as Torch.Indef.Cuda.Int.Dynamic.Tensor.Math.Compare, Torch.Indef.Dynamic.Tensor.Math.CompareT as Torch.Indef.Cuda.Int.Dynamic.Tensor.Math.CompareT, Torch.Indef.Dynamic.Tensor.Math.Pairwise as Torch.Indef.Cuda.Int.Dynamic.Tensor.Math.Pairwise, Torch.Indef.Dynamic.Tensor.Math.Pointwise as Torch.Indef.Cuda.Int.Dynamic.Tensor.Math.Pointwise, Torch.Indef.Dynamic.Tensor.Math.Reduce as Torch.Indef.Cuda.Int.Dynamic.Tensor.Math.Reduce, Torch.Indef.Dynamic.Tensor.Math.Scan as Torch.Indef.Cuda.Int.Dynamic.Tensor.Math.Scan, Torch.Indef.Dynamic.Tensor.Mode as Torch.Indef.Cuda.Int.Dynamic.Tensor.Mode, Torch.Indef.Dynamic.Tensor.ScatterGather as Torch.Indef.Cuda.Int.Dynamic.Tensor.ScatterGather, Torch.Indef.Dynamic.Tensor.Sort as Torch.Indef.Cuda.Int.Dynamic.Tensor.Sort, Torch.Indef.Dynamic.Tensor.TopK as Torch.Indef.Cuda.Int.Dynamic.Tensor.TopK, Torch.Indef.Types as Torch.Cuda.Int.Types, Torch.Indef.Index as Torch.Cuda.Int.Index, Torch.Indef.Mask as Torch.Cuda.Int.Mask, Torch.Indef.Static.Tensor.Math.Pointwise.Signed as Torch.Indef.Cuda.Int.Tensor.Math.Pointwise.Signed, Torch.Indef.Dynamic.Tensor.Math.Pointwise.Signed as Torch.Indef.Cuda.Int.Dynamic.Tensor.Math.Pointwise.Signed) requires (Torch.Sig.Index.Tensor as Torch.FFI.THC.Long.Tensor, Torch.Sig.Index.TensorFree as Torch.FFI.THC.Long.Tensor, Torch.Sig.Mask.Tensor as Torch.FFI.THC.Byte.Tensor, Torch.Sig.Mask.TensorFree as Torch.FFI.THC.Byte.Tensor, Torch.Sig.Mask.MathReduce as Torch.FFI.THC.Byte.TensorMathReduce, Torch.Sig.State as Torch.FFI.THC.State, Torch.Sig.Types.Global as Torch.Types.THC, Torch.Sig.Types as Torch.Types.THC.Int, Torch.Sig.Storage as Torch.FFI.THC.Int.Storage, Torch.Sig.Storage.Copy as Torch.FFI.THC.Int.StorageCopy, Torch.Sig.Storage.Memory as Torch.FFI.THC.Int.Storage, Torch.Sig.Tensor as Torch.FFI.THC.Int.Tensor, Torch.Sig.Tensor.Copy as Torch.FFI.THC.Int.TensorCopy, Torch.Sig.Tensor.Memory as Torch.FFI.THC.Int.Tensor, Torch.Sig.Tensor.Index as Torch.FFI.THC.Int.TensorIndex, Torch.Sig.Tensor.Masked as Torch.FFI.THC.Int.TensorMasked, Torch.Sig.Tensor.Math as Torch.FFI.THC.Int.TensorMath, Torch.Sig.Tensor.Math.Compare as Torch.FFI.THC.Int.TensorMathCompare, Torch.Sig.Tensor.Math.CompareT as Torch.FFI.THC.Int.TensorMathCompareT, Torch.Sig.Tensor.Math.Pairwise as Torch.FFI.THC.Int.TensorMathPairwise, Torch.Sig.Tensor.Math.Pointwise as Torch.FFI.THC.Int.TensorMathPointwise, Torch.Sig.Tensor.Math.Reduce as Torch.FFI.THC.Int.TensorMathReduce, Torch.Sig.Tensor.Math.Scan as Torch.FFI.THC.Int.TensorMathScan, Torch.Sig.Tensor.Mode as Torch.FFI.THC.Int.TensorMode, Torch.Sig.Tensor.ScatterGather as Torch.FFI.THC.Int.TensorScatterGather, Torch.Sig.Tensor.Sort as Torch.FFI.THC.Int.TensorSort, Torch.Sig.Tensor.TopK as Torch.FFI.THC.Int.TensorTopK, Torch.Sig.Tensor.Math.Pointwise.Signed as Torch.FFI.THC.Int.TensorMathPointwise) + +library hasktorch-indef-unsigned + reexported-modules: + Torch.Indef.Index, + Torch.Indef.Mask, + Torch.Indef.Types, + Torch.Indef.Storage, + Torch.Indef.Storage.Copy, + Torch.Indef.Dynamic.Print, + Torch.Indef.Dynamic.Tensor, + Torch.Indef.Dynamic.Tensor.Copy, + Torch.Indef.Dynamic.Tensor.Index, + Torch.Indef.Dynamic.Tensor.Masked, + Torch.Indef.Dynamic.Tensor.Math, + Torch.Indef.Dynamic.Tensor.Math.Compare, + Torch.Indef.Dynamic.Tensor.Math.CompareT, + Torch.Indef.Dynamic.Tensor.Math.Pairwise, + Torch.Indef.Dynamic.Tensor.Math.Pointwise, + Torch.Indef.Dynamic.Tensor.Math.Reduce, + Torch.Indef.Dynamic.Tensor.Math.Scan, + Torch.Indef.Dynamic.Tensor.Mode, + Torch.Indef.Dynamic.Tensor.ScatterGather, + Torch.Indef.Dynamic.Tensor.Sort, + Torch.Indef.Dynamic.Tensor.TopK, + Torch.Indef.Static.Tensor, + Torch.Indef.Static.Tensor.Copy, + Torch.Indef.Static.Tensor.Index, + Torch.Indef.Static.Tensor.Masked, + Torch.Indef.Static.Tensor.Math, + Torch.Indef.Static.Tensor.Math.Compare, + Torch.Indef.Static.Tensor.Math.CompareT, + Torch.Indef.Static.Tensor.Math.Pairwise, + Torch.Indef.Static.Tensor.Math.Pointwise, + Torch.Indef.Static.Tensor.Math.Reduce, + Torch.Indef.Static.Tensor.Math.Scan, + Torch.Indef.Static.Tensor.Mode, + Torch.Indef.Static.Tensor.ScatterGather, + Torch.Indef.Static.Tensor.Sort, + Torch.Indef.Static.Tensor.TopK + + default-language: Haskell2010 + build-depends: + base (==4.7 || >4.7) && <5, + hasktorch-signatures-partial (==0.0.1 || >0.0.1) && <0.0.2, + hasktorch-indef + + mixins: + hasktorch-indef requires (Torch.Sig.NN as Torch.Undefined.NN, Torch.Sig.Types.NN as Torch.Undefined.Types.NN, Torch.Sig.Tensor.Math.Blas as Torch.Undefined.Tensor.Math.Blas, Torch.Sig.Tensor.Math.Floating as Torch.Undefined.Tensor.Math.Floating, Torch.Sig.Tensor.Math.Lapack as Torch.Undefined.Tensor.Math.Lapack, Torch.Sig.Tensor.Math.Pointwise.Signed as Torch.Undefined.Tensor.Math.Pointwise.Signed, Torch.Sig.Tensor.Math.Pointwise.Floating as Torch.Undefined.Tensor.Math.Pointwise.Floating, Torch.Sig.Tensor.Math.Reduce.Floating as Torch.Undefined.Tensor.Math.Reduce.Floating, Torch.Sig.Tensor.Math.Random.TH as Torch.Undefined.Tensor.Math.Random.TH, Torch.Sig.Tensor.Random.TH as Torch.Undefined.Tensor.Random.TH, Torch.Sig.Tensor.Random.THC as Torch.Undefined.Tensor.Random.THC) + +library hasktorch-indef-signed + reexported-modules: + Torch.Indef.Index, + Torch.Indef.Mask, + Torch.Indef.Types, + Torch.Indef.Storage, + Torch.Indef.Storage.Copy, + Torch.Indef.Dynamic.Print, + Torch.Indef.Dynamic.Tensor, + Torch.Indef.Dynamic.Tensor.Copy, + Torch.Indef.Dynamic.Tensor.Index, + Torch.Indef.Dynamic.Tensor.Masked, + Torch.Indef.Dynamic.Tensor.Math, + Torch.Indef.Dynamic.Tensor.Math.Compare, + Torch.Indef.Dynamic.Tensor.Math.CompareT, + Torch.Indef.Dynamic.Tensor.Math.Pairwise, + Torch.Indef.Dynamic.Tensor.Math.Pointwise, + Torch.Indef.Dynamic.Tensor.Math.Reduce, + Torch.Indef.Dynamic.Tensor.Math.Scan, + Torch.Indef.Dynamic.Tensor.Mode, + Torch.Indef.Dynamic.Tensor.ScatterGather, + Torch.Indef.Dynamic.Tensor.Sort, + Torch.Indef.Dynamic.Tensor.TopK, + Torch.Indef.Static.Tensor, + Torch.Indef.Static.Tensor.Copy, + Torch.Indef.Static.Tensor.Index, + Torch.Indef.Static.Tensor.Masked, + Torch.Indef.Static.Tensor.Math, + Torch.Indef.Static.Tensor.Math.Compare, + Torch.Indef.Static.Tensor.Math.CompareT, + Torch.Indef.Static.Tensor.Math.Pairwise, + Torch.Indef.Static.Tensor.Math.Pointwise, + Torch.Indef.Static.Tensor.Math.Reduce, + Torch.Indef.Static.Tensor.Math.Scan, + Torch.Indef.Static.Tensor.Mode, + Torch.Indef.Static.Tensor.ScatterGather, + Torch.Indef.Static.Tensor.Sort, + Torch.Indef.Static.Tensor.TopK, + Torch.Indef.Static.Tensor.Math.Pointwise.Signed, + Torch.Indef.Dynamic.Tensor.Math.Pointwise.Signed + + default-language: Haskell2010 + build-depends: + base (==4.7 || >4.7) && <5, + hasktorch-signatures-partial (==0.0.1 || >0.0.1) && <0.0.2, + hasktorch-indef + + mixins: + hasktorch-indef requires (Torch.Sig.NN as Torch.Undefined.NN, Torch.Sig.Types.NN as Torch.Undefined.Types.NN, Torch.Sig.Tensor.Math.Blas as Torch.Undefined.Tensor.Math.Blas, Torch.Sig.Tensor.Math.Floating as Torch.Undefined.Tensor.Math.Floating, Torch.Sig.Tensor.Math.Lapack as Torch.Undefined.Tensor.Math.Lapack, Torch.Sig.Tensor.Math.Pointwise.Floating as Torch.Undefined.Tensor.Math.Pointwise.Floating, Torch.Sig.Tensor.Math.Reduce.Floating as Torch.Undefined.Tensor.Math.Reduce.Floating, Torch.Sig.Tensor.Math.Random.TH as Torch.Undefined.Tensor.Math.Random.TH, Torch.Sig.Tensor.Random.TH as Torch.Undefined.Tensor.Random.TH, Torch.Sig.Tensor.Random.THC as Torch.Undefined.Tensor.Random.THC) + +library hasktorch-indef-floating + reexported-modules: + Torch.Indef.Index, + Torch.Indef.Mask, + Torch.Indef.Types, + Torch.Indef.Storage, + Torch.Indef.Storage.Copy, + Torch.Indef.Dynamic.Print, + Torch.Indef.Dynamic.Tensor, + Torch.Indef.Dynamic.Tensor.Copy, + Torch.Indef.Dynamic.Tensor.Index, + Torch.Indef.Dynamic.Tensor.Masked, + Torch.Indef.Dynamic.Tensor.Math, + Torch.Indef.Dynamic.Tensor.Math.Compare, + Torch.Indef.Dynamic.Tensor.Math.CompareT, + Torch.Indef.Dynamic.Tensor.Math.Pairwise, + Torch.Indef.Dynamic.Tensor.Math.Pointwise, + Torch.Indef.Dynamic.Tensor.Math.Reduce, + Torch.Indef.Dynamic.Tensor.Math.Scan, + Torch.Indef.Dynamic.Tensor.Mode, + Torch.Indef.Dynamic.Tensor.ScatterGather, + Torch.Indef.Dynamic.Tensor.Sort, + Torch.Indef.Dynamic.Tensor.TopK, + Torch.Indef.Static.Tensor, + Torch.Indef.Static.Tensor.Copy, + Torch.Indef.Static.Tensor.Index, + Torch.Indef.Static.Tensor.Masked, + Torch.Indef.Static.Tensor.Math, + Torch.Indef.Static.Tensor.Math.Compare, + Torch.Indef.Static.Tensor.Math.CompareT, + Torch.Indef.Static.Tensor.Math.Pairwise, + Torch.Indef.Static.Tensor.Math.Pointwise, + Torch.Indef.Static.Tensor.Math.Reduce, + Torch.Indef.Static.Tensor.Math.Scan, + Torch.Indef.Static.Tensor.Mode, + Torch.Indef.Static.Tensor.ScatterGather, + Torch.Indef.Static.Tensor.Sort, + Torch.Indef.Static.Tensor.TopK, + Torch.Indef.Static.Tensor.Math.Pointwise.Signed, + Torch.Indef.Dynamic.Tensor.Math.Pointwise.Signed, + Torch.Indef.Dynamic.Tensor.Math.Blas, + Torch.Indef.Dynamic.Tensor.Math.Floating, + Torch.Indef.Dynamic.Tensor.Math.Lapack, + Torch.Indef.Dynamic.Tensor.Math.Pointwise.Floating, + Torch.Indef.Dynamic.Tensor.Math.Reduce.Floating, + Torch.Indef.Dynamic.Tensor.Random.TH, + Torch.Indef.Dynamic.Tensor.Random.THC, + Torch.Indef.Dynamic.Tensor.Math.Random.TH, + Torch.Indef.Static.Tensor.Math.Blas, + Torch.Indef.Static.Tensor.Math.Floating, + Torch.Indef.Static.Tensor.Math.Lapack, + Torch.Indef.Static.Tensor.Math.Pointwise.Floating, + Torch.Indef.Static.Tensor.Math.Reduce.Floating, + Torch.Indef.Static.Tensor.Random.TH, + Torch.Indef.Static.Tensor.Random.THC, + Torch.Indef.Static.Tensor.Math.Random.TH, + Torch.Indef.Dynamic.NN, + Torch.Indef.Dynamic.NN.Activation, + Torch.Indef.Dynamic.NN.Pooling, + Torch.Indef.Dynamic.NN.Criterion, + Torch.Indef.Static.NN, + Torch.Indef.Static.NN.Activation, + Torch.Indef.Static.NN.Backprop, + Torch.Indef.Static.NN.Conv1d, + Torch.Indef.Static.NN.Conv2d, + Torch.Indef.Static.NN.Criterion, + Torch.Indef.Static.NN.Layers, + Torch.Indef.Static.NN.Linear, + Torch.Indef.Static.NN.Math, + Torch.Indef.Static.NN.Padding, + Torch.Indef.Static.NN.Pooling, + Torch.Indef.Static.NN.Sampling, + Torch.Undefined.Tensor.Math.Random.TH, + Torch.Undefined.Tensor.Random.TH, + Torch.Undefined.Tensor.Random.THC + + default-language: Haskell2010 + build-depends: + base (==4.7 || >4.7) && <5, + hasktorch-indef, + hasktorch-signatures-partial (==0.0.1 || >0.0.1) && <0.0.2 + +executable isdefinite-cpu + main-is: Noop.hs + hs-source-dirs: exe + default-language: Haskell2010 + build-depends: + base (==4.7 || >4.7) && <5, + hasktorch-cpu + +executable isdefinite-gpu + main-is: Noop.hs + hs-source-dirs: exe + default-language: Haskell2010 + build-depends: + base (==4.7 || >4.7) && <5, + hasktorch-gpu + +executable isdefinite + main-is: Noop.hs + hs-source-dirs: exe + default-language: Haskell2010 + build-depends: + base (==4.7 || >4.7) && <5, + hasktorch + +executable memcheck + main-is: Memcheck.hs + hs-source-dirs: exe + default-language: Haskell2010 + build-depends: + base (==4.7 || >4.7) && <5, + hasktorch + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: tests + other-modules: + Orphans + MemorySpec + RawLapackSVDSpec + GarbageCollectionSpec + Torch.Prelude.Extras + Torch.Core.LogAddSpec + Torch.Core.RandomSpec + Torch.Static.NN.AbsSpec + Torch.Static.NN.LinearSpec + + default-language: Haskell2010 + default-extensions: + LambdaCase DataKinds TypeFamilies TypeSynonymInstances + ScopedTypeVariables FlexibleContexts CPP + + build-depends: + QuickCheck ==2.11 || >2.11, + backprop ==0.2.5 || >0.2.5, + base (==4.7 || >4.7) && <5, + dimensions ==1.0 || >1.0, + ghc-typelits-natnormalise, + hasktorch, + hspec ==2.4.4 || >2.4.4, + singletons ==2.2 || >2.2, + mtl ==2.2.2 || >2.2.2, + microlens-platform ==0.3.10 || >0.3.10, + monad-loops ==0.4.3 || >0.4.3, + time ==1.8.0 || >1.8.0, + transformers ==0.5.5 || >0.5.5, + generic-lens diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/hidden-main-lib.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/hidden-main-lib.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/hidden-main-lib.cabal @@ -0,0 +1,11 @@ +cabal-version: 3.0 +name: hidden-main-lib +version: 0 +synopsis: main lib have to be visible +build-type: Simple + +library + default-language: Haskell2010 + exposed-modules: ElseIf + build-depends: base + visibility: private diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/hidden-main-lib.expr b/cabal/Cabal-tests/tests/ParserTests/regressions/hidden-main-lib.expr new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/hidden-main-lib.expr @@ -0,0 +1,108 @@ +GenericPackageDescription + {condBenchmarks = [], + condExecutables = [], + condForeignLibs = [], + condLibrary = Just + CondNode + {condTreeComponents = [], + condTreeConstraints = [Dependency + (PackageName "base") + (OrLaterVersion (mkVersion [0])) + mainLibSet], + condTreeData = Library + {exposedModules = [ModuleName "ElseIf"], + libBuildInfo = BuildInfo + {asmOptions = [], + asmSources = [], + autogenIncludes = [], + autogenModules = [], + buildToolDepends = [], + buildTools = [], + buildable = True, + cSources = [], + ccOptions = [], + cmmOptions = [], + cmmSources = [], + cppOptions = [], + customFieldsBI = [], + cxxOptions = [], + cxxSources = [], + defaultExtensions = [], + defaultLanguage = Just Haskell2010, + extraBundledLibs = [], + extraDynLibFlavours = [], + extraFrameworkDirs = [], + extraGHCiLibs = [], + extraLibDirs = [], + extraLibDirsStatic = [], + extraLibFlavours = [], + extraLibs = [], + extraLibsStatic = [], + frameworks = [], + hsSourceDirs = [], + hsc2hsOptions = [], + includeDirs = [], + includes = [], + installIncludes = [], + jsSources = [], + ldOptions = [], + mixins = [], + oldExtensions = [], + options = PerCompilerFlavor [] [], + otherExtensions = [], + otherLanguages = [], + otherModules = [], + pkgconfigDepends = [], + profOptions = PerCompilerFlavor [] [], + sharedOptions = PerCompilerFlavor [] [], + staticOptions = PerCompilerFlavor [] [], + targetBuildDepends = [Dependency + (PackageName + "base") + (OrLaterVersion + (mkVersion + [0])) + mainLibSet], + virtualModules = []}, + libExposed = True, + libName = LMainLibName, + libVisibility = LibraryVisibilityPublic, + reexportedModules = [], + signatures = []}}, + condSubLibraries = [], + condTestSuites = [], + genPackageFlags = [], + gpdScannedVersion = Nothing, + packageDescription = PackageDescription + {author = "", + benchmarks = [], + bugReports = "", + buildTypeRaw = Just Simple, + category = "", + copyright = "", + customFieldsPD = [], + dataDir = ".", + dataFiles = [], + description = "", + executables = [], + extraDocFiles = [], + extraSrcFiles = [], + extraTmpFiles = [], + foreignLibs = [], + homepage = "", + library = Nothing, + licenseFiles = [], + licenseRaw = Left NONE, + maintainer = "", + package = PackageIdentifier + {pkgName = PackageName "hidden-main-lib", + pkgVersion = mkVersion [0]}, + pkgUrl = "", + setupBuildInfo = Nothing, + sourceRepos = [], + specVersion = CabalSpecV3_0, + stability = "", + subLibraries = [], + synopsis = "main lib have to be visible", + testSuites = [], + testedWith = []}} diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/hidden-main-lib.format b/cabal/Cabal-tests/tests/ParserTests/regressions/hidden-main-lib.format new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/hidden-main-lib.format @@ -0,0 +1,11 @@ +hidden-main-lib.cabal:11:3: Unknown field: "visibility" +cabal-version: 3.0 +name: hidden-main-lib +version: 0 +synopsis: main lib have to be visible +build-type: Simple + +library + exposed-modules: ElseIf + default-language: Haskell2010 + build-depends: base diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/indentation.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/indentation.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/indentation.cabal @@ -0,0 +1,18 @@ +cabal-version: 3.0 +name: indentation +version: 0 +description: + + * foo + + * foo-bar + + * foo-baz + + . + . + . + some dots + +library + default-language: Haskell2010 diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/indentation.expr b/cabal/Cabal-tests/tests/ParserTests/regressions/indentation.expr new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/indentation.expr @@ -0,0 +1,109 @@ +GenericPackageDescription + {condBenchmarks = [], + condExecutables = [], + condForeignLibs = [], + condLibrary = Just + CondNode + {condTreeComponents = [], + condTreeConstraints = [], + condTreeData = Library + {exposedModules = [], + libBuildInfo = BuildInfo + {asmOptions = [], + asmSources = [], + autogenIncludes = [], + autogenModules = [], + buildToolDepends = [], + buildTools = [], + buildable = True, + cSources = [], + ccOptions = [], + cmmOptions = [], + cmmSources = [], + cppOptions = [], + customFieldsBI = [], + cxxOptions = [], + cxxSources = [], + defaultExtensions = [], + defaultLanguage = Just Haskell2010, + extraBundledLibs = [], + extraDynLibFlavours = [], + extraFrameworkDirs = [], + extraGHCiLibs = [], + extraLibDirs = [], + extraLibDirsStatic = [], + extraLibFlavours = [], + extraLibs = [], + extraLibsStatic = [], + frameworks = [], + hsSourceDirs = [], + hsc2hsOptions = [], + includeDirs = [], + includes = [], + installIncludes = [], + jsSources = [], + ldOptions = [], + mixins = [], + oldExtensions = [], + options = PerCompilerFlavor [] [], + otherExtensions = [], + otherLanguages = [], + otherModules = [], + pkgconfigDepends = [], + profOptions = PerCompilerFlavor [] [], + sharedOptions = PerCompilerFlavor [] [], + staticOptions = PerCompilerFlavor [] [], + targetBuildDepends = [], + virtualModules = []}, + libExposed = True, + libName = LMainLibName, + libVisibility = LibraryVisibilityPublic, + reexportedModules = [], + signatures = []}}, + condSubLibraries = [], + condTestSuites = [], + genPackageFlags = [], + gpdScannedVersion = Nothing, + packageDescription = PackageDescription + {author = "", + benchmarks = [], + bugReports = "", + buildTypeRaw = Nothing, + category = "", + copyright = "", + customFieldsPD = [], + dataDir = ".", + dataFiles = [], + description = concat + ["* foo\n", + "\n", + " * foo-bar\n", + "\n", + " * foo-baz\n", + "\n", + ".\n", + ".\n", + ".\n", + "some dots"], + executables = [], + extraDocFiles = [], + extraSrcFiles = [], + extraTmpFiles = [], + foreignLibs = [], + homepage = "", + library = Nothing, + licenseFiles = [], + licenseRaw = Left NONE, + maintainer = "", + package = PackageIdentifier + {pkgName = PackageName "indentation", + pkgVersion = mkVersion [0]}, + pkgUrl = "", + setupBuildInfo = Nothing, + sourceRepos = [], + specVersion = CabalSpecV3_0, + stability = "", + subLibraries = [], + synopsis = "", + testSuites = [], + testedWith = []}} diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/indentation.format b/cabal/Cabal-tests/tests/ParserTests/regressions/indentation.format new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/indentation.format @@ -0,0 +1,17 @@ +cabal-version: 3.0 +name: indentation +version: 0 +description: + * foo + + * foo-bar + + * foo-baz + + . + . + . + some dots + +library + default-language: Haskell2010 diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/indentation2.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/indentation2.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/indentation2.cabal @@ -0,0 +1,9 @@ +cabal-version: 3.0 +name: indentation +version: 0 +description: foo + indent2 + indent4 + +library + default-language: Haskell2010 diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/indentation2.expr b/cabal/Cabal-tests/tests/ParserTests/regressions/indentation2.expr new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/indentation2.expr @@ -0,0 +1,99 @@ +GenericPackageDescription + {condBenchmarks = [], + condExecutables = [], + condForeignLibs = [], + condLibrary = Just + CondNode + {condTreeComponents = [], + condTreeConstraints = [], + condTreeData = Library + {exposedModules = [], + libBuildInfo = BuildInfo + {asmOptions = [], + asmSources = [], + autogenIncludes = [], + autogenModules = [], + buildToolDepends = [], + buildTools = [], + buildable = True, + cSources = [], + ccOptions = [], + cmmOptions = [], + cmmSources = [], + cppOptions = [], + customFieldsBI = [], + cxxOptions = [], + cxxSources = [], + defaultExtensions = [], + defaultLanguage = Just Haskell2010, + extraBundledLibs = [], + extraDynLibFlavours = [], + extraFrameworkDirs = [], + extraGHCiLibs = [], + extraLibDirs = [], + extraLibDirsStatic = [], + extraLibFlavours = [], + extraLibs = [], + extraLibsStatic = [], + frameworks = [], + hsSourceDirs = [], + hsc2hsOptions = [], + includeDirs = [], + includes = [], + installIncludes = [], + jsSources = [], + ldOptions = [], + mixins = [], + oldExtensions = [], + options = PerCompilerFlavor [] [], + otherExtensions = [], + otherLanguages = [], + otherModules = [], + pkgconfigDepends = [], + profOptions = PerCompilerFlavor [] [], + sharedOptions = PerCompilerFlavor [] [], + staticOptions = PerCompilerFlavor [] [], + targetBuildDepends = [], + virtualModules = []}, + libExposed = True, + libName = LMainLibName, + libVisibility = LibraryVisibilityPublic, + reexportedModules = [], + signatures = []}}, + condSubLibraries = [], + condTestSuites = [], + genPackageFlags = [], + gpdScannedVersion = Nothing, + packageDescription = PackageDescription + {author = "", + benchmarks = [], + bugReports = "", + buildTypeRaw = Nothing, + category = "", + copyright = "", + customFieldsPD = [], + dataDir = ".", + dataFiles = [], + description = concat ["foo\n", " indent2\n", " indent4"], + executables = [], + extraDocFiles = [], + extraSrcFiles = [], + extraTmpFiles = [], + foreignLibs = [], + homepage = "", + library = Nothing, + licenseFiles = [], + licenseRaw = Left NONE, + maintainer = "", + package = PackageIdentifier + {pkgName = PackageName "indentation", + pkgVersion = mkVersion [0]}, + pkgUrl = "", + setupBuildInfo = Nothing, + sourceRepos = [], + specVersion = CabalSpecV3_0, + stability = "", + subLibraries = [], + synopsis = "", + testSuites = [], + testedWith = []}} diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/indentation2.format b/cabal/Cabal-tests/tests/ParserTests/regressions/indentation2.format new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/indentation2.format @@ -0,0 +1,10 @@ +cabal-version: 3.0 +name: indentation +version: 0 +description: + foo + indent2 + indent4 + +library + default-language: Haskell2010 diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/indentation3.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/indentation3.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/indentation3.cabal @@ -0,0 +1,11 @@ +cabal-version: 3.0 +name: indentation +version: 0 +description: indent0 + + indent2 + indent0 + indent2 + +library + default-language: Haskell2010 diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/indentation3.expr b/cabal/Cabal-tests/tests/ParserTests/regressions/indentation3.expr new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/indentation3.expr @@ -0,0 +1,104 @@ +GenericPackageDescription + {condBenchmarks = [], + condExecutables = [], + condForeignLibs = [], + condLibrary = Just + CondNode + {condTreeComponents = [], + condTreeConstraints = [], + condTreeData = Library + {exposedModules = [], + libBuildInfo = BuildInfo + {asmOptions = [], + asmSources = [], + autogenIncludes = [], + autogenModules = [], + buildToolDepends = [], + buildTools = [], + buildable = True, + cSources = [], + ccOptions = [], + cmmOptions = [], + cmmSources = [], + cppOptions = [], + customFieldsBI = [], + cxxOptions = [], + cxxSources = [], + defaultExtensions = [], + defaultLanguage = Just Haskell2010, + extraBundledLibs = [], + extraDynLibFlavours = [], + extraFrameworkDirs = [], + extraGHCiLibs = [], + extraLibDirs = [], + extraLibDirsStatic = [], + extraLibFlavours = [], + extraLibs = [], + extraLibsStatic = [], + frameworks = [], + hsSourceDirs = [], + hsc2hsOptions = [], + includeDirs = [], + includes = [], + installIncludes = [], + jsSources = [], + ldOptions = [], + mixins = [], + oldExtensions = [], + options = PerCompilerFlavor [] [], + otherExtensions = [], + otherLanguages = [], + otherModules = [], + pkgconfigDepends = [], + profOptions = PerCompilerFlavor [] [], + sharedOptions = PerCompilerFlavor [] [], + staticOptions = PerCompilerFlavor [] [], + targetBuildDepends = [], + virtualModules = []}, + libExposed = True, + libName = LMainLibName, + libVisibility = LibraryVisibilityPublic, + reexportedModules = [], + signatures = []}}, + condSubLibraries = [], + condTestSuites = [], + genPackageFlags = [], + gpdScannedVersion = Nothing, + packageDescription = PackageDescription + {author = "", + benchmarks = [], + bugReports = "", + buildTypeRaw = Nothing, + category = "", + copyright = "", + customFieldsPD = [], + dataDir = ".", + dataFiles = [], + description = concat + ["indent0\n", + "\n", + " indent2\n", + "indent0\n", + " indent2"], + executables = [], + extraDocFiles = [], + extraSrcFiles = [], + extraTmpFiles = [], + foreignLibs = [], + homepage = "", + library = Nothing, + licenseFiles = [], + licenseRaw = Left NONE, + maintainer = "", + package = PackageIdentifier + {pkgName = PackageName "indentation", + pkgVersion = mkVersion [0]}, + pkgUrl = "", + setupBuildInfo = Nothing, + sourceRepos = [], + specVersion = CabalSpecV3_0, + stability = "", + subLibraries = [], + synopsis = "", + testSuites = [], + testedWith = []}} diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/indentation3.format b/cabal/Cabal-tests/tests/ParserTests/regressions/indentation3.format new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/indentation3.format @@ -0,0 +1,12 @@ +cabal-version: 3.0 +name: indentation +version: 0 +description: + indent0 + + indent2 + indent0 + indent2 + +library + default-language: Haskell2010 diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/issue-5055.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-5055.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-5055.cabal @@ -0,0 +1,25 @@ +name: issue +version: 5055 +synopsis: no type in all branches +description: no type in all branches. +license: BSD3 +category: Test +build-type: Simple +cabal-version: 2.0 + +executable flag-test-exe + main-is: FirstMain.hs + build-depends: base >= 4.8 && < 5 + default-language: Haskell2010 + +test-suite flag-cabal-test + -- TODO: fix so `type` can be on the top level + build-depends: base >= 4.8 && < 5 + default-language: Haskell2010 + + main-is: SecondMain.hs + type: exitcode-stdio-1.0 + + if os(windows) + main-is: FirstMain.hs + -- type: exitcode-stdio-1.0 diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/issue-5055.expr b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-5055.expr new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-5055.expr @@ -0,0 +1,278 @@ +GenericPackageDescription { + packageDescription = + PackageDescription { + specVersion = CabalSpecV2_0, + package = PackageIdentifier { + pkgName = PackageName "issue", + pkgVersion = mkVersion [5055]}, + licenseRaw = Right BSD3, + licenseFiles = [], + copyright = "", + maintainer = "", + author = "", + stability = "", + testedWith = [], + homepage = "", + pkgUrl = "", + bugReports = "", + sourceRepos = [], + synopsis = + "no type in all branches", + description = + "no type in all branches.", + category = "Test", + customFieldsPD = [], + buildTypeRaw = Just Simple, + setupBuildInfo = Nothing, + library = Nothing, + subLibraries = [], + executables = [], + foreignLibs = [], + testSuites = [], + benchmarks = [], + dataFiles = [], + dataDir = ".", + extraSrcFiles = [], + extraTmpFiles = [], + extraDocFiles = []}, + gpdScannedVersion = Nothing, + genPackageFlags = [], + condLibrary = Nothing, + condSubLibraries = [], + condForeignLibs = [], + condExecutables = [ + _×_ + (UnqualComponentName + "flag-test-exe") + CondNode { + condTreeData = Executable { + exeName = UnqualComponentName + "flag-test-exe", + modulePath = "FirstMain.hs", + exeScope = ExecutablePublic, + buildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Just + Haskell2010, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + Dependency + (PackageName "base") + (IntersectVersionRanges + (OrLaterVersion + (mkVersion [4, 8])) + (EarlierVersion + (mkVersion [5]))) + mainLibSet], + mixins = []}}, + condTreeConstraints = [ + Dependency + (PackageName "base") + (IntersectVersionRanges + (OrLaterVersion + (mkVersion [4, 8])) + (EarlierVersion + (mkVersion [5]))) + mainLibSet], + condTreeComponents = []}], + condTestSuites = [ + _×_ + (UnqualComponentName + "flag-cabal-test") + CondNode { + condTreeData = TestSuite { + testName = UnqualComponentName + "", + testInterface = TestSuiteExeV10 + (mkVersion [1, 0]) + "SecondMain.hs", + testBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Just + Haskell2010, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + Dependency + (PackageName "base") + (IntersectVersionRanges + (OrLaterVersion + (mkVersion [4, 8])) + (EarlierVersion + (mkVersion [5]))) + mainLibSet], + mixins = []}, + testCodeGenerators = []}, + condTreeConstraints = [ + Dependency + (PackageName "base") + (IntersectVersionRanges + (OrLaterVersion + (mkVersion [4, 8])) + (EarlierVersion + (mkVersion [5]))) + mainLibSet], + condTreeComponents = [ + CondBranch { + condBranchCondition = + `Var (OS Windows)`, + condBranchIfTrue = CondNode { + condTreeData = TestSuite { + testName = UnqualComponentName + "", + testInterface = + TestSuiteUnsupported + (TestTypeUnknown + "" + (mkVersion [])), + testBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [], + mixins = []}, + testCodeGenerators = []}, + condTreeConstraints = [], + condTreeComponents = []}, + condBranchIfFalse = Nothing}]}], + condBenchmarks = []} diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/issue-5055.format b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-5055.format new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-5055.format @@ -0,0 +1,21 @@ +cabal-version: 2.0 +name: issue +version: 5055 +license: BSD3 +synopsis: no type in all branches +description: no type in all branches. +category: Test +build-type: Simple + +executable flag-test-exe + main-is: FirstMain.hs + default-language: Haskell2010 + build-depends: base >=4.8 && <5 + +test-suite flag-cabal-test + type: exitcode-stdio-1.0 + main-is: SecondMain.hs + default-language: Haskell2010 + build-depends: base >=4.8 && <5 + + if os(windows) diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/issue-5846.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-5846.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-5846.cabal @@ -0,0 +1,11 @@ +cabal-version: 3.0 +name: issue +version: 5846 + +library + default-language: Haskell2010 + build-depends: lib1:{a,b} + , lib2:c + + build-depends: lib3:d>=1 + build-depends: lib4:{a,b}>=1 diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/issue-5846.expr b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-5846.expr new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-5846.expr @@ -0,0 +1,180 @@ +GenericPackageDescription { + packageDescription = + PackageDescription { + specVersion = CabalSpecV3_0, + package = PackageIdentifier { + pkgName = PackageName "issue", + pkgVersion = mkVersion [5846]}, + licenseRaw = Left NONE, + licenseFiles = [], + copyright = "", + maintainer = "", + author = "", + stability = "", + testedWith = [], + homepage = "", + pkgUrl = "", + bugReports = "", + sourceRepos = [], + synopsis = "", + description = "", + category = "", + customFieldsPD = [], + buildTypeRaw = Nothing, + setupBuildInfo = Nothing, + library = Nothing, + subLibraries = [], + executables = [], + foreignLibs = [], + testSuites = [], + benchmarks = [], + dataFiles = [], + dataDir = ".", + extraSrcFiles = [], + extraTmpFiles = [], + extraDocFiles = []}, + gpdScannedVersion = Nothing, + genPackageFlags = [], + condLibrary = Just + CondNode { + condTreeData = Library { + libName = LMainLibName, + exposedModules = [], + reexportedModules = [], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPublic, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Just + Haskell2010, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + 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")]))], + 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 = [], + condExecutables = [], + condTestSuites = [], + condBenchmarks = []} diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/issue-5846.format b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-5846.format new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-5846.format @@ -0,0 +1,11 @@ +cabal-version: 3.0 +name: issue +version: 5846 + +library + default-language: Haskell2010 + build-depends: + lib1:{a, b}, + lib2:c, + lib3:d >=1, + lib4:{a, b} >=1 diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6083-a.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6083-a.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6083-a.cabal @@ -0,0 +1,19 @@ +cabal-version: 3.4 +name: issue +version: 6083 + +library + default-language: Haskell2010 + -- This should be parsed as the main lib + build-depends: base, issue:sublib + +library sublib + default-language: Haskell2010 + +executable demo-a + main-is: Main.hs + build-depends: issue, sublib + +executable demo-b + main-is: Main.hs + build-depends: issue, issue:sublib diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6083-a.expr b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6083-a.expr new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6083-a.expr @@ -0,0 +1,370 @@ +GenericPackageDescription { + packageDescription = + PackageDescription { + specVersion = CabalSpecV3_4, + package = PackageIdentifier { + pkgName = PackageName "issue", + pkgVersion = mkVersion [6083]}, + licenseRaw = Left NONE, + licenseFiles = [], + copyright = "", + maintainer = "", + author = "", + stability = "", + testedWith = [], + homepage = "", + pkgUrl = "", + bugReports = "", + sourceRepos = [], + synopsis = "", + description = "", + category = "", + customFieldsPD = [], + buildTypeRaw = Nothing, + setupBuildInfo = Nothing, + library = Nothing, + subLibraries = [], + executables = [], + foreignLibs = [], + testSuites = [], + benchmarks = [], + dataFiles = [], + dataDir = ".", + extraSrcFiles = [], + extraTmpFiles = [], + extraDocFiles = []}, + gpdScannedVersion = Nothing, + genPackageFlags = [], + condLibrary = Just + CondNode { + condTreeData = Library { + libName = LMainLibName, + exposedModules = [], + reexportedModules = [], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPublic, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Just + Haskell2010, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + Dependency + (PackageName "base") + (OrLaterVersion (mkVersion [0])) + mainLibSet, + Dependency + (PackageName "issue") + (OrLaterVersion (mkVersion [0])) + (NonEmptySet.fromNonEmpty + (NE.fromList + [ + LSubLibName + (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 = [ + _×_ + (UnqualComponentName "sublib") + CondNode { + condTreeData = Library { + libName = LSubLibName + (UnqualComponentName "sublib"), + exposedModules = [], + reexportedModules = [], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPrivate, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Just + Haskell2010, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [], + mixins = []}}, + condTreeConstraints = [], + condTreeComponents = []}], + condForeignLibs = [], + condExecutables = [ + _×_ + (UnqualComponentName "demo-a") + CondNode { + condTreeData = Executable { + exeName = UnqualComponentName + "demo-a", + modulePath = "Main.hs", + exeScope = ExecutablePublic, + buildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + Dependency + (PackageName "issue") + (OrLaterVersion (mkVersion [0])) + mainLibSet, + Dependency + (PackageName "sublib") + (OrLaterVersion (mkVersion [0])) + mainLibSet], + mixins = []}}, + condTreeConstraints = [ + Dependency + (PackageName "issue") + (OrLaterVersion (mkVersion [0])) + mainLibSet, + Dependency + (PackageName "sublib") + (OrLaterVersion (mkVersion [0])) + mainLibSet], + condTreeComponents = []}, + _×_ + (UnqualComponentName "demo-b") + CondNode { + condTreeData = Executable { + exeName = UnqualComponentName + "demo-b", + modulePath = "Main.hs", + exeScope = ExecutablePublic, + buildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + Dependency + (PackageName "issue") + (OrLaterVersion (mkVersion [0])) + mainLibSet, + Dependency + (PackageName "issue") + (OrLaterVersion (mkVersion [0])) + (NonEmptySet.fromNonEmpty + (NE.fromList + [ + LSubLibName + (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/Cabal-tests/tests/ParserTests/regressions/issue-6083-a.format b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6083-a.format new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6083-a.format @@ -0,0 +1,24 @@ +cabal-version: 3.4 +name: issue +version: 6083 + +library + default-language: Haskell2010 + build-depends: + base, + issue:sublib + +library sublib + default-language: Haskell2010 + +executable demo-a + main-is: Main.hs + build-depends: + issue, + sublib + +executable demo-b + main-is: Main.hs + build-depends: + issue, + issue:sublib diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6083-b.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6083-b.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6083-b.cabal @@ -0,0 +1,19 @@ +cabal-version: 3.0 +name: issue +version: 6083 + +library + default-language: Haskell2010 + -- This should be parsed as the main lib + build-depends: base, sublib + +library sublib + default-language: Haskell2010 + +executable demo-a + main-is: Main.hs + build-depends: issue, sublib + +executable demo-b + main-is: Main.hs + build-depends: issue, issue:sublib diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6083-b.expr b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6083-b.expr new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6083-b.expr @@ -0,0 +1,380 @@ +GenericPackageDescription { + packageDescription = + PackageDescription { + specVersion = CabalSpecV3_0, + package = PackageIdentifier { + pkgName = PackageName "issue", + pkgVersion = mkVersion [6083]}, + licenseRaw = Left NONE, + licenseFiles = [], + copyright = "", + maintainer = "", + author = "", + stability = "", + testedWith = [], + homepage = "", + pkgUrl = "", + bugReports = "", + sourceRepos = [], + synopsis = "", + description = "", + category = "", + customFieldsPD = [], + buildTypeRaw = Nothing, + setupBuildInfo = Nothing, + library = Nothing, + subLibraries = [], + executables = [], + foreignLibs = [], + testSuites = [], + benchmarks = [], + dataFiles = [], + dataDir = ".", + extraSrcFiles = [], + extraTmpFiles = [], + extraDocFiles = []}, + gpdScannedVersion = Nothing, + genPackageFlags = [], + condLibrary = Just + CondNode { + condTreeData = Library { + libName = LMainLibName, + exposedModules = [], + reexportedModules = [], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPublic, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Just + Haskell2010, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + Dependency + (PackageName "base") + (OrLaterVersion (mkVersion [0])) + mainLibSet, + Dependency + (PackageName "issue") + (OrLaterVersion (mkVersion [0])) + (NonEmptySet.fromNonEmpty + (NE.fromList + [ + LSubLibName + (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 = [ + _×_ + (UnqualComponentName "sublib") + CondNode { + condTreeData = Library { + libName = LSubLibName + (UnqualComponentName "sublib"), + exposedModules = [], + reexportedModules = [], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPrivate, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Just + Haskell2010, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [], + mixins = []}}, + condTreeConstraints = [], + condTreeComponents = []}], + condForeignLibs = [], + condExecutables = [ + _×_ + (UnqualComponentName "demo-a") + CondNode { + condTreeData = Executable { + exeName = UnqualComponentName + "demo-a", + modulePath = "Main.hs", + exeScope = ExecutablePublic, + buildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + Dependency + (PackageName "issue") + (OrLaterVersion (mkVersion [0])) + mainLibSet, + Dependency + (PackageName "issue") + (OrLaterVersion (mkVersion [0])) + (NonEmptySet.fromNonEmpty + (NE.fromList + [ + LSubLibName + (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") + CondNode { + condTreeData = Executable { + exeName = UnqualComponentName + "demo-b", + modulePath = "Main.hs", + exeScope = ExecutablePublic, + buildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + Dependency + (PackageName "issue") + (OrLaterVersion (mkVersion [0])) + mainLibSet, + Dependency + (PackageName "issue") + (OrLaterVersion (mkVersion [0])) + (NonEmptySet.fromNonEmpty + (NE.fromList + [ + LSubLibName + (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/Cabal-tests/tests/ParserTests/regressions/issue-6083-b.format b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6083-b.format new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6083-b.format @@ -0,0 +1,24 @@ +cabal-version: 3.0 +name: issue +version: 6083 + +library + default-language: Haskell2010 + build-depends: + base, + sublib + +library sublib + default-language: Haskell2010 + +executable demo-a + main-is: Main.hs + build-depends: + issue, + sublib + +executable demo-b + main-is: Main.hs + build-depends: + issue, + sublib diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6083-c.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6083-c.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6083-c.cabal @@ -0,0 +1,11 @@ +cabal-version: 2.4 +name: issue +version: 6083 + +library + default-language: Haskell2010 + -- This should be parsed as the main lib + build-depends: base, sublib + +library sublib + default-language: Haskell2010 diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6083-c.expr b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6083-c.expr new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6083-c.expr @@ -0,0 +1,202 @@ +GenericPackageDescription { + packageDescription = + PackageDescription { + specVersion = CabalSpecV2_4, + package = PackageIdentifier { + pkgName = PackageName "issue", + pkgVersion = mkVersion [6083]}, + licenseRaw = Left NONE, + licenseFiles = [], + copyright = "", + maintainer = "", + author = "", + stability = "", + testedWith = [], + homepage = "", + pkgUrl = "", + bugReports = "", + sourceRepos = [], + synopsis = "", + description = "", + category = "", + customFieldsPD = [], + buildTypeRaw = Nothing, + setupBuildInfo = Nothing, + library = Nothing, + subLibraries = [], + executables = [], + foreignLibs = [], + testSuites = [], + benchmarks = [], + dataFiles = [], + dataDir = ".", + extraSrcFiles = [], + extraTmpFiles = [], + extraDocFiles = []}, + gpdScannedVersion = Nothing, + genPackageFlags = [], + condLibrary = Just + CondNode { + condTreeData = Library { + libName = LMainLibName, + exposedModules = [], + reexportedModules = [], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPublic, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Just + Haskell2010, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + Dependency + (PackageName "base") + (OrLaterVersion (mkVersion [0])) + mainLibSet, + Dependency + (PackageName "issue") + (OrLaterVersion (mkVersion [0])) + (NonEmptySet.fromNonEmpty + (NE.fromList + [ + LSubLibName + (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 = [ + _×_ + (UnqualComponentName "sublib") + CondNode { + condTreeData = Library { + libName = LSubLibName + (UnqualComponentName "sublib"), + exposedModules = [], + reexportedModules = [], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPrivate, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Just + Haskell2010, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [], + mixins = []}}, + condTreeConstraints = [], + condTreeComponents = []}], + condForeignLibs = [], + condExecutables = [], + condTestSuites = [], + condBenchmarks = []} diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6083-c.format b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6083-c.format new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6083-c.format @@ -0,0 +1,12 @@ +cabal-version: 2.4 +name: issue +version: 6083 + +library + default-language: Haskell2010 + build-depends: + base, + sublib + +library sublib + default-language: Haskell2010 diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6083-pkg-pkg.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6083-pkg-pkg.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6083-pkg-pkg.cabal @@ -0,0 +1,9 @@ +cabal-version: 3.0 +name: issue +version: 6083 + +library + default-language: Haskell2010 + -- This should be parsed as the main lib + build-depends: freetype + build-depends: freetype:freetype diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6083-pkg-pkg.expr b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6083-pkg-pkg.expr new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6083-pkg-pkg.expr @@ -0,0 +1,124 @@ +GenericPackageDescription { + packageDescription = + PackageDescription { + specVersion = CabalSpecV3_0, + package = PackageIdentifier { + pkgName = PackageName "issue", + pkgVersion = mkVersion [6083]}, + licenseRaw = Left NONE, + licenseFiles = [], + copyright = "", + maintainer = "", + author = "", + stability = "", + testedWith = [], + homepage = "", + pkgUrl = "", + bugReports = "", + sourceRepos = [], + synopsis = "", + description = "", + category = "", + customFieldsPD = [], + buildTypeRaw = Nothing, + setupBuildInfo = Nothing, + library = Nothing, + subLibraries = [], + executables = [], + foreignLibs = [], + testSuites = [], + benchmarks = [], + dataFiles = [], + dataDir = ".", + extraSrcFiles = [], + extraTmpFiles = [], + extraDocFiles = []}, + gpdScannedVersion = Nothing, + genPackageFlags = [], + condLibrary = Just + CondNode { + condTreeData = Library { + libName = LMainLibName, + exposedModules = [], + reexportedModules = [], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPublic, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Just + Haskell2010, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + Dependency + (PackageName "freetype") + (OrLaterVersion (mkVersion [0])) + mainLibSet, + Dependency + (PackageName "freetype") + (OrLaterVersion (mkVersion [0])) + mainLibSet], + mixins = []}}, + condTreeConstraints = [ + Dependency + (PackageName "freetype") + (OrLaterVersion (mkVersion [0])) + mainLibSet, + Dependency + (PackageName "freetype") + (OrLaterVersion (mkVersion [0])) + mainLibSet], + condTreeComponents = []}, + condSubLibraries = [], + condForeignLibs = [], + condExecutables = [], + condTestSuites = [], + condBenchmarks = []} diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6083-pkg-pkg.format b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6083-pkg-pkg.format new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6083-pkg-pkg.format @@ -0,0 +1,9 @@ +cabal-version: 3.0 +name: issue +version: 6083 + +library + default-language: Haskell2010 + build-depends: + freetype, + freetype diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6288-a.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6288-a.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6288-a.cabal @@ -0,0 +1,14 @@ +cabal-version: >=1.8 +name: issue +version: 6288 +build-type: Simple +synopsis: default-language optionality +category: Test +description: Field is introduced in 1.10, defaulted in 3.4 +license: BSD3 +license-file: LICENSE +maintainer: Cabal Contributors + +library + default-language: Haskell2010 + exposed-modules: Foo diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6288-a.check b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6288-a.check new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6288-a.check @@ -0,0 +1,1 @@ +issue-6288-a.cabal:13:3: The field "default-language" is available only since the Cabal specification version 1.10. This field will be ignored. diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6288-b.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6288-b.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6288-b.cabal @@ -0,0 +1,13 @@ +cabal-version: >= 1.8 +name: issue +version: 6288 +build-type: Simple +synopsis: default-language optionality +category: Test +description: Field is introduced in 1.10, defaulted in 3.4 +license: BSD3 +license-file: LICENSE +maintainer: Cabal Contributors + +library + exposed-modules: Foo diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6288-b.check b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6288-b.check new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6288-b.check diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6288-c.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6288-c.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6288-c.cabal @@ -0,0 +1,14 @@ +cabal-version: >= 1.10 +name: issue +version: 6288 +build-type: Simple +synopsis: default-language optionality +category: Test +description: Field is introduced in 1.10, defaulted in 3.4 +license: BSD3 +license-file: LICENSE +maintainer: Cabal Contributors + +library + default-language: Haskell2010 + exposed-modules: Foo diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6288-c.check b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6288-c.check new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6288-c.check diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6288-d.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6288-d.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6288-d.cabal @@ -0,0 +1,13 @@ +cabal-version: >=1.10 +name: issue +version: 6288 +build-type: Simple +synopsis: default-language optionality +category: Test +description: Field is introduced in 1.10, defaulted in 3.4 +license: BSD3 +license-file: LICENSE +maintainer: Cabal Contributors + +library + exposed-modules: Foo diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6288-d.check b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6288-d.check new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6288-d.check @@ -0,0 +1,1 @@ +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. diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6288-e.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6288-e.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6288-e.cabal @@ -0,0 +1,13 @@ +cabal-version: 3.4 +name: issue +version: 6288 +synopsis: default-language optionality +category: Test +description: Field is introduced in 1.10, defaulted in 3.4 +license: BSD-3-Clause +license-file: LICENSE +maintainer: Cabal Contributors + +library + default-language: Haskell2010 + exposed-modules: Foo diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6288-e.check b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6288-e.check new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6288-e.check diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6288-f.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6288-f.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6288-f.cabal @@ -0,0 +1,13 @@ +cabal-version: 3.4 +name: issue +version: 6288 +build-type: Simple +synopsis: default-language optionality +category: Test +description: Field is introduced in 1.10, defaulted in 3.4 +license: BSD-3-Clause +license-file: LICENSE +maintainer: Cabal Contributors + +library + exposed-modules: Foo diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6288-f.check b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6288-f.check new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-6288-f.check diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/issue-774.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-774.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-774.cabal @@ -0,0 +1,21 @@ +name: issue +version: 744 +synopsis: Package description parser interprets curly braces in the description field +description: Here is some C code: + . + > for(i = 0; i < 100; i++) { + > printf("%d\n",i); + > } + . + What does it look like? +build-type: Simple +-- we test that check warns about this +cabal-version: >=1.12 + +library + default-language: Haskell2010 + exposed-modules: Issue + + -- Test for round-trip of ghc-options here too + -- See https://github.com/haskell/cabal/issues/2661 + ghc-options: -Wall -threaded "-with-rtsopts=-N -s -M1G -c" -rtsopts diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/issue-774.check b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-774.check new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-774.check @@ -0,0 +1,7 @@ +issue-774.cabal:13:22: Packages with 'cabal-version: 1.12' or later should specify a specific version of the Cabal spec of the form 'cabal-version: x.y'. Use 'cabal-version: 1.12'. +No 'category' field. +No 'maintainer' field. +The 'license' field is missing or is NONE. +'ghc-options: -threaded' has no effect for libraries. It should only be used for executables. +'ghc-options: -rtsopts' has no effect for libraries. It should only be used for executables. +'ghc-options: -with-rtsopts' has no effect for libraries. It should only be used for executables. diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/issue-774.expr b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-774.expr new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-774.expr @@ -0,0 +1,111 @@ +GenericPackageDescription + {condBenchmarks = [], + condExecutables = [], + condForeignLibs = [], + condLibrary = Just + CondNode + {condTreeComponents = [], + condTreeConstraints = [], + condTreeData = Library + {exposedModules = [ModuleName "Issue"], + libBuildInfo = BuildInfo + {asmOptions = [], + asmSources = [], + autogenIncludes = [], + autogenModules = [], + buildToolDepends = [], + buildTools = [], + buildable = True, + cSources = [], + ccOptions = [], + cmmOptions = [], + cmmSources = [], + cppOptions = [], + customFieldsBI = [], + cxxOptions = [], + cxxSources = [], + defaultExtensions = [], + defaultLanguage = Just Haskell2010, + extraBundledLibs = [], + extraDynLibFlavours = [], + extraFrameworkDirs = [], + extraGHCiLibs = [], + extraLibDirs = [], + extraLibDirsStatic = [], + extraLibFlavours = [], + extraLibs = [], + extraLibsStatic = [], + frameworks = [], + hsSourceDirs = [], + hsc2hsOptions = [], + includeDirs = [], + includes = [], + installIncludes = [], + jsSources = [], + ldOptions = [], + mixins = [], + oldExtensions = [], + options = PerCompilerFlavor + ["-Wall", + "-threaded", + "-with-rtsopts=-N -s -M1G -c", + "-rtsopts"] + [], + otherExtensions = [], + otherLanguages = [], + otherModules = [], + pkgconfigDepends = [], + profOptions = PerCompilerFlavor [] [], + sharedOptions = PerCompilerFlavor [] [], + staticOptions = PerCompilerFlavor [] [], + targetBuildDepends = [], + virtualModules = []}, + libExposed = True, + libName = LMainLibName, + libVisibility = LibraryVisibilityPublic, + reexportedModules = [], + signatures = []}}, + condSubLibraries = [], + condTestSuites = [], + genPackageFlags = [], + gpdScannedVersion = Nothing, + packageDescription = PackageDescription + {author = "", + benchmarks = [], + bugReports = "", + buildTypeRaw = Just Simple, + category = "", + copyright = "", + customFieldsPD = [], + dataDir = ".", + dataFiles = [], + description = concat + ["Here is some C code:\n", + "\n", + "> for(i = 0; i < 100; i++) {\n", + "> printf(\"%d\\n\",i);\n", + "> }\n", + "\n", + "What does it look like?"], + executables = [], + extraDocFiles = [], + extraSrcFiles = [], + extraTmpFiles = [], + foreignLibs = [], + homepage = "", + library = Nothing, + licenseFiles = [], + licenseRaw = Left NONE, + maintainer = "", + package = PackageIdentifier + {pkgName = PackageName "issue", + pkgVersion = mkVersion [744]}, + pkgUrl = "", + setupBuildInfo = Nothing, + sourceRepos = [], + specVersion = CabalSpecV1_12, + stability = "", + subLibraries = [], + synopsis = "Package description parser interprets curly braces in the description field", + testSuites = [], + testedWith = []}} diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/issue-774.format b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-774.format new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-774.format @@ -0,0 +1,22 @@ +issue-774.cabal:13:22: Packages with 'cabal-version: 1.12' or later should specify a specific version of the Cabal spec of the form 'cabal-version: x.y'. Use 'cabal-version: 1.12'. +cabal-version: 1.12 +name: issue +version: 744 +synopsis: + Package description parser interprets curly braces in the description field + +description: + Here is some C code: + . + > for(i = 0; i < 100; i++) { + > printf("%d\n",i); + > } + . + What does it look like? + +build-type: Simple + +library + exposed-modules: Issue + default-language: Haskell2010 + ghc-options: -Wall -threaded "-with-rtsopts=-N -s -M1G -c" -rtsopts diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/issue-7776-a.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-7776-a.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-7776-a.cabal @@ -0,0 +1,26 @@ +cabal-version: 3.4 +name: issue +version: 7776 +build-type: Simple +synopsis: duplicate-module check +category: Test +description: + With duplicate modules guarded by exclusive conditions, it should be buildable but should show a warning. + It *could* be smart enough to don't show the warning but we have to teach it about +license: BSD-3-Clause +license-file: LICENSE +maintainer: Cabal Contributors + +-- Example taken from ghc-source-gen +library + exposed-modules: Foo + if impl(ghc<8.10) + other-modules: + GHC.Hs.Type + hs-source-dirs: + compat + if impl(ghc>=8.10) && impl(ghc<9.0) + other-modules: + GHC.Hs.Type + hs-source-dirs: + compat-8.10 diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/issue-7776-a.check b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-7776-a.check new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-7776-a.check @@ -0,0 +1,1 @@ +Potential duplicate modules (subject to conditionals) in library: GHC.Hs.Type diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/issue-7776-b.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-7776-b.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-7776-b.cabal @@ -0,0 +1,27 @@ +cabal-version: 3.4 +name: issue +version: 7776 +build-type: Simple +synopsis: duplicate-module check +category: Test +description: With duplicate modules, even with overlapping conditions, it should be buildable but should show a warning. +license: BSD-3-Clause +license-file: LICENSE +maintainer: Cabal Contributors + +-- Example taken from hashable-1.3.0 +library + exposed-modules: Foo + -- the base lower bound makes the package not buildable with ghc < 6.8 + -- but cabal is not smart enough to know it :-P + build-depends: base >= 4.5 && < 4.15 + +benchmark benchmarks + main-is: Benchmarks.hs + other-modules: + Data.Hashable.RandomSource + type: exitcode-stdio-1.0 + if impl(ghc >= 6.8) + Ghc-options: -fwarn-tabs + else + other-modules: Data.Hashable.RandomSource diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/issue-7776-b.check b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-7776-b.check new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-7776-b.check @@ -0,0 +1,1 @@ +Potential duplicate modules (subject to conditionals) in benchmark: Data.Hashable.RandomSource diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/issue-7776-c.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-7776-c.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-7776-c.cabal @@ -0,0 +1,19 @@ +cabal-version: 3.4 +name: issue +version: 7776 +build-type: Simple +synopsis: duplicate-module check +category: Test +description: With duplicate modules not guarded by any condition, it should throw an error. +license: BSD-3-Clause +license-file: LICENSE +maintainer: Cabal Contributors + +library + exposed-modules: Foo + other-modules: + GHC.Hs.Type + hs-source-dirs: + compat + other-modules: + GHC.Hs.Type diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/issue-7776-c.check b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-7776-c.check new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/issue-7776-c.check @@ -0,0 +1,1 @@ +Duplicate modules in library: GHC.Hs.Type diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/jaeger-flamegraph.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/jaeger-flamegraph.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/jaeger-flamegraph.cabal @@ -0,0 +1,70 @@ +cabal-version: 2.2 +name: jaeger-flamegraph +version: 1.0.0 +synopsis: Generate flamegraphs from Jaeger .json dumps. +license: BSD-3-Clause +license-file: LICENSE +author: Sam Halliday +maintainer: Sam Halliday +copyright: (c) 2018 Symbiont.io +bug-reports: https://github.com/symbiont-io/jaeger-flamegraph/pulls +tested-with: GHC ^>= 8.4.4 || ^>= 8.6.2 +category: Testing +description: + This is a small tool to convert JSON dumps obtained from a Jaeger + server () into a format consumable + by [FlameGraph](https://github.com/brendangregg/FlameGraph). + . + First download the traces for your SERVICE limiting to LIMIT traces + . + > $ curl http://your-jaeger-installation/api/traces?service=SERVICE&limit=LIMIT > input.json + . + using the [undocumented Jaeger API](https://github.com/jaegertracing/jaeger/issues/456#issuecomment-412560321) + then use @jaeger-flamegraph@ to convert the data and send to @flamegraph.pl@ + . + > $ jaeger-flamegraph -f input.json | flamegraph.pl > output.svg + . + +source-repository head + type: git + location: https://github.com/symbiont-io/jaeger-flamegraph + +-- https://www.haskell.org/cabal/users-guide/cabal-projectindex.html + +common deps + build-depends: , base ^>= 4.11.1.0 || ^>= 4.12.0.0 + ghc-options: -Wall + -Werror=missing-home-modules + default-language: Haskell2010 + +executable jaeger-flamegraph + import: deps + hs-source-dirs: exe + main-is: Main.hs + build-depends: , jaeger-flamegraph + , bytestring ^>= 0.10.8.2 + , containers ^>= 0.6.0.1 + , extra ^>= 1.6.13 + , aeson ^>= 1.4.1.0 + , optparse-applicative ^>= 0.14.3.0 + , text ^>= 1.2.3.1 + ghc-options: -threaded + +library + import: deps + hs-source-dirs: library + exposed-modules: Interval + build-depends: , QuickCheck ^>= 2.12.6.1 + +test-suite tests + import: deps + hs-source-dirs: test + type: exitcode-stdio-1.0 + main-is: Driver.hs + other-modules: IntervalTest + build-depends: , jaeger-flamegraph + , tasty ^>= 1.1.0.4 + , tasty-hspec ^>= 1.1.5 + , tasty-quickcheck ^>= 0.10 + build-tool-depends: tasty-discover:tasty-discover ^>= 4.2.1 + ghc-options: -threaded diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/jaeger-flamegraph.expr b/cabal/Cabal-tests/tests/ParserTests/regressions/jaeger-flamegraph.expr new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/jaeger-flamegraph.expr @@ -0,0 +1,469 @@ +GenericPackageDescription { + packageDescription = + PackageDescription { + specVersion = CabalSpecV2_2, + package = PackageIdentifier { + pkgName = PackageName + "jaeger-flamegraph", + pkgVersion = mkVersion + [1, 0, 0]}, + licenseRaw = Left + (License + (ELicense + (ELicenseId BSD_3_Clause) + Nothing)), + licenseFiles = [ + SymbolicPath "LICENSE"], + copyright = + "(c) 2018 Symbiont.io", + maintainer = "Sam Halliday", + author = "Sam Halliday", + stability = "", + testedWith = [ + _×_ + GHC + (UnionVersionRanges + (MajorBoundVersion + (mkVersion [8, 4, 4])) + (MajorBoundVersion + (mkVersion [8, 6, 2])))], + homepage = "", + pkgUrl = "", + bugReports = + "https://github.com/symbiont-io/jaeger-flamegraph/pulls", + sourceRepos = [ + SourceRepo { + repoKind = RepoHead, + repoType = Just + (KnownRepoType Git), + repoLocation = Just + "https://github.com/symbiont-io/jaeger-flamegraph", + repoModule = Nothing, + repoBranch = Nothing, + repoTag = Nothing, + repoSubdir = Nothing}], + synopsis = + "Generate flamegraphs from Jaeger .json dumps.", + description = + concat + [ + "This is a small tool to convert JSON dumps obtained from a Jaeger\n", + "server () into a format consumable\n", + "by [FlameGraph](https://github.com/brendangregg/FlameGraph).\n", + "\n", + "First download the traces for your SERVICE limiting to LIMIT traces\n", + "\n", + "> $ curl http://your-jaeger-installation/api/traces?service=SERVICE&limit=LIMIT > input.json\n", + "\n", + "using the [undocumented Jaeger API](https://github.com/jaegertracing/jaeger/issues/456#issuecomment-412560321)\n", + "then use @jaeger-flamegraph@ to convert the data and send to @flamegraph.pl@\n", + "\n", + "> $ jaeger-flamegraph -f input.json | flamegraph.pl > output.svg\n"], + category = "Testing", + customFieldsPD = [], + buildTypeRaw = Nothing, + setupBuildInfo = Nothing, + library = Nothing, + subLibraries = [], + executables = [], + foreignLibs = [], + testSuites = [], + benchmarks = [], + dataFiles = [], + dataDir = ".", + extraSrcFiles = [], + extraTmpFiles = [], + extraDocFiles = []}, + gpdScannedVersion = Nothing, + genPackageFlags = [], + condLibrary = Just + CondNode { + condTreeData = Library { + libName = LMainLibName, + exposedModules = [ + ModuleName "Interval"], + reexportedModules = [], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPublic, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [ + SymbolicPath "library"], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Just + Haskell2010, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [ + "-Wall", + "-Werror=missing-home-modules"] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + 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], + 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 = [], + condExecutables = [ + _×_ + (UnqualComponentName + "jaeger-flamegraph") + CondNode { + condTreeData = Executable { + exeName = UnqualComponentName + "jaeger-flamegraph", + modulePath = "Main.hs", + exeScope = ExecutablePublic, + buildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [ + SymbolicPath "exe"], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Just + Haskell2010, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [ + "-Wall", + "-Werror=missing-home-modules", + "-threaded"] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + 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], + 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 = [ + _×_ + (UnqualComponentName "tests") + CondNode { + condTreeData = TestSuite { + testName = UnqualComponentName + "", + testInterface = TestSuiteExeV10 + (mkVersion [1, 0]) + "Driver.hs", + testBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [ + ExeDependency + (PackageName "tasty-discover") + (UnqualComponentName + "tasty-discover") + (MajorBoundVersion + (mkVersion [4, 2, 1]))], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [ + SymbolicPath "test"], + otherModules = [ + ModuleName "IntervalTest"], + virtualModules = [], + autogenModules = [], + defaultLanguage = Just + Haskell2010, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [ + "-Wall", + "-Werror=missing-home-modules", + "-threaded"] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + 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], + 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/Cabal-tests/tests/ParserTests/regressions/jaeger-flamegraph.format b/cabal/Cabal-tests/tests/ParserTests/regressions/jaeger-flamegraph.format new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/jaeger-flamegraph.format @@ -0,0 +1,70 @@ +cabal-version: 2.2 +name: jaeger-flamegraph +version: 1.0.0 +license: BSD-3-Clause +license-file: LICENSE +copyright: (c) 2018 Symbiont.io +maintainer: Sam Halliday +author: Sam Halliday +tested-with: ghc ^>=8.4.4 || ^>=8.6.2 +bug-reports: https://github.com/symbiont-io/jaeger-flamegraph/pulls +synopsis: Generate flamegraphs from Jaeger .json dumps. +description: + This is a small tool to convert JSON dumps obtained from a Jaeger + server () into a format consumable + by [FlameGraph](https://github.com/brendangregg/FlameGraph). + . + First download the traces for your SERVICE limiting to LIMIT traces + . + > $ curl http://your-jaeger-installation/api/traces?service=SERVICE&limit=LIMIT > input.json + . + using the [undocumented Jaeger API](https://github.com/jaegertracing/jaeger/issues/456#issuecomment-412560321) + then use @jaeger-flamegraph@ to convert the data and send to @flamegraph.pl@ + . + > $ jaeger-flamegraph -f input.json | flamegraph.pl > output.svg + . + +category: Testing + +source-repository head + type: git + location: https://github.com/symbiont-io/jaeger-flamegraph + +library + exposed-modules: Interval + hs-source-dirs: library + default-language: Haskell2010 + ghc-options: -Wall -Werror=missing-home-modules + build-depends: + base ^>=4.11.1.0 || ^>=4.12.0.0, + QuickCheck ^>=2.12.6.1 + +executable jaeger-flamegraph + main-is: Main.hs + hs-source-dirs: exe + default-language: Haskell2010 + ghc-options: -Wall -Werror=missing-home-modules -threaded + build-depends: + base ^>=4.11.1.0 || ^>=4.12.0.0, + jaeger-flamegraph, + bytestring ^>=0.10.8.2, + containers ^>=0.6.0.1, + extra ^>=1.6.13, + aeson ^>=1.4.1.0, + optparse-applicative ^>=0.14.3.0, + text ^>=1.2.3.1 + +test-suite tests + type: exitcode-stdio-1.0 + main-is: Driver.hs + build-tool-depends: tasty-discover:tasty-discover ^>=4.2.1 + hs-source-dirs: test + other-modules: IntervalTest + default-language: Haskell2010 + ghc-options: -Wall -Werror=missing-home-modules -threaded + build-depends: + base ^>=4.11.1.0 || ^>=4.12.0.0, + jaeger-flamegraph, + tasty ^>=1.1.0.4, + tasty-hspec ^>=1.1.5, + tasty-quickcheck ^>=0.10 diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/leading-comma-2.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/leading-comma-2.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/leading-comma-2.cabal @@ -0,0 +1,33 @@ +cabal-version: 3.0 +name: leading-comma +version: 0 +synopsis: leading comma, trailing comma, or ordinary +build-type: Simple + +library + default-language: Haskell2010 + + -- empty field on purpose + exposed-modules: + + exposed-modules: + , LeadingComma + , LeadingComma2 + + exposed-modules: + TrailingComma, + TrailingComma, + + exposed-modules: Comma, InBetween + + exposed-modules: NoCommas NoCommas + + build-depends: base, containers + + build-depends: + deepseq, + transformers, + + build-depends: + , filepath + , directory diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/leading-comma-2.expr b/cabal/Cabal-tests/tests/ParserTests/regressions/leading-comma-2.expr new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/leading-comma-2.expr @@ -0,0 +1,170 @@ +GenericPackageDescription + {condBenchmarks = [], + condExecutables = [], + condForeignLibs = [], + condLibrary = Just + CondNode + {condTreeComponents = [], + 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], + condTreeData = Library + {exposedModules = [ModuleName "LeadingComma", + ModuleName "LeadingComma2", + ModuleName "TrailingComma", + ModuleName "TrailingComma", + ModuleName "Comma", + ModuleName "InBetween", + ModuleName "NoCommas", + ModuleName "NoCommas"], + libBuildInfo = BuildInfo + {asmOptions = [], + asmSources = [], + autogenIncludes = [], + autogenModules = [], + buildToolDepends = [], + buildTools = [], + buildable = True, + cSources = [], + ccOptions = [], + cmmOptions = [], + cmmSources = [], + cppOptions = [], + customFieldsBI = [], + cxxOptions = [], + cxxSources = [], + defaultExtensions = [], + defaultLanguage = Just Haskell2010, + extraBundledLibs = [], + extraDynLibFlavours = [], + extraFrameworkDirs = [], + extraGHCiLibs = [], + extraLibDirs = [], + extraLibDirsStatic = [], + extraLibFlavours = [], + extraLibs = [], + extraLibsStatic = [], + frameworks = [], + hsSourceDirs = [], + hsc2hsOptions = [], + includeDirs = [], + includes = [], + installIncludes = [], + jsSources = [], + ldOptions = [], + mixins = [], + oldExtensions = [], + options = PerCompilerFlavor [] [], + otherExtensions = [], + otherLanguages = [], + otherModules = [], + pkgconfigDepends = [], + profOptions = PerCompilerFlavor [] [], + sharedOptions = PerCompilerFlavor [] [], + staticOptions = PerCompilerFlavor [] [], + targetBuildDepends = [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], + virtualModules = []}, + libExposed = True, + libName = LMainLibName, + libVisibility = LibraryVisibilityPublic, + reexportedModules = [], + signatures = []}}, + condSubLibraries = [], + condTestSuites = [], + genPackageFlags = [], + gpdScannedVersion = Nothing, + packageDescription = PackageDescription + {author = "", + benchmarks = [], + bugReports = "", + buildTypeRaw = Just Simple, + category = "", + copyright = "", + customFieldsPD = [], + dataDir = ".", + dataFiles = [], + description = "", + executables = [], + extraDocFiles = [], + extraSrcFiles = [], + extraTmpFiles = [], + foreignLibs = [], + homepage = "", + library = Nothing, + licenseFiles = [], + licenseRaw = Left NONE, + maintainer = "", + package = PackageIdentifier + {pkgName = PackageName "leading-comma", + pkgVersion = mkVersion [0]}, + pkgUrl = "", + setupBuildInfo = Nothing, + sourceRepos = [], + specVersion = CabalSpecV3_0, + stability = "", + subLibraries = [], + synopsis = "leading comma, trailing comma, or ordinary", + testSuites = [], + testedWith = []}} diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/leading-comma-2.format b/cabal/Cabal-tests/tests/ParserTests/regressions/leading-comma-2.format new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/leading-comma-2.format @@ -0,0 +1,25 @@ +cabal-version: 3.0 +name: leading-comma +version: 0 +synopsis: leading comma, trailing comma, or ordinary +build-type: Simple + +library + exposed-modules: + LeadingComma + LeadingComma2 + TrailingComma + TrailingComma + Comma + InBetween + NoCommas + NoCommas + + default-language: Haskell2010 + build-depends: + base, + containers, + deepseq, + transformers, + filepath, + directory diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/leading-comma.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/leading-comma.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/leading-comma.cabal @@ -0,0 +1,19 @@ +cabal-version: 2.2 +name: leading-comma +version: 0 +synopsis: leading comma, trailing comma, or ordinary +build-type: Simple + +library + default-language: Haskell2010 + exposed-modules: LeadingComma + + build-depends: base, containers + + build-depends: + deepseq, + transformers, + + build-depends: + , filepath + , directory diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/leading-comma.expr b/cabal/Cabal-tests/tests/ParserTests/regressions/leading-comma.expr new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/leading-comma.expr @@ -0,0 +1,163 @@ +GenericPackageDescription + {condBenchmarks = [], + condExecutables = [], + condForeignLibs = [], + condLibrary = Just + CondNode + {condTreeComponents = [], + 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], + condTreeData = Library + {exposedModules = [ModuleName "LeadingComma"], + libBuildInfo = BuildInfo + {asmOptions = [], + asmSources = [], + autogenIncludes = [], + autogenModules = [], + buildToolDepends = [], + buildTools = [], + buildable = True, + cSources = [], + ccOptions = [], + cmmOptions = [], + cmmSources = [], + cppOptions = [], + customFieldsBI = [], + cxxOptions = [], + cxxSources = [], + defaultExtensions = [], + defaultLanguage = Just Haskell2010, + extraBundledLibs = [], + extraDynLibFlavours = [], + extraFrameworkDirs = [], + extraGHCiLibs = [], + extraLibDirs = [], + extraLibDirsStatic = [], + extraLibFlavours = [], + extraLibs = [], + extraLibsStatic = [], + frameworks = [], + hsSourceDirs = [], + hsc2hsOptions = [], + includeDirs = [], + includes = [], + installIncludes = [], + jsSources = [], + ldOptions = [], + mixins = [], + oldExtensions = [], + options = PerCompilerFlavor [] [], + otherExtensions = [], + otherLanguages = [], + otherModules = [], + pkgconfigDepends = [], + profOptions = PerCompilerFlavor [] [], + sharedOptions = PerCompilerFlavor [] [], + staticOptions = PerCompilerFlavor [] [], + targetBuildDepends = [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], + virtualModules = []}, + libExposed = True, + libName = LMainLibName, + libVisibility = LibraryVisibilityPublic, + reexportedModules = [], + signatures = []}}, + condSubLibraries = [], + condTestSuites = [], + genPackageFlags = [], + gpdScannedVersion = Nothing, + packageDescription = PackageDescription + {author = "", + benchmarks = [], + bugReports = "", + buildTypeRaw = Just Simple, + category = "", + copyright = "", + customFieldsPD = [], + dataDir = ".", + dataFiles = [], + description = "", + executables = [], + extraDocFiles = [], + extraSrcFiles = [], + extraTmpFiles = [], + foreignLibs = [], + homepage = "", + library = Nothing, + licenseFiles = [], + licenseRaw = Left NONE, + maintainer = "", + package = PackageIdentifier + {pkgName = PackageName "leading-comma", + pkgVersion = mkVersion [0]}, + pkgUrl = "", + setupBuildInfo = Nothing, + sourceRepos = [], + specVersion = CabalSpecV2_2, + stability = "", + subLibraries = [], + synopsis = "leading comma, trailing comma, or ordinary", + testSuites = [], + testedWith = []}} diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/leading-comma.format b/cabal/Cabal-tests/tests/ParserTests/regressions/leading-comma.format new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/leading-comma.format @@ -0,0 +1,16 @@ +cabal-version: 2.2 +name: leading-comma +version: 0 +synopsis: leading comma, trailing comma, or ordinary +build-type: Simple + +library + exposed-modules: LeadingComma + default-language: Haskell2010 + build-depends: + base, + containers, + deepseq, + transformers, + filepath, + directory diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/libpq1.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/libpq1.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/libpq1.cabal @@ -0,0 +1,81 @@ +Name: postgresql-libpq +Version: 0.9.4.2 +Synopsis: low-level binding to libpq + +Description: This is a binding to libpq: the C application + programmer's interface to PostgreSQL. libpq is a + set of library functions that allow client + programs to pass queries to the PostgreSQL + backend server and to receive the results of + these queries. + +Homepage: https://github.com/phadej/postgresql-libpq +License: BSD3 +License-file: LICENSE +Author: Grant Monroe, Leon P Smith, Joey Adams +Maintainer: Oleg Grenrus +Copyright: (c) 2010 Grant Monroe + (c) 2011 Leon P Smith +Category: Database +Build-type: Custom +Extra-source-files: cbits/noticehandlers.h +Cabal-version: >=1.8 +Tested-with: + GHC==7.0.4, + GHC==7.2.2, + GHC==7.4.2, + GHC==7.6.3, + GHC==7.8.4, + GHC==7.10.3, + GHC==8.0.2, + GHC==8.2.2, + GHC==8.4.3, + GHC==8.6.1 + +extra-source-files: + CHANGELOG.md + +Custom-setup + setup-depends: + base >= 4.3 && <5, Cabal >= 1.10 && <2.5 + +-- If true, use pkg-config, otherwise use the pg_config based build +-- configuration +Flag use-pkg-config + default: False + manual: True + +Library + hs-source-dirs: src + c-sources: cbits/noticehandlers.c + include-dirs: cbits + Exposed-modules: Database.PostgreSQL.LibPQ + Database.PostgreSQL.LibPQ.Internal + Build-depends: base >=4.3 && <4.13 + , bytestring >=0.9.1.0 && <0.11 + + if !os(windows) + Build-depends: unix >=2.4.2.0 && <2.8 + + if os(windows) + Build-depends: Win32 >=2.2.0.2 && <2.7 + + GHC-Options: -Wall + + if flag(use-pkg-config) + Pkgconfig-depends: libpq ==9.* + else + if os(windows) + -- Due to https://sourceware.org/bugzilla/show_bug.cgi?id=22948, + -- if we specify pq instead of libpq, then ld might link against + -- libpq.dll directly, which can lead to segfaults. As a temporary hack, + -- we force ld to link against the libpq.lib import library directly + -- by specifying libpq here. + Extra-Libraries: libpq + else + Extra-Libraries: pq + if os(openbsd) + Extra-Libraries: crypto ssl + + -- Other-modules: + Build-tools: hsc2hs diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/libpq1.expr b/cabal/Cabal-tests/tests/ParserTests/regressions/libpq1.expr new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/libpq1.expr @@ -0,0 +1,741 @@ +GenericPackageDescription { + packageDescription = + PackageDescription { + specVersion = CabalSpecV1_8, + package = PackageIdentifier { + pkgName = PackageName + "postgresql-libpq", + pkgVersion = mkVersion + [0, 9, 4, 2]}, + licenseRaw = Right BSD3, + licenseFiles = [ + SymbolicPath "LICENSE"], + copyright = concat + [ + "(c) 2010 Grant Monroe\n", + "(c) 2011 Leon P Smith"], + maintainer = + "Oleg Grenrus ", + author = + "Grant Monroe, Leon P Smith, Joey Adams", + stability = "", + testedWith = [ + _×_ + GHC + (ThisVersion + (mkVersion [7, 0, 4])), + _×_ + GHC + (ThisVersion + (mkVersion [7, 2, 2])), + _×_ + GHC + (ThisVersion + (mkVersion [7, 4, 2])), + _×_ + GHC + (ThisVersion + (mkVersion [7, 6, 3])), + _×_ + GHC + (ThisVersion + (mkVersion [7, 8, 4])), + _×_ + GHC + (ThisVersion + (mkVersion [7, 10, 3])), + _×_ + GHC + (ThisVersion + (mkVersion [8, 0, 2])), + _×_ + GHC + (ThisVersion + (mkVersion [8, 2, 2])), + _×_ + GHC + (ThisVersion + (mkVersion [8, 4, 3])), + _×_ + GHC + (ThisVersion + (mkVersion [8, 6, 1]))], + homepage = + "https://github.com/phadej/postgresql-libpq", + pkgUrl = "", + bugReports = "", + sourceRepos = [], + synopsis = + "low-level binding to libpq", + description = concat + [ + "This is a binding to libpq: the C application\n", + "programmer's interface to PostgreSQL. libpq is a\n", + "set of library functions that allow client\n", + "programs to pass queries to the PostgreSQL\n", + "backend server and to receive the results of\n", + "these queries."], + category = "Database", + customFieldsPD = [], + buildTypeRaw = Just Custom, + setupBuildInfo = Just + SetupBuildInfo { + setupDepends = [ + Dependency + (PackageName "base") + (IntersectVersionRanges + (OrLaterVersion + (mkVersion [4, 3])) + (EarlierVersion + (mkVersion [5]))) + mainLibSet, + Dependency + (PackageName "Cabal") + (IntersectVersionRanges + (OrLaterVersion + (mkVersion [1, 10])) + (EarlierVersion + (mkVersion [2, 5]))) + mainLibSet], + defaultSetupDepends = False}, + library = Nothing, + subLibraries = [], + executables = [], + foreignLibs = [], + testSuites = [], + benchmarks = [], + dataFiles = [], + dataDir = ".", + extraSrcFiles = [ + "cbits/noticehandlers.h", + "CHANGELOG.md"], + extraTmpFiles = [], + extraDocFiles = []}, + gpdScannedVersion = Nothing, + genPackageFlags = [ + MkPackageFlag { + flagName = FlagName + "use-pkg-config", + flagDescription = "", + flagDefault = False, + flagManual = True}], + condLibrary = Just + CondNode { + condTreeData = Library { + libName = LMainLibName, + exposedModules = [ + ModuleName + "Database.PostgreSQL.LibPQ", + ModuleName + "Database.PostgreSQL.LibPQ.Internal"], + reexportedModules = [], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPublic, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [ + LegacyExeDependency + "hsc2hs" + (OrLaterVersion + (mkVersion [0]))], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [ + "cbits/noticehandlers.c"], + cxxSources = [], + jsSources = [], + hsSourceDirs = [ + SymbolicPath "src"], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = ["cbits"], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + ["-Wall"] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + 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], + 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 = + `CNot (Var (OS Windows))`, + condBranchIfTrue = CondNode { + condTreeData = Library { + libName = LMainLibName, + exposedModules = [], + reexportedModules = [], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPublic, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + Dependency + (PackageName "unix") + (IntersectVersionRanges + (OrLaterVersion + (mkVersion [2, 4, 2, 0])) + (EarlierVersion + (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 { + condBranchCondition = + `Var (OS Windows)`, + condBranchIfTrue = CondNode { + condTreeData = Library { + libName = LMainLibName, + exposedModules = [], + reexportedModules = [], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPublic, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + Dependency + (PackageName "Win32") + (IntersectVersionRanges + (OrLaterVersion + (mkVersion [2, 2, 0, 2])) + (EarlierVersion + (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 { + condBranchCondition = + `Var (PackageFlag (FlagName "use-pkg-config"))`, + condBranchIfTrue = CondNode { + condTreeData = Library { + libName = LMainLibName, + exposedModules = [], + reexportedModules = [], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPublic, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [ + PkgconfigDependency + (PkgconfigName "libpq") + (PcIntersectVersionRanges + (PcOrLaterVersion + (PkgconfigVersion "9")) + (PcEarlierVersion + (PkgconfigVersion "10")))], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [], + mixins = []}}, + condTreeConstraints = [], + condTreeComponents = []}, + condBranchIfFalse = Just + CondNode { + condTreeData = Library { + libName = LMainLibName, + exposedModules = [], + reexportedModules = [], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPublic, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [], + mixins = []}}, + condTreeConstraints = [], + condTreeComponents = [ + CondBranch { + condBranchCondition = + `Var (OS Windows)`, + condBranchIfTrue = CondNode { + condTreeData = Library { + libName = LMainLibName, + exposedModules = [], + reexportedModules = [], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPublic, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = ["libpq"], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [], + mixins = []}}, + condTreeConstraints = [], + condTreeComponents = []}, + condBranchIfFalse = Just + CondNode { + condTreeData = Library { + libName = LMainLibName, + exposedModules = [], + reexportedModules = [], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPublic, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = ["pq"], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [], + mixins = []}}, + condTreeConstraints = [], + condTreeComponents = [ + CondBranch { + condBranchCondition = + `Var (OS OpenBSD)`, + condBranchIfTrue = CondNode { + condTreeData = Library { + libName = LMainLibName, + exposedModules = [], + reexportedModules = [], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPublic, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = ["crypto", "ssl"], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [], + mixins = []}}, + condTreeConstraints = [], + condTreeComponents = []}, + condBranchIfFalse = + Nothing}]}}]}}]}, + condSubLibraries = [], + condForeignLibs = [], + condExecutables = [], + condTestSuites = [], + condBenchmarks = []} diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/libpq1.format b/cabal/Cabal-tests/tests/ParserTests/regressions/libpq1.format new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/libpq1.format @@ -0,0 +1,74 @@ +cabal-version: >=1.8 +name: postgresql-libpq +version: 0.9.4.2 +license: BSD3 +license-file: LICENSE +copyright: + (c) 2010 Grant Monroe + (c) 2011 Leon P Smith + +maintainer: Oleg Grenrus +author: Grant Monroe, Leon P Smith, Joey Adams +tested-with: + ghc ==7.0.4 ghc ==7.2.2 ghc ==7.4.2 ghc ==7.6.3 ghc ==7.8.4 + ghc ==7.10.3 ghc ==8.0.2 ghc ==8.2.2 ghc ==8.4.3 ghc ==8.6.1 + +homepage: https://github.com/phadej/postgresql-libpq +synopsis: low-level binding to libpq +description: + This is a binding to libpq: the C application + programmer's interface to PostgreSQL. libpq is a + set of library functions that allow client + programs to pass queries to the PostgreSQL + backend server and to receive the results of + these queries. + +category: Database +build-type: Custom +extra-source-files: + cbits/noticehandlers.h + CHANGELOG.md + +custom-setup + setup-depends: + base >=4.3 && <5, + Cabal >=1.10 && <2.5 + +flag use-pkg-config + default: False + manual: True + +library + exposed-modules: + Database.PostgreSQL.LibPQ + Database.PostgreSQL.LibPQ.Internal + + build-tools: hsc2hs >=0 + c-sources: cbits/noticehandlers.c + hs-source-dirs: src + include-dirs: cbits + ghc-options: -Wall + build-depends: + base >=4.3 && <4.13, + bytestring >=0.9.1.0 && <0.11 + + if !os(windows) + build-depends: unix >=2.4.2.0 && <2.8 + + if os(windows) + build-depends: Win32 >=2.2.0.2 && <2.7 + + if flag(use-pkg-config) + pkgconfig-depends: libpq >=9 && <10 + + else + if os(windows) + extra-libraries: libpq + + else + extra-libraries: pq + + if os(openbsd) + extra-libraries: + crypto + ssl diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/libpq2.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/libpq2.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/libpq2.cabal @@ -0,0 +1,81 @@ +Cabal-version: 3.0 +Name: postgresql-libpq +Version: 0.9.4.2 +Synopsis: low-level binding to libpq + +Description: This is a binding to libpq: the C application + programmer's interface to PostgreSQL. libpq is a + set of library functions that allow client + programs to pass queries to the PostgreSQL + backend server and to receive the results of + these queries. + +Homepage: https://github.com/phadej/postgresql-libpq +License: BSD-3-Clause +License-file: LICENSE +Author: Grant Monroe, Leon P Smith, Joey Adams +Maintainer: Oleg Grenrus +Copyright: (c) 2010 Grant Monroe + (c) 2011 Leon P Smith +Category: Database +Build-type: Custom +Extra-source-files: cbits/noticehandlers.h +Tested-with: + GHC==7.0.4, + GHC==7.2.2, + GHC==7.4.2, + GHC==7.6.3, + GHC==7.8.4, + GHC==7.10.3, + GHC==8.0.2, + GHC==8.2.2, + GHC==8.4.3, + GHC==8.6.1 + +extra-source-files: + CHANGELOG.md + +Custom-setup + setup-depends: + base >= 4.3 && <5, Cabal >= 1.10 && <2.5 + +-- If true, use pkg-config, otherwise use the pg_config based build +-- configuration +Flag use-pkg-config + default: False + manual: True + +Library + hs-source-dirs: src + c-sources: cbits/noticehandlers.c + include-dirs: cbits + Exposed-modules: Database.PostgreSQL.LibPQ + Database.PostgreSQL.LibPQ.Internal + Build-depends: base >=4.3 && <4.13 + , bytestring >=0.9.1.0 && <0.11 + + if !os(windows) + Build-depends: unix >=2.4.2.0 && <2.8 + + if os(windows) + Build-depends: Win32 >=2.2.0.2 && <2.7 + + GHC-Options: -Wall + + if flag(use-pkg-config) + Pkgconfig-depends: libpq >=9.3h + else + if os(windows) + -- Due to https://sourceware.org/bugzilla/show_bug.cgi?id=22948, + -- if we specify pq instead of libpq, then ld might link against + -- libpq.dll directly, which can lead to segfaults. As a temporary hack, + -- we force ld to link against the libpq.lib import library directly + -- by specifying libpq here. + Extra-Libraries: libpq + else + Extra-Libraries: pq + if os(openbsd) + Extra-Libraries: crypto ssl + + -- Other-modules: + build-tool-depends: hsc2hs:hsc2hs diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/libpq2.expr b/cabal/Cabal-tests/tests/ParserTests/regressions/libpq2.expr new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/libpq2.expr @@ -0,0 +1,743 @@ +GenericPackageDescription { + packageDescription = + PackageDescription { + specVersion = CabalSpecV3_0, + package = PackageIdentifier { + pkgName = PackageName + "postgresql-libpq", + pkgVersion = mkVersion + [0, 9, 4, 2]}, + licenseRaw = Left + (License + (ELicense + (ELicenseId BSD_3_Clause) + Nothing)), + licenseFiles = [ + SymbolicPath "LICENSE"], + copyright = concat + [ + "(c) 2010 Grant Monroe\n", + "(c) 2011 Leon P Smith"], + maintainer = + "Oleg Grenrus ", + author = + "Grant Monroe, Leon P Smith, Joey Adams", + stability = "", + testedWith = [ + _×_ + GHC + (ThisVersion + (mkVersion [7, 0, 4])), + _×_ + GHC + (ThisVersion + (mkVersion [7, 2, 2])), + _×_ + GHC + (ThisVersion + (mkVersion [7, 4, 2])), + _×_ + GHC + (ThisVersion + (mkVersion [7, 6, 3])), + _×_ + GHC + (ThisVersion + (mkVersion [7, 8, 4])), + _×_ + GHC + (ThisVersion + (mkVersion [7, 10, 3])), + _×_ + GHC + (ThisVersion + (mkVersion [8, 0, 2])), + _×_ + GHC + (ThisVersion + (mkVersion [8, 2, 2])), + _×_ + GHC + (ThisVersion + (mkVersion [8, 4, 3])), + _×_ + GHC + (ThisVersion + (mkVersion [8, 6, 1]))], + homepage = + "https://github.com/phadej/postgresql-libpq", + pkgUrl = "", + bugReports = "", + sourceRepos = [], + synopsis = + "low-level binding to libpq", + description = concat + [ + "This is a binding to libpq: the C application\n", + "programmer's interface to PostgreSQL. libpq is a\n", + "set of library functions that allow client\n", + "programs to pass queries to the PostgreSQL\n", + "backend server and to receive the results of\n", + "these queries."], + category = "Database", + customFieldsPD = [], + buildTypeRaw = Just Custom, + setupBuildInfo = Just + SetupBuildInfo { + setupDepends = [ + Dependency + (PackageName "base") + (IntersectVersionRanges + (OrLaterVersion + (mkVersion [4, 3])) + (EarlierVersion + (mkVersion [5]))) + mainLibSet, + Dependency + (PackageName "Cabal") + (IntersectVersionRanges + (OrLaterVersion + (mkVersion [1, 10])) + (EarlierVersion + (mkVersion [2, 5]))) + mainLibSet], + defaultSetupDepends = False}, + library = Nothing, + subLibraries = [], + executables = [], + foreignLibs = [], + testSuites = [], + benchmarks = [], + dataFiles = [], + dataDir = ".", + extraSrcFiles = [ + "cbits/noticehandlers.h", + "CHANGELOG.md"], + extraTmpFiles = [], + extraDocFiles = []}, + gpdScannedVersion = Nothing, + genPackageFlags = [ + MkPackageFlag { + flagName = FlagName + "use-pkg-config", + flagDescription = "", + flagDefault = False, + flagManual = True}], + condLibrary = Just + CondNode { + condTreeData = Library { + libName = LMainLibName, + exposedModules = [ + ModuleName + "Database.PostgreSQL.LibPQ", + ModuleName + "Database.PostgreSQL.LibPQ.Internal"], + reexportedModules = [], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPublic, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [ + ExeDependency + (PackageName "hsc2hs") + (UnqualComponentName "hsc2hs") + (OrLaterVersion + (mkVersion [0]))], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [ + "cbits/noticehandlers.c"], + cxxSources = [], + jsSources = [], + hsSourceDirs = [ + SymbolicPath "src"], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = ["cbits"], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + ["-Wall"] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + 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], + 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 = + `CNot (Var (OS Windows))`, + condBranchIfTrue = CondNode { + condTreeData = Library { + libName = LMainLibName, + exposedModules = [], + reexportedModules = [], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPublic, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + Dependency + (PackageName "unix") + (IntersectVersionRanges + (OrLaterVersion + (mkVersion [2, 4, 2, 0])) + (EarlierVersion + (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 { + condBranchCondition = + `Var (OS Windows)`, + condBranchIfTrue = CondNode { + condTreeData = Library { + libName = LMainLibName, + exposedModules = [], + reexportedModules = [], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPublic, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + Dependency + (PackageName "Win32") + (IntersectVersionRanges + (OrLaterVersion + (mkVersion [2, 2, 0, 2])) + (EarlierVersion + (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 { + condBranchCondition = + `Var (PackageFlag (FlagName "use-pkg-config"))`, + condBranchIfTrue = CondNode { + condTreeData = Library { + libName = LMainLibName, + exposedModules = [], + reexportedModules = [], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPublic, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [ + PkgconfigDependency + (PkgconfigName "libpq") + (PcOrLaterVersion + (PkgconfigVersion "9.3h"))], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [], + mixins = []}}, + condTreeConstraints = [], + condTreeComponents = []}, + condBranchIfFalse = Just + CondNode { + condTreeData = Library { + libName = LMainLibName, + exposedModules = [], + reexportedModules = [], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPublic, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [], + mixins = []}}, + condTreeConstraints = [], + condTreeComponents = [ + CondBranch { + condBranchCondition = + `Var (OS Windows)`, + condBranchIfTrue = CondNode { + condTreeData = Library { + libName = LMainLibName, + exposedModules = [], + reexportedModules = [], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPublic, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = ["libpq"], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [], + mixins = []}}, + condTreeConstraints = [], + condTreeComponents = []}, + condBranchIfFalse = Just + CondNode { + condTreeData = Library { + libName = LMainLibName, + exposedModules = [], + reexportedModules = [], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPublic, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = ["pq"], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [], + mixins = []}}, + condTreeConstraints = [], + condTreeComponents = [ + CondBranch { + condBranchCondition = + `Var (OS OpenBSD)`, + condBranchIfTrue = CondNode { + condTreeData = Library { + libName = LMainLibName, + exposedModules = [], + reexportedModules = [], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPublic, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = ["crypto", "ssl"], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [], + mixins = []}}, + condTreeConstraints = [], + condTreeComponents = []}, + condBranchIfFalse = + Nothing}]}}]}}]}, + condSubLibraries = [], + condForeignLibs = [], + condExecutables = [], + condTestSuites = [], + condBenchmarks = []} diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/libpq2.format b/cabal/Cabal-tests/tests/ParserTests/regressions/libpq2.format new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/libpq2.format @@ -0,0 +1,74 @@ +cabal-version: 3.0 +name: postgresql-libpq +version: 0.9.4.2 +license: BSD-3-Clause +license-file: LICENSE +copyright: + (c) 2010 Grant Monroe + (c) 2011 Leon P Smith + +maintainer: Oleg Grenrus +author: Grant Monroe, Leon P Smith, Joey Adams +tested-with: + ghc ==7.0.4 ghc ==7.2.2 ghc ==7.4.2 ghc ==7.6.3 ghc ==7.8.4 + ghc ==7.10.3 ghc ==8.0.2 ghc ==8.2.2 ghc ==8.4.3 ghc ==8.6.1 + +homepage: https://github.com/phadej/postgresql-libpq +synopsis: low-level binding to libpq +description: + This is a binding to libpq: the C application + programmer's interface to PostgreSQL. libpq is a + set of library functions that allow client + programs to pass queries to the PostgreSQL + backend server and to receive the results of + these queries. + +category: Database +build-type: Custom +extra-source-files: + cbits/noticehandlers.h + CHANGELOG.md + +custom-setup + setup-depends: + base >=4.3 && <5, + Cabal >=1.10 && <2.5 + +flag use-pkg-config + default: False + manual: True + +library + exposed-modules: + Database.PostgreSQL.LibPQ + Database.PostgreSQL.LibPQ.Internal + + build-tool-depends: hsc2hs:hsc2hs + c-sources: cbits/noticehandlers.c + hs-source-dirs: src + include-dirs: cbits + ghc-options: -Wall + build-depends: + base >=4.3 && <4.13, + bytestring >=0.9.1.0 && <0.11 + + if !os(windows) + build-depends: unix >=2.4.2.0 && <2.8 + + if os(windows) + build-depends: Win32 >=2.2.0.2 && <2.7 + + if flag(use-pkg-config) + pkgconfig-depends: libpq >=9.3h + + else + if os(windows) + extra-libraries: libpq + + else + extra-libraries: pq + + if os(openbsd) + extra-libraries: + crypto + ssl diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/mixin-1.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/mixin-1.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/mixin-1.cabal @@ -0,0 +1,11 @@ +cabal-version: 2.0 +name: mixin +version: 0 +build-type: Simple + +executable str-example + main-is: Main.hs + build-depends: base, str-string, str-bytestring + mixins: str-string (Str as Str.String), + str-bytestring (Str as Str.ByteString) + hs-source-dirs: str-example diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/mixin-1.expr b/cabal/Cabal-tests/tests/ParserTests/regressions/mixin-1.expr new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/mixin-1.expr @@ -0,0 +1,151 @@ +GenericPackageDescription + {condBenchmarks = [], + condExecutables = [_×_ + (UnqualComponentName "str-example") + CondNode + {condTreeComponents = [], + condTreeConstraints = [Dependency + (PackageName "base") + (OrLaterVersion (mkVersion [0])) + mainLibSet, + Dependency + (PackageName "str-string") + (OrLaterVersion (mkVersion [0])) + mainLibSet, + Dependency + (PackageName "str-bytestring") + (OrLaterVersion (mkVersion [0])) + mainLibSet], + condTreeData = Executable + {buildInfo = BuildInfo + {asmOptions = [], + asmSources = [], + autogenIncludes = [], + autogenModules = [], + buildToolDepends = [], + buildTools = [], + buildable = True, + cSources = [], + ccOptions = [], + cmmOptions = [], + cmmSources = [], + cppOptions = [], + customFieldsBI = [], + cxxOptions = [], + cxxSources = [], + defaultExtensions = [], + defaultLanguage = Nothing, + extraBundledLibs = [], + extraDynLibFlavours = [], + extraFrameworkDirs = [], + extraGHCiLibs = [], + extraLibDirs = [], + extraLibDirsStatic = [], + extraLibFlavours = [], + extraLibs = [], + extraLibsStatic = [], + frameworks = [], + hsSourceDirs = [SymbolicPath + "str-example"], + hsc2hsOptions = [], + includeDirs = [], + includes = [], + installIncludes = [], + jsSources = [], + ldOptions = [], + mixins = [Mixin + {mixinIncludeRenaming = IncludeRenaming + {includeProvidesRn = ModuleRenaming + [_×_ + (ModuleName + "Str") + (ModuleName + "Str.String")], + includeRequiresRn = DefaultRenaming}, + mixinLibraryName = LMainLibName, + mixinPackageName = PackageName + "str-string"}, + Mixin + {mixinIncludeRenaming = IncludeRenaming + {includeProvidesRn = ModuleRenaming + [_×_ + (ModuleName + "Str") + (ModuleName + "Str.ByteString")], + includeRequiresRn = DefaultRenaming}, + mixinLibraryName = LMainLibName, + mixinPackageName = PackageName + "str-bytestring"}], + oldExtensions = [], + options = PerCompilerFlavor [] [], + otherExtensions = [], + otherLanguages = [], + otherModules = [], + pkgconfigDepends = [], + profOptions = PerCompilerFlavor [] [], + sharedOptions = PerCompilerFlavor [] [], + staticOptions = PerCompilerFlavor [] [], + targetBuildDepends = [Dependency + (PackageName + "base") + (OrLaterVersion + (mkVersion + [0])) + mainLibSet, + Dependency + (PackageName + "str-string") + (OrLaterVersion + (mkVersion + [0])) + mainLibSet, + Dependency + (PackageName + "str-bytestring") + (OrLaterVersion + (mkVersion + [0])) + mainLibSet], + virtualModules = []}, + exeName = UnqualComponentName "str-example", + exeScope = ExecutablePublic, + modulePath = "Main.hs"}}], + condForeignLibs = [], + condLibrary = Nothing, + condSubLibraries = [], + condTestSuites = [], + genPackageFlags = [], + gpdScannedVersion = Nothing, + packageDescription = PackageDescription + {author = "", + benchmarks = [], + bugReports = "", + buildTypeRaw = Just Simple, + category = "", + copyright = "", + customFieldsPD = [], + dataDir = ".", + dataFiles = [], + description = "", + executables = [], + extraDocFiles = [], + extraSrcFiles = [], + extraTmpFiles = [], + foreignLibs = [], + homepage = "", + library = Nothing, + licenseFiles = [], + licenseRaw = Left NONE, + maintainer = "", + package = PackageIdentifier + {pkgName = PackageName "mixin", pkgVersion = mkVersion [0]}, + pkgUrl = "", + setupBuildInfo = Nothing, + sourceRepos = [], + specVersion = CabalSpecV2_0, + stability = "", + subLibraries = [], + synopsis = "", + testSuites = [], + testedWith = []}} diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/mixin-1.format b/cabal/Cabal-tests/tests/ParserTests/regressions/mixin-1.format new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/mixin-1.format @@ -0,0 +1,16 @@ +cabal-version: 2.0 +name: mixin +version: 0 +build-type: Simple + +executable str-example + main-is: Main.hs + hs-source-dirs: str-example + build-depends: + base, + str-string, + str-bytestring + + mixins: + str-string (Str as Str.String), + str-bytestring (Str as Str.ByteString) diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/mixin-2.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/mixin-2.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/mixin-2.cabal @@ -0,0 +1,13 @@ +cabal-version: 3.0 +name: mixin +version: 0 + +-- mixin field: +-- in 2.2 we got leading/trailing commas +-- in 3.0 we got lax space parsing +executable str-example + main-is: Main.hs + build-depends: base, str-string, str-bytestring + mixins: str-string ( Str as Str.String ), + str-bytestring ( Str as Str.ByteString ), + hs-source-dirs: str-example diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/mixin-2.expr b/cabal/Cabal-tests/tests/ParserTests/regressions/mixin-2.expr new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/mixin-2.expr @@ -0,0 +1,151 @@ +GenericPackageDescription + {condBenchmarks = [], + condExecutables = [_×_ + (UnqualComponentName "str-example") + CondNode + {condTreeComponents = [], + condTreeConstraints = [Dependency + (PackageName "base") + (OrLaterVersion (mkVersion [0])) + mainLibSet, + Dependency + (PackageName "str-string") + (OrLaterVersion (mkVersion [0])) + mainLibSet, + Dependency + (PackageName "str-bytestring") + (OrLaterVersion (mkVersion [0])) + mainLibSet], + condTreeData = Executable + {buildInfo = BuildInfo + {asmOptions = [], + asmSources = [], + autogenIncludes = [], + autogenModules = [], + buildToolDepends = [], + buildTools = [], + buildable = True, + cSources = [], + ccOptions = [], + cmmOptions = [], + cmmSources = [], + cppOptions = [], + customFieldsBI = [], + cxxOptions = [], + cxxSources = [], + defaultExtensions = [], + defaultLanguage = Nothing, + extraBundledLibs = [], + extraDynLibFlavours = [], + extraFrameworkDirs = [], + extraGHCiLibs = [], + extraLibDirs = [], + extraLibDirsStatic = [], + extraLibFlavours = [], + extraLibs = [], + extraLibsStatic = [], + frameworks = [], + hsSourceDirs = [SymbolicPath + "str-example"], + hsc2hsOptions = [], + includeDirs = [], + includes = [], + installIncludes = [], + jsSources = [], + ldOptions = [], + mixins = [Mixin + {mixinIncludeRenaming = IncludeRenaming + {includeProvidesRn = ModuleRenaming + [_×_ + (ModuleName + "Str") + (ModuleName + "Str.String")], + includeRequiresRn = DefaultRenaming}, + mixinLibraryName = LMainLibName, + mixinPackageName = PackageName + "str-string"}, + Mixin + {mixinIncludeRenaming = IncludeRenaming + {includeProvidesRn = ModuleRenaming + [_×_ + (ModuleName + "Str") + (ModuleName + "Str.ByteString")], + includeRequiresRn = DefaultRenaming}, + mixinLibraryName = LMainLibName, + mixinPackageName = PackageName + "str-bytestring"}], + oldExtensions = [], + options = PerCompilerFlavor [] [], + otherExtensions = [], + otherLanguages = [], + otherModules = [], + pkgconfigDepends = [], + profOptions = PerCompilerFlavor [] [], + sharedOptions = PerCompilerFlavor [] [], + staticOptions = PerCompilerFlavor [] [], + targetBuildDepends = [Dependency + (PackageName + "base") + (OrLaterVersion + (mkVersion + [0])) + mainLibSet, + Dependency + (PackageName + "str-string") + (OrLaterVersion + (mkVersion + [0])) + mainLibSet, + Dependency + (PackageName + "str-bytestring") + (OrLaterVersion + (mkVersion + [0])) + mainLibSet], + virtualModules = []}, + exeName = UnqualComponentName "str-example", + exeScope = ExecutablePublic, + modulePath = "Main.hs"}}], + condForeignLibs = [], + condLibrary = Nothing, + condSubLibraries = [], + condTestSuites = [], + genPackageFlags = [], + gpdScannedVersion = Nothing, + packageDescription = PackageDescription + {author = "", + benchmarks = [], + bugReports = "", + buildTypeRaw = Nothing, + category = "", + copyright = "", + customFieldsPD = [], + dataDir = ".", + dataFiles = [], + description = "", + executables = [], + extraDocFiles = [], + extraSrcFiles = [], + extraTmpFiles = [], + foreignLibs = [], + homepage = "", + library = Nothing, + licenseFiles = [], + licenseRaw = Left NONE, + maintainer = "", + package = PackageIdentifier + {pkgName = PackageName "mixin", pkgVersion = mkVersion [0]}, + pkgUrl = "", + setupBuildInfo = Nothing, + sourceRepos = [], + specVersion = CabalSpecV3_0, + stability = "", + subLibraries = [], + synopsis = "", + testSuites = [], + testedWith = []}} diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/mixin-2.format b/cabal/Cabal-tests/tests/ParserTests/regressions/mixin-2.format new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/mixin-2.format @@ -0,0 +1,15 @@ +cabal-version: 3.0 +name: mixin +version: 0 + +executable str-example + main-is: Main.hs + hs-source-dirs: str-example + build-depends: + base, + str-string, + str-bytestring + + mixins: + str-string (Str as Str.String), + str-bytestring (Str as Str.ByteString) diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/mixin-3.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/mixin-3.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/mixin-3.cabal @@ -0,0 +1,12 @@ +cabal-version: 3.0 +name: mixin +version: 0 + +-- mixin field: +-- in 2.2 we got leading/trailing commas +-- in 3.0 we got lax space parsing +executable str-example + main-is: Main.hs + build-depends: base, str-string, str-bytestring + mixins: str hiding ( Foo ) + hs-source-dirs: str-example diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/mixin-3.expr b/cabal/Cabal-tests/tests/ParserTests/regressions/mixin-3.expr new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/mixin-3.expr @@ -0,0 +1,136 @@ +GenericPackageDescription + {condBenchmarks = [], + condExecutables = [_×_ + (UnqualComponentName "str-example") + CondNode + {condTreeComponents = [], + condTreeConstraints = [Dependency + (PackageName "base") + (OrLaterVersion (mkVersion [0])) + mainLibSet, + Dependency + (PackageName "str-string") + (OrLaterVersion (mkVersion [0])) + mainLibSet, + Dependency + (PackageName "str-bytestring") + (OrLaterVersion (mkVersion [0])) + mainLibSet], + condTreeData = Executable + {buildInfo = BuildInfo + {asmOptions = [], + asmSources = [], + autogenIncludes = [], + autogenModules = [], + buildToolDepends = [], + buildTools = [], + buildable = True, + cSources = [], + ccOptions = [], + cmmOptions = [], + cmmSources = [], + cppOptions = [], + customFieldsBI = [], + cxxOptions = [], + cxxSources = [], + defaultExtensions = [], + defaultLanguage = Nothing, + extraBundledLibs = [], + extraDynLibFlavours = [], + extraFrameworkDirs = [], + extraGHCiLibs = [], + extraLibDirs = [], + extraLibDirsStatic = [], + extraLibFlavours = [], + extraLibs = [], + extraLibsStatic = [], + frameworks = [], + hsSourceDirs = [SymbolicPath + "str-example"], + hsc2hsOptions = [], + includeDirs = [], + includes = [], + installIncludes = [], + jsSources = [], + ldOptions = [], + mixins = [Mixin + {mixinIncludeRenaming = IncludeRenaming + {includeProvidesRn = HidingRenaming + [ModuleName + "Foo"], + includeRequiresRn = DefaultRenaming}, + mixinLibraryName = LMainLibName, + mixinPackageName = PackageName + "str"}], + oldExtensions = [], + options = PerCompilerFlavor [] [], + otherExtensions = [], + otherLanguages = [], + otherModules = [], + pkgconfigDepends = [], + profOptions = PerCompilerFlavor [] [], + sharedOptions = PerCompilerFlavor [] [], + staticOptions = PerCompilerFlavor [] [], + targetBuildDepends = [Dependency + (PackageName + "base") + (OrLaterVersion + (mkVersion + [0])) + mainLibSet, + Dependency + (PackageName + "str-string") + (OrLaterVersion + (mkVersion + [0])) + mainLibSet, + Dependency + (PackageName + "str-bytestring") + (OrLaterVersion + (mkVersion + [0])) + mainLibSet], + virtualModules = []}, + exeName = UnqualComponentName "str-example", + exeScope = ExecutablePublic, + modulePath = "Main.hs"}}], + condForeignLibs = [], + condLibrary = Nothing, + condSubLibraries = [], + condTestSuites = [], + genPackageFlags = [], + gpdScannedVersion = Nothing, + packageDescription = PackageDescription + {author = "", + benchmarks = [], + bugReports = "", + buildTypeRaw = Nothing, + category = "", + copyright = "", + customFieldsPD = [], + dataDir = ".", + dataFiles = [], + description = "", + executables = [], + extraDocFiles = [], + extraSrcFiles = [], + extraTmpFiles = [], + foreignLibs = [], + homepage = "", + library = Nothing, + licenseFiles = [], + licenseRaw = Left NONE, + maintainer = "", + package = PackageIdentifier + {pkgName = PackageName "mixin", pkgVersion = mkVersion [0]}, + pkgUrl = "", + setupBuildInfo = Nothing, + sourceRepos = [], + specVersion = CabalSpecV3_0, + stability = "", + subLibraries = [], + synopsis = "", + testSuites = [], + testedWith = []}} diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/mixin-3.format b/cabal/Cabal-tests/tests/ParserTests/regressions/mixin-3.format new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/mixin-3.format @@ -0,0 +1,13 @@ +cabal-version: 3.0 +name: mixin +version: 0 + +executable str-example + main-is: Main.hs + hs-source-dirs: str-example + build-depends: + base, + str-string, + str-bytestring + + mixins: str hiding (Foo) diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/monad-param.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/monad-param.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/monad-param.cabal @@ -0,0 +1,25 @@ +name: monad-param +category: Control +version: 0.0.1 +synopsis: Parameterized monads +description: Implements parameterized monads by overloading the monad sugar with more liberal types. +stability: alpha +author: Edward Kmett +maintainer: Edward Kmett +copyright: Copyright (C) 2006-2007, Edward Kmett +homepage: http://comonad.com/haskell/monad-param/dist/doc/html/Control-Monad-Parameterized.html +package-url: http://comonad.com/haskell/monad-param +build-depends: base -any, mtl -any, stm -any +cabal-version: -any +license: BSD3 +license-file: LICENSE +buildable: True +extensions: MultiParamTypeClasses + FunctionalDependencies + OverlappingInstances + UndecidableInstances + EmptyDataDecls + NoImplicitPrelude +exposed-modules: Control.Monad.Parameterized +ghc-options: -funbox-strict-fields -threaded -fasm +hs-source-dirs: src diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/monad-param.expr b/cabal/Cabal-tests/tests/ParserTests/regressions/monad-param.expr new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/monad-param.expr @@ -0,0 +1,158 @@ +GenericPackageDescription { + packageDescription = + PackageDescription { + specVersion = CabalSpecV1_0, + package = PackageIdentifier { + pkgName = PackageName + "monad-param", + pkgVersion = mkVersion + [0, 0, 1]}, + licenseRaw = Right BSD3, + licenseFiles = [ + SymbolicPath "LICENSE"], + copyright = + "Copyright (C) 2006-2007, Edward Kmett", + maintainer = + "Edward Kmett ", + author = + "Edward Kmett ", + stability = "alpha", + testedWith = [], + homepage = + "http://comonad.com/haskell/monad-param/dist/doc/html/Control-Monad-Parameterized.html", + pkgUrl = + "http://comonad.com/haskell/monad-param", + bugReports = "", + sourceRepos = [], + synopsis = + "Parameterized monads", + description = + "Implements parameterized monads by overloading the monad sugar with more liberal types.", + category = "Control", + customFieldsPD = [], + buildTypeRaw = Nothing, + setupBuildInfo = Nothing, + library = Nothing, + subLibraries = [], + executables = [], + foreignLibs = [], + testSuites = [], + benchmarks = [], + dataFiles = [], + dataDir = ".", + extraSrcFiles = [], + extraTmpFiles = [], + extraDocFiles = []}, + gpdScannedVersion = Nothing, + genPackageFlags = [], + condLibrary = Just + CondNode { + condTreeData = Library { + libName = LMainLibName, + exposedModules = [ + ModuleName + "Control.Monad.Parameterized"], + reexportedModules = [], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPublic, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [ + SymbolicPath "src"], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [ + EnableExtension + MultiParamTypeClasses, + EnableExtension + FunctionalDependencies, + EnableExtension + OverlappingInstances, + EnableExtension + UndecidableInstances, + EnableExtension EmptyDataDecls, + DisableExtension + ImplicitPrelude], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [ + "-funbox-strict-fields", + "-threaded", + "-fasm"] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + Dependency + (PackageName "base") + (OrLaterVersion (mkVersion [0])) + mainLibSet, + Dependency + (PackageName "mtl") + (OrLaterVersion (mkVersion [0])) + mainLibSet, + Dependency + (PackageName "stm") + (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 = [], + condExecutables = [], + condTestSuites = [], + condBenchmarks = []} diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/monad-param.format b/cabal/Cabal-tests/tests/ParserTests/regressions/monad-param.format new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/monad-param.format @@ -0,0 +1,31 @@ +monad-param.cabal:19:3: Tabs used as indentation at 19:3, 20:3 +name: monad-param +version: 0.0.1 +license: BSD3 +license-file: LICENSE +copyright: Copyright (C) 2006-2007, Edward Kmett +maintainer: Edward Kmett +author: Edward Kmett +stability: alpha +homepage: + http://comonad.com/haskell/monad-param/dist/doc/html/Control-Monad-Parameterized.html + +package-url: http://comonad.com/haskell/monad-param +synopsis: Parameterized monads +description: + Implements parameterized monads by overloading the monad sugar with more liberal types. + +category: Control + +library + exposed-modules: Control.Monad.Parameterized + hs-source-dirs: src + extensions: + MultiParamTypeClasses FunctionalDependencies OverlappingInstances + UndecidableInstances EmptyDataDecls NoImplicitPrelude + + ghc-options: -funbox-strict-fields -threaded -fasm + build-depends: + base, + mtl, + stm diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/multiple-libs-2.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/multiple-libs-2.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/multiple-libs-2.cabal @@ -0,0 +1,17 @@ +cabal-version: 2.0 +name: multiple-libs +version: 0 + +synopsis: visible flag only since 3.0 +build-type: Simple + +library + default-language: Haskell2010 + exposed-modules: ElseIf + build-depends: base + +library public + default-language: Haskell2010 + exposed-modules: ElseIf2 + build-depends: base + visibility: public diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/multiple-libs-2.check b/cabal/Cabal-tests/tests/ParserTests/regressions/multiple-libs-2.check new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/multiple-libs-2.check @@ -0,0 +1,6 @@ +multiple-libs-2.cabal:17:3: The field "visibility" is available only since the Cabal specification version 3.0. This field will be ignored. +No 'category' field. +No 'maintainer' field. +No 'description' field. +The 'license' field is missing or is NONE. +The dependency 'build-depends: base' does not specify an upper bound on the version number. Each major release of the 'base' package changes the API in various ways and most packages will need some changes to compile with it. The recommended practice is to specify an upper bound on the version of the 'base' package. This ensures your package will continue to build when a new major version of the 'base' package is released. If you are not sure what upper bound to use then use the next major version. For example if you have tested your package with 'base' version 4.5 and 4.6 then use 'build-depends: base >= 4.5 && < 4.7'. diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/multiple-libs-2.expr b/cabal/Cabal-tests/tests/ParserTests/regressions/multiple-libs-2.expr new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/multiple-libs-2.expr @@ -0,0 +1,178 @@ +GenericPackageDescription + {condBenchmarks = [], + condExecutables = [], + condForeignLibs = [], + condLibrary = Just + CondNode + {condTreeComponents = [], + condTreeConstraints = [Dependency + (PackageName "base") + (OrLaterVersion (mkVersion [0])) + mainLibSet], + condTreeData = Library + {exposedModules = [ModuleName "ElseIf"], + libBuildInfo = BuildInfo + {asmOptions = [], + asmSources = [], + autogenIncludes = [], + autogenModules = [], + buildToolDepends = [], + buildTools = [], + buildable = True, + cSources = [], + ccOptions = [], + cmmOptions = [], + cmmSources = [], + cppOptions = [], + customFieldsBI = [], + cxxOptions = [], + cxxSources = [], + defaultExtensions = [], + defaultLanguage = Just Haskell2010, + extraBundledLibs = [], + extraDynLibFlavours = [], + extraFrameworkDirs = [], + extraGHCiLibs = [], + extraLibDirs = [], + extraLibDirsStatic = [], + extraLibFlavours = [], + extraLibs = [], + extraLibsStatic = [], + frameworks = [], + hsSourceDirs = [], + hsc2hsOptions = [], + includeDirs = [], + includes = [], + installIncludes = [], + jsSources = [], + ldOptions = [], + mixins = [], + oldExtensions = [], + options = PerCompilerFlavor [] [], + otherExtensions = [], + otherLanguages = [], + otherModules = [], + pkgconfigDepends = [], + profOptions = PerCompilerFlavor [] [], + sharedOptions = PerCompilerFlavor [] [], + staticOptions = PerCompilerFlavor [] [], + targetBuildDepends = [Dependency + (PackageName + "base") + (OrLaterVersion + (mkVersion + [0])) + mainLibSet], + virtualModules = []}, + libExposed = True, + libName = LMainLibName, + libVisibility = LibraryVisibilityPublic, + reexportedModules = [], + signatures = []}}, + condSubLibraries = [_×_ + (UnqualComponentName "public") + CondNode + {condTreeComponents = [], + condTreeConstraints = [Dependency + (PackageName "base") + (OrLaterVersion (mkVersion [0])) + mainLibSet], + condTreeData = Library + {exposedModules = [ModuleName "ElseIf2"], + libBuildInfo = BuildInfo + {asmOptions = [], + asmSources = [], + autogenIncludes = [], + autogenModules = [], + buildToolDepends = [], + buildTools = [], + buildable = True, + cSources = [], + ccOptions = [], + cmmOptions = [], + cmmSources = [], + cppOptions = [], + customFieldsBI = [], + cxxOptions = [], + cxxSources = [], + defaultExtensions = [], + defaultLanguage = Just Haskell2010, + extraBundledLibs = [], + extraDynLibFlavours = [], + extraFrameworkDirs = [], + extraGHCiLibs = [], + extraLibDirs = [], + extraLibDirsStatic = [], + extraLibFlavours = [], + extraLibs = [], + extraLibsStatic = [], + frameworks = [], + hsSourceDirs = [], + hsc2hsOptions = [], + includeDirs = [], + includes = [], + installIncludes = [], + jsSources = [], + ldOptions = [], + mixins = [], + oldExtensions = [], + options = PerCompilerFlavor [] [], + otherExtensions = [], + otherLanguages = [], + otherModules = [], + pkgconfigDepends = [], + profOptions = PerCompilerFlavor + [] [], + sharedOptions = PerCompilerFlavor + [] [], + staticOptions = PerCompilerFlavor + [] [], + targetBuildDepends = [Dependency + (PackageName + "base") + (OrLaterVersion + (mkVersion + [0])) + mainLibSet], + virtualModules = []}, + libExposed = True, + libName = LSubLibName (UnqualComponentName "public"), + libVisibility = LibraryVisibilityPrivate, + reexportedModules = [], + signatures = []}}], + condTestSuites = [], + genPackageFlags = [], + gpdScannedVersion = Nothing, + packageDescription = PackageDescription + {author = "", + benchmarks = [], + bugReports = "", + buildTypeRaw = Just Simple, + category = "", + copyright = "", + customFieldsPD = [], + dataDir = ".", + dataFiles = [], + description = "", + executables = [], + extraDocFiles = [], + extraSrcFiles = [], + extraTmpFiles = [], + foreignLibs = [], + homepage = "", + library = Nothing, + licenseFiles = [], + licenseRaw = Left NONE, + maintainer = "", + package = PackageIdentifier + {pkgName = PackageName "multiple-libs", + pkgVersion = mkVersion [0]}, + pkgUrl = "", + setupBuildInfo = Nothing, + sourceRepos = [], + specVersion = CabalSpecV2_0, + stability = "", + subLibraries = [], + synopsis = "visible flag only since 3.0", + testSuites = [], + testedWith = []}} diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/multiple-libs-2.format b/cabal/Cabal-tests/tests/ParserTests/regressions/multiple-libs-2.format new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/multiple-libs-2.format @@ -0,0 +1,16 @@ +multiple-libs-2.cabal:17:3: The field "visibility" is available only since the Cabal specification version 3.0. This field will be ignored. +cabal-version: 2.0 +name: multiple-libs +version: 0 +synopsis: visible flag only since 3.0 +build-type: Simple + +library + exposed-modules: ElseIf + default-language: Haskell2010 + build-depends: base + +library public + exposed-modules: ElseIf2 + default-language: Haskell2010 + build-depends: base diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/noVersion.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/noVersion.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/noVersion.cabal @@ -0,0 +1,11 @@ +name: noVersion +version: 0 +synopsis: -none in build-depends +build-type: Simple +cabal-version: 1.22 + +library + default-language: Haskell2010 + exposed-modules: ElseIf + + build-depends: bad-package -none diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/noVersion.expr b/cabal/Cabal-tests/tests/ParserTests/regressions/noVersion.expr new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/noVersion.expr @@ -0,0 +1,108 @@ +GenericPackageDescription + {condBenchmarks = [], + condExecutables = [], + condForeignLibs = [], + condLibrary = Just + CondNode + {condTreeComponents = [], + condTreeConstraints = [Dependency + (PackageName "bad-package") + (EarlierVersion (mkVersion [0])) + mainLibSet], + condTreeData = Library + {exposedModules = [ModuleName "ElseIf"], + libBuildInfo = BuildInfo + {asmOptions = [], + asmSources = [], + autogenIncludes = [], + autogenModules = [], + buildToolDepends = [], + buildTools = [], + buildable = True, + cSources = [], + ccOptions = [], + cmmOptions = [], + cmmSources = [], + cppOptions = [], + customFieldsBI = [], + cxxOptions = [], + cxxSources = [], + defaultExtensions = [], + defaultLanguage = Just Haskell2010, + extraBundledLibs = [], + extraDynLibFlavours = [], + extraFrameworkDirs = [], + extraGHCiLibs = [], + extraLibDirs = [], + extraLibDirsStatic = [], + extraLibFlavours = [], + extraLibs = [], + extraLibsStatic = [], + frameworks = [], + hsSourceDirs = [], + hsc2hsOptions = [], + includeDirs = [], + includes = [], + installIncludes = [], + jsSources = [], + ldOptions = [], + mixins = [], + oldExtensions = [], + options = PerCompilerFlavor [] [], + otherExtensions = [], + otherLanguages = [], + otherModules = [], + pkgconfigDepends = [], + profOptions = PerCompilerFlavor [] [], + sharedOptions = PerCompilerFlavor [] [], + staticOptions = PerCompilerFlavor [] [], + targetBuildDepends = [Dependency + (PackageName + "bad-package") + (EarlierVersion + (mkVersion + [0])) + mainLibSet], + virtualModules = []}, + libExposed = True, + libName = LMainLibName, + libVisibility = LibraryVisibilityPublic, + reexportedModules = [], + signatures = []}}, + condSubLibraries = [], + condTestSuites = [], + genPackageFlags = [], + gpdScannedVersion = Nothing, + packageDescription = PackageDescription + {author = "", + benchmarks = [], + bugReports = "", + buildTypeRaw = Just Simple, + category = "", + copyright = "", + customFieldsPD = [], + dataDir = ".", + dataFiles = [], + description = "", + executables = [], + extraDocFiles = [], + extraSrcFiles = [], + extraTmpFiles = [], + foreignLibs = [], + homepage = "", + library = Nothing, + licenseFiles = [], + licenseRaw = Left NONE, + maintainer = "", + package = PackageIdentifier + {pkgName = PackageName "noVersion", + pkgVersion = mkVersion [0]}, + pkgUrl = "", + setupBuildInfo = Nothing, + sourceRepos = [], + specVersion = CabalSpecV1_22, + stability = "", + subLibraries = [], + synopsis = "-none in build-depends", + testSuites = [], + testedWith = []}} diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/noVersion.format b/cabal/Cabal-tests/tests/ParserTests/regressions/noVersion.format new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/noVersion.format @@ -0,0 +1,10 @@ +cabal-version: 1.22 +name: noVersion +version: 0 +synopsis: -none in build-depends +build-type: Simple + +library + exposed-modules: ElseIf + default-language: Haskell2010 + build-depends: bad-package <0 diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/nothing-unicode.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/nothing-unicode.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/nothing-unicode.cabal @@ -0,0 +1,21 @@ +name: 無 +version: 0 +synopsis: The canonical non-package 無 +build-type: Simple +cabal-version: >=1.10 +x-無: 無 + +source-repository head + Type: git + Location: https://github.com/hvr/-.git + +flag 無 + description: 無 + +library + default-language: Haskell2010 + + exposed-modules: Ω + + if !flag(無) + buildable:False diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/nothing-unicode.check b/cabal/Cabal-tests/tests/ParserTests/regressions/nothing-unicode.check new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/nothing-unicode.check @@ -0,0 +1,6 @@ +No 'category' field. +No 'maintainer' field. +No 'description' field. +The 'license' field is missing or is NONE. +Suspicious flag names: 無. To avoid ambiguity in command line interfaces, flag shouldn't start with a dash. Also for better compatibility, flag names shouldn't contain non-ascii characters. +Non ascii custom fields: x-無. For better compatibility, custom field names shouldn't contain non-ascii characters. diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/nothing-unicode.expr b/cabal/Cabal-tests/tests/ParserTests/regressions/nothing-unicode.expr new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/nothing-unicode.expr @@ -0,0 +1,176 @@ +GenericPackageDescription + {condBenchmarks = [], + condExecutables = [], + condForeignLibs = [], + condLibrary = Just + CondNode + {condTreeComponents = [CondBranch + {condBranchCondition = `CNot (Var (PackageFlag (FlagName "\\28961")))`, + condBranchIfFalse = Nothing, + condBranchIfTrue = CondNode + {condTreeComponents = [], + condTreeConstraints = [], + condTreeData = Library + {exposedModules = [], + libBuildInfo = BuildInfo + {asmOptions = [], + asmSources = [], + autogenIncludes = [], + autogenModules = [], + buildToolDepends = [], + buildTools = [], + buildable = False, + cSources = [], + ccOptions = [], + cmmOptions = [], + cmmSources = [], + cppOptions = [], + customFieldsBI = [], + cxxOptions = [], + cxxSources = [], + defaultExtensions = [], + defaultLanguage = Nothing, + extraBundledLibs = [], + extraDynLibFlavours = [], + extraFrameworkDirs = [], + extraGHCiLibs = [], + extraLibDirs = [], + extraLibDirsStatic = [], + extraLibFlavours = [], + extraLibs = [], + extraLibsStatic = [], + frameworks = [], + hsSourceDirs = [], + hsc2hsOptions = [], + includeDirs = [], + includes = [], + installIncludes = [], + jsSources = [], + ldOptions = [], + mixins = [], + oldExtensions = [], + options = PerCompilerFlavor + [] + [], + otherExtensions = [], + otherLanguages = [], + otherModules = [], + pkgconfigDepends = [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = PerCompilerFlavor + [] + [], + staticOptions = PerCompilerFlavor + [] + [], + targetBuildDepends = [], + virtualModules = []}, + libExposed = True, + libName = LMainLibName, + libVisibility = LibraryVisibilityPublic, + reexportedModules = [], + signatures = []}}}], + condTreeConstraints = [], + condTreeData = Library + {exposedModules = [ModuleName "\937"], + libBuildInfo = BuildInfo + {asmOptions = [], + asmSources = [], + autogenIncludes = [], + autogenModules = [], + buildToolDepends = [], + buildTools = [], + buildable = True, + cSources = [], + ccOptions = [], + cmmOptions = [], + cmmSources = [], + cppOptions = [], + customFieldsBI = [], + cxxOptions = [], + cxxSources = [], + defaultExtensions = [], + defaultLanguage = Just Haskell2010, + extraBundledLibs = [], + extraDynLibFlavours = [], + extraFrameworkDirs = [], + extraGHCiLibs = [], + extraLibDirs = [], + extraLibDirsStatic = [], + extraLibFlavours = [], + extraLibs = [], + extraLibsStatic = [], + frameworks = [], + hsSourceDirs = [], + hsc2hsOptions = [], + includeDirs = [], + includes = [], + installIncludes = [], + jsSources = [], + ldOptions = [], + mixins = [], + oldExtensions = [], + options = PerCompilerFlavor [] [], + otherExtensions = [], + otherLanguages = [], + otherModules = [], + pkgconfigDepends = [], + profOptions = PerCompilerFlavor [] [], + sharedOptions = PerCompilerFlavor [] [], + staticOptions = PerCompilerFlavor [] [], + targetBuildDepends = [], + virtualModules = []}, + libExposed = True, + libName = LMainLibName, + libVisibility = LibraryVisibilityPublic, + reexportedModules = [], + signatures = []}}, + condSubLibraries = [], + condTestSuites = [], + genPackageFlags = [MkPackageFlag + {flagDefault = True, + flagDescription = "\28961", + flagManual = False, + flagName = FlagName "\28961"}], + gpdScannedVersion = Nothing, + packageDescription = PackageDescription + {author = "", + benchmarks = [], + bugReports = "", + buildTypeRaw = Just Simple, + category = "", + copyright = "", + customFieldsPD = [_×_ "x-\28961" "\28961"], + dataDir = ".", + dataFiles = [], + description = "", + executables = [], + extraDocFiles = [], + extraSrcFiles = [], + extraTmpFiles = [], + foreignLibs = [], + homepage = "", + library = Nothing, + licenseFiles = [], + licenseRaw = Left NONE, + maintainer = "", + package = PackageIdentifier + {pkgName = PackageName "\28961", pkgVersion = mkVersion [0]}, + pkgUrl = "", + setupBuildInfo = Nothing, + sourceRepos = [SourceRepo + {repoBranch = Nothing, + repoKind = RepoHead, + repoLocation = Just "https://github.com/hvr/-.git", + repoModule = Nothing, + repoSubdir = Nothing, + repoTag = Nothing, + repoType = Just (KnownRepoType Git)}], + specVersion = CabalSpecV1_10, + stability = "", + subLibraries = [], + synopsis = "The canonical non-package \28961", + testSuites = [], + testedWith = []}} diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/nothing-unicode.format b/cabal/Cabal-tests/tests/ParserTests/regressions/nothing-unicode.format new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/nothing-unicode.format @@ -0,0 +1,20 @@ +cabal-version: >=1.10 +name: 無 +version: 0 +synopsis: The canonical non-package 無 +x-無: 無 +build-type: Simple + +source-repository head + type: git + location: https://github.com/hvr/-.git + +flag 無 + description: 無 + +library + exposed-modules: Ω + default-language: Haskell2010 + + if !flag(無) + buildable: False diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/pre-1.6-glob.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/pre-1.6-glob.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/pre-1.6-glob.cabal @@ -0,0 +1,17 @@ +cabal-version: >= 1.4 +name: pre-1dot6-glob +version: 0 +license: BSD3 +license-file: pre-1.6-glob.cabal +synopsis: no +description: none +build-type: Simple +category: Test +maintainer: none + +extra-source-files: + foo/*.hs + +library + exposed-modules: + Foo diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/pre-1.6-glob.check b/cabal/Cabal-tests/tests/ParserTests/regressions/pre-1.6-glob.check new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/pre-1.6-glob.check @@ -0,0 +1,1 @@ +In the 'extra-source-files' field: invalid file glob 'foo/*.hs'. Using star wildcards requires 'cabal-version: >= 1.6'. Alternatively if you require compatibility with earlier Cabal versions then list all the files explicitly. diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/pre-2.4-globstar.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/pre-2.4-globstar.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/pre-2.4-globstar.cabal @@ -0,0 +1,19 @@ +cabal-version: 2.2 +name: pre-3dot0-globstar +version: 0 +extra-source-files: + foo/**/*.hs +extra-doc-files: + foo/**/*.html +data-files: + foo/**/*.dat +license: BSD-3-Clause +synopsis: no +description: none +category: Test +maintainer: none + +library + default-language: Haskell2010 + exposed-modules: + Foo diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/pre-2.4-globstar.check b/cabal/Cabal-tests/tests/ParserTests/regressions/pre-2.4-globstar.check new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/pre-2.4-globstar.check @@ -0,0 +1,3 @@ +In the 'data-files' field: invalid file glob 'foo/**/*.dat'. Using the double-star syntax requires 'cabal-version: 2.4' or greater. Alternatively, for compatibility with earlier Cabal versions, list the included directories explicitly. +In the 'extra-source-files' field: invalid file glob 'foo/**/*.hs'. Using the double-star syntax requires 'cabal-version: 2.4' or greater. Alternatively, for compatibility with earlier Cabal versions, list the included directories explicitly. +In the 'extra-doc-files' field: invalid file glob 'foo/**/*.html'. Using the double-star syntax requires 'cabal-version: 2.4' or greater. Alternatively, for compatibility with earlier Cabal versions, list the included directories explicitly. diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/pre-3.8-globstar-literal.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/pre-3.8-globstar-literal.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/pre-3.8-globstar-literal.cabal @@ -0,0 +1,16 @@ +cabal-version: 3.6 +name: globstar-literal +version: 0 +extra-source-files: + foo/**/bar + +license: BSD-3-Clause +synopsis: no +description: none +category: Test +maintainer: none + +library + default-language: Haskell2010 + exposed-modules: + Foo diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/pre-3.8-globstar-literal.check b/cabal/Cabal-tests/tests/ParserTests/regressions/pre-3.8-globstar-literal.check new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/pre-3.8-globstar-literal.check @@ -0,0 +1,1 @@ +In the 'extra-source-files' field: invalid file glob 'foo/**/bar'. Prior to 'cabal-version: 3.8' if a wildcard '**' is used as a parent directory, the file's base name must be a wildcard '*'. diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/public-multilib-1.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/public-multilib-1.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/public-multilib-1.cabal @@ -0,0 +1,17 @@ +cabal-version: 3.0 +name: public-multilib1 +version: 0 +synopsis: public-multilibs +category: Tests +license: MIT + +library + default-language: Haskell2010 + build-depends: base ^>=4.14, internal + exposed-modules: Foo + +library internal + default-language: Haskell2010 + build-depends: base ^>=4.14 + visibility: public + exposed-modules: Bar diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/public-multilib-1.check b/cabal/Cabal-tests/tests/ParserTests/regressions/public-multilib-1.check new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/public-multilib-1.check @@ -0,0 +1,2 @@ +No 'maintainer' field. +No 'description' field. diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/public-multilib-2.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/public-multilib-2.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/public-multilib-2.cabal @@ -0,0 +1,14 @@ +cabal-version: 3.0 +name: public-multilib1 +version: 0 +synopsis: public-multilibs +category: Tests +license: MIT + +library + default-language: Haskell2010 + build-depends: + , base ^>=4.14 + , somelib:internal + + exposed-modules: Foo diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/public-multilib-2.check b/cabal/Cabal-tests/tests/ParserTests/regressions/public-multilib-2.check new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/public-multilib-2.check @@ -0,0 +1,2 @@ +No 'maintainer' field. +No 'description' field. diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/shake.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/shake.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/shake.cabal @@ -0,0 +1,405 @@ +cabal-version: 1.18 +build-type: Simple +name: shake +version: 0.15.11 +license: BSD3 +license-file: LICENSE +category: Development, Shake +author: Neil Mitchell +maintainer: Neil Mitchell +copyright: Neil Mitchell 2011-2017 +synopsis: Build system library, like Make, but more accurate dependencies. +description: + Shake is a Haskell library for writing build systems - designed as a + replacement for @make@. See "Development.Shake" for an introduction, + including an example. Further examples are included in the Cabal tarball, + under the @Examples@ directory. The homepage contains links to a user + manual, an academic paper and further information: + + . + To use Shake the user writes a Haskell program + that imports "Development.Shake", defines some build rules, and calls + the 'Development.Shake.shakeArgs' function. Thanks to do notation and infix + operators, a simple Shake build system + is not too dissimilar from a simple Makefile. However, as build systems + get more complex, Shake is able to take advantage of the excellent + abstraction facilities offered by Haskell and easily support much larger + projects. The Shake library provides all the standard features available in other + build systems, including automatic parallelism and minimal rebuilds. + Shake also provides more accurate dependency tracking, including seamless + support for generated files, and dependencies on system information + (e.g. compiler version). +homepage: http://shakebuild.com +bug-reports: https://github.com/ndmitchell/shake/issues +tested-with: GHC==8.0.1, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2 +extra-doc-files: + CHANGES.txt + README.md +extra-source-files: + src/Test/C/constants.c + src/Test/C/constants.h + src/Test/C/main.c + src/Test/MakeTutor/Makefile + src/Test/MakeTutor/hellofunc.c + src/Test/MakeTutor/hellomake.c + src/Test/MakeTutor/hellomake.h + src/Test/Tar/list.txt + src/Test/Ninja/*.ninja + src/Test/Ninja/subdir/*.ninja + src/Test/Ninja/*.output + src/Test/Progress/*.prog + src/Test/Tup/hello.c + src/Test/Tup/root.cfg + src/Test/Tup/newmath/root.cfg + src/Test/Tup/newmath/square.c + src/Test/Tup/newmath/square.h + src/Paths.hs + docs/Manual.md + docs/shake-progress.png + +data-files: + html/viz.js + html/profile.html + html/progress.html + html/shake.js + docs/manual/build.bat + docs/manual/Build.hs + docs/manual/build.sh + docs/manual/constants.c + docs/manual/constants.h + docs/manual/main.c + +source-repository head + type: git + location: https://github.com/ndmitchell/shake.git + +flag portable + default: False + manual: True + description: Obtain FileTime using portable functions + +library + default-language: Haskell2010 + -- dot directory on own row + hs-source-dirs: + . + src + build-depends: + base >= 4.5, + directory, + hashable >= 1.1.2.3, + binary, + filepath, + process >= 1.1, + unordered-containers >= 0.2.1, + bytestring, + utf8-string >= 0.3, + time, + random, + js-jquery, + js-flot, + transformers >= 0.2, + extra >= 1.4.8, + deepseq >= 1.1 + + if flag(portable) + cpp-options: -DPORTABLE + if impl(ghc < 7.6) + build-depends: old-time + else + if !os(windows) + build-depends: unix >= 2.5.1 + if !os(windows) + build-depends: unix + + exposed-modules: + Development.Shake + Development.Shake.Classes + Development.Shake.Command + Development.Shake.Config + Development.Shake.FilePath + Development.Shake.Forward + Development.Shake.Rule + Development.Shake.Util + + other-modules: + Development.Ninja.Env + Development.Ninja.Lexer + Development.Ninja.Parse + Development.Ninja.Type + Development.Shake.Args + Development.Shake.ByteString + Development.Shake.Core + Development.Shake.CmdOption + Development.Shake.Database + Development.Shake.Demo + Development.Shake.Derived + Development.Shake.Errors + Development.Shake.FileInfo + Development.Shake.FilePattern + Development.Shake.Monad + Development.Shake.Pool + Development.Shake.Profile + Development.Shake.Progress + Development.Shake.Resource + Development.Shake.Rules.Directory + Development.Shake.Rules.File + Development.Shake.Rules.Files + Development.Shake.Rules.Oracle + Development.Shake.Rules.OrderOnly + Development.Shake.Rules.Rerun + Development.Shake.Shake + Development.Shake.Special + Development.Shake.Storage + Development.Shake.Types + Development.Shake.Value + General.Bilist + General.Binary + General.Cleanup + General.Concurrent + General.Extra + General.FileLock + General.Intern + General.Process + General.String + General.Template + General.Timing + Paths_shake + + +executable shake + default-language: Haskell2010 + hs-source-dirs: src + ghc-options: -main-is Run.main + main-is: Run.hs + ghc-options: -rtsopts + -- GHC bug 7646 means -threaded causes errors + if impl(ghc >= 7.8) + ghc-options: -threaded "-with-rtsopts=-I0 -qg -qb" + build-depends: + base == 4.*, + directory, + hashable >= 1.1.2.3, + binary, + filepath, + process >= 1.1, + unordered-containers >= 0.2.1, + bytestring, + utf8-string >= 0.3, + time, + random, + js-jquery, + js-flot, + transformers >= 0.2, + extra >= 1.4.8, + deepseq >= 1.1, + primitive + + if flag(portable) + cpp-options: -DPORTABLE + if impl(ghc < 7.6) + build-depends: old-time + else + if !os(windows) + build-depends: unix >= 2.5.1 + if !os(windows) + build-depends: unix + + other-modules: + Development.Make.All + Development.Make.Env + Development.Make.Parse + Development.Make.Rules + Development.Make.Type + Development.Ninja.All + Development.Ninja.Env + Development.Ninja.Lexer + Development.Ninja.Parse + Development.Ninja.Type + Development.Shake + Development.Shake.Args + Development.Shake.ByteString + Development.Shake.Classes + Development.Shake.CmdOption + Development.Shake.Command + Development.Shake.Core + Development.Shake.Database + Development.Shake.Demo + Development.Shake.Derived + Development.Shake.Errors + Development.Shake.FileInfo + Development.Shake.FilePath + Development.Shake.FilePattern + Development.Shake.Forward + Development.Shake.Monad + Development.Shake.Pool + Development.Shake.Profile + Development.Shake.Progress + Development.Shake.Resource + Development.Shake.Rule + Development.Shake.Rules.Directory + Development.Shake.Rules.File + Development.Shake.Rules.Files + Development.Shake.Rules.Oracle + Development.Shake.Rules.OrderOnly + Development.Shake.Rules.Rerun + Development.Shake.Shake + Development.Shake.Special + Development.Shake.Storage + Development.Shake.Types + Development.Shake.Value + General.Bilist + General.Binary + General.Cleanup + General.Concurrent + General.Extra + General.FileLock + General.Intern + General.Process + General.String + General.Template + General.Timing + Paths_shake + Run + + +test-suite shake-test + default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: Test.hs + hs-source-dirs: src + + ghc-options: -main-is Test.main -rtsopts + if impl(ghc >= 7.6) + -- space leak introduced by -O1 in 7.4, see #445 + ghc-options: -with-rtsopts=-K1K + if impl(ghc >= 7.8) + -- GHC bug 7646 (fixed in 7.8) means -threaded causes errors + ghc-options: -threaded + + build-depends: + base == 4.*, + directory, + hashable >= 1.1.2.3, + binary, + filepath, + process >= 1.1, + unordered-containers >= 0.2.1, + bytestring, + utf8-string >= 0.3, + time, + random, + js-jquery, + js-flot, + transformers >= 0.2, + deepseq >= 1.1, + extra >= 1.4.8, + QuickCheck >= 2.0 + + if flag(portable) + cpp-options: -DPORTABLE + if impl(ghc < 7.6) + build-depends: old-time + else + if !os(windows) + build-depends: unix >= 2.5.1 + if !os(windows) + build-depends: unix + + other-modules: + Development.Make.All + Development.Make.Env + Development.Make.Parse + Development.Make.Rules + Development.Make.Type + Development.Ninja.All + Development.Ninja.Env + Development.Ninja.Lexer + Development.Ninja.Parse + Development.Ninja.Type + Development.Shake + Development.Shake.Args + Development.Shake.ByteString + Development.Shake.Classes + Development.Shake.CmdOption + Development.Shake.Command + Development.Shake.Config + Development.Shake.Core + Development.Shake.Database + Development.Shake.Demo + Development.Shake.Derived + Development.Shake.Errors + Development.Shake.FileInfo + Development.Shake.FilePath + Development.Shake.FilePattern + Development.Shake.Forward + Development.Shake.Monad + Development.Shake.Pool + Development.Shake.Profile + Development.Shake.Progress + Development.Shake.Resource + Development.Shake.Rule + Development.Shake.Rules.Directory + Development.Shake.Rules.File + Development.Shake.Rules.Files + Development.Shake.Rules.Oracle + Development.Shake.Rules.OrderOnly + Development.Shake.Rules.Rerun + Development.Shake.Shake + Development.Shake.Special + Development.Shake.Storage + Development.Shake.Types + Development.Shake.Util + Development.Shake.Value + General.Bilist + General.Binary + General.Cleanup + General.Concurrent + General.Extra + General.FileLock + General.Intern + General.Process + General.String + General.Template + General.Timing + Paths_shake + Run + Test.Assume + Test.Basic + Test.Benchmark + Test.C + Test.Cache + Test.Command + Test.Config + Test.Digest + Test.Directory + Test.Docs + Test.Errors + Test.FileLock + Test.FilePath + Test.FilePattern + Test.Files + Test.Forward + Test.Journal + Test.Lint + Test.Live + Test.Makefile + Test.Manual + Test.Match + Test.Monad + Test.Ninja + Test.Oracle + Test.OrderOnly + Test.Parallel + Test.Pool + Test.Progress + Test.Random + Test.Resources + Test.Self + Test.Tar + Test.Tup + Test.Type + Test.Unicode + Test.Util + Test.Verbosity + Test.Version diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/shake.expr b/cabal/Cabal-tests/tests/ParserTests/regressions/shake.expr new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/shake.expr @@ -0,0 +1,2413 @@ +GenericPackageDescription { + packageDescription = + PackageDescription { + specVersion = CabalSpecV1_18, + package = PackageIdentifier { + pkgName = PackageName "shake", + pkgVersion = mkVersion + [0, 15, 11]}, + licenseRaw = Right BSD3, + licenseFiles = [ + SymbolicPath "LICENSE"], + copyright = + "Neil Mitchell 2011-2017", + maintainer = + "Neil Mitchell ", + author = + "Neil Mitchell ", + stability = "", + testedWith = [ + _×_ + GHC + (ThisVersion + (mkVersion [8, 0, 1])), + _×_ + GHC + (ThisVersion + (mkVersion [7, 10, 3])), + _×_ + GHC + (ThisVersion + (mkVersion [7, 8, 4])), + _×_ + GHC + (ThisVersion + (mkVersion [7, 6, 3])), + _×_ + GHC + (ThisVersion + (mkVersion [7, 4, 2]))], + homepage = + "http://shakebuild.com", + pkgUrl = "", + bugReports = + "https://github.com/ndmitchell/shake/issues", + sourceRepos = [ + SourceRepo { + repoKind = RepoHead, + repoType = Just + (KnownRepoType Git), + repoLocation = Just + "https://github.com/ndmitchell/shake.git", + repoModule = Nothing, + repoBranch = Nothing, + repoTag = Nothing, + repoSubdir = Nothing}], + synopsis = + "Build system library, like Make, but more accurate dependencies.", + description = + concat + [ + "Shake is a Haskell library for writing build systems - designed as a\n", + "replacement for @make@. See \"Development.Shake\" for an introduction,\n", + "including an example. Further examples are included in the Cabal tarball,\n", + "under the @Examples@ directory. The homepage contains links to a user\n", + "manual, an academic paper and further information:\n", + "\n", + "\n", + "To use Shake the user writes a Haskell program\n", + "that imports \"Development.Shake\", defines some build rules, and calls\n", + "the 'Development.Shake.shakeArgs' function. Thanks to do notation and infix\n", + "operators, a simple Shake build system\n", + "is not too dissimilar from a simple Makefile. However, as build systems\n", + "get more complex, Shake is able to take advantage of the excellent\n", + "abstraction facilities offered by Haskell and easily support much larger\n", + "projects. The Shake library provides all the standard features available in other\n", + "build systems, including automatic parallelism and minimal rebuilds.\n", + "Shake also provides more accurate dependency tracking, including seamless\n", + "support for generated files, and dependencies on system information\n", + "(e.g. compiler version)."], + category = "Development, Shake", + customFieldsPD = [], + buildTypeRaw = Just Simple, + setupBuildInfo = Nothing, + library = Nothing, + subLibraries = [], + executables = [], + foreignLibs = [], + testSuites = [], + benchmarks = [], + dataFiles = [ + "html/viz.js", + "html/profile.html", + "html/progress.html", + "html/shake.js", + "docs/manual/build.bat", + "docs/manual/Build.hs", + "docs/manual/build.sh", + "docs/manual/constants.c", + "docs/manual/constants.h", + "docs/manual/main.c"], + dataDir = ".", + extraSrcFiles = [ + "src/Test/C/constants.c", + "src/Test/C/constants.h", + "src/Test/C/main.c", + "src/Test/MakeTutor/Makefile", + "src/Test/MakeTutor/hellofunc.c", + "src/Test/MakeTutor/hellomake.c", + "src/Test/MakeTutor/hellomake.h", + "src/Test/Tar/list.txt", + "src/Test/Ninja/*.ninja", + "src/Test/Ninja/subdir/*.ninja", + "src/Test/Ninja/*.output", + "src/Test/Progress/*.prog", + "src/Test/Tup/hello.c", + "src/Test/Tup/root.cfg", + "src/Test/Tup/newmath/root.cfg", + "src/Test/Tup/newmath/square.c", + "src/Test/Tup/newmath/square.h", + "src/Paths.hs", + "docs/Manual.md", + "docs/shake-progress.png"], + extraTmpFiles = [], + extraDocFiles = [ + "CHANGES.txt", + "README.md"]}, + gpdScannedVersion = Nothing, + genPackageFlags = [ + MkPackageFlag { + flagName = FlagName "portable", + flagDescription = + "Obtain FileTime using portable functions", + flagDefault = False, + flagManual = True}], + condLibrary = Just + CondNode { + condTreeData = Library { + libName = LMainLibName, + exposedModules = [ + ModuleName "Development.Shake", + ModuleName + "Development.Shake.Classes", + ModuleName + "Development.Shake.Command", + ModuleName + "Development.Shake.Config", + ModuleName + "Development.Shake.FilePath", + ModuleName + "Development.Shake.Forward", + ModuleName + "Development.Shake.Rule", + ModuleName + "Development.Shake.Util"], + reexportedModules = [], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPublic, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [ + SymbolicPath ".", + SymbolicPath "src"], + otherModules = [ + ModuleName + "Development.Ninja.Env", + ModuleName + "Development.Ninja.Lexer", + ModuleName + "Development.Ninja.Parse", + ModuleName + "Development.Ninja.Type", + ModuleName + "Development.Shake.Args", + ModuleName + "Development.Shake.ByteString", + ModuleName + "Development.Shake.Core", + ModuleName + "Development.Shake.CmdOption", + ModuleName + "Development.Shake.Database", + ModuleName + "Development.Shake.Demo", + ModuleName + "Development.Shake.Derived", + ModuleName + "Development.Shake.Errors", + ModuleName + "Development.Shake.FileInfo", + ModuleName + "Development.Shake.FilePattern", + ModuleName + "Development.Shake.Monad", + ModuleName + "Development.Shake.Pool", + ModuleName + "Development.Shake.Profile", + ModuleName + "Development.Shake.Progress", + ModuleName + "Development.Shake.Resource", + ModuleName + "Development.Shake.Rules.Directory", + ModuleName + "Development.Shake.Rules.File", + ModuleName + "Development.Shake.Rules.Files", + ModuleName + "Development.Shake.Rules.Oracle", + ModuleName + "Development.Shake.Rules.OrderOnly", + ModuleName + "Development.Shake.Rules.Rerun", + ModuleName + "Development.Shake.Shake", + ModuleName + "Development.Shake.Special", + ModuleName + "Development.Shake.Storage", + ModuleName + "Development.Shake.Types", + ModuleName + "Development.Shake.Value", + ModuleName "General.Bilist", + ModuleName "General.Binary", + ModuleName "General.Cleanup", + ModuleName "General.Concurrent", + ModuleName "General.Extra", + ModuleName "General.FileLock", + ModuleName "General.Intern", + ModuleName "General.Process", + ModuleName "General.String", + ModuleName "General.Template", + ModuleName "General.Timing", + ModuleName "Paths_shake"], + virtualModules = [], + autogenModules = [], + defaultLanguage = Just + Haskell2010, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + 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], + 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 = + `Var (PackageFlag (FlagName "portable"))`, + condBranchIfTrue = CondNode { + condTreeData = Library { + libName = LMainLibName, + exposedModules = [], + reexportedModules = [], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPublic, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = ["-DPORTABLE"], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [], + mixins = []}}, + condTreeConstraints = [], + condTreeComponents = [ + CondBranch { + condBranchCondition = + `Var (Impl GHC (EarlierVersion (mkVersion [7,6])))`, + condBranchIfTrue = CondNode { + condTreeData = Library { + libName = LMainLibName, + exposedModules = [], + reexportedModules = [], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPublic, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + Dependency + (PackageName "old-time") + (OrLaterVersion (mkVersion [0])) + mainLibSet], + mixins = []}}, + condTreeConstraints = [ + Dependency + (PackageName "old-time") + (OrLaterVersion (mkVersion [0])) + mainLibSet], + condTreeComponents = []}, + condBranchIfFalse = Nothing}]}, + condBranchIfFalse = Just + CondNode { + condTreeData = Library { + libName = LMainLibName, + exposedModules = [], + reexportedModules = [], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPublic, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [], + mixins = []}}, + condTreeConstraints = [], + condTreeComponents = [ + CondBranch { + condBranchCondition = + `CNot (Var (OS Windows))`, + condBranchIfTrue = CondNode { + condTreeData = Library { + libName = LMainLibName, + exposedModules = [], + reexportedModules = [], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPublic, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + Dependency + (PackageName "unix") + (OrLaterVersion + (mkVersion [2, 5, 1])) + mainLibSet], + mixins = []}}, + condTreeConstraints = [ + Dependency + (PackageName "unix") + (OrLaterVersion + (mkVersion [2, 5, 1])) + mainLibSet], + condTreeComponents = []}, + condBranchIfFalse = Nothing}]}}, + CondBranch { + condBranchCondition = + `CNot (Var (OS Windows))`, + condBranchIfTrue = CondNode { + condTreeData = Library { + libName = LMainLibName, + exposedModules = [], + reexportedModules = [], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPublic, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + Dependency + (PackageName "unix") + (OrLaterVersion (mkVersion [0])) + mainLibSet], + mixins = []}}, + condTreeConstraints = [ + Dependency + (PackageName "unix") + (OrLaterVersion (mkVersion [0])) + mainLibSet], + condTreeComponents = []}, + condBranchIfFalse = Nothing}]}, + condSubLibraries = [], + condForeignLibs = [], + condExecutables = [ + _×_ + (UnqualComponentName "shake") + CondNode { + condTreeData = Executable { + exeName = UnqualComponentName + "shake", + modulePath = "Run.hs", + exeScope = ExecutablePublic, + buildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [ + SymbolicPath "src"], + otherModules = [ + ModuleName + "Development.Make.All", + ModuleName + "Development.Make.Env", + ModuleName + "Development.Make.Parse", + ModuleName + "Development.Make.Rules", + ModuleName + "Development.Make.Type", + ModuleName + "Development.Ninja.All", + ModuleName + "Development.Ninja.Env", + ModuleName + "Development.Ninja.Lexer", + ModuleName + "Development.Ninja.Parse", + ModuleName + "Development.Ninja.Type", + ModuleName "Development.Shake", + ModuleName + "Development.Shake.Args", + ModuleName + "Development.Shake.ByteString", + ModuleName + "Development.Shake.Classes", + ModuleName + "Development.Shake.CmdOption", + ModuleName + "Development.Shake.Command", + ModuleName + "Development.Shake.Core", + ModuleName + "Development.Shake.Database", + ModuleName + "Development.Shake.Demo", + ModuleName + "Development.Shake.Derived", + ModuleName + "Development.Shake.Errors", + ModuleName + "Development.Shake.FileInfo", + ModuleName + "Development.Shake.FilePath", + ModuleName + "Development.Shake.FilePattern", + ModuleName + "Development.Shake.Forward", + ModuleName + "Development.Shake.Monad", + ModuleName + "Development.Shake.Pool", + ModuleName + "Development.Shake.Profile", + ModuleName + "Development.Shake.Progress", + ModuleName + "Development.Shake.Resource", + ModuleName + "Development.Shake.Rule", + ModuleName + "Development.Shake.Rules.Directory", + ModuleName + "Development.Shake.Rules.File", + ModuleName + "Development.Shake.Rules.Files", + ModuleName + "Development.Shake.Rules.Oracle", + ModuleName + "Development.Shake.Rules.OrderOnly", + ModuleName + "Development.Shake.Rules.Rerun", + ModuleName + "Development.Shake.Shake", + ModuleName + "Development.Shake.Special", + ModuleName + "Development.Shake.Storage", + ModuleName + "Development.Shake.Types", + ModuleName + "Development.Shake.Value", + ModuleName "General.Bilist", + ModuleName "General.Binary", + ModuleName "General.Cleanup", + ModuleName "General.Concurrent", + ModuleName "General.Extra", + ModuleName "General.FileLock", + ModuleName "General.Intern", + ModuleName "General.Process", + ModuleName "General.String", + ModuleName "General.Template", + ModuleName "General.Timing", + ModuleName "Paths_shake", + ModuleName "Run"], + virtualModules = [], + autogenModules = [], + defaultLanguage = Just + Haskell2010, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [ + "-main-is", + "Run.main", + "-rtsopts"] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + 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], + 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 = + `Var (Impl GHC (OrLaterVersion (mkVersion [7,8])))`, + condBranchIfTrue = CondNode { + condTreeData = Executable { + exeName = UnqualComponentName + "shake", + modulePath = "", + exeScope = ExecutablePublic, + buildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [ + "-threaded", + "-with-rtsopts=-I0 -qg -qb"] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [], + mixins = []}}, + condTreeConstraints = [], + condTreeComponents = []}, + condBranchIfFalse = Nothing}, + CondBranch { + condBranchCondition = + `Var (PackageFlag (FlagName "portable"))`, + condBranchIfTrue = CondNode { + condTreeData = Executable { + exeName = UnqualComponentName + "shake", + modulePath = "", + exeScope = ExecutablePublic, + buildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = ["-DPORTABLE"], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [], + mixins = []}}, + condTreeConstraints = [], + condTreeComponents = [ + CondBranch { + condBranchCondition = + `Var (Impl GHC (EarlierVersion (mkVersion [7,6])))`, + condBranchIfTrue = CondNode { + condTreeData = Executable { + exeName = UnqualComponentName + "shake", + modulePath = "", + exeScope = ExecutablePublic, + buildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + Dependency + (PackageName "old-time") + (OrLaterVersion (mkVersion [0])) + mainLibSet], + mixins = []}}, + condTreeConstraints = [ + Dependency + (PackageName "old-time") + (OrLaterVersion (mkVersion [0])) + mainLibSet], + condTreeComponents = []}, + condBranchIfFalse = Nothing}]}, + condBranchIfFalse = Just + CondNode { + condTreeData = Executable { + exeName = UnqualComponentName + "shake", + modulePath = "", + exeScope = ExecutablePublic, + buildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [], + mixins = []}}, + condTreeConstraints = [], + condTreeComponents = [ + CondBranch { + condBranchCondition = + `CNot (Var (OS Windows))`, + condBranchIfTrue = CondNode { + condTreeData = Executable { + exeName = UnqualComponentName + "shake", + modulePath = "", + exeScope = ExecutablePublic, + buildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + Dependency + (PackageName "unix") + (OrLaterVersion + (mkVersion [2, 5, 1])) + mainLibSet], + mixins = []}}, + condTreeConstraints = [ + Dependency + (PackageName "unix") + (OrLaterVersion + (mkVersion [2, 5, 1])) + mainLibSet], + condTreeComponents = []}, + condBranchIfFalse = Nothing}]}}, + CondBranch { + condBranchCondition = + `CNot (Var (OS Windows))`, + condBranchIfTrue = CondNode { + condTreeData = Executable { + exeName = UnqualComponentName + "shake", + modulePath = "", + exeScope = ExecutablePublic, + buildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + Dependency + (PackageName "unix") + (OrLaterVersion (mkVersion [0])) + mainLibSet], + mixins = []}}, + condTreeConstraints = [ + Dependency + (PackageName "unix") + (OrLaterVersion (mkVersion [0])) + mainLibSet], + condTreeComponents = []}, + condBranchIfFalse = Nothing}]}], + condTestSuites = [ + _×_ + (UnqualComponentName + "shake-test") + CondNode { + condTreeData = TestSuite { + testName = UnqualComponentName + "", + testInterface = TestSuiteExeV10 + (mkVersion [1, 0]) + "Test.hs", + testBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [ + SymbolicPath "src"], + otherModules = [ + ModuleName + "Development.Make.All", + ModuleName + "Development.Make.Env", + ModuleName + "Development.Make.Parse", + ModuleName + "Development.Make.Rules", + ModuleName + "Development.Make.Type", + ModuleName + "Development.Ninja.All", + ModuleName + "Development.Ninja.Env", + ModuleName + "Development.Ninja.Lexer", + ModuleName + "Development.Ninja.Parse", + ModuleName + "Development.Ninja.Type", + ModuleName "Development.Shake", + ModuleName + "Development.Shake.Args", + ModuleName + "Development.Shake.ByteString", + ModuleName + "Development.Shake.Classes", + ModuleName + "Development.Shake.CmdOption", + ModuleName + "Development.Shake.Command", + ModuleName + "Development.Shake.Config", + ModuleName + "Development.Shake.Core", + ModuleName + "Development.Shake.Database", + ModuleName + "Development.Shake.Demo", + ModuleName + "Development.Shake.Derived", + ModuleName + "Development.Shake.Errors", + ModuleName + "Development.Shake.FileInfo", + ModuleName + "Development.Shake.FilePath", + ModuleName + "Development.Shake.FilePattern", + ModuleName + "Development.Shake.Forward", + ModuleName + "Development.Shake.Monad", + ModuleName + "Development.Shake.Pool", + ModuleName + "Development.Shake.Profile", + ModuleName + "Development.Shake.Progress", + ModuleName + "Development.Shake.Resource", + ModuleName + "Development.Shake.Rule", + ModuleName + "Development.Shake.Rules.Directory", + ModuleName + "Development.Shake.Rules.File", + ModuleName + "Development.Shake.Rules.Files", + ModuleName + "Development.Shake.Rules.Oracle", + ModuleName + "Development.Shake.Rules.OrderOnly", + ModuleName + "Development.Shake.Rules.Rerun", + ModuleName + "Development.Shake.Shake", + ModuleName + "Development.Shake.Special", + ModuleName + "Development.Shake.Storage", + ModuleName + "Development.Shake.Types", + ModuleName + "Development.Shake.Util", + ModuleName + "Development.Shake.Value", + ModuleName "General.Bilist", + ModuleName "General.Binary", + ModuleName "General.Cleanup", + ModuleName "General.Concurrent", + ModuleName "General.Extra", + ModuleName "General.FileLock", + ModuleName "General.Intern", + ModuleName "General.Process", + ModuleName "General.String", + ModuleName "General.Template", + ModuleName "General.Timing", + ModuleName "Paths_shake", + ModuleName "Run", + ModuleName "Test.Assume", + ModuleName "Test.Basic", + ModuleName "Test.Benchmark", + ModuleName "Test.C", + ModuleName "Test.Cache", + ModuleName "Test.Command", + ModuleName "Test.Config", + ModuleName "Test.Digest", + ModuleName "Test.Directory", + ModuleName "Test.Docs", + ModuleName "Test.Errors", + ModuleName "Test.FileLock", + ModuleName "Test.FilePath", + ModuleName "Test.FilePattern", + ModuleName "Test.Files", + ModuleName "Test.Forward", + ModuleName "Test.Journal", + ModuleName "Test.Lint", + ModuleName "Test.Live", + ModuleName "Test.Makefile", + ModuleName "Test.Manual", + ModuleName "Test.Match", + ModuleName "Test.Monad", + ModuleName "Test.Ninja", + ModuleName "Test.Oracle", + ModuleName "Test.OrderOnly", + ModuleName "Test.Parallel", + ModuleName "Test.Pool", + ModuleName "Test.Progress", + ModuleName "Test.Random", + ModuleName "Test.Resources", + ModuleName "Test.Self", + ModuleName "Test.Tar", + ModuleName "Test.Tup", + ModuleName "Test.Type", + ModuleName "Test.Unicode", + ModuleName "Test.Util", + ModuleName "Test.Verbosity", + ModuleName "Test.Version"], + virtualModules = [], + autogenModules = [], + defaultLanguage = Just + Haskell2010, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [ + "-main-is", + "Test.main", + "-rtsopts"] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + 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], + 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 = + `Var (Impl GHC (OrLaterVersion (mkVersion [7,6])))`, + condBranchIfTrue = CondNode { + condTreeData = TestSuite { + testName = UnqualComponentName + "", + testInterface = + TestSuiteUnsupported + (TestTypeUnknown + "" + (mkVersion [])), + testBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + ["-with-rtsopts=-K1K"] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [], + mixins = []}, + testCodeGenerators = []}, + condTreeConstraints = [], + condTreeComponents = []}, + condBranchIfFalse = Nothing}, + CondBranch { + condBranchCondition = + `Var (Impl GHC (OrLaterVersion (mkVersion [7,8])))`, + condBranchIfTrue = CondNode { + condTreeData = TestSuite { + testName = UnqualComponentName + "", + testInterface = + TestSuiteUnsupported + (TestTypeUnknown + "" + (mkVersion [])), + testBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + ["-threaded"] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [], + mixins = []}, + testCodeGenerators = []}, + condTreeConstraints = [], + condTreeComponents = []}, + condBranchIfFalse = Nothing}, + CondBranch { + condBranchCondition = + `Var (PackageFlag (FlagName "portable"))`, + condBranchIfTrue = CondNode { + condTreeData = TestSuite { + testName = UnqualComponentName + "", + testInterface = + TestSuiteUnsupported + (TestTypeUnknown + "" + (mkVersion [])), + testBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = ["-DPORTABLE"], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [], + mixins = []}, + testCodeGenerators = []}, + condTreeConstraints = [], + condTreeComponents = [ + CondBranch { + condBranchCondition = + `Var (Impl GHC (EarlierVersion (mkVersion [7,6])))`, + condBranchIfTrue = CondNode { + condTreeData = TestSuite { + testName = UnqualComponentName + "", + testInterface = + TestSuiteUnsupported + (TestTypeUnknown + "" + (mkVersion [])), + testBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + Dependency + (PackageName "old-time") + (OrLaterVersion (mkVersion [0])) + mainLibSet], + mixins = []}, + testCodeGenerators = []}, + condTreeConstraints = [ + Dependency + (PackageName "old-time") + (OrLaterVersion (mkVersion [0])) + mainLibSet], + condTreeComponents = []}, + condBranchIfFalse = Nothing}]}, + condBranchIfFalse = Just + CondNode { + condTreeData = TestSuite { + testName = UnqualComponentName + "", + testInterface = + TestSuiteUnsupported + (TestTypeUnknown + "" + (mkVersion [])), + testBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [], + mixins = []}, + testCodeGenerators = []}, + condTreeConstraints = [], + condTreeComponents = [ + CondBranch { + condBranchCondition = + `CNot (Var (OS Windows))`, + condBranchIfTrue = CondNode { + condTreeData = TestSuite { + testName = UnqualComponentName + "", + testInterface = + TestSuiteUnsupported + (TestTypeUnknown + "" + (mkVersion [])), + testBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + Dependency + (PackageName "unix") + (OrLaterVersion + (mkVersion [2, 5, 1])) + mainLibSet], + mixins = []}, + testCodeGenerators = []}, + condTreeConstraints = [ + Dependency + (PackageName "unix") + (OrLaterVersion + (mkVersion [2, 5, 1])) + mainLibSet], + condTreeComponents = []}, + condBranchIfFalse = Nothing}]}}, + CondBranch { + condBranchCondition = + `CNot (Var (OS Windows))`, + condBranchIfTrue = CondNode { + condTreeData = TestSuite { + testName = UnqualComponentName + "", + testInterface = + TestSuiteUnsupported + (TestTypeUnknown + "" + (mkVersion [])), + testBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + Dependency + (PackageName "unix") + (OrLaterVersion (mkVersion [0])) + mainLibSet], + mixins = []}, + testCodeGenerators = []}, + condTreeConstraints = [ + Dependency + (PackageName "unix") + (OrLaterVersion (mkVersion [0])) + mainLibSet], + condTreeComponents = []}, + condBranchIfFalse = Nothing}]}], + condBenchmarks = []} diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/shake.format b/cabal/Cabal-tests/tests/ParserTests/regressions/shake.format new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/shake.format @@ -0,0 +1,412 @@ +cabal-version: 1.18 +name: shake +version: 0.15.11 +license: BSD3 +license-file: LICENSE +copyright: Neil Mitchell 2011-2017 +maintainer: Neil Mitchell +author: Neil Mitchell +tested-with: + ghc ==8.0.1 ghc ==7.10.3 ghc ==7.8.4 ghc ==7.6.3 ghc ==7.4.2 + +homepage: http://shakebuild.com +bug-reports: https://github.com/ndmitchell/shake/issues +synopsis: + Build system library, like Make, but more accurate dependencies. + +description: + Shake is a Haskell library for writing build systems - designed as a + replacement for @make@. See "Development.Shake" for an introduction, + including an example. Further examples are included in the Cabal tarball, + under the @Examples@ directory. The homepage contains links to a user + manual, an academic paper and further information: + + . + To use Shake the user writes a Haskell program + that imports "Development.Shake", defines some build rules, and calls + the 'Development.Shake.shakeArgs' function. Thanks to do notation and infix + operators, a simple Shake build system + is not too dissimilar from a simple Makefile. However, as build systems + get more complex, Shake is able to take advantage of the excellent + abstraction facilities offered by Haskell and easily support much larger + projects. The Shake library provides all the standard features available in other + build systems, including automatic parallelism and minimal rebuilds. + Shake also provides more accurate dependency tracking, including seamless + support for generated files, and dependencies on system information + (e.g. compiler version). + +category: Development, Shake +build-type: Simple +data-files: + html/viz.js + html/profile.html + html/progress.html + html/shake.js + docs/manual/build.bat + docs/manual/Build.hs + docs/manual/build.sh + docs/manual/constants.c + docs/manual/constants.h + docs/manual/main.c + +extra-source-files: + src/Test/C/constants.c + src/Test/C/constants.h + src/Test/C/main.c + src/Test/MakeTutor/Makefile + src/Test/MakeTutor/hellofunc.c + src/Test/MakeTutor/hellomake.c + src/Test/MakeTutor/hellomake.h + src/Test/Tar/list.txt + src/Test/Ninja/*.ninja + src/Test/Ninja/subdir/*.ninja + src/Test/Ninja/*.output + src/Test/Progress/*.prog + src/Test/Tup/hello.c + src/Test/Tup/root.cfg + src/Test/Tup/newmath/root.cfg + src/Test/Tup/newmath/square.c + src/Test/Tup/newmath/square.h + src/Paths.hs + docs/Manual.md + docs/shake-progress.png + +extra-doc-files: + CHANGES.txt + README.md + +source-repository head + type: git + location: https://github.com/ndmitchell/shake.git + +flag portable + description: Obtain FileTime using portable functions + default: False + manual: True + +library + exposed-modules: + Development.Shake + Development.Shake.Classes + Development.Shake.Command + Development.Shake.Config + Development.Shake.FilePath + Development.Shake.Forward + Development.Shake.Rule + Development.Shake.Util + + hs-source-dirs: . src + other-modules: + Development.Ninja.Env + Development.Ninja.Lexer + Development.Ninja.Parse + Development.Ninja.Type + Development.Shake.Args + Development.Shake.ByteString + Development.Shake.Core + Development.Shake.CmdOption + Development.Shake.Database + Development.Shake.Demo + Development.Shake.Derived + Development.Shake.Errors + Development.Shake.FileInfo + Development.Shake.FilePattern + Development.Shake.Monad + Development.Shake.Pool + Development.Shake.Profile + Development.Shake.Progress + Development.Shake.Resource + Development.Shake.Rules.Directory + Development.Shake.Rules.File + Development.Shake.Rules.Files + Development.Shake.Rules.Oracle + Development.Shake.Rules.OrderOnly + Development.Shake.Rules.Rerun + Development.Shake.Shake + Development.Shake.Special + Development.Shake.Storage + Development.Shake.Types + Development.Shake.Value + General.Bilist + General.Binary + General.Cleanup + General.Concurrent + General.Extra + General.FileLock + General.Intern + General.Process + General.String + General.Template + General.Timing + Paths_shake + + default-language: Haskell2010 + build-depends: + base >=4.5, + directory, + hashable >=1.1.2.3, + binary, + filepath, + process >=1.1, + unordered-containers >=0.2.1, + bytestring, + utf8-string >=0.3, + time, + random, + js-jquery, + js-flot, + transformers >=0.2, + extra >=1.4.8, + deepseq >=1.1 + + if flag(portable) + cpp-options: -DPORTABLE + + if impl(ghc <7.6) + build-depends: old-time + + else + if !os(windows) + build-depends: unix >=2.5.1 + + if !os(windows) + build-depends: unix + +executable shake + main-is: Run.hs + hs-source-dirs: src + other-modules: + Development.Make.All + Development.Make.Env + Development.Make.Parse + Development.Make.Rules + Development.Make.Type + Development.Ninja.All + Development.Ninja.Env + Development.Ninja.Lexer + Development.Ninja.Parse + Development.Ninja.Type + Development.Shake + Development.Shake.Args + Development.Shake.ByteString + Development.Shake.Classes + Development.Shake.CmdOption + Development.Shake.Command + Development.Shake.Core + Development.Shake.Database + Development.Shake.Demo + Development.Shake.Derived + Development.Shake.Errors + Development.Shake.FileInfo + Development.Shake.FilePath + Development.Shake.FilePattern + Development.Shake.Forward + Development.Shake.Monad + Development.Shake.Pool + Development.Shake.Profile + Development.Shake.Progress + Development.Shake.Resource + Development.Shake.Rule + Development.Shake.Rules.Directory + Development.Shake.Rules.File + Development.Shake.Rules.Files + Development.Shake.Rules.Oracle + Development.Shake.Rules.OrderOnly + Development.Shake.Rules.Rerun + Development.Shake.Shake + Development.Shake.Special + Development.Shake.Storage + Development.Shake.Types + Development.Shake.Value + General.Bilist + General.Binary + General.Cleanup + General.Concurrent + General.Extra + General.FileLock + General.Intern + General.Process + General.String + General.Template + General.Timing + Paths_shake + Run + + default-language: Haskell2010 + ghc-options: -main-is Run.main -rtsopts + build-depends: + base >=4 && <5, + directory, + hashable >=1.1.2.3, + binary, + filepath, + process >=1.1, + unordered-containers >=0.2.1, + bytestring, + utf8-string >=0.3, + time, + random, + js-jquery, + js-flot, + transformers >=0.2, + extra >=1.4.8, + deepseq >=1.1, + primitive + + if impl(ghc >=7.8) + ghc-options: -threaded "-with-rtsopts=-I0 -qg -qb" + + if flag(portable) + cpp-options: -DPORTABLE + + if impl(ghc <7.6) + build-depends: old-time + + else + if !os(windows) + build-depends: unix >=2.5.1 + + if !os(windows) + build-depends: unix + +test-suite shake-test + type: exitcode-stdio-1.0 + main-is: Test.hs + hs-source-dirs: src + other-modules: + Development.Make.All + Development.Make.Env + Development.Make.Parse + Development.Make.Rules + Development.Make.Type + Development.Ninja.All + Development.Ninja.Env + Development.Ninja.Lexer + Development.Ninja.Parse + Development.Ninja.Type + Development.Shake + Development.Shake.Args + Development.Shake.ByteString + Development.Shake.Classes + Development.Shake.CmdOption + Development.Shake.Command + Development.Shake.Config + Development.Shake.Core + Development.Shake.Database + Development.Shake.Demo + Development.Shake.Derived + Development.Shake.Errors + Development.Shake.FileInfo + Development.Shake.FilePath + Development.Shake.FilePattern + Development.Shake.Forward + Development.Shake.Monad + Development.Shake.Pool + Development.Shake.Profile + Development.Shake.Progress + Development.Shake.Resource + Development.Shake.Rule + Development.Shake.Rules.Directory + Development.Shake.Rules.File + Development.Shake.Rules.Files + Development.Shake.Rules.Oracle + Development.Shake.Rules.OrderOnly + Development.Shake.Rules.Rerun + Development.Shake.Shake + Development.Shake.Special + Development.Shake.Storage + Development.Shake.Types + Development.Shake.Util + Development.Shake.Value + General.Bilist + General.Binary + General.Cleanup + General.Concurrent + General.Extra + General.FileLock + General.Intern + General.Process + General.String + General.Template + General.Timing + Paths_shake + Run + Test.Assume + Test.Basic + Test.Benchmark + Test.C + Test.Cache + Test.Command + Test.Config + Test.Digest + Test.Directory + Test.Docs + Test.Errors + Test.FileLock + Test.FilePath + Test.FilePattern + Test.Files + Test.Forward + Test.Journal + Test.Lint + Test.Live + Test.Makefile + Test.Manual + Test.Match + Test.Monad + Test.Ninja + Test.Oracle + Test.OrderOnly + Test.Parallel + Test.Pool + Test.Progress + Test.Random + Test.Resources + Test.Self + Test.Tar + Test.Tup + Test.Type + Test.Unicode + Test.Util + Test.Verbosity + Test.Version + + default-language: Haskell2010 + ghc-options: -main-is Test.main -rtsopts + build-depends: + base >=4 && <5, + directory, + hashable >=1.1.2.3, + binary, + filepath, + process >=1.1, + unordered-containers >=0.2.1, + bytestring, + utf8-string >=0.3, + time, + random, + js-jquery, + js-flot, + transformers >=0.2, + deepseq >=1.1, + extra >=1.4.8, + QuickCheck >=2.0 + + if impl(ghc >=7.6) + ghc-options: -with-rtsopts=-K1K + + if impl(ghc >=7.8) + ghc-options: -threaded + + if flag(portable) + cpp-options: -DPORTABLE + + if impl(ghc <7.6) + build-depends: old-time + + else + if !os(windows) + build-depends: unix >=2.5.1 + + if !os(windows) + build-depends: unix diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/spdx-1.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/spdx-1.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/spdx-1.cabal @@ -0,0 +1,9 @@ +cabal-version: 2.0 +name: spdx +version: 0 +synopsis: testing positive parsing of spdx identifiers +build-type: Simple +license: BSD3 + +library + default-language: Haskell2010 diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/spdx-1.expr b/cabal/Cabal-tests/tests/ParserTests/regressions/spdx-1.expr new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/spdx-1.expr @@ -0,0 +1,98 @@ +GenericPackageDescription + {condBenchmarks = [], + condExecutables = [], + condForeignLibs = [], + condLibrary = Just + CondNode + {condTreeComponents = [], + condTreeConstraints = [], + condTreeData = Library + {exposedModules = [], + libBuildInfo = BuildInfo + {asmOptions = [], + asmSources = [], + autogenIncludes = [], + autogenModules = [], + buildToolDepends = [], + buildTools = [], + buildable = True, + cSources = [], + ccOptions = [], + cmmOptions = [], + cmmSources = [], + cppOptions = [], + customFieldsBI = [], + cxxOptions = [], + cxxSources = [], + defaultExtensions = [], + defaultLanguage = Just Haskell2010, + extraBundledLibs = [], + extraDynLibFlavours = [], + extraFrameworkDirs = [], + extraGHCiLibs = [], + extraLibDirs = [], + extraLibDirsStatic = [], + extraLibFlavours = [], + extraLibs = [], + extraLibsStatic = [], + frameworks = [], + hsSourceDirs = [], + hsc2hsOptions = [], + includeDirs = [], + includes = [], + installIncludes = [], + jsSources = [], + ldOptions = [], + mixins = [], + oldExtensions = [], + options = PerCompilerFlavor [] [], + otherExtensions = [], + otherLanguages = [], + otherModules = [], + pkgconfigDepends = [], + profOptions = PerCompilerFlavor [] [], + sharedOptions = PerCompilerFlavor [] [], + staticOptions = PerCompilerFlavor [] [], + targetBuildDepends = [], + virtualModules = []}, + libExposed = True, + libName = LMainLibName, + libVisibility = LibraryVisibilityPublic, + reexportedModules = [], + signatures = []}}, + condSubLibraries = [], + condTestSuites = [], + genPackageFlags = [], + gpdScannedVersion = Nothing, + packageDescription = PackageDescription + {author = "", + benchmarks = [], + bugReports = "", + buildTypeRaw = Just Simple, + category = "", + copyright = "", + customFieldsPD = [], + dataDir = ".", + dataFiles = [], + description = "", + executables = [], + extraDocFiles = [], + extraSrcFiles = [], + extraTmpFiles = [], + foreignLibs = [], + homepage = "", + library = Nothing, + licenseFiles = [], + licenseRaw = Right BSD3, + maintainer = "", + package = PackageIdentifier + {pkgName = PackageName "spdx", pkgVersion = mkVersion [0]}, + pkgUrl = "", + setupBuildInfo = Nothing, + sourceRepos = [], + specVersion = CabalSpecV2_0, + stability = "", + subLibraries = [], + synopsis = "testing positive parsing of spdx identifiers", + testSuites = [], + testedWith = []}} diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/spdx-1.format b/cabal/Cabal-tests/tests/ParserTests/regressions/spdx-1.format new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/spdx-1.format @@ -0,0 +1,9 @@ +cabal-version: 2.0 +name: spdx +version: 0 +license: BSD3 +synopsis: testing positive parsing of spdx identifiers +build-type: Simple + +library + default-language: Haskell2010 diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/spdx-2.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/spdx-2.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/spdx-2.cabal @@ -0,0 +1,9 @@ +cabal-version: 2.2 +name: spdx +version: 0 +synopsis: testing positive parsing of spdx identifiers +build-type: Simple +license: AGPL-1.0 + +library + default-language: Haskell2010 diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/spdx-2.expr b/cabal/Cabal-tests/tests/ParserTests/regressions/spdx-2.expr new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/spdx-2.expr @@ -0,0 +1,99 @@ +GenericPackageDescription + {condBenchmarks = [], + condExecutables = [], + condForeignLibs = [], + condLibrary = Just + CondNode + {condTreeComponents = [], + condTreeConstraints = [], + condTreeData = Library + {exposedModules = [], + libBuildInfo = BuildInfo + {asmOptions = [], + asmSources = [], + autogenIncludes = [], + autogenModules = [], + buildToolDepends = [], + buildTools = [], + buildable = True, + cSources = [], + ccOptions = [], + cmmOptions = [], + cmmSources = [], + cppOptions = [], + customFieldsBI = [], + cxxOptions = [], + cxxSources = [], + defaultExtensions = [], + defaultLanguage = Just Haskell2010, + extraBundledLibs = [], + extraDynLibFlavours = [], + extraFrameworkDirs = [], + extraGHCiLibs = [], + extraLibDirs = [], + extraLibDirsStatic = [], + extraLibFlavours = [], + extraLibs = [], + extraLibsStatic = [], + frameworks = [], + hsSourceDirs = [], + hsc2hsOptions = [], + includeDirs = [], + includes = [], + installIncludes = [], + jsSources = [], + ldOptions = [], + mixins = [], + oldExtensions = [], + options = PerCompilerFlavor [] [], + otherExtensions = [], + otherLanguages = [], + otherModules = [], + pkgconfigDepends = [], + profOptions = PerCompilerFlavor [] [], + sharedOptions = PerCompilerFlavor [] [], + staticOptions = PerCompilerFlavor [] [], + targetBuildDepends = [], + virtualModules = []}, + libExposed = True, + libName = LMainLibName, + libVisibility = LibraryVisibilityPublic, + reexportedModules = [], + signatures = []}}, + condSubLibraries = [], + condTestSuites = [], + genPackageFlags = [], + gpdScannedVersion = Nothing, + packageDescription = PackageDescription + {author = "", + benchmarks = [], + bugReports = "", + buildTypeRaw = Just Simple, + category = "", + copyright = "", + customFieldsPD = [], + dataDir = ".", + dataFiles = [], + description = "", + executables = [], + extraDocFiles = [], + extraSrcFiles = [], + extraTmpFiles = [], + foreignLibs = [], + homepage = "", + library = Nothing, + licenseFiles = [], + licenseRaw = Left + (License (ELicense (ELicenseId AGPL_1_0) Nothing)), + maintainer = "", + package = PackageIdentifier + {pkgName = PackageName "spdx", pkgVersion = mkVersion [0]}, + pkgUrl = "", + setupBuildInfo = Nothing, + sourceRepos = [], + specVersion = CabalSpecV2_2, + stability = "", + subLibraries = [], + synopsis = "testing positive parsing of spdx identifiers", + testSuites = [], + testedWith = []}} diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/spdx-2.format b/cabal/Cabal-tests/tests/ParserTests/regressions/spdx-2.format new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/spdx-2.format @@ -0,0 +1,9 @@ +cabal-version: 2.2 +name: spdx +version: 0 +license: AGPL-1.0 +synopsis: testing positive parsing of spdx identifiers +build-type: Simple + +library + default-language: Haskell2010 diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/spdx-3.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/spdx-3.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/spdx-3.cabal @@ -0,0 +1,9 @@ +cabal-version: 2.4 +name: spdx +version: 0 +synopsis: testing positive parsing of spdx identifiers +build-type: Simple +license: AGPL-1.0-only + +library + default-language: Haskell2010 diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/spdx-3.expr b/cabal/Cabal-tests/tests/ParserTests/regressions/spdx-3.expr new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/spdx-3.expr @@ -0,0 +1,99 @@ +GenericPackageDescription + {condBenchmarks = [], + condExecutables = [], + condForeignLibs = [], + condLibrary = Just + CondNode + {condTreeComponents = [], + condTreeConstraints = [], + condTreeData = Library + {exposedModules = [], + libBuildInfo = BuildInfo + {asmOptions = [], + asmSources = [], + autogenIncludes = [], + autogenModules = [], + buildToolDepends = [], + buildTools = [], + buildable = True, + cSources = [], + ccOptions = [], + cmmOptions = [], + cmmSources = [], + cppOptions = [], + customFieldsBI = [], + cxxOptions = [], + cxxSources = [], + defaultExtensions = [], + defaultLanguage = Just Haskell2010, + extraBundledLibs = [], + extraDynLibFlavours = [], + extraFrameworkDirs = [], + extraGHCiLibs = [], + extraLibDirs = [], + extraLibDirsStatic = [], + extraLibFlavours = [], + extraLibs = [], + extraLibsStatic = [], + frameworks = [], + hsSourceDirs = [], + hsc2hsOptions = [], + includeDirs = [], + includes = [], + installIncludes = [], + jsSources = [], + ldOptions = [], + mixins = [], + oldExtensions = [], + options = PerCompilerFlavor [] [], + otherExtensions = [], + otherLanguages = [], + otherModules = [], + pkgconfigDepends = [], + profOptions = PerCompilerFlavor [] [], + sharedOptions = PerCompilerFlavor [] [], + staticOptions = PerCompilerFlavor [] [], + targetBuildDepends = [], + virtualModules = []}, + libExposed = True, + libName = LMainLibName, + libVisibility = LibraryVisibilityPublic, + reexportedModules = [], + signatures = []}}, + condSubLibraries = [], + condTestSuites = [], + genPackageFlags = [], + gpdScannedVersion = Nothing, + packageDescription = PackageDescription + {author = "", + benchmarks = [], + bugReports = "", + buildTypeRaw = Just Simple, + category = "", + copyright = "", + customFieldsPD = [], + dataDir = ".", + dataFiles = [], + description = "", + executables = [], + extraDocFiles = [], + extraSrcFiles = [], + extraTmpFiles = [], + foreignLibs = [], + homepage = "", + library = Nothing, + licenseFiles = [], + licenseRaw = Left + (License (ELicense (ELicenseId AGPL_1_0_only) Nothing)), + maintainer = "", + package = PackageIdentifier + {pkgName = PackageName "spdx", pkgVersion = mkVersion [0]}, + pkgUrl = "", + setupBuildInfo = Nothing, + sourceRepos = [], + specVersion = CabalSpecV2_4, + stability = "", + subLibraries = [], + synopsis = "testing positive parsing of spdx identifiers", + testSuites = [], + testedWith = []}} diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/spdx-3.format b/cabal/Cabal-tests/tests/ParserTests/regressions/spdx-3.format new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/spdx-3.format @@ -0,0 +1,9 @@ +cabal-version: 2.4 +name: spdx +version: 0 +license: AGPL-1.0-only +synopsis: testing positive parsing of spdx identifiers +build-type: Simple + +library + default-language: Haskell2010 diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/th-lift-instances.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/th-lift-instances.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/th-lift-instances.cabal @@ -0,0 +1,76 @@ +name: th-lift-instances +version: 0.1.4 +x-revision: 1 +license: BSD3 +cabal-version: >= 1.10 +license-file: LICENSE +author: Benno Fünfstück +maintainer: Benno Fünfstück +stability: experimental +homepage: http://github.com/bennofs/th-lift-instances/ +bug-reports: http://github.com/bennofs/th-lift-instances/issues +copyright: Copyright (C) 2013-2014 Benno Fünfstück +synopsis: Lift instances for template-haskell for common data types. +description: Most data types in haskell platform do not have Lift instances. This package provides orphan instances + for containers, text, bytestring and vector. +build-type: Custom +category: Template Haskell + +extra-source-files: + .ghci + .gitignore + .travis.yml + .vim.custom + README.md + +source-repository head + type: git + location: https://github.com/bennofs/th-lift-instances.git + +library + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall -fwarn-tabs + build-depends: + base >= 4.4 && < 5 + , template-haskell < 2.10 + , th-lift + , containers >= 0.4 && < 0.6 + , vector >= 0.9 && < 0.11 + , text >= 0.11 && < 1.3 + , bytestring >= 0.9 && < 0.11 + exposed-modules: + Instances.TH.Lift + other-extensions: TemplateHaskell + +test-suite tests + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + Data + default-language: Haskell2010 + build-depends: + base + , template-haskell <2.10 + , containers >= 0.4 && < 0.6 + , vector >= 0.9 && < 0.11 + , text >= 0.11 && < 1.2 + , bytestring >= 0.9 && < 0.11 + , th-lift-instances + , QuickCheck >= 2.6 && < 2.8 + hs-source-dirs: tests + other-extensions: TemplateHaskell + +test-suite doctests + type: exitcode-stdio-1.0 + main-is: doctests.hs + default-language: Haskell2010 + build-depends: + base + , directory >= 1.0 + , doctest >= 0.9.1 + , filepath + ghc-options: -Wall -threaded + if impl(ghc<7.6.1) + ghc-options: -Werror + hs-source-dirs: tests diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/th-lift-instances.expr b/cabal/Cabal-tests/tests/ParserTests/regressions/th-lift-instances.expr new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/th-lift-instances.expr @@ -0,0 +1,589 @@ +GenericPackageDescription { + packageDescription = + PackageDescription { + specVersion = CabalSpecV1_10, + package = PackageIdentifier { + pkgName = PackageName + "th-lift-instances", + pkgVersion = mkVersion + [0, 1, 4]}, + licenseRaw = Right BSD3, + licenseFiles = [ + SymbolicPath "LICENSE"], + copyright = + "Copyright (C) 2013-2014 Benno F\252nfst\252ck", + maintainer = + "Benno F\252nfst\252ck ", + author = + "Benno F\252nfst\252ck", + stability = "experimental", + testedWith = [], + homepage = + "http://github.com/bennofs/th-lift-instances/", + pkgUrl = "", + bugReports = + "http://github.com/bennofs/th-lift-instances/issues", + sourceRepos = [ + SourceRepo { + repoKind = RepoHead, + repoType = Just + (KnownRepoType Git), + repoLocation = Just + "https://github.com/bennofs/th-lift-instances.git", + repoModule = Nothing, + repoBranch = Nothing, + repoTag = Nothing, + repoSubdir = Nothing}], + synopsis = + "Lift instances for template-haskell for common data types.", + description = + concat + [ + "Most data types in haskell platform do not have Lift instances. This package provides orphan instances\n", + "for containers, text, bytestring and vector."], + category = "Template Haskell", + customFieldsPD = [ + _×_ "x-revision" "1"], + buildTypeRaw = Just Custom, + setupBuildInfo = Nothing, + library = Nothing, + subLibraries = [], + executables = [], + foreignLibs = [], + testSuites = [], + benchmarks = [], + dataFiles = [], + dataDir = ".", + extraSrcFiles = [ + ".ghci", + ".gitignore", + ".travis.yml", + ".vim.custom", + "README.md"], + extraTmpFiles = [], + extraDocFiles = []}, + gpdScannedVersion = Nothing, + genPackageFlags = [], + condLibrary = Just + CondNode { + condTreeData = Library { + libName = LMainLibName, + exposedModules = [ + ModuleName "Instances.TH.Lift"], + reexportedModules = [], + signatures = [], + libExposed = True, + libVisibility = + LibraryVisibilityPublic, + libBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [ + SymbolicPath "src"], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Just + Haskell2010, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [ + EnableExtension + TemplateHaskell], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + ["-Wall", "-fwarn-tabs"] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + 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], + 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 = [], + condExecutables = [], + condTestSuites = [ + _×_ + (UnqualComponentName "tests") + CondNode { + condTreeData = TestSuite { + testName = UnqualComponentName + "", + testInterface = TestSuiteExeV10 + (mkVersion [1, 0]) + "Main.hs", + testBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [ + SymbolicPath "tests"], + otherModules = [ + ModuleName "Data"], + virtualModules = [], + autogenModules = [], + defaultLanguage = Just + Haskell2010, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [ + EnableExtension + TemplateHaskell], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + [] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + 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], + 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") + CondNode { + condTreeData = TestSuite { + testName = UnqualComponentName + "", + testInterface = TestSuiteExeV10 + (mkVersion [1, 0]) + "doctests.hs", + testBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [ + SymbolicPath "tests"], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Just + Haskell2010, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + ["-Wall", "-threaded"] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [ + 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], + 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 = + `Var (Impl GHC (EarlierVersion (mkVersion [7,6,1])))`, + condBranchIfTrue = CondNode { + condTreeData = TestSuite { + testName = UnqualComponentName + "", + testInterface = + TestSuiteUnsupported + (TestTypeUnknown + "" + (mkVersion [])), + testBuildInfo = BuildInfo { + buildable = True, + buildTools = [], + buildToolDepends = [], + cppOptions = [], + asmOptions = [], + cmmOptions = [], + ccOptions = [], + cxxOptions = [], + ldOptions = [], + hsc2hsOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], + cSources = [], + cxxSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + virtualModules = [], + autogenModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibsStatic = [], + extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], + extraDynLibFlavours = [], + extraLibDirs = [], + extraLibDirsStatic = [], + includeDirs = [], + includes = [], + autogenIncludes = [], + installIncludes = [], + options = PerCompilerFlavor + ["-Werror"] + [], + profOptions = PerCompilerFlavor + [] + [], + sharedOptions = + PerCompilerFlavor [] [], + staticOptions = + PerCompilerFlavor [] [], + customFieldsBI = [], + targetBuildDepends = [], + mixins = []}, + testCodeGenerators = []}, + condTreeConstraints = [], + condTreeComponents = []}, + condBranchIfFalse = Nothing}]}], + condBenchmarks = []} diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/th-lift-instances.format b/cabal/Cabal-tests/tests/ParserTests/regressions/th-lift-instances.format new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/th-lift-instances.format @@ -0,0 +1,77 @@ +th-lift-instances.cabal:15:9: Tabs used as indentation at 15:9 +cabal-version: >=1.10 +name: th-lift-instances +version: 0.1.4 +license: BSD3 +license-file: LICENSE +copyright: Copyright (C) 2013-2014 Benno Fünfstück +maintainer: Benno Fünfstück +author: Benno Fünfstück +stability: experimental +homepage: http://github.com/bennofs/th-lift-instances/ +bug-reports: http://github.com/bennofs/th-lift-instances/issues +synopsis: Lift instances for template-haskell for common data types. +description: + Most data types in haskell platform do not have Lift instances. This package provides orphan instances + for containers, text, bytestring and vector. + +category: Template Haskell +x-revision: 1 +build-type: Custom +extra-source-files: + .ghci + .gitignore + .travis.yml + .vim.custom + README.md + +source-repository head + type: git + location: https://github.com/bennofs/th-lift-instances.git + +library + exposed-modules: Instances.TH.Lift + hs-source-dirs: src + default-language: Haskell2010 + other-extensions: TemplateHaskell + ghc-options: -Wall -fwarn-tabs + build-depends: + base >=4.4 && <5, + template-haskell <2.10, + th-lift, + containers >=0.4 && <0.6, + vector >=0.9 && <0.11, + text >=0.11 && <1.3, + bytestring >=0.9 && <0.11 + +test-suite tests + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: tests + other-modules: Data + default-language: Haskell2010 + other-extensions: TemplateHaskell + build-depends: + base, + template-haskell <2.10, + containers >=0.4 && <0.6, + vector >=0.9 && <0.11, + text >=0.11 && <1.2, + bytestring >=0.9 && <0.11, + th-lift-instances, + QuickCheck >=2.6 && <2.8 + +test-suite doctests + type: exitcode-stdio-1.0 + main-is: doctests.hs + hs-source-dirs: tests + default-language: Haskell2010 + ghc-options: -Wall -threaded + build-depends: + base, + directory >=1.0, + doctest >=0.9.1, + filepath + + if impl(ghc <7.6.1) + ghc-options: -Werror diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/version-sets.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/version-sets.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/version-sets.cabal @@ -0,0 +1,18 @@ +cabal-version: 3.0 +name: version-sets +version: 0 +synopsis: version set notation +tested-with: GHC == { 8.6.3, 8.4.4, 8.2.2, 8.0.2, 7.10.3, 7.8.4, 7.6.3, 7.4.2 } + +library + default-language: Haskell2010 + build-depends: network ^>= {0} + build-depends: base == {1}, base == { 1 }, base == {1,2}, base == {1.2}, base == {1.2,3.4} + build-depends: ghc == { + 8.6.3 + , + 8.4.4 ,8.2.2 , + 8.0.2,7.10.3 + , 7.8.4, 7.6.3, 7.4.2 + } + build-depends: Cabal ^>= { 2.4.1.1, 2.2.0.0 } diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/version-sets.expr b/cabal/Cabal-tests/tests/ParserTests/regressions/version-sets.expr new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/version-sets.expr @@ -0,0 +1,286 @@ +GenericPackageDescription + {condBenchmarks = [], + condExecutables = [], + condForeignLibs = [], + condLibrary = Just + CondNode + {condTreeComponents = [], + 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], + condTreeData = Library + {exposedModules = [], + libBuildInfo = BuildInfo + {asmOptions = [], + asmSources = [], + autogenIncludes = [], + autogenModules = [], + buildToolDepends = [], + buildTools = [], + buildable = True, + cSources = [], + ccOptions = [], + cmmOptions = [], + cmmSources = [], + cppOptions = [], + customFieldsBI = [], + cxxOptions = [], + cxxSources = [], + defaultExtensions = [], + defaultLanguage = Just Haskell2010, + extraBundledLibs = [], + extraDynLibFlavours = [], + extraFrameworkDirs = [], + extraGHCiLibs = [], + extraLibDirs = [], + extraLibDirsStatic = [], + extraLibFlavours = [], + extraLibs = [], + extraLibsStatic = [], + frameworks = [], + hsSourceDirs = [], + hsc2hsOptions = [], + includeDirs = [], + includes = [], + installIncludes = [], + jsSources = [], + ldOptions = [], + mixins = [], + oldExtensions = [], + options = PerCompilerFlavor [] [], + otherExtensions = [], + otherLanguages = [], + otherModules = [], + pkgconfigDepends = [], + profOptions = PerCompilerFlavor [] [], + sharedOptions = PerCompilerFlavor [] [], + staticOptions = PerCompilerFlavor [] [], + targetBuildDepends = [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], + virtualModules = []}, + libExposed = True, + libName = LMainLibName, + libVisibility = LibraryVisibilityPublic, + reexportedModules = [], + signatures = []}}, + condSubLibraries = [], + condTestSuites = [], + genPackageFlags = [], + gpdScannedVersion = Nothing, + packageDescription = PackageDescription + {author = "", + benchmarks = [], + bugReports = "", + buildTypeRaw = Nothing, + category = "", + copyright = "", + customFieldsPD = [], + dataDir = ".", + dataFiles = [], + description = "", + executables = [], + extraDocFiles = [], + extraSrcFiles = [], + extraTmpFiles = [], + foreignLibs = [], + homepage = "", + library = Nothing, + licenseFiles = [], + licenseRaw = Left NONE, + maintainer = "", + package = PackageIdentifier + {pkgName = PackageName "version-sets", + pkgVersion = mkVersion [0]}, + pkgUrl = "", + setupBuildInfo = Nothing, + sourceRepos = [], + specVersion = CabalSpecV3_0, + stability = "", + subLibraries = [], + synopsis = "version set notation", + testSuites = [], + testedWith = [_×_ + 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])))))))))]}} diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/version-sets.format b/cabal/Cabal-tests/tests/ParserTests/regressions/version-sets.format new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/version-sets.format @@ -0,0 +1,19 @@ +cabal-version: 3.0 +name: version-sets +version: 0 +tested-with: + ghc ==8.6.3 || ==8.4.4 || ==8.2.2 || ==8.0.2 || ==7.10.3 || ==7.8.4 || ==7.6.3 || ==7.4.2 + +synopsis: version set notation + +library + default-language: Haskell2010 + build-depends: + network ^>=0, + base ==1, + base ==1, + base ==1 || ==2, + base ==1.2, + base ==1.2 || ==3.4, + ghc ==8.6.3 || ==8.4.4 || ==8.2.2 || ==8.0.2 || ==7.10.3 || ==7.8.4 || ==7.6.3 || ==7.4.2, + Cabal ^>=2.4.1.1 || ^>=2.2.0.0 diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/wl-pprint-indef.cabal b/cabal/Cabal-tests/tests/ParserTests/regressions/wl-pprint-indef.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/wl-pprint-indef.cabal @@ -0,0 +1,34 @@ +Name: wl-pprint-indef +Version: 1.2 +Cabal-Version: >=1.6 +Synopsis: The Wadler/Leijen Pretty Printer +Category: Text +Description: + This is a pretty printing library based on Wadler's paper "A Prettier + Printer". See the haddocks for full info. This version allows the + library user to declare overlapping instances of the 'Pretty' class. +License: BSD3 +License-file: LICENSE +Author: Daan Leijen +Maintainer: Noam Lewis +Build-Type: Simple + +Executable wl-pprint-string-example + Main-is: Main.hs + Hs-Source-Dirs: example-string + Other-Modules: StringImpl + Build-Depends: base < 5, + str-string >= 0.1.0.0, + wl-pprint-indef + Mixins: wl-pprint-indef requires (Text.PrettyPrint.Leijen.Str as StringImpl) + +Library + Exposed-Modules: Text.PrettyPrint.Leijen + Signatures: Text.PrettyPrint.Leijen.Str + Mixins: str-sig requires (Str as Text.PrettyPrint.Leijen.Str) + Build-Depends: base < 5, + str-sig >= 0.1.0.0 + +source-repository head + type: git + location: git@github.com:danidiaz/wl-pprint-indef.git diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/wl-pprint-indef.expr b/cabal/Cabal-tests/tests/ParserTests/regressions/wl-pprint-indef.expr new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/wl-pprint-indef.expr @@ -0,0 +1,225 @@ +GenericPackageDescription + {condBenchmarks = [], + condExecutables = [_×_ + (UnqualComponentName "wl-pprint-string-example") + CondNode + {condTreeComponents = [], + 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], + condTreeData = Executable + {buildInfo = BuildInfo + {asmOptions = [], + asmSources = [], + autogenIncludes = [], + autogenModules = [], + buildToolDepends = [], + buildTools = [], + buildable = True, + cSources = [], + ccOptions = [], + cmmOptions = [], + cmmSources = [], + cppOptions = [], + customFieldsBI = [], + cxxOptions = [], + cxxSources = [], + defaultExtensions = [], + defaultLanguage = Nothing, + extraBundledLibs = [], + extraDynLibFlavours = [], + extraFrameworkDirs = [], + extraGHCiLibs = [], + extraLibDirs = [], + extraLibDirsStatic = [], + extraLibFlavours = [], + extraLibs = [], + extraLibsStatic = [], + frameworks = [], + hsSourceDirs = [SymbolicPath + "example-string"], + hsc2hsOptions = [], + includeDirs = [], + includes = [], + installIncludes = [], + jsSources = [], + ldOptions = [], + mixins = [], + oldExtensions = [], + options = PerCompilerFlavor [] [], + otherExtensions = [], + otherLanguages = [], + otherModules = [ModuleName + "StringImpl"], + pkgconfigDepends = [], + profOptions = PerCompilerFlavor [] [], + sharedOptions = PerCompilerFlavor [] [], + staticOptions = PerCompilerFlavor [] [], + targetBuildDepends = [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], + virtualModules = []}, + exeName = UnqualComponentName + "wl-pprint-string-example", + exeScope = ExecutablePublic, + modulePath = "Main.hs"}}], + condForeignLibs = [], + condLibrary = Just + CondNode + {condTreeComponents = [], + condTreeConstraints = [Dependency + (PackageName "base") + (EarlierVersion (mkVersion [5])) + mainLibSet, + Dependency + (PackageName "str-sig") + (OrLaterVersion (mkVersion [0, 1, 0, 0])) + mainLibSet], + condTreeData = Library + {exposedModules = [ModuleName "Text.PrettyPrint.Leijen"], + libBuildInfo = BuildInfo + {asmOptions = [], + asmSources = [], + autogenIncludes = [], + autogenModules = [], + buildToolDepends = [], + buildTools = [], + buildable = True, + cSources = [], + ccOptions = [], + cmmOptions = [], + cmmSources = [], + cppOptions = [], + customFieldsBI = [], + cxxOptions = [], + cxxSources = [], + defaultExtensions = [], + defaultLanguage = Nothing, + extraBundledLibs = [], + extraDynLibFlavours = [], + extraFrameworkDirs = [], + extraGHCiLibs = [], + extraLibDirs = [], + extraLibDirsStatic = [], + extraLibFlavours = [], + extraLibs = [], + extraLibsStatic = [], + frameworks = [], + hsSourceDirs = [], + hsc2hsOptions = [], + includeDirs = [], + includes = [], + installIncludes = [], + jsSources = [], + ldOptions = [], + mixins = [], + oldExtensions = [], + options = PerCompilerFlavor [] [], + otherExtensions = [], + otherLanguages = [], + otherModules = [], + pkgconfigDepends = [], + profOptions = PerCompilerFlavor [] [], + sharedOptions = PerCompilerFlavor [] [], + staticOptions = PerCompilerFlavor [] [], + targetBuildDepends = [Dependency + (PackageName + "base") + (EarlierVersion + (mkVersion + [5])) + mainLibSet, + Dependency + (PackageName + "str-sig") + (OrLaterVersion + (mkVersion + [0, + 1, + 0, + 0])) + mainLibSet], + virtualModules = []}, + libExposed = True, + libName = LMainLibName, + libVisibility = LibraryVisibilityPublic, + reexportedModules = [], + signatures = []}}, + condSubLibraries = [], + condTestSuites = [], + genPackageFlags = [], + gpdScannedVersion = Nothing, + packageDescription = PackageDescription + {author = "Daan Leijen", + benchmarks = [], + bugReports = "", + buildTypeRaw = Just Simple, + category = "Text", + copyright = "", + customFieldsPD = [], + dataDir = ".", + dataFiles = [], + description = concat + ["This is a pretty printing library based on Wadler's paper \"A Prettier\n", + "Printer\". See the haddocks for full info. This version allows the\n", + "library user to declare overlapping instances of the 'Pretty' class."], + executables = [], + extraDocFiles = [], + extraSrcFiles = [], + extraTmpFiles = [], + foreignLibs = [], + homepage = "", + library = Nothing, + licenseFiles = [SymbolicPath "LICENSE"], + licenseRaw = Right BSD3, + maintainer = "Noam Lewis ", + package = PackageIdentifier + {pkgName = PackageName "wl-pprint-indef", + pkgVersion = mkVersion [1, 2]}, + pkgUrl = "", + setupBuildInfo = Nothing, + sourceRepos = [SourceRepo + {repoBranch = Nothing, + repoKind = RepoHead, + repoLocation = Just + "git@github.com:danidiaz/wl-pprint-indef.git", + repoModule = Nothing, + repoSubdir = Nothing, + repoTag = Nothing, + repoType = Just (KnownRepoType Git)}], + specVersion = CabalSpecV1_6, + stability = "", + subLibraries = [], + synopsis = "The Wadler/Leijen Pretty Printer", + testSuites = [], + testedWith = []}} diff --git a/cabal/Cabal-tests/tests/ParserTests/regressions/wl-pprint-indef.format b/cabal/Cabal-tests/tests/ParserTests/regressions/wl-pprint-indef.format new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/regressions/wl-pprint-indef.format @@ -0,0 +1,37 @@ +wl-pprint-indef.cabal:28:3: The field "mixins" is available only since the Cabal specification version 2.0. This field will be ignored. +wl-pprint-indef.cabal:27:3: The field "signatures" is available only since the Cabal specification version 2.0. This field will be ignored. +wl-pprint-indef.cabal:23:3: The field "mixins" is available only since the Cabal specification version 2.0. This field will be ignored. +cabal-version: >=1.6 +name: wl-pprint-indef +version: 1.2 +license: BSD3 +license-file: LICENSE +maintainer: Noam Lewis +author: Daan Leijen +synopsis: The Wadler/Leijen Pretty Printer +description: + This is a pretty printing library based on Wadler's paper "A Prettier + Printer". See the haddocks for full info. This version allows the + library user to declare overlapping instances of the 'Pretty' class. + +category: Text +build-type: Simple + +source-repository head + type: git + location: git@github.com:danidiaz/wl-pprint-indef.git + +library + exposed-modules: Text.PrettyPrint.Leijen + build-depends: + base <5, + str-sig >=0.1.0.0 + +executable wl-pprint-string-example + main-is: Main.hs + hs-source-dirs: example-string + other-modules: StringImpl + build-depends: + base <5, + str-string >=0.1.0.0, + wl-pprint-indef diff --git a/cabal/Cabal-tests/tests/ParserTests/warnings/bom.cabal b/cabal/Cabal-tests/tests/ParserTests/warnings/bom.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/warnings/bom.cabal @@ -0,0 +1,7 @@ +name: bom +version: 1 +cabal-version: >= 1.8 + +library + build-depends: base >= 4.9 && <4.10 + hs-source-dirs: . diff --git a/cabal/Cabal-tests/tests/ParserTests/warnings/bool.cabal b/cabal/Cabal-tests/tests/ParserTests/warnings/bool.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/warnings/bool.cabal @@ -0,0 +1,12 @@ +name: bool +version: 1 +cabal-version: >= 1.8 + +flag foo + manual: true + +library + build-depends: base >= 4.9 && <4.10 + if flag(foo) + build-depends: containers + hs-source-dirs: . diff --git a/cabal/Cabal-tests/tests/ParserTests/warnings/deprecatedfield.cabal b/cabal/Cabal-tests/tests/ParserTests/warnings/deprecatedfield.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/warnings/deprecatedfield.cabal @@ -0,0 +1,7 @@ +name: deprecatedfield +version: 1 +cabal-version: >= 1.8 + +library + build-depends: base >= 4.9 && <4.10 + hs-source-dir: . diff --git a/cabal/Cabal-tests/tests/ParserTests/warnings/doubledash.cabal b/cabal/Cabal-tests/tests/ParserTests/warnings/doubledash.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/warnings/doubledash.cabal @@ -0,0 +1,9 @@ +name: bool +version: 1 +cabal-version: >= 1.8 +extra-source-files: + README.md -- we include it + +library + build-depends: base >= 4.9 && <4.10 + hs-source-dirs: . diff --git a/cabal/Cabal-tests/tests/ParserTests/warnings/extratestmodule.cabal b/cabal/Cabal-tests/tests/ParserTests/warnings/extratestmodule.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/warnings/extratestmodule.cabal @@ -0,0 +1,11 @@ +name: extramainis +version: 1 +cabal-version: >= 1.6 + +library + build-depends: base >= 4.9 && <4.10 + hs-source-dirs: . + +test-suite tests + type: exitcode-stdio-1.0 + test-module: Tests diff --git a/cabal/Cabal-tests/tests/ParserTests/warnings/gluedop.cabal b/cabal/Cabal-tests/tests/ParserTests/warnings/gluedop.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/warnings/gluedop.cabal @@ -0,0 +1,9 @@ +name: gluedop +version: 1 +cabal-version: >= 1.6 + +library + build-depends: base >= 4.9 && <4.10 + if os(windows) &&!impl(ghc) + build-depends: containers + hs-source-dirs: . diff --git a/cabal/Cabal-tests/tests/ParserTests/warnings/multiplesingular.cabal b/cabal/Cabal-tests/tests/ParserTests/warnings/multiplesingular.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/warnings/multiplesingular.cabal @@ -0,0 +1,8 @@ +name: multiplesingular +name: multiplesingular2 +version: 1 +cabal-version: >= 1.8 + +library + build-depends: base >= 4.9 && <4.10 + hs-source-dirs: . diff --git a/cabal/Cabal-tests/tests/ParserTests/warnings/nbsp.cabal b/cabal/Cabal-tests/tests/ParserTests/warnings/nbsp.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/warnings/nbsp.cabal @@ -0,0 +1,7 @@ +name: nbsp +version: 1 +cabal-version: >= 1.8 + +library +  build-depends: base >= 4.9 && <4.10 + hs-source-dirs: . diff --git a/cabal/Cabal-tests/tests/ParserTests/warnings/newsyntax.cabal b/cabal/Cabal-tests/tests/ParserTests/warnings/newsyntax.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/warnings/newsyntax.cabal @@ -0,0 +1,6 @@ +name: newsyntax +version: 1 + +library + build-depends: base + hs-source-dirs: . diff --git a/cabal/Cabal-tests/tests/ParserTests/warnings/oldsyntax.cabal b/cabal/Cabal-tests/tests/ParserTests/warnings/oldsyntax.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/warnings/oldsyntax.cabal @@ -0,0 +1,6 @@ +name: oldsyntax +version: 1 +cabal-version: >= 1.8 + +build-depends: base >= 4.9 && <4.10 +hs-source-dirs: . diff --git a/cabal/Cabal-tests/tests/ParserTests/warnings/operator.cabal b/cabal/Cabal-tests/tests/ParserTests/warnings/operator.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/warnings/operator.cabal @@ -0,0 +1,7 @@ +name: version-operator +version: 1 +cabal-version: >= 1.6 + +library + build-depends: base >= 4.9 && <4.10 + hs-source-dirs: . diff --git a/cabal/Cabal-tests/tests/ParserTests/warnings/specversion-a.cabal b/cabal/Cabal-tests/tests/ParserTests/warnings/specversion-a.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/warnings/specversion-a.cabal @@ -0,0 +1,7 @@ +name: specversion +version: 1 +cabal-version: >= 1.12 + +library + build-depends: base >= 4.9 && <4.10 + hs-source-dirs: . diff --git a/cabal/Cabal-tests/tests/ParserTests/warnings/specversion-b.cabal b/cabal/Cabal-tests/tests/ParserTests/warnings/specversion-b.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/warnings/specversion-b.cabal @@ -0,0 +1,7 @@ +name: specversion +version: 1 +cabal-version: >= 1.10 && <1.11 + +library + build-depends: base >= 4.9 && <4.10 + hs-source-dirs: . diff --git a/cabal/Cabal-tests/tests/ParserTests/warnings/specversion-c.cabal b/cabal/Cabal-tests/tests/ParserTests/warnings/specversion-c.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/warnings/specversion-c.cabal @@ -0,0 +1,7 @@ +name: specversion +version: 1 +cabal-version: 1.10 + +library + build-depends: base >= 4.9 && <4.10 + hs-source-dirs: . diff --git a/cabal/Cabal-tests/tests/ParserTests/warnings/subsection.cabal b/cabal/Cabal-tests/tests/ParserTests/warnings/subsection.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/warnings/subsection.cabal @@ -0,0 +1,9 @@ +name: subsection +version: 1 +cabal-version: >= 1.8 + +library + build-depends: base >= 4.9 && <4.10 + hs-source-dirs: . + iff os(windows) + build-depends: containers diff --git a/cabal/Cabal-tests/tests/ParserTests/warnings/tab.cabal b/cabal/Cabal-tests/tests/ParserTests/warnings/tab.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/warnings/tab.cabal @@ -0,0 +1,12 @@ +name: tab +version: 1 +cabal-version: >= 1.8 + +library + build-depends: { base >= 4.9 && <4.10 } + hs-source-dirs: . + +test-suite tests { + type: exitcode-stdio-1.0 + main-is: Main.hs +} diff --git a/cabal/Cabal-tests/tests/ParserTests/warnings/trailingfield.cabal b/cabal/Cabal-tests/tests/ParserTests/warnings/trailingfield.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/warnings/trailingfield.cabal @@ -0,0 +1,9 @@ +name: trailingfield +version: 1 +cabal-version: >= 1.8 + +library + build-depends: base >= 4.9 && <4.10 + hs-source-dirs: . + +description: No fields after sections diff --git a/cabal/Cabal-tests/tests/ParserTests/warnings/unknownfield.cabal b/cabal/Cabal-tests/tests/ParserTests/warnings/unknownfield.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/warnings/unknownfield.cabal @@ -0,0 +1,8 @@ +name: unknownfield +version: 1 +cabal-version: >= 1.8 + +library + build-depends: base >= 4.9 && <4.10 + hs-source-dirs: . + xfield: x diff --git a/cabal/Cabal-tests/tests/ParserTests/warnings/unknownsection.cabal b/cabal/Cabal-tests/tests/ParserTests/warnings/unknownsection.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/warnings/unknownsection.cabal @@ -0,0 +1,10 @@ +name: unknownsection +version: 1 +cabal-version: >= 1.8 + +library + build-depends: base >= 4.9 && <4.10 + hs-source-dirs: . + +z + z-field: z diff --git a/cabal/Cabal-tests/tests/ParserTests/warnings/utf8.cabal b/cabal/Cabal-tests/tests/ParserTests/warnings/utf8.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/warnings/utf8.cabal @@ -0,0 +1,8 @@ +name: utf8 +author: Oleg Grönroos +version: 1 +cabal-version: >= 1.8 + +library + build-depends: base >= 4.9 && <4.10 + hs-source-dirs: . diff --git a/cabal/Cabal-tests/tests/ParserTests/warnings/versiontag.cabal b/cabal/Cabal-tests/tests/ParserTests/warnings/versiontag.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/warnings/versiontag.cabal @@ -0,0 +1,7 @@ +name: versiontag +version: 1 +cabal-version: >= 1.8 + +library + build-depends: base >= 4.9 && <4.10-rc1 + hs-source-dirs: . diff --git a/cabal/Cabal-tests/tests/ParserTests/warnings/wildcard.cabal b/cabal/Cabal-tests/tests/ParserTests/warnings/wildcard.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/ParserTests/warnings/wildcard.cabal @@ -0,0 +1,7 @@ +name: version-wildcard +version: 1 +cabal-version: >= 1.4 + +library + build-depends: base == 4.* + hs-source-dirs: . diff --git a/cabal/Cabal-tests/tests/README.md b/cabal/Cabal-tests/tests/README.md new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/README.md @@ -0,0 +1,5 @@ +Unit tests +========== + +Ordinary unit tests. If you're looking for the package tests, +they live in cabal-testsuite now. diff --git a/cabal/Cabal-tests/tests/RPMVerCmp.hs b/cabal/Cabal-tests/tests/RPMVerCmp.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/RPMVerCmp.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Foreign.C.String (CString) +import Foreign.C.Types (CInt (..)) +import System.IO.Unsafe (unsafePerformIO) +import Data.Bits ((.&.)) + +import Test.QuickCheck (Arbitrary (..), (===)) +import Test.Tasty (defaultMain, testGroup) +import Test.Tasty.HUnit (assertEqual, testCase) +import Test.Tasty.QuickCheck (testProperty) + +import Distribution.Pretty (prettyShow) +import Distribution.Types.PkgconfigVersion (rpmvercmp) +import Distribution.Types.Version + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 + +------------------------------------------------------------------------------- +-- C reference implementation +------------------------------------------------------------------------------- + +foreign import ccall unsafe "rpmvercmp" c_rmpvercmp + :: CString -> CString -> CInt + +rpmvercmpRef :: BS.ByteString -> BS.ByteString -> Ordering +rpmvercmpRef a b = unsafePerformIO $ + BS.useAsCString a $ \a' -> + BS.useAsCString b $ \b' -> + return $ fromInt $ c_rmpvercmp a' b' + where + fromInt = flip compare 0 + +------------------------------------------------------------------------------- +-- Tests +------------------------------------------------------------------------------- + +main :: IO () +main = defaultMain $ testGroup "rpmvercmp" + [ testGroup "examples" + [ example "openssl" "1.1.0g" "1.1.0i" LT + , example "openssl" "1.0.2h" "1.1.0" LT + + , example "simple" "1.2.3" "1.2.4" LT + , example "word" "apple" "banana" LT + + , example "corner case" "r" "" GT + , example "corner case" "0" "1" LT + , example "corner case" "1" "0.0" GT + ] + , testGroup "Properties" + [ testProperty "ref reflexive" $ \a -> + rpmvercmpRef (BS.pack a) (BS.pack a) === EQ + , testProperty "pure reflexive" $ \a -> + rpmvercmp (BS.pack a) (BS.pack a) === EQ + , testProperty "ref agrees with Version" $ \a b -> + compare a b === rpmvercmpRef (v2bs a) (v2bs b) + , testProperty "pure agrees with Version" $ \a b -> + compare a b === rpmvercmp (v2bs a) (v2bs b) + ] + , testGroup "Random inputs" + [ testProperty "random" $ \xs ys -> + -- only 7bit numbers, no zero, and non-empty. + let xs' = BS.pack $ unnull $ filter (/= 0) $ map (.&. 0x7f) xs + ys' = BS.pack $ unnull $ filter (/= 0) $ map (.&. 0x7f) ys + + -- ref doesn't really work with empty inputs reliably. + unnull [] = [1] + unnull zs = zs + in rpmvercmpRef xs' ys' === rpmvercmp xs' ys' + ] + ] + where + example n a b c = testCase (n ++ " " ++ BS8.unpack a ++ " <=> " ++ BS8.unpack b) $ do + let ref = rpmvercmpRef a b + let pur = rpmvercmp a b + assertEqual "ref" c ref + assertEqual "pure" c pur + +------------------------------------------------------------------------------- +-- Version arbitrary +------------------------------------------------------------------------------- + +newtype V = V Version + deriving (Show, Eq, Ord) + +unV :: V -> Version +unV (V x) = x + +instance Arbitrary V where + arbitrary = fmap (V . mkVersion_) arbitrary + + shrink = map V . filter (/= version0) . map mkVersion_ . shrink . versionNumbers . unV + +mkVersion_ :: [Int] -> Version +mkVersion_ [] = version0 +mkVersion_ xs = mkVersion (map abs xs) + +v2bs :: V -> BS.ByteString +v2bs (V x) = BS8.pack (prettyShow x) diff --git a/cabal/Cabal-tests/tests/Test/Laws.hs b/cabal/Cabal-tests/tests/Test/Laws.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/Test/Laws.hs @@ -0,0 +1,79 @@ +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +module Test.Laws where + +import Prelude hiding (Num((+), (*))) +import Data.Monoid (Monoid(..), Endo(..)) +import qualified Data.Foldable as Foldable + +idempotent_unary f x = f fx == fx where fx = f x + +-- Basic laws on binary operators + +idempotent_binary (+) x = x + x == x + +commutative (+) x y = x + y == y + x + +associative (+) x y z = (x + y) + z == x + (y + z) + +distributive_left (*) (+) x y z = x * (y + z) == (x * y) + (x * z) + +distributive_right (*) (+) x y z = (y + z) * x == (y * x) + (z * x) + + +-- | The first 'fmap' law +-- +-- > fmap id == id +-- +fmap_1 :: (Eq (f a), Functor f) => f a -> Bool +fmap_1 x = fmap id x == x + +-- | The second 'fmap' law +-- +-- > fmap (f . g) == fmap f . fmap g +-- +fmap_2 :: (Eq (f c), Functor f) => (b -> c) -> (a -> b) -> f a -> Bool +fmap_2 f g x = fmap (f . g) x == (fmap f . fmap g) x + + +-- | The monoid identity law, 'mempty' is a left and right identity of +-- 'mappend': +-- +-- > mempty `mappend` x = x +-- > x `mappend` mempty = x +-- +monoid_1 :: (Eq a, Data.Monoid.Monoid a) => a -> Bool +monoid_1 x = mempty `mappend` x == x + && x `mappend` mempty == x + +-- | The monoid associativity law, 'mappend' must be associative. +-- +-- > (x `mappend` y) `mappend` z = x `mappend` (y `mappend` z) +-- +monoid_2 :: (Eq a, Data.Monoid.Monoid a) => a -> a -> a -> Bool +monoid_2 x y z = (x `mappend` y) `mappend` z + == x `mappend` (y `mappend` z) + +-- | The 'mconcat' definition. It can be overridden for the sake of efficiency +-- but it must still satisfy the property given by the default definition: +-- +-- > mconcat = foldr mappend mempty +-- +monoid_3 :: (Eq a, Data.Monoid.Monoid a) => [a] -> Bool +monoid_3 xs = mconcat xs == foldr mappend mempty xs + + +-- | First 'Foldable' law +-- +-- > Foldable.fold = Foldable.foldr mappend mempty +-- +foldable_1 :: (Foldable.Foldable t, Monoid m, Eq m) => t m -> Bool +foldable_1 x = Foldable.fold x == Foldable.foldr mappend mempty x + +-- | Second 'Foldable' law +-- +-- > foldr f z t = appEndo (foldMap (Endo . f) t) z +-- +foldable_2 :: (Foldable.Foldable t, Eq b) + => (a -> b -> b) -> b -> t a -> Bool +foldable_2 f z t = Foldable.foldr f z t + == appEndo (Foldable.foldMap (Endo . f) t) z diff --git a/cabal/Cabal-tests/tests/Test/QuickCheck/Utils.hs b/cabal/Cabal-tests/tests/Test/QuickCheck/Utils.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/Test/QuickCheck/Utils.hs @@ -0,0 +1,29 @@ +module Test.QuickCheck.Utils where + +import Test.QuickCheck.Gen + + +-- | Adjust the size of the generated value. +-- +-- In general the size gets bigger and bigger linearly. For some types +-- it is not appropriate to generate ever bigger values but instead +-- to generate lots of intermediate sized values. You could do that using: +-- +-- > adjustSize (\n -> min n 5) +-- +-- Similarly, for some types the linear size growth may mean getting too big +-- too quickly relative to other values. So you may want to adjust how +-- quickly the size grows. For example dividing by a constant, or even +-- something like the integer square root or log. +-- +-- > adjustSize (\n -> n `div` 2) +-- +-- Putting this together we can make for example a relatively short list: +-- +-- > adjustSize (\n -> min 5 (n `div` 3)) (listOf1 arbitrary) +-- +-- Not only do we put a limit on the length but we also scale the growth to +-- prevent it from hitting the maximum size quite so early. +-- +adjustSize :: (Int -> Int) -> Gen a -> Gen a +adjustSize adjust gen = sized (\n -> resize (adjust n) gen) diff --git a/cabal/Cabal-tests/tests/UnitTests.hs b/cabal/Cabal-tests/tests/UnitTests.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/UnitTests.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE DeriveDataTypeable #-} +module Main + ( main + ) where + +import Test.Tasty +import Test.Tasty.Options + +import Data.Proxy +import Data.Typeable + +import Distribution.Simple.Utils +import Distribution.Verbosity +import Distribution.Compat.Time + +import qualified UnitTests.Distribution.Compat.Time +import qualified UnitTests.Distribution.Compat.Graph +import qualified UnitTests.Distribution.Simple.Command +import qualified UnitTests.Distribution.Simple.Glob +import qualified UnitTests.Distribution.Simple.Program.GHC +import qualified UnitTests.Distribution.Simple.Program.Internal +import qualified UnitTests.Distribution.Simple.Utils +import qualified UnitTests.Distribution.System +import qualified UnitTests.Distribution.Utils.CharSet +import qualified UnitTests.Distribution.Utils.Generic +import qualified UnitTests.Distribution.Utils.Json +import qualified UnitTests.Distribution.Utils.NubList +import qualified UnitTests.Distribution.Utils.ShortText +import qualified UnitTests.Distribution.Utils.Structured +import qualified UnitTests.Distribution.Version (versionTests) +import qualified UnitTests.Distribution.PkgconfigVersion (pkgconfigVersionTests) +import qualified UnitTests.Distribution.SPDX (spdxTests) +import qualified UnitTests.Distribution.Described +import qualified UnitTests.Distribution.CabalSpecVersion +import qualified UnitTests.Distribution.Types.GenericPackageDescription + +tests :: Int -> TestTree +tests mtimeChangeCalibrated = + askOption $ \(OptionMtimeChangeDelay mtimeChangeProvided) -> + askOption $ \(GhcPath ghcPath) -> + let mtimeChange = if mtimeChangeProvided /= 0 + then mtimeChangeProvided + else mtimeChangeCalibrated + in + testGroup "Unit Tests" + [ testGroup "Distribution.Compat.Time" + (UnitTests.Distribution.Compat.Time.tests mtimeChange) + , testGroup "Distribution.Compat.Graph" + UnitTests.Distribution.Compat.Graph.tests + , testGroup "Distribution.Simple.Command" + UnitTests.Distribution.Simple.Command.tests + , testGroup "Distribution.Simple.Glob" + UnitTests.Distribution.Simple.Glob.tests + , UnitTests.Distribution.Simple.Program.GHC.tests + , testGroup "Distribution.Simple.Program.Internal" + UnitTests.Distribution.Simple.Program.Internal.tests + , testGroup "Distribution.Simple.Utils" $ + UnitTests.Distribution.Simple.Utils.tests ghcPath + , testGroup "Distribution.Utils.Generic" + UnitTests.Distribution.Utils.Generic.tests + , testGroup "Distribution.Utils.Json" $ + UnitTests.Distribution.Utils.Json.tests + , testGroup "Distribution.Utils.NubList" + UnitTests.Distribution.Utils.NubList.tests + , testGroup "Distribution.Utils.ShortText" + UnitTests.Distribution.Utils.ShortText.tests + , testGroup "Distribution.System" + UnitTests.Distribution.System.tests + , testGroup "Distribution.Types.GenericPackageDescription" + UnitTests.Distribution.Types.GenericPackageDescription.tests + , testGroup "Distribution.Version" + UnitTests.Distribution.Version.versionTests + , testGroup "Distribution.Types.PkgconfigVersion(Range)" + UnitTests.Distribution.PkgconfigVersion.pkgconfigVersionTests + , testGroup "Distribution.SPDX" + UnitTests.Distribution.SPDX.spdxTests + , UnitTests.Distribution.Utils.CharSet.tests + , UnitTests.Distribution.Utils.Structured.tests + , UnitTests.Distribution.Described.tests + , UnitTests.Distribution.CabalSpecVersion.tests + ] + +extraOptions :: [OptionDescription] +extraOptions = + [ Option (Proxy :: Proxy OptionMtimeChangeDelay) + , Option (Proxy :: Proxy GhcPath) + ] + +newtype OptionMtimeChangeDelay = OptionMtimeChangeDelay Int + deriving Typeable + +instance IsOption OptionMtimeChangeDelay where + defaultValue = OptionMtimeChangeDelay 0 + parseValue = fmap OptionMtimeChangeDelay . safeRead + optionName = return "mtime-change-delay" + optionHelp = return $ "How long to wait before attempting to detect" + ++ "file modification, in microseconds" + +newtype GhcPath = GhcPath FilePath + deriving Typeable + +instance IsOption GhcPath where + defaultValue = GhcPath "ghc" + optionName = return "with-ghc" + optionHelp = return "The ghc compiler to use" + parseValue = Just . GhcPath + +main :: IO () +main = do + (mtimeChange, mtimeChange') <- calibrateMtimeChangeDelay + let toMillis :: Int -> Double + toMillis x = fromIntegral x / 1000.0 + notice normal $ "File modification time resolution calibration completed, " + ++ "maximum delay observed: " + ++ (show . toMillis $ mtimeChange ) ++ " ms. " + ++ "Will be using delay of " ++ (show . toMillis $ mtimeChange') + ++ " for test runs." + defaultMainWithIngredients + (includingOptions extraOptions : defaultIngredients) + (tests mtimeChange') diff --git a/cabal/Cabal-tests/tests/UnitTests/Distribution/CabalSpecVersion.hs b/cabal/Cabal-tests/tests/UnitTests/Distribution/CabalSpecVersion.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/UnitTests/Distribution/CabalSpecVersion.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-deprecations #-} +module UnitTests.Distribution.CabalSpecVersion (tests) where + +import Distribution.Compat.Prelude.Internal +import Prelude () + +import Distribution.CabalSpecVersion +import Distribution.FieldGrammar.Newtypes (SpecVersion (..)) +import Distribution.Parsec (eitherParsec) +import Distribution.Pretty (prettyShow) + +import Test.Tasty +import Test.Tasty.QuickCheck + +-- instances +import Test.QuickCheck.Instances.Cabal () + +tests :: TestTree +tests = testGroup "Distribution.CabalSpecVersion" + [ testProperty "roundtrip" propRoundtrip + , testProperty "fromVersionDigits . toVersionDigits = Just" propViaVersionDigits + ] + where + -- we test roundtrip here, + -- because Described instance is a small simplification. + propRoundtrip :: SpecVersion -> Property + propRoundtrip x = counterexample (show (res, str)) $ case res of + Right y -> x == y + Left _ -> False + where + str = prettyShow x + res = eitherParsec str + + propViaVersionDigits :: CabalSpecVersion -> Property + propViaVersionDigits csv = + counterexample (show digits) $ + lhs === rhs + where + digits = cabalSpecToVersionDigits csv + lhs = cabalSpecFromVersionDigits digits + rhs = Just csv diff --git a/cabal/Cabal-tests/tests/UnitTests/Distribution/Compat/Graph.hs b/cabal/Cabal-tests/tests/UnitTests/Distribution/Compat/Graph.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/UnitTests/Distribution/Compat/Graph.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module UnitTests.Distribution.Compat.Graph + ( tests + , arbitraryGraph + ) where + +import Distribution.Compat.Graph + +import qualified Prelude +import Prelude hiding (null) +import Test.Tasty +import Test.Tasty.QuickCheck +import qualified Data.Set as Set +import Control.Monad +import qualified Data.Graph as G +import Data.Array ((!)) +import Data.Maybe +import Data.List (sort) + +tests :: [TestTree] +tests = + [ testProperty "arbitrary unbroken" (prop_arbitrary_unbroken :: Graph (Node Int ()) -> Bool) + , testProperty "nodes consistent" (prop_nodes_consistent :: Graph (Node Int ()) -> Bool) + , testProperty "edges consistent" (prop_edges_consistent :: Graph (Node Int ()) -> Property) + , testProperty "closure consistent" (prop_closure_consistent :: Graph (Node Int ()) -> Property) + ] + +-- Our arbitrary instance does not generate broken graphs +prop_arbitrary_unbroken :: Graph a -> Bool +prop_arbitrary_unbroken g = Prelude.null (broken g) + +-- Every node from 'toList' maps to a vertex which +-- is present in the constructed graph, and maps back +-- to a node correctly. +prop_nodes_consistent :: (Eq a, IsNode a) => Graph a -> Bool +prop_nodes_consistent g = all p (toList g) + where + (_, vtn, ktv) = toGraph g + p n = case ktv (nodeKey n) of + Just v -> vtn v == n + Nothing -> False + +-- A non-broken graph has the 'nodeNeighbors' of each node +-- equal the recorded adjacent edges in the node graph. +prop_edges_consistent :: IsNode a => Graph a -> Property +prop_edges_consistent g = Prelude.null (broken g) ==> all p (toList g) + where + (gr, vtn, ktv) = toGraph g + p n = sort (nodeNeighbors n) + == sort (map (nodeKey . vtn) (gr ! fromJust (ktv (nodeKey n)))) + +-- Closure is consistent with reachable +prop_closure_consistent :: (Show a, IsNode a) => Graph a -> Property +prop_closure_consistent g = + not (null g) ==> + forAll (elements (toList g)) $ \n -> + Set.fromList (map nodeKey (fromJust (closure g [nodeKey n]))) + == Set.fromList (map (nodeKey . vtn) (G.reachable gr (fromJust (ktv (nodeKey n))))) + where + (gr, vtn, ktv) = toGraph g + +hasNoDups :: Ord a => [a] -> Bool +hasNoDups = loop Set.empty + where + loop _ [] = True + loop s (x:xs) | s' <- Set.insert x s, Set.size s' > Set.size s + = loop s' xs + | otherwise + = False + +-- | Produces a graph of size @len@. We sample with 'suchThat'; if we +-- dropped duplicate entries our size could be smaller. +arbitraryGraph :: (Ord k, Show k, Arbitrary k, Arbitrary a) + => Int -> Gen (Graph (Node k a)) +arbitraryGraph len = do + -- Careful! Assume k is much larger than size. + ks <- vectorOf len arbitrary `suchThat` hasNoDups + ns <- forM ks $ \k -> do + a <- arbitrary + ns <- listOf (elements ks) + -- Allow duplicates! + return (N a k ns) + return (fromDistinctList ns) + +instance (Ord k, Show k, Arbitrary k, Arbitrary a) + => Arbitrary (Graph (Node k a)) where + arbitrary = sized $ \n -> do + len <- choose (0, n) + arbitraryGraph len diff --git a/cabal/Cabal-tests/tests/UnitTests/Distribution/Compat/Time.hs b/cabal/Cabal-tests/tests/UnitTests/Distribution/Compat/Time.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/UnitTests/Distribution/Compat/Time.hs @@ -0,0 +1,49 @@ +module UnitTests.Distribution.Compat.Time (tests) where + +import Control.Concurrent (threadDelay) +import System.FilePath + +import Distribution.Simple.Utils (withTempDirectory) +import Distribution.Verbosity + +import Distribution.Compat.Time + +import Test.Tasty +import Test.Tasty.HUnit + +tests :: Int -> [TestTree] +tests mtimeChange = + [ testCase "getModTime has sub-second resolution" $ getModTimeTest mtimeChange + , testCase "getCurTime works as expected" $ getCurTimeTest mtimeChange + ] + +getModTimeTest :: Int -> Assertion +getModTimeTest mtimeChange = + withTempDirectory silent "." "getmodtime-" $ \dir -> do + let fileName = dir "foo" + writeFile fileName "bar" + t0 <- getModTime fileName + threadDelay mtimeChange + writeFile fileName "baz" + t1 <- getModTime fileName + assertBool "expected different file mtimes" (t1 > t0) + + +getCurTimeTest :: Int -> Assertion +getCurTimeTest mtimeChange = + withTempDirectory silent "." "getmodtime-" $ \dir -> do + let fileName = dir "foo" + writeFile fileName "bar" + t0 <- getModTime fileName + threadDelay mtimeChange + t1 <- getCurTime + assertBool("expected file mtime (" ++ show t0 + ++ ") to be earlier than current time (" ++ show t1 ++ ")") + (t0 < t1) + + threadDelay mtimeChange + writeFile fileName "baz" + t2 <- getModTime fileName + assertBool ("expected current time (" ++ show t1 + ++ ") to be earlier than file mtime (" ++ show t2 ++ ")") + (t1 < t2) diff --git a/cabal/Cabal-tests/tests/UnitTests/Distribution/Described.hs b/cabal/Cabal-tests/tests/UnitTests/Distribution/Described.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/UnitTests/Distribution/Described.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-deprecations #-} +module UnitTests.Distribution.Described where + +import Distribution.Compat.Prelude.Internal +import Prelude () + +import Distribution.Described (testDescribed) +import Test.Tasty (TestTree, testGroup) + +import Distribution.Compiler (CompilerFlavor, CompilerId) +import Distribution.ModuleName (ModuleName) +import Distribution.System (Arch, OS) +import Distribution.Types.Dependency (Dependency) +import Distribution.Types.Flag (FlagAssignment, FlagName) +import Distribution.Types.IncludeRenaming (IncludeRenaming) +import Distribution.Types.Mixin (Mixin) +import Distribution.Types.ModuleRenaming (ModuleRenaming) +import Distribution.Types.PackageId (PackageIdentifier) +import Distribution.Types.PackageName (PackageName) +import Distribution.Types.PackageVersionConstraint (PackageVersionConstraint) +import Distribution.Types.Version (Version) +import Distribution.Types.VersionRange (VersionRange) +import Distribution.Verbosity (Verbosity) + +-- instances +import Test.QuickCheck.Instances.Cabal () + +tests :: TestTree +tests = testGroup "Described" + [ testDescribed (Proxy :: Proxy Dependency) + , testDescribed (Proxy :: Proxy PackageName) + , testDescribed (Proxy :: Proxy PackageIdentifier) + , testDescribed (Proxy :: Proxy PackageVersionConstraint) + , testDescribed (Proxy :: Proxy Version) + , testDescribed (Proxy :: Proxy VersionRange) + , testDescribed (Proxy :: Proxy FlagName) + , testDescribed (Proxy :: Proxy FlagAssignment) + , testDescribed (Proxy :: Proxy ModuleName) + , testDescribed (Proxy :: Proxy OS) + , testDescribed (Proxy :: Proxy Arch) + , testDescribed (Proxy :: Proxy CompilerFlavor) + , testDescribed (Proxy :: Proxy CompilerId) + , testDescribed (Proxy :: Proxy ModuleRenaming) + , testDescribed (Proxy :: Proxy IncludeRenaming) + , testDescribed (Proxy :: Proxy Mixin) + , testDescribed (Proxy :: Proxy Verbosity) + ] diff --git a/cabal/Cabal-tests/tests/UnitTests/Distribution/PkgconfigVersion.hs b/cabal/Cabal-tests/tests/UnitTests/Distribution/PkgconfigVersion.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/UnitTests/Distribution/PkgconfigVersion.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} +module UnitTests.Distribution.PkgconfigVersion (pkgconfigVersionTests) where + +import Test.Tasty +import Test.Tasty.QuickCheck + +import Distribution.Parsec (eitherParsec) +import Distribution.Pretty +import Distribution.Types.PkgconfigVersionRange + +import Test.QuickCheck.Instances.Cabal () + +pkgconfigVersionTests :: [TestTree] +pkgconfigVersionTests = + [ testProperty "simpleParsec . prettyShow = Just" prop_parse_disp + ] + +prop_parse_disp :: PkgconfigVersionRange -> Property +prop_parse_disp vr = counterexample (show (prettyShow vr)) $ + eitherParsec (prettyShow vr) === Right vr diff --git a/cabal/Cabal-tests/tests/UnitTests/Distribution/SPDX.hs b/cabal/Cabal-tests/tests/UnitTests/Distribution/SPDX.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/UnitTests/Distribution/SPDX.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-deprecations #-} +module UnitTests.Distribution.SPDX (spdxTests) where + +import Distribution.Compat.Prelude.Internal +import Prelude () + +import Distribution.SPDX +import Distribution.Parsec (eitherParsec) +import Distribution.Pretty (prettyShow) + +import Test.Tasty +import Test.Tasty.QuickCheck + +#if MIN_VERSION_binary(0,7,0) +import qualified Data.Binary as Binary +import qualified Data.Binary.Get as Binary +import qualified Data.Binary.Put as Binary +import qualified Data.ByteString.Lazy as LBS +import GHC.Generics (to, from) +#endif + +import Test.QuickCheck.Instances.Cabal () + +spdxTests :: [TestTree] +spdxTests = + [ testProperty "LicenseId roundtrip" licenseIdRoundtrip + , testProperty "LicenseExceptionId roundtrip" licenseExceptionIdRoundtrip + , testProperty "LicenseRef roundtrip" licenseRefRoundtrip + , testProperty "SimpleLicenseExpression roundtrip" simpleLicenseExpressionRoundtrip + , testProperty "LicenseExpression roundtrip" licenseExpressionRoundtrip + , testProperty "isAcceptableLicense l = True" shouldAcceptProp + , testProperty "isAcceptableLicense l = False" shouldRejectProp + ] + +licenseIdRoundtrip :: LicenseId -> Property +licenseIdRoundtrip x = + counterexample (prettyShow x) $ + Right x === eitherParsec (prettyShow x) + +licenseExceptionIdRoundtrip :: LicenseExceptionId -> Property +licenseExceptionIdRoundtrip x = + counterexample (prettyShow x) $ + Right x === eitherParsec (prettyShow x) + +#if MIN_VERSION_binary(0,7,0) +licenseExceptionIdBinaryPut :: LicenseExceptionId -> Property +licenseExceptionIdBinaryPut x = + Binary.runPut (Binary.put x) + === + Binary.runPut (Binary.gput (from x)) + +licenseExceptionIdBinaryGet :: Word8 -> Property +licenseExceptionIdBinaryGet w0 = + stripMsg id (Binary.runGetOrFail Binary.get bs) + === + stripMsg to (Binary.runGetOrFail Binary.gget bs) + where + bs = LBS.pack [w0] + + stripMsg + :: (a -> LicenseExceptionId) + -> Either (x, y, String) (x, y, a) + -> Either (x, y) (x, y, LicenseExceptionId) + stripMsg _ (Left (x,y,_)) = Left (x,y) + stripMsg f (Right (x,y,t)) = Right (x,y,f t) +#endif + +licenseRefRoundtrip :: LicenseRef -> Property +licenseRefRoundtrip x = + counterexample (prettyShow x) $ + Right x === eitherParsec (prettyShow x) + +simpleLicenseExpressionRoundtrip :: SimpleLicenseExpression -> Property +simpleLicenseExpressionRoundtrip x = + counterexample (prettyShow x) $ + Right x === eitherParsec (prettyShow x) + +licenseExpressionRoundtrip :: LicenseExpression -> Property +licenseExpressionRoundtrip x = + counterexample (prettyShow x) $ + Right (reassoc x) === eitherParsec (prettyShow x) + +-- Parser produces right biased trees of and/or expressions +reassoc :: LicenseExpression -> LicenseExpression +reassoc (EOr a b) = case reassoc a of + EOr x y -> EOr x (reassoc (EOr y b)) + x -> EOr x (reassoc b) +reassoc (EAnd a b) = case reassoc a of + EAnd x y -> EAnd x (reassoc (EAnd y b)) + x -> EAnd x (reassoc b) +reassoc l = l + +------------------------------------------------------------------------------- +-- isAcceptableLicence +------------------------------------------------------------------------------- + +shouldAccept :: [License] +shouldAccept = map License + [ simpleLicenseExpression GPL_2_0_only + , simpleLicenseExpression GPL_2_0_or_later + , simpleLicenseExpression BSD_2_Clause + , simpleLicenseExpression BSD_3_Clause + , simpleLicenseExpression MIT + , simpleLicenseExpression ISC + , simpleLicenseExpression MPL_2_0 + , simpleLicenseExpression Apache_2_0 + , simpleLicenseExpression CC0_1_0 + , simpleLicenseExpression BSD_4_Clause `EOr` simpleLicenseExpression MIT + ] + +shouldReject :: [License] +shouldReject = map License + [ simpleLicenseExpression BSD_4_Clause + , simpleLicenseExpression BSD_4_Clause `EAnd` simpleLicenseExpression MIT + ] + +-- | A sketch of what Hackage could accept +-- +-- * NONE is rejected +-- +-- * "or later" syntax (+ postfix) is rejected +-- +-- * "WITH exc" exceptions are rejected +-- +-- * There should be a way to interpert license as (conjunction of) +-- OSI-accepted licenses or CC0 +-- +isAcceptableLicense :: License -> Bool +isAcceptableLicense NONE = False +isAcceptableLicense (License expr) = goExpr expr + where + goExpr (EAnd a b) = goExpr a && goExpr b + goExpr (EOr a b) = goExpr a || goExpr b + goExpr (ELicense _ (Just _)) = False -- Don't allow exceptions + goExpr (ELicense s Nothing) = goSimple s + + goSimple (ELicenseRef _) = False -- don't allow referenced licenses + goSimple (ELicenseIdPlus _) = False -- don't allow + licenses (use GPL-3.0-or-later e.g.) + goSimple (ELicenseId CC0_1_0) = True -- CC0 isn't OSI approved, but we allow it as "PublicDomain", this is eg. PublicDomain in http://hackage.haskell.org/package/string-qq-0.0.2/src/LICENSE + goSimple (ELicenseId lid) = licenseIsOsiApproved lid -- allow only OSI approved licenses. + +shouldAcceptProp :: Property +shouldAcceptProp = conjoin $ + map (\l -> counterexample (prettyShow l) (isAcceptableLicense l)) shouldAccept + +shouldRejectProp :: Property +shouldRejectProp = conjoin $ + map (\l -> counterexample (prettyShow l) (not $ isAcceptableLicense l)) shouldReject diff --git a/cabal/Cabal-tests/tests/UnitTests/Distribution/Simple/Command.hs b/cabal/Cabal-tests/tests/UnitTests/Distribution/Simple/Command.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/UnitTests/Distribution/Simple/Command.hs @@ -0,0 +1,44 @@ +module UnitTests.Distribution.Simple.Command + ( tests + ) where + +import Distribution.Simple.Command +import qualified Distribution.Simple.Flag as Flag +import Distribution.Simple.Setup (optionVerbosity) +import qualified Distribution.Verbosity as Verbosity +import Test.Tasty +import Test.Tasty.HUnit + +argumentTests :: [TestTree] +argumentTests = + [ testCase "parses verbosity successfully" $ do + let p = commandParseArgs cmdUI isGlobal ["-v2"] + assertEqual "expected verbose" (Right verbose) $ evalParse p + , testCase "handles argument parse error gracefully" $ do + let p = commandParseArgs cmdUI isGlobal ["-v=2"] + assertEqual "expected error" (Left "errors") $ evalParse p + ] + where + -- evaluate command parse result, to force possible exceptions in 'f' + evalParse p = case p of + CommandErrors _ -> Left "errors" + CommandHelp _ -> Left "help" + CommandList _ -> Left "list" + CommandReadyToGo (f, _) -> Right $ f Flag.NoFlag + verbose = Flag.Flag Verbosity.verbose + isGlobal = True + cmdUI = CommandUI + { commandName = "cmd" + , commandSynopsis = "the command" + , commandUsage = \name -> name ++ " cmd -v[N]" + , commandDescription = Nothing + , commandNotes = Nothing + , commandDefaultFlags = Flag.NoFlag + , commandOptions = const [ optField ] + } + optField = optionVerbosity id const + +tests :: [TestTree] +tests = + [ testGroup "option argument tests" argumentTests + ] diff --git a/cabal/Cabal-tests/tests/UnitTests/Distribution/Simple/Glob.hs b/cabal/Cabal-tests/tests/UnitTests/Distribution/Simple/Glob.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/UnitTests/Distribution/Simple/Glob.hs @@ -0,0 +1,164 @@ +module UnitTests.Distribution.Simple.Glob + ( tests + ) where + +import Control.Monad +import Data.Foldable (for_) +import Data.Function (on) +import Data.List (sort) +import Data.Maybe (mapMaybe) +import Distribution.Simple.Glob +import qualified Distribution.Verbosity as Verbosity +import Distribution.CabalSpecVersion +import System.Directory (createDirectoryIfMissing) +import System.FilePath ((), splitFileName, normalise) +import System.IO.Temp (withSystemTempDirectory) +import Test.Tasty +import Test.Tasty.HUnit + +sampleFileNames :: [FilePath] +sampleFileNames = + [ "a" + , "a.html" + , "b.html" + , "b.html.gz" + , "foo/.blah.html" + , "foo/.html" + , "foo/a" + , "foo/a.html" + , "foo/a.html.gz" + , "foo/a.tex" + , "foo/a.tex.gz" + , "foo/b.html" + , "foo/b.html.gz" + , "foo/x.gz" + , "foo/bar/.html" + , "foo/bar/a.html" + , "foo/bar/a.html.gz" + , "foo/bar/a.tex" + , "foo/bar/a.tex.gz" + , "foo/bar/b.html" + , "foo/bar/b.html.gz" + , "foo/c.html/blah" + , "xyz/foo/a.html" + ] + +makeSampleFiles :: FilePath -> IO () +makeSampleFiles dir = for_ sampleFileNames $ \filename -> do + let (dir', name) = splitFileName filename + createDirectoryIfMissing True (dir dir') + writeFile (dir dir' name) $ "This is " ++ filename + +compatibilityTests :: CabalSpecVersion -> [TestTree] +compatibilityTests version = + [ testCase "literal match" $ + testMatches "foo/a" [GlobMatch "foo/a"] + , testCase "literal no match on prefix" $ + testMatches "foo/c.html" [] + , testCase "literal no match on suffix" $ + testMatches "foo/a.html" [GlobMatch "foo/a.html"] + , testCase "literal no prefix" $ + testMatches "a" [GlobMatch "a"] + , testCase "literal multiple prefix" $ + testMatches "foo/bar/a.html" [GlobMatch "foo/bar/a.html"] + , testCase "glob" $ + testMatches "*.html" [GlobMatch "a.html", GlobMatch "b.html"] + , testCase "glob in subdir" $ + testMatches "foo/*.html" [GlobMatch "foo/a.html", GlobMatch "foo/b.html"] + , testCase "glob multiple extensions" $ + testMatches "foo/*.html.gz" [GlobMatch "foo/a.html.gz", GlobMatch "foo/b.html.gz"] + , testCase "glob in deep subdir" $ + testMatches "foo/bar/*.tex" [GlobMatch "foo/bar/a.tex"] + , testCase "star in directory" $ + testFailParse "blah/*/foo" StarInDirectory + , testCase "star plus text in segment" $ + testFailParse "xyz*/foo" StarInDirectory + , testCase "star in filename plus text" $ + testFailParse "foo*.bar" StarInFileName + , testCase "no extension on star" $ + testFailParse "foo/*" NoExtensionOnStar + , testCase "star in extension" $ + testFailParse "foo.*.gz" StarInExtension + ] + where + testMatches = testMatchesVersion version + testFailParse = testFailParseVersion version + +-- For efficiency reasons, matchDirFileGlob isn't a simple call to +-- getDirectoryContentsRecursive and then a filter with +-- fileGlobMatches. So test both that naive approach and the actual +-- approach to make sure they are both correct. +-- +-- TODO: Work out how to construct the sample tree once for all tests, +-- rather than once for each test. +testMatchesVersion :: CabalSpecVersion -> FilePath -> [GlobResult FilePath] -> Assertion +testMatchesVersion version pat expected = do + globPat <- case parseFileGlob version pat of + Left _ -> assertFailure "Couldn't compile the pattern." + Right globPat -> return globPat + checkPure globPat + checkIO globPat + where + isEqual = (==) `on` (sort . fmap (fmap normalise)) + checkPure globPat = do + let actual = mapMaybe (fileGlobMatches globPat) sampleFileNames + unless (sort expected == sort actual) $ + assertFailure $ "Unexpected result (pure matcher): " ++ show actual + checkIO globPat = + withSystemTempDirectory "globstar-sample" $ \tmpdir -> do + makeSampleFiles tmpdir + actual <- runDirFileGlob Verbosity.normal tmpdir globPat + unless (isEqual actual expected) $ + assertFailure $ "Unexpected result (impure matcher): " ++ show actual + +testFailParseVersion :: CabalSpecVersion -> FilePath -> GlobSyntaxError -> Assertion +testFailParseVersion version pat expected = + case parseFileGlob version pat of + Left err -> unless (expected == err) $ + assertFailure $ "Unexpected error: " ++ show err + Right _ -> assertFailure "Unexpected success in parsing." + +globstarTests :: [TestTree] +globstarTests = + [ testCase "fails to parse on early spec version" $ + testFailParseVersion CabalSpecV2_2 "**/*.html" VersionDoesNotSupportGlobStar + , testCase "out-of-place double star" $ + testFailParse "blah/**/blah/*.foo" StarInDirectory + , testCase "multiple double star" $ + testFailParse "blah/**/**/*.foo" StarInDirectory + , testCase "fails with literal filename" $ + testFailParse "**/a.html" LiteralFileNameGlobStar + , testCase "with glob filename" $ + testMatches "**/*.html" [GlobMatch "a.html", GlobMatch "b.html", GlobMatch "foo/a.html", GlobMatch "foo/b.html", GlobMatch "foo/bar/a.html", GlobMatch "foo/bar/b.html", GlobMatch "xyz/foo/a.html"] + , testCase "glob with prefix" $ + testMatches "foo/**/*.html" [GlobMatch "foo/a.html", GlobMatch "foo/b.html", GlobMatch "foo/bar/a.html", GlobMatch "foo/bar/b.html"] + ] + where + testFailParse = testFailParseVersion CabalSpecV2_4 + testMatches = testMatchesVersion CabalSpecV2_4 + +multiDotTests :: [TestTree] +multiDotTests = + [ testCase "pre-2.4 single extension not matching multiple" $ + testMatchesVersion CabalSpecV2_2 "foo/*.gz" [GlobWarnMultiDot "foo/a.html.gz", GlobWarnMultiDot "foo/a.tex.gz", GlobWarnMultiDot "foo/b.html.gz", GlobMatch "foo/x.gz"] + , testCase "doesn't match literal" $ + testMatches "foo/a.tex" [GlobMatch "foo/a.tex"] + , testCase "works" $ + testMatches "foo/*.gz" [GlobMatch "foo/a.html.gz", GlobMatch "foo/a.tex.gz", GlobMatch "foo/b.html.gz", GlobMatch "foo/x.gz"] + , testCase "works with globstar" $ + testMatches "foo/**/*.gz" [GlobMatch "foo/a.html.gz", GlobMatch "foo/a.tex.gz", GlobMatch "foo/b.html.gz", GlobMatch "foo/x.gz", GlobMatch "foo/bar/a.html.gz", GlobMatch "foo/bar/a.tex.gz", GlobMatch "foo/bar/b.html.gz"] + ] + where + testMatches = testMatchesVersion CabalSpecV2_4 + +tests :: [TestTree] +tests = + [ testGroup "pre-2.4 compatibility" $ + compatibilityTests CabalSpecV2_2 + , testGroup "post-2.4 compatibility" $ + compatibilityTests CabalSpecV2_4 + , testGroup "globstar" globstarTests + , testCase "pre-1.6 rejects globbing" $ + testFailParseVersion CabalSpecV1_4 "foo/*.bar" VersionDoesNotSupportGlob + , testGroup "multi-dot globbing" multiDotTests + ] diff --git a/cabal/Cabal-tests/tests/UnitTests/Distribution/Simple/Program/GHC.hs b/cabal/Cabal-tests/tests/UnitTests/Distribution/Simple/Program/GHC.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/UnitTests/Distribution/Simple/Program/GHC.hs @@ -0,0 +1,172 @@ +module UnitTests.Distribution.Simple.Program.GHC (tests) where + +import Data.Algorithm.Diff (PolyDiff (..), getDiff) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit + +import Distribution.PackageDescription (emptyPackageDescription) +import Distribution.Simple.Program.GHC (normaliseGhcArgs) +import Distribution.Version (mkVersion) + +tests :: TestTree +tests = testGroup "Distribution.Simple.Program.GHC" + [ testGroup "normaliseGhcArgs" + [ testCase "options added in GHC-8.8" $ do + let flags :: [String] + flags = normaliseGhcArgs + (Just $ mkVersion [8,8,1]) + emptyPackageDescription + options_8_8_all + + assertListEquals flags options_8_8_affects + + , testCase "options added in GHC-8.10" $ do + let flags :: [String] + flags = normaliseGhcArgs + (Just $ mkVersion [8,10,1]) + emptyPackageDescription + options_8_10_all + + assertListEquals flags options_8_10_affects + + , testCase "options added in GHC-9.0" $ do + let flags :: [String] + flags = normaliseGhcArgs + (Just $ mkVersion [9,0,1]) + emptyPackageDescription + options_9_0_all + + assertListEquals flags options_9_0_affects + ] + ] + +assertListEquals :: (Eq a, Show a) => [a] -> [a] -> Assertion +assertListEquals xs ys + | xs == ys = return () + | otherwise = assertFailure $ unlines $ + "Lists are not equal" : + [ case d of + First x -> "- " ++ show x + Second y -> "+ " ++ show y + Both x _ -> " " ++ show x + | d <- getDiff xs ys + ] + +------------------------------------------------------------------------------- +-- GHC 8.8 +------------------------------------------------------------------------------- + +-- | Options added in GHC-8.8, to generate: +-- +-- @ +-- ghc-8.6.5 --show-options | sort > 8.6.5.txt +-- ghc-8.8.1 --show-options | sort > 8.8.1.txt +-- diff -u 8.6.5 8.8.1 +-- @ +-- +-- - remove -W(no-)error=, -W(no-)warn flags. +-- - split into all and flags which may affect artifacts +options_8_8_all :: [String] +options_8_8_all = + [ "-ddump-cfg-weights" + , "-dno-suppress-stg-exts" + , "-dsuppress-stg-exts" + , "-Wmissed-extra-shared-lib" + , "-Wmissing-deriving-strategies" + , "-Wmissing-space-after-bang" + , "-Wno-missed-extra-shared-lib" + , "-Wno-missing-deriving-strategies" + , "-Wno-missing-space-after-bang" + , "-fno-show-docs-of-hole-fits" + , "-fshow-docs-of-hole-fits" + ] ++ options_8_8_affects + +options_8_8_affects :: [String] +options_8_8_affects = + [ "-fblock-layout-cfg" + , "-fblock-layout-weightless" + , "-fblock-layout-weights" + , "-fclear-plugins" + , "-fkeep-cafs" + , "-fno-block-layout-cfg" + , "-fno-block-layout-weightless" + , "-fno-keep-cafs" + , "-fno-safe-haskell" + , "-fno-stg-lift-lams" + , "-fno-stg-lift-lams-known" + , "-fno-validate-ide-info" + , "-fno-write-ide-info" + , "-fstg-lift-lams" + , "-fstg-lift-lams-known" + , "-fstg-lift-lams-non-rec-args" + , "-fstg-lift-lams-non-rec-args-any" + , "-fstg-lift-lams-rec-args" + , "-fstg-lift-lams-rec-args-any" + , "-fvalidate-ide-info" + , "-fwrite-ide-info" + , "-hiedir" + , "-hiesuf" + , "-keep-hscpp-file" + , "-keep-hscpp-files" + ] + +------------------------------------------------------------------------------- +-- GHC 8.10 +------------------------------------------------------------------------------- + +options_8_10_all :: [String] +options_8_10_all = + [ "-ddump-cmm-verbose-by-proc" + , "-ddump-stg-final" + , "-ddump-stg-unarised" + , "-Wderiving-defaults" + , "-Winferred-safe-imports" + , "-Wmissing-safe-haskell-mode" + , "-Wno-deriving-defaults" + , "-Wno-inferred-safe-imports" + , "-Wno-missing-safe-haskell-mode" + , "-Wno-prepositive-qualified-module" + , "-Wno-redundant-record-wildcards" + , "-Wno-unused-packages" + , "-Wno-unused-record-wildcards" + , "-Wprepositive-qualified-module" + , "-Wredundant-record-wildcards" + , "-Wunused-packages" + , "-Wunused-record-wildcards" + , "-fdefer-diagnostics" + , "-fkeep-going" + , "-fprint-axiom-incomps" + , "-fno-defer-diagnostics" + , "-fno-keep-going" + , "-fno-print-axiom-incomps" + ] ++ options_8_10_affects + +options_8_10_affects :: [String] +options_8_10_affects = + [ "-dno-typeable-binds" + , "-fbinary-blob-threshold" + , "-fmax-pmcheck-models" + , "-fplugin-trustworthy" + , "-include-cpp-deps" + , "-optcxx" + ] + +------------------------------------------------------------------------------- +-- GHC-9.0 +------------------------------------------------------------------------------- + +options_9_0_all :: [String] +options_9_0_all = + [ "-ddump-cmm-opt" + , "-ddump-cpranal" + , "-ddump-cpr-signatures" + , "-ddump-hie" + -- NOTE: we filter out -dlinear-core-lint + -- we filter, -dcore-lint, -dstg-lint etc. + , "-dlinear-core-lint" + ] ++ options_9_0_affects + +options_9_0_affects :: [String] +options_9_0_affects = + [ "-fcmm-static-pred" + ] diff --git a/cabal/Cabal-tests/tests/UnitTests/Distribution/Simple/Program/Internal.hs b/cabal/Cabal-tests/tests/UnitTests/Distribution/Simple/Program/Internal.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/UnitTests/Distribution/Simple/Program/Internal.hs @@ -0,0 +1,36 @@ +module UnitTests.Distribution.Simple.Program.Internal + ( tests + ) where + +import Distribution.Simple.Program.Internal ( stripExtractVersion ) + +import Test.Tasty +import Test.Tasty.HUnit + +v :: String +v = "GNU strip (GNU Binutils; openSUSE 13.2) 2.24.0.20140403-6.1\nCopyright 2013\ + \ Free Software Foundation, Inc.\nThis program is free software; you may\ + \ redistribute it under the terms of\nthe GNU General Public License version 3\ + \ or (at your option) any later version.\nThis program has absolutely no\ + \ warranty.\n" + +v' :: String +v' = "GNU strip 2.17.50.0.6-26.el5 20061020" + +v'' :: String +v'' = "GNU strip (openSUSE-13.2) 2.23.50.0.6-26.el5 20061020" + +v''' :: String +v''' = "GNU strip (GNU (Binutils for) Ubuntu 12.04 ) 2.22" + +tests :: [TestTree] +tests = + [ testCase "Handles parentheses" $ + (stripExtractVersion v) @=? "2.24" + , testCase "Handles dashes and alphabetic characters" $ + (stripExtractVersion v') @=? "2.17" + , testCase "Handles single-word parenthetical expressions" $ + (stripExtractVersion v'') @=? "2.23" + , testCase "Handles nested parentheses" $ + (stripExtractVersion v''') @=? "2.22" + ] diff --git a/cabal/Cabal-tests/tests/UnitTests/Distribution/Simple/Utils.hs b/cabal/Cabal-tests/tests/UnitTests/Distribution/Simple/Utils.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/UnitTests/Distribution/Simple/Utils.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE GADTs #-} +module UnitTests.Distribution.Simple.Utils + ( tests + ) where + +import Distribution.Simple.BuildPaths ( exeExtension ) +import Distribution.Simple.Utils +import Distribution.System ( buildPlatform ) +import Distribution.Verbosity + +import Data.IORef +import System.Directory ( doesDirectoryExist, doesFileExist + , getTemporaryDirectory + , removeDirectoryRecursive, removeFile ) +import System.FilePath ( (<.>) ) +import System.IO (hClose, localeEncoding, hPutStrLn) +import System.IO.Error +import qualified Control.Exception as Exception + +import Test.Tasty +import Test.Tasty.HUnit + +withTempFileTest :: Assertion +withTempFileTest = do + fileName <- newIORef "" + tempDir <- getTemporaryDirectory + withTempFile tempDir ".foo" $ \fileName' _handle -> do + writeIORef fileName fileName' + fileExists <- readIORef fileName >>= doesFileExist + assertBool "Temporary file not deleted by 'withTempFile'!" (not fileExists) + +withTempFileRemovedTest :: Assertion +withTempFileRemovedTest = do + tempDir <- getTemporaryDirectory + withTempFile tempDir ".foo" $ \fileName handle -> do + hClose handle + removeFile fileName + +withTempDirTest :: Assertion +withTempDirTest = do + dirName <- newIORef "" + tempDir <- getTemporaryDirectory + withTempDirectory normal tempDir "foo" $ \dirName' -> do + writeIORef dirName dirName' + dirExists <- readIORef dirName >>= doesDirectoryExist + assertBool "Temporary directory not deleted by 'withTempDirectory'!" + (not dirExists) + +withTempDirRemovedTest :: Assertion +withTempDirRemovedTest = do + tempDir <- getTemporaryDirectory + withTempDirectory normal tempDir "foo" $ \dirPath -> do + removeDirectoryRecursive dirPath + +rawSystemStdInOutTextDecodingTest :: FilePath -> Assertion +rawSystemStdInOutTextDecodingTest ghcPath + -- We can only get this exception when the locale encoding is UTF-8 + -- so skip the test if it's not. + | show localeEncoding /= "UTF-8" = return () + | otherwise = do + tempDir <- getTemporaryDirectory + res <- withTempFile tempDir ".hs" $ \filenameHs handleHs -> do + withTempFile tempDir ".exe" $ \filenameExe handleExe -> do + -- Small program printing not utf8 + hPutStrLn handleHs "import Data.ByteString" + hPutStrLn handleHs "main = Data.ByteString.putStr (Data.ByteString.pack [32, 32, 255])" + hClose handleHs + + -- We need to close exe handle as well, otherwise compilation (writing) may fail + hClose handleExe + + -- Compile + (resOutput, resErrors, resExitCode) <- rawSystemStdInOut normal + ghcPath ["-o", filenameExe, filenameHs] + Nothing Nothing Nothing + IODataModeText + print (resOutput, resErrors, resExitCode) + + -- Execute + Exception.try $ do + rawSystemStdInOut normal + filenameExe [] + Nothing Nothing Nothing + IODataModeText -- not binary mode output, ie utf8 text mode so try to decode + case res of + Right (x1, x2, x3) -> assertFailure $ "expected IO decoding exception: " ++ show (x1,x2,x3) + Left err | isDoesNotExistError err -> Exception.throwIO err -- no ghc! + | otherwise -> return () + +dropExeExtensionTest :: Assertion +dropExeExtensionTest = + assertBool "dropExeExtension didn't drop exeExtension!" $ + dropExeExtension ("foo" <.> exeExtension buildPlatform) == "foo" + + +tests :: FilePath -> [TestTree] +tests ghcPath = + [ testCase "withTempFile works as expected" $ + withTempFileTest + , testCase "withTempFile can handle removed files" $ + withTempFileRemovedTest + , testCase "withTempDirectory works as expected" $ + withTempDirTest + , testCase "withTempDirectory can handle removed directories" $ + withTempDirRemovedTest + , testCase "rawSystemStdInOut reports text decoding errors" $ + rawSystemStdInOutTextDecodingTest ghcPath + , testCase "dropExeExtension drops exe extension" $ + dropExeExtensionTest + ] diff --git a/cabal/Cabal-tests/tests/UnitTests/Distribution/System.hs b/cabal/Cabal-tests/tests/UnitTests/Distribution/System.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/UnitTests/Distribution/System.hs @@ -0,0 +1,22 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module UnitTests.Distribution.System + ( tests + ) where + +import Distribution.Parsec +import Distribution.Pretty +import Distribution.System +import Test.Tasty +import Test.Tasty.QuickCheck (testProperty) +import Test.QuickCheck (Property, (===)) +import Test.QuickCheck.Instances.Cabal () + +textRoundtrip :: (Show a, Eq a, Pretty a, Parsec a) => a -> Property +textRoundtrip x = simpleParsec (prettyShow x) === Just x + +tests :: [TestTree] +tests = + [ testProperty "Text OS round trip" (textRoundtrip :: OS -> Property) + , testProperty "Text Arch round trip" (textRoundtrip :: Arch -> Property) + , testProperty "Text Platform round trip" (textRoundtrip :: Platform -> Property) + ] diff --git a/cabal/Cabal-tests/tests/UnitTests/Distribution/Types/GenericPackageDescription.hs b/cabal/Cabal-tests/tests/UnitTests/Distribution/Types/GenericPackageDescription.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/UnitTests/Distribution/Types/GenericPackageDescription.hs @@ -0,0 +1,37 @@ +{-# OPTIONS_GHC -fno-warn-deprecations #-} -- for importing "Distribution.Compat.Prelude.Internal" + +module UnitTests.Distribution.Types.GenericPackageDescription where + +import Prelude () +import Distribution.Compat.Prelude.Internal +import Distribution.Types.GenericPackageDescription + +import Test.Tasty +import Test.Tasty.HUnit +import qualified Control.Exception as C + +tests :: [TestTree] +tests = + [ testCase "GenericPackageDescription deepseq" gpdDeepseq + ] + +gpdFields :: [(String, GenericPackageDescription -> GenericPackageDescription)] +gpdFields = + [ ("packageDescription", \gpd -> gpd { packageDescription = undefined }) + , ("genPackageFlags", \gpd -> gpd { genPackageFlags = undefined }) + , ("condLibrary", \gpd -> gpd { condLibrary = undefined }) + , ("condSubLibraries", \gpd -> gpd { condSubLibraries = undefined }) + , ("condForeignLibs", \gpd -> gpd { condForeignLibs = undefined }) + , ("condExecutables", \gpd -> gpd { condExecutables = undefined }) + , ("condTestSuites", \gpd -> gpd { condTestSuites = undefined }) + , ("condBenchmarks", \gpd -> gpd { condBenchmarks = undefined }) + ] + +gpdDeepseq :: Assertion +gpdDeepseq = sequence_ + [ throwsUndefined msg (f emptyGenericPackageDescription) | (msg, f) <- gpdFields ] + +throwsUndefined :: NFData a => String -> a -> Assertion +throwsUndefined field a = + C.catch (C.evaluate (rnf a) >> assertFailure ("Deepseq failed to evaluate " ++ show field)) + (\(C.ErrorCall _) -> return ()) diff --git a/cabal/Cabal-tests/tests/UnitTests/Distribution/Utils/CharSet.hs b/cabal/Cabal-tests/tests/UnitTests/Distribution/Utils/CharSet.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/UnitTests/Distribution/Utils/CharSet.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE CPP #-} +-- isAlpha and isAlphaNum definitions change from base to base +#if MIN_VERSION_base(4,12,0) && !MIN_VERSION_base(4,13,0) +#define HAS_TESTS +#endif +module UnitTests.Distribution.Utils.CharSet where + +import Data.Char (isAlpha, isAlphaNum) +import Data.List (foldl') +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) + +import qualified Distribution.Utils.CharSet as CS + +tests :: TestTree +tests = testGroup "Distribution.Utils.CharSet" + [ testCase "alphanum" $ + CS.alphanum @?= foldl' (flip CS.insert) CS.empty + [ c | c <- [ minBound .. maxBound ], isAlphaNum c ] + + , testCase "alpha" $ + CS.alpha @?= foldl' (flip CS.insert) CS.empty + [ c | c <- [ minBound .. maxBound ], isAlpha c ] + + , testCase "alpha is subset of alphanum" $ + CS.union CS.alpha CS.alphanum @?= CS.alphanum + ] diff --git a/cabal/Cabal-tests/tests/UnitTests/Distribution/Utils/Generic.hs b/cabal/Cabal-tests/tests/UnitTests/Distribution/Utils/Generic.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/UnitTests/Distribution/Utils/Generic.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- to suppress WARNING in "Distribution.Compat.Prelude.Internal" +{-# OPTIONS_GHC -fno-warn-deprecations #-} + +module UnitTests.Distribution.Utils.Generic ( tests ) where + +import Prelude () +import Distribution.Compat.Prelude.Internal + +import Distribution.Utils.Generic + +import qualified Data.ByteString.Char8 as BS +import qualified Data.Text as T +import qualified Data.Text.Encoding as T + +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +tests :: [TestTree] +tests = + [ -- fromUTF8BS / toUTF8BS + testCase "fromUTF8BS mempty" testFromUTF8BSEmpty + , testCase "toUTF8BS mempty" testToUTF8BSEmpty + , testCase "toUTF8BS [U+D800..U+DFFF]" testToUTF8BSSurr + , testCase "toUTF8BS [U+0000..U+7F]" testToUTF8BSAscii + , testCase "toUTF8BS [U+0000..U+10FFFF]" testToUTF8BSText + , testCase "fromUTF8BS.toUTF8BS [U+0000..U+10FFFF]" testToFromUTF8BS + + , testProperty "fromUTF8BS.toUTF8BS == id" prop_toFromUTF8BS + , testProperty "toUTF8BS == encodeUtf8" prop_toUTF8BS + + , testProperty "Nothing = validateUtf8 (encodeUtf8 x)" prop_validateUtf8 + ] + +testFromUTF8BSEmpty :: Assertion +testFromUTF8BSEmpty = mempty @=? fromUTF8BS mempty + +testToUTF8BSEmpty :: Assertion +testToUTF8BSEmpty = mempty @=? toUTF8BS mempty + +testToUTF8BSSurr :: Assertion +testToUTF8BSSurr = BS.concat (replicate 2048 u_fffd) @=? toUTF8BS surrogates + where + surrogates = ['\xD800'..'\xDFFF'] + u_fffd = "\xEF\xBF\xBD" + +testToUTF8BSText :: Assertion +testToUTF8BSText = T.encodeUtf8 (T.pack txt) @=? toUTF8BS txt + where + txt = ['\x00'..'\x10FFFF'] + +testToUTF8BSAscii :: Assertion +testToUTF8BSAscii = BS.pack txt @=? toUTF8BS txt + where + txt = ['\x00'..'\x7F'] + +testToFromUTF8BS :: Assertion +testToFromUTF8BS = txt @=? (fromUTF8BS . toUTF8BS) txt + where + txt = ['\x0000'..'\xD7FF'] ++ ['\xE000'..'\x10FFFF'] + +prop_toFromUTF8BS :: [Char] -> Property +prop_toFromUTF8BS txt = txt === (fromUTF8BS . toUTF8BS) txt + +prop_toUTF8BS :: [Char] -> Property +prop_toUTF8BS txt = T.encodeUtf8 (T.pack txt) === toUTF8BS txt + +prop_validateUtf8 :: [Char] -> Property +prop_validateUtf8 txt = Nothing === validateUTF8 (toUTF8BS txt) diff --git a/cabal/Cabal-tests/tests/UnitTests/Distribution/Utils/Json.hs b/cabal/Cabal-tests/tests/UnitTests/Distribution/Utils/Json.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/UnitTests/Distribution/Utils/Json.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +module UnitTests.Distribution.Utils.Json + ( tests + ) where + +import Distribution.Utils.Json + +import Test.Tasty +import Test.Tasty.HUnit + +tests :: [TestTree] +tests = + [ testCase "escapes strings correctly" $ + renderJson (JsonString "foo\"bar") @?= "\"foo\\\"bar\"" + , testCase "renders empty list" $ + renderJson (JsonArray []) @?= "[]" + , testCase "renders singleton list" $ + renderJson (JsonArray [JsonString "foo\"bar"]) @?= "[\"foo\\\"bar\"]" + , testCase "renders list" $ + renderJson (JsonArray [JsonString "foo\"bar", JsonString "baz"]) @?= "[\"foo\\\"bar\",\"baz\"]" + , testCase "renders empty object" $ + renderJson (JsonObject []) @?= "{}" + , testCase "renders singleton object" $ + renderJson (JsonObject [("key", JsonString "foo\"bar")]) @?= "{\"key\":\"foo\\\"bar\"}" + , testCase "renders object" $ + renderJson (JsonObject + [ ("key", JsonString "foo\"bar") + , ("key2", JsonString "baz")]) + @?= "{\"key\":\"foo\\\"bar\",\"key2\":\"baz\"}" + , testCase "renders number" $ + renderJson (JsonNumber 0) @?= "0" + , testCase "renders negative number" $ + renderJson (JsonNumber (-1)) @?= "-1" + , testCase "renders big number" $ + renderJson (JsonNumber 5000000) @?= "5000000" + , testCase "renders bool" $ do + renderJson (JsonBool True) @?= "true" + renderJson (JsonBool False) @?= "false" + , testCase "renders null" $ do + renderJson JsonNull @?= "null" + ] diff --git a/cabal/Cabal-tests/tests/UnitTests/Distribution/Utils/NubList.hs b/cabal/Cabal-tests/tests/UnitTests/Distribution/Utils/NubList.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/UnitTests/Distribution/Utils/NubList.hs @@ -0,0 +1,76 @@ +-- to suppress WARNING in "Distribution.Compat.Prelude.Internal" +{-# OPTIONS_GHC -fno-warn-deprecations #-} +module UnitTests.Distribution.Utils.NubList + ( tests + ) where + +import Prelude () +import Distribution.Compat.Prelude.Internal + +import Distribution.Utils.NubList +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +tests :: [TestTree] +tests = + [ testCase "NubList retains ordering example" testOrdering + , testCase "NubList removes duplicates example" testDeDupe + , testProperty "NubList retains ordering" prop_Ordering + , testProperty "NubList removes duplicates" prop_DeDupe + , testProperty "fromNubList . toNubList = nub" prop_Nub + , testProperty "Monoid NubList Identity" prop_Identity + , testProperty "Monoid NubList Associativity" prop_Associativity + -- NubListR + , testProperty "NubListR removes duplicates from the right" prop_DeDupeR + ] + +someIntList :: [Int] +-- This list must not have duplicate entries. +someIntList = [ 1, 3, 4, 2, 0, 7, 6, 5, 9, -1 ] + +testOrdering :: Assertion +testOrdering = + assertBool "Maintains element ordering:" $ + fromNubList (toNubList someIntList) == someIntList + +testDeDupe :: Assertion +testDeDupe = + assertBool "De-duplicates a list:" $ + fromNubList (toNubList (someIntList ++ someIntList)) == someIntList + +-- --------------------------------------------------------------------------- +-- QuickCheck properties for NubList + +prop_Ordering :: [Int] -> Property +prop_Ordering xs = + mempty <> toNubList xs' === toNubList xs' <> mempty + where + xs' = nub xs + +prop_DeDupe :: [Int] -> Property +prop_DeDupe xs = + fromNubList (toNubList (xs' ++ xs)) === xs' -- Note, we append primeless xs + where + xs' = nub xs + +prop_DeDupeR :: [Int] -> Property +prop_DeDupeR xs = + fromNubListR (toNubListR (xs ++ xs')) === xs' -- Note, we prepend primeless xs + where + xs' = nub xs + +prop_Nub :: [Int] -> Property +prop_Nub xs = rhs === lhs + where + rhs = fromNubList (toNubList xs) + lhs = nub xs + +prop_Identity :: [Int] -> Bool +prop_Identity xs = + mempty `mappend` toNubList xs == toNubList xs `mappend` mempty + +prop_Associativity :: [Int] -> [Int] -> [Int] -> Bool +prop_Associativity xs ys zs = + (toNubList xs `mappend` toNubList ys) `mappend` toNubList zs + == toNubList xs `mappend` (toNubList ys `mappend` toNubList zs) diff --git a/cabal/Cabal-tests/tests/UnitTests/Distribution/Utils/ShortText.hs b/cabal/Cabal-tests/tests/UnitTests/Distribution/Utils/ShortText.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/UnitTests/Distribution/Utils/ShortText.hs @@ -0,0 +1,33 @@ +module UnitTests.Distribution.Utils.ShortText + ( tests + ) where + +import Data.Monoid as Mon +import Test.Tasty +import Test.Tasty.QuickCheck + +import Distribution.Compat.Binary (encode, decode) + +import Distribution.Utils.ShortText + +prop_ShortTextOrd :: String -> String -> Bool +prop_ShortTextOrd a b = compare a b == compare (toShortText a) (toShortText b) + +prop_ShortTextMonoid :: String -> String -> Bool +prop_ShortTextMonoid a b = Mon.mappend a b == fromShortText (mappend (toShortText a) (toShortText b)) + +prop_ShortTextId :: String -> Bool +prop_ShortTextId a = (fromShortText . toShortText) a == a + +prop_ShortTextBinaryId :: String -> Bool +prop_ShortTextBinaryId a = (decode . encode) a' == a' + where + a' = toShortText a + +tests :: [TestTree] +tests = + [ testProperty "ShortText Id" prop_ShortTextId + , testProperty "ShortText Ord" prop_ShortTextOrd + , testProperty "ShortText Monoid" prop_ShortTextMonoid + , testProperty "ShortText BinaryId" prop_ShortTextBinaryId + ] diff --git a/cabal/Cabal-tests/tests/UnitTests/Distribution/Utils/Structured.hs b/cabal/Cabal-tests/tests/UnitTests/Distribution/Utils/Structured.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/UnitTests/Distribution/Utils/Structured.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE CPP #-} +module UnitTests.Distribution.Utils.Structured (tests) where + +import Data.Proxy (Proxy (..)) +import Distribution.Utils.MD5 (md5FromInteger) +import Distribution.Utils.Structured (structureHash, Structured) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=), Assertion) + +import Distribution.SPDX.License (License) +import Distribution.Types.VersionRange (VersionRange) + +#if MIN_VERSION_base(4,7,0) +import Distribution.Types.GenericPackageDescription (GenericPackageDescription) +import Distribution.Types.LocalBuildInfo (LocalBuildInfo) +#endif + +import UnitTests.Orphans () + +tests :: TestTree +tests = testGroup "Distribution.Utils.Structured" + -- This test also verifies that structureHash doesn't loop. + [ testCase "VersionRange" $ + md5Check (Proxy :: Proxy VersionRange) 0x39396fc4f2d751aaa1f94e6d843f03bd + , testCase "SPDX.License" $ + md5Check (Proxy :: Proxy License) 0xd3d4a09f517f9f75bc3d16370d5a853a + -- The difference is in encoding of newtypes +#if MIN_VERSION_base(4,7,0) + , testCase "GenericPackageDescription" $ + md5Check (Proxy :: Proxy GenericPackageDescription) 0xaf3d4c667a8f019c98a45451419ad71c + , testCase "LocalBuildInfo" $ + md5Check (Proxy :: Proxy LocalBuildInfo) 0x6d132d3f99c869b678468256f24b6241 +#endif + ] + +-- -------------------------------------------------------------------- -- +-- utils + +md5Check :: Structured a => Proxy a -> Integer -> Assertion +md5Check proxy md5Int = structureHash proxy @?= md5FromInteger md5Int diff --git a/cabal/Cabal-tests/tests/UnitTests/Distribution/Version.hs b/cabal/Cabal-tests/tests/UnitTests/Distribution/Version.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/UnitTests/Distribution/Version.hs @@ -0,0 +1,419 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns + -fno-warn-deprecations + -fno-warn-unused-binds #-} --FIXME +module UnitTests.Distribution.Version (versionTests) where + +import Distribution.Compat.Prelude.Internal +import Prelude () + +import Distribution.Parsec (simpleParsec) +import Distribution.Pretty +import Distribution.Types.VersionRange.Internal +import Distribution.Utils.Generic +import Distribution.Version + + +import Data.Maybe (fromJust) +import Data.Typeable (typeOf) +import Test.QuickCheck (Arbitrary (..), NonEmptyList (..), NonNegative (..), Property, Testable, counterexample, property, (===), (==>), vectorOf, sized, choose, arbitrarySizedNatural) +import Test.QuickCheck.Instances.Cabal () +import Test.Tasty (TestTree) +import Test.Tasty.QuickCheck (testProperty) + +import qualified Distribution.Types.VersionInterval as New +import qualified Distribution.Types.VersionInterval.Legacy as Old +import qualified Text.PrettyPrint as Disp + +versionTests :: [TestTree] +versionTests = + -- test 'Version' type + [ tp "versionNumbers . mkVersion = id @[NonNegative Int]" prop_VersionId + , tp "versionNumbers . mkVersion = id @Base.Version" prop_VersionId2 + , tp "(==) = (==) `on` versionNumbers" prop_VersionEq + , tp "(==) = (==) `on` mkVersion" prop_VersionEq2 + , tp "compare = compare `on` versionNumbers" prop_VersionOrd + , tp "compare = compare `on` mkVersion" prop_VersionOrd2 + + , tp "readMaybe . show = Just" prop_ShowRead + , tp "read example" prop_ShowRead_example + + , tp "parsec . prettyShow involutive" prop_parsec_disp_inv + + , tp "normaliseVersionRange involutive" prop_normalise_inv + , tp "normaliseVersionRange equivalent" prop_normalise_equiv + , tp "normaliseVersionRange caretequiv" prop_normalise_caret_equiv + , tp "normaliseVersionRange model" prop_normalise_model + + , tp "simplifyVersionRange involutive" prop_simplify_inv + , tp "simplifyVersionRange equivalent" prop_simplify_equiv + -- , tp "simplifyVersionRange caretequiv" prop_simplify_caret_equiv + + , tp "simpleParsec . prettyShow = Just" prop_parse_disp + ] + + ++ + zipWith + (\n (rep, p) -> testProperty ("Range Property " ++ show n ++ " (" ++ show rep ++ ")") p) + [1::Int ..] + -- properties to validate the test framework + [ typProperty prop_nonNull + , typProperty prop_gen_intervals1 + , typProperty prop_gen_intervals2 + + , typProperty prop_anyVersion + , typProperty prop_noVersion + , typProperty prop_thisVersion + , typProperty prop_notThisVersion + , typProperty prop_laterVersion + , typProperty prop_orLaterVersion + , typProperty prop_earlierVersion + , typProperty prop_orEarlierVersion + , typProperty prop_unionVersionRanges + , typProperty prop_intersectVersionRanges + , typProperty prop_withinVersion + , typProperty prop_foldVersionRange + + -- converting between version ranges and version intervals + , typProperty prop_to_from_intervals + ] + where + tp :: Testable p => String -> p -> TestTree + tp = testProperty + + typProperty p = (typeOf p, property p) + +------------------------------------------------------------------------------- +-- Arbitrary for inputs of mkVersion +------------------------------------------------------------------------------- + +newtype VersionArb = VersionArb [Int] + deriving (Eq,Ord,Show) + +-- | 'Version' instance as used by QC 2.9 +instance Arbitrary VersionArb where + arbitrary = sized $ \n -> + do k <- choose (0, log2 n) + xs <- vectorOf (k+1) arbitrarySizedNatural + return (VersionArb xs) + where + log2 :: Int -> Int + log2 n | n <= 1 = 0 + | otherwise = 1 + log2 (n `div` 2) + + shrink (VersionArb xs) = + [ VersionArb xs' + | xs' <- shrink xs + , length xs' > 0 + , all (>=0) xs' + ] + +--------------------- +-- Version properties +-- + +prop_VersionId :: [NonNegative Int] -> Bool +prop_VersionId lst0 = + (versionNumbers . mkVersion) lst == lst + where + lst = map getNonNegative lst0 + +prop_VersionId2 :: VersionArb -> Bool +prop_VersionId2 (VersionArb lst) = + (versionNumbers . mkVersion) lst == lst + +prop_VersionEq :: Version -> Version -> Bool +prop_VersionEq v1 v2 = (==) v1 v2 == ((==) `on` versionNumbers) v1 v2 + +prop_VersionEq2 :: VersionArb -> VersionArb -> Bool +prop_VersionEq2 (VersionArb v1) (VersionArb v2) = + (==) v1 v2 == ((==) `on` mkVersion) v1 v2 + +prop_VersionOrd :: Version -> Version -> Bool +prop_VersionOrd v1 v2 = + compare v1 v2 == (compare `on` versionNumbers) v1 v2 + +prop_VersionOrd2 :: VersionArb -> VersionArb -> Bool +prop_VersionOrd2 (VersionArb v1) (VersionArb v2) = + (==) v1 v2 == ((==) `on` mkVersion) v1 v2 + +prop_ShowRead :: Version -> Property +prop_ShowRead v = Just v === readMaybe (show v) + +prop_ShowRead_example :: Bool +prop_ShowRead_example = show (mkVersion [1,2,3]) == "mkVersion [1,2,3]" + +--------------------------- +-- VersionRange properties +-- + +prop_normalise_inv :: VersionRange -> Property +prop_normalise_inv vr = normaliseVersionRange vr === normaliseVersionRange (normaliseVersionRange vr) + +prop_normalise_equiv :: VersionRange -> Version -> Property +prop_normalise_equiv vr = + prop_equivalentVersionRange vr (normaliseVersionRange vr) + +prop_normalise_caret_equiv :: VersionRange -> Version -> Property +prop_normalise_caret_equiv vr = prop_equivalentVersionRange + (transformCaretUpper vr) + (transformCaretUpper (normaliseVersionRange vr)) + +prop_normalise_model :: VersionRange -> Property +prop_normalise_model vr = + oldNormaliseVersionRange vr' === newNormaliseVersionRange vr' + where + vr' = transformCaret vr + + oldNormaliseVersionRange :: VersionRange -> VersionRange + oldNormaliseVersionRange = Old.fromVersionIntervals . Old.toVersionIntervals + + newNormaliseVersionRange :: VersionRange -> VersionRange + newNormaliseVersionRange = New.normaliseVersionRange2 + +prop_simplify_inv :: VersionRange -> Property +prop_simplify_inv vr = + simplifyVersionRange vr === simplifyVersionRange (simplifyVersionRange vr) + +prop_simplify_equiv :: VersionRange -> Version -> Property +prop_simplify_equiv vr v = + counterexample (show vr') $ prop_equivalentVersionRange vr vr' v + where + vr' = simplifyVersionRange vr + +-- TODO: Doesn't hold yet +-- prop_simplify_caret_equiv :: VersionRange -> Version -> Property +-- prop_simplify_caret_equiv vr = prop_equivalentVersionRange +-- (transformCaretUpper vr) +-- (transformCaretUpper (simplifyVersionRange vr)) + +prop_nonNull :: Version -> Bool +prop_nonNull = (/= nullVersion) + +prop_anyVersion :: Version -> Bool +prop_anyVersion v' = + withinRange v' anyVersion + +prop_noVersion :: Version -> Bool +prop_noVersion v' = + withinRange v' noVersion == False + +prop_thisVersion :: Version -> Version -> Bool +prop_thisVersion v v' = + withinRange v' (thisVersion v) + == (v' == v) + +prop_notThisVersion :: Version -> Version -> Bool +prop_notThisVersion v v' = + withinRange v' (notThisVersion v) + == (v' /= v) + +prop_laterVersion :: Version -> Version -> Bool +prop_laterVersion v v' = + withinRange v' (laterVersion v) + == (v' > v) + +prop_orLaterVersion :: Version -> Version -> Bool +prop_orLaterVersion v v' = + withinRange v' (orLaterVersion v) + == (v' >= v) + +prop_earlierVersion :: Version -> Version -> Bool +prop_earlierVersion v v' = + withinRange v' (earlierVersion v) + == (v' < v) + +prop_orEarlierVersion :: Version -> Version -> Bool +prop_orEarlierVersion v v' = + withinRange v' (orEarlierVersion v) + == (v' <= v) + +prop_unionVersionRanges :: VersionRange -> VersionRange -> Version -> Bool +prop_unionVersionRanges vr1 vr2 v' = + withinRange v' (unionVersionRanges vr1 vr2) + == (withinRange v' vr1 || withinRange v' vr2) + +prop_intersectVersionRanges :: VersionRange -> VersionRange -> Version -> Bool +prop_intersectVersionRanges vr1 vr2 v' = + withinRange v' (intersectVersionRanges vr1 vr2) + == (withinRange v' vr1 && withinRange v' vr2) + +prop_withinVersion :: Version -> Version -> Property +prop_withinVersion v v' = + withinRange v' (withinVersion v) + === + (v' >= v && v' < upper v) + where + upper = alterVersion $ \numbers -> case unsnoc numbers of + Nothing -> [] + Just (xs, x) -> xs ++ [x + 1] + +prop_foldVersionRange :: VersionRange -> Property +prop_foldVersionRange range = + expandVR range + === foldVersionRange anyVersion thisVersion + laterVersion earlierVersion + unionVersionRanges intersectVersionRanges + range + where + expandVR (MajorBoundVersion v) = + intersectVersionRanges (expandVR (orLaterVersion v)) (earlierVersion (majorUpperBound v)) + expandVR (OrEarlierVersion v) = + unionVersionRanges (thisVersion v) (earlierVersion v) + expandVR (OrLaterVersion v) = + unionVersionRanges (thisVersion v) (laterVersion v) + expandVR (UnionVersionRanges v1 v2) = + UnionVersionRanges (expandVR v1) (expandVR v2) + expandVR (IntersectVersionRanges v1 v2) = + IntersectVersionRanges (expandVR v1) (expandVR v2) + expandVR v = v + + upper = alterVersion $ \numbers -> case unsnoc numbers of + Nothing -> [] + Just (xs, x) -> xs ++ [x + 1] + +prop_isAnyVersion1 :: VersionRange -> Version -> Property +prop_isAnyVersion1 range version = + isAnyVersion range ==> withinRange version range + +prop_isAnyVersion2 :: VersionRange -> Property +prop_isAnyVersion2 range = + isAnyVersion range ==> + foldVersionRange True (\_ -> False) (\_ -> False) (\_ -> False) + (\_ _ -> False) (\_ _ -> False) + (simplifyVersionRange range) + +prop_isNoVersion :: VersionRange -> Version -> Property +prop_isNoVersion range version = + isNoVersion range ==> not (withinRange version range) + +prop_isSpecificVersion1 :: VersionRange -> NonEmptyList Version -> Property +prop_isSpecificVersion1 range (NonEmpty versions) = + isJust version && not (null versions') ==> + allEqual (fromJust version) versions' + where + version = isSpecificVersion range + versions' = filter (`withinRange` range) versions + allEqual x xs = and (zipWith (==) (x:xs) xs) + +prop_isSpecificVersion2 :: VersionRange -> Property +prop_isSpecificVersion2 range = + isJust version ==> + foldVersionRange Nothing Just (\_ -> Nothing) (\_ -> Nothing) + (\_ _ -> Nothing) (\_ _ -> Nothing) + (simplifyVersionRange range) + == version + + where + version = isSpecificVersion range + +-- | Check that our VersionIntervals' arbitrary instance generates intervals +-- that satisfies the invariant. +-- +prop_gen_intervals1 :: VersionIntervals -> Property +prop_gen_intervals1 = property . New.invariantVersionIntervals + +-- | Check that constructing our intervals type and converting it to a +-- 'VersionRange' and then into the true intervals type gives us back +-- the exact same sequence of intervals. This tells us that our arbitrary +-- instance for 'VersionIntervals'' is ok. +-- +prop_gen_intervals2 :: VersionIntervals -> Property +prop_gen_intervals2 intervals = + toVersionIntervals (fromVersionIntervals intervals) === intervals +-- +-- | @'toVersionIntervals' . 'fromVersionIntervals'@ is an exact identity on +-- 'VersionIntervals'. +-- +prop_to_from_intervals :: VersionIntervals -> Bool +prop_to_from_intervals intervals = + toVersionIntervals (fromVersionIntervals intervals) == intervals + +-------------------------------- +-- equivalentVersionRange helper + +prop_equivalentVersionRange + :: VersionRange -> VersionRange -> Version -> Property +prop_equivalentVersionRange range range' version = + withinRange version range === withinRange version range' + +-------------------------------- +-- Parsing and pretty printing +-- +prop_parsec_disp_inv :: VersionRange -> Property +prop_parsec_disp_inv vr = + parseDisp vr === (parseDisp vr >>= parseDisp) + where + parseDisp = simpleParsec . prettyShow + +prop_parse_disp :: VersionRange -> Property +prop_parse_disp vr = counterexample (show (prettyShow vr')) $ + fmap s (simpleParsec (prettyShow vr')) === Just vr' + where + -- we have to strip parens, because arbitrary 'VersionRange' may have + -- too little parens constructors. + s = stripParensVersionRange + vr' = s vr + +prop_parse_disp1 :: VersionRange -> Bool +prop_parse_disp1 vr = + simpleParsec (prettyShow vr) == Just (normaliseVersionRange vr) + +prop_parse_disp2 :: VersionRange -> Property +prop_parse_disp2 vr = + let b = fmap (prettyShow :: VersionRange -> String) (simpleParsec (prettyShow vr)) + a = Just (prettyShow vr) + in + counterexample ("Expected: " ++ show a) $ + counterexample ("But got: " ++ show b) $ + b == a + +prop_parse_disp3 :: VersionRange -> Property +prop_parse_disp3 vr = + let a = Just (prettyShow vr) + b = fmap displayRaw (simpleParsec (prettyShow vr)) + in + counterexample ("Expected: " ++ show a) $ + counterexample ("But got: " ++ show b) $ + b == a + +prop_parse_disp4 :: VersionRange -> Property +prop_parse_disp4 vr = + let a = Just vr + b = (simpleParsec (prettyShow vr)) + in + counterexample ("Expected: " ++ show a) $ + counterexample ("But got: " ++ show b) $ + b == a + +prop_parse_disp5 :: VersionRange -> Property +prop_parse_disp5 vr = + let a = Just vr + b = simpleParsec (displayRaw vr) + in + counterexample ("Expected: " ++ show a) $ + counterexample ("But got: " ++ show b) $ + b == a + +displayRaw :: VersionRange -> String +displayRaw = + Disp.render + . cataVersionRange alg . normaliseVersionRange + where + + -- precedence: + -- All the same as the usual pretty printer, except for the parens + alg (ThisVersionF v) = Disp.text "==" <<>> pretty v + alg (LaterVersionF v) = Disp.char '>' <<>> pretty v + alg (EarlierVersionF v) = Disp.char '<' <<>> pretty v + alg (OrLaterVersionF v) = Disp.text ">=" <<>> pretty v + alg (OrEarlierVersionF v) = Disp.text "<=" <<>> pretty v + alg (MajorBoundVersionF v) = Disp.text "^>=" <<>> pretty v + alg (UnionVersionRangesF r1 r2) = r1 <+> Disp.text "||" <+> r2 + alg (IntersectVersionRangesF r1 r2) = r1 <+> Disp.text "&&" <+> r2 + + dispWild v = + Disp.hcat (Disp.punctuate (Disp.char '.') + (map Disp.int (versionNumbers v))) + <<>> Disp.text ".*" diff --git a/cabal/Cabal-tests/tests/UnitTests/Orphans.hs b/cabal/Cabal-tests/tests/UnitTests/Orphans.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/UnitTests/Orphans.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module UnitTests.Orphans where + +#if !MIN_VERSION_base(4,7,0) +import GHC.Fingerprint (Fingerprint (..)) + +deriving instance Show Fingerprint +#endif diff --git a/cabal/Cabal-tests/tests/cbits/rpmvercmp.c b/cabal/Cabal-tests/tests/cbits/rpmvercmp.c new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/cbits/rpmvercmp.c @@ -0,0 +1,141 @@ +/* + * This code is taken from the RPM package manager. + * + * RPM is Copyright (c) 1998 by Red Hat Software, Inc., + * and may be distributed under the terms of the GPL and LGPL. + * See http://rpm.org/gitweb?p=rpm.git;a=blob_plain;f=COPYING;hb=HEAD + * + * The code should follow upstream as closely as possible. + * See http://rpm.org/gitweb?p=rpm.git;a=blob_plain;f=lib/rpmvercmp.c;hb=HEAD + * + * Currently the only difference as a policy is that upstream uses C99 + * features and pkg-config does not require a C99 compiler yet. + */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif + +#include +#include +#include + +/* macros to help code look more like upstream */ +#define rstreq(a, b) (strcmp(a, b) == 0) +#define risalnum(c) isalnum((char)(c)) +#define risdigit(c) isdigit((char)(c)) +#define risalpha(c) isalpha((char)(c)) + +int rmpvercmp_impl(const char *a, const char *b, char *buf1, char *buf2); + +/* compare alpha and numeric segments of two versions */ +/* return 1: a is newer than b */ +/* 0: a and b are the same version */ +/* -1: b is newer than a */ +int rpmvercmp(const char * a, const char * b) +{ + /* easy comparison to see if versions are identical */ + if (rstreq(a, b)) return 0; + + char *buf1 = malloc(strlen(a) + 1); + char *buf2 = malloc(strlen(b) + 1); + + if (!buf1 || !buf2) return 0; // arbitrary + + int r = rmpvercmp_impl(a, b, buf1, buf2); + + free(buf1); + free(buf2); + + return r; +} + +int rmpvercmp_impl(const char *a, const char *b, char *str1, char *str2) { + char oldch1, oldch2; + char * one, * two; + int rc; + int isnum; + + strcpy(str1, a); + strcpy(str2, b); + + one = str1; + two = str2; + + /* loop through each version segment of str1 and str2 and compare them */ + while (*one && *two) { + while (*one && !risalnum(*one)) one++; + while (*two && !risalnum(*two)) two++; + + /* If we ran to the end of either, we are finished with the loop */ + if (!(*one && *two)) break; + + str1 = one; + str2 = two; + + /* grab first completely alpha or completely numeric segment */ + /* leave one and two pointing to the start of the alpha or numeric */ + /* segment and walk str1 and str2 to end of segment */ + if (risdigit(*str1)) { + while (*str1 && risdigit(*str1)) str1++; + while (*str2 && risdigit(*str2)) str2++; + isnum = 1; + } else { + while (*str1 && risalpha(*str1)) str1++; + while (*str2 && risalpha(*str2)) str2++; + isnum = 0; + } + + /* save character at the end of the alpha or numeric segment */ + /* so that they can be restored after the comparison */ + oldch1 = *str1; + *str1 = '\0'; + oldch2 = *str2; + *str2 = '\0'; + + /* this cannot happen, as we previously tested to make sure that */ + /* the first string has a non-null segment */ + if (one == str1) return -1; /* arbitrary */ + + /* take care of the case where the two version segments are */ + /* different types: one numeric, the other alpha (i.e. empty) */ + /* numeric segments are always newer than alpha segments */ + /* XXX See patch #60884 (and details) from bugzilla #50977. */ + if (two == str2) return (isnum ? 1 : -1); + + if (isnum) { + /* this used to be done by converting the digit segments */ + /* to ints using atoi() - it's changed because long */ + /* digit segments can overflow an int - this should fix that. */ + + /* throw away any leading zeros - it's a number, right? */ + while (*one == '0') one++; + while (*two == '0') two++; + + /* whichever number has more digits wins */ + if (strlen(one) > strlen(two)) return 1; + if (strlen(two) > strlen(one)) return -1; + } + + /* strcmp will return which one is greater - even if the two */ + /* segments are alpha or if they are numeric. don't return */ + /* if they are equal because there might be more segments to */ + /* compare */ + rc = strcmp(one, two); + if (rc) return (rc < 1 ? -1 : 1); + + /* restore character that was replaced by null above */ + *str1 = oldch1; + one = str1; + *str2 = oldch2; + two = str2; + } + + /* this catches the case where all numeric and alpha segments have */ + /* compared identically but the segment separating characters were */ + /* different */ + if ((!*one) && (!*two)) return 0; + + /* whichever version still has characters left over wins */ + if (!*one) return -1; else return 1; +} diff --git a/cabal/Cabal-tests/tests/custom-setup/CabalDoctestSetup.hs b/cabal/Cabal-tests/tests/custom-setup/CabalDoctestSetup.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/custom-setup/CabalDoctestSetup.hs @@ -0,0 +1,590 @@ +-- This is Distribution.Extra.Doctest module from cabal-doctest-1.0.4 +-- This isn't technically a Custom-Setup script, but it /was/. + +{- + +Copyright (c) 2017, Oleg Grenrus + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Oleg Grenrus nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +-- | The provided 'generateBuildModule' generates 'Build_doctests' module. +-- That module exports enough configuration, so your doctests could be simply +-- +-- @ +-- module Main where +-- +-- import Build_doctests (flags, pkgs, module_sources) +-- import Data.Foldable (traverse_) +-- import Test.Doctest (doctest) +-- +-- main :: IO () +-- main = do +-- traverse_ putStrLn args -- optionally print arguments +-- doctest args +-- where +-- args = flags ++ pkgs ++ module_sources +-- @ +-- +-- To use this library in the @Setup.hs@, you should specify a @custom-setup@ +-- section in the cabal file, for example: +-- +-- @ +-- custom-setup +-- setup-depends: +-- base >= 4 && <5, +-- cabal-doctest >= 1 && <1.1 +-- @ +-- +-- /Note:/ you don't need to depend on @Cabal@ if you use only +-- 'defaultMainWithDoctests' in the @Setup.hs@. +-- +module CabalDoctestSetup ( + defaultMainWithDoctests, + defaultMainAutoconfWithDoctests, + addDoctestsUserHook, + doctestsUserHooks, + generateBuildModule, + ) where + +-- Hacky way to suppress few deprecation warnings. +#if MIN_VERSION_Cabal(1,24,0) +#define InstalledPackageId UnitId +#endif + +import Control.Monad + (when) +import Data.IORef + (modifyIORef, newIORef, readIORef) +import Data.List + (nub) +import Data.Maybe + (mapMaybe, maybeToList) +import Data.String + (fromString) +import Distribution.Package + (InstalledPackageId, Package (..)) +import Distribution.PackageDescription + (BuildInfo (..), Executable (..), GenericPackageDescription, + Library (..), PackageDescription, TestSuite (..)) +import Distribution.Simple + (UserHooks (..), autoconfUserHooks, defaultMainWithHooks, + simpleUserHooks) +import Distribution.Simple.Compiler + (CompilerFlavor (GHC), CompilerId (..), PackageDB (..), compilerId) +import Distribution.Simple.LocalBuildInfo + (ComponentLocalBuildInfo (componentPackageDeps), LocalBuildInfo, + compiler, withExeLBI, withLibLBI, withPackageDB, withTestLBI) +import Distribution.Simple.Setup + (BuildFlags (buildDistPref, buildVerbosity), + HaddockFlags (haddockDistPref, haddockVerbosity), emptyBuildFlags, + fromFlag) +import Distribution.Simple.Utils + (createDirectoryIfMissingVerbose, info) +import Distribution.Text + (display) +import System.FilePath + (()) + +import qualified Data.Foldable as F + (for_) +import qualified Data.Traversable as T + (traverse) + +#if MIN_VERSION_Cabal(1,25,0) +import Distribution.Simple.BuildPaths + (autogenComponentModulesDir) +#else +import Distribution.Simple.BuildPaths + (autogenModulesDir) +#endif + +#if MIN_VERSION_Cabal(2,0,0) +import Distribution.Types.MungedPackageId + (MungedPackageId) +import Distribution.Types.UnqualComponentName + (unUnqualComponentName) + +-- For amendGPD +import Distribution.PackageDescription + (CondTree (..)) +import Distribution.Types.GenericPackageDescription + (GenericPackageDescription (condTestSuites)) + +import Distribution.Version + (mkVersion) +#else +import Data.Version + (Version (..)) +import Distribution.Package + (PackageId) +#endif + +#if MIN_VERSION_Cabal(3,0,0) +import Distribution.Simple.Utils + (findFileEx) +#else +import Distribution.Simple.Utils + (findFile) +#endif + +#if MIN_VERSION_Cabal(3,0,0) +import Distribution.Types.LibraryName + (libraryNameString) +#endif + +#if MIN_VERSION_Cabal(3,5,0) +import Distribution.Utils.Path + (getSymbolicPath) +#endif + +#if MIN_VERSION_directory(1,2,2) +import System.Directory + (makeAbsolute) +#else +import System.Directory + (getCurrentDirectory) +import System.FilePath + (isAbsolute) + +makeAbsolute :: FilePath -> IO FilePath +makeAbsolute p | isAbsolute p = return p + | otherwise = do + cwd <- getCurrentDirectory + return $ cwd p +#endif + +#if !MIN_VERSION_Cabal(3,0,0) +findFileEx :: verbosity -> [FilePath] -> FilePath -> IO FilePath +findFileEx _ = findFile +#endif + +#if !MIN_VERSION_Cabal(2,0,0) +mkVersion :: [Int] -> Version +mkVersion ds = Version ds [] +#endif + +#if !MIN_VERSION_Cabal(3,5,0) +getSymbolicPath :: FilePath -> FilePath +getSymbolicPath = id +#endif + +------------------------------------------------------------------------------- +-- Mains +------------------------------------------------------------------------------- + +-- | A default main with doctests: +-- +-- @ +-- import Distribution.Extra.Doctest +-- (defaultMainWithDoctests) +-- +-- main :: IO () +-- main = defaultMainWithDoctests "doctests" +-- @ +defaultMainWithDoctests + :: String -- ^ doctests test-suite name + -> IO () +defaultMainWithDoctests = defaultMainWithHooks . doctestsUserHooks + +-- | Like 'defaultMainWithDoctests', for 'build-type: Configure' packages. +-- +-- @since 1.0.2 +defaultMainAutoconfWithDoctests + :: String -- ^ doctests test-suite name + -> IO () +defaultMainAutoconfWithDoctests n = + defaultMainWithHooks (addDoctestsUserHook n autoconfUserHooks) + +-- | 'simpleUserHooks' with 'generateBuildModule' prepended to the 'buildHook'. +doctestsUserHooks + :: String -- ^ doctests test-suite name + -> UserHooks +doctestsUserHooks testsuiteName = + addDoctestsUserHook testsuiteName simpleUserHooks + +-- | +-- +-- @since 1.0.2 +addDoctestsUserHook :: String -> UserHooks -> UserHooks +addDoctestsUserHook testsuiteName uh = uh + { buildHook = \pkg lbi hooks flags -> do + generateBuildModule testsuiteName flags pkg lbi + buildHook uh pkg lbi hooks flags + -- We use confHook to add "Build_Doctests" to otherModules and autogenModules. + -- + -- We cannot use HookedBuildInfo as it let's alter only the library and executables. + , confHook = \(gpd, hbi) flags -> + confHook uh (amendGPD testsuiteName gpd, hbi) flags + , haddockHook = \pkg lbi hooks flags -> do + generateBuildModule testsuiteName (haddockToBuildFlags flags) pkg lbi + haddockHook uh pkg lbi hooks flags + } + +-- | Convert only flags used by 'generateBuildModule'. +haddockToBuildFlags :: HaddockFlags -> BuildFlags +haddockToBuildFlags f = emptyBuildFlags + { buildVerbosity = haddockVerbosity f + , buildDistPref = haddockDistPref f + } + +data Name = NameLib (Maybe String) | NameExe String deriving (Eq, Show) + +nameToString :: Name -> String +nameToString n = case n of + NameLib x -> maybe "" (("_lib_" ++) . map fixchar) x + NameExe x -> "_exe_" ++ map fixchar x + where + -- Taken from Cabal: + -- https://github.com/haskell/cabal/blob/20de0bfea72145ba1c37e3f500cee5258cc18e51/Cabal/Distribution/Simple/Build/Macros.hs#L156-L158 + -- + -- Needed to fix component names with hyphens in them, as hyphens aren't + -- allowed in Haskell identifier names. + fixchar :: Char -> Char + fixchar '-' = '_' + fixchar c = c + +data Component = Component Name [String] [String] [String] + deriving Show + +-- | Generate a build module for the test suite. +-- +-- @ +-- import Distribution.Simple +-- (defaultMainWithHooks, UserHooks(..), simpleUserHooks) +-- import Distribution.Extra.Doctest +-- (generateBuildModule) +-- +-- main :: IO () +-- main = defaultMainWithHooks simpleUserHooks +-- { buildHook = \pkg lbi hooks flags -> do +-- generateBuildModule "doctests" flags pkg lbi +-- buildHook simpleUserHooks pkg lbi hooks flags +-- } +-- @ +generateBuildModule + :: String -- ^ doctests test-suite name + -> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO () +generateBuildModule testSuiteName flags pkg lbi = do + let verbosity = fromFlag (buildVerbosity flags) + let distPref = fromFlag (buildDistPref flags) + + -- Package DBs & environments + let dbStack = withPackageDB lbi ++ [ SpecificPackageDB $ distPref "package.conf.inplace" ] + let dbFlags = "-hide-all-packages" : packageDbArgs dbStack + let envFlags + | ghcCanBeToldToIgnorePkgEnvs = [ "-package-env=-" ] + | otherwise = [] + + withTestLBI pkg lbi $ \suite suitecfg -> when (testName suite == fromString testSuiteName) $ do +#if MIN_VERSION_Cabal(1,25,0) + let testAutogenDir = autogenComponentModulesDir lbi suitecfg +#else + let testAutogenDir = autogenModulesDir lbi +#endif + + createDirectoryIfMissingVerbose verbosity True testAutogenDir + + let buildDoctestsFile = testAutogenDir "Build_doctests.hs" + + -- First, we create the autogen'd module Build_doctests. + -- Initially populate Build_doctests with a simple preamble. + info verbosity $ "cabal-doctest: writing Build_doctests to " ++ buildDoctestsFile + writeFile buildDoctestsFile $ unlines + [ "module Build_doctests where" + , "" + , "import Prelude" + , "" + , "data Name = NameLib (Maybe String) | NameExe String deriving (Eq, Show)" + , "data Component = Component Name [String] [String] [String] deriving (Eq, Show)" + , "" + ] + + -- we cannot traverse, only traverse_ + -- so we use IORef to collect components + componentsRef <- newIORef [] + + let testBI = testBuildInfo suite + + -- TODO: `words` is not proper parser (no support for quotes) + let additionalFlags = maybe [] words + $ lookup "x-doctest-options" + $ customFieldsBI testBI + + let additionalModules = maybe [] words + $ lookup "x-doctest-modules" + $ customFieldsBI testBI + + let additionalDirs' = maybe [] words + $ lookup "x-doctest-source-dirs" + $ customFieldsBI testBI + + additionalDirs <- mapM (fmap ("-i" ++) . makeAbsolute) additionalDirs' + + -- Next, for each component (library or executable), we get to Build_doctests + -- the sets of flags needed to run doctest on that component. + let getBuildDoctests withCompLBI mbCompName compExposedModules compMainIs compBuildInfo = + withCompLBI pkg lbi $ \comp compCfg -> do + let compBI = compBuildInfo comp + + -- modules + let modules = compExposedModules comp ++ otherModules compBI + -- it seems that doctest is happy to take in module names, not actual files! + let module_sources = modules + + -- We need the directory with the component's cabal_macros.h! +#if MIN_VERSION_Cabal(1,25,0) + let compAutogenDir = autogenComponentModulesDir lbi compCfg +#else + let compAutogenDir = autogenModulesDir lbi +#endif + + -- Lib sources and includes + iArgsNoPrefix + <- mapM makeAbsolute + $ compAutogenDir -- autogenerated files + : (distPref ++ "/build") -- preprocessed files (.hsc -> .hs); "build" is hardcoded in Cabal. + : map getSymbolicPath (hsSourceDirs compBI) + includeArgs <- mapM (fmap ("-I"++) . makeAbsolute) $ includeDirs compBI + -- We clear all includes, so the CWD isn't used. + let iArgs' = map ("-i"++) iArgsNoPrefix + iArgs = "-i" : iArgs' + + -- default-extensions + let extensionArgs = map (("-X"++) . display) $ defaultExtensions compBI + + -- CPP includes, i.e. include cabal_macros.h + let cppFlags = map ("-optP"++) $ + [ "-include", compAutogenDir ++ "/cabal_macros.h" ] + ++ cppOptions compBI + + -- Unlike other modules, the main-is module of an executable is not + -- guaranteed to share a module name with its filepath name. That is, + -- even though the main-is module is named Main, its filepath might + -- actually be Something.hs. To account for this possibility, we simply + -- pass the full path to the main-is module instead. + mainIsPath <- T.traverse (findFileEx verbosity iArgsNoPrefix) (compMainIs comp) + + let all_sources = map display module_sources + ++ additionalModules + ++ maybeToList mainIsPath + + let component = Component + (mbCompName comp) + (formatDeps $ testDeps compCfg suitecfg) + (concat + [ iArgs + , additionalDirs + , includeArgs + , envFlags + , dbFlags + , cppFlags + , extensionArgs + , additionalFlags + ]) + all_sources + + -- modify IORef, append component + modifyIORef componentsRef (\cs -> cs ++ [component]) + + -- For now, we only check for doctests in libraries and executables. + getBuildDoctests withLibLBI mbLibraryName exposedModules (const Nothing) libBuildInfo + getBuildDoctests withExeLBI (NameExe . executableName) (const []) (Just . modulePath) buildInfo + + components <- readIORef componentsRef + F.for_ components $ \(Component cmpName cmpPkgs cmpFlags cmpSources) -> do + let compSuffix = nameToString cmpName + pkgs_comp = "pkgs" ++ compSuffix + flags_comp = "flags" ++ compSuffix + module_sources_comp = "module_sources" ++ compSuffix + + -- write autogen'd file + appendFile buildDoctestsFile $ unlines + [ -- -package-id etc. flags + pkgs_comp ++ " :: [String]" + , pkgs_comp ++ " = " ++ show cmpPkgs + , "" + , flags_comp ++ " :: [String]" + , flags_comp ++ " = " ++ show cmpFlags + , "" + , module_sources_comp ++ " :: [String]" + , module_sources_comp ++ " = " ++ show cmpSources + , "" + ] + + -- write enabled components, i.e. x-doctest-components + -- if none enabled, pick library + let enabledComponents = maybe [NameLib Nothing] (mapMaybe parseComponentName . words) + $ lookup "x-doctest-components" + $ customFieldsBI testBI + + let components' = + filter (\(Component n _ _ _) -> n `elem` enabledComponents) components + appendFile buildDoctestsFile $ unlines + [ "-- " ++ show enabledComponents + , "components :: [Component]" + , "components = " ++ show components' + ] + + where + parseComponentName :: String -> Maybe Name + parseComponentName "lib" = Just (NameLib Nothing) + parseComponentName ('l' : 'i' : 'b' : ':' : x) = Just (NameLib (Just x)) + parseComponentName ('e' : 'x' : 'e' : ':' : x) = Just (NameExe x) + parseComponentName _ = Nothing + + -- we do this check in Setup, as then doctests don't need to depend on Cabal + isNewCompiler = case compilerId $ compiler lbi of + CompilerId GHC v -> v >= mkVersion [7,6] + _ -> False + + ghcCanBeToldToIgnorePkgEnvs :: Bool + ghcCanBeToldToIgnorePkgEnvs = case compilerId $ compiler lbi of + CompilerId GHC v -> v >= mkVersion [8,4,4] + _ -> False + + formatDeps = map formatOne + formatOne (installedPkgId, pkgId) + -- The problem is how different cabal executables handle package databases + -- when doctests depend on the library + -- + -- If the pkgId is current package, we don't output the full package-id + -- but only the name + -- + -- Because of MungedPackageId we compare display version of identifiers + -- not the identifiers themfselves. + | display (packageId pkg) == display pkgId = "-package=" ++ display pkgId + | otherwise = "-package-id=" ++ display installedPkgId + + -- From Distribution.Simple.Program.GHC + packageDbArgs :: [PackageDB] -> [String] + packageDbArgs | isNewCompiler = packageDbArgsDb + | otherwise = packageDbArgsConf + + -- GHC <7.6 uses '-package-conf' instead of '-package-db'. + packageDbArgsConf :: [PackageDB] -> [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://ghc.haskell.org/trac/ghc/ticket/5977. + packageDbArgsDb :: [PackageDB] -> [String] + -- special cases to make arguments prettier in common scenarios + packageDbArgsDb dbstack = case dbstack of + (GlobalPackageDB:UserPackageDB:dbs) + | all isSpecific dbs -> concatMap single dbs + (GlobalPackageDB:dbs) + | all isSpecific dbs -> "-no-user-package-db" + : concatMap single dbs + dbs -> "-clear-package-db" + : concatMap single dbs + where + single (SpecificPackageDB db) = [ "-package-db=" ++ db ] + single GlobalPackageDB = [ "-global-package-db" ] + single UserPackageDB = [ "-user-package-db" ] + isSpecific (SpecificPackageDB _) = True + isSpecific _ = False + + mbLibraryName :: Library -> Name +#if MIN_VERSION_Cabal(3,0,0) + mbLibraryName = NameLib . fmap unUnqualComponentName . libraryNameString . libName +#elif MIN_VERSION_Cabal(2,0,0) + -- Cabal-2.0 introduced internal libraries, which are named. + mbLibraryName = NameLib . fmap unUnqualComponentName . libName +#else + -- Before that, there was only ever at most one library per + -- .cabal file, which has no name. + mbLibraryName _ = NameLib Nothing +#endif + + executableName :: Executable -> String +#if MIN_VERSION_Cabal(2,0,0) + executableName = unUnqualComponentName . exeName +#else + executableName = exeName +#endif + +-- | In compat settings it's better to omit the type-signature +testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo +#if MIN_VERSION_Cabal(2,0,0) + -> [(InstalledPackageId, MungedPackageId)] +#else + -> [(InstalledPackageId, PackageId)] +#endif +testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys + +amendGPD + :: String -- ^ doctests test-suite name + -> GenericPackageDescription + -> GenericPackageDescription +#if !(MIN_VERSION_Cabal(2,0,0)) +amendGPD _ gpd = gpd +#else +amendGPD testSuiteName gpd = gpd + { condTestSuites = map f (condTestSuites gpd) + } + where + f (name, condTree) + | name == fromString testSuiteName = (name, condTree') + | otherwise = (name, condTree) + where + -- I miss 'lens' + testSuite = condTreeData condTree + bi = testBuildInfo testSuite + om = otherModules bi + am = autogenModules bi + + -- Cons the module to both other-modules and autogen-modules. + -- At the moment, cabal-spec-2.0 and cabal-spec-2.2 don't have + -- "all autogen-modules are other-modules if they aren't exposed-modules" + -- rule. Hopefully cabal-spec-3.0 will have. + -- + -- Note: we `nub`, because it's unclear if that's ok to have duplicate + -- modules in the lists. + om' = nub $ mn : om + am' = nub $ mn : am + + mn = fromString "Build_doctests" + + bi' = bi { otherModules = om', autogenModules = am' } + testSuite' = testSuite { testBuildInfo = bi' } + condTree' = condTree { condTreeData = testSuite' } +#endif diff --git a/cabal/Cabal-tests/tests/custom-setup/CustomSetupTests.hs b/cabal/Cabal-tests/tests/custom-setup/CustomSetupTests.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/custom-setup/CustomSetupTests.hs @@ -0,0 +1,8 @@ +-- This test-suite verifies some custom-setup scripts compile ok +-- so we don't break them by accident, i.e. when breakage can be prevented. +module Main (main) where +import CabalDoctestSetup () +import IdrisSetup () + +main :: IO () +main = return () diff --git a/cabal/Cabal-tests/tests/custom-setup/IdrisSetup.hs b/cabal/Cabal-tests/tests/custom-setup/IdrisSetup.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/custom-setup/IdrisSetup.hs @@ -0,0 +1,388 @@ +-- This is Setup.hs script from idris-1.1.1 + +{- + +Copyright (c) 2011 Edwin Brady + School of Computer Science, University of St Andrews +All rights reserved. + +This code is derived from software written by Edwin Brady +(eb@cs.st-andrews.ac.uk). + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. None of the names of the copyright holders may be used to endorse + or promote products derived from this software without specific + prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS ``AS IS'' AND ANY +EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN +IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +*** End of disclaimer. *** + +-} + +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -w #-} +module IdrisSetup (main) where + +#if !defined(MIN_VERSION_Cabal) +# define MIN_VERSION_Cabal(x,y,z) 0 +#endif + +#if !defined(MIN_VERSION_base) +# define MIN_VERSION_base(x,y,z) 0 +#endif + +import Control.Monad +import Data.IORef +import Control.Exception (SomeException, catch) +import Data.String (fromString) + +import Distribution.Simple +import Distribution.Simple.BuildPaths +import Distribution.Simple.InstallDirs as I +import Distribution.Simple.LocalBuildInfo as L +import qualified Distribution.Simple.Setup as S +import qualified Distribution.Simple.Program as P +import Distribution.Simple.Utils (createDirectoryIfMissingVerbose, notice, installOrdinaryFiles) +import Distribution.Simple.Utils (rewriteFileEx) +import Distribution.Compiler +import Distribution.PackageDescription +import Distribution.Text + +import System.Environment +import System.Exit +import System.FilePath ((), splitDirectories,isAbsolute) +import System.Directory +import qualified System.FilePath.Posix as Px +import System.Process + +-- This is difference from vanilla idris-1.1.1 +configConfigurationsFlags :: S.ConfigFlags -> [(FlagName, Bool)] +#if MIN_VERSION_Cabal(2,1,0) +configConfigurationsFlags = unFlagAssignment . S.configConfigurationsFlags +#else +configConfigurationsFlags = S.configConfigurationsFlags +#endif + +#if !MIN_VERSION_base(4,6,0) +lookupEnv :: String -> IO (Maybe String) +lookupEnv v = lookup v `fmap` getEnvironment +#endif + +-- After Idris is built, we need to check and install the prelude and other libs + +-- ----------------------------------------------------------------------------- +-- Idris Command Path + +-- make on mingw32 expects unix style separators +#ifdef mingw32_HOST_OS +() = (Px.) +idrisCmd local = Px.joinPath $ splitDirectories $ ".." ".." buildDir local "idris" "idris" +#else +idrisCmd local = ".." ".." buildDir local "idris" "idris" +#endif + +-- ----------------------------------------------------------------------------- +-- Make Commands + +-- use GNU make on FreeBSD +#if defined(freebsd_HOST_OS) || defined(dragonfly_HOST_OS)\ + || defined(openbsd_HOST_OS) || defined(netbsd_HOST_OS) +mymake = "gmake" +#else +mymake = "make" +#endif +make verbosity = + P.runProgramInvocation verbosity . P.simpleProgramInvocation mymake + +#ifdef mingw32_HOST_OS +windres verbosity = P.runProgramInvocation verbosity . P.simpleProgramInvocation "windres" +#endif +-- ----------------------------------------------------------------------------- +-- Flags + +usesGMP :: S.ConfigFlags -> Bool +usesGMP flags = + case lookup (mkFlagName "gmp") (configConfigurationsFlags flags) of + Just True -> True + Just False -> False + Nothing -> False + +execOnly :: S.ConfigFlags -> Bool +execOnly flags = + case lookup (mkFlagName "execonly") (configConfigurationsFlags flags) of + Just True -> True + Just False -> False + Nothing -> False + +isRelease :: S.ConfigFlags -> Bool +isRelease flags = + case lookup (mkFlagName "release") (configConfigurationsFlags flags) of + Just True -> True + Just False -> False + Nothing -> False + +isFreestanding :: S.ConfigFlags -> Bool +isFreestanding flags = + case lookup (mkFlagName "freestanding") (configConfigurationsFlags flags) of + Just True -> True + Just False -> False + Nothing -> False + +#if !(MIN_VERSION_Cabal(2,0,0)) +mkFlagName :: String -> FlagName +mkFlagName = FlagName +#endif + +-- ----------------------------------------------------------------------------- +-- Clean + +idrisClean _ flags _ _ = cleanStdLib + where + verbosity = S.fromFlag $ S.cleanVerbosity flags + + cleanStdLib = makeClean "libs" + + makeClean dir = make verbosity [ "-C", dir, "clean", "IDRIS=idris" ] + +-- ----------------------------------------------------------------------------- +-- Configure + +gitHash :: IO String +gitHash = do h <- Control.Exception.catch (readProcess "git" ["rev-parse", "--short", "HEAD"] "") + (\e -> let e' = (e :: SomeException) in return "PRE") + return $ takeWhile (/= '\n') h + +-- Put the Git hash into a module for use in the program +-- For release builds, just put the empty string in the module +generateVersionModule verbosity dir release = do + hash <- gitHash + let versionModulePath = dir "Version_idris" Px.<.> "hs" + putStrLn $ "Generating " ++ versionModulePath ++ + if release then " for release" else " for prerelease " ++ hash + createDirectoryIfMissingVerbose verbosity True dir + rewriteFileEx verbosity versionModulePath (versionModuleContents hash) + + where versionModuleContents h = "module Version_idris where\n\n" ++ + "gitHash :: String\n" ++ + if release + then "gitHash = \"\"\n" + else "gitHash = \"git:" ++ h ++ "\"\n" + +-- Generate a module that contains the lib path for a freestanding Idris +generateTargetModule verbosity dir targetDir = do + let absPath = isAbsolute targetDir + let targetModulePath = dir "Target_idris" Px.<.> "hs" + putStrLn $ "Generating " ++ targetModulePath + createDirectoryIfMissingVerbose verbosity True dir + rewriteFileEx verbosity targetModulePath (versionModuleContents absPath targetDir) + where versionModuleContents absolute td = "module Target_idris where\n\n" ++ + "import System.FilePath\n" ++ + "import System.Environment\n" ++ + "getDataDir :: IO String\n" ++ + if absolute + then "getDataDir = return \"" ++ td ++ "\"\n" + else "getDataDir = do \n" ++ + " expath <- getExecutablePath\n" ++ + " execDir <- return $ dropFileName expath\n" ++ + " return $ execDir ++ \"" ++ td ++ "\"\n" + ++ "getDataFileName :: FilePath -> IO FilePath\n" + ++ "getDataFileName name = do\n" + ++ " dir <- getDataDir\n" + ++ " return (dir ++ \"/\" ++ name)" + +-- a module that has info about existence and location of a bundled toolchain +generateToolchainModule verbosity srcDir toolDir = do + let commonContent = "module Tools_idris where\n\n" + let toolContent = case toolDir of + Just dir -> "hasBundledToolchain = True\n" ++ + "getToolchainDir = \"" ++ dir ++ "\"\n" + Nothing -> "hasBundledToolchain = False\n" ++ + "getToolchainDir = \"\"" + let toolPath = srcDir "Tools_idris" Px.<.> "hs" + createDirectoryIfMissingVerbose verbosity True srcDir + rewriteFileEx verbosity toolPath (commonContent ++ toolContent) + +idrisConfigure _ flags pkgdesc local = do + configureRTS + withLibLBI pkgdesc local $ \_ libcfg -> do + let libAutogenDir = autogenComponentModulesDir local libcfg + generateVersionModule verbosity libAutogenDir (isRelease (configFlags local)) + if isFreestanding $ configFlags local + then do + toolDir <- lookupEnv "IDRIS_TOOLCHAIN_DIR" + generateToolchainModule verbosity libAutogenDir toolDir + targetDir <- lookupEnv "IDRIS_LIB_DIR" + case targetDir of + Just d -> generateTargetModule verbosity libAutogenDir d + Nothing -> error $ "Trying to build freestanding without a target directory." + ++ " Set it by defining IDRIS_LIB_DIR." + else + generateToolchainModule verbosity libAutogenDir Nothing + where + verbosity = S.fromFlag $ S.configVerbosity flags + version = pkgVersion . package $ localPkgDescr local + + -- This is a hack. I don't know how to tell cabal that a data file needs + -- installing but shouldn't be in the distribution. And it won't make the + -- distribution if it's not there, so instead I just delete + -- the file after configure. + configureRTS = make verbosity ["-C", "rts", "clean"] + +#if !(MIN_VERSION_Cabal(2,0,0)) + autogenComponentModulesDir lbi _ = autogenModulesDir lbi +#endif + +#if !MIN_VERSION_Cabal(3,0,0) +idrisPreSDist args flags = do + let dir = S.fromFlag (S.sDistDirectory flags) + let verb = S.fromFlag (S.sDistVerbosity flags) + generateVersionModule verb "src" True + generateTargetModule verb "src" "./libs" + generateToolchainModule verb "src" Nothing + preSDist simpleUserHooks args flags + +idrisSDist sdist pkgDesc bi hooks flags = do + pkgDesc' <- addGitFiles pkgDesc + sdist pkgDesc' bi hooks flags + where + addGitFiles :: PackageDescription -> IO PackageDescription + addGitFiles pkgDesc = do + files <- gitFiles + return $ pkgDesc { extraSrcFiles = extraSrcFiles pkgDesc ++ files} + gitFiles :: IO [FilePath] + gitFiles = liftM lines (readProcess "git" ["ls-files"] "") + +idrisPostSDist args flags desc lbi = do + Control.Exception.catch (do let file = "src" "Version_idris" Px.<.> "hs" + let targetFile = "src" "Target_idris" Px.<.> "hs" + putStrLn $ "Removing generated modules:\n " + ++ file ++ "\n" ++ targetFile + removeFile file + removeFile targetFile) + (\e -> let e' = (e :: SomeException) in return ()) + postSDist simpleUserHooks args flags desc lbi +#endif + +-- ----------------------------------------------------------------------------- +-- Build + +getVersion :: Args -> S.BuildFlags -> IO HookedBuildInfo +getVersion args flags = do + hash <- gitHash + let buildinfo = (emptyBuildInfo { cppOptions = ["-DVERSION="++hash] }) :: BuildInfo + return (Just buildinfo, []) + +idrisPreBuild args flags = do +#ifdef mingw32_HOST_OS + createDirectoryIfMissingVerbose verbosity True dir + windres verbosity ["icons/idris_icon.rc","-o", dir++"/idris_icon.o"] + return (Nothing, [(fromString "idris", emptyBuildInfo { ldOptions = [dir ++ "/idris_icon.o"] })]) + where + verbosity = S.fromFlag $ S.buildVerbosity flags + dir = S.fromFlagOrDefault "dist" $ S.buildDistPref flags +#else + return (Nothing, []) +#endif + +idrisBuild _ flags _ local + = if (execOnly (configFlags local)) then buildRTS + else do buildStdLib + buildRTS + where + verbosity = S.fromFlag $ S.buildVerbosity flags + + buildStdLib = do + putStrLn "Building libraries..." + makeBuild "libs" + where + makeBuild dir = make verbosity [ "-C", dir, "build" , "IDRIS=" ++ idrisCmd local] + + buildRTS = make verbosity (["-C", "rts", "build"] ++ + gmpflag (usesGMP (configFlags local))) + + gmpflag False = [] + gmpflag True = ["GMP=-DIDRIS_GMP"] + +-- ----------------------------------------------------------------------------- +-- Copy/Install + +idrisInstall verbosity copy pkg local + = if (execOnly (configFlags local)) then installRTS + else do installStdLib + installRTS + installManPage + where + target = datadir $ L.absoluteInstallDirs pkg local copy + + installStdLib = do + let target' = target -- "libs" + putStrLn $ "Installing libraries in " ++ target' + makeInstall "libs" target' + + installRTS = do + let target' = target "rts" + putStrLn $ "Installing run time system in " ++ target' + makeInstall "rts" target' + + installManPage = do + let mandest = mandir (L.absoluteInstallDirs pkg local copy) ++ "/man1" + notice verbosity $ unwords ["Copying man page to", mandest] + installOrdinaryFiles verbosity mandest [("man", "idris.1")] + + makeInstall src target = + make verbosity [ "-C", src, "install" , "TARGET=" ++ target, "IDRIS=" ++ idrisCmd local] + +-- ----------------------------------------------------------------------------- +-- Test + +-- There are two "dataDir" in cabal, and they don't relate to each other. +-- When fetching modules, idris uses the second path (in the pkg record), +-- which by default is the root folder of the project. +-- We want it to be the install directory where we put the idris libraries. +fixPkg pkg target = pkg { dataDir = target } + +idrisTestHook args pkg local hooks flags = do + let target = datadir $ L.absoluteInstallDirs pkg local NoCopyDest + testHook simpleUserHooks args (fixPkg pkg target) local hooks flags + +-- ----------------------------------------------------------------------------- +-- Main + +-- Install libraries during both copy and install +-- See https://github.com/haskell/cabal/issues/709 +main = defaultMainWithHooks $ simpleUserHooks + { postClean = idrisClean + , postConf = idrisConfigure + , preBuild = idrisPreBuild + , postBuild = idrisBuild + , postCopy = \_ flags pkg local -> + idrisInstall (S.fromFlag $ S.copyVerbosity flags) + (S.fromFlag $ S.copyDest flags) pkg local + , postInst = \_ flags pkg local -> + idrisInstall (S.fromFlag $ S.installVerbosity flags) + NoCopyDest pkg local +#if !MIN_VERSION_Cabal(3,0,0) + , preSDist = idrisPreSDist + , sDistHook = idrisSDist (sDistHook simpleUserHooks) + , postSDist = idrisPostSDist +#endif + , testHook = idrisTestHook + } diff --git a/cabal/Cabal-tests/tests/hackage/check.sh b/cabal/Cabal-tests/tests/hackage/check.sh new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/hackage/check.sh @@ -0,0 +1,25 @@ +#!/bin/sh + +base_version=1.4.0.2 +test_version=1.5.6 + +for setup in archive/*/*/Setup.hs archive/*/*/Setup.lhs; do + + pkgname=$(basename ${setup}) + + if test $(wc -w < ${setup}) -gt 21; then + if ghc -package Cabal-${base_version} -S ${setup} -o /dev/null 2> /dev/null; then + + if ghc -package Cabal-${test_version} -S ${setup} -o /dev/null 2> /dev/null; then + echo "OK ${setup}" + else + echo "FAIL ${setup} does not compile with Cabal-${test_version}" + fi + else + echo "OK ${setup} (does not compile with Cabal-${base_version})" + fi + else + echo "trivial ${setup}" + fi + +done diff --git a/cabal/Cabal-tests/tests/hackage/download.sh b/cabal/Cabal-tests/tests/hackage/download.sh new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/hackage/download.sh @@ -0,0 +1,19 @@ +#!/bin/sh + +if test ! -f archive/archive.tar; then + + wget http://hackage.haskell.org/cgi-bin/hackage-scripts/archive.tar + mkdir -p archive + mv archive.tar archive/ + tar -C archive -xf archive/archive.tar + +fi + +if test ! -f archive/00-index.tar.gz; then + + wget http://hackage.haskell.org/packages/archive/00-index.tar.gz + mkdir -p archive + mv 00-index.tar.gz archive/ + tar -C archive -xzf archive/00-index.tar.gz + +fi diff --git a/cabal/Cabal-tests/tests/hackage/unpack.sh b/cabal/Cabal-tests/tests/hackage/unpack.sh new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/hackage/unpack.sh @@ -0,0 +1,16 @@ +#!/bin/sh + +for tarball in archive/*/*/*.tar.gz; do + + pkgdir=$(dirname ${tarball}) + pkgname=$(basename ${tarball} .tar.gz) + + if tar -tzf ${tarball} ${pkgname}/Setup.hs 2> /dev/null; then + tar -xzf ${tarball} ${pkgname}/Setup.hs -O > ${pkgdir}/Setup.hs + elif tar -tzf ${tarball} ${pkgname}/Setup.lhs 2> /dev/null; then + tar -xzf ${tarball} ${pkgname}/Setup.lhs -O > ${pkgdir}/Setup.lhs + else + echo "${pkgname} has no Setup.hs or .lhs at all!!?!" + fi + +done diff --git a/cabal/Cabal-tests/tests/misc/ghc-supported-languages.hs b/cabal/Cabal-tests/tests/misc/ghc-supported-languages.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tests/tests/misc/ghc-supported-languages.hs @@ -0,0 +1,97 @@ +-- | 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/Cabal-tree-diff/Cabal-tree-diff.cabal b/cabal/Cabal-tree-diff/Cabal-tree-diff.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tree-diff/Cabal-tree-diff.cabal @@ -0,0 +1,22 @@ +cabal-version: 2.2 +name: Cabal-tree-diff +version: 3.8.1.0 +synopsis: QuickCheck instances for types in Cabal +category: Testing +description: Provides tree-diff ToExpr instances for some types in Cabal + +library + default-language: Haskell2010 + hs-source-dirs: src + ghc-options: -Wall + build-depends: + , base + , Cabal-syntax ^>=3.8.0.0 + , Cabal ^>=3.8.0.0 + , tree-diff ^>=0.1 || ^>=0.2 + + exposed-modules: Data.TreeDiff.Instances.Cabal + other-modules: + Data.TreeDiff.Instances.CabalLanguage + Data.TreeDiff.Instances.CabalSPDX + Data.TreeDiff.Instances.CabalVersion diff --git a/cabal/Cabal-tree-diff/src/Data/TreeDiff/Instances/Cabal.hs b/cabal/Cabal-tree-diff/src/Data/TreeDiff/Instances/Cabal.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tree-diff/src/Data/TreeDiff/Instances/Cabal.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -freduction-depth=0 #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Data.TreeDiff.Instances.Cabal () where + +import Data.TreeDiff + +import Data.TreeDiff.Instances.CabalLanguage () +import Data.TreeDiff.Instances.CabalSPDX () +import Data.TreeDiff.Instances.CabalVersion () + +------------------------------------------------------------------------------- + +import Distribution.Backpack (OpenModule, OpenUnitId) +import Distribution.CabalSpecVersion (CabalSpecVersion) +import Distribution.Compiler (CompilerFlavor, CompilerId, PerCompilerFlavor) +import Distribution.InstalledPackageInfo (AbiDependency, ExposedModule, InstalledPackageInfo) +import Distribution.ModuleName (ModuleName) +import Distribution.PackageDescription +import Distribution.Simple.Compiler (DebugInfoLevel, OptimisationLevel, ProfDetailLevel) +import Distribution.Simple.Flag (Flag) +import Distribution.Simple.InstallDirs +import Distribution.Simple.InstallDirs.Internal +import Distribution.Simple.Setup (HaddockTarget, TestShowDetails) +import Distribution.System +import Distribution.Types.AbiHash (AbiHash) +import Distribution.Types.ComponentId (ComponentId) +import Distribution.Types.DumpBuildInfo (DumpBuildInfo) +import Distribution.Types.PackageVersionConstraint +import Distribution.Types.UnitId (DefUnitId, UnitId) +import Distribution.Utils.NubList (NubList) +import Distribution.Utils.Path (SymbolicPath) +import Distribution.Utils.ShortText (ShortText, fromShortText) +import Distribution.Verbosity +import Distribution.Verbosity.Internal + +import qualified Distribution.Compat.NonEmptySet as NES + +------------------------------------------------------------------------------- +-- instances +------------------------------------------------------------------------------- + +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 (ToExpr a) => ToExpr (NubList a) +instance (ToExpr a) => ToExpr (Flag a) +instance ToExpr a => ToExpr (NES.NonEmptySet a) where + toExpr xs = App "NonEmptySet.fromNonEmpty" [toExpr $ NES.toNonEmpty xs] + +instance ToExpr a => ToExpr (PerCompilerFlavor a) + +instance ToExpr Dependency where + toExpr d@(Dependency pn vr cs) + | cs == mainLibSet = App "Dependency" [toExpr pn, toExpr vr, App "mainLibSet" []] + | otherwise = genericToExpr d + +instance ToExpr (SymbolicPath from to) + +instance ToExpr AbiDependency +instance ToExpr AbiHash +instance ToExpr Arch +instance ToExpr Benchmark +instance ToExpr BenchmarkInterface +instance ToExpr BenchmarkType +instance ToExpr BuildInfo +instance ToExpr BuildType +instance ToExpr CabalSpecVersion +instance ToExpr CompilerFlavor +instance ToExpr CompilerId +instance ToExpr ComponentId +instance ToExpr DebugInfoLevel +instance ToExpr DefUnitId +instance ToExpr DumpBuildInfo +instance ToExpr ExeDependency +instance ToExpr Executable +instance ToExpr ExecutableScope +instance ToExpr ExposedModule +instance ToExpr FlagAssignment +instance ToExpr FlagName +instance ToExpr ForeignLib +instance ToExpr ForeignLibOption +instance ToExpr ForeignLibType +instance ToExpr GenericPackageDescription +instance ToExpr HaddockTarget +instance ToExpr IncludeRenaming +instance ToExpr InstalledPackageInfo +instance ToExpr KnownRepoType +instance ToExpr LegacyExeDependency +instance ToExpr LibVersionInfo +instance ToExpr Library +instance ToExpr LibraryName +instance ToExpr LibraryVisibility +instance ToExpr Mixin +instance ToExpr ModuleName +instance ToExpr ModuleReexport +instance ToExpr ModuleRenaming +instance ToExpr OS +instance ToExpr OpenModule +instance ToExpr OpenUnitId +instance ToExpr OptimisationLevel +instance ToExpr PackageDescription +instance ToExpr PackageFlag +instance ToExpr PackageIdentifier +instance ToExpr PackageName +instance ToExpr PackageVersionConstraint +instance ToExpr PathComponent +instance ToExpr PathTemplate +instance ToExpr PathTemplateVariable +instance ToExpr PkgconfigDependency +instance ToExpr PkgconfigName +instance ToExpr PkgconfigVersion +instance ToExpr PkgconfigVersionRange +instance ToExpr ProfDetailLevel +instance ToExpr RepoKind +instance ToExpr RepoType +instance ToExpr SetupBuildInfo +instance ToExpr SourceRepo +instance ToExpr TestShowDetails +instance ToExpr TestSuite +instance ToExpr TestSuiteInterface +instance ToExpr TestType +instance ToExpr UnitId +instance ToExpr UnqualComponentName +instance ToExpr Verbosity +instance ToExpr VerbosityFlag +instance ToExpr VerbosityLevel + +instance ToExpr ShortText where toExpr = toExpr . fromShortText diff --git a/cabal/Cabal-tree-diff/src/Data/TreeDiff/Instances/CabalLanguage.hs b/cabal/Cabal-tree-diff/src/Data/TreeDiff/Instances/CabalLanguage.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tree-diff/src/Data/TreeDiff/Instances/CabalLanguage.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -freduction-depth=0 #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Data.TreeDiff.Instances.CabalLanguage () where + +import Data.TreeDiff +import Language.Haskell.Extension (Extension, KnownExtension, Language) + +-- These are big enums, so they are in separate file. +-- +instance ToExpr Extension +instance ToExpr KnownExtension +instance ToExpr Language diff --git a/cabal/Cabal-tree-diff/src/Data/TreeDiff/Instances/CabalSPDX.hs b/cabal/Cabal-tree-diff/src/Data/TreeDiff/Instances/CabalSPDX.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tree-diff/src/Data/TreeDiff/Instances/CabalSPDX.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -freduction-depth=0 #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Data.TreeDiff.Instances.CabalSPDX () where + +import Data.TreeDiff +import Distribution.License (License) + +import Data.TreeDiff.Instances.CabalVersion () + +import qualified Distribution.SPDX as SPDX + +-- 'License' almost belongs here. + +instance ToExpr License + +-- Generics instance is too heavy +instance ToExpr SPDX.LicenseId where toExpr = defaultExprViaShow +instance ToExpr SPDX.LicenseExceptionId where toExpr = defaultExprViaShow + +instance ToExpr SPDX.License +instance ToExpr SPDX.LicenseExpression +instance ToExpr SPDX.LicenseRef +instance ToExpr SPDX.SimpleLicenseExpression diff --git a/cabal/Cabal-tree-diff/src/Data/TreeDiff/Instances/CabalVersion.hs b/cabal/Cabal-tree-diff/src/Data/TreeDiff/Instances/CabalVersion.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal-tree-diff/src/Data/TreeDiff/Instances/CabalVersion.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -freduction-depth=0 #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Data.TreeDiff.Instances.CabalVersion where + +import Data.TreeDiff +import Distribution.Version (Version, VersionRange, versionNumbers) + +instance ToExpr Version where toExpr v = App "mkVersion" [toExpr $ versionNumbers v] +instance ToExpr VersionRange diff --git a/cabal/Cabal/Cabal-QuickCheck/Cabal-QuickCheck.cabal b/cabal/Cabal/Cabal-QuickCheck/Cabal-QuickCheck.cabal deleted file mode 100644 --- a/cabal/Cabal/Cabal-QuickCheck/Cabal-QuickCheck.cabal +++ /dev/null @@ -1,24 +0,0 @@ -cabal-version: 2.2 -name: Cabal-QuickCheck -version: 3.3.0.0 -synopsis: QuickCheck instances for types in Cabal -category: Testing -description: - Provides QuickCheck Arbitrary instances for some types in Cabal - -library - default-language: Haskell2010 - hs-source-dirs: src - ghc-options: -Wall - build-depends: - , base - , bytestring - , Cabal ^>=3.3.0.0 - , QuickCheck ^>=2.13.2 || ^>=2.14 - - if !impl(ghc >= 8.0) - build-depends: semigroups - - exposed-modules: - Test.QuickCheck.GenericArbitrary - Test.QuickCheck.Instances.Cabal diff --git a/cabal/Cabal/Cabal-QuickCheck/src/Test/QuickCheck/GenericArbitrary.hs b/cabal/Cabal/Cabal-QuickCheck/src/Test/QuickCheck/GenericArbitrary.hs deleted file mode 100644 --- a/cabal/Cabal/Cabal-QuickCheck/src/Test/QuickCheck/GenericArbitrary.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TypeOperators #-} -module Test.QuickCheck.GenericArbitrary ( - genericArbitrary, - GArbitrary, -) where - -import GHC.Generics -import Test.QuickCheck - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative (pure, (<$>), (<*>)) -#endif - --- Generic arbitary for non-recursive types -genericArbitrary :: (Generic a, GArbitrary (Rep a)) => Gen a -genericArbitrary = fmap to garbitrary - -class GArbitrary f where - garbitrary :: Gen (f ()) - -class GArbitrarySum f where - garbitrarySum :: [Gen (f ())] - -class GArbitraryProd f where - garbitraryProd :: Gen (f ()) - -instance (GArbitrarySum f, i ~ D) => GArbitrary (M1 i c f) where - garbitrary = fmap M1 (oneof garbitrarySum) - -instance (GArbitraryProd f, i ~ C) => GArbitrarySum (M1 i c f) where - garbitrarySum = [fmap M1 garbitraryProd] - -instance (GArbitrarySum f, GArbitrarySum g) => GArbitrarySum (f :+: g) where - garbitrarySum = map (fmap L1) garbitrarySum ++ map (fmap R1) garbitrarySum - -instance (GArbitraryProd f, i ~ S) => GArbitraryProd (M1 i c f) where - garbitraryProd = fmap M1 garbitraryProd - -instance GArbitraryProd U1 where - garbitraryProd = pure U1 - -instance (GArbitraryProd f, GArbitraryProd g) => GArbitraryProd (f :*: g) where - garbitraryProd = (:*:) <$> garbitraryProd <*> garbitraryProd - -instance (Arbitrary a) => GArbitraryProd (K1 i a) where - garbitraryProd = fmap K1 arbitrary diff --git a/cabal/Cabal/Cabal-QuickCheck/src/Test/QuickCheck/Instances/Cabal.hs b/cabal/Cabal/Cabal-QuickCheck/src/Test/QuickCheck/Instances/Cabal.hs deleted file mode 100644 --- a/cabal/Cabal/Cabal-QuickCheck/src/Test/QuickCheck/Instances/Cabal.hs +++ /dev/null @@ -1,513 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeOperators #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Test.QuickCheck.Instances.Cabal () where - -import Control.Applicative (liftA2) -import Data.Char (isAlphaNum, isDigit) -import Data.List (intercalate, isPrefixOf) -import Data.List.NonEmpty (NonEmpty (..)) -import Distribution.Utils.Generic (lowercase) -import Test.QuickCheck - -import Distribution.CabalSpecVersion -import Distribution.Compat.NonEmptySet (NonEmptySet) -import Distribution.Compiler -import Distribution.FieldGrammar.Newtypes -import Distribution.ModuleName -import Distribution.Simple.Compiler (DebugInfoLevel (..), OptimisationLevel (..), PackageDB (..), ProfDetailLevel (..), knownProfDetailLevels) -import Distribution.Simple.Flag (Flag (..)) -import Distribution.Simple.InstallDirs -import Distribution.Simple.Setup (HaddockTarget (..), TestShowDetails (..)) -import Distribution.SPDX -import Distribution.System -import Distribution.Types.Dependency -import Distribution.Types.Flag (FlagAssignment, FlagName, mkFlagAssignment, mkFlagName, unFlagAssignment) -import Distribution.Types.IncludeRenaming -import Distribution.Types.LibraryName -import Distribution.Types.LibraryVisibility -import Distribution.Types.Mixin -import Distribution.Types.ModuleRenaming -import Distribution.Types.PackageId -import Distribution.Types.PackageName -import Distribution.Types.PackageVersionConstraint -import Distribution.Types.PkgconfigVersion -import Distribution.Types.PkgconfigVersionRange -import Distribution.Types.SourceRepo -import Distribution.Types.UnqualComponentName -import Distribution.Types.VersionRange.Internal -import Distribution.Utils.NubList -import Distribution.Verbosity -import Distribution.Version - -import Test.QuickCheck.GenericArbitrary - -import qualified Data.ByteString.Char8 as BS8 -import qualified Distribution.Compat.NonEmptySet as NES - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative (pure, (<$>), (<*>)) -#endif - -------------------------------------------------------------------------------- --- CabalSpecVersion -------------------------------------------------------------------------------- - -instance Arbitrary CabalSpecVersion where - arbitrary = arbitraryBoundedEnum - -instance Arbitrary SpecVersion where - arbitrary = fmap SpecVersion arbitrary - -------------------------------------------------------------------------------- --- PackageName and PackageIdentifier -------------------------------------------------------------------------------- - -instance Arbitrary PackageName where - arbitrary = mkPackageName . intercalate "-" <$> shortListOf1 2 nameComponent - where - nameComponent = shortListOf1 5 (elements packageChars) - `suchThat` (not . all isDigit) - packageChars = filter isAlphaNum ['\0'..'\127'] - -instance Arbitrary PackageIdentifier where - arbitrary = PackageIdentifier <$> arbitrary <*> arbitrary - - shrink (PackageIdentifier pn vr) = uncurry PackageIdentifier <$> shrink (pn, vr) - -------------------------------------------------------------------------------- --- Version -------------------------------------------------------------------------------- - --- | Does *NOT* generate 'nullVersion' -instance Arbitrary Version where - arbitrary = do - branch <- smallListOf1 $ - frequency [(3, return 0) - ,(3, return 1) - ,(2, return 2) - ,(2, return 3) - ,(1, return 0xfffd) - ,(1, return 0xfffe) -- max fitting into packed W64 - ,(1, return 0xffff) - ,(1, return 999999998) - ,(1, return 999999999) - ,(1, return 0x10000)] - return (mkVersion branch) - where - smallListOf1 = scale (\n -> min 6 (n `div` 3)) . listOf1 - - shrink ver = [ mkVersion ns | ns <- shrink (versionNumbers ver) - , not (null ns) ] - -instance Arbitrary VersionRange where - arbitrary = sized verRangeExp - where - verRangeExp n = frequency $ - [ (2, return anyVersion) - , (1, fmap thisVersion arbitrary) - , (1, fmap laterVersion arbitrary) - , (1, fmap orLaterVersion arbitrary) - , (1, fmap orLaterVersion' arbitrary) - , (1, fmap earlierVersion arbitrary) - , (1, fmap orEarlierVersion arbitrary) - , (1, fmap orEarlierVersion' arbitrary) - , (1, fmap withinVersion arbitraryV) - , (1, fmap majorBoundVersion arbitrary) - ] ++ if n == 0 then [] else - [ (2, liftA2 unionVersionRanges verRangeExp2 verRangeExp2) - , (2, liftA2 intersectVersionRanges verRangeExp2 verRangeExp2) - ] - where - verRangeExp2 = verRangeExp (n `div` 2) - - arbitraryV :: Gen Version - arbitraryV = arbitrary `suchThat` \v -> all (< 999999999) (versionNumbers v) - - orLaterVersion' v = - unionVersionRanges (LaterVersion v) (ThisVersion v) - orEarlierVersion' v = - unionVersionRanges (EarlierVersion v) (ThisVersion v) - - shrink (ThisVersion v) = map ThisVersion (shrink v) - shrink (LaterVersion v) = map LaterVersion (shrink v) - shrink (EarlierVersion v) = map EarlierVersion (shrink v) - shrink (OrLaterVersion v) = LaterVersion v : map OrLaterVersion (shrink v) - shrink (OrEarlierVersion v) = EarlierVersion v : map OrEarlierVersion (shrink v) - shrink (MajorBoundVersion v) = map MajorBoundVersion (shrink v) - shrink (UnionVersionRanges a b) = a : b : map (uncurry UnionVersionRanges) (shrink (a, b)) - shrink (IntersectVersionRanges a b) = a : b : map (uncurry IntersectVersionRanges) (shrink (a, b)) - --- | Generating VersionIntervals --- --- This is a tad tricky as VersionIntervals is an abstract type, so we first --- make a local type for generating the internal representation. Then we check --- that this lets us construct valid 'VersionIntervals'. --- - -instance Arbitrary VersionIntervals where - arbitrary = fmap mkVersionIntervals' arbitrary - where - mkVersionIntervals' :: [(Version, Bound)] -> VersionIntervals - mkVersionIntervals' = mkVersionIntervals . go version0 - where - go :: Version -> [(Version, Bound)] -> [VersionInterval] - go _ [] = [] - go v [(lv, lb)] = - [(LowerBound (addVersion lv v) lb, NoUpperBound)] - go v ((lv, lb) : (uv, ub) : rest) = - (LowerBound lv' lb, UpperBound uv' ub) : go uv' rest - where - lv' = addVersion v lv - uv' = addVersion lv' uv - - addVersion :: Version -> Version -> Version - addVersion xs ys = mkVersion $ z (versionNumbers xs) (versionNumbers ys) - where - z [] ys' = ys' - z xs' [] = xs' - z (x : xs') (y : ys') = x + y : z xs' ys' - -instance Arbitrary Bound where - arbitrary = elements [ExclusiveBound, InclusiveBound] - -------------------------------------------------------------------------------- --- Backpack -------------------------------------------------------------------------------- - -instance Arbitrary Mixin where - arbitrary = normaliseMixin <$> genericArbitrary - shrink = fmap normaliseMixin . genericShrink - -instance Arbitrary IncludeRenaming where - arbitrary = genericArbitrary - shrink = genericShrink - -instance Arbitrary ModuleRenaming where - arbitrary = genericArbitrary - shrink = genericShrink - -------------------------------------------------------------------------------- --- -------------------------------------------------------------------------------- - -instance Arbitrary LibraryVisibility where - arbitrary = elements [LibraryVisibilityPrivate, LibraryVisibilityPublic] - - shrink LibraryVisibilityPublic = [LibraryVisibilityPrivate] - shrink LibraryVisibilityPrivate = [] - -------------------------------------------------------------------------------- --- ModuleName -------------------------------------------------------------------------------- - -instance Arbitrary ModuleName where - arbitrary = fromString . intercalate "." <$> shortListOf1 4 comp where - comp = (:) <$> elements upper <*> shortListOf1 10 (elements moduleChar) - upper = ['A'..'Z'] - moduleChar = [ c | c <- ['\0' .. '\255'], isAlphaNum c || c `elem` "_'" ] - -------------------------------------------------------------------------------- --- Dependency -------------------------------------------------------------------------------- - -instance Arbitrary Dependency where - arbitrary = mkDependency - <$> arbitrary - <*> arbitrary - <*> (arbitrary `suchThat` const True) -- should be (not . null) - - shrink (Dependency pn vr lb) = - [ mkDependency pn' vr' lb' - | (pn', vr', lb') <- shrink (pn, vr, lb) - ] - -------------------------------------------------------------------------------- --- PackageVersionConstraint -------------------------------------------------------------------------------- - -instance Arbitrary PackageVersionConstraint where - arbitrary = PackageVersionConstraint - <$> arbitrary - <*> arbitrary - - shrink (PackageVersionConstraint pn vr) = - [ PackageVersionConstraint pn' vr' - | (pn', vr') <- shrink (pn, vr) - ] - -------------------------------------------------------------------------------- --- System -------------------------------------------------------------------------------- - -instance Arbitrary OS where - arbitrary = elements knownOSs - -instance Arbitrary Arch where - arbitrary = elements knownArches - -instance Arbitrary Platform where - arbitrary = Platform <$> arbitrary <*> arbitrary - -------------------------------------------------------------------------------- --- Various names -------------------------------------------------------------------------------- - -instance Arbitrary UnqualComponentName where - -- same rules as package names - arbitrary = packageNameToUnqualComponentName <$> arbitrary - -instance Arbitrary LibraryName where - arbitrary = oneof - [ LSubLibName <$> arbitrary - , pure LMainLibName - ] - - shrink (LSubLibName _) = [LMainLibName] - shrink _ = [] - -------------------------------------------------------------------------------- --- option flags -------------------------------------------------------------------------------- - -instance Arbitrary a => Arbitrary (Flag a) where - arbitrary = arbitrary1 - - shrink NoFlag = [] - shrink (Flag x) = NoFlag : [ Flag x' | x' <- shrink x ] - -instance Arbitrary1 Flag where - liftArbitrary genA = sized $ \sz -> - if sz <= 0 - then pure NoFlag - else frequency [ (1, pure NoFlag) - , (3, Flag <$> genA) ] - -------------------------------------------------------------------------------- --- GPD flags -------------------------------------------------------------------------------- - -instance Arbitrary FlagName where - arbitrary = mkFlagName <$> frequency - [ (20, flagident) - -- special nasty cases - , (1, pure "none") - , (1, pure "any") - ] - where - flagident = lowercase <$> shortListOf1 5 (elements flagChars) - `suchThat` (("-" /=) . take 1) - flagChars = "-_" ++ ['a'..'z'] - -instance Arbitrary FlagAssignment where - arbitrary = mkFlagAssignment <$> arbitrary - shrink x = mkFlagAssignment <$> shrink (unFlagAssignment x) - -------------------------------------------------------------------------------- --- Verbosity -------------------------------------------------------------------------------- - -instance Arbitrary Verbosity where - arbitrary = do - v <- elements [minBound..maxBound] - -- verbose markoutput is left out on purpose - flags <- listOf $ elements - [ verboseCallSite - , verboseCallStack - , verboseNoWrap - , verboseTimestamp - , verboseStderr - ] - return (foldr ($) v flags) - -------------------------------------------------------------------------------- --- SourceRepo -------------------------------------------------------------------------------- - -instance Arbitrary RepoType where - arbitrary = elements (KnownRepoType <$> knownRepoTypes) - -instance Arbitrary RepoKind where - arbitrary = elements [RepoHead, RepoThis] - -------------------------------------------------------------------------------- --- SPDX -------------------------------------------------------------------------------- - -instance Arbitrary LicenseId where - arbitrary = elements $ licenseIdList currentLicenseListVersion - -instance Arbitrary LicenseExceptionId where - arbitrary = elements $ licenseExceptionIdList currentLicenseListVersion - -currentLicenseListVersion :: LicenseListVersion -currentLicenseListVersion = cabalSpecVersionToSPDXListVersion cabalSpecLatest - -instance Arbitrary LicenseRef where - arbitrary = mkLicenseRef' <$> ids' <*> ids - where - ids = listOf1 $ elements $ ['a'..'z'] ++ ['A' .. 'Z'] ++ ['0'..'9'] ++ "_-" - ids' = oneof [ pure Nothing, Just <$> ids ] - -instance Arbitrary SimpleLicenseExpression where - arbitrary = oneof - [ ELicenseId <$> arbitrary - , ELicenseIdPlus <$> arbitrary - , ELicenseRef <$> arbitrary - ] - -instance Arbitrary LicenseExpression where - arbitrary = sized arb - where - arb n - | n <= 0 = ELicense <$> arbitrary <*> pure Nothing - | otherwise = oneof - [ ELicense <$> arbitrary <*> arbitrary - , EAnd <$> arbA <*> arbB - , EOr <$> arbA <*> arbB - ] - where - m = n `div` 2 - arbA = arb m - arbB = arb (n - m) - - shrink (EAnd a b) = a : b : map (uncurry EAnd) (shrink (a, b)) - shrink (EOr a b) = a : b : map (uncurry EOr) (shrink (a, b)) - shrink _ = [] - -------------------------------------------------------------------------------- --- Compiler -------------------------------------------------------------------------------- - -instance Arbitrary CompilerFlavor where - arbitrary = elements knownCompilerFlavors - -instance Arbitrary CompilerId where - arbitrary = genericArbitrary - shrink = genericShrink - -instance Arbitrary ProfDetailLevel where - arbitrary = elements [ d | (_,_,d) <- knownProfDetailLevels ] - -instance Arbitrary OptimisationLevel where - arbitrary = elements [minBound..maxBound] - -instance Arbitrary DebugInfoLevel where - arbitrary = elements [minBound..maxBound] - -------------------------------------------------------------------------------- --- NonEmptySet -------------------------------------------------------------------------------- - -instance (Arbitrary a, Ord a) => Arbitrary (NonEmptySet a) where - arbitrary = mk <$> arbitrary <*> arbitrary where - mk x xs = NES.fromNonEmpty (x :| xs) - - shrink nes = case NES.toNonEmpty nes of - x :| xs -> map mk (shrink (x, xs)) - where - mk (x,xs) = NES.fromNonEmpty (x :| xs) - -------------------------------------------------------------------------------- --- NubList -------------------------------------------------------------------------------- - -instance (Arbitrary a, Ord a) => Arbitrary (NubList a) where - arbitrary = toNubList <$> arbitrary - shrink xs = [ toNubList [] | (not . null) (fromNubList xs) ] - -- try empty, otherwise don't shrink as it can loop - -------------------------------------------------------------------------------- --- InstallDirs -------------------------------------------------------------------------------- - -instance Arbitrary a => Arbitrary (InstallDirs a) where - arbitrary = InstallDirs - <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary -- 4 - <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary -- 8 - <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary -- 12 - <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary -- 16 - -instance Arbitrary PathTemplate where - arbitrary = toPathTemplate <$> arbitraryShortToken - shrink t = [ toPathTemplate s - | s <- shrink (fromPathTemplate t) - , not (null s) ] - -------------------------------------------------------------------------------- --- Pkgconfig -------------------------------------------------------------------------------- - -instance Arbitrary PkgconfigVersion where - arbitrary = PkgconfigVersion . BS8.pack . dropDash . concat <$> listOf1 elems where - elems = frequency - [ (2, pure ".") - , (1, pure "-") - , (5, listOf1 $ elements ['0' .. '9']) - , (1, listOf1 $ elements ['A' .. 'Z']) - , (1, listOf1 $ elements ['a' .. 'z']) - ] - - -- disallow versions starting with dash - dropDash = notEmpty . dropWhile (== '-') - notEmpty x - | null x = "0" - | otherwise = x - -instance Arbitrary PkgconfigVersionRange where - arbitrary = sized verRangeExp - where - verRangeExp n = frequency $ - [ (2, return PcAnyVersion) - , (1, fmap PcThisVersion arbitrary) - , (1, fmap PcLaterVersion arbitrary) - , (1, fmap PcOrLaterVersion arbitrary) - , (1, fmap orLaterVersion' arbitrary) - , (1, fmap PcEarlierVersion arbitrary) - , (1, fmap PcOrEarlierVersion arbitrary) - , (1, fmap orEarlierVersion' arbitrary) - ] ++ if n == 0 then [] else - [ (2, liftA2 PcUnionVersionRanges verRangeExp2 verRangeExp2) - , (2, liftA2 PcIntersectVersionRanges verRangeExp2 verRangeExp2) - ] - where - verRangeExp2 = verRangeExp (n `div` 2) - - orLaterVersion' v = - PcUnionVersionRanges (PcLaterVersion v) (PcThisVersion v) - orEarlierVersion' v = - PcUnionVersionRanges (PcEarlierVersion v) (PcThisVersion v) - -------------------------------------------------------------------------------- --- Setup -------------------------------------------------------------------------------- - -instance Arbitrary HaddockTarget where - arbitrary = elements [ForHackage, ForDevelopment] - -instance Arbitrary TestShowDetails where - arbitrary = arbitraryBoundedEnum - -------------------------------------------------------------------------------- --- PackageDB -------------------------------------------------------------------------------- - -instance Arbitrary PackageDB where - arbitrary = oneof [ pure GlobalPackageDB - , pure UserPackageDB - , SpecificPackageDB <$> arbitraryShortToken - ] - - -------------------------------------------------------------------------------- --- Helpers -------------------------------------------------------------------------------- - -shortListOf1 :: Int -> Gen a -> Gen [a] -shortListOf1 bound gen = sized $ \n -> do - k <- choose (1, 1 `max` ((n `div` 2) `min` bound)) - vectorOf k gen - -arbitraryShortToken :: Gen String -arbitraryShortToken = - shortListOf1 5 (choose ('#', '~')) `suchThat` (not . ("[]" `isPrefixOf`)) diff --git a/cabal/Cabal/Cabal-described/Cabal-described.cabal b/cabal/Cabal/Cabal-described/Cabal-described.cabal deleted file mode 100644 --- a/cabal/Cabal/Cabal-described/Cabal-described.cabal +++ /dev/null @@ -1,26 +0,0 @@ -cabal-version: 2.2 -name: Cabal-described -version: 3.3.0.0 -synopsis: Described functionality for types in Cabal -category: Testing, Parsec -description: Provides rere bindings - -library - default-language: Haskell2010 - hs-source-dirs: src - ghc-options: -Wall - build-depends: - , base - , Cabal ^>=3.3.0.0 - , containers - , pretty - , QuickCheck - , rere ^>=0.1 - , tasty - , tasty-quickcheck - , transformers - - exposed-modules: - Distribution.Described - Distribution.Utils.CharSet - Distribution.Utils.GrammarRegex diff --git a/cabal/Cabal/Cabal-described/src/Distribution/Described.hs b/cabal/Cabal/Cabal-described/src/Distribution/Described.hs deleted file mode 100644 --- a/cabal/Cabal/Cabal-described/src/Distribution/Described.hs +++ /dev/null @@ -1,577 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Distribution.Described ( - Described (..), - describeDoc, - -- * Regular expressions - GrammarRegex (..), - reEps, - reChar, - reChars, - reMunchCS, - reMunch1CS, - -- * Variables - reVar0, - reVar1, - -- * Special expressions - reDot, - reComma, - reSpacedComma, - reHsString, - reUnqualComponent, - -- * - describeFlagAssignmentNonEmpty, - -- * Lists - reSpacedList, - reCommaList, - reCommaNonEmpty, - reOptCommaList, - -- * Character Sets - csChar, - csAlpha, - csAlphaNum, - csUpper, - csNotSpace, - csNotSpaceOrComma, - -- * tasty - testDescribed, - ) where - -import Prelude - (Bool (..), Char, Either (..), Enum (..), Eq (..), Ord (..), Show (..), String, elem, fmap, foldr, id, map, maybe, otherwise, return, undefined, ($), - (.)) - -import Data.Functor.Identity (Identity (..)) -import Data.Maybe (fromMaybe) -import Data.Proxy (Proxy (..)) -import Data.String (IsString (..)) -import Data.Typeable (Typeable, typeOf) -import Data.Void (Void, vacuous) -import Test.QuickCheck (Arbitrary (..), Property, counterexample) -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.QuickCheck (testProperty) - -import Distribution.Compat.Semigroup (Semigroup (..)) -import Distribution.Parsec (Parsec, eitherParsec) -import Distribution.Pretty (Pretty, prettyShow) - -import qualified Distribution.Utils.CharSet as CS -import qualified RERE as RE -import qualified RERE.CharSet as RE -import qualified Text.PrettyPrint as PP - -import Distribution.Utils.GrammarRegex - --- Types -import Distribution.Compat.Newtype -import Distribution.Compiler (CompilerFlavor, CompilerId, knownCompilerFlavors) -import Distribution.FieldGrammar.Newtypes -import Distribution.ModuleName (ModuleName) -import Distribution.System (Arch, OS, knownArches, knownOSs) -import Distribution.Types.AbiDependency (AbiDependency) -import Distribution.Types.AbiHash (AbiHash) -import Distribution.Types.BenchmarkType (BenchmarkType) -import Distribution.Types.BuildType (BuildType) -import Distribution.Types.Dependency (Dependency) -import Distribution.Types.ExecutableScope (ExecutableScope) -import Distribution.Types.ExeDependency (ExeDependency) -import Distribution.Types.ExposedModule (ExposedModule) -import Distribution.Types.Flag (FlagAssignment, FlagName) -import Distribution.Types.ForeignLib (LibVersionInfo) -import Distribution.Types.ForeignLibOption (ForeignLibOption) -import Distribution.Types.ForeignLibType (ForeignLibType) -import Distribution.Types.IncludeRenaming (IncludeRenaming) -import Distribution.Types.LegacyExeDependency (LegacyExeDependency) -import Distribution.Types.LibraryVisibility (LibraryVisibility) -import Distribution.Types.Mixin (Mixin) -import Distribution.Types.ModuleReexport (ModuleReexport) -import Distribution.Types.ModuleRenaming (ModuleRenaming) -import Distribution.Types.MungedPackageName (MungedPackageName) -import Distribution.Types.PackageId (PackageIdentifier) -import Distribution.Types.PackageName (PackageName) -import Distribution.Types.PackageVersionConstraint (PackageVersionConstraint) -import Distribution.Types.PkgconfigDependency (PkgconfigDependency) -import Distribution.Types.SourceRepo (RepoType) -import Distribution.Types.TestType (TestType) -import Distribution.Types.UnitId (UnitId) -import Distribution.Types.UnqualComponentName (UnqualComponentName) -import Distribution.Verbosity (Verbosity) -import Distribution.Version (Version, VersionRange) -import Language.Haskell.Extension (Extension, Language) - --- | Class describing the pretty/parsec format of a. -class (Pretty a, Parsec a) => Described a where - -- | A pretty document of "regex" describing the field format - describe :: proxy a -> GrammarRegex void - --- | Pretty-print description. --- --- >>> describeDoc ([] :: [Bool]) --- \left\{ \mathop{\mathord{``}\mathtt{True}\mathord{"}}\mid\mathop{\mathord{``}\mathtt{False}\mathord{"}} \right\} --- -describeDoc :: Described a => proxy a -> PP.Doc -describeDoc p = regexDoc (describe p) - -instance Described Bool where - describe _ = REUnion ["True", "False"] - -instance Described a => Described (Identity a) where - describe _ = describe ([] :: [a]) - -------------------------------------------------------------------------------- --- Lists ------------------------------------------------------------------------------- - -reSpacedList :: GrammarRegex a -> GrammarRegex a -reSpacedList = REMunch RESpaces1 - -reCommaList :: GrammarRegex a -> GrammarRegex a -reCommaList = RECommaList - -reCommaNonEmpty :: GrammarRegex a -> GrammarRegex a -reCommaNonEmpty = RECommaNonEmpty - -reOptCommaList :: GrammarRegex a -> GrammarRegex a -reOptCommaList = REOptCommaList - -------------------------------------------------------------------------------- --- Specific grammars -------------------------------------------------------------------------------- - -reHsString :: GrammarRegex a -reHsString = RENamed "hs-string" impl where - impl = reChar '"' <> REMunch reEps (REUnion [strChar, escChar]) <> reChar '"' - strChar = RECharSet $ CS.difference CS.universe (CS.fromList "\"\\") - - escChar = REUnion - [ "\\&" - , "\\\\" - , REUnion ["\\n", RENamed "escapes" "\\n"] -- TODO - , "\\" <> RECharSet "0123456789" - , "\\o" <> RECharSet "01234567" - , "\\x" <> RECharSet "0123456789abcdefABCDEF" - , REUnion ["\\^@", RENamed "control" "\\^@"] -- TODO - , REUnion ["\\NUL", RENamed "ascii" "\\NUL"] -- TODO - ] - -reUnqualComponent :: GrammarRegex a -reUnqualComponent = RENamed "unqual-name" $ - REMunch1 (reChar '-') component - where - component - = REMunch reEps (RECharSet csAlphaNum) - -- currently the parser accepts "csAlphaNum `difference` "0123456789" - -- which is larger set than CS.alpha - -- - -- Hackage rejects non ANSI names, so it's not so relevant. - <> RECharSet CS.alpha - <> REMunch reEps (RECharSet csAlphaNum) - -reDot :: GrammarRegex a -reDot = reChar '.' - -reComma :: GrammarRegex a -reComma = reChar ',' - -reSpacedComma :: GrammarRegex a -reSpacedComma = RESpaces <> reComma <> RESpaces - -------------------------------------------------------------------------------- --- Character sets -------------------------------------------------------------------------------- - -csChar :: Char -> CS.CharSet -csChar = CS.singleton - -csAlpha :: CS.CharSet -csAlpha = CS.alpha - -csAlphaNum :: CS.CharSet -csAlphaNum = CS.alphanum - -csUpper :: CS.CharSet -csUpper = CS.upper - -csNotSpace :: CS.CharSet -csNotSpace = CS.difference CS.universe $ CS.singleton ' ' - -csNotSpaceOrComma :: CS.CharSet -csNotSpaceOrComma = CS.difference csNotSpace $ CS.singleton ',' - -------------------------------------------------------------------------------- --- Special -------------------------------------------------------------------------------- - -describeFlagAssignmentNonEmpty :: GrammarRegex void -describeFlagAssignmentNonEmpty = REMunch1 RESpaces1 $ - REUnion [fromString "+", fromString "-"] <> describe (Proxy :: Proxy FlagName) - -------------------------------------------------------------------------------- --- Conversion -------------------------------------------------------------------------------- - -convert :: GrammarRegex Void -> RE.RE Void -convert = go id . vacuous where - go :: Ord b => (a -> b) -> GrammarRegex a -> RE.RE b - go f (REAppend rs) = foldr (\r acc -> go f r <> acc) RE.Eps rs - go f (REUnion rs) = foldr (\r acc -> go f r RE.\/ acc) RE.Null rs - go _ (RECharSet cs) = RE.Ch (convertCS cs) - go _ (REString str) = RE.string_ str - - go f (REMunch sep r) = RE.Eps RE.\/ r' <> RE.star_ (sep' <> r') where - sep' = go f sep - r' = go f r - go f (REMunch1 sep r) = r' <> RE.star_ (sep' <> r') where - sep' = go f sep - r' = go f r - go f (REMunchR n sep r) - | n <= 0 = RE.Eps - | otherwise = RE.Eps RE.\/ r' <> go' (pred n) - where - sep' = go f sep - r' = go f r - - go' m | m <= 0 = RE.Eps - | otherwise = RE.Eps RE.\/ sep' <> r' <> go' (pred m) - - go f (REOpt r) = RE.Eps RE.\/ go f r - - go f (REVar a) = RE.Var (f a) - go f (RENamed _ r) = go f r - go f (RERec n r) = RE.fix_ (fromString n) - (go (maybe RE.B (RE.F . f)) r) - - go _ RESpaces = RE.Eps RE.\/ RE.ch_ ' ' RE.\/ " " RE.\/ "\n" - go _ RESpaces1 = RE.ch_ ' ' RE.\/ " " RE.\/ "\n" - - go f (RECommaList r) = go f (expandedCommaList r) - go f (RECommaNonEmpty r)= go f (expandedCommaNonEmpty r) - go f (REOptCommaList r) = go f (expandedOptCommaList r) - - go _ RETodo = RE.Null - -expandedCommaList :: GrammarRegex a -> GrammarRegex a -expandedCommaList = REUnion . expandedCommaList' - -expandedCommaNonEmpty :: GrammarRegex a -> GrammarRegex a -expandedCommaNonEmpty r = REUnion - [ REMunch1 reSpacedComma r - , reComma <> RESpaces <> REMunch1 reSpacedComma r - , REMunch1 reSpacedComma r <> RESpaces <> reComma - ] - -expandedCommaList' :: GrammarRegex a -> [GrammarRegex a] -expandedCommaList' r = - [ REMunch reSpacedComma r - , reComma <> RESpaces <> REMunch1 reSpacedComma r - , REMunch1 reSpacedComma r <> RESpaces <> reComma - ] - -expandedOptCommaList :: GrammarRegex a -> GrammarRegex a -expandedOptCommaList r = REUnion $ reSpacedList r : expandedCommaList' r - -convertCS :: CS.CharSet -> RE.CharSet -convertCS = RE.fromIntervalList . CS.toIntervalList - -------------------------------------------------------------------------------- --- tasty -------------------------------------------------------------------------------- - -testDescribed - :: forall a. (Arbitrary a, Described a, Typeable a, Eq a, Show a) - => Proxy a - -> TestTree -testDescribed _ = testGroup name - [ testProperty "parsec" propParsec - , testProperty "pretty" propPretty - , testProperty "roundtrip" propRoundtrip - ] - where - name = show (typeOf (undefined :: a)) - - propParsec :: Ex a -> Property - propParsec (Example str) = counterexample (show res) $ case res of - Right _ -> True - Left _ -> False - where - res :: Either String a - res = eitherParsec str - - rr :: RE.RE Void - rr = convert $ describe (Proxy :: Proxy a) - - propPretty :: a -> Property - propPretty x = counterexample str $ RE.matchR rr str - where - str = prettyShow x - - propRoundtrip :: a -> Property - propRoundtrip x = counterexample (show (res, str)) $ case res of - Right y -> x == y - Left _ -> False - where - str = prettyShow x - res = eitherParsec str - -newtype Ex a = Example String - deriving (Show) - -instance Described a => Arbitrary (Ex a) where - arbitrary - = fmap Example - $ fromMaybe (return "") - $ RE.generate 10 5 - $ convert $ describe (Proxy :: Proxy a) - - shrink (Example s) - | '\n' `elem` s = [ Example $ map (\c -> if c == '\n' then ' ' else c) s ] - | otherwise = [] - -------------------------------------------------------------------------------- --- Instances -------------------------------------------------------------------------------- - -instance Described AbiDependency where - describe _ = - describe (Proxy :: Proxy UnitId) <> - reChar '=' <> - describe (Proxy :: Proxy AbiHash) - -instance Described AbiHash where - describe _ = reMunchCS csAlphaNum - -instance Described Arch where - describe _ = REUnion - [ fromString (prettyShow arch) - | arch <- knownArches - ] - -instance Described BenchmarkType where - describe _ = "exitcode-stdio-1.0" - -instance Described BuildType where - describe _ = REUnion ["Simple","Configure","Custom","Make","Default"] - -instance Described CompilerFlavor where - describe _ = REUnion - [ fromString (prettyShow c) - | c <- knownCompilerFlavors - ] - -instance Described CompilerId where - describe _ = - describe (Proxy :: Proxy CompilerFlavor) - <> fromString "-" - <> describe (Proxy :: Proxy Version) - -instance Described Dependency where - describe _ = REAppend - [ RENamed "pkg-name" (describe (Proxy :: Proxy PackageName)) - , REOpt $ - reChar ':' - <> REUnion - [ reUnqualComponent - , REAppend - [ reChar '{' - , RESpaces - -- no leading or trailing comma - , REMunch1 reSpacedComma reUnqualComponent - , RESpaces - , reChar '}' - ] - ] - - , REOpt $ RESpaces <> vr - ] - where - vr = RENamed "version-range" (describe (Proxy :: Proxy VersionRange)) - -instance Described ExecutableScope where - describe _ = REUnion ["public","private"] - -instance Described ExeDependency where - describe _ = RETodo - -instance Described ExposedModule where - describe _ = RETodo - -instance Described Extension where - describe _ = RETodo - -instance Described FlagAssignment where - describe _ = REMunch RESpaces1 $ - REUnion [fromString "+", fromString "-"] <> describe (Proxy :: Proxy FlagName) - -instance Described FlagName where - describe _ = lead <> rest where - lead = RECharSet $ csAlphaNum <> fromString "_" - rest = reMunchCS $ csAlphaNum <> fromString "_-" - -instance Described ForeignLibOption where - describe _ = "standalone" - -instance Described ForeignLibType where - describe _ = REUnion ["native-shared","native-static"] - -instance Described IncludeRenaming where - describe _ = mr <> REOpt (RESpaces <> "requires" <> RESpaces1 <> mr) - where - mr = describe (Proxy :: Proxy ModuleRenaming) - -instance Described Language where - describe _ = REUnion ["Haskell98", "Haskell2010"] - -instance Described LegacyExeDependency where - describe _ = RETodo - -instance Described LibraryVisibility where - describe _ = REUnion ["public","private"] - -instance Described LibVersionInfo where - describe _ = reDigits <> REOpt (reChar ':' <> reDigits <> REOpt (reChar ':' <> reDigits)) where - reDigits = reChars ['0'..'9'] - -instance Described Mixin where - describe _ = - RENamed "package-name" (describe (Proxy :: Proxy PackageName)) <> - REOpt (reChar ':' <> RENamed "library-name" (describe (Proxy :: Proxy UnqualComponentName))) <> - REOpt (RESpaces1 <> describe (Proxy :: Proxy IncludeRenaming)) - -instance Described ModuleName where - describe _ = REMunch1 (reChar '.') component where - component = RECharSet csUpper <> REMunch reEps (REUnion [RECharSet csAlphaNum, RECharSet (fromString "_'")]) - -instance Described ModuleReexport where - describe _ = RETodo - -instance Described ModuleRenaming where - describe _ = REUnion - [ reEps - , "hiding" <> RESpaces <> bp (REMunch reSpacedComma mn) - , bp (REMunch reSpacedComma entry) - ] - where - bp r = "(" <> RESpaces <> r <> RESpaces <> ")" - mn = RENamed "module-name" $ describe (Proxy :: Proxy ModuleName) - - entry = mn <> REOpt (RESpaces1 <> "as" <> RESpaces1 <> mn) - -instance Described MungedPackageName where - describe _ = RETodo - -instance Described OS where - describe _ = REUnion - [ fromString (prettyShow os) - | os <- knownOSs - ] - -instance Described PackageIdentifier where - describe _ = describe (Proxy :: Proxy PackageName) <> fromString "-" <> describe (Proxy :: Proxy Version) - -instance Described PackageName where - describe _ = reUnqualComponent - -instance Described PackageVersionConstraint where - describe _ = describe (Proxy :: Proxy PackageName) <> REUnion - [ fromString "-" <> describe (Proxy :: Proxy Version) - , RESpaces <> describe (Proxy :: Proxy VersionRange) - ] - -instance Described PkgconfigDependency where - describe _ = RETodo - -instance Described RepoType where - describe _ = reMunch1CS $ csAlphaNum <> csChar '_' <> csChar '-' - -instance Described TestType where - describe _ = REUnion ["exitcode-stdio-1.0", "detailed-0.9"] - -instance Described Verbosity where - describe _ = REUnion - [ REUnion ["0", "1", "2", "3"] - , REUnion ["silent", "normal", "verbose", "debug", "deafening"] - <> REMunch reEps (RESpaces <> "+" <> - -- markoutput is left out on purpose - REUnion ["callsite", "callstack", "nowrap", "timestamp", "stderr", "stdout" ]) - ] - -instance Described Version where - describe _ = REMunch1 reDot reDigits where - reDigits = REUnion - [ reChar '0' - , reChars ['1'..'9'] <> REMunchR 8 reEps (reChars ['0'..'9']) - ] - -instance Described VersionRange where - describe _ = RERec "version-range" $ REUnion - [ "==" <> RESpaces <> ver - , ">" <> RESpaces <> ver - , "<" <> RESpaces <> ver - , "<=" <> RESpaces <> ver - , ">=" <> RESpaces <> ver - , "^>=" <> RESpaces <> ver - - -- ==0.1.* - , "==" <> RESpaces <> wildVer - - , reVar0 <> RESpaces <> "||" <> RESpaces <> reVar0 - , reVar0 <> RESpaces <> "&&" <> RESpaces <> reVar0 - , "(" <> RESpaces <> reVar0 <> RESpaces <> ")" - - -- == { 0.1.2 } - -- silly haddock: ^>= { 0.1.2, 3.4.5 } - , "==" <> RESpaces <> verSet - , "^>=" <> RESpaces <> verSet - ] - where - ver' = describe (Proxy :: Proxy Version) - ver = RENamed "version" ver' - wildVer = ver' <> ".*" - verSet = "{" <> RESpaces <> REMunch1 reSpacedComma ver <> RESpaces <> "}" - -instance Described UnitId where - describe _ = reMunch1CS $ csAlphaNum <> csChar '-' <> csChar '_' <> csChar '.' <> csChar '+' - -instance Described UnqualComponentName where - describe _ = reUnqualComponent - -------------------------------------------------------------------------------- --- Instances: Newtypes -------------------------------------------------------------------------------- - -class Sep sep => DescribeSep sep where - describeSep :: Proxy sep -> GrammarRegex a -> GrammarRegex a - -instance DescribeSep CommaVCat where describeSep _ = reCommaList -instance DescribeSep CommaFSep where describeSep _ = reCommaList -instance DescribeSep VCat where describeSep _ = reCommaList -instance DescribeSep FSep where describeSep _ = reOptCommaList -instance DescribeSep NoCommaFSep where describeSep _ = reSpacedList - -instance (Newtype a b, DescribeSep sep, Described b) => Described (List sep b a) where - describe _ = describeSep (Proxy :: Proxy sep) (describe (Proxy :: Proxy b)) - -instance (Newtype a b, Ord a, DescribeSep sep, Described b) => Described (Set' sep b a) where - describe _ = describeSep (Proxy :: Proxy sep) (describe (Proxy :: Proxy b)) - -instance Described Token where - describe _ = REUnion [reHsString, reMunch1CS csNotSpaceOrComma] - -instance Described Token' where - describe _ = REUnion [reHsString, reMunch1CS csNotSpace] - -instance Described a => Described (MQuoted a) where - -- TODO: this is simplification - describe _ = describe ([] :: [a]) - -instance Described SpecVersion where - describe _ = "3.4" -- :) - -instance Described SpecLicense where - describe _ = RETodo - -instance Described TestedWith where - describe _ = RETodo - -instance Described FilePathNT where - describe _ = describe ([] :: [Token]) diff --git a/cabal/Cabal/Cabal-described/src/Distribution/Utils/CharSet.hs b/cabal/Cabal/Cabal-described/src/Distribution/Utils/CharSet.hs deleted file mode 100644 --- a/cabal/Cabal/Cabal-described/src/Distribution/Utils/CharSet.hs +++ /dev/null @@ -1,242 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} --- | Sets of characters. --- --- Using this is more efficint than 'RE.Type.Alt':ng individual characters. -module Distribution.Utils.CharSet ( - -- * Set of characters - CharSet, - -- * Construction - empty, - universe, - singleton, - insert, - union, - intersection, - complement, - difference, - -- * Query - size, - null, - member, - -- * Conversions - fromList, - toList, - fromIntervalList, - toIntervalList, - -- * Special lists - alpha, - alphanum, - upper, - ) where - -import Data.Char (chr, isAlpha, isAlphaNum, isUpper, ord) -import Data.List (foldl', sortBy) -import Data.Monoid (Monoid (..)) -import Data.String (IsString (..)) -import Distribution.Compat.Semigroup (Semigroup (..)) -import Prelude - (Bool (..), Bounded (..), Char, Enum (..), Eq (..), Int, Maybe (..), Num (..), Ord (..), Show (..), String, concatMap, flip, fst, otherwise, showParen, - showString, uncurry, ($), (.)) - -#if MIN_VERSION_containers(0,5,0) -import qualified Data.IntMap.Strict as IM -#else -import qualified Data.IntMap as IM -#endif - --- | A set of 'Char's. --- --- We use range set, which works great with 'Char'. -newtype CharSet = CS { unCS :: IM.IntMap Int } - deriving (Eq, Ord) - -instance IsString CharSet where - fromString = fromList - -instance Show CharSet where - showsPrec d cs - | size cs < 20 - = showsPrec d (toList cs) - | otherwise - = showParen (d > 10) - $ showString "CS " - . showsPrec 11 (unCS cs) - -instance Semigroup CharSet where - (<>) = union - -instance Monoid CharSet where - mempty = empty - mappend = (<>) - --- | Empty character set. -empty :: CharSet -empty = CS IM.empty - --- | universe -universe :: CharSet -universe = CS $ IM.singleton 0 0x10ffff - --- | Check whether 'CharSet' is 'empty'. -null :: CharSet -> Bool -null (CS cs) = IM.null cs - --- | Size of 'CharSet' --- --- >>> size $ fromIntervalList [('a','f'), ('0','9')] --- 16 --- --- >>> length $ toList $ fromIntervalList [('a','f'), ('0','9')] --- 16 --- -size :: CharSet -> Int -size (CS m) = foldl' (\ !acc (lo, hi) -> acc + (hi - lo) + 1) 0 (IM.toList m) - --- | Singleton character set. -singleton :: Char -> CharSet -singleton c = CS (IM.singleton (ord c) (ord c)) - --- | Test whether character is in the set. -member :: Char -> CharSet -> Bool -#if MIN_VERSION_containers(0,5,0) -member c (CS m) = case IM.lookupLE i m of - Nothing -> False - Just (_, hi) -> i <= hi - where -#else -member c (CS m) = go (IM.toList m) - where - go [] = False - go ((x,y):zs) = (x <= i && i <= y) || go zs -#endif - i = ord c - --- | Insert 'Char' into 'CharSet'. -insert :: Char -> CharSet -> CharSet -insert c (CS m) = normalise (IM.insert (ord c) (ord c) m) - --- | Union of two 'CharSet's. -union :: CharSet -> CharSet -> CharSet -union (CS xs) (CS ys) = normalise (IM.unionWith max xs ys) - --- | Intersection of two 'CharSet's -intersection :: CharSet -> CharSet -> CharSet -intersection (CS xs) (CS ys) = CS $ - IM.fromList (intersectRangeList (IM.toList xs) (IM.toList ys)) - --- | Compute the intersection. -intersectRangeList :: Ord a => [(a, a)] -> [(a, a)] -> [(a, a)] -intersectRangeList aset@((x,y):as) bset@((u,v):bs) - | y < u = intersectRangeList as bset - | v < x = intersectRangeList aset bs - | y < v = (max x u, y) : intersectRangeList as bset - | otherwise = (max x u, v) : intersectRangeList aset bs -intersectRangeList _ [] = [] -intersectRangeList [] _ = [] - --- | Complement of a CharSet -complement :: CharSet -> CharSet -complement (CS xs) = CS $ IM.fromList $ complementRangeList (IM.toList xs) - --- | Compute the complement intersected with @[x,)@ assuming @x [(Int, Int)] -> [(Int, Int)] -complementRangeList' x ((u,v):s) = (x,pred u) : complementRangeList'' v s -complementRangeList' x [] = [(x,0x10ffff)] - --- | Compute the complement intersected with @(x,)@. -complementRangeList'' :: Int -> [(Int, Int)] -> [(Int, Int)] -complementRangeList'' x s - | x == 0x10ffff = [] - | otherwise = complementRangeList' (succ x) s - --- | Compute the complement. --- --- Note: we treat Ints as codepoints, i.e minBound is 0, and maxBound is 0x10ffff -complementRangeList :: [(Int, Int)] -> [(Int, Int)] -complementRangeList s@((x,y):s') - | x == 0 = complementRangeList'' y s' - | otherwise = complementRangeList' 0 s -complementRangeList [] = [(0, 0x10ffff)] - --- | Difference of two 'CharSet's. -difference :: CharSet -> CharSet -> CharSet -difference xs ys = intersection xs (complement ys) - --- | Make 'CharSet' from a list of characters, i.e. 'String'. -fromList :: String -> CharSet -fromList = normalise . foldl' (\ acc c -> IM.insert (ord c) (ord c) acc) IM.empty - --- | Convert 'CharSet' to a list of characters i.e. 'String'. -toList :: CharSet -> String -toList = concatMap (uncurry enumFromTo) . toIntervalList - --- | Convert to interval list --- --- >>> toIntervalList $ union "01234" "56789" --- [('0','9')] --- -toIntervalList :: CharSet -> [(Char, Char)] -toIntervalList (CS m) = [ (chr lo, chr hi) | (lo, hi) <- IM.toList m ] - --- | Convert from interval pairs. --- --- >>> fromIntervalList [] --- "" --- --- >>> fromIntervalList [('a','f'), ('0','9')] --- "0123456789abcdef" --- --- >>> fromIntervalList [('Z','A')] --- "" --- -fromIntervalList :: [(Char,Char)] -> CharSet -fromIntervalList xs = normalise' $ sortBy (\a b -> compare (fst a) (fst b)) - [ (ord lo, ord hi) - | (lo, hi) <- xs - , lo <= hi - ] - -------------------------------------------------------------------------------- --- Normalisation -------------------------------------------------------------------------------- - -normalise :: IM.IntMap Int -> CharSet -normalise = normalise'. IM.toList - -normalise' :: [(Int,Int)] -> CharSet -normalise' = CS . IM.fromList . go where - go :: [(Int,Int)] -> [(Int,Int)] - go [] = [] - go ((x,y):zs) = go' x y zs - - go' :: Int -> Int -> [(Int, Int)] -> [(Int, Int)] - go' lo hi [] = [(lo, hi)] - go' lo hi ws0@((u,v):ws) - | u <= succ hi = go' lo (max v hi) ws - | otherwise = (lo,hi) : go ws0 - -------------------------------------------------------------------------------- --- Alpha Numeric character list -------------------------------------------------------------------------------- - --- Computing this takes some time, --- but they are not used in-non testing in Cabal's normal operation. - --- | Note: this set varies depending on @base@ version. --- -alpha :: CharSet -alpha = foldl' (flip insert) empty [ c | c <- [ minBound .. maxBound ], isAlpha c ] -{-# NOINLINE alpha #-} - --- | Note: this set varies depending on @base@ version. --- -alphanum :: CharSet -alphanum = foldl' (flip insert) empty [ c | c <- [ minBound .. maxBound ], isAlphaNum c ] -{-# NOINLINE alphanum #-} - --- | Note: this set varies depending on @base@ version. --- -upper :: CharSet -upper = foldl' (flip insert) empty [ c | c <- [ minBound .. maxBound ], isUpper c ] -{-# NOINLINE upper #-} diff --git a/cabal/Cabal/Cabal-described/src/Distribution/Utils/GrammarRegex.hs b/cabal/Cabal/Cabal-described/src/Distribution/Utils/GrammarRegex.hs deleted file mode 100644 --- a/cabal/Cabal/Cabal-described/src/Distribution/Utils/GrammarRegex.hs +++ /dev/null @@ -1,215 +0,0 @@ -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Distribution.Utils.GrammarRegex ( - -- * Regular expressions - GrammarRegex (..), - reEps, - reChar, - reChars, - reMunchCS, - reMunch1CS, - -- * Variables - reVar0, - reVar1, - -- * Pretty-printing - regexDoc, - ) where - -import Data.Char (isAlphaNum, isControl, ord) -import Data.Foldable (Foldable) -import Data.Maybe (fromMaybe) -import Data.Monoid (Monoid (..)) -import Data.String (IsString (..)) -import Data.Traversable (Traversable) -import Data.Void (Void, vacuous) -import Distribution.Compat.Semigroup (Semigroup (..)) -import Prelude (Bool (..), Char, Eq (..), Functor, Int, Maybe (..), Ord (..), Show, String, fmap, length, map, otherwise, ($), (++), (.)) - -import qualified Distribution.Utils.CharSet as CS -import qualified Text.PrettyPrint as PP - -(<<>>) :: PP.Doc -> PP.Doc -> PP.Doc -(<<>>) = (PP.<>) - -------------------------------------------------------------------------------- --- GrammarRegex -------------------------------------------------------------------------------- - --- | Recursive regular expressions tuned for 'Described' use-case. -data GrammarRegex a - = REAppend [GrammarRegex a] -- ^ append @ab@ - | REUnion [GrammarRegex a] -- ^ union @a|b@ - - -- repetition - | REMunch (GrammarRegex a) (GrammarRegex a) -- ^ star @a*@, with a separator - | REMunch1 (GrammarRegex a) (GrammarRegex a) -- ^ plus @a+@, with a separator - | REMunchR Int (GrammarRegex a) (GrammarRegex a) -- ^ 1-n, with a separator - | REOpt (GrammarRegex a) -- ^ optional @r?@ - - | REString String -- ^ literal string @abcd@ - | RECharSet CS.CharSet -- ^ charset @[:alnum:]@ - | REVar a -- ^ variable - | RENamed String (GrammarRegex a) -- ^ named expression - | RERec String (GrammarRegex (Maybe a)) -- ^ recursive expressions - - -- cabal syntax specifics - | RESpaces -- ^ zero-or-more spaces - | RESpaces1 -- ^ one-or-more spaces - | RECommaList (GrammarRegex a) -- ^ comma list (note, leading or trailing commas) - | RECommaNonEmpty (GrammarRegex a) -- ^ comma non-empty list (note, leading or trailing commas) - | REOptCommaList (GrammarRegex a) -- ^ opt comma list - - | RETodo -- ^ unspecified - deriving (Eq, Ord, Show, Functor, Foldable, Traversable) - -------------------------------------------------------------------------------- --- Instances -------------------------------------------------------------------------------- - -instance IsString (GrammarRegex a) where - fromString = REString - -instance Semigroup (GrammarRegex a) where - x <> y = REAppend (unAppend x ++ unAppend y) where - unAppend (REAppend rs) = rs - unAppend r = [r] - -instance Monoid (GrammarRegex a) where - mempty = REAppend [] - mappend = (<>) - -------------------------------------------------------------------------------- --- Smart constructors -------------------------------------------------------------------------------- - -reEps :: GrammarRegex a -reEps = REAppend [] - -reChar :: Char -> GrammarRegex a -reChar = RECharSet . CS.singleton - -reChars :: [Char] -> GrammarRegex a -reChars = RECharSet . CS.fromList - -reMunch1CS :: CS.CharSet -> GrammarRegex a -reMunch1CS = REMunch1 reEps . RECharSet - -reMunchCS :: CS.CharSet -> GrammarRegex a -reMunchCS = REMunch reEps . RECharSet - -------------------------------------------------------------------------------- --- Variables -------------------------------------------------------------------------------- - -reVar0 :: GrammarRegex (Maybe a) -reVar0 = REVar Nothing - -reVar1 :: GrammarRegex (Maybe (Maybe a)) -reVar1 = REVar (Just Nothing) - -------------------------------------------------------------------------------- --- Pretty-printing -------------------------------------------------------------------------------- - --- | --- --- >>> regexDoc $ REString "True" --- \mathop{\mathord{``}\mathtt{True}\mathord{"}} --- --- Note: we don't simplify regexps yet: --- --- >>> regexDoc $ REString "foo" <> REString "bar" --- \mathop{\mathord{``}\mathtt{foo}\mathord{"}}\mathop{\mathord{``}\mathtt{bar}\mathord{"}} --- -regexDoc :: GrammarRegex Void -> PP.Doc -regexDoc = go 0 . vacuous where - go :: Int -> GrammarRegex PP.Doc -> PP.Doc - go _ (REAppend []) = "" - go d (REAppend rs) = parensIf (d > 2) $ PP.hcat (map (go 2) rs) - go d (REUnion [r]) = go d r - go _ (REUnion rs) = PP.hsep - [ "\\left\\{" - , if length rs < 4 - then PP.hcat (PP.punctuate (PP.text "\\mid") (map (go 0) rs)) - else "\\begin{gathered}" <<>> - PP.hcat (PP.punctuate "\\\\" (map (go 0) rs)) <<>> - "\\end{gathered}" - , "\\right\\}" ] - - go d (REMunch sep r) = parensIf (d > 3) $ - PP.text "{" <<>> go 4 r <<>> PP.text "}^\\ast_{" <<>> go 4 sep <<>> PP.text "}" - go d (REMunch1 sep r) = parensIf (d > 3) $ - PP.text "{" <<>> go 4 r <<>> PP.text "}^+_{" <<>> go 4 sep <<>> PP.text "}" - go d (REMunchR n sep r) = parensIf (d > 3) $ - PP.text "{" <<>> go 4 r <<>> PP.text "}^{\\in [0\\ldots" <<>> PP.int n <<>> "]}_{" <<>> go 4 sep <<>> PP.text "}" - go d (REOpt r) = parensIf (d > 3) $ - PP.text "{" <<>> go 4 r <<>> PP.text "}^?" - - go _ (REString s) = PP.text "\\mathop{\\mathord{``}\\mathtt{" <<>> PP.hcat (map charDoc s) <<>> PP.text "}\\mathord{\"}}" - go _ (RECharSet cs) = charsetDoc cs - - go _ RESpaces = "\\circ" - go _ RESpaces1 = "\\bullet" - - go _ (RECommaList r) = - "\\mathrm{commalist}" <<>> go 4 r - go _ (RECommaNonEmpty r) = - "\\mathrm{commanonempty}" <<>> go 4 r - go _ (REOptCommaList r) = - "\\mathrm{optcommalist}" <<>> go 4 r - - go _ (REVar a) = a - go _ (RENamed n _) = terminalDoc n - go d (RERec n r) = parensIf (d > 0) $ - "\\mathbf{fix}\\;" <<>> n' <<>> "\\;\\mathbf{in}\\;" <<>> - go 0 (fmap (fromMaybe n') r) - where - n' = terminalDoc n - - go _ RETodo = PP.text "\\mathsf{\\color{red}{TODO}}" - - parensIf :: Bool -> PP.Doc -> PP.Doc - parensIf True d = PP.text "\\left(" <<>> d <<>> PP.text "\\right)" - parensIf False d = d - -terminalDoc :: String -> PP.Doc -terminalDoc s = PP.text "\\mathop{\\mathit{" <<>> PP.hcat (map charDoc s) <<>> PP.text "}}" - -charDoc :: Char -> PP.Doc -charDoc ' ' = PP.text "\\ " -charDoc '{' = PP.text "\\{" -charDoc '}' = PP.text "\\}" -charDoc '\\' = PP.text "\\text{\\\\}" -charDoc c - | isAlphaNum c = PP.char c - | isControl c = PP.int (ord c) -- TODO: some syntax - | otherwise = PP.text ("\\text{" ++ c : "}") - -inquotes :: PP.Doc -> PP.Doc -inquotes d = "\\mathop{\\mathord{``}" <<>> d <<>> "\\mathord{\"}}" - -mathtt :: PP.Doc -> PP.Doc -mathtt d = "\\mathtt{" <<>> d <<>> "}" - -charsetDoc :: CS.CharSet -> PP.Doc -charsetDoc acs - | acs == CS.alpha = terminalDoc "alpha" - | acs == CS.alphanum = terminalDoc "alpha-num" - | acs == CS.upper = terminalDoc "upper" -charsetDoc acs = case CS.toIntervalList acs of - [] -> "\\emptyset" - [(x,y)] | x == y -> inquotes $ mathtt $ charDoc x - rs - | CS.size acs <= CS.size notAcs - -> PP.brackets $ PP.hcat $ map rangeDoc rs - | otherwise - -> PP.braces $ PP.brackets (PP.hcat $ map rangeDoc (CS.toIntervalList notAcs)) <<>> PP.text "^c" - where - notAcs = CS.complement acs - - rangeDoc :: (Char, Char) -> PP.Doc - rangeDoc (x, y) | x == y = inquotes (mathtt $ charDoc x) - | otherwise = inquotes (mathtt $ charDoc x) <<>> PP.text "\\cdots" <<>> inquotes (mathtt $ charDoc y) diff --git a/cabal/Cabal/Cabal-tree-diff/Cabal-tree-diff.cabal b/cabal/Cabal/Cabal-tree-diff/Cabal-tree-diff.cabal deleted file mode 100644 --- a/cabal/Cabal/Cabal-tree-diff/Cabal-tree-diff.cabal +++ /dev/null @@ -1,21 +0,0 @@ -cabal-version: 2.2 -name: Cabal-tree-diff -version: 3.3.0.0 -synopsis: QuickCheck instances for types in Cabal -category: Testing -description: Provides tree-diff ToExpr instances for some types in Cabal - -library - default-language: Haskell2010 - hs-source-dirs: src - ghc-options: -Wall - build-depends: - , base - , Cabal ^>=3.3.0.0 - , tree-diff ^>=0.1 - - exposed-modules: Data.TreeDiff.Instances.Cabal - other-modules: - Data.TreeDiff.Instances.CabalLanguage - Data.TreeDiff.Instances.CabalSPDX - Data.TreeDiff.Instances.CabalVersion diff --git a/cabal/Cabal/Cabal-tree-diff/src/Data/TreeDiff/Instances/Cabal.hs b/cabal/Cabal/Cabal-tree-diff/src/Data/TreeDiff/Instances/Cabal.hs deleted file mode 100644 --- a/cabal/Cabal/Cabal-tree-diff/src/Data/TreeDiff/Instances/Cabal.hs +++ /dev/null @@ -1,135 +0,0 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 800 -{-# OPTIONS_GHC -freduction-depth=0 #-} -#else -{-# OPTIONS_GHC -fcontext-stack=151 #-} -#endif -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Data.TreeDiff.Instances.Cabal () where - -import Data.TreeDiff - -import Data.TreeDiff.Instances.CabalLanguage () -import Data.TreeDiff.Instances.CabalSPDX () -import Data.TreeDiff.Instances.CabalVersion () - -------------------------------------------------------------------------------- - -import Distribution.Backpack (OpenModule, OpenUnitId) -import Distribution.CabalSpecVersion (CabalSpecVersion) -import Distribution.Compiler (CompilerFlavor, CompilerId, PerCompilerFlavor) -import Distribution.InstalledPackageInfo (AbiDependency, ExposedModule, InstalledPackageInfo) -import Distribution.ModuleName (ModuleName) -import Distribution.PackageDescription -import Distribution.Simple.Compiler (DebugInfoLevel, OptimisationLevel, ProfDetailLevel) -import Distribution.Simple.Flag (Flag) -import Distribution.Simple.InstallDirs -import Distribution.Simple.InstallDirs.Internal -import Distribution.Simple.Setup (HaddockTarget, TestShowDetails) -import Distribution.System -import Distribution.Types.AbiHash (AbiHash) -import Distribution.Types.ComponentId (ComponentId) -import Distribution.Types.IncludeRenaming (IncludeRenaming) -import Distribution.Types.Mixin -import Distribution.Types.ModuleReexport -import Distribution.Types.ModuleRenaming -import Distribution.Types.PackageVersionConstraint -import Distribution.Types.PkgconfigName (PkgconfigName) -import Distribution.Types.PkgconfigVersion (PkgconfigVersion) -import Distribution.Types.PkgconfigVersionRange (PkgconfigVersionRange) -import Distribution.Types.UnitId (DefUnitId, UnitId) -import Distribution.Utils.NubList (NubList) -import Distribution.Utils.ShortText (ShortText, fromShortText) -import Distribution.Verbosity -import Distribution.Verbosity.Internal - -import qualified Distribution.Compat.NonEmptySet as NES - -------------------------------------------------------------------------------- --- instances -------------------------------------------------------------------------------- - -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 (ToExpr a) => ToExpr (NubList a) -instance (ToExpr a) => ToExpr (Flag a) -instance ToExpr a => ToExpr (NES.NonEmptySet a) where - toExpr xs = App "NonEmptySet.fromNonEmpty" [toExpr $ NES.toNonEmpty xs] - -instance ToExpr a => ToExpr (PerCompilerFlavor a) - -instance ToExpr Dependency where - toExpr d@(Dependency pn vr cs) - | cs == mainLibSet = App "Dependency" [toExpr pn, toExpr vr, App "mainLibSet" []] - | otherwise = genericToExpr d - -instance ToExpr AbiDependency -instance ToExpr AbiHash -instance ToExpr Arch -instance ToExpr Benchmark -instance ToExpr BenchmarkInterface -instance ToExpr BenchmarkType -instance ToExpr BuildInfo -instance ToExpr BuildType -instance ToExpr CabalSpecVersion -instance ToExpr CompilerFlavor -instance ToExpr CompilerId -instance ToExpr ComponentId -instance ToExpr DebugInfoLevel -instance ToExpr DefUnitId -instance ToExpr ExeDependency -instance ToExpr Executable -instance ToExpr ExecutableScope -instance ToExpr ExposedModule -instance ToExpr FlagAssignment -instance ToExpr FlagName -instance ToExpr ForeignLib -instance ToExpr ForeignLibOption -instance ToExpr ForeignLibType -instance ToExpr GenericPackageDescription -instance ToExpr HaddockTarget -instance ToExpr IncludeRenaming -instance ToExpr InstalledPackageInfo -instance ToExpr KnownRepoType -instance ToExpr LegacyExeDependency -instance ToExpr LibVersionInfo -instance ToExpr Library -instance ToExpr LibraryName -instance ToExpr LibraryVisibility -instance ToExpr Mixin -instance ToExpr ModuleName -instance ToExpr ModuleReexport -instance ToExpr ModuleRenaming -instance ToExpr OS -instance ToExpr OpenModule -instance ToExpr OpenUnitId -instance ToExpr OptimisationLevel -instance ToExpr PackageDescription -instance ToExpr PackageFlag -instance ToExpr PackageIdentifier -instance ToExpr PackageName -instance ToExpr PackageVersionConstraint -instance ToExpr PathComponent -instance ToExpr PathTemplate -instance ToExpr PathTemplateVariable -instance ToExpr PkgconfigDependency -instance ToExpr PkgconfigName -instance ToExpr PkgconfigVersion -instance ToExpr PkgconfigVersionRange -instance ToExpr ProfDetailLevel -instance ToExpr RepoKind -instance ToExpr RepoType -instance ToExpr SetupBuildInfo -instance ToExpr SourceRepo -instance ToExpr TestShowDetails -instance ToExpr TestSuite -instance ToExpr TestSuiteInterface -instance ToExpr TestType -instance ToExpr UnitId -instance ToExpr UnqualComponentName -instance ToExpr Verbosity -instance ToExpr VerbosityFlag -instance ToExpr VerbosityLevel - -instance ToExpr ShortText where toExpr = toExpr . fromShortText diff --git a/cabal/Cabal/Cabal-tree-diff/src/Data/TreeDiff/Instances/CabalLanguage.hs b/cabal/Cabal/Cabal-tree-diff/src/Data/TreeDiff/Instances/CabalLanguage.hs deleted file mode 100644 --- a/cabal/Cabal/Cabal-tree-diff/src/Data/TreeDiff/Instances/CabalLanguage.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 800 -{-# OPTIONS_GHC -freduction-depth=0 #-} -#else -{-# OPTIONS_GHC -fcontext-stack=151 #-} -#endif -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Data.TreeDiff.Instances.CabalLanguage () where - -import Data.TreeDiff -import Language.Haskell.Extension (Extension, KnownExtension, Language) - --- These are big enums, so they are in separate file. --- -instance ToExpr Extension -instance ToExpr KnownExtension -instance ToExpr Language diff --git a/cabal/Cabal/Cabal-tree-diff/src/Data/TreeDiff/Instances/CabalSPDX.hs b/cabal/Cabal/Cabal-tree-diff/src/Data/TreeDiff/Instances/CabalSPDX.hs deleted file mode 100644 --- a/cabal/Cabal/Cabal-tree-diff/src/Data/TreeDiff/Instances/CabalSPDX.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 800 -{-# OPTIONS_GHC -freduction-depth=0 #-} -#else -{-# OPTIONS_GHC -fcontext-stack=151 #-} -#endif -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Data.TreeDiff.Instances.CabalSPDX () where - -import Data.TreeDiff -import Distribution.License (License) - -import Data.TreeDiff.Instances.CabalVersion () - -import qualified Distribution.SPDX as SPDX - --- 'License' almost belongs here. - -instance ToExpr License - --- Generics instance is too heavy -instance ToExpr SPDX.LicenseId where toExpr = defaultExprViaShow -instance ToExpr SPDX.LicenseExceptionId where toExpr = defaultExprViaShow - -instance ToExpr SPDX.License -instance ToExpr SPDX.LicenseExpression -instance ToExpr SPDX.LicenseRef -instance ToExpr SPDX.SimpleLicenseExpression diff --git a/cabal/Cabal/Cabal-tree-diff/src/Data/TreeDiff/Instances/CabalVersion.hs b/cabal/Cabal/Cabal-tree-diff/src/Data/TreeDiff/Instances/CabalVersion.hs deleted file mode 100644 --- a/cabal/Cabal/Cabal-tree-diff/src/Data/TreeDiff/Instances/CabalVersion.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 800 -{-# OPTIONS_GHC -freduction-depth=0 #-} -#else -{-# OPTIONS_GHC -fcontext-stack=151 #-} -#endif -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Data.TreeDiff.Instances.CabalVersion where - -import Data.TreeDiff -import Distribution.Version (Version, VersionRange, versionNumbers) - -instance ToExpr Version where toExpr v = App "mkVersion" [toExpr $ versionNumbers v] -instance ToExpr VersionRange diff --git a/cabal/Cabal/Cabal.cabal b/cabal/Cabal/Cabal.cabal --- a/cabal/Cabal/Cabal.cabal +++ b/cabal/Cabal/Cabal.cabal @@ -1,7 +1,7 @@ -cabal-version: >=1.10 +cabal-version: 1.22 name: Cabal -version: 3.3.0.0 -copyright: 2003-2020, Cabal Development Team (see AUTHORS file) +version: 3.8.1.0 +copyright: 2003-2022, Cabal Development Team (see AUTHORS file) license: BSD3 license-file: LICENSE author: Cabal Development Team @@ -22,337 +22,44 @@ -- we can bootstrap. extra-source-files: - README.md tests/README.md ChangeLog.md - doc/bugs-and-stability.rst doc/concepts-and-development.rst - doc/conf.py doc/config-and-install.rst doc/developing-packages.rst - doc/images/Cabal-dark.png doc/index.rst doc/installing-packages.rst - doc/intro.rst doc/misc.rst doc/nix-local-build-overview.rst - doc/nix-local-build.rst doc/file-format-changelog.rst doc/README.md - doc/references.inc - - -- Generated with 'make gen-extra-source-files' - -- Do NOT edit this section manually; instead, run the script. - -- BEGIN gen-extra-source-files - tests/ParserTests/errors/MiniAgda.cabal - tests/ParserTests/errors/MiniAgda.errors - tests/ParserTests/errors/anynone.cabal - tests/ParserTests/errors/anynone.errors - tests/ParserTests/errors/big-version.cabal - tests/ParserTests/errors/big-version.errors - tests/ParserTests/errors/common1.cabal - tests/ParserTests/errors/common1.errors - tests/ParserTests/errors/common2.cabal - tests/ParserTests/errors/common2.errors - tests/ParserTests/errors/common3.cabal - tests/ParserTests/errors/common3.errors - tests/ParserTests/errors/forward-compat.cabal - tests/ParserTests/errors/forward-compat.errors - tests/ParserTests/errors/forward-compat2.cabal - tests/ParserTests/errors/forward-compat2.errors - tests/ParserTests/errors/forward-compat3.cabal - tests/ParserTests/errors/forward-compat3.errors - tests/ParserTests/errors/issue-5055-2.cabal - tests/ParserTests/errors/issue-5055-2.errors - tests/ParserTests/errors/issue-5055.cabal - tests/ParserTests/errors/issue-5055.errors - tests/ParserTests/errors/leading-comma-2.cabal - tests/ParserTests/errors/leading-comma-2.errors - tests/ParserTests/errors/leading-comma-2b.cabal - tests/ParserTests/errors/leading-comma-2b.errors - tests/ParserTests/errors/leading-comma-2c.cabal - tests/ParserTests/errors/leading-comma-2c.errors - tests/ParserTests/errors/leading-comma.cabal - tests/ParserTests/errors/leading-comma.errors - tests/ParserTests/errors/libpq1.cabal - tests/ParserTests/errors/libpq1.errors - tests/ParserTests/errors/libpq2.cabal - tests/ParserTests/errors/libpq2.errors - tests/ParserTests/errors/mixin-1.cabal - tests/ParserTests/errors/mixin-1.errors - tests/ParserTests/errors/mixin-2.cabal - tests/ParserTests/errors/mixin-2.errors - tests/ParserTests/errors/multiple-libs.cabal - tests/ParserTests/errors/multiple-libs.errors - tests/ParserTests/errors/noVersion.cabal - tests/ParserTests/errors/noVersion.errors - tests/ParserTests/errors/noVersion2.cabal - tests/ParserTests/errors/noVersion2.errors - tests/ParserTests/errors/range-ge-wild.cabal - tests/ParserTests/errors/range-ge-wild.errors - tests/ParserTests/errors/removed-fields.cabal - tests/ParserTests/errors/removed-fields.errors - tests/ParserTests/errors/spdx-1.cabal - tests/ParserTests/errors/spdx-1.errors - tests/ParserTests/errors/spdx-2.cabal - tests/ParserTests/errors/spdx-2.errors - tests/ParserTests/errors/spdx-3.cabal - tests/ParserTests/errors/spdx-3.errors - tests/ParserTests/errors/undefined-flag.cabal - tests/ParserTests/errors/undefined-flag.errors - tests/ParserTests/errors/version-sets-1.cabal - tests/ParserTests/errors/version-sets-1.errors - tests/ParserTests/errors/version-sets-2.cabal - tests/ParserTests/errors/version-sets-2.errors - tests/ParserTests/errors/version-sets-3.cabal - tests/ParserTests/errors/version-sets-3.errors - tests/ParserTests/errors/version-sets-4.cabal - tests/ParserTests/errors/version-sets-4.errors - tests/ParserTests/ipi/Includes2.cabal - tests/ParserTests/ipi/Includes2.expr - tests/ParserTests/ipi/Includes2.format - tests/ParserTests/ipi/internal-preprocessor-test.cabal - tests/ParserTests/ipi/internal-preprocessor-test.expr - tests/ParserTests/ipi/internal-preprocessor-test.format - tests/ParserTests/ipi/issue-2276-ghc-9885.cabal - tests/ParserTests/ipi/issue-2276-ghc-9885.expr - tests/ParserTests/ipi/issue-2276-ghc-9885.format - tests/ParserTests/ipi/transformers.cabal - tests/ParserTests/ipi/transformers.expr - tests/ParserTests/ipi/transformers.format - tests/ParserTests/regressions/Octree-0.5.cabal - tests/ParserTests/regressions/Octree-0.5.expr - tests/ParserTests/regressions/Octree-0.5.format - tests/ParserTests/regressions/anynone.cabal - tests/ParserTests/regressions/anynone.expr - tests/ParserTests/regressions/anynone.format - tests/ParserTests/regressions/assoc-cpp-options.cabal - tests/ParserTests/regressions/assoc-cpp-options.check - tests/ParserTests/regressions/bad-glob-syntax.cabal - tests/ParserTests/regressions/bad-glob-syntax.check - tests/ParserTests/regressions/big-version.cabal - tests/ParserTests/regressions/big-version.expr - tests/ParserTests/regressions/big-version.format - tests/ParserTests/regressions/cc-options-with-optimization.cabal - tests/ParserTests/regressions/cc-options-with-optimization.check - tests/ParserTests/regressions/common-conditional.cabal - tests/ParserTests/regressions/common-conditional.expr - tests/ParserTests/regressions/common-conditional.format - tests/ParserTests/regressions/common.cabal - tests/ParserTests/regressions/common.expr - tests/ParserTests/regressions/common.format - tests/ParserTests/regressions/common2.cabal - tests/ParserTests/regressions/common2.expr - tests/ParserTests/regressions/common2.format - tests/ParserTests/regressions/common3.cabal - tests/ParserTests/regressions/common3.expr - tests/ParserTests/regressions/common3.format - tests/ParserTests/regressions/cxx-options-with-optimization.cabal - tests/ParserTests/regressions/cxx-options-with-optimization.check - tests/ParserTests/regressions/elif.cabal - tests/ParserTests/regressions/elif.expr - tests/ParserTests/regressions/elif.format - tests/ParserTests/regressions/elif2.cabal - tests/ParserTests/regressions/elif2.expr - tests/ParserTests/regressions/elif2.format - tests/ParserTests/regressions/encoding-0.8.cabal - tests/ParserTests/regressions/encoding-0.8.expr - tests/ParserTests/regressions/encoding-0.8.format - tests/ParserTests/regressions/extensions-paths-5054.cabal - tests/ParserTests/regressions/extensions-paths-5054.check - tests/ParserTests/regressions/generics-sop.cabal - tests/ParserTests/regressions/generics-sop.expr - tests/ParserTests/regressions/generics-sop.format - tests/ParserTests/regressions/ghc-option-j.cabal - tests/ParserTests/regressions/ghc-option-j.check - tests/ParserTests/regressions/haddock-api-2.18.1-check.cabal - tests/ParserTests/regressions/haddock-api-2.18.1-check.check - tests/ParserTests/regressions/hasktorch.cabal - tests/ParserTests/regressions/hasktorch.expr - tests/ParserTests/regressions/hasktorch.format - tests/ParserTests/regressions/hidden-main-lib.cabal - tests/ParserTests/regressions/hidden-main-lib.expr - tests/ParserTests/regressions/hidden-main-lib.format - tests/ParserTests/regressions/indentation.cabal - tests/ParserTests/regressions/indentation.expr - tests/ParserTests/regressions/indentation.format - tests/ParserTests/regressions/indentation2.cabal - tests/ParserTests/regressions/indentation2.expr - tests/ParserTests/regressions/indentation2.format - tests/ParserTests/regressions/indentation3.cabal - tests/ParserTests/regressions/indentation3.expr - tests/ParserTests/regressions/indentation3.format - tests/ParserTests/regressions/issue-5055.cabal - tests/ParserTests/regressions/issue-5055.expr - tests/ParserTests/regressions/issue-5055.format - tests/ParserTests/regressions/issue-5846.cabal - tests/ParserTests/regressions/issue-5846.expr - tests/ParserTests/regressions/issue-5846.format - tests/ParserTests/regressions/issue-6083-a.cabal - tests/ParserTests/regressions/issue-6083-a.expr - tests/ParserTests/regressions/issue-6083-a.format - tests/ParserTests/regressions/issue-6083-b.cabal - tests/ParserTests/regressions/issue-6083-b.expr - tests/ParserTests/regressions/issue-6083-b.format - tests/ParserTests/regressions/issue-6083-c.cabal - tests/ParserTests/regressions/issue-6083-c.expr - tests/ParserTests/regressions/issue-6083-c.format - tests/ParserTests/regressions/issue-6083-pkg-pkg.cabal - tests/ParserTests/regressions/issue-6083-pkg-pkg.expr - tests/ParserTests/regressions/issue-6083-pkg-pkg.format - tests/ParserTests/regressions/issue-6288-a.cabal - tests/ParserTests/regressions/issue-6288-a.check - tests/ParserTests/regressions/issue-6288-b.cabal - tests/ParserTests/regressions/issue-6288-b.check - tests/ParserTests/regressions/issue-6288-c.cabal - tests/ParserTests/regressions/issue-6288-c.check - tests/ParserTests/regressions/issue-6288-d.cabal - tests/ParserTests/regressions/issue-6288-d.check - tests/ParserTests/regressions/issue-6288-e.cabal - tests/ParserTests/regressions/issue-6288-e.check - tests/ParserTests/regressions/issue-6288-f.cabal - tests/ParserTests/regressions/issue-6288-f.check - tests/ParserTests/regressions/issue-774.cabal - tests/ParserTests/regressions/issue-774.check - tests/ParserTests/regressions/issue-774.expr - tests/ParserTests/regressions/issue-774.format - tests/ParserTests/regressions/jaeger-flamegraph.cabal - tests/ParserTests/regressions/jaeger-flamegraph.expr - tests/ParserTests/regressions/jaeger-flamegraph.format - tests/ParserTests/regressions/leading-comma-2.cabal - tests/ParserTests/regressions/leading-comma-2.expr - tests/ParserTests/regressions/leading-comma-2.format - tests/ParserTests/regressions/leading-comma.cabal - tests/ParserTests/regressions/leading-comma.expr - tests/ParserTests/regressions/leading-comma.format - tests/ParserTests/regressions/libpq1.cabal - tests/ParserTests/regressions/libpq1.expr - tests/ParserTests/regressions/libpq1.format - tests/ParserTests/regressions/libpq2.cabal - tests/ParserTests/regressions/libpq2.expr - tests/ParserTests/regressions/libpq2.format - tests/ParserTests/regressions/mixin-1.cabal - tests/ParserTests/regressions/mixin-1.expr - tests/ParserTests/regressions/mixin-1.format - tests/ParserTests/regressions/mixin-2.cabal - tests/ParserTests/regressions/mixin-2.expr - tests/ParserTests/regressions/mixin-2.format - tests/ParserTests/regressions/mixin-3.cabal - tests/ParserTests/regressions/mixin-3.expr - tests/ParserTests/regressions/mixin-3.format - tests/ParserTests/regressions/monad-param.cabal - tests/ParserTests/regressions/monad-param.expr - tests/ParserTests/regressions/monad-param.format - tests/ParserTests/regressions/multiple-libs-2.cabal - tests/ParserTests/regressions/multiple-libs-2.check - tests/ParserTests/regressions/multiple-libs-2.expr - tests/ParserTests/regressions/multiple-libs-2.format - tests/ParserTests/regressions/noVersion.cabal - tests/ParserTests/regressions/noVersion.expr - tests/ParserTests/regressions/noVersion.format - tests/ParserTests/regressions/nothing-unicode.cabal - tests/ParserTests/regressions/nothing-unicode.check - tests/ParserTests/regressions/nothing-unicode.expr - tests/ParserTests/regressions/nothing-unicode.format - tests/ParserTests/regressions/pre-1.6-glob.cabal - tests/ParserTests/regressions/pre-1.6-glob.check - tests/ParserTests/regressions/pre-2.4-globstar.cabal - tests/ParserTests/regressions/pre-2.4-globstar.check - tests/ParserTests/regressions/public-multilib-1.cabal - tests/ParserTests/regressions/public-multilib-1.check - tests/ParserTests/regressions/public-multilib-2.cabal - tests/ParserTests/regressions/public-multilib-2.check - tests/ParserTests/regressions/shake.cabal - tests/ParserTests/regressions/shake.expr - tests/ParserTests/regressions/shake.format - tests/ParserTests/regressions/spdx-1.cabal - tests/ParserTests/regressions/spdx-1.expr - tests/ParserTests/regressions/spdx-1.format - tests/ParserTests/regressions/spdx-2.cabal - tests/ParserTests/regressions/spdx-2.expr - tests/ParserTests/regressions/spdx-2.format - tests/ParserTests/regressions/spdx-3.cabal - tests/ParserTests/regressions/spdx-3.expr - tests/ParserTests/regressions/spdx-3.format - tests/ParserTests/regressions/th-lift-instances.cabal - tests/ParserTests/regressions/th-lift-instances.expr - tests/ParserTests/regressions/th-lift-instances.format - tests/ParserTests/regressions/version-sets.cabal - tests/ParserTests/regressions/version-sets.expr - tests/ParserTests/regressions/version-sets.format - tests/ParserTests/regressions/wl-pprint-indef.cabal - tests/ParserTests/regressions/wl-pprint-indef.expr - tests/ParserTests/regressions/wl-pprint-indef.format - tests/ParserTests/warnings/bom.cabal - tests/ParserTests/warnings/bool.cabal - tests/ParserTests/warnings/deprecatedfield.cabal - tests/ParserTests/warnings/doubledash.cabal - tests/ParserTests/warnings/extratestmodule.cabal - tests/ParserTests/warnings/gluedop.cabal - tests/ParserTests/warnings/multiplesingular.cabal - tests/ParserTests/warnings/nbsp.cabal - tests/ParserTests/warnings/newsyntax.cabal - tests/ParserTests/warnings/oldsyntax.cabal - tests/ParserTests/warnings/operator.cabal - tests/ParserTests/warnings/specversion-a.cabal - tests/ParserTests/warnings/specversion-b.cabal - tests/ParserTests/warnings/specversion-c.cabal - tests/ParserTests/warnings/subsection.cabal - tests/ParserTests/warnings/tab.cabal - tests/ParserTests/warnings/trailingfield.cabal - tests/ParserTests/warnings/unknownfield.cabal - tests/ParserTests/warnings/unknownsection.cabal - tests/ParserTests/warnings/utf8.cabal - tests/ParserTests/warnings/versiontag.cabal - tests/ParserTests/warnings/wildcard.cabal - tests/cbits/rpmvercmp.c - tests/hackage/check.sh - tests/hackage/download.sh - tests/hackage/unpack.sh - tests/misc/ghc-supported-languages.hs - -- END gen-extra-source-files + README.md ChangeLog.md source-repository head type: git location: https://github.com/haskell/cabal/ subdir: Cabal -flag bundled-binary-generic - default: False - library + default-language: Haskell2010 + hs-source-dirs: src + build-depends: + Cabal-syntax >= 3.8 && < 3.9, array >= 0.4.0.1 && < 0.6, base >= 4.6 && < 5, - bytestring >= 0.10.0.0 && < 0.11, + bytestring >= 0.10.0.0 && < 0.12, containers >= 0.5.0.0 && < 0.7, deepseq >= 1.3.0.1 && < 1.5, directory >= 1.2 && < 1.4, filepath >= 1.3.0.1 && < 1.5, pretty >= 1.1.1 && < 1.2, - process >= 1.1.0.2 && < 1.7, - time >= 1.4.0.1 && < 1.11 - - if flag(bundled-binary-generic) - build-depends: binary >= 0.5.1.1 && < 0.7 - else - build-depends: binary >= 0.7 && < 0.9 + process >= 1.2.1.0 && < 1.7, + time >= 1.4.0.1 && < 1.13 if os(windows) - build-depends: Win32 >= 2.3.0.0 && < 2.9 + build-depends: Win32 >= 2.3.0.0 && < 2.14 else build-depends: unix >= 2.6.0.0 && < 2.8 - ghc-options: -Wall -fno-ignore-asserts -fwarn-tabs -fwarn-incomplete-uni-patterns + ghc-options: -Wall -fno-ignore-asserts -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates + if impl(ghc >= 8.0) ghc-options: -Wcompat -Wnoncanonical-monad-instances - if impl(ghc <8.8) - ghc-options: -Wnoncanonical-monadfail-instances - - if !impl(ghc >= 8.0) - -- at least one of lib:Cabal's dependency (i.e. `parsec`) - -- already depends on `fail` and `semigroups` transitively - build-depends: fail == 4.9.*, semigroups >= 0.18.3 && < 0.20 - - if !impl(ghc >= 7.10) - build-depends: void >= 0.7.3 && < 0.8 - - if !impl(ghc >= 7.8) - -- semigroups depends on tagged. - build-depends: tagged >=0.8.6 && <0.9 + if impl(ghc >= 8.0) && impl(ghc < 8.8) + ghc-options: -Wnoncanonical-monadfail-instances exposed-modules: - Distribution.Backpack Distribution.Backpack.Configure Distribution.Backpack.ComponentsGraph Distribution.Backpack.ConfiguredComponent @@ -362,44 +69,21 @@ Distribution.Backpack.ModSubst Distribution.Backpack.ModuleShape Distribution.Backpack.PreModuleShape - Distribution.CabalSpecVersion Distribution.Utils.IOData Distribution.Utils.LogProgress Distribution.Utils.MapAccum - Distribution.Utils.MD5 - Distribution.Utils.Structured Distribution.Compat.CreatePipe Distribution.Compat.Directory Distribution.Compat.Environment - Distribution.Compat.Exception Distribution.Compat.FilePath - Distribution.Compat.Graph Distribution.Compat.Internal.TempFile - Distribution.Compat.Newtype - Distribution.Compat.NonEmptySet Distribution.Compat.ResponseFile Distribution.Compat.Prelude.Internal Distribution.Compat.Process - Distribution.Compat.Semigroup Distribution.Compat.Stack Distribution.Compat.Time - Distribution.Compat.Typeable - Distribution.Compat.DList - Distribution.Compiler - Distribution.InstalledPackageInfo - Distribution.Types.AbiDependency - Distribution.Types.ExposedModule - Distribution.Types.InstalledPackageInfo - Distribution.Types.InstalledPackageInfo.FieldGrammar - Distribution.License Distribution.Make - Distribution.ModuleName - Distribution.Package - Distribution.PackageDescription Distribution.PackageDescription.Check - Distribution.PackageDescription.Configuration - Distribution.PackageDescription.PrettyPrint - Distribution.PackageDescription.Utils Distribution.ReadE Distribution.Simple Distribution.Simple.Bench @@ -417,7 +101,6 @@ Distribution.Simple.GHC Distribution.Simple.GHCJS Distribution.Simple.Haddock - Distribution.Simple.Doctest Distribution.Simple.Glob Distribution.Simple.HaskellSuite Distribution.Simple.Hpc @@ -425,6 +108,7 @@ Distribution.Simple.InstallDirs Distribution.Simple.InstallDirs.Internal Distribution.Simple.LocalBuildInfo + Distribution.Simple.PackageDescription Distribution.Simple.PackageIndex Distribution.Simple.PreProcess Distribution.Simple.PreProcess.Unlit @@ -454,87 +138,162 @@ Distribution.Simple.UHC Distribution.Simple.UserHooks Distribution.Simple.Utils - Distribution.SPDX - Distribution.SPDX.License - Distribution.SPDX.LicenseId - Distribution.SPDX.LicenseExceptionId - Distribution.SPDX.LicenseExpression - Distribution.SPDX.LicenseListVersion - Distribution.SPDX.LicenseReference - Distribution.System Distribution.TestSuite - Distribution.Text - Distribution.Pretty - Distribution.Types.AbiHash Distribution.Types.AnnotatedId - Distribution.Types.Benchmark - Distribution.Types.BenchmarkInterface - Distribution.Types.BenchmarkType - Distribution.Types.BuildInfo - Distribution.Types.BuildType Distribution.Types.ComponentInclude - Distribution.Types.ConfVar - Distribution.Types.Dependency - Distribution.Types.ExeDependency - Distribution.Types.LegacyExeDependency - Distribution.Types.PkgconfigDependency - Distribution.Types.DependencyMap - Distribution.Types.ComponentId - Distribution.Types.MungedPackageId - Distribution.Types.PackageId - Distribution.Types.UnitId - Distribution.Types.Executable - Distribution.Types.ExecutableScope - Distribution.Types.Library - Distribution.Types.LibraryVisibility - Distribution.Types.Flag - Distribution.Types.ForeignLib - Distribution.Types.ForeignLibType - Distribution.Types.ForeignLibOption - Distribution.Types.Module - Distribution.Types.ModuleReexport - Distribution.Types.ModuleRenaming - Distribution.Types.ComponentName - Distribution.Types.LibraryName - Distribution.Types.MungedPackageName - Distribution.Types.PackageName + Distribution.Types.DumpBuildInfo Distribution.Types.PackageName.Magic - Distribution.Types.PkgconfigName - Distribution.Types.PkgconfigVersion - Distribution.Types.PkgconfigVersionRange - Distribution.Types.UnqualComponentName - Distribution.Types.IncludeRenaming - Distribution.Types.Mixin - Distribution.Types.SetupBuildInfo - Distribution.Types.TestSuite - Distribution.Types.TestSuiteInterface - Distribution.Types.TestType - Distribution.Types.GenericPackageDescription - Distribution.Types.Condition - Distribution.Types.CondTree - Distribution.Types.HookedBuildInfo - Distribution.Types.PackageDescription - Distribution.Types.SourceRepo - Distribution.Types.Component Distribution.Types.ComponentLocalBuildInfo Distribution.Types.LocalBuildInfo - Distribution.Types.ComponentRequestedSpec Distribution.Types.TargetInfo - Distribution.Types.Version - Distribution.Types.VersionRange - Distribution.Types.VersionRange.Internal - Distribution.Types.VersionInterval Distribution.Types.GivenComponent - Distribution.Types.PackageVersionConstraint - Distribution.Utils.Generic + Distribution.Utils.Json Distribution.Utils.NubList - Distribution.Utils.ShortText Distribution.Utils.Progress Distribution.Verbosity Distribution.Verbosity.Internal - Distribution.Version + + -- We reexport all of Cabal-syntax to aid in compatibility for downstream + -- users. In the future we may opt to deprecate some or all of these exports. + -- See haskell/Cabal#7974. + reexported-modules: + Distribution.Backpack, + Distribution.CabalSpecVersion, + Distribution.Compat.Binary, + Distribution.Compat.CharParsing, + Distribution.Compat.DList, + Distribution.Compat.Exception, + Distribution.Compat.Graph, + Distribution.Compat.Lens, + Distribution.Compat.MonadFail, + Distribution.Compat.Newtype, + Distribution.Compat.NonEmptySet, + Distribution.Compat.Parsing, + Distribution.Compat.Prelude, + Distribution.Compat.Semigroup, + Distribution.Compat.Typeable, + Distribution.Compiler, + Distribution.FieldGrammar, + Distribution.FieldGrammar.Class, + Distribution.FieldGrammar.FieldDescrs, + Distribution.FieldGrammar.Newtypes, + Distribution.FieldGrammar.Parsec, + Distribution.FieldGrammar.Pretty, + Distribution.Fields, + Distribution.Fields.ConfVar, + Distribution.Fields.Field, + Distribution.Fields.Lexer, + Distribution.Fields.LexerMonad, + Distribution.Fields.ParseResult, + Distribution.Fields.Parser, + Distribution.Fields.Pretty, + Distribution.InstalledPackageInfo, + Distribution.License, + Distribution.ModuleName, + Distribution.Package, + Distribution.PackageDescription, + Distribution.PackageDescription.Configuration, + Distribution.PackageDescription.FieldGrammar, + Distribution.PackageDescription.Parsec, + Distribution.PackageDescription.PrettyPrint, + Distribution.PackageDescription.Quirks, + Distribution.PackageDescription.Utils, + Distribution.Parsec, + Distribution.Parsec.Error, + Distribution.Parsec.FieldLineStream, + Distribution.Parsec.Position, + Distribution.Parsec.Warning, + Distribution.Pretty, + Distribution.SPDX, + Distribution.SPDX.License, + Distribution.SPDX.LicenseExceptionId, + Distribution.SPDX.LicenseExpression, + Distribution.SPDX.LicenseId, + Distribution.SPDX.LicenseListVersion, + Distribution.SPDX.LicenseReference, + Distribution.System, + Distribution.Text, + Distribution.Types.AbiDependency, + Distribution.Types.AbiHash, + Distribution.Types.Benchmark, + Distribution.Types.Benchmark.Lens, + Distribution.Types.BenchmarkInterface, + Distribution.Types.BenchmarkType, + Distribution.Types.BuildInfo, + Distribution.Types.BuildInfo.Lens, + Distribution.Types.BuildType, + Distribution.Types.Component, + Distribution.Types.ComponentId, + Distribution.Types.ComponentName, + Distribution.Types.ComponentRequestedSpec, + Distribution.Types.CondTree, + Distribution.Types.Condition, + Distribution.Types.ConfVar, + Distribution.Types.Dependency, + Distribution.Types.DependencyMap, + Distribution.Types.ExeDependency, + Distribution.Types.Executable, + Distribution.Types.Executable.Lens, + Distribution.Types.ExecutableScope, + Distribution.Types.ExposedModule, + Distribution.Types.Flag, + Distribution.Types.ForeignLib, + Distribution.Types.ForeignLib.Lens, + Distribution.Types.ForeignLibOption, + Distribution.Types.ForeignLibType, + Distribution.Types.GenericPackageDescription, + Distribution.Types.GenericPackageDescription.Lens, + Distribution.Types.HookedBuildInfo, + Distribution.Types.IncludeRenaming, + Distribution.Types.InstalledPackageInfo, + Distribution.Types.InstalledPackageInfo.Lens, + Distribution.Types.InstalledPackageInfo.FieldGrammar, + Distribution.Types.LegacyExeDependency, + Distribution.Types.Lens, + Distribution.Types.Library, + Distribution.Types.Library.Lens, + Distribution.Types.LibraryName, + Distribution.Types.LibraryVisibility, + Distribution.Types.Mixin, + Distribution.Types.Module, + Distribution.Types.ModuleReexport, + Distribution.Types.ModuleRenaming, + Distribution.Types.MungedPackageId, + Distribution.Types.MungedPackageName, + Distribution.Types.PackageDescription, + Distribution.Types.PackageDescription.Lens, + Distribution.Types.PackageId, + Distribution.Types.PackageId.Lens, + Distribution.Types.PackageName, + Distribution.Types.PackageVersionConstraint, + Distribution.Types.PkgconfigDependency, + Distribution.Types.PkgconfigName, + Distribution.Types.PkgconfigVersion, + Distribution.Types.PkgconfigVersionRange, + Distribution.Types.SetupBuildInfo, + Distribution.Types.SetupBuildInfo.Lens, + Distribution.Types.SourceRepo, + Distribution.Types.SourceRepo.Lens, + Distribution.Types.TestSuite, + Distribution.Types.TestSuite.Lens, + Distribution.Types.TestSuiteInterface, + Distribution.Types.TestType, + Distribution.Types.UnitId, + Distribution.Types.UnqualComponentName, + Distribution.Types.Version, + Distribution.Types.VersionInterval, + Distribution.Types.VersionInterval.Legacy, + Distribution.Types.VersionRange, + Distribution.Types.VersionRange.Internal, + Distribution.Utils.Base62, + Distribution.Utils.Generic, + Distribution.Utils.MD5, + Distribution.Utils.Path, + Distribution.Utils.ShortText, + Distribution.Utils.String, + Distribution.Utils.Structured, + Distribution.Version, Language.Haskell.Extension - Distribution.Compat.Binary -- Parsec parser-related modules build-depends: @@ -542,51 +301,9 @@ -- See also https://github.com/ekmett/transformers-compat/issues/35 transformers (>= 0.3 && < 0.4) || (>=0.4.1.0 && <0.6), mtl >= 2.1 && < 2.3, - text >= 1.2.3.0 && < 1.3, + text (>= 1.2.3.0 && < 1.3) || (>= 2.0 && < 2.1), parsec >= 3.1.13.0 && < 3.2 - exposed-modules: - Distribution.Compat.Parsing - Distribution.Compat.CharParsing - Distribution.FieldGrammar - Distribution.FieldGrammar.Class - Distribution.FieldGrammar.FieldDescrs - Distribution.FieldGrammar.Newtypes - Distribution.FieldGrammar.Parsec - Distribution.FieldGrammar.Pretty - Distribution.PackageDescription.FieldGrammar - Distribution.PackageDescription.Parsec - Distribution.PackageDescription.Quirks - Distribution.Parsec - Distribution.Parsec.Error - Distribution.Parsec.Position - Distribution.Parsec.Warning - Distribution.Parsec.FieldLineStream - Distribution.Fields - Distribution.Fields.ConfVar - Distribution.Fields.Field - Distribution.Fields.Lexer - Distribution.Fields.LexerMonad - Distribution.Fields.ParseResult - Distribution.Fields.Parser - Distribution.Fields.Pretty - -- Lens functionality - exposed-modules: - Distribution.Compat.Lens - Distribution.Types.Lens - Distribution.Types.Benchmark.Lens - Distribution.Types.BuildInfo.Lens - Distribution.Types.Executable.Lens - Distribution.Types.ForeignLib.Lens - Distribution.Types.GenericPackageDescription.Lens - Distribution.Types.InstalledPackageInfo.Lens - Distribution.Types.Library.Lens - Distribution.Types.PackageDescription.Lens - Distribution.Types.PackageId.Lens - Distribution.Types.SetupBuildInfo.Lens - Distribution.Types.SourceRepo.Lens - Distribution.Types.TestSuite.Lens - other-modules: Distribution.Backpack.PreExistingComponent Distribution.Backpack.ReadyComponent @@ -595,30 +312,20 @@ Distribution.Backpack.UnifyM Distribution.Backpack.Id Distribution.Utils.UnionFind - Distribution.Utils.Base62 Distribution.Compat.Async Distribution.Compat.CopyFile Distribution.Compat.GetShortPathName - Distribution.Compat.MonadFail - Distribution.Compat.Prelude Distribution.Compat.SnocList Distribution.GetOpt Distribution.Lex - Distribution.Utils.String Distribution.Simple.Build.Macros.Z + Distribution.Simple.Build.PathsModule.Z Distribution.Simple.GHC.EnvironmentParser Distribution.Simple.GHC.Internal Distribution.Simple.GHC.ImplInfo - Distribution.Simple.Utils.Json Distribution.ZinzaPrelude Paths_Cabal - if flag(bundled-binary-generic) - other-modules: - Distribution.Compat.Binary.Class - Distribution.Compat.Binary.Generic - - default-language: Haskell2010 other-extensions: BangPatterns CPP @@ -634,8 +341,10 @@ GeneralizedNewtypeDeriving ImplicitParams KindSignatures + LambdaCase NondecreasingIndentation OverloadedStrings + PatternSynonyms RankNTypes RecordWildCards ScopedTypeVariables @@ -645,208 +354,3 @@ TypeOperators TypeSynonymInstances UndecidableInstances - - if impl(ghc >= 7.11) - other-extensions: PatternSynonyms - --- Small, fast running tests. -test-suite unit-tests - type: exitcode-stdio-1.0 - hs-source-dirs: tests - other-modules: - Test.Laws - Test.QuickCheck.Utils - UnitTests.Distribution.CabalSpecVersion - UnitTests.Distribution.Compat.CreatePipe - UnitTests.Distribution.Compat.Graph - UnitTests.Distribution.Compat.Time - UnitTests.Distribution.Described - UnitTests.Distribution.Simple.Glob - UnitTests.Distribution.Simple.Program.GHC - UnitTests.Distribution.Simple.Program.Internal - UnitTests.Distribution.Simple.Utils - UnitTests.Distribution.SPDX - UnitTests.Distribution.System - UnitTests.Distribution.Types.GenericPackageDescription - UnitTests.Distribution.Utils.CharSet - UnitTests.Distribution.Utils.Generic - UnitTests.Distribution.Utils.NubList - UnitTests.Distribution.Utils.ShortText - UnitTests.Distribution.Utils.Structured - UnitTests.Distribution.Version - UnitTests.Distribution.PkgconfigVersion - UnitTests.Orphans - - -- Cabal-quickcheck - hs-source-dirs: Cabal-QuickCheck/src - other-modules: - Test.QuickCheck.GenericArbitrary - Test.QuickCheck.Instances.Cabal - - -- Cabal-described - hs-source-dirs: Cabal-described/src - other-modules: - Distribution.Described - Distribution.Utils.CharSet - Distribution.Utils.GrammarRegex - - main-is: UnitTests.hs - build-depends: - array, - async >= 2.2.2 && <2.3, - base, - binary, - bytestring, - containers, - deepseq, - directory, - filepath, - integer-logarithms >= 1.0.2 && <1.1, - pretty, - rere >=0.1 && <0.2, - tagged, - tasty >= 1.2.3 && < 1.4, - tasty-hunit, - tasty-quickcheck, - temporary, - text, - transformers, - Diff >=0.4 && <0.5, - QuickCheck >= 2.14 && < 2.15, - Cabal - ghc-options: -Wall - default-language: Haskell2010 - - if !impl(ghc >= 7.10) - build-depends: void - - if !impl(ghc >= 8.0) - build-depends: semigroups - -test-suite parser-tests - type: exitcode-stdio-1.0 - hs-source-dirs: tests - main-is: ParserTests.hs - build-depends: - base, - base-compat >=0.11.0 && <0.12, - bytestring, - directory, - filepath, - tasty >= 1.2.3 && < 1.4, - tasty-hunit, - tasty-quickcheck, - tasty-golden >=2.3.1.1 && <2.4, - Diff >=0.4 && <0.5, - Cabal - ghc-options: -Wall - default-language: Haskell2010 - - if !impl(ghc >= 8.0) - build-depends: semigroups - - if impl(ghc >= 7.8) - build-depends: - tree-diff >= 0.1 && <0.2 - hs-source-dirs: Cabal-tree-diff/src - other-modules: - Data.TreeDiff.Instances.Cabal - Data.TreeDiff.Instances.CabalLanguage - Data.TreeDiff.Instances.CabalSPDX - Data.TreeDiff.Instances.CabalVersion - -test-suite check-tests - type: exitcode-stdio-1.0 - hs-source-dirs: tests - main-is: CheckTests.hs - build-depends: - base, - bytestring, - directory, - filepath, - tasty >= 1.2.3 && < 1.4, - tasty-golden >=2.3.1.1 && <2.4, - Diff >=0.4 && <0.5, - Cabal - ghc-options: -Wall - default-language: Haskell2010 - if !impl(ghc >= 8.0) - build-depends: semigroups - -test-suite custom-setup-tests - type: exitcode-stdio-1.0 - hs-source-dirs: tests/custom-setup - main-is: CustomSetupTests.hs - other-modules: - CabalDoctestSetup - IdrisSetup - build-depends: - Cabal, - base, - directory, - filepath, - process - default-language: Haskell2010 - -test-suite hackage-tests - type: exitcode-stdio-1.0 - main-is: HackageTests.hs - - -- TODO: need to get 01-index.tar on appveyor - if os(windows) - buildable: False - - hs-source-dirs: tests - - build-depends: - base, - Cabal, - bytestring, - deepseq, - containers, - directory, - filepath - - build-depends: - base-compat >=0.11.0 && <0.12, - base-orphans >=0.6 && <0.9, - clock >=0.8 && <0.9, - optparse-applicative >=0.13.2.0 && <0.16, - stm >=2.4.5.0 && <2.6, - tar >=0.5.0.3 && <0.6 - - if impl(ghc >= 7.8) - build-depends: - tree-diff >= 0.1 && <0.2 - hs-source-dirs: Cabal-tree-diff/src - other-modules: - Data.TreeDiff.Instances.Cabal - Data.TreeDiff.Instances.CabalLanguage - Data.TreeDiff.Instances.CabalSPDX - Data.TreeDiff.Instances.CabalVersion - - ghc-options: -Wall -rtsopts -threaded - default-extensions: CPP - default-language: Haskell2010 - -test-suite rpmvercmp - type: exitcode-stdio-1.0 - main-is: RPMVerCmp.hs - - hs-source-dirs: tests - build-depends: - base, - Cabal, - bytestring - - build-depends: - tasty >= 1.2.3 && < 1.4, - tasty-hunit, - tasty-quickcheck, - QuickCheck - - c-sources: tests/cbits/rpmvercmp.c - cc-options: -Wall - - ghc-options: -Wall - default-language: Haskell2010 diff --git a/cabal/Cabal/ChangeLog.md b/cabal/Cabal/ChangeLog.md --- a/cabal/Cabal/ChangeLog.md +++ b/cabal/Cabal/ChangeLog.md @@ -1,3 +1,32 @@ +# 3.8.1.0 [Mikolaj Konarski](mailto:mikolaj@well-typed.com) August 2022 + * See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.8.1.0.md + +# 3.6.3.0 March 2022 + * See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.6.3.0.md + +# 3.6.2.0 [Emily Pillmore](mailto:emilypi@cohomolo.gy) October 2021 + * See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.6.2.0.md + +# 3.6.1.0 [Emily Pillmore](mailto:emilypi@cohomolo.gy) August 2021 + * See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.6.1.0.md + +# 3.6.0.0 [Emily Pillmore](mailto:emilypi@cohomolo.gy) August 2021 + * See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.6.0.0.md + +# 3.4.1.0 [Emily Pillmore](mailto:emilypi@cohomolo.gy) October 2021 + * See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.4.1.0.md + +# 3.4.0.0 [Oleg Grenrus](mailto:oleg.grnerus@iki.fi) February 2021 + * See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.4.0.0.md + +# 3.2.1.0 [Oleg Grenrus](mailto:oleg.grenris@iki.fi) October 2020 + * Pass `cxx-options` with `-optcxx` for GHC >= 8.10 + * Use process jobs when calling subprocesses + * Require custom-setup for `cabal-version: 1.24` and later + * Accept `linux-androideabi` as an alias for Android + * Fix ghci being launched before other sources are built + * Require cabal-versions >=1.25 to be exact + # 3.2.0.0 [Herbert Valerio Riedel](mailto:hvr@gnu.org) April 2020 * Change free text `String` fields to use `ShortText` in package description and installed package info. diff --git a/cabal/Cabal/Distribution/Backpack.hs b/cabal/Cabal/Distribution/Backpack.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Backpack.hs +++ /dev/null @@ -1,269 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE RankNTypes #-} - --- | This module defines the core data types for Backpack. For more --- details, see: --- --- - -module Distribution.Backpack ( - -- * OpenUnitId - OpenUnitId(..), - openUnitIdFreeHoles, - mkOpenUnitId, - - -- * DefUnitId - DefUnitId, - unDefUnitId, - mkDefUnitId, - - -- * OpenModule - OpenModule(..), - openModuleFreeHoles, - - -- * OpenModuleSubst - OpenModuleSubst, - dispOpenModuleSubst, - dispOpenModuleSubstEntry, - parsecOpenModuleSubst, - parsecOpenModuleSubstEntry, - openModuleSubstFreeHoles, - - -- * Conversions to 'UnitId' - abstractUnitId, - hashModuleSubst, -) where - -import Distribution.Compat.Prelude hiding (mod) -import Distribution.Parsec -import Distribution.Pretty -import Prelude () -import Text.PrettyPrint (hcat) - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - -import Distribution.ModuleName -import Distribution.Types.ComponentId -import Distribution.Types.Module -import Distribution.Types.UnitId -import Distribution.Utils.Base62 - -import qualified Data.Map as Map -import qualified Data.Set as Set - ------------------------------------------------------------------------ --- OpenUnitId - --- | An 'OpenUnitId' describes a (possibly partially) instantiated --- Backpack component, with a description of how the holes are filled --- in. Unlike 'OpenUnitId', the 'ModuleSubst' is kept in a structured --- form that allows for substitution (which fills in holes.) This form --- of unit cannot be installed. It must first be converted to a --- 'UnitId'. --- --- In the absence of Backpack, there are no holes to fill, so any such --- component always has an empty module substitution; thus we can lossly --- represent it as an 'OpenUnitId uid'. --- --- For a source component using Backpack, however, there is more --- structure as components may be parametrized over some signatures, and --- these \"holes\" may be partially or wholly filled. --- --- OpenUnitId plays an important role when we are mix-in linking, --- and is recorded to the installed packaged database for indefinite --- packages; however, for compiled packages that are fully instantiated, --- we instantiate 'OpenUnitId' into 'UnitId'. --- --- For more details see the Backpack spec --- --- - -data OpenUnitId - -- | Identifies a component which may have some unfilled holes; - -- specifying its 'ComponentId' and its 'OpenModuleSubst'. - -- TODO: Invariant that 'OpenModuleSubst' is non-empty? - -- See also the Text instance. - = IndefFullUnitId ComponentId OpenModuleSubst - -- | Identifies a fully instantiated component, which has - -- been compiled and abbreviated as a hash. The embedded 'UnitId' - -- MUST NOT be for an indefinite component; an 'OpenUnitId' - -- is guaranteed not to have any holes. - | DefiniteUnitId DefUnitId - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) --- TODO: cache holes? - -instance Binary OpenUnitId -instance Structured OpenUnitId -instance NFData OpenUnitId where - rnf (IndefFullUnitId cid subst) = rnf cid `seq` rnf subst - rnf (DefiniteUnitId uid) = rnf uid - -instance Pretty OpenUnitId where - pretty (IndefFullUnitId cid insts) - -- TODO: arguably a smart constructor to enforce invariant would be - -- better - | Map.null insts = pretty cid - | otherwise = pretty cid <<>> Disp.brackets (dispOpenModuleSubst insts) - pretty (DefiniteUnitId uid) = pretty uid - --- | --- --- >>> eitherParsec "foobar" :: Either String OpenUnitId ---Right (DefiniteUnitId (DefUnitId {unDefUnitId = UnitId "foobar"})) --- --- >>> eitherParsec "foo[Str=text-1.2.3:Data.Text.Text]" :: Either String OpenUnitId --- Right (IndefFullUnitId (ComponentId "foo") (fromList [(ModuleName "Str",OpenModule (DefiniteUnitId (DefUnitId {unDefUnitId = UnitId "text-1.2.3"})) (ModuleName "Data.Text.Text"))])) --- -instance Parsec OpenUnitId where - parsec = P.try parseOpenUnitId <|> fmap DefiniteUnitId parsec - where - parseOpenUnitId = do - cid <- parsec - insts <- P.between (P.char '[') (P.char ']') - parsecOpenModuleSubst - return (IndefFullUnitId cid insts) - --- | Get the set of holes ('ModuleVar') embedded in a 'UnitId'. -openUnitIdFreeHoles :: OpenUnitId -> Set ModuleName -openUnitIdFreeHoles (IndefFullUnitId _ insts) = openModuleSubstFreeHoles insts -openUnitIdFreeHoles _ = Set.empty - --- | Safe constructor from a UnitId. The only way to do this safely --- is if the instantiation is provided. -mkOpenUnitId :: UnitId -> ComponentId -> OpenModuleSubst -> OpenUnitId -mkOpenUnitId uid cid insts = - if Set.null (openModuleSubstFreeHoles insts) - then DefiniteUnitId (unsafeMkDefUnitId uid) -- invariant holds! - else IndefFullUnitId cid insts - ------------------------------------------------------------------------ --- DefUnitId - --- | Create a 'DefUnitId' from a 'ComponentId' and an instantiation --- with no holes. -mkDefUnitId :: ComponentId -> Map ModuleName Module -> DefUnitId -mkDefUnitId cid insts = - unsafeMkDefUnitId (mkUnitId - (unComponentId cid ++ maybe "" ("+"++) (hashModuleSubst insts))) - -- impose invariant! - ------------------------------------------------------------------------ --- OpenModule - --- | Unlike a 'Module', an 'OpenModule' is either an ordinary --- module from some unit, OR an 'OpenModuleVar', representing a --- hole that needs to be filled in. Substitutions are over --- module variables. -data OpenModule - = OpenModule OpenUnitId ModuleName - | OpenModuleVar ModuleName - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) - -instance Binary OpenModule -instance Structured OpenModule - -instance NFData OpenModule where - rnf (OpenModule uid mod_name) = rnf uid `seq` rnf mod_name - rnf (OpenModuleVar mod_name) = rnf mod_name - -instance Pretty OpenModule where - pretty (OpenModule uid mod_name) = - hcat [pretty uid, Disp.text ":", pretty mod_name] - pretty (OpenModuleVar mod_name) = - hcat [Disp.char '<', pretty mod_name, Disp.char '>'] - --- | --- --- >>> eitherParsec "Includes2-0.1.0.0-inplace-mysql:Database.MySQL" :: Either String OpenModule --- Right (OpenModule (DefiniteUnitId (DefUnitId {unDefUnitId = UnitId "Includes2-0.1.0.0-inplace-mysql"})) (ModuleName "Database.MySQL")) --- -instance Parsec OpenModule where - parsec = parsecModuleVar <|> parsecOpenModule - where - parsecOpenModule = do - uid <- parsec - _ <- P.char ':' - mod_name <- parsec - return (OpenModule uid mod_name) - - parsecModuleVar = do - _ <- P.char '<' - mod_name <- parsec - _ <- P.char '>' - return (OpenModuleVar mod_name) - --- | Get the set of holes ('ModuleVar') embedded in a 'Module'. -openModuleFreeHoles :: OpenModule -> Set ModuleName -openModuleFreeHoles (OpenModuleVar mod_name) = Set.singleton mod_name -openModuleFreeHoles (OpenModule uid _n) = openUnitIdFreeHoles uid - ------------------------------------------------------------------------ --- OpenModuleSubst - --- | An explicit substitution on modules. --- --- NB: These substitutions are NOT idempotent, for example, a --- valid substitution is (A -> B, B -> A). -type OpenModuleSubst = Map ModuleName OpenModule - --- | Pretty-print the entries of a module substitution, suitable --- for embedding into a 'OpenUnitId' or passing to GHC via @--instantiate-with@. -dispOpenModuleSubst :: OpenModuleSubst -> Disp.Doc -dispOpenModuleSubst subst - = Disp.hcat - . Disp.punctuate Disp.comma - $ map dispOpenModuleSubstEntry (Map.toAscList subst) - --- | Pretty-print a single entry of a module substitution. -dispOpenModuleSubstEntry :: (ModuleName, OpenModule) -> Disp.Doc -dispOpenModuleSubstEntry (k, v) = pretty k <<>> Disp.char '=' <<>> pretty v - --- | Inverse to 'dispModSubst'. --- --- @since 2.2 -parsecOpenModuleSubst :: CabalParsing m => m OpenModuleSubst -parsecOpenModuleSubst = fmap Map.fromList - . flip P.sepBy (P.char ',') - $ parsecOpenModuleSubstEntry - --- | Inverse to 'dispModSubstEntry'. --- --- @since 2.2 -parsecOpenModuleSubstEntry :: CabalParsing m => m (ModuleName, OpenModule) -parsecOpenModuleSubstEntry = - do k <- parsec - _ <- P.char '=' - v <- parsec - return (k, v) - --- | Get the set of holes ('ModuleVar') embedded in a 'OpenModuleSubst'. --- This is NOT the domain of the substitution. -openModuleSubstFreeHoles :: OpenModuleSubst -> Set ModuleName -openModuleSubstFreeHoles insts = Set.unions (map openModuleFreeHoles (Map.elems insts)) - ------------------------------------------------------------------------ --- Conversions to UnitId - --- | When typechecking, we don't demand that a freshly instantiated --- 'IndefFullUnitId' be compiled; instead, we just depend on the --- installed indefinite unit installed at the 'ComponentId'. -abstractUnitId :: OpenUnitId -> UnitId -abstractUnitId (DefiniteUnitId def_uid) = unDefUnitId def_uid -abstractUnitId (IndefFullUnitId cid _) = newSimpleUnitId cid - --- | Take a module substitution and hash it into a string suitable for --- 'UnitId'. Note that since this takes 'Module', not 'OpenModule', --- you are responsible for recursively converting 'OpenModule' --- into 'Module'. See also "Distribution.Backpack.ReadyComponent". -hashModuleSubst :: Map ModuleName Module -> Maybe String -hashModuleSubst subst - | Map.null subst = Nothing - | otherwise = - Just . hashToBase62 $ - concat [ prettyShow mod_name ++ "=" ++ prettyShow m ++ "\n" - | (mod_name, m) <- Map.toList subst] diff --git a/cabal/Cabal/Distribution/Backpack/ComponentsGraph.hs b/cabal/Cabal/Distribution/Backpack/ComponentsGraph.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Backpack/ComponentsGraph.hs +++ /dev/null @@ -1,97 +0,0 @@ --- | See -module Distribution.Backpack.ComponentsGraph ( - ComponentsGraph, - ComponentsWithDeps, - mkComponentsGraph, - componentsGraphToList, - dispComponentsWithDeps, - componentCycleMsg -) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Package -import Distribution.PackageDescription -import Distribution.Simple.BuildToolDepends -import Distribution.Simple.LocalBuildInfo -import Distribution.Types.ComponentRequestedSpec -import Distribution.Compat.Graph (Graph, Node(..)) -import qualified Distribution.Compat.Graph as Graph -import qualified Distribution.Compat.NonEmptySet as NES -import Distribution.Utils.Generic - -import Distribution.Pretty (pretty) -import Text.PrettyPrint - ------------------------------------------------------------------------------- --- Components graph ------------------------------------------------------------------------------- - --- | A graph of source-level components by their source-level --- dependencies --- -type ComponentsGraph = Graph (Node ComponentName Component) - --- | A list of components associated with the source level --- dependencies between them. --- -type ComponentsWithDeps = [(Component, [ComponentName])] - --- | Pretty-print 'ComponentsWithDeps'. --- -dispComponentsWithDeps :: ComponentsWithDeps -> Doc -dispComponentsWithDeps graph = - vcat [ hang (text "component" <+> pretty (componentName c)) 4 - (vcat [ text "dependency" <+> pretty cdep | cdep <- cdeps ]) - | (c, cdeps) <- graph ] - --- | Create a 'Graph' of 'Component', or report a cycle if there is a --- problem. --- -mkComponentsGraph :: ComponentRequestedSpec - -> PackageDescription - -> Either [ComponentName] ComponentsGraph -mkComponentsGraph enabled pkg_descr = - let g = Graph.fromDistinctList - [ N c (componentName c) (componentDeps c) - | c <- pkgBuildableComponents pkg_descr - , componentEnabled enabled c ] - in case Graph.cycles g of - [] -> Right g - ccycles -> Left [ componentName c | N c _ _ <- concat ccycles ] - where - -- The dependencies for the given component - componentDeps component = - toolDependencies ++ libDependencies - where - bi = componentBuildInfo component - - toolDependencies = CExeName <$> getAllInternalToolDependencies pkg_descr bi - - libDependencies = do - Dependency pkgname _ lns <- targetBuildDepends bi - guard (pkgname == packageName pkg_descr) - - ln <- NES.toList lns - return (CLibName ln) - --- | Given the package description and a 'PackageDescription' (used --- to determine if a package name is internal or not), sort the --- components in dependency order (fewest dependencies first). This is --- NOT necessarily the build order (although it is in the absence of --- Backpack.) --- -componentsGraphToList :: ComponentsGraph - -> ComponentsWithDeps -componentsGraphToList = - map (\(N c _ cs) -> (c, cs)) . Graph.revTopSort - --- | Error message when there is a cycle; takes the SCC of components. -componentCycleMsg :: PackageIdentifier -> [ComponentName] -> Doc -componentCycleMsg pn cnames = - text "Components in the package" <+> pretty pn <+> text "depend on each other in a cyclic way:" - $$ - text (intercalate " depends on " - [ "'" ++ showComponentName cname ++ "'" - | cname <- cnames ++ maybeToList (safeHead cnames) ]) diff --git a/cabal/Cabal/Distribution/Backpack/Configure.hs b/cabal/Cabal/Distribution/Backpack/Configure.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Backpack/Configure.hs +++ /dev/null @@ -1,359 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE NoMonoLocalBinds #-} -{-# LANGUAGE NondecreasingIndentation #-} - --- | See --- --- WARNING: The contents of this module are HIGHLY experimental. --- We may refactor it under you. -module Distribution.Backpack.Configure ( - configureComponentLocalBuildInfos, -) where - -import Prelude () -import Distribution.Compat.Prelude hiding ((<>)) - -import Distribution.Backpack -import Distribution.Backpack.FullUnitId -import Distribution.Backpack.PreExistingComponent -import Distribution.Backpack.ConfiguredComponent -import Distribution.Backpack.LinkedComponent -import Distribution.Backpack.ReadyComponent -import Distribution.Backpack.ComponentsGraph -import Distribution.Backpack.Id - -import Distribution.Simple.Compiler -import Distribution.Package -import qualified Distribution.InstalledPackageInfo as Installed -import Distribution.InstalledPackageInfo (InstalledPackageInfo - ,emptyInstalledPackageInfo) -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.PackageIndex (InstalledPackageIndex) -import Distribution.PackageDescription -import Distribution.ModuleName -import Distribution.Simple.Setup as Setup -import Distribution.Simple.LocalBuildInfo -import Distribution.Types.AnnotatedId -import Distribution.Types.ComponentRequestedSpec -import Distribution.Types.ComponentInclude -import Distribution.Types.MungedPackageName -import Distribution.Verbosity -import qualified Distribution.Compat.Graph as Graph -import Distribution.Compat.Graph (Graph, IsNode(..)) -import Distribution.Utils.LogProgress - -import Data.Either - ( lefts ) -import qualified Data.Set as Set -import qualified Data.Map as Map -import Distribution.Pretty -import Text.PrettyPrint - ------------------------------------------------------------------------------- --- Pipeline ------------------------------------------------------------------------------- - -configureComponentLocalBuildInfos - :: Verbosity - -> Bool -- use_external_internal_deps - -> ComponentRequestedSpec - -> Bool -- deterministic - -> Flag String -- configIPID - -> Flag ComponentId -- configCID - -> PackageDescription - -> [PreExistingComponent] - -> FlagAssignment -- configConfigurationsFlags - -> [(ModuleName, Module)] -- configInstantiateWith - -> InstalledPackageIndex - -> Compiler - -> LogProgress ([ComponentLocalBuildInfo], InstalledPackageIndex) -configureComponentLocalBuildInfos - verbosity use_external_internal_deps enabled deterministic ipid_flag cid_flag pkg_descr - prePkgDeps flagAssignment instantiate_with installedPackageSet comp = do - -- NB: In single component mode, this returns a *single* component. - -- In this graph, the graph is NOT closed. - graph0 <- case mkComponentsGraph enabled pkg_descr of - Left ccycle -> dieProgress (componentCycleMsg (package pkg_descr) ccycle) - Right g -> return (componentsGraphToList g) - infoProgress $ hang (text "Source component graph:") 4 - (dispComponentsWithDeps graph0) - - let conf_pkg_map = Map.fromListWith Map.union - [(pc_pkgname pkg, - Map.singleton (pc_compname pkg) - (AnnotatedId { - ann_id = pc_cid pkg, - ann_pid = packageId pkg, - ann_cname = pc_compname pkg - })) - | pkg <- prePkgDeps] - graph1 <- toConfiguredComponents use_external_internal_deps - flagAssignment - deterministic ipid_flag cid_flag pkg_descr - conf_pkg_map (map fst graph0) - infoProgress $ hang (text "Configured component graph:") 4 - (vcat (map dispConfiguredComponent graph1)) - - let shape_pkg_map = Map.fromList - [ (pc_cid pkg, (pc_open_uid pkg, pc_shape pkg)) - | pkg <- prePkgDeps] - uid_lookup def_uid - | Just pkg <- PackageIndex.lookupUnitId installedPackageSet uid - = FullUnitId (Installed.installedComponentId pkg) - (Map.fromList (Installed.instantiatedWith pkg)) - | otherwise = error ("uid_lookup: " ++ prettyShow uid) - where uid = unDefUnitId def_uid - graph2 <- toLinkedComponents verbosity uid_lookup - (package pkg_descr) shape_pkg_map graph1 - - infoProgress $ - hang (text "Linked component graph:") 4 - (vcat (map dispLinkedComponent graph2)) - - let pid_map = Map.fromList $ - [ (pc_uid pkg, pc_munged_id pkg) - | pkg <- prePkgDeps] ++ - [ (Installed.installedUnitId pkg, mungedId pkg) - | (_, Module uid _) <- instantiate_with - , Just pkg <- [PackageIndex.lookupUnitId - installedPackageSet (unDefUnitId uid)] ] - subst = Map.fromList instantiate_with - graph3 = toReadyComponents pid_map subst graph2 - graph4 = Graph.revTopSort (Graph.fromDistinctList graph3) - - infoProgress $ hang (text "Ready component graph:") 4 - (vcat (map dispReadyComponent graph4)) - - toComponentLocalBuildInfos comp installedPackageSet pkg_descr prePkgDeps graph4 - ------------------------------------------------------------------------------- --- ComponentLocalBuildInfo ------------------------------------------------------------------------------- - -toComponentLocalBuildInfos - :: Compiler - -> InstalledPackageIndex -- FULL set - -> PackageDescription - -> [PreExistingComponent] -- external package deps - -> [ReadyComponent] - -> LogProgress ([ComponentLocalBuildInfo], - InstalledPackageIndex) -- only relevant packages -toComponentLocalBuildInfos - comp installedPackageSet pkg_descr externalPkgDeps graph = do - -- Check and make sure that every instantiated component exists. - -- We have to do this now, because prior to linking/instantiating - -- we don't actually know what the full set of 'UnitId's we need - -- are. - let -- TODO: This is actually a bit questionable performance-wise, - -- since we will pay for the ALL installed packages even if - -- they are not related to what we are building. This was true - -- in the old configure code. - external_graph :: Graph (Either InstalledPackageInfo ReadyComponent) - external_graph = Graph.fromDistinctList - . map Left - $ PackageIndex.allPackages installedPackageSet - internal_graph :: Graph (Either InstalledPackageInfo ReadyComponent) - internal_graph = Graph.fromDistinctList - . map Right - $ graph - combined_graph = Graph.unionRight external_graph internal_graph - local_graph = fromMaybe (error "toComponentLocalBuildInfos: closure returned Nothing") - $ Graph.closure combined_graph (map nodeKey graph) - -- The database of transitively reachable installed packages that the - -- external components the package (as a whole) depends on. This will be - -- used in several ways: - -- - -- * We'll use it to do a consistency check so we're not depending - -- on multiple versions of the same package (TODO: someday relax - -- this for private dependencies.) See right below. - -- - -- * We'll pass it on in the LocalBuildInfo, where preprocessors - -- and other things will incorrectly use it to determine what - -- the include paths and everything should be. - -- - packageDependsIndex = PackageIndex.fromList (lefts local_graph) - fullIndex = Graph.fromDistinctList local_graph - case Graph.broken fullIndex of - [] -> return () - broken -> - -- TODO: ppr this - dieProgress . text $ - "The following packages are broken because other" - ++ " packages they depend on are missing. These broken " - ++ "packages must be rebuilt before they can be used.\n" - -- TODO: Undupe. - ++ unlines [ "installed package " - ++ prettyShow (packageId pkg) - ++ " is broken due to missing package " - ++ intercalate ", " (map prettyShow deps) - | (Left pkg, deps) <- broken ] - ++ unlines [ "planned package " - ++ prettyShow (packageId pkg) - ++ " is broken due to missing package " - ++ intercalate ", " (map prettyShow deps) - | (Right pkg, deps) <- broken ] - - -- In this section, we'd like to look at the 'packageDependsIndex' - -- and see if we've picked multiple versions of the same - -- installed package (this is bad, because it means you might - -- get an error could not match foo-0.1:Type with foo-0.2:Type). - -- - -- What is pseudoTopPkg for? I have no idea. It was used - -- in the very original commit which introduced checking for - -- inconsistencies 5115bb2be4e13841ea07dc9166b9d9afa5f0d012, - -- and then moved out of PackageIndex and put here later. - -- TODO: Try this code without it... - -- - -- TODO: Move this into a helper function - -- - -- TODO: This is probably wrong for Backpack - let pseudoTopPkg :: InstalledPackageInfo - pseudoTopPkg = emptyInstalledPackageInfo { - Installed.installedUnitId = mkLegacyUnitId (packageId pkg_descr), - Installed.sourcePackageId = packageId pkg_descr, - Installed.depends = map pc_uid externalPkgDeps - } - case PackageIndex.dependencyInconsistencies - . PackageIndex.insert pseudoTopPkg - $ packageDependsIndex of - [] -> return () - inconsistencies -> - warnProgress $ - hang (text "This package indirectly depends on multiple versions of the same" <+> - text "package. This is very likely to cause a compile failure.") 2 - (vcat [ text "package" <+> pretty (packageName user) <+> - parens (pretty (installedUnitId user)) <+> text "requires" <+> - pretty inst - | (_dep_key, insts) <- inconsistencies - , (inst, users) <- insts - , user <- users ]) - let clbis = mkLinkedComponentsLocalBuildInfo comp graph - -- forM clbis $ \(clbi,deps) -> info verbosity $ "UNIT" ++ hashUnitId (componentUnitId clbi) ++ "\n" ++ intercalate "\n" (map hashUnitId deps) - return (clbis, packageDependsIndex) - --- Build ComponentLocalBuildInfo for each component we are going --- to build. --- --- This conversion is lossy; we lose some invariants from ReadyComponent -mkLinkedComponentsLocalBuildInfo - :: Compiler - -> [ReadyComponent] - -> [ComponentLocalBuildInfo] -mkLinkedComponentsLocalBuildInfo comp rcs = map go rcs - where - internalUnits = Set.fromList (map rc_uid rcs) - isInternal x = Set.member x internalUnits - go rc = - case rc_component rc of - CLib lib -> - let convModuleExport (modname', (Module uid modname)) - | this_uid == unDefUnitId uid - , modname' == modname - = Installed.ExposedModule modname' Nothing - | otherwise - = Installed.ExposedModule modname' - (Just (OpenModule (DefiniteUnitId uid) modname)) - convOpenModuleExport (modname', modu@(OpenModule uid modname)) - | uid == this_open_uid - , modname' == modname - = Installed.ExposedModule modname' Nothing - | otherwise - = Installed.ExposedModule modname' (Just modu) - convOpenModuleExport (_, OpenModuleVar _) - = error "convOpenModuleExport: top-level modvar" - exports = - -- Loses invariants - case rc_i rc of - Left indefc -> map convOpenModuleExport - $ Map.toList (indefc_provides indefc) - Right instc -> map convModuleExport - $ Map.toList (instc_provides instc) - insts = - case rc_i rc of - Left indefc -> [ (m, OpenModuleVar m) | m <- indefc_requires indefc ] - Right instc -> [ (m, OpenModule (DefiniteUnitId uid') m') - | (m, Module uid' m') <- instc_insts instc ] - - compat_name = MungedPackageName (packageName rc) (libName lib) - compat_key = computeCompatPackageKey comp compat_name (packageVersion rc) this_uid - - in LibComponentLocalBuildInfo { - componentPackageDeps = cpds, - componentUnitId = this_uid, - componentComponentId = this_cid, - componentInstantiatedWith = insts, - componentIsIndefinite_ = is_indefinite, - componentLocalName = cname, - componentInternalDeps = internal_deps, - componentExeDeps = exe_deps, - componentIncludes = includes, - componentExposedModules = exports, - componentIsPublic = rc_public rc, - componentCompatPackageKey = compat_key, - componentCompatPackageName = compat_name - } - CFLib _ -> - FLibComponentLocalBuildInfo { - componentUnitId = this_uid, - componentComponentId = this_cid, - componentLocalName = cname, - componentPackageDeps = cpds, - componentExeDeps = exe_deps, - componentInternalDeps = internal_deps, - componentIncludes = includes - } - CExe _ -> - ExeComponentLocalBuildInfo { - componentUnitId = this_uid, - componentComponentId = this_cid, - componentLocalName = cname, - componentPackageDeps = cpds, - componentExeDeps = exe_deps, - componentInternalDeps = internal_deps, - componentIncludes = includes - } - CTest _ -> - TestComponentLocalBuildInfo { - componentUnitId = this_uid, - componentComponentId = this_cid, - componentLocalName = cname, - componentPackageDeps = cpds, - componentExeDeps = exe_deps, - componentInternalDeps = internal_deps, - componentIncludes = includes - } - CBench _ -> - BenchComponentLocalBuildInfo { - componentUnitId = this_uid, - componentComponentId = this_cid, - componentLocalName = cname, - componentPackageDeps = cpds, - componentExeDeps = exe_deps, - componentInternalDeps = internal_deps, - componentIncludes = includes - } - where - this_uid = rc_uid rc - this_open_uid = rc_open_uid rc - this_cid = rc_cid rc - cname = componentName (rc_component rc) - cpds = rc_depends rc - exe_deps = map ann_id $ rc_exe_deps rc - is_indefinite = - case rc_i rc of - Left _ -> True - Right _ -> False - includes = - map (\ci -> (ci_id ci, ci_renaming ci)) $ - case rc_i rc of - Left indefc -> - indefc_includes indefc - Right instc -> - map (\ci -> ci { ci_ann_id = fmap DefiniteUnitId (ci_ann_id ci) }) - (instc_includes instc) - internal_deps = filter isInternal (nodeNeighbors rc) diff --git a/cabal/Cabal/Distribution/Backpack/ConfiguredComponent.hs b/cabal/Cabal/Distribution/Backpack/ConfiguredComponent.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Backpack/ConfiguredComponent.hs +++ /dev/null @@ -1,308 +0,0 @@ -{-# LANGUAGE PatternGuards #-} --- | See -module Distribution.Backpack.ConfiguredComponent ( - ConfiguredComponent(..), - cc_name, - cc_cid, - cc_pkgid, - toConfiguredComponent, - toConfiguredComponents, - dispConfiguredComponent, - - ConfiguredComponentMap, - extendConfiguredComponentMap, - - -- TODO: Should go somewhere else - newPackageDepsBehaviour -) where - -import Prelude () -import Distribution.Compat.Prelude hiding ((<>)) - -import Distribution.Backpack.Id - -import Distribution.CabalSpecVersion -import Distribution.Types.AnnotatedId -import Distribution.Types.Dependency -import Distribution.Types.ExeDependency -import Distribution.Types.IncludeRenaming -import Distribution.Types.ComponentId -import Distribution.Types.PackageId -import Distribution.Types.PackageName -import Distribution.Types.Mixin -import Distribution.Types.ComponentName -import Distribution.Types.LibraryName -import Distribution.Types.ComponentInclude -import Distribution.Package -import Distribution.PackageDescription -import Distribution.Simple.BuildToolDepends -import Distribution.Simple.Setup as Setup -import Distribution.Simple.LocalBuildInfo -import Distribution.Utils.LogProgress -import Distribution.Utils.MapAccum -import Distribution.Utils.Generic - -import Control.Monad -import qualified Data.Set as Set -import qualified Distribution.Compat.NonEmptySet as NonEmptySet -import qualified Data.Map as Map -import Distribution.Pretty -import Text.PrettyPrint (Doc, hang, text, vcat, hsep, quotes, ($$)) -import qualified Text.PrettyPrint as PP - --- | A configured component, we know exactly what its 'ComponentId' is, --- and the 'ComponentId's of the things it depends on. -data ConfiguredComponent - = ConfiguredComponent { - -- | Unique identifier of component, plus extra useful info. - cc_ann_id :: AnnotatedId ComponentId, - -- | The fragment of syntax from the Cabal file describing this - -- component. - cc_component :: Component, - -- | Is this the public library component of the package? - -- (If we invoke Setup with an instantiation, this is the - -- component the instantiation applies to.) - -- Note that in one-component configure mode, this is - -- always True, because any component is the "public" one.) - cc_public :: Bool, - -- | Dependencies on executables from @build-tools@ and - -- @build-tool-depends@. - cc_exe_deps :: [AnnotatedId ComponentId], - -- | The mixins of this package, including both explicit (from - -- the @mixins@ field) and implicit (from @build-depends@). Not - -- mix-in linked yet; component configuration only looks at - -- 'ComponentId's. - cc_includes :: [ComponentInclude ComponentId IncludeRenaming] - } - - --- | Uniquely identifies a configured component. -cc_cid :: ConfiguredComponent -> ComponentId -cc_cid = ann_id . cc_ann_id - --- | The package this component came from. -cc_pkgid :: ConfiguredComponent -> PackageId -cc_pkgid = ann_pid . cc_ann_id - --- | The 'ComponentName' of a component; this uniquely identifies --- a fragment of syntax within a specified Cabal file describing the --- component. -cc_name :: ConfiguredComponent -> ComponentName -cc_name = ann_cname . cc_ann_id - --- | Pretty-print a 'ConfiguredComponent'. -dispConfiguredComponent :: ConfiguredComponent -> Doc -dispConfiguredComponent cc = - hang (text "component" <+> pretty (cc_cid cc)) 4 - (vcat [ hsep $ [ text "include" - , pretty (ci_id incl), pretty (ci_renaming incl) ] - | incl <- cc_includes cc - ]) - --- | Construct a 'ConfiguredComponent', given that the 'ComponentId' --- and library/executable dependencies are known. The primary --- work this does is handling implicit @backpack-include@ fields. -mkConfiguredComponent - :: PackageDescription - -> ComponentId - -> [AnnotatedId ComponentId] -- lib deps - -> [AnnotatedId ComponentId] -- exe deps - -> Component - -> LogProgress ConfiguredComponent -mkConfiguredComponent pkg_descr this_cid lib_deps exe_deps component = do - -- Resolve each @mixins@ into the actual dependency - -- from @lib_deps@. - explicit_includes <- forM (mixins bi) $ \(Mixin pn ln rns) -> do - aid <- case Map.lookup (pn, CLibName ln) deps_map of - Nothing -> - dieProgress $ - text "Mix-in refers to non-existent library" <+> - quotes (pretty pn <<>> prettyLN ln) $$ - text "(did you forget to add the package to build-depends?)" - Just r -> return r - return ComponentInclude { - ci_ann_id = aid, - ci_renaming = rns, - ci_implicit = False - } - - -- Any @build-depends@ which is not explicitly mentioned in - -- @backpack-include@ is converted into an "implicit" include. - let used_explicitly = Set.fromList (map ci_id explicit_includes) - implicit_includes - = map (\aid -> ComponentInclude { - ci_ann_id = aid, - ci_renaming = defaultIncludeRenaming, - ci_implicit = True - }) - $ filter (flip Set.notMember used_explicitly . ann_id) lib_deps - - return ConfiguredComponent { - cc_ann_id = AnnotatedId { - ann_id = this_cid, - ann_pid = package pkg_descr, - ann_cname = componentName component - }, - cc_component = component, - cc_public = is_public, - cc_exe_deps = exe_deps, - cc_includes = explicit_includes ++ implicit_includes - } - where - bi :: BuildInfo - bi = componentBuildInfo component - - prettyLN :: LibraryName -> Doc - prettyLN LMainLibName = PP.empty - prettyLN (LSubLibName n) = PP.colon <<>> pretty n - - deps_map :: Map (PackageName, ComponentName) (AnnotatedId ComponentId) - deps_map = Map.fromList [ ((packageName dep, ann_cname dep), dep) - | dep <- lib_deps ] - - is_public = componentName component == CLibName LMainLibName - -type ConfiguredComponentMap = - Map PackageName (Map ComponentName (AnnotatedId ComponentId)) - -toConfiguredComponent - :: PackageDescription - -> ComponentId - -> ConfiguredComponentMap - -> ConfiguredComponentMap - -> Component - -> LogProgress ConfiguredComponent -toConfiguredComponent pkg_descr this_cid lib_dep_map exe_dep_map component = do - lib_deps <- - if newPackageDepsBehaviour pkg_descr - then fmap concat $ forM (targetBuildDepends bi) $ - \(Dependency name _ sublibs) -> do - pkg <- case Map.lookup name lib_dep_map of - Nothing -> - dieProgress $ - text "Dependency on unbuildable" <+> - text "package" <+> pretty name - Just p -> return p - -- Return all library components - forM (NonEmptySet.toList sublibs) $ \lib -> - let comp = CLibName lib in - case Map.lookup comp pkg of - Nothing -> - dieProgress $ - text "Dependency on unbuildable" <+> - text (showLibraryName lib) <+> - text "from" <+> pretty name - Just v -> return v - else return old_style_lib_deps - mkConfiguredComponent - pkg_descr this_cid - lib_deps exe_deps component - where - bi = componentBuildInfo component - -- lib_dep_map contains a mix of internal and external deps. - -- We want all the public libraries (dep_cn == CLibName) - -- of all external deps (dep /= pn). Note that this - -- excludes the public library of the current package: - -- this is not supported by old-style deps behavior - -- because it would imply a cyclic dependency for the - -- library itself. - old_style_lib_deps = [ e - | (pn, comp_map) <- Map.toList lib_dep_map - , pn /= packageName pkg_descr - , (cn, e) <- Map.toList comp_map - , cn == CLibName LMainLibName ] - -- We have to nub here, because 'getAllToolDependencies' may return - -- duplicates (see #4986). (NB: This is not needed for lib_deps, - -- since those elaborate into includes, for which there explicitly - -- may be multiple instances of a package) - exe_deps = ordNub $ - [ exe - | ExeDependency pn cn _ <- getAllToolDependencies pkg_descr bi - -- The error suppression here is important, because in general - -- we won't know about external dependencies (e.g., 'happy') - -- which the package is attempting to use (those deps are only - -- fed in when cabal-install uses this codepath.) - -- TODO: Let cabal-install request errors here - , Just exe <- [Map.lookup (CExeName cn) =<< Map.lookup pn exe_dep_map] - ] - --- | Also computes the 'ComponentId', and sets cc_public if necessary. --- This is Cabal-only; cabal-install won't use this. -toConfiguredComponent' - :: Bool -- use_external_internal_deps - -> FlagAssignment - -> PackageDescription - -> Bool -- deterministic - -> Flag String -- configIPID (todo: remove me) - -> Flag ComponentId -- configCID - -> ConfiguredComponentMap - -> Component - -> LogProgress ConfiguredComponent -toConfiguredComponent' use_external_internal_deps flags - pkg_descr deterministic ipid_flag cid_flag - dep_map component = do - cc <- toConfiguredComponent - pkg_descr this_cid - dep_map dep_map component - return $ if use_external_internal_deps - then cc { cc_public = True } - else cc - where - -- TODO: pass component names to it too! - this_cid = computeComponentId deterministic ipid_flag cid_flag - (package pkg_descr) (componentName component) (Just (deps, flags)) - deps = [ ann_id aid | m <- Map.elems dep_map - , aid <- Map.elems m ] - -extendConfiguredComponentMap - :: ConfiguredComponent - -> ConfiguredComponentMap - -> ConfiguredComponentMap -extendConfiguredComponentMap cc = - Map.insertWith Map.union - (pkgName (cc_pkgid cc)) - (Map.singleton (cc_name cc) (cc_ann_id cc)) - --- Compute the 'ComponentId's for a graph of 'Component's. The --- list of internal components must be topologically sorted --- based on internal package dependencies, so that any internal --- dependency points to an entry earlier in the list. --- --- TODO: This function currently restricts the input configured components to --- one version per package, by using the type ConfiguredComponentMap. It cannot --- be used to configure a component that depends on one version of a package for --- a library and another version for a build-tool. -toConfiguredComponents - :: Bool -- use_external_internal_deps - -> FlagAssignment - -> Bool -- deterministic - -> Flag String -- configIPID - -> Flag ComponentId -- configCID - -> PackageDescription - -> ConfiguredComponentMap - -> [Component] - -> LogProgress [ConfiguredComponent] -toConfiguredComponents - use_external_internal_deps flags deterministic ipid_flag cid_flag pkg_descr - dep_map comps - = fmap snd (mapAccumM go dep_map comps) - where - go m component = do - cc <- toConfiguredComponent' - use_external_internal_deps flags pkg_descr - deterministic ipid_flag cid_flag - m component - return (extendConfiguredComponentMap cc m, cc) - -newPackageDepsBehaviourMinVersion :: CabalSpecVersion -newPackageDepsBehaviourMinVersion = CabalSpecV1_8 - - --- In older cabal versions, there was only one set of package dependencies for --- the whole package. In this version, we can have separate dependencies per --- target, but we only enable this behaviour if the minimum cabal version --- specified is >= a certain minimum. Otherwise, for compatibility we use the --- old behaviour. -newPackageDepsBehaviour :: PackageDescription -> Bool -newPackageDepsBehaviour pkg = - specVersion pkg >= newPackageDepsBehaviourMinVersion diff --git a/cabal/Cabal/Distribution/Backpack/DescribeUnitId.hs b/cabal/Cabal/Distribution/Backpack/DescribeUnitId.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Backpack/DescribeUnitId.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE Rank2Types #-} -module Distribution.Backpack.DescribeUnitId where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Compat.Stack -import Distribution.ModuleName -import Distribution.Pretty -import Distribution.Simple.Utils -import Distribution.Types.ComponentName -import Distribution.Types.PackageId -import Distribution.Verbosity - -import Text.PrettyPrint - --- Unit identifiers have a well defined, machine-readable format, --- but this format isn't very user-friendly for users. This --- module defines some functions for solving common rendering --- problems one has for displaying these. --- --- There are three basic problems we tackle: --- --- - Users don't want to see pkg-0.5-inplace-libname, --- they want to see "library 'libname' from 'pkg-0.5'" --- --- - Users don't want to see the raw component identifier, which --- usually contains a wordy hash that doesn't matter. --- --- - Users don't want to see a hash of the instantiation: they --- want to see the actual instantiation, and they want it in --- interpretable form. --- - --- | Print a Setup message stating (1) what operation we are doing, --- for (2) which component (with enough details to uniquely identify --- the build in question.) --- -setupMessage' :: Pretty a => Verbosity - -> String -- ^ Operation being done (capitalized), on: - -> PackageIdentifier -- ^ Package - -> ComponentName -- ^ Component name - -> Maybe [(ModuleName, a)] -- ^ Instantiation, if available. - -- Polymorphic to take - -- 'OpenModule' or 'Module' - -> IO () -setupMessage' verbosity msg pkgid cname mb_insts = withFrozenCallStack $ do - noticeDoc verbosity $ - case mb_insts of - Just insts | not (null insts) -> - hang (msg_doc <+> text "instantiated with") 2 - (vcat [ pretty k <+> text "=" <+> pretty v - | (k,v) <- insts ]) $$ - for_doc - _ -> - msg_doc <+> for_doc - - where - msg_doc = text msg <+> text (showComponentName cname) - for_doc = text "for" <+> pretty pkgid <<>> text ".." diff --git a/cabal/Cabal/Distribution/Backpack/FullUnitId.hs b/cabal/Cabal/Distribution/Backpack/FullUnitId.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Backpack/FullUnitId.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Backpack.FullUnitId ( - FullUnitId(..), - FullDb, - expandOpenUnitId, - expandUnitId -) where - -import Distribution.Backpack -import Distribution.Types.ComponentId -import Distribution.Compat.Prelude - --- Unlike OpenUnitId, which could direct to a UnitId. -data FullUnitId = FullUnitId ComponentId OpenModuleSubst - deriving (Show, Generic) - -type FullDb = DefUnitId -> FullUnitId - -expandOpenUnitId :: FullDb -> OpenUnitId -> FullUnitId -expandOpenUnitId _db (IndefFullUnitId cid subst) - = FullUnitId cid subst -expandOpenUnitId db (DefiniteUnitId uid) - = expandUnitId db uid - -expandUnitId :: FullDb -> DefUnitId -> FullUnitId -expandUnitId db uid = db uid diff --git a/cabal/Cabal/Distribution/Backpack/Id.hs b/cabal/Cabal/Distribution/Backpack/Id.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Backpack/Id.hs +++ /dev/null @@ -1,145 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE PatternGuards #-} --- | See -module Distribution.Backpack.Id( - computeComponentId, - computeCompatPackageKey, -) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Types.UnqualComponentName -import Distribution.Simple.Compiler -import Distribution.PackageDescription -import Distribution.Simple.Setup as Setup -import qualified Distribution.Simple.InstallDirs as InstallDirs -import Distribution.Simple.LocalBuildInfo -import Distribution.Types.ComponentId -import Distribution.Types.UnitId -import Distribution.Types.MungedPackageName -import Distribution.Utils.Base62 -import Distribution.Version - -import Distribution.Pretty - ( prettyShow ) -import Distribution.Parsec ( simpleParsec ) - --- | This method computes a default, "good enough" 'ComponentId' --- for a package. The intent is that cabal-install (or the user) will --- specify a more detailed IPID via the @--ipid@ flag if necessary. -computeComponentId - :: Bool -- deterministic mode - -> Flag String - -> Flag ComponentId - -> PackageIdentifier - -> ComponentName - -- This is used by cabal-install's legacy codepath - -> Maybe ([ComponentId], FlagAssignment) - -> ComponentId -computeComponentId deterministic mb_ipid mb_cid pid cname mb_details = - -- show is found to be faster than intercalate and then replacement of - -- special character used in intercalating. We cannot simply hash by - -- doubly concating list, as it just flatten out the nested list, so - -- different sources can produce same hash - let hash_suffix - | Just (dep_ipids, flags) <- mb_details - = "-" ++ hashToBase62 - -- For safety, include the package + version here - -- for GHC 7.10, where just the hash is used as - -- the package key - ( prettyShow pid - ++ show dep_ipids - ++ show flags ) - | otherwise = "" - generated_base = prettyShow pid ++ hash_suffix - explicit_base cid0 = fromPathTemplate (InstallDirs.substPathTemplate env - (toPathTemplate cid0)) - -- Hack to reuse install dirs machinery - -- NB: no real IPID available at this point - where env = packageTemplateEnv pid (mkUnitId "") - actual_base = case mb_ipid of - Flag ipid0 -> explicit_base ipid0 - NoFlag | deterministic -> prettyShow pid - | otherwise -> generated_base - in case mb_cid of - Flag cid -> cid - NoFlag -> mkComponentId $ actual_base - ++ (case componentNameString cname of - Nothing -> "" - Just s -> "-" ++ unUnqualComponentName s) - --- | In GHC 8.0, the string we pass to GHC to use for symbol --- names for a package can be an arbitrary, IPID-compatible string. --- However, prior to GHC 8.0 there are some restrictions on what --- format this string can be (due to how ghc-pkg parsed the key): --- --- 1. In GHC 7.10, the string had either be of the form --- foo_ABCD, where foo is a non-semantic alphanumeric/hyphenated --- prefix and ABCD is two base-64 encoded 64-bit integers, --- or a GHC 7.8 style identifier. --- --- 2. In GHC 7.8, the string had to be a valid package identifier --- like foo-0.1. --- --- So, the problem is that Cabal, in general, has a general IPID, --- but needs to figure out a package key / package ID that the --- old ghc-pkg will actually accept. But there's an EVERY WORSE --- problem: if ghc-pkg decides to parse an identifier foo-0.1-xxx --- as if it were a package identifier, which means it will SILENTLY --- DROP the "xxx" (because it's a tag, and Cabal does not allow tags.) --- So we must CONNIVE to ensure that we don't pick something that --- looks like this. --- --- So this function attempts to define a mapping into the old formats. --- --- The mapping for GHC 7.8 and before: --- --- * We use the *compatibility* package name and version. For --- public libraries this is just the package identifier; for --- internal libraries, it's something like "z-pkgname-z-libname-0.1". --- See 'computeCompatPackageName' for more details. --- --- The mapping for GHC 7.10: --- --- * For CLibName: --- If the IPID is of the form foo-0.1-ABCDEF where foo_ABCDEF would --- validly parse as a package key, we pass "ABCDEF". (NB: not --- all hashes parse this way, because GHC 7.10 mandated that --- these hashes be two base-62 encoded 64 bit integers), --- but hashes that Cabal generated using 'computeComponentId' --- are guaranteed to have this form. --- --- If it is not of this form, we rehash the IPID into the --- correct form and pass that. --- --- * For sub-components, we rehash the IPID into the correct format --- and pass that. --- -computeCompatPackageKey - :: Compiler - -> MungedPackageName - -> Version - -> UnitId - -> String -computeCompatPackageKey comp pkg_name pkg_version uid - | not (packageKeySupported comp || unitIdSupported comp) - = prettyShow pkg_name ++ "-" ++ prettyShow pkg_version - | not (unifiedIPIDRequired comp) = - let str = unUnitId uid -- assume no Backpack support - mb_verbatim_key - = case simpleParsec str :: Maybe PackageId of - -- Something like 'foo-0.1', use it verbatim. - -- (NB: hash tags look like tags, so they are parsed, - -- so the extra equality check tests if a tag was dropped.) - Just pid0 | prettyShow pid0 == str -> Just str - _ -> Nothing - mb_truncated_key - = let cand = reverse (takeWhile isAlphaNum (reverse str)) - in if length cand == 22 && all isAlphaNum cand - then Just cand - else Nothing - rehashed_key = hashToBase62 str - in fromMaybe rehashed_key (mb_verbatim_key `mplus` mb_truncated_key) - | otherwise = prettyShow uid diff --git a/cabal/Cabal/Distribution/Backpack/LinkedComponent.hs b/cabal/Cabal/Distribution/Backpack/LinkedComponent.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Backpack/LinkedComponent.hs +++ /dev/null @@ -1,396 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} --- | See -module Distribution.Backpack.LinkedComponent ( - LinkedComponent(..), - lc_insts, - lc_uid, - lc_cid, - lc_pkgid, - toLinkedComponent, - toLinkedComponents, - dispLinkedComponent, - LinkedComponentMap, - extendLinkedComponentMap, -) where - -import Prelude () -import Distribution.Compat.Prelude hiding ((<>)) - -import Distribution.Backpack -import Distribution.Backpack.FullUnitId -import Distribution.Backpack.ConfiguredComponent -import Distribution.Backpack.ModuleShape -import Distribution.Backpack.PreModuleShape -import Distribution.Backpack.ModuleScope -import Distribution.Backpack.UnifyM -import Distribution.Backpack.MixLink -import Distribution.Utils.MapAccum - -import Distribution.Types.AnnotatedId -import Distribution.Types.ComponentName -import Distribution.Types.ModuleReexport -import Distribution.Types.ModuleRenaming -import Distribution.Types.IncludeRenaming -import Distribution.Types.ComponentInclude -import Distribution.Types.ComponentId -import Distribution.Types.PackageId -import Distribution.Package -import Distribution.PackageDescription -import Distribution.ModuleName -import Distribution.Simple.LocalBuildInfo -import Distribution.Verbosity -import Distribution.Utils.LogProgress - -import qualified Data.Set as Set -import qualified Data.Map as Map -import Distribution.Pretty (pretty) -import Text.PrettyPrint (Doc, hang, text, vcat, ($+$), hsep, quotes) - --- | A linked component is a component that has been mix-in linked, at --- which point we have determined how all the dependencies of the --- component are explicitly instantiated (in the form of an OpenUnitId). --- 'ConfiguredComponent' is mix-in linked into 'LinkedComponent', which --- is then instantiated into 'ReadyComponent'. -data LinkedComponent - = LinkedComponent { - -- | Uniquely identifies linked component - lc_ann_id :: AnnotatedId ComponentId, - -- | Corresponds to 'cc_component'. - lc_component :: Component, - -- | @build-tools@ and @build-tool-depends@ dependencies. - -- Corresponds to 'cc_exe_deps'. - lc_exe_deps :: [AnnotatedId OpenUnitId], - -- | Is this the public library of a package? Corresponds to - -- 'cc_public'. - lc_public :: Bool, - -- | Corresponds to 'cc_includes', but (1) this does not contain - -- includes of signature packages (packages with no exports), - -- and (2) the 'ModuleRenaming' for requirements (stored in - -- 'IncludeRenaming') has been removed, as it is reflected in - -- 'OpenUnitId'.) - lc_includes :: [ComponentInclude OpenUnitId ModuleRenaming], - -- | Like 'lc_includes', but this specifies includes on - -- signature packages which have no exports. - lc_sig_includes :: [ComponentInclude OpenUnitId ModuleRenaming], - -- | The module shape computed by mix-in linking. This is - -- newly computed from 'ConfiguredComponent' - lc_shape :: ModuleShape - } - --- | Uniquely identifies a 'LinkedComponent'. Corresponds to --- 'cc_cid'. -lc_cid :: LinkedComponent -> ComponentId -lc_cid = ann_id . lc_ann_id - --- | Corresponds to 'cc_pkgid'. -lc_pkgid :: LinkedComponent -> PackageId -lc_pkgid = ann_pid . lc_ann_id - --- | The 'OpenUnitId' of this component in the "default" instantiation. --- See also 'lc_insts'. 'LinkedComponent's cannot be instantiated --- (e.g., there is no 'ModSubst' instance for them). -lc_uid :: LinkedComponent -> OpenUnitId -lc_uid lc = IndefFullUnitId (lc_cid lc) . Map.fromList $ lc_insts lc - --- | The instantiation of 'lc_uid'; this always has the invariant --- that it is a mapping from a module name @A@ to @@ (the hole A). -lc_insts :: LinkedComponent -> [(ModuleName, OpenModule)] -lc_insts lc = [ (req, OpenModuleVar req) - | req <- Set.toList (modShapeRequires (lc_shape lc)) ] - -dispLinkedComponent :: LinkedComponent -> Doc -dispLinkedComponent lc = - hang (text "unit" <+> pretty (lc_uid lc)) 4 $ - vcat [ text "include" <+> pretty (ci_id incl) <+> pretty (ci_renaming incl) - | incl <- lc_includes lc ] - $+$ - vcat [ text "signature include" <+> pretty (ci_id incl) - | incl <- lc_sig_includes lc ] - $+$ dispOpenModuleSubst (modShapeProvides (lc_shape lc)) - -instance Package LinkedComponent where - packageId = lc_pkgid - -toLinkedComponent - :: Verbosity - -> FullDb - -> PackageId - -> LinkedComponentMap - -> ConfiguredComponent - -> LogProgress LinkedComponent -toLinkedComponent verbosity db this_pid pkg_map ConfiguredComponent { - cc_ann_id = aid@AnnotatedId { ann_id = this_cid }, - cc_component = component, - cc_exe_deps = exe_deps, - cc_public = is_public, - cc_includes = cid_includes - } = do - let - -- The explicitly specified requirements, provisions and - -- reexports from the Cabal file. These are only non-empty for - -- libraries; everything else is trivial. - (src_reqs :: [ModuleName], - src_provs :: [ModuleName], - src_reexports :: [ModuleReexport]) = - case component of - CLib lib -> (signatures lib, - exposedModules lib, - reexportedModules lib) - _ -> ([], [], []) - src_hidden = otherModules (componentBuildInfo component) - - -- Take each included ComponentId and resolve it into an - -- *unlinked* unit identity. We will use unification (relying - -- on the ModuleShape) to resolve these into linked identities. - unlinked_includes :: [ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming] - unlinked_includes = [ ComponentInclude (fmap lookupUid dep_aid) rns i - | ComponentInclude dep_aid rns i <- cid_includes ] - - lookupUid :: ComponentId -> (OpenUnitId, ModuleShape) - lookupUid cid = fromMaybe (error "linkComponent: lookupUid") - (Map.lookup cid pkg_map) - - let orErr (Right x) = return x - orErr (Left [err]) = dieProgress err - orErr (Left errs) = do - dieProgress (vcat (intersperse (text "") -- double newline! - [ hang (text "-") 2 err | err <- errs])) - - -- Pre-shaping - let pre_shape = mixLinkPreModuleShape $ - PreModuleShape { - preModShapeProvides = Set.fromList (src_provs ++ src_hidden), - preModShapeRequires = Set.fromList src_reqs - } : [ renamePreModuleShape (toPreModuleShape sh) rns - | ComponentInclude (AnnotatedId { ann_id = (_, sh) }) rns _ <- unlinked_includes ] - reqs = preModShapeRequires pre_shape - insts = [ (req, OpenModuleVar req) - | req <- Set.toList reqs ] - this_uid = IndefFullUnitId this_cid . Map.fromList $ insts - - -- OK, actually do unification - -- TODO: the unification monad might return errors, in which - -- case we have to deal. Use monadic bind for now. - (linked_shape0 :: ModuleScope, - linked_includes0 :: [ComponentInclude OpenUnitId ModuleRenaming], - linked_sig_includes0 :: [ComponentInclude OpenUnitId ModuleRenaming]) - <- orErr $ runUnifyM verbosity this_cid db $ do - -- The unification monad is implemented using mutable - -- references. Thus, we must convert our *pure* data - -- structures into mutable ones to perform unification. - - let convertMod :: (ModuleName -> ModuleSource) -> ModuleName -> UnifyM s (ModuleScopeU s) - convertMod from m = do - m_u <- convertModule (OpenModule this_uid m) - return (Map.singleton m [WithSource (from m) m_u], Map.empty) - -- Handle 'exposed-modules' - exposed_mod_shapes_u <- traverse (convertMod FromExposedModules) src_provs - -- Handle 'other-modules' - other_mod_shapes_u <- traverse (convertMod FromOtherModules) src_hidden - - -- Handle 'signatures' - let convertReq :: ModuleName -> UnifyM s (ModuleScopeU s) - convertReq req = do - req_u <- convertModule (OpenModuleVar req) - return (Map.empty, Map.singleton req [WithSource (FromSignatures req) req_u]) - req_shapes_u <- traverse convertReq src_reqs - - -- Handle 'mixins' - (incl_shapes_u, all_includes_u) <- fmap unzip (traverse convertInclude unlinked_includes) - - failIfErrs -- Prevent error cascade - -- Mix-in link everything! mixLink is the real workhorse. - shape_u <- mixLink $ exposed_mod_shapes_u - ++ other_mod_shapes_u - ++ req_shapes_u - ++ incl_shapes_u - - -- src_reqs_u <- traverse convertReq src_reqs - -- Read out all the final results by converting back - -- into a pure representation. - let convertIncludeU (ComponentInclude dep_aid rns i) = do - uid <- convertUnitIdU (ann_id dep_aid) - return (ComponentInclude { - ci_ann_id = dep_aid { ann_id = uid }, - ci_renaming = rns, - ci_implicit = i - }) - shape <- convertModuleScopeU shape_u - let (includes_u, sig_includes_u) = partitionEithers all_includes_u - incls <- traverse convertIncludeU includes_u - sig_incls <- traverse convertIncludeU sig_includes_u - return (shape, incls, sig_incls) - - let isNotLib (CLib _) = False - isNotLib _ = True - when (not (Set.null reqs) && isNotLib component) $ - dieProgress $ - hang (text "Non-library component has unfilled requirements:") - 4 (vcat [pretty req | req <- Set.toList reqs]) - - -- NB: do NOT include hidden modules here: GHC 7.10's ghc-pkg - -- won't allow it (since someone could directly synthesize - -- an 'InstalledPackageInfo' that violates abstraction.) - -- Though, maybe it should be relaxed? - let src_hidden_set = Set.fromList src_hidden - linked_shape = linked_shape0 { - modScopeProvides = - -- Would rather use withoutKeys but need BC - Map.filterWithKey - (\k _ -> not (k `Set.member` src_hidden_set)) - (modScopeProvides linked_shape0) - } - - -- OK, compute the reexports - -- TODO: This code reports the errors for reexports one reexport at - -- a time. Better to collect them all up and report them all at - -- once. - let hdl :: [Either Doc a] -> LogProgress [a] - hdl es = - case partitionEithers es of - ([], rs) -> return rs - (ls, _) -> - dieProgress $ - hang (text "Problem with module re-exports:") 2 - (vcat [hang (text "-") 2 l | l <- ls]) - reexports_list <- hdl . (flip map) src_reexports $ \reex@(ModuleReexport mb_pn from to) -> do - case Map.lookup from (modScopeProvides linked_shape) of - Just cands@(x0:xs0) -> do - -- Make sure there is at least one candidate - (x, xs) <- - case mb_pn of - Just pn -> - let matches_pn (FromMixins pn' _ _) = pn == pn' - matches_pn (FromBuildDepends pn' _) = pn == pn' - matches_pn (FromExposedModules _) = pn == packageName this_pid - matches_pn (FromOtherModules _) = pn == packageName this_pid - matches_pn (FromSignatures _) = pn == packageName this_pid - in case filter (matches_pn . getSource) cands of - (x1:xs1) -> return (x1, xs1) - _ -> Left (brokenReexportMsg reex) - Nothing -> return (x0, xs0) - -- Test that all the candidates are consistent - case filter (\x' -> unWithSource x /= unWithSource x') xs of - [] -> return () - _ -> Left $ ambiguousReexportMsg reex x xs - return (to, unWithSource x) - _ -> - Left (brokenReexportMsg reex) - - -- TODO: maybe check this earlier; it's syntactically obvious. - let build_reexports m (k, v) - | Map.member k m = - dieProgress $ hsep - [ text "Module name ", pretty k, text " is exported multiple times." ] - | otherwise = return (Map.insert k v m) - provs <- foldM build_reexports Map.empty $ - -- TODO: doublecheck we have checked for - -- src_provs duplicates already! - [ (mod_name, OpenModule this_uid mod_name) | mod_name <- src_provs ] ++ - reexports_list - - let final_linked_shape = ModuleShape provs (Map.keysSet (modScopeRequires linked_shape)) - - -- See Note Note [Signature package special case] - let (linked_includes, linked_sig_includes) - | Set.null reqs = (linked_includes0 ++ linked_sig_includes0, []) - | otherwise = (linked_includes0, linked_sig_includes0) - - return $ LinkedComponent { - lc_ann_id = aid, - lc_component = component, - lc_public = is_public, - -- These must be executables - lc_exe_deps = map (fmap (\cid -> IndefFullUnitId cid Map.empty)) exe_deps, - lc_shape = final_linked_shape, - lc_includes = linked_includes, - lc_sig_includes = linked_sig_includes - } - --- Note [Signature package special case] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Suppose we have p-indef, which depends on str-sig and inherits --- the hole from that signature package. When we instantiate p-indef, --- it's a bit pointless to also go ahead and build str-sig, because --- str-sig cannot possibly have contributed any code to the package --- in question. Furthermore, because the signature was inherited to --- p-indef, if we test matching against p-indef, we also have tested --- matching against p-sig. In fact, skipping p-sig is *mandatory*, --- because p-indef may have thinned it (so that an implementation may --- match p-indef but not p-sig.) --- --- However, suppose that we have a package which mixes together str-sig --- and str-bytestring, with the intent of *checking* that str-sig is --- implemented by str-bytestring. Here, it's quite important to --- build an instantiated str-sig, since that is the only way we will --- actually end up testing if the matching works. Note that this --- admonition only applies if the package has NO requirements; if it --- has any requirements, we will typecheck it as an indefinite --- package, at which point the signature includes will be passed to --- GHC who will in turn actually do the checking to make sure they --- are instantiated correctly. - --- Handle mix-in linking for components. In the absence of Backpack, --- every ComponentId gets converted into a UnitId by way of SimpleUnitId. -toLinkedComponents - :: Verbosity - -> FullDb - -> PackageId - -> LinkedComponentMap - -> [ConfiguredComponent] - -> LogProgress [LinkedComponent] -toLinkedComponents verbosity db this_pid lc_map0 comps - = fmap snd (mapAccumM go lc_map0 comps) - where - go :: Map ComponentId (OpenUnitId, ModuleShape) - -> ConfiguredComponent - -> LogProgress (Map ComponentId (OpenUnitId, ModuleShape), LinkedComponent) - go lc_map cc = do - lc <- addProgressCtx (text "In the stanza" <+> text (componentNameStanza (cc_name cc))) $ - toLinkedComponent verbosity db this_pid lc_map cc - return (extendLinkedComponentMap lc lc_map, lc) - -type LinkedComponentMap = Map ComponentId (OpenUnitId, ModuleShape) - -extendLinkedComponentMap :: LinkedComponent - -> LinkedComponentMap - -> LinkedComponentMap -extendLinkedComponentMap lc m = - Map.insert (lc_cid lc) (lc_uid lc, lc_shape lc) m - -brokenReexportMsg :: ModuleReexport -> Doc -brokenReexportMsg (ModuleReexport (Just pn) from _to) = - vcat [ text "The package" <+> quotes (pretty pn) - , text "does not export a module" <+> quotes (pretty from) ] -brokenReexportMsg (ModuleReexport Nothing from _to) = - vcat [ text "The module" <+> quotes (pretty from) - , text "is not exported by any suitable package." - , text "It occurs in neither the 'exposed-modules' of this package," - , text "nor any of its 'build-depends' dependencies." ] - -ambiguousReexportMsg :: ModuleReexport -> ModuleWithSource -> [ModuleWithSource] -> Doc -ambiguousReexportMsg (ModuleReexport mb_pn from _to) y1 ys = - vcat [ text "Ambiguous reexport" <+> quotes (pretty from) - , hang (text "It could refer to either:") 2 - (vcat (msg : msgs)) - , help_msg mb_pn ] - where - msg = text " " <+> displayModuleWithSource y1 - msgs = [text "or" <+> displayModuleWithSource y | y <- ys] - help_msg Nothing = - -- TODO: This advice doesn't help if the ambiguous exports - -- come from a package named the same thing - vcat [ text "The ambiguity can be resolved by qualifying the" - , text "re-export with a package name." - , text "The syntax is 'packagename:ModuleName [as NewName]'." ] - -- Qualifying won't help that much. - help_msg (Just _) = - vcat [ text "The ambiguity can be resolved by using the" - , text "mixins field to rename one of the module" - , text "names differently." ] - displayModuleWithSource y - = vcat [ quotes (pretty (unWithSource y)) - , text "brought into scope by" <+> - dispModuleSource (getSource y) - ] diff --git a/cabal/Cabal/Distribution/Backpack/MixLink.hs b/cabal/Cabal/Distribution/Backpack/MixLink.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Backpack/MixLink.hs +++ /dev/null @@ -1,185 +0,0 @@ -{-# LANGUAGE NondecreasingIndentation #-} --- | See -module Distribution.Backpack.MixLink ( - mixLink, -) where - -import Prelude () -import Distribution.Compat.Prelude hiding (mod) - -import Distribution.Backpack -import Distribution.Backpack.UnifyM -import Distribution.Backpack.FullUnitId -import Distribution.Backpack.ModuleScope - -import qualified Distribution.Utils.UnionFind as UnionFind -import Distribution.ModuleName -import Distribution.Pretty -import Distribution.Types.ComponentId - -import Text.PrettyPrint -import Control.Monad -import qualified Data.Map as Map -import qualified Data.Foldable as F - ------------------------------------------------------------------------ --- Linking - --- | Given to scopes of provisions and requirements, link them together. -mixLink :: [ModuleScopeU s] -> UnifyM s (ModuleScopeU s) -mixLink scopes = do - let provs = Map.unionsWith (++) (map fst scopes) - -- Invariant: any identically named holes refer to same mutable cell - reqs = Map.unionsWith (++) (map snd scopes) - filled = Map.intersectionWithKey linkProvision provs reqs - F.sequenceA_ filled - let remaining = Map.difference reqs filled - return (provs, remaining) - --- | Link a list of possibly provided modules to a single --- requirement. This applies a side-condition that all --- of the provided modules at the same name are *actually* --- the same module. -linkProvision :: ModuleName - -> [ModuleWithSourceU s] -- provs - -> [ModuleWithSourceU s] -- reqs - -> UnifyM s [ModuleWithSourceU s] -linkProvision mod_name ret@(prov:provs) (req:reqs) = do - -- TODO: coalesce all the non-unifying modules together - forM_ provs $ \prov' -> do - -- Careful: read it out BEFORE unifying, because the - -- unification algorithm preemptively unifies modules - mod <- convertModuleU (unWithSource prov) - mod' <- convertModuleU (unWithSource prov') - r <- unify prov prov' - case r of - Just () -> return () - Nothing -> do - addErr $ - text "Ambiguous module" <+> quotes (pretty mod_name) $$ - text "It could refer to" <+> - ( text " " <+> (quotes (pretty mod) $$ in_scope_by (getSource prov)) $$ - text "or" <+> (quotes (pretty mod') $$ in_scope_by (getSource prov')) ) $$ - link_doc - mod <- convertModuleU (unWithSource prov) - req_mod <- convertModuleU (unWithSource req) - self_cid <- fmap unify_self_cid getUnifEnv - case mod of - OpenModule (IndefFullUnitId cid _) _ - | cid == self_cid -> addErr $ - text "Cannot instantiate requirement" <+> quotes (pretty mod_name) <+> - in_scope_by (getSource req) $$ - text "with locally defined module" <+> in_scope_by (getSource prov) $$ - text "as this would create a cyclic dependency, which GHC does not support." $$ - text "Try moving this module to a separate library, e.g.," $$ - text "create a new stanza: library 'sublib'." - _ -> return () - r <- unify prov req - case r of - Just () -> return () - Nothing -> do - -- TODO: Record and report WHERE the bad constraint came from - addErr $ text "Could not instantiate requirement" <+> quotes (pretty mod_name) $$ - nest 4 (text "Expected:" <+> pretty mod $$ - text "Actual: " <+> pretty req_mod) $$ - parens (text "This can occur if an exposed module of" <+> - text "a libraries shares a name with another module.") $$ - link_doc - return ret - where - unify s1 s2 = tryM $ addErrContext short_link_doc - $ unifyModule (unWithSource s1) (unWithSource s2) - in_scope_by s = text "brought into scope by" <+> dispModuleSource s - short_link_doc = text "While filling requirement" <+> quotes (pretty mod_name) - link_doc = text "While filling requirements of" <+> reqs_doc - reqs_doc - | null reqs = dispModuleSource (getSource req) - | otherwise = ( text " " <+> dispModuleSource (getSource req) $$ - vcat [ text "and" <+> dispModuleSource (getSource r) | r <- reqs]) -linkProvision _ _ _ = error "linkProvision" - - - ------------------------------------------------------------------------ --- The unification algorithm - --- This is based off of https://gist.github.com/amnn/559551517d020dbb6588 --- which is a translation from Huet's thesis. - -unifyUnitId :: UnitIdU s -> UnitIdU s -> UnifyM s () -unifyUnitId uid1_u uid2_u - | uid1_u == uid2_u = return () - | otherwise = do - xuid1 <- liftST $ UnionFind.find uid1_u - xuid2 <- liftST $ UnionFind.find uid2_u - case (xuid1, xuid2) of - (UnitIdThunkU u1, UnitIdThunkU u2) - | u1 == u2 -> return () - | otherwise -> - failWith $ hang (text "Couldn't match unit IDs:") 4 - (text " " <+> pretty u1 $$ - text "and" <+> pretty u2) - (UnitIdThunkU uid1, UnitIdU _ cid2 insts2) - -> unifyThunkWith cid2 insts2 uid2_u uid1 uid1_u - (UnitIdU _ cid1 insts1, UnitIdThunkU uid2) - -> unifyThunkWith cid1 insts1 uid1_u uid2 uid2_u - (UnitIdU _ cid1 insts1, UnitIdU _ cid2 insts2) - -> unifyInner cid1 insts1 uid1_u cid2 insts2 uid2_u - -unifyThunkWith :: ComponentId - -> Map ModuleName (ModuleU s) - -> UnitIdU s - -> DefUnitId - -> UnitIdU s - -> UnifyM s () -unifyThunkWith cid1 insts1 uid1_u uid2 uid2_u = do - db <- fmap unify_db getUnifEnv - let FullUnitId cid2 insts2' = expandUnitId db uid2 - insts2 <- convertModuleSubst insts2' - unifyInner cid1 insts1 uid1_u cid2 insts2 uid2_u - -unifyInner :: ComponentId - -> Map ModuleName (ModuleU s) - -> UnitIdU s - -> ComponentId - -> Map ModuleName (ModuleU s) - -> UnitIdU s - -> UnifyM s () -unifyInner cid1 insts1 uid1_u cid2 insts2 uid2_u = do - when (cid1 /= cid2) $ - -- TODO: if we had a package identifier, could be an - -- easier to understand error message. - failWith $ - hang (text "Couldn't match component IDs:") 4 - (text " " <+> pretty cid1 $$ - text "and" <+> pretty cid2) - -- The KEY STEP which makes this a Huet-style unification - -- algorithm. (Also a payoff of using union-find.) - -- We can build infinite unit IDs this way, which is necessary - -- for support mutual recursion. NB: union keeps the SECOND - -- descriptor, so we always arrange for a UnitIdThunkU to live - -- there. - liftST $ UnionFind.union uid1_u uid2_u - F.sequenceA_ $ Map.intersectionWith unifyModule insts1 insts2 - --- | Imperatively unify two modules. -unifyModule :: ModuleU s -> ModuleU s -> UnifyM s () -unifyModule mod1_u mod2_u - | mod1_u == mod2_u = return () - | otherwise = do - mod1 <- liftST $ UnionFind.find mod1_u - mod2 <- liftST $ UnionFind.find mod2_u - case (mod1, mod2) of - (ModuleVarU _, _) -> liftST $ UnionFind.union mod1_u mod2_u - (_, ModuleVarU _) -> liftST $ UnionFind.union mod2_u mod1_u - (ModuleU uid1 mod_name1, ModuleU uid2 mod_name2) -> do - when (mod_name1 /= mod_name2) $ - failWith $ - hang (text "Cannot match module names") 4 $ - text " " <+> pretty mod_name1 $$ - text "and" <+> pretty mod_name2 - -- NB: this is not actually necessary (because we'll - -- detect loops eventually in 'unifyUnitId'), but it - -- seems harmless enough - liftST $ UnionFind.union mod1_u mod2_u - unifyUnitId uid1 uid2 diff --git a/cabal/Cabal/Distribution/Backpack/ModSubst.hs b/cabal/Cabal/Distribution/Backpack/ModSubst.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Backpack/ModSubst.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PatternGuards #-} - --- | A type class 'ModSubst' for objects which can have 'ModuleSubst' --- applied to them. --- --- See also - -module Distribution.Backpack.ModSubst ( - ModSubst(..), -) where - -import Prelude () -import Distribution.Compat.Prelude hiding (mod) - -import Distribution.Backpack -import Distribution.ModuleName - -import qualified Data.Map as Map -import qualified Data.Set as Set - --- | Applying module substitutions to semantic objects. -class ModSubst a where - -- In notation, substitution is postfix, which implies - -- putting it on the right hand side, but for partial - -- application it's more convenient to have it on the left - -- hand side. - modSubst :: OpenModuleSubst -> a -> a - -instance ModSubst OpenModule where - modSubst subst (OpenModule cid mod_name) = OpenModule (modSubst subst cid) mod_name - modSubst subst mod@(OpenModuleVar mod_name) - | Just mod' <- Map.lookup mod_name subst = mod' - | otherwise = mod - -instance ModSubst OpenUnitId where - modSubst subst (IndefFullUnitId cid insts) = IndefFullUnitId cid (modSubst subst insts) - modSubst _subst uid = uid - -instance ModSubst (Set ModuleName) where - modSubst subst reqs - = Set.union (Set.difference reqs (Map.keysSet subst)) - (openModuleSubstFreeHoles subst) - --- Substitutions are functorial. NB: this means that --- there is an @instance 'ModSubst' 'ModuleSubst'@! -instance ModSubst a => ModSubst (Map k a) where - modSubst subst = fmap (modSubst subst) -instance ModSubst a => ModSubst [a] where - modSubst subst = fmap (modSubst subst) -instance ModSubst a => ModSubst (k, a) where - modSubst subst (x,y) = (x, modSubst subst y) diff --git a/cabal/Cabal/Distribution/Backpack/ModuleScope.hs b/cabal/Cabal/Distribution/Backpack/ModuleScope.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Backpack/ModuleScope.hs +++ /dev/null @@ -1,132 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DeriveFoldable #-} --- | See -module Distribution.Backpack.ModuleScope ( - -- * Module scopes - ModuleScope(..), - ModuleProvides, - ModuleRequires, - ModuleSource(..), - dispModuleSource, - WithSource(..), - unWithSource, - getSource, - ModuleWithSource, - emptyModuleScope, -) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.ModuleName -import Distribution.Types.IncludeRenaming -import Distribution.Types.PackageName -import Distribution.Types.ComponentName -import Distribution.Types.LibraryName -import Distribution.Pretty - -import Distribution.Backpack -import Distribution.Backpack.ModSubst - -import qualified Data.Map as Map -import Text.PrettyPrint - - ------------------------------------------------------------------------ --- Module scopes - --- Why is ModuleProvides so complicated? The basic problem is that --- we want to support this: --- --- package p where --- include q (A) --- include r (A) --- module B where --- import "q" A --- import "r" A --- --- Specifically, in Cabal today it is NOT an error have two modules in --- scope with the same identifier. So we need to preserve this for --- Backpack. The modification is that an ambiguous module name is --- OK... as long as it is NOT used to fill a requirement! --- --- So as a first try, we might try deferring unifying provisions that --- are being glommed together, and check for equality after the fact. --- But this doesn't work, because what if a multi-module provision --- is used to fill a requirement?! So you do the equality test --- IMMEDIATELY before a requirement fill happens... or never at all. --- --- Alternate strategy: go ahead and unify, and then if it is revealed --- that some requirements got filled "out-of-thin-air", error. - - --- | A 'ModuleScope' describes the modules and requirements that --- are in-scope as we are processing a Cabal package. Unlike --- a 'ModuleShape', there may be multiple modules in scope at --- the same 'ModuleName'; this is only an error if we attempt --- to use those modules to fill a requirement. A 'ModuleScope' --- can influence the 'ModuleShape' via a reexport. -data ModuleScope = ModuleScope { - modScopeProvides :: ModuleProvides, - modScopeRequires :: ModuleRequires - } - --- | An empty 'ModuleScope'. -emptyModuleScope :: ModuleScope -emptyModuleScope = ModuleScope Map.empty Map.empty - --- | Every 'Module' in scope at a 'ModuleName' is annotated with --- the 'PackageName' it comes from. -type ModuleProvides = Map ModuleName [ModuleWithSource] --- | INVARIANT: entries for ModuleName m, have msrc_module is OpenModuleVar m -type ModuleRequires = Map ModuleName [ModuleWithSource] --- TODO: consider newtping the two types above. - --- | Description of where a module participating in mixin linking came --- from. -data ModuleSource - = FromMixins PackageName ComponentName IncludeRenaming - | FromBuildDepends PackageName ComponentName - | FromExposedModules ModuleName - | FromOtherModules ModuleName - | FromSignatures ModuleName --- We don't have line numbers, but if we did, we'd want to record that --- too - --- TODO: Deduplicate this with Distribution.Backpack.UnifyM.ci_msg -dispModuleSource :: ModuleSource -> Doc -dispModuleSource (FromMixins pn cn incls) - = text "mixins:" <+> dispComponent pn cn <+> pretty incls -dispModuleSource (FromBuildDepends pn cn) - = text "build-depends:" <+> dispComponent pn cn -dispModuleSource (FromExposedModules m) - = text "exposed-modules:" <+> pretty m -dispModuleSource (FromOtherModules m) - = text "other-modules:" <+> pretty m -dispModuleSource (FromSignatures m) - = text "signatures:" <+> pretty m - --- Dependency -dispComponent :: PackageName -> ComponentName -> Doc -dispComponent pn cn = - -- NB: This syntax isn't quite the source syntax, but it - -- should be clear enough. To do source syntax, we'd - -- need to know what the package we're linking is. - case cn of - CLibName LMainLibName -> pretty pn - CLibName (LSubLibName ucn) -> pretty pn <<>> colon <<>> pretty ucn - -- Case below shouldn't happen - _ -> pretty pn <+> parens (pretty cn) - --- | An 'OpenModule', annotated with where it came from in a Cabal file. -data WithSource a = WithSource ModuleSource a - deriving (Functor, Foldable, Traversable) -unWithSource :: WithSource a -> a -unWithSource (WithSource _ x) = x -getSource :: WithSource a -> ModuleSource -getSource (WithSource s _) = s -type ModuleWithSource = WithSource OpenModule - -instance ModSubst a => ModSubst (WithSource a) where - modSubst subst (WithSource s m) = WithSource s (modSubst subst m) diff --git a/cabal/Cabal/Distribution/Backpack/ModuleShape.hs b/cabal/Cabal/Distribution/Backpack/ModuleShape.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Backpack/ModuleShape.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} --- | See -module Distribution.Backpack.ModuleShape ( - -- * Module shapes - ModuleShape(..), - emptyModuleShape, - shapeInstalledPackage, -) where - -import Prelude () -import Distribution.Compat.Prelude hiding (mod) - -import Distribution.ModuleName -import Distribution.InstalledPackageInfo as IPI - -import Distribution.Backpack.ModSubst -import Distribution.Backpack - -import qualified Data.Map as Map -import qualified Data.Set as Set - ------------------------------------------------------------------------ --- Module shapes - --- | A 'ModuleShape' describes the provisions and requirements of --- a library. We can extract a 'ModuleShape' from an --- 'InstalledPackageInfo'. -data ModuleShape = ModuleShape { - modShapeProvides :: OpenModuleSubst, - modShapeRequires :: Set ModuleName - } - deriving (Eq, Show, Generic, Typeable) - -instance Binary ModuleShape -instance Structured ModuleShape - -instance ModSubst ModuleShape where - modSubst subst (ModuleShape provs reqs) - = ModuleShape (modSubst subst provs) (modSubst subst reqs) - --- | The default module shape, with no provisions and no requirements. -emptyModuleShape :: ModuleShape -emptyModuleShape = ModuleShape Map.empty Set.empty - --- Food for thought: suppose we apply the Merkel tree optimization. --- Imagine this situation: --- --- component p --- signature H --- module P --- component h --- module H --- component a --- signature P --- module A --- component q(P) --- include p --- include h --- component r --- include q (P) --- include p (P) requires (H) --- include h (H) --- include a (A) requires (P) --- --- Component r should not have any conflicts, since after mix-in linking --- the two P imports will end up being the same, so we can properly --- instantiate it. But to know that q's P is p:P instantiated with h:H, --- we have to be able to expand its unit id. Maybe we can expand it --- lazily but in some cases it will need to be expanded. --- --- FWIW, the way that GHC handles this is by improving unit IDs as --- soon as it sees an improved one in the package database. This --- is a bit disgusting. -shapeInstalledPackage :: IPI.InstalledPackageInfo -> ModuleShape -shapeInstalledPackage ipi = ModuleShape (Map.fromList provs) reqs - where - uid = installedOpenUnitId ipi - provs = map shapeExposedModule (IPI.exposedModules ipi) - reqs = requiredSignatures ipi - shapeExposedModule (IPI.ExposedModule mod_name Nothing) - = (mod_name, OpenModule uid mod_name) - shapeExposedModule (IPI.ExposedModule mod_name (Just mod)) - = (mod_name, mod) diff --git a/cabal/Cabal/Distribution/Backpack/PreExistingComponent.hs b/cabal/Cabal/Distribution/Backpack/PreExistingComponent.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Backpack/PreExistingComponent.hs +++ /dev/null @@ -1,67 +0,0 @@ --- | See -module Distribution.Backpack.PreExistingComponent ( - PreExistingComponent(..), - ipiToPreExistingComponent, -) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Backpack.ModuleShape -import Distribution.Backpack -import Distribution.Types.ComponentId -import Distribution.Types.MungedPackageId -import Distribution.Types.PackageId -import Distribution.Types.UnitId -import Distribution.Types.ComponentName -import Distribution.Types.PackageName -import Distribution.Package - -import qualified Data.Map as Map -import qualified Distribution.InstalledPackageInfo as Installed -import Distribution.InstalledPackageInfo (InstalledPackageInfo) - --- | Stripped down version of 'LinkedComponent' for things --- we don't need to know how to build. -data PreExistingComponent - = PreExistingComponent { - -- | The actual name of the package. This may DISAGREE with 'pc_pkgid' - -- for internal dependencies: e.g., an internal component @lib@ may be - -- munged to @z-pkg-z-lib@, but we still want to use it when we see - -- @lib@ in @build-depends@ - pc_pkgname :: PackageName, - -- | The actual name of the component. - pc_compname :: ComponentName, - pc_munged_id :: MungedPackageId, - pc_uid :: UnitId, - pc_cid :: ComponentId, - pc_open_uid :: OpenUnitId, - pc_shape :: ModuleShape - } - --- | Convert an 'InstalledPackageInfo' into a 'PreExistingComponent', --- which was brought into scope under the 'PackageName' (important for --- a package qualified reference.) -ipiToPreExistingComponent :: InstalledPackageInfo -> PreExistingComponent -ipiToPreExistingComponent ipi = - PreExistingComponent { - pc_pkgname = packageName ipi, - pc_compname = CLibName $ Installed.sourceLibName ipi, - pc_munged_id = mungedId ipi, - pc_uid = Installed.installedUnitId ipi, - pc_cid = Installed.installedComponentId ipi, - pc_open_uid = - IndefFullUnitId (Installed.installedComponentId ipi) - (Map.fromList (Installed.instantiatedWith ipi)), - pc_shape = shapeInstalledPackage ipi - } - -instance HasMungedPackageId PreExistingComponent where - mungedId = pc_munged_id - -instance Package PreExistingComponent where - packageId pec = PackageIdentifier (pc_pkgname pec) v - where MungedPackageId _ v = pc_munged_id pec - -instance HasUnitId PreExistingComponent where - installedUnitId = pc_uid diff --git a/cabal/Cabal/Distribution/Backpack/PreModuleShape.hs b/cabal/Cabal/Distribution/Backpack/PreModuleShape.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Backpack/PreModuleShape.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - -module Distribution.Backpack.PreModuleShape ( - PreModuleShape(..), - toPreModuleShape, - renamePreModuleShape, - mixLinkPreModuleShape, -) where - -import Prelude () -import Distribution.Compat.Prelude - -import qualified Data.Set as Set -import qualified Data.Map as Map - -import Distribution.Backpack.ModuleShape -import Distribution.Types.IncludeRenaming -import Distribution.Types.ModuleRenaming -import Distribution.ModuleName - -data PreModuleShape = PreModuleShape { - preModShapeProvides :: Set ModuleName, - preModShapeRequires :: Set ModuleName - } - deriving (Eq, Show, Generic) - -toPreModuleShape :: ModuleShape -> PreModuleShape -toPreModuleShape (ModuleShape provs reqs) = PreModuleShape (Map.keysSet provs) reqs - -renamePreModuleShape :: PreModuleShape -> IncludeRenaming -> PreModuleShape -renamePreModuleShape (PreModuleShape provs reqs) (IncludeRenaming prov_rn req_rn) = - PreModuleShape - (Set.fromList (mapMaybe prov_fn (Set.toList provs))) - (Set.map req_fn reqs) - where - prov_fn = interpModuleRenaming prov_rn - req_fn k = fromMaybe k (interpModuleRenaming req_rn k) - -mixLinkPreModuleShape :: [PreModuleShape] -> PreModuleShape -mixLinkPreModuleShape shapes = PreModuleShape provs (Set.difference reqs provs) - where - provs = Set.unions (map preModShapeProvides shapes) - reqs = Set.unions (map preModShapeRequires shapes) diff --git a/cabal/Cabal/Distribution/Backpack/ReadyComponent.hs b/cabal/Cabal/Distribution/Backpack/ReadyComponent.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Backpack/ReadyComponent.hs +++ /dev/null @@ -1,376 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE PatternGuards #-} --- | See -module Distribution.Backpack.ReadyComponent ( - ReadyComponent(..), - InstantiatedComponent(..), - IndefiniteComponent(..), - rc_depends, - rc_uid, - rc_pkgid, - dispReadyComponent, - toReadyComponents, -) where - -import Prelude () -import Distribution.Compat.Prelude hiding ((<>)) - -import Distribution.Backpack -import Distribution.Backpack.LinkedComponent -import Distribution.Backpack.ModuleShape - -import Distribution.Types.AnnotatedId -import Distribution.Types.ModuleRenaming -import Distribution.Types.Component -import Distribution.Types.ComponentInclude -import Distribution.Types.ComponentId -import Distribution.Types.ComponentName -import Distribution.Types.PackageId -import Distribution.Types.PackageName.Magic -import Distribution.Types.UnitId -import Distribution.Compat.Graph (IsNode(..)) -import Distribution.Types.Module -import Distribution.Types.MungedPackageId -import Distribution.Types.MungedPackageName -import Distribution.Types.Library -import Distribution.Types.LibraryName - -import Distribution.ModuleName -import Distribution.Package -import Distribution.Simple.Utils - -import Control.Monad -import Text.PrettyPrint -import qualified Data.Map as Map -import qualified Data.Set as Set - -import Distribution.Version -import Distribution.Pretty - --- | A 'ReadyComponent' is one that we can actually generate build --- products for. We have a ready component for the typecheck-only --- products of every indefinite package, as well as a ready component --- for every way these packages can be fully instantiated. --- -data ReadyComponent - = ReadyComponent { - rc_ann_id :: AnnotatedId UnitId, - -- | The 'OpenUnitId' for this package. At the moment, this - -- is used in only one case, which is to determine if an - -- export is of a module from this library (indefinite - -- libraries record these exports as 'OpenModule'); - -- 'rc_open_uid' can be conveniently used to test for - -- equality, whereas 'UnitId' cannot always be used in this - -- case. - rc_open_uid :: OpenUnitId, - -- | Corresponds to 'lc_cid'. Invariant: if 'rc_open_uid' - -- records a 'ComponentId', it coincides with this one. - rc_cid :: ComponentId, - -- | Corresponds to 'lc_component'. - rc_component :: Component, - -- | Corresponds to 'lc_exe_deps'. - -- Build-tools don't participate in mix-in linking. - -- (but what if they could?) - rc_exe_deps :: [AnnotatedId UnitId], - -- | Corresponds to 'lc_public'. - rc_public :: Bool, - -- | Extra metadata depending on whether or not this is an - -- indefinite library (typechecked only) or an instantiated - -- component (can be compiled). - rc_i :: Either IndefiniteComponent InstantiatedComponent - } - --- | The final, string 'UnitId' that will uniquely identify --- the compilation products of this component. -rc_uid :: ReadyComponent -> UnitId -rc_uid = ann_id . rc_ann_id - --- | Corresponds to 'lc_pkgid'. -rc_pkgid :: ReadyComponent -> PackageId -rc_pkgid = ann_pid . rc_ann_id - --- | An 'InstantiatedComponent' is a library which is fully instantiated --- (or, possibly, has no requirements at all.) -data InstantiatedComponent - = InstantiatedComponent { - -- | How this library was instantiated. - instc_insts :: [(ModuleName, Module)], - -- | Dependencies induced by 'instc_insts'. These are recorded - -- here because there isn't a convenient way otherwise to get - -- the 'PackageId' we need to fill 'componentPackageDeps' as needed. - instc_insts_deps :: [(UnitId, MungedPackageId)], - -- | The modules exported/reexported by this library. - instc_provides :: Map ModuleName Module, - -- | The dependencies which need to be passed to the compiler - -- to bring modules into scope. These always refer to installed - -- fully instantiated libraries. - instc_includes :: [ComponentInclude DefUnitId ModuleRenaming] - } - --- | An 'IndefiniteComponent' is a library with requirements --- which we will typecheck only. -data IndefiniteComponent - = IndefiniteComponent { - -- | The requirements of the library. - indefc_requires :: [ModuleName], - -- | The modules exported/reexported by this library. - indefc_provides :: Map ModuleName OpenModule, - -- | The dependencies which need to be passed to the compiler - -- to bring modules into scope. These are 'OpenUnitId' because - -- these may refer to partially instantiated libraries. - indefc_includes :: [ComponentInclude OpenUnitId ModuleRenaming] - } - --- | Compute the dependencies of a 'ReadyComponent' that should --- be recorded in the @depends@ field of 'InstalledPackageInfo'. -rc_depends :: ReadyComponent -> [(UnitId, MungedPackageId)] -rc_depends rc = ordNub $ - case rc_i rc of - Left indefc -> - map (\ci -> (abstractUnitId $ ci_id ci, toMungedPackageId ci)) - (indefc_includes indefc) - Right instc -> - map (\ci -> (unDefUnitId $ ci_id ci, toMungedPackageId ci)) - (instc_includes instc) - ++ instc_insts_deps instc - where - toMungedPackageId :: Pretty id => ComponentInclude id rn -> MungedPackageId - toMungedPackageId ci = - computeCompatPackageId - (ci_pkgid ci) - (case ci_cname ci of - CLibName name -> name - _ -> error $ prettyShow (rc_cid rc) ++ - " depends on non-library " ++ prettyShow (ci_id ci)) - --- | Get the 'MungedPackageId' of a 'ReadyComponent' IF it is --- a library. -rc_munged_id :: ReadyComponent -> MungedPackageId -rc_munged_id rc = - computeCompatPackageId - (rc_pkgid rc) - (case rc_component rc of - CLib lib -> libName lib - _ -> error "rc_munged_id: not library") - -instance Package ReadyComponent where - packageId = rc_pkgid - -instance HasUnitId ReadyComponent where - installedUnitId = rc_uid - -instance IsNode ReadyComponent where - type Key ReadyComponent = UnitId - nodeKey = rc_uid - nodeNeighbors rc = - (case rc_i rc of - Right inst | [] <- instc_insts inst - -> [] - | otherwise - -> [newSimpleUnitId (rc_cid rc)] - _ -> []) ++ - ordNub (map fst (rc_depends rc)) ++ - map ann_id (rc_exe_deps rc) - -dispReadyComponent :: ReadyComponent -> Doc -dispReadyComponent rc = - hang (text (case rc_i rc of - Left _ -> "indefinite" - Right _ -> "definite") - <+> pretty (nodeKey rc) - {- <+> dispModSubst (Map.fromList (lc_insts lc)) -} ) 4 $ - vcat [ text "depends" <+> pretty uid - | uid <- nodeNeighbors rc ] - --- | The state of 'InstM'; a mapping from 'UnitId's to their --- ready component, or @Nothing@ if its an external --- component which we don't know how to build. -type InstS = Map UnitId (Maybe ReadyComponent) - --- | A state monad for doing instantiations (can't use actual --- State because that would be an extra dependency.) -newtype InstM a = InstM { runInstM :: InstS -> (a, InstS) } - -instance Functor InstM where - fmap f (InstM m) = InstM $ \s -> let (x, s') = m s - in (f x, s') - -instance Applicative InstM where - pure a = InstM $ \s -> (a, s) - InstM f <*> InstM x = InstM $ \s -> let (f', s') = f s - (x', s'') = x s' - in (f' x', s'') - -instance Monad InstM where - return = pure - InstM m >>= f = InstM $ \s -> let (x, s') = m s - in runInstM (f x) s' - --- | Given a list of 'LinkedComponent's, expand the module graph --- so that we have an instantiated graph containing all of the --- instantiated components we need to build. --- --- Instantiation intuitively follows the following algorithm: --- --- instantiate a definite unit id p[S]: --- recursively instantiate each module M in S --- recursively instantiate modules exported by this unit --- recursively instantiate dependencies substituted by S --- --- The implementation is a bit more involved to memoize instantiation --- if we have done it already. --- --- We also call 'improveUnitId' during this process, so that fully --- instantiated components are given 'HashedUnitId'. --- -toReadyComponents - :: Map UnitId MungedPackageId - -> Map ModuleName Module -- subst for the public component - -> [LinkedComponent] - -> [ReadyComponent] -toReadyComponents pid_map subst0 comps - = catMaybes (Map.elems ready_map) - where - cmap = Map.fromList [ (lc_cid lc, lc) | lc <- comps ] - - instantiateUnitId :: ComponentId -> Map ModuleName Module - -> InstM DefUnitId - instantiateUnitId cid insts = InstM $ \s -> - case Map.lookup uid s of - Nothing -> - -- Knot tied - let (r, s') = runInstM (instantiateComponent uid cid insts) - (Map.insert uid r s) - in (def_uid, Map.insert uid r s') - Just _ -> (def_uid, s) - where - -- The mkDefUnitId here indicates that we assume - -- that Cabal handles unit id hash allocation. - -- Good thing about hashing here: map is only on string. - -- Bad thing: have to repeatedly hash. - def_uid = mkDefUnitId cid insts - uid = unDefUnitId def_uid - - instantiateComponent - :: UnitId -> ComponentId -> Map ModuleName Module - -> InstM (Maybe ReadyComponent) - instantiateComponent uid cid insts - | Just lc <- Map.lookup cid cmap = do - provides <- traverse (substModule insts) (modShapeProvides (lc_shape lc)) - -- NB: lc_sig_includes is omitted here, because we don't - -- need them to build - includes <- forM (lc_includes lc) $ \ci -> do - uid' <- substUnitId insts (ci_id ci) - return ci { ci_ann_id = fmap (const uid') (ci_ann_id ci) } - exe_deps <- traverse (substExeDep insts) (lc_exe_deps lc) - s <- InstM $ \s -> (s, s) - let getDep (Module dep_def_uid _) - | let dep_uid = unDefUnitId dep_def_uid - -- Lose DefUnitId invariant for rc_depends - = [(dep_uid, - fromMaybe err_pid $ - Map.lookup dep_uid pid_map <|> - fmap rc_munged_id (join (Map.lookup dep_uid s)))] - where - err_pid = MungedPackageId - (MungedPackageName nonExistentPackageThisIsCabalBug LMainLibName) - (mkVersion [0]) - instc = InstantiatedComponent { - instc_insts = Map.toList insts, - instc_insts_deps = concatMap getDep (Map.elems insts), - instc_provides = provides, - instc_includes = includes - -- NB: there is no dependency on the - -- indefinite version of this instantiated package here, - -- as (1) it doesn't go in depends in the - -- IPI: it's not a run time dep, and (2) - -- we don't have to tell GHC about it, it - -- will match up the ComponentId - -- automatically - } - return $ Just ReadyComponent { - rc_ann_id = (lc_ann_id lc) { ann_id = uid }, - rc_open_uid = DefiniteUnitId (unsafeMkDefUnitId uid), - rc_cid = lc_cid lc, - rc_component = lc_component lc, - rc_exe_deps = exe_deps, - rc_public = lc_public lc, - rc_i = Right instc - } - | otherwise = return Nothing - - substUnitId :: Map ModuleName Module -> OpenUnitId -> InstM DefUnitId - substUnitId _ (DefiniteUnitId uid) = - return uid - substUnitId subst (IndefFullUnitId cid insts) = do - insts' <- substSubst subst insts - instantiateUnitId cid insts' - - -- NB: NOT composition - substSubst :: Map ModuleName Module - -> Map ModuleName OpenModule - -> InstM (Map ModuleName Module) - substSubst subst insts = traverse (substModule subst) insts - - substModule :: Map ModuleName Module -> OpenModule -> InstM Module - substModule subst (OpenModuleVar mod_name) - | Just m <- Map.lookup mod_name subst = return m - | otherwise = error "substModule: non-closing substitution" - substModule subst (OpenModule uid mod_name) = do - uid' <- substUnitId subst uid - return (Module uid' mod_name) - - substExeDep :: Map ModuleName Module - -> AnnotatedId OpenUnitId -> InstM (AnnotatedId UnitId) - substExeDep insts exe_aid = do - exe_uid' <- substUnitId insts (ann_id exe_aid) - return exe_aid { ann_id = unDefUnitId exe_uid' } - - indefiniteUnitId :: ComponentId -> InstM UnitId - indefiniteUnitId cid = do - let uid = newSimpleUnitId cid - r <- indefiniteComponent uid cid - InstM $ \s -> (uid, Map.insert uid r s) - - indefiniteComponent :: UnitId -> ComponentId -> InstM (Maybe ReadyComponent) - indefiniteComponent uid cid - | Just lc <- Map.lookup cid cmap = do - -- We're going to process includes, in case some of them - -- are fully definite even without any substitution. We - -- want to build those too; see #5634. - inst_includes <- forM (lc_includes lc) $ \ci -> - if Set.null (openUnitIdFreeHoles (ci_id ci)) - then do uid' <- substUnitId Map.empty (ci_id ci) - return $ ci { ci_ann_id = fmap (const (DefiniteUnitId uid')) (ci_ann_id ci) } - else return ci - exe_deps <- traverse (substExeDep Map.empty) (lc_exe_deps lc) - let indefc = IndefiniteComponent { - indefc_requires = map fst (lc_insts lc), - indefc_provides = modShapeProvides (lc_shape lc), - indefc_includes = inst_includes ++ lc_sig_includes lc - } - return $ Just ReadyComponent { - rc_ann_id = (lc_ann_id lc) { ann_id = uid }, - rc_cid = lc_cid lc, - rc_open_uid = lc_uid lc, - rc_component = lc_component lc, - -- It's always fully built - rc_exe_deps = exe_deps, - rc_public = lc_public lc, - rc_i = Left indefc - } - | otherwise = return Nothing - - ready_map = snd $ runInstM work Map.empty - - work - -- Top-level instantiation per subst0 - | not (Map.null subst0) - , [lc] <- filter lc_public (Map.elems cmap) - = do _ <- instantiateUnitId (lc_cid lc) subst0 - return () - | otherwise - = forM_ (Map.elems cmap) $ \lc -> - if null (lc_insts lc) - then instantiateUnitId (lc_cid lc) Map.empty >> return () - else indefiniteUnitId (lc_cid lc) >> return () diff --git a/cabal/Cabal/Distribution/Backpack/UnifyM.hs b/cabal/Cabal/Distribution/Backpack/UnifyM.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Backpack/UnifyM.hs +++ /dev/null @@ -1,627 +0,0 @@ -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE ScopedTypeVariables #-} --- | See -module Distribution.Backpack.UnifyM ( - -- * Unification monad - UnifyM, - runUnifyM, - failWith, - addErr, - failIfErrs, - tryM, - addErrContext, - addErrContextM, - liftST, - - UnifEnv(..), - getUnifEnv, - - -- * Modules and unit IDs - ModuleU, - ModuleU'(..), - convertModule, - convertModuleU, - - UnitIdU, - UnitIdU'(..), - convertUnitId, - convertUnitIdU, - - ModuleSubstU, - convertModuleSubstU, - convertModuleSubst, - - ModuleScopeU, - emptyModuleScopeU, - convertModuleScopeU, - - ModuleWithSourceU, - - convertInclude, - convertModuleProvides, - convertModuleProvidesU, - -) where - -import Prelude () -import Distribution.Compat.Prelude hiding (mod) - -import Distribution.Backpack.ModuleShape -import Distribution.Backpack.ModuleScope -import Distribution.Backpack.ModSubst -import Distribution.Backpack.FullUnitId -import Distribution.Backpack - -import qualified Distribution.Utils.UnionFind as UnionFind -import Distribution.ModuleName -import Distribution.Package -import Distribution.PackageDescription -import Distribution.Pretty -import Distribution.Types.IncludeRenaming -import Distribution.Types.ComponentInclude -import Distribution.Types.AnnotatedId -import Distribution.Types.ModuleRenaming -import Distribution.Verbosity - -import Data.STRef -import Data.Traversable -import Control.Monad.ST -import qualified Data.Map as Map -import qualified Data.Set as Set -import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap -import Text.PrettyPrint - --- TODO: more detailed trace output on high verbosity would probably --- be appreciated by users debugging unification errors. Collect --- some good examples! - -data ErrMsg = ErrMsg { - err_msg :: Doc, - err_ctx :: [Doc] - } -type MsgDoc = Doc - -renderErrMsg :: ErrMsg -> MsgDoc -renderErrMsg ErrMsg { err_msg = msg, err_ctx = ctx } = - msg $$ vcat ctx - --- | The unification monad, this monad encapsulates imperative --- unification. -newtype UnifyM s a = UnifyM { unUnifyM :: UnifEnv s -> ST s (Maybe a) } - --- | Run a computation in the unification monad. -runUnifyM :: Verbosity -> ComponentId -> FullDb -> (forall s. UnifyM s a) -> Either [MsgDoc] a -runUnifyM verbosity self_cid db m - = runST $ do i <- newSTRef 0 - hmap <- newSTRef Map.empty - errs <- newSTRef [] - mb_r <- unUnifyM m UnifEnv { - unify_uniq = i, - unify_reqs = hmap, - unify_self_cid = self_cid, - unify_verbosity = verbosity, - unify_ctx = [], - unify_db = db, - unify_errs = errs } - final_errs <- readSTRef errs - case mb_r of - Just x | null final_errs -> return (Right x) - _ -> return (Left (map renderErrMsg (reverse final_errs))) --- NB: GHC 7.6 throws a hissy fit if you pattern match on 'm'. - -type ErrCtx s = MsgDoc - --- | The unification environment. -data UnifEnv s = UnifEnv { - -- | A supply of unique integers to label 'UnitIdU' - -- cells. This is used to determine loops in unit - -- identifiers (which can happen with mutual recursion.) - unify_uniq :: UnifRef s UnitIdUnique, - -- | The set of requirements in scope. When - -- a provision is brought into scope, we unify with - -- the requirement at the same module name to fill it. - -- This mapping grows monotonically. - unify_reqs :: UnifRef s (Map ModuleName (ModuleU s)), - -- | Component id of the unit we're linking. We use this - -- to detect if we fill a requirement with a local module, - -- which in principle should be OK but is not currently - -- supported by GHC. - unify_self_cid :: ComponentId, - -- | How verbose the error message should be - unify_verbosity :: Verbosity, - -- | The error reporting context - unify_ctx :: [ErrCtx s], - -- | The package index for expanding unit identifiers - unify_db :: FullDb, - -- | Accumulated errors - unify_errs :: UnifRef s [ErrMsg] - } - -instance Functor (UnifyM s) where - fmap f (UnifyM m) = UnifyM (fmap (fmap (fmap f)) m) - -instance Applicative (UnifyM s) where - pure = UnifyM . pure . pure . pure - UnifyM f <*> UnifyM x = UnifyM $ \r -> do - f' <- f r - case f' of - Nothing -> return Nothing - Just f'' -> do - x' <- x r - case x' of - Nothing -> return Nothing - Just x'' -> return (Just (f'' x'')) - -instance Monad (UnifyM s) where - return = pure - UnifyM m >>= f = UnifyM $ \r -> do - x <- m r - case x of - Nothing -> return Nothing - Just x' -> unUnifyM (f x') r - --- | Lift a computation from 'ST' monad to 'UnifyM' monad. --- Internal use only. -liftST :: ST s a -> UnifyM s a -liftST m = UnifyM $ \_ -> fmap Just m - -addErr :: MsgDoc -> UnifyM s () -addErr msg = do - env <- getUnifEnv - let err = ErrMsg { - err_msg = msg, - err_ctx = unify_ctx env - } - liftST $ modifySTRef (unify_errs env) (\errs -> err:errs) - -failWith :: MsgDoc -> UnifyM s a -failWith msg = do - addErr msg - failM - -failM :: UnifyM s a -failM = UnifyM $ \_ -> return Nothing - -failIfErrs :: UnifyM s () -failIfErrs = do - env <- getUnifEnv - errs <- liftST $ readSTRef (unify_errs env) - when (not (null errs)) failM - -tryM :: UnifyM s a -> UnifyM s (Maybe a) -tryM m = - UnifyM (\env -> do - mb_r <- unUnifyM m env - return (Just mb_r)) - -{- -otherFail :: ErrMsg -> UnifyM s a -otherFail s = UnifyM $ \_ -> return (Left s) - -unifyFail :: ErrMsg -> UnifyM s a -unifyFail err = do - env <- getUnifEnv - msg <- case unify_ctx env of - Nothing -> return (text "Unspecified unification error:" <+> err) - Just (ctx, mod1, mod2) - | unify_verbosity env > normal - -> do mod1' <- convertModuleU mod1 - mod2' <- convertModuleU mod2 - let extra = " (was unifying " ++ display mod1' - ++ " and " ++ display mod2' ++ ")" - return (ctx ++ err ++ extra) - | otherwise - -> return (ctx ++ err ++ " (for more information, pass -v flag)") - UnifyM $ \_ -> return (Left msg) --} - --- | A convenient alias for mutable references in the unification monad. -type UnifRef s a = STRef s a - --- | Imperatively read a 'UnifRef'. -readUnifRef :: UnifRef s a -> UnifyM s a -readUnifRef = liftST . readSTRef - --- | Imperatively write a 'UnifRef'. -writeUnifRef :: UnifRef s a -> a -> UnifyM s () -writeUnifRef x = liftST . writeSTRef x - --- | Get the current unification environment. -getUnifEnv :: UnifyM s (UnifEnv s) -getUnifEnv = UnifyM $ \r -> return (return r) - --- | Add a fixed message to the error context. -addErrContext :: Doc -> UnifyM s a -> UnifyM s a -addErrContext ctx m = addErrContextM ctx m - --- | Add a message to the error context. It may make monadic queries. -addErrContextM :: ErrCtx s -> UnifyM s a -> UnifyM s a -addErrContextM ctx m = - UnifyM $ \r -> unUnifyM m r { unify_ctx = ctx : unify_ctx r } - - ------------------------------------------------------------------------ --- The "unifiable" variants of the data types --- --- In order to properly do unification over infinite trees, we --- need to union find over 'Module's and 'UnitId's. The pure --- representation is ill-equipped to do this, so we convert --- from the pure representation into one which is indirected --- through union-find. 'ModuleU' handles hole variables; --- 'UnitIdU' handles mu-binders. - --- | Contents of a mutable 'ModuleU' reference. -data ModuleU' s - = ModuleU (UnitIdU s) ModuleName - | ModuleVarU ModuleName - --- | Contents of a mutable 'UnitIdU' reference. -data UnitIdU' s - = UnitIdU UnitIdUnique ComponentId (Map ModuleName (ModuleU s)) - | UnitIdThunkU DefUnitId - --- | A mutable version of 'Module' which can be imperatively unified. -type ModuleU s = UnionFind.Point s (ModuleU' s) - --- | A mutable version of 'UnitId' which can be imperatively unified. -type UnitIdU s = UnionFind.Point s (UnitIdU' s) - --- | An integer for uniquely labeling 'UnitIdU' nodes. We need --- these labels in order to efficiently serialize 'UnitIdU's into --- 'UnitId's (we use the label to check if any parent is the --- node in question, and if so insert a deBruijn index instead.) --- These labels must be unique across all 'UnitId's/'Module's which --- participate in unification! -type UnitIdUnique = Int - - ------------------------------------------------------------------------ --- Conversion to the unifiable data types - --- An environment for tracking the mu-bindings in scope. --- The invariant for a state @(m, i)@ is that [0..i] are --- keys of @m@; in fact, the @i-k@th entry is the @k@th --- de Bruijn index (this saves us from having to shift as --- we enter mu-binders.) -type MuEnv s = (IntMap (UnitIdU s), Int) - -extendMuEnv :: MuEnv s -> UnitIdU s -> MuEnv s -extendMuEnv (m, i) x = - (IntMap.insert (i + 1) x m, i + 1) - -{- -lookupMuEnv :: MuEnv s -> Int {- de Bruijn index -} -> UnitIdU s -lookupMuEnv (m, i) k = - case IntMap.lookup (i - k) m of - -- Technically a user can trigger this by giving us a - -- bad 'UnitId', so handle this better. - Nothing -> error "lookupMuEnv: out of bounds (malformed de Bruijn index)" - Just v -> v --} - -emptyMuEnv :: MuEnv s -emptyMuEnv = (IntMap.empty, -1) - --- The workhorse functions. These share an environment: --- * @UnifRef s UnitIdUnique@ - the unique label supply for 'UnitIdU' nodes --- * @UnifRef s (Map ModuleName moduleU)@ - the (lazily initialized) --- environment containing the implicitly universally quantified --- @hole:A@ binders. --- * @MuEnv@ - the environment for mu-binders. - -convertUnitId' :: MuEnv s - -> OpenUnitId - -> UnifyM s (UnitIdU s) --- TODO: this could be more lazy if we know there are no internal --- references -convertUnitId' _ (DefiniteUnitId uid) = - liftST $ UnionFind.fresh (UnitIdThunkU uid) -convertUnitId' stk (IndefFullUnitId cid insts) = do - fs <- fmap unify_uniq getUnifEnv - x <- liftST $ UnionFind.fresh (error "convertUnitId") -- tie the knot later - insts_u <- for insts $ convertModule' (extendMuEnv stk x) - u <- readUnifRef fs - writeUnifRef fs (u+1) - y <- liftST $ UnionFind.fresh (UnitIdU u cid insts_u) - liftST $ UnionFind.union x y - return y --- convertUnitId' stk (UnitIdVar i) = return (lookupMuEnv stk i) - -convertModule' :: MuEnv s - -> OpenModule -> UnifyM s (ModuleU s) -convertModule' _stk (OpenModuleVar mod_name) = do - hmap <- fmap unify_reqs getUnifEnv - hm <- readUnifRef hmap - case Map.lookup mod_name hm of - Nothing -> do mod <- liftST $ UnionFind.fresh (ModuleVarU mod_name) - writeUnifRef hmap (Map.insert mod_name mod hm) - return mod - Just mod -> return mod -convertModule' stk (OpenModule uid mod_name) = do - uid_u <- convertUnitId' stk uid - liftST $ UnionFind.fresh (ModuleU uid_u mod_name) - -convertUnitId :: OpenUnitId -> UnifyM s (UnitIdU s) -convertUnitId = convertUnitId' emptyMuEnv - -convertModule :: OpenModule -> UnifyM s (ModuleU s) -convertModule = convertModule' emptyMuEnv - - - ------------------------------------------------------------------------ --- Substitutions - --- | The mutable counterpart of a 'ModuleSubst' (not defined here). -type ModuleSubstU s = Map ModuleName (ModuleU s) - --- | Conversion of 'ModuleSubst' to 'ModuleSubstU' -convertModuleSubst :: Map ModuleName OpenModule -> UnifyM s (Map ModuleName (ModuleU s)) -convertModuleSubst = traverse convertModule - --- | Conversion of 'ModuleSubstU' to 'ModuleSubst' -convertModuleSubstU :: ModuleSubstU s -> UnifyM s OpenModuleSubst -convertModuleSubstU = traverse convertModuleU - ------------------------------------------------------------------------ --- Conversion from the unifiable data types - --- An environment for tracking candidates for adding a mu-binding. --- The invariant for a state @(m, i)@, is that if we encounter a node --- labeled @k@ such that @m[k -> v]@, then we can replace this --- node with the de Bruijn index @i-v@ referring to an enclosing --- mu-binder; furthermore, @range(m) = [0..i]@. -type MooEnv = (IntMap Int, Int) - -emptyMooEnv :: MooEnv -emptyMooEnv = (IntMap.empty, -1) - -extendMooEnv :: MooEnv -> UnitIdUnique -> MooEnv -extendMooEnv (m, i) k = (IntMap.insert k (i + 1) m, i + 1) - -lookupMooEnv :: MooEnv -> UnitIdUnique -> Maybe Int -lookupMooEnv (m, i) k = - case IntMap.lookup k m of - Nothing -> Nothing - Just v -> Just (i-v) -- de Bruijn indexize - --- The workhorse functions - -convertUnitIdU' :: MooEnv -> UnitIdU s -> UnifyM s OpenUnitId -convertUnitIdU' stk uid_u = do - x <- liftST $ UnionFind.find uid_u - case x of - UnitIdThunkU uid -> return (DefiniteUnitId uid) - UnitIdU u cid insts_u -> - case lookupMooEnv stk u of - Just _i -> - failWith (text "Unsupported mutually recursive unit identifier") - -- return (UnitIdVar i) - Nothing -> do - insts <- for insts_u $ convertModuleU' (extendMooEnv stk u) - return (IndefFullUnitId cid insts) - -convertModuleU' :: MooEnv -> ModuleU s -> UnifyM s OpenModule -convertModuleU' stk mod_u = do - mod <- liftST $ UnionFind.find mod_u - case mod of - ModuleVarU mod_name -> return (OpenModuleVar mod_name) - ModuleU uid_u mod_name -> do - uid <- convertUnitIdU' stk uid_u - return (OpenModule uid mod_name) - --- Helper functions - -convertUnitIdU :: UnitIdU s -> UnifyM s OpenUnitId -convertUnitIdU = convertUnitIdU' emptyMooEnv - -convertModuleU :: ModuleU s -> UnifyM s OpenModule -convertModuleU = convertModuleU' emptyMooEnv - --- | An empty 'ModuleScopeU'. -emptyModuleScopeU :: ModuleScopeU s -emptyModuleScopeU = (Map.empty, Map.empty) - - --- | The mutable counterpart of 'ModuleScope'. -type ModuleScopeU s = (ModuleProvidesU s, ModuleRequiresU s) --- | The mutable counterpart of 'ModuleProvides' -type ModuleProvidesU s = Map ModuleName [ModuleWithSourceU s] -type ModuleRequiresU s = ModuleProvidesU s -type ModuleWithSourceU s = WithSource (ModuleU s) - --- TODO: Deduplicate this with Distribution.Backpack.MixLink.dispSource -ci_msg :: ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming -> Doc -ci_msg ci - | ci_implicit ci = text "build-depends:" <+> pp_pn - | otherwise = text "mixins:" <+> pp_pn <+> pretty (ci_renaming ci) - where - pn = pkgName (ci_pkgid ci) - pp_pn = - case ci_cname ci of - CLibName LMainLibName -> pretty pn - CLibName (LSubLibName cn) -> pretty pn <<>> colon <<>> pretty cn - -- Shouldn't happen - cn -> pretty pn <+> parens (pretty cn) - --- | Convert a 'ModuleShape' into a 'ModuleScopeU', so we can do --- unification on it. -convertInclude - :: ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming - -> UnifyM s (ModuleScopeU s, - Either (ComponentInclude (UnitIdU s) ModuleRenaming) {- normal -} - (ComponentInclude (UnitIdU s) ModuleRenaming) {- sig -}) -convertInclude ci@(ComponentInclude { - ci_ann_id = AnnotatedId { - ann_id = (uid, ModuleShape provs reqs), - ann_pid = pid, - ann_cname = compname - }, - ci_renaming = incl@(IncludeRenaming prov_rns req_rns), - ci_implicit = implicit - }) = addErrContext (text "In" <+> ci_msg ci) $ do - let pn = packageName pid - the_source | implicit - = FromBuildDepends pn compname - | otherwise - = FromMixins pn compname incl - source = WithSource the_source - - -- Suppose our package has two requirements A and B, and - -- we include it with @requires (A as X)@ - -- There are three closely related things we compute based - -- off of @reqs@ and @reqs_rns@: - -- - -- 1. The requirement renaming (A -> X) - -- 2. The requirement substitution (A -> , B -> ) - - -- Requirement renaming. This is read straight off the syntax: - -- - -- [nothing] ==> [empty] - -- requires (B as Y) ==> B -> Y - -- - -- Requirement renamings are NOT injective: if two requirements - -- are mapped to the same name, the intent is to merge them - -- together. But they are *functions*, so @B as X, B as Y@ is - -- illegal. - - req_rename_list <- - case req_rns of - DefaultRenaming -> return [] - HidingRenaming _ -> do - -- Not valid here for requires! - addErr $ text "Unsupported syntax" <+> - quotes (text "requires hiding (...)") - return [] - ModuleRenaming rns -> return rns - - let req_rename_listmap :: Map ModuleName [ModuleName] - req_rename_listmap = - Map.fromListWith (++) [ (k,[v]) | (k,v) <- req_rename_list ] - req_rename <- sequenceA . flip Map.mapWithKey req_rename_listmap $ \k vs0 -> - case vs0 of - [] -> error "req_rename" - [v] -> return v - v:vs -> do addErr $ - text "Conflicting renamings of requirement" <+> quotes (pretty k) $$ - text "Renamed to: " <+> vcat (map pretty (v:vs)) - return v - - let req_rename_fn k = case Map.lookup k req_rename of - Nothing -> k - Just v -> v - - -- Requirement substitution. - -- - -- A -> X ==> A -> - let req_subst = fmap OpenModuleVar req_rename - - uid_u <- convertUnitId (modSubst req_subst uid) - - -- Requirement mapping. This is just taking the range of the - -- requirement substitution, and making a mapping so that it is - -- convenient to merge things together. It INCLUDES the implicit - -- mappings. - -- - -- A -> X ==> X -> , B -> - reqs_u <- convertModuleRequires . Map.fromList $ - [ (k, [source (OpenModuleVar k)]) - | k <- map req_rename_fn (Set.toList reqs) - ] - - -- Report errors if there were unused renamings - let leftover = Map.keysSet req_rename `Set.difference` reqs - unless (Set.null leftover) $ - addErr $ - hang (text "The" <+> text (showComponentName compname) <+> - text "from package" <+> quotes (pretty pid) - <+> text "does not require:") 4 - (vcat (map pretty (Set.toList leftover))) - - -- Provision computation is more complex. - -- For example, if we have: - -- - -- include p (A as X) requires (B as Y) - -- where A -> q[B=]:A - -- - -- Then we need: - -- - -- X -> [("p", q[B=]:A)] - -- - -- There are a bunch of clever ways to present the algorithm - -- but here is the simple one: - -- - -- 1. If we have a default renaming, apply req_subst - -- to provs and use that. - -- - -- 2. Otherwise, build a map by successively looking - -- up the referenced modules in the renaming in provs. - -- - -- Importantly, overlapping rename targets get accumulated - -- together. It's not an (immediate) error. - (pre_prov_scope, prov_rns') <- - case prov_rns of - DefaultRenaming -> return (Map.toList provs, prov_rns) - HidingRenaming hides -> - let hides_set = Set.fromList hides - in let r = [ (k,v) - | (k,v) <- Map.toList provs - , not (k `Set.member` hides_set) ] - -- GHC doesn't understand hiding, so expand it out! - in return (r, ModuleRenaming (map ((\x -> (x,x)).fst) r)) - ModuleRenaming rns -> do - r <- sequence - [ case Map.lookup from provs of - Just m -> return (to, m) - Nothing -> failWith $ - text "Package" <+> quotes (pretty pid) <+> - text "does not expose the module" <+> quotes (pretty from) - | (from, to) <- rns ] - return (r, prov_rns) - let prov_scope = modSubst req_subst - $ Map.fromListWith (++) - [ (k, [source v]) - | (k, v) <- pre_prov_scope ] - - provs_u <- convertModuleProvides prov_scope - - -- TODO: Assert that provs_u is empty if provs was empty - return ((provs_u, reqs_u), - -- NB: We test that requirements is not null so that - -- users can create packages with zero module exports - -- that cause some C library to linked in, etc. - (if Map.null provs && not (Set.null reqs) - then Right -- is sig - else Left) (ComponentInclude { - ci_ann_id = AnnotatedId { - ann_id = uid_u, - ann_pid = pid, - ann_cname = compname - }, - ci_renaming = prov_rns', - ci_implicit = ci_implicit ci - })) - --- | Convert a 'ModuleScopeU' to a 'ModuleScope'. -convertModuleScopeU :: ModuleScopeU s -> UnifyM s ModuleScope -convertModuleScopeU (provs_u, reqs_u) = do - provs <- convertModuleProvidesU provs_u - reqs <- convertModuleRequiresU reqs_u - -- TODO: Test that the requirements are still free. If they - -- are not, they got unified, and that's dodgy at best. - return (ModuleScope provs reqs) - --- | Convert a 'ModuleProvides' to a 'ModuleProvidesU' -convertModuleProvides :: ModuleProvides -> UnifyM s (ModuleProvidesU s) -convertModuleProvides = traverse (traverse (traverse convertModule)) - --- | Convert a 'ModuleProvidesU' to a 'ModuleProvides' -convertModuleProvidesU :: ModuleProvidesU s -> UnifyM s ModuleProvides -convertModuleProvidesU = traverse (traverse (traverse convertModuleU)) - -convertModuleRequires :: ModuleRequires -> UnifyM s (ModuleRequiresU s) -convertModuleRequires = convertModuleProvides - -convertModuleRequiresU :: ModuleRequiresU s -> UnifyM s ModuleRequires -convertModuleRequiresU = convertModuleProvidesU diff --git a/cabal/Cabal/Distribution/CabalSpecVersion.hs b/cabal/Cabal/Distribution/CabalSpecVersion.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/CabalSpecVersion.hs +++ /dev/null @@ -1,146 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.CabalSpecVersion where - -import Prelude () -import Distribution.Compat.Prelude - --- | Different Cabal-the-spec versions. --- --- We branch based on this at least in the parser. --- -data CabalSpecVersion - = CabalSpecV1_0 -- ^ this is older than 'CabalSpecV1_2' - | CabalSpecV1_2 -- ^ new syntax (sections) - | CabalSpecV1_4 - | CabalSpecV1_6 - | CabalSpecV1_8 - | CabalSpecV1_10 - | CabalSpecV1_12 - -- 1.16 -- 1.14: no changes - | CabalSpecV1_18 - | CabalSpecV1_20 - | CabalSpecV1_22 - | CabalSpecV1_24 - | CabalSpecV2_0 - | CabalSpecV2_2 - | CabalSpecV2_4 - | CabalSpecV3_0 - -- 3.2: no changes - | CabalSpecV3_4 - deriving (Eq, Ord, Show, Read, Enum, Bounded, Typeable, Data, Generic) - -instance Binary CabalSpecVersion -instance Structured CabalSpecVersion -instance NFData CabalSpecVersion where rnf = genericRnf - --- | Show cabal spec version, but not the way in the .cabal files --- --- @since 3.0.0.0 -showCabalSpecVersion :: CabalSpecVersion -> String -showCabalSpecVersion CabalSpecV3_4 = "3.4" -showCabalSpecVersion CabalSpecV3_0 = "3.0" -showCabalSpecVersion CabalSpecV2_4 = "2.4" -showCabalSpecVersion CabalSpecV2_2 = "2.2" -showCabalSpecVersion CabalSpecV2_0 = "2.0" -showCabalSpecVersion CabalSpecV1_24 = "1.24" -showCabalSpecVersion CabalSpecV1_22 = "1.22" -showCabalSpecVersion CabalSpecV1_20 = "1.20" -showCabalSpecVersion CabalSpecV1_18 = "1.18" -showCabalSpecVersion CabalSpecV1_12 = "1.12" -showCabalSpecVersion CabalSpecV1_10 = "1.10" -showCabalSpecVersion CabalSpecV1_8 = "1.8" -showCabalSpecVersion CabalSpecV1_6 = "1.6" -showCabalSpecVersion CabalSpecV1_4 = "1.4" -showCabalSpecVersion CabalSpecV1_2 = "1.2" -showCabalSpecVersion CabalSpecV1_0 = "1.0" - -cabalSpecLatest :: CabalSpecVersion -cabalSpecLatest = CabalSpecV3_4 - --- | Parse 'CabalSpecVersion' from version digits. --- --- It may fail if for recent versions the version is not exact. --- -cabalSpecFromVersionDigits :: [Int] -> Maybe CabalSpecVersion -cabalSpecFromVersionDigits v - | v == [3,4] = Just CabalSpecV3_4 - | v == [3,0] = Just CabalSpecV3_0 - | v == [2,4] = Just CabalSpecV2_4 - | v == [2,2] = Just CabalSpecV2_2 - | v == [2,0] = Just CabalSpecV2_0 - | v >= [1,25] = Nothing - | v >= [1,23] = Just CabalSpecV1_24 - | v >= [1,21] = Just CabalSpecV1_22 - | v >= [1,19] = Just CabalSpecV1_20 - | v >= [1,17] = Just CabalSpecV1_18 - | v >= [1,11] = Just CabalSpecV1_12 - | v >= [1,9] = Just CabalSpecV1_10 - | v >= [1,7] = Just CabalSpecV1_8 - | v >= [1,5] = Just CabalSpecV1_6 - | v >= [1,3] = Just CabalSpecV1_4 - | v >= [1,1] = Just CabalSpecV1_2 - | otherwise = Just CabalSpecV1_0 - --- | @since 3.4.0.0 -cabalSpecToVersionDigits :: CabalSpecVersion -> [Int] -cabalSpecToVersionDigits CabalSpecV3_4 = [3,4] -cabalSpecToVersionDigits CabalSpecV3_0 = [3,0] -cabalSpecToVersionDigits CabalSpecV2_4 = [2,4] -cabalSpecToVersionDigits CabalSpecV2_2 = [2,2] -cabalSpecToVersionDigits CabalSpecV2_0 = [2,0] -cabalSpecToVersionDigits CabalSpecV1_24 = [1,24] -cabalSpecToVersionDigits CabalSpecV1_22 = [1,22] -cabalSpecToVersionDigits CabalSpecV1_20 = [1,20] -cabalSpecToVersionDigits CabalSpecV1_18 = [1,18] -cabalSpecToVersionDigits CabalSpecV1_12 = [1,12] -cabalSpecToVersionDigits CabalSpecV1_10 = [1,10] -cabalSpecToVersionDigits CabalSpecV1_8 = [1,8] -cabalSpecToVersionDigits CabalSpecV1_6 = [1,6] -cabalSpecToVersionDigits CabalSpecV1_4 = [1,4] -cabalSpecToVersionDigits CabalSpecV1_2 = [1,2] -cabalSpecToVersionDigits CabalSpecV1_0 = [1,0] - --- | What is the minimum Cabal library version which knows how handle --- this spec version. --- --- /Note:/ this is a point where we could decouple cabal-spec and Cabal --- versions, if we ever want that. --- --- >>> cabalSpecMinimumLibraryVersion CabalSpecV3_0 --- [2,5] --- --- >>> cabalSpecMinimumLibraryVersion CabalSpecV2_4 --- [2,3] --- --- @since 3.4.0.0 -cabalSpecMinimumLibraryVersion :: CabalSpecVersion -> [Int] -cabalSpecMinimumLibraryVersion CabalSpecV1_0 = [1,0] -cabalSpecMinimumLibraryVersion csv = case cabalSpecToVersionDigits (pred csv) of - [x,y] -> [x, y+1] - xs -> xs - -specHasCommonStanzas :: CabalSpecVersion -> HasCommonStanzas -specHasCommonStanzas v = - if v >= CabalSpecV2_2 - then HasCommonStanzas - else NoCommonStanzas - -specHasElif :: CabalSpecVersion -> HasElif -specHasElif v = - if v >= CabalSpecV2_2 - then HasElif - else NoElif - -------------------------------------------------------------------------------- --- Booleans -------------------------------------------------------------------------------- - --- IDEA: make some kind of tagged booleans? -data HasElif = HasElif | NoElif - deriving (Eq, Show) - -data HasCommonStanzas = HasCommonStanzas | NoCommonStanzas - deriving (Eq, Show) - -data HasGlobstar = HasGlobstar | NoGlobstar diff --git a/cabal/Cabal/Distribution/Compat/Async.hs b/cabal/Cabal/Distribution/Compat/Async.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Compat/Async.hs +++ /dev/null @@ -1,148 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} --- | 'Async', yet using 'MVar's. --- --- Adopted from @async@ library --- Copyright (c) 2012, Simon Marlow --- Licensed under BSD-3-Clause --- --- @since 3.2.0.0 --- -module Distribution.Compat.Async ( - AsyncM, - withAsync, waitCatch, - wait, asyncThreadId, - cancel, uninterruptibleCancel, AsyncCancelled (..), - -- * Cabal extras - withAsyncNF, - ) where - -import Control.Concurrent (ThreadId, forkIO) -import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, readMVar) -import Control.DeepSeq (NFData, force) -import Control.Exception - (BlockedIndefinitelyOnMVar (..), Exception (..), SomeException (..), catch, evaluate, mask, throwIO, throwTo, try, uninterruptibleMask_) -import Control.Monad (void) -import Data.Typeable (Typeable) -import GHC.Exts (inline) - -#if MIN_VERSION_base(4,7,0) -import Control.Exception (asyncExceptionFromException, asyncExceptionToException) -#endif - --- | Async, but based on 'MVar', as we don't depend on @stm@. -data AsyncM a = Async - { asyncThreadId :: {-# UNPACK #-} !ThreadId - -- ^ Returns the 'ThreadId' of the thread running - -- the given 'Async'. - , _asyncMVar :: MVar (Either SomeException a) - } - --- | Spawn an asynchronous action in a separate thread, and pass its --- @Async@ handle to the supplied function. When the function returns --- or throws an exception, 'uninterruptibleCancel' is called on the @Async@. --- --- > withAsync action inner = mask $ \restore -> do --- > a <- async (restore action) --- > restore (inner a) `finally` uninterruptibleCancel a --- --- This is a useful variant of 'async' that ensures an @Async@ is --- never left running unintentionally. --- --- Note: a reference to the child thread is kept alive until the call --- to `withAsync` returns, so nesting many `withAsync` calls requires --- linear memory. --- -withAsync :: IO a -> (AsyncM a -> IO b) -> IO b -withAsync = inline withAsyncUsing forkIO - -withAsyncNF :: NFData a => IO a -> (AsyncM a -> IO b) -> IO b -withAsyncNF m = inline withAsyncUsing forkIO (m >>= evaluateNF) where - evaluateNF = evaluate . force - -withAsyncUsing :: (IO () -> IO ThreadId) -> IO a -> (AsyncM a -> IO b) -> IO b --- The bracket version works, but is slow. We can do better by --- hand-coding it: -withAsyncUsing doFork = \action inner -> do - var <- newEmptyMVar - mask $ \restore -> do - t <- doFork $ try (restore action) >>= putMVar var - let a = Async t var - r <- restore (inner a) `catchAll` \e -> do - uninterruptibleCancel a - throwIO e - uninterruptibleCancel a - return r - --- | Wait for an asynchronous action to complete, and return its --- value. If the asynchronous action threw an exception, then the --- exception is re-thrown by 'wait'. --- --- > wait = atomically . waitSTM --- -{-# INLINE wait #-} -wait :: AsyncM a -> IO a -wait a = do - res <- waitCatch a - case res of - Left (SomeException e) -> throwIO e - Right x -> return x - --- | Wait for an asynchronous action to complete, and return either --- @Left e@ if the action raised an exception @e@, or @Right a@ if it --- returned a value @a@. --- --- > waitCatch = atomically . waitCatchSTM --- -{-# INLINE waitCatch #-} -waitCatch :: AsyncM a -> IO (Either SomeException a) -waitCatch (Async _ var) = tryAgain (readMVar var) - where - -- See: https://github.com/simonmar/async/issues/14 - tryAgain f = f `catch` \BlockedIndefinitelyOnMVar -> f - -catchAll :: IO a -> (SomeException -> IO a) -> IO a -catchAll = catch - --- | Cancel an asynchronous action by throwing the @AsyncCancelled@ --- exception to it, and waiting for the `Async` thread to quit. --- Has no effect if the 'Async' has already completed. --- --- > cancel a = throwTo (asyncThreadId a) AsyncCancelled <* waitCatch a --- --- Note that 'cancel' will not terminate until the thread the 'Async' --- refers to has terminated. This means that 'cancel' will block for --- as long said thread blocks when receiving an asynchronous exception. --- --- For example, it could block if: --- --- * It's executing a foreign call, and thus cannot receive the asynchronous --- exception; --- * It's executing some cleanup handler after having received the exception, --- and the handler is blocking. -{-# INLINE cancel #-} -cancel :: AsyncM a -> IO () -cancel a@(Async t _) = do - throwTo t AsyncCancelled - void (waitCatch a) - --- | The exception thrown by `cancel` to terminate a thread. -data AsyncCancelled = AsyncCancelled - deriving (Show, Eq - , Typeable - ) - -instance Exception AsyncCancelled where -#if MIN_VERSION_base(4,7,0) - -- wraps in SomeAsyncException - -- See https://github.com/ghc/ghc/commit/756a970eacbb6a19230ee3ba57e24999e4157b09 - fromException = asyncExceptionFromException - toException = asyncExceptionToException -#endif - --- | Cancel an asynchronous action --- --- This is a variant of `cancel`, but it is not interruptible. -{-# INLINE uninterruptibleCancel #-} -uninterruptibleCancel :: AsyncM a -> IO () -uninterruptibleCancel = uninterruptibleMask_ . cancel diff --git a/cabal/Cabal/Distribution/Compat/Binary.hs b/cabal/Cabal/Distribution/Compat/Binary.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Compat/Binary.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 711 -{-# LANGUAGE PatternSynonyms #-} -#endif - -#ifndef MIN_VERSION_binary -#define MIN_VERSION_binary(x, y, z) 0 -#endif - -module Distribution.Compat.Binary - ( decodeOrFailIO - , decodeFileOrFail' -#if __GLASGOW_HASKELL__ >= 708 || MIN_VERSION_binary(0,7,0) - , module Data.Binary -#else - , Binary(..) - , decode, encode, encodeFile -#endif - ) where - -import Control.Exception (ErrorCall (..), catch, evaluate) -import Data.ByteString.Lazy (ByteString) - -#if __GLASGOW_HASKELL__ >= 708 || MIN_VERSION_binary(0,7,0) - -import Data.Binary - --- | Lazily reconstruct a value previously written to a file. -decodeFileOrFail' :: Binary a => FilePath -> IO (Either String a) -decodeFileOrFail' f = either (Left . snd) Right `fmap` decodeFileOrFail f - -#else - -import Data.Binary.Get -import Data.Binary.Put -import qualified Data.ByteString.Lazy as BSL - -import Distribution.Compat.Binary.Class -import Distribution.Compat.Binary.Generic () - --- | Decode a value from a lazy ByteString, reconstructing the --- original structure. --- -decode :: Binary a => ByteString -> a -decode = runGet get - --- | Encode a value using binary serialisation to a lazy ByteString. --- -encode :: Binary a => a -> ByteString -encode = runPut . put -{-# INLINE encode #-} - --- | Lazily reconstruct a value previously written to a file. -decodeFileOrFail' :: Binary a => FilePath -> IO (Either String a) -decodeFileOrFail' f = decodeOrFailIO =<< BSL.readFile f - --- | Lazily serialise a value to a file -encodeFile :: Binary a => FilePath -> a -> IO () -encodeFile f = BSL.writeFile f . encode - -#endif - -decodeOrFailIO :: Binary a => ByteString -> IO (Either String a) -decodeOrFailIO bs = - catch (evaluate (decode bs) >>= return . Right) handler - where -#if MIN_VERSION_base(4,9,0) - handler (ErrorCallWithLocation str _) = return $ Left str -#else - handler (ErrorCall str) = return $ Left str -#endif diff --git a/cabal/Cabal/Distribution/Compat/Binary/Class.hs b/cabal/Cabal/Distribution/Compat/Binary/Class.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Compat/Binary/Class.hs +++ /dev/null @@ -1,519 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE DefaultSignatures #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Compat.Binary.Class --- Copyright : Lennart Kolmodin --- License : BSD3-style (see LICENSE) --- --- Maintainer : Lennart Kolmodin --- Stability : unstable --- Portability : portable to Hugs and GHC. Requires the FFI and some flexible instances --- --- Typeclass and instances for binary serialization. --- ------------------------------------------------------------------------------ - -module Distribution.Compat.Binary.Class ( - - -- * The Binary class - Binary(..) - - -- * Support for generics - , GBinary(..) - - ) where - -import Data.Word - -import Data.Binary.Put -import Data.Binary.Get - -import Control.Applicative ((<$>), (<*>), (*>)) -import Foreign - -import Data.ByteString.Lazy (ByteString) -import qualified Data.ByteString.Lazy as L - -import Data.Char (chr,ord) -import Data.List (unfoldr) -import Data.Foldable (traverse_) - --- And needed for the instances: -import qualified Data.ByteString as B -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Data.IntMap as IntMap -import qualified Data.IntSet as IntSet -import qualified Data.Ratio as R - -import qualified Data.Tree as T - -import Data.Array.Unboxed - -import GHC.Generics - -import qualified Data.Sequence as Seq -import qualified Data.Foldable as Fold - ------------------------------------------------------------------------- - -class GBinary f where - gput :: f t -> Put - gget :: Get (f t) - --- | The 'Binary' class provides 'put' and 'get', methods to encode and --- decode a Haskell value to a lazy 'ByteString'. It mirrors the 'Read' and --- 'Show' classes for textual representation of Haskell types, and is --- suitable for serialising Haskell values to disk, over the network. --- --- For decoding and generating simple external binary formats (e.g. C --- structures), Binary may be used, but in general is not suitable --- for complex protocols. Instead use the 'Put' and 'Get' primitives --- directly. --- --- Instances of Binary should satisfy the following property: --- --- > decode . encode == id --- --- That is, the 'get' and 'put' methods should be the inverse of each --- other. A range of instances are provided for basic Haskell types. --- -class Binary t where - -- | Encode a value in the Put monad. - put :: t -> Put - -- | Decode a value in the Get monad - get :: Get t - - default put :: (Generic t, GBinary (Rep t)) => t -> Put - put = gput . from - - default get :: (Generic t, GBinary (Rep t)) => Get t - get = to `fmap` gget - ------------------------------------------------------------------------- --- Simple instances - --- The () type need never be written to disk: values of singleton type --- can be reconstructed from the type alone -instance Binary () where - put () = return () - get = return () - --- Bools are encoded as a byte in the range 0 .. 1 -instance Binary Bool where - put = putWord8 . fromIntegral . fromEnum - get = fmap (toEnum . fromIntegral) getWord8 - --- Values of type 'Ordering' are encoded as a byte in the range 0 .. 2 -instance Binary Ordering where - put = putWord8 . fromIntegral . fromEnum - get = fmap (toEnum . fromIntegral) getWord8 - ------------------------------------------------------------------------- --- Words and Ints - --- Words8s are written as bytes -instance Binary Word8 where - put = putWord8 - get = getWord8 - --- Words16s are written as 2 bytes in big-endian (network) order -instance Binary Word16 where - put = putWord16be - get = getWord16be - --- Words32s are written as 4 bytes in big-endian (network) order -instance Binary Word32 where - put = putWord32be - get = getWord32be - --- Words64s are written as 8 bytes in big-endian (network) order -instance Binary Word64 where - put = putWord64be - get = getWord64be - --- Int8s are written as a single byte. -instance Binary Int8 where - put i = put (fromIntegral i :: Word8) - get = fmap fromIntegral (get :: Get Word8) - --- Int16s are written as a 2 bytes in big endian format -instance Binary Int16 where - put i = put (fromIntegral i :: Word16) - get = fmap fromIntegral (get :: Get Word16) - --- Int32s are written as a 4 bytes in big endian format -instance Binary Int32 where - put i = put (fromIntegral i :: Word32) - get = fmap fromIntegral (get :: Get Word32) - --- Int64s are written as a 4 bytes in big endian format -instance Binary Int64 where - put i = put (fromIntegral i :: Word64) - get = fmap fromIntegral (get :: Get Word64) - ------------------------------------------------------------------------- - --- Words are are written as Word64s, that is, 8 bytes in big endian format -instance Binary Word where - put i = put (fromIntegral i :: Word64) - get = fmap fromIntegral (get :: Get Word64) - --- Ints are are written as Int64s, that is, 8 bytes in big endian format -instance Binary Int where - put i = put (fromIntegral i :: Int64) - get = fmap fromIntegral (get :: Get Int64) - ------------------------------------------------------------------------- --- --- Portable, and pretty efficient, serialisation of Integer --- - --- Fixed-size type for a subset of Integer -type SmallInt = Int32 - --- Integers are encoded in two ways: if they fit inside a SmallInt, --- they're written as a byte tag, and that value. If the Integer value --- is too large to fit in a SmallInt, it is written as a byte array, --- along with a sign and length field. - -instance Binary Integer where - - {-# INLINE put #-} - put n | n >= lo && n <= hi = do - putWord8 0 - put (fromIntegral n :: SmallInt) -- fast path - where - lo = fromIntegral (minBound :: SmallInt) :: Integer - hi = fromIntegral (maxBound :: SmallInt) :: Integer - - put n = do - putWord8 1 - put sign - put (unroll (abs n)) -- unroll the bytes - where - sign = fromIntegral (signum n) :: Word8 - - {-# INLINE get #-} - get = do - tag <- get :: Get Word8 - case tag of - 0 -> fmap fromIntegral (get :: Get SmallInt) - _ -> do sign <- get - bytes <- get - let v = roll bytes - return $! if sign == (1 :: Word8) then v else - v - --- --- Fold and unfold an Integer to and from a list of its bytes --- -unroll :: Integer -> [Word8] -unroll = unfoldr step - where - step 0 = Nothing - step i = Just (fromIntegral i, i `shiftR` 8) - -roll :: [Word8] -> Integer -roll = foldr unstep 0 - where - unstep b a = a `shiftL` 8 .|. fromIntegral b - -{- - --- --- An efficient, raw serialisation for Integer (GHC only) --- - --- TODO This instance is not architecture portable. GMP stores numbers as --- arrays of machine sized words, so the byte format is not portable across --- architectures with different endianness and word size. - -import Data.ByteString.Base (toForeignPtr,unsafePackAddress, memcpy) -import GHC.Base hiding (ord, chr) -import GHC.Prim -import GHC.Ptr (Ptr(..)) -import GHC.IOBase (IO(..)) - -instance Binary Integer where - put (S# i) = putWord8 0 *> put (I# i) - put (J# s ba) = do - putWord8 1 - put (I# s) - put (BA ba) - - get = do - b <- getWord8 - case b of - 0 -> do (I# i#) <- get - return (S# i#) - _ -> do (I# s#) <- get - (BA a#) <- get - return (J# s# a#) - -instance Binary ByteArray where - - -- Pretty safe. - put (BA ba) = - let sz = sizeofByteArray# ba -- (primitive) in *bytes* - addr = byteArrayContents# ba - bs = unsafePackAddress (I# sz) addr - in put bs -- write as a ByteString. easy, yay! - - -- Pretty scary. Should be quick though - get = do - (fp, off, n@(I# sz)) <- fmap toForeignPtr get -- so decode a ByteString - assert (off == 0) $ return $ unsafePerformIO $ do - (MBA arr) <- newByteArray sz -- and copy it into a ByteArray# - let to = byteArrayContents# (unsafeCoerce# arr) -- urk, is this safe? - withForeignPtr fp $ \from -> memcpy (Ptr to) from (fromIntegral n) - freezeByteArray arr - --- wrapper for ByteArray# -data ByteArray = BA {-# UNPACK #-} !ByteArray# -data MBA = MBA {-# UNPACK #-} !(MutableByteArray# RealWorld) - -newByteArray :: Int# -> IO MBA -newByteArray sz = IO $ \s -> - case newPinnedByteArray# sz s of { (# s', arr #) -> - (# s', MBA arr #) } - -freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray -freezeByteArray arr = IO $ \s -> - case unsafeFreezeByteArray# arr s of { (# s', arr' #) -> - (# s', BA arr' #) } - --} - -instance (Binary a,Integral a) => Binary (R.Ratio a) where - put r = put (R.numerator r) *> put (R.denominator r) - get = (R.%) <$> get <*> get - ------------------------------------------------------------------------- - --- Char is serialised as UTF-8 -instance Binary Char where - put a | c <= 0x7f = put (fromIntegral c :: Word8) - | c <= 0x7ff = do put (0xc0 .|. y) - put (0x80 .|. z) - | c <= 0xffff = do put (0xe0 .|. x) - put (0x80 .|. y) - put (0x80 .|. z) - | c <= 0x10ffff = do put (0xf0 .|. w) - put (0x80 .|. x) - put (0x80 .|. y) - put (0x80 .|. z) - | otherwise = error "Not a valid Unicode code point" - where - c = ord a - z, y, x, w :: Word8 - z = fromIntegral (c .&. 0x3f) - y = fromIntegral (shiftR c 6 .&. 0x3f) - x = fromIntegral (shiftR c 12 .&. 0x3f) - w = fromIntegral (shiftR c 18 .&. 0x7) - - get = do - let getByte = fmap (fromIntegral :: Word8 -> Int) get - shiftL6 = flip shiftL 6 :: Int -> Int - w <- getByte - r <- case () of - _ | w < 0x80 -> return w - | w < 0xe0 -> do - x <- fmap (xor 0x80) getByte - return (x .|. shiftL6 (xor 0xc0 w)) - | w < 0xf0 -> do - x <- fmap (xor 0x80) getByte - y <- fmap (xor 0x80) getByte - return (y .|. shiftL6 (x .|. shiftL6 - (xor 0xe0 w))) - | otherwise -> do - x <- fmap (xor 0x80) getByte - y <- fmap (xor 0x80) getByte - z <- fmap (xor 0x80) getByte - return (z .|. shiftL6 (y .|. shiftL6 - (x .|. shiftL6 (xor 0xf0 w)))) - return $! chr r - ------------------------------------------------------------------------- --- Instances for the first few tuples - -instance (Binary a, Binary b) => Binary (a,b) where - put (a,b) = put a *> put b - get = (,) <$> get <*> get - -instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where - put (a,b,c) = put a *> put b *> put c - get = (,,) <$> get <*> get <*> get - -instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where - put (a,b,c,d) = put a *> put b *> put c *> put d - get = (,,,) <$> get <*> get <*> get <*> get - -instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d,e) where - put (a,b,c,d,e) = put a *> put b *> put c *> put d *> put e - get = (,,,,) <$> get <*> get <*> get <*> get <*> get - --- --- and now just recurse: --- - -instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f) - => Binary (a,b,c,d,e,f) where - put (a,b,c,d,e,f) = put (a,(b,c,d,e,f)) - get = do (a,(b,c,d,e,f)) <- get ; return (a,b,c,d,e,f) - -instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f, Binary g) - => Binary (a,b,c,d,e,f,g) where - put (a,b,c,d,e,f,g) = put (a,(b,c,d,e,f,g)) - get = do (a,(b,c,d,e,f,g)) <- get ; return (a,b,c,d,e,f,g) - -instance (Binary a, Binary b, Binary c, Binary d, Binary e, - Binary f, Binary g, Binary h) - => Binary (a,b,c,d,e,f,g,h) where - put (a,b,c,d,e,f,g,h) = put (a,(b,c,d,e,f,g,h)) - get = do (a,(b,c,d,e,f,g,h)) <- get ; return (a,b,c,d,e,f,g,h) - -instance (Binary a, Binary b, Binary c, Binary d, Binary e, - Binary f, Binary g, Binary h, Binary i) - => Binary (a,b,c,d,e,f,g,h,i) where - put (a,b,c,d,e,f,g,h,i) = put (a,(b,c,d,e,f,g,h,i)) - get = do (a,(b,c,d,e,f,g,h,i)) <- get ; return (a,b,c,d,e,f,g,h,i) - -instance (Binary a, Binary b, Binary c, Binary d, Binary e, - Binary f, Binary g, Binary h, Binary i, Binary j) - => Binary (a,b,c,d,e,f,g,h,i,j) where - put (a,b,c,d,e,f,g,h,i,j) = put (a,(b,c,d,e,f,g,h,i,j)) - get = do (a,(b,c,d,e,f,g,h,i,j)) <- get ; return (a,b,c,d,e,f,g,h,i,j) - ------------------------------------------------------------------------- --- Container types - -instance Binary a => Binary [a] where - put l = put (length l) *> traverse_ put l - get = do n <- get :: Get Int - getMany n - --- | 'getMany n' get 'n' elements in order, without blowing the stack. -getMany :: Binary a => Int -> Get [a] -getMany n = go [] n - where - go xs 0 = return $! reverse xs - go xs i = do x <- get - -- we must seq x to avoid stack overflows due to laziness in - -- (>>=) - x `seq` go (x:xs) (i-1) -{-# INLINE getMany #-} - -instance (Binary a) => Binary (Maybe a) where - put Nothing = putWord8 0 - put (Just x) = putWord8 1 *> put x - get = do - w <- getWord8 - case w of - 0 -> return Nothing - _ -> fmap Just get - -instance (Binary a, Binary b) => Binary (Either a b) where - put (Left a) = putWord8 0 *> put a - put (Right b) = putWord8 1 *> put b - get = do - w <- getWord8 - case w of - 0 -> fmap Left get - _ -> fmap Right get - ------------------------------------------------------------------------- --- ByteStrings (have specially efficient instances) - -instance Binary B.ByteString where - put bs = do put (B.length bs) - putByteString bs - get = get >>= getByteString - --- --- Using old versions of fps, this is a type synonym, and non portable --- --- Requires 'flexible instances' --- -instance Binary ByteString where - put bs = do put (fromIntegral (L.length bs) :: Int) - putLazyByteString bs - get = get >>= getLazyByteString - ------------------------------------------------------------------------- --- Maps and Sets - -instance (Binary a) => Binary (Set.Set a) where - put s = put (Set.size s) *> traverse_ put (Set.toAscList s) - get = fmap Set.fromDistinctAscList get - -instance (Binary k, Binary e) => Binary (Map.Map k e) where - put m = put (Map.size m) *> traverse_ put (Map.toAscList m) - get = fmap Map.fromDistinctAscList get - -instance Binary IntSet.IntSet where - put s = put (IntSet.size s) *> traverse_ put (IntSet.toAscList s) - get = fmap IntSet.fromDistinctAscList get - -instance (Binary e) => Binary (IntMap.IntMap e) where - put m = put (IntMap.size m) *> traverse_ put (IntMap.toAscList m) - get = fmap IntMap.fromDistinctAscList get - ------------------------------------------------------------------------- --- Queues and Sequences - -instance (Binary e) => Binary (Seq.Seq e) where - put s = put (Seq.length s) *> Fold.traverse_ put s - get = do n <- get :: Get Int - rep Seq.empty n get - where rep xs 0 _ = return $! xs - rep xs n g = xs `seq` n `seq` do - x <- g - rep (xs Seq.|> x) (n-1) g - ------------------------------------------------------------------------- --- Floating point - -instance Binary Double where - put d = put (decodeFloat d) - get = encodeFloat <$> get <*> get - -instance Binary Float where - put f = put (decodeFloat f) - get = encodeFloat <$> get <*> get - ------------------------------------------------------------------------- --- Trees - -instance (Binary e) => Binary (T.Tree e) where - put (T.Node r s) = put r *> put s - get = T.Node <$> get <*> get - ------------------------------------------------------------------------- --- Arrays - -instance (Binary i, Ix i, Binary e) => Binary (Array i e) where - put a = do - put (bounds a) - put (rangeSize $ bounds a) -- write the length - traverse_ put (elems a) -- now the elems. - get = do - bs <- get - n <- get -- read the length - xs <- getMany n -- now the elems. - return (listArray bs xs) - --- --- The IArray UArray e constraint is non portable. Requires flexible instances --- -instance (Binary i, Ix i, Binary e, IArray UArray e) => Binary (UArray i e) where - put a = do - put (bounds a) - put (rangeSize $ bounds a) -- now write the length - traverse_ put (elems a) - get = do - bs <- get - n <- get - xs <- getMany n - return (listArray bs xs) diff --git a/cabal/Cabal/Distribution/Compat/Binary/Generic.hs b/cabal/Cabal/Distribution/Compat/Binary/Generic.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Compat/Binary/Generic.hs +++ /dev/null @@ -1,128 +0,0 @@ -{-# LANGUAGE BangPatterns, CPP, FlexibleInstances, KindSignatures, - ScopedTypeVariables, Trustworthy, TypeOperators, TypeSynonymInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Compat.Binary.Generic --- Copyright : Bryan O'Sullivan --- License : BSD3-style (see LICENSE) --- --- Maintainer : Bryan O'Sullivan --- Stability : unstable --- Portability : Only works with GHC 7.2 and newer --- --- Instances for supporting GHC generics. --- ------------------------------------------------------------------------------ -module Distribution.Compat.Binary.Generic - ( - ) where - -import Control.Applicative -import Distribution.Compat.Binary.Class -import Data.Binary.Get -import Data.Binary.Put -import Data.Bits -import Data.Word -import GHC.Generics - --- Type without constructors -instance GBinary V1 where - gput _ = return () - gget = return undefined - --- Constructor without arguments -instance GBinary U1 where - gput U1 = return () - gget = return U1 - --- Product: constructor with parameters -instance (GBinary a, GBinary b) => GBinary (a :*: b) where - gput (x :*: y) = gput x >> gput y - gget = (:*:) <$> gget <*> gget - --- Metadata (constructor name, etc) -instance GBinary a => GBinary (M1 i c a) where - gput = gput . unM1 - gget = M1 <$> gget - --- Constants, additional parameters, and rank-1 recursion -instance Binary a => GBinary (K1 i a) where - gput = put . unK1 - gget = K1 <$> get - --- Borrowed from the cereal package. - --- The following GBinary instance for sums has support for serializing --- types with up to 2^64-1 constructors. It will use the minimal --- number of bytes needed to encode the constructor. For example when --- a type has 2^8 constructors or less it will use a single byte to --- encode the constructor. If it has 2^16 constructors or less it will --- use two bytes, and so on till 2^64-1. - -#define GUARD(WORD) (size - 1) <= fromIntegral (maxBound :: WORD) -#define PUTSUM(WORD) GUARD(WORD) = putSum (0 :: WORD) (fromIntegral size) -#define GETSUM(WORD) GUARD(WORD) = (get :: Get WORD) >>= checkGetSum (fromIntegral size) - -instance ( GSum a, GSum b - , GBinary a, GBinary b - , SumSize a, SumSize b) => GBinary (a :+: b) where - gput | PUTSUM(Word8) | PUTSUM(Word16) | PUTSUM(Word32) | PUTSUM(Word64) - | otherwise = sizeError "encode" size - where - size = unTagged (sumSize :: Tagged (a :+: b) Word64) - - gget | GETSUM(Word8) | GETSUM(Word16) | GETSUM(Word32) | GETSUM(Word64) - | otherwise = sizeError "decode" size - where - size = unTagged (sumSize :: Tagged (a :+: b) Word64) - -sizeError :: Show size => String -> size -> error -sizeError s size = - error $ "Can't " ++ s ++ " a type with " ++ show size ++ " constructors" - ------------------------------------------------------------------------- - -checkGetSum :: (Ord word, Num word, Bits word, GSum f) - => word -> word -> Get (f a) -checkGetSum size code | code < size = getSum code size - | otherwise = fail "Unknown encoding for constructor" -{-# INLINE checkGetSum #-} - -class GSum f where - getSum :: (Ord word, Num word, Bits word) => word -> word -> Get (f a) - putSum :: (Num w, Bits w, Binary w) => w -> w -> f a -> Put - -instance (GSum a, GSum b, GBinary a, GBinary b) => GSum (a :+: b) where - getSum !code !size | code < sizeL = L1 <$> getSum code sizeL - | otherwise = R1 <$> getSum (code - sizeL) sizeR - where - sizeL = size `shiftR` 1 - sizeR = size - sizeL - - putSum !code !size s = case s of - L1 x -> putSum code sizeL x - R1 x -> putSum (code + sizeL) sizeR x - where - sizeL = size `shiftR` 1 - sizeR = size - sizeL - -instance GBinary a => GSum (C1 c a) where - getSum _ _ = gget - - putSum !code _ x = put code *> gput x - ------------------------------------------------------------------------- - -class SumSize f where - sumSize :: Tagged f Word64 - -newtype Tagged (s :: * -> *) b = Tagged {unTagged :: b} - -instance (SumSize a, SumSize b) => SumSize (a :+: b) where - sumSize = Tagged $ unTagged (sumSize :: Tagged a Word64) + - unTagged (sumSize :: Tagged b Word64) - -instance SumSize (C1 c a) where - sumSize = Tagged 1 diff --git a/cabal/Cabal/Distribution/Compat/CharParsing.hs b/cabal/Cabal/Distribution/Compat/CharParsing.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Compat/CharParsing.hs +++ /dev/null @@ -1,357 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -fspec-constr -fspec-constr-count=8 #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Compat.CharParsing --- Copyright : (c) Edward Kmett 2011 --- License : BSD3 --- --- Maintainer : ekmett@gmail.com --- Stability : experimental --- Portability : non-portable --- --- Parsers for character streams --- --- Originally in @parsers@ package. --- ------------------------------------------------------------------------------ -module Distribution.Compat.CharParsing - ( - -- * Combinators - oneOf -- :: CharParsing m => [Char] -> m Char - , noneOf -- :: CharParsing m => [Char] -> m Char - , spaces -- :: CharParsing m => m () - , space -- :: CharParsing m => m Char - , newline -- :: CharParsing m => m Char - , tab -- :: CharParsing m => m Char - , upper -- :: CharParsing m => m Char - , lower -- :: CharParsing m => m Char - , alphaNum -- :: CharParsing m => m Char - , letter -- :: CharParsing m => m Char - , digit -- :: CharParsing m => m Char - , hexDigit -- :: CharParsing m => m Char - , octDigit -- :: CharParsing m => m Char - , satisfyRange -- :: CharParsing m => Char -> Char -> m Char - -- * Class - , CharParsing(..) - -- * Cabal additions - , integral - , signedIntegral - , munch1 - , munch - , skipSpaces1 - , module Distribution.Compat.Parsing - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.State.Lazy as Lazy -import Control.Monad.Trans.State.Strict as Strict -import Control.Monad.Trans.Writer.Lazy as Lazy -import Control.Monad.Trans.Writer.Strict as Strict -import Control.Monad.Trans.RWS.Lazy as Lazy -import Control.Monad.Trans.RWS.Strict as Strict -import Control.Monad.Trans.Reader (ReaderT (..)) -import Control.Monad.Trans.Identity (IdentityT (..)) -import Data.Char -import Data.Text (Text, unpack) - -import qualified Text.Parsec as Parsec - -import Distribution.Compat.Parsing - --- | @oneOf cs@ succeeds if the current character is in the supplied --- list of characters @cs@. Returns the parsed character. See also --- 'satisfy'. --- --- > vowel = oneOf "aeiou" -oneOf :: CharParsing m => [Char] -> m Char -oneOf xs = satisfy (\c -> c `elem` xs) -{-# INLINE oneOf #-} - --- | As the dual of 'oneOf', @noneOf cs@ succeeds if the current --- character is /not/ in the supplied list of characters @cs@. Returns the --- parsed character. --- --- > consonant = noneOf "aeiou" -noneOf :: CharParsing m => [Char] -> m Char -noneOf xs = satisfy (\c -> c `notElem` xs) -{-# INLINE noneOf #-} - --- | Skips /zero/ or more white space characters. See also 'skipMany'. -spaces :: CharParsing m => m () -spaces = skipMany space "white space" -{-# INLINE spaces #-} - --- | Parses a white space character (any character which satisfies 'isSpace') --- Returns the parsed character. -space :: CharParsing m => m Char -space = satisfy isSpace "space" -{-# INLINE space #-} - --- | Parses a newline character (\'\\n\'). Returns a newline character. -newline :: CharParsing m => m Char -newline = char '\n' "new-line" -{-# INLINE newline #-} - --- | Parses a tab character (\'\\t\'). Returns a tab character. -tab :: CharParsing m => m Char -tab = char '\t' "tab" -{-# INLINE tab #-} - --- | Parses an upper case letter. Returns the parsed character. -upper :: CharParsing m => m Char -upper = satisfy isUpper "uppercase letter" -{-# INLINE upper #-} - --- | Parses a lower case character. Returns the parsed character. -lower :: CharParsing m => m Char -lower = satisfy isLower "lowercase letter" -{-# INLINE lower #-} - --- | Parses a letter or digit. Returns the parsed character. -alphaNum :: CharParsing m => m Char -alphaNum = satisfy isAlphaNum "letter or digit" -{-# INLINE alphaNum #-} - --- | Parses a letter (an upper case or lower case character). Returns the --- parsed character. -letter :: CharParsing m => m Char -letter = satisfy isAlpha "letter" -{-# INLINE letter #-} - --- | Parses a digit. Returns the parsed character. -digit :: CharParsing m => m Char -digit = satisfy isDigit "digit" -{-# INLINE digit #-} - --- | Parses a hexadecimal digit (a digit or a letter between \'a\' and --- \'f\' or \'A\' and \'F\'). Returns the parsed character. -hexDigit :: CharParsing m => m Char -hexDigit = satisfy isHexDigit "hexadecimal digit" -{-# INLINE hexDigit #-} - --- | Parses an octal digit (a character between \'0\' and \'7\'). Returns --- the parsed character. -octDigit :: CharParsing m => m Char -octDigit = satisfy isOctDigit "octal digit" -{-# INLINE octDigit #-} - -satisfyRange :: CharParsing m => Char -> Char -> m Char -satisfyRange a z = satisfy (\c -> c >= a && c <= z) -{-# INLINE satisfyRange #-} - --- | Additional functionality needed to parse character streams. -class Parsing m => CharParsing m where - -- | Parse a single character of the input, with UTF-8 decoding - satisfy :: (Char -> Bool) -> m Char - - -- | @char c@ parses a single character @c@. Returns the parsed - -- character (i.e. @c@). - -- - -- /e.g./ - -- - -- @semiColon = 'char' ';'@ - char :: Char -> m Char - char c = satisfy (c ==) show [c] - {-# INLINE char #-} - - -- | @notChar c@ parses any single character other than @c@. Returns the parsed - -- character. - notChar :: Char -> m Char - notChar c = satisfy (c /=) - {-# INLINE notChar #-} - - -- | This parser succeeds for any character. Returns the parsed character. - anyChar :: m Char - anyChar = satisfy (const True) - {-# INLINE anyChar #-} - - -- | @string s@ parses a sequence of characters given by @s@. Returns - -- the parsed string (i.e. @s@). - -- - -- > divOrMod = string "div" - -- > <|> string "mod" - string :: String -> m String - string s = s <$ try (traverse_ char s) show s - {-# INLINE string #-} - - -- | @text t@ parses a sequence of characters determined by the text @t@ Returns - -- the parsed text fragment (i.e. @t@). - -- - -- Using @OverloadedStrings@: - -- - -- > divOrMod = text "div" - -- > <|> text "mod" - text :: Text -> m Text - text t = t <$ string (unpack t) - {-# INLINE text #-} - -instance (CharParsing m, MonadPlus m) => CharParsing (Lazy.StateT s m) where - satisfy = lift . satisfy - {-# INLINE satisfy #-} - char = lift . char - {-# INLINE char #-} - notChar = lift . notChar - {-# INLINE notChar #-} - anyChar = lift anyChar - {-# INLINE anyChar #-} - string = lift . string - {-# INLINE string #-} - text = lift . text - {-# INLINE text #-} - -instance (CharParsing m, MonadPlus m) => CharParsing (Strict.StateT s m) where - satisfy = lift . satisfy - {-# INLINE satisfy #-} - char = lift . char - {-# INLINE char #-} - notChar = lift . notChar - {-# INLINE notChar #-} - anyChar = lift anyChar - {-# INLINE anyChar #-} - string = lift . string - {-# INLINE string #-} - text = lift . text - {-# INLINE text #-} - -instance (CharParsing m, MonadPlus m) => CharParsing (ReaderT e m) where - satisfy = lift . satisfy - {-# INLINE satisfy #-} - char = lift . char - {-# INLINE char #-} - notChar = lift . notChar - {-# INLINE notChar #-} - anyChar = lift anyChar - {-# INLINE anyChar #-} - string = lift . string - {-# INLINE string #-} - text = lift . text - {-# INLINE text #-} - -instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Strict.WriterT w m) where - satisfy = lift . satisfy - {-# INLINE satisfy #-} - char = lift . char - {-# INLINE char #-} - notChar = lift . notChar - {-# INLINE notChar #-} - anyChar = lift anyChar - {-# INLINE anyChar #-} - string = lift . string - {-# INLINE string #-} - text = lift . text - {-# INLINE text #-} - -instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Lazy.WriterT w m) where - satisfy = lift . satisfy - {-# INLINE satisfy #-} - char = lift . char - {-# INLINE char #-} - notChar = lift . notChar - {-# INLINE notChar #-} - anyChar = lift anyChar - {-# INLINE anyChar #-} - string = lift . string - {-# INLINE string #-} - text = lift . text - {-# INLINE text #-} - -instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Lazy.RWST r w s m) where - satisfy = lift . satisfy - {-# INLINE satisfy #-} - char = lift . char - {-# INLINE char #-} - notChar = lift . notChar - {-# INLINE notChar #-} - anyChar = lift anyChar - {-# INLINE anyChar #-} - string = lift . string - {-# INLINE string #-} - text = lift . text - {-# INLINE text #-} - -instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Strict.RWST r w s m) where - satisfy = lift . satisfy - {-# INLINE satisfy #-} - char = lift . char - {-# INLINE char #-} - notChar = lift . notChar - {-# INLINE notChar #-} - anyChar = lift anyChar - {-# INLINE anyChar #-} - string = lift . string - {-# INLINE string #-} - text = lift . text - {-# INLINE text #-} - -instance (CharParsing m, MonadPlus m) => CharParsing (IdentityT m) where - satisfy = lift . satisfy - {-# INLINE satisfy #-} - char = lift . char - {-# INLINE char #-} - notChar = lift . notChar - {-# INLINE notChar #-} - anyChar = lift anyChar - {-# INLINE anyChar #-} - string = lift . string - {-# INLINE string #-} - text = lift . text - {-# INLINE text #-} - -instance Parsec.Stream s m Char => CharParsing (Parsec.ParsecT s u m) where - satisfy = Parsec.satisfy - char = Parsec.char - notChar c = Parsec.satisfy (/= c) - anyChar = Parsec.anyChar - string = Parsec.string - -------------------------------------------------------------------------------- --- Our additions -------------------------------------------------------------------------------- - -integral :: (CharParsing m, Integral a) => m a -integral = toNumber <$> some d "integral" - where - toNumber = foldl' (\a b -> a * 10 + b) 0 - d = f <$> satisfyRange '0' '9' - f '0' = 0 - f '1' = 1 - f '2' = 2 - f '3' = 3 - f '4' = 4 - f '5' = 5 - f '6' = 6 - f '7' = 7 - f '8' = 8 - f '9' = 9 - f _ = error "panic! integral" -{-# INLINE integral #-} - --- | Accepts negative (starting with @-@) and positive (without sign) integral --- numbers. --- --- @since 3.4.0.0 -signedIntegral :: (CharParsing m, Integral a) => m a -signedIntegral = negate <$ char '-' <*> integral <|> integral -{-# INLINE signedIntegral #-} - --- | Greedily munch characters while predicate holds. --- Require at least one character. -munch1 :: CharParsing m => (Char -> Bool) -> m String -munch1 = some . satisfy -{-# INLINE munch1 #-} - --- | Greedely munch characters while predicate holds. --- Always succeeds. -munch :: CharParsing m => (Char -> Bool) -> m String -munch = many . satisfy -{-# INLINE munch #-} - -skipSpaces1 :: CharParsing m => m () -skipSpaces1 = skipSome space -{-# INLINE skipSpaces1 #-} diff --git a/cabal/Cabal/Distribution/Compat/CopyFile.hs b/cabal/Cabal/Distribution/Compat/CopyFile.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Compat/CopyFile.hs +++ /dev/null @@ -1,250 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# OPTIONS_HADDOCK hide #-} -module Distribution.Compat.CopyFile ( - copyFile, - copyFileChanged, - filesEqual, - copyOrdinaryFile, - copyExecutableFile, - setFileOrdinary, - setFileExecutable, - setDirOrdinary, - ) where - -import Prelude () -import Distribution.Compat.Prelude - -#ifndef mingw32_HOST_OS -import Distribution.Compat.Internal.TempFile - -import Control.Exception - ( bracketOnError ) -import qualified Data.ByteString.Lazy as BSL -import System.IO.Error - ( ioeSetLocation ) -import System.Directory - ( doesFileExist, renameFile, removeFile ) -import System.FilePath - ( takeDirectory ) -import System.IO - ( IOMode(ReadMode), hClose, hGetBuf, hPutBuf, hFileSize - , withBinaryFile ) -import Foreign - ( allocaBytes ) - -import System.Posix.Types - ( FileMode ) -import System.Posix.Internals - ( c_chmod, withFilePath ) -import Foreign.C - ( throwErrnoPathIfMinus1_ ) - -#else /* else mingw32_HOST_OS */ - -import qualified Data.ByteString.Lazy as BSL -import System.IO.Error - ( ioeSetLocation ) -import System.Directory - ( doesFileExist ) -import System.FilePath - ( addTrailingPathSeparator - , hasTrailingPathSeparator - , isPathSeparator - , isRelative - , joinDrive - , joinPath - , pathSeparator - , pathSeparators - , splitDirectories - , splitDrive - ) -import System.IO - ( IOMode(ReadMode), hFileSize - , withBinaryFile ) - -import qualified System.Win32.File as Win32 ( copyFile ) -#endif /* mingw32_HOST_OS */ - -copyOrdinaryFile, copyExecutableFile :: FilePath -> FilePath -> IO () -copyOrdinaryFile src dest = copyFile src dest >> setFileOrdinary dest -copyExecutableFile src dest = copyFile src dest >> setFileExecutable dest - -setFileOrdinary, setFileExecutable, setDirOrdinary :: FilePath -> IO () -#ifndef mingw32_HOST_OS -setFileOrdinary path = setFileMode path 0o644 -- file perms -rw-r--r-- -setFileExecutable path = setFileMode path 0o755 -- file perms -rwxr-xr-x - -setFileMode :: FilePath -> FileMode -> IO () -setFileMode name m = - withFilePath name $ \s -> do - throwErrnoPathIfMinus1_ "setFileMode" name (c_chmod s m) -#else -setFileOrdinary _ = return () -setFileExecutable _ = return () -#endif --- This happens to be true on Unix and currently on Windows too: -setDirOrdinary = setFileExecutable - --- | Copies a file to a new destination. --- Often you should use `copyFileChanged` instead. -copyFile :: FilePath -> FilePath -> IO () -copyFile fromFPath toFPath = - copy - `catchIO` (\ioe -> throwIO (ioeSetLocation ioe "copyFile")) - where -#ifndef mingw32_HOST_OS - copy = withBinaryFile fromFPath ReadMode $ \hFrom -> - bracketOnError openTmp cleanTmp $ \(tmpFPath, hTmp) -> - do allocaBytes bufferSize $ copyContents hFrom hTmp - hClose hTmp - renameFile tmpFPath toFPath - openTmp = openBinaryTempFile (takeDirectory toFPath) ".copyFile.tmp" - cleanTmp (tmpFPath, hTmp) = do - hClose hTmp `catchIO` \_ -> return () - removeFile tmpFPath `catchIO` \_ -> return () - bufferSize = 4096 - - copyContents hFrom hTo buffer = do - count <- hGetBuf hFrom buffer bufferSize - when (count > 0) $ do - hPutBuf hTo buffer count - copyContents hFrom hTo buffer -#else - copy = Win32.copyFile (toExtendedLengthPath fromFPath) - (toExtendedLengthPath toFPath) - False - --- NOTE: Shamelessly lifted from System.Directory.Internal.Windows - --- | Add the @"\\\\?\\"@ prefix if necessary or possible. The path remains --- unchanged if the prefix is not added. This function can sometimes be used --- to bypass the @MAX_PATH@ length restriction in Windows API calls. --- --- See Note [Path normalization]. -toExtendedLengthPath :: FilePath -> FilePath -toExtendedLengthPath path - | isRelative path = path - | otherwise = - case normalisedPath of - '\\' : '?' : '?' : '\\' : _ -> normalisedPath - '\\' : '\\' : '?' : '\\' : _ -> normalisedPath - '\\' : '\\' : '.' : '\\' : _ -> normalisedPath - '\\' : subpath@('\\' : _) -> "\\\\?\\UNC" <> subpath - _ -> "\\\\?\\" <> normalisedPath - where normalisedPath = simplifyWindows path - --- | Similar to 'normalise' but: --- --- * empty paths stay empty, --- * parent dirs (@..@) are expanded, and --- * paths starting with @\\\\?\\@ are preserved. --- --- The goal is to preserve the meaning of paths better than 'normalise'. --- --- Note [Path normalization] --- 'normalise' doesn't simplify path names but will convert / into \\ --- this would normally not be a problem as once the path hits the RTS we would --- have simplified the path then. However since we're calling the WIn32 API --- directly we have to do the simplification before the call. Without this the --- path Z:// would become Z:\\\\ and when converted to a device path the path --- becomes \\?\Z:\\\\ which is an invalid path. --- --- This is not a bug in normalise as it explicitly states that it won't simplify --- a FilePath. -simplifyWindows :: FilePath -> FilePath -simplifyWindows "" = "" -simplifyWindows path = - case drive' of - "\\\\?\\" -> drive' <> subpath - _ -> simplifiedPath - where - simplifiedPath = joinDrive drive' subpath' - (drive, subpath) = splitDrive path - drive' = upperDrive (normaliseTrailingSep (normalisePathSeps drive)) - subpath' = appendSep . avoidEmpty . prependSep . joinPath . - stripPardirs . expandDots . skipSeps . - splitDirectories $ subpath - - upperDrive d = case d of - c : ':' : s | isAlpha c && all isPathSeparator s -> toUpper c : ':' : s - _ -> d - skipSeps = filter (not . (`elem` (pure <$> pathSeparators))) - stripPardirs | pathIsAbsolute || subpathIsAbsolute = dropWhile (== "..") - | otherwise = id - prependSep | subpathIsAbsolute = (pathSeparator :) - | otherwise = id - avoidEmpty | not pathIsAbsolute - && (null drive || hasTrailingPathSep) -- prefer "C:" over "C:." - = emptyToCurDir - | otherwise = id - appendSep p | hasTrailingPathSep - && not (pathIsAbsolute && null p) - = addTrailingPathSeparator p - | otherwise = p - pathIsAbsolute = not (isRelative path) - subpathIsAbsolute = any isPathSeparator (take 1 subpath) - hasTrailingPathSep = hasTrailingPathSeparator subpath - --- | Given a list of path segments, expand @.@ and @..@. The path segments --- must not contain path separators. -expandDots :: [FilePath] -> [FilePath] -expandDots = reverse . go [] - where - go ys' xs' = - case xs' of - [] -> ys' - x : xs -> - case x of - "." -> go ys' xs - ".." -> - case ys' of - [] -> go (x : ys') xs - ".." : _ -> go (x : ys') xs - _ : ys -> go ys xs - _ -> go (x : ys') xs - --- | Convert to the right kind of slashes. -normalisePathSeps :: FilePath -> FilePath -normalisePathSeps p = (\ c -> if isPathSeparator c then pathSeparator else c) <$> p - --- | Remove redundant trailing slashes and pick the right kind of slash. -normaliseTrailingSep :: FilePath -> FilePath -normaliseTrailingSep path = do - let path' = reverse path - let (sep, path'') = span isPathSeparator path' - let addSep = if null sep then id else (pathSeparator :) - reverse (addSep path'') - --- | Convert empty paths to the current directory, otherwise leave it --- unchanged. -emptyToCurDir :: FilePath -> FilePath -emptyToCurDir "" = "." -emptyToCurDir path = path -#endif /* mingw32_HOST_OS */ - --- | Like `copyFile`, but does not touch the target if source and destination --- are already byte-identical. This is recommended as it is useful for --- time-stamp based recompilation avoidance. -copyFileChanged :: FilePath -> FilePath -> IO () -copyFileChanged src dest = do - equal <- filesEqual src dest - unless equal $ copyFile src dest - --- | Checks if two files are byte-identical. --- Returns False if either of the files do not exist or if files --- are of different size. -filesEqual :: FilePath -> FilePath -> IO Bool -filesEqual f1 f2 = do - ex1 <- doesFileExist f1 - ex2 <- doesFileExist f2 - if not (ex1 && ex2) then return False else - withBinaryFile f1 ReadMode $ \h1 -> - withBinaryFile f2 ReadMode $ \h2 -> do - s1 <- hFileSize h1 - s2 <- hFileSize h2 - if s1 /= s2 - then return False - else do - c1 <- BSL.hGetContents h1 - c2 <- BSL.hGetContents h2 - return $! c1 == c2 diff --git a/cabal/Cabal/Distribution/Compat/CreatePipe.hs b/cabal/Cabal/Distribution/Compat/CreatePipe.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Compat/CreatePipe.hs +++ /dev/null @@ -1,81 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - -module Distribution.Compat.CreatePipe (createPipe) where - -#if MIN_VERSION_process(1,2,1) -import System.Process (createPipe) -#else -import System.IO (Handle, hSetBinaryMode) - -import Prelude () -import Distribution.Compat.Prelude -import Distribution.Compat.Stack - --- The mingw32_HOST_OS CPP macro is GHC-specific -#ifdef mingw32_HOST_OS -import qualified Prelude -import Control.Exception (onException) -import Foreign.C.Error (throwErrnoIfMinus1_) -import Foreign.C.Types (CInt(..), CUInt(..)) -import Foreign.Ptr (Ptr) -import Foreign.Marshal.Array (allocaArray) -import Foreign.Storable (peek, peekElemOff) -import GHC.IO.FD (mkFD) -import GHC.IO.Device (IODeviceType(Stream)) -import GHC.IO.Handle.FD (mkHandleFromFD) -import System.IO (IOMode(ReadMode, WriteMode)) -#elif defined ghcjs_HOST_OS -#else -import System.Posix.IO (fdToHandle) -import qualified System.Posix.IO as Posix -#endif - -createPipe :: IO (Handle, Handle) --- The mingw32_HOST_OS CPP macro is GHC-specific -#ifdef mingw32_HOST_OS -createPipe = do - (readfd, writefd) <- allocaArray 2 $ \ pfds -> do - throwErrnoIfMinus1_ "_pipe" $ c__pipe pfds 2 ({- _O_BINARY -} 32768) - readfd <- peek pfds - writefd <- peekElemOff pfds 1 - return (readfd, writefd) - (do readh <- fdToHandle readfd ReadMode - writeh <- fdToHandle writefd WriteMode - hSetBinaryMode readh True - hSetBinaryMode writeh True - return (readh, writeh)) `onException` (close readfd >> close writefd) - where - fdToHandle :: CInt -> IOMode -> IO Handle - fdToHandle fd mode = do - (fd', deviceType) <- mkFD fd mode (Just (Stream, 0, 0)) False False - mkHandleFromFD fd' deviceType "" mode False Nothing - - close :: CInt -> IO () - close = throwErrnoIfMinus1_ "_close" . c__close - where _ = callStack -- TODO: attach call stack to exception - - _ = callStack -- TODO: attach call stack to exceptions - -foreign import ccall "io.h _pipe" c__pipe :: - Ptr CInt -> CUInt -> CInt -> Prelude.IO CInt - -foreign import ccall "io.h _close" c__close :: - CInt -> Prelude.IO CInt -#elif defined ghcjs_HOST_OS -createPipe = error "createPipe" - where - _ = callStack -#else -createPipe = do - (readfd, writefd) <- Posix.createPipe - readh <- fdToHandle readfd - writeh <- fdToHandle writefd - hSetBinaryMode readh True - hSetBinaryMode writeh True - return (readh, writeh) - where - _ = callStack -#endif -#endif diff --git a/cabal/Cabal/Distribution/Compat/DList.hs b/cabal/Cabal/Distribution/Compat/DList.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Compat/DList.hs +++ /dev/null @@ -1,53 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Compat.DList --- Copyright : (c) Ben Gamari 2015-2019 --- License : BSD3 --- --- Maintainer : cabal-dev@haskell.org --- Stability : experimental --- Portability : portable --- --- A very simple difference list. -module Distribution.Compat.DList ( - DList, - runDList, - empty, - singleton, - fromList, - toList, - snoc, -) where - -import Prelude () -import Distribution.Compat.Prelude hiding (toList, empty) - --- | Difference list. -newtype DList a = DList ([a] -> [a]) - -runDList :: DList a -> [a] -runDList (DList run) = run [] - --- | Make 'DList' with containing single element. -singleton :: a -> DList a -singleton a = DList (a:) - --- | @since 3.4.0.0 -empty :: DList a -empty = DList id - -fromList :: [a] -> DList a -fromList as = DList (as ++) - -toList :: DList a -> [a] -toList = runDList - -snoc :: DList a -> a -> DList a -snoc xs x = xs <> singleton x - -instance Monoid (DList a) where - mempty = empty - mappend = (<>) - -instance Semigroup (DList a) where - DList a <> DList b = DList (a . b) diff --git a/cabal/Cabal/Distribution/Compat/Directory.hs b/cabal/Cabal/Distribution/Compat/Directory.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Compat/Directory.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE CPP #-} - -module Distribution.Compat.Directory -( listDirectory -, makeAbsolute -, doesPathExist -) where - -#if MIN_VERSION_directory(1,2,7) -import System.Directory as Dir hiding (doesPathExist) -import System.Directory (doesPathExist) -#else -import System.Directory as Dir -#endif -#if !MIN_VERSION_directory(1,2,2) -import System.FilePath as Path -#endif - -#if !MIN_VERSION_directory(1,2,5) - -listDirectory :: FilePath -> IO [FilePath] -listDirectory path = - filter f `fmap` Dir.getDirectoryContents path - where f filename = filename /= "." && filename /= ".." - -#endif - -#if !MIN_VERSION_directory(1,2,2) - -makeAbsolute :: FilePath -> IO FilePath -makeAbsolute p | Path.isAbsolute p = return p - | otherwise = do - cwd <- Dir.getCurrentDirectory - return $ cwd p - -#endif - -#if !MIN_VERSION_directory(1,2,7) - -doesPathExist :: FilePath -> IO Bool -doesPathExist path = do - -- not using Applicative, as this way we can do less IO - e <- doesDirectoryExist path - if e - then return True - else doesFileExist path - -#endif - diff --git a/cabal/Cabal/Distribution/Compat/Environment.hs b/cabal/Cabal/Distribution/Compat/Environment.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Compat/Environment.hs +++ /dev/null @@ -1,135 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ForeignFunctionInterface #-} -{-# OPTIONS_HADDOCK hide #-} - -module Distribution.Compat.Environment - ( getEnvironment, lookupEnv, setEnv, unsetEnv ) - where - -import Prelude () -import qualified Prelude -import Distribution.Compat.Prelude - -#ifndef mingw32_HOST_OS -#if __GLASGOW_HASKELL__ < 708 -import Foreign.C.Error (throwErrnoIf_) -#endif -#endif - -import qualified System.Environment as System -import System.Environment (lookupEnv) -#if __GLASGOW_HASKELL__ >= 708 -import System.Environment (unsetEnv) -#endif - -import Distribution.Compat.Stack - -#ifdef mingw32_HOST_OS -import Foreign.C -#if __GLASGOW_HASKELL__ < 708 -import Foreign.Ptr (nullPtr) -#endif -import GHC.Windows -#else -import Foreign.C.Types -import Foreign.C.String -import Foreign.C.Error (throwErrnoIfMinus1_) -import System.Posix.Internals ( withFilePath ) -#endif /* mingw32_HOST_OS */ - -getEnvironment :: IO [(String, String)] -#ifdef mingw32_HOST_OS --- On Windows, the names of environment variables are case-insensitive, but are --- often given in mixed-case (e.g. "PATH" is "Path"), so we have to normalise --- them. -getEnvironment = fmap upcaseVars System.getEnvironment - where - upcaseVars = map upcaseVar - upcaseVar (var, val) = (map toUpper var, val) -#else -getEnvironment = System.getEnvironment -#endif - --- | @setEnv name value@ sets the specified environment variable to @value@. --- --- Throws `Control.Exception.IOException` if either @name@ or @value@ is the --- empty string or contains an equals sign. -setEnv :: String -> String -> IO () -setEnv key value_ = setEnv_ key value - where - -- NOTE: Anything that follows NUL is ignored on both POSIX and Windows. We - -- still strip it manually so that the null check above succeeds if a value - -- starts with NUL. - value = takeWhile (/= '\NUL') value_ - -setEnv_ :: String -> String -> IO () - -#ifdef mingw32_HOST_OS - -setEnv_ key value = withCWString key $ \k -> withCWString value $ \v -> do - success <- c_SetEnvironmentVariable k v - unless success (throwGetLastError "setEnv") - where - _ = callStack -- TODO: attach CallStack to exception - -# if defined(i386_HOST_ARCH) -# define WINDOWS_CCONV stdcall -# elif defined(x86_64_HOST_ARCH) -# define WINDOWS_CCONV ccall -# else -# error Unknown mingw32 arch -# endif /* i386_HOST_ARCH */ - -foreign import WINDOWS_CCONV unsafe "windows.h SetEnvironmentVariableW" - c_SetEnvironmentVariable :: LPTSTR -> LPTSTR -> Prelude.IO Bool -#else -setEnv_ key value = do - withFilePath key $ \ keyP -> - withFilePath value $ \ valueP -> - throwErrnoIfMinus1_ "setenv" $ - c_setenv keyP valueP (fromIntegral (fromEnum True)) - where - _ = callStack -- TODO: attach CallStack to exception - -foreign import ccall unsafe "setenv" - c_setenv :: CString -> CString -> CInt -> Prelude.IO CInt -#endif /* mingw32_HOST_OS */ - -#if __GLASGOW_HASKELL__ < 708 - --- | @unsetEnv name@ removes the specified environment variable from the --- environment of the current process. --- --- Throws `Control.Exception.IOException` if @name@ is the empty string or --- contains an equals sign. --- --- @since 4.7.0.0 -unsetEnv :: String -> IO () -#ifdef mingw32_HOST_OS -unsetEnv key = withCWString key $ \k -> do - success <- c_SetEnvironmentVariable k nullPtr - unless success $ do - -- We consider unsetting an environment variable that does not exist not as - -- an error, hence we ignore eRROR_ENVVAR_NOT_FOUND. - err <- c_GetLastError - unless (err == eRROR_ENVVAR_NOT_FOUND) $ do - throwGetLastError "unsetEnv" - -eRROR_ENVVAR_NOT_FOUND :: DWORD -eRROR_ENVVAR_NOT_FOUND = 203 - -foreign import WINDOWS_CCONV unsafe "windows.h GetLastError" - c_GetLastError:: IO DWORD -#else -unsetEnv key = withFilePath key (throwErrnoIf_ (/= 0) "unsetEnv" . c_unsetenv) -#if __GLASGOW_HASKELL__ > 706 -foreign import ccall unsafe "__hsbase_unsetenv" c_unsetenv :: CString -> Prelude.IO CInt -#else --- HACK: We hope very hard that !UNSETENV_RETURNS_VOID -foreign import ccall unsafe "unsetenv" c_unsetenv :: CString -> Prelude.IO CInt -#endif -#endif - -#endif diff --git a/cabal/Cabal/Distribution/Compat/Exception.hs b/cabal/Cabal/Distribution/Compat/Exception.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Compat/Exception.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE CPP #-} -module Distribution.Compat.Exception ( - catchIO, - catchExit, - tryIO, - displayException, - ) where - -#ifdef MIN_VERSION_base -#define MINVER_base_48 MIN_VERSION_base(4,8,0) -#else -#define MINVER_base_48 (__GLASGOW_HASKELL__ >= 710) -#endif - -import System.Exit -import qualified Control.Exception as Exception - -#if MINVER_base_48 -import Control.Exception (displayException) -#endif - --- | Try 'IOException'. -tryIO :: IO a -> IO (Either Exception.IOException a) -tryIO = Exception.try - --- | Catch 'IOException'. -catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a -catchIO = Exception.catch - --- | Catch 'ExitCode' -catchExit :: IO a -> (ExitCode -> IO a) -> IO a -catchExit = Exception.catch - -#if !MINVER_base_48 -displayException :: Exception.Exception e => e -> String -displayException = show -#endif diff --git a/cabal/Cabal/Distribution/Compat/FilePath.hs b/cabal/Cabal/Distribution/Compat/FilePath.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Compat/FilePath.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE CPP #-} - -{-# OPTIONS_GHC -fno-warn-unused-imports #-} - -module Distribution.Compat.FilePath -( isExtensionOf -, stripExtension -) where - -import Data.List ( isSuffixOf, stripPrefix ) -import System.FilePath - -#if !MIN_VERSION_filepath(1,4,2) -isExtensionOf :: String -> FilePath -> Bool -isExtensionOf ext@('.':_) = isSuffixOf ext . takeExtensions -isExtensionOf ext = isSuffixOf ('.':ext) . takeExtensions -#endif - -#if !MIN_VERSION_filepath(1,4,1) -stripExtension :: String -> FilePath -> Maybe FilePath -stripExtension [] path = Just path -stripExtension ext@(x:_) path = stripSuffix dotExt path - where - dotExt = if isExtSeparator x then ext else '.':ext - stripSuffix :: Eq a => [a] -> [a] -> Maybe [a] - stripSuffix xs ys = fmap reverse $ stripPrefix (reverse xs) (reverse ys) -#endif diff --git a/cabal/Cabal/Distribution/Compat/GetShortPathName.hs b/cabal/Cabal/Distribution/Compat/GetShortPathName.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Compat/GetShortPathName.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Compat.GetShortPathName --- --- Maintainer : cabal-devel@haskell.org --- Portability : Windows-only --- --- Win32 API 'GetShortPathName' function. - -module Distribution.Compat.GetShortPathName ( getShortPathName ) - where - -import Prelude () -import Distribution.Compat.Prelude - -#ifdef mingw32_HOST_OS - -import qualified Prelude -import qualified System.Win32 as Win32 -import System.Win32 (LPCTSTR, LPTSTR, DWORD) -import Foreign.Marshal.Array (allocaArray) - -#ifdef x86_64_HOST_ARCH -#define WINAPI ccall -#else -#define WINAPI stdcall -#endif - -foreign import WINAPI unsafe "windows.h GetShortPathNameW" - c_GetShortPathName :: LPCTSTR -> LPTSTR -> DWORD -> Prelude.IO DWORD - --- | On Windows, retrieves the short path form of the specified path. On --- non-Windows, does nothing. See https://github.com/haskell/cabal/issues/3185. --- --- From MS's GetShortPathName docs: --- --- Passing NULL for [the second] parameter and zero for cchBuffer --- will always return the required buffer size for a --- specified lpszLongPath. --- -getShortPathName :: FilePath -> IO FilePath -getShortPathName path = - Win32.withTString path $ \c_path -> do - c_len <- Win32.failIfZero "GetShortPathName #1 failed!" $ - c_GetShortPathName c_path Win32.nullPtr 0 - let arr_len = fromIntegral c_len - allocaArray arr_len $ \c_out -> do - void $ Win32.failIfZero "GetShortPathName #2 failed!" $ - c_GetShortPathName c_path c_out c_len - Win32.peekTString c_out - -#else - -getShortPathName :: FilePath -> IO FilePath -getShortPathName path = return path - -#endif diff --git a/cabal/Cabal/Distribution/Compat/Graph.hs b/cabal/Cabal/Distribution/Compat/Graph.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Compat/Graph.hs +++ /dev/null @@ -1,408 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Compat.Graph --- Copyright : (c) Edward Z. Yang 2016 --- License : BSD3 --- --- Maintainer : cabal-dev@haskell.org --- Stability : experimental --- Portability : portable --- --- A data type representing directed graphs, backed by "Data.Graph". --- It is strict in the node type. --- --- This is an alternative interface to "Data.Graph". In this interface, --- nodes (identified by the 'IsNode' type class) are associated with a --- key and record the keys of their neighbors. This interface is more --- convenient than 'Data.Graph.Graph', which requires vertices to be --- explicitly handled by integer indexes. --- --- The current implementation has somewhat peculiar performance --- characteristics. The asymptotics of all map-like operations mirror --- their counterparts in "Data.Map". However, to perform a graph --- operation, we first must build the "Data.Graph" representation, an --- operation that takes /O(V + E log V)/. However, this operation can --- be amortized across all queries on that particular graph. --- --- Some nodes may be broken, i.e., refer to neighbors which are not --- stored in the graph. In our graph algorithms, we transparently --- ignore such edges; however, you can easily query for the broken --- vertices of a graph using 'broken' (and should, e.g., to ensure that --- a closure of a graph is well-formed.) It's possible to take a closed --- subset of a broken graph and get a well-formed graph. --- ------------------------------------------------------------------------------ - -module Distribution.Compat.Graph ( - -- * Graph type - Graph, - IsNode(..), - -- * Query - null, - size, - member, - lookup, - -- * Construction - empty, - insert, - deleteKey, - deleteLookup, - -- * Combine - unionLeft, - unionRight, - -- * Graph algorithms - stronglyConnComp, - SCC(..), - cycles, - broken, - neighbors, - revNeighbors, - closure, - revClosure, - topSort, - revTopSort, - -- * Conversions - -- ** Maps - toMap, - -- ** Lists - fromDistinctList, - toList, - keys, - -- ** Sets - keysSet, - -- ** Graphs - toGraph, - -- * Node type - Node(..), - nodeValue, -) where - -import Distribution.Compat.Prelude hiding (empty, lookup, null, toList) -import Prelude () - -import Data.Array ((!)) -import Data.Graph (SCC (..)) -import Distribution.Utils.Structured (Structure (..), Structured (..)) - -import qualified Data.Array as Array -import qualified Data.Foldable as Foldable -import qualified Data.Graph as G -import qualified Data.Map.Strict as Map -import qualified Data.Set as Set -import qualified Data.Tree as Tree -import qualified Distribution.Compat.Prelude as Prelude - --- | A graph of nodes @a@. The nodes are expected to have instance --- of class 'IsNode'. -data Graph a - = Graph { - graphMap :: !(Map (Key a) a), - -- Lazily cached graph representation - graphForward :: G.Graph, - graphAdjoint :: G.Graph, - graphVertexToNode :: G.Vertex -> a, - graphKeyToVertex :: Key a -> Maybe G.Vertex, - graphBroken :: [(a, [Key a])] - } - deriving (Typeable) - --- NB: Not a Functor! (or Traversable), because you need --- to restrict Key a ~ Key b. We provide our own mapping --- functions. - --- General strategy is most operations are deferred to the --- Map representation. - -instance Show a => Show (Graph a) where - show = show . toList - -instance (IsNode a, Read a, Show (Key a)) => Read (Graph a) where - readsPrec d s = map (\(a,r) -> (fromDistinctList a, r)) (readsPrec d s) - -instance (IsNode a, Binary a, Show (Key a)) => Binary (Graph a) where - put x = put (toList x) - get = fmap fromDistinctList get - -instance Structured a => Structured (Graph a) where - structure p = Nominal (typeRep p) 0 "Graph" [structure (Proxy :: Proxy a)] - -instance (Eq (Key a), Eq a) => Eq (Graph a) where - g1 == g2 = graphMap g1 == graphMap g2 - -instance Foldable.Foldable Graph where - fold = Foldable.fold . graphMap - foldr f z = Foldable.foldr f z . graphMap - foldl f z = Foldable.foldl f z . graphMap - foldMap f = Foldable.foldMap f . graphMap - foldl' f z = Foldable.foldl' f z . graphMap - foldr' f z = Foldable.foldr' f z . graphMap -#ifdef MIN_VERSION_base -#if MIN_VERSION_base(4,8,0) - length = Foldable.length . graphMap - null = Foldable.null . graphMap - toList = Foldable.toList . graphMap - elem x = Foldable.elem x . graphMap - maximum = Foldable.maximum . graphMap - minimum = Foldable.minimum . graphMap - sum = Foldable.sum . graphMap - product = Foldable.product . graphMap -#endif -#endif - -instance (NFData a, NFData (Key a)) => NFData (Graph a) where - rnf Graph { - graphMap = m, - graphForward = gf, - graphAdjoint = ga, - graphVertexToNode = vtn, - graphKeyToVertex = ktv, - graphBroken = b - } = gf `seq` ga `seq` vtn `seq` ktv `seq` b `seq` rnf m - --- TODO: Data instance? - --- | The 'IsNode' class is used for datatypes which represent directed --- graph nodes. A node of type @a@ is associated with some unique key of --- type @'Key' a@; given a node we can determine its key ('nodeKey') --- and the keys of its neighbors ('nodeNeighbors'). -class Ord (Key a) => IsNode a where - type Key a - nodeKey :: a -> Key a - nodeNeighbors :: a -> [Key a] - -instance (IsNode a, IsNode b, Key a ~ Key b) => IsNode (Either a b) where - type Key (Either a b) = Key a - nodeKey (Left x) = nodeKey x - nodeKey (Right x) = nodeKey x - nodeNeighbors (Left x) = nodeNeighbors x - nodeNeighbors (Right x) = nodeNeighbors x - --- | A simple, trivial data type which admits an 'IsNode' instance. -data Node k a = N a k [k] - deriving (Show, Eq) - --- | Get the value from a 'Node'. -nodeValue :: Node k a -> a -nodeValue (N a _ _) = a - -instance Functor (Node k) where - fmap f (N a k ks) = N (f a) k ks - -instance Ord k => IsNode (Node k a) where - type Key (Node k a) = k - nodeKey (N _ k _) = k - nodeNeighbors (N _ _ ks) = ks - --- TODO: Maybe introduce a typeclass for items which just --- keys (so, Key associated type, and nodeKey method). But --- I didn't need it here, so I didn't introduce it. - --- Query - --- | /O(1)/. Is the graph empty? -null :: Graph a -> Bool -null = Map.null . toMap - --- | /O(1)/. The number of nodes in the graph. -size :: Graph a -> Int -size = Map.size . toMap - --- | /O(log V)/. Check if the key is in the graph. -member :: IsNode a => Key a -> Graph a -> Bool -member k g = Map.member k (toMap g) - --- | /O(log V)/. Lookup the node at a key in the graph. -lookup :: IsNode a => Key a -> Graph a -> Maybe a -lookup k g = Map.lookup k (toMap g) - --- Construction - --- | /O(1)/. The empty graph. -empty :: IsNode a => Graph a -empty = fromMap Map.empty - --- | /O(log V)/. Insert a node into a graph. -insert :: IsNode a => a -> Graph a -> Graph a -insert !n g = fromMap (Map.insert (nodeKey n) n (toMap g)) - --- | /O(log V)/. Delete the node at a key from the graph. -deleteKey :: IsNode a => Key a -> Graph a -> Graph a -deleteKey k g = fromMap (Map.delete k (toMap g)) - --- | /O(log V)/. Lookup and delete. This function returns the deleted --- value if it existed. -deleteLookup :: IsNode a => Key a -> Graph a -> (Maybe a, Graph a) -deleteLookup k g = - let (r, m') = Map.updateLookupWithKey (\_ _ -> Nothing) k (toMap g) - in (r, fromMap m') - --- Combining - --- | /O(V + V')/. Right-biased union, preferring entries --- from the second map when conflicts occur. --- @'nodeKey' x = 'nodeKey' (f x)@. -unionRight :: IsNode a => Graph a -> Graph a -> Graph a -unionRight g g' = fromMap (Map.union (toMap g') (toMap g)) - --- | /O(V + V')/. Left-biased union, preferring entries from --- the first map when conflicts occur. -unionLeft :: IsNode a => Graph a -> Graph a -> Graph a -unionLeft = flip unionRight - --- Graph-like operations - --- | /Ω(V + E)/. Compute the strongly connected components of a graph. --- Requires amortized construction of graph. -stronglyConnComp :: Graph a -> [SCC a] -stronglyConnComp g = map decode forest - where - forest = G.scc (graphForward g) - decode (Tree.Node v []) - | mentions_itself v = CyclicSCC [graphVertexToNode g v] - | otherwise = AcyclicSCC (graphVertexToNode g v) - decode other = CyclicSCC (dec other []) - where dec (Tree.Node v ts) vs - = graphVertexToNode g v : foldr dec vs ts - mentions_itself v = v `elem` (graphForward g ! v) --- Implementation copied from 'stronglyConnCompR' in 'Data.Graph'. - --- | /Ω(V + E)/. Compute the cycles of a graph. --- Requires amortized construction of graph. -cycles :: Graph a -> [[a]] -cycles g = [ vs | CyclicSCC vs <- stronglyConnComp g ] - --- | /O(1)/. Return a list of nodes paired with their broken --- neighbors (i.e., neighbor keys which are not in the graph). --- Requires amortized construction of graph. -broken :: Graph a -> [(a, [Key a])] -broken g = graphBroken g - --- | Lookup the immediate neighbors from a key in the graph. --- Requires amortized construction of graph. -neighbors :: Graph a -> Key a -> Maybe [a] -neighbors g k = do - v <- graphKeyToVertex g k - return (map (graphVertexToNode g) (graphForward g ! v)) - --- | Lookup the immediate reverse neighbors from a key in the graph. --- Requires amortized construction of graph. -revNeighbors :: Graph a -> Key a -> Maybe [a] -revNeighbors g k = do - v <- graphKeyToVertex g k - return (map (graphVertexToNode g) (graphAdjoint g ! v)) - --- | Compute the subgraph which is the closure of some set of keys. --- Returns @Nothing@ if one (or more) keys are not present in --- the graph. --- Requires amortized construction of graph. -closure :: Graph a -> [Key a] -> Maybe [a] -closure g ks = do - vs <- traverse (graphKeyToVertex g) ks - return (decodeVertexForest g (G.dfs (graphForward g) vs)) - --- | Compute the reverse closure of a graph from some set --- of keys. Returns @Nothing@ if one (or more) keys are not present in --- the graph. --- Requires amortized construction of graph. -revClosure :: Graph a -> [Key a] -> Maybe [a] -revClosure g ks = do - vs <- traverse (graphKeyToVertex g) ks - return (decodeVertexForest g (G.dfs (graphAdjoint g) vs)) - -flattenForest :: Tree.Forest a -> [a] -flattenForest = concatMap Tree.flatten - -decodeVertexForest :: Graph a -> Tree.Forest G.Vertex -> [a] -decodeVertexForest g = map (graphVertexToNode g) . flattenForest - --- | Topologically sort the nodes of a graph. --- Requires amortized construction of graph. -topSort :: Graph a -> [a] -topSort g = map (graphVertexToNode g) $ G.topSort (graphForward g) - --- | Reverse topologically sort the nodes of a graph. --- Requires amortized construction of graph. -revTopSort :: Graph a -> [a] -revTopSort g = map (graphVertexToNode g) $ G.topSort (graphAdjoint g) - --- Conversions - --- | /O(1)/. Convert a map from keys to nodes into a graph. --- The map must satisfy the invariant that --- @'fromMap' m == 'fromList' ('Data.Map.elems' m)@; --- if you can't fulfill this invariant use @'fromList' ('Data.Map.elems' m)@ --- instead. The values of the map are assumed to already --- be in WHNF. -fromMap :: IsNode a => Map (Key a) a -> Graph a -fromMap m - = Graph { graphMap = m - -- These are lazily computed! - , graphForward = g - , graphAdjoint = G.transposeG g - , graphVertexToNode = vertex_to_node - , graphKeyToVertex = key_to_vertex - , graphBroken = broke - } - where - try_key_to_vertex k = maybe (Left k) Right (key_to_vertex k) - - (brokenEdges, edges) - = unzip - $ [ partitionEithers (map try_key_to_vertex (nodeNeighbors n)) - | n <- ns ] - broke = filter (not . Prelude.null . snd) (zip ns brokenEdges) - - g = Array.listArray bounds edges - - ns = Map.elems m -- sorted ascending - vertices = zip (map nodeKey ns) [0..] - vertex_map = Map.fromAscList vertices - key_to_vertex k = Map.lookup k vertex_map - - vertex_to_node vertex = nodeTable ! vertex - - nodeTable = Array.listArray bounds ns - bounds = (0, Map.size m - 1) - --- | /O(V log V)/. Convert a list of nodes (with distinct keys) into a graph. -fromDistinctList :: (IsNode a, Show (Key a)) => [a] -> Graph a -fromDistinctList = fromMap - . Map.fromListWith (\_ -> duplicateError) - . map (\n -> n `seq` (nodeKey n, n)) - where - duplicateError n = error $ "Graph.fromDistinctList: duplicate key: " - ++ show (nodeKey n) - --- Map-like operations - --- | /O(V)/. Convert a graph into a list of nodes. -toList :: Graph a -> [a] -toList g = Map.elems (toMap g) - --- | /O(V)/. Convert a graph into a list of keys. -keys :: Graph a -> [Key a] -keys g = Map.keys (toMap g) - --- | /O(V)/. Convert a graph into a set of keys. -keysSet :: Graph a -> Set.Set (Key a) -keysSet g = Map.keysSet (toMap g) - --- | /O(1)/. Convert a graph into a map from keys to nodes. --- The resulting map @m@ is guaranteed to have the property that --- @'Prelude.all' (\(k,n) -> k == 'nodeKey' n) ('Data.Map.toList' m)@. -toMap :: Graph a -> Map (Key a) a -toMap = graphMap - --- Graph-like operations - --- | /O(1)/. Convert a graph into a 'Data.Graph.Graph'. --- Requires amortized construction of graph. -toGraph :: Graph a -> (G.Graph, G.Vertex -> a, Key a -> Maybe G.Vertex) -toGraph g = (graphForward g, graphVertexToNode g, graphKeyToVertex g) diff --git a/cabal/Cabal/Distribution/Compat/Internal/TempFile.hs b/cabal/Cabal/Distribution/Compat/Internal/TempFile.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Compat/Internal/TempFile.hs +++ /dev/null @@ -1,137 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# OPTIONS_HADDOCK hide #-} -module Distribution.Compat.Internal.TempFile ( - openTempFile, - openBinaryTempFile, - openNewBinaryFile, - createTempDirectory, - ) where - -import Distribution.Compat.Exception - -import System.FilePath (()) - -import System.IO (Handle, openTempFile, openBinaryTempFile) -#if defined(__IO_MANAGER_WINIO__) -import System.IO (openBinaryTempFileWithDefaultPermissions) -#else -import Control.Exception (onException) -import Data.Bits ((.|.)) -import Foreign.C (CInt, eEXIST, getErrno, errnoToIOError) -import GHC.IO.Handle.FD (fdToHandle) -import System.Posix.Internals (c_open, c_close, o_EXCL, o_BINARY, withFilePath, - o_CREAT, o_RDWR, o_NONBLOCK, o_NOCTTY) -#endif - -import System.Posix.Internals (c_getpid) -import System.IO.Error (isAlreadyExistsError) - -#if defined(mingw32_HOST_OS) || defined(ghcjs_HOST_OS) -import System.Directory ( createDirectory ) -#else -import qualified System.Posix -#endif - --- ------------------------------------------------------------ --- * temporary files --- ------------------------------------------------------------ - --- This is here for Haskell implementations that do not come with --- System.IO.openTempFile. This includes nhc-1.20, hugs-2006.9. --- TODO: This file should probably be removed. - --- This is a copy/paste of the openBinaryTempFile definition, but --- it uses 666 rather than 600 for the permissions. Newer versions --- of base have a new function with this behavior which we use on --- Windows when the new IO manager is used. -openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle) -openNewBinaryFile dir template = do - -- This method can't be used under WINIO. Also the current implementation has - -- thread safety issues depending on which GHC is used. On newer GHC's let's - -- use the built in one. -#if defined(__IO_MANAGER_WINIO__) - openBinaryTempFileWithDefaultPermissions dir template -#else - pid <- c_getpid - findTempName pid - where - -- We split off the last extension, so we can use .foo.ext files - -- for temporary files (hidden on Unix OSes). Unfortunately we're - -- below file path in the hierarchy here. - (prefix,suffix) = - case break (== '.') $ reverse template of - -- First case: template contains no '.'s. Just re-reverse it. - (rev_suffix, "") -> (reverse rev_suffix, "") - -- Second case: template contains at least one '.'. Strip the - -- dot from the prefix and prepend it to the suffix (if we don't - -- do this, the unique number will get added after the '.' and - -- thus be part of the extension, which is wrong.) - (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix) - -- Otherwise, something is wrong, because (break (== '.')) should - -- always return a pair with either the empty string or a string - -- beginning with '.' as the second component. - _ -> error "bug in System.IO.openTempFile" - - oflags = rw_flags .|. o_EXCL .|. o_BINARY - - findTempName x = do - fd <- withFilePath filepath $ \ f -> - c_open f oflags 0o666 - if fd < 0 - then do - errno <- getErrno - if errno == eEXIST - then findTempName (x+1) - else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir)) - else do - -- TODO: We want to tell fdToHandle what the file path is, - -- as any exceptions etc will only be able to report the - -- FD currently - h <- fdToHandle fd `onException` c_close fd - return (filepath, h) - where - filename = prefix ++ show x ++ suffix - filepath = dir `combine` filename - - -- FIXME: bits copied from System.FilePath - combine a b - | null b = a - | null a = b - | last a == pathSeparator = a ++ b - | otherwise = a ++ [pathSeparator] ++ b - --- FIXME: Copied from GHC.Handle -std_flags, output_flags, rw_flags :: CInt -std_flags = o_NONBLOCK .|. o_NOCTTY -output_flags = std_flags .|. o_CREAT -rw_flags = output_flags .|. o_RDWR - --- FIXME: Should use System.FilePath library -pathSeparator :: Char -#ifdef mingw32_HOST_OS -pathSeparator = '\\' -#else -pathSeparator = '/' -#endif --- /* __IO_MANAGER_WINIO__ */ -#endif - -createTempDirectory :: FilePath -> String -> IO FilePath -createTempDirectory dir template = do - pid <- c_getpid - findTempName pid - where - findTempName x = do - let dirpath = dir template ++ "-" ++ show x - r <- tryIO $ mkPrivateDir dirpath - case r of - Right _ -> return dirpath - Left e | isAlreadyExistsError e -> findTempName (x+1) - | otherwise -> ioError e - -mkPrivateDir :: String -> IO () -#if defined(mingw32_HOST_OS) || defined(ghcjs_HOST_OS) -mkPrivateDir s = createDirectory s -#else -mkPrivateDir s = System.Posix.createDirectory s 0o700 -#endif diff --git a/cabal/Cabal/Distribution/Compat/Lens.hs b/cabal/Cabal/Distribution/Compat/Lens.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Compat/Lens.hs +++ /dev/null @@ -1,262 +0,0 @@ -{-# LANGUAGE RankNTypes #-} --- | This module provides very basic lens functionality, without extra dependencies. --- --- For the documentation of the combinators see package. --- This module uses the same vocabulary. -module Distribution.Compat.Lens ( - -- * Types - Lens, - Lens', - Traversal, - Traversal', - -- ** LensLike - LensLike, - LensLike', - -- ** rank-1 types - Getting, - AGetter, - ASetter, - ALens, - ALens', - -- * Getter - view, - use, - getting, - -- * Setter - set, - over, - -- * Fold - toDListOf, - toListOf, - toSetOf, - -- * Lens - cloneLens, - aview, - -- * Common lenses - _1, _2, - -- * Operators - (&), - (^.), - (.~), (?~), (%~), - (.=), (?=), (%=), - (^#), - (#~), (#%~), - -- * Internal Comonads - Pretext (..), - -- * Cabal developer info - -- $development - ) where - -import Prelude() -import Distribution.Compat.Prelude - -import Control.Monad.State.Class (MonadState (..), gets, modify) - -import qualified Distribution.Compat.DList as DList -import qualified Data.Set as Set - -------------------------------------------------------------------------------- --- Types -------------------------------------------------------------------------------- - -type LensLike f s t a b = (a -> f b) -> s -> f t -type LensLike' f s a = (a -> f a) -> s -> f s - -type Lens s t a b = forall f. Functor f => LensLike f s t a b -type Traversal s t a b = forall f. Applicative f => LensLike f s t a b - -type Lens' s a = Lens s s a a -type Traversal' s a = Traversal s s a a - -type Getting r s a = LensLike (Const r) s s a a - -type AGetter s a = LensLike (Const a) s s a a -- this doesn't exist in 'lens' -type ASetter s t a b = LensLike Identity s t a b -type ALens s t a b = LensLike (Pretext a b) s t a b - -type ALens' s a = ALens s s a a - -------------------------------------------------------------------------------- --- Getter -------------------------------------------------------------------------------- - -view :: Getting a s a -> s -> a -view l s = getConst (l Const s) -{-# INLINE view #-} - -use :: MonadState s m => Getting a s a -> m a -use l = gets (view l) -{-# INLINE use #-} - --- | @since 2.4 --- --- >>> (3 :: Int) ^. getting (+2) . getting show --- "5" -getting :: (s -> a) -> Getting r s a -getting k f = Const . getConst . f . k -{-# INLINE getting #-} - -------------------------------------------------------------------------------- --- Setter -------------------------------------------------------------------------------- - -set :: ASetter s t a b -> b -> s -> t -set l x = over l (const x) - -over :: ASetter s t a b -> (a -> b) -> s -> t -over l f s = runIdentity (l (\x -> Identity (f x)) s) - -------------------------------------------------------------------------------- --- Fold -------------------------------------------------------------------------------- - -toDListOf :: Getting (DList.DList a) s a -> s -> DList.DList a -toDListOf l s = getConst (l (\x -> Const (DList.singleton x)) s) - -toListOf :: Getting (DList.DList a) s a -> s -> [a] -toListOf l = DList.runDList . toDListOf l - -toSetOf :: Getting (Set.Set a) s a -> s -> Set.Set a -toSetOf l s = getConst (l (\x -> Const (Set.singleton x)) s) - -------------------------------------------------------------------------------- --- Lens -------------------------------------------------------------------------------- - -aview :: ALens s t a b -> s -> a -aview l = pretextPos . l pretextSell -{-# INLINE aview #-} - -{- -lens :: (s -> a) -> (s -> a -> s) -> Lens' s a -lens sa sbt afb s = sbt s <$> afb (sa s) --} - -------------------------------------------------------------------------------- --- Common -------------------------------------------------------------------------------- - -_1 :: Lens (a, c) (b, c) a b -_1 f (a, c) = flip (,) c <$> f a - -_2 :: Lens (c, a) (c, b) a b -_2 f (c, a) = (,) c <$> f a - -------------------------------------------------------------------------------- --- Operators -------------------------------------------------------------------------------- - --- | '&' is a reverse application operator -(&) :: a -> (a -> b) -> b -(&) = flip ($) -{-# INLINE (&) #-} -infixl 1 & - -infixl 8 ^., ^# -infixr 4 .~, %~, ?~ -infixr 4 #~, #%~ -infixr 4 .=, %=, ?= - -(^.) :: s -> Getting a s a -> a -s ^. l = getConst (l Const s) -{-# INLINE (^.) #-} - -(.~) :: ASetter s t a b -> b -> s -> t -(.~) = set -{-# INLINE (.~) #-} - -(?~) :: ASetter s t a (Maybe b) -> b -> s -> t -l ?~ b = set l (Just b) -{-# INLINE (?~) #-} - -(%~) :: ASetter s t a b -> (a -> b) -> s -> t -(%~) = over -{-# INLINE (%~) #-} - -(.=) :: MonadState s m => ASetter s s a b -> b -> m () -l .= b = modify (l .~ b) -{-# INLINE (.=) #-} - -(?=) :: MonadState s m => ASetter s s a (Maybe b) -> b -> m () -l ?= b = modify (l ?~ b) -{-# INLINE (?=) #-} - -(%=) :: MonadState s m => ASetter s s a b -> (a -> b) -> m () -l %= f = modify (l %~ f) -{-# INLINE (%=) #-} - -(^#) :: s -> ALens s t a b -> a -s ^# l = aview l s - -(#~) :: ALens s t a b -> b -> s -> t -(#~) l b s = pretextPeek b (l pretextSell s) -{-# INLINE (#~) #-} - -(#%~) :: ALens s t a b -> (a -> b) -> s -> t -(#%~) l f s = pretextPeeks f (l pretextSell s) -{-# INLINE (#%~) #-} - -pretextSell :: a -> Pretext a b b -pretextSell a = Pretext (\afb -> afb a) -{-# INLINE pretextSell #-} - -pretextPeeks :: (a -> b) -> Pretext a b t -> t -pretextPeeks f (Pretext m) = runIdentity $ m (\x -> Identity (f x)) -{-# INLINE pretextPeeks #-} - -pretextPeek :: b -> Pretext a b t -> t -pretextPeek b (Pretext m) = runIdentity $ m (\_ -> Identity b) -{-# INLINE pretextPeek #-} - -pretextPos :: Pretext a b t -> a -pretextPos (Pretext m) = getConst (m Const) -{-# INLINE pretextPos #-} - -cloneLens :: Functor f => ALens s t a b -> LensLike f s t a b -cloneLens l f s = runPretext (l pretextSell s) f -{-# INLINE cloneLens #-} - -------------------------------------------------------------------------------- --- Comonads -------------------------------------------------------------------------------- - --- | @lens@ variant is also parametrised by profunctor. -data Pretext a b t = Pretext { runPretext :: forall f. Functor f => (a -> f b) -> f t } - -instance Functor (Pretext a b) where - fmap f (Pretext pretext) = Pretext (\afb -> fmap f (pretext afb)) - -------------------------------------------------------------------------------- --- Documentation -------------------------------------------------------------------------------- - --- $development --- --- We cannot depend on @template-haskell@, because Cabal is a boot library. --- This fact makes defining optics a manual task. Here is a small recipe to --- make the process less tedious. --- --- First start a repl --- --- > cabal new-repl Cabal:hackage-tests --- --- Because @--extra-package@ isn't yet implemented, we use a test-suite --- with @generics-sop@ dependency. --- --- In the repl, we load a helper script: --- --- > :l ../generics-sop-lens.hs --- --- Now we are set up to derive lenses! --- --- > :m +Distribution.Types.SourceRepo --- > putStr $ genericLenses (Proxy :: Proxy SourceRepo) --- --- @ --- repoKind :: Lens' SourceRepo RepoKind --- repoKind f s = fmap (\\x -> s { T.repoKind = x }) (f (T.repoKind s)) --- \{-# INLINE repoKind #-\} --- ... --- @ --- --- /Note:/ You may need to adjust type-aliases, e.g. `String` to `FilePath`. diff --git a/cabal/Cabal/Distribution/Compat/MonadFail.hs b/cabal/Cabal/Distribution/Compat/MonadFail.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Compat/MonadFail.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE CPP #-} - --- | Compatibility layer for "Control.Monad.Fail" -module Distribution.Compat.MonadFail ( Control.Monad.Fail.MonadFail(fail) ) where -import Control.Monad.Fail diff --git a/cabal/Cabal/Distribution/Compat/Newtype.hs b/cabal/Cabal/Distribution/Compat/Newtype.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Compat/Newtype.hs +++ /dev/null @@ -1,91 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} --- | Per Conor McBride, the 'Newtype' typeclass represents the packing and --- unpacking of a newtype, and allows you to operatate under that newtype with --- functions such as 'ala'. -module Distribution.Compat.Newtype ( - Newtype (..), - ala, - alaf, - pack', - unpack', - ) where - -import Data.Functor.Identity (Identity (..)) -import Data.Monoid (Sum (..), Product (..), Endo (..)) - -#if MIN_VERSION_base(4,7,0) -import Data.Coerce (coerce, Coercible) -#else -import Unsafe.Coerce (unsafeCoerce) -#endif - --- | The @FunctionalDependencies@ version of 'Newtype' type-class. --- --- Since Cabal-3.0 class arguments are in a different order than in @newtype@ package. --- This change is to allow usage with @DeriveAnyClass@ (and @DerivingStrategies@, in GHC-8.2). --- Unfortunately one have to repeat inner type. --- --- @ --- newtype New = New Old --- deriving anyclass (Newtype Old) --- @ --- --- Another approach would be to use @TypeFamilies@ (and possibly --- compute inner type using "GHC.Generics"), but we think @FunctionalDependencies@ --- version gives cleaner type signatures. --- -class Newtype o n | n -> o where - pack :: o -> n -#if MIN_VERSION_base(4,7,0) - default pack :: Coercible o n => o -> n - pack = coerce -#else - default pack :: o -> n - pack = unsafeCoerce -#endif - - unpack :: n -> o -#if MIN_VERSION_base(4,7,0) - default unpack :: Coercible n o => n -> o - unpack = coerce -#else - default unpack :: n -> o - unpack = unsafeCoerce -#endif - -instance Newtype a (Identity a) -instance Newtype a (Sum a) -instance Newtype a (Product a) -instance Newtype (a -> a) (Endo a) - --- | --- --- >>> ala Sum foldMap [1, 2, 3, 4 :: Int] --- 10 --- --- /Note:/ the user supplied function for the newtype is /ignored/. --- --- >>> ala (Sum . (+1)) foldMap [1, 2, 3, 4 :: Int] --- 10 -ala :: (Newtype o n, Newtype o' n') => (o -> n) -> ((o -> n) -> b -> n') -> (b -> o') -ala pa hof = alaf pa hof id - --- | --- --- >>> alaf Sum foldMap length ["cabal", "install"] --- 12 --- --- /Note:/ as with 'ala', the user supplied function for the newtype is /ignored/. -alaf :: (Newtype o n, Newtype o' n') => (o -> n) -> ((a -> n) -> b -> n') -> (a -> o) -> (b -> o') -alaf _ hof f = unpack . hof (pack . f) - --- | Variant of 'pack', which takes a phantom type. -pack' :: Newtype o n => (o -> n) -> o -> n -pack' _ = pack - --- | Variant of 'pack', which takes a phantom type. -unpack' :: Newtype o n => (o -> n) -> n -> o -unpack' _ = unpack diff --git a/cabal/Cabal/Distribution/Compat/NonEmptySet.hs b/cabal/Cabal/Distribution/Compat/NonEmptySet.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Compat/NonEmptySet.hs +++ /dev/null @@ -1,155 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -module Distribution.Compat.NonEmptySet ( - NonEmptySet, - -- * Construction - singleton, - -- * Insertion - insert, - -- * Deletion - delete, - -- * Conversions - toNonEmpty, - fromNonEmpty, - toList, - toSet, - -- * Query - member, - -- * Map - map, -) where - -import Prelude (Bool (..), Eq, Maybe (..), Ord (..), Read, Show (..), String, error, otherwise, return, showParen, showString, ($), (++), (.)) - -import Control.DeepSeq (NFData (..)) -import Data.Data (Data) -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Semigroup (Semigroup (..)) -import Data.Typeable (Typeable) - -import qualified Data.Foldable as F -import qualified Data.Set as Set - -import Distribution.Compat.Binary (Binary (..)) -import Distribution.Utils.Structured - -#if MIN_VERSION_binary(0,6,0) -import Control.Applicative (empty) -#else -import Control.Monad (fail) -#endif - --- | @since 3.4.0.0 -newtype NonEmptySet a = NES (Set.Set a) - deriving (Eq, Ord, Typeable, Data, Read) - -------------------------------------------------------------------------------- --- Instances -------------------------------------------------------------------------------- - -instance Show a => Show (NonEmptySet a) where - showsPrec d s = showParen (d > 10) - $ showString "fromNonEmpty " - . showsPrec 11 (toNonEmpty s) - -instance Binary a => Binary (NonEmptySet a) where - put (NES s) = put s - get = do - xs <- get - if Set.null xs -#if MIN_VERSION_binary(0,6,0) - then empty -#else - then fail "NonEmptySet: empty" -#endif - else return (NES xs) - -instance Structured a => Structured (NonEmptySet a) where - structure = containerStructure - -instance NFData a => NFData (NonEmptySet a) where - rnf (NES x) = rnf x - --- | Note: there aren't @Monoid@ instance. -instance Ord a => Semigroup (NonEmptySet a) where - NES x <> NES y = NES (Set.union x y) - -instance F.Foldable NonEmptySet where - foldMap f (NES s) = F.foldMap f s - foldr f z (NES s) = F.foldr f z s - -#if MIN_VERSION_base(4,8,0) - toList = toList - null _ = False - length (NES s) = F.length s -#endif - -------------------------------------------------------------------------------- --- Constructors -------------------------------------------------------------------------------- - -singleton :: a -> NonEmptySet a -singleton = NES . Set.singleton - -------------------------------------------------------------------------------- --- Insertion -------------------------------------------------------------------------------- - -insert :: Ord a => a -> NonEmptySet a -> NonEmptySet a -insert x (NES xs) = NES (Set.insert x xs) - -------------------------------------------------------------------------------- --- Deletion -------------------------------------------------------------------------------- - -delete :: Ord a => a -> NonEmptySet a -> Maybe (NonEmptySet a) -delete x (NES xs) - | Set.null res = Nothing - | otherwise = Just (NES xs) - where - res = Set.delete x xs - -------------------------------------------------------------------------------- --- Conversions -------------------------------------------------------------------------------- - -fromNonEmpty :: Ord a => NonEmpty a -> NonEmptySet a -fromNonEmpty (x :| xs) = NES (Set.fromList (x : xs)) - -toNonEmpty :: NonEmptySet a -> NonEmpty a -toNonEmpty (NES s) = case Set.toList s of - [] -> panic "toNonEmpty" - x:xs -> x :| xs - -toList :: NonEmptySet a -> [a] -toList (NES s) = Set.toList s - -toSet :: NonEmptySet a -> Set.Set a -toSet (NES s) = s - -------------------------------------------------------------------------------- --- Query -------------------------------------------------------------------------------- - -member :: Ord a => a -> NonEmptySet a -> Bool -member x (NES xs) = Set.member x xs - -------------------------------------------------------------------------------- --- Map -------------------------------------------------------------------------------- - -map - :: ( Ord b -#if !MIN_VERSION_containers(0,5,2) - , Ord a -#endif - ) - => (a -> b) -> NonEmptySet a -> NonEmptySet b -map f (NES x) = NES (Set.map f x) - -------------------------------------------------------------------------------- --- Internal -------------------------------------------------------------------------------- - -panic :: String -> a -panic msg = error $ "NonEmptySet invariant violated: " ++ msg diff --git a/cabal/Cabal/Distribution/Compat/Parsing.hs b/cabal/Cabal/Distribution/Compat/Parsing.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Compat/Parsing.hs +++ /dev/null @@ -1,362 +0,0 @@ -{-# LANGUAGE GADTs, UndecidableInstances #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Compat.Parsing --- Copyright : (c) Edward Kmett 2011-2012 --- License : BSD3 --- --- Maintainer : ekmett@gmail.com --- Stability : experimental --- Portability : non-portable --- --- Alternative parser combinators. --- --- Originally in @parsers@ package. --- ------------------------------------------------------------------------------ -module Distribution.Compat.Parsing - ( - -- * Parsing Combinators - choice - , option - , optional -- from Control.Applicative, parsec optionMaybe - , skipOptional -- parsec optional - , between - , some -- from Control.Applicative, parsec many1 - , many -- from Control.Applicative - , sepBy - , sepByNonEmpty - , sepEndByNonEmpty - , sepEndBy - , endByNonEmpty - , endBy - , count - , chainl - , chainr - , chainl1 - , chainr1 - , manyTill - -- * Parsing Class - , Parsing(..) - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Control.Applicative ((<**>), optional) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.State.Lazy as Lazy -import Control.Monad.Trans.State.Strict as Strict -import Control.Monad.Trans.Writer.Lazy as Lazy -import Control.Monad.Trans.Writer.Strict as Strict -import Control.Monad.Trans.RWS.Lazy as Lazy -import Control.Monad.Trans.RWS.Strict as Strict -import Control.Monad.Trans.Reader (ReaderT (..)) -import Control.Monad.Trans.Identity (IdentityT (..)) -import Data.Foldable (asum) - -import qualified Data.List.NonEmpty as NE -import qualified Text.Parsec as Parsec - --- | @choice ps@ tries to apply the parsers in the list @ps@ in order, --- until one of them succeeds. Returns the value of the succeeding --- parser. -choice :: Alternative m => [m a] -> m a -choice = asum -{-# INLINE choice #-} - --- | @option x p@ tries to apply parser @p@. If @p@ fails without --- consuming input, it returns the value @x@, otherwise the value --- returned by @p@. --- --- > priority = option 0 (digitToInt <$> digit) -option :: Alternative m => a -> m a -> m a -option x p = p <|> pure x -{-# INLINE option #-} - --- | @skipOptional p@ tries to apply parser @p@. It will parse @p@ or nothing. --- It only fails if @p@ fails after consuming input. It discards the result --- of @p@. (Plays the role of parsec's optional, which conflicts with Applicative's optional) -skipOptional :: Alternative m => m a -> m () -skipOptional p = (() <$ p) <|> pure () -{-# INLINE skipOptional #-} - --- | @between open close p@ parses @open@, followed by @p@ and @close@. --- Returns the value returned by @p@. --- --- > braces = between (symbol "{") (symbol "}") -between :: Applicative m => m bra -> m ket -> m a -> m a -between bra ket p = bra *> p <* ket -{-# INLINE between #-} - --- | @sepBy p sep@ parses /zero/ or more occurrences of @p@, separated --- by @sep@. Returns a list of values returned by @p@. --- --- > commaSep p = p `sepBy` (symbol ",") -sepBy :: Alternative m => m a -> m sep -> m [a] -sepBy p sep = toList <$> sepByNonEmpty p sep <|> pure [] -{-# INLINE sepBy #-} - --- | @sepByNonEmpty p sep@ parses /one/ or more occurrences of @p@, separated --- by @sep@. Returns a non-empty list of values returned by @p@. -sepByNonEmpty :: Alternative m => m a -> m sep -> m (NonEmpty a) -sepByNonEmpty p sep = (:|) <$> p <*> many (sep *> p) -{-# INLINE sepByNonEmpty #-} - --- | @sepEndByNonEmpty p sep@ parses /one/ or more occurrences of @p@, --- separated and optionally ended by @sep@. Returns a non-empty list of values --- returned by @p@. -sepEndByNonEmpty :: Alternative m => m a -> m sep -> m (NonEmpty a) -sepEndByNonEmpty p sep = (:|) <$> p <*> ((sep *> sepEndBy p sep) <|> pure []) - --- | @sepEndBy p sep@ parses /zero/ or more occurrences of @p@, --- separated and optionally ended by @sep@, ie. haskell style --- statements. Returns a list of values returned by @p@. --- --- > haskellStatements = haskellStatement `sepEndBy` semi -sepEndBy :: Alternative m => m a -> m sep -> m [a] -sepEndBy p sep = toList <$> sepEndByNonEmpty p sep <|> pure [] -{-# INLINE sepEndBy #-} - --- | @endByNonEmpty p sep@ parses /one/ or more occurrences of @p@, separated --- and ended by @sep@. Returns a non-empty list of values returned by @p@. -endByNonEmpty :: Alternative m => m a -> m sep -> m (NonEmpty a) -endByNonEmpty p sep = NE.some1 (p <* sep) -{-# INLINE endByNonEmpty #-} - --- | @endBy p sep@ parses /zero/ or more occurrences of @p@, separated --- and ended by @sep@. Returns a list of values returned by @p@. --- --- > cStatements = cStatement `endBy` semi -endBy :: Alternative m => m a -> m sep -> m [a] -endBy p sep = many (p <* sep) -{-# INLINE endBy #-} - --- | @count n p@ parses @n@ occurrences of @p@. If @n@ is smaller or --- equal to zero, the parser equals to @return []@. Returns a list of --- @n@ values returned by @p@. -count :: Applicative m => Int -> m a -> m [a] -count n p | n <= 0 = pure [] - | otherwise = sequenceA (replicate n p) -{-# INLINE count #-} - --- | @chainr p op x@ parses /zero/ or more occurrences of @p@, --- separated by @op@ Returns a value obtained by a /right/ associative --- application of all functions returned by @op@ to the values returned --- by @p@. If there are no occurrences of @p@, the value @x@ is --- returned. -chainr :: Alternative m => m a -> m (a -> a -> a) -> a -> m a -chainr p op x = chainr1 p op <|> pure x -{-# INLINE chainr #-} - --- | @chainl p op x@ parses /zero/ or more occurrences of @p@, --- separated by @op@. Returns a value obtained by a /left/ associative --- application of all functions returned by @op@ to the values returned --- by @p@. If there are zero occurrences of @p@, the value @x@ is --- returned. -chainl :: Alternative m => m a -> m (a -> a -> a) -> a -> m a -chainl p op x = chainl1 p op <|> pure x -{-# INLINE chainl #-} - --- | @chainl1 p op x@ parses /one/ or more occurrences of @p@, --- separated by @op@ Returns a value obtained by a /left/ associative --- application of all functions returned by @op@ to the values returned --- by @p@. . This parser can for example be used to eliminate left --- recursion which typically occurs in expression grammars. --- --- > expr = term `chainl1` addop --- > term = factor `chainl1` mulop --- > factor = parens expr <|> integer --- > --- > mulop = (*) <$ symbol "*" --- > <|> div <$ symbol "/" --- > --- > addop = (+) <$ symbol "+" --- > <|> (-) <$ symbol "-" -chainl1 :: Alternative m => m a -> m (a -> a -> a) -> m a -chainl1 p op = scan where - scan = p <**> rst - rst = (\f y g x -> g (f x y)) <$> op <*> p <*> rst <|> pure id -{-# INLINE chainl1 #-} - --- | @chainr1 p op x@ parses /one/ or more occurrences of @p@, --- separated by @op@ Returns a value obtained by a /right/ associative --- application of all functions returned by @op@ to the values returned --- by @p@. -chainr1 :: Alternative m => m a -> m (a -> a -> a) -> m a -chainr1 p op = scan where - scan = p <**> rst - rst = (flip <$> op <*> scan) <|> pure id -{-# INLINE chainr1 #-} - --- | @manyTill p end@ applies parser @p@ /zero/ or more times until --- parser @end@ succeeds. Returns the list of values returned by @p@. --- This parser can be used to scan comments: --- --- > simpleComment = do{ string "")) --- > } --- --- Note the overlapping parsers @anyChar@ and @string \"-->\"@, and --- therefore the use of the 'try' combinator. -manyTill :: Alternative m => m a -> m end -> m [a] -manyTill p end = go where go = ([] <$ end) <|> ((:) <$> p <*> go) -{-# INLINE manyTill #-} - -infixr 0 - --- | Additional functionality needed to describe parsers independent of input type. -class Alternative m => Parsing m where - -- | Take a parser that may consume input, and on failure, go back to - -- where we started and fail as if we didn't consume input. - try :: m a -> m a - - -- | Give a parser a name - () :: m a -> String -> m a - - -- | A version of many that discards its input. Specialized because it - -- can often be implemented more cheaply. - skipMany :: m a -> m () - skipMany p = () <$ many p - {-# INLINE skipMany #-} - - -- | @skipSome p@ applies the parser @p@ /one/ or more times, skipping - -- its result. (aka skipMany1 in parsec) - skipSome :: m a -> m () - skipSome p = p *> skipMany p - {-# INLINE skipSome #-} - - -- | Used to emit an error on an unexpected token - unexpected :: String -> m a - - -- | This parser only succeeds at the end of the input. This is not a - -- primitive parser but it is defined using 'notFollowedBy'. - -- - -- > eof = notFollowedBy anyChar "end of input" - eof :: m () - - -- | @notFollowedBy p@ only succeeds when parser @p@ fails. This parser - -- does not consume any input. This parser can be used to implement the - -- \'longest match\' rule. For example, when recognizing keywords (for - -- example @let@), we want to make sure that a keyword is not followed - -- by a legal identifier character, in which case the keyword is - -- actually an identifier (for example @lets@). We can program this - -- behaviour as follows: - -- - -- > keywordLet = try $ string "let" <* notFollowedBy alphaNum - notFollowedBy :: Show a => m a -> m () - -instance (Parsing m, MonadPlus m) => Parsing (Lazy.StateT s m) where - try (Lazy.StateT m) = Lazy.StateT $ try . m - {-# INLINE try #-} - Lazy.StateT m l = Lazy.StateT $ \s -> m s l - {-# INLINE () #-} - unexpected = lift . unexpected - {-# INLINE unexpected #-} - eof = lift eof - {-# INLINE eof #-} - notFollowedBy (Lazy.StateT m) = Lazy.StateT - $ \s -> notFollowedBy (fst <$> m s) >> return ((),s) - {-# INLINE notFollowedBy #-} - -instance (Parsing m, MonadPlus m) => Parsing (Strict.StateT s m) where - try (Strict.StateT m) = Strict.StateT $ try . m - {-# INLINE try #-} - Strict.StateT m l = Strict.StateT $ \s -> m s l - {-# INLINE () #-} - unexpected = lift . unexpected - {-# INLINE unexpected #-} - eof = lift eof - {-# INLINE eof #-} - notFollowedBy (Strict.StateT m) = Strict.StateT - $ \s -> notFollowedBy (fst <$> m s) >> return ((),s) - {-# INLINE notFollowedBy #-} - -instance (Parsing m, MonadPlus m) => Parsing (ReaderT e m) where - try (ReaderT m) = ReaderT $ try . m - {-# INLINE try #-} - ReaderT m l = ReaderT $ \e -> m e l - {-# INLINE () #-} - skipMany (ReaderT m) = ReaderT $ skipMany . m - {-# INLINE skipMany #-} - unexpected = lift . unexpected - {-# INLINE unexpected #-} - eof = lift eof - {-# INLINE eof #-} - notFollowedBy (ReaderT m) = ReaderT $ notFollowedBy . m - {-# INLINE notFollowedBy #-} - -instance (Parsing m, MonadPlus m, Monoid w) => Parsing (Strict.WriterT w m) where - try (Strict.WriterT m) = Strict.WriterT $ try m - {-# INLINE try #-} - Strict.WriterT m l = Strict.WriterT (m l) - {-# INLINE () #-} - unexpected = lift . unexpected - {-# INLINE unexpected #-} - eof = lift eof - {-# INLINE eof #-} - notFollowedBy (Strict.WriterT m) = Strict.WriterT - $ notFollowedBy (fst <$> m) >>= \x -> return (x, mempty) - {-# INLINE notFollowedBy #-} - -instance (Parsing m, MonadPlus m, Monoid w) => Parsing (Lazy.WriterT w m) where - try (Lazy.WriterT m) = Lazy.WriterT $ try m - {-# INLINE try #-} - Lazy.WriterT m l = Lazy.WriterT (m l) - {-# INLINE () #-} - unexpected = lift . unexpected - {-# INLINE unexpected #-} - eof = lift eof - {-# INLINE eof #-} - notFollowedBy (Lazy.WriterT m) = Lazy.WriterT - $ notFollowedBy (fst <$> m) >>= \x -> return (x, mempty) - {-# INLINE notFollowedBy #-} - -instance (Parsing m, MonadPlus m, Monoid w) => Parsing (Lazy.RWST r w s m) where - try (Lazy.RWST m) = Lazy.RWST $ \r s -> try (m r s) - {-# INLINE try #-} - Lazy.RWST m l = Lazy.RWST $ \r s -> m r s l - {-# INLINE () #-} - unexpected = lift . unexpected - {-# INLINE unexpected #-} - eof = lift eof - {-# INLINE eof #-} - notFollowedBy (Lazy.RWST m) = Lazy.RWST - $ \r s -> notFollowedBy ((\(a,_,_) -> a) <$> m r s) >>= \x -> return (x, s, mempty) - {-# INLINE notFollowedBy #-} - -instance (Parsing m, MonadPlus m, Monoid w) => Parsing (Strict.RWST r w s m) where - try (Strict.RWST m) = Strict.RWST $ \r s -> try (m r s) - {-# INLINE try #-} - Strict.RWST m l = Strict.RWST $ \r s -> m r s l - {-# INLINE () #-} - unexpected = lift . unexpected - {-# INLINE unexpected #-} - eof = lift eof - {-# INLINE eof #-} - notFollowedBy (Strict.RWST m) = Strict.RWST - $ \r s -> notFollowedBy ((\(a,_,_) -> a) <$> m r s) >>= \x -> return (x, s, mempty) - {-# INLINE notFollowedBy #-} - -instance (Parsing m, Monad m) => Parsing (IdentityT m) where - try = IdentityT . try . runIdentityT - {-# INLINE try #-} - IdentityT m l = IdentityT (m l) - {-# INLINE () #-} - skipMany = IdentityT . skipMany . runIdentityT - {-# INLINE skipMany #-} - unexpected = lift . unexpected - {-# INLINE unexpected #-} - eof = lift eof - {-# INLINE eof #-} - notFollowedBy (IdentityT m) = IdentityT $ notFollowedBy m - {-# INLINE notFollowedBy #-} - -instance (Parsec.Stream s m t, Show t) => Parsing (Parsec.ParsecT s u m) where - try = Parsec.try - () = (Parsec.) - skipMany = Parsec.skipMany - skipSome = Parsec.skipMany1 - unexpected = Parsec.unexpected - eof = Parsec.eof - notFollowedBy = Parsec.notFollowedBy diff --git a/cabal/Cabal/Distribution/Compat/Prelude.hs b/cabal/Cabal/Distribution/Compat/Prelude.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Compat/Prelude.hs +++ /dev/null @@ -1,316 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeOperators #-} - -#ifdef MIN_VERSION_base -#define MINVER_base_411 MIN_VERSION_base(4,11,0) -#define MINVER_base_48 MIN_VERSION_base(4,8,0) -#define MINVER_base_47 MIN_VERSION_base(4,7,0) -#else -#define MINVER_base_411 (__GLASGOW_HASKELL__ >= 804) -#define MINVER_base_48 (__GLASGOW_HASKELL__ >= 710) -#define MINVER_base_47 (__GLASGOW_HASKELL__ >= 708) -#endif - --- | This module does two things: --- --- * Acts as a compatibility layer, like @base-compat@. --- --- * Provides commonly used imports. -module Distribution.Compat.Prelude ( - -- * Prelude - -- - -- Prelude is re-exported, following is hidden: - module BasePrelude, - -#if !MINVER_base_48 - -- * base 4.8 shim - Applicative(..), (<$), (<$>), - Monoid(..), -#endif - - -- * Common type-classes - Semigroup (..), - gmappend, gmempty, - Typeable, TypeRep, typeRep, - Data, - Generic, - NFData (..), genericRnf, - Binary (..), - Structured, - Alternative (..), - MonadPlus (..), - IsString (..), - - -- * Some types - Map, - Set, - NonEmptySet, - Identity (..), - Proxy (..), - Const (..), - Void, - - -- * Data.Either - partitionEithers, - - -- * Data.Maybe - catMaybes, mapMaybe, - fromMaybe, - maybeToList, listToMaybe, - isNothing, isJust, - - -- * Data.List - unfoldr, - isPrefixOf, isSuffixOf, - intercalate, intersperse, - sort, sortBy, - nub, nubBy, - partition, - - -- * Data.List.NonEmpty - NonEmpty((:|)), foldl1, foldr1, - head, tail, last, init, - - -- * Data.Foldable - Foldable, foldMap, foldr, - null, length, - find, foldl', - traverse_, for_, - any, all, - toList, - - -- * Data.Traversable - Traversable, traverse, sequenceA, - for, - - -- * Data.Function - on, - - -- * Data.Ord - comparing, - - -- * Control.Arrow - first, - - -- * Control.Monad - liftM, liftM2, - unless, when, - ap, void, - foldM, filterM, - join, guard, - - -- * Control.Exception - catch, throwIO, evaluate, - Exception (..), IOException, SomeException (..), -#if !MINVER_base_48 - displayException, -#endif - tryIO, catchIO, catchExit, - - -- * Control.DeepSeq - deepseq, force, - - -- * Data.Char - isSpace, isDigit, isUpper, isAlpha, isAlphaNum, - chr, ord, - toLower, toUpper, - - -- * Data.Void - absurd, vacuous, - - -- * Data.Word & Data.Int - Word, - Word8, Word16, Word32, Word64, - Int8, Int16, Int32, Int64, - - -- * Text.PrettyPrint - (<<>>), (Disp.<+>), - - -- * System.Exit - ExitCode (..), - exitWith, exitSuccess, exitFailure, - - -- * Text.Read - readMaybe, - - -- * Debug.Trace (as deprecated functions) - trace, traceShow, traceShowId, - ) where - --- We also could hide few partial function -import Prelude as BasePrelude hiding - ( mapM, mapM_, sequence, null, length, foldr, any, all, head, tail, last, init - -- partial functions - , read - , foldr1, foldl1 -#if MINVER_base_411 - -- As of base 4.11.0.0 Prelude exports part of Semigroup(..). - -- Hide this so we instead rely on Distribution.Compat.Semigroup. - , Semigroup(..) -#endif -#if MINVER_base_48 - , Word - -- We hide them, as we import only some members - , Traversable, traverse, sequenceA - , Foldable, foldMap -#endif - ) - --- AMP -#if !MINVER_base_48 -import Control.Applicative (Applicative (..), (<$), (<$>)) -import Data.Foldable (toList) -import Distribution.Compat.Semigroup (Monoid (..)) -#else -import Data.Foldable (Foldable (toList), length, null) -#endif - -import Data.Foldable (Foldable (foldMap, foldr), all, any, find, foldl', for_, traverse_) -import Data.Traversable (Traversable (sequenceA, traverse), for) - -import qualified Data.Foldable - --- Extra exports -import Control.Applicative (Alternative (..)) -import Control.Applicative (Const (..)) -import Control.Arrow (first) -import Control.DeepSeq (NFData (..), deepseq, force) -import Control.Exception (Exception (..), IOException, SomeException (..), catch, evaluate, throwIO) -import Control.Monad (MonadPlus (..), ap, filterM, foldM, guard, join, liftM, liftM2, unless, void, when) -import Data.Char (chr, isAlpha, isAlphaNum, isDigit, isSpace, isUpper, ord, toLower, toUpper) -import Data.Data (Data) -import Data.Either (partitionEithers) -import Data.Function (on) -import Data.Functor.Identity (Identity (..)) -import Data.Int (Int16, Int32, Int64, Int8) -import Data.List (intercalate, intersperse, isPrefixOf, isSuffixOf, nub, nubBy, partition, sort, sortBy, unfoldr) -import Data.List.NonEmpty (NonEmpty ((:|)), head, init, last, tail) -import Data.Map (Map) -import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, listToMaybe, mapMaybe, maybeToList) -import Data.Ord (comparing) -import Data.Proxy (Proxy (..)) -import Data.Set (Set) -import Data.String (IsString (..)) -import Data.Void (Void, absurd, vacuous) -import Data.Word (Word, Word16, Word32, Word64, Word8) -import Distribution.Compat.Binary (Binary (..)) -import Distribution.Compat.Semigroup (Semigroup (..), gmappend, gmempty) -import Distribution.Compat.Typeable (TypeRep, Typeable, typeRep) -import GHC.Generics ((:*:) ((:*:)), (:+:) (L1, R1), Generic, K1 (unK1), M1 (unM1), Rep (..), U1 (U1), V1) -import System.Exit (ExitCode (..), exitFailure, exitSuccess, exitWith) -import Text.Read (readMaybe) - -import qualified Text.PrettyPrint as Disp - -import Distribution.Compat.Exception -import Distribution.Compat.NonEmptySet (NonEmptySet) -import Distribution.Utils.Structured (Structured) - -import qualified Debug.Trace - --- | New name for 'Text.PrettyPrint.<>' -(<<>>) :: Disp.Doc -> Disp.Doc -> Disp.Doc -(<<>>) = (Disp.<>) - -#if !MINVER_base_48 --- | Test whether the structure is empty. The default implementation is --- optimized for structures that are similar to cons-lists, because there --- is no general way to do better. -null :: Foldable t => t a -> Bool -null = foldr (\_ _ -> False) True - --- | Returns the size/length of a finite structure as an 'Int'. The --- default implementation is optimized for structures that are similar to --- cons-lists, because there is no general way to do better. -length :: Foldable t => t a -> Int -length = foldl' (\c _ -> c+1) 0 -#endif - - --- | "GHC.Generics"-based 'rnf' implementation --- --- This is needed in order to support @deepseq < 1.4@ which didn't --- have a 'Generic'-based default 'rnf' implementation yet. --- --- In order to define instances, use e.g. --- --- > instance NFData MyType where rnf = genericRnf --- --- The implementation has been taken from @deepseq-1.4.2@'s default --- 'rnf' implementation. -genericRnf :: (Generic a, GNFData (Rep a)) => a -> () -genericRnf = grnf . from - --- | Hidden internal type-class -class GNFData f where - grnf :: f a -> () - -instance GNFData V1 where - grnf = error "Control.DeepSeq.rnf: uninhabited type" - -instance GNFData U1 where - grnf U1 = () - -instance NFData a => GNFData (K1 i a) where - grnf = rnf . unK1 - {-# INLINEABLE grnf #-} - -instance GNFData a => GNFData (M1 i c a) where - grnf = grnf . unM1 - {-# INLINEABLE grnf #-} - -instance (GNFData a, GNFData b) => GNFData (a :*: b) where - grnf (x :*: y) = grnf x `seq` grnf y - {-# INLINEABLE grnf #-} - -instance (GNFData a, GNFData b) => GNFData (a :+: b) where - grnf (L1 x) = grnf x - grnf (R1 x) = grnf x - {-# INLINEABLE grnf #-} - - --- TODO: if we want foldr1/foldl1 to work on more than NonEmpty, we --- can define a local typeclass 'Foldable1', e.g. --- --- @ --- class Foldable f => Foldable1 f --- --- instance Foldable1 NonEmpty --- --- foldr1 :: Foldable1 t => (a -> a -> a) -> t a -> a --- foldr1 = Data.Foldable.foldr1 --- --- foldl1 :: Foldable1 t => (a -> a -> a) -> t a -> a --- foldl1 = Data.Foldable.foldl1 --- @ --- - -{-# INLINE foldr1 #-} -foldr1 :: (a -> a -> a) -> NonEmpty a -> a -foldr1 = Data.Foldable.foldr1 - -{-# INLINE foldl1 #-} -foldl1 :: (a -> a -> a) -> NonEmpty a -> a -foldl1 = Data.Foldable.foldl1 - -------------------------------------------------------------------------------- --- Trace -------------------------------------------------------------------------------- - --- Functions from Debug.Trace --- but with DEPRECATED pragma, so -Werror will scream on them. - -trace :: String -> a -> a -trace = Debug.Trace.trace -{-# DEPRECATED trace "Don't leave me in the code" #-} - -traceShowId :: Show a => a -> a -traceShowId x = Debug.Trace.traceShow x x -{-# DEPRECATED traceShowId "Don't leave me in the code" #-} - -traceShow :: Show a => a -> b -> b -traceShow = Debug.Trace.traceShow -{-# DEPRECATED traceShow "Don't leave me in the code" #-} diff --git a/cabal/Cabal/Distribution/Compat/Prelude/Internal.hs b/cabal/Cabal/Distribution/Compat/Prelude/Internal.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Compat/Prelude/Internal.hs +++ /dev/null @@ -1,14 +0,0 @@ --- | This module re-exports the non-exposed --- "Distribution.Compat.Prelude" module for --- reuse by @cabal-install@'s --- "Distribution.Client.Compat.Prelude" module. --- --- It is highly discouraged to rely on this module --- for @Setup.hs@ scripts since its API is /not/ --- stable. -module Distribution.Compat.Prelude.Internal - {-# WARNING "This modules' API is not stable. Use at your own risk, or better yet, use @base-compat@!" #-} - ( module Distribution.Compat.Prelude - ) where - -import Distribution.Compat.Prelude diff --git a/cabal/Cabal/Distribution/Compat/Process.hs b/cabal/Cabal/Distribution/Compat/Process.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Compat/Process.hs +++ /dev/null @@ -1,82 +0,0 @@ -{-# LANGUAGE CPP #-} -module Distribution.Compat.Process ( - -- * Redefined functions - createProcess, - runInteractiveProcess, - rawSystem, - -- * Additions - enableProcessJobs, - ) where - -import System.Exit (ExitCode (..)) -import System.IO (Handle) - -import System.Process (CreateProcess, ProcessHandle) -import qualified System.Process as Process - -#if MIN_VERSION_process(1,2,0) -import System.Process (waitForProcess) -#endif - -------------------------------------------------------------------------------- --- enableProcessJobs -------------------------------------------------------------------------------- - --- | Enable process jobs to ensure accurate determination of process completion --- in the presence of @exec(3)@ on Windows. --- --- Unfortunately the process job support is badly broken in @process@ releases --- prior to 1.6.8, so we disable it in these versions, despite the fact that --- this means we may see sporatic build failures without jobs. -enableProcessJobs :: CreateProcess -> CreateProcess -#ifdef MIN_VERSION_process -#if MIN_VERSION_process(1,6,8) -enableProcessJobs cp = cp {Process.use_process_jobs = True} -#else -enableProcessJobs cp = cp -#endif -#else -enableProcessJobs cp = cp -#endif - -------------------------------------------------------------------------------- --- process redefinitions -------------------------------------------------------------------------------- - --- | 'System.Process.createProcess' with process jobs enabled when appropriate. --- See 'enableProcessJobs'. -createProcess :: CreateProcess - -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -createProcess = Process.createProcess . enableProcessJobs - --- | 'System.Process.rawSystem' with process jobs enabled when appropriate. --- See 'enableProcessJobs'. -rawSystem :: String -> [String] -> IO ExitCode -rawSystem cmd args = do -#if MIN_VERSION_process(1,2,0) - (_,_,_,p) <- createProcess (Process.proc cmd args) { Process.delegate_ctlc = True } - waitForProcess p -#else - -- With very old 'process', just do its rawSystem - Process.rawSystem cmd args -#endif - --- | 'System.Process.runInteractiveProcess' with process jobs enabled when --- appropriate. See 'enableProcessJobs'. -runInteractiveProcess - :: FilePath -- ^ Filename of the executable (see 'RawCommand' for details) - -> [String] -- ^ Arguments to pass to the executable - -> Maybe FilePath -- ^ Optional path to the working directory - -> Maybe [(String,String)] -- ^ Optional environment (otherwise inherit) - -> IO (Handle,Handle,Handle,ProcessHandle) -runInteractiveProcess cmd args mb_cwd mb_env = do - (mb_in, mb_out, mb_err, p) <- - createProcess (Process.proc cmd args) - { Process.std_in = Process.CreatePipe, - Process.std_out = Process.CreatePipe, - Process.std_err = Process.CreatePipe, - Process.env = mb_env, - Process.cwd = mb_cwd } - return (fromJust mb_in, fromJust mb_out, fromJust mb_err, p) - where - fromJust = maybe (error "runInteractiveProcess: fromJust") id diff --git a/cabal/Cabal/Distribution/Compat/ResponseFile.hs b/cabal/Cabal/Distribution/Compat/ResponseFile.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Compat/ResponseFile.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# LANGUAGE CPP, RankNTypes, FlexibleContexts #-} - --- Compatibility layer for GHC.ResponseFile --- Implementation from base 4.12.0 is used. --- http://hackage.haskell.org/package/base-4.12.0.0/src/LICENSE -module Distribution.Compat.ResponseFile (expandResponse) where - -import Distribution.Compat.Prelude -import Prelude () - -import System.FilePath -import System.IO (hPutStrLn, stderr) -import System.IO.Error - -#if MIN_VERSION_base(4,12,0) -import GHC.ResponseFile (unescapeArgs) -#else - -unescapeArgs :: String -> [String] -unescapeArgs = filter (not . null) . unescape - -data Quoting = NoneQ | SngQ | DblQ - -unescape :: String -> [String] -unescape args = reverse . map reverse $ go args NoneQ False [] [] - where - -- n.b., the order of these cases matters; these are cribbed from gcc - -- case 1: end of input - go [] _q _bs a as = a:as - -- case 2: back-slash escape in progress - go (c:cs) q True a as = go cs q False (c:a) as - -- case 3: no back-slash escape in progress, but got a back-slash - go (c:cs) q False a as - | '\\' == c = go cs q True a as - -- case 4: single-quote escaping in progress - go (c:cs) SngQ False a as - | '\'' == c = go cs NoneQ False a as - | otherwise = go cs SngQ False (c:a) as - -- case 5: double-quote escaping in progress - go (c:cs) DblQ False a as - | '"' == c = go cs NoneQ False a as - | otherwise = go cs DblQ False (c:a) as - -- case 6: no escaping is in progress - go (c:cs) NoneQ False a as - | isSpace c = go cs NoneQ False [] (a:as) - | '\'' == c = go cs SngQ False a as - | '"' == c = go cs DblQ False a as - | otherwise = go cs NoneQ False (c:a) as - -#endif - -expandResponse :: [String] -> IO [String] -expandResponse = go recursionLimit "." - where - recursionLimit = 100 - - go :: Int -> FilePath -> [String] -> IO [String] - go n dir - | n >= 0 = fmap concat . traverse (expand n dir) - | otherwise = const $ hPutStrLn stderr "Error: response file recursion limit exceeded." >> exitFailure - - expand :: Int -> FilePath -> String -> IO [String] - expand n dir arg@('@':f) = readRecursively n (dir f) `catchIOError` (const $ print "?" >> return [arg]) - expand _n _dir x = return [x] - - readRecursively :: Int -> FilePath -> IO [String] - readRecursively n f = go (n - 1) (takeDirectory f) =<< unescapeArgs <$> readFile f diff --git a/cabal/Cabal/Distribution/Compat/Semigroup.hs b/cabal/Cabal/Distribution/Compat/Semigroup.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Compat/Semigroup.hs +++ /dev/null @@ -1,119 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TypeOperators #-} - --- | Compatibility layer for "Data.Semigroup" -module Distribution.Compat.Semigroup - ( Semigroup((<>)) - , Mon.Monoid(..) - , All(..) - , Any(..) - - , First'(..) - , Last'(..) - - , Option'(..) - - , gmappend - , gmempty - ) where - -import Distribution.Compat.Binary (Binary) -import Distribution.Utils.Structured (Structured) -import Data.Typeable (Typeable) - -import GHC.Generics --- Data.Semigroup is available since GHC 8.0/base-4.9 in `base` --- for older GHC/base, it's provided by `semigroups` -import Data.Semigroup -import qualified Data.Monoid as Mon - - --- | A copy of 'Data.Semigroup.First'. -newtype First' a = First' { getFirst' :: a } - deriving (Eq, Ord, Show) - -instance Semigroup (First' a) where - a <> _ = a - --- | A copy of 'Data.Semigroup.Last'. -newtype Last' a = Last' { getLast' :: a } - deriving (Eq, Ord, Read, Show, Generic, Binary, Typeable) - -instance Structured a => Structured (Last' a) - -instance Semigroup (Last' a) where - _ <> b = b - -instance Functor Last' where - fmap f (Last' x) = Last' (f x) - --- | A wrapper around 'Maybe', providing the 'Semigroup' and 'Monoid' instances --- implemented for 'Maybe' since @base-4.11@. -newtype Option' a = Option' { getOption' :: Maybe a } - deriving (Eq, Ord, Read, Show, Binary, Generic, Functor, Typeable) - -instance Structured a => Structured (Option' a) - -instance Semigroup a => Semigroup (Option' a) where - Option' (Just a) <> Option' (Just b) = Option' (Just (a <> b)) - Option' Nothing <> b = b - a <> Option' Nothing = a - -instance Semigroup a => Monoid (Option' a) where - mempty = Option' Nothing - mappend = (<>) - -------------------------------------------------------------------------------- -------------------------------------------------------------------------------- --- Stolen from Edward Kmett's BSD3-licensed `semigroups` package - --- | Generically generate a 'Semigroup' ('<>') operation for any type --- implementing 'Generic'. This operation will append two values --- by point-wise appending their component fields. It is only defined --- for product types. --- --- @ --- 'gmappend' a ('gmappend' b c) = 'gmappend' ('gmappend' a b) c --- @ -gmappend :: (Generic a, GSemigroup (Rep a)) => a -> a -> a -gmappend x y = to (gmappend' (from x) (from y)) - -class GSemigroup f where - gmappend' :: f p -> f p -> f p - -instance Semigroup a => GSemigroup (K1 i a) where - gmappend' (K1 x) (K1 y) = K1 (x <> y) - -instance GSemigroup f => GSemigroup (M1 i c f) where - gmappend' (M1 x) (M1 y) = M1 (gmappend' x y) - -instance (GSemigroup f, GSemigroup g) => GSemigroup (f :*: g) where - gmappend' (x1 :*: x2) (y1 :*: y2) = gmappend' x1 y1 :*: gmappend' x2 y2 - --- | Generically generate a 'Monoid' 'mempty' for any product-like type --- implementing 'Generic'. --- --- It is only defined for product types. --- --- @ --- 'gmappend' 'gmempty' a = a = 'gmappend' a 'gmempty' --- @ - -gmempty :: (Generic a, GMonoid (Rep a)) => a -gmempty = to gmempty' - -class GSemigroup f => GMonoid f where - gmempty' :: f p - -instance (Semigroup a, Monoid a) => GMonoid (K1 i a) where - gmempty' = K1 mempty - -instance GMonoid f => GMonoid (M1 i c f) where - gmempty' = M1 gmempty' - -instance (GMonoid f, GMonoid g) => GMonoid (f :*: g) where - gmempty' = gmempty' :*: gmempty' diff --git a/cabal/Cabal/Distribution/Compat/SnocList.hs b/cabal/Cabal/Distribution/Compat/SnocList.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Compat/SnocList.hs +++ /dev/null @@ -1,33 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Compat.SnocList --- License : BSD3 --- --- Maintainer : cabal-dev@haskell.org --- Stability : experimental --- Portability : portable --- --- A very reversed list. Has efficient `snoc` -module Distribution.Compat.SnocList ( - SnocList, - runSnocList, - snoc, -) where - -import Prelude () -import Distribution.Compat.Prelude - -newtype SnocList a = SnocList [a] - -snoc :: SnocList a -> a -> SnocList a -snoc (SnocList xs) x = SnocList (x : xs) - -runSnocList :: SnocList a -> [a] -runSnocList (SnocList xs) = reverse xs - -instance Semigroup (SnocList a) where - SnocList xs <> SnocList ys = SnocList (ys <> xs) - -instance Monoid (SnocList a) where - mempty = SnocList [] - mappend = (<>) diff --git a/cabal/Cabal/Distribution/Compat/Stack.hs b/cabal/Cabal/Distribution/Compat/Stack.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Compat/Stack.hs +++ /dev/null @@ -1,113 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ImplicitParams #-} -module Distribution.Compat.Stack ( - WithCallStack, - CallStack, - annotateCallStackIO, - withFrozenCallStack, - withLexicalCallStack, - callStack, - prettyCallStack, - parentSrcLocPrefix -) where - -import System.IO.Error - -#ifdef MIN_VERSION_base -#if MIN_VERSION_base(4,8,1) -#define GHC_STACK_SUPPORTED 1 -#endif -#endif - -#ifdef GHC_STACK_SUPPORTED -import GHC.Stack -#endif - -#ifdef GHC_STACK_SUPPORTED - -#if MIN_VERSION_base(4,9,0) -type WithCallStack a = HasCallStack => a -#elif MIN_VERSION_base(4,8,1) -type WithCallStack a = (?callStack :: CallStack) => a -#endif - -#if !MIN_VERSION_base(4,9,0) --- NB: Can't say WithCallStack (WithCallStack a -> a); --- Haskell doesn't support this kind of implicit parameter! --- See https://mail.haskell.org/pipermail/ghc-devs/2016-January/011096.html --- Since this function doesn't do anything, it's OK to --- give it a less good type. -withFrozenCallStack :: WithCallStack (a -> a) -withFrozenCallStack x = x - -callStack :: (?callStack :: CallStack) => CallStack -callStack = ?callStack - -prettyCallStack :: CallStack -> String -prettyCallStack = showCallStack -#endif - --- | Give the *parent* of the person who invoked this; --- so it's most suitable for being called from a utility function. --- You probably want to call this using 'withFrozenCallStack'; otherwise --- it's not very useful. We didn't implement this for base-4.8.1 --- because we cannot rely on freezing to have taken place. --- -parentSrcLocPrefix :: WithCallStack String -#if MIN_VERSION_base(4,9,0) -parentSrcLocPrefix = - case getCallStack callStack of - (_:(_, loc):_) -> showLoc loc - [(_, loc)] -> showLoc loc - [] -> error "parentSrcLocPrefix: empty call stack" - where - showLoc loc = - srcLocFile loc ++ ":" ++ show (srcLocStartLine loc) ++ ": " -#else -parentSrcLocPrefix = "Call sites not available with base < 4.9.0.0 (GHC 8.0): " -#endif - --- Yeah, this uses skivvy implementation details. -withLexicalCallStack :: (a -> WithCallStack (IO b)) -> WithCallStack (a -> IO b) -withLexicalCallStack f = - let stk = ?callStack - in \x -> let ?callStack = stk in f x - -#else - -data CallStack = CallStack - deriving (Eq, Show) - -type WithCallStack a = a - -withFrozenCallStack :: a -> a -withFrozenCallStack x = x - -callStack :: CallStack -callStack = CallStack - -prettyCallStack :: CallStack -> String -prettyCallStack _ = "Call stacks not available with base < 4.8.1.0 (GHC 7.10)" - -parentSrcLocPrefix :: String -parentSrcLocPrefix = "Call sites not available with base < 4.9.0.0 (GHC 8.0): " - -withLexicalCallStack :: (a -> IO b) -> a -> IO b -withLexicalCallStack f = f - -#endif - --- | This function is for when you *really* want to add a call --- stack to raised IO, but you don't have a --- 'Distribution.Verbosity.Verbosity' so you can't use --- 'Distribution.Simple.Utils.annotateIO'. If you have a 'Verbosity', --- please use that function instead. -annotateCallStackIO :: WithCallStack (IO a -> IO a) -annotateCallStackIO = modifyIOError f - where - f ioe = ioeSetErrorString ioe - . wrapCallStack - $ ioeGetErrorString ioe - wrapCallStack s = - prettyCallStack callStack ++ "\n" ++ s diff --git a/cabal/Cabal/Distribution/Compat/Time.hs b/cabal/Cabal/Distribution/Compat/Time.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Compat/Time.hs +++ /dev/null @@ -1,194 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Distribution.Compat.Time - ( ModTime(..) -- Needed for testing - , getModTime, getFileAge, getCurTime - , posixSecondsToModTime - , calibrateMtimeChangeDelay ) - where - -import Prelude () -import Distribution.Compat.Prelude - -import System.Directory ( getModificationTime ) - -import Distribution.Simple.Utils ( withTempDirectory ) -import Distribution.Verbosity ( silent ) - -import System.FilePath - -import Data.Time.Clock.POSIX ( POSIXTime, getPOSIXTime ) -import Data.Time ( diffUTCTime, getCurrentTime ) -import Data.Time.Clock.POSIX ( posixDayLength ) - - -#if defined mingw32_HOST_OS - -import qualified Prelude -import Data.Bits ((.|.), unsafeShiftL) -#if MIN_VERSION_base(4,7,0) -import Data.Bits (finiteBitSize) -#else -import Data.Bits (bitSize) -#endif - -import Foreign ( allocaBytes, peekByteOff ) -import System.IO.Error ( mkIOError, doesNotExistErrorType ) -import System.Win32.Types ( BOOL, DWORD, LPCTSTR, LPVOID, withTString ) - -#else - -import System.Posix.Files ( FileStatus, getFileStatus ) - -#if MIN_VERSION_unix(2,6,0) -import System.Posix.Files ( modificationTimeHiRes ) -#else -import System.Posix.Files ( modificationTime ) -#endif - -#endif - --- | An opaque type representing a file's modification time, represented --- internally as a 64-bit unsigned integer in the Windows UTC format. -newtype ModTime = ModTime Word64 - deriving (Binary, Generic, Bounded, Eq, Ord, Typeable) - -instance Structured ModTime - -instance Show ModTime where - show (ModTime x) = show x - -instance Read ModTime where - readsPrec p str = map (first ModTime) (readsPrec p str) - --- | Return modification time of the given file. Works around the low clock --- resolution problem that 'getModificationTime' has on GHC < 7.8. --- --- This is a modified version of the code originally written for Shake by Neil --- Mitchell. See module Development.Shake.FileInfo. -getModTime :: FilePath -> IO ModTime - -#if defined mingw32_HOST_OS - --- Directly against the Win32 API. -getModTime path = allocaBytes size_WIN32_FILE_ATTRIBUTE_DATA $ \info -> do - res <- getFileAttributesEx path info - if not res - then do - let err = mkIOError doesNotExistErrorType - "Distribution.Compat.Time.getModTime" - Nothing (Just path) - ioError err - else do - dwLow <- peekByteOff info - index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime - dwHigh <- peekByteOff info - index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwHighDateTime -#if MIN_VERSION_base(4,7,0) - let qwTime = - (fromIntegral (dwHigh :: DWORD) `unsafeShiftL` finiteBitSize dwHigh) - .|. (fromIntegral (dwLow :: DWORD)) -#else - let qwTime = - (fromIntegral (dwHigh :: DWORD) `unsafeShiftL` bitSize dwHigh) - .|. (fromIntegral (dwLow :: DWORD)) -#endif - return $! ModTime (qwTime :: Word64) - -#ifdef x86_64_HOST_ARCH -#define CALLCONV ccall -#else -#define CALLCONV stdcall -#endif - -foreign import CALLCONV "windows.h GetFileAttributesExW" - c_getFileAttributesEx :: LPCTSTR -> Int32 -> LPVOID -> Prelude.IO BOOL - -getFileAttributesEx :: String -> LPVOID -> IO BOOL -getFileAttributesEx path lpFileInformation = - withTString path $ \c_path -> - c_getFileAttributesEx c_path getFileExInfoStandard lpFileInformation - -getFileExInfoStandard :: Int32 -getFileExInfoStandard = 0 - -size_WIN32_FILE_ATTRIBUTE_DATA :: Int -size_WIN32_FILE_ATTRIBUTE_DATA = 36 - -index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime :: Int -index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime = 20 - -index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwHighDateTime :: Int -index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwHighDateTime = 24 - -#else - --- Directly against the unix library. -getModTime path = do - st <- getFileStatus path - return $! (extractFileTime st) - -extractFileTime :: FileStatus -> ModTime -extractFileTime x = posixTimeToModTime (modificationTimeHiRes x) - -#endif - -windowsTick, secToUnixEpoch :: Word64 -windowsTick = 10000000 -secToUnixEpoch = 11644473600 - --- | Convert POSIX seconds to ModTime. -posixSecondsToModTime :: Int64 -> ModTime -posixSecondsToModTime s = - ModTime $ ((fromIntegral s :: Word64) + secToUnixEpoch) * windowsTick - --- | Convert 'POSIXTime' to 'ModTime'. -posixTimeToModTime :: POSIXTime -> ModTime -posixTimeToModTime p = ModTime $ (ceiling $ p * 1e7) -- 100 ns precision - + (secToUnixEpoch * windowsTick) - --- | Return age of given file in days. -getFileAge :: FilePath -> IO Double -getFileAge file = do - t0 <- getModificationTime file - t1 <- getCurrentTime - return $ realToFrac (t1 `diffUTCTime` t0) / realToFrac posixDayLength - --- | Return the current time as 'ModTime'. -getCurTime :: IO ModTime -getCurTime = posixTimeToModTime `fmap` getPOSIXTime -- Uses 'gettimeofday'. - --- | Based on code written by Neil Mitchell for Shake. See --- 'sleepFileTimeCalibrate' in 'Test.Type'. Returns a pair --- of microsecond values: first, the maximum delay seen, and the --- recommended delay to use before testing for file modification change. --- The returned delay is never smaller --- than 10 ms, but never larger than 1 second. -calibrateMtimeChangeDelay :: IO (Int, Int) -calibrateMtimeChangeDelay = - withTempDirectory silent "." "calibration-" $ \dir -> do - let fileName = dir "probe" - mtimes <- for [1..25] $ \(i::Int) -> time $ do - writeFile fileName $ show i - t0 <- getModTime fileName - let spin j = do - writeFile fileName $ show (i,j) - t1 <- getModTime fileName - unless (t0 < t1) (spin $ j + 1) - spin (0::Int) - let mtimeChange = maximum mtimes - mtimeChange' = min 1000000 $ (max 10000 mtimeChange) * 2 - return (mtimeChange, mtimeChange') - where - time :: IO () -> IO Int - time act = do - t0 <- getCurrentTime - act - t1 <- getCurrentTime - return . ceiling $! (t1 `diffUTCTime` t0) * 1e6 -- microseconds diff --git a/cabal/Cabal/Distribution/Compat/Typeable.hs b/cabal/Cabal/Distribution/Compat/Typeable.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Compat/Typeable.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Distribution.Compat.Typeable ( - Typeable, - TypeRep, - typeRep, - ) where - -#if MIN_VERSION_base(4,7,0) -import Data.Typeable (Typeable, TypeRep, typeRep) -#else -import Data.Typeable (Typeable, TypeRep, typeOf) -#endif - -#if !MIN_VERSION_base(4,7,0) -typeRep :: forall a proxy. Typeable a => proxy a -> TypeRep -typeRep _ = typeOf (undefined :: a) -#endif diff --git a/cabal/Cabal/Distribution/Compiler.hs b/cabal/Cabal/Distribution/Compiler.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Compiler.hs +++ /dev/null @@ -1,223 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveTraversable #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Compiler --- Copyright : Isaac Jones 2003-2004 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This has an enumeration of the various compilers that Cabal knows about. It --- also specifies the default compiler. Sadly you'll often see code that does --- case analysis on this compiler flavour enumeration like: --- --- > case compilerFlavor comp of --- > GHC -> GHC.getInstalledPackages verbosity packageDb progdb --- --- Obviously it would be better to use the proper 'Compiler' abstraction --- because that would keep all the compiler-specific code together. --- Unfortunately we cannot make this change yet without breaking the --- 'UserHooks' api, which would break all custom @Setup.hs@ files, so for the --- moment we just have to live with this deficiency. If you're interested, see --- ticket #57. - -module Distribution.Compiler ( - -- * Compiler flavor - CompilerFlavor(..), - buildCompilerId, - buildCompilerFlavor, - defaultCompilerFlavor, - classifyCompilerFlavor, - knownCompilerFlavors, - - -- * Per compiler flavor - PerCompilerFlavor (..), - perCompilerFlavorToList, - - -- * Compiler id - CompilerId(..), - - -- * Compiler info - CompilerInfo(..), - unknownCompilerInfo, - AbiTag(..), abiTagString - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Language.Haskell.Extension - -import Distribution.Version (Version, mkVersion', nullVersion) - -import qualified System.Info (compilerName, compilerVersion) -import Distribution.Parsec (Parsec (..)) -import Distribution.Pretty (Pretty (..), prettyShow) -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - -data CompilerFlavor = - GHC | GHCJS | NHC | YHC | Hugs | HBC | Helium | JHC | LHC | UHC | Eta - | HaskellSuite String -- string is the id of the actual compiler - | OtherCompiler String - deriving (Generic, Show, Read, Eq, Ord, Typeable, Data) - -instance Binary CompilerFlavor -instance Structured CompilerFlavor -instance NFData CompilerFlavor where rnf = genericRnf - -knownCompilerFlavors :: [CompilerFlavor] -knownCompilerFlavors = - [GHC, GHCJS, NHC, YHC, Hugs, HBC, Helium, JHC, LHC, UHC, Eta] - -instance Pretty CompilerFlavor where - pretty (OtherCompiler name) = Disp.text name - pretty (HaskellSuite name) = Disp.text name - pretty NHC = Disp.text "nhc98" - pretty other = Disp.text (lowercase (show other)) - -instance Parsec CompilerFlavor where - parsec = classifyCompilerFlavor <$> component - where - component = do - cs <- P.munch1 isAlphaNum - if all isDigit cs then fail "all digits compiler name" else return cs - -classifyCompilerFlavor :: String -> CompilerFlavor -classifyCompilerFlavor s = - fromMaybe (OtherCompiler s) $ lookup (lowercase s) compilerMap - where - compilerMap = [ (lowercase (prettyShow compiler), compiler) - | compiler <- knownCompilerFlavors ] - -buildCompilerFlavor :: CompilerFlavor -buildCompilerFlavor = classifyCompilerFlavor System.Info.compilerName - -buildCompilerVersion :: Version -buildCompilerVersion = mkVersion' System.Info.compilerVersion - -buildCompilerId :: CompilerId -buildCompilerId = CompilerId buildCompilerFlavor buildCompilerVersion - --- | The default compiler flavour to pick when compiling stuff. This defaults --- to the compiler used to build the Cabal lib. --- --- However if it's not a recognised compiler then it's 'Nothing' and the user --- will have to specify which compiler they want. --- -defaultCompilerFlavor :: Maybe CompilerFlavor -defaultCompilerFlavor = case buildCompilerFlavor of - OtherCompiler _ -> Nothing - _ -> Just buildCompilerFlavor - -------------------------------------------------------------------------------- --- Per compiler data -------------------------------------------------------------------------------- - --- | 'PerCompilerFlavor' carries only info per GHC and GHCJS --- --- Cabal parses only @ghc-options@ and @ghcjs-options@, others are omitted. --- -data PerCompilerFlavor v = PerCompilerFlavor v v - deriving (Generic, Show, Read, Eq, Typeable, Data, Functor, Foldable - , Traversable) - -instance Binary a => Binary (PerCompilerFlavor a) -instance Structured a => Structured (PerCompilerFlavor a) -instance NFData a => NFData (PerCompilerFlavor a) - -perCompilerFlavorToList :: PerCompilerFlavor v -> [(CompilerFlavor, v)] -perCompilerFlavorToList (PerCompilerFlavor a b) = [(GHC, a), (GHCJS, b)] - -instance Semigroup a => Semigroup (PerCompilerFlavor a) where - PerCompilerFlavor a b <> PerCompilerFlavor a' b' = PerCompilerFlavor - (a <> a') (b <> b') - -instance (Semigroup a, Monoid a) => Monoid (PerCompilerFlavor a) where - mempty = PerCompilerFlavor mempty mempty - mappend = (<>) - --- ------------------------------------------------------------ --- * Compiler Id --- ------------------------------------------------------------ - -data CompilerId = CompilerId CompilerFlavor Version - deriving (Eq, Generic, Ord, Read, Show, Typeable) - -instance Binary CompilerId -instance Structured CompilerId -instance NFData CompilerId where rnf = genericRnf - -instance Pretty CompilerId where - pretty (CompilerId f v) - | v == nullVersion = pretty f - | otherwise = pretty f <<>> Disp.char '-' <<>> pretty v - -instance Parsec CompilerId where - parsec = do - flavour <- parsec - version <- (P.char '-' >> parsec) <|> return nullVersion - return (CompilerId flavour version) - -lowercase :: String -> String -lowercase = map toLower - --- ------------------------------------------------------------ --- * Compiler Info --- ------------------------------------------------------------ - --- | Compiler information used for resolving configurations. Some --- fields can be set to Nothing to indicate that the information is --- unknown. - -data CompilerInfo = CompilerInfo { - compilerInfoId :: CompilerId, - -- ^ Compiler flavour and version. - compilerInfoAbiTag :: AbiTag, - -- ^ Tag for distinguishing incompatible ABI's on the same - -- architecture/os. - compilerInfoCompat :: Maybe [CompilerId], - -- ^ Other implementations that this compiler claims to be - -- compatible with, if known. - compilerInfoLanguages :: Maybe [Language], - -- ^ Supported language standards, if known. - compilerInfoExtensions :: Maybe [Extension] - -- ^ Supported extensions, if known. - } - deriving (Generic, Show, Read) - -instance Binary CompilerInfo - -data AbiTag - = NoAbiTag - | AbiTag String - deriving (Eq, Generic, Show, Read, Typeable) - -instance Binary AbiTag -instance Structured AbiTag - -instance Pretty AbiTag where - pretty NoAbiTag = Disp.empty - pretty (AbiTag tag) = Disp.text tag - -instance Parsec AbiTag where - parsec = do - tag <- P.munch (\c -> isAlphaNum c || c == '_') - if null tag then return NoAbiTag else return (AbiTag tag) - -abiTagString :: AbiTag -> String -abiTagString NoAbiTag = "" -abiTagString (AbiTag tag) = tag - --- | Make a CompilerInfo of which only the known information is its CompilerId, --- its AbiTag and that it does not claim to be compatible with other --- compiler id's. -unknownCompilerInfo :: CompilerId -> AbiTag -> CompilerInfo -unknownCompilerInfo compilerId abiTag = - CompilerInfo compilerId abiTag (Just []) Nothing Nothing diff --git a/cabal/Cabal/Distribution/FieldGrammar.hs b/cabal/Cabal/Distribution/FieldGrammar.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/FieldGrammar.hs +++ /dev/null @@ -1,88 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} --- | This module provides a way to specify a grammar of @.cabal@ -like files. -module Distribution.FieldGrammar ( - -- * Field grammar type - FieldGrammar (..), - uniqueField, - optionalField, - optionalFieldDef, - monoidalField, - -- * Concrete grammar implementations - ParsecFieldGrammar, - ParsecFieldGrammar', - parseFieldGrammar, - fieldGrammarKnownFieldList, - PrettyFieldGrammar, - PrettyFieldGrammar', - prettyFieldGrammar, - -- * Auxlilary - (^^^), - Section(..), - Fields, - partitionFields, - takeFields, - runFieldParser, - runFieldParser', - defaultFreeTextFieldDefST, - -- * Newtypes - module Distribution.FieldGrammar.Newtypes, - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import qualified Data.Map.Strict as Map - -import Distribution.FieldGrammar.Class -import Distribution.FieldGrammar.Newtypes -import Distribution.FieldGrammar.Parsec -import Distribution.FieldGrammar.Pretty -import Distribution.Fields.Field -import Distribution.Utils.Generic (spanMaybe) - -type ParsecFieldGrammar' a = ParsecFieldGrammar a a -type PrettyFieldGrammar' a = PrettyFieldGrammar a a - -infixl 5 ^^^ - --- | Reverse function application which binds tighter than '<$>' and '<*>'. --- Useful for refining grammar specification. --- --- @ --- \<*\> 'monoidalFieldAla' "extensions" (alaList' FSep MQuoted) oldExtensions --- ^^^ 'deprecatedSince' [1,12] "Please use 'default-extensions' or 'other-extensions' fields." --- @ -(^^^) :: a -> (a -> b) -> b -x ^^^ f = f x - --- | Partitioning state -data PS ann = PS (Fields ann) [Section ann] [[Section ann]] - --- | Partition field list into field map and groups of sections. -partitionFields :: [Field ann] -> (Fields ann, [[Section ann]]) -partitionFields = finalize . foldl' f (PS mempty mempty mempty) - where - finalize :: PS ann -> (Fields ann, [[Section ann]]) - finalize (PS fs s ss) - | null s = (fs, reverse ss) - | otherwise = (fs, reverse (reverse s : ss)) - - f :: PS ann -> Field ann -> PS ann - f (PS fs s ss) (Field (Name ann name) fss) = - PS (Map.insertWith (flip (++)) name [MkNamelessField ann fss] fs) [] ss' - where - ss' | null s = ss - | otherwise = reverse s : ss - f (PS fs s ss) (Section name sargs sfields) = - PS fs (MkSection name sargs sfields : s) ss - --- | Take all fields from the front. -takeFields :: [Field ann] -> (Fields ann, [Field ann]) -takeFields = finalize . spanMaybe match - where - finalize (fs, rest) = (Map.fromListWith (flip (++)) fs, rest) - - match (Field (Name ann name) fs) = Just (name, [MkNamelessField ann fs]) - match _ = Nothing diff --git a/cabal/Cabal/Distribution/FieldGrammar/Class.hs b/cabal/Cabal/Distribution/FieldGrammar/Class.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/FieldGrammar/Class.hs +++ /dev/null @@ -1,192 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -#if __GLASGOW_HASKELL__ >= 800 -{-# LANGUAGE UndecidableSuperClasses #-} -#else -{-# LANGUAGE UndecidableInstances #-} -#endif -module Distribution.FieldGrammar.Class ( - FieldGrammar (..), - uniqueField, - optionalField, - optionalFieldDef, - monoidalField, - defaultFreeTextFieldDefST, -) where - -import Distribution.Compat.Lens -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.CabalSpecVersion (CabalSpecVersion) -import Distribution.Compat.Newtype (Newtype) -import Distribution.FieldGrammar.Newtypes -import Distribution.Fields.Field -import Distribution.Utils.ShortText - --- | 'FieldGrammar' is parametrised by --- --- * @s@ which is a structure we are parsing. We need this to provide prettyprinter --- functionality --- --- * @a@ type of the field. --- --- /Note:/ We'd like to have @forall s. Applicative (f s)@ context. --- -class - ( c SpecVersion, c TestedWith, c SpecLicense, c Token, c Token', c FilePathNT - ) - => FieldGrammar c g | g -> c - where - -- | Unfocus, zoom out, /blur/ 'FieldGrammar'. - blurFieldGrammar :: ALens' a b -> g b d -> g a d - - -- | Field which should be defined, exactly once. - uniqueFieldAla - :: (c b, Newtype a b) - => FieldName -- ^ field name - -> (a -> b) -- ^ 'Newtype' pack - -> ALens' s a -- ^ lens into the field - -> g s a - - -- | Boolean field with a default value. - booleanFieldDef - :: FieldName -- ^ field name - -> ALens' s Bool -- ^ lens into the field - -> Bool -- ^ default - -> g s Bool - - -- | Optional field. - optionalFieldAla - :: (c b, Newtype a b) - => FieldName -- ^ field name - -> (a -> b) -- ^ 'pack' - -> ALens' s (Maybe a) -- ^ lens into the field - -> g s (Maybe a) - - -- | Optional field with default value. - optionalFieldDefAla - :: (c b, Newtype a b, Eq a) - => FieldName -- ^ field name - -> (a -> b) -- ^ 'Newtype' pack - -> ALens' s a -- ^ @'Lens'' s a@: lens into the field - -> a -- ^ default value - -> g s a - - -- | Free text field is essentially 'optionalFieldDefAla` with @""@ - -- as the default and "accept everything" parser. - -- - -- @since 3.0.0.0 - freeTextField - :: FieldName - -> ALens' s (Maybe String) -- ^ lens into the field - -> g s (Maybe String) - - -- | Free text field is essentially 'optionalFieldDefAla` with @""@ - -- as the default and "accept everything" parser. - -- - -- @since 3.0.0.0 - freeTextFieldDef - :: FieldName - -> ALens' s String -- ^ lens into the field - -> g s String - - -- | @since 3.2.0.0 - freeTextFieldDefST - :: FieldName - -> ALens' s ShortText -- ^ lens into the field - -> g s ShortText - - -- | Monoidal field. - -- - -- Values are combined with 'mappend'. - -- - -- /Note:/ 'optionalFieldAla' is a @monoidalField@ with 'Last' monoid. - -- - monoidalFieldAla - :: (c b, Monoid a, Newtype a b) - => FieldName -- ^ field name - -> (a -> b) -- ^ 'pack' - -> ALens' s a -- ^ lens into the field - -> g s a - - -- | Parser matching all fields with a name starting with a prefix. - prefixedFields - :: FieldName -- ^ field name prefix - -> ALens' s [(String, String)] -- ^ lens into the field - -> g s [(String, String)] - - -- | Known field, which we don't parse, neither pretty print. - knownField :: FieldName -> g s () - - -- | Field which is parsed but not pretty printed. - hiddenField :: g s a -> g s a - - -- | Deprecated since - deprecatedSince - :: CabalSpecVersion -- ^ version - -> String -- ^ deprecation message - -> g s a - -> g s a - - -- | Removed in. If we occur removed field, parsing fails. - removedIn - :: CabalSpecVersion -- ^ version - -> String -- ^ removal message - -> g s a - -> g s a - - -- | Annotate field with since spec-version. - availableSince - :: CabalSpecVersion -- ^ spec version - -> a -- ^ default value - -> g s a - -> g s a - --- | Field which can be defined at most once. -uniqueField - :: (FieldGrammar c g, c (Identity a)) - => FieldName -- ^ field name - -> ALens' s a -- ^ lens into the field - -> g s a -uniqueField fn l = uniqueFieldAla fn Identity l - --- | Field which can be defined at most once. -optionalField - :: (FieldGrammar c g, c (Identity a)) - => FieldName -- ^ field name - -> ALens' s (Maybe a) -- ^ lens into the field - -> g s (Maybe a) -optionalField fn l = optionalFieldAla fn Identity l - --- | Optional field with default value. -optionalFieldDef - :: (FieldGrammar c g, Functor (g s), c (Identity a), Eq a) - => FieldName -- ^ field name - -> ALens' s a -- ^ @'Lens'' s a@: lens into the field - -> a -- ^ default value - -> g s a -optionalFieldDef fn l x = optionalFieldDefAla fn Identity l x - --- | Field which can be define multiple times, and the results are @mappend@ed. -monoidalField - :: (FieldGrammar c g, c (Identity a), Monoid a) - => FieldName -- ^ field name - -> ALens' s a -- ^ lens into the field - -> g s a -monoidalField fn l = monoidalFieldAla fn Identity l - --- | Default implementation for 'freeTextFieldDefST'. -defaultFreeTextFieldDefST - :: (Functor (g s), FieldGrammar c g) - => FieldName - -> ALens' s ShortText -- ^ lens into the field - -> g s ShortText -defaultFreeTextFieldDefST fn l = - toShortText <$> freeTextFieldDef fn (cloneLens l . st) - where - st :: Lens' ShortText String - st f s = toShortText <$> f (fromShortText s) diff --git a/cabal/Cabal/Distribution/FieldGrammar/FieldDescrs.hs b/cabal/Cabal/Distribution/FieldGrammar/FieldDescrs.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/FieldGrammar/FieldDescrs.hs +++ /dev/null @@ -1,122 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE NoMonoLocalBinds #-} -module Distribution.FieldGrammar.FieldDescrs ( - FieldDescrs, - fieldDescrPretty, - fieldDescrParse, - fieldDescrsToList, - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Data.List (dropWhileEnd) -import Distribution.Compat.Lens (aview, cloneLens) -import Distribution.Compat.Newtype -import Distribution.FieldGrammar -import Distribution.Pretty (Pretty (..), showFreeText) - -import qualified Data.Map as Map -import qualified Distribution.Compat.CharParsing as C -import qualified Distribution.Fields.Field as P -import qualified Distribution.Parsec as P -import qualified Text.PrettyPrint as Disp - --- strict pair -data SP s = SP - { pPretty :: !(s -> Disp.Doc) - , pParse :: !(forall m. P.CabalParsing m => s -> m s) - } - --- | A collection field parsers and pretty-printers. -newtype FieldDescrs s a = F { runF :: Map P.FieldName (SP s) } - deriving (Functor) - -instance Applicative (FieldDescrs s) where - pure _ = F mempty - f <*> x = F (mappend (runF f) (runF x)) - -singletonF :: P.FieldName -> (s -> Disp.Doc) -> (forall m. P.CabalParsing m => s -> m s) -> FieldDescrs s a -singletonF fn f g = F $ Map.singleton fn (SP f g) - --- | Lookup a field value pretty-printer. -fieldDescrPretty :: FieldDescrs s a -> P.FieldName -> Maybe (s -> Disp.Doc) -fieldDescrPretty (F m) fn = pPretty <$> Map.lookup fn m - --- | Lookup a field value parser. -fieldDescrParse :: P.CabalParsing m => FieldDescrs s a -> P.FieldName -> Maybe (s -> m s) -fieldDescrParse (F m) fn = (\f -> pParse f) <$> Map.lookup fn m - -fieldDescrsToList - :: P.CabalParsing m - => FieldDescrs s a - -> [(P.FieldName, s -> Disp.Doc, s -> m s)] -fieldDescrsToList = map mk . Map.toList . runF where - mk (name, SP ppr parse) = (name, ppr, parse) - --- | /Note:/ default values are printed. -instance FieldGrammar ParsecPretty FieldDescrs where - blurFieldGrammar l (F m) = F (fmap blur m) where - blur (SP f g) = SP (f . aview l) (cloneLens l g) - - booleanFieldDef fn l _def = singletonF fn f g where - f s = Disp.text (show (aview l s)) - g s = cloneLens l (const P.parsec) s - -- Note: eta expansion is needed for RankNTypes type-checking to work. - - uniqueFieldAla fn _pack l = singletonF fn f g where - f s = pretty (pack' _pack (aview l s)) - g s = cloneLens l (const (unpack' _pack <$> P.parsec)) s - - optionalFieldAla fn _pack l = singletonF fn f g where - f s = maybe mempty (pretty . pack' _pack) (aview l s) - g s = cloneLens l (const (Just . unpack' _pack <$> P.parsec)) s - - optionalFieldDefAla fn _pack l _def = singletonF fn f g where - f s = pretty (pack' _pack (aview l s)) - g s = cloneLens l (const (unpack' _pack <$> P.parsec)) s - - freeTextField fn l = singletonF fn f g where - f s = maybe mempty showFreeText (aview l s) - g s = cloneLens l (const (Just <$> parsecFreeText)) s - - freeTextFieldDef fn l = singletonF fn f g where - f s = showFreeText (aview l s) - g s = cloneLens l (const parsecFreeText) s - - freeTextFieldDefST = defaultFreeTextFieldDefST - - monoidalFieldAla fn _pack l = singletonF fn f g where - f s = pretty (pack' _pack (aview l s)) - g s = cloneLens l (\x -> mappend x . unpack' _pack <$> P.parsec) s - - prefixedFields _fnPfx _l = F mempty - knownField _ = pure () - deprecatedSince _ _ x = x - removedIn _ _ x = x - availableSince _ _ = id - hiddenField _ = F mempty - -parsecFreeText :: P.CabalParsing m => m String -parsecFreeText = dropDotLines <$ C.spaces <*> many C.anyChar - where - -- Example package with dot lines - -- http://hackage.haskell.org/package/copilot-cbmc-0.1/copilot-cbmc.cabal - dropDotLines "." = "." - dropDotLines x = intercalate "\n" . map dotToEmpty . lines $ x - - dotToEmpty x | trim' x == "." = "" - dotToEmpty x = trim x - - trim' :: String -> String - trim' = dropWhileEnd (`elem` (" \t" :: String)) - - trim :: String -> String - trim = dropWhile isSpace . dropWhileEnd isSpace - -class (P.Parsec a, Pretty a) => ParsecPretty a -instance (P.Parsec a, Pretty a) => ParsecPretty a diff --git a/cabal/Cabal/Distribution/FieldGrammar/Newtypes.hs b/cabal/Cabal/Distribution/FieldGrammar/Newtypes.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/FieldGrammar/Newtypes.hs +++ /dev/null @@ -1,339 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} --- | This module provides @newtype@ wrappers to be used with "Distribution.FieldGrammar". -module Distribution.FieldGrammar.Newtypes ( - -- * List - alaList, - alaList', - -- ** Modifiers - CommaVCat (..), - CommaFSep (..), - VCat (..), - FSep (..), - NoCommaFSep (..), - Sep (..), - -- ** Type - List, - -- * Set - alaSet, - alaSet', - Set', - -- * Version & License - SpecVersion (..), - TestedWith (..), - SpecLicense (..), - -- * Identifiers - Token (..), - Token' (..), - MQuoted (..), - FilePathNT (..), - ) where - -import Distribution.Compat.Newtype -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.CabalSpecVersion -import Distribution.Compiler (CompilerFlavor) -import Distribution.License (License) -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Version - (LowerBound (..), Version, VersionRange, VersionRangeF (..), anyVersion, asVersionIntervals, cataVersionRange, mkVersion, version0, versionNumbers) -import Text.PrettyPrint (Doc, comma, fsep, punctuate, text, vcat) - -import qualified Data.Set as Set -import qualified Distribution.Compat.CharParsing as P -import qualified Distribution.SPDX as SPDX - --- | Vertical list with commas. Displayed with 'vcat' -data CommaVCat = CommaVCat - --- | Paragraph fill list with commas. Displayed with 'fsep' -data CommaFSep = CommaFSep - --- | Vertical list with optional commas. Displayed with 'vcat'. -data VCat = VCat - --- | Paragraph fill list with optional commas. Displayed with 'fsep'. -data FSep = FSep - --- | Paragraph fill list without commas. Displayed with 'fsep'. -data NoCommaFSep = NoCommaFSep - -class Sep sep where - prettySep :: Proxy sep -> [Doc] -> Doc - - parseSep :: CabalParsing m => Proxy sep -> m a -> m [a] - -instance Sep CommaVCat where - prettySep _ = vcat . punctuate comma - parseSep _ p = do - v <- askCabalSpecVersion - if v >= CabalSpecV2_2 then parsecLeadingCommaList p else parsecCommaList p -instance Sep CommaFSep where - prettySep _ = fsep . punctuate comma - parseSep _ p = do - v <- askCabalSpecVersion - if v >= CabalSpecV2_2 then parsecLeadingCommaList p else parsecCommaList p -instance Sep VCat where - prettySep _ = vcat - parseSep _ p = do - v <- askCabalSpecVersion - if v >= CabalSpecV3_0 then parsecLeadingOptCommaList p else parsecOptCommaList p -instance Sep FSep where - prettySep _ = fsep - parseSep _ p = do - v <- askCabalSpecVersion - if v >= CabalSpecV3_0 then parsecLeadingOptCommaList p else parsecOptCommaList p -instance Sep NoCommaFSep where - prettySep _ = fsep - parseSep _ p = many (p <* P.spaces) - --- | List separated with optional commas. Displayed with @sep@, arguments of --- type @a@ are parsed and pretty-printed as @b@. -newtype List sep b a = List { _getList :: [a] } - --- | 'alaList' and 'alaList'' are simply 'List', with additional phantom --- arguments to constraint the resulting type --- --- >>> :t alaList VCat --- alaList VCat :: [a] -> List VCat (Identity a) a --- --- >>> :t alaList' FSep Token --- alaList' FSep Token :: [String] -> List FSep Token String --- -alaList :: sep -> [a] -> List sep (Identity a) a -alaList _ = List - --- | More general version of 'alaList'. -alaList' :: sep -> (a -> b) -> [a] -> List sep b a -alaList' _ _ = List - -instance Newtype [a] (List sep wrapper a) - -instance (Newtype a b, Sep sep, Parsec b) => Parsec (List sep b a) where - parsec = pack . map (unpack :: b -> a) <$> parseSep (Proxy :: Proxy sep) parsec - -instance (Newtype a b, Sep sep, Pretty b) => Pretty (List sep b a) where - pretty = prettySep (Proxy :: Proxy sep) . map (pretty . (pack :: a -> b)) . unpack - --- --- | Like 'List', but for 'Set'. --- --- @since 3.2.0.0 -newtype Set' sep b a = Set' { _getSet :: Set a } - --- | 'alaSet' and 'alaSet'' are simply 'Set'' constructor, with additional phantom --- arguments to constraint the resulting type --- --- >>> :t alaSet VCat --- alaSet VCat :: Set a -> Set' VCat (Identity a) a --- --- >>> :t alaSet' FSep Token --- alaSet' FSep Token :: Set String -> Set' FSep Token String --- --- >>> unpack' (alaSet' FSep Token) <$> eitherParsec "foo bar foo" --- Right (fromList ["bar","foo"]) --- --- @since 3.2.0.0 -alaSet :: sep -> Set a -> Set' sep (Identity a) a -alaSet _ = Set' - --- | More general version of 'alaSet'. --- --- @since 3.2.0.0 -alaSet' :: sep -> (a -> b) -> Set a -> Set' sep b a -alaSet' _ _ = Set' - -instance Newtype (Set a) (Set' sep wrapper a) - -instance (Newtype a b, Ord a, Sep sep, Parsec b) => Parsec (Set' sep b a) where - parsec = pack . Set.fromList . map (unpack :: b -> a) <$> parseSep (Proxy :: Proxy sep) parsec - -instance (Newtype a b, Sep sep, Pretty b) => Pretty (Set' sep b a) where - pretty = prettySep (Proxy :: Proxy sep) . map (pretty . (pack :: a -> b)) . Set.toList . unpack - -------------------------------------------------------------------------------- --- Identifiers -------------------------------------------------------------------------------- - --- | Haskell string or @[^ ,]+@ -newtype Token = Token { getToken :: String } - -instance Newtype String Token - -instance Parsec Token where - parsec = pack <$> parsecToken - -instance Pretty Token where - pretty = showToken . unpack - --- | Haskell string or @[^ ]+@ -newtype Token' = Token' { getToken' :: String } - -instance Newtype String Token' - -instance Parsec Token' where - parsec = pack <$> parsecToken' - -instance Pretty Token' where - pretty = showToken . unpack - --- | Either @"quoted"@ or @un-quoted@. -newtype MQuoted a = MQuoted { getMQuoted :: a } - -instance Newtype a (MQuoted a) - -instance Parsec a => Parsec (MQuoted a) where - parsec = pack <$> parsecMaybeQuoted parsec - -instance Pretty a => Pretty (MQuoted a) where - pretty = pretty . unpack - --- | Filepath are parsed as 'Token'. -newtype FilePathNT = FilePathNT { getFilePathNT :: String } - -instance Newtype String FilePathNT - -instance Parsec FilePathNT where - parsec = pack <$> parsecToken - -instance Pretty FilePathNT where - pretty = showFilePath . unpack - -------------------------------------------------------------------------------- --- SpecVersion -------------------------------------------------------------------------------- - --- | Version range or just version, i.e. @cabal-version@ field. --- --- There are few things to consider: --- --- * Starting with 2.2 the cabal-version field should be the first field in the --- file and only exact version is accepted. Therefore if we get e.g. --- @>= 2.2@, we fail. --- See --- --- We have this newtype, as writing Parsec and Pretty instances --- for CabalSpecVersion would cause cycle in modules: --- Version -> CabalSpecVersion -> Parsec -> ... --- -newtype SpecVersion = SpecVersion { getSpecVersion :: CabalSpecVersion } - deriving (Eq, Show) -- instances needed for tests - -instance Newtype CabalSpecVersion SpecVersion - -instance Parsec SpecVersion where - parsec = do - e <- parsecSpecVersion - let ver :: Version - ver = either id specVersionFromRange e - - digits :: [Int] - digits = versionNumbers ver - - case cabalSpecFromVersionDigits digits of - Nothing -> fail $ "Unknown cabal spec version specified: " ++ prettyShow ver - Just csv -> do - -- Check some warnings: - case e of - -- example: cabal-version: 1.10 - -- should be cabal-version: >=1.10 - Left _v | csv < CabalSpecV1_12 -> parsecWarning PWTSpecVersion $ concat - [ "With 1.10 or earlier, the 'cabal-version' field must use " - , "range syntax rather than a simple version number. Use " - , "'cabal-version: >= " ++ prettyShow ver ++ "'." - ] - - -- example: cabal-version: >=1.12 - -- should be cabal-version: 1.12 - Right _vr | csv >= CabalSpecV1_12 -> parsecWarning PWTSpecVersion $ concat - [ "Packages with 'cabal-version: 1.12' or later should specify a " - , "specific version of the Cabal spec of the form " - , "'cabal-version: x.y'. " - , "Use 'cabal-version: " ++ prettyShow ver ++ "'." - ] - - -- example: cabal-version: >=1.10 && <1.12 - -- should be cabal-version: >=1.10 - Right vr | csv < CabalSpecV1_12 - , not (simpleSpecVersionRangeSyntax vr) -> parsecWarning PWTSpecVersion $ concat - [ "It is recommended that the 'cabal-version' field only specify a " - , "version range of the form '>= x.y' for older cabal versions. Use " - , "'cabal-version: >= " ++ prettyShow ver ++ "'. " - , "Tools based on Cabal 1.10 and later will ignore upper bounds." - ] - - -- otherwise no warnings - _ -> pure () - - return (pack csv) - where - parsecSpecVersion = Left <$> parsec <|> Right <$> range - - range = do - vr <- parsec - if specVersionFromRange vr >= mkVersion [2,1] - then fail "cabal-version higher than 2.2 cannot be specified as a range. See https://github.com/haskell/cabal/issues/4899" - else return vr - - specVersionFromRange :: VersionRange -> Version - specVersionFromRange versionRange = case asVersionIntervals versionRange of - [] -> version0 - ((LowerBound version _, _):_) -> version - - simpleSpecVersionRangeSyntax = cataVersionRange alg where - alg (OrLaterVersionF _) = True - alg _ = False - - -instance Pretty SpecVersion where - pretty (SpecVersion csv) - | csv >= CabalSpecV1_12 = text (showCabalSpecVersion csv) - | otherwise = text ">=" <<>> text (showCabalSpecVersion csv) - -------------------------------------------------------------------------------- --- SpecLicense -------------------------------------------------------------------------------- - --- | SPDX License expression or legacy license -newtype SpecLicense = SpecLicense { getSpecLicense :: Either SPDX.License License } - -instance Newtype (Either SPDX.License License) SpecLicense - -instance Parsec SpecLicense where - parsec = do - v <- askCabalSpecVersion - if v >= CabalSpecV2_2 - then SpecLicense . Left <$> parsec - else SpecLicense . Right <$> parsec - -instance Pretty SpecLicense where - pretty = either pretty pretty . unpack - -------------------------------------------------------------------------------- --- TestedWith -------------------------------------------------------------------------------- - --- | Version range or just version -newtype TestedWith = TestedWith { getTestedWith :: (CompilerFlavor, VersionRange) } - -instance Newtype (CompilerFlavor, VersionRange) TestedWith - -instance Parsec TestedWith where - parsec = pack <$> parsecTestedWith - -instance Pretty TestedWith where - pretty x = case unpack x of - (compiler, vr) -> pretty compiler <+> pretty vr - -parsecTestedWith :: CabalParsing m => m (CompilerFlavor, VersionRange) -parsecTestedWith = do - name <- lexemeParsec - ver <- parsec <|> pure anyVersion - return (name, ver) diff --git a/cabal/Cabal/Distribution/FieldGrammar/Parsec.hs b/cabal/Cabal/Distribution/FieldGrammar/Parsec.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/FieldGrammar/Parsec.hs +++ /dev/null @@ -1,425 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} --- | This module provides a 'FieldGrammarParser', one way to parse --- @.cabal@ -like files. --- --- Fields can be specified multiple times in the .cabal files. The order of --- such entries is important, but the mutual ordering of different fields is --- not.Also conditional sections are considered after non-conditional data. --- The example of this silent-commutation quirk is the fact that --- --- @ --- buildable: True --- if os(linux) --- buildable: False --- @ --- --- and --- --- @ --- if os(linux) --- buildable: False --- buildable: True --- @ --- --- behave the same! This is the limitation of 'GeneralPackageDescription' --- structure. --- --- So we transform the list of fields @['Field' ann]@ into --- a map of grouped ordinary fields and a list of lists of sections: --- @'Fields' ann = 'Map' 'FieldName' ['NamelessField' ann]@ and @[['Section' ann]]@. --- --- We need list of list of sections, because we need to distinguish situations --- where there are fields in between. For example --- --- @ --- if flag(bytestring-lt-0_10_4) --- build-depends: bytestring < 0.10.4 --- --- default-language: Haskell2020 --- --- else --- build-depends: bytestring >= 0.10.4 --- --- @ --- --- is obviously invalid specification. --- --- We can parse 'Fields' like we parse @aeson@ objects, yet we use --- slightly higher-level API, so we can process unspecified fields, --- to report unknown fields and save custom @x-fields@. --- -module Distribution.FieldGrammar.Parsec ( - ParsecFieldGrammar, - parseFieldGrammar, - fieldGrammarKnownFieldList, - -- * Auxiliary - Fields, - NamelessField (..), - namelessFieldAnn, - Section (..), - runFieldParser, - runFieldParser', - fieldLinesToStream, - ) where - -import Data.List (dropWhileEnd) -import Distribution.Compat.Newtype -import Distribution.Compat.Prelude -import Distribution.Simple.Utils (fromUTF8BS) -import Prelude () - -import qualified Data.ByteString as BS -import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Strict as Map -import qualified Data.Set as Set -import qualified Distribution.Utils.ShortText as ShortText -import qualified Text.Parsec as P -import qualified Text.Parsec.Error as P - -import Distribution.CabalSpecVersion -import Distribution.FieldGrammar.Class -import Distribution.Fields.Field -import Distribution.Fields.ParseResult -import Distribution.Parsec -import Distribution.Parsec.FieldLineStream -import Distribution.Parsec.Position (positionCol, positionRow) - -------------------------------------------------------------------------------- --- Auxiliary types -------------------------------------------------------------------------------- - -type Fields ann = Map FieldName [NamelessField ann] - --- | Single field, without name, but with its annotation. -data NamelessField ann = MkNamelessField !ann [FieldLine ann] - deriving (Eq, Show, Functor) - -namelessFieldAnn :: NamelessField ann -> ann -namelessFieldAnn (MkNamelessField ann _) = ann - --- | The 'Section' constructor of 'Field'. -data Section ann = MkSection !(Name ann) [SectionArg ann] [Field ann] - deriving (Eq, Show, Functor) - -------------------------------------------------------------------------------- --- ParsecFieldGrammar -------------------------------------------------------------------------------- - -data ParsecFieldGrammar s a = ParsecFG - { fieldGrammarKnownFields :: !(Set FieldName) - , fieldGrammarKnownPrefixes :: !(Set FieldName) - , fieldGrammarParser :: !(CabalSpecVersion -> Fields Position -> ParseResult a) - } - deriving (Functor) - -parseFieldGrammar :: CabalSpecVersion -> Fields Position -> ParsecFieldGrammar s a -> ParseResult a -parseFieldGrammar v fields grammar = do - for_ (Map.toList (Map.filterWithKey isUnknownField fields)) $ \(name, nfields) -> - for_ nfields $ \(MkNamelessField pos _) -> - parseWarning pos PWTUnknownField $ "Unknown field: " ++ show name - -- TODO: fields allowed in this section - - -- parse - fieldGrammarParser grammar v fields - - where - isUnknownField k _ = not $ - k `Set.member` fieldGrammarKnownFields grammar - || any (`BS.isPrefixOf` k) (fieldGrammarKnownPrefixes grammar) - -fieldGrammarKnownFieldList :: ParsecFieldGrammar s a -> [FieldName] -fieldGrammarKnownFieldList = Set.toList . fieldGrammarKnownFields - -instance Applicative (ParsecFieldGrammar s) where - pure x = ParsecFG mempty mempty (\_ _ -> pure x) - {-# INLINE pure #-} - - ParsecFG f f' f'' <*> ParsecFG x x' x'' = ParsecFG - (mappend f x) - (mappend f' x') - (\v fields -> f'' v fields <*> x'' v fields) - {-# INLINE (<*>) #-} - -warnMultipleSingularFields :: FieldName -> [NamelessField Position] -> ParseResult () -warnMultipleSingularFields _ [] = pure () -warnMultipleSingularFields fn (x : xs) = do - let pos = namelessFieldAnn x - poss = map namelessFieldAnn xs - parseWarning pos PWTMultipleSingularField $ - "The field " <> show fn <> " is specified more than once at positions " ++ intercalate ", " (map showPos (pos : poss)) - -instance FieldGrammar Parsec ParsecFieldGrammar where - blurFieldGrammar _ (ParsecFG s s' parser) = ParsecFG s s' parser - - uniqueFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser - where - parser v fields = case Map.lookup fn fields of - Nothing -> parseFatalFailure zeroPos $ show fn ++ " field missing" - Just [] -> parseFatalFailure zeroPos $ show fn ++ " field missing" - Just [x] -> parseOne v x - Just xs@(_:y:ys) -> do - warnMultipleSingularFields fn xs - NE.last <$> traverse (parseOne v) (y:|ys) - - parseOne v (MkNamelessField pos fls) = - unpack' _pack <$> runFieldParser pos parsec v fls - - booleanFieldDef fn _extract def = ParsecFG (Set.singleton fn) Set.empty parser - where - parser v fields = case Map.lookup fn fields of - Nothing -> pure def - Just [] -> pure def - Just [x] -> parseOne v x - Just xs@(_:y:ys) -> do - warnMultipleSingularFields fn xs - NE.last <$> traverse (parseOne v) (y:|ys) - - parseOne v (MkNamelessField pos fls) = runFieldParser pos parsec v fls - - optionalFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser - where - parser v fields = case Map.lookup fn fields of - Nothing -> pure Nothing - Just [] -> pure Nothing - Just [x] -> parseOne v x - Just xs@(_:y:ys) -> do - warnMultipleSingularFields fn xs - NE.last <$> traverse (parseOne v) (y:|ys) - - parseOne v (MkNamelessField pos fls) - | null fls = pure Nothing - | otherwise = Just . unpack' _pack <$> runFieldParser pos parsec v fls - - optionalFieldDefAla fn _pack _extract def = ParsecFG (Set.singleton fn) Set.empty parser - where - parser v fields = case Map.lookup fn fields of - Nothing -> pure def - Just [] -> pure def - Just [x] -> parseOne v x - Just xs@(_:y:ys) -> do - warnMultipleSingularFields fn xs - NE.last <$> traverse (parseOne v) (y:|ys) - - parseOne v (MkNamelessField pos fls) - | null fls = pure def - | otherwise = unpack' _pack <$> runFieldParser pos parsec v fls - - freeTextField fn _ = ParsecFG (Set.singleton fn) Set.empty parser where - parser v fields = case Map.lookup fn fields of - Nothing -> pure Nothing - Just [] -> pure Nothing - Just [x] -> parseOne v x - Just xs@(_:y:ys) -> do - warnMultipleSingularFields fn xs - NE.last <$> traverse (parseOne v) (y:|ys) - - parseOne v (MkNamelessField pos fls) - | null fls = pure Nothing - | v >= CabalSpecV3_0 = pure (Just (fieldlinesToFreeText3 pos fls)) - | otherwise = pure (Just (fieldlinesToFreeText fls)) - - freeTextFieldDef fn _ = ParsecFG (Set.singleton fn) Set.empty parser where - parser v fields = case Map.lookup fn fields of - Nothing -> pure "" - Just [] -> pure "" - Just [x] -> parseOne v x - Just xs@(_:y:ys) -> do - warnMultipleSingularFields fn xs - NE.last <$> traverse (parseOne v) (y:|ys) - - parseOne v (MkNamelessField pos fls) - | null fls = pure "" - | v >= CabalSpecV3_0 = pure (fieldlinesToFreeText3 pos fls) - | otherwise = pure (fieldlinesToFreeText fls) - - -- freeTextFieldDefST = defaultFreeTextFieldDefST - freeTextFieldDefST fn _ = ParsecFG (Set.singleton fn) Set.empty parser where - parser v fields = case Map.lookup fn fields of - Nothing -> pure mempty - Just [] -> pure mempty - Just [x] -> parseOne v x - Just xs@(_:y:ys) -> do - warnMultipleSingularFields fn xs - NE.last <$> traverse (parseOne v) (y:|ys) - - parseOne v (MkNamelessField pos fls) = case fls of - [] -> pure mempty - [FieldLine _ bs] -> pure (ShortText.unsafeFromUTF8BS bs) - _ | v >= CabalSpecV3_0 -> pure (ShortText.toShortText $ fieldlinesToFreeText3 pos fls) - | otherwise -> pure (ShortText.toShortText $ fieldlinesToFreeText fls) - - monoidalFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser - where - parser v fields = case Map.lookup fn fields of - Nothing -> pure mempty - Just xs -> foldMap (unpack' _pack) <$> traverse (parseOne v) xs - - parseOne v (MkNamelessField pos fls) = runFieldParser pos parsec v fls - - prefixedFields fnPfx _extract = ParsecFG mempty (Set.singleton fnPfx) (\_ fs -> pure (parser fs)) - where - parser :: Fields Position -> [(String, String)] - parser values = reorder $ concatMap convert $ filter match $ Map.toList values - - match (fn, _) = fnPfx `BS.isPrefixOf` fn - convert (fn, fields) = - [ (pos, (fromUTF8BS fn, trim $ fromUTF8BS $ fieldlinesToBS fls)) - | MkNamelessField pos fls <- fields - ] - -- hack: recover the order of prefixed fields - reorder = map snd . sortBy (comparing fst) - trim :: String -> String - trim = dropWhile isSpace . dropWhileEnd isSpace - - availableSince vs def (ParsecFG names prefixes parser) = ParsecFG names prefixes parser' - where - parser' v values - | v >= vs = parser v values - | otherwise = do - let unknownFields = Map.intersection values $ Map.fromSet (const ()) names - for_ (Map.toList unknownFields) $ \(name, fields) -> - for_ fields $ \(MkNamelessField pos _) -> - parseWarning pos PWTUnknownField $ - "The field " <> show name <> " is available only since the Cabal specification version " ++ showCabalSpecVersion vs ++ ". This field will be ignored." - - pure def - - -- todo we know about this field - deprecatedSince vs msg (ParsecFG names prefixes parser) = ParsecFG names prefixes parser' - where - parser' v values - | v >= vs = do - let deprecatedFields = Map.intersection values $ Map.fromSet (const ()) names - for_ (Map.toList deprecatedFields) $ \(name, fields) -> - for_ fields $ \(MkNamelessField pos _) -> - parseWarning pos PWTDeprecatedField $ - "The field " <> show name <> " is deprecated in the Cabal specification version " ++ showCabalSpecVersion vs ++ ". " ++ msg - - parser v values - - | otherwise = parser v values - - removedIn vs msg (ParsecFG names prefixes parser) = ParsecFG names prefixes parser' where - parser' v values - | v >= vs = do - let msg' = if null msg then "" else ' ' : msg - let unknownFields = Map.intersection values $ Map.fromSet (const ()) names - let namePos = - [ (name, pos) - | (name, fields) <- Map.toList unknownFields - , MkNamelessField pos _ <- fields - ] - - let makeMsg name = "The field " <> show name <> " is removed in the Cabal specification version " ++ showCabalSpecVersion vs ++ "." ++ msg' - - case namePos of - -- no fields => proceed (with empty values, to be sure) - [] -> parser v mempty - - -- if there's single field: fail fatally with it - ((name, pos) : rest) -> do - for_ rest $ \(name', pos') -> parseFailure pos' $ makeMsg name' - parseFatalFailure pos $ makeMsg name - - | otherwise = parser v values - - knownField fn = ParsecFG (Set.singleton fn) Set.empty (\_ _ -> pure ()) - - hiddenField = id - -------------------------------------------------------------------------------- --- Parsec -------------------------------------------------------------------------------- - -runFieldParser' :: [Position] -> ParsecParser a -> CabalSpecVersion -> FieldLineStream -> ParseResult a -runFieldParser' inputPoss p v str = case P.runParser p' [] "" str of - Right (pok, ws) -> do - traverse_ (\(PWarning t pos w) -> parseWarning (mapPosition pos) t w) ws - pure pok - Left err -> do - let ppos = P.errorPos err - let epos = mapPosition $ Position (P.sourceLine ppos) (P.sourceColumn ppos) - - let msg = P.showErrorMessages - "or" "unknown parse error" "expecting" "unexpected" "end of input" - (P.errorMessages err) - parseFatalFailure epos $ msg ++ "\n" - where - p' = (,) <$ P.spaces <*> unPP p v <* P.spaces <* P.eof <*> P.getState - - -- Positions start from 1:1, not 0:0 - mapPosition (Position prow pcol) = go (prow - 1) inputPoss where - go _ [] = zeroPos - go _ [Position row col] = Position row (col + pcol - 1) - go n (Position row col:_) | n <= 0 = Position row (col + pcol - 1) - go n (_:ps) = go (n - 1) ps - -runFieldParser :: Position -> ParsecParser a -> CabalSpecVersion -> [FieldLine Position] -> ParseResult a -runFieldParser pp p v ls = runFieldParser' poss p v (fieldLinesToStream ls) - where - poss = map (\(FieldLine pos _) -> pos) ls ++ [pp] -- add "default" position - -fieldlinesToBS :: [FieldLine ann] -> BS.ByteString -fieldlinesToBS = BS.intercalate "\n" . map (\(FieldLine _ bs) -> bs) - --- Example package with dot lines --- http://hackage.haskell.org/package/copilot-cbmc-0.1/copilot-cbmc.cabal -fieldlinesToFreeText :: [FieldLine ann] -> String -fieldlinesToFreeText [FieldLine _ "."] = "." -fieldlinesToFreeText fls = intercalate "\n" (map go fls) - where - go (FieldLine _ bs) - | s == "." = "" - | otherwise = s - where - s = trim (fromUTF8BS bs) - - trim :: String -> String - trim = dropWhile isSpace . dropWhileEnd isSpace - -fieldlinesToFreeText3 :: Position -> [FieldLine Position] -> String -fieldlinesToFreeText3 _ [] = "" -fieldlinesToFreeText3 _ [FieldLine _ bs] = fromUTF8BS bs -fieldlinesToFreeText3 pos (FieldLine pos1 bs1 : fls2@(FieldLine pos2 _ : _)) - -- if first line is on the same line with field name: - -- the indentation level is either - -- 1. the indentation of left most line in rest fields - -- 2. the indentation of the first line - -- whichever is leftmost - | positionRow pos == positionRow pos1 = concat - $ fromUTF8BS bs1 - : mealy (mk mcol1) pos1 fls2 - - -- otherwise, also indent the first line - | otherwise = concat - $ replicate (positionCol pos1 - mcol2) ' ' - : fromUTF8BS bs1 - : mealy (mk mcol2) pos1 fls2 - - where - mcol1 = foldl' (\a b -> min a $ positionCol $ fieldLineAnn b) (min (positionCol pos1) (positionCol pos2)) fls2 - mcol2 = foldl' (\a b -> min a $ positionCol $ fieldLineAnn b) (positionCol pos1) fls2 - - mk :: Int -> Position -> FieldLine Position -> (Position, String) - mk col p (FieldLine q bs) = - ( q - , replicate newlines '\n' - ++ replicate indent ' ' - ++ fromUTF8BS bs - ) - where - newlines = positionRow q - positionRow p - indent = positionCol q - col - -mealy :: (s -> a -> (s, b)) -> s -> [a] -> [b] -mealy f = go where - go _ [] = [] - go s (x : xs) = let ~(s', y) = f s x in y : go s' xs - -fieldLinesToStream :: [FieldLine ann] -> FieldLineStream -fieldLinesToStream [] = fieldLineStreamEnd -fieldLinesToStream [FieldLine _ bs] = FLSLast bs -fieldLinesToStream (FieldLine _ bs : fs) = FLSCons bs (fieldLinesToStream fs) diff --git a/cabal/Cabal/Distribution/FieldGrammar/Pretty.hs b/cabal/Cabal/Distribution/FieldGrammar/Pretty.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/FieldGrammar/Pretty.hs +++ /dev/null @@ -1,104 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE MultiParamTypeClasses #-} -module Distribution.FieldGrammar.Pretty ( - PrettyFieldGrammar, - prettyFieldGrammar, - ) where - -import Distribution.CabalSpecVersion -import Distribution.Compat.Lens -import Distribution.Compat.Newtype -import Distribution.Compat.Prelude -import Distribution.Fields.Field (FieldName) -import Distribution.Fields.Pretty (PrettyField (..)) -import Distribution.Pretty (Pretty (..), showFreeText, showFreeTextV3) -import Distribution.Simple.Utils (toUTF8BS) -import Prelude () -import Text.PrettyPrint (Doc) -import qualified Text.PrettyPrint as PP - -import Distribution.FieldGrammar.Class - -newtype PrettyFieldGrammar s a = PrettyFG - { fieldGrammarPretty :: CabalSpecVersion -> s -> [PrettyField ()] - } - deriving (Functor) - -instance Applicative (PrettyFieldGrammar s) where - pure _ = PrettyFG (\_ _ -> mempty) - PrettyFG f <*> PrettyFG x = PrettyFG (\v s -> f v s <> x v s) - --- | We can use 'PrettyFieldGrammar' to pp print the @s@. --- --- /Note:/ there is not trailing @($+$ text "")@. -prettyFieldGrammar :: CabalSpecVersion -> PrettyFieldGrammar s a -> s -> [PrettyField ()] -prettyFieldGrammar = flip fieldGrammarPretty - -instance FieldGrammar Pretty PrettyFieldGrammar where - blurFieldGrammar f (PrettyFG pp) = PrettyFG (\v -> pp v . aview f) - - uniqueFieldAla fn _pack l = PrettyFG $ \_v s -> - ppField fn (pretty (pack' _pack (aview l s))) - - booleanFieldDef fn l def = PrettyFG pp - where - pp _v s - | b == def = mempty - | otherwise = ppField fn (PP.text (show b)) - where - b = aview l s - - optionalFieldAla fn _pack l = PrettyFG pp - where - pp v s = case aview l s of - Nothing -> mempty - Just a -> ppField fn (prettyVersioned v (pack' _pack a)) - - optionalFieldDefAla fn _pack l def = PrettyFG pp - where - pp v s - | x == def = mempty - | otherwise = ppField fn (prettyVersioned v (pack' _pack x)) - where - x = aview l s - - freeTextField fn l = PrettyFG pp where - pp v s = maybe mempty (ppField fn . showFT) (aview l s) where - showFT | v >= CabalSpecV3_0 = showFreeTextV3 - | otherwise = showFreeText - - -- it's ok to just show, as showFreeText of empty string is empty. - freeTextFieldDef fn l = PrettyFG pp where - pp v s = ppField fn (showFT (aview l s)) where - showFT | v >= CabalSpecV3_0 = showFreeTextV3 - | otherwise = showFreeText - - freeTextFieldDefST = defaultFreeTextFieldDefST - - monoidalFieldAla fn _pack l = PrettyFG pp - where - pp v s = ppField fn (prettyVersioned v (pack' _pack (aview l s))) - - prefixedFields _fnPfx l = PrettyFG (\_ -> pp . aview l) - where - pp xs = - -- always print the field, even its Doc is empty. - -- i.e. don't use ppField - [ PrettyField () (toUTF8BS n) $ PP.vcat $ map PP.text $ lines s - | (n, s) <- xs - -- fnPfx `isPrefixOf` n - ] - - knownField _ = pure () - deprecatedSince _ _ x = x - -- TODO: as PrettyFieldGrammar isn't aware of cabal-version: we output the field - -- this doesn't affect roundtrip as `removedIn` fields cannot be parsed - -- so invalid documents can be only manually constructed. - removedIn _ _ x = x - availableSince _ _ = id - hiddenField _ = PrettyFG (\_ -> mempty) - -ppField :: FieldName -> Doc -> [PrettyField ()] -ppField name fielddoc - | PP.isEmpty fielddoc = [] - | otherwise = [ PrettyField () name fielddoc ] diff --git a/cabal/Cabal/Distribution/Fields.hs b/cabal/Cabal/Distribution/Fields.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Fields.hs +++ /dev/null @@ -1,42 +0,0 @@ --- | Utilitiies to work with @.cabal@ like file structure. -module Distribution.Fields ( - -- * Types - Field(..), - Name(..), - FieldLine(..), - SectionArg(..), - FieldName, - -- * Grammar and parsing - -- - -- See "Distribution.Fields.Parser" for grammar. - readFields, - readFields', - -- ** ParseResult - ParseResult, - runParseResult, - parseString, - parseWarning, - parseWarnings, - parseFailure, - parseFatalFailure, - -- ** Warnings - PWarnType (..), - PWarning (..), - showPWarning, - -- ** Errors - PError (..), - showPError, - -- * Pretty printing - PrettyField (..), - showFields, - -- ** Transformation from Field - genericFromParsecFields, - fromParsecFields, - ) where - -import Distribution.Fields.Field -import Distribution.Fields.Parser -import Distribution.Fields.ParseResult -import Distribution.Fields.Pretty -import Distribution.Parsec.Error -import Distribution.Parsec.Warning diff --git a/cabal/Cabal/Distribution/Fields/ConfVar.hs b/cabal/Cabal/Distribution/Fields/ConfVar.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Fields/ConfVar.hs +++ /dev/null @@ -1,127 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoMonoLocalBinds #-} -module Distribution.Fields.ConfVar (parseConditionConfVar) where - -import Distribution.Compat.CharParsing (char, integral) -import Distribution.Compat.Prelude -import Distribution.Fields.Field (SectionArg (..)) -import Distribution.Fields.ParseResult -import Distribution.Parsec (Parsec (..), Position (..), runParsecParser) -import Distribution.Parsec.FieldLineStream (fieldLineStreamFromBS) -import Distribution.Types.Condition -import Distribution.Types.ConfVar (ConfVar (..)) -import Distribution.Version - (anyVersion, earlierVersion, intersectVersionRanges, laterVersion, majorBoundVersion, - mkVersion, noVersion, orEarlierVersion, orLaterVersion, thisVersion, unionVersionRanges, - withinVersion) -import Prelude () - -import qualified Text.Parsec as P -import qualified Text.Parsec.Error as P - --- | Parse @'Condition' 'ConfVar'@ from section arguments provided by parsec --- based outline parser. -parseConditionConfVar :: [SectionArg Position] -> ParseResult (Condition ConfVar) -parseConditionConfVar args = - -- The name of the input file is irrelevant, as we reformat the error message. - case P.runParser (parser <* P.eof) () "" args of - Right x -> pure x - Left err -> do - -- Mangle the position to the actual one - let ppos = P.errorPos err - let epos = Position (P.sourceLine ppos) (P.sourceColumn ppos) - let msg = P.showErrorMessages - "or" "unknown parse error" "expecting" "unexpected" "end of input" - (P.errorMessages err) - parseFailure epos msg - pure $ Lit True - -type Parser = P.Parsec [SectionArg Position] () - -sepByNonEmpty :: Parser a -> Parser sep -> Parser (NonEmpty a) -sepByNonEmpty p sep = (:|) <$> p <*> many (sep *> p) - -parser :: Parser (Condition ConfVar) -parser = condOr - where - condOr = sepByNonEmpty condAnd (oper "||") >>= return . foldl1 COr - condAnd = sepByNonEmpty cond (oper "&&") >>= return . foldl1 CAnd - cond = P.choice - [ boolLiteral, parens condOr, notCond, osCond, archCond, flagCond, implCond ] - - notCond = CNot <$ oper "!" <*> cond - - boolLiteral = Lit <$> boolLiteral' - osCond = Var . OS <$ string "os" <*> parens fromParsec - flagCond = Var . PackageFlag <$ string "flag" <*> parens fromParsec - archCond = Var . Arch <$ string "arch" <*> parens fromParsec - implCond = Var <$ string "impl" <*> parens implCond' - - implCond' = Impl - <$> fromParsec - <*> P.option anyVersion versionRange - - version = fromParsec - versionStar = mkVersion <$> fromParsec' versionStar' <* oper "*" - versionStar' = some (integral <* char '.') - - versionRange = expr - where - expr = foldl1 unionVersionRanges <$> sepByNonEmpty term (oper "||") - term = foldl1 intersectVersionRanges <$> sepByNonEmpty factor (oper "&&") - - factor = P.choice - $ parens expr - : parseAnyVersion - : parseNoVersion - : parseWildcardRange - : map parseRangeOp rangeOps - - parseAnyVersion = anyVersion <$ string "-any" - parseNoVersion = noVersion <$ string "-none" - - parseWildcardRange = P.try $ withinVersion <$ oper "==" <*> versionStar - - parseRangeOp (s,f) = P.try (f <$ oper s <*> version) - rangeOps = [ ("<", earlierVersion), - ("<=", orEarlierVersion), - (">", laterVersion), - (">=", orLaterVersion), - ("^>=", majorBoundVersion), - ("==", thisVersion) ] - - -- Number token can have many dots in it: SecArgNum (Position 65 15) "7.6.1" - identBS = tokenPrim $ \t -> case t of - SecArgName _ s -> Just s - _ -> Nothing - - boolLiteral' = tokenPrim $ \t -> case t of - SecArgName _ s - | s == "True" -> Just True - | s == "true" -> Just True - | s == "False" -> Just False - | s == "false" -> Just False - _ -> Nothing - - string s = tokenPrim $ \t -> case t of - SecArgName _ s' | s == s' -> Just () - _ -> Nothing - - oper o = tokenPrim $ \t -> case t of - SecArgOther _ o' | o == o' -> Just () - _ -> Nothing - - parens = P.between (oper "(") (oper ")") - - tokenPrim = P.tokenPrim prettySectionArg updatePosition - -- TODO: check where the errors are reported - updatePosition x _ _ = x - prettySectionArg = show - - fromParsec :: Parsec a => Parser a - fromParsec = fromParsec' parsec - - fromParsec' p = do - bs <- identBS - let fls = fieldLineStreamFromBS bs - either (fail . show) pure (runParsecParser p "" fls) diff --git a/cabal/Cabal/Distribution/Fields/Field.hs b/cabal/Cabal/Distribution/Fields/Field.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Fields/Field.hs +++ /dev/null @@ -1,108 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveTraversable #-} --- | Cabal-like file AST types: 'Field', 'Section' etc --- --- These types are parametrized by an annotation. -module Distribution.Fields.Field ( - -- * Cabal file - Field (..), - fieldName, - fieldAnn, - fieldUniverse, - FieldLine (..), - fieldLineAnn, - fieldLineBS, - SectionArg (..), - sectionArgAnn, - -- * Name - FieldName, - Name (..), - mkName, - getName, - nameAnn, - ) where - -import Prelude () -import Distribution.Compat.Prelude -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as B -import qualified Data.Char as Char - -------------------------------------------------------------------------------- --- Cabal file -------------------------------------------------------------------------------- - --- | A Cabal-like file consists of a series of fields (@foo: bar@) and sections (@library ...@). -data Field ann - = Field !(Name ann) [FieldLine ann] - | Section !(Name ann) [SectionArg ann] [Field ann] - deriving (Eq, Show, Functor, Foldable, Traversable) - --- | Section of field name -fieldName :: Field ann -> Name ann -fieldName (Field n _ ) = n -fieldName (Section n _ _) = n - -fieldAnn :: Field ann -> ann -fieldAnn = nameAnn . fieldName - --- | All transitive descendants of 'Field', including itself. --- --- /Note:/ the resulting list is never empty. --- -fieldUniverse :: Field ann -> [Field ann] -fieldUniverse f@(Section _ _ fs) = f : concatMap fieldUniverse fs -fieldUniverse f@(Field _ _) = [f] - --- | A line of text representing the value of a field from a Cabal file. --- A field may contain multiple lines. --- --- /Invariant:/ 'ByteString' has no newlines. -data FieldLine ann = FieldLine !ann !ByteString - deriving (Eq, Show, Functor, Foldable, Traversable) - --- | @since 3.0.0.0 -fieldLineAnn :: FieldLine ann -> ann -fieldLineAnn (FieldLine ann _) = ann - --- | @since 3.0.0.0 -fieldLineBS :: FieldLine ann -> ByteString -fieldLineBS (FieldLine _ bs) = bs - --- | Section arguments, e.g. name of the library -data SectionArg ann - = SecArgName !ann !ByteString - -- ^ identifier, or something which looks like number. Also many dot numbers, i.e. "7.6.3" - | SecArgStr !ann !ByteString - -- ^ quoted string - | SecArgOther !ann !ByteString - -- ^ everything else, mm. operators (e.g. in if-section conditionals) - deriving (Eq, Show, Functor, Foldable, Traversable) - --- | Extract annotation from 'SectionArg'. -sectionArgAnn :: SectionArg ann -> ann -sectionArgAnn (SecArgName ann _) = ann -sectionArgAnn (SecArgStr ann _) = ann -sectionArgAnn (SecArgOther ann _) = ann - -------------------------------------------------------------------------------- --- Name -------------------------------------------------------------------------------- - -type FieldName = ByteString - --- | A field name. --- --- /Invariant/: 'ByteString' is lower-case ASCII. -data Name ann = Name !ann !FieldName - deriving (Eq, Show, Functor, Foldable, Traversable) - -mkName :: ann -> FieldName -> Name ann -mkName ann bs = Name ann (B.map Char.toLower bs) - -getName :: Name ann -> FieldName -getName (Name _ bs) = bs - -nameAnn :: Name ann -> ann -nameAnn (Name ann _) = ann diff --git a/cabal/Cabal/Distribution/Fields/Lexer.hs b/cabal/Cabal/Distribution/Fields/Lexer.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Fields/Lexer.hs +++ /dev/null @@ -1,488 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} -{-# LANGUAGE CPP,MagicHash #-} -{-# LINE 1 "boot/Lexer.x" #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Fields.Lexer --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Lexer for the cabal files. -{-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} -#ifdef CABAL_PARSEC_DEBUG -{-# LANGUAGE PatternGuards #-} -#endif -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -module Distribution.Fields.Lexer - (ltest, lexToken, Token(..), LToken(..) - ,bol_section, in_section, in_field_layout, in_field_braces - ,mkLexState) where - --- [Note: boostrapping parsec parser] --- --- We manually produce the `Lexer.hs` file from `boot/Lexer.x` (make lexer) --- because boostrapping cabal-install would be otherwise tricky. --- Alex is (atm) tricky package to build, cabal-install has some magic --- to move bundled generated files in place, so rather we don't depend --- on it before we can build it ourselves. --- Therefore there is one thing less to worry in bootstrap.sh, which is a win. --- --- See also https://github.com/haskell/cabal/issues/4633 --- - -import Prelude () -import qualified Prelude as Prelude -import Distribution.Compat.Prelude - -import Distribution.Fields.LexerMonad -import Distribution.Parsec.Position (Position (..), incPos, retPos) -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as B.Char8 -import qualified Data.Word as Word - -#ifdef CABAL_PARSEC_DEBUG -import Debug.Trace -import qualified Data.Vector as V -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.Encoding.Error as T -#endif - -#if __GLASGOW_HASKELL__ >= 603 -#include "ghcconfig.h" -#elif defined(__GLASGOW_HASKELL__) -#include "config.h" -#endif -#if __GLASGOW_HASKELL__ >= 503 -import Data.Array -#else -import Array -#endif -#if __GLASGOW_HASKELL__ >= 503 -import Data.Array.Base (unsafeAt) -import GHC.Exts -#else -import GlaExts -#endif -alex_tab_size :: Int -alex_tab_size = 8 -alex_base :: AlexAddr -alex_base = AlexA# - "\x12\xff\xff\xff\xf9\xff\xff\xff\xfb\xff\xff\xff\x01\x00\x00\x00\x2f\x00\x00\x00\x50\x00\x00\x00\xd0\x00\x00\x00\x48\xff\xff\xff\xdc\xff\xff\xff\x51\xff\xff\xff\x6d\xff\xff\xff\x6f\xff\xff\xff\x50\x01\x00\x00\x74\x01\x00\x00\x70\xff\xff\xff\x68\x00\x00\x00\x09\x00\x00\x00\x00\x00\x00\x00\x07\x00\x00\x00\xa3\x01\x00\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x00\x00\xd1\x01\x00\x00\xfb\x01\x00\x00\x7b\x02\x00\x00\xfb\x02\x00\x00\x00\x00\x00\x00\x7b\x03\x00\x00\x7d\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x6d\x00\x00\x00\x6b\x00\x00\x00\xfc\x03\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x6f\x00\x00\x00\x1c\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00"# - -alex_table :: AlexAddr -alex_table = AlexA# - "\x00\x00\x09\x00\x0f\x00\x11\x00\x02\x00\x11\x00\x12\x00\x00\x00\x12\x00\x13\x00\x03\x00\x11\x00\x07\x00\x10\x00\x12\x00\x25\x00\x14\x00\x11\x00\x10\x00\x11\x00\x14\x00\x11\x00\x12\x00\x23\x00\x12\x00\x0f\x00\x28\x00\x02\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x08\x00\x10\x00\x00\x00\x14\x00\x00\x00\x00\x00\x08\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2a\x00\x2e\x00\xff\xff\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x28\x00\xff\xff\xff\xff\x29\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x0f\x00\x11\x00\x17\x00\x26\x00\x12\x00\x25\x00\x11\x00\x2a\x00\x00\x00\x12\x00\x00\x00\x15\x00\x00\x00\x16\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0f\x00\x00\x00\x17\x00\x26\x00\x00\x00\x25\x00\x00\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x00\x00\x2d\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x0e\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x17\x00\x23\x00\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x17\x00\x1e\x00\x0d\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x1f\x00\x1f\x00\x1e\x00\x1e\x00\x1e\x00\x19\x00\x1a\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x1f\x00\x1e\x00\x1f\x00\x1e\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x21\x00\x1e\x00\x22\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x1d\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x1c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x0c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1e\x00\xff\xff\x1e\x00\x1e\x00\x1e\x00\x1e\x00\xff\xff\xff\xff\xff\xff\x1e\x00\x1e\x00\x1e\x00\x18\x00\x1a\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x1e\x00\xff\xff\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x1e\x00\xff\xff\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1e\x00\xff\xff\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\xff\xff\xff\xff\x1e\x00\x1e\x00\x1e\x00\x1a\x00\x1a\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x1e\x00\xff\xff\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x1e\x00\xff\xff\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x1c\x00\x1e\x00\x00\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x1e\x00\x00\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1e\x00\xff\xff\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -alex_check :: AlexAddr -alex_check = AlexA# - "\xff\xff\xef\x00\x09\x00\x0a\x00\x09\x00\x0a\x00\x0d\x00\xbf\x00\x0d\x00\x2d\x00\x09\x00\x0a\x00\xbb\x00\xa0\x00\x0d\x00\xa0\x00\xa0\x00\x0a\x00\x09\x00\x0a\x00\x09\x00\x0a\x00\x0d\x00\x0a\x00\x0d\x00\x20\x00\x0a\x00\x20\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x00\xff\xff\x2d\x00\x20\x00\xff\xff\x20\x00\xff\xff\xff\xff\x2d\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x09\x00\x0a\x00\x09\x00\x09\x00\x0d\x00\x09\x00\x0a\x00\x09\x00\xff\xff\x0d\x00\xff\xff\x7b\x00\xff\xff\x7d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\x20\x00\x20\x00\xff\xff\x20\x00\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\xff\xff\x7d\x00\xff\xff\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc2\x00\xff\xff\xc2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc2\x00\xff\xff\xc2\x00\xff\xff\x7f\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc2\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xc2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\xff\xff\xff\xff\x22\x00\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\xff\xff\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x5c\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7f\x00\x5c\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\xff\xff\xff\xff\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x7f\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\xff\xff\xff\xff\x22\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x7f\x00\x7e\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\xff\xff\x7d\x00\xff\xff\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# - -alex_deflt :: AlexAddr -alex_deflt = AlexA# - "\xff\xff\xff\xff\xff\xff\xff\xff\x2b\x00\x27\x00\x1b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0d\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x00\xff\xff\xff\xff\xff\xff\xff\xff\x18\x00\x1b\x00\x1b\x00\x1b\x00\xff\xff\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\x2b\x00\xff\xff\xff\xff\xff\xff\xff\xff"# - -alex_accept = listArray (0 :: Int, 47) - [ AlexAcc 29 - , AlexAcc 28 - , AlexAcc 27 - , AlexAcc 26 - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAcc 25 - , AlexAcc 24 - , AlexAccSkip - , AlexAcc 23 - , AlexAcc 22 - , AlexAcc 21 - , AlexAccSkip - , AlexAccSkip - , AlexAcc 20 - , AlexAcc 19 - , AlexAcc 18 - , AlexAcc 17 - , AlexAcc 16 - , AlexAcc 15 - , AlexAcc 14 - , AlexAcc 13 - , AlexAcc 12 - , AlexAcc 11 - , AlexAcc 10 - , AlexAcc 9 - , AlexAcc 8 - , AlexAccSkip - , AlexAcc 7 - , AlexAcc 6 - , AlexAcc 5 - , AlexAccSkip - , AlexAcc 4 - , AlexAcc 3 - , AlexAcc 2 - , AlexAcc 1 - , AlexAcc 0 - ] - -alex_actions = array (0 :: Int, 30) - [ (29,alex_action_0) - , (28,alex_action_20) - , (27,alex_action_16) - , (26,alex_action_3) - , (25,alex_action_1) - , (24,alex_action_1) - , (23,alex_action_3) - , (22,alex_action_4) - , (21,alex_action_5) - , (20,alex_action_8) - , (19,alex_action_8) - , (18,alex_action_8) - , (17,alex_action_9) - , (16,alex_action_9) - , (15,alex_action_10) - , (14,alex_action_11) - , (13,alex_action_12) - , (12,alex_action_13) - , (11,alex_action_14) - , (10,alex_action_15) - , (9,alex_action_15) - , (8,alex_action_16) - , (7,alex_action_18) - , (6,alex_action_19) - , (5,alex_action_19) - , (4,alex_action_22) - , (3,alex_action_23) - , (2,alex_action_24) - , (1,alex_action_25) - , (0,alex_action_25) - ] - -{-# LINE 151 "boot/Lexer.x" #-} - --- | Tokens of outer cabal file structure. Field values are treated opaquely. -data Token = TokSym !ByteString -- ^ Haskell-like identifier, number or operator - | TokStr !ByteString -- ^ String in quotes - | TokOther !ByteString -- ^ Operators and parens - | Indent !Int -- ^ Indentation token - | TokFieldLine !ByteString -- ^ Lines after @:@ - | Colon - | OpenBrace - | CloseBrace - | EOF - | LexicalError InputStream --TODO: add separate string lexical error - deriving Show - -data LToken = L !Position !Token - deriving Show - -toki :: (ByteString -> Token) -> Position -> Int -> ByteString -> Lex LToken -toki t pos len input = return $! L pos (t (B.take len input)) - -tok :: Token -> Position -> Int -> ByteString -> Lex LToken -tok t pos _len _input = return $! L pos t - -checkLeadingWhitespace :: Int -> ByteString -> Lex Int -checkLeadingWhitespace len bs - | B.any (== 9) (B.take len bs) = do - addWarning LexWarningTab - checkWhitespace len bs - | otherwise = checkWhitespace len bs - -checkWhitespace :: Int -> ByteString -> Lex Int -checkWhitespace len bs - | B.any (== 194) (B.take len bs) = do - addWarning LexWarningNBSP - return $ len - B.count 194 (B.take len bs) - | otherwise = return len - --- ----------------------------------------------------------------------------- --- The input type - -type AlexInput = InputStream - -alexInputPrevChar :: AlexInput -> Char -alexInputPrevChar _ = error "alexInputPrevChar not used" - -alexGetByte :: AlexInput -> Maybe (Word.Word8,AlexInput) -alexGetByte = B.uncons - -lexicalError :: Position -> InputStream -> Lex LToken -lexicalError pos inp = do - setInput B.empty - return $! L pos (LexicalError inp) - -lexToken :: Lex LToken -lexToken = do - pos <- getPos - inp <- getInput - st <- getStartCode - case alexScan inp st of - AlexEOF -> return (L pos EOF) - AlexError inp' -> - let !len_bytes = B.length inp - B.length inp' in - --FIXME: we want len_chars here really - -- need to decode utf8 up to this point - lexicalError (incPos len_bytes pos) inp' - AlexSkip inp' len_chars -> do - checkPosition pos inp inp' len_chars - adjustPos (incPos len_chars) - setInput inp' - lexToken - AlexToken inp' len_chars action -> do - checkPosition pos inp inp' len_chars - adjustPos (incPos len_chars) - setInput inp' - let !len_bytes = B.length inp - B.length inp' - t <- action pos len_bytes inp - --traceShow t $ return tok - return t - -checkPosition :: Position -> ByteString -> ByteString -> Int -> Lex () -#ifdef CABAL_PARSEC_DEBUG -checkPosition pos@(Position lineno colno) inp inp' len_chars = do - text_lines <- getDbgText - let len_bytes = B.length inp - B.length inp' - pos_txt | lineno-1 < V.length text_lines = T.take len_chars (T.drop (colno-1) (text_lines V.! (lineno-1))) - | otherwise = T.empty - real_txt = B.take len_bytes inp - when (pos_txt /= T.decodeUtf8 real_txt) $ - traceShow (pos, pos_txt, T.decodeUtf8 real_txt) $ - traceShow (take 3 (V.toList text_lines)) $ return () - where - getDbgText = Lex $ \s@LexState{ dbgText = txt } -> LexResult s txt -#else -checkPosition _ _ _ _ = return () -#endif - -lexAll :: Lex [LToken] -lexAll = do - t <- lexToken - case t of - L _ EOF -> return [t] - _ -> do ts <- lexAll - return (t : ts) - -ltest :: Int -> String -> Prelude.IO () -ltest code s = - let (ws, xs) = execLexer (setStartCode code >> lexAll) (B.Char8.pack s) - in traverse_ print ws >> traverse_ print xs - -mkLexState :: ByteString -> LexState -mkLexState input = LexState - { curPos = Position 1 1 - , curInput = input - , curCode = 0 - , warnings = [] -#ifdef CABAL_PARSEC_DEBUG - , dbgText = V.fromList . lines' . T.decodeUtf8With T.lenientDecode $ input -#endif - } - -#ifdef CABAL_PARSEC_DEBUG -lines' :: T.Text -> [T.Text] -lines' s1 - | T.null s1 = [] - | otherwise = case T.break (\c -> c == '\r' || c == '\n') s1 of - (l, s2) | Just (c,s3) <- T.uncons s2 - -> case T.uncons s3 of - Just ('\n', s4) | c == '\r' -> l `T.snoc` '\r' `T.snoc` '\n' : lines' s4 - _ -> l `T.snoc` c : lines' s3 - - | otherwise - -> [l] -#endif - -bol_field_braces,bol_field_layout,bol_section,in_field_braces,in_field_layout,in_section :: Int -bol_field_braces = 1 -bol_field_layout = 2 -bol_section = 3 -in_field_braces = 4 -in_field_layout = 5 -in_section = 6 -alex_action_0 = \_ len _ -> do - when (len /= 0) $ addWarning LexWarningBOM - setStartCode bol_section - lexToken - -alex_action_1 = \_pos len inp -> checkWhitespace len inp >> adjustPos retPos >> lexToken -alex_action_3 = \pos len inp -> checkLeadingWhitespace len inp >> - if B.length inp == len - then return (L pos EOF) - else setStartCode in_section - >> return (L pos (Indent len)) -alex_action_4 = tok OpenBrace -alex_action_5 = tok CloseBrace -alex_action_8 = toki TokSym -alex_action_9 = \pos len inp -> return $! L pos (TokStr (B.take (len - 2) (B.tail inp))) -alex_action_10 = toki TokOther -alex_action_11 = toki TokOther -alex_action_12 = tok Colon -alex_action_13 = tok OpenBrace -alex_action_14 = tok CloseBrace -alex_action_15 = \_ _ _ -> adjustPos retPos >> setStartCode bol_section >> lexToken -alex_action_16 = \pos len inp -> checkLeadingWhitespace len inp >>= \len' -> - if B.length inp == len - then return (L pos EOF) - else setStartCode in_field_layout - >> return (L pos (Indent len')) -alex_action_18 = toki TokFieldLine -alex_action_19 = \_ _ _ -> adjustPos retPos >> setStartCode bol_field_layout >> lexToken -alex_action_20 = \_ _ _ -> setStartCode in_field_braces >> lexToken -alex_action_22 = toki TokFieldLine -alex_action_23 = tok OpenBrace -alex_action_24 = tok CloseBrace -alex_action_25 = \_ _ _ -> adjustPos retPos >> setStartCode bol_field_braces >> lexToken -{-# LINE 1 "templates/GenericTemplate.hs" #-} --- ----------------------------------------------------------------------------- --- ALEX TEMPLATE --- --- This code is in the PUBLIC DOMAIN; you may copy it freely and use --- it for any purpose whatsoever. - --- ----------------------------------------------------------------------------- --- INTERNALS and main scanner engine - --- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. -#if __GLASGOW_HASKELL__ > 706 -#define GTE(n,m) (tagToEnum# (n >=# m)) -#define EQ(n,m) (tagToEnum# (n ==# m)) -#else -#define GTE(n,m) (n >=# m) -#define EQ(n,m) (n ==# m) -#endif - -data AlexAddr = AlexA# Addr# --- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. -#if __GLASGOW_HASKELL__ < 503 -uncheckedShiftL# = shiftL# -#endif - -{-# INLINE alexIndexInt16OffAddr #-} -alexIndexInt16OffAddr (AlexA# arr) off = -#ifdef WORDS_BIGENDIAN - narrow16Int# i - where - i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) - high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) - low = int2Word# (ord# (indexCharOffAddr# arr off')) - off' = off *# 2# -#else - indexInt16OffAddr# arr off -#endif - -{-# INLINE alexIndexInt32OffAddr #-} -alexIndexInt32OffAddr (AlexA# arr) off = -#ifdef WORDS_BIGENDIAN - narrow32Int# i - where - i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#` - (b2 `uncheckedShiftL#` 16#) `or#` - (b1 `uncheckedShiftL#` 8#) `or#` b0) - b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#))) - b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#))) - b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) - b0 = int2Word# (ord# (indexCharOffAddr# arr off')) - off' = off *# 4# -#else - indexInt32OffAddr# arr off -#endif - -#if __GLASGOW_HASKELL__ < 503 -quickIndex arr i = arr ! i -#else --- GHC >= 503, unsafeAt is available from Data.Array.Base. -quickIndex = unsafeAt -#endif - --- ----------------------------------------------------------------------------- --- Main lexing routines - -data AlexReturn a - = AlexEOF - | AlexError !AlexInput - | AlexSkip !AlexInput !Int - | AlexToken !AlexInput !Int a - --- alexScan :: AlexInput -> StartCode -> AlexReturn a -alexScan input__ (I# (sc)) - = alexScanUser undefined input__ (I# (sc)) - -alexScanUser user__ input__ (I# (sc)) - = case alex_scan_tkn user__ input__ 0# input__ sc AlexNone of - (AlexNone, input__') -> - case alexGetByte input__ of - Nothing -> - - AlexEOF - Just _ -> - - AlexError input__' - - (AlexLastSkip input__'' len, _) -> - - AlexSkip input__'' len - - (AlexLastAcc k input__''' len, _) -> - - AlexToken input__''' len (alex_actions ! k) - --- Push the input through the DFA, remembering the most recent accepting --- state it encountered. - -alex_scan_tkn user__ orig_input len input__ s last_acc = - input__ `seq` -- strict in the input - let - new_acc = (check_accs (alex_accept `quickIndex` (I# (s)))) - in - new_acc `seq` - case alexGetByte input__ of - Nothing -> (new_acc, input__) - Just (c, new_input) -> - - case fromIntegral c of { (I# (ord_c)) -> - let - base = alexIndexInt32OffAddr alex_base s - offset = (base +# ord_c) - check = alexIndexInt16OffAddr alex_check offset - - new_s = if GTE(offset,0#) && EQ(check,ord_c) - then alexIndexInt16OffAddr alex_table offset - else alexIndexInt16OffAddr alex_deflt s - in - case new_s of - -1# -> (new_acc, input__) - -- on an error, we want to keep the input *before* the - -- character that failed, not after. - _ -> alex_scan_tkn user__ orig_input (if c < 0x80 || c >= 0xC0 then (len +# 1#) else len) - -- note that the length is increased ONLY if this is the 1st byte in a char encoding) - new_input new_s new_acc - } - where - check_accs (AlexAccNone) = last_acc - check_accs (AlexAcc a ) = AlexLastAcc a input__ (I# (len)) - check_accs (AlexAccSkip) = AlexLastSkip input__ (I# (len)) - -data AlexLastAcc - = AlexNone - | AlexLastAcc !Int !AlexInput !Int - | AlexLastSkip !AlexInput !Int - -data AlexAcc user - = AlexAccNone - | AlexAcc Int - | AlexAccSkip - diff --git a/cabal/Cabal/Distribution/Fields/LexerMonad.hs b/cabal/Cabal/Distribution/Fields/LexerMonad.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Fields/LexerMonad.hs +++ /dev/null @@ -1,155 +0,0 @@ -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Fields.LexerMonad --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable -module Distribution.Fields.LexerMonad ( - InputStream, - LexState(..), - LexResult(..), - - Lex(..), - execLexer, - - getPos, - setPos, - adjustPos, - - getInput, - setInput, - - getStartCode, - setStartCode, - - LexWarning(..), - LexWarningType(..), - addWarning, - toPWarnings, - - ) where - -import qualified Data.ByteString as B -import qualified Data.List.NonEmpty as NE -import Distribution.Compat.Prelude -import Distribution.Parsec.Position (Position (..), showPos) -import Distribution.Parsec.Warning (PWarnType (..), PWarning (..)) -import Prelude () - -import qualified Data.Map.Strict as Map - -#ifdef CABAL_PARSEC_DEBUG --- testing only: -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Vector as V -#endif - --- simple state monad -newtype Lex a = Lex { unLex :: LexState -> LexResult a } - -instance Functor Lex where - fmap = liftM - -instance Applicative Lex where - pure = returnLex - (<*>) = ap - -instance Monad Lex where - return = pure - (>>=) = thenLex - -data LexResult a = LexResult {-# UNPACK #-} !LexState a - -data LexWarningType - = LexWarningNBSP -- ^ Encountered non breaking space - | LexWarningBOM -- ^ BOM at the start of the cabal file - | LexWarningTab -- ^ Leading tags - deriving (Eq, Ord, Show) - -data LexWarning = LexWarning !LexWarningType - {-# UNPACK #-} !Position - deriving (Show) - -toPWarnings :: [LexWarning] -> [PWarning] -toPWarnings - = map (uncurry toWarning) - . Map.toList - . Map.fromListWith (<>) - . map (\(LexWarning t p) -> (t, pure p)) - where - toWarning LexWarningBOM poss = - PWarning PWTLexBOM (NE.head poss) "Byte-order mark found at the beginning of the file" - toWarning LexWarningNBSP poss = - PWarning PWTLexNBSP (NE.head poss) $ "Non breaking spaces at " ++ intercalate ", " (NE.toList $ fmap showPos poss) - toWarning LexWarningTab poss = - PWarning PWTLexTab (NE.head poss) $ "Tabs used as indentation at " ++ intercalate ", " (NE.toList $ fmap showPos poss) - -data LexState = LexState { - curPos :: {-# UNPACK #-} !Position, -- ^ position at current input location - curInput :: {-# UNPACK #-} !InputStream, -- ^ the current input - curCode :: {-# UNPACK #-} !StartCode, -- ^ lexer code - warnings :: [LexWarning] -#ifdef CABAL_PARSEC_DEBUG - , dbgText :: V.Vector T.Text -- ^ input lines, to print pretty debug info -#endif - } --TODO: check if we should cache the first token - -- since it looks like parsec's uncons can be called many times on the same input - -type StartCode = Int -- ^ An @alex@ lexer start code -type InputStream = B.ByteString - - - --- | Execute the given lexer on the supplied input stream. -execLexer :: Lex a -> InputStream -> ([LexWarning], a) -execLexer (Lex lexer) input = - case lexer initialState of - LexResult LexState{ warnings = ws } result -> (ws, result) - where - initialState = LexState - -- TODO: add 'startPosition' - { curPos = Position 1 1 - , curInput = input - , curCode = 0 - , warnings = [] -#ifdef CABAL_PARSEC_DEBUG - , dbgText = V.fromList . T.lines . T.decodeUtf8 $ input -#endif - } - -{-# INLINE returnLex #-} -returnLex :: a -> Lex a -returnLex a = Lex $ \s -> LexResult s a - -{-# INLINE thenLex #-} -thenLex :: Lex a -> (a -> Lex b) -> Lex b -(Lex m) `thenLex` k = Lex $ \s -> case m s of LexResult s' a -> (unLex (k a)) s' - -setPos :: Position -> Lex () -setPos pos = Lex $ \s -> LexResult s{ curPos = pos } () - -getPos :: Lex Position -getPos = Lex $ \s@LexState{ curPos = pos } -> LexResult s pos - -adjustPos :: (Position -> Position) -> Lex () -adjustPos f = Lex $ \s@LexState{ curPos = pos } -> LexResult s{ curPos = f pos } () - -getInput :: Lex InputStream -getInput = Lex $ \s@LexState{ curInput = i } -> LexResult s i - -setInput :: InputStream -> Lex () -setInput i = Lex $ \s -> LexResult s{ curInput = i } () - -getStartCode :: Lex Int -getStartCode = Lex $ \s@LexState{ curCode = c } -> LexResult s c - -setStartCode :: Int -> Lex () -setStartCode c = Lex $ \s -> LexResult s{ curCode = c } () - --- | Add warning at the current position -addWarning :: LexWarningType -> Lex () -addWarning wt = Lex $ \s@LexState{ curPos = pos, warnings = ws } -> - LexResult s{ warnings = LexWarning wt pos : ws } () diff --git a/cabal/Cabal/Distribution/Fields/ParseResult.hs b/cabal/Cabal/Distribution/Fields/ParseResult.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Fields/ParseResult.hs +++ /dev/null @@ -1,196 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} --- | A parse result type for parsers from AST to Haskell types. -module Distribution.Fields.ParseResult ( - ParseResult, - runParseResult, - recoverWith, - parseWarning, - parseWarnings, - parseFailure, - parseFatalFailure, - parseFatalFailure', - getCabalSpecVersion, - setCabalSpecVersion, - readAndParseFile, - parseString, - withoutWarnings, - ) where - -import qualified Data.ByteString.Char8 as BS -import Distribution.Compat.Prelude -import Distribution.Parsec.Error (PError (..), showPError) -import Distribution.Parsec.Position (Position (..), zeroPos) -import Distribution.Parsec.Warning (PWarnType (..), PWarning (..), showPWarning) -import Distribution.Simple.Utils (die', warn) -import Distribution.Verbosity (Verbosity) -import Distribution.Version (Version) -import Prelude () -import System.Directory (doesFileExist) - -#if MIN_VERSION_base(4,10,0) -import Control.Applicative (Applicative (..)) -#endif - --- | A monad with failure and accumulating errors and warnings. -newtype ParseResult a = PR - { unPR - :: forall r. PRState - -> (PRState -> r) -- failure, but we were able to recover a new-style spec-version declaration - -> (PRState -> a -> r) -- success - -> r - } - --- Note: we have version here, as we could get any version. -data PRState = PRState ![PWarning] ![PError] !(Maybe Version) - -emptyPRState :: PRState -emptyPRState = PRState [] [] Nothing - --- | Forget 'ParseResult's warnings. --- --- @since 3.4.0.0 -withoutWarnings :: ParseResult a -> ParseResult a -withoutWarnings m = PR $ \s failure success -> - unPR m s failure $ \ !s1 -> success (s1 `withWarningsOf` s) - where - withWarningsOf (PRState _ e v) (PRState w _ _) = PRState w e v - --- | Destruct a 'ParseResult' into the emitted warnings and either --- a successful value or --- list of errors and possibly recovered a spec-version declaration. -runParseResult :: ParseResult a -> ([PWarning], Either (Maybe Version, NonEmpty PError) a) -runParseResult pr = unPR pr emptyPRState failure success - where - failure (PRState warns [] v) = (warns, Left (v, PError zeroPos "panic" :| [])) - failure (PRState warns (err:errs) v) = (warns, Left (v, err :| errs)) where - success (PRState warns [] _) x = (warns, Right x) - -- If there are any errors, don't return the result - success (PRState warns (err:errs) v) _ = (warns, Left (v, err :| errs)) - -instance Functor ParseResult where - fmap f (PR pr) = PR $ \ !s failure success -> - pr s failure $ \ !s' a -> - success s' (f a) - {-# INLINE fmap #-} - -instance Applicative ParseResult where - pure x = PR $ \ !s _ success -> success s x - {-# INLINE pure #-} - - f <*> x = PR $ \ !s0 failure success -> - unPR f s0 failure $ \ !s1 f' -> - unPR x s1 failure $ \ !s2 x' -> - success s2 (f' x') - {-# INLINE (<*>) #-} - - x *> y = PR $ \ !s0 failure success -> - unPR x s0 failure $ \ !s1 _ -> - unPR y s1 failure success - {-# INLINE (*>) #-} - - x <* y = PR $ \ !s0 failure success -> - unPR x s0 failure $ \ !s1 x' -> - unPR y s1 failure $ \ !s2 _ -> - success s2 x' - {-# INLINE (<*) #-} - -#if MIN_VERSION_base(4,10,0) - liftA2 f x y = PR $ \ !s0 failure success -> - unPR x s0 failure $ \ !s1 x' -> - unPR y s1 failure $ \ !s2 y' -> - success s2 (f x' y') - {-# INLINE liftA2 #-} -#endif - -instance Monad ParseResult where - return = pure - (>>) = (*>) - - m >>= k = PR $ \ !s failure success -> - unPR m s failure $ \ !s' a -> - unPR (k a) s' failure success - {-# INLINE (>>=) #-} - --- | "Recover" the parse result, so we can proceed parsing. --- 'runParseResult' will still result in 'Nothing', if there are recorded errors. -recoverWith :: ParseResult a -> a -> ParseResult a -recoverWith (PR pr) x = PR $ \ !s _failure success -> - pr s (\ !s' -> success s' x) success - --- | Set cabal spec version. -setCabalSpecVersion :: Maybe Version -> ParseResult () -setCabalSpecVersion v = PR $ \(PRState warns errs _) _failure success -> - success (PRState warns errs v) () - --- | Get cabal spec version. -getCabalSpecVersion :: ParseResult (Maybe Version) -getCabalSpecVersion = PR $ \s@(PRState _ _ v) _failure success -> - success s v - --- | Add a warning. This doesn't fail the parsing process. -parseWarning :: Position -> PWarnType -> String -> ParseResult () -parseWarning pos t msg = PR $ \(PRState warns errs v) _failure success -> - success (PRState (PWarning t pos msg : warns) errs v) () - --- | Add multiple warnings at once. -parseWarnings :: [PWarning] -> ParseResult () -parseWarnings newWarns = PR $ \(PRState warns errs v) _failure success -> - success (PRState (newWarns ++ warns) errs v) () - --- | Add an error, but not fail the parser yet. --- --- For fatal failure use 'parseFatalFailure' -parseFailure :: Position -> String -> ParseResult () -parseFailure pos msg = PR $ \(PRState warns errs v) _failure success -> - success (PRState warns (PError pos msg : errs) v) () - --- | Add an fatal error. -parseFatalFailure :: Position -> String -> ParseResult a -parseFatalFailure pos msg = PR $ \(PRState warns errs v) failure _success -> - failure (PRState warns (PError pos msg : errs) v) - --- | A 'mzero'. -parseFatalFailure' :: ParseResult a -parseFatalFailure' = PR pr - where - pr (PRState warns [] v) failure _success = failure (PRState warns [err] v) - pr s failure _success = failure s - - err = PError zeroPos "Unknown fatal error" - --- | Helper combinator to do parsing plumbing for files. --- --- Given a parser and a filename, return the parse of the file, --- after checking if the file exists. --- --- Argument order is chosen to encourage partial application. -readAndParseFile - :: (BS.ByteString -> ParseResult a) -- ^ File contents to final value parser - -> Verbosity -- ^ Verbosity level - -> FilePath -- ^ File to read - -> IO a -readAndParseFile parser verbosity fpath = do - exists <- doesFileExist fpath - unless exists $ - die' verbosity $ - "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue." - bs <- BS.readFile fpath - parseString parser verbosity fpath bs - -parseString - :: (BS.ByteString -> ParseResult a) -- ^ File contents to final value parser - -> Verbosity -- ^ Verbosity level - -> String -- ^ File name - -> BS.ByteString - -> IO a -parseString parser verbosity name bs = do - let (warnings, result) = runParseResult (parser bs) - traverse_ (warn verbosity . showPWarning name) warnings - case result of - Right x -> return x - Left (_, errors) -> do - traverse_ (warn verbosity . showPError name) errors - die' verbosity $ "Failed parsing \"" ++ name ++ "\"." diff --git a/cabal/Cabal/Distribution/Fields/Parser.hs b/cabal/Cabal/Distribution/Fields/Parser.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Fields/Parser.hs +++ /dev/null @@ -1,377 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternGuards #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Fields.Parser --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable -module Distribution.Fields.Parser ( - -- * Types - Field(..), - Name(..), - FieldLine(..), - SectionArg(..), - -- * Grammar and parsing - -- $grammar - readFields, - readFields', -#ifdef CABAL_PARSEC_DEBUG - -- * Internal - parseFile, - parseStr, - parseBS, -#endif - ) where - -import qualified Data.ByteString.Char8 as B8 -import Data.Functor.Identity -import Distribution.Compat.Prelude -import Distribution.Fields.Field -import Distribution.Fields.Lexer -import Distribution.Fields.LexerMonad - (LexResult (..), LexState (..), LexWarning (..), unLex) -import Distribution.Parsec.Position (Position (..)) -import Prelude () -import Text.Parsec.Combinator hiding (eof, notFollowedBy) -import Text.Parsec.Error -import Text.Parsec.Pos -import Text.Parsec.Prim hiding (many, (<|>)) - -#ifdef CABAL_PARSEC_DEBUG -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.Encoding.Error as T -#endif - --- | The 'LexState'' (with a prime) is an instance of parsec's 'Stream' --- wrapped around lexer's 'LexState' (without a prime) -data LexState' = LexState' !LexState (LToken, LexState') - -mkLexState' :: LexState -> LexState' -mkLexState' st = LexState' st - (case unLex lexToken st of LexResult st' tok -> (tok, mkLexState' st')) - -type Parser a = ParsecT LexState' () Identity a - -instance Stream LexState' Identity LToken where - uncons (LexState' _ (tok, st')) = - case tok of - L _ EOF -> return Nothing - _ -> return (Just (tok, st')) - --- | Get lexer warnings accumulated so far -getLexerWarnings :: Parser [LexWarning] -getLexerWarnings = do - LexState' (LexState { warnings = ws }) _ <- getInput - return ws - --- | Set Alex code i.e. the mode "state" lexer is in. -setLexerMode :: Int -> Parser () -setLexerMode code = do - LexState' ls _ <- getInput - setInput $! mkLexState' ls { curCode = code } - -getToken :: (Token -> Maybe a) -> Parser a -getToken getTok = getTokenWithPos (\(L _ t) -> getTok t) - -getTokenWithPos :: (LToken -> Maybe a) -> Parser a -getTokenWithPos getTok = tokenPrim (\(L _ t) -> describeToken t) updatePos getTok - where - updatePos :: SourcePos -> LToken -> LexState' -> SourcePos - updatePos pos (L (Position col line) _) _ = newPos (sourceName pos) col line - -describeToken :: Token -> String -describeToken t = case t of - TokSym s -> "symbol " ++ show s - TokStr s -> "string " ++ show s - TokOther s -> "operator " ++ show s - Indent _ -> "new line" - TokFieldLine _ -> "field content" - Colon -> "\":\"" - OpenBrace -> "\"{\"" - CloseBrace -> "\"}\"" --- SemiColon -> "\";\"" - EOF -> "end of file" - LexicalError is -> "character in input " ++ show (B8.head is) - -tokSym :: Parser (Name Position) -tokSym', tokStr, tokOther :: Parser (SectionArg Position) -tokIndent :: Parser Int -tokColon, tokOpenBrace, tokCloseBrace :: Parser () -tokFieldLine :: Parser (FieldLine Position) - -tokSym = getTokenWithPos $ \t -> case t of L pos (TokSym x) -> Just (mkName pos x); _ -> Nothing -tokSym' = getTokenWithPos $ \t -> case t of L pos (TokSym x) -> Just (SecArgName pos x); _ -> Nothing -tokStr = getTokenWithPos $ \t -> case t of L pos (TokStr x) -> Just (SecArgStr pos x); _ -> Nothing -tokOther = getTokenWithPos $ \t -> case t of L pos (TokOther x) -> Just (SecArgOther pos x); _ -> Nothing -tokIndent = getToken $ \t -> case t of Indent x -> Just x; _ -> Nothing -tokColon = getToken $ \t -> case t of Colon -> Just (); _ -> Nothing -tokOpenBrace = getToken $ \t -> case t of OpenBrace -> Just (); _ -> Nothing -tokCloseBrace = getToken $ \t -> case t of CloseBrace -> Just (); _ -> Nothing -tokFieldLine = getTokenWithPos $ \t -> case t of L pos (TokFieldLine s) -> Just (FieldLine pos s); _ -> Nothing - -colon, openBrace, closeBrace :: Parser () - -sectionArg :: Parser (SectionArg Position) -sectionArg = tokSym' <|> tokStr <|> tokOther "section parameter" - -fieldSecName :: Parser (Name Position) -fieldSecName = tokSym "field or section name" - -colon = tokColon "\":\"" -openBrace = tokOpenBrace "\"{\"" -closeBrace = tokCloseBrace "\"}\"" - -fieldContent :: Parser (FieldLine Position) -fieldContent = tokFieldLine "field contents" - -newtype IndentLevel = IndentLevel Int - -zeroIndentLevel :: IndentLevel -zeroIndentLevel = IndentLevel 0 - -incIndentLevel :: IndentLevel -> IndentLevel -incIndentLevel (IndentLevel i) = IndentLevel (succ i) - -indentOfAtLeast :: IndentLevel -> Parser IndentLevel -indentOfAtLeast (IndentLevel i) = try $ do - j <- tokIndent - guard (j >= i) "indentation of at least " ++ show i - return (IndentLevel j) - - -newtype LexerMode = LexerMode Int - -inLexerMode :: LexerMode -> Parser p -> Parser p -inLexerMode (LexerMode mode) p = - do setLexerMode mode; x <- p; setLexerMode in_section; return x - - ------------------------ --- Cabal file grammar --- - --- $grammar --- --- @ --- CabalStyleFile ::= SecElems --- --- SecElems ::= SecElem* '\\n'? --- SecElem ::= '\\n' SecElemLayout | SecElemBraces --- SecElemLayout ::= FieldLayout | FieldBraces | SectionLayout | SectionBraces --- SecElemBraces ::= FieldInline | FieldBraces | SectionBraces --- FieldLayout ::= name ':' line? ('\\n' line)* --- FieldBraces ::= name ':' '\\n'? '{' content '}' --- FieldInline ::= name ':' content --- SectionLayout ::= name arg* SecElems --- SectionBraces ::= name arg* '\\n'? '{' SecElems '}' --- @ --- --- and the same thing but left factored... --- --- @ --- SecElems ::= SecElem* --- SecElem ::= '\\n' name SecElemLayout --- | name SecElemBraces --- SecElemLayout ::= ':' FieldLayoutOrBraces --- | arg* SectionLayoutOrBraces --- FieldLayoutOrBraces ::= '\\n'? '{' content '}' --- | line? ('\\n' line)* --- SectionLayoutOrBraces ::= '\\n'? '{' SecElems '\\n'? '}' --- | SecElems --- SecElemBraces ::= ':' FieldInlineOrBraces --- | arg* '\\n'? '{' SecElems '\\n'? '}' --- FieldInlineOrBraces ::= '\\n'? '{' content '}' --- | content --- @ --- --- Note how we have several productions with the sequence: --- --- > '\\n'? '{' --- --- That is, an optional newline (and indent) followed by a @{@ token. --- In the @SectionLayoutOrBraces@ case you can see that this makes it --- not fully left factored (because @SecElems@ can start with a @\\n@). --- Fully left factoring here would be ugly, and though we could use a --- lookahead of two tokens to resolve the alternatives, we can't --- conveniently use Parsec's 'try' here to get a lookahead of only two. --- So instead we deal with this case in the lexer by making a line --- where the first non-space is @{@ lex as just the @{@ token, without --- the usual indent token. Then in the parser we can resolve everything --- with just one token of lookahead and so without using 'try'. - --- Top level of a file using cabal syntax --- -cabalStyleFile :: Parser [Field Position] -cabalStyleFile = do es <- elements zeroIndentLevel - eof - return es - --- Elements that live at the top level or inside a section, ie fields --- and sectionscontent --- --- elements ::= element* -elements :: IndentLevel -> Parser [Field Position] -elements ilevel = many (element ilevel) - --- An individual element, ie a field or a section. These can either use --- layout style or braces style. For layout style then it must start on --- a line on its own (so that we know its indentation level). --- --- element ::= '\\n' name elementInLayoutContext --- | name elementInNonLayoutContext -element :: IndentLevel -> Parser (Field Position) -element ilevel = - (do ilevel' <- indentOfAtLeast ilevel - name <- fieldSecName - elementInLayoutContext (incIndentLevel ilevel') name) - <|> (do name <- fieldSecName - elementInNonLayoutContext name) - --- An element (field or section) that is valid in a layout context. --- In a layout context we can have fields and sections that themselves --- either use layout style or that use braces style. --- --- elementInLayoutContext ::= ':' fieldLayoutOrBraces --- | arg* sectionLayoutOrBraces -elementInLayoutContext :: IndentLevel -> Name Position -> Parser (Field Position) -elementInLayoutContext ilevel name = - (do colon; fieldLayoutOrBraces ilevel name) - <|> (do args <- many sectionArg - elems <- sectionLayoutOrBraces ilevel - return (Section name args elems)) - --- An element (field or section) that is valid in a non-layout context. --- In a non-layout context we can have only have fields and sections that --- themselves use braces style, or inline style fields. --- --- elementInNonLayoutContext ::= ':' FieldInlineOrBraces --- | arg* '\\n'? '{' elements '\\n'? '}' -elementInNonLayoutContext :: Name Position -> Parser (Field Position) -elementInNonLayoutContext name = - (do colon; fieldInlineOrBraces name) - <|> (do args <- many sectionArg - openBrace - elems <- elements zeroIndentLevel - optional tokIndent - closeBrace - return (Section name args elems)) - --- The body of a field, using either layout style or braces style. --- --- fieldLayoutOrBraces ::= '\\n'? '{' content '}' --- | line? ('\\n' line)* -fieldLayoutOrBraces :: IndentLevel -> Name Position -> Parser (Field Position) -fieldLayoutOrBraces ilevel name = braces <|> fieldLayout - where - braces = do - openBrace - ls <- inLexerMode (LexerMode in_field_braces) (many fieldContent) - closeBrace - return (Field name ls) - fieldLayout = inLexerMode (LexerMode in_field_layout) $ do - l <- optionMaybe fieldContent - ls <- many (do _ <- indentOfAtLeast ilevel; fieldContent) - return $ case l of - Nothing -> Field name ls - Just l' -> Field name (l' : ls) - --- The body of a section, using either layout style or braces style. --- --- sectionLayoutOrBraces ::= '\\n'? '{' elements \\n? '}' --- | elements -sectionLayoutOrBraces :: IndentLevel -> Parser [Field Position] -sectionLayoutOrBraces ilevel = - (do openBrace - elems <- elements zeroIndentLevel - optional tokIndent - closeBrace - return elems) - <|> (elements ilevel) - --- The body of a field, using either inline style or braces. --- --- fieldInlineOrBraces ::= '\\n'? '{' content '}' --- | content -fieldInlineOrBraces :: Name Position -> Parser (Field Position) -fieldInlineOrBraces name = - (do openBrace - ls <- inLexerMode (LexerMode in_field_braces) (many fieldContent) - closeBrace - return (Field name ls)) - <|> (do ls <- inLexerMode (LexerMode in_field_braces) (option [] (fmap (\l -> [l]) fieldContent)) - return (Field name ls)) - - --- | Parse cabal style 'B8.ByteString' into list of 'Field's, i.e. the cabal AST. -readFields :: B8.ByteString -> Either ParseError [Field Position] -readFields s = fmap fst (readFields' s) - --- | Like 'readFields' but also return lexer warnings -readFields' :: B8.ByteString -> Either ParseError ([Field Position], [LexWarning]) -readFields' s = do - parse parser "the input" lexSt - where - parser = do - fields <- cabalStyleFile - ws <- getLexerWarnings - pure (fields, ws) - - lexSt = mkLexState' (mkLexState s) - -#ifdef CABAL_PARSEC_DEBUG -parseTest' :: Show a => Parsec LexState' () a -> SourceName -> B8.ByteString -> IO () -parseTest' p fname s = - case parse p fname (lexSt s) of - Left err -> putStrLn (formatError s err) - - Right x -> print x - where - lexSt = mkLexState' . mkLexState - -parseFile :: Show a => Parser a -> FilePath -> IO () -parseFile p f = B8.readFile f >>= \s -> parseTest' p f s - -parseStr :: Show a => Parser a -> String -> IO () -parseStr p = parseBS p . B8.pack - -parseBS :: Show a => Parser a -> B8.ByteString -> IO () -parseBS p = parseTest' p "" - -formatError :: B8.ByteString -> ParseError -> String -formatError input perr = - unlines - [ "Parse error "++ show (errorPos perr) ++ ":" - , errLine - , indicator ++ errmsg ] - where - pos = errorPos perr - ls = lines' (T.decodeUtf8With T.lenientDecode input) - errLine = T.unpack (ls !! (sourceLine pos - 1)) - indicator = replicate (sourceColumn pos) ' ' ++ "^" - errmsg = showErrorMessages "or" "unknown parse error" - "expecting" "unexpected" "end of file" - (errorMessages perr) - --- | Handles windows/osx/unix line breaks uniformly -lines' :: T.Text -> [T.Text] -lines' s1 - | T.null s1 = [] - | otherwise = case T.break (\c -> c == '\r' || c == '\n') s1 of - (l, s2) | Just (c,s3) <- T.uncons s2 - -> case T.uncons s3 of - Just ('\n', s4) | c == '\r' -> l : lines' s4 - _ -> l : lines' s3 - | otherwise -> [l] -#endif - -eof :: Parser () -eof = notFollowedBy anyToken "end of file" - where - notFollowedBy :: Parser LToken -> Parser () - notFollowedBy p = try ( (do L _ t <- try p; unexpected (describeToken t)) - <|> return ()) diff --git a/cabal/Cabal/Distribution/Fields/Pretty.hs b/cabal/Cabal/Distribution/Fields/Pretty.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Fields/Pretty.hs +++ /dev/null @@ -1,176 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveTraversable #-} --- | Cabal-like file AST types: 'Field', 'Section' etc, --- --- This (intermediate) data type is used for pretty-printing. --- --- @since 3.0.0.0 --- -module Distribution.Fields.Pretty ( - -- * Fields - PrettyField (..), - showFields, - showFields', - -- * Transformation from 'P.Field' - fromParsecFields, - genericFromParsecFields, - prettyFieldLines, - prettySectionArgs, - ) where - -import Distribution.Compat.Prelude -import Distribution.Pretty (showToken) -import Prelude () - -import Distribution.Fields.Field (FieldName) -import Distribution.Simple.Utils (fromUTF8BS) - -import qualified Distribution.Fields.Parser as P - -import qualified Data.ByteString as BS -import qualified Text.PrettyPrint as PP - -data PrettyField ann - = PrettyField ann FieldName PP.Doc - | PrettySection ann FieldName [PP.Doc] [PrettyField ann] - deriving (Functor, Foldable, Traversable) - --- | Prettyprint a list of fields. --- --- Note: the first argument should return 'String's without newlines --- and properly prefixes (with @--@) to count as comments. --- This unsafety is left in place so one could generate empty lines --- between comment lines. --- -showFields :: (ann -> [String]) -> [PrettyField ann] -> String -showFields rann = showFields' rann (const id) 4 - --- | 'showFields' with user specified indentation. -showFields' - :: (ann -> [String]) - -- ^ Convert an annotation to lined to preceed the field or section. - -> (ann -> [String] -> [String]) - -- ^ Post-process non-annotation produced lines. - -> Int - -- ^ Indentation level. - -> [PrettyField ann] - -- ^ Fields/sections to show. - -> String -showFields' rann post n = unlines . renderFields (Opts rann indent post) - where - -- few hardcoded, "unrolled" variants. - indent | n == 4 = indent4 - | n == 2 = indent2 - | otherwise = (replicate (max n 1) ' ' ++) - - indent4 :: String -> String - indent4 [] = [] - indent4 xs = ' ' : ' ' : ' ' : ' ' : xs - - indent2 :: String -> String - indent2 [] = [] - indent2 xs = ' ' : ' ' : xs - -data Opts ann = Opts - { _optAnnotation ::(ann -> [String]) - , _optIndent ::(String -> String) - , _optPostprocess :: ann -> [String] -> [String] - } - -renderFields :: Opts ann -> [PrettyField ann] -> [String] -renderFields opts fields = flattenBlocks $ map (renderField opts len) fields - where - len = maxNameLength 0 fields - - maxNameLength !acc [] = acc - maxNameLength !acc (PrettyField _ name _ : rest) = maxNameLength (max acc (BS.length name)) rest - maxNameLength !acc (PrettySection {} : rest) = maxNameLength acc rest - --- | Block of lines, --- Boolean parameter tells whether block should be surrounded by empty lines -data Block = Block Margin Margin [String] - -data Margin = Margin | NoMargin - deriving Eq - --- | Collapse margins, any margin = margin -instance Semigroup Margin where - NoMargin <> NoMargin = NoMargin - _ <> _ = Margin - -flattenBlocks :: [Block] -> [String] -flattenBlocks = go0 where - go0 [] = [] - go0 (Block _before after strs : blocks) = strs ++ go after blocks - - go _surr' [] = [] - go surr' (Block before after strs : blocks) = ins $ strs ++ go after blocks where - ins | surr' <> before == Margin = ("" :) - | otherwise = id - -renderField :: Opts ann -> Int -> PrettyField ann -> Block -renderField (Opts rann indent post) fw (PrettyField ann name doc) = - Block before after $ comments ++ post ann lines' - where - comments = rann ann - before = if null comments then NoMargin else Margin - - (lines', after) = case lines narrow of - [] -> ([ name' ++ ":" ], NoMargin) - [singleLine] | length singleLine < 60 - -> ([ name' ++ ": " ++ replicate (fw - length name') ' ' ++ narrow ], NoMargin) - _ -> ((name' ++ ":") : map indent (lines (PP.render doc)), Margin) - - name' = fromUTF8BS name - narrow = PP.renderStyle narrowStyle doc - - narrowStyle :: PP.Style - narrowStyle = PP.style { PP.lineLength = PP.lineLength PP.style - fw } - -renderField opts@(Opts rann indent post) _ (PrettySection ann name args fields) = Block Margin Margin $ - rann ann - ++ - post ann [ PP.render $ PP.hsep $ PP.text (fromUTF8BS name) : args ] - ++ - (map indent $ renderFields opts fields) - -------------------------------------------------------------------------------- --- Transform from Parsec.Field -------------------------------------------------------------------------------- - -genericFromParsecFields - :: Applicative f - => (FieldName -> [P.FieldLine ann] -> f PP.Doc) -- ^ transform field contents - -> (FieldName -> [P.SectionArg ann] -> f [PP.Doc]) -- ^ transform section arguments - -> [P.Field ann] - -> f [PrettyField ann] -genericFromParsecFields f g = goMany where - goMany = traverse go - - go (P.Field (P.Name ann name) fls) = PrettyField ann name <$> f name fls - go (P.Section (P.Name ann name) secargs fs) = PrettySection ann name <$> g name secargs <*> goMany fs - --- | Used in 'fromParsecFields'. -prettyFieldLines :: FieldName -> [P.FieldLine ann] -> PP.Doc -prettyFieldLines _ fls = PP.vcat - [ PP.text $ fromUTF8BS bs - | P.FieldLine _ bs <- fls - ] - --- | Used in 'fromParsecFields'. -prettySectionArgs :: FieldName -> [P.SectionArg ann] -> [PP.Doc] -prettySectionArgs _ = map $ \sa -> case sa of - P.SecArgName _ bs -> showToken $ fromUTF8BS bs - P.SecArgStr _ bs -> showToken $ fromUTF8BS bs - P.SecArgOther _ bs -> PP.text $ fromUTF8BS bs - --- | Simple variant of 'genericFromParsecField' -fromParsecFields :: [P.Field ann] -> [PrettyField ann] -fromParsecFields = runIdentity . genericFromParsecFields - (Identity .: prettyFieldLines) - (Identity .: prettySectionArgs) - where - (.:) :: (a -> b) -> (c -> d -> a) -> (c -> d -> b) - (f .: g) x y = f (g x y) diff --git a/cabal/Cabal/Distribution/GetOpt.hs b/cabal/Cabal/Distribution/GetOpt.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/GetOpt.hs +++ /dev/null @@ -1,209 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.GetOpt --- Copyright : (c) Sven Panne 2002-2005 --- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : libraries@haskell.org --- Portability : portable --- --- This is a fork of "System.Console.GetOpt" with the following changes: --- --- * Treat "cabal --flag command" as "cabal command --flag" e.g. --- "cabal -v configure" to mean "cabal configure -v" For flags that are --- not recognised as global flags, pass them on to the sub-command. See --- the difference in 'shortOpt'. --- --- * Line wrapping in the 'usageInfo' output, plus a more compact --- rendering of short options, and slightly less padding. --- --- If you want to take on the challenge of merging this with the GetOpt --- from the base package then go for it! --- -module Distribution.GetOpt ( - -- * GetOpt - getOpt, getOpt', - usageInfo, - ArgOrder(..), - OptDescr(..), - ArgDescr(..), - - -- * Example - -- | See "System.Console.GetOpt" for examples -) where - -import Prelude () -import Distribution.Compat.Prelude -import System.Console.GetOpt - ( ArgOrder(..), OptDescr(..), ArgDescr(..) ) - -data OptKind a -- kind of cmd line arg (internal use only): - = Opt a -- an option - | UnreqOpt String -- an un-recognized option - | NonOpt String -- a non-option - | EndOfOpts -- end-of-options marker (i.e. "--") - | OptErr String -- something went wrong... - --- | Return a string describing the usage of a command, derived from --- the header (first argument) and the options described by the --- second argument. -usageInfo :: String -- header - -> [OptDescr a] -- option descriptors - -> String -- nicely formatted decription of options -usageInfo header optDescr = unlines (header:table) - where (ss,ls,ds) = unzip3 [ (intercalate ", " (map (fmtShort ad) sos) - ,concatMap (fmtLong ad) (take 1 los) - ,d) - | Option sos los ad d <- optDescr ] - ssWidth = (maximum . map length) ss - lsWidth = (maximum . map length) ls - dsWidth = 30 `max` (80 - (ssWidth + lsWidth + 3)) - table = [ " " ++ padTo ssWidth so' ++ - " " ++ padTo lsWidth lo' ++ - " " ++ d' - | (so,lo,d) <- zip3 ss ls ds - , (so',lo',d') <- fmtOpt dsWidth so lo d ] - padTo n x = take n (x ++ repeat ' ') - -fmtOpt :: Int -> String -> String -> String -> [(String, String, String)] -fmtOpt descrWidth so lo descr = - case wrapText descrWidth descr of - [] -> [(so,lo,"")] - (d:ds) -> (so,lo,d) : [ ("","",d') | d' <- ds ] - -fmtShort :: ArgDescr a -> Char -> String -fmtShort (NoArg _ ) so = "-" ++ [so] -fmtShort (ReqArg _ _) so = "-" ++ [so] -fmtShort (OptArg _ _) so = "-" ++ [so] - -- unlike upstream GetOpt we omit the arg name for short options - -fmtLong :: ArgDescr a -> String -> String -fmtLong (NoArg _ ) lo = "--" ++ lo -fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad -fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]" - -wrapText :: Int -> String -> [String] -wrapText width = map unwords . wrap 0 [] . words - where wrap :: Int -> [String] -> [String] -> [[String]] - wrap 0 [] (w:ws) - | length w + 1 > width - = wrap (length w) [w] ws - wrap col line (w:ws) - | col + length w + 1 > width - = reverse line : wrap 0 [] (w:ws) - wrap col line (w:ws) - = let col' = col + length w + 1 - in wrap col' (w:line) ws - wrap _ [] [] = [] - wrap _ line [] = [reverse line] - -{-| -Process the command-line, and return the list of values that matched -(and those that didn\'t). The arguments are: - -* The order requirements (see 'ArgOrder') - -* The option descriptions (see 'OptDescr') - -* The actual command line arguments (presumably got from - 'System.Environment.getArgs'). - -'getOpt' returns a triple consisting of the option arguments, a list -of non-options, and a list of error messages. --} -getOpt :: ArgOrder a -- non-option handling - -> [OptDescr a] -- option descriptors - -> [String] -- the command-line arguments - -> ([a],[String],[String]) -- (options,non-options,error messages) -getOpt ordering optDescr args = (os,xs,es ++ map errUnrec us) - where (os,xs,us,es) = getOpt' ordering optDescr args - -{-| -This is almost the same as 'getOpt', but returns a quadruple -consisting of the option arguments, a list of non-options, a list of -unrecognized options, and a list of error messages. --} -getOpt' :: ArgOrder a -- non-option handling - -> [OptDescr a] -- option descriptors - -> [String] -- the command-line arguments - -> ([a],[String], [String] ,[String]) -- (options,non-options,unrecognized,error messages) -getOpt' _ _ [] = ([],[],[],[]) -getOpt' ordering optDescr (arg:args) = procNextOpt opt ordering - where procNextOpt (Opt o) _ = (o:os,xs,us,es) - procNextOpt (UnreqOpt u) _ = (os,xs,u:us,es) - procNextOpt (NonOpt x) RequireOrder = ([],x:rest,[],[]) - procNextOpt (NonOpt x) Permute = (os,x:xs,us,es) - procNextOpt (NonOpt x) (ReturnInOrder f) = (f x :os, xs,us,es) - procNextOpt EndOfOpts RequireOrder = ([],rest,[],[]) - procNextOpt EndOfOpts Permute = ([],rest,[],[]) - procNextOpt EndOfOpts (ReturnInOrder f) = (map f rest,[],[],[]) - procNextOpt (OptErr e) _ = (os,xs,us,e:es) - - (opt,rest) = getNext arg args optDescr - (os,xs,us,es) = getOpt' ordering optDescr rest - --- take a look at the next cmd line arg and decide what to do with it -getNext :: String -> [String] -> [OptDescr a] -> (OptKind a,[String]) -getNext ('-':'-':[]) rest _ = (EndOfOpts,rest) -getNext ('-':'-':xs) rest optDescr = longOpt xs rest optDescr -getNext ('-': x :xs) rest optDescr = shortOpt x xs rest optDescr -getNext a rest _ = (NonOpt a,rest) - --- handle long option -longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String]) -longOpt ls rs optDescr = long ads arg rs - where (opt,arg) = break (=='=') ls - getWith p = [ o | o@(Option _ xs _ _) <- optDescr - , isJust (find (p opt) xs)] - exact = getWith (==) - options = if null exact then getWith isPrefixOf else exact - ads = [ ad | Option _ _ ad _ <- options ] - optStr = "--" ++ opt - - long (_:_:_) _ rest = (errAmbig options optStr,rest) - long [NoArg a ] [] rest = (Opt a,rest) - long [NoArg _ ] ('=':_) rest = (errNoArg optStr,rest) - long [ReqArg _ d] [] [] = (errReq d optStr,[]) - long [ReqArg f _] [] (r:rest) = (Opt (f r),rest) - long [ReqArg f _] ('=':xs) rest = (Opt (f xs),rest) - long [OptArg f _] [] rest = (Opt (f Nothing),rest) - long [OptArg f _] ('=':xs) rest = (Opt (f (Just xs)),rest) - long _ _ rest = (UnreqOpt ("--"++ls),rest) - --- handle short option -shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a,[String]) -shortOpt y ys rs optDescr = short ads ys rs - where options = [ o | o@(Option ss _ _ _) <- optDescr, s <- ss, y == s ] - ads = [ ad | Option _ _ ad _ <- options ] - optStr = '-':[y] - - short (_:_:_) _ rest = (errAmbig options optStr,rest) - short (NoArg a :_) [] rest = (Opt a,rest) - short (NoArg a :_) xs rest = (Opt a,('-':xs):rest) - short (ReqArg _ d:_) [] [] = (errReq d optStr,[]) - short (ReqArg f _:_) [] (r:rest) = (Opt (f r),rest) - short (ReqArg f _:_) xs rest = (Opt (f xs),rest) - short (OptArg f _:_) [] rest = (Opt (f Nothing),rest) - short (OptArg f _:_) xs rest = (Opt (f (Just xs)),rest) - short [] [] rest = (UnreqOpt optStr,rest) - short [] xs rest = (UnreqOpt (optStr++xs),rest) - -- This is different vs upstream = (UnreqOpt optStr,('-':xs):rest) - -- Apparently this was part of the change so that flags that are - -- not recognised as global flags are passed on to the sub-command. - -- But why was no equivalent change required for longOpt? So could - -- this change go upstream? - --- miscellaneous error formatting - -errAmbig :: [OptDescr a] -> String -> OptKind a -errAmbig ods optStr = OptErr (usageInfo header ods) - where header = "option `" ++ optStr ++ "' is ambiguous; could be one of:" - -errReq :: String -> String -> OptKind a -errReq d optStr = OptErr ("option `" ++ optStr ++ "' requires an argument " ++ d ++ "\n") - -errUnrec :: String -> String -errUnrec optStr = "unrecognized option `" ++ optStr ++ "'\n" - -errNoArg :: String -> OptKind a -errNoArg optStr = OptErr ("option `" ++ optStr ++ "' doesn't allow an argument\n") diff --git a/cabal/Cabal/Distribution/InstalledPackageInfo.hs b/cabal/Cabal/Distribution/InstalledPackageInfo.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/InstalledPackageInfo.hs +++ /dev/null @@ -1,145 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.InstalledPackageInfo --- Copyright : (c) The University of Glasgow 2004 --- --- Maintainer : libraries@haskell.org --- Portability : portable --- --- This is the information about an /installed/ package that --- is communicated to the @ghc-pkg@ program in order to register --- a package. @ghc-pkg@ now consumes this package format (as of version --- 6.4). This is specific to GHC at the moment. --- --- The @.cabal@ file format is for describing a package that is not yet --- installed. It has a lot of flexibility, like conditionals and dependency --- ranges. As such, that format is not at all suitable for describing a package --- that has already been built and installed. By the time we get to that stage, --- we have resolved all conditionals and resolved dependency version --- constraints to exact versions of dependent packages. So, this module defines --- the 'InstalledPackageInfo' data structure that contains all the info we keep --- about an installed package. There is a parser and pretty printer. The --- textual format is rather simpler than the @.cabal@ format: there are no --- sections, for example. - --- This module is meant to be local-only to Distribution... - -module Distribution.InstalledPackageInfo ( - InstalledPackageInfo(..), - installedComponentId, - installedOpenUnitId, - sourceComponentName, - requiredSignatures, - ExposedModule(..), - AbiDependency(..), - emptyInstalledPackageInfo, - parseInstalledPackageInfo, - showInstalledPackageInfo, - showFullInstalledPackageInfo, - showInstalledPackageInfoField, - showSimpleInstalledPackageInfoField, - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Backpack -import Distribution.CabalSpecVersion (cabalSpecLatest) -import Distribution.FieldGrammar -import Distribution.FieldGrammar.FieldDescrs -import Distribution.ModuleName -import Distribution.Package hiding (installedUnitId) -import Distribution.Types.ComponentName -import Distribution.Utils.Generic (toUTF8BS) - -import Data.ByteString (ByteString) - -import qualified Data.Map as Map -import qualified Distribution.Fields as P -import qualified Text.PrettyPrint as Disp - -import Distribution.Types.InstalledPackageInfo -import Distribution.Types.InstalledPackageInfo.FieldGrammar - --- $setup --- >>> :set -XOverloadedStrings - -installedComponentId :: InstalledPackageInfo -> ComponentId -installedComponentId ipi = - case unComponentId (installedComponentId_ ipi) of - "" -> mkComponentId (unUnitId (installedUnitId ipi)) - _ -> installedComponentId_ ipi - --- | Get the indefinite unit identity representing this package. --- This IS NOT guaranteed to give you a substitution; for --- instantiated packages you will get @DefiniteUnitId (installedUnitId ipi)@. --- For indefinite libraries, however, you will correctly get --- an @OpenUnitId@ with the appropriate 'OpenModuleSubst'. -installedOpenUnitId :: InstalledPackageInfo -> OpenUnitId -installedOpenUnitId ipi - = mkOpenUnitId (installedUnitId ipi) (installedComponentId ipi) (Map.fromList (instantiatedWith ipi)) - --- | Returns the set of module names which need to be filled for --- an indefinite package, or the empty set if the package is definite. -requiredSignatures :: InstalledPackageInfo -> Set ModuleName -requiredSignatures ipi = openModuleSubstFreeHoles (Map.fromList (instantiatedWith ipi)) - --- ----------------------------------------------------------------------------- --- Munging - -sourceComponentName :: InstalledPackageInfo -> ComponentName -sourceComponentName = CLibName . sourceLibName - --- ----------------------------------------------------------------------------- --- Parsing - --- | Return either errors, or IPI with list of warnings -parseInstalledPackageInfo - :: ByteString - -> Either (NonEmpty String) ([String], InstalledPackageInfo) -parseInstalledPackageInfo s = case P.readFields s of - Left err -> Left (show err :| []) - Right fs -> case partitionFields fs of - (fs', _) -> case P.runParseResult $ parseFieldGrammar cabalSpecLatest fs' ipiFieldGrammar of - (ws, Right x) -> x `deepseq` Right (ws', x) where - ws' = [ P.showPWarning "" w - | w@(P.PWarning wt _ _) <- ws - -- filter out warnings about experimental features - , wt /= P.PWTExperimental - ] - (_, Left (_, errs)) -> Left errs' where - errs' = fmap (P.showPError "") errs - --- ----------------------------------------------------------------------------- --- Pretty-printing - --- | Pretty print 'InstalledPackageInfo'. --- --- @pkgRoot@ isn't printed, as ghc-pkg prints it manually (as GHC-8.4). -showInstalledPackageInfo :: InstalledPackageInfo -> String -showInstalledPackageInfo ipi = - showFullInstalledPackageInfo ipi { pkgRoot = Nothing } - --- | The variant of 'showInstalledPackageInfo' which outputs @pkgroot@ field too. -showFullInstalledPackageInfo :: InstalledPackageInfo -> String -showFullInstalledPackageInfo = P.showFields (const []) . prettyFieldGrammar cabalSpecLatest ipiFieldGrammar - --- | --- --- >>> let ipi = emptyInstalledPackageInfo { maintainer = "Tester" } --- >>> fmap ($ ipi) $ showInstalledPackageInfoField "maintainer" --- Just "maintainer: Tester" -showInstalledPackageInfoField :: String -> Maybe (InstalledPackageInfo -> String) -showInstalledPackageInfoField fn = - fmap (\g -> Disp.render . ppField fn . g) $ fieldDescrPretty ipiFieldGrammar (toUTF8BS fn) - -showSimpleInstalledPackageInfoField :: String -> Maybe (InstalledPackageInfo -> String) -showSimpleInstalledPackageInfoField fn = - fmap (Disp.renderStyle myStyle .) $ fieldDescrPretty ipiFieldGrammar (toUTF8BS fn) - where - myStyle = Disp.style { Disp.mode = Disp.LeftMode } - -ppField :: String -> Disp.Doc -> Disp.Doc -ppField name fielddoc - | Disp.isEmpty fielddoc = mempty - | otherwise = Disp.text name <<>> Disp.colon Disp.<+> fielddoc diff --git a/cabal/Cabal/Distribution/Lex.hs b/cabal/Cabal/Distribution/Lex.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Lex.hs +++ /dev/null @@ -1,40 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Lex --- Copyright : Ben Gamari 2015-2019 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This module contains a simple lexer supporting quoted strings - -module Distribution.Lex ( - tokenizeQuotedWords - ) where - -import Prelude () -import Distribution.Compat.Prelude -import Distribution.Compat.DList - -tokenizeQuotedWords :: String -> [String] -tokenizeQuotedWords = filter (not . null) . go False mempty - where - go :: Bool -- ^ in quoted region - -> DList Char -- ^ accumulator - -> String -- ^ string to be parsed - -> [String] -- ^ parse result - go _ accum [] - | [] <- accum' = [] - | otherwise = [accum'] - where accum' = runDList accum - - go False accum (c:cs) - | isSpace c = runDList accum : go False mempty cs - | c == '"' = go True accum cs - - go True accum (c:cs) - | c == '"' = go False accum cs - - go quoted accum (c:cs) - = go quoted (accum `mappend` singleton c) cs - diff --git a/cabal/Cabal/Distribution/License.hs b/cabal/Cabal/Distribution/License.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/License.hs +++ /dev/null @@ -1,252 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.License --- Description : The License data type. --- Copyright : Isaac Jones 2003-2005 --- Duncan Coutts 2008 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Package descriptions contain fields for specifying the name of a software --- license and the name of the file containing the text of that license. While --- package authors may choose any license they like, Cabal provides an --- enumeration of a small set of common free and open source software licenses. --- This is done so that Hackage can recognise licenses, so that tools can detect --- , --- and to deter --- . --- --- It is recommended that all package authors use the @license-file@ or --- @license-files@ fields in their package descriptions. Further information --- about these fields can be found in the --- . --- --- = Additional resources --- --- The following websites provide information about free and open source --- software licenses: --- --- * --- --- * --- --- = Disclaimer --- --- The descriptions of software licenses provided by this documentation are --- intended for informational purposes only and in no way constitute legal --- advice. Please read the text of the licenses and consult a lawyer for any --- advice regarding software licensing. - -module Distribution.License ( - License(..), - knownLicenses, - licenseToSPDX, - licenseFromSPDX, - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Version - -import qualified Distribution.Compat.CharParsing as P -import qualified Data.Map.Strict as Map -import qualified Distribution.SPDX as SPDX -import qualified Text.PrettyPrint as Disp - --- | Indicates the license under which a package's source code is released. --- Versions of the licenses not listed here will be rejected by Hackage and --- cause @cabal check@ to issue a warning. -data License = - -- TODO: * remove BSD4 - - -- | GNU General Public License, - -- or - -- . - GPL (Maybe Version) - - -- | . - | AGPL (Maybe Version) - - -- | GNU Lesser General Public License, - -- or - -- . - | LGPL (Maybe Version) - - -- | . - | BSD2 - - -- | . - | BSD3 - - -- | . - -- This license has not been approved by the OSI and is incompatible with - -- the GNU GPL. It is provided for historical reasons and should be avoided. - | BSD4 - - -- | . - | MIT - - -- | - | ISC - - -- | . - | MPL Version - - -- | . - | Apache (Maybe Version) - - -- | The author of a package disclaims any copyright to its source code and - -- dedicates it to the public domain. This is not a software license. Please - -- note that it is not possible to dedicate works to the public domain in - -- every jurisdiction, nor is a work that is in the public domain in one - -- jurisdiction necessarily in the public domain elsewhere. - | PublicDomain - - -- | Explicitly 'All Rights Reserved', eg for proprietary software. The - -- package may not be legally modified or redistributed by anyone but the - -- rightsholder. - | AllRightsReserved - - -- | No license specified which legally defaults to 'All Rights Reserved'. - -- The package may not be legally modified or redistributed by anyone but - -- the rightsholder. - | UnspecifiedLicense - - -- | Any other software license. - | OtherLicense - - -- | Indicates an erroneous license name. - | UnknownLicense String - deriving (Generic, Read, Show, Eq, Typeable, Data) - -instance Binary License -instance Structured License -instance NFData License where rnf = genericRnf - --- | The list of all currently recognised licenses. -knownLicenses :: [License] -knownLicenses = [ GPL unversioned, GPL (version [2]), GPL (version [3]) - , LGPL unversioned, LGPL (version [2, 1]), LGPL (version [3]) - , AGPL unversioned, AGPL (version [3]) - , BSD2, BSD3, MIT, ISC - , MPL (mkVersion [2, 0]) - , Apache unversioned, Apache (version [2, 0]) - , PublicDomain, AllRightsReserved, OtherLicense] - where - unversioned = Nothing - version = Just . mkVersion - --- | Convert old 'License' to SPDX 'SPDX.License'. --- Non-SPDX licenses are converted to 'SPDX.LicenseRef'. --- --- @since 2.2.0.0 -licenseToSPDX :: License -> SPDX.License -licenseToSPDX l = case l of - GPL v | v == version [2] -> spdx SPDX.GPL_2_0_only - GPL v | v == version [3] -> spdx SPDX.GPL_3_0_only - LGPL v | v == version [2,1] -> spdx SPDX.LGPL_2_1_only - LGPL v | v == version [3] -> spdx SPDX.LGPL_3_0_only - AGPL v | v == version [3] -> spdx SPDX.AGPL_3_0_only - BSD2 -> spdx SPDX.BSD_2_Clause - BSD3 -> spdx SPDX.BSD_3_Clause - BSD4 -> spdx SPDX.BSD_4_Clause - MIT -> spdx SPDX.MIT - ISC -> spdx SPDX.ISC - MPL v | v == mkVersion [2,0] -> spdx SPDX.MPL_2_0 - Apache v | v == version [2,0] -> spdx SPDX.Apache_2_0 - AllRightsReserved -> SPDX.NONE - UnspecifiedLicense -> SPDX.NONE - OtherLicense -> ref (SPDX.mkLicenseRef' Nothing "OtherLicense") - PublicDomain -> ref (SPDX.mkLicenseRef' Nothing "PublicDomain") - UnknownLicense str -> ref (SPDX.mkLicenseRef' Nothing str) - _ -> ref (SPDX.mkLicenseRef' Nothing $ prettyShow l) - where - version = Just . mkVersion - spdx = SPDX.License . SPDX.simpleLicenseExpression - ref r = SPDX.License $ SPDX.ELicense (SPDX.ELicenseRef r) Nothing - --- | Convert 'SPDX.License' to 'License', --- --- This is lossy conversion. We try our best. --- --- >>> licenseFromSPDX . licenseToSPDX $ BSD3 --- BSD3 --- --- >>> licenseFromSPDX . licenseToSPDX $ GPL (Just (mkVersion [3])) --- GPL (Just (mkVersion [3])) --- --- >>> licenseFromSPDX . licenseToSPDX $ PublicDomain --- UnknownLicense "LicenseRefPublicDomain" --- --- >>> licenseFromSPDX $ SPDX.License $ SPDX.simpleLicenseExpression SPDX.EUPL_1_1 --- UnknownLicense "EUPL-1.1" --- --- >>> licenseFromSPDX . licenseToSPDX $ AllRightsReserved --- AllRightsReserved --- --- >>> licenseFromSPDX <$> simpleParsec "BSD-3-Clause OR GPL-3.0-only" --- Just (UnknownLicense "BSD3ClauseORGPL30only") --- --- @since 2.2.0.0 -licenseFromSPDX :: SPDX.License -> License -licenseFromSPDX SPDX.NONE = AllRightsReserved -licenseFromSPDX l = - fromMaybe (mungle $ prettyShow l) $ Map.lookup l m - where - m :: Map.Map SPDX.License License - m = Map.fromList $ filter (isSimple . fst ) $ - map (\x -> (licenseToSPDX x, x)) knownLicenses - - isSimple (SPDX.License (SPDX.ELicense (SPDX.ELicenseId _) Nothing)) = True - isSimple _ = False - - mungle name = fromMaybe (UnknownLicense (mapMaybe mangle name)) (simpleParsec name) - - mangle c - | isAlphaNum c = Just c - | otherwise = Nothing - -instance Pretty License where - pretty (GPL version) = Disp.text "GPL" <<>> dispOptVersion version - pretty (LGPL version) = Disp.text "LGPL" <<>> dispOptVersion version - pretty (AGPL version) = Disp.text "AGPL" <<>> dispOptVersion version - pretty (MPL version) = Disp.text "MPL" <<>> dispVersion version - pretty (Apache version) = Disp.text "Apache" <<>> dispOptVersion version - pretty (UnknownLicense other) = Disp.text other - pretty other = Disp.text (show other) - -instance Parsec License where - parsec = do - name <- P.munch1 isAlphaNum - version <- P.optional (P.char '-' *> parsec) - return $! case (name, version :: Maybe Version) of - ("GPL", _ ) -> GPL version - ("LGPL", _ ) -> LGPL version - ("AGPL", _ ) -> AGPL version - ("BSD2", Nothing) -> BSD2 - ("BSD3", Nothing) -> BSD3 - ("BSD4", Nothing) -> BSD4 - ("ISC", Nothing) -> ISC - ("MIT", Nothing) -> MIT - ("MPL", Just version') -> MPL version' - ("Apache", _ ) -> Apache version - ("PublicDomain", Nothing) -> PublicDomain - ("AllRightsReserved", Nothing) -> AllRightsReserved - ("OtherLicense", Nothing) -> OtherLicense - _ -> UnknownLicense $ name ++ - maybe "" (('-':) . prettyShow) version - -dispOptVersion :: Maybe Version -> Disp.Doc -dispOptVersion Nothing = Disp.empty -dispOptVersion (Just v) = dispVersion v - -dispVersion :: Version -> Disp.Doc -dispVersion v = Disp.char '-' <<>> pretty v diff --git a/cabal/Cabal/Distribution/Make.hs b/cabal/Cabal/Distribution/Make.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Make.hs +++ /dev/null @@ -1,182 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Make --- Copyright : Martin Sjögren 2004 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This is an alternative build system that delegates everything to the @make@ --- program. All the commands just end up calling @make@ with appropriate --- arguments. The intention was to allow preexisting packages that used --- makefiles to be wrapped into Cabal packages. In practice essentially all --- such packages were converted over to the \"Simple\" build system instead. --- Consequently this module is not used much and it certainly only sees cursory --- maintenance and no testing. Perhaps at some point we should stop pretending --- that it works. --- --- Uses the parsed command-line from "Distribution.Simple.Setup" in order to build --- Haskell tools using a back-end build system based on make. Obviously we --- assume that there is a configure script, and that after the ConfigCmd has --- been run, there is a Makefile. Further assumptions: --- --- [ConfigCmd] We assume the configure script accepts --- @--with-hc@, --- @--with-hc-pkg@, --- @--prefix@, --- @--bindir@, --- @--libdir@, --- @--libexecdir@, --- @--datadir@. --- --- [BuildCmd] We assume that the default Makefile target will build everything. --- --- [InstallCmd] We assume there is an @install@ target. Note that we assume that --- this does *not* register the package! --- --- [CopyCmd] We assume there is a @copy@ target, and a variable @$(destdir)@. --- The @copy@ target should probably just invoke @make install@ --- recursively (e.g. @$(MAKE) install prefix=$(destdir)\/$(prefix) --- bindir=$(destdir)\/$(bindir)@. The reason we can\'t invoke @make --- install@ directly here is that we don\'t know the value of @$(prefix)@. --- --- [SDistCmd] We assume there is a @dist@ target. --- --- [RegisterCmd] We assume there is a @register@ target and a variable @$(user)@. --- --- [UnregisterCmd] We assume there is an @unregister@ target. --- --- [HaddockCmd] We assume there is a @docs@ or @doc@ target. - - --- copy : --- $(MAKE) install prefix=$(destdir)/$(prefix) \ --- bindir=$(destdir)/$(bindir) \ - -module Distribution.Make ( - module Distribution.Package, - License(..), Version, - defaultMain, defaultMainArgs - ) where - -import Prelude () -import Distribution.Compat.Prelude - --- local -import Distribution.Package -import Distribution.Simple.Program -import Distribution.Simple.Setup -import Distribution.Simple.Command - -import Distribution.Simple.Utils - -import Distribution.License -import Distribution.Version -import Distribution.Pretty - -import System.Environment (getArgs, getProgName) - -defaultMain :: IO () -defaultMain = getArgs >>= defaultMainArgs - -defaultMainArgs :: [String] -> IO () -defaultMainArgs = defaultMainHelper - -defaultMainHelper :: [String] -> IO () -defaultMainHelper args = - case commandsRun (globalCommand commands) commands args of - CommandHelp help -> printHelp help - CommandList opts -> printOptionsList opts - CommandErrors errs -> printErrors errs - CommandReadyToGo (flags, commandParse) -> - case commandParse of - _ | fromFlag (globalVersion flags) -> printVersion - | fromFlag (globalNumericVersion flags) -> printNumericVersion - CommandHelp help -> printHelp help - CommandList opts -> printOptionsList opts - CommandErrors errs -> printErrors errs - CommandReadyToGo action -> action - - where - printHelp help = getProgName >>= putStr . help - printOptionsList = putStr . unlines - printErrors errs = do - putStr (intercalate "\n" errs) - exitWith (ExitFailure 1) - printNumericVersion = putStrLn $ prettyShow cabalVersion - printVersion = putStrLn $ "Cabal library version " - ++ prettyShow cabalVersion - - progs = defaultProgramDb - commands = - [configureCommand progs `commandAddAction` configureAction - ,buildCommand progs `commandAddAction` buildAction - ,installCommand `commandAddAction` installAction - ,copyCommand `commandAddAction` copyAction - ,haddockCommand `commandAddAction` haddockAction - ,cleanCommand `commandAddAction` cleanAction - ,sdistCommand `commandAddAction` sdistAction - ,registerCommand `commandAddAction` registerAction - ,unregisterCommand `commandAddAction` unregisterAction - ] - -configureAction :: ConfigFlags -> [String] -> IO () -configureAction flags args = do - noExtraFlags args - let verbosity = fromFlag (configVerbosity flags) - rawSystemExit verbosity "sh" $ - "configure" - : configureArgs backwardsCompatHack flags - where backwardsCompatHack = True - -copyAction :: CopyFlags -> [String] -> IO () -copyAction flags args = do - noExtraFlags args - let destArgs = case fromFlag $ copyDest flags of - NoCopyDest -> ["install"] - CopyTo path -> ["copy", "destdir=" ++ path] - CopyToDb _ -> error "CopyToDb not supported via Make" - - rawSystemExit (fromFlag $ copyVerbosity flags) "make" destArgs - -installAction :: InstallFlags -> [String] -> IO () -installAction flags args = do - noExtraFlags args - rawSystemExit (fromFlag $ installVerbosity flags) "make" ["install"] - rawSystemExit (fromFlag $ installVerbosity flags) "make" ["register"] - -haddockAction :: HaddockFlags -> [String] -> IO () -haddockAction flags args = do - noExtraFlags args - rawSystemExit (fromFlag $ haddockVerbosity flags) "make" ["docs"] - `catchIO` \_ -> - rawSystemExit (fromFlag $ haddockVerbosity flags) "make" ["doc"] - -buildAction :: BuildFlags -> [String] -> IO () -buildAction flags args = do - noExtraFlags args - rawSystemExit (fromFlag $ buildVerbosity flags) "make" [] - -cleanAction :: CleanFlags -> [String] -> IO () -cleanAction flags args = do - noExtraFlags args - rawSystemExit (fromFlag $ cleanVerbosity flags) "make" ["clean"] - -sdistAction :: SDistFlags -> [String] -> IO () -sdistAction flags args = do - noExtraFlags args - rawSystemExit (fromFlag $ sDistVerbosity flags) "make" ["dist"] - -registerAction :: RegisterFlags -> [String] -> IO () -registerAction flags args = do - noExtraFlags args - rawSystemExit (fromFlag $ regVerbosity flags) "make" ["register"] - -unregisterAction :: RegisterFlags -> [String] -> IO () -unregisterAction flags args = do - noExtraFlags args - rawSystemExit (fromFlag $ regVerbosity flags) "make" ["unregister"] diff --git a/cabal/Cabal/Distribution/ModuleName.hs b/cabal/Cabal/Distribution/ModuleName.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/ModuleName.hs +++ /dev/null @@ -1,131 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE ScopedTypeVariables #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.ModuleName --- Copyright : Duncan Coutts 2008 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Data type for Haskell module names. - -module Distribution.ModuleName ( - ModuleName, - fromString, - fromComponents, - components, - toFilePath, - main, - -- * Internal - validModuleComponent, - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Utils.ShortText (ShortText, fromShortText, toShortText) -import System.FilePath (pathSeparator) - -import qualified Distribution.Compat.CharParsing as P -import qualified Distribution.Compat.DList as DList -import qualified Text.PrettyPrint as Disp - --- | A valid Haskell module name. --- -newtype ModuleName = ModuleName ShortText - deriving (Eq, Generic, Ord, Read, Show, Typeable, Data) - -unModuleName :: ModuleName -> String -unModuleName (ModuleName s) = fromShortText s - -instance Binary ModuleName -instance Structured ModuleName - -instance NFData ModuleName where - rnf (ModuleName ms) = rnf ms - -instance Pretty ModuleName where - pretty = Disp.text . unModuleName - -instance Parsec ModuleName where - parsec = parsecModuleName - -parsecModuleName :: forall m. CabalParsing m => m ModuleName -parsecModuleName = state0 DList.empty where - upper :: m Char - !upper = P.satisfy isUpper - - ch :: m Char - !ch = P.satisfy (\c -> validModuleChar c || c == '.') - - alt :: m ModuleName -> m ModuleName -> m ModuleName - !alt = (<|>) - - state0 :: DList.DList Char -> m ModuleName - state0 acc = do - c <- upper - state1 (DList.snoc acc c) - - state1 :: DList.DList Char -> m ModuleName - state1 acc = state1' acc `alt` return (fromString (DList.toList acc)) - - state1' :: DList.DList Char -> m ModuleName - state1' acc = do - c <- ch - case c of - '.' -> state0 (DList.snoc acc c) - _ -> state1 (DList.snoc acc c) - -validModuleChar :: Char -> Bool -validModuleChar c = isAlphaNum c || c == '_' || c == '\'' - -validModuleComponent :: String -> Bool -validModuleComponent [] = False -validModuleComponent (c:cs) = isUpper c && all validModuleChar cs - --- | Construct a 'ModuleName' from a valid module name 'String'. --- --- This is just a convenience function intended for valid module strings. It is --- an error if it is used with a string that is not a valid module name. If you --- are parsing user input then use 'Distribution.Text.simpleParse' instead. --- -instance IsString ModuleName where - fromString = ModuleName . toShortText - --- | Construct a 'ModuleName' from valid module components, i.e. parts --- separated by dots. -fromComponents :: [String] -> ModuleName -fromComponents comps = fromString (intercalate "." comps) -{-# DEPRECATED fromComponents "Exists for cabal-install only" #-} - --- | The module name @Main@. --- -main :: ModuleName -main = ModuleName (fromString "Main") - --- | The individual components of a hierarchical module name. For example --- --- > components (fromString "A.B.C") = ["A", "B", "C"] --- -components :: ModuleName -> [String] -components mn = split (unModuleName mn) - where - split cs = case break (=='.') cs of - (chunk,[]) -> chunk : [] - (chunk,_:rest) -> chunk : split rest - --- | Convert a module name to a file path, but without any file extension. --- For example: --- --- > toFilePath (fromString "A.B.C") = "A/B/C" --- -toFilePath :: ModuleName -> FilePath -toFilePath = map f . unModuleName where - f '.' = pathSeparator - f c = c diff --git a/cabal/Cabal/Distribution/Package.hs b/cabal/Cabal/Distribution/Package.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Package.hs +++ /dev/null @@ -1,96 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Package --- Copyright : Isaac Jones 2003-2004 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Defines a package identifier along with a parser and pretty printer for it. --- 'PackageIdentifier's consist of a name and an exact version. It also defines --- a 'Dependency' data type. A dependency is a package name and a version --- range, like @\"foo >= 1.2 && < 2\"@. - -module Distribution.Package - ( module Distribution.Types.AbiHash - , module Distribution.Types.ComponentId - , module Distribution.Types.PackageId - , module Distribution.Types.UnitId - , module Distribution.Types.Module - , module Distribution.Types.PackageName - , module Distribution.Types.PkgconfigName - , module Distribution.Types.Dependency - , Package(..), packageName, packageVersion - , HasMungedPackageId(..), mungedName', mungedVersion' - , HasUnitId(..) - , PackageInstalled(..) - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Version - ( Version ) - -import Distribution.Types.AbiHash -import Distribution.Types.ComponentId -import Distribution.Types.Dependency -import Distribution.Types.MungedPackageId -import Distribution.Types.PackageId -import Distribution.Types.UnitId -import Distribution.Types.Module -import Distribution.Types.MungedPackageName -import Distribution.Types.PackageName -import Distribution.Types.PkgconfigName - --- | Class of things that have a 'PackageIdentifier' --- --- Types in this class are all notions of a package. This allows us to have --- different types for the different phases that packages go though, from --- simple name\/id, package description, configured or installed packages. --- --- Not all kinds of packages can be uniquely identified by a --- 'PackageIdentifier'. In particular, installed packages cannot, there may be --- many installed instances of the same source package. --- -class Package pkg where - packageId :: pkg -> PackageIdentifier - -mungedName' :: HasMungedPackageId pkg => pkg -> MungedPackageName -mungedName' = mungedName . mungedId - -mungedVersion' :: HasMungedPackageId munged => munged -> Version -mungedVersion' = mungedVersion . mungedId - -class HasMungedPackageId pkg where - mungedId :: pkg -> MungedPackageId - -instance Package PackageIdentifier where - packageId = id - -packageName :: Package pkg => pkg -> PackageName -packageName = pkgName . packageId - -packageVersion :: Package pkg => pkg -> Version -packageVersion = pkgVersion . packageId - -instance HasMungedPackageId MungedPackageId where - mungedId = id - --- | Packages that have an installed unit ID -class Package pkg => HasUnitId pkg where - installedUnitId :: pkg -> UnitId - --- | Class of installed packages. --- --- The primary data type which is an instance of this package is --- 'InstalledPackageInfo', but when we are doing install plans in Cabal install --- we may have other, installed package-like things which contain more metadata. --- Installed packages have exact dependencies 'installedDepends'. -class (HasUnitId pkg) => PackageInstalled pkg where - installedDepends :: pkg -> [UnitId] diff --git a/cabal/Cabal/Distribution/PackageDescription.hs b/cabal/Cabal/Distribution/PackageDescription.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/PackageDescription.hs +++ /dev/null @@ -1,100 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE NoMonoLocalBinds #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.PackageDescription --- Copyright : Isaac Jones 2003-2005 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Backwards compatibility reexport of most things you need to know --- about @.cabal@ files. - -module Distribution.PackageDescription ( - -- * PD and GPD - module Distribution.Types.PackageDescription, - module Distribution.Types.GenericPackageDescription, - -- * Components - module Distribution.Types.ComponentName, - -- ** Library - module Distribution.Types.Library, - module Distribution.Types.LibraryName, - module Distribution.Types.LibraryVisibility, - -- ** Executable - module Distribution.Types.Executable, - module Distribution.Types.ExecutableScope, - -- ** TestSuite - module Distribution.Types.TestSuite, - module Distribution.Types.TestType, - module Distribution.Types.TestSuiteInterface, - -- ** Benchmark - module Distribution.Types.Benchmark, - module Distribution.Types.BenchmarkType, - module Distribution.Types.BenchmarkInterface, - -- ** Foreign library - module Distribution.Types.ForeignLib, - module Distribution.Types.ForeignLibType, - module Distribution.Types.ForeignLibOption, - -- * BuildInfo - module Distribution.Types.BuildType, - module Distribution.Types.BuildInfo, - module Distribution.Types.HookedBuildInfo, - module Distribution.Types.SetupBuildInfo, - -- * Flags - module Distribution.Types.Flag, - -- * Identifiers - module Distribution.Types.PackageId, - module Distribution.Types.PackageName, - module Distribution.Types.UnqualComponentName, - -- * Dependencies - module Distribution.Types.Dependency, - module Distribution.Types.ExeDependency, - module Distribution.Types.LegacyExeDependency, - module Distribution.Types.PkgconfigDependency, - -- * Condition trees - module Distribution.Types.CondTree, - module Distribution.Types.Condition, - module Distribution.Types.ConfVar, - -- * Source repository - module Distribution.Types.SourceRepo, - ) where - -import Prelude () ---import Distribution.Compat.Prelude - -import Distribution.Types.Benchmark -import Distribution.Types.BenchmarkInterface -import Distribution.Types.BenchmarkType -import Distribution.Types.BuildInfo -import Distribution.Types.BuildType -import Distribution.Types.ComponentName -import Distribution.Types.Condition -import Distribution.Types.CondTree -import Distribution.Types.ConfVar -import Distribution.Types.Dependency -import Distribution.Types.Executable -import Distribution.Types.ExecutableScope -import Distribution.Types.ExeDependency -import Distribution.Types.Flag -import Distribution.Types.ForeignLib -import Distribution.Types.ForeignLibOption -import Distribution.Types.ForeignLibType -import Distribution.Types.GenericPackageDescription -import Distribution.Types.HookedBuildInfo -import Distribution.Types.LegacyExeDependency -import Distribution.Types.Library -import Distribution.Types.LibraryName -import Distribution.Types.LibraryVisibility -import Distribution.Types.PackageDescription -import Distribution.Types.PackageId -import Distribution.Types.PackageName -import Distribution.Types.PkgconfigDependency -import Distribution.Types.SetupBuildInfo -import Distribution.Types.SourceRepo -import Distribution.Types.TestSuite -import Distribution.Types.TestSuiteInterface -import Distribution.Types.TestType -import Distribution.Types.UnqualComponentName diff --git a/cabal/Cabal/Distribution/PackageDescription/Check.hs b/cabal/Cabal/Distribution/PackageDescription/Check.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/PackageDescription/Check.hs +++ /dev/null @@ -1,2113 +0,0 @@ -{-# LANGUAGE NoMonoLocalBinds #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.PackageDescription.Check --- Copyright : Lennart Kolmodin 2008 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This has code for checking for various problems in packages. There is one --- set of checks that just looks at a 'PackageDescription' in isolation and --- another set of checks that also looks at files in the package. Some of the --- checks are basic sanity checks, others are portability standards that we'd --- like to encourage. There is a 'PackageCheck' type that distinguishes the --- different kinds of check so we can see which ones are appropriate to report --- in different situations. This code gets uses when configuring a package when --- we consider only basic problems. The higher standard is uses when --- preparing a source tarball and by Hackage when uploading new packages. The --- reason for this is that we want to hold packages that are expected to be --- distributed to a higher standard than packages that are only ever expected --- to be used on the author's own environment. - -module Distribution.PackageDescription.Check ( - -- * Package Checking - PackageCheck(..), - checkPackage, - checkConfiguredPackage, - - -- ** Checking package contents - checkPackageFiles, - checkPackageContent, - CheckPackageContentOps(..), - checkPackageFileNames, - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Data.List (group) -import Distribution.CabalSpecVersion -import Distribution.Compat.Lens -import Distribution.Compiler -import Distribution.License -import Distribution.Package -import Distribution.PackageDescription -import Distribution.PackageDescription.Configuration -import Distribution.Pretty (prettyShow) -import Distribution.Simple.BuildPaths (autogenPathsModuleName) -import Distribution.Simple.BuildToolDepends -import Distribution.Simple.CCompiler -import Distribution.Simple.Glob -import Distribution.Simple.Utils hiding (findPackageDesc, notice) -import Distribution.System -import Distribution.Types.ComponentRequestedSpec -import Distribution.Types.ModuleReexport -import Distribution.Utils.Generic (isAscii) -import Distribution.Verbosity -import Distribution.Version -import Language.Haskell.Extension -import System.FilePath - (splitDirectories, splitExtension, splitPath, takeExtension, takeFileName, (<.>), ()) - -import qualified Data.ByteString.Lazy as BS -import qualified Data.Map as Map -import qualified Distribution.Compat.DList as DList -import qualified Distribution.SPDX as SPDX -import qualified System.Directory as System - -import qualified System.Directory (getDirectoryContents) -import qualified System.FilePath.Windows as FilePath.Windows (isValid) - -import qualified Data.Set as Set -import qualified Distribution.Utils.ShortText as ShortText - -import qualified Distribution.Types.BuildInfo.Lens as L -import qualified Distribution.Types.GenericPackageDescription.Lens as L -import qualified Distribution.Types.PackageDescription.Lens as L - --- | Results of some kind of failed package check. --- --- There are a range of severities, from merely dubious to totally insane. --- All of them come with a human readable explanation. In future we may augment --- them with more machine readable explanations, for example to help an IDE --- suggest automatic corrections. --- -data PackageCheck = - - -- | This package description is no good. There's no way it's going to - -- build sensibly. This should give an error at configure time. - PackageBuildImpossible { explanation :: String } - - -- | A problem that is likely to affect building the package, or an - -- issue that we'd like every package author to be aware of, even if - -- the package is never distributed. - | PackageBuildWarning { explanation :: String } - - -- | An issue that might not be a problem for the package author but - -- might be annoying or detrimental when the package is distributed to - -- users. We should encourage distributed packages to be free from these - -- issues, but occasionally there are justifiable reasons so we cannot - -- ban them entirely. - | PackageDistSuspicious { explanation :: String } - - -- | Like PackageDistSuspicious but will only display warnings - -- rather than causing abnormal exit when you run 'cabal check'. - | PackageDistSuspiciousWarn { explanation :: String } - - -- | An issue that is OK in the author's environment but is almost - -- certain to be a portability problem for other environments. We can - -- quite legitimately refuse to publicly distribute packages with these - -- problems. - | PackageDistInexcusable { explanation :: String } - deriving (Eq, Ord) - -instance Show PackageCheck where - show notice = explanation notice - -check :: Bool -> PackageCheck -> Maybe PackageCheck -check False _ = Nothing -check True pc = Just pc - -checkSpecVersion :: PackageDescription -> CabalSpecVersion -> Bool -> PackageCheck - -> Maybe PackageCheck -checkSpecVersion pkg specver cond pc - | specVersion pkg >= specver = Nothing - | otherwise = check cond pc - --- ------------------------------------------------------------ --- * Standard checks --- ------------------------------------------------------------ - --- | Check for common mistakes and problems in package descriptions. --- --- This is the standard collection of checks covering all aspects except --- for checks that require looking at files within the package. For those --- see 'checkPackageFiles'. --- --- It requires the 'GenericPackageDescription' and optionally a particular --- configuration of that package. If you pass 'Nothing' then we just check --- a version of the generic description using 'flattenPackageDescription'. --- -checkPackage :: GenericPackageDescription - -> Maybe PackageDescription - -> [PackageCheck] -checkPackage gpkg mpkg = - checkConfiguredPackage pkg - ++ checkConditionals gpkg - ++ checkPackageVersions gpkg - ++ checkDevelopmentOnlyFlags gpkg - ++ checkFlagNames gpkg - ++ checkUnusedFlags gpkg - ++ checkUnicodeXFields gpkg - ++ checkPathsModuleExtensions pkg - where - pkg = fromMaybe (flattenPackageDescription gpkg) mpkg - ---TODO: make this variant go away --- we should always know the GenericPackageDescription -checkConfiguredPackage :: PackageDescription -> [PackageCheck] -checkConfiguredPackage pkg = - checkSanity pkg - ++ checkFields pkg - ++ checkLicense pkg - ++ checkSourceRepos pkg - ++ checkAllGhcOptions pkg - ++ checkCCOptions pkg - ++ checkCxxOptions pkg - ++ checkCPPOptions pkg - ++ checkPaths pkg - ++ checkCabalVersion pkg - - --- ------------------------------------------------------------ --- * Basic sanity checks --- ------------------------------------------------------------ - --- | Check that this package description is sane. --- -checkSanity :: PackageDescription -> [PackageCheck] -checkSanity pkg = - catMaybes [ - - check (null . unPackageName . packageName $ pkg) $ - PackageBuildImpossible "No 'name' field." - - , check (nullVersion == packageVersion pkg) $ - PackageBuildImpossible "No 'version' field." - - , check (all ($ pkg) [ null . executables - , null . testSuites - , null . benchmarks - , null . allLibraries - , null . foreignLibs ]) $ - PackageBuildImpossible - "No executables, libraries, tests, or benchmarks found. Nothing to do." - - , check (any (== LMainLibName) (map libName $ subLibraries pkg)) $ - PackageBuildImpossible $ "Found one or more unnamed internal libraries. " - ++ "Only the non-internal library can have the same name as the package." - - , check (not (null duplicateNames)) $ - PackageBuildImpossible $ "Duplicate sections: " - ++ commaSep (map unUnqualComponentName duplicateNames) - ++ ". The name of every library, executable, test suite," - ++ " and benchmark section in" - ++ " the package must be unique." - - -- NB: but it's OK for executables to have the same name! - -- TODO shouldn't need to compare on the string level - , check (any (== prettyShow (packageName pkg)) (prettyShow <$> subLibNames)) $ - PackageBuildImpossible $ "Illegal internal library name " - ++ prettyShow (packageName pkg) - ++ ". Internal libraries cannot have the same name as the package." - ++ " Maybe you wanted a non-internal library?" - ++ " If so, rewrite the section stanza" - ++ " from 'library: '" ++ prettyShow (packageName pkg) ++ "' to 'library'." - ] - --TODO: check for name clashes case insensitively: windows file systems cannot - --cope. - - ++ concatMap (checkLibrary pkg) (allLibraries pkg) - ++ concatMap (checkExecutable pkg) (executables pkg) - ++ concatMap (checkTestSuite pkg) (testSuites pkg) - ++ concatMap (checkBenchmark pkg) (benchmarks pkg) - - where - -- The public 'library' gets special dispensation, because it - -- is common practice to export a library and name the executable - -- the same as the package. - subLibNames = mapMaybe (libraryNameString . libName) $ subLibraries pkg - exeNames = map exeName $ executables pkg - testNames = map testName $ testSuites pkg - bmNames = map benchmarkName $ benchmarks pkg - duplicateNames = dups $ subLibNames ++ exeNames ++ testNames ++ bmNames - -checkLibrary :: PackageDescription -> Library -> [PackageCheck] -checkLibrary pkg lib = - catMaybes [ - - check (not (null moduleDuplicates)) $ - PackageBuildImpossible $ - "Duplicate modules in library: " - ++ commaSep (map prettyShow moduleDuplicates) - - -- TODO: This check is bogus if a required-signature was passed through - , check (null (explicitLibModules lib) && null (reexportedModules lib)) $ - PackageDistSuspiciousWarn $ - showLibraryName (libName lib) ++ " does not expose any modules" - - -- check use of signatures sections - , checkVersion CabalSpecV2_0 (not (null (signatures lib))) $ - PackageDistInexcusable $ - "To use the 'signatures' field the package needs to specify " - ++ "at least 'cabal-version: 2.0'." - - -- check that all autogen-modules appear on other-modules or exposed-modules - , check - (not $ and $ map (flip elem (explicitLibModules lib)) (libModulesAutogen lib)) $ - PackageBuildImpossible $ - "An 'autogen-module' is neither on 'exposed-modules' or " - ++ "'other-modules'." - - -- check that all autogen-includes appear on includes or install-includes - , check - (not $ and $ map (flip elem (allExplicitIncludes lib)) (view L.autogenIncludes lib)) $ - PackageBuildImpossible $ - "An include in 'autogen-includes' is neither in 'includes' or " - ++ "'install-includes'." - ] - - where - checkVersion :: CabalSpecVersion -> Bool -> PackageCheck -> Maybe PackageCheck - checkVersion ver cond pc - | specVersion pkg >= ver = Nothing - | otherwise = check cond pc - - -- TODO: not sure if this check is always right in Backpack - moduleDuplicates = dups (explicitLibModules lib ++ - map moduleReexportName (reexportedModules lib)) - -allExplicitIncludes :: L.HasBuildInfo a => a -> [FilePath] -allExplicitIncludes x = view L.includes x ++ view L.installIncludes x - -checkExecutable :: PackageDescription -> Executable -> [PackageCheck] -checkExecutable pkg exe = - catMaybes [ - - check (null (modulePath exe)) $ - PackageBuildImpossible $ - "No 'main-is' field found for executable " ++ prettyShow (exeName exe) - - , check (not (null (modulePath exe)) - && (not $ fileExtensionSupportedLanguage $ modulePath exe)) $ - PackageBuildImpossible $ - "The 'main-is' field must specify a '.hs' or '.lhs' file " - ++ "(even if it is generated by a preprocessor), " - ++ "or it may specify a C/C++/obj-C source file." - - , checkSpecVersion pkg CabalSpecV1_18 - (fileExtensionSupportedLanguage (modulePath exe) - && takeExtension (modulePath exe) `notElem` [".hs", ".lhs"]) $ - PackageDistInexcusable $ - "The package uses a C/C++/obj-C source file for the 'main-is' field. " - ++ "To use this feature you must specify 'cabal-version: >= 1.18'." - - , check (not (null moduleDuplicates)) $ - PackageBuildImpossible $ - "Duplicate modules in executable '" ++ prettyShow (exeName exe) ++ "': " - ++ commaSep (map prettyShow moduleDuplicates) - - -- check that all autogen-modules appear on other-modules - , check - (not $ and $ map (flip elem (exeModules exe)) (exeModulesAutogen exe)) $ - PackageBuildImpossible $ - "On executable '" ++ prettyShow (exeName exe) ++ "' an 'autogen-module' is not " - ++ "on 'other-modules'" - - -- check that all autogen-includes appear on includes - , check - (not $ and $ map (flip elem (view L.includes exe)) (view L.autogenIncludes exe)) $ - PackageBuildImpossible "An include in 'autogen-includes' is not in 'includes'." - ] - where - moduleDuplicates = dups (exeModules exe) - -checkTestSuite :: PackageDescription -> TestSuite -> [PackageCheck] -checkTestSuite pkg test = - catMaybes [ - - case testInterface test of - TestSuiteUnsupported tt@(TestTypeUnknown _ _) -> Just $ - PackageBuildWarning $ - quote (prettyShow tt) ++ " is not a known type of test suite. " - ++ "The known test suite types are: " - ++ commaSep (map prettyShow knownTestTypes) - - TestSuiteUnsupported tt -> Just $ - PackageBuildWarning $ - quote (prettyShow tt) ++ " is not a supported test suite version. " - ++ "The known test suite types are: " - ++ commaSep (map prettyShow knownTestTypes) - _ -> Nothing - - , check (not $ null moduleDuplicates) $ - PackageBuildImpossible $ - "Duplicate modules in test suite '" ++ prettyShow (testName test) ++ "': " - ++ commaSep (map prettyShow moduleDuplicates) - - , check mainIsWrongExt $ - PackageBuildImpossible $ - "The 'main-is' field must specify a '.hs' or '.lhs' file " - ++ "(even if it is generated by a preprocessor), " - ++ "or it may specify a C/C++/obj-C source file." - - , checkSpecVersion pkg CabalSpecV1_18 (mainIsNotHsExt && not mainIsWrongExt) $ - PackageDistInexcusable $ - "The package uses a C/C++/obj-C source file for the 'main-is' field. " - ++ "To use this feature you must specify 'cabal-version: >= 1.18'." - - -- check that all autogen-modules appear on other-modules - , check - (not $ and $ map (flip elem (testModules test)) (testModulesAutogen test)) $ - PackageBuildImpossible $ - "On test suite '" ++ prettyShow (testName test) ++ "' an 'autogen-module' is not " - ++ "on 'other-modules'" - - -- check that all autogen-includes appear on includes - , check - (not $ and $ map (flip elem (view L.includes test)) (view L.autogenIncludes test)) $ - PackageBuildImpossible "An include in 'autogen-includes' is not in 'includes'." - ] - where - moduleDuplicates = dups $ testModules test - - mainIsWrongExt = case testInterface test of - TestSuiteExeV10 _ f -> not $ fileExtensionSupportedLanguage f - _ -> False - - mainIsNotHsExt = case testInterface test of - TestSuiteExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"] - _ -> False - -checkBenchmark :: PackageDescription -> Benchmark -> [PackageCheck] -checkBenchmark _pkg bm = - catMaybes [ - - case benchmarkInterface bm of - BenchmarkUnsupported tt@(BenchmarkTypeUnknown _ _) -> Just $ - PackageBuildWarning $ - quote (prettyShow tt) ++ " is not a known type of benchmark. " - ++ "The known benchmark types are: " - ++ commaSep (map prettyShow knownBenchmarkTypes) - - BenchmarkUnsupported tt -> Just $ - PackageBuildWarning $ - quote (prettyShow tt) ++ " is not a supported benchmark version. " - ++ "The known benchmark types are: " - ++ commaSep (map prettyShow knownBenchmarkTypes) - _ -> Nothing - - , check (not $ null moduleDuplicates) $ - PackageBuildImpossible $ - "Duplicate modules in benchmark '" ++ prettyShow (benchmarkName bm) ++ "': " - ++ commaSep (map prettyShow moduleDuplicates) - - , check mainIsWrongExt $ - PackageBuildImpossible $ - "The 'main-is' field must specify a '.hs' or '.lhs' file " - ++ "(even if it is generated by a preprocessor)." - - -- check that all autogen-modules appear on other-modules - , check - (not $ and $ map (flip elem (benchmarkModules bm)) (benchmarkModulesAutogen bm)) $ - PackageBuildImpossible $ - "On benchmark '" ++ prettyShow (benchmarkName bm) ++ "' an 'autogen-module' is " - ++ "not on 'other-modules'" - - -- check that all autogen-includes appear on includes - , check - (not $ and $ map (flip elem (view L.includes bm)) (view L.autogenIncludes bm)) $ - PackageBuildImpossible "An include in 'autogen-includes' is not in 'includes'." - ] - where - moduleDuplicates = dups $ benchmarkModules bm - - mainIsWrongExt = case benchmarkInterface bm of - BenchmarkExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"] - _ -> False - --- ------------------------------------------------------------ --- * Additional pure checks --- ------------------------------------------------------------ - -checkFields :: PackageDescription -> [PackageCheck] -checkFields pkg = - catMaybes [ - - check (not . FilePath.Windows.isValid . prettyShow . packageName $ pkg) $ - PackageDistInexcusable $ - "Unfortunately, the package name '" ++ prettyShow (packageName pkg) - ++ "' is one of the reserved system file names on Windows. Many tools " - ++ "need to convert package names to file names so using this name " - ++ "would cause problems." - - , check ((isPrefixOf "z-") . prettyShow . packageName $ pkg) $ - PackageDistInexcusable $ - "Package names with the prefix 'z-' are reserved by Cabal and " - ++ "cannot be used." - - , check (isNothing (buildTypeRaw pkg) && specVersion pkg < CabalSpecV2_2) $ - PackageBuildWarning $ - "No 'build-type' specified. If you do not need a custom Setup.hs or " - ++ "./configure script then use 'build-type: Simple'." - - , check (isJust (setupBuildInfo pkg) && buildType pkg /= Custom) $ - PackageBuildWarning $ - "Ignoring the 'custom-setup' section because the 'build-type' is " - ++ "not 'Custom'. Use 'build-type: Custom' if you need to use a " - ++ "custom Setup.hs script." - - , check (not (null unknownCompilers)) $ - PackageBuildWarning $ - "Unknown compiler " ++ commaSep (map quote unknownCompilers) - ++ " in 'tested-with' field." - - , check (not (null unknownLanguages)) $ - PackageBuildWarning $ - "Unknown languages: " ++ commaSep unknownLanguages - - , check (not (null unknownExtensions)) $ - PackageBuildWarning $ - "Unknown extensions: " ++ commaSep unknownExtensions - - , check (not (null languagesUsedAsExtensions)) $ - PackageBuildWarning $ - "Languages listed as extensions: " - ++ commaSep languagesUsedAsExtensions - ++ ". Languages must be specified in either the 'default-language' " - ++ " or the 'other-languages' field." - - , check (not (null ourDeprecatedExtensions)) $ - PackageDistSuspicious $ - "Deprecated extensions: " - ++ commaSep (map (quote . prettyShow . fst) ourDeprecatedExtensions) - ++ ". " ++ unwords - [ "Instead of '" ++ prettyShow ext - ++ "' use '" ++ prettyShow replacement ++ "'." - | (ext, Just replacement) <- ourDeprecatedExtensions ] - - , check (ShortText.null (category pkg)) $ - PackageDistSuspicious "No 'category' field." - - , check (ShortText.null (maintainer pkg)) $ - PackageDistSuspicious "No 'maintainer' field." - - , check (ShortText.null (synopsis pkg) && ShortText.null (description pkg)) $ - PackageDistInexcusable "No 'synopsis' or 'description' field." - - , check (ShortText.null (description pkg) && not (ShortText.null (synopsis pkg))) $ - PackageDistSuspicious "No 'description' field." - - , check (ShortText.null (synopsis pkg) && not (ShortText.null (description pkg))) $ - PackageDistSuspicious "No 'synopsis' field." - - --TODO: recommend the bug reports URL, author and homepage fields - --TODO: recommend not using the stability field - --TODO: recommend specifying a source repo - - , check (ShortText.length (synopsis pkg) >= 80) $ - PackageDistSuspicious - "The 'synopsis' field is rather long (max 80 chars is recommended)." - - -- See also https://github.com/haskell/cabal/pull/3479 - , check (not (ShortText.null (description pkg)) - && ShortText.length (description pkg) <= ShortText.length (synopsis pkg)) $ - PackageDistSuspicious $ - "The 'description' field should be longer than the 'synopsis' " - ++ "field. " - ++ "It's useful to provide an informative 'description' to allow " - ++ "Haskell programmers who have never heard about your package to " - ++ "understand the purpose of your package. " - ++ "The 'description' field content is typically shown by tooling " - ++ "(e.g. 'cabal info', Haddock, Hackage) below the 'synopsis' which " - ++ "serves as a headline. " - ++ "Please refer to " - ++ " for more details." - - -- check use of impossible constraints "tested-with: GHC== 6.10 && ==6.12" - , check (not (null testedWithImpossibleRanges)) $ - PackageDistInexcusable $ - "Invalid 'tested-with' version range: " - ++ commaSep (map prettyShow testedWithImpossibleRanges) - ++ ". To indicate that you have tested a package with multiple " - ++ "different versions of the same compiler use multiple entries, " - ++ "for example 'tested-with: GHC==6.10.4, GHC==6.12.3' and not " - ++ "'tested-with: GHC==6.10.4 && ==6.12.3'." - - , check (not (null depInternalLibraryWithExtraVersion)) $ - PackageBuildWarning $ - "The package has an extraneous version range for a dependency on an " - ++ "internal library: " - ++ commaSep (map prettyShow depInternalLibraryWithExtraVersion) - ++ ". This version range includes the current package but isn't needed " - ++ "as the current package's library will always be used." - - , check (not (null depInternalLibraryWithImpossibleVersion)) $ - PackageBuildImpossible $ - "The package has an impossible version range for a dependency on an " - ++ "internal library: " - ++ commaSep (map prettyShow depInternalLibraryWithImpossibleVersion) - ++ ". This version range does not include the current package, and must " - ++ "be removed as the current package's library will always be used." - - , check (not (null depInternalExecutableWithExtraVersion)) $ - PackageBuildWarning $ - "The package has an extraneous version range for a dependency on an " - ++ "internal executable: " - ++ commaSep (map prettyShow depInternalExecutableWithExtraVersion) - ++ ". This version range includes the current package but isn't needed " - ++ "as the current package's executable will always be used." - - , check (not (null depInternalExecutableWithImpossibleVersion)) $ - PackageBuildImpossible $ - "The package has an impossible version range for a dependency on an " - ++ "internal executable: " - ++ commaSep (map prettyShow depInternalExecutableWithImpossibleVersion) - ++ ". This version range does not include the current package, and must " - ++ "be removed as the current package's executable will always be used." - - , check (not (null depMissingInternalExecutable)) $ - PackageBuildImpossible $ - "The package depends on a missing internal executable: " - ++ commaSep (map prettyShow depInternalExecutableWithImpossibleVersion) - ] - where - unknownCompilers = [ name | (OtherCompiler name, _) <- testedWith pkg ] - unknownLanguages = [ name | bi <- allBuildInfo pkg - , UnknownLanguage name <- allLanguages bi ] - unknownExtensions = [ name | bi <- allBuildInfo pkg - , UnknownExtension name <- allExtensions bi - , name `notElem` map prettyShow knownLanguages ] - ourDeprecatedExtensions = nub $ catMaybes - [ find ((==ext) . fst) deprecatedExtensions - | bi <- allBuildInfo pkg - , ext <- allExtensions bi ] - languagesUsedAsExtensions = - [ name | bi <- allBuildInfo pkg - , UnknownExtension name <- allExtensions bi - , name `elem` map prettyShow knownLanguages ] - - testedWithImpossibleRanges = - [ Dependency (mkPackageName (prettyShow compiler)) vr mainLibSet - | (compiler, vr) <- testedWith pkg - , isNoVersion vr ] - - internalLibraries = - map (maybe (packageName pkg) (unqualComponentNameToPackageName) . libraryNameString . libName) - (allLibraries pkg) - - internalExecutables = map exeName $ executables pkg - - internalLibDeps = - [ dep - | bi <- allBuildInfo pkg - , dep@(Dependency name _ _) <- targetBuildDepends bi - , name `elem` internalLibraries - ] - - internalExeDeps = - [ dep - | bi <- allBuildInfo pkg - , dep <- getAllToolDependencies pkg bi - , isInternal pkg dep - ] - - depInternalLibraryWithExtraVersion = - [ dep - | dep@(Dependency _ versionRange _) <- internalLibDeps - , not $ isAnyVersion versionRange - , packageVersion pkg `withinRange` versionRange - ] - - depInternalLibraryWithImpossibleVersion = - [ dep - | dep@(Dependency _ versionRange _) <- internalLibDeps - , not $ packageVersion pkg `withinRange` versionRange - ] - - depInternalExecutableWithExtraVersion = - [ dep - | dep@(ExeDependency _ _ versionRange) <- internalExeDeps - , not $ isAnyVersion versionRange - , packageVersion pkg `withinRange` versionRange - ] - - depInternalExecutableWithImpossibleVersion = - [ dep - | dep@(ExeDependency _ _ versionRange) <- internalExeDeps - , not $ packageVersion pkg `withinRange` versionRange - ] - - depMissingInternalExecutable = - [ dep - | dep@(ExeDependency _ eName _) <- internalExeDeps - , not $ eName `elem` internalExecutables - ] - - -checkLicense :: PackageDescription -> [PackageCheck] -checkLicense pkg = case licenseRaw pkg of - Right l -> checkOldLicense pkg l - Left l -> checkNewLicense pkg l - -checkNewLicense :: PackageDescription -> SPDX.License -> [PackageCheck] -checkNewLicense _pkg lic = catMaybes - [ check (lic == SPDX.NONE) $ - PackageDistInexcusable - "The 'license' field is missing or is NONE." - ] - -checkOldLicense :: PackageDescription -> License -> [PackageCheck] -checkOldLicense pkg lic = catMaybes - [ check (lic == UnspecifiedLicense) $ - PackageDistInexcusable - "The 'license' field is missing." - - , check (lic == AllRightsReserved) $ - PackageDistSuspicious - "The 'license' is AllRightsReserved. Is that really what you want?" - - , checkVersion CabalSpecV1_4 (lic `notElem` compatLicenses) $ - PackageDistInexcusable $ - "Unfortunately the license " ++ quote (prettyShow (license pkg)) - ++ " messes up the parser in earlier Cabal versions so you need to " - ++ "specify 'cabal-version: >= 1.4'. Alternatively if you require " - ++ "compatibility with earlier Cabal versions then use 'OtherLicense'." - - , case lic of - UnknownLicense l -> Just $ - PackageBuildWarning $ - quote ("license: " ++ l) ++ " is not a recognised license. The " - ++ "known licenses are: " - ++ commaSep (map prettyShow knownLicenses) - _ -> Nothing - - , check (lic == BSD4) $ - PackageDistSuspicious $ - "Using 'license: BSD4' is almost always a misunderstanding. 'BSD4' " - ++ "refers to the old 4-clause BSD license with the advertising " - ++ "clause. 'BSD3' refers the new 3-clause BSD license." - - , case unknownLicenseVersion (lic) of - Just knownVersions -> Just $ - PackageDistSuspicious $ - "'license: " ++ prettyShow (lic) ++ "' is not a known " - ++ "version of that license. The known versions are " - ++ commaSep (map prettyShow knownVersions) - ++ ". If this is not a mistake and you think it should be a known " - ++ "version then please file a ticket." - _ -> Nothing - - , check (lic `notElem` [ AllRightsReserved - , UnspecifiedLicense, PublicDomain] - -- AllRightsReserved and PublicDomain are not strictly - -- licenses so don't need license files. - && null (licenseFiles pkg)) $ - PackageDistSuspicious "A 'license-file' is not specified." - ] - where - unknownLicenseVersion (GPL (Just v)) - | v `notElem` knownVersions = Just knownVersions - where knownVersions = [ v' | GPL (Just v') <- knownLicenses ] - unknownLicenseVersion (LGPL (Just v)) - | v `notElem` knownVersions = Just knownVersions - where knownVersions = [ v' | LGPL (Just v') <- knownLicenses ] - unknownLicenseVersion (AGPL (Just v)) - | v `notElem` knownVersions = Just knownVersions - where knownVersions = [ v' | AGPL (Just v') <- knownLicenses ] - unknownLicenseVersion (Apache (Just v)) - | v `notElem` knownVersions = Just knownVersions - where knownVersions = [ v' | Apache (Just v') <- knownLicenses ] - unknownLicenseVersion _ = Nothing - - checkVersion :: CabalSpecVersion -> Bool -> PackageCheck -> Maybe PackageCheck - checkVersion ver cond pc - | specVersion pkg >= ver = Nothing - | otherwise = check cond pc - - compatLicenses = [ GPL Nothing, LGPL Nothing, AGPL Nothing, BSD3, BSD4 - , PublicDomain, AllRightsReserved - , UnspecifiedLicense, OtherLicense ] - -checkSourceRepos :: PackageDescription -> [PackageCheck] -checkSourceRepos pkg = - catMaybes $ concat [[ - - case repoKind repo of - RepoKindUnknown kind -> Just $ PackageDistInexcusable $ - quote kind ++ " is not a recognised kind of source-repository. " - ++ "The repo kind is usually 'head' or 'this'" - _ -> Nothing - - , check (isNothing (repoType repo)) $ - PackageDistInexcusable - "The source-repository 'type' is a required field." - - , check (isNothing (repoLocation repo)) $ - PackageDistInexcusable - "The source-repository 'location' is a required field." - - , check (repoType repo == Just (KnownRepoType CVS) && isNothing (repoModule repo)) $ - PackageDistInexcusable - "For a CVS source-repository, the 'module' is a required field." - - , check (repoKind repo == RepoThis && isNothing (repoTag repo)) $ - PackageDistInexcusable $ - "For the 'this' kind of source-repository, the 'tag' is a required " - ++ "field. It should specify the tag corresponding to this version " - ++ "or release of the package." - - , check (maybe False isAbsoluteOnAnyPlatform (repoSubdir repo)) $ - PackageDistInexcusable - "The 'subdir' field of a source-repository must be a relative path." - ] - | repo <- sourceRepos pkg ] - ---TODO: check location looks like a URL for some repo types. - --- | Checks GHC options from all ghc-*-options fields in the given --- PackageDescription and reports commonly misused or non-portable flags -checkAllGhcOptions :: PackageDescription -> [PackageCheck] -checkAllGhcOptions pkg = - checkGhcOptions "ghc-options" (hcOptions GHC) pkg - ++ checkGhcOptions "ghc-prof-options" (hcProfOptions GHC) pkg - ++ checkGhcOptions "ghc-shared-options" (hcSharedOptions GHC) pkg - --- | Extracts GHC options belonging to the given field from the given --- PackageDescription using given function and checks them for commonly misused --- or non-portable flags -checkGhcOptions :: String -> (BuildInfo -> [String]) -> PackageDescription -> [PackageCheck] -checkGhcOptions fieldName getOptions pkg = - catMaybes [ - - checkFlags ["-fasm"] $ - PackageDistInexcusable $ - "'" ++ fieldName ++ ": -fasm' is unnecessary and will not work on CPU " - ++ "architectures other than x86, x86-64, ppc or sparc." - - , checkFlags ["-fvia-C"] $ - PackageDistSuspicious $ - "'" ++ fieldName ++": -fvia-C' is usually unnecessary. If your package " - ++ "needs -via-C for correctness rather than performance then it " - ++ "is using the FFI incorrectly and will probably not work with GHC " - ++ "6.10 or later." - - , checkFlags ["-fhpc"] $ - PackageDistInexcusable $ - "'" ++ fieldName ++ ": -fhpc' is not necessary. Use the configure flag " - ++ " --enable-coverage instead." - - , checkFlags ["-prof"] $ - PackageBuildWarning $ - "'" ++ fieldName ++ ": -prof' is not necessary and will lead to problems " - ++ "when used on a library. Use the configure flag " - ++ "--enable-library-profiling and/or --enable-profiling." - - , checkFlags ["-o"] $ - PackageBuildWarning $ - "'" ++ fieldName ++ ": -o' is not needed. " - ++ "The output files are named automatically." - - , checkFlags ["-hide-package"] $ - PackageBuildWarning $ - "'" ++ fieldName ++ ": -hide-package' is never needed. " - ++ "Cabal hides all packages." - - , checkFlags ["--make"] $ - PackageBuildWarning $ - "'" ++ fieldName ++ ": --make' is never needed. Cabal uses this automatically." - - , checkFlags ["-main-is"] $ - PackageDistSuspicious $ - "'" ++ fieldName ++ ": -main-is' is not portable." - - , checkNonTestAndBenchmarkFlags ["-O0", "-Onot"] $ - PackageDistSuspicious $ - "'" ++ fieldName ++ ": -O0' is not needed. " - ++ "Use the --disable-optimization configure flag." - - , checkTestAndBenchmarkFlags ["-O0", "-Onot"] $ - PackageDistSuspiciousWarn $ - "'" ++ fieldName ++ ": -O0' is not needed. " - ++ "Use the --disable-optimization configure flag." - - , checkFlags [ "-O", "-O1"] $ - PackageDistInexcusable $ - "'" ++ fieldName ++ ": -O' is not needed. " - ++ "Cabal automatically adds the '-O' flag. " - ++ "Setting it yourself interferes with the --disable-optimization flag." - - , checkFlags ["-O2"] $ - PackageDistSuspiciousWarn $ - "'" ++ fieldName ++ ": -O2' is rarely needed. " - ++ "Check that it is giving a real benefit " - ++ "and not just imposing longer compile times on your users." - - , checkFlags ["-split-sections"] $ - PackageBuildWarning $ - "'" ++ fieldName ++ ": -split-sections' is not needed. " - ++ "Use the --enable-split-sections configure flag." - - , checkFlags ["-split-objs"] $ - PackageBuildWarning $ - "'" ++ fieldName ++ ": -split-objs' is not needed. " - ++ "Use the --enable-split-objs configure flag." - - , checkFlags ["-optl-Wl,-s", "-optl-s"] $ - PackageDistInexcusable $ - "'" ++ fieldName ++ ": -optl-Wl,-s' is not needed and is not portable to all" - ++ " operating systems. Cabal 1.4 and later automatically strip" - ++ " executables. Cabal also has a flag --disable-executable-stripping" - ++ " which is necessary when building packages for some Linux" - ++ " distributions and using '-optl-Wl,-s' prevents that from working." - - , checkFlags ["-fglasgow-exts"] $ - PackageDistSuspicious $ - "Instead of '" ++ fieldName ++ ": -fglasgow-exts' it is preferable to use " - ++ "the 'extensions' field." - - , check ("-threaded" `elem` lib_ghc_options) $ - PackageBuildWarning $ - "'" ++ fieldName ++ ": -threaded' has no effect for libraries. It should " - ++ "only be used for executables." - - , check ("-rtsopts" `elem` lib_ghc_options) $ - PackageBuildWarning $ - "'" ++ fieldName ++ ": -rtsopts' has no effect for libraries. It should " - ++ "only be used for executables." - - , check (any (\opt -> "-with-rtsopts" `isPrefixOf` opt) lib_ghc_options) $ - PackageBuildWarning $ - "'" ++ fieldName ++ ": -with-rtsopts' has no effect for libraries. It " - ++ "should only be used for executables." - - , checkAlternatives fieldName "extensions" - [ (flag, prettyShow extension) | flag <- all_ghc_options - , Just extension <- [ghcExtension flag] ] - - , checkAlternatives fieldName "extensions" - [ (flag, extension) | flag@('-':'X':extension) <- all_ghc_options ] - - , checkAlternatives fieldName "cpp-options" $ - [ (flag, flag) | flag@('-':'D':_) <- all_ghc_options ] - ++ [ (flag, flag) | flag@('-':'U':_) <- all_ghc_options ] - - , checkAlternatives fieldName "include-dirs" - [ (flag, dir) | flag@('-':'I':dir) <- all_ghc_options ] - - , checkAlternatives fieldName "extra-libraries" - [ (flag, lib) | flag@('-':'l':lib) <- all_ghc_options ] - - , checkAlternatives fieldName "extra-lib-dirs" - [ (flag, dir) | flag@('-':'L':dir) <- all_ghc_options ] - - , checkAlternatives fieldName "frameworks" - [ (flag, fmwk) | (flag@"-framework", fmwk) <- - zip all_ghc_options (safeTail all_ghc_options) ] - - , checkAlternatives fieldName "extra-framework-dirs" - [ (flag, dir) | (flag@"-framework-path", dir) <- - zip all_ghc_options (safeTail all_ghc_options) ] - ] - - where - all_ghc_options = concatMap getOptions (allBuildInfo pkg) - lib_ghc_options = concatMap (getOptions . libBuildInfo) - (allLibraries pkg) - test_ghc_options = concatMap (getOptions . testBuildInfo) - (testSuites pkg) - benchmark_ghc_options = concatMap (getOptions . benchmarkBuildInfo) - (benchmarks pkg) - test_and_benchmark_ghc_options = test_ghc_options ++ - benchmark_ghc_options - non_test_and_benchmark_ghc_options = concatMap getOptions - (allBuildInfo (pkg { testSuites = [] - , benchmarks = [] - })) - - checkFlags :: [String] -> PackageCheck -> Maybe PackageCheck - checkFlags flags = check (any (`elem` flags) all_ghc_options) - - checkTestAndBenchmarkFlags :: [String] -> PackageCheck -> Maybe PackageCheck - checkTestAndBenchmarkFlags flags = check (any (`elem` flags) test_and_benchmark_ghc_options) - - checkNonTestAndBenchmarkFlags :: [String] -> PackageCheck -> Maybe PackageCheck - checkNonTestAndBenchmarkFlags flags = check (any (`elem` flags) non_test_and_benchmark_ghc_options) - - ghcExtension ('-':'f':name) = case name of - "allow-overlapping-instances" -> enable OverlappingInstances - "no-allow-overlapping-instances" -> disable OverlappingInstances - "th" -> enable TemplateHaskell - "no-th" -> disable TemplateHaskell - "ffi" -> enable ForeignFunctionInterface - "no-ffi" -> disable ForeignFunctionInterface - "fi" -> enable ForeignFunctionInterface - "no-fi" -> disable ForeignFunctionInterface - "monomorphism-restriction" -> enable MonomorphismRestriction - "no-monomorphism-restriction" -> disable MonomorphismRestriction - "mono-pat-binds" -> enable MonoPatBinds - "no-mono-pat-binds" -> disable MonoPatBinds - "allow-undecidable-instances" -> enable UndecidableInstances - "no-allow-undecidable-instances" -> disable UndecidableInstances - "allow-incoherent-instances" -> enable IncoherentInstances - "no-allow-incoherent-instances" -> disable IncoherentInstances - "arrows" -> enable Arrows - "no-arrows" -> disable Arrows - "generics" -> enable Generics - "no-generics" -> disable Generics - "implicit-prelude" -> enable ImplicitPrelude - "no-implicit-prelude" -> disable ImplicitPrelude - "implicit-params" -> enable ImplicitParams - "no-implicit-params" -> disable ImplicitParams - "bang-patterns" -> enable BangPatterns - "no-bang-patterns" -> disable BangPatterns - "scoped-type-variables" -> enable ScopedTypeVariables - "no-scoped-type-variables" -> disable ScopedTypeVariables - "extended-default-rules" -> enable ExtendedDefaultRules - "no-extended-default-rules" -> disable ExtendedDefaultRules - _ -> Nothing - ghcExtension "-cpp" = enable CPP - ghcExtension _ = Nothing - - enable e = Just (EnableExtension e) - disable e = Just (DisableExtension e) - -checkCCOptions :: PackageDescription -> [PackageCheck] -checkCCOptions = checkCLikeOptions "C" "cc-options" ccOptions - -checkCxxOptions :: PackageDescription -> [PackageCheck] -checkCxxOptions = checkCLikeOptions "C++" "cxx-options" cxxOptions - -checkCLikeOptions :: String -> String -> (BuildInfo -> [String]) -> PackageDescription -> [PackageCheck] -checkCLikeOptions label prefix accessor pkg = - catMaybes [ - - checkAlternatives prefix "include-dirs" - [ (flag, dir) | flag@('-':'I':dir) <- all_cLikeOptions ] - - , checkAlternatives prefix "extra-libraries" - [ (flag, lib) | flag@('-':'l':lib) <- all_cLikeOptions ] - - , checkAlternatives prefix "extra-lib-dirs" - [ (flag, dir) | flag@('-':'L':dir) <- all_cLikeOptions ] - - , checkAlternatives "ld-options" "extra-libraries" - [ (flag, lib) | flag@('-':'l':lib) <- all_ldOptions ] - - , checkAlternatives "ld-options" "extra-lib-dirs" - [ (flag, dir) | flag@('-':'L':dir) <- all_ldOptions ] - - , checkCCFlags [ "-O", "-Os", "-O0", "-O1", "-O2", "-O3" ] $ - PackageDistSuspicious $ - "'"++prefix++": -O[n]' is generally not needed. When building with " - ++ " optimisations Cabal automatically adds '-O2' for "++label++" code. " - ++ "Setting it yourself interferes with the --disable-optimization flag." - ] - - where all_cLikeOptions = [ opts | bi <- allBuildInfo pkg - , opts <- accessor bi ] - all_ldOptions = [ opts | bi <- allBuildInfo pkg - , opts <- ldOptions bi ] - - checkCCFlags :: [String] -> PackageCheck -> Maybe PackageCheck - checkCCFlags flags = check (any (`elem` flags) all_cLikeOptions) - -checkCPPOptions :: PackageDescription -> [PackageCheck] -checkCPPOptions pkg = catMaybes - [ checkAlternatives "cpp-options" "include-dirs" - [ (flag, dir) | flag@('-':'I':dir) <- all_cppOptions ] - ] - ++ - [ PackageBuildWarning $ "'cpp-options': " ++ opt ++ " is not portable C-preprocessor flag" - | opt <- all_cppOptions - -- "-I" is handled above, we allow only -DNEWSTUFF and -UOLDSTUFF - , not $ any (`isPrefixOf` opt) ["-D", "-U", "-I" ] - ] - where - all_cppOptions = [ opts | bi <- allBuildInfo pkg, opts <- cppOptions bi ] - -checkAlternatives :: String -> String -> [(String, String)] - -> Maybe PackageCheck -checkAlternatives badField goodField flags = - check (not (null badFlags)) $ - PackageBuildWarning $ - "Instead of " ++ quote (badField ++ ": " ++ unwords badFlags) - ++ " use " ++ quote (goodField ++ ": " ++ unwords goodFlags) - - where (badFlags, goodFlags) = unzip flags - -checkPaths :: PackageDescription -> [PackageCheck] -checkPaths pkg = - [ PackageBuildWarning $ - quote (kind ++ ": " ++ path) - ++ " is a relative path outside of the source tree. " - ++ "This will not work when generating a tarball with 'sdist'." - | (path, kind) <- relPaths ++ absPaths - , isOutsideTree path ] - ++ - [ PackageDistInexcusable $ - quote (kind ++ ": " ++ path) ++ " is an absolute path." - | (path, kind) <- relPaths - , isAbsoluteOnAnyPlatform path ] - ++ - [ PackageDistInexcusable $ - quote (kind ++ ": " ++ path) ++ " points inside the 'dist' " - ++ "directory. This is not reliable because the location of this " - ++ "directory is configurable by the user (or package manager). In " - ++ "addition the layout of the 'dist' directory is subject to change " - ++ "in future versions of Cabal." - | (path, kind) <- relPaths ++ absPaths - , isInsideDist path ] - ++ - [ PackageDistInexcusable $ - "The 'ghc-options' contains the path '" ++ path ++ "' which points " - ++ "inside the 'dist' directory. This is not reliable because the " - ++ "location of this directory is configurable by the user (or package " - ++ "manager). In addition the layout of the 'dist' directory is subject " - ++ "to change in future versions of Cabal." - | bi <- allBuildInfo pkg - , (GHC, flags) <- perCompilerFlavorToList $ options bi - , path <- flags - , isInsideDist path ] - ++ - [ PackageDistInexcusable $ - "In the 'data-files' field: " ++ explainGlobSyntaxError pat err - | pat <- dataFiles pkg - , Left err <- [parseFileGlob (specVersion pkg) pat] - ] - ++ - [ PackageDistInexcusable $ - "In the 'extra-source-files' field: " ++ explainGlobSyntaxError pat err - | pat <- extraSrcFiles pkg - , Left err <- [parseFileGlob (specVersion pkg) pat] - ] - ++ - [ PackageDistInexcusable $ - "In the 'extra-doc-files' field: " ++ explainGlobSyntaxError pat err - | pat <- extraDocFiles pkg - , Left err <- [parseFileGlob (specVersion pkg) pat] - ] - where - isOutsideTree path = case splitDirectories path of - "..":_ -> True - ".":"..":_ -> True - _ -> False - isInsideDist path = case map lowercase (splitDirectories path) of - "dist" :_ -> True - ".":"dist":_ -> True - _ -> False - -- paths that must be relative - relPaths = - [ (path, "extra-source-files") | path <- extraSrcFiles pkg ] - ++ [ (path, "extra-tmp-files") | path <- extraTmpFiles pkg ] - ++ [ (path, "extra-doc-files") | path <- extraDocFiles pkg ] - ++ [ (path, "data-files") | path <- dataFiles pkg ] - ++ [ (path, "data-dir") | path <- [dataDir pkg]] - ++ [ (path, "license-file") | path <- licenseFiles pkg ] - ++ concat - [ [ (path, "asm-sources") | path <- asmSources bi ] - ++ [ (path, "cmm-sources") | path <- cmmSources bi ] - ++ [ (path, "c-sources") | path <- cSources bi ] - ++ [ (path, "cxx-sources") | path <- cxxSources bi ] - ++ [ (path, "js-sources") | path <- jsSources bi ] - ++ [ (path, "install-includes") | path <- installIncludes bi ] - ++ [ (path, "hs-source-dirs") | path <- hsSourceDirs bi ] - | bi <- allBuildInfo pkg ] - -- paths that are allowed to be absolute - absPaths = concat - [ [ (path, "includes") | path <- includes bi ] - ++ [ (path, "include-dirs") | path <- includeDirs bi ] - ++ [ (path, "extra-lib-dirs") | path <- extraLibDirs bi ] - | bi <- allBuildInfo pkg ] - ---TODO: check sets of paths that would be interpreted differently between Unix --- and windows, ie case-sensitive or insensitive. Things that might clash, or --- conversely be distinguished. - ---TODO: use the tar path checks on all the above paths - --- | Check that the package declares the version in the @\"cabal-version\"@ --- field correctly. --- -checkCabalVersion :: PackageDescription -> [PackageCheck] -checkCabalVersion pkg = - catMaybes [ - - -- check use of test suite sections - checkVersion CabalSpecV1_8 (not (null $ testSuites pkg)) $ - PackageDistInexcusable $ - "The 'test-suite' section is new in Cabal 1.10. " - ++ "Unfortunately it messes up the parser in older Cabal versions " - ++ "so you must specify at least 'cabal-version: >= 1.8', but note " - ++ "that only Cabal 1.10 and later can actually run such test suites." - - -- check use of default-language field - -- note that we do not need to do an equivalent check for the - -- other-language field since that one does not change behaviour - , checkVersion CabalSpecV1_10 (any isJust (buildInfoField defaultLanguage)) $ - PackageBuildWarning $ - "To use the 'default-language' field the package needs to specify " - ++ "at least 'cabal-version: >= 1.10'." - - , check (specVersion pkg >= CabalSpecV1_10 && specVersion pkg < CabalSpecV3_4 - && (any isNothing (buildInfoField defaultLanguage))) $ - PackageBuildWarning $ - "Packages using 'cabal-version: >= 1.10' and before 'cabal-version: 3.4' must specify the " - ++ "'default-language' field for each component (e.g. Haskell98 or " - ++ "Haskell2010). If a component uses different languages in " - ++ "different modules then list the other ones in the " - ++ "'other-languages' field." - - , checkVersion CabalSpecV1_18 - (not . null $ extraDocFiles pkg) $ - PackageDistInexcusable $ - "To use the 'extra-doc-files' field the package needs to specify " - ++ "at least 'cabal-version: >= 1.18'." - - , checkVersion CabalSpecV2_0 - (not (null (subLibraries pkg))) $ - PackageDistInexcusable $ - "To use multiple 'library' sections or a named library section " - ++ "the package needs to specify at least 'cabal-version: 2.0'." - - -- check use of reexported-modules sections - , checkVersion CabalSpecV1_22 - (any (not.null.reexportedModules) (allLibraries pkg)) $ - PackageDistInexcusable $ - "To use the 'reexported-module' field the package needs to specify " - ++ "at least 'cabal-version: >= 1.22'." - - -- check use of thinning and renaming - , checkVersion CabalSpecV2_0 usesBackpackIncludes $ - PackageDistInexcusable $ - "To use the 'mixins' field the package needs to specify " - ++ "at least 'cabal-version: 2.0'." - - -- check use of 'extra-framework-dirs' field - , checkVersion CabalSpecV1_24 (any (not . null) (buildInfoField extraFrameworkDirs)) $ - -- Just a warning, because this won't break on old Cabal versions. - PackageDistSuspiciousWarn $ - "To use the 'extra-framework-dirs' field the package needs to specify" - ++ " at least 'cabal-version: >= 1.24'." - - -- check use of default-extensions field - -- don't need to do the equivalent check for other-extensions - , checkVersion CabalSpecV1_10 (any (not . null) (buildInfoField defaultExtensions)) $ - PackageBuildWarning $ - "To use the 'default-extensions' field the package needs to specify " - ++ "at least 'cabal-version: >= 1.10'." - - -- check use of extensions field - , check (specVersion pkg >= CabalSpecV1_10 - && (any (not . null) (buildInfoField oldExtensions))) $ - PackageBuildWarning $ - "For packages using 'cabal-version: >= 1.10' the 'extensions' " - ++ "field is deprecated. The new 'default-extensions' field lists " - ++ "extensions that are used in all modules in the component, while " - ++ "the 'other-extensions' field lists extensions that are used in " - ++ "some modules, e.g. via the {-# LANGUAGE #-} pragma." - - , checkVersion CabalSpecV3_0 (any (not . null) - (concatMap buildInfoField - [ asmSources - , cmmSources - , extraBundledLibs - , extraLibFlavours ])) $ - PackageDistInexcusable $ - "The use of 'asm-sources', 'cmm-sources', 'extra-bundled-libraries' " - ++ " and 'extra-library-flavours' requires the package " - ++ " to specify at least 'cabal-version: 3.0'." - - , checkVersion CabalSpecV3_0 (any (not . null) $ buildInfoField extraDynLibFlavours) $ - PackageDistInexcusable $ - "The use of 'extra-dynamic-library-flavours' requires the package " - ++ " to specify at least 'cabal-version: 3.0'. The flavours are: " - ++ commaSep [ flav - | flavs <- buildInfoField extraDynLibFlavours - , flav <- flavs ] - - , checkVersion CabalSpecV2_2 (any (not . null) - (buildInfoField virtualModules)) $ - PackageDistInexcusable $ - "The use of 'virtual-modules' requires the package " - ++ " to specify at least 'cabal-version: 2.2'." - - -- check use of "source-repository" section - , checkVersion CabalSpecV1_6 (not (null (sourceRepos pkg))) $ - PackageDistInexcusable $ - "The 'source-repository' section is new in Cabal 1.6. " - ++ "Unfortunately it messes up the parser in earlier Cabal versions " - ++ "so you need to specify 'cabal-version: >= 1.6'." - - -- check for new language extensions - , checkVersion CabalSpecV1_4 (not (null mentionedExtensionsThatNeedCabal12)) $ - PackageDistInexcusable $ - "Unfortunately the language extensions " - ++ commaSep (map (quote . prettyShow) mentionedExtensionsThatNeedCabal12) - ++ " break the parser in earlier Cabal versions so you need to " - ++ "specify 'cabal-version: >= 1.4'. Alternatively if you require " - ++ "compatibility with earlier Cabal versions then you may be able to " - ++ "use an equivalent compiler-specific flag." - - , checkVersion CabalSpecV1_4 (not (null mentionedExtensionsThatNeedCabal14)) $ - PackageDistInexcusable $ - "Unfortunately the language extensions " - ++ commaSep (map (quote . prettyShow) mentionedExtensionsThatNeedCabal14) - ++ " break the parser in earlier Cabal versions so you need to " - ++ "specify 'cabal-version: >= 1.4'. Alternatively if you require " - ++ "compatibility with earlier Cabal versions then you may be able to " - ++ "use an equivalent compiler-specific flag." - - , check (specVersion pkg >= CabalSpecV1_24 - && isNothing (setupBuildInfo pkg) - && buildType pkg == Custom) $ - PackageBuildWarning $ - "Packages using 'cabal-version: >= 1.24' with 'build-type: Custom' " - ++ "must use a 'custom-setup' section with a 'setup-depends' field " - ++ "that specifies the dependencies of the Setup.hs script itself. " - ++ "The 'setup-depends' field uses the same syntax as 'build-depends', " - ++ "so a simple example would be 'setup-depends: base, Cabal'." - - , check (specVersion pkg < CabalSpecV1_24 - && isNothing (setupBuildInfo pkg) - && buildType pkg == Custom) $ - PackageDistSuspiciousWarn $ - "From version 1.24 cabal supports specifying explicit dependencies " - ++ "for Custom setup scripts. Consider using cabal-version >= 1.24 and " - ++ "adding a 'custom-setup' section with a 'setup-depends' field " - ++ "that specifies the dependencies of the Setup.hs script itself. " - ++ "The 'setup-depends' field uses the same syntax as 'build-depends', " - ++ "so a simple example would be 'setup-depends: base, Cabal'." - - , check (specVersion pkg >= CabalSpecV2_0 - && elem (autogenPathsModuleName pkg) allModuleNames - && not (elem (autogenPathsModuleName pkg) allModuleNamesAutogen) ) $ - PackageDistInexcusable $ - "Packages using 'cabal-version: 2.0' and the autogenerated " - ++ "module Paths_* must include it also on the 'autogen-modules' field " - ++ "besides 'exposed-modules' and 'other-modules'. This specifies that " - ++ "the module does not come with the package and is generated on " - ++ "setup. Modules built with a custom Setup.hs script also go here " - ++ "to ensure that commands like sdist don't fail." - - ] - where - -- Perform a check on packages that use a version of the spec less than - -- the version given. This is for cases where a new Cabal version adds - -- a new feature and we want to check that it is not used prior to that - -- version. - checkVersion :: CabalSpecVersion -> Bool -> PackageCheck -> Maybe PackageCheck - checkVersion ver cond pc - | specVersion pkg >= ver = Nothing - | otherwise = check cond pc - - buildInfoField field = map field (allBuildInfo pkg) - - usesBackpackIncludes = any (not . null . mixins) (allBuildInfo pkg) - - mentionedExtensions = [ ext | bi <- allBuildInfo pkg - , ext <- allExtensions bi ] - mentionedExtensionsThatNeedCabal12 = - nub (filter (`elem` compatExtensionsExtra) mentionedExtensions) - - -- As of Cabal-1.4 we can add new extensions without worrying about - -- breaking old versions of cabal. - mentionedExtensionsThatNeedCabal14 = - nub (filter (`notElem` compatExtensions) mentionedExtensions) - - -- The known extensions in Cabal-1.2.3 - compatExtensions = - map EnableExtension - [ OverlappingInstances, UndecidableInstances, IncoherentInstances - , RecursiveDo, ParallelListComp, MultiParamTypeClasses - , FunctionalDependencies, Rank2Types - , RankNTypes, PolymorphicComponents, ExistentialQuantification - , ScopedTypeVariables, ImplicitParams, FlexibleContexts - , FlexibleInstances, EmptyDataDecls, CPP, BangPatterns - , TypeSynonymInstances, TemplateHaskell, ForeignFunctionInterface - , Arrows, Generics, NamedFieldPuns, PatternGuards - , GeneralizedNewtypeDeriving, ExtensibleRecords, RestrictedTypeSynonyms - , HereDocuments] ++ - map DisableExtension - [MonomorphismRestriction, ImplicitPrelude] ++ - compatExtensionsExtra - - -- The extra known extensions in Cabal-1.2.3 vs Cabal-1.1.6 - -- (Cabal-1.1.6 came with ghc-6.6. Cabal-1.2 came with ghc-6.8) - compatExtensionsExtra = - map EnableExtension - [ KindSignatures, MagicHash, TypeFamilies, StandaloneDeriving - , UnicodeSyntax, PatternSignatures, UnliftedFFITypes, LiberalTypeSynonyms - , TypeOperators, RecordWildCards, RecordPuns, DisambiguateRecordFields - , OverloadedStrings, GADTs, RelaxedPolyRec - , ExtendedDefaultRules, UnboxedTuples, DeriveDataTypeable - , ConstrainedClassMethods - ] ++ - map DisableExtension - [MonoPatBinds] - - allModuleNames = - (case library pkg of - Nothing -> [] - (Just lib) -> explicitLibModules lib - ) - ++ concatMap otherModules (allBuildInfo pkg) - - allModuleNamesAutogen = concatMap autogenModules (allBuildInfo pkg) - --- ------------------------------------------------------------ --- * Checks on the GenericPackageDescription --- ------------------------------------------------------------ - --- | Check the build-depends fields for any weirdness or bad practice. --- -checkPackageVersions :: GenericPackageDescription -> [PackageCheck] -checkPackageVersions pkg = - catMaybes [ - - -- Check that the version of base is bounded above. - -- For example this bans "build-depends: base >= 3". - -- It should probably be "build-depends: base >= 3 && < 4" - -- which is the same as "build-depends: base == 3.*" - check (not (boundedAbove baseDependency)) $ - PackageDistInexcusable $ - "The dependency 'build-depends: base' does not specify an upper " - ++ "bound on the version number. Each major release of the 'base' " - ++ "package changes the API in various ways and most packages will " - ++ "need some changes to compile with it. The recommended practice " - ++ "is to specify an upper bound on the version of the 'base' " - ++ "package. This ensures your package will continue to build when a " - ++ "new major version of the 'base' package is released. If you are " - ++ "not sure what upper bound to use then use the next major " - ++ "version. For example if you have tested your package with 'base' " - ++ "version 4.5 and 4.6 then use 'build-depends: base >= 4.5 && < 4.7'." - - ] - where - -- TODO: What we really want to do is test if there exists any - -- configuration in which the base version is unbounded above. - -- However that's a bit tricky because there are many possible - -- configurations. As a cheap easy and safe approximation we will - -- pick a single "typical" configuration and check if that has an - -- open upper bound. To get a typical configuration we finalise - -- using no package index and the current platform. - finalised = finalizePD - mempty defaultComponentRequestedSpec (const True) - buildPlatform - (unknownCompilerInfo - (CompilerId buildCompilerFlavor nullVersion) - NoAbiTag) - [] pkg - baseDependency = case finalised of - Right (pkg', _) | not (null baseDeps) -> - foldr intersectVersionRanges anyVersion baseDeps - where - baseDeps = - [ vr | Dependency pname vr _ <- allBuildDepends pkg' - , pname == mkPackageName "base" ] - - -- Just in case finalizePD fails for any reason, - -- or if the package doesn't depend on the base package at all, - -- then we will just skip the check, since boundedAbove noVersion = True - _ -> noVersion - - boundedAbove :: VersionRange -> Bool - boundedAbove vr = case asVersionIntervals vr of - [] -> True -- this is the inconsistent version range. - (x:xs) -> case last (x:|xs) of - (_, UpperBound _ _) -> True - (_, NoUpperBound ) -> False - - -checkConditionals :: GenericPackageDescription -> [PackageCheck] -checkConditionals pkg = - catMaybes [ - - check (not $ null unknownOSs) $ - PackageDistInexcusable $ - "Unknown operating system name " - ++ commaSep (map quote unknownOSs) - - , check (not $ null unknownArches) $ - PackageDistInexcusable $ - "Unknown architecture name " - ++ commaSep (map quote unknownArches) - - , check (not $ null unknownImpls) $ - PackageDistInexcusable $ - "Unknown compiler name " - ++ commaSep (map quote unknownImpls) - ] - where - unknownOSs = [ os | OS (OtherOS os) <- conditions ] - unknownArches = [ arch | Arch (OtherArch arch) <- conditions ] - unknownImpls = [ impl | Impl (OtherCompiler impl) _ <- conditions ] - conditions = concatMap fvs (maybeToList (condLibrary pkg)) - ++ concatMap (fvs . snd) (condSubLibraries pkg) - ++ concatMap (fvs . snd) (condForeignLibs pkg) - ++ concatMap (fvs . snd) (condExecutables pkg) - ++ concatMap (fvs . snd) (condTestSuites pkg) - ++ concatMap (fvs . snd) (condBenchmarks pkg) - fvs (CondNode _ _ ifs) = concatMap compfv ifs -- free variables - compfv (CondBranch c ct mct) = condfv c ++ fvs ct ++ maybe [] fvs mct - condfv c = case c of - Var v -> [v] - Lit _ -> [] - CNot c1 -> condfv c1 - COr c1 c2 -> condfv c1 ++ condfv c2 - CAnd c1 c2 -> condfv c1 ++ condfv c2 - -checkFlagNames :: GenericPackageDescription -> [PackageCheck] -checkFlagNames gpd - | null invalidFlagNames = [] - | otherwise = [ PackageDistInexcusable - $ "Suspicious flag names: " ++ unwords invalidFlagNames ++ ". " - ++ "To avoid ambiguity in command line interfaces, flag shouldn't " - ++ "start with a dash. Also for better compatibility, flag names " - ++ "shouldn't contain non-ascii characters." - ] - where - invalidFlagNames = - [ fn - | flag <- genPackageFlags gpd - , let fn = unFlagName (flagName flag) - , invalidFlagName fn - ] - -- starts with dash - invalidFlagName ('-':_) = True - -- mon ascii letter - invalidFlagName cs = any (not . isAscii) cs - -checkUnusedFlags :: GenericPackageDescription -> [PackageCheck] -checkUnusedFlags gpd - | declared == used = [] - | otherwise = [ PackageDistSuspicious - $ "Declared and used flag sets differ: " - ++ s declared ++ " /= " ++ s used ++ ". " - ] - where - s :: Set.Set FlagName -> String - s = commaSep . map unFlagName . Set.toList - - declared :: Set.Set FlagName - declared = toSetOf (L.genPackageFlags . traverse . L.flagName) gpd - - used :: Set.Set FlagName - used = mconcat - [ toSetOf (L.condLibrary . traverse . traverseCondTreeV . L._PackageFlag) gpd - , toSetOf (L.condSubLibraries . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd - , toSetOf (L.condForeignLibs . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd - , toSetOf (L.condExecutables . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd - , toSetOf (L.condTestSuites . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd - , toSetOf (L.condBenchmarks . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd - ] - -checkUnicodeXFields :: GenericPackageDescription -> [PackageCheck] -checkUnicodeXFields gpd - | null nonAsciiXFields = [] - | otherwise = [ PackageDistInexcusable - $ "Non ascii custom fields: " ++ unwords nonAsciiXFields ++ ". " - ++ "For better compatibility, custom field names " - ++ "shouldn't contain non-ascii characters." - ] - where - nonAsciiXFields :: [String] - nonAsciiXFields = [ n | (n, _) <- xfields, any (not . isAscii) n ] - - xfields :: [(String,String)] - xfields = DList.runDList $ mconcat - [ toDListOf (L.packageDescription . L.customFieldsPD . traverse) gpd - , toDListOf (L.traverseBuildInfos . L.customFieldsBI . traverse) gpd - ] - --- | cabal-version <2.2 + Paths_module + default-extensions: doesn't build. -checkPathsModuleExtensions :: PackageDescription -> [PackageCheck] -checkPathsModuleExtensions pd - | specVersion pd >= CabalSpecV2_2 = [] - | any checkBI (allBuildInfo pd) || any checkLib (allLibraries pd) - = return $ PackageBuildImpossible $ unwords - [ "The package uses RebindableSyntax with OverloadedStrings or OverloadedLists" - , "in default-extensions, and also Paths_ autogen module." - , "That configuration is known to cause compile failures with Cabal < 2.2." - , "To use these default-extensions with Paths_ autogen module" - , "specify at least 'cabal-version: 2.2'." - ] - | otherwise = [] - where - mn = autogenPathsModuleName pd - - checkLib :: Library -> Bool - checkLib l = mn `elem` exposedModules l && checkExts (l ^. L.defaultExtensions) - - checkBI :: BuildInfo -> Bool - checkBI bi = - (mn `elem` otherModules bi || mn `elem` autogenModules bi) && - checkExts (bi ^. L.defaultExtensions) - - checkExts exts = rebind `elem` exts && (strings `elem` exts || lists `elem` exts) - where - rebind = EnableExtension RebindableSyntax - strings = EnableExtension OverloadedStrings - lists = EnableExtension OverloadedLists - --- | Checks GHC options from all ghc-*-options fields from the given BuildInfo --- and reports flags that are OK during development process, but are --- unacceptable in a distrubuted package -checkDevelopmentOnlyFlagsBuildInfo :: BuildInfo -> [PackageCheck] -checkDevelopmentOnlyFlagsBuildInfo bi = - checkDevelopmentOnlyFlagsOptions "ghc-options" (hcOptions GHC bi) - ++ checkDevelopmentOnlyFlagsOptions "ghc-prof-options" (hcProfOptions GHC bi) - ++ checkDevelopmentOnlyFlagsOptions "ghc-shared-options" (hcSharedOptions GHC bi) - --- | Checks the given list of flags belonging to the given field and reports --- flags that are OK during development process, but are unacceptable in a --- distributed package -checkDevelopmentOnlyFlagsOptions :: String -> [String] -> [PackageCheck] -checkDevelopmentOnlyFlagsOptions fieldName ghcOptions = - catMaybes [ - - check has_WerrorWall $ - PackageDistInexcusable $ - "'" ++ fieldName ++ ": -Wall -Werror' makes the package very easy to " - ++ "break with future GHC versions because new GHC versions often " - ++ "add new warnings. Use just '" ++ fieldName ++ ": -Wall' instead." - ++ extraExplanation - - , check (not has_WerrorWall && has_Werror) $ - PackageDistInexcusable $ - "'" ++ fieldName ++ ": -Werror' makes the package easy to " - ++ "break with future GHC versions because new GHC versions often " - ++ "add new warnings. " - ++ extraExplanation - - , check (has_J) $ - PackageDistInexcusable $ - "'" ++ fieldName ++ ": -j[N]' can make sense for specific user's setup," - ++ " but it is not appropriate for a distributed package." - ++ extraExplanation - - , checkFlags ["-fdefer-type-errors"] $ - PackageDistInexcusable $ - "'" ++ fieldName ++ ": -fdefer-type-errors' is fine during development but " - ++ "is not appropriate for a distributed package. " - ++ extraExplanation - - -- -dynamic is not a debug flag - , check (any (\opt -> "-d" `isPrefixOf` opt && opt /= "-dynamic") - ghcOptions) $ - PackageDistInexcusable $ - "'" ++ fieldName ++ ": -d*' debug flags are not appropriate " - ++ "for a distributed package. " - ++ extraExplanation - - , checkFlags ["-fprof-auto", "-fprof-auto-top", "-fprof-auto-calls", - "-fprof-cafs", "-fno-prof-count-entries", - "-auto-all", "-auto", "-caf-all"] $ - PackageDistSuspicious $ - "'" ++ fieldName ++ ": -fprof*' profiling flags are typically not " - ++ "appropriate for a distributed library package. These flags are " - ++ "useful to profile this package, but when profiling other packages " - ++ "that use this one these flags clutter the profile output with " - ++ "excessive detail. If you think other packages really want to see " - ++ "cost centres from this package then use '-fprof-auto-exported' " - ++ "which puts cost centres only on exported functions. " - ++ extraExplanation - ] - where - extraExplanation = - " Alternatively, if you want to use this, make it conditional based " - ++ "on a Cabal configuration flag (with 'manual: True' and 'default: " - ++ "False') and enable that flag during development." - - has_WerrorWall = has_Werror && ( has_Wall || has_W ) - has_Werror = "-Werror" `elem` ghcOptions - has_Wall = "-Wall" `elem` ghcOptions - has_W = "-W" `elem` ghcOptions - has_J = any - (\o -> case o of - "-j" -> True - ('-' : 'j' : d : _) -> isDigit d - _ -> False - ) - ghcOptions - checkFlags :: [String] -> PackageCheck -> Maybe PackageCheck - checkFlags flags = check (any (`elem` flags) ghcOptions) - -checkDevelopmentOnlyFlags :: GenericPackageDescription -> [PackageCheck] -checkDevelopmentOnlyFlags pkg = - concatMap checkDevelopmentOnlyFlagsBuildInfo - [ bi - | (conditions, bi) <- allConditionalBuildInfo - , not (any guardedByManualFlag conditions) ] - where - guardedByManualFlag = definitelyFalse - - -- We've basically got three-values logic here: True, False or unknown - -- hence this pattern to propagate the unknown cases properly. - definitelyFalse (Var (PackageFlag n)) = maybe False not (Map.lookup n manualFlags) - definitelyFalse (Var _) = False - definitelyFalse (Lit b) = not b - definitelyFalse (CNot c) = definitelyTrue c - definitelyFalse (COr c1 c2) = definitelyFalse c1 && definitelyFalse c2 - definitelyFalse (CAnd c1 c2) = definitelyFalse c1 || definitelyFalse c2 - - definitelyTrue (Var (PackageFlag n)) = fromMaybe False (Map.lookup n manualFlags) - definitelyTrue (Var _) = False - definitelyTrue (Lit b) = b - definitelyTrue (CNot c) = definitelyFalse c - definitelyTrue (COr c1 c2) = definitelyTrue c1 || definitelyTrue c2 - definitelyTrue (CAnd c1 c2) = definitelyTrue c1 && definitelyTrue c2 - - manualFlags = Map.fromList - [ (flagName flag, flagDefault flag) - | flag <- genPackageFlags pkg - , flagManual flag ] - - allConditionalBuildInfo :: [([Condition ConfVar], BuildInfo)] - allConditionalBuildInfo = - concatMap (collectCondTreePaths libBuildInfo) - (maybeToList (condLibrary pkg)) - - ++ concatMap (collectCondTreePaths libBuildInfo . snd) - (condSubLibraries pkg) - - ++ concatMap (collectCondTreePaths buildInfo . snd) - (condExecutables pkg) - - ++ concatMap (collectCondTreePaths testBuildInfo . snd) - (condTestSuites pkg) - - ++ concatMap (collectCondTreePaths benchmarkBuildInfo . snd) - (condBenchmarks pkg) - - -- get all the leaf BuildInfo, paired up with the path (in the tree sense) - -- of if-conditions that guard it - collectCondTreePaths :: (a -> b) - -> CondTree v c a - -> [([Condition v], b)] - collectCondTreePaths mapData = go [] - where - go conditions condNode = - -- the data at this level in the tree: - (reverse conditions, mapData (condTreeData condNode)) - - : concat - [ go (condition:conditions) ifThen - | (CondBranch condition ifThen _) <- condTreeComponents condNode ] - - ++ concat - [ go (condition:conditions) elseThen - | (CondBranch condition _ (Just elseThen)) <- condTreeComponents condNode ] - - --- ------------------------------------------------------------ --- * Checks involving files in the package --- ------------------------------------------------------------ - --- | Sanity check things that requires IO. It looks at the files in the --- package and expects to find the package unpacked in at the given file path. --- -checkPackageFiles :: Verbosity -> PackageDescription -> FilePath -> IO [PackageCheck] -checkPackageFiles verbosity pkg root = do - contentChecks <- checkPackageContent checkFilesIO pkg - preDistributionChecks <- checkPackageFilesPreDistribution verbosity pkg root - -- Sort because different platforms will provide files from - -- `getDirectoryContents` in different orders, and we'd like to be - -- stable for test output. - return (sort contentChecks ++ sort preDistributionChecks) - where - checkFilesIO = CheckPackageContentOps { - doesFileExist = System.doesFileExist . relative, - doesDirectoryExist = System.doesDirectoryExist . relative, - getDirectoryContents = System.Directory.getDirectoryContents . relative, - getFileContents = BS.readFile . relative - } - relative path = root path - --- | A record of operations needed to check the contents of packages. --- Used by 'checkPackageContent'. --- -data CheckPackageContentOps m = CheckPackageContentOps { - doesFileExist :: FilePath -> m Bool, - doesDirectoryExist :: FilePath -> m Bool, - getDirectoryContents :: FilePath -> m [FilePath], - getFileContents :: FilePath -> m BS.ByteString - } - --- | Sanity check things that requires looking at files in the package. --- This is a generalised version of 'checkPackageFiles' that can work in any --- monad for which you can provide 'CheckPackageContentOps' operations. --- --- The point of this extra generality is to allow doing checks in some virtual --- file system, for example a tarball in memory. --- -checkPackageContent :: (Monad m, Applicative m) - => CheckPackageContentOps m - -> PackageDescription - -> m [PackageCheck] -checkPackageContent ops pkg = do - cabalBomError <- checkCabalFileBOM ops - cabalNameError <- checkCabalFileName ops pkg - licenseErrors <- checkLicensesExist ops pkg - setupError <- checkSetupExists ops pkg - configureError <- checkConfigureExists ops pkg - localPathErrors <- checkLocalPathsExist ops pkg - vcsLocation <- checkMissingVcsInfo ops pkg - - return $ licenseErrors - ++ catMaybes [cabalBomError, cabalNameError, setupError, configureError] - ++ localPathErrors - ++ vcsLocation - -checkCabalFileBOM :: Monad m => CheckPackageContentOps m - -> m (Maybe PackageCheck) -checkCabalFileBOM ops = do - epdfile <- findPackageDesc ops - case epdfile of - -- MASSIVE HACK. If the Cabal file doesn't exist, that is - -- a very strange situation to be in, because the driver code - -- in 'Distribution.Setup' ought to have noticed already! - -- But this can be an issue, see #3552 and also when - -- --cabal-file is specified. So if you can't find the file, - -- just don't bother with this check. - Left _ -> return $ Nothing - Right pdfile -> (flip check pc . BS.isPrefixOf bomUtf8) - `liftM` (getFileContents ops pdfile) - where pc = PackageDistInexcusable $ - pdfile ++ " starts with an Unicode byte order mark (BOM)." - ++ " This may cause problems with older cabal versions." - - where - bomUtf8 :: BS.ByteString - bomUtf8 = BS.pack [0xef,0xbb,0xbf] -- U+FEFF encoded as UTF8 - -checkCabalFileName :: Monad m => CheckPackageContentOps m - -> PackageDescription - -> m (Maybe PackageCheck) -checkCabalFileName ops pkg = do - -- findPackageDesc already takes care to detect missing/multiple - -- .cabal files; we don't include this check in 'findPackageDesc' in - -- order not to short-cut other checks which call 'findPackageDesc' - epdfile <- findPackageDesc ops - case epdfile of - -- see "MASSIVE HACK" note in 'checkCabalFileBOM' - Left _ -> return Nothing - Right pdfile - | takeFileName pdfile == expectedCabalname -> return Nothing - | otherwise -> return $ Just $ PackageDistInexcusable $ - "The filename " ++ pdfile ++ " does not match package name " ++ - "(expected: " ++ expectedCabalname ++ ")" - where - pkgname = unPackageName . packageName $ pkg - expectedCabalname = pkgname <.> "cabal" - - --- |Find a package description file in the given directory. Looks for --- @.cabal@ files. Like 'Distribution.Simple.Utils.findPackageDesc', --- but generalized over monads. -findPackageDesc :: Monad m => CheckPackageContentOps m - -> m (Either PackageCheck FilePath) -- ^.cabal -findPackageDesc ops - = do let dir = "." - files <- getDirectoryContents ops dir - -- to make sure we do not mistake a ~/.cabal/ dir for a .cabal - -- file we filter to exclude dirs and null base file names: - cabalFiles <- filterM (doesFileExist ops) - [ dir file - | file <- files - , let (name, ext) = splitExtension file - , not (null name) && ext == ".cabal" ] - case cabalFiles of - [] -> return (Left $ PackageBuildImpossible noDesc) - [cabalFile] -> return (Right cabalFile) - multiple -> return (Left $ PackageBuildImpossible - $ multiDesc multiple) - - where - noDesc :: String - noDesc = "No cabal file found.\n" - ++ "Please create a package description file .cabal" - - multiDesc :: [String] -> String - multiDesc l = "Multiple cabal files found while checking.\n" - ++ "Please use only one of: " - ++ intercalate ", " l - -checkLicensesExist :: (Monad m, Applicative m) - => CheckPackageContentOps m - -> PackageDescription - -> m [PackageCheck] -checkLicensesExist ops pkg = do - exists <- traverse (doesFileExist ops) (licenseFiles pkg) - return - [ PackageBuildWarning $ - "The '" ++ fieldname ++ "' field refers to the file " - ++ quote file ++ " which does not exist." - | (file, False) <- zip (licenseFiles pkg) exists ] - where - fieldname | length (licenseFiles pkg) == 1 = "license-file" - | otherwise = "license-files" - -checkSetupExists :: Monad m => CheckPackageContentOps m - -> PackageDescription - -> m (Maybe PackageCheck) -checkSetupExists ops pkg = do - let simpleBuild = buildType pkg == Simple - hsexists <- doesFileExist ops "Setup.hs" - lhsexists <- doesFileExist ops "Setup.lhs" - return $ check (not simpleBuild && not hsexists && not lhsexists) $ - PackageDistInexcusable $ - "The package is missing a Setup.hs or Setup.lhs script." - -checkConfigureExists :: Monad m => CheckPackageContentOps m - -> PackageDescription - -> m (Maybe PackageCheck) -checkConfigureExists ops pd - | buildType pd == Configure = do - exists <- doesFileExist ops "configure" - return $ check (not exists) $ - PackageBuildWarning $ - "The 'build-type' is 'Configure' but there is no 'configure' script. " - ++ "You probably need to run 'autoreconf -i' to generate it." - | otherwise = return Nothing - -checkLocalPathsExist :: Monad m => CheckPackageContentOps m - -> PackageDescription - -> m [PackageCheck] -checkLocalPathsExist ops pkg = do - let dirs = [ (dir, kind) - | bi <- allBuildInfo pkg - , (dir, kind) <- - [ (dir, "extra-lib-dirs") | dir <- extraLibDirs bi ] - ++ [ (dir, "extra-framework-dirs") - | dir <- extraFrameworkDirs bi ] - ++ [ (dir, "include-dirs") | dir <- includeDirs bi ] - ++ [ (dir, "hs-source-dirs") | dir <- hsSourceDirs bi ] - , isRelativeOnAnyPlatform dir ] - missing <- filterM (liftM not . doesDirectoryExist ops . fst) dirs - return [ PackageBuildWarning { - explanation = quote (kind ++ ": " ++ dir) - ++ " directory does not exist." - } - | (dir, kind) <- missing ] - -checkMissingVcsInfo :: (Monad m, Applicative m) - => CheckPackageContentOps m - -> PackageDescription - -> m [PackageCheck] -checkMissingVcsInfo ops pkg | null (sourceRepos pkg) = do - vcsInUse <- liftM or $ traverse (doesDirectoryExist ops) repoDirnames - if vcsInUse - then return [ PackageDistSuspicious message ] - else return [] - where - repoDirnames = [ dirname | repo <- knownRepoTypes - , dirname <- repoTypeDirname repo] - message = "When distributing packages it is encouraged to specify source " - ++ "control information in the .cabal file using one or more " - ++ "'source-repository' sections. See the Cabal user guide for " - ++ "details." - -checkMissingVcsInfo _ _ = return [] - -repoTypeDirname :: KnownRepoType -> [FilePath] -repoTypeDirname Darcs = ["_darcs"] -repoTypeDirname Git = [".git"] -repoTypeDirname SVN = [".svn"] -repoTypeDirname CVS = ["CVS"] -repoTypeDirname Mercurial = [".hg"] -repoTypeDirname GnuArch = [".arch-params"] -repoTypeDirname Bazaar = [".bzr"] -repoTypeDirname Monotone = ["_MTN"] -repoTypeDirname Pijul = [".pijul"] - --- ------------------------------------------------------------ --- * Checks involving files in the package --- ------------------------------------------------------------ - --- | Check the names of all files in a package for portability problems. This --- should be done for example when creating or validating a package tarball. --- -checkPackageFileNames :: [FilePath] -> [PackageCheck] -checkPackageFileNames files = - (take 1 . mapMaybe checkWindowsPath $ files) - ++ (take 1 . mapMaybe checkTarPath $ files) - -- If we get any of these checks triggering then we're likely to get - -- many, and that's probably not helpful, so return at most one. - -checkWindowsPath :: FilePath -> Maybe PackageCheck -checkWindowsPath path = - check (not $ FilePath.Windows.isValid path') $ - PackageDistInexcusable $ - "Unfortunately, the file " ++ quote path ++ " is not a valid file " - ++ "name on Windows which would cause portability problems for this " - ++ "package. Windows file names cannot contain any of the characters " - ++ "\":*?<>|\" and there are a few reserved names including \"aux\", " - ++ "\"nul\", \"con\", \"prn\", \"com1-9\", \"lpt1-9\" and \"clock$\"." - where - path' = ".\\" ++ path - -- force a relative name to catch invalid file names like "f:oo" which - -- otherwise parse as file "oo" in the current directory on the 'f' drive. - --- | Check a file name is valid for the portable POSIX tar format. --- --- The POSIX tar format has a restriction on the length of file names. It is --- unfortunately not a simple restriction like a maximum length. The exact --- restriction is that either the whole path be 100 characters or less, or it --- be possible to split the path on a directory separator such that the first --- part is 155 characters or less and the second part 100 characters or less. --- -checkTarPath :: FilePath -> Maybe PackageCheck -checkTarPath path - | length path > 255 = Just longPath - | otherwise = case pack nameMax (reverse (splitPath path)) of - Left err -> Just err - Right [] -> Nothing - Right (h:rest) -> case pack prefixMax remainder of - Left err -> Just err - Right [] -> Nothing - Right (_:_) -> Just noSplit - where - -- drop the '/' between the name and prefix: - remainder = safeInit h : rest - - where - nameMax, prefixMax :: Int - nameMax = 100 - prefixMax = 155 - - pack _ [] = Left emptyName - pack maxLen (c:cs) - | n > maxLen = Left longName - | otherwise = Right (pack' maxLen n cs) - where n = length c - - pack' maxLen n (c:cs) - | n' <= maxLen = pack' maxLen n' cs - where n' = n + length c - pack' _ _ cs = cs - - longPath = PackageDistInexcusable $ - "The following file name is too long to store in a portable POSIX " - ++ "format tar archive. The maximum length is 255 ASCII characters.\n" - ++ "The file in question is:\n " ++ path - longName = PackageDistInexcusable $ - "The following file name is too long to store in a portable POSIX " - ++ "format tar archive. The maximum length for the name part (including " - ++ "extension) is 100 ASCII characters. The maximum length for any " - ++ "individual directory component is 155.\n" - ++ "The file in question is:\n " ++ path - noSplit = PackageDistInexcusable $ - "The following file name is too long to store in a portable POSIX " - ++ "format tar archive. While the total length is less than 255 ASCII " - ++ "characters, there are unfortunately further restrictions. It has to " - ++ "be possible to split the file path on a directory separator into " - ++ "two parts such that the first part fits in 155 characters or less " - ++ "and the second part fits in 100 characters or less. Basically you " - ++ "have to make the file name or directory names shorter, or you could " - ++ "split a long directory name into nested subdirectories with shorter " - ++ "names.\nThe file in question is:\n " ++ path - emptyName = PackageDistInexcusable $ - "Encountered a file with an empty name, something is very wrong! " - ++ "Files with an empty name cannot be stored in a tar archive or in " - ++ "standard file systems." - --- -------------------------------------------------------------- --- * Checks for missing content and other pre-distribution checks --- -------------------------------------------------------------- - --- | Similar to 'checkPackageContent', 'checkPackageFilesPreDistribution' --- inspects the files included in the package, but is primarily looking for --- files in the working tree that may have been missed or other similar --- problems that can only be detected pre-distribution. --- --- Because Hackage necessarily checks the uploaded tarball, it is too late to --- check these on the server; these checks only make sense in the development --- and package-creation environment. Hence we can use IO, rather than needing --- to pass a 'CheckPackageContentOps' dictionary around. -checkPackageFilesPreDistribution :: Verbosity -> PackageDescription -> FilePath -> IO [PackageCheck] --- Note: this really shouldn't return any 'Inexcusable' warnings, --- because that will make us say that Hackage would reject the package. --- But, because Hackage doesn't run these tests, that will be a lie! -checkPackageFilesPreDistribution = checkGlobFiles - --- | Discover problems with the package's wildcards. -checkGlobFiles :: Verbosity - -> PackageDescription - -> FilePath - -> IO [PackageCheck] -checkGlobFiles verbosity pkg root = - fmap concat $ for allGlobs $ \(field, dir, glob) -> - -- Note: we just skip over parse errors here; they're reported elsewhere. - case parseFileGlob (specVersion pkg) glob of - Left _ -> return [] - Right parsedGlob -> do - results <- runDirFileGlob verbosity (root dir) parsedGlob - let individualWarnings = results >>= getWarning field glob - noMatchesWarning = - [ PackageDistSuspiciousWarn $ - "In '" ++ field ++ "': the pattern '" ++ glob ++ "' does not" - ++ " match any files." - | all (not . suppressesNoMatchesWarning) results - ] - return (noMatchesWarning ++ individualWarnings) - where - adjustedDataDir = if null (dataDir pkg) then "." else dataDir pkg - allGlobs = concat - [ (,,) "extra-source-files" "." <$> extraSrcFiles pkg - , (,,) "extra-doc-files" "." <$> extraDocFiles pkg - , (,,) "data-files" adjustedDataDir <$> dataFiles pkg - ] - - -- If there's a missing directory in play, since our globs don't - -- (currently) support disjunction, that will always mean there are no - -- matches. The no matches error in this case is strictly less informative - -- than the missing directory error, so sit on it. - suppressesNoMatchesWarning (GlobMatch _) = True - suppressesNoMatchesWarning (GlobWarnMultiDot _) = False - suppressesNoMatchesWarning (GlobMissingDirectory _) = True - - getWarning :: String -> FilePath -> GlobResult FilePath -> [PackageCheck] - getWarning _ _ (GlobMatch _) = - [] - -- Before Cabal 2.4, the extensions of globs had to match the file - -- exactly. This has been relaxed in 2.4 to allow matching only the - -- suffix. This warning detects when pre-2.4 package descriptions are - -- omitting files purely because of the stricter check. - getWarning field glob (GlobWarnMultiDot file) = - [ PackageDistSuspiciousWarn $ - "In '" ++ field ++ "': the pattern '" ++ glob ++ "' does not" - ++ " match the file '" ++ file ++ "' because the extensions do not" - ++ " exactly match (e.g., foo.en.html does not exactly match *.html)." - ++ " To enable looser suffix-only matching, set 'cabal-version: 2.4' or higher." - ] - getWarning field glob (GlobMissingDirectory dir) = - [ PackageDistSuspiciousWarn $ - "In '" ++ field ++ "': the pattern '" ++ glob ++ "' attempts to" - ++ " match files in the directory '" ++ dir ++ "', but there is no" - ++ " directory by that name." - ] - --- ------------------------------------------------------------ --- * Utils --- ------------------------------------------------------------ - -quote :: String -> String -quote s = "'" ++ s ++ "'" - -commaSep :: [String] -> String -commaSep = intercalate ", " - -dups :: Ord a => [a] -> [a] -dups xs = [ x | (x:_:_) <- group (sort xs) ] - -fileExtensionSupportedLanguage :: FilePath -> Bool -fileExtensionSupportedLanguage path = - isHaskell || isC - where - extension = takeExtension path - isHaskell = extension `elem` [".hs", ".lhs"] - isC = isJust (filenameCDialect extension) diff --git a/cabal/Cabal/Distribution/PackageDescription/Configuration.hs b/cabal/Cabal/Distribution/PackageDescription/Configuration.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/PackageDescription/Configuration.hs +++ /dev/null @@ -1,600 +0,0 @@ --- -fno-warn-deprecations for use of Map.foldWithKey -{-# OPTIONS_GHC -fno-warn-deprecations #-} -{-# LANGUAGE NoMonoLocalBinds #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.PackageDescription.Configuration --- Copyright : Thomas Schilling, 2007 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This is about the cabal configurations feature. It exports --- 'finalizePD' and 'flattenPackageDescription' which are --- functions for converting 'GenericPackageDescription's down to --- 'PackageDescription's. It has code for working with the tree of conditions --- and resolving or flattening conditions. - -module Distribution.PackageDescription.Configuration ( - finalizePD, - flattenPackageDescription, - - -- Utils - parseCondition, - freeVars, - extractCondition, - extractConditions, - addBuildableCondition, - mapCondTree, - mapTreeData, - mapTreeConds, - mapTreeConstrs, - transformAllBuildInfos, - transformAllBuildDepends, - transformAllBuildDependsN, - ) where - -import Distribution.Compat.Prelude -import Prelude () - --- lens -import qualified Distribution.Types.BuildInfo.Lens as L -import qualified Distribution.Types.GenericPackageDescription.Lens as L -import qualified Distribution.Types.PackageDescription.Lens as L -import qualified Distribution.Types.SetupBuildInfo.Lens as L - -import Distribution.Compat.CharParsing hiding (char) -import qualified Distribution.Compat.CharParsing as P -import Distribution.Compat.Lens -import Distribution.Compiler -import Distribution.PackageDescription -import Distribution.PackageDescription.Utils -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Simple.Utils -import Distribution.System -import Distribution.Types.Component -import Distribution.Types.ComponentRequestedSpec -import Distribution.Types.DependencyMap -import Distribution.Types.PackageVersionConstraint -import Distribution.Version - -import qualified Data.Map.Lazy as Map -import Data.Tree (Tree (Node)) - ------------------------------------------------------------------------------- - --- | Simplify a configuration condition using the OS and arch names. Returns --- the names of all the flags occurring in the condition. -simplifyWithSysParams :: OS -> Arch -> CompilerInfo -> Condition ConfVar - -> (Condition FlagName, [FlagName]) -simplifyWithSysParams os arch cinfo cond = (cond', flags) - where - (cond', flags) = simplifyCondition cond interp - interp (OS os') = Right $ os' == os - interp (Arch arch') = Right $ arch' == arch - interp (Impl comp vr) - | matchImpl (compilerInfoId cinfo) = Right True - | otherwise = case compilerInfoCompat cinfo of - -- fixme: treat Nothing as unknown, rather than empty list once we - -- support partial resolution of system parameters - Nothing -> Right False - Just compat -> Right (any matchImpl compat) - where - matchImpl (CompilerId c v) = comp == c && v `withinRange` vr - interp (PackageFlag f) = Left f - --- TODO: Add instances and check --- --- prop_sC_idempotent cond a o = cond' == cond'' --- where --- cond' = simplifyCondition cond a o --- cond'' = simplifyCondition cond' a o --- --- prop_sC_noLits cond a o = isLit res || not (hasLits res) --- where --- res = simplifyCondition cond a o --- hasLits (Lit _) = True --- hasLits (CNot c) = hasLits c --- hasLits (COr l r) = hasLits l || hasLits r --- hasLits (CAnd l r) = hasLits l || hasLits r --- hasLits _ = False --- - --- | Parse a configuration condition from a string. -parseCondition :: CabalParsing m => m (Condition ConfVar) -parseCondition = condOr - where - condOr = sepByNonEmpty condAnd (oper "||") >>= return . foldl1 COr - condAnd = sepByNonEmpty cond (oper "&&")>>= return . foldl1 CAnd - -- TODO: try? - cond = sp >> (boolLiteral <|> inparens condOr <|> notCond <|> osCond - <|> archCond <|> flagCond <|> implCond ) - inparens = between (P.char '(' >> sp) (sp >> P.char ')' >> sp) - notCond = P.char '!' >> sp >> cond >>= return . CNot - osCond = string "os" >> sp >> inparens osIdent >>= return . Var - archCond = string "arch" >> sp >> inparens archIdent >>= return . Var - flagCond = string "flag" >> sp >> inparens flagIdent >>= return . Var - implCond = string "impl" >> sp >> inparens implIdent >>= return . Var - boolLiteral = fmap Lit parsec - archIdent = fmap Arch parsec - osIdent = fmap OS parsec - flagIdent = fmap (PackageFlag . mkFlagName . lowercase) (munch1 isIdentChar) - isIdentChar c = isAlphaNum c || c == '_' || c == '-' - oper s = sp >> string s >> sp - sp = spaces - implIdent = do i <- parsec - vr <- sp >> option anyVersion parsec - return $ Impl i vr - ------------------------------------------------------------------------------- - --- | Result of dependency test. Isomorphic to @Maybe d@ but renamed for --- clarity. -data DepTestRslt d = DepOk | MissingDeps d - -instance Semigroup d => Monoid (DepTestRslt d) where - mempty = DepOk - mappend = (<>) - -instance Semigroup d => Semigroup (DepTestRslt d) where - DepOk <> x = x - x <> DepOk = x - (MissingDeps d) <> (MissingDeps d') = MissingDeps (d <> d') - - --- | Try to find a flag assignment that satisfies the constraints of all trees. --- --- Returns either the missing dependencies, or a tuple containing the --- resulting data, the associated dependencies, and the chosen flag --- assignments. --- --- In case of failure, the union of the dependencies that led to backtracking --- on all branches is returned. --- [TODO: Could also be specified with a function argument.] --- --- TODO: The current algorithm is rather naive. A better approach would be to: --- --- * Rule out possible paths, by taking a look at the associated dependencies. --- --- * Infer the required values for the conditions of these paths, and --- calculate the required domains for the variables used in these --- conditions. Then picking a flag assignment would be linear (I guess). --- --- This would require some sort of SAT solving, though, thus it's not --- implemented unless we really need it. --- -resolveWithFlags :: - [(FlagName,[Bool])] - -- ^ Domain for each flag name, will be tested in order. - -> ComponentRequestedSpec - -> OS -- ^ OS as returned by Distribution.System.buildOS - -> Arch -- ^ Arch as returned by Distribution.System.buildArch - -> CompilerInfo -- ^ Compiler information - -> [PackageVersionConstraint] -- ^ Additional constraints - -> [CondTree ConfVar [Dependency] PDTagged] - -> ([Dependency] -> DepTestRslt [Dependency]) -- ^ Dependency test function. - -> Either [Dependency] (TargetSet PDTagged, FlagAssignment) - -- ^ Either the missing dependencies (error case), or a pair of - -- (set of build targets with dependencies, chosen flag assignments) -resolveWithFlags dom enabled os arch impl constrs trees checkDeps = - either (Left . fromDepMapUnion) Right $ explore (build mempty dom) - where - -- simplify trees by (partially) evaluating all conditions and converting - -- dependencies to dependency maps. - simplifiedTrees :: [CondTree FlagName DependencyMap PDTagged] - simplifiedTrees = map ( mapTreeConstrs toDepMap -- convert to maps - . addBuildableConditionPDTagged - . mapTreeConds (fst . simplifyWithSysParams os arch impl)) - trees - - -- @explore@ searches a tree of assignments, backtracking whenever a flag - -- introduces a dependency that cannot be satisfied. If there is no - -- solution, @explore@ returns the union of all dependencies that caused - -- it to backtrack. Since the tree is constructed lazily, we avoid some - -- computation overhead in the successful case. - explore :: Tree FlagAssignment - -> Either DepMapUnion (TargetSet PDTagged, FlagAssignment) - explore (Node flags ts) = - let targetSet = TargetSet $ flip map simplifiedTrees $ - -- apply additional constraints to all dependencies - first (`constrainBy` constrs) . - simplifyCondTree (env flags) - deps = overallDependencies enabled targetSet - in case checkDeps (fromDepMap deps) of - DepOk | null ts -> Right (targetSet, flags) - | otherwise -> tryAll $ map explore ts - MissingDeps mds -> Left (toDepMapUnion mds) - - -- Builds a tree of all possible flag assignments. Internal nodes - -- have only partial assignments. - build :: FlagAssignment -> [(FlagName, [Bool])] -> Tree FlagAssignment - build assigned [] = Node assigned [] - build assigned ((fn, vals) : unassigned) = - Node assigned $ map (\v -> build (insertFlagAssignment fn v assigned) unassigned) vals - - tryAll :: [Either DepMapUnion a] -> Either DepMapUnion a - tryAll = foldr mp mz - - -- special version of `mplus' for our local purposes - mp :: Either DepMapUnion a -> Either DepMapUnion a -> Either DepMapUnion a - mp m@(Right _) _ = m - mp _ m@(Right _) = m - mp (Left xs) (Left ys) = Left (xs <> ys) - - -- `mzero' - mz :: Either DepMapUnion a - mz = Left (DepMapUnion Map.empty) - - env :: FlagAssignment -> FlagName -> Either FlagName Bool - env flags flag = (maybe (Left flag) Right . lookupFlagAssignment flag) flags - --- | Transforms a 'CondTree' by putting the input under the "then" branch of a --- conditional that is True when Buildable is True. If 'addBuildableCondition' --- can determine that Buildable is always True, it returns the input unchanged. --- If Buildable is always False, it returns the empty 'CondTree'. -addBuildableCondition :: (Eq v, Monoid a, Monoid c) => (a -> BuildInfo) - -> CondTree v c a - -> CondTree v c a -addBuildableCondition getInfo t = - case extractCondition (buildable . getInfo) t of - Lit True -> t - Lit False -> CondNode mempty mempty [] - c -> CondNode mempty mempty [condIfThen c t] - --- | This is a special version of 'addBuildableCondition' for the 'PDTagged' --- type. --- --- It is not simply a specialisation. It is more complicated than it --- ought to be because of the way the 'PDTagged' monoid instance works. The --- @mempty = 'PDNull'@ forgets the component type, which has the effect of --- completely deleting components that are not buildable. --- --- See for more details. --- -addBuildableConditionPDTagged :: (Eq v, Monoid c) => - CondTree v c PDTagged - -> CondTree v c PDTagged -addBuildableConditionPDTagged t = - case extractCondition (buildable . getInfo) t of - Lit True -> t - Lit False -> deleteConstraints t - c -> CondNode mempty mempty [condIfThenElse c t (deleteConstraints t)] - where - deleteConstraints = mapTreeConstrs (const mempty) - - getInfo :: PDTagged -> BuildInfo - getInfo (Lib l) = libBuildInfo l - getInfo (SubComp _ c) = componentBuildInfo c - getInfo PDNull = mempty - - --- Note: extracting buildable conditions. --- -------------------------------------- --- --- If the conditions in a cond tree lead to Buildable being set to False, then --- none of the dependencies for this cond tree should actually be taken into --- account. On the other hand, some of the flags may only be decided in the --- solver, so we cannot necessarily make the decision whether a component is --- Buildable or not prior to solving. --- --- What we are doing here is to partially evaluate a condition tree in order to --- extract the condition under which Buildable is True. The predicate determines --- whether data under a 'CondTree' is buildable. - --- | Extract conditions matched by the given predicate from all cond trees in a --- 'GenericPackageDescription'. -extractConditions :: (BuildInfo -> Bool) -> GenericPackageDescription - -> [Condition ConfVar] -extractConditions f gpkg = - concat [ - extractCondition (f . libBuildInfo) <$> maybeToList (condLibrary gpkg) - , extractCondition (f . libBuildInfo) . snd <$> condSubLibraries gpkg - , extractCondition (f . buildInfo) . snd <$> condExecutables gpkg - , extractCondition (f . testBuildInfo) . snd <$> condTestSuites gpkg - , extractCondition (f . benchmarkBuildInfo) . snd <$> condBenchmarks gpkg - ] - - --- | A map of package constraints that combines version ranges using 'unionVersionRanges'. -newtype DepMapUnion = DepMapUnion { unDepMapUnion :: Map PackageName (VersionRange, NonEmptySet LibraryName) } - -instance Semigroup DepMapUnion where - DepMapUnion x <> DepMapUnion y = DepMapUnion $ - Map.unionWith unionVersionRanges' x y - -unionVersionRanges' - :: (VersionRange, NonEmptySet LibraryName) - -> (VersionRange, NonEmptySet LibraryName) - -> (VersionRange, NonEmptySet LibraryName) -unionVersionRanges' (vr, cs) (vr', cs') = (unionVersionRanges vr vr', cs <> cs') - -toDepMapUnion :: [Dependency] -> DepMapUnion -toDepMapUnion ds = - DepMapUnion $ Map.fromListWith unionVersionRanges' [ (p,(vr,cs)) | Dependency p vr cs <- ds ] - - -fromDepMapUnion :: DepMapUnion -> [Dependency] -fromDepMapUnion m = [ Dependency p vr cs | (p,(vr,cs)) <- Map.toList (unDepMapUnion m) ] - -freeVars :: CondTree ConfVar c a -> [FlagName] -freeVars t = [ f | PackageFlag f <- freeVars' t ] - where - freeVars' (CondNode _ _ ifs) = concatMap compfv ifs - compfv (CondBranch c ct mct) = condfv c ++ freeVars' ct ++ maybe [] freeVars' mct - condfv c = case c of - Var v -> [v] - Lit _ -> [] - CNot c' -> condfv c' - COr c1 c2 -> condfv c1 ++ condfv c2 - CAnd c1 c2 -> condfv c1 ++ condfv c2 - - ------------------------------------------------------------------------------- - --- | A set of targets with their package dependencies -newtype TargetSet a = TargetSet [(DependencyMap, a)] - --- | Combine the target-specific dependencies in a TargetSet to give the --- dependencies for the package as a whole. -overallDependencies :: ComponentRequestedSpec -> TargetSet PDTagged -> DependencyMap -overallDependencies enabled (TargetSet targets) = mconcat depss - where - (depss, _) = unzip $ filter (removeDisabledSections . snd) targets - removeDisabledSections :: PDTagged -> Bool - -- UGH. The embedded componentName in the 'Component's here is - -- BLANK. I don't know whose fault this is but I'll use the tag - -- instead. -- ezyang - removeDisabledSections (Lib _) = componentNameRequested - enabled - (CLibName LMainLibName) - removeDisabledSections (SubComp t c) - -- Do NOT use componentName - = componentNameRequested enabled - $ case c of - CLib _ -> CLibName (LSubLibName t) - CFLib _ -> CFLibName t - CExe _ -> CExeName t - CTest _ -> CTestName t - CBench _ -> CBenchName t - removeDisabledSections PDNull = True - --- | Collect up the targets in a TargetSet of tagged targets, storing the --- dependencies as we go. -flattenTaggedTargets :: TargetSet PDTagged -> (Maybe Library, [(UnqualComponentName, Component)]) -flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, []) targets where - untag (depMap, pdTagged) accum = case (pdTagged, accum) of - (Lib _, (Just _, _)) -> userBug "Only one library expected" - (Lib l, (Nothing, comps)) -> (Just $ redoBD l, comps) - (SubComp n c, (mb_lib, comps)) - | any ((== n) . fst) comps -> - userBug $ "There exist several components with the same name: '" ++ prettyShow n ++ "'" - | otherwise -> (mb_lib, (n, redoBD c) : comps) - (PDNull, x) -> x -- actually this should not happen, but let's be liberal - where - redoBD :: L.HasBuildInfo a => a -> a - redoBD = set L.targetBuildDepends $ fromDepMap depMap - ------------------------------------------------------------------------------- --- Convert GenericPackageDescription to PackageDescription --- - -data PDTagged = Lib Library - | SubComp UnqualComponentName Component - | PDNull - deriving Show - -instance Monoid PDTagged where - mempty = PDNull - mappend = (<>) - -instance Semigroup PDTagged where - PDNull <> x = x - x <> PDNull = x - Lib l <> Lib l' = Lib (l <> l') - SubComp n x <> SubComp n' x' | n == n' = SubComp n (x <> x') - _ <> _ = cabalBug "Cannot combine incompatible tags" - --- | Create a package description with all configurations resolved. --- --- This function takes a `GenericPackageDescription` and several environment --- parameters and tries to generate `PackageDescription` by finding a flag --- assignment that result in satisfiable dependencies. --- --- It takes as inputs a not necessarily complete specifications of flags --- assignments, an optional package index as well as platform parameters. If --- some flags are not assigned explicitly, this function will try to pick an --- assignment that causes this function to succeed. The package index is --- optional since on some platforms we cannot determine which packages have --- been installed before. When no package index is supplied, every dependency --- is assumed to be satisfiable, therefore all not explicitly assigned flags --- will get their default values. --- --- This function will fail if it cannot find a flag assignment that leads to --- satisfiable dependencies. (It will not try alternative assignments for --- explicitly specified flags.) In case of failure it will return the missing --- dependencies that it encountered when trying different flag assignments. --- On success, it will return the package description and the full flag --- assignment chosen. --- --- Note that this drops any stanzas which have @buildable: False@. While --- this is arguably the right thing to do, it means we give bad error --- messages in some situations, see #3858. --- -finalizePD :: - FlagAssignment -- ^ Explicitly specified flag assignments - -> ComponentRequestedSpec - -> (Dependency -> Bool) -- ^ Is a given dependency satisfiable from the set of - -- available packages? If this is unknown then use - -- True. - -> Platform -- ^ The 'Arch' and 'OS' - -> CompilerInfo -- ^ Compiler information - -> [PackageVersionConstraint] -- ^ Additional constraints - -> GenericPackageDescription - -> Either [Dependency] - (PackageDescription, FlagAssignment) - -- ^ Either missing dependencies or the resolved package - -- description along with the flag assignments chosen. -finalizePD userflags enabled satisfyDep - (Platform arch os) impl constraints - (GenericPackageDescription pkg _ver flags mb_lib0 sub_libs0 flibs0 exes0 tests0 bms0) = do - (targetSet, flagVals) <- - resolveWithFlags flagChoices enabled os arch impl constraints condTrees check - let - (mb_lib, comps) = flattenTaggedTargets targetSet - mb_lib' = fmap libFillInDefaults mb_lib - comps' = flip map comps $ \(n,c) -> foldComponent - (\l -> CLib (libFillInDefaults l) { libName = LSubLibName n - , libExposed = False }) - (\l -> CFLib (flibFillInDefaults l) { foreignLibName = n }) - (\e -> CExe (exeFillInDefaults e) { exeName = n }) - (\t -> CTest (testFillInDefaults t) { testName = n }) - (\b -> CBench (benchFillInDefaults b) { benchmarkName = n }) - c - (sub_libs', flibs', exes', tests', bms') = partitionComponents comps' - return ( pkg { library = mb_lib' - , subLibraries = sub_libs' - , foreignLibs = flibs' - , executables = exes' - , testSuites = tests' - , benchmarks = bms' - } - , flagVals ) - where - -- Combine lib, exes, and tests into one list of @CondTree@s with tagged data - condTrees = maybeToList (fmap (mapTreeData Lib) mb_lib0) - ++ map (\(name,tree) -> mapTreeData (SubComp name . CLib) tree) sub_libs0 - ++ map (\(name,tree) -> mapTreeData (SubComp name . CFLib) tree) flibs0 - ++ map (\(name,tree) -> mapTreeData (SubComp name . CExe) tree) exes0 - ++ map (\(name,tree) -> mapTreeData (SubComp name . CTest) tree) tests0 - ++ map (\(name,tree) -> mapTreeData (SubComp name . CBench) tree) bms0 - - flagChoices = map (\(MkPackageFlag n _ d manual) -> (n, d2c manual n d)) flags - d2c manual n b = case lookupFlagAssignment n userflags of - Just val -> [val] - Nothing - | manual -> [b] - | otherwise -> [b, not b] - --flagDefaults = map (\(n,x:_) -> (n,x)) flagChoices - check ds = let missingDeps = filter (not . satisfyDep) ds - in if null missingDeps - then DepOk - else MissingDeps missingDeps - -{- -let tst_p = (CondNode [1::Int] [Distribution.Package.Dependency "a" AnyVersion] []) -let tst_p2 = (CondNode [1::Int] [Distribution.Package.Dependency "a" (EarlierVersion (Version [1,0] [])), Distribution.Package.Dependency "a" (LaterVersion (Version [2,0] []))] []) - -let p_index = Distribution.Simple.PackageIndex.fromList [Distribution.Package.PackageIdentifier "a" (Version [0,5] []), Distribution.Package.PackageIdentifier "a" (Version [2,5] [])] -let look = not . null . Distribution.Simple.PackageIndex.lookupDependency p_index -let looks ds = mconcat $ map (\d -> if look d then DepOk else MissingDeps [d]) ds -resolveWithFlags [] Distribution.System.Linux Distribution.System.I386 (Distribution.Compiler.GHC,Version [6,8,2] []) [tst_p] looks ===> Right ... -resolveWithFlags [] Distribution.System.Linux Distribution.System.I386 (Distribution.Compiler.GHC,Version [6,8,2] []) [tst_p2] looks ===> Left ... --} - --- | Flatten a generic package description by ignoring all conditions and just --- join the field descriptors into on package description. Note, however, --- that this may lead to inconsistent field values, since all values are --- joined into one field, which may not be possible in the original package --- description, due to the use of exclusive choices (if ... else ...). --- --- TODO: One particularly tricky case is defaulting. In the original package --- description, e.g., the source directory might either be the default or a --- certain, explicitly set path. Since defaults are filled in only after the --- package has been resolved and when no explicit value has been set, the --- default path will be missing from the package description returned by this --- function. -flattenPackageDescription :: GenericPackageDescription -> PackageDescription -flattenPackageDescription - (GenericPackageDescription pkg _ _ mlib0 sub_libs0 flibs0 exes0 tests0 bms0) = - pkg { library = mlib - , subLibraries = reverse sub_libs - , foreignLibs = reverse flibs - , executables = reverse exes - , testSuites = reverse tests - , benchmarks = reverse bms - } - where - mlib = f <$> mlib0 - where f lib = (libFillInDefaults . fst . ignoreConditions $ lib) { libName = LMainLibName } - sub_libs = flattenLib <$> sub_libs0 - flibs = flattenFLib <$> flibs0 - exes = flattenExe <$> exes0 - tests = flattenTst <$> tests0 - bms = flattenBm <$> bms0 - flattenLib (n, t) = libFillInDefaults $ (fst $ ignoreConditions t) - { libName = LSubLibName n, libExposed = False } - flattenFLib (n, t) = flibFillInDefaults $ (fst $ ignoreConditions t) - { foreignLibName = n } - flattenExe (n, t) = exeFillInDefaults $ (fst $ ignoreConditions t) - { exeName = n } - flattenTst (n, t) = testFillInDefaults $ (fst $ ignoreConditions t) - { testName = n } - flattenBm (n, t) = benchFillInDefaults $ (fst $ ignoreConditions t) - { benchmarkName = n } - --- This is in fact rather a hack. The original version just overrode the --- default values, however, when adding conditions we had to switch to a --- modifier-based approach. There, nothing is ever overwritten, but only --- joined together. --- --- This is the cleanest way i could think of, that doesn't require --- changing all field parsing functions to return modifiers instead. -libFillInDefaults :: Library -> Library -libFillInDefaults lib@(Library { libBuildInfo = bi }) = - lib { libBuildInfo = biFillInDefaults bi } - -flibFillInDefaults :: ForeignLib -> ForeignLib -flibFillInDefaults flib@(ForeignLib { foreignLibBuildInfo = bi }) = - flib { foreignLibBuildInfo = biFillInDefaults bi } - -exeFillInDefaults :: Executable -> Executable -exeFillInDefaults exe@(Executable { buildInfo = bi }) = - exe { buildInfo = biFillInDefaults bi } - -testFillInDefaults :: TestSuite -> TestSuite -testFillInDefaults tst@(TestSuite { testBuildInfo = bi }) = - tst { testBuildInfo = biFillInDefaults bi } - -benchFillInDefaults :: Benchmark -> Benchmark -benchFillInDefaults bm@(Benchmark { benchmarkBuildInfo = bi }) = - bm { benchmarkBuildInfo = biFillInDefaults bi } - -biFillInDefaults :: BuildInfo -> BuildInfo -biFillInDefaults bi = - if null (hsSourceDirs bi) - then bi { hsSourceDirs = [currentDir] } - else bi - --- Walk a 'GenericPackageDescription' and apply @onBuildInfo@/@onSetupBuildInfo@ --- to all nested 'BuildInfo'/'SetupBuildInfo' values. -transformAllBuildInfos :: (BuildInfo -> BuildInfo) - -> (SetupBuildInfo -> SetupBuildInfo) - -> GenericPackageDescription - -> GenericPackageDescription -transformAllBuildInfos onBuildInfo onSetupBuildInfo = - over L.traverseBuildInfos onBuildInfo - . over (L.packageDescription . L.setupBuildInfo . traverse) onSetupBuildInfo - --- | Walk a 'GenericPackageDescription' and apply @f@ to all nested --- @build-depends@ fields. -transformAllBuildDepends :: (Dependency -> Dependency) - -> GenericPackageDescription - -> GenericPackageDescription -transformAllBuildDepends f = - over (L.traverseBuildInfos . L.targetBuildDepends . traverse) f - . over (L.packageDescription . L.setupBuildInfo . traverse . L.setupDepends . traverse) f - -- cannot be point-free as normal because of higher rank - . over (\f' -> L.allCondTrees $ traverseCondTreeC f') (map f) - --- | Walk a 'GenericPackageDescription' and apply @f@ to all nested --- @build-depends@ fields. -transformAllBuildDependsN :: ([Dependency] -> [Dependency]) - -> GenericPackageDescription - -> GenericPackageDescription -transformAllBuildDependsN f = - over (L.traverseBuildInfos . L.targetBuildDepends) f - . over (L.packageDescription . L.setupBuildInfo . traverse . L.setupDepends) f - -- cannot be point-free as normal because of higher rank - . over (\f' -> L.allCondTrees $ traverseCondTreeC f') f diff --git a/cabal/Cabal/Distribution/PackageDescription/FieldGrammar.hs b/cabal/Cabal/Distribution/PackageDescription/FieldGrammar.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/PackageDescription/FieldGrammar.hs +++ /dev/null @@ -1,692 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE OverloadedStrings #-} --- | 'GenericPackageDescription' Field descriptions -module Distribution.PackageDescription.FieldGrammar ( - -- * Package description - packageDescriptionFieldGrammar, - -- * Library - libraryFieldGrammar, - -- * Foreign library - foreignLibFieldGrammar, - -- * Executable - executableFieldGrammar, - -- * Test suite - TestSuiteStanza (..), - testSuiteFieldGrammar, - validateTestSuite, - unvalidateTestSuite, - -- ** Lenses - testStanzaTestType, - testStanzaMainIs, - testStanzaTestModule, - testStanzaBuildInfo, - -- * Benchmark - BenchmarkStanza (..), - benchmarkFieldGrammar, - validateBenchmark, - unvalidateBenchmark, - -- * Field grammars - formatDependencyList, - formatExposedModules, - formatExtraSourceFiles, - formatHsSourceDirs, - formatMixinList, - formatOtherExtensions, - formatOtherModules, - -- ** Lenses - benchmarkStanzaBenchmarkType, - benchmarkStanzaMainIs, - benchmarkStanzaBenchmarkModule, - benchmarkStanzaBuildInfo, - -- * Flag - flagFieldGrammar, - -- * Source repository - sourceRepoFieldGrammar, - -- * Setup build info - setupBInfoFieldGrammar, - -- * Component build info - buildInfoFieldGrammar, - ) where - - -import Distribution.Compat.Lens -import Distribution.Compat.Prelude -import Language.Haskell.Extension -import Prelude () - -import Distribution.CabalSpecVersion -import Distribution.Compiler (CompilerFlavor (..), PerCompilerFlavor (..)) -import Distribution.FieldGrammar -import Distribution.Fields -import Distribution.ModuleName (ModuleName) -import Distribution.Package -import Distribution.PackageDescription -import Distribution.Parsec -import Distribution.Pretty (prettyShow) -import Distribution.Types.ModuleReexport -import Distribution.Types.Mixin (Mixin) -import Distribution.Version (Version, VersionRange) - -import qualified Distribution.SPDX as SPDX - -import qualified Distribution.Types.Lens as L - -------------------------------------------------------------------------------- --- PackageDescription -------------------------------------------------------------------------------- - -packageDescriptionFieldGrammar - :: ( FieldGrammar c g, Applicative (g PackageDescription), Applicative (g PackageIdentifier) - , c (Identity BuildType) - , c (Identity PackageName) - , c (Identity Version) - , c (List FSep FilePathNT String) - , c (List FSep TestedWith (CompilerFlavor, VersionRange)) - , c (List VCat FilePathNT String) - , c FilePathNT - , c SpecLicense - , c SpecVersion - ) - => g PackageDescription PackageDescription -packageDescriptionFieldGrammar = PackageDescription - <$> optionalFieldDefAla "cabal-version" SpecVersion L.specVersion CabalSpecV1_0 - <*> blurFieldGrammar L.package packageIdentifierGrammar - <*> optionalFieldDefAla "license" SpecLicense L.licenseRaw (Left SPDX.NONE) - <*> licenseFilesGrammar - <*> freeTextFieldDefST "copyright" L.copyright - <*> freeTextFieldDefST "maintainer" L.maintainer - <*> freeTextFieldDefST "author" L.author - <*> freeTextFieldDefST "stability" L.stability - <*> monoidalFieldAla "tested-with" (alaList' FSep TestedWith) L.testedWith - <*> freeTextFieldDefST "homepage" L.homepage - <*> freeTextFieldDefST "package-url" L.pkgUrl - <*> freeTextFieldDefST "bug-reports" L.bugReports - <*> pure [] -- source-repos are stanza - <*> freeTextFieldDefST "synopsis" L.synopsis - <*> freeTextFieldDefST "description" L.description - <*> freeTextFieldDefST "category" L.category - <*> prefixedFields "x-" L.customFieldsPD - <*> optionalField "build-type" L.buildTypeRaw - <*> pure Nothing -- custom-setup - -- components - <*> pure Nothing -- lib - <*> pure [] -- sub libs - <*> pure [] -- executables - <*> pure [] -- foreign libs - <*> pure [] -- test suites - <*> pure [] -- benchmarks - -- * Files - <*> monoidalFieldAla "data-files" (alaList' VCat FilePathNT) L.dataFiles - <*> optionalFieldDefAla "data-dir" FilePathNT L.dataDir "" - <*> monoidalFieldAla "extra-source-files" formatExtraSourceFiles L.extraSrcFiles - <*> monoidalFieldAla "extra-tmp-files" (alaList' VCat FilePathNT) L.extraTmpFiles - <*> monoidalFieldAla "extra-doc-files" (alaList' VCat FilePathNT) L.extraDocFiles - where - packageIdentifierGrammar = PackageIdentifier - <$> uniqueField "name" L.pkgName - <*> uniqueField "version" L.pkgVersion - - licenseFilesGrammar = (++) - -- TODO: neither field is deprecated - -- should we pretty print license-file if there's single license file - -- and license-files when more - <$> monoidalFieldAla "license-file" (alaList' FSep FilePathNT) L.licenseFiles - <*> monoidalFieldAla "license-files" (alaList' FSep FilePathNT) L.licenseFiles - ^^^ hiddenField - -------------------------------------------------------------------------------- --- Library -------------------------------------------------------------------------------- - -libraryFieldGrammar - :: ( FieldGrammar c g, Applicative (g Library), Applicative (g BuildInfo) - , c (Identity LibraryVisibility) - , c (List CommaFSep (Identity ExeDependency) ExeDependency) - , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) - , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) - , c (List CommaVCat (Identity Dependency) Dependency) - , c (List CommaVCat (Identity Mixin) Mixin) - , c (List CommaVCat (Identity ModuleReexport) ModuleReexport) - , c (List FSep (MQuoted Extension) Extension) - , c (List FSep (MQuoted Language) Language) - , c (List FSep FilePathNT String) - , c (List FSep Token String) - , c (List NoCommaFSep Token' String) - , c (List VCat (MQuoted ModuleName) ModuleName) - , c (List VCat FilePathNT String) - , c (List VCat Token String) - , c (MQuoted Language) - ) - => LibraryName - -> g Library Library -libraryFieldGrammar n = Library n - <$> monoidalFieldAla "exposed-modules" formatExposedModules L.exposedModules - <*> monoidalFieldAla "reexported-modules" (alaList CommaVCat) L.reexportedModules - <*> monoidalFieldAla "signatures" (alaList' VCat MQuoted) L.signatures - ^^^ availableSince CabalSpecV2_0 [] - <*> booleanFieldDef "exposed" L.libExposed True - <*> visibilityField - <*> blurFieldGrammar L.libBuildInfo buildInfoFieldGrammar - where - visibilityField = case n of - -- nameless/"main" libraries are public - LMainLibName -> pure LibraryVisibilityPublic - -- named libraries have the field - LSubLibName _ -> - optionalFieldDef "visibility" L.libVisibility LibraryVisibilityPrivate - ^^^ availableSince CabalSpecV3_0 LibraryVisibilityPrivate - -{-# SPECIALIZE libraryFieldGrammar :: LibraryName -> ParsecFieldGrammar' Library #-} -{-# SPECIALIZE libraryFieldGrammar :: LibraryName -> PrettyFieldGrammar' Library #-} - -------------------------------------------------------------------------------- --- Foreign library -------------------------------------------------------------------------------- - -foreignLibFieldGrammar - :: ( FieldGrammar c g, Applicative (g ForeignLib), Applicative (g BuildInfo) - , c (Identity ForeignLibType) - , c (Identity LibVersionInfo) - , c (Identity Version) - , c (List CommaFSep (Identity ExeDependency) ExeDependency) - , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) - , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) - , c (List CommaVCat (Identity Dependency) Dependency) - , c (List CommaVCat (Identity Mixin) Mixin) - , c (List FSep (Identity ForeignLibOption) ForeignLibOption) - , c (List FSep (MQuoted Extension) Extension) - , c (List FSep (MQuoted Language) Language) - , c (List FSep FilePathNT String) - , c (List FSep Token String) - , c (List NoCommaFSep Token' String) - , c (List VCat (MQuoted ModuleName) ModuleName) - , c (List VCat FilePathNT String), c (List VCat Token String) - , c (MQuoted Language) - ) - => UnqualComponentName -> g ForeignLib ForeignLib -foreignLibFieldGrammar n = ForeignLib n - <$> optionalFieldDef "type" L.foreignLibType ForeignLibTypeUnknown - <*> monoidalFieldAla "options" (alaList FSep) L.foreignLibOptions - <*> blurFieldGrammar L.foreignLibBuildInfo buildInfoFieldGrammar - <*> optionalField "lib-version-info" L.foreignLibVersionInfo - <*> optionalField "lib-version-linux" L.foreignLibVersionLinux - <*> monoidalFieldAla "mod-def-file" (alaList' FSep FilePathNT) L.foreignLibModDefFile -{-# SPECIALIZE foreignLibFieldGrammar :: UnqualComponentName -> ParsecFieldGrammar' ForeignLib #-} -{-# SPECIALIZE foreignLibFieldGrammar :: UnqualComponentName -> PrettyFieldGrammar' ForeignLib #-} - -------------------------------------------------------------------------------- --- Executable -------------------------------------------------------------------------------- - -executableFieldGrammar - :: ( FieldGrammar c g, Applicative (g Executable), Applicative (g BuildInfo) - , c (Identity ExecutableScope), - c (List CommaFSep (Identity ExeDependency) ExeDependency), - c (List - CommaFSep (Identity LegacyExeDependency) LegacyExeDependency), - c (List - CommaFSep (Identity PkgconfigDependency) PkgconfigDependency), - c (List CommaVCat (Identity Dependency) Dependency), - c (List CommaVCat (Identity Mixin) Mixin), - c (List FSep (MQuoted Extension) Extension), - c (List FSep (MQuoted Language) Language), - c (List FSep FilePathNT String), c (List FSep Token String), - c (List NoCommaFSep Token' String), - c (List VCat (MQuoted ModuleName) ModuleName), - c (List VCat FilePathNT String), c (List VCat Token String), - c (MQuoted Language) - ) - => UnqualComponentName -> g Executable Executable -executableFieldGrammar n = Executable n - -- main-is is optional as conditional blocks don't have it - <$> optionalFieldDefAla "main-is" FilePathNT L.modulePath "" - <*> optionalFieldDef "scope" L.exeScope ExecutablePublic - ^^^ availableSince CabalSpecV2_0 ExecutablePublic - <*> blurFieldGrammar L.buildInfo buildInfoFieldGrammar -{-# SPECIALIZE executableFieldGrammar :: UnqualComponentName -> ParsecFieldGrammar' Executable #-} -{-# SPECIALIZE executableFieldGrammar :: UnqualComponentName -> PrettyFieldGrammar' Executable #-} - -------------------------------------------------------------------------------- --- TestSuite -------------------------------------------------------------------------------- - --- | An intermediate type just used for parsing the test-suite stanza. --- After validation it is converted into the proper 'TestSuite' type. -data TestSuiteStanza = TestSuiteStanza - { _testStanzaTestType :: Maybe TestType - , _testStanzaMainIs :: Maybe FilePath - , _testStanzaTestModule :: Maybe ModuleName - , _testStanzaBuildInfo :: BuildInfo - } - -instance L.HasBuildInfo TestSuiteStanza where - buildInfo = testStanzaBuildInfo - -testStanzaTestType :: Lens' TestSuiteStanza (Maybe TestType) -testStanzaTestType f s = fmap (\x -> s { _testStanzaTestType = x }) (f (_testStanzaTestType s)) -{-# INLINE testStanzaTestType #-} - -testStanzaMainIs :: Lens' TestSuiteStanza (Maybe FilePath) -testStanzaMainIs f s = fmap (\x -> s { _testStanzaMainIs = x }) (f (_testStanzaMainIs s)) -{-# INLINE testStanzaMainIs #-} - -testStanzaTestModule :: Lens' TestSuiteStanza (Maybe ModuleName) -testStanzaTestModule f s = fmap (\x -> s { _testStanzaTestModule = x }) (f (_testStanzaTestModule s)) -{-# INLINE testStanzaTestModule #-} - -testStanzaBuildInfo :: Lens' TestSuiteStanza BuildInfo -testStanzaBuildInfo f s = fmap (\x -> s { _testStanzaBuildInfo = x }) (f (_testStanzaBuildInfo s)) -{-# INLINE testStanzaBuildInfo #-} - -testSuiteFieldGrammar - :: ( FieldGrammar c g, Applicative (g TestSuiteStanza), Applicative (g BuildInfo) - , c (Identity ModuleName) - , c (Identity TestType) - , c (List CommaFSep (Identity ExeDependency) ExeDependency) - , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) - , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) - , c (List CommaVCat (Identity Dependency) Dependency) - , c (List CommaVCat (Identity Mixin) Mixin) - , c (List FSep (MQuoted Extension) Extension) - , c (List FSep (MQuoted Language) Language) - , c (List FSep FilePathNT String) - , c (List FSep Token String) - , c (List NoCommaFSep Token' String) - , c (List VCat (MQuoted ModuleName) ModuleName) - , c (List VCat FilePathNT String) - , c (List VCat Token String) - , c (MQuoted Language) - ) - => g TestSuiteStanza TestSuiteStanza -testSuiteFieldGrammar = TestSuiteStanza - <$> optionalField "type" testStanzaTestType - <*> optionalFieldAla "main-is" FilePathNT testStanzaMainIs - <*> optionalField "test-module" testStanzaTestModule - <*> blurFieldGrammar testStanzaBuildInfo buildInfoFieldGrammar - -validateTestSuite :: Position -> TestSuiteStanza -> ParseResult TestSuite -validateTestSuite pos stanza = case _testStanzaTestType stanza of - Nothing -> return $ - emptyTestSuite { testBuildInfo = _testStanzaBuildInfo stanza } - - Just tt@(TestTypeUnknown _ _) -> - pure emptyTestSuite - { testInterface = TestSuiteUnsupported tt - , testBuildInfo = _testStanzaBuildInfo stanza - } - - Just tt | tt `notElem` knownTestTypes -> - pure emptyTestSuite - { testInterface = TestSuiteUnsupported tt - , testBuildInfo = _testStanzaBuildInfo stanza - } - - Just tt@(TestTypeExe ver) -> case _testStanzaMainIs stanza of - Nothing -> do - parseFailure pos (missingField "main-is" tt) - pure emptyTestSuite - Just file -> do - when (isJust (_testStanzaTestModule stanza)) $ - parseWarning pos PWTExtraBenchmarkModule (extraField "test-module" tt) - pure emptyTestSuite - { testInterface = TestSuiteExeV10 ver file - , testBuildInfo = _testStanzaBuildInfo stanza - } - - Just tt@(TestTypeLib ver) -> case _testStanzaTestModule stanza of - Nothing -> do - parseFailure pos (missingField "test-module" tt) - pure emptyTestSuite - Just module_ -> do - when (isJust (_testStanzaMainIs stanza)) $ - parseWarning pos PWTExtraMainIs (extraField "main-is" tt) - pure emptyTestSuite - { testInterface = TestSuiteLibV09 ver module_ - , testBuildInfo = _testStanzaBuildInfo stanza - } - - where - missingField name tt = "The '" ++ name ++ "' field is required for the " - ++ prettyShow tt ++ " test suite type." - - extraField name tt = "The '" ++ name ++ "' field is not used for the '" - ++ prettyShow tt ++ "' test suite type." - -unvalidateTestSuite :: TestSuite -> TestSuiteStanza -unvalidateTestSuite t = TestSuiteStanza - { _testStanzaTestType = ty - , _testStanzaMainIs = ma - , _testStanzaTestModule = mo - , _testStanzaBuildInfo = testBuildInfo t - } - where - (ty, ma, mo) = case testInterface t of - TestSuiteExeV10 ver file -> (Just $ TestTypeExe ver, Just file, Nothing) - TestSuiteLibV09 ver modu -> (Just $ TestTypeLib ver, Nothing, Just modu) - _ -> (Nothing, Nothing, Nothing) - -------------------------------------------------------------------------------- --- Benchmark -------------------------------------------------------------------------------- - --- | An intermediate type just used for parsing the benchmark stanza. --- After validation it is converted into the proper 'Benchmark' type. -data BenchmarkStanza = BenchmarkStanza - { _benchmarkStanzaBenchmarkType :: Maybe BenchmarkType - , _benchmarkStanzaMainIs :: Maybe FilePath - , _benchmarkStanzaBenchmarkModule :: Maybe ModuleName - , _benchmarkStanzaBuildInfo :: BuildInfo - } - -instance L.HasBuildInfo BenchmarkStanza where - buildInfo = benchmarkStanzaBuildInfo - -benchmarkStanzaBenchmarkType :: Lens' BenchmarkStanza (Maybe BenchmarkType) -benchmarkStanzaBenchmarkType f s = fmap (\x -> s { _benchmarkStanzaBenchmarkType = x }) (f (_benchmarkStanzaBenchmarkType s)) -{-# INLINE benchmarkStanzaBenchmarkType #-} - -benchmarkStanzaMainIs :: Lens' BenchmarkStanza (Maybe FilePath) -benchmarkStanzaMainIs f s = fmap (\x -> s { _benchmarkStanzaMainIs = x }) (f (_benchmarkStanzaMainIs s)) -{-# INLINE benchmarkStanzaMainIs #-} - -benchmarkStanzaBenchmarkModule :: Lens' BenchmarkStanza (Maybe ModuleName) -benchmarkStanzaBenchmarkModule f s = fmap (\x -> s { _benchmarkStanzaBenchmarkModule = x }) (f (_benchmarkStanzaBenchmarkModule s)) -{-# INLINE benchmarkStanzaBenchmarkModule #-} - -benchmarkStanzaBuildInfo :: Lens' BenchmarkStanza BuildInfo -benchmarkStanzaBuildInfo f s = fmap (\x -> s { _benchmarkStanzaBuildInfo = x }) (f (_benchmarkStanzaBuildInfo s)) -{-# INLINE benchmarkStanzaBuildInfo #-} - -benchmarkFieldGrammar - :: ( FieldGrammar c g, Applicative (g BenchmarkStanza), Applicative (g BuildInfo) - , c (Identity BenchmarkType) - , c (Identity ModuleName) - , c (List CommaFSep (Identity ExeDependency) ExeDependency) - , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) - , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) - , c (List CommaVCat (Identity Dependency) Dependency) - , c (List CommaVCat (Identity Mixin) Mixin) - , c (List FSep (MQuoted Extension) Extension) - , c (List FSep (MQuoted Language) Language) - , c (List FSep FilePathNT String) - , c (List FSep Token String) - , c (List NoCommaFSep Token' String) - , c (List VCat (MQuoted ModuleName) ModuleName) - , c (List VCat FilePathNT String) - , c (List VCat Token String) - , c (MQuoted Language) - ) - => g BenchmarkStanza BenchmarkStanza -benchmarkFieldGrammar = BenchmarkStanza - <$> optionalField "type" benchmarkStanzaBenchmarkType - <*> optionalFieldAla "main-is" FilePathNT benchmarkStanzaMainIs - <*> optionalField "benchmark-module" benchmarkStanzaBenchmarkModule - <*> blurFieldGrammar benchmarkStanzaBuildInfo buildInfoFieldGrammar - -validateBenchmark :: Position -> BenchmarkStanza -> ParseResult Benchmark -validateBenchmark pos stanza = case _benchmarkStanzaBenchmarkType stanza of - Nothing -> pure emptyBenchmark - { benchmarkBuildInfo = _benchmarkStanzaBuildInfo stanza } - - Just tt@(BenchmarkTypeUnknown _ _) -> pure emptyBenchmark - { benchmarkInterface = BenchmarkUnsupported tt - , benchmarkBuildInfo = _benchmarkStanzaBuildInfo stanza - } - - Just tt | tt `notElem` knownBenchmarkTypes -> pure emptyBenchmark - { benchmarkInterface = BenchmarkUnsupported tt - , benchmarkBuildInfo = _benchmarkStanzaBuildInfo stanza - } - - Just tt@(BenchmarkTypeExe ver) -> case _benchmarkStanzaMainIs stanza of - Nothing -> do - parseFailure pos (missingField "main-is" tt) - pure emptyBenchmark - Just file -> do - when (isJust (_benchmarkStanzaBenchmarkModule stanza)) $ - parseWarning pos PWTExtraBenchmarkModule (extraField "benchmark-module" tt) - pure emptyBenchmark - { benchmarkInterface = BenchmarkExeV10 ver file - , benchmarkBuildInfo = _benchmarkStanzaBuildInfo stanza - } - - where - missingField name tt = "The '" ++ name ++ "' field is required for the " - ++ prettyShow tt ++ " benchmark type." - - extraField name tt = "The '" ++ name ++ "' field is not used for the '" - ++ prettyShow tt ++ "' benchmark type." - -unvalidateBenchmark :: Benchmark -> BenchmarkStanza -unvalidateBenchmark b = BenchmarkStanza - { _benchmarkStanzaBenchmarkType = ty - , _benchmarkStanzaMainIs = ma - , _benchmarkStanzaBenchmarkModule = mo - , _benchmarkStanzaBuildInfo = benchmarkBuildInfo b - } - where - (ty, ma, mo) = case benchmarkInterface b of - BenchmarkExeV10 ver "" -> (Just $ BenchmarkTypeExe ver, Nothing, Nothing) - BenchmarkExeV10 ver ma' -> (Just $ BenchmarkTypeExe ver, Just ma', Nothing) - _ -> (Nothing, Nothing, Nothing) - -------------------------------------------------------------------------------- --- Build info -------------------------------------------------------------------------------- - -buildInfoFieldGrammar - :: ( FieldGrammar c g, Applicative (g BuildInfo) - , c (List CommaFSep (Identity ExeDependency) ExeDependency) - , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) - , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) - , c (List CommaVCat (Identity Dependency) Dependency) - , c (List CommaVCat (Identity Mixin) Mixin) - , c (List FSep (MQuoted Extension) Extension) - , c (List FSep (MQuoted Language) Language) - , c (List FSep FilePathNT String) - , c (List FSep Token String) - , c (List NoCommaFSep Token' String) - , c (List VCat (MQuoted ModuleName) ModuleName) - , c (List VCat FilePathNT String) - , c (List VCat Token String) - , c (MQuoted Language) - ) - => g BuildInfo BuildInfo -buildInfoFieldGrammar = BuildInfo - <$> booleanFieldDef "buildable" L.buildable True - <*> monoidalFieldAla "build-tools" (alaList CommaFSep) L.buildTools - ^^^ deprecatedSince CabalSpecV2_0 - "Please use 'build-tool-depends' field" - ^^^ removedIn CabalSpecV3_0 - "Please use 'build-tool-depends' field." - <*> monoidalFieldAla "build-tool-depends" (alaList CommaFSep) L.buildToolDepends - -- {- ^^^ availableSince [2,0] [] -} - -- here, we explicitly want to recognise build-tool-depends for all Cabal files - -- as otherwise cabal new-build cannot really work. - -- - -- I.e. we don't want trigger unknown field warning - <*> monoidalFieldAla "cpp-options" (alaList' NoCommaFSep Token') L.cppOptions - <*> monoidalFieldAla "asm-options" (alaList' NoCommaFSep Token') L.asmOptions - ^^^ availableSince CabalSpecV3_0 [] - <*> monoidalFieldAla "cmm-options" (alaList' NoCommaFSep Token') L.cmmOptions - ^^^ availableSince CabalSpecV3_0 [] - <*> monoidalFieldAla "cc-options" (alaList' NoCommaFSep Token') L.ccOptions - <*> monoidalFieldAla "cxx-options" (alaList' NoCommaFSep Token') L.cxxOptions - ^^^ availableSince CabalSpecV2_2 [] - <*> monoidalFieldAla "ld-options" (alaList' NoCommaFSep Token') L.ldOptions - <*> monoidalFieldAla "pkgconfig-depends" (alaList CommaFSep) L.pkgconfigDepends - <*> monoidalFieldAla "frameworks" (alaList' FSep Token) L.frameworks - <*> monoidalFieldAla "extra-framework-dirs" (alaList' FSep FilePathNT) L.extraFrameworkDirs - <*> monoidalFieldAla "asm-sources" (alaList' VCat FilePathNT) L.asmSources - ^^^ availableSince CabalSpecV3_0 [] - <*> monoidalFieldAla "cmm-sources" (alaList' VCat FilePathNT) L.cmmSources - ^^^ availableSince CabalSpecV3_0 [] - <*> monoidalFieldAla "c-sources" (alaList' VCat FilePathNT) L.cSources - <*> monoidalFieldAla "cxx-sources" (alaList' VCat FilePathNT) L.cxxSources - ^^^ availableSince CabalSpecV2_2 [] - <*> monoidalFieldAla "js-sources" (alaList' VCat FilePathNT) L.jsSources - <*> hsSourceDirsGrammar - <*> monoidalFieldAla "other-modules" formatOtherModules L.otherModules - <*> monoidalFieldAla "virtual-modules" (alaList' VCat MQuoted) L.virtualModules - ^^^ availableSince CabalSpecV2_2 [] - <*> monoidalFieldAla "autogen-modules" (alaList' VCat MQuoted) L.autogenModules - ^^^ availableSince CabalSpecV2_0 [] - <*> optionalFieldAla "default-language" MQuoted L.defaultLanguage - ^^^ availableSince CabalSpecV1_10 Nothing - <*> monoidalFieldAla "other-languages" (alaList' FSep MQuoted) L.otherLanguages - ^^^ availableSince CabalSpecV1_10 [] - <*> monoidalFieldAla "default-extensions" (alaList' FSep MQuoted) L.defaultExtensions - ^^^ availableSince CabalSpecV1_10 [] - <*> monoidalFieldAla "other-extensions" formatOtherExtensions L.otherExtensions - ^^^ availableSince CabalSpecV1_10 [] - <*> monoidalFieldAla "extensions" (alaList' FSep MQuoted) L.oldExtensions - ^^^ deprecatedSince CabalSpecV1_12 - "Please use 'default-extensions' or 'other-extensions' fields." - ^^^ removedIn CabalSpecV3_0 - "Please use 'default-extensions' or 'other-extensions' fields." - <*> monoidalFieldAla "extra-libraries" (alaList' VCat Token) L.extraLibs - <*> monoidalFieldAla "extra-ghci-libraries" (alaList' VCat Token) L.extraGHCiLibs - <*> monoidalFieldAla "extra-bundled-libraries" (alaList' VCat Token) L.extraBundledLibs - <*> monoidalFieldAla "extra-library-flavours" (alaList' VCat Token) L.extraLibFlavours - <*> monoidalFieldAla "extra-dynamic-library-flavours" (alaList' VCat Token) L.extraDynLibFlavours - ^^^ availableSince CabalSpecV3_0 [] - <*> monoidalFieldAla "extra-lib-dirs" (alaList' FSep FilePathNT) L.extraLibDirs - <*> monoidalFieldAla "include-dirs" (alaList' FSep FilePathNT) L.includeDirs - <*> monoidalFieldAla "includes" (alaList' FSep FilePathNT) L.includes - <*> monoidalFieldAla "autogen-includes" (alaList' FSep FilePathNT) L.autogenIncludes - ^^^ availableSince CabalSpecV3_0 [] - <*> monoidalFieldAla "install-includes" (alaList' FSep FilePathNT) L.installIncludes - <*> optionsFieldGrammar - <*> profOptionsFieldGrammar - <*> sharedOptionsFieldGrammar - <*> pure mempty -- static-options ??? - <*> prefixedFields "x-" L.customFieldsBI - <*> monoidalFieldAla "build-depends" formatDependencyList L.targetBuildDepends - <*> monoidalFieldAla "mixins" formatMixinList L.mixins - ^^^ availableSince CabalSpecV2_0 [] -{-# SPECIALIZE buildInfoFieldGrammar :: ParsecFieldGrammar' BuildInfo #-} -{-# SPECIALIZE buildInfoFieldGrammar :: PrettyFieldGrammar' BuildInfo #-} - -hsSourceDirsGrammar - :: (FieldGrammar c g, Applicative (g BuildInfo), c (List FSep FilePathNT FilePath)) - => g BuildInfo [FilePath] -hsSourceDirsGrammar = (++) - <$> monoidalFieldAla "hs-source-dirs" formatHsSourceDirs L.hsSourceDirs - <*> monoidalFieldAla "hs-source-dir" (alaList' FSep FilePathNT) wrongLens - --- https://github.com/haskell/cabal/commit/49e3cdae3bdf21b017ccd42e66670ca402e22b44 - ^^^ deprecatedSince CabalSpecV1_2 "Please use 'hs-source-dirs'" - ^^^ removedIn CabalSpecV3_0 "Please use 'hs-source-dirs' field." - where - -- TODO: make pretty printer aware of CabalSpecVersion - wrongLens :: Functor f => LensLike' f BuildInfo [FilePath] - wrongLens f bi = (\fps -> set L.hsSourceDirs fps bi) <$> f [] - -optionsFieldGrammar - :: (FieldGrammar c g, Applicative (g BuildInfo), c (List NoCommaFSep Token' String)) - => g BuildInfo (PerCompilerFlavor [String]) -optionsFieldGrammar = PerCompilerFlavor - <$> monoidalFieldAla "ghc-options" (alaList' NoCommaFSep Token') (extract GHC) - <*> monoidalFieldAla "ghcjs-options" (alaList' NoCommaFSep Token') (extract GHCJS) - -- NOTE: Hugs, NHC and JHC are not supported anymore, but these - -- fields are kept around so that we can still parse legacy .cabal - -- files that have them. - <* knownField "jhc-options" - <* knownField "hugs-options" - <* knownField "nhc98-options" - where - extract :: CompilerFlavor -> ALens' BuildInfo [String] - extract flavor = L.options . lookupLens flavor - -profOptionsFieldGrammar - :: (FieldGrammar c g, Applicative (g BuildInfo), c (List NoCommaFSep Token' String)) - => g BuildInfo (PerCompilerFlavor [String]) -profOptionsFieldGrammar = PerCompilerFlavor - <$> monoidalFieldAla "ghc-prof-options" (alaList' NoCommaFSep Token') (extract GHC) - <*> monoidalFieldAla "ghcjs-prof-options" (alaList' NoCommaFSep Token') (extract GHCJS) - where - extract :: CompilerFlavor -> ALens' BuildInfo [String] - extract flavor = L.profOptions . lookupLens flavor - -sharedOptionsFieldGrammar - :: (FieldGrammar c g, Applicative (g BuildInfo), c (List NoCommaFSep Token' String)) - => g BuildInfo (PerCompilerFlavor [String]) -sharedOptionsFieldGrammar = PerCompilerFlavor - <$> monoidalFieldAla "ghc-shared-options" (alaList' NoCommaFSep Token') (extract GHC) - <*> monoidalFieldAla "ghcjs-shared-options" (alaList' NoCommaFSep Token') (extract GHCJS) - where - extract :: CompilerFlavor -> ALens' BuildInfo [String] - extract flavor = L.sharedOptions . lookupLens flavor - -lookupLens :: (Functor f, Monoid v) => CompilerFlavor -> LensLike' f (PerCompilerFlavor v) v -lookupLens k f p@(PerCompilerFlavor ghc ghcjs) - | k == GHC = (\n -> PerCompilerFlavor n ghcjs) <$> f ghc - | k == GHCJS = (\n -> PerCompilerFlavor ghc n) <$> f ghcjs - | otherwise = p <$ f mempty - -------------------------------------------------------------------------------- --- Flag -------------------------------------------------------------------------------- - -flagFieldGrammar - :: (FieldGrammar c g, Applicative (g PackageFlag)) - => FlagName -> g PackageFlag PackageFlag -flagFieldGrammar name = MkPackageFlag name - <$> freeTextFieldDef "description" L.flagDescription - <*> booleanFieldDef "default" L.flagDefault True - <*> booleanFieldDef "manual" L.flagManual False -{-# SPECIALIZE flagFieldGrammar :: FlagName -> ParsecFieldGrammar' PackageFlag #-} -{-# SPECIALIZE flagFieldGrammar :: FlagName -> PrettyFieldGrammar' PackageFlag #-} - -------------------------------------------------------------------------------- --- SourceRepo -------------------------------------------------------------------------------- - -sourceRepoFieldGrammar - :: (FieldGrammar c g, Applicative (g SourceRepo), c (Identity RepoType), c Token, c FilePathNT) - => RepoKind -> g SourceRepo SourceRepo -sourceRepoFieldGrammar kind = SourceRepo kind - <$> optionalField "type" L.repoType - <*> freeTextField "location" L.repoLocation - <*> optionalFieldAla "module" Token L.repoModule - <*> optionalFieldAla "branch" Token L.repoBranch - <*> optionalFieldAla "tag" Token L.repoTag - <*> optionalFieldAla "subdir" FilePathNT L.repoSubdir -{-# SPECIALIZE sourceRepoFieldGrammar :: RepoKind -> ParsecFieldGrammar' SourceRepo #-} -{-# SPECIALIZE sourceRepoFieldGrammar :: RepoKind -> PrettyFieldGrammar' SourceRepo #-} - -------------------------------------------------------------------------------- --- SetupBuildInfo -------------------------------------------------------------------------------- - -setupBInfoFieldGrammar - :: (FieldGrammar c g, Functor (g SetupBuildInfo), c (List CommaVCat (Identity Dependency) Dependency)) - => Bool -> g SetupBuildInfo SetupBuildInfo -setupBInfoFieldGrammar def = flip SetupBuildInfo def - <$> monoidalFieldAla "setup-depends" (alaList CommaVCat) L.setupDepends -{-# SPECIALIZE setupBInfoFieldGrammar :: Bool -> ParsecFieldGrammar' SetupBuildInfo #-} -{-# SPECIALIZE setupBInfoFieldGrammar :: Bool -> PrettyFieldGrammar' SetupBuildInfo #-} - -------------------------------------------------------------------------------- --- Define how field values should be formatted for 'pretty'. -------------------------------------------------------------------------------- - -formatDependencyList :: [Dependency] -> List CommaVCat (Identity Dependency) Dependency -formatDependencyList = alaList CommaVCat - -formatMixinList :: [Mixin] -> List CommaVCat (Identity Mixin) Mixin -formatMixinList = alaList CommaVCat - -formatExtraSourceFiles :: [FilePath] -> List VCat FilePathNT FilePath -formatExtraSourceFiles = alaList' VCat FilePathNT - -formatExposedModules :: [ModuleName] -> List VCat (MQuoted ModuleName) ModuleName -formatExposedModules = alaList' VCat MQuoted - -formatHsSourceDirs :: [FilePath] -> List FSep FilePathNT FilePath -formatHsSourceDirs = alaList' FSep FilePathNT - -formatOtherExtensions :: [Extension] -> List FSep (MQuoted Extension) Extension -formatOtherExtensions = alaList' FSep MQuoted - -formatOtherModules :: [ModuleName] -> List VCat (MQuoted ModuleName) ModuleName -formatOtherModules = alaList' VCat MQuoted diff --git a/cabal/Cabal/Distribution/PackageDescription/Parsec.hs b/cabal/Cabal/Distribution/PackageDescription/Parsec.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/PackageDescription/Parsec.hs +++ /dev/null @@ -1,957 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE ScopedTypeVariables #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.PackageDescription.Parsec --- Copyright : Isaac Jones 2003-2005 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This defined parsers and partial pretty printers for the @.cabal@ format. - -module Distribution.PackageDescription.Parsec ( - -- * Package descriptions - readGenericPackageDescription, - parseGenericPackageDescription, - parseGenericPackageDescriptionMaybe, - - -- ** Parsing - ParseResult, - runParseResult, - - -- * New-style spec-version - scanSpecVersion, - - -- ** Supplementary build information - readHookedBuildInfo, - parseHookedBuildInfo, - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Control.Monad.State.Strict (StateT, execStateT) -import Control.Monad.Trans.Class (lift) -import Distribution.CabalSpecVersion -import Distribution.Compat.Lens -import Distribution.FieldGrammar -import Distribution.FieldGrammar.Parsec (NamelessField (..)) -import Distribution.Fields.ConfVar (parseConditionConfVar) -import Distribution.Fields.Field (FieldName, getName) -import Distribution.Fields.LexerMonad (LexWarning, toPWarnings) -import Distribution.Fields.Parser -import Distribution.Fields.ParseResult -import Distribution.PackageDescription -import Distribution.PackageDescription.Configuration (freeVars, transformAllBuildInfos) -import Distribution.PackageDescription.FieldGrammar -import Distribution.PackageDescription.Quirks (patchQuirks) -import Distribution.Parsec (parsec, simpleParsecBS) -import Distribution.Parsec.FieldLineStream (fieldLineStreamFromBS) -import Distribution.Parsec.Position (Position (..), zeroPos) -import Distribution.Parsec.Warning (PWarnType (..)) -import Distribution.Pretty (prettyShow) -import Distribution.Simple.Utils (fromUTF8BS, toUTF8BS) -import Distribution.Types.Mixin (Mixin (..), mkMixin) -import Distribution.Utils.Generic (breakMaybe, unfoldrM, validateUTF8) -import Distribution.Verbosity (Verbosity) -import Distribution.Version (Version, mkVersion, versionNumbers) - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.Map.Strict as Map -import qualified Data.Set as Set -import qualified Distribution.Compat.Newtype as Newtype -import qualified Distribution.Compat.NonEmptySet as NES -import qualified Distribution.Types.BuildInfo.Lens as L -import qualified Distribution.Types.Executable.Lens as L -import qualified Distribution.Types.ForeignLib.Lens as L -import qualified Distribution.Types.GenericPackageDescription.Lens as L -import qualified Distribution.Types.PackageDescription.Lens as L -import qualified Distribution.Types.SetupBuildInfo.Lens as L -import qualified Text.Parsec as P - --- --------------------------------------------------------------- --- Parsing --- --------------------------------------------------------------- - --- | Parse the given package file. -readGenericPackageDescription :: Verbosity -> FilePath -> IO GenericPackageDescription -readGenericPackageDescription = readAndParseFile parseGenericPackageDescription - ------------------------------------------------------------------------------- --- | Parses the given file into a 'GenericPackageDescription'. --- --- In Cabal 1.2 the syntax for package descriptions was changed to a format --- with sections and possibly indented property descriptions. --- -parseGenericPackageDescription :: BS.ByteString -> ParseResult GenericPackageDescription -parseGenericPackageDescription bs = do - -- set scanned version - setCabalSpecVersion ver - - csv <- case ver of - -- if we get too new version, fail right away - Just v -> case cabalSpecFromVersionDigits (versionNumbers v) of - Just csv -> return (Just csv) - Nothing -> parseFatalFailure zeroPos $ - "Unsupported cabal-version " ++ prettyShow v ++ ". See https://github.com/haskell/cabal/issues/4899." - _ -> pure Nothing - - case readFields' bs'' of - Right (fs, lexWarnings) -> do - when patched $ - parseWarning zeroPos PWTQuirkyCabalFile "Legacy cabal file" - -- UTF8 is validated in a prepass step, afterwards parsing is lenient. - parseGenericPackageDescription' csv lexWarnings invalidUtf8 fs - -- TODO: better marshalling of errors - Left perr -> parseFatalFailure pos (show perr) where - ppos = P.errorPos perr - pos = Position (P.sourceLine ppos) (P.sourceColumn ppos) - where - (patched, bs') = patchQuirks bs - ver = scanSpecVersion bs' - - invalidUtf8 = validateUTF8 bs' - - -- if there are invalid utf8 characters, we make the bytestring valid. - bs'' = case invalidUtf8 of - Nothing -> bs' - Just _ -> toUTF8BS (fromUTF8BS bs') - - --- | 'Maybe' variant of 'parseGenericPackageDescription' -parseGenericPackageDescriptionMaybe :: BS.ByteString -> Maybe GenericPackageDescription -parseGenericPackageDescriptionMaybe = - either (const Nothing) Just . snd . runParseResult . parseGenericPackageDescription - -fieldlinesToBS :: [FieldLine ann] -> BS.ByteString -fieldlinesToBS = BS.intercalate "\n" . map (\(FieldLine _ bs) -> bs) - --- Monad in which sections are parsed -type SectionParser = StateT SectionS ParseResult - --- | State of section parser -data SectionS = SectionS - { _stateGpd :: !GenericPackageDescription - , _stateCommonStanzas :: !(Map String CondTreeBuildInfo) - } - -stateGpd :: Lens' SectionS GenericPackageDescription -stateGpd f (SectionS gpd cs) = (\x -> SectionS x cs) <$> f gpd -{-# INLINE stateGpd #-} - -stateCommonStanzas :: Lens' SectionS (Map String CondTreeBuildInfo) -stateCommonStanzas f (SectionS gpd cs) = SectionS gpd <$> f cs -{-# INLINE stateCommonStanzas #-} - --- Note [Accumulating parser] --- --- This parser has two "states": --- * first we parse fields of PackageDescription --- * then we parse sections (libraries, executables, etc) -parseGenericPackageDescription' - :: Maybe CabalSpecVersion - -> [LexWarning] - -> Maybe Int - -> [Field Position] - -> ParseResult GenericPackageDescription -parseGenericPackageDescription' scannedVer lexWarnings utf8WarnPos fs = do - parseWarnings (toPWarnings lexWarnings) - for_ utf8WarnPos $ \pos -> - parseWarning zeroPos PWTUTF $ "UTF8 encoding problem at byte offset " ++ show pos - let (syntax, fs') = sectionizeFields fs - let (fields, sectionFields) = takeFields fs' - - -- cabal-version - specVer <- case scannedVer of - Just v -> return v - Nothing -> case Map.lookup "cabal-version" fields >>= safeLast of - Nothing -> return CabalSpecV1_0 - Just (MkNamelessField pos fls) -> do - -- version will be parsed twice, therefore we parse without warnings. - v <- withoutWarnings $ - Newtype.unpack' SpecVersion <$> - -- Use version with || and && but before addition of ^>= and removal of -any - runFieldParser pos parsec CabalSpecV1_24 fls - - -- if it were at the beginning, scanner would found it - when (v >= CabalSpecV2_2) $ parseFailure pos $ - "cabal-version should be at the beginning of the file starting with spec version 2.2. " ++ - "See https://github.com/haskell/cabal/issues/4899" - - return v - - -- reset cabal version, it might not be set - let specVer' = mkVersion (cabalSpecToVersionDigits specVer) - setCabalSpecVersion (Just specVer') - - -- Package description - pd <- parseFieldGrammar specVer fields packageDescriptionFieldGrammar - - -- Check that scanned and parsed versions match. - unless (specVer == specVersion pd) $ parseFailure zeroPos $ - "Scanned and parsed cabal-versions don't match " ++ - prettyShow (SpecVersion specVer) ++ " /= " ++ prettyShow (SpecVersion (specVersion pd)) - - maybeWarnCabalVersion syntax pd - - -- Sections - let gpd = emptyGenericPackageDescription - & L.packageDescription .~ pd - gpd1 <- view stateGpd <$> execStateT (goSections specVer sectionFields) (SectionS gpd Map.empty) - - let gpd2 = postProcessInternalDeps specVer gpd1 - checkForUndefinedFlags gpd2 - gpd2 `deepseq` return gpd2 - where - safeLast :: [a] -> Maybe a - safeLast = listToMaybe . reverse - - newSyntaxVersion :: CabalSpecVersion - newSyntaxVersion = CabalSpecV1_2 - - maybeWarnCabalVersion :: Syntax -> PackageDescription -> ParseResult () - maybeWarnCabalVersion syntax pkg - | syntax == NewSyntax && specVersion pkg < newSyntaxVersion - = parseWarning zeroPos PWTNewSyntax $ - "A package using section syntax must specify at least\n" - ++ "'cabal-version: >= 1.2'." - - maybeWarnCabalVersion syntax pkg - | syntax == OldSyntax && specVersion pkg >= newSyntaxVersion - = parseWarning zeroPos PWTOldSyntax $ - "A package using 'cabal-version: " - ++ prettyShow (SpecVersion (specVersion pkg)) - ++ "' must use section syntax. See the Cabal user guide for details." - - maybeWarnCabalVersion _ _ = return () - -goSections :: CabalSpecVersion -> [Field Position] -> SectionParser () -goSections specVer = traverse_ process - where - process (Field (Name pos name) _) = - lift $ parseWarning pos PWTTrailingFields $ - "Ignoring trailing fields after sections: " ++ show name - process (Section name args secFields) = - parseSection name args secFields - - snoc x xs = xs ++ [x] - - hasCommonStanzas = specHasCommonStanzas specVer - - -- we need signature, because this is polymorphic, but not-closed - parseCondTree' - :: L.HasBuildInfo a - => ParsecFieldGrammar' a -- ^ grammar - -> (BuildInfo -> a) - -> Map String CondTreeBuildInfo -- ^ common stanzas - -> [Field Position] - -> ParseResult (CondTree ConfVar [Dependency] a) - parseCondTree' = parseCondTreeWithCommonStanzas specVer - - parseSection :: Name Position -> [SectionArg Position] -> [Field Position] -> SectionParser () - parseSection (Name pos name) args fields - | hasCommonStanzas == NoCommonStanzas, name == "common" = lift $ do - parseWarning pos PWTUnknownSection $ "Ignoring section: common. You should set cabal-version: 2.2 or larger to use common stanzas." - - | name == "common" = do - commonStanzas <- use stateCommonStanzas - name' <- lift $ parseCommonName pos args - biTree <- lift $ parseCondTree' buildInfoFieldGrammar id commonStanzas fields - - case Map.lookup name' commonStanzas of - Nothing -> stateCommonStanzas .= Map.insert name' biTree commonStanzas - Just _ -> lift $ parseFailure pos $ - "Duplicate common stanza: " ++ name' - - | name == "library" && null args = do - prev <- use $ stateGpd . L.condLibrary - when (isJust prev) $ lift $ parseFailure pos $ - "Multiple main libraries; have you forgotten to specify a name for an internal library?" - - commonStanzas <- use stateCommonStanzas - let name'' = LMainLibName - lib <- lift $ parseCondTree' (libraryFieldGrammar name'') (libraryFromBuildInfo name'') commonStanzas fields - -- - -- TODO check that not set - stateGpd . L.condLibrary ?= lib - - -- Sublibraries - -- TODO: check cabal-version - | name == "library" = do - commonStanzas <- use stateCommonStanzas - name' <- parseUnqualComponentName pos args - let name'' = LSubLibName name' - lib <- lift $ parseCondTree' (libraryFieldGrammar name'') (libraryFromBuildInfo name'') commonStanzas fields - -- TODO check duplicate name here? - stateGpd . L.condSubLibraries %= snoc (name', lib) - - -- TODO: check cabal-version - | name == "foreign-library" = do - commonStanzas <- use stateCommonStanzas - name' <- parseUnqualComponentName pos args - flib <- lift $ parseCondTree' (foreignLibFieldGrammar name') (fromBuildInfo' name') commonStanzas fields - - let hasType ts = foreignLibType ts /= foreignLibType mempty - unless (onAllBranches hasType flib) $ lift $ parseFailure pos $ concat - [ "Foreign library " ++ show (prettyShow name') - , " is missing required field \"type\" or the field " - , "is not present in all conditional branches. The " - , "available test types are: " - , intercalate ", " (map prettyShow knownForeignLibTypes) - ] - - -- TODO check duplicate name here? - stateGpd . L.condForeignLibs %= snoc (name', flib) - - | name == "executable" = do - commonStanzas <- use stateCommonStanzas - name' <- parseUnqualComponentName pos args - exe <- lift $ parseCondTree' (executableFieldGrammar name') (fromBuildInfo' name') commonStanzas fields - -- TODO check duplicate name here? - stateGpd . L.condExecutables %= snoc (name', exe) - - | name == "test-suite" = do - commonStanzas <- use stateCommonStanzas - name' <- parseUnqualComponentName pos args - testStanza <- lift $ parseCondTree' testSuiteFieldGrammar (fromBuildInfo' name') commonStanzas fields - testSuite <- lift $ traverse (validateTestSuite pos) testStanza - - let hasType ts = testInterface ts /= testInterface mempty - unless (onAllBranches hasType testSuite) $ lift $ parseFailure pos $ concat - [ "Test suite " ++ show (prettyShow name') - , " is missing required field \"type\" or the field " - , "is not present in all conditional branches. The " - , "available test types are: " - , intercalate ", " (map prettyShow knownTestTypes) - ] - - -- TODO check duplicate name here? - stateGpd . L.condTestSuites %= snoc (name', testSuite) - - | name == "benchmark" = do - commonStanzas <- use stateCommonStanzas - name' <- parseUnqualComponentName pos args - benchStanza <- lift $ parseCondTree' benchmarkFieldGrammar (fromBuildInfo' name') commonStanzas fields - bench <- lift $ traverse (validateBenchmark pos) benchStanza - - let hasType ts = benchmarkInterface ts /= benchmarkInterface mempty - unless (onAllBranches hasType bench) $ lift $ parseFailure pos $ concat - [ "Benchmark " ++ show (prettyShow name') - , " is missing required field \"type\" or the field " - , "is not present in all conditional branches. The " - , "available benchmark types are: " - , intercalate ", " (map prettyShow knownBenchmarkTypes) - ] - - -- TODO check duplicate name here? - stateGpd . L.condBenchmarks %= snoc (name', bench) - - | name == "flag" = do - name' <- parseNameBS pos args - name'' <- lift $ runFieldParser' [pos] parsec specVer (fieldLineStreamFromBS name') `recoverWith` mkFlagName "" - flag <- lift $ parseFields specVer fields (flagFieldGrammar name'') - -- Check default flag - stateGpd . L.genPackageFlags %= snoc flag - - | name == "custom-setup" && null args = do - sbi <- lift $ parseFields specVer fields (setupBInfoFieldGrammar False) - stateGpd . L.packageDescription . L.setupBuildInfo ?= sbi - - | name == "source-repository" = do - kind <- lift $ case args of - [SecArgName spos secName] -> - runFieldParser' [spos] parsec specVer (fieldLineStreamFromBS secName) `recoverWith` RepoHead - [] -> do - parseFailure pos "'source-repository' requires exactly one argument" - pure RepoHead - _ -> do - parseFailure pos $ "Invalid source-repository kind " ++ show args - pure RepoHead - - sr <- lift $ parseFields specVer fields (sourceRepoFieldGrammar kind) - stateGpd . L.packageDescription . L.sourceRepos %= snoc sr - - | otherwise = lift $ - parseWarning pos PWTUnknownSection $ "Ignoring section: " ++ show name - -parseName :: Position -> [SectionArg Position] -> SectionParser String -parseName pos args = fromUTF8BS <$> parseNameBS pos args - -parseNameBS :: Position -> [SectionArg Position] -> SectionParser BS.ByteString --- TODO: use strict parser -parseNameBS pos args = case args of - [SecArgName _pos secName] -> - pure secName - [SecArgStr _pos secName] -> - pure secName - [] -> do - lift $ parseFailure pos "name required" - pure "" - _ -> do - -- TODO: pretty print args - lift $ parseFailure pos $ "Invalid name " ++ show args - pure "" - -parseCommonName :: Position -> [SectionArg Position] -> ParseResult String -parseCommonName pos args = case args of - [SecArgName _pos secName] -> - pure $ fromUTF8BS secName - [SecArgStr _pos secName] -> - pure $ fromUTF8BS secName - [] -> do - parseFailure pos $ "name required" - pure "" - _ -> do - -- TODO: pretty print args - parseFailure pos $ "Invalid name " ++ show args - pure "" - --- TODO: avoid conversion to 'String'. -parseUnqualComponentName :: Position -> [SectionArg Position] -> SectionParser UnqualComponentName -parseUnqualComponentName pos args = mkUnqualComponentName <$> parseName pos args - --- | Parse a non-recursive list of fields. -parseFields - :: CabalSpecVersion - -> [Field Position] -- ^ fields to be parsed - -> ParsecFieldGrammar' a - -> ParseResult a -parseFields v fields grammar = do - let (fs0, ss) = partitionFields fields - traverse_ (traverse_ warnInvalidSubsection) ss - parseFieldGrammar v fs0 grammar - -warnInvalidSubsection :: Section Position -> ParseResult () -warnInvalidSubsection (MkSection (Name pos name) _ _) = - void $ parseFailure pos $ "invalid subsection " ++ show name - -parseCondTree - :: forall a. L.HasBuildInfo a - => CabalSpecVersion - -> HasElif -- ^ accept @elif@ - -> ParsecFieldGrammar' a -- ^ grammar - -> Map String CondTreeBuildInfo -- ^ common stanzas - -> (BuildInfo -> a) -- ^ constructor from buildInfo - -> (a -> [Dependency]) -- ^ condition extractor - -> [Field Position] - -> ParseResult (CondTree ConfVar [Dependency] a) -parseCondTree v hasElif grammar commonStanzas fromBuildInfo cond = go - where - go fields0 = do - (fields, endo) <- - if v >= CabalSpecV3_0 - then processImports v fromBuildInfo commonStanzas fields0 - else traverse (warnImport v) fields0 >>= \fields1 -> return (catMaybes fields1, id) - - let (fs, ss) = partitionFields fields - x <- parseFieldGrammar v fs grammar - branches <- concat <$> traverse parseIfs ss - return $ endo $ CondNode x (cond x) branches - - parseIfs :: [Section Position] -> ParseResult [CondBranch ConfVar [Dependency] a] - parseIfs [] = return [] - parseIfs (MkSection (Name _ name) test fields : sections) | name == "if" = do - test' <- parseConditionConfVar test - fields' <- go fields - (elseFields, sections') <- parseElseIfs sections - return (CondBranch test' fields' elseFields : sections') - parseIfs (MkSection (Name pos name) _ _ : sections) = do - parseWarning pos PWTInvalidSubsection $ "invalid subsection " ++ show name - parseIfs sections - - parseElseIfs - :: [Section Position] - -> ParseResult (Maybe (CondTree ConfVar [Dependency] a), [CondBranch ConfVar [Dependency] a]) - parseElseIfs [] = return (Nothing, []) - parseElseIfs (MkSection (Name pos name) args fields : sections) | name == "else" = do - unless (null args) $ - parseFailure pos $ "`else` section has section arguments " ++ show args - elseFields <- go fields - sections' <- parseIfs sections - return (Just elseFields, sections') - - parseElseIfs (MkSection (Name _ name) test fields : sections) | hasElif == HasElif, name == "elif" = do - test' <- parseConditionConfVar test - fields' <- go fields - (elseFields, sections') <- parseElseIfs sections - -- we parse an empty 'Fields', to get empty value for a node - a <- parseFieldGrammar v mempty grammar - return (Just $ CondNode a (cond a) [CondBranch test' fields' elseFields], sections') - - parseElseIfs (MkSection (Name pos name) _ _ : sections) | name == "elif" = do - parseWarning pos PWTInvalidSubsection $ "invalid subsection \"elif\". You should set cabal-version: 2.2 or larger to use elif-conditionals." - (,) Nothing <$> parseIfs sections - - parseElseIfs sections = (,) Nothing <$> parseIfs sections - -{- Note [Accumulating parser] - -Note: Outdated a bit - -In there parser, @'FieldDescr' a@ is transformed into @Map FieldName (a -> -FieldParser a)@. The weird value is used because we accumulate structure of -@a@ by folding over the fields. There are various reasons for that: - -* Almost all fields are optional - -* This is simple approach so declarative bi-directional format (parsing and -printing) of structure could be specified (list of @'FieldDescr' a@) - -* There are surface syntax fields corresponding to single field in the file: - @license-file@ and @license-files@ - -* This is quite safe approach. - -When/if we re-implement the parser to support formatting preservging roundtrip -with new AST, this all need to be rewritten. --} - -------------------------------------------------------------------------------- --- Common stanzas -------------------------------------------------------------------------------- - --- $commonStanzas --- --- [Note: Common stanzas] --- --- In Cabal 2.2 we support simple common stanzas: --- --- * Commons stanzas define 'BuildInfo' --- --- * import "fields" can only occur at top of other stanzas (think: imports) --- --- In particular __there aren't__ --- --- * implicit stanzas --- --- * More specific common stanzas (executable, test-suite). --- --- --- The approach uses the fact that 'BuildInfo' is a 'Monoid': --- --- @ --- mergeCommonStanza' :: HasBuildInfo comp => BuildInfo -> comp -> comp --- mergeCommonStanza' bi = over L.BuildInfo (bi <>) --- @ --- --- Real 'mergeCommonStanza' is more complicated as we have to deal with --- conditional trees. --- --- The approach is simple, and have good properties: --- --- * Common stanzas are parsed exactly once, even if not-used. Thus we report errors in them. --- -type CondTreeBuildInfo = CondTree ConfVar [Dependency] BuildInfo - --- | Create @a@ from 'BuildInfo'. --- This class is used to implement common stanza parsing. --- --- Law: @view buildInfo . fromBuildInfo = id@ --- --- This takes name, as 'FieldGrammar's take names too. -class L.HasBuildInfo a => FromBuildInfo a where - fromBuildInfo' :: UnqualComponentName -> BuildInfo -> a - -libraryFromBuildInfo :: LibraryName -> BuildInfo -> Library -libraryFromBuildInfo n bi = emptyLibrary - { libName = n - , libVisibility = case n of - LMainLibName -> LibraryVisibilityPublic - LSubLibName _ -> LibraryVisibilityPrivate - , libBuildInfo = bi - } - -instance FromBuildInfo BuildInfo where fromBuildInfo' _ = id -instance FromBuildInfo ForeignLib where fromBuildInfo' n bi = set L.foreignLibName n $ set L.buildInfo bi emptyForeignLib -instance FromBuildInfo Executable where fromBuildInfo' n bi = set L.exeName n $ set L.buildInfo bi emptyExecutable - -instance FromBuildInfo TestSuiteStanza where - fromBuildInfo' _ bi = TestSuiteStanza Nothing Nothing Nothing bi - -instance FromBuildInfo BenchmarkStanza where - fromBuildInfo' _ bi = BenchmarkStanza Nothing Nothing Nothing bi - -parseCondTreeWithCommonStanzas - :: forall a. L.HasBuildInfo a - => CabalSpecVersion - -> ParsecFieldGrammar' a -- ^ grammar - -> (BuildInfo -> a) -- ^ construct fromBuildInfo - -> Map String CondTreeBuildInfo -- ^ common stanzas - -> [Field Position] - -> ParseResult (CondTree ConfVar [Dependency] a) -parseCondTreeWithCommonStanzas v grammar fromBuildInfo commonStanzas fields = do - (fields', endo) <- processImports v fromBuildInfo commonStanzas fields - x <- parseCondTree v hasElif grammar commonStanzas fromBuildInfo (view L.targetBuildDepends) fields' - return (endo x) - where - hasElif = specHasElif v - -processImports - :: forall a. L.HasBuildInfo a - => CabalSpecVersion - -> (BuildInfo -> a) -- ^ construct fromBuildInfo - -> Map String CondTreeBuildInfo -- ^ common stanzas - -> [Field Position] - -> ParseResult ([Field Position], CondTree ConfVar [Dependency] a -> CondTree ConfVar [Dependency] a) -processImports v fromBuildInfo commonStanzas = go [] - where - hasCommonStanzas = specHasCommonStanzas v - - getList' :: List CommaFSep Token String -> [String] - getList' = Newtype.unpack - - go acc (Field (Name pos name) _ : fields) | name == "import", hasCommonStanzas == NoCommonStanzas = do - parseWarning pos PWTUnknownField "Unknown field: import. You should set cabal-version: 2.2 or larger to use common stanzas" - go acc fields - -- supported: - go acc (Field (Name pos name) fls : fields) | name == "import" = do - names <- getList' <$> runFieldParser pos parsec v fls - names' <- for names $ \commonName -> - case Map.lookup commonName commonStanzas of - Nothing -> do - parseFailure pos $ "Undefined common stanza imported: " ++ commonName - pure Nothing - Just commonTree -> - pure (Just commonTree) - - go (acc ++ catMaybes names') fields - - -- parse actual CondTree - go acc fields = do - fields' <- catMaybes <$> traverse (warnImport v) fields - pure $ (fields', \x -> foldr (mergeCommonStanza fromBuildInfo) x acc) - --- | Warn on "import" fields, also map to Maybe, so errorneous fields can be filtered -warnImport :: CabalSpecVersion -> Field Position -> ParseResult (Maybe (Field Position)) -warnImport v (Field (Name pos name) _) | name == "import" = do - if specHasCommonStanzas v == NoCommonStanzas - then parseWarning pos PWTUnknownField "Unknown field: import. You should set cabal-version: 2.2 or larger to use common stanzas" - else parseWarning pos PWTUnknownField "Unknown field: import. Common stanza imports should be at the top of the enclosing section" - return Nothing -warnImport _ f = pure (Just f) - -mergeCommonStanza - :: L.HasBuildInfo a - => (BuildInfo -> a) - -> CondTree ConfVar [Dependency] BuildInfo - -> CondTree ConfVar [Dependency] a - -> CondTree ConfVar [Dependency] a -mergeCommonStanza fromBuildInfo (CondNode bi _ bis) (CondNode x _ cs) = - CondNode x' (x' ^. L.targetBuildDepends) cs' - where - -- new value is old value with buildInfo field _prepended_. - x' = x & L.buildInfo %~ (bi <>) - - -- tree components are appended together. - cs' = map (fmap fromBuildInfo) bis ++ cs - -------------------------------------------------------------------------------- --- Branches -------------------------------------------------------------------------------- - --- Check that a property holds on all branches of a condition tree -onAllBranches :: forall v c a. Monoid a => (a -> Bool) -> CondTree v c a -> Bool -onAllBranches p = go mempty - where - -- If the current level of the tree satisfies the property, then we are - -- done. If not, then one of the conditional branches below the current node - -- must satisfy it. Each node may have multiple immediate children; we only - -- one need one to satisfy the property because the configure step uses - -- 'mappend' to join together the results of flag resolution. - go :: a -> CondTree v c a -> Bool - go acc ct = let acc' = acc `mappend` condTreeData ct - in p acc' || any (goBranch acc') (condTreeComponents ct) - - -- Both the 'true' and the 'false' block must satisfy the property. - goBranch :: a -> CondBranch v c a -> Bool - goBranch _ (CondBranch _ _ Nothing) = False - goBranch acc (CondBranch _ t (Just e)) = go acc t && go acc e - -------------------------------------------------------------------------------- --- Flag check -------------------------------------------------------------------------------- - -checkForUndefinedFlags :: GenericPackageDescription -> ParseResult () -checkForUndefinedFlags gpd = do - let definedFlags, usedFlags :: Set.Set FlagName - definedFlags = toSetOf (L.genPackageFlags . traverse . getting flagName) gpd - usedFlags = getConst $ L.allCondTrees f gpd - - -- Note: we can check for defined, but unused flags here too. - unless (usedFlags `Set.isSubsetOf` definedFlags) $ parseFailure zeroPos $ - "These flags are used without having been defined: " ++ - intercalate ", " [ unFlagName fn | fn <- Set.toList $ usedFlags `Set.difference` definedFlags ] - where - f :: CondTree ConfVar c a -> Const (Set.Set FlagName) (CondTree ConfVar c a) - f ct = Const (Set.fromList (freeVars ct)) - -------------------------------------------------------------------------------- --- Post processing of internal dependencies -------------------------------------------------------------------------------- - --- Note [Dependencies on sublibraries] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- This is solution to https://github.com/haskell/cabal/issues/6083 --- --- Before 'cabal-version: 3.0' we didn't have a syntax specially --- for referring to internal libraries. Internal library names --- shadowed the outside ones. --- --- Since 'cabal-version: 3.0' we have ability to write --- --- build-depends: some-package:its-sub-lib >=1.2.3 --- --- This allows us to refer also to local packages by `this-package:sublib`. --- So since 'cabal-version: 3.4' to refer to *any* --- sublibrary we must use the two part syntax. Here's small table: --- --- | pre-3.4 | 3.4 and after | --- ------------------|---------------------|-------------------------------| --- pkg-name | may refer to sublib | always refers to external pkg | --- pkg-name:sublib | refers to sublib | refers to sublib | --- pkg-name:pkg-name | may refer to sublib | always refers to external pkg | --- --- In pre-3.4 case, if a package 'this-pkg' has a sublibrary 'pkg-name', --- all dependency definitions will refer to that sublirary. --- --- In 3.4 and after case, 'pkg-name' will always refer to external package, --- and to use internal library you have to say 'this-pkg:pkg-name'. --- --- In summary, In 3.4 and after, the internal names don't shadow, --- as there is an explicit syntax to refer to them, --- i.e. what you write is what you get; --- For pre-3.4 we post-process the file. --- --- Similarly, we process mixins. --- See https://github.com/haskell/cabal/issues/6281 --- - -postProcessInternalDeps :: CabalSpecVersion -> GenericPackageDescription -> GenericPackageDescription -postProcessInternalDeps specVer gpd - | specVer >= CabalSpecV3_4 = gpd - | otherwise = transformAllBuildInfos transformBI transformSBI gpd - where - transformBI :: BuildInfo -> BuildInfo - transformBI - = over L.targetBuildDepends (concatMap transformD) - . over L.mixins (map transformM) - - transformSBI :: SetupBuildInfo -> SetupBuildInfo - transformSBI = over L.setupDepends (concatMap transformD) - - transformD :: Dependency -> [Dependency] - transformD (Dependency pn vr ln) - | uqn `Set.member` internalLibs - , LMainLibName `NES.member` ln - = case NES.delete LMainLibName ln of - Nothing -> [dep] - Just ln' -> [dep, Dependency pn vr ln'] - where - uqn = packageNameToUnqualComponentName pn - dep = Dependency thisPn vr (NES.singleton (LSubLibName uqn)) - - transformD d = [d] - - transformM :: Mixin -> Mixin - transformM (Mixin pn LMainLibName incl) - | uqn `Set.member` internalLibs - = mkMixin thisPn (LSubLibName uqn) incl - where - uqn = packageNameToUnqualComponentName pn - - transformM m = m - - thisPn :: PackageName - thisPn = pkgName (package (packageDescription gpd)) - - internalLibs :: Set UnqualComponentName - internalLibs = Set.fromList - [ n - | (n, _) <- condSubLibraries gpd - ] - -------------------------------------------------------------------------------- --- Old syntax -------------------------------------------------------------------------------- - --- TODO: move to own module - --- | "Sectionize" an old-style Cabal file. A sectionized file has: --- --- * all global fields at the beginning, followed by --- --- * all flag declarations, followed by --- --- * an optional library section, and an arbitrary number of executable --- sections (in any order). --- --- The current implementation just gathers all library-specific fields --- in a library section and wraps all executable stanzas in an executable --- section. -sectionizeFields :: [Field ann] -> (Syntax, [Field ann]) -sectionizeFields fs = case classifyFields fs of - Just fields -> (OldSyntax, convert fields) - Nothing -> (NewSyntax, fs) - where - -- return 'Just' if all fields are simple fields - classifyFields :: [Field ann] -> Maybe [(Name ann, [FieldLine ann])] - classifyFields = traverse f - where - f (Field name fieldlines) = Just (name, fieldlines) - f _ = Nothing - - trim = BS.dropWhile isSpace' . BS.reverse . BS.dropWhile isSpace' . BS.reverse - isSpace' = (== 32) - - convert :: [(Name ann, [FieldLine ann])] -> [Field ann] - convert fields = - let - toField (name, ls) = Field name ls - -- "build-depends" is a local field now. To be backwards - -- compatible, we still allow it as a global field in old-style - -- package description files and translate it to a local field by - -- adding it to every non-empty section - (hdr0, exes0) = break ((=="executable") . getName . fst) fields - (hdr, libfs0) = partition (not . (`elem` libFieldNames) . getName . fst) hdr0 - - (deps, libfs) = partition ((== "build-depends") . getName . fst) - libfs0 - - exes = unfoldr toExe exes0 - toExe [] = Nothing - toExe ((Name pos n, ls) : r) - | n == "executable" = - let (efs, r') = break ((== "executable") . getName . fst) r - in Just (Section (Name pos "executable") [SecArgName pos $ trim $ fieldlinesToBS ls] (map toField $ deps ++ efs), r') - toExe _ = error "unexpected input to 'toExe'" - - lib = case libfs of - [] -> [] - ((Name pos _, _) : _) -> - [Section (Name pos "library") [] (map toField $ deps ++ libfs)] - - in map toField hdr ++ lib ++ exes - --- | See 'sectionizeFields'. -data Syntax = OldSyntax | NewSyntax - deriving (Eq, Show) - --- TODO: -libFieldNames :: [FieldName] -libFieldNames = fieldGrammarKnownFieldList (libraryFieldGrammar LMainLibName) - -------------------------------------------------------------------------------- --- Suplementary build information -------------------------------------------------------------------------------- - -readHookedBuildInfo :: Verbosity -> FilePath -> IO HookedBuildInfo -readHookedBuildInfo = readAndParseFile parseHookedBuildInfo - -parseHookedBuildInfo :: BS.ByteString -> ParseResult HookedBuildInfo -parseHookedBuildInfo bs = case readFields' bs of - Right (fs, lexWarnings) -> do - parseHookedBuildInfo' lexWarnings fs - -- TODO: better marshalling of errors - Left perr -> parseFatalFailure zeroPos (show perr) - -parseHookedBuildInfo' - :: [LexWarning] - -> [Field Position] - -> ParseResult HookedBuildInfo -parseHookedBuildInfo' lexWarnings fs = do - parseWarnings (toPWarnings lexWarnings) - (mLibFields, exes) <- stanzas fs - mLib <- parseLib mLibFields - biExes <- traverse parseExe exes - return (mLib, biExes) - where - parseLib :: Fields Position -> ParseResult (Maybe BuildInfo) - parseLib fields - | Map.null fields = pure Nothing - | otherwise = Just <$> parseFieldGrammar cabalSpecLatest fields buildInfoFieldGrammar - - parseExe :: (UnqualComponentName, Fields Position) -> ParseResult (UnqualComponentName, BuildInfo) - parseExe (n, fields) = do - bi <- parseFieldGrammar cabalSpecLatest fields buildInfoFieldGrammar - pure (n, bi) - - stanzas :: [Field Position] -> ParseResult (Fields Position, [(UnqualComponentName, Fields Position)]) - stanzas fields = do - let (hdr0, exes0) = breakMaybe isExecutableField fields - hdr <- toFields hdr0 - exes <- unfoldrM (traverse toExe) exes0 - pure (hdr, exes) - - toFields :: [Field Position] -> ParseResult (Fields Position) - toFields fields = do - let (fields', ss) = partitionFields fields - traverse_ (traverse_ warnInvalidSubsection) ss - pure fields' - - toExe - :: ([FieldLine Position], [Field Position]) - -> ParseResult ((UnqualComponentName, Fields Position), Maybe ([FieldLine Position], [Field Position])) - toExe (fss, fields) = do - name <- runFieldParser zeroPos parsec cabalSpecLatest fss - let (hdr0, rest) = breakMaybe isExecutableField fields - hdr <- toFields hdr0 - pure ((name, hdr), rest) - - isExecutableField (Field (Name _ name) fss) - | name == "executable" = Just fss - | otherwise = Nothing - isExecutableField _ = Nothing - -------------------------------------------------------------------------------- --- Scan of spec version -------------------------------------------------------------------------------- - --- | Quickly scan new-style spec-version --- --- A new-style spec-version declaration begins the .cabal file and --- follow the following case-insensitive grammar (expressed in --- RFC5234 ABNF): --- --- @ --- newstyle-spec-version-decl = "cabal-version" *WS ":" *WS newstyle-pec-version *WS --- --- spec-version = NUM "." NUM [ "." NUM ] --- --- NUM = DIGIT0 / DIGITP 1*DIGIT0 --- DIGIT0 = %x30-39 --- DIGITP = %x31-39 --- WS = %20 --- @ --- -scanSpecVersion :: BS.ByteString -> Maybe Version -scanSpecVersion bs = do - fstline':_ <- pure (BS8.lines bs) - - -- parse - -- normalise: remove all whitespace, convert to lower-case - let fstline = BS.map toLowerW8 $ BS.filter (/= 0x20) fstline' - ["cabal-version",vers] <- pure (BS8.split ':' fstline) - - -- parse - -- - -- This is currently more tolerant regarding leading 0 digits. - -- - ver <- simpleParsecBS vers - guard $ case versionNumbers ver of - [_,_] -> True - [_,_,_] -> True - _ -> False - - pure ver - where - -- | Translate ['A'..'Z'] to ['a'..'z'] - toLowerW8 :: Word8 -> Word8 - toLowerW8 w | 0x40 < w && w < 0x5b = w+0x20 - | otherwise = w diff --git a/cabal/Cabal/Distribution/PackageDescription/PrettyPrint.hs b/cabal/Cabal/Distribution/PackageDescription/PrettyPrint.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/PackageDescription/PrettyPrint.hs +++ /dev/null @@ -1,283 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.PackageDescription.PrettyPrint --- Copyright : Jürgen Nicklisch-Franken 2010 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- Pretty printing for cabal files --- ------------------------------------------------------------------------------ - -module Distribution.PackageDescription.PrettyPrint ( - -- * Generic package descriptions - writeGenericPackageDescription, - showGenericPackageDescription, - ppGenericPackageDescription, - - -- * Package descriptions - writePackageDescription, - showPackageDescription, - - -- ** Supplementary build information - writeHookedBuildInfo, - showHookedBuildInfo, -) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.CabalSpecVersion -import Distribution.Fields.Pretty -import Distribution.Compat.Lens -import Distribution.PackageDescription -import Distribution.Pretty -import Distribution.Simple.Utils (writeFileAtomic, writeUTF8File) -import Distribution.Types.Mixin (Mixin (..), mkMixin) -import Distribution.FieldGrammar (PrettyFieldGrammar', prettyFieldGrammar) -import Distribution.PackageDescription.Configuration (transformAllBuildInfos) -import Distribution.PackageDescription.FieldGrammar - (benchmarkFieldGrammar, buildInfoFieldGrammar, executableFieldGrammar, flagFieldGrammar, foreignLibFieldGrammar, libraryFieldGrammar, - packageDescriptionFieldGrammar, setupBInfoFieldGrammar, sourceRepoFieldGrammar, testSuiteFieldGrammar) - -import qualified Distribution.PackageDescription.FieldGrammar as FG -import qualified Distribution.Types.BuildInfo.Lens as L -import qualified Distribution.Types.SetupBuildInfo.Lens as L - -import Text.PrettyPrint (Doc, char, hsep, parens, text) - -import qualified Data.ByteString.Lazy.Char8 as BS.Char8 -import qualified Distribution.Compat.NonEmptySet as NES - --- | Writes a .cabal file from a generic package description -writeGenericPackageDescription :: FilePath -> GenericPackageDescription -> IO () -writeGenericPackageDescription fpath pkg = writeUTF8File fpath (showGenericPackageDescription pkg) - --- | Writes a generic package description to a string -showGenericPackageDescription :: GenericPackageDescription -> String -showGenericPackageDescription gpd = showFields (const []) $ ppGenericPackageDescription v gpd - where - v = specVersion $ packageDescription gpd - --- | Convert a generic package description to 'PrettyField's. -ppGenericPackageDescription :: CabalSpecVersion -> GenericPackageDescription -> [PrettyField ()] -ppGenericPackageDescription v gpd0 = concat - [ ppPackageDescription v (packageDescription gpd) - , ppSetupBInfo v (setupBuildInfo (packageDescription gpd)) - , ppGenPackageFlags v (genPackageFlags gpd) - , ppCondLibrary v (condLibrary gpd) - , ppCondSubLibraries v (condSubLibraries gpd) - , ppCondForeignLibs v (condForeignLibs gpd) - , ppCondExecutables v (condExecutables gpd) - , ppCondTestSuites v (condTestSuites gpd) - , ppCondBenchmarks v (condBenchmarks gpd) - ] - where - gpd = preProcessInternalDeps (specVersion (packageDescription gpd0)) gpd0 - - -ppPackageDescription :: CabalSpecVersion -> PackageDescription -> [PrettyField ()] -ppPackageDescription v pd = - prettyFieldGrammar v packageDescriptionFieldGrammar pd - ++ ppSourceRepos v (sourceRepos pd) - -ppSourceRepos :: CabalSpecVersion -> [SourceRepo] -> [PrettyField ()] -ppSourceRepos = map . ppSourceRepo - -ppSourceRepo :: CabalSpecVersion -> SourceRepo -> PrettyField () -ppSourceRepo v repo = PrettySection () "source-repository" [pretty kind] $ - prettyFieldGrammar v (sourceRepoFieldGrammar kind) repo - where - kind = repoKind repo - -ppSetupBInfo :: CabalSpecVersion -> Maybe SetupBuildInfo -> [PrettyField ()] -ppSetupBInfo _ Nothing = mempty -ppSetupBInfo v (Just sbi) - | defaultSetupDepends sbi = mempty - | otherwise = pure $ PrettySection () "custom-setup" [] $ - prettyFieldGrammar v (setupBInfoFieldGrammar False) sbi - -ppGenPackageFlags :: CabalSpecVersion -> [PackageFlag] -> [PrettyField ()] -ppGenPackageFlags = map . ppFlag - -ppFlag :: CabalSpecVersion -> PackageFlag -> PrettyField () -ppFlag v flag@(MkPackageFlag name _ _ _) = PrettySection () "flag" [ppFlagName name] $ - prettyFieldGrammar v (flagFieldGrammar name) flag - -ppCondTree2 :: CabalSpecVersion -> PrettyFieldGrammar' s -> CondTree ConfVar [Dependency] s -> [PrettyField ()] -ppCondTree2 v grammar = go - where - -- TODO: recognise elif opportunities - go (CondNode it _ ifs) = - prettyFieldGrammar v grammar it ++ - concatMap ppIf ifs - - ppIf (CondBranch c thenTree Nothing) --- | isEmpty thenDoc = mempty - | otherwise = [ppIfCondition c thenDoc] - where - thenDoc = go thenTree - - ppIf (CondBranch c thenTree (Just elseTree)) = - -- See #6193 - [ ppIfCondition c (go thenTree) - , PrettySection () "else" [] (go elseTree) - ] - -ppCondLibrary :: CabalSpecVersion -> Maybe (CondTree ConfVar [Dependency] Library) -> [PrettyField ()] -ppCondLibrary _ Nothing = mempty -ppCondLibrary v (Just condTree) = pure $ PrettySection () "library" [] $ - ppCondTree2 v (libraryFieldGrammar LMainLibName) condTree - -ppCondSubLibraries :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] Library)] -> [PrettyField ()] -ppCondSubLibraries v libs = - [ PrettySection () "library" [pretty n] - $ ppCondTree2 v (libraryFieldGrammar $ LSubLibName n) condTree - | (n, condTree) <- libs - ] - -ppCondForeignLibs :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)] -> [PrettyField ()] -ppCondForeignLibs v flibs = - [ PrettySection () "foreign-library" [pretty n] - $ ppCondTree2 v (foreignLibFieldGrammar n) condTree - | (n, condTree) <- flibs - ] - -ppCondExecutables :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] Executable)] -> [PrettyField ()] -ppCondExecutables v exes = - [ PrettySection () "executable" [pretty n] - $ ppCondTree2 v (executableFieldGrammar n) condTree - | (n, condTree) <- exes - ] - -ppCondTestSuites :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)] -> [PrettyField ()] -ppCondTestSuites v suites = - [ PrettySection () "test-suite" [pretty n] - $ ppCondTree2 v testSuiteFieldGrammar (fmap FG.unvalidateTestSuite condTree) - | (n, condTree) <- suites - ] - -ppCondBenchmarks :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)] -> [PrettyField ()] -ppCondBenchmarks v suites = - [ PrettySection () "benchmark" [pretty n] - $ ppCondTree2 v benchmarkFieldGrammar (fmap FG.unvalidateBenchmark condTree) - | (n, condTree) <- suites - ] - -ppCondition :: Condition ConfVar -> Doc -ppCondition (Var x) = ppConfVar x -ppCondition (Lit b) = text (show b) -ppCondition (CNot c) = char '!' <<>> (ppCondition c) -ppCondition (COr c1 c2) = parens (hsep [ppCondition c1, text "||" - <+> ppCondition c2]) -ppCondition (CAnd c1 c2) = parens (hsep [ppCondition c1, text "&&" - <+> ppCondition c2]) -ppConfVar :: ConfVar -> Doc -ppConfVar (OS os) = text "os" <<>> parens (pretty os) -ppConfVar (Arch arch) = text "arch" <<>> parens (pretty arch) -ppConfVar (PackageFlag name) = text "flag" <<>> parens (ppFlagName name) -ppConfVar (Impl c v) = text "impl" <<>> parens (pretty c <+> pretty v) - -ppFlagName :: FlagName -> Doc -ppFlagName = text . unFlagName - -ppIfCondition :: Condition ConfVar -> [PrettyField ()] -> PrettyField () -ppIfCondition c = PrettySection () "if" [ppCondition c] - --- | @since 2.0.0.2 -writePackageDescription :: FilePath -> PackageDescription -> IO () -writePackageDescription fpath pkg = writeUTF8File fpath (showPackageDescription pkg) - ---TODO: make this use section syntax --- add equivalent for GenericPackageDescription - --- | @since 2.0.0.2 -showPackageDescription :: PackageDescription -> String -showPackageDescription = showGenericPackageDescription . pdToGpd - -pdToGpd :: PackageDescription -> GenericPackageDescription -pdToGpd pd = GenericPackageDescription - { packageDescription = pd - , gpdScannedVersion = Nothing - , genPackageFlags = [] - , condLibrary = mkCondTree <$> library pd - , condSubLibraries = mkCondTreeL <$> subLibraries pd - , condForeignLibs = mkCondTree' foreignLibName <$> foreignLibs pd - , condExecutables = mkCondTree' exeName <$> executables pd - , condTestSuites = mkCondTree' testName <$> testSuites pd - , condBenchmarks = mkCondTree' benchmarkName <$> benchmarks pd - } - where - -- We set CondTree's [Dependency] to an empty list, as it - -- is not pretty printed anyway. - mkCondTree x = CondNode x [] [] - mkCondTreeL l = (fromMaybe (mkUnqualComponentName "") (libraryNameString (libName l)), CondNode l [] []) - - mkCondTree' - :: (a -> UnqualComponentName) - -> a -> (UnqualComponentName, CondTree ConfVar [Dependency] a) - mkCondTree' f x = (f x, CondNode x [] []) - -------------------------------------------------------------------------------- --- Internal libs -------------------------------------------------------------------------------- - --- See Note [Dependencies on sublibraries] in Distribution.PackageDescription.Parsec --- -preProcessInternalDeps :: CabalSpecVersion -> GenericPackageDescription -> GenericPackageDescription -preProcessInternalDeps specVer gpd - | specVer >= CabalSpecV3_4 = gpd - | otherwise = transformAllBuildInfos transformBI transformSBI gpd - where - transformBI :: BuildInfo -> BuildInfo - transformBI - = over L.targetBuildDepends (concatMap transformD) - . over L.mixins (map transformM) - - transformSBI :: SetupBuildInfo -> SetupBuildInfo - transformSBI = over L.setupDepends (concatMap transformD) - - transformD :: Dependency -> [Dependency] - transformD (Dependency pn vr ln) - | pn == thisPn - = if LMainLibName `NES.member` ln - then Dependency thisPn vr mainLibSet : sublibs - else sublibs - where - sublibs = - [ Dependency (unqualComponentNameToPackageName uqn) vr mainLibSet - | LSubLibName uqn <- NES.toList ln - ] - - transformD d = [d] - - transformM :: Mixin -> Mixin - transformM (Mixin pn (LSubLibName uqn) inc) - | pn == thisPn - = mkMixin (unqualComponentNameToPackageName uqn) LMainLibName inc - transformM m = m - - thisPn :: PackageName - thisPn = pkgName (package (packageDescription gpd)) - -------------------------------------------------------------------------------- --- HookedBuildInfo -------------------------------------------------------------------------------- - --- | @since 2.0.0.2 -writeHookedBuildInfo :: FilePath -> HookedBuildInfo -> IO () -writeHookedBuildInfo fpath = writeFileAtomic fpath . BS.Char8.pack - . showHookedBuildInfo - --- | @since 2.0.0.2 -showHookedBuildInfo :: HookedBuildInfo -> String -showHookedBuildInfo (mb_lib_bi, ex_bis) = showFields (const []) $ - maybe mempty (prettyFieldGrammar cabalSpecLatest buildInfoFieldGrammar) mb_lib_bi ++ - [ PrettySection () "executable:" [pretty name] - $ prettyFieldGrammar cabalSpecLatest buildInfoFieldGrammar bi - | (name, bi) <- ex_bis - ] diff --git a/cabal/Cabal/Distribution/PackageDescription/Quirks.hs b/cabal/Cabal/Distribution/PackageDescription/Quirks.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/PackageDescription/Quirks.hs +++ /dev/null @@ -1,319 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} --- | --- --- @since 2.2.0.0 -module Distribution.PackageDescription.Quirks (patchQuirks) where - -import Distribution.Compat.Prelude -import Distribution.Utils.MD5 -import GHC.Fingerprint (Fingerprint (..)) -import Prelude () - -import qualified Data.ByteString as BS -import qualified Data.Map as Map - --- | Patch legacy @.cabal@ file contents to allow parsec parser to accept --- all of Hackage. --- --- Bool part of the result tells whether the output is modified. --- --- @since 2.2.0.0 -patchQuirks :: BS.ByteString -> (Bool, BS.ByteString) -patchQuirks bs = case Map.lookup (BS.take 256 bs, md5 bs) patches of - Nothing -> (False, bs) - Just (post, f) - | post /= md5 output -> (False, bs) - | otherwise -> (True, output) - where - output = f bs - --- | 'patches' contains first 256 bytes, pre- and post-fingerprints and a patch function. -patches :: Map.Map (BS.ByteString, Fingerprint) (Fingerprint, BS.ByteString -> BS.ByteString) -patches = Map.fromList - -- http://hackage.haskell.org/package/unicode-transforms-0.3.3 - -- other-modules: . - -- ReadP assumed dot is empty line - [ mk "-- This file has been generated from package.yaml by hpack version 0.17.0.\n--\n-- see: https://github.com/sol/hpack\n\nname: unicode-transforms\nversion: 0.3.3\nsynopsis: Unicode normalization\ndescription: Fast Unic" - (Fingerprint 15958160436627155571 10318709190730872881) - (Fingerprint 11008465475756725834 13815629925116264363) - (bsRemove " other-modules:\n .\n") -- TODO: remove traling \n to test structural-diff - -- http://hackage.haskell.org/package/DSTM-0.1.2 - -- http://hackage.haskell.org/package/DSTM-0.1.1 - -- http://hackage.haskell.org/package/DSTM-0.1 - -- Other Modules: no dash - -- ReadP parsed as section - , mk "Name: DSTM\nVersion: 0.1.2\nCopyright: (c) 2010, Frank Kupke\nLicense: LGPL\nLicense-File: LICENSE\nAuthor: Frank Kupke\nMaintainer: frk@informatik.uni-kiel.de\nCabal-Version: >= 1.2.3\nStability: provisional\nSynopsis: A framework for using STM within distributed " - (Fingerprint 6919263071548559054 9050746360708965827) - (Fingerprint 17015177514298962556 11943164891661867280) - (bsReplace "Other modules:" "-- ") - , mk "Name: DSTM\nVersion: 0.1.1\nCopyright: (c) 2010, Frank Kupke\nLicense: LGPL\nLicense-File: LICENSE\nAuthor: Frank Kupke\nMaintainer: frk@informatik.uni-kiel.de\nCabal-Version: >= 1.2.3\nStability: provisional\nSynopsis: A framework for using STM within distributed " - (Fingerprint 17313105789069667153 9610429408495338584) - (Fingerprint 17250946493484671738 17629939328766863497) - (bsReplace "Other modules:" "-- ") - , mk "Name: DSTM\nVersion: 0.1\nCopyright: (c) 2010, Frank Kupke\nLicense: LGPL\nLicense-File: LICENSE\nAuthor: Frank Kupke\nMaintainer: frk@informatik.uni-kiel.de\nCabal-Version: >= 1.2.3\nStability: provisional\nSynopsis: A framework for using STM within distributed sy" - (Fingerprint 10502599650530614586 16424112934471063115) - (Fingerprint 13562014713536696107 17899511905611879358) - (bsReplace "Other modules:" "-- ") - -- http://hackage.haskell.org/package/control-monad-exception-mtl-0.10.3 - , mk "name: control-monad-exception-mtl\nversion: 0.10.3\nCabal-Version: >= 1.10\nbuild-type: Simple\nlicense: PublicDomain\nauthor: Pepe Iborra\nmaintainer: pepeiborra@gmail.com\nhomepage: http://pepeiborra.github.com/control-monad-exception\nsynopsis: MTL instances f" - (Fingerprint 18274748422558568404 4043538769550834851) - (Fingerprint 11395257416101232635 4303318131190196308) - (bsReplace " default- extensions:" "unknown-section") - -- http://hackage.haskell.org/package/vacuum-opengl-0.0 - -- \DEL character - , mk "Name: vacuum-opengl\nVersion: 0.0\nSynopsis: Visualize live Haskell data structures using vacuum, graphviz and OpenGL.\nDescription: \DELVisualize live Haskell data structures using vacuum, graphviz and OpenGL.\n " - (Fingerprint 5946760521961682577 16933361639326309422) - (Fingerprint 14034745101467101555 14024175957788447824) - (bsRemove "\DEL") - , mk "Name: vacuum-opengl\nVersion: 0.0.1\nSynopsis: Visualize live Haskell data structures using vacuum, graphviz and OpenGL.\nDescription: \DELVisualize live Haskell data structures using vacuum, graphviz and OpenGL.\n " - (Fingerprint 10790950110330119503 1309560249972452700) - (Fingerprint 1565743557025952928 13645502325715033593) - (bsRemove "\DEL") - -- http://hackage.haskell.org/package/ixset-1.0.4 - -- {- comments -} - , mk "Name: ixset\nVersion: 1.0.4\nSynopsis: Efficient relational queries on Haskell sets.\nDescription:\n Create and query sets that are indexed by multiple indices.\nLicense: BSD3\nLicense-file: COPYING\nAut" - (Fingerprint 11886092342440414185 4150518943472101551) - (Fingerprint 5731367240051983879 17473925006273577821) - (bsRemoveStarting "{-") - -- : after section - -- http://hackage.haskell.org/package/ds-kanren - , mk "name: ds-kanren\nversion: 0.2.0.0\nsynopsis: A subset of the miniKanren language\ndescription:\n ds-kanren is an implementation of the language.\n .\n == What's in ds-kanren?\n .\n ['dis" - (Fingerprint 2804006762382336875 9677726932108735838) - (Fingerprint 9830506174094917897 12812107316777006473) - (bsReplace "Test-Suite test-unify:" "Test-Suite \"test-unify:\"" . bsReplace "Test-Suite test-list-ops:" "Test-Suite \"test-list-ops:\"") - , mk "name: ds-kanren\nversion: 0.2.0.1\nsynopsis: A subset of the miniKanren language\ndescription:\n ds-kanren is an implementation of the language.\n\nlicense: MIT\nlicense-file: " - (Fingerprint 9130259649220396193 2155671144384738932) - (Fingerprint 1847988234352024240 4597789823227580457) - (bsReplace "Test-Suite test-unify:" "Test-Suite \"test-unify:\"" . bsReplace "Test-Suite test-list-ops:" "Test-Suite \"test-list-ops:\"") - , mk "name: metric\nversion: 0.1.4\nsynopsis: Metric spaces.\nlicense: MIT\nlicense-file: LICENSE\nauthor: Vikram Verma\nmaintainer: me@vikramverma.com\ncategory: Data\nbuild-type:" - (Fingerprint 6150019278861565482 3066802658031228162) - (Fingerprint 9124826020564520548 15629704249829132420) - (bsReplace "test-suite metric-tests:" "test-suite \"metric-tests:\"") - , mk "name: metric\nversion: 0.2.0\nsynopsis: Metric spaces.\nlicense: MIT\nlicense-file: LICENSE\nauthor: Vikram Verma\nmaintainer: me@vikramverma.com\ncategory: Data\nbuild-type:" - (Fingerprint 4639805967994715694 7859317050376284551) - (Fingerprint 5566222290622325231 873197212916959151) - (bsReplace "test-suite metric-tests:" "test-suite \"metric-tests:\"") - , mk "name: phasechange\ncategory: Data\nversion: 0.1\nauthor: G\195\161bor Lehel\nmaintainer: G\195\161bor Lehel \nhomepage: http://github.com/glehel/phasechange\ncopyright: Copyright (C) 2012 G\195\161bor Lehel\nlicense: " - (Fingerprint 10546509771395401582 245508422312751943) - (Fingerprint 5169853482576003304 7247091607933993833) - (bsReplace "impl(ghc >= 7.4):" "erroneous-section" . bsReplace "impl(ghc >= 7.6):" "erroneous-section") - , mk "Name: smartword\nSynopsis: Web based flash card for Word Smart I and II vocabularies\nVersion: 0.0.0.5\nHomepage: http://kyagrd.dyndns.org/~kyagrd/project/smartword/\nCategory: Web,Education\nLicense: " - (Fingerprint 7803544783533485151 10807347873998191750) - (Fingerprint 1665635316718752601 16212378357991151549) - (bsReplace "build depends:" "--") - , mk "name: shelltestrunner\n-- sync with README.md, ANNOUNCE:\nversion: 1.3\ncategory: Testing\nsynopsis: A tool for testing command-line programs.\ndescription:\n shelltestrunner is a cross-platform tool for testing command-line\n program" - (Fingerprint 4403237110790078829 15392625961066653722) - (Fingerprint 10218887328390239431 4644205837817510221) - (bsReplace "other modules:" "--") - -- &&! - -- http://hackage.haskell.org/package/hblas-0.3.0.0 - , mk "-- Initial hblas.cabal generated by cabal init. For further \n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP) \n-- " - (Fingerprint 8570120150072467041 18315524331351505945) - (Fingerprint 10838007242302656005 16026440017674974175) - (bsReplace "&&!" "&& !") - , mk "-- Initial hblas.cabal generated by cabal init. For further \n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP) \n-- " - (Fingerprint 5262875856214215155 10846626274067555320) - (Fingerprint 3022954285783401045 13395975869915955260) - (bsReplace "&&!" "&& !") - , mk "-- Initial hblas.cabal generated by cabal init. For further \n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP) \n-- " - (Fingerprint 54222628930951453 5526514916844166577) - (Fingerprint 1749630806887010665 8607076506606977549) - (bsReplace "&&!" "&& !") - , mk "-- Initial hblas.cabal generated by cabal init. For further\n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP)\n-- fo" - (Fingerprint 6817250511240350300 15278852712000783849) - (Fingerprint 15757717081429529536 15542551865099640223) - (bsReplace "&&!" "&& !") - , mk "-- Initial hblas.cabal generated by cabal init. For further\n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP)\n-- fo" - (Fingerprint 8310050400349211976 201317952074418615) - (Fingerprint 10283381191257209624 4231947623042413334) - (bsReplace "&&!" "&& !") - , mk "-- Initial hblas.cabal generated by cabal init. For further\n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP)\n-- fo" - (Fingerprint 7010988292906098371 11591884496857936132) - (Fingerprint 6158672440010710301 6419743768695725095) - (bsReplace "&&!" "&& !") - , mk "-- Initial hblas.cabal generated by cabal init. For further\r\n-- documentation, see http://haskell.org/cabal/users-guide/\r\n\r\n-- The name of the package.\r\nname: hblas\r\n\r\n-- The package version. See the Haskell package versioning policy (PVP)" - (Fingerprint 2076850805659055833 16615160726215879467) - (Fingerprint 10634706281258477722 5285812379517916984) - (bsReplace "&&!" "&& !") - , mk "-- Initial hblas.cabal generated by cabal init. For further\r\n-- documentation, see http://haskell.org/cabal/users-guide/\r\n\r\n-- The name of the package.\r\nname: hblas\r\n\r\n-- The package version. See the Haskell package versioning policy (PVP)" - (Fingerprint 11850020631622781099 11956481969231030830) - (Fingerprint 13702868780337762025 13383526367149067158) - (bsReplace "&&!" "&& !") - , mk "-- Initial hblas.cabal generated by cabal init. For further\n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP)\n-- fo" - (Fingerprint 13690322768477779172 19704059263540994) - (Fingerprint 11189374824645442376 8363528115442591078) - (bsReplace "&&!" "&& !") - -- flag used, but not defined - , mk "name: brainheck\nversion: 0.1.0.2\nsynopsis: Brainh*ck interpreter in haskell\ndescription: Brainh*ck interpreter written in haskell and taking advantage of many prominent libraries\nhomepage: https://gi" - (Fingerprint 6910727116443152200 15401634478524888973) - (Fingerprint 16551412117098094368 16260377389127603629) - (bsReplace "flag(llvm-fast)" "False") - , mk "name: brainheck\r\nversion: 0.1.0.2\r\nx-revision: 1\r\nsynopsis: Brainh*ck interpreter in haskell\r\ndescription: Brainh*ck interpreter written in haskell and taking advantage of many prominent libraries\r\nhomepage: " - (Fingerprint 14320987921316832277 10031098243571536929) - (Fingerprint 7959395602414037224 13279941216182213050) - (bsReplace "flag(llvm-fast)" "False") - , mk "name: brainheck\r\nversion: 0.1.0.2\r\nx-revision: 2\r\nsynopsis: Brainh*ck interpreter in haskell\r\ndescription: Brainh*ck interpreter written in haskell and taking advantage of many prominent libraries\r\nhomepage: " - (Fingerprint 3809078390223299128 10796026010775813741) - (Fingerprint 1127231189459220796 12088367524333209349) - (bsReplace "flag(llvm-fast)" "False") - , mk "name: brainheck\r\nversion: 0.1.0.2\r\nx-revision: 3\r\nsynopsis: Brainh*ck interpreter in haskell\r\ndescription: Brainh*ck interpreter written in haskell and taking advantage of many prominent libraries\r\nhomepage: " - (Fingerprint 13860013038089410950 12479824176801390651) - (Fingerprint 4687484721703340391 8013395164515771785) - (bsReplace "flag(llvm-fast)" "False") - , mk "name: wordchoice\nversion: 0.1.0.1\nsynopsis: Get word counts and distributions\ndescription: A command line tool to compute the word distribution from various types of document, converting to text with pandoc.\nho" - (Fingerprint 16215911397419608203 15594928482155652475) - (Fingerprint 15120681510314491047 2666192399775157359) - (bsReplace "flag(llvm-fast)" "False") - , mk "name: wordchoice\r\nversion: 0.1.0.1\r\nx-revision: 1\r\nsynopsis: Get word counts and distributions\r\ndescription: A command line tool to compute the word distribution from various types of document, converting to te" - (Fingerprint 16593139224723441188 4052919014346212001) - (Fingerprint 3577381082410411593 11481899387780544641) - (bsReplace "flag(llvm-fast)" "False") - , mk "name: wordchoice\nversion: 0.1.0.2\nsynopsis: Get word counts and distributions\ndescription: A command line tool to compute the word distribution from various types of document, converting to text with pandoc.\nho" - (Fingerprint 9321301260802539374 1316392715016096607) - (Fingerprint 3784628652257760949 12662640594755291035) - (bsReplace "flag(llvm-fast)" "False") - , mk "name: wordchoice\r\nversion: 0.1.0.2\r\nx-revision: 1\r\nsynopsis: Get word counts and distributions\r\ndescription: A command line tool to compute the word distribution from various types of document, converting to te" - (Fingerprint 2546901804824433337 2059732715322561176) - (Fingerprint 8082068680348326500 615008613291421947) - (bsReplace "flag(llvm-fast)" "False") - , mk "name: wordchoice\nversion: 0.1.0.3\nsynopsis: Get word counts and distributions\ndescription: A command line tool to compute the word distribution from various types of document, converting to text with pandoc.\nho" - (Fingerprint 2282380737467965407 12457554753171662424) - (Fingerprint 17324757216926991616 17172911843227482125) - (bsReplace "flag(llvm-fast)" "False") - , mk "name: wordchoice\r\nversion: 0.1.0.3\r\nx-revision: 1\r\nsynopsis: Get word counts and distributions\r\ndescription: A command line tool to compute the word distribution from various types of document, converting to te" - (Fingerprint 12907988890480595481 11078473638628359710) - (Fingerprint 13246185333368731848 4663060731847518614) - (bsReplace "flag(llvm-fast)" "False") - , mk "name: hw-prim-bits\nversion: 0.1.0.0\nsynopsis: Primitive support for bit manipulation\ndescription: Please see README.md\nhomepage: https://github.com/githubuser/hw-prim-bits#readme\nlicense: " - (Fingerprint 12386777729082870356 17414156731912743711) - (Fingerprint 3452290353395041602 14102887112483033720) - (bsReplace "flag(sse42)" "False") - , mk "name: hw-prim-bits\nversion: 0.1.0.1\nsynopsis: Primitive support for bit manipulation\ndescription: Please see README.md\nhomepage: https://github.com/githubuser/hw-prim-bits#readme\nlicen" - (Fingerprint 6870520675313101180 14553457351296240636) - (Fingerprint 12481021059537696455 14711088786769892762) - (bsReplace "flag(sse42)" "False") - -- leading zeros in version digits - -- https://github.com/haskell-infra/hackage-trustees/issues/128 - -- https://github.com/haskell/cabal/issues/5092 - -- https://github.com/haskell/cabal/issues/5138 - , mk "name: Sit\nversion: 0.2017.02.26\nbuild-type: Simple\ncabal-version: >= 1.8\nlicense: OtherLicense\nlicense-file: LICENSE\nauthor: Anonymous\nmaintainer: Anonymous\nhomepage: NONE\ncategory: Dependent" - (Fingerprint 8458530898096910998 3228538743646501413) - (Fingerprint 14470502514907936793 17514354054641875371) - (bsReplace "0.2017.02.26" "0.2017.2.26") - , mk "name: Sit\nversion: 0.2017.05.01\nbuild-type: Simple\ncabal-version: >= 1.8\nlicense: OtherLicense\nlicense-file: LICENSE\nauthor: Andreas Abel \nmaintainer: Andreas Abel \n" - (Fingerprint 1450130849535097473 11742099607098860444) - (Fingerprint 16679762943850814021 4253724355613883542) - (bsReplace "0.2017.05.01" "0.2017.5.1") - , mk "name: Sit\nversion: 0.2017.05.02\nbuild-type: Simple\ncabal-version: >= 1.8\nlicense: OtherLicense\nlicense-file: LICENSE\nauthor: Andreas Abel \nmaintainer: Andreas Abel \n" - (Fingerprint 297248532398492441 17322625167861324800) - (Fingerprint 634812045126693280 1755581866539318862) - (bsReplace "0.2017.05.02" "0.2017.5.2") - , mk "name: Sit\nversion: 0.2017.5.02\nx-revision: 1\n-- x-revision:1 see https://github.com/haskell-infra/hackage-trustees/issues/128\nbuild-type: Simple\ncabal-version: >= 1.8\nlicense: OtherLicense\nlicense-file: LICENSE\nauthor: " - (Fingerprint 3697869560530373941 3942982281026987312) - (Fingerprint 14344526114710295386 16386400353475114712) - (bsReplace "0.2017.5.02" "0.2017.5.2") - , mk "name: MiniAgda\nversion: 0.2017.02.18\nbuild-type: Simple\ncabal-version: >= 1.22\nlicense: OtherLicense\nlicense-file: LICENSE\nauthor: Andreas Abel and Karl Mehltretter\nmaintainer: Andreas Abel (BS.ByteString -> BS.ByteString) -> IO () -_makePatchKey fp transform = do - contents <- BS.readFile fp - let output = transform contents - let Fingerprint hi lo = md5 contents - let Fingerprint hi' lo' = md5 output - putStrLn - $ showString " , mk " - . shows (BS.take 256 contents) - . showString "\n (Fingerprint " - . shows hi - . showString " " - . shows lo - . showString ")\n (Fingerprint " - . shows hi' - . showString " " - . shows lo' - . showString ")" - $ "" - -------------------------------------------------------------------------------- --- Patch helpers -------------------------------------------------------------------------------- - -bsRemove - :: BS.ByteString -- ^ needle - -> BS.ByteString -> BS.ByteString -bsRemove needle haystack = case BS.breakSubstring needle haystack of - (h, t) -> BS.append h (BS.drop (BS.length needle) t) - -bsReplace - :: BS.ByteString -- ^ needle - -> BS.ByteString -- ^ replacement - -> BS.ByteString -> BS.ByteString -bsReplace needle repl haystack = case BS.breakSubstring needle haystack of - (h, t) - | not (BS.null t) -> BS.append h (BS.append repl (BS.drop (BS.length needle) t)) - | otherwise -> haystack - -bsRemoveStarting - :: BS.ByteString -- ^ needle - -> BS.ByteString -> BS.ByteString -bsRemoveStarting needle haystack = case BS.breakSubstring needle haystack of - (h, _) -> h diff --git a/cabal/Cabal/Distribution/PackageDescription/Utils.hs b/cabal/Cabal/Distribution/PackageDescription/Utils.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/PackageDescription/Utils.hs +++ /dev/null @@ -1,23 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.PackageDescription.Utils --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Common utils used by modules under Distribution.PackageDescription.*. - -module Distribution.PackageDescription.Utils ( - cabalBug, userBug - ) where - --- ---------------------------------------------------------------------------- --- Exception and logging utils - -userBug :: String -> a -userBug msg = error $ msg ++ ". This is a bug in your .cabal file." - -cabalBug :: String -> a -cabalBug msg = error $ msg ++ ". This is possibly a bug in Cabal.\n" - ++ "Please report it to the developers: " - ++ "https://github.com/haskell/cabal/issues/new" diff --git a/cabal/Cabal/Distribution/Parsec.hs b/cabal/Cabal/Distribution/Parsec.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Parsec.hs +++ /dev/null @@ -1,524 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Distribution.Parsec ( - Parsec(..), - ParsecParser (..), - runParsecParser, - runParsecParser', - simpleParsec, - simpleParsecBS, - simpleParsec', - simpleParsecW', - lexemeParsec, - eitherParsec, - explicitEitherParsec, - explicitEitherParsec', - -- * CabalParsing and diagnostics - CabalParsing (..), - -- ** Warnings - PWarnType (..), - PWarning (..), - showPWarning, - -- ** Errors - PError (..), - showPError, - -- * Position - Position (..), - incPos, - retPos, - showPos, - zeroPos, - -- * Utilities - parsecToken, - parsecToken', - parsecFilePath, - parsecQuoted, - parsecMaybeQuoted, - parsecCommaList, - parsecCommaNonEmpty, - parsecLeadingCommaList, - parsecLeadingCommaNonEmpty, - parsecOptCommaList, - parsecLeadingOptCommaList, - parsecStandard, - parsecUnqualComponentName, - ) where - -import Data.ByteString (ByteString) -import Data.Char (digitToInt, intToDigit) -import Data.List (transpose) -import Distribution.CabalSpecVersion -import Distribution.Compat.Prelude -import Distribution.Parsec.Error (PError (..), showPError) -import Distribution.Parsec.FieldLineStream (FieldLineStream, fieldLineStreamFromBS, fieldLineStreamFromString) -import Distribution.Parsec.Position (Position (..), incPos, retPos, showPos, zeroPos) -import Distribution.Parsec.Warning (PWarnType (..), PWarning (..), showPWarning) -import Numeric (showIntAtBase) -import Prelude () - -import qualified Distribution.Compat.CharParsing as P -import qualified Distribution.Compat.DList as DList -import qualified Distribution.Compat.MonadFail as Fail -import qualified Text.Parsec as Parsec - -------------------------------------------------------------------------------- --- Class -------------------------------------------------------------------------------- - --- | Class for parsing with @parsec@. Mainly used for @.cabal@ file fields. --- --- For parsing @.cabal@ like file structure, see "Distribution.Fields". --- -class Parsec a where - parsec :: CabalParsing m => m a - --- | Parsing class which --- --- * can report Cabal parser warnings. --- --- * knows @cabal-version@ we work with --- -class (P.CharParsing m, MonadPlus m, Fail.MonadFail m) => CabalParsing m where - parsecWarning :: PWarnType -> String -> m () - - parsecHaskellString :: m String - parsecHaskellString = stringLiteral - - askCabalSpecVersion :: m CabalSpecVersion - --- | 'parsec' /could/ consume trailing spaces, this function /will/ consume. -lexemeParsec :: (CabalParsing m, Parsec a) => m a -lexemeParsec = parsec <* P.spaces - -newtype ParsecParser a = PP { unPP - :: CabalSpecVersion -> Parsec.Parsec FieldLineStream [PWarning] a - } - -liftParsec :: Parsec.Parsec FieldLineStream [PWarning] a -> ParsecParser a -liftParsec p = PP $ \_ -> p - -instance Functor ParsecParser where - fmap f p = PP $ \v -> fmap f (unPP p v) - {-# INLINE fmap #-} - - x <$ p = PP $ \v -> x <$ unPP p v - {-# INLINE (<$) #-} - -instance Applicative ParsecParser where - pure = liftParsec . pure - {-# INLINE pure #-} - - f <*> x = PP $ \v -> unPP f v <*> unPP x v - {-# INLINE (<*>) #-} - f *> x = PP $ \v -> unPP f v *> unPP x v - {-# INLINE (*>) #-} - f <* x = PP $ \v -> unPP f v <* unPP x v - {-# INLINE (<*) #-} - -instance Alternative ParsecParser where - empty = liftParsec empty - - a <|> b = PP $ \v -> unPP a v <|> unPP b v - {-# INLINE (<|>) #-} - - many p = PP $ \v -> many (unPP p v) - {-# INLINE many #-} - - some p = PP $ \v -> some (unPP p v) - {-# INLINE some #-} - -instance Monad ParsecParser where - return = pure - - m >>= k = PP $ \v -> unPP m v >>= \x -> unPP (k x) v - {-# INLINE (>>=) #-} - (>>) = (*>) - {-# INLINE (>>) #-} - -#if !(MIN_VERSION_base(4,13,0)) - fail = Fail.fail -#endif - -instance MonadPlus ParsecParser where - mzero = empty - mplus = (<|>) - -instance Fail.MonadFail ParsecParser where - fail = P.unexpected - -instance P.Parsing ParsecParser where - try p = PP $ \v -> P.try (unPP p v) - p d = PP $ \v -> unPP p v P. d - skipMany p = PP $ \v -> P.skipMany (unPP p v) - skipSome p = PP $ \v -> P.skipSome (unPP p v) - unexpected = liftParsec . P.unexpected - eof = liftParsec P.eof - notFollowedBy p = PP $ \v -> P.notFollowedBy (unPP p v) - -instance P.CharParsing ParsecParser where - satisfy = liftParsec . P.satisfy - char = liftParsec . P.char - notChar = liftParsec . P.notChar - anyChar = liftParsec P.anyChar - string = liftParsec . P.string - -instance CabalParsing ParsecParser where - parsecWarning t w = liftParsec $ do - spos <- Parsec.getPosition - Parsec.modifyState - (PWarning t (Position (Parsec.sourceLine spos) (Parsec.sourceColumn spos)) w :) - askCabalSpecVersion = PP pure - --- | Parse a 'String' with 'lexemeParsec'. -simpleParsec :: Parsec a => String -> Maybe a -simpleParsec - = either (const Nothing) Just - . runParsecParser lexemeParsec "" - . fieldLineStreamFromString - --- | Like 'simpleParsec' but for 'ByteString' -simpleParsecBS :: Parsec a => ByteString -> Maybe a -simpleParsecBS - = either (const Nothing) Just - . runParsecParser lexemeParsec "" - . fieldLineStreamFromBS - --- | Parse a 'String' with 'lexemeParsec' using specific 'CabalSpecVersion'. --- --- @since 3.4.0.0 -simpleParsec' :: Parsec a => CabalSpecVersion -> String -> Maybe a -simpleParsec' spec - = either (const Nothing) Just - . runParsecParser' spec lexemeParsec "" - . fieldLineStreamFromString - --- | Parse a 'String' with 'lexemeParsec' using specific 'CabalSpecVersion'. --- Fail if there are any warnings. --- --- @since 3.4.0.0 -simpleParsecW' :: Parsec a => CabalSpecVersion -> String -> Maybe a -simpleParsecW' spec - = either (const Nothing) (\(x, ws) -> if null ws then Just x else Nothing) - . runParsecParser' spec ((,) <$> lexemeParsec <*> liftParsec Parsec.getState) "" - . fieldLineStreamFromString - --- | Parse a 'String' with 'lexemeParsec'. -eitherParsec :: Parsec a => String -> Either String a -eitherParsec = explicitEitherParsec parsec - --- | Parse a 'String' with given 'ParsecParser'. Trailing whitespace is accepted. -explicitEitherParsec :: ParsecParser a -> String -> Either String a -explicitEitherParsec parser - = either (Left . show) Right - . runParsecParser (parser <* P.spaces) "" - . fieldLineStreamFromString - --- | Parse a 'String' with given 'ParsecParser' and 'CabalSpecVersion'. Trailing whitespace is accepted. --- See 'explicitEitherParsec'. --- --- @since 3.4.0.0 --- -explicitEitherParsec' :: CabalSpecVersion -> ParsecParser a -> String -> Either String a -explicitEitherParsec' spec parser - = either (Left . show) Right - . runParsecParser' spec (parser <* P.spaces) "" - . fieldLineStreamFromString - --- | Run 'ParsecParser' with 'cabalSpecLatest'. -runParsecParser :: ParsecParser a -> FilePath -> FieldLineStream -> Either Parsec.ParseError a -runParsecParser = runParsecParser' cabalSpecLatest - --- | Like 'runParsecParser' but lets specify 'CabalSpecVersion' used. --- --- @since 3.0.0.0 --- -runParsecParser' :: CabalSpecVersion -> ParsecParser a -> FilePath -> FieldLineStream -> Either Parsec.ParseError a -runParsecParser' v p n = Parsec.runParser (unPP p v <* P.eof) [] n - -instance Parsec a => Parsec (Identity a) where - parsec = Identity <$> parsec - -instance Parsec Bool where - parsec = P.munch1 isAlpha >>= postprocess - where - postprocess str - | str == "True" = pure True - | str == "False" = pure False - | lstr == "true" = parsecWarning PWTBoolCase caseWarning *> pure True - | lstr == "false" = parsecWarning PWTBoolCase caseWarning *> pure False - | otherwise = fail $ "Not a boolean: " ++ str - where - lstr = map toLower str - caseWarning = - "Boolean values are case sensitive, use 'True' or 'False'." - --- | @[^ ,]@ -parsecToken :: CabalParsing m => m String -parsecToken = parsecHaskellString <|> ((P.munch1 (\x -> not (isSpace x) && x /= ',') P. "identifier" ) >>= checkNotDoubleDash) - --- | @[^ ]@ -parsecToken' :: CabalParsing m => m String -parsecToken' = parsecHaskellString <|> ((P.munch1 (not . isSpace) P. "token") >>= checkNotDoubleDash) - -checkNotDoubleDash :: CabalParsing m => String -> m String -checkNotDoubleDash s = do - when (s == "--") $ parsecWarning PWTDoubleDash $ unwords - [ "Double-dash token found." - , "Note: there are no end-of-line comments in .cabal files, only whole line comments." - , "Use \"--\" (quoted double dash) to silence this warning, if you actually want -- token" - ] - - return s - -parsecFilePath :: CabalParsing m => m FilePath -parsecFilePath = parsecToken - --- | Parse a benchmark/test-suite types. -parsecStandard :: (CabalParsing m, Parsec ver) => (ver -> String -> a) -> m a -parsecStandard f = do - cs <- some $ P.try (component <* P.char '-') - ver <- parsec - let name = map toLower (intercalate "-" cs) - return $! f ver name - where - component = do - cs <- P.munch1 isAlphaNum - if all isDigit cs then fail "all digit component" else return cs - -- each component must contain an alphabetic character, to avoid - -- ambiguity in identifiers like foo-1 (the 1 is the version number). - -parsecCommaList :: CabalParsing m => m a -> m [a] -parsecCommaList p = P.sepBy (p <* P.spaces) (P.char ',' *> P.spaces P. "comma") - -parsecCommaNonEmpty :: CabalParsing m => m a -> m (NonEmpty a) -parsecCommaNonEmpty p = P.sepByNonEmpty (p <* P.spaces) (P.char ',' *> P.spaces P. "comma") - --- | Like 'parsecCommaList' but accept leading or trailing comma. --- --- @ --- p (comma p)* -- p `sepBy` comma --- (comma p)* -- leading comma --- (p comma)* -- trailing comma --- @ -parsecLeadingCommaList :: CabalParsing m => m a -> m [a] -parsecLeadingCommaList p = do - c <- P.optional comma - case c of - Nothing -> toList <$> P.sepEndByNonEmpty lp comma <|> pure [] - Just _ -> toList <$> P.sepByNonEmpty lp comma - where - lp = p <* P.spaces - comma = P.char ',' *> P.spaces P. "comma" - --- | --- --- @since 3.4.0.0 -parsecLeadingCommaNonEmpty :: CabalParsing m => m a -> m (NonEmpty a) -parsecLeadingCommaNonEmpty p = do - c <- P.optional comma - case c of - Nothing -> P.sepEndByNonEmpty lp comma - Just _ -> P.sepByNonEmpty lp comma - where - lp = p <* P.spaces - comma = P.char ',' *> P.spaces P. "comma" - -parsecOptCommaList :: CabalParsing m => m a -> m [a] -parsecOptCommaList p = P.sepBy (p <* P.spaces) (P.optional comma) - where - comma = P.char ',' *> P.spaces - --- | Like 'parsecOptCommaList' but --- --- * require all or none commas --- * accept leading or trailing comma. --- --- @ --- p (comma p)* -- p `sepBy` comma --- (comma p)* -- leading comma --- (p comma)* -- trailing comma --- p* -- no commas: many p --- @ --- --- @since 3.0.0.0 --- -parsecLeadingOptCommaList :: CabalParsing m => m a -> m [a] -parsecLeadingOptCommaList p = do - c <- P.optional comma - case c of - Nothing -> sepEndBy1Start <|> pure [] - Just _ -> toList <$> P.sepByNonEmpty lp comma - where - lp = p <* P.spaces - comma = P.char ',' *> P.spaces P. "comma" - - sepEndBy1Start = do - x <- lp - c <- P.optional comma - case c of - Nothing -> (x :) <$> many lp - Just _ -> (x :) <$> P.sepEndBy lp comma - --- | Content isn't unquoted -parsecQuoted :: CabalParsing m => m a -> m a -parsecQuoted = P.between (P.char '"') (P.char '"') - --- | @parsecMaybeQuoted p = 'parsecQuoted' p <|> p@. -parsecMaybeQuoted :: CabalParsing m => m a -> m a -parsecMaybeQuoted p = parsecQuoted p <|> p - -parsecUnqualComponentName :: forall m. CabalParsing m => m String -parsecUnqualComponentName = state0 DList.empty where - -- - -- using @kleene@ package we can easily see that - -- we need only two states to recognize - -- unqual-component-name - -- - -- Compare with declarative - -- 'Distribution.FieldGrammar.Described.reUnqualComponent'. - -- - -- @ - -- import Kleene - -- import Kleene.Internal.Pretty - -- import Algebra.Lattice - -- import Data.Char - -- - -- import qualified Data.RangeSet.Map as RSet - -- - -- main = do - -- -- this is an approximation, to get an idea. - -- let component :: RE Char - -- component = star alphaNum <> alpha <> star alphaNum - -- - -- alphaNum = alpha \/ num - -- alpha = unions $ map char ['a'..'z'] - -- num = unions $ map char ['0'..'9'] - -- - -- re :: RE Char - -- re = component <> star (char '-' <> component) - -- - -- putPretty re - -- putPretty $ fromTM re - -- @ - - state0 :: DList.DList Char -> m String - state0 acc = do - c <- ch -- <|> fail ("Invalid component, after " ++ DList.toList acc) - case () of - _ | isDigit c -> state0 (DList.snoc acc c) - | isAlphaNum c -> state1 (DList.snoc acc c) - | c == '-' -> fail ("Empty component, after " ++ DList.toList acc) - | otherwise -> fail ("Internal error, after " ++ DList.toList acc) - - state1 :: DList.DList Char -> m String - state1 acc = state1' acc `alt` return (DList.toList acc) - - state1' :: DList.DList Char -> m String - state1' acc = do - c <- ch - case () of - _ | isAlphaNum c -> state1 (DList.snoc acc c) - | c == '-' -> state0 (DList.snoc acc c) - | otherwise -> fail ("Internal error, after " ++ DList.toList acc) - - ch :: m Char - !ch = P.satisfy (\c -> isAlphaNum c || c == '-') - - alt :: m String -> m String -> m String - !alt = (<|>) - -stringLiteral :: forall m. P.CharParsing m => m String -stringLiteral = lit where - lit :: m String - lit = foldr (maybe id (:)) "" - <$> P.between (P.char '"') (P.char '"' P. "end of string") (many stringChar) - P. "string" - - stringChar :: m (Maybe Char) - stringChar = Just <$> stringLetter - <|> stringEscape - P. "string character" - - stringLetter :: m Char - stringLetter = P.satisfy (\c -> (c /= '"') && (c /= '\\') && (c > '\026')) - - stringEscape :: m (Maybe Char) - stringEscape = P.char '\\' *> esc where - esc :: m (Maybe Char) - esc = Nothing <$ escapeGap - <|> Nothing <$ escapeEmpty - <|> Just <$> escapeCode - - escapeEmpty, escapeGap :: m Char - escapeEmpty = P.char '&' - escapeGap = P.skipSpaces1 *> (P.char '\\' P. "end of string gap") - -escapeCode :: forall m. P.CharParsing m => m Char -escapeCode = (charEsc <|> charNum <|> charAscii <|> charControl) P. "escape code" - where - charControl, charNum :: m Char - charControl = (\c -> toEnum (fromEnum c - fromEnum '@')) <$> (P.char '^' *> (P.upper <|> P.char '@')) - charNum = toEnum <$> num - where - num :: m Int - num = bounded 10 maxchar - <|> (P.char 'o' *> bounded 8 maxchar) - <|> (P.char 'x' *> bounded 16 maxchar) - maxchar = fromEnum (maxBound :: Char) - - bounded :: Int -> Int -> m Int - bounded base bnd = foldl' (\x d -> base * x + digitToInt d) 0 - <$> bounded' (take base thedigits) (map digitToInt $ showIntAtBase base intToDigit bnd "") - where - thedigits :: [m Char] - thedigits = map P.char ['0'..'9'] ++ map P.oneOf (transpose [['A'..'F'],['a'..'f']]) - - toomuch :: m a - toomuch = P.unexpected "out-of-range numeric escape sequence" - - bounded', bounded'' :: [m Char] -> [Int] -> m [Char] - bounded' dps@(zero:_) bds = P.skipSome zero *> ([] <$ P.notFollowedBy (P.choice dps) <|> bounded'' dps bds) - <|> bounded'' dps bds - bounded' [] _ = error "bounded called with base 0" - bounded'' dps [] = [] <$ P.notFollowedBy (P.choice dps) <|> toomuch - bounded'' dps (bd : bds) = let anyd :: m Char - anyd = P.choice dps - - nomore :: m () - nomore = P.notFollowedBy anyd <|> toomuch - - (low, ex, high) = case splitAt bd dps of - (low', ex' : high') -> (low', ex', high') - (_, _) -> error "escapeCode: Logic error" - in ((:) <$> P.choice low <*> atMost (length bds) anyd) <* nomore - <|> ((:) <$> ex <*> ([] <$ nomore <|> bounded'' dps bds)) - <|> if not (null bds) - then (:) <$> P.choice high <*> atMost (length bds - 1) anyd <* nomore - else empty - atMost n p | n <= 0 = pure [] - | otherwise = ((:) <$> p <*> atMost (n - 1) p) <|> pure [] - - charEsc :: m Char - charEsc = P.choice $ parseEsc <$> escMap - - parseEsc (c,code) = code <$ P.char c - escMap = zip "abfnrtv\\\"\'" "\a\b\f\n\r\t\v\\\"\'" - - charAscii :: m Char - charAscii = P.choice $ parseAscii <$> asciiMap - - parseAscii (asc,code) = P.try $ code <$ P.string asc - asciiMap = zip (ascii3codes ++ ascii2codes) (ascii3 ++ ascii2) - ascii2codes, ascii3codes :: [String] - ascii2codes = [ "BS","HT","LF","VT","FF","CR","SO" - , "SI","EM","FS","GS","RS","US","SP"] - ascii3codes = ["NUL","SOH","STX","ETX","EOT","ENQ","ACK" - ,"BEL","DLE","DC1","DC2","DC3","DC4","NAK" - ,"SYN","ETB","CAN","SUB","ESC","DEL"] - ascii2, ascii3 :: String - ascii2 = "\BS\HT\LF\VT\FF\CR\SO\SI\EM\FS\GS\RS\US\SP" - ascii3 = "\NUL\SOH\STX\ETX\EOT\ENQ\ACK\BEL\DLE\DC1\DC2\DC3\DC4\NAK\SYN\ETB\CAN\SUB\ESC\DEL" diff --git a/cabal/Cabal/Distribution/Parsec/Error.hs b/cabal/Cabal/Distribution/Parsec/Error.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Parsec/Error.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Parsec.Error ( - PError (..), - showPError, - ) where - -import Distribution.Compat.Prelude -import Distribution.Parsec.Position -import Prelude () -import System.FilePath (normalise) - --- | Parser error. -data PError = PError Position String - deriving (Show, Generic) - -instance Binary PError -instance NFData PError where rnf = genericRnf - -showPError :: FilePath -> PError -> String -showPError fpath (PError pos msg) = - normalise fpath ++ ":" ++ showPos pos ++ ": " ++ msg diff --git a/cabal/Cabal/Distribution/Parsec/FieldLineStream.hs b/cabal/Cabal/Distribution/Parsec/FieldLineStream.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Parsec/FieldLineStream.hs +++ /dev/null @@ -1,91 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wall -Werror #-} -module Distribution.Parsec.FieldLineStream ( - FieldLineStream (..), - fieldLineStreamFromString, - fieldLineStreamFromBS, - fieldLineStreamEnd, - ) where - -import Data.Bits -import Data.ByteString (ByteString) -import Distribution.Compat.Prelude -import Distribution.Utils.Generic (toUTF8BS) -import Prelude () - -import qualified Data.ByteString as BS -import qualified Text.Parsec as Parsec - --- | This is essentially a lazy bytestring, but chunks are glued with newline @\'\\n\'@. -data FieldLineStream - = FLSLast !ByteString - | FLSCons {-# UNPACK #-} !ByteString FieldLineStream - deriving Show - -fieldLineStreamEnd :: FieldLineStream -fieldLineStreamEnd = FLSLast mempty - --- | Convert 'String' to 'FieldLineStream'. --- --- /Note:/ inefficient! -fieldLineStreamFromString :: String -> FieldLineStream -fieldLineStreamFromString = FLSLast . toUTF8BS - -fieldLineStreamFromBS :: ByteString -> FieldLineStream -fieldLineStreamFromBS = FLSLast - -instance Monad m => Parsec.Stream FieldLineStream m Char where - uncons (FLSLast bs) = return $ case BS.uncons bs of - Nothing -> Nothing - Just (c, bs') -> Just (unconsChar c bs' (\bs'' -> FLSLast bs'') fieldLineStreamEnd) - - uncons (FLSCons bs s) = return $ case BS.uncons bs of - -- as lines are glued with '\n', we return '\n' here! - Nothing -> Just ('\n', s) - Just (c, bs') -> Just (unconsChar c bs' (\bs'' -> FLSCons bs'' s) s) - --- Based on implementation 'decodeStringUtf8' -unconsChar :: forall a. Word8 -> ByteString -> (ByteString -> a) -> a -> (Char, a) -unconsChar c0 bs0 f next - | c0 <= 0x7F = (chr (fromIntegral c0), f bs0) - | c0 <= 0xBF = (replacementChar, f bs0) - | c0 <= 0xDF = twoBytes - | c0 <= 0xEF = moreBytes 3 0x800 bs0 (fromIntegral $ c0 .&. 0xF) - | c0 <= 0xF7 = moreBytes 4 0x10000 bs0 (fromIntegral $ c0 .&. 0x7) - | c0 <= 0xFB = moreBytes 5 0x200000 bs0 (fromIntegral $ c0 .&. 0x3) - | c0 <= 0xFD = moreBytes 6 0x4000000 bs0 (fromIntegral $ c0 .&. 0x1) - | otherwise = error $ "not implemented " ++ show c0 - where - twoBytes = case BS.uncons bs0 of - Nothing -> (replacementChar, next) - Just (c1, bs1) - | c1 .&. 0xC0 == 0x80 -> - if d >= 0x80 - then (chr d, f bs1) - else (replacementChar, f bs1) - | otherwise -> (replacementChar, f bs1) - where - d = (fromIntegral (c0 .&. 0x1F) `shiftL` 6) .|. fromIntegral (c1 .&. 0x3F) - - moreBytes :: Int -> Int -> ByteString -> Int -> (Char, a) - moreBytes 1 overlong bs' acc - | overlong <= acc, acc <= 0x10FFFF, acc < 0xD800 || 0xDFFF < acc - = (chr acc, f bs') - | otherwise - = (replacementChar, f bs') - - moreBytes byteCount overlong bs' acc = case BS.uncons bs' of - Nothing -> (replacementChar, f bs') - Just (cn, bs1) - | cn .&. 0xC0 == 0x80 -> moreBytes - (byteCount-1) - overlong - bs1 - ((acc `shiftL` 6) .|. fromIntegral cn .&. 0x3F) - | otherwise -> (replacementChar, f bs1) - -replacementChar :: Char -replacementChar = '\xfffd' diff --git a/cabal/Cabal/Distribution/Parsec/Position.hs b/cabal/Cabal/Distribution/Parsec/Position.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Parsec/Position.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Parsec.Position ( - Position (..), - incPos, - retPos, - showPos, - zeroPos, - positionCol, - positionRow, - ) where - -import Distribution.Compat.Prelude -import Prelude () - --- | 1-indexed row and column positions in a file. -data Position = Position - {-# UNPACK #-} !Int -- row - {-# UNPACK #-} !Int -- column - deriving (Eq, Ord, Show, Generic) - -instance Binary Position -instance NFData Position where rnf = genericRnf - --- | Shift position by n columns to the right. -incPos :: Int -> Position -> Position -incPos n (Position row col) = Position row (col + n) - --- | Shift position to beginning of next row. -retPos :: Position -> Position -retPos (Position row _col) = Position (row + 1) 1 - -showPos :: Position -> String -showPos (Position row col) = show row ++ ":" ++ show col - -zeroPos :: Position -zeroPos = Position 0 0 - --- | @since 3.0.0.0 -positionCol :: Position -> Int -positionCol (Position _ c) = c - --- | @since 3.0.0.0 -positionRow :: Position -> Int -positionRow (Position r _) = r diff --git a/cabal/Cabal/Distribution/Parsec/Warning.hs b/cabal/Cabal/Distribution/Parsec/Warning.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Parsec/Warning.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Parsec.Warning ( - PWarning (..), - PWarnType (..), - showPWarning, - ) where - -import Distribution.Compat.Prelude -import Distribution.Parsec.Position -import Prelude () -import System.FilePath (normalise) - --- | Type of parser warning. We do classify warnings. --- --- Different application may decide not to show some, or have fatal behaviour on others -data PWarnType - = PWTOther -- ^ Unclassified warning - | PWTUTF -- ^ Invalid UTF encoding - | PWTBoolCase -- ^ @true@ or @false@, not @True@ or @False@ - | PWTVersionTag -- ^ there are version with tags - | PWTNewSyntax -- ^ New syntax used, but no @cabal-version: >= 1.2@ specified - | PWTOldSyntax -- ^ Old syntax used, and @cabal-version >= 1.2@ specified - | PWTDeprecatedField - | PWTInvalidSubsection - | PWTUnknownField - | PWTUnknownSection - | PWTTrailingFields - | PWTExtraMainIs -- ^ extra main-is field - | PWTExtraTestModule -- ^ extra test-module field - | PWTExtraBenchmarkModule -- ^ extra benchmark-module field - | PWTLexNBSP - | PWTLexBOM - | PWTLexTab - | PWTQuirkyCabalFile -- ^ legacy cabal file that we know how to patch - | PWTDoubleDash -- ^ Double dash token, most likely it's a mistake - it's not a comment - | PWTMultipleSingularField -- ^ e.g. name or version should be specified only once. - | PWTBuildTypeDefault -- ^ Workaround for derive-package having build-type: Default. See . - - | PWTVersionOperator -- ^ Version operators used (without cabal-version: 1.8) - | PWTVersionWildcard -- ^ Version wildcard used (without cabal-version: 1.6) - - | PWTSpecVersion -- ^ Warnings about cabal-version format. - - | PWTExperimental -- ^ Experimental feature - deriving (Eq, Ord, Show, Enum, Bounded, Generic) - -instance Binary PWarnType -instance NFData PWarnType where rnf = genericRnf - --- | Parser warning. -data PWarning = PWarning !PWarnType !Position String - deriving (Show, Generic) - -instance Binary PWarning -instance NFData PWarning where rnf = genericRnf - -showPWarning :: FilePath -> PWarning -> String -showPWarning fpath (PWarning _ pos msg) = - normalise fpath ++ ":" ++ showPos pos ++ ": " ++ msg diff --git a/cabal/Cabal/Distribution/Pretty.hs b/cabal/Cabal/Distribution/Pretty.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Pretty.hs +++ /dev/null @@ -1,106 +0,0 @@ -module Distribution.Pretty ( - Pretty (..), - prettyShow, - defaultStyle, - flatStyle, - -- * Utilities - showFilePath, - showToken, - showFreeText, - showFreeTextV3, - -- * Deprecated - Separator, - ) where - -import Distribution.CabalSpecVersion -import Distribution.Compat.Prelude -import Prelude () - -import qualified Text.PrettyPrint as PP - -class Pretty a where - pretty :: a -> PP.Doc - - prettyVersioned :: CabalSpecVersion -> a -> PP.Doc - prettyVersioned _ = pretty - --- | @since 3.4.0.0 -instance Pretty PP.Doc where - pretty = id - -instance Pretty Bool where - pretty = PP.text . show - -instance Pretty Int where - pretty = PP.text . show - -instance Pretty a => Pretty (Identity a) where - pretty = pretty . runIdentity - -prettyShow :: Pretty a => a -> String -prettyShow = PP.renderStyle defaultStyle . pretty - --- | The default rendering style used in Cabal for console --- output. It has a fixed page width and adds line breaks --- automatically. -defaultStyle :: PP.Style -defaultStyle = PP.Style { PP.mode = PP.PageMode - , PP.lineLength = 79 - , PP.ribbonsPerLine = 1.0 - } - --- | A style for rendering all on one line. -flatStyle :: PP.Style -flatStyle = PP.Style { PP.mode = PP.LeftMode - , PP.lineLength = err "lineLength" - , PP.ribbonsPerLine = err "ribbonsPerLine" - } - where - err x = error ("flatStyle: tried to access " ++ x ++ " in LeftMode. " ++ - "This should never happen and indicates a bug in Cabal.") - -------------------------------------------------------------------------------- --- Utilities -------------------------------------------------------------------------------- - --- TODO: remove when ReadP parser is gone. -type Separator = [PP.Doc] -> PP.Doc - -showFilePath :: FilePath -> PP.Doc -showFilePath = showToken - -showToken :: String -> PP.Doc -showToken str - -- if token looks like a comment (starts with --), print it in quotes - | "--" `isPrefixOf` str = PP.text (show str) - -- also if token ends with a colon (e.g. executable name), print it in quotes - | ":" `isSuffixOf` str = PP.text (show str) - | not (any dodgy str) && not (null str) = PP.text str - | otherwise = PP.text (show str) - where - dodgy c = isSpace c || c == ',' - - --- | Pretty-print free-format text, ensuring that it is vertically aligned, --- and with blank lines replaced by dots for correct re-parsing. -showFreeText :: String -> PP.Doc -showFreeText "" = mempty -showFreeText s = PP.vcat [ PP.text (if null l then "." else l) | l <- lines_ s ] - --- | Pretty-print free-format text. --- Since @cabal-version: 3.0@ we don't replace blank lines with dots. --- --- @since 3.0.0.0 -showFreeTextV3 :: String -> PP.Doc -showFreeTextV3 "" = mempty -showFreeTextV3 s = PP.vcat [ PP.text l | l <- lines_ s ] - --- | 'lines_' breaks a string up into a list of strings at newline --- characters. The resulting strings do not contain newlines. -lines_ :: String -> [String] -lines_ [] = [""] -lines_ s = - let (l, s') = break (== '\n') s - in l : case s' of - [] -> [] - (_:s'') -> lines_ s'' diff --git a/cabal/Cabal/Distribution/ReadE.hs b/cabal/Cabal/Distribution/ReadE.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/ReadE.hs +++ /dev/null @@ -1,49 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.ReadE --- Copyright : Jose Iborra 2008 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Simple parsing with failure - -module Distribution.ReadE ( - -- * ReadE - ReadE(..), succeedReadE, failReadE, - -- * Projections - readEOrFail, - parsecToReadE, - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Parsec -import Distribution.Parsec.FieldLineStream - --- | Parser with simple error reporting -newtype ReadE a = ReadE {runReadE :: String -> Either ErrorMsg a} -type ErrorMsg = String - -instance Functor ReadE where - fmap f (ReadE p) = ReadE $ \txt -> case p txt of - Right a -> Right (f a) - Left err -> Left err - -succeedReadE :: (String -> a) -> ReadE a -succeedReadE f = ReadE (Right . f) - -failReadE :: ErrorMsg -> ReadE a -failReadE = ReadE . const . Left - -readEOrFail :: ReadE a -> String -> a -readEOrFail r = either error id . runReadE r - -parsecToReadE :: (String -> ErrorMsg) -> ParsecParser a -> ReadE a -parsecToReadE err p = ReadE $ \txt -> - case runParsecParser p "" (fieldLineStreamFromString txt) of - Right x -> Right x - Left _e -> Left (err txt) --- TODO: use parsec error to make 'ErrorMsg'. diff --git a/cabal/Cabal/Distribution/SPDX.hs b/cabal/Cabal/Distribution/SPDX.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/SPDX.hs +++ /dev/null @@ -1,40 +0,0 @@ --- | This module implements SPDX specification version 2.1 with a version 3.0 license list. --- --- Specification is available on -module Distribution.SPDX ( - -- * License - License (..), - -- * License expression - LicenseExpression (..), - SimpleLicenseExpression (..), - simpleLicenseExpression, - -- * License identifier - LicenseId (..), - licenseId, - licenseName, - licenseIsOsiApproved, - mkLicenseId, - licenseIdList, - -- * License exception - LicenseExceptionId (..), - licenseExceptionId, - licenseExceptionName, - mkLicenseExceptionId, - licenseExceptionIdList, - -- * License reference - LicenseRef, - licenseRef, - licenseDocumentRef, - mkLicenseRef, - mkLicenseRef', - -- * License list version - LicenseListVersion (..), - cabalSpecVersionToSPDXListVersion, - ) where - -import Distribution.SPDX.LicenseExceptionId -import Distribution.SPDX.License -import Distribution.SPDX.LicenseId -import Distribution.SPDX.LicenseExpression -import Distribution.SPDX.LicenseReference -import Distribution.SPDX.LicenseListVersion diff --git a/cabal/Cabal/Distribution/SPDX/License.hs b/cabal/Cabal/Distribution/SPDX/License.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/SPDX/License.hs +++ /dev/null @@ -1,65 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.SPDX.License ( - License (..), - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Pretty -import Distribution.Parsec -import Distribution.SPDX.LicenseExpression - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - --- | Declared license. --- See [section 3.15 of SPDX Specification 2.1](https://spdx.org/spdx-specification-21-web-version#h.1hmsyys) --- --- /Note:/ the NOASSERTION case is omitted. --- --- Old 'License' can be migrated using following rules: --- --- * @AllRightsReserved@ and @UnspecifiedLicense@ to 'NONE'. --- No license specified which legally defaults to /All Rights Reserved/. --- The package may not be legally modified or redistributed by anyone but --- the rightsholder. --- --- * @OtherLicense@ can be converted to 'LicenseRef' pointing to the file --- in the package. --- --- * @UnknownLicense@ i.e. other licenses of the form @name-x.y@, should be --- covered by SPDX license list, otherwise use 'LicenseRef'. --- --- * @PublicDomain@ isn't covered. Consider using CC0. --- See --- for more information. --- -data License - = NONE - -- ^ if the package contains no license information whatsoever; or - | License LicenseExpression - -- ^ A valid SPDX License Expression as defined in Appendix IV. - deriving (Show, Read, Eq, Ord, Typeable, Data, Generic) - -instance Binary License -instance Structured License - -instance NFData License where - rnf NONE = () - rnf (License l) = rnf l - -instance Pretty License where - pretty NONE = Disp.text "NONE" - pretty (License l) = pretty l - --- | --- >>> eitherParsec "BSD-3-Clause AND MIT" :: Either String License --- Right (License (EAnd (ELicense (ELicenseId BSD_3_Clause) Nothing) (ELicense (ELicenseId MIT) Nothing))) --- --- >>> eitherParsec "NONE" :: Either String License --- Right NONE --- -instance Parsec License where - parsec = NONE <$ P.try (P.string "NONE") <|> License <$> parsec diff --git a/cabal/Cabal/Distribution/SPDX/LicenseExceptionId.hs b/cabal/Cabal/Distribution/SPDX/LicenseExceptionId.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/SPDX/LicenseExceptionId.hs +++ /dev/null @@ -1,294 +0,0 @@ --- This file is generated. See Makefile's spdx rule -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.SPDX.LicenseExceptionId ( - LicenseExceptionId (..), - licenseExceptionId, - licenseExceptionName, - mkLicenseExceptionId, - licenseExceptionIdList, - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Compat.Lens (set) -import Distribution.Pretty -import Distribution.Parsec -import Distribution.Utils.Generic (isAsciiAlphaNum) -import Distribution.Utils.Structured (Structured (..), nominalStructure, typeVersion) -import Distribution.SPDX.LicenseListVersion - -import qualified Data.Binary.Get as Binary -import qualified Data.Binary.Put as Binary -import qualified Data.Map.Strict as Map -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - -------------------------------------------------------------------------------- --- LicenseExceptionId -------------------------------------------------------------------------------- - --- | SPDX License identifier -data LicenseExceptionId - = DS389_exception -- ^ @389-exception@, 389 Directory Server Exception - | Autoconf_exception_2_0 -- ^ @Autoconf-exception-2.0@, Autoconf exception 2.0 - | Autoconf_exception_3_0 -- ^ @Autoconf-exception-3.0@, Autoconf exception 3.0 - | Bison_exception_2_2 -- ^ @Bison-exception-2.2@, Bison exception 2.2 - | Bootloader_exception -- ^ @Bootloader-exception@, Bootloader Distribution Exception - | Classpath_exception_2_0 -- ^ @Classpath-exception-2.0@, Classpath exception 2.0 - | CLISP_exception_2_0 -- ^ @CLISP-exception-2.0@, CLISP exception 2.0 - | DigiRule_FOSS_exception -- ^ @DigiRule-FOSS-exception@, DigiRule FOSS License Exception - | ECos_exception_2_0 -- ^ @eCos-exception-2.0@, eCos exception 2.0 - | Fawkes_Runtime_exception -- ^ @Fawkes-Runtime-exception@, Fawkes Runtime Exception - | FLTK_exception -- ^ @FLTK-exception@, FLTK exception - | Font_exception_2_0 -- ^ @Font-exception-2.0@, Font exception 2.0 - | Freertos_exception_2_0 -- ^ @freertos-exception-2.0@, FreeRTOS Exception 2.0 - | GCC_exception_2_0 -- ^ @GCC-exception-2.0@, GCC Runtime Library exception 2.0 - | GCC_exception_3_1 -- ^ @GCC-exception-3.1@, GCC Runtime Library exception 3.1 - | Gnu_javamail_exception -- ^ @gnu-javamail-exception@, GNU JavaMail exception - | GPL_3_0_linking_exception -- ^ @GPL-3.0-linking-exception@, GPL-3.0 Linking Exception, SPDX License List 3.9 - | GPL_3_0_linking_source_exception -- ^ @GPL-3.0-linking-source-exception@, GPL-3.0 Linking Exception (with Corresponding Source), SPDX License List 3.9 - | GPL_CC_1_0 -- ^ @GPL-CC-1.0@, GPL Cooperation Commitment 1.0, SPDX License List 3.6, SPDX License List 3.9 - | I2p_gpl_java_exception -- ^ @i2p-gpl-java-exception@, i2p GPL+Java Exception - | LGPL_3_0_linking_exception -- ^ @LGPL-3.0-linking-exception@, LGPL-3.0 Linking Exception, SPDX License List 3.9 - | Libtool_exception -- ^ @Libtool-exception@, Libtool Exception - | Linux_syscall_note -- ^ @Linux-syscall-note@, Linux Syscall Note - | LLVM_exception -- ^ @LLVM-exception@, LLVM Exception, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9 - | LZMA_exception -- ^ @LZMA-exception@, LZMA exception - | Mif_exception -- ^ @mif-exception@, Macros and Inline Functions Exception - | Nokia_Qt_exception_1_1 -- ^ @Nokia-Qt-exception-1.1@, Nokia Qt LGPL exception 1.1, SPDX License List 3.0, SPDX License List 3.2 - | OCaml_LGPL_linking_exception -- ^ @OCaml-LGPL-linking-exception@, OCaml LGPL Linking Exception, SPDX License List 3.6, SPDX License List 3.9 - | OCCT_exception_1_0 -- ^ @OCCT-exception-1.0@, Open CASCADE Exception 1.0 - | OpenJDK_assembly_exception_1_0 -- ^ @OpenJDK-assembly-exception-1.0@, OpenJDK Assembly exception 1.0, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9 - | Openvpn_openssl_exception -- ^ @openvpn-openssl-exception@, OpenVPN OpenSSL Exception - | PS_or_PDF_font_exception_20170817 -- ^ @PS-or-PDF-font-exception-20170817@, PS/PDF font exception (2017-08-17), SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9 - | Qt_GPL_exception_1_0 -- ^ @Qt-GPL-exception-1.0@, Qt GPL exception 1.0, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9 - | Qt_LGPL_exception_1_1 -- ^ @Qt-LGPL-exception-1.1@, Qt LGPL exception 1.1, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9 - | Qwt_exception_1_0 -- ^ @Qwt-exception-1.0@, Qwt exception 1.0 - | SHL_2_0 -- ^ @SHL-2.0@, Solderpad Hardware License v2.0, SPDX License List 3.9 - | SHL_2_1 -- ^ @SHL-2.1@, Solderpad Hardware License v2.1, SPDX License List 3.9 - | Swift_exception -- ^ @Swift-exception@, Swift Exception, SPDX License List 3.6, SPDX License List 3.9 - | U_boot_exception_2_0 -- ^ @u-boot-exception-2.0@, U-Boot exception 2.0 - | Universal_FOSS_exception_1_0 -- ^ @Universal-FOSS-exception-1.0@, Universal FOSS Exception, Version 1.0, SPDX License List 3.6, SPDX License List 3.9 - | WxWindows_exception_3_1 -- ^ @WxWindows-exception-3.1@, WxWindows Library Exception 3.1 - deriving (Eq, Ord, Enum, Bounded, Show, Read, Typeable, Data, Generic) - -instance Binary LicenseExceptionId where - put = Binary.putWord8 . fromIntegral . fromEnum - get = do - i <- Binary.getWord8 - if i > fromIntegral (fromEnum (maxBound :: LicenseExceptionId)) - then fail "Too large LicenseExceptionId tag" - else return (toEnum (fromIntegral i)) - --- note: remember to bump version each time the definition changes -instance Structured LicenseExceptionId where - structure p = set typeVersion 306 $ nominalStructure p - -instance Pretty LicenseExceptionId where - pretty = Disp.text . licenseExceptionId - -instance Parsec LicenseExceptionId where - parsec = do - n <- some $ P.satisfy $ \c -> isAsciiAlphaNum c || c == '-' || c == '.' - v <- askCabalSpecVersion - maybe (fail $ "Unknown SPDX license exception identifier: " ++ n) return $ - mkLicenseExceptionId (cabalSpecVersionToSPDXListVersion v) n - -instance NFData LicenseExceptionId where - rnf l = l `seq` () - -------------------------------------------------------------------------------- --- License Data -------------------------------------------------------------------------------- - --- | License SPDX identifier, e.g. @"BSD-3-Clause"@. -licenseExceptionId :: LicenseExceptionId -> String -licenseExceptionId DS389_exception = "389-exception" -licenseExceptionId Autoconf_exception_2_0 = "Autoconf-exception-2.0" -licenseExceptionId Autoconf_exception_3_0 = "Autoconf-exception-3.0" -licenseExceptionId Bison_exception_2_2 = "Bison-exception-2.2" -licenseExceptionId Bootloader_exception = "Bootloader-exception" -licenseExceptionId Classpath_exception_2_0 = "Classpath-exception-2.0" -licenseExceptionId CLISP_exception_2_0 = "CLISP-exception-2.0" -licenseExceptionId DigiRule_FOSS_exception = "DigiRule-FOSS-exception" -licenseExceptionId ECos_exception_2_0 = "eCos-exception-2.0" -licenseExceptionId Fawkes_Runtime_exception = "Fawkes-Runtime-exception" -licenseExceptionId FLTK_exception = "FLTK-exception" -licenseExceptionId Font_exception_2_0 = "Font-exception-2.0" -licenseExceptionId Freertos_exception_2_0 = "freertos-exception-2.0" -licenseExceptionId GCC_exception_2_0 = "GCC-exception-2.0" -licenseExceptionId GCC_exception_3_1 = "GCC-exception-3.1" -licenseExceptionId Gnu_javamail_exception = "gnu-javamail-exception" -licenseExceptionId GPL_3_0_linking_exception = "GPL-3.0-linking-exception" -licenseExceptionId GPL_3_0_linking_source_exception = "GPL-3.0-linking-source-exception" -licenseExceptionId GPL_CC_1_0 = "GPL-CC-1.0" -licenseExceptionId I2p_gpl_java_exception = "i2p-gpl-java-exception" -licenseExceptionId LGPL_3_0_linking_exception = "LGPL-3.0-linking-exception" -licenseExceptionId Libtool_exception = "Libtool-exception" -licenseExceptionId Linux_syscall_note = "Linux-syscall-note" -licenseExceptionId LLVM_exception = "LLVM-exception" -licenseExceptionId LZMA_exception = "LZMA-exception" -licenseExceptionId Mif_exception = "mif-exception" -licenseExceptionId Nokia_Qt_exception_1_1 = "Nokia-Qt-exception-1.1" -licenseExceptionId OCaml_LGPL_linking_exception = "OCaml-LGPL-linking-exception" -licenseExceptionId OCCT_exception_1_0 = "OCCT-exception-1.0" -licenseExceptionId OpenJDK_assembly_exception_1_0 = "OpenJDK-assembly-exception-1.0" -licenseExceptionId Openvpn_openssl_exception = "openvpn-openssl-exception" -licenseExceptionId PS_or_PDF_font_exception_20170817 = "PS-or-PDF-font-exception-20170817" -licenseExceptionId Qt_GPL_exception_1_0 = "Qt-GPL-exception-1.0" -licenseExceptionId Qt_LGPL_exception_1_1 = "Qt-LGPL-exception-1.1" -licenseExceptionId Qwt_exception_1_0 = "Qwt-exception-1.0" -licenseExceptionId SHL_2_0 = "SHL-2.0" -licenseExceptionId SHL_2_1 = "SHL-2.1" -licenseExceptionId Swift_exception = "Swift-exception" -licenseExceptionId U_boot_exception_2_0 = "u-boot-exception-2.0" -licenseExceptionId Universal_FOSS_exception_1_0 = "Universal-FOSS-exception-1.0" -licenseExceptionId WxWindows_exception_3_1 = "WxWindows-exception-3.1" - --- | License name, e.g. @"GNU General Public License v2.0 only"@ -licenseExceptionName :: LicenseExceptionId -> String -licenseExceptionName DS389_exception = "389 Directory Server Exception" -licenseExceptionName Autoconf_exception_2_0 = "Autoconf exception 2.0" -licenseExceptionName Autoconf_exception_3_0 = "Autoconf exception 3.0" -licenseExceptionName Bison_exception_2_2 = "Bison exception 2.2" -licenseExceptionName Bootloader_exception = "Bootloader Distribution Exception" -licenseExceptionName Classpath_exception_2_0 = "Classpath exception 2.0" -licenseExceptionName CLISP_exception_2_0 = "CLISP exception 2.0" -licenseExceptionName DigiRule_FOSS_exception = "DigiRule FOSS License Exception" -licenseExceptionName ECos_exception_2_0 = "eCos exception 2.0" -licenseExceptionName Fawkes_Runtime_exception = "Fawkes Runtime Exception" -licenseExceptionName FLTK_exception = "FLTK exception" -licenseExceptionName Font_exception_2_0 = "Font exception 2.0" -licenseExceptionName Freertos_exception_2_0 = "FreeRTOS Exception 2.0" -licenseExceptionName GCC_exception_2_0 = "GCC Runtime Library exception 2.0" -licenseExceptionName GCC_exception_3_1 = "GCC Runtime Library exception 3.1" -licenseExceptionName Gnu_javamail_exception = "GNU JavaMail exception" -licenseExceptionName GPL_3_0_linking_exception = "GPL-3.0 Linking Exception" -licenseExceptionName GPL_3_0_linking_source_exception = "GPL-3.0 Linking Exception (with Corresponding Source)" -licenseExceptionName GPL_CC_1_0 = "GPL Cooperation Commitment 1.0" -licenseExceptionName I2p_gpl_java_exception = "i2p GPL+Java Exception" -licenseExceptionName LGPL_3_0_linking_exception = "LGPL-3.0 Linking Exception" -licenseExceptionName Libtool_exception = "Libtool Exception" -licenseExceptionName Linux_syscall_note = "Linux Syscall Note" -licenseExceptionName LLVM_exception = "LLVM Exception" -licenseExceptionName LZMA_exception = "LZMA exception" -licenseExceptionName Mif_exception = "Macros and Inline Functions Exception" -licenseExceptionName Nokia_Qt_exception_1_1 = "Nokia Qt LGPL exception 1.1" -licenseExceptionName OCaml_LGPL_linking_exception = "OCaml LGPL Linking Exception" -licenseExceptionName OCCT_exception_1_0 = "Open CASCADE Exception 1.0" -licenseExceptionName OpenJDK_assembly_exception_1_0 = "OpenJDK Assembly exception 1.0" -licenseExceptionName Openvpn_openssl_exception = "OpenVPN OpenSSL Exception" -licenseExceptionName PS_or_PDF_font_exception_20170817 = "PS/PDF font exception (2017-08-17)" -licenseExceptionName Qt_GPL_exception_1_0 = "Qt GPL exception 1.0" -licenseExceptionName Qt_LGPL_exception_1_1 = "Qt LGPL exception 1.1" -licenseExceptionName Qwt_exception_1_0 = "Qwt exception 1.0" -licenseExceptionName SHL_2_0 = "Solderpad Hardware License v2.0" -licenseExceptionName SHL_2_1 = "Solderpad Hardware License v2.1" -licenseExceptionName Swift_exception = "Swift Exception" -licenseExceptionName U_boot_exception_2_0 = "U-Boot exception 2.0" -licenseExceptionName Universal_FOSS_exception_1_0 = "Universal FOSS Exception, Version 1.0" -licenseExceptionName WxWindows_exception_3_1 = "WxWindows Library Exception 3.1" - -------------------------------------------------------------------------------- --- Creation -------------------------------------------------------------------------------- - -licenseExceptionIdList :: LicenseListVersion -> [LicenseExceptionId] -licenseExceptionIdList LicenseListVersion_3_0 = - [ Nokia_Qt_exception_1_1 - ] - ++ bulkOfLicenses -licenseExceptionIdList LicenseListVersion_3_2 = - [ LLVM_exception - , Nokia_Qt_exception_1_1 - , OpenJDK_assembly_exception_1_0 - , PS_or_PDF_font_exception_20170817 - , Qt_GPL_exception_1_0 - , Qt_LGPL_exception_1_1 - ] - ++ bulkOfLicenses -licenseExceptionIdList LicenseListVersion_3_6 = - [ GPL_CC_1_0 - , LLVM_exception - , OCaml_LGPL_linking_exception - , OpenJDK_assembly_exception_1_0 - , PS_or_PDF_font_exception_20170817 - , Qt_GPL_exception_1_0 - , Qt_LGPL_exception_1_1 - , Swift_exception - , Universal_FOSS_exception_1_0 - ] - ++ bulkOfLicenses -licenseExceptionIdList LicenseListVersion_3_9 = - [ GPL_3_0_linking_exception - , GPL_3_0_linking_source_exception - , GPL_CC_1_0 - , LGPL_3_0_linking_exception - , LLVM_exception - , OCaml_LGPL_linking_exception - , OpenJDK_assembly_exception_1_0 - , PS_or_PDF_font_exception_20170817 - , Qt_GPL_exception_1_0 - , Qt_LGPL_exception_1_1 - , SHL_2_0 - , SHL_2_1 - , Swift_exception - , Universal_FOSS_exception_1_0 - ] - ++ bulkOfLicenses - --- | Create a 'LicenseExceptionId' from a 'String'. -mkLicenseExceptionId :: LicenseListVersion -> String -> Maybe LicenseExceptionId -mkLicenseExceptionId LicenseListVersion_3_0 s = Map.lookup s stringLookup_3_0 -mkLicenseExceptionId LicenseListVersion_3_2 s = Map.lookup s stringLookup_3_2 -mkLicenseExceptionId LicenseListVersion_3_6 s = Map.lookup s stringLookup_3_6 -mkLicenseExceptionId LicenseListVersion_3_9 s = Map.lookup s stringLookup_3_9 - -stringLookup_3_0 :: Map String LicenseExceptionId -stringLookup_3_0 = Map.fromList $ map (\i -> (licenseExceptionId i, i)) $ - licenseExceptionIdList LicenseListVersion_3_0 - -stringLookup_3_2 :: Map String LicenseExceptionId -stringLookup_3_2 = Map.fromList $ map (\i -> (licenseExceptionId i, i)) $ - licenseExceptionIdList LicenseListVersion_3_2 - -stringLookup_3_6 :: Map String LicenseExceptionId -stringLookup_3_6 = Map.fromList $ map (\i -> (licenseExceptionId i, i)) $ - licenseExceptionIdList LicenseListVersion_3_6 - -stringLookup_3_9 :: Map String LicenseExceptionId -stringLookup_3_9 = Map.fromList $ map (\i -> (licenseExceptionId i, i)) $ - licenseExceptionIdList LicenseListVersion_3_9 - --- | License exceptions in all SPDX License lists -bulkOfLicenses :: [LicenseExceptionId] -bulkOfLicenses = - [ DS389_exception - , Autoconf_exception_2_0 - , Autoconf_exception_3_0 - , Bison_exception_2_2 - , Bootloader_exception - , Classpath_exception_2_0 - , CLISP_exception_2_0 - , DigiRule_FOSS_exception - , ECos_exception_2_0 - , Fawkes_Runtime_exception - , FLTK_exception - , Font_exception_2_0 - , Freertos_exception_2_0 - , GCC_exception_2_0 - , GCC_exception_3_1 - , Gnu_javamail_exception - , I2p_gpl_java_exception - , Libtool_exception - , Linux_syscall_note - , LZMA_exception - , Mif_exception - , OCCT_exception_1_0 - , Openvpn_openssl_exception - , Qwt_exception_1_0 - , U_boot_exception_2_0 - , WxWindows_exception_3_1 - ] diff --git a/cabal/Cabal/Distribution/SPDX/LicenseExpression.hs b/cabal/Cabal/Distribution/SPDX/LicenseExpression.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/SPDX/LicenseExpression.hs +++ /dev/null @@ -1,162 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.SPDX.LicenseExpression ( - LicenseExpression (..), - SimpleLicenseExpression (..), - simpleLicenseExpression, - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Parsec -import Distribution.Pretty -import Distribution.SPDX.LicenseExceptionId -import Distribution.SPDX.LicenseId -import Distribution.SPDX.LicenseListVersion -import Distribution.SPDX.LicenseReference -import Distribution.Utils.Generic (isAsciiAlphaNum) - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - --- | SPDX License Expression. --- --- @ --- idstring = 1*(ALPHA \/ DIGIT \/ "-" \/ "." ) --- license id = \ --- license exception id = \ --- license ref = [\"DocumentRef-"1*(idstring)":"]\"LicenseRef-"1*(idstring) --- --- simple expression = license id \/ license id"+" \/ license ref --- --- compound expression = 1*1(simple expression \/ --- simple expression \"WITH" license exception id \/ --- compound expression \"AND" compound expression \/ --- compound expression \"OR" compound expression ) \/ --- "(" compound expression ")" ) --- --- license expression = 1*1(simple expression / compound expression) --- @ -data LicenseExpression - = ELicense !SimpleLicenseExpression !(Maybe LicenseExceptionId) - | EAnd !LicenseExpression !LicenseExpression - | EOr !LicenseExpression !LicenseExpression - deriving (Show, Read, Eq, Ord, Typeable, Data, Generic) - --- | Simple License Expressions. -data SimpleLicenseExpression - = ELicenseId LicenseId - -- ^ An SPDX License List Short Form Identifier. For example: @GPL-2.0-only@ - | ELicenseIdPlus LicenseId - -- ^ An SPDX License List Short Form Identifier with a unary"+" operator suffix to represent the current version of the license or any later version. For example: @GPL-2.0+@ - | ELicenseRef LicenseRef - -- ^ A SPDX user defined license reference: For example: @LicenseRef-23@, @LicenseRef-MIT-Style-1@, or @DocumentRef-spdx-tool-1.2:LicenseRef-MIT-Style-2@ - deriving (Show, Read, Eq, Ord, Typeable, Data, Generic) - -simpleLicenseExpression :: LicenseId -> LicenseExpression -simpleLicenseExpression i = ELicense (ELicenseId i) Nothing - -instance Binary LicenseExpression -instance Binary SimpleLicenseExpression -instance Structured SimpleLicenseExpression -instance Structured LicenseExpression - -instance Pretty LicenseExpression where - pretty = go 0 - where - go :: Int -> LicenseExpression -> Disp.Doc - go _ (ELicense lic exc) = - let doc = pretty lic - in maybe id (\e d -> d <+> Disp.text "WITH" <+> pretty e) exc doc - go d (EAnd e1 e2) = parens (d < 0) $ go 0 e1 <+> Disp.text "AND" <+> go 0 e2 - go d (EOr e1 e2) = parens (d < 1) $ go 1 e1 <+> Disp.text "OR" <+> go 1 e2 - - - parens False doc = doc - parens True doc = Disp.parens doc - -instance Pretty SimpleLicenseExpression where - pretty (ELicenseId i) = pretty i - pretty (ELicenseIdPlus i) = pretty i <<>> Disp.char '+' - pretty (ELicenseRef r) = pretty r - -instance Parsec SimpleLicenseExpression where - parsec = idstring >>= simple where - simple n - | Just l <- "LicenseRef-" `isPrefixOfMaybe` n = - maybe (fail $ "Incorrect LicenseRef format: " ++ n) (return . ELicenseRef) $ mkLicenseRef Nothing l - | Just d <- "DocumentRef-" `isPrefixOfMaybe` n = do - _ <- P.string ":LicenseRef-" - l <- idstring - maybe (fail $ "Incorrect LicenseRef format:" ++ n) (return . ELicenseRef) $ mkLicenseRef (Just d) l - | otherwise = do - v <- askCabalSpecVersion - l <- maybe (fail $ "Unknown SPDX license identifier: '" ++ n ++ "' " ++ licenseIdMigrationMessage n) return $ - mkLicenseId (cabalSpecVersionToSPDXListVersion v) n - orLater <- isJust <$> P.optional (P.char '+') - if orLater - then return (ELicenseIdPlus l) - else return (ELicenseId l) - -idstring :: P.CharParsing m => m String -idstring = P.munch1 $ \c -> isAsciiAlphaNum c || c == '-' || c == '.' - --- returns suffix part -isPrefixOfMaybe :: Eq a => [a] -> [a] -> Maybe [a] -isPrefixOfMaybe pfx s - | pfx `isPrefixOf` s = Just (drop (length pfx) s) - | otherwise = Nothing - -instance Parsec LicenseExpression where - parsec = expr - where - expr = compoundOr - - simple = do - s <- parsec - exc <- exception - return $ ELicense s exc - - exception = P.optional $ P.try (spaces1 *> P.string "WITH" *> spaces1) *> parsec - - compoundOr = do - x <- compoundAnd - l <- P.optional $ P.try (spaces1 *> P.string "OR" *> spaces1) *> compoundOr - return $ maybe id (flip EOr) l x - - compoundAnd = do - x <- compound - l <- P.optional $ P.try (spaces1 *> P.string "AND" *> spaces1) *> compoundAnd - return $ maybe id (flip EAnd) l x - - compound = braces <|> simple - - -- NOTE: we require that there's a space around AND & OR operators, - -- i.e. @(MIT)AND(MIT)@ will cause parse-error. - braces = do - _ <- P.char '(' - _ <- P.spaces - x <- expr - _ <- P.char ')' - return x - - spaces1 = P.space *> P.spaces - --- notes: --- --- There MUST NOT be whitespace between a license­id and any following "+".  This supports easy parsing and --- backwards compatibility.  There MUST be whitespace on either side of the operator "WITH".  There MUST be --- whitespace and/or parentheses on either side of the operators "AND" and "OR". --- --- We handle that by having greedy 'idstring' parser, so MITAND would parse as invalid license identifier. - -instance NFData LicenseExpression where - rnf (ELicense s e) = rnf s `seq` rnf e - rnf (EAnd x y) = rnf x `seq` rnf y - rnf (EOr x y) = rnf x `seq` rnf y - -instance NFData SimpleLicenseExpression where - rnf (ELicenseId i) = rnf i - rnf (ELicenseIdPlus i) = rnf i - rnf (ELicenseRef r) = rnf r diff --git a/cabal/Cabal/Distribution/SPDX/LicenseId.hs b/cabal/Cabal/Distribution/SPDX/LicenseId.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/SPDX/LicenseId.hs +++ /dev/null @@ -1,2025 +0,0 @@ --- This file is generated. See Makefile's spdx rule -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.SPDX.LicenseId ( - LicenseId (..), - licenseId, - licenseName, - licenseIsOsiApproved, - licenseIsFsfLibre, - mkLicenseId, - licenseIdList, - -- * Helpers - licenseIdMigrationMessage, - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Compat.Lens (set) -import Distribution.Pretty -import Distribution.Parsec -import Distribution.Utils.Generic (isAsciiAlphaNum) -import Distribution.Utils.Structured (Structured (..), nominalStructure, typeVersion) -import Distribution.SPDX.LicenseListVersion - -import qualified Data.Binary.Get as Binary -import qualified Data.Binary.Put as Binary -import qualified Data.Map.Strict as Map -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - -------------------------------------------------------------------------------- --- LicenseId -------------------------------------------------------------------------------- - --- | SPDX License identifier -data LicenseId - = NullBSD -- ^ @0BSD@, BSD Zero Clause License - | AAL -- ^ @AAL@, Attribution Assurance License - | Abstyles -- ^ @Abstyles@, Abstyles License - | Adobe_2006 -- ^ @Adobe-2006@, Adobe Systems Incorporated Source Code License Agreement - | Adobe_Glyph -- ^ @Adobe-Glyph@, Adobe Glyph List License - | ADSL -- ^ @ADSL@, Amazon Digital Services License - | AFL_1_1 -- ^ @AFL-1.1@, Academic Free License v1.1 - | AFL_1_2 -- ^ @AFL-1.2@, Academic Free License v1.2 - | AFL_2_0 -- ^ @AFL-2.0@, Academic Free License v2.0 - | AFL_2_1 -- ^ @AFL-2.1@, Academic Free License v2.1 - | AFL_3_0 -- ^ @AFL-3.0@, Academic Free License v3.0 - | Afmparse -- ^ @Afmparse@, Afmparse License - | AGPL_1_0 -- ^ @AGPL-1.0@, Affero General Public License v1.0, SPDX License List 3.0 - | AGPL_1_0_only -- ^ @AGPL-1.0-only@, Affero General Public License v1.0 only, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9 - | AGPL_1_0_or_later -- ^ @AGPL-1.0-or-later@, Affero General Public License v1.0 or later, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9 - | AGPL_3_0_only -- ^ @AGPL-3.0-only@, GNU Affero General Public License v3.0 only - | AGPL_3_0_or_later -- ^ @AGPL-3.0-or-later@, GNU Affero General Public License v3.0 or later - | Aladdin -- ^ @Aladdin@, Aladdin Free Public License - | AMDPLPA -- ^ @AMDPLPA@, AMD's plpa_map.c License - | AML -- ^ @AML@, Apple MIT License - | AMPAS -- ^ @AMPAS@, Academy of Motion Picture Arts and Sciences BSD - | ANTLR_PD -- ^ @ANTLR-PD@, ANTLR Software Rights Notice - | Apache_1_0 -- ^ @Apache-1.0@, Apache License 1.0 - | Apache_1_1 -- ^ @Apache-1.1@, Apache License 1.1 - | Apache_2_0 -- ^ @Apache-2.0@, Apache License 2.0 - | APAFML -- ^ @APAFML@, Adobe Postscript AFM License - | APL_1_0 -- ^ @APL-1.0@, Adaptive Public License 1.0 - | APSL_1_0 -- ^ @APSL-1.0@, Apple Public Source License 1.0 - | APSL_1_1 -- ^ @APSL-1.1@, Apple Public Source License 1.1 - | APSL_1_2 -- ^ @APSL-1.2@, Apple Public Source License 1.2 - | APSL_2_0 -- ^ @APSL-2.0@, Apple Public Source License 2.0 - | Artistic_1_0_cl8 -- ^ @Artistic-1.0-cl8@, Artistic License 1.0 w/clause 8 - | Artistic_1_0_Perl -- ^ @Artistic-1.0-Perl@, Artistic License 1.0 (Perl) - | Artistic_1_0 -- ^ @Artistic-1.0@, Artistic License 1.0 - | Artistic_2_0 -- ^ @Artistic-2.0@, Artistic License 2.0 - | Bahyph -- ^ @Bahyph@, Bahyph License - | Barr -- ^ @Barr@, Barr License - | Beerware -- ^ @Beerware@, Beerware License - | BitTorrent_1_0 -- ^ @BitTorrent-1.0@, BitTorrent Open Source License v1.0 - | BitTorrent_1_1 -- ^ @BitTorrent-1.1@, BitTorrent Open Source License v1.1 - | Blessing -- ^ @blessing@, SQLite Blessing, SPDX License List 3.6, SPDX License List 3.9 - | BlueOak_1_0_0 -- ^ @BlueOak-1.0.0@, Blue Oak Model License 1.0.0, SPDX License List 3.6, SPDX License List 3.9 - | Borceux -- ^ @Borceux@, Borceux license - | BSD_1_Clause -- ^ @BSD-1-Clause@, BSD 1-Clause License - | BSD_2_Clause_FreeBSD -- ^ @BSD-2-Clause-FreeBSD@, BSD 2-Clause FreeBSD License - | BSD_2_Clause_NetBSD -- ^ @BSD-2-Clause-NetBSD@, BSD 2-Clause NetBSD License, SPDX License List 3.0, SPDX License List 3.2, SPDX License List 3.6 - | BSD_2_Clause_Patent -- ^ @BSD-2-Clause-Patent@, BSD-2-Clause Plus Patent License - | BSD_2_Clause -- ^ @BSD-2-Clause@, BSD 2-Clause "Simplified" License - | BSD_3_Clause_Attribution -- ^ @BSD-3-Clause-Attribution@, BSD with attribution - | BSD_3_Clause_Clear -- ^ @BSD-3-Clause-Clear@, BSD 3-Clause Clear License - | BSD_3_Clause_LBNL -- ^ @BSD-3-Clause-LBNL@, Lawrence Berkeley National Labs BSD variant license - | BSD_3_Clause_No_Nuclear_License_2014 -- ^ @BSD-3-Clause-No-Nuclear-License-2014@, BSD 3-Clause No Nuclear License 2014 - | BSD_3_Clause_No_Nuclear_License -- ^ @BSD-3-Clause-No-Nuclear-License@, BSD 3-Clause No Nuclear License - | BSD_3_Clause_No_Nuclear_Warranty -- ^ @BSD-3-Clause-No-Nuclear-Warranty@, BSD 3-Clause No Nuclear Warranty - | BSD_3_Clause_Open_MPI -- ^ @BSD-3-Clause-Open-MPI@, BSD 3-Clause Open MPI variant, SPDX License List 3.6, SPDX License List 3.9 - | BSD_3_Clause -- ^ @BSD-3-Clause@, BSD 3-Clause "New" or "Revised" License - | BSD_4_Clause_UC -- ^ @BSD-4-Clause-UC@, BSD-4-Clause (University of California-Specific) - | BSD_4_Clause -- ^ @BSD-4-Clause@, BSD 4-Clause "Original" or "Old" License - | BSD_Protection -- ^ @BSD-Protection@, BSD Protection License - | BSD_Source_Code -- ^ @BSD-Source-Code@, BSD Source Code Attribution - | BSL_1_0 -- ^ @BSL-1.0@, Boost Software License 1.0 - | Bzip2_1_0_5 -- ^ @bzip2-1.0.5@, bzip2 and libbzip2 License v1.0.5 - | Bzip2_1_0_6 -- ^ @bzip2-1.0.6@, bzip2 and libbzip2 License v1.0.6 - | CAL_1_0_Combined_Work_Exception -- ^ @CAL-1.0-Combined-Work-Exception@, Cryptographic Autonomy License 1.0 (Combined Work Exception), SPDX License List 3.9 - | CAL_1_0 -- ^ @CAL-1.0@, Cryptographic Autonomy License 1.0, SPDX License List 3.9 - | Caldera -- ^ @Caldera@, Caldera License - | CATOSL_1_1 -- ^ @CATOSL-1.1@, Computer Associates Trusted Open Source License 1.1 - | CC_BY_1_0 -- ^ @CC-BY-1.0@, Creative Commons Attribution 1.0 Generic - | CC_BY_2_0 -- ^ @CC-BY-2.0@, Creative Commons Attribution 2.0 Generic - | CC_BY_2_5 -- ^ @CC-BY-2.5@, Creative Commons Attribution 2.5 Generic - | CC_BY_3_0 -- ^ @CC-BY-3.0@, Creative Commons Attribution 3.0 Unported - | CC_BY_4_0 -- ^ @CC-BY-4.0@, Creative Commons Attribution 4.0 International - | CC_BY_NC_1_0 -- ^ @CC-BY-NC-1.0@, Creative Commons Attribution Non Commercial 1.0 Generic - | CC_BY_NC_2_0 -- ^ @CC-BY-NC-2.0@, Creative Commons Attribution Non Commercial 2.0 Generic - | CC_BY_NC_2_5 -- ^ @CC-BY-NC-2.5@, Creative Commons Attribution Non Commercial 2.5 Generic - | CC_BY_NC_3_0 -- ^ @CC-BY-NC-3.0@, Creative Commons Attribution Non Commercial 3.0 Unported - | CC_BY_NC_4_0 -- ^ @CC-BY-NC-4.0@, Creative Commons Attribution Non Commercial 4.0 International - | CC_BY_NC_ND_1_0 -- ^ @CC-BY-NC-ND-1.0@, Creative Commons Attribution Non Commercial No Derivatives 1.0 Generic - | CC_BY_NC_ND_2_0 -- ^ @CC-BY-NC-ND-2.0@, Creative Commons Attribution Non Commercial No Derivatives 2.0 Generic - | CC_BY_NC_ND_2_5 -- ^ @CC-BY-NC-ND-2.5@, Creative Commons Attribution Non Commercial No Derivatives 2.5 Generic - | CC_BY_NC_ND_3_0 -- ^ @CC-BY-NC-ND-3.0@, Creative Commons Attribution Non Commercial No Derivatives 3.0 Unported - | CC_BY_NC_ND_4_0 -- ^ @CC-BY-NC-ND-4.0@, Creative Commons Attribution Non Commercial No Derivatives 4.0 International - | CC_BY_NC_SA_1_0 -- ^ @CC-BY-NC-SA-1.0@, Creative Commons Attribution Non Commercial Share Alike 1.0 Generic - | CC_BY_NC_SA_2_0 -- ^ @CC-BY-NC-SA-2.0@, Creative Commons Attribution Non Commercial Share Alike 2.0 Generic - | CC_BY_NC_SA_2_5 -- ^ @CC-BY-NC-SA-2.5@, Creative Commons Attribution Non Commercial Share Alike 2.5 Generic - | CC_BY_NC_SA_3_0 -- ^ @CC-BY-NC-SA-3.0@, Creative Commons Attribution Non Commercial Share Alike 3.0 Unported - | CC_BY_NC_SA_4_0 -- ^ @CC-BY-NC-SA-4.0@, Creative Commons Attribution Non Commercial Share Alike 4.0 International - | CC_BY_ND_1_0 -- ^ @CC-BY-ND-1.0@, Creative Commons Attribution No Derivatives 1.0 Generic - | CC_BY_ND_2_0 -- ^ @CC-BY-ND-2.0@, Creative Commons Attribution No Derivatives 2.0 Generic - | CC_BY_ND_2_5 -- ^ @CC-BY-ND-2.5@, Creative Commons Attribution No Derivatives 2.5 Generic - | CC_BY_ND_3_0 -- ^ @CC-BY-ND-3.0@, Creative Commons Attribution No Derivatives 3.0 Unported - | CC_BY_ND_4_0 -- ^ @CC-BY-ND-4.0@, Creative Commons Attribution No Derivatives 4.0 International - | CC_BY_SA_1_0 -- ^ @CC-BY-SA-1.0@, Creative Commons Attribution Share Alike 1.0 Generic - | CC_BY_SA_2_0 -- ^ @CC-BY-SA-2.0@, Creative Commons Attribution Share Alike 2.0 Generic - | CC_BY_SA_2_5 -- ^ @CC-BY-SA-2.5@, Creative Commons Attribution Share Alike 2.5 Generic - | CC_BY_SA_3_0 -- ^ @CC-BY-SA-3.0@, Creative Commons Attribution Share Alike 3.0 Unported - | CC_BY_SA_4_0 -- ^ @CC-BY-SA-4.0@, Creative Commons Attribution Share Alike 4.0 International - | CC_PDDC -- ^ @CC-PDDC@, Creative Commons Public Domain Dedication and Certification, SPDX License List 3.6, SPDX License List 3.9 - | CC0_1_0 -- ^ @CC0-1.0@, Creative Commons Zero v1.0 Universal - | CDDL_1_0 -- ^ @CDDL-1.0@, Common Development and Distribution License 1.0 - | CDDL_1_1 -- ^ @CDDL-1.1@, Common Development and Distribution License 1.1 - | CDLA_Permissive_1_0 -- ^ @CDLA-Permissive-1.0@, Community Data License Agreement Permissive 1.0 - | CDLA_Sharing_1_0 -- ^ @CDLA-Sharing-1.0@, Community Data License Agreement Sharing 1.0 - | CECILL_1_0 -- ^ @CECILL-1.0@, CeCILL Free Software License Agreement v1.0 - | CECILL_1_1 -- ^ @CECILL-1.1@, CeCILL Free Software License Agreement v1.1 - | CECILL_2_0 -- ^ @CECILL-2.0@, CeCILL Free Software License Agreement v2.0 - | CECILL_2_1 -- ^ @CECILL-2.1@, CeCILL Free Software License Agreement v2.1 - | CECILL_B -- ^ @CECILL-B@, CeCILL-B Free Software License Agreement - | CECILL_C -- ^ @CECILL-C@, CeCILL-C Free Software License Agreement - | CERN_OHL_1_1 -- ^ @CERN-OHL-1.1@, CERN Open Hardware Licence v1.1, SPDX License List 3.6, SPDX License List 3.9 - | CERN_OHL_1_2 -- ^ @CERN-OHL-1.2@, CERN Open Hardware Licence v1.2, SPDX License List 3.6, SPDX License List 3.9 - | CERN_OHL_P_2_0 -- ^ @CERN-OHL-P-2.0@, CERN Open Hardware Licence Version 2 - Permissive, SPDX License List 3.9 - | CERN_OHL_S_2_0 -- ^ @CERN-OHL-S-2.0@, CERN Open Hardware Licence Version 2 - Strongly Reciprocal, SPDX License List 3.9 - | CERN_OHL_W_2_0 -- ^ @CERN-OHL-W-2.0@, CERN Open Hardware Licence Version 2 - Weakly Reciprocal, SPDX License List 3.9 - | ClArtistic -- ^ @ClArtistic@, Clarified Artistic License - | CNRI_Jython -- ^ @CNRI-Jython@, CNRI Jython License - | CNRI_Python_GPL_Compatible -- ^ @CNRI-Python-GPL-Compatible@, CNRI Python Open Source GPL Compatible License Agreement - | CNRI_Python -- ^ @CNRI-Python@, CNRI Python License - | Condor_1_1 -- ^ @Condor-1.1@, Condor Public License v1.1 - | Copyleft_next_0_3_0 -- ^ @copyleft-next-0.3.0@, copyleft-next 0.3.0, SPDX License List 3.6, SPDX License List 3.9 - | Copyleft_next_0_3_1 -- ^ @copyleft-next-0.3.1@, copyleft-next 0.3.1, SPDX License List 3.6, SPDX License List 3.9 - | CPAL_1_0 -- ^ @CPAL-1.0@, Common Public Attribution License 1.0 - | CPL_1_0 -- ^ @CPL-1.0@, Common Public License 1.0 - | CPOL_1_02 -- ^ @CPOL-1.02@, Code Project Open License 1.02 - | Crossword -- ^ @Crossword@, Crossword License - | CrystalStacker -- ^ @CrystalStacker@, CrystalStacker License - | CUA_OPL_1_0 -- ^ @CUA-OPL-1.0@, CUA Office Public License v1.0 - | Cube -- ^ @Cube@, Cube License - | Curl -- ^ @curl@, curl License - | D_FSL_1_0 -- ^ @D-FSL-1.0@, Deutsche Freie Software Lizenz - | Diffmark -- ^ @diffmark@, diffmark license - | DOC -- ^ @DOC@, DOC License - | Dotseqn -- ^ @Dotseqn@, Dotseqn License - | DSDP -- ^ @DSDP@, DSDP License - | Dvipdfm -- ^ @dvipdfm@, dvipdfm License - | ECL_1_0 -- ^ @ECL-1.0@, Educational Community License v1.0 - | ECL_2_0 -- ^ @ECL-2.0@, Educational Community License v2.0 - | EFL_1_0 -- ^ @EFL-1.0@, Eiffel Forum License v1.0 - | EFL_2_0 -- ^ @EFL-2.0@, Eiffel Forum License v2.0 - | EGenix -- ^ @eGenix@, eGenix.com Public License 1.1.0 - | Entessa -- ^ @Entessa@, Entessa Public License v1.0 - | EPL_1_0 -- ^ @EPL-1.0@, Eclipse Public License 1.0 - | EPL_2_0 -- ^ @EPL-2.0@, Eclipse Public License 2.0 - | ErlPL_1_1 -- ^ @ErlPL-1.1@, Erlang Public License v1.1 - | Etalab_2_0 -- ^ @etalab-2.0@, Etalab Open License 2.0, SPDX License List 3.9 - | EUDatagrid -- ^ @EUDatagrid@, EU DataGrid Software License - | EUPL_1_0 -- ^ @EUPL-1.0@, European Union Public License 1.0 - | EUPL_1_1 -- ^ @EUPL-1.1@, European Union Public License 1.1 - | EUPL_1_2 -- ^ @EUPL-1.2@, European Union Public License 1.2 - | Eurosym -- ^ @Eurosym@, Eurosym License - | Fair -- ^ @Fair@, Fair License - | Frameworx_1_0 -- ^ @Frameworx-1.0@, Frameworx Open License 1.0 - | FreeImage -- ^ @FreeImage@, FreeImage Public License v1.0 - | FSFAP -- ^ @FSFAP@, FSF All Permissive License - | FSFULLR -- ^ @FSFULLR@, FSF Unlimited License (with License Retention) - | FSFUL -- ^ @FSFUL@, FSF Unlimited License - | FTL -- ^ @FTL@, Freetype Project License - | GFDL_1_1_only -- ^ @GFDL-1.1-only@, GNU Free Documentation License v1.1 only - | GFDL_1_1_or_later -- ^ @GFDL-1.1-or-later@, GNU Free Documentation License v1.1 or later - | GFDL_1_2_only -- ^ @GFDL-1.2-only@, GNU Free Documentation License v1.2 only - | GFDL_1_2_or_later -- ^ @GFDL-1.2-or-later@, GNU Free Documentation License v1.2 or later - | GFDL_1_3_only -- ^ @GFDL-1.3-only@, GNU Free Documentation License v1.3 only - | GFDL_1_3_or_later -- ^ @GFDL-1.3-or-later@, GNU Free Documentation License v1.3 or later - | Giftware -- ^ @Giftware@, Giftware License - | GL2PS -- ^ @GL2PS@, GL2PS License - | Glide -- ^ @Glide@, 3dfx Glide License - | Glulxe -- ^ @Glulxe@, Glulxe License - | Gnuplot -- ^ @gnuplot@, gnuplot License - | GPL_1_0_only -- ^ @GPL-1.0-only@, GNU General Public License v1.0 only - | GPL_1_0_or_later -- ^ @GPL-1.0-or-later@, GNU General Public License v1.0 or later - | GPL_2_0_only -- ^ @GPL-2.0-only@, GNU General Public License v2.0 only - | GPL_2_0_or_later -- ^ @GPL-2.0-or-later@, GNU General Public License v2.0 or later - | GPL_3_0_only -- ^ @GPL-3.0-only@, GNU General Public License v3.0 only - | GPL_3_0_or_later -- ^ @GPL-3.0-or-later@, GNU General Public License v3.0 or later - | GSOAP_1_3b -- ^ @gSOAP-1.3b@, gSOAP Public License v1.3b - | HaskellReport -- ^ @HaskellReport@, Haskell Language Report License - | Hippocratic_2_1 -- ^ @Hippocratic-2.1@, Hippocratic License 2.1, SPDX License List 3.9 - | HPND_sell_variant -- ^ @HPND-sell-variant@, Historical Permission Notice and Disclaimer - sell variant, SPDX License List 3.6, SPDX License List 3.9 - | HPND -- ^ @HPND@, Historical Permission Notice and Disclaimer - | IBM_pibs -- ^ @IBM-pibs@, IBM PowerPC Initialization and Boot Software - | ICU -- ^ @ICU@, ICU License - | IJG -- ^ @IJG@, Independent JPEG Group License - | ImageMagick -- ^ @ImageMagick@, ImageMagick License - | IMatix -- ^ @iMatix@, iMatix Standard Function Library Agreement - | Imlib2 -- ^ @Imlib2@, Imlib2 License - | Info_ZIP -- ^ @Info-ZIP@, Info-ZIP License - | Intel_ACPI -- ^ @Intel-ACPI@, Intel ACPI Software License Agreement - | Intel -- ^ @Intel@, Intel Open Source License - | Interbase_1_0 -- ^ @Interbase-1.0@, Interbase Public License v1.0 - | IPA -- ^ @IPA@, IPA Font License - | IPL_1_0 -- ^ @IPL-1.0@, IBM Public License v1.0 - | ISC -- ^ @ISC@, ISC License - | JasPer_2_0 -- ^ @JasPer-2.0@, JasPer License - | JPNIC -- ^ @JPNIC@, Japan Network Information Center License, SPDX License List 3.6, SPDX License List 3.9 - | JSON -- ^ @JSON@, JSON License - | LAL_1_2 -- ^ @LAL-1.2@, Licence Art Libre 1.2 - | LAL_1_3 -- ^ @LAL-1.3@, Licence Art Libre 1.3 - | Latex2e -- ^ @Latex2e@, Latex2e License - | Leptonica -- ^ @Leptonica@, Leptonica License - | LGPL_2_0_only -- ^ @LGPL-2.0-only@, GNU Library General Public License v2 only - | LGPL_2_0_or_later -- ^ @LGPL-2.0-or-later@, GNU Library General Public License v2 or later - | LGPL_2_1_only -- ^ @LGPL-2.1-only@, GNU Lesser General Public License v2.1 only - | LGPL_2_1_or_later -- ^ @LGPL-2.1-or-later@, GNU Lesser General Public License v2.1 or later - | LGPL_3_0_only -- ^ @LGPL-3.0-only@, GNU Lesser General Public License v3.0 only - | LGPL_3_0_or_later -- ^ @LGPL-3.0-or-later@, GNU Lesser General Public License v3.0 or later - | LGPLLR -- ^ @LGPLLR@, Lesser General Public License For Linguistic Resources - | Libpng_2_0 -- ^ @libpng-2.0@, PNG Reference Library version 2, SPDX License List 3.6, SPDX License List 3.9 - | Libpng -- ^ @Libpng@, libpng License - | Libselinux_1_0 -- ^ @libselinux-1.0@, libselinux public domain notice, SPDX License List 3.9 - | Libtiff -- ^ @libtiff@, libtiff License - | LiLiQ_P_1_1 -- ^ @LiLiQ-P-1.1@, Licence Libre du Québec – Permissive version 1.1 - | LiLiQ_R_1_1 -- ^ @LiLiQ-R-1.1@, Licence Libre du Québec – Réciprocité version 1.1 - | LiLiQ_Rplus_1_1 -- ^ @LiLiQ-Rplus-1.1@, Licence Libre du Québec – Réciprocité forte version 1.1 - | Linux_OpenIB -- ^ @Linux-OpenIB@, Linux Kernel Variant of OpenIB.org license, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9 - | LPL_1_02 -- ^ @LPL-1.02@, Lucent Public License v1.02 - | LPL_1_0 -- ^ @LPL-1.0@, Lucent Public License Version 1.0 - | LPPL_1_0 -- ^ @LPPL-1.0@, LaTeX Project Public License v1.0 - | LPPL_1_1 -- ^ @LPPL-1.1@, LaTeX Project Public License v1.1 - | LPPL_1_2 -- ^ @LPPL-1.2@, LaTeX Project Public License v1.2 - | LPPL_1_3a -- ^ @LPPL-1.3a@, LaTeX Project Public License v1.3a - | LPPL_1_3c -- ^ @LPPL-1.3c@, LaTeX Project Public License v1.3c - | MakeIndex -- ^ @MakeIndex@, MakeIndex License - | MirOS -- ^ @MirOS@, The MirOS Licence - | MIT_0 -- ^ @MIT-0@, MIT No Attribution, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9 - | MIT_advertising -- ^ @MIT-advertising@, Enlightenment License (e16) - | MIT_CMU -- ^ @MIT-CMU@, CMU License - | MIT_enna -- ^ @MIT-enna@, enna License - | MIT_feh -- ^ @MIT-feh@, feh License - | MITNFA -- ^ @MITNFA@, MIT +no-false-attribs license - | MIT -- ^ @MIT@, MIT License - | Motosoto -- ^ @Motosoto@, Motosoto License - | Mpich2 -- ^ @mpich2@, mpich2 License - | MPL_1_0 -- ^ @MPL-1.0@, Mozilla Public License 1.0 - | MPL_1_1 -- ^ @MPL-1.1@, Mozilla Public License 1.1 - | MPL_2_0_no_copyleft_exception -- ^ @MPL-2.0-no-copyleft-exception@, Mozilla Public License 2.0 (no copyleft exception) - | MPL_2_0 -- ^ @MPL-2.0@, Mozilla Public License 2.0 - | MS_PL -- ^ @MS-PL@, Microsoft Public License - | MS_RL -- ^ @MS-RL@, Microsoft Reciprocal License - | MTLL -- ^ @MTLL@, Matrix Template Library License - | MulanPSL_1_0 -- ^ @MulanPSL-1.0@, Mulan Permissive Software License, Version 1, SPDX License List 3.9 - | MulanPSL_2_0 -- ^ @MulanPSL-2.0@, Mulan Permissive Software License, Version 2, SPDX License List 3.9 - | Multics -- ^ @Multics@, Multics License - | Mup -- ^ @Mup@, Mup License - | NASA_1_3 -- ^ @NASA-1.3@, NASA Open Source Agreement 1.3 - | Naumen -- ^ @Naumen@, Naumen Public License - | NBPL_1_0 -- ^ @NBPL-1.0@, Net Boolean Public License v1 - | NCGL_UK_2_0 -- ^ @NCGL-UK-2.0@, Non-Commercial Government Licence, SPDX License List 3.9 - | NCSA -- ^ @NCSA@, University of Illinois/NCSA Open Source License - | Net_SNMP -- ^ @Net-SNMP@, Net-SNMP License - | NetCDF -- ^ @NetCDF@, NetCDF license - | Newsletr -- ^ @Newsletr@, Newsletr License - | NGPL -- ^ @NGPL@, Nethack General Public License - | NLOD_1_0 -- ^ @NLOD-1.0@, Norwegian Licence for Open Government Data - | NLPL -- ^ @NLPL@, No Limit Public License - | Nokia -- ^ @Nokia@, Nokia Open Source License - | NOSL -- ^ @NOSL@, Netizen Open Source License - | Noweb -- ^ @Noweb@, Noweb License - | NPL_1_0 -- ^ @NPL-1.0@, Netscape Public License v1.0 - | NPL_1_1 -- ^ @NPL-1.1@, Netscape Public License v1.1 - | NPOSL_3_0 -- ^ @NPOSL-3.0@, Non-Profit Open Software License 3.0 - | NRL -- ^ @NRL@, NRL License - | NTP_0 -- ^ @NTP-0@, NTP No Attribution, SPDX License List 3.9 - | NTP -- ^ @NTP@, NTP License - | O_UDA_1_0 -- ^ @O-UDA-1.0@, Open Use of Data Agreement v1.0, SPDX License List 3.9 - | OCCT_PL -- ^ @OCCT-PL@, Open CASCADE Technology Public License - | OCLC_2_0 -- ^ @OCLC-2.0@, OCLC Research Public License 2.0 - | ODbL_1_0 -- ^ @ODbL-1.0@, ODC Open Database License v1.0 - | ODC_By_1_0 -- ^ @ODC-By-1.0@, Open Data Commons Attribution License v1.0, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9 - | OFL_1_0_no_RFN -- ^ @OFL-1.0-no-RFN@, SIL Open Font License 1.0 with no Reserved Font Name, SPDX License List 3.9 - | OFL_1_0_RFN -- ^ @OFL-1.0-RFN@, SIL Open Font License 1.0 with Reserved Font Name, SPDX License List 3.9 - | OFL_1_0 -- ^ @OFL-1.0@, SIL Open Font License 1.0 - | OFL_1_1_no_RFN -- ^ @OFL-1.1-no-RFN@, SIL Open Font License 1.1 with no Reserved Font Name, SPDX License List 3.9 - | OFL_1_1_RFN -- ^ @OFL-1.1-RFN@, SIL Open Font License 1.1 with Reserved Font Name, SPDX License List 3.9 - | OFL_1_1 -- ^ @OFL-1.1@, SIL Open Font License 1.1 - | OGC_1_0 -- ^ @OGC-1.0@, OGC Software License, Version 1.0, SPDX License List 3.9 - | OGL_Canada_2_0 -- ^ @OGL-Canada-2.0@, Open Government Licence - Canada, SPDX License List 3.9 - | OGL_UK_1_0 -- ^ @OGL-UK-1.0@, Open Government Licence v1.0, SPDX License List 3.6, SPDX License List 3.9 - | OGL_UK_2_0 -- ^ @OGL-UK-2.0@, Open Government Licence v2.0, SPDX License List 3.6, SPDX License List 3.9 - | OGL_UK_3_0 -- ^ @OGL-UK-3.0@, Open Government Licence v3.0, SPDX License List 3.6, SPDX License List 3.9 - | OGTSL -- ^ @OGTSL@, Open Group Test Suite License - | OLDAP_1_1 -- ^ @OLDAP-1.1@, Open LDAP Public License v1.1 - | OLDAP_1_2 -- ^ @OLDAP-1.2@, Open LDAP Public License v1.2 - | OLDAP_1_3 -- ^ @OLDAP-1.3@, Open LDAP Public License v1.3 - | OLDAP_1_4 -- ^ @OLDAP-1.4@, Open LDAP Public License v1.4 - | OLDAP_2_0_1 -- ^ @OLDAP-2.0.1@, Open LDAP Public License v2.0.1 - | OLDAP_2_0 -- ^ @OLDAP-2.0@, Open LDAP Public License v2.0 (or possibly 2.0A and 2.0B) - | OLDAP_2_1 -- ^ @OLDAP-2.1@, Open LDAP Public License v2.1 - | OLDAP_2_2_1 -- ^ @OLDAP-2.2.1@, Open LDAP Public License v2.2.1 - | OLDAP_2_2_2 -- ^ @OLDAP-2.2.2@, Open LDAP Public License 2.2.2 - | OLDAP_2_2 -- ^ @OLDAP-2.2@, Open LDAP Public License v2.2 - | OLDAP_2_3 -- ^ @OLDAP-2.3@, Open LDAP Public License v2.3 - | OLDAP_2_4 -- ^ @OLDAP-2.4@, Open LDAP Public License v2.4 - | OLDAP_2_5 -- ^ @OLDAP-2.5@, Open LDAP Public License v2.5 - | OLDAP_2_6 -- ^ @OLDAP-2.6@, Open LDAP Public License v2.6 - | OLDAP_2_7 -- ^ @OLDAP-2.7@, Open LDAP Public License v2.7 - | OLDAP_2_8 -- ^ @OLDAP-2.8@, Open LDAP Public License v2.8 - | OML -- ^ @OML@, Open Market License - | OpenSSL -- ^ @OpenSSL@, OpenSSL License - | OPL_1_0 -- ^ @OPL-1.0@, Open Public License v1.0 - | OSET_PL_2_1 -- ^ @OSET-PL-2.1@, OSET Public License version 2.1 - | OSL_1_0 -- ^ @OSL-1.0@, Open Software License 1.0 - | OSL_1_1 -- ^ @OSL-1.1@, Open Software License 1.1 - | OSL_2_0 -- ^ @OSL-2.0@, Open Software License 2.0 - | OSL_2_1 -- ^ @OSL-2.1@, Open Software License 2.1 - | OSL_3_0 -- ^ @OSL-3.0@, Open Software License 3.0 - | Parity_6_0_0 -- ^ @Parity-6.0.0@, The Parity Public License 6.0.0, SPDX License List 3.6, SPDX License List 3.9 - | Parity_7_0_0 -- ^ @Parity-7.0.0@, The Parity Public License 7.0.0, SPDX License List 3.9 - | PDDL_1_0 -- ^ @PDDL-1.0@, ODC Public Domain Dedication & License 1.0 - | PHP_3_01 -- ^ @PHP-3.01@, PHP License v3.01 - | PHP_3_0 -- ^ @PHP-3.0@, PHP License v3.0 - | Plexus -- ^ @Plexus@, Plexus Classworlds License - | PolyForm_Noncommercial_1_0_0 -- ^ @PolyForm-Noncommercial-1.0.0@, PolyForm Noncommercial License 1.0.0, SPDX License List 3.9 - | PolyForm_Small_Business_1_0_0 -- ^ @PolyForm-Small-Business-1.0.0@, PolyForm Small Business License 1.0.0, SPDX License List 3.9 - | PostgreSQL -- ^ @PostgreSQL@, PostgreSQL License - | PSF_2_0 -- ^ @PSF-2.0@, Python Software Foundation License 2.0, SPDX License List 3.9 - | Psfrag -- ^ @psfrag@, psfrag License - | Psutils -- ^ @psutils@, psutils License - | Python_2_0 -- ^ @Python-2.0@, Python License 2.0 - | Qhull -- ^ @Qhull@, Qhull License - | QPL_1_0 -- ^ @QPL-1.0@, Q Public License 1.0 - | Rdisc -- ^ @Rdisc@, Rdisc License - | RHeCos_1_1 -- ^ @RHeCos-1.1@, Red Hat eCos Public License v1.1 - | RPL_1_1 -- ^ @RPL-1.1@, Reciprocal Public License 1.1 - | RPL_1_5 -- ^ @RPL-1.5@, Reciprocal Public License 1.5 - | RPSL_1_0 -- ^ @RPSL-1.0@, RealNetworks Public Source License v1.0 - | RSA_MD -- ^ @RSA-MD@, RSA Message-Digest License - | RSCPL -- ^ @RSCPL@, Ricoh Source Code Public License - | Ruby -- ^ @Ruby@, Ruby License - | SAX_PD -- ^ @SAX-PD@, Sax Public Domain Notice - | Saxpath -- ^ @Saxpath@, Saxpath License - | SCEA -- ^ @SCEA@, SCEA Shared Source License - | Sendmail_8_23 -- ^ @Sendmail-8.23@, Sendmail License 8.23, SPDX License List 3.6, SPDX License List 3.9 - | Sendmail -- ^ @Sendmail@, Sendmail License - | SGI_B_1_0 -- ^ @SGI-B-1.0@, SGI Free Software License B v1.0 - | SGI_B_1_1 -- ^ @SGI-B-1.1@, SGI Free Software License B v1.1 - | SGI_B_2_0 -- ^ @SGI-B-2.0@, SGI Free Software License B v2.0 - | SHL_0_51 -- ^ @SHL-0.51@, Solderpad Hardware License, Version 0.51, SPDX License List 3.6, SPDX License List 3.9 - | SHL_0_5 -- ^ @SHL-0.5@, Solderpad Hardware License v0.5, SPDX License List 3.6, SPDX License List 3.9 - | SimPL_2_0 -- ^ @SimPL-2.0@, Simple Public License 2.0 - | SISSL_1_2 -- ^ @SISSL-1.2@, Sun Industry Standards Source License v1.2 - | SISSL -- ^ @SISSL@, Sun Industry Standards Source License v1.1 - | Sleepycat -- ^ @Sleepycat@, Sleepycat License - | SMLNJ -- ^ @SMLNJ@, Standard ML of New Jersey License - | SMPPL -- ^ @SMPPL@, Secure Messaging Protocol Public License - | SNIA -- ^ @SNIA@, SNIA Public License 1.1 - | Spencer_86 -- ^ @Spencer-86@, Spencer License 86 - | Spencer_94 -- ^ @Spencer-94@, Spencer License 94 - | Spencer_99 -- ^ @Spencer-99@, Spencer License 99 - | SPL_1_0 -- ^ @SPL-1.0@, Sun Public License v1.0 - | SSH_OpenSSH -- ^ @SSH-OpenSSH@, SSH OpenSSH license, SPDX License List 3.9 - | SSH_short -- ^ @SSH-short@, SSH short notice, SPDX License List 3.9 - | SSPL_1_0 -- ^ @SSPL-1.0@, Server Side Public License, v 1, SPDX License List 3.6, SPDX License List 3.9 - | SugarCRM_1_1_3 -- ^ @SugarCRM-1.1.3@, SugarCRM Public License v1.1.3 - | SWL -- ^ @SWL@, Scheme Widget Library (SWL) Software License Agreement - | TAPR_OHL_1_0 -- ^ @TAPR-OHL-1.0@, TAPR Open Hardware License v1.0, SPDX License List 3.6, SPDX License List 3.9 - | TCL -- ^ @TCL@, TCL/TK License - | TCP_wrappers -- ^ @TCP-wrappers@, TCP Wrappers License - | TMate -- ^ @TMate@, TMate Open Source License - | TORQUE_1_1 -- ^ @TORQUE-1.1@, TORQUE v2.5+ Software License v1.1 - | TOSL -- ^ @TOSL@, Trusster Open Source License - | TU_Berlin_1_0 -- ^ @TU-Berlin-1.0@, Technische Universitaet Berlin License 1.0, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9 - | TU_Berlin_2_0 -- ^ @TU-Berlin-2.0@, Technische Universitaet Berlin License 2.0, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9 - | UCL_1_0 -- ^ @UCL-1.0@, Upstream Compatibility License v1.0, SPDX License List 3.9 - | Unicode_DFS_2015 -- ^ @Unicode-DFS-2015@, Unicode License Agreement - Data Files and Software (2015) - | Unicode_DFS_2016 -- ^ @Unicode-DFS-2016@, Unicode License Agreement - Data Files and Software (2016) - | Unicode_TOU -- ^ @Unicode-TOU@, Unicode Terms of Use - | Unlicense -- ^ @Unlicense@, The Unlicense - | UPL_1_0 -- ^ @UPL-1.0@, Universal Permissive License v1.0 - | Vim -- ^ @Vim@, Vim License - | VOSTROM -- ^ @VOSTROM@, VOSTROM Public License for Open Source - | VSL_1_0 -- ^ @VSL-1.0@, Vovida Software License v1.0 - | W3C_19980720 -- ^ @W3C-19980720@, W3C Software Notice and License (1998-07-20) - | W3C_20150513 -- ^ @W3C-20150513@, W3C Software Notice and Document License (2015-05-13) - | W3C -- ^ @W3C@, W3C Software Notice and License (2002-12-31) - | Watcom_1_0 -- ^ @Watcom-1.0@, Sybase Open Watcom Public License 1.0 - | Wsuipa -- ^ @Wsuipa@, Wsuipa License - | WTFPL -- ^ @WTFPL@, Do What The F*ck You Want To Public License - | X11 -- ^ @X11@, X11 License - | Xerox -- ^ @Xerox@, Xerox License - | XFree86_1_1 -- ^ @XFree86-1.1@, XFree86 License 1.1 - | Xinetd -- ^ @xinetd@, xinetd License - | Xnet -- ^ @Xnet@, X.Net License - | Xpp -- ^ @xpp@, XPP License - | XSkat -- ^ @XSkat@, XSkat License - | YPL_1_0 -- ^ @YPL-1.0@, Yahoo! Public License v1.0 - | YPL_1_1 -- ^ @YPL-1.1@, Yahoo! Public License v1.1 - | Zed -- ^ @Zed@, Zed License - | Zend_2_0 -- ^ @Zend-2.0@, Zend License v2.0 - | Zimbra_1_3 -- ^ @Zimbra-1.3@, Zimbra Public License v1.3 - | Zimbra_1_4 -- ^ @Zimbra-1.4@, Zimbra Public License v1.4 - | Zlib_acknowledgement -- ^ @zlib-acknowledgement@, zlib/libpng License with Acknowledgement - | Zlib -- ^ @Zlib@, zlib License - | ZPL_1_1 -- ^ @ZPL-1.1@, Zope Public License 1.1 - | ZPL_2_0 -- ^ @ZPL-2.0@, Zope Public License 2.0 - | ZPL_2_1 -- ^ @ZPL-2.1@, Zope Public License 2.1 - deriving (Eq, Ord, Enum, Bounded, Show, Read, Typeable, Data, Generic) - -instance Binary LicenseId where - -- Word16 is encoded in big endianess - -- https://github.com/kolmodin/binary/blob/master/src/Data/Binary/Class.hs#L220-LL227 - put = Binary.putWord16be . fromIntegral . fromEnum - get = do - i <- Binary.getWord16be - if i > fromIntegral (fromEnum (maxBound :: LicenseId)) - then fail "Too large LicenseId tag" - else return (toEnum (fromIntegral i)) - --- note: remember to bump version each time the definition changes -instance Structured LicenseId where - structure p = set typeVersion 306 $ nominalStructure p - -instance Pretty LicenseId where - pretty = Disp.text . licenseId - --- | --- >>> eitherParsec "BSD-3-Clause" :: Either String LicenseId --- Right BSD_3_Clause --- --- >>> eitherParsec "BSD3" :: Either String LicenseId --- Left "...Unknown SPDX license identifier: 'BSD3' Do you mean BSD-3-Clause?" --- -instance Parsec LicenseId where - parsec = do - n <- some $ P.satisfy $ \c -> isAsciiAlphaNum c || c == '-' || c == '.' - v <- askCabalSpecVersion - maybe (fail $ "Unknown SPDX license identifier: '" ++ n ++ "' " ++ licenseIdMigrationMessage n) return $ - mkLicenseId (cabalSpecVersionToSPDXListVersion v) n - -instance NFData LicenseId where - rnf l = l `seq` () - --- | Help message for migrating from non-SPDX license identifiers. --- --- Old 'License' is almost SPDX, except for 'BSD2', 'BSD3'. This function --- suggests SPDX variant: --- --- >>> licenseIdMigrationMessage "BSD3" --- "Do you mean BSD-3-Clause?" --- --- Also 'OtherLicense', 'AllRightsReserved', and 'PublicDomain' aren't --- valid SPDX identifiers --- --- >>> traverse_ (print . licenseIdMigrationMessage) [ "OtherLicense", "AllRightsReserved", "PublicDomain" ] --- "SPDX license list contains plenty of licenses. See https://spdx.org/licenses/. Also they can be combined into complex expressions with AND and OR." --- "You can use NONE as a value of license field." --- "Public Domain is a complex matter. See https://wiki.spdx.org/view/Legal_Team/Decisions/Dealing_with_Public_Domain_within_SPDX_Files. Consider using a proper license." --- --- SPDX License list version 3.0 introduced "-only" and "-or-later" variants for GNU family of licenses. --- See --- >>> licenseIdMigrationMessage "GPL-2.0" --- "SPDX license list 3.0 deprecated suffixless variants of GNU family of licenses. Use GPL-2.0-only or GPL-2.0-or-later." --- --- For other common licenses their old license format coincides with the SPDX identifiers: --- --- >>> traverse eitherParsec ["GPL-2.0-only", "GPL-3.0-only", "LGPL-2.1-only", "MIT", "ISC", "MPL-2.0", "Apache-2.0"] :: Either String [LicenseId] --- Right [GPL_2_0_only,GPL_3_0_only,LGPL_2_1_only,MIT,ISC,MPL_2_0,Apache_2_0] --- -licenseIdMigrationMessage :: String -> String -licenseIdMigrationMessage = go where - go l | gnuVariant l = "SPDX license list 3.0 deprecated suffixless variants of GNU family of licenses. Use " ++ l ++ "-only or " ++ l ++ "-or-later." - go "BSD3" = "Do you mean BSD-3-Clause?" - go "BSD2" = "Do you mean BSD-2-Clause?" - go "AllRightsReserved" = "You can use NONE as a value of license field." - go "OtherLicense" = "SPDX license list contains plenty of licenses. See https://spdx.org/licenses/. Also they can be combined into complex expressions with AND and OR." - go "PublicDomain" = "Public Domain is a complex matter. See https://wiki.spdx.org/view/Legal_Team/Decisions/Dealing_with_Public_Domain_within_SPDX_Files. Consider using a proper license." - - -- otherwise, we don't know - go _ = "" - - gnuVariant = flip elem ["GPL-2.0", "GPL-3.0", "LGPL-2.1", "LGPL-3.0", "AGPL-3.0" ] - -------------------------------------------------------------------------------- --- License Data -------------------------------------------------------------------------------- - --- | License SPDX identifier, e.g. @"BSD-3-Clause"@. -licenseId :: LicenseId -> String -licenseId NullBSD = "0BSD" -licenseId AAL = "AAL" -licenseId Abstyles = "Abstyles" -licenseId Adobe_2006 = "Adobe-2006" -licenseId Adobe_Glyph = "Adobe-Glyph" -licenseId ADSL = "ADSL" -licenseId AFL_1_1 = "AFL-1.1" -licenseId AFL_1_2 = "AFL-1.2" -licenseId AFL_2_0 = "AFL-2.0" -licenseId AFL_2_1 = "AFL-2.1" -licenseId AFL_3_0 = "AFL-3.0" -licenseId Afmparse = "Afmparse" -licenseId AGPL_1_0 = "AGPL-1.0" -licenseId AGPL_1_0_only = "AGPL-1.0-only" -licenseId AGPL_1_0_or_later = "AGPL-1.0-or-later" -licenseId AGPL_3_0_only = "AGPL-3.0-only" -licenseId AGPL_3_0_or_later = "AGPL-3.0-or-later" -licenseId Aladdin = "Aladdin" -licenseId AMDPLPA = "AMDPLPA" -licenseId AML = "AML" -licenseId AMPAS = "AMPAS" -licenseId ANTLR_PD = "ANTLR-PD" -licenseId Apache_1_0 = "Apache-1.0" -licenseId Apache_1_1 = "Apache-1.1" -licenseId Apache_2_0 = "Apache-2.0" -licenseId APAFML = "APAFML" -licenseId APL_1_0 = "APL-1.0" -licenseId APSL_1_0 = "APSL-1.0" -licenseId APSL_1_1 = "APSL-1.1" -licenseId APSL_1_2 = "APSL-1.2" -licenseId APSL_2_0 = "APSL-2.0" -licenseId Artistic_1_0_cl8 = "Artistic-1.0-cl8" -licenseId Artistic_1_0_Perl = "Artistic-1.0-Perl" -licenseId Artistic_1_0 = "Artistic-1.0" -licenseId Artistic_2_0 = "Artistic-2.0" -licenseId Bahyph = "Bahyph" -licenseId Barr = "Barr" -licenseId Beerware = "Beerware" -licenseId BitTorrent_1_0 = "BitTorrent-1.0" -licenseId BitTorrent_1_1 = "BitTorrent-1.1" -licenseId Blessing = "blessing" -licenseId BlueOak_1_0_0 = "BlueOak-1.0.0" -licenseId Borceux = "Borceux" -licenseId BSD_1_Clause = "BSD-1-Clause" -licenseId BSD_2_Clause_FreeBSD = "BSD-2-Clause-FreeBSD" -licenseId BSD_2_Clause_NetBSD = "BSD-2-Clause-NetBSD" -licenseId BSD_2_Clause_Patent = "BSD-2-Clause-Patent" -licenseId BSD_2_Clause = "BSD-2-Clause" -licenseId BSD_3_Clause_Attribution = "BSD-3-Clause-Attribution" -licenseId BSD_3_Clause_Clear = "BSD-3-Clause-Clear" -licenseId BSD_3_Clause_LBNL = "BSD-3-Clause-LBNL" -licenseId BSD_3_Clause_No_Nuclear_License_2014 = "BSD-3-Clause-No-Nuclear-License-2014" -licenseId BSD_3_Clause_No_Nuclear_License = "BSD-3-Clause-No-Nuclear-License" -licenseId BSD_3_Clause_No_Nuclear_Warranty = "BSD-3-Clause-No-Nuclear-Warranty" -licenseId BSD_3_Clause_Open_MPI = "BSD-3-Clause-Open-MPI" -licenseId BSD_3_Clause = "BSD-3-Clause" -licenseId BSD_4_Clause_UC = "BSD-4-Clause-UC" -licenseId BSD_4_Clause = "BSD-4-Clause" -licenseId BSD_Protection = "BSD-Protection" -licenseId BSD_Source_Code = "BSD-Source-Code" -licenseId BSL_1_0 = "BSL-1.0" -licenseId Bzip2_1_0_5 = "bzip2-1.0.5" -licenseId Bzip2_1_0_6 = "bzip2-1.0.6" -licenseId CAL_1_0_Combined_Work_Exception = "CAL-1.0-Combined-Work-Exception" -licenseId CAL_1_0 = "CAL-1.0" -licenseId Caldera = "Caldera" -licenseId CATOSL_1_1 = "CATOSL-1.1" -licenseId CC_BY_1_0 = "CC-BY-1.0" -licenseId CC_BY_2_0 = "CC-BY-2.0" -licenseId CC_BY_2_5 = "CC-BY-2.5" -licenseId CC_BY_3_0 = "CC-BY-3.0" -licenseId CC_BY_4_0 = "CC-BY-4.0" -licenseId CC_BY_NC_1_0 = "CC-BY-NC-1.0" -licenseId CC_BY_NC_2_0 = "CC-BY-NC-2.0" -licenseId CC_BY_NC_2_5 = "CC-BY-NC-2.5" -licenseId CC_BY_NC_3_0 = "CC-BY-NC-3.0" -licenseId CC_BY_NC_4_0 = "CC-BY-NC-4.0" -licenseId CC_BY_NC_ND_1_0 = "CC-BY-NC-ND-1.0" -licenseId CC_BY_NC_ND_2_0 = "CC-BY-NC-ND-2.0" -licenseId CC_BY_NC_ND_2_5 = "CC-BY-NC-ND-2.5" -licenseId CC_BY_NC_ND_3_0 = "CC-BY-NC-ND-3.0" -licenseId CC_BY_NC_ND_4_0 = "CC-BY-NC-ND-4.0" -licenseId CC_BY_NC_SA_1_0 = "CC-BY-NC-SA-1.0" -licenseId CC_BY_NC_SA_2_0 = "CC-BY-NC-SA-2.0" -licenseId CC_BY_NC_SA_2_5 = "CC-BY-NC-SA-2.5" -licenseId CC_BY_NC_SA_3_0 = "CC-BY-NC-SA-3.0" -licenseId CC_BY_NC_SA_4_0 = "CC-BY-NC-SA-4.0" -licenseId CC_BY_ND_1_0 = "CC-BY-ND-1.0" -licenseId CC_BY_ND_2_0 = "CC-BY-ND-2.0" -licenseId CC_BY_ND_2_5 = "CC-BY-ND-2.5" -licenseId CC_BY_ND_3_0 = "CC-BY-ND-3.0" -licenseId CC_BY_ND_4_0 = "CC-BY-ND-4.0" -licenseId CC_BY_SA_1_0 = "CC-BY-SA-1.0" -licenseId CC_BY_SA_2_0 = "CC-BY-SA-2.0" -licenseId CC_BY_SA_2_5 = "CC-BY-SA-2.5" -licenseId CC_BY_SA_3_0 = "CC-BY-SA-3.0" -licenseId CC_BY_SA_4_0 = "CC-BY-SA-4.0" -licenseId CC_PDDC = "CC-PDDC" -licenseId CC0_1_0 = "CC0-1.0" -licenseId CDDL_1_0 = "CDDL-1.0" -licenseId CDDL_1_1 = "CDDL-1.1" -licenseId CDLA_Permissive_1_0 = "CDLA-Permissive-1.0" -licenseId CDLA_Sharing_1_0 = "CDLA-Sharing-1.0" -licenseId CECILL_1_0 = "CECILL-1.0" -licenseId CECILL_1_1 = "CECILL-1.1" -licenseId CECILL_2_0 = "CECILL-2.0" -licenseId CECILL_2_1 = "CECILL-2.1" -licenseId CECILL_B = "CECILL-B" -licenseId CECILL_C = "CECILL-C" -licenseId CERN_OHL_1_1 = "CERN-OHL-1.1" -licenseId CERN_OHL_1_2 = "CERN-OHL-1.2" -licenseId CERN_OHL_P_2_0 = "CERN-OHL-P-2.0" -licenseId CERN_OHL_S_2_0 = "CERN-OHL-S-2.0" -licenseId CERN_OHL_W_2_0 = "CERN-OHL-W-2.0" -licenseId ClArtistic = "ClArtistic" -licenseId CNRI_Jython = "CNRI-Jython" -licenseId CNRI_Python_GPL_Compatible = "CNRI-Python-GPL-Compatible" -licenseId CNRI_Python = "CNRI-Python" -licenseId Condor_1_1 = "Condor-1.1" -licenseId Copyleft_next_0_3_0 = "copyleft-next-0.3.0" -licenseId Copyleft_next_0_3_1 = "copyleft-next-0.3.1" -licenseId CPAL_1_0 = "CPAL-1.0" -licenseId CPL_1_0 = "CPL-1.0" -licenseId CPOL_1_02 = "CPOL-1.02" -licenseId Crossword = "Crossword" -licenseId CrystalStacker = "CrystalStacker" -licenseId CUA_OPL_1_0 = "CUA-OPL-1.0" -licenseId Cube = "Cube" -licenseId Curl = "curl" -licenseId D_FSL_1_0 = "D-FSL-1.0" -licenseId Diffmark = "diffmark" -licenseId DOC = "DOC" -licenseId Dotseqn = "Dotseqn" -licenseId DSDP = "DSDP" -licenseId Dvipdfm = "dvipdfm" -licenseId ECL_1_0 = "ECL-1.0" -licenseId ECL_2_0 = "ECL-2.0" -licenseId EFL_1_0 = "EFL-1.0" -licenseId EFL_2_0 = "EFL-2.0" -licenseId EGenix = "eGenix" -licenseId Entessa = "Entessa" -licenseId EPL_1_0 = "EPL-1.0" -licenseId EPL_2_0 = "EPL-2.0" -licenseId ErlPL_1_1 = "ErlPL-1.1" -licenseId Etalab_2_0 = "etalab-2.0" -licenseId EUDatagrid = "EUDatagrid" -licenseId EUPL_1_0 = "EUPL-1.0" -licenseId EUPL_1_1 = "EUPL-1.1" -licenseId EUPL_1_2 = "EUPL-1.2" -licenseId Eurosym = "Eurosym" -licenseId Fair = "Fair" -licenseId Frameworx_1_0 = "Frameworx-1.0" -licenseId FreeImage = "FreeImage" -licenseId FSFAP = "FSFAP" -licenseId FSFULLR = "FSFULLR" -licenseId FSFUL = "FSFUL" -licenseId FTL = "FTL" -licenseId GFDL_1_1_only = "GFDL-1.1-only" -licenseId GFDL_1_1_or_later = "GFDL-1.1-or-later" -licenseId GFDL_1_2_only = "GFDL-1.2-only" -licenseId GFDL_1_2_or_later = "GFDL-1.2-or-later" -licenseId GFDL_1_3_only = "GFDL-1.3-only" -licenseId GFDL_1_3_or_later = "GFDL-1.3-or-later" -licenseId Giftware = "Giftware" -licenseId GL2PS = "GL2PS" -licenseId Glide = "Glide" -licenseId Glulxe = "Glulxe" -licenseId Gnuplot = "gnuplot" -licenseId GPL_1_0_only = "GPL-1.0-only" -licenseId GPL_1_0_or_later = "GPL-1.0-or-later" -licenseId GPL_2_0_only = "GPL-2.0-only" -licenseId GPL_2_0_or_later = "GPL-2.0-or-later" -licenseId GPL_3_0_only = "GPL-3.0-only" -licenseId GPL_3_0_or_later = "GPL-3.0-or-later" -licenseId GSOAP_1_3b = "gSOAP-1.3b" -licenseId HaskellReport = "HaskellReport" -licenseId Hippocratic_2_1 = "Hippocratic-2.1" -licenseId HPND_sell_variant = "HPND-sell-variant" -licenseId HPND = "HPND" -licenseId IBM_pibs = "IBM-pibs" -licenseId ICU = "ICU" -licenseId IJG = "IJG" -licenseId ImageMagick = "ImageMagick" -licenseId IMatix = "iMatix" -licenseId Imlib2 = "Imlib2" -licenseId Info_ZIP = "Info-ZIP" -licenseId Intel_ACPI = "Intel-ACPI" -licenseId Intel = "Intel" -licenseId Interbase_1_0 = "Interbase-1.0" -licenseId IPA = "IPA" -licenseId IPL_1_0 = "IPL-1.0" -licenseId ISC = "ISC" -licenseId JasPer_2_0 = "JasPer-2.0" -licenseId JPNIC = "JPNIC" -licenseId JSON = "JSON" -licenseId LAL_1_2 = "LAL-1.2" -licenseId LAL_1_3 = "LAL-1.3" -licenseId Latex2e = "Latex2e" -licenseId Leptonica = "Leptonica" -licenseId LGPL_2_0_only = "LGPL-2.0-only" -licenseId LGPL_2_0_or_later = "LGPL-2.0-or-later" -licenseId LGPL_2_1_only = "LGPL-2.1-only" -licenseId LGPL_2_1_or_later = "LGPL-2.1-or-later" -licenseId LGPL_3_0_only = "LGPL-3.0-only" -licenseId LGPL_3_0_or_later = "LGPL-3.0-or-later" -licenseId LGPLLR = "LGPLLR" -licenseId Libpng_2_0 = "libpng-2.0" -licenseId Libpng = "Libpng" -licenseId Libselinux_1_0 = "libselinux-1.0" -licenseId Libtiff = "libtiff" -licenseId LiLiQ_P_1_1 = "LiLiQ-P-1.1" -licenseId LiLiQ_R_1_1 = "LiLiQ-R-1.1" -licenseId LiLiQ_Rplus_1_1 = "LiLiQ-Rplus-1.1" -licenseId Linux_OpenIB = "Linux-OpenIB" -licenseId LPL_1_02 = "LPL-1.02" -licenseId LPL_1_0 = "LPL-1.0" -licenseId LPPL_1_0 = "LPPL-1.0" -licenseId LPPL_1_1 = "LPPL-1.1" -licenseId LPPL_1_2 = "LPPL-1.2" -licenseId LPPL_1_3a = "LPPL-1.3a" -licenseId LPPL_1_3c = "LPPL-1.3c" -licenseId MakeIndex = "MakeIndex" -licenseId MirOS = "MirOS" -licenseId MIT_0 = "MIT-0" -licenseId MIT_advertising = "MIT-advertising" -licenseId MIT_CMU = "MIT-CMU" -licenseId MIT_enna = "MIT-enna" -licenseId MIT_feh = "MIT-feh" -licenseId MITNFA = "MITNFA" -licenseId MIT = "MIT" -licenseId Motosoto = "Motosoto" -licenseId Mpich2 = "mpich2" -licenseId MPL_1_0 = "MPL-1.0" -licenseId MPL_1_1 = "MPL-1.1" -licenseId MPL_2_0_no_copyleft_exception = "MPL-2.0-no-copyleft-exception" -licenseId MPL_2_0 = "MPL-2.0" -licenseId MS_PL = "MS-PL" -licenseId MS_RL = "MS-RL" -licenseId MTLL = "MTLL" -licenseId MulanPSL_1_0 = "MulanPSL-1.0" -licenseId MulanPSL_2_0 = "MulanPSL-2.0" -licenseId Multics = "Multics" -licenseId Mup = "Mup" -licenseId NASA_1_3 = "NASA-1.3" -licenseId Naumen = "Naumen" -licenseId NBPL_1_0 = "NBPL-1.0" -licenseId NCGL_UK_2_0 = "NCGL-UK-2.0" -licenseId NCSA = "NCSA" -licenseId Net_SNMP = "Net-SNMP" -licenseId NetCDF = "NetCDF" -licenseId Newsletr = "Newsletr" -licenseId NGPL = "NGPL" -licenseId NLOD_1_0 = "NLOD-1.0" -licenseId NLPL = "NLPL" -licenseId Nokia = "Nokia" -licenseId NOSL = "NOSL" -licenseId Noweb = "Noweb" -licenseId NPL_1_0 = "NPL-1.0" -licenseId NPL_1_1 = "NPL-1.1" -licenseId NPOSL_3_0 = "NPOSL-3.0" -licenseId NRL = "NRL" -licenseId NTP_0 = "NTP-0" -licenseId NTP = "NTP" -licenseId O_UDA_1_0 = "O-UDA-1.0" -licenseId OCCT_PL = "OCCT-PL" -licenseId OCLC_2_0 = "OCLC-2.0" -licenseId ODbL_1_0 = "ODbL-1.0" -licenseId ODC_By_1_0 = "ODC-By-1.0" -licenseId OFL_1_0_no_RFN = "OFL-1.0-no-RFN" -licenseId OFL_1_0_RFN = "OFL-1.0-RFN" -licenseId OFL_1_0 = "OFL-1.0" -licenseId OFL_1_1_no_RFN = "OFL-1.1-no-RFN" -licenseId OFL_1_1_RFN = "OFL-1.1-RFN" -licenseId OFL_1_1 = "OFL-1.1" -licenseId OGC_1_0 = "OGC-1.0" -licenseId OGL_Canada_2_0 = "OGL-Canada-2.0" -licenseId OGL_UK_1_0 = "OGL-UK-1.0" -licenseId OGL_UK_2_0 = "OGL-UK-2.0" -licenseId OGL_UK_3_0 = "OGL-UK-3.0" -licenseId OGTSL = "OGTSL" -licenseId OLDAP_1_1 = "OLDAP-1.1" -licenseId OLDAP_1_2 = "OLDAP-1.2" -licenseId OLDAP_1_3 = "OLDAP-1.3" -licenseId OLDAP_1_4 = "OLDAP-1.4" -licenseId OLDAP_2_0_1 = "OLDAP-2.0.1" -licenseId OLDAP_2_0 = "OLDAP-2.0" -licenseId OLDAP_2_1 = "OLDAP-2.1" -licenseId OLDAP_2_2_1 = "OLDAP-2.2.1" -licenseId OLDAP_2_2_2 = "OLDAP-2.2.2" -licenseId OLDAP_2_2 = "OLDAP-2.2" -licenseId OLDAP_2_3 = "OLDAP-2.3" -licenseId OLDAP_2_4 = "OLDAP-2.4" -licenseId OLDAP_2_5 = "OLDAP-2.5" -licenseId OLDAP_2_6 = "OLDAP-2.6" -licenseId OLDAP_2_7 = "OLDAP-2.7" -licenseId OLDAP_2_8 = "OLDAP-2.8" -licenseId OML = "OML" -licenseId OpenSSL = "OpenSSL" -licenseId OPL_1_0 = "OPL-1.0" -licenseId OSET_PL_2_1 = "OSET-PL-2.1" -licenseId OSL_1_0 = "OSL-1.0" -licenseId OSL_1_1 = "OSL-1.1" -licenseId OSL_2_0 = "OSL-2.0" -licenseId OSL_2_1 = "OSL-2.1" -licenseId OSL_3_0 = "OSL-3.0" -licenseId Parity_6_0_0 = "Parity-6.0.0" -licenseId Parity_7_0_0 = "Parity-7.0.0" -licenseId PDDL_1_0 = "PDDL-1.0" -licenseId PHP_3_01 = "PHP-3.01" -licenseId PHP_3_0 = "PHP-3.0" -licenseId Plexus = "Plexus" -licenseId PolyForm_Noncommercial_1_0_0 = "PolyForm-Noncommercial-1.0.0" -licenseId PolyForm_Small_Business_1_0_0 = "PolyForm-Small-Business-1.0.0" -licenseId PostgreSQL = "PostgreSQL" -licenseId PSF_2_0 = "PSF-2.0" -licenseId Psfrag = "psfrag" -licenseId Psutils = "psutils" -licenseId Python_2_0 = "Python-2.0" -licenseId Qhull = "Qhull" -licenseId QPL_1_0 = "QPL-1.0" -licenseId Rdisc = "Rdisc" -licenseId RHeCos_1_1 = "RHeCos-1.1" -licenseId RPL_1_1 = "RPL-1.1" -licenseId RPL_1_5 = "RPL-1.5" -licenseId RPSL_1_0 = "RPSL-1.0" -licenseId RSA_MD = "RSA-MD" -licenseId RSCPL = "RSCPL" -licenseId Ruby = "Ruby" -licenseId SAX_PD = "SAX-PD" -licenseId Saxpath = "Saxpath" -licenseId SCEA = "SCEA" -licenseId Sendmail_8_23 = "Sendmail-8.23" -licenseId Sendmail = "Sendmail" -licenseId SGI_B_1_0 = "SGI-B-1.0" -licenseId SGI_B_1_1 = "SGI-B-1.1" -licenseId SGI_B_2_0 = "SGI-B-2.0" -licenseId SHL_0_51 = "SHL-0.51" -licenseId SHL_0_5 = "SHL-0.5" -licenseId SimPL_2_0 = "SimPL-2.0" -licenseId SISSL_1_2 = "SISSL-1.2" -licenseId SISSL = "SISSL" -licenseId Sleepycat = "Sleepycat" -licenseId SMLNJ = "SMLNJ" -licenseId SMPPL = "SMPPL" -licenseId SNIA = "SNIA" -licenseId Spencer_86 = "Spencer-86" -licenseId Spencer_94 = "Spencer-94" -licenseId Spencer_99 = "Spencer-99" -licenseId SPL_1_0 = "SPL-1.0" -licenseId SSH_OpenSSH = "SSH-OpenSSH" -licenseId SSH_short = "SSH-short" -licenseId SSPL_1_0 = "SSPL-1.0" -licenseId SugarCRM_1_1_3 = "SugarCRM-1.1.3" -licenseId SWL = "SWL" -licenseId TAPR_OHL_1_0 = "TAPR-OHL-1.0" -licenseId TCL = "TCL" -licenseId TCP_wrappers = "TCP-wrappers" -licenseId TMate = "TMate" -licenseId TORQUE_1_1 = "TORQUE-1.1" -licenseId TOSL = "TOSL" -licenseId TU_Berlin_1_0 = "TU-Berlin-1.0" -licenseId TU_Berlin_2_0 = "TU-Berlin-2.0" -licenseId UCL_1_0 = "UCL-1.0" -licenseId Unicode_DFS_2015 = "Unicode-DFS-2015" -licenseId Unicode_DFS_2016 = "Unicode-DFS-2016" -licenseId Unicode_TOU = "Unicode-TOU" -licenseId Unlicense = "Unlicense" -licenseId UPL_1_0 = "UPL-1.0" -licenseId Vim = "Vim" -licenseId VOSTROM = "VOSTROM" -licenseId VSL_1_0 = "VSL-1.0" -licenseId W3C_19980720 = "W3C-19980720" -licenseId W3C_20150513 = "W3C-20150513" -licenseId W3C = "W3C" -licenseId Watcom_1_0 = "Watcom-1.0" -licenseId Wsuipa = "Wsuipa" -licenseId WTFPL = "WTFPL" -licenseId X11 = "X11" -licenseId Xerox = "Xerox" -licenseId XFree86_1_1 = "XFree86-1.1" -licenseId Xinetd = "xinetd" -licenseId Xnet = "Xnet" -licenseId Xpp = "xpp" -licenseId XSkat = "XSkat" -licenseId YPL_1_0 = "YPL-1.0" -licenseId YPL_1_1 = "YPL-1.1" -licenseId Zed = "Zed" -licenseId Zend_2_0 = "Zend-2.0" -licenseId Zimbra_1_3 = "Zimbra-1.3" -licenseId Zimbra_1_4 = "Zimbra-1.4" -licenseId Zlib_acknowledgement = "zlib-acknowledgement" -licenseId Zlib = "Zlib" -licenseId ZPL_1_1 = "ZPL-1.1" -licenseId ZPL_2_0 = "ZPL-2.0" -licenseId ZPL_2_1 = "ZPL-2.1" - --- | License name, e.g. @"GNU General Public License v2.0 only"@ -licenseName :: LicenseId -> String -licenseName NullBSD = "BSD Zero Clause License" -licenseName AAL = "Attribution Assurance License" -licenseName Abstyles = "Abstyles License" -licenseName Adobe_2006 = "Adobe Systems Incorporated Source Code License Agreement" -licenseName Adobe_Glyph = "Adobe Glyph List License" -licenseName ADSL = "Amazon Digital Services License" -licenseName AFL_1_1 = "Academic Free License v1.1" -licenseName AFL_1_2 = "Academic Free License v1.2" -licenseName AFL_2_0 = "Academic Free License v2.0" -licenseName AFL_2_1 = "Academic Free License v2.1" -licenseName AFL_3_0 = "Academic Free License v3.0" -licenseName Afmparse = "Afmparse License" -licenseName AGPL_1_0 = "Affero General Public License v1.0" -licenseName AGPL_1_0_only = "Affero General Public License v1.0 only" -licenseName AGPL_1_0_or_later = "Affero General Public License v1.0 or later" -licenseName AGPL_3_0_only = "GNU Affero General Public License v3.0 only" -licenseName AGPL_3_0_or_later = "GNU Affero General Public License v3.0 or later" -licenseName Aladdin = "Aladdin Free Public License" -licenseName AMDPLPA = "AMD's plpa_map.c License" -licenseName AML = "Apple MIT License" -licenseName AMPAS = "Academy of Motion Picture Arts and Sciences BSD" -licenseName ANTLR_PD = "ANTLR Software Rights Notice" -licenseName Apache_1_0 = "Apache License 1.0" -licenseName Apache_1_1 = "Apache License 1.1" -licenseName Apache_2_0 = "Apache License 2.0" -licenseName APAFML = "Adobe Postscript AFM License" -licenseName APL_1_0 = "Adaptive Public License 1.0" -licenseName APSL_1_0 = "Apple Public Source License 1.0" -licenseName APSL_1_1 = "Apple Public Source License 1.1" -licenseName APSL_1_2 = "Apple Public Source License 1.2" -licenseName APSL_2_0 = "Apple Public Source License 2.0" -licenseName Artistic_1_0_cl8 = "Artistic License 1.0 w/clause 8" -licenseName Artistic_1_0_Perl = "Artistic License 1.0 (Perl)" -licenseName Artistic_1_0 = "Artistic License 1.0" -licenseName Artistic_2_0 = "Artistic License 2.0" -licenseName Bahyph = "Bahyph License" -licenseName Barr = "Barr License" -licenseName Beerware = "Beerware License" -licenseName BitTorrent_1_0 = "BitTorrent Open Source License v1.0" -licenseName BitTorrent_1_1 = "BitTorrent Open Source License v1.1" -licenseName Blessing = "SQLite Blessing" -licenseName BlueOak_1_0_0 = "Blue Oak Model License 1.0.0" -licenseName Borceux = "Borceux license" -licenseName BSD_1_Clause = "BSD 1-Clause License" -licenseName BSD_2_Clause_FreeBSD = "BSD 2-Clause FreeBSD License" -licenseName BSD_2_Clause_NetBSD = "BSD 2-Clause NetBSD License" -licenseName BSD_2_Clause_Patent = "BSD-2-Clause Plus Patent License" -licenseName BSD_2_Clause = "BSD 2-Clause \"Simplified\" License" -licenseName BSD_3_Clause_Attribution = "BSD with attribution" -licenseName BSD_3_Clause_Clear = "BSD 3-Clause Clear License" -licenseName BSD_3_Clause_LBNL = "Lawrence Berkeley National Labs BSD variant license" -licenseName BSD_3_Clause_No_Nuclear_License_2014 = "BSD 3-Clause No Nuclear License 2014" -licenseName BSD_3_Clause_No_Nuclear_License = "BSD 3-Clause No Nuclear License" -licenseName BSD_3_Clause_No_Nuclear_Warranty = "BSD 3-Clause No Nuclear Warranty" -licenseName BSD_3_Clause_Open_MPI = "BSD 3-Clause Open MPI variant" -licenseName BSD_3_Clause = "BSD 3-Clause \"New\" or \"Revised\" License" -licenseName BSD_4_Clause_UC = "BSD-4-Clause (University of California-Specific)" -licenseName BSD_4_Clause = "BSD 4-Clause \"Original\" or \"Old\" License" -licenseName BSD_Protection = "BSD Protection License" -licenseName BSD_Source_Code = "BSD Source Code Attribution" -licenseName BSL_1_0 = "Boost Software License 1.0" -licenseName Bzip2_1_0_5 = "bzip2 and libbzip2 License v1.0.5" -licenseName Bzip2_1_0_6 = "bzip2 and libbzip2 License v1.0.6" -licenseName CAL_1_0_Combined_Work_Exception = "Cryptographic Autonomy License 1.0 (Combined Work Exception)" -licenseName CAL_1_0 = "Cryptographic Autonomy License 1.0" -licenseName Caldera = "Caldera License" -licenseName CATOSL_1_1 = "Computer Associates Trusted Open Source License 1.1" -licenseName CC_BY_1_0 = "Creative Commons Attribution 1.0 Generic" -licenseName CC_BY_2_0 = "Creative Commons Attribution 2.0 Generic" -licenseName CC_BY_2_5 = "Creative Commons Attribution 2.5 Generic" -licenseName CC_BY_3_0 = "Creative Commons Attribution 3.0 Unported" -licenseName CC_BY_4_0 = "Creative Commons Attribution 4.0 International" -licenseName CC_BY_NC_1_0 = "Creative Commons Attribution Non Commercial 1.0 Generic" -licenseName CC_BY_NC_2_0 = "Creative Commons Attribution Non Commercial 2.0 Generic" -licenseName CC_BY_NC_2_5 = "Creative Commons Attribution Non Commercial 2.5 Generic" -licenseName CC_BY_NC_3_0 = "Creative Commons Attribution Non Commercial 3.0 Unported" -licenseName CC_BY_NC_4_0 = "Creative Commons Attribution Non Commercial 4.0 International" -licenseName CC_BY_NC_ND_1_0 = "Creative Commons Attribution Non Commercial No Derivatives 1.0 Generic" -licenseName CC_BY_NC_ND_2_0 = "Creative Commons Attribution Non Commercial No Derivatives 2.0 Generic" -licenseName CC_BY_NC_ND_2_5 = "Creative Commons Attribution Non Commercial No Derivatives 2.5 Generic" -licenseName CC_BY_NC_ND_3_0 = "Creative Commons Attribution Non Commercial No Derivatives 3.0 Unported" -licenseName CC_BY_NC_ND_4_0 = "Creative Commons Attribution Non Commercial No Derivatives 4.0 International" -licenseName CC_BY_NC_SA_1_0 = "Creative Commons Attribution Non Commercial Share Alike 1.0 Generic" -licenseName CC_BY_NC_SA_2_0 = "Creative Commons Attribution Non Commercial Share Alike 2.0 Generic" -licenseName CC_BY_NC_SA_2_5 = "Creative Commons Attribution Non Commercial Share Alike 2.5 Generic" -licenseName CC_BY_NC_SA_3_0 = "Creative Commons Attribution Non Commercial Share Alike 3.0 Unported" -licenseName CC_BY_NC_SA_4_0 = "Creative Commons Attribution Non Commercial Share Alike 4.0 International" -licenseName CC_BY_ND_1_0 = "Creative Commons Attribution No Derivatives 1.0 Generic" -licenseName CC_BY_ND_2_0 = "Creative Commons Attribution No Derivatives 2.0 Generic" -licenseName CC_BY_ND_2_5 = "Creative Commons Attribution No Derivatives 2.5 Generic" -licenseName CC_BY_ND_3_0 = "Creative Commons Attribution No Derivatives 3.0 Unported" -licenseName CC_BY_ND_4_0 = "Creative Commons Attribution No Derivatives 4.0 International" -licenseName CC_BY_SA_1_0 = "Creative Commons Attribution Share Alike 1.0 Generic" -licenseName CC_BY_SA_2_0 = "Creative Commons Attribution Share Alike 2.0 Generic" -licenseName CC_BY_SA_2_5 = "Creative Commons Attribution Share Alike 2.5 Generic" -licenseName CC_BY_SA_3_0 = "Creative Commons Attribution Share Alike 3.0 Unported" -licenseName CC_BY_SA_4_0 = "Creative Commons Attribution Share Alike 4.0 International" -licenseName CC_PDDC = "Creative Commons Public Domain Dedication and Certification" -licenseName CC0_1_0 = "Creative Commons Zero v1.0 Universal" -licenseName CDDL_1_0 = "Common Development and Distribution License 1.0" -licenseName CDDL_1_1 = "Common Development and Distribution License 1.1" -licenseName CDLA_Permissive_1_0 = "Community Data License Agreement Permissive 1.0" -licenseName CDLA_Sharing_1_0 = "Community Data License Agreement Sharing 1.0" -licenseName CECILL_1_0 = "CeCILL Free Software License Agreement v1.0" -licenseName CECILL_1_1 = "CeCILL Free Software License Agreement v1.1" -licenseName CECILL_2_0 = "CeCILL Free Software License Agreement v2.0" -licenseName CECILL_2_1 = "CeCILL Free Software License Agreement v2.1" -licenseName CECILL_B = "CeCILL-B Free Software License Agreement" -licenseName CECILL_C = "CeCILL-C Free Software License Agreement" -licenseName CERN_OHL_1_1 = "CERN Open Hardware Licence v1.1" -licenseName CERN_OHL_1_2 = "CERN Open Hardware Licence v1.2" -licenseName CERN_OHL_P_2_0 = "CERN Open Hardware Licence Version 2 - Permissive" -licenseName CERN_OHL_S_2_0 = "CERN Open Hardware Licence Version 2 - Strongly Reciprocal" -licenseName CERN_OHL_W_2_0 = "CERN Open Hardware Licence Version 2 - Weakly Reciprocal" -licenseName ClArtistic = "Clarified Artistic License" -licenseName CNRI_Jython = "CNRI Jython License" -licenseName CNRI_Python_GPL_Compatible = "CNRI Python Open Source GPL Compatible License Agreement" -licenseName CNRI_Python = "CNRI Python License" -licenseName Condor_1_1 = "Condor Public License v1.1" -licenseName Copyleft_next_0_3_0 = "copyleft-next 0.3.0" -licenseName Copyleft_next_0_3_1 = "copyleft-next 0.3.1" -licenseName CPAL_1_0 = "Common Public Attribution License 1.0" -licenseName CPL_1_0 = "Common Public License 1.0" -licenseName CPOL_1_02 = "Code Project Open License 1.02" -licenseName Crossword = "Crossword License" -licenseName CrystalStacker = "CrystalStacker License" -licenseName CUA_OPL_1_0 = "CUA Office Public License v1.0" -licenseName Cube = "Cube License" -licenseName Curl = "curl License" -licenseName D_FSL_1_0 = "Deutsche Freie Software Lizenz" -licenseName Diffmark = "diffmark license" -licenseName DOC = "DOC License" -licenseName Dotseqn = "Dotseqn License" -licenseName DSDP = "DSDP License" -licenseName Dvipdfm = "dvipdfm License" -licenseName ECL_1_0 = "Educational Community License v1.0" -licenseName ECL_2_0 = "Educational Community License v2.0" -licenseName EFL_1_0 = "Eiffel Forum License v1.0" -licenseName EFL_2_0 = "Eiffel Forum License v2.0" -licenseName EGenix = "eGenix.com Public License 1.1.0" -licenseName Entessa = "Entessa Public License v1.0" -licenseName EPL_1_0 = "Eclipse Public License 1.0" -licenseName EPL_2_0 = "Eclipse Public License 2.0" -licenseName ErlPL_1_1 = "Erlang Public License v1.1" -licenseName Etalab_2_0 = "Etalab Open License 2.0" -licenseName EUDatagrid = "EU DataGrid Software License" -licenseName EUPL_1_0 = "European Union Public License 1.0" -licenseName EUPL_1_1 = "European Union Public License 1.1" -licenseName EUPL_1_2 = "European Union Public License 1.2" -licenseName Eurosym = "Eurosym License" -licenseName Fair = "Fair License" -licenseName Frameworx_1_0 = "Frameworx Open License 1.0" -licenseName FreeImage = "FreeImage Public License v1.0" -licenseName FSFAP = "FSF All Permissive License" -licenseName FSFULLR = "FSF Unlimited License (with License Retention)" -licenseName FSFUL = "FSF Unlimited License" -licenseName FTL = "Freetype Project License" -licenseName GFDL_1_1_only = "GNU Free Documentation License v1.1 only" -licenseName GFDL_1_1_or_later = "GNU Free Documentation License v1.1 or later" -licenseName GFDL_1_2_only = "GNU Free Documentation License v1.2 only" -licenseName GFDL_1_2_or_later = "GNU Free Documentation License v1.2 or later" -licenseName GFDL_1_3_only = "GNU Free Documentation License v1.3 only" -licenseName GFDL_1_3_or_later = "GNU Free Documentation License v1.3 or later" -licenseName Giftware = "Giftware License" -licenseName GL2PS = "GL2PS License" -licenseName Glide = "3dfx Glide License" -licenseName Glulxe = "Glulxe License" -licenseName Gnuplot = "gnuplot License" -licenseName GPL_1_0_only = "GNU General Public License v1.0 only" -licenseName GPL_1_0_or_later = "GNU General Public License v1.0 or later" -licenseName GPL_2_0_only = "GNU General Public License v2.0 only" -licenseName GPL_2_0_or_later = "GNU General Public License v2.0 or later" -licenseName GPL_3_0_only = "GNU General Public License v3.0 only" -licenseName GPL_3_0_or_later = "GNU General Public License v3.0 or later" -licenseName GSOAP_1_3b = "gSOAP Public License v1.3b" -licenseName HaskellReport = "Haskell Language Report License" -licenseName Hippocratic_2_1 = "Hippocratic License 2.1" -licenseName HPND_sell_variant = "Historical Permission Notice and Disclaimer - sell variant" -licenseName HPND = "Historical Permission Notice and Disclaimer" -licenseName IBM_pibs = "IBM PowerPC Initialization and Boot Software" -licenseName ICU = "ICU License" -licenseName IJG = "Independent JPEG Group License" -licenseName ImageMagick = "ImageMagick License" -licenseName IMatix = "iMatix Standard Function Library Agreement" -licenseName Imlib2 = "Imlib2 License" -licenseName Info_ZIP = "Info-ZIP License" -licenseName Intel_ACPI = "Intel ACPI Software License Agreement" -licenseName Intel = "Intel Open Source License" -licenseName Interbase_1_0 = "Interbase Public License v1.0" -licenseName IPA = "IPA Font License" -licenseName IPL_1_0 = "IBM Public License v1.0" -licenseName ISC = "ISC License" -licenseName JasPer_2_0 = "JasPer License" -licenseName JPNIC = "Japan Network Information Center License" -licenseName JSON = "JSON License" -licenseName LAL_1_2 = "Licence Art Libre 1.2" -licenseName LAL_1_3 = "Licence Art Libre 1.3" -licenseName Latex2e = "Latex2e License" -licenseName Leptonica = "Leptonica License" -licenseName LGPL_2_0_only = "GNU Library General Public License v2 only" -licenseName LGPL_2_0_or_later = "GNU Library General Public License v2 or later" -licenseName LGPL_2_1_only = "GNU Lesser General Public License v2.1 only" -licenseName LGPL_2_1_or_later = "GNU Lesser General Public License v2.1 or later" -licenseName LGPL_3_0_only = "GNU Lesser General Public License v3.0 only" -licenseName LGPL_3_0_or_later = "GNU Lesser General Public License v3.0 or later" -licenseName LGPLLR = "Lesser General Public License For Linguistic Resources" -licenseName Libpng_2_0 = "PNG Reference Library version 2" -licenseName Libpng = "libpng License" -licenseName Libselinux_1_0 = "libselinux public domain notice" -licenseName Libtiff = "libtiff License" -licenseName LiLiQ_P_1_1 = "Licence Libre du Qu\233bec \8211 Permissive version 1.1" -licenseName LiLiQ_R_1_1 = "Licence Libre du Qu\233bec \8211 R\233ciprocit\233 version 1.1" -licenseName LiLiQ_Rplus_1_1 = "Licence Libre du Qu\233bec \8211 R\233ciprocit\233 forte version 1.1" -licenseName Linux_OpenIB = "Linux Kernel Variant of OpenIB.org license" -licenseName LPL_1_02 = "Lucent Public License v1.02" -licenseName LPL_1_0 = "Lucent Public License Version 1.0" -licenseName LPPL_1_0 = "LaTeX Project Public License v1.0" -licenseName LPPL_1_1 = "LaTeX Project Public License v1.1" -licenseName LPPL_1_2 = "LaTeX Project Public License v1.2" -licenseName LPPL_1_3a = "LaTeX Project Public License v1.3a" -licenseName LPPL_1_3c = "LaTeX Project Public License v1.3c" -licenseName MakeIndex = "MakeIndex License" -licenseName MirOS = "The MirOS Licence" -licenseName MIT_0 = "MIT No Attribution" -licenseName MIT_advertising = "Enlightenment License (e16)" -licenseName MIT_CMU = "CMU License" -licenseName MIT_enna = "enna License" -licenseName MIT_feh = "feh License" -licenseName MITNFA = "MIT +no-false-attribs license" -licenseName MIT = "MIT License" -licenseName Motosoto = "Motosoto License" -licenseName Mpich2 = "mpich2 License" -licenseName MPL_1_0 = "Mozilla Public License 1.0" -licenseName MPL_1_1 = "Mozilla Public License 1.1" -licenseName MPL_2_0_no_copyleft_exception = "Mozilla Public License 2.0 (no copyleft exception)" -licenseName MPL_2_0 = "Mozilla Public License 2.0" -licenseName MS_PL = "Microsoft Public License" -licenseName MS_RL = "Microsoft Reciprocal License" -licenseName MTLL = "Matrix Template Library License" -licenseName MulanPSL_1_0 = "Mulan Permissive Software License, Version 1" -licenseName MulanPSL_2_0 = "Mulan Permissive Software License, Version 2" -licenseName Multics = "Multics License" -licenseName Mup = "Mup License" -licenseName NASA_1_3 = "NASA Open Source Agreement 1.3" -licenseName Naumen = "Naumen Public License" -licenseName NBPL_1_0 = "Net Boolean Public License v1" -licenseName NCGL_UK_2_0 = "Non-Commercial Government Licence" -licenseName NCSA = "University of Illinois/NCSA Open Source License" -licenseName Net_SNMP = "Net-SNMP License" -licenseName NetCDF = "NetCDF license" -licenseName Newsletr = "Newsletr License" -licenseName NGPL = "Nethack General Public License" -licenseName NLOD_1_0 = "Norwegian Licence for Open Government Data" -licenseName NLPL = "No Limit Public License" -licenseName Nokia = "Nokia Open Source License" -licenseName NOSL = "Netizen Open Source License" -licenseName Noweb = "Noweb License" -licenseName NPL_1_0 = "Netscape Public License v1.0" -licenseName NPL_1_1 = "Netscape Public License v1.1" -licenseName NPOSL_3_0 = "Non-Profit Open Software License 3.0" -licenseName NRL = "NRL License" -licenseName NTP_0 = "NTP No Attribution" -licenseName NTP = "NTP License" -licenseName O_UDA_1_0 = "Open Use of Data Agreement v1.0" -licenseName OCCT_PL = "Open CASCADE Technology Public License" -licenseName OCLC_2_0 = "OCLC Research Public License 2.0" -licenseName ODbL_1_0 = "ODC Open Database License v1.0" -licenseName ODC_By_1_0 = "Open Data Commons Attribution License v1.0" -licenseName OFL_1_0_no_RFN = "SIL Open Font License 1.0 with no Reserved Font Name" -licenseName OFL_1_0_RFN = "SIL Open Font License 1.0 with Reserved Font Name" -licenseName OFL_1_0 = "SIL Open Font License 1.0" -licenseName OFL_1_1_no_RFN = "SIL Open Font License 1.1 with no Reserved Font Name" -licenseName OFL_1_1_RFN = "SIL Open Font License 1.1 with Reserved Font Name" -licenseName OFL_1_1 = "SIL Open Font License 1.1" -licenseName OGC_1_0 = "OGC Software License, Version 1.0" -licenseName OGL_Canada_2_0 = "Open Government Licence - Canada" -licenseName OGL_UK_1_0 = "Open Government Licence v1.0" -licenseName OGL_UK_2_0 = "Open Government Licence v2.0" -licenseName OGL_UK_3_0 = "Open Government Licence v3.0" -licenseName OGTSL = "Open Group Test Suite License" -licenseName OLDAP_1_1 = "Open LDAP Public License v1.1" -licenseName OLDAP_1_2 = "Open LDAP Public License v1.2" -licenseName OLDAP_1_3 = "Open LDAP Public License v1.3" -licenseName OLDAP_1_4 = "Open LDAP Public License v1.4" -licenseName OLDAP_2_0_1 = "Open LDAP Public License v2.0.1" -licenseName OLDAP_2_0 = "Open LDAP Public License v2.0 (or possibly 2.0A and 2.0B)" -licenseName OLDAP_2_1 = "Open LDAP Public License v2.1" -licenseName OLDAP_2_2_1 = "Open LDAP Public License v2.2.1" -licenseName OLDAP_2_2_2 = "Open LDAP Public License 2.2.2" -licenseName OLDAP_2_2 = "Open LDAP Public License v2.2" -licenseName OLDAP_2_3 = "Open LDAP Public License v2.3" -licenseName OLDAP_2_4 = "Open LDAP Public License v2.4" -licenseName OLDAP_2_5 = "Open LDAP Public License v2.5" -licenseName OLDAP_2_6 = "Open LDAP Public License v2.6" -licenseName OLDAP_2_7 = "Open LDAP Public License v2.7" -licenseName OLDAP_2_8 = "Open LDAP Public License v2.8" -licenseName OML = "Open Market License" -licenseName OpenSSL = "OpenSSL License" -licenseName OPL_1_0 = "Open Public License v1.0" -licenseName OSET_PL_2_1 = "OSET Public License version 2.1" -licenseName OSL_1_0 = "Open Software License 1.0" -licenseName OSL_1_1 = "Open Software License 1.1" -licenseName OSL_2_0 = "Open Software License 2.0" -licenseName OSL_2_1 = "Open Software License 2.1" -licenseName OSL_3_0 = "Open Software License 3.0" -licenseName Parity_6_0_0 = "The Parity Public License 6.0.0" -licenseName Parity_7_0_0 = "The Parity Public License 7.0.0" -licenseName PDDL_1_0 = "ODC Public Domain Dedication & License 1.0" -licenseName PHP_3_01 = "PHP License v3.01" -licenseName PHP_3_0 = "PHP License v3.0" -licenseName Plexus = "Plexus Classworlds License" -licenseName PolyForm_Noncommercial_1_0_0 = "PolyForm Noncommercial License 1.0.0" -licenseName PolyForm_Small_Business_1_0_0 = "PolyForm Small Business License 1.0.0" -licenseName PostgreSQL = "PostgreSQL License" -licenseName PSF_2_0 = "Python Software Foundation License 2.0" -licenseName Psfrag = "psfrag License" -licenseName Psutils = "psutils License" -licenseName Python_2_0 = "Python License 2.0" -licenseName Qhull = "Qhull License" -licenseName QPL_1_0 = "Q Public License 1.0" -licenseName Rdisc = "Rdisc License" -licenseName RHeCos_1_1 = "Red Hat eCos Public License v1.1" -licenseName RPL_1_1 = "Reciprocal Public License 1.1" -licenseName RPL_1_5 = "Reciprocal Public License 1.5" -licenseName RPSL_1_0 = "RealNetworks Public Source License v1.0" -licenseName RSA_MD = "RSA Message-Digest License " -licenseName RSCPL = "Ricoh Source Code Public License" -licenseName Ruby = "Ruby License" -licenseName SAX_PD = "Sax Public Domain Notice" -licenseName Saxpath = "Saxpath License" -licenseName SCEA = "SCEA Shared Source License" -licenseName Sendmail_8_23 = "Sendmail License 8.23" -licenseName Sendmail = "Sendmail License" -licenseName SGI_B_1_0 = "SGI Free Software License B v1.0" -licenseName SGI_B_1_1 = "SGI Free Software License B v1.1" -licenseName SGI_B_2_0 = "SGI Free Software License B v2.0" -licenseName SHL_0_51 = "Solderpad Hardware License, Version 0.51" -licenseName SHL_0_5 = "Solderpad Hardware License v0.5" -licenseName SimPL_2_0 = "Simple Public License 2.0" -licenseName SISSL_1_2 = "Sun Industry Standards Source License v1.2" -licenseName SISSL = "Sun Industry Standards Source License v1.1" -licenseName Sleepycat = "Sleepycat License" -licenseName SMLNJ = "Standard ML of New Jersey License" -licenseName SMPPL = "Secure Messaging Protocol Public License" -licenseName SNIA = "SNIA Public License 1.1" -licenseName Spencer_86 = "Spencer License 86" -licenseName Spencer_94 = "Spencer License 94" -licenseName Spencer_99 = "Spencer License 99" -licenseName SPL_1_0 = "Sun Public License v1.0" -licenseName SSH_OpenSSH = "SSH OpenSSH license" -licenseName SSH_short = "SSH short notice" -licenseName SSPL_1_0 = "Server Side Public License, v 1" -licenseName SugarCRM_1_1_3 = "SugarCRM Public License v1.1.3" -licenseName SWL = "Scheme Widget Library (SWL) Software License Agreement" -licenseName TAPR_OHL_1_0 = "TAPR Open Hardware License v1.0" -licenseName TCL = "TCL/TK License" -licenseName TCP_wrappers = "TCP Wrappers License" -licenseName TMate = "TMate Open Source License" -licenseName TORQUE_1_1 = "TORQUE v2.5+ Software License v1.1" -licenseName TOSL = "Trusster Open Source License" -licenseName TU_Berlin_1_0 = "Technische Universitaet Berlin License 1.0" -licenseName TU_Berlin_2_0 = "Technische Universitaet Berlin License 2.0" -licenseName UCL_1_0 = "Upstream Compatibility License v1.0" -licenseName Unicode_DFS_2015 = "Unicode License Agreement - Data Files and Software (2015)" -licenseName Unicode_DFS_2016 = "Unicode License Agreement - Data Files and Software (2016)" -licenseName Unicode_TOU = "Unicode Terms of Use" -licenseName Unlicense = "The Unlicense" -licenseName UPL_1_0 = "Universal Permissive License v1.0" -licenseName Vim = "Vim License" -licenseName VOSTROM = "VOSTROM Public License for Open Source" -licenseName VSL_1_0 = "Vovida Software License v1.0" -licenseName W3C_19980720 = "W3C Software Notice and License (1998-07-20)" -licenseName W3C_20150513 = "W3C Software Notice and Document License (2015-05-13)" -licenseName W3C = "W3C Software Notice and License (2002-12-31)" -licenseName Watcom_1_0 = "Sybase Open Watcom Public License 1.0" -licenseName Wsuipa = "Wsuipa License" -licenseName WTFPL = "Do What The F*ck You Want To Public License" -licenseName X11 = "X11 License" -licenseName Xerox = "Xerox License" -licenseName XFree86_1_1 = "XFree86 License 1.1" -licenseName Xinetd = "xinetd License" -licenseName Xnet = "X.Net License" -licenseName Xpp = "XPP License" -licenseName XSkat = "XSkat License" -licenseName YPL_1_0 = "Yahoo! Public License v1.0" -licenseName YPL_1_1 = "Yahoo! Public License v1.1" -licenseName Zed = "Zed License" -licenseName Zend_2_0 = "Zend License v2.0" -licenseName Zimbra_1_3 = "Zimbra Public License v1.3" -licenseName Zimbra_1_4 = "Zimbra Public License v1.4" -licenseName Zlib_acknowledgement = "zlib/libpng License with Acknowledgement" -licenseName Zlib = "zlib License" -licenseName ZPL_1_1 = "Zope Public License 1.1" -licenseName ZPL_2_0 = "Zope Public License 2.0" -licenseName ZPL_2_1 = "Zope Public License 2.1" - --- | Whether the license is approved by Open Source Initiative (OSI). --- --- See . -licenseIsOsiApproved :: LicenseId -> Bool -licenseIsOsiApproved NullBSD = True -licenseIsOsiApproved AAL = True -licenseIsOsiApproved AFL_1_1 = True -licenseIsOsiApproved AFL_1_2 = True -licenseIsOsiApproved AFL_2_0 = True -licenseIsOsiApproved AFL_2_1 = True -licenseIsOsiApproved AFL_3_0 = True -licenseIsOsiApproved AGPL_3_0_only = True -licenseIsOsiApproved AGPL_3_0_or_later = True -licenseIsOsiApproved Apache_1_1 = True -licenseIsOsiApproved Apache_2_0 = True -licenseIsOsiApproved APL_1_0 = True -licenseIsOsiApproved APSL_1_0 = True -licenseIsOsiApproved APSL_1_1 = True -licenseIsOsiApproved APSL_1_2 = True -licenseIsOsiApproved APSL_2_0 = True -licenseIsOsiApproved Artistic_1_0_cl8 = True -licenseIsOsiApproved Artistic_1_0_Perl = True -licenseIsOsiApproved Artistic_1_0 = True -licenseIsOsiApproved Artistic_2_0 = True -licenseIsOsiApproved BSD_1_Clause = True -licenseIsOsiApproved BSD_2_Clause_Patent = True -licenseIsOsiApproved BSD_2_Clause = True -licenseIsOsiApproved BSD_3_Clause_LBNL = True -licenseIsOsiApproved BSD_3_Clause = True -licenseIsOsiApproved BSL_1_0 = True -licenseIsOsiApproved CAL_1_0_Combined_Work_Exception = True -licenseIsOsiApproved CAL_1_0 = True -licenseIsOsiApproved CATOSL_1_1 = True -licenseIsOsiApproved CDDL_1_0 = True -licenseIsOsiApproved CECILL_2_1 = True -licenseIsOsiApproved CNRI_Python = True -licenseIsOsiApproved CPAL_1_0 = True -licenseIsOsiApproved CPL_1_0 = True -licenseIsOsiApproved CUA_OPL_1_0 = True -licenseIsOsiApproved ECL_1_0 = True -licenseIsOsiApproved ECL_2_0 = True -licenseIsOsiApproved EFL_1_0 = True -licenseIsOsiApproved EFL_2_0 = True -licenseIsOsiApproved Entessa = True -licenseIsOsiApproved EPL_1_0 = True -licenseIsOsiApproved EPL_2_0 = True -licenseIsOsiApproved EUDatagrid = True -licenseIsOsiApproved EUPL_1_1 = True -licenseIsOsiApproved EUPL_1_2 = True -licenseIsOsiApproved Fair = True -licenseIsOsiApproved Frameworx_1_0 = True -licenseIsOsiApproved GPL_2_0_only = True -licenseIsOsiApproved GPL_2_0_or_later = True -licenseIsOsiApproved GPL_3_0_only = True -licenseIsOsiApproved GPL_3_0_or_later = True -licenseIsOsiApproved HPND = True -licenseIsOsiApproved Intel = True -licenseIsOsiApproved IPA = True -licenseIsOsiApproved IPL_1_0 = True -licenseIsOsiApproved ISC = True -licenseIsOsiApproved LGPL_2_0_only = True -licenseIsOsiApproved LGPL_2_0_or_later = True -licenseIsOsiApproved LGPL_2_1_only = True -licenseIsOsiApproved LGPL_2_1_or_later = True -licenseIsOsiApproved LGPL_3_0_only = True -licenseIsOsiApproved LGPL_3_0_or_later = True -licenseIsOsiApproved LiLiQ_P_1_1 = True -licenseIsOsiApproved LiLiQ_R_1_1 = True -licenseIsOsiApproved LiLiQ_Rplus_1_1 = True -licenseIsOsiApproved LPL_1_02 = True -licenseIsOsiApproved LPL_1_0 = True -licenseIsOsiApproved LPPL_1_3c = True -licenseIsOsiApproved MirOS = True -licenseIsOsiApproved MIT = True -licenseIsOsiApproved Motosoto = True -licenseIsOsiApproved MPL_1_0 = True -licenseIsOsiApproved MPL_1_1 = True -licenseIsOsiApproved MPL_2_0_no_copyleft_exception = True -licenseIsOsiApproved MPL_2_0 = True -licenseIsOsiApproved MS_PL = True -licenseIsOsiApproved MS_RL = True -licenseIsOsiApproved MulanPSL_2_0 = True -licenseIsOsiApproved Multics = True -licenseIsOsiApproved NASA_1_3 = True -licenseIsOsiApproved Naumen = True -licenseIsOsiApproved NCSA = True -licenseIsOsiApproved NGPL = True -licenseIsOsiApproved Nokia = True -licenseIsOsiApproved NPOSL_3_0 = True -licenseIsOsiApproved NTP = True -licenseIsOsiApproved OCLC_2_0 = True -licenseIsOsiApproved OFL_1_1_no_RFN = True -licenseIsOsiApproved OFL_1_1_RFN = True -licenseIsOsiApproved OFL_1_1 = True -licenseIsOsiApproved OGTSL = True -licenseIsOsiApproved OSET_PL_2_1 = True -licenseIsOsiApproved OSL_1_0 = True -licenseIsOsiApproved OSL_2_0 = True -licenseIsOsiApproved OSL_2_1 = True -licenseIsOsiApproved OSL_3_0 = True -licenseIsOsiApproved PHP_3_0 = True -licenseIsOsiApproved PostgreSQL = True -licenseIsOsiApproved Python_2_0 = True -licenseIsOsiApproved QPL_1_0 = True -licenseIsOsiApproved RPL_1_1 = True -licenseIsOsiApproved RPL_1_5 = True -licenseIsOsiApproved RPSL_1_0 = True -licenseIsOsiApproved RSCPL = True -licenseIsOsiApproved SimPL_2_0 = True -licenseIsOsiApproved SISSL = True -licenseIsOsiApproved Sleepycat = True -licenseIsOsiApproved SPL_1_0 = True -licenseIsOsiApproved UCL_1_0 = True -licenseIsOsiApproved UPL_1_0 = True -licenseIsOsiApproved VSL_1_0 = True -licenseIsOsiApproved W3C = True -licenseIsOsiApproved Watcom_1_0 = True -licenseIsOsiApproved Xnet = True -licenseIsOsiApproved Zlib = True -licenseIsOsiApproved ZPL_2_0 = True -licenseIsOsiApproved _ = False - --- | Whether the license is considered libre by Free Software Foundation (FSF). --- --- See --- --- @since 3.4.0.0 --- -licenseIsFsfLibre :: LicenseId -> Bool -licenseIsFsfLibre AFL_1_1 = True -licenseIsFsfLibre AFL_1_2 = True -licenseIsFsfLibre AFL_2_0 = True -licenseIsFsfLibre AFL_2_1 = True -licenseIsFsfLibre AFL_3_0 = True -licenseIsFsfLibre AGPL_1_0 = True -licenseIsFsfLibre AGPL_3_0_only = True -licenseIsFsfLibre AGPL_3_0_or_later = True -licenseIsFsfLibre Apache_1_0 = True -licenseIsFsfLibre Apache_1_1 = True -licenseIsFsfLibre Apache_2_0 = True -licenseIsFsfLibre APSL_2_0 = True -licenseIsFsfLibre Artistic_2_0 = True -licenseIsFsfLibre BitTorrent_1_1 = True -licenseIsFsfLibre BSD_2_Clause_FreeBSD = True -licenseIsFsfLibre BSD_3_Clause_Clear = True -licenseIsFsfLibre BSD_3_Clause = True -licenseIsFsfLibre BSD_4_Clause = True -licenseIsFsfLibre BSL_1_0 = True -licenseIsFsfLibre CC_BY_4_0 = True -licenseIsFsfLibre CC_BY_SA_4_0 = True -licenseIsFsfLibre CC0_1_0 = True -licenseIsFsfLibre CDDL_1_0 = True -licenseIsFsfLibre CECILL_2_0 = True -licenseIsFsfLibre CECILL_B = True -licenseIsFsfLibre CECILL_C = True -licenseIsFsfLibre ClArtistic = True -licenseIsFsfLibre Condor_1_1 = True -licenseIsFsfLibre CPAL_1_0 = True -licenseIsFsfLibre CPL_1_0 = True -licenseIsFsfLibre ECL_2_0 = True -licenseIsFsfLibre EFL_2_0 = True -licenseIsFsfLibre EPL_1_0 = True -licenseIsFsfLibre EPL_2_0 = True -licenseIsFsfLibre EUDatagrid = True -licenseIsFsfLibre EUPL_1_1 = True -licenseIsFsfLibre EUPL_1_2 = True -licenseIsFsfLibre FSFAP = True -licenseIsFsfLibre FTL = True -licenseIsFsfLibre GFDL_1_1_only = True -licenseIsFsfLibre GFDL_1_1_or_later = True -licenseIsFsfLibre GFDL_1_2_only = True -licenseIsFsfLibre GFDL_1_2_or_later = True -licenseIsFsfLibre GFDL_1_3_only = True -licenseIsFsfLibre GFDL_1_3_or_later = True -licenseIsFsfLibre Gnuplot = True -licenseIsFsfLibre GPL_2_0_only = True -licenseIsFsfLibre GPL_2_0_or_later = True -licenseIsFsfLibre GPL_3_0_only = True -licenseIsFsfLibre GPL_3_0_or_later = True -licenseIsFsfLibre HPND = True -licenseIsFsfLibre IJG = True -licenseIsFsfLibre IMatix = True -licenseIsFsfLibre Imlib2 = True -licenseIsFsfLibre Intel = True -licenseIsFsfLibre IPA = True -licenseIsFsfLibre IPL_1_0 = True -licenseIsFsfLibre ISC = True -licenseIsFsfLibre LGPL_2_1_only = True -licenseIsFsfLibre LGPL_2_1_or_later = True -licenseIsFsfLibre LGPL_3_0_only = True -licenseIsFsfLibre LGPL_3_0_or_later = True -licenseIsFsfLibre LPL_1_02 = True -licenseIsFsfLibre LPPL_1_2 = True -licenseIsFsfLibre LPPL_1_3a = True -licenseIsFsfLibre MIT = True -licenseIsFsfLibre MPL_1_1 = True -licenseIsFsfLibre MPL_2_0 = True -licenseIsFsfLibre MS_PL = True -licenseIsFsfLibre MS_RL = True -licenseIsFsfLibre NCSA = True -licenseIsFsfLibre Nokia = True -licenseIsFsfLibre NOSL = True -licenseIsFsfLibre NPL_1_0 = True -licenseIsFsfLibre NPL_1_1 = True -licenseIsFsfLibre ODbL_1_0 = True -licenseIsFsfLibre OFL_1_0 = True -licenseIsFsfLibre OFL_1_1 = True -licenseIsFsfLibre OLDAP_2_3 = True -licenseIsFsfLibre OLDAP_2_7 = True -licenseIsFsfLibre OpenSSL = True -licenseIsFsfLibre OSL_1_0 = True -licenseIsFsfLibre OSL_1_1 = True -licenseIsFsfLibre OSL_2_0 = True -licenseIsFsfLibre OSL_2_1 = True -licenseIsFsfLibre OSL_3_0 = True -licenseIsFsfLibre PHP_3_01 = True -licenseIsFsfLibre Python_2_0 = True -licenseIsFsfLibre QPL_1_0 = True -licenseIsFsfLibre RPSL_1_0 = True -licenseIsFsfLibre Ruby = True -licenseIsFsfLibre SGI_B_2_0 = True -licenseIsFsfLibre SISSL = True -licenseIsFsfLibre Sleepycat = True -licenseIsFsfLibre SMLNJ = True -licenseIsFsfLibre SPL_1_0 = True -licenseIsFsfLibre Unlicense = True -licenseIsFsfLibre UPL_1_0 = True -licenseIsFsfLibre Vim = True -licenseIsFsfLibre W3C = True -licenseIsFsfLibre WTFPL = True -licenseIsFsfLibre X11 = True -licenseIsFsfLibre XFree86_1_1 = True -licenseIsFsfLibre Xinetd = True -licenseIsFsfLibre YPL_1_1 = True -licenseIsFsfLibre Zend_2_0 = True -licenseIsFsfLibre Zimbra_1_3 = True -licenseIsFsfLibre Zlib = True -licenseIsFsfLibre ZPL_2_0 = True -licenseIsFsfLibre ZPL_2_1 = True -licenseIsFsfLibre _ = False - -------------------------------------------------------------------------------- --- Creation -------------------------------------------------------------------------------- - -licenseIdList :: LicenseListVersion -> [LicenseId] -licenseIdList LicenseListVersion_3_0 = - [ AGPL_1_0 - , BSD_2_Clause_NetBSD - ] - ++ bulkOfLicenses -licenseIdList LicenseListVersion_3_2 = - [ AGPL_1_0_only - , AGPL_1_0_or_later - , BSD_2_Clause_NetBSD - , Linux_OpenIB - , MIT_0 - , ODC_By_1_0 - , TU_Berlin_1_0 - , TU_Berlin_2_0 - ] - ++ bulkOfLicenses -licenseIdList LicenseListVersion_3_6 = - [ AGPL_1_0_only - , AGPL_1_0_or_later - , Blessing - , BlueOak_1_0_0 - , BSD_2_Clause_NetBSD - , BSD_3_Clause_Open_MPI - , CC_PDDC - , CERN_OHL_1_1 - , CERN_OHL_1_2 - , Copyleft_next_0_3_0 - , Copyleft_next_0_3_1 - , HPND_sell_variant - , JPNIC - , Libpng_2_0 - , Linux_OpenIB - , MIT_0 - , ODC_By_1_0 - , OGL_UK_1_0 - , OGL_UK_2_0 - , OGL_UK_3_0 - , Parity_6_0_0 - , Sendmail_8_23 - , SHL_0_51 - , SHL_0_5 - , SSPL_1_0 - , TAPR_OHL_1_0 - , TU_Berlin_1_0 - , TU_Berlin_2_0 - ] - ++ bulkOfLicenses -licenseIdList LicenseListVersion_3_9 = - [ AGPL_1_0_only - , AGPL_1_0_or_later - , Blessing - , BlueOak_1_0_0 - , BSD_3_Clause_Open_MPI - , CAL_1_0_Combined_Work_Exception - , CAL_1_0 - , CC_PDDC - , CERN_OHL_1_1 - , CERN_OHL_1_2 - , CERN_OHL_P_2_0 - , CERN_OHL_S_2_0 - , CERN_OHL_W_2_0 - , Copyleft_next_0_3_0 - , Copyleft_next_0_3_1 - , Etalab_2_0 - , Hippocratic_2_1 - , HPND_sell_variant - , JPNIC - , Libpng_2_0 - , Libselinux_1_0 - , Linux_OpenIB - , MIT_0 - , MulanPSL_1_0 - , MulanPSL_2_0 - , NCGL_UK_2_0 - , NTP_0 - , O_UDA_1_0 - , ODC_By_1_0 - , OFL_1_0_no_RFN - , OFL_1_0_RFN - , OFL_1_1_no_RFN - , OFL_1_1_RFN - , OGC_1_0 - , OGL_Canada_2_0 - , OGL_UK_1_0 - , OGL_UK_2_0 - , OGL_UK_3_0 - , Parity_6_0_0 - , Parity_7_0_0 - , PolyForm_Noncommercial_1_0_0 - , PolyForm_Small_Business_1_0_0 - , PSF_2_0 - , Sendmail_8_23 - , SHL_0_51 - , SHL_0_5 - , SSH_OpenSSH - , SSH_short - , SSPL_1_0 - , TAPR_OHL_1_0 - , TU_Berlin_1_0 - , TU_Berlin_2_0 - , UCL_1_0 - ] - ++ bulkOfLicenses - --- | Create a 'LicenseId' from a 'String'. -mkLicenseId :: LicenseListVersion -> String -> Maybe LicenseId -mkLicenseId LicenseListVersion_3_0 s = Map.lookup s stringLookup_3_0 -mkLicenseId LicenseListVersion_3_2 s = Map.lookup s stringLookup_3_2 -mkLicenseId LicenseListVersion_3_6 s = Map.lookup s stringLookup_3_6 -mkLicenseId LicenseListVersion_3_9 s = Map.lookup s stringLookup_3_9 - -stringLookup_3_0 :: Map String LicenseId -stringLookup_3_0 = Map.fromList $ map (\i -> (licenseId i, i)) $ - licenseIdList LicenseListVersion_3_0 - -stringLookup_3_2 :: Map String LicenseId -stringLookup_3_2 = Map.fromList $ map (\i -> (licenseId i, i)) $ - licenseIdList LicenseListVersion_3_2 - -stringLookup_3_6 :: Map String LicenseId -stringLookup_3_6 = Map.fromList $ map (\i -> (licenseId i, i)) $ - licenseIdList LicenseListVersion_3_6 - -stringLookup_3_9 :: Map String LicenseId -stringLookup_3_9 = Map.fromList $ map (\i -> (licenseId i, i)) $ - licenseIdList LicenseListVersion_3_9 - --- | Licenses in all SPDX License lists -bulkOfLicenses :: [LicenseId] -bulkOfLicenses = - [ NullBSD - , AAL - , Abstyles - , Adobe_2006 - , Adobe_Glyph - , ADSL - , AFL_1_1 - , AFL_1_2 - , AFL_2_0 - , AFL_2_1 - , AFL_3_0 - , Afmparse - , AGPL_3_0_only - , AGPL_3_0_or_later - , Aladdin - , AMDPLPA - , AML - , AMPAS - , ANTLR_PD - , Apache_1_0 - , Apache_1_1 - , Apache_2_0 - , APAFML - , APL_1_0 - , APSL_1_0 - , APSL_1_1 - , APSL_1_2 - , APSL_2_0 - , Artistic_1_0_cl8 - , Artistic_1_0_Perl - , Artistic_1_0 - , Artistic_2_0 - , Bahyph - , Barr - , Beerware - , BitTorrent_1_0 - , BitTorrent_1_1 - , Borceux - , BSD_1_Clause - , BSD_2_Clause_FreeBSD - , BSD_2_Clause_Patent - , BSD_2_Clause - , BSD_3_Clause_Attribution - , BSD_3_Clause_Clear - , BSD_3_Clause_LBNL - , BSD_3_Clause_No_Nuclear_License_2014 - , BSD_3_Clause_No_Nuclear_License - , BSD_3_Clause_No_Nuclear_Warranty - , BSD_3_Clause - , BSD_4_Clause_UC - , BSD_4_Clause - , BSD_Protection - , BSD_Source_Code - , BSL_1_0 - , Bzip2_1_0_5 - , Bzip2_1_0_6 - , Caldera - , CATOSL_1_1 - , CC_BY_1_0 - , CC_BY_2_0 - , CC_BY_2_5 - , CC_BY_3_0 - , CC_BY_4_0 - , CC_BY_NC_1_0 - , CC_BY_NC_2_0 - , CC_BY_NC_2_5 - , CC_BY_NC_3_0 - , CC_BY_NC_4_0 - , CC_BY_NC_ND_1_0 - , CC_BY_NC_ND_2_0 - , CC_BY_NC_ND_2_5 - , CC_BY_NC_ND_3_0 - , CC_BY_NC_ND_4_0 - , CC_BY_NC_SA_1_0 - , CC_BY_NC_SA_2_0 - , CC_BY_NC_SA_2_5 - , CC_BY_NC_SA_3_0 - , CC_BY_NC_SA_4_0 - , CC_BY_ND_1_0 - , CC_BY_ND_2_0 - , CC_BY_ND_2_5 - , CC_BY_ND_3_0 - , CC_BY_ND_4_0 - , CC_BY_SA_1_0 - , CC_BY_SA_2_0 - , CC_BY_SA_2_5 - , CC_BY_SA_3_0 - , CC_BY_SA_4_0 - , CC0_1_0 - , CDDL_1_0 - , CDDL_1_1 - , CDLA_Permissive_1_0 - , CDLA_Sharing_1_0 - , CECILL_1_0 - , CECILL_1_1 - , CECILL_2_0 - , CECILL_2_1 - , CECILL_B - , CECILL_C - , ClArtistic - , CNRI_Jython - , CNRI_Python_GPL_Compatible - , CNRI_Python - , Condor_1_1 - , CPAL_1_0 - , CPL_1_0 - , CPOL_1_02 - , Crossword - , CrystalStacker - , CUA_OPL_1_0 - , Cube - , Curl - , D_FSL_1_0 - , Diffmark - , DOC - , Dotseqn - , DSDP - , Dvipdfm - , ECL_1_0 - , ECL_2_0 - , EFL_1_0 - , EFL_2_0 - , EGenix - , Entessa - , EPL_1_0 - , EPL_2_0 - , ErlPL_1_1 - , EUDatagrid - , EUPL_1_0 - , EUPL_1_1 - , EUPL_1_2 - , Eurosym - , Fair - , Frameworx_1_0 - , FreeImage - , FSFAP - , FSFULLR - , FSFUL - , FTL - , GFDL_1_1_only - , GFDL_1_1_or_later - , GFDL_1_2_only - , GFDL_1_2_or_later - , GFDL_1_3_only - , GFDL_1_3_or_later - , Giftware - , GL2PS - , Glide - , Glulxe - , Gnuplot - , GPL_1_0_only - , GPL_1_0_or_later - , GPL_2_0_only - , GPL_2_0_or_later - , GPL_3_0_only - , GPL_3_0_or_later - , GSOAP_1_3b - , HaskellReport - , HPND - , IBM_pibs - , ICU - , IJG - , ImageMagick - , IMatix - , Imlib2 - , Info_ZIP - , Intel_ACPI - , Intel - , Interbase_1_0 - , IPA - , IPL_1_0 - , ISC - , JasPer_2_0 - , JSON - , LAL_1_2 - , LAL_1_3 - , Latex2e - , Leptonica - , LGPL_2_0_only - , LGPL_2_0_or_later - , LGPL_2_1_only - , LGPL_2_1_or_later - , LGPL_3_0_only - , LGPL_3_0_or_later - , LGPLLR - , Libpng - , Libtiff - , LiLiQ_P_1_1 - , LiLiQ_R_1_1 - , LiLiQ_Rplus_1_1 - , LPL_1_02 - , LPL_1_0 - , LPPL_1_0 - , LPPL_1_1 - , LPPL_1_2 - , LPPL_1_3a - , LPPL_1_3c - , MakeIndex - , MirOS - , MIT_advertising - , MIT_CMU - , MIT_enna - , MIT_feh - , MITNFA - , MIT - , Motosoto - , Mpich2 - , MPL_1_0 - , MPL_1_1 - , MPL_2_0_no_copyleft_exception - , MPL_2_0 - , MS_PL - , MS_RL - , MTLL - , Multics - , Mup - , NASA_1_3 - , Naumen - , NBPL_1_0 - , NCSA - , Net_SNMP - , NetCDF - , Newsletr - , NGPL - , NLOD_1_0 - , NLPL - , Nokia - , NOSL - , Noweb - , NPL_1_0 - , NPL_1_1 - , NPOSL_3_0 - , NRL - , NTP - , OCCT_PL - , OCLC_2_0 - , ODbL_1_0 - , OFL_1_0 - , OFL_1_1 - , OGTSL - , OLDAP_1_1 - , OLDAP_1_2 - , OLDAP_1_3 - , OLDAP_1_4 - , OLDAP_2_0_1 - , OLDAP_2_0 - , OLDAP_2_1 - , OLDAP_2_2_1 - , OLDAP_2_2_2 - , OLDAP_2_2 - , OLDAP_2_3 - , OLDAP_2_4 - , OLDAP_2_5 - , OLDAP_2_6 - , OLDAP_2_7 - , OLDAP_2_8 - , OML - , OpenSSL - , OPL_1_0 - , OSET_PL_2_1 - , OSL_1_0 - , OSL_1_1 - , OSL_2_0 - , OSL_2_1 - , OSL_3_0 - , PDDL_1_0 - , PHP_3_01 - , PHP_3_0 - , Plexus - , PostgreSQL - , Psfrag - , Psutils - , Python_2_0 - , Qhull - , QPL_1_0 - , Rdisc - , RHeCos_1_1 - , RPL_1_1 - , RPL_1_5 - , RPSL_1_0 - , RSA_MD - , RSCPL - , Ruby - , SAX_PD - , Saxpath - , SCEA - , Sendmail - , SGI_B_1_0 - , SGI_B_1_1 - , SGI_B_2_0 - , SimPL_2_0 - , SISSL_1_2 - , SISSL - , Sleepycat - , SMLNJ - , SMPPL - , SNIA - , Spencer_86 - , Spencer_94 - , Spencer_99 - , SPL_1_0 - , SugarCRM_1_1_3 - , SWL - , TCL - , TCP_wrappers - , TMate - , TORQUE_1_1 - , TOSL - , Unicode_DFS_2015 - , Unicode_DFS_2016 - , Unicode_TOU - , Unlicense - , UPL_1_0 - , Vim - , VOSTROM - , VSL_1_0 - , W3C_19980720 - , W3C_20150513 - , W3C - , Watcom_1_0 - , Wsuipa - , WTFPL - , X11 - , Xerox - , XFree86_1_1 - , Xinetd - , Xnet - , Xpp - , XSkat - , YPL_1_0 - , YPL_1_1 - , Zed - , Zend_2_0 - , Zimbra_1_3 - , Zimbra_1_4 - , Zlib_acknowledgement - , Zlib - , ZPL_1_1 - , ZPL_2_0 - , ZPL_2_1 - ] diff --git a/cabal/Cabal/Distribution/SPDX/LicenseListVersion.hs b/cabal/Cabal/Distribution/SPDX/LicenseListVersion.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/SPDX/LicenseListVersion.hs +++ /dev/null @@ -1,20 +0,0 @@ -module Distribution.SPDX.LicenseListVersion ( - LicenseListVersion (..), - cabalSpecVersionToSPDXListVersion, - ) where - -import Distribution.CabalSpecVersion - --- | SPDX License List version @Cabal@ is aware of. -data LicenseListVersion - = LicenseListVersion_3_0 - | LicenseListVersion_3_2 - | LicenseListVersion_3_6 - | LicenseListVersion_3_9 - deriving (Eq, Ord, Show, Enum, Bounded) - -cabalSpecVersionToSPDXListVersion :: CabalSpecVersion -> LicenseListVersion -cabalSpecVersionToSPDXListVersion CabalSpecV3_4 = LicenseListVersion_3_9 -cabalSpecVersionToSPDXListVersion CabalSpecV3_0 = LicenseListVersion_3_6 -cabalSpecVersionToSPDXListVersion CabalSpecV2_4 = LicenseListVersion_3_2 -cabalSpecVersionToSPDXListVersion _ = LicenseListVersion_3_0 diff --git a/cabal/Cabal/Distribution/SPDX/LicenseReference.hs b/cabal/Cabal/Distribution/SPDX/LicenseReference.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/SPDX/LicenseReference.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.SPDX.LicenseReference ( - LicenseRef, - licenseRef, - licenseDocumentRef, - mkLicenseRef, - mkLicenseRef', - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Utils.Generic (isAsciiAlphaNum) -import Distribution.Pretty -import Distribution.Parsec - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - --- | A user defined license reference denoted by @LicenseRef-[idstring]@ (for a license not on the SPDX License List); -data LicenseRef = LicenseRef - { _lrDocument :: !(Maybe String) - , _lrLicense :: !String - } - deriving (Show, Read, Eq, Ord, Typeable, Data, Generic) - --- | License reference. -licenseRef :: LicenseRef -> String -licenseRef = _lrLicense - --- | Document reference. -licenseDocumentRef :: LicenseRef -> Maybe String -licenseDocumentRef = _lrDocument - -instance Binary LicenseRef -instance Structured LicenseRef - -instance NFData LicenseRef where - rnf (LicenseRef d l) = rnf d `seq` rnf l - -instance Pretty LicenseRef where - pretty (LicenseRef Nothing l) = Disp.text "LicenseRef-" <<>> Disp.text l - pretty (LicenseRef (Just d) l) = - Disp.text "DocumentRef-" <<>> Disp.text d <<>> Disp.char ':' <<>> Disp.text "LicenseRef-" <<>> Disp.text l - -instance Parsec LicenseRef where - parsec = name <|> doc - where - name = do - _ <- P.string "LicenseRef-" - n <- some $ P.satisfy $ \c -> isAsciiAlphaNum c || c == '-' || c == '.' - pure (LicenseRef Nothing n) - - doc = do - _ <- P.string "DocumentRef-" - d <- some $ P.satisfy $ \c -> isAsciiAlphaNum c || c == '-' || c == '.' - _ <- P.char ':' - _ <- P.string "LicenseRef-" - n <- some $ P.satisfy $ \c -> isAsciiAlphaNum c || c == '-' || c == '.' - pure (LicenseRef (Just d) n) - --- | Create 'LicenseRef' from optional document ref and name. -mkLicenseRef :: Maybe String -> String -> Maybe LicenseRef -mkLicenseRef d l = do - d' <- traverse checkIdString d - l' <- checkIdString l - pure (LicenseRef d' l') - where - checkIdString s - | all (\c -> isAsciiAlphaNum c || c == '-' || c == '.') s = Just s - | otherwise = Nothing - --- | Like 'mkLicenseRef' but convert invalid characters into @-@. -mkLicenseRef' :: Maybe String -> String -> LicenseRef -mkLicenseRef' d l = LicenseRef (fmap f d) (f l) - where - f = map g - g c | isAsciiAlphaNum c || c == '-' || c == '.' = c - | otherwise = '-' diff --git a/cabal/Cabal/Distribution/Simple.hs b/cabal/Cabal/Distribution/Simple.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple.hs +++ /dev/null @@ -1,837 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE LambdaCase #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple --- Copyright : Isaac Jones 2003-2005 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This is the command line front end to the Simple build system. When given --- the parsed command-line args and package information, is able to perform --- basic commands like configure, build, install, register, etc. --- --- This module exports the main functions that Setup.hs scripts use. It --- re-exports the 'UserHooks' type, the standard entry points like --- 'defaultMain' and 'defaultMainWithHooks' and the predefined sets of --- 'UserHooks' that custom @Setup.hs@ scripts can extend to add their own --- behaviour. --- --- This module isn't called \"Simple\" because it's simple. Far from --- it. It's called \"Simple\" because it does complicated things to --- simple software. --- --- The original idea was that there could be different build systems that all --- presented the same compatible command line interfaces. There is still a --- "Distribution.Make" system but in practice no packages use it. - -{- -Work around this warning: -libraries/Cabal/Distribution/Simple.hs:78:0: - Warning: In the use of `runTests' - (imported from Distribution.Simple.UserHooks): - Deprecated: "Please use the new testing interface instead!" --} -{-# OPTIONS_GHC -fno-warn-deprecations #-} - -module Distribution.Simple ( - module Distribution.Package, - module Distribution.Version, - module Distribution.License, - module Distribution.Simple.Compiler, - module Language.Haskell.Extension, - -- * Simple interface - defaultMain, defaultMainNoRead, defaultMainArgs, - -- * Customization - UserHooks(..), Args, - defaultMainWithHooks, defaultMainWithHooksArgs, - defaultMainWithHooksNoRead, defaultMainWithHooksNoReadArgs, - -- ** Standard sets of hooks - simpleUserHooks, - autoconfUserHooks, - emptyUserHooks, - ) where - -import Control.Exception (try) - -import Prelude () -import Distribution.Compat.Prelude - --- local -import Distribution.Simple.Compiler -import Distribution.Simple.UserHooks -import Distribution.Package -import Distribution.PackageDescription -import Distribution.PackageDescription.Configuration -import Distribution.Simple.Program -import Distribution.Simple.Program.Db -import Distribution.Simple.PreProcess -import Distribution.Simple.Setup -import Distribution.Simple.Command - -import Distribution.Simple.Build -import Distribution.Simple.SrcDist -import Distribution.Simple.Register - -import Distribution.Simple.Configure - -import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.Bench -import Distribution.Simple.BuildPaths -import Distribution.Simple.Test -import Distribution.Simple.Install -import Distribution.Simple.Haddock -import Distribution.Simple.Doctest -import Distribution.Simple.Utils -import Distribution.Utils.NubList -import Distribution.Verbosity -import Language.Haskell.Extension -import Distribution.Version -import Distribution.License -import Distribution.Pretty -import Distribution.System (buildPlatform) - --- Base -import System.Environment (getArgs, getProgName) -import System.Directory (removeFile, doesFileExist - ,doesDirectoryExist, removeDirectoryRecursive) -import System.FilePath (searchPathSeparator, takeDirectory, (), splitDirectories, dropDrive) -import Distribution.Compat.ResponseFile (expandResponse) -import Distribution.Compat.Directory (makeAbsolute) -import Distribution.Compat.Environment (getEnvironment) -import Distribution.Compat.GetShortPathName (getShortPathName) - -import Data.List (unionBy, (\\)) - -import Distribution.PackageDescription.Parsec - --- | A simple implementation of @main@ for a Cabal setup script. --- It reads the package description file using IO, and performs the --- action specified on the command line. -defaultMain :: IO () -defaultMain = getArgs >>= defaultMainHelper simpleUserHooks - --- | A version of 'defaultMain' that is passed the command line --- arguments, rather than getting them from the environment. -defaultMainArgs :: [String] -> IO () -defaultMainArgs = defaultMainHelper simpleUserHooks - --- | A customizable version of 'defaultMain'. -defaultMainWithHooks :: UserHooks -> IO () -defaultMainWithHooks hooks = getArgs >>= defaultMainHelper hooks - --- | A customizable version of 'defaultMain' that also takes the command --- line arguments. -defaultMainWithHooksArgs :: UserHooks -> [String] -> IO () -defaultMainWithHooksArgs = defaultMainHelper - --- | Like 'defaultMain', but accepts the package description as input --- rather than using IO to read it. -defaultMainNoRead :: GenericPackageDescription -> IO () -defaultMainNoRead = defaultMainWithHooksNoRead simpleUserHooks - --- | A customizable version of 'defaultMainNoRead'. -defaultMainWithHooksNoRead :: UserHooks -> GenericPackageDescription -> IO () -defaultMainWithHooksNoRead hooks pkg_descr = - getArgs >>= - defaultMainHelper hooks { readDesc = return (Just pkg_descr) } - --- | A customizable version of 'defaultMainNoRead' that also takes the --- command line arguments. --- --- @since 2.2.0.0 -defaultMainWithHooksNoReadArgs :: UserHooks -> GenericPackageDescription -> [String] -> IO () -defaultMainWithHooksNoReadArgs hooks pkg_descr = - defaultMainHelper hooks { readDesc = return (Just pkg_descr) } - -defaultMainHelper :: UserHooks -> Args -> IO () -defaultMainHelper hooks args = topHandler $ do - args' <- expandResponse args - case commandsRun (globalCommand commands) commands args' of - CommandHelp help -> printHelp help - CommandList opts -> printOptionsList opts - CommandErrors errs -> printErrors errs - CommandReadyToGo (flags, commandParse) -> - case commandParse of - _ | fromFlag (globalVersion flags) -> printVersion - | fromFlag (globalNumericVersion flags) -> printNumericVersion - CommandHelp help -> printHelp help - CommandList opts -> printOptionsList opts - CommandErrors errs -> printErrors errs - CommandReadyToGo action -> action - - where - printHelp help = getProgName >>= putStr . help - printOptionsList = putStr . unlines - printErrors errs = do - putStr (intercalate "\n" errs) - exitWith (ExitFailure 1) - printNumericVersion = putStrLn $ prettyShow cabalVersion - printVersion = putStrLn $ "Cabal library version " - ++ prettyShow cabalVersion - - progs = addKnownPrograms (hookedPrograms hooks) defaultProgramDb - commands = - [configureCommand progs `commandAddAction` - \fs as -> configureAction hooks fs as >> return () - ,buildCommand progs `commandAddAction` buildAction hooks - ,showBuildInfoCommand progs `commandAddAction` showBuildInfoAction hooks - ,replCommand progs `commandAddAction` replAction hooks - ,installCommand `commandAddAction` installAction hooks - ,copyCommand `commandAddAction` copyAction hooks - ,doctestCommand `commandAddAction` doctestAction hooks - ,haddockCommand `commandAddAction` haddockAction hooks - ,cleanCommand `commandAddAction` cleanAction hooks - ,sdistCommand `commandAddAction` sdistAction hooks - ,hscolourCommand `commandAddAction` hscolourAction hooks - ,registerCommand `commandAddAction` registerAction hooks - ,unregisterCommand `commandAddAction` unregisterAction hooks - ,testCommand `commandAddAction` testAction hooks - ,benchmarkCommand `commandAddAction` benchAction hooks - ] - --- | Combine the preprocessors in the given hooks with the --- preprocessors built into cabal. -allSuffixHandlers :: UserHooks - -> [PPSuffixHandler] -allSuffixHandlers hooks - = overridesPP (hookedPreProcessors hooks) knownSuffixHandlers - where - overridesPP :: [PPSuffixHandler] -> [PPSuffixHandler] -> [PPSuffixHandler] - overridesPP = unionBy (\x y -> fst x == fst y) - -configureAction :: UserHooks -> ConfigFlags -> Args -> IO LocalBuildInfo -configureAction hooks flags args = do - distPref <- findDistPrefOrDefault (configDistPref flags) - let flags' = flags { configDistPref = toFlag distPref - , configArgs = args } - - -- See docs for 'HookedBuildInfo' - pbi <- preConf hooks args flags' - - (mb_pd_file, pkg_descr0) <- confPkgDescr hooks verbosity - (flagToMaybe (configCabalFilePath flags)) - - let epkg_descr = (pkg_descr0, pbi) - - localbuildinfo0 <- confHook hooks epkg_descr flags' - - -- remember the .cabal filename if we know it - -- and all the extra command line args - let localbuildinfo = localbuildinfo0 { - pkgDescrFile = mb_pd_file, - extraConfigArgs = args - } - writePersistBuildConfig distPref localbuildinfo - - let pkg_descr = localPkgDescr localbuildinfo - postConf hooks args flags' pkg_descr localbuildinfo - return localbuildinfo - where - verbosity = fromFlag (configVerbosity flags) - -confPkgDescr :: UserHooks -> Verbosity -> Maybe FilePath - -> IO (Maybe FilePath, GenericPackageDescription) -confPkgDescr hooks verbosity mb_path = do - mdescr <- readDesc hooks - case mdescr of - Just descr -> return (Nothing, descr) - Nothing -> do - pdfile <- case mb_path of - Nothing -> defaultPackageDesc verbosity - Just path -> return path - info verbosity "Using Parsec parser" - descr <- readGenericPackageDescription verbosity pdfile - return (Just pdfile, descr) - -buildAction :: UserHooks -> BuildFlags -> Args -> IO () -buildAction hooks flags args = do - distPref <- findDistPrefOrDefault (buildDistPref flags) - let verbosity = fromFlag $ buildVerbosity flags - lbi <- getBuildConfig hooks verbosity distPref - let flags' = flags { buildDistPref = toFlag distPref - , buildCabalFilePath = maybeToFlag (cabalFilePath lbi)} - - progs <- reconfigurePrograms verbosity - (buildProgramPaths flags') - (buildProgramArgs flags') - (withPrograms lbi) - - hookedAction verbosity preBuild buildHook postBuild - (return lbi { withPrograms = progs }) - hooks flags' { buildArgs = args } args - -showBuildInfoAction :: UserHooks -> ShowBuildInfoFlags -> Args -> IO () -showBuildInfoAction hooks (ShowBuildInfoFlags flags fileOutput) args = do - distPref <- findDistPrefOrDefault (buildDistPref flags) - let verbosity = fromFlag $ buildVerbosity flags - lbi <- getBuildConfig hooks verbosity distPref - let flags' = flags { buildDistPref = toFlag distPref - , buildCabalFilePath = maybeToFlag (cabalFilePath lbi) - } - - progs <- reconfigurePrograms verbosity - (buildProgramPaths flags') - (buildProgramArgs flags') - (withPrograms lbi) - - pbi <- preBuild hooks args flags' - let lbi' = lbi { withPrograms = progs } - pkg_descr0 = localPkgDescr lbi' - pkg_descr = updatePackageDescription pbi pkg_descr0 - -- TODO: Somehow don't ignore build hook? - buildInfoString <- showBuildInfo pkg_descr lbi' flags - - case fileOutput of - Nothing -> putStr buildInfoString - Just fp -> writeFile fp buildInfoString - - postBuild hooks args flags' pkg_descr lbi' - -replAction :: UserHooks -> ReplFlags -> Args -> IO () -replAction hooks flags args = do - distPref <- findDistPrefOrDefault (replDistPref flags) - let verbosity = fromFlag $ replVerbosity flags - flags' = flags { replDistPref = toFlag distPref } - - lbi <- getBuildConfig hooks verbosity distPref - progs <- reconfigurePrograms verbosity - (replProgramPaths flags') - (replProgramArgs flags') - (withPrograms lbi) - - -- As far as I can tell, the only reason this doesn't use - -- 'hookedActionWithArgs' is because the arguments of 'replHook' - -- takes the args explicitly. UGH. -- ezyang - pbi <- preRepl hooks args flags' - let pkg_descr0 = localPkgDescr lbi - sanityCheckHookedBuildInfo verbosity pkg_descr0 pbi - let pkg_descr = updatePackageDescription pbi pkg_descr0 - lbi' = lbi { withPrograms = progs - , localPkgDescr = pkg_descr } - replHook hooks pkg_descr lbi' hooks flags' args - postRepl hooks args flags' pkg_descr lbi' - -hscolourAction :: UserHooks -> HscolourFlags -> Args -> IO () -hscolourAction hooks flags args = do - distPref <- findDistPrefOrDefault (hscolourDistPref flags) - let verbosity = fromFlag $ hscolourVerbosity flags - lbi <- getBuildConfig hooks verbosity distPref - let flags' = flags { hscolourDistPref = toFlag distPref - , hscolourCabalFilePath = maybeToFlag (cabalFilePath lbi)} - - hookedAction verbosity preHscolour hscolourHook postHscolour - (getBuildConfig hooks verbosity distPref) - hooks flags' args - -doctestAction :: UserHooks -> DoctestFlags -> Args -> IO () -doctestAction hooks flags args = do - distPref <- findDistPrefOrDefault (doctestDistPref flags) - let verbosity = fromFlag $ doctestVerbosity flags - flags' = flags { doctestDistPref = toFlag distPref } - - lbi <- getBuildConfig hooks verbosity distPref - progs <- reconfigurePrograms verbosity - (doctestProgramPaths flags') - (doctestProgramArgs flags') - (withPrograms lbi) - - hookedAction verbosity preDoctest doctestHook postDoctest - (return lbi { withPrograms = progs }) - hooks flags' args - -haddockAction :: UserHooks -> HaddockFlags -> Args -> IO () -haddockAction hooks flags args = do - distPref <- findDistPrefOrDefault (haddockDistPref flags) - let verbosity = fromFlag $ haddockVerbosity flags - lbi <- getBuildConfig hooks verbosity distPref - let flags' = flags { haddockDistPref = toFlag distPref - , haddockCabalFilePath = maybeToFlag (cabalFilePath lbi)} - - progs <- reconfigurePrograms verbosity - (haddockProgramPaths flags') - (haddockProgramArgs flags') - (withPrograms lbi) - - hookedAction verbosity preHaddock haddockHook postHaddock - (return lbi { withPrograms = progs }) - hooks flags' { haddockArgs = args } args - -cleanAction :: UserHooks -> CleanFlags -> Args -> IO () -cleanAction hooks flags args = do - distPref <- findDistPrefOrDefault (cleanDistPref flags) - - elbi <- tryGetBuildConfig hooks verbosity distPref - let flags' = flags { cleanDistPref = toFlag distPref - , cleanCabalFilePath = case elbi of - Left _ -> mempty - Right lbi -> maybeToFlag (cabalFilePath lbi)} - - pbi <- preClean hooks args flags' - - (_, ppd) <- confPkgDescr hooks verbosity Nothing - -- It might seem like we are doing something clever here - -- but we're really not: if you look at the implementation - -- of 'clean' in the end all the package description is - -- used for is to clear out @extra-tmp-files@. IMO, - -- the configure script goo should go into @dist@ too! - -- -- ezyang - let pkg_descr0 = flattenPackageDescription ppd - -- We don't sanity check for clean as an error - -- here would prevent cleaning: - --sanityCheckHookedBuildInfo verbosity pkg_descr0 pbi - let pkg_descr = updatePackageDescription pbi pkg_descr0 - - cleanHook hooks pkg_descr () hooks flags' - postClean hooks args flags' pkg_descr () - where - verbosity = fromFlag (cleanVerbosity flags) - -copyAction :: UserHooks -> CopyFlags -> Args -> IO () -copyAction hooks flags args = do - distPref <- findDistPrefOrDefault (copyDistPref flags) - let verbosity = fromFlag $ copyVerbosity flags - lbi <- getBuildConfig hooks verbosity distPref - let flags' = flags { copyDistPref = toFlag distPref - , copyCabalFilePath = maybeToFlag (cabalFilePath lbi)} - hookedAction verbosity preCopy copyHook postCopy - (getBuildConfig hooks verbosity distPref) - hooks flags' { copyArgs = args } args - -installAction :: UserHooks -> InstallFlags -> Args -> IO () -installAction hooks flags args = do - distPref <- findDistPrefOrDefault (installDistPref flags) - let verbosity = fromFlag $ installVerbosity flags - lbi <- getBuildConfig hooks verbosity distPref - let flags' = flags { installDistPref = toFlag distPref - , installCabalFilePath = maybeToFlag (cabalFilePath lbi)} - hookedAction verbosity preInst instHook postInst - (getBuildConfig hooks verbosity distPref) - hooks flags' args - --- Since Cabal-3.4 UserHooks are completely ignored -sdistAction :: UserHooks -> SDistFlags -> Args -> IO () -sdistAction _hooks flags _args = do - (_, ppd) <- confPkgDescr emptyUserHooks verbosity Nothing - let pkg_descr = flattenPackageDescription ppd - sdist pkg_descr flags srcPref knownSuffixHandlers - where - verbosity = fromFlag (sDistVerbosity flags) - -testAction :: UserHooks -> TestFlags -> Args -> IO () -testAction hooks flags args = do - distPref <- findDistPrefOrDefault (testDistPref flags) - let verbosity = fromFlag $ testVerbosity flags - flags' = flags { testDistPref = toFlag distPref } - - hookedActionWithArgs verbosity preTest testHook postTest - (getBuildConfig hooks verbosity distPref) - hooks flags' args - -benchAction :: UserHooks -> BenchmarkFlags -> Args -> IO () -benchAction hooks flags args = do - distPref <- findDistPrefOrDefault (benchmarkDistPref flags) - let verbosity = fromFlag $ benchmarkVerbosity flags - flags' = flags { benchmarkDistPref = toFlag distPref } - hookedActionWithArgs verbosity preBench benchHook postBench - (getBuildConfig hooks verbosity distPref) - hooks flags' args - -registerAction :: UserHooks -> RegisterFlags -> Args -> IO () -registerAction hooks flags args = do - distPref <- findDistPrefOrDefault (regDistPref flags) - let verbosity = fromFlag $ regVerbosity flags - lbi <- getBuildConfig hooks verbosity distPref - let flags' = flags { regDistPref = toFlag distPref - , regCabalFilePath = maybeToFlag (cabalFilePath lbi)} - hookedAction verbosity preReg regHook postReg - (getBuildConfig hooks verbosity distPref) - hooks flags' { regArgs = args } args - -unregisterAction :: UserHooks -> RegisterFlags -> Args -> IO () -unregisterAction hooks flags args = do - distPref <- findDistPrefOrDefault (regDistPref flags) - let verbosity = fromFlag $ regVerbosity flags - lbi <- getBuildConfig hooks verbosity distPref - let flags' = flags { regDistPref = toFlag distPref - , regCabalFilePath = maybeToFlag (cabalFilePath lbi)} - hookedAction verbosity preUnreg unregHook postUnreg - (getBuildConfig hooks verbosity distPref) - hooks flags' args - -hookedAction - :: Verbosity - -> (UserHooks -> Args -> flags -> IO HookedBuildInfo) - -> (UserHooks -> PackageDescription -> LocalBuildInfo - -> UserHooks -> flags -> IO ()) - -> (UserHooks -> Args -> flags -> PackageDescription - -> LocalBuildInfo -> IO ()) - -> IO LocalBuildInfo - -> UserHooks -> flags -> Args -> IO () -hookedAction verbosity pre_hook cmd_hook = - hookedActionWithArgs verbosity pre_hook - (\h _ pd lbi uh flags -> - cmd_hook h pd lbi uh flags) - -hookedActionWithArgs - :: Verbosity - -> (UserHooks -> Args -> flags -> IO HookedBuildInfo) - -> (UserHooks -> Args -> PackageDescription -> LocalBuildInfo - -> UserHooks -> flags -> IO ()) - -> (UserHooks -> Args -> flags -> PackageDescription - -> LocalBuildInfo -> IO ()) - -> IO LocalBuildInfo - -> UserHooks -> flags -> Args -> IO () -hookedActionWithArgs verbosity pre_hook cmd_hook post_hook - get_build_config hooks flags args = do - pbi <- pre_hook hooks args flags - lbi0 <- get_build_config - let pkg_descr0 = localPkgDescr lbi0 - sanityCheckHookedBuildInfo verbosity pkg_descr0 pbi - let pkg_descr = updatePackageDescription pbi pkg_descr0 - lbi = lbi0 { localPkgDescr = pkg_descr } - cmd_hook hooks args pkg_descr lbi hooks flags - post_hook hooks args flags pkg_descr lbi - -sanityCheckHookedBuildInfo - :: Verbosity -> PackageDescription -> HookedBuildInfo -> IO () -sanityCheckHookedBuildInfo verbosity - (PackageDescription { library = Nothing }) (Just _,_) - = die' verbosity $ "The buildinfo contains info for a library, " - ++ "but the package does not have a library." - -sanityCheckHookedBuildInfo verbosity pkg_descr (_, hookExes) - | exe1 : _ <- nonExistant - = die' verbosity $ "The buildinfo contains info for an executable called '" - ++ prettyShow exe1 ++ "' but the package does not have a " - ++ "executable with that name." - where - pkgExeNames = nub (map exeName (executables pkg_descr)) - hookExeNames = nub (map fst hookExes) - nonExistant = hookExeNames \\ pkgExeNames - -sanityCheckHookedBuildInfo _ _ _ = return () - --- | Try to read the 'localBuildInfoFile' -tryGetBuildConfig :: UserHooks -> Verbosity -> FilePath - -> IO (Either ConfigStateFileError LocalBuildInfo) -tryGetBuildConfig u v = try . getBuildConfig u v - - --- | Read the 'localBuildInfoFile' or throw an exception. -getBuildConfig :: UserHooks -> Verbosity -> FilePath -> IO LocalBuildInfo -getBuildConfig hooks verbosity distPref = do - lbi_wo_programs <- getPersistBuildConfig distPref - -- Restore info about unconfigured programs, since it is not serialized - let lbi = lbi_wo_programs { - withPrograms = restoreProgramDb - (builtinPrograms ++ hookedPrograms hooks) - (withPrograms lbi_wo_programs) - } - - case pkgDescrFile lbi of - Nothing -> return lbi - Just pkg_descr_file -> do - outdated <- checkPersistBuildConfigOutdated distPref pkg_descr_file - if outdated - then reconfigure pkg_descr_file lbi - else return lbi - - where - reconfigure :: FilePath -> LocalBuildInfo -> IO LocalBuildInfo - reconfigure pkg_descr_file lbi = do - notice verbosity $ pkg_descr_file ++ " has been changed. " - ++ "Re-configuring with most recently used options. " - ++ "If this fails, please run configure manually.\n" - let cFlags = configFlags lbi - let cFlags' = cFlags { - -- Since the list of unconfigured programs is not serialized, - -- restore it to the same value as normally used at the beginning - -- of a configure run: - configPrograms_ = fmap (restoreProgramDb - (builtinPrograms ++ hookedPrograms hooks)) - `fmap` configPrograms_ cFlags, - - -- Use the current, not saved verbosity level: - configVerbosity = Flag verbosity - } - configureAction hooks cFlags' (extraConfigArgs lbi) - - --- -------------------------------------------------------------------------- --- Cleaning - -clean :: PackageDescription -> CleanFlags -> IO () -clean pkg_descr flags = do - let distPref = fromFlagOrDefault defaultDistPref $ cleanDistPref flags - notice verbosity "cleaning..." - - maybeConfig <- if fromFlag (cleanSaveConf flags) - then maybeGetPersistBuildConfig distPref - else return Nothing - - -- remove the whole dist/ directory rather than tracking exactly what files - -- we created in there. - chattyTry "removing dist/" $ do - exists <- doesDirectoryExist distPref - when exists (removeDirectoryRecursive distPref) - - -- Any extra files the user wants to remove - traverse_ removeFileOrDirectory (extraTmpFiles pkg_descr) - - -- If the user wanted to save the config, write it back - traverse_ (writePersistBuildConfig distPref) maybeConfig - - where - removeFileOrDirectory :: FilePath -> IO () - removeFileOrDirectory fname = do - isDir <- doesDirectoryExist fname - isFile <- doesFileExist fname - if isDir then removeDirectoryRecursive fname - else when isFile $ removeFile fname - verbosity = fromFlag (cleanVerbosity flags) - --- -------------------------------------------------------------------------- --- Default hooks - --- | Hooks that correspond to a plain instantiation of the --- \"simple\" build system -simpleUserHooks :: UserHooks -simpleUserHooks = - emptyUserHooks { - confHook = configure, - postConf = finalChecks, - buildHook = defaultBuildHook, - replHook = defaultReplHook, - copyHook = \desc lbi _ f -> install desc lbi f, - -- 'install' has correct 'copy' behavior with params - testHook = defaultTestHook, - benchHook = defaultBenchHook, - instHook = defaultInstallHook, - cleanHook = \p _ _ f -> clean p f, - hscolourHook = \p l h f -> hscolour p l (allSuffixHandlers h) f, - haddockHook = \p l h f -> haddock p l (allSuffixHandlers h) f, - doctestHook = \p l h f -> doctest p l (allSuffixHandlers h) f, - regHook = defaultRegHook, - unregHook = \p l _ f -> unregister p l f - } - where - finalChecks _args flags pkg_descr lbi = - checkForeignDeps pkg_descr lbi (lessVerbose verbosity) - where - verbosity = fromFlag (configVerbosity flags) - --- | Basic autoconf 'UserHooks': --- --- * 'postConf' runs @.\/configure@, if present. --- --- * the pre-hooks 'preBuild', 'preClean', 'preCopy', 'preInst', --- 'preReg' and 'preUnreg' read additional build information from --- /package/@.buildinfo@, if present. --- --- Thus @configure@ can use local system information to generate --- /package/@.buildinfo@ and possibly other files. - -autoconfUserHooks :: UserHooks -autoconfUserHooks - = simpleUserHooks - { - postConf = defaultPostConf, - preBuild = readHookWithArgs buildVerbosity buildDistPref, -- buildCabalFilePath, - preCopy = readHookWithArgs copyVerbosity copyDistPref, - preClean = readHook cleanVerbosity cleanDistPref, - preInst = readHook installVerbosity installDistPref, - preHscolour = readHook hscolourVerbosity hscolourDistPref, - preHaddock = readHookWithArgs haddockVerbosity haddockDistPref, - preReg = readHook regVerbosity regDistPref, - preUnreg = readHook regVerbosity regDistPref - } - where defaultPostConf :: Args -> ConfigFlags -> PackageDescription - -> LocalBuildInfo -> IO () - defaultPostConf args flags pkg_descr lbi - = do let verbosity = fromFlag (configVerbosity flags) - baseDir lbi' = fromMaybe "" - (takeDirectory <$> cabalFilePath lbi') - confExists <- doesFileExist $ (baseDir lbi) "configure" - if confExists - then runConfigureScript verbosity - backwardsCompatHack flags lbi - else die' verbosity "configure script not found." - - pbi <- getHookedBuildInfo verbosity (buildDir lbi) - sanityCheckHookedBuildInfo verbosity pkg_descr pbi - let pkg_descr' = updatePackageDescription pbi pkg_descr - lbi' = lbi { localPkgDescr = pkg_descr' } - postConf simpleUserHooks args flags pkg_descr' lbi' - - backwardsCompatHack = False - - readHookWithArgs :: (a -> Flag Verbosity) - -> (a -> Flag FilePath) - -> Args -> a - -> IO HookedBuildInfo - readHookWithArgs get_verbosity get_dist_pref _ flags = do - dist_dir <- findDistPrefOrDefault (get_dist_pref flags) - getHookedBuildInfo verbosity (dist_dir "build") - where - verbosity = fromFlag (get_verbosity flags) - - readHook :: (a -> Flag Verbosity) - -> (a -> Flag FilePath) - -> Args -> a -> IO HookedBuildInfo - readHook get_verbosity get_dist_pref a flags = do - noExtraFlags a - dist_dir <- findDistPrefOrDefault (get_dist_pref flags) - getHookedBuildInfo verbosity (dist_dir "build") - where - verbosity = fromFlag (get_verbosity flags) - -runConfigureScript :: Verbosity -> Bool -> ConfigFlags -> LocalBuildInfo - -> IO () -runConfigureScript verbosity backwardsCompatHack flags lbi = do - env <- getEnvironment - let programDb = withPrograms lbi - (ccProg, ccFlags) <- configureCCompiler verbosity programDb - ccProgShort <- getShortPathName ccProg - -- The C compiler's compilation and linker flags (e.g. - -- "C compiler flags" and "Gcc Linker flags" from GHC) have already - -- been merged into ccFlags, so we set both CFLAGS and LDFLAGS - -- to ccFlags - -- We don't try and tell configure which ld to use, as we don't have - -- a way to pass its flags too - configureFile <- makeAbsolute $ - fromMaybe "." (takeDirectory <$> cabalFilePath lbi) "configure" - -- autoconf is fussy about filenames, and has a set of forbidden - -- characters that can't appear in the build directory, etc: - -- https://www.gnu.org/software/autoconf/manual/autoconf.html#File-System-Conventions - -- - -- This has caused hard-to-debug failures in the past (#5368), so we - -- detect some cases early and warn with a clear message. Windows's - -- use of backslashes is problematic here, so we'll switch to - -- slashes, but we do still want to fail on backslashes in POSIX - -- paths. - -- - -- TODO: We don't check for colons, tildes or leading dashes. We - -- also should check the builddir's path, destdir, and all other - -- paths as well. - let configureFile' = intercalate "/" $ splitDirectories configureFile - for_ badAutoconfCharacters $ \(c, cname) -> - when (c `elem` dropDrive configureFile') $ - warn verbosity $ concat - [ "The path to the './configure' script, '", configureFile' - , "', contains the character '", [c], "' (", cname, ")." - , " This may cause the script to fail with an obscure error, or for" - , " building the package to fail later." - ] - - let extraPath = fromNubList $ configProgramPathExtra flags - let cflagsEnv = maybe (unwords ccFlags) (++ (" " ++ unwords ccFlags)) - $ lookup "CFLAGS" env - spSep = [searchPathSeparator] - pathEnv = maybe (intercalate spSep extraPath) - ((intercalate spSep extraPath ++ spSep)++) $ lookup "PATH" env - overEnv = ("CFLAGS", Just cflagsEnv) : - [("PATH", Just pathEnv) | not (null extraPath)] - hp = hostPlatform lbi - maybeHostFlag = if hp == buildPlatform then [] else ["--host=" ++ show (pretty hp)] - args' = configureFile':args ++ ["CC=" ++ ccProgShort] ++ maybeHostFlag - shProg = simpleProgram "sh" - progDb = modifyProgramSearchPath - (\p -> map ProgramSearchPathDir extraPath ++ p) emptyProgramDb - shConfiguredProg <- lookupProgram shProg - `fmap` configureProgram verbosity shProg progDb - case shConfiguredProg of - Just sh -> runProgramInvocation verbosity $ - (programInvocation (sh {programOverrideEnv = overEnv}) args') - { progInvokeCwd = Just (buildDir lbi) } - Nothing -> die' verbosity notFoundMsg - where - args = configureArgs backwardsCompatHack flags - - notFoundMsg = "The package has a './configure' script. " - ++ "If you are on Windows, This requires a " - ++ "Unix compatibility toolchain such as MinGW+MSYS or Cygwin. " - ++ "If you are not on Windows, ensure that an 'sh' command " - ++ "is discoverable in your path." - -badAutoconfCharacters :: [(Char, String)] -badAutoconfCharacters = - [ (' ', "space") - , ('\t', "tab") - , ('\n', "newline") - , ('\0', "null") - , ('"', "double quote") - , ('#', "hash") - , ('$', "dollar sign") - , ('&', "ampersand") - , ('\'', "single quote") - , ('(', "left bracket") - , (')', "right bracket") - , ('*', "star") - , (';', "semicolon") - , ('<', "less-than sign") - , ('=', "equals sign") - , ('>', "greater-than sign") - , ('?', "question mark") - , ('[', "left square bracket") - , ('\\', "backslash") - , ('`', "backtick") - , ('|', "pipe") - ] - -getHookedBuildInfo :: Verbosity -> FilePath -> IO HookedBuildInfo -getHookedBuildInfo verbosity build_dir = do - maybe_infoFile <- findHookedPackageDesc verbosity build_dir - case maybe_infoFile of - Nothing -> return emptyHookedBuildInfo - Just infoFile -> do - info verbosity $ "Reading parameters from " ++ infoFile - readHookedBuildInfo verbosity infoFile - -defaultTestHook :: Args -> PackageDescription -> LocalBuildInfo - -> UserHooks -> TestFlags -> IO () -defaultTestHook args pkg_descr localbuildinfo _ flags = - test args pkg_descr localbuildinfo flags - -defaultBenchHook :: Args -> PackageDescription -> LocalBuildInfo - -> UserHooks -> BenchmarkFlags -> IO () -defaultBenchHook args pkg_descr localbuildinfo _ flags = - bench args pkg_descr localbuildinfo flags - -defaultInstallHook :: PackageDescription -> LocalBuildInfo - -> UserHooks -> InstallFlags -> IO () -defaultInstallHook pkg_descr localbuildinfo _ flags = do - let copyFlags = defaultCopyFlags { - copyDistPref = installDistPref flags, - copyDest = installDest flags, - copyVerbosity = installVerbosity flags - } - install pkg_descr localbuildinfo copyFlags - let registerFlags = defaultRegisterFlags { - regDistPref = installDistPref flags, - regInPlace = installInPlace flags, - regPackageDB = installPackageDB flags, - regVerbosity = installVerbosity flags - } - when (hasLibs pkg_descr) $ register pkg_descr localbuildinfo registerFlags - -defaultBuildHook :: PackageDescription -> LocalBuildInfo - -> UserHooks -> BuildFlags -> IO () -defaultBuildHook pkg_descr localbuildinfo hooks flags = - build pkg_descr localbuildinfo flags (allSuffixHandlers hooks) - -defaultReplHook :: PackageDescription -> LocalBuildInfo - -> UserHooks -> ReplFlags -> [String] -> IO () -defaultReplHook pkg_descr localbuildinfo hooks flags args = - repl pkg_descr localbuildinfo flags (allSuffixHandlers hooks) args - -defaultRegHook :: PackageDescription -> LocalBuildInfo - -> UserHooks -> RegisterFlags -> IO () -defaultRegHook pkg_descr localbuildinfo _ flags = - if hasLibs pkg_descr - then register pkg_descr localbuildinfo flags - else setupMessage (fromFlag (regVerbosity flags)) - "Package contains no library to register:" (packageId pkg_descr) diff --git a/cabal/Cabal/Distribution/Simple/Bench.hs b/cabal/Cabal/Distribution/Simple/Bench.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/Bench.hs +++ /dev/null @@ -1,125 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Bench --- Copyright : Johan Tibell 2011 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This is the entry point into running the benchmarks in a built --- package. It performs the \"@.\/setup bench@\" action. It runs --- benchmarks designated in the package description. - -module Distribution.Simple.Bench - ( bench - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Types.UnqualComponentName -import qualified Distribution.PackageDescription as PD -import Distribution.Simple.BuildPaths -import Distribution.Simple.Compiler -import Distribution.Simple.InstallDirs -import qualified Distribution.Simple.LocalBuildInfo as LBI -import Distribution.Simple.Setup -import Distribution.Simple.UserHooks -import Distribution.Simple.Utils -import Distribution.Pretty - -import System.Directory ( doesFileExist ) -import System.FilePath ( (), (<.>) ) - --- | Perform the \"@.\/setup bench@\" action. -bench :: Args -- ^positional command-line arguments - -> PD.PackageDescription -- ^information from the .cabal file - -> LBI.LocalBuildInfo -- ^information from the configure step - -> BenchmarkFlags -- ^flags sent to benchmark - -> IO () -bench args pkg_descr lbi flags = do - let verbosity = fromFlag $ benchmarkVerbosity flags - benchmarkNames = args - pkgBenchmarks = PD.benchmarks pkg_descr - enabledBenchmarks = map fst (LBI.enabledBenchLBIs pkg_descr lbi) - - -- Run the benchmark - doBench :: PD.Benchmark -> IO ExitCode - doBench bm = - case PD.benchmarkInterface bm of - PD.BenchmarkExeV10 _ _ -> do - let cmd = LBI.buildDir lbi name name <.> exeExtension (LBI.hostPlatform lbi) - options = map (benchOption pkg_descr lbi bm) $ - benchmarkOptions flags - -- Check that the benchmark executable exists. - exists <- doesFileExist cmd - unless exists $ die' verbosity $ - "Error: Could not find benchmark program \"" - ++ cmd ++ "\". Did you build the package first?" - - notice verbosity $ startMessage name - -- This will redirect the child process - -- stdout/stderr to the parent process. - exitcode <- rawSystemExitCode verbosity cmd options - notice verbosity $ finishMessage name exitcode - return exitcode - - _ -> do - notice verbosity $ "No support for running " - ++ "benchmark " ++ name ++ " of type: " - ++ prettyShow (PD.benchmarkType bm) - exitFailure - where name = unUnqualComponentName $ PD.benchmarkName bm - - unless (PD.hasBenchmarks pkg_descr) $ do - notice verbosity "Package has no benchmarks." - exitSuccess - - when (PD.hasBenchmarks pkg_descr && null enabledBenchmarks) $ - die' verbosity $ "No benchmarks enabled. Did you remember to configure with " - ++ "\'--enable-benchmarks\'?" - - bmsToRun <- case benchmarkNames of - [] -> return enabledBenchmarks - names -> for names $ \bmName -> - let benchmarkMap = zip enabledNames enabledBenchmarks - enabledNames = map PD.benchmarkName enabledBenchmarks - allNames = map PD.benchmarkName pkgBenchmarks - in case lookup (mkUnqualComponentName bmName) benchmarkMap of - Just t -> return t - _ | mkUnqualComponentName bmName `elem` allNames -> - die' verbosity $ "Package configured with benchmark " - ++ bmName ++ " disabled." - | otherwise -> die' verbosity $ "no such benchmark: " ++ bmName - - let totalBenchmarks = length bmsToRun - notice verbosity $ "Running " ++ show totalBenchmarks ++ " benchmarks..." - exitcodes <- traverse doBench bmsToRun - let allOk = totalBenchmarks == length (filter (== ExitSuccess) exitcodes) - unless allOk exitFailure - where - startMessage name = "Benchmark " ++ name ++ ": RUNNING...\n" - finishMessage name exitcode = "Benchmark " ++ name ++ ": " - ++ (case exitcode of - ExitSuccess -> "FINISH" - ExitFailure _ -> "ERROR") - - --- TODO: This is abusing the notion of a 'PathTemplate'. The result isn't --- necessarily a path. -benchOption :: PD.PackageDescription - -> LBI.LocalBuildInfo - -> PD.Benchmark - -> PathTemplate - -> String -benchOption pkg_descr lbi bm template = - fromPathTemplate $ substPathTemplate env template - where - env = initialPathTemplateEnv - (PD.package pkg_descr) (LBI.localUnitId lbi) - (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) ++ - [(BenchmarkNameVar, toPathTemplate $ unUnqualComponentName $ PD.benchmarkName bm)] diff --git a/cabal/Cabal/Distribution/Simple/Build.hs b/cabal/Cabal/Distribution/Simple/Build.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/Build.hs +++ /dev/null @@ -1,733 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Build --- Copyright : Isaac Jones 2003-2005, --- Ross Paterson 2006, --- Duncan Coutts 2007-2008, 2012 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This is the entry point to actually building the modules in a package. It --- doesn't actually do much itself, most of the work is delegated to --- compiler-specific actions. It does do some non-compiler specific bits like --- running pre-processors. --- - -module Distribution.Simple.Build ( - build, showBuildInfo, repl, - startInterpreter, - - initialBuildSteps, - createInternalPackageDB, - componentInitialBuildSteps, - writeAutogenFiles, - ) where - -import Prelude () -import Distribution.Compat.Prelude -import Distribution.Utils.Generic - -import Distribution.Types.ComponentLocalBuildInfo -import Distribution.Types.ComponentRequestedSpec -import Distribution.Types.Dependency -import Distribution.Types.ExecutableScope -import Distribution.Types.ForeignLib -import Distribution.Types.LibraryVisibility -import Distribution.Types.LocalBuildInfo -import Distribution.Types.MungedPackageId -import Distribution.Types.MungedPackageName -import Distribution.Types.ModuleRenaming -import Distribution.Types.TargetInfo - -import Distribution.Package -import Distribution.Backpack -import Distribution.Backpack.DescribeUnitId -import qualified Distribution.Simple.GHC as GHC -import qualified Distribution.Simple.GHCJS as GHCJS -import qualified Distribution.Simple.UHC as UHC -import qualified Distribution.Simple.HaskellSuite as HaskellSuite -import qualified Distribution.Simple.PackageIndex as Index - -import Distribution.Simple.Build.Macros (generateCabalMacrosHeader) -import Distribution.Simple.Build.PathsModule (generatePathsModule) -import qualified Distribution.Simple.Program.HcPkg as HcPkg - -import Distribution.Simple.Compiler -import Distribution.PackageDescription -import qualified Distribution.InstalledPackageInfo as IPI -import Distribution.InstalledPackageInfo (InstalledPackageInfo) -import qualified Distribution.ModuleName as ModuleName - -import Distribution.Simple.Setup -import Distribution.Simple.BuildTarget -import Distribution.Simple.BuildToolDepends -import Distribution.Simple.PreProcess -import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.Program.Types -import Distribution.Simple.Program.Db -import Distribution.Simple.ShowBuildInfo -import Distribution.Simple.BuildPaths -import Distribution.Simple.Configure -import Distribution.Simple.Register -import Distribution.Simple.Test.LibV09 -import Distribution.Simple.Utils -import Distribution.Simple.Utils.Json - -import Distribution.System -import Distribution.Pretty -import Distribution.Verbosity -import Distribution.Version (thisVersion) - -import Distribution.Compat.Graph (IsNode(..)) - -import Control.Monad -import qualified Data.Set as Set -import System.FilePath ( (), (<.>), takeDirectory ) -import System.Directory ( getCurrentDirectory ) - --- ----------------------------------------------------------------------------- --- |Build the libraries and executables in this package. - -build :: PackageDescription -- ^ Mostly information from the .cabal file - -> LocalBuildInfo -- ^ Configuration information - -> BuildFlags -- ^ Flags that the user passed to build - -> [ PPSuffixHandler ] -- ^ preprocessors to run before compiling - -> IO () -build pkg_descr lbi flags suffixes = do - targets <- readTargetInfos verbosity pkg_descr lbi (buildArgs flags) - let componentsToBuild = neededTargetsInBuildOrder' pkg_descr lbi (map nodeKey targets) - info verbosity $ "Component build order: " - ++ intercalate ", " - (map (showComponentName . componentLocalName . targetCLBI) - componentsToBuild) - - when (null targets) $ - -- Only bother with this message if we're building the whole package - setupMessage verbosity "Building" (packageId pkg_descr) - - internalPackageDB <- createInternalPackageDB verbosity lbi distPref - - (\f -> foldM_ f (installedPkgs lbi) componentsToBuild) $ \index target -> do - let comp = targetComponent target - clbi = targetCLBI target - componentInitialBuildSteps distPref pkg_descr lbi clbi verbosity - let bi = componentBuildInfo comp - progs' = addInternalBuildTools pkg_descr lbi bi (withPrograms lbi) - lbi' = lbi { - withPrograms = progs', - withPackageDB = withPackageDB lbi ++ [internalPackageDB], - installedPkgs = index - } - mb_ipi <- buildComponent verbosity (buildNumJobs flags) pkg_descr - lbi' suffixes comp clbi distPref - return (maybe index (Index.insert `flip` index) mb_ipi) - return () - where - distPref = fromFlag (buildDistPref flags) - verbosity = fromFlag (buildVerbosity flags) - - -showBuildInfo :: PackageDescription -- ^ Mostly information from the .cabal file - -> LocalBuildInfo -- ^ Configuration information - -> BuildFlags -- ^ Flags that the user passed to build - -> IO String -showBuildInfo pkg_descr lbi flags = do - let verbosity = fromFlag (buildVerbosity flags) - targets <- readTargetInfos verbosity pkg_descr lbi (buildArgs flags) - let targetsToBuild = neededTargetsInBuildOrder' pkg_descr lbi (map nodeKey targets) - doc = mkBuildInfo pkg_descr lbi flags targetsToBuild - return $ renderJson doc "" - - -repl :: PackageDescription -- ^ Mostly information from the .cabal file - -> LocalBuildInfo -- ^ Configuration information - -> ReplFlags -- ^ Flags that the user passed to build - -> [ PPSuffixHandler ] -- ^ preprocessors to run before compiling - -> [String] - -> IO () -repl pkg_descr lbi flags suffixes args = do - let distPref = fromFlag (replDistPref flags) - verbosity = fromFlag (replVerbosity flags) - - target <- readTargetInfos verbosity pkg_descr lbi args >>= \r -> case r of - -- This seems DEEPLY questionable. - [] -> case allTargetsInBuildOrder' pkg_descr lbi of - (target:_) -> return target - [] -> die' verbosity $ "Failed to determine target." - [target] -> return target - _ -> die' verbosity $ "The 'repl' command does not support multiple targets at once." - let componentsToBuild = neededTargetsInBuildOrder' pkg_descr lbi [nodeKey target] - debug verbosity $ "Component build order: " - ++ intercalate ", " - (map (showComponentName . componentLocalName . targetCLBI) - componentsToBuild) - - internalPackageDB <- createInternalPackageDB verbosity lbi distPref - - let lbiForComponent comp lbi' = - lbi' { - withPackageDB = withPackageDB lbi ++ [internalPackageDB], - withPrograms = addInternalBuildTools pkg_descr lbi' - (componentBuildInfo comp) (withPrograms lbi') - } - - -- build any dependent components - sequence_ - [ do let clbi = targetCLBI subtarget - comp = targetComponent subtarget - lbi' = lbiForComponent comp lbi - componentInitialBuildSteps distPref pkg_descr lbi clbi verbosity - buildComponent verbosity NoFlag - pkg_descr lbi' suffixes comp clbi distPref - | subtarget <- safeInit componentsToBuild ] - - -- REPL for target components - let clbi = targetCLBI target - comp = targetComponent target - lbi' = lbiForComponent comp lbi - replFlags = replReplOptions flags - componentInitialBuildSteps distPref pkg_descr lbi clbi verbosity - replComponent replFlags verbosity pkg_descr lbi' suffixes comp clbi distPref - - --- | Start an interpreter without loading any package files. -startInterpreter :: Verbosity -> ProgramDb -> Compiler -> Platform - -> PackageDBStack -> IO () -startInterpreter verbosity programDb comp platform packageDBs = - case compilerFlavor comp of - GHC -> GHC.startInterpreter verbosity programDb comp platform packageDBs - GHCJS -> GHCJS.startInterpreter verbosity programDb comp platform packageDBs - _ -> die' verbosity "A REPL is not supported with this compiler." - -buildComponent :: Verbosity - -> Flag (Maybe Int) - -> PackageDescription - -> LocalBuildInfo - -> [PPSuffixHandler] - -> Component - -> ComponentLocalBuildInfo - -> FilePath - -> IO (Maybe InstalledPackageInfo) -buildComponent verbosity numJobs pkg_descr lbi suffixes - comp@(CLib lib) clbi distPref = do - preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras verbosity comp lbi - setupMessage' verbosity "Building" (packageId pkg_descr) - (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) - let libbi = libBuildInfo lib - lib' = lib { libBuildInfo = flip addExtraAsmSources extras - $ flip addExtraCmmSources extras - $ flip addExtraCxxSources extras - $ flip addExtraCSources extras - $ libbi - } - - buildLib verbosity numJobs pkg_descr lbi lib' clbi - - let oneComponentRequested (OneComponentRequestedSpec _) = True - oneComponentRequested _ = False - -- Don't register inplace if we're only building a single component; - -- it's not necessary because there won't be any subsequent builds - -- that need to tag us - if (not (oneComponentRequested (componentEnabledSpec lbi))) - then do - -- Register the library in-place, so exes can depend - -- on internally defined libraries. - pwd <- getCurrentDirectory - let -- The in place registration uses the "-inplace" suffix, not an ABI hash - installedPkgInfo = inplaceInstalledPackageInfo pwd distPref pkg_descr - -- NB: Use a fake ABI hash to avoid - -- needing to recompute it every build. - (mkAbiHash "inplace") lib' lbi clbi - - debug verbosity $ "Registering inplace:\n" ++ (IPI.showInstalledPackageInfo installedPkgInfo) - registerPackage verbosity (compiler lbi) (withPrograms lbi) - (withPackageDB lbi) installedPkgInfo - HcPkg.defaultRegisterOptions { - HcPkg.registerMultiInstance = True - } - return (Just installedPkgInfo) - else return Nothing - -buildComponent verbosity numJobs pkg_descr lbi suffixes - comp@(CFLib flib) clbi _distPref = do - preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - setupMessage' verbosity "Building" (packageId pkg_descr) - (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) - buildFLib verbosity numJobs pkg_descr lbi flib clbi - return Nothing - -buildComponent verbosity numJobs pkg_descr lbi suffixes - comp@(CExe exe) clbi _ = do - preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras verbosity comp lbi - setupMessage' verbosity "Building" (packageId pkg_descr) - (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) - let ebi = buildInfo exe - exe' = exe { buildInfo = addExtraCSources ebi extras } - buildExe verbosity numJobs pkg_descr lbi exe' clbi - return Nothing - - -buildComponent verbosity numJobs pkg_descr lbi suffixes - comp@(CTest test@TestSuite { testInterface = TestSuiteExeV10{} }) - clbi _distPref = do - let exe = testSuiteExeV10AsExe test - preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras verbosity comp lbi - setupMessage' verbosity "Building" (packageId pkg_descr) - (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) - let ebi = buildInfo exe - exe' = exe { buildInfo = addExtraCSources ebi extras } - buildExe verbosity numJobs pkg_descr lbi exe' clbi - return Nothing - - -buildComponent verbosity numJobs pkg_descr lbi0 suffixes - comp@(CTest - test@TestSuite { testInterface = TestSuiteLibV09{} }) - clbi -- This ComponentLocalBuildInfo corresponds to a detailed - -- test suite and not a real component. It should not - -- be used, except to construct the CLBIs for the - -- library and stub executable that will actually be - -- built. - distPref = do - pwd <- getCurrentDirectory - let (pkg, lib, libClbi, lbi, ipi, exe, exeClbi) = - testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 distPref pwd - preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras verbosity comp lbi - setupMessage' verbosity "Building" (packageId pkg_descr) - (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) - buildLib verbosity numJobs pkg lbi lib libClbi - -- NB: need to enable multiple instances here, because on 7.10+ - -- the package name is the same as the library, and we still - -- want the registration to go through. - registerPackage verbosity (compiler lbi) (withPrograms lbi) - (withPackageDB lbi) ipi - HcPkg.defaultRegisterOptions { - HcPkg.registerMultiInstance = True - } - let ebi = buildInfo exe - -- NB: The stub executable is linked against the test-library - -- which already contains all `other-modules`, so we need - -- to remove those from the stub-exe's build-info - exe' = exe { buildInfo = (addExtraCSources ebi extras) { otherModules = [] } } - buildExe verbosity numJobs pkg_descr lbi exe' exeClbi - return Nothing -- Can't depend on test suite - - -buildComponent verbosity _ _ _ _ - (CTest TestSuite { testInterface = TestSuiteUnsupported tt }) - _ _ = - die' verbosity $ "No support for building test suite type " ++ prettyShow tt - - -buildComponent verbosity numJobs pkg_descr lbi suffixes - comp@(CBench bm@Benchmark { benchmarkInterface = BenchmarkExeV10 {} }) - clbi _distPref = do - let exe = benchmarkExeV10asExe bm - preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras verbosity comp lbi - setupMessage' verbosity "Building" (packageId pkg_descr) - (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) - let ebi = buildInfo exe - exe' = exe { buildInfo = addExtraCSources ebi extras } - buildExe verbosity numJobs pkg_descr lbi exe' clbi - return Nothing - - -buildComponent verbosity _ _ _ _ - (CBench Benchmark { benchmarkInterface = BenchmarkUnsupported tt }) - _ _ = - die' verbosity $ "No support for building benchmark type " ++ prettyShow tt - - --- | Add extra C sources generated by preprocessing to build --- information. -addExtraCSources :: BuildInfo -> [FilePath] -> BuildInfo -addExtraCSources bi extras = bi { cSources = new } - where new = Set.toList $ old `Set.union` exs - old = Set.fromList $ cSources bi - exs = Set.fromList extras - - --- | Add extra C++ sources generated by preprocessing to build --- information. -addExtraCxxSources :: BuildInfo -> [FilePath] -> BuildInfo -addExtraCxxSources bi extras = bi { cxxSources = new } - where new = Set.toList $ old `Set.union` exs - old = Set.fromList $ cxxSources bi - exs = Set.fromList extras - - --- | Add extra C-- sources generated by preprocessing to build --- information. -addExtraCmmSources :: BuildInfo -> [FilePath] -> BuildInfo -addExtraCmmSources bi extras = bi { cmmSources = new } - where new = Set.toList $ old `Set.union` exs - old = Set.fromList $ cmmSources bi - exs = Set.fromList extras - - --- | Add extra ASM sources generated by preprocessing to build --- information. -addExtraAsmSources :: BuildInfo -> [FilePath] -> BuildInfo -addExtraAsmSources bi extras = bi { asmSources = new } - where new = Set.toList $ old `Set.union` exs - old = Set.fromList $ asmSources bi - exs = Set.fromList extras - - -replComponent :: [String] - -> Verbosity - -> PackageDescription - -> LocalBuildInfo - -> [PPSuffixHandler] - -> Component - -> ComponentLocalBuildInfo - -> FilePath - -> IO () -replComponent replFlags verbosity pkg_descr lbi suffixes - comp@(CLib lib) clbi _ = do - preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras verbosity comp lbi - let libbi = libBuildInfo lib - lib' = lib { libBuildInfo = libbi { cSources = cSources libbi ++ extras } } - replLib replFlags verbosity pkg_descr lbi lib' clbi - -replComponent replFlags verbosity pkg_descr lbi suffixes - comp@(CFLib flib) clbi _ = do - preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - replFLib replFlags verbosity pkg_descr lbi flib clbi - -replComponent replFlags verbosity pkg_descr lbi suffixes - comp@(CExe exe) clbi _ = do - preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras verbosity comp lbi - let ebi = buildInfo exe - exe' = exe { buildInfo = ebi { cSources = cSources ebi ++ extras } } - replExe replFlags verbosity pkg_descr lbi exe' clbi - - -replComponent replFlags verbosity pkg_descr lbi suffixes - comp@(CTest test@TestSuite { testInterface = TestSuiteExeV10{} }) - clbi _distPref = do - let exe = testSuiteExeV10AsExe test - preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras verbosity comp lbi - let ebi = buildInfo exe - exe' = exe { buildInfo = ebi { cSources = cSources ebi ++ extras } } - replExe replFlags verbosity pkg_descr lbi exe' clbi - - -replComponent replFlags verbosity pkg_descr lbi0 suffixes - comp@(CTest - test@TestSuite { testInterface = TestSuiteLibV09{} }) - clbi distPref = do - pwd <- getCurrentDirectory - let (pkg, lib, libClbi, lbi, _, _, _) = - testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 distPref pwd - preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras verbosity comp lbi - let libbi = libBuildInfo lib - lib' = lib { libBuildInfo = libbi { cSources = cSources libbi ++ extras } } - replLib replFlags verbosity pkg lbi lib' libClbi - - -replComponent _ verbosity _ _ _ - (CTest TestSuite { testInterface = TestSuiteUnsupported tt }) - _ _ = - die' verbosity $ "No support for building test suite type " ++ prettyShow tt - - -replComponent replFlags verbosity pkg_descr lbi suffixes - comp@(CBench bm@Benchmark { benchmarkInterface = BenchmarkExeV10 {} }) - clbi _distPref = do - let exe = benchmarkExeV10asExe bm - preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras verbosity comp lbi - let ebi = buildInfo exe - exe' = exe { buildInfo = ebi { cSources = cSources ebi ++ extras } } - replExe replFlags verbosity pkg_descr lbi exe' clbi - - -replComponent _ verbosity _ _ _ - (CBench Benchmark { benchmarkInterface = BenchmarkUnsupported tt }) - _ _ = - die' verbosity $ "No support for building benchmark type " ++ prettyShow tt - ----------------------------------------------------- --- Shared code for buildComponent and replComponent --- - --- | Translate a exe-style 'TestSuite' component into an exe for building -testSuiteExeV10AsExe :: TestSuite -> Executable -testSuiteExeV10AsExe test@TestSuite { testInterface = TestSuiteExeV10 _ mainFile } = - Executable { - exeName = testName test, - modulePath = mainFile, - exeScope = ExecutablePublic, - buildInfo = testBuildInfo test - } -testSuiteExeV10AsExe TestSuite{} = error "testSuiteExeV10AsExe: wrong kind" - --- | Translate a exe-style 'Benchmark' component into an exe for building -benchmarkExeV10asExe :: Benchmark -> Executable -benchmarkExeV10asExe bm@Benchmark { benchmarkInterface = BenchmarkExeV10 _ mainFile } = - Executable { - exeName = benchmarkName bm, - modulePath = mainFile, - exeScope = ExecutablePublic, - buildInfo = benchmarkBuildInfo bm - } -benchmarkExeV10asExe Benchmark{} = error "benchmarkExeV10asExe: wrong kind" - --- | Translate a lib-style 'TestSuite' component into a lib + exe for building -testSuiteLibV09AsLibAndExe :: PackageDescription - -> TestSuite - -> ComponentLocalBuildInfo - -> LocalBuildInfo - -> FilePath - -> FilePath - -> (PackageDescription, - Library, ComponentLocalBuildInfo, - LocalBuildInfo, - IPI.InstalledPackageInfo, - Executable, ComponentLocalBuildInfo) -testSuiteLibV09AsLibAndExe pkg_descr - test@TestSuite { testInterface = TestSuiteLibV09 _ m } - clbi lbi distPref pwd = - (pkg, lib, libClbi, lbi, ipi, exe, exeClbi) - where - bi = testBuildInfo test - lib = Library { - libName = LMainLibName, - exposedModules = [ m ], - reexportedModules = [], - signatures = [], - libExposed = True, - libVisibility = LibraryVisibilityPrivate, - libBuildInfo = bi - } - -- This is, like, the one place where we use a CTestName for a library. - -- Should NOT use library name, since that could conflict! - PackageIdentifier pkg_name pkg_ver = package pkg_descr - -- Note: we do make internal library from the test! - compat_name = MungedPackageName pkg_name (LSubLibName (testName test)) - compat_key = computeCompatPackageKey (compiler lbi) compat_name pkg_ver (componentUnitId clbi) - libClbi = LibComponentLocalBuildInfo - { componentPackageDeps = componentPackageDeps clbi - , componentInternalDeps = componentInternalDeps clbi - , componentIsIndefinite_ = False - , componentExeDeps = componentExeDeps clbi - , componentLocalName = CLibName $ LSubLibName $ testName test - , componentIsPublic = False - , componentIncludes = componentIncludes clbi - , componentUnitId = componentUnitId clbi - , componentComponentId = componentComponentId clbi - , componentInstantiatedWith = [] - , componentCompatPackageName = compat_name - , componentCompatPackageKey = compat_key - , componentExposedModules = [IPI.ExposedModule m Nothing] - } - pkgName' = mkPackageName $ prettyShow compat_name - pkg = pkg_descr { - package = (package pkg_descr) { pkgName = pkgName' } - , executables = [] - , testSuites = [] - , subLibraries = [lib] - } - ipi = inplaceInstalledPackageInfo pwd distPref pkg (mkAbiHash "") lib lbi libClbi - testDir = buildDir lbi stubName test - stubName test ++ "-tmp" - testLibDep = Dependency - pkgName' - (thisVersion $ pkgVersion $ package pkg_descr) - mainLibSet - exe = Executable { - exeName = mkUnqualComponentName $ stubName test, - modulePath = stubFilePath test, - exeScope = ExecutablePublic, - buildInfo = (testBuildInfo test) { - hsSourceDirs = [ testDir ], - targetBuildDepends = testLibDep - : (targetBuildDepends $ testBuildInfo test) - } - } - -- | The stub executable needs a new 'ComponentLocalBuildInfo' - -- that exposes the relevant test suite library. - deps = (IPI.installedUnitId ipi, mungedId ipi) - : (filter (\(_, x) -> let name = prettyShow $ mungedName x - in name == "Cabal" || name == "base") - (componentPackageDeps clbi)) - exeClbi = ExeComponentLocalBuildInfo { - -- TODO: this is a hack, but as long as this is unique - -- (doesn't clobber something) we won't run into trouble - componentUnitId = mkUnitId (stubName test), - componentComponentId = mkComponentId (stubName test), - componentInternalDeps = [componentUnitId clbi], - componentExeDeps = [], - componentLocalName = CExeName $ mkUnqualComponentName $ stubName test, - componentPackageDeps = deps, - -- Assert DefUnitId invariant! - -- Executable can't be indefinite, so dependencies must - -- be definite packages. - componentIncludes = zip (map (DefiniteUnitId . unsafeMkDefUnitId . fst) deps) - (repeat defaultRenaming) - } -testSuiteLibV09AsLibAndExe _ TestSuite{} _ _ _ _ = error "testSuiteLibV09AsLibAndExe: wrong kind" - - --- | Initialize a new package db file for libraries defined --- internally to the package. -createInternalPackageDB :: Verbosity -> LocalBuildInfo -> FilePath - -> IO PackageDB -createInternalPackageDB verbosity lbi distPref = do - existsAlready <- doesPackageDBExist dbPath - when existsAlready $ deletePackageDB dbPath - createPackageDB verbosity (compiler lbi) (withPrograms lbi) False dbPath - return (SpecificPackageDB dbPath) - where - dbPath = internalPackageDBPath lbi distPref - -addInternalBuildTools :: PackageDescription -> LocalBuildInfo -> BuildInfo - -> ProgramDb -> ProgramDb -addInternalBuildTools pkg lbi bi progs = - foldr updateProgram progs internalBuildTools - where - internalBuildTools = - [ simpleConfiguredProgram toolName' (FoundOnSystem toolLocation) - | toolName <- getAllInternalToolDependencies pkg bi - , let toolName' = unUnqualComponentName toolName - , let toolLocation = buildDir lbi toolName' toolName' <.> exeExtension (hostPlatform lbi) ] - - --- TODO: build separate libs in separate dirs so that we can build --- multiple libs, e.g. for 'LibTest' library-style test suites -buildLib :: Verbosity -> Flag (Maybe Int) - -> PackageDescription -> LocalBuildInfo - -> Library -> ComponentLocalBuildInfo -> IO () -buildLib verbosity numJobs pkg_descr lbi lib clbi = - case compilerFlavor (compiler lbi) of - GHC -> GHC.buildLib verbosity numJobs pkg_descr lbi lib clbi - GHCJS -> GHCJS.buildLib verbosity numJobs pkg_descr lbi lib clbi - UHC -> UHC.buildLib verbosity pkg_descr lbi lib clbi - HaskellSuite {} -> HaskellSuite.buildLib verbosity pkg_descr lbi lib clbi - _ -> die' verbosity "Building is not supported with this compiler." - --- | Build a foreign library --- --- NOTE: We assume that we already checked that we can actually build the --- foreign library in configure. -buildFLib :: Verbosity -> Flag (Maybe Int) - -> PackageDescription -> LocalBuildInfo - -> ForeignLib -> ComponentLocalBuildInfo -> IO () -buildFLib verbosity numJobs pkg_descr lbi flib clbi = - case compilerFlavor (compiler lbi) of - GHC -> GHC.buildFLib verbosity numJobs pkg_descr lbi flib clbi - _ -> die' verbosity "Building is not supported with this compiler." - -buildExe :: Verbosity -> Flag (Maybe Int) - -> PackageDescription -> LocalBuildInfo - -> Executable -> ComponentLocalBuildInfo -> IO () -buildExe verbosity numJobs pkg_descr lbi exe clbi = - case compilerFlavor (compiler lbi) of - GHC -> GHC.buildExe verbosity numJobs pkg_descr lbi exe clbi - GHCJS -> GHCJS.buildExe verbosity numJobs pkg_descr lbi exe clbi - UHC -> UHC.buildExe verbosity pkg_descr lbi exe clbi - _ -> die' verbosity "Building is not supported with this compiler." - -replLib :: [String] -> Verbosity -> PackageDescription - -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo - -> IO () -replLib replFlags verbosity pkg_descr lbi lib clbi = - case compilerFlavor (compiler lbi) of - -- 'cabal repl' doesn't need to support 'ghc --make -j', so we just pass - -- NoFlag as the numJobs parameter. - GHC -> GHC.replLib replFlags verbosity NoFlag pkg_descr lbi lib clbi - GHCJS -> GHCJS.replLib replFlags verbosity NoFlag pkg_descr lbi lib clbi - _ -> die' verbosity "A REPL is not supported for this compiler." - -replExe :: [String] -> Verbosity -> PackageDescription - -> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo - -> IO () -replExe replFlags verbosity pkg_descr lbi exe clbi = - case compilerFlavor (compiler lbi) of - GHC -> GHC.replExe replFlags verbosity NoFlag pkg_descr lbi exe clbi - GHCJS -> GHCJS.replExe replFlags verbosity NoFlag pkg_descr lbi exe clbi - _ -> die' verbosity "A REPL is not supported for this compiler." - -replFLib :: [String] -> Verbosity -> PackageDescription - -> LocalBuildInfo -> ForeignLib -> ComponentLocalBuildInfo - -> IO () -replFLib replFlags verbosity pkg_descr lbi exe clbi = - case compilerFlavor (compiler lbi) of - GHC -> GHC.replFLib replFlags verbosity NoFlag pkg_descr lbi exe clbi - _ -> die' verbosity "A REPL is not supported for this compiler." - --- | Runs 'componentInitialBuildSteps' on every configured component. -initialBuildSteps :: FilePath -- ^"dist" prefix - -> PackageDescription -- ^mostly information from the .cabal file - -> LocalBuildInfo -- ^Configuration information - -> Verbosity -- ^The verbosity to use - -> IO () -initialBuildSteps distPref pkg_descr lbi verbosity = - withAllComponentsInBuildOrder pkg_descr lbi $ \_comp clbi -> - componentInitialBuildSteps distPref pkg_descr lbi clbi verbosity - --- | Creates the autogenerated files for a particular configured component. -componentInitialBuildSteps :: FilePath -- ^"dist" prefix - -> PackageDescription -- ^mostly information from the .cabal file - -> LocalBuildInfo -- ^Configuration information - -> ComponentLocalBuildInfo - -> Verbosity -- ^The verbosity to use - -> IO () -componentInitialBuildSteps _distPref pkg_descr lbi clbi verbosity = do - createDirectoryIfMissingVerbose verbosity True (componentBuildDir lbi clbi) - - writeAutogenFiles verbosity pkg_descr lbi clbi - --- | Generate and write out the Paths_.hs and cabal_macros.h files --- -writeAutogenFiles :: Verbosity - -> PackageDescription - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> IO () -writeAutogenFiles verbosity pkg lbi clbi = do - createDirectoryIfMissingVerbose verbosity True (autogenComponentModulesDir lbi clbi) - - let pathsModulePath = autogenComponentModulesDir lbi clbi - ModuleName.toFilePath (autogenPathsModuleName pkg) <.> "hs" - pathsModuleDir = takeDirectory pathsModulePath - -- Ensure that the directory exists! - createDirectoryIfMissingVerbose verbosity True pathsModuleDir - rewriteFileEx verbosity pathsModulePath (generatePathsModule pkg lbi clbi) - - --TODO: document what we're doing here, and move it to its own function - case clbi of - LibComponentLocalBuildInfo { componentInstantiatedWith = insts } -> - -- Write out empty hsig files for all requirements, so that GHC - -- has a source file to look at it when it needs to typecheck - -- a signature. It's harmless to write these out even when - -- there is a real hsig file written by the user, since - -- include path ordering ensures that the real hsig file - -- will always be picked up before the autogenerated one. - for_ (map fst insts) $ \mod_name -> do - let sigPath = autogenComponentModulesDir lbi clbi - ModuleName.toFilePath mod_name <.> "hsig" - createDirectoryIfMissingVerbose verbosity True (takeDirectory sigPath) - rewriteFileEx verbosity sigPath $ - "{-# OPTIONS_GHC -w #-}\n" ++ - "{-# LANGUAGE NoImplicitPrelude #-}\n" ++ - "signature " ++ prettyShow mod_name ++ " where" - _ -> return () - - let cppHeaderPath = autogenComponentModulesDir lbi clbi cppHeaderName - rewriteFileEx verbosity cppHeaderPath (generateCabalMacrosHeader pkg lbi clbi) diff --git a/cabal/Cabal/Distribution/Simple/Build/Macros.hs b/cabal/Cabal/Distribution/Simple/Build/Macros.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/Build/Macros.hs +++ /dev/null @@ -1,110 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Build.Macros --- Copyright : Simon Marlow 2008 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Generate cabal_macros.h - CPP macros for package version testing --- --- When using CPP you get --- --- > VERSION_ --- > MIN_VERSION_(A,B,C) --- --- for each /package/ in @build-depends@, which is true if the version of --- /package/ in use is @>= A.B.C@, using the normal ordering on version --- numbers. --- --- TODO Figure out what to do about backpack and internal libraries. It is very --- suspecious that this stuff works with munged package identifiers -module Distribution.Simple.Build.Macros ( - generateCabalMacrosHeader, - generatePackageVersionMacros, - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Version -import Distribution.PackageDescription -import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.Program.Db -import Distribution.Simple.Program.Types -import Distribution.Types.MungedPackageId -import Distribution.Types.MungedPackageName -import Distribution.Pretty - -import qualified Distribution.Simple.Build.Macros.Z as Z - --- | The contents of the @cabal_macros.h@ for the given configured package. --- -generateCabalMacrosHeader :: PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> String -generateCabalMacrosHeader pkg_descr lbi clbi = Z.render Z.Z - { Z.zPackages = map mkZPackage $ package pkg_descr : map getPid (componentPackageDeps clbi) - , Z.zTools = - [ Z.ZTool - { Z.ztoolName = programId prog - , Z.ztoolVersion = ver - , Z.ztoolX = major1 - , Z.ztoolY = major2 - , Z.ztoolZ = minor - } - | prog <- configuredPrograms $ withPrograms lbi - , ver <- maybeToList (programVersion prog) - , let (major1,major2,minor) = majorMinor ver - ] - , Z.zPackageKey = case clbi of - LibComponentLocalBuildInfo{} -> componentCompatPackageKey clbi - _ -> "" - , Z.zComponentId = prettyShow (componentComponentId clbi) - , Z.zPackageVersion = pkgVersion (package pkg_descr) - , Z.zNotNull = not . null - , Z.zManglePkgName = map fixchar . unPackageName - , Z.zMangleStr = map fixchar - } - where - getPid (_, MungedPackageId (MungedPackageName pn _) v) = - -- NB: Drop the library name! We're just reporting package versions. - -- This would have to be revisited if you are allowed to depend - -- on different versions of the same package - PackageIdentifier pn v - --- | Helper function that generates just the @VERSION_pkg@ and @MIN_VERSION_pkg@ --- macros for a list of package ids (usually used with the specific deps of --- a configured package). --- -generatePackageVersionMacros :: Version -> [PackageId] -> String -generatePackageVersionMacros ver pkgids = Z.render Z.Z - { Z.zPackages = map mkZPackage pkgids - , Z.zTools = [] - , Z.zPackageKey = "" - , Z.zComponentId = "" - , Z.zPackageVersion = ver - , Z.zNotNull = not . null - , Z.zManglePkgName = map fixchar . unPackageName - , Z.zMangleStr = map fixchar - } - -mkZPackage :: PackageId -> Z.ZPackage -mkZPackage (PackageIdentifier name ver) = Z.ZPackage - { Z.zpkgName = name - , Z.zpkgVersion = ver - , Z.zpkgX = major1 - , Z.zpkgY = major2 - , Z.zpkgZ = minor - } - where - (major1,major2,minor) = majorMinor ver - -majorMinor :: Version -> (String, String, String) -majorMinor ver = case map show (versionNumbers ver) of - [] -> ("0", "0", "0") - [x] -> (x, "0", "0") - [x,y] -> (x, y, "0") - (x:y:z:_) -> (x, y, z) - -fixchar :: Char -> Char -fixchar '-' = '_' -fixchar c = c diff --git a/cabal/Cabal/Distribution/Simple/Build/Macros/Z.hs b/cabal/Cabal/Distribution/Simple/Build/Macros/Z.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/Build/Macros/Z.hs +++ /dev/null @@ -1,140 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Simple.Build.Macros.Z (render, Z(..), ZPackage (..), ZTool (..)) where -import Distribution.ZinzaPrelude -data Z - = Z {zPackages :: ([ZPackage]), - zTools :: ([ZTool]), - zPackageKey :: String, - zComponentId :: String, - zPackageVersion :: Version, - zNotNull :: (String -> Bool), - zManglePkgName :: (PackageName -> String), - zMangleStr :: (String -> String)} - deriving Generic -data ZPackage - = ZPackage {zpkgName :: PackageName, - zpkgVersion :: Version, - zpkgX :: String, - zpkgY :: String, - zpkgZ :: String} - deriving Generic -data ZTool - = ZTool {ztoolName :: String, - ztoolVersion :: Version, - ztoolX :: String, - ztoolY :: String, - ztoolZ :: String} - deriving Generic -render :: Z -> String -render z_root = execWriter $ do - tell "/* DO NOT EDIT: This file is automatically generated by Cabal */\n" - tell "\n" - forM_ (zPackages z_root) $ \z_var0_pkg -> do - tell "/* package " - tell (prettyShow (zpkgName z_var0_pkg)) - tell "-" - tell (prettyShow (zpkgVersion z_var0_pkg)) - tell " */\n" - tell "#ifndef VERSION_" - tell (zManglePkgName z_root (zpkgName z_var0_pkg)) - tell "\n" - tell "#define VERSION_" - tell (zManglePkgName z_root (zpkgName z_var0_pkg)) - tell " \"" - tell (prettyShow (zpkgVersion z_var0_pkg)) - tell "\"\n" - tell "#endif /* VERSION_" - tell (zManglePkgName z_root (zpkgName z_var0_pkg)) - tell " */\n" - tell "#ifndef MIN_VERSION_" - tell (zManglePkgName z_root (zpkgName z_var0_pkg)) - tell "\n" - tell "#define MIN_VERSION_" - tell (zManglePkgName z_root (zpkgName z_var0_pkg)) - tell "(major1,major2,minor) (\\\n" - tell " (major1) < " - tell (zpkgX z_var0_pkg) - tell " || \\\n" - tell " (major1) == " - tell (zpkgX z_var0_pkg) - tell " && (major2) < " - tell (zpkgY z_var0_pkg) - tell " || \\\n" - tell " (major1) == " - tell (zpkgX z_var0_pkg) - tell " && (major2) == " - tell (zpkgY z_var0_pkg) - tell " && (minor) <= " - tell (zpkgZ z_var0_pkg) - tell ")\n" - tell "#endif /* MIN_VERSION_" - tell (zManglePkgName z_root (zpkgName z_var0_pkg)) - tell " */\n" - tell "\n" - forM_ (zTools z_root) $ \z_var1_tool -> do - tell "/* tool " - tell (ztoolName z_var1_tool) - tell "-" - tell (prettyShow (ztoolVersion z_var1_tool)) - tell " */\n" - tell "#ifndef TOOL_VERSION_" - tell (zMangleStr z_root (ztoolName z_var1_tool)) - tell "\n" - tell "#define TOOL_VERSION_" - tell (zMangleStr z_root (ztoolName z_var1_tool)) - tell " \"" - tell (prettyShow (ztoolVersion z_var1_tool)) - tell "\"\n" - tell "#endif /* TOOL_VERSION_" - tell (zMangleStr z_root (ztoolName z_var1_tool)) - tell " */\n" - tell "#ifndef MIN_TOOL_VERSION_" - tell (zMangleStr z_root (ztoolName z_var1_tool)) - tell "\n" - tell "#define MIN_TOOL_VERSION_" - tell (zMangleStr z_root (ztoolName z_var1_tool)) - tell "(major1,major2,minor) (\\\n" - tell " (major1) < " - tell (ztoolX z_var1_tool) - tell " || \\\n" - tell " (major1) == " - tell (ztoolX z_var1_tool) - tell " && (major2) < " - tell (ztoolY z_var1_tool) - tell " || \\\n" - tell " (major1) == " - tell (ztoolX z_var1_tool) - tell " && (major2) == " - tell (ztoolY z_var1_tool) - tell " && (minor) <= " - tell (ztoolZ z_var1_tool) - tell ")\n" - tell "#endif /* MIN_TOOL_VERSION_" - tell (zMangleStr z_root (ztoolName z_var1_tool)) - tell " */\n" - tell "\n" - if (zNotNull z_root (zPackageKey z_root)) - then do - tell "#ifndef CURRENT_PACKAGE_KEY\n" - tell "#define CURRENT_PACKAGE_KEY \"" - tell (zPackageKey z_root) - tell "\"\n" - tell "#endif /* CURRENT_packageKey */\n" - return () - else do - return () - if (zNotNull z_root (zComponentId z_root)) - then do - tell "#ifndef CURRENT_COMPONENT_ID\n" - tell "#define CURRENT_COMPONENT_ID \"" - tell (zComponentId z_root) - tell "\"\n" - tell "#endif /* CURRENT_COMPONENT_ID */\n" - return () - else do - return () - tell "#ifndef CURRENT_PACKAGE_VERSION\n" - tell "#define CURRENT_PACKAGE_VERSION \"" - tell (prettyShow (zPackageVersion z_root)) - tell "\"\n" - tell "#endif /* CURRENT_PACKAGE_VERSION */\n" diff --git a/cabal/Cabal/Distribution/Simple/Build/PathsModule.hs b/cabal/Cabal/Distribution/Simple/Build/PathsModule.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/Build/PathsModule.hs +++ /dev/null @@ -1,354 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Build.Macros --- Copyright : Isaac Jones 2003-2005, --- Ross Paterson 2006, --- Duncan Coutts 2007-2008 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Generating the Paths_pkgname module. --- --- This is a module that Cabal generates for the benefit of packages. It --- enables them to find their version number and find any installed data files --- at runtime. This code should probably be split off into another module. --- -module Distribution.Simple.Build.PathsModule ( - generatePathsModule, pkgPathEnvVar - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.System -import Distribution.Simple.Compiler -import Distribution.Package -import Distribution.PackageDescription -import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.BuildPaths -import Distribution.Simple.Utils -import Distribution.Pretty -import Distribution.Version - -import System.FilePath ( pathSeparator ) - --- ------------------------------------------------------------ --- * Building Paths_.hs --- ------------------------------------------------------------ - -generatePathsModule :: PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> String -generatePathsModule pkg_descr lbi clbi = - let pragmas = - cpp_pragma - ++ no_rebindable_syntax_pragma - ++ ffi_pragmas - ++ warning_pragmas - - cpp_pragma - | supports_cpp = "{-# LANGUAGE CPP #-}\n" - | otherwise = "" - - -- -XRebindableSyntax is problematic because when paired with - -- -XOverloadedLists, 'fromListN' is not in scope, - -- or -XOverloadedStrings 'fromString' is not in scope, - -- so we disable 'RebindableSyntax'. - no_rebindable_syntax_pragma - | supports_rebindable_syntax = "{-# LANGUAGE NoRebindableSyntax #-}\n" - | otherwise = "" - - ffi_pragmas - | absolute = "" - | supports_language_pragma = - "{-# LANGUAGE ForeignFunctionInterface #-}\n" - | otherwise = - "{-# OPTIONS_GHC -fffi #-}\n" - - warning_pragmas = - "{-# OPTIONS_GHC -fno-warn-missing-import-lists #-}\n" - - foreign_imports - | absolute = "" - | otherwise = - "import Foreign\n"++ - "import Foreign.C\n" - - reloc_imports - | reloc = - "import System.Environment (getExecutablePath)\n" - | otherwise = "" - - header = - pragmas++ - "module " ++ prettyShow paths_modulename ++ " (\n"++ - " version,\n"++ - " getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir,\n"++ - " getDataFileName, getSysconfDir\n"++ - " ) where\n"++ - "\n"++ - foreign_imports++ - "import qualified Control.Exception as Exception\n"++ - "import Data.Version (Version(..))\n"++ - "import System.Environment (getEnv)\n"++ - reloc_imports ++ - "import Prelude\n"++ - "\n"++ - (if supports_cpp - then - ("#if defined(VERSION_base)\n"++ - "\n"++ - "#if MIN_VERSION_base(4,0,0)\n"++ - "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n"++ - "#else\n"++ - "catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a\n"++ - "#endif\n"++ - "\n"++ - "#else\n"++ - "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n"++ - "#endif\n") - else - "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n")++ - "catchIO = Exception.catch\n" ++ - "\n"++ - "version :: Version"++ - "\nversion = Version " ++ show branch ++ " []" - where branch = versionNumbers $ packageVersion pkg_descr - - body - | reloc = - "\n\nbindirrel :: FilePath\n" ++ - "bindirrel = " ++ show flat_bindirreloc ++ - "\n"++ - "\ngetBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath\n"++ - "getBinDir = "++mkGetEnvOrReloc "bindir" flat_bindirreloc++"\n"++ - "getLibDir = "++mkGetEnvOrReloc "libdir" flat_libdirreloc++"\n"++ - "getDynLibDir = "++mkGetEnvOrReloc "libdir" flat_dynlibdirreloc++"\n"++ - "getDataDir = "++mkGetEnvOrReloc "datadir" flat_datadirreloc++"\n"++ - "getLibexecDir = "++mkGetEnvOrReloc "libexecdir" flat_libexecdirreloc++"\n"++ - "getSysconfDir = "++mkGetEnvOrReloc "sysconfdir" flat_sysconfdirreloc++"\n"++ - "\n"++ - "getDataFileName :: FilePath -> IO FilePath\n"++ - "getDataFileName name = do\n"++ - " dir <- getDataDir\n"++ - " return (dir `joinFileName` name)\n"++ - "\n"++ - get_prefix_reloc_stuff++ - "\n"++ - filename_stuff - | absolute = - "\nbindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath\n"++ - "\nbindir = " ++ show flat_bindir ++ - "\nlibdir = " ++ show flat_libdir ++ - "\ndynlibdir = " ++ show flat_dynlibdir ++ - "\ndatadir = " ++ show flat_datadir ++ - "\nlibexecdir = " ++ show flat_libexecdir ++ - "\nsysconfdir = " ++ show flat_sysconfdir ++ - "\n"++ - "\ngetBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath\n"++ - "getBinDir = "++mkGetEnvOr "bindir" "return bindir"++"\n"++ - "getLibDir = "++mkGetEnvOr "libdir" "return libdir"++"\n"++ - "getDynLibDir = "++mkGetEnvOr "dynlibdir" "return dynlibdir"++"\n"++ - "getDataDir = "++mkGetEnvOr "datadir" "return datadir"++"\n"++ - "getLibexecDir = "++mkGetEnvOr "libexecdir" "return libexecdir"++"\n"++ - "getSysconfDir = "++mkGetEnvOr "sysconfdir" "return sysconfdir"++"\n"++ - "\n"++ - "getDataFileName :: FilePath -> IO FilePath\n"++ - "getDataFileName name = do\n"++ - " dir <- getDataDir\n"++ - " return (dir ++ "++path_sep++" ++ name)\n" - | otherwise = - "\nprefix, bindirrel :: FilePath" ++ - "\nprefix = " ++ show flat_prefix ++ - "\nbindirrel = " ++ show (fromMaybe (error "PathsModule.generate") flat_bindirrel) ++ - "\n\n"++ - "getBinDir :: IO FilePath\n"++ - "getBinDir = getPrefixDirRel bindirrel\n\n"++ - "getLibDir :: IO FilePath\n"++ - "getLibDir = "++mkGetDir flat_libdir flat_libdirrel++"\n\n"++ - "getDynLibDir :: IO FilePath\n"++ - "getDynLibDir = "++mkGetDir flat_dynlibdir flat_dynlibdirrel++"\n\n"++ - "getDataDir :: IO FilePath\n"++ - "getDataDir = "++ mkGetEnvOr "datadir" - (mkGetDir flat_datadir flat_datadirrel)++"\n\n"++ - "getLibexecDir :: IO FilePath\n"++ - "getLibexecDir = "++mkGetDir flat_libexecdir flat_libexecdirrel++"\n\n"++ - "getSysconfDir :: IO FilePath\n"++ - "getSysconfDir = "++mkGetDir flat_sysconfdir flat_sysconfdirrel++"\n\n"++ - "getDataFileName :: FilePath -> IO FilePath\n"++ - "getDataFileName name = do\n"++ - " dir <- getDataDir\n"++ - " return (dir `joinFileName` name)\n"++ - "\n"++ - get_prefix_stuff++ - "\n"++ - filename_stuff - in header++body - - where - cid = componentUnitId clbi - - InstallDirs { - prefix = flat_prefix, - bindir = flat_bindir, - libdir = flat_libdir, - dynlibdir = flat_dynlibdir, - datadir = flat_datadir, - libexecdir = flat_libexecdir, - sysconfdir = flat_sysconfdir - } = absoluteInstallCommandDirs pkg_descr lbi cid NoCopyDest - - InstallDirs { - bindir = flat_bindirrel, - libdir = flat_libdirrel, - dynlibdir = flat_dynlibdirrel, - datadir = flat_datadirrel, - libexecdir = flat_libexecdirrel, - sysconfdir = flat_sysconfdirrel - } = prefixRelativeComponentInstallDirs (packageId pkg_descr) lbi cid - - flat_bindirreloc = shortRelativePath flat_prefix flat_bindir - flat_libdirreloc = shortRelativePath flat_prefix flat_libdir - flat_dynlibdirreloc = shortRelativePath flat_prefix flat_dynlibdir - flat_datadirreloc = shortRelativePath flat_prefix flat_datadir - flat_libexecdirreloc = shortRelativePath flat_prefix flat_libexecdir - flat_sysconfdirreloc = shortRelativePath flat_prefix flat_sysconfdir - - mkGetDir _ (Just dirrel) = "getPrefixDirRel " ++ show dirrel - mkGetDir dir Nothing = "return " ++ show dir - - mkGetEnvOrReloc var dirrel = "catchIO (getEnv \""++var'++"\")" ++ - " (\\_ -> getPrefixDirReloc \"" ++ dirrel ++ - "\")" - where var' = pkgPathEnvVar pkg_descr var - - mkGetEnvOr var expr = "catchIO (getEnv \""++var'++"\")"++ - " (\\_ -> "++expr++")" - where var' = pkgPathEnvVar pkg_descr var - - -- In several cases we cannot make relocatable installations - absolute = - hasLibs pkg_descr -- we can only make progs relocatable - || isNothing flat_bindirrel -- if the bin dir is an absolute path - || not (supportsRelocatableProgs (compilerFlavor (compiler lbi))) - - reloc = relocatable lbi - - supportsRelocatableProgs GHC = case buildOS of - Windows -> True - _ -> False - supportsRelocatableProgs GHCJS = case buildOS of - Windows -> True - _ -> False - supportsRelocatableProgs _ = False - - paths_modulename = autogenPathsModuleName pkg_descr - - get_prefix_stuff = get_prefix_win32 supports_cpp buildArch - - path_sep = show [pathSeparator] - - 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 - --- | Generates the name of the environment variable controlling the path --- component of interest. --- --- Note: The format of these strings is part of Cabal's public API; --- changing this function constitutes a *backwards-compatibility* break. -pkgPathEnvVar :: PackageDescription - -> String -- ^ path component; one of \"bindir\", \"libdir\", - -- \"datadir\", \"libexecdir\", or \"sysconfdir\" - -> String -- ^ environment variable name -pkgPathEnvVar pkg_descr var = - showPkgName (packageName pkg_descr) ++ "_" ++ var - where - showPkgName = map fixchar . prettyShow - fixchar '-' = '_' - fixchar c = c - -get_prefix_reloc_stuff :: String -get_prefix_reloc_stuff = - "getPrefixDirReloc :: FilePath -> IO FilePath\n"++ - "getPrefixDirReloc dirRel = do\n"++ - " exePath <- getExecutablePath\n"++ - " let (bindir,_) = splitFileName exePath\n"++ - " return ((bindir `minusFileName` bindirrel) `joinFileName` dirRel)\n" - -get_prefix_win32 :: Bool -> Arch -> String -get_prefix_win32 supports_cpp arch = - "getPrefixDirRel :: FilePath -> IO FilePath\n"++ - "getPrefixDirRel dirRel = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.\n"++ - " where\n"++ - " try_size size = allocaArray (fromIntegral size) $ \\buf -> do\n"++ - " ret <- c_GetModuleFileName nullPtr buf size\n"++ - " case ret of\n"++ - " 0 -> return (prefix `joinFileName` dirRel)\n"++ - " _ | ret < size -> do\n"++ - " exePath <- peekCWString buf\n"++ - " let (bindir,_) = splitFileName exePath\n"++ - " return ((bindir `minusFileName` bindirrel) `joinFileName` dirRel)\n"++ - " | otherwise -> try_size (size * 2)\n"++ - "\n"++ - (case supports_cpp of - False -> "" - True -> "#if defined(i386_HOST_ARCH)\n"++ - "# define WINDOWS_CCONV stdcall\n"++ - "#elif defined(x86_64_HOST_ARCH)\n"++ - "# define WINDOWS_CCONV ccall\n"++ - "#else\n"++ - "# error Unknown mingw32 arch\n"++ - "#endif\n")++ - "foreign import " ++ cconv ++ " unsafe \"windows.h GetModuleFileNameW\"\n"++ - " c_GetModuleFileName :: Ptr () -> CWString -> Int32 -> IO Int32\n" - where cconv = if supports_cpp - then "WINDOWS_CCONV" - else case arch of - I386 -> "stdcall" - X86_64 -> "ccall" - _ -> error "win32 supported only with I386, X86_64" - -filename_stuff :: String -filename_stuff = - "minusFileName :: FilePath -> String -> FilePath\n"++ - "minusFileName dir \"\" = dir\n"++ - "minusFileName dir \".\" = dir\n"++ - "minusFileName dir suffix =\n"++ - " minusFileName (fst (splitFileName dir)) (fst (splitFileName suffix))\n"++ - "\n"++ - "joinFileName :: String -> String -> FilePath\n"++ - "joinFileName \"\" fname = fname\n"++ - "joinFileName \".\" fname = fname\n"++ - "joinFileName dir \"\" = dir\n"++ - "joinFileName dir fname\n"++ - " | isPathSeparator (last dir) = dir++fname\n"++ - " | otherwise = dir++pathSeparator:fname\n"++ - "\n"++ - "splitFileName :: FilePath -> (String, String)\n"++ - "splitFileName p = (reverse (path2++drive), reverse fname)\n"++ - " where\n"++ - " (path,drive) = case p of\n"++ - " (c:':':p') -> (reverse p',[':',c])\n"++ - " _ -> (reverse p ,\"\")\n"++ - " (fname,path1) = break isPathSeparator path\n"++ - " path2 = case path1 of\n"++ - " [] -> \".\"\n"++ - " [_] -> path1 -- don't remove the trailing slash if \n"++ - " -- there is only one character\n"++ - " (c:path') | isPathSeparator c -> path'\n"++ - " _ -> path1\n"++ - "\n"++ - "pathSeparator :: Char\n"++ - (case buildOS of - Windows -> "pathSeparator = '\\\\'\n" - _ -> "pathSeparator = '/'\n") ++ - "\n"++ - "isPathSeparator :: Char -> Bool\n"++ - (case buildOS of - Windows -> "isPathSeparator c = c == '/' || c == '\\\\'\n" - _ -> "isPathSeparator c = c == '/'\n") diff --git a/cabal/Cabal/Distribution/Simple/BuildPaths.hs b/cabal/Cabal/Distribution/Simple/BuildPaths.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/BuildPaths.hs +++ /dev/null @@ -1,256 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.BuildPaths --- Copyright : Isaac Jones 2003-2004, --- Duncan Coutts 2008 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- A bunch of dirs, paths and file names used for intermediate build steps. --- - -module Distribution.Simple.BuildPaths ( - defaultDistPref, srcPref, - haddockDirName, hscolourPref, haddockPref, - autogenPackageModulesDir, - autogenComponentModulesDir, - - autogenPathsModuleName, - cppHeaderName, - haddockName, - - mkGenericStaticLibName, - mkLibName, - mkProfLibName, - mkGenericSharedLibName, - mkSharedLibName, - mkStaticLibName, - mkGenericSharedBundledLibName, - - exeExtension, - objExtension, - dllExtension, - staticLibExtension, - -- * Source files & build directories - getSourceFiles, getLibSourceFiles, getExeSourceFiles, - getFLibSourceFiles, exeBuildDir, flibBuildDir, - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Package -import Distribution.ModuleName as ModuleName -import Distribution.Compiler -import Distribution.PackageDescription -import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.Setup -import Distribution.Pretty -import Distribution.System -import Distribution.Verbosity -import Distribution.Simple.Utils - -import Data.List (stripPrefix) -import System.FilePath ((), (<.>), normalise) - --- --------------------------------------------------------------------------- --- Build directories and files - -srcPref :: FilePath -> FilePath -srcPref distPref = distPref "src" - -hscolourPref :: HaddockTarget -> FilePath -> PackageDescription -> FilePath -hscolourPref = haddockPref - --- | This is the name of the directory in which the generated haddocks --- should be stored. It does not include the @/doc/html@ prefix. -haddockDirName :: HaddockTarget -> PackageDescription -> FilePath -haddockDirName ForDevelopment = prettyShow . packageName -haddockDirName ForHackage = (++ "-docs") . prettyShow . packageId - --- | The directory to which generated haddock documentation should be written. -haddockPref :: HaddockTarget -> FilePath -> PackageDescription -> FilePath -haddockPref haddockTarget distPref pkg_descr - = distPref "doc" "html" haddockDirName haddockTarget pkg_descr - --- | The directory in which we put auto-generated modules for EVERY --- component in the package. -autogenPackageModulesDir :: LocalBuildInfo -> String -autogenPackageModulesDir lbi = buildDir lbi "global-autogen" - --- | The directory in which we put auto-generated modules for a --- particular component. -autogenComponentModulesDir :: LocalBuildInfo -> ComponentLocalBuildInfo -> String -autogenComponentModulesDir lbi clbi = componentBuildDir lbi clbi "autogen" --- NB: Look at 'checkForeignDeps' for where a simplified version of this --- has been copy-pasted. - -cppHeaderName :: String -cppHeaderName = "cabal_macros.h" - --- | The name of the auto-generated Paths_* module associated with a package -autogenPathsModuleName :: PackageDescription -> ModuleName -autogenPathsModuleName pkg_descr = - ModuleName.fromString $ - "Paths_" ++ map fixchar (prettyShow (packageName pkg_descr)) - where fixchar '-' = '_' - fixchar c = c - -haddockName :: PackageDescription -> FilePath -haddockName pkg_descr = prettyShow (packageName pkg_descr) <.> "haddock" - --- ----------------------------------------------------------------------------- --- Source File helper - -getLibSourceFiles :: Verbosity - -> LocalBuildInfo - -> Library - -> ComponentLocalBuildInfo - -> IO [(ModuleName.ModuleName, FilePath)] -getLibSourceFiles verbosity lbi lib clbi = getSourceFiles verbosity searchpaths modules - where - bi = libBuildInfo lib - modules = allLibModules lib clbi - searchpaths = componentBuildDir lbi clbi : hsSourceDirs bi ++ - [ autogenComponentModulesDir lbi clbi - , autogenPackageModulesDir lbi ] - -getExeSourceFiles :: Verbosity - -> LocalBuildInfo - -> Executable - -> ComponentLocalBuildInfo - -> IO [(ModuleName.ModuleName, FilePath)] -getExeSourceFiles verbosity lbi exe clbi = do - moduleFiles <- getSourceFiles verbosity searchpaths modules - srcMainPath <- findFileEx verbosity (hsSourceDirs bi) (modulePath exe) - return ((ModuleName.main, srcMainPath) : moduleFiles) - where - bi = buildInfo exe - modules = otherModules bi - searchpaths = autogenComponentModulesDir lbi clbi - : autogenPackageModulesDir lbi - : exeBuildDir lbi exe : hsSourceDirs bi - -getFLibSourceFiles :: Verbosity - -> LocalBuildInfo - -> ForeignLib - -> ComponentLocalBuildInfo - -> IO [(ModuleName.ModuleName, FilePath)] -getFLibSourceFiles verbosity lbi flib clbi = getSourceFiles verbosity searchpaths modules - where - bi = foreignLibBuildInfo flib - modules = otherModules bi - searchpaths = autogenComponentModulesDir lbi clbi - : autogenPackageModulesDir lbi - : flibBuildDir lbi flib : hsSourceDirs bi - -getSourceFiles :: Verbosity -> [FilePath] - -> [ModuleName.ModuleName] - -> IO [(ModuleName.ModuleName, FilePath)] -getSourceFiles verbosity dirs modules = flip traverse modules $ \m -> fmap ((,) m) $ - findFileWithExtension ["hs", "lhs", "hsig", "lhsig"] dirs (ModuleName.toFilePath m) - >>= maybe (notFound m) (return . normalise) - where - notFound module_ = die' verbosity $ "can't find source for module " ++ prettyShow module_ - --- | The directory where we put build results for an executable -exeBuildDir :: LocalBuildInfo -> Executable -> FilePath -exeBuildDir lbi exe = buildDir lbi nm nm ++ "-tmp" - where - nm = unUnqualComponentName $ exeName exe - --- | The directory where we put build results for a foreign library -flibBuildDir :: LocalBuildInfo -> ForeignLib -> FilePath -flibBuildDir lbi flib = buildDir lbi nm nm ++ "-tmp" - where - nm = unUnqualComponentName $ foreignLibName flib - --- --------------------------------------------------------------------------- --- Library file names - --- | Create a library name for a static library from a given name. --- Prepends @lib@ and appends the static library extension (@.a@). -mkGenericStaticLibName :: String -> String -mkGenericStaticLibName lib = "lib" ++ lib <.> "a" - -mkLibName :: UnitId -> String -mkLibName lib = mkGenericStaticLibName (getHSLibraryName lib) - -mkProfLibName :: UnitId -> String -mkProfLibName lib = mkGenericStaticLibName (getHSLibraryName lib ++ "_p") - --- | Create a library name for a shared library from a given name. --- Prepends @lib@ and appends the @-\\@ --- as well as the shared library extension. -mkGenericSharedLibName :: Platform -> CompilerId -> String -> String -mkGenericSharedLibName platform (CompilerId compilerFlavor compilerVersion) lib - = mconcat [ "lib", lib, "-", comp <.> dllExtension platform ] - where comp = prettyShow compilerFlavor ++ prettyShow compilerVersion - --- Implement proper name mangling for dynamical shared objects --- @libHS\-\\@ --- e.g. @libHSbase-2.1-ghc6.6.1.so@ -mkSharedLibName :: Platform -> CompilerId -> UnitId -> String -mkSharedLibName platform comp lib - = mkGenericSharedLibName platform comp (getHSLibraryName lib) - --- Static libs are named the same as shared libraries, only with --- a different extension. -mkStaticLibName :: Platform -> CompilerId -> UnitId -> String -mkStaticLibName platform (CompilerId compilerFlavor compilerVersion) lib - = "lib" ++ getHSLibraryName lib ++ "-" ++ comp <.> staticLibExtension platform - where comp = prettyShow compilerFlavor ++ prettyShow compilerVersion - --- | Create a library name for a bundled shared library from a given name. --- This matches the naming convention for shared libraries as implemented in --- GHC's packageHsLibs function in the Packages module. --- If the given name is prefixed with HS, then this prepends 'lib' and appends --- the compiler flavour/version and shared library extension e.g.: --- "HSrts-1.0" -> "libHSrts-1.0-ghc8.7.20190109.so" --- Otherwise the given name should be prefixed with 'C', then this strips the --- 'C', prepends 'lib' and appends the shared library extension e.g.: --- "Cffi" -> "libffi.so" -mkGenericSharedBundledLibName :: Platform -> CompilerId -> String -> String -mkGenericSharedBundledLibName platform comp lib - | "HS" `isPrefixOf` lib - = mkGenericSharedLibName platform comp lib - | Just lib' <- stripPrefix "C" lib - = "lib" ++ lib' <.> dllExtension platform - | otherwise - = error ("Don't understand library name " ++ lib) - --- ------------------------------------------------------------ --- * Platform file extensions --- ------------------------------------------------------------ - --- | Default extension for executable files on the current platform. --- (typically @\"\"@ on Unix and @\"exe\"@ on Windows or OS\/2) -exeExtension :: Platform -> String -exeExtension (Platform _arch os) = case os of - Windows -> "exe" - _ -> "" - --- | Extension for object files. For GHC the extension is @\"o\"@. -objExtension :: String -objExtension = "o" - --- | Extension for dynamically linked (or shared) libraries --- (typically @\"so\"@ on Unix and @\"dll\"@ on Windows) -dllExtension :: Platform -> String -dllExtension (Platform _arch os)= case os of - Windows -> "dll" - OSX -> "dylib" - _ -> "so" - --- | Extension for static libraries --- --- TODO: Here, as well as in dllExtension, it's really the target OS that we're --- interested in, not the build OS. -staticLibExtension :: Platform -> String -staticLibExtension (Platform _arch os) = case os of - Windows -> "lib" - _ -> "a" diff --git a/cabal/Cabal/Distribution/Simple/BuildTarget.hs b/cabal/Cabal/Distribution/Simple/BuildTarget.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/BuildTarget.hs +++ /dev/null @@ -1,1063 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.BuildTargets --- Copyright : (c) Duncan Coutts 2012 --- License : BSD-like --- --- Maintainer : duncan@community.haskell.org --- --- Handling for user-specified build targets ------------------------------------------------------------------------------ -module Distribution.Simple.BuildTarget ( - -- * Main interface - readTargetInfos, - readBuildTargets, -- in case you don't have LocalBuildInfo - - -- * Build targets - BuildTarget(..), - showBuildTarget, - QualLevel(..), - buildTargetComponentName, - - -- * Parsing user build targets - UserBuildTarget, - readUserBuildTargets, - showUserBuildTarget, - UserBuildTargetProblem(..), - reportUserBuildTargetProblems, - - -- * Resolving build targets - resolveBuildTargets, - BuildTargetProblem(..), - reportBuildTargetProblems, - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Types.TargetInfo -import Distribution.Types.LocalBuildInfo -import Distribution.Types.ComponentRequestedSpec -import Distribution.Types.ForeignLib -import Distribution.Types.UnqualComponentName - -import Distribution.Package -import Distribution.PackageDescription -import Distribution.ModuleName -import Distribution.Simple.LocalBuildInfo -import Distribution.Pretty -import Distribution.Parsec -import Distribution.Simple.Utils -import Distribution.Verbosity - -import qualified Distribution.Compat.CharParsing as P - -import Control.Monad ( msum ) -import Data.List ( stripPrefix, groupBy ) -import qualified Data.List.NonEmpty as NE -import System.FilePath as FilePath - ( dropExtension, normalise, splitDirectories, joinPath, splitPath - , hasTrailingPathSeparator ) -import System.Directory ( doesFileExist, doesDirectoryExist ) -import qualified Data.Map as Map - --- | Take a list of 'String' build targets, and parse and validate them --- into actual 'TargetInfo's to be built/registered/whatever. -readTargetInfos :: Verbosity -> PackageDescription -> LocalBuildInfo -> [String] -> IO [TargetInfo] -readTargetInfos verbosity pkg_descr lbi args = do - build_targets <- readBuildTargets verbosity pkg_descr args - checkBuildTargets verbosity pkg_descr lbi build_targets - --- ------------------------------------------------------------ --- * User build targets --- ------------------------------------------------------------ - --- | Various ways that a user may specify a build target. --- -data UserBuildTarget = - - -- | A target specified by a single name. This could be a component - -- module or file. - -- - -- > cabal build foo - -- > cabal build Data.Foo - -- > cabal build Data/Foo.hs Data/Foo.hsc - -- - UserBuildTargetSingle String - - -- | A target specified by a qualifier and name. This could be a component - -- name qualified by the component namespace kind, or a module or file - -- qualified by the component name. - -- - -- > cabal build lib:foo exe:foo - -- > cabal build foo:Data.Foo - -- > cabal build foo:Data/Foo.hs - -- - | UserBuildTargetDouble String String - - -- | A fully qualified target, either a module or file qualified by a - -- component name with the component namespace kind. - -- - -- > cabal build lib:foo:Data/Foo.hs exe:foo:Data/Foo.hs - -- > cabal build lib:foo:Data.Foo exe:foo:Data.Foo - -- - | UserBuildTargetTriple String String String - deriving (Show, Eq, Ord) - - --- ------------------------------------------------------------ --- * Resolved build targets --- ------------------------------------------------------------ - --- | A fully resolved build target. --- -data BuildTarget = - - -- | A specific component - -- - BuildTargetComponent ComponentName - - -- | A specific module within a specific component. - -- - | BuildTargetModule ComponentName ModuleName - - -- | A specific file within a specific component. - -- - | BuildTargetFile ComponentName FilePath - deriving (Eq, Show, Generic) - -instance Binary BuildTarget - -buildTargetComponentName :: BuildTarget -> ComponentName -buildTargetComponentName (BuildTargetComponent cn) = cn -buildTargetComponentName (BuildTargetModule cn _) = cn -buildTargetComponentName (BuildTargetFile cn _) = cn - --- | Read a list of user-supplied build target strings and resolve them to --- 'BuildTarget's according to a 'PackageDescription'. If there are problems --- with any of the targets e.g. they don't exist or are misformatted, throw an --- 'IOException'. -readBuildTargets :: Verbosity -> PackageDescription -> [String] -> IO [BuildTarget] -readBuildTargets verbosity pkg targetStrs = do - let (uproblems, utargets) = readUserBuildTargets targetStrs - reportUserBuildTargetProblems verbosity uproblems - - utargets' <- traverse checkTargetExistsAsFile utargets - - let (bproblems, btargets) = resolveBuildTargets pkg utargets' - reportBuildTargetProblems verbosity bproblems - - return btargets - -checkTargetExistsAsFile :: UserBuildTarget -> IO (UserBuildTarget, Bool) -checkTargetExistsAsFile t = do - fexists <- existsAsFile (fileComponentOfTarget t) - return (t, fexists) - - where - existsAsFile f = do - exists <- doesFileExist f - case splitPath f of - (d:_) | hasTrailingPathSeparator d -> doesDirectoryExist d - (d:_:_) | not exists -> doesDirectoryExist d - _ -> return exists - - fileComponentOfTarget (UserBuildTargetSingle s1) = s1 - fileComponentOfTarget (UserBuildTargetDouble _ s2) = s2 - fileComponentOfTarget (UserBuildTargetTriple _ _ s3) = s3 - - --- ------------------------------------------------------------ --- * Parsing user targets --- ------------------------------------------------------------ - -readUserBuildTargets :: [String] -> ([UserBuildTargetProblem] - ,[UserBuildTarget]) -readUserBuildTargets = partitionEithers . map readUserBuildTarget - --- | --- --- >>> readUserBuildTarget "comp" --- Right (UserBuildTargetSingle "comp") --- --- >>> readUserBuildTarget "lib:comp" --- Right (UserBuildTargetDouble "lib" "comp") --- --- >>> readUserBuildTarget "pkg:lib:comp" --- Right (UserBuildTargetTriple "pkg" "lib" "comp") --- --- >>> readUserBuildTarget "\"comp\"" --- Right (UserBuildTargetSingle "comp") --- --- >>> readUserBuildTarget "lib:\"comp\"" --- Right (UserBuildTargetDouble "lib" "comp") --- --- >>> readUserBuildTarget "pkg:lib:\"comp\"" --- Right (UserBuildTargetTriple "pkg" "lib" "comp") --- --- >>> readUserBuildTarget "pkg:lib:comp:more" --- Left (UserBuildTargetUnrecognised "pkg:lib:comp:more") --- --- >>> readUserBuildTarget "pkg:\"lib\":comp" --- Left (UserBuildTargetUnrecognised "pkg:\"lib\":comp") --- -readUserBuildTarget :: String -> Either UserBuildTargetProblem - UserBuildTarget -readUserBuildTarget targetstr = - case explicitEitherParsec parseTargetApprox targetstr of - Left _ -> Left (UserBuildTargetUnrecognised targetstr) - Right tgt -> Right tgt - - where - parseTargetApprox :: CabalParsing m => m UserBuildTarget - parseTargetApprox = do - -- read one, two, or three tokens, where last could be "hs-string" - ts <- tokens - return $ case ts of - (a, Nothing) -> UserBuildTargetSingle a - (a, Just (b, Nothing)) -> UserBuildTargetDouble a b - (a, Just (b, Just c)) -> UserBuildTargetTriple a b c - - tokens :: CabalParsing m => m (String, Maybe (String, Maybe String)) - tokens = (\s -> (s, Nothing)) <$> parsecHaskellString - <|> (,) <$> token <*> P.optional (P.char ':' *> tokens2) - - tokens2 :: CabalParsing m => m (String, Maybe String) - tokens2 = (\s -> (s, Nothing)) <$> parsecHaskellString - <|> (,) <$> token <*> P.optional (P.char ':' *> (parsecHaskellString <|> token)) - - token :: CabalParsing m => m String - token = P.munch1 (\x -> not (isSpace x) && x /= ':') - -data UserBuildTargetProblem - = UserBuildTargetUnrecognised String - deriving Show - -reportUserBuildTargetProblems :: Verbosity -> [UserBuildTargetProblem] -> IO () -reportUserBuildTargetProblems verbosity problems = do - case [ target | UserBuildTargetUnrecognised target <- problems ] of - [] -> return () - target -> - die' verbosity $ unlines - [ "Unrecognised build target '" ++ name ++ "'." - | name <- target ] - ++ "Examples:\n" - ++ " - build foo -- component name " - ++ "(library, executable, test-suite or benchmark)\n" - ++ " - build Data.Foo -- module name\n" - ++ " - build Data/Foo.hsc -- file name\n" - ++ " - build lib:foo exe:foo -- component qualified by kind\n" - ++ " - build foo:Data.Foo -- module qualified by component\n" - ++ " - build foo:Data/Foo.hsc -- file qualified by component" - -showUserBuildTarget :: UserBuildTarget -> String -showUserBuildTarget = intercalate ":" . getComponents - where - getComponents (UserBuildTargetSingle s1) = [s1] - getComponents (UserBuildTargetDouble s1 s2) = [s1,s2] - getComponents (UserBuildTargetTriple s1 s2 s3) = [s1,s2,s3] - --- | Unless you use 'QL1', this function is PARTIAL; --- use 'showBuildTarget' instead. -showBuildTarget' :: QualLevel -> PackageId -> BuildTarget -> String -showBuildTarget' ql pkgid bt = - showUserBuildTarget (renderBuildTarget ql bt pkgid) - --- | Unambiguously render a 'BuildTarget', so that it can --- be parsed in all situations. -showBuildTarget :: PackageId -> BuildTarget -> String -showBuildTarget pkgid t = - showBuildTarget' (qlBuildTarget t) pkgid t - where - qlBuildTarget BuildTargetComponent{} = QL2 - qlBuildTarget _ = QL3 - - --- ------------------------------------------------------------ --- * Resolving user targets to build targets --- ------------------------------------------------------------ - -{- -stargets = - [ BuildTargetComponent (CExeName "foo") - , BuildTargetModule (CExeName "foo") (mkMn "Foo") - , BuildTargetModule (CExeName "tst") (mkMn "Foo") - ] - where - mkMn :: String -> ModuleName - mkMn = fromJust . simpleParse - -ex_pkgid :: PackageIdentifier -Just ex_pkgid = simpleParse "thelib" --} - --- | Given a bunch of user-specified targets, try to resolve what it is they --- refer to. --- -resolveBuildTargets :: PackageDescription - -> [(UserBuildTarget, Bool)] - -> ([BuildTargetProblem], [BuildTarget]) -resolveBuildTargets pkg = partitionEithers - . map (uncurry (resolveBuildTarget pkg)) - -resolveBuildTarget :: PackageDescription -> UserBuildTarget -> Bool - -> Either BuildTargetProblem BuildTarget -resolveBuildTarget pkg userTarget fexists = - case findMatch (matchBuildTarget pkg userTarget fexists) of - Unambiguous target -> Right target - Ambiguous targets -> Left (BuildTargetAmbiguous userTarget targets') - where targets' = disambiguateBuildTargets - (packageId pkg) - userTarget - targets - None errs -> Left (classifyMatchErrors errs) - - where - classifyMatchErrors errs - | Just expected' <- NE.nonEmpty expected - = let (things, got:|_) = NE.unzip expected' in - BuildTargetExpected userTarget (NE.toList things) got - | not (null nosuch) = BuildTargetNoSuch userTarget nosuch - | otherwise = error $ "resolveBuildTarget: internal error in matching" - where - expected = [ (thing, got) | MatchErrorExpected thing got <- errs ] - nosuch = [ (thing, got) | MatchErrorNoSuch thing got <- errs ] - - -data BuildTargetProblem - = BuildTargetExpected UserBuildTarget [String] String - -- ^ [expected thing] (actually got) - | BuildTargetNoSuch UserBuildTarget [(String, String)] - -- ^ [(no such thing, actually got)] - | BuildTargetAmbiguous UserBuildTarget [(UserBuildTarget, BuildTarget)] - deriving Show - - -disambiguateBuildTargets :: PackageId -> UserBuildTarget -> [BuildTarget] - -> [(UserBuildTarget, BuildTarget)] -disambiguateBuildTargets pkgid original = - disambiguate (userTargetQualLevel original) - where - disambiguate ql ts - | null amb = unamb - | otherwise = unamb ++ disambiguate (succ ql) amb - where - (amb, unamb) = step ql ts - - userTargetQualLevel (UserBuildTargetSingle _ ) = QL1 - userTargetQualLevel (UserBuildTargetDouble _ _ ) = QL2 - userTargetQualLevel (UserBuildTargetTriple _ _ _) = QL3 - - step :: QualLevel -> [BuildTarget] - -> ([BuildTarget], [(UserBuildTarget, BuildTarget)]) - step ql = (\(amb, unamb) -> (map snd $ concat amb, concat unamb)) - . partition (\g -> length g > 1) - . groupBy (equating fst) - . sortBy (comparing fst) - . map (\t -> (renderBuildTarget ql t pkgid, t)) - -data QualLevel = QL1 | QL2 | QL3 - deriving (Enum, Show) - -renderBuildTarget :: QualLevel -> BuildTarget -> PackageId -> UserBuildTarget -renderBuildTarget ql target pkgid = - case ql of - QL1 -> UserBuildTargetSingle s1 where s1 = single target - QL2 -> UserBuildTargetDouble s1 s2 where (s1, s2) = double target - QL3 -> UserBuildTargetTriple s1 s2 s3 where (s1, s2, s3) = triple target - - where - single (BuildTargetComponent cn ) = dispCName cn - single (BuildTargetModule _ m) = prettyShow m - single (BuildTargetFile _ f) = f - - double (BuildTargetComponent cn ) = (dispKind cn, dispCName cn) - double (BuildTargetModule cn m) = (dispCName cn, prettyShow m) - double (BuildTargetFile cn f) = (dispCName cn, f) - - triple (BuildTargetComponent _ ) = error "triple BuildTargetComponent" - triple (BuildTargetModule cn m) = (dispKind cn, dispCName cn, prettyShow m) - triple (BuildTargetFile cn f) = (dispKind cn, dispCName cn, f) - - dispCName = componentStringName pkgid - dispKind = showComponentKindShort . componentKind - -reportBuildTargetProblems :: Verbosity -> [BuildTargetProblem] -> IO () -reportBuildTargetProblems verbosity problems = do - - case [ (t, e, g) | BuildTargetExpected t e g <- problems ] of - [] -> return () - targets -> - die' verbosity $ unlines - [ "Unrecognised build target '" ++ showUserBuildTarget target - ++ "'.\n" - ++ "Expected a " ++ intercalate " or " expected - ++ ", rather than '" ++ got ++ "'." - | (target, expected, got) <- targets ] - - case [ (t, e) | BuildTargetNoSuch t e <- problems ] of - [] -> return () - targets -> - die' verbosity $ unlines - [ "Unknown build target '" ++ showUserBuildTarget target - ++ "'.\nThere is no " - ++ intercalate " or " [ mungeThing thing ++ " '" ++ got ++ "'" - | (thing, got) <- nosuch ] ++ "." - | (target, nosuch) <- targets ] - where - mungeThing "file" = "file target" - mungeThing thing = thing - - case [ (t, ts) | BuildTargetAmbiguous t ts <- problems ] of - [] -> return () - targets -> - die' verbosity $ unlines - [ "Ambiguous build target '" ++ showUserBuildTarget target - ++ "'. It could be:\n " - ++ unlines [ " "++ showUserBuildTarget ut ++ - " (" ++ showBuildTargetKind bt ++ ")" - | (ut, bt) <- amb ] - | (target, amb) <- targets ] - - where - showBuildTargetKind (BuildTargetComponent _ ) = "component" - showBuildTargetKind (BuildTargetModule _ _) = "module" - showBuildTargetKind (BuildTargetFile _ _) = "file" - - ----------------------------------- --- Top level BuildTarget matcher --- - -matchBuildTarget :: PackageDescription - -> UserBuildTarget -> Bool -> Match BuildTarget -matchBuildTarget pkg = \utarget fexists -> - case utarget of - UserBuildTargetSingle str1 -> - matchBuildTarget1 cinfo str1 fexists - - UserBuildTargetDouble str1 str2 -> - matchBuildTarget2 cinfo str1 str2 fexists - - UserBuildTargetTriple str1 str2 str3 -> - matchBuildTarget3 cinfo str1 str2 str3 fexists - where - cinfo = pkgComponentInfo pkg - -matchBuildTarget1 :: [ComponentInfo] -> String -> Bool -> Match BuildTarget -matchBuildTarget1 cinfo str1 fexists = - matchComponent1 cinfo str1 - `matchPlusShadowing` matchModule1 cinfo str1 - `matchPlusShadowing` matchFile1 cinfo str1 fexists - - -matchBuildTarget2 :: [ComponentInfo] -> String -> String -> Bool - -> Match BuildTarget -matchBuildTarget2 cinfo str1 str2 fexists = - matchComponent2 cinfo str1 str2 - `matchPlusShadowing` matchModule2 cinfo str1 str2 - `matchPlusShadowing` matchFile2 cinfo str1 str2 fexists - - -matchBuildTarget3 :: [ComponentInfo] -> String -> String -> String -> Bool - -> Match BuildTarget -matchBuildTarget3 cinfo str1 str2 str3 fexists = - matchModule3 cinfo str1 str2 str3 - `matchPlusShadowing` matchFile3 cinfo str1 str2 str3 fexists - - -data ComponentInfo = ComponentInfo { - cinfoName :: ComponentName, - cinfoStrName :: ComponentStringName, - cinfoSrcDirs :: [FilePath], - cinfoModules :: [ModuleName], - cinfoHsFiles :: [FilePath], -- other hs files (like main.hs) - cinfoAsmFiles:: [FilePath], - cinfoCmmFiles:: [FilePath], - cinfoCFiles :: [FilePath], - cinfoCxxFiles:: [FilePath], - cinfoJsFiles :: [FilePath] - } - -type ComponentStringName = String - -pkgComponentInfo :: PackageDescription -> [ComponentInfo] -pkgComponentInfo pkg = - [ ComponentInfo { - cinfoName = componentName c, - cinfoStrName = componentStringName pkg (componentName c), - cinfoSrcDirs = hsSourceDirs bi, - cinfoModules = componentModules c, - cinfoHsFiles = componentHsFiles c, - cinfoAsmFiles= asmSources bi, - cinfoCmmFiles= cmmSources bi, - cinfoCFiles = cSources bi, - cinfoCxxFiles= cxxSources bi, - cinfoJsFiles = jsSources bi - } - | c <- pkgComponents pkg - , let bi = componentBuildInfo c ] - -componentStringName :: Package pkg => pkg -> ComponentName -> ComponentStringName -componentStringName pkg (CLibName LMainLibName ) = prettyShow (packageName pkg) -componentStringName _ (CLibName (LSubLibName name)) = unUnqualComponentName name -componentStringName _ (CFLibName name) = unUnqualComponentName name -componentStringName _ (CExeName name) = unUnqualComponentName name -componentStringName _ (CTestName name) = unUnqualComponentName name -componentStringName _ (CBenchName name) = unUnqualComponentName name - -componentModules :: Component -> [ModuleName] --- TODO: Use of 'explicitLibModules' here is a bit wrong: --- a user could very well ask to build a specific signature --- that was inherited from other packages. To fix this --- we have to plumb 'LocalBuildInfo' through this code. --- Fortunately, this is only used by 'pkgComponentInfo' --- Please don't export this function unless you plan on fixing --- this. -componentModules (CLib lib) = explicitLibModules lib -componentModules (CFLib flib) = foreignLibModules flib -componentModules (CExe exe) = exeModules exe -componentModules (CTest test) = testModules test -componentModules (CBench bench) = benchmarkModules bench - -componentHsFiles :: Component -> [FilePath] -componentHsFiles (CExe exe) = [modulePath exe] -componentHsFiles (CTest TestSuite { - testInterface = TestSuiteExeV10 _ mainfile - }) = [mainfile] -componentHsFiles (CBench Benchmark { - benchmarkInterface = BenchmarkExeV10 _ mainfile - }) = [mainfile] -componentHsFiles _ = [] - -{- -ex_cs :: [ComponentInfo] -ex_cs = - [ (mkC (CExeName "foo") ["src1", "src1/src2"] ["Foo", "Src2.Bar", "Bar"]) - , (mkC (CExeName "tst") ["src1", "test"] ["Foo"]) - ] - where - mkC n ds ms = ComponentInfo n (componentStringName pkgid n) ds (map mkMn ms) - mkMn :: String -> ModuleName - mkMn = fromJust . simpleParse - pkgid :: PackageIdentifier - Just pkgid = simpleParse "thelib" --} - ------------------------------- --- Matching component kinds --- - -data ComponentKind = LibKind | FLibKind | ExeKind | TestKind | BenchKind - deriving (Eq, Ord, Show, Enum, Bounded) - -componentKind :: ComponentName -> ComponentKind -componentKind (CLibName _) = LibKind -componentKind (CFLibName _) = FLibKind -componentKind (CExeName _) = ExeKind -componentKind (CTestName _) = TestKind -componentKind (CBenchName _) = BenchKind - -cinfoKind :: ComponentInfo -> ComponentKind -cinfoKind = componentKind . cinfoName - -matchComponentKind :: String -> Match ComponentKind -matchComponentKind s - | s `elem` ["lib", "library"] = return' LibKind - | s `elem` ["flib", "foreign-lib", "foreign-library"] = return' FLibKind - | s `elem` ["exe", "executable"] = return' ExeKind - | s `elem` ["tst", "test", "test-suite"] = return' TestKind - | s `elem` ["bench", "benchmark"] = return' BenchKind - | otherwise = matchErrorExpected "component kind" s - where - return' ck = increaseConfidence >> return ck - -showComponentKind :: ComponentKind -> String -showComponentKind LibKind = "library" -showComponentKind FLibKind = "foreign-library" -showComponentKind ExeKind = "executable" -showComponentKind TestKind = "test-suite" -showComponentKind BenchKind = "benchmark" - -showComponentKindShort :: ComponentKind -> String -showComponentKindShort LibKind = "lib" -showComponentKindShort FLibKind = "flib" -showComponentKindShort ExeKind = "exe" -showComponentKindShort TestKind = "test" -showComponentKindShort BenchKind = "bench" - ------------------------------- --- Matching component targets --- - -matchComponent1 :: [ComponentInfo] -> String -> Match BuildTarget -matchComponent1 cs = \str1 -> do - guardComponentName str1 - c <- matchComponentName cs str1 - return (BuildTargetComponent (cinfoName c)) - -matchComponent2 :: [ComponentInfo] -> String -> String -> Match BuildTarget -matchComponent2 cs = \str1 str2 -> do - ckind <- matchComponentKind str1 - guardComponentName str2 - c <- matchComponentKindAndName cs ckind str2 - return (BuildTargetComponent (cinfoName c)) - --- utils: - -guardComponentName :: String -> Match () -guardComponentName s - | all validComponentChar s - && not (null s) = increaseConfidence - | otherwise = matchErrorExpected "component name" s - where - validComponentChar c = isAlphaNum c || c == '.' - || c == '_' || c == '-' || c == '\'' - -matchComponentName :: [ComponentInfo] -> String -> Match ComponentInfo -matchComponentName cs str = - orNoSuchThing "component" str - $ increaseConfidenceFor - $ matchInexactly caseFold - [ (cinfoStrName c, c) | c <- cs ] - str - -matchComponentKindAndName :: [ComponentInfo] -> ComponentKind -> String - -> Match ComponentInfo -matchComponentKindAndName cs ckind str = - orNoSuchThing (showComponentKind ckind ++ " component") str - $ increaseConfidenceFor - $ matchInexactly (\(ck, cn) -> (ck, caseFold cn)) - [ ((cinfoKind c, cinfoStrName c), c) | c <- cs ] - (ckind, str) - - ------------------------------- --- Matching module targets --- - -matchModule1 :: [ComponentInfo] -> String -> Match BuildTarget -matchModule1 cs = \str1 -> do - guardModuleName str1 - nubMatchErrors $ do - c <- tryEach cs - let ms = cinfoModules c - m <- matchModuleName ms str1 - return (BuildTargetModule (cinfoName c) m) - -matchModule2 :: [ComponentInfo] -> String -> String -> Match BuildTarget -matchModule2 cs = \str1 str2 -> do - guardComponentName str1 - guardModuleName str2 - c <- matchComponentName cs str1 - let ms = cinfoModules c - m <- matchModuleName ms str2 - return (BuildTargetModule (cinfoName c) m) - -matchModule3 :: [ComponentInfo] -> String -> String -> String - -> Match BuildTarget -matchModule3 cs str1 str2 str3 = do - ckind <- matchComponentKind str1 - guardComponentName str2 - c <- matchComponentKindAndName cs ckind str2 - guardModuleName str3 - let ms = cinfoModules c - m <- matchModuleName ms str3 - return (BuildTargetModule (cinfoName c) m) - --- utils: - -guardModuleName :: String -> Match () -guardModuleName s - | all validModuleChar s - && not (null s) = increaseConfidence - | otherwise = matchErrorExpected "module name" s - where - validModuleChar c = isAlphaNum c || c == '.' || c == '_' || c == '\'' - -matchModuleName :: [ModuleName] -> String -> Match ModuleName -matchModuleName ms str = - orNoSuchThing "module" str - $ increaseConfidenceFor - $ matchInexactly caseFold - [ (prettyShow m, m) - | m <- ms ] - str - - ------------------------------- --- Matching file targets --- - -matchFile1 :: [ComponentInfo] -> String -> Bool -> Match BuildTarget -matchFile1 cs str1 exists = - nubMatchErrors $ do - c <- tryEach cs - filepath <- matchComponentFile c str1 exists - return (BuildTargetFile (cinfoName c) filepath) - - -matchFile2 :: [ComponentInfo] -> String -> String -> Bool -> Match BuildTarget -matchFile2 cs str1 str2 exists = do - guardComponentName str1 - c <- matchComponentName cs str1 - filepath <- matchComponentFile c str2 exists - return (BuildTargetFile (cinfoName c) filepath) - - -matchFile3 :: [ComponentInfo] -> String -> String -> String -> Bool - -> Match BuildTarget -matchFile3 cs str1 str2 str3 exists = do - ckind <- matchComponentKind str1 - guardComponentName str2 - c <- matchComponentKindAndName cs ckind str2 - filepath <- matchComponentFile c str3 exists - return (BuildTargetFile (cinfoName c) filepath) - - -matchComponentFile :: ComponentInfo -> String -> Bool -> Match FilePath -matchComponentFile c str fexists = - expecting "file" str $ - matchPlus - (matchFileExists str fexists) - (matchPlusShadowing - (msum [ matchModuleFileRooted dirs ms str - , matchOtherFileRooted dirs hsFiles str ]) - (msum [ matchModuleFileUnrooted ms str - , matchOtherFileUnrooted hsFiles str - , matchOtherFileUnrooted cFiles str - , matchOtherFileUnrooted jsFiles str ])) - where - dirs = cinfoSrcDirs c - ms = cinfoModules c - hsFiles = cinfoHsFiles c - cFiles = cinfoCFiles c - jsFiles = cinfoJsFiles c - - --- utils - -matchFileExists :: FilePath -> Bool -> Match a -matchFileExists _ False = mzero -matchFileExists fname True = do increaseConfidence - matchErrorNoSuch "file" fname - -matchModuleFileUnrooted :: [ModuleName] -> String -> Match FilePath -matchModuleFileUnrooted ms str = do - let filepath = normalise str - _ <- matchModuleFileStem ms filepath - return filepath - -matchModuleFileRooted :: [FilePath] -> [ModuleName] -> String -> Match FilePath -matchModuleFileRooted dirs ms str = nubMatches $ do - let filepath = normalise str - filepath' <- matchDirectoryPrefix dirs filepath - _ <- matchModuleFileStem ms filepath' - return filepath - -matchModuleFileStem :: [ModuleName] -> FilePath -> Match ModuleName -matchModuleFileStem ms = - increaseConfidenceFor - . matchInexactly caseFold - [ (toFilePath m, m) | m <- ms ] - . dropExtension - -matchOtherFileRooted :: [FilePath] -> [FilePath] -> FilePath -> Match FilePath -matchOtherFileRooted dirs fs str = do - let filepath = normalise str - filepath' <- matchDirectoryPrefix dirs filepath - _ <- matchFile fs filepath' - return filepath - -matchOtherFileUnrooted :: [FilePath] -> FilePath -> Match FilePath -matchOtherFileUnrooted fs str = do - let filepath = normalise str - _ <- matchFile fs filepath - return filepath - -matchFile :: [FilePath] -> FilePath -> Match FilePath -matchFile fs = increaseConfidenceFor - . matchInexactly caseFold [ (f, f) | f <- fs ] - -matchDirectoryPrefix :: [FilePath] -> FilePath -> Match FilePath -matchDirectoryPrefix dirs filepath = - exactMatches $ - catMaybes - [ stripDirectory (normalise dir) filepath | dir <- dirs ] - where - stripDirectory :: FilePath -> FilePath -> Maybe FilePath - stripDirectory dir fp = - joinPath `fmap` stripPrefix (splitDirectories dir) (splitDirectories fp) - - ------------------------------- --- Matching monad --- - --- | A matcher embodies a way to match some input as being some recognised --- value. In particular it deals with multiple and ambiguous matches. --- --- There are various matcher primitives ('matchExactly', 'matchInexactly'), --- ways to combine matchers ('ambiguousWith', 'shadows') and finally we can --- run a matcher against an input using 'findMatch'. --- - -data Match a = NoMatch Confidence [MatchError] - | ExactMatch Confidence [a] - | InexactMatch Confidence [a] - deriving Show - -type Confidence = Int - -data MatchError = MatchErrorExpected String String - | MatchErrorNoSuch String String - deriving (Show, Eq) - - -instance Alternative Match where - empty = mzero - (<|>) = mplus - -instance MonadPlus Match where - mzero = matchZero - mplus = matchPlus - -matchZero :: Match a -matchZero = NoMatch 0 [] - --- | Combine two matchers. Exact matches are used over inexact matches --- but if we have multiple exact, or inexact then the we collect all the --- ambiguous matches. --- -matchPlus :: Match a -> Match a -> Match a -matchPlus (ExactMatch d1 xs) (ExactMatch d2 xs') = - ExactMatch (max d1 d2) (xs ++ xs') -matchPlus a@(ExactMatch _ _ ) (InexactMatch _ _ ) = a -matchPlus a@(ExactMatch _ _ ) (NoMatch _ _ ) = a -matchPlus (InexactMatch _ _ ) b@(ExactMatch _ _ ) = b -matchPlus (InexactMatch d1 xs) (InexactMatch d2 xs') = - InexactMatch (max d1 d2) (xs ++ xs') -matchPlus a@(InexactMatch _ _ ) (NoMatch _ _ ) = a -matchPlus (NoMatch _ _ ) b@(ExactMatch _ _ ) = b -matchPlus (NoMatch _ _ ) b@(InexactMatch _ _ ) = b -matchPlus a@(NoMatch d1 ms) b@(NoMatch d2 ms') - | d1 > d2 = a - | d1 < d2 = b - | otherwise = NoMatch d1 (ms ++ ms') - --- | Combine two matchers. This is similar to 'ambiguousWith' with the --- difference that an exact match from the left matcher shadows any exact --- match on the right. Inexact matches are still collected however. --- -matchPlusShadowing :: Match a -> Match a -> Match a -matchPlusShadowing a@(ExactMatch _ _) (ExactMatch _ _) = a -matchPlusShadowing a b = matchPlus a b - -instance Functor Match where - fmap _ (NoMatch d ms) = NoMatch d ms - fmap f (ExactMatch d xs) = ExactMatch d (fmap f xs) - fmap f (InexactMatch d xs) = InexactMatch d (fmap f xs) - -instance Applicative Match where - pure a = ExactMatch 0 [a] - (<*>) = ap - -instance Monad Match where - return = pure - - NoMatch d ms >>= _ = NoMatch d ms - ExactMatch d xs >>= f = addDepth d - $ foldr matchPlus matchZero (map f xs) - InexactMatch d xs >>= f = addDepth d . forceInexact - $ foldr matchPlus matchZero (map f xs) - -addDepth :: Confidence -> Match a -> Match a -addDepth d' (NoMatch d msgs) = NoMatch (d'+d) msgs -addDepth d' (ExactMatch d xs) = ExactMatch (d'+d) xs -addDepth d' (InexactMatch d xs) = InexactMatch (d'+d) xs - -forceInexact :: Match a -> Match a -forceInexact (ExactMatch d ys) = InexactMatch d ys -forceInexact m = m - ------------------------------- --- Various match primitives --- - -matchErrorExpected, matchErrorNoSuch :: String -> String -> Match a -matchErrorExpected thing got = NoMatch 0 [MatchErrorExpected thing got] -matchErrorNoSuch thing got = NoMatch 0 [MatchErrorNoSuch thing got] - -expecting :: String -> String -> Match a -> Match a -expecting thing got (NoMatch 0 _) = matchErrorExpected thing got -expecting _ _ m = m - -orNoSuchThing :: String -> String -> Match a -> Match a -orNoSuchThing thing got (NoMatch 0 _) = matchErrorNoSuch thing got -orNoSuchThing _ _ m = m - -increaseConfidence :: Match () -increaseConfidence = ExactMatch 1 [()] - -increaseConfidenceFor :: Match a -> Match a -increaseConfidenceFor m = m >>= \r -> increaseConfidence >> return r - -nubMatches :: Eq a => Match a -> Match a -nubMatches (NoMatch d msgs) = NoMatch d msgs -nubMatches (ExactMatch d xs) = ExactMatch d (nub xs) -nubMatches (InexactMatch d xs) = InexactMatch d (nub xs) - -nubMatchErrors :: Match a -> Match a -nubMatchErrors (NoMatch d msgs) = NoMatch d (nub msgs) -nubMatchErrors (ExactMatch d xs) = ExactMatch d xs -nubMatchErrors (InexactMatch d xs) = InexactMatch d xs - --- | Lift a list of matches to an exact match. --- -exactMatches, inexactMatches :: [a] -> Match a - -exactMatches [] = matchZero -exactMatches xs = ExactMatch 0 xs - -inexactMatches [] = matchZero -inexactMatches xs = InexactMatch 0 xs - -tryEach :: [a] -> Match a -tryEach = exactMatches - - ------------------------------- --- Top level match runner --- - --- | Given a matcher and a key to look up, use the matcher to find all the --- possible matches. There may be 'None', a single 'Unambiguous' match or --- you may have an 'Ambiguous' match with several possibilities. --- -findMatch :: Eq b => Match b -> MaybeAmbiguous b -findMatch match = - case match of - NoMatch _ msgs -> None (nub msgs) - ExactMatch _ xs -> checkAmbiguous xs - InexactMatch _ xs -> checkAmbiguous xs - where - checkAmbiguous xs = case nub xs of - [x] -> Unambiguous x - xs' -> Ambiguous xs' - -data MaybeAmbiguous a = None [MatchError] | Unambiguous a | Ambiguous [a] - deriving Show - - ------------------------------- --- Basic matchers --- - -{- --- | A primitive matcher that looks up a value in a finite 'Map'. The --- value must match exactly. --- -matchExactly :: forall a b. Ord a => [(a, b)] -> (a -> Match b) -matchExactly xs = - \x -> case Map.lookup x m of - Nothing -> matchZero - Just ys -> ExactMatch 0 ys - where - m :: Ord a => Map a [b] - m = Map.fromListWith (++) [ (k,[x]) | (k,x) <- xs ] --} - --- | A primitive matcher that looks up a value in a finite 'Map'. It checks --- for an exact or inexact match. We get an inexact match if the match --- is not exact, but the canonical forms match. It takes a canonicalisation --- function for this purpose. --- --- So for example if we used string case fold as the canonicalisation --- function, then we would get case insensitive matching (but it will still --- report an exact match when the case matches too). --- -matchInexactly :: (Ord a, Ord a') => - (a -> a') -> - [(a, b)] -> (a -> Match b) -matchInexactly cannonicalise xs = - \x -> case Map.lookup x m of - Just ys -> exactMatches ys - Nothing -> case Map.lookup (cannonicalise x) m' of - Just ys -> inexactMatches ys - Nothing -> matchZero - where - m = Map.fromListWith (++) [ (k,[x]) | (k,x) <- xs ] - - -- the map of canonicalised keys to groups of inexact matches - m' = Map.mapKeysWith (++) cannonicalise m - - - ------------------------------- --- Utils --- - -caseFold :: String -> String -caseFold = lowercase - - --- | Check that the given build targets are valid in the current context. --- --- Also swizzle into a more convenient form. --- -checkBuildTargets :: Verbosity -> PackageDescription -> LocalBuildInfo -> [BuildTarget] - -> IO [TargetInfo] -checkBuildTargets _ pkg_descr lbi [] = - return (allTargetsInBuildOrder' pkg_descr lbi) - -checkBuildTargets verbosity pkg_descr lbi targets = do - - let (enabled, disabled) = - partitionEithers - [ case componentDisabledReason (componentEnabledSpec lbi) comp of - Nothing -> Left target' - Just reason -> Right (cname, reason) - | target <- targets - , let target'@(cname,_) = swizzleTarget target - , let comp = getComponent pkg_descr cname ] - - case disabled of - [] -> return () - ((cname,reason):_) -> die' verbosity $ formatReason (showComponentName cname) reason - - for_ [ (c, t) | (c, Just t) <- enabled ] $ \(c, t) -> - warn verbosity $ "Ignoring '" ++ either prettyShow id t ++ ". The whole " - ++ showComponentName c ++ " will be processed. (Support for " - ++ "module and file targets has not been implemented yet.)" - - -- Pick out the actual CLBIs for each of these cnames - enabled' <- for enabled $ \(cname, _) -> do - case componentNameTargets' pkg_descr lbi cname of - [] -> error "checkBuildTargets: nothing enabled" - [target] -> return target - _targets -> error "checkBuildTargets: multiple copies enabled" - - return enabled' - - where - swizzleTarget (BuildTargetComponent c) = (c, Nothing) - swizzleTarget (BuildTargetModule c m) = (c, Just (Left m)) - swizzleTarget (BuildTargetFile c f) = (c, Just (Right f)) - - formatReason cn DisabledComponent = - "Cannot process the " ++ cn ++ " because the component is marked " - ++ "as disabled in the .cabal file." - formatReason cn DisabledAllTests = - "Cannot process the " ++ cn ++ " because test suites are not " - ++ "enabled. Run configure with the flag --enable-tests" - formatReason cn DisabledAllBenchmarks = - "Cannot process the " ++ cn ++ " because benchmarks are not " - ++ "enabled. Re-run configure with the flag --enable-benchmarks" - formatReason cn (DisabledAllButOne cn') = - "Cannot process the " ++ cn ++ " because this package was " - ++ "configured only to build " ++ cn' ++ ". Re-run configure " - ++ "with the argument " ++ cn diff --git a/cabal/Cabal/Distribution/Simple/BuildToolDepends.hs b/cabal/Cabal/Distribution/Simple/BuildToolDepends.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/BuildToolDepends.hs +++ /dev/null @@ -1,93 +0,0 @@ --- | --- --- This modules provides functions for working with both the legacy --- "build-tools" field, and its replacement, "build-tool-depends". Prefer using --- the functions contained to access those fields directly. -module Distribution.Simple.BuildToolDepends where - -import Prelude () -import Distribution.Compat.Prelude - -import qualified Data.Map as Map - -import Distribution.Package -import Distribution.PackageDescription - --- | Desugar a "build-tools" entry into proper a executable dependency if --- possible. --- --- An entry can be so desguared in two cases: --- --- 1. The name in build-tools matches a locally defined executable. The --- executable dependency produced is on that exe in the current package. --- --- 2. The name in build-tools matches a hard-coded set of known tools. For now, --- the executable dependency produced is one an executable in a package of --- the same, but the hard-coding could just as well be per-key. --- --- The first cases matches first. -desugarBuildTool :: PackageDescription - -> LegacyExeDependency - -> Maybe ExeDependency -desugarBuildTool pkg led = - if foundLocal - then Just $ ExeDependency (packageName pkg) toolName reqVer - else Map.lookup name whiteMap - where - LegacyExeDependency name reqVer = led - toolName = mkUnqualComponentName name - foundLocal = toolName `elem` map exeName (executables pkg) - whitelist = [ "hscolour", "haddock", "happy", "alex", "hsc2hs", "c2hs" - , "cpphs", "greencard", "hspec-discover" - ] - whiteMap = Map.fromList $ flip map whitelist $ \n -> - (n, ExeDependency (mkPackageName n) (mkUnqualComponentName n) reqVer) - --- | Get everything from "build-tool-depends", along with entries from --- "build-tools" that we know how to desugar. --- --- This should almost always be used instead of just accessing the --- `buildToolDepends` field directly. -getAllToolDependencies :: PackageDescription - -> BuildInfo - -> [ExeDependency] -getAllToolDependencies pkg bi = - buildToolDepends bi ++ mapMaybe (desugarBuildTool pkg) (buildTools bi) - --- | Does the given executable dependency map to this current package? --- --- This is a tiny function, but used in a number of places. --- --- This function is only sound to call on `BuildInfo`s from the given package --- description. This is because it just filters the package names of each --- dependency, and does not check whether version bounds in fact exclude the --- current package, or the referenced components in fact exist in the current --- package. --- --- This is OK because when a package is loaded, it is checked (in --- `Distribution.Package.Check`) that dependencies matching internal components --- do indeed have version bounds accepting the current package, and any --- depended-on component in the current package actually exists. In fact this --- check is performed by gathering the internal tool dependencies of each --- component of the package according to this module, and ensuring those --- properties on each so-gathered dependency. --- --- version bounds and components of the package are unchecked. This is because --- we sanitize exe deps so that the matching name implies these other --- conditions. -isInternal :: PackageDescription -> ExeDependency -> Bool -isInternal pkg (ExeDependency n _ _) = n == packageName pkg - - --- | Get internal "build-tool-depends", along with internal "build-tools" --- --- This is a tiny function, but used in a number of places. The same --- restrictions that apply to `isInternal` also apply to this function. -getAllInternalToolDependencies :: PackageDescription - -> BuildInfo - -> [UnqualComponentName] -getAllInternalToolDependencies pkg bi = - [ toolname - | dep@(ExeDependency _ toolname _) <- getAllToolDependencies pkg bi - , isInternal pkg dep - ] diff --git a/cabal/Cabal/Distribution/Simple/CCompiler.hs b/cabal/Cabal/Distribution/Simple/CCompiler.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/CCompiler.hs +++ /dev/null @@ -1,123 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.CCompiler --- Copyright : 2011, Dan Knapp --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This simple package provides types and functions for interacting with --- C compilers. Currently it's just a type enumerating extant C-like --- languages, which we call dialects. - -{- -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - -module Distribution.Simple.CCompiler ( - CDialect(..), - cSourceExtensions, - cDialectFilenameExtension, - filenameCDialect - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import System.FilePath - ( takeExtension ) - - --- | Represents a dialect of C. The Monoid instance expresses backward --- compatibility, in the sense that 'mappend a b' is the least inclusive --- dialect which both 'a' and 'b' can be correctly interpreted as. -data CDialect = C - | ObjectiveC - | CPlusPlus - | ObjectiveCPlusPlus - deriving (Eq, Show) - -instance Monoid CDialect where - mempty = C - mappend = (<>) - -instance Semigroup CDialect where - C <> anything = anything - ObjectiveC <> CPlusPlus = ObjectiveCPlusPlus - CPlusPlus <> ObjectiveC = ObjectiveCPlusPlus - _ <> ObjectiveCPlusPlus = ObjectiveCPlusPlus - ObjectiveC <> _ = ObjectiveC - CPlusPlus <> _ = CPlusPlus - ObjectiveCPlusPlus <> _ = ObjectiveCPlusPlus - --- | A list of all file extensions which are recognized as possibly containing --- some dialect of C code. Note that this list is only for source files, --- not for header files. -cSourceExtensions :: [String] -cSourceExtensions = ["c", "i", "ii", "m", "mi", "mm", "M", "mii", "cc", "cp", - "cxx", "cpp", "CPP", "c++", "C"] - - --- | Takes a dialect of C and whether code is intended to be passed through --- the preprocessor, and returns a filename extension for containing that --- code. -cDialectFilenameExtension :: CDialect -> Bool -> String -cDialectFilenameExtension C True = "c" -cDialectFilenameExtension C False = "i" -cDialectFilenameExtension ObjectiveC True = "m" -cDialectFilenameExtension ObjectiveC False = "mi" -cDialectFilenameExtension CPlusPlus True = "cpp" -cDialectFilenameExtension CPlusPlus False = "ii" -cDialectFilenameExtension ObjectiveCPlusPlus True = "mm" -cDialectFilenameExtension ObjectiveCPlusPlus False = "mii" - - --- | Infers from a filename's extension the dialect of C which it contains, --- and whether it is intended to be passed through the preprocessor. -filenameCDialect :: String -> Maybe (CDialect, Bool) -filenameCDialect filename = do - extension <- case takeExtension filename of - '.':ext -> Just ext - _ -> Nothing - case extension of - "c" -> return (C, True) - "i" -> return (C, False) - "ii" -> return (CPlusPlus, False) - "m" -> return (ObjectiveC, True) - "mi" -> return (ObjectiveC, False) - "mm" -> return (ObjectiveCPlusPlus, True) - "M" -> return (ObjectiveCPlusPlus, True) - "mii" -> return (ObjectiveCPlusPlus, False) - "cc" -> return (CPlusPlus, True) - "cp" -> return (CPlusPlus, True) - "cxx" -> return (CPlusPlus, True) - "cpp" -> return (CPlusPlus, True) - "CPP" -> return (CPlusPlus, True) - "c++" -> return (CPlusPlus, True) - "C" -> return (CPlusPlus, True) - _ -> Nothing diff --git a/cabal/Cabal/Distribution/Simple/Command.hs b/cabal/Cabal/Distribution/Simple/Command.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/Command.hs +++ /dev/null @@ -1,555 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Command --- Copyright : Duncan Coutts 2007 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : non-portable (ExistentialQuantification) --- --- This is to do with command line handling. The Cabal command line is --- organised into a number of named sub-commands (much like darcs). The --- 'CommandUI' abstraction represents one of these sub-commands, with a name, --- description, a set of flags. Commands can be associated with actions and --- run. It handles some common stuff automatically, like the @--help@ and --- command line completion flags. It is designed to allow other tools make --- derived commands. This feature is used heavily in @cabal-install@. - -module Distribution.Simple.Command ( - - -- * Command interface - CommandUI(..), - commandShowOptions, - CommandParse(..), - commandParseArgs, - getNormalCommandDescriptions, - helpCommandUI, - - -- ** Constructing commands - ShowOrParseArgs(..), - usageDefault, - usageAlternatives, - mkCommandUI, - hiddenCommand, - - -- ** Associating actions with commands - Command, - commandAddAction, - noExtraFlags, - - -- ** Building lists of commands - CommandType(..), - CommandSpec(..), - commandFromSpec, - - -- ** Running commands - commandsRun, - --- * Option Fields - OptionField(..), Name, - --- ** Constructing Option Fields - option, multiOption, - --- ** Liftings & Projections - liftOption, liftOptionL, - --- * Option Descriptions - OptDescr(..), Description, SFlags, LFlags, OptFlags, ArgPlaceHolder, - --- ** OptDescr 'smart' constructors - MkOptDescr, - reqArg, reqArg', optArg, optArg', noArg, - boolOpt, boolOpt', choiceOpt, choiceOptFromEnum - - ) where - -import Prelude () -import Distribution.Compat.Prelude hiding (get) - -import qualified Distribution.GetOpt as GetOpt -import Distribution.ReadE -import Distribution.Simple.Utils -import Distribution.Compat.Lens (ALens', (^#), (#~)) - - -data CommandUI flags = CommandUI { - -- | The name of the command as it would be entered on the command line. - -- For example @\"build\"@. - commandName :: String, - -- | A short, one line description of the command to use in help texts. - commandSynopsis :: String, - -- | A function that maps a program name to a usage summary for this - -- command. - commandUsage :: String -> String, - -- | Additional explanation of the command to use in help texts. - commandDescription :: Maybe (String -> String), - -- | Post-Usage notes and examples in help texts - commandNotes :: Maybe (String -> String), - -- | Initial \/ empty flags - commandDefaultFlags :: flags, - -- | All the Option fields for this command - commandOptions :: ShowOrParseArgs -> [OptionField flags] - } - -data ShowOrParseArgs = ShowArgs | ParseArgs -type Name = String -type Description = String - --- | We usually have a data type for storing configuration values, where --- every field stores a configuration option, and the user sets --- the value either via command line flags or a configuration file. --- An individual OptionField models such a field, and we usually --- build a list of options associated to a configuration data type. -data OptionField a = OptionField { - optionName :: Name, - optionDescr :: [OptDescr a] } - --- | An OptionField takes one or more OptDescrs, describing the command line --- interface for the field. -data OptDescr a = ReqArg Description OptFlags ArgPlaceHolder - (ReadE (a->a)) (a -> [String]) - - | OptArg Description OptFlags ArgPlaceHolder - (ReadE (a->a)) (a->a) (a -> [Maybe String]) - - | ChoiceOpt [(Description, OptFlags, a->a, a -> Bool)] - - | BoolOpt Description OptFlags{-True-} OptFlags{-False-} - (Bool -> a -> a) (a-> Maybe Bool) - --- | Short command line option strings -type SFlags = [Char] --- | Long command line option strings -type LFlags = [String] -type OptFlags = (SFlags,LFlags) -type ArgPlaceHolder = String - - --- | Create an option taking a single OptDescr. --- No explicit Name is given for the Option, the name is the first LFlag given. -option :: SFlags -> LFlags -> Description -> get -> set -> MkOptDescr get set a - -> OptionField a -option sf lf@(n:_) d get set arg = OptionField n [arg sf lf d get set] -option _ _ _ _ _ _ = error $ "Distribution.command.option: " - ++ "An OptionField must have at least one LFlag" - --- | Create an option taking several OptDescrs. --- You will have to give the flags and description individually to the --- OptDescr constructor. -multiOption :: Name -> get -> set - -> [get -> set -> OptDescr a] -- ^MkOptDescr constructors partially - -- applied to flags and description. - -> OptionField a -multiOption n get set args = OptionField n [arg get set | arg <- args] - -type MkOptDescr get set a = SFlags -> LFlags -> Description -> get -> set - -> OptDescr a - --- | Create a string-valued command line interface. -reqArg :: Monoid b => ArgPlaceHolder -> ReadE b -> (b -> [String]) - -> MkOptDescr (a -> b) (b -> a -> a) a -reqArg ad mkflag showflag sf lf d get set = - ReqArg d (sf,lf) ad (fmap (\a b -> set (get b `mappend` a) b) mkflag) - (showflag . get) - --- | Create a string-valued command line interface with a default value. -optArg :: Monoid b => ArgPlaceHolder -> ReadE b -> b -> (b -> [Maybe String]) - -> MkOptDescr (a -> b) (b -> a -> a) a -optArg ad mkflag def showflag sf lf d get set = - OptArg d (sf,lf) ad (fmap (\a b -> set (get b `mappend` a) b) mkflag) - (\b -> set (get b `mappend` def) b) - (showflag . get) - --- | (String -> a) variant of "reqArg" -reqArg' :: Monoid b => ArgPlaceHolder -> (String -> b) -> (b -> [String]) - -> MkOptDescr (a -> b) (b -> a -> a) a -reqArg' ad mkflag showflag = - reqArg ad (succeedReadE mkflag) showflag - --- | (String -> a) variant of "optArg" -optArg' :: Monoid b => ArgPlaceHolder -> (Maybe String -> b) - -> (b -> [Maybe String]) - -> MkOptDescr (a -> b) (b -> a -> a) a -optArg' ad mkflag showflag = - optArg ad (succeedReadE (mkflag . Just)) def showflag - where def = mkflag Nothing - -noArg :: (Eq b) => b -> MkOptDescr (a -> b) (b -> a -> a) a -noArg flag sf lf d = choiceOpt [(flag, (sf,lf), d)] sf lf d - -boolOpt :: (b -> Maybe Bool) -> (Bool -> b) -> SFlags -> SFlags - -> MkOptDescr (a -> b) (b -> a -> a) a -boolOpt g s sfT sfF _sf _lf@(n:_) d get set = - BoolOpt d (sfT, ["enable-"++n]) (sfF, ["disable-"++n]) (set.s) (g.get) -boolOpt _ _ _ _ _ _ _ _ _ = error - "Distribution.Simple.Setup.boolOpt: unreachable" - -boolOpt' :: (b -> Maybe Bool) -> (Bool -> b) -> OptFlags -> OptFlags - -> MkOptDescr (a -> b) (b -> a -> a) a -boolOpt' g s ffT ffF _sf _lf d get set = BoolOpt d ffT ffF (set.s) (g . get) - --- | create a Choice option -choiceOpt :: Eq b => [(b,OptFlags,Description)] - -> MkOptDescr (a -> b) (b -> a -> a) a -choiceOpt aa_ff _sf _lf _d get set = ChoiceOpt alts - where alts = [(d,flags, set alt, (==alt) . get) | (alt,flags,d) <- aa_ff] - --- | create a Choice option out of an enumeration type. --- As long flags, the Show output is used. As short flags, the first character --- which does not conflict with a previous one is used. -choiceOptFromEnum :: (Bounded b, Enum b, Show b, Eq b) => - MkOptDescr (a -> b) (b -> a -> a) a -choiceOptFromEnum _sf _lf d get = - choiceOpt [ (x, (sf, [map toLower $ show x]), d') - | (x, sf) <- sflags' - , let d' = d ++ show x] - _sf _lf d get - where sflags' = foldl f [] [firstOne..] - f prev x = let prevflags = concatMap snd prev in - prev ++ take 1 [(x, [toLower sf]) - | sf <- show x, isAlpha sf - , toLower sf `notElem` prevflags] - firstOne = minBound `asTypeOf` get undefined - -commandGetOpts :: ShowOrParseArgs -> CommandUI flags - -> [GetOpt.OptDescr (flags -> flags)] -commandGetOpts showOrParse command = - concatMap viewAsGetOpt (commandOptions command showOrParse) - -viewAsGetOpt :: OptionField a -> [GetOpt.OptDescr (a->a)] -viewAsGetOpt (OptionField _n aa) = concatMap optDescrToGetOpt aa - where - optDescrToGetOpt (ReqArg d (cs,ss) arg_desc set _) = - [GetOpt.Option cs ss (GetOpt.ReqArg set' arg_desc) d] - where set' = readEOrFail set - optDescrToGetOpt (OptArg d (cs,ss) arg_desc set def _) = - [GetOpt.Option cs ss (GetOpt.OptArg set' arg_desc) d] - where set' Nothing = def - set' (Just txt) = readEOrFail set txt - optDescrToGetOpt (ChoiceOpt alts) = - [GetOpt.Option sf lf (GetOpt.NoArg set) d | (d,(sf,lf),set,_) <- alts ] - optDescrToGetOpt (BoolOpt d (sfT, lfT) ([], []) set _) = - [ GetOpt.Option sfT lfT (GetOpt.NoArg (set True)) d ] - optDescrToGetOpt (BoolOpt d ([], []) (sfF, lfF) set _) = - [ GetOpt.Option sfF lfF (GetOpt.NoArg (set False)) d ] - optDescrToGetOpt (BoolOpt d (sfT,lfT) (sfF, lfF) set _) = - [ GetOpt.Option sfT lfT (GetOpt.NoArg (set True)) ("Enable " ++ d) - , GetOpt.Option sfF lfF (GetOpt.NoArg (set False)) ("Disable " ++ d) ] - -getCurrentChoice :: OptDescr a -> a -> [String] -getCurrentChoice (ChoiceOpt alts) a = - [ lf | (_,(_sf,lf:_), _, currentChoice) <- alts, currentChoice a] - -getCurrentChoice _ _ = error "Command.getChoice: expected a Choice OptDescr" - - -liftOption :: (b -> a) -> (a -> (b -> b)) -> OptionField a -> OptionField b -liftOption get' set' opt = - opt { optionDescr = liftOptDescr get' set' `map` optionDescr opt} - --- | @since 3.4.0.0 -liftOptionL :: ALens' b a -> OptionField a -> OptionField b -liftOptionL l = liftOption (^# l) (l #~) - - -liftOptDescr :: (b -> a) -> (a -> (b -> b)) -> OptDescr a -> OptDescr b -liftOptDescr get' set' (ChoiceOpt opts) = - ChoiceOpt [ (d, ff, liftSet get' set' set , (get . get')) - | (d, ff, set, get) <- opts] - -liftOptDescr get' set' (OptArg d ff ad set def get) = - OptArg d ff ad (liftSet get' set' `fmap` set) - (liftSet get' set' def) (get . get') - -liftOptDescr get' set' (ReqArg d ff ad set get) = - ReqArg d ff ad (liftSet get' set' `fmap` set) (get . get') - -liftOptDescr get' set' (BoolOpt d ffT ffF set get) = - BoolOpt d ffT ffF (liftSet get' set' . set) (get . get') - -liftSet :: (b -> a) -> (a -> (b -> b)) -> (a -> a) -> b -> b -liftSet get' set' set x = set' (set $ get' x) x - --- | Show flags in the standard long option command line format -commandShowOptions :: CommandUI flags -> flags -> [String] -commandShowOptions command v = concat - [ showOptDescr v od | o <- commandOptions command ParseArgs - , od <- optionDescr o] - where - maybePrefix [] = [] - maybePrefix (lOpt:_) = ["--" ++ lOpt] - - showOptDescr :: a -> OptDescr a -> [String] - showOptDescr x (BoolOpt _ (_,lfTs) (_,lfFs) _ enabled) - = case enabled x of - Nothing -> [] - Just True -> maybePrefix lfTs - Just False -> maybePrefix lfFs - showOptDescr x c@ChoiceOpt{} - = ["--" ++ val | val <- getCurrentChoice c x] - showOptDescr x (ReqArg _ (_ssff,lf:_) _ _ showflag) - = [ "--"++lf++"="++flag - | flag <- showflag x ] - showOptDescr x (OptArg _ (_ssff,lf:_) _ _ _ showflag) - = [ case flag of - Just s -> "--"++lf++"="++s - Nothing -> "--"++lf - | flag <- showflag x ] - showOptDescr _ _ - = error "Distribution.Simple.Command.showOptDescr: unreachable" - - -commandListOptions :: CommandUI flags -> [String] -commandListOptions command = - concatMap listOption $ - addCommonFlags ShowArgs $ -- This is a slight hack, we don't want - -- "--list-options" showing up in the - -- list options output, so use ShowArgs - commandGetOpts ShowArgs command - where - listOption (GetOpt.Option shortNames longNames _ _) = - [ "-" ++ [name] | name <- shortNames ] - ++ [ "--" ++ name | name <- longNames ] - --- | The help text for this command with descriptions of all the options. -commandHelp :: CommandUI flags -> String -> String -commandHelp command pname = - commandSynopsis command - ++ "\n\n" - ++ commandUsage command pname - ++ ( case commandDescription command of - Nothing -> "" - Just desc -> '\n': desc pname) - ++ "\n" - ++ ( if cname == "" - then "Global flags:" - else "Flags for " ++ cname ++ ":" ) - ++ ( GetOpt.usageInfo "" - . addCommonFlags ShowArgs - $ commandGetOpts ShowArgs command ) - ++ ( case commandNotes command of - Nothing -> "" - Just notes -> '\n': notes pname) - where cname = commandName command - --- | Default "usage" documentation text for commands. -usageDefault :: String -> String -> String -usageDefault name pname = - "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n\n" - ++ "Flags for " ++ name ++ ":" - --- | Create "usage" documentation from a list of parameter --- configurations. -usageAlternatives :: String -> [String] -> String -> String -usageAlternatives name strs pname = unlines - [ start ++ pname ++ " " ++ name ++ " " ++ s - | let starts = "Usage: " : repeat " or: " - , (start, s) <- zip starts strs - ] - --- | Make a Command from standard 'GetOpt' options. -mkCommandUI :: String -- ^ name - -> String -- ^ synopsis - -> [String] -- ^ usage alternatives - -> flags -- ^ initial\/empty flags - -> (ShowOrParseArgs -> [OptionField flags]) -- ^ options - -> CommandUI flags -mkCommandUI name synopsis usages flags options = CommandUI - { commandName = name - , commandSynopsis = synopsis - , commandDescription = Nothing - , commandNotes = Nothing - , commandUsage = usageAlternatives name usages - , commandDefaultFlags = flags - , commandOptions = options - } - --- | Common flags that apply to every command -data CommonFlag = HelpFlag | ListOptionsFlag - -commonFlags :: ShowOrParseArgs -> [GetOpt.OptDescr CommonFlag] -commonFlags showOrParseArgs = case showOrParseArgs of - ShowArgs -> [help] - ParseArgs -> [help, list] - where - help = GetOpt.Option helpShortFlags ["help"] (GetOpt.NoArg HelpFlag) - "Show this help text" - helpShortFlags = case showOrParseArgs of - ShowArgs -> ['h'] - ParseArgs -> ['h', '?'] - list = GetOpt.Option [] ["list-options"] (GetOpt.NoArg ListOptionsFlag) - "Print a list of command line flags" - -addCommonFlags :: ShowOrParseArgs - -> [GetOpt.OptDescr a] - -> [GetOpt.OptDescr (Either CommonFlag a)] -addCommonFlags showOrParseArgs options = - map (fmapOptDesc Left) (commonFlags showOrParseArgs) - ++ map (fmapOptDesc Right) options - where fmapOptDesc f (GetOpt.Option s l d m) = - GetOpt.Option s l (fmapArgDesc f d) m - fmapArgDesc f (GetOpt.NoArg a) = GetOpt.NoArg (f a) - fmapArgDesc f (GetOpt.ReqArg s d) = GetOpt.ReqArg (f . s) d - fmapArgDesc f (GetOpt.OptArg s d) = GetOpt.OptArg (f . s) d - --- | Parse a bunch of command line arguments --- -commandParseArgs :: CommandUI flags - -> Bool -- ^ Is the command a global or subcommand? - -> [String] - -> CommandParse (flags -> flags, [String]) -commandParseArgs command global args = - let options = addCommonFlags ParseArgs - $ commandGetOpts ParseArgs command - order | global = GetOpt.RequireOrder - | otherwise = GetOpt.Permute - in case GetOpt.getOpt' order options args of - (flags, _, _, _) - | any listFlag flags -> CommandList (commandListOptions command) - | any helpFlag flags -> CommandHelp (commandHelp command) - where listFlag (Left ListOptionsFlag) = True; listFlag _ = False - helpFlag (Left HelpFlag) = True; helpFlag _ = False - (flags, opts, opts', []) - | global || null opts' -> CommandReadyToGo (accum flags, mix opts opts') - | otherwise -> CommandErrors (unrecognised opts') - (_, _, _, errs) -> CommandErrors errs - - where -- Note: It is crucial to use reverse function composition here or to - -- reverse the flags here as we want to process the flags left to right - -- but data flow in function composition is right to left. - accum flags = foldr (flip (.)) id [ f | Right f <- flags ] - unrecognised opts = [ "unrecognized " - ++ "'" ++ (commandName command) ++ "'" - ++ " option `" ++ opt ++ "'\n" - | opt <- opts ] - -- For unrecognised global flags we put them in the position just after - -- the command, if there is one. This gives us a chance to parse them - -- as sub-command rather than global flags. - mix [] ys = ys - mix (x:xs) ys = x:ys++xs - -data CommandParse flags = CommandHelp (String -> String) - | CommandList [String] - | CommandErrors [String] - | CommandReadyToGo flags -instance Functor CommandParse where - fmap _ (CommandHelp help) = CommandHelp help - fmap _ (CommandList opts) = CommandList opts - fmap _ (CommandErrors errs) = CommandErrors errs - fmap f (CommandReadyToGo flags) = CommandReadyToGo (f flags) - - -data CommandType = NormalCommand | HiddenCommand -data Command action = - Command String String ([String] -> CommandParse action) CommandType - --- | Mark command as hidden. Hidden commands don't show up in the 'progname --- help' or 'progname --help' output. -hiddenCommand :: Command action -> Command action -hiddenCommand (Command name synopsys f _cmdType) = - Command name synopsys f HiddenCommand - -commandAddAction :: CommandUI flags - -> (flags -> [String] -> action) - -> Command action -commandAddAction command action = - Command (commandName command) - (commandSynopsis command) - (fmap (uncurry applyDefaultArgs) . commandParseArgs command False) - NormalCommand - - where applyDefaultArgs mkflags args = - let flags = mkflags (commandDefaultFlags command) - in action flags args - -commandsRun :: CommandUI a - -> [Command action] - -> [String] - -> CommandParse (a, CommandParse action) -commandsRun globalCommand commands args = - case commandParseArgs globalCommand True args of - CommandHelp help -> CommandHelp help - CommandList opts -> CommandList (opts ++ commandNames) - CommandErrors errs -> CommandErrors errs - CommandReadyToGo (mkflags, args') -> case args' of - ("help":cmdArgs) -> handleHelpCommand cmdArgs - (name:cmdArgs) -> case lookupCommand name of - [Command _ _ action _] - -> CommandReadyToGo (flags, action cmdArgs) - _ -> CommandReadyToGo (flags, badCommand name) - [] -> CommandReadyToGo (flags, noCommand) - where flags = mkflags (commandDefaultFlags globalCommand) - - where - lookupCommand cname = [ cmd | cmd@(Command cname' _ _ _) <- commands' - , cname' == cname ] - noCommand = CommandErrors ["no command given (try --help)\n"] - badCommand cname = CommandErrors ["unrecognised command: " ++ cname - ++ " (try --help)\n"] - commands' = commands ++ [commandAddAction helpCommandUI undefined] - commandNames = [ name | (Command name _ _ NormalCommand) <- commands' ] - - -- A bit of a hack: support "prog help" as a synonym of "prog --help" - -- furthermore, support "prog help command" as "prog command --help" - handleHelpCommand cmdArgs = - case commandParseArgs helpCommandUI True cmdArgs of - CommandHelp help -> CommandHelp help - CommandList list -> CommandList (list ++ commandNames) - CommandErrors _ -> CommandHelp globalHelp - CommandReadyToGo (_,[]) -> CommandHelp globalHelp - CommandReadyToGo (_,(name:cmdArgs')) -> - case lookupCommand name of - [Command _ _ action _] -> - case action ("--help":cmdArgs') of - CommandHelp help -> CommandHelp help - CommandList _ -> CommandList [] - _ -> CommandHelp globalHelp - _ -> badCommand name - - where globalHelp = commandHelp globalCommand - --- | Utility function, many commands do not accept additional flags. This --- action fails with a helpful error message if the user supplies any extra. --- -noExtraFlags :: [String] -> IO () -noExtraFlags [] = return () -noExtraFlags extraFlags = - dieNoVerbosity $ "Unrecognised flags: " ++ intercalate ", " extraFlags ---TODO: eliminate this function and turn it into a variant on commandAddAction --- instead like commandAddActionNoArgs that doesn't supply the [String] - --- | Helper function for creating globalCommand description -getNormalCommandDescriptions :: [Command action] -> [(String, String)] -getNormalCommandDescriptions cmds = - [ (name, description) - | Command name description _ NormalCommand <- cmds ] - -helpCommandUI :: CommandUI () -helpCommandUI = - (mkCommandUI - "help" - "Help about commands." - ["[FLAGS]", "COMMAND [FLAGS]"] - () - (const [])) - { - commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " help help\n" - ++ " Oh, appararently you already know this.\n" - } - --- | wraps a @CommandUI@ together with a function that turns it into a @Command@. --- By hiding the type of flags for the UI allows construction of a list of all UIs at the --- top level of the program. That list can then be used for generation of manual page --- as well as for executing the selected command. -data CommandSpec action - = forall flags. CommandSpec (CommandUI flags) (CommandUI flags -> Command action) CommandType - -commandFromSpec :: CommandSpec a -> Command a -commandFromSpec (CommandSpec ui action _) = action ui diff --git a/cabal/Cabal/Distribution/Simple/Compiler.hs b/cabal/Cabal/Distribution/Simple/Compiler.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/Compiler.hs +++ /dev/null @@ -1,453 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveDataTypeable #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Compiler --- Copyright : Isaac Jones 2003-2004 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This should be a much more sophisticated abstraction than it is. Currently --- it's just a bit of data about the compiler, like its flavour and name and --- version. The reason it's just data is because currently it has to be in --- 'Read' and 'Show' so it can be saved along with the 'LocalBuildInfo'. The --- only interesting bit of info it contains is a mapping between language --- extensions and compiler command line flags. This module also defines a --- 'PackageDB' type which is used to refer to package databases. Most compilers --- only know about a single global package collection but GHC has a global and --- per-user one and it lets you create arbitrary other package databases. We do --- not yet fully support this latter feature. - -module Distribution.Simple.Compiler ( - -- * Haskell implementations - module Distribution.Compiler, - Compiler(..), - showCompilerId, showCompilerIdWithAbi, - compilerFlavor, compilerVersion, - compilerCompatFlavor, - compilerCompatVersion, - compilerInfo, - - -- * Support for package databases - PackageDB(..), - PackageDBStack, - registrationPackageDB, - absolutePackageDBPaths, - absolutePackageDBPath, - - -- * Support for optimisation levels - OptimisationLevel(..), - flagToOptimisationLevel, - - -- * Support for debug info levels - DebugInfoLevel(..), - flagToDebugInfoLevel, - - -- * Support for language extensions - CompilerFlag, - languageToFlags, - unsupportedLanguages, - extensionsToFlags, - unsupportedExtensions, - parmakeSupported, - reexportedModulesSupported, - renamingPackageFlagsSupported, - unifiedIPIDRequired, - packageKeySupported, - unitIdSupported, - coverageSupported, - profilingSupported, - backpackSupported, - arResponseFilesSupported, - libraryDynDirSupported, - libraryVisibilitySupported, - - -- * Support for profiling detail levels - ProfDetailLevel(..), - knownProfDetailLevels, - flagToProfDetailLevel, - showProfDetailLevel, - ) where - -import Prelude () -import Distribution.Compat.Prelude -import Distribution.Pretty - -import Distribution.Compiler -import Distribution.Version -import Language.Haskell.Extension -import Distribution.Simple.Utils - -import qualified Data.Map as Map (lookup) -import System.Directory (canonicalizePath) - -data Compiler = Compiler { - compilerId :: CompilerId, - -- ^ Compiler flavour and version. - compilerAbiTag :: AbiTag, - -- ^ Tag for distinguishing incompatible ABI's on the same - -- architecture/os. - compilerCompat :: [CompilerId], - -- ^ Other implementations that this compiler claims to be - -- compatible with. - compilerLanguages :: [(Language, CompilerFlag)], - -- ^ Supported language standards. - compilerExtensions :: [(Extension, Maybe CompilerFlag)], - -- ^ Supported extensions. - compilerProperties :: Map String String - -- ^ A key-value map for properties not covered by the above fields. - } - deriving (Eq, Generic, Typeable, Show, Read) - -instance Binary Compiler -instance Structured Compiler - -showCompilerId :: Compiler -> String -showCompilerId = prettyShow . compilerId - -showCompilerIdWithAbi :: Compiler -> String -showCompilerIdWithAbi comp = - prettyShow (compilerId comp) ++ - case compilerAbiTag comp of - NoAbiTag -> [] - AbiTag xs -> '-':xs - -compilerFlavor :: Compiler -> CompilerFlavor -compilerFlavor = (\(CompilerId f _) -> f) . compilerId - -compilerVersion :: Compiler -> Version -compilerVersion = (\(CompilerId _ v) -> v) . compilerId - - --- | Is this compiler compatible with the compiler flavour we're interested in? --- --- For example this checks if the compiler is actually GHC or is another --- compiler that claims to be compatible with some version of GHC, e.g. GHCJS. --- --- > if compilerCompatFlavor GHC compiler then ... else ... --- -compilerCompatFlavor :: CompilerFlavor -> Compiler -> Bool -compilerCompatFlavor flavor comp = - flavor == compilerFlavor comp - || flavor `elem` [ flavor' | CompilerId flavor' _ <- compilerCompat comp ] - - --- | Is this compiler compatible with the compiler flavour we're interested in, --- and if so what version does it claim to be compatible with. --- --- For example this checks if the compiler is actually GHC-7.x or is another --- compiler that claims to be compatible with some GHC-7.x version. --- --- > case compilerCompatVersion GHC compiler of --- > Just (Version (7:_)) -> ... --- > _ -> ... --- -compilerCompatVersion :: CompilerFlavor -> Compiler -> Maybe Version -compilerCompatVersion flavor comp - | compilerFlavor comp == flavor = Just (compilerVersion comp) - | otherwise = - listToMaybe [ v | CompilerId fl v <- compilerCompat comp, fl == flavor ] - -compilerInfo :: Compiler -> CompilerInfo -compilerInfo c = CompilerInfo (compilerId c) - (compilerAbiTag c) - (Just . compilerCompat $ c) - (Just . map fst . compilerLanguages $ c) - (Just . map fst . compilerExtensions $ c) - --- ------------------------------------------------------------ --- * Package databases --- ------------------------------------------------------------ - --- |Some compilers have a notion of a database of available packages. --- For some there is just one global db of packages, other compilers --- support a per-user or an arbitrary db specified at some location in --- the file system. This can be used to build isloated environments of --- packages, for example to build a collection of related packages --- without installing them globally. --- -data PackageDB = GlobalPackageDB - | UserPackageDB - | SpecificPackageDB FilePath - deriving (Eq, Generic, Ord, Show, Read, Typeable) - -instance Binary PackageDB -instance Structured PackageDB - --- | We typically get packages from several databases, and stack them --- together. This type lets us be explicit about that stacking. For example --- typical stacks include: --- --- > [GlobalPackageDB] --- > [GlobalPackageDB, UserPackageDB] --- > [GlobalPackageDB, SpecificPackageDB "package.conf.inplace"] --- --- Note that the 'GlobalPackageDB' is invariably at the bottom since it --- contains the rts, base and other special compiler-specific packages. --- --- We are not restricted to using just the above combinations. In particular --- we can use several custom package dbs and the user package db together. --- --- When it comes to writing, the top most (last) package is used. --- -type PackageDBStack = [PackageDB] - --- | Return the package that we should register into. This is the package db at --- the top of the stack. --- -registrationPackageDB :: PackageDBStack -> PackageDB -registrationPackageDB dbs = case safeLast dbs of - Nothing -> error "internal error: empty package db set" - Just p -> p - --- | Make package paths absolute - - -absolutePackageDBPaths :: PackageDBStack -> IO PackageDBStack -absolutePackageDBPaths = traverse absolutePackageDBPath - -absolutePackageDBPath :: PackageDB -> IO PackageDB -absolutePackageDBPath GlobalPackageDB = return GlobalPackageDB -absolutePackageDBPath UserPackageDB = return UserPackageDB -absolutePackageDBPath (SpecificPackageDB db) = - SpecificPackageDB `liftM` canonicalizePath db - --- ------------------------------------------------------------ --- * Optimisation levels --- ------------------------------------------------------------ - --- | Some compilers support optimising. Some have different levels. --- For compilers that do not the level is just capped to the level --- they do support. --- -data OptimisationLevel = NoOptimisation - | NormalOptimisation - | MaximumOptimisation - deriving (Bounded, Enum, Eq, Generic, Read, Show, Typeable) - -instance Binary OptimisationLevel -instance Structured OptimisationLevel - -flagToOptimisationLevel :: Maybe String -> OptimisationLevel -flagToOptimisationLevel Nothing = NormalOptimisation -flagToOptimisationLevel (Just s) = case reads s of - [(i, "")] - | i >= fromEnum (minBound :: OptimisationLevel) - && i <= fromEnum (maxBound :: OptimisationLevel) - -> toEnum i - | otherwise -> error $ "Bad optimisation level: " ++ show i - ++ ". Valid values are 0..2" - _ -> error $ "Can't parse optimisation level " ++ s - --- ------------------------------------------------------------ --- * Debug info levels --- ------------------------------------------------------------ - --- | Some compilers support emitting debug info. Some have different --- levels. For compilers that do not the level is just capped to the --- level they do support. --- -data DebugInfoLevel = NoDebugInfo - | MinimalDebugInfo - | NormalDebugInfo - | MaximalDebugInfo - deriving (Bounded, Enum, Eq, Generic, Read, Show, Typeable) - -instance Binary DebugInfoLevel -instance Structured DebugInfoLevel - -flagToDebugInfoLevel :: Maybe String -> DebugInfoLevel -flagToDebugInfoLevel Nothing = NormalDebugInfo -flagToDebugInfoLevel (Just s) = case reads s of - [(i, "")] - | i >= fromEnum (minBound :: DebugInfoLevel) - && i <= fromEnum (maxBound :: DebugInfoLevel) - -> toEnum i - | otherwise -> error $ "Bad debug info level: " ++ show i - ++ ". Valid values are 0..3" - _ -> error $ "Can't parse debug info level " ++ s - --- ------------------------------------------------------------ --- * Languages and Extensions --- ------------------------------------------------------------ - -unsupportedLanguages :: Compiler -> [Language] -> [Language] -unsupportedLanguages comp langs = - [ lang | lang <- langs - , isNothing (languageToFlag comp lang) ] - -languageToFlags :: Compiler -> Maybe Language -> [CompilerFlag] -languageToFlags comp = filter (not . null) - . catMaybes . map (languageToFlag comp) - . maybe [Haskell98] (\x->[x]) - -languageToFlag :: Compiler -> Language -> Maybe CompilerFlag -languageToFlag comp ext = lookup ext (compilerLanguages comp) - - --- |For the given compiler, return the extensions it does not support. -unsupportedExtensions :: Compiler -> [Extension] -> [Extension] -unsupportedExtensions comp exts = - [ ext | ext <- exts - , isNothing (extensionToFlag' comp ext) ] - -type CompilerFlag = String - --- |For the given compiler, return the flags for the supported extensions. -extensionsToFlags :: Compiler -> [Extension] -> [CompilerFlag] -extensionsToFlags comp = nub . filter (not . null) - . catMaybes . map (extensionToFlag comp) - --- | Looks up the flag for a given extension, for a given compiler. --- Ignores the subtlety of extensions which lack associated flags. -extensionToFlag :: Compiler -> Extension -> Maybe CompilerFlag -extensionToFlag comp ext = join (extensionToFlag' comp ext) - --- | Looks up the flag for a given extension, for a given compiler. --- However, the extension may be valid for the compiler but not have a flag. --- For example, NondecreasingIndentation is enabled by default on GHC 7.0.4, --- hence it is considered a supported extension but not an accepted flag. --- --- The outer layer of Maybe indicates whether the extensions is supported, while --- the inner layer indicates whether it has a flag. --- When building strings, it is often more convenient to use 'extensionToFlag', --- which ignores the difference. -extensionToFlag' :: Compiler -> Extension -> Maybe (Maybe CompilerFlag) -extensionToFlag' comp ext = lookup ext (compilerExtensions comp) - --- | Does this compiler support parallel --make mode? -parmakeSupported :: Compiler -> Bool -parmakeSupported = ghcSupported "Support parallel --make" - --- | Does this compiler support reexported-modules? -reexportedModulesSupported :: Compiler -> Bool -reexportedModulesSupported = ghcSupported "Support reexported-modules" - --- | Does this compiler support thinning/renaming on package flags? -renamingPackageFlagsSupported :: Compiler -> Bool -renamingPackageFlagsSupported = ghcSupported - "Support thinning and renaming package flags" - --- | Does this compiler have unified IPIDs (so no package keys) -unifiedIPIDRequired :: Compiler -> Bool -unifiedIPIDRequired = ghcSupported "Requires unified installed package IDs" - --- | Does this compiler support package keys? -packageKeySupported :: Compiler -> Bool -packageKeySupported = ghcSupported "Uses package keys" - --- | Does this compiler support unit IDs? -unitIdSupported :: Compiler -> Bool -unitIdSupported = ghcSupported "Uses unit IDs" - --- | Does this compiler support Backpack? -backpackSupported :: Compiler -> Bool -backpackSupported = ghcSupported "Support Backpack" - --- | Does this compiler support a package database entry with: --- "dynamic-library-dirs"? -libraryDynDirSupported :: Compiler -> Bool -libraryDynDirSupported comp = case compilerFlavor comp of - GHC -> - -- Not just v >= mkVersion [8,0,1,20161022], as there - -- are many GHC 8.1 nightlies which don't support this. - ((v >= mkVersion [8,0,1,20161022] && v < mkVersion [8,1]) || - v >= mkVersion [8,1,20161021]) - _ -> False - where - v = compilerVersion comp - --- | Does this compiler's "ar" command supports response file --- arguments (i.e. @file-style arguments). -arResponseFilesSupported :: Compiler -> Bool -arResponseFilesSupported = ghcSupported "ar supports at file" - --- | Does this compiler support Haskell program coverage? -coverageSupported :: Compiler -> Bool -coverageSupported comp = - case compilerFlavor comp of - GHC -> True - GHCJS -> True - _ -> False - --- | Does this compiler support profiling? -profilingSupported :: Compiler -> Bool -profilingSupported comp = - case compilerFlavor comp of - GHC -> True - GHCJS -> True - _ -> False - --- | Does this compiler support a package database entry with: --- "visibility"? -libraryVisibilitySupported :: Compiler -> Bool -libraryVisibilitySupported comp = case compilerFlavor comp of - GHC -> v >= mkVersion [8,8] - _ -> False - where - v = compilerVersion comp - --- | Utility function for GHC only features -ghcSupported :: String -> Compiler -> Bool -ghcSupported key comp = - case compilerFlavor comp of - GHC -> checkProp - GHCJS -> checkProp - _ -> False - where checkProp = - case Map.lookup key (compilerProperties comp) of - Just "YES" -> True - _ -> False - --- ------------------------------------------------------------ --- * Profiling detail level --- ------------------------------------------------------------ - --- | Some compilers (notably GHC) support profiling and can instrument --- programs so the system can account costs to different functions. There are --- different levels of detail that can be used for this accounting. --- For compilers that do not support this notion or the particular detail --- levels, this is either ignored or just capped to some similar level --- they do support. --- -data ProfDetailLevel = ProfDetailNone - | ProfDetailDefault - | ProfDetailExportedFunctions - | ProfDetailToplevelFunctions - | ProfDetailAllFunctions - | ProfDetailOther String - deriving (Eq, Generic, Read, Show, Typeable) - -instance Binary ProfDetailLevel -instance Structured ProfDetailLevel - -flagToProfDetailLevel :: String -> ProfDetailLevel -flagToProfDetailLevel "" = ProfDetailDefault -flagToProfDetailLevel s = - case lookup (lowercase s) - [ (name, value) - | (primary, aliases, value) <- knownProfDetailLevels - , name <- primary : aliases ] - of Just value -> value - Nothing -> ProfDetailOther s - -knownProfDetailLevels :: [(String, [String], ProfDetailLevel)] -knownProfDetailLevels = - [ ("default", [], ProfDetailDefault) - , ("none", [], ProfDetailNone) - , ("exported-functions", ["exported"], ProfDetailExportedFunctions) - , ("toplevel-functions", ["toplevel", "top"], ProfDetailToplevelFunctions) - , ("all-functions", ["all"], ProfDetailAllFunctions) - ] - -showProfDetailLevel :: ProfDetailLevel -> String -showProfDetailLevel dl = case dl of - ProfDetailNone -> "none" - ProfDetailDefault -> "default" - ProfDetailExportedFunctions -> "exported-functions" - ProfDetailToplevelFunctions -> "toplevel-functions" - ProfDetailAllFunctions -> "all-functions" - ProfDetailOther other -> other diff --git a/cabal/Cabal/Distribution/Simple/Configure.hs b/cabal/Cabal/Distribution/Simple/Configure.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/Configure.hs +++ /dev/null @@ -1,2093 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE NoMonoLocalBinds #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Configure --- Copyright : Isaac Jones 2003-2005 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This deals with the /configure/ phase. It provides the 'configure' action --- which is given the package description and configure flags. It then tries --- to: configure the compiler; resolves any conditionals in the package --- description; resolve the package dependencies; check if all the extensions --- used by this package are supported by the compiler; check that all the build --- tools are available (including version checks if appropriate); checks for --- any required @pkg-config@ packages (updating the 'BuildInfo' with the --- results) --- --- Then based on all this it saves the info in the 'LocalBuildInfo' and writes --- it out to the @dist\/setup-config@ file. It also displays various details to --- the user, the amount of information displayed depending on the verbosity --- level. - -module Distribution.Simple.Configure - ( configure - , writePersistBuildConfig - , getConfigStateFile - , getPersistBuildConfig - , checkPersistBuildConfigOutdated - , tryGetPersistBuildConfig - , maybeGetPersistBuildConfig - , findDistPref, findDistPrefOrDefault - , getInternalLibraries - , computeComponentId - , computeCompatPackageKey - , localBuildInfoFile - , getInstalledPackages - , getInstalledPackagesMonitorFiles - , getPackageDBContents - , configCompilerEx, configCompilerAuxEx - , computeEffectiveProfiling - , ccLdOptionsBuildInfo - , checkForeignDeps - , interpretPackageDbFlags - , ConfigStateFileError(..) - , tryGetConfigStateFile - , platformDefines, - ) where - -import qualified Prelude as Unsafe (tail) -import Distribution.Compat.Prelude - -import Distribution.Compiler -import Distribution.Types.IncludeRenaming -import Distribution.Utils.NubList -import Distribution.Simple.Compiler -import Distribution.Simple.PreProcess -import Distribution.Package -import qualified Distribution.InstalledPackageInfo as IPI -import Distribution.InstalledPackageInfo (InstalledPackageInfo) -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.PackageIndex (InstalledPackageIndex) -import Distribution.PackageDescription -import Distribution.PackageDescription.PrettyPrint -import Distribution.PackageDescription.Configuration -import Distribution.PackageDescription.Check hiding (doesFileExist) -import Distribution.Simple.BuildToolDepends -import Distribution.Simple.Program -import Distribution.Simple.Setup as Setup -import Distribution.Simple.BuildTarget -import Distribution.Simple.LocalBuildInfo -import Distribution.Types.PackageVersionConstraint -import Distribution.Types.PkgconfigVersion -import Distribution.Types.PkgconfigVersionRange -import Distribution.Types.LocalBuildInfo -import Distribution.Types.ComponentRequestedSpec -import Distribution.Types.GivenComponent -import Distribution.Types.Mixin -import Distribution.Simple.Utils -import Distribution.System -import Distribution.Version -import Distribution.Verbosity -import qualified Distribution.Compat.Graph as Graph -import Distribution.Compat.Stack -import Distribution.Backpack.Configure -import Distribution.Backpack.DescribeUnitId -import Distribution.Backpack.PreExistingComponent -import Distribution.Backpack.ConfiguredComponent (newPackageDepsBehaviour) -import Distribution.Backpack.Id -import Distribution.Utils.LogProgress - -import qualified Distribution.Simple.GHC as GHC -import qualified Distribution.Simple.GHCJS as GHCJS -import qualified Distribution.Simple.UHC as UHC -import qualified Distribution.Simple.HaskellSuite as HaskellSuite - -import Control.Exception - ( try ) -import Data.List.NonEmpty ( nonEmpty ) -import Distribution.Utils.Structured ( structuredDecodeOrFailIO, structuredEncode ) -import Distribution.Compat.Directory ( listDirectory ) -import Data.ByteString.Lazy ( ByteString ) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy.Char8 as BLC8 -import Data.List - ( (\\), inits, stripPrefix, intersect, dropWhileEnd ) -import qualified Data.Map as Map -import System.Directory - ( canonicalizePath, createDirectoryIfMissing, doesFileExist - , getTemporaryDirectory, removeFile) -import System.FilePath - ( (), isAbsolute, takeDirectory ) -import Distribution.Compat.Directory - ( doesPathExist ) -import qualified System.Info - ( compilerName, compilerVersion ) -import System.IO - ( hPutStrLn, hClose ) -import Distribution.Pretty - ( pretty, defaultStyle, prettyShow ) -import Distribution.Parsec - ( simpleParsec ) -import Text.PrettyPrint - ( Doc, ($+$), char, comma, hsep, nest - , punctuate, quotes, render, renderStyle, sep, text ) -import Distribution.Compat.Environment ( lookupEnv ) - -import qualified Data.Set as Set -import qualified Distribution.Compat.NonEmptySet as NES - - -type UseExternalInternalDeps = Bool - --- | The errors that can be thrown when reading the @setup-config@ file. -data ConfigStateFileError - = ConfigStateFileNoHeader -- ^ No header found. - | ConfigStateFileBadHeader -- ^ Incorrect header. - | ConfigStateFileNoParse -- ^ Cannot parse file contents. - | ConfigStateFileMissing -- ^ No file! - | ConfigStateFileBadVersion PackageIdentifier PackageIdentifier - (Either ConfigStateFileError LocalBuildInfo) -- ^ Mismatched version. - deriving (Typeable) - --- | Format a 'ConfigStateFileError' as a user-facing error message. -dispConfigStateFileError :: ConfigStateFileError -> Doc -dispConfigStateFileError ConfigStateFileNoHeader = - text "Saved package config file header is missing." - <+> text "Re-run the 'configure' command." -dispConfigStateFileError ConfigStateFileBadHeader = - text "Saved package config file header is corrupt." - <+> text "Re-run the 'configure' command." -dispConfigStateFileError ConfigStateFileNoParse = - text "Saved package config file is corrupt." - <+> text "Re-run the 'configure' command." -dispConfigStateFileError ConfigStateFileMissing = - text "Run the 'configure' command first." -dispConfigStateFileError (ConfigStateFileBadVersion oldCabal oldCompiler _) = - text "Saved package config file is outdated:" - $+$ badCabal $+$ badCompiler - $+$ text "Re-run the 'configure' command." - where - badCabal = - text "• the Cabal version changed from" - <+> pretty oldCabal <+> "to" <+> pretty currentCabalId - badCompiler - | oldCompiler == currentCompilerId = mempty - | otherwise = - text "• the compiler changed from" - <+> pretty oldCompiler <+> "to" <+> pretty currentCompilerId - -instance Show ConfigStateFileError where - show = renderStyle defaultStyle . dispConfigStateFileError - -instance Exception ConfigStateFileError - --- | Read the 'localBuildInfoFile'. Throw an exception if the file is --- missing, if the file cannot be read, or if the file was created by an older --- version of Cabal. -getConfigStateFile :: FilePath -- ^ The file path of the @setup-config@ file. - -> IO LocalBuildInfo -getConfigStateFile filename = do - exists <- doesFileExist filename - unless exists $ throwIO ConfigStateFileMissing - -- Read the config file into a strict ByteString to avoid problems with - -- lazy I/O, then convert to lazy because the binary package needs that. - contents <- BS.readFile filename - let (header, body) = BLC8.span (/='\n') (BLC8.fromChunks [contents]) - - (cabalId, compId) <- parseHeader header - - let getStoredValue = do - result <- structuredDecodeOrFailIO (BLC8.tail body) - case result of - Left _ -> throwIO ConfigStateFileNoParse - Right x -> return x - deferErrorIfBadVersion act - | cabalId /= currentCabalId = do - eResult <- try act - throwIO $ ConfigStateFileBadVersion cabalId compId eResult - | otherwise = act - deferErrorIfBadVersion getStoredValue - where - _ = callStack -- TODO: attach call stack to exception - --- | Read the 'localBuildInfoFile', returning either an error or the local build --- info. -tryGetConfigStateFile :: FilePath -- ^ The file path of the @setup-config@ file. - -> IO (Either ConfigStateFileError LocalBuildInfo) -tryGetConfigStateFile = try . getConfigStateFile - --- | Try to read the 'localBuildInfoFile'. -tryGetPersistBuildConfig :: FilePath -- ^ The @dist@ directory path. - -> IO (Either ConfigStateFileError LocalBuildInfo) -tryGetPersistBuildConfig = try . getPersistBuildConfig - --- | Read the 'localBuildInfoFile'. Throw an exception if the file is --- missing, if the file cannot be read, or if the file was created by an older --- version of Cabal. -getPersistBuildConfig :: FilePath -- ^ The @dist@ directory path. - -> IO LocalBuildInfo -getPersistBuildConfig = getConfigStateFile . localBuildInfoFile - --- | Try to read the 'localBuildInfoFile'. -maybeGetPersistBuildConfig :: FilePath -- ^ The @dist@ directory path. - -> IO (Maybe LocalBuildInfo) -maybeGetPersistBuildConfig = - liftM (either (const Nothing) Just) . tryGetPersistBuildConfig - --- | After running configure, output the 'LocalBuildInfo' to the --- 'localBuildInfoFile'. -writePersistBuildConfig :: FilePath -- ^ The @dist@ directory path. - -> LocalBuildInfo -- ^ The 'LocalBuildInfo' to write. - -> IO () -writePersistBuildConfig distPref lbi = do - createDirectoryIfMissing False distPref - writeFileAtomic (localBuildInfoFile distPref) $ - BLC8.unlines [showHeader pkgId, structuredEncode lbi] - where - pkgId = localPackage lbi - --- | Identifier of the current Cabal package. -currentCabalId :: PackageIdentifier -currentCabalId = PackageIdentifier (mkPackageName "Cabal") cabalVersion - --- | Identifier of the current compiler package. -currentCompilerId :: PackageIdentifier -currentCompilerId = PackageIdentifier (mkPackageName System.Info.compilerName) - (mkVersion' System.Info.compilerVersion) - --- | Parse the @setup-config@ file header, returning the package identifiers --- for Cabal and the compiler. -parseHeader :: ByteString -- ^ The file contents. - -> IO (PackageIdentifier, PackageIdentifier) -parseHeader header = case BLC8.words header of - ["Saved", "package", "config", "for", pkgId, "written", "by", cabalId, - "using", compId] -> - maybe (throwIO ConfigStateFileBadHeader) return $ do - _ <- simpleParsec (fromUTF8LBS pkgId) :: Maybe PackageIdentifier - cabalId' <- simpleParsec (BLC8.unpack cabalId) - compId' <- simpleParsec (BLC8.unpack compId) - return (cabalId', compId') - _ -> throwIO ConfigStateFileNoHeader - --- | Generate the @setup-config@ file header. -showHeader :: PackageIdentifier -- ^ The processed package. - -> ByteString -showHeader pkgId = BLC8.unwords - [ "Saved", "package", "config", "for" - , toUTF8LBS $ prettyShow pkgId - , "written", "by" - , BLC8.pack $ prettyShow currentCabalId - , "using" - , BLC8.pack $ prettyShow currentCompilerId - ] - --- | Check that localBuildInfoFile is up-to-date with respect to the --- .cabal file. -checkPersistBuildConfigOutdated :: FilePath -> FilePath -> IO Bool -checkPersistBuildConfigOutdated distPref pkg_descr_file = - pkg_descr_file `moreRecentFile` localBuildInfoFile distPref - --- | Get the path of @dist\/setup-config@. -localBuildInfoFile :: FilePath -- ^ The @dist@ directory path. - -> FilePath -localBuildInfoFile distPref = distPref "setup-config" - --- ----------------------------------------------------------------------------- --- * Configuration --- ----------------------------------------------------------------------------- - --- | Return the \"dist/\" prefix, or the default prefix. The prefix is taken --- from (in order of highest to lowest preference) the override prefix, the --- \"CABAL_BUILDDIR\" environment variable, or the default prefix. -findDistPref :: FilePath -- ^ default \"dist\" prefix - -> Setup.Flag FilePath -- ^ override \"dist\" prefix - -> IO FilePath -findDistPref defDistPref overrideDistPref = do - envDistPref <- liftM parseEnvDistPref (lookupEnv "CABAL_BUILDDIR") - return $ fromFlagOrDefault defDistPref (mappend envDistPref overrideDistPref) - where - parseEnvDistPref env = - case env of - Just distPref | not (null distPref) -> toFlag distPref - _ -> NoFlag - --- | Return the \"dist/\" prefix, or the default prefix. The prefix is taken --- from (in order of highest to lowest preference) the override prefix, the --- \"CABAL_BUILDDIR\" environment variable, or 'defaultDistPref' is used. Call --- this function to resolve a @*DistPref@ flag whenever it is not known to be --- set. (The @*DistPref@ flags are always set to a definite value before --- invoking 'UserHooks'.) -findDistPrefOrDefault :: Setup.Flag FilePath -- ^ override \"dist\" prefix - -> IO FilePath -findDistPrefOrDefault = findDistPref defaultDistPref - --- |Perform the \"@.\/setup configure@\" action. --- Returns the @.setup-config@ file. -configure :: (GenericPackageDescription, HookedBuildInfo) - -> ConfigFlags -> IO LocalBuildInfo -configure (pkg_descr0, pbi) cfg = do - -- Determine the component we are configuring, if a user specified - -- one on the command line. We use a fake, flattened version of - -- the package since at this point, we're not really sure what - -- components we *can* configure. @Nothing@ means that we should - -- configure everything (the old behavior). - (mb_cname :: Maybe ComponentName) <- do - let flat_pkg_descr = flattenPackageDescription pkg_descr0 - targets <- readBuildTargets verbosity flat_pkg_descr (configArgs cfg) - -- TODO: bleat if you use the module/file syntax - let targets' = [ cname | BuildTargetComponent cname <- targets ] - case targets' of - _ | null (configArgs cfg) -> return Nothing - [cname] -> return (Just cname) - [] -> die' verbosity "No valid component targets found" - _ -> die' verbosity - "Can only configure either single component or all of them" - - let use_external_internal_deps = isJust mb_cname - case mb_cname of - Nothing -> setupMessage verbosity "Configuring" (packageId pkg_descr0) - Just cname -> setupMessage' verbosity "Configuring" (packageId pkg_descr0) - cname (Just (configInstantiateWith cfg)) - - -- configCID is only valid for per-component configure - when (isJust (flagToMaybe (configCID cfg)) && isNothing mb_cname) $ - die' verbosity "--cid is only supported for per-component configure" - - checkDeprecatedFlags verbosity cfg - checkExactConfiguration verbosity pkg_descr0 cfg - - -- Where to build the package - let buildDir :: FilePath -- e.g. dist/build - -- fromFlag OK due to Distribution.Simple calling - -- findDistPrefOrDefault to fill it in - buildDir = fromFlag (configDistPref cfg) "build" - createDirectoryIfMissingVerbose (lessVerbose verbosity) True buildDir - - -- What package database(s) to use - let packageDbs :: PackageDBStack - packageDbs - = interpretPackageDbFlags - (fromFlag (configUserInstall cfg)) - (configPackageDBs cfg) - - -- comp: the compiler we're building with - -- compPlatform: the platform we're building for - -- programDb: location and args of all programs we're - -- building with - (comp :: Compiler, - compPlatform :: Platform, - programDb :: ProgramDb) - <- configCompilerEx - (flagToMaybe (configHcFlavor cfg)) - (flagToMaybe (configHcPath cfg)) - (flagToMaybe (configHcPkg cfg)) - (mkProgramDb cfg (configPrograms cfg)) - (lessVerbose verbosity) - - -- The InstalledPackageIndex of all installed packages - installedPackageSet :: InstalledPackageIndex - <- getInstalledPackages (lessVerbose verbosity) comp - packageDbs programDb - - -- The set of package names which are "shadowed" by internal - -- packages, and which component they map to - let internalPackageSet :: Set LibraryName - internalPackageSet = getInternalLibraries pkg_descr0 - - -- Make a data structure describing what components are enabled. - let enabled :: ComponentRequestedSpec - enabled = case mb_cname of - Just cname -> OneComponentRequestedSpec cname - Nothing -> ComponentRequestedSpec - -- The flag name (@--enable-tests@) is a - -- little bit of a misnomer, because - -- just passing this flag won't - -- "enable", in our internal - -- nomenclature; it's just a request; a - -- @buildable: False@ might make it - -- not possible to enable. - { testsRequested = fromFlag (configTests cfg) - , benchmarksRequested = - fromFlag (configBenchmarks cfg) } - -- Some sanity checks related to enabling components. - when (isJust mb_cname - && (fromFlag (configTests cfg) || fromFlag (configBenchmarks cfg))) $ - die' verbosity $ - "--enable-tests/--enable-benchmarks are incompatible with" ++ - " explicitly specifying a component to configure." - - -- Some sanity checks related to dynamic/static linking. - when (fromFlag (configDynExe cfg) && fromFlag (configFullyStaticExe cfg)) $ - die' verbosity $ - "--enable-executable-dynamic and --enable-executable-static" ++ - " are incompatible with each other." - - -- allConstraints: The set of all 'Dependency's we have. Used ONLY - -- to 'configureFinalizedPackage'. - -- requiredDepsMap: A map from 'PackageName' to the specifically - -- required 'InstalledPackageInfo', due to --dependency - -- - -- NB: These constraints are to be applied to ALL components of - -- a package. Thus, it's not an error if allConstraints contains - -- more constraints than is necessary for a component (another - -- component might need it.) - -- - -- NB: The fact that we bundle all the constraints together means - -- that is not possible to configure a test-suite to use one - -- version of a dependency, and the executable to use another. - (allConstraints :: [PackageVersionConstraint], - requiredDepsMap :: Map (PackageName, ComponentName) InstalledPackageInfo) - <- either (die' verbosity) return $ - combinedConstraints (configConstraints cfg) - (configDependencies cfg) - installedPackageSet - - -- pkg_descr: The resolved package description, that does not contain any - -- conditionals, because we have an assignment for - -- every flag, either picking them ourselves using a - -- simple naive algorithm, or having them be passed to - -- us by 'configConfigurationsFlags') - -- flags: The 'FlagAssignment' that the conditionals were - -- resolved with. - -- - -- NB: Why doesn't finalizing a package also tell us what the - -- dependencies are (e.g. when we run the naive algorithm, - -- we are checking if dependencies are satisfiable)? The - -- primary reason is that we may NOT have done any solving: - -- if the flags are all chosen for us, this step is a simple - -- matter of flattening according to that assignment. It's - -- cleaner to then configure the dependencies afterwards. - (pkg_descr :: PackageDescription, - flags :: FlagAssignment) - <- configureFinalizedPackage verbosity cfg enabled - allConstraints - (dependencySatisfiable - use_external_internal_deps - (fromFlagOrDefault False (configExactConfiguration cfg)) - (fromFlagOrDefault False (configAllowDependingOnPrivateLibs cfg)) - (packageName pkg_descr0) - installedPackageSet - internalPackageSet - requiredDepsMap) - comp - compPlatform - pkg_descr0 - - debug verbosity $ "Finalized package description:\n" - ++ showPackageDescription pkg_descr - - let cabalFileDir = maybe "." takeDirectory $ - flagToMaybe (configCabalFilePath cfg) - checkCompilerProblems verbosity comp pkg_descr enabled - checkPackageProblems verbosity cabalFileDir pkg_descr0 - (updatePackageDescription pbi pkg_descr) - - -- The list of 'InstalledPackageInfo' recording the selected - -- dependencies on external packages. - -- - -- Invariant: For any package name, there is at most one package - -- in externalPackageDeps which has that name. - -- - -- NB: The dependency selection is global over ALL components - -- in the package (similar to how allConstraints and - -- requiredDepsMap are global over all components). In particular, - -- if *any* component (post-flag resolution) has an unsatisfiable - -- dependency, we will fail. This can sometimes be undesirable - -- for users, see #1786 (benchmark conflicts with executable), - -- - -- In the presence of Backpack, these package dependencies are - -- NOT complete: they only ever include the INDEFINITE - -- dependencies. After we apply an instantiation, we'll get - -- definite references which constitute extra dependencies. - -- (Why not have cabal-install pass these in explicitly? - -- For one it's deterministic; for two, we need to associate - -- them with renamings which would require a far more complicated - -- input scheme than what we have today.) - externalPkgDeps :: [PreExistingComponent] - <- configureDependencies - verbosity - use_external_internal_deps - internalPackageSet - installedPackageSet - requiredDepsMap - pkg_descr - enabled - - -- Compute installation directory templates, based on user - -- configuration. - -- - -- TODO: Move this into a helper function. - defaultDirs :: InstallDirTemplates - <- defaultInstallDirs' use_external_internal_deps - (compilerFlavor comp) - (fromFlag (configUserInstall cfg)) - (hasLibs pkg_descr) - let installDirs :: InstallDirTemplates - installDirs = combineInstallDirs fromFlagOrDefault - defaultDirs (configInstallDirs cfg) - - -- Check languages and extensions - -- TODO: Move this into a helper function. - let langlist = nub $ catMaybes $ map defaultLanguage - (enabledBuildInfos pkg_descr enabled) - let langs = unsupportedLanguages comp langlist - when (not (null langs)) $ - die' verbosity $ "The package " ++ prettyShow (packageId pkg_descr0) - ++ " requires the following languages which are not " - ++ "supported by " ++ prettyShow (compilerId comp) ++ ": " - ++ intercalate ", " (map prettyShow langs) - let extlist = nub $ concatMap allExtensions - (enabledBuildInfos pkg_descr enabled) - let exts = unsupportedExtensions comp extlist - when (not (null exts)) $ - die' verbosity $ "The package " ++ prettyShow (packageId pkg_descr0) - ++ " requires the following language extensions which are not " - ++ "supported by " ++ prettyShow (compilerId comp) ++ ": " - ++ intercalate ", " (map prettyShow exts) - - -- Check foreign library build requirements - let flibs = [flib | CFLib flib <- enabledComponents pkg_descr enabled] - let unsupportedFLibs = unsupportedForeignLibs comp compPlatform flibs - when (not (null unsupportedFLibs)) $ - die' verbosity $ "Cannot build some foreign libraries: " - ++ intercalate "," unsupportedFLibs - - -- Configure certain external build tools, see below for which ones. - let requiredBuildTools = do - bi <- enabledBuildInfos pkg_descr enabled - -- First, we collect any tool dep that we know is external. This is, - -- in practice: - -- - -- 1. `build-tools` entries on the whitelist - -- - -- 2. `build-tool-depends` that aren't from the current package. - let externBuildToolDeps = - [ LegacyExeDependency (unUnqualComponentName eName) versionRange - | buildTool@(ExeDependency _ eName versionRange) - <- getAllToolDependencies pkg_descr bi - , not $ isInternal pkg_descr buildTool ] - -- Second, we collect any build-tools entry we don't know how to - -- desugar. We'll never have any idea how to build them, so we just - -- hope they are already on the PATH. - let unknownBuildTools = - [ buildTool - | buildTool <- buildTools bi - , Nothing == desugarBuildTool pkg_descr buildTool ] - externBuildToolDeps ++ unknownBuildTools - - programDb' <- - configureAllKnownPrograms (lessVerbose verbosity) programDb - >>= configureRequiredPrograms verbosity requiredBuildTools - - (pkg_descr', programDb'') <- - configurePkgconfigPackages verbosity pkg_descr programDb' enabled - - -- Compute internal component graph - -- - -- The general idea is that we take a look at all the source level - -- components (which may build-depends on each other) and form a graph. - -- From there, we build a ComponentLocalBuildInfo for each of the - -- components, which lets us actually build each component. - -- internalPackageSet - -- use_external_internal_deps - (buildComponents :: [ComponentLocalBuildInfo], - packageDependsIndex :: InstalledPackageIndex) <- - runLogProgress verbosity $ configureComponentLocalBuildInfos - verbosity - use_external_internal_deps - enabled - (fromFlagOrDefault False (configDeterministic cfg)) - (configIPID cfg) - (configCID cfg) - pkg_descr - externalPkgDeps - (configConfigurationsFlags cfg) - (configInstantiateWith cfg) - installedPackageSet - comp - - -- Decide if we're going to compile with split sections. - split_sections :: Bool <- - if not (fromFlag $ configSplitSections cfg) - then return False - else case compilerFlavor comp of - GHC | compilerVersion comp >= mkVersion [8,0] - -> return True - GHCJS - -> return True - _ -> do warn verbosity - ("this compiler does not support " ++ - "--enable-split-sections; ignoring") - return False - - -- Decide if we're going to compile with split objects. - split_objs :: Bool <- - if not (fromFlag $ configSplitObjs cfg) - then return False - else case compilerFlavor comp of - _ | split_sections - -> do warn verbosity - ("--enable-split-sections and " ++ - "--enable-split-objs are mutually" ++ - "exclusive; ignoring the latter") - return False - GHC - -> return True - GHCJS - -> return True - _ -> do warn verbosity - ("this compiler does not support " ++ - "--enable-split-objs; ignoring") - return False - - let ghciLibByDefault = - case compilerId comp of - CompilerId GHC _ -> - -- If ghc is non-dynamic, then ghci needs object files, - -- so we build one by default. - -- - -- Technically, archive files should be sufficient for ghci, - -- but because of GHC bug #8942, it has never been safe to - -- rely on them. By the time that bug was fixed, ghci had - -- been changed to read shared libraries instead of archive - -- files (see next code block). - not (GHC.isDynamic comp) - CompilerId GHCJS _ -> - not (GHCJS.isDynamic comp) - _ -> False - - let sharedLibsByDefault - | fromFlag (configDynExe cfg) = - -- build a shared library if dynamically-linked - -- executables are requested - True - | otherwise = case compilerId comp of - CompilerId GHC _ -> - -- if ghc is dynamic, then ghci needs a shared - -- library, so we build one by default. - GHC.isDynamic comp - CompilerId GHCJS _ -> - GHCJS.isDynamic comp - _ -> False - withSharedLib_ = - -- build shared libraries if required by GHC or by the - -- executable linking mode, but allow the user to force - -- building only static library archives with - -- --disable-shared. - fromFlagOrDefault sharedLibsByDefault $ configSharedLib cfg - - withStaticLib_ = - -- build a static library (all dependent libraries rolled - -- into a huge .a archive) via GHCs -staticlib flag. - fromFlagOrDefault False $ configStaticLib cfg - - withDynExe_ = fromFlag $ configDynExe cfg - - withFullyStaticExe_ = fromFlag $ configFullyStaticExe cfg - when (withDynExe_ && not withSharedLib_) $ warn verbosity $ - "Executables will use dynamic linking, but a shared library " - ++ "is not being built. Linking will fail if any executables " - ++ "depend on the library." - - setProfLBI <- configureProfiling verbosity cfg comp - - setCoverageLBI <- configureCoverage verbosity cfg comp - - - - -- Turn off library and executable stripping when `debug-info` is set - -- to anything other than zero. - let - strip_libexe s f = - let defaultStrip = fromFlagOrDefault True (f cfg) - in case fromFlag (configDebugInfo cfg) of - NoDebugInfo -> return defaultStrip - _ -> case f cfg of - Flag True -> do - warn verbosity $ "Setting debug-info implies " - ++ s ++ "-stripping: False" - return False - - _ -> return False - - strip_lib <- strip_libexe "library" configStripLibs - strip_exe <- strip_libexe "executable" configStripExes - - - let reloc = fromFlagOrDefault False $ configRelocatable cfg - - let buildComponentsMap = - foldl' (\m clbi -> Map.insertWith (++) - (componentLocalName clbi) [clbi] m) - Map.empty buildComponents - - let lbi = (setCoverageLBI . setProfLBI) - LocalBuildInfo { - configFlags = cfg, - flagAssignment = flags, - componentEnabledSpec = enabled, - extraConfigArgs = [], -- Currently configure does not - -- take extra args, but if it - -- did they would go here. - installDirTemplates = installDirs, - compiler = comp, - hostPlatform = compPlatform, - buildDir = buildDir, - cabalFilePath = flagToMaybe (configCabalFilePath cfg), - componentGraph = Graph.fromDistinctList buildComponents, - componentNameMap = buildComponentsMap, - installedPkgs = packageDependsIndex, - pkgDescrFile = Nothing, - localPkgDescr = pkg_descr', - withPrograms = programDb'', - withVanillaLib = fromFlag $ configVanillaLib cfg, - withSharedLib = withSharedLib_, - withStaticLib = withStaticLib_, - withDynExe = withDynExe_, - withFullyStaticExe = withFullyStaticExe_, - withProfLib = False, - withProfLibDetail = ProfDetailNone, - withProfExe = False, - withProfExeDetail = ProfDetailNone, - withOptimization = fromFlag $ configOptimization cfg, - withDebugInfo = fromFlag $ configDebugInfo cfg, - withGHCiLib = fromFlagOrDefault ghciLibByDefault $ - configGHCiLib cfg, - splitSections = split_sections, - splitObjs = split_objs, - stripExes = strip_exe, - stripLibs = strip_lib, - exeCoverage = False, - libCoverage = False, - withPackageDB = packageDbs, - progPrefix = fromFlag $ configProgPrefix cfg, - progSuffix = fromFlag $ configProgSuffix cfg, - relocatable = reloc - } - - when reloc (checkRelocatable verbosity pkg_descr lbi) - - -- TODO: This is not entirely correct, because the dirs may vary - -- across libraries/executables - let dirs = absoluteInstallDirs pkg_descr lbi NoCopyDest - relative = prefixRelativeInstallDirs (packageId pkg_descr) lbi - - -- PKGROOT: allowing ${pkgroot} to be passed as --prefix to - -- cabal configure, is only a hidden option. It allows packages - -- to be relocatable with their package database. This however - -- breaks when the Paths_* or other includes are used that - -- contain hard coded paths. This is still an open TODO. - -- - -- Allowing ${pkgroot} here, however requires less custom hooks - -- in scripts that *really* want ${pkgroot}. See haskell/cabal/#4872 - unless (isAbsolute (prefix dirs) - || "${pkgroot}" `isPrefixOf` prefix dirs) $ die' verbosity $ - "expected an absolute directory name for --prefix: " ++ prefix dirs - - when ("${pkgroot}" `isPrefixOf` prefix dirs) $ - warn verbosity $ "Using ${pkgroot} in prefix " ++ prefix dirs - ++ " will not work if you rely on the Path_* module " - ++ " or other hard coded paths. Cabal does not yet " - ++ " support fully relocatable builds! " - ++ " See #462 #2302 #2994 #3305 #3473 #3586 #3909" - ++ " #4097 #4291 #4872" - - info verbosity $ "Using " ++ prettyShow currentCabalId - ++ " compiled by " ++ prettyShow currentCompilerId - info verbosity $ "Using compiler: " ++ showCompilerId comp - info verbosity $ "Using install prefix: " ++ prefix dirs - - let dirinfo name dir isPrefixRelative = - info verbosity $ name ++ " installed in: " ++ dir ++ relNote - where relNote = case buildOS of - Windows | not (hasLibs pkg_descr) - && isNothing isPrefixRelative - -> " (fixed location)" - _ -> "" - - dirinfo "Executables" (bindir dirs) (bindir relative) - dirinfo "Libraries" (libdir dirs) (libdir relative) - dirinfo "Dynamic Libraries" (dynlibdir dirs) (dynlibdir relative) - dirinfo "Private executables" (libexecdir dirs) (libexecdir relative) - dirinfo "Data files" (datadir dirs) (datadir relative) - dirinfo "Documentation" (docdir dirs) (docdir relative) - dirinfo "Configuration files" (sysconfdir dirs) (sysconfdir relative) - - sequence_ [ reportProgram verbosity prog configuredProg - | (prog, configuredProg) <- knownPrograms programDb'' ] - - return lbi - - where - verbosity = fromFlag (configVerbosity cfg) - -mkProgramDb :: ConfigFlags -> ProgramDb -> ProgramDb -mkProgramDb cfg initialProgramDb = programDb - where - programDb = userSpecifyArgss (configProgramArgs cfg) - . userSpecifyPaths (configProgramPaths cfg) - . setProgramSearchPath searchpath - $ initialProgramDb - searchpath = getProgramSearchPath initialProgramDb - ++ map ProgramSearchPathDir - (fromNubList $ configProgramPathExtra cfg) - --- ----------------------------------------------------------------------------- --- Helper functions for configure - --- | Check if the user used any deprecated flags. -checkDeprecatedFlags :: Verbosity -> ConfigFlags -> IO () -checkDeprecatedFlags verbosity cfg = do - unless (configProfExe cfg == NoFlag) $ do - let enable | fromFlag (configProfExe cfg) = "enable" - | otherwise = "disable" - warn verbosity - ("The flag --" ++ enable ++ "-executable-profiling is deprecated. " - ++ "Please use --" ++ enable ++ "-profiling instead.") - - unless (configLibCoverage cfg == NoFlag) $ do - let enable | fromFlag (configLibCoverage cfg) = "enable" - | otherwise = "disable" - warn verbosity - ("The flag --" ++ enable ++ "-library-coverage is deprecated. " - ++ "Please use --" ++ enable ++ "-coverage instead.") - --- | Sanity check: if '--exact-configuration' was given, ensure that the --- complete flag assignment was specified on the command line. -checkExactConfiguration - :: Verbosity -> GenericPackageDescription -> ConfigFlags -> IO () -checkExactConfiguration verbosity pkg_descr0 cfg = - when (fromFlagOrDefault False (configExactConfiguration cfg)) $ do - let cmdlineFlags = map fst (unFlagAssignment (configConfigurationsFlags cfg)) - allFlags = map flagName . genPackageFlags $ pkg_descr0 - diffFlags = allFlags \\ cmdlineFlags - when (not . null $ diffFlags) $ - die' verbosity $ "'--exact-configuration' was given, " - ++ "but the following flags were not specified: " - ++ intercalate ", " (map show diffFlags) - --- | Create a PackageIndex that makes *any libraries that might be* --- defined internally to this package look like installed packages, in --- case an executable should refer to any of them as dependencies. --- --- It must be *any libraries that might be* defined rather than the --- actual definitions, because these depend on conditionals in the .cabal --- file, and we haven't resolved them yet. finalizePD --- does the resolution of conditionals, and it takes internalPackageSet --- as part of its input. -getInternalLibraries :: GenericPackageDescription - -> Set LibraryName -getInternalLibraries pkg_descr0 = - -- TODO: some day, executables will be fair game here too! - let pkg_descr = flattenPackageDescription pkg_descr0 - in Set.fromList (map libName (allLibraries pkg_descr)) - --- | Returns true if a dependency is satisfiable. This function may --- report a dependency satisfiable even when it is not, but not vice --- versa. This is to be passed to finalize -dependencySatisfiable - :: Bool -- ^ use external internal deps? - -> Bool -- ^ exact configuration? - -> Bool -- ^ allow depending on private libs? - -> PackageName - -> InstalledPackageIndex -- ^ installed set - -> Set LibraryName -- ^ library components - -> Map (PackageName, ComponentName) InstalledPackageInfo - -- ^ required dependencies - -> (Dependency -> Bool) -dependencySatisfiable - use_external_internal_deps - exact_config - allow_private_deps - pn installedPackageSet packageLibraries requiredDepsMap - (Dependency depName vr sublibs) - | exact_config - -- When we're given '--exact-configuration', we assume that all - -- dependencies and flags are exactly specified on the command - -- line. Thus we only consult the 'requiredDepsMap'. Note that - -- we're not doing the version range check, so if there's some - -- dependency that wasn't specified on the command line, - -- 'finalizePD' will fail. - -- TODO: mention '--exact-configuration' in the error message - -- when this fails? - = if isInternalDep && not use_external_internal_deps - -- Except for internal deps, when we're NOT per-component mode; - -- those are just True. - then internalDepSatisfiable - else - -- Backward compatibility for the old sublibrary syntax - (sublibs == mainLibSet - && Map.member - (pn, CLibName $ LSubLibName $ - packageNameToUnqualComponentName depName) - requiredDepsMap) - - || all visible sublibs - - | isInternalDep - = if use_external_internal_deps - -- When we are doing per-component configure, we now need to - -- test if the internal dependency is in the index. This has - -- DIFFERENT semantics from normal dependency satisfiability. - then internalDepSatisfiableExternally - -- If a 'PackageName' is defined by an internal component, the dep is - -- satisfiable (we're going to build it ourselves) - else internalDepSatisfiable - - | otherwise - = depSatisfiable - - where - -- Internal dependency is when dependency is the same as package. - isInternalDep = pn == depName - - depSatisfiable = - not . null $ PackageIndex.lookupDependency installedPackageSet depName vr - - internalDepSatisfiable = - Set.isSubsetOf (NES.toSet sublibs) packageLibraries - internalDepSatisfiableExternally = - all (\ln -> not $ null $ PackageIndex.lookupInternalDependency installedPackageSet pn vr ln) sublibs - - -- Check whether a library exists and is visible. - -- We don't disambiguate between dependency on non-existent or private - -- library yet, so we just return a bool and later report a generic error. - visible lib = maybe - False -- Does not even exist (wasn't in the depsMap) - (\ipi -> IPI.libVisibility ipi == LibraryVisibilityPublic - -- If the override is enabled, the visibility does - -- not matter (it's handled externally) - || allow_private_deps - -- If it's a library of the same package then it's - -- always visible. - -- This is only triggered when passing a component - -- of the same package as --dependency, such as in: - -- cabal-testsuite/PackageTests/ConfigureComponent/SubLib/setup-explicit.test.hs - || pkgName (IPI.sourcePackageId ipi) == pn) - maybeIPI - where maybeIPI = Map.lookup (depName, CLibName lib) requiredDepsMap - --- | Finalize a generic package description. The workhorse is --- 'finalizePD' but there's a bit of other nattering --- about necessary. --- --- TODO: what exactly is the business with @flaggedTests@ and --- @flaggedBenchmarks@? -configureFinalizedPackage - :: Verbosity - -> ConfigFlags - -> ComponentRequestedSpec - -> [PackageVersionConstraint] - -> (Dependency -> Bool) -- ^ tests if a dependency is satisfiable. - -- Might say it's satisfiable even when not. - -> Compiler - -> Platform - -> GenericPackageDescription - -> IO (PackageDescription, FlagAssignment) -configureFinalizedPackage verbosity cfg enabled - allConstraints satisfies comp compPlatform pkg_descr0 = do - - (pkg_descr0', flags) <- - case finalizePD - (configConfigurationsFlags cfg) - enabled - satisfies - compPlatform - (compilerInfo comp) - allConstraints - pkg_descr0 - of Right r -> return r - Left missing -> - die' verbosity $ "Encountered missing or private dependencies:\n" - ++ (render . nest 4 . sep . punctuate comma - . map (pretty . simplifyDependency) - $ missing) - - -- add extra include/lib dirs as specified in cfg - -- we do it here so that those get checked too - let pkg_descr = addExtraIncludeLibDirs pkg_descr0' - - unless (nullFlagAssignment flags) $ - info verbosity $ "Flags chosen: " - ++ intercalate ", " [ unFlagName fn ++ "=" ++ prettyShow value - | (fn, value) <- unFlagAssignment flags ] - - return (pkg_descr, flags) - where - addExtraIncludeLibDirs pkg_descr = - let extraBi = mempty { extraLibDirs = configExtraLibDirs cfg - , extraFrameworkDirs = configExtraFrameworkDirs cfg - , includeDirs = configExtraIncludeDirs cfg} - modifyLib l = l{ libBuildInfo = libBuildInfo l - `mappend` extraBi } - modifyExecutable e = e{ buildInfo = buildInfo e - `mappend` extraBi} - modifyForeignLib f = f{ foreignLibBuildInfo = foreignLibBuildInfo f - `mappend` extraBi} - modifyTestsuite t = t{ testBuildInfo = testBuildInfo t - `mappend` extraBi} - modifyBenchmark b = b{ benchmarkBuildInfo = benchmarkBuildInfo b - `mappend` extraBi} - in pkg_descr - { library = modifyLib `fmap` library pkg_descr - , subLibraries = modifyLib `map` subLibraries pkg_descr - , executables = modifyExecutable `map` executables pkg_descr - , foreignLibs = modifyForeignLib `map` foreignLibs pkg_descr - , testSuites = modifyTestsuite `map` testSuites pkg_descr - , benchmarks = modifyBenchmark `map` benchmarks pkg_descr - } - --- | Check for use of Cabal features which require compiler support -checkCompilerProblems - :: Verbosity -> Compiler -> PackageDescription -> ComponentRequestedSpec -> IO () -checkCompilerProblems verbosity comp pkg_descr enabled = do - unless (renamingPackageFlagsSupported comp || - all (all (isDefaultIncludeRenaming . mixinIncludeRenaming) . mixins) - (enabledBuildInfos pkg_descr enabled)) $ - die' verbosity $ - "Your compiler does not support thinning and renaming on " - ++ "package flags. To use this feature you must use " - ++ "GHC 7.9 or later." - - when (any (not.null.reexportedModules) (allLibraries pkg_descr) - && not (reexportedModulesSupported comp)) $ - die' verbosity $ - "Your compiler does not support module re-exports. To use " - ++ "this feature you must use GHC 7.9 or later." - - when (any (not.null.signatures) (allLibraries pkg_descr) - && not (backpackSupported comp)) $ - die' verbosity $ - "Your compiler does not support Backpack. To use " - ++ "this feature you must use GHC 8.1 or later." - --- | Select dependencies for the package. -configureDependencies - :: Verbosity - -> UseExternalInternalDeps - -> Set LibraryName - -> InstalledPackageIndex -- ^ installed packages - -> Map (PackageName, ComponentName) InstalledPackageInfo -- ^ required deps - -> PackageDescription - -> ComponentRequestedSpec - -> IO [PreExistingComponent] -configureDependencies verbosity use_external_internal_deps - packageLibraries installedPackageSet requiredDepsMap pkg_descr enableSpec = do - let failedDeps :: [FailedDependency] - allPkgDeps :: [ResolvedDependency] - (failedDeps, allPkgDeps) = partitionEithers $ concat - [ fmap (\s -> (dep, s)) <$> status - | dep <- enabledBuildDepends pkg_descr enableSpec - , let status = selectDependency (package pkg_descr) - packageLibraries installedPackageSet - requiredDepsMap use_external_internal_deps dep ] - - internalPkgDeps = [ pkgid - | (_, InternalDependency pkgid) <- allPkgDeps ] - -- NB: we have to SAVE the package name, because this is the only - -- way we can be able to resolve package names in the package - -- description. - externalPkgDeps = [ pec - | (_, ExternalDependency pec) <- allPkgDeps ] - - when (not (null internalPkgDeps) - && not (newPackageDepsBehaviour pkg_descr)) $ - die' verbosity $ "The field 'build-depends: " - ++ intercalate ", " (map (prettyShow . packageName) internalPkgDeps) - ++ "' refers to a library which is defined within the same " - ++ "package. To use this feature the package must specify at " - ++ "least 'cabal-version: >= 1.8'." - - reportFailedDependencies verbosity failedDeps - reportSelectedDependencies verbosity allPkgDeps - - return externalPkgDeps - --- | Select and apply coverage settings for the build based on the --- 'ConfigFlags' and 'Compiler'. -configureCoverage :: Verbosity -> ConfigFlags -> Compiler - -> IO (LocalBuildInfo -> LocalBuildInfo) -configureCoverage verbosity cfg comp = do - let tryExeCoverage = fromFlagOrDefault False (configCoverage cfg) - tryLibCoverage = fromFlagOrDefault tryExeCoverage - (mappend (configCoverage cfg) (configLibCoverage cfg)) - if coverageSupported comp - then do - let apply lbi = lbi { libCoverage = tryLibCoverage - , exeCoverage = tryExeCoverage - } - return apply - else do - let apply lbi = lbi { libCoverage = False - , exeCoverage = False - } - when (tryExeCoverage || tryLibCoverage) $ warn verbosity - ("The compiler " ++ showCompilerId comp ++ " does not support " - ++ "program coverage. Program coverage has been disabled.") - return apply - --- | Compute the effective value of the profiling flags --- @--enable-library-profiling@ and @--enable-executable-profiling@ --- from the specified 'ConfigFlags'. This may be useful for --- external Cabal tools which need to interact with Setup in --- a backwards-compatible way: the most predictable mechanism --- for enabling profiling across many legacy versions is to --- NOT use @--enable-profiling@ and use those two flags instead. --- --- Note that @--enable-executable-profiling@ also affects profiling --- of benchmarks and (non-detailed) test suites. -computeEffectiveProfiling :: ConfigFlags -> (Bool {- lib -}, Bool {- exe -}) -computeEffectiveProfiling cfg = - -- The --profiling flag sets the default for both libs and exes, - -- but can be overidden by --library-profiling, or the old deprecated - -- --executable-profiling flag. - -- - -- The --profiling-detail and --library-profiling-detail flags behave - -- similarly - let tryExeProfiling = fromFlagOrDefault False - (mappend (configProf cfg) (configProfExe cfg)) - tryLibProfiling = fromFlagOrDefault tryExeProfiling - (mappend (configProf cfg) (configProfLib cfg)) - in (tryLibProfiling, tryExeProfiling) - --- | Select and apply profiling settings for the build based on the --- 'ConfigFlags' and 'Compiler'. -configureProfiling :: Verbosity -> ConfigFlags -> Compiler - -> IO (LocalBuildInfo -> LocalBuildInfo) -configureProfiling verbosity cfg comp = do - let (tryLibProfiling, tryExeProfiling) = computeEffectiveProfiling cfg - - tryExeProfileLevel = fromFlagOrDefault ProfDetailDefault - (configProfDetail cfg) - tryLibProfileLevel = fromFlagOrDefault ProfDetailDefault - (mappend - (configProfDetail cfg) - (configProfLibDetail cfg)) - - checkProfileLevel (ProfDetailOther other) = do - warn verbosity - ("Unknown profiling detail level '" ++ other - ++ "', using default.\nThe profiling detail levels are: " - ++ intercalate ", " - [ name | (name, _, _) <- knownProfDetailLevels ]) - return ProfDetailDefault - checkProfileLevel other = return other - - (exeProfWithoutLibProf, applyProfiling) <- - if profilingSupported comp - then do - exeLevel <- checkProfileLevel tryExeProfileLevel - libLevel <- checkProfileLevel tryLibProfileLevel - let apply lbi = lbi { withProfLib = tryLibProfiling - , withProfLibDetail = libLevel - , withProfExe = tryExeProfiling - , withProfExeDetail = exeLevel - } - return (tryExeProfiling && not tryLibProfiling, apply) - else do - let apply lbi = lbi { withProfLib = False - , withProfLibDetail = ProfDetailNone - , withProfExe = False - , withProfExeDetail = ProfDetailNone - } - when (tryExeProfiling || tryLibProfiling) $ warn verbosity - ("The compiler " ++ showCompilerId comp ++ " does not support " - ++ "profiling. Profiling has been disabled.") - return (False, apply) - - when exeProfWithoutLibProf $ warn verbosity - ("Executables will be built with profiling, but library " - ++ "profiling is disabled. Linking will fail if any executables " - ++ "depend on the library.") - - return applyProfiling - --- ----------------------------------------------------------------------------- --- Configuring package dependencies - -reportProgram :: Verbosity -> Program -> Maybe ConfiguredProgram -> IO () -reportProgram verbosity prog Nothing - = info verbosity $ "No " ++ programName prog ++ " found" -reportProgram verbosity prog (Just configuredProg) - = info verbosity $ "Using " ++ programName prog ++ version ++ location - where location = case programLocation configuredProg of - FoundOnSystem p -> " found on system at: " ++ p - UserSpecified p -> " given by user at: " ++ p - version = case programVersion configuredProg of - Nothing -> "" - Just v -> " version " ++ prettyShow v - -hackageUrl :: String -hackageUrl = "http://hackage.haskell.org/package/" - -type ResolvedDependency = (Dependency, DependencyResolution) - -data DependencyResolution - -- | An external dependency from the package database, OR an - -- internal dependency which we are getting from the package - -- database. - = ExternalDependency PreExistingComponent - -- | An internal dependency ('PackageId' should be a library name) - -- which we are going to have to build. (The - -- 'PackageId' here is a hack to get a modest amount of - -- polymorphism out of the 'Package' typeclass.) - | InternalDependency PackageId - -data FailedDependency = DependencyNotExists PackageName - | DependencyMissingInternal PackageName LibraryName - | DependencyNoVersion Dependency - --- | Test for a package dependency and record the version we have installed. -selectDependency :: PackageId -- ^ Package id of current package - -> Set LibraryName -- ^ package libraries - -> InstalledPackageIndex -- ^ Installed packages - -> Map (PackageName, ComponentName) InstalledPackageInfo - -- ^ Packages for which we have been given specific deps to - -- use - -> UseExternalInternalDeps -- ^ Are we configuring a - -- single component? - -> Dependency - -> [Either FailedDependency DependencyResolution] -selectDependency pkgid internalIndex installedIndex requiredDepsMap - use_external_internal_deps - (Dependency dep_pkgname vr libs) = - -- If the dependency specification matches anything in the internal package - -- index, then we prefer that match to anything in the second. - -- For example: - -- - -- Name: MyLibrary - -- Version: 0.1 - -- Library - -- .. - -- Executable my-exec - -- build-depends: MyLibrary - -- - -- We want "build-depends: MyLibrary" always to match the internal library - -- even if there is a newer installed library "MyLibrary-0.2". - if dep_pkgname == pn - then - if use_external_internal_deps - then do_external_internal <$> NES.toList libs - else do_internal <$> NES.toList libs - else - do_external_external <$> NES.toList libs - where - pn = packageName pkgid - - -- It's an internal library, and we're not per-component build - do_internal lib - | Set.member lib internalIndex - = Right $ InternalDependency $ PackageIdentifier dep_pkgname $ packageVersion pkgid - - | otherwise - = Left $ DependencyMissingInternal dep_pkgname lib - - -- We have to look it up externally - do_external_external :: LibraryName -> Either FailedDependency DependencyResolution - do_external_external lib = do - ipi <- case Map.lookup (dep_pkgname, CLibName lib) requiredDepsMap of - -- If we know the exact pkg to use, then use it. - Just pkginstance -> Right pkginstance - -- Otherwise we just pick an arbitrary instance of the latest version. - Nothing -> case pickLastIPI $ PackageIndex.lookupDependency installedIndex dep_pkgname vr of - Nothing -> Left (DependencyNotExists dep_pkgname) - Just pkg -> Right pkg - return $ ExternalDependency $ ipiToPreExistingComponent ipi - - do_external_internal :: LibraryName -> Either FailedDependency DependencyResolution - do_external_internal lib = do - ipi <- case Map.lookup (dep_pkgname, CLibName lib) requiredDepsMap of - -- If we know the exact pkg to use, then use it. - Just pkginstance -> Right pkginstance - Nothing -> case pickLastIPI $ PackageIndex.lookupInternalDependency installedIndex pn vr lib of - -- It's an internal library, being looked up externally - Nothing -> Left (DependencyMissingInternal dep_pkgname lib) - Just pkg -> Right pkg - return $ ExternalDependency $ ipiToPreExistingComponent ipi - - pickLastIPI :: [(Version, [InstalledPackageInfo])] -> Maybe InstalledPackageInfo - pickLastIPI pkgs = safeHead . snd . last =<< nonEmpty pkgs - -reportSelectedDependencies :: Verbosity - -> [ResolvedDependency] -> IO () -reportSelectedDependencies verbosity deps = - info verbosity $ unlines - [ "Dependency " ++ prettyShow (simplifyDependency dep) - ++ ": using " ++ prettyShow pkgid - | (dep, resolution) <- deps - , let pkgid = case resolution of - ExternalDependency pkg' -> packageId pkg' - InternalDependency pkgid' -> pkgid' ] - -reportFailedDependencies :: Verbosity -> [FailedDependency] -> IO () -reportFailedDependencies _ [] = return () -reportFailedDependencies verbosity failed = - die' verbosity (intercalate "\n\n" (map reportFailedDependency failed)) - - where - reportFailedDependency (DependencyNotExists pkgname) = - "there is no version of " ++ prettyShow pkgname ++ " installed.\n" - ++ "Perhaps you need to download and install it from\n" - ++ hackageUrl ++ prettyShow pkgname ++ "?" - - reportFailedDependency (DependencyMissingInternal pkgname lib) = - "internal dependency " ++ prettyShow (prettyLibraryNameComponent lib) ++ " not installed.\n" - ++ "Perhaps you need to configure and install it first?\n" - ++ "(This library was defined by " ++ prettyShow pkgname ++ ")" - - reportFailedDependency (DependencyNoVersion dep) = - "cannot satisfy dependency " ++ prettyShow (simplifyDependency dep) ++ "\n" - --- | List all installed packages in the given package databases. --- Non-existent package databases do not cause errors, they just get skipped --- with a warning and treated as empty ones, since technically they do not --- contain any package. -getInstalledPackages :: Verbosity -> Compiler - -> PackageDBStack -- ^ The stack of package databases. - -> ProgramDb - -> IO InstalledPackageIndex -getInstalledPackages verbosity comp packageDBs progdb = do - when (null packageDBs) $ - die' verbosity $ "No package databases have been specified. If you use " - ++ "--package-db=clear, you must follow it with --package-db= " - ++ "with 'global', 'user' or a specific file." - - info verbosity "Reading installed packages..." - -- do not check empty packagedbs (ghc-pkg would error out) - packageDBs' <- filterM packageDBExists packageDBs - case compilerFlavor comp of - GHC -> GHC.getInstalledPackages verbosity comp packageDBs' progdb - GHCJS -> GHCJS.getInstalledPackages verbosity packageDBs' progdb - UHC -> UHC.getInstalledPackages verbosity comp packageDBs' progdb - HaskellSuite {} -> - HaskellSuite.getInstalledPackages verbosity packageDBs' progdb - flv -> die' verbosity $ "don't know how to find the installed packages for " - ++ prettyShow flv - where - packageDBExists (SpecificPackageDB path) = do - exists <- doesPathExist path - unless exists $ - warn verbosity $ "Package db " <> path <> " does not exist yet" - return exists - -- Checking the user and global package dbs is more complicated and needs - -- way more data. Also ghc-pkg won't error out unless the user/global - -- pkgdb is overridden with an empty one, so we just don't check for them. - packageDBExists UserPackageDB = pure True - packageDBExists GlobalPackageDB = pure True - --- | Like 'getInstalledPackages', but for a single package DB. --- --- NB: Why isn't this always a fall through to 'getInstalledPackages'? --- That is because 'getInstalledPackages' performs some sanity checks --- on the package database stack in question. However, when sandboxes --- are involved these sanity checks are not desirable. -getPackageDBContents :: Verbosity -> Compiler - -> PackageDB -> ProgramDb - -> IO InstalledPackageIndex -getPackageDBContents verbosity comp packageDB progdb = do - info verbosity "Reading installed packages..." - case compilerFlavor comp of - GHC -> GHC.getPackageDBContents verbosity packageDB progdb - GHCJS -> GHCJS.getPackageDBContents verbosity packageDB progdb - -- For other compilers, try to fall back on 'getInstalledPackages'. - _ -> getInstalledPackages verbosity comp [packageDB] progdb - - --- | A set of files (or directories) that can be monitored to detect when --- there might have been a change in the installed packages. --- -getInstalledPackagesMonitorFiles :: Verbosity -> Compiler - -> PackageDBStack - -> ProgramDb -> Platform - -> IO [FilePath] -getInstalledPackagesMonitorFiles verbosity comp packageDBs progdb platform = - case compilerFlavor comp of - GHC -> GHC.getInstalledPackagesMonitorFiles - verbosity platform progdb packageDBs - other -> do - warn verbosity $ "don't know how to find change monitoring files for " - ++ "the installed package databases for " ++ prettyShow other - return [] - --- | The user interface specifies the package dbs to use with a combination of --- @--global@, @--user@ and @--package-db=global|user|clear|$file@. --- This function combines the global/user flag and interprets the package-db --- flag into a single package db stack. --- -interpretPackageDbFlags :: Bool -> [Maybe PackageDB] -> PackageDBStack -interpretPackageDbFlags userInstall specificDBs = - extra initialStack specificDBs - where - initialStack | userInstall = [GlobalPackageDB, UserPackageDB] - | otherwise = [GlobalPackageDB] - - extra dbs' [] = dbs' - extra _ (Nothing:dbs) = extra [] dbs - extra dbs' (Just db:dbs) = extra (dbs' ++ [db]) dbs - --- We are given both --constraint="foo < 2.0" style constraints and also --- specific packages to pick via --dependency="foo=foo-2.0-177d5cdf20962d0581". --- --- When finalising the package we have to take into account the specific --- installed deps we've been given, and the finalise function expects --- constraints, so we have to translate these deps into version constraints. --- --- But after finalising we then have to make sure we pick the right specific --- deps in the end. So we still need to remember which installed packages to --- pick. -combinedConstraints - :: [PackageVersionConstraint] - -> [GivenComponent] - -> InstalledPackageIndex - -> Either String ([PackageVersionConstraint], - Map (PackageName, ComponentName) InstalledPackageInfo) -combinedConstraints constraints dependencies installedPackages = do - - when (not (null badComponentIds)) $ - Left $ render $ text "The following package dependencies were requested" - $+$ nest 4 (dispDependencies badComponentIds) - $+$ text "however the given installed package instance does not exist." - - --TODO: we don't check that all dependencies are used! - - return (allConstraints, idConstraintMap) - - where - allConstraints :: [PackageVersionConstraint] - allConstraints = constraints - ++ [ thisPackageVersionConstraint (packageId pkg) - | (_, _, _, Just pkg) <- dependenciesPkgInfo ] - - idConstraintMap :: Map (PackageName, ComponentName) InstalledPackageInfo - idConstraintMap = Map.fromList - -- NB: do NOT use the packageName from - -- dependenciesPkgInfo! - [ ((pn, cname), pkg) - | (pn, cname, _, Just pkg) <- dependenciesPkgInfo ] - - -- The dependencies along with the installed package info, if it exists - dependenciesPkgInfo :: [(PackageName, ComponentName, ComponentId, - Maybe InstalledPackageInfo)] - dependenciesPkgInfo = - [ (pkgname, CLibName lname, cid, mpkg) - | GivenComponent pkgname lname cid <- dependencies - , let mpkg = PackageIndex.lookupComponentId - installedPackages cid - ] - - -- If we looked up a package specified by an installed package id - -- (i.e. someone has written a hash) and didn't find it then it's - -- an error. - badComponentIds = - [ (pkgname, cname, cid) - | (pkgname, cname, cid, Nothing) <- dependenciesPkgInfo ] - - dispDependencies deps = - hsep [ text "--dependency=" - <<>> quotes - (pretty pkgname - <<>> case cname of - CLibName LMainLibName -> "" - CLibName (LSubLibName n) -> ":" <<>> pretty n - _ -> ":" <<>> pretty cname - <<>> char '=' - <<>> pretty cid) - | (pkgname, cname, cid) <- deps ] - --- ----------------------------------------------------------------------------- --- Configuring program dependencies - -configureRequiredPrograms :: Verbosity -> [LegacyExeDependency] -> ProgramDb - -> IO ProgramDb -configureRequiredPrograms verbosity deps progdb = - foldM (configureRequiredProgram verbosity) progdb deps - --- | Configure a required program, ensuring that it exists in the PATH --- (or where the user has specified the program must live) and making it --- available for use via the 'ProgramDb' interface. If the program is --- known (exists in the input 'ProgramDb'), we will make sure that the --- program matches the required version; otherwise we will accept --- any version of the program and assume that it is a simpleProgram. -configureRequiredProgram :: Verbosity -> ProgramDb -> LegacyExeDependency - -> IO ProgramDb -configureRequiredProgram verbosity progdb - (LegacyExeDependency progName verRange) = - case lookupKnownProgram progName progdb of - Nothing -> - -- Try to configure it as a 'simpleProgram' automatically - -- - -- There's a bit of a story behind this line. In old versions - -- of Cabal, there were only internal build-tools dependencies. So the - -- behavior in this case was: - -- - -- - If a build-tool dependency was internal, don't do - -- any checking. - -- - -- - If it was external, call 'configureRequiredProgram' to - -- "configure" the executable. In particular, if - -- the program was not "known" (present in 'ProgramDb'), - -- then we would just error. This was fine, because - -- the only way a program could be executed from 'ProgramDb' - -- is if some library code from Cabal actually called it, - -- and the pre-existing Cabal code only calls known - -- programs from 'defaultProgramDb', and so if it - -- is calling something else, you have a Custom setup - -- script, and in that case you are expected to register - -- the program you want to call in the ProgramDb. - -- - -- OK, so that was fine, until I (ezyang, in 2016) refactored - -- Cabal to support per-component builds. In this case, what - -- was previously an internal build-tool dependency now became - -- an external one, and now previously "internal" dependencies - -- are now external. But these are permitted to exist even - -- when they are not previously configured (something that - -- can only occur by a Custom script.) - -- - -- So, I decided, "Fine, let's just accept these in any - -- case." Thus this line. The alternative would have been to - -- somehow detect when a build-tools dependency was "internal" (by - -- looking at the unflattened package description) but this - -- would also be incompatible with future work to support - -- external executable dependencies: we definitely cannot - -- assume they will be preinitialized in the 'ProgramDb'. - configureProgram verbosity (simpleProgram progName) progdb - Just prog - -- requireProgramVersion always requires the program have a version - -- but if the user says "build-depends: foo" ie no version constraint - -- then we should not fail if we cannot discover the program version. - | verRange == anyVersion -> do - (_, progdb') <- requireProgram verbosity prog progdb - return progdb' - | otherwise -> do - (_, _, progdb') <- requireProgramVersion verbosity prog verRange progdb - return progdb' - --- ----------------------------------------------------------------------------- --- Configuring pkg-config package dependencies - -configurePkgconfigPackages :: Verbosity -> PackageDescription - -> ProgramDb -> ComponentRequestedSpec - -> IO (PackageDescription, ProgramDb) -configurePkgconfigPackages verbosity pkg_descr progdb enabled - | null allpkgs = return (pkg_descr, progdb) - | otherwise = do - (_, _, progdb') <- requireProgramVersion - (lessVerbose verbosity) pkgConfigProgram - (orLaterVersion $ mkVersion [0,9,0]) progdb - traverse_ requirePkg allpkgs - mlib' <- traverse addPkgConfigBILib (library pkg_descr) - libs' <- traverse addPkgConfigBILib (subLibraries pkg_descr) - exes' <- traverse addPkgConfigBIExe (executables pkg_descr) - tests' <- traverse addPkgConfigBITest (testSuites pkg_descr) - benches' <- traverse addPkgConfigBIBench (benchmarks pkg_descr) - let pkg_descr' = pkg_descr { library = mlib', - subLibraries = libs', executables = exes', - testSuites = tests', benchmarks = benches' } - return (pkg_descr', progdb') - - where - allpkgs = concatMap pkgconfigDepends (enabledBuildInfos pkg_descr enabled) - pkgconfig = getDbProgramOutput (lessVerbose verbosity) - pkgConfigProgram progdb - - requirePkg dep@(PkgconfigDependency pkgn range) = do - version <- pkgconfig ["--modversion", pkg] - `catchIO` (\_ -> die' verbosity notFound) - `catchExit` (\_ -> die' verbosity notFound) - let trim = dropWhile isSpace . dropWhileEnd isSpace - let v = PkgconfigVersion (toUTF8BS $ trim version) - if not (withinPkgconfigVersionRange v range) - then die' verbosity (badVersion v) - else info verbosity (depSatisfied v) - where - notFound = "The pkg-config package '" ++ pkg ++ "'" - ++ versionRequirement - ++ " is required but it could not be found." - badVersion v = "The pkg-config package '" ++ pkg ++ "'" - ++ versionRequirement - ++ " is required but the version installed on the" - ++ " system is version " ++ prettyShow v - depSatisfied v = "Dependency " ++ prettyShow dep - ++ ": using version " ++ prettyShow v - - versionRequirement - | isAnyPkgconfigVersion range = "" - | otherwise = " version " ++ prettyShow range - - pkg = unPkgconfigName pkgn - - -- Adds pkgconfig dependencies to the build info for a component - addPkgConfigBI compBI setCompBI comp = do - bi <- pkgconfigBuildInfo (pkgconfigDepends (compBI comp)) - return $ setCompBI comp (compBI comp `mappend` bi) - - -- Adds pkgconfig dependencies to the build info for a library - addPkgConfigBILib = addPkgConfigBI libBuildInfo $ - \lib bi -> lib { libBuildInfo = bi } - - -- Adds pkgconfig dependencies to the build info for an executable - addPkgConfigBIExe = addPkgConfigBI buildInfo $ - \exe bi -> exe { buildInfo = bi } - - -- Adds pkgconfig dependencies to the build info for a test suite - addPkgConfigBITest = addPkgConfigBI testBuildInfo $ - \test bi -> test { testBuildInfo = bi } - - -- Adds pkgconfig dependencies to the build info for a benchmark - addPkgConfigBIBench = addPkgConfigBI benchmarkBuildInfo $ - \bench bi -> bench { benchmarkBuildInfo = bi } - - pkgconfigBuildInfo :: [PkgconfigDependency] -> IO BuildInfo - pkgconfigBuildInfo [] = return mempty - pkgconfigBuildInfo pkgdeps = do - let pkgs = nub [ prettyShow pkg | PkgconfigDependency pkg _ <- pkgdeps ] - ccflags <- pkgconfig ("--cflags" : pkgs) - ldflags <- pkgconfig ("--libs" : pkgs) - return (ccLdOptionsBuildInfo (words ccflags) (words ldflags)) - --- | Makes a 'BuildInfo' from C compiler and linker flags. --- --- This can be used with the output from configuration programs like pkg-config --- and similar package-specific programs like mysql-config, freealut-config etc. --- For example: --- --- > ccflags <- getDbProgramOutput verbosity prog progdb ["--cflags"] --- > ldflags <- getDbProgramOutput verbosity prog progdb ["--libs"] --- > return (ccldOptionsBuildInfo (words ccflags) (words ldflags)) --- -ccLdOptionsBuildInfo :: [String] -> [String] -> BuildInfo -ccLdOptionsBuildInfo cflags ldflags = - let (includeDirs', cflags') = partition ("-I" `isPrefixOf`) cflags - (extraLibs', ldflags') = partition ("-l" `isPrefixOf`) ldflags - (extraLibDirs', ldflags'') = partition ("-L" `isPrefixOf`) ldflags' - in mempty { - includeDirs = map (drop 2) includeDirs', - extraLibs = map (drop 2) extraLibs', - extraLibDirs = map (drop 2) extraLibDirs', - ccOptions = cflags', - ldOptions = ldflags'' - } - --- ----------------------------------------------------------------------------- --- Determining the compiler details - -configCompilerAuxEx :: ConfigFlags - -> IO (Compiler, Platform, ProgramDb) -configCompilerAuxEx cfg = configCompilerEx (flagToMaybe $ configHcFlavor cfg) - (flagToMaybe $ configHcPath cfg) - (flagToMaybe $ configHcPkg cfg) - programDb - (fromFlag (configVerbosity cfg)) - where - programDb = mkProgramDb cfg defaultProgramDb - -configCompilerEx :: Maybe CompilerFlavor -> Maybe FilePath -> Maybe FilePath - -> ProgramDb -> Verbosity - -> IO (Compiler, Platform, ProgramDb) -configCompilerEx Nothing _ _ _ verbosity = die' verbosity "Unknown compiler" -configCompilerEx (Just hcFlavor) hcPath hcPkg progdb verbosity = do - (comp, maybePlatform, programDb) <- case hcFlavor of - GHC -> GHC.configure verbosity hcPath hcPkg progdb - GHCJS -> GHCJS.configure verbosity hcPath hcPkg progdb - UHC -> UHC.configure verbosity hcPath hcPkg progdb - HaskellSuite {} -> HaskellSuite.configure verbosity hcPath hcPkg progdb - _ -> die' verbosity "Unknown compiler" - return (comp, fromMaybe buildPlatform maybePlatform, programDb) - --- ----------------------------------------------------------------------------- --- Testing C lib and header dependencies - --- Try to build a test C program which includes every header and links every --- lib. If that fails, try to narrow it down by preprocessing (only) and linking --- with individual headers and libs. If none is the obvious culprit then give a --- generic error message. --- TODO: produce a log file from the compiler errors, if any. -checkForeignDeps :: PackageDescription -> LocalBuildInfo -> Verbosity -> IO () -checkForeignDeps pkg lbi verbosity = - ifBuildsWith allHeaders (commonCcArgs ++ makeLdArgs allLibs) -- I'm feeling - -- lucky - (return ()) - (do missingLibs <- findMissingLibs - missingHdr <- findOffendingHdr - explainErrors missingHdr missingLibs) - where - allHeaders = collectField includes - allLibs = collectField extraLibs - - ifBuildsWith headers args success failure = do - checkDuplicateHeaders - ok <- builds (makeProgram headers) args - if ok then success else failure - - -- Ensure that there is only one header with a given name - -- in either the generated (most likely by `configure`) - -- build directory (e.g. `dist/build`) or in the source directory. - -- - -- If it exists in both, we'll remove the one in the source - -- directory, as the generated should take precedence. - -- - -- C compilers like to prefer source local relative includes, - -- so the search paths provided to the compiler via -I are - -- ignored if the included file can be found relative to the - -- including file. As such we need to take drastic measures - -- and delete the offending file in the source directory. - checkDuplicateHeaders = do - let relIncDirs = filter (not . isAbsolute) (collectField includeDirs) - isHeader = isSuffixOf ".h" - genHeaders <- for relIncDirs $ \dir -> - fmap (dir ) . filter isHeader <$> - listDirectory (buildDir lbi dir) `catchIO` (\_ -> return []) - srcHeaders <- for relIncDirs $ \dir -> - fmap (dir ) . filter isHeader <$> - listDirectory (baseDir lbi dir) `catchIO` (\_ -> return []) - let commonHeaders = concat genHeaders `intersect` concat srcHeaders - for_ commonHeaders $ \hdr -> do - warn verbosity $ "Duplicate header found in " - ++ (buildDir lbi hdr) - ++ " and " - ++ (baseDir lbi hdr) - ++ "; removing " - ++ (baseDir lbi hdr) - removeFile (baseDir lbi hdr) - - findOffendingHdr = - ifBuildsWith allHeaders ccArgs - (return Nothing) - (go . Unsafe.tail . inits $ allHeaders) -- inits always contains at least [] - where - go [] = return Nothing -- cannot happen - go (hdrs:hdrsInits) = - -- Try just preprocessing first - ifBuildsWith hdrs cppArgs - -- If that works, try compiling too - (ifBuildsWith hdrs ccArgs - (go hdrsInits) - (return . fmap Right . safeLast $ hdrs)) - (return . fmap Left . safeLast $ hdrs) - - - cppArgs = "-E":commonCppArgs -- preprocess only - ccArgs = "-c":commonCcArgs -- don't try to link - - findMissingLibs = ifBuildsWith [] (makeLdArgs allLibs) - (return []) - (filterM (fmap not . libExists) allLibs) - - libExists lib = builds (makeProgram []) (makeLdArgs [lib]) - - baseDir lbi' = fromMaybe "." (takeDirectory <$> cabalFilePath lbi') - - commonCppArgs = platformDefines lbi - -- TODO: This is a massive hack, to work around the - -- fact that the test performed here should be - -- PER-component (c.f. the "I'm Feeling Lucky"; we - -- should NOT be glomming everything together.) - ++ [ "-I" ++ buildDir lbi "autogen" ] - -- `configure' may generate headers in the build directory - ++ [ "-I" ++ buildDir lbi dir - | dir <- ordNub (collectField includeDirs) - , not (isAbsolute dir)] - -- we might also reference headers from the - -- packages directory. - ++ [ "-I" ++ baseDir lbi dir - | dir <- ordNub (collectField includeDirs) - , not (isAbsolute dir)] - ++ [ "-I" ++ dir | dir <- ordNub (collectField includeDirs) - , isAbsolute dir] - ++ ["-I" ++ baseDir lbi] - ++ collectField cppOptions - ++ collectField ccOptions - ++ [ "-I" ++ dir - | dir <- ordNub [ dir - | dep <- deps - , dir <- IPI.includeDirs dep ] - -- dedupe include dirs of dependencies - -- to prevent quadratic blow-up - ] - ++ [ opt - | dep <- deps - , opt <- IPI.ccOptions dep ] - - commonCcArgs = commonCppArgs - ++ collectField ccOptions - ++ [ opt - | dep <- deps - , opt <- IPI.ccOptions dep ] - - commonLdArgs = [ "-L" ++ dir - | dir <- ordNub (collectField extraLibDirs) ] - ++ collectField ldOptions - ++ [ "-L" ++ dir - | dir <- ordNub [ dir - | dep <- deps - , dir <- IPI.libraryDirs dep ] - ] - --TODO: do we also need dependent packages' ld options? - makeLdArgs libs = [ "-l"++lib | lib <- libs ] ++ commonLdArgs - - makeProgram hdrs = unlines $ - [ "#include \"" ++ hdr ++ "\"" | hdr <- hdrs ] ++ - ["int main(int argc, char** argv) { return 0; }"] - - collectField f = concatMap f allBi - allBi = enabledBuildInfos pkg (componentEnabledSpec lbi) - deps = PackageIndex.topologicalOrder (installedPkgs lbi) - - builds program args = do - tempDir <- getTemporaryDirectory - withTempFile tempDir ".c" $ \cName cHnd -> - withTempFile tempDir "" $ \oNname oHnd -> do - hPutStrLn cHnd program - hClose cHnd - hClose oHnd - _ <- getDbProgramOutput verbosity - gccProgram (withPrograms lbi) (cName:"-o":oNname:args) - return True - `catchIO` (\_ -> return False) - `catchExit` (\_ -> return False) - - explainErrors Nothing [] = return () -- should be impossible! - explainErrors _ _ - | isNothing . lookupProgram gccProgram . withPrograms $ lbi - - = die' verbosity $ unlines - [ "No working gcc", - "This package depends on foreign library but we cannot " - ++ "find a working C compiler. If you have it in a " - ++ "non-standard location you can use the --with-gcc " - ++ "flag to specify it." ] - - explainErrors hdr libs = die' verbosity $ unlines $ - [ if plural - then "Missing dependencies on foreign libraries:" - else "Missing dependency on a foreign library:" - | missing ] - ++ case hdr of - Just (Left h) -> ["* Missing (or bad) header file: " ++ h ] - _ -> [] - ++ case libs of - [] -> [] - [lib] -> ["* Missing (or bad) C library: " ++ lib] - _ -> ["* Missing (or bad) C libraries: " ++ - intercalate ", " libs] - ++ [if plural then messagePlural else messageSingular | missing] - ++ case hdr of - Just (Left _) -> [ headerCppMessage ] - Just (Right h) -> [ (if missing then "* " else "") - ++ "Bad header file: " ++ h - , headerCcMessage ] - _ -> [] - - where - plural = length libs >= 2 - -- Is there something missing? (as opposed to broken) - missing = not (null libs) - || case hdr of Just (Left _) -> True; _ -> False - - messageSingular = - "This problem can usually be solved by installing the system " - ++ "package that provides this library (you may need the " - ++ "\"-dev\" version). If the library is already installed " - ++ "but in a non-standard location then you can use the flags " - ++ "--extra-include-dirs= and --extra-lib-dirs= to specify " - ++ "where it is." - ++ "If the library file does exist, it may contain errors that " - ++ "are caught by the C compiler at the preprocessing stage. " - ++ "In this case you can re-run configure with the verbosity " - ++ "flag -v3 to see the error messages." - messagePlural = - "This problem can usually be solved by installing the system " - ++ "packages that provide these libraries (you may need the " - ++ "\"-dev\" versions). If the libraries are already installed " - ++ "but in a non-standard location then you can use the flags " - ++ "--extra-include-dirs= and --extra-lib-dirs= to specify " - ++ "where they are." - ++ "If the library files do exist, it may contain errors that " - ++ "are caught by the C compiler at the preprocessing stage. " - ++ "In this case you can re-run configure with the verbosity " - ++ "flag -v3 to see the error messages." - headerCppMessage = - "If the header file does exist, it may contain errors that " - ++ "are caught by the C compiler at the preprocessing stage. " - ++ "In this case you can re-run configure with the verbosity " - ++ "flag -v3 to see the error messages." - headerCcMessage = - "The header file contains a compile error. " - ++ "You can re-run configure with the verbosity flag " - ++ "-v3 to see the error messages from the C compiler." - --- | Output package check warnings and errors. Exit if any errors. -checkPackageProblems :: Verbosity - -> FilePath - -- ^ Path to the @.cabal@ file's directory - -> GenericPackageDescription - -> PackageDescription - -> IO () -checkPackageProblems verbosity dir gpkg pkg = do - ioChecks <- checkPackageFiles verbosity pkg dir - let pureChecks = checkPackage gpkg (Just pkg) - errors = [ e | PackageBuildImpossible e <- pureChecks ++ ioChecks ] - warnings = [ w | PackageBuildWarning w <- pureChecks ++ ioChecks ] - if null errors - then traverse_ (warn verbosity) warnings - else die' verbosity (intercalate "\n\n" errors) - --- | Preform checks if a relocatable build is allowed -checkRelocatable :: Verbosity - -> PackageDescription - -> LocalBuildInfo - -> IO () -checkRelocatable verbosity pkg lbi - = sequence_ [ checkOS - , checkCompiler - , packagePrefixRelative - , depsPrefixRelative - ] - where - -- Check if the OS support relocatable builds. - -- - -- If you add new OS' to this list, and your OS supports dynamic libraries - -- and RPATH, make sure you add your OS to RPATH-support list of: - -- Distribution.Simple.GHC.getRPaths - checkOS - = unless (os `elem` [ OSX, Linux ]) - $ die' verbosity $ "Operating system: " ++ prettyShow os ++ - ", does not support relocatable builds" - where - (Platform _ os) = hostPlatform lbi - - -- Check if the Compiler support relocatable builds - checkCompiler - = unless (compilerFlavor comp `elem` [ GHC ]) - $ die' verbosity $ "Compiler: " ++ show comp ++ - ", does not support relocatable builds" - where - comp = compiler lbi - - -- Check if all the install dirs are relative to same prefix - packagePrefixRelative - = unless (relativeInstallDirs installDirs) - $ die' verbosity $ "Installation directories are not prefix_relative:\n" ++ - show installDirs - where - -- NB: should be good enough to check this against the default - -- component ID, but if we wanted to be strictly correct we'd - -- check for each ComponentId. - installDirs = absoluteInstallDirs pkg lbi NoCopyDest - p = prefix installDirs - relativeInstallDirs (InstallDirs {..}) = - all isJust - (fmap (stripPrefix p) - [ bindir, libdir, dynlibdir, libexecdir, includedir, datadir - , docdir, mandir, htmldir, haddockdir, sysconfdir] ) - - -- Check if the library dirs of the dependencies that are in the package - -- database to which the package is installed are relative to the - -- prefix of the package - depsPrefixRelative = do - pkgr <- GHC.pkgRoot verbosity lbi (registrationPackageDB (withPackageDB lbi)) - traverse_ (doCheck pkgr) ipkgs - where - doCheck pkgr ipkg - | maybe False (== pkgr) (IPI.pkgRoot ipkg) - = for_ (IPI.libraryDirs ipkg) $ \libdir -> do - -- When @prefix@ is not under @pkgroot@, - -- @shortRelativePath prefix pkgroot@ will return a path with - -- @..@s and following check will fail without @canonicalizePath@. - canonicalized <- canonicalizePath libdir - unless (p `isPrefixOf` canonicalized) $ - die' verbosity $ msg libdir - | otherwise - = return () - -- NB: should be good enough to check this against the default - -- component ID, but if we wanted to be strictly correct we'd - -- check for each ComponentId. - installDirs = absoluteInstallDirs pkg lbi NoCopyDest - p = prefix installDirs - ipkgs = PackageIndex.allPackages (installedPkgs lbi) - msg l = "Library directory of a dependency: " ++ show l ++ - "\nis not relative to the installation prefix:\n" ++ - show p - --- ----------------------------------------------------------------------------- --- Testing foreign library requirements - -unsupportedForeignLibs :: Compiler -> Platform -> [ForeignLib] -> [String] -unsupportedForeignLibs comp platform = - mapMaybe (checkForeignLibSupported comp platform) - -checkForeignLibSupported :: Compiler -> Platform -> ForeignLib -> Maybe String -checkForeignLibSupported comp platform flib = go (compilerFlavor comp) - where - go :: CompilerFlavor -> Maybe String - go GHC - | compilerVersion comp < mkVersion [7,8] = unsupported [ - "Building foreign libraires is only supported with GHC >= 7.8" - ] - | otherwise = goGhcPlatform platform - go _ = unsupported [ - "Building foreign libraries is currently only supported with ghc" - ] - - goGhcPlatform :: Platform -> Maybe String - goGhcPlatform (Platform X86_64 OSX ) = goGhcOsx (foreignLibType flib) - goGhcPlatform (Platform _ Linux ) = goGhcLinux (foreignLibType flib) - goGhcPlatform (Platform I386 Windows) = goGhcWindows (foreignLibType flib) - goGhcPlatform (Platform X86_64 Windows) = goGhcWindows (foreignLibType flib) - goGhcPlatform _ = unsupported [ - "Building foreign libraries is currently only supported on OSX, " - , "Linux and Windows" - ] - - goGhcOsx :: ForeignLibType -> Maybe String - goGhcOsx ForeignLibNativeShared - | not (null (foreignLibModDefFile flib)) = unsupported [ - "Module definition file not supported on OSX" - ] - | not (null (foreignLibVersionInfo flib)) = unsupported [ - "Foreign library versioning not currently supported on OSX" - ] - | otherwise = - Nothing - goGhcOsx _ = unsupported [ - "We can currently only build shared foreign libraries on OSX" - ] - - goGhcLinux :: ForeignLibType -> Maybe String - goGhcLinux ForeignLibNativeShared - | not (null (foreignLibModDefFile flib)) = unsupported [ - "Module definition file not supported on Linux" - ] - | not (null (foreignLibVersionInfo flib)) - && not (null (foreignLibVersionLinux flib)) = unsupported [ - "You must not specify both lib-version-info and lib-version-linux" - ] - | otherwise = - Nothing - goGhcLinux _ = unsupported [ - "We can currently only build shared foreign libraries on Linux" - ] - - goGhcWindows :: ForeignLibType -> Maybe String - goGhcWindows ForeignLibNativeShared - | not standalone = unsupported [ - "We can currently only build standalone libraries on Windows. Use\n" - , " if os(Windows)\n" - , " options: standalone\n" - , "in your foreign-library stanza." - ] - | not (null (foreignLibVersionInfo flib)) = unsupported [ - "Foreign library versioning not currently supported on Windows.\n" - , "You can specify module definition files in the mod-def-file field." - ] - | otherwise = - Nothing - goGhcWindows _ = unsupported [ - "We can currently only build shared foreign libraries on Windows" - ] - - standalone :: Bool - standalone = ForeignLibStandalone `elem` foreignLibOptions flib - - unsupported :: [String] -> Maybe String - unsupported = Just . concat diff --git a/cabal/Cabal/Distribution/Simple/Doctest.hs b/cabal/Cabal/Distribution/Simple/Doctest.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/Doctest.hs +++ /dev/null @@ -1,187 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Doctest --- Copyright : Moritz Angermann 2017 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This module deals with the @doctest@ command. - --- Note: this module is modelled after Distribution.Simple.Haddock - -module Distribution.Simple.Doctest ( - doctest - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import qualified Distribution.Simple.GHC as GHC -import qualified Distribution.Simple.GHCJS as GHCJS - --- local -import Distribution.PackageDescription -import Distribution.Simple.Compiler -import Distribution.Simple.Program.GHC -import Distribution.Simple.Program -import Distribution.Simple.PreProcess -import Distribution.Simple.Setup -import Distribution.Simple.Build -import Distribution.Simple.LocalBuildInfo hiding (substPathTemplate) -import Distribution.Simple.Register (internalPackageDBPath) -import Distribution.Simple.BuildPaths -import Distribution.Simple.Utils -import Distribution.System -import Distribution.Version -import Distribution.Verbosity - --- ----------------------------------------------------------------------------- --- Types - --- | A record that represents the arguments to the doctest executable. -data DoctestArgs = DoctestArgs { - argTargets :: [FilePath] - -- ^ Modules to process - , argGhcOptions :: Flag (GhcOptions, Version) -} deriving (Show, Generic) - --- ----------------------------------------------------------------------------- --- Doctest support - -doctest :: PackageDescription - -> LocalBuildInfo - -> [PPSuffixHandler] - -> DoctestFlags - -> IO () -doctest pkg_descr lbi suffixes doctestFlags = do - let verbosity = flag doctestVerbosity - distPref = flag doctestDistPref - flag f = fromFlag $ f doctestFlags - tmpFileOpts = defaultTempFileOptions - lbi' = lbi { withPackageDB = withPackageDB lbi - ++ [SpecificPackageDB (internalPackageDBPath lbi distPref)] } - - (doctestProg, _version, _) <- - requireProgramVersion verbosity doctestProgram - (orLaterVersion (mkVersion [0,11,3])) (withPrograms lbi) - - withAllComponentsInBuildOrder pkg_descr lbi $ \component clbi -> do - componentInitialBuildSteps distPref pkg_descr lbi clbi verbosity - preprocessComponent pkg_descr component lbi clbi False verbosity suffixes - - case component of - CLib lib -> do - withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $ - \tmp -> do - inFiles <- map snd <$> getLibSourceFiles verbosity lbi lib clbi - args <- mkDoctestArgs verbosity tmp lbi' clbi inFiles (libBuildInfo lib) - runDoctest verbosity (compiler lbi) (hostPlatform lbi) doctestProg args - CExe exe -> do - withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $ - \tmp -> do - inFiles <- map snd <$> getExeSourceFiles verbosity lbi exe clbi - args <- mkDoctestArgs verbosity tmp lbi' clbi inFiles (buildInfo exe) - runDoctest verbosity (compiler lbi) (hostPlatform lbi) doctestProg args - CFLib _ -> return () -- do not doctest foreign libs - CTest _ -> return () -- do not doctest tests - CBench _ -> return () -- do not doctest benchmarks - --- ----------------------------------------------------------------------------- --- Contributions to DoctestArgs (see also Haddock.hs for very similar code). - -componentGhcOptions :: Verbosity -> LocalBuildInfo - -> BuildInfo -> ComponentLocalBuildInfo -> FilePath - -> GhcOptions -componentGhcOptions verbosity lbi bi clbi odir = - let f = case compilerFlavor (compiler lbi) of - GHC -> GHC.componentGhcOptions - GHCJS -> GHCJS.componentGhcOptions - _ -> error $ - "Distribution.Simple.Doctest.componentGhcOptions:" ++ - "doctest only supports GHC and GHCJS" - in f verbosity lbi bi clbi odir - -mkDoctestArgs :: Verbosity - -> FilePath - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> [FilePath] - -> BuildInfo - -> IO DoctestArgs -mkDoctestArgs verbosity tmp lbi clbi inFiles bi = do - let vanillaOpts = (componentGhcOptions normal lbi bi clbi (buildDir lbi)) - { ghcOptOptimisation = mempty -- no optimizations when runnign doctest - -- disable -Wmissing-home-modules - , ghcOptWarnMissingHomeModules = mempty - -- clear out ghc-options: these are likely not meant for doctest. - -- If so, should be explicitly specified via doctest-ghc-options: again. - , ghcOptExtra = mempty - , ghcOptCabal = toFlag False - - , ghcOptObjDir = toFlag tmp - , ghcOptHiDir = toFlag tmp - , ghcOptStubDir = toFlag tmp } - sharedOpts = vanillaOpts - { ghcOptDynLinkMode = toFlag GhcDynamicOnly - , ghcOptFPic = toFlag True - , ghcOptHiSuffix = toFlag "dyn_hi" - , ghcOptObjSuffix = toFlag "dyn_o" - , ghcOptExtra = hcSharedOptions GHC bi} - opts <- if withVanillaLib lbi - then return vanillaOpts - else if withSharedLib lbi - then return sharedOpts - else die' verbosity $ "Must have vanilla or shared libraries " - ++ "enabled in order to run doctest" - ghcVersion <- maybe (die' verbosity "Compiler has no GHC version") - return - (compilerCompatVersion GHC (compiler lbi)) - return $ DoctestArgs - { argTargets = inFiles - , argGhcOptions = toFlag (opts, ghcVersion) - } - - --- ----------------------------------------------------------------------------- --- Call doctest with the specified arguments. -runDoctest :: Verbosity - -> Compiler - -> Platform - -> ConfiguredProgram - -> DoctestArgs - -> IO () -runDoctest verbosity comp platform doctestProg args = do - renderArgs verbosity comp platform args $ - \(flags, files) -> do - runProgram verbosity doctestProg (flags <> files) - -renderArgs :: Verbosity - -> Compiler - -> Platform - -> DoctestArgs - -> (([String],[FilePath]) -> IO a) - -> IO a -renderArgs _verbosity comp platform args k = do - k (flags, argTargets args) - where - flags :: [String] - flags = mconcat - [ pure "--no-magic" -- disable doctests automagic discovery heuristics - , pure "-fdiagnostics-color=never" -- disable ghc's color diagnostics. - , [ opt | (opts, _ghcVer) <- flagToList (argGhcOptions args) - , opt <- renderGhcOptions comp platform opts ] - ] - --- ------------------------------------------------------------------------------ --- Boilerplate Monoid instance. -instance Monoid DoctestArgs where - mempty = gmempty - mappend = (<>) - -instance Semigroup DoctestArgs where - (<>) = gmappend diff --git a/cabal/Cabal/Distribution/Simple/Flag.hs b/cabal/Cabal/Distribution/Simple/Flag.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/Flag.hs +++ /dev/null @@ -1,132 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Flag --- Copyright : Isaac Jones 2003-2004 --- Duncan Coutts 2007 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Defines the 'Flag' type and it's 'Monoid' instance, see --- --- for an explanation. --- --- Split off from "Distribution.Simple.Setup" to break import cycles. -module Distribution.Simple.Flag ( - Flag(..), - allFlags, - toFlag, - fromFlag, - fromFlagOrDefault, - flagElim, - flagToMaybe, - flagToList, - maybeToFlag, - BooleanFlag(..) ) where - -import Prelude () -import Distribution.Compat.Prelude hiding (get) -import Distribution.Compat.Stack - --- ------------------------------------------------------------ --- * Flag type --- ------------------------------------------------------------ - --- | All flags are monoids, they come in two flavours: --- --- 1. list flags eg --- --- > --ghc-option=foo --ghc-option=bar --- --- gives us all the values ["foo", "bar"] --- --- 2. singular value flags, eg: --- --- > --enable-foo --disable-foo --- --- gives us Just False --- So this Flag type is for the latter singular kind of flag. --- Its monoid instance gives us the behaviour where it starts out as --- 'NoFlag' and later flags override earlier ones. --- -data Flag a = Flag a | NoFlag deriving (Eq, Generic, Show, Read, Typeable) - -instance Binary a => Binary (Flag a) -instance Structured a => Structured (Flag a) - -instance Functor Flag where - fmap f (Flag x) = Flag (f x) - fmap _ NoFlag = NoFlag - -instance Applicative Flag where - (Flag x) <*> y = x <$> y - NoFlag <*> _ = NoFlag - pure = Flag - -instance Monoid (Flag a) where - mempty = NoFlag - mappend = (<>) - -instance Semigroup (Flag a) where - _ <> f@(Flag _) = f - f <> NoFlag = f - -instance Bounded a => Bounded (Flag a) where - minBound = toFlag minBound - maxBound = toFlag maxBound - -instance Enum a => Enum (Flag a) where - fromEnum = fromEnum . fromFlag - toEnum = toFlag . toEnum - enumFrom (Flag a) = map toFlag . enumFrom $ a - enumFrom _ = [] - enumFromThen (Flag a) (Flag b) = toFlag `map` enumFromThen a b - enumFromThen _ _ = [] - enumFromTo (Flag a) (Flag b) = toFlag `map` enumFromTo a b - enumFromTo _ _ = [] - enumFromThenTo (Flag a) (Flag b) (Flag c) = toFlag `map` enumFromThenTo a b c - enumFromThenTo _ _ _ = [] - -toFlag :: a -> Flag a -toFlag = Flag - -fromFlag :: WithCallStack (Flag a -> a) -fromFlag (Flag x) = x -fromFlag NoFlag = error "fromFlag NoFlag. Use fromFlagOrDefault" - -fromFlagOrDefault :: a -> Flag a -> a -fromFlagOrDefault _ (Flag x) = x -fromFlagOrDefault def NoFlag = def - -flagToMaybe :: Flag a -> Maybe a -flagToMaybe (Flag x) = Just x -flagToMaybe NoFlag = Nothing - --- | @since 3.4.0.0 -flagElim :: b -> (a -> b) -> Flag a -> b -flagElim n _ NoFlag = n -flagElim _ f (Flag x) = f x - -flagToList :: Flag a -> [a] -flagToList (Flag x) = [x] -flagToList NoFlag = [] - -allFlags :: [Flag Bool] -> Flag Bool -allFlags flags = if all (\f -> fromFlagOrDefault False f) flags - then Flag True - else NoFlag - -maybeToFlag :: Maybe a -> Flag a -maybeToFlag Nothing = NoFlag -maybeToFlag (Just x) = Flag x - --- | Types that represent boolean flags. -class BooleanFlag a where - asBool :: a -> Bool - -instance BooleanFlag Bool where - asBool = id diff --git a/cabal/Cabal/Distribution/Simple/GHC.hs b/cabal/Cabal/Distribution/Simple/GHC.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/GHC.hs +++ /dev/null @@ -1,2083 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.GHC --- Copyright : Isaac Jones 2003-2007 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This is a fairly large module. It contains most of the GHC-specific code for --- configuring, building and installing packages. It also exports a function --- for finding out what packages are already installed. Configuring involves --- finding the @ghc@ and @ghc-pkg@ programs, finding what language extensions --- this version of ghc supports and returning a 'Compiler' value. --- --- 'getInstalledPackages' involves calling the @ghc-pkg@ program to find out --- what packages are installed. --- --- Building is somewhat complex as there is quite a bit of information to take --- into account. We have to build libs and programs, possibly for profiling and --- shared libs. We have to support building libraries that will be usable by --- GHCi and also ghc's @-split-objs@ feature. We have to compile any C files --- using ghc. Linking, especially for @split-objs@ is remarkably complex, --- partly because there tend to be 1,000's of @.o@ files and this can often be --- more than we can pass to the @ld@ or @ar@ programs in one go. --- --- Installing for libs and exes involves finding the right files and copying --- them to the right places. One of the more tricky things about this module is --- remembering the layout of files in the build directory (which is not --- explicitly documented) and thus what search dirs are used for various kinds --- of files. - -module Distribution.Simple.GHC ( - getGhcInfo, - configure, - getInstalledPackages, - getInstalledPackagesMonitorFiles, - getPackageDBContents, - buildLib, buildFLib, buildExe, - replLib, replFLib, replExe, - startInterpreter, - installLib, installFLib, installExe, - libAbiHash, - hcPkgInfo, - registerPackage, - componentGhcOptions, - componentCcGhcOptions, - getGhcAppDir, - getLibDir, - isDynamic, - getGlobalPackageDB, - pkgRoot, - -- * Constructing and deconstructing GHC environment files - Internal.GhcEnvironmentFileEntry(..), - Internal.simpleGhcEnvironmentFile, - Internal.renderGhcEnvironmentFile, - Internal.writeGhcEnvironmentFile, - Internal.ghcPlatformAndVersionString, - readGhcEnvironmentFile, - parseGhcEnvironmentFile, - ParseErrorExc(..), - -- * Version-specific implementation quirks - getImplInfo, - GhcImplInfo(..) - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import qualified Distribution.Simple.GHC.Internal as Internal -import Distribution.CabalSpecVersion -import Distribution.Simple.GHC.ImplInfo -import Distribution.Simple.GHC.EnvironmentParser -import Distribution.PackageDescription.Utils (cabalBug) -import Distribution.PackageDescription as PD -import Distribution.InstalledPackageInfo (InstalledPackageInfo) -import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo -import Distribution.Simple.PackageIndex (InstalledPackageIndex) -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.LocalBuildInfo -import Distribution.Types.ComponentLocalBuildInfo -import qualified Distribution.Simple.Hpc as Hpc -import Distribution.Simple.BuildPaths -import Distribution.Simple.Utils -import Distribution.Package -import qualified Distribution.ModuleName as ModuleName -import Distribution.ModuleName (ModuleName) -import Distribution.Simple.Program -import Distribution.Simple.Program.Builtin (runghcProgram) -import qualified Distribution.Simple.Program.HcPkg as HcPkg -import qualified Distribution.Simple.Program.Ar as Ar -import qualified Distribution.Simple.Program.Ld as Ld -import qualified Distribution.Simple.Program.Strip as Strip -import Distribution.Simple.Program.GHC -import Distribution.Simple.Setup -import qualified Distribution.Simple.Setup as Cabal -import Distribution.Simple.Compiler -import Distribution.Version -import Distribution.System -import Distribution.Verbosity -import Distribution.Pretty -import Distribution.Utils.NubList -import Language.Haskell.Extension - -import Control.Monad (msum, forM_) -import Data.Char (isLower) -import qualified Data.Map as Map -import System.Directory - ( doesFileExist, getAppUserDataDirectory, createDirectoryIfMissing - , canonicalizePath, removeFile, renameFile, getDirectoryContents ) -import System.FilePath ( (), (<.>), takeExtension - , takeDirectory, replaceExtension - ,isRelative ) -import qualified System.Info -#ifndef mingw32_HOST_OS -import System.Posix (createSymbolicLink) -#endif /* mingw32_HOST_OS */ - --- ----------------------------------------------------------------------------- --- Configuring - -configure :: Verbosity -> Maybe FilePath -> Maybe FilePath - -> ProgramDb - -> IO (Compiler, Maybe Platform, ProgramDb) -configure verbosity hcPath hcPkgPath conf0 = do - - (ghcProg, ghcVersion, progdb1) <- - requireProgramVersion verbosity ghcProgram - (orLaterVersion (mkVersion [7,0,1])) - (userMaybeSpecifyPath "ghc" hcPath conf0) - let implInfo = ghcVersionImplInfo ghcVersion - - -- Cabal currently supports ghc >= 7.0.1 && < 8.12 - unless (ghcVersion < mkVersion [8,14]) $ - warn verbosity $ - "Unknown/unsupported 'ghc' version detected " - ++ "(Cabal " ++ prettyShow cabalVersion ++ " supports 'ghc' version < 8.12): " - ++ programPath ghcProg ++ " is version " ++ prettyShow ghcVersion - - -- This is slightly tricky, we have to configure ghc first, then we use the - -- location of ghc to help find ghc-pkg in the case that the user did not - -- specify the location of ghc-pkg directly: - (ghcPkgProg, ghcPkgVersion, progdb2) <- - requireProgramVersion verbosity ghcPkgProgram { - programFindLocation = guessGhcPkgFromGhcPath ghcProg - } - anyVersion (userMaybeSpecifyPath "ghc-pkg" hcPkgPath progdb1) - - when (ghcVersion /= ghcPkgVersion) $ die' verbosity $ - "Version mismatch between ghc and ghc-pkg: " - ++ programPath ghcProg ++ " is version " ++ prettyShow ghcVersion ++ " " - ++ programPath ghcPkgProg ++ " is version " ++ prettyShow ghcPkgVersion - - -- Likewise we try to find the matching hsc2hs and haddock programs. - let hsc2hsProgram' = hsc2hsProgram { - programFindLocation = guessHsc2hsFromGhcPath ghcProg - } - haddockProgram' = haddockProgram { - programFindLocation = guessHaddockFromGhcPath ghcProg - } - hpcProgram' = hpcProgram { - programFindLocation = guessHpcFromGhcPath ghcProg - } - runghcProgram' = runghcProgram { - programFindLocation = guessRunghcFromGhcPath ghcProg - } - progdb3 = addKnownProgram haddockProgram' $ - addKnownProgram hsc2hsProgram' $ - addKnownProgram hpcProgram' $ - addKnownProgram runghcProgram' progdb2 - - languages <- Internal.getLanguages verbosity implInfo ghcProg - extensions0 <- Internal.getExtensions verbosity implInfo ghcProg - - ghcInfo <- Internal.getGhcInfo verbosity implInfo ghcProg - let ghcInfoMap = Map.fromList ghcInfo - extensions = -- workaround https://gitlab.haskell.org/ghc/ghc/-/issues/11214 - filterExt JavaScriptFFI $ - -- see 'filterExtTH' comment below - filterExtTH $ extensions0 - - -- starting with GHC 8.0, `TemplateHaskell` will be omitted from - -- `--supported-extensions` when it's not available. - -- for older GHCs we can use the "Have interpreter" property to - -- filter out `TemplateHaskell` - filterExtTH | ghcVersion < mkVersion [8] - , Just "NO" <- Map.lookup "Have interpreter" ghcInfoMap - = filterExt TemplateHaskell - | otherwise = id - - filterExt ext = filter ((/= EnableExtension ext) . fst) - - let comp = Compiler { - compilerId = CompilerId GHC ghcVersion, - compilerAbiTag = NoAbiTag, - compilerCompat = [], - compilerLanguages = languages, - compilerExtensions = extensions, - compilerProperties = ghcInfoMap - } - compPlatform = Internal.targetPlatform ghcInfo - -- configure gcc and ld - progdb4 = Internal.configureToolchain implInfo ghcProg ghcInfoMap progdb3 - return (comp, compPlatform, progdb4) - --- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find --- the corresponding tool; e.g. if the tool is ghc-pkg, we try looking --- for a versioned or unversioned ghc-pkg in the same dir, that is: --- --- > /usr/local/bin/ghc-pkg-ghc-6.6.1(.exe) --- > /usr/local/bin/ghc-pkg-6.6.1(.exe) --- > /usr/local/bin/ghc-pkg(.exe) --- -guessToolFromGhcPath :: Program -> ConfiguredProgram - -> Verbosity -> ProgramSearchPath - -> IO (Maybe (FilePath, [FilePath])) -guessToolFromGhcPath tool ghcProg verbosity searchpath - = do let toolname = programName tool - given_path = programPath ghcProg - given_dir = takeDirectory given_path - real_path <- canonicalizePath given_path - let real_dir = takeDirectory real_path - versionSuffix path = takeVersionSuffix (dropExeExtension path) - given_suf = versionSuffix given_path - real_suf = versionSuffix real_path - guessNormal dir = dir toolname <.> exeExtension buildPlatform - guessGhcVersioned dir suf = dir (toolname ++ "-ghc" ++ suf) - <.> exeExtension buildPlatform - guessVersioned dir suf = dir (toolname ++ suf) - <.> exeExtension buildPlatform - mkGuesses dir suf | null suf = [guessNormal dir] - | otherwise = [guessGhcVersioned dir suf, - guessVersioned dir suf, - guessNormal dir] - guesses = mkGuesses given_dir given_suf ++ - if real_path == given_path - then [] - else mkGuesses real_dir real_suf - info verbosity $ "looking for tool " ++ toolname - ++ " near compiler in " ++ given_dir - debug verbosity $ "candidate locations: " ++ show guesses - exists <- traverse doesFileExist guesses - case [ file | (file, True) <- zip guesses exists ] of - -- If we can't find it near ghc, fall back to the usual - -- method. - [] -> programFindLocation tool verbosity searchpath - (fp:_) -> do info verbosity $ "found " ++ toolname ++ " in " ++ fp - let lookedAt = map fst - . takeWhile (\(_file, exist) -> not exist) - $ zip guesses exists - return (Just (fp, lookedAt)) - - where takeVersionSuffix :: FilePath -> String - takeVersionSuffix = takeWhileEndLE isSuffixChar - - isSuffixChar :: Char -> Bool - isSuffixChar c = isDigit c || c == '.' || c == '-' - --- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a --- corresponding ghc-pkg, we try looking for both a versioned and unversioned --- ghc-pkg in the same dir, that is: --- --- > /usr/local/bin/ghc-pkg-ghc-6.6.1(.exe) --- > /usr/local/bin/ghc-pkg-6.6.1(.exe) --- > /usr/local/bin/ghc-pkg(.exe) --- -guessGhcPkgFromGhcPath :: ConfiguredProgram - -> Verbosity -> ProgramSearchPath - -> IO (Maybe (FilePath, [FilePath])) -guessGhcPkgFromGhcPath = guessToolFromGhcPath ghcPkgProgram - --- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a --- corresponding hsc2hs, we try looking for both a versioned and unversioned --- hsc2hs in the same dir, that is: --- --- > /usr/local/bin/hsc2hs-ghc-6.6.1(.exe) --- > /usr/local/bin/hsc2hs-6.6.1(.exe) --- > /usr/local/bin/hsc2hs(.exe) --- -guessHsc2hsFromGhcPath :: ConfiguredProgram - -> Verbosity -> ProgramSearchPath - -> IO (Maybe (FilePath, [FilePath])) -guessHsc2hsFromGhcPath = guessToolFromGhcPath hsc2hsProgram - --- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a --- corresponding haddock, we try looking for both a versioned and unversioned --- haddock in the same dir, that is: --- --- > /usr/local/bin/haddock-ghc-6.6.1(.exe) --- > /usr/local/bin/haddock-6.6.1(.exe) --- > /usr/local/bin/haddock(.exe) --- -guessHaddockFromGhcPath :: ConfiguredProgram - -> Verbosity -> ProgramSearchPath - -> IO (Maybe (FilePath, [FilePath])) -guessHaddockFromGhcPath = guessToolFromGhcPath haddockProgram - -guessHpcFromGhcPath :: ConfiguredProgram - -> Verbosity -> ProgramSearchPath - -> IO (Maybe (FilePath, [FilePath])) -guessHpcFromGhcPath = guessToolFromGhcPath hpcProgram - -guessRunghcFromGhcPath :: ConfiguredProgram - -> Verbosity -> ProgramSearchPath - -> IO (Maybe (FilePath, [FilePath])) -guessRunghcFromGhcPath = guessToolFromGhcPath runghcProgram - - -getGhcInfo :: Verbosity -> ConfiguredProgram -> IO [(String, String)] -getGhcInfo verbosity ghcProg = Internal.getGhcInfo verbosity implInfo ghcProg - where - version = fromMaybe (error "GHC.getGhcInfo: no ghc version") $ programVersion ghcProg - implInfo = ghcVersionImplInfo version - --- | Given a single package DB, return all installed packages. -getPackageDBContents :: Verbosity -> PackageDB -> ProgramDb - -> IO InstalledPackageIndex -getPackageDBContents verbosity packagedb progdb = do - pkgss <- getInstalledPackages' verbosity [packagedb] progdb - toPackageIndex verbosity pkgss progdb - --- | Given a package DB stack, return all installed packages. -getInstalledPackages :: Verbosity -> Compiler -> PackageDBStack - -> ProgramDb - -> IO InstalledPackageIndex -getInstalledPackages verbosity comp packagedbs progdb = do - checkPackageDbEnvVar verbosity - checkPackageDbStack verbosity comp packagedbs - pkgss <- getInstalledPackages' verbosity packagedbs progdb - index <- toPackageIndex verbosity pkgss progdb - return $! hackRtsPackage index - - where - hackRtsPackage index = - case PackageIndex.lookupPackageName index (mkPackageName "rts") of - [(_,[rts])] - -> PackageIndex.insert (removeMingwIncludeDir rts) index - _ -> index -- No (or multiple) ghc rts package is registered!! - -- Feh, whatever, the ghc test suite does some crazy stuff. - --- | Given a list of @(PackageDB, InstalledPackageInfo)@ pairs, produce a --- @PackageIndex@. Helper function used by 'getPackageDBContents' and --- 'getInstalledPackages'. -toPackageIndex :: Verbosity - -> [(PackageDB, [InstalledPackageInfo])] - -> ProgramDb - -> IO InstalledPackageIndex -toPackageIndex verbosity pkgss progdb = do - -- On Windows, various fields have $topdir/foo rather than full - -- paths. We need to substitute the right value in so that when - -- we, for example, call gcc, we have proper paths to give it. - topDir <- getLibDir' verbosity ghcProg - let indices = [ PackageIndex.fromList (map (Internal.substTopDir topDir) pkgs) - | (_, pkgs) <- pkgss ] - return $! mconcat indices - - where - ghcProg = fromMaybe (error "GHC.toPackageIndex: no ghc program") $ lookupProgram ghcProgram progdb - --- | Return the 'FilePath' to the GHC application data directory. --- --- @since 3.4.0.0 -getGhcAppDir :: IO FilePath -getGhcAppDir = getAppUserDataDirectory "ghc" - -getLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath -getLibDir verbosity lbi = - dropWhileEndLE isSpace `fmap` - getDbProgramOutput verbosity ghcProgram - (withPrograms lbi) ["--print-libdir"] - -getLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath -getLibDir' verbosity ghcProg = - dropWhileEndLE isSpace `fmap` - getProgramOutput verbosity ghcProg ["--print-libdir"] - - --- | Return the 'FilePath' to the global GHC package database. -getGlobalPackageDB :: Verbosity -> ConfiguredProgram -> IO FilePath -getGlobalPackageDB verbosity ghcProg = - dropWhileEndLE isSpace `fmap` - getProgramOutput verbosity ghcProg ["--print-global-package-db"] - --- | Return the 'FilePath' to the per-user GHC package database. -getUserPackageDB - :: Verbosity -> ConfiguredProgram -> Platform -> IO FilePath -getUserPackageDB _verbosity ghcProg platform = do - -- It's rather annoying that we have to reconstruct this, because ghc - -- hides this information from us otherwise. But for certain use cases - -- like change monitoring it really can't remain hidden. - appdir <- getGhcAppDir - return (appdir platformAndVersion packageConfFileName) - where - platformAndVersion = Internal.ghcPlatformAndVersionString - platform ghcVersion - packageConfFileName = "package.conf.d" - ghcVersion = fromMaybe (error "GHC.getUserPackageDB: no ghc version") $ programVersion ghcProg - -checkPackageDbEnvVar :: Verbosity -> IO () -checkPackageDbEnvVar verbosity = - Internal.checkPackageDbEnvVar verbosity "GHC" "GHC_PACKAGE_PATH" - -checkPackageDbStack :: Verbosity -> Compiler -> PackageDBStack -> IO () -checkPackageDbStack verbosity comp = - if flagPackageConf implInfo - then checkPackageDbStackPre76 verbosity - else checkPackageDbStackPost76 verbosity - where implInfo = ghcVersionImplInfo (compilerVersion comp) - -checkPackageDbStackPost76 :: Verbosity -> PackageDBStack -> IO () -checkPackageDbStackPost76 _ (GlobalPackageDB:rest) - | GlobalPackageDB `notElem` rest = return () -checkPackageDbStackPost76 verbosity rest - | GlobalPackageDB `elem` rest = - die' verbosity $ "If the global package db is specified, it must be " - ++ "specified first and cannot be specified multiple times" -checkPackageDbStackPost76 _ _ = return () - -checkPackageDbStackPre76 :: Verbosity -> PackageDBStack -> IO () -checkPackageDbStackPre76 _ (GlobalPackageDB:rest) - | GlobalPackageDB `notElem` rest = return () -checkPackageDbStackPre76 verbosity rest - | GlobalPackageDB `notElem` rest = - die' verbosity $ - "With current ghc versions the global package db is always used " - ++ "and must be listed first. This ghc limitation is lifted in GHC 7.6," - ++ "see https://gitlab.haskell.org/ghc/ghc/-/issues/5977" -checkPackageDbStackPre76 verbosity _ = - die' verbosity $ "If the global package db is specified, it must be " - ++ "specified first and cannot be specified multiple times" - --- GHC < 6.10 put "$topdir/include/mingw" in rts's installDirs. This --- breaks when you want to use a different gcc, so we need to filter --- it out. -removeMingwIncludeDir :: InstalledPackageInfo -> InstalledPackageInfo -removeMingwIncludeDir pkg = - let ids = InstalledPackageInfo.includeDirs pkg - ids' = filter (not . ("mingw" `isSuffixOf`)) ids - in pkg { InstalledPackageInfo.includeDirs = ids' } - --- | Get the packages from specific PackageDBs, not cumulative. --- -getInstalledPackages' :: Verbosity -> [PackageDB] -> ProgramDb - -> IO [(PackageDB, [InstalledPackageInfo])] -getInstalledPackages' verbosity packagedbs progdb = - sequenceA - [ do pkgs <- HcPkg.dump (hcPkgInfo progdb) verbosity packagedb - return (packagedb, pkgs) - | packagedb <- packagedbs ] - -getInstalledPackagesMonitorFiles :: Verbosity -> Platform - -> ProgramDb - -> [PackageDB] - -> IO [FilePath] -getInstalledPackagesMonitorFiles verbosity platform progdb = - traverse getPackageDBPath - where - getPackageDBPath :: PackageDB -> IO FilePath - getPackageDBPath GlobalPackageDB = - selectMonitorFile =<< getGlobalPackageDB verbosity ghcProg - - getPackageDBPath UserPackageDB = - selectMonitorFile =<< getUserPackageDB verbosity ghcProg platform - - getPackageDBPath (SpecificPackageDB path) = selectMonitorFile path - - -- GHC has old style file dbs, and new style directory dbs. - -- Note that for dir style dbs, we only need to monitor the cache file, not - -- the whole directory. The ghc program itself only reads the cache file - -- so it's safe to only monitor this one file. - selectMonitorFile path = do - isFileStyle <- doesFileExist path - if isFileStyle then return path - else return (path "package.cache") - - ghcProg = fromMaybe (error "GHC.toPackageIndex: no ghc program") $ lookupProgram ghcProgram progdb - - --- ----------------------------------------------------------------------------- --- Building a library - -buildLib :: Verbosity -> Cabal.Flag (Maybe Int) - -> PackageDescription -> LocalBuildInfo - -> Library -> ComponentLocalBuildInfo -> IO () -buildLib = buildOrReplLib Nothing - -replLib :: [String] -> Verbosity - -> Cabal.Flag (Maybe Int) -> PackageDescription - -> LocalBuildInfo -> Library - -> ComponentLocalBuildInfo -> IO () -replLib = buildOrReplLib . Just - -buildOrReplLib :: Maybe [String] -> Verbosity - -> Cabal.Flag (Maybe Int) -> PackageDescription - -> LocalBuildInfo -> Library - -> ComponentLocalBuildInfo -> IO () -buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do - let uid = componentUnitId clbi - libTargetDir = componentBuildDir lbi clbi - whenVanillaLib forceVanilla = - when (forceVanilla || withVanillaLib lbi) - whenProfLib = when (withProfLib lbi) - whenSharedLib forceShared = - when (forceShared || withSharedLib lbi) - whenStaticLib forceStatic = - when (forceStatic || withStaticLib lbi) - whenGHCiLib = when (withGHCiLib lbi) - forRepl = maybe False (const True) mReplFlags - whenReplLib = when forRepl - replFlags = fromMaybe mempty mReplFlags - comp = compiler lbi - ghcVersion = compilerVersion comp - implInfo = getImplInfo comp - platform@(Platform _hostArch hostOS) = hostPlatform lbi - has_code = not (componentIsIndefinite clbi) - - (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi) - let runGhcProg = runGHC verbosity ghcProg comp platform - - let libBi = libBuildInfo lib - - let isGhcDynamic = isDynamic comp - dynamicTooSupported = supportsDynamicToo comp - doingTH = usesTemplateHaskellOrQQ libBi - forceVanillaLib = doingTH && not isGhcDynamic - forceSharedLib = doingTH && isGhcDynamic - -- TH always needs default libs, even when building for profiling - - -- Determine if program coverage should be enabled and if so, what - -- '-hpcdir' should be. - let isCoverageEnabled = libCoverage lbi - -- TODO: Historically HPC files have been put into a directory which - -- has the package name. I'm going to avoid changing this for - -- now, but it would probably be better for this to be the - -- component ID instead... - pkg_name = prettyShow (PD.package pkg_descr) - distPref = fromFlag $ configDistPref $ configFlags lbi - hpcdir way - | forRepl = mempty -- HPC is not supported in ghci - | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way pkg_name - | otherwise = mempty - - createDirectoryIfMissingVerbose verbosity True libTargetDir - -- TODO: do we need to put hs-boot files into place for mutually recursive - -- modules? - let cLikeFiles = fromNubListR $ mconcat - [ toNubListR (cSources libBi) - , toNubListR (cxxSources libBi) - , toNubListR (cmmSources libBi) - , toNubListR (asmSources libBi) - ] - cObjs = map (`replaceExtension` objExtension) cLikeFiles - baseOpts = componentGhcOptions verbosity lbi libBi clbi libTargetDir - vanillaOpts = baseOpts `mappend` mempty { - ghcOptMode = toFlag GhcModeMake, - ghcOptNumJobs = numJobs, - ghcOptInputModules = toNubListR $ allLibModules lib clbi, - ghcOptHPCDir = hpcdir Hpc.Vanilla - } - - profOpts = vanillaOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True, - ghcOptProfilingAuto = Internal.profDetailLevelFlag True - (withProfLibDetail lbi), - ghcOptHiSuffix = toFlag "p_hi", - ghcOptObjSuffix = toFlag "p_o", - ghcOptExtra = hcProfOptions GHC libBi, - ghcOptHPCDir = hpcdir Hpc.Prof - } - - sharedOpts = vanillaOpts `mappend` mempty { - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptFPic = toFlag True, - ghcOptHiSuffix = toFlag "dyn_hi", - ghcOptObjSuffix = toFlag "dyn_o", - ghcOptExtra = hcSharedOptions GHC libBi, - ghcOptHPCDir = hpcdir Hpc.Dyn - } - linkerOpts = mempty { - ghcOptLinkOptions = PD.ldOptions libBi - ++ [ "-static" - | withFullyStaticExe lbi ] - -- Pass extra `ld-options` given - -- through to GHC's linker. - ++ maybe [] programOverrideArgs - (lookupProgram ldProgram (withPrograms lbi)), - ghcOptLinkLibs = extraLibs libBi, - ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi, - ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi, - ghcOptLinkFrameworkDirs = toNubListR $ - PD.extraFrameworkDirs libBi, - ghcOptInputFiles = toNubListR - [libTargetDir x | x <- cObjs] - } - replOpts = vanillaOpts { - ghcOptExtra = Internal.filterGhciFlags - (ghcOptExtra vanillaOpts) - <> replFlags, - ghcOptNumJobs = mempty - } - `mappend` linkerOpts - `mappend` mempty { - ghcOptMode = toFlag GhcModeInteractive, - ghcOptOptimisation = toFlag GhcNoOptimisation - } - - vanillaSharedOpts = vanillaOpts `mappend` mempty { - ghcOptDynLinkMode = toFlag GhcStaticAndDynamic, - ghcOptDynHiSuffix = toFlag "dyn_hi", - ghcOptDynObjSuffix = toFlag "dyn_o", - ghcOptHPCDir = hpcdir Hpc.Dyn - } - - unless (forRepl || null (allLibModules lib clbi)) $ - do let vanilla = whenVanillaLib forceVanillaLib (runGhcProg vanillaOpts) - shared = whenSharedLib forceSharedLib (runGhcProg sharedOpts) - useDynToo = dynamicTooSupported && - (forceVanillaLib || withVanillaLib lbi) && - (forceSharedLib || withSharedLib lbi) && - null (hcSharedOptions GHC libBi) - if not has_code - then vanilla - else - if useDynToo - then do - runGhcProg vanillaSharedOpts - case (hpcdir Hpc.Dyn, hpcdir Hpc.Vanilla) of - (Cabal.Flag dynDir, Cabal.Flag vanillaDir) -> - -- When the vanilla and shared library builds are done - -- in one pass, only one set of HPC module interfaces - -- are generated. This set should suffice for both - -- static and dynamically linked executables. We copy - -- the modules interfaces so they are available under - -- both ways. - copyDirectoryRecursive verbosity dynDir vanillaDir - _ -> return () - else if isGhcDynamic - then do shared; vanilla - else do vanilla; shared - whenProfLib (runGhcProg profOpts) - - -- Build any C++ sources separately. - unless (not has_code || null (cxxSources libBi)) $ do - info verbosity "Building C++ Sources..." - sequence_ - [ do let baseCxxOpts = Internal.componentCxxGhcOptions verbosity implInfo - lbi libBi clbi libTargetDir filename - vanillaCxxOpts = if isGhcDynamic - then baseCxxOpts { ghcOptFPic = toFlag True } - else baseCxxOpts - profCxxOpts = vanillaCxxOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True, - ghcOptObjSuffix = toFlag "p_o" - } - sharedCxxOpts = vanillaCxxOpts `mappend` mempty { - ghcOptFPic = toFlag True, - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptObjSuffix = toFlag "dyn_o" - } - odir = fromFlag (ghcOptObjDir vanillaCxxOpts) - createDirectoryIfMissingVerbose verbosity True odir - let runGhcProgIfNeeded cxxOpts = do - needsRecomp <- checkNeedsRecompilation filename cxxOpts - when needsRecomp $ runGhcProg cxxOpts - runGhcProgIfNeeded vanillaCxxOpts - unless forRepl $ - whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCxxOpts) - unless forRepl $ whenProfLib (runGhcProgIfNeeded profCxxOpts) - | filename <- cxxSources libBi] - - -- build any C sources - unless (not has_code || null (cSources libBi)) $ do - info verbosity "Building C Sources..." - sequence_ - [ do let baseCcOpts = Internal.componentCcGhcOptions verbosity implInfo - lbi libBi clbi libTargetDir filename - vanillaCcOpts = if isGhcDynamic - -- Dynamic GHC requires C sources to be built - -- with -fPIC for REPL to work. See #2207. - then baseCcOpts { ghcOptFPic = toFlag True } - else baseCcOpts - profCcOpts = vanillaCcOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True, - ghcOptObjSuffix = toFlag "p_o" - } - sharedCcOpts = vanillaCcOpts `mappend` mempty { - ghcOptFPic = toFlag True, - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptObjSuffix = toFlag "dyn_o" - } - odir = fromFlag (ghcOptObjDir vanillaCcOpts) - createDirectoryIfMissingVerbose verbosity True odir - let runGhcProgIfNeeded ccOpts = do - needsRecomp <- checkNeedsRecompilation filename ccOpts - when needsRecomp $ runGhcProg ccOpts - runGhcProgIfNeeded vanillaCcOpts - unless forRepl $ - whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCcOpts) - unless forRepl $ whenProfLib (runGhcProgIfNeeded profCcOpts) - | filename <- cSources libBi] - - -- build any ASM sources - unless (not has_code || null (asmSources libBi)) $ do - info verbosity "Building Assembler Sources..." - sequence_ - [ do let baseAsmOpts = Internal.componentAsmGhcOptions verbosity implInfo - lbi libBi clbi libTargetDir filename - vanillaAsmOpts = if isGhcDynamic - -- Dynamic GHC requires objects to be built - -- with -fPIC for REPL to work. See #2207. - then baseAsmOpts { ghcOptFPic = toFlag True } - else baseAsmOpts - profAsmOpts = vanillaAsmOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True, - ghcOptObjSuffix = toFlag "p_o" - } - sharedAsmOpts = vanillaAsmOpts `mappend` mempty { - ghcOptFPic = toFlag True, - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptObjSuffix = toFlag "dyn_o" - } - odir = fromFlag (ghcOptObjDir vanillaAsmOpts) - createDirectoryIfMissingVerbose verbosity True odir - let runGhcProgIfNeeded asmOpts = do - needsRecomp <- checkNeedsRecompilation filename asmOpts - when needsRecomp $ runGhcProg asmOpts - runGhcProgIfNeeded vanillaAsmOpts - unless forRepl $ - whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedAsmOpts) - unless forRepl $ whenProfLib (runGhcProgIfNeeded profAsmOpts) - | filename <- asmSources libBi] - - -- build any Cmm sources - unless (not has_code || null (cmmSources libBi)) $ do - info verbosity "Building C-- Sources..." - sequence_ - [ do let baseCmmOpts = Internal.componentCmmGhcOptions verbosity implInfo - lbi libBi clbi libTargetDir filename - vanillaCmmOpts = if isGhcDynamic - -- Dynamic GHC requires C sources to be built - -- with -fPIC for REPL to work. See #2207. - then baseCmmOpts { ghcOptFPic = toFlag True } - else baseCmmOpts - profCmmOpts = vanillaCmmOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True, - ghcOptObjSuffix = toFlag "p_o" - } - sharedCmmOpts = vanillaCmmOpts `mappend` mempty { - ghcOptFPic = toFlag True, - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptObjSuffix = toFlag "dyn_o" - } - odir = fromFlag (ghcOptObjDir vanillaCmmOpts) - createDirectoryIfMissingVerbose verbosity True odir - let runGhcProgIfNeeded cmmOpts = do - needsRecomp <- checkNeedsRecompilation filename cmmOpts - when needsRecomp $ runGhcProg cmmOpts - runGhcProgIfNeeded vanillaCmmOpts - unless forRepl $ - whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCmmOpts) - unless forRepl $ whenProfLib (runGhcProgIfNeeded profCmmOpts) - | filename <- cmmSources libBi] - - -- TODO: problem here is we need the .c files built first, so we can load them - -- with ghci, but .c files can depend on .h files generated by ghc by ffi - -- exports. - whenReplLib $ do - when (null (allLibModules lib clbi)) $ warn verbosity "No exposed modules" - runGhcProg replOpts - - -- link: - when has_code . unless forRepl $ do - info verbosity "Linking..." - let cProfObjs = map (`replaceExtension` ("p_" ++ objExtension)) - (cSources libBi ++ cxxSources libBi) - cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension)) - (cSources libBi ++ cxxSources libBi) - compiler_id = compilerId (compiler lbi) - vanillaLibFilePath = libTargetDir mkLibName uid - profileLibFilePath = libTargetDir mkProfLibName uid - sharedLibFilePath = libTargetDir - mkSharedLibName (hostPlatform lbi) compiler_id uid - staticLibFilePath = libTargetDir - mkStaticLibName (hostPlatform lbi) compiler_id uid - ghciLibFilePath = libTargetDir Internal.mkGHCiLibName uid - ghciProfLibFilePath = libTargetDir Internal.mkGHCiProfLibName uid - libInstallPath = libdir $ - absoluteComponentInstallDirs - pkg_descr lbi uid NoCopyDest - sharedLibInstallPath = libInstallPath - mkSharedLibName (hostPlatform lbi) compiler_id uid - - stubObjs <- catMaybes <$> sequenceA - [ findFileWithExtension [objExtension] [libTargetDir] - (ModuleName.toFilePath x ++"_stub") - | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files - , x <- allLibModules lib clbi ] - stubProfObjs <- catMaybes <$> sequenceA - [ findFileWithExtension ["p_" ++ objExtension] [libTargetDir] - (ModuleName.toFilePath x ++"_stub") - | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files - , x <- allLibModules lib clbi ] - stubSharedObjs <- catMaybes <$> sequenceA - [ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir] - (ModuleName.toFilePath x ++"_stub") - | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files - , x <- allLibModules lib clbi ] - - hObjs <- Internal.getHaskellObjects implInfo lib lbi clbi - libTargetDir objExtension True - hProfObjs <- - if withProfLib lbi - then Internal.getHaskellObjects implInfo lib lbi clbi - libTargetDir ("p_" ++ objExtension) True - else return [] - hSharedObjs <- - if withSharedLib lbi - then Internal.getHaskellObjects implInfo lib lbi clbi - libTargetDir ("dyn_" ++ objExtension) False - else return [] - - unless (null hObjs && null cObjs && null stubObjs) $ do - rpaths <- getRPaths lbi clbi - - let staticObjectFiles = - hObjs - ++ map (libTargetDir ) cObjs - ++ stubObjs - profObjectFiles = - hProfObjs - ++ map (libTargetDir ) cProfObjs - ++ stubProfObjs - dynamicObjectFiles = - hSharedObjs - ++ map (libTargetDir ) cSharedObjs - ++ stubSharedObjs - -- After the relocation lib is created we invoke ghc -shared - -- with the dependencies spelled out as -package arguments - -- and ghc invokes the linker with the proper library paths - ghcSharedLinkArgs = - mempty { - ghcOptShared = toFlag True, - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptInputFiles = toNubListR dynamicObjectFiles, - ghcOptOutputFile = toFlag sharedLibFilePath, - ghcOptExtra = hcSharedOptions GHC libBi, - -- For dynamic libs, Mac OS/X needs to know the install location - -- at build time. This only applies to GHC < 7.8 - see the - -- discussion in #1660. - ghcOptDylibName = if hostOS == OSX - && ghcVersion < mkVersion [7,8] - then toFlag sharedLibInstallPath - else mempty, - ghcOptHideAllPackages = toFlag True, - ghcOptNoAutoLinkPackages = toFlag True, - ghcOptPackageDBs = withPackageDB lbi, - ghcOptThisUnitId = case clbi of - LibComponentLocalBuildInfo { componentCompatPackageKey = pk } - -> toFlag pk - _ -> mempty, - ghcOptThisComponentId = case clbi of - LibComponentLocalBuildInfo - { componentInstantiatedWith = insts } -> - if null insts - then mempty - else toFlag (componentComponentId clbi) - _ -> mempty, - ghcOptInstantiatedWith = case clbi of - LibComponentLocalBuildInfo - { componentInstantiatedWith = insts } - -> insts - _ -> [], - ghcOptPackages = toNubListR $ - Internal.mkGhcOptPackages clbi , - ghcOptLinkLibs = extraLibs libBi, - ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi, - ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi, - ghcOptLinkFrameworkDirs = - toNubListR $ PD.extraFrameworkDirs libBi, - ghcOptRPaths = rpaths - } - ghcStaticLinkArgs = - mempty { - ghcOptStaticLib = toFlag True, - ghcOptInputFiles = toNubListR staticObjectFiles, - ghcOptOutputFile = toFlag staticLibFilePath, - ghcOptExtra = hcStaticOptions GHC libBi, - ghcOptHideAllPackages = toFlag True, - ghcOptNoAutoLinkPackages = toFlag True, - ghcOptPackageDBs = withPackageDB lbi, - ghcOptThisUnitId = case clbi of - LibComponentLocalBuildInfo { componentCompatPackageKey = pk } - -> toFlag pk - _ -> mempty, - ghcOptThisComponentId = case clbi of - LibComponentLocalBuildInfo - { componentInstantiatedWith = insts } -> - if null insts - then mempty - else toFlag (componentComponentId clbi) - _ -> mempty, - ghcOptInstantiatedWith = case clbi of - LibComponentLocalBuildInfo - { componentInstantiatedWith = insts } - -> insts - _ -> [], - ghcOptPackages = toNubListR $ - Internal.mkGhcOptPackages clbi , - ghcOptLinkLibs = extraLibs libBi, - ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi - } - - info verbosity (show (ghcOptPackages ghcSharedLinkArgs)) - - whenVanillaLib False $ do - Ar.createArLibArchive verbosity lbi vanillaLibFilePath staticObjectFiles - whenGHCiLib $ do - (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi) - Ld.combineObjectFiles verbosity lbi ldProg - ghciLibFilePath staticObjectFiles - - whenProfLib $ do - Ar.createArLibArchive verbosity lbi profileLibFilePath profObjectFiles - whenGHCiLib $ do - (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi) - Ld.combineObjectFiles verbosity lbi ldProg - ghciProfLibFilePath profObjectFiles - - whenSharedLib False $ - runGhcProg ghcSharedLinkArgs - - whenStaticLib False $ - runGhcProg ghcStaticLinkArgs - --- | Start a REPL without loading any source files. -startInterpreter :: Verbosity -> ProgramDb -> Compiler -> Platform - -> PackageDBStack -> IO () -startInterpreter verbosity progdb comp platform packageDBs = do - let replOpts = mempty { - ghcOptMode = toFlag GhcModeInteractive, - ghcOptPackageDBs = packageDBs - } - checkPackageDbStack verbosity comp packageDBs - (ghcProg, _) <- requireProgram verbosity ghcProgram progdb - runGHC verbosity ghcProg comp platform replOpts - --- ----------------------------------------------------------------------------- --- Building an executable or foreign library - --- | Build a foreign library -buildFLib - :: Verbosity -> Cabal.Flag (Maybe Int) - -> PackageDescription -> LocalBuildInfo - -> ForeignLib -> ComponentLocalBuildInfo -> IO () -buildFLib v njobs pkg lbi = gbuild v njobs pkg lbi . GBuildFLib - -replFLib - :: [String] -> Verbosity - -> Cabal.Flag (Maybe Int) -> PackageDescription - -> LocalBuildInfo -> ForeignLib - -> ComponentLocalBuildInfo -> IO () -replFLib replFlags v njobs pkg lbi = - gbuild v njobs pkg lbi . GReplFLib replFlags - --- | Build an executable with GHC. --- -buildExe - :: Verbosity -> Cabal.Flag (Maybe Int) - -> PackageDescription -> LocalBuildInfo - -> Executable -> ComponentLocalBuildInfo -> IO () -buildExe v njobs pkg lbi = gbuild v njobs pkg lbi . GBuildExe - -replExe - :: [String] -> Verbosity - -> Cabal.Flag (Maybe Int) -> PackageDescription - -> LocalBuildInfo -> Executable - -> ComponentLocalBuildInfo -> IO () -replExe replFlags v njobs pkg lbi = - gbuild v njobs pkg lbi . GReplExe replFlags - --- | Building an executable, starting the REPL, and building foreign --- libraries are all very similar and implemented in 'gbuild'. The --- 'GBuildMode' distinguishes between the various kinds of operation. -data GBuildMode = - GBuildExe Executable - | GReplExe [String] Executable - | GBuildFLib ForeignLib - | GReplFLib [String] ForeignLib - -gbuildInfo :: GBuildMode -> BuildInfo -gbuildInfo (GBuildExe exe) = buildInfo exe -gbuildInfo (GReplExe _ exe) = buildInfo exe -gbuildInfo (GBuildFLib flib) = foreignLibBuildInfo flib -gbuildInfo (GReplFLib _ flib) = foreignLibBuildInfo flib - -gbuildName :: GBuildMode -> String -gbuildName (GBuildExe exe) = unUnqualComponentName $ exeName exe -gbuildName (GReplExe _ exe) = unUnqualComponentName $ exeName exe -gbuildName (GBuildFLib flib) = unUnqualComponentName $ foreignLibName flib -gbuildName (GReplFLib _ flib) = unUnqualComponentName $ foreignLibName flib - -gbuildTargetName :: LocalBuildInfo -> GBuildMode -> String -gbuildTargetName lbi (GBuildExe exe) = exeTargetName (hostPlatform lbi) exe -gbuildTargetName lbi (GReplExe _ exe) = exeTargetName (hostPlatform lbi) exe -gbuildTargetName lbi (GBuildFLib flib) = flibTargetName lbi flib -gbuildTargetName lbi (GReplFLib _ flib) = flibTargetName lbi flib - -exeTargetName :: Platform -> Executable -> String -exeTargetName platform exe = unUnqualComponentName (exeName exe) `withExt` exeExtension platform - --- | Target name for a foreign library (the actual file name) --- --- We do not use mkLibName and co here because the naming for foreign libraries --- is slightly different (we don't use "_p" or compiler version suffices, and we --- don't want the "lib" prefix on Windows). --- --- TODO: We do use `dllExtension` and co here, but really that's wrong: they --- use the OS used to build cabal to determine which extension to use, rather --- than the target OS (but this is wrong elsewhere in Cabal as well). -flibTargetName :: LocalBuildInfo -> ForeignLib -> String -flibTargetName lbi flib = - case (os, foreignLibType flib) of - (Windows, ForeignLibNativeShared) -> nm <.> "dll" - (Windows, ForeignLibNativeStatic) -> nm <.> "lib" - (Linux, ForeignLibNativeShared) -> "lib" ++ nm <.> versionedExt - (_other, ForeignLibNativeShared) -> - "lib" ++ nm <.> dllExtension (hostPlatform lbi) - (_other, ForeignLibNativeStatic) -> - "lib" ++ nm <.> staticLibExtension (hostPlatform lbi) - (_any, ForeignLibTypeUnknown) -> cabalBug "unknown foreign lib type" - where - nm :: String - nm = unUnqualComponentName $ foreignLibName flib - - os :: OS - os = let (Platform _ os') = hostPlatform lbi - in os' - - -- If a foreign lib foo has lib-version-info 5:1:2 or - -- lib-version-linux 3.2.1, it should be built as libfoo.so.3.2.1 - -- Libtool's version-info data is translated into library versions in a - -- nontrivial way: so refer to libtool documentation. - versionedExt :: String - versionedExt = - let nums = foreignLibVersion flib os - in foldl (<.>) "so" (map show nums) - --- | Name for the library when building. --- --- If the `lib-version-info` field or the `lib-version-linux` field of --- a foreign library target is set, we need to incorporate that --- version into the SONAME field. --- --- If a foreign library foo has lib-version-info 5:1:2, it should be --- built as libfoo.so.3.2.1. We want it to get soname libfoo.so.3. --- However, GHC does not allow overriding soname by setting linker --- options, as it sets a soname of its own (namely the output --- filename), after the user-supplied linker options. Hence, we have --- to compile the library with the soname as its filename. We rename --- the compiled binary afterwards. --- --- This method allows to adjust the name of the library at build time --- such that the correct soname can be set. -flibBuildName :: LocalBuildInfo -> ForeignLib -> String -flibBuildName lbi flib - -- On linux, if a foreign-library has version data, the first digit is used - -- to produce the SONAME. - | (os, foreignLibType flib) == - (Linux, ForeignLibNativeShared) - = let nums = foreignLibVersion flib os - in "lib" ++ nm <.> foldl (<.>) "so" (map show (take 1 nums)) - | otherwise = flibTargetName lbi flib - where - os :: OS - os = let (Platform _ os') = hostPlatform lbi - in os' - - nm :: String - nm = unUnqualComponentName $ foreignLibName flib - -gbuildIsRepl :: GBuildMode -> Bool -gbuildIsRepl (GBuildExe _) = False -gbuildIsRepl (GReplExe _ _) = True -gbuildIsRepl (GBuildFLib _) = False -gbuildIsRepl (GReplFLib _ _) = True - -gbuildNeedDynamic :: LocalBuildInfo -> GBuildMode -> Bool -gbuildNeedDynamic lbi bm = - case bm of - GBuildExe _ -> withDynExe lbi - GReplExe _ _ -> withDynExe lbi - GBuildFLib flib -> withDynFLib flib - GReplFLib _ flib -> withDynFLib flib - where - withDynFLib flib = - case foreignLibType flib of - ForeignLibNativeShared -> - ForeignLibStandalone `notElem` foreignLibOptions flib - ForeignLibNativeStatic -> - False - ForeignLibTypeUnknown -> - cabalBug "unknown foreign lib type" - -gbuildModDefFiles :: GBuildMode -> [FilePath] -gbuildModDefFiles (GBuildExe _) = [] -gbuildModDefFiles (GReplExe _ _) = [] -gbuildModDefFiles (GBuildFLib flib) = foreignLibModDefFile flib -gbuildModDefFiles (GReplFLib _ flib) = foreignLibModDefFile flib - --- | "Main" module name when overridden by @ghc-options: -main-is ...@ --- or 'Nothing' if no @-main-is@ flag could be found. --- --- In case of 'Nothing', 'Distribution.ModuleName.main' can be assumed. -exeMainModuleName :: Executable -> Maybe ModuleName -exeMainModuleName Executable{buildInfo = bnfo} = - -- GHC honors the last occurrence of a module name updated via -main-is - -- - -- Moreover, -main-is when parsed left-to-right can update either - -- the "Main" module name, or the "main" function name, or both, - -- see also 'decodeMainIsArg'. - msum $ reverse $ map decodeMainIsArg $ findIsMainArgs ghcopts - where - ghcopts = hcOptions GHC bnfo - - findIsMainArgs [] = [] - findIsMainArgs ("-main-is":arg:rest) = arg : findIsMainArgs rest - findIsMainArgs (_:rest) = findIsMainArgs rest - --- | Decode argument to '-main-is' --- --- Returns 'Nothing' if argument set only the function name. --- --- This code has been stolen/refactored from GHC's DynFlags.setMainIs --- function. The logic here is deliberately imperfect as it is --- intended to be bug-compatible with GHC's parser. See discussion in --- https://github.com/haskell/cabal/pull/4539#discussion_r118981753. -decodeMainIsArg :: String -> Maybe ModuleName -decodeMainIsArg arg - | headOf main_fn isLower - -- The arg looked like "Foo.Bar.baz" - = Just (ModuleName.fromString main_mod) - | headOf arg isUpper -- The arg looked like "Foo" or "Foo.Bar" - = Just (ModuleName.fromString arg) - | otherwise -- The arg looked like "baz" - = Nothing - where - headOf :: String -> (Char -> Bool) -> Bool - headOf str pred' = any pred' (safeHead str) - - (main_mod, main_fn) = splitLongestPrefix arg (== '.') - - splitLongestPrefix :: String -> (Char -> Bool) -> (String,String) - splitLongestPrefix str pred' - | null r_pre = (str, []) - | otherwise = (reverse (safeTail r_pre), reverse r_suf) - -- 'safeTail' drops the char satisfying 'pred' - where (r_suf, r_pre) = break pred' (reverse str) - --- | A collection of: --- * C input files --- * C++ input files --- * GHC input files --- * GHC input modules --- --- Used to correctly build and link sources. -data BuildSources = BuildSources { - cSourcesFiles :: [FilePath], - cxxSourceFiles :: [FilePath], - inputSourceFiles :: [FilePath], - inputSourceModules :: [ModuleName] - } - --- | Locate and return the 'BuildSources' required to build and link. -gbuildSources :: Verbosity - -> CabalSpecVersion - -> FilePath - -> GBuildMode - -> IO BuildSources -gbuildSources verbosity specVer tmpDir bm = - case bm of - GBuildExe exe -> exeSources exe - GReplExe _ exe -> exeSources exe - GBuildFLib flib -> return $ flibSources flib - GReplFLib _ flib -> return $ flibSources flib - where - exeSources :: Executable -> IO BuildSources - exeSources exe@Executable{buildInfo = bnfo, modulePath = modPath} = do - main <- findFileEx verbosity (tmpDir : hsSourceDirs bnfo) modPath - let mainModName = fromMaybe ModuleName.main $ exeMainModuleName exe - otherModNames = exeModules exe - - if isHaskell main - then - if specVer < CabalSpecV2_0 && (mainModName `elem` otherModNames) - then do - -- The cabal manual clearly states that `other-modules` is - -- intended for non-main modules. However, there's at least one - -- important package on Hackage (happy-1.19.5) which - -- violates this. We workaround this here so that we don't - -- invoke GHC with e.g. 'ghc --make Main src/Main.hs' which - -- would result in GHC complaining about duplicate Main - -- modules. - -- - -- Finally, we only enable this workaround for - -- specVersion < 2, as 'cabal-version:>=2.0' cabal files - -- have no excuse anymore to keep doing it wrong... ;-) - warn verbosity $ "Enabling workaround for Main module '" - ++ prettyShow mainModName - ++ "' listed in 'other-modules' illegally!" - - return BuildSources { - cSourcesFiles = cSources bnfo, - cxxSourceFiles = cxxSources bnfo, - inputSourceFiles = [main], - inputSourceModules = filter (/= mainModName) $ - exeModules exe - } - - else return BuildSources { - cSourcesFiles = cSources bnfo, - cxxSourceFiles = cxxSources bnfo, - inputSourceFiles = [main], - inputSourceModules = exeModules exe - } - else let (csf, cxxsf) - | isCxx main = ( cSources bnfo, main : cxxSources bnfo) - -- if main is not a Haskell source - -- and main is not a C++ source - -- then we assume that it is a C source - | otherwise = (main : cSources bnfo, cxxSources bnfo) - - in return BuildSources { - cSourcesFiles = csf, - cxxSourceFiles = cxxsf, - inputSourceFiles = [], - inputSourceModules = exeModules exe - } - - flibSources :: ForeignLib -> BuildSources - flibSources flib@ForeignLib{foreignLibBuildInfo = bnfo} = - BuildSources { - cSourcesFiles = cSources bnfo, - cxxSourceFiles = cxxSources bnfo, - inputSourceFiles = [], - inputSourceModules = foreignLibModules flib - } - - isHaskell :: FilePath -> Bool - isHaskell fp = elem (takeExtension fp) [".hs", ".lhs"] - - isCxx :: FilePath -> Bool - isCxx fp = elem (takeExtension fp) [".cpp", ".cxx", ".c++"] - --- | Generic build function. See comment for 'GBuildMode'. -gbuild :: Verbosity -> Cabal.Flag (Maybe Int) - -> PackageDescription -> LocalBuildInfo - -> GBuildMode -> ComponentLocalBuildInfo -> IO () -gbuild verbosity numJobs pkg_descr lbi bm clbi = do - (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi) - let replFlags = case bm of - GReplExe flags _ -> flags - GReplFLib flags _ -> flags - GBuildExe{} -> mempty - GBuildFLib{} -> mempty - comp = compiler lbi - platform = hostPlatform lbi - implInfo = getImplInfo comp - runGhcProg = runGHC verbosity ghcProg comp platform - - let (bnfo, threaded) = case bm of - GBuildFLib _ -> popThreadedFlag (gbuildInfo bm) - _ -> (gbuildInfo bm, False) - - -- the name that GHC really uses (e.g., with .exe on Windows for executables) - let targetName = gbuildTargetName lbi bm - let targetDir = buildDir lbi (gbuildName bm) - let tmpDir = targetDir (gbuildName bm ++ "-tmp") - createDirectoryIfMissingVerbose verbosity True targetDir - createDirectoryIfMissingVerbose verbosity True tmpDir - - -- TODO: do we need to put hs-boot files into place for mutually recursive - -- modules? FIX: what about exeName.hi-boot? - - -- Determine if program coverage should be enabled and if so, what - -- '-hpcdir' should be. - let isCoverageEnabled = exeCoverage lbi - distPref = fromFlag $ configDistPref $ configFlags lbi - hpcdir way - | gbuildIsRepl bm = mempty -- HPC is not supported in ghci - | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way (gbuildName bm) - | otherwise = mempty - - rpaths <- getRPaths lbi clbi - buildSources <- gbuildSources verbosity (specVersion pkg_descr) tmpDir bm - - let cSrcs = cSourcesFiles buildSources - cxxSrcs = cxxSourceFiles buildSources - inputFiles = inputSourceFiles buildSources - inputModules = inputSourceModules buildSources - isGhcDynamic = isDynamic comp - dynamicTooSupported = supportsDynamicToo comp - cObjs = map (`replaceExtension` objExtension) cSrcs - cxxObjs = map (`replaceExtension` objExtension) cxxSrcs - needDynamic = gbuildNeedDynamic lbi bm - needProfiling = withProfExe lbi - - -- build executables - baseOpts = (componentGhcOptions verbosity lbi bnfo clbi tmpDir) - `mappend` mempty { - ghcOptMode = toFlag GhcModeMake, - ghcOptInputFiles = toNubListR inputFiles, - ghcOptInputModules = toNubListR inputModules - } - staticOpts = baseOpts `mappend` mempty { - ghcOptDynLinkMode = toFlag GhcStaticOnly, - ghcOptHPCDir = hpcdir Hpc.Vanilla - } - profOpts = baseOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True, - ghcOptProfilingAuto = Internal.profDetailLevelFlag False - (withProfExeDetail lbi), - ghcOptHiSuffix = toFlag "p_hi", - ghcOptObjSuffix = toFlag "p_o", - ghcOptExtra = hcProfOptions GHC bnfo, - ghcOptHPCDir = hpcdir Hpc.Prof - } - dynOpts = baseOpts `mappend` mempty { - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - -- TODO: Does it hurt to set -fPIC for executables? - ghcOptFPic = toFlag True, - ghcOptHiSuffix = toFlag "dyn_hi", - ghcOptObjSuffix = toFlag "dyn_o", - ghcOptExtra = hcSharedOptions GHC bnfo, - ghcOptHPCDir = hpcdir Hpc.Dyn - } - dynTooOpts = staticOpts `mappend` mempty { - ghcOptDynLinkMode = toFlag GhcStaticAndDynamic, - ghcOptDynHiSuffix = toFlag "dyn_hi", - ghcOptDynObjSuffix = toFlag "dyn_o", - ghcOptHPCDir = hpcdir Hpc.Dyn - } - linkerOpts = mempty { - ghcOptLinkOptions = PD.ldOptions bnfo - ++ [ "-static" - | withFullyStaticExe lbi ] - -- Pass extra `ld-options` given - -- through to GHC's linker. - ++ maybe [] programOverrideArgs - (lookupProgram ldProgram (withPrograms lbi)), - ghcOptLinkLibs = extraLibs bnfo, - ghcOptLinkLibPath = toNubListR $ extraLibDirs bnfo, - ghcOptLinkFrameworks = toNubListR $ - PD.frameworks bnfo, - ghcOptLinkFrameworkDirs = toNubListR $ - PD.extraFrameworkDirs bnfo, - ghcOptInputFiles = toNubListR - [tmpDir x | x <- cObjs ++ cxxObjs] - } - dynLinkerOpts = mempty { - ghcOptRPaths = rpaths - } - replOpts = baseOpts { - ghcOptExtra = Internal.filterGhciFlags - (ghcOptExtra baseOpts) - <> replFlags - } - -- For a normal compile we do separate invocations of ghc for - -- compiling as for linking. But for repl we have to do just - -- the one invocation, so that one has to include all the - -- linker stuff too, like -l flags and any .o files from C - -- files etc. - `mappend` linkerOpts - `mappend` mempty { - ghcOptMode = toFlag GhcModeInteractive, - ghcOptOptimisation = toFlag GhcNoOptimisation - } - commonOpts | needProfiling = profOpts - | needDynamic = dynOpts - | otherwise = staticOpts - compileOpts | useDynToo = dynTooOpts - | otherwise = commonOpts - withStaticExe = not needProfiling && not needDynamic - - -- For building exe's that use TH with -prof or -dynamic we actually have - -- to build twice, once without -prof/-dynamic and then again with - -- -prof/-dynamic. This is because the code that TH needs to run at - -- compile time needs to be the vanilla ABI so it can be loaded up and run - -- by the compiler. - -- With dynamic-by-default GHC the TH object files loaded at compile-time - -- need to be .dyn_o instead of .o. - doingTH = usesTemplateHaskellOrQQ bnfo - -- Should we use -dynamic-too instead of compiling twice? - useDynToo = dynamicTooSupported && isGhcDynamic - && doingTH && withStaticExe - && null (hcSharedOptions GHC bnfo) - compileTHOpts | isGhcDynamic = dynOpts - | otherwise = staticOpts - compileForTH - | gbuildIsRepl bm = False - | useDynToo = False - | isGhcDynamic = doingTH && (needProfiling || withStaticExe) - | otherwise = doingTH && (needProfiling || needDynamic) - - -- Build static/dynamic object files for TH, if needed. - when compileForTH $ - runGhcProg compileTHOpts { ghcOptNoLink = toFlag True - , ghcOptNumJobs = numJobs } - - -- Do not try to build anything if there are no input files. - -- This can happen if the cabal file ends up with only cSrcs - -- but no Haskell modules. - unless ((null inputFiles && null inputModules) - || gbuildIsRepl bm) $ - runGhcProg compileOpts { ghcOptNoLink = toFlag True - , ghcOptNumJobs = numJobs } - - -- build any C++ sources - unless (null cxxSrcs) $ do - info verbosity "Building C++ Sources..." - sequence_ - [ do let baseCxxOpts = Internal.componentCxxGhcOptions verbosity implInfo - lbi bnfo clbi tmpDir filename - vanillaCxxOpts = if isGhcDynamic - -- Dynamic GHC requires C++ sources to be built - -- with -fPIC for REPL to work. See #2207. - then baseCxxOpts { ghcOptFPic = toFlag True } - else baseCxxOpts - profCxxOpts = vanillaCxxOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True - } - sharedCxxOpts = vanillaCxxOpts `mappend` mempty { - ghcOptFPic = toFlag True, - ghcOptDynLinkMode = toFlag GhcDynamicOnly - } - opts | needProfiling = profCxxOpts - | needDynamic = sharedCxxOpts - | otherwise = vanillaCxxOpts - -- TODO: Placing all Haskell, C, & C++ objects in a single directory - -- Has the potential for file collisions. In general we would - -- consider this a user error. However, we should strive to - -- add a warning if this occurs. - odir = fromFlag (ghcOptObjDir opts) - createDirectoryIfMissingVerbose verbosity True odir - needsRecomp <- checkNeedsRecompilation filename opts - when needsRecomp $ - runGhcProg opts - | filename <- cxxSrcs ] - - -- build any C sources - unless (null cSrcs) $ do - info verbosity "Building C Sources..." - sequence_ - [ do let baseCcOpts = Internal.componentCcGhcOptions verbosity implInfo - lbi bnfo clbi tmpDir filename - vanillaCcOpts = if isGhcDynamic - -- Dynamic GHC requires C sources to be built - -- with -fPIC for REPL to work. See #2207. - then baseCcOpts { ghcOptFPic = toFlag True } - else baseCcOpts - profCcOpts = vanillaCcOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True - } - sharedCcOpts = vanillaCcOpts `mappend` mempty { - ghcOptFPic = toFlag True, - ghcOptDynLinkMode = toFlag GhcDynamicOnly - } - opts | needProfiling = profCcOpts - | needDynamic = sharedCcOpts - | otherwise = vanillaCcOpts - odir = fromFlag (ghcOptObjDir opts) - createDirectoryIfMissingVerbose verbosity True odir - needsRecomp <- checkNeedsRecompilation filename opts - when needsRecomp $ - runGhcProg opts - | filename <- cSrcs ] - - -- TODO: problem here is we need the .c files built first, so we can load them - -- with ghci, but .c files can depend on .h files generated by ghc by ffi - -- exports. - case bm of - GReplExe _ _ -> runGhcProg replOpts - GReplFLib _ _ -> runGhcProg replOpts - GBuildExe _ -> do - let linkOpts = commonOpts - `mappend` linkerOpts - `mappend` mempty { - ghcOptLinkNoHsMain = toFlag (null inputFiles) - } - `mappend` (if withDynExe lbi then dynLinkerOpts else mempty) - - info verbosity "Linking..." - -- Work around old GHCs not relinking in this - -- situation, see #3294 - let target = targetDir targetName - when (compilerVersion comp < mkVersion [7,7]) $ do - e <- doesFileExist target - when e (removeFile target) - runGhcProg linkOpts { ghcOptOutputFile = toFlag target } - GBuildFLib flib -> do - let rtsInfo = extractRtsInfo lbi - rtsOptLinkLibs = [ - if needDynamic - then if threaded - then dynRtsThreadedLib (rtsDynamicInfo rtsInfo) - else dynRtsVanillaLib (rtsDynamicInfo rtsInfo) - else if threaded - then statRtsThreadedLib (rtsStaticInfo rtsInfo) - else statRtsVanillaLib (rtsStaticInfo rtsInfo) - ] - linkOpts = case foreignLibType flib of - ForeignLibNativeShared -> - commonOpts - `mappend` linkerOpts - `mappend` dynLinkerOpts - `mappend` mempty { - ghcOptLinkNoHsMain = toFlag True, - ghcOptShared = toFlag True, - ghcOptLinkLibs = rtsOptLinkLibs, - ghcOptLinkLibPath = toNubListR $ rtsLibPaths rtsInfo, - ghcOptFPic = toFlag True, - ghcOptLinkModDefFiles = toNubListR $ gbuildModDefFiles bm - } - -- See Note [RPATH] - `mappend` ifNeedsRPathWorkaround lbi mempty { - ghcOptLinkOptions = ["-Wl,--no-as-needed"] - , ghcOptLinkLibs = ["ffi"] - } - ForeignLibNativeStatic -> - -- this should be caught by buildFLib - -- (and if we do implement this, we probably don't even want to call - -- ghc here, but rather Ar.createArLibArchive or something) - cabalBug "static libraries not yet implemented" - ForeignLibTypeUnknown -> - cabalBug "unknown foreign lib type" - -- We build under a (potentially) different filename to set a - -- soname on supported platforms. See also the note for - -- @flibBuildName@. - info verbosity "Linking..." - let buildName = flibBuildName lbi flib - runGhcProg linkOpts { ghcOptOutputFile = toFlag (targetDir buildName) } - renameFile (targetDir buildName) (targetDir targetName) - -{- -Note [RPATH] -~~~~~~~~~~~~ - -Suppose that the dynamic library depends on `base`, but not (directly) on -`integer-gmp` (which, however, is a dependency of `base`). We will link the -library as - - gcc ... -lHSbase-4.7.0.2-ghc7.8.4 -lHSinteger-gmp-0.5.1.0-ghc7.8.4 ... - -However, on systems (like Ubuntu) where the linker gets called with `-as-needed` -by default, the linker will notice that `integer-gmp` isn't actually a direct -dependency and hence omit the link. - -Then when we attempt to link a C program against this dynamic library, the -_static_ linker will attempt to verify that all symbols can be resolved. The -dynamic library itself does not require any symbols from `integer-gmp`, but -`base` does. In order to verify that the symbols used by `base` can be -resolved, the static linker needs to be able to _find_ integer-gmp. - -Finding the `base` dependency is simple, because the dynamic elf header -(`readelf -d`) for the library that we have created looks something like - - (NEEDED) Shared library: [libHSbase-4.7.0.2-ghc7.8.4.so] - (RPATH) Library rpath: [/path/to/base-4.7.0.2:...] - -However, when it comes to resolving the dependency on `integer-gmp`, it needs -to look at the dynamic header for `base`. On modern ghc (7.8 and higher) this -looks something like - - (NEEDED) Shared library: [libHSinteger-gmp-0.5.1.0-ghc7.8.4.so] - (RPATH) Library rpath: [$ORIGIN/../integer-gmp-0.5.1.0:...] - -This specifies the location of `integer-gmp` _in terms of_ the location of base -(using the `$ORIGIN`) variable. But here's the crux: when the static linker -attempts to verify that all symbols can be resolved, [**IT DOES NOT RESOLVE -`$ORIGIN`**](http://stackoverflow.com/questions/6323603/ld-using-rpath-origin-inside-a-shared-library-recursive). -As a consequence, it will not be able to resolve the symbols and report the -missing symbols as errors, _even though the dynamic linker **would** be able to -resolve these symbols_. We can tell the static linker not to report these -errors by using `--unresolved-symbols=ignore-all` and all will be fine when we -run the program ([(indeed, this is what the gold linker -does)](https://sourceware.org/ml/binutils/2013-05/msg00038.html), but it makes -the resulting library more difficult to use. - -Instead what we can do is make sure that the generated dynamic library has -explicit top-level dependencies on these libraries. This means that the static -linker knows where to find them, and when we have transitive dependencies on -the same libraries the linker will only load them once, so we avoid needing to -look at the `RPATH` of our dependencies. We can do this by passing -`--no-as-needed` to the linker, so that it doesn't omit any libraries. - -Note that on older ghc (7.6 and before) the Haskell libraries don't have an -RPATH set at all, which makes it even more important that we make these -top-level dependencies. - -Finally, we have to explicitly link against `libffi` for the same reason. For -newer ghc this _happens_ to be unnecessary on many systems because `libffi` is -a library which is not specific to GHC, and when the static linker verifies -that all symbols can be resolved it will find the `libffi` that is globally -installed (completely independent from ghc). Of course, this may well be the -_wrong_ version of `libffi`, but it's quite possible that symbol resolution -happens to work. This is of course the wrong approach, which is why we link -explicitly against `libffi` so that we will find the _right_ version of -`libffi`. --} - --- | Do we need the RPATH workaround? --- --- See Note [RPATH]. -ifNeedsRPathWorkaround :: Monoid a => LocalBuildInfo -> a -> a -ifNeedsRPathWorkaround lbi a = - case hostPlatform lbi of - Platform _ Linux -> a - _otherwise -> mempty - -data DynamicRtsInfo = DynamicRtsInfo { - dynRtsVanillaLib :: FilePath - , dynRtsThreadedLib :: FilePath - , dynRtsDebugLib :: FilePath - , dynRtsEventlogLib :: FilePath - , dynRtsThreadedDebugLib :: FilePath - , dynRtsThreadedEventlogLib :: FilePath - } - -data StaticRtsInfo = StaticRtsInfo { - statRtsVanillaLib :: FilePath - , statRtsThreadedLib :: FilePath - , statRtsDebugLib :: FilePath - , statRtsEventlogLib :: FilePath - , statRtsThreadedDebugLib :: FilePath - , statRtsThreadedEventlogLib :: FilePath - , statRtsProfilingLib :: FilePath - , statRtsThreadedProfilingLib :: FilePath - } - -data RtsInfo = RtsInfo { - rtsDynamicInfo :: DynamicRtsInfo - , rtsStaticInfo :: StaticRtsInfo - , rtsLibPaths :: [FilePath] - } - --- | Extract (and compute) information about the RTS library --- --- TODO: This hardcodes the name as @HSrts-ghc@. I don't know if we can --- find this information somewhere. We can lookup the 'hsLibraries' field of --- 'InstalledPackageInfo' but it will tell us @["HSrts", "Cffi"]@, which --- doesn't really help. -extractRtsInfo :: LocalBuildInfo -> RtsInfo -extractRtsInfo lbi = - case PackageIndex.lookupPackageName - (installedPkgs lbi) (mkPackageName "rts") of - [(_, [rts])] -> aux rts - _otherwise -> error "No (or multiple) ghc rts package is registered" - where - aux :: InstalledPackageInfo -> RtsInfo - aux rts = RtsInfo { - rtsDynamicInfo = DynamicRtsInfo { - dynRtsVanillaLib = withGhcVersion "HSrts" - , dynRtsThreadedLib = withGhcVersion "HSrts_thr" - , dynRtsDebugLib = withGhcVersion "HSrts_debug" - , dynRtsEventlogLib = withGhcVersion "HSrts_l" - , dynRtsThreadedDebugLib = withGhcVersion "HSrts_thr_debug" - , dynRtsThreadedEventlogLib = withGhcVersion "HSrts_thr_l" - } - , rtsStaticInfo = StaticRtsInfo { - statRtsVanillaLib = "HSrts" - , statRtsThreadedLib = "HSrts_thr" - , statRtsDebugLib = "HSrts_debug" - , statRtsEventlogLib = "HSrts_l" - , statRtsThreadedDebugLib = "HSrts_thr_debug" - , statRtsThreadedEventlogLib = "HSrts_thr_l" - , statRtsProfilingLib = "HSrts_p" - , statRtsThreadedProfilingLib = "HSrts_thr_p" - } - , rtsLibPaths = InstalledPackageInfo.libraryDirs rts - } - withGhcVersion = (++ ("-ghc" ++ prettyShow (compilerVersion (compiler lbi)))) - --- | Returns True if the modification date of the given source file is newer than --- the object file we last compiled for it, or if no object file exists yet. -checkNeedsRecompilation :: FilePath -> GhcOptions -> IO Bool -checkNeedsRecompilation filename opts = filename `moreRecentFile` oname - where oname = getObjectFileName filename opts - --- | Finds the object file name of the given source file -getObjectFileName :: FilePath -> GhcOptions -> FilePath -getObjectFileName filename opts = oname - where odir = fromFlag (ghcOptObjDir opts) - oext = fromFlagOrDefault "o" (ghcOptObjSuffix opts) - oname = odir replaceExtension filename oext - --- | Calculate the RPATHs for the component we are building. --- --- Calculates relative RPATHs when 'relocatable' is set. -getRPaths :: LocalBuildInfo - -> ComponentLocalBuildInfo -- ^ Component we are building - -> IO (NubListR FilePath) -getRPaths lbi clbi | supportRPaths hostOS = do - libraryPaths <- depLibraryPaths False (relocatable lbi) lbi clbi - let hostPref = case hostOS of - OSX -> "@loader_path" - _ -> "$ORIGIN" - relPath p = if isRelative p then hostPref p else p - rpaths = toNubListR (map relPath libraryPaths) - return rpaths - where - (Platform _ hostOS) = hostPlatform lbi - compid = compilerId . compiler $ lbi - - -- The list of RPath-supported operating systems below reflects the - -- platforms on which Cabal's RPATH handling is tested. It does _NOT_ - -- reflect whether the OS supports RPATH. - - -- E.g. when this comment was written, the *BSD operating systems were - -- untested with regards to Cabal RPATH handling, and were hence set to - -- 'False', while those operating systems themselves do support RPATH. - supportRPaths Linux   = True - supportRPaths Windows = False - supportRPaths OSX   = True - supportRPaths FreeBSD   = - case compid of - CompilerId GHC ver | ver >= mkVersion [7,10,2] -> True - _ -> False - supportRPaths OpenBSD   = False - supportRPaths NetBSD   = False - supportRPaths DragonFly = False - supportRPaths Solaris = False - supportRPaths AIX = False - supportRPaths HPUX = False - supportRPaths IRIX = False - supportRPaths HaLVM = False - supportRPaths IOS = False - supportRPaths Android = False - supportRPaths Ghcjs = False - supportRPaths Hurd = False - supportRPaths (OtherOS _) = False - -- Do _not_ add a default case so that we get a warning here when a new OS - -- is added. - -getRPaths _ _ = return mempty - --- | Remove the "-threaded" flag when building a foreign library, as it has no --- effect when used with "-shared". Returns the updated 'BuildInfo', along --- with whether or not the flag was present, so we can use it to link against --- the appropriate RTS on our own. -popThreadedFlag :: BuildInfo -> (BuildInfo, Bool) -popThreadedFlag bi = - ( bi { options = filterHcOptions (/= "-threaded") (options bi) } - , hasThreaded (options bi)) - - where - filterHcOptions :: (String -> Bool) - -> PerCompilerFlavor [String] - -> PerCompilerFlavor [String] - filterHcOptions p (PerCompilerFlavor ghc ghcjs) = - PerCompilerFlavor (filter p ghc) ghcjs - - hasThreaded :: PerCompilerFlavor [String] -> Bool - hasThreaded (PerCompilerFlavor ghc _) = elem "-threaded" ghc - --- | Extracts a String representing a hash of the ABI of a built --- library. It can fail if the library has not yet been built. --- -libAbiHash :: Verbosity -> PackageDescription -> LocalBuildInfo - -> Library -> ComponentLocalBuildInfo -> IO String -libAbiHash verbosity _pkg_descr lbi lib clbi = do - let - libBi = libBuildInfo lib - comp = compiler lbi - platform = hostPlatform lbi - vanillaArgs0 = - (componentGhcOptions verbosity lbi libBi clbi (componentBuildDir lbi clbi)) - `mappend` mempty { - ghcOptMode = toFlag GhcModeAbiHash, - ghcOptInputModules = toNubListR $ exposedModules lib - } - vanillaArgs = - -- Package DBs unnecessary, and break ghc-cabal. See #3633 - -- BUT, put at least the global database so that 7.4 doesn't - -- break. - vanillaArgs0 { ghcOptPackageDBs = [GlobalPackageDB] - , ghcOptPackages = mempty } - sharedArgs = vanillaArgs `mappend` mempty { - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptFPic = toFlag True, - ghcOptHiSuffix = toFlag "dyn_hi", - ghcOptObjSuffix = toFlag "dyn_o", - ghcOptExtra = hcSharedOptions GHC libBi - } - profArgs = vanillaArgs `mappend` mempty { - ghcOptProfilingMode = toFlag True, - ghcOptProfilingAuto = Internal.profDetailLevelFlag True - (withProfLibDetail lbi), - ghcOptHiSuffix = toFlag "p_hi", - ghcOptObjSuffix = toFlag "p_o", - ghcOptExtra = hcProfOptions GHC libBi - } - ghcArgs - | withVanillaLib lbi = vanillaArgs - | withSharedLib lbi = sharedArgs - | withProfLib lbi = profArgs - | otherwise = error "libAbiHash: Can't find an enabled library way" - - (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi) - hash <- getProgramInvocationOutput verbosity - (ghcInvocation ghcProg comp platform ghcArgs) - return (takeWhile (not . isSpace) hash) - -componentGhcOptions :: Verbosity -> LocalBuildInfo - -> BuildInfo -> ComponentLocalBuildInfo -> FilePath - -> GhcOptions -componentGhcOptions verbosity lbi = - Internal.componentGhcOptions verbosity implInfo lbi - where - comp = compiler lbi - implInfo = getImplInfo comp - -componentCcGhcOptions :: Verbosity -> LocalBuildInfo - -> BuildInfo -> ComponentLocalBuildInfo - -> FilePath -> FilePath - -> GhcOptions -componentCcGhcOptions verbosity lbi = - Internal.componentCcGhcOptions verbosity implInfo lbi - where - comp = compiler lbi - implInfo = getImplInfo comp - --- ----------------------------------------------------------------------------- --- Installing - --- |Install executables for GHC. -installExe :: Verbosity - -> LocalBuildInfo - -> FilePath -- ^Where to copy the files to - -> FilePath -- ^Build location - -> (FilePath, FilePath) -- ^Executable (prefix,suffix) - -> PackageDescription - -> Executable - -> IO () -installExe verbosity lbi binDir buildPref - (progprefix, progsuffix) _pkg exe = do - createDirectoryIfMissingVerbose verbosity True binDir - let exeName' = unUnqualComponentName $ exeName exe - exeFileName = exeTargetName (hostPlatform lbi) exe - fixedExeBaseName = progprefix ++ exeName' ++ progsuffix - installBinary dest = do - installExecutableFile verbosity - (buildPref exeName' exeFileName) - (dest <.> exeExtension (hostPlatform lbi)) - when (stripExes lbi) $ - Strip.stripExe verbosity (hostPlatform lbi) (withPrograms lbi) - (dest <.> exeExtension (hostPlatform lbi)) - installBinary (binDir fixedExeBaseName) - --- |Install foreign library for GHC. -installFLib :: Verbosity - -> LocalBuildInfo - -> FilePath -- ^install location - -> FilePath -- ^Build location - -> PackageDescription - -> ForeignLib - -> IO () -installFLib verbosity lbi targetDir builtDir _pkg flib = - install (foreignLibIsShared flib) - builtDir - targetDir - (flibTargetName lbi flib) - where - install isShared srcDir dstDir name = do - let src = srcDir name - dst = dstDir name - createDirectoryIfMissingVerbose verbosity True targetDir - -- TODO: Should we strip? (stripLibs lbi) - if isShared - then installExecutableFile verbosity src dst - else installOrdinaryFile verbosity src dst - -- Now install appropriate symlinks if library is versioned - let (Platform _ os) = hostPlatform lbi - when (not (null (foreignLibVersion flib os))) $ do - when (os /= Linux) $ die' verbosity - -- It should be impossible to get here. - "Can't install foreign-library symlink on non-Linux OS" -#ifndef mingw32_HOST_OS - -- 'createSymbolicLink file1 file2' creates a symbolic link - -- named 'file2' which points to the file 'file1'. - -- Note that we do want a symlink to 'name' rather than - -- 'dst', because the symlink will be relative to the - -- directory it's created in. - -- Finally, we first create the symlinks in a temporary - -- directory and then rename to simulate 'ln --force'. - withTempDirectory verbosity dstDir nm $ \tmpDir -> do - let link1 = flibBuildName lbi flib - link2 = "lib" ++ nm <.> "so" - createSymbolicLink name (tmpDir link1) - renameFile (tmpDir link1) (dstDir link1) - createSymbolicLink name (tmpDir link2) - renameFile (tmpDir link2) (dstDir link2) - where - nm :: String - nm = unUnqualComponentName $ foreignLibName flib -#endif /* mingw32_HOST_OS */ - - --- |Install for ghc, .hi, .a and, if --with-ghci given, .o -installLib :: Verbosity - -> LocalBuildInfo - -> FilePath -- ^install location - -> FilePath -- ^install location for dynamic libraries - -> FilePath -- ^Build location - -> PackageDescription - -> Library - -> ComponentLocalBuildInfo - -> IO () -installLib verbosity lbi targetDir dynlibTargetDir _builtDir pkg lib clbi = do - -- copy .hi files over: - whenVanilla $ copyModuleFiles "hi" - whenProf $ copyModuleFiles "p_hi" - whenShared $ copyModuleFiles "dyn_hi" - - -- copy the built library files over: - whenHasCode $ do - whenVanilla $ do - sequence_ [ installOrdinary - builtDir - targetDir - (mkGenericStaticLibName (l ++ f)) - | l <- getHSLibraryName - (componentUnitId clbi):(extraBundledLibs (libBuildInfo lib)) - , f <- "":extraLibFlavours (libBuildInfo lib) - ] - whenGHCi $ installOrdinary builtDir targetDir ghciLibName - whenProf $ do - installOrdinary builtDir targetDir profileLibName - whenGHCi $ installOrdinary builtDir targetDir ghciProfLibName - whenShared $ if - -- The behavior for "extra-bundled-libraries" changed in version 2.5.0. - -- See ghc issue #15837 and Cabal PR #5855. - | specVersion pkg < CabalSpecV3_0 -> do - sequence_ [ installShared builtDir dynlibTargetDir - (mkGenericSharedLibName platform compiler_id (l ++ f)) - | l <- getHSLibraryName uid : extraBundledLibs (libBuildInfo lib) - , f <- "":extraDynLibFlavours (libBuildInfo lib) - ] - | otherwise -> do - sequence_ [ installShared - builtDir - dynlibTargetDir - (mkGenericSharedLibName - platform - compiler_id - (getHSLibraryName uid ++ f)) - | f <- "":extraDynLibFlavours (libBuildInfo lib) - ] - sequence_ [ do - files <- getDirectoryContents builtDir - let l' = mkGenericSharedBundledLibName - platform - compiler_id - l - forM_ files $ \ file -> - when (l' `isPrefixOf` file) $ do - isFile <- doesFileExist (builtDir file) - when isFile $ do - installShared - builtDir - dynlibTargetDir - file - | l <- extraBundledLibs (libBuildInfo lib) - ] - - where - builtDir = componentBuildDir lbi clbi - - install isShared srcDir dstDir name = do - let src = srcDir name - dst = dstDir name - - createDirectoryIfMissingVerbose verbosity True dstDir - - if isShared - then installExecutableFile verbosity src dst - else installOrdinaryFile verbosity src dst - - when (stripLibs lbi) $ Strip.stripLib verbosity - platform (withPrograms lbi) dst - - installOrdinary = install False - installShared = install True - - copyModuleFiles ext = - findModuleFilesEx verbosity [builtDir] [ext] (allLibModules lib clbi) - >>= installOrdinaryFiles verbosity targetDir - - compiler_id = compilerId (compiler lbi) - platform = hostPlatform lbi - uid = componentUnitId clbi - profileLibName = mkProfLibName uid - ghciLibName = Internal.mkGHCiLibName uid - ghciProfLibName = Internal.mkGHCiProfLibName uid - - hasLib = not $ null (allLibModules lib clbi) - && null (cSources (libBuildInfo lib)) - && null (cxxSources (libBuildInfo lib)) - && null (cmmSources (libBuildInfo lib)) - && null (asmSources (libBuildInfo lib)) - has_code = not (componentIsIndefinite clbi) - whenHasCode = when has_code - whenVanilla = when (hasLib && withVanillaLib lbi) - whenProf = when (hasLib && withProfLib lbi && has_code) - whenGHCi = when (hasLib && withGHCiLib lbi && has_code) - whenShared = when (hasLib && withSharedLib lbi && has_code) - --- ----------------------------------------------------------------------------- --- Registering - -hcPkgInfo :: ProgramDb -> HcPkg.HcPkgInfo -hcPkgInfo progdb = HcPkg.HcPkgInfo - { HcPkg.hcPkgProgram = ghcPkgProg - , HcPkg.noPkgDbStack = v < [6,9] - , HcPkg.noVerboseFlag = v < [6,11] - , HcPkg.flagPackageConf = v < [7,5] - , HcPkg.supportsDirDbs = v >= [6,8] - , HcPkg.requiresDirDbs = v >= [7,10] - , HcPkg.nativeMultiInstance = v >= [7,10] - , HcPkg.recacheMultiInstance = v >= [6,12] - , HcPkg.suppressFilesCheck = v >= [6,6] - } - where - v = versionNumbers ver - ghcPkgProg = fromMaybe (error "GHC.hcPkgInfo: no ghc program") $ lookupProgram ghcPkgProgram progdb - ver = fromMaybe (error "GHC.hcPkgInfo: no ghc version") $ programVersion ghcPkgProg - -registerPackage - :: Verbosity - -> ProgramDb - -> PackageDBStack - -> InstalledPackageInfo - -> HcPkg.RegisterOptions - -> IO () -registerPackage verbosity progdb packageDbs installedPkgInfo registerOptions = - HcPkg.register (hcPkgInfo progdb) verbosity packageDbs - installedPkgInfo registerOptions - -pkgRoot :: Verbosity -> LocalBuildInfo -> PackageDB -> IO FilePath -pkgRoot verbosity lbi = pkgRoot' - where - pkgRoot' GlobalPackageDB = - let ghcProg = fromMaybe (error "GHC.pkgRoot: no ghc program") $ lookupProgram ghcProgram (withPrograms lbi) - in fmap takeDirectory (getGlobalPackageDB verbosity ghcProg) - pkgRoot' UserPackageDB = do - appDir <- getGhcAppDir - let ver = compilerVersion (compiler lbi) - subdir = System.Info.arch ++ '-':System.Info.os - ++ '-':prettyShow ver - rootDir = appDir subdir - -- We must create the root directory for the user package database if it - -- does not yet exists. Otherwise '${pkgroot}' will resolve to a - -- directory at the time of 'ghc-pkg register', and registration will - -- fail. - createDirectoryIfMissing True rootDir - return rootDir - pkgRoot' (SpecificPackageDB fp) = return (takeDirectory fp) - --- ----------------------------------------------------------------------------- --- Utils - -isDynamic :: Compiler -> Bool -isDynamic = Internal.ghcLookupProperty "GHC Dynamic" - -supportsDynamicToo :: Compiler -> Bool -supportsDynamicToo = Internal.ghcLookupProperty "Support dynamic-too" - -withExt :: FilePath -> String -> FilePath -withExt fp ext = fp <.> if takeExtension fp /= ('.':ext) then ext else "" diff --git a/cabal/Cabal/Distribution/Simple/GHC/EnvironmentParser.hs b/cabal/Cabal/Distribution/Simple/GHC/EnvironmentParser.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/GHC/EnvironmentParser.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -module Distribution.Simple.GHC.EnvironmentParser - ( parseGhcEnvironmentFile, readGhcEnvironmentFile, ParseErrorExc(..) ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Simple.Compiler - ( PackageDB(..) ) -import Distribution.Simple.GHC.Internal - ( GhcEnvironmentFileEntry(..) ) -import Distribution.Types.UnitId - ( mkUnitId ) - -import qualified Text.Parsec as P -import Text.Parsec.String - ( Parser, parseFromFile ) - -parseEnvironmentFileLine :: Parser GhcEnvironmentFileEntry -parseEnvironmentFileLine = GhcEnvFileComment <$> comment - <|> GhcEnvFilePackageId <$> unitId - <|> GhcEnvFilePackageDb <$> packageDb - <|> pure GhcEnvFileClearPackageDbStack <* clearDb - where - comment = P.string "--" *> P.many (P.noneOf "\r\n") - unitId = P.try $ P.string "package-id" *> P.spaces *> - (mkUnitId <$> P.many1 (P.satisfy $ \c -> isAlphaNum c || c `elem` "-_.+")) - packageDb = (P.string "global-package-db" *> pure GlobalPackageDB) - <|> (P.string "user-package-db" *> pure UserPackageDB) - <|> (P.string "package-db" *> P.spaces *> (SpecificPackageDB <$> P.many1 (P.noneOf "\r\n") <* P.lookAhead P.endOfLine)) - clearDb = P.string "clear-package-db" - -newtype ParseErrorExc = ParseErrorExc P.ParseError - deriving (Show, Typeable) - -instance Exception ParseErrorExc - -parseGhcEnvironmentFile :: Parser [GhcEnvironmentFileEntry] -parseGhcEnvironmentFile = parseEnvironmentFileLine `P.sepEndBy` P.endOfLine <* P.eof - -readGhcEnvironmentFile :: FilePath -> IO [GhcEnvironmentFileEntry] -readGhcEnvironmentFile path = - either (throwIO . ParseErrorExc) return =<< - parseFromFile parseGhcEnvironmentFile path diff --git a/cabal/Cabal/Distribution/Simple/GHC/ImplInfo.hs b/cabal/Cabal/Distribution/Simple/GHC/ImplInfo.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/GHC/ImplInfo.hs +++ /dev/null @@ -1,93 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.GHC.ImplInfo --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This module contains the data structure describing invocation --- details for a GHC or GHC-derived compiler, such as supported flags --- and workarounds for bugs. - -module Distribution.Simple.GHC.ImplInfo ( - GhcImplInfo(..), getImplInfo, - ghcVersionImplInfo, ghcjsVersionImplInfo - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Simple.Compiler -import Distribution.Version - -{- | - Information about features and quirks of a GHC-based implementation. - - Compiler flavors based on GHC behave similarly enough that some of - the support code for them is shared. Every implementation has its - own peculiarities, that may or may not be a direct result of the - underlying GHC version. This record keeps track of these differences. - - All shared code (i.e. everything not in the Distribution.Simple.FLAVOR - module) should use implementation info rather than version numbers - to test for supported features. --} - -data GhcImplInfo = GhcImplInfo - { supportsHaskell2010 :: Bool -- ^ -XHaskell2010 and -XHaskell98 flags - , reportsNoExt :: Bool -- ^ --supported-languages gives Ext and NoExt - , alwaysNondecIndent :: Bool -- ^ NondecreasingIndentation is always on - , flagGhciScript :: Bool -- ^ -ghci-script flag supported - , flagProfAuto :: Bool -- ^ new style -fprof-auto* flags - , flagPackageConf :: Bool -- ^ use package-conf instead of package-db - , flagDebugInfo :: Bool -- ^ -g flag supported - , supportsDebugLevels :: Bool -- ^ supports numeric @-g@ levels - , supportsPkgEnvFiles :: Bool -- ^ picks up @.ghc.environment@ files - , flagWarnMissingHomeModules :: Bool -- ^ -Wmissing-home-modules is supported - } - -getImplInfo :: Compiler -> GhcImplInfo -getImplInfo comp = - case compilerFlavor comp of - GHC -> ghcVersionImplInfo (compilerVersion comp) - GHCJS -> case compilerCompatVersion GHC comp of - Just ghcVer -> ghcjsVersionImplInfo (compilerVersion comp) ghcVer - _ -> error ("Distribution.Simple.GHC.Props.getImplProps: " ++ - "could not find GHC version for GHCJS compiler") - x -> error ("Distribution.Simple.GHC.Props.getImplProps only works" ++ - "for GHC-like compilers (GHC, GHCJS)" ++ - ", but found " ++ show x) - -ghcVersionImplInfo :: Version -> GhcImplInfo -ghcVersionImplInfo ver = GhcImplInfo - { supportsHaskell2010 = v >= [7] - , reportsNoExt = v >= [7] - , alwaysNondecIndent = v < [7,1] - , flagGhciScript = v >= [7,2] - , flagProfAuto = v >= [7,4] - , flagPackageConf = v < [7,5] - , flagDebugInfo = v >= [7,10] - , supportsDebugLevels = v >= [8,0] - , supportsPkgEnvFiles = v >= [8,0,1,20160901] -- broken in 8.0.1, fixed in 8.0.2 - , flagWarnMissingHomeModules = v >= [8,2] - } - where - v = versionNumbers ver - -ghcjsVersionImplInfo :: Version -- ^ The GHCJS version - -> Version -- ^ The GHC version - -> GhcImplInfo -ghcjsVersionImplInfo _ghcjsver ghcver = GhcImplInfo - { supportsHaskell2010 = True - , reportsNoExt = True - , alwaysNondecIndent = False - , flagGhciScript = True - , flagProfAuto = True - , flagPackageConf = False - , flagDebugInfo = False - , supportsDebugLevels = ghcv >= [8,0] - , supportsPkgEnvFiles = ghcv >= [8,0,2] --TODO: check this works in ghcjs - , flagWarnMissingHomeModules = ghcv >= [8,2] - } - where - ghcv = versionNumbers ghcver diff --git a/cabal/Cabal/Distribution/Simple/GHC/Internal.hs b/cabal/Cabal/Distribution/Simple/GHC/Internal.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/GHC/Internal.hs +++ /dev/null @@ -1,681 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.GHC.Internal --- Copyright : Isaac Jones 2003-2007 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This module contains functions shared by GHC (Distribution.Simple.GHC) --- and GHC-derived compilers. - -module Distribution.Simple.GHC.Internal ( - configureToolchain, - getLanguages, - getExtensions, - targetPlatform, - getGhcInfo, - componentCcGhcOptions, - componentCmmGhcOptions, - componentCxxGhcOptions, - componentAsmGhcOptions, - componentGhcOptions, - mkGHCiLibName, - mkGHCiProfLibName, - filterGhciFlags, - ghcLookupProperty, - getHaskellObjects, - mkGhcOptPackages, - substTopDir, - checkPackageDbEnvVar, - profDetailLevelFlag, - -- * GHC platform and version strings - ghcArchString, - ghcOsString, - ghcPlatformAndVersionString, - -- * Constructing GHC environment files - GhcEnvironmentFileEntry(..), - writeGhcEnvironmentFile, - simpleGhcEnvironmentFile, - ghcEnvironmentFileName, - renderGhcEnvironmentFile, - renderGhcEnvironmentFileEntry, - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Simple.GHC.ImplInfo -import Distribution.Types.ComponentLocalBuildInfo -import Distribution.Backpack -import qualified Distribution.InstalledPackageInfo as IPI -import Distribution.PackageDescription -import Distribution.Lex -import Distribution.Simple.Compiler -import Distribution.Simple.Program.GHC -import Distribution.Simple.Setup -import qualified Distribution.ModuleName as ModuleName -import Distribution.Simple.Program -import Distribution.Simple.LocalBuildInfo -import Distribution.Types.UnitId -import Distribution.Types.LocalBuildInfo -import Distribution.Types.TargetInfo -import Distribution.Types.ModuleRenaming -import Distribution.Simple.Utils -import Distribution.Simple.BuildPaths -import Distribution.System -import Distribution.Pretty ( prettyShow ) -import Distribution.Parsec ( simpleParsec ) -import Distribution.Utils.NubList ( toNubListR ) -import Distribution.Verbosity -import Distribution.Compat.Stack -import Distribution.Version (Version) -import Language.Haskell.Extension - -import qualified Data.Map as Map -import qualified Data.ByteString.Lazy.Char8 as BS -import System.Directory ( getDirectoryContents, getTemporaryDirectory ) -import System.Environment ( getEnv ) -import System.FilePath ( (), (<.>), takeExtension - , takeDirectory, takeFileName) -import System.IO ( hClose, hPutStrLn ) - -targetPlatform :: [(String, String)] -> Maybe Platform -targetPlatform ghcInfo = platformFromTriple =<< lookup "Target platform" ghcInfo - --- | Adjust the way we find and configure gcc and ld --- -configureToolchain :: GhcImplInfo - -> ConfiguredProgram - -> Map String String - -> ProgramDb - -> ProgramDb -configureToolchain _implInfo ghcProg ghcInfo = - addKnownProgram gccProgram { - programFindLocation = findProg gccProgramName extraGccPath, - programPostConf = configureGcc - } - . addKnownProgram ldProgram { - programFindLocation = findProg ldProgramName extraLdPath, - programPostConf = configureLd - } - . addKnownProgram arProgram { - programFindLocation = findProg arProgramName extraArPath - } - . addKnownProgram stripProgram { - programFindLocation = findProg stripProgramName extraStripPath - } - where - compilerDir = takeDirectory (programPath ghcProg) - base_dir = takeDirectory compilerDir - mingwBinDir = base_dir "mingw" "bin" - isWindows = case buildOS of Windows -> True; _ -> False - binPrefix = "" - - maybeName :: Program -> Maybe FilePath -> String - maybeName prog = maybe (programName prog) (dropExeExtension . takeFileName) - - gccProgramName = maybeName gccProgram mbGccLocation - ldProgramName = maybeName ldProgram mbLdLocation - arProgramName = maybeName arProgram mbArLocation - stripProgramName = maybeName stripProgram mbStripLocation - - mkExtraPath :: Maybe FilePath -> FilePath -> [FilePath] - mkExtraPath mbPath mingwPath | isWindows = mbDir ++ [mingwPath] - | otherwise = mbDir - where - mbDir = maybeToList . fmap takeDirectory $ mbPath - - extraGccPath = mkExtraPath mbGccLocation windowsExtraGccDir - extraLdPath = mkExtraPath mbLdLocation windowsExtraLdDir - extraArPath = mkExtraPath mbArLocation windowsExtraArDir - extraStripPath = mkExtraPath mbStripLocation windowsExtraStripDir - - -- on Windows finding and configuring ghc's gcc & binutils is a bit special - (windowsExtraGccDir, windowsExtraLdDir, - windowsExtraArDir, windowsExtraStripDir) = - let b = mingwBinDir binPrefix - in (b, b, b, b) - - findProg :: String -> [FilePath] - -> Verbosity -> ProgramSearchPath - -> IO (Maybe (FilePath, [FilePath])) - findProg progName extraPath v searchpath = - findProgramOnSearchPath v searchpath' progName - where - searchpath' = (map ProgramSearchPathDir extraPath) ++ searchpath - - -- Read tool locations from the 'ghc --info' output. Useful when - -- cross-compiling. - mbGccLocation = Map.lookup "C compiler command" ghcInfo - mbLdLocation = Map.lookup "ld command" ghcInfo - mbArLocation = Map.lookup "ar command" ghcInfo - mbStripLocation = Map.lookup "strip command" ghcInfo - - ccFlags = getFlags "C compiler flags" - -- GHC 7.8 renamed "Gcc Linker flags" to "C compiler link flags" - -- and "Ld Linker flags" to "ld flags" (GHC #4862). - gccLinkerFlags = getFlags "Gcc Linker flags" ++ getFlags "C compiler link flags" - ldLinkerFlags = getFlags "Ld Linker flags" ++ getFlags "ld flags" - - -- It appears that GHC 7.6 and earlier encode the tokenized flags as a - -- [String] in these settings whereas later versions just encode the flags as - -- String. - -- - -- We first try to parse as a [String] and if this fails then tokenize the - -- flags ourself. - getFlags :: String -> [String] - getFlags key = - case Map.lookup key ghcInfo of - Nothing -> [] - Just flags - | (flags', ""):_ <- reads flags -> flags' - | otherwise -> tokenizeQuotedWords flags - - configureGcc :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram - configureGcc _v gccProg = do - return gccProg { - programDefaultArgs = programDefaultArgs gccProg - ++ ccFlags ++ gccLinkerFlags - } - - configureLd :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram - configureLd v ldProg = do - ldProg' <- configureLd' v ldProg - return ldProg' { - programDefaultArgs = programDefaultArgs ldProg' ++ ldLinkerFlags - } - - -- we need to find out if ld supports the -x flag - configureLd' :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram - configureLd' verbosity ldProg = do - tempDir <- getTemporaryDirectory - ldx <- withTempFile tempDir ".c" $ \testcfile testchnd -> - withTempFile tempDir ".o" $ \testofile testohnd -> do - hPutStrLn testchnd "int foo() { return 0; }" - hClose testchnd; hClose testohnd - runProgram verbosity ghcProg - [ "-hide-all-packages" - , "-c", testcfile - , "-o", testofile - ] - withTempFile tempDir ".o" $ \testofile' testohnd' -> - do - hClose testohnd' - _ <- getProgramOutput verbosity ldProg - ["-x", "-r", testofile, "-o", testofile'] - return True - `catchIO` (\_ -> return False) - `catchExit` (\_ -> return False) - if ldx - then return ldProg { programDefaultArgs = ["-x"] } - else return ldProg - -getLanguages :: Verbosity -> GhcImplInfo -> ConfiguredProgram - -> IO [(Language, String)] -getLanguages _ implInfo _ - -- TODO: should be using --supported-languages rather than hard coding - | supportsHaskell2010 implInfo = return [(Haskell98, "-XHaskell98") - ,(Haskell2010, "-XHaskell2010")] - | otherwise = return [(Haskell98, "")] - -getGhcInfo :: Verbosity -> GhcImplInfo -> ConfiguredProgram - -> IO [(String, String)] -getGhcInfo verbosity _implInfo ghcProg = do - xs <- getProgramOutput verbosity (suppressOverrideArgs ghcProg) - ["--info"] - case reads xs of - [(i, ss)] - | all isSpace ss -> - return i - _ -> - die' verbosity "Can't parse --info output of GHC" - -getExtensions :: Verbosity -> GhcImplInfo -> ConfiguredProgram - -> IO [(Extension, Maybe String)] -getExtensions verbosity implInfo ghcProg = do - str <- getProgramOutput verbosity (suppressOverrideArgs ghcProg) - ["--supported-languages"] - let extStrs = if reportsNoExt implInfo - then lines str - else -- Older GHCs only gave us either Foo or NoFoo, - -- so we have to work out the other one ourselves - [ extStr'' - | extStr <- lines str - , let extStr' = case extStr of - 'N' : 'o' : xs -> xs - _ -> "No" ++ extStr - , extStr'' <- [extStr, extStr'] - ] - let extensions0 = [ (ext, Just $ "-X" ++ prettyShow ext) - | Just ext <- map simpleParsec extStrs ] - extensions1 = if alwaysNondecIndent implInfo - then -- ghc-7.2 split NondecreasingIndentation off - -- into a proper extension. Before that it - -- was always on. - -- Since it was not a proper extension, it could - -- not be turned off, hence we omit a - -- DisableExtension entry here. - (EnableExtension NondecreasingIndentation, Nothing) : - extensions0 - else extensions0 - return extensions1 - -componentCcGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo - -> BuildInfo -> ComponentLocalBuildInfo - -> FilePath -> FilePath - -> GhcOptions -componentCcGhcOptions verbosity _implInfo lbi bi clbi odir filename = - mempty { - -- Respect -v0, but don't crank up verbosity on GHC if - -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! - ghcOptVerbosity = toFlag (min verbosity normal), - ghcOptMode = toFlag GhcModeCompile, - ghcOptInputFiles = toNubListR [filename], - - ghcOptCppIncludePath = toNubListR $ [autogenComponentModulesDir lbi clbi - ,autogenPackageModulesDir lbi - ,odir] - -- includes relative to the package - ++ includeDirs bi - -- potential includes generated by `configure' - -- in the build directory - ++ [buildDir lbi dir | dir <- includeDirs bi], - ghcOptHideAllPackages= toFlag True, - ghcOptPackageDBs = withPackageDB lbi, - ghcOptPackages = toNubListR $ mkGhcOptPackages clbi, - ghcOptCcOptions = (case withOptimization lbi of - NoOptimisation -> [] - _ -> ["-O2"]) ++ - (case withDebugInfo lbi of - NoDebugInfo -> [] - MinimalDebugInfo -> ["-g1"] - NormalDebugInfo -> ["-g"] - MaximalDebugInfo -> ["-g3"]) ++ - ccOptions bi, - ghcOptObjDir = toFlag odir - } - - -componentCxxGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo - -> BuildInfo -> ComponentLocalBuildInfo - -> FilePath -> FilePath - -> GhcOptions -componentCxxGhcOptions verbosity _implInfo lbi bi clbi odir filename = - mempty { - -- Respect -v0, but don't crank up verbosity on GHC if - -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! - ghcOptVerbosity = toFlag (min verbosity normal), - ghcOptMode = toFlag GhcModeCompile, - ghcOptInputFiles = toNubListR [filename], - - ghcOptCppIncludePath = toNubListR $ [autogenComponentModulesDir lbi clbi - ,autogenPackageModulesDir lbi - ,odir] - -- includes relative to the package - ++ includeDirs bi - -- potential includes generated by `configure' - -- in the build directory - ++ [buildDir lbi dir | dir <- includeDirs bi], - ghcOptHideAllPackages= toFlag True, - ghcOptPackageDBs = withPackageDB lbi, - ghcOptPackages = toNubListR $ mkGhcOptPackages clbi, - ghcOptCxxOptions = (case withOptimization lbi of - NoOptimisation -> [] - _ -> ["-O2"]) ++ - (case withDebugInfo lbi of - NoDebugInfo -> [] - MinimalDebugInfo -> ["-g1"] - NormalDebugInfo -> ["-g"] - MaximalDebugInfo -> ["-g3"]) ++ - cxxOptions bi, - ghcOptObjDir = toFlag odir - } - - -componentAsmGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo - -> BuildInfo -> ComponentLocalBuildInfo - -> FilePath -> FilePath - -> GhcOptions -componentAsmGhcOptions verbosity _implInfo lbi bi clbi odir filename = - mempty { - -- Respect -v0, but don't crank up verbosity on GHC if - -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! - ghcOptVerbosity = toFlag (min verbosity normal), - ghcOptMode = toFlag GhcModeCompile, - ghcOptInputFiles = toNubListR [filename], - - ghcOptCppIncludePath = toNubListR $ [autogenComponentModulesDir lbi clbi - ,autogenPackageModulesDir lbi - ,odir] - -- includes relative to the package - ++ includeDirs bi - -- potential includes generated by `configure' - -- in the build directory - ++ [buildDir lbi dir | dir <- includeDirs bi], - ghcOptHideAllPackages= toFlag True, - ghcOptPackageDBs = withPackageDB lbi, - ghcOptPackages = toNubListR $ mkGhcOptPackages clbi, - ghcOptAsmOptions = (case withOptimization lbi of - NoOptimisation -> [] - _ -> ["-O2"]) ++ - (case withDebugInfo lbi of - NoDebugInfo -> [] - MinimalDebugInfo -> ["-g1"] - NormalDebugInfo -> ["-g"] - MaximalDebugInfo -> ["-g3"]) ++ - asmOptions bi, - ghcOptObjDir = toFlag odir - } - - -componentGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo - -> BuildInfo -> ComponentLocalBuildInfo -> FilePath - -> GhcOptions -componentGhcOptions verbosity implInfo lbi bi clbi odir = - mempty { - -- Respect -v0, but don't crank up verbosity on GHC if - -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! - ghcOptVerbosity = toFlag (min verbosity normal), - ghcOptCabal = toFlag True, - ghcOptThisUnitId = case clbi of - LibComponentLocalBuildInfo { componentCompatPackageKey = pk } - -> toFlag pk - _ -> mempty, - ghcOptThisComponentId = case clbi of - LibComponentLocalBuildInfo { componentComponentId = cid - , componentInstantiatedWith = insts } -> - if null insts - then mempty - else toFlag cid - _ -> mempty, - ghcOptInstantiatedWith = case clbi of - LibComponentLocalBuildInfo { componentInstantiatedWith = insts } - -> insts - _ -> [], - ghcOptNoCode = toFlag $ componentIsIndefinite clbi, - ghcOptHideAllPackages = toFlag True, - ghcOptWarnMissingHomeModules = toFlag $ flagWarnMissingHomeModules implInfo, - ghcOptPackageDBs = withPackageDB lbi, - ghcOptPackages = toNubListR $ mkGhcOptPackages clbi, - ghcOptSplitSections = toFlag (splitSections lbi), - ghcOptSplitObjs = toFlag (splitObjs lbi), - ghcOptSourcePathClear = toFlag True, - ghcOptSourcePath = toNubListR $ [odir] ++ (hsSourceDirs bi) - ++ [autogenComponentModulesDir lbi clbi] - ++ [autogenPackageModulesDir lbi], - ghcOptCppIncludePath = toNubListR $ [autogenComponentModulesDir lbi clbi - ,autogenPackageModulesDir lbi - ,odir] - -- includes relative to the package - ++ includeDirs bi - -- potential includes generated by `configure' - -- in the build directory - ++ [buildDir lbi dir | dir <- includeDirs bi], - ghcOptCppOptions = cppOptions bi, - ghcOptCppIncludes = toNubListR $ - [autogenComponentModulesDir lbi clbi cppHeaderName], - ghcOptFfiIncludes = toNubListR $ includes bi, - ghcOptObjDir = toFlag odir, - ghcOptHiDir = toFlag odir, - ghcOptStubDir = toFlag odir, - ghcOptOutputDir = toFlag odir, - ghcOptOptimisation = toGhcOptimisation (withOptimization lbi), - ghcOptDebugInfo = toFlag (withDebugInfo lbi), - ghcOptExtra = hcOptions GHC bi, - ghcOptExtraPath = toNubListR $ exe_paths, - ghcOptLanguage = toFlag (fromMaybe Haskell98 (defaultLanguage bi)), - -- Unsupported extensions have already been checked by configure - ghcOptExtensions = toNubListR $ usedExtensions bi, - ghcOptExtensionMap = Map.fromList . compilerExtensions $ (compiler lbi) - } - where - exe_paths = [ componentBuildDir lbi (targetCLBI exe_tgt) - | uid <- componentExeDeps clbi - -- TODO: Ugh, localPkgDescr - , Just exe_tgt <- [unitIdTarget' (localPkgDescr lbi) lbi uid] ] - -toGhcOptimisation :: OptimisationLevel -> Flag GhcOptimisation -toGhcOptimisation NoOptimisation = mempty --TODO perhaps override? -toGhcOptimisation NormalOptimisation = toFlag GhcNormalOptimisation -toGhcOptimisation MaximumOptimisation = toFlag GhcMaximumOptimisation - - -componentCmmGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo - -> BuildInfo -> ComponentLocalBuildInfo - -> FilePath -> FilePath - -> GhcOptions -componentCmmGhcOptions verbosity _implInfo lbi bi clbi odir filename = - mempty { - -- Respect -v0, but don't crank up verbosity on GHC if - -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! - ghcOptVerbosity = toFlag (min verbosity normal), - ghcOptMode = toFlag GhcModeCompile, - ghcOptInputFiles = toNubListR [filename], - - ghcOptCppIncludePath = toNubListR $ [autogenComponentModulesDir lbi clbi - ,autogenPackageModulesDir lbi - ,odir] - -- includes relative to the package - ++ includeDirs bi - -- potential includes generated by `configure' - -- in the build directory - ++ [buildDir lbi dir | dir <- includeDirs bi], - ghcOptCppOptions = cppOptions bi, - ghcOptCppIncludes = toNubListR $ - [autogenComponentModulesDir lbi clbi cppHeaderName], - ghcOptHideAllPackages= toFlag True, - ghcOptPackageDBs = withPackageDB lbi, - ghcOptPackages = toNubListR $ mkGhcOptPackages clbi, - ghcOptOptimisation = toGhcOptimisation (withOptimization lbi), - ghcOptDebugInfo = toFlag (withDebugInfo lbi), - ghcOptExtra = cmmOptions bi, - ghcOptObjDir = toFlag odir - } - - --- | Strip out flags that are not supported in ghci -filterGhciFlags :: [String] -> [String] -filterGhciFlags = filter supported - where - supported ('-':'O':_) = False - supported "-debug" = False - supported "-threaded" = False - supported "-ticky" = False - supported "-eventlog" = False - supported "-prof" = False - supported "-unreg" = False - supported _ = True - -mkGHCiLibName :: UnitId -> String -mkGHCiLibName lib = getHSLibraryName lib <.> "o" - -mkGHCiProfLibName :: UnitId -> String -mkGHCiProfLibName lib = getHSLibraryName lib <.> "p_o" - -ghcLookupProperty :: String -> Compiler -> Bool -ghcLookupProperty prop comp = - case Map.lookup prop (compilerProperties comp) of - Just "YES" -> True - _ -> False - --- when using -split-objs, we need to search for object files in the --- Module_split directory for each module. -getHaskellObjects :: GhcImplInfo -> Library -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> FilePath -> String -> Bool -> IO [FilePath] -getHaskellObjects _implInfo lib lbi clbi pref wanted_obj_ext allow_split_objs - | splitObjs lbi && allow_split_objs = do - let splitSuffix = "_" ++ wanted_obj_ext ++ "_split" - dirs = [ pref (ModuleName.toFilePath x ++ splitSuffix) - | x <- allLibModules lib clbi ] - objss <- traverse getDirectoryContents dirs - let objs = [ dir obj - | (objs',dir) <- zip objss dirs, obj <- objs', - let obj_ext = takeExtension obj, - '.':wanted_obj_ext == obj_ext ] - return objs - | otherwise = - return [ pref ModuleName.toFilePath x <.> wanted_obj_ext - | x <- allLibModules lib clbi ] - -mkGhcOptPackages :: ComponentLocalBuildInfo - -> [(OpenUnitId, ModuleRenaming)] -mkGhcOptPackages = componentIncludes - -substTopDir :: FilePath -> IPI.InstalledPackageInfo -> IPI.InstalledPackageInfo -substTopDir topDir ipo - = ipo { - IPI.importDirs = map f (IPI.importDirs ipo), - IPI.libraryDirs = map f (IPI.libraryDirs ipo), - IPI.includeDirs = map f (IPI.includeDirs ipo), - IPI.frameworkDirs = map f (IPI.frameworkDirs ipo), - IPI.haddockInterfaces = map f (IPI.haddockInterfaces ipo), - IPI.haddockHTMLs = map f (IPI.haddockHTMLs ipo) - } - where f ('$':'t':'o':'p':'d':'i':'r':rest) = topDir ++ rest - f x = x - --- Cabal does not use the environment variable GHC{,JS}_PACKAGE_PATH; let --- users know that this is the case. See ticket #335. Simply ignoring it is --- not a good idea, since then ghc and cabal are looking at different sets --- of package DBs and chaos is likely to ensue. --- --- An exception to this is when running cabal from within a `cabal exec` --- environment. In this case, `cabal exec` will set the --- CABAL_SANDBOX_PACKAGE_PATH to the same value that it set --- GHC{,JS}_PACKAGE_PATH to. If that is the case it is OK to allow --- GHC{,JS}_PACKAGE_PATH. -checkPackageDbEnvVar :: Verbosity -> String -> String -> IO () -checkPackageDbEnvVar verbosity compilerName packagePathEnvVar = do - mPP <- lookupEnv packagePathEnvVar - when (isJust mPP) $ do - mcsPP <- lookupEnv "CABAL_SANDBOX_PACKAGE_PATH" - unless (mPP == mcsPP) abort - where - lookupEnv :: String -> IO (Maybe String) - lookupEnv name = (Just `fmap` getEnv name) - `catchIO` const (return Nothing) - abort = - die' verbosity $ "Use of " ++ compilerName ++ "'s environment variable " - ++ packagePathEnvVar ++ " is incompatible with Cabal. Use the " - ++ "flag --package-db to specify a package database (it can be " - ++ "used multiple times)." - - _ = callStack -- TODO: output stack when erroring - -profDetailLevelFlag :: Bool -> ProfDetailLevel -> Flag GhcProfAuto -profDetailLevelFlag forLib mpl = - case mpl of - ProfDetailNone -> mempty - ProfDetailDefault | forLib -> toFlag GhcProfAutoExported - | otherwise -> toFlag GhcProfAutoToplevel - ProfDetailExportedFunctions -> toFlag GhcProfAutoExported - ProfDetailToplevelFunctions -> toFlag GhcProfAutoToplevel - ProfDetailAllFunctions -> toFlag GhcProfAutoAll - ProfDetailOther _ -> mempty - - --- ----------------------------------------------------------------------------- --- GHC platform and version strings - --- | GHC's rendering of its host or target 'Arch' as used in its platform --- strings and certain file locations (such as user package db location). --- -ghcArchString :: Arch -> String -ghcArchString PPC = "powerpc" -ghcArchString PPC64 = "powerpc64" -ghcArchString other = prettyShow other - --- | GHC's rendering of its host or target 'OS' as used in its platform --- strings and certain file locations (such as user package db location). --- -ghcOsString :: OS -> String -ghcOsString Windows = "mingw32" -ghcOsString OSX = "darwin" -ghcOsString Solaris = "solaris2" -ghcOsString other = prettyShow other - --- | GHC's rendering of its platform and compiler version string as used in --- certain file locations (such as user package db location). --- For example @x86_64-linux-7.10.4@ --- -ghcPlatformAndVersionString :: Platform -> Version -> String -ghcPlatformAndVersionString (Platform arch os) version = - intercalate "-" [ ghcArchString arch, ghcOsString os, prettyShow version ] - - --- ----------------------------------------------------------------------------- --- Constructing GHC environment files - --- | The kinds of entries we can stick in a @.ghc.environment@ file. --- -data GhcEnvironmentFileEntry = - GhcEnvFileComment String -- ^ @-- a comment@ - | GhcEnvFilePackageId UnitId -- ^ @package-id foo-1.0-4fe301a...@ - | GhcEnvFilePackageDb PackageDB -- ^ @global-package-db@, - -- @user-package-db@ or - -- @package-db blah/package.conf.d/@ - | GhcEnvFileClearPackageDbStack -- ^ @clear-package-db@ - deriving (Eq, Ord, Show) - --- | Make entries for a GHC environment file based on a 'PackageDBStack' and --- a bunch of package (unit) ids. --- --- If you need to do anything more complicated then either use this as a basis --- and add more entries, or just make all the entries directly. --- -simpleGhcEnvironmentFile :: PackageDBStack - -> [UnitId] - -> [GhcEnvironmentFileEntry] -simpleGhcEnvironmentFile packageDBs pkgids = - GhcEnvFileClearPackageDbStack - : map GhcEnvFilePackageDb packageDBs - ++ map GhcEnvFilePackageId pkgids - --- | Write a @.ghc.environment-$arch-$os-$ver@ file in the given directory. --- --- The 'Platform' and GHC 'Version' are needed as part of the file name. --- --- Returns the name of the file written. -writeGhcEnvironmentFile :: FilePath -- ^ directory in which to put it - -> Platform -- ^ the GHC target platform - -> Version -- ^ the GHC version - -> [GhcEnvironmentFileEntry] -- ^ the content - -> IO FilePath -writeGhcEnvironmentFile directory platform ghcversion entries = do - writeFileAtomic envfile . BS.pack . renderGhcEnvironmentFile $ entries - return envfile - where - envfile = directory ghcEnvironmentFileName platform ghcversion - --- | The @.ghc.environment-$arch-$os-$ver@ file name --- -ghcEnvironmentFileName :: Platform -> Version -> FilePath -ghcEnvironmentFileName platform ghcversion = - ".ghc.environment." ++ ghcPlatformAndVersionString platform ghcversion - --- | Render a bunch of GHC environment file entries --- -renderGhcEnvironmentFile :: [GhcEnvironmentFileEntry] -> String -renderGhcEnvironmentFile = - unlines . map renderGhcEnvironmentFileEntry - --- | Render an individual GHC environment file entry --- -renderGhcEnvironmentFileEntry :: GhcEnvironmentFileEntry -> String -renderGhcEnvironmentFileEntry entry = case entry of - GhcEnvFileComment comment -> format comment - where format = intercalate "\n" . map ("--" <++>) . lines - pref <++> "" = pref - pref <++> str = pref ++ " " ++ str - GhcEnvFilePackageId pkgid -> "package-id " ++ prettyShow pkgid - GhcEnvFilePackageDb pkgdb -> - case pkgdb of - GlobalPackageDB -> "global-package-db" - UserPackageDB -> "user-package-db" - SpecificPackageDB dbfile -> "package-db " ++ dbfile - GhcEnvFileClearPackageDbStack -> "clear-package-db" diff --git a/cabal/Cabal/Distribution/Simple/GHCJS.hs b/cabal/Cabal/Distribution/Simple/GHCJS.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/GHCJS.hs +++ /dev/null @@ -1,1830 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE CPP #-} - -module Distribution.Simple.GHCJS ( - getGhcInfo, - configure, - getInstalledPackages, - getInstalledPackagesMonitorFiles, - getPackageDBContents, - buildLib, buildFLib, buildExe, - replLib, replFLib, replExe, - startInterpreter, - installLib, installFLib, installExe, - libAbiHash, - hcPkgInfo, - registerPackage, - componentGhcOptions, - componentCcGhcOptions, - getLibDir, - isDynamic, - getGlobalPackageDB, - pkgRoot, - runCmd, - -- * Constructing and deconstructing GHC environment files - Internal.GhcEnvironmentFileEntry(..), - Internal.simpleGhcEnvironmentFile, - Internal.renderGhcEnvironmentFile, - Internal.writeGhcEnvironmentFile, - Internal.ghcPlatformAndVersionString, - readGhcEnvironmentFile, - parseGhcEnvironmentFile, - ParseErrorExc(..), - -- * Version-specific implementation quirks - getImplInfo, - GhcImplInfo(..) - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import qualified Distribution.Simple.GHC.Internal as Internal -import Distribution.Simple.GHC.ImplInfo -import Distribution.Simple.GHC.EnvironmentParser -import Distribution.PackageDescription.Utils (cabalBug) -import Distribution.PackageDescription as PD -import Distribution.InstalledPackageInfo (InstalledPackageInfo) -import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo -import Distribution.Simple.PackageIndex (InstalledPackageIndex) -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.LocalBuildInfo -import Distribution.Types.ComponentLocalBuildInfo -import qualified Distribution.Simple.Hpc as Hpc -import Distribution.Simple.BuildPaths -import Distribution.Simple.Utils -import Distribution.Package -import qualified Distribution.ModuleName as ModuleName -import Distribution.ModuleName (ModuleName) -import Distribution.Simple.Program -import qualified Distribution.Simple.Program.HcPkg as HcPkg -import qualified Distribution.Simple.Program.Strip as Strip -import Distribution.Simple.Program.GHC -import Distribution.Simple.Setup -import qualified Distribution.Simple.Setup as Cabal -import Distribution.Simple.Compiler -import Distribution.CabalSpecVersion -import Distribution.Version -import Distribution.System -import Distribution.Verbosity -import Distribution.Pretty -import Distribution.Utils.NubList - -import Control.Monad (msum) -import Data.Char (isLower) -import qualified Data.Map as Map -import System.Directory - ( doesFileExist, getAppUserDataDirectory, createDirectoryIfMissing - , canonicalizePath, removeFile, renameFile ) -import System.FilePath ( (), (<.>), takeExtension - , takeDirectory, replaceExtension - ,isRelative ) -import qualified System.Info - --- ----------------------------------------------------------------------------- --- Configuring - -configure :: Verbosity -> Maybe FilePath -> Maybe FilePath - -> ProgramDb - -> IO (Compiler, Maybe Platform, ProgramDb) -configure verbosity hcPath hcPkgPath conf0 = do - - (ghcjsProg, ghcjsVersion, progdb1) <- - requireProgramVersion verbosity ghcjsProgram - (orLaterVersion (mkVersion [0,1])) - (userMaybeSpecifyPath "ghcjs" hcPath conf0) - - Just ghcjsGhcVersion <- findGhcjsGhcVersion verbosity (programPath ghcjsProg) - unless (ghcjsGhcVersion < mkVersion [8,8]) $ - warn verbosity $ - "Unknown/unsupported 'ghc' version detected " - ++ "(Cabal " ++ prettyShow cabalVersion ++ " supports 'ghc' version < 8.8): " - ++ programPath ghcjsProg ++ " is based on GHC version " ++ - prettyShow ghcjsGhcVersion - - let implInfo = ghcjsVersionImplInfo ghcjsVersion ghcjsGhcVersion - - -- This is slightly tricky, we have to configure ghc first, then we use the - -- location of ghc to help find ghc-pkg in the case that the user did not - -- specify the location of ghc-pkg directly: - (ghcjsPkgProg, ghcjsPkgVersion, progdb2) <- - requireProgramVersion verbosity ghcjsPkgProgram { - programFindLocation = guessGhcjsPkgFromGhcjsPath ghcjsProg - } - anyVersion (userMaybeSpecifyPath "ghcjs-pkg" hcPkgPath progdb1) - - Just ghcjsPkgGhcjsVersion <- findGhcjsPkgGhcjsVersion - verbosity (programPath ghcjsPkgProg) - - when (ghcjsVersion /= ghcjsPkgGhcjsVersion) $ die' verbosity $ - "Version mismatch between ghcjs and ghcjs-pkg: " - ++ programPath ghcjsProg ++ " is version " ++ prettyShow ghcjsVersion ++ " " - ++ programPath ghcjsPkgProg ++ " is version " ++ prettyShow ghcjsPkgGhcjsVersion - - when (ghcjsGhcVersion /= ghcjsPkgVersion) $ die' verbosity $ - "Version mismatch between ghcjs and ghcjs-pkg: " - ++ programPath ghcjsProg - ++ " was built with GHC version " ++ prettyShow ghcjsGhcVersion ++ " " - ++ programPath ghcjsPkgProg - ++ " was built with GHC version " ++ prettyShow ghcjsPkgVersion - - - -- Likewise we try to find the matching hsc2hs and haddock programs. - let hsc2hsProgram' = hsc2hsProgram { - programFindLocation = - guessHsc2hsFromGhcjsPath ghcjsProg - } - haddockProgram' = haddockProgram { - programFindLocation = - guessHaddockFromGhcjsPath ghcjsProg - } - hpcProgram' = hpcProgram { - programFindLocation = guessHpcFromGhcjsPath ghcjsProg - } - {- - runghcProgram' = runghcProgram { - programFindLocation = guessRunghcFromGhcjsPath ghcjsProg - } -} - progdb3 = addKnownProgram haddockProgram' $ - addKnownProgram hsc2hsProgram' $ - addKnownProgram hpcProgram' $ - {- addKnownProgram runghcProgram' -} progdb2 - - languages <- Internal.getLanguages verbosity implInfo ghcjsProg - extensions <- Internal.getExtensions verbosity implInfo ghcjsProg - - ghcjsInfo <- Internal.getGhcInfo verbosity implInfo ghcjsProg - let ghcInfoMap = Map.fromList ghcjsInfo - - let comp = Compiler { - compilerId = CompilerId GHCJS ghcjsVersion, - compilerAbiTag = AbiTag $ - "ghc" ++ intercalate "_" (map show . versionNumbers $ ghcjsGhcVersion), - compilerCompat = [CompilerId GHC ghcjsGhcVersion], - compilerLanguages = languages, - compilerExtensions = extensions, - compilerProperties = ghcInfoMap - } - compPlatform = Internal.targetPlatform ghcjsInfo - return (comp, compPlatform, progdb3) - -guessGhcjsPkgFromGhcjsPath :: ConfiguredProgram -> Verbosity - -> ProgramSearchPath -> IO (Maybe (FilePath, [FilePath])) -guessGhcjsPkgFromGhcjsPath = guessToolFromGhcjsPath ghcjsPkgProgram - -guessHsc2hsFromGhcjsPath :: ConfiguredProgram -> Verbosity - -> ProgramSearchPath -> IO (Maybe (FilePath, [FilePath])) -guessHsc2hsFromGhcjsPath = guessToolFromGhcjsPath hsc2hsProgram - -guessHaddockFromGhcjsPath :: ConfiguredProgram -> Verbosity - -> ProgramSearchPath -> IO (Maybe (FilePath, [FilePath])) -guessHaddockFromGhcjsPath = guessToolFromGhcjsPath haddockProgram - -guessHpcFromGhcjsPath :: ConfiguredProgram - -> Verbosity -> ProgramSearchPath - -> IO (Maybe (FilePath, [FilePath])) -guessHpcFromGhcjsPath = guessToolFromGhcjsPath hpcProgram - - -guessToolFromGhcjsPath :: Program -> ConfiguredProgram - -> Verbosity -> ProgramSearchPath - -> IO (Maybe (FilePath, [FilePath])) -guessToolFromGhcjsPath tool ghcjsProg verbosity searchpath - = do let toolname = programName tool - given_path = programPath ghcjsProg - given_dir = takeDirectory given_path - real_path <- canonicalizePath given_path - let real_dir = takeDirectory real_path - versionSuffix path = takeVersionSuffix (dropExeExtension path) - given_suf = versionSuffix given_path - real_suf = versionSuffix real_path - guessNormal dir = dir toolname <.> exeExtension buildPlatform - guessGhcjs dir = dir (toolname ++ "-ghcjs") - <.> exeExtension buildPlatform - guessGhcjsVersioned dir suf = dir (toolname ++ "-ghcjs" ++ suf) - <.> exeExtension buildPlatform - guessVersioned dir suf = dir (toolname ++ suf) - <.> exeExtension buildPlatform - mkGuesses dir suf | null suf = [guessGhcjs dir, guessNormal dir] - | otherwise = [guessGhcjsVersioned dir suf, - guessVersioned dir suf, - guessGhcjs dir, - guessNormal dir] - guesses = mkGuesses given_dir given_suf ++ - if real_path == given_path - then [] - else mkGuesses real_dir real_suf - info verbosity $ "looking for tool " ++ toolname - ++ " near compiler in " ++ given_dir - debug verbosity $ "candidate locations: " ++ show guesses - exists <- traverse doesFileExist guesses - case [ file | (file, True) <- zip guesses exists ] of - -- If we can't find it near ghc, fall back to the usual - -- method. - [] -> programFindLocation tool verbosity searchpath - (fp:_) -> do info verbosity $ "found " ++ toolname ++ " in " ++ fp - let lookedAt = map fst - . takeWhile (\(_file, exist) -> not exist) - $ zip guesses exists - return (Just (fp, lookedAt)) - - where takeVersionSuffix :: FilePath -> String - takeVersionSuffix = takeWhileEndLE isSuffixChar - - isSuffixChar :: Char -> Bool - isSuffixChar c = isDigit c || c == '.' || c == '-' - -getGhcInfo :: Verbosity -> ConfiguredProgram -> IO [(String, String)] -getGhcInfo verbosity ghcjsProg = Internal.getGhcInfo verbosity implInfo ghcjsProg - where - version = fromMaybe (error "GHCJS.getGhcInfo: no version") $ programVersion ghcjsProg - implInfo = ghcVersionImplInfo version - --- | Given a single package DB, return all installed packages. -getPackageDBContents :: Verbosity -> PackageDB -> ProgramDb - -> IO InstalledPackageIndex -getPackageDBContents verbosity packagedb progdb = do - pkgss <- getInstalledPackages' verbosity [packagedb] progdb - toPackageIndex verbosity pkgss progdb - --- | Given a package DB stack, return all installed packages. -getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramDb - -> IO InstalledPackageIndex -getInstalledPackages verbosity packagedbs progdb = do - checkPackageDbEnvVar verbosity - checkPackageDbStack verbosity packagedbs - pkgss <- getInstalledPackages' verbosity packagedbs progdb - index <- toPackageIndex verbosity pkgss progdb - return $! index - -toPackageIndex :: Verbosity - -> [(PackageDB, [InstalledPackageInfo])] - -> ProgramDb - -> IO InstalledPackageIndex -toPackageIndex verbosity pkgss progdb = do - -- On Windows, various fields have $topdir/foo rather than full - -- paths. We need to substitute the right value in so that when - -- we, for example, call gcc, we have proper paths to give it. - topDir <- getLibDir' verbosity ghcjsProg - let indices = [ PackageIndex.fromList (map (Internal.substTopDir topDir) pkgs) - | (_, pkgs) <- pkgss ] - return $! (mconcat indices) - - where - ghcjsProg = fromMaybe (error "GHCJS.toPackageIndex no ghcjs program") $ lookupProgram ghcjsProgram progdb - -getLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath -getLibDir verbosity lbi = - dropWhileEndLE isSpace `fmap` - getDbProgramOutput verbosity ghcjsProgram - (withPrograms lbi) ["--print-libdir"] - -getLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath -getLibDir' verbosity ghcjsProg = - dropWhileEndLE isSpace `fmap` - getProgramOutput verbosity ghcjsProg ["--print-libdir"] - - --- | Return the 'FilePath' to the global GHC package database. -getGlobalPackageDB :: Verbosity -> ConfiguredProgram -> IO FilePath -getGlobalPackageDB verbosity ghcProg = - dropWhileEndLE isSpace `fmap` - getProgramOutput verbosity ghcProg ["--print-global-package-db"] - --- | Return the 'FilePath' to the per-user GHC package database. -getUserPackageDB :: Verbosity -> ConfiguredProgram -> Platform -> IO FilePath -getUserPackageDB _verbosity ghcjsProg platform = do - -- It's rather annoying that we have to reconstruct this, because ghc - -- hides this information from us otherwise. But for certain use cases - -- like change monitoring it really can't remain hidden. - appdir <- getAppUserDataDirectory "ghcjs" - return (appdir platformAndVersion packageConfFileName) - where - platformAndVersion = Internal.ghcPlatformAndVersionString - platform ghcjsVersion - packageConfFileName = "package.conf.d" - ghcjsVersion = fromMaybe (error "GHCJS.getUserPackageDB: no version") $ programVersion ghcjsProg - -checkPackageDbEnvVar :: Verbosity -> IO () -checkPackageDbEnvVar verbosity = - Internal.checkPackageDbEnvVar verbosity "GHCJS" "GHCJS_PACKAGE_PATH" - -checkPackageDbStack :: Verbosity -> PackageDBStack -> IO () -checkPackageDbStack _ (GlobalPackageDB:rest) - | GlobalPackageDB `notElem` rest = return () -checkPackageDbStack verbosity rest - | GlobalPackageDB `notElem` rest = - die' verbosity $ "With current ghc versions the global package db is always used " - ++ "and must be listed first. This ghc limitation may be lifted in " - ++ "future, see https://gitlab.haskell.org/ghc/ghc/-/issues/5977" -checkPackageDbStack verbosity _ = - die' verbosity $ "If the global package db is specified, it must be " - ++ "specified first and cannot be specified multiple times" - -getInstalledPackages' :: Verbosity -> [PackageDB] -> ProgramDb - -> IO [(PackageDB, [InstalledPackageInfo])] -getInstalledPackages' verbosity packagedbs progdb = - sequenceA - [ do pkgs <- HcPkg.dump (hcPkgInfo progdb) verbosity packagedb - return (packagedb, pkgs) - | packagedb <- packagedbs ] - --- | Get the packages from specific PackageDBs, not cumulative. --- -getInstalledPackagesMonitorFiles :: Verbosity -> Platform - -> ProgramDb - -> [PackageDB] - -> IO [FilePath] -getInstalledPackagesMonitorFiles verbosity platform progdb = - traverse getPackageDBPath - where - getPackageDBPath :: PackageDB -> IO FilePath - getPackageDBPath GlobalPackageDB = - selectMonitorFile =<< getGlobalPackageDB verbosity ghcjsProg - - getPackageDBPath UserPackageDB = - selectMonitorFile =<< getUserPackageDB verbosity ghcjsProg platform - - getPackageDBPath (SpecificPackageDB path) = selectMonitorFile path - - -- GHC has old style file dbs, and new style directory dbs. - -- Note that for dir style dbs, we only need to monitor the cache file, not - -- the whole directory. The ghc program itself only reads the cache file - -- so it's safe to only monitor this one file. - selectMonitorFile path = do - isFileStyle <- doesFileExist path - if isFileStyle then return path - else return (path "package.cache") - - ghcjsProg = fromMaybe (error "GHCJS.toPackageIndex no ghcjs program") $ lookupProgram ghcjsProgram progdb - - -toJSLibName :: String -> String -toJSLibName lib - | takeExtension lib `elem` [".dll",".dylib",".so"] - = replaceExtension lib "js_so" - | takeExtension lib == ".a" = replaceExtension lib "js_a" - | otherwise = lib <.> "js_a" - --- ----------------------------------------------------------------------------- --- Building a library - -buildLib :: Verbosity -> Cabal.Flag (Maybe Int) -> PackageDescription - -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo - -> IO () -buildLib = buildOrReplLib Nothing - -replLib :: [String] -> Verbosity - -> Cabal.Flag (Maybe Int) -> PackageDescription - -> LocalBuildInfo -> Library - -> ComponentLocalBuildInfo -> IO () -replLib = buildOrReplLib . Just - -buildOrReplLib :: Maybe [String] -> Verbosity - -> Cabal.Flag (Maybe Int) -> PackageDescription - -> LocalBuildInfo -> Library - -> ComponentLocalBuildInfo -> IO () -buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do - let uid = componentUnitId clbi - libTargetDir = componentBuildDir lbi clbi - whenVanillaLib forceVanilla = - when (forceVanilla || withVanillaLib lbi) - whenProfLib = when (withProfLib lbi) - whenSharedLib forceShared = - when (forceShared || withSharedLib lbi) - whenStaticLib forceStatic = - when (forceStatic || withStaticLib lbi) - -- whenGHCiLib = when (withGHCiLib lbi) - forRepl = maybe False (const True) mReplFlags - -- ifReplLib = when forRepl - comp = compiler lbi - implInfo = getImplInfo comp - platform@(Platform _hostArch _hostOS) = hostPlatform lbi - has_code = not (componentIsIndefinite clbi) - - (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi) - let runGhcjsProg = runGHC verbosity ghcjsProg comp platform - - let libBi = libBuildInfo lib - - -- fixme flags shouldn't depend on ghcjs being dynamic or not - let isGhcjsDynamic = isDynamic comp - dynamicTooSupported = supportsDynamicToo comp - doingTH = usesTemplateHaskellOrQQ libBi - forceVanillaLib = doingTH && not isGhcjsDynamic - forceSharedLib = doingTH && isGhcjsDynamic - -- TH always needs default libs, even when building for profiling - - -- Determine if program coverage should be enabled and if so, what - -- '-hpcdir' should be. - let isCoverageEnabled = libCoverage lbi - -- TODO: Historically HPC files have been put into a directory which - -- has the package name. I'm going to avoid changing this for - -- now, but it would probably be better for this to be the - -- component ID instead... - pkg_name = prettyShow (PD.package pkg_descr) - distPref = fromFlag $ configDistPref $ configFlags lbi - hpcdir way - | forRepl = mempty -- HPC is not supported in ghci - | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way pkg_name - | otherwise = mempty - - createDirectoryIfMissingVerbose verbosity True libTargetDir - -- TODO: do we need to put hs-boot files into place for mutually recursive - -- modules? - let cLikeFiles = fromNubListR $ toNubListR (cSources libBi) <> toNubListR (cxxSources libBi) - jsSrcs = jsSources libBi - cObjs = map (`replaceExtension` objExtension) cLikeFiles - baseOpts = componentGhcOptions verbosity lbi libBi clbi libTargetDir - linkJsLibOpts = mempty { - ghcOptExtra = - [ "-link-js-lib" , getHSLibraryName uid - , "-js-lib-outputdir", libTargetDir ] ++ - jsSrcs - } - vanillaOptsNoJsLib = baseOpts `mappend` mempty { - ghcOptMode = toFlag GhcModeMake, - ghcOptNumJobs = numJobs, - ghcOptInputModules = toNubListR $ allLibModules lib clbi, - ghcOptHPCDir = hpcdir Hpc.Vanilla - } - vanillaOpts = vanillaOptsNoJsLib `mappend` linkJsLibOpts - - profOpts = adjustExts "p_hi" "p_o" vanillaOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True, - ghcOptProfilingAuto = Internal.profDetailLevelFlag True - (withProfLibDetail lbi), - -- ghcOptHiSuffix = toFlag "p_hi", - -- ghcOptObjSuffix = toFlag "p_o", - ghcOptExtra = hcProfOptions GHC libBi, - ghcOptHPCDir = hpcdir Hpc.Prof - } - - sharedOpts = adjustExts "dyn_hi" "dyn_o" vanillaOpts `mappend` mempty { - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptFPic = toFlag True, - -- ghcOptHiSuffix = toFlag "dyn_hi", - -- ghcOptObjSuffix = toFlag "dyn_o", - ghcOptExtra = hcSharedOptions GHC libBi, - ghcOptHPCDir = hpcdir Hpc.Dyn - } - - vanillaSharedOpts = vanillaOpts `mappend` mempty { - ghcOptDynLinkMode = toFlag GhcStaticAndDynamic, - ghcOptDynHiSuffix = toFlag "js_dyn_hi", - ghcOptDynObjSuffix = toFlag "js_dyn_o", - ghcOptHPCDir = hpcdir Hpc.Dyn - } - - unless (forRepl || null (allLibModules lib clbi) && null jsSrcs && null cObjs) $ - do let vanilla = whenVanillaLib forceVanillaLib (runGhcjsProg vanillaOpts) - shared = whenSharedLib forceSharedLib (runGhcjsProg sharedOpts) - useDynToo = dynamicTooSupported && - (forceVanillaLib || withVanillaLib lbi) && - (forceSharedLib || withSharedLib lbi) && - null (hcSharedOptions GHC libBi) - if not has_code - then vanilla - else - if useDynToo - then do - runGhcjsProg vanillaSharedOpts - case (hpcdir Hpc.Dyn, hpcdir Hpc.Vanilla) of - (Cabal.Flag dynDir, Cabal.Flag vanillaDir) -> - -- When the vanilla and shared library builds are done - -- in one pass, only one set of HPC module interfaces - -- are generated. This set should suffice for both - -- static and dynamically linked executables. We copy - -- the modules interfaces so they are available under - -- both ways. - copyDirectoryRecursive verbosity dynDir vanillaDir - _ -> return () - else if isGhcjsDynamic - then do shared; vanilla - else do vanilla; shared - whenProfLib (runGhcjsProg profOpts) - - -- Build any C++ sources separately. - {- - unless (not has_code || null (cxxSources libBi) || not nativeToo) $ do - info verbosity "Building C++ Sources..." - sequence_ - [ do let baseCxxOpts = Internal.componentCxxGhcOptions verbosity implInfo - lbi libBi clbi libTargetDir filename - vanillaCxxOpts = if isGhcjsDynamic - then baseCxxOpts { ghcOptFPic = toFlag True } - else baseCxxOpts - profCxxOpts = vanillaCxxOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True, - ghcOptObjSuffix = toFlag "p_o" - } - sharedCxxOpts = vanillaCxxOpts `mappend` mempty { - ghcOptFPic = toFlag True, - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptObjSuffix = toFlag "dyn_o" - } - odir = fromFlag (ghcOptObjDir vanillaCxxOpts) - createDirectoryIfMissingVerbose verbosity True odir - let runGhcProgIfNeeded cxxOpts = do - needsRecomp <- checkNeedsRecompilation filename cxxOpts - when needsRecomp $ runGhcjsProg cxxOpts - runGhcProgIfNeeded vanillaCxxOpts - unless forRepl $ - whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCxxOpts) - unless forRepl $ whenProfLib (runGhcProgIfNeeded profCxxOpts) - | filename <- cxxSources libBi] - - ifReplLib $ do - when (null (allLibModules lib clbi)) $ warn verbosity "No exposed modules" - ifReplLib (runGhcjsProg replOpts) --} - -- build any C sources - -- TODO: Add support for S and CMM files. - {- - unless (not has_code || null (cSources libBi) || not nativeToo) $ do - info verbosity "Building C Sources..." - sequence_ - [ do let baseCcOpts = Internal.componentCcGhcOptions verbosity implInfo - lbi libBi clbi libTargetDir filename - vanillaCcOpts = if isGhcjsDynamic - -- Dynamic GHC requires C sources to be built - -- with -fPIC for REPL to work. See #2207. - then baseCcOpts { ghcOptFPic = toFlag True } - else baseCcOpts - profCcOpts = vanillaCcOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True, - ghcOptObjSuffix = toFlag "p_o" - } - sharedCcOpts = vanillaCcOpts `mappend` mempty { - ghcOptFPic = toFlag True, - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptObjSuffix = toFlag "dyn_o" - } - odir = fromFlag (ghcOptObjDir vanillaCcOpts) - createDirectoryIfMissingVerbose verbosity True odir - let runGhcProgIfNeeded ccOpts = do - needsRecomp <- checkNeedsRecompilation filename ccOpts - when needsRecomp $ runGhcjsProg ccOpts - runGhcProgIfNeeded vanillaCcOpts - unless forRepl $ - whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCcOpts) - unless forRepl $ whenProfLib (runGhcProgIfNeeded profCcOpts) - | filename <- cSources libBi] --} - -- TODO: problem here is we need the .c files built first, so we can load them - -- with ghci, but .c files can depend on .h files generated by ghc by ffi - -- exports. - - -- link: - - when has_code . when False {- fixme nativeToo -} . unless forRepl $ do - info verbosity "Linking..." - let cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension)) - (cSources libBi ++ cxxSources libBi) - compiler_id = compilerId (compiler lbi) - sharedLibFilePath = libTargetDir mkSharedLibName (hostPlatform lbi) compiler_id uid - staticLibFilePath = libTargetDir mkStaticLibName (hostPlatform lbi) compiler_id uid - - let stubObjs = [] - stubSharedObjs = [] - -{- - stubObjs <- catMaybes <$> sequenceA - [ findFileWithExtension [objExtension] [libTargetDir] - (ModuleName.toFilePath x ++"_stub") - | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files - , x <- allLibModules lib clbi ] - stubProfObjs <- catMaybes <$> sequenceA - [ findFileWithExtension ["p_" ++ objExtension] [libTargetDir] - (ModuleName.toFilePath x ++"_stub") - | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files - , x <- allLibModules lib clbi ] - stubSharedObjs <- catMaybes <$> sequenceA - [ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir] - (ModuleName.toFilePath x ++"_stub") - | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files - , x <- allLibModules lib clbi ] --} - hObjs <- Internal.getHaskellObjects implInfo lib lbi clbi - libTargetDir objExtension True - hSharedObjs <- - if withSharedLib lbi - then Internal.getHaskellObjects implInfo lib lbi clbi - libTargetDir ("dyn_" ++ objExtension) False - else return [] - - unless (null hObjs && null cObjs && null stubObjs) $ do - rpaths <- getRPaths lbi clbi - - let staticObjectFiles = - hObjs - ++ map (libTargetDir ) cObjs - ++ stubObjs - dynamicObjectFiles = - hSharedObjs - ++ map (libTargetDir ) cSharedObjs - ++ stubSharedObjs - -- After the relocation lib is created we invoke ghc -shared - -- with the dependencies spelled out as -package arguments - -- and ghc invokes the linker with the proper library paths - ghcSharedLinkArgs = - mempty { - ghcOptShared = toFlag True, - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptInputFiles = toNubListR dynamicObjectFiles, - ghcOptOutputFile = toFlag sharedLibFilePath, - ghcOptExtra = hcSharedOptions GHC libBi, - -- For dynamic libs, Mac OS/X needs to know the install location - -- at build time. This only applies to GHC < 7.8 - see the - -- discussion in #1660. - {- - ghcOptDylibName = if hostOS == OSX - && ghcVersion < mkVersion [7,8] - then toFlag sharedLibInstallPath - else mempty, -} - ghcOptHideAllPackages = toFlag True, - ghcOptNoAutoLinkPackages = toFlag True, - ghcOptPackageDBs = withPackageDB lbi, - ghcOptThisUnitId = case clbi of - LibComponentLocalBuildInfo { componentCompatPackageKey = pk } - -> toFlag pk - _ -> mempty, - ghcOptThisComponentId = case clbi of - LibComponentLocalBuildInfo { componentInstantiatedWith = insts } -> - if null insts - then mempty - else toFlag (componentComponentId clbi) - _ -> mempty, - ghcOptInstantiatedWith = case clbi of - LibComponentLocalBuildInfo { componentInstantiatedWith = insts } - -> insts - _ -> [], - ghcOptPackages = toNubListR $ - Internal.mkGhcOptPackages clbi , - ghcOptLinkLibs = extraLibs libBi, - ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi, - ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi, - ghcOptLinkFrameworkDirs = - toNubListR $ PD.extraFrameworkDirs libBi, - ghcOptRPaths = rpaths - } - ghcStaticLinkArgs = - mempty { - ghcOptStaticLib = toFlag True, - ghcOptInputFiles = toNubListR staticObjectFiles, - ghcOptOutputFile = toFlag staticLibFilePath, - ghcOptExtra = hcStaticOptions GHC libBi, - ghcOptHideAllPackages = toFlag True, - ghcOptNoAutoLinkPackages = toFlag True, - ghcOptPackageDBs = withPackageDB lbi, - ghcOptThisUnitId = case clbi of - LibComponentLocalBuildInfo { componentCompatPackageKey = pk } - -> toFlag pk - _ -> mempty, - ghcOptThisComponentId = case clbi of - LibComponentLocalBuildInfo { componentInstantiatedWith = insts } -> - if null insts - then mempty - else toFlag (componentComponentId clbi) - _ -> mempty, - ghcOptInstantiatedWith = case clbi of - LibComponentLocalBuildInfo { componentInstantiatedWith = insts } - -> insts - _ -> [], - ghcOptPackages = toNubListR $ - Internal.mkGhcOptPackages clbi , - ghcOptLinkLibs = extraLibs libBi, - ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi - } - - info verbosity (show (ghcOptPackages ghcSharedLinkArgs)) -{- - whenVanillaLib False $ do - Ar.createArLibArchive verbosity lbi vanillaLibFilePath staticObjectFiles - whenGHCiLib $ do - (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi) - Ld.combineObjectFiles verbosity lbi ldProg - ghciLibFilePath staticObjectFiles - -} -{- - whenProfLib $ do - Ar.createArLibArchive verbosity lbi profileLibFilePath profObjectFiles - whenGHCiLib $ do - (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi) - Ld.combineObjectFiles verbosity lbi ldProg - ghciProfLibFilePath profObjectFiles --} - whenSharedLib False $ - runGhcjsProg ghcSharedLinkArgs - - whenStaticLib False $ - runGhcjsProg ghcStaticLinkArgs - --- | Start a REPL without loading any source files. -startInterpreter :: Verbosity -> ProgramDb -> Compiler -> Platform - -> PackageDBStack -> IO () -startInterpreter verbosity progdb comp platform packageDBs = do - let replOpts = mempty { - ghcOptMode = toFlag GhcModeInteractive, - ghcOptPackageDBs = packageDBs - } - checkPackageDbStack verbosity packageDBs - (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram progdb - runGHC verbosity ghcjsProg comp platform replOpts - --- ----------------------------------------------------------------------------- --- Building an executable or foreign library - --- | Build a foreign library -buildFLib - :: Verbosity -> Cabal.Flag (Maybe Int) - -> PackageDescription -> LocalBuildInfo - -> ForeignLib -> ComponentLocalBuildInfo -> IO () -buildFLib v njobs pkg lbi = gbuild v njobs pkg lbi . GBuildFLib - -replFLib - :: [String] -> Verbosity - -> Cabal.Flag (Maybe Int) -> PackageDescription - -> LocalBuildInfo -> ForeignLib - -> ComponentLocalBuildInfo -> IO () -replFLib replFlags v njobs pkg lbi = - gbuild v njobs pkg lbi . GReplFLib replFlags - --- | Build an executable with GHC. --- -buildExe - :: Verbosity -> Cabal.Flag (Maybe Int) - -> PackageDescription -> LocalBuildInfo - -> Executable -> ComponentLocalBuildInfo -> IO () -buildExe v njobs pkg lbi = gbuild v njobs pkg lbi . GBuildExe - -replExe - :: [String] -> Verbosity - -> Cabal.Flag (Maybe Int) -> PackageDescription - -> LocalBuildInfo -> Executable - -> ComponentLocalBuildInfo -> IO () -replExe replFlags v njobs pkg lbi = - gbuild v njobs pkg lbi . GReplExe replFlags - --- | Building an executable, starting the REPL, and building foreign --- libraries are all very similar and implemented in 'gbuild'. The --- 'GBuildMode' distinguishes between the various kinds of operation. -data GBuildMode = - GBuildExe Executable - | GReplExe [String] Executable - | GBuildFLib ForeignLib - | GReplFLib [String] ForeignLib - -gbuildInfo :: GBuildMode -> BuildInfo -gbuildInfo (GBuildExe exe) = buildInfo exe -gbuildInfo (GReplExe _ exe) = buildInfo exe -gbuildInfo (GBuildFLib flib) = foreignLibBuildInfo flib -gbuildInfo (GReplFLib _ flib) = foreignLibBuildInfo flib - -gbuildName :: GBuildMode -> String -gbuildName (GBuildExe exe) = unUnqualComponentName $ exeName exe -gbuildName (GReplExe _ exe) = unUnqualComponentName $ exeName exe -gbuildName (GBuildFLib flib) = unUnqualComponentName $ foreignLibName flib -gbuildName (GReplFLib _ flib) = unUnqualComponentName $ foreignLibName flib - -gbuildTargetName :: LocalBuildInfo -> GBuildMode -> String -gbuildTargetName lbi (GBuildExe exe) = exeTargetName (hostPlatform lbi) exe -gbuildTargetName lbi (GReplExe _ exe) = exeTargetName (hostPlatform lbi) exe -gbuildTargetName lbi (GBuildFLib flib) = flibTargetName lbi flib -gbuildTargetName lbi (GReplFLib _ flib) = flibTargetName lbi flib - -exeTargetName :: Platform -> Executable -> String -exeTargetName platform exe = unUnqualComponentName (exeName exe) `withExt` exeExtension platform - --- | Target name for a foreign library (the actual file name) --- --- We do not use mkLibName and co here because the naming for foreign libraries --- is slightly different (we don't use "_p" or compiler version suffices, and we --- don't want the "lib" prefix on Windows). --- --- TODO: We do use `dllExtension` and co here, but really that's wrong: they --- use the OS used to build cabal to determine which extension to use, rather --- than the target OS (but this is wrong elsewhere in Cabal as well). -flibTargetName :: LocalBuildInfo -> ForeignLib -> String -flibTargetName lbi flib = - case (os, foreignLibType flib) of - (Windows, ForeignLibNativeShared) -> nm <.> "dll" - (Windows, ForeignLibNativeStatic) -> nm <.> "lib" - (Linux, ForeignLibNativeShared) -> "lib" ++ nm <.> versionedExt - (_other, ForeignLibNativeShared) -> "lib" ++ nm <.> dllExtension (hostPlatform lbi) - (_other, ForeignLibNativeStatic) -> "lib" ++ nm <.> staticLibExtension (hostPlatform lbi) - (_any, ForeignLibTypeUnknown) -> cabalBug "unknown foreign lib type" - where - nm :: String - nm = unUnqualComponentName $ foreignLibName flib - - os :: OS - os = let (Platform _ os') = hostPlatform lbi - in os' - - -- If a foreign lib foo has lib-version-info 5:1:2 or - -- lib-version-linux 3.2.1, it should be built as libfoo.so.3.2.1 - -- Libtool's version-info data is translated into library versions in a - -- nontrivial way: so refer to libtool documentation. - versionedExt :: String - versionedExt = - let nums = foreignLibVersion flib os - in foldl (<.>) "so" (map show nums) - --- | Name for the library when building. --- --- If the `lib-version-info` field or the `lib-version-linux` field of --- a foreign library target is set, we need to incorporate that --- version into the SONAME field. --- --- If a foreign library foo has lib-version-info 5:1:2, it should be --- built as libfoo.so.3.2.1. We want it to get soname libfoo.so.3. --- However, GHC does not allow overriding soname by setting linker --- options, as it sets a soname of its own (namely the output --- filename), after the user-supplied linker options. Hence, we have --- to compile the library with the soname as its filename. We rename --- the compiled binary afterwards. --- --- This method allows to adjust the name of the library at build time --- such that the correct soname can be set. -flibBuildName :: LocalBuildInfo -> ForeignLib -> String -flibBuildName lbi flib - -- On linux, if a foreign-library has version data, the first digit is used - -- to produce the SONAME. - | (os, foreignLibType flib) == - (Linux, ForeignLibNativeShared) - = let nums = foreignLibVersion flib os - in "lib" ++ nm <.> foldl (<.>) "so" (map show (take 1 nums)) - | otherwise = flibTargetName lbi flib - where - os :: OS - os = let (Platform _ os') = hostPlatform lbi - in os' - - nm :: String - nm = unUnqualComponentName $ foreignLibName flib - -gbuildIsRepl :: GBuildMode -> Bool -gbuildIsRepl (GBuildExe _) = False -gbuildIsRepl (GReplExe _ _) = True -gbuildIsRepl (GBuildFLib _) = False -gbuildIsRepl (GReplFLib _ _) = True - -gbuildNeedDynamic :: LocalBuildInfo -> GBuildMode -> Bool -gbuildNeedDynamic lbi bm = - case bm of - GBuildExe _ -> withDynExe lbi - GReplExe _ _ -> withDynExe lbi - GBuildFLib flib -> withDynFLib flib - GReplFLib _ flib -> withDynFLib flib - where - withDynFLib flib = - case foreignLibType flib of - ForeignLibNativeShared -> - ForeignLibStandalone `notElem` foreignLibOptions flib - ForeignLibNativeStatic -> - False - ForeignLibTypeUnknown -> - cabalBug "unknown foreign lib type" - -gbuildModDefFiles :: GBuildMode -> [FilePath] -gbuildModDefFiles (GBuildExe _) = [] -gbuildModDefFiles (GReplExe _ _) = [] -gbuildModDefFiles (GBuildFLib flib) = foreignLibModDefFile flib -gbuildModDefFiles (GReplFLib _ flib) = foreignLibModDefFile flib - --- | "Main" module name when overridden by @ghc-options: -main-is ...@ --- or 'Nothing' if no @-main-is@ flag could be found. --- --- In case of 'Nothing', 'Distribution.ModuleName.main' can be assumed. -exeMainModuleName :: Executable -> Maybe ModuleName -exeMainModuleName Executable{buildInfo = bnfo} = - -- GHC honors the last occurrence of a module name updated via -main-is - -- - -- Moreover, -main-is when parsed left-to-right can update either - -- the "Main" module name, or the "main" function name, or both, - -- see also 'decodeMainIsArg'. - msum $ reverse $ map decodeMainIsArg $ findIsMainArgs ghcopts - where - ghcopts = hcOptions GHC bnfo - - findIsMainArgs [] = [] - findIsMainArgs ("-main-is":arg:rest) = arg : findIsMainArgs rest - findIsMainArgs (_:rest) = findIsMainArgs rest - --- | Decode argument to '-main-is' --- --- Returns 'Nothing' if argument set only the function name. --- --- This code has been stolen/refactored from GHC's DynFlags.setMainIs --- function. The logic here is deliberately imperfect as it is --- intended to be bug-compatible with GHC's parser. See discussion in --- https://github.com/haskell/cabal/pull/4539#discussion_r118981753. -decodeMainIsArg :: String -> Maybe ModuleName -decodeMainIsArg arg - | headOf main_fn isLower - -- The arg looked like "Foo.Bar.baz" - = Just (ModuleName.fromString main_mod) - | headOf arg isUpper -- The arg looked like "Foo" or "Foo.Bar" - = Just (ModuleName.fromString arg) - | otherwise -- The arg looked like "baz" - = Nothing - where - headOf :: String -> (Char -> Bool) -> Bool - headOf str pred' = any pred' (safeHead str) - - (main_mod, main_fn) = splitLongestPrefix arg (== '.') - - splitLongestPrefix :: String -> (Char -> Bool) -> (String,String) - splitLongestPrefix str pred' - | null r_pre = (str, []) - | otherwise = (reverse (safeTail r_pre), reverse r_suf) - -- 'safeTail' drops the char satisfying 'pred' - where (r_suf, r_pre) = break pred' (reverse str) - - --- | A collection of: --- * C input files --- * C++ input files --- * GHC input files --- * GHC input modules --- --- Used to correctly build and link sources. -data BuildSources = BuildSources { - cSourcesFiles :: [FilePath], - cxxSourceFiles :: [FilePath], - inputSourceFiles :: [FilePath], - inputSourceModules :: [ModuleName] - } - --- | Locate and return the 'BuildSources' required to build and link. -gbuildSources :: Verbosity - -> CabalSpecVersion - -> FilePath - -> GBuildMode - -> IO BuildSources -gbuildSources verbosity specVer tmpDir bm = - case bm of - GBuildExe exe -> exeSources exe - GReplExe _ exe -> exeSources exe - GBuildFLib flib -> return $ flibSources flib - GReplFLib _ flib -> return $ flibSources flib - where - exeSources :: Executable -> IO BuildSources - exeSources exe@Executable{buildInfo = bnfo, modulePath = modPath} = do - main <- findFileEx verbosity (tmpDir : hsSourceDirs bnfo) modPath - let mainModName = fromMaybe ModuleName.main $ exeMainModuleName exe - otherModNames = exeModules exe - - if isHaskell main - then - if specVer < CabalSpecV2_0 && (mainModName `elem` otherModNames) - then do - -- The cabal manual clearly states that `other-modules` is - -- intended for non-main modules. However, there's at least one - -- important package on Hackage (happy-1.19.5) which - -- violates this. We workaround this here so that we don't - -- invoke GHC with e.g. 'ghc --make Main src/Main.hs' which - -- would result in GHC complaining about duplicate Main - -- modules. - -- - -- Finally, we only enable this workaround for - -- specVersion < 2, as 'cabal-version:>=2.0' cabal files - -- have no excuse anymore to keep doing it wrong... ;-) - warn verbosity $ "Enabling workaround for Main module '" - ++ prettyShow mainModName - ++ "' listed in 'other-modules' illegally!" - - return BuildSources { - cSourcesFiles = cSources bnfo, - cxxSourceFiles = cxxSources bnfo, - inputSourceFiles = [main], - inputSourceModules = filter (/= mainModName) $ exeModules exe - } - - else return BuildSources { - cSourcesFiles = cSources bnfo, - cxxSourceFiles = cxxSources bnfo, - inputSourceFiles = [main], - inputSourceModules = exeModules exe - } - else let (csf, cxxsf) - | isCxx main = ( cSources bnfo, main : cxxSources bnfo) - -- if main is not a Haskell source - -- and main is not a C++ source - -- then we assume that it is a C source - | otherwise = (main : cSources bnfo, cxxSources bnfo) - - in return BuildSources { - cSourcesFiles = csf, - cxxSourceFiles = cxxsf, - inputSourceFiles = [], - inputSourceModules = exeModules exe - } - - flibSources :: ForeignLib -> BuildSources - flibSources flib@ForeignLib{foreignLibBuildInfo = bnfo} = - BuildSources { - cSourcesFiles = cSources bnfo, - cxxSourceFiles = cxxSources bnfo, - inputSourceFiles = [], - inputSourceModules = foreignLibModules flib - } - - isHaskell :: FilePath -> Bool - isHaskell fp = elem (takeExtension fp) [".hs", ".lhs"] - - isCxx :: FilePath -> Bool - isCxx fp = elem (takeExtension fp) [".cpp", ".cxx", ".c++"] - --- | Generic build function. See comment for 'GBuildMode'. -gbuild :: Verbosity -> Cabal.Flag (Maybe Int) - -> PackageDescription -> LocalBuildInfo - -> GBuildMode -> ComponentLocalBuildInfo -> IO () -gbuild verbosity numJobs pkg_descr lbi bm clbi = do - (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi) - let replFlags = case bm of - GReplExe flags _ -> flags - GReplFLib flags _ -> flags - GBuildExe{} -> mempty - GBuildFLib{} -> mempty - comp = compiler lbi - platform = hostPlatform lbi - implInfo = getImplInfo comp - runGhcProg = runGHC verbosity ghcjsProg comp platform - - let (bnfo, threaded) = case bm of - GBuildFLib _ -> popThreadedFlag (gbuildInfo bm) - _ -> (gbuildInfo bm, False) - - -- the name that GHC really uses (e.g., with .exe on Windows for executables) - let targetName = gbuildTargetName lbi bm - let targetDir = buildDir lbi (gbuildName bm) - let tmpDir = targetDir (gbuildName bm ++ "-tmp") - createDirectoryIfMissingVerbose verbosity True targetDir - createDirectoryIfMissingVerbose verbosity True tmpDir - - -- TODO: do we need to put hs-boot files into place for mutually recursive - -- modules? FIX: what about exeName.hi-boot? - - -- Determine if program coverage should be enabled and if so, what - -- '-hpcdir' should be. - let isCoverageEnabled = exeCoverage lbi - distPref = fromFlag $ configDistPref $ configFlags lbi - hpcdir way - | gbuildIsRepl bm = mempty -- HPC is not supported in ghci - | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way (gbuildName bm) - | otherwise = mempty - - rpaths <- getRPaths lbi clbi - buildSources <- gbuildSources verbosity (specVersion pkg_descr) tmpDir bm - - let cSrcs = cSourcesFiles buildSources - cxxSrcs = cxxSourceFiles buildSources - inputFiles = inputSourceFiles buildSources - inputModules = inputSourceModules buildSources - isGhcDynamic = isDynamic comp - dynamicTooSupported = supportsDynamicToo comp - cObjs = map (`replaceExtension` objExtension) cSrcs - cxxObjs = map (`replaceExtension` objExtension) cxxSrcs - needDynamic = gbuildNeedDynamic lbi bm - needProfiling = withProfExe lbi - - -- build executables - baseOpts = (componentGhcOptions verbosity lbi bnfo clbi tmpDir) - `mappend` mempty { - ghcOptMode = toFlag GhcModeMake, - ghcOptInputFiles = toNubListR inputFiles, - ghcOptInputModules = toNubListR inputModules - } - staticOpts = baseOpts `mappend` mempty { - ghcOptDynLinkMode = toFlag GhcStaticOnly, - ghcOptHPCDir = hpcdir Hpc.Vanilla - } - profOpts = baseOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True, - ghcOptProfilingAuto = Internal.profDetailLevelFlag False - (withProfExeDetail lbi), - ghcOptHiSuffix = toFlag "p_hi", - ghcOptObjSuffix = toFlag "p_o", - ghcOptExtra = hcProfOptions GHC bnfo, - ghcOptHPCDir = hpcdir Hpc.Prof - } - dynOpts = baseOpts `mappend` mempty { - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - -- TODO: Does it hurt to set -fPIC for executables? - ghcOptFPic = toFlag True, - ghcOptHiSuffix = toFlag "dyn_hi", - ghcOptObjSuffix = toFlag "dyn_o", - ghcOptExtra = hcSharedOptions GHC bnfo, - ghcOptHPCDir = hpcdir Hpc.Dyn - } - dynTooOpts = staticOpts `mappend` mempty { - ghcOptDynLinkMode = toFlag GhcStaticAndDynamic, - ghcOptDynHiSuffix = toFlag "dyn_hi", - ghcOptDynObjSuffix = toFlag "dyn_o", - ghcOptHPCDir = hpcdir Hpc.Dyn - } - linkerOpts = mempty { - ghcOptLinkOptions = PD.ldOptions bnfo, - ghcOptLinkLibs = extraLibs bnfo, - ghcOptLinkLibPath = toNubListR $ extraLibDirs bnfo, - ghcOptLinkFrameworks = toNubListR $ - PD.frameworks bnfo, - ghcOptLinkFrameworkDirs = toNubListR $ - PD.extraFrameworkDirs bnfo, - ghcOptInputFiles = toNubListR - [tmpDir x | x <- cObjs ++ cxxObjs] - } - dynLinkerOpts = mempty { - ghcOptRPaths = rpaths - } - replOpts = baseOpts { - ghcOptExtra = Internal.filterGhciFlags - (ghcOptExtra baseOpts) - <> replFlags - } - -- For a normal compile we do separate invocations of ghc for - -- compiling as for linking. But for repl we have to do just - -- the one invocation, so that one has to include all the - -- linker stuff too, like -l flags and any .o files from C - -- files etc. - `mappend` linkerOpts - `mappend` mempty { - ghcOptMode = toFlag GhcModeInteractive, - ghcOptOptimisation = toFlag GhcNoOptimisation - } - commonOpts | needProfiling = profOpts - | needDynamic = dynOpts - | otherwise = staticOpts - compileOpts | useDynToo = dynTooOpts - | otherwise = commonOpts - withStaticExe = not needProfiling && not needDynamic - - -- For building exe's that use TH with -prof or -dynamic we actually have - -- to build twice, once without -prof/-dynamic and then again with - -- -prof/-dynamic. This is because the code that TH needs to run at - -- compile time needs to be the vanilla ABI so it can be loaded up and run - -- by the compiler. - -- With dynamic-by-default GHC the TH object files loaded at compile-time - -- need to be .dyn_o instead of .o. - doingTH = usesTemplateHaskellOrQQ bnfo - -- Should we use -dynamic-too instead of compiling twice? - useDynToo = dynamicTooSupported && isGhcDynamic - && doingTH && withStaticExe - && null (hcSharedOptions GHC bnfo) - compileTHOpts | isGhcDynamic = dynOpts - | otherwise = staticOpts - compileForTH - | gbuildIsRepl bm = False - | useDynToo = False - | isGhcDynamic = doingTH && (needProfiling || withStaticExe) - | otherwise = doingTH && (needProfiling || needDynamic) - - -- Build static/dynamic object files for TH, if needed. - when compileForTH $ - runGhcProg compileTHOpts { ghcOptNoLink = toFlag True - , ghcOptNumJobs = numJobs } - - -- Do not try to build anything if there are no input files. - -- This can happen if the cabal file ends up with only cSrcs - -- but no Haskell modules. - unless ((null inputFiles && null inputModules) - || gbuildIsRepl bm) $ - runGhcProg compileOpts { ghcOptNoLink = toFlag True - , ghcOptNumJobs = numJobs } - - -- build any C++ sources - unless (null cxxSrcs) $ do - info verbosity "Building C++ Sources..." - sequence_ - [ do let baseCxxOpts = Internal.componentCxxGhcOptions verbosity implInfo - lbi bnfo clbi tmpDir filename - vanillaCxxOpts = if isGhcDynamic - -- Dynamic GHC requires C++ sources to be built - -- with -fPIC for REPL to work. See #2207. - then baseCxxOpts { ghcOptFPic = toFlag True } - else baseCxxOpts - profCxxOpts = vanillaCxxOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True - } - sharedCxxOpts = vanillaCxxOpts `mappend` mempty { - ghcOptFPic = toFlag True, - ghcOptDynLinkMode = toFlag GhcDynamicOnly - } - opts | needProfiling = profCxxOpts - | needDynamic = sharedCxxOpts - | otherwise = vanillaCxxOpts - -- TODO: Placing all Haskell, C, & C++ objects in a single directory - -- Has the potential for file collisions. In general we would - -- consider this a user error. However, we should strive to - -- add a warning if this occurs. - odir = fromFlag (ghcOptObjDir opts) - createDirectoryIfMissingVerbose verbosity True odir - needsRecomp <- checkNeedsRecompilation filename opts - when needsRecomp $ - runGhcProg opts - | filename <- cxxSrcs ] - - -- build any C sources - unless (null cSrcs) $ do - info verbosity "Building C Sources..." - sequence_ - [ do let baseCcOpts = Internal.componentCcGhcOptions verbosity implInfo - lbi bnfo clbi tmpDir filename - vanillaCcOpts = if isGhcDynamic - -- Dynamic GHC requires C sources to be built - -- with -fPIC for REPL to work. See #2207. - then baseCcOpts { ghcOptFPic = toFlag True } - else baseCcOpts - profCcOpts = vanillaCcOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True - } - sharedCcOpts = vanillaCcOpts `mappend` mempty { - ghcOptFPic = toFlag True, - ghcOptDynLinkMode = toFlag GhcDynamicOnly - } - opts | needProfiling = profCcOpts - | needDynamic = sharedCcOpts - | otherwise = vanillaCcOpts - odir = fromFlag (ghcOptObjDir opts) - createDirectoryIfMissingVerbose verbosity True odir - needsRecomp <- checkNeedsRecompilation filename opts - when needsRecomp $ - runGhcProg opts - | filename <- cSrcs ] - - -- TODO: problem here is we need the .c files built first, so we can load them - -- with ghci, but .c files can depend on .h files generated by ghc by ffi - -- exports. - case bm of - GReplExe _ _ -> runGhcProg replOpts - GReplFLib _ _ -> runGhcProg replOpts - GBuildExe _ -> do - let linkOpts = commonOpts - `mappend` linkerOpts - `mappend` mempty { - ghcOptLinkNoHsMain = toFlag (null inputFiles) - } - `mappend` (if withDynExe lbi then dynLinkerOpts else mempty) - - info verbosity "Linking..." - -- Work around old GHCs not relinking in this - -- situation, see #3294 - let target = targetDir targetName - when (compilerVersion comp < mkVersion [7,7]) $ do - e <- doesFileExist target - when e (removeFile target) - runGhcProg linkOpts { ghcOptOutputFile = toFlag target } - GBuildFLib flib -> do - let rtsInfo = extractRtsInfo lbi - rtsOptLinkLibs = [ - if needDynamic - then if threaded - then dynRtsThreadedLib (rtsDynamicInfo rtsInfo) - else dynRtsVanillaLib (rtsDynamicInfo rtsInfo) - else if threaded - then statRtsThreadedLib (rtsStaticInfo rtsInfo) - else statRtsVanillaLib (rtsStaticInfo rtsInfo) - ] - linkOpts = case foreignLibType flib of - ForeignLibNativeShared -> - commonOpts - `mappend` linkerOpts - `mappend` dynLinkerOpts - `mappend` mempty { - ghcOptLinkNoHsMain = toFlag True, - ghcOptShared = toFlag True, - ghcOptLinkLibs = rtsOptLinkLibs, - ghcOptLinkLibPath = toNubListR $ rtsLibPaths rtsInfo, - ghcOptFPic = toFlag True, - ghcOptLinkModDefFiles = toNubListR $ gbuildModDefFiles bm - } - -- See Note [RPATH] - `mappend` ifNeedsRPathWorkaround lbi mempty { - ghcOptLinkOptions = ["-Wl,--no-as-needed"] - , ghcOptLinkLibs = ["ffi"] - } - ForeignLibNativeStatic -> - -- this should be caught by buildFLib - -- (and if we do implement this, we probably don't even want to call - -- ghc here, but rather Ar.createArLibArchive or something) - cabalBug "static libraries not yet implemented" - ForeignLibTypeUnknown -> - cabalBug "unknown foreign lib type" - -- We build under a (potentially) different filename to set a - -- soname on supported platforms. See also the note for - -- @flibBuildName@. - info verbosity "Linking..." - let buildName = flibBuildName lbi flib - runGhcProg linkOpts { ghcOptOutputFile = toFlag (targetDir buildName) } - renameFile (targetDir buildName) (targetDir targetName) - -{- -Note [RPATH] -~~~~~~~~~~~~ - -Suppose that the dynamic library depends on `base`, but not (directly) on -`integer-gmp` (which, however, is a dependency of `base`). We will link the -library as - - gcc ... -lHSbase-4.7.0.2-ghc7.8.4 -lHSinteger-gmp-0.5.1.0-ghc7.8.4 ... - -However, on systems (like Ubuntu) where the linker gets called with `-as-needed` -by default, the linker will notice that `integer-gmp` isn't actually a direct -dependency and hence omit the link. - -Then when we attempt to link a C program against this dynamic library, the -_static_ linker will attempt to verify that all symbols can be resolved. The -dynamic library itself does not require any symbols from `integer-gmp`, but -`base` does. In order to verify that the symbols used by `base` can be -resolved, the static linker needs to be able to _find_ integer-gmp. - -Finding the `base` dependency is simple, because the dynamic elf header -(`readelf -d`) for the library that we have created looks something like - - (NEEDED) Shared library: [libHSbase-4.7.0.2-ghc7.8.4.so] - (RPATH) Library rpath: [/path/to/base-4.7.0.2:...] - -However, when it comes to resolving the dependency on `integer-gmp`, it needs -to look at the dynamic header for `base`. On modern ghc (7.8 and higher) this -looks something like - - (NEEDED) Shared library: [libHSinteger-gmp-0.5.1.0-ghc7.8.4.so] - (RPATH) Library rpath: [$ORIGIN/../integer-gmp-0.5.1.0:...] - -This specifies the location of `integer-gmp` _in terms of_ the location of base -(using the `$ORIGIN`) variable. But here's the crux: when the static linker -attempts to verify that all symbols can be resolved, [**IT DOES NOT RESOLVE -`$ORIGIN`**](http://stackoverflow.com/questions/6323603/ld-using-rpath-origin-inside-a-shared-library-recursive). -As a consequence, it will not be able to resolve the symbols and report the -missing symbols as errors, _even though the dynamic linker **would** be able to -resolve these symbols_. We can tell the static linker not to report these -errors by using `--unresolved-symbols=ignore-all` and all will be fine when we -run the program ([(indeed, this is what the gold linker -does)](https://sourceware.org/ml/binutils/2013-05/msg00038.html), but it makes -the resulting library more difficult to use. - -Instead what we can do is make sure that the generated dynamic library has -explicit top-level dependencies on these libraries. This means that the static -linker knows where to find them, and when we have transitive dependencies on -the same libraries the linker will only load them once, so we avoid needing to -look at the `RPATH` of our dependencies. We can do this by passing -`--no-as-needed` to the linker, so that it doesn't omit any libraries. - -Note that on older ghc (7.6 and before) the Haskell libraries don't have an -RPATH set at all, which makes it even more important that we make these -top-level dependencies. - -Finally, we have to explicitly link against `libffi` for the same reason. For -newer ghc this _happens_ to be unnecessary on many systems because `libffi` is -a library which is not specific to GHC, and when the static linker verifies -that all symbols can be resolved it will find the `libffi` that is globally -installed (completely independent from ghc). Of course, this may well be the -_wrong_ version of `libffi`, but it's quite possible that symbol resolution -happens to work. This is of course the wrong approach, which is why we link -explicitly against `libffi` so that we will find the _right_ version of -`libffi`. --} - --- | Do we need the RPATH workaround? --- --- See Note [RPATH]. -ifNeedsRPathWorkaround :: Monoid a => LocalBuildInfo -> a -> a -ifNeedsRPathWorkaround lbi a = - case hostPlatform lbi of - Platform _ Linux -> a - _otherwise -> mempty - -data DynamicRtsInfo = DynamicRtsInfo { - dynRtsVanillaLib :: FilePath - , dynRtsThreadedLib :: FilePath - , dynRtsDebugLib :: FilePath - , dynRtsEventlogLib :: FilePath - , dynRtsThreadedDebugLib :: FilePath - , dynRtsThreadedEventlogLib :: FilePath - } - -data StaticRtsInfo = StaticRtsInfo { - statRtsVanillaLib :: FilePath - , statRtsThreadedLib :: FilePath - , statRtsDebugLib :: FilePath - , statRtsEventlogLib :: FilePath - , statRtsThreadedDebugLib :: FilePath - , statRtsThreadedEventlogLib :: FilePath - , statRtsProfilingLib :: FilePath - , statRtsThreadedProfilingLib :: FilePath - } - -data RtsInfo = RtsInfo { - rtsDynamicInfo :: DynamicRtsInfo - , rtsStaticInfo :: StaticRtsInfo - , rtsLibPaths :: [FilePath] - } - --- | Extract (and compute) information about the RTS library --- --- TODO: This hardcodes the name as @HSrts-ghc@. I don't know if we can --- find this information somewhere. We can lookup the 'hsLibraries' field of --- 'InstalledPackageInfo' but it will tell us @["HSrts", "Cffi"]@, which --- doesn't really help. -extractRtsInfo :: LocalBuildInfo -> RtsInfo -extractRtsInfo lbi = - case PackageIndex.lookupPackageName (installedPkgs lbi) (mkPackageName "rts") of - [(_, [rts])] -> aux rts - _otherwise -> error "No (or multiple) ghc rts package is registered" - where - aux :: InstalledPackageInfo -> RtsInfo - aux rts = RtsInfo { - rtsDynamicInfo = DynamicRtsInfo { - dynRtsVanillaLib = withGhcVersion "HSrts" - , dynRtsThreadedLib = withGhcVersion "HSrts_thr" - , dynRtsDebugLib = withGhcVersion "HSrts_debug" - , dynRtsEventlogLib = withGhcVersion "HSrts_l" - , dynRtsThreadedDebugLib = withGhcVersion "HSrts_thr_debug" - , dynRtsThreadedEventlogLib = withGhcVersion "HSrts_thr_l" - } - , rtsStaticInfo = StaticRtsInfo { - statRtsVanillaLib = "HSrts" - , statRtsThreadedLib = "HSrts_thr" - , statRtsDebugLib = "HSrts_debug" - , statRtsEventlogLib = "HSrts_l" - , statRtsThreadedDebugLib = "HSrts_thr_debug" - , statRtsThreadedEventlogLib = "HSrts_thr_l" - , statRtsProfilingLib = "HSrts_p" - , statRtsThreadedProfilingLib = "HSrts_thr_p" - } - , rtsLibPaths = InstalledPackageInfo.libraryDirs rts - } - withGhcVersion = (++ ("-ghc" ++ prettyShow (compilerVersion (compiler lbi)))) - --- | Returns True if the modification date of the given source file is newer than --- the object file we last compiled for it, or if no object file exists yet. -checkNeedsRecompilation :: FilePath -> GhcOptions -> IO Bool -checkNeedsRecompilation filename opts = filename `moreRecentFile` oname - where oname = getObjectFileName filename opts - --- | Finds the object file name of the given source file -getObjectFileName :: FilePath -> GhcOptions -> FilePath -getObjectFileName filename opts = oname - where odir = fromFlag (ghcOptObjDir opts) - oext = fromFlagOrDefault "o" (ghcOptObjSuffix opts) - oname = odir replaceExtension filename oext - --- | Calculate the RPATHs for the component we are building. --- --- Calculates relative RPATHs when 'relocatable' is set. -getRPaths :: LocalBuildInfo - -> ComponentLocalBuildInfo -- ^ Component we are building - -> IO (NubListR FilePath) -getRPaths lbi clbi | supportRPaths hostOS = do - libraryPaths <- depLibraryPaths False (relocatable lbi) lbi clbi - let hostPref = case hostOS of - OSX -> "@loader_path" - _ -> "$ORIGIN" - relPath p = if isRelative p then hostPref p else p - rpaths = toNubListR (map relPath libraryPaths) - return rpaths - where - (Platform _ hostOS) = hostPlatform lbi - compid = compilerId . compiler $ lbi - - -- The list of RPath-supported operating systems below reflects the - -- platforms on which Cabal's RPATH handling is tested. It does _NOT_ - -- reflect whether the OS supports RPATH. - - -- E.g. when this comment was written, the *BSD operating systems were - -- untested with regards to Cabal RPATH handling, and were hence set to - -- 'False', while those operating systems themselves do support RPATH. - supportRPaths Linux   = True - supportRPaths Windows = False - supportRPaths OSX   = True - supportRPaths FreeBSD   = - case compid of - CompilerId GHC ver | ver >= mkVersion [7,10,2] -> True - _ -> False - supportRPaths OpenBSD   = False - supportRPaths NetBSD   = False - supportRPaths DragonFly = False - supportRPaths Solaris = False - supportRPaths AIX = False - supportRPaths HPUX = False - supportRPaths IRIX = False - supportRPaths HaLVM = False - supportRPaths IOS = False - supportRPaths Android = False - supportRPaths Ghcjs = False - supportRPaths Hurd = False - supportRPaths (OtherOS _) = False - -- Do _not_ add a default case so that we get a warning here when a new OS - -- is added. - -getRPaths _ _ = return mempty - --- | Remove the "-threaded" flag when building a foreign library, as it has no --- effect when used with "-shared". Returns the updated 'BuildInfo', along --- with whether or not the flag was present, so we can use it to link against --- the appropriate RTS on our own. -popThreadedFlag :: BuildInfo -> (BuildInfo, Bool) -popThreadedFlag bi = - ( bi { options = filterHcOptions (/= "-threaded") (options bi) } - , hasThreaded (options bi)) - - where - filterHcOptions :: (String -> Bool) - -> PerCompilerFlavor [String] - -> PerCompilerFlavor [String] - filterHcOptions p (PerCompilerFlavor ghc ghcjs) = - PerCompilerFlavor (filter p ghc) ghcjs - - hasThreaded :: PerCompilerFlavor [String] -> Bool - hasThreaded (PerCompilerFlavor ghc _) = elem "-threaded" ghc - --- | Extracts a String representing a hash of the ABI of a built --- library. It can fail if the library has not yet been built. --- -libAbiHash :: Verbosity -> PackageDescription -> LocalBuildInfo - -> Library -> ComponentLocalBuildInfo -> IO String -libAbiHash verbosity _pkg_descr lbi lib clbi = do - let - libBi = libBuildInfo lib - comp = compiler lbi - platform = hostPlatform lbi - vanillaArgs0 = - (componentGhcOptions verbosity lbi libBi clbi (componentBuildDir lbi clbi)) - `mappend` mempty { - ghcOptMode = toFlag GhcModeAbiHash, - ghcOptInputModules = toNubListR $ exposedModules lib - } - vanillaArgs = - -- Package DBs unnecessary, and break ghc-cabal. See #3633 - -- BUT, put at least the global database so that 7.4 doesn't - -- break. - vanillaArgs0 { ghcOptPackageDBs = [GlobalPackageDB] - , ghcOptPackages = mempty } - sharedArgs = vanillaArgs `mappend` mempty { - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptFPic = toFlag True, - ghcOptHiSuffix = toFlag "js_dyn_hi", - ghcOptObjSuffix = toFlag "js_dyn_o", - ghcOptExtra = hcSharedOptions GHC libBi - } - profArgs = vanillaArgs `mappend` mempty { - ghcOptProfilingMode = toFlag True, - ghcOptProfilingAuto = Internal.profDetailLevelFlag True - (withProfLibDetail lbi), - ghcOptHiSuffix = toFlag "js_p_hi", - ghcOptObjSuffix = toFlag "js_p_o", - ghcOptExtra = hcProfOptions GHC libBi - } - ghcArgs - | withVanillaLib lbi = vanillaArgs - | withSharedLib lbi = sharedArgs - | withProfLib lbi = profArgs - | otherwise = error "libAbiHash: Can't find an enabled library way" - - (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi) - hash <- getProgramInvocationOutput verbosity - (ghcInvocation ghcjsProg comp platform ghcArgs) - return (takeWhile (not . isSpace) hash) - -componentGhcOptions :: Verbosity -> LocalBuildInfo - -> BuildInfo -> ComponentLocalBuildInfo -> FilePath - -> GhcOptions -componentGhcOptions verbosity lbi bi clbi odir = - let opts = Internal.componentGhcOptions verbosity implInfo lbi bi clbi odir - comp = compiler lbi - implInfo = getImplInfo comp - in opts { ghcOptExtra = ghcOptExtra opts `mappend` hcOptions GHCJS bi - } - - -componentCcGhcOptions :: Verbosity -> LocalBuildInfo - -> BuildInfo -> ComponentLocalBuildInfo - -> FilePath -> FilePath - -> GhcOptions -componentCcGhcOptions verbosity lbi = - Internal.componentCcGhcOptions verbosity implInfo lbi - where - comp = compiler lbi - implInfo = getImplInfo comp - - --- ----------------------------------------------------------------------------- --- Installing - --- |Install executables for GHCJS. -installExe :: Verbosity - -> LocalBuildInfo - -> FilePath -- ^Where to copy the files to - -> FilePath -- ^Build location - -> (FilePath, FilePath) -- ^Executable (prefix,suffix) - -> PackageDescription - -> Executable - -> IO () -installExe verbosity lbi binDir buildPref - (progprefix, progsuffix) _pkg exe = do - createDirectoryIfMissingVerbose verbosity True binDir - let exeName' = unUnqualComponentName $ exeName exe - exeFileName = exeName' - fixedExeBaseName = progprefix ++ exeName' ++ progsuffix - installBinary dest = do - runDbProgram verbosity ghcjsProgram (withPrograms lbi) $ - [ "--install-executable" - , buildPref exeName' exeFileName - , "-o", dest - ] ++ - case (stripExes lbi, lookupProgram stripProgram $ withPrograms lbi) of - (True, Just strip) -> ["-strip-program", programPath strip] - _ -> [] - installBinary (binDir fixedExeBaseName) - - --- |Install foreign library for GHC. -installFLib :: Verbosity - -> LocalBuildInfo - -> FilePath -- ^install location - -> FilePath -- ^Build location - -> PackageDescription - -> ForeignLib - -> IO () -installFLib verbosity lbi targetDir builtDir _pkg flib = - install (foreignLibIsShared flib) - builtDir - targetDir - (flibTargetName lbi flib) - where - install _isShared srcDir dstDir name = do - let src = srcDir name - dst = dstDir name - createDirectoryIfMissingVerbose verbosity True targetDir - installOrdinaryFile verbosity src dst - - --- |Install for ghc, .hi, .a and, if --with-ghci given, .o -installLib :: Verbosity - -> LocalBuildInfo - -> FilePath -- ^install location - -> FilePath -- ^install location for dynamic libraries - -> FilePath -- ^Build location - -> PackageDescription - -> Library - -> ComponentLocalBuildInfo - -> IO () -installLib verbosity lbi targetDir dynlibTargetDir _builtDir _pkg lib clbi = do - whenVanilla $ copyModuleFiles "js_hi" - whenProf $ copyModuleFiles "js_p_hi" - whenShared $ copyModuleFiles "js_dyn_hi" - - -- whenVanilla $ installOrdinary builtDir targetDir $ toJSLibName vanillaLibName - -- whenProf $ installOrdinary builtDir targetDir $ toJSLibName profileLibName - -- whenShared $ installShared builtDir dynlibTargetDir $ toJSLibName sharedLibName - -- fixme do these make the correct lib names? - whenHasCode $ do - whenVanilla $ do - sequence_ [ installOrdinary builtDir' targetDir (toJSLibName $ mkGenericStaticLibName (l ++ f)) - | l <- getHSLibraryName (componentUnitId clbi):(extraBundledLibs (libBuildInfo lib)) - , f <- "":extraLibFlavours (libBuildInfo lib) - ] - -- whenGHCi $ installOrdinary builtDir targetDir (toJSLibName ghciLibName) - whenProf $ do - installOrdinary builtDir' targetDir (toJSLibName profileLibName) - -- whenGHCi $ installOrdinary builtDir targetDir (toJSLibName ghciProfLibName) - whenShared $ - sequence_ [ installShared builtDir' dynlibTargetDir - (toJSLibName $ mkGenericSharedLibName platform compiler_id (l ++ f)) - | l <- getHSLibraryName uid : extraBundledLibs (libBuildInfo lib) - , f <- "":extraDynLibFlavours (libBuildInfo lib) - ] - where - builtDir' = componentBuildDir lbi clbi - - install isShared isJS srcDir dstDir name = do - let src = srcDir name - dst = dstDir name - createDirectoryIfMissingVerbose verbosity True dstDir - - if isShared - then installExecutableFile verbosity src dst - else installOrdinaryFile verbosity src dst - - when (stripLibs lbi && not isJS) $ - Strip.stripLib verbosity - (hostPlatform lbi) (withPrograms lbi) dst - - installOrdinary = install False True - installShared = install True True - - copyModuleFiles ext = - findModuleFilesEx verbosity [builtDir'] [ext] (allLibModules lib clbi) - >>= installOrdinaryFiles verbosity targetDir - - compiler_id = compilerId (compiler lbi) - platform = hostPlatform lbi - uid = componentUnitId clbi - -- vanillaLibName = mkLibName uid - profileLibName = mkProfLibName uid - -- sharedLibName = (mkSharedLibName (hostPlatform lbi) compiler_id) uid - - hasLib = not $ null (allLibModules lib clbi) - && null (cSources (libBuildInfo lib)) - && null (cxxSources (libBuildInfo lib)) - && null (jsSources (libBuildInfo lib)) - has_code = not (componentIsIndefinite clbi) - whenHasCode = when has_code - whenVanilla = when (hasLib && withVanillaLib lbi) - whenProf = when (hasLib && withProfLib lbi && has_code) - -- whenGHCi = when (hasLib && withGHCiLib lbi && has_code) - whenShared = when (hasLib && withSharedLib lbi && has_code) - - -adjustExts :: String -> String -> GhcOptions -> GhcOptions -adjustExts hiSuf objSuf opts = - opts `mappend` mempty { - ghcOptHiSuffix = toFlag hiSuf, - ghcOptObjSuffix = toFlag objSuf - } - -isDynamic :: Compiler -> Bool -isDynamic = Internal.ghcLookupProperty "GHC Dynamic" - -supportsDynamicToo :: Compiler -> Bool -supportsDynamicToo = Internal.ghcLookupProperty "Support dynamic-too" - -withExt :: FilePath -> String -> FilePath -withExt fp ext = fp <.> if takeExtension fp /= ('.':ext) then ext else "" - -findGhcjsGhcVersion :: Verbosity -> FilePath -> IO (Maybe Version) -findGhcjsGhcVersion verbosity pgm = - findProgramVersion "--numeric-ghc-version" id verbosity pgm - -findGhcjsPkgGhcjsVersion :: Verbosity -> FilePath -> IO (Maybe Version) -findGhcjsPkgGhcjsVersion verbosity pgm = - findProgramVersion "--numeric-ghcjs-version" id verbosity pgm - --- ----------------------------------------------------------------------------- --- Registering - -hcPkgInfo :: ProgramDb -> HcPkg.HcPkgInfo -hcPkgInfo progdb = HcPkg.HcPkgInfo { HcPkg.hcPkgProgram = ghcjsPkgProg - , HcPkg.noPkgDbStack = False - , HcPkg.noVerboseFlag = False - , HcPkg.flagPackageConf = False - , HcPkg.supportsDirDbs = True - , HcPkg.requiresDirDbs = ver >= v7_10 - , HcPkg.nativeMultiInstance = ver >= v7_10 - , HcPkg.recacheMultiInstance = True - , HcPkg.suppressFilesCheck = True - } - where - v7_10 = mkVersion [7,10] - ghcjsPkgProg = fromMaybe (error "GHCJS.hcPkgInfo no ghcjs program") $ lookupProgram ghcjsPkgProgram progdb - ver = fromMaybe (error "GHCJS.hcPkgInfo no ghcjs version") $ programVersion ghcjsPkgProg - -registerPackage - :: Verbosity - -> ProgramDb - -> PackageDBStack - -> InstalledPackageInfo - -> HcPkg.RegisterOptions - -> IO () -registerPackage verbosity progdb packageDbs installedPkgInfo registerOptions = - HcPkg.register (hcPkgInfo progdb) verbosity packageDbs - installedPkgInfo registerOptions - -pkgRoot :: Verbosity -> LocalBuildInfo -> PackageDB -> IO FilePath -pkgRoot verbosity lbi = pkgRoot' - where - pkgRoot' GlobalPackageDB = - let ghcjsProg = fromMaybe (error "GHCJS.pkgRoot: no ghcjs program") $ lookupProgram ghcjsProgram (withPrograms lbi) - in fmap takeDirectory (getGlobalPackageDB verbosity ghcjsProg) - pkgRoot' UserPackageDB = do - appDir <- getAppUserDataDirectory "ghcjs" - -- fixme correct this version - let ver = compilerVersion (compiler lbi) - subdir = System.Info.arch ++ '-':System.Info.os - ++ '-':prettyShow ver - rootDir = appDir subdir - -- We must create the root directory for the user package database if it - -- does not yet exists. Otherwise '${pkgroot}' will resolve to a - -- directory at the time of 'ghc-pkg register', and registration will - -- fail. - createDirectoryIfMissing True rootDir - return rootDir - pkgRoot' (SpecificPackageDB fp) = return (takeDirectory fp) - - --- | Get the JavaScript file name and command and arguments to run a --- program compiled by GHCJS --- the exe should be the base program name without exe extension -runCmd :: ProgramDb -> FilePath - -> (FilePath, FilePath, [String]) -runCmd progdb exe = - ( script - , programPath ghcjsProg - , programDefaultArgs ghcjsProg ++ programOverrideArgs ghcjsProg ++ ["--run"] - ) - where - script = exe <.> "jsexe" "all" <.> "js" - ghcjsProg = fromMaybe (error "GHCJS.runCmd: no ghcjs program") $ lookupProgram ghcjsProgram progdb diff --git a/cabal/Cabal/Distribution/Simple/Glob.hs b/cabal/Cabal/Distribution/Simple/Glob.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/Glob.hs +++ /dev/null @@ -1,306 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Glob --- Copyright : Isaac Jones, Simon Marlow 2003-2004 --- License : BSD3 --- portions Copyright (c) 2007, Galois Inc. --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Simple file globbing. - -module Distribution.Simple.Glob ( - GlobSyntaxError(..), - GlobResult(..), - matchDirFileGlob, - runDirFileGlob, - fileGlobMatches, - parseFileGlob, - explainGlobSyntaxError, - Glob, - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.CabalSpecVersion -import Distribution.Simple.Utils -import Distribution.Verbosity - -import System.Directory (getDirectoryContents, doesDirectoryExist, doesFileExist) -import System.FilePath (joinPath, splitExtensions, splitDirectories, takeFileName, (), (<.>)) - -import qualified Data.List.NonEmpty as NE - --- Note throughout that we use splitDirectories, not splitPath. On --- Posix, this makes no difference, but, because Windows accepts both --- slash and backslash as its path separators, if we left in the --- separators from the glob we might not end up properly normalised. - -data GlobResult a - = GlobMatch a - -- ^ The glob matched the value supplied. - | GlobWarnMultiDot a - -- ^ The glob did not match the value supplied because the - -- cabal-version is too low and the extensions on the file did - -- not precisely match the glob's extensions, but rather the - -- glob was a proper suffix of the file's extensions; i.e., if - -- not for the low cabal-version, it would have matched. - | GlobMissingDirectory FilePath - -- ^ The glob couldn't match because the directory named doesn't - -- exist. The directory will be as it appears in the glob (i.e., - -- relative to the directory passed to 'matchDirFileGlob', and, - -- for 'data-files', relative to 'data-dir'). - deriving (Show, Eq, Ord, Functor) - --- | Extract the matches from a list of 'GlobResult's. --- --- Note: throws away the 'GlobMissingDirectory' results; chances are --- that you want to check for these and error out if any are present. -globMatches :: [GlobResult a] -> [a] -globMatches input = [ a | GlobMatch a <- input ] - -data GlobSyntaxError - = StarInDirectory - | StarInFileName - | StarInExtension - | NoExtensionOnStar - | EmptyGlob - | LiteralFileNameGlobStar - | VersionDoesNotSupportGlobStar - | VersionDoesNotSupportGlob - deriving (Eq, Show) - -explainGlobSyntaxError :: FilePath -> GlobSyntaxError -> String -explainGlobSyntaxError filepath StarInDirectory = - "invalid file glob '" ++ filepath - ++ "'. A wildcard '**' is only allowed as the final parent" - ++ " directory. Stars must not otherwise appear in the parent" - ++ " directories." -explainGlobSyntaxError filepath StarInExtension = - "invalid file glob '" ++ filepath - ++ "'. Wildcards '*' are only allowed as the" - ++ " file's base name, not in the file extension." -explainGlobSyntaxError filepath StarInFileName = - "invalid file glob '" ++ filepath - ++ "'. Wildcards '*' may only totally replace the" - ++ " file's base name, not only parts of it." -explainGlobSyntaxError filepath NoExtensionOnStar = - "invalid file glob '" ++ filepath - ++ "'. If a wildcard '*' is used it must be with an file extension." -explainGlobSyntaxError filepath LiteralFileNameGlobStar = - "invalid file glob '" ++ filepath - ++ "'. If a wildcard '**' is used as a parent directory, the" - ++ " file's base name must be a wildcard '*'." -explainGlobSyntaxError _ EmptyGlob = - "invalid file glob. A glob cannot be the empty string." -explainGlobSyntaxError filepath VersionDoesNotSupportGlobStar = - "invalid file glob '" ++ filepath - ++ "'. Using the double-star syntax requires 'cabal-version: 2.4'" - ++ " or greater. Alternatively, for compatibility with earlier Cabal" - ++ " versions, list the included directories explicitly." -explainGlobSyntaxError filepath VersionDoesNotSupportGlob = - "invalid file glob '" ++ filepath - ++ "'. Using star wildcards requires 'cabal-version: >= 1.6'. " - ++ "Alternatively if you require compatibility with earlier Cabal " - ++ "versions then list all the files explicitly." - -data IsRecursive = Recursive | NonRecursive - -data MultiDot = MultiDotDisabled | MultiDotEnabled - -data Glob - = GlobStem FilePath Glob - -- ^ A single subdirectory component + remainder. - | GlobFinal GlobFinal - -data GlobFinal - = FinalMatch IsRecursive MultiDot String - -- ^ First argument: Is this a @**/*.ext@ pattern? - -- Second argument: should we match against the exact extensions, or accept a suffix? - -- Third argument: the extensions to accept. - | FinalLit FilePath - -- ^ Literal file name. - -reconstructGlob :: Glob -> FilePath -reconstructGlob (GlobStem dir glob) = - dir reconstructGlob glob -reconstructGlob (GlobFinal final) = case final of - FinalMatch Recursive _ exts -> "**" "*" <.> exts - FinalMatch NonRecursive _ exts -> "*" <.> exts - FinalLit path -> path - --- | Returns 'Nothing' if the glob didn't match at all, or 'Just' the --- result if the glob matched (or would have matched with a higher --- cabal-version). -fileGlobMatches :: Glob -> FilePath -> Maybe (GlobResult FilePath) -fileGlobMatches pat candidate = do - match <- fileGlobMatchesSegments pat (splitDirectories candidate) - return (candidate <$ match) - -fileGlobMatchesSegments :: Glob -> [FilePath] -> Maybe (GlobResult ()) -fileGlobMatchesSegments _ [] = Nothing -fileGlobMatchesSegments pat (seg : segs) = case pat of - GlobStem dir pat' -> do - guard (dir == seg) - fileGlobMatchesSegments pat' segs - GlobFinal final -> case final of - FinalMatch Recursive multidot ext -> do - let (candidateBase, candidateExts) = splitExtensions (NE.last $ seg:|segs) - guard (not (null candidateBase)) - checkExt multidot ext candidateExts - FinalMatch NonRecursive multidot ext -> do - let (candidateBase, candidateExts) = splitExtensions seg - guard (null segs && not (null candidateBase)) - checkExt multidot ext candidateExts - FinalLit filename -> do - guard (null segs && filename == seg) - return (GlobMatch ()) - -checkExt - :: MultiDot - -> String -- ^ The pattern's extension - -> String -- ^ The candidate file's extension - -> Maybe (GlobResult ()) -checkExt multidot ext candidate - | ext == candidate = Just (GlobMatch ()) - | ext `isSuffixOf` candidate = case multidot of - MultiDotDisabled -> Just (GlobWarnMultiDot ()) - MultiDotEnabled -> Just (GlobMatch ()) - | otherwise = Nothing - -parseFileGlob :: CabalSpecVersion -> FilePath -> Either GlobSyntaxError Glob -parseFileGlob version filepath = case reverse (splitDirectories filepath) of - [] -> - Left EmptyGlob - (filename : "**" : segments) - | allowGlobStar -> do - ext <- case splitExtensions filename of - ("*", ext) | '*' `elem` ext -> Left StarInExtension - | null ext -> Left NoExtensionOnStar - | otherwise -> Right ext - _ -> Left LiteralFileNameGlobStar - foldM addStem (GlobFinal $ FinalMatch Recursive multidot ext) segments - | otherwise -> Left VersionDoesNotSupportGlobStar - (filename : segments) -> do - pat <- case splitExtensions filename of - ("*", ext) | not allowGlob -> Left VersionDoesNotSupportGlob - | '*' `elem` ext -> Left StarInExtension - | null ext -> Left NoExtensionOnStar - | otherwise -> Right (FinalMatch NonRecursive multidot ext) - (_, ext) | '*' `elem` ext -> Left StarInExtension - | '*' `elem` filename -> Left StarInFileName - | otherwise -> Right (FinalLit filename) - foldM addStem (GlobFinal pat) segments - where - allowGlob = version >= CabalSpecV1_6 - allowGlobStar = version >= CabalSpecV2_4 - addStem pat seg - | '*' `elem` seg = Left StarInDirectory - | otherwise = Right (GlobStem seg pat) - multidot - | version >= CabalSpecV2_4 = MultiDotEnabled - | otherwise = MultiDotDisabled - --- | This will 'die'' when the glob matches no files, or if the glob --- refers to a missing directory, or if the glob fails to parse. --- --- The 'Version' argument must be the spec version of the package --- description being processed, as globs behave slightly differently --- in different spec versions. --- --- The first 'FilePath' argument is the directory that the glob is --- relative to. It must be a valid directory (and hence it can't be --- the empty string). The returned values will not include this --- prefix. --- --- The second 'FilePath' is the glob itself. -matchDirFileGlob :: Verbosity -> CabalSpecVersion -> FilePath -> FilePath -> IO [FilePath] -matchDirFileGlob verbosity version dir filepath = case parseFileGlob version filepath of - Left err -> die' verbosity $ explainGlobSyntaxError filepath err - Right glob -> do - results <- runDirFileGlob verbosity dir glob - let missingDirectories = - [ missingDir | GlobMissingDirectory missingDir <- results ] - matches = globMatches results - -- Check for missing directories first, since we'll obviously have - -- no matches in that case. - for_ missingDirectories $ \ missingDir -> - die' verbosity $ - "filepath wildcard '" ++ filepath ++ "' refers to the directory" - ++ " '" ++ missingDir ++ "', which does not exist or is not a directory." - when (null matches) $ die' verbosity $ - "filepath wildcard '" ++ filepath - ++ "' does not match any files." - return matches - --- | Match files against a pre-parsed glob, starting in a directory. --- --- The 'Version' argument must be the spec version of the package --- description being processed, as globs behave slightly differently --- in different spec versions. --- --- The 'FilePath' argument is the directory that the glob is relative --- to. It must be a valid directory (and hence it can't be the empty --- string). The returned values will not include this prefix. -runDirFileGlob :: Verbosity -> FilePath -> Glob -> IO [GlobResult FilePath] -runDirFileGlob verbosity rawDir pat = do - -- The default data-dir is null. Our callers -should- be - -- converting that to '.' themselves, but it's a certainty that - -- some future call-site will forget and trigger a really - -- hard-to-debug failure if we don't check for that here. - when (null rawDir) $ - warn verbosity $ - "Null dir passed to runDirFileGlob; interpreting it " - ++ "as '.'. This is probably an internal error." - let dir = if null rawDir then "." else rawDir - debug verbosity $ "Expanding glob '" ++ reconstructGlob pat ++ "' in directory '" ++ dir ++ "'." - -- This function might be called from the project root with dir as - -- ".". Walking the tree starting there involves going into .git/ - -- and dist-newstyle/, which is a lot of work for no reward, so - -- extract the constant prefix from the pattern and start walking - -- there, and only walk as much as we need to: recursively if **, - -- the whole directory if *, and just the specific file if it's a - -- literal. - let (prefixSegments, final) = splitConstantPrefix pat - joinedPrefix = joinPath prefixSegments - case final of - FinalMatch recursive multidot exts -> do - let prefix = dir joinedPrefix - directoryExists <- doesDirectoryExist prefix - if directoryExists - then do - candidates <- case recursive of - Recursive -> getDirectoryContentsRecursive prefix - NonRecursive -> filterM (doesFileExist . (prefix )) =<< getDirectoryContents prefix - let checkName candidate = do - let (candidateBase, candidateExts) = splitExtensions $ takeFileName candidate - guard (not (null candidateBase)) - match <- checkExt multidot exts candidateExts - return (joinedPrefix candidate <$ match) - return $ mapMaybe checkName candidates - else - return [ GlobMissingDirectory joinedPrefix ] - FinalLit fn -> do - exists <- doesFileExist (dir joinedPrefix fn) - return [ GlobMatch (joinedPrefix fn) | exists ] - -unfoldr' :: (a -> Either r (b, a)) -> a -> ([b], r) -unfoldr' f a = case f a of - Left r -> ([], r) - Right (b, a') -> case unfoldr' f a' of - (bs, r) -> (b : bs, r) - --- | Extract the (possibly null) constant prefix from the pattern. --- This has the property that, if @(pref, final) = splitConstantPrefix pat@, --- then @pat === foldr GlobStem (GlobFinal final) pref@. -splitConstantPrefix :: Glob -> ([FilePath], GlobFinal) -splitConstantPrefix = unfoldr' step - where - step (GlobStem seg pat) = Right (seg, pat) - step (GlobFinal pat) = Left pat diff --git a/cabal/Cabal/Distribution/Simple/Haddock.hs b/cabal/Cabal/Distribution/Simple/Haddock.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/Haddock.hs +++ /dev/null @@ -1,926 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Haddock --- Copyright : Isaac Jones 2003-2005 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This module deals with the @haddock@ and @hscolour@ commands. --- It uses information about installed packages (from @ghc-pkg@) to find the --- locations of documentation for dependent packages, so it can create links. --- --- The @hscolour@ support allows generating HTML versions of the original --- source, with coloured syntax highlighting. - -module Distribution.Simple.Haddock ( - haddock, hscolour, - - haddockPackagePaths - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import qualified Distribution.Simple.GHC as GHC -import qualified Distribution.Simple.GHCJS as GHCJS - --- local -import Distribution.Backpack.DescribeUnitId -import Distribution.Backpack (OpenModule) -import Distribution.Types.ForeignLib -import Distribution.Types.UnqualComponentName -import Distribution.Types.ComponentLocalBuildInfo -import Distribution.Types.ExecutableScope -import Distribution.Types.LocalBuildInfo -import Distribution.Types.TargetInfo -import Distribution.Types.ExposedModule -import Distribution.Package -import qualified Distribution.ModuleName as ModuleName -import Distribution.PackageDescription -import Distribution.Simple.Compiler -import Distribution.Simple.Glob -import Distribution.Simple.Program.GHC -import Distribution.Simple.Program.ResponseFile -import Distribution.Simple.Program -import Distribution.Simple.PreProcess -import Distribution.Simple.Setup -import Distribution.Simple.Build -import Distribution.Simple.BuildTarget -import Distribution.Simple.InstallDirs -import Distribution.Simple.LocalBuildInfo hiding (substPathTemplate) -import Distribution.Simple.BuildPaths -import Distribution.Simple.Register -import qualified Distribution.Simple.Program.HcPkg as HcPkg -import qualified Distribution.Simple.PackageIndex as PackageIndex -import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo -import Distribution.InstalledPackageInfo ( InstalledPackageInfo ) -import Distribution.Simple.Utils -import Distribution.System -import Distribution.Pretty -import Distribution.Parsec (simpleParsec) -import Distribution.Utils.NubList -import Distribution.Version -import qualified Distribution.Utils.ShortText as ShortText - -import Distribution.Verbosity -import Language.Haskell.Extension - -import Distribution.Compat.Semigroup (All (..), Any (..)) - -import Control.Monad -import Data.Either ( rights ) - -import System.Directory (getCurrentDirectory, doesDirectoryExist, doesFileExist) -import System.FilePath ( (), (<.>), normalise, isAbsolute ) -import System.IO (hClose, hPutStrLn, hSetEncoding, utf8) - --- ------------------------------------------------------------------------------ --- Types - --- | A record that represents the arguments to the haddock executable, a product --- monoid. -data HaddockArgs = HaddockArgs { - argInterfaceFile :: Flag FilePath, - -- ^ Path to the interface file, relative to argOutputDir, required. - argPackageName :: Flag PackageIdentifier, - -- ^ Package name, required. - argHideModules :: (All,[ModuleName.ModuleName]), - -- ^ (Hide modules ?, modules to hide) - argIgnoreExports :: Any, - -- ^ Ignore export lists in modules? - argLinkSource :: Flag (Template,Template,Template), - -- ^ (Template for modules, template for symbols, template for lines). - argLinkedSource :: Flag Bool, - -- ^ Generate hyperlinked sources - argQuickJump :: Flag Bool, - -- ^ Generate quickjump index - argCssFile :: Flag FilePath, - -- ^ Optional custom CSS file. - argContents :: Flag String, - -- ^ Optional URL to contents page. - argVerbose :: Any, - argOutput :: Flag [Output], - -- ^ HTML or Hoogle doc or both? Required. - argInterfaces :: [(FilePath, Maybe String, Maybe String)], - -- ^ [(Interface file, URL to the HTML docs and hyperlinked-source for links)]. - argOutputDir :: Directory, - -- ^ Where to generate the documentation. - argTitle :: Flag String, - -- ^ Page title, required. - argPrologue :: Flag String, - -- ^ Prologue text, required. - argGhcOptions :: GhcOptions, - -- ^ Additional flags to pass to GHC. - argGhcLibDir :: Flag FilePath, - -- ^ To find the correct GHC, required. - argReexports :: [OpenModule], - -- ^ Re-exported modules - argTargets :: [FilePath] - -- ^ Modules to process. -} deriving Generic - --- | The FilePath of a directory, it's a monoid under '()'. -newtype Directory = Dir { unDir' :: FilePath } deriving (Read,Show,Eq,Ord) - -unDir :: Directory -> FilePath -unDir = normalise . unDir' - -type Template = String - -data Output = Html | Hoogle - --- ------------------------------------------------------------------------------ --- Haddock support - -haddock :: PackageDescription - -> LocalBuildInfo - -> [PPSuffixHandler] - -> HaddockFlags - -> IO () -haddock pkg_descr _ _ haddockFlags - | not (hasLibs pkg_descr) - && not (fromFlag $ haddockExecutables haddockFlags) - && not (fromFlag $ haddockTestSuites haddockFlags) - && not (fromFlag $ haddockBenchmarks haddockFlags) - && not (fromFlag $ haddockForeignLibs haddockFlags) - = - warn (fromFlag $ haddockVerbosity haddockFlags) $ - "No documentation was generated as this package does not contain " - ++ "a library. Perhaps you want to use the --executables, --tests," - ++ " --benchmarks or --foreign-libraries flags." - -haddock pkg_descr lbi suffixes flags' = do - let verbosity = flag haddockVerbosity - comp = compiler lbi - platform = hostPlatform lbi - - quickJmpFlag = haddockQuickJump flags' - flags = case haddockTarget of - ForDevelopment -> flags' - ForHackage -> flags' - { haddockHoogle = Flag True - , haddockHtml = Flag True - , haddockHtmlLocation = Flag (pkg_url ++ "/docs") - , haddockContents = Flag (toPathTemplate pkg_url) - , haddockLinkedSource = Flag True - , haddockQuickJump = Flag True - } - pkg_url = "/package/$pkg-$version" - flag f = fromFlag $ f flags - - tmpFileOpts = defaultTempFileOptions - { optKeepTempFiles = flag haddockKeepTempFiles } - htmlTemplate = fmap toPathTemplate . flagToMaybe . haddockHtmlLocation - $ flags - haddockTarget = - fromFlagOrDefault ForDevelopment (haddockForHackage flags') - - (haddockProg, version, _) <- - requireProgramVersion verbosity haddockProgram - (orLaterVersion (mkVersion [2,0])) (withPrograms lbi) - - -- various sanity checks - when (flag haddockHoogle && version < mkVersion [2,2]) $ - die' verbosity "Haddock 2.0 and 2.1 do not support the --hoogle flag." - - - when (flag haddockQuickJump && version < mkVersion [2,19]) $ do - let msg = "Haddock prior to 2.19 does not support the --quickjump flag." - alt = "The generated documentation won't have the QuickJump feature." - if Flag True == quickJmpFlag - then die' verbosity msg - else warn verbosity (msg ++ "\n" ++ alt) - - haddockGhcVersionStr <- getProgramOutput verbosity haddockProg - ["--ghc-version"] - case (simpleParsec haddockGhcVersionStr, compilerCompatVersion GHC comp) of - (Nothing, _) -> die' verbosity "Could not get GHC version from Haddock" - (_, Nothing) -> die' verbosity "Could not get GHC version from compiler" - (Just haddockGhcVersion, Just ghcVersion) - | haddockGhcVersion == ghcVersion -> return () - | otherwise -> die' verbosity $ - "Haddock's internal GHC version must match the configured " - ++ "GHC version.\n" - ++ "The GHC version is " ++ prettyShow ghcVersion ++ " but " - ++ "haddock is using GHC version " ++ prettyShow haddockGhcVersion - - -- the tools match the requests, we can proceed - - -- We fall back to using HsColour only for versions of Haddock which don't - -- support '--hyperlinked-sources'. - when (flag haddockLinkedSource && version < mkVersion [2,17]) $ - hscolour' (warn verbosity) haddockTarget pkg_descr lbi suffixes - (defaultHscolourFlags `mappend` haddockToHscolour flags) - - libdirArgs <- getGhcLibDir verbosity lbi - let commonArgs = mconcat - [ libdirArgs - , fromFlags (haddockTemplateEnv lbi (packageId pkg_descr)) flags - , fromPackageDescription haddockTarget pkg_descr ] - - targets <- readTargetInfos verbosity pkg_descr lbi (haddockArgs flags) - - let - targets' = - case targets of - [] -> allTargetsInBuildOrder' pkg_descr lbi - _ -> targets - - internalPackageDB <- - createInternalPackageDB verbosity lbi (flag haddockDistPref) - - (\f -> foldM_ f (installedPkgs lbi) targets') $ \index target -> do - - let component = targetComponent target - clbi = targetCLBI target - - componentInitialBuildSteps (flag haddockDistPref) pkg_descr lbi clbi verbosity - - let - lbi' = lbi { - withPackageDB = withPackageDB lbi ++ [internalPackageDB], - installedPkgs = index - } - - preprocessComponent pkg_descr component lbi' clbi False verbosity suffixes - let - doExe com = case (compToExe com) of - Just exe -> do - withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi') "tmp" $ - \tmp -> do - exeArgs <- fromExecutable verbosity tmp lbi' clbi htmlTemplate - version exe - let exeArgs' = commonArgs `mappend` exeArgs - runHaddock verbosity tmpFileOpts comp platform - haddockProg exeArgs' - Nothing -> do - warn (fromFlag $ haddockVerbosity flags) - "Unsupported component, skipping..." - return () - -- We define 'smsg' once and then reuse it inside the case, so that - -- we don't say we are running Haddock when we actually aren't - -- (e.g., Haddock is not run on non-libraries) - smsg :: IO () - smsg = setupMessage' verbosity "Running Haddock on" (packageId pkg_descr) - (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) - case component of - CLib lib -> do - withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $ - \tmp -> do - smsg - libArgs <- fromLibrary verbosity tmp lbi' clbi htmlTemplate - version lib - let libArgs' = commonArgs `mappend` libArgs - runHaddock verbosity tmpFileOpts comp platform haddockProg libArgs' - - case libName lib of - LMainLibName -> - pure index - LSubLibName _ -> do - pwd <- getCurrentDirectory - - let - ipi = inplaceInstalledPackageInfo - pwd (flag haddockDistPref) pkg_descr - (mkAbiHash "inplace") lib lbi' clbi - - debug verbosity $ "Registering inplace:\n" - ++ (InstalledPackageInfo.showInstalledPackageInfo ipi) - - registerPackage verbosity (compiler lbi') (withPrograms lbi') - (withPackageDB lbi') ipi - HcPkg.defaultRegisterOptions { - HcPkg.registerMultiInstance = True - } - - return $ PackageIndex.insert ipi index - - CFLib flib -> (when (flag haddockForeignLibs) $ do - withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi') "tmp" $ - \tmp -> do - smsg - flibArgs <- fromForeignLib verbosity tmp lbi' clbi htmlTemplate - version flib - let libArgs' = commonArgs `mappend` flibArgs - runHaddock verbosity tmpFileOpts comp platform haddockProg libArgs') - - >> return index - - CExe _ -> (when (flag haddockExecutables) $ smsg >> doExe component) >> return index - CTest _ -> (when (flag haddockTestSuites) $ smsg >> doExe component) >> return index - CBench _ -> (when (flag haddockBenchmarks) $ smsg >> doExe component) >> return index - - for_ (extraDocFiles pkg_descr) $ \ fpath -> do - files <- matchDirFileGlob verbosity (specVersion pkg_descr) "." fpath - for_ files $ copyFileTo verbosity (unDir $ argOutputDir commonArgs) - --- ------------------------------------------------------------------------------ --- Contributions to HaddockArgs (see also Doctest.hs for very similar code). - -fromFlags :: PathTemplateEnv -> HaddockFlags -> HaddockArgs -fromFlags env flags = - mempty { - argHideModules = (maybe mempty (All . not) - $ flagToMaybe (haddockInternal flags), mempty), - argLinkSource = if fromFlag (haddockLinkedSource flags) - then Flag ("src/%{MODULE/./-}.html" - ,"src/%{MODULE/./-}.html#%{NAME}" - ,"src/%{MODULE/./-}.html#line-%{LINE}") - else NoFlag, - argLinkedSource = haddockLinkedSource flags, - argQuickJump = haddockQuickJump flags, - argCssFile = haddockCss flags, - argContents = fmap (fromPathTemplate . substPathTemplate env) - (haddockContents flags), - argVerbose = maybe mempty (Any . (>= deafening)) - . flagToMaybe $ haddockVerbosity flags, - argOutput = - Flag $ case [ Html | Flag True <- [haddockHtml flags] ] ++ - [ Hoogle | Flag True <- [haddockHoogle flags] ] - of [] -> [ Html ] - os -> os, - argOutputDir = maybe mempty Dir . flagToMaybe $ haddockDistPref flags, - - argGhcOptions = mempty { ghcOptExtra = ghcArgs } - } - where - ghcArgs = fromMaybe [] . lookup "ghc" . haddockProgramArgs $ flags - -fromPackageDescription :: HaddockTarget -> PackageDescription -> HaddockArgs -fromPackageDescription haddockTarget pkg_descr = mempty - { argInterfaceFile = Flag $ haddockName pkg_descr - , argPackageName = Flag $ packageId $ pkg_descr - , argOutputDir = Dir $ - "doc" "html" haddockDirName haddockTarget pkg_descr - , argPrologue = Flag $ ShortText.fromShortText $ - if ShortText.null desc - then synopsis pkg_descr - else desc - , argTitle = Flag $ showPkg ++ subtitle - } - where - desc = description pkg_descr - showPkg = prettyShow (packageId pkg_descr) - subtitle - | ShortText.null (synopsis pkg_descr) = "" - | otherwise = ": " ++ ShortText.fromShortText (synopsis pkg_descr) - -componentGhcOptions :: Verbosity -> LocalBuildInfo - -> BuildInfo -> ComponentLocalBuildInfo -> FilePath - -> GhcOptions -componentGhcOptions verbosity lbi bi clbi odir = - let f = case compilerFlavor (compiler lbi) of - GHC -> GHC.componentGhcOptions - GHCJS -> GHCJS.componentGhcOptions - _ -> error $ - "Distribution.Simple.Haddock.componentGhcOptions:" ++ - "haddock only supports GHC and GHCJS" - in f verbosity lbi bi clbi odir - -mkHaddockArgs :: Verbosity - -> FilePath - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> Maybe PathTemplate -- ^ template for HTML location - -> Version - -> [FilePath] - -> BuildInfo - -> IO HaddockArgs -mkHaddockArgs verbosity tmp lbi clbi htmlTemplate haddockVersion inFiles bi = do - ifaceArgs <- getInterfaces verbosity lbi clbi htmlTemplate - let vanillaOpts = (componentGhcOptions normal lbi bi clbi (buildDir lbi)) { - -- Noooooooooo!!!!!111 - -- haddock stomps on our precious .hi - -- and .o files. Workaround by telling - -- haddock to write them elsewhere. - ghcOptObjDir = toFlag tmp, - ghcOptHiDir = toFlag tmp, - ghcOptStubDir = toFlag tmp - } `mappend` getGhcCppOpts haddockVersion bi - sharedOpts = vanillaOpts { - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptFPic = toFlag True, - ghcOptHiSuffix = toFlag "dyn_hi", - ghcOptObjSuffix = toFlag "dyn_o", - ghcOptExtra = hcSharedOptions GHC bi - - } - opts <- if withVanillaLib lbi - then return vanillaOpts - else if withSharedLib lbi - then return sharedOpts - else die' verbosity $ "Must have vanilla or shared libraries " - ++ "enabled in order to run haddock" - - return ifaceArgs - { argGhcOptions = opts - , argTargets = inFiles - , argReexports = getReexports clbi - } - -fromLibrary :: Verbosity - -> FilePath - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> Maybe PathTemplate -- ^ template for HTML location - -> Version - -> Library - -> IO HaddockArgs -fromLibrary verbosity tmp lbi clbi htmlTemplate haddockVersion lib = do - inFiles <- map snd `fmap` getLibSourceFiles verbosity lbi lib clbi - args <- mkHaddockArgs verbosity tmp lbi clbi htmlTemplate haddockVersion - inFiles (libBuildInfo lib) - return args { - argHideModules = (mempty, otherModules (libBuildInfo lib)) - } - -fromExecutable :: Verbosity - -> FilePath - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> Maybe PathTemplate -- ^ template for HTML location - -> Version - -> Executable - -> IO HaddockArgs -fromExecutable verbosity tmp lbi clbi htmlTemplate haddockVersion exe = do - inFiles <- map snd `fmap` getExeSourceFiles verbosity lbi exe clbi - args <- mkHaddockArgs verbosity tmp lbi clbi htmlTemplate - haddockVersion inFiles (buildInfo exe) - return args { - argOutputDir = Dir $ unUnqualComponentName $ exeName exe, - argTitle = Flag $ unUnqualComponentName $ exeName exe - } - -fromForeignLib :: Verbosity - -> FilePath - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> Maybe PathTemplate -- ^ template for HTML location - -> Version - -> ForeignLib - -> IO HaddockArgs -fromForeignLib verbosity tmp lbi clbi htmlTemplate haddockVersion flib = do - inFiles <- map snd `fmap` getFLibSourceFiles verbosity lbi flib clbi - args <- mkHaddockArgs verbosity tmp lbi clbi htmlTemplate - haddockVersion inFiles (foreignLibBuildInfo flib) - return args { - argOutputDir = Dir $ unUnqualComponentName $ foreignLibName flib, - argTitle = Flag $ unUnqualComponentName $ foreignLibName flib - } - -compToExe :: Component -> Maybe Executable -compToExe comp = - case comp of - CTest test@TestSuite { testInterface = TestSuiteExeV10 _ f } -> - Just Executable { - exeName = testName test, - modulePath = f, - exeScope = ExecutablePublic, - buildInfo = testBuildInfo test - } - CBench bench@Benchmark { benchmarkInterface = BenchmarkExeV10 _ f } -> - Just Executable { - exeName = benchmarkName bench, - modulePath = f, - exeScope = ExecutablePublic, - buildInfo = benchmarkBuildInfo bench - } - CExe exe -> Just exe - _ -> Nothing - -getInterfaces :: Verbosity - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> Maybe PathTemplate -- ^ template for HTML location - -> IO HaddockArgs -getInterfaces verbosity lbi clbi htmlTemplate = do - (packageFlags, warnings) <- haddockPackageFlags verbosity lbi clbi htmlTemplate - traverse_ (warn (verboseUnmarkOutput verbosity)) warnings - return $ mempty { - argInterfaces = packageFlags - } - -getReexports :: ComponentLocalBuildInfo -> [OpenModule] -getReexports LibComponentLocalBuildInfo {componentExposedModules = mods } = - mapMaybe exposedReexport mods -getReexports _ = [] - -getGhcCppOpts :: Version - -> BuildInfo - -> GhcOptions -getGhcCppOpts haddockVersion bi = - mempty { - ghcOptExtensions = toNubListR [EnableExtension CPP | needsCpp], - ghcOptCppOptions = defines - } - where - needsCpp = EnableExtension CPP `elem` usedExtensions bi - defines = [haddockVersionMacro] - haddockVersionMacro = "-D__HADDOCK_VERSION__=" - ++ show (v1 * 1000 + v2 * 10 + v3) - where - (v1, v2, v3) = case versionNumbers haddockVersion of - [] -> (0,0,0) - [x] -> (x,0,0) - [x,y] -> (x,y,0) - (x:y:z:_) -> (x,y,z) - -getGhcLibDir :: Verbosity -> LocalBuildInfo - -> IO HaddockArgs -getGhcLibDir verbosity lbi = do - l <- case compilerFlavor (compiler lbi) of - GHC -> GHC.getLibDir verbosity lbi - GHCJS -> GHCJS.getLibDir verbosity lbi - _ -> error "haddock only supports GHC and GHCJS" - return $ mempty { argGhcLibDir = Flag l } - --- ------------------------------------------------------------------------------ --- | Call haddock with the specified arguments. -runHaddock :: Verbosity - -> TempFileOptions - -> Compiler - -> Platform - -> ConfiguredProgram - -> HaddockArgs - -> IO () -runHaddock verbosity tmpFileOpts comp platform haddockProg args - | null (argTargets args) = warn verbosity $ - "Haddocks are being requested, but there aren't any modules given " - ++ "to create documentation for." - | otherwise = do - let haddockVersion = fromMaybe (error "unable to determine haddock version") - (programVersion haddockProg) - renderArgs verbosity tmpFileOpts haddockVersion comp platform args $ - \(flags,result)-> do - - runProgram verbosity haddockProg flags - - notice verbosity $ "Documentation created: " ++ result - - -renderArgs :: Verbosity - -> TempFileOptions - -> Version - -> Compiler - -> Platform - -> HaddockArgs - -> (([String], FilePath) -> IO a) - -> IO a -renderArgs verbosity tmpFileOpts version comp platform args k = do - let haddockSupportsUTF8 = version >= mkVersion [2,14,4] - haddockSupportsResponseFiles = version > mkVersion [2,16,2] - createDirectoryIfMissingVerbose verbosity True outputDir - withTempFileEx tmpFileOpts outputDir "haddock-prologue.txt" $ - \prologueFileName h -> do - do - when haddockSupportsUTF8 (hSetEncoding h utf8) - hPutStrLn h $ fromFlag $ argPrologue args - hClose h - let pflag = "--prologue=" ++ prologueFileName - renderedArgs = pflag : renderPureArgs version comp platform args - if haddockSupportsResponseFiles - then - withResponseFile - verbosity - tmpFileOpts - outputDir - "haddock-response.txt" - (if haddockSupportsUTF8 then Just utf8 else Nothing) - renderedArgs - (\responseFileName -> k (["@" ++ responseFileName], result)) - else - k (renderedArgs, result) - where - outputDir = (unDir $ argOutputDir args) - result = intercalate ", " - . map (\o -> outputDir - case o of - Html -> "index.html" - Hoogle -> pkgstr <.> "txt") - $ arg argOutput - where - pkgstr = prettyShow $ packageName pkgid - pkgid = arg argPackageName - arg f = fromFlag $ f args - -renderPureArgs :: Version -> Compiler -> Platform -> HaddockArgs -> [String] -renderPureArgs version comp platform args = concat - [ (:[]) . (\f -> "--dump-interface="++ unDir (argOutputDir args) f) - . fromFlag . argInterfaceFile $ args - - , if isVersion 2 16 - then (\pkg -> [ "--package-name=" ++ prettyShow (pkgName pkg) - , "--package-version=" ++ prettyShow (pkgVersion pkg) - ]) - . fromFlag . argPackageName $ args - else [] - - , [ "--since-qual=external" | isVersion 2 20 ] - - , [ "--quickjump" | isVersion 2 19 - , fromFlag . argQuickJump $ args ] - - , [ "--hyperlinked-source" | isVersion 2 17 - , fromFlag . argLinkedSource $ args ] - - , (\(All b,xs) -> bool (map (("--hide=" ++) . prettyShow) xs) [] b) - . argHideModules $ args - - , bool ["--ignore-all-exports"] [] . getAny . argIgnoreExports $ args - - , maybe [] (\(m,e,l) -> - ["--source-module=" ++ m - ,"--source-entity=" ++ e] - ++ if isVersion 2 14 then ["--source-entity-line=" ++ l] - else [] - ) . flagToMaybe . argLinkSource $ args - - , maybe [] ((:[]) . ("--css="++)) . flagToMaybe . argCssFile $ args - - , maybe [] ((:[]) . ("--use-contents="++)) . flagToMaybe . argContents $ args - - , bool [] [verbosityFlag] . getAny . argVerbose $ args - - , map (\o -> case o of Hoogle -> "--hoogle"; Html -> "--html") - . fromFlag . argOutput $ args - - , renderInterfaces . argInterfaces $ args - - , (:[]) . ("--odir="++) . unDir . argOutputDir $ args - - , (:[]) . ("--title="++) - . (bool (++" (internal documentation)") - id (getAny $ argIgnoreExports args)) - . fromFlag . argTitle $ args - - , [ "--optghc=" ++ opt | let opts = argGhcOptions args - , opt <- renderGhcOptions comp platform opts ] - - , maybe [] (\l -> ["-B"++l]) $ - flagToMaybe (argGhcLibDir args) -- error if Nothing? - - -- https://github.com/haskell/haddock/pull/547 - , [ "--reexport=" ++ prettyShow r - | r <- argReexports args - , isVersion 2 19 - ] - - , argTargets $ args - ] - where - renderInterfaces = map renderInterface - - renderInterface :: (FilePath, Maybe FilePath, Maybe FilePath) -> String - renderInterface (i, html, hypsrc) = "--read-interface=" ++ - (intercalate "," $ concat [ [ x | Just x <- [html] ] - , [ x | Just _ <- [html] - -- only render hypsrc path if html path - -- is given and hyperlinked-source is - -- enabled - , Just x <- [hypsrc] - , isVersion 2 17 - , fromFlag . argLinkedSource $ args - ] - , [ i ] - ]) - - bool a b c = if c then a else b - isVersion major minor = version >= mkVersion [major,minor] - verbosityFlag - | isVersion 2 5 = "--verbosity=1" - | otherwise = "--verbose" - ---------------------------------------------------------------------------------- - --- | Given a list of 'InstalledPackageInfo's, return a list of interfaces and --- HTML paths, and an optional warning for packages with missing documentation. -haddockPackagePaths :: [InstalledPackageInfo] - -> Maybe (InstalledPackageInfo -> FilePath) - -> IO ([( FilePath -- path to interface - -- file - - , Maybe FilePath -- url to html - -- documentation - - , Maybe FilePath -- url to hyperlinked - -- source - )] - , Maybe String -- warning about - -- missing documentation - ) -haddockPackagePaths ipkgs mkHtmlPath = do - interfaces <- sequenceA - [ case interfaceAndHtmlPath ipkg of - Nothing -> return (Left (packageId ipkg)) - Just (interface, html) -> do - - (html', hypsrc') <- - case html of - Just htmlPath -> do - let hypSrcPath = htmlPath defaultHyperlinkedSourceDirectory - hypSrcExists <- doesDirectoryExist hypSrcPath - return $ ( Just (fixFileUrl htmlPath) - , if hypSrcExists - then Just (fixFileUrl hypSrcPath) - else Nothing - ) - Nothing -> return (Nothing, Nothing) - - exists <- doesFileExist interface - if exists - then return (Right (interface, html', hypsrc')) - else return (Left pkgid) - | ipkg <- ipkgs, let pkgid = packageId ipkg - , pkgName pkgid `notElem` noHaddockWhitelist - ] - - let missing = [ pkgid | Left pkgid <- interfaces ] - warning = "The documentation for the following packages are not " - ++ "installed. No links will be generated to these packages: " - ++ intercalate ", " (map prettyShow missing) - flags = rights interfaces - - return (flags, if null missing then Nothing else Just warning) - - where - -- Don't warn about missing documentation for these packages. See #1231. - noHaddockWhitelist = map mkPackageName [ "rts" ] - - -- Actually extract interface and HTML paths from an 'InstalledPackageInfo'. - interfaceAndHtmlPath :: InstalledPackageInfo - -> Maybe (FilePath, Maybe FilePath) - interfaceAndHtmlPath pkg = do - interface <- listToMaybe (InstalledPackageInfo.haddockInterfaces pkg) - html <- case mkHtmlPath of - Nothing -> listToMaybe (InstalledPackageInfo.haddockHTMLs pkg) - Just mkPath -> Just (mkPath pkg) - return (interface, if null html then Nothing else Just html) - - -- The 'haddock-html' field in the hc-pkg output is often set as a - -- native path, but we need it as a URL. See #1064. Also don't "fix" - -- the path if it is an interpolated one. - fixFileUrl f | Nothing <- mkHtmlPath - , isAbsolute f = "file://" ++ f - | otherwise = f - - -- 'src' is the default hyperlinked source directory ever since. It is - -- not possible to configure that directory in any way in haddock. - defaultHyperlinkedSourceDirectory = "src" - - -haddockPackageFlags :: Verbosity - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> Maybe PathTemplate - -> IO ([( FilePath -- path to interface - -- file - - , Maybe FilePath -- url to html - -- documentation - - , Maybe FilePath -- url to hyperlinked - -- source - )] - , Maybe String -- warning about - -- missing documentation - ) -haddockPackageFlags verbosity lbi clbi htmlTemplate = do - let allPkgs = installedPkgs lbi - directDeps = map fst (componentPackageDeps clbi) - transitiveDeps <- case PackageIndex.dependencyClosure allPkgs directDeps of - Left x -> return x - Right inf -> die' verbosity $ "internal error when calculating transitive " - ++ "package dependencies.\nDebug info: " ++ show inf - haddockPackagePaths (PackageIndex.allPackages transitiveDeps) mkHtmlPath - where - mkHtmlPath = fmap expandTemplateVars htmlTemplate - expandTemplateVars tmpl pkg = - fromPathTemplate . substPathTemplate (env pkg) $ tmpl - env pkg = haddockTemplateEnv lbi (packageId pkg) - - -haddockTemplateEnv :: LocalBuildInfo -> PackageIdentifier -> PathTemplateEnv -haddockTemplateEnv lbi pkg_id = - (PrefixVar, prefix (installDirTemplates lbi)) - -- We want the legacy unit ID here, because it gives us nice paths - -- (Haddock people don't care about the dependencies) - : initialPathTemplateEnv - pkg_id - (mkLegacyUnitId pkg_id) - (compilerInfo (compiler lbi)) - (hostPlatform lbi) - --- ------------------------------------------------------------------------------ --- hscolour support. - -hscolour :: PackageDescription - -> LocalBuildInfo - -> [PPSuffixHandler] - -> HscolourFlags - -> IO () -hscolour = hscolour' dieNoVerbosity ForDevelopment - -hscolour' :: (String -> IO ()) -- ^ Called when the 'hscolour' exe is not found. - -> HaddockTarget - -> PackageDescription - -> LocalBuildInfo - -> [PPSuffixHandler] - -> HscolourFlags - -> IO () -hscolour' onNoHsColour haddockTarget pkg_descr lbi suffixes flags = - either onNoHsColour (\(hscolourProg, _, _) -> go hscolourProg) =<< - lookupProgramVersion verbosity hscolourProgram - (orLaterVersion (mkVersion [1,8])) (withPrograms lbi) - where - go :: ConfiguredProgram -> IO () - go hscolourProg = do - warn verbosity $ - "the 'cabal hscolour' command is deprecated in favour of 'cabal " ++ - "haddock --hyperlink-source' and will be removed in the next major " ++ - "release." - - setupMessage verbosity "Running hscolour for" (packageId pkg_descr) - createDirectoryIfMissingVerbose verbosity True $ - hscolourPref haddockTarget distPref pkg_descr - - withAllComponentsInBuildOrder pkg_descr lbi $ \comp clbi -> do - componentInitialBuildSteps distPref pkg_descr lbi clbi verbosity - preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - let - doExe com = case (compToExe com) of - Just exe -> do - let outputDir = hscolourPref haddockTarget distPref pkg_descr - unUnqualComponentName (exeName exe) "src" - runHsColour hscolourProg outputDir =<< getExeSourceFiles verbosity lbi exe clbi - Nothing -> do - warn (fromFlag $ hscolourVerbosity flags) - "Unsupported component, skipping..." - return () - case comp of - CLib lib -> do - let outputDir = hscolourPref haddockTarget distPref pkg_descr "src" - runHsColour hscolourProg outputDir =<< getLibSourceFiles verbosity lbi lib clbi - CFLib flib -> do - let outputDir = hscolourPref haddockTarget distPref pkg_descr - unUnqualComponentName (foreignLibName flib) "src" - runHsColour hscolourProg outputDir =<< getFLibSourceFiles verbosity lbi flib clbi - CExe _ -> when (fromFlag (hscolourExecutables flags)) $ doExe comp - CTest _ -> when (fromFlag (hscolourTestSuites flags)) $ doExe comp - CBench _ -> when (fromFlag (hscolourBenchmarks flags)) $ doExe comp - - stylesheet = flagToMaybe (hscolourCSS flags) - - verbosity = fromFlag (hscolourVerbosity flags) - distPref = fromFlag (hscolourDistPref flags) - - runHsColour prog outputDir moduleFiles = do - createDirectoryIfMissingVerbose verbosity True outputDir - - case stylesheet of -- copy the CSS file - Nothing | programVersion prog >= Just (mkVersion [1,9]) -> - runProgram verbosity prog - ["-print-css", "-o" ++ outputDir "hscolour.css"] - | otherwise -> return () - Just s -> copyFileVerbose verbosity s (outputDir "hscolour.css") - - for_ moduleFiles $ \(m, inFile) -> - runProgram verbosity prog - ["-css", "-anchor", "-o" ++ outFile m, inFile] - where - outFile m = outputDir - intercalate "-" (ModuleName.components m) <.> "html" - -haddockToHscolour :: HaddockFlags -> HscolourFlags -haddockToHscolour flags = - HscolourFlags { - hscolourCSS = haddockHscolourCss flags, - hscolourExecutables = haddockExecutables flags, - hscolourTestSuites = haddockTestSuites flags, - hscolourBenchmarks = haddockBenchmarks flags, - hscolourForeignLibs = haddockForeignLibs flags, - hscolourVerbosity = haddockVerbosity flags, - hscolourDistPref = haddockDistPref flags, - hscolourCabalFilePath = haddockCabalFilePath flags - } - --- ------------------------------------------------------------------------------ --- Boilerplate Monoid instance. -instance Monoid HaddockArgs where - mempty = gmempty - mappend = (<>) - -instance Semigroup HaddockArgs where - (<>) = gmappend - -instance Monoid Directory where - mempty = Dir "." - mappend = (<>) - -instance Semigroup Directory where - Dir m <> Dir n = Dir $ m n diff --git a/cabal/Cabal/Distribution/Simple/HaskellSuite.hs b/cabal/Cabal/Distribution/Simple/HaskellSuite.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/HaskellSuite.hs +++ /dev/null @@ -1,227 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - -module Distribution.Simple.HaskellSuite where - -import Prelude () -import Distribution.Compat.Prelude - -import qualified Data.List.NonEmpty as NE - -import Distribution.Simple.Program -import Distribution.Simple.Compiler -import Distribution.Simple.Utils -import Distribution.Simple.BuildPaths -import Distribution.Verbosity -import Distribution.Version -import Distribution.Pretty -import Distribution.Parsec (simpleParsec) -import Distribution.Package -import Distribution.InstalledPackageInfo hiding (includeDirs) -import Distribution.Simple.PackageIndex as PackageIndex -import Distribution.PackageDescription -import Distribution.Simple.LocalBuildInfo -import Distribution.System (Platform) -import Language.Haskell.Extension -import Distribution.Simple.Program.Builtin - -configure - :: Verbosity -> Maybe FilePath -> Maybe FilePath - -> ProgramDb -> IO (Compiler, Maybe Platform, ProgramDb) -configure verbosity mbHcPath hcPkgPath progdb0 = do - - -- We have no idea how a haskell-suite tool is named, so we require at - -- least some information from the user. - hcPath <- - let msg = "You have to provide name or path of a haskell-suite tool (-w PATH)" - in maybe (die' verbosity msg) return mbHcPath - - when (isJust hcPkgPath) $ - warn verbosity "--with-hc-pkg option is ignored for haskell-suite" - - (comp, confdCompiler, progdb1) <- configureCompiler hcPath progdb0 - - -- Update our pkg tool. It uses the same executable as the compiler, but - -- all command start with "pkg" - (confdPkg, _) <- requireProgram verbosity haskellSuitePkgProgram progdb1 - let progdb2 = - updateProgram - confdPkg - { programLocation = programLocation confdCompiler - , programDefaultArgs = ["pkg"] - } - progdb1 - - return (comp, Nothing, progdb2) - - where - configureCompiler hcPath progdb0' = do - let - haskellSuiteProgram' = - haskellSuiteProgram - { programFindLocation = \v p -> findProgramOnSearchPath v p hcPath } - - -- NB: cannot call requireProgram right away — it'd think that - -- the program is already configured and won't reconfigure it again. - -- Instead, call configureProgram directly first. - progdb1 <- configureProgram verbosity haskellSuiteProgram' progdb0' - (confdCompiler, progdb2) <- requireProgram verbosity haskellSuiteProgram' progdb1 - - extensions <- getExtensions verbosity confdCompiler - languages <- getLanguages verbosity confdCompiler - (compName, compVersion) <- - getCompilerVersion verbosity confdCompiler - - let - comp = Compiler { - compilerId = CompilerId (HaskellSuite compName) compVersion, - compilerAbiTag = NoAbiTag, - compilerCompat = [], - compilerLanguages = languages, - compilerExtensions = extensions, - compilerProperties = mempty - } - - return (comp, confdCompiler, progdb2) - -hstoolVersion :: Verbosity -> FilePath -> IO (Maybe Version) -hstoolVersion = findProgramVersion "--hspkg-version" id - -numericVersion :: Verbosity -> FilePath -> IO (Maybe Version) -numericVersion = findProgramVersion "--compiler-version" (fromMaybe "" . safeLast . words) - -getCompilerVersion :: Verbosity -> ConfiguredProgram -> IO (String, Version) -getCompilerVersion verbosity prog = do - output <- rawSystemStdout verbosity (programPath prog) ["--compiler-version"] - let - parts = words output - name = concat $ safeInit parts -- there shouldn't be any spaces in the name anyway - versionStr = fromMaybe "" $ safeLast parts - version <- - maybe (die' verbosity "haskell-suite: couldn't determine compiler version") return $ - simpleParsec versionStr - return (name, version) - -getExtensions :: Verbosity -> ConfiguredProgram -> IO [(Extension, Maybe CompilerFlag)] -getExtensions verbosity prog = do - extStrs <- - lines `fmap` - rawSystemStdout verbosity (programPath prog) ["--supported-extensions"] - return - [ (ext, Just $ "-X" ++ prettyShow ext) | Just ext <- map simpleParsec extStrs ] - -getLanguages :: Verbosity -> ConfiguredProgram -> IO [(Language, CompilerFlag)] -getLanguages verbosity prog = do - langStrs <- - lines `fmap` - rawSystemStdout verbosity (programPath prog) ["--supported-languages"] - return - [ (ext, "-G" ++ prettyShow ext) | Just ext <- map simpleParsec langStrs ] - --- Other compilers do some kind of a packagedb stack check here. Not sure --- if we need something like that as well. -getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramDb - -> IO InstalledPackageIndex -getInstalledPackages verbosity packagedbs progdb = - liftM (PackageIndex.fromList . concat) $ for packagedbs $ \packagedb -> - do str <- - getDbProgramOutput verbosity haskellSuitePkgProgram progdb - ["dump", packageDbOpt packagedb] - `catchExit` \_ -> die' verbosity $ "pkg dump failed" - case parsePackages str of - Right ok -> return ok - _ -> die' verbosity "failed to parse output of 'pkg dump'" - - where - parsePackages str = - case partitionEithers $ map (parseInstalledPackageInfo . toUTF8BS) (splitPkgs str) of - ([], ok) -> Right [ pkg | (_, pkg) <- ok ] - (msgss, _) -> Left (foldMap NE.toList msgss) - - splitPkgs :: String -> [String] - splitPkgs = map unlines . splitWith ("---" ==) . lines - where - splitWith :: (a -> Bool) -> [a] -> [[a]] - splitWith p xs = ys : case zs of - [] -> [] - _:ws -> splitWith p ws - where (ys,zs) = break p xs - -buildLib - :: Verbosity -> PackageDescription -> LocalBuildInfo - -> Library -> ComponentLocalBuildInfo -> IO () -buildLib verbosity pkg_descr lbi lib clbi = do - -- In future, there should be a mechanism for the compiler to request any - -- number of the above parameters (or their parts) — in particular, - -- pieces of PackageDescription. - -- - -- For now, we only pass those that we know are used. - - let odir = buildDir lbi - bi = libBuildInfo lib - srcDirs = hsSourceDirs bi ++ [odir] - dbStack = withPackageDB lbi - language = fromMaybe Haskell98 (defaultLanguage bi) - progdb = withPrograms lbi - pkgid = packageId pkg_descr - - runDbProgram verbosity haskellSuiteProgram progdb $ - [ "compile", "--build-dir", odir ] ++ - concat [ ["-i", d] | d <- srcDirs ] ++ - concat [ ["-I", d] | d <- [autogenComponentModulesDir lbi clbi - ,autogenPackageModulesDir lbi - ,odir] ++ includeDirs bi ] ++ - [ packageDbOpt pkgDb | pkgDb <- dbStack ] ++ - [ "--package-name", prettyShow pkgid ] ++ - concat [ ["--package-id", prettyShow ipkgid ] - | (ipkgid, _) <- componentPackageDeps clbi ] ++ - ["-G", prettyShow language] ++ - concat [ ["-X", prettyShow ex] | ex <- usedExtensions bi ] ++ - cppOptions (libBuildInfo lib) ++ - [ prettyShow modu | modu <- allLibModules lib clbi ] - - - -installLib - :: Verbosity - -> LocalBuildInfo - -> FilePath -- ^install location - -> FilePath -- ^install location for dynamic libraries - -> FilePath -- ^Build location - -> PackageDescription - -> Library - -> ComponentLocalBuildInfo - -> IO () -installLib verbosity lbi targetDir dynlibTargetDir builtDir pkg lib clbi = do - let progdb = withPrograms lbi - runDbProgram verbosity haskellSuitePkgProgram progdb $ - [ "install-library" - , "--build-dir", builtDir - , "--target-dir", targetDir - , "--dynlib-target-dir", dynlibTargetDir - , "--package-id", prettyShow $ packageId pkg - ] ++ map prettyShow (allLibModules lib clbi) - -registerPackage - :: Verbosity - -> ProgramDb - -> PackageDBStack - -> InstalledPackageInfo - -> IO () -registerPackage verbosity progdb packageDbs installedPkgInfo = do - (hspkg, _) <- requireProgram verbosity haskellSuitePkgProgram progdb - - runProgramInvocation verbosity $ - (programInvocation hspkg - ["update", packageDbOpt $ registrationPackageDB packageDbs]) - { progInvokeInput = Just $ IODataText $ showInstalledPackageInfo installedPkgInfo } - -initPackageDB :: Verbosity -> ProgramDb -> FilePath -> IO () -initPackageDB verbosity progdb dbPath = - runDbProgram verbosity haskellSuitePkgProgram progdb - ["init", dbPath] - -packageDbOpt :: PackageDB -> String -packageDbOpt GlobalPackageDB = "--global" -packageDbOpt UserPackageDB = "--user" -packageDbOpt (SpecificPackageDB db) = "--package-db=" ++ db diff --git a/cabal/Cabal/Distribution/Simple/Hpc.hs b/cabal/Cabal/Distribution/Simple/Hpc.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/Hpc.hs +++ /dev/null @@ -1,149 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Hpc --- Copyright : Thomas Tuegel 2011 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This module provides functions for locating various HPC-related paths and --- a function for adding the necessary options to a PackageDescription to --- build test suites with HPC enabled. - -module Distribution.Simple.Hpc - ( Way(..), guessWay - , htmlDir - , mixDir - , tixDir - , tixFilePath - , markupPackage - , markupTest - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Types.UnqualComponentName -import Distribution.ModuleName ( main ) -import Distribution.PackageDescription - ( TestSuite(..) - , testModules - ) -import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) ) -import Distribution.Simple.Program - ( hpcProgram - , requireProgramVersion - ) -import Distribution.Simple.Program.Hpc ( markup, union ) -import Distribution.Simple.Utils ( notice ) -import Distribution.Version ( anyVersion ) -import Distribution.Verbosity ( Verbosity() ) -import System.Directory ( createDirectoryIfMissing, doesFileExist ) -import System.FilePath - --- ------------------------------------------------------------------------- --- Haskell Program Coverage - -data Way = Vanilla | Prof | Dyn - deriving (Bounded, Enum, Eq, Read, Show) - -hpcDir :: FilePath -- ^ \"dist/\" prefix - -> Way - -> FilePath -- ^ Directory containing component's HPC .mix files -hpcDir distPref way = distPref "hpc" wayDir - where - wayDir = case way of - Vanilla -> "vanilla" - Prof -> "prof" - Dyn -> "dyn" - -mixDir :: FilePath -- ^ \"dist/\" prefix - -> Way - -> FilePath -- ^ Component name - -> FilePath -- ^ Directory containing test suite's .mix files -mixDir distPref way name = hpcDir distPref way "mix" name - -tixDir :: FilePath -- ^ \"dist/\" prefix - -> Way - -> FilePath -- ^ Component name - -> FilePath -- ^ Directory containing test suite's .tix files -tixDir distPref way name = hpcDir distPref way "tix" name - --- | Path to the .tix file containing a test suite's sum statistics. -tixFilePath :: FilePath -- ^ \"dist/\" prefix - -> Way - -> FilePath -- ^ Component name - -> FilePath -- ^ Path to test suite's .tix file -tixFilePath distPref way name = tixDir distPref way name name <.> "tix" - -htmlDir :: FilePath -- ^ \"dist/\" prefix - -> Way - -> FilePath -- ^ Component name - -> FilePath -- ^ Path to test suite's HTML markup directory -htmlDir distPref way name = hpcDir distPref way "html" name - --- | Attempt to guess the way the test suites in this package were compiled --- and linked with the library so the correct module interfaces are found. -guessWay :: LocalBuildInfo -> Way -guessWay lbi - | withProfExe lbi = Prof - | withDynExe lbi = Dyn - | otherwise = Vanilla - --- | Generate the HTML markup for a test suite. -markupTest :: Verbosity - -> LocalBuildInfo - -> FilePath -- ^ \"dist/\" prefix - -> String -- ^ Library name - -> TestSuite - -> IO () -markupTest verbosity lbi distPref libName suite = do - tixFileExists <- doesFileExist $ tixFilePath distPref way $ testName' - when tixFileExists $ do - -- behaviour of 'markup' depends on version, so we need *a* version - -- but no particular one - (hpc, hpcVer, _) <- requireProgramVersion verbosity - hpcProgram anyVersion (withPrograms lbi) - let htmlDir_ = htmlDir distPref way testName' - markup hpc hpcVer verbosity - (tixFilePath distPref way testName') mixDirs - htmlDir_ - (testModules suite ++ [ main ]) - notice verbosity $ "Test coverage report written to " - ++ htmlDir_ "hpc_index" <.> "html" - where - way = guessWay lbi - testName' = unUnqualComponentName $ testName suite - mixDirs = map (mixDir distPref way) [ testName', libName ] - --- | Generate the HTML markup for all of a package's test suites. -markupPackage :: Verbosity - -> LocalBuildInfo - -> FilePath -- ^ \"dist/\" prefix - -> String -- ^ Library name - -> [TestSuite] - -> IO () -markupPackage verbosity lbi distPref libName suites = do - let tixFiles = map (tixFilePath distPref way) testNames - tixFilesExist <- traverse doesFileExist tixFiles - when (and tixFilesExist) $ do - -- behaviour of 'markup' depends on version, so we need *a* version - -- but no particular one - (hpc, hpcVer, _) <- requireProgramVersion verbosity - hpcProgram anyVersion (withPrograms lbi) - let outFile = tixFilePath distPref way libName - htmlDir' = htmlDir distPref way libName - excluded = concatMap testModules suites ++ [ main ] - createDirectoryIfMissing True $ takeDirectory outFile - union hpc verbosity tixFiles outFile excluded - markup hpc hpcVer verbosity outFile mixDirs htmlDir' excluded - notice verbosity $ "Package coverage report written to " - ++ htmlDir' "hpc_index.html" - where - way = guessWay lbi - testNames = fmap (unUnqualComponentName . testName) suites - mixDirs = map (mixDir distPref way) $ libName : testNames diff --git a/cabal/Cabal/Distribution/Simple/Install.hs b/cabal/Cabal/Distribution/Simple/Install.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/Install.hs +++ /dev/null @@ -1,258 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Install --- Copyright : Isaac Jones 2003-2004 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This is the entry point into installing a built package. Performs the --- \"@.\/setup install@\" and \"@.\/setup copy@\" actions. It moves files into --- place based on the prefix argument. It does the generic bits and then calls --- compiler-specific functions to do the rest. - -module Distribution.Simple.Install ( - install, - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Types.TargetInfo -import Distribution.Types.LocalBuildInfo -import Distribution.Types.ForeignLib -import Distribution.Types.PackageDescription -import Distribution.Types.UnqualComponentName -import Distribution.Types.ExecutableScope - -import Distribution.Package -import Distribution.PackageDescription -import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.BuildPaths (haddockName, haddockPref) -import Distribution.Simple.Glob (matchDirFileGlob) -import Distribution.Simple.Utils - ( createDirectoryIfMissingVerbose - , installDirectoryContents, installOrdinaryFile, isInSearchPath - , die', info, noticeNoWrap, warn ) -import Distribution.Simple.Compiler - ( CompilerFlavor(..), compilerFlavor ) -import Distribution.Simple.Setup - ( CopyFlags(..), fromFlag, HaddockTarget(ForDevelopment) ) -import Distribution.Simple.BuildTarget - -import qualified Distribution.Simple.GHC as GHC -import qualified Distribution.Simple.GHCJS as GHCJS -import qualified Distribution.Simple.UHC as UHC -import qualified Distribution.Simple.HaskellSuite as HaskellSuite -import Distribution.Compat.Graph (IsNode(..)) - -import System.Directory - ( doesDirectoryExist, doesFileExist ) -import System.FilePath - ( takeFileName, takeDirectory, (), isRelative ) - -import Distribution.Verbosity -import Distribution.Pretty - ( prettyShow ) - --- |Perform the \"@.\/setup install@\" and \"@.\/setup copy@\" --- actions. Move files into place based on the prefix argument. --- --- This does NOT register libraries, you should call 'register' --- to do that. - -install :: PackageDescription -- ^information from the .cabal file - -> LocalBuildInfo -- ^information from the configure step - -> CopyFlags -- ^flags sent to copy or install - -> IO () -install pkg_descr lbi flags = do - checkHasLibsOrExes - targets <- readTargetInfos verbosity pkg_descr lbi (copyArgs flags) - - copyPackage verbosity pkg_descr lbi distPref copydest - - -- It's not necessary to do these in build-order, but it's harmless - withNeededTargetsInBuildOrder' pkg_descr lbi (map nodeKey targets) $ \target -> - let comp = targetComponent target - clbi = targetCLBI target - in copyComponent verbosity pkg_descr lbi comp clbi copydest - where - distPref = fromFlag (copyDistPref flags) - verbosity = fromFlag (copyVerbosity flags) - copydest = fromFlag (copyDest flags) - - checkHasLibsOrExes = - unless (hasLibs pkg_descr || hasForeignLibs pkg_descr || hasExes pkg_descr) $ - die' verbosity "No executables and no library found. Nothing to do." - --- | Copy package global files. -copyPackage :: Verbosity -> PackageDescription - -> LocalBuildInfo -> FilePath -> CopyDest -> IO () -copyPackage verbosity pkg_descr lbi distPref copydest = do - let -- This is a bit of a hack, to handle files which are not - -- per-component (data files and Haddock files.) - InstallDirs { - datadir = dataPref, - docdir = docPref, - htmldir = htmlPref, - haddockdir = interfacePref - } = absoluteInstallCommandDirs pkg_descr lbi (localUnitId lbi) copydest - - -- Install (package-global) data files - installDataFiles verbosity pkg_descr dataPref - - -- Install (package-global) Haddock files - -- TODO: these should be done per-library - docExists <- doesDirectoryExist $ haddockPref ForDevelopment distPref pkg_descr - info verbosity ("directory " ++ haddockPref ForDevelopment distPref pkg_descr ++ - " does exist: " ++ show docExists) - - -- TODO: this is a bit questionable, Haddock files really should - -- be per library (when there are convenience libraries.) - when docExists $ do - createDirectoryIfMissingVerbose verbosity True htmlPref - installDirectoryContents verbosity - (haddockPref ForDevelopment distPref pkg_descr) htmlPref - -- setPermissionsRecursive [Read] htmlPref - -- The haddock interface file actually already got installed - -- in the recursive copy, but now we install it where we actually - -- want it to be (normally the same place). We could remove the - -- copy in htmlPref first. - let haddockInterfaceFileSrc = haddockPref ForDevelopment distPref pkg_descr - haddockName pkg_descr - haddockInterfaceFileDest = interfacePref haddockName pkg_descr - -- We only generate the haddock interface file for libs, So if the - -- package consists only of executables there will not be one: - exists <- doesFileExist haddockInterfaceFileSrc - when exists $ do - createDirectoryIfMissingVerbose verbosity True interfacePref - installOrdinaryFile verbosity haddockInterfaceFileSrc - haddockInterfaceFileDest - - let lfiles = licenseFiles pkg_descr - unless (null lfiles) $ do - createDirectoryIfMissingVerbose verbosity True docPref - sequence_ - [ installOrdinaryFile verbosity lfile (docPref takeFileName lfile) - | lfile <- lfiles ] - --- | Copy files associated with a component. -copyComponent :: Verbosity -> PackageDescription - -> LocalBuildInfo -> Component -> ComponentLocalBuildInfo - -> CopyDest - -> IO () -copyComponent verbosity pkg_descr lbi (CLib lib) clbi copydest = do - let InstallDirs{ - libdir = libPref, - dynlibdir = dynlibPref, - includedir = incPref - } = absoluteInstallCommandDirs pkg_descr lbi (componentUnitId clbi) copydest - buildPref = componentBuildDir lbi clbi - - case libName lib of - LMainLibName -> noticeNoWrap verbosity ("Installing library in " ++ libPref) - LSubLibName n -> noticeNoWrap verbosity ("Installing internal library " ++ prettyShow n ++ " in " ++ libPref) - - -- install include files for all compilers - they may be needed to compile - -- haskell files (using the CPP extension) - installIncludeFiles verbosity (libBuildInfo lib) lbi buildPref incPref - - case compilerFlavor (compiler lbi) of - GHC -> GHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi - GHCJS -> GHCJS.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi - UHC -> UHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi - HaskellSuite _ -> HaskellSuite.installLib - verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi - _ -> die' verbosity $ "installing with " - ++ prettyShow (compilerFlavor (compiler lbi)) - ++ " is not implemented" - -copyComponent verbosity pkg_descr lbi (CFLib flib) clbi copydest = do - let InstallDirs{ - flibdir = flibPref, - includedir = incPref - } = absoluteComponentInstallDirs pkg_descr lbi (componentUnitId clbi) copydest - buildPref = componentBuildDir lbi clbi - - noticeNoWrap verbosity ("Installing foreign library " ++ unUnqualComponentName (foreignLibName flib) ++ " in " ++ flibPref) - installIncludeFiles verbosity (foreignLibBuildInfo flib) lbi buildPref incPref - - case compilerFlavor (compiler lbi) of - GHC -> GHC.installFLib verbosity lbi flibPref buildPref pkg_descr flib - GHCJS -> GHCJS.installFLib verbosity lbi flibPref buildPref pkg_descr flib - _ -> die' verbosity $ "installing foreign lib with " - ++ prettyShow (compilerFlavor (compiler lbi)) - ++ " is not implemented" - -copyComponent verbosity pkg_descr lbi (CExe exe) clbi copydest = do - let installDirs = absoluteComponentInstallDirs pkg_descr lbi (componentUnitId clbi) copydest - -- the installers know how to find the actual location of the - -- binaries - buildPref = buildDir lbi - uid = componentUnitId clbi - pkgid = packageId pkg_descr - binPref | ExecutablePrivate <- exeScope exe = libexecdir installDirs - | otherwise = bindir installDirs - progPrefixPref = substPathTemplate pkgid lbi uid (progPrefix lbi) - progSuffixPref = substPathTemplate pkgid lbi uid (progSuffix lbi) - progFix = (progPrefixPref, progSuffixPref) - noticeNoWrap verbosity ("Installing executable " ++ prettyShow (exeName exe) - ++ " in " ++ binPref) - inPath <- isInSearchPath binPref - when (not inPath) $ - warn verbosity ("The directory " ++ binPref - ++ " is not in the system search path.") - case compilerFlavor (compiler lbi) of - GHC -> GHC.installExe verbosity lbi binPref buildPref progFix pkg_descr exe - GHCJS -> GHCJS.installExe verbosity lbi binPref buildPref progFix pkg_descr exe - UHC -> return () - HaskellSuite {} -> return () - _ -> die' verbosity $ "installing with " - ++ prettyShow (compilerFlavor (compiler lbi)) - ++ " is not implemented" - --- Nothing to do for benchmark/testsuite -copyComponent _ _ _ (CBench _) _ _ = return () -copyComponent _ _ _ (CTest _) _ _ = return () - --- | Install the files listed in data-files --- -installDataFiles :: Verbosity -> PackageDescription -> FilePath -> IO () -installDataFiles verbosity pkg_descr destDataDir = - flip traverse_ (dataFiles pkg_descr) $ \ glob -> do - let srcDataDirRaw = dataDir pkg_descr - srcDataDir = if null srcDataDirRaw - then "." - else srcDataDirRaw - files <- matchDirFileGlob verbosity (specVersion pkg_descr) srcDataDir glob - for_ files $ \ file' -> do - let src = srcDataDir file' - dst = destDataDir file' - createDirectoryIfMissingVerbose verbosity True (takeDirectory dst) - installOrdinaryFile verbosity src dst - --- | Install the files listed in install-includes for a library --- -installIncludeFiles :: Verbosity -> BuildInfo -> LocalBuildInfo -> FilePath -> FilePath -> IO () -installIncludeFiles verbosity libBi lbi buildPref destIncludeDir = do - let relincdirs = "." : filter isRelative (includeDirs libBi) - incdirs = [ baseDir lbi dir | dir <- relincdirs ] - ++ [ buildPref dir | dir <- relincdirs ] - incs <- traverse (findInc incdirs) (installIncludes libBi) - sequence_ - [ do createDirectoryIfMissingVerbose verbosity True destDir - installOrdinaryFile verbosity srcFile destFile - | (relFile, srcFile) <- incs - , let destFile = destIncludeDir relFile - destDir = takeDirectory destFile ] - where - baseDir lbi' = fromMaybe "" (takeDirectory <$> cabalFilePath lbi') - findInc [] file = die' verbosity ("can't find include file " ++ file) - findInc (dir:dirs) file = do - let path = dir file - exists <- doesFileExist path - if exists then return (file, path) else findInc dirs file diff --git a/cabal/Cabal/Distribution/Simple/InstallDirs.hs b/cabal/Cabal/Distribution/Simple/InstallDirs.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/InstallDirs.hs +++ /dev/null @@ -1,506 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.InstallDirs --- Copyright : Isaac Jones 2003-2004 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This manages everything to do with where files get installed (though does --- not get involved with actually doing any installation). It provides an --- 'InstallDirs' type which is a set of directories for where to install --- things. It also handles the fact that we use templates in these install --- dirs. For example most install dirs are relative to some @$prefix@ and by --- changing the prefix all other dirs still end up changed appropriately. So it --- provides a 'PathTemplate' type and functions for substituting for these --- templates. - -module Distribution.Simple.InstallDirs ( - InstallDirs(..), - InstallDirTemplates, - defaultInstallDirs, - defaultInstallDirs', - combineInstallDirs, - absoluteInstallDirs, - CopyDest(..), - prefixRelativeInstallDirs, - substituteInstallDirTemplates, - - PathTemplate, - PathTemplateVariable(..), - PathTemplateEnv, - toPathTemplate, - fromPathTemplate, - combinePathTemplate, - substPathTemplate, - initialPathTemplateEnv, - platformTemplateEnv, - compilerTemplateEnv, - packageTemplateEnv, - abiTemplateEnv, - installDirsTemplateEnv, - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Compat.Environment (lookupEnv) -import Distribution.Pretty -import Distribution.Package -import Distribution.System -import Distribution.Compiler -import Distribution.Simple.InstallDirs.Internal - -import System.Directory (getAppUserDataDirectory) -import System.FilePath - ( (), isPathSeparator - , pathSeparator, dropDrive - , takeDirectory ) - -#ifdef mingw32_HOST_OS -import qualified Prelude -import Foreign -import Foreign.C -#endif - --- --------------------------------------------------------------------------- --- Installation directories - - --- | The directories where we will install files for packages. --- --- We have several different directories for different types of files since --- many systems have conventions whereby different types of files in a package --- are installed in different directories. This is particularly the case on --- Unix style systems. --- -data InstallDirs dir = InstallDirs { - prefix :: dir, - bindir :: dir, - libdir :: dir, - libsubdir :: dir, - dynlibdir :: dir, - flibdir :: dir, -- ^ foreign libraries - libexecdir :: dir, - libexecsubdir:: dir, - includedir :: dir, - datadir :: dir, - datasubdir :: dir, - docdir :: dir, - mandir :: dir, - htmldir :: dir, - haddockdir :: dir, - sysconfdir :: dir - } deriving (Eq, Read, Show, Functor, Generic, Typeable) - -instance Binary dir => Binary (InstallDirs dir) -instance Structured dir => Structured (InstallDirs dir) - -instance (Semigroup dir, Monoid dir) => Monoid (InstallDirs dir) where - mempty = gmempty - mappend = (<>) - -instance Semigroup dir => Semigroup (InstallDirs dir) where - (<>) = gmappend - -combineInstallDirs :: (a -> b -> c) - -> InstallDirs a - -> InstallDirs b - -> InstallDirs c -combineInstallDirs combine a b = InstallDirs { - prefix = prefix a `combine` prefix b, - bindir = bindir a `combine` bindir b, - libdir = libdir a `combine` libdir b, - libsubdir = libsubdir a `combine` libsubdir b, - dynlibdir = dynlibdir a `combine` dynlibdir b, - flibdir = flibdir a `combine` flibdir b, - libexecdir = libexecdir a `combine` libexecdir b, - libexecsubdir= libexecsubdir a `combine` libexecsubdir b, - includedir = includedir a `combine` includedir b, - datadir = datadir a `combine` datadir b, - datasubdir = datasubdir a `combine` datasubdir b, - docdir = docdir a `combine` docdir b, - mandir = mandir a `combine` mandir b, - htmldir = htmldir a `combine` htmldir b, - haddockdir = haddockdir a `combine` haddockdir b, - sysconfdir = sysconfdir a `combine` sysconfdir b - } - -appendSubdirs :: (a -> a -> a) -> InstallDirs a -> InstallDirs a -appendSubdirs append dirs = dirs { - libdir = libdir dirs `append` libsubdir dirs, - libexecdir = libexecdir dirs `append` libexecsubdir dirs, - datadir = datadir dirs `append` datasubdir dirs, - libsubdir = error "internal error InstallDirs.libsubdir", - libexecsubdir = error "internal error InstallDirs.libexecsubdir", - datasubdir = error "internal error InstallDirs.datasubdir" - } - --- | The installation directories in terms of 'PathTemplate's that contain --- variables. --- --- The defaults for most of the directories are relative to each other, in --- particular they are all relative to a single prefix. This makes it --- convenient for the user to override the default installation directory --- by only having to specify --prefix=... rather than overriding each --- individually. This is done by allowing $-style variables in the dirs. --- These are expanded by textual substitution (see 'substPathTemplate'). --- --- A few of these installation directories are split into two components, the --- dir and subdir. The full installation path is formed by combining the two --- together with @\/@. The reason for this is compatibility with other Unix --- build systems which also support @--libdir@ and @--datadir@. We would like --- users to be able to configure @--libdir=\/usr\/lib64@ for example but --- because by default we want to support installing multiple versions of --- packages and building the same package for multiple compilers we append the --- libsubdir to get: @\/usr\/lib64\/$libname\/$compiler@. --- --- An additional complication is the need to support relocatable packages on --- systems which support such things, like Windows. --- -type InstallDirTemplates = InstallDirs PathTemplate - --- --------------------------------------------------------------------------- --- Default installation directories - -defaultInstallDirs :: CompilerFlavor -> Bool -> Bool -> IO InstallDirTemplates -defaultInstallDirs = defaultInstallDirs' False - -defaultInstallDirs' :: Bool {- use external internal deps -} - -> CompilerFlavor -> Bool -> Bool -> IO InstallDirTemplates -defaultInstallDirs' True comp userInstall hasLibs = do - dflt <- defaultInstallDirs' False comp userInstall hasLibs - -- Be a bit more hermetic about per-component installs - return dflt { datasubdir = toPathTemplate $ "$abi" "$libname", - docdir = toPathTemplate $ "$datadir" "doc" "$abi" "$libname" - } -defaultInstallDirs' False comp userInstall _hasLibs = do - installPrefix <- - if userInstall - then do - mDir <- lookupEnv "CABAL_DIR" - case mDir of - Nothing -> getAppUserDataDirectory "cabal" - Just dir -> return dir - else case buildOS of - Windows -> do windowsProgramFilesDir <- getWindowsProgramFilesDir - return (windowsProgramFilesDir "Haskell") - _ -> return "/usr/local" - installLibDir <- - case buildOS of - Windows -> return "$prefix" - _ -> return ("$prefix" "lib") - return $ fmap toPathTemplate $ InstallDirs { - prefix = installPrefix, - bindir = "$prefix" "bin", - libdir = installLibDir, - libsubdir = case comp of - UHC -> "$pkgid" - _other -> "$abi" "$libname", - dynlibdir = "$libdir" case comp of - UHC -> "$pkgid" - _other -> "$abi", - libexecsubdir= "$abi" "$pkgid", - flibdir = "$libdir", - libexecdir = case buildOS of - Windows -> "$prefix" "$libname" - _other -> "$prefix" "libexec", - includedir = "$libdir" "$libsubdir" "include", - datadir = case buildOS of - Windows -> "$prefix" - _other -> "$prefix" "share", - datasubdir = "$abi" "$pkgid", - docdir = "$datadir" "doc" "$abi" "$pkgid", - mandir = "$datadir" "man", - htmldir = "$docdir" "html", - haddockdir = "$htmldir", - sysconfdir = "$prefix" "etc" - } - --- --------------------------------------------------------------------------- --- Converting directories, absolute or prefix-relative - --- | Substitute the install dir templates into each other. --- --- To prevent cyclic substitutions, only some variables are allowed in --- particular dir templates. If out of scope vars are present, they are not --- substituted for. Checking for any remaining unsubstituted vars can be done --- as a subsequent operation. --- --- The reason it is done this way is so that in 'prefixRelativeInstallDirs' we --- can replace 'prefix' with the 'PrefixVar' and get resulting --- 'PathTemplate's that still have the 'PrefixVar' in them. Doing this makes it --- each to check which paths are relative to the $prefix. --- -substituteInstallDirTemplates :: PathTemplateEnv - -> InstallDirTemplates -> InstallDirTemplates -substituteInstallDirTemplates env dirs = dirs' - where - dirs' = InstallDirs { - -- So this specifies exactly which vars are allowed in each template - prefix = subst prefix [], - bindir = subst bindir [prefixVar], - libdir = subst libdir [prefixVar, bindirVar], - libsubdir = subst libsubdir [], - dynlibdir = subst dynlibdir [prefixVar, bindirVar, libdirVar], - flibdir = subst flibdir [prefixVar, bindirVar, libdirVar], - libexecdir = subst libexecdir prefixBinLibVars, - libexecsubdir = subst libexecsubdir [], - includedir = subst includedir prefixBinLibVars, - datadir = subst datadir prefixBinLibVars, - datasubdir = subst datasubdir [], - docdir = subst docdir prefixBinLibDataVars, - mandir = subst mandir (prefixBinLibDataVars ++ [docdirVar]), - htmldir = subst htmldir (prefixBinLibDataVars ++ [docdirVar]), - haddockdir = subst haddockdir (prefixBinLibDataVars ++ - [docdirVar, htmldirVar]), - sysconfdir = subst sysconfdir prefixBinLibVars - } - subst dir env' = substPathTemplate (env'++env) (dir dirs) - - prefixVar = (PrefixVar, prefix dirs') - bindirVar = (BindirVar, bindir dirs') - libdirVar = (LibdirVar, libdir dirs') - libsubdirVar = (LibsubdirVar, libsubdir dirs') - datadirVar = (DatadirVar, datadir dirs') - datasubdirVar = (DatasubdirVar, datasubdir dirs') - docdirVar = (DocdirVar, docdir dirs') - htmldirVar = (HtmldirVar, htmldir dirs') - prefixBinLibVars = [prefixVar, bindirVar, libdirVar, libsubdirVar] - prefixBinLibDataVars = prefixBinLibVars ++ [datadirVar, datasubdirVar] - --- | Convert from abstract install directories to actual absolute ones by --- substituting for all the variables in the abstract paths, to get real --- absolute path. -absoluteInstallDirs :: PackageIdentifier - -> UnitId - -> CompilerInfo - -> CopyDest - -> Platform - -> InstallDirs PathTemplate - -> InstallDirs FilePath -absoluteInstallDirs pkgId libname compilerId copydest platform dirs = - (case copydest of - CopyTo destdir -> fmap ((destdir ) . dropDrive) - CopyToDb dbdir -> fmap (substPrefix "${pkgroot}" (takeDirectory dbdir)) - _ -> id) - . appendSubdirs () - . fmap fromPathTemplate - $ substituteInstallDirTemplates env dirs - where - env = initialPathTemplateEnv pkgId libname compilerId platform - substPrefix pre root path - | pre `isPrefixOf` path = root ++ drop (length pre) path - | otherwise = path - - --- |The location prefix for the /copy/ command. -data CopyDest - = NoCopyDest - | CopyTo FilePath - | CopyToDb FilePath - -- ^ when using the ${pkgroot} as prefix. The CopyToDb will - -- adjust the paths to be relative to the provided package - -- database when copying / installing. - deriving (Eq, Show, Generic) - -instance Binary CopyDest - --- | Check which of the paths are relative to the installation $prefix. --- --- If any of the paths are not relative, ie they are absolute paths, then it --- prevents us from making a relocatable package (also known as a \"prefix --- independent\" package). --- -prefixRelativeInstallDirs :: PackageIdentifier - -> UnitId - -> CompilerInfo - -> Platform - -> InstallDirTemplates - -> InstallDirs (Maybe FilePath) -prefixRelativeInstallDirs pkgId libname compilerId platform dirs = - fmap relative - . appendSubdirs combinePathTemplate - $ -- substitute the path template into each other, except that we map - -- \$prefix back to $prefix. We're trying to end up with templates that - -- mention no vars except $prefix. - substituteInstallDirTemplates env dirs { - prefix = PathTemplate [Variable PrefixVar] - } - where - env = initialPathTemplateEnv pkgId libname compilerId platform - - -- If it starts with $prefix then it's relative and produce the relative - -- path by stripping off $prefix/ or $prefix - relative dir = case dir of - PathTemplate cs -> fmap (fromPathTemplate . PathTemplate) (relative' cs) - relative' (Variable PrefixVar : Ordinary (s:rest) : rest') - | isPathSeparator s = Just (Ordinary rest : rest') - relative' (Variable PrefixVar : rest) = Just rest - relative' _ = Nothing - --- --------------------------------------------------------------------------- --- Path templates - --- | An abstract path, possibly containing variables that need to be --- substituted for to get a real 'FilePath'. --- -newtype PathTemplate = PathTemplate [PathComponent] - deriving (Eq, Ord, Generic, Typeable) - -instance Binary PathTemplate -instance Structured PathTemplate - -type PathTemplateEnv = [(PathTemplateVariable, PathTemplate)] - --- | Convert a 'FilePath' to a 'PathTemplate' including any template vars. --- -toPathTemplate :: FilePath -> PathTemplate -toPathTemplate fp = PathTemplate - . fromMaybe (error $ "panic! toPathTemplate " ++ show fp) - . readMaybe -- TODO: eradicateNoParse - $ fp - --- | Convert back to a path, any remaining vars are included --- -fromPathTemplate :: PathTemplate -> FilePath -fromPathTemplate (PathTemplate template) = show template - -combinePathTemplate :: PathTemplate -> PathTemplate -> PathTemplate -combinePathTemplate (PathTemplate t1) (PathTemplate t2) = - PathTemplate (t1 ++ [Ordinary [pathSeparator]] ++ t2) - -substPathTemplate :: PathTemplateEnv -> PathTemplate -> PathTemplate -substPathTemplate environment (PathTemplate template) = - PathTemplate (concatMap subst template) - - where subst component@(Ordinary _) = [component] - subst component@(Variable variable) = - case lookup variable environment of - Just (PathTemplate components) -> components - Nothing -> [component] - --- | The initial environment has all the static stuff but no paths -initialPathTemplateEnv :: PackageIdentifier - -> UnitId - -> CompilerInfo - -> Platform - -> PathTemplateEnv -initialPathTemplateEnv pkgId libname compiler platform = - packageTemplateEnv pkgId libname - ++ compilerTemplateEnv compiler - ++ platformTemplateEnv platform - ++ abiTemplateEnv compiler platform - -packageTemplateEnv :: PackageIdentifier -> UnitId -> PathTemplateEnv -packageTemplateEnv pkgId uid = - [(PkgNameVar, PathTemplate [Ordinary $ prettyShow (packageName pkgId)]) - ,(PkgVerVar, PathTemplate [Ordinary $ prettyShow (packageVersion pkgId)]) - -- Invariant: uid is actually a HashedUnitId. Hard to enforce because - -- it's an API change. - ,(LibNameVar, PathTemplate [Ordinary $ prettyShow uid]) - ,(PkgIdVar, PathTemplate [Ordinary $ prettyShow pkgId]) - ] - -compilerTemplateEnv :: CompilerInfo -> PathTemplateEnv -compilerTemplateEnv compiler = - [(CompilerVar, PathTemplate [Ordinary $ prettyShow (compilerInfoId compiler)]) - ] - -platformTemplateEnv :: Platform -> PathTemplateEnv -platformTemplateEnv (Platform arch os) = - [(OSVar, PathTemplate [Ordinary $ prettyShow os]) - ,(ArchVar, PathTemplate [Ordinary $ prettyShow arch]) - ] - -abiTemplateEnv :: CompilerInfo -> Platform -> PathTemplateEnv -abiTemplateEnv compiler (Platform arch os) = - [(AbiVar, PathTemplate [Ordinary $ prettyShow arch ++ '-':prettyShow os ++ - '-':prettyShow (compilerInfoId compiler) ++ - case compilerInfoAbiTag compiler of - NoAbiTag -> "" - AbiTag tag -> '-':tag]) - ,(AbiTagVar, PathTemplate [Ordinary $ abiTagString (compilerInfoAbiTag compiler)]) - ] - -installDirsTemplateEnv :: InstallDirs PathTemplate -> PathTemplateEnv -installDirsTemplateEnv dirs = - [(PrefixVar, prefix dirs) - ,(BindirVar, bindir dirs) - ,(LibdirVar, libdir dirs) - ,(LibsubdirVar, libsubdir dirs) - ,(DynlibdirVar, dynlibdir dirs) - ,(DatadirVar, datadir dirs) - ,(DatasubdirVar, datasubdir dirs) - ,(DocdirVar, docdir dirs) - ,(HtmldirVar, htmldir dirs) - ] - - --- --------------------------------------------------------------------------- --- Parsing and showing path templates: - --- The textual format is that of an ordinary Haskell String, eg --- "$prefix/bin" --- and this gets parsed to the internal representation as a sequence of path --- spans which are either strings or variables, eg: --- PathTemplate [Variable PrefixVar, Ordinary "/bin" ] - -instance Show PathTemplate where - show (PathTemplate template) = show (show template) - -instance Read PathTemplate where - readsPrec p s = [ (PathTemplate template, s') - | (path, s') <- readsPrec p s - , (template, "") <- reads path ] - --- --------------------------------------------------------------------------- --- Internal utilities - -getWindowsProgramFilesDir :: IO FilePath -getWindowsProgramFilesDir = do -#ifdef mingw32_HOST_OS - m <- shGetFolderPath csidl_PROGRAM_FILES -#else - let m = Nothing -#endif - return (fromMaybe "C:\\Program Files" m) - -#ifdef mingw32_HOST_OS -shGetFolderPath :: CInt -> IO (Maybe FilePath) -shGetFolderPath n = - allocaArray long_path_size $ \pPath -> do - r <- c_SHGetFolderPath nullPtr n nullPtr 0 pPath - if (r /= 0) - then return Nothing - else do s <- peekCWString pPath; return (Just s) - where - long_path_size = 1024 -- MAX_PATH is 260, this should be plenty - -csidl_PROGRAM_FILES :: CInt -csidl_PROGRAM_FILES = 0x0026 --- csidl_PROGRAM_FILES_COMMON :: CInt --- csidl_PROGRAM_FILES_COMMON = 0x002b - -#ifdef x86_64_HOST_ARCH -#define CALLCONV ccall -#else -#define CALLCONV stdcall -#endif - -foreign import CALLCONV unsafe "shlobj.h SHGetFolderPathW" - c_SHGetFolderPath :: Ptr () - -> CInt - -> Ptr () - -> CInt - -> CWString - -> Prelude.IO CInt -#endif diff --git a/cabal/Cabal/Distribution/Simple/InstallDirs/Internal.hs b/cabal/Cabal/Distribution/Simple/InstallDirs/Internal.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/InstallDirs/Internal.hs +++ /dev/null @@ -1,127 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Simple.InstallDirs.Internal - ( PathComponent(..) - , PathTemplateVariable(..) - ) where - -import Prelude () -import Distribution.Compat.Prelude - -data PathComponent = - Ordinary FilePath - | Variable PathTemplateVariable - deriving (Eq, Ord, Generic, Typeable) - -instance Binary PathComponent -instance Structured PathComponent - -data PathTemplateVariable = - PrefixVar -- ^ The @$prefix@ path variable - | BindirVar -- ^ The @$bindir@ path variable - | LibdirVar -- ^ The @$libdir@ path variable - | LibsubdirVar -- ^ The @$libsubdir@ path variable - | DynlibdirVar -- ^ The @$dynlibdir@ path variable - | DatadirVar -- ^ The @$datadir@ path variable - | DatasubdirVar -- ^ The @$datasubdir@ path variable - | DocdirVar -- ^ The @$docdir@ path variable - | HtmldirVar -- ^ The @$htmldir@ path variable - | PkgNameVar -- ^ The @$pkg@ package name path variable - | PkgVerVar -- ^ The @$version@ package version path variable - | PkgIdVar -- ^ The @$pkgid@ package Id path variable, eg @foo-1.0@ - | LibNameVar -- ^ The @$libname@ path variable - | CompilerVar -- ^ The compiler name and version, eg @ghc-6.6.1@ - | OSVar -- ^ The operating system name, eg @windows@ or @linux@ - | ArchVar -- ^ The CPU architecture name, eg @i386@ or @x86_64@ - | AbiVar -- ^ The compiler's ABI identifier, - --- $arch-$os-$compiler-$abitag - | AbiTagVar -- ^ The optional ABI tag for the compiler - | ExecutableNameVar -- ^ The executable name; used in shell wrappers - | TestSuiteNameVar -- ^ The name of the test suite being run - | TestSuiteResultVar -- ^ The result of the test suite being run, eg - -- @pass@, @fail@, or @error@. - | BenchmarkNameVar -- ^ The name of the benchmark being run - deriving (Eq, Ord, Generic, Typeable) - -instance Binary PathTemplateVariable -instance Structured PathTemplateVariable - -instance Show PathTemplateVariable where - show PrefixVar = "prefix" - show LibNameVar = "libname" - show BindirVar = "bindir" - show LibdirVar = "libdir" - show LibsubdirVar = "libsubdir" - show DynlibdirVar = "dynlibdir" - show DatadirVar = "datadir" - show DatasubdirVar = "datasubdir" - show DocdirVar = "docdir" - show HtmldirVar = "htmldir" - show PkgNameVar = "pkg" - show PkgVerVar = "version" - show PkgIdVar = "pkgid" - show CompilerVar = "compiler" - show OSVar = "os" - show ArchVar = "arch" - show AbiTagVar = "abitag" - show AbiVar = "abi" - show ExecutableNameVar = "executablename" - show TestSuiteNameVar = "test-suite" - show TestSuiteResultVar = "result" - show BenchmarkNameVar = "benchmark" - -instance Read PathTemplateVariable where - readsPrec _ s = - take 1 - [ (var, drop (length varStr) s) - | (varStr, var) <- vars - , varStr `isPrefixOf` s ] - -- NB: order matters! Longer strings first - where vars = [("prefix", PrefixVar) - ,("bindir", BindirVar) - ,("libdir", LibdirVar) - ,("libsubdir", LibsubdirVar) - ,("dynlibdir", DynlibdirVar) - ,("datadir", DatadirVar) - ,("datasubdir", DatasubdirVar) - ,("docdir", DocdirVar) - ,("htmldir", HtmldirVar) - ,("pkgid", PkgIdVar) - ,("libname", LibNameVar) - ,("pkgkey", LibNameVar) -- backwards compatibility - ,("pkg", PkgNameVar) - ,("version", PkgVerVar) - ,("compiler", CompilerVar) - ,("os", OSVar) - ,("arch", ArchVar) - ,("abitag", AbiTagVar) - ,("abi", AbiVar) - ,("executablename", ExecutableNameVar) - ,("test-suite", TestSuiteNameVar) - ,("result", TestSuiteResultVar) - ,("benchmark", BenchmarkNameVar)] - -instance Show PathComponent where - show (Ordinary path) = path - show (Variable var) = '$':show var - showList = foldr (\x -> (shows x .)) id - -instance Read PathComponent where - -- for some reason we collapse multiple $ symbols here - readsPrec _ = lex0 - where lex0 [] = [] - lex0 ('$':'$':s') = lex0 ('$':s') - lex0 ('$':s') = case [ (Variable var, s'') - | (var, s'') <- reads s' ] of - [] -> lex1 "$" s' - ok -> ok - lex0 s' = lex1 [] s' - lex1 "" "" = [] - lex1 acc "" = [(Ordinary (reverse acc), "")] - lex1 acc ('$':'$':s) = lex1 acc ('$':s) - lex1 acc ('$':s) = [(Ordinary (reverse acc), '$':s)] - lex1 acc (c:s) = lex1 (c:acc) s - readList [] = [([],"")] - readList s = [ (component:components, s'') - | (component, s') <- reads s - , (components, s'') <- readList s' ] diff --git a/cabal/Cabal/Distribution/Simple/LocalBuildInfo.hs b/cabal/Cabal/Distribution/Simple/LocalBuildInfo.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/LocalBuildInfo.hs +++ /dev/null @@ -1,365 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.LocalBuildInfo --- Copyright : Isaac Jones 2003-2004 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Once a package has been configured we have resolved conditionals and --- dependencies, configured the compiler and other needed external programs. --- The 'LocalBuildInfo' is used to hold all this information. It holds the --- install dirs, the compiler, the exact package dependencies, the configured --- programs, the package database to use and a bunch of miscellaneous configure --- flags. It gets saved and reloaded from a file (@dist\/setup-config@). It gets --- passed in to very many subsequent build actions. - -module Distribution.Simple.LocalBuildInfo ( - LocalBuildInfo(..), - localComponentId, - localUnitId, - localCompatPackageKey, - - -- * Buildable package components - Component(..), - ComponentName(..), - LibraryName(..), - defaultLibName, - showComponentName, - componentNameString, - ComponentLocalBuildInfo(..), - componentBuildDir, - foldComponent, - componentName, - componentBuildInfo, - componentBuildable, - pkgComponents, - pkgBuildableComponents, - lookupComponent, - getComponent, - allComponentsInBuildOrder, - depLibraryPaths, - allLibModules, - - withAllComponentsInBuildOrder, - withLibLBI, - withExeLBI, - withBenchLBI, - withTestLBI, - enabledTestLBIs, - enabledBenchLBIs, - - -- * Installation directories - module Distribution.Simple.InstallDirs, - absoluteInstallDirs, prefixRelativeInstallDirs, - absoluteInstallCommandDirs, - absoluteComponentInstallDirs, prefixRelativeComponentInstallDirs, - substPathTemplate, - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Types.Component -import Distribution.Types.PackageId -import Distribution.Types.UnitId -import Distribution.Types.ComponentName -import Distribution.Types.UnqualComponentName -import Distribution.Types.PackageDescription -import Distribution.Types.ComponentLocalBuildInfo -import Distribution.Types.LocalBuildInfo -import Distribution.Types.TargetInfo - -import Distribution.Simple.InstallDirs hiding (absoluteInstallDirs, - prefixRelativeInstallDirs, - substPathTemplate, ) -import qualified Distribution.Simple.InstallDirs as InstallDirs -import Distribution.PackageDescription -import qualified Distribution.InstalledPackageInfo as Installed -import Distribution.Package -import Distribution.ModuleName -import Distribution.Simple.Compiler -import Distribution.Simple.PackageIndex -import Distribution.Simple.Utils -import Distribution.Pretty -import qualified Distribution.Compat.Graph as Graph - -import Data.List (stripPrefix) -import System.FilePath - -import System.Directory (doesDirectoryExist, canonicalizePath) - --- ----------------------------------------------------------------------------- --- Configuration information of buildable components - -componentBuildDir :: LocalBuildInfo -> ComponentLocalBuildInfo -> FilePath --- For now, we assume that libraries/executables/test-suites/benchmarks --- are only ever built once. With Backpack, we need a special case for --- libraries so that we can handle building them multiple times. -componentBuildDir lbi clbi - = buildDir lbi - case componentLocalName clbi of - CLibName LMainLibName -> - if prettyShow (componentUnitId clbi) == prettyShow (componentComponentId clbi) - then "" - else prettyShow (componentUnitId clbi) - CLibName (LSubLibName s) -> - if prettyShow (componentUnitId clbi) == prettyShow (componentComponentId clbi) - then unUnqualComponentName s - else prettyShow (componentUnitId clbi) - CFLibName s -> unUnqualComponentName s - CExeName s -> unUnqualComponentName s - CTestName s -> unUnqualComponentName s - CBenchName s -> unUnqualComponentName s - --- | Perform the action on each enabled 'library' in the package --- description with the 'ComponentLocalBuildInfo'. -withLibLBI :: PackageDescription -> LocalBuildInfo - -> (Library -> ComponentLocalBuildInfo -> IO ()) -> IO () -withLibLBI pkg lbi f = - withAllTargetsInBuildOrder' pkg lbi $ \target -> - case targetComponent target of - CLib lib -> f lib (targetCLBI target) - _ -> return () - --- | Perform the action on each enabled 'Executable' in the package --- description. Extended version of 'withExe' that also gives corresponding --- build info. -withExeLBI :: PackageDescription -> LocalBuildInfo - -> (Executable -> ComponentLocalBuildInfo -> IO ()) -> IO () -withExeLBI pkg lbi f = - withAllTargetsInBuildOrder' pkg lbi $ \target -> - case targetComponent target of - CExe exe -> f exe (targetCLBI target) - _ -> return () - --- | Perform the action on each enabled 'Benchmark' in the package --- description. -withBenchLBI :: PackageDescription -> LocalBuildInfo - -> (Benchmark -> ComponentLocalBuildInfo -> IO ()) -> IO () -withBenchLBI pkg lbi f = - sequence_ [ f bench clbi | (bench, clbi) <- enabledBenchLBIs pkg lbi ] - -withTestLBI :: PackageDescription -> LocalBuildInfo - -> (TestSuite -> ComponentLocalBuildInfo -> IO ()) -> IO () -withTestLBI pkg lbi f = - sequence_ [ f test clbi | (test, clbi) <- enabledTestLBIs pkg lbi ] - -enabledTestLBIs :: PackageDescription -> LocalBuildInfo - -> [(TestSuite, ComponentLocalBuildInfo)] -enabledTestLBIs pkg lbi = - [ (test, targetCLBI target) - | target <- allTargetsInBuildOrder' pkg lbi - , CTest test <- [targetComponent target] ] - -enabledBenchLBIs :: PackageDescription -> LocalBuildInfo - -> [(Benchmark, ComponentLocalBuildInfo)] -enabledBenchLBIs pkg lbi = - [ (bench, targetCLBI target) - | target <- allTargetsInBuildOrder' pkg lbi - , CBench bench <- [targetComponent target] ] - --- | Perform the action on each buildable 'Library' or 'Executable' (Component) --- in the PackageDescription, subject to the build order specified by the --- 'compBuildOrder' field of the given 'LocalBuildInfo' -withAllComponentsInBuildOrder :: PackageDescription -> LocalBuildInfo - -> (Component -> ComponentLocalBuildInfo -> IO ()) - -> IO () -withAllComponentsInBuildOrder pkg lbi f = - withAllTargetsInBuildOrder' pkg lbi $ \target -> - f (targetComponent target) (targetCLBI target) - -allComponentsInBuildOrder :: LocalBuildInfo - -> [ComponentLocalBuildInfo] -allComponentsInBuildOrder lbi = - Graph.topSort (componentGraph lbi) - --- ----------------------------------------------------------------------------- --- A random function that has no business in this module - --- | Determine the directories containing the dynamic libraries of the --- transitive dependencies of the component we are building. --- --- When wanted, and possible, returns paths relative to the installDirs 'prefix' -depLibraryPaths :: Bool -- ^ Building for inplace? - -> Bool -- ^ Generate prefix-relative library paths - -> LocalBuildInfo - -> ComponentLocalBuildInfo -- ^ Component that is being built - -> IO [FilePath] -depLibraryPaths inplace relative lbi clbi = do - let pkgDescr = localPkgDescr lbi - installDirs = absoluteComponentInstallDirs pkgDescr lbi (componentUnitId clbi) NoCopyDest - executable = case clbi of - ExeComponentLocalBuildInfo {} -> True - _ -> False - relDir | executable = bindir installDirs - | otherwise = libdir installDirs - - let -- TODO: this is kind of inefficient - internalDeps = [ uid - | (uid, _) <- componentPackageDeps clbi - -- Test that it's internal - , sub_target <- allTargetsInBuildOrder' pkgDescr lbi - , componentUnitId (targetCLBI (sub_target)) == uid ] - internalLibs = [ getLibDir (targetCLBI sub_target) - | sub_target <- neededTargetsInBuildOrder' - pkgDescr lbi internalDeps ] - {- - -- This is better, but it doesn't work, because we may be passed a - -- CLBI which doesn't actually exist, and was faked up when we - -- were building a test suite/benchmark. See #3599 for proposal - -- to fix this. - let internalCLBIs = filter ((/= componentUnitId clbi) . componentUnitId) - . map targetCLBI - $ neededTargetsInBuildOrder lbi [componentUnitId clbi] - internalLibs = map getLibDir internalCLBIs - -} - getLibDir sub_clbi - | inplace = componentBuildDir lbi sub_clbi - | otherwise = dynlibdir (absoluteComponentInstallDirs pkgDescr lbi (componentUnitId sub_clbi) NoCopyDest) - - -- Why do we go through all the trouble of a hand-crafting - -- internalLibs, when 'installedPkgs' actually contains the - -- internal libraries? The trouble is that 'installedPkgs' - -- may contain *inplace* entries, which we must NOT use for - -- not inplace 'depLibraryPaths' (e.g., for RPATH calculation). - -- See #4025 for more details. This is all horrible but it - -- is a moot point if you are using a per-component build, - -- because you never have any internal libraries in this case; - -- they're all external. - let external_ipkgs = filter is_external (allPackages (installedPkgs lbi)) - is_external ipkg = not (installedUnitId ipkg `elem` internalDeps) - -- First look for dynamic libraries in `dynamic-library-dirs`, and use - -- `library-dirs` as a fall back. - getDynDir pkg = case Installed.libraryDynDirs pkg of - [] -> Installed.libraryDirs pkg - d -> d - allDepLibDirs = concatMap getDynDir external_ipkgs - - allDepLibDirs' = internalLibs ++ allDepLibDirs - allDepLibDirsC <- traverse canonicalizePathNoFail allDepLibDirs' - - let p = prefix installDirs - prefixRelative l = isJust (stripPrefix p l) - libPaths - | relative && - prefixRelative relDir = map (\l -> - if prefixRelative l - then shortRelativePath relDir l - else l - ) allDepLibDirsC - | otherwise = allDepLibDirsC - - return libPaths - where - -- 'canonicalizePath' fails on UNIX when the directory does not exists. - -- So just don't canonicalize when it doesn't exist. - canonicalizePathNoFail p = do - exists <- doesDirectoryExist p - if exists - then canonicalizePath p - else return p - --- | Get all module names that needed to be built by GHC; i.e., all --- of these 'ModuleName's have interface files associated with them --- that need to be installed. -allLibModules :: Library -> ComponentLocalBuildInfo -> [ModuleName] -allLibModules lib clbi = - ordNub $ - explicitLibModules lib ++ - case clbi of - LibComponentLocalBuildInfo { componentInstantiatedWith = insts } -> map fst insts - _ -> [] - --- ----------------------------------------------------------------------------- --- Wrappers for a couple functions from InstallDirs - --- | Backwards compatibility function which computes the InstallDirs --- assuming that @$libname@ points to the public library (or some fake --- package identifier if there is no public library.) IF AT ALL --- POSSIBLE, please use 'absoluteComponentInstallDirs' instead. -absoluteInstallDirs :: PackageDescription -> LocalBuildInfo - -> CopyDest - -> InstallDirs FilePath -absoluteInstallDirs pkg lbi copydest = - absoluteComponentInstallDirs pkg lbi (localUnitId lbi) copydest - --- | See 'InstallDirs.absoluteInstallDirs'. -absoluteComponentInstallDirs :: PackageDescription -> LocalBuildInfo - -> UnitId - -> CopyDest - -> InstallDirs FilePath -absoluteComponentInstallDirs pkg lbi uid copydest = - InstallDirs.absoluteInstallDirs - (packageId pkg) - uid - (compilerInfo (compiler lbi)) - copydest - (hostPlatform lbi) - (installDirTemplates lbi) - -absoluteInstallCommandDirs :: PackageDescription -> LocalBuildInfo - -> UnitId - -> CopyDest - -> InstallDirs FilePath -absoluteInstallCommandDirs pkg lbi uid copydest = - dirs { - -- Handle files which are not - -- per-component (data files and Haddock files.) - datadir = datadir dirs', - -- NB: The situation with Haddock is a bit delicate. On the - -- one hand, the easiest to understand Haddock documentation - -- path is pkgname-0.1, which means it's per-package (not - -- per-component). But this means that it's impossible to - -- install Haddock documentation for internal libraries. We'll - -- keep this constraint for now; this means you can't use - -- Cabal to Haddock internal libraries. This does not seem - -- like a big problem. - docdir = docdir dirs', - htmldir = htmldir dirs', - haddockdir = haddockdir dirs' - } - where - dirs = absoluteComponentInstallDirs pkg lbi uid copydest - -- Notice use of 'absoluteInstallDirs' (not the - -- per-component variant). This means for non-library - -- packages we'll just pick a nondescriptive foo-0.1 - dirs' = absoluteInstallDirs pkg lbi copydest - --- | Backwards compatibility function which computes the InstallDirs --- assuming that @$libname@ points to the public library (or some fake --- package identifier if there is no public library.) IF AT ALL --- POSSIBLE, please use 'prefixRelativeComponentInstallDirs' instead. -prefixRelativeInstallDirs :: PackageId -> LocalBuildInfo - -> InstallDirs (Maybe FilePath) -prefixRelativeInstallDirs pkg_descr lbi = - prefixRelativeComponentInstallDirs pkg_descr lbi (localUnitId lbi) - --- |See 'InstallDirs.prefixRelativeInstallDirs' -prefixRelativeComponentInstallDirs :: PackageId -> LocalBuildInfo - -> UnitId - -> InstallDirs (Maybe FilePath) -prefixRelativeComponentInstallDirs pkg_descr lbi uid = - InstallDirs.prefixRelativeInstallDirs - (packageId pkg_descr) - uid - (compilerInfo (compiler lbi)) - (hostPlatform lbi) - (installDirTemplates lbi) - -substPathTemplate :: PackageId -> LocalBuildInfo - -> UnitId - -> PathTemplate -> FilePath -substPathTemplate pkgid lbi uid = fromPathTemplate - . ( InstallDirs.substPathTemplate env ) - where env = initialPathTemplateEnv - pkgid - uid - (compilerInfo (compiler lbi)) - (hostPlatform lbi) - diff --git a/cabal/Cabal/Distribution/Simple/PackageIndex.hs b/cabal/Cabal/Distribution/Simple/PackageIndex.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/PackageIndex.hs +++ /dev/null @@ -1,716 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.PackageIndex --- Copyright : (c) David Himmelstrup 2005, --- Bjorn Bringert 2007, --- Duncan Coutts 2008-2009 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- An index of packages whose primary key is 'UnitId'. Public libraries --- are additionally indexed by 'PackageName' and 'Version'. --- Technically, these are an index of *units* (so we should eventually --- rename it to 'UnitIndex'); but in the absence of internal libraries --- or Backpack each unit is equivalent to a package. --- --- While 'PackageIndex' is parametric over what it actually records, --- it is in fact only ever instantiated with a single element: --- The 'InstalledPackageIndex' (defined here) contains a graph of --- 'InstalledPackageInfo's representing the packages in a --- package database stack. It is used in a variety of ways: --- --- * The primary use to let Cabal access the same installed --- package database which is used by GHC during compilation. --- For example, this data structure is used by 'ghc-pkg' --- and 'Cabal' to do consistency checks on the database --- (are the references closed). --- --- * Given a set of dependencies, we can compute the transitive --- closure of dependencies. This is to check if the versions --- of packages are consistent, and also needed by multiple --- tools (Haddock must be explicitly told about the every --- transitive package to do cross-package linking; --- preprocessors must know about the include paths of all --- transitive dependencies.) --- --- This 'PackageIndex' is NOT to be confused with --- 'Distribution.Client.PackageIndex', which indexes packages only by --- 'PackageName' (this makes it suitable for indexing source packages, --- for which we don't know 'UnitId's.) --- -module Distribution.Simple.PackageIndex ( - -- * Package index data type - InstalledPackageIndex, - PackageIndex, - - -- * Creating an index - fromList, - - -- * Updates - merge, - - insert, - - deleteUnitId, - deleteSourcePackageId, - deletePackageName, --- deleteDependency, - - -- * Queries - - -- ** Precise lookups - lookupUnitId, - lookupComponentId, - lookupSourcePackageId, - lookupPackageId, - lookupPackageName, - lookupDependency, - lookupInternalDependency, - - -- ** Case-insensitive searches - searchByName, - SearchResult(..), - searchByNameSubstring, - searchWithPredicate, - - -- ** Bulk queries - allPackages, - allPackagesByName, - allPackagesBySourcePackageId, - allPackagesBySourcePackageIdAndLibName, - - -- ** Special queries - brokenPackages, - dependencyClosure, - reverseDependencyClosure, - topologicalOrder, - reverseTopologicalOrder, - dependencyInconsistencies, - dependencyCycles, - dependencyGraph, - moduleNameIndex - ) where - -import Prelude () -import Distribution.Compat.Prelude hiding (lookup) -import qualified Data.Map.Strict as Map - -import Distribution.Package -import Distribution.Backpack -import Distribution.ModuleName -import qualified Distribution.InstalledPackageInfo as IPI -import Distribution.Version -import Distribution.Simple.Utils -import Distribution.Types.LibraryName - -import Control.Exception (assert) -import Data.Array ((!)) -import qualified Data.Array as Array -import qualified Data.Graph as Graph -import Data.List as List ( groupBy, deleteBy, deleteFirstsBy ) -import qualified Data.List.NonEmpty as NE -import qualified Data.Tree as Tree -import Control.Monad -import Distribution.Compat.Stack - -import qualified Prelude (foldr1) - --- | The collection of information about packages from one or more 'PackageDB's. --- These packages generally should have an instance of 'PackageInstalled' --- --- Packages are uniquely identified in by their 'UnitId', they can --- also be efficiently looked up by package name or by name and version. --- -data PackageIndex a = PackageIndex { - -- The primary index. Each InstalledPackageInfo record is uniquely identified - -- by its UnitId. - -- - unitIdIndex :: !(Map UnitId a), - - -- This auxiliary index maps package names (case-sensitively) to all the - -- versions and instances of that package. This allows us to find all - -- versions satisfying a dependency. - -- - -- It is a three-level index. The first level is the package name, - -- the second is the package version and the final level is instances - -- of the same package version. These are unique by UnitId - -- and are kept in preference order. - -- - -- FIXME: Clarify what "preference order" means. Check that this invariant is - -- preserved. See #1463 for discussion. - packageIdIndex :: !(Map (PackageName, LibraryName) (Map Version [a])) - - } deriving (Eq, Generic, Show, Read, Typeable) - -instance Binary a => Binary (PackageIndex a) -instance Structured a => Structured (PackageIndex a) - --- | The default package index which contains 'InstalledPackageInfo'. Normally --- use this. -type InstalledPackageIndex = PackageIndex IPI.InstalledPackageInfo - -instance Monoid (PackageIndex IPI.InstalledPackageInfo) where - mempty = PackageIndex Map.empty Map.empty - mappend = (<>) - --save one mappend with empty in the common case: - mconcat [] = mempty - mconcat xs = Prelude.foldr1 mappend xs - -instance Semigroup (PackageIndex IPI.InstalledPackageInfo) where - (<>) = merge - -{-# NOINLINE invariant #-} -invariant :: WithCallStack (InstalledPackageIndex -> Bool) -invariant (PackageIndex pids pnames) = - -- trace (show pids' ++ "\n" ++ show pnames') $ - pids' == pnames' - where - pids' = map installedUnitId (Map.elems pids) - pnames' = sort - [ assert pinstOk (installedUnitId pinst) - | ((pname, plib), pvers) <- Map.toList pnames - , let pversOk = not (Map.null pvers) - , (pver, pinsts) <- assert pversOk $ Map.toList pvers - , let pinsts' = sortBy (comparing installedUnitId) pinsts - pinstsOk = all (\g -> length g == 1) - (groupBy (equating installedUnitId) pinsts') - , pinst <- assert pinstsOk $ pinsts' - , let pinstOk = packageName pinst == pname - && packageVersion pinst == pver - && IPI.sourceLibName pinst == plib - ] - -- If you see this invariant failing (ie the assert in mkPackageIndex below) - -- then one thing to check is if it is happening in fromList. Check if the - -- second list above (the sort [...] bit) is ending up with duplicates. This - -- has been observed in practice once due to a messed up ghc-pkg db. How/why - -- it became messed up was not discovered. - - --- --- * Internal helpers --- - -mkPackageIndex :: WithCallStack (Map UnitId IPI.InstalledPackageInfo - -> Map (PackageName, LibraryName) - (Map Version [IPI.InstalledPackageInfo]) - -> InstalledPackageIndex) -mkPackageIndex pids pnames = assert (invariant index) index - where index = PackageIndex pids pnames - - --- --- * Construction --- - --- | Build an index out of a bunch of packages. --- --- If there are duplicates by 'UnitId' then later ones mask earlier --- ones. --- -fromList :: [IPI.InstalledPackageInfo] -> InstalledPackageIndex -fromList pkgs = mkPackageIndex pids ((fmap . fmap) toList pnames) - where - pids = Map.fromList [ (installedUnitId pkg, pkg) | pkg <- pkgs ] - pnames = - Map.fromList - [ (liftM2 (,) packageName IPI.sourceLibName (NE.head pkgsN), pvers) - | pkgsN <- NE.groupBy (equating (liftM2 (,) packageName IPI.sourceLibName)) - . sortBy (comparing (liftM3 (,,) packageName IPI.sourceLibName packageVersion)) - $ pkgs - , let pvers = - Map.fromList - [ (packageVersion (NE.head pkgsNV), - NE.nubBy (equating installedUnitId) (NE.reverse pkgsNV)) - | pkgsNV <- NE.groupBy (equating packageVersion) pkgsN - ] - ] - --- --- * Updates --- - --- | Merge two indexes. --- --- Packages from the second mask packages from the first if they have the exact --- same 'UnitId'. --- --- For packages with the same source 'PackageId', packages from the second are --- \"preferred\" over those from the first. Being preferred means they are top --- result when we do a lookup by source 'PackageId'. This is the mechanism we --- use to prefer user packages over global packages. --- -merge :: InstalledPackageIndex -> InstalledPackageIndex - -> InstalledPackageIndex -merge (PackageIndex pids1 pnames1) (PackageIndex pids2 pnames2) = - mkPackageIndex (Map.unionWith (\_ y -> y) pids1 pids2) - (Map.unionWith (Map.unionWith mergeBuckets) pnames1 pnames2) - where - -- Packages in the second list mask those in the first, however preferred - -- packages go first in the list. - mergeBuckets xs ys = ys ++ (xs \\ ys) - (\\) = deleteFirstsBy (equating installedUnitId) - - --- | Inserts a single package into the index. --- --- This is equivalent to (but slightly quicker than) using 'mappend' or --- 'merge' with a singleton index. --- -insert :: IPI.InstalledPackageInfo -> InstalledPackageIndex -> InstalledPackageIndex -insert pkg (PackageIndex pids pnames) = - mkPackageIndex pids' pnames' - - where - pids' = Map.insert (installedUnitId pkg) pkg pids - pnames' = insertPackageName pnames - insertPackageName = - Map.insertWith (\_ -> insertPackageVersion) - (packageName pkg, IPI.sourceLibName pkg) - (Map.singleton (packageVersion pkg) [pkg]) - - insertPackageVersion = - Map.insertWith (\_ -> insertPackageInstance) - (packageVersion pkg) [pkg] - - insertPackageInstance pkgs = - pkg : deleteBy (equating installedUnitId) pkg pkgs - - --- | Removes a single installed package from the index. --- -deleteUnitId :: UnitId -> InstalledPackageIndex - -> InstalledPackageIndex -deleteUnitId ipkgid original@(PackageIndex pids pnames) = - case Map.updateLookupWithKey (\_ _ -> Nothing) ipkgid pids of - (Nothing, _) -> original - (Just spkgid, pids') -> mkPackageIndex pids' - (deletePkgName spkgid pnames) - - where - deletePkgName spkgid = - Map.update (deletePkgVersion spkgid) (packageName spkgid, IPI.sourceLibName spkgid) - - deletePkgVersion spkgid = - (\m -> if Map.null m then Nothing else Just m) - . Map.update deletePkgInstance (packageVersion spkgid) - - deletePkgInstance = - (\xs -> if null xs then Nothing else Just xs) - . List.deleteBy (\_ pkg -> installedUnitId pkg == ipkgid) undefined - --- | Removes all packages with this source 'PackageId' from the index. --- -deleteSourcePackageId :: PackageId -> InstalledPackageIndex - -> InstalledPackageIndex -deleteSourcePackageId pkgid original@(PackageIndex pids pnames) = - -- NB: Doesn't delete internal packages - case Map.lookup (packageName pkgid, LMainLibName) pnames of - Nothing -> original - Just pvers -> case Map.lookup (packageVersion pkgid) pvers of - Nothing -> original - Just pkgs -> mkPackageIndex - (foldl' (flip (Map.delete . installedUnitId)) pids pkgs) - (deletePkgName pnames) - where - deletePkgName = - Map.update deletePkgVersion (packageName pkgid, LMainLibName) - - deletePkgVersion = - (\m -> if Map.null m then Nothing else Just m) - . Map.delete (packageVersion pkgid) - - --- | Removes all packages with this (case-sensitive) name from the index. --- --- NB: Does NOT delete internal libraries from this package. --- -deletePackageName :: PackageName -> InstalledPackageIndex - -> InstalledPackageIndex -deletePackageName name original@(PackageIndex pids pnames) = - case Map.lookup (name, LMainLibName) pnames of - Nothing -> original - Just pvers -> mkPackageIndex - (foldl' (flip (Map.delete . installedUnitId)) pids - (concat (Map.elems pvers))) - (Map.delete (name, LMainLibName) pnames) - -{- --- | Removes all packages satisfying this dependency from the index. --- -deleteDependency :: Dependency -> PackageIndex -> PackageIndex -deleteDependency (Dependency name verstionRange) = - delete' name (\pkg -> packageVersion pkg `withinRange` verstionRange) --} - --- --- * Bulk queries --- - --- | Get all the packages from the index. --- -allPackages :: PackageIndex a -> [a] -allPackages = Map.elems . unitIdIndex - --- | Get all the packages from the index. --- --- They are grouped by package name (case-sensitively). --- --- (Doesn't include private libraries.) --- -allPackagesByName :: PackageIndex a -> [(PackageName, [a])] -allPackagesByName index = - [ (pkgname, concat (Map.elems pvers)) - | ((pkgname, LMainLibName), pvers) <- Map.toList (packageIdIndex index) ] - --- | Get all the packages from the index. --- --- They are grouped by source package id (package name and version). --- --- (Doesn't include private libraries) --- -allPackagesBySourcePackageId :: HasUnitId a => PackageIndex a - -> [(PackageId, [a])] -allPackagesBySourcePackageId index = - [ (packageId ipkg, ipkgs) - | ((_, LMainLibName), pvers) <- Map.toList (packageIdIndex index) - , ipkgs@(ipkg:_) <- Map.elems pvers ] - --- | Get all the packages from the index. --- --- They are grouped by source package id and library name. --- --- This DOES include internal libraries. -allPackagesBySourcePackageIdAndLibName :: HasUnitId a => PackageIndex a - -> [((PackageId, LibraryName), [a])] -allPackagesBySourcePackageIdAndLibName index = - [ ((packageId ipkg, ln), ipkgs) - | ((_, ln), pvers) <- Map.toList (packageIdIndex index) - , ipkgs@(ipkg:_) <- Map.elems pvers ] - --- --- * Lookups --- - --- | Does a lookup by unit identifier. --- --- Since multiple package DBs mask each other by 'UnitId', --- then we get back at most one package. --- -lookupUnitId :: PackageIndex a -> UnitId - -> Maybe a -lookupUnitId index uid = Map.lookup uid (unitIdIndex index) - --- | Does a lookup by component identifier. In the absence --- of Backpack, this is just a 'lookupUnitId'. --- -lookupComponentId :: PackageIndex a -> ComponentId - -> Maybe a -lookupComponentId index cid = - Map.lookup (newSimpleUnitId cid) (unitIdIndex index) - --- | Does a lookup by source package id (name & version). --- --- There can be multiple installed packages with the same source 'PackageId' --- but different 'UnitId'. They are returned in order of --- preference, with the most preferred first. --- -lookupSourcePackageId :: PackageIndex a -> PackageId -> [a] -lookupSourcePackageId index pkgid = - -- Do not lookup internal libraries - case Map.lookup (packageName pkgid, LMainLibName) (packageIdIndex index) of - Nothing -> [] - Just pvers -> case Map.lookup (packageVersion pkgid) pvers of - Nothing -> [] - Just pkgs -> pkgs -- in preference order - --- | Convenient alias of 'lookupSourcePackageId', but assuming only --- one package per package ID. -lookupPackageId :: PackageIndex a -> PackageId -> Maybe a -lookupPackageId index pkgid = case lookupSourcePackageId index pkgid of - [] -> Nothing - [pkg] -> Just pkg - _ -> error "Distribution.Simple.PackageIndex: multiple matches found" - --- | Does a lookup by source package name. --- -lookupPackageName :: PackageIndex a -> PackageName - -> [(Version, [a])] -lookupPackageName index name = - -- Do not match internal libraries - case Map.lookup (name, LMainLibName) (packageIdIndex index) of - Nothing -> [] - Just pvers -> Map.toList pvers - - --- | Does a lookup by source package name and a range of versions. --- --- We get back any number of versions of the specified package name, all --- satisfying the version range constraint. --- --- This does NOT work for internal dependencies, DO NOT use this --- function on those; use 'lookupInternalDependency' instead. --- --- INVARIANT: List of eligible 'IPI.InstalledPackageInfo' is non-empty. --- -lookupDependency :: InstalledPackageIndex -> PackageName -> VersionRange - -> [(Version, [IPI.InstalledPackageInfo])] -lookupDependency index pn vr = - -- Yes, a little bit of a misnomer here! - lookupInternalDependency index pn vr LMainLibName - --- | Does a lookup by source package name and a range of versions. --- --- We get back any number of versions of the specified package name, all --- satisfying the version range constraint. --- --- INVARIANT: List of eligible 'IPI.InstalledPackageInfo' is non-empty. --- -lookupInternalDependency :: InstalledPackageIndex -> PackageName -> VersionRange - -> LibraryName - -> [(Version, [IPI.InstalledPackageInfo])] -lookupInternalDependency index name versionRange libn = - case Map.lookup (name, libn) (packageIdIndex index) of - Nothing -> [] - Just pvers -> [ (ver, pkgs') - | (ver, pkgs) <- Map.toList pvers - , ver `withinRange` versionRange - , let pkgs' = filter eligible pkgs - -- Enforce the invariant - , not (null pkgs') - ] - where - -- When we select for dependencies, we ONLY want to pick up indefinite - -- packages, or packages with no instantiations. We'll do mix-in - -- linking to improve any such package into an instantiated one - -- later. - eligible pkg = IPI.indefinite pkg || null (IPI.instantiatedWith pkg) - - --- --- * Case insensitive name lookups --- - --- | Does a case-insensitive search by package name. --- --- If there is only one package that compares case-insensitively to this name --- then the search is unambiguous and we get back all versions of that package. --- If several match case-insensitively but one matches exactly then it is also --- unambiguous. --- --- If however several match case-insensitively and none match exactly then we --- have an ambiguous result, and we get back all the versions of all the --- packages. The list of ambiguous results is split by exact package name. So --- it is a non-empty list of non-empty lists. --- -searchByName :: PackageIndex a -> String -> SearchResult [a] -searchByName index name = - -- Don't match internal packages - case [ pkgs | pkgs@((pname, LMainLibName),_) <- Map.toList (packageIdIndex index) - , lowercase (unPackageName pname) == lname ] of - [] -> None - [(_,pvers)] -> Unambiguous (concat (Map.elems pvers)) - pkgss -> case find ((mkPackageName name ==) . fst . fst) pkgss of - Just (_,pvers) -> Unambiguous (concat (Map.elems pvers)) - Nothing -> Ambiguous (map (concat . Map.elems . snd) pkgss) - where lname = lowercase name - -data SearchResult a = None | Unambiguous a | Ambiguous [a] - --- | Does a case-insensitive substring search by package name. --- --- That is, all packages that contain the given string in their name. --- -searchByNameSubstring :: PackageIndex a -> String -> [a] -searchByNameSubstring index searchterm = - searchWithPredicate index (\n -> lsearchterm `isInfixOf` lowercase n) - where lsearchterm = lowercase searchterm - --- | @since 3.4.0.0 -searchWithPredicate :: PackageIndex a -> (String -> Bool) -> [a] -searchWithPredicate index predicate = - [ pkg - -- Don't match internal packages - | ((pname, LMainLibName), pvers) <- Map.toList (packageIdIndex index) - , predicate (unPackageName pname) - , pkgs <- Map.elems pvers - , pkg <- pkgs ] - --- --- * Special queries --- - --- None of the stuff below depends on the internal representation of the index. --- - --- | Find if there are any cycles in the dependency graph. If there are no --- cycles the result is @[]@. --- --- This actually computes the strongly connected components. So it gives us a --- list of groups of packages where within each group they all depend on each --- other, directly or indirectly. --- -dependencyCycles :: PackageInstalled a => PackageIndex a -> [[a]] -dependencyCycles index = - [ vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList ] - where - adjacencyList = [ (pkg, installedUnitId pkg, installedDepends pkg) - | pkg <- allPackages index ] - - --- | All packages that have immediate dependencies that are not in the index. --- --- Returns such packages along with the dependencies that they're missing. --- -brokenPackages :: PackageInstalled a => PackageIndex a - -> [(a, [UnitId])] -brokenPackages index = - [ (pkg, missing) - | pkg <- allPackages index - , let missing = [ pkg' | pkg' <- installedDepends pkg - , isNothing (lookupUnitId index pkg') ] - , not (null missing) ] - --- | Tries to take the transitive closure of the package dependencies. --- --- If the transitive closure is complete then it returns that subset of the --- index. Otherwise it returns the broken packages as in 'brokenPackages'. --- --- * Note that if the result is @Right []@ it is because at least one of --- the original given 'PackageId's do not occur in the index. --- -dependencyClosure :: InstalledPackageIndex - -> [UnitId] - -> Either (InstalledPackageIndex) - [(IPI.InstalledPackageInfo, [UnitId])] -dependencyClosure index pkgids0 = case closure mempty [] pkgids0 of - (completed, []) -> Left completed - (completed, _) -> Right (brokenPackages completed) - where - closure completed failed [] = (completed, failed) - closure completed failed (pkgid:pkgids) = case lookupUnitId index pkgid of - Nothing -> closure completed (pkgid:failed) pkgids - Just pkg -> case lookupUnitId completed (installedUnitId pkg) of - Just _ -> closure completed failed pkgids - Nothing -> closure completed' failed pkgids' - where completed' = insert pkg completed - pkgids' = installedDepends pkg ++ pkgids - --- | Takes the transitive closure of the packages reverse dependencies. --- --- * The given 'PackageId's must be in the index. --- -reverseDependencyClosure :: PackageInstalled a => PackageIndex a - -> [UnitId] - -> [a] -reverseDependencyClosure index = - map vertexToPkg - . concatMap Tree.flatten - . Graph.dfs reverseDepGraph - . map (fromMaybe noSuchPkgId . pkgIdToVertex) - - where - (depGraph, vertexToPkg, pkgIdToVertex) = dependencyGraph index - reverseDepGraph = Graph.transposeG depGraph - noSuchPkgId = error "reverseDependencyClosure: package is not in the graph" - -topologicalOrder :: PackageInstalled a => PackageIndex a -> [a] -topologicalOrder index = map toPkgId - . Graph.topSort - $ graph - where (graph, toPkgId, _) = dependencyGraph index - -reverseTopologicalOrder :: PackageInstalled a => PackageIndex a -> [a] -reverseTopologicalOrder index = map toPkgId - . Graph.topSort - . Graph.transposeG - $ graph - where (graph, toPkgId, _) = dependencyGraph index - --- | Builds a graph of the package dependencies. --- --- Dependencies on other packages that are not in the index are discarded. --- You can check if there are any such dependencies with 'brokenPackages'. --- -dependencyGraph :: PackageInstalled a => PackageIndex a - -> (Graph.Graph, - Graph.Vertex -> a, - UnitId -> Maybe Graph.Vertex) -dependencyGraph index = (graph, vertex_to_pkg, id_to_vertex) - where - graph = Array.listArray bounds - [ [ v | Just v <- map id_to_vertex (installedDepends pkg) ] - | pkg <- pkgs ] - - pkgs = sortBy (comparing packageId) (allPackages index) - vertices = zip (map installedUnitId pkgs) [0..] - vertex_map = Map.fromList vertices - id_to_vertex pid = Map.lookup pid vertex_map - - vertex_to_pkg vertex = pkgTable ! vertex - - pkgTable = Array.listArray bounds pkgs - topBound = length pkgs - 1 - bounds = (0, topBound) - --- | We maintain the invariant that, for any 'DepUniqueKey', there --- is only one instance of the package in our database. -type DepUniqueKey = (PackageName, LibraryName, Map ModuleName OpenModule) - --- | Given a package index where we assume we want to use all the packages --- (use 'dependencyClosure' if you need to get such a index subset) find out --- if the dependencies within it use consistent versions of each package. --- Return all cases where multiple packages depend on different versions of --- some other package. --- --- Each element in the result is a package name along with the packages that --- depend on it and the versions they require. These are guaranteed to be --- distinct. --- -dependencyInconsistencies :: InstalledPackageIndex - -- At DepUniqueKey... - -> [(DepUniqueKey, - -- There were multiple packages (BAD!) - [(UnitId, - -- And here are the packages which - -- immediately depended on it - [IPI.InstalledPackageInfo])])] -dependencyInconsistencies index = do - (dep_key, insts_map) <- Map.toList inverseIndex - let insts = Map.toList insts_map - guard (length insts >= 2) - return (dep_key, insts) - where - inverseIndex :: Map DepUniqueKey (Map UnitId [IPI.InstalledPackageInfo]) - inverseIndex = Map.fromListWith (Map.unionWith (++)) $ do - pkg <- allPackages index - dep_ipid <- installedDepends pkg - Just dep <- [lookupUnitId index dep_ipid] - let dep_key = (packageName dep, IPI.sourceLibName dep, - Map.fromList (IPI.instantiatedWith dep)) - return (dep_key, Map.singleton dep_ipid [pkg]) - --- | A rough approximation of GHC's module finder, takes a --- 'InstalledPackageIndex' and turns it into a map from module names to their --- source packages. It's used to initialize the @build-deps@ field in @cabal --- init@. -moduleNameIndex :: InstalledPackageIndex -> Map ModuleName [IPI.InstalledPackageInfo] -moduleNameIndex index = - Map.fromListWith (++) $ do - pkg <- allPackages index - IPI.ExposedModule m reexport <- IPI.exposedModules pkg - case reexport of - Nothing -> return (m, [pkg]) - Just (OpenModuleVar _) -> [] - Just (OpenModule _ m') | m == m' -> [] - | otherwise -> return (m', [pkg]) - -- The heuristic is this: we want to prefer the original package - -- which originally exported a module. However, if a reexport - -- also *renamed* the module (m /= m'), then we have to use the - -- downstream package, since the upstream package has the wrong - -- module name! diff --git a/cabal/Cabal/Distribution/Simple/PreProcess.hs b/cabal/Cabal/Distribution/Simple/PreProcess.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/PreProcess.hs +++ /dev/null @@ -1,751 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.PreProcess --- Copyright : (c) 2003-2005, Isaac Jones, Malcolm Wallace --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This defines a 'PreProcessor' abstraction which represents a pre-processor --- that can transform one kind of file into another. There is also a --- 'PPSuffixHandler' which is a combination of a file extension and a function --- for configuring a 'PreProcessor'. It defines a bunch of known built-in --- preprocessors like @cpp@, @cpphs@, @c2hs@, @hsc2hs@, @happy@, @alex@ etc and --- lists them in 'knownSuffixHandlers'. On top of this it provides a function --- for actually preprocessing some sources given a bunch of known suffix --- handlers. This module is not as good as it could be, it could really do with --- a rewrite to address some of the problems we have with pre-processors. - -module Distribution.Simple.PreProcess (preprocessComponent, preprocessExtras, - knownSuffixHandlers, ppSuffixes, - PPSuffixHandler, PreProcessor(..), - mkSimplePreProcessor, runSimplePreProcessor, - ppCpp, ppCpp', ppGreenCard, ppC2hs, ppHsc2hs, - ppHappy, ppAlex, ppUnlit, platformDefines - ) - where - -import Prelude () -import Distribution.Compat.Prelude -import Distribution.Compat.Stack - -import Distribution.Simple.PreProcess.Unlit -import Distribution.Backpack.DescribeUnitId -import Distribution.Package -import qualified Distribution.ModuleName as ModuleName -import Distribution.ModuleName (ModuleName) -import Distribution.PackageDescription as PD -import qualified Distribution.InstalledPackageInfo as Installed -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.CCompiler -import Distribution.Simple.Compiler -import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.BuildPaths -import Distribution.Simple.Utils -import Distribution.Simple.Program -import Distribution.Simple.Program.ResponseFile -import Distribution.Simple.Test.LibV09 -import Distribution.System -import Distribution.Pretty -import Distribution.Version -import Distribution.Verbosity - -import System.Directory (doesFileExist) -import System.Info (os, arch) -import System.FilePath (splitExtension, dropExtensions, (), (<.>), - takeDirectory, normalise, replaceExtension, - takeExtensions) - --- |The interface to a preprocessor, which may be implemented using an --- external program, but need not be. The arguments are the name of --- the input file, the name of the output file and a verbosity level. --- Here is a simple example that merely prepends a comment to the given --- source file: --- --- > ppTestHandler :: PreProcessor --- > ppTestHandler = --- > PreProcessor { --- > platformIndependent = True, --- > runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> --- > do info verbosity (inFile++" has been preprocessed to "++outFile) --- > stuff <- readFile inFile --- > writeFile outFile ("-- preprocessed as a test\n\n" ++ stuff) --- > return ExitSuccess --- --- We split the input and output file names into a base directory and the --- rest of the file name. The input base dir is the path in the list of search --- dirs that this file was found in. The output base dir is the build dir where --- all the generated source files are put. --- --- The reason for splitting it up this way is that some pre-processors don't --- simply generate one output .hs file from one input file but have --- dependencies on other generated files (notably c2hs, where building one --- .hs file may require reading other .chi files, and then compiling the .hs --- file may require reading a generated .h file). In these cases the generated --- files need to embed relative path names to each other (eg the generated .hs --- file mentions the .h file in the FFI imports). This path must be relative to --- the base directory where the generated files are located, it cannot be --- relative to the top level of the build tree because the compilers do not --- look for .h files relative to there, ie we do not use \"-I .\", instead we --- use \"-I dist\/build\" (or whatever dist dir has been set by the user) --- --- Most pre-processors do not care of course, so mkSimplePreProcessor and --- runSimplePreProcessor functions handle the simple case. --- -data PreProcessor = PreProcessor { - - -- Is the output of the pre-processor platform independent? eg happy output - -- is portable haskell but c2hs's output is platform dependent. - -- This matters since only platform independent generated code can be - -- included into a source tarball. - platformIndependent :: Bool, - - -- TODO: deal with pre-processors that have implementation dependent output - -- eg alex and happy have --ghc flags. However we can't really include - -- ghc-specific code into supposedly portable source tarballs. - - runPreProcessor :: (FilePath, FilePath) -- Location of the source file relative to a base dir - -> (FilePath, FilePath) -- Output file name, relative to an output base dir - -> Verbosity -- verbosity - -> IO () -- Should exit if the preprocessor fails - } - --- | Function to determine paths to possible extra C sources for a --- preprocessor: just takes the path to the build directory and uses --- this to search for C sources with names that match the --- preprocessor's output name format. -type PreProcessorExtras = FilePath -> IO [FilePath] - - -mkSimplePreProcessor :: (FilePath -> FilePath -> Verbosity -> IO ()) - -> (FilePath, FilePath) - -> (FilePath, FilePath) -> Verbosity -> IO () -mkSimplePreProcessor simplePP - (inBaseDir, inRelativeFile) - (outBaseDir, outRelativeFile) verbosity = simplePP inFile outFile verbosity - where inFile = normalise (inBaseDir inRelativeFile) - outFile = normalise (outBaseDir outRelativeFile) - -runSimplePreProcessor :: PreProcessor -> FilePath -> FilePath -> Verbosity - -> IO () -runSimplePreProcessor pp inFile outFile verbosity = - runPreProcessor pp (".", inFile) (".", outFile) verbosity - --- |A preprocessor for turning non-Haskell files with the given extension --- into plain Haskell source files. -type PPSuffixHandler - = (String, BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor) - --- | Apply preprocessors to the sources from 'hsSourceDirs' for a given --- component (lib, exe, or test suite). -preprocessComponent :: PackageDescription - -> Component - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> Bool - -> Verbosity - -> [PPSuffixHandler] - -> IO () -preprocessComponent pd comp lbi clbi isSrcDist verbosity handlers = do - -- NB: never report instantiation here; we'll report it properly when - -- building. - setupMessage' verbosity "Preprocessing" (packageId pd) - (componentLocalName clbi) (Nothing :: Maybe [(ModuleName, Module)]) - case comp of - (CLib lib@Library{ libBuildInfo = bi }) -> do - let dirs = hsSourceDirs bi ++ [autogenComponentModulesDir lbi clbi - ,autogenPackageModulesDir lbi] - for_ (map ModuleName.toFilePath $ allLibModules lib clbi) $ - pre dirs (componentBuildDir lbi clbi) (localHandlers bi) - (CFLib flib@ForeignLib { foreignLibBuildInfo = bi, foreignLibName = nm }) -> do - let nm' = unUnqualComponentName nm - let flibDir = buildDir lbi nm' nm' ++ "-tmp" - dirs = hsSourceDirs bi ++ [autogenComponentModulesDir lbi clbi - ,autogenPackageModulesDir lbi] - for_ (map ModuleName.toFilePath $ foreignLibModules flib) $ - pre dirs flibDir (localHandlers bi) - (CExe exe@Executable { buildInfo = bi, exeName = nm }) -> do - let nm' = unUnqualComponentName nm - let exeDir = buildDir lbi nm' nm' ++ "-tmp" - dirs = hsSourceDirs bi ++ [autogenComponentModulesDir lbi clbi - ,autogenPackageModulesDir lbi] - for_ (map ModuleName.toFilePath $ otherModules bi) $ - pre dirs exeDir (localHandlers bi) - pre (hsSourceDirs bi) exeDir (localHandlers bi) $ - dropExtensions (modulePath exe) - CTest test@TestSuite{ testName = nm } -> do - let nm' = unUnqualComponentName nm - case testInterface test of - TestSuiteExeV10 _ f -> - preProcessTest test f $ buildDir lbi nm' nm' ++ "-tmp" - TestSuiteLibV09 _ _ -> do - let testDir = buildDir lbi stubName test - stubName test ++ "-tmp" - writeSimpleTestStub test testDir - preProcessTest test (stubFilePath test) testDir - TestSuiteUnsupported tt -> - die' verbosity $ "No support for preprocessing test " - ++ "suite type " ++ prettyShow tt - CBench bm@Benchmark{ benchmarkName = nm } -> do - let nm' = unUnqualComponentName nm - case benchmarkInterface bm of - BenchmarkExeV10 _ f -> - preProcessBench bm f $ buildDir lbi nm' nm' ++ "-tmp" - BenchmarkUnsupported tt -> - die' verbosity $ "No support for preprocessing benchmark " - ++ "type " ++ prettyShow tt - where - builtinHaskellSuffixes = ["hs", "lhs", "hsig", "lhsig"] - builtinCSuffixes = cSourceExtensions - builtinSuffixes = builtinHaskellSuffixes ++ builtinCSuffixes - localHandlers bi = [(ext, h bi lbi clbi) | (ext, h) <- handlers] - pre dirs dir lhndlrs fp = - preprocessFile dirs dir isSrcDist fp verbosity builtinSuffixes lhndlrs - preProcessTest test = preProcessComponent (testBuildInfo test) - (testModules test) - preProcessBench bm = preProcessComponent (benchmarkBuildInfo bm) - (benchmarkModules bm) - preProcessComponent bi modules exePath dir = do - let biHandlers = localHandlers bi - sourceDirs = hsSourceDirs bi ++ [ autogenComponentModulesDir lbi clbi - , autogenPackageModulesDir lbi ] - sequence_ [ preprocessFile sourceDirs dir isSrcDist - (ModuleName.toFilePath modu) verbosity builtinSuffixes - biHandlers - | modu <- modules ] - preprocessFile (dir : (hsSourceDirs bi)) dir isSrcDist - (dropExtensions $ exePath) verbosity - builtinSuffixes biHandlers - ---TODO: try to list all the modules that could not be found --- not just the first one. It's annoying and slow due to the need --- to reconfigure after editing the .cabal file each time. - --- |Find the first extension of the file that exists, and preprocess it --- if required. -preprocessFile - :: [FilePath] -- ^source directories - -> FilePath -- ^build directory - -> Bool -- ^preprocess for sdist - -> FilePath -- ^module file name - -> Verbosity -- ^verbosity - -> [String] -- ^builtin suffixes - -> [(String, PreProcessor)] -- ^possible preprocessors - -> IO () -preprocessFile searchLoc buildLoc forSDist baseFile verbosity builtinSuffixes handlers = do - -- look for files in the various source dirs with this module name - -- and a file extension of a known preprocessor - psrcFiles <- findFileWithExtension' (map fst handlers) searchLoc baseFile - case psrcFiles of - -- no preprocessor file exists, look for an ordinary source file - -- just to make sure one actually exists at all for this module. - -- Note: by looking in the target/output build dir too, we allow - -- source files to appear magically in the target build dir without - -- any corresponding "real" source file. This lets custom Setup.hs - -- files generate source modules directly into the build dir without - -- the rest of the build system being aware of it (somewhat dodgy) - Nothing -> do - bsrcFiles <- findFileWithExtension builtinSuffixes (buildLoc : searchLoc) baseFile - case bsrcFiles of - Nothing -> - die' verbosity $ "can't find source for " ++ baseFile - ++ " in " ++ intercalate ", " searchLoc - _ -> return () - -- found a pre-processable file in one of the source dirs - Just (psrcLoc, psrcRelFile) -> do - let (srcStem, ext) = splitExtension psrcRelFile - psrcFile = psrcLoc psrcRelFile - pp = fromMaybe (error "Distribution.Simple.PreProcess: Just expected") - (lookup (safeTail ext) handlers) - -- Preprocessing files for 'sdist' is different from preprocessing - -- for 'build'. When preprocessing for sdist we preprocess to - -- avoid that the user has to have the preprocessors available. - -- ATM, we don't have a way to specify which files are to be - -- preprocessed and which not, so for sdist we only process - -- platform independent files and put them into the 'buildLoc' - -- (which we assume is set to the temp. directory that will become - -- the tarball). - --TODO: eliminate sdist variant, just supply different handlers - when (not forSDist || forSDist && platformIndependent pp) $ do - -- look for existing pre-processed source file in the dest dir to - -- see if we really have to re-run the preprocessor. - ppsrcFiles <- findFileWithExtension builtinSuffixes [buildLoc] baseFile - recomp <- case ppsrcFiles of - Nothing -> return True - Just ppsrcFile -> - psrcFile `moreRecentFile` ppsrcFile - when recomp $ do - let destDir = buildLoc dirName srcStem - createDirectoryIfMissingVerbose verbosity True destDir - runPreProcessorWithHsBootHack pp - (psrcLoc, psrcRelFile) - (buildLoc, srcStem <.> "hs") - - where - dirName = takeDirectory - - -- FIXME: This is a somewhat nasty hack. GHC requires that hs-boot files - -- be in the same place as the hs files, so if we put the hs file in dist/ - -- then we need to copy the hs-boot file there too. This should probably be - -- done another way. Possibly we should also be looking for .lhs-boot - -- files, but I think that preprocessors only produce .hs files. - runPreProcessorWithHsBootHack pp - (inBaseDir, inRelativeFile) - (outBaseDir, outRelativeFile) = do - runPreProcessor pp - (inBaseDir, inRelativeFile) - (outBaseDir, outRelativeFile) verbosity - - exists <- doesFileExist inBoot - when exists $ copyFileVerbose verbosity inBoot outBoot - - where - inBoot = replaceExtension inFile "hs-boot" - outBoot = replaceExtension outFile "hs-boot" - - inFile = normalise (inBaseDir inRelativeFile) - outFile = normalise (outBaseDir outRelativeFile) - --- ------------------------------------------------------------ --- * known preprocessors --- ------------------------------------------------------------ - -ppGreenCard :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor -ppGreenCard _ lbi _ - = PreProcessor { - platformIndependent = False, - runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> - runDbProgram verbosity greencardProgram (withPrograms lbi) - (["-tffi", "-o" ++ outFile, inFile]) - } - --- This one is useful for preprocessors that can't handle literate source. --- We also need a way to chain preprocessors. -ppUnlit :: PreProcessor -ppUnlit = - PreProcessor { - platformIndependent = True, - runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> - withUTF8FileContents inFile $ \contents -> - either (writeUTF8File outFile) (die' verbosity) (unlit inFile contents) - } - -ppCpp :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor -ppCpp = ppCpp' [] - -ppCpp' :: [String] -> BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor -ppCpp' extraArgs bi lbi clbi = - case compilerFlavor (compiler lbi) of - GHC -> ppGhcCpp ghcProgram (const True) args bi lbi clbi - GHCJS -> ppGhcCpp ghcjsProgram (const True) args bi lbi clbi - _ -> ppCpphs args bi lbi clbi - where cppArgs = getCppOptions bi lbi - args = cppArgs ++ extraArgs - -ppGhcCpp :: Program -> (Version -> Bool) - -> [String] -> BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor -ppGhcCpp program xHs extraArgs _bi lbi clbi = - PreProcessor { - platformIndependent = False, - runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do - (prog, version, _) <- requireProgramVersion verbosity - program anyVersion (withPrograms lbi) - runProgram verbosity prog $ - ["-E", "-cpp"] - -- This is a bit of an ugly hack. We're going to - -- unlit the file ourselves later on if appropriate, - -- so we need GHC not to unlit it now or it'll get - -- double-unlitted. In the future we might switch to - -- using cpphs --unlit instead. - ++ (if xHs version then ["-x", "hs"] else []) - ++ [ "-optP-include", "-optP"++ (autogenComponentModulesDir lbi clbi cppHeaderName) ] - ++ ["-o", outFile, inFile] - ++ extraArgs - } - -ppCpphs :: [String] -> BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor -ppCpphs extraArgs _bi lbi clbi = - PreProcessor { - platformIndependent = False, - runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do - (cpphsProg, cpphsVersion, _) <- requireProgramVersion verbosity - cpphsProgram anyVersion (withPrograms lbi) - runProgram verbosity cpphsProg $ - ("-O" ++ outFile) : inFile - : "--noline" : "--strip" - : (if cpphsVersion >= mkVersion [1,6] - then ["--include="++ (autogenComponentModulesDir lbi clbi cppHeaderName)] - else []) - ++ extraArgs - } - -ppHsc2hs :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor -ppHsc2hs bi lbi clbi = - PreProcessor { - platformIndependent = False, - runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do - (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi) - (hsc2hsProg, hsc2hsVersion, _) <- requireProgramVersion verbosity - hsc2hsProgram anyVersion (withPrograms lbi) - -- See Trac #13896 and https://github.com/haskell/cabal/issues/3122. - let isCross = hostPlatform lbi /= buildPlatform - prependCrossFlags = if isCross then ("-x":) else id - let hsc2hsSupportsResponseFiles = hsc2hsVersion >= mkVersion [0,68,4] - pureArgs = genPureArgs gccProg inFile outFile - if hsc2hsSupportsResponseFiles - then withResponseFile - verbosity - defaultTempFileOptions - (takeDirectory outFile) - "hsc2hs-response.txt" - Nothing - pureArgs - (\responseFileName -> - runProgram verbosity hsc2hsProg (prependCrossFlags ["@"++ responseFileName])) - else runProgram verbosity hsc2hsProg (prependCrossFlags pureArgs) - } - where - -- Returns a list of command line arguments that can either be passed - -- directly, or via a response file. - genPureArgs :: ConfiguredProgram -> String -> String -> [String] - genPureArgs gccProg inFile outFile = - [ "--cc=" ++ programPath gccProg - , "--ld=" ++ programPath gccProg ] - - -- Additional gcc options - ++ [ "--cflag=" ++ opt | opt <- programDefaultArgs gccProg - ++ programOverrideArgs gccProg ] - ++ [ "--lflag=" ++ opt | opt <- programDefaultArgs gccProg - ++ programOverrideArgs gccProg ] - - -- OSX frameworks: - ++ [ what ++ "=-F" ++ opt - | isOSX - , opt <- nub (concatMap Installed.frameworkDirs pkgs) - , what <- ["--cflag", "--lflag"] ] - ++ [ "--lflag=" ++ arg - | isOSX - , opt <- PD.frameworks bi ++ concatMap Installed.frameworks pkgs - , arg <- ["-framework", opt] ] - - -- Note that on ELF systems, wherever we use -L, we must also use -R - -- because presumably that -L dir is not on the normal path for the - -- system's dynamic linker. This is needed because hsc2hs works by - -- compiling a C program and then running it. - - ++ [ "--cflag=" ++ opt | opt <- platformDefines lbi ] - - -- Options from the current package: - ++ [ "--cflag=-I" ++ dir | dir <- PD.includeDirs bi ] - ++ [ "--cflag=-I" ++ buildDir lbi dir | dir <- PD.includeDirs bi ] - ++ [ "--cflag=" ++ opt | opt <- PD.ccOptions bi - ++ PD.cppOptions bi - -- hsc2hs uses the C ABI - -- We assume that there are only C sources - -- and C++ functions are exported via a C - -- interface and wrapped in a C source file. - -- Therefore we do not supply C++ flags - -- because there will not be C++ sources. - -- - -- DO NOT add PD.cxxOptions unless this changes! - ] - ++ [ "--cflag=" ++ opt | opt <- - [ "-I" ++ autogenComponentModulesDir lbi clbi, - "-I" ++ autogenPackageModulesDir lbi, - "-include", autogenComponentModulesDir lbi clbi cppHeaderName ] ] - ++ [ "--lflag=-L" ++ opt | opt <- PD.extraLibDirs bi ] - ++ [ "--lflag=-Wl,-R," ++ opt | isELF - , opt <- PD.extraLibDirs bi ] - ++ [ "--lflag=-l" ++ opt | opt <- PD.extraLibs bi ] - ++ [ "--lflag=" ++ opt | opt <- PD.ldOptions bi ] - - -- Options from dependent packages - ++ [ "--cflag=" ++ opt - | pkg <- pkgs - , opt <- [ "-I" ++ opt | opt <- Installed.includeDirs pkg ] - ++ [ opt | opt <- Installed.ccOptions pkg ] ] - ++ [ "--lflag=" ++ opt - | pkg <- pkgs - , opt <- [ "-L" ++ opt | opt <- Installed.libraryDirs pkg ] - ++ [ "-Wl,-R," ++ opt | isELF - , opt <- Installed.libraryDirs pkg ] - ++ [ "-l" ++ opt | opt <- Installed.extraLibraries pkg ] - ++ [ opt | opt <- Installed.ldOptions pkg ] ] - ++ ["-o", outFile, inFile] - - hacked_index = packageHacks (installedPkgs lbi) - -- Look only at the dependencies of the current component - -- being built! This relies on 'installedPkgs' maintaining - -- 'InstalledPackageInfo' for internal deps too; see #2971. - pkgs = PackageIndex.topologicalOrder $ - case PackageIndex.dependencyClosure hacked_index - (map fst (componentPackageDeps clbi)) of - Left index' -> index' - Right inf -> - error ("ppHsc2hs: broken closure: " ++ show inf) - isOSX = case buildOS of OSX -> True; _ -> False - isELF = case buildOS of OSX -> False; Windows -> False; AIX -> False; _ -> True; - packageHacks = case compilerFlavor (compiler lbi) of - GHC -> hackRtsPackage - GHCJS -> hackRtsPackage - _ -> id - -- We don't link in the actual Haskell libraries of our dependencies, so - -- the -u flags in the ldOptions of the rts package mean linking fails on - -- OS X (its ld is a tad stricter than gnu ld). Thus we remove the - -- ldOptions for GHC's rts package: - hackRtsPackage index = - case PackageIndex.lookupPackageName index (mkPackageName "rts") of - [(_, [rts])] - -> PackageIndex.insert rts { Installed.ldOptions = [] } index - _ -> error "No (or multiple) ghc rts package is registered!!" - -ppHsc2hsExtras :: PreProcessorExtras -ppHsc2hsExtras buildBaseDir = filter ("_hsc.c" `isSuffixOf`) `fmap` - getDirectoryContentsRecursive buildBaseDir - -ppC2hs :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor -ppC2hs bi lbi clbi = - PreProcessor { - platformIndependent = False, - runPreProcessor = \(inBaseDir, inRelativeFile) - (outBaseDir, outRelativeFile) verbosity -> do - (c2hsProg, _, _) <- requireProgramVersion verbosity - c2hsProgram (orLaterVersion (mkVersion [0,15])) - (withPrograms lbi) - (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi) - runProgram verbosity c2hsProg $ - - -- Options from the current package: - [ "--cpp=" ++ programPath gccProg, "--cppopts=-E" ] - ++ [ "--cppopts=" ++ opt | opt <- getCppOptions bi lbi ] - ++ [ "--cppopts=-include" ++ (autogenComponentModulesDir lbi clbi cppHeaderName) ] - ++ [ "--include=" ++ outBaseDir ] - - -- Options from dependent packages - ++ [ "--cppopts=" ++ opt - | pkg <- pkgs - , opt <- [ "-I" ++ opt | opt <- Installed.includeDirs pkg ] - ++ [ opt | opt@('-':c:_) <- Installed.ccOptions pkg - -- c2hs uses the C ABI - -- We assume that there are only C sources - -- and C++ functions are exported via a C - -- interface and wrapped in a C source file. - -- Therefore we do not supply C++ flags - -- because there will not be C++ sources. - -- - -- - -- DO NOT add Installed.cxxOptions unless this changes! - , c `elem` "DIU" ] ] - --TODO: install .chi files for packages, so we can --include - -- those dirs here, for the dependencies - - -- input and output files - ++ [ "--output-dir=" ++ outBaseDir - , "--output=" ++ outRelativeFile - , inBaseDir inRelativeFile ] - } - where - pkgs = PackageIndex.topologicalOrder (installedPkgs lbi) - -ppC2hsExtras :: PreProcessorExtras -ppC2hsExtras d = filter (\p -> takeExtensions p == ".chs.c") `fmap` - getDirectoryContentsRecursive d - ---TODO: perhaps use this with hsc2hs too ---TODO: remove cc-options from cpphs for cabal-version: >= 1.10 ---TODO: Refactor and add separate getCppOptionsForHs, getCppOptionsForCxx, & getCppOptionsForC --- instead of combining all these cases in a single function. This blind combination can --- potentially lead to compilation inconsistencies. -getCppOptions :: BuildInfo -> LocalBuildInfo -> [String] -getCppOptions bi lbi - = platformDefines lbi - ++ cppOptions bi - ++ ["-I" ++ dir | dir <- PD.includeDirs bi] - ++ [opt | opt@('-':c:_) <- PD.ccOptions bi ++ PD.cxxOptions bi, c `elem` "DIU"] - -platformDefines :: LocalBuildInfo -> [String] -platformDefines lbi = - case compilerFlavor comp of - GHC -> - ["-D__GLASGOW_HASKELL__=" ++ versionInt version] ++ - ["-D" ++ os ++ "_BUILD_OS=1"] ++ - ["-D" ++ arch ++ "_BUILD_ARCH=1"] ++ - map (\os' -> "-D" ++ os' ++ "_HOST_OS=1") osStr ++ - map (\arch' -> "-D" ++ arch' ++ "_HOST_ARCH=1") archStr - GHCJS -> - compatGlasgowHaskell ++ - ["-D__GHCJS__=" ++ versionInt version] ++ - ["-D" ++ os ++ "_BUILD_OS=1"] ++ - ["-D" ++ arch ++ "_BUILD_ARCH=1"] ++ - map (\os' -> "-D" ++ os' ++ "_HOST_OS=1") osStr ++ - map (\arch' -> "-D" ++ arch' ++ "_HOST_ARCH=1") archStr - HaskellSuite {} -> - ["-D__HASKELL_SUITE__"] ++ - map (\os' -> "-D" ++ os' ++ "_HOST_OS=1") osStr ++ - map (\arch' -> "-D" ++ arch' ++ "_HOST_ARCH=1") archStr - _ -> [] - where - comp = compiler lbi - Platform hostArch hostOS = hostPlatform lbi - version = compilerVersion comp - compatGlasgowHaskell = - maybe [] (\v -> ["-D__GLASGOW_HASKELL__=" ++ versionInt v]) - (compilerCompatVersion GHC comp) - -- TODO: move this into the compiler abstraction - -- FIXME: this forces GHC's crazy 4.8.2 -> 408 convention on all - -- the other compilers. Check if that's really what they want. - versionInt :: Version -> String - versionInt v = case versionNumbers v of - [] -> "1" - [n] -> show n - n1:n2:_ -> - -- 6.8.x -> 608 - -- 6.10.x -> 610 - let s1 = show n1 - s2 = show n2 - middle = case s2 of - _ : _ : _ -> "" - _ -> "0" - in s1 ++ middle ++ s2 - - osStr = case hostOS of - Linux -> ["linux"] - Windows -> ["mingw32"] - OSX -> ["darwin"] - FreeBSD -> ["freebsd"] - OpenBSD -> ["openbsd"] - NetBSD -> ["netbsd"] - DragonFly -> ["dragonfly"] - Solaris -> ["solaris2"] - AIX -> ["aix"] - HPUX -> ["hpux"] - IRIX -> ["irix"] - HaLVM -> [] - IOS -> ["ios"] - Android -> ["android"] - Ghcjs -> ["ghcjs"] - Hurd -> ["hurd"] - OtherOS _ -> [] - archStr = case hostArch of - I386 -> ["i386"] - X86_64 -> ["x86_64"] - PPC -> ["powerpc"] - PPC64 -> ["powerpc64"] - Sparc -> ["sparc"] - Arm -> ["arm"] - AArch64 -> ["aarch64"] - Mips -> ["mips"] - SH -> [] - IA64 -> ["ia64"] - S390 -> ["s390"] - Alpha -> ["alpha"] - Hppa -> ["hppa"] - Rs6000 -> ["rs6000"] - M68k -> ["m68k"] - Vax -> ["vax"] - JavaScript -> ["javascript"] - OtherArch _ -> [] - -ppHappy :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor -ppHappy _ lbi _ = pp { platformIndependent = True } - where pp = standardPP lbi happyProgram (hcFlags hc) - hc = compilerFlavor (compiler lbi) - hcFlags GHC = ["-agc"] - hcFlags GHCJS = ["-agc"] - hcFlags _ = [] - -ppAlex :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor -ppAlex _ lbi _ = pp { platformIndependent = True } - where pp = standardPP lbi alexProgram (hcFlags hc) - hc = compilerFlavor (compiler lbi) - hcFlags GHC = ["-g"] - hcFlags GHCJS = ["-g"] - hcFlags _ = [] - -standardPP :: LocalBuildInfo -> Program -> [String] -> PreProcessor -standardPP lbi prog args = - PreProcessor { - platformIndependent = False, - runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> - runDbProgram verbosity prog (withPrograms lbi) - (args ++ ["-o", outFile, inFile]) - } - --- |Convenience function; get the suffixes of these preprocessors. -ppSuffixes :: [ PPSuffixHandler ] -> [String] -ppSuffixes = map fst - --- |Standard preprocessors: GreenCard, c2hs, hsc2hs, happy, alex and cpphs. -knownSuffixHandlers :: [ PPSuffixHandler ] -knownSuffixHandlers = - [ ("gc", ppGreenCard) - , ("chs", ppC2hs) - , ("hsc", ppHsc2hs) - , ("x", ppAlex) - , ("y", ppHappy) - , ("ly", ppHappy) - , ("cpphs", ppCpp) - ] - --- |Standard preprocessors with possible extra C sources: c2hs, hsc2hs. -knownExtrasHandlers :: [ PreProcessorExtras ] -knownExtrasHandlers = [ ppC2hsExtras, ppHsc2hsExtras ] - --- | Find any extra C sources generated by preprocessing that need to --- be added to the component (addresses issue #238). -preprocessExtras :: Verbosity - -> Component - -> LocalBuildInfo - -> IO [FilePath] -preprocessExtras verbosity comp lbi = case comp of - CLib _ -> pp $ buildDir lbi - (CExe Executable { exeName = nm }) -> do - let nm' = unUnqualComponentName nm - pp $ buildDir lbi nm' nm' ++ "-tmp" - (CFLib ForeignLib { foreignLibName = nm }) -> do - let nm' = unUnqualComponentName nm - pp $ buildDir lbi nm' nm' ++ "-tmp" - CTest test -> do - let nm' = unUnqualComponentName $ testName test - case testInterface test of - TestSuiteExeV10 _ _ -> - pp $ buildDir lbi nm' nm' ++ "-tmp" - TestSuiteLibV09 _ _ -> - pp $ buildDir lbi stubName test stubName test ++ "-tmp" - TestSuiteUnsupported tt -> - die' verbosity $ "No support for preprocessing test suite type " ++ - prettyShow tt - CBench bm -> do - let nm' = unUnqualComponentName $ benchmarkName bm - case benchmarkInterface bm of - BenchmarkExeV10 _ _ -> - pp $ buildDir lbi nm' nm' ++ "-tmp" - BenchmarkUnsupported tt -> - die' verbosity $ "No support for preprocessing benchmark " - ++ "type " ++ prettyShow tt - where - pp :: FilePath -> IO [FilePath] - pp dir = (map (dir ) . filter not_sub . concat) - <$> for knownExtrasHandlers - (withLexicalCallStack (\f -> f dir)) - -- TODO: This is a terrible hack to work around #3545 while we don't - -- reorganize the directory layout. Basically, for the main - -- library, we might accidentally pick up autogenerated sources for - -- our subcomponents, because they are all stored as subdirectories - -- in dist/build. This is a cheap and cheerful check to prevent - -- this from happening. It is not particularly correct; for example - -- if a user has a test suite named foobar and puts their C file in - -- foobar/foo.c, this test will incorrectly exclude it. But I - -- didn't want to break BC... - not_sub p = and [ not (pre `isPrefixOf` p) | pre <- component_dirs ] - component_dirs = component_names (localPkgDescr lbi) - -- TODO: libify me - component_names pkg_descr = fmap unUnqualComponentName $ - mapMaybe (libraryNameString . libName) (subLibraries pkg_descr) ++ - map exeName (executables pkg_descr) ++ - map testName (testSuites pkg_descr) ++ - map benchmarkName (benchmarks pkg_descr) diff --git a/cabal/Cabal/Distribution/Simple/PreProcess/Unlit.hs b/cabal/Cabal/Distribution/Simple/PreProcess/Unlit.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/PreProcess/Unlit.hs +++ /dev/null @@ -1,167 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.PreProcess.Unlit --- Copyright : ... --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Remove the \"literal\" markups from a Haskell source file, including --- \"@>@\", \"@\\begin{code}@\", \"@\\end{code}@\", and \"@#@\" - --- This version is interesting because instead of striping comment lines, it --- turns them into "-- " style comments. This allows using haddock markup --- in literate scripts without having to use "> --" prefix. - -module Distribution.Simple.PreProcess.Unlit (unlit,plain) where - -import Prelude () -import Distribution.Compat.Prelude -import Distribution.Utils.Generic (safeTail, safeLast, safeInit) - -import Data.List (mapAccumL) - -data Classified = BirdTrack String | Blank String | Ordinary String - | Line !Int String | CPP String - | BeginCode | EndCode - -- output only: - | Error String | Comment String - --- | No unliteration. -plain :: String -> String -> String -plain _ hs = hs - -classify :: String -> Classified -classify ('>':s) = BirdTrack s -classify ('#':s) = case tokens s of - (line:file@('"':_:_):_) | all isDigit line - && safeLast file == Just '"' - -- this shouldn't fail as we tested for 'all isDigit' - -> Line (fromMaybe (error $ "panic! read @Int " ++ show line) $ readMaybe line) (safeTail (safeInit file)) -- TODO:eradicateNoParse - _ -> CPP s - where tokens = unfoldr $ \str -> case lex str of - (t@(_:_), str'):_ -> Just (t, str') - _ -> Nothing -classify ('\\':s) - | "begin{code}" `isPrefixOf` s = BeginCode - | "end{code}" `isPrefixOf` s = EndCode -classify s | all isSpace s = Blank s -classify s = Ordinary s - --- So the weird exception for comment indenting is to make things work with --- haddock, see classifyAndCheckForBirdTracks below. -unclassify :: Bool -> Classified -> String -unclassify _ (BirdTrack s) = ' ':s -unclassify _ (Blank s) = s -unclassify _ (Ordinary s) = s -unclassify _ (Line n file) = "# " ++ show n ++ " " ++ show file -unclassify _ (CPP s) = '#':s -unclassify True (Comment "") = " --" -unclassify True (Comment s) = " -- " ++ s -unclassify False (Comment "") = "--" -unclassify False (Comment s) = "-- " ++ s -unclassify _ _ = internalError - --- | 'unlit' takes a filename (for error reports), and transforms the --- given string, to eliminate the literate comments from the program text. -unlit :: FilePath -> String -> Either String String -unlit file input = - let (usesBirdTracks, classified) = classifyAndCheckForBirdTracks - . inlines - $ input - in either (Left . unlines . map (unclassify usesBirdTracks)) - Right - . checkErrors - . reclassify - $ classified - - where - -- So haddock requires comments and code to align, since it treats comments - -- as following the layout rule. This is a pain for us since bird track - -- style literate code typically gets indented by two since ">" is replaced - -- by " " and people usually use one additional space of indent ie - -- "> then the code". On the other hand we cannot just go and indent all - -- the comments by two since that does not work for latex style literate - -- code. So the hacky solution we use here is that if we see any bird track - -- style code then we'll indent all comments by two, otherwise by none. - -- Of course this will not work for mixed latex/bird track .lhs files but - -- nobody does that, it's silly and specifically recommended against in the - -- H98 unlit spec. - -- - classifyAndCheckForBirdTracks = - flip mapAccumL False $ \seenBirdTrack line -> - let classification = classify line - in (seenBirdTrack || isBirdTrack classification, classification) - - isBirdTrack (BirdTrack _) = True - isBirdTrack _ = False - - checkErrors ls = case [ e | Error e <- ls ] of - [] -> Left ls - (message:_) -> Right (f ++ ":" ++ show n ++ ": " ++ message) - where (f, n) = errorPos file 1 ls - errorPos f n [] = (f, n) - errorPos f n (Error _:_) = (f, n) - errorPos _ _ (Line n' f':ls) = errorPos f' n' ls - errorPos f n (_ :ls) = errorPos f (n+1) ls - --- Here we model a state machine, with each state represented by --- a local function. We only have four states (well, five, --- if you count the error state), but the rules --- to transition between then are not so simple. --- Would it be simpler to have more states? --- --- Each state represents the type of line that was last read --- i.e. are we in a comment section, or a latex-code section, --- or a bird-code section, etc? -reclassify :: [Classified] -> [Classified] -reclassify = blank -- begin in blank state - where - latex [] = [] - latex (EndCode :ls) = Blank "" : comment ls - latex (BeginCode :_ ) = [Error "\\begin{code} in code section"] - latex (BirdTrack l:ls) = Ordinary ('>':l) : latex ls - latex ( l:ls) = l : latex ls - - blank [] = [] - blank (EndCode :_ ) = [Error "\\end{code} without \\begin{code}"] - blank (BeginCode :ls) = Blank "" : latex ls - blank (BirdTrack l:ls) = BirdTrack l : bird ls - blank (Ordinary l:ls) = Comment l : comment ls - blank ( l:ls) = l : blank ls - - bird [] = [] - bird (EndCode :_ ) = [Error "\\end{code} without \\begin{code}"] - bird (BeginCode :ls) = Blank "" : latex ls - bird (Blank l :ls) = Blank l : blank ls - bird (Ordinary _:_ ) = [Error "program line before comment line"] - bird ( l:ls) = l : bird ls - - comment [] = [] - comment (EndCode :_ ) = [Error "\\end{code} without \\begin{code}"] - comment (BeginCode :ls) = Blank "" : latex ls - comment (CPP l :ls) = CPP l : comment ls - comment (BirdTrack _:_ ) = [Error "comment line before program line"] - -- a blank line and another ordinary line following a comment - -- will be treated as continuing the comment. Otherwise it's - -- then end of the comment, with a blank line. - comment (Blank l:ls@(Ordinary _:_)) = Comment l : comment ls - comment (Blank l:ls) = Blank l : blank ls - comment (Line n f :ls) = Line n f : comment ls - comment (Ordinary l:ls) = Comment l : comment ls - comment (Comment _: _) = internalError - comment (Error _: _) = internalError - --- Re-implementation of 'lines', for better efficiency (but decreased laziness). --- Also, importantly, accepts non-standard DOS and Mac line ending characters. -inlines :: String -> [String] -inlines xs = lines' xs id - where - lines' [] acc = [acc []] - lines' ('\^M':'\n':s) acc = acc [] : lines' s id -- DOS - lines' ('\^M':s) acc = acc [] : lines' s id -- MacOS - lines' ('\n':s) acc = acc [] : lines' s id -- Unix - lines' (c:s) acc = lines' s (acc . (c:)) - -internalError :: a -internalError = error "unlit: internal error" diff --git a/cabal/Cabal/Distribution/Simple/Program.hs b/cabal/Cabal/Distribution/Simple/Program.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/Program.hs +++ /dev/null @@ -1,183 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Program --- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This provides an abstraction which deals with configuring and running --- programs. A 'Program' is a static notion of a known program. A --- 'ConfiguredProgram' is a 'Program' that has been found on the current --- machine and is ready to be run (possibly with some user-supplied default --- args). Configuring a program involves finding its location and if necessary --- finding its version. There is also a 'ProgramDb' type which holds --- configured and not-yet configured programs. It is the parameter to lots of --- actions elsewhere in Cabal that need to look up and run programs. If we had --- a Cabal monad, the 'ProgramDb' would probably be a reader or --- state component of it. --- --- The module also defines all the known built-in 'Program's and the --- 'defaultProgramDb' which contains them all. --- --- One nice thing about using it is that any program that is --- registered with Cabal will get some \"configure\" and \".cabal\" --- helpers like --with-foo-args --foo-path= and extra-foo-args. --- --- There's also good default behavior for trying to find \"foo\" in --- PATH, being able to override its location, etc. --- --- There's also a hook for adding programs in a Setup.lhs script. See --- hookedPrograms in 'Distribution.Simple.UserHooks'. This gives a --- hook user the ability to get the above flags and such so that they --- don't have to write all the PATH logic inside Setup.lhs. - -module Distribution.Simple.Program ( - -- * Program and functions for constructing them - Program(..) - , ProgramSearchPath - , ProgramSearchPathEntry(..) - , simpleProgram - , findProgramOnSearchPath - , defaultProgramSearchPath - , findProgramVersion - - -- * Configured program and related functions - , ConfiguredProgram(..) - , programPath - , ProgArg - , ProgramLocation(..) - , runProgram - , getProgramOutput - , suppressOverrideArgs - - -- * Program invocations - , ProgramInvocation(..) - , emptyProgramInvocation - , simpleProgramInvocation - , programInvocation - , runProgramInvocation - , getProgramInvocationOutput - , getProgramInvocationLBS - - -- * The collection of unconfigured and configured programs - , builtinPrograms - - -- * The collection of configured programs we can run - , ProgramDb - , defaultProgramDb - , emptyProgramDb - , restoreProgramDb - , addKnownProgram - , addKnownPrograms - , lookupKnownProgram - , knownPrograms - , getProgramSearchPath - , setProgramSearchPath - , userSpecifyPath - , userSpecifyPaths - , userMaybeSpecifyPath - , userSpecifyArgs - , userSpecifyArgss - , userSpecifiedArgs - , lookupProgram - , lookupProgramVersion - , updateProgram - , configureProgram - , configureAllKnownPrograms - , reconfigurePrograms - , requireProgram - , requireProgramVersion - , needProgram - , runDbProgram - , getDbProgramOutput - - -- * Programs that Cabal knows about - , ghcProgram - , ghcPkgProgram - , ghcjsProgram - , ghcjsPkgProgram - , hmakeProgram - , jhcProgram - , uhcProgram - , gccProgram - , arProgram - , stripProgram - , happyProgram - , alexProgram - , hsc2hsProgram - , c2hsProgram - , cpphsProgram - , hscolourProgram - , doctestProgram - , haddockProgram - , greencardProgram - , ldProgram - , tarProgram - , cppProgram - , pkgConfigProgram - , hpcProgram - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Simple.Program.Types -import Distribution.Simple.Program.Run -import Distribution.Simple.Program.Db -import Distribution.Simple.Program.Builtin -import Distribution.Simple.Program.Find -import Distribution.Simple.Utils -import Distribution.Verbosity - --- | Runs the given configured program. -runProgram :: Verbosity -- ^Verbosity - -> ConfiguredProgram -- ^The program to run - -> [ProgArg] -- ^Any /extra/ arguments to add - -> IO () -runProgram verbosity prog args = - runProgramInvocation verbosity (programInvocation prog args) - - --- | Runs the given configured program and gets the output. --- -getProgramOutput :: Verbosity -- ^Verbosity - -> ConfiguredProgram -- ^The program to run - -> [ProgArg] -- ^Any /extra/ arguments to add - -> IO String -getProgramOutput verbosity prog args = - getProgramInvocationOutput verbosity (programInvocation prog args) - - --- | Looks up the given program in the program database and runs it. --- -runDbProgram :: Verbosity -- ^verbosity - -> Program -- ^The program to run - -> ProgramDb -- ^look up the program here - -> [ProgArg] -- ^Any /extra/ arguments to add - -> IO () -runDbProgram verbosity prog programDb args = - case lookupProgram prog programDb of - Nothing -> die' verbosity notFound - Just configuredProg -> runProgram verbosity configuredProg args - where - notFound = "The program '" ++ programName prog - ++ "' is required but it could not be found" - --- | Looks up the given program in the program database and runs it. --- -getDbProgramOutput :: Verbosity -- ^verbosity - -> Program -- ^The program to run - -> ProgramDb -- ^look up the program here - -> [ProgArg] -- ^Any /extra/ arguments to add - -> IO String -getDbProgramOutput verbosity prog programDb args = - case lookupProgram prog programDb of - Nothing -> die' verbosity notFound - Just configuredProg -> getProgramOutput verbosity configuredProg args - where - notFound = "The program '" ++ programName prog - ++ "' is required but it could not be found" diff --git a/cabal/Cabal/Distribution/Simple/Program/Ar.hs b/cabal/Cabal/Distribution/Simple/Program/Ar.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/Program/Ar.hs +++ /dev/null @@ -1,192 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE NondecreasingIndentation #-} -{-# LANGUAGE NoMonoLocalBinds #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Program.Ar --- Copyright : Duncan Coutts 2009 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This module provides an library interface to the @ar@ program. - -module Distribution.Simple.Program.Ar ( - createArLibArchive, - multiStageProgramInvocation - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BS8 -import Distribution.Compat.CopyFile (filesEqual) -import Distribution.Simple.Compiler (arResponseFilesSupported) -import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..)) -import Distribution.Simple.Program - ( ProgramInvocation, arProgram, requireProgram ) -import Distribution.Simple.Program.ResponseFile - ( withResponseFile ) -import Distribution.Simple.Program.Run - ( programInvocation, multiStageProgramInvocation - , runProgramInvocation ) -import Distribution.Simple.Setup - ( fromFlagOrDefault, configUseResponseFiles ) -import Distribution.Simple.Utils - ( defaultTempFileOptions, dieWithLocation', withTempDirectory ) -import Distribution.System - ( Arch(..), OS(..), Platform(..) ) -import Distribution.Verbosity - ( Verbosity, deafening, verbose ) -import System.Directory (doesFileExist, renameFile) -import System.FilePath ((), splitFileName) -import System.IO - ( Handle, IOMode(ReadWriteMode), SeekMode(AbsoluteSeek) - , hFileSize, hSeek, withBinaryFile ) - --- | Call @ar@ to create a library archive from a bunch of object files. --- -createArLibArchive :: Verbosity -> LocalBuildInfo - -> FilePath -> [FilePath] -> IO () -createArLibArchive verbosity lbi targetPath files = do - (ar, _) <- requireProgram verbosity arProgram progDb - - let (targetDir, targetName) = splitFileName targetPath - withTempDirectory verbosity targetDir "objs" $ \ tmpDir -> do - let tmpPath = tmpDir targetName - - -- The args to use with "ar" are actually rather subtle and system-dependent. - -- In particular we have the following issues: - -- - -- -- On OS X, "ar q" does not make an archive index. Archives with no - -- index cannot be used. - -- - -- -- GNU "ar r" will not let us add duplicate objects, only "ar q" lets us - -- do that. We have duplicates because of modules like "A.M" and "B.M" - -- both make an object file "M.o" and ar does not consider the directory. - -- - -- Our solution is to use "ar r" in the simple case when one call is enough. - -- When we need to call ar multiple times we use "ar q" and for the last - -- call on OSX we use "ar qs" so that it'll make the index. - - let simpleArgs = case hostOS of - OSX -> ["-r", "-s"] - _ -> ["-r"] - - initialArgs = ["-q"] - finalArgs = case hostOS of - OSX -> ["-q", "-s"] - _ -> ["-q"] - - extraArgs = verbosityOpts verbosity ++ [tmpPath] - - simple = programInvocation ar (simpleArgs ++ extraArgs) - initial = programInvocation ar (initialArgs ++ extraArgs) - middle = initial - final = programInvocation ar (finalArgs ++ extraArgs) - - oldVersionManualOverride = - fromFlagOrDefault False $ configUseResponseFiles $ configFlags lbi - responseArgumentsNotSupported = - not (arResponseFilesSupported (compiler lbi)) - - invokeWithResponesFile :: FilePath -> ProgramInvocation - invokeWithResponesFile atFile = - programInvocation ar $ - simpleArgs ++ extraArgs ++ ['@' : atFile] - - if oldVersionManualOverride || responseArgumentsNotSupported - then - sequence_ - [ runProgramInvocation verbosity inv - | inv <- multiStageProgramInvocation - simple (initial, middle, final) files ] - else - withResponseFile verbosity defaultTempFileOptions tmpDir "ar.rsp" Nothing files $ - \path -> runProgramInvocation verbosity $ invokeWithResponesFile path - - unless (hostArch == Arm -- See #1537 - || hostOS == AIX) $ -- AIX uses its own "ar" format variant - wipeMetadata verbosity tmpPath - equal <- filesEqual tmpPath targetPath - unless equal $ renameFile tmpPath targetPath - - where - progDb = withPrograms lbi - Platform hostArch hostOS = hostPlatform lbi - verbosityOpts v - | v >= deafening = ["-v"] - | v >= verbose = [] - | otherwise = ["-c"] -- Do not warn if library had to be created. - --- | @ar@ by default includes various metadata for each object file in their --- respective headers, so the output can differ for the same inputs, making --- it difficult to avoid re-linking. GNU @ar@(1) has a deterministic mode --- (@-D@) flag that always writes zero for the mtime, UID and GID, and 0644 --- for the file mode. However detecting whether @-D@ is supported seems --- rather harder than just re-implementing this feature. -wipeMetadata :: Verbosity -> FilePath -> IO () -wipeMetadata verbosity path = do - -- Check for existence first (ReadWriteMode would create one otherwise) - exists <- doesFileExist path - unless exists $ wipeError "Temporary file disappeared" - withBinaryFile path ReadWriteMode $ \ h -> hFileSize h >>= wipeArchive h - - where - wipeError msg = dieWithLocation' verbosity path Nothing $ - "Distribution.Simple.Program.Ar.wipeMetadata: " ++ msg - archLF = "!\x0a" -- global magic, 8 bytes - x60LF = "\x60\x0a" -- header magic, 2 bytes - metadata = BS.concat - [ "0 " -- mtime, 12 bytes - , "0 " -- UID, 6 bytes - , "0 " -- GID, 6 bytes - , "0644 " -- mode, 8 bytes - ] - headerSize :: Int - headerSize = 60 - - -- http://en.wikipedia.org/wiki/Ar_(Unix)#File_format_details - wipeArchive :: Handle -> Integer -> IO () - wipeArchive h archiveSize = do - global <- BS.hGet h (BS.length archLF) - unless (global == archLF) $ wipeError "Bad global header" - wipeHeader (toInteger $ BS.length archLF) - - where - wipeHeader :: Integer -> IO () - wipeHeader offset = case compare offset archiveSize of - EQ -> return () - GT -> wipeError (atOffset "Archive truncated") - LT -> do - header <- BS.hGet h headerSize - unless (BS.length header == headerSize) $ - wipeError (atOffset "Short header") - let magic = BS.drop 58 header - unless (magic == x60LF) . wipeError . atOffset $ - "Bad magic " ++ show magic ++ " in header" - - let name = BS.take 16 header - let size = BS.take 10 $ BS.drop 48 header - objSize <- case reads (BS8.unpack size) of - [(n, s)] | all isSpace s -> return n - _ -> wipeError (atOffset "Bad file size in header") - - let replacement = BS.concat [ name, metadata, size, magic ] - unless (BS.length replacement == headerSize) $ - wipeError (atOffset "Something has gone terribly wrong") - hSeek h AbsoluteSeek offset - BS.hPut h replacement - - let nextHeader = offset + toInteger headerSize + - -- Odd objects are padded with an extra '\x0a' - if odd objSize then objSize + 1 else objSize - hSeek h AbsoluteSeek nextHeader - wipeHeader nextHeader - - where - atOffset msg = msg ++ " at offset " ++ show offset diff --git a/cabal/Cabal/Distribution/Simple/Program/Builtin.hs b/cabal/Cabal/Distribution/Simple/Program/Builtin.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/Program/Builtin.hs +++ /dev/null @@ -1,348 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Program.Builtin --- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- The module defines all the known built-in 'Program's. --- --- Where possible we try to find their version numbers. --- -module Distribution.Simple.Program.Builtin ( - - -- * The collection of unconfigured and configured programs - builtinPrograms, - - -- * Programs that Cabal knows about - ghcProgram, - ghcPkgProgram, - runghcProgram, - ghcjsProgram, - ghcjsPkgProgram, - hmakeProgram, - jhcProgram, - haskellSuiteProgram, - haskellSuitePkgProgram, - uhcProgram, - gccProgram, - arProgram, - stripProgram, - happyProgram, - alexProgram, - hsc2hsProgram, - c2hsProgram, - cpphsProgram, - hscolourProgram, - doctestProgram, - haddockProgram, - greencardProgram, - ldProgram, - tarProgram, - cppProgram, - pkgConfigProgram, - hpcProgram, - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Simple.Program.GHC -import Distribution.Simple.Program.Find -import Distribution.Simple.Program.Internal -import Distribution.Simple.Program.Run -import Distribution.Simple.Program.Types -import Distribution.Simple.Utils -import Distribution.Verbosity -import Distribution.Version - -import qualified Data.Map as Map - --- ------------------------------------------------------------ --- * Known programs --- ------------------------------------------------------------ - --- | The default list of programs. --- These programs are typically used internally to Cabal. -builtinPrograms :: [Program] -builtinPrograms = - [ - -- compilers and related progs - ghcProgram - , runghcProgram - , ghcPkgProgram - , ghcjsProgram - , ghcjsPkgProgram - , haskellSuiteProgram - , haskellSuitePkgProgram - , hmakeProgram - , jhcProgram - , uhcProgram - , hpcProgram - -- preprocessors - , hscolourProgram - , doctestProgram - , haddockProgram - , happyProgram - , alexProgram - , hsc2hsProgram - , c2hsProgram - , cpphsProgram - , greencardProgram - -- platform toolchain - , gccProgram - , arProgram - , stripProgram - , ldProgram - , tarProgram - -- configuration tools - , pkgConfigProgram - ] - -ghcProgram :: Program -ghcProgram = (simpleProgram "ghc") { - programFindVersion = findProgramVersion "--numeric-version" id, - - -- Workaround for https://gitlab.haskell.org/ghc/ghc/-/issues/8825 - -- (spurious warning on non-english locales) - programPostConf = \_verbosity ghcProg -> - do let ghcProg' = ghcProg { - programOverrideEnv = ("LANGUAGE", Just "en") - : programOverrideEnv ghcProg - } - -- Only the 7.8 branch seems to be affected. Fixed in 7.8.4. - affectedVersionRange = intersectVersionRanges - (laterVersion $ mkVersion [7,8,0]) - (earlierVersion $ mkVersion [7,8,4]) - return $ maybe ghcProg - (\v -> if withinRange v affectedVersionRange - then ghcProg' else ghcProg) - (programVersion ghcProg), - - programNormaliseArgs = normaliseGhcArgs - } - -runghcProgram :: Program -runghcProgram = (simpleProgram "runghc") { - programFindVersion = findProgramVersion "--version" $ \str -> - case words str of - -- "runghc 7.10.3" - (_:ver:_) -> ver - _ -> "" - } - -ghcPkgProgram :: Program -ghcPkgProgram = (simpleProgram "ghc-pkg") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- Invoking "ghc-pkg --version" gives a string like - -- "GHC package manager version 6.4.1" - case words str of - (_:_:_:_:ver:_) -> ver - _ -> "" - } - -ghcjsProgram :: Program -ghcjsProgram = (simpleProgram "ghcjs") { - programFindVersion = findProgramVersion "--numeric-ghcjs-version" id - } - --- note: version is the version number of the GHC version that ghcjs-pkg was built with -ghcjsPkgProgram :: Program -ghcjsPkgProgram = (simpleProgram "ghcjs-pkg") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- Invoking "ghcjs-pkg --version" gives a string like - -- "GHCJS package manager version 6.4.1" - case words str of - (_:_:_:_:ver:_) -> ver - _ -> "" - } - -hmakeProgram :: Program -hmakeProgram = (simpleProgram "hmake") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- Invoking "hmake --version" gives a string line - -- "/usr/local/bin/hmake: 3.13 (2006-11-01)" - case words str of - (_:ver:_) -> ver - _ -> "" - } - -jhcProgram :: Program -jhcProgram = (simpleProgram "jhc") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- invoking "jhc --version" gives a string like - -- "jhc 0.3.20080208 (wubgipkamcep-2) - -- compiled by ghc-6.8 on a x86_64 running linux" - case words str of - (_:ver:_) -> ver - _ -> "" - } - -uhcProgram :: Program -uhcProgram = (simpleProgram "uhc") { - programFindVersion = findProgramVersion "--version-dotted" id - } - -hpcProgram :: Program -hpcProgram = (simpleProgram "hpc") - { - programFindVersion = findProgramVersion "version" $ \str -> - case words str of - (_ : _ : _ : ver : _) -> ver - _ -> "" - } - --- This represents a haskell-suite compiler. Of course, the compiler --- itself probably is not called "haskell-suite", so this is not a real --- program. (But we don't know statically the name of the actual compiler, --- so this is the best we can do.) --- --- Having this Program value serves two purposes: --- --- 1. We can accept options for the compiler in the form of --- --- --haskell-suite-option(s)=... --- --- 2. We can find a program later using this static id (with --- requireProgram). --- --- The path to the real compiler is found and recorded in the ProgramDb --- during the configure phase. -haskellSuiteProgram :: Program -haskellSuiteProgram = (simpleProgram "haskell-suite") { - -- pretend that the program exists, otherwise it won't be in the - -- "configured" state - programFindLocation = \_verbosity _searchPath -> - return $ Just ("haskell-suite-dummy-location", []) - } - --- This represent a haskell-suite package manager. See the comments for --- haskellSuiteProgram. -haskellSuitePkgProgram :: Program -haskellSuitePkgProgram = (simpleProgram "haskell-suite-pkg") { - programFindLocation = \_verbosity _searchPath -> - return $ Just ("haskell-suite-pkg-dummy-location", []) - } - - -happyProgram :: Program -happyProgram = (simpleProgram "happy") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- Invoking "happy --version" gives a string like - -- "Happy Version 1.16 Copyright (c) ...." - case words str of - (_:_:ver:_) -> ver - _ -> "" - } - -alexProgram :: Program -alexProgram = (simpleProgram "alex") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- Invoking "alex --version" gives a string like - -- "Alex version 2.1.0, (c) 2003 Chris Dornan and Simon Marlow" - case words str of - (_:_:ver:_) -> takeWhile (\x -> isDigit x || x == '.') ver - _ -> "" - } - -gccProgram :: Program -gccProgram = (simpleProgram "gcc") { - programFindVersion = findProgramVersion "-dumpversion" id - } - -arProgram :: Program -arProgram = simpleProgram "ar" - -stripProgram :: Program -stripProgram = (simpleProgram "strip") { - programFindVersion = \verbosity -> - findProgramVersion "--version" stripExtractVersion (lessVerbose verbosity) - } - -hsc2hsProgram :: Program -hsc2hsProgram = (simpleProgram "hsc2hs") { - programFindVersion = - findProgramVersion "--version" $ \str -> - -- Invoking "hsc2hs --version" gives a string like "hsc2hs version 0.66" - case words str of - (_:_:ver:_) -> ver - _ -> "" - } - -c2hsProgram :: Program -c2hsProgram = (simpleProgram "c2hs") { - programFindVersion = findProgramVersion "--numeric-version" id - } - -cpphsProgram :: Program -cpphsProgram = (simpleProgram "cpphs") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- Invoking "cpphs --version" gives a string like "cpphs 1.3" - case words str of - (_:ver:_) -> ver - _ -> "" - } - -hscolourProgram :: Program -hscolourProgram = (simpleProgram "hscolour") { - programFindLocation = \v p -> findProgramOnSearchPath v p "HsColour", - programFindVersion = findProgramVersion "-version" $ \str -> - -- Invoking "HsColour -version" gives a string like "HsColour 1.7" - case words str of - (_:ver:_) -> ver - _ -> "" - } - --- TODO: Ensure that doctest is built against the same GHC as the one --- that's being used. Same for haddock. @phadej pointed this out. -doctestProgram :: Program -doctestProgram = (simpleProgram "doctest") { - programFindLocation = \v p -> findProgramOnSearchPath v p "doctest" - , programFindVersion = findProgramVersion "--version" $ \str -> - -- "doctest version 0.11.2" - case words str of - (_:_:ver:_) -> ver - _ -> "" - } - -haddockProgram :: Program -haddockProgram = (simpleProgram "haddock") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- Invoking "haddock --version" gives a string like - -- "Haddock version 0.8, (c) Simon Marlow 2006" - case words str of - (_:_:ver:_) -> takeWhile (`elem` ('.':['0'..'9'])) ver - _ -> "", - - programNormaliseArgs = \_ _ args -> args - } - -greencardProgram :: Program -greencardProgram = simpleProgram "greencard" - -ldProgram :: Program -ldProgram = simpleProgram "ld" - -tarProgram :: Program -tarProgram = (simpleProgram "tar") { - -- See #1901. Some versions of 'tar' (OpenBSD, NetBSD, ...) don't support the - -- '--format' option. - programPostConf = \verbosity tarProg -> do - tarHelpOutput <- getProgramInvocationOutput - verbosity (programInvocation tarProg ["--help"]) - -- Some versions of tar don't support '--help'. - `catchIO` (\_ -> return "") - let k = "Supports --format" - v = if ("--format" `isInfixOf` tarHelpOutput) then "YES" else "NO" - m = Map.insert k v (programProperties tarProg) - return $ tarProg { programProperties = m } - } - -cppProgram :: Program -cppProgram = simpleProgram "cpp" - -pkgConfigProgram :: Program -pkgConfigProgram = (simpleProgram "pkg-config") { - programFindVersion = findProgramVersion "--version" id - } diff --git a/cabal/Cabal/Distribution/Simple/Program/Db.hs b/cabal/Cabal/Distribution/Simple/Program/Db.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/Program/Db.hs +++ /dev/null @@ -1,505 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Program.Db --- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This provides a 'ProgramDb' type which holds configured and not-yet --- configured programs. It is the parameter to lots of actions elsewhere in --- Cabal that need to look up and run programs. If we had a Cabal monad, --- the 'ProgramDb' would probably be a reader or state component of it. --- --- One nice thing about using it is that any program that is --- registered with Cabal will get some \"configure\" and \".cabal\" --- helpers like --with-foo-args --foo-path= and extra-foo-args. --- --- There's also a hook for adding programs in a Setup.lhs script. See --- hookedPrograms in 'Distribution.Simple.UserHooks'. This gives a --- hook user the ability to get the above flags and such so that they --- don't have to write all the PATH logic inside Setup.lhs. - -module Distribution.Simple.Program.Db ( - -- * The collection of configured programs we can run - ProgramDb, - emptyProgramDb, - defaultProgramDb, - restoreProgramDb, - - -- ** Query and manipulate the program db - addKnownProgram, - addKnownPrograms, - lookupKnownProgram, - knownPrograms, - getProgramSearchPath, - setProgramSearchPath, - modifyProgramSearchPath, - userSpecifyPath, - userSpecifyPaths, - userMaybeSpecifyPath, - userSpecifyArgs, - userSpecifyArgss, - userSpecifiedArgs, - lookupProgram, - updateProgram, - configuredPrograms, - - -- ** Query and manipulate the program db - configureProgram, - configureAllKnownPrograms, - unconfigureProgram, - lookupProgramVersion, - reconfigurePrograms, - requireProgram, - requireProgramVersion, - needProgram, - - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Pretty -import Distribution.Simple.Program.Builtin -import Distribution.Simple.Program.Find -import Distribution.Simple.Program.Types -import Distribution.Simple.Utils -import Distribution.Utils.Structured (Structure (..), Structured (..)) -import Distribution.Verbosity -import Distribution.Version - -import Data.Tuple (swap) - -import qualified Data.Map as Map - --- ------------------------------------------------------------ --- * Programs database --- ------------------------------------------------------------ - --- | The configuration is a collection of information about programs. It --- contains information both about configured programs and also about programs --- that we are yet to configure. --- --- The idea is that we start from a collection of unconfigured programs and one --- by one we try to configure them at which point we move them into the --- configured collection. For unconfigured programs we record not just the --- 'Program' but also any user-provided arguments and location for the program. -data ProgramDb = ProgramDb { - unconfiguredProgs :: UnconfiguredProgs, - progSearchPath :: ProgramSearchPath, - configuredProgs :: ConfiguredProgs - } - deriving (Typeable) - -type UnconfiguredProgram = (Program, Maybe FilePath, [ProgArg]) -type UnconfiguredProgs = Map.Map String UnconfiguredProgram -type ConfiguredProgs = Map.Map String ConfiguredProgram - - -emptyProgramDb :: ProgramDb -emptyProgramDb = ProgramDb Map.empty defaultProgramSearchPath Map.empty - -defaultProgramDb :: ProgramDb -defaultProgramDb = restoreProgramDb builtinPrograms emptyProgramDb - - --- internal helpers: -updateUnconfiguredProgs :: (UnconfiguredProgs -> UnconfiguredProgs) - -> ProgramDb -> ProgramDb -updateUnconfiguredProgs update progdb = - progdb { unconfiguredProgs = update (unconfiguredProgs progdb) } - -updateConfiguredProgs :: (ConfiguredProgs -> ConfiguredProgs) - -> ProgramDb -> ProgramDb -updateConfiguredProgs update progdb = - progdb { configuredProgs = update (configuredProgs progdb) } - - --- Read & Show instances are based on listToFM - --- | Note that this instance does not preserve the known 'Program's. --- See 'restoreProgramDb' for details. --- -instance Show ProgramDb where - show = show . Map.toAscList . configuredProgs - --- | Note that this instance does not preserve the known 'Program's. --- See 'restoreProgramDb' for details. --- -instance Read ProgramDb where - readsPrec p s = - [ (emptyProgramDb { configuredProgs = Map.fromList s' }, r) - | (s', r) <- readsPrec p s ] - --- | Note that this instance does not preserve the known 'Program's. --- See 'restoreProgramDb' for details. --- -instance Binary ProgramDb where - put db = do - put (progSearchPath db) - put (configuredProgs db) - - get = do - searchpath <- get - progs <- get - return $! emptyProgramDb { - progSearchPath = searchpath, - configuredProgs = progs - } - -instance Structured ProgramDb where - structure p = Nominal (typeRep p) 0 "ProgramDb" - [ structure (Proxy :: Proxy ProgramSearchPath) - , structure (Proxy :: Proxy ConfiguredProgs) - ] - - --- | The 'Read'\/'Show' and 'Binary' instances do not preserve all the --- unconfigured 'Programs' because 'Program' is not in 'Read'\/'Show' because --- it contains functions. So to fully restore a deserialised 'ProgramDb' use --- this function to add back all the known 'Program's. --- --- * It does not add the default programs, but you probably want them, use --- 'builtinPrograms' in addition to any extra you might need. --- -restoreProgramDb :: [Program] -> ProgramDb -> ProgramDb -restoreProgramDb = addKnownPrograms - - --- ------------------------------- --- Managing unconfigured programs - --- | Add a known program that we may configure later --- -addKnownProgram :: Program -> ProgramDb -> ProgramDb -addKnownProgram prog = updateUnconfiguredProgs $ - Map.insertWith combine (programName prog) (prog, Nothing, []) - where combine _ (_, path, args) = (prog, path, args) - - -addKnownPrograms :: [Program] -> ProgramDb -> ProgramDb -addKnownPrograms progs progdb = foldl' (flip addKnownProgram) progdb progs - - -lookupKnownProgram :: String -> ProgramDb -> Maybe Program -lookupKnownProgram name = - fmap (\(p,_,_)->p) . Map.lookup name . unconfiguredProgs - - -knownPrograms :: ProgramDb -> [(Program, Maybe ConfiguredProgram)] -knownPrograms progdb = - [ (p,p') | (p,_,_) <- Map.elems (unconfiguredProgs progdb) - , let p' = Map.lookup (programName p) (configuredProgs progdb) ] - --- | Get the current 'ProgramSearchPath' used by the 'ProgramDb'. --- This is the default list of locations where programs are looked for when --- configuring them. This can be overridden for specific programs (with --- 'userSpecifyPath'), and specific known programs can modify or ignore this --- search path in their own configuration code. --- -getProgramSearchPath :: ProgramDb -> ProgramSearchPath -getProgramSearchPath = progSearchPath - --- | Change the current 'ProgramSearchPath' used by the 'ProgramDb'. --- This will affect programs that are configured from here on, so you --- should usually set it before configuring any programs. --- -setProgramSearchPath :: ProgramSearchPath -> ProgramDb -> ProgramDb -setProgramSearchPath searchpath db = db { progSearchPath = searchpath } - --- | Modify the current 'ProgramSearchPath' used by the 'ProgramDb'. --- This will affect programs that are configured from here on, so you --- should usually modify it before configuring any programs. --- -modifyProgramSearchPath :: (ProgramSearchPath -> ProgramSearchPath) - -> ProgramDb - -> ProgramDb -modifyProgramSearchPath f db = - setProgramSearchPath (f $ getProgramSearchPath db) db - --- |User-specify this path. Basically override any path information --- for this program in the configuration. If it's not a known --- program ignore it. --- -userSpecifyPath :: String -- ^Program name - -> FilePath -- ^user-specified path to the program - -> ProgramDb -> ProgramDb -userSpecifyPath name path = updateUnconfiguredProgs $ - flip Map.update name $ \(prog, _, args) -> Just (prog, Just path, args) - - -userMaybeSpecifyPath :: String -> Maybe FilePath - -> ProgramDb -> ProgramDb -userMaybeSpecifyPath _ Nothing progdb = progdb -userMaybeSpecifyPath name (Just path) progdb = userSpecifyPath name path progdb - - --- |User-specify the arguments for this program. Basically override --- any args information for this program in the configuration. If it's --- not a known program, ignore it.. -userSpecifyArgs :: String -- ^Program name - -> [ProgArg] -- ^user-specified args - -> ProgramDb - -> ProgramDb -userSpecifyArgs name args' = - updateUnconfiguredProgs - (flip Map.update name $ - \(prog, path, args) -> Just (prog, path, args ++ args')) - . updateConfiguredProgs - (flip Map.update name $ - \prog -> Just prog { programOverrideArgs = programOverrideArgs prog - ++ args' }) - - --- | Like 'userSpecifyPath' but for a list of progs and their paths. --- -userSpecifyPaths :: [(String, FilePath)] - -> ProgramDb - -> ProgramDb -userSpecifyPaths paths progdb = - foldl' (\progdb' (prog, path) -> userSpecifyPath prog path progdb') progdb paths - - --- | Like 'userSpecifyPath' but for a list of progs and their args. --- -userSpecifyArgss :: [(String, [ProgArg])] - -> ProgramDb - -> ProgramDb -userSpecifyArgss argss progdb = - foldl' (\progdb' (prog, args) -> userSpecifyArgs prog args progdb') progdb argss - - --- | Get the path that has been previously specified for a program, if any. --- -userSpecifiedPath :: Program -> ProgramDb -> Maybe FilePath -userSpecifiedPath prog = - join . fmap (\(_,p,_)->p) . Map.lookup (programName prog) . unconfiguredProgs - - --- | Get any extra args that have been previously specified for a program. --- -userSpecifiedArgs :: Program -> ProgramDb -> [ProgArg] -userSpecifiedArgs prog = - maybe [] (\(_,_,as)->as) . Map.lookup (programName prog) . unconfiguredProgs - - --- ----------------------------- --- Managing configured programs - --- | Try to find a configured program -lookupProgram :: Program -> ProgramDb -> Maybe ConfiguredProgram -lookupProgram prog = Map.lookup (programName prog) . configuredProgs - - --- | Update a configured program in the database. -updateProgram :: ConfiguredProgram -> ProgramDb - -> ProgramDb -updateProgram prog = updateConfiguredProgs $ - Map.insert (programId prog) prog - - --- | List all configured programs. -configuredPrograms :: ProgramDb -> [ConfiguredProgram] -configuredPrograms = Map.elems . configuredProgs - --- --------------------------- --- Configuring known programs - --- | Try to configure a specific program. If the program is already included in --- the collection of unconfigured programs then we use any user-supplied --- location and arguments. If the program gets configured successfully it gets --- added to the configured collection. --- --- Note that it is not a failure if the program cannot be configured. It's only --- a failure if the user supplied a location and the program could not be found --- at that location. --- --- The reason for it not being a failure at this stage is that we don't know up --- front all the programs we will need, so we try to configure them all. --- To verify that a program was actually successfully configured use --- 'requireProgram'. --- -configureProgram :: Verbosity - -> Program - -> ProgramDb - -> IO ProgramDb -configureProgram verbosity prog progdb = do - let name = programName prog - maybeLocation <- case userSpecifiedPath prog progdb of - Nothing -> - programFindLocation prog verbosity (progSearchPath progdb) - >>= return . fmap (swap . fmap FoundOnSystem . swap) - Just path -> do - absolute <- doesExecutableExist path - if absolute - then return (Just (UserSpecified path, [])) - else findProgramOnSearchPath verbosity (progSearchPath progdb) path - >>= maybe (die' verbosity notFound) - (return . Just . swap . fmap UserSpecified . swap) - where notFound = "Cannot find the program '" ++ name - ++ "'. User-specified path '" - ++ path ++ "' does not refer to an executable and " - ++ "the program is not on the system path." - case maybeLocation of - Nothing -> return progdb - Just (location, triedLocations) -> do - version <- programFindVersion prog verbosity (locationPath location) - newPath <- programSearchPathAsPATHVar (progSearchPath progdb) - let configuredProg = ConfiguredProgram { - programId = name, - programVersion = version, - programDefaultArgs = [], - programOverrideArgs = userSpecifiedArgs prog progdb, - programOverrideEnv = [("PATH", Just newPath)], - programProperties = Map.empty, - programLocation = location, - programMonitorFiles = triedLocations - } - configuredProg' <- programPostConf prog verbosity configuredProg - return (updateConfiguredProgs (Map.insert name configuredProg') progdb) - - --- | Configure a bunch of programs using 'configureProgram'. Just a 'foldM'. --- -configurePrograms :: Verbosity - -> [Program] - -> ProgramDb - -> IO ProgramDb -configurePrograms verbosity progs progdb = - foldM (flip (configureProgram verbosity)) progdb progs - - --- | Unconfigure a program. This is basically a hack and you shouldn't --- use it, but it can be handy for making sure a 'requireProgram' --- actually reconfigures. -unconfigureProgram :: String -> ProgramDb -> ProgramDb -unconfigureProgram progname = - updateConfiguredProgs $ Map.delete progname - --- | Try to configure all the known programs that have not yet been configured. --- -configureAllKnownPrograms :: Verbosity - -> ProgramDb - -> IO ProgramDb -configureAllKnownPrograms verbosity progdb = - configurePrograms verbosity - [ prog | (prog,_,_) <- Map.elems notYetConfigured ] progdb - where - notYetConfigured = unconfiguredProgs progdb - `Map.difference` configuredProgs progdb - - --- | reconfigure a bunch of programs given new user-specified args. It takes --- the same inputs as 'userSpecifyPath' and 'userSpecifyArgs' and for all progs --- with a new path it calls 'configureProgram'. --- -reconfigurePrograms :: Verbosity - -> [(String, FilePath)] - -> [(String, [ProgArg])] - -> ProgramDb - -> IO ProgramDb -reconfigurePrograms verbosity paths argss progdb = do - configurePrograms verbosity progs - . userSpecifyPaths paths - . userSpecifyArgss argss - $ progdb - - where - progs = catMaybes [ lookupKnownProgram name progdb | (name,_) <- paths ] - - --- | Check that a program is configured and available to be run. --- --- It raises an exception if the program could not be configured, otherwise --- it returns the configured program. --- -requireProgram :: Verbosity -> Program -> ProgramDb - -> IO (ConfiguredProgram, ProgramDb) -requireProgram verbosity prog progdb = do - mres <- needProgram verbosity prog progdb - case mres of - Nothing -> die' verbosity notFound - Just res -> return res - where - notFound = "The program '" ++ programName prog ++ "' is required but it could not be found." - --- | Check that a program is configured and available to be run. --- --- It returns 'Nothing' if the program couldn't be configured, --- or is not found. --- --- @since 3.0.1.0 -needProgram :: Verbosity -> Program -> ProgramDb - -> IO (Maybe (ConfiguredProgram, ProgramDb)) -needProgram verbosity prog progdb = do - - -- If it's not already been configured, try to configure it now - progdb' <- case lookupProgram prog progdb of - Nothing -> configureProgram verbosity prog progdb - Just _ -> return progdb - - case lookupProgram prog progdb' of - Nothing -> return Nothing - Just configuredProg -> return (Just (configuredProg, progdb')) - --- | Check that a program is configured and available to be run. --- --- Additionally check that the program version number is suitable and return --- it. For example you could require 'AnyVersion' or @'orLaterVersion' --- ('Version' [1,0] [])@ --- --- It returns the configured program, its version number and a possibly updated --- 'ProgramDb'. If the program could not be configured or the version is --- unsuitable, it returns an error value. --- -lookupProgramVersion - :: Verbosity -> Program -> VersionRange -> ProgramDb - -> IO (Either String (ConfiguredProgram, Version, ProgramDb)) -lookupProgramVersion verbosity prog range programDb = do - - -- If it's not already been configured, try to configure it now - programDb' <- case lookupProgram prog programDb of - Nothing -> configureProgram verbosity prog programDb - Just _ -> return programDb - - case lookupProgram prog programDb' of - Nothing -> return $! Left notFound - Just configuredProg@ConfiguredProgram { programLocation = location } -> - case programVersion configuredProg of - Just version - | withinRange version range -> - return $! Right (configuredProg, version ,programDb') - | otherwise -> - return $! Left (badVersion version location) - Nothing -> - return $! Left (unknownVersion location) - - where notFound = "The program '" - ++ programName prog ++ "'" ++ versionRequirement - ++ " is required but it could not be found." - badVersion v l = "The program '" - ++ programName prog ++ "'" ++ versionRequirement - ++ " is required but the version found at " - ++ locationPath l ++ " is version " ++ prettyShow v - unknownVersion l = "The program '" - ++ programName prog ++ "'" ++ versionRequirement - ++ " is required but the version of " - ++ locationPath l ++ " could not be determined." - versionRequirement - | isAnyVersion range = "" - | otherwise = " version " ++ prettyShow range - --- | Like 'lookupProgramVersion', but raises an exception in case of error --- instead of returning 'Left errMsg'. --- -requireProgramVersion :: Verbosity -> Program -> VersionRange - -> ProgramDb - -> IO (ConfiguredProgram, Version, ProgramDb) -requireProgramVersion verbosity prog range programDb = - join $ either (die' verbosity) return `fmap` - lookupProgramVersion verbosity prog range programDb diff --git a/cabal/Cabal/Distribution/Simple/Program/Find.hs b/cabal/Cabal/Distribution/Simple/Program/Find.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/Program/Find.hs +++ /dev/null @@ -1,198 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Program.Find --- Copyright : Duncan Coutts 2013 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- A somewhat extended notion of the normal program search path concept. --- --- Usually when finding executables we just want to look in the usual places --- using the OS's usual method for doing so. In Haskell the normal OS-specific --- method is captured by 'findExecutable'. On all common OSs that makes use of --- a @PATH@ environment variable, (though on Windows it is not just the @PATH@). --- --- However it is sometimes useful to be able to look in additional locations --- without having to change the process-global @PATH@ environment variable. --- So we need an extension of the usual 'findExecutable' that can look in --- additional locations, either before, after or instead of the normal OS --- locations. --- -module Distribution.Simple.Program.Find ( - -- * Program search path - ProgramSearchPath, - ProgramSearchPathEntry(..), - defaultProgramSearchPath, - findProgramOnSearchPath, - programSearchPathAsPATHVar, - getSystemSearchPath, - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Verbosity -import Distribution.Simple.Utils -import Distribution.System -import Distribution.Compat.Environment - -import qualified System.Directory as Directory - ( findExecutable ) -import System.FilePath as FilePath - ( (), (<.>), splitSearchPath, searchPathSeparator, getSearchPath - , takeDirectory ) -#if defined(mingw32_HOST_OS) -import qualified System.Win32 as Win32 -#endif - --- | A search path to use when locating executables. This is analogous --- to the unix @$PATH@ or win32 @%PATH%@ but with the ability to use --- the system default method for finding executables ('findExecutable' which --- on unix is simply looking on the @$PATH@ but on win32 is a bit more --- complicated). --- --- The default to use is @[ProgSearchPathDefault]@ but you can add extra dirs --- either before, after or instead of the default, e.g. here we add an extra --- dir to search after the usual ones. --- --- > ['ProgramSearchPathDefault', 'ProgramSearchPathDir' dir] --- -type ProgramSearchPath = [ProgramSearchPathEntry] -data ProgramSearchPathEntry = - ProgramSearchPathDir FilePath -- ^ A specific dir - | ProgramSearchPathDefault -- ^ The system default - deriving (Eq, Generic, Typeable) - -instance Binary ProgramSearchPathEntry -instance Structured ProgramSearchPathEntry - -defaultProgramSearchPath :: ProgramSearchPath -defaultProgramSearchPath = [ProgramSearchPathDefault] - -findProgramOnSearchPath :: Verbosity -> ProgramSearchPath - -> FilePath -> IO (Maybe (FilePath, [FilePath])) -findProgramOnSearchPath verbosity searchpath prog = do - debug verbosity $ "Searching for " ++ prog ++ " in path." - res <- tryPathElems [] searchpath - case res of - Nothing -> debug verbosity ("Cannot find " ++ prog ++ " on the path") - Just (path, _) -> debug verbosity ("Found " ++ prog ++ " at "++ path) - return res - where - tryPathElems :: [[FilePath]] -> [ProgramSearchPathEntry] - -> IO (Maybe (FilePath, [FilePath])) - tryPathElems _ [] = return Nothing - tryPathElems tried (pe:pes) = do - res <- tryPathElem pe - case res of - (Nothing, notfoundat) -> tryPathElems (notfoundat : tried) pes - (Just foundat, notfoundat) -> return (Just (foundat, alltried)) - where - alltried = concat (reverse (notfoundat : tried)) - - tryPathElem :: ProgramSearchPathEntry -> IO (Maybe FilePath, [FilePath]) - tryPathElem (ProgramSearchPathDir dir) = - findFirstExe [ dir prog <.> ext | ext <- exeExtensions ] - - -- On windows, getSystemSearchPath is not guaranteed 100% correct so we - -- use findExecutable and then approximate the not-found-at locations. - tryPathElem ProgramSearchPathDefault | buildOS == Windows = do - mExe <- firstJustM [ findExecutable (prog <.> ext) | ext <- exeExtensions ] - syspath <- getSystemSearchPath - case mExe of - Nothing -> - let notfoundat = [ dir prog | dir <- syspath ] in - return (Nothing, notfoundat) - - Just foundat -> do - let founddir = takeDirectory foundat - notfoundat = [ dir prog - | dir <- takeWhile (/= founddir) syspath ] - return (Just foundat, notfoundat) - - -- On other OSs we can just do the simple thing - tryPathElem ProgramSearchPathDefault = do - dirs <- getSystemSearchPath - findFirstExe [ dir prog <.> ext | dir <- dirs, ext <- exeExtensions ] - - findFirstExe :: [FilePath] -> IO (Maybe FilePath, [FilePath]) - findFirstExe = go [] - where - go fs' [] = return (Nothing, reverse fs') - go fs' (f:fs) = do - isExe <- doesExecutableExist f - if isExe - then return (Just f, reverse fs') - else go (f:fs') fs - - -- Helper for evaluating actions until the first one returns 'Just' - firstJustM :: Monad m => [m (Maybe a)] -> m (Maybe a) - firstJustM [] = return Nothing - firstJustM (ma:mas) = do - a <- ma - case a of - Just _ -> return a - Nothing -> firstJustM mas - --- | Interpret a 'ProgramSearchPath' to construct a new @$PATH@ env var. --- Note that this is close but not perfect because on Windows the search --- algorithm looks at more than just the @%PATH%@. -programSearchPathAsPATHVar :: ProgramSearchPath -> IO String -programSearchPathAsPATHVar searchpath = do - ess <- traverse getEntries searchpath - return (intercalate [searchPathSeparator] (concat ess)) - where - getEntries (ProgramSearchPathDir dir) = return [dir] - getEntries ProgramSearchPathDefault = do - env <- getEnvironment - return (maybe [] splitSearchPath (lookup "PATH" env)) - --- | Get the system search path. On Unix systems this is just the @$PATH@ env --- var, but on windows it's a bit more complicated. --- -getSystemSearchPath :: IO [FilePath] -getSystemSearchPath = fmap nub $ do -#if defined(mingw32_HOST_OS) - processdir <- takeDirectory `fmap` Win32.getModuleFileName Win32.nullHANDLE - currentdir <- Win32.getCurrentDirectory - systemdir <- Win32.getSystemDirectory - windowsdir <- Win32.getWindowsDirectory - pathdirs <- FilePath.getSearchPath - let path = processdir : currentdir - : systemdir : windowsdir - : pathdirs - return path -#else - FilePath.getSearchPath -#endif - -#ifdef MIN_VERSION_directory -#if MIN_VERSION_directory(1,2,1) -#define HAVE_directory_121 -#endif -#endif - -findExecutable :: FilePath -> IO (Maybe FilePath) -#ifdef HAVE_directory_121 -findExecutable = Directory.findExecutable -#else -findExecutable prog = do - -- With directory < 1.2.1 'findExecutable' doesn't check that the path - -- really refers to an executable. - mExe <- Directory.findExecutable prog - case mExe of - Just exe -> do - exeExists <- doesExecutableExist exe - if exeExists - then return mExe - else return Nothing - _ -> return mExe -#endif - diff --git a/cabal/Cabal/Distribution/Simple/Program/GHC.hs b/cabal/Cabal/Distribution/Simple/Program/GHC.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/Program/GHC.hs +++ /dev/null @@ -1,847 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE NoMonoLocalBinds #-} -module Distribution.Simple.Program.GHC ( - GhcOptions(..), - GhcMode(..), - GhcOptimisation(..), - GhcDynLinkMode(..), - GhcProfAuto(..), - - ghcInvocation, - renderGhcOptions, - - runGHC, - - packageDbArgsDb, - normaliseGhcArgs - - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Backpack -import Distribution.Compat.Semigroup (First'(..), Last'(..), Option'(..)) -import Distribution.Simple.GHC.ImplInfo -import Distribution.PackageDescription -import Distribution.ModuleName -import Distribution.Simple.Compiler -import Distribution.Simple.Flag -import Distribution.Simple.Program.Types -import Distribution.Simple.Program.Run -import Distribution.System -import Distribution.Pretty -import Distribution.Types.ComponentId -import Distribution.Types.ModuleRenaming -import Distribution.Verbosity -import Distribution.Version -import Distribution.Utils.NubList -import Language.Haskell.Extension - -import Data.List (stripPrefix) -import qualified Data.Map as Map -import Data.Monoid (All(..), Any(..), Endo(..)) -import qualified Data.Set as Set - -normaliseGhcArgs :: Maybe Version -> PackageDescription -> [String] -> [String] -normaliseGhcArgs (Just ghcVersion) PackageDescription{..} ghcArgs - | ghcVersion `withinRange` supportedGHCVersions - = argumentFilters . filter simpleFilters . filterRtsOpts $ ghcArgs - where - supportedGHCVersions :: VersionRange - supportedGHCVersions = intersectVersionRanges - (orLaterVersion (mkVersion [8,0])) - (earlierVersion (mkVersion [8,13])) - - from :: Monoid m => [Int] -> m -> m - from version flags - | ghcVersion `withinRange` orLaterVersion (mkVersion version) = flags - | otherwise = mempty - - to :: Monoid m => [Int] -> m -> m - to version flags - | ghcVersion `withinRange` earlierVersion (mkVersion version) = flags - | otherwise = mempty - - checkGhcFlags :: forall m . Monoid m => ([String] -> m) -> m - checkGhcFlags fun = mconcat - [ fun ghcArgs - , checkComponentFlags libBuildInfo pkgLibs - , checkComponentFlags buildInfo executables - , checkComponentFlags testBuildInfo testSuites - , checkComponentFlags benchmarkBuildInfo benchmarks - ] - where - pkgLibs = maybeToList library ++ subLibraries - - checkComponentFlags :: (a -> BuildInfo) -> [a] -> m - checkComponentFlags getInfo = foldMap (checkComponent . getInfo) - where - checkComponent :: BuildInfo -> m - checkComponent = foldMap fun . filterGhcOptions . allGhcOptions - - allGhcOptions :: BuildInfo -> [(CompilerFlavor, [String])] - allGhcOptions = foldMap (perCompilerFlavorToList .) - [options, profOptions, sharedOptions, staticOptions] - - filterGhcOptions :: [(CompilerFlavor, [String])] -> [[String]] - filterGhcOptions l = [opts | (GHC, opts) <- l] - - safeToFilterWarnings :: Bool - safeToFilterWarnings = getAll $ checkGhcFlags checkWarnings - where - checkWarnings :: [String] -> All - checkWarnings = All . Set.null . foldr alter Set.empty - - alter :: String -> Set String -> Set String - alter flag = appEndo $ mconcat - [ \s -> Endo $ if s == "-Werror" then Set.insert s else id - , \s -> Endo $ if s == "-Wwarn" then const Set.empty else id - , \s -> from [8,6] . Endo $ - if s == "-Werror=compat" - then Set.union compatWarningSet else id - , \s -> from [8,6] . Endo $ - if s == "-Wno-error=compat" - then (`Set.difference` compatWarningSet) else id - , \s -> from [8,6] . Endo $ - if s == "-Wwarn=compat" - then (`Set.difference` compatWarningSet) else id - , from [8,4] $ markFlag "-Werror=" Set.insert - , from [8,4] $ markFlag "-Wwarn=" Set.delete - , from [8,4] $ markFlag "-Wno-error=" Set.delete - ] flag - - markFlag - :: String - -> (String -> Set String -> Set String) - -> String - -> Endo (Set String) - markFlag name update flag = Endo $ case stripPrefix name flag of - Just rest | not (null rest) && rest /= "compat" -> update rest - _ -> id - - flagArgumentFilter :: [String] -> [String] -> [String] - flagArgumentFilter flags = go - where - makeFilter :: String -> String -> Option' (First' ([String] -> [String])) - makeFilter flag arg = Option' $ First' . filterRest <$> stripPrefix flag arg - where - filterRest leftOver = case dropEq leftOver of - [] -> drop 1 - _ -> id - - checkFilter :: String -> Maybe ([String] -> [String]) - checkFilter = fmap getFirst' . getOption' . foldMap makeFilter flags - - go :: [String] -> [String] - go [] = [] - go (arg:args) = case checkFilter arg of - Just f -> go (f args) - Nothing -> arg : go args - - argumentFilters :: [String] -> [String] - argumentFilters = flagArgumentFilter - ["-ghci-script", "-H", "-interactive-print"] - - filterRtsOpts :: [String] -> [String] - filterRtsOpts = go False - where - go :: Bool -> [String] -> [String] - go _ [] = [] - go _ ("+RTS":opts) = go True opts - go _ ("-RTS":opts) = go False opts - go isRTSopts (opt:opts) = addOpt $ go isRTSopts opts - where - addOpt | isRTSopts = id - | otherwise = (opt:) - - simpleFilters :: String -> Bool - simpleFilters = not . getAny . mconcat - [ flagIn simpleFlags - , Any . isPrefixOf "-ddump-" - , Any . isPrefixOf "-dsuppress-" - , Any . isPrefixOf "-dno-suppress-" - , flagIn $ invertibleFlagSet "-" ["ignore-dot-ghci"] - , flagIn . invertibleFlagSet "-f" . mconcat $ - [ [ "reverse-errors", "warn-unused-binds", "break-on-error" - , "break-on-exception", "print-bind-result" - , "print-bind-contents", "print-evld-with-show" - , "implicit-import-qualified", "error-spans" - ] - , from [7,8] - [ "print-explicit-foralls" -- maybe also earlier, but GHC-7.6 doesn't have --show-options - , "print-explicit-kinds" - ] - , from [8,0] - [ "print-explicit-coercions" - , "print-explicit-runtime-reps" - , "print-equality-relations" - , "print-unicode-syntax" - , "print-expanded-synonyms" - , "print-potential-instances" - , "print-typechecker-elaboration" - ] - , from [8,2] - [ "diagnostics-show-caret", "local-ghci-history" - , "show-warning-groups", "hide-source-paths" - , "show-hole-constraints" - ] - , from [8,4] ["show-loaded-modules"] - , from [8,6] [ "ghci-leak-check", "no-it" ] - , from [8,10] - [ "defer-diagnostics" -- affects printing of diagnostics - , "keep-going" -- try harder, the build will still fail if it's erroneous - , "print-axiom-incomps" -- print more debug info for closed type families - ] - ] - , flagIn . invertibleFlagSet "-d" $ [ "ppr-case-as-let", "ppr-ticks" ] - , isOptIntFlag - , isIntFlag - , if safeToFilterWarnings - then isWarning <> (Any . ("-w"==)) - else mempty - , from [8,6] $ - if safeToFilterHoles - then isTypedHoleFlag - else mempty - ] - - flagIn :: Set String -> String -> Any - flagIn set flag = Any $ Set.member flag set - - isWarning :: String -> Any - isWarning = mconcat $ map ((Any .) . isPrefixOf) - ["-fwarn-", "-fno-warn-", "-W", "-Wno-"] - - simpleFlags :: Set String - simpleFlags = Set.fromList . mconcat $ - [ [ "-n", "-#include", "-Rghc-timing", "-dstg-stats" - , "-dth-dec-file", "-dsource-stats", "-dverbose-core2core" - , "-dverbose-stg2stg", "-dcore-lint", "-dstg-lint", "-dcmm-lint" - , "-dasm-lint", "-dannot-lint", "-dshow-passes", "-dfaststring-stats" - , "-fno-max-relevant-binds", "-recomp", "-no-recomp", "-fforce-recomp" - , "-fno-force-recomp" - ] - - , from [8,2] - [ "-fno-max-errors", "-fdiagnostics-color=auto" - , "-fdiagnostics-color=always", "-fdiagnostics-color=never" - , "-dppr-debug", "-dno-debug-output" - ] - - , from [8,4] [ "-ddebug-output" ] - , from [8,4] $ to [8,6] [ "-fno-max-valid-substitutions" ] - , from [8,6] [ "-dhex-word-literals" ] - , from [8,8] [ "-fshow-docs-of-hole-fits", "-fno-show-docs-of-hole-fits" ] - , from [8,12] [ "-dlinear-core-lint" ] - ] - - isOptIntFlag :: String -> Any - isOptIntFlag = mconcat . map (dropIntFlag True) $ ["-v", "-j"] - - isIntFlag :: String -> Any - isIntFlag = mconcat . map (dropIntFlag False) . mconcat $ - [ [ "-fmax-relevant-binds", "-ddpr-user-length", "-ddpr-cols" - , "-dtrace-level", "-fghci-hist-size" ] - , from [8,2] ["-fmax-uncovered-patterns", "-fmax-errors"] - , from [8,4] $ to [8,6] ["-fmax-valid-substitutions"] - ] - - dropIntFlag :: Bool -> String -> String -> Any - dropIntFlag isOpt flag input = Any $ case stripPrefix flag input of - Nothing -> False - Just rest | isOpt && null rest -> True - | otherwise -> case parseInt rest of - Just _ -> True - Nothing -> False - where - parseInt :: String -> Maybe Int - parseInt = readMaybe . dropEq - - dropEq :: String -> String - dropEq ('=':s) = s - dropEq s = s - - invertibleFlagSet :: String -> [String] -> Set String - invertibleFlagSet prefix flagNames = - Set.fromList $ (++) <$> [prefix, prefix ++ "no-"] <*> flagNames - - compatWarningSet :: Set String - compatWarningSet = Set.fromList $ mconcat - [ from [8,6] - [ "missing-monadfail-instances", "semigroup" - , "noncanonical-monoid-instances", "implicit-kind-vars" ] - ] - - safeToFilterHoles :: Bool - safeToFilterHoles = getAll . checkGhcFlags $ - All . fromMaybe True . fmap getLast' . getOption' . foldMap notDeferred - where - notDeferred :: String -> Option' (Last' Bool) - notDeferred "-fdefer-typed-holes" = Option' . Just . Last' $ False - notDeferred "-fno-defer-typed-holes" = Option' . Just . Last' $ True - notDeferred _ = Option' Nothing - - isTypedHoleFlag :: String -> Any - isTypedHoleFlag = mconcat - [ flagIn . invertibleFlagSet "-f" $ - [ "show-hole-constraints", "show-valid-substitutions" - , "show-valid-hole-fits", "sort-valid-hole-fits" - , "sort-by-size-hole-fits", "sort-by-subsumption-hole-fits" - , "abstract-refinement-hole-fits", "show-provenance-of-hole-fits" - , "show-hole-matches-of-hole-fits", "show-type-of-hole-fits" - , "show-type-app-of-hole-fits", "show-type-app-vars-of-hole-fits" - , "unclutter-valid-hole-fits" - ] - , flagIn . Set.fromList $ - [ "-fno-max-valid-hole-fits", "-fno-max-refinement-hole-fits" - , "-fno-refinement-level-hole-fits" ] - , mconcat . map (dropIntFlag False) $ - [ "-fmax-valid-hole-fits", "-fmax-refinement-hole-fits" - , "-frefinement-level-hole-fits" ] - ] - -normaliseGhcArgs _ _ args = args - --- | A structured set of GHC options/flags --- --- Note that options containing lists fall into two categories: --- --- * options that can be safely deduplicated, e.g. input modules or --- enabled extensions; --- * options that cannot be deduplicated in general without changing --- semantics, e.g. extra ghc options or linking options. -data GhcOptions = GhcOptions { - - -- | The major mode for the ghc invocation. - ghcOptMode :: Flag GhcMode, - - -- | Any extra options to pass directly to ghc. These go at the end and hence - -- override other stuff. - ghcOptExtra :: [String], - - -- | Extra default flags to pass directly to ghc. These go at the beginning - -- and so can be overridden by other stuff. - ghcOptExtraDefault :: [String], - - ----------------------- - -- Inputs and outputs - - -- | The main input files; could be .hs, .hi, .c, .o, depending on mode. - ghcOptInputFiles :: NubListR FilePath, - - -- | The names of input Haskell modules, mainly for @--make@ mode. - ghcOptInputModules :: NubListR ModuleName, - - -- | Location for output file; the @ghc -o@ flag. - ghcOptOutputFile :: Flag FilePath, - - -- | Location for dynamic output file in 'GhcStaticAndDynamic' mode; - -- the @ghc -dyno@ flag. - ghcOptOutputDynFile :: Flag FilePath, - - -- | Start with an empty search path for Haskell source files; - -- the @ghc -i@ flag (@-i@ on its own with no path argument). - ghcOptSourcePathClear :: Flag Bool, - - -- | Search path for Haskell source files; the @ghc -i@ flag. - ghcOptSourcePath :: NubListR FilePath, - - ------------- - -- Packages - - -- | The unit ID the modules will belong to; the @ghc -this-unit-id@ - -- flag (or @-this-package-key@ or @-package-name@ on older - -- versions of GHC). This is a 'String' because we assume you've - -- already figured out what the correct format for this string is - -- (we need to handle backwards compatibility.) - ghcOptThisUnitId :: Flag String, - - -- | GHC doesn't make any assumptions about the format of - -- definite unit ids, so when we are instantiating a package it - -- needs to be told explicitly what the component being instantiated - -- is. This only gets set when 'ghcOptInstantiatedWith' is non-empty - ghcOptThisComponentId :: Flag ComponentId, - - -- | How the requirements of the package being compiled are to - -- be filled. When typechecking an indefinite package, the 'OpenModule' - -- is always a 'OpenModuleVar'; otherwise, it specifies the installed module - -- that instantiates a package. - ghcOptInstantiatedWith :: [(ModuleName, OpenModule)], - - -- | No code? (But we turn on interface writing - ghcOptNoCode :: Flag Bool, - - -- | GHC package databases to use, the @ghc -package-conf@ flag. - ghcOptPackageDBs :: PackageDBStack, - - -- | The GHC packages to bring into scope when compiling, - -- the @ghc -package-id@ flags. - ghcOptPackages :: - NubListR (OpenUnitId, ModuleRenaming), - - -- | Start with a clean package set; the @ghc -hide-all-packages@ flag - ghcOptHideAllPackages :: Flag Bool, - - -- | Warn about modules, not listed in command line - ghcOptWarnMissingHomeModules :: Flag Bool, - - -- | Don't automatically link in Haskell98 etc; the @ghc - -- -no-auto-link-packages@ flag. - ghcOptNoAutoLinkPackages :: Flag Bool, - - ----------------- - -- Linker stuff - - -- | Names of libraries to link in; the @ghc -l@ flag. - ghcOptLinkLibs :: [FilePath], - - -- | Search path for libraries to link in; the @ghc -L@ flag. - ghcOptLinkLibPath :: NubListR FilePath, - - -- | Options to pass through to the linker; the @ghc -optl@ flag. - ghcOptLinkOptions :: [String], - - -- | OSX only: frameworks to link in; the @ghc -framework@ flag. - ghcOptLinkFrameworks :: NubListR String, - - -- | OSX only: Search path for frameworks to link in; the - -- @ghc -framework-path@ flag. - ghcOptLinkFrameworkDirs :: NubListR String, - - -- | Don't do the link step, useful in make mode; the @ghc -no-link@ flag. - ghcOptNoLink :: Flag Bool, - - -- | Don't link in the normal RTS @main@ entry point; the @ghc -no-hs-main@ - -- flag. - ghcOptLinkNoHsMain :: Flag Bool, - - -- | Module definition files (Windows specific) - ghcOptLinkModDefFiles :: NubListR FilePath, - - -------------------- - -- C and CPP stuff - - -- | Options to pass through to the C compiler; the @ghc -optc@ flag. - ghcOptCcOptions :: [String], - - -- | Options to pass through to the C++ compiler. - ghcOptCxxOptions :: [String], - - -- | Options to pass through to the Assembler. - ghcOptAsmOptions :: [String], - - -- | Options to pass through to CPP; the @ghc -optP@ flag. - ghcOptCppOptions :: [String], - - -- | Search path for CPP includes like header files; the @ghc -I@ flag. - ghcOptCppIncludePath :: NubListR FilePath, - - -- | Extra header files to include at CPP stage; the @ghc -optP-include@ flag. - ghcOptCppIncludes :: NubListR FilePath, - - -- | Extra header files to include for old-style FFI; the @ghc -#include@ flag. - ghcOptFfiIncludes :: NubListR FilePath, - - ---------------------------- - -- Language and extensions - - -- | The base language; the @ghc -XHaskell98@ or @-XHaskell2010@ flag. - ghcOptLanguage :: Flag Language, - - -- | The language extensions; the @ghc -X@ flag. - ghcOptExtensions :: NubListR Extension, - - -- | A GHC version-dependent mapping of extensions to flags. This must be - -- set to be able to make use of the 'ghcOptExtensions'. - ghcOptExtensionMap :: Map Extension (Maybe CompilerFlag), - - ---------------- - -- Compilation - - -- | What optimisation level to use; the @ghc -O@ flag. - ghcOptOptimisation :: Flag GhcOptimisation, - - -- | Emit debug info; the @ghc -g@ flag. - ghcOptDebugInfo :: Flag DebugInfoLevel, - - -- | Compile in profiling mode; the @ghc -prof@ flag. - ghcOptProfilingMode :: Flag Bool, - - -- | Automatically add profiling cost centers; the @ghc -fprof-auto*@ flags. - ghcOptProfilingAuto :: Flag GhcProfAuto, - - -- | Use the \"split sections\" feature; the @ghc -split-sections@ flag. - ghcOptSplitSections :: Flag Bool, - - -- | Use the \"split object files\" feature; the @ghc -split-objs@ flag. - ghcOptSplitObjs :: Flag Bool, - - -- | Run N jobs simultaneously (if possible). - ghcOptNumJobs :: Flag (Maybe Int), - - -- | Enable coverage analysis; the @ghc -fhpc -hpcdir@ flags. - ghcOptHPCDir :: Flag FilePath, - - ---------------- - -- GHCi - - -- | Extra GHCi startup scripts; the @-ghci-script@ flag - ghcOptGHCiScripts :: [FilePath], - - ------------------------ - -- Redirecting outputs - - ghcOptHiSuffix :: Flag String, - ghcOptObjSuffix :: Flag String, - ghcOptDynHiSuffix :: Flag String, -- ^ only in 'GhcStaticAndDynamic' mode - ghcOptDynObjSuffix :: Flag String, -- ^ only in 'GhcStaticAndDynamic' mode - ghcOptHiDir :: Flag FilePath, - ghcOptObjDir :: Flag FilePath, - ghcOptOutputDir :: Flag FilePath, - ghcOptStubDir :: Flag FilePath, - - -------------------- - -- Creating libraries - - ghcOptDynLinkMode :: Flag GhcDynLinkMode, - ghcOptStaticLib :: Flag Bool, - ghcOptShared :: Flag Bool, - ghcOptFPic :: Flag Bool, - ghcOptDylibName :: Flag String, - ghcOptRPaths :: NubListR FilePath, - - --------------- - -- Misc flags - - -- | Get GHC to be quiet or verbose with what it's doing; the @ghc -v@ flag. - ghcOptVerbosity :: Flag Verbosity, - - -- | Put the extra folders in the PATH environment variable we invoke - -- GHC with - ghcOptExtraPath :: NubListR FilePath, - - -- | Let GHC know that it is Cabal that's calling it. - -- Modifies some of the GHC error messages. - ghcOptCabal :: Flag Bool - -} deriving (Show, Generic) - - -data GhcMode = GhcModeCompile -- ^ @ghc -c@ - | GhcModeLink -- ^ @ghc@ - | GhcModeMake -- ^ @ghc --make@ - | GhcModeInteractive -- ^ @ghci@ \/ @ghc --interactive@ - | GhcModeAbiHash -- ^ @ghc --abi-hash@ --- | GhcModeDepAnalysis -- ^ @ghc -M@ --- | GhcModeEvaluate -- ^ @ghc -e@ - deriving (Show, Eq) - -data GhcOptimisation = GhcNoOptimisation -- ^ @-O0@ - | GhcNormalOptimisation -- ^ @-O@ - | GhcMaximumOptimisation -- ^ @-O2@ - | GhcSpecialOptimisation String -- ^ e.g. @-Odph@ - deriving (Show, Eq) - -data GhcDynLinkMode = GhcStaticOnly -- ^ @-static@ - | GhcDynamicOnly -- ^ @-dynamic@ - | GhcStaticAndDynamic -- ^ @-static -dynamic-too@ - deriving (Show, Eq) - -data GhcProfAuto = GhcProfAutoAll -- ^ @-fprof-auto@ - | GhcProfAutoToplevel -- ^ @-fprof-auto-top@ - | GhcProfAutoExported -- ^ @-fprof-auto-exported@ - deriving (Show, Eq) - -runGHC :: Verbosity -> ConfiguredProgram -> Compiler -> Platform -> GhcOptions - -> IO () -runGHC verbosity ghcProg comp platform opts = do - runProgramInvocation verbosity (ghcInvocation ghcProg comp platform opts) - - -ghcInvocation :: ConfiguredProgram -> Compiler -> Platform -> GhcOptions - -> ProgramInvocation -ghcInvocation prog comp platform opts = - (programInvocation prog (renderGhcOptions comp platform opts)) { - progInvokePathEnv = fromNubListR (ghcOptExtraPath opts) - } - -renderGhcOptions :: Compiler -> Platform -> GhcOptions -> [String] -renderGhcOptions comp _platform@(Platform _arch os) opts - | compilerFlavor comp `notElem` [GHC, GHCJS] = - error $ "Distribution.Simple.Program.GHC.renderGhcOptions: " - ++ "compiler flavor must be 'GHC' or 'GHCJS'!" - | otherwise = - concat - [ case flagToMaybe (ghcOptMode opts) of - Nothing -> [] - Just GhcModeCompile -> ["-c"] - Just GhcModeLink -> [] - Just GhcModeMake -> ["--make"] - Just GhcModeInteractive -> ["--interactive"] - Just GhcModeAbiHash -> ["--abi-hash"] --- Just GhcModeDepAnalysis -> ["-M"] --- Just GhcModeEvaluate -> ["-e", expr] - - , ghcOptExtraDefault opts - - , [ "-no-link" | flagBool ghcOptNoLink ] - - --------------- - -- Misc flags - - , maybe [] verbosityOpts (flagToMaybe (ghcOptVerbosity opts)) - - , [ "-fbuilding-cabal-package" | flagBool ghcOptCabal ] - - ---------------- - -- Compilation - - , case flagToMaybe (ghcOptOptimisation opts) of - Nothing -> [] - Just GhcNoOptimisation -> ["-O0"] - Just GhcNormalOptimisation -> ["-O"] - Just GhcMaximumOptimisation -> ["-O2"] - Just (GhcSpecialOptimisation s) -> ["-O" ++ s] -- eg -Odph - - , case flagToMaybe (ghcOptDebugInfo opts) of - Nothing -> [] - Just NoDebugInfo -> [] - Just MinimalDebugInfo -> ["-g1"] - Just NormalDebugInfo -> ["-g2"] - Just MaximalDebugInfo -> ["-g3"] - - , [ "-prof" | flagBool ghcOptProfilingMode ] - - , case flagToMaybe (ghcOptProfilingAuto opts) of - _ | not (flagBool ghcOptProfilingMode) - -> [] - Nothing -> [] - Just GhcProfAutoAll - | flagProfAuto implInfo -> ["-fprof-auto"] - | otherwise -> ["-auto-all"] -- not the same, but close - Just GhcProfAutoToplevel - | flagProfAuto implInfo -> ["-fprof-auto-top"] - | otherwise -> ["-auto-all"] - Just GhcProfAutoExported - | flagProfAuto implInfo -> ["-fprof-auto-exported"] - | otherwise -> ["-auto"] - - , [ "-split-sections" | flagBool ghcOptSplitSections ] - , [ "-split-objs" | flagBool ghcOptSplitObjs ] - - , case flagToMaybe (ghcOptHPCDir opts) of - Nothing -> [] - Just hpcdir -> ["-fhpc", "-hpcdir", hpcdir] - - , if parmakeSupported comp - then case ghcOptNumJobs opts of - NoFlag -> [] - Flag n -> ["-j" ++ maybe "" show n] - else [] - - -------------------- - -- Creating libraries - - , [ "-staticlib" | flagBool ghcOptStaticLib ] - , [ "-shared" | flagBool ghcOptShared ] - , case flagToMaybe (ghcOptDynLinkMode opts) of - Nothing -> [] - Just GhcStaticOnly -> ["-static"] - Just GhcDynamicOnly -> ["-dynamic"] - Just GhcStaticAndDynamic -> ["-static", "-dynamic-too"] - , [ "-fPIC" | flagBool ghcOptFPic ] - - , concat [ ["-dylib-install-name", libname] | libname <- flag ghcOptDylibName ] - - ------------------------ - -- Redirecting outputs - - , concat [ ["-osuf", suf] | suf <- flag ghcOptObjSuffix ] - , concat [ ["-hisuf", suf] | suf <- flag ghcOptHiSuffix ] - , concat [ ["-dynosuf", suf] | suf <- flag ghcOptDynObjSuffix ] - , concat [ ["-dynhisuf",suf] | suf <- flag ghcOptDynHiSuffix ] - , concat [ ["-outputdir", dir] | dir <- flag ghcOptOutputDir ] - , concat [ ["-odir", dir] | dir <- flag ghcOptObjDir ] - , concat [ ["-hidir", dir] | dir <- flag ghcOptHiDir ] - , concat [ ["-stubdir", dir] | dir <- flag ghcOptStubDir ] - - ----------------------- - -- Source search path - - , [ "-i" | flagBool ghcOptSourcePathClear ] - , [ "-i" ++ dir | dir <- flags ghcOptSourcePath ] - - -------------------- - - -------------------- - -- CPP, C, and C++ stuff - - , [ "-I" ++ dir | dir <- flags ghcOptCppIncludePath ] - , [ "-optP" ++ opt | opt <- ghcOptCppOptions opts] - , concat [ [ "-optP-include", "-optP" ++ inc] - | inc <- flags ghcOptCppIncludes ] - , [ "-optc" ++ opt | opt <- ghcOptCcOptions opts] - , [ "-optc" ++ opt | opt <- ghcOptCxxOptions opts] - , [ "-opta" ++ opt | opt <- ghcOptAsmOptions opts] - - ----------------- - -- Linker stuff - - , [ "-optl" ++ opt | opt <- ghcOptLinkOptions opts] - , ["-l" ++ lib | lib <- ghcOptLinkLibs opts] - , ["-L" ++ dir | dir <- flags ghcOptLinkLibPath ] - , if isOSX - then concat [ ["-framework", fmwk] - | fmwk <- flags ghcOptLinkFrameworks ] - else [] - , if isOSX - then concat [ ["-framework-path", path] - | path <- flags ghcOptLinkFrameworkDirs ] - else [] - , [ "-no-hs-main" | flagBool ghcOptLinkNoHsMain ] - , [ "-dynload deploy" | not (null (flags ghcOptRPaths)) ] - , concat [ [ "-optl-Wl,-rpath," ++ dir] - | dir <- flags ghcOptRPaths ] - , [ modDefFile | modDefFile <- flags ghcOptLinkModDefFiles ] - - ------------- - -- Packages - - , concat [ [ case () of - _ | unitIdSupported comp -> "-this-unit-id" - | packageKeySupported comp -> "-this-package-key" - | otherwise -> "-package-name" - , this_arg ] - | this_arg <- flag ghcOptThisUnitId ] - - , concat [ ["-this-component-id", prettyShow this_cid ] - | this_cid <- flag ghcOptThisComponentId ] - - , if null (ghcOptInstantiatedWith opts) - then [] - else "-instantiated-with" - : intercalate "," (map (\(n,m) -> prettyShow n ++ "=" - ++ prettyShow m) - (ghcOptInstantiatedWith opts)) - : [] - - , concat [ ["-fno-code", "-fwrite-interface"] | flagBool ghcOptNoCode ] - - , [ "-hide-all-packages" | flagBool ghcOptHideAllPackages ] - , [ "-Wmissing-home-modules" | flagBool ghcOptWarnMissingHomeModules ] - , [ "-no-auto-link-packages" | flagBool ghcOptNoAutoLinkPackages ] - - , packageDbArgs implInfo (ghcOptPackageDBs opts) - - , concat $ let space "" = "" - space xs = ' ' : xs - in [ ["-package-id", prettyShow ipkgid ++ space (prettyShow rns)] - | (ipkgid,rns) <- flags ghcOptPackages ] - - ---------------------------- - -- Language and extensions - - , if supportsHaskell2010 implInfo - then [ "-X" ++ prettyShow lang | lang <- flag ghcOptLanguage ] - else [] - - , [ ext' - | ext <- flags ghcOptExtensions - , ext' <- case Map.lookup ext (ghcOptExtensionMap opts) of - Just (Just arg) -> [arg] - Just Nothing -> [] - Nothing -> - error $ "Distribution.Simple.Program.GHC.renderGhcOptions: " - ++ prettyShow ext ++ " not present in ghcOptExtensionMap." - ] - - ---------------- - -- GHCi - - , concat [ [ "-ghci-script", script ] | script <- ghcOptGHCiScripts opts - , flagGhciScript implInfo ] - - --------------- - -- Inputs - - -- Specify the input file(s) first, so that in ghci the `main-is` module is - -- in scope instead of the first module defined in `other-modules`. - , flags ghcOptInputFiles - , [ prettyShow modu | modu <- flags ghcOptInputModules ] - - , concat [ [ "-o", out] | out <- flag ghcOptOutputFile ] - , concat [ [ "-dyno", out] | out <- flag ghcOptOutputDynFile ] - - --------------- - -- Extra - - , ghcOptExtra opts - - ] - - - where - implInfo = getImplInfo comp - isOSX = os == OSX - flag flg = flagToList (flg opts) - flags flg = fromNubListR . flg $ opts - flagBool flg = fromFlagOrDefault False (flg opts) - -verbosityOpts :: Verbosity -> [String] -verbosityOpts verbosity - | verbosity >= deafening = ["-v"] - | verbosity >= normal = [] - | otherwise = ["-w", "-v0"] - - --- | GHC <7.6 uses '-package-conf' instead of '-package-db'. -packageDbArgsConf :: PackageDBStack -> [String] -packageDbArgsConf dbstack = case dbstack of - (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs - (GlobalPackageDB:dbs) -> ("-no-user-package-conf") - : concatMap specific dbs - _ -> ierror - where - specific (SpecificPackageDB db) = [ "-package-conf", db ] - specific _ = ierror - ierror = error $ "internal error: unexpected package db stack: " - ++ show dbstack - --- | GHC >= 7.6 uses the '-package-db' flag. See --- https://gitlab.haskell.org/ghc/ghc/-/issues/5977. -packageDbArgsDb :: PackageDBStack -> [String] --- special cases to make arguments prettier in common scenarios -packageDbArgsDb dbstack = case dbstack of - (GlobalPackageDB:UserPackageDB:dbs) - | all isSpecific dbs -> concatMap single dbs - (GlobalPackageDB:dbs) - | all isSpecific dbs -> "-no-user-package-db" - : concatMap single dbs - dbs -> "-clear-package-db" - : concatMap single dbs - where - single (SpecificPackageDB db) = [ "-package-db", db ] - single GlobalPackageDB = [ "-global-package-db" ] - single UserPackageDB = [ "-user-package-db" ] - isSpecific (SpecificPackageDB _) = True - isSpecific _ = False - -packageDbArgs :: GhcImplInfo -> PackageDBStack -> [String] -packageDbArgs implInfo - | flagPackageConf implInfo = packageDbArgsConf - | otherwise = packageDbArgsDb - --- ----------------------------------------------------------------------------- --- Boilerplate Monoid instance for GhcOptions - -instance Monoid GhcOptions where - mempty = gmempty - mappend = (<>) - -instance Semigroup GhcOptions where - (<>) = gmappend diff --git a/cabal/Cabal/Distribution/Simple/Program/HcPkg.hs b/cabal/Cabal/Distribution/Simple/Program/HcPkg.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/Program/HcPkg.hs +++ /dev/null @@ -1,516 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE OverloadedStrings #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Program.HcPkg --- Copyright : Duncan Coutts 2009, 2013 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This module provides an library interface to the @hc-pkg@ program. --- Currently only GHC and GHCJS have hc-pkg programs. - -module Distribution.Simple.Program.HcPkg ( - -- * Types - HcPkgInfo(..), - RegisterOptions(..), - defaultRegisterOptions, - - -- * Actions - init, - invoke, - register, - unregister, - recache, - expose, - hide, - dump, - describe, - list, - - -- * Program invocations - initInvocation, - registerInvocation, - unregisterInvocation, - recacheInvocation, - exposeInvocation, - hideInvocation, - dumpInvocation, - describeInvocation, - listInvocation, - ) where - -import Distribution.Compat.Prelude hiding (init) -import Prelude () - -import Distribution.InstalledPackageInfo -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Simple.Compiler -import Distribution.Simple.Program.Run -import Distribution.Simple.Program.Types -import Distribution.Simple.Utils -import Distribution.Types.ComponentId -import Distribution.Types.PackageId -import Distribution.Types.UnitId -import Distribution.Verbosity - -import Data.List (stripPrefix) -import System.FilePath as FilePath (isPathSeparator, joinPath, splitDirectories, splitPath, (<.>), ()) - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LBS -import qualified Data.List.NonEmpty as NE -import qualified System.FilePath.Posix as FilePath.Posix - --- | Information about the features and capabilities of an @hc-pkg@ --- program. --- -data HcPkgInfo = HcPkgInfo - { hcPkgProgram :: ConfiguredProgram - , noPkgDbStack :: Bool -- ^ no package DB stack supported - , noVerboseFlag :: Bool -- ^ hc-pkg does not support verbosity flags - , flagPackageConf :: Bool -- ^ use package-conf option instead of package-db - , supportsDirDbs :: Bool -- ^ supports directory style package databases - , requiresDirDbs :: Bool -- ^ requires directory style package databases - , nativeMultiInstance :: Bool -- ^ supports --enable-multi-instance flag - , recacheMultiInstance :: Bool -- ^ supports multi-instance via recache - , suppressFilesCheck :: Bool -- ^ supports --force-files or equivalent - } - - --- | Call @hc-pkg@ to initialise a package database at the location {path}. --- --- > hc-pkg init {path} --- -init :: HcPkgInfo -> Verbosity -> Bool -> FilePath -> IO () -init hpi verbosity preferCompat path - | not (supportsDirDbs hpi) - || (not (requiresDirDbs hpi) && preferCompat) - = writeFile path "[]" - - | otherwise - = runProgramInvocation verbosity (initInvocation hpi verbosity path) - --- | Run @hc-pkg@ using a given package DB stack, directly forwarding the --- provided command-line arguments to it. -invoke :: HcPkgInfo -> Verbosity -> PackageDBStack -> [String] -> IO () -invoke hpi verbosity dbStack extraArgs = - runProgramInvocation verbosity invocation - where - args = packageDbStackOpts hpi dbStack ++ extraArgs - invocation = programInvocation (hcPkgProgram hpi) args - --- | Additional variations in the behaviour for 'register'. -data RegisterOptions = RegisterOptions { - -- | Allows re-registering \/ overwriting an existing package - registerAllowOverwrite :: Bool, - - -- | Insist on the ability to register multiple instances of a - -- single version of a single package. This will fail if the @hc-pkg@ - -- does not support it, see 'nativeMultiInstance' and - -- 'recacheMultiInstance'. - registerMultiInstance :: Bool, - - -- | Require that no checks are performed on the existence of package - -- files mentioned in the registration info. This must be used if - -- registering prior to putting the files in their final place. This will - -- fail if the @hc-pkg@ does not support it, see 'suppressFilesCheck'. - registerSuppressFilesCheck :: Bool - } - --- | Defaults are @True@, @False@ and @False@ -defaultRegisterOptions :: RegisterOptions -defaultRegisterOptions = RegisterOptions { - registerAllowOverwrite = True, - registerMultiInstance = False, - registerSuppressFilesCheck = False - } - --- | Call @hc-pkg@ to register a package. --- --- > hc-pkg register {filename | -} [--user | --global | --package-db] --- -register :: HcPkgInfo -> Verbosity -> PackageDBStack - -> InstalledPackageInfo - -> RegisterOptions - -> IO () -register hpi verbosity packagedbs pkgInfo registerOptions - | registerMultiInstance registerOptions - , not (nativeMultiInstance hpi || recacheMultiInstance hpi) - = die' verbosity $ "HcPkg.register: the compiler does not support " - ++ "registering multiple instances of packages." - - | registerSuppressFilesCheck registerOptions - , not (suppressFilesCheck hpi) - = die' verbosity $ "HcPkg.register: the compiler does not support " - ++ "suppressing checks on files." - - -- This is a trick. Older versions of GHC do not support the - -- --enable-multi-instance flag for ghc-pkg register but it turns out that - -- the same ability is available by using ghc-pkg recache. The recache - -- command is there to support distro package managers that like to work - -- by just installing files and running update commands, rather than - -- special add/remove commands. So the way to register by this method is - -- to write the package registration file directly into the package db and - -- then call hc-pkg recache. - -- - | registerMultiInstance registerOptions - , recacheMultiInstance hpi - = do let pkgdb = registrationPackageDB packagedbs - writeRegistrationFileDirectly verbosity hpi pkgdb pkgInfo - recache hpi verbosity pkgdb - - | otherwise - = runProgramInvocation verbosity - (registerInvocation hpi verbosity packagedbs pkgInfo registerOptions) - -writeRegistrationFileDirectly :: Verbosity - -> HcPkgInfo - -> PackageDB - -> InstalledPackageInfo - -> IO () -writeRegistrationFileDirectly verbosity hpi (SpecificPackageDB dir) pkgInfo - | supportsDirDbs hpi - = do let pkgfile = dir prettyShow (installedUnitId pkgInfo) <.> "conf" - writeUTF8File pkgfile (showInstalledPackageInfo pkgInfo) - - | otherwise - = die' verbosity $ "HcPkg.writeRegistrationFileDirectly: compiler does not support dir style package dbs" - -writeRegistrationFileDirectly verbosity _ _ _ = - -- We don't know here what the dir for the global or user dbs are, - -- if that's needed it'll require a bit more plumbing to support. - die' verbosity $ "HcPkg.writeRegistrationFileDirectly: only supports SpecificPackageDB for now" - - --- | Call @hc-pkg@ to unregister a package --- --- > hc-pkg unregister [pkgid] [--user | --global | --package-db] --- -unregister :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO () -unregister hpi verbosity packagedb pkgid = - runProgramInvocation verbosity - (unregisterInvocation hpi verbosity packagedb pkgid) - - --- | Call @hc-pkg@ to recache the registered packages. --- --- > hc-pkg recache [--user | --global | --package-db] --- -recache :: HcPkgInfo -> Verbosity -> PackageDB -> IO () -recache hpi verbosity packagedb = - runProgramInvocation verbosity - (recacheInvocation hpi verbosity packagedb) - - --- | Call @hc-pkg@ to expose a package. --- --- > hc-pkg expose [pkgid] [--user | --global | --package-db] --- -expose :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO () -expose hpi verbosity packagedb pkgid = - runProgramInvocation verbosity - (exposeInvocation hpi verbosity packagedb pkgid) - --- | Call @hc-pkg@ to retrieve a specific package --- --- > hc-pkg describe [pkgid] [--user | --global | --package-db] --- -describe :: HcPkgInfo -> Verbosity -> PackageDBStack -> PackageId -> IO [InstalledPackageInfo] -describe hpi verbosity packagedb pid = do - - output <- getProgramInvocationLBS verbosity - (describeInvocation hpi verbosity packagedb pid) - `catchIO` \_ -> return mempty - - case parsePackages output of - Left ok -> return ok - _ -> die' verbosity $ "failed to parse output of '" - ++ programId (hcPkgProgram hpi) ++ " describe " ++ prettyShow pid ++ "'" - --- | Call @hc-pkg@ to hide a package. --- --- > hc-pkg hide [pkgid] [--user | --global | --package-db] --- -hide :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO () -hide hpi verbosity packagedb pkgid = - runProgramInvocation verbosity - (hideInvocation hpi verbosity packagedb pkgid) - - --- | Call @hc-pkg@ to get all the details of all the packages in the given --- package database. --- -dump :: HcPkgInfo -> Verbosity -> PackageDB -> IO [InstalledPackageInfo] -dump hpi verbosity packagedb = do - - output <- getProgramInvocationLBS verbosity - (dumpInvocation hpi verbosity packagedb) - `catchIO` \e -> die' verbosity $ programId (hcPkgProgram hpi) ++ " dump failed: " - ++ displayException e - - case parsePackages output of - Left ok -> return ok - _ -> die' verbosity $ "failed to parse output of '" - ++ programId (hcPkgProgram hpi) ++ " dump'" - - -parsePackages :: LBS.ByteString -> Either [InstalledPackageInfo] [String] -parsePackages lbs0 = - case traverse parseInstalledPackageInfo $ splitPkgs lbs0 of - Right ok -> Left [ setUnitId . maybe id mungePackagePaths (pkgRoot pkg) $ pkg | (_, pkg) <- ok ] - Left msgs -> Right (NE.toList msgs) - where - splitPkgs :: LBS.ByteString -> [BS.ByteString] - splitPkgs = checkEmpty . doSplit - where - -- Handle the case of there being no packages at all. - checkEmpty [s] | BS.all isSpace8 s = [] - checkEmpty ss = ss - - isSpace8 :: Word8 -> Bool - isSpace8 9 = True -- '\t' - isSpace8 10 = True -- '\n' - isSpace8 13 = True -- '\r' - isSpace8 32 = True -- ' ' - isSpace8 _ = False - - doSplit :: LBS.ByteString -> [BS.ByteString] - doSplit lbs = go (LBS.findIndices (\w -> w == 10 || w == 13) lbs) - where - go :: [Int64] -> [BS.ByteString] - go [] = [ LBS.toStrict lbs ] - go (idx:idxs) = - let (pfx, sfx) = LBS.splitAt idx lbs - in case foldr (<|>) Nothing $ map (`lbsStripPrefix` sfx) separators of - Just sfx' -> LBS.toStrict pfx : doSplit sfx' - Nothing -> go idxs - - separators :: [LBS.ByteString] - separators = ["\n---\n", "\r\n---\r\n", "\r---\r"] - -lbsStripPrefix :: LBS.ByteString -> LBS.ByteString -> Maybe LBS.ByteString -#if MIN_VERSION_bytestring(0,10,8) -lbsStripPrefix pfx lbs = LBS.stripPrefix pfx lbs -#else -lbsStripPrefix pfx lbs - | LBS.isPrefixOf pfx lbs = Just (LBS.drop (LBS.length pfx) lbs) - | otherwise = Nothing -#endif - - -mungePackagePaths :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo --- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec --- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html) --- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}. --- The "pkgroot" is the directory containing the package database. -mungePackagePaths pkgroot pkginfo = - pkginfo { - importDirs = mungePaths (importDirs pkginfo), - includeDirs = mungePaths (includeDirs pkginfo), - libraryDirs = mungePaths (libraryDirs pkginfo), - libraryDynDirs = mungePaths (libraryDynDirs pkginfo), - frameworkDirs = mungePaths (frameworkDirs pkginfo), - haddockInterfaces = mungePaths (haddockInterfaces pkginfo), - haddockHTMLs = mungeUrls (haddockHTMLs pkginfo) - } - where - mungePaths = map mungePath - mungeUrls = map mungeUrl - - mungePath p = case stripVarPrefix "${pkgroot}" p of - Just p' -> pkgroot p' - Nothing -> p - - mungeUrl p = case stripVarPrefix "${pkgrooturl}" p of - Just p' -> toUrlPath pkgroot p' - Nothing -> p - - toUrlPath r p = "file:///" - -- URLs always use posix style '/' separators: - ++ FilePath.Posix.joinPath (r : FilePath.splitDirectories p) - - stripVarPrefix var p = - case splitPath p of - (root:path') -> case stripPrefix var root of - Just [sep] | isPathSeparator sep -> Just (joinPath path') - _ -> Nothing - _ -> Nothing - - --- Older installed package info files did not have the installedUnitId --- field, so if it is missing then we fill it as the source package ID. --- NB: Internal libraries not supported. -setUnitId :: InstalledPackageInfo -> InstalledPackageInfo -setUnitId pkginfo@InstalledPackageInfo { - installedUnitId = uid, - sourcePackageId = pid - } | unUnitId uid == "" - = pkginfo { - installedUnitId = mkLegacyUnitId pid, - installedComponentId_ = mkComponentId (prettyShow pid) - } -setUnitId pkginfo = pkginfo - - --- | Call @hc-pkg@ to get the source package Id of all the packages in the --- given package database. --- --- This is much less information than with 'dump', but also rather quicker. --- Note in particular that it does not include the 'UnitId', just --- the source 'PackageId' which is not necessarily unique in any package db. --- -list :: HcPkgInfo -> Verbosity -> PackageDB - -> IO [PackageId] -list hpi verbosity packagedb = do - - output <- getProgramInvocationOutput verbosity - (listInvocation hpi verbosity packagedb) - `catchIO` \_ -> die' verbosity $ programId (hcPkgProgram hpi) ++ " list failed" - - case parsePackageIds output of - Just ok -> return ok - _ -> die' verbosity $ "failed to parse output of '" - ++ programId (hcPkgProgram hpi) ++ " list'" - - where - parsePackageIds = traverse simpleParsec . words - --------------------------- --- The program invocations --- - -initInvocation :: HcPkgInfo -> Verbosity -> FilePath -> ProgramInvocation -initInvocation hpi verbosity path = - programInvocation (hcPkgProgram hpi) args - where - args = ["init", path] - ++ verbosityOpts hpi verbosity - -registerInvocation - :: HcPkgInfo -> Verbosity -> PackageDBStack - -> InstalledPackageInfo - -> RegisterOptions - -> ProgramInvocation -registerInvocation hpi verbosity packagedbs pkgInfo registerOptions = - (programInvocation (hcPkgProgram hpi) (args "-")) { - progInvokeInput = Just $ IODataText $ showInstalledPackageInfo pkgInfo, - progInvokeInputEncoding = IOEncodingUTF8 - } - where - cmdname - | registerAllowOverwrite registerOptions = "update" - | registerMultiInstance registerOptions = "update" - | otherwise = "register" - - args file = [cmdname, file] - ++ packageDbStackOpts hpi packagedbs - ++ [ "--enable-multi-instance" - | registerMultiInstance registerOptions ] - ++ [ "--force-files" - | registerSuppressFilesCheck registerOptions ] - ++ verbosityOpts hpi verbosity - -unregisterInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId - -> ProgramInvocation -unregisterInvocation hpi verbosity packagedb pkgid = - programInvocation (hcPkgProgram hpi) $ - ["unregister", packageDbOpts hpi packagedb, prettyShow pkgid] - ++ verbosityOpts hpi verbosity - - -recacheInvocation :: HcPkgInfo -> Verbosity -> PackageDB - -> ProgramInvocation -recacheInvocation hpi verbosity packagedb = - programInvocation (hcPkgProgram hpi) $ - ["recache", packageDbOpts hpi packagedb] - ++ verbosityOpts hpi verbosity - - -exposeInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId - -> ProgramInvocation -exposeInvocation hpi verbosity packagedb pkgid = - programInvocation (hcPkgProgram hpi) $ - ["expose", packageDbOpts hpi packagedb, prettyShow pkgid] - ++ verbosityOpts hpi verbosity - -describeInvocation :: HcPkgInfo -> Verbosity -> PackageDBStack -> PackageId - -> ProgramInvocation -describeInvocation hpi verbosity packagedbs pkgid = - programInvocation (hcPkgProgram hpi) $ - ["describe", prettyShow pkgid] - ++ packageDbStackOpts hpi packagedbs - ++ verbosityOpts hpi verbosity - -hideInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId - -> ProgramInvocation -hideInvocation hpi verbosity packagedb pkgid = - programInvocation (hcPkgProgram hpi) $ - ["hide", packageDbOpts hpi packagedb, prettyShow pkgid] - ++ verbosityOpts hpi verbosity - - -dumpInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> ProgramInvocation -dumpInvocation hpi _verbosity packagedb = - (programInvocation (hcPkgProgram hpi) args) { - progInvokeOutputEncoding = IOEncodingUTF8 - } - where - args = ["dump", packageDbOpts hpi packagedb] - ++ verbosityOpts hpi silent - -- We use verbosity level 'silent' because it is important that we - -- do not contaminate the output with info/debug messages. - -listInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> ProgramInvocation -listInvocation hpi _verbosity packagedb = - (programInvocation (hcPkgProgram hpi) args) { - progInvokeOutputEncoding = IOEncodingUTF8 - } - where - args = ["list", "--simple-output", packageDbOpts hpi packagedb] - ++ verbosityOpts hpi silent - -- We use verbosity level 'silent' because it is important that we - -- do not contaminate the output with info/debug messages. - - -packageDbStackOpts :: HcPkgInfo -> PackageDBStack -> [String] -packageDbStackOpts hpi dbstack - | noPkgDbStack hpi = [packageDbOpts hpi (registrationPackageDB dbstack)] - | otherwise = case dbstack of - (GlobalPackageDB:UserPackageDB:dbs) -> "--global" - : "--user" - : map specific dbs - (GlobalPackageDB:dbs) -> "--global" - : ("--no-user-" ++ packageDbFlag hpi) - : map specific dbs - _ -> ierror - where - specific (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ db - specific _ = ierror - ierror :: a - ierror = error ("internal error: unexpected package db stack: " ++ show dbstack) - -packageDbFlag :: HcPkgInfo -> String -packageDbFlag hpi - | flagPackageConf hpi - = "package-conf" - | otherwise - = "package-db" - -packageDbOpts :: HcPkgInfo -> PackageDB -> String -packageDbOpts _ GlobalPackageDB = "--global" -packageDbOpts _ UserPackageDB = "--user" -packageDbOpts hpi (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ db - -verbosityOpts :: HcPkgInfo -> Verbosity -> [String] -verbosityOpts hpi v - | noVerboseFlag hpi - = [] - | v >= deafening = ["-v2"] - | v == silent = ["-v0"] - | otherwise = [] diff --git a/cabal/Cabal/Distribution/Simple/Program/Hpc.hs b/cabal/Cabal/Distribution/Simple/Program/Hpc.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/Program/Hpc.hs +++ /dev/null @@ -1,110 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Program.Hpc --- Copyright : Thomas Tuegel 2011 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This module provides an library interface to the @hpc@ program. - -module Distribution.Simple.Program.Hpc - ( markup - , union - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import System.Directory (makeRelativeToCurrentDirectory) - -import Distribution.ModuleName -import Distribution.Simple.Program.Run -import Distribution.Simple.Program.Types -import Distribution.Pretty -import Distribution.Simple.Utils -import Distribution.Verbosity -import Distribution.Version - --- | Invoke hpc with the given parameters. --- --- Prior to HPC version 0.7 (packaged with GHC 7.8), hpc did not handle --- multiple .mix paths correctly, so we print a warning, and only pass it the --- first path in the list. This means that e.g. test suites that import their --- library as a dependency can still work, but those that include the library --- modules directly (in other-modules) don't. -markup :: ConfiguredProgram - -> Version - -> Verbosity - -> FilePath -- ^ Path to .tix file - -> [FilePath] -- ^ Paths to .mix file directories - -> FilePath -- ^ Path where html output should be located - -> [ModuleName] -- ^ List of modules to exclude from report - -> IO () -markup hpc hpcVer verbosity tixFile hpcDirs destDir excluded = do - hpcDirs' <- if withinRange hpcVer (orLaterVersion version07) - then return hpcDirs - else do - warn verbosity $ "Your version of HPC (" ++ prettyShow hpcVer - ++ ") does not properly handle multiple search paths. " - ++ "Coverage report generation may fail unexpectedly. These " - ++ "issues are addressed in version 0.7 or later (GHC 7.8 or " - ++ "later)." - ++ if null droppedDirs - then "" - else " The following search paths have been abandoned: " - ++ show droppedDirs - return passedDirs - - -- Prior to GHC 8.0, hpc assumes all .mix paths are relative. - hpcDirs'' <- traverse makeRelativeToCurrentDirectory hpcDirs' - - runProgramInvocation verbosity - (markupInvocation hpc tixFile hpcDirs'' destDir excluded) - where - version07 = mkVersion [0, 7] - (passedDirs, droppedDirs) = splitAt 1 hpcDirs - -markupInvocation :: ConfiguredProgram - -> FilePath -- ^ Path to .tix file - -> [FilePath] -- ^ Paths to .mix file directories - -> FilePath -- ^ Path where html output should be - -- located - -> [ModuleName] -- ^ List of modules to exclude from - -- report - -> ProgramInvocation -markupInvocation hpc tixFile hpcDirs destDir excluded = - let args = [ "markup", tixFile - , "--destdir=" ++ destDir - ] - ++ map ("--hpcdir=" ++) hpcDirs - ++ ["--exclude=" ++ prettyShow moduleName - | moduleName <- excluded ] - in programInvocation hpc args - -union :: ConfiguredProgram - -> Verbosity - -> [FilePath] -- ^ Paths to .tix files - -> FilePath -- ^ Path to resultant .tix file - -> [ModuleName] -- ^ List of modules to exclude from union - -> IO () -union hpc verbosity tixFiles outFile excluded = - runProgramInvocation verbosity - (unionInvocation hpc tixFiles outFile excluded) - -unionInvocation :: ConfiguredProgram - -> [FilePath] -- ^ Paths to .tix files - -> FilePath -- ^ Path to resultant .tix file - -> [ModuleName] -- ^ List of modules to exclude from union - -> ProgramInvocation -unionInvocation hpc tixFiles outFile excluded = - programInvocation hpc $ concat - [ ["sum", "--union"] - , tixFiles - , ["--output=" ++ outFile] - , ["--exclude=" ++ prettyShow moduleName - | moduleName <- excluded ] - ] diff --git a/cabal/Cabal/Distribution/Simple/Program/Internal.hs b/cabal/Cabal/Distribution/Simple/Program/Internal.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/Program/Internal.hs +++ /dev/null @@ -1,47 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Program.Internal --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Internal utilities used by Distribution.Simple.Program.*. - -module Distribution.Simple.Program.Internal ( - stripExtractVersion, - ) where - -import Prelude () -import Distribution.Compat.Prelude -import Distribution.Utils.Generic(safeTail) - --- | Extract the version number from the output of 'strip --version'. --- --- Invoking "strip --version" gives very inconsistent results. We ignore --- everything in parentheses (see #2497), look for the first word that starts --- with a number, and try parsing out the first two components of it. Non-GNU --- 'strip' doesn't appear to have a version flag. -stripExtractVersion :: String -> String -stripExtractVersion str = - let numeric "" = False - numeric (x:_) = isDigit x - - -- Filter out everything in parentheses. - filterPar' :: Int -> [String] -> [String] - filterPar' _ [] = [] - filterPar' n (x:xs) - | n >= 0 && "(" `isPrefixOf` x = filterPar' (n+1) ((safeTail x):xs) - | n > 0 && ")" `isSuffixOf` x = filterPar' (n-1) xs - | n > 0 = filterPar' n xs - | otherwise = x:filterPar' n xs - - filterPar = filterPar' 0 - - in case dropWhile (not . numeric) (filterPar . words $ str) of - (ver:_) -> - -- take the first two version components - let isDot = (== '.') - (major, rest) = break isDot ver - minor = takeWhile isDigit (dropWhile isDot rest) - in major ++ "." ++ minor - _ -> "" diff --git a/cabal/Cabal/Distribution/Simple/Program/Ld.hs b/cabal/Cabal/Distribution/Simple/Program/Ld.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/Program/Ld.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Program.Ld --- Copyright : Duncan Coutts 2009 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This module provides an library interface to the @ld@ linker program. - -module Distribution.Simple.Program.Ld ( - combineObjectFiles, - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Simple.Compiler (arResponseFilesSupported) -import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..)) -import Distribution.Simple.Program.ResponseFile - ( withResponseFile ) -import Distribution.Simple.Program.Run - ( ProgramInvocation, programInvocation, multiStageProgramInvocation - , runProgramInvocation ) -import Distribution.Simple.Program.Types - ( ConfiguredProgram(..) ) -import Distribution.Simple.Setup - ( fromFlagOrDefault, configUseResponseFiles ) -import Distribution.Simple.Utils - ( defaultTempFileOptions ) -import Distribution.Verbosity - ( Verbosity ) - -import System.Directory - ( renameFile ) -import System.FilePath - ( (<.>), takeDirectory ) - --- | Call @ld -r@ to link a bunch of object files together. --- -combineObjectFiles :: Verbosity -> LocalBuildInfo -> ConfiguredProgram - -> FilePath -> [FilePath] -> IO () -combineObjectFiles verbosity lbi ld target files = do - - -- Unlike "ar", the "ld" tool is not designed to be used with xargs. That is, - -- if we have more object files than fit on a single command line then we - -- have a slight problem. What we have to do is link files in batches into - -- a temp object file and then include that one in the next batch. - - let simpleArgs = ["-r", "-o", target] - - initialArgs = ["-r", "-o", target] - middleArgs = ["-r", "-o", target, tmpfile] - finalArgs = middleArgs - - simple = programInvocation ld simpleArgs - initial = programInvocation ld initialArgs - middle = programInvocation ld middleArgs - final = programInvocation ld finalArgs - - targetDir = takeDirectory target - - invokeWithResponesFile :: FilePath -> ProgramInvocation - invokeWithResponesFile atFile = - programInvocation ld $ simpleArgs ++ ['@' : atFile] - - oldVersionManualOverride = - fromFlagOrDefault False $ configUseResponseFiles $ configFlags lbi - -- Whether ghc's ar supports response files is a good proxy for - -- whether ghc's ld supports them as well. - responseArgumentsNotSupported = - not (arResponseFilesSupported (compiler lbi)) - - if oldVersionManualOverride || responseArgumentsNotSupported - then - run $ multiStageProgramInvocation simple (initial, middle, final) files - else - withResponseFile verbosity defaultTempFileOptions targetDir "ld.rsp" Nothing files $ - \path -> runProgramInvocation verbosity $ invokeWithResponesFile path - - where - tmpfile = target <.> "tmp" -- perhaps should use a proper temp file - - run :: [ProgramInvocation] -> IO () - run [] = return () - run [inv] = runProgramInvocation verbosity inv - run (inv:invs) = do runProgramInvocation verbosity inv - renameFile target tmpfile - run invs diff --git a/cabal/Cabal/Distribution/Simple/Program/ResponseFile.hs b/cabal/Cabal/Distribution/Simple/Program/ResponseFile.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/Program/ResponseFile.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- --- | --- Module : Distribution.Simple.Program.ResponseFile --- Copyright : (c) Sergey Vinokurov 2017 --- License : BSD3-style --- --- Maintainer : cabal-devel@haskell.org --- Created : 23 July 2017 ----------------------------------------------------------------------------- - -module Distribution.Simple.Program.ResponseFile (withResponseFile) where - -import Prelude () -import System.IO (TextEncoding, hSetEncoding, hPutStr, hClose) - -import Distribution.Compat.Prelude -import Distribution.Simple.Utils (TempFileOptions, withTempFileEx, debug) -import Distribution.Verbosity - -withResponseFile - :: Verbosity - -> TempFileOptions - -> FilePath -- ^ Working directory to create response file in. - -> FilePath -- ^ Template for response file name. - -> Maybe TextEncoding -- ^ Encoding to use for response file contents. - -> [String] -- ^ Arguments to put into response file. - -> (FilePath -> IO a) - -> IO a -withResponseFile verbosity tmpFileOpts workDir fileNameTemplate encoding arguments f = - withTempFileEx tmpFileOpts workDir fileNameTemplate $ \responseFileName hf -> do - traverse_ (hSetEncoding hf) encoding - let responseContents = unlines $ map escapeResponseFileArg arguments - hPutStr hf responseContents - hClose hf - debug verbosity $ responseFileName ++ " contents: <<<" - debug verbosity responseContents - debug verbosity $ ">>> " ++ responseFileName - f responseFileName - --- Support a gcc-like response file syntax. Each separate --- argument and its possible parameter(s), will be separated in the --- response file by an actual newline; all other whitespace, --- single quotes, double quotes, and the character used for escaping --- (backslash) are escaped. The called program will need to do a similar --- inverse operation to de-escape and re-constitute the argument list. -escapeResponseFileArg :: String -> String -escapeResponseFileArg = reverse . foldl' escape [] - where - escape :: String -> Char -> String - escape cs c = - case c of - '\\' -> c:'\\':cs - '\'' -> c:'\\':cs - '"' -> c:'\\':cs - _ | isSpace c -> c:'\\':cs - | otherwise -> c:cs - - diff --git a/cabal/Cabal/Distribution/Simple/Program/Run.hs b/cabal/Cabal/Distribution/Simple/Program/Run.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/Program/Run.hs +++ /dev/null @@ -1,297 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Program.Run --- Copyright : Duncan Coutts 2009 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This module provides a data type for program invocations and functions to --- run them. - -module Distribution.Simple.Program.Run ( - ProgramInvocation(..), - IOEncoding(..), - emptyProgramInvocation, - simpleProgramInvocation, - programInvocation, - multiStageProgramInvocation, - - runProgramInvocation, - getProgramInvocationOutput, - getProgramInvocationLBS, - getProgramInvocationOutputAndErrors, - - getEffectiveEnvironment, - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Compat.Environment -import Distribution.Simple.Program.Types -import Distribution.Simple.Utils -import Distribution.Utils.Generic -import Distribution.Verbosity - -import System.FilePath (searchPathSeparator) - -import qualified Data.ByteString.Lazy as LBS -import qualified Data.Map as Map - --- | Represents a specific invocation of a specific program. --- --- This is used as an intermediate type between deciding how to call a program --- and actually doing it. This provides the opportunity to the caller to --- adjust how the program will be called. These invocations can either be run --- directly or turned into shell or batch scripts. --- -data ProgramInvocation = ProgramInvocation { - progInvokePath :: FilePath, - progInvokeArgs :: [String], - progInvokeEnv :: [(String, Maybe String)], - -- Extra paths to add to PATH - progInvokePathEnv :: [FilePath], - progInvokeCwd :: Maybe FilePath, - progInvokeInput :: Maybe IOData, - progInvokeInputEncoding :: IOEncoding, -- ^ TODO: remove this, make user decide when constructing 'progInvokeInput'. - progInvokeOutputEncoding :: IOEncoding - } - -data IOEncoding = IOEncodingText -- locale mode text - | IOEncodingUTF8 -- always utf8 - -encodeToIOData :: IOEncoding -> IOData -> IOData -encodeToIOData _ iod@(IODataBinary _) = iod -encodeToIOData IOEncodingText iod@(IODataText _) = iod -encodeToIOData IOEncodingUTF8 (IODataText str) = IODataBinary (toUTF8LBS str) - -emptyProgramInvocation :: ProgramInvocation -emptyProgramInvocation = - ProgramInvocation { - progInvokePath = "", - progInvokeArgs = [], - progInvokeEnv = [], - progInvokePathEnv = [], - progInvokeCwd = Nothing, - progInvokeInput = Nothing, - progInvokeInputEncoding = IOEncodingText, - progInvokeOutputEncoding = IOEncodingText - } - -simpleProgramInvocation :: FilePath -> [String] -> ProgramInvocation -simpleProgramInvocation path args = - emptyProgramInvocation { - progInvokePath = path, - progInvokeArgs = args - } - -programInvocation :: ConfiguredProgram -> [String] -> ProgramInvocation -programInvocation prog args = - emptyProgramInvocation { - progInvokePath = programPath prog, - progInvokeArgs = programDefaultArgs prog - ++ args - ++ programOverrideArgs prog, - progInvokeEnv = programOverrideEnv prog - } - - -runProgramInvocation :: Verbosity -> ProgramInvocation -> IO () -runProgramInvocation verbosity - ProgramInvocation { - progInvokePath = path, - progInvokeArgs = args, - progInvokeEnv = [], - progInvokePathEnv = [], - progInvokeCwd = Nothing, - progInvokeInput = Nothing - } = - rawSystemExit verbosity path args - -runProgramInvocation verbosity - ProgramInvocation { - progInvokePath = path, - progInvokeArgs = args, - progInvokeEnv = envOverrides, - progInvokePathEnv = extraPath, - progInvokeCwd = mcwd, - progInvokeInput = Nothing - } = do - pathOverride <- getExtraPathEnv envOverrides extraPath - menv <- getEffectiveEnvironment (envOverrides ++ pathOverride) - exitCode <- rawSystemIOWithEnv verbosity - path args - mcwd menv - Nothing Nothing Nothing - when (exitCode /= ExitSuccess) $ - exitWith exitCode - -runProgramInvocation verbosity - ProgramInvocation { - progInvokePath = path, - progInvokeArgs = args, - progInvokeEnv = envOverrides, - progInvokePathEnv = extraPath, - progInvokeCwd = mcwd, - progInvokeInput = Just inputStr, - progInvokeInputEncoding = encoding - } = do - pathOverride <- getExtraPathEnv envOverrides extraPath - menv <- getEffectiveEnvironment (envOverrides ++ pathOverride) - (_, errors, exitCode) <- rawSystemStdInOut verbosity - path args - mcwd menv - (Just input) IODataModeBinary - when (exitCode /= ExitSuccess) $ - die' verbosity $ "'" ++ path ++ "' exited with an error:\n" ++ errors - where - input = encodeToIOData encoding inputStr - -getProgramInvocationOutput :: Verbosity -> ProgramInvocation -> IO String -getProgramInvocationOutput verbosity inv = do - (output, errors, exitCode) <- getProgramInvocationOutputAndErrors verbosity inv - when (exitCode /= ExitSuccess) $ - die' verbosity $ "'" ++ progInvokePath inv ++ "' exited with an error:\n" ++ errors - return output - -getProgramInvocationLBS :: Verbosity -> ProgramInvocation -> IO LBS.ByteString -getProgramInvocationLBS verbosity inv = do - (output, errors, exitCode) <- getProgramInvocationIODataAndErrors verbosity inv IODataModeBinary - when (exitCode /= ExitSuccess) $ - die' verbosity $ "'" ++ progInvokePath inv ++ "' exited with an error:\n" ++ errors - return output - -getProgramInvocationOutputAndErrors :: Verbosity -> ProgramInvocation - -> IO (String, String, ExitCode) -getProgramInvocationOutputAndErrors verbosity inv = case progInvokeOutputEncoding inv of - IOEncodingText -> do - (output, errors, exitCode) <- getProgramInvocationIODataAndErrors verbosity inv IODataModeText - return (output, errors, exitCode) - IOEncodingUTF8 -> do - (output', errors, exitCode) <- getProgramInvocationIODataAndErrors verbosity inv IODataModeBinary - return (normaliseLineEndings (fromUTF8LBS output'), errors, exitCode) - -getProgramInvocationIODataAndErrors - :: KnownIODataMode mode => Verbosity -> ProgramInvocation -> IODataMode mode - -> IO (mode, String, ExitCode) -getProgramInvocationIODataAndErrors - verbosity - ProgramInvocation - { progInvokePath = path - , progInvokeArgs = args - , progInvokeEnv = envOverrides - , progInvokePathEnv = extraPath - , progInvokeCwd = mcwd - , progInvokeInput = minputStr - , progInvokeInputEncoding = encoding - } - mode = do - pathOverride <- getExtraPathEnv envOverrides extraPath - menv <- getEffectiveEnvironment (envOverrides ++ pathOverride) - rawSystemStdInOut verbosity path args mcwd menv input mode - where - input = encodeToIOData encoding <$> minputStr - -getExtraPathEnv :: [(String, Maybe String)] -> [FilePath] -> IO [(String, Maybe String)] -getExtraPathEnv _ [] = return [] -getExtraPathEnv env extras = do - mb_path <- case lookup "PATH" env of - Just x -> return x - Nothing -> lookupEnv "PATH" - let extra = intercalate [searchPathSeparator] extras - path' = case mb_path of - Nothing -> extra - Just path -> extra ++ searchPathSeparator : path - return [("PATH", Just path')] - --- | Return the current environment extended with the given overrides. --- If an entry is specified twice in @overrides@, the second entry takes --- precedence. --- -getEffectiveEnvironment :: [(String, Maybe String)] - -> IO (Maybe [(String, String)]) -getEffectiveEnvironment [] = return Nothing -getEffectiveEnvironment overrides = - fmap (Just . Map.toList . apply overrides . Map.fromList) getEnvironment - where - apply os env = foldl' (flip update) env os - update (var, Nothing) = Map.delete var - update (var, Just val) = Map.insert var val - --- | Like the unix xargs program. Useful for when we've got very long command --- lines that might overflow an OS limit on command line length and so you --- need to invoke a command multiple times to get all the args in. --- --- It takes four template invocations corresponding to the simple, initial, --- middle and last invocations. If the number of args given is small enough --- that we can get away with just a single invocation then the simple one is --- used: --- --- > $ simple args --- --- If the number of args given means that we need to use multiple invocations --- then the templates for the initial, middle and last invocations are used: --- --- > $ initial args_0 --- > $ middle args_1 --- > $ middle args_2 --- > ... --- > $ final args_n --- -multiStageProgramInvocation - :: ProgramInvocation - -> (ProgramInvocation, ProgramInvocation, ProgramInvocation) - -> [String] - -> [ProgramInvocation] -multiStageProgramInvocation simple (initial, middle, final) args = - - let argSize inv = length (progInvokePath inv) - + foldl' (\s a -> length a + 1 + s) 1 (progInvokeArgs inv) - fixedArgSize = maximum (map argSize [simple, initial, middle, final]) - chunkSize = maxCommandLineSize - fixedArgSize - - in case splitChunks chunkSize args of - [] -> [ simple ] - - [c] -> [ simple `appendArgs` c ] - - (c:c2:cs) | (xs, x) <- unsnocNE (c2:|cs) -> - [ initial `appendArgs` c ] - ++ [ middle `appendArgs` c'| c' <- xs ] - ++ [ final `appendArgs` x ] - - where - appendArgs :: ProgramInvocation -> [String] -> ProgramInvocation - inv `appendArgs` as = inv { progInvokeArgs = progInvokeArgs inv ++ as } - - splitChunks :: Int -> [[a]] -> [[[a]]] - splitChunks len = unfoldr $ \s -> - if null s then Nothing - else Just (chunk len s) - - chunk :: Int -> [[a]] -> ([[a]], [[a]]) - chunk len (s:_) | length s >= len = error toolong - chunk len ss = chunk' [] len ss - - chunk' :: [[a]] -> Int -> [[a]] -> ([[a]], [[a]]) - chunk' acc len (s:ss) - | len' < len = chunk' (s:acc) (len-len'-1) ss - where len' = length s - chunk' acc _ ss = (reverse acc, ss) - - toolong = "multiStageProgramInvocation: a single program arg is larger " - ++ "than the maximum command line length!" - - ---FIXME: discover this at configure time or runtime on unix --- The value is 32k on Windows and posix specifies a minimum of 4k --- but all sensible unixes use more than 4k. --- we could use getSysVar ArgumentLimit but that's in the unix lib --- -maxCommandLineSize :: Int -maxCommandLineSize = 30 * 1024 diff --git a/cabal/Cabal/Distribution/Simple/Program/Script.hs b/cabal/Cabal/Distribution/Simple/Program/Script.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/Program/Script.hs +++ /dev/null @@ -1,114 +0,0 @@ -{-# LANGUAGE GADTs #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Program.Script --- Copyright : Duncan Coutts 2009 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This module provides an library interface to the @hc-pkg@ program. --- Currently only GHC and LHC have hc-pkg programs. - -module Distribution.Simple.Program.Script ( - - invocationAsSystemScript, - invocationAsShellScript, - invocationAsBatchFile, - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Simple.Program.Run -import Distribution.Simple.Utils -import Distribution.System - --- | Generate a system script, either POSIX shell script or Windows batch file --- as appropriate for the given system. --- -invocationAsSystemScript :: OS -> ProgramInvocation -> String -invocationAsSystemScript Windows = invocationAsBatchFile -invocationAsSystemScript _ = invocationAsShellScript - - --- | Generate a POSIX shell script that invokes a program. --- -invocationAsShellScript :: ProgramInvocation -> String -invocationAsShellScript - ProgramInvocation { - progInvokePath = path, - progInvokeArgs = args, - progInvokeEnv = envExtra, - progInvokeCwd = mcwd, - progInvokeInput = minput - } = unlines $ - [ "#!/bin/sh" ] - ++ concatMap setEnv envExtra - ++ [ "cd " ++ quote cwd | cwd <- maybeToList mcwd ] - ++ [ (case minput of - Nothing -> "" - Just input -> "echo " ++ quote (iodataToText input) ++ " | ") - ++ unwords (map quote $ path : args) ++ " \"$@\""] - - where - setEnv (var, Nothing) = ["unset " ++ var, "export " ++ var] - setEnv (var, Just val) = ["export " ++ var ++ "=" ++ quote val] - - quote :: String -> String - quote s = "'" ++ escape s ++ "'" - - escape [] = [] - escape ('\'':cs) = "'\\''" ++ escape cs - escape (c :cs) = c : escape cs - -iodataToText :: IOData -> String -iodataToText (IODataText str) = str -iodataToText (IODataBinary lbs) = fromUTF8LBS lbs - - --- | Generate a Windows batch file that invokes a program. --- -invocationAsBatchFile :: ProgramInvocation -> String -invocationAsBatchFile - ProgramInvocation { - progInvokePath = path, - progInvokeArgs = args, - progInvokeEnv = envExtra, - progInvokeCwd = mcwd, - progInvokeInput = minput - } = unlines $ - [ "@echo off" ] - ++ map setEnv envExtra - ++ [ "cd \"" ++ cwd ++ "\"" | cwd <- maybeToList mcwd ] - ++ case minput of - Nothing -> - [ path ++ concatMap (' ':) args ] - - Just input -> - [ "(" ] - ++ [ "echo " ++ escape line | line <- lines $ iodataToText input ] - ++ [ ") | " - ++ "\"" ++ path ++ "\"" - ++ concatMap (\arg -> ' ':quote arg) args ] - - where - setEnv (var, Nothing) = "set " ++ var ++ "=" - setEnv (var, Just val) = "set " ++ var ++ "=" ++ escape val - - quote :: String -> String - quote s = "\"" ++ escapeQ s ++ "\"" - - escapeQ [] = [] - escapeQ ('"':cs) = "\"\"\"" ++ escapeQ cs - escapeQ (c :cs) = c : escapeQ cs - - escape [] = [] - escape ('|':cs) = "^|" ++ escape cs - escape ('<':cs) = "^<" ++ escape cs - escape ('>':cs) = "^>" ++ escape cs - escape ('&':cs) = "^&" ++ escape cs - escape ('(':cs) = "^(" ++ escape cs - escape (')':cs) = "^)" ++ escape cs - escape ('^':cs) = "^^" ++ escape cs - escape (c :cs) = c : escape cs diff --git a/cabal/Cabal/Distribution/Simple/Program/Strip.hs b/cabal/Cabal/Distribution/Simple/Program/Strip.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/Program/Strip.hs +++ /dev/null @@ -1,75 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Program.Strip --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This module provides an library interface to the @strip@ program. - -module Distribution.Simple.Program.Strip (stripLib, stripExe) - where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Simple.Program -import Distribution.Simple.Utils -import Distribution.System -import Distribution.Verbosity -import Distribution.Version - -import System.FilePath (takeBaseName) - -runStrip :: Verbosity -> ProgramDb -> FilePath -> [String] -> IO () -runStrip verbosity progDb path args = - case lookupProgram stripProgram progDb of - Just strip -> runProgram verbosity strip (args ++ [path]) - Nothing -> unless (buildOS == Windows) $ - -- Don't bother warning on windows, we don't expect them to - -- have the strip program anyway. - warn verbosity $ "Unable to strip executable or library '" - ++ (takeBaseName path) - ++ "' (missing the 'strip' program)" - -stripExe :: Verbosity -> Platform -> ProgramDb -> FilePath -> IO () -stripExe verbosity (Platform _arch os) progdb path = - runStrip verbosity progdb path args - where - args = case os of - OSX -> ["-x"] -- By default, stripping the ghc binary on at least - -- some OS X installations causes: - -- HSbase-3.0.o: unknown symbol `_environ'" - -- The -x flag fixes that. - _ -> [] - -stripLib :: Verbosity -> Platform -> ProgramDb -> FilePath -> IO () -stripLib verbosity (Platform arch os) progdb path = do - case os of - OSX -> -- '--strip-unneeded' is not supported on OS X, iOS, AIX, or - -- Solaris. See #1630. - return () - IOS -> return () - AIX -> return () - Solaris -> return () - Windows -> -- Stripping triggers a bug in 'strip.exe' for - -- libraries with lots identically named modules. See - -- #1784. - return() - Linux | arch == I386 -> - -- Versions of 'strip' on 32-bit Linux older than 2.18 are - -- broken. See #2339. - let okVersion = orLaterVersion (mkVersion [2,18]) - in case programVersion =<< lookupProgram stripProgram progdb of - Just v | withinRange v okVersion -> - runStrip verbosity progdb path args - _ -> warn verbosity $ "Unable to strip library '" - ++ (takeBaseName path) - ++ "' (version of 'strip' too old; " - ++ "requires >= 2.18 on 32-bit Linux)" - _ -> runStrip verbosity progdb path args - where - args = ["--strip-unneeded"] diff --git a/cabal/Cabal/Distribution/Simple/Program/Types.hs b/cabal/Cabal/Distribution/Simple/Program/Types.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/Program/Types.hs +++ /dev/null @@ -1,190 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE DeriveDataTypeable #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Program.Types --- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This provides an abstraction which deals with configuring and running --- programs. A 'Program' is a static notion of a known program. A --- 'ConfiguredProgram' is a 'Program' that has been found on the current --- machine and is ready to be run (possibly with some user-supplied default --- args). Configuring a program involves finding its location and if necessary --- finding its version. There's reasonable default behavior for trying to find --- \"foo\" in PATH, being able to override its location, etc. --- -module Distribution.Simple.Program.Types ( - -- * Program and functions for constructing them - Program(..), - ProgramSearchPath, - ProgramSearchPathEntry(..), - simpleProgram, - - -- * Configured program and related functions - ConfiguredProgram(..), - programPath, - suppressOverrideArgs, - ProgArg, - ProgramLocation(..), - simpleConfiguredProgram, - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.PackageDescription -import Distribution.Simple.Program.Find -import Distribution.Version -import Distribution.Verbosity - -import qualified Data.Map as Map - --- | Represents a program which can be configured. --- --- Note: rather than constructing this directly, start with 'simpleProgram' and --- override any extra fields. --- -data Program = Program { - -- | The simple name of the program, eg. ghc - programName :: String, - - -- | A function to search for the program if its location was not - -- specified by the user. Usually this will just be a call to - -- 'findProgramOnSearchPath'. - -- - -- It is supplied with the prevailing search path which will typically - -- just be used as-is, but can be extended or ignored as needed. - -- - -- For the purpose of change monitoring, in addition to the location - -- where the program was found, it returns all the other places that - -- were tried. - -- - programFindLocation :: Verbosity -> ProgramSearchPath - -> IO (Maybe (FilePath, [FilePath])), - - -- | Try to find the version of the program. For many programs this is - -- not possible or is not necessary so it's OK to return Nothing. - programFindVersion :: Verbosity -> FilePath -> IO (Maybe Version), - - -- | A function to do any additional configuration after we have - -- located the program (and perhaps identified its version). For example - -- it could add args, or environment vars. - programPostConf :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram, - -- | A function that filters any arguments that don't impact the output - -- from a commandline. Used to limit the volatility of dependency hashes - -- when using new-build. - programNormaliseArgs :: Maybe Version -> PackageDescription -> [String] -> [String] - } -instance Show Program where - show (Program name _ _ _ _) = "Program: " ++ name - -type ProgArg = String - --- | Represents a program which has been configured and is thus ready to be run. --- --- These are usually made by configuring a 'Program', but if you have to --- construct one directly then start with 'simpleConfiguredProgram' and --- override any extra fields. --- -data ConfiguredProgram = ConfiguredProgram { - -- | Just the name again - programId :: String, - - -- | The version of this program, if it is known. - programVersion :: Maybe Version, - - -- | Default command-line args for this program. - -- These flags will appear first on the command line, so they can be - -- overridden by subsequent flags. - programDefaultArgs :: [String], - - -- | Override command-line args for this program. - -- These flags will appear last on the command line, so they override - -- all earlier flags. - programOverrideArgs :: [String], - - -- | Override environment variables for this program. - -- These env vars will extend\/override the prevailing environment of - -- the current to form the environment for the new process. - programOverrideEnv :: [(String, Maybe String)], - - -- | A key-value map listing various properties of the program, useful - -- for feature detection. Populated during the configuration step, key - -- names depend on the specific program. - programProperties :: Map.Map String String, - - -- | Location of the program. eg. @\/usr\/bin\/ghc-6.4@ - programLocation :: ProgramLocation, - - -- | In addition to the 'programLocation' where the program was found, - -- these are additional locations that were looked at. The combination - -- of ths found location and these not-found locations can be used to - -- monitor to detect when the re-configuring the program might give a - -- different result (e.g. found in a different location). - -- - programMonitorFiles :: [FilePath] - } - deriving (Eq, Generic, Read, Show, Typeable) - -instance Binary ConfiguredProgram -instance Structured ConfiguredProgram - --- | Where a program was found. Also tells us whether it's specified by user or --- not. This includes not just the path, but the program as well. -data ProgramLocation - = UserSpecified { locationPath :: FilePath } - -- ^The user gave the path to this program, - -- eg. --ghc-path=\/usr\/bin\/ghc-6.6 - | FoundOnSystem { locationPath :: FilePath } - -- ^The program was found automatically. - deriving (Eq, Generic, Read, Show, Typeable) - -instance Binary ProgramLocation -instance Structured ProgramLocation - --- | The full path of a configured program. -programPath :: ConfiguredProgram -> FilePath -programPath = locationPath . programLocation - --- | Suppress any extra arguments added by the user. -suppressOverrideArgs :: ConfiguredProgram -> ConfiguredProgram -suppressOverrideArgs prog = prog { programOverrideArgs = [] } - --- | Make a simple named program. --- --- By default we'll just search for it in the path and not try to find the --- version name. You can override these behaviours if necessary, eg: --- --- > (simpleProgram "foo") { programFindLocation = ... , programFindVersion ... } --- -simpleProgram :: String -> Program -simpleProgram name = Program { - programName = name, - programFindLocation = \v p -> findProgramOnSearchPath v p name, - programFindVersion = \_ _ -> return Nothing, - programPostConf = \_ p -> return p, - programNormaliseArgs = \_ _ -> id - } - --- | Make a simple 'ConfiguredProgram'. --- --- > simpleConfiguredProgram "foo" (FoundOnSystem path) --- -simpleConfiguredProgram :: String -> ProgramLocation -> ConfiguredProgram -simpleConfiguredProgram name loc = ConfiguredProgram { - programId = name, - programVersion = Nothing, - programDefaultArgs = [], - programOverrideArgs = [], - programOverrideEnv = [], - programProperties = Map.empty, - programLocation = loc, - programMonitorFiles = [] -- did not look in any other locations - } diff --git a/cabal/Cabal/Distribution/Simple/Register.hs b/cabal/Cabal/Distribution/Simple/Register.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/Register.hs +++ /dev/null @@ -1,595 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Register --- Copyright : Isaac Jones 2003-2004 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This module deals with registering and unregistering packages. There are a --- couple ways it can do this, one is to do it directly. Another is to generate --- a script that can be run later to do it. The idea here being that the user --- is shielded from the details of what command to use for package registration --- for a particular compiler. In practice this aspect was not especially --- popular so we also provide a way to simply generate the package registration --- file which then must be manually passed to @ghc-pkg@. It is possible to --- generate registration information for where the package is to be installed, --- or alternatively to register the package in place in the build tree. The --- latter is occasionally handy, and will become more important when we try to --- build multi-package systems. --- --- This module does not delegate anything to the per-compiler modules but just --- mixes it all in this module, which is rather unsatisfactory. The script --- generation and the unregister feature are not well used or tested. - -module Distribution.Simple.Register ( - register, - unregister, - - internalPackageDBPath, - - initPackageDB, - doesPackageDBExist, - createPackageDB, - deletePackageDB, - - abiHash, - invokeHcPkg, - registerPackage, - HcPkg.RegisterOptions(..), - HcPkg.defaultRegisterOptions, - generateRegistrationInfo, - inplaceInstalledPackageInfo, - absoluteInstalledPackageInfo, - generalInstalledPackageInfo, - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Types.TargetInfo -import Distribution.Types.LocalBuildInfo -import Distribution.Types.ComponentLocalBuildInfo - -import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.BuildPaths -import Distribution.Simple.BuildTarget - -import qualified Distribution.Simple.GHC as GHC -import qualified Distribution.Simple.GHCJS as GHCJS -import qualified Distribution.Simple.UHC as UHC -import qualified Distribution.Simple.HaskellSuite as HaskellSuite -import qualified Distribution.Simple.PackageIndex as Index - -import Distribution.Backpack.DescribeUnitId -import Distribution.Simple.Compiler -import Distribution.Simple.Program -import Distribution.Simple.Program.Script -import qualified Distribution.Simple.Program.HcPkg as HcPkg -import Distribution.Simple.Setup -import Distribution.PackageDescription -import Distribution.Package -import Distribution.License (licenseToSPDX, licenseFromSPDX) -import qualified Distribution.InstalledPackageInfo as IPI -import Distribution.InstalledPackageInfo (InstalledPackageInfo) -import Distribution.Simple.Utils -import Distribution.Utils.MapAccum -import Distribution.System -import Distribution.Pretty -import Distribution.Verbosity as Verbosity -import Distribution.Version -import Distribution.Compat.Graph (IsNode(nodeKey)) - -import System.FilePath ((), (<.>), isAbsolute) -import System.Directory - -import qualified Data.ByteString.Lazy.Char8 as BS.Char8 - --- ----------------------------------------------------------------------------- --- Registration - -register :: PackageDescription -> LocalBuildInfo - -> RegisterFlags -- ^Install in the user's database?; verbose - -> IO () -register pkg_descr lbi0 flags = - -- Duncan originally asked for us to not register/install files - -- when there was no public library. But with per-component - -- configure, we legitimately need to install internal libraries - -- so that we can get them. So just unconditionally install. - doRegister - where - doRegister = do - targets <- readTargetInfos verbosity pkg_descr lbi0 (regArgs flags) - - -- It's important to register in build order, because ghc-pkg - -- will complain if a dependency is not registered. - let componentsToRegister - = neededTargetsInBuildOrder' pkg_descr lbi0 (map nodeKey targets) - - (_, ipi_mbs) <- - mapAccumM `flip` installedPkgs lbi0 `flip` componentsToRegister $ \index tgt -> - case targetComponent tgt of - CLib lib -> do - let clbi = targetCLBI tgt - lbi = lbi0 { installedPkgs = index } - ipi <- generateOne pkg_descr lib lbi clbi flags - return (Index.insert ipi index, Just ipi) - _ -> return (index, Nothing) - - registerAll pkg_descr lbi0 flags (catMaybes ipi_mbs) - where - verbosity = fromFlag (regVerbosity flags) - -generateOne :: PackageDescription -> Library -> LocalBuildInfo -> ComponentLocalBuildInfo - -> RegisterFlags - -> IO InstalledPackageInfo -generateOne pkg lib lbi clbi regFlags - = do - absPackageDBs <- absolutePackageDBPaths packageDbs - installedPkgInfo <- generateRegistrationInfo - verbosity pkg lib lbi clbi inplace reloc distPref - (registrationPackageDB absPackageDBs) - info verbosity (IPI.showInstalledPackageInfo installedPkgInfo) - return installedPkgInfo - where - inplace = fromFlag (regInPlace regFlags) - reloc = relocatable lbi - -- FIXME: there's really no guarantee this will work. - -- registering into a totally different db stack can - -- fail if dependencies cannot be satisfied. - packageDbs = nub $ withPackageDB lbi - ++ maybeToList (flagToMaybe (regPackageDB regFlags)) - distPref = fromFlag (regDistPref regFlags) - verbosity = fromFlag (regVerbosity regFlags) - -registerAll :: PackageDescription -> LocalBuildInfo -> RegisterFlags - -> [InstalledPackageInfo] - -> IO () -registerAll pkg lbi regFlags ipis - = do - when (fromFlag (regPrintId regFlags)) $ do - for_ ipis $ \installedPkgInfo -> - -- Only print the public library's IPI - when (packageId installedPkgInfo == packageId pkg - && IPI.sourceLibName installedPkgInfo == LMainLibName) $ - putStrLn (prettyShow (IPI.installedUnitId installedPkgInfo)) - - -- Three different modes: - case () of - _ | modeGenerateRegFile -> writeRegistrationFileOrDirectory - | modeGenerateRegScript -> writeRegisterScript - | otherwise -> do - for_ ipis $ \ipi -> do - setupMessage' verbosity "Registering" (packageId pkg) - (CLibName (IPI.sourceLibName ipi)) - (Just (IPI.instantiatedWith ipi)) - registerPackage verbosity (compiler lbi) (withPrograms lbi) - packageDbs ipi HcPkg.defaultRegisterOptions - - where - modeGenerateRegFile = isJust (flagToMaybe (regGenPkgConf regFlags)) - regFile = fromMaybe (prettyShow (packageId pkg) <.> "conf") - (fromFlag (regGenPkgConf regFlags)) - - modeGenerateRegScript = fromFlag (regGenScript regFlags) - - -- FIXME: there's really no guarantee this will work. - -- registering into a totally different db stack can - -- fail if dependencies cannot be satisfied. - packageDbs = nub $ withPackageDB lbi - ++ maybeToList (flagToMaybe (regPackageDB regFlags)) - verbosity = fromFlag (regVerbosity regFlags) - - writeRegistrationFileOrDirectory = do - -- Handles overwriting both directory and file - deletePackageDB regFile - case ipis of - [installedPkgInfo] -> do - info verbosity ("Creating package registration file: " ++ regFile) - writeUTF8File regFile (IPI.showInstalledPackageInfo installedPkgInfo) - _ -> do - info verbosity ("Creating package registration directory: " ++ regFile) - createDirectory regFile - let num_ipis = length ipis - lpad m xs = replicate (m - length ys) '0' ++ ys - where ys = take m xs - number i = lpad (length (show num_ipis)) (show i) - for_ (zip ([1..] :: [Int]) ipis) $ \(i, installedPkgInfo) -> - writeUTF8File (regFile (number i ++ "-" ++ prettyShow (IPI.installedUnitId installedPkgInfo))) - (IPI.showInstalledPackageInfo installedPkgInfo) - - writeRegisterScript = - case compilerFlavor (compiler lbi) of - UHC -> notice verbosity "Registration scripts not needed for uhc" - _ -> withHcPkg verbosity - "Registration scripts are not implemented for this compiler" - (compiler lbi) (withPrograms lbi) - (writeHcPkgRegisterScript verbosity ipis packageDbs) - - -generateRegistrationInfo :: Verbosity - -> PackageDescription - -> Library - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> Bool - -> Bool - -> FilePath - -> PackageDB - -> IO InstalledPackageInfo -generateRegistrationInfo verbosity pkg lib lbi clbi inplace reloc distPref packageDb = do - --TODO: eliminate pwd! - pwd <- getCurrentDirectory - - installedPkgInfo <- - if inplace - -- NB: With an inplace installation, the user may run './Setup - -- build' to update the library files, without reregistering. - -- In this case, it is critical that the ABI hash not flip. - then return (inplaceInstalledPackageInfo pwd distPref - pkg (mkAbiHash "inplace") lib lbi clbi) - else do - abi_hash <- abiHash verbosity pkg distPref lbi lib clbi - if reloc - then relocRegistrationInfo verbosity - pkg lib lbi clbi abi_hash packageDb - else return (absoluteInstalledPackageInfo - pkg abi_hash lib lbi clbi) - - - return installedPkgInfo - --- | Compute the 'AbiHash' of a library that we built inplace. -abiHash :: Verbosity - -> PackageDescription - -> FilePath - -> LocalBuildInfo - -> Library - -> ComponentLocalBuildInfo - -> IO AbiHash -abiHash verbosity pkg distPref lbi lib clbi = - case compilerFlavor comp of - GHC -> do - fmap mkAbiHash $ GHC.libAbiHash verbosity pkg lbi' lib clbi - GHCJS -> do - fmap mkAbiHash $ GHCJS.libAbiHash verbosity pkg lbi' lib clbi - _ -> return (mkAbiHash "") - where - comp = compiler lbi - lbi' = lbi { - withPackageDB = withPackageDB lbi - ++ [SpecificPackageDB (internalPackageDBPath lbi distPref)] - } - -relocRegistrationInfo :: Verbosity - -> PackageDescription - -> Library - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> AbiHash - -> PackageDB - -> IO InstalledPackageInfo -relocRegistrationInfo verbosity pkg lib lbi clbi abi_hash packageDb = - case (compilerFlavor (compiler lbi)) of - GHC -> do fs <- GHC.pkgRoot verbosity lbi packageDb - return (relocatableInstalledPackageInfo - pkg abi_hash lib lbi clbi fs) - _ -> die' verbosity - "Distribution.Simple.Register.relocRegistrationInfo: \ - \not implemented for this compiler" - -initPackageDB :: Verbosity -> Compiler -> ProgramDb -> FilePath -> IO () -initPackageDB verbosity comp progdb dbPath = - createPackageDB verbosity comp progdb False dbPath - --- | Create an empty package DB at the specified location. -createPackageDB :: Verbosity -> Compiler -> ProgramDb -> Bool - -> FilePath -> IO () -createPackageDB verbosity comp progdb preferCompat dbPath = - case compilerFlavor comp of - GHC -> HcPkg.init (GHC.hcPkgInfo progdb) verbosity preferCompat dbPath - GHCJS -> HcPkg.init (GHCJS.hcPkgInfo progdb) verbosity False dbPath - UHC -> return () - HaskellSuite _ -> HaskellSuite.initPackageDB verbosity progdb dbPath - _ -> die' verbosity $ - "Distribution.Simple.Register.createPackageDB: " - ++ "not implemented for this compiler" - -doesPackageDBExist :: FilePath -> IO Bool -doesPackageDBExist dbPath = do - -- currently one impl for all compiler flavours, but could change if needed - dir_exists <- doesDirectoryExist dbPath - if dir_exists - then return True - else doesFileExist dbPath - -deletePackageDB :: FilePath -> IO () -deletePackageDB dbPath = do - -- currently one impl for all compiler flavours, but could change if needed - dir_exists <- doesDirectoryExist dbPath - if dir_exists - then removeDirectoryRecursive dbPath - else do file_exists <- doesFileExist dbPath - when file_exists $ removeFile dbPath - --- | Run @hc-pkg@ using a given package DB stack, directly forwarding the --- provided command-line arguments to it. -invokeHcPkg :: Verbosity -> Compiler -> ProgramDb -> PackageDBStack - -> [String] -> IO () -invokeHcPkg verbosity comp progdb dbStack extraArgs = - withHcPkg verbosity "invokeHcPkg" comp progdb - (\hpi -> HcPkg.invoke hpi verbosity dbStack extraArgs) - -withHcPkg :: Verbosity -> String -> Compiler -> ProgramDb - -> (HcPkg.HcPkgInfo -> IO a) -> IO a -withHcPkg verbosity name comp progdb f = - case compilerFlavor comp of - GHC -> f (GHC.hcPkgInfo progdb) - GHCJS -> f (GHCJS.hcPkgInfo progdb) - _ -> die' verbosity ("Distribution.Simple.Register." ++ name ++ ":\ - \not implemented for this compiler") - -registerPackage :: Verbosity - -> Compiler - -> ProgramDb - -> PackageDBStack - -> InstalledPackageInfo - -> HcPkg.RegisterOptions - -> IO () -registerPackage verbosity comp progdb packageDbs installedPkgInfo registerOptions = - case compilerFlavor comp of - GHC -> GHC.registerPackage verbosity progdb packageDbs installedPkgInfo registerOptions - GHCJS -> GHCJS.registerPackage verbosity progdb packageDbs installedPkgInfo registerOptions - HaskellSuite {} -> - HaskellSuite.registerPackage verbosity progdb packageDbs installedPkgInfo - _ | HcPkg.registerMultiInstance registerOptions - -> die' verbosity "Registering multiple package instances is not yet supported for this compiler" - UHC -> UHC.registerPackage verbosity comp progdb packageDbs installedPkgInfo - _ -> die' verbosity "Registering is not implemented for this compiler" - -writeHcPkgRegisterScript :: Verbosity - -> [InstalledPackageInfo] - -> PackageDBStack - -> HcPkg.HcPkgInfo - -> IO () -writeHcPkgRegisterScript verbosity ipis packageDbs hpi = do - let genScript installedPkgInfo = - let invocation = HcPkg.registerInvocation hpi Verbosity.normal - packageDbs installedPkgInfo - HcPkg.defaultRegisterOptions - in invocationAsSystemScript buildOS invocation - scripts = map genScript ipis - -- TODO: Do something more robust here - regScript = unlines scripts - - info verbosity ("Creating package registration script: " ++ regScriptFileName) - writeUTF8File regScriptFileName regScript - setFileExecutable regScriptFileName - -regScriptFileName :: FilePath -regScriptFileName = case buildOS of - Windows -> "register.bat" - _ -> "register.sh" - - --- ----------------------------------------------------------------------------- --- Making the InstalledPackageInfo - --- | Construct 'InstalledPackageInfo' for a library in a package, given a set --- of installation directories. --- -generalInstalledPackageInfo - :: ([FilePath] -> [FilePath]) -- ^ Translate relative include dir paths to - -- absolute paths. - -> PackageDescription - -> AbiHash - -> Library - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> InstallDirs FilePath - -> InstalledPackageInfo -generalInstalledPackageInfo adjustRelIncDirs pkg abi_hash lib lbi clbi installDirs = - IPI.InstalledPackageInfo { - IPI.sourcePackageId = packageId pkg, - IPI.installedUnitId = componentUnitId clbi, - IPI.installedComponentId_ = componentComponentId clbi, - IPI.instantiatedWith = componentInstantiatedWith clbi, - IPI.sourceLibName = libName lib, - IPI.compatPackageKey = componentCompatPackageKey clbi, - -- If GHC >= 8.4 we register with SDPX, otherwise with legacy license - IPI.license = - if ghc84 - then Left $ either id licenseToSPDX $ licenseRaw pkg - else Right $ either licenseFromSPDX id $ licenseRaw pkg, - IPI.copyright = copyright pkg, - IPI.maintainer = maintainer pkg, - IPI.author = author pkg, - IPI.stability = stability pkg, - IPI.homepage = homepage pkg, - IPI.pkgUrl = pkgUrl pkg, - IPI.synopsis = synopsis pkg, - IPI.description = description pkg, - IPI.category = category pkg, - IPI.abiHash = abi_hash, - IPI.indefinite = componentIsIndefinite clbi, - IPI.exposed = libExposed lib, - IPI.exposedModules = componentExposedModules clbi - -- add virtual modules into the list of exposed modules for the - -- package database as well. - ++ map (\name -> IPI.ExposedModule name Nothing) (virtualModules bi), - IPI.hiddenModules = otherModules bi, - IPI.trusted = IPI.trusted IPI.emptyInstalledPackageInfo, - IPI.importDirs = [ libdir installDirs | hasModules ], - IPI.libraryDirs = libdirs, - IPI.libraryDynDirs = dynlibdirs, - IPI.dataDir = datadir installDirs, - IPI.hsLibraries = (if hasLibrary - then [getHSLibraryName (componentUnitId clbi)] - else []) ++ extraBundledLibs bi, - IPI.extraLibraries = extraLibs bi, - IPI.extraGHCiLibraries = extraGHCiLibs bi, - IPI.includeDirs = absinc ++ adjustRelIncDirs relinc, - IPI.includes = includes bi, - IPI.depends = depends, - IPI.abiDepends = [], -- due to #5465 - IPI.ccOptions = [], -- Note. NOT ccOptions bi! - -- We don't want cc-options to be propagated - -- to C compilations in other packages. - IPI.cxxOptions = [], -- Also. NOT cxxOptions bi! - IPI.ldOptions = ldOptions bi, - IPI.frameworks = frameworks bi, - IPI.frameworkDirs = extraFrameworkDirs bi, - IPI.haddockInterfaces = [haddockdir installDirs haddockName pkg], - IPI.haddockHTMLs = [htmldir installDirs], - IPI.pkgRoot = Nothing, - IPI.libVisibility = libVisibility lib - } - where - ghc84 = case compilerId $ compiler lbi of - CompilerId GHC v -> v >= mkVersion [8, 4] - _ -> False - - bi = libBuildInfo lib - --TODO: unclear what the root cause of the - -- duplication is, but we nub it here for now: - depends = ordNub $ map fst (componentPackageDeps clbi) - (absinc, relinc) = partition isAbsolute (includeDirs bi) - hasModules = not $ null (allLibModules lib clbi) - comp = compiler lbi - hasLibrary = (hasModules || not (null (cSources bi)) - || not (null (asmSources bi)) - || not (null (cmmSources bi)) - || not (null (cxxSources bi)) - || (not (null (jsSources bi)) && - compilerFlavor comp == GHCJS)) - && not (componentIsIndefinite clbi) - (libdirs, dynlibdirs) - | not hasLibrary - = (extraLibDirs bi, []) - -- the dynamic-library-dirs defaults to the library-dirs if not specified, - -- so this works whether the dynamic-library-dirs field is supported or not - - | libraryDynDirSupported comp - = (libdir installDirs : extraLibDirs bi, - dynlibdir installDirs : extraLibDirs bi) - - | otherwise - = (libdir installDirs : dynlibdir installDirs : extraLibDirs bi, []) - -- the compiler doesn't understand the dynamic-library-dirs field so we - -- add the dyn directory to the "normal" list in the library-dirs field - --- | Construct 'InstalledPackageInfo' for a library that is in place in the --- build tree. --- --- This function knows about the layout of in place packages. --- -inplaceInstalledPackageInfo :: FilePath -- ^ top of the build tree - -> FilePath -- ^ location of the dist tree - -> PackageDescription - -> AbiHash - -> Library - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> InstalledPackageInfo -inplaceInstalledPackageInfo inplaceDir distPref pkg abi_hash lib lbi clbi = - generalInstalledPackageInfo adjustRelativeIncludeDirs - pkg abi_hash lib lbi clbi installDirs - where - adjustRelativeIncludeDirs = concatMap $ \d -> - [ inplaceDir d -- local include-dir - , inplaceDir libTargetDir d -- autogen include-dir - ] - libTargetDir = componentBuildDir lbi clbi - installDirs = - (absoluteComponentInstallDirs pkg lbi (componentUnitId clbi) NoCopyDest) { - libdir = inplaceDir libTargetDir, - dynlibdir = inplaceDir libTargetDir, - datadir = inplaceDir dataDir pkg, - docdir = inplaceDocdir, - htmldir = inplaceHtmldir, - haddockdir = inplaceHtmldir - } - inplaceDocdir = inplaceDir distPref "doc" - inplaceHtmldir = inplaceDocdir "html" prettyShow (packageName pkg) - - --- | Construct 'InstalledPackageInfo' for the final install location of a --- library package. --- --- This function knows about the layout of installed packages. --- -absoluteInstalledPackageInfo :: PackageDescription - -> AbiHash - -> Library - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> InstalledPackageInfo -absoluteInstalledPackageInfo pkg abi_hash lib lbi clbi = - generalInstalledPackageInfo adjustReativeIncludeDirs - pkg abi_hash lib lbi clbi installDirs - where - -- For installed packages we install all include files into one dir, - -- whereas in the build tree they may live in multiple local dirs. - adjustReativeIncludeDirs _ - | null (installIncludes bi) = [] - | otherwise = [includedir installDirs] - bi = libBuildInfo lib - installDirs = absoluteComponentInstallDirs pkg lbi (componentUnitId clbi) NoCopyDest - - -relocatableInstalledPackageInfo :: PackageDescription - -> AbiHash - -> Library - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> FilePath - -> InstalledPackageInfo -relocatableInstalledPackageInfo pkg abi_hash lib lbi clbi pkgroot = - generalInstalledPackageInfo adjustReativeIncludeDirs - pkg abi_hash lib lbi clbi installDirs - where - -- For installed packages we install all include files into one dir, - -- whereas in the build tree they may live in multiple local dirs. - adjustReativeIncludeDirs _ - | null (installIncludes bi) = [] - | otherwise = [includedir installDirs] - bi = libBuildInfo lib - - installDirs = fmap (("${pkgroot}" ) . shortRelativePath pkgroot) - $ absoluteComponentInstallDirs pkg lbi (componentUnitId clbi) NoCopyDest - --- ----------------------------------------------------------------------------- --- Unregistration - -unregister :: PackageDescription -> LocalBuildInfo -> RegisterFlags -> IO () -unregister pkg lbi regFlags = do - let pkgid = packageId pkg - genScript = fromFlag (regGenScript regFlags) - verbosity = fromFlag (regVerbosity regFlags) - packageDb = fromFlagOrDefault (registrationPackageDB (withPackageDB lbi)) - (regPackageDB regFlags) - unreg hpi = - let invocation = HcPkg.unregisterInvocation - hpi Verbosity.normal packageDb pkgid - in if genScript - then writeFileAtomic unregScriptFileName - (BS.Char8.pack $ invocationAsSystemScript buildOS invocation) - else runProgramInvocation verbosity invocation - setupMessage verbosity "Unregistering" pkgid - withHcPkg verbosity "unregistering is only implemented for GHC and GHCJS" - (compiler lbi) (withPrograms lbi) unreg - -unregScriptFileName :: FilePath -unregScriptFileName = case buildOS of - Windows -> "unregister.bat" - _ -> "unregister.sh" - -internalPackageDBPath :: LocalBuildInfo -> FilePath -> FilePath -internalPackageDBPath lbi distPref = - case compilerFlavor (compiler lbi) of - UHC -> UHC.inplacePackageDbPath lbi - _ -> distPref "package.conf.inplace" diff --git a/cabal/Cabal/Distribution/Simple/Setup.hs b/cabal/Cabal/Distribution/Simple/Setup.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/Setup.hs +++ /dev/null @@ -1,2412 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE NoMonoLocalBinds #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Setup --- Copyright : Isaac Jones 2003-2004 --- Duncan Coutts 2007 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This is a big module, but not very complicated. The code is very regular --- and repetitive. It defines the command line interface for all the Cabal --- commands. For each command (like @configure@, @build@ etc) it defines a type --- that holds all the flags, the default set of flags and a 'CommandUI' that --- maps command line flags to and from the corresponding flags type. --- --- All the flags types are instances of 'Monoid', see --- --- for an explanation. --- --- The types defined here get used in the front end and especially in --- @cabal-install@ which has to do quite a bit of manipulating sets of command --- line flags. --- --- This is actually relatively nice, it works quite well. The main change it --- needs is to unify it with the code for managing sets of fields that can be --- read and written from files. This would allow us to save configure flags in --- config files. - -module Distribution.Simple.Setup ( - - GlobalFlags(..), emptyGlobalFlags, defaultGlobalFlags, globalCommand, - ConfigFlags(..), emptyConfigFlags, defaultConfigFlags, configureCommand, - configPrograms, - configAbsolutePaths, readPackageDbList, showPackageDbList, - CopyFlags(..), emptyCopyFlags, defaultCopyFlags, copyCommand, - InstallFlags(..), emptyInstallFlags, defaultInstallFlags, installCommand, - DoctestFlags(..), emptyDoctestFlags, defaultDoctestFlags, doctestCommand, - HaddockTarget(..), - HaddockFlags(..), emptyHaddockFlags, defaultHaddockFlags, haddockCommand, - HscolourFlags(..), emptyHscolourFlags, defaultHscolourFlags, hscolourCommand, - BuildFlags(..), emptyBuildFlags, defaultBuildFlags, buildCommand, - ShowBuildInfoFlags(..), defaultShowBuildFlags, showBuildInfoCommand, - ReplFlags(..), defaultReplFlags, replCommand, - CleanFlags(..), emptyCleanFlags, defaultCleanFlags, cleanCommand, - RegisterFlags(..), emptyRegisterFlags, defaultRegisterFlags, registerCommand, - unregisterCommand, - SDistFlags(..), emptySDistFlags, defaultSDistFlags, sdistCommand, - TestFlags(..), emptyTestFlags, defaultTestFlags, testCommand, - TestShowDetails(..), - BenchmarkFlags(..), emptyBenchmarkFlags, - defaultBenchmarkFlags, benchmarkCommand, - CopyDest(..), - configureArgs, configureOptions, configureCCompiler, configureLinker, - buildOptions, haddockOptions, installDirsOptions, - testOptions', benchmarkOptions', - programDbOptions, programDbPaths', - programFlagsDescription, - replOptions, - splitArgs, - - defaultDistPref, optionDistPref, - - Flag(..), - toFlag, - fromFlag, - fromFlagOrDefault, - flagToMaybe, - flagToList, - maybeToFlag, - BooleanFlag(..), - boolOpt, boolOpt', trueArg, falseArg, - optionVerbosity, optionNumJobs) where - -import Prelude () -import Distribution.Compat.Prelude hiding (get) - -import Distribution.Compiler -import Distribution.ReadE -import Distribution.Parsec -import Distribution.Pretty -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp -import Distribution.ModuleName -import Distribution.PackageDescription -import Distribution.Simple.Command hiding (boolOpt, boolOpt') -import qualified Distribution.Simple.Command as Command -import Distribution.Simple.Compiler -import Distribution.Simple.Flag -import Distribution.Simple.Utils -import Distribution.Simple.Program -import Distribution.Simple.InstallDirs -import Distribution.Verbosity -import Distribution.Utils.NubList -import Distribution.Types.ComponentId -import Distribution.Types.GivenComponent -import Distribution.Types.Module -import Distribution.Types.PackageVersionConstraint - -import Distribution.Compat.Stack -import Distribution.Compat.Semigroup (Last' (..), Option' (..)) - --- FIXME Not sure where this should live -defaultDistPref :: FilePath -defaultDistPref = "dist" - --- ------------------------------------------------------------ --- * Global flags --- ------------------------------------------------------------ - --- In fact since individual flags types are monoids and these are just sets of --- flags then they are also monoids pointwise. This turns out to be really --- useful. The mempty is the set of empty flags and mappend allows us to --- override specific flags. For example we can start with default flags and --- override with the ones we get from a file or the command line, or both. - --- | Flags that apply at the top level, not to any sub-command. -data GlobalFlags = GlobalFlags { - globalVersion :: Flag Bool, - globalNumericVersion :: Flag Bool - } deriving (Generic, Typeable) - -defaultGlobalFlags :: GlobalFlags -defaultGlobalFlags = GlobalFlags { - globalVersion = Flag False, - globalNumericVersion = Flag False - } - -globalCommand :: [Command action] -> CommandUI GlobalFlags -globalCommand commands = CommandUI - { commandName = "" - , commandSynopsis = "" - , commandUsage = \pname -> - "This Setup program uses the Haskell Cabal Infrastructure.\n" - ++ "See http://www.haskell.org/cabal/ for more information.\n" - ++ "\n" - ++ "Usage: " ++ pname ++ " [GLOBAL FLAGS] [COMMAND [FLAGS]]\n" - , commandDescription = Just $ \pname -> - let - commands' = commands ++ [commandAddAction helpCommandUI undefined] - cmdDescs = getNormalCommandDescriptions commands' - maxlen = maximum $ [length name | (name, _) <- cmdDescs] - align str = str ++ replicate (maxlen - length str) ' ' - in - "Commands:\n" - ++ unlines [ " " ++ align name ++ " " ++ descr - | (name, descr) <- cmdDescs ] - ++ "\n" - ++ "For more information about a command use\n" - ++ " " ++ pname ++ " COMMAND --help\n\n" - ++ "Typical steps for installing Cabal packages:\n" - ++ concat [ " " ++ pname ++ " " ++ x ++ "\n" - | x <- ["configure", "build", "install"]] - , commandNotes = Nothing - , commandDefaultFlags = defaultGlobalFlags - , commandOptions = \_ -> - [option ['V'] ["version"] - "Print version information" - globalVersion (\v flags -> flags { globalVersion = v }) - trueArg - ,option [] ["numeric-version"] - "Print just the version number" - globalNumericVersion (\v flags -> flags { globalNumericVersion = v }) - trueArg - ] - } - -emptyGlobalFlags :: GlobalFlags -emptyGlobalFlags = mempty - -instance Monoid GlobalFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup GlobalFlags where - (<>) = gmappend - --- ------------------------------------------------------------ --- * Config flags --- ------------------------------------------------------------ - --- | Flags to @configure@ command. --- --- IMPORTANT: every time a new flag is added, 'D.C.Setup.filterConfigureFlags' --- should be updated. --- IMPORTANT: every time a new flag is added, it should be added to the Eq instance -data ConfigFlags = ConfigFlags { - -- This is the same hack as in 'buildArgs' and 'copyArgs'. - -- TODO: Stop using this eventually when 'UserHooks' gets changed - configArgs :: [String], - - --FIXME: the configPrograms is only here to pass info through to configure - -- because the type of configure is constrained by the UserHooks. - -- when we change UserHooks next we should pass the initial - -- ProgramDb directly and not via ConfigFlags - configPrograms_ :: Option' (Last' ProgramDb), -- ^All programs that - -- @cabal@ may run - - configProgramPaths :: [(String, FilePath)], -- ^user specified programs paths - configProgramArgs :: [(String, [String])], -- ^user specified programs args - configProgramPathExtra :: NubList FilePath, -- ^Extend the $PATH - configHcFlavor :: Flag CompilerFlavor, -- ^The \"flavor\" of the - -- compiler, e.g. GHC. - configHcPath :: Flag FilePath, -- ^given compiler location - configHcPkg :: Flag FilePath, -- ^given hc-pkg location - configVanillaLib :: Flag Bool, -- ^Enable vanilla library - configProfLib :: Flag Bool, -- ^Enable profiling in the library - configSharedLib :: Flag Bool, -- ^Build shared library - configStaticLib :: Flag Bool, -- ^Build static library - configDynExe :: Flag Bool, -- ^Enable dynamic linking of the - -- executables. - configFullyStaticExe :: Flag Bool, -- ^Enable fully static linking of the - -- executables. - configProfExe :: Flag Bool, -- ^Enable profiling in the - -- executables. - configProf :: Flag Bool, -- ^Enable profiling in the library - -- and executables. - configProfDetail :: Flag ProfDetailLevel, -- ^Profiling detail level - -- in the library and executables. - configProfLibDetail :: Flag ProfDetailLevel, -- ^Profiling detail level - -- in the library - configConfigureArgs :: [String], -- ^Extra arguments to @configure@ - configOptimization :: Flag OptimisationLevel, -- ^Enable optimization. - configProgPrefix :: Flag PathTemplate, -- ^Installed executable prefix. - configProgSuffix :: Flag PathTemplate, -- ^Installed executable suffix. - configInstallDirs :: InstallDirs (Flag PathTemplate), -- ^Installation - -- paths - configScratchDir :: Flag FilePath, - configExtraLibDirs :: [FilePath], -- ^ path to search for extra libraries - configExtraFrameworkDirs :: [FilePath], -- ^ path to search for extra - -- frameworks (OS X only) - configExtraIncludeDirs :: [FilePath], -- ^ path to search for header files - configIPID :: Flag String, -- ^ explicit IPID to be used - configCID :: Flag ComponentId, -- ^ explicit CID to be used - configDeterministic :: Flag Bool, -- ^ be as deterministic as possible - -- (e.g., invariant over GHC, database, - -- etc). Used by the test suite - - configDistPref :: Flag FilePath, -- ^"dist" prefix - configCabalFilePath :: Flag FilePath, -- ^ Cabal file to use - configVerbosity :: Flag Verbosity, -- ^verbosity level - configUserInstall :: Flag Bool, -- ^The --user\/--global flag - configPackageDBs :: [Maybe PackageDB], -- ^Which package DBs to use - configGHCiLib :: Flag Bool, -- ^Enable compiling library for GHCi - configSplitSections :: Flag Bool, -- ^Enable -split-sections with GHC - configSplitObjs :: Flag Bool, -- ^Enable -split-objs with GHC - configStripExes :: Flag Bool, -- ^Enable executable stripping - configStripLibs :: Flag Bool, -- ^Enable library stripping - configConstraints :: [PackageVersionConstraint], -- ^Additional constraints for - -- dependencies. - configDependencies :: [GivenComponent], - -- ^The packages depended on. - configInstantiateWith :: [(ModuleName, Module)], - -- ^ The requested Backpack instantiation. If empty, either this - -- package does not use Backpack, or we just want to typecheck - -- the indefinite package. - configConfigurationsFlags :: FlagAssignment, - configTests :: Flag Bool, -- ^Enable test suite compilation - configBenchmarks :: Flag Bool, -- ^Enable benchmark compilation - configCoverage :: Flag Bool, -- ^Enable program coverage - configLibCoverage :: Flag Bool, -- ^Enable program coverage (deprecated) - configExactConfiguration :: Flag Bool, - -- ^All direct dependencies and flags are provided on the command line by - -- the user via the '--dependency' and '--flags' options. - configFlagError :: Flag String, - -- ^Halt and show an error message indicating an error in flag assignment - configRelocatable :: Flag Bool, -- ^ Enable relocatable package built - configDebugInfo :: Flag DebugInfoLevel, -- ^ Emit debug info. - configUseResponseFiles :: Flag Bool, - -- ^ Whether to use response files at all. They're used for such tools - -- as haddock, or ld. - configAllowDependingOnPrivateLibs :: Flag Bool - -- ^ Allow depending on private sublibraries. This is used by external - -- tools (like cabal-install) so they can add multiple-public-libraries - -- compatibility to older ghcs by checking visibility externally. - } - deriving (Generic, Read, Show, Typeable) - -instance Binary ConfigFlags -instance Structured ConfigFlags - --- | More convenient version of 'configPrograms'. Results in an --- 'error' if internal invariant is violated. -configPrograms :: WithCallStack (ConfigFlags -> ProgramDb) -configPrograms = fromMaybe (error "FIXME: remove configPrograms") . fmap getLast' - . getOption' . configPrograms_ - -instance Eq ConfigFlags where - (==) a b = - -- configPrograms skipped: not user specified, has no Eq instance - equal configProgramPaths - && equal configProgramArgs - && equal configProgramPathExtra - && equal configHcFlavor - && equal configHcPath - && equal configHcPkg - && equal configVanillaLib - && equal configProfLib - && equal configSharedLib - && equal configStaticLib - && equal configDynExe - && equal configFullyStaticExe - && equal configProfExe - && equal configProf - && equal configProfDetail - && equal configProfLibDetail - && equal configConfigureArgs - && equal configOptimization - && equal configProgPrefix - && equal configProgSuffix - && equal configInstallDirs - && equal configScratchDir - && equal configExtraLibDirs - && equal configExtraIncludeDirs - && equal configIPID - && equal configDeterministic - && equal configDistPref - && equal configVerbosity - && equal configUserInstall - && equal configPackageDBs - && equal configGHCiLib - && equal configSplitSections - && equal configSplitObjs - && equal configStripExes - && equal configStripLibs - && equal configConstraints - && equal configDependencies - && equal configConfigurationsFlags - && equal configTests - && equal configBenchmarks - && equal configCoverage - && equal configLibCoverage - && equal configExactConfiguration - && equal configFlagError - && equal configRelocatable - && equal configDebugInfo - && equal configUseResponseFiles - where - equal f = on (==) f a b - -configAbsolutePaths :: ConfigFlags -> IO ConfigFlags -configAbsolutePaths f = - (\v -> f { configPackageDBs = v }) - `liftM` traverse (maybe (return Nothing) (liftM Just . absolutePackageDBPath)) - (configPackageDBs f) - -defaultConfigFlags :: ProgramDb -> ConfigFlags -defaultConfigFlags progDb = emptyConfigFlags { - configArgs = [], - configPrograms_ = Option' (Just (Last' progDb)), - configHcFlavor = maybe NoFlag Flag defaultCompilerFlavor, - configVanillaLib = Flag True, - configProfLib = NoFlag, - configSharedLib = NoFlag, - configStaticLib = NoFlag, - configDynExe = Flag False, - configFullyStaticExe = Flag False, - configProfExe = NoFlag, - configProf = NoFlag, - configProfDetail = NoFlag, - configProfLibDetail= NoFlag, - configOptimization = Flag NormalOptimisation, - configProgPrefix = Flag (toPathTemplate ""), - configProgSuffix = Flag (toPathTemplate ""), - configDistPref = NoFlag, - configCabalFilePath = NoFlag, - configVerbosity = Flag normal, - configUserInstall = Flag False, --TODO: reverse this -#if defined(mingw32_HOST_OS) - -- See #1589. - configGHCiLib = Flag True, -#else - configGHCiLib = NoFlag, -#endif - configSplitSections = Flag False, - configSplitObjs = Flag False, -- takes longer, so turn off by default - configStripExes = NoFlag, - configStripLibs = NoFlag, - configTests = Flag False, - configBenchmarks = Flag False, - configCoverage = Flag False, - configLibCoverage = NoFlag, - configExactConfiguration = Flag False, - configFlagError = NoFlag, - configRelocatable = Flag False, - configDebugInfo = Flag NoDebugInfo, - configUseResponseFiles = NoFlag - } - -configureCommand :: ProgramDb -> CommandUI ConfigFlags -configureCommand progDb = CommandUI - { commandName = "configure" - , commandSynopsis = "Prepare to build the package." - , commandDescription = Just $ \_ -> wrapText $ - "Configure how the package is built by setting " - ++ "package (and other) flags.\n" - ++ "\n" - ++ "The configuration affects several other commands, " - ++ "including build, test, bench, run, repl.\n" - , commandNotes = Just $ \_pname -> programFlagsDescription progDb - , commandUsage = \pname -> - "Usage: " ++ pname ++ " configure [FLAGS]\n" - , commandDefaultFlags = defaultConfigFlags progDb - , commandOptions = \showOrParseArgs -> - configureOptions showOrParseArgs - ++ programDbPaths progDb showOrParseArgs - configProgramPaths (\v fs -> fs { configProgramPaths = v }) - ++ programDbOption progDb showOrParseArgs - configProgramArgs (\v fs -> fs { configProgramArgs = v }) - ++ programDbOptions progDb showOrParseArgs - configProgramArgs (\v fs -> fs { configProgramArgs = v }) - } - --- | Inverse to 'dispModSubstEntry'. -parsecModSubstEntry :: ParsecParser (ModuleName, Module) -parsecModSubstEntry = do - k <- parsec - _ <- P.char '=' - v <- parsec - return (k, v) - --- | Pretty-print a single entry of a module substitution. -dispModSubstEntry :: (ModuleName, Module) -> Disp.Doc -dispModSubstEntry (k, v) = pretty k <<>> Disp.char '=' <<>> pretty v - -configureOptions :: ShowOrParseArgs -> [OptionField ConfigFlags] -configureOptions showOrParseArgs = - [optionVerbosity configVerbosity - (\v flags -> flags { configVerbosity = v }) - ,optionDistPref - configDistPref (\d flags -> flags { configDistPref = d }) - showOrParseArgs - - ,option [] ["compiler"] "compiler" - configHcFlavor (\v flags -> flags { configHcFlavor = v }) - (choiceOpt [ (Flag GHC, ("g", ["ghc"]), "compile with GHC") - , (Flag GHCJS, ([] , ["ghcjs"]), "compile with GHCJS") - , (Flag UHC, ([] , ["uhc"]), "compile with UHC") - -- "haskell-suite" compiler id string will be replaced - -- by a more specific one during the configure stage - , (Flag (HaskellSuite "haskell-suite"), ([] , ["haskell-suite"]), - "compile with a haskell-suite compiler")]) - - ,option "" ["cabal-file"] - "use this Cabal file" - configCabalFilePath (\v flags -> flags { configCabalFilePath = v }) - (reqArgFlag "PATH") - - ,option "w" ["with-compiler"] - "give the path to a particular compiler" - configHcPath (\v flags -> flags { configHcPath = v }) - (reqArgFlag "PATH") - - ,option "" ["with-hc-pkg"] - "give the path to the package tool" - configHcPkg (\v flags -> flags { configHcPkg = v }) - (reqArgFlag "PATH") - ] - ++ map liftInstallDirs installDirsOptions - ++ [option "" ["program-prefix"] - "prefix to be applied to installed executables" - configProgPrefix - (\v flags -> flags { configProgPrefix = v }) - (reqPathTemplateArgFlag "PREFIX") - - ,option "" ["program-suffix"] - "suffix to be applied to installed executables" - configProgSuffix (\v flags -> flags { configProgSuffix = v } ) - (reqPathTemplateArgFlag "SUFFIX") - - ,option "" ["library-vanilla"] - "Vanilla libraries" - configVanillaLib (\v flags -> flags { configVanillaLib = v }) - (boolOpt [] []) - - ,option "p" ["library-profiling"] - "Library profiling" - configProfLib (\v flags -> flags { configProfLib = v }) - (boolOpt "p" []) - - ,option "" ["shared"] - "Shared library" - configSharedLib (\v flags -> flags { configSharedLib = v }) - (boolOpt [] []) - - ,option "" ["static"] - "Static library" - configStaticLib (\v flags -> flags { configStaticLib = v }) - (boolOpt [] []) - - ,option "" ["executable-dynamic"] - "Executable dynamic linking" - configDynExe (\v flags -> flags { configDynExe = v }) - (boolOpt [] []) - - ,option "" ["executable-static"] - "Executable fully static linking" - configFullyStaticExe (\v flags -> flags { configFullyStaticExe = v }) - (boolOpt [] []) - - ,option "" ["profiling"] - "Executable and library profiling" - configProf (\v flags -> flags { configProf = v }) - (boolOpt [] []) - - ,option "" ["executable-profiling"] - "Executable profiling (DEPRECATED)" - configProfExe (\v flags -> flags { configProfExe = v }) - (boolOpt [] []) - - ,option "" ["profiling-detail"] - ("Profiling detail level for executable and library (default, " ++ - "none, exported-functions, toplevel-functions, all-functions).") - configProfDetail (\v flags -> flags { configProfDetail = v }) - (reqArg' "level" (Flag . flagToProfDetailLevel) - showProfDetailLevelFlag) - - ,option "" ["library-profiling-detail"] - "Profiling detail level for libraries only." - configProfLibDetail (\v flags -> flags { configProfLibDetail = v }) - (reqArg' "level" (Flag . flagToProfDetailLevel) - showProfDetailLevelFlag) - - ,multiOption "optimization" - configOptimization (\v flags -> flags { configOptimization = v }) - [optArg' "n" (Flag . flagToOptimisationLevel) - (\f -> case f of - Flag NoOptimisation -> [] - Flag NormalOptimisation -> [Nothing] - Flag MaximumOptimisation -> [Just "2"] - _ -> []) - "O" ["enable-optimization","enable-optimisation"] - "Build with optimization (n is 0--2, default is 1)", - noArg (Flag NoOptimisation) [] - ["disable-optimization","disable-optimisation"] - "Build without optimization" - ] - - ,multiOption "debug-info" - configDebugInfo (\v flags -> flags { configDebugInfo = v }) - [optArg' "n" (Flag . flagToDebugInfoLevel) - (\f -> case f of - Flag NoDebugInfo -> [] - Flag MinimalDebugInfo -> [Just "1"] - Flag NormalDebugInfo -> [Nothing] - Flag MaximalDebugInfo -> [Just "3"] - _ -> []) - "" ["enable-debug-info"] - "Emit debug info (n is 0--3, default is 0)", - noArg (Flag NoDebugInfo) [] - ["disable-debug-info"] - "Don't emit debug info" - ] - - ,option "" ["library-for-ghci"] - "compile library for use with GHCi" - configGHCiLib (\v flags -> flags { configGHCiLib = v }) - (boolOpt [] []) - - ,option "" ["split-sections"] - "compile library code such that unneeded definitions can be dropped from the final executable (GHC 7.8+)" - configSplitSections (\v flags -> flags { configSplitSections = v }) - (boolOpt [] []) - - ,option "" ["split-objs"] - "split library into smaller objects to reduce binary sizes (GHC 6.6+)" - configSplitObjs (\v flags -> flags { configSplitObjs = v }) - (boolOpt [] []) - - ,option "" ["executable-stripping"] - "strip executables upon installation to reduce binary sizes" - configStripExes (\v flags -> flags { configStripExes = v }) - (boolOpt [] []) - - ,option "" ["library-stripping"] - "strip libraries upon installation to reduce binary sizes" - configStripLibs (\v flags -> flags { configStripLibs = v }) - (boolOpt [] []) - - ,option "" ["configure-option"] - "Extra option for configure" - configConfigureArgs (\v flags -> flags { configConfigureArgs = v }) - (reqArg' "OPT" (\x -> [x]) id) - - ,option "" ["user-install"] - "doing a per-user installation" - configUserInstall (\v flags -> flags { configUserInstall = v }) - (boolOpt' ([],["user"]) ([], ["global"])) - - ,option "" ["package-db"] - ( "Append the given package database to the list of package" - ++ " databases used (to satisfy dependencies and register into)." - ++ " May be a specific file, 'global' or 'user'. The initial list" - ++ " is ['global'], ['global', 'user'], or ['global', $sandbox]," - ++ " depending on context. Use 'clear' to reset the list to empty." - ++ " See the user guide for details.") - configPackageDBs (\v flags -> flags { configPackageDBs = v }) - (reqArg' "DB" readPackageDbList showPackageDbList) - - ,option "f" ["flags"] - "Force values for the given flags in Cabal conditionals in the .cabal file. E.g., --flags=\"debug -usebytestrings\" forces the flag \"debug\" to true and \"usebytestrings\" to false." - configConfigurationsFlags (\v flags -> flags { configConfigurationsFlags = v }) - (reqArg "FLAGS" - (parsecToReadE (\err -> "Invalid flag assignment: " ++ err) legacyParsecFlagAssignment) - legacyShowFlagAssignment') - - ,option "" ["extra-include-dirs"] - "A list of directories to search for header files" - configExtraIncludeDirs (\v flags -> flags {configExtraIncludeDirs = v}) - (reqArg' "PATH" (\x -> [x]) id) - - ,option "" ["deterministic"] - "Try to be as deterministic as possible (used by the test suite)" - configDeterministic (\v flags -> flags {configDeterministic = v}) - (boolOpt [] []) - - ,option "" ["ipid"] - "Installed package ID to compile this package as" - configIPID (\v flags -> flags {configIPID = v}) - (reqArgFlag "IPID") - - ,option "" ["cid"] - "Installed component ID to compile this component as" - (fmap prettyShow . configCID) (\v flags -> flags {configCID = fmap mkComponentId v}) - (reqArgFlag "CID") - - ,option "" ["extra-lib-dirs"] - "A list of directories to search for external libraries" - configExtraLibDirs (\v flags -> flags {configExtraLibDirs = v}) - (reqArg' "PATH" (\x -> [x]) id) - - ,option "" ["extra-framework-dirs"] - "A list of directories to search for external frameworks (OS X only)" - configExtraFrameworkDirs - (\v flags -> flags {configExtraFrameworkDirs = v}) - (reqArg' "PATH" (\x -> [x]) id) - - ,option "" ["extra-prog-path"] - "A list of directories to search for required programs (in addition to the normal search locations)" - configProgramPathExtra (\v flags -> flags {configProgramPathExtra = v}) - (reqArg' "PATH" (\x -> toNubList [x]) fromNubList) - - ,option "" ["constraint"] - "A list of additional constraints on the dependencies." - configConstraints (\v flags -> flags { configConstraints = v}) - (reqArg "DEPENDENCY" - (parsecToReadE (const "dependency expected") ((\x -> [x]) `fmap` parsec)) - (map prettyShow)) - - ,option "" ["dependency"] - "A list of exact dependencies. E.g., --dependency=\"void=void-0.5.8-177d5cdf20962d0581fe2e4932a6c309\"" - configDependencies (\v flags -> flags { configDependencies = v}) - (reqArg "NAME[:COMPONENT_NAME]=CID" - (parsecToReadE (const "dependency expected") ((\x -> [x]) `fmap` parsecGivenComponent)) - (map (\(GivenComponent pn cn cid) -> - prettyShow pn - ++ case cn of LMainLibName -> "" - LSubLibName n -> ":" ++ prettyShow n - ++ "=" ++ prettyShow cid))) - - ,option "" ["instantiate-with"] - "A mapping of signature names to concrete module instantiations." - configInstantiateWith (\v flags -> flags { configInstantiateWith = v }) - (reqArg "NAME=MOD" - (parsecToReadE ("Cannot parse module substitution: " ++) (fmap (:[]) parsecModSubstEntry)) - (map (Disp.renderStyle defaultStyle . dispModSubstEntry))) - - ,option "" ["tests"] - "dependency checking and compilation for test suites listed in the package description file." - configTests (\v flags -> flags { configTests = v }) - (boolOpt [] []) - - ,option "" ["coverage"] - "build package with Haskell Program Coverage. (GHC only)" - configCoverage (\v flags -> flags { configCoverage = v }) - (boolOpt [] []) - - ,option "" ["library-coverage"] - "build package with Haskell Program Coverage. (GHC only) (DEPRECATED)" - configLibCoverage (\v flags -> flags { configLibCoverage = v }) - (boolOpt [] []) - - ,option "" ["exact-configuration"] - "All direct dependencies and flags are provided on the command line." - configExactConfiguration - (\v flags -> flags { configExactConfiguration = v }) - trueArg - - ,option "" ["benchmarks"] - "dependency checking and compilation for benchmarks listed in the package description file." - configBenchmarks (\v flags -> flags { configBenchmarks = v }) - (boolOpt [] []) - - ,option "" ["relocatable"] - "building a package that is relocatable. (GHC only)" - configRelocatable (\v flags -> flags { configRelocatable = v}) - (boolOpt [] []) - - ,option "" ["response-files"] - "enable workaround for old versions of programs like \"ar\" that do not support @file arguments" - configUseResponseFiles - (\v flags -> flags { configUseResponseFiles = v }) - (boolOpt' ([], ["disable-response-files"]) ([], [])) - - ,option "" ["allow-depending-on-private-libs"] - ( "Allow depending on private libraries. " - ++ "If set, the library visibility check MUST be done externally." ) - configAllowDependingOnPrivateLibs - (\v flags -> flags { configAllowDependingOnPrivateLibs = v }) - trueArg - ] - where - liftInstallDirs = - liftOption configInstallDirs (\v flags -> flags { configInstallDirs = v }) - - reqPathTemplateArgFlag title _sf _lf d get set = - reqArgFlag title _sf _lf d - (fmap fromPathTemplate . get) (set . fmap toPathTemplate) - -readPackageDbList :: String -> [Maybe PackageDB] -readPackageDbList "clear" = [Nothing] -readPackageDbList "global" = [Just GlobalPackageDB] -readPackageDbList "user" = [Just UserPackageDB] -readPackageDbList other = [Just (SpecificPackageDB other)] - -showPackageDbList :: [Maybe PackageDB] -> [String] -showPackageDbList = map showPackageDb - where - showPackageDb Nothing = "clear" - showPackageDb (Just GlobalPackageDB) = "global" - showPackageDb (Just UserPackageDB) = "user" - showPackageDb (Just (SpecificPackageDB db)) = db - -showProfDetailLevelFlag :: Flag ProfDetailLevel -> [String] -showProfDetailLevelFlag NoFlag = [] -showProfDetailLevelFlag (Flag dl) = [showProfDetailLevel dl] - -parsecGivenComponent :: ParsecParser GivenComponent -parsecGivenComponent = do - pn <- parsec - ln <- P.option LMainLibName $ do - _ <- P.char ':' - ucn <- parsec - return $ if unUnqualComponentName ucn == unPackageName pn - then LMainLibName - else LSubLibName ucn - _ <- P.char '=' - cid <- parsec - return $ GivenComponent pn ln cid - -installDirsOptions :: [OptionField (InstallDirs (Flag PathTemplate))] -installDirsOptions = - [ option "" ["prefix"] - "bake this prefix in preparation of installation" - prefix (\v flags -> flags { prefix = v }) - installDirArg - - , option "" ["bindir"] - "installation directory for executables" - bindir (\v flags -> flags { bindir = v }) - installDirArg - - , option "" ["libdir"] - "installation directory for libraries" - libdir (\v flags -> flags { libdir = v }) - installDirArg - - , option "" ["libsubdir"] - "subdirectory of libdir in which libs are installed" - libsubdir (\v flags -> flags { libsubdir = v }) - installDirArg - - , option "" ["dynlibdir"] - "installation directory for dynamic libraries" - dynlibdir (\v flags -> flags { dynlibdir = v }) - installDirArg - - , option "" ["libexecdir"] - "installation directory for program executables" - libexecdir (\v flags -> flags { libexecdir = v }) - installDirArg - - , option "" ["libexecsubdir"] - "subdirectory of libexecdir in which private executables are installed" - libexecsubdir (\v flags -> flags { libexecsubdir = v }) - installDirArg - - , option "" ["datadir"] - "installation directory for read-only data" - datadir (\v flags -> flags { datadir = v }) - installDirArg - - , option "" ["datasubdir"] - "subdirectory of datadir in which data files are installed" - datasubdir (\v flags -> flags { datasubdir = v }) - installDirArg - - , option "" ["docdir"] - "installation directory for documentation" - docdir (\v flags -> flags { docdir = v }) - installDirArg - - , option "" ["htmldir"] - "installation directory for HTML documentation" - htmldir (\v flags -> flags { htmldir = v }) - installDirArg - - , option "" ["haddockdir"] - "installation directory for haddock interfaces" - haddockdir (\v flags -> flags { haddockdir = v }) - installDirArg - - , option "" ["sysconfdir"] - "installation directory for configuration files" - sysconfdir (\v flags -> flags { sysconfdir = v }) - installDirArg - ] - where - installDirArg _sf _lf d get set = - reqArgFlag "DIR" _sf _lf d - (fmap fromPathTemplate . get) (set . fmap toPathTemplate) - -emptyConfigFlags :: ConfigFlags -emptyConfigFlags = mempty - -instance Monoid ConfigFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup ConfigFlags where - (<>) = gmappend - --- ------------------------------------------------------------ --- * Copy flags --- ------------------------------------------------------------ - --- | Flags to @copy@: (destdir, copy-prefix (backwards compat), verbosity) -data CopyFlags = CopyFlags { - copyDest :: Flag CopyDest, - copyDistPref :: Flag FilePath, - copyVerbosity :: Flag Verbosity, - -- This is the same hack as in 'buildArgs'. But I (ezyang) don't - -- think it's a hack, it's the right way to make hooks more robust - -- TODO: Stop using this eventually when 'UserHooks' gets changed - copyArgs :: [String], - copyCabalFilePath :: Flag FilePath - } - deriving (Show, Generic) - -defaultCopyFlags :: CopyFlags -defaultCopyFlags = CopyFlags { - copyDest = Flag NoCopyDest, - copyDistPref = NoFlag, - copyVerbosity = Flag normal, - copyArgs = [], - copyCabalFilePath = mempty - } - -copyCommand :: CommandUI CopyFlags -copyCommand = CommandUI - { commandName = "copy" - , commandSynopsis = "Copy the files of all/specific components to install locations." - , commandDescription = Just $ \_ -> wrapText $ - "Components encompass executables and libraries. " - ++ "Does not call register, and allows a prefix at install time. " - ++ "Without the --destdir flag, configure determines location.\n" - , commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " copy " - ++ " All the components in the package\n" - ++ " " ++ pname ++ " copy foo " - ++ " A component (i.e. lib, exe, test suite)" - , commandUsage = usageAlternatives "copy" $ - [ "[FLAGS]" - , "COMPONENTS [FLAGS]" - ] - , commandDefaultFlags = defaultCopyFlags - , commandOptions = \showOrParseArgs -> case showOrParseArgs of - ShowArgs -> filter ((`notElem` ["target-package-db"]) - . optionName) $ copyOptions ShowArgs - ParseArgs -> copyOptions ParseArgs -} - -copyOptions :: ShowOrParseArgs -> [OptionField CopyFlags] -copyOptions showOrParseArgs = - [optionVerbosity copyVerbosity (\v flags -> flags { copyVerbosity = v }) - - ,optionDistPref - copyDistPref (\d flags -> flags { copyDistPref = d }) - showOrParseArgs - - ,option "" ["destdir"] - "directory to copy files to, prepended to installation directories" - copyDest (\v flags -> case copyDest flags of - Flag (CopyToDb _) -> error "Use either 'destdir' or 'target-package-db'." - _ -> flags { copyDest = v }) - (reqArg "DIR" (succeedReadE (Flag . CopyTo)) - (\f -> case f of Flag (CopyTo p) -> [p]; _ -> [])) - - ,option "" ["target-package-db"] - "package database to copy files into. Required when using ${pkgroot} prefix." - copyDest (\v flags -> case copyDest flags of - NoFlag -> flags { copyDest = v } - Flag NoCopyDest -> flags { copyDest = v } - _ -> error "Use either 'destdir' or 'target-package-db'.") - (reqArg "DATABASE" (succeedReadE (Flag . CopyToDb)) - (\f -> case f of Flag (CopyToDb p) -> [p]; _ -> [])) - ] - -emptyCopyFlags :: CopyFlags -emptyCopyFlags = mempty - -instance Monoid CopyFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup CopyFlags where - (<>) = gmappend - --- ------------------------------------------------------------ --- * Install flags --- ------------------------------------------------------------ - --- | Flags to @install@: (package db, verbosity) -data InstallFlags = InstallFlags { - installPackageDB :: Flag PackageDB, - installDest :: Flag CopyDest, - installDistPref :: Flag FilePath, - installUseWrapper :: Flag Bool, - installInPlace :: Flag Bool, - installVerbosity :: Flag Verbosity, - -- this is only here, because we can not - -- change the hooks API. - installCabalFilePath :: Flag FilePath - } - deriving (Show, Generic) - -defaultInstallFlags :: InstallFlags -defaultInstallFlags = InstallFlags { - installPackageDB = NoFlag, - installDest = Flag NoCopyDest, - installDistPref = NoFlag, - installUseWrapper = Flag False, - installInPlace = Flag False, - installVerbosity = Flag normal, - installCabalFilePath = mempty - } - -installCommand :: CommandUI InstallFlags -installCommand = CommandUI - { commandName = "install" - , commandSynopsis = - "Copy the files into the install locations. Run register." - , commandDescription = Just $ \_ -> wrapText $ - "Unlike the copy command, install calls the register command." - ++ "If you want to install into a location that is not what was" - ++ "specified in the configure step, use the copy command.\n" - , commandNotes = Nothing - , commandUsage = \pname -> - "Usage: " ++ pname ++ " install [FLAGS]\n" - , commandDefaultFlags = defaultInstallFlags - , commandOptions = \showOrParseArgs -> case showOrParseArgs of - ShowArgs -> filter ((`notElem` ["target-package-db"]) - . optionName) $ installOptions ShowArgs - ParseArgs -> installOptions ParseArgs - } - -installOptions :: ShowOrParseArgs -> [OptionField InstallFlags] -installOptions showOrParseArgs = - [optionVerbosity installVerbosity (\v flags -> flags { installVerbosity = v }) - ,optionDistPref - installDistPref (\d flags -> flags { installDistPref = d }) - showOrParseArgs - - ,option "" ["inplace"] - "install the package in the install subdirectory of the dist prefix, so it can be used without being installed" - installInPlace (\v flags -> flags { installInPlace = v }) - trueArg - - ,option "" ["shell-wrappers"] - "using shell script wrappers around executables" - installUseWrapper (\v flags -> flags { installUseWrapper = v }) - (boolOpt [] []) - - ,option "" ["package-db"] "" - installPackageDB (\v flags -> flags { installPackageDB = v }) - (choiceOpt [ (Flag UserPackageDB, ([],["user"]), - "upon configuration register this package in the user's local package database") - , (Flag GlobalPackageDB, ([],["global"]), - "(default) upon configuration register this package in the system-wide package database")]) - ,option "" ["target-package-db"] - "package database to install into. Required when using ${pkgroot} prefix." - installDest (\v flags -> flags { installDest = v }) - (reqArg "DATABASE" (succeedReadE (Flag . CopyToDb)) - (\f -> case f of Flag (CopyToDb p) -> [p]; _ -> [])) - ] - -emptyInstallFlags :: InstallFlags -emptyInstallFlags = mempty - -instance Monoid InstallFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup InstallFlags where - (<>) = gmappend - --- ------------------------------------------------------------ --- * SDist flags --- ------------------------------------------------------------ - --- | Flags to @sdist@: (snapshot, verbosity) -data SDistFlags = SDistFlags { - sDistSnapshot :: Flag Bool, - sDistDirectory :: Flag FilePath, - sDistDistPref :: Flag FilePath, - sDistListSources :: Flag FilePath, - sDistVerbosity :: Flag Verbosity - } - deriving (Show, Generic, Typeable) - -defaultSDistFlags :: SDistFlags -defaultSDistFlags = SDistFlags { - sDistSnapshot = Flag False, - sDistDirectory = mempty, - sDistDistPref = NoFlag, - sDistListSources = mempty, - sDistVerbosity = Flag normal - } - -sdistCommand :: CommandUI SDistFlags -sdistCommand = CommandUI - { commandName = "sdist" - , commandSynopsis = - "Generate a source distribution file (.tar.gz)." - , commandDescription = Nothing - , commandNotes = Nothing - , commandUsage = \pname -> - "Usage: " ++ pname ++ " sdist [FLAGS]\n" - , commandDefaultFlags = defaultSDistFlags - , commandOptions = \showOrParseArgs -> - [optionVerbosity sDistVerbosity (\v flags -> flags { sDistVerbosity = v }) - ,optionDistPref - sDistDistPref (\d flags -> flags { sDistDistPref = d }) - showOrParseArgs - - ,option "" ["list-sources"] - "Just write a list of the package's sources to a file" - sDistListSources (\v flags -> flags { sDistListSources = v }) - (reqArgFlag "FILE") - - ,option "" ["snapshot"] - "Produce a snapshot source distribution" - sDistSnapshot (\v flags -> flags { sDistSnapshot = v }) - trueArg - - ,option "" ["output-directory"] - ("Generate a source distribution in the given directory, " - ++ "without creating a tarball") - sDistDirectory (\v flags -> flags { sDistDirectory = v }) - (reqArgFlag "DIR") - ] - } - -emptySDistFlags :: SDistFlags -emptySDistFlags = mempty - -instance Monoid SDistFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup SDistFlags where - (<>) = gmappend - --- ------------------------------------------------------------ --- * Register flags --- ------------------------------------------------------------ - --- | Flags to @register@ and @unregister@: (user package, gen-script, --- in-place, verbosity) -data RegisterFlags = RegisterFlags { - regPackageDB :: Flag PackageDB, - regGenScript :: Flag Bool, - regGenPkgConf :: Flag (Maybe FilePath), - regInPlace :: Flag Bool, - regDistPref :: Flag FilePath, - regPrintId :: Flag Bool, - regVerbosity :: Flag Verbosity, - -- Same as in 'buildArgs' and 'copyArgs' - regArgs :: [String], - regCabalFilePath :: Flag FilePath - } - deriving (Show, Generic, Typeable) - -defaultRegisterFlags :: RegisterFlags -defaultRegisterFlags = RegisterFlags { - regPackageDB = NoFlag, - regGenScript = Flag False, - regGenPkgConf = NoFlag, - regInPlace = Flag False, - regDistPref = NoFlag, - regPrintId = Flag False, - regArgs = [], - regCabalFilePath = mempty, - regVerbosity = Flag normal - } - -registerCommand :: CommandUI RegisterFlags -registerCommand = CommandUI - { commandName = "register" - , commandSynopsis = - "Register this package with the compiler." - , commandDescription = Nothing - , commandNotes = Nothing - , commandUsage = \pname -> - "Usage: " ++ pname ++ " register [FLAGS]\n" - , commandDefaultFlags = defaultRegisterFlags - , commandOptions = \showOrParseArgs -> - [optionVerbosity regVerbosity (\v flags -> flags { regVerbosity = v }) - ,optionDistPref - regDistPref (\d flags -> flags { regDistPref = d }) - showOrParseArgs - - ,option "" ["packageDB"] "" - regPackageDB (\v flags -> flags { regPackageDB = v }) - (choiceOpt [ (Flag UserPackageDB, ([],["user"]), - "upon registration, register this package in the user's local package database") - , (Flag GlobalPackageDB, ([],["global"]), - "(default)upon registration, register this package in the system-wide package database")]) - - ,option "" ["inplace"] - "register the package in the build location, so it can be used without being installed" - regInPlace (\v flags -> flags { regInPlace = v }) - trueArg - - ,option "" ["gen-script"] - "instead of registering, generate a script to register later" - regGenScript (\v flags -> flags { regGenScript = v }) - trueArg - - ,option "" ["gen-pkg-config"] - "instead of registering, generate a package registration file/directory" - regGenPkgConf (\v flags -> flags { regGenPkgConf = v }) - (optArg' "PKG" Flag flagToList) - - ,option "" ["print-ipid"] - "print the installed package ID calculated for this package" - regPrintId (\v flags -> flags { regPrintId = v }) - trueArg - ] - } - -unregisterCommand :: CommandUI RegisterFlags -unregisterCommand = CommandUI - { commandName = "unregister" - , commandSynopsis = - "Unregister this package with the compiler." - , commandDescription = Nothing - , commandNotes = Nothing - , commandUsage = \pname -> - "Usage: " ++ pname ++ " unregister [FLAGS]\n" - , commandDefaultFlags = defaultRegisterFlags - , commandOptions = \showOrParseArgs -> - [optionVerbosity regVerbosity (\v flags -> flags { regVerbosity = v }) - ,optionDistPref - regDistPref (\d flags -> flags { regDistPref = d }) - showOrParseArgs - - ,option "" ["user"] "" - regPackageDB (\v flags -> flags { regPackageDB = v }) - (choiceOpt [ (Flag UserPackageDB, ([],["user"]), - "unregister this package in the user's local package database") - , (Flag GlobalPackageDB, ([],["global"]), - "(default) unregister this package in the system-wide package database")]) - - ,option "" ["gen-script"] - "Instead of performing the unregister command, generate a script to unregister later" - regGenScript (\v flags -> flags { regGenScript = v }) - trueArg - ] - } - -emptyRegisterFlags :: RegisterFlags -emptyRegisterFlags = mempty - -instance Monoid RegisterFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup RegisterFlags where - (<>) = gmappend - --- ------------------------------------------------------------ --- * HsColour flags --- ------------------------------------------------------------ - -data HscolourFlags = HscolourFlags { - hscolourCSS :: Flag FilePath, - hscolourExecutables :: Flag Bool, - hscolourTestSuites :: Flag Bool, - hscolourBenchmarks :: Flag Bool, - hscolourForeignLibs :: Flag Bool, - hscolourDistPref :: Flag FilePath, - hscolourVerbosity :: Flag Verbosity, - hscolourCabalFilePath :: Flag FilePath - } - deriving (Show, Generic, Typeable) - -emptyHscolourFlags :: HscolourFlags -emptyHscolourFlags = mempty - -defaultHscolourFlags :: HscolourFlags -defaultHscolourFlags = HscolourFlags { - hscolourCSS = NoFlag, - hscolourExecutables = Flag False, - hscolourTestSuites = Flag False, - hscolourBenchmarks = Flag False, - hscolourDistPref = NoFlag, - hscolourForeignLibs = Flag False, - hscolourVerbosity = Flag normal, - hscolourCabalFilePath = mempty - } - -instance Monoid HscolourFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup HscolourFlags where - (<>) = gmappend - -hscolourCommand :: CommandUI HscolourFlags -hscolourCommand = CommandUI - { commandName = "hscolour" - , commandSynopsis = - "Generate HsColour colourised code, in HTML format." - , commandDescription = Just (\_ -> "Requires the hscolour program.\n") - , commandNotes = Just $ \_ -> - "Deprecated in favour of 'cabal haddock --hyperlink-source'." - , commandUsage = \pname -> - "Usage: " ++ pname ++ " hscolour [FLAGS]\n" - , commandDefaultFlags = defaultHscolourFlags - , commandOptions = \showOrParseArgs -> - [optionVerbosity hscolourVerbosity - (\v flags -> flags { hscolourVerbosity = v }) - ,optionDistPref - hscolourDistPref (\d flags -> flags { hscolourDistPref = d }) - showOrParseArgs - - ,option "" ["executables"] - "Run hscolour for Executables targets" - hscolourExecutables (\v flags -> flags { hscolourExecutables = v }) - trueArg - - ,option "" ["tests"] - "Run hscolour for Test Suite targets" - hscolourTestSuites (\v flags -> flags { hscolourTestSuites = v }) - trueArg - - ,option "" ["benchmarks"] - "Run hscolour for Benchmark targets" - hscolourBenchmarks (\v flags -> flags { hscolourBenchmarks = v }) - trueArg - - ,option "" ["foreign-libraries"] - "Run hscolour for Foreign Library targets" - hscolourForeignLibs (\v flags -> flags { hscolourForeignLibs = v }) - trueArg - - ,option "" ["all"] - "Run hscolour for all targets" - (\f -> allFlags [ hscolourExecutables f - , hscolourTestSuites f - , hscolourBenchmarks f - , hscolourForeignLibs f - ]) - (\v flags -> flags { hscolourExecutables = v - , hscolourTestSuites = v - , hscolourBenchmarks = v - , hscolourForeignLibs = v - }) - trueArg - - ,option "" ["css"] - "Use a cascading style sheet" - hscolourCSS (\v flags -> flags { hscolourCSS = v }) - (reqArgFlag "PATH") - ] - } - --- ------------------------------------------------------------ --- * Doctest flags --- ------------------------------------------------------------ - -data DoctestFlags = DoctestFlags { - doctestProgramPaths :: [(String, FilePath)], - doctestProgramArgs :: [(String, [String])], - doctestDistPref :: Flag FilePath, - doctestVerbosity :: Flag Verbosity - } - deriving (Show, Generic, Typeable) - -defaultDoctestFlags :: DoctestFlags -defaultDoctestFlags = DoctestFlags { - doctestProgramPaths = mempty, - doctestProgramArgs = [], - doctestDistPref = NoFlag, - doctestVerbosity = Flag normal - } - -doctestCommand :: CommandUI DoctestFlags -doctestCommand = CommandUI - { commandName = "doctest" - , commandSynopsis = "Run doctest tests." - , commandDescription = Just $ \_ -> - "Requires the program doctest, version 0.12.\n" - , commandNotes = Nothing - , commandUsage = \pname -> - "Usage: " ++ pname ++ " doctest [FLAGS]\n" - , commandDefaultFlags = defaultDoctestFlags - , commandOptions = \showOrParseArgs -> - doctestOptions showOrParseArgs - ++ programDbPaths progDb ParseArgs - doctestProgramPaths (\v flags -> flags { doctestProgramPaths = v }) - ++ programDbOption progDb showOrParseArgs - doctestProgramArgs (\v fs -> fs { doctestProgramArgs = v }) - ++ programDbOptions progDb ParseArgs - doctestProgramArgs (\v flags -> flags { doctestProgramArgs = v }) - } - where - progDb = addKnownProgram doctestProgram - emptyProgramDb - -doctestOptions :: ShowOrParseArgs -> [OptionField DoctestFlags] -doctestOptions showOrParseArgs = - [optionVerbosity doctestVerbosity - (\v flags -> flags { doctestVerbosity = v }) - ,optionDistPref - doctestDistPref (\d flags -> flags { doctestDistPref = d }) - showOrParseArgs - ] - -emptyDoctestFlags :: DoctestFlags -emptyDoctestFlags = mempty - -instance Monoid DoctestFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup DoctestFlags where - (<>) = gmappend - --- ------------------------------------------------------------ --- * Haddock flags --- ------------------------------------------------------------ - - --- | When we build haddock documentation, there are two cases: --- --- 1. We build haddocks only for the current development version, --- intended for local use and not for distribution. In this case, --- we store the generated documentation in @/doc/html/@. --- --- 2. We build haddocks for intended for uploading them to hackage. --- In this case, we need to follow the layout that hackage expects --- from documentation tarballs, and we might also want to use different --- flags than for development builds, so in this case we store the generated --- documentation in @/doc/html/-docs@. -data HaddockTarget = ForHackage | ForDevelopment deriving (Eq, Show, Generic, Typeable) - -instance Binary HaddockTarget -instance Structured HaddockTarget - -instance Pretty HaddockTarget where - pretty ForHackage = Disp.text "for-hackage" - pretty ForDevelopment = Disp.text "for-development" - -instance Parsec HaddockTarget where - parsec = P.choice [ P.try $ P.string "for-hackage" >> return ForHackage - , P.string "for-development" >> return ForDevelopment] - -data HaddockFlags = HaddockFlags { - haddockProgramPaths :: [(String, FilePath)], - haddockProgramArgs :: [(String, [String])], - haddockHoogle :: Flag Bool, - haddockHtml :: Flag Bool, - haddockHtmlLocation :: Flag String, - haddockForHackage :: Flag HaddockTarget, - haddockExecutables :: Flag Bool, - haddockTestSuites :: Flag Bool, - haddockBenchmarks :: Flag Bool, - haddockForeignLibs :: Flag Bool, - haddockInternal :: Flag Bool, - haddockCss :: Flag FilePath, - haddockLinkedSource :: Flag Bool, - haddockQuickJump :: Flag Bool, - haddockHscolourCss :: Flag FilePath, - haddockContents :: Flag PathTemplate, - haddockDistPref :: Flag FilePath, - haddockKeepTempFiles:: Flag Bool, - haddockVerbosity :: Flag Verbosity, - haddockCabalFilePath :: Flag FilePath, - haddockArgs :: [String] - } - deriving (Show, Generic, Typeable) - -defaultHaddockFlags :: HaddockFlags -defaultHaddockFlags = HaddockFlags { - haddockProgramPaths = mempty, - haddockProgramArgs = [], - haddockHoogle = Flag False, - haddockHtml = Flag False, - haddockHtmlLocation = NoFlag, - haddockForHackage = NoFlag, - haddockExecutables = Flag False, - haddockTestSuites = Flag False, - haddockBenchmarks = Flag False, - haddockForeignLibs = Flag False, - haddockInternal = Flag False, - haddockCss = NoFlag, - haddockLinkedSource = Flag False, - haddockQuickJump = Flag False, - haddockHscolourCss = NoFlag, - haddockContents = NoFlag, - haddockDistPref = NoFlag, - haddockKeepTempFiles= Flag False, - haddockVerbosity = Flag normal, - haddockCabalFilePath = mempty, - haddockArgs = mempty - } - -haddockCommand :: CommandUI HaddockFlags -haddockCommand = CommandUI - { commandName = "haddock" - , commandSynopsis = "Generate Haddock HTML documentation." - , commandDescription = Just $ \_ -> - "Requires the program haddock, version 2.x.\n" - , commandNotes = Nothing - , commandUsage = usageAlternatives "haddock" $ - [ "[FLAGS]" - , "COMPONENTS [FLAGS]" - ] - , commandDefaultFlags = defaultHaddockFlags - , commandOptions = \showOrParseArgs -> - haddockOptions showOrParseArgs - ++ programDbPaths progDb ParseArgs - haddockProgramPaths (\v flags -> flags { haddockProgramPaths = v}) - ++ programDbOption progDb showOrParseArgs - haddockProgramArgs (\v fs -> fs { haddockProgramArgs = v }) - ++ programDbOptions progDb ParseArgs - haddockProgramArgs (\v flags -> flags { haddockProgramArgs = v}) - } - where - progDb = addKnownProgram haddockProgram - $ addKnownProgram ghcProgram - $ emptyProgramDb - -haddockOptions :: ShowOrParseArgs -> [OptionField HaddockFlags] -haddockOptions showOrParseArgs = - [optionVerbosity haddockVerbosity - (\v flags -> flags { haddockVerbosity = v }) - ,optionDistPref - haddockDistPref (\d flags -> flags { haddockDistPref = d }) - showOrParseArgs - - ,option "" ["keep-temp-files"] - "Keep temporary files" - haddockKeepTempFiles (\b flags -> flags { haddockKeepTempFiles = b }) - trueArg - - ,option "" ["hoogle"] - "Generate a hoogle database" - haddockHoogle (\v flags -> flags { haddockHoogle = v }) - trueArg - - ,option "" ["html"] - "Generate HTML documentation (the default)" - haddockHtml (\v flags -> flags { haddockHtml = v }) - trueArg - - ,option "" ["html-location"] - "Location of HTML documentation for pre-requisite packages" - haddockHtmlLocation (\v flags -> flags { haddockHtmlLocation = v }) - (reqArgFlag "URL") - - ,option "" ["for-hackage"] - "Collection of flags to generate documentation suitable for upload to hackage" - haddockForHackage (\v flags -> flags { haddockForHackage = v }) - (noArg (Flag ForHackage)) - - ,option "" ["executables"] - "Run haddock for Executables targets" - haddockExecutables (\v flags -> flags { haddockExecutables = v }) - trueArg - - ,option "" ["tests"] - "Run haddock for Test Suite targets" - haddockTestSuites (\v flags -> flags { haddockTestSuites = v }) - trueArg - - ,option "" ["benchmarks"] - "Run haddock for Benchmark targets" - haddockBenchmarks (\v flags -> flags { haddockBenchmarks = v }) - trueArg - - ,option "" ["foreign-libraries"] - "Run haddock for Foreign Library targets" - haddockForeignLibs (\v flags -> flags { haddockForeignLibs = v }) - trueArg - - ,option "" ["all"] - "Run haddock for all targets" - (\f -> allFlags [ haddockExecutables f - , haddockTestSuites f - , haddockBenchmarks f - , haddockForeignLibs f - ]) - (\v flags -> flags { haddockExecutables = v - , haddockTestSuites = v - , haddockBenchmarks = v - , haddockForeignLibs = v - }) - trueArg - - ,option "" ["internal"] - "Run haddock for internal modules and include all symbols" - haddockInternal (\v flags -> flags { haddockInternal = v }) - trueArg - - ,option "" ["css"] - "Use PATH as the haddock stylesheet" - haddockCss (\v flags -> flags { haddockCss = v }) - (reqArgFlag "PATH") - - ,option "" ["hyperlink-source","hyperlink-sources","hyperlinked-source"] - "Hyperlink the documentation to the source code" - haddockLinkedSource (\v flags -> flags { haddockLinkedSource = v }) - trueArg - - ,option "" ["quickjump"] - "Generate an index for interactive documentation navigation" - haddockQuickJump (\v flags -> flags { haddockQuickJump = v }) - trueArg - - ,option "" ["hscolour-css"] - "Use PATH as the HsColour stylesheet" - haddockHscolourCss (\v flags -> flags { haddockHscolourCss = v }) - (reqArgFlag "PATH") - - ,option "" ["contents-location"] - "Bake URL in as the location for the contents page" - haddockContents (\v flags -> flags { haddockContents = v }) - (reqArg' "URL" - (toFlag . toPathTemplate) - (flagToList . fmap fromPathTemplate)) - ] - -emptyHaddockFlags :: HaddockFlags -emptyHaddockFlags = mempty - -instance Monoid HaddockFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup HaddockFlags where - (<>) = gmappend - --- ------------------------------------------------------------ --- * Clean flags --- ------------------------------------------------------------ - -data CleanFlags = CleanFlags { - cleanSaveConf :: Flag Bool, - cleanDistPref :: Flag FilePath, - cleanVerbosity :: Flag Verbosity, - cleanCabalFilePath :: Flag FilePath - } - deriving (Show, Generic, Typeable) - -defaultCleanFlags :: CleanFlags -defaultCleanFlags = CleanFlags { - cleanSaveConf = Flag False, - cleanDistPref = NoFlag, - cleanVerbosity = Flag normal, - cleanCabalFilePath = mempty - } - -cleanCommand :: CommandUI CleanFlags -cleanCommand = CommandUI - { commandName = "clean" - , commandSynopsis = "Clean up after a build." - , commandDescription = Just $ \_ -> - "Removes .hi, .o, preprocessed sources, etc.\n" - , commandNotes = Nothing - , commandUsage = \pname -> - "Usage: " ++ pname ++ " clean [FLAGS]\n" - , commandDefaultFlags = defaultCleanFlags - , commandOptions = \showOrParseArgs -> - [optionVerbosity cleanVerbosity (\v flags -> flags { cleanVerbosity = v }) - ,optionDistPref - cleanDistPref (\d flags -> flags { cleanDistPref = d }) - showOrParseArgs - - ,option "s" ["save-configure"] - "Do not remove the configuration file (dist/setup-config) during cleaning. Saves need to reconfigure." - cleanSaveConf (\v flags -> flags { cleanSaveConf = v }) - trueArg - ] - } - -emptyCleanFlags :: CleanFlags -emptyCleanFlags = mempty - -instance Monoid CleanFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup CleanFlags where - (<>) = gmappend - --- ------------------------------------------------------------ --- * Build flags --- ------------------------------------------------------------ - -data BuildFlags = BuildFlags { - buildProgramPaths :: [(String, FilePath)], - buildProgramArgs :: [(String, [String])], - buildDistPref :: Flag FilePath, - buildVerbosity :: Flag Verbosity, - buildNumJobs :: Flag (Maybe Int), - -- TODO: this one should not be here, it's just that the silly - -- UserHooks stop us from passing extra info in other ways - buildArgs :: [String], - buildCabalFilePath :: Flag FilePath - } - deriving (Read, Show, Generic, Typeable) - -defaultBuildFlags :: BuildFlags -defaultBuildFlags = BuildFlags { - buildProgramPaths = mempty, - buildProgramArgs = [], - buildDistPref = mempty, - buildVerbosity = Flag normal, - buildNumJobs = mempty, - buildArgs = [], - buildCabalFilePath = mempty - } - -buildCommand :: ProgramDb -> CommandUI BuildFlags -buildCommand progDb = CommandUI - { commandName = "build" - , commandSynopsis = "Compile all/specific components." - , commandDescription = Just $ \_ -> wrapText $ - "Components encompass executables, tests, and benchmarks.\n" - ++ "\n" - ++ "Affected by configuration options, see `configure`.\n" - , commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " build " - ++ " All the components in the package\n" - ++ " " ++ pname ++ " build foo " - ++ " A component (i.e. lib, exe, test suite)\n\n" - ++ programFlagsDescription progDb ---TODO: re-enable once we have support for module/file targets --- ++ " " ++ pname ++ " build Foo.Bar " --- ++ " A module\n" --- ++ " " ++ pname ++ " build Foo/Bar.hs" --- ++ " A file\n\n" --- ++ "If a target is ambiguous it can be qualified with the component " --- ++ "name, e.g.\n" --- ++ " " ++ pname ++ " build foo:Foo.Bar\n" --- ++ " " ++ pname ++ " build testsuite1:Foo/Bar.hs\n" - , commandUsage = usageAlternatives "build" $ - [ "[FLAGS]" - , "COMPONENTS [FLAGS]" - ] - , commandDefaultFlags = defaultBuildFlags - , commandOptions = \showOrParseArgs -> - [ optionVerbosity - buildVerbosity (\v flags -> flags { buildVerbosity = v }) - - , optionDistPref - buildDistPref (\d flags -> flags { buildDistPref = d }) showOrParseArgs - ] - ++ buildOptions progDb showOrParseArgs - } - -buildOptions :: ProgramDb -> ShowOrParseArgs - -> [OptionField BuildFlags] -buildOptions progDb showOrParseArgs = - [ optionNumJobs - buildNumJobs (\v flags -> flags { buildNumJobs = v }) - ] - - ++ programDbPaths progDb showOrParseArgs - buildProgramPaths (\v flags -> flags { buildProgramPaths = v}) - - ++ programDbOption progDb showOrParseArgs - buildProgramArgs (\v fs -> fs { buildProgramArgs = v }) - - ++ programDbOptions progDb showOrParseArgs - buildProgramArgs (\v flags -> flags { buildProgramArgs = v}) - -emptyBuildFlags :: BuildFlags -emptyBuildFlags = mempty - -instance Monoid BuildFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup BuildFlags where - (<>) = gmappend - --- ------------------------------------------------------------ --- * REPL Flags --- ------------------------------------------------------------ - -data ReplFlags = ReplFlags { - replProgramPaths :: [(String, FilePath)], - replProgramArgs :: [(String, [String])], - replDistPref :: Flag FilePath, - replVerbosity :: Flag Verbosity, - replReload :: Flag Bool, - replReplOptions :: [String] - } - deriving (Show, Generic, Typeable) - -defaultReplFlags :: ReplFlags -defaultReplFlags = ReplFlags { - replProgramPaths = mempty, - replProgramArgs = [], - replDistPref = NoFlag, - replVerbosity = Flag normal, - replReload = Flag False, - replReplOptions = [] - } - -instance Monoid ReplFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup ReplFlags where - (<>) = gmappend - -replCommand :: ProgramDb -> CommandUI ReplFlags -replCommand progDb = CommandUI - { commandName = "repl" - , commandSynopsis = - "Open an interpreter session for the given component." - , commandDescription = Just $ \pname -> wrapText $ - "If the current directory contains no package, ignores COMPONENT " - ++ "parameters and opens an interactive interpreter session; if a " - ++ "sandbox is present, its package database will be used.\n" - ++ "\n" - ++ "Otherwise, (re)configures with the given or default flags, and " - ++ "loads the interpreter with the relevant modules. For executables, " - ++ "tests and benchmarks, loads the main module (and its " - ++ "dependencies); for libraries all exposed/other modules.\n" - ++ "\n" - ++ "The default component is the library itself, or the executable " - ++ "if that is the only component.\n" - ++ "\n" - ++ "Support for loading specific modules is planned but not " - ++ "implemented yet. For certain scenarios, `" ++ pname - ++ " exec -- ghci :l Foo` may be used instead. Note that `exec` will " - ++ "not (re)configure and you will have to specify the location of " - ++ "other modules, if required.\n" - - , commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " repl " - ++ " The first component in the package\n" - ++ " " ++ pname ++ " repl foo " - ++ " A named component (i.e. lib, exe, test suite)\n" - ++ " " ++ pname ++ " repl --repl-options=\"-lstdc++\"" - ++ " Specifying flags for interpreter\n" ---TODO: re-enable once we have support for module/file targets --- ++ " " ++ pname ++ " repl Foo.Bar " --- ++ " A module\n" --- ++ " " ++ pname ++ " repl Foo/Bar.hs" --- ++ " A file\n\n" --- ++ "If a target is ambiguous it can be qualified with the component " --- ++ "name, e.g.\n" --- ++ " " ++ pname ++ " repl foo:Foo.Bar\n" --- ++ " " ++ pname ++ " repl testsuite1:Foo/Bar.hs\n" - , commandUsage = \pname -> "Usage: " ++ pname ++ " repl [COMPONENT] [FLAGS]\n" - , commandDefaultFlags = defaultReplFlags - , commandOptions = \showOrParseArgs -> - optionVerbosity replVerbosity (\v flags -> flags { replVerbosity = v }) - : optionDistPref - replDistPref (\d flags -> flags { replDistPref = d }) - showOrParseArgs - - : programDbPaths progDb showOrParseArgs - replProgramPaths (\v flags -> flags { replProgramPaths = v}) - - ++ programDbOption progDb showOrParseArgs - replProgramArgs (\v flags -> flags { replProgramArgs = v}) - - ++ programDbOptions progDb showOrParseArgs - replProgramArgs (\v flags -> flags { replProgramArgs = v}) - - ++ case showOrParseArgs of - ParseArgs -> - [ option "" ["reload"] - "Used from within an interpreter to update files." - replReload (\v flags -> flags { replReload = v }) - trueArg - ] - _ -> [] - ++ map liftReplOption (replOptions showOrParseArgs) - } - where - liftReplOption = liftOption replReplOptions (\v flags -> flags { replReplOptions = v }) - -replOptions :: ShowOrParseArgs -> [OptionField [String]] -replOptions _ = [ option [] ["repl-options"] "use this option for the repl" id - const (reqArg "FLAG" (succeedReadE (:[])) id) ] - --- ------------------------------------------------------------ --- * Test flags --- ------------------------------------------------------------ - -data TestShowDetails = Never | Failures | Always | Streaming | Direct - deriving (Eq, Ord, Enum, Bounded, Generic, Show, Typeable) - -instance Binary TestShowDetails -instance Structured TestShowDetails - -knownTestShowDetails :: [TestShowDetails] -knownTestShowDetails = [minBound..maxBound] - -instance Pretty TestShowDetails where - pretty = Disp.text . lowercase . show - -instance Parsec TestShowDetails where - parsec = maybe (fail "invalid TestShowDetails") return . classify =<< ident - where - ident = P.munch1 (\c -> isAlpha c || c == '_' || c == '-') - classify str = lookup (lowercase str) enumMap - enumMap :: [(String, TestShowDetails)] - enumMap = [ (prettyShow x, x) - | x <- knownTestShowDetails ] - ---TODO: do we need this instance? -instance Monoid TestShowDetails where - mempty = Never - mappend = (<>) - -instance Semigroup TestShowDetails where - a <> b = if a < b then b else a - -data TestFlags = TestFlags { - testDistPref :: Flag FilePath, - testVerbosity :: Flag Verbosity, - testHumanLog :: Flag PathTemplate, - testMachineLog :: Flag PathTemplate, - testShowDetails :: Flag TestShowDetails, - testKeepTix :: Flag Bool, - testWrapper :: Flag FilePath, - testFailWhenNoTestSuites :: Flag Bool, - -- TODO: think about if/how options are passed to test exes - testOptions :: [PathTemplate] - } deriving (Show, Generic, Typeable) - -defaultTestFlags :: TestFlags -defaultTestFlags = TestFlags { - testDistPref = NoFlag, - testVerbosity = Flag normal, - testHumanLog = toFlag $ toPathTemplate $ "$pkgid-$test-suite.log", - testMachineLog = toFlag $ toPathTemplate $ "$pkgid.log", - testShowDetails = toFlag Failures, - testKeepTix = toFlag False, - testWrapper = NoFlag, - testFailWhenNoTestSuites = toFlag False, - testOptions = [] - } - -testCommand :: CommandUI TestFlags -testCommand = CommandUI - { commandName = "test" - , commandSynopsis = - "Run all/specific tests in the test suite." - , commandDescription = Just $ \pname -> wrapText $ - "If necessary (re)configures with `--enable-tests` flag and builds" - ++ " the test suite.\n" - ++ "\n" - ++ "Remember that the tests' dependencies must be installed if there" - ++ " are additional ones; e.g. with `" ++ pname - ++ " install --only-dependencies --enable-tests`.\n" - ++ "\n" - ++ "By defining UserHooks in a custom Setup.hs, the package can" - ++ " define actions to be executed before and after running tests.\n" - , commandNotes = Nothing - , commandUsage = usageAlternatives "test" - [ "[FLAGS]" - , "TESTCOMPONENTS [FLAGS]" - ] - , commandDefaultFlags = defaultTestFlags - , commandOptions = testOptions' - } - -testOptions' :: ShowOrParseArgs -> [OptionField TestFlags] -testOptions' showOrParseArgs = - [ optionVerbosity testVerbosity (\v flags -> flags { testVerbosity = v }) - , optionDistPref - testDistPref (\d flags -> flags { testDistPref = d }) - showOrParseArgs - , option [] ["log"] - ("Log all test suite results to file (name template can use " - ++ "$pkgid, $compiler, $os, $arch, $test-suite, $result)") - testHumanLog (\v flags -> flags { testHumanLog = v }) - (reqArg' "TEMPLATE" - (toFlag . toPathTemplate) - (flagToList . fmap fromPathTemplate)) - , option [] ["machine-log"] - ("Produce a machine-readable log file (name template can use " - ++ "$pkgid, $compiler, $os, $arch, $result)") - testMachineLog (\v flags -> flags { testMachineLog = v }) - (reqArg' "TEMPLATE" - (toFlag . toPathTemplate) - (flagToList . fmap fromPathTemplate)) - , option [] ["show-details"] - ("'always': always show results of individual test cases. " - ++ "'never': never show results of individual test cases. " - ++ "'failures': show results of failing test cases. " - ++ "'streaming': show results of test cases in real time." - ++ "'direct': send results of test cases in real time; no log file.") - testShowDetails (\v flags -> flags { testShowDetails = v }) - (reqArg "FILTER" - (parsecToReadE (\_ -> "--show-details flag expects one of " - ++ intercalate ", " - (map prettyShow knownTestShowDetails)) - (fmap toFlag parsec)) - (flagToList . fmap prettyShow)) - , option [] ["keep-tix-files"] - "keep .tix files for HPC between test runs" - testKeepTix (\v flags -> flags { testKeepTix = v}) - trueArg - , option [] ["test-wrapper"] - "Run test through a wrapper." - testWrapper (\v flags -> flags { testWrapper = v }) - (reqArg' "FILE" (toFlag :: FilePath -> Flag FilePath) - (flagToList :: Flag FilePath -> [FilePath])) - , option [] ["fail-when-no-test-suites"] - ("Exit with failure when no test suites are found.") - testFailWhenNoTestSuites (\v flags -> flags { testFailWhenNoTestSuites = v}) - trueArg - , option [] ["test-options"] - ("give extra options to test executables " - ++ "(name templates can use $pkgid, $compiler, " - ++ "$os, $arch, $test-suite)") - testOptions (\v flags -> flags { testOptions = v }) - (reqArg' "TEMPLATES" (map toPathTemplate . splitArgs) - (const [])) - , option [] ["test-option"] - ("give extra option to test executables " - ++ "(no need to quote options containing spaces, " - ++ "name template can use $pkgid, $compiler, " - ++ "$os, $arch, $test-suite)") - testOptions (\v flags -> flags { testOptions = v }) - (reqArg' "TEMPLATE" (\x -> [toPathTemplate x]) - (map fromPathTemplate)) - ] - -emptyTestFlags :: TestFlags -emptyTestFlags = mempty - -instance Monoid TestFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup TestFlags where - (<>) = gmappend - --- ------------------------------------------------------------ --- * Benchmark flags --- ------------------------------------------------------------ - -data BenchmarkFlags = BenchmarkFlags { - benchmarkDistPref :: Flag FilePath, - benchmarkVerbosity :: Flag Verbosity, - benchmarkOptions :: [PathTemplate] - } deriving (Show, Generic, Typeable) - -defaultBenchmarkFlags :: BenchmarkFlags -defaultBenchmarkFlags = BenchmarkFlags { - benchmarkDistPref = NoFlag, - benchmarkVerbosity = Flag normal, - benchmarkOptions = [] - } - -benchmarkCommand :: CommandUI BenchmarkFlags -benchmarkCommand = CommandUI - { commandName = "bench" - , commandSynopsis = - "Run all/specific benchmarks." - , commandDescription = Just $ \pname -> wrapText $ - "If necessary (re)configures with `--enable-benchmarks` flag and" - ++ " builds the benchmarks.\n" - ++ "\n" - ++ "Remember that the benchmarks' dependencies must be installed if" - ++ " there are additional ones; e.g. with `" ++ pname - ++ " install --only-dependencies --enable-benchmarks`.\n" - ++ "\n" - ++ "By defining UserHooks in a custom Setup.hs, the package can" - ++ " define actions to be executed before and after running" - ++ " benchmarks.\n" - , commandNotes = Nothing - , commandUsage = usageAlternatives "bench" - [ "[FLAGS]" - , "BENCHCOMPONENTS [FLAGS]" - ] - , commandDefaultFlags = defaultBenchmarkFlags - , commandOptions = benchmarkOptions' - } - -benchmarkOptions' :: ShowOrParseArgs -> [OptionField BenchmarkFlags] -benchmarkOptions' showOrParseArgs = - [ optionVerbosity benchmarkVerbosity - (\v flags -> flags { benchmarkVerbosity = v }) - , optionDistPref - benchmarkDistPref (\d flags -> flags { benchmarkDistPref = d }) - showOrParseArgs - , option [] ["benchmark-options"] - ("give extra options to benchmark executables " - ++ "(name templates can use $pkgid, $compiler, " - ++ "$os, $arch, $benchmark)") - benchmarkOptions (\v flags -> flags { benchmarkOptions = v }) - (reqArg' "TEMPLATES" (map toPathTemplate . splitArgs) - (const [])) - , option [] ["benchmark-option"] - ("give extra option to benchmark executables " - ++ "(no need to quote options containing spaces, " - ++ "name template can use $pkgid, $compiler, " - ++ "$os, $arch, $benchmark)") - benchmarkOptions (\v flags -> flags { benchmarkOptions = v }) - (reqArg' "TEMPLATE" (\x -> [toPathTemplate x]) - (map fromPathTemplate)) - ] - -emptyBenchmarkFlags :: BenchmarkFlags -emptyBenchmarkFlags = mempty - -instance Monoid BenchmarkFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup BenchmarkFlags where - (<>) = gmappend - --- ------------------------------------------------------------ --- * Shared options utils --- ------------------------------------------------------------ - -programFlagsDescription :: ProgramDb -> String -programFlagsDescription progDb = - "The flags --with-PROG and --PROG-option(s) can be used with" - ++ " the following programs:" - ++ (concatMap (\line -> "\n " ++ unwords line) . wrapLine 77 . sort) - [ programName prog | (prog, _) <- knownPrograms progDb ] - ++ "\n" - --- | For each known program @PROG@ in 'progDb', produce a @with-PROG@ --- 'OptionField'. -programDbPaths - :: ProgramDb - -> ShowOrParseArgs - -> (flags -> [(String, FilePath)]) - -> ([(String, FilePath)] -> (flags -> flags)) - -> [OptionField flags] -programDbPaths progDb showOrParseArgs get set = - programDbPaths' ("with-" ++) progDb showOrParseArgs get set - --- | Like 'programDbPaths', but allows to customise the option name. -programDbPaths' - :: (String -> String) - -> ProgramDb - -> ShowOrParseArgs - -> (flags -> [(String, FilePath)]) - -> ([(String, FilePath)] -> (flags -> flags)) - -> [OptionField flags] -programDbPaths' mkName progDb showOrParseArgs get set = - case showOrParseArgs of - -- we don't want a verbose help text list so we just show a generic one: - ShowArgs -> [withProgramPath "PROG"] - ParseArgs -> map (withProgramPath . programName . fst) - (knownPrograms progDb) - where - withProgramPath prog = - option "" [mkName prog] - ("give the path to " ++ prog) - get set - (reqArg' "PATH" (\path -> [(prog, path)]) - (\progPaths -> [ path | (prog', path) <- progPaths, prog==prog' ])) - --- | For each known program @PROG@ in 'progDb', produce a @PROG-option@ --- 'OptionField'. -programDbOption - :: ProgramDb - -> ShowOrParseArgs - -> (flags -> [(String, [String])]) - -> ([(String, [String])] -> (flags -> flags)) - -> [OptionField flags] -programDbOption progDb showOrParseArgs get set = - case showOrParseArgs of - -- we don't want a verbose help text list so we just show a generic one: - ShowArgs -> [programOption "PROG"] - ParseArgs -> map (programOption . programName . fst) - (knownPrograms progDb) - where - programOption prog = - option "" [prog ++ "-option"] - ("give an extra option to " ++ prog ++ - " (no need to quote options containing spaces)") - get set - (reqArg' "OPT" (\arg -> [(prog, [arg])]) - (\progArgs -> concat [ args - | (prog', args) <- progArgs, prog==prog' ])) - - --- | For each known program @PROG@ in 'progDb', produce a @PROG-options@ --- 'OptionField'. -programDbOptions - :: ProgramDb - -> ShowOrParseArgs - -> (flags -> [(String, [String])]) - -> ([(String, [String])] -> (flags -> flags)) - -> [OptionField flags] -programDbOptions progDb showOrParseArgs get set = - case showOrParseArgs of - -- we don't want a verbose help text list so we just show a generic one: - ShowArgs -> [programOptions "PROG"] - ParseArgs -> map (programOptions . programName . fst) - (knownPrograms progDb) - where - programOptions prog = - option "" [prog ++ "-options"] - ("give extra options to " ++ prog) - get set - (reqArg' "OPTS" (\args -> [(prog, splitArgs args)]) (const [])) - --- ------------------------------------------------------------ --- * GetOpt Utils --- ------------------------------------------------------------ - -boolOpt :: SFlags -> SFlags - -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a -boolOpt = Command.boolOpt flagToMaybe Flag - -boolOpt' :: OptFlags -> OptFlags - -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a -boolOpt' = Command.boolOpt' flagToMaybe Flag - -trueArg, falseArg :: MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a -trueArg sfT lfT = boolOpt' (sfT, lfT) ([], []) sfT lfT -falseArg sfF lfF = boolOpt' ([], []) (sfF, lfF) sfF lfF - -reqArgFlag :: ArgPlaceHolder -> SFlags -> LFlags -> Description -> - (b -> Flag String) -> (Flag String -> b -> b) -> OptDescr b -reqArgFlag ad = reqArg ad (succeedReadE Flag) flagToList - -optionDistPref :: (flags -> Flag FilePath) - -> (Flag FilePath -> flags -> flags) - -> ShowOrParseArgs - -> OptionField flags -optionDistPref get set = \showOrParseArgs -> - option "" (distPrefFlagName showOrParseArgs) - ( "The directory where Cabal puts generated build files " - ++ "(default " ++ defaultDistPref ++ ")") - get set - (reqArgFlag "DIR") - where - distPrefFlagName ShowArgs = ["builddir"] - distPrefFlagName ParseArgs = ["builddir", "distdir", "distpref"] - -optionVerbosity :: (flags -> Flag Verbosity) - -> (Flag Verbosity -> flags -> flags) - -> OptionField flags -optionVerbosity get set = - option "v" ["verbose"] - "Control verbosity (n is 0--3, default verbosity level is 1)" - get set - (optArg "n" (fmap Flag flagToVerbosity) - (Flag verbose) -- default Value if no n is given - (fmap (Just . showForCabal) . flagToList)) - -optionNumJobs :: (flags -> Flag (Maybe Int)) - -> (Flag (Maybe Int) -> flags -> flags) - -> OptionField flags -optionNumJobs get set = - option "j" ["jobs"] - "Run NUM jobs simultaneously (or '$ncpus' if no NUM is given)." - get set - (optArg "NUM" (fmap Flag numJobsParser) - (Flag Nothing) - (map (Just . maybe "$ncpus" show) . flagToList)) - where - numJobsParser :: ReadE (Maybe Int) - numJobsParser = ReadE $ \s -> - case s of - "$ncpus" -> Right Nothing - _ -> case reads s of - [(n, "")] - | n < 1 -> Left "The number of jobs should be 1 or more." - | otherwise -> Right (Just n) - _ -> Left "The jobs value should be a number or '$ncpus'" - - --- ------------------------------------------------------------ --- * show-build-info command flags --- ------------------------------------------------------------ - -data ShowBuildInfoFlags = ShowBuildInfoFlags - { buildInfoBuildFlags :: BuildFlags - , buildInfoOutputFile :: Maybe FilePath - } deriving (Show, Typeable) - -defaultShowBuildFlags :: ShowBuildInfoFlags -defaultShowBuildFlags = - ShowBuildInfoFlags - { buildInfoBuildFlags = defaultBuildFlags - , buildInfoOutputFile = Nothing - } - -showBuildInfoCommand :: ProgramDb -> CommandUI ShowBuildInfoFlags -showBuildInfoCommand progDb = CommandUI - { commandName = "show-build-info" - , commandSynopsis = "Emit details about how a package would be built." - , commandDescription = Just $ \_ -> wrapText $ - "Components encompass executables, tests, and benchmarks.\n" - ++ "\n" - ++ "Affected by configuration options, see `configure`.\n" - , commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " show-build-info " - ++ " All the components in the package\n" - ++ " " ++ pname ++ " show-build-info foo " - ++ " A component (i.e. lib, exe, test suite)\n\n" - ++ programFlagsDescription progDb ---TODO: re-enable once we have support for module/file targets --- ++ " " ++ pname ++ " show-build-info Foo.Bar " --- ++ " A module\n" --- ++ " " ++ pname ++ " show-build-info Foo/Bar.hs" --- ++ " A file\n\n" --- ++ "If a target is ambiguous it can be qualified with the component " --- ++ "name, e.g.\n" --- ++ " " ++ pname ++ " show-build-info foo:Foo.Bar\n" --- ++ " " ++ pname ++ " show-build-info testsuite1:Foo/Bar.hs\n" - , commandUsage = usageAlternatives "show-build-info" $ - [ "[FLAGS]" - , "COMPONENTS [FLAGS]" - ] - , commandDefaultFlags = defaultShowBuildFlags - , commandOptions = \showOrParseArgs -> - parseBuildFlagsForShowBuildInfoFlags showOrParseArgs progDb - ++ - [ option [] ["buildinfo-json-output"] - "Write the result to the given file instead of stdout" - buildInfoOutputFile (\pf flags -> flags { buildInfoOutputFile = pf }) - (reqArg' "FILE" Just (maybe [] pure)) - ] - - } - -parseBuildFlagsForShowBuildInfoFlags :: ShowOrParseArgs -> ProgramDb -> [OptionField ShowBuildInfoFlags] -parseBuildFlagsForShowBuildInfoFlags showOrParseArgs progDb = - map - (liftOption - buildInfoBuildFlags - (\bf flags -> flags { buildInfoBuildFlags = bf } ) - ) - buildFlags - where - buildFlags = buildOptions progDb showOrParseArgs - ++ - [ optionVerbosity - buildVerbosity (\v flags -> flags { buildVerbosity = v }) - - , optionDistPref - buildDistPref (\d flags -> flags { buildDistPref = d }) showOrParseArgs - ] - --- ------------------------------------------------------------ --- * Other Utils --- ------------------------------------------------------------ - --- | Arguments to pass to a @configure@ script, e.g. generated by --- @autoconf@. -configureArgs :: Bool -> ConfigFlags -> [String] -configureArgs bcHack flags - = hc_flag - ++ optFlag "with-hc-pkg" configHcPkg - ++ optFlag' "prefix" prefix - ++ optFlag' "bindir" bindir - ++ optFlag' "libdir" libdir - ++ optFlag' "libexecdir" libexecdir - ++ optFlag' "datadir" datadir - ++ optFlag' "sysconfdir" sysconfdir - ++ configConfigureArgs flags - where - hc_flag = case (configHcFlavor flags, configHcPath flags) of - (_, Flag hc_path) -> [hc_flag_name ++ hc_path] - (Flag hc, NoFlag) -> [hc_flag_name ++ prettyShow hc] - (NoFlag,NoFlag) -> [] - hc_flag_name - --TODO kill off thic bc hack when defaultUserHooks is removed. - | bcHack = "--with-hc=" - | otherwise = "--with-compiler=" - optFlag name config_field = case config_field flags of - Flag p -> ["--" ++ name ++ "=" ++ p] - NoFlag -> [] - optFlag' name config_field = optFlag name (fmap fromPathTemplate - . config_field - . configInstallDirs) - -configureCCompiler :: Verbosity -> ProgramDb - -> IO (FilePath, [String]) -configureCCompiler verbosity progdb = configureProg verbosity progdb gccProgram - -configureLinker :: Verbosity -> ProgramDb -> IO (FilePath, [String]) -configureLinker verbosity progdb = configureProg verbosity progdb ldProgram - -configureProg :: Verbosity -> ProgramDb -> Program - -> IO (FilePath, [String]) -configureProg verbosity programDb prog = do - (p, _) <- requireProgram verbosity prog programDb - let pInv = programInvocation p [] - return (progInvokePath pInv, progInvokeArgs pInv) - --- | Helper function to split a string into a list of arguments. --- It's supposed to handle quoted things sensibly, eg: --- --- > splitArgs "--foo=\"C:/Program Files/Bar/" --baz" --- > = ["--foo=C:/Program Files/Bar", "--baz"] --- --- > splitArgs "\"-DMSGSTR=\\\"foo bar\\\"\" --baz" --- > = ["-DMSGSTR=\"foo bar\"","--baz"] --- -splitArgs :: String -> [String] -splitArgs = space [] - where - space :: String -> String -> [String] - space w [] = word w [] - space w ( c :s) - | isSpace c = word w (space [] s) - space w ('"':s) = string w s - space w s = nonstring w s - - string :: String -> String -> [String] - string w [] = word w [] - string w ('"':s) = space w s - string w ('\\':'"':s) = string ('"':w) s - string w ( c :s) = string (c:w) s - - nonstring :: String -> String -> [String] - nonstring w [] = word w [] - nonstring w ('"':s) = string w s - nonstring w ( c :s) = space (c:w) s - - word [] s = s - word w s = reverse w : s - --- The test cases kinda have to be rewritten from the ground up... :/ ---hunitTests :: [Test] ---hunitTests = --- let m = [("ghc", GHC), ("nhc98", NHC), ("hugs", Hugs)] --- (flags, commands', unkFlags, ers) --- = getOpt Permute options ["configure", "foobar", "--prefix=/foo", "--ghc", "--nhc98", "--hugs", "--with-compiler=/comp", "--unknown1", "--unknown2", "--install-prefix=/foo", "--user", "--global"] --- in [TestLabel "very basic option parsing" $ TestList [ --- "getOpt flags" ~: "failed" ~: --- [Prefix "/foo", GhcFlag, NhcFlag, HugsFlag, --- WithCompiler "/comp", InstPrefix "/foo", UserFlag, GlobalFlag] --- ~=? flags, --- "getOpt commands" ~: "failed" ~: ["configure", "foobar"] ~=? commands', --- "getOpt unknown opts" ~: "failed" ~: --- ["--unknown1", "--unknown2"] ~=? unkFlags, --- "getOpt errors" ~: "failed" ~: [] ~=? ers], --- --- TestLabel "test location of various compilers" $ TestList --- ["configure parsing for prefix and compiler flag" ~: "failed" ~: --- (Right (ConfigCmd (Just comp, Nothing, Just "/usr/local"), [])) --- ~=? (parseArgs ["--prefix=/usr/local", "--"++name, "configure"]) --- | (name, comp) <- m], --- --- TestLabel "find the package tool" $ TestList --- ["configure parsing for prefix comp flag, withcompiler" ~: "failed" ~: --- (Right (ConfigCmd (Just comp, Just "/foo/comp", Just "/usr/local"), [])) --- ~=? (parseArgs ["--prefix=/usr/local", "--"++name, --- "--with-compiler=/foo/comp", "configure"]) --- | (name, comp) <- m], --- --- TestLabel "simpler commands" $ TestList --- [flag ~: "failed" ~: (Right (flagCmd, [])) ~=? (parseArgs [flag]) --- | (flag, flagCmd) <- [("build", BuildCmd), --- ("install", InstallCmd Nothing False), --- ("sdist", SDistCmd), --- ("register", RegisterCmd False)] --- ] --- ] - -{- Testing ideas: - * IO to look for hugs and hugs-pkg (which hugs, etc) - * quickCheck to test permutations of arguments - * what other options can we over-ride with a command-line flag? --} diff --git a/cabal/Cabal/Distribution/Simple/ShowBuildInfo.hs b/cabal/Cabal/Distribution/Simple/ShowBuildInfo.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/ShowBuildInfo.hs +++ /dev/null @@ -1,161 +0,0 @@ --- | --- This module defines a simple JSON-based format for exporting basic --- information about a Cabal package and the compiler configuration Cabal --- would use to build it. This can be produced with the --- @cabal new-show-build-info@ command. --- --- --- This format is intended for consumption by external tooling and should --- therefore be rather stable. Moreover, this allows tooling users to avoid --- linking against Cabal. This is an important advantage as direct API usage --- tends to be rather fragile in the presence of user-initiated upgrades of --- Cabal. --- --- Below is an example of the output this module produces, --- --- @ --- { "cabal-version": "1.23.0.0", --- "compiler": { --- "flavour": "GHC", --- "compiler-id": "ghc-7.10.2", --- "path": "/usr/bin/ghc", --- }, --- "components": [ --- { "type": "lib", --- "name": "lib:Cabal", --- "compiler-args": --- ["-O", "-XHaskell98", "-Wall", --- "-package-id", "parallel-3.2.0.6-b79c38c5c25fff77f3ea7271851879eb"] --- "modules": ["Project.ModA", "Project.ModB", "Paths_project"], --- "src-files": [], --- "src-dirs": ["src"] --- } --- ] --- } --- @ --- --- The @cabal-version@ property provides the version of the Cabal library --- which generated the output. The @compiler@ property gives some basic --- information about the compiler Cabal would use to compile the package. --- --- The @components@ property gives a list of the Cabal 'Component's defined by --- the package. Each has, --- --- * @type@: the type of the component (one of @lib@, @exe@, --- @test@, @bench@, or @flib@) --- * @name@: a string serving to uniquely identify the component within the --- package. --- * @compiler-args@: the command-line arguments Cabal would pass to the --- compiler to compile the component --- * @modules@: the modules belonging to the component --- * @src-dirs@: a list of directories where the modules might be found --- * @src-files@: any other Haskell sources needed by the component --- --- Note: At the moment this is only supported when using the GHC compiler. --- - -module Distribution.Simple.ShowBuildInfo (mkBuildInfo) where - -import Distribution.Compat.Prelude -import Prelude () - -import qualified Distribution.Simple.GHC as GHC -import qualified Distribution.Simple.Program.GHC as GHC - -import Distribution.PackageDescription -import Distribution.Compiler -import Distribution.Verbosity -import Distribution.Simple.Compiler -import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.Program -import Distribution.Simple.Setup -import Distribution.Simple.Utils (cabalVersion) -import Distribution.Simple.Utils.Json -import Distribution.Types.TargetInfo -import Distribution.Text -import Distribution.Pretty - --- | Construct a JSON document describing the build information for a --- package. -mkBuildInfo - :: PackageDescription -- ^ Mostly information from the .cabal file - -> LocalBuildInfo -- ^ Configuration information - -> BuildFlags -- ^ Flags that the user passed to build - -> [TargetInfo] - -> Json -mkBuildInfo pkg_descr lbi _flags targetsToBuild = info - where - targetToNameAndLBI target = - (componentLocalName $ targetCLBI target, targetCLBI target) - componentsToBuild = map targetToNameAndLBI targetsToBuild - (.=) :: String -> Json -> (String, Json) - k .= v = (k, v) - - info = JsonObject - [ "cabal-version" .= JsonString (display cabalVersion) - , "compiler" .= mkCompilerInfo - , "components" .= JsonArray (map mkComponentInfo componentsToBuild) - ] - - mkCompilerInfo = JsonObject - [ "flavour" .= JsonString (prettyShow $ compilerFlavor $ compiler lbi) - , "compiler-id" .= JsonString (showCompilerId $ compiler lbi) - , "path" .= path - ] - where - path = maybe JsonNull (JsonString . programPath) - $ (flavorToProgram . compilerFlavor $ compiler lbi) - >>= flip lookupProgram (withPrograms lbi) - - flavorToProgram :: CompilerFlavor -> Maybe Program - flavorToProgram GHC = Just ghcProgram - flavorToProgram GHCJS = Just ghcjsProgram - flavorToProgram UHC = Just uhcProgram - flavorToProgram JHC = Just jhcProgram - flavorToProgram _ = Nothing - - mkComponentInfo (name, clbi) = JsonObject - [ "type" .= JsonString compType - , "name" .= JsonString (prettyShow name) - , "unit-id" .= JsonString (prettyShow $ componentUnitId clbi) - , "compiler-args" .= JsonArray (map JsonString $ getCompilerArgs bi lbi clbi) - , "modules" .= JsonArray (map (JsonString . display) modules) - , "src-files" .= JsonArray (map JsonString sourceFiles) - , "src-dirs" .= JsonArray (map JsonString $ hsSourceDirs bi) - ] - where - bi = componentBuildInfo comp - comp = fromMaybe (error $ "mkBuildInfo: no component " ++ prettyShow name) $ lookupComponent pkg_descr name - compType = case comp of - CLib _ -> "lib" - CExe _ -> "exe" - CTest _ -> "test" - CBench _ -> "bench" - CFLib _ -> "flib" - modules = case comp of - CLib lib -> explicitLibModules lib - CExe exe -> exeModules exe - _ -> [] - sourceFiles = case comp of - CLib _ -> [] - CExe exe -> [modulePath exe] - _ -> [] - --- | Get the command-line arguments that would be passed --- to the compiler to build the given component. -getCompilerArgs - :: BuildInfo - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> [String] -getCompilerArgs bi lbi clbi = - case compilerFlavor $ compiler lbi of - GHC -> ghc - GHCJS -> ghc - c -> error $ "ShowBuildInfo.getCompilerArgs: Don't know how to get "++ - "build arguments for compiler "++show c - where - -- This is absolutely awful - ghc = GHC.renderGhcOptions (compiler lbi) (hostPlatform lbi) baseOpts - where - baseOpts = GHC.componentGhcOptions normal lbi bi clbi (buildDir lbi) diff --git a/cabal/Cabal/Distribution/Simple/SrcDist.hs b/cabal/Cabal/Distribution/Simple/SrcDist.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/SrcDist.hs +++ /dev/null @@ -1,519 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.SrcDist --- Copyright : Simon Marlow 2004 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This handles the @sdist@ command. The module exports an 'sdist' action but --- also some of the phases that make it up so that other tools can use just the --- bits they need. In particular the preparation of the tree of files to go --- into the source tarball is separated from actually building the source --- tarball. --- --- The 'createArchive' action uses the external @tar@ program and assumes that --- it accepts the @-z@ flag. Neither of these assumptions are valid on Windows. --- The 'sdist' action now also does some distribution QA checks. - --- NOTE: FIX: we don't have a great way of testing this module, since --- we can't easily look inside a tarball once its created. - -module Distribution.Simple.SrcDist ( - -- * The top level action - sdist, - - -- ** Parts of 'sdist' - printPackageProblems, - prepareTree, - createArchive, - - -- ** Snapshots - prepareSnapshotTree, - snapshotPackage, - snapshotVersion, - dateToSnapshotNumber, - - -- * Extracting the source files - listPackageSources, - listPackageSourcesWithDie, - - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.PackageDescription -import Distribution.PackageDescription.Check hiding (doesFileExist) -import Distribution.Package -import Distribution.ModuleName -import qualified Distribution.ModuleName as ModuleName -import Distribution.Version -import Distribution.Simple.Configure (findDistPrefOrDefault) -import Distribution.Simple.Glob -import Distribution.Simple.Utils -import Distribution.Simple.Setup -import Distribution.Simple.PreProcess -import Distribution.Simple.BuildPaths -import Distribution.Simple.Program -import Distribution.Pretty -import Distribution.Verbosity - -import qualified Data.Map as Map -import Data.Time (UTCTime, getCurrentTime, toGregorian, utctDay) -import System.Directory ( doesFileExist ) -import System.IO (IOMode(WriteMode), hPutStrLn, withFile) -import System.FilePath ((), (<.>), dropExtension, isRelative) - --- |Create a source distribution. -sdist :: PackageDescription -- ^ information from the tarball - -> SDistFlags -- ^ verbosity & snapshot - -> (FilePath -> FilePath) -- ^ build prefix (temp dir) - -> [PPSuffixHandler] -- ^ extra preprocessors (includes suffixes) - -> IO () -sdist pkg flags mkTmpDir pps = do - - distPref <- findDistPrefOrDefault $ sDistDistPref flags - let targetPref = distPref - tmpTargetDir = mkTmpDir distPref - - -- When given --list-sources, just output the list of sources to a file. - case sDistListSources flags of - Flag path -> withFile path WriteMode $ \outHandle -> do - ordinary <- listPackageSources verbosity "." pkg pps - traverse_ (hPutStrLn outHandle) ordinary - notice verbosity $ "List of package sources written to file '" ++ path ++ "'" - - NoFlag -> do - -- do some QA - printPackageProblems verbosity pkg - - date <- getCurrentTime - let pkg' | snapshot = snapshotPackage date pkg - | otherwise = pkg - - case flagToMaybe (sDistDirectory flags) of - Just targetDir -> do - generateSourceDir targetDir pkg' - info verbosity $ "Source directory created: " ++ targetDir - - Nothing -> do - createDirectoryIfMissingVerbose verbosity True tmpTargetDir - withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do - let targetDir = tmpDir tarBallName pkg' - generateSourceDir targetDir pkg' - targzFile <- createArchive verbosity pkg' tmpDir targetPref - notice verbosity $ "Source tarball created: " ++ targzFile - - where - generateSourceDir :: FilePath -> PackageDescription -> IO () - generateSourceDir targetDir pkg' = do - setupMessage verbosity "Building source dist for" (packageId pkg') - prepareTree verbosity pkg' targetDir pps - when snapshot $ - overwriteSnapshotPackageDesc verbosity pkg' targetDir - - verbosity = fromFlag (sDistVerbosity flags) - snapshot = fromFlag (sDistSnapshot flags) - --- | List all source files of a package. --- --- Since @Cabal-3.4@ returns a single list. There shouldn't be any --- executable files, they are hardly portable. --- -listPackageSources - :: Verbosity -- ^ verbosity - -> FilePath -- ^ directory with cabal file - -> PackageDescription -- ^ info from the cabal file - -> [PPSuffixHandler] -- ^ extra preprocessors (include suffixes) - -> IO [FilePath] -- ^ relative paths -listPackageSources verbosity cwd pkg_descr0 pps = do - -- Call helpers that actually do all work. - listPackageSources' verbosity die' cwd pkg_descr pps - where - pkg_descr = filterAutogenModules pkg_descr0 - --- | A variant of 'listPackageSources' with configurable 'die'. --- --- /Note:/ may still 'die' directly. For example on missing include file. --- --- Since @3.4.0.0 -listPackageSourcesWithDie - :: Verbosity -- ^ verbosity - -> (Verbosity -> String -> IO [FilePath]) -- ^ 'die'' alternative - -> FilePath -- ^ directory with cabal file - -> PackageDescription -- ^ info from the cabal file - -> [PPSuffixHandler] -- ^ extra preprocessors (include suffixes) - -> IO [FilePath] -- ^ relative paths -listPackageSourcesWithDie verbosity rip cwd pkg_descr0 pps = do - -- Call helpers that actually do all work. - listPackageSources' verbosity rip cwd pkg_descr pps - where - pkg_descr = filterAutogenModules pkg_descr0 - - -listPackageSources' - :: Verbosity - -> (Verbosity -> String -> IO [FilePath]) - -> FilePath - -> PackageDescription - -> [PPSuffixHandler] - -> IO [FilePath] -listPackageSources' verbosity rip cwd pkg_descr pps = - fmap concat . sequenceA $ - [ - -- Library sources. - fmap concat - . withAllLib $ \Library { - exposedModules = modules, - signatures = sigs, - libBuildInfo = libBi - } -> - allSourcesBuildInfo verbosity rip cwd libBi pps (modules ++ sigs) - - -- Executables sources. - , fmap concat - . withAllExe $ \Executable { modulePath = mainPath, buildInfo = exeBi } -> do - biSrcs <- allSourcesBuildInfo verbosity rip cwd exeBi pps [] - mainSrc <- findMainExeFile verbosity cwd exeBi pps mainPath - return (mainSrc:biSrcs) - - -- Foreign library sources - , fmap concat - . withAllFLib $ \flib@(ForeignLib { foreignLibBuildInfo = flibBi }) -> do - biSrcs <- allSourcesBuildInfo verbosity rip cwd flibBi pps [] - defFiles <- traverse (findModDefFile verbosity cwd flibBi pps) - (foreignLibModDefFile flib) - return (defFiles ++ biSrcs) - - -- Test suites sources. - , fmap concat - . withAllTest $ \t -> do - let bi = testBuildInfo t - case testInterface t of - TestSuiteExeV10 _ mainPath -> do - biSrcs <- allSourcesBuildInfo verbosity rip cwd bi pps [] - srcMainFile <- findMainExeFile verbosity cwd bi pps mainPath - return (srcMainFile:biSrcs) - TestSuiteLibV09 _ m -> - allSourcesBuildInfo verbosity rip cwd bi pps [m] - TestSuiteUnsupported tp -> - rip verbosity $ "Unsupported test suite type: " ++ show tp - - -- Benchmarks sources. - , fmap concat - . withAllBenchmark $ \bm -> do - let bi = benchmarkBuildInfo bm - case benchmarkInterface bm of - BenchmarkExeV10 _ mainPath -> do - biSrcs <- allSourcesBuildInfo verbosity rip cwd bi pps [] - srcMainFile <- findMainExeFile verbosity cwd bi pps mainPath - return (srcMainFile:biSrcs) - BenchmarkUnsupported tp -> - rip verbosity $ "Unsupported benchmark type: " ++ show tp - - -- Data files. - , fmap concat - . for (dataFiles pkg_descr) $ \filename -> - let srcDataDirRaw = dataDir pkg_descr - srcDataDir = if null srcDataDirRaw - then "." - else srcDataDirRaw - in fmap (fmap (\p -> srcDataDir p)) $ - matchDirFileGlob verbosity (specVersion pkg_descr) srcDataDir filename - - -- Extra source files. - , fmap concat . for (extraSrcFiles pkg_descr) $ \fpath -> - matchDirFileGlob verbosity (specVersion pkg_descr) cwd fpath - - -- Extra doc files. - , fmap concat - . for (extraDocFiles pkg_descr) $ \ filename -> - matchDirFileGlob verbosity (specVersion pkg_descr) cwd filename - - -- License file(s). - , return (licenseFiles pkg_descr) - - -- Install-include files, without autogen-include files - , fmap concat - . withAllLib $ \ l -> do - let lbi = libBuildInfo l - incls = filter (`notElem` autogenIncludes lbi) (installIncludes lbi) - relincdirs = "." : filter isRelative (includeDirs lbi) - traverse (fmap snd . findIncludeFile verbosity cwd relincdirs) incls - - -- Setup script, if it exists. - , fmap (maybe [] (\f -> [f])) $ findSetupFile cwd - - -- The .cabal file itself. - , fmap (\d -> [d]) (tryFindPackageDescCwd verbosity cwd ".") - - ] - where - -- We have to deal with all libs and executables, so we have local - -- versions of these functions that ignore the 'buildable' attribute: - withAllLib action = traverse action (allLibraries pkg_descr) - withAllFLib action = traverse action (foreignLibs pkg_descr) - withAllExe action = traverse action (executables pkg_descr) - withAllTest action = traverse action (testSuites pkg_descr) - withAllBenchmark action = traverse action (benchmarks pkg_descr) - - --- |Prepare a directory tree of source files. -prepareTree :: Verbosity -- ^verbosity - -> PackageDescription -- ^info from the cabal file - -> FilePath -- ^source tree to populate - -> [PPSuffixHandler] -- ^extra preprocessors (includes suffixes) - -> IO () -prepareTree verbosity pkg_descr0 targetDir pps = do - ordinary <- listPackageSources verbosity "." pkg_descr pps - installOrdinaryFiles verbosity targetDir (zip (repeat []) ordinary) - maybeCreateDefaultSetupScript targetDir - where - pkg_descr = filterAutogenModules pkg_descr0 - --- | Find the setup script file, if it exists. -findSetupFile :: FilePath -> IO (Maybe FilePath) -findSetupFile targetDir = do - hsExists <- doesFileExist (targetDir setupHs) - lhsExists <- doesFileExist (targetDir setupLhs) - if hsExists - then return (Just setupHs) - else if lhsExists - then return (Just setupLhs) - else return Nothing - where - setupHs = "Setup.hs" - setupLhs = "Setup.lhs" - --- | Create a default setup script in the target directory, if it doesn't exist. -maybeCreateDefaultSetupScript :: FilePath -> IO () -maybeCreateDefaultSetupScript targetDir = do - mSetupFile <- findSetupFile targetDir - case mSetupFile of - Just _setupFile -> return () - Nothing -> do - writeUTF8File (targetDir "Setup.hs") $ unlines [ - "import Distribution.Simple", - "main = defaultMain"] - --- | Find the main executable file. -findMainExeFile - :: Verbosity - -> FilePath -- ^ cwd - -> BuildInfo - -> [PPSuffixHandler] - -> FilePath -- ^ main-is - -> IO FilePath -findMainExeFile verbosity cwd exeBi pps mainPath = do - ppFile <- findFileCwdWithExtension cwd (ppSuffixes pps) (hsSourceDirs exeBi) - (dropExtension mainPath) - case ppFile of - Nothing -> findFileCwd verbosity cwd (hsSourceDirs exeBi) mainPath - Just pp -> return pp - --- | Find a module definition file --- --- TODO: I don't know if this is right -findModDefFile - :: Verbosity -> FilePath -> BuildInfo -> [PPSuffixHandler] -> FilePath -> IO FilePath -findModDefFile verbosity cwd flibBi _pps modDefPath = - findFileCwd verbosity cwd (".":hsSourceDirs flibBi) modDefPath - --- | Given a list of include paths, try to find the include file named --- @f@. Return the name of the file and the full path, or exit with error if --- there's no such file. -findIncludeFile :: Verbosity -> FilePath -> [FilePath] -> String -> IO (String, FilePath) -findIncludeFile verbosity _ [] f = die' verbosity ("can't find include file " ++ f) -findIncludeFile verbosity cwd (d:ds) f = do - let path = (d f) - b <- doesFileExist (cwd path) - if b then return (f,path) else findIncludeFile verbosity cwd ds f - --- | Remove the auto-generated modules (like 'Paths_*') from 'exposed-modules' --- and 'other-modules'. -filterAutogenModules :: PackageDescription -> PackageDescription -filterAutogenModules pkg_descr0 = mapLib filterAutogenModuleLib $ - mapAllBuildInfo filterAutogenModuleBI pkg_descr0 - where - mapLib f pkg = pkg { library = fmap f (library pkg) - , subLibraries = map f (subLibraries pkg) } - filterAutogenModuleLib lib = lib { - exposedModules = filter (filterFunction (libBuildInfo lib)) (exposedModules lib) - } - filterAutogenModuleBI bi = bi { - otherModules = filter (filterFunction bi) (otherModules bi) - } - pathsModule = autogenPathsModuleName pkg_descr0 - filterFunction bi = \mn -> - mn /= pathsModule - && not (mn `elem` autogenModules bi) - --- | Prepare a directory tree of source files for a snapshot version. --- It is expected that the appropriate snapshot version has already been set --- in the package description, eg using 'snapshotPackage' or 'snapshotVersion'. --- -prepareSnapshotTree - :: Verbosity -- ^verbosity - -> PackageDescription -- ^info from the cabal file - -> FilePath -- ^source tree to populate - -> [PPSuffixHandler] -- ^extra preprocessors (includes suffixes) - -> IO () -prepareSnapshotTree verbosity pkg targetDir pps = do - prepareTree verbosity pkg targetDir pps - overwriteSnapshotPackageDesc verbosity pkg targetDir - -overwriteSnapshotPackageDesc :: Verbosity -- ^verbosity - -> PackageDescription -- ^info from the cabal file - -> FilePath -- ^source tree - -> IO () -overwriteSnapshotPackageDesc verbosity pkg targetDir = do - -- We could just writePackageDescription targetDescFile pkg_descr, - -- but that would lose comments and formatting. - descFile <- defaultPackageDesc verbosity - withUTF8FileContents descFile $ - writeUTF8File (targetDir descFile) - . unlines . map (replaceVersion (packageVersion pkg)) . lines - - where - replaceVersion :: Version -> String -> String - replaceVersion version line - | "version:" `isPrefixOf` map toLower line - = "version: " ++ prettyShow version - | otherwise = line - --- | Modifies a 'PackageDescription' by appending a snapshot number --- corresponding to the given date. --- -snapshotPackage :: UTCTime -> PackageDescription -> PackageDescription -snapshotPackage date pkg = - pkg { - package = pkgid { pkgVersion = snapshotVersion date (pkgVersion pkgid) } - } - where pkgid = packageId pkg - --- | Modifies a 'Version' by appending a snapshot number corresponding --- to the given date. --- -snapshotVersion :: UTCTime -> Version -> Version -snapshotVersion date = alterVersion (++ [dateToSnapshotNumber date]) - --- | Given a date produce a corresponding integer representation. --- For example given a date @18/03/2008@ produce the number @20080318@. --- -dateToSnapshotNumber :: UTCTime -> Int -dateToSnapshotNumber date = case toGregorian (utctDay date) of - (year, month, day) -> - fromIntegral year * 10000 - + month * 100 - + day - --- | Create an archive from a tree of source files, and clean up the tree. -createArchive - :: Verbosity -- ^ verbosity - -> PackageDescription -- ^ info from cabal file - -> FilePath -- ^ source tree to archive - -> FilePath -- ^ name of archive to create - -> IO FilePath -createArchive verbosity pkg_descr tmpDir targetPref = do - let tarBallFilePath = targetPref tarBallName pkg_descr <.> "tar.gz" - (tarProg, _) <- requireProgram verbosity tarProgram defaultProgramDb - let formatOptSupported = maybe False (== "YES") $ - Map.lookup "Supports --format" - (programProperties tarProg) - runProgram verbosity tarProg $ - -- Hmm: I could well be skating on thinner ice here by using the -C option - -- (=> seems to be supported at least by GNU and *BSD tar) [The - -- prev. solution used pipes and sub-command sequences to set up the paths - -- correctly, which is problematic in a Windows setting.] - ["-czf", tarBallFilePath, "-C", tmpDir] - ++ (if formatOptSupported then ["--format", "ustar"] else []) - ++ [tarBallName pkg_descr] - return tarBallFilePath - --- | Given a buildinfo, return the names of all source files. -allSourcesBuildInfo - :: Verbosity - -> (Verbosity -> String -> IO [FilePath]) - -> FilePath -- ^ cwd - -> BuildInfo - -> [PPSuffixHandler] -- ^ Extra preprocessors - -> [ModuleName] -- ^ Exposed modules - -> IO [FilePath] -allSourcesBuildInfo verbosity rip cwd bi pps modules = do - let searchDirs = hsSourceDirs bi - sources <- fmap concat $ sequenceA $ - [ let file = ModuleName.toFilePath module_ - -- NB: *Not* findFileWithExtension, because the same source - -- file may show up in multiple paths due to a conditional; - -- we need to package all of them. See #367. - in findAllFilesCwdWithExtension cwd suffixes searchDirs file - >>= nonEmpty (notFound module_) return - | module_ <- modules ++ otherModules bi ] - bootFiles <- sequenceA - [ let file = ModuleName.toFilePath module_ - fileExts = ["hs-boot", "lhs-boot"] - in findFileCwdWithExtension cwd fileExts (hsSourceDirs bi) file - | module_ <- modules ++ otherModules bi ] - - return $ sources ++ catMaybes bootFiles ++ cSources bi ++ cxxSources bi ++ - cmmSources bi ++ asmSources bi ++ jsSources bi - - where - nonEmpty x _ [] = x - nonEmpty _ f xs = f xs - suffixes = ppSuffixes pps ++ ["hs", "lhs", "hsig", "lhsig"] - - notFound :: ModuleName -> IO [FilePath] - notFound m = rip verbosity $ "Error: Could not find module: " ++ prettyShow m - ++ " with any suffix: " ++ show suffixes ++ ". If the module " - ++ "is autogenerated it should be added to 'autogen-modules'." - - --- | Note: must be called with the CWD set to the directory containing --- the '.cabal' file. -printPackageProblems :: Verbosity -> PackageDescription -> IO () -printPackageProblems verbosity pkg_descr = do - ioChecks <- checkPackageFiles verbosity pkg_descr "." - let pureChecks = checkConfiguredPackage pkg_descr - isDistError (PackageDistSuspicious _) = False - isDistError (PackageDistSuspiciousWarn _) = False - isDistError _ = True - (errors, warnings) = partition isDistError (pureChecks ++ ioChecks) - unless (null errors) $ - notice verbosity $ "Distribution quality errors:\n" - ++ unlines (map explanation errors) - unless (null warnings) $ - notice verbosity $ "Distribution quality warnings:\n" - ++ unlines (map explanation warnings) - unless (null errors) $ - notice verbosity - "Note: the public hackage server would reject this package." - ------------------------------------------------------------- - --- | The name of the tarball without extension --- -tarBallName :: PackageDescription -> String -tarBallName = prettyShow . packageId - -mapAllBuildInfo :: (BuildInfo -> BuildInfo) - -> (PackageDescription -> PackageDescription) -mapAllBuildInfo f pkg = pkg { - library = fmap mapLibBi (library pkg), - subLibraries = fmap mapLibBi (subLibraries pkg), - foreignLibs = fmap mapFLibBi (foreignLibs pkg), - executables = fmap mapExeBi (executables pkg), - testSuites = fmap mapTestBi (testSuites pkg), - benchmarks = fmap mapBenchBi (benchmarks pkg) - } - where - mapLibBi lib = lib { libBuildInfo = f (libBuildInfo lib) } - mapFLibBi flib = flib { foreignLibBuildInfo = f (foreignLibBuildInfo flib) } - mapExeBi exe = exe { buildInfo = f (buildInfo exe) } - mapTestBi tst = tst { testBuildInfo = f (testBuildInfo tst) } - mapBenchBi bm = bm { benchmarkBuildInfo = f (benchmarkBuildInfo bm) } diff --git a/cabal/Cabal/Distribution/Simple/Test.hs b/cabal/Cabal/Distribution/Simple/Test.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/Test.hs +++ /dev/null @@ -1,136 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Test --- Copyright : Thomas Tuegel 2010 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This is the entry point into testing a built package. It performs the --- \"@.\/setup test@\" action. It runs test suites designated in the package --- description and reports on the results. - -module Distribution.Simple.Test - ( test - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Types.UnqualComponentName -import qualified Distribution.PackageDescription as PD -import Distribution.Simple.Compiler -import Distribution.Simple.Hpc -import Distribution.Simple.InstallDirs -import qualified Distribution.Simple.LocalBuildInfo as LBI -import qualified Distribution.Types.LocalBuildInfo as LBI -import Distribution.Simple.Setup -import Distribution.Simple.UserHooks -import qualified Distribution.Simple.Test.ExeV10 as ExeV10 -import qualified Distribution.Simple.Test.LibV09 as LibV09 -import Distribution.Simple.Test.Log -import Distribution.Simple.Utils -import Distribution.TestSuite -import Distribution.Pretty - -import System.Directory - ( createDirectoryIfMissing, doesFileExist, getDirectoryContents - , removeFile ) -import System.FilePath ( () ) - --- |Perform the \"@.\/setup test@\" action. -test :: Args -- ^positional command-line arguments - -> PD.PackageDescription -- ^information from the .cabal file - -> LBI.LocalBuildInfo -- ^information from the configure step - -> TestFlags -- ^flags sent to test - -> IO () -test args pkg_descr lbi flags = do - let verbosity = fromFlag $ testVerbosity flags - machineTemplate = fromFlag $ testMachineLog flags - distPref = fromFlag $ testDistPref flags - testLogDir = distPref "test" - testNames = args - pkgTests = PD.testSuites pkg_descr - enabledTests = LBI.enabledTestLBIs pkg_descr lbi - - doTest :: ((PD.TestSuite, LBI.ComponentLocalBuildInfo), - Maybe TestSuiteLog) -> IO TestSuiteLog - doTest ((suite, clbi), _) = - case PD.testInterface suite of - PD.TestSuiteExeV10 _ _ -> - ExeV10.runTest pkg_descr lbi clbi flags suite - - PD.TestSuiteLibV09 _ _ -> - LibV09.runTest pkg_descr lbi clbi flags suite - - _ -> return TestSuiteLog - { testSuiteName = PD.testName suite - , testLogs = TestLog - { testName = unUnqualComponentName $ PD.testName suite - , testOptionsReturned = [] - , testResult = - Error $ "No support for running test suite type: " - ++ show (pretty $ PD.testType suite) - } - , logFile = "" - } - - unless (PD.hasTests pkg_descr) $ do - notice verbosity "Package has no test suites." - exitSuccess - - when (PD.hasTests pkg_descr && null enabledTests) $ - die' verbosity $ - "No test suites enabled. Did you remember to configure with " - ++ "\'--enable-tests\'?" - - testsToRun <- case testNames of - [] -> return $ zip enabledTests $ repeat Nothing - names -> for names $ \tName -> - let testMap = zip enabledNames enabledTests - enabledNames = map (PD.testName . fst) enabledTests - allNames = map PD.testName pkgTests - tCompName = mkUnqualComponentName tName - in case lookup tCompName testMap of - Just t -> return (t, Nothing) - _ | tCompName `elem` allNames -> - die' verbosity $ "Package configured with test suite " - ++ tName ++ " disabled." - | otherwise -> die' verbosity $ "no such test: " ++ tName - - createDirectoryIfMissing True testLogDir - - -- Delete ordinary files from test log directory. - getDirectoryContents testLogDir - >>= filterM doesFileExist . map (testLogDir ) - >>= traverse_ removeFile - - let totalSuites = length testsToRun - notice verbosity $ "Running " ++ show totalSuites ++ " test suites..." - suites <- traverse doTest testsToRun - let packageLog = (localPackageLog pkg_descr lbi) { testSuites = suites } - packageLogFile = () testLogDir - $ packageLogPath machineTemplate pkg_descr lbi - allOk <- summarizePackage verbosity packageLog - writeFile packageLogFile $ show packageLog - - when (LBI.testCoverage lbi) $ - markupPackage verbosity lbi distPref (prettyShow $ PD.package pkg_descr) $ - map (fst . fst) testsToRun - - unless allOk exitFailure - -packageLogPath :: PathTemplate - -> PD.PackageDescription - -> LBI.LocalBuildInfo - -> FilePath -packageLogPath template pkg_descr lbi = - fromPathTemplate $ substPathTemplate env template - where - env = initialPathTemplateEnv - (PD.package pkg_descr) (LBI.localUnitId lbi) - (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) diff --git a/cabal/Cabal/Distribution/Simple/Test/ExeV10.hs b/cabal/Cabal/Distribution/Simple/Test/ExeV10.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/Test/ExeV10.hs +++ /dev/null @@ -1,188 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - -module Distribution.Simple.Test.ExeV10 - ( runTest - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Types.UnqualComponentName -import Distribution.Compat.CreatePipe -import Distribution.Compat.Environment -import qualified Distribution.PackageDescription as PD -import Distribution.Simple.Build.PathsModule -import Distribution.Simple.BuildPaths -import Distribution.Simple.Compiler -import Distribution.Simple.Hpc -import Distribution.Simple.InstallDirs -import qualified Distribution.Simple.LocalBuildInfo as LBI -import qualified Distribution.Types.LocalBuildInfo as LBI -import Distribution.Simple.Setup -import Distribution.Simple.Test.Log -import Distribution.Simple.Utils -import Distribution.System -import Distribution.TestSuite -import Distribution.Pretty -import Distribution.Verbosity - -import System.Directory - ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist - , getCurrentDirectory, removeDirectoryRecursive ) -import System.FilePath ( (), (<.>) ) -import System.IO ( stdout, stderr ) - -import qualified Data.ByteString.Lazy as LBS - -runTest :: PD.PackageDescription - -> LBI.LocalBuildInfo - -> LBI.ComponentLocalBuildInfo - -> TestFlags - -> PD.TestSuite - -> IO TestSuiteLog -runTest pkg_descr lbi clbi flags suite = do - let isCoverageEnabled = LBI.testCoverage lbi - way = guessWay lbi - tixDir_ = tixDir distPref way testName' - - pwd <- getCurrentDirectory - existingEnv <- getEnvironment - - let cmd = LBI.buildDir lbi testName' - testName' <.> exeExtension (LBI.hostPlatform lbi) - -- Check that the test executable exists. - exists <- doesFileExist cmd - unless exists $ die' verbosity $ "Error: Could not find test program \"" ++ cmd - ++ "\". Did you build the package first?" - - -- Remove old .tix files if appropriate. - unless (fromFlag $ testKeepTix flags) $ do - exists' <- doesDirectoryExist tixDir_ - when exists' $ removeDirectoryRecursive tixDir_ - - -- Create directory for HPC files. - createDirectoryIfMissing True tixDir_ - - -- Write summary notices indicating start of test suite - notice verbosity $ summarizeSuiteStart $ testName' - - - -- Run the test executable - let opts = map (testOption pkg_descr lbi suite) - (testOptions flags) - dataDirPath = pwd PD.dataDir pkg_descr - tixFile = pwd tixFilePath distPref way (testName') - pkgPathEnv = (pkgPathEnvVar pkg_descr "datadir", dataDirPath) - : existingEnv - shellEnv = [("HPCTIXFILE", tixFile) | isCoverageEnabled] ++ pkgPathEnv - - -- Add (DY)LD_LIBRARY_PATH if needed - shellEnv' <- if LBI.withDynExe lbi - then do let (Platform _ os) = LBI.hostPlatform lbi - paths <- LBI.depLibraryPaths True False lbi clbi - return (addLibraryPath os paths shellEnv) - else return shellEnv - - -- Output logger - (wOut, wErr, getLogText) <- case details of - Direct -> return (stdout, stderr, return LBS.empty) - _ -> do - (rOut, wOut) <- createPipe - - return $ (,,) wOut wOut $ do - -- Read test executables' output - logText <- LBS.hGetContents rOut - - -- '--show-details=streaming': print the log output in another thread - when (details == Streaming) $ LBS.putStr logText - - -- drain the output. - evaluate (force logText) - - (exit, logText) <- case testWrapper flags of - Flag path -> rawSystemIOWithEnvAndAction - verbosity path (cmd:opts) Nothing (Just shellEnv') - getLogText - -- these handles are automatically closed - Nothing (Just wOut) (Just wErr) - - NoFlag -> rawSystemIOWithEnvAndAction - verbosity cmd opts Nothing (Just shellEnv') - getLogText - -- these handles are automatically closed - Nothing (Just wOut) (Just wErr) - - -- Generate TestSuiteLog from executable exit code and a machine- - -- readable test log. - let suiteLog = buildLog exit - - -- Write summary notice to log file indicating start of test suite - appendFile (logFile suiteLog) $ summarizeSuiteStart $ testName' - - -- Append contents of temporary log file to the final human- - -- readable log file - LBS.appendFile (logFile suiteLog) logText - - -- Write end-of-suite summary notice to log file - appendFile (logFile suiteLog) $ summarizeSuiteFinish suiteLog - - -- Show the contents of the human-readable log file on the terminal - -- if there is a failure and/or detailed output is requested - let whenPrinting = when $ - ( details == Always || - details == Failures && not (suitePassed $ testLogs suiteLog)) - -- verbosity overrides show-details - && verbosity >= normal - whenPrinting $ do - LBS.putStr logText - putChar '\n' - - -- Write summary notice to terminal indicating end of test suite - notice verbosity $ summarizeSuiteFinish suiteLog - - when isCoverageEnabled $ - markupTest verbosity lbi distPref (prettyShow $ PD.package pkg_descr) suite - - return suiteLog - where - testName' = unUnqualComponentName $ PD.testName suite - - distPref = fromFlag $ testDistPref flags - verbosity = fromFlag $ testVerbosity flags - details = fromFlag $ testShowDetails flags - testLogDir = distPref "test" - - buildLog exit = - let r = case exit of - ExitSuccess -> Pass - ExitFailure c -> Fail $ "exit code: " ++ show c - --n = unUnqualComponentName $ PD.testName suite - l = TestLog - { testName = testName' - , testOptionsReturned = [] - , testResult = r - } - in TestSuiteLog - { testSuiteName = PD.testName suite - , testLogs = l - , logFile = - testLogDir - testSuiteLogPath (fromFlag $ testHumanLog flags) - pkg_descr lbi testName' l - } - --- TODO: This is abusing the notion of a 'PathTemplate'. The result isn't --- necessarily a path. -testOption :: PD.PackageDescription - -> LBI.LocalBuildInfo - -> PD.TestSuite - -> PathTemplate - -> String -testOption pkg_descr lbi suite template = - fromPathTemplate $ substPathTemplate env template - where - env = initialPathTemplateEnv - (PD.package pkg_descr) (LBI.localUnitId lbi) - (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) ++ - [(TestSuiteNameVar, toPathTemplate $ unUnqualComponentName $ PD.testName suite)] diff --git a/cabal/Cabal/Distribution/Simple/Test/LibV09.hs b/cabal/Cabal/Distribution/Simple/Test/LibV09.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/Test/LibV09.hs +++ /dev/null @@ -1,287 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - -module Distribution.Simple.Test.LibV09 - ( runTest - -- Test stub - , simpleTestStub - , stubFilePath, stubMain, stubName, stubWriteLog - , writeSimpleTestStub - ) where - -import Prelude () -import Distribution.Compat.Prelude -import Distribution.Types.UnqualComponentName - -import Distribution.Compat.CreatePipe -import Distribution.Compat.Environment -import Distribution.Compat.Internal.TempFile -import Distribution.ModuleName -import qualified Distribution.PackageDescription as PD -import Distribution.Simple.Build.PathsModule -import Distribution.Simple.BuildPaths -import Distribution.Simple.Compiler -import Distribution.Simple.Hpc -import Distribution.Simple.InstallDirs -import qualified Distribution.Simple.LocalBuildInfo as LBI -import qualified Distribution.Types.LocalBuildInfo as LBI -import Distribution.Simple.Setup -import Distribution.Simple.Test.Log -import Distribution.Simple.Utils -import Distribution.System -import Distribution.TestSuite -import Distribution.Pretty -import Distribution.Verbosity - -import qualified Control.Exception as CE -import qualified Data.ByteString.Lazy as LBS -import System.Directory - ( createDirectoryIfMissing, canonicalizePath - , doesDirectoryExist, doesFileExist - , getCurrentDirectory, removeDirectoryRecursive, removeFile - , setCurrentDirectory ) -import System.FilePath ( (), (<.>) ) -import System.IO ( hClose, hPutStr ) -import System.Process (StdStream(..), waitForProcess) - -runTest :: PD.PackageDescription - -> LBI.LocalBuildInfo - -> LBI.ComponentLocalBuildInfo - -> TestFlags - -> PD.TestSuite - -> IO TestSuiteLog -runTest pkg_descr lbi clbi flags suite = do - let isCoverageEnabled = LBI.testCoverage lbi - way = guessWay lbi - - pwd <- getCurrentDirectory - existingEnv <- getEnvironment - - let cmd = LBI.buildDir lbi stubName suite - stubName suite <.> exeExtension (LBI.hostPlatform lbi) - -- Check that the test executable exists. - exists <- doesFileExist cmd - unless exists $ - die' verbosity $ "Error: Could not find test program \"" ++ cmd - ++ "\". Did you build the package first?" - - -- Remove old .tix files if appropriate. - unless (fromFlag $ testKeepTix flags) $ do - let tDir = tixDir distPref way testName' - exists' <- doesDirectoryExist tDir - when exists' $ removeDirectoryRecursive tDir - - -- Create directory for HPC files. - createDirectoryIfMissing True $ tixDir distPref way testName' - - -- Write summary notices indicating start of test suite - notice verbosity $ summarizeSuiteStart testName' - - suiteLog <- CE.bracket openCabalTemp deleteIfExists $ \tempLog -> do - - -- TODO: this setup is broken, - -- if the test output is too big, we will deadlock. - (rOut, wOut) <- createPipe - - -- Run test executable - (Just wIn, _, _, process) <- do - let opts = map (testOption pkg_descr lbi suite) $ testOptions flags - dataDirPath = pwd PD.dataDir pkg_descr - tixFile = pwd tixFilePath distPref way testName' - pkgPathEnv = (pkgPathEnvVar pkg_descr "datadir", dataDirPath) - : existingEnv - shellEnv = [("HPCTIXFILE", tixFile) | isCoverageEnabled] - ++ pkgPathEnv - -- Add (DY)LD_LIBRARY_PATH if needed - shellEnv' <- - if LBI.withDynExe lbi - then do - let (Platform _ os) = LBI.hostPlatform lbi - paths <- LBI.depLibraryPaths True False lbi clbi - cpath <- canonicalizePath $ LBI.componentBuildDir lbi clbi - return (addLibraryPath os (cpath : paths) shellEnv) - else return shellEnv - case testWrapper flags of - Flag path -> createProcessWithEnv verbosity path (cmd:opts) Nothing (Just shellEnv') - -- these handles are closed automatically - CreatePipe (UseHandle wOut) (UseHandle wOut) - - NoFlag -> createProcessWithEnv verbosity cmd opts Nothing (Just shellEnv') - -- these handles are closed automatically - CreatePipe (UseHandle wOut) (UseHandle wOut) - - hPutStr wIn $ show (tempLog, PD.testName suite) - hClose wIn - - -- Append contents of temporary log file to the final human- - -- readable log file - logText <- LBS.hGetContents rOut - -- Force the IO manager to drain the test output pipe - _ <- evaluate (force logText) - - exitcode <- waitForProcess process - unless (exitcode == ExitSuccess) $ do - debug verbosity $ cmd ++ " returned " ++ show exitcode - - -- Generate final log file name - let finalLogName l = testLogDir - testSuiteLogPath - (fromFlag $ testHumanLog flags) pkg_descr lbi - (unUnqualComponentName $ testSuiteName l) (testLogs l) - -- Generate TestSuiteLog from executable exit code and a machine- - -- readable test log - suiteLog <- fmap (\s -> (\l -> l { logFile = finalLogName l }) - . fromMaybe (error $ "panic! read @TestSuiteLog " ++ show s) $ readMaybe s) -- TODO: eradicateNoParse - $ readFile tempLog - - -- Write summary notice to log file indicating start of test suite - appendFile (logFile suiteLog) $ summarizeSuiteStart testName' - - LBS.appendFile (logFile suiteLog) logText - - -- Write end-of-suite summary notice to log file - appendFile (logFile suiteLog) $ summarizeSuiteFinish suiteLog - - -- Show the contents of the human-readable log file on the terminal - -- if there is a failure and/or detailed output is requested - let details = fromFlag $ testShowDetails flags - whenPrinting = when $ (details > Never) - && (not (suitePassed $ testLogs suiteLog) || details == Always) - && verbosity >= normal - whenPrinting $ do - LBS.putStr logText - putChar '\n' - - return suiteLog - - -- Write summary notice to terminal indicating end of test suite - notice verbosity $ summarizeSuiteFinish suiteLog - - when isCoverageEnabled $ - markupTest verbosity lbi distPref (prettyShow $ PD.package pkg_descr) suite - - return suiteLog - where - testName' = unUnqualComponentName $ PD.testName suite - - deleteIfExists file = do - exists <- doesFileExist file - when exists $ removeFile file - - testLogDir = distPref "test" - openCabalTemp = do - (f, h) <- openTempFile testLogDir $ "cabal-test-" <.> "log" - hClose h >> return f - - distPref = fromFlag $ testDistPref flags - verbosity = fromFlag $ testVerbosity flags - --- TODO: This is abusing the notion of a 'PathTemplate'. The result isn't --- necessarily a path. -testOption :: PD.PackageDescription - -> LBI.LocalBuildInfo - -> PD.TestSuite - -> PathTemplate - -> String -testOption pkg_descr lbi suite template = - fromPathTemplate $ substPathTemplate env template - where - env = initialPathTemplateEnv - (PD.package pkg_descr) (LBI.localUnitId lbi) - (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) ++ - [(TestSuiteNameVar, toPathTemplate $ unUnqualComponentName $ PD.testName suite)] - --- Test stub ---------- - --- | The name of the stub executable associated with a library 'TestSuite'. -stubName :: PD.TestSuite -> FilePath -stubName t = unUnqualComponentName (PD.testName t) ++ "Stub" - --- | The filename of the source file for the stub executable associated with a --- library 'TestSuite'. -stubFilePath :: PD.TestSuite -> FilePath -stubFilePath t = stubName t <.> "hs" - --- | Write the source file for a library 'TestSuite' stub executable. -writeSimpleTestStub :: PD.TestSuite -- ^ library 'TestSuite' for which a stub - -- is being created - -> FilePath -- ^ path to directory where stub source - -- should be located - -> IO () -writeSimpleTestStub t dir = do - createDirectoryIfMissing True dir - let filename = dir stubFilePath t - m = case PD.testInterface t of - PD.TestSuiteLibV09 _ m' -> m' - _ -> error "writeSimpleTestStub: invalid TestSuite passed" - writeFile filename $ simpleTestStub m - --- | Source code for library test suite stub executable -simpleTestStub :: ModuleName -> String -simpleTestStub m = unlines - [ "module Main ( main ) where" - , "import Distribution.Simple.Test.LibV09 ( stubMain )" - , "import " ++ show (pretty m) ++ " ( tests )" - , "main :: IO ()" - , "main = stubMain tests" - ] - --- | Main function for test stubs. Once, it was written directly into the stub, --- but minimizing the amount of code actually in the stub maximizes the number --- of detectable errors when Cabal is compiled. -stubMain :: IO [Test] -> IO () -stubMain tests = do - (f, n) <- fmap (\s -> fromMaybe (error $ "panic! read " ++ show s) $ readMaybe s) getContents -- TODO: eradicateNoParse - dir <- getCurrentDirectory - results <- (tests >>= stubRunTests) `CE.catch` errHandler - setCurrentDirectory dir - stubWriteLog f n results - where - errHandler :: CE.SomeException -> IO TestLogs - errHandler e = case CE.fromException e of - Just CE.UserInterrupt -> CE.throwIO e - _ -> return $ TestLog { testName = "Cabal test suite exception", - testOptionsReturned = [], - testResult = Error $ show e } - --- | The test runner used in library "TestSuite" stub executables. Runs a list --- of 'Test's. An executable calling this function is meant to be invoked as --- the child of a Cabal process during @.\/setup test@. A 'TestSuiteLog', --- provided by Cabal, is read from the standard input; it supplies the name of --- the test suite and the location of the machine-readable test suite log file. --- Human-readable log information is written to the standard output for capture --- by the calling Cabal process. -stubRunTests :: [Test] -> IO TestLogs -stubRunTests tests = do - logs <- traverse stubRunTests' tests - return $ GroupLogs "Default" logs - where - stubRunTests' (Test t) = do - l <- run t >>= finish - summarizeTest normal Always l - return l - where - finish (Finished result) = - return TestLog - { testName = name t - , testOptionsReturned = defaultOptions t - , testResult = result - } - finish (Progress _ next) = next >>= finish - stubRunTests' g@(Group {}) = do - logs <- traverse stubRunTests' $ groupTests g - return $ GroupLogs (groupName g) logs - stubRunTests' (ExtraOptions _ t) = stubRunTests' t - maybeDefaultOption opt = - maybe Nothing (\d -> Just (optionName opt, d)) $ optionDefault opt - defaultOptions testInst = mapMaybe maybeDefaultOption $ options testInst - --- | From a test stub, write the 'TestSuiteLog' to temporary file for the calling --- Cabal process to read. -stubWriteLog :: FilePath -> UnqualComponentName -> TestLogs -> IO () -stubWriteLog f n logs = do - let testLog = TestSuiteLog { testSuiteName = n, testLogs = logs, logFile = f } - writeFile (logFile testLog) $ show testLog - when (suiteError logs) $ exitWith $ ExitFailure 2 - when (suiteFailed logs) $ exitWith $ ExitFailure 1 - exitSuccess diff --git a/cabal/Cabal/Distribution/Simple/Test/Log.hs b/cabal/Cabal/Distribution/Simple/Test/Log.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/Test/Log.hs +++ /dev/null @@ -1,166 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - -module Distribution.Simple.Test.Log - ( PackageLog(..) - , TestLogs(..) - , TestSuiteLog(..) - , countTestResults - , localPackageLog - , summarizePackage - , summarizeSuiteFinish, summarizeSuiteStart - , summarizeTest - , suiteError, suiteFailed, suitePassed - , testSuiteLogPath - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Package -import Distribution.Types.UnqualComponentName -import qualified Distribution.PackageDescription as PD -import Distribution.Simple.Compiler -import Distribution.Simple.InstallDirs -import qualified Distribution.Simple.LocalBuildInfo as LBI -import Distribution.Simple.Setup -import Distribution.Simple.Utils -import Distribution.System -import Distribution.TestSuite -import Distribution.Verbosity -import Distribution.Pretty - -import qualified Prelude (foldl1) - --- | Logs all test results for a package, broken down first by test suite and --- then by test case. -data PackageLog = PackageLog - { package :: PackageId - , compiler :: CompilerId - , platform :: Platform - , testSuites :: [TestSuiteLog] - } - deriving (Read, Show, Eq) - --- | A 'PackageLog' with package and platform information specified. -localPackageLog :: PD.PackageDescription -> LBI.LocalBuildInfo -> PackageLog -localPackageLog pkg_descr lbi = PackageLog - { package = PD.package pkg_descr - , compiler = compilerId $ LBI.compiler lbi - , platform = LBI.hostPlatform lbi - , testSuites = [] - } - --- | Logs test suite results, itemized by test case. -data TestSuiteLog = TestSuiteLog - { testSuiteName :: UnqualComponentName - , testLogs :: TestLogs - , logFile :: FilePath -- path to human-readable log file - } - deriving (Read, Show, Eq) - -data TestLogs - = TestLog - { testName :: String - , testOptionsReturned :: Options - , testResult :: Result - } - | GroupLogs String [TestLogs] - deriving (Read, Show, Eq) - --- | Count the number of pass, fail, and error test results in a 'TestLogs' --- tree. -countTestResults :: TestLogs - -> (Int, Int, Int) -- ^ Passes, fails, and errors, - -- respectively. -countTestResults = go (0, 0, 0) - where - go (p, f, e) (TestLog { testResult = r }) = - case r of - Pass -> (p + 1, f, e) - Fail _ -> (p, f + 1, e) - Error _ -> (p, f, e + 1) - go (p, f, e) (GroupLogs _ ts) = foldl go (p, f, e) ts - --- | From a 'TestSuiteLog', determine if the test suite passed. -suitePassed :: TestLogs -> Bool -suitePassed l = - case countTestResults l of - (_, 0, 0) -> True - _ -> False - --- | From a 'TestSuiteLog', determine if the test suite failed. -suiteFailed :: TestLogs -> Bool -suiteFailed l = - case countTestResults l of - (_, 0, _) -> False - _ -> True - --- | From a 'TestSuiteLog', determine if the test suite encountered errors. -suiteError :: TestLogs -> Bool -suiteError l = - case countTestResults l of - (_, _, 0) -> False - _ -> True - -resultString :: TestLogs -> String -resultString l | suiteError l = "error" - | suiteFailed l = "fail" - | otherwise = "pass" - -testSuiteLogPath :: PathTemplate - -> PD.PackageDescription - -> LBI.LocalBuildInfo - -> String -- ^ test suite name - -> TestLogs -- ^ test suite results - -> FilePath -testSuiteLogPath template pkg_descr lbi test_name result = - fromPathTemplate $ substPathTemplate env template - where - env = initialPathTemplateEnv - (PD.package pkg_descr) (LBI.localUnitId lbi) - (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) - ++ [ (TestSuiteNameVar, toPathTemplate test_name) - , (TestSuiteResultVar, toPathTemplate $ resultString result) - ] - --- | Print a summary to the console after all test suites have been run --- indicating the number of successful test suites and cases. Returns 'True' if --- all test suites passed and 'False' otherwise. -summarizePackage :: Verbosity -> PackageLog -> IO Bool -summarizePackage verbosity packageLog = do - let counts = map (countTestResults . testLogs) $ testSuites packageLog - (passed, failed, errors) = Prelude.foldl1 addTriple counts - totalCases = passed + failed + errors - passedSuites = length - $ filter (suitePassed . testLogs) - $ testSuites packageLog - totalSuites = length $ testSuites packageLog - notice verbosity $ show passedSuites ++ " of " ++ show totalSuites - ++ " test suites (" ++ show passed ++ " of " - ++ show totalCases ++ " test cases) passed." - return $! passedSuites == totalSuites - where - addTriple (p1, f1, e1) (p2, f2, e2) = (p1 + p2, f1 + f2, e1 + e2) - --- | Print a summary of a single test case's result to the console, suppressing --- output for certain verbosity or test filter levels. -summarizeTest :: Verbosity -> TestShowDetails -> TestLogs -> IO () -summarizeTest _ _ (GroupLogs {}) = return () -summarizeTest verbosity details t = - when shouldPrint $ notice verbosity $ "Test case " ++ testName t - ++ ": " ++ show (testResult t) - where shouldPrint = (details > Never) && (notPassed || details == Always) - notPassed = testResult t /= Pass - --- | Print a summary of the test suite's results on the console, suppressing --- output for certain verbosity or test filter levels. -summarizeSuiteFinish :: TestSuiteLog -> String -summarizeSuiteFinish testLog = unlines - [ "Test suite " ++ prettyShow (testSuiteName testLog) ++ ": " ++ resStr - , "Test suite logged to: " ++ logFile testLog - ] - where resStr = map toUpper (resultString $ testLogs testLog) - -summarizeSuiteStart :: String -> String -summarizeSuiteStart n = "Test suite " ++ n ++ ": RUNNING...\n" diff --git a/cabal/Cabal/Distribution/Simple/UHC.hs b/cabal/Cabal/Distribution/Simple/UHC.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/UHC.hs +++ /dev/null @@ -1,295 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.UHC --- Copyright : Andres Loeh 2009 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This module contains most of the UHC-specific code for configuring, building --- and installing packages. --- --- Thanks to the authors of the other implementation-specific files, in --- particular to Isaac Jones, Duncan Coutts and Henning Thielemann, for --- inspiration on how to design this module. - -module Distribution.Simple.UHC ( - configure, getInstalledPackages, - buildLib, buildExe, installLib, registerPackage, inplacePackageDbPath - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.InstalledPackageInfo -import Distribution.Package hiding (installedUnitId) -import Distribution.PackageDescription -import Distribution.Simple.BuildPaths -import Distribution.Simple.Compiler -import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.PackageIndex -import Distribution.Simple.Program -import Distribution.Simple.Utils -import Distribution.Pretty -import Distribution.Parsec -import Distribution.Types.MungedPackageId -import Distribution.Verbosity -import Distribution.Version -import Distribution.System -import Language.Haskell.Extension - -import qualified Data.Map as Map ( empty ) -import System.Directory -import System.FilePath - --- ----------------------------------------------------------------------------- --- Configuring - -configure :: Verbosity -> Maybe FilePath -> Maybe FilePath - -> ProgramDb -> IO (Compiler, Maybe Platform, ProgramDb) -configure verbosity hcPath _hcPkgPath progdb = do - - (_uhcProg, uhcVersion, progdb') <- - requireProgramVersion verbosity uhcProgram - (orLaterVersion (mkVersion [1,0,2])) - (userMaybeSpecifyPath "uhc" hcPath progdb) - - let comp = Compiler { - compilerId = CompilerId UHC uhcVersion, - compilerAbiTag = NoAbiTag, - compilerCompat = [], - compilerLanguages = uhcLanguages, - compilerExtensions = uhcLanguageExtensions, - compilerProperties = Map.empty - } - compPlatform = Nothing - return (comp, compPlatform, progdb') - -uhcLanguages :: [(Language, CompilerFlag)] -uhcLanguages = [(Haskell98, "")] - --- | The flags for the supported extensions. -uhcLanguageExtensions :: [(Extension, Maybe CompilerFlag)] -uhcLanguageExtensions = - let doFlag (f, (enable, disable)) = [(EnableExtension f, enable), - (DisableExtension f, disable)] - alwaysOn = (Nothing, Nothing{- wrong -}) - in concatMap doFlag - [(CPP, (Just "--cpp", Nothing{- wrong -})), - (PolymorphicComponents, alwaysOn), - (ExistentialQuantification, alwaysOn), - (ForeignFunctionInterface, alwaysOn), - (UndecidableInstances, alwaysOn), - (MultiParamTypeClasses, alwaysOn), - (Rank2Types, alwaysOn), - (PatternSignatures, alwaysOn), - (EmptyDataDecls, alwaysOn), - (ImplicitPrelude, (Nothing, Just "--no-prelude"{- wrong -})), - (TypeOperators, alwaysOn), - (OverlappingInstances, alwaysOn), - (FlexibleInstances, alwaysOn)] - -getInstalledPackages :: Verbosity -> Compiler -> PackageDBStack -> ProgramDb - -> IO InstalledPackageIndex -getInstalledPackages verbosity comp packagedbs progdb = do - let compilerid = compilerId comp - systemPkgDir <- getGlobalPackageDir verbosity progdb - userPkgDir <- getUserPackageDir - let pkgDirs = nub (concatMap (packageDbPaths userPkgDir systemPkgDir) packagedbs) - -- putStrLn $ "pkgdirs: " ++ show pkgDirs - pkgs <- liftM (map addBuiltinVersions . concat) $ - traverse (\ d -> getDirectoryContents d >>= filterM (isPkgDir (prettyShow compilerid) d)) - pkgDirs - -- putStrLn $ "pkgs: " ++ show pkgs - let iPkgs = - map mkInstalledPackageInfo $ - concatMap parsePackage $ - pkgs - -- putStrLn $ "installed pkgs: " ++ show iPkgs - return (fromList iPkgs) - -getGlobalPackageDir :: Verbosity -> ProgramDb -> IO FilePath -getGlobalPackageDir verbosity progdb = do - output <- getDbProgramOutput verbosity - uhcProgram progdb ["--meta-pkgdir-system"] - -- we need to trim because pkgdir contains an extra newline at the end - let pkgdir = trimEnd output - return pkgdir - where - trimEnd = reverse . dropWhile isSpace . reverse - -getUserPackageDir :: IO FilePath -getUserPackageDir = do - homeDir <- getHomeDirectory - return $ homeDir ".cabal" "lib" -- TODO: determine in some other way - -packageDbPaths :: FilePath -> FilePath -> PackageDB -> [FilePath] -packageDbPaths user system db = - case db of - GlobalPackageDB -> [ system ] - UserPackageDB -> [ user ] - SpecificPackageDB path -> [ path ] - --- | Hack to add version numbers to UHC-built-in packages. This should sooner or --- later be fixed on the UHC side. -addBuiltinVersions :: String -> String -{- -addBuiltinVersions "uhcbase" = "uhcbase-1.0" -addBuiltinVersions "base" = "base-3.0" -addBuiltinVersions "array" = "array-0.2" --} -addBuiltinVersions xs = xs - --- | Name of the installed package config file. -installedPkgConfig :: String -installedPkgConfig = "installed-pkg-config" - --- | Check if a certain dir contains a valid package. Currently, we are --- looking only for the presence of an installed package configuration. --- TODO: Actually make use of the information provided in the file. -isPkgDir :: String -> String -> String -> IO Bool -isPkgDir _ _ ('.' : _) = return False -- ignore files starting with a . -isPkgDir c dir xs = do - let candidate = dir uhcPackageDir xs c - -- putStrLn $ "trying: " ++ candidate - doesFileExist (candidate installedPkgConfig) - -parsePackage :: String -> [PackageId] -parsePackage = toList . simpleParsec - --- | Create a trivial package info from a directory name. -mkInstalledPackageInfo :: PackageId -> InstalledPackageInfo -mkInstalledPackageInfo p = emptyInstalledPackageInfo - { installedUnitId = mkLegacyUnitId p, - sourcePackageId = p } - - --- ----------------------------------------------------------------------------- --- Building - -buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo - -> Library -> ComponentLocalBuildInfo -> IO () -buildLib verbosity pkg_descr lbi lib clbi = do - - systemPkgDir <- getGlobalPackageDir verbosity (withPrograms lbi) - userPkgDir <- getUserPackageDir - let runUhcProg = runDbProgram verbosity uhcProgram (withPrograms lbi) - let uhcArgs = -- set package name - ["--pkg-build=" ++ prettyShow (packageId pkg_descr)] - -- common flags lib/exe - ++ constructUHCCmdLine userPkgDir systemPkgDir - lbi (libBuildInfo lib) clbi - (buildDir lbi) verbosity - -- source files - -- suboptimal: UHC does not understand module names, so - -- we replace periods by path separators - ++ map (map (\ c -> if c == '.' then pathSeparator else c)) - (map prettyShow (allLibModules lib clbi)) - - runUhcProg uhcArgs - - return () - -buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo - -> Executable -> ComponentLocalBuildInfo -> IO () -buildExe verbosity _pkg_descr lbi exe clbi = do - systemPkgDir <- getGlobalPackageDir verbosity (withPrograms lbi) - userPkgDir <- getUserPackageDir - let runUhcProg = runDbProgram verbosity uhcProgram (withPrograms lbi) - let uhcArgs = -- common flags lib/exe - constructUHCCmdLine userPkgDir systemPkgDir - lbi (buildInfo exe) clbi - (buildDir lbi) verbosity - -- output file - ++ ["--output", buildDir lbi prettyShow (exeName exe)] - -- main source module - ++ [modulePath exe] - runUhcProg uhcArgs - -constructUHCCmdLine :: FilePath -> FilePath - -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo - -> FilePath -> Verbosity -> [String] -constructUHCCmdLine user system lbi bi clbi odir verbosity = - -- verbosity - (if verbosity >= deafening then ["-v4"] - else if verbosity >= normal then [] - else ["-v0"]) - ++ hcOptions UHC bi - -- flags for language extensions - ++ languageToFlags (compiler lbi) (defaultLanguage bi) - ++ extensionsToFlags (compiler lbi) (usedExtensions bi) - -- packages - ++ ["--hide-all-packages"] - ++ uhcPackageDbOptions user system (withPackageDB lbi) - ++ ["--package=uhcbase"] - ++ ["--package=" ++ prettyShow (mungedName pkgid) | (_, pkgid) <- componentPackageDeps clbi ] - -- search paths - ++ ["-i" ++ odir] - ++ ["-i" ++ l | l <- nub (hsSourceDirs bi)] - ++ ["-i" ++ autogenComponentModulesDir lbi clbi] - ++ ["-i" ++ autogenPackageModulesDir lbi] - -- cpp options - ++ ["--optP=" ++ opt | opt <- cppOptions bi] - -- output path - ++ ["--odir=" ++ odir] - -- optimization - ++ (case withOptimization lbi of - NoOptimisation -> ["-O0"] - NormalOptimisation -> ["-O1"] - MaximumOptimisation -> ["-O2"]) - -uhcPackageDbOptions :: FilePath -> FilePath -> PackageDBStack -> [String] -uhcPackageDbOptions user system db = map (\ x -> "--pkg-searchpath=" ++ x) - (concatMap (packageDbPaths user system) db) - --- ----------------------------------------------------------------------------- --- Installation - -installLib :: Verbosity -> LocalBuildInfo - -> FilePath -> FilePath -> FilePath - -> PackageDescription -> Library -> ComponentLocalBuildInfo -> IO () -installLib verbosity _lbi targetDir _dynlibTargetDir builtDir pkg _library _clbi = do - -- putStrLn $ "dest: " ++ targetDir - -- putStrLn $ "built: " ++ builtDir - installDirectoryContents verbosity (builtDir prettyShow (packageId pkg)) targetDir - --- currently hard-coded UHC code generator and variant to use -uhcTarget, uhcTargetVariant :: String -uhcTarget = "bc" -uhcTargetVariant = "plain" - --- root directory for a package in UHC -uhcPackageDir :: String -> String -> FilePath -uhcPackageSubDir :: String -> FilePath -uhcPackageDir pkgid compilerid = pkgid uhcPackageSubDir compilerid -uhcPackageSubDir compilerid = compilerid uhcTarget uhcTargetVariant - --- ----------------------------------------------------------------------------- --- Registering - -registerPackage - :: Verbosity - -> Compiler - -> ProgramDb - -> PackageDBStack - -> InstalledPackageInfo - -> IO () -registerPackage verbosity comp progdb packageDbs installedPkgInfo = do - dbdir <- case registrationPackageDB packageDbs of - GlobalPackageDB -> getGlobalPackageDir verbosity progdb - UserPackageDB -> getUserPackageDir - SpecificPackageDB dir -> return dir - let pkgdir = dbdir uhcPackageDir (prettyShow pkgid) (prettyShow compilerid) - createDirectoryIfMissingVerbose verbosity True pkgdir - writeUTF8File (pkgdir installedPkgConfig) - (showInstalledPackageInfo installedPkgInfo) - where - pkgid = sourcePackageId installedPkgInfo - compilerid = compilerId comp - -inplacePackageDbPath :: LocalBuildInfo -> FilePath -inplacePackageDbPath lbi = buildDir lbi diff --git a/cabal/Cabal/Distribution/Simple/UserHooks.hs b/cabal/Cabal/Distribution/Simple/UserHooks.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/UserHooks.hs +++ /dev/null @@ -1,207 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.UserHooks --- Copyright : Isaac Jones 2003-2005 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This defines the API that @Setup.hs@ scripts can use to customise the way --- the build works. This module just defines the 'UserHooks' type. The --- predefined sets of hooks that implement the @Simple@, @Make@ and @Configure@ --- build systems are defined in "Distribution.Simple". The 'UserHooks' is a big --- record of functions. There are 3 for each action, a pre, post and the action --- itself. There are few other miscellaneous hooks, ones to extend the set of --- programs and preprocessors and one to override the function used to read the --- @.cabal@ file. --- --- This hooks type is widely agreed to not be the right solution. Partly this --- is because changes to it usually break custom @Setup.hs@ files and yet many --- internal code changes do require changes to the hooks. For example we cannot --- pass any extra parameters to most of the functions that implement the --- various phases because it would involve changing the types of the --- corresponding hook. At some point it will have to be replaced. - -module Distribution.Simple.UserHooks ( - UserHooks(..), Args, - emptyUserHooks, - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.PackageDescription -import Distribution.Simple.Program -import Distribution.Simple.Command -import Distribution.Simple.PreProcess -import Distribution.Simple.Setup -import Distribution.Simple.LocalBuildInfo - -type Args = [String] - --- | Hooks allow authors to add specific functionality before and after a --- command is run, and also to specify additional preprocessors. --- --- * WARNING: The hooks interface is under rather constant flux as we try to --- understand users needs. Setup files that depend on this interface may --- break in future releases. -data UserHooks = UserHooks { - - -- | Read the description file - readDesc :: IO (Maybe GenericPackageDescription), - -- | Custom preprocessors in addition to and overriding 'knownSuffixHandlers'. - hookedPreProcessors :: [ PPSuffixHandler ], - -- | These programs are detected at configure time. Arguments for them are - -- added to the configure command. - hookedPrograms :: [Program], - - -- |Hook to run before configure command - preConf :: Args -> ConfigFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during configure. - confHook :: (GenericPackageDescription, HookedBuildInfo) - -> ConfigFlags -> IO LocalBuildInfo, - -- |Hook to run after configure command - postConf :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before build command. Second arg indicates verbosity level. - preBuild :: Args -> BuildFlags -> IO HookedBuildInfo, - - -- |Over-ride this hook to get different behavior during build. - buildHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO (), - -- |Hook to run after build command. Second arg indicates verbosity level. - postBuild :: Args -> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before repl command. Second arg indicates verbosity level. - preRepl :: Args -> ReplFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during interpretation. - replHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> ReplFlags -> [String] -> IO (), - -- |Hook to run after repl command. Second arg indicates verbosity level. - postRepl :: Args -> ReplFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before clean command. Second arg indicates verbosity level. - preClean :: Args -> CleanFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during clean. - cleanHook :: PackageDescription -> () -> UserHooks -> CleanFlags -> IO (), - -- |Hook to run after clean command. Second arg indicates verbosity level. - postClean :: Args -> CleanFlags -> PackageDescription -> () -> IO (), - - -- |Hook to run before copy command - preCopy :: Args -> CopyFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during copy. - copyHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> CopyFlags -> IO (), - -- |Hook to run after copy command - postCopy :: Args -> CopyFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before install command - preInst :: Args -> InstallFlags -> IO HookedBuildInfo, - - -- |Over-ride this hook to get different behavior during install. - instHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> InstallFlags -> IO (), - -- |Hook to run after install command. postInst should be run - -- on the target, not on the build machine. - postInst :: Args -> InstallFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before register command - preReg :: Args -> RegisterFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during registration. - regHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO (), - -- |Hook to run after register command - postReg :: Args -> RegisterFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before unregister command - preUnreg :: Args -> RegisterFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during unregistration. - unregHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO (), - -- |Hook to run after unregister command - postUnreg :: Args -> RegisterFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before hscolour command. Second arg indicates verbosity level. - preHscolour :: Args -> HscolourFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during hscolour. - hscolourHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> HscolourFlags -> IO (), - -- |Hook to run after hscolour command. Second arg indicates verbosity level. - postHscolour :: Args -> HscolourFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before doctest command. Second arg indicates verbosity level. - preDoctest :: Args -> DoctestFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during doctest. - doctestHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> DoctestFlags -> IO (), - -- |Hook to run after doctest command. Second arg indicates verbosity level. - postDoctest :: Args -> DoctestFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before haddock command. Second arg indicates verbosity level. - preHaddock :: Args -> HaddockFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during haddock. - haddockHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> HaddockFlags -> IO (), - -- |Hook to run after haddock command. Second arg indicates verbosity level. - postHaddock :: Args -> HaddockFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before test command. - preTest :: Args -> TestFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during test. - testHook :: Args -> PackageDescription -> LocalBuildInfo -> UserHooks -> TestFlags -> IO (), - -- |Hook to run after test command. - postTest :: Args -> TestFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before bench command. - preBench :: Args -> BenchmarkFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during bench. - benchHook :: Args -> PackageDescription -> LocalBuildInfo -> UserHooks -> BenchmarkFlags -> IO (), - -- |Hook to run after bench command. - postBench :: Args -> BenchmarkFlags -> PackageDescription -> LocalBuildInfo -> IO () - } - --- |Empty 'UserHooks' which do nothing. -emptyUserHooks :: UserHooks -emptyUserHooks - = UserHooks { - readDesc = return Nothing, - hookedPreProcessors = [], - hookedPrograms = [], - preConf = rn', - confHook = (\_ _ -> return (error "No local build info generated during configure. Over-ride empty configure hook.")), - postConf = ru, - preBuild = rn', - buildHook = ru, - postBuild = ru, - preRepl = \_ _ -> return emptyHookedBuildInfo, - replHook = \_ _ _ _ _ -> return (), - postRepl = ru, - preClean = rn, - cleanHook = ru, - postClean = ru, - preCopy = rn', - copyHook = ru, - postCopy = ru, - preInst = rn, - instHook = ru, - postInst = ru, - preReg = rn', - regHook = ru, - postReg = ru, - preUnreg = rn, - unregHook = ru, - postUnreg = ru, - preHscolour = rn, - hscolourHook = ru, - postHscolour = ru, - preDoctest = rn, - doctestHook = ru, - postDoctest = ru, - preHaddock = rn', - haddockHook = ru, - postHaddock = ru, - preTest = rn', - testHook = \_ -> ru, - postTest = ru, - preBench = rn', - benchHook = \_ -> ru, - postBench = ru - } - where rn args _ = noExtraFlags args >> return emptyHookedBuildInfo - rn' _ _ = return emptyHookedBuildInfo - ru _ _ _ _ = return () diff --git a/cabal/Cabal/Distribution/Simple/Utils.hs b/cabal/Cabal/Distribution/Simple/Utils.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/Utils.hs +++ /dev/null @@ -1,1610 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE NoMonoLocalBinds #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Utils --- Copyright : Isaac Jones, Simon Marlow 2003-2004 --- License : BSD3 --- portions Copyright (c) 2007, Galois Inc. --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- A large and somewhat miscellaneous collection of utility functions used --- throughout the rest of the Cabal lib and in other tools that use the Cabal --- lib like @cabal-install@. It has a very simple set of logging actions. It --- has low level functions for running programs, a bunch of wrappers for --- various directory and file functions that do extra logging. - -module Distribution.Simple.Utils ( - cabalVersion, - - -- * logging and errors - dieNoVerbosity, - die', dieWithLocation', - dieNoWrap, - topHandler, topHandlerWith, - warn, - notice, noticeNoWrap, noticeDoc, - setupMessage, - info, infoNoWrap, - debug, debugNoWrap, - chattyTry, - annotateIO, - printRawCommandAndArgs, printRawCommandAndArgsAndEnv, - withOutputMarker, - - -- * exceptions - handleDoesNotExist, - - -- * running programs - rawSystemExit, - rawSystemExitCode, - rawSystemExitWithEnv, - rawSystemStdout, - rawSystemStdInOut, - rawSystemIOWithEnv, - rawSystemIOWithEnvAndAction, - createProcessWithEnv, - maybeExit, - xargs, - findProgramVersion, - - -- ** 'IOData' re-export - -- - -- These types are re-exported from - -- "Distribution.Utils.IOData" for convience as they're - -- exposed in the API of 'rawSystemStdInOut' - IOData(..), - KnownIODataMode (..), - IODataMode (..), - - -- * copying files - createDirectoryIfMissingVerbose, - copyFileVerbose, - copyFiles, - copyFileTo, - - -- * installing files - installOrdinaryFile, - installExecutableFile, - installMaybeExecutableFile, - installOrdinaryFiles, - installExecutableFiles, - installMaybeExecutableFiles, - installDirectoryContents, - copyDirectoryRecursive, - - -- * File permissions - doesExecutableExist, - setFileOrdinary, - setFileExecutable, - - -- * file names - currentDir, - shortRelativePath, - dropExeExtension, - exeExtensions, - - -- * finding files - findFileEx, - findFileCwd, - findFirstFile, - findFileWithExtension, - findFileCwdWithExtension, - findFileWithExtension', - findAllFilesWithExtension, - findAllFilesCwdWithExtension, - findModuleFileEx, - findModuleFilesEx, - getDirectoryContentsRecursive, - - -- * environment variables - isInSearchPath, - addLibraryPath, - - -- * modification time - moreRecentFile, - existsAndIsMoreRecentThan, - - -- * temp files and dirs - TempFileOptions(..), defaultTempFileOptions, - withTempFile, withTempFileEx, - withTempDirectory, withTempDirectoryEx, - createTempDirectory, - - -- * .cabal and .buildinfo files - defaultPackageDesc, - findPackageDesc, - findPackageDescCwd, - tryFindPackageDesc, - tryFindPackageDescCwd, - findHookedPackageDesc, - - -- * reading and writing files safely - withFileContents, - writeFileAtomic, - rewriteFileEx, - rewriteFileLBS, - - -- * Unicode - fromUTF8BS, - fromUTF8LBS, - toUTF8BS, - toUTF8LBS, - readUTF8File, - withUTF8FileContents, - writeUTF8File, - normaliseLineEndings, - - -- * BOM - ignoreBOM, - - -- * generic utils - dropWhileEndLE, - takeWhileEndLE, - equating, - comparing, - isInfixOf, - intercalate, - lowercase, - listUnion, - listUnionRight, - ordNub, - ordNubBy, - ordNubRight, - safeHead, - safeTail, - safeLast, - safeInit, - unintersperse, - wrapText, - wrapLine, - - -- * FilePath stuff - isAbsoluteOnAnyPlatform, - isRelativeOnAnyPlatform, - - -- * Deprecated functions - findFile, - findModuleFile, - findModuleFiles, - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Utils.Generic -import Distribution.Utils.IOData (IOData(..), IODataMode (..), KnownIODataMode (..)) -import qualified Distribution.Utils.IOData as IOData -import Distribution.ModuleName as ModuleName -import Distribution.System -import Distribution.Version -import Distribution.Compat.Async -import Distribution.Compat.CopyFile -import Distribution.Compat.Internal.TempFile -import Distribution.Compat.FilePath as FilePath -import Distribution.Compat.Stack -import Distribution.Verbosity -import Distribution.Types.PackageId - -#if __GLASGOW_HASKELL__ < 711 -#ifdef VERSION_base -#define BOOTSTRAPPED_CABAL 1 -#endif -#else -#ifdef CURRENT_PACKAGE_KEY -#define BOOTSTRAPPED_CABAL 1 -#endif -#endif - -#ifdef BOOTSTRAPPED_CABAL -import qualified Paths_Cabal (version) -#endif - -import Distribution.Pretty -import Distribution.Parsec - -import Data.Typeable - ( cast ) -import qualified Data.ByteString.Lazy as BS - -import System.Directory - ( Permissions(executable), getDirectoryContents, getPermissions - , doesDirectoryExist, doesFileExist, removeFile - , getModificationTime, createDirectory, removeDirectoryRecursive ) -import System.Environment - ( getProgName ) -import System.FilePath as FilePath - ( normalise, (), (<.>) - , getSearchPath, joinPath, takeDirectory, splitExtension - , splitDirectories, searchPathSeparator ) -import System.IO - ( Handle, hSetBinaryMode, hGetContents, stderr, stdout, hPutStr, hFlush - , hClose, hSetBuffering, BufferMode(..), hPutStrLn ) -import System.IO.Error -import System.IO.Unsafe - ( unsafeInterleaveIO ) -import qualified Control.Exception as Exception - -import Foreign.C.Error (Errno (..), ePIPE) -import Data.Time.Clock.POSIX (getPOSIXTime, POSIXTime) -import Numeric (showFFloat) -import Distribution.Compat.Process (createProcess, rawSystem, runInteractiveProcess) -import System.Process - ( ProcessHandle - , showCommandForUser, waitForProcess) -import qualified System.Process as Process -import qualified GHC.IO.Exception as GHC - -import qualified Text.PrettyPrint as Disp - --- We only get our own version number when we're building with ourselves -cabalVersion :: Version -#if defined(BOOTSTRAPPED_CABAL) -cabalVersion = mkVersion' Paths_Cabal.version -#elif defined(CABAL_VERSION) -cabalVersion = mkVersion [CABAL_VERSION] -#else -cabalVersion = mkVersion [3,0] --used when bootstrapping -#endif - --- ---------------------------------------------------------------------------- --- Exception and logging utils - --- Cabal's logging infrastructure has a few constraints: --- --- * We must make all logging formatting and emissions decisions based --- on the 'Verbosity' parameter, which is the only parameter that is --- plumbed to enough call-sites to actually be used for this matter. --- (One of Cabal's "big mistakes" is to have never have defined a --- monad of its own.) --- --- * When we 'die', we must raise an IOError. This a backwards --- compatibility consideration, because that's what we've raised --- previously, and if we change to any other exception type, --- exception handlers which match on IOError will no longer work. --- One case where it is known we rely on IOError being catchable --- is 'readPkgConfigDb' in cabal-install; there may be other --- user code that also assumes this. --- --- * The 'topHandler' does not know what 'Verbosity' is, because --- it gets called before we've done command line parsing (where --- the 'Verbosity' parameter would come from). --- --- This leads to two big architectural choices: --- --- * Although naively we might imagine 'Verbosity' to be a simple --- enumeration type, actually it is a full-on abstract data type --- that may contain arbitrarily complex information. At the --- moment, it is fully representable as a string, but we might --- eventually also use verbosity to let users register their --- own logging handler. --- --- * When we call 'die', we perform all the formatting and addition --- of extra information we need, and then ship this in the IOError --- to the top-level handler. Here are alternate designs that --- don't work: --- --- a) Ship the unformatted info to the handler. This doesn't --- work because at the point the handler gets the message, --- we've lost call stacks, and even if we did, we don't have access --- to 'Verbosity' to decide whether or not to render it. --- --- b) Print the information at the 'die' site, then raise an --- error. This means that if the exception is subsequently --- caught by a handler, we will still have emitted the output, --- which is not the correct behavior. --- --- For the top-level handler to "know" that an error message --- contains one of these fully formatted packets, we set a sentinel --- in one of IOError's extra fields. This is handled by --- 'ioeSetVerbatim' and 'ioeGetVerbatim'. --- - -dieNoVerbosity :: String -> IO a -dieNoVerbosity msg - = ioError (userError msg) - where - _ = callStack -- TODO: Attach CallStack to exception - --- | Tag an 'IOError' whose error string should be output to the screen --- verbatim. -ioeSetVerbatim :: IOError -> IOError -ioeSetVerbatim e = ioeSetLocation e "dieVerbatim" - --- | Check if an 'IOError' should be output verbatim to screen. -ioeGetVerbatim :: IOError -> Bool -ioeGetVerbatim e = ioeGetLocation e == "dieVerbatim" - --- | Create a 'userError' whose error text will be output verbatim -verbatimUserError :: String -> IOError -verbatimUserError = ioeSetVerbatim . userError - -dieWithLocation' :: Verbosity -> FilePath -> Maybe Int -> String -> IO a -dieWithLocation' verbosity filename mb_lineno msg = withFrozenCallStack $ do - ts <- getPOSIXTime - pname <- getProgName - ioError . verbatimUserError - . withMetadata ts AlwaysMark VerboseTrace verbosity - . wrapTextVerbosity verbosity - $ pname ++ ": " ++ - filename ++ (case mb_lineno of - Just lineno -> ":" ++ show lineno - Nothing -> "") ++ - ": " ++ msg - -die' :: Verbosity -> String -> IO a -die' verbosity msg = withFrozenCallStack $ do - ts <- getPOSIXTime - pname <- getProgName - ioError . verbatimUserError - . withMetadata ts AlwaysMark VerboseTrace verbosity - . wrapTextVerbosity verbosity - $ pname ++ ": " ++ msg - -dieNoWrap :: Verbosity -> String -> IO a -dieNoWrap verbosity msg = withFrozenCallStack $ do - -- TODO: should this have program name or not? - ts <- getPOSIXTime - ioError . verbatimUserError - . withMetadata ts AlwaysMark VerboseTrace verbosity - $ msg - --- | Given a block of IO code that may raise an exception, annotate --- it with the metadata from the current scope. Use this as close --- to external code that raises IO exceptions as possible, since --- this function unconditionally wraps the error message with a trace --- (so it is NOT idempotent.) -annotateIO :: Verbosity -> IO a -> IO a -annotateIO verbosity act = do - ts <- getPOSIXTime - modifyIOError (f ts) act - where - f ts ioe = ioeSetErrorString ioe - . withMetadata ts NeverMark VerboseTrace verbosity - $ ioeGetErrorString ioe - - -{-# NOINLINE topHandlerWith #-} -topHandlerWith :: forall a. (Exception.SomeException -> IO a) -> IO a -> IO a -topHandlerWith cont prog = do - -- By default, stderr to a terminal device is NoBuffering. But this - -- is *really slow* - hSetBuffering stderr LineBuffering - Exception.catches prog [ - Exception.Handler rethrowAsyncExceptions - , Exception.Handler rethrowExitStatus - , Exception.Handler handle - ] - where - -- Let async exceptions rise to the top for the default top-handler - rethrowAsyncExceptions :: Exception.AsyncException -> IO a - rethrowAsyncExceptions a = throwIO a - - -- ExitCode gets thrown asynchronously too, and we don't want to print it - rethrowExitStatus :: ExitCode -> IO a - rethrowExitStatus = throwIO - - -- Print all other exceptions - handle :: Exception.SomeException -> IO a - handle se = do - hFlush stdout - pname <- getProgName - hPutStr stderr (message pname se) - cont se - - message :: String -> Exception.SomeException -> String - message pname (Exception.SomeException se) = - case cast se :: Maybe Exception.IOException of - Just ioe - | ioeGetVerbatim ioe -> - -- Use the message verbatim - ioeGetErrorString ioe ++ "\n" - | isUserError ioe -> - let file = case ioeGetFileName ioe of - Nothing -> "" - Just path -> path ++ location ++ ": " - location = case ioeGetLocation ioe of - l@(n:_) | isDigit n -> ':' : l - _ -> "" - detail = ioeGetErrorString ioe - in wrapText (pname ++ ": " ++ file ++ detail) - _ -> - displaySomeException se ++ "\n" - --- | BC wrapper around 'Exception.displayException'. -displaySomeException :: Exception.Exception e => e -> String -displaySomeException se = -#if __GLASGOW_HASKELL__ < 710 - show se -#else - Exception.displayException se -#endif - -topHandler :: IO a -> IO a -topHandler prog = topHandlerWith (const $ exitWith (ExitFailure 1)) prog - -verbosityHandle :: Verbosity -> Handle -verbosityHandle verbosity - | isVerboseStderr verbosity = stderr - | otherwise = stdout - --- | Non fatal conditions that may be indicative of an error or problem. --- --- We display these at the 'normal' verbosity level. --- -warn :: Verbosity -> String -> IO () -warn verbosity msg = withFrozenCallStack $ do - when (verbosity >= normal) $ do - ts <- getPOSIXTime - hFlush stdout - hPutStr stderr . withMetadata ts NormalMark FlagTrace verbosity - . wrapTextVerbosity verbosity - $ "Warning: " ++ msg - --- | Useful status messages. --- --- We display these at the 'normal' verbosity level. --- --- This is for the ordinary helpful status messages that users see. Just --- enough information to know that things are working but not floods of detail. --- -notice :: Verbosity -> String -> IO () -notice verbosity msg = withFrozenCallStack $ do - when (verbosity >= normal) $ do - let h = verbosityHandle verbosity - ts <- getPOSIXTime - hPutStr h - $ withMetadata ts NormalMark FlagTrace verbosity - $ wrapTextVerbosity verbosity - $ msg - --- | Display a message at 'normal' verbosity level, but without --- wrapping. --- -noticeNoWrap :: Verbosity -> String -> IO () -noticeNoWrap verbosity msg = withFrozenCallStack $ do - when (verbosity >= normal) $ do - let h = verbosityHandle verbosity - ts <- getPOSIXTime - hPutStr h . withMetadata ts NormalMark FlagTrace verbosity $ msg - --- | Pretty-print a 'Disp.Doc' status message at 'normal' verbosity --- level. Use this if you need fancy formatting. --- -noticeDoc :: Verbosity -> Disp.Doc -> IO () -noticeDoc verbosity msg = withFrozenCallStack $ do - when (verbosity >= normal) $ do - let h = verbosityHandle verbosity - ts <- getPOSIXTime - hPutStr h - $ withMetadata ts NormalMark FlagTrace verbosity - $ Disp.renderStyle defaultStyle - $ msg - --- | Display a "setup status message". Prefer using setupMessage' --- if possible. --- -setupMessage :: Verbosity -> String -> PackageIdentifier -> IO () -setupMessage verbosity msg pkgid = withFrozenCallStack $ do - noticeNoWrap verbosity (msg ++ ' ': prettyShow pkgid ++ "...") - --- | More detail on the operation of some action. --- --- We display these messages when the verbosity level is 'verbose' --- -info :: Verbosity -> String -> IO () -info verbosity msg = withFrozenCallStack $ - when (verbosity >= verbose) $ do - let h = verbosityHandle verbosity - ts <- getPOSIXTime - hPutStr h - $ withMetadata ts NeverMark FlagTrace verbosity - $ wrapTextVerbosity verbosity - $ msg - -infoNoWrap :: Verbosity -> String -> IO () -infoNoWrap verbosity msg = withFrozenCallStack $ - when (verbosity >= verbose) $ do - let h = verbosityHandle verbosity - ts <- getPOSIXTime - hPutStr h - $ withMetadata ts NeverMark FlagTrace verbosity - $ msg - --- | Detailed internal debugging information --- --- We display these messages when the verbosity level is 'deafening' --- -debug :: Verbosity -> String -> IO () -debug verbosity msg = withFrozenCallStack $ - when (verbosity >= deafening) $ do - let h = verbosityHandle verbosity - ts <- getPOSIXTime - hPutStr h $ withMetadata ts NeverMark FlagTrace verbosity - $ wrapTextVerbosity verbosity - $ msg - -- ensure that we don't lose output if we segfault/infinite loop - hFlush stdout - --- | A variant of 'debug' that doesn't perform the automatic line --- wrapping. Produces better output in some cases. -debugNoWrap :: Verbosity -> String -> IO () -debugNoWrap verbosity msg = withFrozenCallStack $ - when (verbosity >= deafening) $ do - let h = verbosityHandle verbosity - ts <- getPOSIXTime - hPutStr h - $ withMetadata ts NeverMark FlagTrace verbosity - $ msg - -- ensure that we don't lose output if we segfault/infinite loop - hFlush stdout - --- | Perform an IO action, catching any IO exceptions and printing an error --- if one occurs. -chattyTry :: String -- ^ a description of the action we were attempting - -> IO () -- ^ the action itself - -> IO () -chattyTry desc action = - catchIO action $ \exception -> - hPutStrLn stderr $ "Error while " ++ desc ++ ": " ++ show exception - --- | Run an IO computation, returning @e@ if it raises a "file --- does not exist" error. -handleDoesNotExist :: a -> IO a -> IO a -handleDoesNotExist e = - Exception.handleJust - (\ioe -> if isDoesNotExistError ioe then Just ioe else Nothing) - (\_ -> return e) - --- ----------------------------------------------------------------------------- --- Helper functions - --- | Wraps text unless the @+nowrap@ verbosity flag is active -wrapTextVerbosity :: Verbosity -> String -> String -wrapTextVerbosity verb - | isVerboseNoWrap verb = withTrailingNewline - | otherwise = withTrailingNewline . wrapText - - --- | Prepends a timestamp if @+timestamp@ verbosity flag is set --- --- This is used by 'withMetadata' --- -withTimestamp :: Verbosity -> POSIXTime -> String -> String -withTimestamp v ts msg - | isVerboseTimestamp v = msg' - | otherwise = msg -- no-op - where - msg' = case lines msg of - [] -> tsstr "\n" - l1:rest -> unlines (tsstr (' ':l1) : map (contpfx++) rest) - - -- format timestamp to be prepended to first line with msec precision - tsstr = showFFloat (Just 3) (realToFrac ts :: Double) - - -- continuation prefix for subsequent lines of msg - contpfx = replicate (length (tsstr " ")) ' ' - --- | Wrap output with a marker if @+markoutput@ verbosity flag is set. --- --- NB: Why is markoutput done with start/end markers, and not prefixes? --- Markers are more convenient to add (if we want to add prefixes, --- we have to 'lines' and then 'map'; here's it's just some --- concatenates). Note that even in the prefix case, we can't --- guarantee that the markers are unambiguous, because some of --- Cabal's output comes straight from external programs, where --- we don't have the ability to interpose on the output. --- --- This is used by 'withMetadata' --- -withOutputMarker :: Verbosity -> String -> String -withOutputMarker v xs | not (isVerboseMarkOutput v) = xs -withOutputMarker _ "" = "" -- Minor optimization, don't mark uselessly -withOutputMarker _ xs = - "-----BEGIN CABAL OUTPUT-----\n" ++ - withTrailingNewline xs ++ - "-----END CABAL OUTPUT-----\n" - --- | Append a trailing newline to a string if it does not --- already have a trailing newline. --- -withTrailingNewline :: String -> String -withTrailingNewline "" = "" -withTrailingNewline (x:xs) = x : go x xs - where - go _ (c:cs) = c : go c cs - go '\n' "" = "" - go _ "" = "\n" - --- | Prepend a call-site and/or call-stack based on Verbosity --- -withCallStackPrefix :: WithCallStack (TraceWhen -> Verbosity -> String -> String) -withCallStackPrefix tracer verbosity s = withFrozenCallStack $ - (if isVerboseCallSite verbosity - then parentSrcLocPrefix ++ - -- Hack: need a newline before starting output marker :( - if isVerboseMarkOutput verbosity - then "\n" - else "" - else "") ++ - (case traceWhen verbosity tracer of - Just pre -> pre ++ prettyCallStack callStack ++ "\n" - Nothing -> "") ++ - s - --- | When should we emit the call stack? We always emit --- for internal errors, emit the trace for errors when we --- are in verbose mode, and otherwise only emit it if --- explicitly asked for using the @+callstack@ verbosity --- flag. (At the moment, 'AlwaysTrace' is not used. --- -data TraceWhen - = AlwaysTrace - | VerboseTrace - | FlagTrace - deriving (Eq) - --- | Determine if we should emit a call stack. --- If we trace, it also emits any prefix we should append. -traceWhen :: Verbosity -> TraceWhen -> Maybe String -traceWhen _ AlwaysTrace = Just "" -traceWhen v VerboseTrace | v >= verbose = Just "" -traceWhen v FlagTrace | isVerboseCallStack v = Just "----\n" -traceWhen _ _ = Nothing - --- | When should we output the marker? Things like 'die' --- always get marked, but a 'NormalMark' will only be --- output if we're not a quiet verbosity. --- -data MarkWhen = AlwaysMark | NormalMark | NeverMark - --- | Add all necessary metadata to a logging message --- -withMetadata :: WithCallStack (POSIXTime -> MarkWhen -> TraceWhen -> Verbosity -> String -> String) -withMetadata ts marker tracer verbosity x = withFrozenCallStack $ - -- NB: order matters. Output marker first because we - -- don't want to capture call stacks. - withTrailingNewline - . withCallStackPrefix tracer verbosity - . (case marker of - AlwaysMark -> withOutputMarker verbosity - NormalMark | not (isVerboseQuiet verbosity) - -> withOutputMarker verbosity - | otherwise - -> id - NeverMark -> id) - -- Clear out any existing markers - . clearMarkers - . withTimestamp verbosity ts - $ x - -clearMarkers :: String -> String -clearMarkers s = unlines . filter isMarker $ lines s - where - isMarker "-----BEGIN CABAL OUTPUT-----" = False - isMarker "-----END CABAL OUTPUT-----" = False - isMarker _ = True - --- ----------------------------------------------------------------------------- --- rawSystem variants -maybeExit :: IO ExitCode -> IO () -maybeExit cmd = do - res <- cmd - unless (res == ExitSuccess) $ exitWith res - - - -printRawCommandAndArgs :: Verbosity -> FilePath -> [String] -> IO () -printRawCommandAndArgs verbosity path args = withFrozenCallStack $ - printRawCommandAndArgsAndEnv verbosity path args Nothing Nothing - -printRawCommandAndArgsAndEnv :: Verbosity - -> FilePath - -> [String] - -> Maybe FilePath - -> Maybe [(String, String)] - -> IO () -printRawCommandAndArgsAndEnv verbosity path args mcwd menv = do - case menv of - Just env -> debugNoWrap verbosity ("Environment: " ++ show env) - Nothing -> return () - case mcwd of - Just cwd -> debugNoWrap verbosity ("Working directory: " ++ show cwd) - Nothing -> return () - infoNoWrap verbosity (showCommandForUser path args) - --- Exit with the same exit code if the subcommand fails -rawSystemExit :: Verbosity -> FilePath -> [String] -> IO () -rawSystemExit verbosity path args = withFrozenCallStack $ do - printRawCommandAndArgs verbosity path args - hFlush stdout - exitcode <- rawSystem path args - unless (exitcode == ExitSuccess) $ do - debug verbosity $ path ++ " returned " ++ show exitcode - exitWith exitcode - -rawSystemExitCode :: Verbosity -> FilePath -> [String] -> IO ExitCode -rawSystemExitCode verbosity path args = withFrozenCallStack $ do - printRawCommandAndArgs verbosity path args - hFlush stdout - exitcode <- rawSystem path args - unless (exitcode == ExitSuccess) $ do - debug verbosity $ path ++ " returned " ++ show exitcode - return exitcode - -rawSystemExitWithEnv :: Verbosity - -> FilePath - -> [String] - -> [(String, String)] - -> IO () -rawSystemExitWithEnv verbosity path args env = withFrozenCallStack $ do - printRawCommandAndArgsAndEnv verbosity path args Nothing (Just env) - hFlush stdout - (_,_,_,ph) <- createProcess $ - (Process.proc path args) { Process.env = (Just env) -#ifdef MIN_VERSION_process -#if MIN_VERSION_process(1,2,0) --- delegate_ctlc has been added in process 1.2, and we still want to be able to --- bootstrap GHC on systems not having that version - , Process.delegate_ctlc = True -#endif -#endif - } - exitcode <- waitForProcess ph - unless (exitcode == ExitSuccess) $ do - debug verbosity $ path ++ " returned " ++ show exitcode - exitWith exitcode - --- Closes the passed in handles before returning. -rawSystemIOWithEnv :: Verbosity - -> FilePath - -> [String] - -> Maybe FilePath -- ^ New working dir or inherit - -> Maybe [(String, String)] -- ^ New environment or inherit - -> Maybe Handle -- ^ stdin - -> Maybe Handle -- ^ stdout - -> Maybe Handle -- ^ stderr - -> IO ExitCode -rawSystemIOWithEnv verbosity path args mcwd menv inp out err = withFrozenCallStack $ do - (_,_,_,ph) <- createProcessWithEnv verbosity path args mcwd menv - (mbToStd inp) (mbToStd out) (mbToStd err) - exitcode <- waitForProcess ph - unless (exitcode == ExitSuccess) $ do - debug verbosity $ path ++ " returned " ++ show exitcode - return exitcode - where - mbToStd :: Maybe Handle -> Process.StdStream - mbToStd = maybe Process.Inherit Process.UseHandle - -rawSystemIOWithEnvAndAction - :: Verbosity - -> FilePath - -> [String] - -> Maybe FilePath -- ^ New working dir or inherit - -> Maybe [(String, String)] -- ^ New environment or inherit - -> IO a -- ^ action to perform after process is created, but before 'waitForProcess'. - -> Maybe Handle -- ^ stdin - -> Maybe Handle -- ^ stdout - -> Maybe Handle -- ^ stderr - -> IO (ExitCode, a) -rawSystemIOWithEnvAndAction verbosity path args mcwd menv action inp out err = withFrozenCallStack $ do - (_,_,_,ph) <- createProcessWithEnv verbosity path args mcwd menv - (mbToStd inp) (mbToStd out) (mbToStd err) - a <- action - exitcode <- waitForProcess ph - unless (exitcode == ExitSuccess) $ do - debug verbosity $ path ++ " returned " ++ show exitcode - return (exitcode, a) - where - mbToStd :: Maybe Handle -> Process.StdStream - mbToStd = maybe Process.Inherit Process.UseHandle - -createProcessWithEnv :: - Verbosity - -> FilePath - -> [String] - -> Maybe FilePath -- ^ New working dir or inherit - -> Maybe [(String, String)] -- ^ New environment or inherit - -> Process.StdStream -- ^ stdin - -> Process.StdStream -- ^ stdout - -> Process.StdStream -- ^ stderr - -> IO (Maybe Handle, Maybe Handle, Maybe Handle,ProcessHandle) - -- ^ Any handles created for stdin, stdout, or stderr - -- with 'CreateProcess', and a handle to the process. -createProcessWithEnv verbosity path args mcwd menv inp out err = withFrozenCallStack $ do - printRawCommandAndArgsAndEnv verbosity path args mcwd menv - hFlush stdout - (inp', out', err', ph) <- createProcess $ - (Process.proc path args) { - Process.cwd = mcwd - , Process.env = menv - , Process.std_in = inp - , Process.std_out = out - , Process.std_err = err -#ifdef MIN_VERSION_process -#if MIN_VERSION_process(1,2,0) --- delegate_ctlc has been added in process 1.2, and we still want to be able to --- bootstrap GHC on systems not having that version - , Process.delegate_ctlc = True -#endif -#endif - } - return (inp', out', err', ph) - --- | Run a command and return its output. --- --- The output is assumed to be text in the locale encoding. --- -rawSystemStdout :: forall mode. KnownIODataMode mode => Verbosity -> FilePath -> [String] -> IO mode -rawSystemStdout verbosity path args = withFrozenCallStack $ do - (output, errors, exitCode) <- rawSystemStdInOut verbosity path args - Nothing Nothing Nothing (IOData.iodataMode :: IODataMode mode) - when (exitCode /= ExitSuccess) $ - die' verbosity errors - return output - --- | Run a command and return its output, errors and exit status. Optionally --- also supply some input. Also provides control over whether the binary/text --- mode of the input and output. --- -rawSystemStdInOut :: KnownIODataMode mode - => Verbosity - -> FilePath -- ^ Program location - -> [String] -- ^ Arguments - -> Maybe FilePath -- ^ New working dir or inherit - -> Maybe [(String, String)] -- ^ New environment or inherit - -> Maybe IOData -- ^ input text and binary mode - -> IODataMode mode -- ^ iodata mode, acts as proxy - -> IO (mode, String, ExitCode) -- ^ output, errors, exit -rawSystemStdInOut verbosity path args mcwd menv input _ = withFrozenCallStack $ do - printRawCommandAndArgs verbosity path args - - Exception.bracket - (runInteractiveProcess path args mcwd menv) - (\(inh,outh,errh,_) -> hClose inh >> hClose outh >> hClose errh) - $ \(inh,outh,errh,pid) -> do - - -- output mode depends on what the caller wants - -- but the errors are always assumed to be text (in the current locale) - hSetBinaryMode errh False - - -- fork off a couple threads to pull on the stderr and stdout - -- so if the process writes to stderr we do not block. - - withAsyncNF (hGetContents errh) $ \errA -> withAsyncNF (IOData.hGetIODataContents outh) $ \outA -> do - -- push all the input, if any - ignoreSigPipe $ case input of - Nothing -> hClose inh - Just inputData -> IOData.hPutContents inh inputData - - -- wait for both to finish - mberr1 <- waitCatch outA - mberr2 <- waitCatch errA - - -- wait for the program to terminate - exitcode <- waitForProcess pid - - -- get the stderr, so it can be added to error message - err <- reportOutputIOError mberr2 - - unless (exitcode == ExitSuccess) $ - debug verbosity $ path ++ " returned " ++ show exitcode - ++ if null err then "" else - " with error message:\n" ++ err - ++ case input of - Nothing -> "" - Just d | IOData.null d -> "" - Just (IODataText inp) -> "\nstdin input:\n" ++ inp - Just (IODataBinary inp) -> "\nstdin input (binary):\n" ++ show inp - - -- Check if we hit an exception while consuming the output - -- (e.g. a text decoding error) - out <- reportOutputIOError mberr1 - - return (out, err, exitcode) - where - reportOutputIOError :: Either Exception.SomeException a -> IO a - reportOutputIOError (Right x) = return x - reportOutputIOError (Left exc) = case fromException exc of - Just ioe -> throwIO (ioeSetFileName ioe ("output of " ++ path)) - Nothing -> throwIO exc - - ignoreSigPipe :: IO () -> IO () - ignoreSigPipe = Exception.handle $ \e -> case e of - GHC.IOError { GHC.ioe_type = GHC.ResourceVanished, GHC.ioe_errno = Just ioe } - | Errno ioe == ePIPE -> return () - _ -> throwIO e - --- | Look for a program and try to find it's version number. It can accept --- either an absolute path or the name of a program binary, in which case we --- will look for the program on the path. --- -findProgramVersion :: String -- ^ version args - -> (String -> String) -- ^ function to select version - -- number from program output - -> Verbosity - -> FilePath -- ^ location - -> IO (Maybe Version) -findProgramVersion versionArg selectVersion verbosity path = withFrozenCallStack $ do - str <- rawSystemStdout verbosity path [versionArg] - `catchIO` (\_ -> return "") - `catchExit` (\_ -> return "") - let version :: Maybe Version - version = simpleParsec (selectVersion str) - case version of - Nothing -> warn verbosity $ "cannot determine version of " ++ path - ++ " :\n" ++ show str - Just v -> debug verbosity $ path ++ " is version " ++ prettyShow v - return version - - --- | Like the Unix xargs program. Useful for when we've got very long command --- lines that might overflow an OS limit on command line length and so you --- need to invoke a command multiple times to get all the args in. --- --- Use it with either of the rawSystem variants above. For example: --- --- > xargs (32*1024) (rawSystemExit verbosity) prog fixedArgs bigArgs --- -xargs :: Int -> ([String] -> IO ()) - -> [String] -> [String] -> IO () -xargs maxSize rawSystemFun fixedArgs bigArgs = - let fixedArgSize = sum (map length fixedArgs) + length fixedArgs - chunkSize = maxSize - fixedArgSize - in traverse_ (rawSystemFun . (fixedArgs ++)) (chunks chunkSize bigArgs) - - where chunks len = unfoldr $ \s -> - if null s then Nothing - else Just (chunk [] len s) - - chunk acc _ [] = (reverse acc,[]) - chunk acc len (s:ss) - | len' < len = chunk (s:acc) (len-len'-1) ss - | otherwise = (reverse acc, s:ss) - where len' = length s - --- ------------------------------------------------------------ --- * File Utilities --- ------------------------------------------------------------ - ----------------- --- Finding files - - -{-# DEPRECATED findFile "Use findFileEx instead. This symbol will be removed in Cabal 3.2 (est. December 2019)" #-} -findFile :: [FilePath] -- ^search locations - -> FilePath -- ^File Name - -> IO FilePath -findFile = findFileEx normal - --- | Find a file by looking in a search path. The file path must match exactly. --- --- @since 3.4.0.0 -findFileCwd - :: Verbosity - -> FilePath -- ^ cwd - -> [FilePath] -- ^ relative search location - -> FilePath -- ^ File Name - -> IO FilePath -findFileCwd verbosity cwd searchPath fileName = - findFirstFile (cwd ) - [ path fileName - | path <- nub searchPath] - >>= maybe (die' verbosity $ fileName ++ " doesn't exist") return - --- | Find a file by looking in a search path. The file path must match exactly. --- -findFileEx :: Verbosity - -> [FilePath] -- ^search locations - -> FilePath -- ^File Name - -> IO FilePath -findFileEx verbosity searchPath fileName = - findFirstFile id - [ path fileName - | path <- nub searchPath] - >>= maybe (die' verbosity $ fileName ++ " doesn't exist") return - --- | Find a file by looking in a search path with one of a list of possible --- file extensions. The file base name should be given and it will be tried --- with each of the extensions in each element of the search path. --- -findFileWithExtension :: [String] - -> [FilePath] - -> FilePath - -> IO (Maybe FilePath) -findFileWithExtension extensions searchPath baseName = - findFirstFile id - [ path baseName <.> ext - | path <- nub searchPath - , ext <- nub extensions ] - --- | @since 3.4.0.0 -findFileCwdWithExtension - :: FilePath - -> [String] - -> [FilePath] - -> FilePath - -> IO (Maybe FilePath) -findFileCwdWithExtension cwd extensions searchPath baseName = - findFirstFile (cwd ) - [ path baseName <.> ext - | path <- nub searchPath - , ext <- nub extensions ] - --- | @since 3.4.0.0 -findAllFilesCwdWithExtension - :: FilePath -- ^ cwd - -> [String] -- ^ extensions - -> [FilePath] -- ^ relative search locations - -> FilePath -- ^ basename - -> IO [FilePath] -findAllFilesCwdWithExtension cwd extensions searchPath basename = - findAllFiles (cwd ) - [ path basename <.> ext - | path <- nub searchPath - , ext <- nub extensions ] - -findAllFilesWithExtension :: [String] - -> [FilePath] - -> FilePath - -> IO [FilePath] -findAllFilesWithExtension extensions searchPath basename = - findAllFiles id - [ path basename <.> ext - | path <- nub searchPath - , ext <- nub extensions ] - --- | Like 'findFileWithExtension' but returns which element of the search path --- the file was found in, and the file path relative to that base directory. --- -findFileWithExtension' :: [String] - -> [FilePath] - -> FilePath - -> IO (Maybe (FilePath, FilePath)) -findFileWithExtension' extensions searchPath baseName = - findFirstFile (uncurry ()) - [ (path, baseName <.> ext) - | path <- nub searchPath - , ext <- nub extensions ] - -findFirstFile :: (a -> FilePath) -> [a] -> IO (Maybe a) -findFirstFile file = findFirst - where findFirst [] = return Nothing - findFirst (x:xs) = do exists <- doesFileExist (file x) - if exists - then return (Just x) - else findFirst xs - -findAllFiles :: (a -> FilePath) -> [a] -> IO [a] -findAllFiles file = filterM (doesFileExist . file) - - -{-# DEPRECATED findModuleFiles "Use findModuleFilesEx instead. This symbol will be removed in Cabal 3.2 (est. December 2019)" #-} -findModuleFiles :: [FilePath] -- ^ build prefix (location of objects) - -> [String] -- ^ search suffixes - -> [ModuleName] -- ^ modules - -> IO [(FilePath, FilePath)] -findModuleFiles = findModuleFilesEx normal - --- | Finds the files corresponding to a list of Haskell module names. --- --- As 'findModuleFile' but for a list of module names. --- -findModuleFilesEx :: Verbosity - -> [FilePath] -- ^ build prefix (location of objects) - -> [String] -- ^ search suffixes - -> [ModuleName] -- ^ modules - -> IO [(FilePath, FilePath)] -findModuleFilesEx verbosity searchPath extensions moduleNames = - traverse (findModuleFileEx verbosity searchPath extensions) moduleNames - -{-# DEPRECATED findModuleFile "Use findModuleFileEx instead. This symbol will be removed in Cabal 3.2 (est. December 2019)" #-} -findModuleFile :: [FilePath] -- ^ build prefix (location of objects) - -> [String] -- ^ search suffixes - -> ModuleName -- ^ module - -> IO (FilePath, FilePath) -findModuleFile = findModuleFileEx normal - --- | Find the file corresponding to a Haskell module name. --- --- This is similar to 'findFileWithExtension'' but specialised to a module --- name. The function fails if the file corresponding to the module is missing. --- -findModuleFileEx :: Verbosity - -> [FilePath] -- ^ build prefix (location of objects) - -> [String] -- ^ search suffixes - -> ModuleName -- ^ module - -> IO (FilePath, FilePath) -findModuleFileEx verbosity searchPath extensions mod_name = - maybe notFound return - =<< findFileWithExtension' extensions searchPath - (ModuleName.toFilePath mod_name) - where - notFound = die' verbosity $ - "Error: Could not find module: " ++ prettyShow mod_name - ++ " with any suffix: " ++ show extensions - ++ " in the search path: " ++ show searchPath - --- | List all the files in a directory and all subdirectories. --- --- The order places files in sub-directories after all the files in their --- parent directories. The list is generated lazily so is not well defined if --- the source directory structure changes before the list is used. --- -getDirectoryContentsRecursive :: FilePath -> IO [FilePath] -getDirectoryContentsRecursive topdir = recurseDirectories [""] - where - recurseDirectories :: [FilePath] -> IO [FilePath] - recurseDirectories [] = return [] - recurseDirectories (dir:dirs) = unsafeInterleaveIO $ do - (files, dirs') <- collect [] [] =<< getDirectoryContents (topdir dir) - files' <- recurseDirectories (dirs' ++ dirs) - return (files ++ files') - - where - collect files dirs' [] = return (reverse files - ,reverse dirs') - collect files dirs' (entry:entries) | ignore entry - = collect files dirs' entries - collect files dirs' (entry:entries) = do - let dirEntry = dir entry - isDirectory <- doesDirectoryExist (topdir dirEntry) - if isDirectory - then collect files (dirEntry:dirs') entries - else collect (dirEntry:files) dirs' entries - - ignore ['.'] = True - ignore ['.', '.'] = True - ignore _ = False - ------------------------- --- Environment variables - --- | Is this directory in the system search path? -isInSearchPath :: FilePath -> IO Bool -isInSearchPath path = fmap (elem path) getSearchPath - -addLibraryPath :: OS - -> [FilePath] - -> [(String,String)] - -> [(String,String)] -addLibraryPath os paths = addEnv - where - pathsString = intercalate [searchPathSeparator] paths - ldPath = case os of - OSX -> "DYLD_LIBRARY_PATH" - _ -> "LD_LIBRARY_PATH" - - addEnv [] = [(ldPath,pathsString)] - addEnv ((key,value):xs) - | key == ldPath = - if null value - then (key,pathsString):xs - else (key,value ++ (searchPathSeparator:pathsString)):xs - | otherwise = (key,value):addEnv xs - --------------------- --- Modification time - --- | Compare the modification times of two files to see if the first is newer --- than the second. The first file must exist but the second need not. --- The expected use case is when the second file is generated using the first. --- In this use case, if the result is True then the second file is out of date. --- -moreRecentFile :: FilePath -> FilePath -> IO Bool -moreRecentFile a b = do - exists <- doesFileExist b - if not exists - then return True - else do tb <- getModificationTime b - ta <- getModificationTime a - return (ta > tb) - --- | Like 'moreRecentFile', but also checks that the first file exists. -existsAndIsMoreRecentThan :: FilePath -> FilePath -> IO Bool -existsAndIsMoreRecentThan a b = do - exists <- doesFileExist a - if not exists - then return False - else a `moreRecentFile` b - ----------------------------------------- --- Copying and installing files and dirs - --- | Same as 'createDirectoryIfMissing' but logs at higher verbosity levels. --- -createDirectoryIfMissingVerbose :: Verbosity - -> Bool -- ^ Create its parents too? - -> FilePath - -> IO () -createDirectoryIfMissingVerbose verbosity create_parents path0 - | create_parents = withFrozenCallStack $ createDirs (parents path0) - | otherwise = withFrozenCallStack $ createDirs (take 1 (parents path0)) - where - parents = reverse . scanl1 () . splitDirectories . normalise - - createDirs [] = return () - createDirs (dir:[]) = createDir dir throwIO - createDirs (dir:dirs) = - createDir dir $ \_ -> do - createDirs dirs - createDir dir throwIO - - createDir :: FilePath -> (IOException -> IO ()) -> IO () - createDir dir notExistHandler = do - r <- tryIO $ createDirectoryVerbose verbosity dir - case (r :: Either IOException ()) of - Right () -> return () - Left e - | isDoesNotExistError e -> notExistHandler e - -- createDirectory (and indeed POSIX mkdir) does not distinguish - -- between a dir already existing and a file already existing. So we - -- check for it here. Unfortunately there is a slight race condition - -- here, but we think it is benign. It could report an exception in - -- the case that the dir did exist but another process deletes the - -- directory and creates a file in its place before we can check - -- that the directory did indeed exist. - | isAlreadyExistsError e -> (do - isDir <- doesDirectoryExist dir - unless isDir $ throwIO e - ) `catchIO` ((\_ -> return ()) :: IOException -> IO ()) - | otherwise -> throwIO e - -createDirectoryVerbose :: Verbosity -> FilePath -> IO () -createDirectoryVerbose verbosity dir = withFrozenCallStack $ do - info verbosity $ "creating " ++ dir - createDirectory dir - setDirOrdinary dir - --- | Copies a file without copying file permissions. The target file is created --- with default permissions. Any existing target file is replaced. --- --- At higher verbosity levels it logs an info message. --- -copyFileVerbose :: Verbosity -> FilePath -> FilePath -> IO () -copyFileVerbose verbosity src dest = withFrozenCallStack $ do - info verbosity ("copy " ++ src ++ " to " ++ dest) - copyFile src dest - --- | Install an ordinary file. This is like a file copy but the permissions --- are set appropriately for an installed file. On Unix it is \"-rw-r--r--\" --- while on Windows it uses the default permissions for the target directory. --- -installOrdinaryFile :: Verbosity -> FilePath -> FilePath -> IO () -installOrdinaryFile verbosity src dest = withFrozenCallStack $ do - info verbosity ("Installing " ++ src ++ " to " ++ dest) - copyOrdinaryFile src dest - --- | Install an executable file. This is like a file copy but the permissions --- are set appropriately for an installed file. On Unix it is \"-rwxr-xr-x\" --- while on Windows it uses the default permissions for the target directory. --- -installExecutableFile :: Verbosity -> FilePath -> FilePath -> IO () -installExecutableFile verbosity src dest = withFrozenCallStack $ do - info verbosity ("Installing executable " ++ src ++ " to " ++ dest) - copyExecutableFile src dest - --- | Install a file that may or not be executable, preserving permissions. -installMaybeExecutableFile :: Verbosity -> FilePath -> FilePath -> IO () -installMaybeExecutableFile verbosity src dest = withFrozenCallStack $ do - perms <- getPermissions src - if (executable perms) --only checks user x bit - then installExecutableFile verbosity src dest - else installOrdinaryFile verbosity src dest - --- | Given a relative path to a file, copy it to the given directory, preserving --- the relative path and creating the parent directories if needed. -copyFileTo :: Verbosity -> FilePath -> FilePath -> IO () -copyFileTo verbosity dir file = withFrozenCallStack $ do - let targetFile = dir file - createDirectoryIfMissingVerbose verbosity True (takeDirectory targetFile) - installOrdinaryFile verbosity file targetFile - --- | Common implementation of 'copyFiles', 'installOrdinaryFiles', --- 'installExecutableFiles' and 'installMaybeExecutableFiles'. -copyFilesWith :: (Verbosity -> FilePath -> FilePath -> IO ()) - -> Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO () -copyFilesWith doCopy verbosity targetDir srcFiles = withFrozenCallStack $ do - - -- Create parent directories for everything - let dirs = map (targetDir ) . nub . map (takeDirectory . snd) $ srcFiles - traverse_ (createDirectoryIfMissingVerbose verbosity True) dirs - - -- Copy all the files - sequence_ [ let src = srcBase srcFile - dest = targetDir srcFile - in doCopy verbosity src dest - | (srcBase, srcFile) <- srcFiles ] - --- | Copies a bunch of files to a target directory, preserving the directory --- structure in the target location. The target directories are created if they --- do not exist. --- --- The files are identified by a pair of base directory and a path relative to --- that base. It is only the relative part that is preserved in the --- destination. --- --- For example: --- --- > copyFiles normal "dist/src" --- > [("", "src/Foo.hs"), ("dist/build/", "src/Bar.hs")] --- --- This would copy \"src\/Foo.hs\" to \"dist\/src\/src\/Foo.hs\" and --- copy \"dist\/build\/src\/Bar.hs\" to \"dist\/src\/src\/Bar.hs\". --- --- This operation is not atomic. Any IO failure during the copy (including any --- missing source files) leaves the target in an unknown state so it is best to --- use it with a freshly created directory so that it can be simply deleted if --- anything goes wrong. --- -copyFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO () -copyFiles v fp fs = withFrozenCallStack (copyFilesWith copyFileVerbose v fp fs) - --- | This is like 'copyFiles' but uses 'installOrdinaryFile'. --- -installOrdinaryFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO () -installOrdinaryFiles v fp fs = withFrozenCallStack (copyFilesWith installOrdinaryFile v fp fs) - --- | This is like 'copyFiles' but uses 'installExecutableFile'. --- -installExecutableFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] - -> IO () -installExecutableFiles v fp fs = withFrozenCallStack (copyFilesWith installExecutableFile v fp fs) - --- | This is like 'copyFiles' but uses 'installMaybeExecutableFile'. --- -installMaybeExecutableFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] - -> IO () -installMaybeExecutableFiles v fp fs = withFrozenCallStack (copyFilesWith installMaybeExecutableFile v fp fs) - --- | This installs all the files in a directory to a target location, --- preserving the directory layout. All the files are assumed to be ordinary --- rather than executable files. --- -installDirectoryContents :: Verbosity -> FilePath -> FilePath -> IO () -installDirectoryContents verbosity srcDir destDir = withFrozenCallStack $ do - info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.") - srcFiles <- getDirectoryContentsRecursive srcDir - installOrdinaryFiles verbosity destDir [ (srcDir, f) | f <- srcFiles ] - --- | Recursively copy the contents of one directory to another path. -copyDirectoryRecursive :: Verbosity -> FilePath -> FilePath -> IO () -copyDirectoryRecursive verbosity srcDir destDir = withFrozenCallStack $ do - info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.") - srcFiles <- getDirectoryContentsRecursive srcDir - copyFilesWith (const copyFile) verbosity destDir [ (srcDir, f) - | f <- srcFiles ] - -------------------- --- File permissions - --- | Like 'doesFileExist', but also checks that the file is executable. -doesExecutableExist :: FilePath -> IO Bool -doesExecutableExist f = do - exists <- doesFileExist f - if exists - then do perms <- getPermissions f - return (executable perms) - else return False - ---------------------------- --- Temporary files and dirs - --- | Advanced options for 'withTempFile' and 'withTempDirectory'. -data TempFileOptions = TempFileOptions { - optKeepTempFiles :: Bool -- ^ Keep temporary files? - } - -defaultTempFileOptions :: TempFileOptions -defaultTempFileOptions = TempFileOptions { optKeepTempFiles = False } - --- | Use a temporary filename that doesn't already exist. --- -withTempFile :: FilePath -- ^ Temp dir to create the file in - -> String -- ^ File name template. See 'openTempFile'. - -> (FilePath -> Handle -> IO a) -> IO a -withTempFile tmpDir template action = - withTempFileEx defaultTempFileOptions tmpDir template action - --- | A version of 'withTempFile' that additionally takes a 'TempFileOptions' --- argument. -withTempFileEx :: TempFileOptions - -> FilePath -- ^ Temp dir to create the file in - -> String -- ^ File name template. See 'openTempFile'. - -> (FilePath -> Handle -> IO a) -> IO a -withTempFileEx opts tmpDir template action = - Exception.bracket - (openTempFile tmpDir template) - (\(name, handle) -> do hClose handle - unless (optKeepTempFiles opts) $ - handleDoesNotExist () . removeFile $ name) - (withLexicalCallStack (\x -> uncurry action x)) - --- | Create and use a temporary directory. --- --- Creates a new temporary directory inside the given directory, making use --- of the template. The temp directory is deleted after use. For example: --- --- > withTempDirectory verbosity "src" "sdist." $ \tmpDir -> do ... --- --- The @tmpDir@ will be a new subdirectory of the given directory, e.g. --- @src/sdist.342@. --- -withTempDirectory :: Verbosity -> FilePath -> String -> (FilePath -> IO a) -> IO a -withTempDirectory verbosity targetDir template f = withFrozenCallStack $ - withTempDirectoryEx verbosity defaultTempFileOptions targetDir template - (withLexicalCallStack (\x -> f x)) - --- | A version of 'withTempDirectory' that additionally takes a --- 'TempFileOptions' argument. -withTempDirectoryEx :: Verbosity -> TempFileOptions - -> FilePath -> String -> (FilePath -> IO a) -> IO a -withTempDirectoryEx _verbosity opts targetDir template f = withFrozenCallStack $ - Exception.bracket - (createTempDirectory targetDir template) - (unless (optKeepTempFiles opts) - . handleDoesNotExist () . removeDirectoryRecursive) - (withLexicalCallStack (\x -> f x)) - ------------------------------------ --- Safely reading and writing files - --- | Write a file but only if it would have new content. If we would be writing --- the same as the existing content then leave the file as is so that we do not --- update the file's modification time. --- --- NB: Before Cabal-3.0 the file content was assumed to be --- ASCII-representable. Since Cabal-3.0 the file is assumed to be --- UTF-8 encoded. -rewriteFileEx :: Verbosity -> FilePath -> String -> IO () -rewriteFileEx verbosity path = - rewriteFileLBS verbosity path . toUTF8LBS - --- | Same as `rewriteFileEx` but for 'ByteString's. -rewriteFileLBS :: Verbosity -> FilePath -> BS.ByteString -> IO () -rewriteFileLBS verbosity path newContent = - flip catchIO mightNotExist $ do - existingContent <- annotateIO verbosity $ BS.readFile path - _ <- evaluate (BS.length existingContent) - unless (existingContent == newContent) $ - annotateIO verbosity $ - writeFileAtomic path newContent - where - mightNotExist e | isDoesNotExistError e - = annotateIO verbosity $ writeFileAtomic path newContent - | otherwise - = ioError e - - --- | The path name that represents the current directory. --- In Unix, it's @\".\"@, but this is system-specific. --- (E.g. AmigaOS uses the empty string @\"\"@ for the current directory.) -currentDir :: FilePath -currentDir = "." - -shortRelativePath :: FilePath -> FilePath -> FilePath -shortRelativePath from to = - case dropCommonPrefix (splitDirectories from) (splitDirectories to) of - (stuff, path) -> joinPath (map (const "..") stuff ++ path) - where - dropCommonPrefix :: Eq a => [a] -> [a] -> ([a],[a]) - dropCommonPrefix (x:xs) (y:ys) - | x == y = dropCommonPrefix xs ys - dropCommonPrefix xs ys = (xs,ys) - --- | Drop the extension if it's one of 'exeExtensions', or return the path --- unchanged. -dropExeExtension :: FilePath -> FilePath -dropExeExtension filepath = - -- System.FilePath's extension handling functions are horribly - -- inconsistent, consider: - -- - -- isExtensionOf "" "foo" == False but - -- isExtensionOf "" "foo." == True. - -- - -- On the other hand stripExtension doesn't remove the empty extension: - -- - -- stripExtension "" "foo." == Just "foo." - -- - -- Since by "" in exeExtensions we mean 'no extension' anyways we can - -- just always ignore it here. - let exts = [ ext | ext <- exeExtensions, ext /= "" ] in - fromMaybe filepath $ do - ext <- find (`FilePath.isExtensionOf` filepath) exts - ext `FilePath.stripExtension` filepath - --- | List of possible executable file extensions on the current build --- platform. -exeExtensions :: [String] -exeExtensions = case buildOS of - -- Possible improvement: on Windows, read the list of extensions from the - -- PATHEXT environment variable. By default PATHEXT is ".com; .exe; .bat; - -- .cmd". - Windows -> ["", "exe"] - Ghcjs -> ["", "exe"] - _ -> [""] - --- ------------------------------------------------------------ --- * Finding the description file --- ------------------------------------------------------------ - --- | Package description file (/pkgname/@.cabal@) -defaultPackageDesc :: Verbosity -> IO FilePath -defaultPackageDesc verbosity = tryFindPackageDesc verbosity currentDir - --- |Find a package description file in the given directory. Looks for --- @.cabal@ files. -findPackageDesc :: FilePath -- ^Where to look - -> IO (Either String FilePath) -- ^.cabal -findPackageDesc = findPackageDescCwd "." - --- | @since 3.4.0.0 -findPackageDescCwd - :: FilePath -- ^ project root - -> FilePath -- ^ relative directory - -> IO (Either String FilePath) -- ^ .cabal relative to the project root -findPackageDescCwd cwd dir - = do files <- getDirectoryContents (cwd dir) - -- to make sure we do not mistake a ~/.cabal/ dir for a .cabal - -- file we filter to exclude dirs and null base file names: - cabalFiles <- filterM (doesFileExist . snd) - [ (dir file, cwd dir file) - | file <- files - , let (name, ext) = splitExtension file - , not (null name) && ext == ".cabal" ] - case map fst cabalFiles of - [] -> return (Left noDesc) - [cabalFile] -> return (Right cabalFile) - multiple -> return (Left $ multiDesc multiple) - - where - noDesc :: String - noDesc = "No cabal file found.\n" - ++ "Please create a package description file .cabal" - - multiDesc :: [String] -> String - multiDesc l = "Multiple cabal files found.\n" - ++ "Please use only one of: " - ++ intercalate ", " l - --- |Like 'findPackageDesc', but calls 'die' in case of error. -tryFindPackageDesc :: Verbosity -> FilePath -> IO FilePath -tryFindPackageDesc verbosity dir = - either (die' verbosity) return =<< findPackageDesc dir - --- | Like 'findPackageDescCwd', but calls 'die' in case of error. --- --- @since 3.4.0.0 -tryFindPackageDescCwd :: Verbosity -> FilePath -> FilePath -> IO FilePath -tryFindPackageDescCwd verbosity cwd dir = - either (die' verbosity) return =<< findPackageDescCwd cwd dir - --- |Find auxiliary package information in the given directory. --- Looks for @.buildinfo@ files. -findHookedPackageDesc - :: Verbosity - -> FilePath -- ^Directory to search - -> IO (Maybe FilePath) -- ^/dir/@\/@/pkgname/@.buildinfo@, if present -findHookedPackageDesc verbosity dir = do - files <- getDirectoryContents dir - buildInfoFiles <- filterM doesFileExist - [ dir file - | file <- files - , let (name, ext) = splitExtension file - , not (null name) && ext == buildInfoExt ] - case buildInfoFiles of - [] -> return Nothing - [f] -> return (Just f) - _ -> die' verbosity ("Multiple files with extension " ++ buildInfoExt) - -buildInfoExt :: String -buildInfoExt = ".buildinfo" diff --git a/cabal/Cabal/Distribution/Simple/Utils/Json.hs b/cabal/Cabal/Distribution/Simple/Utils/Json.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Simple/Utils/Json.hs +++ /dev/null @@ -1,46 +0,0 @@ --- | Utility json lib for Cabal --- TODO: Remove it again. -module Distribution.Simple.Utils.Json - ( Json(..) - , renderJson - ) where - -data Json = JsonArray [Json] - | JsonBool !Bool - | JsonNull - | JsonNumber !Int - | JsonObject [(String, Json)] - | JsonString !String - -renderJson :: Json -> ShowS -renderJson (JsonArray objs) = - surround "[" "]" $ intercalate "," $ map renderJson objs -renderJson (JsonBool True) = showString "true" -renderJson (JsonBool False) = showString "false" -renderJson JsonNull = showString "null" -renderJson (JsonNumber n) = shows n -renderJson (JsonObject attrs) = - surround "{" "}" $ intercalate "," $ map render attrs - where - render (k,v) = (surround "\"" "\"" $ showString' k) . showString ":" . renderJson v -renderJson (JsonString s) = surround "\"" "\"" $ showString' s - -surround :: String -> String -> ShowS -> ShowS -surround begin end middle = showString begin . middle . showString end - -showString' :: String -> ShowS -showString' xs = showStringWorker xs - where - showStringWorker :: String -> ShowS - showStringWorker ('\"':as) = showString "\\\"" . showStringWorker as - showStringWorker ('\\':as) = showString "\\\\" . showStringWorker as - showStringWorker ('\'':as) = showString "\\\'" . showStringWorker as - showStringWorker (x:as) = showString [x] . showStringWorker as - showStringWorker [] = showString "" - -intercalate :: String -> [ShowS] -> ShowS -intercalate sep = go - where - go [] = id - go [x] = x - go (x:xs) = x . showString' sep . go xs diff --git a/cabal/Cabal/Distribution/System.hs b/cabal/Cabal/Distribution/System.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/System.hs +++ /dev/null @@ -1,275 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.System --- Copyright : Duncan Coutts 2007-2008 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Cabal often needs to do slightly different things on specific platforms. You --- probably know about the 'System.Info.os' however using that is very --- inconvenient because it is a string and different Haskell implementations --- do not agree on using the same strings for the same platforms! (In --- particular see the controversy over \"windows\" vs \"mingw32\"). So to make it --- more consistent and easy to use we have an 'OS' enumeration. --- -module Distribution.System ( - -- * Operating System - OS(..), - buildOS, - - -- * Machine Architecture - Arch(..), - buildArch, - - -- * Platform is a pair of arch and OS - Platform(..), - buildPlatform, - platformFromTriple, - - -- * Internal - knownOSs, - knownArches, - - -- * Classification - ClassificationStrictness (..), - classifyOS, - classifyArch, - ) where - -import Prelude () -import Distribution.Compat.Prelude -import Control.Applicative (liftA2) - -import qualified System.Info (os, arch) -import Distribution.Utils.Generic (lowercase) - -import Distribution.Parsec -import Distribution.Pretty - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - --- | How strict to be when classifying strings into the 'OS' and 'Arch' enums. --- --- The reason we have multiple ways to do the classification is because there --- are two situations where we need to do it. --- --- For parsing OS and arch names in .cabal files we really want everyone to be --- referring to the same or arch by the same name. Variety is not a virtue --- in this case. We don't mind about case though. --- --- For the System.Info.os\/arch different Haskell implementations use different --- names for the same or\/arch. Also they tend to distinguish versions of an --- OS\/arch which we just don't care about. --- --- The 'Compat' classification allows us to recognise aliases that are already --- in common use but it allows us to distinguish them from the canonical name --- which enables us to warn about such deprecated aliases. --- -data ClassificationStrictness = Permissive | Compat | Strict - --- ------------------------------------------------------------ --- * Operating System --- ------------------------------------------------------------ - --- | These are the known OS names: Linux, Windows, OSX --- ,FreeBSD, OpenBSD, NetBSD, DragonFly --- ,Solaris, AIX, HPUX, IRIX --- ,HaLVM ,Hurd ,IOS, Android,Ghcjs --- --- The following aliases can also be used:, --- * Windows aliases: mingw32, win32, cygwin32 --- * OSX alias: darwin --- * Hurd alias: gnu --- * FreeBSD alias: kfreebsdgnu --- * Solaris alias: solaris2 --- -data OS = Linux | Windows | OSX -- tier 1 desktop OSs - | FreeBSD | OpenBSD | NetBSD -- other free Unix OSs - | DragonFly - | Solaris | AIX | HPUX | IRIX -- ageing Unix OSs - | HaLVM -- bare metal / VMs / hypervisors - | Hurd -- GNU's microkernel - | IOS | Android -- mobile OSs - | Ghcjs - | OtherOS String - deriving (Eq, Generic, Ord, Show, Read, Typeable, Data) - -instance Binary OS -instance Structured OS -instance NFData OS where rnf = genericRnf - -knownOSs :: [OS] -knownOSs = [Linux, Windows, OSX - ,FreeBSD, OpenBSD, NetBSD, DragonFly - ,Solaris, AIX, HPUX, IRIX - ,HaLVM - ,Hurd - ,IOS, Android - ,Ghcjs] - -osAliases :: ClassificationStrictness -> OS -> [String] -osAliases Permissive Windows = ["mingw32", "win32", "cygwin32"] -osAliases Compat Windows = ["mingw32", "win32"] -osAliases _ OSX = ["darwin"] -osAliases _ Hurd = ["gnu"] -osAliases Permissive FreeBSD = ["kfreebsdgnu"] -osAliases Compat FreeBSD = ["kfreebsdgnu"] -osAliases Permissive Solaris = ["solaris2"] -osAliases Compat Solaris = ["solaris2"] -osAliases Permissive Android = ["linux-android", "linux-androideabi", "linux-androideabihf"] -osAliases Compat Android = ["linux-android"] -osAliases _ _ = [] - -instance Pretty OS where - pretty (OtherOS name) = Disp.text name - pretty other = Disp.text (lowercase (show other)) - -instance Parsec OS where - parsec = classifyOS Compat <$> parsecIdent - - - -classifyOS :: ClassificationStrictness -> String -> OS -classifyOS strictness s = - fromMaybe (OtherOS s) $ lookup (lowercase s) osMap - where - osMap = [ (name, os) - | os <- knownOSs - , name <- prettyShow os : osAliases strictness os ] - -buildOS :: OS -buildOS = classifyOS Permissive System.Info.os - --- ------------------------------------------------------------ --- * Machine Architecture --- ------------------------------------------------------------ - --- | These are the known Arches: I386, X86_64, PPC, PPC64, Sparc, --- Arm, AArch64, Mips, SH, IA64, S39, Alpha, Hppa, Rs6000, M68k, --- Vax, and JavaScript. --- --- The following aliases can also be used: --- * PPC alias: powerpc --- * PPC64 alias : powerpc64, powerpc64le --- * Sparc aliases: sparc64, sun4 --- * Mips aliases: mipsel, mipseb --- * Arm aliases: armeb, armel --- * AArch64 aliases: arm64 --- -data Arch = I386 | X86_64 | PPC | PPC64 | Sparc - | Arm | AArch64 | Mips | SH - | IA64 | S390 - | Alpha | Hppa | Rs6000 - | M68k | Vax - | JavaScript - | OtherArch String - deriving (Eq, Generic, Ord, Show, Read, Typeable, Data) - -instance Binary Arch -instance Structured Arch -instance NFData Arch where rnf = genericRnf - -knownArches :: [Arch] -knownArches = [I386, X86_64, PPC, PPC64, Sparc - ,Arm, AArch64, Mips, SH - ,IA64, S390 - ,Alpha, Hppa, Rs6000 - ,M68k, Vax - ,JavaScript] - -archAliases :: ClassificationStrictness -> Arch -> [String] -archAliases Strict _ = [] -archAliases Compat _ = [] -archAliases _ PPC = ["powerpc"] -archAliases _ PPC64 = ["powerpc64", "powerpc64le"] -archAliases _ Sparc = ["sparc64", "sun4"] -archAliases _ Mips = ["mipsel", "mipseb"] -archAliases _ Arm = ["armeb", "armel"] -archAliases _ AArch64 = ["arm64"] -archAliases _ _ = [] - -instance Pretty Arch where - pretty (OtherArch name) = Disp.text name - pretty other = Disp.text (lowercase (show other)) - -instance Parsec Arch where - parsec = classifyArch Strict <$> parsecIdent - -classifyArch :: ClassificationStrictness -> String -> Arch -classifyArch strictness s = - fromMaybe (OtherArch s) $ lookup (lowercase s) archMap - where - archMap = [ (name, arch) - | arch <- knownArches - , name <- prettyShow arch : archAliases strictness arch ] - -buildArch :: Arch -buildArch = classifyArch Permissive System.Info.arch - --- ------------------------------------------------------------ --- * Platform --- ------------------------------------------------------------ - -data Platform = Platform Arch OS - deriving (Eq, Generic, Ord, Show, Read, Typeable, Data) - -instance Binary Platform -instance Structured Platform -instance NFData Platform where rnf = genericRnf - -instance Pretty Platform where - pretty (Platform arch os) = pretty arch <<>> Disp.char '-' <<>> pretty os - -instance Parsec Platform where - -- TODO: there are ambigious platforms like: `arch-word-os` - -- which could be parsed as - -- * Platform "arch-word" "os" - -- * Platform "arch" "word-os" - -- We could support that preferring variants 'OtherOS' or 'OtherArch' - -- - -- For now we split into arch and os parts on the first dash. - parsec = do - arch <- parsecDashlessArch - _ <- P.char '-' - os <- parsec - return (Platform arch os) - where - parsecDashlessArch = classifyArch Strict <$> dashlessIdent - - dashlessIdent = liftA2 (:) firstChar rest - where - firstChar = P.satisfy isAlpha - rest = P.munch (\c -> isAlphaNum c || c == '_') - --- | The platform Cabal was compiled on. In most cases, --- @LocalBuildInfo.hostPlatform@ should be used instead (the platform we're --- targeting). -buildPlatform :: Platform -buildPlatform = Platform buildArch buildOS - --- Utils: - -parsecIdent :: CabalParsing m => m String -parsecIdent = (:) <$> firstChar <*> rest - where - firstChar = P.satisfy isAlpha - rest = P.munch (\c -> isAlphaNum c || c == '_' || c == '-') - -platformFromTriple :: String -> Maybe Platform -platformFromTriple triple = - either (const Nothing) Just $ explicitEitherParsec parseTriple triple - where parseWord = P.munch1 (\c -> isAlphaNum c || c == '_') - parseTriple = do - arch <- fmap (classifyArch Permissive) parseWord - _ <- P.char '-' - _ <- parseWord -- Skip vendor - _ <- P.char '-' - os <- fmap (classifyOS Permissive) parsecIdent -- OS may have hyphens, like - -- 'nto-qnx' - return $ Platform arch os diff --git a/cabal/Cabal/Distribution/TestSuite.hs b/cabal/Cabal/Distribution/TestSuite.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/TestSuite.hs +++ /dev/null @@ -1,102 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.TestSuite --- Copyright : Thomas Tuegel 2010 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This module defines the detailed test suite interface which makes it --- possible to expose individual tests to Cabal or other test agents. - -module Distribution.TestSuite - ( TestInstance(..) - , OptionDescr(..) - , OptionType(..) - , Test(..) - , Options - , Progress(..) - , Result(..) - , testGroup - ) where - -import Prelude () -import Distribution.Compat.Prelude - -data TestInstance = TestInstance - { run :: IO Progress -- ^ Perform the test. - , name :: String -- ^ A name for the test, unique within a - -- test suite. - , tags :: [String] -- ^ Users can select groups of tests by - -- their tags. - , options :: [OptionDescr] -- ^ Descriptions of the options recognized - -- by this test. - , setOption :: String -> String -> Either String TestInstance - -- ^ Try to set the named option to the given value. Returns an error - -- message if the option is not supported or the value could not be - -- correctly parsed; otherwise, a 'TestInstance' with the option set to - -- the given value is returned. - } - -data OptionDescr = OptionDescr - { optionName :: String - , optionDescription :: String -- ^ A human-readable description of the - -- option to guide the user setting it. - , optionType :: OptionType - , optionDefault :: Maybe String - } - deriving (Eq, Read, Show) - -data OptionType - = OptionFile - { optionFileMustExist :: Bool - , optionFileIsDir :: Bool - , optionFileExtensions :: [String] - } - | OptionString - { optionStringMultiline :: Bool - } - | OptionNumber - { optionNumberIsInt :: Bool - , optionNumberBounds :: (Maybe String, Maybe String) - } - | OptionBool - | OptionEnum [String] - | OptionSet [String] - | OptionRngSeed - deriving (Eq, Read, Show) - -data Test - = Test TestInstance - | Group - { groupName :: String - , concurrently :: Bool - -- ^ If true, then children of this group may be run in parallel. - -- Note that this setting is not inherited by children. In - -- particular, consider a group F with "concurrently = False" that - -- has some children, including a group T with "concurrently = - -- True". The children of group T may be run concurrently with each - -- other, as long as none are run at the same time as any of the - -- direct children of group F. - , groupTests :: [Test] - } - | ExtraOptions [OptionDescr] Test - -type Options = [(String, String)] - -data Progress = Finished Result - | Progress String (IO Progress) - -data Result = Pass - | Fail String - | Error String - deriving (Eq, Read, Show) - --- | Create a named group of tests, which are assumed to be safe to run in --- parallel. -testGroup :: String -> [Test] -> Test -testGroup n ts = Group { groupName = n, concurrently = True, groupTests = ts } diff --git a/cabal/Cabal/Distribution/Text.hs b/cabal/Cabal/Distribution/Text.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Text.hs +++ /dev/null @@ -1,12 +0,0 @@ --- Since @3.0@ this is a compat module. -module Distribution.Text (display, simpleParse) where -{- {-# DEPRECATED "Use Distribution.Parsec or Distribution.Pretty" #-} -} - -import Distribution.Pretty -import Distribution.Parsec - -display :: Pretty a => a -> String -display = prettyShow - -simpleParse :: Parsec a => String -> Maybe a -simpleParse = simpleParsec diff --git a/cabal/Cabal/Distribution/Types/AbiDependency.hs b/cabal/Cabal/Distribution/Types/AbiDependency.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/AbiDependency.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.AbiDependency where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Parsec -import Distribution.Pretty - -import qualified Distribution.Compat.CharParsing as P -import qualified Distribution.Package as Package -import qualified Text.PrettyPrint as Disp - --- | An ABI dependency is a dependency on a library which also --- records the ABI hash ('abiHash') of the library it depends --- on. --- --- The primary utility of this is to enable an extra sanity when --- GHC loads libraries: it can check if the dependency has a matching --- ABI and if not, refuse to load this library. This information --- is critical if we are shadowing libraries; differences in the --- ABI hash let us know what packages get shadowed by the new version --- of a package. -data AbiDependency = AbiDependency { - depUnitId :: Package.UnitId, - depAbiHash :: Package.AbiHash - } - deriving (Eq, Generic, Read, Show, Typeable) - -instance Pretty AbiDependency where - pretty (AbiDependency uid abi) = - pretty uid <<>> Disp.char '=' <<>> pretty abi - -instance Parsec AbiDependency where - parsec = do - uid <- parsec - _ <- P.char '=' - abi <- parsec - return (AbiDependency uid abi) - -instance Binary AbiDependency -instance Structured AbiDependency -instance NFData AbiDependency where rnf = genericRnf diff --git a/cabal/Cabal/Distribution/Types/AbiHash.hs b/cabal/Cabal/Distribution/Types/AbiHash.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/AbiHash.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Distribution.Types.AbiHash - ( AbiHash, unAbiHash, mkAbiHash - ) where - -import Prelude () -import Distribution.Compat.Prelude -import Distribution.Utils.ShortText - -import qualified Distribution.Compat.CharParsing as P -import Distribution.Pretty -import Distribution.Parsec - -import Text.PrettyPrint (text) - --- | ABI Hashes --- --- Use 'mkAbiHash' and 'unAbiHash' to convert from/to a --- 'String'. --- --- This type is opaque since @Cabal-2.0@ --- --- @since 2.0.0.2 -newtype AbiHash = AbiHash ShortText - deriving (Eq, Show, Read, Generic, Typeable) - --- | Construct a 'AbiHash' from a 'String' --- --- 'mkAbiHash' is the inverse to 'unAbiHash' --- --- Note: No validations are performed to ensure that the resulting --- 'AbiHash' is valid --- --- @since 2.0.0.2 -unAbiHash :: AbiHash -> String -unAbiHash (AbiHash h) = fromShortText h - --- | Convert 'AbiHash' to 'String' --- --- @since 2.0.0.2 -mkAbiHash :: String -> AbiHash -mkAbiHash = AbiHash . toShortText - --- | 'mkAbiHash' --- --- @since 2.0.0.2 -instance IsString AbiHash where - fromString = mkAbiHash - -instance Binary AbiHash -instance Structured AbiHash -instance NFData AbiHash where rnf = genericRnf - -instance Pretty AbiHash where - pretty = text . unAbiHash - -instance Parsec AbiHash where - parsec = fmap mkAbiHash (P.munch isAlphaNum) diff --git a/cabal/Cabal/Distribution/Types/AnnotatedId.hs b/cabal/Cabal/Distribution/Types/AnnotatedId.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/AnnotatedId.hs +++ /dev/null @@ -1,34 +0,0 @@ -module Distribution.Types.AnnotatedId ( - AnnotatedId(..) -) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Package -import Distribution.Types.ComponentName - --- | An 'AnnotatedId' is a 'ComponentId', 'UnitId', etc. --- which is annotated with some other useful information --- that is useful for printing to users, etc. --- --- Invariant: if ann_id x == ann_id y, then ann_pid x == ann_pid y --- and ann_cname x == ann_cname y -data AnnotatedId id = AnnotatedId { - ann_pid :: PackageId, - ann_cname :: ComponentName, - ann_id :: id - } - deriving (Show) - -instance Eq id => Eq (AnnotatedId id) where - x == y = ann_id x == ann_id y - -instance Ord id => Ord (AnnotatedId id) where - compare x y = compare (ann_id x) (ann_id y) - -instance Package (AnnotatedId id) where - packageId = ann_pid - -instance Functor AnnotatedId where - fmap f (AnnotatedId pid cn x) = AnnotatedId pid cn (f x) diff --git a/cabal/Cabal/Distribution/Types/Benchmark.hs b/cabal/Cabal/Distribution/Types/Benchmark.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/Benchmark.hs +++ /dev/null @@ -1,78 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE NoMonoLocalBinds #-} - -module Distribution.Types.Benchmark ( - Benchmark(..), - emptyBenchmark, - benchmarkType, - benchmarkModules, - benchmarkModulesAutogen -) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Types.BuildInfo -import Distribution.Types.BenchmarkType -import Distribution.Types.BenchmarkInterface -import Distribution.Types.UnqualComponentName - -import Distribution.ModuleName - -import qualified Distribution.Types.BuildInfo.Lens as L - --- | A \"benchmark\" stanza in a cabal file. --- -data Benchmark = Benchmark { - benchmarkName :: UnqualComponentName, - benchmarkInterface :: BenchmarkInterface, - benchmarkBuildInfo :: BuildInfo - } - deriving (Generic, Show, Read, Eq, Typeable, Data) - -instance Binary Benchmark -instance Structured Benchmark -instance NFData Benchmark where rnf = genericRnf - -instance L.HasBuildInfo Benchmark where - buildInfo f (Benchmark x1 x2 x3) = fmap (\y1 -> Benchmark x1 x2 y1) (f x3) - -instance Monoid Benchmark where - mempty = Benchmark { - benchmarkName = mempty, - benchmarkInterface = mempty, - benchmarkBuildInfo = mempty - } - mappend = (<>) - -instance Semigroup Benchmark where - a <> b = Benchmark { - benchmarkName = combine' benchmarkName, - benchmarkInterface = combine benchmarkInterface, - benchmarkBuildInfo = combine benchmarkBuildInfo - } - where combine field = field a `mappend` field b - combine' field = case ( unUnqualComponentName $ field a - , unUnqualComponentName $ field b) of - ("", _) -> field b - (_, "") -> field a - (x, y) -> error $ "Ambiguous values for test field: '" - ++ x ++ "' and '" ++ y ++ "'" - -emptyBenchmark :: Benchmark -emptyBenchmark = mempty - -benchmarkType :: Benchmark -> BenchmarkType -benchmarkType benchmark = case benchmarkInterface benchmark of - BenchmarkExeV10 ver _ -> BenchmarkTypeExe ver - BenchmarkUnsupported benchmarktype -> benchmarktype - --- | Get all the module names from a benchmark. -benchmarkModules :: Benchmark -> [ModuleName] -benchmarkModules benchmark = otherModules (benchmarkBuildInfo benchmark) - --- | Get all the auto generated module names from a benchmark. --- This are a subset of 'benchmarkModules'. -benchmarkModulesAutogen :: Benchmark -> [ModuleName] -benchmarkModulesAutogen benchmark = autogenModules (benchmarkBuildInfo benchmark) diff --git a/cabal/Cabal/Distribution/Types/Benchmark/Lens.hs b/cabal/Cabal/Distribution/Types/Benchmark/Lens.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/Benchmark/Lens.hs +++ /dev/null @@ -1,27 +0,0 @@ -module Distribution.Types.Benchmark.Lens ( - Benchmark, - module Distribution.Types.Benchmark.Lens, - ) where - -import Distribution.Compat.Lens -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Types.Benchmark (Benchmark) -import Distribution.Types.BenchmarkInterface (BenchmarkInterface) -import Distribution.Types.BuildInfo (BuildInfo) -import Distribution.Types.UnqualComponentName (UnqualComponentName) - -import qualified Distribution.Types.Benchmark as T - -benchmarkName :: Lens' Benchmark UnqualComponentName -benchmarkName f s = fmap (\x -> s { T.benchmarkName = x }) (f (T.benchmarkName s)) -{-# INLINE benchmarkName #-} - -benchmarkInterface :: Lens' Benchmark BenchmarkInterface -benchmarkInterface f s = fmap (\x -> s { T.benchmarkInterface = x }) (f (T.benchmarkInterface s)) -{-# INLINE benchmarkInterface #-} - -benchmarkBuildInfo :: Lens' Benchmark BuildInfo -benchmarkBuildInfo f s = fmap (\x -> s { T.benchmarkBuildInfo = x }) (f (T.benchmarkBuildInfo s)) -{-# INLINE benchmarkBuildInfo #-} diff --git a/cabal/Cabal/Distribution/Types/BenchmarkInterface.hs b/cabal/Cabal/Distribution/Types/BenchmarkInterface.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/BenchmarkInterface.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - -module Distribution.Types.BenchmarkInterface ( - BenchmarkInterface(..), -) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Types.BenchmarkType -import Distribution.Version - --- | The benchmark interfaces that are currently defined. Each --- benchmark must specify which interface it supports. --- --- More interfaces may be defined in future, either new revisions or --- totally new interfaces. --- -data BenchmarkInterface = - - -- | Benchmark interface \"exitcode-stdio-1.0\". The benchmark - -- takes the form of an executable. It returns a zero exit code - -- for success, non-zero for failure. The stdout and stderr - -- channels may be logged. It takes no command line parameters - -- and nothing on stdin. - -- - BenchmarkExeV10 Version FilePath - - -- | A benchmark that does not conform to one of the above - -- interfaces for the given reason (e.g. unknown benchmark type). - -- - | BenchmarkUnsupported BenchmarkType - deriving (Eq, Generic, Read, Show, Typeable, Data) - -instance Binary BenchmarkInterface -instance Structured BenchmarkInterface -instance NFData BenchmarkInterface where rnf = genericRnf - -instance Monoid BenchmarkInterface where - mempty = BenchmarkUnsupported (BenchmarkTypeUnknown mempty nullVersion) - mappend = (<>) - -instance Semigroup BenchmarkInterface where - a <> (BenchmarkUnsupported _) = a - _ <> b = b diff --git a/cabal/Cabal/Distribution/Types/BenchmarkType.hs b/cabal/Cabal/Distribution/Types/BenchmarkType.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/BenchmarkType.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} - -module Distribution.Types.BenchmarkType ( - BenchmarkType(..), - knownBenchmarkTypes, -) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Version -import Text.PrettyPrint (char, text) - --- | The \"benchmark-type\" field in the benchmark stanza. --- -data BenchmarkType = BenchmarkTypeExe Version - -- ^ \"type: exitcode-stdio-x.y\" - | BenchmarkTypeUnknown String Version - -- ^ Some unknown benchmark type e.g. \"type: foo\" - deriving (Generic, Show, Read, Eq, Typeable, Data) - -instance Binary BenchmarkType -instance Structured BenchmarkType -instance NFData BenchmarkType where rnf = genericRnf - -knownBenchmarkTypes :: [BenchmarkType] -knownBenchmarkTypes = [ BenchmarkTypeExe (mkVersion [1,0]) ] - -instance Pretty BenchmarkType where - pretty (BenchmarkTypeExe ver) = text "exitcode-stdio-" <<>> pretty ver - pretty (BenchmarkTypeUnknown name ver) = text name <<>> char '-' <<>> pretty ver - -instance Parsec BenchmarkType where - parsec = parsecStandard $ \ver name -> case name of - "exitcode-stdio" -> BenchmarkTypeExe ver - _ -> BenchmarkTypeUnknown name ver diff --git a/cabal/Cabal/Distribution/Types/BuildInfo.hs b/cabal/Cabal/Distribution/Types/BuildInfo.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/BuildInfo.hs +++ /dev/null @@ -1,263 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE NoMonoLocalBinds #-} - -module Distribution.Types.BuildInfo ( - BuildInfo(..), - - emptyBuildInfo, - allLanguages, - allExtensions, - usedExtensions, - usesTemplateHaskellOrQQ, - - hcOptions, - hcProfOptions, - hcSharedOptions, - hcStaticOptions, -) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Types.Mixin -import Distribution.Types.Dependency -import Distribution.Types.ExeDependency -import Distribution.Types.LegacyExeDependency -import Distribution.Types.PkgconfigDependency - -import Distribution.ModuleName -import Distribution.Compiler -import Language.Haskell.Extension - --- Consider refactoring into executable and library versions. -data BuildInfo = BuildInfo { - -- | component is buildable here - buildable :: Bool, - -- | Tools needed to build this bit. - -- - -- This is a legacy field that 'buildToolDepends' largely supersedes. - -- - -- Unless use are very sure what you are doing, use the functions in - -- "Distribution.Simple.BuildToolDepends" rather than accessing this - -- field directly. - buildTools :: [LegacyExeDependency], - -- | Haskell tools needed to build this bit - -- - -- This field is better than 'buildTools' because it allows one to - -- precisely specify an executable in a package. - -- - -- Unless use are very sure what you are doing, use the functions in - -- "Distribution.Simple.BuildToolDepends" rather than accessing this - -- field directly. - buildToolDepends :: [ExeDependency], - cppOptions :: [String], -- ^ options for pre-processing Haskell code - asmOptions :: [String], -- ^ options for assmebler - cmmOptions :: [String], -- ^ options for C-- compiler - ccOptions :: [String], -- ^ options for C compiler - cxxOptions :: [String], -- ^ options for C++ compiler - ldOptions :: [String], -- ^ options for linker - pkgconfigDepends :: [PkgconfigDependency], -- ^ pkg-config packages that are used - frameworks :: [String], -- ^support frameworks for Mac OS X - extraFrameworkDirs:: [String], -- ^ extra locations to find frameworks. - asmSources :: [FilePath], -- ^ Assembly files. - cmmSources :: [FilePath], -- ^ C-- files. - cSources :: [FilePath], - cxxSources :: [FilePath], - jsSources :: [FilePath], - hsSourceDirs :: [FilePath], -- ^ where to look for the Haskell module hierarchy - otherModules :: [ModuleName], -- ^ non-exposed or non-main modules - virtualModules :: [ModuleName], -- ^ exposed modules that do not have a source file (e.g. @GHC.Prim@ from @ghc-prim@ package) - autogenModules :: [ModuleName], -- ^ not present on sdist, Paths_* or user-generated with a custom Setup.hs - - defaultLanguage :: Maybe Language,-- ^ language used when not explicitly specified - otherLanguages :: [Language], -- ^ other languages used within the package - defaultExtensions :: [Extension], -- ^ language extensions used by all modules - otherExtensions :: [Extension], -- ^ other language extensions used within the package - oldExtensions :: [Extension], -- ^ the old extensions field, treated same as 'defaultExtensions' - - extraLibs :: [String], -- ^ what libraries to link with when compiling a program that uses your package - extraGHCiLibs :: [String], -- ^ if present, overrides extraLibs when package is loaded with GHCi. - extraBundledLibs :: [String], -- ^ if present, adds libs to hs-libraries, which become part of the package. - -- Example: the Cffi library shipping with the rts, alognside the HSrts-1.0.a,.o,... - -- Example 2: a library that is being built by a foreing tool (e.g. rust) - -- and copied and registered together with this library. The - -- logic on how this library is built will have to be encoded in a - -- custom Setup for now. Otherwise cabal would need to lear how to - -- call arbitrary library builders. - extraLibFlavours :: [String], -- ^ Hidden Flag. This set of strings, will be appended to all libraries when - -- copying. E.g. [libHS_ | flavour <- extraLibFlavours]. This - -- should only be needed in very specific cases, e.g. the `rts` package, where - -- there are multiple copies of slightly differently built libs. - extraDynLibFlavours :: [String], -- ^ Hidden Flag. This set of strings will be appended to all /dynamic/ - -- libraries when copying. This is particularly useful with the `rts` package, - -- where we want different dynamic flavours of the RTS library to be installed. - extraLibDirs :: [String], - includeDirs :: [FilePath], -- ^directories to find .h files - includes :: [FilePath], -- ^ The .h files to be found in includeDirs - autogenIncludes :: [FilePath], -- ^ The .h files to be generated (e.g. by @autoconf@) - installIncludes :: [FilePath], -- ^ .h files to install with the package - options :: PerCompilerFlavor [String], - profOptions :: PerCompilerFlavor [String], - sharedOptions :: PerCompilerFlavor [String], - staticOptions :: PerCompilerFlavor [String], - customFieldsBI :: [(String,String)], -- ^Custom fields starting - -- with x-, stored in a - -- simple assoc-list. - targetBuildDepends :: [Dependency], -- ^ Dependencies specific to a library or executable target - mixins :: [Mixin] - } - deriving (Generic, Show, Read, Eq, Typeable, Data) - -instance Binary BuildInfo -instance Structured BuildInfo -instance NFData BuildInfo where rnf = genericRnf - -instance Monoid BuildInfo where - mempty = BuildInfo { - buildable = True, - buildTools = [], - buildToolDepends = [], - cppOptions = [], - asmOptions = [], - cmmOptions = [], - ccOptions = [], - cxxOptions = [], - ldOptions = [], - pkgconfigDepends = [], - frameworks = [], - extraFrameworkDirs = [], - asmSources = [], - cmmSources = [], - cSources = [], - cxxSources = [], - jsSources = [], - hsSourceDirs = [], - otherModules = [], - virtualModules = [], - autogenModules = [], - defaultLanguage = Nothing, - otherLanguages = [], - defaultExtensions = [], - otherExtensions = [], - oldExtensions = [], - extraLibs = [], - extraGHCiLibs = [], - extraBundledLibs = [], - extraLibFlavours = [], - extraDynLibFlavours = [], - extraLibDirs = [], - includeDirs = [], - includes = [], - autogenIncludes = [], - installIncludes = [], - options = mempty, - profOptions = mempty, - sharedOptions = mempty, - staticOptions = mempty, - customFieldsBI = [], - targetBuildDepends = [], - mixins = [] - } - mappend = (<>) - -instance Semigroup BuildInfo where - a <> b = BuildInfo { - buildable = buildable a && buildable b, - buildTools = combine buildTools, - buildToolDepends = combine buildToolDepends, - cppOptions = combine cppOptions, - asmOptions = combine asmOptions, - cmmOptions = combine cmmOptions, - ccOptions = combine ccOptions, - cxxOptions = combine cxxOptions, - ldOptions = combine ldOptions, - pkgconfigDepends = combine pkgconfigDepends, - frameworks = combineNub frameworks, - extraFrameworkDirs = combineNub extraFrameworkDirs, - asmSources = combineNub asmSources, - cmmSources = combineNub cmmSources, - cSources = combineNub cSources, - cxxSources = combineNub cxxSources, - jsSources = combineNub jsSources, - hsSourceDirs = combineNub hsSourceDirs, - otherModules = combineNub otherModules, - virtualModules = combineNub virtualModules, - autogenModules = combineNub autogenModules, - defaultLanguage = combineMby defaultLanguage, - otherLanguages = combineNub otherLanguages, - defaultExtensions = combineNub defaultExtensions, - otherExtensions = combineNub otherExtensions, - oldExtensions = combineNub oldExtensions, - extraLibs = combine extraLibs, - extraGHCiLibs = combine extraGHCiLibs, - extraBundledLibs = combine extraBundledLibs, - extraLibFlavours = combine extraLibFlavours, - extraDynLibFlavours = combine extraDynLibFlavours, - extraLibDirs = combineNub extraLibDirs, - includeDirs = combineNub includeDirs, - includes = combineNub includes, - autogenIncludes = combineNub autogenIncludes, - installIncludes = combineNub installIncludes, - options = combine options, - profOptions = combine profOptions, - sharedOptions = combine sharedOptions, - staticOptions = combine staticOptions, - customFieldsBI = combine customFieldsBI, - targetBuildDepends = combineNub targetBuildDepends, - mixins = combine mixins - } - where - combine field = field a `mappend` field b - combineNub field = nub (combine field) - combineMby field = field b `mplus` field a - -emptyBuildInfo :: BuildInfo -emptyBuildInfo = mempty - --- | The 'Language's used by this component --- -allLanguages :: BuildInfo -> [Language] -allLanguages bi = maybeToList (defaultLanguage bi) - ++ otherLanguages bi - --- | The 'Extension's that are used somewhere by this component --- -allExtensions :: BuildInfo -> [Extension] -allExtensions bi = usedExtensions bi - ++ otherExtensions bi - --- | The 'Extensions' that are used by all modules in this component --- -usedExtensions :: BuildInfo -> [Extension] -usedExtensions bi = oldExtensions bi - ++ defaultExtensions bi - --- | Whether any modules in this component use Template Haskell or --- Quasi Quotes -usesTemplateHaskellOrQQ :: BuildInfo -> Bool -usesTemplateHaskellOrQQ bi = any p (allExtensions bi) - where - p ex = ex `elem` - [EnableExtension TemplateHaskell, EnableExtension QuasiQuotes] - --- |Select options for a particular Haskell compiler. -hcOptions :: CompilerFlavor -> BuildInfo -> [String] -hcOptions = lookupHcOptions options - -hcProfOptions :: CompilerFlavor -> BuildInfo -> [String] -hcProfOptions = lookupHcOptions profOptions - -hcSharedOptions :: CompilerFlavor -> BuildInfo -> [String] -hcSharedOptions = lookupHcOptions sharedOptions - -hcStaticOptions :: CompilerFlavor -> BuildInfo -> [String] -hcStaticOptions = lookupHcOptions staticOptions - -lookupHcOptions :: (BuildInfo -> PerCompilerFlavor [String]) - -> CompilerFlavor -> BuildInfo -> [String] -lookupHcOptions f hc bi = case f bi of - PerCompilerFlavor ghc ghcjs - | hc == GHC -> ghc - | hc == GHCJS -> ghcjs - | otherwise -> mempty diff --git a/cabal/Cabal/Distribution/Types/BuildInfo/Lens.hs b/cabal/Cabal/Distribution/Types/BuildInfo/Lens.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/BuildInfo/Lens.hs +++ /dev/null @@ -1,334 +0,0 @@ -module Distribution.Types.BuildInfo.Lens ( - BuildInfo, - HasBuildInfo (..), - HasBuildInfos (..), - ) where - -import Prelude () -import Distribution.Compat.Prelude -import Distribution.Compat.Lens - -import Distribution.Compiler (PerCompilerFlavor) -import Distribution.ModuleName (ModuleName) -import Distribution.Types.BuildInfo (BuildInfo) -import Distribution.Types.Dependency (Dependency) -import Distribution.Types.ExeDependency (ExeDependency) -import Distribution.Types.LegacyExeDependency (LegacyExeDependency) -import Distribution.Types.Mixin (Mixin) -import Distribution.Types.PkgconfigDependency (PkgconfigDependency) -import Language.Haskell.Extension (Extension, Language) - -import qualified Distribution.Types.BuildInfo as T - --- | Classy lenses for 'BuildInfo'. -class HasBuildInfo a where - buildInfo :: Lens' a BuildInfo - - buildable :: Lens' a Bool - buildable = buildInfo . buildable - {-# INLINE buildable #-} - - buildTools :: Lens' a [LegacyExeDependency] - buildTools = buildInfo . buildTools - {-# INLINE buildTools #-} - - buildToolDepends :: Lens' a [ExeDependency] - buildToolDepends = buildInfo . buildToolDepends - {-# INLINE buildToolDepends #-} - - cppOptions :: Lens' a [String] - cppOptions = buildInfo . cppOptions - {-# INLINE cppOptions #-} - - asmOptions :: Lens' a [String] - asmOptions = buildInfo . asmOptions - {-# INLINE asmOptions #-} - - cmmOptions :: Lens' a [String] - cmmOptions = buildInfo . cmmOptions - {-# INLINE cmmOptions #-} - - ccOptions :: Lens' a [String] - ccOptions = buildInfo . ccOptions - {-# INLINE ccOptions #-} - - cxxOptions :: Lens' a [String] - cxxOptions = buildInfo . cxxOptions - {-# INLINE cxxOptions #-} - - ldOptions :: Lens' a [String] - ldOptions = buildInfo . ldOptions - {-# INLINE ldOptions #-} - - pkgconfigDepends :: Lens' a [PkgconfigDependency] - pkgconfigDepends = buildInfo . pkgconfigDepends - {-# INLINE pkgconfigDepends #-} - - frameworks :: Lens' a [String] - frameworks = buildInfo . frameworks - {-# INLINE frameworks #-} - - extraFrameworkDirs :: Lens' a [String] - extraFrameworkDirs = buildInfo . extraFrameworkDirs - {-# INLINE extraFrameworkDirs #-} - - asmSources :: Lens' a [FilePath] - asmSources = buildInfo . asmSources - {-# INLINE asmSources #-} - - cmmSources :: Lens' a [FilePath] - cmmSources = buildInfo . cmmSources - {-# INLINE cmmSources #-} - - cSources :: Lens' a [FilePath] - cSources = buildInfo . cSources - {-# INLINE cSources #-} - - cxxSources :: Lens' a [FilePath] - cxxSources = buildInfo . cxxSources - {-# INLINE cxxSources #-} - - jsSources :: Lens' a [FilePath] - jsSources = buildInfo . jsSources - {-# INLINE jsSources #-} - - hsSourceDirs :: Lens' a [FilePath] - hsSourceDirs = buildInfo . hsSourceDirs - {-# INLINE hsSourceDirs #-} - - otherModules :: Lens' a [ModuleName] - otherModules = buildInfo . otherModules - {-# INLINE otherModules #-} - - virtualModules :: Lens' a [ModuleName] - virtualModules = buildInfo . virtualModules - {-# INLINE virtualModules #-} - - autogenModules :: Lens' a [ModuleName] - autogenModules = buildInfo . autogenModules - {-# INLINE autogenModules #-} - - defaultLanguage :: Lens' a (Maybe Language) - defaultLanguage = buildInfo . defaultLanguage - {-# INLINE defaultLanguage #-} - - otherLanguages :: Lens' a [Language] - otherLanguages = buildInfo . otherLanguages - {-# INLINE otherLanguages #-} - - defaultExtensions :: Lens' a [Extension] - defaultExtensions = buildInfo . defaultExtensions - {-# INLINE defaultExtensions #-} - - otherExtensions :: Lens' a [Extension] - otherExtensions = buildInfo . otherExtensions - {-# INLINE otherExtensions #-} - - oldExtensions :: Lens' a [Extension] - oldExtensions = buildInfo . oldExtensions - {-# INLINE oldExtensions #-} - - extraLibs :: Lens' a [String] - extraLibs = buildInfo . extraLibs - {-# INLINE extraLibs #-} - - extraGHCiLibs :: Lens' a [String] - extraGHCiLibs = buildInfo . extraGHCiLibs - {-# INLINE extraGHCiLibs #-} - - extraBundledLibs :: Lens' a [String] - extraBundledLibs = buildInfo . extraBundledLibs - {-# INLINE extraBundledLibs #-} - - extraLibFlavours :: Lens' a [String] - extraLibFlavours = buildInfo . extraLibFlavours - {-# INLINE extraLibFlavours #-} - - extraDynLibFlavours :: Lens' a [String] - extraDynLibFlavours = buildInfo . extraDynLibFlavours - {-# INLINE extraDynLibFlavours #-} - - extraLibDirs :: Lens' a [String] - extraLibDirs = buildInfo . extraLibDirs - {-# INLINE extraLibDirs #-} - - includeDirs :: Lens' a [FilePath] - includeDirs = buildInfo . includeDirs - {-# INLINE includeDirs #-} - - includes :: Lens' a [FilePath] - includes = buildInfo . includes - {-# INLINE includes #-} - - autogenIncludes :: Lens' a [FilePath] - autogenIncludes = buildInfo . autogenIncludes - {-# INLINE autogenIncludes #-} - - installIncludes :: Lens' a [FilePath] - installIncludes = buildInfo . installIncludes - {-# INLINE installIncludes #-} - - options :: Lens' a (PerCompilerFlavor [String]) - options = buildInfo . options - {-# INLINE options #-} - - profOptions :: Lens' a (PerCompilerFlavor [String]) - profOptions = buildInfo . profOptions - {-# INLINE profOptions #-} - - sharedOptions :: Lens' a (PerCompilerFlavor [String]) - sharedOptions = buildInfo . sharedOptions - {-# INLINE sharedOptions #-} - - staticOptions :: Lens' a (PerCompilerFlavor [String]) - staticOptions = buildInfo . staticOptions - {-# INLINE staticOptions #-} - - customFieldsBI :: Lens' a [(String,String)] - customFieldsBI = buildInfo . customFieldsBI - {-# INLINE customFieldsBI #-} - - targetBuildDepends :: Lens' a [Dependency] - targetBuildDepends = buildInfo . targetBuildDepends - {-# INLINE targetBuildDepends #-} - - mixins :: Lens' a [Mixin] - mixins = buildInfo . mixins - {-# INLINE mixins #-} - - -instance HasBuildInfo BuildInfo where - buildInfo = id - {-# INLINE buildInfo #-} - - buildable f s = fmap (\x -> s { T.buildable = x }) (f (T.buildable s)) - {-# INLINE buildable #-} - - buildTools f s = fmap (\x -> s { T.buildTools = x }) (f (T.buildTools s)) - {-# INLINE buildTools #-} - - buildToolDepends f s = fmap (\x -> s { T.buildToolDepends = x }) (f (T.buildToolDepends s)) - {-# INLINE buildToolDepends #-} - - cppOptions f s = fmap (\x -> s { T.cppOptions = x }) (f (T.cppOptions s)) - {-# INLINE cppOptions #-} - - asmOptions f s = fmap (\x -> s { T.asmOptions = x }) (f (T.asmOptions s)) - {-# INLINE asmOptions #-} - - cmmOptions f s = fmap (\x -> s { T.cmmOptions = x }) (f (T.cmmOptions s)) - {-# INLINE cmmOptions #-} - - ccOptions f s = fmap (\x -> s { T.ccOptions = x }) (f (T.ccOptions s)) - {-# INLINE ccOptions #-} - - cxxOptions f s = fmap (\x -> s { T.cxxOptions = x }) (f (T.cxxOptions s)) - {-# INLINE cxxOptions #-} - - ldOptions f s = fmap (\x -> s { T.ldOptions = x }) (f (T.ldOptions s)) - {-# INLINE ldOptions #-} - - pkgconfigDepends f s = fmap (\x -> s { T.pkgconfigDepends = x }) (f (T.pkgconfigDepends s)) - {-# INLINE pkgconfigDepends #-} - - frameworks f s = fmap (\x -> s { T.frameworks = x }) (f (T.frameworks s)) - {-# INLINE frameworks #-} - - extraFrameworkDirs f s = fmap (\x -> s { T.extraFrameworkDirs = x }) (f (T.extraFrameworkDirs s)) - {-# INLINE extraFrameworkDirs #-} - - asmSources f s = fmap (\x -> s { T.asmSources = x }) (f (T.asmSources s)) - {-# INLINE asmSources #-} - - cmmSources f s = fmap (\x -> s { T.cmmSources = x }) (f (T.cmmSources s)) - {-# INLINE cmmSources #-} - - cSources f s = fmap (\x -> s { T.cSources = x }) (f (T.cSources s)) - {-# INLINE cSources #-} - - cxxSources f s = fmap (\x -> s { T.cSources = x }) (f (T.cxxSources s)) - {-# INLINE cxxSources #-} - - jsSources f s = fmap (\x -> s { T.jsSources = x }) (f (T.jsSources s)) - {-# INLINE jsSources #-} - - hsSourceDirs f s = fmap (\x -> s { T.hsSourceDirs = x }) (f (T.hsSourceDirs s)) - {-# INLINE hsSourceDirs #-} - - otherModules f s = fmap (\x -> s { T.otherModules = x }) (f (T.otherModules s)) - {-# INLINE otherModules #-} - - virtualModules f s = fmap (\x -> s { T.virtualModules = x }) (f (T.virtualModules s)) - {-# INLINE virtualModules #-} - - autogenModules f s = fmap (\x -> s { T.autogenModules = x }) (f (T.autogenModules s)) - {-# INLINE autogenModules #-} - - defaultLanguage f s = fmap (\x -> s { T.defaultLanguage = x }) (f (T.defaultLanguage s)) - {-# INLINE defaultLanguage #-} - - otherLanguages f s = fmap (\x -> s { T.otherLanguages = x }) (f (T.otherLanguages s)) - {-# INLINE otherLanguages #-} - - defaultExtensions f s = fmap (\x -> s { T.defaultExtensions = x }) (f (T.defaultExtensions s)) - {-# INLINE defaultExtensions #-} - - otherExtensions f s = fmap (\x -> s { T.otherExtensions = x }) (f (T.otherExtensions s)) - {-# INLINE otherExtensions #-} - - oldExtensions f s = fmap (\x -> s { T.oldExtensions = x }) (f (T.oldExtensions s)) - {-# INLINE oldExtensions #-} - - extraLibs f s = fmap (\x -> s { T.extraLibs = x }) (f (T.extraLibs s)) - {-# INLINE extraLibs #-} - - extraGHCiLibs f s = fmap (\x -> s { T.extraGHCiLibs = x }) (f (T.extraGHCiLibs s)) - {-# INLINE extraGHCiLibs #-} - - extraBundledLibs f s = fmap (\x -> s { T.extraBundledLibs = x }) (f (T.extraBundledLibs s)) - {-# INLINE extraBundledLibs #-} - - extraLibFlavours f s = fmap (\x -> s { T.extraLibFlavours = x }) (f (T.extraLibFlavours s)) - {-# INLINE extraLibFlavours #-} - - extraDynLibFlavours f s = fmap (\x -> s { T.extraDynLibFlavours = x}) (f (T.extraDynLibFlavours s)) - {-# INLINE extraDynLibFlavours #-} - - extraLibDirs f s = fmap (\x -> s { T.extraLibDirs = x }) (f (T.extraLibDirs s)) - {-# INLINE extraLibDirs #-} - - includeDirs f s = fmap (\x -> s { T.includeDirs = x }) (f (T.includeDirs s)) - {-# INLINE includeDirs #-} - - includes f s = fmap (\x -> s { T.includes = x }) (f (T.includes s)) - {-# INLINE includes #-} - - autogenIncludes f s = fmap (\x -> s { T.autogenIncludes = x }) (f (T.autogenIncludes s)) - {-# INLINE autogenIncludes #-} - - installIncludes f s = fmap (\x -> s { T.installIncludes = x }) (f (T.installIncludes s)) - {-# INLINE installIncludes #-} - - options f s = fmap (\x -> s { T.options = x }) (f (T.options s)) - {-# INLINE options #-} - - profOptions f s = fmap (\x -> s { T.profOptions = x }) (f (T.profOptions s)) - {-# INLINE profOptions #-} - - sharedOptions f s = fmap (\x -> s { T.sharedOptions = x }) (f (T.sharedOptions s)) - {-# INLINE sharedOptions #-} - - staticOptions f s = fmap (\x -> s { T.staticOptions = x }) (f (T.staticOptions s)) - {-# INLINE staticOptions #-} - - customFieldsBI f s = fmap (\x -> s { T.customFieldsBI = x }) (f (T.customFieldsBI s)) - {-# INLINE customFieldsBI #-} - - targetBuildDepends f s = fmap (\x -> s { T.targetBuildDepends = x }) (f (T.targetBuildDepends s)) - {-# INLINE targetBuildDepends #-} - - mixins f s = fmap (\x -> s { T.mixins = x }) (f (T.mixins s)) - {-# INLINE mixins #-} - -class HasBuildInfos a where - traverseBuildInfos :: Traversal' a BuildInfo diff --git a/cabal/Cabal/Distribution/Types/BuildType.hs b/cabal/Cabal/Distribution/Types/BuildType.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/BuildType.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} - -module Distribution.Types.BuildType ( - BuildType(..), - knownBuildTypes, -) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.CabalSpecVersion (CabalSpecVersion (..)) -import Distribution.Pretty -import Distribution.Parsec - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - --- | The type of build system used by this package. -data BuildType - = Simple -- ^ calls @Distribution.Simple.defaultMain@ - | Configure -- ^ calls @Distribution.Simple.defaultMainWithHooks defaultUserHooks@, - -- which invokes @configure@ to generate additional build - -- information used by later phases. - | Make -- ^ calls @Distribution.Make.defaultMain@ - | Custom -- ^ uses user-supplied @Setup.hs@ or @Setup.lhs@ (default) - deriving (Generic, Show, Read, Eq, Typeable, Data) - -instance Binary BuildType -instance Structured BuildType -instance NFData BuildType where rnf = genericRnf - -knownBuildTypes :: [BuildType] -knownBuildTypes = [Simple, Configure, Make, Custom] - -instance Pretty BuildType where - pretty = Disp.text . show - -instance Parsec BuildType where - parsec = do - name <- P.munch1 isAlphaNum - case name of - "Simple" -> return Simple - "Configure" -> return Configure - "Custom" -> return Custom - "Make" -> return Make - "Default" -> do - v <- askCabalSpecVersion - if v <= CabalSpecV1_18 -- oldest version needing this, based on hackage-tests - then do - parsecWarning PWTBuildTypeDefault "build-type: Default is parsed as Custom for legacy reasons. See https://github.com/haskell/cabal/issues/5020" - return Custom - else fail ("unknown build-type: '" ++ name ++ "'") - _ -> fail ("unknown build-type: '" ++ name ++ "'") diff --git a/cabal/Cabal/Distribution/Types/Component.hs b/cabal/Cabal/Distribution/Types/Component.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/Component.hs +++ /dev/null @@ -1,91 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Distribution.Types.Component ( - Component(..), - foldComponent, - componentBuildInfo, - componentBuildable, - componentName, - partitionComponents, -) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Types.Library -import Distribution.Types.ForeignLib -import Distribution.Types.Executable -import Distribution.Types.TestSuite -import Distribution.Types.Benchmark - -import Distribution.Types.ComponentName -import Distribution.Types.BuildInfo - -import qualified Distribution.Types.BuildInfo.Lens as L - -data Component = CLib Library - | CFLib ForeignLib - | CExe Executable - | CTest TestSuite - | CBench Benchmark - deriving (Show, Eq, Read) - -instance Semigroup Component where - CLib l <> CLib l' = CLib (l <> l') - CFLib l <> CFLib l' = CFLib (l <> l') - CExe e <> CExe e' = CExe (e <> e') - CTest t <> CTest t' = CTest (t <> t') - CBench b <> CBench b' = CBench (b <> b') - _ <> _ = error "Cannot merge Component" - -instance L.HasBuildInfo Component where - buildInfo f (CLib l) = CLib <$> L.buildInfo f l - buildInfo f (CFLib l) = CFLib <$> L.buildInfo f l - buildInfo f (CExe e) = CExe <$> L.buildInfo f e - buildInfo f (CTest t) = CTest <$> L.buildInfo f t - buildInfo f (CBench b) = CBench <$> L.buildInfo f b - -foldComponent :: (Library -> a) - -> (ForeignLib -> a) - -> (Executable -> a) - -> (TestSuite -> a) - -> (Benchmark -> a) - -> Component - -> a -foldComponent f _ _ _ _ (CLib lib) = f lib -foldComponent _ f _ _ _ (CFLib flib)= f flib -foldComponent _ _ f _ _ (CExe exe) = f exe -foldComponent _ _ _ f _ (CTest tst) = f tst -foldComponent _ _ _ _ f (CBench bch) = f bch - -componentBuildInfo :: Component -> BuildInfo -componentBuildInfo = - foldComponent libBuildInfo foreignLibBuildInfo buildInfo testBuildInfo benchmarkBuildInfo - --- | Is a component buildable (i.e., not marked with @buildable: False@)? --- See also this note in --- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components". --- --- @since 2.0.0.2 --- -componentBuildable :: Component -> Bool -componentBuildable = buildable . componentBuildInfo - -componentName :: Component -> ComponentName -componentName = - foldComponent (CLibName . libName) - (CFLibName . foreignLibName) - (CExeName . exeName) - (CTestName . testName) - (CBenchName . benchmarkName) - -partitionComponents - :: [Component] - -> ([Library], [ForeignLib], [Executable], [TestSuite], [Benchmark]) -partitionComponents = foldr (foldComponent fa fb fc fd fe) ([],[],[],[],[]) - where - fa x ~(a,b,c,d,e) = (x:a,b,c,d,e) - fb x ~(a,b,c,d,e) = (a,x:b,c,d,e) - fc x ~(a,b,c,d,e) = (a,b,x:c,d,e) - fd x ~(a,b,c,d,e) = (a,b,c,x:d,e) - fe x ~(a,b,c,d,e) = (a,b,c,d,x:e) diff --git a/cabal/Cabal/Distribution/Types/ComponentId.hs b/cabal/Cabal/Distribution/Types/ComponentId.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/ComponentId.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Distribution.Types.ComponentId - ( ComponentId, unComponentId, mkComponentId - ) where - -import Prelude () -import Distribution.Compat.Prelude -import Distribution.Utils.ShortText - -import Distribution.Pretty -import Distribution.Parsec - -import qualified Distribution.Compat.CharParsing as P -import Text.PrettyPrint (text) - --- | A 'ComponentId' uniquely identifies the transitive source --- code closure of a component (i.e. libraries, executables). --- --- For non-Backpack components, this corresponds one to one with --- the 'UnitId', which serves as the basis for install paths, --- linker symbols, etc. --- --- Use 'mkComponentId' and 'unComponentId' to convert from/to a --- 'String'. --- --- This type is opaque since @Cabal-2.0@ --- --- @since 2.0.0.2 -newtype ComponentId = ComponentId ShortText - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) - --- | Construct a 'ComponentId' from a 'String' --- --- 'mkComponentId' is the inverse to 'unComponentId' --- --- Note: No validations are performed to ensure that the resulting --- 'ComponentId' is valid --- --- @since 2.0.0.2 -mkComponentId :: String -> ComponentId -mkComponentId = ComponentId . toShortText - --- | Convert 'ComponentId' to 'String' --- --- @since 2.0.0.2 -unComponentId :: ComponentId -> String -unComponentId (ComponentId s) = fromShortText s - --- | 'mkComponentId' --- --- @since 2.0.0.2 -instance IsString ComponentId where - fromString = mkComponentId - -instance Binary ComponentId -instance Structured ComponentId - -instance Pretty ComponentId where - pretty = text . unComponentId - -instance Parsec ComponentId where - parsec = mkComponentId `fmap` P.munch1 abi_char - where abi_char c = isAlphaNum c || c `elem` "-_." - -instance NFData ComponentId where - rnf = rnf . unComponentId diff --git a/cabal/Cabal/Distribution/Types/ComponentInclude.hs b/cabal/Cabal/Distribution/Types/ComponentInclude.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/ComponentInclude.hs +++ /dev/null @@ -1,32 +0,0 @@ -module Distribution.Types.ComponentInclude ( - ComponentInclude(..), - ci_id, - ci_pkgid, - ci_cname -) where - -import Distribution.Types.PackageId -import Distribution.Types.ComponentName -import Distribution.Types.AnnotatedId - --- Once ci_id is refined to an 'OpenUnitId' or 'DefUnitId', --- the 'includeRequiresRn' is not so useful (because it --- includes the requirements renaming that is no longer --- needed); use 'ci_prov_renaming' instead. -data ComponentInclude id rn = ComponentInclude { - ci_ann_id :: AnnotatedId id, - ci_renaming :: rn, - -- | Did this come from an entry in @mixins@, or - -- was implicitly generated by @build-depends@? - ci_implicit :: Bool - } - -ci_id :: ComponentInclude id rn -> id -ci_id = ann_id . ci_ann_id - -ci_pkgid :: ComponentInclude id rn -> PackageId -ci_pkgid = ann_pid . ci_ann_id - --- | This should always return 'CLibName' or 'CSubLibName' -ci_cname :: ComponentInclude id rn -> ComponentName -ci_cname = ann_cname . ci_ann_id diff --git a/cabal/Cabal/Distribution/Types/ComponentLocalBuildInfo.hs b/cabal/Cabal/Distribution/Types/ComponentLocalBuildInfo.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/ComponentLocalBuildInfo.hs +++ /dev/null @@ -1,129 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TypeFamilies #-} - -module Distribution.Types.ComponentLocalBuildInfo ( - ComponentLocalBuildInfo(..), - componentIsIndefinite, - maybeComponentInstantiatedWith, - ) where - -import Prelude () -import Distribution.Compat.Prelude -import Distribution.ModuleName - -import Distribution.Backpack -import Distribution.Compat.Graph -import Distribution.Types.ComponentId -import Distribution.Types.MungedPackageId -import Distribution.Types.UnitId -import Distribution.Types.ComponentName -import Distribution.Types.MungedPackageName -import Distribution.Types.ModuleRenaming - -import qualified Distribution.InstalledPackageInfo as Installed - --- | The first five fields are common across all algebraic variants. -data ComponentLocalBuildInfo - = LibComponentLocalBuildInfo { - -- | It would be very convenient to store the literal Library here, - -- but if we do that, it will get serialized (via the Binary) - -- instance twice. So instead we just provide the ComponentName, - -- which can be used to find the Component in the - -- PackageDescription. NB: eventually, this will NOT uniquely - -- identify the ComponentLocalBuildInfo. - componentLocalName :: ComponentName, - -- | The computed 'ComponentId' of this component. - componentComponentId :: ComponentId, - -- | The computed 'UnitId' which uniquely identifies this - -- component. Might be hashed. - componentUnitId :: UnitId, - -- | Is this an indefinite component (i.e. has unfilled holes)? - componentIsIndefinite_ :: Bool, - -- | How the component was instantiated - componentInstantiatedWith :: [(ModuleName, OpenModule)], - -- | Resolved internal and external package dependencies for this component. - -- The 'BuildInfo' specifies a set of build dependencies that must be - -- satisfied in terms of version ranges. This field fixes those dependencies - -- to the specific versions available on this machine for this compiler. - componentPackageDeps :: [(UnitId, MungedPackageId)], - -- | The set of packages that are brought into scope during - -- compilation, including a 'ModuleRenaming' which may used - -- to hide or rename modules. This is what gets translated into - -- @-package-id@ arguments. This is a modernized version of - -- 'componentPackageDeps', which is kept around for BC purposes. - componentIncludes :: [(OpenUnitId, ModuleRenaming)], - componentExeDeps :: [UnitId], - -- | The internal dependencies which induce a graph on the - -- 'ComponentLocalBuildInfo' of this package. This does NOT - -- coincide with 'componentPackageDeps' because it ALSO records - -- 'build-tool' dependencies on executables. Maybe one day - -- @cabal-install@ will also handle these correctly too! - componentInternalDeps :: [UnitId], - -- | Compatibility "package key" that we pass to older versions of GHC. - componentCompatPackageKey :: String, - -- | Compatibility "package name" that we register this component as. - componentCompatPackageName :: MungedPackageName, - -- | A list of exposed modules (either defined in this component, - -- or reexported from another component.) - componentExposedModules :: [Installed.ExposedModule], - -- | Convenience field, specifying whether or not this is the - -- "public library" that has the same name as the package. - componentIsPublic :: Bool - } - -- TODO: refactor all these duplicates - | FLibComponentLocalBuildInfo { - componentLocalName :: ComponentName, - componentComponentId :: ComponentId, - componentUnitId :: UnitId, - componentPackageDeps :: [(UnitId, MungedPackageId)], - componentIncludes :: [(OpenUnitId, ModuleRenaming)], - componentExeDeps :: [UnitId], - componentInternalDeps :: [UnitId] - } - | ExeComponentLocalBuildInfo { - componentLocalName :: ComponentName, - componentComponentId :: ComponentId, - componentUnitId :: UnitId, - componentPackageDeps :: [(UnitId, MungedPackageId)], - componentIncludes :: [(OpenUnitId, ModuleRenaming)], - componentExeDeps :: [UnitId], - componentInternalDeps :: [UnitId] - } - | TestComponentLocalBuildInfo { - componentLocalName :: ComponentName, - componentComponentId :: ComponentId, - componentUnitId :: UnitId, - componentPackageDeps :: [(UnitId, MungedPackageId)], - componentIncludes :: [(OpenUnitId, ModuleRenaming)], - componentExeDeps :: [UnitId], - componentInternalDeps :: [UnitId] - - } - | BenchComponentLocalBuildInfo { - componentLocalName :: ComponentName, - componentComponentId :: ComponentId, - componentUnitId :: UnitId, - componentPackageDeps :: [(UnitId, MungedPackageId)], - componentIncludes :: [(OpenUnitId, ModuleRenaming)], - componentExeDeps :: [UnitId], - componentInternalDeps :: [UnitId] - } - deriving (Generic, Read, Show, Typeable) - -instance Binary ComponentLocalBuildInfo -instance Structured ComponentLocalBuildInfo - -instance IsNode ComponentLocalBuildInfo where - type Key ComponentLocalBuildInfo = UnitId - nodeKey = componentUnitId - nodeNeighbors = componentInternalDeps - -componentIsIndefinite :: ComponentLocalBuildInfo -> Bool -componentIsIndefinite LibComponentLocalBuildInfo{ componentIsIndefinite_ = b } = b -componentIsIndefinite _ = False - -maybeComponentInstantiatedWith :: ComponentLocalBuildInfo -> Maybe [(ModuleName, OpenModule)] -maybeComponentInstantiatedWith - LibComponentLocalBuildInfo { componentInstantiatedWith = insts } = Just insts -maybeComponentInstantiatedWith _ = Nothing diff --git a/cabal/Cabal/Distribution/Types/ComponentName.hs b/cabal/Cabal/Distribution/Types/ComponentName.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/ComponentName.hs +++ /dev/null @@ -1,78 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - -module Distribution.Types.ComponentName ( - ComponentName(..), - showComponentName, - componentNameStanza, - componentNameString, - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Types.UnqualComponentName -import Distribution.Types.LibraryName -import Distribution.Pretty -import Distribution.Parsec - -import qualified Text.PrettyPrint as Disp -import qualified Distribution.Compat.CharParsing as P - --- Libraries live in a separate namespace, so must distinguish -data ComponentName = CLibName LibraryName - | CFLibName UnqualComponentName - | CExeName UnqualComponentName - | CTestName UnqualComponentName - | CBenchName UnqualComponentName - deriving (Eq, Generic, Ord, Read, Show, Typeable) - -instance Binary ComponentName -instance Structured ComponentName - --- Build-target-ish syntax -instance Pretty ComponentName where - pretty (CLibName lib) = prettyLibraryNameComponent lib - pretty (CFLibName str) = Disp.text "flib:" <<>> pretty str - pretty (CExeName str) = Disp.text "exe:" <<>> pretty str - pretty (CTestName str) = Disp.text "test:" <<>> pretty str - pretty (CBenchName str) = Disp.text "bench:" <<>> pretty str - -instance Parsec ComponentName where - -- note: this works as lib/flib/... all start with different character! - parsec = parseComposite <|> parseLib - where - parseLib = CLibName <$> parsecLibraryNameComponent - parseComposite = do - ctor <- P.choice - [ P.string "flib:" >> return CFLibName - , P.string "exe:" >> return CExeName - , P.string "bench:" >> return CBenchName - , P.string "test:" >> return CTestName - ] - ctor <$> parsec - -showComponentName :: ComponentName -> String -showComponentName (CLibName lib) = showLibraryName lib -showComponentName (CFLibName name) = "foreign library '" ++ prettyShow name ++ "'" -showComponentName (CExeName name) = "executable '" ++ prettyShow name ++ "'" -showComponentName (CTestName name) = "test suite '" ++ prettyShow name ++ "'" -showComponentName (CBenchName name) = "benchmark '" ++ prettyShow name ++ "'" - -componentNameStanza :: ComponentName -> String -componentNameStanza (CLibName lib) = libraryNameStanza lib -componentNameStanza (CFLibName name) = "foreign-library " ++ prettyShow name -componentNameStanza (CExeName name) = "executable " ++ prettyShow name -componentNameStanza (CTestName name) = "test-suite " ++ prettyShow name -componentNameStanza (CBenchName name) = "benchmark " ++ prettyShow name - --- | This gets the underlying unqualified component name. In fact, it is --- guaranteed to uniquely identify a component, returning --- @Nothing@ if the 'ComponentName' was for the public --- library. -componentNameString :: ComponentName -> Maybe UnqualComponentName -componentNameString (CLibName lib) = libraryNameString lib -componentNameString (CFLibName n) = Just n -componentNameString (CExeName n) = Just n -componentNameString (CTestName n) = Just n -componentNameString (CBenchName n) = Just n diff --git a/cabal/Cabal/Distribution/Types/ComponentRequestedSpec.hs b/cabal/Cabal/Distribution/Types/ComponentRequestedSpec.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/ComponentRequestedSpec.hs +++ /dev/null @@ -1,127 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.ComponentRequestedSpec ( - -- $buildable_vs_enabled_components - - ComponentRequestedSpec(..), - ComponentDisabledReason(..), - - defaultComponentRequestedSpec, - componentNameRequested, - - componentEnabled, - componentDisabledReason, -) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Types.Component -- TODO: maybe remove me? -import Distribution.Types.ComponentName - -import Distribution.Pretty (prettyShow) - --- $buildable_vs_enabled_components --- #buildable_vs_enabled_components# --- --- = Note: Buildable versus requested versus enabled components --- What's the difference between a buildable component (ala --- 'componentBuildable'), a requested component --- (ala 'componentNameRequested'), and an enabled component (ala --- 'componentEnabled')? --- --- A component is __buildable__ if, after resolving flags and --- conditionals, there is no @buildable: False@ property in it. --- This is a /static/ property that arises from the --- Cabal file and the package description flattening; once we have --- a 'PackageDescription' buildability is known. --- --- A component is __requested__ if a user specified, via a --- the flags and arguments passed to configure, that it should be --- built. E.g., @--enable-tests@ or @--enable-benchmarks@ request --- all tests and benchmarks, if they are provided. What is requested --- can be read off directly from 'ComponentRequestedSpec'. A requested --- component is not always buildable; e.g., a user may @--enable-tests@ --- but one of the test suites may have @buildable: False@. --- --- A component is __enabled__ if it is BOTH buildable --- and requested. Once we have a 'LocalBuildInfo', whether or not a --- component is enabled is known. --- --- Generally speaking, most Cabal API code cares if a component --- is enabled. (For example, if you want to run a preprocessor on each --- component prior to building them, you want to run this on each --- /enabled/ component.) --- --- Note that post-configuration, you will generally not see a --- non-buildable 'Component'. This is because 'flattenPD' will drop --- any such components from 'PackageDescription'. See #3858 for --- an example where this causes problems. - --- | Describes what components are enabled by user-interaction. --- See also this note in --- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components". --- --- @since 2.0.0.2 -data ComponentRequestedSpec - = ComponentRequestedSpec { testsRequested :: Bool - , benchmarksRequested :: Bool } - | OneComponentRequestedSpec ComponentName - deriving (Generic, Read, Show, Eq, Typeable) - -instance Binary ComponentRequestedSpec -instance Structured ComponentRequestedSpec - --- | The default set of enabled components. Historically tests and --- benchmarks are NOT enabled by default. --- --- @since 2.0.0.2 -defaultComponentRequestedSpec :: ComponentRequestedSpec -defaultComponentRequestedSpec = ComponentRequestedSpec False False - --- | Is this component enabled? See also this note in --- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components". --- --- @since 2.0.0.2 -componentEnabled :: ComponentRequestedSpec -> Component -> Bool -componentEnabled enabled = isNothing . componentDisabledReason enabled - --- | Is this component name enabled? See also this note in --- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components". --- --- @since 2.0.0.2 -componentNameRequested :: ComponentRequestedSpec -> ComponentName -> Bool -componentNameRequested enabled = isNothing . componentNameNotRequestedReason enabled - --- | Is this component disabled, and if so, why? --- --- @since 2.0.0.2 -componentDisabledReason :: ComponentRequestedSpec -> Component - -> Maybe ComponentDisabledReason -componentDisabledReason enabled comp - | not (componentBuildable comp) = Just DisabledComponent - | otherwise = componentNameNotRequestedReason enabled (componentName comp) - --- | Is this component name disabled, and if so, why? --- --- @since 2.0.0.2 -componentNameNotRequestedReason :: ComponentRequestedSpec -> ComponentName - -> Maybe ComponentDisabledReason -componentNameNotRequestedReason - ComponentRequestedSpec{ testsRequested = False } (CTestName _) - = Just DisabledAllTests -componentNameNotRequestedReason - ComponentRequestedSpec{ benchmarksRequested = False } (CBenchName _) - = Just DisabledAllBenchmarks -componentNameNotRequestedReason ComponentRequestedSpec{} _ = Nothing -componentNameNotRequestedReason (OneComponentRequestedSpec cname) c - | c == cname = Nothing - | otherwise = Just (DisabledAllButOne (prettyShow cname)) - --- | A reason explaining why a component is disabled. --- --- @since 2.0.0.2 -data ComponentDisabledReason = DisabledComponent - | DisabledAllTests - | DisabledAllBenchmarks - | DisabledAllButOne String diff --git a/cabal/Cabal/Distribution/Types/CondTree.hs b/cabal/Cabal/Distribution/Types/CondTree.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/CondTree.hs +++ /dev/null @@ -1,181 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Distribution.Types.CondTree ( - CondTree(..), - CondBranch(..), - condIfThen, - condIfThenElse, - mapCondTree, - mapTreeConstrs, - mapTreeConds, - mapTreeData, - traverseCondTreeV, - traverseCondBranchV, - traverseCondTreeC, - traverseCondBranchC, - extractCondition, - simplifyCondTree, - ignoreConditions, -) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Types.Condition - -import qualified Distribution.Compat.Lens as L - - --- | A 'CondTree' is used to represent the conditional structure of --- a Cabal file, reflecting a syntax element subject to constraints, --- and then any number of sub-elements which may be enabled subject --- to some condition. Both @a@ and @c@ are usually 'Monoid's. --- --- To be more concrete, consider the following fragment of a @Cabal@ --- file: --- --- @ --- build-depends: base >= 4.0 --- if flag(extra) --- build-depends: base >= 4.2 --- @ --- --- One way to represent this is to have @'CondTree' 'ConfVar' --- ['Dependency'] 'BuildInfo'@. Here, 'condTreeData' represents --- the actual fields which are not behind any conditional, while --- 'condTreeComponents' recursively records any further fields --- which are behind a conditional. 'condTreeConstraints' records --- the constraints (in this case, @base >= 4.0@) which would --- be applied if you use this syntax; in general, this is --- derived off of 'targetBuildInfo' (perhaps a good refactoring --- would be to convert this into an opaque type, with a smart --- constructor that pre-computes the dependencies.) --- -data CondTree v c a = CondNode - { condTreeData :: a - , condTreeConstraints :: c - , condTreeComponents :: [CondBranch v c a] - } - deriving (Show, Eq, Typeable, Data, Generic, Functor, Foldable, Traversable) - -instance (Binary v, Binary c, Binary a) => Binary (CondTree v c a) -instance (Structured v, Structured c, Structured a) => Structured (CondTree v c a) -instance (NFData v, NFData c, NFData a) => NFData (CondTree v c a) where rnf = genericRnf - --- | A 'CondBranch' represents a conditional branch, e.g., @if --- flag(foo)@ on some syntax @a@. It also has an optional false --- branch. --- -data CondBranch v c a = CondBranch - { condBranchCondition :: Condition v - , condBranchIfTrue :: CondTree v c a - , condBranchIfFalse :: Maybe (CondTree v c a) - } - deriving (Show, Eq, Typeable, Data, Generic, Functor, Traversable) - --- This instance is written by hand because GHC 8.0.1/8.0.2 infinite --- loops when trying to derive it with optimizations. See --- https://gitlab.haskell.org/ghc/ghc/-/issues/13056 -instance Foldable (CondBranch v c) where - foldMap f (CondBranch _ c Nothing) = foldMap f c - foldMap f (CondBranch _ c (Just a)) = foldMap f c `mappend` foldMap f a - -instance (Binary v, Binary c, Binary a) => Binary (CondBranch v c a) -instance (Structured v, Structured c, Structured a) => Structured (CondBranch v c a) -instance (NFData v, NFData c, NFData a) => NFData (CondBranch v c a) where rnf = genericRnf - -condIfThen :: Condition v -> CondTree v c a -> CondBranch v c a -condIfThen c t = CondBranch c t Nothing - -condIfThenElse :: Condition v -> CondTree v c a -> CondTree v c a -> CondBranch v c a -condIfThenElse c t e = CondBranch c t (Just e) - -mapCondTree :: (a -> b) -> (c -> d) -> (Condition v -> Condition w) - -> CondTree v c a -> CondTree w d b -mapCondTree fa fc fcnd (CondNode a c ifs) = - CondNode (fa a) (fc c) (map g ifs) - where - g (CondBranch cnd t me) - = CondBranch (fcnd cnd) - (mapCondTree fa fc fcnd t) - (fmap (mapCondTree fa fc fcnd) me) - -mapTreeConstrs :: (c -> d) -> CondTree v c a -> CondTree v d a -mapTreeConstrs f = mapCondTree id f id - -mapTreeConds :: (Condition v -> Condition w) -> CondTree v c a -> CondTree w c a -mapTreeConds f = mapCondTree id id f - -mapTreeData :: (a -> b) -> CondTree v c a -> CondTree v c b -mapTreeData f = mapCondTree f id id - --- | @@Traversal@@ for the variables -traverseCondTreeV :: L.Traversal (CondTree v c a) (CondTree w c a) v w -traverseCondTreeV f (CondNode a c ifs) = - CondNode a c <$> traverse (traverseCondBranchV f) ifs - --- | @@Traversal@@ for the variables -traverseCondBranchV :: L.Traversal (CondBranch v c a) (CondBranch w c a) v w -traverseCondBranchV f (CondBranch cnd t me) = CondBranch - <$> traverse f cnd - <*> traverseCondTreeV f t - <*> traverse (traverseCondTreeV f) me - --- | @@Traversal@@ for the aggregated constraints -traverseCondTreeC :: L.Traversal (CondTree v c a) (CondTree v d a) c d -traverseCondTreeC f (CondNode a c ifs) = - CondNode a <$> f c <*> traverse (traverseCondBranchC f) ifs - --- | @@Traversal@@ for the aggregated constraints -traverseCondBranchC :: L.Traversal (CondBranch v c a) (CondBranch v d a) c d -traverseCondBranchC f (CondBranch cnd t me) = CondBranch cnd - <$> traverseCondTreeC f t - <*> traverse (traverseCondTreeC f) me - - --- | Extract the condition matched by the given predicate from a cond tree. --- --- We use this mainly for extracting buildable conditions (see the Note in --- Distribution.PackageDescription.Configuration), but the function is in fact --- more general. -extractCondition :: Eq v => (a -> Bool) -> CondTree v c a -> Condition v -extractCondition p = go - where - go (CondNode x _ cs) | not (p x) = Lit False - | otherwise = goList cs - - goList [] = Lit True - goList (CondBranch c t e : cs) = - let - ct = go t - ce = maybe (Lit True) go e - in - ((c `cAnd` ct) `cOr` (CNot c `cAnd` ce)) `cAnd` goList cs - --- | Flattens a CondTree using a partial flag assignment. When a condition --- cannot be evaluated, both branches are ignored. -simplifyCondTree :: (Semigroup a, Semigroup d) => - (v -> Either v Bool) - -> CondTree v d a - -> (d, a) -simplifyCondTree env (CondNode a d ifs) = - foldl (<>) (d, a) $ mapMaybe simplifyIf ifs - where - simplifyIf (CondBranch cnd t me) = - case simplifyCondition cnd env of - (Lit True, _) -> Just $ simplifyCondTree env t - (Lit False, _) -> fmap (simplifyCondTree env) me - _ -> Nothing - --- | Flatten a CondTree. This will resolve the CondTree by taking all --- possible paths into account. Note that since branches represent exclusive --- choices this may not result in a \"sane\" result. -ignoreConditions :: (Semigroup a, Semigroup c) => CondTree v c a -> (a, c) -ignoreConditions (CondNode a c ifs) = foldl (<>) (a, c) $ concatMap f ifs - where f (CondBranch _ t me) = ignoreConditions t - : maybeToList (fmap ignoreConditions me) diff --git a/cabal/Cabal/Distribution/Types/Condition.hs b/cabal/Cabal/Distribution/Types/Condition.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/Condition.hs +++ /dev/null @@ -1,135 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - -module Distribution.Types.Condition ( - Condition(..), - cNot, - cAnd, - cOr, - simplifyCondition, -) where - -import Prelude () -import Distribution.Compat.Prelude - --- | A boolean expression parameterized over the variable type used. -data Condition c = Var c - | Lit Bool - | CNot (Condition c) - | COr (Condition c) (Condition c) - | CAnd (Condition c) (Condition c) - deriving (Show, Eq, Typeable, Data, Generic) - --- | Boolean negation of a 'Condition' value. -cNot :: Condition a -> Condition a -cNot (Lit b) = Lit (not b) -cNot (CNot c) = c -cNot c = CNot c - --- | Boolean AND of two 'Condtion' values. -cAnd :: Condition a -> Condition a -> Condition a -cAnd (Lit False) _ = Lit False -cAnd _ (Lit False) = Lit False -cAnd (Lit True) x = x -cAnd x (Lit True) = x -cAnd x y = CAnd x y - --- | Boolean OR of two 'Condition' values. -cOr :: Eq v => Condition v -> Condition v -> Condition v -cOr (Lit True) _ = Lit True -cOr _ (Lit True) = Lit True -cOr (Lit False) x = x -cOr x (Lit False) = x -cOr c (CNot d) - | c == d = Lit True -cOr (CNot c) d - | c == d = Lit True -cOr x y = COr x y - -instance Functor Condition where - f `fmap` Var c = Var (f c) - _ `fmap` Lit c = Lit c - f `fmap` CNot c = CNot (fmap f c) - f `fmap` COr c d = COr (fmap f c) (fmap f d) - f `fmap` CAnd c d = CAnd (fmap f c) (fmap f d) - -instance Foldable Condition where - f `foldMap` Var c = f c - _ `foldMap` Lit _ = mempty - f `foldMap` CNot c = foldMap f c - f `foldMap` COr c d = foldMap f c `mappend` foldMap f d - f `foldMap` CAnd c d = foldMap f c `mappend` foldMap f d - -instance Traversable Condition where - f `traverse` Var c = Var `fmap` f c - _ `traverse` Lit c = pure $ Lit c - f `traverse` CNot c = CNot `fmap` traverse f c - f `traverse` COr c d = COr `fmap` traverse f c <*> traverse f d - f `traverse` CAnd c d = CAnd `fmap` traverse f c <*> traverse f d - -instance Applicative Condition where - pure = Var - (<*>) = ap - -instance Monad Condition where - return = pure - -- Terminating cases - (>>=) (Lit x) _ = Lit x - (>>=) (Var x) f = f x - -- Recursing cases - (>>=) (CNot x ) f = CNot (x >>= f) - (>>=) (COr x y) f = COr (x >>= f) (y >>= f) - (>>=) (CAnd x y) f = CAnd (x >>= f) (y >>= f) - -instance Monoid (Condition a) where - mempty = Lit False - mappend = (<>) - -instance Semigroup (Condition a) where - (<>) = COr - -instance Alternative Condition where - empty = mempty - (<|>) = mappend - -instance MonadPlus Condition where - mzero = mempty - mplus = mappend - -instance Binary c => Binary (Condition c) -instance Structured c => Structured (Condition c) -instance NFData c => NFData (Condition c) where rnf = genericRnf - --- | Simplify the condition and return its free variables. -simplifyCondition :: Condition c - -> (c -> Either d Bool) -- ^ (partial) variable assignment - -> (Condition d, [d]) -simplifyCondition cond i = fv . walk $ cond - where - walk cnd = case cnd of - Var v -> either Var Lit (i v) - Lit b -> Lit b - CNot c -> case walk c of - Lit True -> Lit False - Lit False -> Lit True - c' -> CNot c' - COr c d -> case (walk c, walk d) of - (Lit False, d') -> d' - (Lit True, _) -> Lit True - (c', Lit False) -> c' - (_, Lit True) -> Lit True - (c',d') -> COr c' d' - CAnd c d -> case (walk c, walk d) of - (Lit False, _) -> Lit False - (Lit True, d') -> d' - (_, Lit False) -> Lit False - (c', Lit True) -> c' - (c',d') -> CAnd c' d' - -- gather free vars - fv c = (c, fv' c) - fv' c = case c of - Var v -> [v] - Lit _ -> [] - CNot c' -> fv' c' - COr c1 c2 -> fv' c1 ++ fv' c2 - CAnd c1 c2 -> fv' c1 ++ fv' c2 diff --git a/cabal/Cabal/Distribution/Types/ConfVar.hs b/cabal/Cabal/Distribution/Types/ConfVar.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/ConfVar.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.ConfVar ( - ConfVar(..), - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Types.Flag -import Distribution.Types.VersionRange -import Distribution.Compiler -import Distribution.System - --- | A @ConfVar@ represents the variable type used. -data ConfVar = OS OS - | Arch Arch - | PackageFlag FlagName - | Impl CompilerFlavor VersionRange - deriving (Eq, Show, Typeable, Data, Generic) - -instance Binary ConfVar -instance Structured ConfVar - -instance NFData ConfVar where rnf = genericRnf diff --git a/cabal/Cabal/Distribution/Types/Dependency.hs b/cabal/Cabal/Distribution/Types/Dependency.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/Dependency.hs +++ /dev/null @@ -1,179 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.Dependency - ( Dependency(..) - , mkDependency - , depPkgName - , depVerRange - , depLibraries - , simplifyDependency - , mainLibSet - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Types.VersionRange (isAnyVersionLight) -import Distribution.Version (VersionRange, anyVersion, simplifyVersionRange) - -import Distribution.CabalSpecVersion -import Distribution.Compat.CharParsing (char, spaces) -import Distribution.Compat.Parsing (between, option) -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Types.LibraryName -import Distribution.Types.PackageName -import Distribution.Types.UnqualComponentName - -import qualified Distribution.Compat.NonEmptySet as NES -import qualified Text.PrettyPrint as PP - --- | Describes a dependency on a source package (API) --- --- /Invariant:/ package name does not appear as 'LSubLibName' in --- set of library names. --- -data Dependency = Dependency - PackageName - VersionRange - (NonEmptySet LibraryName) - -- ^ The set of libraries required from the package. - -- Only the selected libraries will be built. - -- It does not affect the cabal-install solver yet. - deriving (Generic, Read, Show, Eq, Typeable, Data) - -depPkgName :: Dependency -> PackageName -depPkgName (Dependency pn _ _) = pn - -depVerRange :: Dependency -> VersionRange -depVerRange (Dependency _ vr _) = vr - -depLibraries :: Dependency -> NonEmptySet LibraryName -depLibraries (Dependency _ _ cs) = cs - --- | Smart constructor of 'Dependency'. --- --- If 'PackageName' is appears as 'LSubLibName' in a set of sublibraries, --- it is automatically converted to 'LMainLibName'. --- --- @since 3.4.0.0 --- -mkDependency :: PackageName -> VersionRange -> NonEmptySet LibraryName -> Dependency -mkDependency pn vr lb = Dependency pn vr (NES.map conv lb) - where - pn' = packageNameToUnqualComponentName pn - - conv l@LMainLibName = l - conv l@(LSubLibName ln) | ln == pn' = LMainLibName - | otherwise = l - -instance Binary Dependency -instance Structured Dependency -instance NFData Dependency where rnf = genericRnf - --- | --- --- >>> prettyShow $ Dependency "pkg" anyVersion mainLibSet --- "pkg" --- --- >>> prettyShow $ Dependency "pkg" anyVersion $ NES.insert (LSubLibName "sublib") mainLibSet --- "pkg:{pkg, sublib}" --- --- >>> prettyShow $ Dependency "pkg" anyVersion $ NES.singleton (LSubLibName "sublib") --- "pkg:sublib" --- --- >>> prettyShow $ Dependency "pkg" anyVersion $ NES.insert (LSubLibName "sublib-b") $ NES.singleton (LSubLibName "sublib-a") --- "pkg:{sublib-a, sublib-b}" --- -instance Pretty Dependency where - pretty (Dependency name ver sublibs) = withSubLibs (pretty name) <+> pver - where - -- TODO: change to isAnyVersion after #6736 - pver | isAnyVersionLight ver = PP.empty - | otherwise = pretty ver - - withSubLibs doc = case NES.toList sublibs of - [LMainLibName] -> doc - [LSubLibName uq] -> doc <<>> PP.colon <<>> pretty uq - _ -> doc <<>> PP.colon <<>> PP.braces prettySublibs - - prettySublibs = PP.hsep $ PP.punctuate PP.comma $ prettySublib <$> NES.toList sublibs - - prettySublib LMainLibName = PP.text $ unPackageName name - prettySublib (LSubLibName un) = PP.text $ unUnqualComponentName un - --- | --- --- >>> simpleParsec "mylib:sub" :: Maybe Dependency --- Just (Dependency (PackageName "mylib") (OrLaterVersion (mkVersion [0])) (fromNonEmpty (LSubLibName (UnqualComponentName "sub") :| []))) --- --- >>> simpleParsec "mylib:{sub1,sub2}" :: Maybe Dependency --- Just (Dependency (PackageName "mylib") (OrLaterVersion (mkVersion [0])) (fromNonEmpty (LSubLibName (UnqualComponentName "sub1") :| [LSubLibName (UnqualComponentName "sub2")]))) --- --- >>> simpleParsec "mylib:{ sub1 , sub2 }" :: Maybe Dependency --- Just (Dependency (PackageName "mylib") (OrLaterVersion (mkVersion [0])) (fromNonEmpty (LSubLibName (UnqualComponentName "sub1") :| [LSubLibName (UnqualComponentName "sub2")]))) --- --- >>> simpleParsec "mylib:{ sub1 , sub2 } ^>= 42" :: Maybe Dependency --- Just (Dependency (PackageName "mylib") (MajorBoundVersion (mkVersion [42])) (fromNonEmpty (LSubLibName (UnqualComponentName "sub1") :| [LSubLibName (UnqualComponentName "sub2")]))) --- --- >>> simpleParsec "mylib:{ } ^>= 42" :: Maybe Dependency --- Nothing --- --- >>> traverse_ print (map simpleParsec ["mylib:mylib", "mylib:{mylib}", "mylib:{mylib,sublib}" ] :: [Maybe Dependency]) --- Just (Dependency (PackageName "mylib") (OrLaterVersion (mkVersion [0])) (fromNonEmpty (LMainLibName :| []))) --- Just (Dependency (PackageName "mylib") (OrLaterVersion (mkVersion [0])) (fromNonEmpty (LMainLibName :| []))) --- Just (Dependency (PackageName "mylib") (OrLaterVersion (mkVersion [0])) (fromNonEmpty (LMainLibName :| [LSubLibName (UnqualComponentName "sublib")]))) --- --- Spaces around colon are not allowed: --- --- >>> map simpleParsec ["mylib: sub", "mylib :sub", "mylib: {sub1,sub2}", "mylib :{sub1,sub2}"] :: [Maybe Dependency] --- [Nothing,Nothing,Nothing,Nothing] --- --- Sublibrary syntax is accepted since @cabal-version: 3.0@ --- --- >>> map (`simpleParsec'` "mylib:sub") [CabalSpecV2_4, CabalSpecV3_0] :: [Maybe Dependency] --- [Nothing,Just (Dependency (PackageName "mylib") (OrLaterVersion (mkVersion [0])) (fromNonEmpty (LSubLibName (UnqualComponentName "sub") :| [])))] --- -instance Parsec Dependency where - parsec = do - name <- parsec - - libs <- option mainLibSet $ do - _ <- char ':' - versionGuardMultilibs - parsecWarning PWTExperimental "colon specifier is experimental feature (issue #5660)" - NES.singleton <$> parseLib <|> parseMultipleLibs - - spaces -- https://github.com/haskell/cabal/issues/5846 - - ver <- parsec <|> pure anyVersion - return $ mkDependency name ver libs - where - parseLib = LSubLibName <$> parsec - parseMultipleLibs = between - (char '{' *> spaces) - (spaces *> char '}') - (NES.fromNonEmpty <$> parsecCommaNonEmpty parseLib) - -versionGuardMultilibs :: CabalParsing m => m () -versionGuardMultilibs = do - csv <- askCabalSpecVersion - when (csv < CabalSpecV3_0) $ fail $ unwords - [ "Sublibrary dependency syntax used." - , "To use this syntax the package needs to specify at least 'cabal-version: 3.0'." - , "Alternatively, if you are depending on an internal library, you can write" - , "directly the library name as it were a package." - ] - --- | Library set with main library. --- --- @since 3.4.0.0 -mainLibSet :: NonEmptySet LibraryName -mainLibSet = NES.singleton LMainLibName - --- | Simplify the 'VersionRange' expression in a 'Dependency'. --- See 'simplifyVersionRange'. --- -simplifyDependency :: Dependency -> Dependency -simplifyDependency (Dependency name range comps) = - Dependency name (simplifyVersionRange range) comps diff --git a/cabal/Cabal/Distribution/Types/DependencyMap.hs b/cabal/Cabal/Distribution/Types/DependencyMap.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/DependencyMap.hs +++ /dev/null @@ -1,57 +0,0 @@ -module Distribution.Types.DependencyMap ( - DependencyMap, - toDepMap, - fromDepMap, - constrainBy, -) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Types.Dependency -import Distribution.Types.LibraryName -import Distribution.Types.PackageName -import Distribution.Types.PackageVersionConstraint -import Distribution.Version - -import qualified Data.Map.Lazy as Map - --- | A map of dependencies. Newtyped since the default monoid instance is not --- appropriate. The monoid instance uses 'intersectVersionRanges'. -newtype DependencyMap = DependencyMap { unDependencyMap :: Map PackageName (VersionRange, NonEmptySet LibraryName) } - deriving (Show, Read) - -instance Monoid DependencyMap where - mempty = DependencyMap Map.empty - mappend = (<>) - -instance Semigroup DependencyMap where - (DependencyMap a) <> (DependencyMap b) = - DependencyMap (Map.unionWith intersectVersionRangesAndJoinComponents a b) - -intersectVersionRangesAndJoinComponents :: (VersionRange, NonEmptySet LibraryName) - -> (VersionRange, NonEmptySet LibraryName) - -> (VersionRange, NonEmptySet LibraryName) -intersectVersionRangesAndJoinComponents (va, ca) (vb, cb) = - (intersectVersionRanges va vb, ca <> cb) - -toDepMap :: [Dependency] -> DependencyMap -toDepMap ds = - DependencyMap $ Map.fromListWith intersectVersionRangesAndJoinComponents [ (p,(vr,cs)) | Dependency p vr cs <- ds ] - -fromDepMap :: DependencyMap -> [Dependency] -fromDepMap m = [ Dependency p vr cs | (p,(vr,cs)) <- Map.toList (unDependencyMap m) ] - --- Apply extra constraints to a dependency map. --- Combines dependencies where the result will only contain keys from the left --- (first) map. If a key also exists in the right map, both constraints will --- be intersected. -constrainBy - :: DependencyMap - -> [PackageVersionConstraint] - -> DependencyMap -constrainBy = foldl' tightenConstraint where - tightenConstraint (DependencyMap l) (PackageVersionConstraint pn vr) = DependencyMap $ - case Map.lookup pn l of - Nothing -> l - Just (vr', cs) -> Map.insert pn (intersectVersionRanges vr' vr, cs) l diff --git a/cabal/Cabal/Distribution/Types/ExeDependency.hs b/cabal/Cabal/Distribution/Types/ExeDependency.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/ExeDependency.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.ExeDependency - ( ExeDependency(..) - , qualifiedExeName - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Types.ComponentName -import Distribution.Types.PackageName -import Distribution.Types.UnqualComponentName -import Distribution.Version (VersionRange, anyVersion, isAnyVersion) - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as PP - --- | Describes a dependency on an executable from a package --- -data ExeDependency = ExeDependency - PackageName - UnqualComponentName -- name of executable component of package - VersionRange - deriving (Generic, Read, Show, Eq, Typeable, Data) - -instance Binary ExeDependency -instance Structured ExeDependency -instance NFData ExeDependency where rnf = genericRnf - -instance Pretty ExeDependency where - pretty (ExeDependency name exe ver) = - pretty name <<>> PP.colon <<>> pretty exe PP.<+> pver - where - pver | isAnyVersion ver = PP.empty - | otherwise = pretty ver - --- | --- --- Examples --- --- >>> simpleParsec "happy:happy" :: Maybe ExeDependency --- Just (ExeDependency (PackageName "happy") (UnqualComponentName "happy") (OrLaterVersion (mkVersion [0]))) --- --- >>> simpleParsec "happy:happy >= 1.19.12" :: Maybe ExeDependency --- Just (ExeDependency (PackageName "happy") (UnqualComponentName "happy") (OrLaterVersion (mkVersion [1,19,12]))) --- --- >>> simpleParsec "happy:happy>=1.19.12" :: Maybe ExeDependency --- Just (ExeDependency (PackageName "happy") (UnqualComponentName "happy") (OrLaterVersion (mkVersion [1,19,12]))) --- --- >>> simpleParsec "happy : happy >= 1.19.12" :: Maybe ExeDependency --- Nothing --- --- >>> simpleParsec "happy: happy >= 1.19.12" :: Maybe ExeDependency --- Nothing --- --- >>> simpleParsec "happy :happy >= 1.19.12" :: Maybe ExeDependency --- Nothing --- -instance Parsec ExeDependency where - parsec = do - name <- parsec - _ <- P.char ':' - exe <- lexemeParsec - ver <- parsec <|> pure anyVersion - return (ExeDependency name exe ver) - -qualifiedExeName :: ExeDependency -> ComponentName -qualifiedExeName (ExeDependency _ ucn _) = CExeName ucn diff --git a/cabal/Cabal/Distribution/Types/Executable.hs b/cabal/Cabal/Distribution/Types/Executable.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/Executable.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE NoMonoLocalBinds #-} - -module Distribution.Types.Executable ( - Executable(..), - emptyExecutable, - exeModules, - exeModulesAutogen -) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Types.BuildInfo -import Distribution.Types.UnqualComponentName -import Distribution.Types.ExecutableScope -import Distribution.ModuleName - -import qualified Distribution.Types.BuildInfo.Lens as L - -data Executable = Executable { - exeName :: UnqualComponentName, - modulePath :: FilePath, - exeScope :: ExecutableScope, - buildInfo :: BuildInfo - } - deriving (Generic, Show, Read, Eq, Typeable, Data) - -instance L.HasBuildInfo Executable where - buildInfo f l = (\x -> l { buildInfo = x }) <$> f (buildInfo l) - -instance Binary Executable -instance Structured Executable -instance NFData Executable where rnf = genericRnf - -instance Monoid Executable where - mempty = gmempty - mappend = (<>) - -instance Semigroup Executable where - a <> b = Executable{ - exeName = combine' exeName, - modulePath = combine modulePath, - exeScope = combine exeScope, - buildInfo = combine buildInfo - } - where combine field = field a `mappend` field b - combine' field = case ( unUnqualComponentName $ field a - , unUnqualComponentName $ field b) of - ("", _) -> field b - (_, "") -> field a - (x, y) -> error $ "Ambiguous values for executable field: '" - ++ x ++ "' and '" ++ y ++ "'" - -emptyExecutable :: Executable -emptyExecutable = mempty - --- | Get all the module names from an exe -exeModules :: Executable -> [ModuleName] -exeModules exe = otherModules (buildInfo exe) - --- | Get all the auto generated module names from an exe --- This are a subset of 'exeModules'. -exeModulesAutogen :: Executable -> [ModuleName] -exeModulesAutogen exe = autogenModules (buildInfo exe) diff --git a/cabal/Cabal/Distribution/Types/Executable/Lens.hs b/cabal/Cabal/Distribution/Types/Executable/Lens.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/Executable/Lens.hs +++ /dev/null @@ -1,31 +0,0 @@ -module Distribution.Types.Executable.Lens ( - Executable, - module Distribution.Types.Executable.Lens, - ) where - -import Distribution.Compat.Lens -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Types.BuildInfo (BuildInfo) -import Distribution.Types.Executable (Executable) -import Distribution.Types.ExecutableScope (ExecutableScope) -import Distribution.Types.UnqualComponentName (UnqualComponentName) - -import qualified Distribution.Types.Executable as T - -exeName :: Lens' Executable UnqualComponentName -exeName f s = fmap (\x -> s { T.exeName = x }) (f (T.exeName s)) -{-# INLINE exeName #-} - -modulePath :: Lens' Executable String -modulePath f s = fmap (\x -> s { T.modulePath = x }) (f (T.modulePath s)) -{-# INLINE modulePath #-} - -exeScope :: Lens' Executable ExecutableScope -exeScope f s = fmap (\x -> s { T.exeScope = x }) (f (T.exeScope s)) -{-# INLINE exeScope #-} - -exeBuildInfo :: Lens' Executable BuildInfo -exeBuildInfo f s = fmap (\x -> s { T.buildInfo = x }) (f (T.buildInfo s)) -{-# INLINE exeBuildInfo #-} diff --git a/cabal/Cabal/Distribution/Types/ExecutableScope.hs b/cabal/Cabal/Distribution/Types/ExecutableScope.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/ExecutableScope.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} - -module Distribution.Types.ExecutableScope ( - ExecutableScope(..), -) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Pretty -import Distribution.Parsec - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - -data ExecutableScope = ExecutablePublic - | ExecutablePrivate - deriving (Generic, Show, Read, Eq, Typeable, Data) - -instance Pretty ExecutableScope where - pretty ExecutablePublic = Disp.text "public" - pretty ExecutablePrivate = Disp.text "private" - -instance Parsec ExecutableScope where - parsec = P.try pub <|> pri where - pub = ExecutablePublic <$ P.string "public" - pri = ExecutablePrivate <$ P.string "private" - -instance Binary ExecutableScope -instance Structured ExecutableScope -instance NFData ExecutableScope where rnf = genericRnf - --- | 'Any' like semigroup, where 'ExecutablePrivate' is 'Any True' -instance Semigroup ExecutableScope where - ExecutablePublic <> x = x - x@ExecutablePrivate <> _ = x - --- | 'mempty' = 'ExecutablePublic' -instance Monoid ExecutableScope where - mempty = ExecutablePublic - mappend = (<>) diff --git a/cabal/Cabal/Distribution/Types/ExposedModule.hs b/cabal/Cabal/Distribution/Types/ExposedModule.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/ExposedModule.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.ExposedModule where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Backpack -import Distribution.ModuleName -import Distribution.Parsec -import Distribution.Pretty - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - -data ExposedModule - = ExposedModule { - exposedName :: ModuleName, - exposedReexport :: Maybe OpenModule - } - deriving (Eq, Generic, Read, Show, Typeable) - -instance Pretty ExposedModule where - pretty (ExposedModule m reexport) = - Disp.hsep [ pretty m - , case reexport of - Just m' -> Disp.hsep [Disp.text "from", pretty m'] - Nothing -> Disp.empty - ] - -instance Parsec ExposedModule where - parsec = do - m <- parsecMaybeQuoted parsec - P.spaces - - reexport <- P.optional $ do - _ <- P.string "from" - P.skipSpaces1 - parsec - - return (ExposedModule m reexport) - -instance Binary ExposedModule -instance Structured ExposedModule -instance NFData ExposedModule where rnf = genericRnf diff --git a/cabal/Cabal/Distribution/Types/Flag.hs b/cabal/Cabal/Distribution/Types/Flag.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/Flag.hs +++ /dev/null @@ -1,346 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Distribution.Types.Flag ( - -- * Package flag - PackageFlag(..), - emptyFlag, - -- * Flag name - FlagName, - mkFlagName, - unFlagName, - -- * Flag assignment - FlagAssignment, - mkFlagAssignment, - unFlagAssignment, - lookupFlagAssignment, - insertFlagAssignment, - diffFlagAssignment, - findDuplicateFlagAssignments, - nullFlagAssignment, - showFlagValue, - dispFlagAssignment, - showFlagAssignment, - parsecFlagAssignment, - parsecFlagAssignmentNonEmpty, - -- ** Legacy formats - legacyShowFlagAssignment, - legacyShowFlagAssignment', - legacyParsecFlagAssignment, - ) where - -import Prelude () -import Distribution.Compat.Prelude -import Distribution.Utils.ShortText -import Distribution.Utils.Generic (lowercase) - -import Distribution.Parsec -import Distribution.Pretty - -import qualified Data.Map as Map -import qualified Text.PrettyPrint as Disp -import qualified Distribution.Compat.CharParsing as P - --- ----------------------------------------------------------------------------- --- The Flag' type - --- | A flag can represent a feature to be included, or a way of linking --- a target against its dependencies, or in fact whatever you can think of. -data PackageFlag = MkPackageFlag - { flagName :: FlagName - , flagDescription :: String - , flagDefault :: Bool - , flagManual :: Bool - } - deriving (Show, Eq, Typeable, Data, Generic) - -instance Binary PackageFlag -instance Structured PackageFlag -instance NFData PackageFlag where rnf = genericRnf - --- | A 'PackageFlag' initialized with default parameters. -emptyFlag :: FlagName -> PackageFlag -emptyFlag name = MkPackageFlag - { flagName = name - , flagDescription = "" - , flagDefault = True - , flagManual = False - } - --- | A 'FlagName' is the name of a user-defined configuration flag --- --- Use 'mkFlagName' and 'unFlagName' to convert from/to a 'String'. --- --- This type is opaque since @Cabal-2.0@ --- --- @since 2.0.0.2 -newtype FlagName = FlagName ShortText - deriving (Eq, Generic, Ord, Show, Read, Typeable, Data, NFData) - --- | Construct a 'FlagName' from a 'String' --- --- 'mkFlagName' is the inverse to 'unFlagName' --- --- Note: No validations are performed to ensure that the resulting --- 'FlagName' is valid --- --- @since 2.0.0.2 -mkFlagName :: String -> FlagName -mkFlagName = FlagName . toShortText - --- | 'mkFlagName' --- --- @since 2.0.0.2 -instance IsString FlagName where - fromString = mkFlagName - --- | Convert 'FlagName' to 'String' --- --- @since 2.0.0.2 -unFlagName :: FlagName -> String -unFlagName (FlagName s) = fromShortText s - -instance Binary FlagName -instance Structured FlagName - -instance Pretty FlagName where - pretty = Disp.text . unFlagName - -instance Parsec FlagName where - -- Note: we don't check that FlagName doesn't have leading dash, - -- cabal check will do that. - parsec = mkFlagName . lowercase <$> parsec' - where - parsec' = (:) <$> lead <*> rest - lead = P.satisfy (\c -> isAlphaNum c || c == '_') - rest = P.munch (\c -> isAlphaNum c || c == '_' || c == '-') - --- | A 'FlagAssignment' is a total or partial mapping of 'FlagName's to --- 'Bool' flag values. It represents the flags chosen by the user or --- discovered during configuration. For example @--flags=foo --flags=-bar@ --- becomes @[("foo", True), ("bar", False)]@ --- --- TODO: Why we record the multiplicity of the flag? --- -newtype FlagAssignment - = FlagAssignment { getFlagAssignment :: Map.Map FlagName (Int, Bool) } - deriving (Binary, Generic, NFData, Typeable) - -instance Structured FlagAssignment - -instance Eq FlagAssignment where - (==) (FlagAssignment m1) (FlagAssignment m2) - = fmap snd m1 == fmap snd m2 - -instance Ord FlagAssignment where - compare (FlagAssignment m1) (FlagAssignment m2) - = fmap snd m1 `compare` fmap snd m2 - --- | Combines pairs of values contained in the 'FlagAssignment' Map. --- --- The last flag specified takes precedence, and we record the number --- of times we have seen the flag. --- -combineFlagValues :: (Int, Bool) -> (Int, Bool) -> (Int, Bool) -combineFlagValues (c1, _) (c2, b2) = (c1 + c2, b2) - --- The 'Semigroup' instance currently is right-biased. --- --- If duplicate flags are specified, we want the last flag specified to --- take precedence and we want to know how many times the flag has been --- specified so that we have the option of warning the user about --- supplying duplicate flags. -instance Semigroup FlagAssignment where - (<>) (FlagAssignment m1) (FlagAssignment m2) - = FlagAssignment (Map.unionWith combineFlagValues m1 m2) - -instance Monoid FlagAssignment where - mempty = FlagAssignment Map.empty - mappend = (<>) - --- | Construct a 'FlagAssignment' from a list of flag/value pairs. --- --- If duplicate flags occur in the input list, the later entries --- in the list will take precedence. --- --- @since 2.2.0 -mkFlagAssignment :: [(FlagName, Bool)] -> FlagAssignment -mkFlagAssignment = - FlagAssignment . - Map.fromListWith (flip combineFlagValues) . fmap (fmap (\b -> (1, b))) - --- | Deconstruct a 'FlagAssignment' into a list of flag/value pairs. --- --- @ 'null' ('findDuplicateFlagAssignments' fa) ==> ('mkFlagAssignment' . 'unFlagAssignment') fa == fa @ --- --- @since 2.2.0 -unFlagAssignment :: FlagAssignment -> [(FlagName, Bool)] -unFlagAssignment = fmap (fmap snd) . Map.toList . getFlagAssignment - --- | Test whether 'FlagAssignment' is empty. --- --- @since 2.2.0 -nullFlagAssignment :: FlagAssignment -> Bool -nullFlagAssignment = Map.null . getFlagAssignment - --- | Lookup the value for a flag --- --- Returns 'Nothing' if the flag isn't contained in the 'FlagAssignment'. --- --- @since 2.2.0 -lookupFlagAssignment :: FlagName -> FlagAssignment -> Maybe Bool -lookupFlagAssignment fn = fmap snd . Map.lookup fn . getFlagAssignment - --- | Insert or update the boolean value of a flag. --- --- If the flag is already present in the 'FlagAssigment', the --- value will be updated and the fact that multiple values have --- been provided for that flag will be recorded so that a --- warning can be generated later on. --- --- @since 2.2.0 -insertFlagAssignment :: FlagName -> Bool -> FlagAssignment -> FlagAssignment --- TODO: this currently just shadows prior values for an existing --- flag; rather than enforcing uniqueness at construction, it's --- verified later on via `D.C.Dependency.configuredPackageProblems` -insertFlagAssignment flag val = - FlagAssignment . - Map.insertWith (flip combineFlagValues) flag (1, val) . getFlagAssignment - --- | Remove all flag-assignments from the first 'FlagAssignment' that --- are contained in the second 'FlagAssignment' --- --- NB/TODO: This currently only removes flag assignments which also --- match the value assignment! We should review the code which uses --- this operation to figure out if this it's not enough to only --- compare the flagnames without the values. --- --- @since 2.2.0 -diffFlagAssignment :: FlagAssignment -> FlagAssignment -> FlagAssignment -diffFlagAssignment fa1 fa2 = FlagAssignment - (Map.difference (getFlagAssignment fa1) (getFlagAssignment fa2)) - --- | Find the 'FlagName's that have been listed more than once. --- --- @since 2.2.0 -findDuplicateFlagAssignments :: FlagAssignment -> [FlagName] -findDuplicateFlagAssignments = - Map.keys . Map.filter ((> 1) . fst) . getFlagAssignment - --- | @since 2.2.0 -instance Read FlagAssignment where - readsPrec p s = [ (FlagAssignment x, rest) | (x,rest) <- readsPrec p s ] - --- | @since 2.2.0 -instance Show FlagAssignment where - showsPrec p (FlagAssignment xs) = showsPrec p xs - --- | String representation of a flag-value pair. -showFlagValue :: (FlagName, Bool) -> String -showFlagValue (f, True) = '+' : unFlagName f -showFlagValue (f, False) = '-' : unFlagName f - --- | @since 3.4.0.0 -instance Pretty FlagAssignment where - pretty = dispFlagAssignment - --- | --- --- >>> simpleParsec "" :: Maybe FlagAssignment --- Just (fromList []) --- --- >>> simpleParsec "+foo -bar" :: Maybe FlagAssignment --- Just (fromList [(FlagName "bar",(1,False)),(FlagName "foo",(1,True))]) --- --- >>> simpleParsec "-none -any" :: Maybe FlagAssignment --- Just (fromList [(FlagName "any",(1,False)),(FlagName "none",(1,False))]) --- --- >>> simpleParsec "+foo -foo +foo +foo" :: Maybe FlagAssignment --- Just (fromList [(FlagName "foo",(4,True))]) --- --- >>> simpleParsec "+foo -bar baz" :: Maybe FlagAssignment --- Nothing --- --- @since 3.4.0.0 --- -instance Parsec FlagAssignment where - parsec = parsecFlagAssignment - --- | Pretty-prints a flag assignment. -dispFlagAssignment :: FlagAssignment -> Disp.Doc -dispFlagAssignment = Disp.hsep . map (Disp.text . showFlagValue) . unFlagAssignment - --- | Parses a flag assignment. -parsecFlagAssignment :: CabalParsing m => m FlagAssignment -parsecFlagAssignment = mkFlagAssignment <$> - P.sepBy (onFlag <|> offFlag) P.skipSpaces1 - where - onFlag = do - _ <- P.char '+' - f <- parsec - return (f, True) - offFlag = do - _ <- P.char '-' - f <- parsec - return (f, False) - --- | Parse a non-empty flag assignment --- --- The flags have to explicitly start with minus or plus. --- --- @since 3.4.0.0 -parsecFlagAssignmentNonEmpty :: CabalParsing m => m FlagAssignment -parsecFlagAssignmentNonEmpty = mkFlagAssignment . toList <$> - P.sepByNonEmpty (onFlag <|> offFlag) P.skipSpaces1 - where - onFlag = do - _ <- P.char '+' - f <- parsec - return (f, True) - offFlag = do - _ <- P.char '-' - f <- parsec - return (f, False) - --- | Show flag assignment. --- --- @since 3.4.0.0 -showFlagAssignment :: FlagAssignment -> String -showFlagAssignment = prettyShow . dispFlagAssignment - -------------------------------------------------------------------------------- --- Legacy: without requiring + -------------------------------------------------------------------------------- - --- | We need this as far as we support custom setups older than 2.2.0.0 --- --- @since 3.4.0.0 -legacyShowFlagAssignment :: FlagAssignment -> String -legacyShowFlagAssignment = - prettyShow . Disp.hsep . map Disp.text . legacyShowFlagAssignment' - --- | @since 3.4.0.0 -legacyShowFlagAssignment' :: FlagAssignment -> [String] -legacyShowFlagAssignment' = map legacyShowFlagValue . unFlagAssignment - --- | @since 3.4.0.0 -legacyShowFlagValue :: (FlagName, Bool) -> String -legacyShowFlagValue (f, True) = unFlagName f -legacyShowFlagValue (f, False) = '-' : unFlagName f - --- | --- We need this as far as we support custom setups older than 2.2.0.0 --- --- @since 3.4.0.0 -legacyParsecFlagAssignment :: CabalParsing m => m FlagAssignment -legacyParsecFlagAssignment = mkFlagAssignment <$> - P.sepBy (onFlag <|> offFlag) P.skipSpaces1 - where - onFlag = do - _ <- P.optional (P.char '+') - f <- parsec - return (f, True) - offFlag = do - _ <- P.char '-' - f <- parsec - return (f, False) diff --git a/cabal/Cabal/Distribution/Types/ForeignLib.hs b/cabal/Cabal/Distribution/Types/ForeignLib.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/ForeignLib.hs +++ /dev/null @@ -1,200 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE NoMonoLocalBinds #-} - -module Distribution.Types.ForeignLib( - ForeignLib(..), - emptyForeignLib, - foreignLibModules, - foreignLibIsShared, - foreignLibVersion, - - LibVersionInfo, - mkLibVersionInfo, - libVersionInfoCRA, - libVersionNumber, - libVersionNumberShow, - libVersionMajor -) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.ModuleName -import Distribution.Parsec -import Distribution.Pretty -import Distribution.System -import Distribution.Types.BuildInfo -import Distribution.Types.ForeignLibOption -import Distribution.Types.ForeignLibType -import Distribution.Types.UnqualComponentName -import Distribution.Version - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp -import qualified Text.Read as Read - -import qualified Distribution.Types.BuildInfo.Lens as L - --- | A foreign library stanza is like a library stanza, except that --- the built code is intended for consumption by a non-Haskell client. -data ForeignLib = ForeignLib { - -- | Name of the foreign library - foreignLibName :: UnqualComponentName - -- | What kind of foreign library is this (static or dynamic). - , foreignLibType :: ForeignLibType - -- | What options apply to this foreign library (e.g., are we - -- merging in all foreign dependencies.) - , foreignLibOptions :: [ForeignLibOption] - -- | Build information for this foreign library. - , foreignLibBuildInfo :: BuildInfo - -- | Libtool-style version-info data to compute library version. - -- Refer to the libtool documentation on the - -- current:revision:age versioning scheme. - , foreignLibVersionInfo :: Maybe LibVersionInfo - -- | Linux library version - , foreignLibVersionLinux :: Maybe Version - - -- | (Windows-specific) module definition files - -- - -- This is a list rather than a maybe field so that we can flatten - -- the condition trees (for instance, when creating an sdist) - , foreignLibModDefFile :: [FilePath] - } - deriving (Generic, Show, Read, Eq, Typeable, Data) - -data LibVersionInfo = LibVersionInfo Int Int Int deriving (Data, Eq, Generic, Typeable) - -instance Ord LibVersionInfo where - LibVersionInfo c r _ `compare` LibVersionInfo c' r' _ = - case c `compare` c' of - EQ -> r `compare` r' - e -> e - -instance Show LibVersionInfo where - showsPrec d (LibVersionInfo c r a) = showParen (d > 10) - $ showString "mkLibVersionInfo " - . showsPrec 11 (c,r,a) - -instance Read LibVersionInfo where - readPrec = Read.parens $ do - Read.Ident "mkLibVersionInfo" <- Read.lexP - t <- Read.step Read.readPrec - return (mkLibVersionInfo t) - -instance Binary LibVersionInfo -instance Structured LibVersionInfo -instance NFData LibVersionInfo where rnf = genericRnf - -instance Pretty LibVersionInfo where - pretty (LibVersionInfo c r a) - = Disp.hcat $ Disp.punctuate (Disp.char ':') $ map Disp.int [c,r,a] - -instance Parsec LibVersionInfo where - parsec = do - c <- P.integral - (r, a) <- P.option (0,0) $ do - _ <- P.char ':' - r <- P.integral - a <- P.option 0 $ do - _ <- P.char ':' - P.integral - return (r,a) - return $ mkLibVersionInfo (c,r,a) - --- | Construct 'LibVersionInfo' from @(current, revision, age)@ --- numbers. --- --- For instance, @mkLibVersionInfo (3,0,0)@ constructs a --- 'LibVersionInfo' representing the version-info @3:0:0@. --- --- All version components must be non-negative. -mkLibVersionInfo :: (Int, Int, Int) -> LibVersionInfo -mkLibVersionInfo (c,r,a) = LibVersionInfo c r a - --- | From a given 'LibVersionInfo', extract the @(current, revision, --- age)@ numbers. -libVersionInfoCRA :: LibVersionInfo -> (Int, Int, Int) -libVersionInfoCRA (LibVersionInfo c r a) = (c,r,a) - --- | Given a version-info field, produce a @major.minor.build@ version -libVersionNumber :: LibVersionInfo -> (Int, Int, Int) -libVersionNumber (LibVersionInfo c r a) = (c-a , a , r) - --- | Given a version-info field, return @"major.minor.build"@ as a --- 'String' -libVersionNumberShow :: LibVersionInfo -> String -libVersionNumberShow v = - let (major, minor, build) = libVersionNumber v - in show major ++ "." ++ show minor ++ "." ++ show build - --- | Return the @major@ version of a version-info field. -libVersionMajor :: LibVersionInfo -> Int -libVersionMajor (LibVersionInfo c _ a) = c-a - -instance L.HasBuildInfo ForeignLib where - buildInfo f l = (\x -> l { foreignLibBuildInfo = x }) <$> f (foreignLibBuildInfo l) - -instance Binary ForeignLib -instance Structured ForeignLib -instance NFData ForeignLib where rnf = genericRnf - -instance Semigroup ForeignLib where - a <> b = ForeignLib { - foreignLibName = combine' foreignLibName - , foreignLibType = combine foreignLibType - , foreignLibOptions = combine foreignLibOptions - , foreignLibBuildInfo = combine foreignLibBuildInfo - , foreignLibVersionInfo = combine'' foreignLibVersionInfo - , foreignLibVersionLinux = combine'' foreignLibVersionLinux - , foreignLibModDefFile = combine foreignLibModDefFile - } - where combine field = field a `mappend` field b - combine' field = case ( unUnqualComponentName $ field a - , unUnqualComponentName $ field b) of - ("", _) -> field b - (_, "") -> field a - (x, y) -> error $ "Ambiguous values for executable field: '" - ++ x ++ "' and '" ++ y ++ "'" - combine'' field = field b - -instance Monoid ForeignLib where - mempty = ForeignLib { - foreignLibName = mempty - , foreignLibType = ForeignLibTypeUnknown - , foreignLibOptions = [] - , foreignLibBuildInfo = mempty - , foreignLibVersionInfo = Nothing - , foreignLibVersionLinux = Nothing - , foreignLibModDefFile = [] - } - mappend = (<>) - --- | An empty foreign library. -emptyForeignLib :: ForeignLib -emptyForeignLib = mempty - --- | Modules defined by a foreign library. -foreignLibModules :: ForeignLib -> [ModuleName] -foreignLibModules = otherModules . foreignLibBuildInfo - --- | Is the foreign library shared? -foreignLibIsShared :: ForeignLib -> Bool -foreignLibIsShared = foreignLibTypeIsShared . foreignLibType - --- | Get a version number for a foreign library. --- If we're on Linux, and a Linux version is specified, use that. --- If we're on Linux, and libtool-style version-info is specified, translate --- that field into appropriate version numbers. --- Otherwise, this feature is unsupported so we don't return any version data. -foreignLibVersion :: ForeignLib -> OS -> [Int] -foreignLibVersion flib Linux = - case foreignLibVersionLinux flib of - Just v -> versionNumbers v - Nothing -> - case foreignLibVersionInfo flib of - Just v' -> - let (major, minor, build) = libVersionNumber v' - in [major, minor, build] - Nothing -> [] -foreignLibVersion _ _ = [] diff --git a/cabal/Cabal/Distribution/Types/ForeignLib/Lens.hs b/cabal/Cabal/Distribution/Types/ForeignLib/Lens.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/ForeignLib/Lens.hs +++ /dev/null @@ -1,45 +0,0 @@ -module Distribution.Types.ForeignLib.Lens ( - ForeignLib, - module Distribution.Types.ForeignLib.Lens, - ) where - -import Distribution.Compat.Lens -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Types.BuildInfo (BuildInfo) -import Distribution.Types.ForeignLib (ForeignLib, LibVersionInfo) -import Distribution.Types.ForeignLibOption (ForeignLibOption) -import Distribution.Types.ForeignLibType (ForeignLibType) -import Distribution.Types.UnqualComponentName (UnqualComponentName) -import Distribution.Version (Version) - -import qualified Distribution.Types.ForeignLib as T - -foreignLibName :: Lens' ForeignLib UnqualComponentName -foreignLibName f s = fmap (\x -> s { T.foreignLibName = x }) (f (T.foreignLibName s)) -{-# INLINE foreignLibName #-} - -foreignLibType :: Lens' ForeignLib ForeignLibType -foreignLibType f s = fmap (\x -> s { T.foreignLibType = x }) (f (T.foreignLibType s)) -{-# INLINE foreignLibType #-} - -foreignLibOptions :: Lens' ForeignLib [ForeignLibOption] -foreignLibOptions f s = fmap (\x -> s { T.foreignLibOptions = x }) (f (T.foreignLibOptions s)) -{-# INLINE foreignLibOptions #-} - -foreignLibBuildInfo :: Lens' ForeignLib BuildInfo -foreignLibBuildInfo f s = fmap (\x -> s { T.foreignLibBuildInfo = x }) (f (T.foreignLibBuildInfo s)) -{-# INLINE foreignLibBuildInfo #-} - -foreignLibVersionInfo :: Lens' ForeignLib (Maybe LibVersionInfo) -foreignLibVersionInfo f s = fmap (\x -> s { T.foreignLibVersionInfo = x }) (f (T.foreignLibVersionInfo s)) -{-# INLINE foreignLibVersionInfo #-} - -foreignLibVersionLinux :: Lens' ForeignLib (Maybe Version) -foreignLibVersionLinux f s = fmap (\x -> s { T.foreignLibVersionLinux = x }) (f (T.foreignLibVersionLinux s)) -{-# INLINE foreignLibVersionLinux #-} - -foreignLibModDefFile :: Lens' ForeignLib [FilePath] -foreignLibModDefFile f s = fmap (\x -> s { T.foreignLibModDefFile = x }) (f (T.foreignLibModDefFile s)) -{-# INLINE foreignLibModDefFile #-} diff --git a/cabal/Cabal/Distribution/Types/ForeignLibOption.hs b/cabal/Cabal/Distribution/Types/ForeignLibOption.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/ForeignLibOption.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} - -module Distribution.Types.ForeignLibOption( - ForeignLibOption(..) -) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Pretty -import Distribution.Parsec - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - -data ForeignLibOption = - -- | Merge in all dependent libraries (i.e., use - -- @ghc -shared -static@ rather than just record - -- the dependencies, ala @ghc -shared -dynamic@). - -- This option is compulsory on Windows and unsupported - -- on other platforms. - ForeignLibStandalone - deriving (Generic, Show, Read, Eq, Typeable, Data) - -instance Pretty ForeignLibOption where - pretty ForeignLibStandalone = Disp.text "standalone" - -instance Parsec ForeignLibOption where - parsec = do - name <- P.munch1 (\c -> isAlphaNum c || c == '-') - case name of - "standalone" -> return ForeignLibStandalone - _ -> fail "unrecognized foreign-library option" - -instance Binary ForeignLibOption -instance Structured ForeignLibOption -instance NFData ForeignLibOption where rnf = genericRnf diff --git a/cabal/Cabal/Distribution/Types/ForeignLibType.hs b/cabal/Cabal/Distribution/Types/ForeignLibType.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/ForeignLibType.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} - -module Distribution.Types.ForeignLibType( - ForeignLibType(..), - knownForeignLibTypes, - foreignLibTypeIsShared, -) where - -import Prelude () -import Distribution.Compat.Prelude -import Distribution.PackageDescription.Utils - -import Distribution.Pretty -import Distribution.Parsec - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - --- | What kind of foreign library is to be built? -data ForeignLibType = - -- | A native shared library (@.so@ on Linux, @.dylib@ on OSX, or - -- @.dll@ on Windows). - ForeignLibNativeShared - -- | A native static library (not currently supported.) - | ForeignLibNativeStatic - -- TODO: Maybe this should record a string? - | ForeignLibTypeUnknown - deriving (Generic, Show, Read, Eq, Typeable, Data) - -instance Pretty ForeignLibType where - pretty ForeignLibNativeShared = Disp.text "native-shared" - pretty ForeignLibNativeStatic = Disp.text "native-static" - pretty ForeignLibTypeUnknown = Disp.text "unknown" - -instance Parsec ForeignLibType where - parsec = do - name <- P.munch1 (\c -> isAlphaNum c || c == '-') - return $ case name of - "native-shared" -> ForeignLibNativeShared - "native-static" -> ForeignLibNativeStatic - _ -> ForeignLibTypeUnknown - -instance Binary ForeignLibType -instance Structured ForeignLibType -instance NFData ForeignLibType where rnf = genericRnf - -instance Semigroup ForeignLibType where - ForeignLibTypeUnknown <> b = b - a <> ForeignLibTypeUnknown = a - _ <> _ = error "Ambiguous foreign library type" - -instance Monoid ForeignLibType where - mempty = ForeignLibTypeUnknown - mappend = (<>) - -knownForeignLibTypes :: [ForeignLibType] -knownForeignLibTypes = [ - ForeignLibNativeShared - , ForeignLibNativeStatic - ] - -foreignLibTypeIsShared :: ForeignLibType -> Bool -foreignLibTypeIsShared t = - case t of - ForeignLibNativeShared -> True - ForeignLibNativeStatic -> False - ForeignLibTypeUnknown -> cabalBug "Unknown foreign library type" diff --git a/cabal/Cabal/Distribution/Types/GenericPackageDescription.hs b/cabal/Cabal/Distribution/Types/GenericPackageDescription.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/GenericPackageDescription.hs +++ /dev/null @@ -1,105 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Distribution.Types.GenericPackageDescription ( - GenericPackageDescription(..), - emptyGenericPackageDescription, -) where - -import Prelude () -import Distribution.Compat.Prelude - --- lens -import Distribution.Compat.Lens as L -import qualified Distribution.Types.BuildInfo.Lens as L - -import Distribution.Types.PackageDescription - -import Distribution.Types.Benchmark -import Distribution.Types.CondTree -import Distribution.Types.ConfVar -import Distribution.Types.Dependency -import Distribution.Types.Executable -import Distribution.Types.Flag -import Distribution.Types.ForeignLib -import Distribution.Types.Library -import Distribution.Types.TestSuite -import Distribution.Types.UnqualComponentName -import Distribution.Package -import Distribution.Version - --- --------------------------------------------------------------------------- --- The 'GenericPackageDescription' type - -data GenericPackageDescription = - GenericPackageDescription - { packageDescription :: PackageDescription - , gpdScannedVersion :: Maybe Version - -- ^ This is a version as specified in source. - -- We populate this field in index reading for dummy GPDs, - -- only when GPD reading failed, but scanning haven't. - -- - -- Cabal-the-library never produces GPDs with Just as gpdScannedVersion. - -- - -- Perfectly, PackageIndex should have sum type, so we don't need to - -- have dummy GPDs. - , genPackageFlags :: [PackageFlag] - , condLibrary :: Maybe (CondTree ConfVar [Dependency] Library) - , condSubLibraries :: [( UnqualComponentName - , CondTree ConfVar [Dependency] Library )] - , condForeignLibs :: [( UnqualComponentName - , CondTree ConfVar [Dependency] ForeignLib )] - , condExecutables :: [( UnqualComponentName - , CondTree ConfVar [Dependency] Executable )] - , condTestSuites :: [( UnqualComponentName - , CondTree ConfVar [Dependency] TestSuite )] - , condBenchmarks :: [( UnqualComponentName - , CondTree ConfVar [Dependency] Benchmark )] - } - deriving (Show, Eq, Typeable, Data, Generic) - -instance Package GenericPackageDescription where - packageId = packageId . packageDescription - -instance Binary GenericPackageDescription -instance Structured GenericPackageDescription -instance NFData GenericPackageDescription where rnf = genericRnf - -emptyGenericPackageDescription :: GenericPackageDescription -emptyGenericPackageDescription = GenericPackageDescription emptyPackageDescription Nothing [] Nothing [] [] [] [] [] - --- ----------------------------------------------------------------------------- --- Traversal Instances - -instance L.HasBuildInfos GenericPackageDescription where - traverseBuildInfos f (GenericPackageDescription p v a1 x1 x2 x3 x4 x5 x6) = - GenericPackageDescription - <$> L.traverseBuildInfos f p - <*> pure v - <*> pure a1 - <*> (traverse . traverseCondTreeBuildInfo) f x1 - <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x2 - <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x3 - <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x4 - <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x5 - <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x6 - where - --- We use this traversal to keep [Dependency] field in CondTree up to date. -traverseCondTreeBuildInfo - :: forall f comp v. (Applicative f, L.HasBuildInfo comp) - => LensLike' f (CondTree v [Dependency] comp) L.BuildInfo -traverseCondTreeBuildInfo g = node where - mkCondNode :: comp -> [CondBranch v [Dependency] comp] -> CondTree v [Dependency] comp - mkCondNode comp branches = CondNode comp (view L.targetBuildDepends comp) branches - - node (CondNode comp _ branches) = mkCondNode - <$> L.buildInfo g comp - <*> traverse branch branches - - branch (CondBranch v x y) = CondBranch v - <$> node x - <*> traverse node y diff --git a/cabal/Cabal/Distribution/Types/GenericPackageDescription/Lens.hs b/cabal/Cabal/Distribution/Types/GenericPackageDescription/Lens.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/GenericPackageDescription/Lens.hs +++ /dev/null @@ -1,131 +0,0 @@ -{-# LANGUAGE Rank2Types #-} -module Distribution.Types.GenericPackageDescription.Lens ( - GenericPackageDescription, - PackageFlag, - FlagName, - ConfVar (..), - module Distribution.Types.GenericPackageDescription.Lens, - ) where - -import Prelude() -import Distribution.Compat.Prelude -import Distribution.Compat.Lens - -import qualified Distribution.Types.GenericPackageDescription as T - --- We import types from their packages, so we can remove unused imports --- and have wider inter-module dependency graph -import Distribution.Types.CondTree (CondTree) -import Distribution.Types.Dependency (Dependency) -import Distribution.Types.Executable (Executable) -import Distribution.Types.PackageDescription (PackageDescription) -import Distribution.Types.Benchmark (Benchmark) -import Distribution.Types.ForeignLib (ForeignLib) -import Distribution.Types.GenericPackageDescription (GenericPackageDescription(GenericPackageDescription) ) -import Distribution.Types.Flag (PackageFlag(MkPackageFlag), FlagName) -import Distribution.Types.ConfVar (ConfVar (..)) -import Distribution.Types.Library (Library) -import Distribution.Types.TestSuite (TestSuite) -import Distribution.Types.UnqualComponentName (UnqualComponentName) -import Distribution.System (Arch, OS) -import Distribution.Compiler (CompilerFlavor) -import Distribution.Version (Version, VersionRange) - -------------------------------------------------------------------------------- --- GenericPackageDescription -------------------------------------------------------------------------------- - -packageDescription :: Lens' GenericPackageDescription PackageDescription -packageDescription f s = fmap (\x -> s { T.packageDescription = x }) (f (T.packageDescription s)) -{-# INLINE packageDescription #-} - -gpdScannedVersion :: Lens' GenericPackageDescription (Maybe Version) -gpdScannedVersion f s = fmap (\x -> s { T.gpdScannedVersion = x }) (f (T.gpdScannedVersion s)) -{-# INLINE gpdScannedVersion #-} - -genPackageFlags :: Lens' GenericPackageDescription [PackageFlag] -genPackageFlags f s = fmap (\x -> s { T.genPackageFlags = x }) (f (T.genPackageFlags s)) -{-# INLINE genPackageFlags #-} - -condLibrary :: Lens' GenericPackageDescription (Maybe (CondTree ConfVar [Dependency] Library)) -condLibrary f s = fmap (\x -> s { T.condLibrary = x }) (f (T.condLibrary s)) -{-# INLINE condLibrary #-} - -condSubLibraries :: Lens' GenericPackageDescription [(UnqualComponentName,(CondTree ConfVar [Dependency] Library))] -condSubLibraries f s = fmap (\x -> s { T.condSubLibraries = x }) (f (T.condSubLibraries s)) -{-# INLINE condSubLibraries #-} - -condForeignLibs :: Lens' GenericPackageDescription [(UnqualComponentName,(CondTree ConfVar [Dependency] ForeignLib))] -condForeignLibs f s = fmap (\x -> s { T.condForeignLibs = x }) (f (T.condForeignLibs s)) -{-# INLINE condForeignLibs #-} - -condExecutables :: Lens' GenericPackageDescription [(UnqualComponentName,(CondTree ConfVar [Dependency] Executable))] -condExecutables f s = fmap (\x -> s { T.condExecutables = x }) (f (T.condExecutables s)) -{-# INLINE condExecutables #-} - -condTestSuites :: Lens' GenericPackageDescription [(UnqualComponentName,(CondTree ConfVar [Dependency] TestSuite))] -condTestSuites f s = fmap (\x -> s { T.condTestSuites = x }) (f (T.condTestSuites s)) -{-# INLINE condTestSuites #-} - -condBenchmarks :: Lens' GenericPackageDescription [(UnqualComponentName,(CondTree ConfVar [Dependency] Benchmark))] -condBenchmarks f s = fmap (\x -> s { T.condBenchmarks = x }) (f (T.condBenchmarks s)) -{-# INLINE condBenchmarks #-} - -allCondTrees - :: Applicative f - => (forall a. CondTree ConfVar [Dependency] a - -> f (CondTree ConfVar [Dependency] a)) - -> GenericPackageDescription - -> f GenericPackageDescription -allCondTrees f (GenericPackageDescription p v a1 x1 x2 x3 x4 x5 x6) = - GenericPackageDescription - <$> pure p - <*> pure v - <*> pure a1 - <*> traverse f x1 - <*> (traverse . _2) f x2 - <*> (traverse . _2) f x3 - <*> (traverse . _2) f x4 - <*> (traverse . _2) f x5 - <*> (traverse . _2) f x6 - - -------------------------------------------------------------------------------- --- Flag -------------------------------------------------------------------------------- - -flagName :: Lens' PackageFlag FlagName -flagName f (MkPackageFlag x1 x2 x3 x4) = fmap (\y1 -> MkPackageFlag y1 x2 x3 x4) (f x1) -{-# INLINE flagName #-} - -flagDescription :: Lens' PackageFlag String -flagDescription f (MkPackageFlag x1 x2 x3 x4) = fmap (\y1 -> MkPackageFlag x1 y1 x3 x4) (f x2) -{-# INLINE flagDescription #-} - -flagDefault :: Lens' PackageFlag Bool -flagDefault f (MkPackageFlag x1 x2 x3 x4) = fmap (\y1 -> MkPackageFlag x1 x2 y1 x4) (f x3) -{-# INLINE flagDefault #-} - -flagManual :: Lens' PackageFlag Bool -flagManual f (MkPackageFlag x1 x2 x3 x4) = fmap (\y1 -> MkPackageFlag x1 x2 x3 y1) (f x4) -{-# INLINE flagManual #-} - -------------------------------------------------------------------------------- --- ConfVar -------------------------------------------------------------------------------- - -_OS :: Traversal' ConfVar OS -_OS f (OS os) = OS <$> f os -_OS _ x = pure x - -_Arch :: Traversal' ConfVar Arch -_Arch f (Arch arch) = Arch <$> f arch -_Arch _ x = pure x - -_PackageFlag :: Traversal' ConfVar FlagName -_PackageFlag f (PackageFlag flag) = PackageFlag <$> f flag -_PackageFlag _ x = pure x - -_Impl :: Traversal' ConfVar (CompilerFlavor, VersionRange) -_Impl f (Impl cf vr) = uncurry Impl <$> f (cf, vr) -_Impl _ x = pure x diff --git a/cabal/Cabal/Distribution/Types/GivenComponent.hs b/cabal/Cabal/Distribution/Types/GivenComponent.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/GivenComponent.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.GivenComponent ( - GivenComponent(..) -) where - -import Distribution.Compat.Prelude - -import Distribution.Types.ComponentId -import Distribution.Types.LibraryName -import Distribution.Types.PackageName - --- | A 'GivenComponent' represents a library depended on and explicitly --- specified by the user/client with @--dependency@ --- --- It enables Cabal to know which 'ComponentId' to associate with a library --- --- @since 2.3.0.0 -data GivenComponent = - GivenComponent - { givenComponentPackage :: PackageName - , givenComponentName :: LibraryName -- --dependency is for libraries - -- only, not for any component - , givenComponentId :: ComponentId } - deriving (Generic, Read, Show, Eq, Typeable) - -instance Binary GivenComponent -instance Structured GivenComponent diff --git a/cabal/Cabal/Distribution/Types/HookedBuildInfo.hs b/cabal/Cabal/Distribution/Types/HookedBuildInfo.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/HookedBuildInfo.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - -module Distribution.Types.HookedBuildInfo ( - HookedBuildInfo, - emptyHookedBuildInfo, - ) where - --- import Distribution.Compat.Prelude -import Distribution.Types.BuildInfo -import Distribution.Types.UnqualComponentName - --- | 'HookedBuildInfo' is mechanism that hooks can use to --- override the 'BuildInfo's inside packages. One example --- use-case (which is used in core libraries today) is as --- a way of passing flags which are computed by a configure --- script into Cabal. In this case, the autoconf build type adds --- hooks to read in a textual 'HookedBuildInfo' format prior --- to doing any operations. --- --- Quite honestly, this mechanism is a massive hack since we shouldn't --- be editing the 'PackageDescription' data structure (it's easy --- to assume that this data structure shouldn't change and --- run into bugs, see for example 1c20a6328579af9e37677d507e2e9836ef70ab9d). --- But it's a bit convenient, because there isn't another data --- structure that allows adding extra 'BuildInfo' style things. --- --- In any case, a lot of care has to be taken to make sure the --- 'HookedBuildInfo' is applied to the 'PackageDescription'. In --- general this process occurs in "Distribution.Simple", which is --- responsible for orchestrating the hooks mechanism. The --- general strategy: --- --- 1. We run the pre-hook, which produces a 'HookedBuildInfo' --- (e.g., in the Autoconf case, it reads it out from a file). --- 2. We sanity-check the hooked build info with --- 'sanityCheckHookedBuildInfo'. --- 3. We update our 'PackageDescription' (either freshly read --- or cached from 'LocalBuildInfo') with 'updatePackageDescription'. --- --- In principle, we are also supposed to update the copy of --- the 'PackageDescription' stored in 'LocalBuildInfo' --- at 'localPkgDescr'. Unfortunately, in practice, there --- are lots of Custom setup scripts which fail to update --- 'localPkgDescr' so you really shouldn't rely on it. --- It's not DEPRECATED because there are legitimate uses --- for it, but... yeah. Sharp knife. See --- --- for more information on the issue. --- --- It is not well-specified whether or not a 'HookedBuildInfo' applied --- at configure time is persistent to the 'LocalBuildInfo'. The --- fact that 'HookedBuildInfo' is passed to 'confHook' MIGHT SUGGEST --- that the 'HookedBuildInfo' is applied at this time, but actually --- since 9317b67e6122ab14e53f81b573bd0ecb388eca5a it has been ONLY used --- to create a modified package description that we check for problems: --- it is never actually saved to the LBI. Since 'HookedBuildInfo' is --- applied monoidally to the existing build infos (and it is not an --- idempotent monoid), it could break things to save it, since we --- are obligated to apply any new 'HookedBuildInfo' and then we'd --- get the effect twice. But this does mean we have to re-apply --- it every time. Hey, it's more flexibility. -type HookedBuildInfo = (Maybe BuildInfo, [(UnqualComponentName, BuildInfo)]) - -emptyHookedBuildInfo :: HookedBuildInfo -emptyHookedBuildInfo = (Nothing, []) diff --git a/cabal/Cabal/Distribution/Types/IncludeRenaming.hs b/cabal/Cabal/Distribution/Types/IncludeRenaming.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/IncludeRenaming.hs +++ /dev/null @@ -1,68 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - -module Distribution.Types.IncludeRenaming ( - IncludeRenaming(..), - defaultIncludeRenaming, - isDefaultIncludeRenaming, -) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Types.ModuleRenaming - -import qualified Distribution.Compat.CharParsing as P -import Distribution.Parsec -import Distribution.Pretty -import Text.PrettyPrint (text) -import qualified Text.PrettyPrint as Disp - --- --------------------------------------------------------------------------- --- Module renaming - --- | A renaming on an include: (provides renaming, requires renaming) -data IncludeRenaming - = IncludeRenaming { - includeProvidesRn :: ModuleRenaming, - includeRequiresRn :: ModuleRenaming - } - deriving (Show, Read, Eq, Ord, Typeable, Data, Generic) - -instance Binary IncludeRenaming -instance Structured IncludeRenaming - -instance NFData IncludeRenaming where rnf = genericRnf - --- | The 'defaultIncludeRenaming' applied when you only @build-depends@ --- on a package. -defaultIncludeRenaming :: IncludeRenaming -defaultIncludeRenaming = IncludeRenaming defaultRenaming defaultRenaming - --- | Is an 'IncludeRenaming' the default one? -isDefaultIncludeRenaming :: IncludeRenaming -> Bool -isDefaultIncludeRenaming (IncludeRenaming p r) = isDefaultRenaming p && isDefaultRenaming r - -instance Pretty IncludeRenaming where - pretty (IncludeRenaming prov_rn req_rn) = - pretty prov_rn - <+> (if isDefaultRenaming req_rn - then Disp.empty - else text "requires" <+> pretty req_rn) - -instance Parsec IncludeRenaming where - parsec = do - prov_rn <- parsec - req_rn <- P.option defaultRenaming $ P.try $ do - P.spaces -- no need to be space - _ <- P.string "requires" - P.spaces - parsec - -- Requirements don't really care if they're mentioned - -- or not (since you can't thin a requirement.) But - -- we have a little hack in Configure to combine - -- the provisions and requirements together before passing - -- them to GHC, and so the most neutral choice for a requirement - -- is for the "with" field to be False, so we correctly - -- thin provisions. - return (IncludeRenaming prov_rn req_rn) diff --git a/cabal/Cabal/Distribution/Types/InstalledPackageInfo.hs b/cabal/Cabal/Distribution/Types/InstalledPackageInfo.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/InstalledPackageInfo.hs +++ /dev/null @@ -1,173 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE OverloadedStrings #-} -module Distribution.Types.InstalledPackageInfo ( - InstalledPackageInfo (..), - emptyInstalledPackageInfo, - mungedPackageId, - mungedPackageName, - AbiDependency (..), - ExposedModule (..), - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Backpack -import Distribution.Compat.Graph (IsNode (..)) -import Distribution.License -import Distribution.ModuleName -import Distribution.Package hiding (installedUnitId) -import Distribution.Types.AbiDependency -import Distribution.Types.ExposedModule -import Distribution.Types.LibraryName -import Distribution.Types.LibraryVisibility -import Distribution.Types.MungedPackageId -import Distribution.Types.MungedPackageName -import Distribution.Version (nullVersion) -import Distribution.Utils.ShortText (ShortText) - -import qualified Distribution.Package as Package -import qualified Distribution.SPDX as SPDX - --- ----------------------------------------------------------------------------- --- The InstalledPackageInfo type - --- For BC reasons, we continue to name this record an InstalledPackageInfo; --- but it would more accurately be called an InstalledUnitInfo with Backpack -data InstalledPackageInfo - = InstalledPackageInfo { - -- these parts (sourcePackageId, installedUnitId) are - -- exactly the same as PackageDescription - sourcePackageId :: PackageId, - sourceLibName :: LibraryName, - installedComponentId_ :: ComponentId, - libVisibility :: LibraryVisibility, - installedUnitId :: UnitId, - -- INVARIANT: if this package is definite, OpenModule's - -- OpenUnitId directly records UnitId. If it is - -- indefinite, OpenModule is always an OpenModuleVar - -- with the same ModuleName as the key. - instantiatedWith :: [(ModuleName, OpenModule)], - compatPackageKey :: String, - license :: Either SPDX.License License, - copyright :: !ShortText, - maintainer :: !ShortText, - author :: !ShortText, - stability :: !ShortText, - homepage :: !ShortText, - pkgUrl :: !ShortText, - synopsis :: !ShortText, - description :: !ShortText, - category :: !ShortText, - -- these parts are required by an installed package only: - abiHash :: AbiHash, - indefinite :: Bool, - exposed :: Bool, - -- INVARIANT: if the package is definite, OpenModule's - -- OpenUnitId directly records UnitId. - exposedModules :: [ExposedModule], - hiddenModules :: [ModuleName], - trusted :: Bool, - importDirs :: [FilePath], - libraryDirs :: [FilePath], - libraryDynDirs :: [FilePath], -- ^ overrides 'libraryDirs' - dataDir :: FilePath, - hsLibraries :: [String], - extraLibraries :: [String], - extraGHCiLibraries:: [String], -- overrides extraLibraries for GHCi - includeDirs :: [FilePath], - includes :: [String], - -- INVARIANT: if the package is definite, UnitId is NOT - -- a ComponentId of an indefinite package - depends :: [UnitId], - abiDepends :: [AbiDependency], - ccOptions :: [String], - cxxOptions :: [String], - ldOptions :: [String], - frameworkDirs :: [FilePath], - frameworks :: [String], - haddockInterfaces :: [FilePath], - haddockHTMLs :: [FilePath], - pkgRoot :: Maybe FilePath - } - deriving (Eq, Generic, Typeable, Read, Show) - -instance Binary InstalledPackageInfo -instance Structured InstalledPackageInfo - -instance NFData InstalledPackageInfo where rnf = genericRnf - -instance Package.HasMungedPackageId InstalledPackageInfo where - mungedId = mungedPackageId - -instance Package.Package InstalledPackageInfo where - packageId = sourcePackageId - -instance Package.HasUnitId InstalledPackageInfo where - installedUnitId = installedUnitId - -instance Package.PackageInstalled InstalledPackageInfo where - installedDepends = depends - -instance IsNode InstalledPackageInfo where - type Key InstalledPackageInfo = UnitId - nodeKey = installedUnitId - nodeNeighbors = depends - -mungedPackageId :: InstalledPackageInfo -> MungedPackageId -mungedPackageId ipi = - MungedPackageId (mungedPackageName ipi) (packageVersion ipi) - --- | Returns the munged package name, which we write into @name@ for --- compatibility with old versions of GHC. -mungedPackageName :: InstalledPackageInfo -> MungedPackageName -mungedPackageName ipi = MungedPackageName (packageName ipi) (sourceLibName ipi) - -emptyInstalledPackageInfo :: InstalledPackageInfo -emptyInstalledPackageInfo - = InstalledPackageInfo { - sourcePackageId = PackageIdentifier (mkPackageName "") nullVersion, - sourceLibName = LMainLibName, - installedComponentId_ = mkComponentId "", - installedUnitId = mkUnitId "", - instantiatedWith = [], - compatPackageKey = "", - license = Left SPDX.NONE, - copyright = "", - maintainer = "", - author = "", - stability = "", - homepage = "", - pkgUrl = "", - synopsis = "", - description = "", - category = "", - abiHash = mkAbiHash "", - indefinite = False, - exposed = False, - exposedModules = [], - hiddenModules = [], - trusted = False, - importDirs = [], - libraryDirs = [], - libraryDynDirs = [], - dataDir = "", - hsLibraries = [], - extraLibraries = [], - extraGHCiLibraries= [], - includeDirs = [], - includes = [], - depends = [], - abiDepends = [], - ccOptions = [], - cxxOptions = [], - ldOptions = [], - frameworkDirs = [], - frameworks = [], - haddockInterfaces = [], - haddockHTMLs = [], - pkgRoot = Nothing, - libVisibility = LibraryVisibilityPrivate - } diff --git a/cabal/Cabal/Distribution/Types/InstalledPackageInfo/FieldGrammar.hs b/cabal/Cabal/Distribution/Types/InstalledPackageInfo/FieldGrammar.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/InstalledPackageInfo/FieldGrammar.hs +++ /dev/null @@ -1,317 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -module Distribution.Types.InstalledPackageInfo.FieldGrammar ( - ipiFieldGrammar, - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Backpack -import Distribution.CabalSpecVersion -import Distribution.Compat.Lens (Lens', (&), (.~)) -import Distribution.Compat.Newtype -import Distribution.FieldGrammar -import Distribution.FieldGrammar.FieldDescrs -import Distribution.License -import Distribution.ModuleName -import Distribution.Package -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Types.LibraryName -import Distribution.Types.LibraryVisibility -import Distribution.Types.MungedPackageName -import Distribution.Types.UnqualComponentName -import Distribution.Version - -import qualified Data.Char as Char -import qualified Data.Map as Map -import qualified Distribution.Compat.CharParsing as P -import qualified Distribution.SPDX as SPDX -import qualified Text.PrettyPrint as Disp - -import Distribution.Types.InstalledPackageInfo - -import qualified Distribution.Types.InstalledPackageInfo.Lens as L -import qualified Distribution.Types.PackageId.Lens as L - --- Note: GHC goes nuts and inlines everything, --- One can see e.g. in -ddump-simpl-stats: --- --- 34886 KnownBranch --- 8197 wild1_ixF0 --- --- https://gitlab.haskell.org/ghc/ghc/-/issues/13253 might be the cause. --- --- The workaround is to prevent GHC optimising the code: -infixl 4 <@> -(<@>) :: Applicative f => f (a -> b) -> f a -> f b -f <@> x = f <*> x -{-# NOINLINE (<@>) #-} - -ipiFieldGrammar - :: ( FieldGrammar c g, Applicative (g InstalledPackageInfo), Applicative (g Basic) - , c (Identity AbiHash) - , c (Identity LibraryVisibility) - , c (Identity PackageName) - , c (Identity UnitId) - , c (Identity UnqualComponentName) - , c (List FSep (Identity AbiDependency) AbiDependency) - , c (List FSep (Identity UnitId) UnitId) - , c (List FSep (MQuoted ModuleName) ModuleName) - , c (List FSep FilePathNT String) - , c (List FSep Token String) - , c (MQuoted MungedPackageName) - , c (MQuoted Version) - , c CompatPackageKey - , c ExposedModules - , c InstWith - , c SpecLicenseLenient - ) - => g InstalledPackageInfo InstalledPackageInfo -ipiFieldGrammar = mkInstalledPackageInfo - -- Deprecated fields - <$> monoidalFieldAla "hugs-options" (alaList' FSep Token) unitedList - --- https://github.com/haskell/cabal/commit/40f3601e17024f07e0da8e64d3dd390177ce908b - ^^^ deprecatedSince CabalSpecV1_22 "hugs isn't supported anymore" - -- Very basic fields: name, version, package-name, lib-name and visibility - <@> blurFieldGrammar basic basicFieldGrammar - -- Basic fields - <@> optionalFieldDef "id" L.installedUnitId (mkUnitId "") - <@> optionalFieldDefAla "instantiated-with" InstWith L.instantiatedWith [] - <@> optionalFieldDefAla "key" CompatPackageKey L.compatPackageKey "" - <@> optionalFieldDefAla "license" SpecLicenseLenient L.license (Left SPDX.NONE) - <@> freeTextFieldDefST "copyright" L.copyright - <@> freeTextFieldDefST "maintainer" L.maintainer - <@> freeTextFieldDefST "author" L.author - <@> freeTextFieldDefST "stability" L.stability - <@> freeTextFieldDefST "homepage" L.homepage - <@> freeTextFieldDefST "package-url" L.pkgUrl - <@> freeTextFieldDefST "synopsis" L.synopsis - <@> freeTextFieldDefST "description" L.description - <@> freeTextFieldDefST "category" L.category - -- Installed fields - <@> optionalFieldDef "abi" L.abiHash (mkAbiHash "") - <@> booleanFieldDef "indefinite" L.indefinite False - <@> booleanFieldDef "exposed" L.exposed False - <@> monoidalFieldAla "exposed-modules" ExposedModules L.exposedModules - <@> monoidalFieldAla "hidden-modules" (alaList' FSep MQuoted) L.hiddenModules - <@> booleanFieldDef "trusted" L.trusted False - <@> monoidalFieldAla "import-dirs" (alaList' FSep FilePathNT) L.importDirs - <@> monoidalFieldAla "library-dirs" (alaList' FSep FilePathNT) L.libraryDirs - <@> monoidalFieldAla "dynamic-library-dirs" (alaList' FSep FilePathNT) L.libraryDynDirs - <@> optionalFieldDefAla "data-dir" FilePathNT L.dataDir "" - <@> monoidalFieldAla "hs-libraries" (alaList' FSep Token) L.hsLibraries - <@> monoidalFieldAla "extra-libraries" (alaList' FSep Token) L.extraLibraries - <@> monoidalFieldAla "extra-ghci-libraries" (alaList' FSep Token) L.extraGHCiLibraries - <@> monoidalFieldAla "include-dirs" (alaList' FSep FilePathNT) L.includeDirs - <@> monoidalFieldAla "includes" (alaList' FSep FilePathNT) L.includes - <@> monoidalFieldAla "depends" (alaList FSep) L.depends - <@> monoidalFieldAla "abi-depends" (alaList FSep) L.abiDepends - <@> monoidalFieldAla "cc-options" (alaList' FSep Token) L.ccOptions - <@> monoidalFieldAla "cxx-options" (alaList' FSep Token) L.cxxOptions - <@> monoidalFieldAla "ld-options" (alaList' FSep Token) L.ldOptions - <@> monoidalFieldAla "framework-dirs" (alaList' FSep FilePathNT) L.frameworkDirs - <@> monoidalFieldAla "frameworks" (alaList' FSep Token) L.frameworks - <@> monoidalFieldAla "haddock-interfaces" (alaList' FSep FilePathNT) L.haddockInterfaces - <@> monoidalFieldAla "haddock-html" (alaList' FSep FilePathNT) L.haddockHTMLs - <@> optionalFieldAla "pkgroot" FilePathNT L.pkgRoot - where - mkInstalledPackageInfo _ Basic {..} = InstalledPackageInfo - -- _basicPkgName is not used - -- setMaybePackageId says it can be no-op. - (PackageIdentifier pn _basicVersion) - (combineLibraryName ln _basicLibName) - (mkComponentId "") -- installedComponentId_, not in use - _basicLibVisibility - where - MungedPackageName pn ln = _basicName -{-# SPECIALIZE ipiFieldGrammar :: FieldDescrs InstalledPackageInfo InstalledPackageInfo #-} -{-# SPECIALIZE ipiFieldGrammar :: ParsecFieldGrammar InstalledPackageInfo InstalledPackageInfo #-} -{-# SPECIALIZE ipiFieldGrammar :: PrettyFieldGrammar InstalledPackageInfo InstalledPackageInfo #-} - --- (forall b. [b]) ~ () -unitedList :: Lens' a [b] -unitedList f s = s <$ f [] - -------------------------------------------------------------------------------- --- Helper functions -------------------------------------------------------------------------------- - --- | Combine 'LibraryName'. in parsing we prefer value coming --- from munged @name@ field over the @lib-name@. --- --- /Should/ be irrelevant. -combineLibraryName :: LibraryName -> LibraryName -> LibraryName -combineLibraryName l@(LSubLibName _) _ = l -combineLibraryName _ l = l - --- To maintain backwards-compatibility, we accept both comma/non-comma --- separated variants of this field. You SHOULD use the comma syntax if you --- use any new functions, although actually it's unambiguous due to a quirk --- of the fact that modules must start with capital letters. - -showExposedModules :: [ExposedModule] -> Disp.Doc -showExposedModules xs - | all isExposedModule xs = Disp.fsep (map pretty xs) - | otherwise = Disp.fsep (Disp.punctuate Disp.comma (map pretty xs)) - where isExposedModule (ExposedModule _ Nothing) = True - isExposedModule _ = False - --- | Setter for the @package-name@ field. It should be acceptable for this --- to be a no-op. -setMaybePackageName :: Maybe PackageName -> InstalledPackageInfo -> InstalledPackageInfo -setMaybePackageName Nothing ipi = ipi -setMaybePackageName (Just pn) ipi = ipi - { sourcePackageId = (sourcePackageId ipi) {pkgName=pn} - } - -setMungedPackageName :: MungedPackageName -> InstalledPackageInfo -> InstalledPackageInfo -setMungedPackageName (MungedPackageName pn ln) ipi = ipi - { sourcePackageId = (sourcePackageId ipi) {pkgName=pn} - , sourceLibName = ln - } - ---- | Returns @Just@ if the @name@ field of the IPI record would not contain ---- the package name verbatim. This helps us avoid writing @package-name@ ---- when it's redundant. -maybePackageName :: InstalledPackageInfo -> Maybe PackageName -maybePackageName ipi = case sourceLibName ipi of - LMainLibName -> Nothing - LSubLibName _ -> Just (packageName ipi) - -------------------------------------------------------------------------------- --- Auxiliary types -------------------------------------------------------------------------------- - -newtype ExposedModules = ExposedModules { getExposedModules :: [ExposedModule] } - -instance Newtype [ExposedModule] ExposedModules - -instance Parsec ExposedModules where - parsec = ExposedModules <$> parsecOptCommaList parsec - -instance Pretty ExposedModules where - pretty = showExposedModules . getExposedModules - -newtype CompatPackageKey = CompatPackageKey { getCompatPackageKey :: String } - -instance Newtype String CompatPackageKey - -instance Pretty CompatPackageKey where - pretty = Disp.text . getCompatPackageKey - -instance Parsec CompatPackageKey where - parsec = CompatPackageKey <$> P.munch1 uid_char where - uid_char c = Char.isAlphaNum c || c `elem` ("-_.=[],:<>+" :: String) - -newtype InstWith = InstWith { getInstWith :: [(ModuleName,OpenModule)] } - -instance Newtype [(ModuleName, OpenModule)] InstWith - -instance Pretty InstWith where - pretty = dispOpenModuleSubst . Map.fromList . getInstWith - -instance Parsec InstWith where - parsec = InstWith . Map.toList <$> parsecOpenModuleSubst - --- | SPDX License expression or legacy license. Lenient parser, accepts either. -newtype SpecLicenseLenient = SpecLicenseLenient { getSpecLicenseLenient :: Either SPDX.License License } - -instance Newtype (Either SPDX.License License) SpecLicenseLenient - -instance Parsec SpecLicenseLenient where - parsec = fmap SpecLicenseLenient $ Left <$> P.try parsec <|> Right <$> parsec - -instance Pretty SpecLicenseLenient where - pretty = either pretty pretty . getSpecLicenseLenient - -------------------------------------------------------------------------------- --- Basic fields -------------------------------------------------------------------------------- - --- | This type is used to mangle fields as --- in serialised textual representation --- to the actual 'InstalledPackageInfo' fields. -data Basic = Basic - { _basicName :: MungedPackageName - , _basicVersion :: Version - , _basicPkgName :: Maybe PackageName - , _basicLibName :: LibraryName - , _basicLibVisibility :: LibraryVisibility - } - -basic :: Lens' InstalledPackageInfo Basic -basic f ipi = g <$> f b - where - b = Basic - (mungedPackageName ipi) - (packageVersion ipi) - (maybePackageName ipi) - (sourceLibName ipi) - (libVisibility ipi) - - g (Basic n v pn ln lv) = ipi - & setMungedPackageName n - & L.sourcePackageId . L.pkgVersion .~ v - & setMaybePackageName pn - & L.sourceLibName .~ ln - & L.libVisibility .~ lv - -basicName :: Lens' Basic MungedPackageName -basicName f b = (\x -> b { _basicName = x }) <$> f (_basicName b) -{-# INLINE basicName #-} - -basicVersion :: Lens' Basic Version -basicVersion f b = (\x -> b { _basicVersion = x }) <$> f (_basicVersion b) -{-# INLINE basicVersion #-} - -basicPkgName :: Lens' Basic (Maybe PackageName) -basicPkgName f b = (\x -> b { _basicPkgName = x }) <$> f (_basicPkgName b) -{-# INLINE basicPkgName #-} - -basicLibName :: Lens' Basic (Maybe UnqualComponentName) -basicLibName f b = (\x -> b { _basicLibName = maybeToLibraryName x }) <$> - f (libraryNameString (_basicLibName b)) -{-# INLINE basicLibName #-} - -basicLibVisibility :: Lens' Basic LibraryVisibility -basicLibVisibility f b = (\x -> b { _basicLibVisibility = x }) <$> - f (_basicLibVisibility b) -{-# INLINE basicLibVisibility #-} - -basicFieldGrammar - :: ( FieldGrammar c g, Applicative (g Basic) - , c (Identity LibraryVisibility) - , c (Identity PackageName) - , c (Identity UnqualComponentName) - , c (MQuoted MungedPackageName) - , c (MQuoted Version) - ) - => g Basic Basic -basicFieldGrammar = mkBasic - <$> optionalFieldDefAla "name" MQuoted basicName (mungedPackageName emptyInstalledPackageInfo) - <*> optionalFieldDefAla "version" MQuoted basicVersion nullVersion - <*> optionalField "package-name" basicPkgName - <*> optionalField "lib-name" basicLibName - <*> optionalFieldDef "visibility" basicLibVisibility LibraryVisibilityPrivate - where - mkBasic n v pn ln lv = Basic n v pn ln' lv' - where - ln' = maybe LMainLibName LSubLibName ln - -- Older GHCs (<8.8) always report installed libraries as private - -- because their ghc-pkg builds with an older Cabal. - -- So we always set LibraryVisibilityPublic for main (unnamed) libs. - -- This can be removed once we stop supporting GHC<8.8, at the - -- condition that we keep marking main libraries as public when - -- registering them. - lv' = if - let MungedPackageName _ mln = n in - -- We need to check both because on ghc<8.2 ln' will always - -- be LMainLibName - ln' == LMainLibName && mln == LMainLibName - then LibraryVisibilityPublic - else lv diff --git a/cabal/Cabal/Distribution/Types/InstalledPackageInfo/Lens.hs b/cabal/Cabal/Distribution/Types/InstalledPackageInfo/Lens.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/InstalledPackageInfo/Lens.hs +++ /dev/null @@ -1,190 +0,0 @@ -module Distribution.Types.InstalledPackageInfo.Lens ( - InstalledPackageInfo, - module Distribution.Types.InstalledPackageInfo.Lens - ) where - -import Distribution.Compat.Lens -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Backpack (OpenModule) -import Distribution.License (License) -import Distribution.ModuleName (ModuleName) -import Distribution.Package (AbiHash, ComponentId, PackageIdentifier, UnitId) -import Distribution.Types.InstalledPackageInfo (AbiDependency, ExposedModule, InstalledPackageInfo) -import Distribution.Types.LibraryName (LibraryName) -import Distribution.Types.LibraryVisibility (LibraryVisibility) -import Distribution.Utils.ShortText (ShortText) - - -import qualified Distribution.SPDX as SPDX -import qualified Distribution.Types.InstalledPackageInfo as T - -sourcePackageId :: Lens' InstalledPackageInfo PackageIdentifier -sourcePackageId f s = fmap (\x -> s { T.sourcePackageId = x }) (f (T.sourcePackageId s)) -{-# INLINE sourcePackageId #-} - -installedUnitId :: Lens' InstalledPackageInfo UnitId -installedUnitId f s = fmap (\x -> s { T.installedUnitId = x }) (f (T.installedUnitId s)) -{-# INLINE installedUnitId #-} - -installedComponentId_ :: Lens' InstalledPackageInfo ComponentId -installedComponentId_ f s = fmap (\x -> s { T.installedComponentId_ = x }) (f (T.installedComponentId_ s)) -{-# INLINE installedComponentId_ #-} - -instantiatedWith :: Lens' InstalledPackageInfo [(ModuleName,OpenModule)] -instantiatedWith f s = fmap (\x -> s { T.instantiatedWith = x }) (f (T.instantiatedWith s)) -{-# INLINE instantiatedWith #-} - -sourceLibName :: Lens' InstalledPackageInfo LibraryName -sourceLibName f s = fmap (\x -> s { T.sourceLibName = x }) (f (T.sourceLibName s)) -{-# INLINE sourceLibName #-} - -compatPackageKey :: Lens' InstalledPackageInfo String -compatPackageKey f s = fmap (\x -> s { T.compatPackageKey = x }) (f (T.compatPackageKey s)) -{-# INLINE compatPackageKey #-} - -license :: Lens' InstalledPackageInfo (Either SPDX.License License) -license f s = fmap (\x -> s { T.license = x }) (f (T.license s)) -{-# INLINE license #-} - -copyright :: Lens' InstalledPackageInfo ShortText -copyright f s = fmap (\x -> s { T.copyright = x }) (f (T.copyright s)) -{-# INLINE copyright #-} - -maintainer :: Lens' InstalledPackageInfo ShortText -maintainer f s = fmap (\x -> s { T.maintainer = x }) (f (T.maintainer s)) -{-# INLINE maintainer #-} - -author :: Lens' InstalledPackageInfo ShortText -author f s = fmap (\x -> s { T.author = x }) (f (T.author s)) -{-# INLINE author #-} - -stability :: Lens' InstalledPackageInfo ShortText -stability f s = fmap (\x -> s { T.stability = x }) (f (T.stability s)) -{-# INLINE stability #-} - -homepage :: Lens' InstalledPackageInfo ShortText -homepage f s = fmap (\x -> s { T.homepage = x }) (f (T.homepage s)) -{-# INLINE homepage #-} - -pkgUrl :: Lens' InstalledPackageInfo ShortText -pkgUrl f s = fmap (\x -> s { T.pkgUrl = x }) (f (T.pkgUrl s)) -{-# INLINE pkgUrl #-} - -synopsis :: Lens' InstalledPackageInfo ShortText -synopsis f s = fmap (\x -> s { T.synopsis = x }) (f (T.synopsis s)) -{-# INLINE synopsis #-} - -description :: Lens' InstalledPackageInfo ShortText -description f s = fmap (\x -> s { T.description = x }) (f (T.description s)) -{-# INLINE description #-} - -category :: Lens' InstalledPackageInfo ShortText -category f s = fmap (\x -> s { T.category = x }) (f (T.category s)) -{-# INLINE category #-} - -abiHash :: Lens' InstalledPackageInfo AbiHash -abiHash f s = fmap (\x -> s { T.abiHash = x }) (f (T.abiHash s)) -{-# INLINE abiHash #-} - -indefinite :: Lens' InstalledPackageInfo Bool -indefinite f s = fmap (\x -> s { T.indefinite = x }) (f (T.indefinite s)) -{-# INLINE indefinite #-} - -exposed :: Lens' InstalledPackageInfo Bool -exposed f s = fmap (\x -> s { T.exposed = x }) (f (T.exposed s)) -{-# INLINE exposed #-} - -exposedModules :: Lens' InstalledPackageInfo [ExposedModule] -exposedModules f s = fmap (\x -> s { T.exposedModules = x }) (f (T.exposedModules s)) -{-# INLINE exposedModules #-} - -hiddenModules :: Lens' InstalledPackageInfo [ModuleName] -hiddenModules f s = fmap (\x -> s { T.hiddenModules = x }) (f (T.hiddenModules s)) -{-# INLINE hiddenModules #-} - -trusted :: Lens' InstalledPackageInfo Bool -trusted f s = fmap (\x -> s { T.trusted = x }) (f (T.trusted s)) -{-# INLINE trusted #-} - -importDirs :: Lens' InstalledPackageInfo [FilePath] -importDirs f s = fmap (\x -> s { T.importDirs = x }) (f (T.importDirs s)) -{-# INLINE importDirs #-} - -libraryDirs :: Lens' InstalledPackageInfo [FilePath] -libraryDirs f s = fmap (\x -> s { T.libraryDirs = x }) (f (T.libraryDirs s)) -{-# INLINE libraryDirs #-} - -libraryDynDirs :: Lens' InstalledPackageInfo [FilePath] -libraryDynDirs f s = fmap (\x -> s { T.libraryDynDirs = x }) (f (T.libraryDynDirs s)) -{-# INLINE libraryDynDirs #-} - -dataDir :: Lens' InstalledPackageInfo FilePath -dataDir f s = fmap (\x -> s { T.dataDir = x }) (f (T.dataDir s)) -{-# INLINE dataDir #-} - -hsLibraries :: Lens' InstalledPackageInfo [String] -hsLibraries f s = fmap (\x -> s { T.hsLibraries = x }) (f (T.hsLibraries s)) -{-# INLINE hsLibraries #-} - -extraLibraries :: Lens' InstalledPackageInfo [String] -extraLibraries f s = fmap (\x -> s { T.extraLibraries = x }) (f (T.extraLibraries s)) -{-# INLINE extraLibraries #-} - -extraGHCiLibraries :: Lens' InstalledPackageInfo [String] -extraGHCiLibraries f s = fmap (\x -> s { T.extraGHCiLibraries = x }) (f (T.extraGHCiLibraries s)) -{-# INLINE extraGHCiLibraries #-} - -includeDirs :: Lens' InstalledPackageInfo [FilePath] -includeDirs f s = fmap (\x -> s { T.includeDirs = x }) (f (T.includeDirs s)) -{-# INLINE includeDirs #-} - -includes :: Lens' InstalledPackageInfo [String] -includes f s = fmap (\x -> s { T.includes = x }) (f (T.includes s)) -{-# INLINE includes #-} - -depends :: Lens' InstalledPackageInfo [UnitId] -depends f s = fmap (\x -> s { T.depends = x }) (f (T.depends s)) -{-# INLINE depends #-} - -abiDepends :: Lens' InstalledPackageInfo [AbiDependency] -abiDepends f s = fmap (\x -> s { T.abiDepends = x }) (f (T.abiDepends s)) -{-# INLINE abiDepends #-} - -ccOptions :: Lens' InstalledPackageInfo [String] -ccOptions f s = fmap (\x -> s { T.ccOptions = x }) (f (T.ccOptions s)) -{-# INLINE ccOptions #-} - -cxxOptions :: Lens' InstalledPackageInfo [String] -cxxOptions f s = fmap (\x -> s { T.cxxOptions = x }) (f (T.cxxOptions s)) -{-# INLINE cxxOptions #-} - -ldOptions :: Lens' InstalledPackageInfo [String] -ldOptions f s = fmap (\x -> s { T.ldOptions = x }) (f (T.ldOptions s)) -{-# INLINE ldOptions #-} - -frameworkDirs :: Lens' InstalledPackageInfo [FilePath] -frameworkDirs f s = fmap (\x -> s { T.frameworkDirs = x }) (f (T.frameworkDirs s)) -{-# INLINE frameworkDirs #-} - -frameworks :: Lens' InstalledPackageInfo [String] -frameworks f s = fmap (\x -> s { T.frameworks = x }) (f (T.frameworks s)) -{-# INLINE frameworks #-} - -haddockInterfaces :: Lens' InstalledPackageInfo [FilePath] -haddockInterfaces f s = fmap (\x -> s { T.haddockInterfaces = x }) (f (T.haddockInterfaces s)) -{-# INLINE haddockInterfaces #-} - -haddockHTMLs :: Lens' InstalledPackageInfo [FilePath] -haddockHTMLs f s = fmap (\x -> s { T.haddockHTMLs = x }) (f (T.haddockHTMLs s)) -{-# INLINE haddockHTMLs #-} - -pkgRoot :: Lens' InstalledPackageInfo (Maybe FilePath) -pkgRoot f s = fmap (\x -> s { T.pkgRoot = x }) (f (T.pkgRoot s)) -{-# INLINE pkgRoot #-} - -libVisibility :: Lens' InstalledPackageInfo LibraryVisibility -libVisibility f s = fmap (\x -> s { T.libVisibility = x }) (f (T.libVisibility s)) -{-# INLINE libVisibility #-} - diff --git a/cabal/Cabal/Distribution/Types/LegacyExeDependency.hs b/cabal/Cabal/Distribution/Types/LegacyExeDependency.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/LegacyExeDependency.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.LegacyExeDependency - ( LegacyExeDependency(..) - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Version (VersionRange, anyVersion) - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - --- | Describes a legacy `build-tools`-style dependency on an executable --- --- It is "legacy" because we do not know what the build-tool referred to. It --- could refer to a pkg-config executable (PkgconfigName), or an internal --- executable (UnqualComponentName). Thus the name is stringly typed. --- --- @since 2.0.0.2 -data LegacyExeDependency = LegacyExeDependency - String - VersionRange - deriving (Generic, Read, Show, Eq, Typeable, Data) - -instance Binary LegacyExeDependency -instance Structured LegacyExeDependency -instance NFData LegacyExeDependency where rnf = genericRnf - -instance Pretty LegacyExeDependency where - pretty (LegacyExeDependency name ver) = - Disp.text name <+> pretty ver - -instance Parsec LegacyExeDependency where - parsec = do - name <- parsecMaybeQuoted nameP - P.spaces - verRange <- parsecMaybeQuoted parsec <|> pure anyVersion - pure $ LegacyExeDependency name verRange - where - nameP = intercalate "-" <$> toList <$> P.sepByNonEmpty component (P.char '-') - component = do - cs <- P.munch1 (\c -> isAlphaNum c || c == '+' || c == '_') - if all isDigit cs then fail "invalid component" else return cs diff --git a/cabal/Cabal/Distribution/Types/Lens.hs b/cabal/Cabal/Distribution/Types/Lens.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/Lens.hs +++ /dev/null @@ -1,25 +0,0 @@ -module Distribution.Types.Lens ( - module Distribution.Types.Benchmark.Lens, - module Distribution.Types.BuildInfo.Lens, - module Distribution.Types.Executable.Lens, - module Distribution.Types.ForeignLib.Lens, - module Distribution.Types.GenericPackageDescription.Lens, - module Distribution.Types.Library.Lens, - module Distribution.Types.PackageDescription.Lens, - module Distribution.Types.PackageId.Lens, - module Distribution.Types.SetupBuildInfo.Lens, - module Distribution.Types.SourceRepo.Lens, - module Distribution.Types.TestSuite.Lens, - ) where - -import Distribution.Types.Benchmark.Lens -import Distribution.Types.BuildInfo.Lens -import Distribution.Types.Executable.Lens -import Distribution.Types.ForeignLib.Lens -import Distribution.Types.GenericPackageDescription.Lens -import Distribution.Types.Library.Lens -import Distribution.Types.PackageDescription.Lens -import Distribution.Types.PackageId.Lens -import Distribution.Types.SetupBuildInfo.Lens -import Distribution.Types.SourceRepo.Lens -import Distribution.Types.TestSuite.Lens diff --git a/cabal/Cabal/Distribution/Types/Library.hs b/cabal/Cabal/Distribution/Types/Library.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/Library.hs +++ /dev/null @@ -1,97 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE NoMonoLocalBinds #-} - -module Distribution.Types.Library ( - Library(..), - emptyLibrary, - explicitLibModules, - libModulesAutogen, -) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.ModuleName -import Distribution.Types.BuildInfo -import Distribution.Types.LibraryVisibility -import Distribution.Types.ModuleReexport -import Distribution.Types.LibraryName - -import qualified Distribution.Types.BuildInfo.Lens as L - -data Library = Library - { libName :: LibraryName - , exposedModules :: [ModuleName] - , reexportedModules :: [ModuleReexport] - , signatures :: [ModuleName] -- ^ What sigs need implementations? - , libExposed :: Bool -- ^ Is the lib to be exposed by default? (i.e. whether its modules available in GHCi for example) - , libVisibility :: LibraryVisibility -- ^ Whether this multilib can be dependent from outside. - , libBuildInfo :: BuildInfo - } - deriving (Generic, Show, Eq, Read, Typeable, Data) - -instance L.HasBuildInfo Library where - buildInfo f l = (\x -> l { libBuildInfo = x }) <$> f (libBuildInfo l) - -instance Binary Library -instance Structured Library -instance NFData Library where rnf = genericRnf - -emptyLibrary :: Library -emptyLibrary = Library - { libName = LMainLibName - , exposedModules = mempty - , reexportedModules = mempty - , signatures = mempty - , libExposed = True - , libVisibility = mempty - , libBuildInfo = mempty - } - --- | This instance is not good. --- --- We need it for 'PackageDescription.Configuration.addBuildableCondition'. --- More correct method would be some kind of "create empty clone". --- --- More concretely, 'addBuildableCondition' will make `libVisibility = False` --- libraries when `buildable: false`. This may cause problems. --- -instance Monoid Library where - mempty = emptyLibrary - mappend = (<>) - -instance Semigroup Library where - a <> b = Library - { libName = combineLibraryName (libName a) (libName b) - , exposedModules = combine exposedModules - , reexportedModules = combine reexportedModules - , signatures = combine signatures - , libExposed = libExposed a && libExposed b -- so False propagates - , libVisibility = combine libVisibility - , libBuildInfo = combine libBuildInfo - } - where combine field = field a `mappend` field b - --- | Get all the module names from the library (exposed and internal modules) --- which are explicitly listed in the package description which would --- need to be compiled. (This does not include reexports, which --- do not need to be compiled.) This may not include all modules for which --- GHC generated interface files (i.e., implicit modules.) -explicitLibModules :: Library -> [ModuleName] -explicitLibModules lib = exposedModules lib - ++ otherModules (libBuildInfo lib) - ++ signatures lib - --- | Get all the auto generated module names from the library, exposed or not. --- This are a subset of 'libModules'. -libModulesAutogen :: Library -> [ModuleName] -libModulesAutogen lib = autogenModules (libBuildInfo lib) - --- | Combine 'LibraryName'. in parsing we prefer value coming --- from munged @name@ field over the @lib-name@. --- --- /Should/ be irrelevant. -combineLibraryName :: LibraryName -> LibraryName -> LibraryName -combineLibraryName l@(LSubLibName _) _ = l -combineLibraryName _ l = l diff --git a/cabal/Cabal/Distribution/Types/Library/Lens.hs b/cabal/Cabal/Distribution/Types/Library/Lens.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/Library/Lens.hs +++ /dev/null @@ -1,45 +0,0 @@ -module Distribution.Types.Library.Lens ( - Library, - module Distribution.Types.Library.Lens, - ) where - -import Distribution.Compat.Lens -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.ModuleName (ModuleName) -import Distribution.Types.BuildInfo (BuildInfo) -import Distribution.Types.Library (Library) -import Distribution.Types.LibraryName (LibraryName) -import Distribution.Types.LibraryVisibility (LibraryVisibility) -import Distribution.Types.ModuleReexport (ModuleReexport) - -import qualified Distribution.Types.Library as T - -libName :: Lens' Library LibraryName -libName f s = fmap (\x -> s { T.libName = x }) (f (T.libName s)) -{-# INLINE libName #-} - -exposedModules :: Lens' Library [ModuleName] -exposedModules f s = fmap (\x -> s { T.exposedModules = x }) (f (T.exposedModules s)) -{-# INLINE exposedModules #-} - -reexportedModules :: Lens' Library [ModuleReexport] -reexportedModules f s = fmap (\x -> s { T.reexportedModules = x }) (f (T.reexportedModules s)) -{-# INLINE reexportedModules #-} - -signatures :: Lens' Library [ModuleName] -signatures f s = fmap (\x -> s { T.signatures = x }) (f (T.signatures s)) -{-# INLINE signatures #-} - -libExposed :: Lens' Library Bool -libExposed f s = fmap (\x -> s { T.libExposed = x }) (f (T.libExposed s)) -{-# INLINE libExposed #-} - -libVisibility :: Lens' Library LibraryVisibility -libVisibility f s = fmap (\x -> s { T.libVisibility = x }) (f (T.libVisibility s)) -{-# INLINE libVisibility #-} - -libBuildInfo :: Lens' Library BuildInfo -libBuildInfo f s = fmap (\x -> s { T.libBuildInfo = x }) (f (T.libBuildInfo s)) -{-# INLINE libBuildInfo #-} diff --git a/cabal/Cabal/Distribution/Types/LibraryName.hs b/cabal/Cabal/Distribution/Types/LibraryName.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/LibraryName.hs +++ /dev/null @@ -1,73 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - -module Distribution.Types.LibraryName ( - LibraryName(..), - defaultLibName, - maybeToLibraryName, - showLibraryName, - libraryNameStanza, - libraryNameString, - -- * Pretty & Parse - prettyLibraryNameComponent, - parsecLibraryNameComponent, - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Types.UnqualComponentName -import Distribution.Pretty -import Distribution.Parsec - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - -data LibraryName = LMainLibName - | LSubLibName UnqualComponentName - deriving (Eq, Generic, Ord, Read, Show, Typeable, Data) - -instance Binary LibraryName -instance Structured LibraryName -instance NFData LibraryName where rnf = genericRnf - --- | Pretty print 'LibraryName' in build-target-ish syntax. --- --- /Note:/ there are no 'Pretty' or 'Parsec' instances, --- as there's other way to represent 'LibraryName', namely as bare --- 'UnqualComponentName'. -prettyLibraryNameComponent :: LibraryName -> Disp.Doc -prettyLibraryNameComponent LMainLibName = Disp.text "lib" -prettyLibraryNameComponent (LSubLibName str) = Disp.text "lib:" <<>> pretty str - -parsecLibraryNameComponent :: CabalParsing m => m LibraryName -parsecLibraryNameComponent = do - _ <- P.string "lib" - parseComposite <|> parseSingle - where - parseSingle = return LMainLibName - parseComposite = do - _ <- P.char ':' - LSubLibName <$> parsec - -defaultLibName :: LibraryName -defaultLibName = LMainLibName - -showLibraryName :: LibraryName -> String -showLibraryName LMainLibName = "library" -showLibraryName (LSubLibName name) = "library '" ++ prettyShow name ++ "'" - -libraryNameStanza :: LibraryName -> String -libraryNameStanza LMainLibName = "library" -libraryNameStanza (LSubLibName name) = "library " ++ prettyShow name - -libraryNameString :: LibraryName -> Maybe UnqualComponentName -libraryNameString LMainLibName = Nothing -libraryNameString (LSubLibName n) = Just n - --- | Convert the 'UnqualComponentName' of a library into a --- 'LibraryName'. -maybeToLibraryName :: Maybe UnqualComponentName -> LibraryName -maybeToLibraryName Nothing = LMainLibName -maybeToLibraryName (Just n) = LSubLibName n - diff --git a/cabal/Cabal/Distribution/Types/LibraryVisibility.hs b/cabal/Cabal/Distribution/Types/LibraryVisibility.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/LibraryVisibility.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} - -module Distribution.Types.LibraryVisibility( - LibraryVisibility(..), -) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Parsec -import Distribution.Pretty - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - --- | Multi-lib visibility --- --- @since 3.0.0.0 --- -data LibraryVisibility - -- | Can be depenendent from other packages - = LibraryVisibilityPublic - -- | Internal library, default - | LibraryVisibilityPrivate - deriving (Generic, Show, Read, Eq, Typeable, Data) - -instance Pretty LibraryVisibility where - pretty LibraryVisibilityPublic = Disp.text "public" - pretty LibraryVisibilityPrivate = Disp.text "private" - -instance Parsec LibraryVisibility where - parsec = do - name <- P.munch1 isAlpha - parsecWarning PWTExperimental "visibility is experimental feature (issue #5660)" - case name of - "public" -> return LibraryVisibilityPublic - "private" -> return LibraryVisibilityPrivate - _ -> fail $ "Unknown visibility: " ++ name - -instance Binary LibraryVisibility -instance Structured LibraryVisibility -instance NFData LibraryVisibility where rnf = genericRnf - -instance Semigroup LibraryVisibility where - LibraryVisibilityPrivate <> LibraryVisibilityPrivate = LibraryVisibilityPrivate - _ <> _ = LibraryVisibilityPublic - -instance Monoid LibraryVisibility where - mempty = LibraryVisibilityPrivate - mappend = (<>) diff --git a/cabal/Cabal/Distribution/Types/LocalBuildInfo.hs b/cabal/Cabal/Distribution/Types/LocalBuildInfo.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/LocalBuildInfo.hs +++ /dev/null @@ -1,304 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - -module Distribution.Types.LocalBuildInfo ( - -- * The type - - LocalBuildInfo(..), - - -- * Convenience accessors - - localComponentId, - localUnitId, - localCompatPackageKey, - localPackage, - - -- * Build targets of the 'LocalBuildInfo'. - - componentNameCLBIs, - - -- NB: the primes mean that they take a 'PackageDescription' - -- which may not match 'localPkgDescr' in 'LocalBuildInfo'. - -- More logical types would drop this argument, but - -- at the moment, this is the ONLY supported function, because - -- 'localPkgDescr' is not guaranteed to match. At some point - -- we will fix it and then we can use the (free) unprimed - -- namespace for the correct commands. - -- - -- See https://github.com/haskell/cabal/issues/3606 for more - -- details. - - componentNameTargets', - unitIdTarget', - allTargetsInBuildOrder', - withAllTargetsInBuildOrder', - neededTargetsInBuildOrder', - withNeededTargetsInBuildOrder', - testCoverage, - - -- * Functions you SHOULD NOT USE (yet), but are defined here to - -- prevent someone from accidentally defining them - - componentNameTargets, - unitIdTarget, - allTargetsInBuildOrder, - withAllTargetsInBuildOrder, - neededTargetsInBuildOrder, - withNeededTargetsInBuildOrder, - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Types.PackageDescription -import Distribution.Types.ComponentLocalBuildInfo -import Distribution.Types.ComponentRequestedSpec -import Distribution.Types.ComponentId -import Distribution.Types.PackageId -import Distribution.Types.UnitId -import Distribution.Types.TargetInfo - -import Distribution.Simple.InstallDirs hiding (absoluteInstallDirs, - prefixRelativeInstallDirs, - substPathTemplate, ) -import Distribution.Simple.Program -import Distribution.PackageDescription -import Distribution.Simple.Compiler -import Distribution.Simple.PackageIndex -import Distribution.Simple.Setup -import Distribution.System -import Distribution.Pretty - -import Distribution.Compat.Graph (Graph) -import qualified Distribution.Compat.Graph as Graph -import qualified Data.Map as Map - --- | Data cached after configuration step. See also --- 'Distribution.Simple.Setup.ConfigFlags'. -data LocalBuildInfo = LocalBuildInfo { - configFlags :: ConfigFlags, - -- ^ Options passed to the configuration step. - -- Needed to re-run configuration when .cabal is out of date - flagAssignment :: FlagAssignment, - -- ^ The final set of flags which were picked for this package - componentEnabledSpec :: ComponentRequestedSpec, - -- ^ What components were enabled during configuration, and why. - extraConfigArgs :: [String], - -- ^ Extra args on the command line for the configuration step. - -- Needed to re-run configuration when .cabal is out of date - installDirTemplates :: InstallDirTemplates, - -- ^ The installation directories for the various different - -- kinds of files - --TODO: inplaceDirTemplates :: InstallDirs FilePath - compiler :: Compiler, - -- ^ The compiler we're building with - hostPlatform :: Platform, - -- ^ The platform we're building for - buildDir :: FilePath, - -- ^ Where to build the package. - cabalFilePath :: Maybe FilePath, - -- ^ Path to the cabal file, if given during configuration. - componentGraph :: Graph ComponentLocalBuildInfo, - -- ^ All the components to build, ordered by topological - -- sort, and with their INTERNAL dependencies over the - -- intrapackage dependency graph. - -- TODO: this is assumed to be short; otherwise we want - -- some sort of ordered map. - componentNameMap :: Map ComponentName [ComponentLocalBuildInfo], - -- ^ A map from component name to all matching - -- components. These coincide with 'componentGraph' - installedPkgs :: InstalledPackageIndex, - -- ^ All the info about the installed packages that the - -- current package depends on (directly or indirectly). - -- The copy saved on disk does NOT include internal - -- dependencies (because we just don't have enough - -- information at this point to have an - -- 'InstalledPackageInfo' for an internal dep), but we - -- will often update it with the internal dependencies; - -- see for example 'Distribution.Simple.Build.build'. - -- (This admonition doesn't apply for per-component builds.) - pkgDescrFile :: Maybe FilePath, - -- ^ the filename containing the .cabal file, if available - localPkgDescr :: PackageDescription, - -- ^ WARNING WARNING WARNING Be VERY careful about using - -- this function; we haven't deprecated it but using it - -- could introduce subtle bugs related to - -- 'HookedBuildInfo'. - -- - -- In principle, this is supposed to contain the - -- resolved package description, that does not contain - -- any conditionals. However, it MAY NOT contain - -- the description with a 'HookedBuildInfo' applied - -- to it; see 'HookedBuildInfo' for the whole sordid saga. - -- As much as possible, Cabal library should avoid using - -- this parameter. - withPrograms :: ProgramDb, -- ^Location and args for all programs - withPackageDB :: PackageDBStack, -- ^What package database to use, global\/user - withVanillaLib:: Bool, -- ^Whether to build normal libs. - withProfLib :: Bool, -- ^Whether to build profiling versions of libs. - withSharedLib :: Bool, -- ^Whether to build shared versions of libs. - withStaticLib :: Bool, -- ^Whether to build static versions of libs (with all other libs rolled in) - withDynExe :: Bool, -- ^Whether to link executables dynamically - withFullyStaticExe :: Bool, -- ^Whether to link executables fully statically - withProfExe :: Bool, -- ^Whether to build executables for profiling. - withProfLibDetail :: ProfDetailLevel, -- ^Level of automatic profile detail. - withProfExeDetail :: ProfDetailLevel, -- ^Level of automatic profile detail. - withOptimization :: OptimisationLevel, -- ^Whether to build with optimization (if available). - withDebugInfo :: DebugInfoLevel, -- ^Whether to emit debug info (if available). - withGHCiLib :: Bool, -- ^Whether to build libs suitable for use with GHCi. - splitSections :: Bool, -- ^Use -split-sections with GHC, if available - splitObjs :: Bool, -- ^Use -split-objs with GHC, if available - stripExes :: Bool, -- ^Whether to strip executables during install - stripLibs :: Bool, -- ^Whether to strip libraries during install - exeCoverage :: Bool, -- ^Whether to enable executable program coverage - libCoverage :: Bool, -- ^Whether to enable library program coverage - progPrefix :: PathTemplate, -- ^Prefix to be prepended to installed executables - progSuffix :: PathTemplate, -- ^Suffix to be appended to installed executables - relocatable :: Bool -- ^Whether to build a relocatable package - } deriving (Generic, Read, Show, Typeable) - -instance Binary LocalBuildInfo -instance Structured LocalBuildInfo - -------------------------------------------------------------------------------- --- Accessor functions - --- TODO: Get rid of these functions, as much as possible. They are --- a bit useful in some cases, but you should be very careful! - --- | Extract the 'ComponentId' from the public library component of a --- 'LocalBuildInfo' if it exists, or make a fake component ID based --- on the package ID. -localComponentId :: LocalBuildInfo -> ComponentId -localComponentId lbi = - case componentNameCLBIs lbi (CLibName LMainLibName) of - [LibComponentLocalBuildInfo { componentComponentId = cid }] - -> cid - _ -> mkComponentId (prettyShow (localPackage lbi)) - --- | Extract the 'PackageIdentifier' of a 'LocalBuildInfo'. --- This is a "safe" use of 'localPkgDescr' -localPackage :: LocalBuildInfo -> PackageId -localPackage lbi = package (localPkgDescr lbi) - --- | Extract the 'UnitId' from the library component of a --- 'LocalBuildInfo' if it exists, or make a fake unit ID based on --- the package ID. -localUnitId :: LocalBuildInfo -> UnitId -localUnitId lbi = - case componentNameCLBIs lbi (CLibName LMainLibName) of - [LibComponentLocalBuildInfo { componentUnitId = uid }] - -> uid - _ -> mkLegacyUnitId $ localPackage lbi - --- | Extract the compatibility package key from the public library component of a --- 'LocalBuildInfo' if it exists, or make a fake package key based --- on the package ID. -localCompatPackageKey :: LocalBuildInfo -> String -localCompatPackageKey lbi = - case componentNameCLBIs lbi (CLibName LMainLibName) of - [LibComponentLocalBuildInfo { componentCompatPackageKey = pk }] - -> pk - _ -> prettyShow (localPackage lbi) - --- | Convenience function to generate a default 'TargetInfo' from a --- 'ComponentLocalBuildInfo'. The idea is to call this once, and then --- use 'TargetInfo' everywhere else. Private to this module. -mkTargetInfo :: PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> TargetInfo -mkTargetInfo pkg_descr _lbi clbi = - TargetInfo { - targetCLBI = clbi, - -- NB: @pkg_descr@, not @localPkgDescr lbi@! - targetComponent = getComponent pkg_descr - (componentLocalName clbi) - } - --- | Return all 'TargetInfo's associated with 'ComponentName'. --- In the presence of Backpack there may be more than one! --- Has a prime because it takes a 'PackageDescription' argument --- which may disagree with 'localPkgDescr' in 'LocalBuildInfo'. -componentNameTargets' :: PackageDescription -> LocalBuildInfo -> ComponentName -> [TargetInfo] -componentNameTargets' pkg_descr lbi cname = - case Map.lookup cname (componentNameMap lbi) of - Just clbis -> map (mkTargetInfo pkg_descr lbi) clbis - Nothing -> [] - -unitIdTarget' :: PackageDescription -> LocalBuildInfo -> UnitId -> Maybe TargetInfo -unitIdTarget' pkg_descr lbi uid = - case Graph.lookup uid (componentGraph lbi) of - Just clbi -> Just (mkTargetInfo pkg_descr lbi clbi) - Nothing -> Nothing - --- | Return all 'ComponentLocalBuildInfo's associated with 'ComponentName'. --- In the presence of Backpack there may be more than one! -componentNameCLBIs :: LocalBuildInfo -> ComponentName -> [ComponentLocalBuildInfo] -componentNameCLBIs lbi cname = - case Map.lookup cname (componentNameMap lbi) of - Just clbis -> clbis - Nothing -> [] - --- TODO: Maybe cache topsort (Graph can do this) - --- | Return the list of default 'TargetInfo's associated with a --- configured package, in the order they need to be built. --- Has a prime because it takes a 'PackageDescription' argument --- which may disagree with 'localPkgDescr' in 'LocalBuildInfo'. -allTargetsInBuildOrder' :: PackageDescription -> LocalBuildInfo -> [TargetInfo] -allTargetsInBuildOrder' pkg_descr lbi - = map (mkTargetInfo pkg_descr lbi) (Graph.revTopSort (componentGraph lbi)) - --- | Execute @f@ for every 'TargetInfo' in the package, respecting the --- build dependency order. (TODO: We should use Shake!) --- Has a prime because it takes a 'PackageDescription' argument --- which may disagree with 'localPkgDescr' in 'LocalBuildInfo'. -withAllTargetsInBuildOrder' :: PackageDescription -> LocalBuildInfo -> (TargetInfo -> IO ()) -> IO () -withAllTargetsInBuildOrder' pkg_descr lbi f - = sequence_ [ f target | target <- allTargetsInBuildOrder' pkg_descr lbi ] - --- | Return the list of all targets needed to build the @uids@, in --- the order they need to be built. --- Has a prime because it takes a 'PackageDescription' argument --- which may disagree with 'localPkgDescr' in 'LocalBuildInfo'. -neededTargetsInBuildOrder' :: PackageDescription -> LocalBuildInfo -> [UnitId] -> [TargetInfo] -neededTargetsInBuildOrder' pkg_descr lbi uids = - case Graph.closure (componentGraph lbi) uids of - Nothing -> error $ "localBuildPlan: missing uids " ++ intercalate ", " (map prettyShow uids) - Just clos -> map (mkTargetInfo pkg_descr lbi) (Graph.revTopSort (Graph.fromDistinctList clos)) - --- | Execute @f@ for every 'TargetInfo' needed to build @uid@s, respecting --- the build dependency order. --- Has a prime because it takes a 'PackageDescription' argument --- which may disagree with 'localPkgDescr' in 'LocalBuildInfo'. -withNeededTargetsInBuildOrder' :: PackageDescription -> LocalBuildInfo -> [UnitId] -> (TargetInfo -> IO ()) -> IO () -withNeededTargetsInBuildOrder' pkg_descr lbi uids f - = sequence_ [ f target | target <- neededTargetsInBuildOrder' pkg_descr lbi uids ] - --- | Is coverage enabled for test suites? In practice, this requires library --- and executable profiling to be enabled. -testCoverage :: LocalBuildInfo -> Bool -testCoverage lbi = exeCoverage lbi && libCoverage lbi - -------------------------------------------------------------------------------- --- Stub functions to prevent someone from accidentally defining them - -{-# WARNING componentNameTargets, unitIdTarget, allTargetsInBuildOrder, withAllTargetsInBuildOrder, neededTargetsInBuildOrder, withNeededTargetsInBuildOrder "By using this function, you may be introducing a bug where you retrieve a 'Component' which does not have 'HookedBuildInfo' applied to it. See the documentation for 'HookedBuildInfo' for an explanation of the issue. If you have a 'PakcageDescription' handy (NOT from the 'LocalBuildInfo'), try using the primed version of the function, which takes it as an extra argument." #-} - -componentNameTargets :: LocalBuildInfo -> ComponentName -> [TargetInfo] -componentNameTargets lbi = componentNameTargets' (localPkgDescr lbi) lbi - -unitIdTarget :: LocalBuildInfo -> UnitId -> Maybe TargetInfo -unitIdTarget lbi = unitIdTarget' (localPkgDescr lbi) lbi - -allTargetsInBuildOrder :: LocalBuildInfo -> [TargetInfo] -allTargetsInBuildOrder lbi = allTargetsInBuildOrder' (localPkgDescr lbi) lbi - -withAllTargetsInBuildOrder :: LocalBuildInfo -> (TargetInfo -> IO ()) -> IO () -withAllTargetsInBuildOrder lbi = withAllTargetsInBuildOrder' (localPkgDescr lbi) lbi - -neededTargetsInBuildOrder :: LocalBuildInfo -> [UnitId] -> [TargetInfo] -neededTargetsInBuildOrder lbi = neededTargetsInBuildOrder' (localPkgDescr lbi) lbi - -withNeededTargetsInBuildOrder :: LocalBuildInfo -> [UnitId] -> (TargetInfo -> IO ()) -> IO () -withNeededTargetsInBuildOrder lbi = withNeededTargetsInBuildOrder' (localPkgDescr lbi) lbi diff --git a/cabal/Cabal/Distribution/Types/Mixin.hs b/cabal/Cabal/Distribution/Types/Mixin.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/Mixin.hs +++ /dev/null @@ -1,93 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - -module Distribution.Types.Mixin ( - Mixin(..), - mkMixin, - normaliseMixin, -) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.CabalSpecVersion -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Types.IncludeRenaming -import Distribution.Types.LibraryName -import Distribution.Types.PackageName -import Distribution.Types.UnqualComponentName - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as PP - --- | --- --- /Invariant:/ if 'mixinLibraryName' is 'LSubLibName', it's not --- the same as 'mixinPackageName'. In other words, --- the same invariant as 'Dependency' has. --- -data Mixin = Mixin { mixinPackageName :: PackageName - , mixinLibraryName :: LibraryName - , mixinIncludeRenaming :: IncludeRenaming } - deriving (Show, Read, Eq, Ord, Typeable, Data, Generic) - -instance Binary Mixin -instance Structured Mixin - -instance NFData Mixin where rnf = genericRnf - -instance Pretty Mixin where - pretty (Mixin pn LMainLibName incl) = pretty pn <+> pretty incl - pretty (Mixin pn (LSubLibName ln) incl) = pretty pn <<>> PP.colon <<>> pretty ln <+> pretty incl - --- | --- --- >>> simpleParsec "mylib" :: Maybe Mixin --- Just (Mixin {mixinPackageName = PackageName "mylib", mixinLibraryName = LMainLibName, mixinIncludeRenaming = IncludeRenaming {includeProvidesRn = DefaultRenaming, includeRequiresRn = DefaultRenaming}}) --- --- >>> simpleParsec "thatlib:sublib" :: Maybe Mixin --- Just (Mixin {mixinPackageName = PackageName "thatlib", mixinLibraryName = LSubLibName (UnqualComponentName "sublib"), mixinIncludeRenaming = IncludeRenaming {includeProvidesRn = DefaultRenaming, includeRequiresRn = DefaultRenaming}}) --- --- >>> simpleParsec "thatlib:thatlib" :: Maybe Mixin --- Just (Mixin {mixinPackageName = PackageName "thatlib", mixinLibraryName = LMainLibName, mixinIncludeRenaming = IncludeRenaming {includeProvidesRn = DefaultRenaming, includeRequiresRn = DefaultRenaming}}) --- --- Sublibrary syntax is accepted since @cabal-version: 3.4@. --- --- >>> map (`simpleParsec'` "mylib:sub") [CabalSpecV3_0, CabalSpecV3_4] :: [Maybe Mixin] --- [Nothing,Just (Mixin {mixinPackageName = PackageName "mylib", mixinLibraryName = LSubLibName (UnqualComponentName "sub"), mixinIncludeRenaming = IncludeRenaming {includeProvidesRn = DefaultRenaming, includeRequiresRn = DefaultRenaming}})] --- -instance Parsec Mixin where - parsec = do - pn <- parsec - ln <- P.option LMainLibName $ do - _ <- P.char ':' - versionGuardMultilibs - parsecWarning PWTExperimental "colon specifier is experimental feature (issue #5660)" - LSubLibName <$> parsec - P.spaces - incl <- parsec - return (mkMixin pn ln incl) - where - -versionGuardMultilibs :: CabalParsing m => m () -versionGuardMultilibs = do - csv <- askCabalSpecVersion - when (csv < CabalSpecV3_4) $ fail $ unwords - [ "Sublibrary mixin syntax used." - , "To use this syntax the package needs to specify at least 'cabal-version: 3.4'." - ] - --- | Smart constructor of 'Mixin', enforces invariant. --- --- @since 3.4.0.0 -mkMixin :: PackageName -> LibraryName -> IncludeRenaming -> Mixin -mkMixin pn (LSubLibName uqn) incl - | packageNameToUnqualComponentName pn == uqn - = Mixin pn LMainLibName incl -mkMixin pn ln incl - = Mixin pn ln incl - --- | Restore invariant -normaliseMixin :: Mixin -> Mixin -normaliseMixin (Mixin pn ln incl) = mkMixin pn ln incl diff --git a/cabal/Cabal/Distribution/Types/Module.hs b/cabal/Cabal/Distribution/Types/Module.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/Module.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Distribution.Types.Module - ( Module(..) - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp -import Distribution.Pretty -import Distribution.Parsec -import Distribution.Types.UnitId -import Distribution.ModuleName - --- | A module identity uniquely identifies a Haskell module by --- qualifying a 'ModuleName' with the 'UnitId' which defined --- it. This type distinguishes between two packages --- which provide a module with the same name, or a module --- from the same package compiled with different dependencies. --- There are a few cases where Cabal needs to know about --- module identities, e.g., when writing out reexported modules in --- the 'InstalledPackageInfo'. -data Module = - Module DefUnitId ModuleName - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) - -instance Binary Module -instance Structured Module - -instance Pretty Module where - pretty (Module uid mod_name) = - pretty uid <<>> Disp.text ":" <<>> pretty mod_name - -instance Parsec Module where - parsec = do - uid <- parsec - _ <- P.char ':' - mod_name <- parsec - return (Module uid mod_name) - -instance NFData Module where - rnf (Module uid mod_name) = rnf uid `seq` rnf mod_name diff --git a/cabal/Cabal/Distribution/Types/ModuleReexport.hs b/cabal/Cabal/Distribution/Types/ModuleReexport.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/ModuleReexport.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - -module Distribution.Types.ModuleReexport ( - ModuleReexport(..) -) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.ModuleName -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Types.PackageName - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - --- ----------------------------------------------------------------------------- --- Module re-exports - -data ModuleReexport = ModuleReexport { - moduleReexportOriginalPackage :: Maybe PackageName, - moduleReexportOriginalName :: ModuleName, - moduleReexportName :: ModuleName - } - deriving (Eq, Generic, Read, Show, Typeable, Data) - -instance Binary ModuleReexport -instance Structured ModuleReexport -instance NFData ModuleReexport where rnf = genericRnf - -instance Pretty ModuleReexport where - pretty (ModuleReexport mpkgname origname newname) = - maybe Disp.empty (\pkgname -> pretty pkgname <<>> Disp.char ':') mpkgname - <<>> pretty origname - <+> if newname == origname - then Disp.empty - else Disp.text "as" <+> pretty newname - -instance Parsec ModuleReexport where - parsec = do - mpkgname <- P.optional (P.try $ parsec <* P.char ':') - origname <- parsec - newname <- P.option origname $ P.try $ do - P.spaces - _ <- P.string "as" - P.spaces - parsec - return (ModuleReexport mpkgname origname newname) diff --git a/cabal/Cabal/Distribution/Types/ModuleRenaming.hs b/cabal/Cabal/Distribution/Types/ModuleRenaming.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/ModuleRenaming.hs +++ /dev/null @@ -1,135 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE NoMonoLocalBinds #-} - -module Distribution.Types.ModuleRenaming ( - ModuleRenaming(..), - interpModuleRenaming, - defaultRenaming, - isDefaultRenaming, -) where - -import Distribution.CabalSpecVersion -import Distribution.Compat.Prelude hiding (empty) -import Prelude () - -import Distribution.ModuleName -import Distribution.Parsec -import Distribution.Pretty - -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Distribution.Compat.CharParsing as P -import Text.PrettyPrint (hsep, parens, punctuate, text, comma) - --- | Renaming applied to the modules provided by a package. --- The boolean indicates whether or not to also include all of the --- original names of modules. Thus, @ModuleRenaming False []@ is --- "don't expose any modules, and @ModuleRenaming True [("Data.Bool", "Bool")]@ --- is, "expose all modules, but also expose @Data.Bool@ as @Bool@". --- If a renaming is omitted you get the 'DefaultRenaming'. --- --- (NB: This is a list not a map so that we can preserve order.) --- -data ModuleRenaming - -- | A module renaming/thinning; e.g., @(A as B, C as C)@ - -- brings @B@ and @C@ into scope. - = ModuleRenaming [(ModuleName, ModuleName)] - -- | The default renaming, bringing all exported modules - -- into scope. - | DefaultRenaming - -- | Hiding renaming, e.g., @hiding (A, B)@, bringing all - -- exported modules into scope except the hidden ones. - | HidingRenaming [ModuleName] - deriving (Show, Read, Eq, Ord, Typeable, Data, Generic) - --- | Interpret a 'ModuleRenaming' as a partial map from 'ModuleName' --- to 'ModuleName'. For efficiency, you should partially apply it --- with 'ModuleRenaming' and then reuse it. -interpModuleRenaming :: ModuleRenaming -> ModuleName -> Maybe ModuleName -interpModuleRenaming DefaultRenaming = Just -interpModuleRenaming (ModuleRenaming rns) = - let m = Map.fromList rns - in \k -> Map.lookup k m -interpModuleRenaming (HidingRenaming hs) = - let s = Set.fromList hs - in \k -> if k `Set.member` s then Nothing else Just k - --- | The default renaming, if something is specified in @build-depends@ --- only. -defaultRenaming :: ModuleRenaming -defaultRenaming = DefaultRenaming - --- | Tests if its the default renaming; we can use a more compact syntax --- in 'Distribution.Types.IncludeRenaming.IncludeRenaming' in this case. -isDefaultRenaming :: ModuleRenaming -> Bool -isDefaultRenaming DefaultRenaming = True -isDefaultRenaming _ = False - - - -instance Binary ModuleRenaming where -instance Structured ModuleRenaming where - -instance NFData ModuleRenaming where rnf = genericRnf - --- NB: parentheses are mandatory, because later we may extend this syntax --- to allow "hiding (A, B)" or other modifier words. -instance Pretty ModuleRenaming where - pretty DefaultRenaming = mempty - pretty (HidingRenaming hides) - = text "hiding" <+> parens (hsep (punctuate comma (map pretty hides))) - pretty (ModuleRenaming rns) - = parens . hsep $ punctuate comma (map dispEntry rns) - where dispEntry (orig, new) - | orig == new = pretty orig - | otherwise = pretty orig <+> text "as" <+> pretty new - -instance Parsec ModuleRenaming where - parsec = do - csv <- askCabalSpecVersion - if csv >= CabalSpecV3_0 - then moduleRenamingParsec parensLax lexemeParsec - else moduleRenamingParsec parensStrict parsec - where - -- For cabal spec versions < 3.0 white spaces were not skipped - -- after the '(' and ')' tokens in the mixin field. This - -- parser checks the cabal file version and does the correct - -- skipping of spaces. - parensLax p = P.between (P.char '(' >> P.spaces) (P.char ')' >> P.spaces) p - parensStrict p = P.between (P.char '(' >> warnSpaces) (P.char ')') p - - warnSpaces = P.optional $ - P.space *> fail "space after parenthesis, use cabal-version: 3.0 or higher" - -moduleRenamingParsec - :: CabalParsing m - => (forall a. m a -> m a) -- ^ between parens - -> m ModuleName -- ^ module name parser - -> m ModuleRenaming -moduleRenamingParsec bp mn = - -- NB: try not necessary as the first token is obvious - P.choice [ parseRename, parseHiding, return DefaultRenaming ] - where - cma = P.char ',' >> P.spaces - parseRename = do - rns <- bp parseList - P.spaces - return (ModuleRenaming rns) - parseHiding = do - _ <- P.string "hiding" - P.spaces -- space isn't strictly required as next is an open paren - hides <- bp (P.sepBy mn cma) - return (HidingRenaming hides) - parseList = - P.sepBy parseEntry cma - parseEntry = do - orig <- parsec - P.spaces - P.option (orig, orig) $ do - _ <- P.string "as" - P.skipSpaces1 -- require space after "as" - new <- parsec - P.spaces - return (orig, new) diff --git a/cabal/Cabal/Distribution/Types/MungedPackageId.hs b/cabal/Cabal/Distribution/Types/MungedPackageId.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/MungedPackageId.hs +++ /dev/null @@ -1,83 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.MungedPackageId - ( MungedPackageId(..) - , computeCompatPackageId - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Types.LibraryName -import Distribution.Types.MungedPackageName -import Distribution.Types.PackageId -import Distribution.Version (Version, nullVersion) - -import qualified Text.PrettyPrint as Disp - --- | A simple pair of a 'MungedPackageName' and 'Version'. 'MungedPackageName' is to --- 'MungedPackageId' as 'PackageName' is to 'PackageId'. See 'MungedPackageName' for more --- info. -data MungedPackageId - = MungedPackageId { - -- | The combined package and component name. see documentation for - -- 'MungedPackageName'. - mungedName :: MungedPackageName, - -- | The version of this package / component, eg 1.2 - mungedVersion :: Version - } - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) - -instance Binary MungedPackageId -instance Structured MungedPackageId - --- | --- --- >>> prettyShow $ MungedPackageId (MungedPackageName "servant" LMainLibName) (mkVersion [1,2,3]) --- "servant-1.2.3" --- --- >>> prettyShow $ MungedPackageId (MungedPackageName "servant" (LSubLibName "lackey")) (mkVersion [0,1,2]) --- "z-servant-z-lackey-0.1.2" --- -instance Pretty MungedPackageId where - pretty (MungedPackageId n v) - | v == nullVersion = pretty n -- if no version, don't show version. - | otherwise = pretty n <<>> Disp.char '-' <<>> pretty v - --- | --- --- >>> simpleParsec "foo-bar-0" :: Maybe MungedPackageId --- Just (MungedPackageId {mungedName = MungedPackageName (PackageName "foo-bar") LMainLibName, mungedVersion = mkVersion [0]}) --- --- >>> simpleParsec "foo-bar" :: Maybe MungedPackageId --- Just (MungedPackageId {mungedName = MungedPackageName (PackageName "foo-bar") LMainLibName, mungedVersion = mkVersion []}) --- --- >>> simpleParsec "z-foo-bar-z-baz-0" :: Maybe MungedPackageId --- Just (MungedPackageId {mungedName = MungedPackageName (PackageName "foo-bar") (LSubLibName (UnqualComponentName "baz")), mungedVersion = mkVersion [0]}) --- --- >>> simpleParsec "foo-bar-0-0" :: Maybe MungedPackageId --- Nothing --- --- >>> simpleParsec "foo-bar.0" :: Maybe MungedPackageId --- Nothing --- --- >>> simpleParsec "foo-bar.4-2" :: Maybe MungedPackageId --- Nothing --- -instance Parsec MungedPackageId where - parsec = do - PackageIdentifier pn v <- parsec - return $ MungedPackageId (decodeCompatPackageName pn) v - -instance NFData MungedPackageId where - rnf (MungedPackageId name version) = rnf name `seq` rnf version - -computeCompatPackageId :: PackageId -> LibraryName -> MungedPackageId -computeCompatPackageId (PackageIdentifier pn vr) ln = - MungedPackageId (MungedPackageName pn ln) vr - --- $setup --- >>> :seti -XOverloadedStrings --- >>> import Distribution.Types.Version diff --git a/cabal/Cabal/Distribution/Types/MungedPackageName.hs b/cabal/Cabal/Distribution/Types/MungedPackageName.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/MungedPackageName.hs +++ /dev/null @@ -1,157 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.MungedPackageName - ( MungedPackageName (..) - , decodeCompatPackageName - , encodeCompatPackageName - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Types.LibraryName -import Distribution.Types.PackageName -import Distribution.Types.UnqualComponentName - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - --- | A combination of a package and component name used in various legacy --- interfaces, chiefly bundled with a version as 'MungedPackageId'. It's generally --- better to use a 'UnitId' to opaquely refer to some compilation/packing unit, --- but that doesn't always work, e.g. where a "name" is needed, in which case --- this can be used as a fallback. --- --- Use 'mkMungedPackageName' and 'unMungedPackageName' to convert from/to a 'String'. --- --- In @3.0.0.0@ representation was changed from opaque (string) to semantic representation. --- --- @since 2.0.0.2 --- -data MungedPackageName = MungedPackageName !PackageName !LibraryName - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) - -instance Binary MungedPackageName -instance Structured MungedPackageName -instance NFData MungedPackageName where rnf = genericRnf - --- | Computes the package name for a library. If this is the public --- library, it will just be the original package name; otherwise, --- it will be a munged package name recording the original package --- name as well as the name of the internal library. --- --- A lot of tooling in the Haskell ecosystem assumes that if something --- is installed to the package database with the package name 'foo', --- then it actually is an entry for the (only public) library in package --- 'foo'. With internal packages, this is not necessarily true: --- a public library as well as arbitrarily many internal libraries may --- come from the same package. To prevent tools from getting confused --- in this case, the package name of these internal libraries is munged --- so that they do not conflict the public library proper. A particular --- case where this matters is ghc-pkg: if we don't munge the package --- name, the inplace registration will OVERRIDE a different internal --- library. --- --- We munge into a reserved namespace, "z-", and encode both the --- component name and the package name of an internal library using the --- following format: --- --- compat-pkg-name ::= "z-" package-name "-z-" library-name --- --- where package-name and library-name have "-" ( "z" + ) "-" --- segments encoded by adding an extra "z". --- --- When we have the public library, the compat-pkg-name is just the --- package-name, no surprises there! --- --- >>> prettyShow $ MungedPackageName "servant" LMainLibName --- "servant" --- --- >>> prettyShow $ MungedPackageName "servant" (LSubLibName "lackey") --- "z-servant-z-lackey" --- -instance Pretty MungedPackageName where - -- First handle the cases where we can just use the original 'PackageName'. - -- This is for the PRIMARY library, and it is non-Backpack, or the - -- indefinite package for us. - pretty = Disp.text . encodeCompatPackageName' - --- | --- --- >>> simpleParsec "servant" :: Maybe MungedPackageName --- Just (MungedPackageName (PackageName "servant") LMainLibName) --- --- >>> simpleParsec "z-servant-z-lackey" :: Maybe MungedPackageName --- Just (MungedPackageName (PackageName "servant") (LSubLibName (UnqualComponentName "lackey"))) --- --- >>> simpleParsec "z-servant-zz" :: Maybe MungedPackageName --- Just (MungedPackageName (PackageName "z-servant-zz") LMainLibName) --- -instance Parsec MungedPackageName where - parsec = decodeCompatPackageName' <$> parsecUnqualComponentName - -------------------------------------------------------------------------------- --- ZDashCode conversions -------------------------------------------------------------------------------- - --- | Intended for internal use only --- --- >>> decodeCompatPackageName "z-servant-z-lackey" --- MungedPackageName (PackageName "servant") (LSubLibName (UnqualComponentName "lackey")) --- -decodeCompatPackageName :: PackageName -> MungedPackageName -decodeCompatPackageName = decodeCompatPackageName' . unPackageName - --- | Intended for internal use only --- --- >>> encodeCompatPackageName $ MungedPackageName "servant" (LSubLibName "lackey") --- PackageName "z-servant-z-lackey" --- --- This is used in @cabal-install@ in the Solver. --- May become obsolete as solver moves to per-component solving. --- -encodeCompatPackageName :: MungedPackageName -> PackageName -encodeCompatPackageName = mkPackageName . encodeCompatPackageName' - -decodeCompatPackageName' :: String -> MungedPackageName -decodeCompatPackageName' m = - case m of - 'z':'-':rest | Right [pn, cn] <- explicitEitherParsec parseZDashCode rest - -> MungedPackageName (mkPackageName pn) (LSubLibName (mkUnqualComponentName cn)) - s -> MungedPackageName (mkPackageName s) LMainLibName - -encodeCompatPackageName' :: MungedPackageName -> String -encodeCompatPackageName' (MungedPackageName pn LMainLibName) = unPackageName pn -encodeCompatPackageName' (MungedPackageName pn (LSubLibName uqn)) = - "z-" ++ zdashcode (unPackageName pn) ++ - "-z-" ++ zdashcode (unUnqualComponentName uqn) - -zdashcode :: String -> String -zdashcode s = go s (Nothing :: Maybe Int) [] - where go [] _ r = reverse r - go ('-':z) (Just n) r | n > 0 = go z (Just 0) ('-':'z':r) - go ('-':z) _ r = go z (Just 0) ('-':r) - go ('z':z) (Just n) r = go z (Just (n+1)) ('z':r) - go (c:z) _ r = go z Nothing (c:r) - -parseZDashCode :: CabalParsing m => m [String] -parseZDashCode = do - ns <- toList <$> P.sepByNonEmpty (some (P.satisfy (/= '-'))) (P.char '-') - return (go ns) - where - go ns = case break (=="z") ns of - (_, []) -> [paste ns] - (as, "z":bs) -> paste as : go bs - _ -> error "parseZDashCode: go" - unZ :: String -> String - unZ "" = error "parseZDashCode: unZ" - unZ r@('z':zs) | all (=='z') zs = zs - | otherwise = r - unZ r = r - paste :: [String] -> String - paste = intercalate "-" . map unZ - --- $setup --- >>> :seti -XOverloadedStrings diff --git a/cabal/Cabal/Distribution/Types/PackageDescription.hs b/cabal/Cabal/Distribution/Types/PackageDescription.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/PackageDescription.hs +++ /dev/null @@ -1,456 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Types.PackageDescription --- Copyright : Isaac Jones 2003-2005 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This defines the data structure for the @.cabal@ file format. There are --- several parts to this structure. It has top level info and then 'Library', --- 'Executable', 'TestSuite', and 'Benchmark' sections each of which have --- associated 'BuildInfo' data that's used to build the library, exe, test, or --- benchmark. To further complicate things there is both a 'PackageDescription' --- and a 'GenericPackageDescription'. This distinction relates to cabal --- configurations. When we initially read a @.cabal@ file we get a --- 'GenericPackageDescription' which has all the conditional sections. --- Before actually building a package we have to decide --- on each conditional. Once we've done that we get a 'PackageDescription'. --- It was done this way initially to avoid breaking too much stuff when the --- feature was introduced. It could probably do with being rationalised at some --- point to make it simpler. - -module Distribution.Types.PackageDescription ( - PackageDescription(..), - license, - license', - buildType, - emptyPackageDescription, - hasPublicLib, - hasLibs, - allLibraries, - withLib, - hasExes, - withExe, - hasTests, - withTest, - hasBenchmarks, - withBenchmark, - hasForeignLibs, - withForeignLib, - allBuildInfo, - enabledBuildInfos, - allBuildDepends, - enabledBuildDepends, - updatePackageDescription, - pkgComponents, - pkgBuildableComponents, - enabledComponents, - lookupComponent, - getComponent, - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Control.Monad ((<=<)) - --- lens -import qualified Distribution.Types.BuildInfo.Lens as L -import Distribution.Types.Library -import Distribution.Types.TestSuite -import Distribution.Types.Executable -import Distribution.Types.Benchmark -import Distribution.Types.ForeignLib - -import Distribution.Types.Component -import Distribution.Types.ComponentRequestedSpec -import Distribution.Types.Dependency -import Distribution.Types.PackageId -import Distribution.Types.ComponentName -import Distribution.Types.PackageName -import Distribution.Types.UnqualComponentName -import Distribution.Types.SetupBuildInfo -import Distribution.Types.BuildInfo -import Distribution.Types.BuildType -import Distribution.Types.SourceRepo -import Distribution.Types.HookedBuildInfo - -import Distribution.CabalSpecVersion -import Distribution.Compiler -import Distribution.License -import Distribution.Package -import Distribution.Version -import Distribution.Utils.ShortText - -import qualified Distribution.SPDX as SPDX - --- ----------------------------------------------------------------------------- --- The PackageDescription type - --- | This data type is the internal representation of the file @pkg.cabal@. --- It contains two kinds of information about the package: information --- which is needed for all packages, such as the package name and version, and --- information which is needed for the simple build system only, such as --- the compiler options and library name. --- -data PackageDescription - = PackageDescription { - -- the following are required by all packages: - - -- | The version of the Cabal spec that this package description uses. - specVersion :: CabalSpecVersion, - package :: PackageIdentifier, - licenseRaw :: Either SPDX.License License, - licenseFiles :: [FilePath], - copyright :: !ShortText, - maintainer :: !ShortText, - author :: !ShortText, - stability :: !ShortText, - testedWith :: [(CompilerFlavor,VersionRange)], - homepage :: !ShortText, - pkgUrl :: !ShortText, - bugReports :: !ShortText, - sourceRepos :: [SourceRepo], - synopsis :: !ShortText, -- ^A one-line summary of this package - description :: !ShortText, -- ^A more verbose description of this package - category :: !ShortText, - customFieldsPD :: [(String,String)], -- ^Custom fields starting - -- with x-, stored in a - -- simple assoc-list. - - -- | The original @build-type@ value as parsed from the - -- @.cabal@ file without defaulting. See also 'buildType'. - -- - -- @since 2.2 - buildTypeRaw :: Maybe BuildType, - setupBuildInfo :: Maybe SetupBuildInfo, - -- components - library :: Maybe Library, - subLibraries :: [Library], - executables :: [Executable], - foreignLibs :: [ForeignLib], - testSuites :: [TestSuite], - benchmarks :: [Benchmark], - -- files - dataFiles :: [FilePath], - dataDir :: FilePath, - extraSrcFiles :: [FilePath], - extraTmpFiles :: [FilePath], - extraDocFiles :: [FilePath] - } - deriving (Generic, Show, Read, Eq, Typeable, Data) - -instance Binary PackageDescription -instance Structured PackageDescription - -instance NFData PackageDescription where rnf = genericRnf - -instance Package PackageDescription where - packageId = package - --- | The SPDX 'LicenseExpression' of the package. --- --- @since 2.2.0.0 -license :: PackageDescription -> SPDX.License -license = license' . licenseRaw - --- | See 'license'. --- --- @since 2.2.0.0 -license' :: Either SPDX.License License -> SPDX.License -license' = either id licenseToSPDX - --- | The effective @build-type@ after applying defaulting rules. --- --- The original @build-type@ value parsed is stored in the --- 'buildTypeRaw' field. However, the @build-type@ field is optional --- and can therefore be empty in which case we need to compute the --- /effective/ @build-type@. This function implements the following --- defaulting rules: --- --- * For @cabal-version:2.0@ and below, default to the @Custom@ --- build-type unconditionally. --- --- * Otherwise, if a @custom-setup@ stanza is defined, default to --- the @Custom@ build-type; else default to @Simple@ build-type. --- --- @since 2.2 -buildType :: PackageDescription -> BuildType -buildType pkg - | specVersion pkg >= CabalSpecV2_2 - = fromMaybe newDefault (buildTypeRaw pkg) - | otherwise -- cabal-version < 2.1 - = fromMaybe Custom (buildTypeRaw pkg) - where - newDefault | isNothing (setupBuildInfo pkg) = Simple - | otherwise = Custom - -emptyPackageDescription :: PackageDescription -emptyPackageDescription - = PackageDescription { - package = PackageIdentifier (mkPackageName "") - nullVersion, - licenseRaw = Right UnspecifiedLicense, -- TODO: - licenseFiles = [], - specVersion = CabalSpecV1_0, - buildTypeRaw = Nothing, - copyright = mempty, - maintainer = mempty, - author = mempty, - stability = mempty, - testedWith = [], - homepage = mempty, - pkgUrl = mempty, - bugReports = mempty, - sourceRepos = [], - synopsis = mempty, - description = mempty, - category = mempty, - customFieldsPD = [], - setupBuildInfo = Nothing, - library = Nothing, - subLibraries = [], - foreignLibs = [], - executables = [], - testSuites = [], - benchmarks = [], - dataFiles = [], - dataDir = "", - extraSrcFiles = [], - extraTmpFiles = [], - extraDocFiles = [] - } - --- --------------------------------------------------------------------------- --- The Library type - --- | Does this package have a buildable PUBLIC library? -hasPublicLib :: PackageDescription -> Bool -hasPublicLib p = - case library p of - Just lib -> buildable (libBuildInfo lib) - Nothing -> False - --- | Does this package have any libraries? -hasLibs :: PackageDescription -> Bool -hasLibs p = any (buildable . libBuildInfo) (allLibraries p) - -allLibraries :: PackageDescription -> [Library] -allLibraries p = maybeToList (library p) ++ subLibraries p - --- | If the package description has a buildable library section, --- call the given function with the library build info as argument. --- You probably want 'withLibLBI' if you have a 'LocalBuildInfo', --- see the note in --- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components" --- for more information. -withLib :: PackageDescription -> (Library -> IO ()) -> IO () -withLib pkg_descr f = - sequence_ [f lib | lib <- allLibraries pkg_descr, buildable (libBuildInfo lib)] - --- --------------------------------------------------------------------------- --- The Executable type - --- |does this package have any executables? -hasExes :: PackageDescription -> Bool -hasExes p = any (buildable . buildInfo) (executables p) - --- | Perform the action on each buildable 'Executable' in the package --- description. You probably want 'withExeLBI' if you have a --- 'LocalBuildInfo', see the note in --- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components" --- for more information. -withExe :: PackageDescription -> (Executable -> IO ()) -> IO () -withExe pkg_descr f = - sequence_ [f exe | exe <- executables pkg_descr, buildable (buildInfo exe)] - --- --------------------------------------------------------------------------- --- The TestSuite type - --- | Does this package have any test suites? -hasTests :: PackageDescription -> Bool -hasTests = any (buildable . testBuildInfo) . testSuites - --- | Perform an action on each buildable 'TestSuite' in a package. --- You probably want 'withTestLBI' if you have a 'LocalBuildInfo', see the note in --- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components" --- for more information. - -withTest :: PackageDescription -> (TestSuite -> IO ()) -> IO () -withTest pkg_descr f = - sequence_ [ f test | test <- testSuites pkg_descr, buildable (testBuildInfo test) ] - --- --------------------------------------------------------------------------- --- The Benchmark type - --- | Does this package have any benchmarks? -hasBenchmarks :: PackageDescription -> Bool -hasBenchmarks = any (buildable . benchmarkBuildInfo) . benchmarks - --- | Perform an action on each buildable 'Benchmark' in a package. --- You probably want 'withBenchLBI' if you have a 'LocalBuildInfo', see the note in --- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components" --- for more information. - -withBenchmark :: PackageDescription -> (Benchmark -> IO ()) -> IO () -withBenchmark pkg_descr f = - sequence_ [f bench | bench <- benchmarks pkg_descr, buildable (benchmarkBuildInfo bench)] - --- --------------------------------------------------------------------------- --- The ForeignLib type - --- | Does this package have any foreign libraries? -hasForeignLibs :: PackageDescription -> Bool -hasForeignLibs p = any (buildable . foreignLibBuildInfo) (foreignLibs p) - --- | Perform the action on each buildable 'ForeignLib' in the package --- description. -withForeignLib :: PackageDescription -> (ForeignLib -> IO ()) -> IO () -withForeignLib pkg_descr f = - sequence_ [ f flib - | flib <- foreignLibs pkg_descr - , buildable (foreignLibBuildInfo flib) - ] - --- --------------------------------------------------------------------------- --- The BuildInfo type - --- | All 'BuildInfo' in the 'PackageDescription': --- libraries, executables, test-suites and benchmarks. --- --- Useful for implementing package checks. -allBuildInfo :: PackageDescription -> [BuildInfo] -allBuildInfo pkg_descr = [ bi | lib <- allLibraries pkg_descr - , let bi = libBuildInfo lib ] - ++ [ bi | flib <- foreignLibs pkg_descr - , let bi = foreignLibBuildInfo flib ] - ++ [ bi | exe <- executables pkg_descr - , let bi = buildInfo exe ] - ++ [ bi | tst <- testSuites pkg_descr - , let bi = testBuildInfo tst ] - ++ [ bi | tst <- benchmarks pkg_descr - , let bi = benchmarkBuildInfo tst ] - --- | Return all of the 'BuildInfo's of enabled components, i.e., all of --- the ones that would be built if you run @./Setup build@. -enabledBuildInfos :: PackageDescription -> ComponentRequestedSpec -> [BuildInfo] -enabledBuildInfos pkg enabled = - [ componentBuildInfo comp - | comp <- enabledComponents pkg enabled ] - - --- ------------------------------------------------------------ --- * Utils --- ------------------------------------------------------------ - --- | Get the combined build-depends entries of all components. -allBuildDepends :: PackageDescription -> [Dependency] -allBuildDepends = targetBuildDepends <=< allBuildInfo - --- | Get the combined build-depends entries of all enabled components, per the --- given request spec. -enabledBuildDepends :: PackageDescription -> ComponentRequestedSpec -> [Dependency] -enabledBuildDepends spec pd = targetBuildDepends =<< enabledBuildInfos spec pd - - -updatePackageDescription :: HookedBuildInfo -> PackageDescription -> PackageDescription -updatePackageDescription (mb_lib_bi, exe_bi) p - = p{ executables = updateExecutables exe_bi (executables p) - , library = updateLibrary mb_lib_bi (library p) } - where - updateLibrary :: Maybe BuildInfo -> Maybe Library -> Maybe Library - updateLibrary (Just bi) (Just lib) = Just (lib{libBuildInfo = bi `mappend` libBuildInfo lib}) - updateLibrary Nothing mb_lib = mb_lib - updateLibrary (Just _) Nothing = Nothing - - updateExecutables :: [(UnqualComponentName, BuildInfo)] -- ^[(exeName, new buildinfo)] - -> [Executable] -- ^list of executables to update - -> [Executable] -- ^list with exeNames updated - updateExecutables exe_bi' executables' = foldr updateExecutable executables' exe_bi' - - updateExecutable :: (UnqualComponentName, BuildInfo) -- ^(exeName, new buildinfo) - -> [Executable] -- ^list of executables to update - -> [Executable] -- ^list with exeName updated - updateExecutable _ [] = [] - updateExecutable exe_bi'@(name,bi) (exe:exes) - | exeName exe == name = exe{buildInfo = bi `mappend` buildInfo exe} : exes - | otherwise = exe : updateExecutable exe_bi' exes - --- ----------------------------------------------------------------------------- --- Source-representation of buildable components - --- | All the components in the package. --- -pkgComponents :: PackageDescription -> [Component] -pkgComponents pkg = - [ CLib lib | lib <- allLibraries pkg ] - ++ [ CFLib flib | flib <- foreignLibs pkg ] - ++ [ CExe exe | exe <- executables pkg ] - ++ [ CTest tst | tst <- testSuites pkg ] - ++ [ CBench bm | bm <- benchmarks pkg ] - --- | A list of all components in the package that are buildable, --- i.e., were not marked with @buildable: False@. This does NOT --- indicate if we are actually going to build the component, --- see 'enabledComponents' instead. --- --- @since 2.0.0.2 --- -pkgBuildableComponents :: PackageDescription -> [Component] -pkgBuildableComponents = filter componentBuildable . pkgComponents - --- | A list of all components in the package that are enabled. --- --- @since 2.0.0.2 --- -enabledComponents :: PackageDescription -> ComponentRequestedSpec -> [Component] -enabledComponents pkg enabled = filter (componentEnabled enabled) $ pkgBuildableComponents pkg - -lookupComponent :: PackageDescription -> ComponentName -> Maybe Component -lookupComponent pkg (CLibName name) = - fmap CLib $ find ((name ==) . libName) (allLibraries pkg) -lookupComponent pkg (CFLibName name) = - fmap CFLib $ find ((name ==) . foreignLibName) (foreignLibs pkg) -lookupComponent pkg (CExeName name) = - fmap CExe $ find ((name ==) . exeName) (executables pkg) -lookupComponent pkg (CTestName name) = - fmap CTest $ find ((name ==) . testName) (testSuites pkg) -lookupComponent pkg (CBenchName name) = - fmap CBench $ find ((name ==) . benchmarkName) (benchmarks pkg) - -getComponent :: PackageDescription -> ComponentName -> Component -getComponent pkg cname = - case lookupComponent pkg cname of - Just cpnt -> cpnt - Nothing -> missingComponent - where - missingComponent = - error $ "internal error: the package description contains no " - ++ "component corresponding to " ++ show cname - --- ----------------------------------------------------------------------------- --- Traversal Instances - -instance L.HasBuildInfos PackageDescription where - traverseBuildInfos f (PackageDescription a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 - x1 x2 x3 x4 x5 x6 - a20 a21 a22 a23 a24) = - PackageDescription a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 - <$> (traverse . L.buildInfo) f x1 -- library - <*> (traverse . L.buildInfo) f x2 -- sub libraries - <*> (traverse . L.buildInfo) f x3 -- executables - <*> (traverse . L.buildInfo) f x4 -- foreign libs - <*> (traverse . L.buildInfo) f x5 -- test suites - <*> (traverse . L.buildInfo) f x6 -- benchmarks - <*> pure a20 -- data files - <*> pure a21 -- data dir - <*> pure a22 -- extra src files - <*> pure a23 -- extra temp files - <*> pure a24 -- extra doc files diff --git a/cabal/Cabal/Distribution/Types/PackageDescription/Lens.hs b/cabal/Cabal/Distribution/Types/PackageDescription/Lens.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/PackageDescription/Lens.hs +++ /dev/null @@ -1,220 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -module Distribution.Types.PackageDescription.Lens ( - PackageDescription, - module Distribution.Types.PackageDescription.Lens, - ) where - -import Distribution.Compat.Lens -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.CabalSpecVersion (CabalSpecVersion) -import Distribution.Compiler (CompilerFlavor) -import Distribution.License (License) -import Distribution.ModuleName (ModuleName) -import Distribution.Types.Benchmark (Benchmark, benchmarkModules) -import Distribution.Types.Benchmark.Lens (benchmarkBuildInfo, benchmarkName) -import Distribution.Types.BuildInfo (BuildInfo) -import Distribution.Types.BuildType (BuildType) -import Distribution.Types.ComponentName (ComponentName (..)) -import Distribution.Types.Executable (Executable, exeModules) -import Distribution.Types.Executable.Lens (exeBuildInfo, exeName) -import Distribution.Types.ForeignLib (ForeignLib, foreignLibModules) -import Distribution.Types.ForeignLib.Lens (foreignLibBuildInfo, foreignLibName) -import Distribution.Types.Library (Library, explicitLibModules) -import Distribution.Types.Library.Lens (libBuildInfo, libName) -import Distribution.Types.PackageDescription (PackageDescription) -import Distribution.Types.PackageId (PackageIdentifier) -import Distribution.Types.SetupBuildInfo (SetupBuildInfo) -import Distribution.Types.SourceRepo (SourceRepo) -import Distribution.Types.TestSuite (TestSuite, testModules) -import Distribution.Types.TestSuite.Lens (testBuildInfo, testName) -import Distribution.Utils.ShortText (ShortText) -import Distribution.Version (VersionRange) - -import qualified Distribution.SPDX as SPDX -import qualified Distribution.Types.PackageDescription as T - -package :: Lens' PackageDescription PackageIdentifier -package f s = fmap (\x -> s { T.package = x }) (f (T.package s)) -{-# INLINE package #-} - -licenseRaw :: Lens' PackageDescription (Either SPDX.License License) -licenseRaw f s = fmap (\x -> s { T.licenseRaw = x }) (f (T.licenseRaw s)) -{-# INLINE licenseRaw #-} - -licenseFiles :: Lens' PackageDescription [FilePath] -licenseFiles f s = fmap (\x -> s { T.licenseFiles = x }) (f (T.licenseFiles s)) -{-# INLINE licenseFiles #-} - -copyright :: Lens' PackageDescription ShortText -copyright f s = fmap (\x -> s { T.copyright = x }) (f (T.copyright s)) -{-# INLINE copyright #-} - -maintainer :: Lens' PackageDescription ShortText -maintainer f s = fmap (\x -> s { T.maintainer = x }) (f (T.maintainer s)) -{-# INLINE maintainer #-} - -author :: Lens' PackageDescription ShortText -author f s = fmap (\x -> s { T.author = x }) (f (T.author s)) -{-# INLINE author #-} - -stability :: Lens' PackageDescription ShortText -stability f s = fmap (\x -> s { T.stability = x }) (f (T.stability s)) -{-# INLINE stability #-} - -testedWith :: Lens' PackageDescription [(CompilerFlavor,VersionRange)] -testedWith f s = fmap (\x -> s { T.testedWith = x }) (f (T.testedWith s)) -{-# INLINE testedWith #-} - -homepage :: Lens' PackageDescription ShortText -homepage f s = fmap (\x -> s { T.homepage = x }) (f (T.homepage s)) -{-# INLINE homepage #-} - -pkgUrl :: Lens' PackageDescription ShortText -pkgUrl f s = fmap (\x -> s { T.pkgUrl = x }) (f (T.pkgUrl s)) -{-# INLINE pkgUrl #-} - -bugReports :: Lens' PackageDescription ShortText -bugReports f s = fmap (\x -> s { T.bugReports = x }) (f (T.bugReports s)) -{-# INLINE bugReports #-} - -sourceRepos :: Lens' PackageDescription [SourceRepo] -sourceRepos f s = fmap (\x -> s { T.sourceRepos = x }) (f (T.sourceRepos s)) -{-# INLINE sourceRepos #-} - -synopsis :: Lens' PackageDescription ShortText -synopsis f s = fmap (\x -> s { T.synopsis = x }) (f (T.synopsis s)) -{-# INLINE synopsis #-} - -description :: Lens' PackageDescription ShortText -description f s = fmap (\x -> s { T.description = x }) (f (T.description s)) -{-# INLINE description #-} - -category :: Lens' PackageDescription ShortText -category f s = fmap (\x -> s { T.category = x }) (f (T.category s)) -{-# INLINE category #-} - -customFieldsPD :: Lens' PackageDescription [(String,String)] -customFieldsPD f s = fmap (\x -> s { T.customFieldsPD = x }) (f (T.customFieldsPD s)) -{-# INLINE customFieldsPD #-} - -specVersion :: Lens' PackageDescription CabalSpecVersion -specVersion f s = fmap (\x -> s { T.specVersion = x }) (f (T.specVersion s)) -{-# INLINE specVersion #-} - -buildTypeRaw :: Lens' PackageDescription (Maybe BuildType) -buildTypeRaw f s = fmap (\x -> s { T.buildTypeRaw = x }) (f (T.buildTypeRaw s)) -{-# INLINE buildTypeRaw #-} - -setupBuildInfo :: Lens' PackageDescription (Maybe SetupBuildInfo) -setupBuildInfo f s = fmap (\x -> s { T.setupBuildInfo = x }) (f (T.setupBuildInfo s)) -{-# INLINE setupBuildInfo #-} - -library :: Lens' PackageDescription (Maybe Library) -library f s = fmap (\x -> s { T.library = x }) (f (T.library s)) -{-# INLINE library #-} - -subLibraries :: Lens' PackageDescription [Library] -subLibraries f s = fmap (\x -> s { T.subLibraries = x }) (f (T.subLibraries s)) -{-# INLINE subLibraries #-} - -executables :: Lens' PackageDescription [Executable] -executables f s = fmap (\x -> s { T.executables = x }) (f (T.executables s)) -{-# INLINE executables #-} - -foreignLibs :: Lens' PackageDescription [ForeignLib] -foreignLibs f s = fmap (\x -> s { T.foreignLibs = x }) (f (T.foreignLibs s)) -{-# INLINE foreignLibs #-} - -testSuites :: Lens' PackageDescription [TestSuite] -testSuites f s = fmap (\x -> s { T.testSuites = x }) (f (T.testSuites s)) -{-# INLINE testSuites #-} - -benchmarks :: Lens' PackageDescription [Benchmark] -benchmarks f s = fmap (\x -> s { T.benchmarks = x }) (f (T.benchmarks s)) -{-# INLINE benchmarks #-} - -dataFiles :: Lens' PackageDescription [FilePath] -dataFiles f s = fmap (\x -> s { T.dataFiles = x }) (f (T.dataFiles s)) -{-# INLINE dataFiles #-} - -dataDir :: Lens' PackageDescription FilePath -dataDir f s = fmap (\x -> s { T.dataDir = x }) (f (T.dataDir s)) -{-# INLINE dataDir #-} - -extraSrcFiles :: Lens' PackageDescription [String] -extraSrcFiles f s = fmap (\x -> s { T.extraSrcFiles = x }) (f (T.extraSrcFiles s)) -{-# INLINE extraSrcFiles #-} - -extraTmpFiles :: Lens' PackageDescription [String] -extraTmpFiles f s = fmap (\x -> s { T.extraTmpFiles = x }) (f (T.extraTmpFiles s)) -{-# INLINE extraTmpFiles #-} - -extraDocFiles :: Lens' PackageDescription [String] -extraDocFiles f s = fmap (\x -> s { T.extraDocFiles = x }) (f (T.extraDocFiles s)) -{-# INLINE extraDocFiles #-} - --- | @since 3.0.0.0 -allLibraries :: Traversal' PackageDescription Library -allLibraries f pd = mk <$> traverse f (T.library pd) <*> traverse f (T.subLibraries pd) - where - mk l ls = pd { T.library = l, T.subLibraries = ls } - --- | @since 2.4 -componentModules :: Monoid r => ComponentName -> Getting r PackageDescription [ModuleName] -componentModules cname = case cname of - CLibName name -> - componentModules' name allLibraries libName explicitLibModules - CFLibName name -> - componentModules' name (foreignLibs . traverse) foreignLibName foreignLibModules - CExeName name -> - componentModules' name (executables . traverse) exeName exeModules - CTestName name -> - componentModules' name (testSuites . traverse) testName testModules - CBenchName name -> - componentModules' name (benchmarks . traverse) benchmarkName benchmarkModules - where - componentModules' - :: (Eq name, Monoid r) - => name - -> Traversal' PackageDescription a - -> Lens' a name - -> (a -> [ModuleName]) - -> Getting r PackageDescription [ModuleName] - componentModules' name pdL nameL modules = - pdL - . filtered ((== name) . view nameL) - . getting modules - - filtered :: (a -> Bool) -> Traversal' a a - filtered p f s = if p s then f s else pure s - --- | @since 2.4 -componentBuildInfo :: ComponentName -> Traversal' PackageDescription BuildInfo -componentBuildInfo cname = case cname of - CLibName name -> - componentBuildInfo' name allLibraries libName libBuildInfo - CFLibName name -> - componentBuildInfo' name (foreignLibs . traverse) foreignLibName foreignLibBuildInfo - CExeName name -> - componentBuildInfo' name (executables . traverse) exeName exeBuildInfo - CTestName name -> - componentBuildInfo' name (testSuites . traverse) testName testBuildInfo - CBenchName name -> - componentBuildInfo' name (benchmarks . traverse) benchmarkName benchmarkBuildInfo - where - componentBuildInfo' :: Eq name - => name - -> Traversal' PackageDescription a - -> Lens' a name - -> Traversal' a BuildInfo - -> Traversal' PackageDescription BuildInfo - componentBuildInfo' name pdL nameL biL = - pdL - . filtered ((== name) . view nameL) - . biL - - filtered :: (a -> Bool) -> Traversal' a a - filtered p f s = if p s then f s else pure s diff --git a/cabal/Cabal/Distribution/Types/PackageId.hs b/cabal/Cabal/Distribution/Types/PackageId.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/PackageId.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.PackageId - ( PackageIdentifier(..) - , PackageId - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Parsec (Parsec (..), simpleParsec) -import Distribution.Pretty -import Distribution.Types.PackageName -import Distribution.Version (Version, nullVersion) - -import qualified Data.List.NonEmpty as NE -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - --- | Type alias so we can use the shorter name PackageId. -type PackageId = PackageIdentifier - --- | The name and version of a package. -data PackageIdentifier - = PackageIdentifier { - pkgName :: PackageName, -- ^The name of this package, eg. foo - pkgVersion :: Version -- ^the version of this package, eg 1.2 - } - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) - -instance Binary PackageIdentifier -instance Structured PackageIdentifier - -instance Pretty PackageIdentifier where - pretty (PackageIdentifier n v) - | v == nullVersion = pretty n -- if no version, don't show version. - | otherwise = pretty n <<>> Disp.char '-' <<>> pretty v - --- | --- --- >>> simpleParsec "foo-bar-0" :: Maybe PackageIdentifier --- Just (PackageIdentifier {pkgName = PackageName "foo-bar", pkgVersion = mkVersion [0]}) --- --- >>> simpleParsec "foo-bar" :: Maybe PackageIdentifier --- Just (PackageIdentifier {pkgName = PackageName "foo-bar", pkgVersion = mkVersion []}) --- --- /Note:/ Stricter than 'Text' instance --- --- >>> simpleParsec "foo-bar-0-0" :: Maybe PackageIdentifier --- Nothing --- --- >>> simpleParsec "foo-bar.0" :: Maybe PackageIdentifier --- Nothing --- --- >>> simpleParsec "foo-bar.4-2" :: Maybe PackageIdentifier --- Nothing --- --- >>> simpleParsec "1.2.3" :: Maybe PackageIdentifier --- Nothing --- -instance Parsec PackageIdentifier where - parsec = do - xs' <- P.sepByNonEmpty component (P.char '-') - (v, xs) <- case simpleParsec (NE.last xs') of - Nothing -> return (nullVersion, toList xs') -- all components are version - Just v -> return (v, NE.init xs') - if not (null xs) && all (\c -> all (/= '.') c && not (all isDigit c)) xs - then return $ PackageIdentifier (mkPackageName (intercalate "-" xs)) v - else fail "all digits or a dot in a portion of package name" - where - component = P.munch1 (\c -> isAlphaNum c || c == '.') - -instance NFData PackageIdentifier where - rnf (PackageIdentifier name version) = rnf name `seq` rnf version diff --git a/cabal/Cabal/Distribution/Types/PackageId/Lens.hs b/cabal/Cabal/Distribution/Types/PackageId/Lens.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/PackageId/Lens.hs +++ /dev/null @@ -1,22 +0,0 @@ -module Distribution.Types.PackageId.Lens ( - PackageIdentifier, - module Distribution.Types.PackageId.Lens, - ) where - -import Distribution.Compat.Lens -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Types.PackageId (PackageIdentifier) -import Distribution.Types.PackageName (PackageName) -import Distribution.Version (Version) - -import qualified Distribution.Types.PackageId as T - -pkgName :: Lens' PackageIdentifier PackageName -pkgName f s = fmap (\x -> s { T.pkgName = x }) (f (T.pkgName s)) -{-# INLINE pkgName #-} - -pkgVersion :: Lens' PackageIdentifier Version -pkgVersion f s = fmap (\x -> s { T.pkgVersion = x }) (f (T.pkgVersion s)) -{-# INLINE pkgVersion #-} diff --git a/cabal/Cabal/Distribution/Types/PackageName.hs b/cabal/Cabal/Distribution/Types/PackageName.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/PackageName.hs +++ /dev/null @@ -1,73 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.PackageName - ( PackageName - , unPackageName, mkPackageName - , unPackageNameST, mkPackageNameST - ) where - -import Prelude () -import Distribution.Compat.Prelude -import Distribution.Utils.ShortText - -import qualified Text.PrettyPrint as Disp -import Distribution.Pretty -import Distribution.Parsec - --- | A package name. --- --- Use 'mkPackageName' and 'unPackageName' to convert from/to a --- 'String'. --- --- This type is opaque since @Cabal-2.0@ --- --- @since 2.0.0.2 -newtype PackageName = PackageName ShortText - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) - --- | Convert 'PackageName' to 'String' -unPackageName :: PackageName -> String -unPackageName (PackageName s) = fromShortText s - --- | @since 3.4.0.0 -unPackageNameST :: PackageName -> ShortText -unPackageNameST (PackageName s) = s - --- | Construct a 'PackageName' from a 'String' --- --- 'mkPackageName' is the inverse to 'unPackageName' --- --- Note: No validations are performed to ensure that the resulting --- 'PackageName' is valid --- --- @since 2.0.0.2 -mkPackageName :: String -> PackageName -mkPackageName = PackageName . toShortText - --- | Construct a 'PackageName' from a 'ShortText' --- --- Note: No validations are performed to ensure that the resulting --- 'PackageName' is valid --- --- @since 3.4.0.0 -mkPackageNameST :: ShortText -> PackageName -mkPackageNameST = PackageName - --- | 'mkPackageName' --- --- @since 2.0.0.2 -instance IsString PackageName where - fromString = mkPackageName - -instance Binary PackageName -instance Structured PackageName - -instance Pretty PackageName where - pretty = Disp.text . unPackageName - -instance Parsec PackageName where - parsec = mkPackageName <$> parsecUnqualComponentName - -instance NFData PackageName where - rnf (PackageName pkg) = rnf pkg diff --git a/cabal/Cabal/Distribution/Types/PackageName/Magic.hs b/cabal/Cabal/Distribution/Types/PackageName/Magic.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/PackageName/Magic.hs +++ /dev/null @@ -1,20 +0,0 @@ --- | Magic 'PackageName's. --- --- @since 3.0.0.0 -module Distribution.Types.PackageName.Magic where - -import Distribution.Types.PackageId -import Distribution.Types.PackageName -import Distribution.Types.Version - --- | Used as a placeholder in "Distribution.Backpack.ReadyComponent" -nonExistentPackageThisIsCabalBug :: PackageName -nonExistentPackageThisIsCabalBug = mkPackageName "nonexistent-package-this-is-a-cabal-bug" - --- | Used by @cabal new-repl@ and @cabal new-run@ -fakePackageName :: PackageName -fakePackageName = mkPackageName "fake-package" - --- | 'fakePackageName' with 'version0'. -fakePackageId :: PackageId -fakePackageId = PackageIdentifier fakePackageName version0 diff --git a/cabal/Cabal/Distribution/Types/PackageVersionConstraint.hs b/cabal/Cabal/Distribution/Types/PackageVersionConstraint.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/PackageVersionConstraint.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.PackageVersionConstraint ( - PackageVersionConstraint(..), - thisPackageVersionConstraint, - simplifyPackageVersionConstraint, -) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Types.PackageId -import Distribution.Types.PackageName -import Distribution.Types.Version -import Distribution.Types.VersionRange.Internal -import Distribution.Version (simplifyVersionRange) - -import qualified Distribution.Compat.CharParsing as P - --- | A version constraint on a package. Different from 'ExeDependency' and --- 'Dependency' since it does not specify the need for a component, not even --- the main library. --- There are a few places in the codebase where 'Dependency' was used where --- 'PackageVersionConstraint' is not used instead (#5570). -data PackageVersionConstraint = PackageVersionConstraint PackageName VersionRange - deriving (Generic, Read, Show, Eq, Typeable, Data) - -instance Binary PackageVersionConstraint -instance Structured PackageVersionConstraint -instance NFData PackageVersionConstraint where rnf = genericRnf - -instance Pretty PackageVersionConstraint where - -- Cannot do: PackageVersionConstraint have to be parseable - -- as Dependency, due roundtrip problems. (e.g. talking to old ./Setup). - -- - -- pretty (PackageVersionConstraint name (ThisVersion ver)) = - -- pretty (PackageIdentifier name ver) - pretty (PackageVersionConstraint name ver) = - pretty name <+> pretty ver - --- | --- --- >>> simpleParsec "foo" :: Maybe PackageVersionConstraint --- Just (PackageVersionConstraint (PackageName "foo") (OrLaterVersion (mkVersion [0]))) --- --- >>> simpleParsec "foo >=2.0" :: Maybe PackageVersionConstraint --- Just (PackageVersionConstraint (PackageName "foo") (OrLaterVersion (mkVersion [2,0]))) --- --- >>> simpleParsec "foo-2.0" :: Maybe PackageVersionConstraint --- Just (PackageVersionConstraint (PackageName "foo") (ThisVersion (mkVersion [2,0]))) --- -instance Parsec PackageVersionConstraint where - parsec = do - PackageIdentifier name ver <- parsec - if ver == nullVersion - then do - P.spaces - vr <- parsec <|> return anyVersion - P.spaces - return (PackageVersionConstraint name vr) - else - pure (PackageVersionConstraint name (thisVersion ver)) - --- | @since 3.4.0.0 -thisPackageVersionConstraint :: PackageIdentifier -> PackageVersionConstraint -thisPackageVersionConstraint (PackageIdentifier pn vr) = - PackageVersionConstraint pn (thisVersion vr) - --- | @since 3.4.0.0 -simplifyPackageVersionConstraint :: PackageVersionConstraint -> PackageVersionConstraint -simplifyPackageVersionConstraint (PackageVersionConstraint pn vr) = - PackageVersionConstraint pn (simplifyVersionRange vr) diff --git a/cabal/Cabal/Distribution/Types/PkgconfigDependency.hs b/cabal/Cabal/Distribution/Types/PkgconfigDependency.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/PkgconfigDependency.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.PkgconfigDependency - ( PkgconfigDependency(..) - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Types.PkgconfigName -import Distribution.Types.PkgconfigVersionRange - -import Distribution.Parsec -import Distribution.Pretty - -import qualified Distribution.Compat.CharParsing as P - --- | Describes a dependency on a pkg-config library --- --- @since 2.0.0.2 -data PkgconfigDependency = PkgconfigDependency - PkgconfigName - PkgconfigVersionRange - deriving (Generic, Read, Show, Eq, Typeable, Data) - -instance Binary PkgconfigDependency -instance Structured PkgconfigDependency -instance NFData PkgconfigDependency where rnf = genericRnf - -instance Pretty PkgconfigDependency where - pretty (PkgconfigDependency name PcAnyVersion) = pretty name - pretty (PkgconfigDependency name ver) = pretty name <+> pretty ver - -instance Parsec PkgconfigDependency where - parsec = do - name <- parsec - P.spaces - verRange <- parsec <|> pure anyPkgconfigVersion - pure $ PkgconfigDependency name verRange diff --git a/cabal/Cabal/Distribution/Types/PkgconfigName.hs b/cabal/Cabal/Distribution/Types/PkgconfigName.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/PkgconfigName.hs +++ /dev/null @@ -1,68 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.PkgconfigName - ( PkgconfigName, unPkgconfigName, mkPkgconfigName - ) where - -import Prelude () -import Distribution.Compat.Prelude -import Distribution.Utils.ShortText - -import Distribution.Pretty -import Distribution.Parsec - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - --- | A pkg-config library name --- --- This is parsed as any valid argument to the pkg-config utility. --- --- @since 2.0.0.2 -newtype PkgconfigName = PkgconfigName ShortText - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) - --- | Convert 'PkgconfigName' to 'String' --- --- @since 2.0.0.2 -unPkgconfigName :: PkgconfigName -> String -unPkgconfigName (PkgconfigName s) = fromShortText s - --- | Construct a 'PkgconfigName' from a 'String' --- --- 'mkPkgconfigName' is the inverse to 'unPkgconfigName' --- --- Note: No validations are performed to ensure that the resulting --- 'PkgconfigName' is valid --- --- @since 2.0.0.2 -mkPkgconfigName :: String -> PkgconfigName -mkPkgconfigName = PkgconfigName . toShortText - --- | 'mkPkgconfigName' --- --- @since 2.0.0.2 -instance IsString PkgconfigName where - fromString = mkPkgconfigName - -instance Binary PkgconfigName -instance Structured PkgconfigName - --- pkg-config allows versions and other letters in package names, eg --- "gtk+-2.0" is a valid pkg-config package _name_. It then has a package --- version number like 2.10.13 -instance Pretty PkgconfigName where - pretty = Disp.text . unPkgconfigName - -instance Parsec PkgconfigName where - parsec = mkPkgconfigName <$> P.munch1 isNameChar where - -- https://gitlab.haskell.org/ghc/ghc/issues/17752 - isNameChar '-' = True - isNameChar '_' = True - isNameChar '.' = True - isNameChar '+' = True - isNameChar c = isAlphaNum c - -instance NFData PkgconfigName where - rnf (PkgconfigName pkg) = rnf pkg diff --git a/cabal/Cabal/Distribution/Types/PkgconfigVersion.hs b/cabal/Cabal/Distribution/Types/PkgconfigVersion.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/PkgconfigVersion.hs +++ /dev/null @@ -1,119 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} --- @since 3.0 -module Distribution.Types.PkgconfigVersion ( - PkgconfigVersion (..), - rpmvercmp, - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Utils.Generic (isAsciiAlphaNum) - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BS8 -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as PP - --- | @pkg-config@ versions. --- --- In fact, this can be arbitrary 'BS.ByteString', --- but 'Parsec' instance is a little pickier. --- --- @since 3.0 -newtype PkgconfigVersion = PkgconfigVersion BS.ByteString - deriving (Generic, Read, Show, Typeable, Data) - -instance Eq PkgconfigVersion where - PkgconfigVersion a == PkgconfigVersion b = rpmvercmp a b == EQ - -instance Ord PkgconfigVersion where - PkgconfigVersion a `compare` PkgconfigVersion b = rpmvercmp a b - -instance Binary PkgconfigVersion -instance Structured PkgconfigVersion -instance NFData PkgconfigVersion where rnf = genericRnf - -instance Pretty PkgconfigVersion where - pretty (PkgconfigVersion bs) = PP.text (BS8.unpack bs) - --- | --- --- >>> simpleParsec "1.0.2n" :: Maybe PkgconfigVersion --- Just (PkgconfigVersion "1.0.2n") --- --- >>> simpleParsec "0.3.5+ds" :: Maybe PkgconfigVersion --- Nothing --- -instance Parsec PkgconfigVersion where - parsec = PkgconfigVersion . BS8.pack <$> P.munch1 predicate where - predicate c = isAsciiAlphaNum c || c == '.' || c == '-' - -------------------------------------------------------------------------------- --- rmpvercmp - pure Haskell implementation -------------------------------------------------------------------------------- - --- | Compare two version strings as @pkg-config@ would compare them. --- --- @since 3.0 -rpmvercmp :: BS.ByteString -> BS.ByteString -> Ordering -rpmvercmp a b = go0 (BS.unpack a) (BS.unpack b) - where - go0 :: [Word8] -> [Word8] -> Ordering - -- if there is _any_ trailing "garbage", it seems to affect result - -- https://github.com/haskell/cabal/issues/6805 - go0 [] [] = EQ - go0 [] _ = LT - go0 _ [] = GT - go0 xs ys = go1 (dropNonAlnum8 xs) (dropNonAlnum8 ys) - - go1 :: [Word8] -> [Word8] -> Ordering - go1 [] [] = EQ - go1 [] _ = LT - go1 _ [] = GT - go1 xs@(x:_) ys - | isDigit8 x = - let (xs1, xs2) = span isDigit8 xs - (ys1, ys2) = span isDigit8 ys - -- numeric segments are always newer than alpha segments - in if null ys1 - then GT - else compareInt xs1 ys1 <> go0 xs2 ys2 - - -- isAlpha - | otherwise = - let (xs1, xs2) = span isAlpha8 xs - (ys1, ys2) = span isAlpha8 ys - in if null ys1 - then LT - else compareStr xs1 ys1 <> go0 xs2 ys2 - --- compare as numbers -compareInt :: [Word8] -> [Word8] -> Ordering -compareInt xs ys = - -- whichever number has more digits wins - compare (length xs') (length ys') <> - -- equal length: use per character compare, "strcmp" - compare xs' ys' - where - -- drop leading zeros - xs' = dropWhile (== 0x30) xs - ys' = dropWhile (== 0x30) ys - --- strcmp -compareStr :: [Word8] -> [Word8] -> Ordering -compareStr = compare - -dropNonAlnum8 :: [Word8] -> [Word8] -dropNonAlnum8 = dropWhile (\w -> not (isDigit8 w || isAlpha8 w)) - -isDigit8 :: Word8 -> Bool -isDigit8 w = 0x30 <= w && w <= 0x39 - -isAlpha8 :: Word8 -> Bool -isAlpha8 w = (0x41 <= w && w <= 0x5A) || (0x61 <= w && w <= 0x7A) - - diff --git a/cabal/Cabal/Distribution/Types/PkgconfigVersionRange.hs b/cabal/Cabal/Distribution/Types/PkgconfigVersionRange.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/PkgconfigVersionRange.hs +++ /dev/null @@ -1,161 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.PkgconfigVersionRange ( - PkgconfigVersionRange (..), - anyPkgconfigVersion, - isAnyPkgconfigVersion, - withinPkgconfigVersionRange, - -- * Internal - versionToPkgconfigVersion, - versionRangeToPkgconfigVersionRange, - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.CabalSpecVersion -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Types.PkgconfigVersion -import Distribution.Types.Version -import Distribution.Types.VersionInterval -import Distribution.Types.VersionRange - -import qualified Data.ByteString.Char8 as BS8 -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as PP - --- | @since 3.0 -data PkgconfigVersionRange - = PcAnyVersion - | PcThisVersion PkgconfigVersion -- = version - | PcLaterVersion PkgconfigVersion -- > version (NB. not >=) - | PcEarlierVersion PkgconfigVersion -- < version - | PcOrLaterVersion PkgconfigVersion -- >= version - | PcOrEarlierVersion PkgconfigVersion -- =< version - | PcUnionVersionRanges PkgconfigVersionRange PkgconfigVersionRange - | PcIntersectVersionRanges PkgconfigVersionRange PkgconfigVersionRange - deriving (Generic, Read, Show, Eq, Typeable, Data) - -instance Binary PkgconfigVersionRange -instance Structured PkgconfigVersionRange -instance NFData PkgconfigVersionRange where rnf = genericRnf - -instance Pretty PkgconfigVersionRange where - pretty = pp 0 where - pp :: Int -> PkgconfigVersionRange -> PP.Doc - pp _ PcAnyVersion = PP.text "-any" - pp _ (PcThisVersion v) = PP.text "==" <<>> pretty v - pp _ (PcLaterVersion v) = PP.text ">" <<>> pretty v - pp _ (PcEarlierVersion v) = PP.text "<" <<>> pretty v - pp _ (PcOrLaterVersion v) = PP.text ">=" <<>> pretty v - pp _ (PcOrEarlierVersion v) = PP.text "<=" <<>> pretty v - - pp d (PcUnionVersionRanges v u) = parens (d >= 1) $ - pp 1 v PP.<+> PP.text "||" PP.<+> pp 0 u - pp d (PcIntersectVersionRanges v u) = parens (d >= 2) $ - pp 2 v PP.<+> PP.text "&&" PP.<+> pp 1 u - - parens True = PP.parens - parens False = id - -instance Parsec PkgconfigVersionRange where - -- note: the wildcard is used in some places, e.g - -- http://hackage.haskell.org/package/bindings-libzip-0.10.1/bindings-libzip.cabal - -- - -- however, in the presence of alphanumerics etc. lax version parser, - -- wildcard is ill-specified - - parsec = do - csv <- askCabalSpecVersion - if csv >= CabalSpecV3_0 - then pkgconfigParser - else versionRangeToPkgconfigVersionRange <$> versionRangeParser P.integral csv - --- "modern" parser of @pkg-config@ package versions. -pkgconfigParser :: CabalParsing m => m PkgconfigVersionRange -pkgconfigParser = P.spaces >> expr where - -- every parser here eats trailing space - expr = do - ts <- term `P.sepByNonEmpty` (P.string "||" >> P.spaces) - return $ foldr1 PcUnionVersionRanges ts - - term = do - fs <- factor `P.sepByNonEmpty` (P.string "&&" >> P.spaces) - return $ foldr1 PcIntersectVersionRanges fs - - factor = parens expr <|> prim - - prim = do - op <- P.munch1 isOpChar P. "operator" - case op of - "-" -> anyPkgconfigVersion <$ (P.string "any" *> P.spaces) - - "==" -> afterOp PcThisVersion - ">" -> afterOp PcLaterVersion - "<" -> afterOp PcEarlierVersion - ">=" -> afterOp PcOrLaterVersion - "<=" -> afterOp PcOrEarlierVersion - - _ -> P.unexpected $ "Unknown version operator " ++ show op - - -- https://gitlab.haskell.org/ghc/ghc/issues/17752 - isOpChar '<' = True - isOpChar '=' = True - isOpChar '>' = True - isOpChar '^' = True - isOpChar '-' = True - isOpChar _ = False - - afterOp f = do - P.spaces - v <- parsec - P.spaces - return (f v) - - parens = P.between - ((P.char '(' P. "opening paren") >> P.spaces) - (P.char ')' >> P.spaces) - -anyPkgconfigVersion :: PkgconfigVersionRange -anyPkgconfigVersion = PcAnyVersion - --- | TODO: this is not precise, but used only to prettify output. -isAnyPkgconfigVersion :: PkgconfigVersionRange -> Bool -isAnyPkgconfigVersion = (== PcAnyVersion) - -withinPkgconfigVersionRange :: PkgconfigVersion -> PkgconfigVersionRange -> Bool -withinPkgconfigVersionRange v = go where - go PcAnyVersion = True - go (PcThisVersion u) = v == u - go (PcLaterVersion u) = v > u - go (PcEarlierVersion u) = v < u - go (PcOrLaterVersion u) = v >= u - go (PcOrEarlierVersion u) = v <= u - go (PcUnionVersionRanges a b) = go a || go b - go (PcIntersectVersionRanges a b) = go a && go b - -------------------------------------------------------------------------------- --- Conversion -------------------------------------------------------------------------------- - -versionToPkgconfigVersion :: Version -> PkgconfigVersion -versionToPkgconfigVersion = PkgconfigVersion . BS8.pack . prettyShow - -versionRangeToPkgconfigVersionRange :: VersionRange -> PkgconfigVersionRange -versionRangeToPkgconfigVersionRange vr - | isAnyVersion vr - = PcAnyVersion - | otherwise - = case asVersionIntervals vr of - [] -> PcEarlierVersion (PkgconfigVersion (BS8.pack "0")) - (i:is) -> foldl (\r j -> PcUnionVersionRanges r (conv j)) (conv i) is - where - conv (LowerBound v b, NoUpperBound) = convL v b - conv (LowerBound v b, UpperBound u c) = PcIntersectVersionRanges (convL v b) (convU u c) - - convL v ExclusiveBound = PcLaterVersion (versionToPkgconfigVersion v) - convL v InclusiveBound = PcOrLaterVersion (versionToPkgconfigVersion v) - - convU v ExclusiveBound = PcEarlierVersion (versionToPkgconfigVersion v) - convU v InclusiveBound = PcOrEarlierVersion (versionToPkgconfigVersion v) diff --git a/cabal/Cabal/Distribution/Types/SetupBuildInfo.hs b/cabal/Cabal/Distribution/Types/SetupBuildInfo.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/SetupBuildInfo.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - -module Distribution.Types.SetupBuildInfo ( - SetupBuildInfo(..) -) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Types.Dependency - --- --------------------------------------------------------------------------- --- The SetupBuildInfo type - --- One can see this as a very cut-down version of BuildInfo below. --- To keep things simple for tools that compile Setup.hs we limit the --- options authors can specify to just Haskell package dependencies. - -data SetupBuildInfo = SetupBuildInfo - { setupDepends :: [Dependency] - , defaultSetupDepends :: Bool - -- ^ Is this a default 'custom-setup' section added by the cabal-install - -- code (as opposed to user-provided)? This field is only used - -- internally, and doesn't correspond to anything in the .cabal - -- file. See #3199. - } - deriving (Generic, Show, Eq, Read, Typeable, Data) - -instance Binary SetupBuildInfo -instance Structured SetupBuildInfo -instance NFData SetupBuildInfo where rnf = genericRnf - -instance Monoid SetupBuildInfo where - mempty = SetupBuildInfo [] False - mappend = (<>) - -instance Semigroup SetupBuildInfo where - a <> b = SetupBuildInfo - (setupDepends a <> setupDepends b) - (defaultSetupDepends a || defaultSetupDepends b) diff --git a/cabal/Cabal/Distribution/Types/SetupBuildInfo/Lens.hs b/cabal/Cabal/Distribution/Types/SetupBuildInfo/Lens.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/SetupBuildInfo/Lens.hs +++ /dev/null @@ -1,21 +0,0 @@ -module Distribution.Types.SetupBuildInfo.Lens ( - SetupBuildInfo, - module Distribution.Types.SetupBuildInfo.Lens, - ) where - -import Distribution.Compat.Lens -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Types.Dependency (Dependency) -import Distribution.Types.SetupBuildInfo (SetupBuildInfo) - -import qualified Distribution.Types.SetupBuildInfo as T - -setupDepends :: Lens' SetupBuildInfo [Dependency] -setupDepends f s = fmap (\x -> s { T.setupDepends = x }) (f (T.setupDepends s)) -{-# INLINE setupDepends #-} - -defaultSetupDepends :: Lens' SetupBuildInfo Bool -defaultSetupDepends f s = fmap (\x -> s { T.defaultSetupDepends = x }) (f (T.defaultSetupDepends s)) -{-# INLINE defaultSetupDepends #-} diff --git a/cabal/Cabal/Distribution/Types/SourceRepo.hs b/cabal/Cabal/Distribution/Types/SourceRepo.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/SourceRepo.hs +++ /dev/null @@ -1,201 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - -module Distribution.Types.SourceRepo ( - SourceRepo(..), - RepoKind(..), - RepoType(..), - KnownRepoType (..), - knownRepoTypes, - emptySourceRepo, - classifyRepoType, - classifyRepoKind, - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Utils.Generic (lowercase) - -import Distribution.Pretty -import Distribution.Parsec - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp -import qualified Data.Map.Strict as M - --- ------------------------------------------------------------ --- * Source repos --- ------------------------------------------------------------ - --- | Information about the source revision control system for a package. --- --- When specifying a repo it is useful to know the meaning or intention of the --- information as doing so enables automation. There are two obvious common --- purposes: one is to find the repo for the latest development version, the --- other is to find the repo for this specific release. The 'ReopKind' --- specifies which one we mean (or another custom one). --- --- A package can specify one or the other kind or both. Most will specify just --- a head repo but some may want to specify a repo to reconstruct the sources --- for this package release. --- --- The required information is the 'RepoType' which tells us if it's using --- 'Darcs', 'Git' for example. The 'repoLocation' and other details are --- interpreted according to the repo type. --- -data SourceRepo = SourceRepo { - -- | The kind of repo. This field is required. - repoKind :: RepoKind, - - -- | The type of the source repository system for this repo, eg 'Darcs' or - -- 'Git'. This field is required. - repoType :: Maybe RepoType, - - -- | The location of the repository. For most 'RepoType's this is a URL. - -- This field is required. - repoLocation :: Maybe String, - - -- | 'CVS' can put multiple \"modules\" on one server and requires a - -- module name in addition to the location to identify a particular repo. - -- Logically this is part of the location but unfortunately has to be - -- specified separately. This field is required for the 'CVS' 'RepoType' and - -- should not be given otherwise. - repoModule :: Maybe String, - - -- | The name or identifier of the branch, if any. Many source control - -- systems have the notion of multiple branches in a repo that exist in the - -- same location. For example 'Git' and 'CVS' use this while systems like - -- 'Darcs' use different locations for different branches. This field is - -- optional but should be used if necessary to identify the sources, - -- especially for the 'RepoThis' repo kind. - repoBranch :: Maybe String, - - -- | The tag identify a particular state of the repository. This should be - -- given for the 'RepoThis' repo kind and not for 'RepoHead' kind. - -- - repoTag :: Maybe String, - - -- | Some repositories contain multiple projects in different subdirectories - -- This field specifies the subdirectory where this packages sources can be - -- found, eg the subdirectory containing the @.cabal@ file. It is interpreted - -- relative to the root of the repository. This field is optional. If not - -- given the default is \".\" ie no subdirectory. - repoSubdir :: Maybe FilePath -} - deriving (Eq, Ord, Generic, Read, Show, Typeable, Data) - -emptySourceRepo :: RepoKind -> SourceRepo -emptySourceRepo kind = SourceRepo - { repoKind = kind - , repoType = Nothing - , repoLocation = Nothing - , repoModule = Nothing - , repoBranch = Nothing - , repoTag = Nothing - , repoSubdir = Nothing - } - -instance Binary SourceRepo -instance Structured SourceRepo -instance NFData SourceRepo where rnf = genericRnf - --- | What this repo info is for, what it represents. --- -data RepoKind = - -- | The repository for the \"head\" or development version of the project. - -- This repo is where we should track the latest development activity or - -- the usual repo people should get to contribute patches. - RepoHead - - -- | The repository containing the sources for this exact package version - -- or release. For this kind of repo a tag should be given to give enough - -- information to re-create the exact sources. - | RepoThis - - | RepoKindUnknown String - deriving (Eq, Generic, Ord, Read, Show, Typeable, Data) - -instance Binary RepoKind -instance Structured RepoKind -instance NFData RepoKind where rnf = genericRnf - --- | An enumeration of common source control systems. The fields used in the --- 'SourceRepo' depend on the type of repo. The tools and methods used to --- obtain and track the repo depend on the repo type. --- -data KnownRepoType = Darcs | Git | SVN | CVS - | Mercurial | GnuArch | Bazaar | Monotone - | Pijul -- ^ @since 3.4.0.0 - deriving (Eq, Generic, Ord, Read, Show, Typeable, Data, Enum, Bounded) - -instance Binary KnownRepoType -instance Structured KnownRepoType -instance NFData KnownRepoType where rnf = genericRnf - -instance Parsec KnownRepoType where - parsec = do - str <- P.munch1 isIdent - maybe - (P.unexpected $ "Could not parse KnownRepoType from " ++ str) - return - (M.lookup str knownRepoTypeMap) - -instance Pretty KnownRepoType where - pretty = Disp.text . lowercase . show - -data RepoType = KnownRepoType KnownRepoType - | OtherRepoType String - deriving (Eq, Generic, Ord, Read, Show, Typeable, Data) - -instance Binary RepoType -instance Structured RepoType -instance NFData RepoType where rnf = genericRnf - -knownRepoTypes :: [KnownRepoType] -knownRepoTypes = [minBound .. maxBound] - -repoTypeAliases :: KnownRepoType -> [String] -repoTypeAliases Bazaar = ["bzr"] -repoTypeAliases Mercurial = ["hg"] -repoTypeAliases GnuArch = ["arch"] -repoTypeAliases _ = [] - -instance Pretty RepoKind where - pretty RepoHead = Disp.text "head" - pretty RepoThis = Disp.text "this" - pretty (RepoKindUnknown other) = Disp.text other - -instance Parsec RepoKind where - parsec = classifyRepoKind <$> P.munch1 isIdent - -classifyRepoKind :: String -> RepoKind -classifyRepoKind name = case lowercase name of - "head" -> RepoHead - "this" -> RepoThis - _ -> RepoKindUnknown name - -instance Parsec RepoType where - parsec = classifyRepoType <$> P.munch1 isIdent - -instance Pretty RepoType where - pretty (OtherRepoType other) = Disp.text other - pretty (KnownRepoType t) = pretty t - -classifyRepoType :: String -> RepoType -classifyRepoType s = - maybe - (OtherRepoType s) - KnownRepoType - (M.lookup (lowercase s) knownRepoTypeMap) - -knownRepoTypeMap :: Map String KnownRepoType -knownRepoTypeMap = - M.fromList - [ (name, repoType') - | repoType' <- knownRepoTypes - , name <- prettyShow repoType' : repoTypeAliases repoType' - ] - -isIdent :: Char -> Bool -isIdent c = isAlphaNum c || c == '_' || c == '-' diff --git a/cabal/Cabal/Distribution/Types/SourceRepo/Lens.hs b/cabal/Cabal/Distribution/Types/SourceRepo/Lens.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/SourceRepo/Lens.hs +++ /dev/null @@ -1,39 +0,0 @@ -module Distribution.Types.SourceRepo.Lens ( - T.SourceRepo, - module Distribution.Types.SourceRepo.Lens, - ) where - -import Prelude() -import Distribution.Compat.Prelude -import Distribution.Compat.Lens - -import Distribution.Types.SourceRepo (SourceRepo, RepoKind, RepoType) -import qualified Distribution.Types.SourceRepo as T - -repoKind :: Lens' SourceRepo RepoKind -repoKind f s = fmap (\x -> s { T.repoKind = x }) (f (T.repoKind s)) -{-# INLINE repoKind #-} - -repoType :: Lens' SourceRepo (Maybe RepoType) -repoType f s = fmap (\x -> s { T.repoType = x }) (f (T.repoType s)) -{-# INLINE repoType #-} - -repoLocation :: Lens' SourceRepo (Maybe String) -repoLocation f s = fmap (\x -> s { T.repoLocation = x }) (f (T.repoLocation s)) -{-# INLINE repoLocation #-} - -repoModule :: Lens' SourceRepo (Maybe String) -repoModule f s = fmap (\x -> s { T.repoModule = x }) (f (T.repoModule s)) -{-# INLINE repoModule #-} - -repoBranch :: Lens' SourceRepo (Maybe String) -repoBranch f s = fmap (\x -> s { T.repoBranch = x }) (f (T.repoBranch s)) -{-# INLINE repoBranch #-} - -repoTag :: Lens' SourceRepo (Maybe String) -repoTag f s = fmap (\x -> s { T.repoTag = x }) (f (T.repoTag s)) -{-# INLINE repoTag #-} - -repoSubdir :: Lens' SourceRepo (Maybe FilePath) -repoSubdir f s = fmap (\x -> s { T.repoSubdir = x }) (f (T.repoSubdir s)) -{-# INLINE repoSubdir #-} diff --git a/cabal/Cabal/Distribution/Types/TargetInfo.hs b/cabal/Cabal/Distribution/Types/TargetInfo.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/TargetInfo.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module Distribution.Types.TargetInfo ( - TargetInfo(..) -) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Types.ComponentLocalBuildInfo -import Distribution.Types.Component -import Distribution.Types.UnitId - -import Distribution.Compat.Graph (IsNode(..)) - --- | The 'TargetInfo' contains all the information necessary to build a --- specific target (e.g., component/module/file) in a package. In --- principle, one can get the 'Component' from a --- 'ComponentLocalBuildInfo' and 'LocalBuildInfo', but it is much more --- convenient to have the component in hand. -data TargetInfo = TargetInfo { - targetCLBI :: ComponentLocalBuildInfo, - targetComponent :: Component - -- TODO: BuildTargets supporting parsing these is dumb, - -- we don't have support for compiling single modules or - -- file paths. Accommodating it now is premature - -- generalization. Figure it out later. - -- targetSub :: Maybe (Either ModuleName FilePath) - } - -instance IsNode TargetInfo where - type Key TargetInfo = UnitId - nodeKey = nodeKey . targetCLBI - nodeNeighbors = nodeNeighbors . targetCLBI diff --git a/cabal/Cabal/Distribution/Types/TestSuite.hs b/cabal/Cabal/Distribution/Types/TestSuite.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/TestSuite.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE NoMonoLocalBinds #-} - -module Distribution.Types.TestSuite ( - TestSuite(..), - emptyTestSuite, - testType, - testModules, - testModulesAutogen -) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Types.BuildInfo -import Distribution.Types.TestType -import Distribution.Types.TestSuiteInterface -import Distribution.Types.UnqualComponentName - -import Distribution.ModuleName - -import qualified Distribution.Types.BuildInfo.Lens as L - --- | A \"test-suite\" stanza in a cabal file. --- -data TestSuite = TestSuite { - testName :: UnqualComponentName, - testInterface :: TestSuiteInterface, - testBuildInfo :: BuildInfo - } - deriving (Generic, Show, Read, Eq, Typeable, Data) - -instance L.HasBuildInfo TestSuite where - buildInfo f l = (\x -> l { testBuildInfo = x }) <$> f (testBuildInfo l) - -instance Binary TestSuite -instance Structured TestSuite - -instance NFData TestSuite where rnf = genericRnf - -instance Monoid TestSuite where - mempty = TestSuite { - testName = mempty, - testInterface = mempty, - testBuildInfo = mempty - } - mappend = (<>) - -instance Semigroup TestSuite where - a <> b = TestSuite { - testName = combine' testName, - testInterface = combine testInterface, - testBuildInfo = combine testBuildInfo - } - where combine field = field a `mappend` field b - combine' field = case ( unUnqualComponentName $ field a - , unUnqualComponentName $ field b) of - ("", _) -> field b - (_, "") -> field a - (x, y) -> error $ "Ambiguous values for test field: '" - ++ x ++ "' and '" ++ y ++ "'" - -emptyTestSuite :: TestSuite -emptyTestSuite = mempty - - -testType :: TestSuite -> TestType -testType test = case testInterface test of - TestSuiteExeV10 ver _ -> TestTypeExe ver - TestSuiteLibV09 ver _ -> TestTypeLib ver - TestSuiteUnsupported testtype -> testtype - --- | Get all the module names from a test suite. -testModules :: TestSuite -> [ModuleName] -testModules test = (case testInterface test of - TestSuiteLibV09 _ m -> [m] - _ -> []) - ++ otherModules (testBuildInfo test) - --- | Get all the auto generated module names from a test suite. --- This are a subset of 'testModules'. -testModulesAutogen :: TestSuite -> [ModuleName] -testModulesAutogen test = autogenModules (testBuildInfo test) diff --git a/cabal/Cabal/Distribution/Types/TestSuite/Lens.hs b/cabal/Cabal/Distribution/Types/TestSuite/Lens.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/TestSuite/Lens.hs +++ /dev/null @@ -1,27 +0,0 @@ -module Distribution.Types.TestSuite.Lens ( - TestSuite, - module Distribution.Types.TestSuite.Lens, - ) where - -import Distribution.Compat.Lens -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Types.BuildInfo (BuildInfo) -import Distribution.Types.TestSuite (TestSuite) -import Distribution.Types.TestSuiteInterface (TestSuiteInterface) -import Distribution.Types.UnqualComponentName (UnqualComponentName) - -import qualified Distribution.Types.TestSuite as T - -testName :: Lens' TestSuite UnqualComponentName -testName f s = fmap (\x -> s { T.testName = x }) (f (T.testName s)) -{-# INLINE testName #-} - -testInterface :: Lens' TestSuite TestSuiteInterface -testInterface f s = fmap (\x -> s { T.testInterface = x }) (f (T.testInterface s)) -{-# INLINE testInterface #-} - -testBuildInfo :: Lens' TestSuite BuildInfo -testBuildInfo f s = fmap (\x -> s { T.testBuildInfo = x }) (f (T.testBuildInfo s)) -{-# INLINE testBuildInfo #-} diff --git a/cabal/Cabal/Distribution/Types/TestSuiteInterface.hs b/cabal/Cabal/Distribution/Types/TestSuiteInterface.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/TestSuiteInterface.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - -module Distribution.Types.TestSuiteInterface ( - TestSuiteInterface(..), -) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Types.TestType -import Distribution.ModuleName -import Distribution.Version - --- | The test suite interfaces that are currently defined. Each test suite must --- specify which interface it supports. --- --- More interfaces may be defined in future, either new revisions or totally --- new interfaces. --- -data TestSuiteInterface = - - -- | Test interface \"exitcode-stdio-1.0\". The test-suite takes the form - -- of an executable. It returns a zero exit code for success, non-zero for - -- failure. The stdout and stderr channels may be logged. It takes no - -- command line parameters and nothing on stdin. - -- - TestSuiteExeV10 Version FilePath - - -- | Test interface \"detailed-0.9\". The test-suite takes the form of a - -- library containing a designated module that exports \"tests :: [Test]\". - -- - | TestSuiteLibV09 Version ModuleName - - -- | A test suite that does not conform to one of the above interfaces for - -- the given reason (e.g. unknown test type). - -- - | TestSuiteUnsupported TestType - deriving (Eq, Generic, Read, Show, Typeable, Data) - -instance Binary TestSuiteInterface -instance Structured TestSuiteInterface - -instance NFData TestSuiteInterface where rnf = genericRnf - -instance Monoid TestSuiteInterface where - mempty = TestSuiteUnsupported (TestTypeUnknown mempty nullVersion) - mappend = (<>) - -instance Semigroup TestSuiteInterface where - a <> (TestSuiteUnsupported _) = a - _ <> b = b diff --git a/cabal/Cabal/Distribution/Types/TestType.hs b/cabal/Cabal/Distribution/Types/TestType.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/TestType.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} - -module Distribution.Types.TestType ( - TestType(..), - knownTestTypes, -) where - -import Distribution.Compat.Prelude -import Distribution.Version -import Prelude () - -import Distribution.Parsec -import Distribution.Pretty -import Text.PrettyPrint (char, text) - --- | The \"test-type\" field in the test suite stanza. --- -data TestType = TestTypeExe Version -- ^ \"type: exitcode-stdio-x.y\" - | TestTypeLib Version -- ^ \"type: detailed-x.y\" - | TestTypeUnknown String Version -- ^ Some unknown test type e.g. \"type: foo\" - deriving (Generic, Show, Read, Eq, Typeable, Data) - -instance Binary TestType -instance Structured TestType - -instance NFData TestType where rnf = genericRnf - -knownTestTypes :: [TestType] -knownTestTypes = [ TestTypeExe (mkVersion [1,0]) - , TestTypeLib (mkVersion [0,9]) ] - -instance Pretty TestType where - pretty (TestTypeExe ver) = text "exitcode-stdio-" <<>> pretty ver - pretty (TestTypeLib ver) = text "detailed-" <<>> pretty ver - pretty (TestTypeUnknown name ver) = text name <<>> char '-' <<>> pretty ver - -instance Parsec TestType where - parsec = parsecStandard $ \ver name -> case name of - "exitcode-stdio" -> TestTypeExe ver - "detailed" -> TestTypeLib ver - _ -> TestTypeUnknown name ver diff --git a/cabal/Cabal/Distribution/Types/UnitId.hs b/cabal/Cabal/Distribution/Types/UnitId.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/UnitId.hs +++ /dev/null @@ -1,134 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE FlexibleContexts #-} - -module Distribution.Types.UnitId - ( UnitId, unUnitId, mkUnitId - , DefUnitId - , unsafeMkDefUnitId - , unDefUnitId - , newSimpleUnitId - , mkLegacyUnitId - , getHSLibraryName - ) where - -import Prelude () -import Distribution.Compat.Prelude -import Distribution.Utils.ShortText - -import qualified Distribution.Compat.CharParsing as P -import Distribution.Pretty -import Distribution.Parsec -import Distribution.Types.ComponentId -import Distribution.Types.PackageId - -import Text.PrettyPrint (text) - --- | A unit identifier identifies a (possibly instantiated) --- package/component that can be installed the installed package --- database. There are several types of components that can be --- installed: --- --- * A traditional library with no holes, so that 'unitIdHash' --- is @Nothing@. In the absence of Backpack, 'UnitId' --- is the same as a 'ComponentId'. --- --- * An indefinite, Backpack library with holes. In this case, --- 'unitIdHash' is still @Nothing@, but in the install, --- there are only interfaces, no compiled objects. --- --- * An instantiated Backpack library with all the holes --- filled in. 'unitIdHash' is a @Just@ a hash of the --- instantiating mapping. --- --- A unit is a component plus the additional information on how the --- holes are filled in. Thus there is a one to many relationship: for a --- particular component there are many different ways of filling in the --- holes, and each different combination is a unit (and has a separate --- 'UnitId'). --- --- 'UnitId' is distinct from 'OpenUnitId', in that it is always --- installed, whereas 'OpenUnitId' are intermediate unit identities --- that arise during mixin linking, and don't necessarily correspond --- to any actually installed unit. Since the mapping is not actually --- recorded in a 'UnitId', you can't actually substitute over them --- (but you can substitute over 'OpenUnitId'). See also --- "Distribution.Backpack.FullUnitId" for a mechanism for expanding an --- instantiated 'UnitId' to retrieve its mapping. --- --- Backwards compatibility note: if you need to get the string --- representation of a UnitId to pass, e.g., as a @-package-id@ --- flag, use the 'display' function, which will work on all --- versions of Cabal. --- -newtype UnitId = UnitId ShortText - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data, NFData) - -instance Binary UnitId -instance Structured UnitId - --- | The textual format for 'UnitId' coincides with the format --- GHC accepts for @-package-id@. --- -instance Pretty UnitId where - pretty = text . unUnitId - --- | The textual format for 'UnitId' coincides with the format --- GHC accepts for @-package-id@. --- -instance Parsec UnitId where - parsec = mkUnitId <$> P.munch1 isUnitChar where - -- https://gitlab.haskell.org/ghc/ghc/issues/17752 - isUnitChar '-' = True - isUnitChar '_' = True - isUnitChar '.' = True - isUnitChar '+' = True - isUnitChar c = isAlphaNum c - --- | If you need backwards compatibility, consider using 'display' --- instead, which is supported by all versions of Cabal. --- -unUnitId :: UnitId -> String -unUnitId (UnitId s) = fromShortText s - -mkUnitId :: String -> UnitId -mkUnitId = UnitId . toShortText - --- | 'mkUnitId' --- --- @since 2.0.0.2 -instance IsString UnitId where - fromString = mkUnitId - --- | Create a unit identity with no associated hash directly --- from a 'ComponentId'. -newSimpleUnitId :: ComponentId -> UnitId -newSimpleUnitId = mkUnitId . unComponentId - --- | Make an old-style UnitId from a package identifier. --- Assumed to be for the public library -mkLegacyUnitId :: PackageId -> UnitId -mkLegacyUnitId = newSimpleUnitId . mkComponentId . prettyShow - --- | Returns library name prefixed with HS, suitable for filenames -getHSLibraryName :: UnitId -> String -getHSLibraryName uid = "HS" ++ prettyShow uid - --- | A 'UnitId' for a definite package. The 'DefUnitId' invariant says --- that a 'UnitId' identified this way is definite; i.e., it has no --- unfilled holes. -newtype DefUnitId = DefUnitId { unDefUnitId :: UnitId } - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data, Binary, NFData, Pretty) - -instance Structured DefUnitId - --- Workaround for a GHC 8.0.1 bug, see --- https://github.com/haskell/cabal/issues/4793#issuecomment-334258288 -instance Parsec DefUnitId where - parsec = DefUnitId <$> parsec - --- | Unsafely create a 'DefUnitId' from a 'UnitId'. Your responsibility --- is to ensure that the 'DefUnitId' invariant holds. -unsafeMkDefUnitId :: UnitId -> DefUnitId -unsafeMkDefUnitId = DefUnitId diff --git a/cabal/Cabal/Distribution/Types/UnqualComponentName.hs b/cabal/Cabal/Distribution/Types/UnqualComponentName.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/UnqualComponentName.hs +++ /dev/null @@ -1,93 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Distribution.Types.UnqualComponentName - ( UnqualComponentName, unUnqualComponentName, unUnqualComponentNameST, mkUnqualComponentName - , packageNameToUnqualComponentName, unqualComponentNameToPackageName - ) where - -import Distribution.Compat.Prelude -import Distribution.Utils.ShortText -import Prelude () - -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Types.PackageName - --- | An unqualified component name, for any kind of component. --- --- This is distinguished from a 'ComponentName' and 'ComponentId'. The former --- also states which of a library, executable, etc the name refers too. The --- later uniquely identifiers a component and its closure. --- --- @since 2.0.0.2 -newtype UnqualComponentName = UnqualComponentName ShortText - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data, - Semigroup, Monoid) -- TODO: bad enabler of bad monoids - --- | Convert 'UnqualComponentName' to 'String' --- --- @since 2.0.0.2 -unUnqualComponentName :: UnqualComponentName -> String -unUnqualComponentName (UnqualComponentName s) = fromShortText s - --- | @since 3.4.0.0 -unUnqualComponentNameST :: UnqualComponentName -> ShortText -unUnqualComponentNameST (UnqualComponentName s) = s - --- | Construct a 'UnqualComponentName' from a 'String' --- --- 'mkUnqualComponentName' is the inverse to 'unUnqualComponentName' --- --- Note: No validations are performed to ensure that the resulting --- 'UnqualComponentName' is valid --- --- @since 2.0.0.2 -mkUnqualComponentName :: String -> UnqualComponentName -mkUnqualComponentName = UnqualComponentName . toShortText - --- | 'mkUnqualComponentName' --- --- @since 2.0.0.2 -instance IsString UnqualComponentName where - fromString = mkUnqualComponentName - -instance Binary UnqualComponentName -instance Structured UnqualComponentName - -instance Pretty UnqualComponentName where - pretty = showToken . unUnqualComponentName - -instance Parsec UnqualComponentName where - parsec = mkUnqualComponentName <$> parsecUnqualComponentName - -instance NFData UnqualComponentName where - rnf (UnqualComponentName pkg) = rnf pkg - --- TODO avoid String round trip with these PackageName <-> --- UnqualComponentName converters. - --- | Converts a package name to an unqualified component name --- --- Useful in legacy situations where a package name may refer to an internal --- component, if one is defined with that name. --- --- 2018-12-21: These "legacy" situations are not legacy. --- We can @build-depends@ on the internal library. However --- Now dependency contains @Set LibraryName@, and we should use that. --- --- @since 2.0.0.2 -packageNameToUnqualComponentName :: PackageName -> UnqualComponentName -packageNameToUnqualComponentName = UnqualComponentName . unPackageNameST - --- | Converts an unqualified component name to a package name --- --- `packageNameToUnqualComponentName` is the inverse of --- `unqualComponentNameToPackageName`. --- --- Useful in legacy situations where a package name may refer to an internal --- component, if one is defined with that name. --- --- @since 2.0.0.2 -unqualComponentNameToPackageName :: UnqualComponentName -> PackageName -unqualComponentNameToPackageName = mkPackageNameST . unUnqualComponentNameST diff --git a/cabal/Cabal/Distribution/Types/Version.hs b/cabal/Cabal/Distribution/Types/Version.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/Version.hs +++ /dev/null @@ -1,242 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.Version ( - -- * Package versions - Version, - mkVersion, - mkVersion', - versionNumbers, - nullVersion, - alterVersion, - version0, - - -- * Internal - validVersion, - versionDigitParser, - ) where - -import Data.Bits (shiftL, shiftR, (.&.), (.|.)) -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Parsec -import Distribution.Pretty - -import qualified Data.Version as Base -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp -import qualified Text.Read as Read - --- | A 'Version' represents the version of a software entity. --- --- Instances of 'Eq' and 'Ord' are provided, which gives exact --- equality and lexicographic ordering of the version number --- components (i.e. 2.1 > 2.0, 1.2.3 > 1.2.2, etc.). --- --- This type is opaque and distinct from the 'Base.Version' type in --- "Data.Version" since @Cabal-2.0@. The difference extends to the --- 'Binary' instance using a different (and more compact) encoding. --- --- @since 2.0.0.2 -data Version = PV0 {-# UNPACK #-} !Word64 - | PV1 !Int [Int] - -- NOTE: If a version fits into the packed Word64 - -- representation (i.e. at most four version components - -- which all fall into the [0..0xfffe] range), then PV0 - -- MUST be used. This is essential for the 'Eq' instance - -- to work. - deriving (Data,Eq,Generic,Typeable) - -instance Ord Version where - compare (PV0 x) (PV0 y) = compare x y - compare (PV1 x xs) (PV1 y ys) = case compare x y of - EQ -> compare xs ys - c -> c - compare (PV0 w) (PV1 y ys) = case compare x y of - EQ -> compare [x2,x3,x4] ys - c -> c - where - x = fromIntegral ((w `shiftR` 48) .&. 0xffff) - 1 - x2 = fromIntegral ((w `shiftR` 32) .&. 0xffff) - 1 - x3 = fromIntegral ((w `shiftR` 16) .&. 0xffff) - 1 - x4 = fromIntegral (w .&. 0xffff) - 1 - compare (PV1 x xs) (PV0 w) = case compare x y of - EQ -> compare xs [y2,y3,y4] - c -> c - where - y = fromIntegral ((w `shiftR` 48) .&. 0xffff) - 1 - y2 = fromIntegral ((w `shiftR` 32) .&. 0xffff) - 1 - y3 = fromIntegral ((w `shiftR` 16) .&. 0xffff) - 1 - y4 = fromIntegral (w .&. 0xffff) - 1 - -instance Show Version where - showsPrec d v = showParen (d > 10) - $ showString "mkVersion " - . showsPrec 11 (versionNumbers v) - -instance Read Version where - readPrec = Read.parens $ do - Read.Ident "mkVersion" <- Read.lexP - v <- Read.step Read.readPrec - return (mkVersion v) - -instance Binary Version -instance Structured Version - -instance NFData Version where - rnf (PV0 _) = () - rnf (PV1 _ ns) = rnf ns - -instance Pretty Version where - pretty ver - = Disp.hcat (Disp.punctuate (Disp.char '.') - (map Disp.int $ versionNumbers ver)) - -instance Parsec Version where - parsec = mkVersion <$> toList <$> P.sepByNonEmpty versionDigitParser (P.char '.') <* tags - where - tags = do - ts <- many $ P.char '-' *> some (P.satisfy isAlphaNum) - case ts of - [] -> pure () - (_ : _) -> parsecWarning PWTVersionTag "version with tags" - --- | An integral without leading zeroes. --- --- @since 3.0 -versionDigitParser :: CabalParsing m => m Int -versionDigitParser = (some d >>= toNumber) P. "version digit (integral without leading zeroes)" - where - toNumber :: CabalParsing m => [Int] -> m Int - toNumber [0] = return 0 - toNumber (0:_) = P.unexpected "Version digit with leading zero" - toNumber xs - -- 10^9 = 1000000000 - -- 2^30 = 1073741824 - -- - -- GHC Int is at least 32 bits, so 2^31-1 is the 'maxBound'. - | length xs > 9 = P.unexpected "At most 9 numbers are allowed per version number part" - | otherwise = return $ foldl' (\a b -> a * 10 + b) 0 xs - - d :: P.CharParsing m => m Int - d = f <$> P.satisfyRange '0' '9' - f c = ord c - ord '0' - --- | Construct 'Version' from list of version number components. --- --- For instance, @mkVersion [3,2,1]@ constructs a 'Version' --- representing the version @3.2.1@. --- --- All version components must be non-negative. @mkVersion []@ --- currently represents the special /null/ version; see also 'nullVersion'. --- --- @since 2.0.0.2 -mkVersion :: [Int] -> Version --- TODO: add validity check; disallow 'mkVersion []' (we have --- 'nullVersion' for that) -mkVersion [] = nullVersion -mkVersion (v1:[]) - | inWord16VerRep1 v1 = PV0 (mkWord64VerRep1 v1) - | otherwise = PV1 v1 [] - where - inWord16VerRep1 x1 = inWord16 (x1 .|. (x1+1)) - mkWord64VerRep1 y1 = mkWord64VerRep (y1+1) 0 0 0 - -mkVersion (v1:vs@(v2:[])) - | inWord16VerRep2 v1 v2 = PV0 (mkWord64VerRep2 v1 v2) - | otherwise = PV1 v1 vs - where - inWord16VerRep2 x1 x2 = inWord16 (x1 .|. (x1+1) - .|. x2 .|. (x2+1)) - mkWord64VerRep2 y1 y2 = mkWord64VerRep (y1+1) (y2+1) 0 0 - -mkVersion (v1:vs@(v2:v3:[])) - | inWord16VerRep3 v1 v2 v3 = PV0 (mkWord64VerRep3 v1 v2 v3) - | otherwise = PV1 v1 vs - where - inWord16VerRep3 x1 x2 x3 = inWord16 (x1 .|. (x1+1) - .|. x2 .|. (x2+1) - .|. x3 .|. (x3+1)) - mkWord64VerRep3 y1 y2 y3 = mkWord64VerRep (y1+1) (y2+1) (y3+1) 0 - -mkVersion (v1:vs@(v2:v3:v4:[])) - | inWord16VerRep4 v1 v2 v3 v4 = PV0 (mkWord64VerRep4 v1 v2 v3 v4) - | otherwise = PV1 v1 vs - where - inWord16VerRep4 x1 x2 x3 x4 = inWord16 (x1 .|. (x1+1) - .|. x2 .|. (x2+1) - .|. x3 .|. (x3+1) - .|. x4 .|. (x4+1)) - mkWord64VerRep4 y1 y2 y3 y4 = mkWord64VerRep (y1+1) (y2+1) (y3+1) (y4+1) - -mkVersion (v1:vs) = PV1 v1 vs - --- | Version 0. A lower bound of 'Version'. --- --- @since 2.2 -version0 :: Version -version0 = mkVersion [0] - -{-# INLINE mkWord64VerRep #-} -mkWord64VerRep :: Int -> Int -> Int -> Int -> Word64 -mkWord64VerRep v1 v2 v3 v4 = - (fromIntegral v1 `shiftL` 48) - .|. (fromIntegral v2 `shiftL` 32) - .|. (fromIntegral v3 `shiftL` 16) - .|. fromIntegral v4 - -{-# INLINE inWord16 #-} -inWord16 :: Int -> Bool -inWord16 x = (fromIntegral x :: Word) <= 0xffff - --- | Variant of 'mkVersion' which converts a "Data.Version" --- 'Base.Version' into Cabal's 'Version' type. --- --- @since 2.0.0.2 -mkVersion' :: Base.Version -> Version -mkVersion' = mkVersion . Base.versionBranch - --- | Unpack 'Version' into list of version number components. --- --- This is the inverse to 'mkVersion', so the following holds: --- --- > (versionNumbers . mkVersion) vs == vs --- --- @since 2.0.0.2 -versionNumbers :: Version -> [Int] -versionNumbers (PV1 n ns) = n:ns -versionNumbers (PV0 w) - | v1 < 0 = [] - | v2 < 0 = [v1] - | v3 < 0 = [v1,v2] - | v4 < 0 = [v1,v2,v3] - | otherwise = [v1,v2,v3,v4] - where - v1 = fromIntegral ((w `shiftR` 48) .&. 0xffff) - 1 - v2 = fromIntegral ((w `shiftR` 32) .&. 0xffff) - 1 - v3 = fromIntegral ((w `shiftR` 16) .&. 0xffff) - 1 - v4 = fromIntegral (w .&. 0xffff) - 1 - - --- | Constant representing the special /null/ 'Version' --- --- The 'nullVersion' compares (via 'Ord') as less than every proper --- 'Version' value. --- --- @since 2.0.0.2 -nullVersion :: Version --- TODO: at some point, 'mkVersion' may disallow creating /null/ --- 'Version's -nullVersion = PV0 0 - --- | Apply function to list of version number components --- --- > alterVersion f == mkVersion . f . versionNumbers --- --- @since 2.0.0.2 -alterVersion :: ([Int] -> [Int]) -> Version -> Version -alterVersion f = mkVersion . f . versionNumbers - --- internal helper -validVersion :: Version -> Bool -validVersion v = v /= nullVersion && all (>=0) (versionNumbers v) diff --git a/cabal/Cabal/Distribution/Types/VersionInterval.hs b/cabal/Cabal/Distribution/Types/VersionInterval.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/VersionInterval.hs +++ /dev/null @@ -1,364 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -module Distribution.Types.VersionInterval ( - -- * Version intervals - VersionIntervals, - toVersionIntervals, - fromVersionIntervals, - withinIntervals, - versionIntervals, - mkVersionIntervals, - unionVersionIntervals, - intersectVersionIntervals, - invertVersionIntervals, - relaxLastInterval, - relaxHeadInterval, - - -- * Version intervals view - asVersionIntervals, - VersionInterval, - LowerBound(..), - UpperBound(..), - Bound(..), - ) where - -import Prelude () -import Distribution.Compat.Prelude -import Control.Exception (assert) - -import Distribution.Types.Version -import Distribution.Types.VersionRange.Internal - --- NonEmpty -import qualified Prelude (foldr1) - -------------------------------------------------------------------------------- --- VersionRange -------------------------------------------------------------------------------- - --- | View a 'VersionRange' as a union of intervals. --- --- This provides a canonical view of the semantics of a 'VersionRange' as --- opposed to the syntax of the expression used to define it. For the syntactic --- view use 'foldVersionRange'. --- --- Each interval is non-empty. The sequence is in increasing order and no --- intervals overlap or touch. Therefore only the first and last can be --- unbounded. The sequence can be empty if the range is empty --- (e.g. a range expression like @< 1 && > 2@). --- --- Other checks are trivial to implement using this view. For example: --- --- > isNoVersion vr | [] <- asVersionIntervals vr = True --- > | otherwise = False --- --- > isSpecificVersion vr --- > | [(LowerBound v InclusiveBound --- > ,UpperBound v' InclusiveBound)] <- asVersionIntervals vr --- > , v == v' = Just v --- > | otherwise = Nothing --- -asVersionIntervals :: VersionRange -> [VersionInterval] -asVersionIntervals = versionIntervals . toVersionIntervals - - -------------------------------------------------------------------------------- --- VersionInterval -------------------------------------------------------------------------------- - --- | A complementary representation of a 'VersionRange'. Instead of a boolean --- version predicate it uses an increasing sequence of non-overlapping, --- non-empty intervals. --- --- The key point is that this representation gives a canonical representation --- for the semantics of 'VersionRange's. This makes it easier to check things --- like whether a version range is empty, covers all versions, or requires a --- certain minimum or maximum version. It also makes it easy to check equality --- or containment. It also makes it easier to identify \'simple\' version --- predicates for translation into foreign packaging systems that do not --- support complex version range expressions. --- -newtype VersionIntervals = VersionIntervals [VersionInterval] - deriving (Eq, Show, Typeable) - --- | Inspect the list of version intervals. --- -versionIntervals :: VersionIntervals -> [VersionInterval] -versionIntervals (VersionIntervals is) = is - -type VersionInterval = (LowerBound, UpperBound) -data LowerBound = LowerBound Version !Bound deriving (Eq, Show) -data UpperBound = NoUpperBound | UpperBound Version !Bound deriving (Eq, Show) -data Bound = ExclusiveBound | InclusiveBound deriving (Eq, Show) - -minLowerBound :: LowerBound -minLowerBound = LowerBound (mkVersion [0]) InclusiveBound - -isVersion0 :: Version -> Bool -isVersion0 = (==) version0 - -instance Ord LowerBound where - LowerBound ver bound <= LowerBound ver' bound' = case compare ver ver' of - LT -> True - EQ -> not (bound == ExclusiveBound && bound' == InclusiveBound) - GT -> False - -instance Ord UpperBound where - _ <= NoUpperBound = True - NoUpperBound <= UpperBound _ _ = False - UpperBound ver bound <= UpperBound ver' bound' = case compare ver ver' of - LT -> True - EQ -> not (bound == InclusiveBound && bound' == ExclusiveBound) - GT -> False - -invariant :: VersionIntervals -> Bool -invariant (VersionIntervals intervals) = all validInterval intervals - && all doesNotTouch' adjacentIntervals - where - doesNotTouch' :: (VersionInterval, VersionInterval) -> Bool - doesNotTouch' ((_,u), (l',_)) = doesNotTouch u l' - - adjacentIntervals :: [(VersionInterval, VersionInterval)] - adjacentIntervals = case intervals of - [] -> [] - (_:tl) -> zip intervals tl - -checkInvariant :: VersionIntervals -> VersionIntervals -checkInvariant is = assert (invariant is) is - --- | Directly construct a 'VersionIntervals' from a list of intervals. --- --- In @Cabal-2.2@ the 'Maybe' is dropped from the result type. --- -mkVersionIntervals :: [VersionInterval] -> VersionIntervals -mkVersionIntervals intervals - | invariant (VersionIntervals intervals) = VersionIntervals intervals - | otherwise - = checkInvariant - . foldl' (flip insertInterval) (VersionIntervals []) - . filter validInterval - $ intervals - -insertInterval :: VersionInterval -> VersionIntervals -> VersionIntervals -insertInterval i is = unionVersionIntervals (VersionIntervals [i]) is - -validInterval :: (LowerBound, UpperBound) -> Bool -validInterval i@(l, u) = validLower l && validUpper u && nonEmpty i - where - validLower (LowerBound v _) = validVersion v - validUpper NoUpperBound = True - validUpper (UpperBound v _) = validVersion v - --- Check an interval is non-empty --- -nonEmpty :: VersionInterval -> Bool -nonEmpty (_, NoUpperBound ) = True -nonEmpty (LowerBound l lb, UpperBound u ub) = - (l < u) || (l == u && lb == InclusiveBound && ub == InclusiveBound) - --- Check an upper bound does not intersect, or even touch a lower bound: --- --- ---| or ---) but not ---] or ---) or ---] --- |--- (--- (--- [--- [--- --- -doesNotTouch :: UpperBound -> LowerBound -> Bool -doesNotTouch NoUpperBound _ = False -doesNotTouch (UpperBound u ub) (LowerBound l lb) = - u < l - || (u == l && ub == ExclusiveBound && lb == ExclusiveBound) - --- | Check an upper bound does not intersect a lower bound: --- --- ---| or ---) or ---] or ---) but not ---] --- |--- (--- (--- [--- [--- --- -doesNotIntersect :: UpperBound -> LowerBound -> Bool -doesNotIntersect NoUpperBound _ = False -doesNotIntersect (UpperBound u ub) (LowerBound l lb) = - u < l - || (u == l && not (ub == InclusiveBound && lb == InclusiveBound)) - --- | Test if a version falls within the version intervals. --- --- It exists mostly for completeness and testing. It satisfies the following --- properties: --- --- > withinIntervals v (toVersionIntervals vr) = withinRange v vr --- > withinIntervals v ivs = withinRange v (fromVersionIntervals ivs) --- -withinIntervals :: Version -> VersionIntervals -> Bool -withinIntervals v (VersionIntervals intervals) = any withinInterval intervals - where - withinInterval (lowerBound, upperBound) = withinLower lowerBound - && withinUpper upperBound - withinLower (LowerBound v' ExclusiveBound) = v' < v - withinLower (LowerBound v' InclusiveBound) = v' <= v - - withinUpper NoUpperBound = True - withinUpper (UpperBound v' ExclusiveBound) = v' > v - withinUpper (UpperBound v' InclusiveBound) = v' >= v - --- | Convert a 'VersionRange' to a sequence of version intervals. --- -toVersionIntervals :: VersionRange -> VersionIntervals -toVersionIntervals = cataVersionRange alg where - alg (ThisVersionF v) = chkIvl (LowerBound v InclusiveBound, UpperBound v InclusiveBound) - alg (LaterVersionF v) = chkIvl (LowerBound v ExclusiveBound, NoUpperBound) - alg (OrLaterVersionF v) = chkIvl (LowerBound v InclusiveBound, NoUpperBound) - alg (EarlierVersionF v) - | isVersion0 v = VersionIntervals [] - | otherwise = chkIvl (minLowerBound, UpperBound v ExclusiveBound) - alg (OrEarlierVersionF v) = chkIvl (minLowerBound, UpperBound v InclusiveBound) - alg (MajorBoundVersionF v) = chkIvl (LowerBound v InclusiveBound, UpperBound (majorUpperBound v) ExclusiveBound) - alg (UnionVersionRangesF v1 v2) = unionVersionIntervals v1 v2 - alg (IntersectVersionRangesF v1 v2) = intersectVersionIntervals v1 v2 - - chkIvl interval = checkInvariant (VersionIntervals [interval]) - --- | Convert a 'VersionIntervals' value back into a 'VersionRange' expression --- representing the version intervals. --- -fromVersionIntervals :: VersionIntervals -> VersionRange -fromVersionIntervals (VersionIntervals []) = noVersion -fromVersionIntervals (VersionIntervals intervals) = - Prelude.foldr1 unionVersionRanges [ interval l u | (l, u) <- intervals ] - - where - interval (LowerBound v InclusiveBound) - (UpperBound v' InclusiveBound) | v == v' - = thisVersion v - interval l u = lowerBound l `intersectVersionRanges'` upperBound u - - lowerBound (LowerBound v InclusiveBound) - | isVersion0 v = Nothing - | otherwise = Just (orLaterVersion v) - lowerBound (LowerBound v ExclusiveBound) = Just (laterVersion v) - - upperBound NoUpperBound = Nothing - upperBound (UpperBound v InclusiveBound) = Just (orEarlierVersion v) - upperBound (UpperBound v ExclusiveBound) = Just (earlierVersion v) - - intersectVersionRanges' Nothing Nothing = anyVersion - intersectVersionRanges' (Just vr) Nothing = vr - intersectVersionRanges' Nothing (Just vr) = vr - intersectVersionRanges' (Just vr) (Just vr') = intersectVersionRanges vr vr' - -unionVersionIntervals :: VersionIntervals -> VersionIntervals - -> VersionIntervals -unionVersionIntervals (VersionIntervals is0) (VersionIntervals is'0) = - checkInvariant (VersionIntervals (union is0 is'0)) - where - union is [] = is - union [] is' = is' - union (i:is) (i':is') = case unionInterval i i' of - Left Nothing -> i : union is (i' :is') - Left (Just i'') -> union is (i'':is') - Right Nothing -> i' : union (i :is) is' - Right (Just i'') -> union (i'':is) is' - -unionInterval :: VersionInterval -> VersionInterval - -> Either (Maybe VersionInterval) (Maybe VersionInterval) -unionInterval (lower , upper ) (lower', upper') - - -- Non-intersecting intervals with the left interval ending first - | upper `doesNotTouch` lower' = Left Nothing - - -- Non-intersecting intervals with the right interval first - | upper' `doesNotTouch` lower = Right Nothing - - -- Complete or partial overlap, with the left interval ending first - | upper <= upper' = lowerBound `seq` - Left (Just (lowerBound, upper')) - - -- Complete or partial overlap, with the left interval ending first - | otherwise = lowerBound `seq` - Right (Just (lowerBound, upper)) - where - lowerBound = min lower lower' - -intersectVersionIntervals :: VersionIntervals -> VersionIntervals - -> VersionIntervals -intersectVersionIntervals (VersionIntervals is0) (VersionIntervals is'0) = - checkInvariant (VersionIntervals (intersect is0 is'0)) - where - intersect _ [] = [] - intersect [] _ = [] - intersect (i:is) (i':is') = case intersectInterval i i' of - Left Nothing -> intersect is (i':is') - Left (Just i'') -> i'' : intersect is (i':is') - Right Nothing -> intersect (i:is) is' - Right (Just i'') -> i'' : intersect (i:is) is' - -intersectInterval :: VersionInterval -> VersionInterval - -> Either (Maybe VersionInterval) (Maybe VersionInterval) -intersectInterval (lower , upper ) (lower', upper') - - -- Non-intersecting intervals with the left interval ending first - | upper `doesNotIntersect` lower' = Left Nothing - - -- Non-intersecting intervals with the right interval first - | upper' `doesNotIntersect` lower = Right Nothing - - -- Complete or partial overlap, with the left interval ending first - | upper <= upper' = lowerBound `seq` - Left (Just (lowerBound, upper)) - - -- Complete or partial overlap, with the right interval ending first - | otherwise = lowerBound `seq` - Right (Just (lowerBound, upper')) - where - lowerBound = max lower lower' - -invertVersionIntervals :: VersionIntervals - -> VersionIntervals -invertVersionIntervals (VersionIntervals xs) = - case xs of - -- Empty interval set - [] -> VersionIntervals [(noLowerBound, NoUpperBound)] - -- Interval with no lower bound - ((lb, ub) : more) | lb == noLowerBound -> - VersionIntervals $ invertVersionIntervals' ub more - -- Interval with a lower bound - ((lb, ub) : more) -> - VersionIntervals $ (noLowerBound, invertLowerBound lb) - : invertVersionIntervals' ub more - where - -- Invert subsequent version intervals given the upper bound of - -- the intervals already inverted. - invertVersionIntervals' :: UpperBound - -> [(LowerBound, UpperBound)] - -> [(LowerBound, UpperBound)] - invertVersionIntervals' NoUpperBound [] = [] - invertVersionIntervals' ub0 [] = [(invertUpperBound ub0, NoUpperBound)] - invertVersionIntervals' ub0 [(lb, NoUpperBound)] = - [(invertUpperBound ub0, invertLowerBound lb)] - invertVersionIntervals' ub0 ((lb, ub1) : more) = - (invertUpperBound ub0, invertLowerBound lb) - : invertVersionIntervals' ub1 more - - invertLowerBound :: LowerBound -> UpperBound - invertLowerBound (LowerBound v b) = UpperBound v (invertBound b) - - invertUpperBound :: UpperBound -> LowerBound - invertUpperBound (UpperBound v b) = LowerBound v (invertBound b) - invertUpperBound NoUpperBound = error "NoUpperBound: unexpected" - - invertBound :: Bound -> Bound - invertBound ExclusiveBound = InclusiveBound - invertBound InclusiveBound = ExclusiveBound - - noLowerBound :: LowerBound - noLowerBound = LowerBound (mkVersion [0]) InclusiveBound - - -relaxLastInterval :: VersionIntervals -> VersionIntervals -relaxLastInterval (VersionIntervals xs) = VersionIntervals (relaxLastInterval' xs) - where - relaxLastInterval' [] = [] - relaxLastInterval' [(l,_)] = [(l, NoUpperBound)] - relaxLastInterval' (i:is) = i : relaxLastInterval' is - -relaxHeadInterval :: VersionIntervals -> VersionIntervals -relaxHeadInterval (VersionIntervals xs) = VersionIntervals (relaxHeadInterval' xs) - where - relaxHeadInterval' [] = [] - relaxHeadInterval' ((_,u):is) = (minLowerBound,u) : is diff --git a/cabal/Cabal/Distribution/Types/VersionRange.hs b/cabal/Cabal/Distribution/Types/VersionRange.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/VersionRange.hs +++ /dev/null @@ -1,180 +0,0 @@ -module Distribution.Types.VersionRange ( - -- * Version ranges - VersionRange, - - -- ** Constructing - anyVersion, noVersion, - thisVersion, notThisVersion, - laterVersion, earlierVersion, - orLaterVersion, orEarlierVersion, - unionVersionRanges, intersectVersionRanges, - withinVersion, - majorBoundVersion, - - -- ** Inspection - -- - -- See "Distribution.Version" for more utilities. - withinRange, - foldVersionRange, - normaliseVersionRange, - stripParensVersionRange, - hasUpperBound, - hasLowerBound, - - -- ** Cata & ana - VersionRangeF (..), - cataVersionRange, - anaVersionRange, - hyloVersionRange, - projectVersionRange, - embedVersionRange, - - -- ** Utilities - isAnyVersion, - isAnyVersionLight, - wildcardUpperBound, - majorUpperBound, - isWildcardRange, - versionRangeParser, - ) where - -import Distribution.Compat.Prelude -import Distribution.Types.Version -import Distribution.Types.VersionInterval -import Distribution.Types.VersionRange.Internal -import Prelude () - --- | Fold over the basic syntactic structure of a 'VersionRange'. --- --- This provides a syntactic view of the expression defining the version range. --- The syntactic sugar @\">= v\"@, @\"<= v\"@ and @\"== v.*\"@ is presented --- in terms of the other basic syntax. --- --- For a semantic view use 'asVersionIntervals'. --- -foldVersionRange :: a -- ^ @\"-any\"@ version - -> (Version -> a) -- ^ @\"== v\"@ - -> (Version -> a) -- ^ @\"> v\"@ - -> (Version -> a) -- ^ @\"< v\"@ - -> (a -> a -> a) -- ^ @\"_ || _\"@ union - -> (a -> a -> a) -- ^ @\"_ && _\"@ intersection - -> VersionRange -> a -foldVersionRange _any this later earlier union intersect = fold - where - fold = cataVersionRange alg - - alg (ThisVersionF v) = this v - alg (LaterVersionF v) = later v - alg (OrLaterVersionF v) = union (this v) (later v) - alg (EarlierVersionF v) = earlier v - alg (OrEarlierVersionF v) = union (this v) (earlier v) - alg (MajorBoundVersionF v) = fold (majorBound v) - alg (UnionVersionRangesF v1 v2) = union v1 v2 - alg (IntersectVersionRangesF v1 v2) = intersect v1 v2 - - majorBound v = intersectVersionRanges - (orLaterVersion v) - (earlierVersion (majorUpperBound v)) - --- | Normalise 'VersionRange'. --- --- In particular collapse @(== v || > v)@ into @>= v@, and so on. -normaliseVersionRange :: VersionRange -> VersionRange -normaliseVersionRange = hyloVersionRange embed projectVersionRange - where - -- == v || > v, > v || == v ==> >= v - embed (UnionVersionRangesF (ThisVersion v) (LaterVersion v')) | v == v' = - orLaterVersion v - embed (UnionVersionRangesF (LaterVersion v) (ThisVersion v')) | v == v' = - orLaterVersion v - - -- == v || < v, < v || == v ==> <= v - embed (UnionVersionRangesF (ThisVersion v) (EarlierVersion v')) | v == v' = - orEarlierVersion v - embed (UnionVersionRangesF (EarlierVersion v) (ThisVersion v')) | v == v' = - orEarlierVersion v - - -- otherwise embed normally - embed vr = embedVersionRange vr - --- | Remove 'VersionRangeParens' constructors. --- --- Since version 3.4 this function is 'id', there aren't 'VersionRangeParens' constructor in 'VersionRange' anymore. --- --- @since 2.2 -stripParensVersionRange :: VersionRange -> VersionRange -stripParensVersionRange = id - --- | Does this version fall within the given range? --- --- This is the evaluation function for the 'VersionRange' type. --- -withinRange :: Version -> VersionRange -> Bool -withinRange v = foldVersionRange - True - (\v' -> v == v') - (\v' -> v > v') - (\v' -> v < v') - (||) - (&&) - --- | Does this 'VersionRange' place any restriction on the 'Version' or is it --- in fact equivalent to 'AnyVersion'. --- --- Note this is a semantic check, not simply a syntactic check. So for example --- the following is @True@ (for all @v@). --- --- > isAnyVersion (EarlierVersion v `UnionVersionRanges` orLaterVersion v) --- -isAnyVersion :: VersionRange -> Bool -isAnyVersion vr = case asVersionIntervals vr of - [(LowerBound v InclusiveBound, NoUpperBound)] -> v == version0 - _ -> False - --- A fast and non-precise version of 'isAnyVersion', --- returns 'True' only for @>= 0@ 'VersionRange's. --- --- /Do not use/. The "VersionIntervals don't destroy MajorBoundVersion" --- https://github.com/haskell/cabal/pull/6736 pull-request --- will change 'simplifyVersionRange' to properly preserve semantics. --- Then we can use it to normalise 'VersionRange's in tests. --- -isAnyVersionLight :: VersionRange -> Bool -isAnyVersionLight (OrLaterVersion v) = v == version0 -isAnyVersionLight _vr = False - ----------------------------- --- Wildcard range utilities --- - - -isWildcardRange :: Version -> Version -> Bool -isWildcardRange ver1 ver2 = check (versionNumbers ver1) (versionNumbers ver2) - where check (n:[]) (m:[]) | n+1 == m = True - check (n:ns) (m:ms) | n == m = check ns ms - check _ _ = False - --- | Does the version range have an upper bound? --- --- @since 1.24.0.0 -hasUpperBound :: VersionRange -> Bool -hasUpperBound = foldVersionRange - False - (const True) - (const False) - (const True) - (&&) (||) - --- | Does the version range have an explicit lower bound? --- --- Note: this function only considers the user-specified lower bounds, but not --- the implicit >=0 lower bound. --- --- @since 1.24.0.0 -hasLowerBound :: VersionRange -> Bool -hasLowerBound = foldVersionRange - False - (const True) - (const True) - (const False) - (&&) (||) diff --git a/cabal/Cabal/Distribution/Types/VersionRange/Internal.hs b/cabal/Cabal/Distribution/Types/VersionRange/Internal.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Types/VersionRange/Internal.hs +++ /dev/null @@ -1,526 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | The only purpose of this module is to prevent the export of --- 'VersionRange' constructors from --- 'Distribution.Types.VersionRange'. To avoid creating orphan --- instances, a lot of related code had to be moved here too. - -module Distribution.Types.VersionRange.Internal - ( VersionRange(..) - , anyVersion, noVersion - , thisVersion, notThisVersion - , laterVersion, earlierVersion - , orLaterVersion, orEarlierVersion - , unionVersionRanges, intersectVersionRanges - , withinVersion - , majorBoundVersion - - , VersionRangeF(..) - , projectVersionRange - , embedVersionRange - , cataVersionRange - , anaVersionRange - , hyloVersionRange - , versionRangeParser - - , majorUpperBound - , wildcardUpperBound - ) where - -import Distribution.Compat.Prelude -import Distribution.Types.Version -import Prelude () - -import Distribution.CabalSpecVersion -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Utils.Generic (unsnoc) - -import qualified Distribution.Compat.CharParsing as P -import qualified Distribution.Compat.DList as DList -import qualified Text.PrettyPrint as Disp - -data VersionRange - = ThisVersion Version -- = version - | LaterVersion Version -- > version (NB. not >=) - | OrLaterVersion Version -- >= version - | EarlierVersion Version -- < version - | OrEarlierVersion Version -- <= version - | MajorBoundVersion Version -- @^>= ver@ (same as >= ver && < MAJ(ver)+1) - | UnionVersionRanges VersionRange VersionRange - | IntersectVersionRanges VersionRange VersionRange - deriving ( Data, Eq, Generic, Read, Show, Typeable ) - -instance Binary VersionRange -instance Structured VersionRange -instance NFData VersionRange where rnf = genericRnf - --- | The version range @-any@. That is, a version range containing all --- versions. --- --- > withinRange v anyVersion = True --- -anyVersion :: VersionRange -anyVersion = OrLaterVersion (mkVersion [0]) - --- | The empty version range, that is a version range containing no versions. --- --- This can be constructed using any unsatisfiable version range expression, --- for example @< 0@. --- --- > withinRange v noVersion = False --- -noVersion :: VersionRange -noVersion = EarlierVersion (mkVersion [0]) - --- | The version range @== v@ --- --- > withinRange v' (thisVersion v) = v' == v --- -thisVersion :: Version -> VersionRange -thisVersion = ThisVersion - --- | The version range @< v || > v@ --- --- > withinRange v' (notThisVersion v) = v' /= v --- -notThisVersion :: Version -> VersionRange -notThisVersion v = UnionVersionRanges (EarlierVersion v) (LaterVersion v) - --- | The version range @> v@ --- --- > withinRange v' (laterVersion v) = v' > v --- -laterVersion :: Version -> VersionRange -laterVersion = LaterVersion - --- | The version range @>= v@ --- --- > withinRange v' (orLaterVersion v) = v' >= v --- -orLaterVersion :: Version -> VersionRange -orLaterVersion = OrLaterVersion - --- | The version range @< v@ --- --- > withinRange v' (earlierVersion v) = v' < v --- -earlierVersion :: Version -> VersionRange -earlierVersion = EarlierVersion - --- | The version range @<= v@ --- --- > withinRange v' (orEarlierVersion v) = v' <= v --- -orEarlierVersion :: Version -> VersionRange -orEarlierVersion = OrEarlierVersion - --- | The version range @vr1 || vr2@ --- --- > withinRange v' (unionVersionRanges vr1 vr2) --- > = withinRange v' vr1 || withinRange v' vr2 --- -unionVersionRanges :: VersionRange -> VersionRange -> VersionRange -unionVersionRanges = UnionVersionRanges - --- | The version range @vr1 && vr2@ --- --- > withinRange v' (intersectVersionRanges vr1 vr2) --- > = withinRange v' vr1 && withinRange v' vr2 --- -intersectVersionRanges :: VersionRange -> VersionRange -> VersionRange -intersectVersionRanges = IntersectVersionRanges - --- | The version range @== v.*@. --- --- For example, for version @1.2@, the version range @== 1.2.*@ is the same as --- @>= 1.2 && < 1.3@ --- --- > withinRange v' (laterVersion v) = v' >= v && v' < upper v --- > where --- > upper (Version lower t) = Version (init lower ++ [last lower + 1]) t --- -withinVersion :: Version -> VersionRange -withinVersion v = intersectVersionRanges - (orLaterVersion v) - (earlierVersion (wildcardUpperBound v)) - --- | The version range @^>= v@. --- --- For example, for version @1.2.3.4@, the version range @^>= 1.2.3.4@ --- is the same as @>= 1.2.3.4 && < 1.3@. --- --- Note that @^>= 1@ is equivalent to @>= 1 && < 1.1@. --- --- @since 2.0.0.2 -majorBoundVersion :: Version -> VersionRange -majorBoundVersion = MajorBoundVersion - - --- | F-Algebra of 'VersionRange'. See 'cataVersionRange'. --- --- @since 2.2 -data VersionRangeF a - = ThisVersionF Version -- = version - | LaterVersionF Version -- > version (NB. not >=) - | OrLaterVersionF Version -- >= version - | EarlierVersionF Version -- < version - | OrEarlierVersionF Version -- <= version - | MajorBoundVersionF Version -- @^>= ver@ (same as >= ver && < MAJ(ver)+1) - | UnionVersionRangesF a a - | IntersectVersionRangesF a a - deriving ( Data, Eq, Generic, Read, Show, Typeable - , Functor, Foldable, Traversable ) - --- | @since 2.2 -projectVersionRange :: VersionRange -> VersionRangeF VersionRange -projectVersionRange (ThisVersion v) = ThisVersionF v -projectVersionRange (LaterVersion v) = LaterVersionF v -projectVersionRange (OrLaterVersion v) = OrLaterVersionF v -projectVersionRange (EarlierVersion v) = EarlierVersionF v -projectVersionRange (OrEarlierVersion v) = OrEarlierVersionF v -projectVersionRange (MajorBoundVersion v) = MajorBoundVersionF v -projectVersionRange (UnionVersionRanges a b) = UnionVersionRangesF a b -projectVersionRange (IntersectVersionRanges a b) = IntersectVersionRangesF a b - --- | Fold 'VersionRange'. --- --- @since 2.2 -cataVersionRange :: (VersionRangeF a -> a) -> VersionRange -> a -cataVersionRange f = c where c = f . fmap c . projectVersionRange - --- | @since 2.2 -embedVersionRange :: VersionRangeF VersionRange -> VersionRange -embedVersionRange (ThisVersionF v) = ThisVersion v -embedVersionRange (LaterVersionF v) = LaterVersion v -embedVersionRange (OrLaterVersionF v) = OrLaterVersion v -embedVersionRange (EarlierVersionF v) = EarlierVersion v -embedVersionRange (OrEarlierVersionF v) = OrEarlierVersion v -embedVersionRange (MajorBoundVersionF v) = MajorBoundVersion v -embedVersionRange (UnionVersionRangesF a b) = UnionVersionRanges a b -embedVersionRange (IntersectVersionRangesF a b) = IntersectVersionRanges a b - --- | Unfold 'VersionRange'. --- --- @since 2.2 -anaVersionRange :: (a -> VersionRangeF a) -> a -> VersionRange -anaVersionRange g = a where a = embedVersionRange . fmap a . g - --- | Refold 'VersionRange' --- --- @since 2.2 -hyloVersionRange :: (VersionRangeF VersionRange -> VersionRange) - -> (VersionRange -> VersionRangeF VersionRange) - -> VersionRange -> VersionRange -hyloVersionRange f g = h where h = f . fmap h . g - -------------------------------------------------------------------------------- --- Parsec & Pretty -------------------------------------------------------------------------------- - --- | --- --- >>> fmap pretty (simpleParsec' CabalSpecV1_6 "== 3.2.*" :: Maybe VersionRange) --- Just >=3.2 && <3.3 --- --- >>> fmap (prettyVersioned CabalSpecV1_6) (simpleParsec' CabalSpecV1_6 "== 3.2.*" :: Maybe VersionRange) --- Just ==3.2.* --- --- >>> fmap pretty (simpleParsec' CabalSpecV1_6 "-any" :: Maybe VersionRange) --- Just >=0 --- --- >>> fmap (prettyVersioned CabalSpecV1_6) (simpleParsec' CabalSpecV1_6 "-any" :: Maybe VersionRange) --- Just >=0 --- -instance Pretty VersionRange where - pretty = prettyVersioned cabalSpecLatest - - prettyVersioned csv - | csv > CabalSpecV1_6 = prettyVersionRange - | otherwise = prettyVersionRange16 - -prettyVersionRange :: VersionRange -> Disp.Doc -prettyVersionRange = fst . cataVersionRange alg - where - alg :: VersionRangeF (Disp.Doc, Int) -> (Disp.Doc, Int) - alg (ThisVersionF v) = (Disp.text "==" <<>> pretty v, 0) - alg (LaterVersionF v) = (Disp.char '>' <<>> pretty v, 0) - alg (OrLaterVersionF v) = (Disp.text ">=" <<>> pretty v, 0) - alg (EarlierVersionF v) = (Disp.char '<' <<>> pretty v, 0) - alg (OrEarlierVersionF v) = (Disp.text "<=" <<>> pretty v, 0) - alg (MajorBoundVersionF v) = (Disp.text "^>=" <<>> pretty v, 0) - alg (UnionVersionRangesF (r1, p1) (r2, p2)) = - (punct 1 p1 r1 <+> Disp.text "||" <+> punct 2 p2 r2 , 2) - alg (IntersectVersionRangesF (r1, p1) (r2, p2)) = - (punct 0 p1 r1 <+> Disp.text "&&" <+> punct 1 p2 r2 , 1) - - punct p p' | p < p' = Disp.parens - | otherwise = id - --- | Don't use && and || operators. If possible. -prettyVersionRange16 :: VersionRange -> Disp.Doc -prettyVersionRange16 (IntersectVersionRanges (OrLaterVersion v) (EarlierVersion u)) - | u == wildcardUpperBound v - = Disp.text "==" <<>> dispWild v - where - dispWild ver = - Disp.hcat (Disp.punctuate (Disp.char '.') - (map Disp.int $ versionNumbers ver)) - <<>> Disp.text ".*" - -prettyVersionRange16 vr = prettyVersionRange vr - --- | --- --- >>> simpleParsec "^>= 3.4" :: Maybe VersionRange --- Just (MajorBoundVersion (mkVersion [3,4])) --- --- Small history: --- --- @-any@ and @-none@ removed in 3.4 --- Use @>=0@ and @<0@ instead. --- --- >>> map (`simpleParsec'` "-none") [CabalSpecV3_0, CabalSpecV3_4] :: [Maybe VersionRange] --- [Just (EarlierVersion (mkVersion [0])),Nothing] --- --- Set operations are introduced in 3.0 --- --- >>> map (`simpleParsec'` "^>= { 1.2 , 1.3 }") [CabalSpecV2_4, CabalSpecV3_0] :: [Maybe VersionRange] --- [Nothing,Just (UnionVersionRanges (MajorBoundVersion (mkVersion [1,2])) (MajorBoundVersion (mkVersion [1,3])))] --- --- @^>=@ is introduced in 2.0 --- --- >>> map (`simpleParsec'` "^>=1.2") [CabalSpecV1_24, CabalSpecV2_0] :: [Maybe VersionRange] --- [Nothing,Just (MajorBoundVersion (mkVersion [1,2]))] --- --- @-none@ is introduced in 1.22 --- --- >>> map (`simpleParsec'` "-none") [CabalSpecV1_20, CabalSpecV1_22] :: [Maybe VersionRange] --- [Nothing,Just (EarlierVersion (mkVersion [0]))] --- --- Operators are introduced in 1.8. Issues only a warning. --- --- >>> map (`simpleParsecW'` "== 1 || ==2") [CabalSpecV1_6, CabalSpecV1_8] :: [Maybe VersionRange] --- [Nothing,Just (UnionVersionRanges (ThisVersion (mkVersion [1])) (ThisVersion (mkVersion [2])))] --- --- Wild-version ranges are introduced in 1.6. Issues only a warning. --- --- >>> map (`simpleParsecW'` "== 1.2.*") [CabalSpecV1_4, CabalSpecV1_6] :: [Maybe VersionRange] --- [Nothing,Just (IntersectVersionRanges (OrLaterVersion (mkVersion [1,2])) (EarlierVersion (mkVersion [1,3])))] --- -instance Parsec VersionRange where - parsec = askCabalSpecVersion >>= versionRangeParser versionDigitParser - --- | 'VersionRange' parser parametrised by version digit parser --- --- - 'versionDigitParser' is used for all 'VersionRange'. --- - 'P.integral' is used for backward-compat @pkgconfig-depends@ --- versions, 'PkgConfigVersionRange'. --- --- @since 3.0 -versionRangeParser :: forall m. CabalParsing m => m Int -> CabalSpecVersion -> m VersionRange -versionRangeParser digitParser csv = expr - where - expr = do P.spaces - t <- term - P.spaces - (do _ <- P.string "||" - checkOp - P.spaces - e <- expr - return (unionVersionRanges t e) - <|> - return t) - term = do f <- factor - P.spaces - (do _ <- P.string "&&" - checkOp - P.spaces - t <- term - return (intersectVersionRanges f t) - <|> - return f) - factor = parens expr <|> prim - - prim = do - op <- P.munch1 isOpChar P. "operator" - case op of - "-" -> anyVersion <$ P.string "any" <|> P.string "none" *> noVersion' - - "==" -> do - P.spaces - (do (wild, v) <- verOrWild - checkWild wild - pure $ (if wild then withinVersion else thisVersion) v - <|> - (verSet' thisVersion =<< verSet)) - - "^>=" -> do - P.spaces - (do (wild, v) <- verOrWild - when wild $ P.unexpected $ - "wild-card version after ^>= operator" - majorBoundVersion' v - <|> - (verSet' majorBoundVersion =<< verSet)) - - _ -> do - P.spaces - (wild, v) <- verOrWild - when wild $ P.unexpected $ - "wild-card version after non-== operator: " ++ show op - case op of - ">=" -> pure $ orLaterVersion v - "<" -> pure $ earlierVersion v - "<=" -> pure $ orEarlierVersion v - ">" -> pure $ laterVersion v - _ -> fail $ "Unknown version operator " ++ show op - - -- Cannot be warning - -- On 2020-03-16 there was around 27400 files on Hackage failing to parse due this - -- For example https://hackage.haskell.org/package/haxr-3000.0.0/haxr.cabal - -- - checkOp = when (csv < CabalSpecV1_8) $ - parsecWarning PWTVersionOperator $ unwords - [ "version operators used." - , "To use version operators the package needs to specify at least 'cabal-version: >= 1.8'." - ] - - -- Cannot be warning - -- On 2020-03-16 there was 46 files on Hackage failing to parse due this - -- For example https://hackage.haskell.org/package/derive-0.1.2/derive.cabal - -- - checkWild False = pure () - checkWild True = when (csv < CabalSpecV1_6) $ - parsecWarning PWTVersionWildcard $ unwords - [ "Wildcard syntax used." - , "To use version wildcards the package needs to specify at least 'cabal-version: >= 1.6'." - ] - - -- https://gitlab.haskell.org/ghc/ghc/issues/17752 - isOpChar '<' = True - isOpChar '=' = True - isOpChar '>' = True - isOpChar '^' = True - isOpChar '-' = csv < CabalSpecV3_4 - -- https://github.com/haskell/cabal/issues/6589 - -- Unfortunately we have must not consume the dash, - -- as otherwise following parts may not be parsed. - -- - -- i.e. we cannot fail here with good error. - isOpChar _ = False - - -- -none version range is available since 1.22 - noVersion' = - if csv >= CabalSpecV1_22 - then pure noVersion - else fail $ unwords - [ "-none version range used." - , "To use this syntax the package needs to specify at least 'cabal-version: 1.22'." - , "Alternatively, if broader compatibility is important then use" - , "<0 or other empty range." - ] - - -- ^>= is available since 2.0 - majorBoundVersion' v = - if csv >= CabalSpecV2_0 - then pure $ majorBoundVersion v - else fail $ unwords - [ "major bounded version syntax (caret, ^>=) used." - , "To use this syntax the package need to specify at least 'cabal-version: 2.0'." - , "Alternatively, if broader compatibility is important then use:" - , prettyShow $ eliminateMajorBoundSyntax $ majorBoundVersion v - ] - where - eliminateMajorBoundSyntax = hyloVersionRange embed projectVersionRange - embed (MajorBoundVersionF u) = intersectVersionRanges - (orLaterVersion u) (earlierVersion (majorUpperBound u)) - embed vr = embedVersionRange vr - - -- version set notation (e.g. "== { 0.0.1.0, 0.0.2.0, 0.1.0.0 }") - verSet' op vs = - if csv >= CabalSpecV3_0 - then pure $ foldr1 unionVersionRanges (fmap op vs) - else fail $ unwords - [ "version set syntax used." - , "To use this syntax the package needs to specify at least 'cabal-version: 3.0'." - , "Alternatively, if broader compatibility is important then use" - , "a series of single version constraints joined with the || operator:" - , prettyShow (foldr1 unionVersionRanges (fmap op vs)) - ] - - verSet :: CabalParsing m => m (NonEmpty Version) - verSet = do - _ <- P.char '{' - P.spaces - vs <- P.sepByNonEmpty (verPlain <* P.spaces) (P.char ',' *> P.spaces) - _ <- P.char '}' - pure vs - - -- a plain version without tags or wildcards - verPlain :: CabalParsing m => m Version - verPlain = mkVersion <$> toList <$> P.sepByNonEmpty digitParser (P.char '.') - - -- either wildcard or normal version - verOrWild :: CabalParsing m => m (Bool, Version) - verOrWild = do - x <- digitParser - verLoop (DList.singleton x) - - -- trailing: wildcard (.y.*) or normal version (optional tags) (.y.z-tag) - verLoop :: CabalParsing m => DList.DList Int -> m (Bool, Version) - verLoop acc = verLoop' acc - <|> (tags *> pure (False, mkVersion (DList.toList acc))) - - verLoop' :: CabalParsing m => DList.DList Int -> m (Bool, Version) - verLoop' acc = do - _ <- P.char '.' - let digit = digitParser >>= verLoop . DList.snoc acc - let wild = (True, mkVersion (DList.toList acc)) <$ P.char '*' - digit <|> wild - - parens p = P.between - ((P.char '(' P. "opening paren") >> P.spaces) - (P.char ')' >> P.spaces) - $ do - a <- p - P.spaces - return a - - tags :: CabalParsing m => m () - tags = do - ts <- many $ P.char '-' *> some (P.satisfy isAlphaNum) - case ts of - [] -> pure () - (_ : _) -> parsecWarning PWTVersionTag "version with tags" - - ----------------------------- --- Wildcard range utilities --- - --- | Compute next greater major version to be used as upper bound --- --- Example: @0.4.1@ produces the version @0.5@ which then can be used --- to construct a range @>= 0.4.1 && < 0.5@ --- --- @since 2.2 -majorUpperBound :: Version -> Version -majorUpperBound = alterVersion $ \numbers -> case numbers of - [] -> [0,1] -- should not happen - [m1] -> [m1,1] -- e.g. version '1' - (m1:m2:_) -> [m1,m2+1] - --- | @since 2.2 -wildcardUpperBound :: Version -> Version -wildcardUpperBound = alterVersion $ - \lowerBound -> case unsnoc lowerBound of - Nothing -> [] - Just (xs, x) -> xs ++ [x + 1] diff --git a/cabal/Cabal/Distribution/Utils/Base62.hs b/cabal/Cabal/Distribution/Utils/Base62.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Utils/Base62.hs +++ /dev/null @@ -1,22 +0,0 @@ - --- | Implementation of base-62 encoding, which we use when computing hashes --- for fully instantiated unit ids. -module Distribution.Utils.Base62 (hashToBase62) where - -import GHC.Fingerprint ( Fingerprint(..), fingerprintString ) -import Numeric ( showIntAtBase ) -import Data.Char ( chr ) - --- | Hash a string using GHC's fingerprinting algorithm (a 128-bit --- MD5 hash) and then encode the resulting hash in base 62. -hashToBase62 :: String -> String -hashToBase62 s = showFingerprint $ fingerprintString s - where - showIntAtBase62 x = showIntAtBase 62 representBase62 x "" - representBase62 x - | x < 10 = chr (48 + x) - | x < 36 = chr (65 + x - 10) - | x < 62 = chr (97 + x - 36) - | otherwise = '@' - showFingerprint (Fingerprint a b) = showIntAtBase62 a ++ showIntAtBase62 b - diff --git a/cabal/Cabal/Distribution/Utils/Generic.hs b/cabal/Cabal/Distribution/Utils/Generic.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Utils/Generic.hs +++ /dev/null @@ -1,575 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE BangPatterns #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Utils --- Copyright : Isaac Jones, Simon Marlow 2003-2004 --- License : BSD3 --- portions Copyright (c) 2007, Galois Inc. --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- A large and somewhat miscellaneous collection of utility functions used --- throughout the rest of the Cabal lib and in other tools that use the Cabal --- lib like @cabal-install@. It has a very simple set of logging actions. It --- has low level functions for running programs, a bunch of wrappers for --- various directory and file functions that do extra logging. - -module Distribution.Utils.Generic ( - -- * reading and writing files safely - withFileContents, - writeFileAtomic, - - -- * Unicode - - -- ** Conversions - fromUTF8BS, - fromUTF8LBS, - - toUTF8BS, - toUTF8LBS, - - validateUTF8, - - -- ** File I/O - readUTF8File, - withUTF8FileContents, - writeUTF8File, - - -- ** BOM - ignoreBOM, - - -- ** Misc - normaliseLineEndings, - - -- * generic utils - dropWhileEndLE, - takeWhileEndLE, - equating, - comparing, - isInfixOf, - intercalate, - lowercase, - isAscii, - isAsciiAlpha, - isAsciiAlphaNum, - listUnion, - listUnionRight, - ordNub, - ordNubBy, - ordNubRight, - safeHead, - safeTail, - safeLast, - safeInit, - unintersperse, - wrapText, - wrapLine, - unfoldrM, - spanMaybe, - breakMaybe, - unsnoc, - unsnocNE, - - -- * Triples - fstOf3, - sndOf3, - trdOf3, - - -- * FilePath stuff - isAbsoluteOnAnyPlatform, - isRelativeOnAnyPlatform, - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Utils.String - -import Data.Bits ((.&.), (.|.), shiftL) -import Data.List - ( isInfixOf ) -import qualified Data.Set as Set -import qualified Data.ByteString as SBS -import qualified Data.ByteString.Lazy as LBS - -import System.Directory - ( removeFile, renameFile ) -import System.FilePath - ( (<.>), splitFileName ) -import System.IO - ( withFile, withBinaryFile - , openBinaryTempFileWithDefaultPermissions - , IOMode(ReadMode), hGetContents, hClose ) -import qualified Control.Exception as Exception - --- ----------------------------------------------------------------------------- --- Helper functions - --- | Wraps text to the default line width. Existing newlines are preserved. -wrapText :: String -> String -wrapText = unlines - . map (intercalate "\n" - . map unwords - . wrapLine 79 - . words) - . lines - --- | Wraps a list of words to a list of lines of words of a particular width. -wrapLine :: Int -> [String] -> [[String]] -wrapLine width = wrap 0 [] - where wrap :: Int -> [String] -> [String] -> [[String]] - wrap 0 [] (w:ws) - | length w + 1 > width - = wrap (length w) [w] ws - wrap col line (w:ws) - | col + length w + 1 > width - = reverse line : wrap 0 [] (w:ws) - wrap col line (w:ws) - = let col' = col + length w + 1 - in wrap col' (w:line) ws - wrap _ [] [] = [] - wrap _ line [] = [reverse line] - ------------------------------------ --- Safely reading and writing files - --- | Gets the contents of a file, but guarantee that it gets closed. --- --- The file is read lazily but if it is not fully consumed by the action then --- the remaining input is truncated and the file is closed. --- -withFileContents :: FilePath -> (String -> IO a) -> IO a -withFileContents name action = - withFile name ReadMode - (\hnd -> hGetContents hnd >>= action) - --- | Writes a file atomically. --- --- The file is either written successfully or an IO exception is raised and --- the original file is left unchanged. --- --- On windows it is not possible to delete a file that is open by a process. --- This case will give an IO exception but the atomic property is not affected. --- -writeFileAtomic :: FilePath -> LBS.ByteString -> IO () -writeFileAtomic targetPath content = do - let (targetDir, targetFile) = splitFileName targetPath - Exception.bracketOnError - (openBinaryTempFileWithDefaultPermissions targetDir $ targetFile <.> "tmp") - (\(tmpPath, handle) -> hClose handle >> removeFile tmpPath) - (\(tmpPath, handle) -> do - LBS.hPut handle content - hClose handle - renameFile tmpPath targetPath) - --- ------------------------------------------------------------ --- * Unicode stuff --- ------------------------------------------------------------ - --- | Decode 'String' from UTF8-encoded 'BS.ByteString' --- --- Invalid data in the UTF8 stream (this includes code-points @U+D800@ --- through @U+DFFF@) will be decoded as the replacement character (@U+FFFD@). --- -fromUTF8BS :: SBS.ByteString -> String -fromUTF8BS = decodeStringUtf8 . SBS.unpack - --- | Variant of 'fromUTF8BS' for lazy 'BS.ByteString's --- -fromUTF8LBS :: LBS.ByteString -> String -fromUTF8LBS = decodeStringUtf8 . LBS.unpack - --- | Encode 'String' to UTF8-encoded 'SBS.ByteString' --- --- Code-points in the @U+D800@-@U+DFFF@ range will be encoded --- as the replacement character (i.e. @U+FFFD@). --- -toUTF8BS :: String -> SBS.ByteString -toUTF8BS = SBS.pack . encodeStringUtf8 - --- | Variant of 'toUTF8BS' for lazy 'BS.ByteString's --- -toUTF8LBS :: String -> LBS.ByteString -toUTF8LBS = LBS.pack . encodeStringUtf8 - --- | Check that strict 'ByteString' is valid UTF8. Returns 'Just offset' if it's not. -validateUTF8 :: SBS.ByteString -> Maybe Int -validateUTF8 = go 0 where - go off bs = case SBS.uncons bs of - Nothing -> Nothing - Just (c, bs') - | c <= 0x7F -> go (off + 1) bs' - | c <= 0xBF -> Just off - | c <= 0xDF -> twoBytes off c bs' - | c <= 0xEF -> moreBytes off 3 0x800 bs' (fromIntegral $ c .&. 0xF) - | c <= 0xF7 -> moreBytes off 4 0x10000 bs' (fromIntegral $ c .&. 0x7) - | c <= 0xFB -> moreBytes off 5 0x200000 bs' (fromIntegral $ c .&. 0x3) - | c <= 0xFD -> moreBytes off 6 0x4000000 bs' (fromIntegral $ c .&. 0x1) - | otherwise -> Just off - - twoBytes off c0 bs = case SBS.uncons bs of - Nothing -> Just off - Just (c1, bs') - | c1 .&. 0xC0 == 0x80 -> - if d >= (0x80 :: Int) - then go (off + 2) bs' - else Just off - | otherwise -> Just off - where - d = (fromIntegral (c0 .&. 0x1F) `shiftL` 6) .|. fromIntegral (c1 .&. 0x3F) - - moreBytes :: Int -> Int -> Int -> SBS.ByteString -> Int -> Maybe Int - moreBytes off 1 overlong cs' acc - | overlong <= acc, acc <= 0x10FFFF, acc < 0xD800 || 0xDFFF < acc - = go (off + 1) cs' - - | otherwise - = Just off - - moreBytes off byteCount overlong bs acc = case SBS.uncons bs of - Just (cn, bs') | cn .&. 0xC0 == 0x80 -> - moreBytes (off + 1) (byteCount-1) overlong bs' ((acc `shiftL` 6) .|. fromIntegral cn .&. 0x3F) - _ -> Just off - - --- | Ignore a Unicode byte order mark (BOM) at the beginning of the input --- -ignoreBOM :: String -> String -ignoreBOM ('\xFEFF':string) = string -ignoreBOM string = string - --- | Reads a UTF8 encoded text file as a Unicode String --- --- Reads lazily using ordinary 'readFile'. --- -readUTF8File :: FilePath -> IO String -readUTF8File f = (ignoreBOM . fromUTF8LBS) <$> LBS.readFile f - --- | Reads a UTF8 encoded text file as a Unicode String --- --- Same behaviour as 'withFileContents'. --- -withUTF8FileContents :: FilePath -> (String -> IO a) -> IO a -withUTF8FileContents name action = - withBinaryFile name ReadMode - (\hnd -> LBS.hGetContents hnd >>= action . ignoreBOM . fromUTF8LBS) - --- | Writes a Unicode String as a UTF8 encoded text file. --- --- Uses 'writeFileAtomic', so provides the same guarantees. --- -writeUTF8File :: FilePath -> String -> IO () -writeUTF8File path = writeFileAtomic path . toUTF8LBS - --- | Fix different systems silly line ending conventions -normaliseLineEndings :: String -> String -normaliseLineEndings [] = [] -normaliseLineEndings ('\r':'\n':s) = '\n' : normaliseLineEndings s -- windows -normaliseLineEndings ('\r':s) = '\n' : normaliseLineEndings s -- old OS X -normaliseLineEndings ( c :s) = c : normaliseLineEndings s - --- ------------------------------------------------------------ --- * Common utils --- ------------------------------------------------------------ - --- | @dropWhileEndLE p@ is equivalent to @reverse . dropWhile p . reverse@, but --- quite a bit faster. The difference between "Data.List.dropWhileEnd" and this --- version is that the one in "Data.List" is strict in elements, but spine-lazy, --- while this one is spine-strict but lazy in elements. That's what @LE@ stands --- for - "lazy in elements". --- --- Example: --- --- >>> safeTail $ Data.List.dropWhileEnd (<3) [undefined, 5, 4, 3, 2, 1] --- *** Exception: Prelude.undefined --- ... --- --- >>> safeTail $ dropWhileEndLE (<3) [undefined, 5, 4, 3, 2, 1] --- [5,4,3] --- --- >>> take 3 $ Data.List.dropWhileEnd (<3) [5, 4, 3, 2, 1, undefined] --- [5,4,3] --- --- >>> take 3 $ dropWhileEndLE (<3) [5, 4, 3, 2, 1, undefined] --- *** Exception: Prelude.undefined --- ... --- -dropWhileEndLE :: (a -> Bool) -> [a] -> [a] -dropWhileEndLE p = foldr (\x r -> if null r && p x then [] else x:r) [] - --- | @takeWhileEndLE p@ is equivalent to @reverse . takeWhile p . reverse@, but --- is usually faster (as well as being easier to read). -takeWhileEndLE :: (a -> Bool) -> [a] -> [a] -takeWhileEndLE p = fst . foldr go ([], False) - where - go x (rest, done) - | not done && p x = (x:rest, False) - | otherwise = (rest, True) - --- | Like 'Data.List.nub', but has @O(n log n)@ complexity instead of --- @O(n^2)@. Code for 'ordNub' and 'listUnion' taken from Niklas Hambüchen's --- package. -ordNub :: Ord a => [a] -> [a] -ordNub = ordNubBy id - --- | Like 'ordNub' and 'Data.List.nubBy'. Selects a key for each element and --- takes the nub based on that key. -ordNubBy :: Ord b => (a -> b) -> [a] -> [a] -ordNubBy f l = go Set.empty l - where - go !_ [] = [] - go !s (x:xs) - | y `Set.member` s = go s xs - | otherwise = let !s' = Set.insert y s - in x : go s' xs - where - y = f x - --- | Like "Data.List.union", but has @O(n log n)@ complexity instead of --- @O(n^2)@. -listUnion :: (Ord a) => [a] -> [a] -> [a] -listUnion a b = a ++ ordNub (filter (`Set.notMember` aSet) b) - where - aSet = Set.fromList a - --- | A right-biased version of 'ordNub'. --- --- Example: --- --- >>> ordNub [1,2,1] :: [Int] --- [1,2] --- --- >>> ordNubRight [1,2,1] :: [Int] --- [2,1] --- -ordNubRight :: (Ord a) => [a] -> [a] -ordNubRight = fst . foldr go ([], Set.empty) - where - go x p@(l, s) = if x `Set.member` s then p - else (x:l, Set.insert x s) - --- | A right-biased version of 'listUnion'. --- --- Example: --- --- >>> listUnion [1,2,3,4,3] [2,1,1] --- [1,2,3,4,3] --- --- >>> listUnionRight [1,2,3,4,3] [2,1,1] --- [4,3,2,1,1] --- -listUnionRight :: (Ord a) => [a] -> [a] -> [a] -listUnionRight a b = ordNubRight (filter (`Set.notMember` bSet) a) ++ b - where - bSet = Set.fromList b - --- | A total variant of 'head'. --- --- @since 3.2.0.0 -safeHead :: [a] -> Maybe a -safeHead [] = Nothing -safeHead (x:_) = Just x - --- | A total variant of 'tail'. --- --- @since 3.2.0.0 -safeTail :: [a] -> [a] -safeTail [] = [] -safeTail (_:xs) = xs - --- | A total variant of 'last'. --- --- @since 3.2.0.0 -safeLast :: [a] -> Maybe a -safeLast [] = Nothing -safeLast (x:xs) = Just (foldl (\_ a -> a) x xs) - --- | A total variant of 'init'. --- --- @since 3.2.0.0 -safeInit :: [a] -> [a] -safeInit [] = [] -safeInit [_] = [] -safeInit (x:xs) = x : safeInit xs - -equating :: Eq a => (b -> a) -> b -> b -> Bool -equating p x y = p x == p y - --- | Lower case string --- --- >>> lowercase "Foobar" --- "foobar" -lowercase :: String -> String -lowercase = map toLower - --- | Ascii characters -isAscii :: Char -> Bool -isAscii c = fromEnum c < 0x80 - --- | Ascii letters. -isAsciiAlpha :: Char -> Bool -isAsciiAlpha c = ('a' <= c && c <= 'z') - || ('A' <= c && c <= 'Z') - --- | Ascii letters and digits. --- --- >>> isAsciiAlphaNum 'a' --- True --- --- >>> isAsciiAlphaNum 'ä' --- False --- -isAsciiAlphaNum :: Char -> Bool -isAsciiAlphaNum c = isAscii c && isAlphaNum c - -unintersperse :: Char -> String -> [String] -unintersperse mark = unfoldr unintersperse1 where - unintersperse1 str - | null str = Nothing - | otherwise = - let (this, rest) = break (== mark) str in - Just (this, safeTail rest) - --- | Like 'break', but with 'Maybe' predicate --- --- >>> breakMaybe (readMaybe :: String -> Maybe Int) ["foo", "bar", "1", "2", "quu"] --- (["foo","bar"],Just (1,["2","quu"])) --- --- >>> breakMaybe (readMaybe :: String -> Maybe Int) ["foo", "bar"] --- (["foo","bar"],Nothing) --- --- @since 2.2 --- -breakMaybe :: (a -> Maybe b) -> [a] -> ([a], Maybe (b, [a])) -breakMaybe f = go id where - go !acc [] = (acc [], Nothing) - go !acc (x:xs) = case f x of - Nothing -> go (acc . (x:)) xs - Just b -> (acc [], Just (b, xs)) - --- | Like 'span' but with 'Maybe' predicate --- --- >>> spanMaybe listToMaybe [[1,2],[3],[],[4,5],[6,7]] --- ([1,3],[[],[4,5],[6,7]]) --- --- >>> spanMaybe (readMaybe :: String -> Maybe Int) ["1", "2", "foo"] --- ([1,2],["foo"]) --- --- @since 2.2 --- -spanMaybe :: (a -> Maybe b) -> [a] -> ([b],[a]) -spanMaybe _ xs@[] = ([], xs) -spanMaybe p xs@(x:xs') = case p x of - Just y -> let (ys, zs) = spanMaybe p xs' in (y : ys, zs) - Nothing -> ([], xs) - --- | 'unfoldr' with monadic action. --- --- >>> take 5 $ unfoldrM (\b r -> Just (r + b, b + 1)) (1 :: Int) 2 --- [3,4,5,6,7] --- --- @since 2.2 --- -unfoldrM :: Monad m => (b -> m (Maybe (a, b))) -> b -> m [a] -unfoldrM f = go where - go b = do - m <- f b - case m of - Nothing -> return [] - Just (a, b') -> liftM (a :) (go b') - --- | The opposite of 'snoc', which is the reverse of 'cons' --- --- Example: --- --- >>> unsnoc [1, 2, 3] --- Just ([1,2],3) --- --- >>> unsnoc [] --- Nothing --- --- @since 3.2.0.0 --- -unsnoc :: [a] -> Maybe ([a], a) -unsnoc [] = Nothing -unsnoc (x:xs) = Just (unsnocNE (x :| xs)) - --- | Like 'unsnoc', but for 'NonEmpty' so without the 'Maybe' --- --- Example: --- --- >>> unsnocNE (1 :| [2, 3]) --- ([1,2],3) --- --- >>> unsnocNE (1 :| []) --- ([],1) --- --- @since 3.2.0.0 --- -unsnocNE :: NonEmpty a -> ([a], a) -unsnocNE (x:|xs) = go x xs where - go y [] = ([], y) - go y (z:zs) = let ~(ws, w) = go z zs in (y : ws, w) - -------------------------------------------------------------------------------- --- Triples -------------------------------------------------------------------------------- - --- | @since 3.4.0.0 -fstOf3 :: (a,b,c) -> a -fstOf3 (a,_,_) = a - --- | @since 3.4.0.0 -sndOf3 :: (a,b,c) -> b -sndOf3 (_,b,_) = b - --- | @since 3.4.0.0 -trdOf3 :: (a,b,c) -> c -trdOf3 (_,_,c) = c - --- ------------------------------------------------------------ --- * FilePath stuff --- ------------------------------------------------------------ - --- | 'isAbsoluteOnAnyPlatform' and 'isRelativeOnAnyPlatform' are like --- 'System.FilePath.isAbsolute' and 'System.FilePath.isRelative' but have --- platform independent heuristics. --- The System.FilePath exists in two versions, Windows and Posix. The two --- versions don't agree on what is a relative path and we don't know if we're --- given Windows or Posix paths. --- This results in false positives when running on Posix and inspecting --- Windows paths, like the hackage server does. --- System.FilePath.Posix.isAbsolute \"C:\\hello\" == False --- System.FilePath.Windows.isAbsolute \"/hello\" == False --- This means that we would treat paths that start with \"/\" to be absolute. --- On Posix they are indeed absolute, while on Windows they are not. --- --- The portable versions should be used when we might deal with paths that --- are from another OS than the host OS. For example, the Hackage Server --- deals with both Windows and Posix paths while performing the --- PackageDescription checks. In contrast, when we run 'cabal configure' we --- do expect the paths to be correct for our OS and we should not have to use --- the platform independent heuristics. -isAbsoluteOnAnyPlatform :: FilePath -> Bool --- C:\\directory -isAbsoluteOnAnyPlatform (drive:':':'\\':_) = isAlpha drive --- UNC -isAbsoluteOnAnyPlatform ('\\':'\\':_) = True --- Posix root -isAbsoluteOnAnyPlatform ('/':_) = True -isAbsoluteOnAnyPlatform _ = False - --- | @isRelativeOnAnyPlatform = not . 'isAbsoluteOnAnyPlatform'@ -isRelativeOnAnyPlatform :: FilePath -> Bool -isRelativeOnAnyPlatform = not . isAbsoluteOnAnyPlatform - --- $setup --- >>> import Data.Maybe --- >>> import Text.Read diff --git a/cabal/Cabal/Distribution/Utils/IOData.hs b/cabal/Cabal/Distribution/Utils/IOData.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Utils/IOData.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} --- | @since 2.2.0 -module Distribution.Utils.IOData - ( -- * 'IOData' & 'IODataMode' type - IOData (..) - , IODataMode (..) - , KnownIODataMode (..) - , withIOData - , null - , hPutContents - ) where - -import qualified Data.ByteString.Lazy as LBS -import Distribution.Compat.Prelude hiding (null) -import qualified Prelude -import qualified System.IO - --- | Represents either textual or binary data passed via I/O functions --- which support binary/text mode --- --- @since 2.2 -data IOData - = IODataText String - -- ^ How Text gets encoded is usually locale-dependent. - | IODataBinary LBS.ByteString - -- ^ Raw binary which gets read/written in binary mode. - -withIOData :: IOData -> (forall mode. IODataMode mode -> mode -> r) -> r -withIOData (IODataText str) k = k IODataModeText str -withIOData (IODataBinary lbs) k = k IODataModeBinary lbs - --- | Test whether 'IOData' is empty -null :: IOData -> Bool -null (IODataText s) = Prelude.null s -null (IODataBinary b) = LBS.null b - -instance NFData IOData where - rnf (IODataText s) = rnf s - rnf (IODataBinary lbs) = rnf lbs - --- | @since 2.2 -class NFData mode => KnownIODataMode mode where - -- | 'IOData' Wrapper for 'System.IO.hGetContents' - -- - -- __Note__: This operation uses lazy I/O. Use 'NFData' to force all - -- data to be read and consequently the internal file handle to be - -- closed. - -- - hGetIODataContents :: System.IO.Handle -> Prelude.IO mode - - toIOData :: mode -> IOData - iodataMode :: IODataMode mode - --- | @since 3.2 -data IODataMode mode where - IODataModeText :: IODataMode String - IODataModeBinary :: IODataMode LBS.ByteString - -instance a ~ Char => KnownIODataMode [a] where - hGetIODataContents h = do - System.IO.hSetBinaryMode h False - System.IO.hGetContents h - - toIOData = IODataText - iodataMode = IODataModeText - -instance KnownIODataMode LBS.ByteString where - hGetIODataContents h = do - System.IO.hSetBinaryMode h True - LBS.hGetContents h - - toIOData = IODataBinary - iodataMode = IODataModeBinary - --- | 'IOData' Wrapper for 'System.IO.hPutStr' and 'System.IO.hClose' --- --- This is the dual operation ot 'hGetIODataContents', --- and consequently the handle is closed with `hClose`. --- --- /Note:/ this performs lazy-IO. --- --- @since 2.2 -hPutContents :: System.IO.Handle -> IOData -> Prelude.IO () -hPutContents h (IODataText c) = do - System.IO.hSetBinaryMode h False - System.IO.hPutStr h c - System.IO.hClose h -hPutContents h (IODataBinary c) = do - System.IO.hSetBinaryMode h True - LBS.hPutStr h c - System.IO.hClose h diff --git a/cabal/Cabal/Distribution/Utils/LogProgress.hs b/cabal/Cabal/Distribution/Utils/LogProgress.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Utils/LogProgress.hs +++ /dev/null @@ -1,89 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE FlexibleContexts #-} -module Distribution.Utils.LogProgress ( - LogProgress, - runLogProgress, - warnProgress, - infoProgress, - dieProgress, - addProgressCtx, -) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Utils.Progress -import Distribution.Verbosity -import Distribution.Simple.Utils -import Text.PrettyPrint - -type CtxMsg = Doc -type LogMsg = Doc -type ErrMsg = Doc - -data LogEnv = LogEnv { - le_verbosity :: Verbosity, - le_context :: [CtxMsg] - } - --- | The 'Progress' monad with specialized logging and --- error messages. -newtype LogProgress a = LogProgress { unLogProgress :: LogEnv -> Progress LogMsg ErrMsg a } - -instance Functor LogProgress where - fmap f (LogProgress m) = LogProgress (fmap (fmap f) m) - -instance Applicative LogProgress where - pure x = LogProgress (pure (pure x)) - LogProgress f <*> LogProgress x = LogProgress $ \r -> f r `ap` x r - -instance Monad LogProgress where - return = pure - LogProgress m >>= f = LogProgress $ \r -> m r >>= \x -> unLogProgress (f x) r - --- | Run 'LogProgress', outputting traces according to 'Verbosity', --- 'die' if there is an error. -runLogProgress :: Verbosity -> LogProgress a -> IO a -runLogProgress verbosity (LogProgress m) = - foldProgress step_fn fail_fn return (m env) - where - env = LogEnv { - le_verbosity = verbosity, - le_context = [] - } - step_fn :: LogMsg -> IO a -> IO a - step_fn doc go = do - putStrLn (render doc) - go - fail_fn :: Doc -> IO a - fail_fn doc = do - dieNoWrap verbosity (render doc) - --- | Output a warning trace message in 'LogProgress'. -warnProgress :: Doc -> LogProgress () -warnProgress s = LogProgress $ \env -> - when (le_verbosity env >= normal) $ - stepProgress $ - hang (text "Warning:") 4 (formatMsg (le_context env) s) - --- | Output an informational trace message in 'LogProgress'. -infoProgress :: Doc -> LogProgress () -infoProgress s = LogProgress $ \env -> - when (le_verbosity env >= verbose) $ - stepProgress s - --- | Fail the computation with an error message. -dieProgress :: Doc -> LogProgress a -dieProgress s = LogProgress $ \env -> - failProgress $ - hang (text "Error:") 4 (formatMsg (le_context env) s) - --- | Format a message with context. (Something simple for now.) -formatMsg :: [CtxMsg] -> Doc -> Doc -formatMsg ctx doc = doc $$ vcat ctx - --- | Add a message to the error/warning context. -addProgressCtx :: CtxMsg -> LogProgress a -> LogProgress a -addProgressCtx s (LogProgress m) = LogProgress $ \env -> - m env { le_context = s : le_context env } diff --git a/cabal/Cabal/Distribution/Utils/MD5.hs b/cabal/Cabal/Distribution/Utils/MD5.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Utils/MD5.hs +++ /dev/null @@ -1,79 +0,0 @@ -module Distribution.Utils.MD5 ( - MD5, - showMD5, - md5, - -- * Helpers - md5FromInteger, - -- * Binary - binaryPutMD5, - binaryGetMD5, - ) where - -import Data.Binary (Get, Put) -import Data.Binary.Get (getWord64le) -import Data.Binary.Put (putWord64le) -import Data.Bits (complement, shiftR, (.&.)) -import Foreign.Ptr (castPtr) -import GHC.Fingerprint (Fingerprint (..), fingerprintData) -import Numeric (showHex) -import System.IO.Unsafe (unsafeDupablePerformIO) - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Unsafe as BS - -type MD5 = Fingerprint - --- | Show 'MD5' in human readable form --- --- >>> showMD5 (Fingerprint 123 456) --- "000000000000007b00000000000001c8" --- --- >>> showMD5 $ md5 $ BS.pack [0..127] --- "37eff01866ba3f538421b30b7cbefcac" --- --- @since 3.2.0.0 -showMD5 :: MD5 -> String -showMD5 (Fingerprint a b) = pad a' ++ pad b' where - a' = showHex a "" - b' = showHex b "" - pad s = replicate (16 - length s) '0' ++ s - --- | @since 3.2.0.0 -md5 :: BS.ByteString -> MD5 -md5 bs = unsafeDupablePerformIO $ BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> - fingerprintData (castPtr ptr) len - --- | @since 3.2.0.0 -binaryPutMD5 :: MD5 -> Put -binaryPutMD5 (Fingerprint a b) = do - putWord64le a - putWord64le b - --- | @since 3.2.0.0 -binaryGetMD5 :: Get MD5 -binaryGetMD5 = do - a <- getWord64le - b <- getWord64le - return (Fingerprint a b) - --- | --- --- >>> showMD5 $ md5FromInteger 0x37eff01866ba3f538421b30b7cbefcac --- "37eff01866ba3f538421b30b7cbefcac" --- --- Note: the input is truncated: --- --- >>> showMD5 $ md5FromInteger 0x1230000037eff01866ba3f538421b30b7cbefcac --- "37eff01866ba3f538421b30b7cbefcac" --- --- Yet, negative numbers are not a problem... --- --- >>> showMD5 $ md5FromInteger (-1) --- "ffffffffffffffffffffffffffffffff" --- --- @since 3.4.0.0 -md5FromInteger :: Integer -> MD5 -md5FromInteger i = Fingerprint hi lo where - mask = complement 0 - lo = mask .&. fromInteger i - hi = mask .&. fromInteger (i `shiftR` 64) diff --git a/cabal/Cabal/Distribution/Utils/MapAccum.hs b/cabal/Cabal/Distribution/Utils/MapAccum.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Utils/MapAccum.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE CPP #-} -module Distribution.Utils.MapAccum (mapAccumM) where - -import Distribution.Compat.Prelude -import Prelude () - --- Like StateT but with return tuple swapped -newtype StateM s m a = StateM { runStateM :: s -> m (s, a) } - -instance Functor m => Functor (StateM s m) where - fmap f (StateM x) = StateM $ \s -> fmap (\(s', a) -> (s', f a)) (x s) - -instance -#if __GLASGOW_HASKELL__ < 709 - (Functor m, Monad m) -#else - Monad m -#endif - => Applicative (StateM s m) where - pure x = StateM $ \s -> return (s, x) - StateM f <*> StateM x = StateM $ \s -> do (s', f') <- f s - (s'', x') <- x s' - return (s'', f' x') - --- | Monadic variant of 'mapAccumL'. -mapAccumM :: -#if __GLASGOW_HASKELL__ < 709 - (Functor m, Monad m, Traversable t) -#else - (Monad m, Traversable t) -#endif - => (a -> b -> m (a, c)) -> a -> t b -> m (a, t c) -mapAccumM f s t = runStateM (traverse (\x -> StateM (\s' -> f s' x)) t) s - diff --git a/cabal/Cabal/Distribution/Utils/NubList.hs b/cabal/Cabal/Distribution/Utils/NubList.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Utils/NubList.hs +++ /dev/null @@ -1,108 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Distribution.Utils.NubList - ( NubList -- opaque - , toNubList -- smart construtor - , fromNubList - , overNubList - - , NubListR - , toNubListR - , fromNubListR - , overNubListR - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Simple.Utils - -import qualified Text.Read as R - --- | NubList : A de-duplicated list that maintains the original order. -newtype NubList a = - NubList { fromNubList :: [a] } - deriving (Eq, Generic, Typeable) - --- NubList assumes that nub retains the list order while removing duplicate --- elements (keeping the first occurrence). Documentation for "Data.List.nub" --- does not specifically state that ordering is maintained so we will add a test --- for that to the test suite. - --- | Smart constructor for the NubList type. -toNubList :: Ord a => [a] -> NubList a -toNubList list = NubList $ ordNub list - --- | Lift a function over lists to a function over NubLists. -overNubList :: Ord a => ([a] -> [a]) -> NubList a -> NubList a -overNubList f (NubList list) = toNubList . f $ list - --- | Monoid operations on NubLists. --- For a valid Monoid instance we need to satistfy the required monoid laws; --- identity, associativity and closure. --- --- Identity : by inspection: --- mempty `mappend` NubList xs == NubList xs `mappend` mempty --- --- Associativity : by inspection: --- (NubList xs `mappend` NubList ys) `mappend` NubList zs --- == NubList xs `mappend` (NubList ys `mappend` NubList zs) --- --- Closure : appending two lists of type a and removing duplicates obviously --- does not change the type. - -instance Ord a => Monoid (NubList a) where - mempty = NubList [] - mappend = (<>) - -instance Ord a => Semigroup (NubList a) where - (NubList xs) <> (NubList ys) = NubList $ xs `listUnion` ys - -instance Show a => Show (NubList a) where - show (NubList list) = show list - -instance (Ord a, Read a) => Read (NubList a) where - readPrec = readNubList toNubList - --- | Helper used by NubList/NubListR's Read instances. -readNubList :: (Read a) => ([a] -> l a) -> R.ReadPrec (l a) -readNubList listToL = R.parens . R.prec 10 $ fmap listToL R.readPrec - --- | Binary instance for 'NubList a' is the same as for '[a]'. For 'put', we --- just pull off constructor and put the list. For 'get', we get the list and --- make a 'NubList' out of it using 'toNubList'. -instance (Ord a, Binary a) => Binary (NubList a) where - put (NubList l) = put l - get = fmap toNubList get - -instance Structured a => Structured (NubList a) - --- | NubListR : A right-biased version of 'NubList'. That is @toNubListR --- ["-XNoFoo", "-XFoo", "-XNoFoo"]@ will result in @["-XFoo", "-XNoFoo"]@, --- unlike the normal 'NubList', which is left-biased. Built on top of --- 'ordNubRight' and 'listUnionRight'. -newtype NubListR a = - NubListR { fromNubListR :: [a] } - deriving Eq - --- | Smart constructor for the NubListR type. -toNubListR :: Ord a => [a] -> NubListR a -toNubListR list = NubListR $ ordNubRight list - --- | Lift a function over lists to a function over NubListRs. -overNubListR :: Ord a => ([a] -> [a]) -> NubListR a -> NubListR a -overNubListR f (NubListR list) = toNubListR . f $ list - -instance Ord a => Monoid (NubListR a) where - mempty = NubListR [] - mappend = (<>) - -instance Ord a => Semigroup (NubListR a) where - (NubListR xs) <> (NubListR ys) = NubListR $ xs `listUnionRight` ys - -instance Show a => Show (NubListR a) where - show (NubListR list) = show list - -instance (Ord a, Read a) => Read (NubListR a) where - readPrec = readNubList toNubListR diff --git a/cabal/Cabal/Distribution/Utils/Progress.hs b/cabal/Cabal/Distribution/Utils/Progress.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Utils/Progress.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} --- Note: This module was copied from cabal-install. - --- | A progress monad, which we use to report failure and logging from --- otherwise pure code. -module Distribution.Utils.Progress - ( Progress - , stepProgress - , failProgress - , foldProgress - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import qualified Data.Monoid as Mon - - --- | A type to represent the unfolding of an expensive long running --- calculation that may fail (or maybe not expensive, but complicated!) --- We may get intermediate steps before the final --- result which may be used to indicate progress and\/or logging messages. --- --- TODO: Apply Codensity to avoid left-associativity problem. --- See http://comonad.com/reader/2011/free-monads-for-less/ and --- http://blog.ezyang.com/2012/01/problem-set-the-codensity-transformation/ --- -data Progress step fail done = Step step (Progress step fail done) - | Fail fail - | Done done - deriving (Functor) - --- | Emit a step and then continue. --- -stepProgress :: step -> Progress step fail () -stepProgress step = Step step (Done ()) - --- | Fail the computation. -failProgress :: fail -> Progress step fail done -failProgress err = Fail err - --- | Consume a 'Progress' calculation. Much like 'foldr' for lists but with two --- base cases, one for a final result and one for failure. --- --- Eg to convert into a simple 'Either' result use: --- --- > foldProgress (flip const) Left Right --- -foldProgress :: (step -> a -> a) -> (fail -> a) -> (done -> a) - -> Progress step fail done -> a -foldProgress step err done = fold - where fold (Step s p) = step s (fold p) - fold (Fail f) = err f - fold (Done r) = done r - -instance Monad (Progress step fail) where - return = pure - p >>= f = foldProgress Step Fail f p - -instance Applicative (Progress step fail) where - pure a = Done a - p <*> x = foldProgress Step Fail (flip fmap x) p - -instance Monoid fail => Alternative (Progress step fail) where - empty = Fail Mon.mempty - p <|> q = foldProgress Step (const q) Done p diff --git a/cabal/Cabal/Distribution/Utils/ShortText.hs b/cabal/Cabal/Distribution/Utils/ShortText.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Utils/ShortText.hs +++ /dev/null @@ -1,159 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - --- | Compact representation of short 'Strings' --- --- This module is designed to be import qualifeid --- --- @ --- import Distribution.Utils.ShortText (ShortText) --- import qualified Distribution.Utils.ShortText as ShortText --- @ -module Distribution.Utils.ShortText - ( -- * 'ShortText' type - ShortText - , toShortText - , fromShortText - , unsafeFromUTF8BS - - -- * Operations - , null - , length - - -- * internal utilities - , decodeStringUtf8 - , encodeStringUtf8 - ) where - -import Distribution.Compat.Prelude hiding (length, null) -import Prelude () - -import Distribution.Utils.String (decodeStringUtf8, encodeStringUtf8) -import Distribution.Utils.Structured (Structured (..), nominalStructure) - -#if defined(MIN_VERSION_bytestring) -# if MIN_VERSION_bytestring(0,10,4) -# define HAVE_SHORTBYTESTRING 1 -# endif -#endif - --- Hack for GHC bootstrapping --- --- Currently (as of GHC 8.1), GHC bootstraps Cabal by building --- binary and Cabal in one giant ghc --make command. This --- means no MIN_VERSION_binary macro is available. --- --- We could try to cleverly figure something out in this case, --- but there is a better plan: just use the unoptimized version --- of the Binary instance. We're not going to use it for anything --- real in any case. --- --- WARNING: Don't use MIN_VERSION_binary to smooth over a BC-break! --- -#ifndef MIN_VERSION_binary -#define MIN_VERSION_binary(x, y, z) 0 -#endif - -import qualified Data.ByteString as BS -import qualified Data.List as List - -#if HAVE_SHORTBYTESTRING -import qualified Data.ByteString.Short as BS.Short -#else -import Distribution.Utils.Generic (fromUTF8BS) -#endif - --- | Construct 'ShortText' from 'String' -toShortText :: String -> ShortText - --- | Convert 'ShortText' to 'String' -fromShortText :: ShortText -> String - --- | Convert from UTF-8 encoded strict 'ByteString'. --- --- @since 3.2.0.0 -unsafeFromUTF8BS :: BS.ByteString -> ShortText - --- | Text whether 'ShortText' is empty. --- --- @since 3.2.0.0 -null :: ShortText -> Bool - --- | Compact representation of short 'Strings' --- --- The data is stored internally as UTF8 in an --- 'BS.Short.ShortByteString' when compiled against @bytestring >= --- 0.10.4@, and otherwise the fallback is to use plain old non-compat --- '[Char]'. --- --- Note: This type is for internal uses (such as e.g. 'PackageName') --- and shall not be exposed in Cabal's API --- --- @since 2.0.0.2 -#if HAVE_SHORTBYTESTRING -newtype ShortText = ST { unST :: BS.Short.ShortByteString } - deriving (Eq,Ord,Generic,Data,Typeable) - -# if MIN_VERSION_binary(0,8,1) -instance Binary ShortText where - put = put . unST - get = fmap ST get -# else -instance Binary ShortText where - put = put . BS.Short.fromShort . unST - get = fmap (ST . BS.Short.toShort) get -# endif - - -toShortText = ST . BS.Short.pack . encodeStringUtf8 - -fromShortText = decodeStringUtf8 . BS.Short.unpack . unST - -unsafeFromUTF8BS = ST . BS.Short.toShort - -null = BS.Short.null . unST -#else -newtype ShortText = ST { unST :: String } - deriving (Eq,Ord,Generic,Data,Typeable) - -instance Binary ShortText where - put = put . encodeStringUtf8 . unST - get = fmap (ST . decodeStringUtf8) get - -toShortText = ST - -fromShortText = unST - -unsafeFromUTF8BS = ST . fromUTF8BS - -null = List.null . unST -#endif - -instance Structured ShortText where structure = nominalStructure - -instance NFData ShortText where - rnf = rnf . unST - -instance Show ShortText where - show = show . fromShortText - -instance Read ShortText where - readsPrec p = map (first toShortText) . readsPrec p - -instance Semigroup ShortText where - ST a <> ST b = ST (mappend a b) - -instance Monoid ShortText where - mempty = ST mempty - mappend = (<>) - -instance IsString ShortText where - fromString = toShortText - --- | /O(n)/. Length in characters. /Slow/ as converts to string. --- --- @since 3.2.0.0 -length :: ShortText -> Int -length = List.length . fromShortText --- Note: avoid using it, we use it @cabal check@ implementation, where it's ok. diff --git a/cabal/Cabal/Distribution/Utils/String.hs b/cabal/Cabal/Distribution/Utils/String.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Utils/String.hs +++ /dev/null @@ -1,93 +0,0 @@ -module Distribution.Utils.String - ( -- * Encode to/from UTF8 - decodeStringUtf8 - , encodeStringUtf8 - ) where - -import Data.Word -import Data.Bits -import Data.Char (chr,ord) - --- | Decode 'String' from UTF8-encoded octets. --- --- Invalid data in the UTF8 stream (this includes code-points @U+D800@ --- through @U+DFFF@) will be decoded as the replacement character (@U+FFFD@). --- --- See also 'encodeStringUtf8' -decodeStringUtf8 :: [Word8] -> String -decodeStringUtf8 = go - where - go :: [Word8] -> String - go [] = [] - go (c : cs) - | c <= 0x7F = chr (fromIntegral c) : go cs - | c <= 0xBF = replacementChar : go cs - | c <= 0xDF = twoBytes c cs - | c <= 0xEF = moreBytes 3 0x800 cs (fromIntegral $ c .&. 0xF) - | c <= 0xF7 = moreBytes 4 0x10000 cs (fromIntegral $ c .&. 0x7) - | c <= 0xFB = moreBytes 5 0x200000 cs (fromIntegral $ c .&. 0x3) - | c <= 0xFD = moreBytes 6 0x4000000 cs (fromIntegral $ c .&. 0x1) - | otherwise = replacementChar : go cs - - twoBytes :: Word8 -> [Word8] -> String - twoBytes c0 (c1:cs') - | c1 .&. 0xC0 == 0x80 - = let d = (fromIntegral (c0 .&. 0x1F) `shiftL` 6) - .|. fromIntegral (c1 .&. 0x3F) - in if d >= 0x80 - then chr d : go cs' - else replacementChar : go cs' - twoBytes _ cs' = replacementChar : go cs' - - moreBytes :: Int -> Int -> [Word8] -> Int -> [Char] - moreBytes 1 overlong cs' acc - | overlong <= acc, acc <= 0x10FFFF, acc < 0xD800 || 0xDFFF < acc - = chr acc : go cs' - - | otherwise - = replacementChar : go cs' - - moreBytes byteCount overlong (cn:cs') acc - | cn .&. 0xC0 == 0x80 - = moreBytes (byteCount-1) overlong cs' - ((acc `shiftL` 6) .|. fromIntegral cn .&. 0x3F) - - moreBytes _ _ cs' _ - = replacementChar : go cs' - - replacementChar = '\xfffd' - - --- | Encode 'String' to a list of UTF8-encoded octets --- --- Code-points in the @U+D800@-@U+DFFF@ range will be encoded --- as the replacement character (i.e. @U+FFFD@). --- --- See also 'decodeUtf8' -encodeStringUtf8 :: String -> [Word8] -encodeStringUtf8 [] = [] -encodeStringUtf8 (c:cs) - | c <= '\x07F' = w8 - : encodeStringUtf8 cs - | c <= '\x7FF' = (0xC0 .|. w8ShiftR 6 ) - : (0x80 .|. (w8 .&. 0x3F)) - : encodeStringUtf8 cs - | c <= '\xD7FF'= (0xE0 .|. w8ShiftR 12 ) - : (0x80 .|. (w8ShiftR 6 .&. 0x3F)) - : (0x80 .|. (w8 .&. 0x3F)) - : encodeStringUtf8 cs - | c <= '\xDFFF'= 0xEF : 0xBF : 0xBD -- U+FFFD - : encodeStringUtf8 cs - | c <= '\xFFFF'= (0xE0 .|. w8ShiftR 12 ) - : (0x80 .|. (w8ShiftR 6 .&. 0x3F)) - : (0x80 .|. (w8 .&. 0x3F)) - : encodeStringUtf8 cs - | otherwise = (0xf0 .|. w8ShiftR 18 ) - : (0x80 .|. (w8ShiftR 12 .&. 0x3F)) - : (0x80 .|. (w8ShiftR 6 .&. 0x3F)) - : (0x80 .|. (w8 .&. 0x3F)) - : encodeStringUtf8 cs - where - w8 = fromIntegral (ord c) :: Word8 - w8ShiftR :: Int -> Word8 - w8ShiftR = fromIntegral . shiftR (ord c) diff --git a/cabal/Cabal/Distribution/Utils/Structured.hs b/cabal/Cabal/Distribution/Utils/Structured.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Utils/Structured.hs +++ /dev/null @@ -1,472 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -#if __GLASGOW_HASKELL__ >= 711 -{-# LANGUAGE PatternSynonyms #-} -#endif -#if __GLASGOW_HASKELL__ >= 800 -{-# LANGUAGE TypeInType #-} -#endif --- | --- --- Copyright: (c) 2019 Oleg Grenrus --- --- Structurally tag binary serialisaton stream. --- Useful when most 'Binary' instances are 'Generic' derived. --- --- Say you have a data type --- --- @ --- data Record = Record --- { _recordFields :: HM.HashMap Text (Integer, ByteString) --- , _recordEnabled :: Bool --- } --- deriving (Eq, Show, Generic) --- --- instance 'Binary' Record --- instance 'Structured' Record --- @ --- --- then you can serialise and deserialise @Record@ values with a structure tag by simply --- --- @ --- 'structuredEncode' record :: 'LBS.ByteString' --- 'structuredDecode' lbs :: IO Record --- @ --- --- If structure of @Record@ changes in between, deserialisation will fail early. --- --- Technically, 'Structured' is not related to 'Binary', and may --- be useful in other uses. --- -module Distribution.Utils.Structured ( - -- * Encoding and decoding - -- | These functions operate like @binary@'s counterparts, - -- but the serialised version has a structure hash in front. - structuredEncode, - structuredEncodeFile, - structuredDecode, - structuredDecodeOrFailIO, - structuredDecodeFileOrFail, - -- * Structured class - Structured (structure), - MD5, - structureHash, - structureBuilder, - genericStructure, - GStructured, - nominalStructure, - containerStructure, - -- * Structure type - Structure (..), - TypeName, - ConstructorName, - TypeVersion, - SopStructure, - hashStructure, - typeVersion, - typeName, - ) where - -import Data.Int (Int16, Int32, Int64, Int8) -import Data.List.NonEmpty (NonEmpty) -import Data.Proxy (Proxy (..)) -import Data.Ratio (Ratio) -import Data.Word (Word, Word16, Word32, Word64, Word8) - -import qualified Control.Monad.Trans.State.Strict as State - -import Control.Exception (ErrorCall (..), catch, evaluate) - -import GHC.Generics - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LBS -import qualified Data.ByteString.Lazy.Builder as Builder -import qualified Data.IntMap as IM -import qualified Data.IntSet as IS -import qualified Data.Map as Map -import qualified Data.Sequence as Seq -import qualified Data.Set as Set -import qualified Data.Text as T -import qualified Data.Text.Lazy as LT -import qualified Data.Time as Time -import qualified Distribution.Compat.Binary as Binary - -#ifdef MIN_VERSION_aeson -import qualified Data.Aeson as Aeson -#endif - -#if __GLASGOW_HASKELL__ >= 800 -import Data.Kind (Type) -#else -#define Type * -#endif - -import Distribution.Compat.Typeable (Typeable, TypeRep, typeRep) -import Distribution.Utils.MD5 - -import Data.Monoid (mconcat) - -import qualified Data.Semigroup -import qualified Data.Foldable - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative (pure) -import Data.Traversable (traverse) -#endif - -#if !MIN_VERSION_base(4,7,0) -import Data.Typeable (Typeable1, typeOf1) -#endif - - -------------------------------------------------------------------------------- --- Types -------------------------------------------------------------------------------- - -type TypeName = String -type ConstructorName = String - --- | A sematic version of a data type. Usually 0. -type TypeVersion = Word32 - --- | Structure of a datatype. --- --- It can be infinite, as far as 'TypeRep's involved are finite. --- (e.g. polymorphic recursion might cause troubles). --- -data Structure - = Nominal !TypeRep !TypeVersion TypeName [Structure] -- ^ nominal, yet can be parametrised by other structures. - | Newtype !TypeRep !TypeVersion TypeName Structure -- ^ a newtype wrapper - | Structure !TypeRep !TypeVersion TypeName SopStructure -- ^ sum-of-products structure - deriving (Eq, Ord, Show, Generic) - -type SopStructure = [(ConstructorName, [Structure])] - --- | A MD5 hash digest of 'Structure'. -hashStructure :: Structure -> MD5 -hashStructure = md5 . LBS.toStrict . Builder.toLazyByteString . structureBuilder - --- | A van-Laarhoven lens into 'TypeVersion' of 'Structure' --- --- @ --- 'typeVersion' :: Lens' 'Structure' 'TypeVersion' --- @ -typeVersion :: Functor f => (TypeVersion -> f TypeVersion) -> Structure -> f Structure -typeVersion f (Nominal t v n s) = fmap (\v' -> Nominal t v' n s) (f v) -typeVersion f (Newtype t v n s) = fmap (\v' -> Newtype t v' n s) (f v) -typeVersion f (Structure t v n s) = fmap (\v' -> Structure t v' n s) (f v) - --- | A van-Laarhoven lens into 'TypeName' of 'Structure' --- --- @ --- 'typeName' :: Lens' 'Structure' 'TypeName' --- @ -typeName :: Functor f => (TypeName -> f TypeName) -> Structure -> f Structure -typeName f (Nominal t v n s) = fmap (\n' -> Nominal t v n' s) (f n) -typeName f (Newtype t v n s) = fmap (\n' -> Newtype t v n' s) (f n) -typeName f (Structure t v n s) = fmap (\n' -> Structure t v n' s) (f n) - -------------------------------------------------------------------------------- --- Builder -------------------------------------------------------------------------------- - --- | Flatten 'Structure' into something we can calculate hash of. --- --- As 'Structure' can be potentially infinite. For mutually recursive types, --- we keep track of 'TypeRep's, and put just 'TypeRep' name when it's occurred --- another time. -structureBuilder :: Structure -> Builder.Builder -structureBuilder s0 = State.evalState (go s0) Map.empty where - go :: Structure -> State.State (Map.Map String (NonEmpty TypeRep)) Builder.Builder - go (Nominal t v n s) = withTypeRep t $ do - s' <- traverse go s - return $ mconcat $ Builder.word8 1 : Builder.word32LE v : Builder.stringUtf8 n : s' - - go (Newtype t v n s) = withTypeRep t $ do - s' <- go s - return $ mconcat [Builder.word8 2, Builder.word32LE v, Builder.stringUtf8 n, s'] - - go (Structure t v n s) = withTypeRep t $ do - s' <- goSop s - return $ mconcat [Builder.word8 3, Builder.word32LE v, Builder.stringUtf8 n, s'] - - withTypeRep t k = do - acc <- State.get - case insert t acc of - Nothing -> return $ mconcat [ Builder.word8 0, Builder.stringUtf8 (show t) ] - Just acc' -> do - State.put acc' - k - - goSop :: SopStructure -> State.State (Map.Map String (NonEmpty TypeRep)) Builder.Builder - goSop sop = do - parts <- traverse part sop - return $ mconcat parts - - part (cn, s) = do - s' <- traverse go s - return $ Data.Monoid.mconcat [ Builder.stringUtf8 cn, mconcat s' ] - - insert :: TypeRep -> Map.Map String (NonEmpty TypeRep) -> Maybe (Map.Map String (NonEmpty TypeRep)) - insert tr m = case Map.lookup trShown m of - Nothing -> inserted - Just ne | tr `Data.Foldable.elem` ne -> Nothing - | otherwise -> inserted - where - inserted = Just (Map.insertWith (Data.Semigroup.<>) trShown (pure tr) m) - trShown = show tr - -------------------------------------------------------------------------------- --- Classes -------------------------------------------------------------------------------- - --- | Class of types with a known 'Structure'. --- --- For regular data types 'Structured' can be derived generically. --- --- @ --- data Record = Record { a :: Int, b :: Bool, c :: [Char] } deriving ('Generic') --- instance 'Structured' Record --- @ --- --- @since 3.2.0.0 --- -class Typeable a => Structured a where - structure :: Proxy a -> Structure - default structure :: (Generic a, GStructured (Rep a)) => Proxy a -> Structure - structure = genericStructure - - -- This member is hidden. It's there to precalc - structureHash' :: Tagged a MD5 - structureHash' = Tagged (hashStructure (structure (Proxy :: Proxy a))) - --- private Tagged -newtype Tagged a b = Tagged { untag :: b } - --- | Semantically @'hashStructure' . 'structure'@. -structureHash :: forall a. Structured a => Proxy a -> MD5 -structureHash _ = untag (structureHash' :: Tagged a MD5) - -------------------------------------------------------------------------------- --- Functions -------------------------------------------------------------------------------- - --- | Structured 'Binary.encode'. --- Encode a value to using binary serialisation to a lazy 'LBS.ByteString'. --- Encoding starts with 16 byte large structure hash. -structuredEncode - :: forall a. (Binary.Binary a, Structured a) - => a -> LBS.ByteString -structuredEncode x = Binary.encode (Tag :: Tag a, x) - --- | Lazily serialise a value to a file -structuredEncodeFile :: (Binary.Binary a, Structured a) => FilePath -> a -> IO () -structuredEncodeFile f = LBS.writeFile f . structuredEncode - --- | Structured 'Binary.decode'. --- Decode a value from a lazy 'LBS.ByteString', reconstructing the original structure. --- Throws pure exception on invalid inputs. -structuredDecode - :: forall a. (Binary.Binary a, Structured a) - => LBS.ByteString -> a -structuredDecode lbs = snd (Binary.decode lbs :: (Tag a, a)) - -structuredDecodeOrFailIO :: (Binary.Binary a, Structured a) => LBS.ByteString -> IO (Either String a) -structuredDecodeOrFailIO bs = - catch (evaluate (structuredDecode bs) >>= return . Right) handler - where -#if MIN_VERSION_base(4,9,0) - handler (ErrorCallWithLocation str _) = return $ Left str -#else - handler (ErrorCall str) = return $ Left str -#endif - --- | Lazily reconstruct a value previously written to a file. -structuredDecodeFileOrFail :: (Binary.Binary a, Structured a) => FilePath -> IO (Either String a) -structuredDecodeFileOrFail f = structuredDecodeOrFailIO =<< LBS.readFile f - -------------------------------------------------------------------------------- --- Helper data -------------------------------------------------------------------------------- - -data Tag a = Tag - -instance Structured a => Binary.Binary (Tag a) where - get = do - actual <- binaryGetMD5 - if actual == expected - then return Tag - else fail $ concat - [ "Non-matching structured hashes: " - , showMD5 actual - , "; expected: " - , showMD5 expected - ] - where - expected = untag (structureHash' :: Tagged a MD5) - - put _ = binaryPutMD5 expected - where - expected = untag (structureHash' :: Tagged a MD5) - -------------------------------------------------------------------------------- --- Smart constructors -------------------------------------------------------------------------------- - --- | Use 'Typeable' to infer name -nominalStructure :: Typeable a => Proxy a -> Structure -nominalStructure p = Nominal tr 0 (show tr) [] where - tr = typeRep p - -#if MIN_VERSION_base(4,7,0) -containerStructure :: forall f a. (Typeable f, Structured a) => Proxy (f a) -> Structure -containerStructure _ = Nominal faTypeRep 0 (show fTypeRep) - [ structure (Proxy :: Proxy a) - ] - where - fTypeRep = typeRep (Proxy :: Proxy f) - faTypeRep = typeRep (Proxy :: Proxy (f a)) - -#else -containerStructure :: forall f a. (Typeable1 f, Structured a) => Proxy (f a) -> Structure -containerStructure _ = Nominal faTypeRep 0 (show fTypeRep) - [ structure (Proxy :: Proxy a) - ] - where - fTypeRep = typeOf1 (undefined :: f ()) - faTypeRep = typeRep (Proxy :: Proxy (f a)) -#endif - -------------------------------------------------------------------------------- --- Generic -------------------------------------------------------------------------------- - --- | Derive 'structure' genrically. -genericStructure :: forall a. (Typeable a, Generic a, GStructured (Rep a)) => Proxy a -> Structure -genericStructure _ = gstructured (typeRep (Proxy :: Proxy a)) (Proxy :: Proxy (Rep a)) 0 - --- | Used to implement 'genericStructure'. -class GStructured (f :: Type -> Type) where - gstructured :: TypeRep -> Proxy f -> TypeVersion -> Structure - -instance (i ~ D, Datatype c, GStructuredSum f) => GStructured (M1 i c f) where - gstructured tr _ v = case sop of -#if MIN_VERSION_base(4,7,0) - [(_, [s])] | isNewtype p -> Newtype tr v name s -#endif - _ -> Structure tr v name sop - where - p = undefined :: M1 i c f () - name = datatypeName p - sop = gstructuredSum (Proxy :: Proxy f) [] - -class GStructuredSum (f :: Type -> Type) where - gstructuredSum :: Proxy f -> SopStructure -> SopStructure - -instance (i ~ C, Constructor c, GStructuredProd f) => GStructuredSum (M1 i c f) where - gstructuredSum _ xs = (name, prod) : xs - where - name = conName (undefined :: M1 i c f ()) - prod = gstructuredProd (Proxy :: Proxy f) [] - -instance (GStructuredSum f, GStructuredSum g) => GStructuredSum (f :+: g) where - gstructuredSum _ xs - = gstructuredSum (Proxy :: Proxy f) - $ gstructuredSum (Proxy :: Proxy g) xs - -instance GStructuredSum V1 where - gstructuredSum _ = id - -class GStructuredProd (f :: Type -> Type) where - gstructuredProd :: Proxy f -> [Structure] -> [Structure] - -instance (i ~ S, GStructuredProd f) => GStructuredProd (M1 i c f) where - gstructuredProd _ = gstructuredProd (Proxy :: Proxy f) - -instance Structured c => GStructuredProd (K1 i c) where - gstructuredProd _ xs = structure (Proxy :: Proxy c) : xs - -instance GStructuredProd U1 where - gstructuredProd _ = id - -instance (GStructuredProd f, GStructuredProd g) => GStructuredProd (f :*: g) where - gstructuredProd _ xs - = gstructuredProd (Proxy :: Proxy f) - $ gstructuredProd (Proxy :: Proxy g) xs - -------------------------------------------------------------------------------- --- instances -------------------------------------------------------------------------------- - -instance Structured () -instance Structured Bool -instance Structured Ordering - -instance Structured Char where structure = nominalStructure -instance Structured Int where structure = nominalStructure -instance Structured Integer where structure = nominalStructure - -instance Structured Data.Word.Word where structure = nominalStructure - -instance Structured Int8 where structure = nominalStructure -instance Structured Int16 where structure = nominalStructure -instance Structured Int32 where structure = nominalStructure -instance Structured Int64 where structure = nominalStructure - -instance Structured Word8 where structure = nominalStructure -instance Structured Word16 where structure = nominalStructure -instance Structured Word32 where structure = nominalStructure -instance Structured Word64 where structure = nominalStructure - -instance Structured Float where structure = nominalStructure -instance Structured Double where structure = nominalStructure - -instance Structured a => Structured (Maybe a) -instance (Structured a, Structured b) => Structured (Either a b) -instance Structured a => Structured (Ratio a) where structure = containerStructure -instance Structured a => Structured [a] where structure = containerStructure -instance Structured a => Structured (NonEmpty a) where structure = containerStructure - -instance (Structured a1, Structured a2) => Structured (a1, a2) -instance (Structured a1, Structured a2, Structured a3) => Structured (a1, a2, a3) -instance (Structured a1, Structured a2, Structured a3, Structured a4) => Structured (a1, a2, a3, a4) -instance (Structured a1, Structured a2, Structured a3, Structured a4, Structured a5) => Structured (a1, a2, a3, a4, a5) -instance (Structured a1, Structured a2, Structured a3, Structured a4, Structured a5, Structured a6) => Structured (a1, a2, a3, a4, a5, a6) -instance (Structured a1, Structured a2, Structured a3, Structured a4, Structured a5, Structured a6, Structured a7) => Structured (a1, a2, a3, a4, a5, a6, a7) - -instance Structured BS.ByteString where structure = nominalStructure -instance Structured LBS.ByteString where structure = nominalStructure - -instance Structured T.Text where structure = nominalStructure -instance Structured LT.Text where structure = nominalStructure - -instance (Structured k, Structured v) => Structured (Map.Map k v) where structure _ = Nominal (typeRep (Proxy :: Proxy (Map.Map k v))) 0 "Map" [ structure (Proxy :: Proxy k), structure (Proxy :: Proxy v) ] -instance (Structured k) => Structured (Set.Set k) where structure = containerStructure -instance (Structured v) => Structured (IM.IntMap v) where structure = containerStructure -instance Structured IS.IntSet where structure = nominalStructure -instance (Structured v) => Structured (Seq.Seq v) where structure = containerStructure - -instance Structured Time.UTCTime where structure = nominalStructure -instance Structured Time.DiffTime where structure = nominalStructure -instance Structured Time.UniversalTime where structure = nominalStructure -instance Structured Time.NominalDiffTime where structure = nominalStructure -instance Structured Time.Day where structure = nominalStructure -instance Structured Time.TimeZone where structure = nominalStructure -instance Structured Time.TimeOfDay where structure = nominalStructure -instance Structured Time.LocalTime where structure = nominalStructure - --- Proxy isn't Typeable in base-4.8 / base - --- #if __GLASGOW_HASKELL__ >= 800 --- instance (Typeable k, Typeable (a :: k)) => Structured (Proxy a) --- #else --- instance (Typeable a) => Structured (Proxy a) where --- structure p = Structure (typeRep p) 0 "Proxy" [("Proxy",[])] --- #endif diff --git a/cabal/Cabal/Distribution/Utils/UnionFind.hs b/cabal/Cabal/Distribution/Utils/UnionFind.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Utils/UnionFind.hs +++ /dev/null @@ -1,102 +0,0 @@ -{-# LANGUAGE NondecreasingIndentation #-} --- | A simple mutable union-find data structure. --- --- It is used in a unification algorithm for backpack mix-in linking. --- --- This implementation is based off of the one in \"The Essence of ML Type --- Inference\". (N.B. the union-find package is also based off of this.) --- -module Distribution.Utils.UnionFind ( - Point, - fresh, - find, - union, - equivalent, -) where - -import Data.STRef -import Control.Monad -import Control.Monad.ST - --- | A variable which can be unified; alternately, this can be thought --- of as an equivalence class with a distinguished representative. -newtype Point s a = Point (STRef s (Link s a)) - deriving (Eq) - --- | Mutable write to a 'Point' -writePoint :: Point s a -> Link s a -> ST s () -writePoint (Point v) = writeSTRef v - --- | Read the current value of 'Point'. -readPoint :: Point s a -> ST s (Link s a) -readPoint (Point v) = readSTRef v - --- | The internal data structure for a 'Point', which either records --- the representative element of an equivalence class, or a link to --- the 'Point' that actually stores the representative type. -data Link s a - -- NB: it is too bad we can't say STRef Int#; the weights remain boxed - = Info {-# UNPACK #-} !(STRef s Int) {-# UNPACK #-} !(STRef s a) - | Link {-# UNPACK #-} !(Point s a) - --- | Create a fresh equivalence class with one element. -fresh :: a -> ST s (Point s a) -fresh desc = do - weight <- newSTRef 1 - descriptor <- newSTRef desc - Point `fmap` newSTRef (Info weight descriptor) - --- | Flatten any chains of links, returning a 'Point' --- which points directly to the canonical representation. -repr :: Point s a -> ST s (Point s a) -repr point = readPoint point >>= \r -> - case r of - Link point' -> do - point'' <- repr point' - when (point'' /= point') $ do - writePoint point =<< readPoint point' - return point'' - Info _ _ -> return point - --- | Return the canonical element of an equivalence --- class 'Point'. -find :: Point s a -> ST s a -find point = - -- Optimize length 0 and 1 case at expense of - -- general case - readPoint point >>= \r -> - case r of - Info _ d_ref -> readSTRef d_ref - Link point' -> readPoint point' >>= \r' -> - case r' of - Info _ d_ref -> readSTRef d_ref - Link _ -> repr point >>= find - --- | Unify two equivalence classes, so that they share --- a canonical element. Keeps the descriptor of point2. -union :: Point s a -> Point s a -> ST s () -union refpoint1 refpoint2 = do - point1 <- repr refpoint1 - point2 <- repr refpoint2 - when (point1 /= point2) $ do - l1 <- readPoint point1 - l2 <- readPoint point2 - case (l1, l2) of - (Info wref1 dref1, Info wref2 dref2) -> do - weight1 <- readSTRef wref1 - weight2 <- readSTRef wref2 - -- Should be able to optimize the == case separately - if weight1 >= weight2 - then do - writePoint point2 (Link point1) - -- The weight calculation here seems a bit dodgy - writeSTRef wref1 (weight1 + weight2) - writeSTRef dref1 =<< readSTRef dref2 - else do - writePoint point1 (Link point2) - writeSTRef wref2 (weight1 + weight2) - _ -> error "UnionFind.union: repr invariant broken" - --- | Test if two points are in the same equivalence class. -equivalent :: Point s a -> Point s a -> ST s Bool -equivalent point1 point2 = liftM2 (==) (repr point1) (repr point2) diff --git a/cabal/Cabal/Distribution/Verbosity.hs b/cabal/Cabal/Distribution/Verbosity.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Verbosity.hs +++ /dev/null @@ -1,345 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Verbosity --- Copyright : Ian Lynagh 2007 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- A 'Verbosity' type with associated utilities. --- --- There are 4 standard verbosity levels from 'silent', 'normal', --- 'verbose' up to 'deafening'. This is used for deciding what logging --- messages to print. --- --- Verbosity also is equipped with some internal settings which can be --- used to control at a fine granularity the verbosity of specific --- settings (e.g., so that you can trace only particular things you --- are interested in.) It's important to note that the instances --- for 'Verbosity' assume that this does not exist. - --- Verbosity for Cabal functions. - -module Distribution.Verbosity ( - -- * Verbosity - Verbosity, - silent, normal, verbose, deafening, - moreVerbose, lessVerbose, isVerboseQuiet, - intToVerbosity, flagToVerbosity, - showForCabal, showForGHC, - verboseNoFlags, verboseHasFlags, - modifyVerbosity, - - -- * Call stacks - verboseCallSite, verboseCallStack, - isVerboseCallSite, isVerboseCallStack, - - -- * Output markets - verboseMarkOutput, isVerboseMarkOutput, - verboseUnmarkOutput, - - -- * line-wrapping - verboseNoWrap, isVerboseNoWrap, - - -- * timestamps - verboseTimestamp, isVerboseTimestamp, - verboseNoTimestamp, - - -- * Stderr - verboseStderr, isVerboseStderr, - verboseNoStderr, - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.ReadE - -import Data.List (elemIndex) -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Verbosity.Internal -import Distribution.Utils.Generic (isAsciiAlpha) - -import qualified Data.Set as Set -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as PP - -data Verbosity = Verbosity { - vLevel :: VerbosityLevel, - vFlags :: Set VerbosityFlag, - vQuiet :: Bool - } deriving (Generic, Show, Read, Typeable) - -mkVerbosity :: VerbosityLevel -> Verbosity -mkVerbosity l = Verbosity { vLevel = l, vFlags = Set.empty, vQuiet = False } - -instance Eq Verbosity where - x == y = vLevel x == vLevel y - -instance Ord Verbosity where - compare x y = compare (vLevel x) (vLevel y) - -instance Enum Verbosity where - toEnum = mkVerbosity . toEnum - fromEnum = fromEnum . vLevel - -instance Bounded Verbosity where - minBound = mkVerbosity minBound - maxBound = mkVerbosity maxBound - -instance Binary Verbosity -instance Structured Verbosity - --- We shouldn't print /anything/ unless an error occurs in silent mode -silent :: Verbosity -silent = mkVerbosity Silent - --- Print stuff we want to see by default -normal :: Verbosity -normal = mkVerbosity Normal - --- Be more verbose about what's going on -verbose :: Verbosity -verbose = mkVerbosity Verbose - --- Not only are we verbose ourselves (perhaps even noisier than when --- being "verbose"), but we tell everything we run to be verbose too -deafening :: Verbosity -deafening = mkVerbosity Deafening - -moreVerbose :: Verbosity -> Verbosity -moreVerbose v = - case vLevel v of - Silent -> v -- silent should stay silent - Normal -> v { vLevel = Verbose } - Verbose -> v { vLevel = Deafening } - Deafening -> v - -lessVerbose :: Verbosity -> Verbosity -lessVerbose v = - verboseQuiet $ - case vLevel v of - Deafening -> v -- deafening stays deafening - Verbose -> v { vLevel = Normal } - Normal -> v { vLevel = Silent } - Silent -> v - --- | Combinator for transforming verbosity level while retaining the --- original hidden state. --- --- For instance, the following property holds --- --- prop> isVerboseNoWrap (modifyVerbosity (max verbose) v) == isVerboseNoWrap v --- --- __Note__: you can use @modifyVerbosity (const v1) v0@ to overwrite --- @v1@'s flags with @v0@'s flags. --- --- @since 2.0.1.0 -modifyVerbosity :: (Verbosity -> Verbosity) -> Verbosity -> Verbosity -modifyVerbosity f v = v { vLevel = vLevel (f v) } - -intToVerbosity :: Int -> Maybe Verbosity -intToVerbosity 0 = Just (mkVerbosity Silent) -intToVerbosity 1 = Just (mkVerbosity Normal) -intToVerbosity 2 = Just (mkVerbosity Verbose) -intToVerbosity 3 = Just (mkVerbosity Deafening) -intToVerbosity _ = Nothing - --- | Parser verbosity --- --- >>> explicitEitherParsec parsecVerbosity "normal" --- Right (Verbosity {vLevel = Normal, vFlags = fromList [], vQuiet = False}) --- --- >>> explicitEitherParsec parsecVerbosity "normal+nowrap " --- Right (Verbosity {vLevel = Normal, vFlags = fromList [VNoWrap], vQuiet = False}) --- --- >>> explicitEitherParsec parsecVerbosity "normal+nowrap +markoutput" --- Right (Verbosity {vLevel = Normal, vFlags = fromList [VNoWrap,VMarkOutput], vQuiet = False}) --- --- >>> explicitEitherParsec parsecVerbosity "normal +nowrap +markoutput" --- Right (Verbosity {vLevel = Normal, vFlags = fromList [VNoWrap,VMarkOutput], vQuiet = False}) --- --- >>> explicitEitherParsec parsecVerbosity "normal+nowrap+markoutput" --- Right (Verbosity {vLevel = Normal, vFlags = fromList [VNoWrap,VMarkOutput], vQuiet = False}) --- --- >>> explicitEitherParsec parsecVerbosity "deafening+nowrap+stdout+stderr+callsite+callstack" --- Right (Verbosity {vLevel = Deafening, vFlags = fromList [VCallStack,VCallSite,VNoWrap,VStderr], vQuiet = False}) --- --- /Note:/ this parser will eat trailing spaces. --- -instance Parsec Verbosity where - parsec = parsecVerbosity - -instance Pretty Verbosity where - pretty = PP.text . showForCabal - -parsecVerbosity :: CabalParsing m => m Verbosity -parsecVerbosity = parseIntVerbosity <|> parseStringVerbosity - where - parseIntVerbosity = do - i <- P.integral - case intToVerbosity i of - Just v -> return v - Nothing -> P.unexpected $ "Bad integral verbosity: " ++ show i ++ ". Valid values are 0..3" - - parseStringVerbosity = do - level <- parseVerbosityLevel - _ <- P.spaces - flags <- many (parseFlag <* P.spaces) - return $ foldl' (flip ($)) (mkVerbosity level) flags - - parseVerbosityLevel = do - token <- P.munch1 isAsciiAlpha - case token of - "silent" -> return Silent - "normal" -> return Normal - "verbose" -> return Verbose - "debug" -> return Deafening - "deafening" -> return Deafening - _ -> P.unexpected $ "Bad verbosity level: " ++ token - parseFlag = do - _ <- P.char '+' - token <- P.munch1 isAsciiAlpha - case token of - "callsite" -> return verboseCallSite - "callstack" -> return verboseCallStack - "nowrap" -> return verboseNoWrap - "markoutput" -> return verboseMarkOutput - "timestamp" -> return verboseTimestamp - "stderr" -> return verboseStderr - "stdout" -> return verboseNoStderr - _ -> P.unexpected $ "Bad verbosity flag: " ++ token - -flagToVerbosity :: ReadE Verbosity -flagToVerbosity = parsecToReadE id parsecVerbosity - -showForCabal :: Verbosity -> String -showForCabal v - | Set.null (vFlags v) - = maybe (error "unknown verbosity") show $ - elemIndex v [silent,normal,verbose,deafening] - | otherwise - = unwords - $ showLevel (vLevel v) - : concatMap showFlag (Set.toList (vFlags v)) - where - showLevel Silent = "silent" - showLevel Normal = "normal" - showLevel Verbose = "verbose" - showLevel Deafening = "debug" - - showFlag VCallSite = ["+callsite"] - showFlag VCallStack = ["+callstack"] - showFlag VNoWrap = ["+nowrap"] - showFlag VMarkOutput = ["+markoutput"] - showFlag VTimestamp = ["+timestamp"] - showFlag VStderr = ["+stderr"] - -showForGHC :: Verbosity -> String -showForGHC v = maybe (error "unknown verbosity") show $ - elemIndex v [silent,normal,__,verbose,deafening] - where __ = silent -- this will be always ignored by elemIndex - --- | Turn on verbose call-site printing when we log. -verboseCallSite :: Verbosity -> Verbosity -verboseCallSite = verboseFlag VCallSite - --- | Turn on verbose call-stack printing when we log. -verboseCallStack :: Verbosity -> Verbosity -verboseCallStack = verboseFlag VCallStack - --- | Turn on @-----BEGIN CABAL OUTPUT-----@ markers for output --- from Cabal (as opposed to GHC, or system dependent). -verboseMarkOutput :: Verbosity -> Verbosity -verboseMarkOutput = verboseFlag VMarkOutput - --- | Turn off marking; useful for suppressing nondeterministic output. -verboseUnmarkOutput :: Verbosity -> Verbosity -verboseUnmarkOutput = verboseNoFlag VMarkOutput - --- | Disable line-wrapping for log messages. -verboseNoWrap :: Verbosity -> Verbosity -verboseNoWrap = verboseFlag VNoWrap - --- | Mark the verbosity as quiet -verboseQuiet :: Verbosity -> Verbosity -verboseQuiet v = v { vQuiet = True } - --- | Turn on timestamps for log messages. -verboseTimestamp :: Verbosity -> Verbosity -verboseTimestamp = verboseFlag VTimestamp - --- | Turn off timestamps for log messages. -verboseNoTimestamp :: Verbosity -> Verbosity -verboseNoTimestamp = verboseNoFlag VTimestamp - --- | Turn on timestamps for log messages. --- --- @since 3.4.0.0 -verboseStderr :: Verbosity -> Verbosity -verboseStderr = verboseFlag VStderr - --- | Turn off timestamps for log messages. --- --- @since 3.4.0.0 -verboseNoStderr :: Verbosity -> Verbosity -verboseNoStderr = verboseNoFlag VStderr - --- | Helper function for flag enabling functions -verboseFlag :: VerbosityFlag -> (Verbosity -> Verbosity) -verboseFlag flag v = v { vFlags = Set.insert flag (vFlags v) } - --- | Helper function for flag disabling functions -verboseNoFlag :: VerbosityFlag -> (Verbosity -> Verbosity) -verboseNoFlag flag v = v { vFlags = Set.delete flag (vFlags v) } - --- | Turn off all flags -verboseNoFlags :: Verbosity -> Verbosity -verboseNoFlags v = v { vFlags = Set.empty } - -verboseHasFlags :: Verbosity -> Bool -verboseHasFlags = not . Set.null . vFlags - --- | Test if we should output call sites when we log. -isVerboseCallSite :: Verbosity -> Bool -isVerboseCallSite = isVerboseFlag VCallSite - --- | Test if we should output call stacks when we log. -isVerboseCallStack :: Verbosity -> Bool -isVerboseCallStack = isVerboseFlag VCallStack - --- | Test if we should output markets. -isVerboseMarkOutput :: Verbosity -> Bool -isVerboseMarkOutput = isVerboseFlag VMarkOutput - --- | Test if line-wrapping is disabled for log messages. -isVerboseNoWrap :: Verbosity -> Bool -isVerboseNoWrap = isVerboseFlag VNoWrap - --- | Test if we had called 'lessVerbose' on the verbosity -isVerboseQuiet :: Verbosity -> Bool -isVerboseQuiet = vQuiet - --- | Test if we should output timestamps when we log. -isVerboseTimestamp :: Verbosity -> Bool -isVerboseTimestamp = isVerboseFlag VTimestamp - --- | Test if we should output to stderr when we log. --- --- @since 3.4.0.0 -isVerboseStderr :: Verbosity -> Bool -isVerboseStderr = isVerboseFlag VStderr - --- | Helper function for flag testing functions. -isVerboseFlag :: VerbosityFlag -> Verbosity -> Bool -isVerboseFlag flag = (Set.member flag) . vFlags - --- $setup --- >>> import Test.QuickCheck (Arbitrary (..), arbitraryBoundedEnum) --- >>> instance Arbitrary VerbosityLevel where arbitrary = arbitraryBoundedEnum --- >>> instance Arbitrary Verbosity where arbitrary = fmap mkVerbosity arbitrary diff --git a/cabal/Cabal/Distribution/Verbosity/Internal.hs b/cabal/Cabal/Distribution/Verbosity/Internal.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Verbosity/Internal.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Verbosity.Internal - ( VerbosityLevel(..) - , VerbosityFlag(..) - ) where - -import Prelude () -import Distribution.Compat.Prelude - -data VerbosityLevel = Silent | Normal | Verbose | Deafening - deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded, Typeable) - -instance Binary VerbosityLevel -instance Structured VerbosityLevel - -data VerbosityFlag - = VCallStack - | VCallSite - | VNoWrap - | VMarkOutput - | VTimestamp - | VStderr -- ^ @since 3.4.0.0 - deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded, Typeable) - -instance Binary VerbosityFlag -instance Structured VerbosityFlag diff --git a/cabal/Cabal/Distribution/Version.hs b/cabal/Cabal/Distribution/Version.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Version.hs +++ /dev/null @@ -1,178 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Version --- Copyright : Isaac Jones, Simon Marlow 2003-2004 --- Duncan Coutts 2008 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Exports the 'Version' type along with a parser and pretty printer. A version --- is something like @\"1.3.3\"@. It also defines the 'VersionRange' data --- types. Version ranges are like @\">= 1.2 && < 2\"@. - -module Distribution.Version ( - -- * Package versions - Version, - version0, - mkVersion, - mkVersion', - versionNumbers, - nullVersion, - alterVersion, - - -- * Version ranges - VersionRange, - - -- ** Constructing - anyVersion, noVersion, - thisVersion, notThisVersion, - laterVersion, earlierVersion, - orLaterVersion, orEarlierVersion, - unionVersionRanges, intersectVersionRanges, - differenceVersionRanges, - invertVersionRange, - withinVersion, - majorBoundVersion, - - -- ** Inspection - withinRange, - isAnyVersion, - isNoVersion, - isSpecificVersion, - simplifyVersionRange, - foldVersionRange, - normaliseVersionRange, - stripParensVersionRange, - hasUpperBound, - hasLowerBound, - - -- ** Cata & ana - VersionRangeF (..), - cataVersionRange, - anaVersionRange, - hyloVersionRange, - projectVersionRange, - embedVersionRange, - - -- ** Utilities - wildcardUpperBound, - majorUpperBound, - - -- ** Modification - removeUpperBound, - removeLowerBound, - - -- * Version intervals view - asVersionIntervals, - VersionInterval, - LowerBound(..), - UpperBound(..), - Bound(..), - - -- ** 'VersionIntervals' abstract type - -- | The 'VersionIntervals' type and the accompanying functions are exposed - -- primarily for completeness and testing purposes. In practice - -- 'asVersionIntervals' is the main function to use to - -- view a 'VersionRange' as a bunch of 'VersionInterval's. - -- - VersionIntervals, - toVersionIntervals, - fromVersionIntervals, - withinIntervals, - versionIntervals, - mkVersionIntervals, - unionVersionIntervals, - intersectVersionIntervals, - invertVersionIntervals - - ) where - -import Distribution.Types.Version -import Distribution.Types.VersionRange -import Distribution.Types.VersionInterval - -------------------------------------------------------------------------------- --- Utilities on VersionRange requiring VersionInterval -------------------------------------------------------------------------------- - --- | This is the converse of 'isAnyVersion'. It check if the version range is --- empty, if there is no possible version that satisfies the version range. --- --- For example this is @True@ (for all @v@): --- --- > isNoVersion (EarlierVersion v `IntersectVersionRanges` LaterVersion v) --- -isNoVersion :: VersionRange -> Bool -isNoVersion vr = case asVersionIntervals vr of - [] -> True - _ -> False - --- | Is this version range in fact just a specific version? --- --- For example the version range @\">= 3 && <= 3\"@ contains only the version --- @3@. --- -isSpecificVersion :: VersionRange -> Maybe Version -isSpecificVersion vr = case asVersionIntervals vr of - [(LowerBound v InclusiveBound - ,UpperBound v' InclusiveBound)] - | v == v' -> Just v - _ -> Nothing - --- | Simplify a 'VersionRange' expression. For non-empty version ranges --- this produces a canonical form. Empty or inconsistent version ranges --- are left as-is because that provides more information. --- --- If you need a canonical form use --- @fromVersionIntervals . toVersionIntervals@ --- --- It satisfies the following properties: --- --- > withinRange v (simplifyVersionRange r) = withinRange v r --- --- > withinRange v r = withinRange v r' --- > ==> simplifyVersionRange r = simplifyVersionRange r' --- > || isNoVersion r --- > || isNoVersion r' --- -simplifyVersionRange :: VersionRange -> VersionRange -simplifyVersionRange vr - -- If the version range is inconsistent then we just return the - -- original since that has more information than ">1 && < 1", which - -- is the canonical inconsistent version range. - | null (versionIntervals vi) = vr - | otherwise = fromVersionIntervals vi - where - vi = toVersionIntervals vr - --- | The difference of two version ranges --- --- > withinRange v' (differenceVersionRanges vr1 vr2) --- > = withinRange v' vr1 && not (withinRange v' vr2) --- --- @since 1.24.1.0 -differenceVersionRanges :: VersionRange -> VersionRange -> VersionRange -differenceVersionRanges vr1 vr2 = - intersectVersionRanges vr1 (invertVersionRange vr2) - --- | The inverse of a version range --- --- > withinRange v' (invertVersionRange vr) --- > = not (withinRange v' vr) --- -invertVersionRange :: VersionRange -> VersionRange -invertVersionRange = - fromVersionIntervals . invertVersionIntervals . toVersionIntervals - --- | Given a version range, remove the highest upper bound. Example: @(>= 1 && < --- 3) || (>= 4 && < 5)@ is converted to @(>= 1 && < 3) || (>= 4)@. -removeUpperBound :: VersionRange -> VersionRange -removeUpperBound = fromVersionIntervals . relaxLastInterval . toVersionIntervals - --- | Given a version range, remove the lowest lower bound. --- Example: @(>= 1 && < 3) || (>= 4 && < 5)@ is converted to --- @(>= 0 && < 3) || (>= 4 && < 5)@. -removeLowerBound :: VersionRange -> VersionRange -removeLowerBound = fromVersionIntervals . relaxHeadInterval . toVersionIntervals diff --git a/cabal/Cabal/Distribution/ZinzaPrelude.hs b/cabal/Cabal/Distribution/ZinzaPrelude.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/ZinzaPrelude.hs +++ /dev/null @@ -1,43 +0,0 @@ --- | A small prelude used in @zinza@ generated --- template modules. -module Distribution.ZinzaPrelude ( - Writer, - execWriter, - tell, - -- * Re-exports - forM_, - Generic, - PackageName, - Version, - prettyShow - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Control.Monad (forM_) -import Distribution.Pretty (prettyShow) -import Distribution.Types.PackageName (PackageName) -import Distribution.Types.Version (Version) - -newtype Writer a = W { unW :: ShowS -> (ShowS, a) } - -instance Functor Writer where - fmap = liftM - -instance Applicative Writer where - pure x = W $ \ss -> (ss, x) - (<*>) = ap - -instance Monad Writer where - return = pure - m >>= k = W $ \s1 -> - let (s2, x) = unW m s1 - in unW (k x) s2 - {-# INLINE (>>=) #-} - -execWriter :: Writer a -> String -execWriter w = fst (unW w id) "" - -tell :: String -> Writer () -tell s = W $ \s' -> (s' . showString s, ()) diff --git a/cabal/Cabal/LICENSE b/cabal/Cabal/LICENSE --- a/cabal/Cabal/LICENSE +++ b/cabal/Cabal/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2003-2020, Cabal Development Team. +Copyright (c) 2003-2022, Cabal Development Team. See the AUTHORS file for the full list of copyright holders. See */LICENSE for the copyright holders of the subcomponents. diff --git a/cabal/Cabal/Language/Haskell/Extension.hs b/cabal/Cabal/Language/Haskell/Extension.hs deleted file mode 100644 --- a/cabal/Cabal/Language/Haskell/Extension.hs +++ /dev/null @@ -1,919 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} - ------------------------------------------------------------------------------ --- | --- Module : Language.Haskell.Extension --- Copyright : Isaac Jones 2003-2004 --- License : BSD3 --- --- Maintainer : libraries@haskell.org --- Portability : portable --- --- Haskell language dialects and extensions - -module Language.Haskell.Extension ( - Language(..), - knownLanguages, - classifyLanguage, - - Extension(..), - KnownExtension(..), - deprecatedExtensions, - classifyExtension, - ) where - -import qualified Prelude (head) -import Distribution.Compat.Prelude - -import Data.Array (Array, accumArray, bounds, Ix(inRange), (!)) - -import Distribution.Parsec -import Distribution.Pretty - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - --- ------------------------------------------------------------ --- * Language --- ------------------------------------------------------------ - --- | This represents a Haskell language dialect. --- --- Language 'Extension's are interpreted relative to one of these base --- languages. --- -data Language = - - -- | The Haskell 98 language as defined by the Haskell 98 report. - -- - Haskell98 - - -- | The Haskell 2010 language as defined by the Haskell 2010 report. - -- - | Haskell2010 - - -- | An unknown language, identified by its name. - | UnknownLanguage String - deriving (Generic, Show, Read, Eq, Typeable, Data) - -instance Binary Language -instance Structured Language - -instance NFData Language where rnf = genericRnf - -knownLanguages :: [Language] -knownLanguages = [Haskell98, Haskell2010] - -instance Pretty Language where - pretty (UnknownLanguage other) = Disp.text other - pretty other = Disp.text (show other) - -instance Parsec Language where - parsec = classifyLanguage <$> P.munch1 isAlphaNum - -classifyLanguage :: String -> Language -classifyLanguage = \str -> case lookup str langTable of - Just lang -> lang - Nothing -> UnknownLanguage str - where - langTable = [ (show lang, lang) - | lang <- knownLanguages ] - --- ------------------------------------------------------------ --- * Extension --- ------------------------------------------------------------ - --- Note: if you add a new 'KnownExtension': --- --- * also add it to the Distribution.Simple.X.languageExtensions lists --- (where X is each compiler: GHC, UHC, HaskellSuite) --- --- | This represents language extensions beyond a base 'Language' definition --- (such as 'Haskell98') that are supported by some implementations, usually --- in some special mode. --- --- Where applicable, references are given to an implementation's --- official documentation. - -data Extension = - -- | Enable a known extension - EnableExtension KnownExtension - - -- | Disable a known extension - | DisableExtension KnownExtension - - -- | An unknown extension, identified by the name of its @LANGUAGE@ - -- pragma. - | UnknownExtension String - - deriving (Generic, Show, Read, Eq, Ord, Typeable, Data) - -instance Binary Extension -instance Structured Extension - -instance NFData Extension where rnf = genericRnf - -data KnownExtension = - - -- | Allow overlapping class instances, provided there is a unique - -- most specific instance for each use. - -- - -- * - OverlappingInstances - - -- | Ignore structural rules guaranteeing the termination of class - -- instance resolution. Termination is guaranteed by a fixed-depth - -- recursion stack, and compilation may fail if this depth is - -- exceeded. - -- - -- * - | UndecidableInstances - - -- | Implies 'OverlappingInstances'. Allow the implementation to - -- choose an instance even when it is possible that further - -- instantiation of types will lead to a more specific instance - -- being applicable. - -- - -- * - | IncoherentInstances - - -- | /(deprecated)/ Deprecated in favour of 'RecursiveDo'. - -- - -- Old description: Allow recursive bindings in @do@ blocks, using - -- the @rec@ keyword. See also 'RecursiveDo'. - | DoRec - - -- | Allow recursive bindings in @do@ blocks, using the @rec@ - -- keyword, or @mdo@, a variant of @do@. - -- - -- * - | RecursiveDo - - -- | Provide syntax for writing list comprehensions which iterate - -- over several lists together, like the 'zipWith' family of - -- functions. - -- - -- * - | ParallelListComp - - -- | Allow multiple parameters in a type class. - -- - -- * - | MultiParamTypeClasses - - -- | Enable the dreaded monomorphism restriction. - -- - -- * - | MonomorphismRestriction - - -- | Allow a specification attached to a multi-parameter type class - -- which indicates that some parameters are entirely determined by - -- others. The implementation will check that this property holds - -- for the declared instances, and will use this property to reduce - -- ambiguity in instance resolution. - -- - -- * - | FunctionalDependencies - - -- | /(deprecated)/ A synonym for 'RankNTypes'. - -- - -- Old description: Like 'RankNTypes' but does not allow a - -- higher-rank type to itself appear on the left of a function - -- arrow. - -- - -- * - | Rank2Types - - -- | Allow a universally-quantified type to occur on the left of a - -- function arrow. - -- - -- * - | RankNTypes - - -- | /(deprecated)/ A synonym for 'RankNTypes'. - -- - -- Old description: Allow data constructors to have polymorphic - -- arguments. Unlike 'RankNTypes', does not allow this for ordinary - -- functions. - -- - -- * - | PolymorphicComponents - - -- | Allow existentially-quantified data constructors. - -- - -- * - | ExistentialQuantification - - -- | Cause a type variable in a signature, which has an explicit - -- @forall@ quantifier, to scope over the definition of the - -- accompanying value declaration. - -- - -- * - | ScopedTypeVariables - - -- | Deprecated, use 'ScopedTypeVariables' instead. - | PatternSignatures - - -- | Enable implicit function parameters with dynamic scope. - -- - -- * - | ImplicitParams - - -- | Relax some restrictions on the form of the context of a type - -- signature. - -- - -- * - | FlexibleContexts - - -- | Relax some restrictions on the form of the context of an - -- instance declaration. - -- - -- * - | FlexibleInstances - - -- | Allow data type declarations with no constructors. - -- - -- * - | EmptyDataDecls - - -- | Run the C preprocessor on Haskell source code. - -- - -- * - | CPP - - -- | Allow an explicit kind signature giving the kind of types over - -- which a type variable ranges. - -- - -- * - | KindSignatures - - -- | Enable a form of pattern which forces evaluation before an - -- attempted match, and a form of strict @let@/@where@ binding. - -- - -- * - | BangPatterns - - -- | Allow type synonyms in instance heads. - -- - -- * - | TypeSynonymInstances - - -- | Enable Template Haskell, a system for compile-time - -- metaprogramming. - -- - -- * - | TemplateHaskell - - -- | Enable the Foreign Function Interface. In GHC, implements the - -- standard Haskell 98 Foreign Function Interface Addendum, plus - -- some GHC-specific extensions. - -- - -- * - | ForeignFunctionInterface - - -- | Enable arrow notation. - -- - -- * - | Arrows - - -- | /(deprecated)/ Enable generic type classes, with default instances defined in - -- terms of the algebraic structure of a type. - -- - -- * - | Generics - - -- | Enable the implicit importing of the module "Prelude". When - -- disabled, when desugaring certain built-in syntax into ordinary - -- identifiers, use whatever is in scope rather than the "Prelude" - -- -- version. - -- - -- * - | ImplicitPrelude - - -- | Enable syntax for implicitly binding local names corresponding - -- to the field names of a record. Puns bind specific names, unlike - -- 'RecordWildCards'. - -- - -- * - | NamedFieldPuns - - -- | Enable a form of guard which matches a pattern and binds - -- variables. - -- - -- * - | PatternGuards - - -- | Allow a type declared with @newtype@ to use @deriving@ for any - -- class with an instance for the underlying type. - -- - -- * - | GeneralizedNewtypeDeriving - - -- Synonym for GeneralizedNewtypeDeriving added in GHC 8.6.1. - | GeneralisedNewtypeDeriving - - -- | Enable the \"Trex\" extensible records system. - -- - -- * - | ExtensibleRecords - - -- | Enable type synonyms which are transparent in some definitions - -- and opaque elsewhere, as a way of implementing abstract - -- datatypes. - -- - -- * - | RestrictedTypeSynonyms - - -- | Enable an alternate syntax for string literals, - -- with string templating. - -- - -- * - | HereDocuments - - -- | Allow the character @#@ as a postfix modifier on identifiers. - -- Also enables literal syntax for unboxed values. - -- - -- * - | MagicHash - - -- | Allow data types and type synonyms which are indexed by types, - -- i.e. ad-hoc polymorphism for types. - -- - -- * - | TypeFamilies - - -- | Allow a standalone declaration which invokes the type class - -- @deriving@ mechanism. - -- - -- * - | StandaloneDeriving - - -- | Allow certain Unicode characters to stand for certain ASCII - -- character sequences, e.g. keywords and punctuation. - -- - -- * - | UnicodeSyntax - - -- | Allow the use of unboxed types as foreign types, e.g. in - -- @foreign import@ and @foreign export@. - -- - -- * - | UnliftedFFITypes - - -- | Enable interruptible FFI. - -- - -- * - | InterruptibleFFI - - -- | Allow use of CAPI FFI calling convention (@foreign import capi@). - -- - -- * - | CApiFFI - - -- | Defer validity checking of types until after expanding type - -- synonyms, relaxing the constraints on how synonyms may be used. - -- - -- * - | LiberalTypeSynonyms - - -- | Allow the name of a type constructor, type class, or type - -- variable to be an infix operator. - -- * - | TypeOperators - - -- | Enable syntax for implicitly binding local names corresponding - -- to the field names of a record. A wildcard binds all unmentioned - -- names, unlike 'NamedFieldPuns'. - -- - -- * - | RecordWildCards - - -- | Deprecated, use 'NamedFieldPuns' instead. - | RecordPuns - - -- | Allow a record field name to be disambiguated by the type of - -- the record it's in. - -- - -- * - | DisambiguateRecordFields - - -- | Enable traditional record syntax (as supported by Haskell 98) - -- - -- * - | TraditionalRecordSyntax - - -- | Enable overloading of string literals using a type class, much - -- like integer literals. - -- - -- * - | OverloadedStrings - - -- | Enable generalized algebraic data types, in which type - -- variables may be instantiated on a per-constructor basis. Implies - -- 'GADTSyntax'. - -- - -- * - | GADTs - - -- | Enable GADT syntax for declaring ordinary algebraic datatypes. - -- - -- * - | GADTSyntax - - -- | /(deprecated)/ Has no effect. - -- - -- Old description: Make pattern bindings monomorphic. - -- - -- * - | MonoPatBinds - - -- | Relax the requirements on mutually-recursive polymorphic - -- functions. - -- - -- * - | RelaxedPolyRec - - -- | Allow default instantiation of polymorphic types in more - -- situations. - -- - -- * - | ExtendedDefaultRules - - -- | Enable unboxed tuples. - -- - -- * - | UnboxedTuples - - -- | Enable @deriving@ for classes 'Data.Typeable.Typeable' and - -- 'Data.Generics.Data'. - -- - -- * - | DeriveDataTypeable - - -- | Enable @deriving@ for 'GHC.Generics.Generic' and 'GHC.Generics.Generic1'. - -- - -- * - | DeriveGeneric - - -- | Enable support for default signatures. - -- - -- * - | DefaultSignatures - - -- | Allow type signatures to be specified in instance declarations. - -- - -- * - | InstanceSigs - - -- | Allow a class method's type to place additional constraints on - -- a class type variable. - -- - -- * - | ConstrainedClassMethods - - -- | Allow imports to be qualified by the package name the module is - -- intended to be imported from, e.g. - -- - -- > import "network" Network.Socket - -- - -- * - | PackageImports - - -- | /(deprecated)/ Allow a type variable to be instantiated at a - -- polymorphic type. - -- - -- * - | ImpredicativeTypes - - -- | /(deprecated)/ Change the syntax for qualified infix operators. - -- - -- * - | NewQualifiedOperators - - -- | Relax the interpretation of left operator sections to allow - -- unary postfix operators. - -- - -- * - | PostfixOperators - - -- | Enable quasi-quotation, a mechanism for defining new concrete - -- syntax for expressions and patterns. - -- - -- * - | QuasiQuotes - - -- | Enable generalized list comprehensions, supporting operations - -- such as sorting and grouping. - -- - -- * - | TransformListComp - - -- | Enable monad comprehensions, which generalise the list - -- comprehension syntax to work for any monad. - -- - -- * - | MonadComprehensions - - -- | Enable view patterns, which match a value by applying a - -- function and matching on the result. - -- - -- * - | ViewPatterns - - -- | Allow concrete XML syntax to be used in expressions and patterns, - -- as per the Haskell Server Pages extension language: - -- . The ideas behind it are - -- discussed in the paper \"Haskell Server Pages through Dynamic Loading\" - -- by Niklas Broberg, from Haskell Workshop '05. - | XmlSyntax - - -- | Allow regular pattern matching over lists, as discussed in the - -- paper \"Regular Expression Patterns\" by Niklas Broberg, Andreas Farre - -- and Josef Svenningsson, from ICFP '04. - | RegularPatterns - - -- | Enable the use of tuple sections, e.g. @(, True)@ desugars into - -- @\x -> (x, True)@. - -- - -- * - | TupleSections - - -- | Allow GHC primops, written in C--, to be imported into a Haskell - -- file. - | GHCForeignImportPrim - - -- | Support for patterns of the form @n + k@, where @k@ is an - -- integer literal. - -- - -- * - | NPlusKPatterns - - -- | Improve the layout rule when @if@ expressions are used in a @do@ - -- block. - | DoAndIfThenElse - - -- | Enable support for multi-way @if@-expressions. - -- - -- * - | MultiWayIf - - -- | Enable support lambda-@case@ expressions. - -- - -- * - | LambdaCase - - -- | Makes much of the Haskell sugar be desugared into calls to the - -- function with a particular name that is in scope. - -- - -- * - | RebindableSyntax - - -- | Make @forall@ a keyword in types, which can be used to give the - -- generalisation explicitly. - -- - -- * - | ExplicitForAll - - -- | Allow contexts to be put on datatypes, e.g. the @Eq a@ in - -- @data Eq a => Set a = NilSet | ConsSet a (Set a)@. - -- - -- * - | DatatypeContexts - - -- | Local (@let@ and @where@) bindings are monomorphic. - -- - -- * - | MonoLocalBinds - - -- | Enable @deriving@ for the 'Data.Functor.Functor' class. - -- - -- * - | DeriveFunctor - - -- | Enable @deriving@ for the 'Data.Traversable.Traversable' class. - -- - -- * - | DeriveTraversable - - -- | Enable @deriving@ for the 'Data.Foldable.Foldable' class. - -- - -- * - | DeriveFoldable - - -- | Enable non-decreasing indentation for @do@ blocks. - -- - -- * - | NondecreasingIndentation - - -- | Allow imports to be qualified with a safe keyword that requires - -- the imported module be trusted as according to the Safe Haskell - -- definition of trust. - -- - -- > import safe Network.Socket - -- - -- * - | SafeImports - - -- | Compile a module in the Safe, Safe Haskell mode -- a restricted - -- form of the Haskell language to ensure type safety. - -- - -- * - | Safe - - -- | Compile a module in the Trustworthy, Safe Haskell mode -- no - -- restrictions apply but the module is marked as trusted as long as - -- the package the module resides in is trusted. - -- - -- * - | Trustworthy - - -- | Compile a module in the Unsafe, Safe Haskell mode so that - -- modules compiled using Safe, Safe Haskell mode can't import it. - -- - -- * - | Unsafe - - -- | Allow type class/implicit parameter/equality constraints to be - -- used as types with the special kind constraint. Also generalise - -- the @(ctxt => ty)@ syntax so that any type of kind constraint can - -- occur before the arrow. - -- - -- * - | ConstraintKinds - - -- | Enable kind polymorphism. - -- - -- * - | PolyKinds - - -- | Enable datatype promotion. - -- - -- * - | DataKinds - - -- | Enable parallel arrays syntax (@[:@, @:]@) for /Data Parallel Haskell/. - -- - -- * - | ParallelArrays - - -- | Enable explicit role annotations, like in (@type role Foo representational representational@). - -- - -- * - | RoleAnnotations - - -- | Enable overloading of list literals, arithmetic sequences and - -- list patterns using the 'IsList' type class. - -- - -- * - | OverloadedLists - - -- | Enable case expressions that have no alternatives. Also applies to lambda-case expressions if they are enabled. - -- - -- * - | EmptyCase - - -- | /(deprecated)/ Deprecated in favour of 'DeriveDataTypeable'. - -- - -- Old description: Triggers the generation of derived 'Typeable' - -- instances for every datatype and type class declaration. - -- - -- * - | AutoDeriveTypeable - - -- | Desugars negative literals directly (without using negate). - -- - -- * - | NegativeLiterals - - -- | Allow the use of binary integer literal syntax (e.g. @0b11001001@ to denote @201@). - -- - -- * - | BinaryLiterals - - -- | Allow the use of floating literal syntax for all instances of 'Num', including 'Int' and 'Integer'. - -- - -- * - | NumDecimals - - -- | Enable support for type classes with no type parameter. - -- - -- * - | NullaryTypeClasses - - -- | Enable explicit namespaces in module import/export lists. - -- - -- * - | ExplicitNamespaces - - -- | Allow the user to write ambiguous types, and the type inference engine to infer them. - -- - -- * - | AllowAmbiguousTypes - - -- | Enable @foreign import javascript@. - | JavaScriptFFI - - -- | Allow giving names to and abstracting over patterns. - -- - -- * - | PatternSynonyms - - -- | Allow anonymous placeholders (underscore) inside type signatures. The - -- type inference engine will generate a message describing the type inferred - -- at the hole's location. - -- - -- * - | PartialTypeSignatures - - -- | Allow named placeholders written with a leading underscore inside type - -- signatures. Wildcards with the same name unify to the same type. - -- - -- * - | NamedWildCards - - -- | Enable @deriving@ for any class. - -- - -- * - | DeriveAnyClass - - -- | Enable @deriving@ for the 'Language.Haskell.TH.Syntax.Lift' class. - -- - -- * - | DeriveLift - - -- | Enable support for 'static pointers' (and the @static@ - -- keyword) to refer to globally stable names, even across - -- different programs. - -- - -- * - | StaticPointers - - -- | Switches data type declarations to be strict by default (as if - -- they had a bang using @BangPatterns@), and allow opt-in field - -- laziness using @~@. - -- - -- * - | StrictData - - -- | Switches all pattern bindings to be strict by default (as if - -- they had a bang using @BangPatterns@), ordinary patterns are - -- recovered using @~@. Implies @StrictData@. - -- - -- * - | Strict - - -- | Allows @do@-notation for types that are @'Applicative'@ as well - -- as @'Monad'@. When enabled, desugaring @do@ notation tries to use - -- @(<*>)@ and @'fmap'@ and @'join'@ as far as possible. - | ApplicativeDo - - -- | Allow records to use duplicated field labels for accessors. - | DuplicateRecordFields - - -- | Enable explicit type applications with the syntax @id \@Int@. - | TypeApplications - - -- | Dissolve the distinction between types and kinds, allowing the compiler - -- to reason about kind equality and therefore enabling GADTs to be promoted - -- to the type-level. - | TypeInType - - -- | Allow recursive (and therefore undecidable) super-class relationships. - | UndecidableSuperClasses - - -- | A temporary extension to help library authors check if their - -- code will compile with the new planned desugaring of fail. - | MonadFailDesugaring - - -- | A subset of @TemplateHaskell@ including only quoting. - | TemplateHaskellQuotes - - -- | Allows use of the @#label@ syntax. - | OverloadedLabels - - -- | Allow functional dependency annotations on type families to declare them - -- as injective. - | TypeFamilyDependencies - - -- | Allow multiple @deriving@ clauses, each optionally qualified with a - -- /strategy/. - | DerivingStrategies - - -- | Enable deriving instances via types of the same runtime representation. - -- Implies 'DerivingStrategies'. - | DerivingVia - - -- | Enable the use of unboxed sum syntax. - | UnboxedSums - - -- | Allow use of hexadecimal literal notation for floating-point values. - | HexFloatLiterals - - -- | Allow @do@ blocks etc. in argument position. - | BlockArguments - - -- | Allow use of underscores in numeric literals. - | NumericUnderscores - - -- | Allow @forall@ in constraints. - | QuantifiedConstraints - - -- | Have @*@ refer to @Type@. - | StarIsType - - -- | Liberalises deriving to provide instances for empty data types. - -- - -- * - | EmptyDataDeriving - - -- | Enable detection of complete user-supplied kind signatures. - | CUSKs - - -- | Allows the syntax @import M qualified@. - | ImportQualifiedPost - - -- | Allow the use of standalone kind signatures. - | StandaloneKindSignatures - - -- | Enable unlifted newtypes. - | UnliftedNewtypes - - -- | Use whitespace to determine whether the minus sign stands for negation or subtraction. - | LexicalNegation - - -- | Enable qualified do-notation desugaring. - | QualifiedDo - - -- | Enable linear types. - | LinearTypes - - deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded, Typeable, Data) - -instance Binary KnownExtension -instance Structured KnownExtension - -instance NFData KnownExtension where rnf = genericRnf - --- | Extensions that have been deprecated, possibly paired with another --- extension that replaces it. --- -deprecatedExtensions :: [(Extension, Maybe Extension)] -deprecatedExtensions = - [ (EnableExtension RecordPuns, Just (EnableExtension NamedFieldPuns)) - , (EnableExtension PatternSignatures, Just (EnableExtension ScopedTypeVariables)) - ] --- NOTE: when adding deprecated extensions that have new alternatives --- we must be careful to make sure that the deprecation messages are --- valid. We must not recommend aliases that cannot be used with older --- compilers, perhaps by adding support in Cabal to translate the new --- name to the old one for older compilers. Otherwise we are in danger --- of the scenario in ticket #689. - -instance Pretty Extension where - pretty (UnknownExtension other) = Disp.text other - pretty (EnableExtension ke) = Disp.text (show ke) - pretty (DisableExtension ke) = Disp.text ("No" ++ show ke) - -instance Parsec Extension where - parsec = classifyExtension <$> P.munch1 isAlphaNum - -instance Pretty KnownExtension where - pretty ke = Disp.text (show ke) - -classifyExtension :: String -> Extension -classifyExtension string - = case classifyKnownExtension string of - Just ext -> EnableExtension ext - Nothing -> - case string of - 'N':'o':string' -> - case classifyKnownExtension string' of - Just ext -> DisableExtension ext - Nothing -> UnknownExtension string - _ -> UnknownExtension string - --- | 'read' for 'KnownExtension's is really really slow so for the Text --- instance --- what we do is make a simple table indexed off the first letter in the --- extension name. The extension names actually cover the range @'A'-'Z'@ --- pretty densely and the biggest bucket is 7 so it's not too bad. We just do --- a linear search within each bucket. --- --- This gives an order of magnitude improvement in parsing speed, and it'll --- also allow us to do case insensitive matches in future if we prefer. --- -classifyKnownExtension :: String -> Maybe KnownExtension -classifyKnownExtension "" = Nothing -classifyKnownExtension string@(c : _) - | inRange (bounds knownExtensionTable) c - = lookup string (knownExtensionTable ! c) - | otherwise = Nothing - -knownExtensionTable :: Array Char [(String, KnownExtension)] -knownExtensionTable = - accumArray (flip (:)) [] ('A', 'Z') - [ (Prelude.head str, (str, extension)) -- assume KnownExtension's Show returns a non-empty string - | extension <- [toEnum 0 ..] - , let str = show extension ] diff --git a/cabal/Cabal/Makefile b/cabal/Cabal/Makefile --- a/cabal/Cabal/Makefile +++ b/cabal/Cabal/Makefile @@ -1,4 +1,4 @@ -VERSION=3.3.0.0 +VERSION=3.8.1.0 #KIND=devel KIND=rc @@ -20,14 +20,10 @@ CONFIG_STAMP=dist/setup-config BUILD_STAMP=dist/build/libHSCabal-$(VERSION).a HADDOCK_STAMP=dist/doc/html/Cabal/index.html -USERGUIDE_STAMP=dist/doc/users-guide/index.html SDIST_STAMP=dist/Cabal-$(VERSION).tar.gz DISTLOC=dist/release DIST_STAMP=$(DISTLOC)/Cabal-$(VERSION).tar.gz -# TODO: when we have sphinx-build2 ? -SPHINXCMD:=sphinx-build - COMMA=, setup: $(SOURCES) Setup.hs @@ -51,20 +47,6 @@ $(HADDOCK_STAMP) : $(CONFIG_STAMP) $(BUILD_STAMP) ./setup haddock -SPHINX_HTML_OUTDIR=dist/doc/users-guide - -# do pip install everytime so we have up to date requirements when we build -users-guide: .python-sphinx-virtualenv $(USERGUIDE_STAMP) -$(USERGUIDE_STAMP) : doc/*.rst - mkdir -p $(SPHINX_HTML_OUTDIR) - (. ./.python-sphinx-virtualenv/bin/activate && pip install -r doc/requirements.txt && $(SPHINXCMD) doc $(SPHINX_HTML_OUTDIR)) - -docs: haddock users-guide - -.python-sphinx-virtualenv: - python3 -m venv .python-sphinx-virtualenv - (. ./.python-sphinx-virtualenv/bin/activate) - clean: rm -rf dist/ rm -f setup @@ -93,17 +75,15 @@ ./setup sdist dist: $(DIST_STAMP) -$(DIST_STAMP) : $(HADDOCK_STAMP) $(USERGUIDE_STAMP) $(SDIST_STAMP) +$(DIST_STAMP) : $(HADDOCK_STAMP) $(SDIST_STAMP) rm -rf $(DISTLOC) mkdir $(DISTLOC) tar -xzf $(SDIST_STAMP) -C $(DISTLOC)/ mkdir -p $(DISTLOC)/Cabal-$(VERSION)/doc cp -r dist/doc/html $(DISTLOC)/Cabal-$(VERSION)/doc/API - cp -r dist/doc/users-guide $(DISTLOC)/Cabal-$(VERSION)/doc/ cp ChangeLog.md $(DISTLOC)/Cabal-$(VERSION)/ tar --format=ustar -C $(DISTLOC) -czf $(DISTLOC)/Cabal-$(VERSION).tar.gz Cabal-$(VERSION) mkdir $(DISTLOC)/doc - mv $(DISTLOC)/Cabal-$(VERSION)/doc/users-guide $(DISTLOC)/doc mv $(DISTLOC)/Cabal-$(VERSION)/doc/API $(DISTLOC)/doc mv $(DISTLOC)/Cabal-$(VERSION)/ChangeLog.md $(DISTLOC)/ rm -r $(DISTLOC)/Cabal-$(VERSION)/ diff --git a/cabal/Cabal/README.md b/cabal/Cabal/README.md --- a/cabal/Cabal/README.md +++ b/cabal/Cabal/README.md @@ -6,119 +6,17 @@ If you also want the `cabal` command-line program, you need the [cabal-install] package in addition to this library. -[cabal-install]: ../cabal-install/README.md - -Installing the Cabal library -============================ - -If you already have the `cabal` program ---------------------------------------- - -In this case run: - - $ cabal install - -However, if you do not have an existing version of the `cabal` program, -you first must install the Cabal library. To avoid this bootstrapping -problem, you can install the Cabal library directly as described below. - - -Installing as a user (no root or administrator access) ------------------------------------------------------- - - ghc -threaded --make Setup - ./Setup configure --user - ./Setup build - ./Setup install - -Note the use of the `--user` flag at the configure step. - -Compiling 'Setup' rather than using `runghc Setup` is much faster and -works on Windows. For all packages other than Cabal itself, it is fine -to use `runghc`. - -This will install into `$HOME/.cabal/` on Unix and into -`Documents and Settings\$User\Application Data\cabal\` on Windows. -If you want to install elsewhere, use the `--prefix=` flag at the -configure step. - - -Installing as root or Administrator ------------------------------------ - - ghc -threaded --make Setup - ./Setup configure - ./Setup build - sudo ./Setup install - -Compiling Setup rather than using `runghc Setup` is much faster and -works on Windows. For all packages other than Cabal itself, it is fine -to use `runghc`. - -This will install into `/usr/local` on Unix, and on Windows it will -install into `$ProgramFiles/Haskell`. If you want to install elsewhere, -use the `--prefix=` flag at the configure step. - - -Using older versions of GHC and Cabal -====================================== - -It is recommended that you leave any pre-existing version of Cabal -installed. In particular, it is *essential* you keep the version that -came with GHC itself, since other installed packages require it (for -instance, the "ghc" API package). - -Prior to GHC 6.4.2, however, GHC did not deal particularly well with -having multiple versions of packages installed at once. So if you are -using GHC 6.4.1 or older and you have an older version of Cabal -installed, you should probably remove it by running: - - $ ghc-pkg unregister Cabal - -or, if you had Cabal installed only for your user account, run: - - $ ghc-pkg unregister Cabal --user - -The `filepath` dependency -========================= - -Cabal uses the [filepath] package, so it must be installed first. -GHC version 6.6.1 and later come with `filepath`, however, earlier -versions do not by default. If you do not already have `filepath`, -you need to install it. You can use any existing version of Cabal to do -that. If you have neither Cabal nor `filepath`, it is slightly -harder but still possible. - -Unpack Cabal and `filepath` into separate directories. For example: - - tar -xzf filepath-1.1.0.0.tar.gz - tar -xzf Cabal-1.6.0.0.tar.gz - - # rename to make the following instructions simpler: - mv filepath-1.1.0.0/ filepath/ - mv Cabal-1.6.0.0/ Cabal/ - - cd Cabal - ghc -i../filepath -cpp --make Setup.hs -o ../filepath/setup - cd ../filepath/ - ./setup configure --user - ./setup build - ./setup install - -This installs `filepath` so that you can install Cabal with the normal -method. - -[filepath]: http://hackage.haskell.org/package/filepath +[cabal-install]: ../cabal-install More information ================ -Please see the [Cabal web site] for the [user guide] and [API +Please see the [Cabal web site], the [user guide] and the [API documentation]. There is additional information available on the [development wiki]. [user guide]: http://www.haskell.org/cabal/users-guide -[API documentation]: http://www.haskell.org/cabal/release/cabal-latest/doc/API/Cabal/Distribution-Simple.html +[API documentation]: https://hackage.haskell.org/package/Cabal/docs/Distribution-Simple.html [development wiki]: https://github.com/haskell/cabal/wiki diff --git a/cabal/Cabal/doc/README.md b/cabal/Cabal/doc/README.md deleted file mode 100644 --- a/cabal/Cabal/doc/README.md +++ /dev/null @@ -1,121 +0,0 @@ -Cabal documentation -=================== - -### Where to read it -These docs will be built and deployed whenever a release is made, -and can be read at: https://www.haskell.org/cabal/users-guide/ - -In addition, the docs are taken directly from git and hosted at: -http://cabal.readthedocs.io/ - - -### How to build it - -Building the documentation requires Python 3 be installed -* `> cd Cabal` -* `> make clean users-guide` -* Python on Mac OS X dislikes `LC_CTYPE=UTF-8`, unset the env var in -terminal preferences and instead set `LC_ALL=en_US.UTF-8` or something - -### Caveats, for newcomers to RST from MD -RST does not allow you to skip section levels when nesting, like MD -does. -So, you cannot have - -``` - Section heading - =============== - - Some unimportant block - """""""""""""""""""""" -``` - - instead you need to observe order and either promote your block: - -``` - Section heading - =============== - - Some not quite so important block - --------------------------------- -``` - - or introduce more subsections: - -``` - Section heading - =============== - - Subsection - ---------- - - Subsubsection - ^^^^^^^^^^^^^ - - Some unimportant block - """""""""""""""""""""" -``` - -* RST simply parses a file and interprets headings to indicate the - start of a new block, - * at the level implied by the header's *adornment*, if the adornment was - previously encountered in this file, - * at one level deeper than the previous block, otherwise. - - This means that a lot of confusion can arise when people use - different adornments to signify the same depth in different files. - - To eliminate this confusion, please stick to the adornment order - recommended by the Sphinx team: - -``` - #### - Part - #### - - ******* - Chapter - ******* - - Section - ======= - - Subsection - ---------- - - Subsubsection - ^^^^^^^^^^^^^ - - Paragraph - """"""""" -``` - -* The Read-The-Docs stylesheet does not support multiple top-level - sections in a file that is linked to from the top-most TOC (in - `index.rst`). It will mess up the sidebar. - E.g. you cannot link to a `cabal.rst` with sections "Introduction", - "Using Cabal", "Epilogue" from `index.rst`. - - One solution is to have a single section, e.g. "All About Cabal", in - `cabal.rst` and make the other blocks subsections of that. - - Another solution is to link via an indirection, e.g. create - `all-about-cabal.rst`, where you include `cabal.rst` using the - `.. toctree::` command and then link to `all-about-cabal.rst` from - `index.rst`. - This will effectively "push down" all blocks by one layer and solve - the problem without having to change `cabal.rst`. - - -* We use [`extlinks`](http://www.sphinx-doc.org/en/stable/ext/extlinks.html) - to shorten links to commonly referred resources (wiki, issue trackers). - - E.g. you can use the more convenient short syntax - - :issue:`123` - - which is expanded into a hyperlink - - `#123 `__ - - See `conf.py` for list of currently defined link shorteners. diff --git a/cabal/Cabal/doc/_templates/layout.html b/cabal/Cabal/doc/_templates/layout.html deleted file mode 100644 --- a/cabal/Cabal/doc/_templates/layout.html +++ /dev/null @@ -1,8 +0,0 @@ -{% extends "!layout.html" %} - -{% block menu %} - {{ super() }} - Reference - Index -{% endblock %} - diff --git a/cabal/Cabal/doc/bugs-and-stability.rst b/cabal/Cabal/doc/bugs-and-stability.rst deleted file mode 100644 --- a/cabal/Cabal/doc/bugs-and-stability.rst +++ /dev/null @@ -1,6 +0,0 @@ -Reporting Bugs and Stability of Cabal Interfaces -================================================ - -.. toctree:: - misc - diff --git a/cabal/Cabal/doc/buildinfo-fields-reference.rst b/cabal/Cabal/doc/buildinfo-fields-reference.rst deleted file mode 100644 --- a/cabal/Cabal/doc/buildinfo-fields-reference.rst +++ /dev/null @@ -1,654 +0,0 @@ -.. _buildinfo-field-reference: - -Field Syntax Reference -====================== - -Notation ---------------- - -Field syntax is described as they are in the latest cabal file format version. - -* terminals are enclosed in quotes and type set in typewriter script: - - .. math:: - - \mathord{"}\mathtt{example}\mathord{"} - -* non-terminals are type set in italic: - - .. math:: - - \mathit{version\text-range} - -* character sets are type set resembling regular expression notation: - - - .. math:: - - [ \mathord{"}\mathtt{1}\mathord{"} \cdots \mathord{"}\mathtt{9}\mathord{"} ] - - Character set complements have :math:`c` superscript: - - .. math:: - - [ \mathord{"}\mathtt{1}\mathord{"} \cdots \mathord{"}\mathtt{9}\mathord{"} ]^c - -* repetition is type set using regular expression inspired notation. - Superscripts tell how many time to repeat: - The generic notation is :math:`\in[n\ldots5]`, however there - are common shorthands: - :math:`\ast` for :math:`\in[0\ldots\infty]` (``many``), - :math:`+` for :math:`\in[1\ldots\infty]` (``some``), - :math:`?` for :math:`\in[0\ldots1]` (``optional``). - - Subscripts tell the used separator: - - .. math:: - - \mathit{digit}^+_{\mathord{"}\mathtt{.}\mathord{"}} - - Would be ``digit(\.digit)*`` in common regex syntax. - -* alternatives are listed in braces separated by vertical bar: - - .. math:: - - \{ \mathit{foo} \mid \mathit{bar} \} - - In case of multiple alternatives, the stacked notation is used - - .. math:: - - \left\{\begin{gathered} - \mathit{one} \\ - \mathit{two} \\ - \mathit{three} \\ - \mathit{four} \\ - \mathit{five} - \end{gathered}\right\} - -* parenthesis are used only for grouping: - - .. math:: - - \left(\mathit{foo} \mid \mathit{bar}\right)^+ - -* any amount of spaces, and at least single space are type set using - :math:`\circ` and :math:`\bullet` respectively. - They may appear standalone, not only as binary operators. - - .. math:: - - \mathit{module} \bullet \mathord{``}\mathtt{as}\mathord{"} \bullet \mathit{module} - -* While notation is heavily regular expression inspired, there - are also fixed points, which allow represent recursive grammars - - - .. math:: - - \mathbf{fix}\; \mathit{expr}\; \mathbf{in}\; \mathit{digit} - \mid \mathit{expr} \circ \mathord{``}\mathtt{+}\mathord{"} \circ \mathit{expr} - \mid \mathord{``}\mathtt{(} \mathord{"} \circ \mathit{expr} \circ \mathord{``}\mathtt{)}\mathord{"} - -Lists ------ - -Many fields in cabal file format are lists. There are three variations: - -Space separated - Are used for lists of things with simple grammars, for example :pkg-field:`ghc-options` - - .. math:: - {\mathop{\mathit{element}}}^\ast_{\bullet} - -Comma separated - Are used for lists of things with complicated grammars, for example :pkg-field:`build-depends` - There can be leading or trailing comma (but not both) since ``cabal-version: 2.2``. - Note, the comma cannot exist alone. - - .. math:: - \mathrm{commalist}(\mathit{element}) = - \left\{ {\mathop{\mathit{element}}}^\ast_{\left(\circ\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}\circ\right)}\mid\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}\circ{\mathop{\mathit{element}}}^+_{\left(\circ\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}\circ\right)}\mid{\mathop{\mathit{element}}}^+_{\left(\circ\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}\circ\right)}\circ\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}} \right\} - -Optional comma separated - Surprisingly many fields can have optional comma separator. - Since ``cabal-version: 3.0`` comma usage have to be consistent, - in other words either used everywhere or nowhere. - It's recommended to avoid using comma in these fields, - an example field is :pkg-field:`default-extensions`. - - .. math:: - \mathrm{optcommalist}(\mathit{element}) = - \left\{ \begin{gathered}{\mathop{\mathit{element}}}^\ast_{\bullet}\\{\mathop{\mathit{element}}}^\ast_{\left(\circ\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}\circ\right)}\\\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}\circ{\mathop{\mathit{element}}}^+_{\left(\circ\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}\circ\right)}\\{\mathop{\mathit{element}}}^+_{\left(\circ\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}\circ\right)}\circ\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}\end{gathered} \right\} - -Non-terminals -------------- - -In the syntax definitions below the following non-terminal symbols are used: - -hs-string - String as in Haskell; it's recommended to avoid using Haskell-specific escapes. - - .. math:: - \mathop{\mathord{``}\mathtt{\text{"}}\mathord{"}}{\left\{ {[\mathop{\mathord{``}\mathtt{\text{"}}\mathord{"}}\mathop{\mathord{``}\mathtt{\text{\\}}\mathord{"}}]^c}\mid\left\{ \begin{gathered}\mathop{\mathord{``}\mathtt{\text{\\}\text{&}}\mathord{"}}\\\mathop{\mathord{``}\mathtt{\text{\\}\text{\\}}\mathord{"}}\\\left\{ \mathop{\mathord{``}\mathtt{\text{\\}n}\mathord{"}}\mid\mathop{\mathit{escapes}} \right\}\\\mathop{\mathord{``}\mathtt{\text{\\}}\mathord{"}}[\mathop{\mathord{``}\mathtt{0}\mathord{"}}\cdots\mathop{\mathord{``}\mathtt{9}\mathord{"}}]\\\mathop{\mathord{``}\mathtt{\text{\\}o}\mathord{"}}[\mathop{\mathord{``}\mathtt{0}\mathord{"}}\cdots\mathop{\mathord{``}\mathtt{7}\mathord{"}}]\\\mathop{\mathord{``}\mathtt{\text{\\}x}\mathord{"}}[\mathop{\mathord{``}\mathtt{0}\mathord{"}}\cdots\mathop{\mathord{``}\mathtt{9}\mathord{"}}\mathop{\mathord{``}\mathtt{A}\mathord{"}}\cdots\mathop{\mathord{``}\mathtt{F}\mathord{"}}\mathop{\mathord{``}\mathtt{a}\mathord{"}}\cdots\mathop{\mathord{``}\mathtt{f}\mathord{"}}]\\\left\{ \mathop{\mathord{``}\mathtt{\text{\\}\text{^}\text{@}}\mathord{"}}\mid\mathop{\mathit{control}} \right\}\\\left\{ \mathop{\mathord{``}\mathtt{\text{\\}NUL}\mathord{"}}\mid\mathop{\mathit{ascii}} \right\}\end{gathered} \right\} \right\}}^\ast_{}\mathop{\mathord{``}\mathtt{\text{"}}\mathord{"}} - -unqual-name - Unqualified component names are used for package names, component names etc. but not flag names. Unqualified component name consist of components separated by dash, each component is non-empty alphanumeric string, with at least one alphabetic character. In other words, component may not look like a number. - - .. math:: - {\left({\mathop{\mathit{alpha\text{-}num}}}^\ast_{}\mathop{\mathit{alpha}}{\mathop{\mathit{alpha\text{-}num}}}^\ast_{}\right)}^+_{\mathop{\mathord{``}\mathtt{\text{-}}\mathord{"}}} - -module-name - Haskell module name as recognized by Cabal parser. - - .. math:: - {\left(\mathop{\mathit{upper}}{\left\{ \mathop{\mathit{alpha\text{-}num}}\mid[\mathop{\mathord{``}\mathtt{\text{'}}\mathord{"}}\mathop{\mathord{``}\mathtt{\text{_}}\mathord{"}}] \right\}}^\ast_{}\right)}^+_{\mathop{\mathord{``}\mathtt{\text{.}}\mathord{"}}} - -version - Version is to first approximation numbers separated by dots, where leading zero is not allowed and each version digit is consists at most of nine characters. - - .. math:: - {\left\{ \mathop{\mathord{``}\mathtt{0}\mathord{"}}\mid[\mathop{\mathord{``}\mathtt{1}\mathord{"}}\cdots\mathop{\mathord{``}\mathtt{9}\mathord{"}}]{[\mathop{\mathord{``}\mathtt{0}\mathord{"}}\cdots\mathop{\mathord{``}\mathtt{9}\mathord{"}}]}^{\in [0\ldots8]}_{} \right\}}^+_{\mathop{\mathord{``}\mathtt{\text{.}}\mathord{"}}} - -version-range - Version range syntax is recursive. Also note the set syntax added in ``cabal-version: 3.0``, set cannot be empty. - - .. math:: - \mathbf{fix}\;\mathop{\mathit{version\text{-}range}}\;\mathbf{in}\;\left\{ \begin{gathered}\mathop{\mathord{``}\mathtt{\text{=}\text{=}}\mathord{"}}\circ\mathop{\mathit{version}}\\\mathop{\mathord{``}\mathtt{\text{>}}\mathord{"}}\circ\mathop{\mathit{version}}\\\mathop{\mathord{``}\mathtt{\text{<}}\mathord{"}}\circ\mathop{\mathit{version}}\\\mathop{\mathord{``}\mathtt{\text{<}\text{=}}\mathord{"}}\circ\mathop{\mathit{version}}\\\mathop{\mathord{``}\mathtt{\text{>}\text{=}}\mathord{"}}\circ\mathop{\mathit{version}}\\\mathop{\mathord{``}\mathtt{\text{^}\text{>}\text{=}}\mathord{"}}\circ\mathop{\mathit{version}}\\\mathop{\mathord{``}\mathtt{\text{=}\text{=}}\mathord{"}}\circ{\left\{ \mathop{\mathord{``}\mathtt{0}\mathord{"}}\mid[\mathop{\mathord{``}\mathtt{1}\mathord{"}}\cdots\mathop{\mathord{``}\mathtt{9}\mathord{"}}]{[\mathop{\mathord{``}\mathtt{0}\mathord{"}}\cdots\mathop{\mathord{``}\mathtt{9}\mathord{"}}]}^{\in [0\ldots8]}_{} \right\}}^+_{\mathop{\mathord{``}\mathtt{\text{.}}\mathord{"}}}\mathop{\mathord{``}\mathtt{\text{.}\text{*}}\mathord{"}}\\\mathop{\mathit{version\text{-}range}}\circ\mathop{\mathord{``}\mathtt{\text{|}\text{|}}\mathord{"}}\circ\mathop{\mathit{version\text{-}range}}\\\mathop{\mathit{version\text{-}range}}\circ\mathop{\mathord{``}\mathtt{\text{&}\text{&}}\mathord{"}}\circ\mathop{\mathit{version\text{-}range}}\\\mathop{\mathord{``}\mathtt{\text{(}}\mathord{"}}\circ\mathop{\mathit{version\text{-}range}}\circ\mathop{\mathord{``}\mathtt{\text{)}}\mathord{"}}\\\mathop{\mathord{``}\mathtt{\text{=}\text{=}}\mathord{"}}\circ\mathop{\mathord{``}\mathtt{\{}\mathord{"}}\circ{\mathop{\mathit{version}}}^+_{\left(\circ\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}\circ\right)}\circ\mathop{\mathord{``}\mathtt{\}}\mathord{"}}\\\mathop{\mathord{``}\mathtt{\text{^}\text{>}\text{=}}\mathord{"}}\circ\mathop{\mathord{``}\mathtt{\{}\mathord{"}}\circ{\mathop{\mathit{version}}}^+_{\left(\circ\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}\circ\right)}\circ\mathop{\mathord{``}\mathtt{\}}\mathord{"}}\end{gathered} \right\} - - -Build info fields ------------------ - -asm-options - * Monoidal field - * Available since ``cabal-version: 3.0``. - * Documentation of :pkg-field:`asm-options` - - .. math:: - {\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}]^c}}^+_{} \right\}}^\ast_{\bullet} - -asm-sources - * Monoidal field - * Available since ``cabal-version: 3.0``. - * Documentation of :pkg-field:`asm-sources` - - .. math:: - \mathrm{commalist}\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}]^c}}^+_{} \right\} - -autogen-includes - * Monoidal field - * Available since ``cabal-version: 3.0``. - * Documentation of :pkg-field:`autogen-includes` - - .. math:: - \mathrm{optcommalist}\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}]^c}}^+_{} \right\} - -autogen-modules - * Monoidal field - * Available since ``cabal-version: 2.0``. - * Documentation of :pkg-field:`autogen-modules` - - .. math:: - \mathrm{commalist}\left({\left(\mathop{\mathit{upper}}{\left\{ \mathop{\mathit{alpha\text{-}num}}\mid[\mathop{\mathord{``}\mathtt{\text{'}}\mathord{"}}\mathop{\mathord{``}\mathtt{\text{_}}\mathord{"}}] \right\}}^\ast_{}\right)}^+_{\mathop{\mathord{``}\mathtt{\text{.}}\mathord{"}}}\right) - -build-depends - * Monoidal field - * Documentation of :pkg-field:`build-depends` - - .. math:: - \mathrm{commalist}\left(\mathop{\mathit{pkg\text{-}name}}{\left(\mathop{\mathord{``}\mathtt{\text{:}}\mathord{"}}\left\{ \mathop{\mathit{unqual\text{-}name}}\mid\mathop{\mathord{``}\mathtt{\{}\mathord{"}}\circ{\mathop{\mathit{unqual\text{-}name}}}^+_{\left(\circ\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}\circ\right)}\circ\mathop{\mathord{``}\mathtt{\}}\mathord{"}} \right\}\right)}^?{\left(\circ\mathop{\mathit{version\text{-}range}}\right)}^?\right) - -build-tool-depends - * Monoidal field - * Documentation of :pkg-field:`build-tool-depends` - - .. math:: - \mathrm{commalist}\mathsf{\color{red}{TODO}} - -build-tools - * Monoidal field - * Deprecated since ``cabal-version: 2.0``: Please use 'build-tool-depends' field - * Removed in ``cabal-version: 3.0``: Please use 'build-tool-depends' field. - - .. math:: - \mathrm{commalist}\mathsf{\color{red}{TODO}} - -buildable - * Boolean field - * Default: ``True`` - * Documentation of :pkg-field:`buildable` - - .. math:: - \left\{ \mathop{\mathord{``}\mathtt{True}\mathord{"}}\mid\mathop{\mathord{``}\mathtt{False}\mathord{"}} \right\} - -c-sources - * Monoidal field - * Documentation of :pkg-field:`c-sources` - - .. math:: - \mathrm{commalist}\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}]^c}}^+_{} \right\} - -cc-options - * Monoidal field - * Documentation of :pkg-field:`cc-options` - - .. math:: - {\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}]^c}}^+_{} \right\}}^\ast_{\bullet} - -cmm-options - * Monoidal field - * Available since ``cabal-version: 3.0``. - * Documentation of :pkg-field:`cmm-options` - - .. math:: - {\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}]^c}}^+_{} \right\}}^\ast_{\bullet} - -cmm-sources - * Monoidal field - * Available since ``cabal-version: 3.0``. - * Documentation of :pkg-field:`cmm-sources` - - .. math:: - \mathrm{commalist}\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}]^c}}^+_{} \right\} - -cpp-options - * Monoidal field - * Documentation of :pkg-field:`cpp-options` - - .. math:: - {\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}]^c}}^+_{} \right\}}^\ast_{\bullet} - -cxx-options - * Monoidal field - * Available since ``cabal-version: 2.2``. - * Documentation of :pkg-field:`cxx-options` - - .. math:: - {\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}]^c}}^+_{} \right\}}^\ast_{\bullet} - -cxx-sources - * Monoidal field - * Available since ``cabal-version: 2.2``. - * Documentation of :pkg-field:`cxx-sources` - - .. math:: - \mathrm{commalist}\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}]^c}}^+_{} \right\} - -default-extensions - * Monoidal field - * Available since ``cabal-version: 1.10``. - * Documentation of :pkg-field:`default-extensions` - - .. math:: - \mathrm{optcommalist}\mathsf{\color{red}{TODO}} - -default-language - * Optional field - * Available since ``cabal-version: 1.10``. - * Documentation of :pkg-field:`default-language` - - .. math:: - \left\{ \mathop{\mathord{``}\mathtt{Haskell98}\mathord{"}}\mid\mathop{\mathord{``}\mathtt{Haskell2010}\mathord{"}} \right\} - -extensions - * Monoidal field - * Deprecated since ``cabal-version: 1.12``: Please use 'default-extensions' or 'other-extensions' fields. - * Removed in ``cabal-version: 3.0``: Please use 'default-extensions' or 'other-extensions' fields. - - .. math:: - \mathrm{optcommalist}\mathsf{\color{red}{TODO}} - -extra-bundled-libraries - * Monoidal field - * Documentation of :pkg-field:`extra-bundled-libraries` - - .. math:: - \mathrm{commalist}\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}]^c}}^+_{} \right\} - -extra-dynamic-library-flavours - * Monoidal field - * Available since ``cabal-version: 3.0``. - * Documentation of :pkg-field:`extra-dynamic-library-flavours` - - .. math:: - \mathrm{commalist}\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}]^c}}^+_{} \right\} - -extra-framework-dirs - * Monoidal field - * Documentation of :pkg-field:`extra-framework-dirs` - - .. math:: - \mathrm{optcommalist}\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}]^c}}^+_{} \right\} - -extra-ghci-libraries - * Monoidal field - * Documentation of :pkg-field:`extra-ghci-libraries` - - .. math:: - \mathrm{commalist}\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}]^c}}^+_{} \right\} - -extra-lib-dirs - * Monoidal field - * Documentation of :pkg-field:`extra-lib-dirs` - - .. math:: - \mathrm{optcommalist}\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}]^c}}^+_{} \right\} - -extra-libraries - * Monoidal field - * Documentation of :pkg-field:`extra-libraries` - - .. math:: - \mathrm{commalist}\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}]^c}}^+_{} \right\} - -extra-library-flavours - * Monoidal field - * Documentation of :pkg-field:`extra-library-flavours` - - .. math:: - \mathrm{commalist}\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}]^c}}^+_{} \right\} - -frameworks - * Monoidal field - * Documentation of :pkg-field:`frameworks` - - .. math:: - \mathrm{optcommalist}\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}]^c}}^+_{} \right\} - -ghc-options - * Monoidal field - * Documentation of :pkg-field:`ghc-options` - - .. math:: - {\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}]^c}}^+_{} \right\}}^\ast_{\bullet} - -ghc-prof-options - * Monoidal field - * Documentation of :pkg-field:`ghc-prof-options` - - .. math:: - {\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}]^c}}^+_{} \right\}}^\ast_{\bullet} - -ghc-shared-options - * Monoidal field - * Documentation of :pkg-field:`ghc-shared-options` - - .. math:: - {\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}]^c}}^+_{} \right\}}^\ast_{\bullet} - -ghcjs-options - * Monoidal field - * Documentation of :pkg-field:`ghcjs-options` - - .. math:: - {\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}]^c}}^+_{} \right\}}^\ast_{\bullet} - -ghcjs-prof-options - * Monoidal field - * Documentation of :pkg-field:`ghcjs-prof-options` - - .. math:: - {\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}]^c}}^+_{} \right\}}^\ast_{\bullet} - -ghcjs-shared-options - * Monoidal field - * Documentation of :pkg-field:`ghcjs-shared-options` - - .. math:: - {\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}]^c}}^+_{} \right\}}^\ast_{\bullet} - -hs-source-dir - * Monoidal field - * Deprecated since ``cabal-version: 1.2``: Please use 'hs-source-dirs' - * Removed in ``cabal-version: 3.0``: Please use 'hs-source-dirs' field. - - .. math:: - \mathrm{optcommalist}\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}]^c}}^+_{} \right\} - -hs-source-dirs - * Monoidal field - * Documentation of :pkg-field:`hs-source-dirs` - - .. math:: - \mathrm{optcommalist}\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}]^c}}^+_{} \right\} - -include-dirs - * Monoidal field - * Documentation of :pkg-field:`include-dirs` - - .. math:: - \mathrm{optcommalist}\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}]^c}}^+_{} \right\} - -includes - * Monoidal field - * Documentation of :pkg-field:`includes` - - .. math:: - \mathrm{optcommalist}\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}]^c}}^+_{} \right\} - -install-includes - * Monoidal field - * Documentation of :pkg-field:`install-includes` - - .. math:: - \mathrm{optcommalist}\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}]^c}}^+_{} \right\} - -js-sources - * Monoidal field - * Documentation of :pkg-field:`js-sources` - - .. math:: - \mathrm{commalist}\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}]^c}}^+_{} \right\} - -ld-options - * Monoidal field - * Documentation of :pkg-field:`ld-options` - - .. math:: - {\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}]^c}}^+_{} \right\}}^\ast_{\bullet} - -mixins - * Monoidal field - * Available since ``cabal-version: 2.0``. - * Documentation of :pkg-field:`mixins` - - .. math:: - \mathrm{commalist}\left(\mathop{\mathit{package\text{-}name}}{\left(\mathop{\mathord{``}\mathtt{\text{:}}\mathord{"}}\mathop{\mathit{library\text{-}name}}\right)}^?{\left(\bullet\left\{ \mid\mathop{\mathord{``}\mathtt{hiding}\mathord{"}}\circ\mathop{\mathord{``}\mathtt{\text{(}}\mathord{"}}\circ{\mathop{\mathit{module\text{-}name}}}^\ast_{\left(\circ\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}\circ\right)}\circ\mathop{\mathord{``}\mathtt{\text{)}}\mathord{"}}\mid\mathop{\mathord{``}\mathtt{\text{(}}\mathord{"}}\circ{\left(\mathop{\mathit{module\text{-}name}}{\left(\bullet\mathop{\mathord{``}\mathtt{as}\mathord{"}}\bullet\mathop{\mathit{module\text{-}name}}\right)}^?\right)}^\ast_{\left(\circ\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}\circ\right)}\circ\mathop{\mathord{``}\mathtt{\text{)}}\mathord{"}} \right\}{\left(\circ\mathop{\mathord{``}\mathtt{requires}\mathord{"}}\bullet\left\{ \mid\mathop{\mathord{``}\mathtt{hiding}\mathord{"}}\circ\mathop{\mathord{``}\mathtt{\text{(}}\mathord{"}}\circ{\mathop{\mathit{module\text{-}name}}}^\ast_{\left(\circ\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}\circ\right)}\circ\mathop{\mathord{``}\mathtt{\text{)}}\mathord{"}}\mid\mathop{\mathord{``}\mathtt{\text{(}}\mathord{"}}\circ{\left(\mathop{\mathit{module\text{-}name}}{\left(\bullet\mathop{\mathord{``}\mathtt{as}\mathord{"}}\bullet\mathop{\mathit{module\text{-}name}}\right)}^?\right)}^\ast_{\left(\circ\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}\circ\right)}\circ\mathop{\mathord{``}\mathtt{\text{)}}\mathord{"}} \right\}\right)}^?\right)}^?\right) - -other-extensions - * Monoidal field - * Available since ``cabal-version: 1.10``. - * Documentation of :pkg-field:`other-extensions` - - .. math:: - \mathrm{optcommalist}\mathsf{\color{red}{TODO}} - -other-languages - * Monoidal field - * Available since ``cabal-version: 1.10``. - * Documentation of :pkg-field:`other-languages` - - .. math:: - \mathrm{optcommalist}\left\{ \mathop{\mathord{``}\mathtt{Haskell98}\mathord{"}}\mid\mathop{\mathord{``}\mathtt{Haskell2010}\mathord{"}} \right\} - -other-modules - * Monoidal field - * Documentation of :pkg-field:`other-modules` - - .. math:: - \mathrm{commalist}\left({\left(\mathop{\mathit{upper}}{\left\{ \mathop{\mathit{alpha\text{-}num}}\mid[\mathop{\mathord{``}\mathtt{\text{'}}\mathord{"}}\mathop{\mathord{``}\mathtt{\text{_}}\mathord{"}}] \right\}}^\ast_{}\right)}^+_{\mathop{\mathord{``}\mathtt{\text{.}}\mathord{"}}}\right) - -pkgconfig-depends - * Monoidal field - * Documentation of :pkg-field:`pkgconfig-depends` - - .. math:: - \mathrm{commalist}\mathsf{\color{red}{TODO}} - -virtual-modules - * Monoidal field - * Available since ``cabal-version: 2.2``. - * Documentation of :pkg-field:`virtual-modules` - - .. math:: - \mathrm{commalist}\left({\left(\mathop{\mathit{upper}}{\left\{ \mathop{\mathit{alpha\text{-}num}}\mid[\mathop{\mathord{``}\mathtt{\text{'}}\mathord{"}}\mathop{\mathord{``}\mathtt{\text{_}}\mathord{"}}] \right\}}^\ast_{}\right)}^+_{\mathop{\mathord{``}\mathtt{\text{.}}\mathord{"}}}\right) - - -Package description fields --------------------------- - -author - * Free text field - * Documentation of :pkg-field:`author` - -bug-reports - * Free text field - * Documentation of :pkg-field:`bug-reports` - -build-type - * Optional field - * Documentation of :pkg-field:`build-type` - - .. math:: - \left\{ \begin{gathered}\mathop{\mathord{``}\mathtt{Simple}\mathord{"}}\\\mathop{\mathord{``}\mathtt{Configure}\mathord{"}}\\\mathop{\mathord{``}\mathtt{Custom}\mathord{"}}\\\mathop{\mathord{``}\mathtt{Make}\mathord{"}}\\\mathop{\mathord{``}\mathtt{Default}\mathord{"}}\end{gathered} \right\} - -cabal-version - * Optional field - * Default: ``>=1.0`` - * Documentation of :pkg-field:`cabal-version` - - .. math:: - \mathop{\mathord{``}\mathtt{3\text{.}4}\mathord{"}} - -category - * Free text field - * Documentation of :pkg-field:`category` - -copyright - * Free text field - * Documentation of :pkg-field:`copyright` - -data-dir - * Optional field - * Default: ``""`` - * Documentation of :pkg-field:`data-dir` - - .. math:: - \left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}]^c}}^+_{} \right\} - -data-files - * Monoidal field - * Documentation of :pkg-field:`data-files` - - .. math:: - \mathrm{commalist}\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}]^c}}^+_{} \right\} - -description - * Free text field - * Documentation of :pkg-field:`description` - -extra-doc-files - * Monoidal field - * Documentation of :pkg-field:`extra-doc-files` - - .. math:: - \mathrm{commalist}\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}]^c}}^+_{} \right\} - -extra-source-files - * Monoidal field - * Documentation of :pkg-field:`extra-source-files` - - .. math:: - \mathrm{commalist}\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}]^c}}^+_{} \right\} - -extra-tmp-files - * Monoidal field - * Documentation of :pkg-field:`extra-tmp-files` - - .. math:: - \mathrm{commalist}\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}]^c}}^+_{} \right\} - -homepage - * Free text field - * Documentation of :pkg-field:`homepage` - -license - * Optional field - * Default: ``NONE`` - * Documentation of :pkg-field:`license` - - .. math:: - \mathsf{\color{red}{TODO}} - -license-file - * Monoidal field - * Documentation of :pkg-field:`license-file` - - .. math:: - \mathrm{optcommalist}\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}]^c}}^+_{} \right\} - -maintainer - * Free text field - * Documentation of :pkg-field:`maintainer` - -name - * Required field - * Documentation of :pkg-field:`name` - - .. math:: - \mathop{\mathit{unqual\text{-}name}} - -package-url - * Free text field - * Documentation of :pkg-field:`package-url` - -stability - * Free text field - * Documentation of :pkg-field:`stability` - -synopsis - * Free text field - * Documentation of :pkg-field:`synopsis` - -tested-with - * Monoidal field - * Documentation of :pkg-field:`tested-with` - - .. math:: - \mathrm{optcommalist}\mathsf{\color{red}{TODO}} - -version - * Required field - * Documentation of :pkg-field:`version` - - .. math:: - {\left\{ \mathop{\mathord{``}\mathtt{0}\mathord{"}}\mid[\mathop{\mathord{``}\mathtt{1}\mathord{"}}\cdots\mathop{\mathord{``}\mathtt{9}\mathord{"}}]{[\mathop{\mathord{``}\mathtt{0}\mathord{"}}\cdots\mathop{\mathord{``}\mathtt{9}\mathord{"}}]}^{\in [0\ldots8]}_{} \right\}}^+_{\mathop{\mathord{``}\mathtt{\text{.}}\mathord{"}}} - - -Test-suite fields ------------------ - -main-is - * Optional field - * Documentation of :pkg-field:`test-suite:main-is` - - .. math:: - \left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}]^c}}^+_{} \right\} - -test-module - * Optional field - * Documentation of :pkg-field:`test-suite:test-module` - - .. math:: - {\left(\mathop{\mathit{upper}}{\left\{ \mathop{\mathit{alpha\text{-}num}}\mid[\mathop{\mathord{``}\mathtt{\text{'}}\mathord{"}}\mathop{\mathord{``}\mathtt{\text{_}}\mathord{"}}] \right\}}^\ast_{}\right)}^+_{\mathop{\mathord{``}\mathtt{\text{.}}\mathord{"}}} - -type - * Optional field - * Documentation of :pkg-field:`test-suite:type` - - .. math:: - \left\{ \mathop{\mathord{``}\mathtt{exitcode\text{-}stdio\text{-}1\text{.}0}\mathord{"}}\mid\mathop{\mathord{``}\mathtt{detailed\text{-}0\text{.}9}\mathord{"}} \right\} - - diff --git a/cabal/Cabal/doc/cabal-commands.rst b/cabal/Cabal/doc/cabal-commands.rst deleted file mode 100644 --- a/cabal/Cabal/doc/cabal-commands.rst +++ /dev/null @@ -1,402 +0,0 @@ -cabal-install Commands -====================== - -We now give an in-depth description of all the commands, describing the -arguments and flags they accept. - -cabal v2-configure -------------------- - -``cabal v2-configure`` takes a set of arguments and writes a -``cabal.project.local`` file based on the flags passed to this command. -``cabal v2-configure FLAGS; cabal v2-build`` is roughly equivalent to -``cabal v2-build FLAGS``, except that with ``v2-configure`` the flags -are persisted to all subsequent calls to ``v2-build``. - -``cabal v2-configure`` is intended to be a convenient way to write out -a ``cabal.project.local`` for simple configurations; e.g., -``cabal v2-configure -w ghc-7.8`` would ensure that all subsequent -builds with ``cabal v2-build`` are performed with the compiler -``ghc-7.8``. For more complex configuration, we recommend writing the -``cabal.project.local`` file directly (or placing it in -``cabal.project``!) - -``cabal v2-configure`` inherits options from ``Cabal``. semantics: - -- Any flag accepted by ``./Setup configure``. - -- Any flag accepted by ``cabal configure`` beyond - ``./Setup configure``, namely ``--cabal-lib-version``, - ``--constraint``, ``--preference`` and ``--solver.`` - -- Any flag accepted by ``cabal install`` beyond ``./Setup configure``. - -- Any flag accepted by ``./Setup haddock``. - -The options of all of these flags apply only to *local* packages in a -project; this behavior is different than that of ``cabal install``, -which applies flags to every package that would be built. The motivation -for this is to avoid an innocuous addition to the flags of a package -resulting in a rebuild of every package in the store (which might need -to happen if a flag actually applied to every transitive dependency). To -apply options to an external package, use a ``package`` stanza in a -``cabal.project`` file. - -cabal v2-update ----------------- - -``cabal v2-update`` updates the state of the package index. If the -project contains multiple remote package repositories it will update -the index of all of them (e.g. when using overlays). - -Some examples: - -:: - - $ cabal v2-update # update all remote repos - $ cabal v2-update head.hackage # update only head.hackage - -cabal v2-build ---------------- - -``cabal v2-build`` takes a set of targets and builds them. It -automatically handles building and installing any dependencies of these -targets. - -A target can take any of the following forms: - -- A package target: ``package``, which specifies that all enabled - components of a package to be built. By default, test suites and - benchmarks are *not* enabled, unless they are explicitly requested - (e.g., via ``--enable-tests``.) - -- A component target: ``[package:][ctype:]component``, which specifies - a specific component (e.g., a library, executable, test suite or - benchmark) to be built. - -- All packages: ``all``, which specifies all packages within the project. - -- Components of a particular type: ``package:ctypes``, ``all:ctypes``: - which specifies all components of the given type. Where valid - ``ctypes`` are: - - - ``libs``, ``libraries``, - - ``flibs``, ``foreign-libraries``, - - ``exes``, ``executables``, - - ``tests``, - - ``benches``, ``benchmarks``. - -- A module target: ``[package:][ctype:]module``, which specifies that the - component of which the given module is a part of will be built. - -- A filepath target: ``[package:][ctype:]filepath``, which specifies that the - component of which the given filepath is a part of will be built. - -In component targets, ``package:`` and ``ctype:`` (valid component types -are ``lib``, ``flib``, ``exe``, ``test`` and ``bench``) can be used to -disambiguate when multiple packages define the same component, or the -same component name is used in a package (e.g., a package ``foo`` -defines both an executable and library named ``foo``). We always prefer -interpreting a target as a package name rather than as a component name. - -Some example targets: - -:: - - $ cabal v2-build lib:foo-pkg # build the library named foo-pkg - $ cabal v2-build foo-pkg:foo-tests # build foo-tests in foo-pkg - $ cabal v2-build src/Lib.s # build the library component to - # which "src/Lib.hs" belongs - $ cabal v2-build app/Main.hs # build the executable component of - # "app/Main.hs" - $ cabal v2-build Lib # build the library component to - # which the module "Lib" belongs - -Beyond a list of targets, ``cabal v2-build`` accepts all the flags that -``cabal v2-configure`` takes. Most of these flags are only taken into -consideration when building local packages; however, some flags may -cause extra store packages to be built (for example, -``--enable-profiling`` will automatically make sure profiling libraries -for all transitive dependencies are built and installed.) - -In addition ``cabal v2-build`` accepts these flags: - -- ``--only-configure``: When given we will forego performing a full build and - abort after running the configure phase of each target package. - - -cabal v2-repl --------------- - -``cabal v2-repl TARGET`` loads all of the modules of the target into -GHCi as interpreted bytecode. In addition to ``cabal v2-build``'s flags, -it takes an additional ``--repl-options`` flag. - -To avoid ``ghci`` specific flags from triggering unneeded global rebuilds these -flags are now stripped from the internal configuration. As a result -``--ghc-options`` will no longer (reliably) work to pass flags to ``ghci`` (or -other repls). Instead, you should use the new ``--repl-options`` flag to -specify these options to the invoked repl. (This flag also works on ``cabal -repl`` and ``Setup repl`` on sufficiently new versions of Cabal.) - -Currently, it is not supported to pass multiple targets to ``v2-repl`` -(``v2-repl`` will just successively open a separate GHCi session for -each target.) - -It also provides a way to experiment with libraries without needing to download -them manually or to install them globally. - -This command opens a REPL with the current default target loaded, and a version -of the ``vector`` package matching that specification exposed. - -:: - - $ cabal v2-repl --build-depends "vector >= 0.12 && < 0.13" - -Both of these commands do the same thing as the above, but only exposes ``base``, -``vector``, and the ``vector`` package's transitive dependencies even if the user -is in a project context. - -:: - - $ cabal v2-repl --ignore-project --build-depends "vector >= 0.12 && < 0.13" - $ cabal v2-repl --project='' --build-depends "vector >= 0.12 && < 0.13" - -This command would add ``vector``, but not (for example) ``primitive``, because -it only includes the packages specified on the command line (and ``base``, which -cannot be excluded for technical reasons). - -:: - - $ cabal v2-repl --build-depends vector --no-transitive-deps - -cabal v2-run -------------- - -``cabal v2-run [TARGET [ARGS]]`` runs the executable specified by the -target, which can be a component, a package or can be left blank, as -long as it can uniquely identify an executable within the project. -Tests and benchmarks are also treated as executables. - -See `the v2-build section <#cabal-v2-build>`__ for the target syntax. - -Except in the case of the empty target, the strings after it will be -passed to the executable as arguments. - -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 -have to separate them with ``--``. - -:: - - $ cabal v2-run target -- -a -bcd --argument - -``v2-run`` also supports running script files that use a certain format. With -a script that looks like: - -:: - - #!/usr/bin/env cabal - {- cabal: - build-depends: base ^>= 4.11 - , shelly ^>= 1.8.1 - -} - - main :: IO () - main = do - ... - -It can either be executed like any other script, using ``cabal`` as an -interpreter, or through this command: - -:: - - $ cabal v2-run script.hs - $ cabal v2-run script.hs -- --arg1 # args are passed like this - -cabal v2-freeze ----------------- - -``cabal v2-freeze`` writes out a **freeze file** which records all of -the versions and flags that are picked by the solver under the -current index and flags. Default name of this file is -``cabal.project.freeze`` but in combination with a -``--project-file=my.project`` flag (see :ref:`project-file -`) -the name will be ``my.project.freeze``. -A freeze file has the same syntax as ``cabal.project`` and looks -something like this: - -.. highlight:: cabal - -:: - - constraints: HTTP ==4000.3.3, - HTTP +warp-tests -warn-as-error -network23 +network-uri -mtl1 -conduit10, - QuickCheck ==2.9.1, - QuickCheck +templatehaskell, - -- etc... - - -For end-user executables, it is recommended that you distribute the -``cabal.project.freeze`` file in your source repository so that all -users see a consistent set of dependencies. For libraries, this is not -recommended: users often need to build against different versions of -libraries than what you developed against. - -cabal v2-bench ---------------- - -``cabal v2-bench [TARGETS] [OPTIONS]`` runs the specified benchmarks -(all the benchmarks in the current package by default), first ensuring -they are up to date. - -cabal v2-test --------------- - -``cabal v2-test [TARGETS] [OPTIONS]`` runs the specified test suites -(all the test suites in the current package by default), first ensuring -they are up to date. - -cabal v2-haddock ------------------ - -``cabal v2-haddock [FLAGS] [TARGET]`` builds Haddock documentation for -the specified packages within the project. - -If a target is not a library :cfg-field:`haddock-benchmarks`, -:cfg-field:`haddock-executables`, :cfg-field:`haddock-internal`, -:cfg-field:`haddock-tests` will be implied as necessary. - -cabal v2-exec ---------------- - -``cabal v2-exec [FLAGS] [--] COMMAND [--] [ARGS]`` runs the specified command -using the project's environment. That is, passing the right flags to compiler -invocations and bringing the project's executables into scope. - -cabal v2-install ------------------ - -``cabal v2-install [FLAGS] PACKAGES`` builds the specified packages and -symlinks/copies their executables in ``installdir`` (usually ``~/.cabal/bin``). - -For example this command will build the latest ``cabal-install`` and symlink -its ``cabal`` executable: - -:: - - $ cabal v2-install cabal-install - -In addition, it's possible to use ``cabal v2-install`` to install components -of a local project. For example, with an up-to-date Git clone of the Cabal -repository, this command will build cabal-install HEAD and symlink the -``cabal`` executable: - -:: - - $ cabal v2-install exe:cabal - -Where symlinking is not possible (eg. on some Windows versions) the ``copy`` -method is used by default. You can specify the install method -by using ``--install-method`` flag: - -:: - - $ cabal v2-install exe:cabal --install-method=copy --installdir=$HOME/bin - -Note that copied executables are not self-contained, since they might use -data-files from the store. - -It is also possible to "install" libraries using the ``--lib`` flag. For -example, this command will build the latest Cabal library and install it: - -:: - - $ cabal v2-install --lib Cabal - -This works by managing GHC environments. By default, it is writing to the -global environment in ``~/.ghc/$ARCH-$OS-$GHCVER/environments/default``. -``v2-install`` provides the ``--package-env`` flag to control which of -these environments is modified. - -This command will modify the environment file in the current directory: - -:: - - $ cabal v2-install --lib Cabal --package-env . - -This command will modify the environment file in the ``~/foo`` directory: - -:: - - $ cabal v2-install --lib Cabal --package-env foo/ - -Do note that the results of the previous two commands will be overwritten by -the use of other v2-style commands, so it is not recommended to use them inside -a project directory. - -This command will modify the environment in the ``local.env`` file in the -current directory: - -:: - - $ cabal v2-install --lib Cabal --package-env local.env - -This command will modify the ``myenv`` named global environment: - -:: - - $ cabal v2-install --lib Cabal --package-env myenv - -If you wish to create a named environment file in the current directory where -the name does not contain an extension, you must reference it as ``./myenv``. - -You can learn more about how to use these environments in `this section of the -GHC manual `_. - -cabal v2-clean ---------------- - -``cabal v2-clean [FLAGS]`` cleans up the temporary files and build artifacts -stored in the ``dist-newstyle`` folder. - -By default, it removes the entire folder, but it can also spare the configuration -and caches if the ``--save-config`` option is given, in which case it only removes -the build artefacts (``.hi``, ``.o`` along with any other temporary files generated -by the compiler, along with the build output). - -cabal v2-sdist ---------------- - -``cabal v2-sdist [FLAGS] [TARGETS]`` takes the crucial files needed to build ``TARGETS`` -and puts them into an archive format ready for upload to Hackage. These archives are stable -and two archives of the same format built from the same source will hash to the same value. - -``cabal v2-sdist`` takes the following flags: - -- ``-l``, ``--list-only``: Rather than creating an archive, lists files that would be included. - Output is to ``stdout`` by default. The file paths are relative to the project's root - directory. - -- ``-o``, ``--output-directory``: Sets the output dir, if a non-default one is desired. The default is - ``dist-newstyle/sdist/``. ``--output-directory -`` will send output to ``stdout`` - unless multiple archives are being created. - -- ``--null-sep``: Only used with ``--list-only``. Separates filenames with a NUL - byte instead of newlines. - -``v2-sdist`` is inherently incompatible with sdist hooks (which were removed in `Cabal-3.0`), -not due to implementation but due to fundamental core invariants -(same source code should result in the same tarball, byte for byte) -that must be satisfied for it to function correctly in the larger v2-build ecosystem. -``autogen-modules`` is able to replace uses of the hooks to add generated modules, along with -the custom publishing of Haddock documentation to Hackage. - -.. warning:: - - Packages that use Backpack will stop working if uploaded to - Hackage, due to `issue #6005 `_. - While this is happening, we recommend not uploading these packages - to Hackage (and instead referencing the package directly - as a ``source-repository-package``). diff --git a/cabal/Cabal/doc/cabal-package.rst b/cabal/Cabal/doc/cabal-package.rst deleted file mode 100644 --- a/cabal/Cabal/doc/cabal-package.rst +++ /dev/null @@ -1,3335 +0,0 @@ -Package Description -=================== - -The Cabal package is the unit of distribution. When installed, its -purpose is to make available: - -- One or more Haskell programs. - -- At most one library, exposing a number of Haskell modules. - -However having both a library and executables in a package does not work -very well; if the executables depend on the library, they must -explicitly list all the modules they directly or indirectly import from -that library. Fortunately, starting with Cabal 1.8.0.4, executables can -also declare the package that they are in as a dependency, and Cabal -will treat them as if they were in another package that depended on the -library. - -Internally, the package may consist of much more than a bunch of Haskell -modules: it may also have C source code and header files, source code -meant for preprocessing, documentation, test cases, auxiliary tools etc. - -A package is identified by a globally-unique *package name*, which -consists of one or more alphanumeric words separated by hyphens. To -avoid ambiguity, each of these words should contain at least one letter. -Chaos will result if two distinct packages with the same name are -installed on the same system. A particular version of the package is -distinguished by a *version number*, consisting of a sequence of one or -more integers separated by dots. These can be combined to form a single -text string called the *package ID*, using a hyphen to separate the name -from the version, e.g. "``HUnit-1.1``". - -.. Note:: - - Packages are not part of the Haskell language; they simply - populate the hierarchical space of module names. In GHC 6.6 and later a - program may contain multiple modules with the same name if they come - from separate packages; in all other current Haskell systems packages - may not overlap in the modules they provide, including hidden modules. - -Creating a package ------------------- - -Suppose you have a directory hierarchy containing the source files that -make up your package. You will need to add two more files to the root -directory of the package: - -:file:`{package-name}.cabal` - a Unicode UTF-8 text file containing a package description. For - details of the syntax of this file, see the section on - `package descriptions`_. - -:file:`Setup.hs` - a single-module Haskell program to perform various setup tasks (with - the interface described in the section on :ref:`installing-packages`). - This module should import only modules that will be present in all Haskell - implementations, including modules of the Cabal library. The content of - this file is determined by the :pkg-field:`build-type` setting in the - ``.cabal`` file. In most cases it will be trivial, calling on the Cabal - library to do most of the work. - -Once you have these, you can create a source bundle of this directory -for distribution. Building of the package is discussed in the section on -:ref:`installing-packages`. - -One of the purposes of Cabal is to make it easier to build a package -with different Haskell implementations. So it provides abstractions of -features present in different Haskell implementations and wherever -possible it is best to take advantage of these to increase portability. -Where necessary however it is possible to use specific features of -specific implementations. For example one of the pieces of information a -package author can put in the package's ``.cabal`` file is what language -extensions the code uses. This is far preferable to specifying flags for -a specific compiler as it allows Cabal to pick the right flags for the -Haskell implementation that the user picks. It also allows Cabal to -figure out if the language extension is even supported by the Haskell -implementation that the user picks. Where compiler-specific options are -needed however, there is an "escape hatch" available. The developer can -specify implementation-specific options and more generally there is a -configuration mechanism to customise many aspects of how a package is -built depending on the Haskell implementation, the Operating system, -computer architecture and user-specified configuration flags. - -:: - - name: Foo - version: 1.0 - - library - build-depends: base >= 4 && < 5 - exposed-modules: Foo - extensions: ForeignFunctionInterface - ghc-options: -Wall - if os(windows) - build-depends: Win32 >= 2.1 && < 2.6 - -Example: A package containing a simple library -^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - -The HUnit package contains a file ``HUnit.cabal`` containing: - -:: - - name: HUnit - version: 1.1.1 - synopsis: A unit testing framework for Haskell - homepage: http://hunit.sourceforge.net/ - category: Testing - author: Dean Herington - license: BSD3 - license-file: LICENSE - cabal-version: 1.12 - build-type: Simple - - library - build-depends: base >= 2 && < 4 - exposed-modules: Test.HUnit.Base, Test.HUnit.Lang, - Test.HUnit.Terminal, Test.HUnit.Text, Test.HUnit - default-extensions: CPP - -and the following ``Setup.hs``: - -.. code-block:: haskell - - import Distribution.Simple - main = defaultMain - -Example: A package containing executable programs -^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - -:: - - name: TestPackage - version: 0.0 - synopsis: Small package with two programs - author: Angela Author - license: BSD3 - build-type: Simple - cabal-version: >= 1.8 - - executable program1 - build-depends: HUnit >= 1.1.1 && < 1.2 - main-is: Main.hs - hs-source-dirs: prog1 - - executable program2 - main-is: Main.hs - build-depends: HUnit >= 1.1.1 && < 1.2 - hs-source-dirs: prog2 - other-modules: Utils - -with ``Setup.hs`` the same as above. - -Example: A package containing a library and executable programs -^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - -:: - - name: TestPackage - version: 0.0 - synopsis: Package with library and two programs - license: BSD3 - author: Angela Author - build-type: Simple - cabal-version: >= 1.8 - - library - build-depends: HUnit >= 1.1.1 && < 1.2 - exposed-modules: A, B, C - - executable program1 - main-is: Main.hs - hs-source-dirs: prog1 - other-modules: A, B - - executable program2 - main-is: Main.hs - hs-source-dirs: prog2 - other-modules: A, C, Utils - -with ``Setup.hs`` the same as above. Note that any library modules -required (directly or indirectly) by an executable must be listed again. - -The trivial setup script used in these examples uses the *simple build -infrastructure* provided by the Cabal library (see -`Distribution.Simple <../release/cabal-latest/doc/API/Cabal/Distribution-Simple.html>`__). -The simplicity lies in its interface rather that its implementation. It -automatically handles preprocessing with standard preprocessors, and -builds packages for all the Haskell implementations. - -The simple build infrastructure can also handle packages where building -is governed by system-dependent parameters, if you specify a little more -(see the section on `system-dependent parameters`_). -A few packages require `more elaborate solutions `_. - -.. _pkg-desc: - -Package descriptions --------------------- - -The package description file must have a name ending in "``.cabal``". It -must be a Unicode text file encoded using valid UTF-8. There must be -exactly one such file in the directory. The first part of the name is -usually the package name, and some of the tools that operate on Cabal -packages require this; specifically, Hackage rejects packages which -don't follow this rule. - -In the package description file, lines whose first non-whitespace -characters are "``--``" are treated as comments and ignored. - -This file should contain a number global property descriptions and -several sections. - -- The `package properties`_ describe the package - as a whole, such as name, license, author, etc. - -- Optionally, a number of *configuration flags* can be declared. These - can be used to enable or disable certain features of a package. (see - the section on `configurations`_). - -- The (optional) library section specifies the `library`_ properties and - relevant `build information`_. - -- Following is an arbitrary number of executable sections which describe - an executable program and relevant `build information`_. - -Each section consists of a number of property descriptions in the form -of field/value pairs, with a syntax roughly like mail message headers. - -- Case is not significant in field names, but is significant in field - values. - -- To continue a field value, indent the next line relative to the field - name. - -- Field names may be indented, but all field values in the same section - must use the same indentation. - -- Tabs are *not* allowed as indentation characters due to a missing - standard interpretation of tab width. - -- Before Cabal 3.0, to get a blank line in a field value, use an indented "``.``" - -The syntax of the value depends on the field. Field types include: - -*token*, *filename*, *directory* - Either a sequence of one or more non-space non-comma characters, or - a quoted string in Haskell 98 lexical syntax. The latter can be used - for escaping whitespace, for example: - ``ghc-options: -Wall "-with-rtsopts=-T -I1"``. Unless otherwise - stated, relative filenames and directories are interpreted from the - package root directory. -*freeform*, *URL*, *address* - An arbitrary, uninterpreted string. -*identifier* - A letter followed by zero or more alphanumerics or underscores. -*compiler* - A compiler flavor (one of: ``GHC``, ``UHC`` or ``LHC``) - followed by a version range. For example, ``GHC ==6.10.3``, or - ``LHC >=0.6 && <0.8``. - -Modules and preprocessors -^^^^^^^^^^^^^^^^^^^^^^^^^ - -Haskell module names listed in the :pkg-field:`library:exposed-modules` and -:pkg-field:`library:other-modules` fields may correspond to Haskell source -files, i.e. with names ending in "``.hs``" or "``.lhs``", or to inputs for -various Haskell preprocessors. The simple build infrastructure understands the -extensions: - -- ``.gc`` (:hackage-pkg:`greencard`) -- ``.chs`` (:hackage-pkg:`c2hs`) -- ``.hsc`` (:hackage-pkg:`hsc2hs`) -- ``.y`` and ``.ly`` (happy_) -- ``.x`` (alex_) -- ``.cpphs`` (cpphs_) - -When building, Cabal will automatically run the appropriate preprocessor -and compile the Haskell module it produces. For the ``c2hs`` and -``hsc2hs`` preprocessors, Cabal will also automatically add, compile and -link any C sources generated by the preprocessor (produced by -``hsc2hs``'s ``#def`` feature or ``c2hs``'s auto-generated wrapper -functions). Dependencies on pre-processors are specified via the -:pkg-field:`build-tools` or :pkg-field:`build-tool-depends` fields. - -Some fields take lists of values, which are optionally separated by -commas, except for the :pkg-field:`build-depends` field, where the commas are -mandatory. - -Some fields are marked as required. All others are optional, and unless -otherwise specified have empty default values. - -Package properties -^^^^^^^^^^^^^^^^^^ - -These fields may occur in the first top-level properties section and -describe the package as a whole: - -.. pkg-field:: name: package-name (required) - - The unique name of the package, without the version number. - - As pointed out in the section on `package descriptions`_, some - tools require the package-name specified for this field to match - the package description's file-name :file:`{package-name}.cabal`. - - Package names are case-sensitive and must match the regular expression - (i.e. alphanumeric "words" separated by dashes; each alphanumeric - word must contain at least one letter): - ``[[:digit:]]*[[:alpha:]][[:alnum:]]*(-[[:digit:]]*[[:alpha:]][[:alnum:]]*)*``. - - Or, expressed in ABNF_: - - .. code-block:: abnf - - package-name = package-name-part *("-" package-name-part) - package-name-part = *DIGIT UALPHA *UALNUM - - UALNUM = UALPHA / DIGIT - UALPHA = ... ; set of alphabetic Unicode code-points - - .. note:: - - Hackage restricts package names to the ASCII subset. - -.. pkg-field:: version: numbers (required) - - The package version number, usually consisting of a sequence of - natural numbers separated by dots, i.e. as the regular - expression ``[0-9]+([.][0-9]+)*`` or expressed in ABNF_: - - .. code-block:: abnf - - package-version = 1*DIGIT *("." 1*DIGIT) - -.. pkg-field:: cabal-version: x.y[.z] - - The version of the Cabal specification that this package - description uses. The Cabal specification does slowly evolve (see - also :ref:`spec-history`), introducing new features and - occasionally changing the meaning of existing features. - Specifying which version of the specification you are using - enables programs which process the package description to know - what syntax to expect and what each part means. - - The version number you specify will affect both compatibility and - behaviour. Most tools (including the Cabal library and the ``cabal`` - program) understand a range of versions of the Cabal specification. - Older tools will of course only work with older versions of the - Cabal specification that was known at the time. Most of the time, - tools that are too old will recognise this fact and produce a - suitable error message. Likewise, ``cabal check`` will tell you - whether the version number is sufficiently high for the features - you use in the package description. - - As for behaviour, new versions of the Cabal specification can change the - meaning of existing syntax. This means if you want to take advantage - of the new meaning or behaviour then you must specify the newer - Cabal version. Tools are expected to use the meaning and behaviour - appropriate to the version given in the package description. - - In particular, the syntax of package descriptions changed - significantly with Cabal version 1.2 and the :pkg-field:`cabal-version` - field is now required. Files written in the old syntax are still - recognized, so if you require compatibility with very old Cabal - versions then you may write your package description file using the - old syntax. Please consult the user's guide of an older Cabal - version for a description of that syntax. - - Starting with ``cabal-version: 2.2`` this field is only valid if - fully contained in the very first line of a package description - and ought to adhere to the ABNF_ grammar - - .. code-block:: abnf - - newstyle-spec-version-decl = "cabal-version" *WS ":" *WS newstyle-spec-version *WS - - newstyle-spec-version = NUM "." NUM [ "." NUM ] - - NUM = DIGIT0 / DIGITP 1*DIGIT0 - DIGIT0 = %x30-39 - DIGITP = %x31-39 - WS = %20 - - - .. note:: - - For package descriptions using a format prior to - ``cabal-version: 1.12`` the legacy syntax resembling a version - range syntax - - .. code-block:: cabal - - cabal-version: >= 1.10 - - needs to be used. - - This legacy syntax is supported up until ``cabal-version: >= - 2.0`` it is however strongly recommended to avoid using the - legacy syntax. See also :issue:`4899`. - - - -.. pkg-field:: build-type: identifier - - :default: ``Custom`` or ``Simple`` - - The type of build used by this package. Build types are the - constructors of the - `BuildType <../release/cabal-latest/doc/API/Cabal/Distribution-PackageDescription.html#t:BuildType>`__ - type. This field is optional and when missing, its default value - is inferred according to the following rules: - - - When :pkg-field:`cabal-version` is set to ``2.2`` or higher, - the default is ``Simple`` unless a :pkg-section:`custom-setup` - exists, in which case the inferred default is ``Custom``. - - - For lower :pkg-field:`cabal-version` values, the default is - ``Custom`` unconditionally. - - If the build type is anything other than ``Custom``, then the - ``Setup.hs`` file *must* be exactly the standardized content - discussed below. This is because in these cases, ``cabal`` will - ignore the ``Setup.hs`` file completely, whereas other methods of - package management, such as ``runhaskell Setup.hs [CMD]``, still - rely on the ``Setup.hs`` file. - - For build type ``Simple``, the contents of ``Setup.hs`` must be: - - .. code-block:: haskell - - import Distribution.Simple - main = defaultMain - - For build type ``Configure`` (see the section on `system-dependent - parameters`_ below), the contents of - ``Setup.hs`` must be: - - .. code-block:: haskell - - import Distribution.Simple - main = defaultMainWithHooks autoconfUserHooks - - For build type ``Make`` (see the section on `more complex packages`_ below), - the contents of ``Setup.hs`` must be: - - .. code-block:: haskell - - import Distribution.Make - main = defaultMain - - For build type ``Custom``, the file ``Setup.hs`` can be customized, - and will be used both by ``cabal`` and other tools. - - For most packages, the build type ``Simple`` is sufficient. - -.. pkg-field:: license: SPDX expression - - :default: ``NONE`` - - The type of license under which this package is distributed. - - Starting with ``cabal-version: 2.2`` the ``license`` field takes a - (case-sensitive) SPDX expression such as - - .. code-block:: cabal - - license: Apache-2.0 AND (MIT OR GPL-2.0-or-later) - - See `SPDX IDs: How to use `__ for more - examples of SPDX expressions. - - The version of the - `list of SPDX license identifiers `__ - is a function of the :pkg-field:`cabal-version` value as defined - in the following table: - - +--------------------------+--------------------+ - | Cabal specification | SPDX license list | - | version | version | - | | | - +==========================+====================+ - | ``cabal-version: 2.2`` | ``3.0 2017-12-28`` | - +--------------------------+--------------------+ - | ``cabal-version: 2.4`` | ``3.2 2018-07-10`` | - +--------------------------+--------------------+ - - **Pre-SPDX Legacy Identifiers** - - The license identifier in the table below are defined for - ``cabal-version: 2.0`` and previous versions of the Cabal - specification. - - +--------------------------+-----------------+ - | :pkg-field:`license` | Note | - | identifier | | - | | | - +==========================+=================+ - | ``GPL`` | | - | ``GPL-2`` | | - | ``GPL-3`` | | - +--------------------------+-----------------+ - | ``LGPL`` | | - | ``LGPL-2.1`` | | - | ``LGPL-3`` | | - +--------------------------+-----------------+ - | ``AGPL`` | since 1.18 | - | ``AGPL-3`` | | - +--------------------------+-----------------+ - | ``BSD2`` | since 1.20 | - +--------------------------+-----------------+ - | ``BSD3`` | | - +--------------------------+-----------------+ - | ``MIT`` | | - +--------------------------+-----------------+ - | ``ISC`` | since 1.22 | - +--------------------------+-----------------+ - | ``MPL-2.0`` | since 1.20 | - +--------------------------+-----------------+ - | ``Apache`` | | - | ``Apache-2.0`` | | - +--------------------------+-----------------+ - | ``PublicDomain`` | | - +--------------------------+-----------------+ - | ``AllRightsReserved`` | | - +--------------------------+-----------------+ - | ``OtherLicense`` | | - +--------------------------+-----------------+ - - -.. pkg-field:: license-file: filename - - See :pkg-field:`license-files`. - -.. pkg-field:: license-files: filename list - :since: 1.20 - - The name of a file(s) containing the precise copyright license for - this package. The license file(s) will be installed with the - package. - - If you have multiple license files then use the :pkg-field:`license-files` - field instead of (or in addition to) the :pkg-field:`license-file` field. - -.. pkg-field:: copyright: freeform - - The content of a copyright notice, typically the name of the holder - of the copyright on the package and the year(s) from which copyright - is claimed. For example:: - - copyright: (c) 2006-2007 Joe Bloggs - -.. pkg-field:: author: freeform - - The original author of the package. - - Remember that ``.cabal`` files are Unicode, using the UTF-8 - encoding. - -.. pkg-field:: maintainer: address - - The current maintainer or maintainers of the package. This is an - e-mail address to which users should send bug reports, feature - requests and patches. - -.. pkg-field:: stability: freeform - - The stability level of the package, e.g. ``alpha``, - ``experimental``, ``provisional``, ``stable``. - -.. pkg-field:: homepage: URL - - The package homepage. - -.. pkg-field:: bug-reports: URL - - The URL where users should direct bug reports. This would normally - be either: - - - A ``mailto:`` URL, e.g. for a person or a mailing list. - - - An ``http:`` (or ``https:``) URL for an online bug tracking - system. - - For example Cabal itself uses a web-based bug tracking system - - :: - - bug-reports: https://github.com/haskell/cabal/issues - -.. pkg-field:: package-url: URL - - The location of a source bundle for the package. The distribution - should be a Cabal package. - -.. pkg-field:: synopsis: freeform - - A very short description of the package, for use in a table of - packages. This is your headline, so keep it short (one line) but as - informative as possible. Save space by not including the package - name or saying it's written in Haskell. - -.. pkg-field:: description: freeform - - Description of the package. This may be several paragraphs, and - should be aimed at a Haskell programmer who has never heard of your - package before. - - For library packages, this field is used as prologue text by - :ref:`setup-haddock` and thus may contain the same markup as Haddock_ - documentation comments. - -.. pkg-field:: category: freeform - - A classification category for future use by the package catalogue - Hackage_. These categories have not - yet been specified, but the upper levels of the module hierarchy - make a good start. - -.. pkg-field:: tested-with: compiler list - - A list of compilers and versions against which the package has been - tested (or at least built). The value of this field is not used by Cabal - and is rather intended as extra metadata for use by third party - tooling, such as e.g. CI tooling. - - Here's a typical usage example - - :: - - tested-with: GHC == 8.6.3, GHC == 8.4.4, GHC == 8.2.2, GHC == 8.0.2, - GHC == 7.10.3, GHC == 7.8.4, GHC == 7.6.3, GHC == 7.4.2 - - which can (starting with Cabal 3.0) also be written using the more - concise set notation syntax - - :: - - tested-with: GHC == { 8.6.3, 8.4.4, 8.2.2, 8.0.2, 7.10.3, 7.8.4, 7.6.3, 7.4.2 } - -.. pkg-field:: data-files: filename list - - A list of files to be installed for run-time use by the package. - This is useful for packages that use a large amount of static data, - such as tables of values or code templates. Cabal provides a way to - `find these files at run-time <#accessing-data-files-from-package-code>`_. - - A limited form of ``*`` wildcards in file names, for example - ``data-files: images/*.png`` matches all the ``.png`` files in the - ``images`` directory. ``data-files: audio/**/*.mp3`` matches all - the ``.mp3`` files in the ``audio`` directory, including - subdirectories. - - The specific limitations of this wildcard syntax are - - - ``*`` wildcards are only allowed in place of the file name, not - in the directory name or file extension. It must replace the - whole file name (e.g., ``*.html`` is allowed, but - ``chapter-*.html`` is not). If a wildcard is used, it must be - used with an extension, so ``data-files: data/*`` is not - allowed. - - - Prior to Cabal 2.4, when matching a wildcard plus extension, a - file's full extension must match exactly, so ``*.gz`` matches - ``foo.gz`` but not ``foo.tar.gz``. This restriction has been - lifted when ``cabal-version: 2.4`` or greater so that ``*.gz`` - does match ``foo.tar.gz`` - - - ``*`` wildcards will not match if the file name is empty (e.g., - ``*.html`` will not match ``foo/.html``). - - - ``**`` wildcards can only appear as the final path component - before the file name (e.g., ``data/**/images/*.jpg`` is not - allowed). If a ``**`` wildcard is used, then the file name must - include a ``*`` wildcard (e.g., ``data/**/README.rst`` is not - allowed). - - - A wildcard that does not match any files is an error. - - The reason for providing only a very limited form of wildcard is to - concisely express the common case of a large number of related files - of the same file type without making it too easy to accidentally - include unwanted files. - - On efficiency: if you use ``**`` patterns, the directory tree will - be walked starting with the parent directory of the ``**``. If - that's the root of the project, this might include ``.git/``, - ``dist-newstyle/``, or other large directories! To avoid this - behaviour, put the files that wildcards will match against in - their own folder. - - ``**`` wildcards are available starting in Cabal 2.4. - -.. pkg-field:: data-dir: directory - - The directory where Cabal looks for data files to install, relative - to the source directory. By default, Cabal will look in the source - directory itself. - -.. pkg-field:: extra-source-files: filename list - - A list of additional files to be included in source distributions - built with :ref:`setup-sdist`. As with :pkg-field:`data-files` it can use - a limited form of ``*`` wildcards in file names. - -.. pkg-field:: extra-doc-files: filename list - :since: 1.18 - - A list of additional files to be included in source distributions, - and also copied to the html directory when Haddock documentation is - generated. As with :pkg-field:`data-files` it can use a limited form of - ``*`` wildcards in file names. - -.. pkg-field:: extra-tmp-files: filename list - - A list of additional files or directories to be removed by - :ref:`setup-clean`. These would typically be additional files created by - additional hooks, such as the scheme described in the section on - `system-dependent parameters`_ - -Library -^^^^^^^ - -.. pkg-section:: library name - :synopsis: Library build information. - - Build information for libraries. - - Currently, there can only be one publicly exposed library in a - package, and its name is the same as package name set by global - :pkg-field:`name` field. In this case, the ``name`` argument to - the :pkg-section:`library` section must be omitted. - - Starting with Cabal 2.0, private internal sub-library components - can be defined by setting the ``name`` field to a name - different from the current package's name; see section on - :ref:`Internal Libraries ` for more information. - -The library section should contain the following fields: - -.. pkg-field:: exposed-modules: identifier list - - :required: if this package contains a library - - A list of modules added by this package. - -.. pkg-field:: virtual-modules: identifier list - :since: 2.2 - - A list of virtual modules provided by this package. Virtual modules - are modules without a source file. See for example the ``GHC.Prim`` - module from the ``ghc-prim`` package. Modules listed here will not be - built, but still end up in the list of ``exposed-modules`` in the - installed package info when the package is registered in the package - database. - -.. pkg-field:: exposed: boolean - - :default: ``True`` - - Some Haskell compilers (notably GHC) support the notion of packages - being "exposed" or "hidden" which means the modules they provide can - be easily imported without always having to specify which package - they come from. However this only works effectively if the modules - provided by all exposed packages do not overlap (otherwise a module - import would be ambiguous). - - Almost all new libraries use hierarchical module names that do not - clash, so it is very uncommon to have to use this field. However it - may be necessary to set ``exposed: False`` for some old libraries - that use a flat module namespace or where it is known that the - exposed modules would clash with other common modules. - -.. pkg-field:: visibility: visibility specifiers - - :since: 3.0 - - :default: ``private`` for internal libraries. Cannot be set for public library. - - Cabal recognizes ``public`` and ``private`` here... - - Multiple public libraries... - -.. pkg-field:: reexported-modules: exportlist - :since: 1.22 - - Supported only in GHC 7.10 and later. A list of modules to - *reexport* from this package. The syntax of this field is - ``orig-pkg:Name as NewName`` to reexport module ``Name`` from - ``orig-pkg`` with the new name ``NewName``. We also support - abbreviated versions of the syntax: if you omit ``as NewName``, - we'll reexport without renaming; if you omit ``orig-pkg``, then we - will automatically figure out which package to reexport from, if - it's unambiguous. - - Reexported modules are useful for compatibility shims when a package - has been split into multiple packages, and they have the useful - property that if a package provides a module, and another package - reexports it under the same name, these are not considered a - conflict (as would be the case with a stub module.) They can also be - used to resolve name conflicts. - -.. pkg-field:: signatures: signature list - :since: 2.0 - - Supported only in GHC 8.2 and later. A list of `module signatures `__ required by this package. - - Module signatures are part of the Backpack_ extension to - the Haskell module system. - - Packages that do not export any modules and only export required signatures - are called "signature-only packages", and their signatures are subjected to - `signature thinning - `__. - - - -The library section may also contain build information fields (see the -section on `build information`_). - -.. _sublibs: - -**Internal Libraries** - -Cabal 2.0 and later support "internal libraries", which are extra named -libraries (as opposed to the usual unnamed library section). For -example, suppose that your test suite needs access to some internal -modules in your library, which you do not otherwise want to export. You -could put these modules in an internal library, which the main library -and the test suite :pkg-field:`build-depends` upon. Then your Cabal file might -look something like this: - -:: - - cabal-version: 2.0 - name: foo - version: 0.1.0.0 - license: BSD3 - build-type: Simple - - library foo-internal - exposed-modules: Foo.Internal - -- NOTE: no explicit constraints on base needed - -- as they're inherited from the 'library' stanza - build-depends: base - - library - exposed-modules: Foo.Public - build-depends: foo-internal, base >= 4.3 && < 5 - - test-suite test-foo - type: exitcode-stdio-1.0 - main-is: test-foo.hs - -- NOTE: no constraints on 'foo-internal' as same-package - -- dependencies implicitly refer to the same package instance - build-depends: foo-internal, base - -Internal libraries are also useful for packages that define multiple -executables, but do not define a publicly accessible library. Internal -libraries are only visible internally in the package (so they can only -be added to the :pkg-field:`build-depends` of same-package libraries, -executables, test suites, etc.) Internal libraries locally shadow any -packages which have the same name; consequently, don't name an internal -library with the same name as an external dependency if you need to be -able to refer to the external dependency in a -:pkg-field:`build-depends` declaration. - -Shadowing can be used to vendor an external dependency into a package -and thus emulate *private dependencies*. Below is an example based on -a real-world use case: - -:: - - cabal-version: 2.2 - name: haddock-library - version: 1.6.0 - - library - build-depends: - , base ^>= 4.11.1.0 - , bytestring ^>= 0.10.2.0 - , containers ^>= 0.4.2.1 || ^>= 0.5.0.0 - , transformers ^>= 0.5.0.0 - - hs-source-dirs: src - - -- internal sub-lib - build-depends: attoparsec - - exposed-modules: - Documentation.Haddock - - library attoparsec - build-depends: - , base ^>= 4.11.1.0 - , bytestring ^>= 0.10.2.0 - , deepseq ^>= 1.4.0.0 - - hs-source-dirs: vendor/attoparsec-0.13.1.0 - - -- NB: haddock-library needs only small part of lib:attoparsec - -- internally, so we only bundle that subset here - exposed-modules: - Data.Attoparsec.ByteString - Data.Attoparsec.Combinator - - other-modules: - Data.Attoparsec.Internal - - ghc-options: -funbox-strict-fields -Wall -fwarn-tabs -O2 - - -Opening an interpreter session -^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - -While developing a package, it is often useful to make its code -available inside an interpreter session. This can be done with the -``repl`` command: - -.. code-block:: console - - $ cabal repl - -The name comes from the acronym -`REPL `__, -which stands for "read-eval-print-loop". By default ``cabal repl`` loads -the first component in a package. If the package contains several named -components, the name can be given as an argument to ``repl``. The name -can be also optionally prefixed with the component's type for -disambiguation purposes. Example: - -.. code-block:: console - - $ cabal repl foo - $ cabal repl exe:foo - $ cabal repl test:bar - $ cabal repl bench:baz - -Freezing dependency versions -"""""""""""""""""""""""""""" - -If a package is built in several different environments, such as a -development environment, a staging environment and a production -environment, it may be necessary or desirable to ensure that the same -dependency versions are selected in each environment. This can be done -with the ``freeze`` command: - -.. code-block:: console - - $ cabal freeze - -The command writes the selected version for all dependencies to the -``cabal.config`` file. All environments which share this file will use -the dependency versions specified in it. - -Generating dependency version bounds -"""""""""""""""""""""""""""""""""""" - -Cabal also has the ability to suggest dependency version bounds that -conform to `Package Versioning Policy`_, which is -a recommended versioning system for publicly released Cabal packages. -This is done by running the ``gen-bounds`` command: - -.. code-block:: console - - $ cabal gen-bounds - -For example, given the following dependencies specified in -:pkg-field:`build-depends`: - -:: - - build-depends: - foo == 0.5.2 - bar == 1.1 - -``gen-bounds`` will suggest changing them to the following: - -:: - - build-depends: - foo >= 0.5.2 && < 0.6 - bar >= 1.1 && < 1.2 - -Listing outdated dependency version bounds -"""""""""""""""""""""""""""""""""""""""""" - -Manually updating dependency version bounds in a ``.cabal`` file or a -freeze file can be tedious, especially when there's a lot of -dependencies. The ``cabal outdated`` command is designed to help with -that. It will print a list of packages for which there is a new -version on Hackage that is outside the version bound specified in the -``build-depends`` field. The ``outdated`` command can also be -configured to act on the freeze file (both old- and v2-style) and -ignore major (or all) version bumps on Hackage for a subset of -dependencies. - -The following flags are supported by the ``outdated`` command: - -``--freeze-file`` - Read dependency version bounds from the freeze file (``cabal.config``) - instead of the package description file (``$PACKAGENAME.cabal``). - ``--v1-freeze-file`` is an alias for this flag starting in Cabal 2.4. -``--v2-freeze-file`` - :since: 2.4 - - Read dependency version bounds from the v2-style freeze file - (by default, ``cabal.project.freeze``) instead of the package - description file. ``--new-freeze-file`` is an alias for this flag - that can be used with pre-2.4 ``cabal``. -``--project-file`` *PROJECTFILE* - :since: 2.4 - - Read dependendency version bounds from the v2-style freeze file - related to the named project file (i.e., ``$PROJECTFILE.freeze``) - instead of the package desctription file. If multiple ``--project-file`` - flags are provided, only the final one is considered. This flag - must only be passed in when ``--new-freeze-file`` is present. -``--simple-output`` - Print only the names of outdated dependencies, one per line. -``--exit-code`` - Exit with a non-zero exit code when there are outdated dependencies. -``-q, --quiet`` - Don't print any output. Implies ``-v0`` and ``--exit-code``. -``--ignore`` *PACKAGENAMES* - Don't warn about outdated dependency version bounds for the packages in this - list. -``--minor`` *[PACKAGENAMES]* - Ignore major version bumps for these packages. E.g. if there's a version 2.0 - of a package ``pkg`` on Hackage and the freeze file specifies the constraint - ``pkg == 1.9``, ``cabal outdated --freeze --minor=pkg`` will only consider - the ``pkg`` outdated when there's a version of ``pkg`` on Hackage satisfying - ``pkg > 1.9 && < 2.0``. ``--minor`` can also be used without arguments, in - that case major version bumps are ignored for all packages. - -Examples: - -.. code-block:: console - - $ cd /some/package - $ cabal outdated - Outdated dependencies: - haskell-src-exts <1.17 (latest: 1.19.1) - language-javascript <0.6 (latest: 0.6.0.9) - unix ==2.7.2.0 (latest: 2.7.2.1) - - $ cabal outdated --simple-output - haskell-src-exts - language-javascript - unix - - $ cabal outdated --ignore=haskell-src-exts - Outdated dependencies: - language-javascript <0.6 (latest: 0.6.0.9) - unix ==2.7.2.0 (latest: 2.7.2.1) - - $ cabal outdated --ignore=haskell-src-exts,language-javascript,unix - All dependencies are up to date. - - $ cabal outdated --ignore=haskell-src-exts,language-javascript,unix -q - $ echo $? - 0 - - $ cd /some/other/package - $ cabal outdated --freeze-file - Outdated dependencies: - HTTP ==4000.3.3 (latest: 4000.3.4) - HUnit ==1.3.1.1 (latest: 1.5.0.0) - - $ cabal outdated --freeze-file --ignore=HTTP --minor=HUnit - Outdated dependencies: - HUnit ==1.3.1.1 (latest: 1.3.1.2) - - -Executables -^^^^^^^^^^^ - -.. pkg-section:: executable name - :synopsis: Executable build info section. - - Executable sections (if present) describe executable programs contained - in the package and must have an argument after the section label, which - defines the name of the executable. This is a freeform argument but may - not contain spaces. - -The executable may be described using the following fields, as well as -build information fields (see the section on `build information`_). - -.. pkg-field:: main-is: filename (required) - - The name of the ``.hs`` or ``.lhs`` file containing the ``Main`` - module. Note that it is the ``.hs`` filename that must be listed, - even if that file is generated using a preprocessor. The source file - must be relative to one of the directories listed in - :pkg-field:`hs-source-dirs`. Further, while the name of the file may - vary, the module itself must be named ``Main``. - - Starting with ``cabal-version: 1.18`` this field supports - specifying a C, C++, or objC source file as the main entry point. - -.. pkg-field:: scope: token - :since: 2.0 - - Whether the executable is ``public`` (default) or ``private``, i.e. meant to - be run by other programs rather than the user. Private executables are - installed into `$libexecdir/$libexecsubdir`. - -Running executables -""""""""""""""""""" - -You can have Cabal build and run your executables by using the ``run`` -command: - -.. code-block:: console - - $ cabal run EXECUTABLE [-- EXECUTABLE_FLAGS] - -This command will configure, build and run the executable -``EXECUTABLE``. The double dash separator is required to distinguish -executable flags from ``run``'s own flags. If there is only one -executable defined in the whole package, the executable's name can be -omitted. See the output of ``cabal help run`` for a list of options you -can pass to ``cabal run``. - -Test suites -^^^^^^^^^^^ - -.. pkg-section:: test-suite name - :synopsis: Test suite build information. - - Test suite sections (if present) describe package test suites and must - have an argument after the section label, which defines the name of the - test suite. This is a freeform argument, but may not contain spaces. It - should be unique among the names of the package's other test suites, the - package's executables, and the package itself. Using test suite sections - requires at least Cabal version 1.9.2. - -The test suite may be described using the following fields, as well as -build information fields (see the section on `build information`_). - -.. pkg-field:: type: interface (required) - - The interface type and version of the test suite. Cabal supports two - test suite interfaces, called ``exitcode-stdio-1.0`` and - ``detailed-0.9``. Each of these types may require or disallow other - fields as described below. - -Test suites using the ``exitcode-stdio-1.0`` interface are executables -that indicate test failure with a non-zero exit code when run; they may -provide human-readable log information through the standard output and -error channels. The ``exitcode-stdio-1.0`` type requires the ``main-is`` -field. - -.. pkg-field:: main-is: filename - :synopsis: Module containing tests main function. - - :required: ``exitcode-stdio-1.0`` - :disallowed: ``detailed-0.9`` - - The name of the ``.hs`` or ``.lhs`` file containing the ``Main`` - module. Note that it is the ``.hs`` filename that must be listed, - even if that file is generated using a preprocessor. The source file - must be relative to one of the directories listed in - :pkg-field:`hs-source-dirs`. This field is analogous to the ``main-is`` field - of an executable section. - -Test suites using the ``detailed-0.9`` interface are modules exporting -the symbol ``tests :: IO [Test]``. The ``Test`` type is exported by the -module ``Distribution.TestSuite`` provided by Cabal. For more details, -see the example below. - -The ``detailed-0.9`` interface allows Cabal and other test agents to -inspect a test suite's results case by case, producing detailed human- -and machine-readable log files. The ``detailed-0.9`` interface requires -the :pkg-field:`test-module` field. - -.. pkg-field:: test-module: identifier - - :required: ``detailed-0.9`` - :disallowed: ``exitcode-stdio-1.0`` - - The module exporting the ``tests`` symbol. - -Example: Package using ``exitcode-stdio-1.0`` interface -""""""""""""""""""""""""""""""""""""""""""""""""""""""" - -The example package description and executable source file below -demonstrate the use of the ``exitcode-stdio-1.0`` interface. - -.. code-block:: cabal - :caption: foo.cabal - - Name: foo - Version: 1.0 - License: BSD3 - Cabal-Version: >= 1.9.2 - Build-Type: Simple - - Test-Suite test-foo - type: exitcode-stdio-1.0 - main-is: test-foo.hs - build-depends: base >= 4 && < 5 - -.. code-block:: haskell - :caption: test-foo.hs - - module Main where - - import System.Exit (exitFailure) - - main = do - putStrLn "This test always fails!" - exitFailure - -Example: Package using ``detailed-0.9`` interface -""""""""""""""""""""""""""""""""""""""""""""""""" - -The example package description and test module source file below -demonstrate the use of the ``detailed-0.9`` interface. The test module -also develops a simple implementation of the interface set by -``Distribution.TestSuite``, but in actual usage the implementation would -be provided by the library that provides the testing facility. - -.. code-block:: cabal - :caption: bar.cabal - - Name: bar - Version: 1.0 - License: BSD3 - Cabal-Version: >= 1.9.2 - Build-Type: Simple - - Test-Suite test-bar - type: detailed-0.9 - test-module: Bar - build-depends: base >= 4 && < 5, Cabal >= 1.9.2 && < 2 - - -.. code-block:: haskell - :caption: Bar.hs - - module Bar ( tests ) where - - import Distribution.TestSuite - - tests :: IO [Test] - tests = return [ Test succeeds, Test fails ] - where - succeeds = TestInstance - { run = return $ Finished Pass - , name = "succeeds" - , tags = [] - , options = [] - , setOption = \_ _ -> Right succeeds - } - fails = TestInstance - { run = return $ Finished $ Fail "Always fails!" - , name = "fails" - , tags = [] - , options = [] - , setOption = \_ _ -> Right fails - } - -Running test suites -""""""""""""""""""" - -You can have Cabal run your test suites using its built-in test runner: - -:: - - $ cabal configure --enable-tests - $ cabal build - $ cabal test - -See the output of ``cabal help test`` for a list of options you can pass -to ``cabal test``. - -Benchmarks -^^^^^^^^^^ - -.. pkg-section:: benchmark name - :since: 1.9.2 - :synopsis: Benchmark build information. - - Benchmark sections (if present) describe benchmarks contained in the - package and must have an argument after the section label, which defines - the name of the benchmark. This is a freeform argument, but may not - contain spaces. It should be unique among the names of the package's - other benchmarks, the package's test suites, the package's executables, - and the package itself. Using benchmark sections requires at least Cabal - version 1.9.2. - -The benchmark may be described using the following fields, as well as -build information fields (see the section on `build information`_). - -.. pkg-field:: type: interface (required) - - The interface type and version of the benchmark. At the moment Cabal - only support one benchmark interface, called ``exitcode-stdio-1.0``. - -Benchmarks using the ``exitcode-stdio-1.0`` interface are executables -that indicate failure to run the benchmark with a non-zero exit code -when run; they may provide human-readable information through the -standard output and error channels. - -.. pkg-field:: main-is: filename - - :required: ``exitcode-stdio-1.0`` - - The name of the ``.hs`` or ``.lhs`` file containing the ``Main`` - module. Note that it is the ``.hs`` filename that must be listed, - even if that file is generated using a preprocessor. The source file - must be relative to one of the directories listed in - :pkg-field:`hs-source-dirs`. This field is analogous to the ``main-is`` - field of an executable section. Further, while the name of the file may - vary, the module itself must be named ``Main``. - -Example: Package using ``exitcode-stdio-1.0`` interface -""""""""""""""""""""""""""""""""""""""""""""""""""""""" - -The example package description and executable source file below -demonstrate the use of the ``exitcode-stdio-1.0`` interface. - -.. code-block:: cabal - :caption: foo.cabal - :name: foo-bench.cabal - - Name: foo - Version: 1.0 - License: BSD3 - Cabal-Version: >= 1.9.2 - Build-Type: Simple - - Benchmark bench-foo - type: exitcode-stdio-1.0 - main-is: bench-foo.hs - build-depends: base >= 4 && < 5, time >= 1.1 && < 1.7 - -.. code-block:: haskell - :caption: bench-foo.hs - - {-# LANGUAGE BangPatterns #-} - module Main where - - import Data.Time.Clock - - fib 0 = 1 - fib 1 = 1 - fib n = fib (n-1) + fib (n-2) - - main = do - start <- getCurrentTime - let !r = fib 20 - end <- getCurrentTime - putStrLn $ "fib 20 took " ++ show (diffUTCTime end start) - -Running benchmarks -"""""""""""""""""" - -You can have Cabal run your benchmark using its built-in benchmark -runner: - -:: - - $ cabal configure --enable-benchmarks - $ cabal build - $ cabal bench - -See the output of ``cabal help bench`` for a list of options you can -pass to ``cabal bench``. - -Foreign libraries -^^^^^^^^^^^^^^^^^ - -Foreign libraries are system libraries intended to be linked against -programs written in C or other "foreign" languages. They -come in two primary flavours: dynamic libraries (``.so`` files on Linux, -``.dylib`` files on OSX, ``.dll`` files on Windows, etc.) are linked against -executables when the executable is run (or even lazily during -execution), while static libraries (``.a`` files on Linux/OSX, ``.lib`` -files on Windows) get linked against the executable at compile time. - -Foreign libraries only work with GHC 7.8 and later. - -A typical stanza for a foreign library looks like - -:: - - foreign-library myforeignlib - type: native-shared - lib-version-info: 6:3:2 - - if os(Windows) - options: standalone - mod-def-file: MyForeignLib.def - - other-modules: MyForeignLib.SomeModule - MyForeignLib.SomeOtherModule - build-depends: base >=4.7 && <4.9 - hs-source-dirs: src - c-sources: csrc/MyForeignLibWrapper.c - default-language: Haskell2010 - - -.. pkg-section:: foreign-library name - :since: 2.0 - :synopsis: Foreign library build information. - - Build information for `foreign libraries`_. - -.. pkg-field:: type: foreign library type - - Cabal recognizes ``native-static`` and ``native-shared`` here, although - we currently only support building `native-shared` libraries. - -.. pkg-field:: options: foreign library option list - - Options for building the foreign library, typically specific to the - specified type of foreign library. Currently we only support - ``standalone`` here. A standalone dynamic library is one that does not - have any dependencies on other (Haskell) shared libraries; without - the ``standalone`` option the generated library would have dependencies - on the Haskell runtime library (``libHSrts``), the base library - (``libHSbase``), etc. Currently, ``standalone`` *must* be used on Windows - and *must not* be used on any other platform. - -.. pkg-field:: mod-def-file: filename - - This option can only be used when creating dynamic Windows libraries - (that is, when using ``native-shared`` and the ``os`` is ``Windows``). If - used, it must be a path to a *module definition file*. The details of - module definition files are beyond the scope of this document; see the - `GHC `_ - manual for some details and some further pointers. - -.. pkg-field:: lib-version-info: current:revision:age - - This field is currently only used on Linux. - - This field specifies a Libtool-style version-info field that sets - an appropriate ABI version for the foreign library. Note that the - three numbers specified in this field do not directly specify the - actual ABI version: ``6:3:2`` results in library version ``4.2.3``. - - With this field set, the SONAME of the library is set, and symlinks - are installed. - - How you should bump this field on an ABI change depends on the - breakage you introduce: - - - Programs using the previous version may use the new version as - drop-in replacement, and programs using the new version can also - work with the previous one. In other words, no recompiling nor - relinking is needed. In this case, bump ``revision`` only, don't - touch current nor age. - - Programs using the previous version may use the new version as - drop-in replacement, but programs using the new version may use - APIs not present in the previous one. In other words, a program - linking against the new version may fail with "unresolved - symbols" if linking against the old version at runtime: set - revision to 0, bump current and age. - - Programs may need to be changed, recompiled, and relinked in - order to use the new version. Bump current, set revision and age - to 0. - - Also refer to the Libtool documentation on the version-info field. - -.. pkg-field:: lib-version-linux: version - - This field is only used on Linux. - - Specifies the library ABI version directly for foreign libraries - built on Linux: so specifying ``4.2.3`` causes a library - ``libfoo.so.4.2.3`` to be built with SONAME ``libfoo.so.4``, and - appropriate symlinks ``libfoo.so.4`` and ``libfoo.so`` to be - installed. - -Note that typically foreign libraries should export a way to initialize -and shutdown the Haskell runtime. In the example above, this is done by -the ``csrc/MyForeignLibWrapper.c`` file, which might look something like - -.. code-block:: c - - #include - #include "HsFFI.h" - - HsBool myForeignLibInit(void){ - int argc = 2; - char *argv[] = { "+RTS", "-A32m", NULL }; - char **pargv = argv; - - // Initialize Haskell runtime - hs_init(&argc, &pargv); - - // do any other initialization here and - // return false if there was a problem - return HS_BOOL_TRUE; - } - - void myForeignLibExit(void){ - hs_exit(); - } - -With modern ghc regular libraries are installed in directories that contain -package keys. This isn't usually a problem because the package gets registered -in ghc's package DB and so we can figure out what the location of the library -is. Foreign libraries however don't get registered, which means that we'd have -to have a way of finding out where a platform library got installed (other than by -searching the ``lib/`` directory). Instead, we install foreign libraries in -``~/.cabal/lib``, much like we install executables in ``~/.cabal/bin``. - -Build information -^^^^^^^^^^^^^^^^^ -.. pkg-section:: None - -The following fields may be optionally present in a library, executable, -test suite or benchmark section, and give information for the building -of the corresponding library or executable. See also the sections on -`system-dependent parameters`_ and `configurations`_ for a way to supply -system-dependent values for these fields. - -.. pkg-field:: build-depends: library list - - Declares the *library* dependencies required to build the current - package component; see :pkg-field:`build-tool-depends` for - declaring build-time *tool* dependencies. External library - dependencies should be annotated with a version constraint. - - **Library Names** - - External libraries are identified by the package's name they're - provided by (currently a package can only publicly expose its - main library component; in future, packages with multiple exposed - public library components will be supported and a syntax for - referring to public sub-libraries will be provided). - - In order to specify an intra-package dependency on an internal - library component you can use the unqualified name of the - library component. Note that locally defined sub-library - names shadow external package names of the same name. See section on - :ref:`Internal Libraries ` for examples and more information. - - **Version Constraints** - - Version constraints use the operators ``==, >=, >, <, <=`` and a - version number. Multiple constraints can be combined using ``&&`` or - ``||``. If no version constraint is specified, any version is - assumed to be acceptable. For example: - - :: - - library - build-depends: - base >= 2, - foo >= 1.2.3 && < 1.3, - bar - - Dependencies like ``foo >= 1.2.3 && < 1.3`` turn out to be very - common because it is recommended practice for package versions to - correspond to API versions (see PVP_). - - Since Cabal 1.6, there is a special wildcard syntax to help with - such ranges - - :: - - build-depends: foo ==1.2.* - - It is only syntactic sugar. It is exactly equivalent to - ``foo >= 1.2 && < 1.3``. - - .. Warning:: - - A potential pitfall of the wildcard syntax is that the - constraint ``nats == 1.0.*`` doesn't match the release - ``nats-1`` because the version ``1`` is lexicographically less - than ``1.0``. This is not an issue with the caret-operator - ``^>=`` described below. - - Starting with Cabal 2.0, there's a new version operator to express - PVP_-style major upper bounds conveniently, and is inspired by similar - syntactic sugar found in other language ecosystems where it's often - called the "Caret" operator: - - :: - - build-depends: - foo ^>= 1.2.3.4, - bar ^>= 1 - - This allows to assert the positive knowledge that this package is - *known* to be semantically compatible with the releases - ``foo-1.2.3.4`` and ``bar-1`` respectively. The information - encoded via such ``^>=``-assertions is used by the cabal solver to - infer version constraints describing semantically compatible - version ranges according to the PVP_ contract (see below). - - Another way to say this is that ``foo < 1.3`` expresses *negative* - information, i.e. "``foo-1.3`` or ``foo-1.4.2`` will *not* be - compatible"; whereas ``foo ^>= 1.2.3.4`` asserts the *positive* - information that "``foo-1.2.3.4`` is *known* to be compatible" and (in - the absence of additional information) according to the PVP_ - contract we can (positively) infer right away that all versions - satisfying ``foo >= 1.2.3.4 && < 1.3`` will be compatible as well. - - .. Note:: - - More generally, the PVP_ contract implies that we can safely - relax the lower bound to ``>= 1.2``, because if we know that - ``foo-1.2.3.4`` is semantically compatible, then so is - ``foo-1.2`` (if it typechecks). But we'd need to perform - additional static analysis (i.e. perform typechecking) in order - to know if our package in the role of an API consumer will - successfully typecheck against the dependency ``foo-1.2``. But - since we cannot do this analysis during constraint solving and - to keep things simple, we pragmatically use ``foo >= 1.2.3.4`` - as the initially inferred approximation for the lower bound - resulting from the assertion ``foo ^>= 1.2.3.4``. If further - evidence becomes available that e.g. ``foo-1.2`` typechecks, - one can simply revise the dependency specification to include - the assertion ``foo ^>= 1.2``. - - The subtle but important difference in signaling allows tooling to - treat explicitly expressed ``<``-style constraints and inferred - (``^>=``-style) upper bounds differently. For instance, - :cfg-field:`allow-newer`'s ``^``-modifier allows to relax only - ``^>=``-style bounds while leaving explicitly stated - ``<``-constraints unaffected. - - Ignoring the signaling intent, the default syntactic desugaring rules are - - - ``^>= x`` == ``>= x && < x.1`` - - ``^>= x.y`` == ``>= x.y && < x.(y+1)`` - - ``^>= x.y.z`` == ``>= x.y.z && < x.(y+1)`` - - ``^>= x.y.z.u`` == ``>= x.y.z.u && < x.(y+1)`` - - etc. - - .. Note:: - - One might expect the desugaring to truncate all version - components below (and including) the patch-level, i.e. - ``^>= x.y.z.u`` == ``>= x.y.z && < x.(y+1)``, - as the major and minor version components alone are supposed to - uniquely identify the API according to the PVP_. However, by - designing ``^>=`` to be closer to the ``>=`` operator, we avoid - the potentially confusing effect of ``^>=`` being more liberal - than ``>=`` in the presence of patch-level versions. - - Consequently, the example declaration above is equivalent to - - :: - - build-depends: - foo >= 1.2.3.4 && < 1.3, - bar >= 1 && < 1.1 - - .. Note:: - - Prior to Cabal 1.8, ``build-depends`` specified in each - section were global to all sections. This was unintentional, but - some packages were written to depend on it, so if you need your - :pkg-field:`build-depends` to be local to each section, you must specify - at least ``Cabal-Version: >= 1.8`` in your ``.cabal`` file. - - .. Note:: - - Cabal 1.20 experimentally supported module thinning and - renaming in ``build-depends``; however, this support has since been - removed and should not be used. - - Starting with Cabal 3.0, a set notation for the ``==`` and ``^>=`` operator - is available. For instance, - - :: - - tested-with: GHC == 8.6.3, GHC == 8.4.4, GHC == 8.2.2, GHC == 8.0.2, - GHC == 7.10.3, GHC == 7.8.4, GHC == 7.6.3, GHC == 7.4.2 - - build-depends: network ^>= 2.6.3.6 || ^>= 2.7.0.2 || ^>= 2.8.0.0 || ^>= 3.0.1.0 - - can be then written in a more convenient and concise form - - :: - - tested-with: GHC == { 8.6.3, 8.4.4, 8.2.2, 8.0.2, 7.10.3, 7.8.4, 7.6.3, 7.4.2 } - - build-depends: network ^>= { 2.6.3.6, 2.7.0.2, 2.8.0.0, 3.0.1.0 } - - -.. pkg-field:: other-modules: identifier list - - A list of modules used by the component but not exposed to users. - For a library component, these would be hidden modules of the - library. For an executable, these would be auxiliary modules to be - linked with the file named in the ``main-is`` field. - - .. Note:: - - Every module in the package *must* be listed in one of - :pkg-field:`other-modules`, :pkg-field:`library:exposed-modules` or - :pkg-field:`executable:main-is` fields. - -.. pkg-field:: hs-source-dir: directory list - :deprecated: 2.0 - :removed: 3.0 - - :default: ``.`` - - Root directories for the module hierarchy. - - Deprecated in favor of :pkg-field:`hs-source-dirs`. - -.. pkg-field:: hs-source-dirs: directory list - - :default: ``.`` - - Root directories for the module hierarchy. - - .. note:: - - Components can share source directories but modules found there will be - recompiled even if other components already built them, i.e., if a - library and an executable share a source directory and the executable - depends on the library and imports its ``Foo`` module, ``Foo`` will be - compiled twice, once as part of the library and again for the executable. - -.. pkg-field:: default-extensions: identifier list - :since: 1.12 - - A list of Haskell extensions used by every module. These determine - corresponding compiler options enabled for all files. Extension - names are the constructors of the - `Extension <../release/cabal-latest/doc/API/Cabal/Language-Haskell-Extension.html#t:Extension>`__ - type. For example, ``CPP`` specifies that Haskell source files are - to be preprocessed with a C preprocessor. - -.. pkg-field:: other-extensions: identifier list - :since: 1.12 - - A list of Haskell extensions used by some (but not necessarily all) - modules. From GHC version 6.6 onward, these may be specified by - placing a ``LANGUAGE`` pragma in the source files affected e.g. - - .. code-block:: haskell - - {-# LANGUAGE CPP, MultiParamTypeClasses #-} - - In Cabal-1.24 the dependency solver will use this and - :pkg-field:`default-extensions` information. Cabal prior to 1.24 will abort - compilation if the current compiler doesn't provide the extensions. - - If you use some extensions conditionally, using CPP or conditional - module lists, it is good to replicate the condition in - :pkg-field:`other-extensions` declarations: - - :: - - other-extensions: CPP - if impl(ghc >= 7.5) - other-extensions: PolyKinds - - You could also omit the conditionally used extensions, as they are - for information only, but it is recommended to replicate them in - :pkg-field:`other-extensions` declarations. - -.. pkg-field:: default-language: identifier - :since: 1.12 - - TBW - -.. pkg-field:: other-languages: identifier - :since: 1.12 - - TBW - -.. pkg-field:: extensions: identifier list - :deprecated: 1.12 - :removed: 3.0 - - Deprecated in favor of :pkg-field:`default-extensions`. - -.. pkg-field:: build-tool-depends: package:executable list - :since: 2.0 - - A list of Haskell executables needed to build this component. Executables are provided - during the whole duration of the component, so this field can be used for executables - needed during :pkg-section:`test-suite` as well. - - Each is specified by the package containing the executable and the name of the - executable itself, separated by a colon, and optionally followed by a version bound. - - All executables defined in the given Cabal file are termed as *internal* dependencies - as opposed to the rest which are *external* dependencies. - - Each of the two is handled differently: - - 1. External dependencies can (and should) contain a version bound like conventional - :pkg-field:`build-depends` dependencies. - 2. Internal dependencies should not contain a version bound, as they will be always - resolved within the same configuration of the package in the build plan. - Specifically, version bounds that include the package's version will be warned for - being extraneous, and version bounds that exclude the package's version will raise - an error for being impossible to follow. - - For example (1) using a test-suite to make sure README.md Haskell snippets are tested using - `markdown-unlit `__: - - :: - - build-tool-depends: markdown-unlit:markdown-unlit >= 0.5.0 && < 0.6 - - For example (2) using a test-suite to test executable behaviour in the same package: - - :: - - build-tool-depends: mypackage:executable - - Cabal tries to make sure that all specified programs are atomically built and prepended - on the ``$PATH`` shell variable before building the component in question, but can only do - so for Nix-style builds. Specifically: - - a) For Nix-style local builds, both internal and external dependencies. - b) For old-style builds, only for internal dependencies [#old-style-build-tool-depends]_. - It's up to the user to provide needed executables in this case under `$PATH.` - - - .. note:: - - :pkg-field:`build-tool-depends` was added in Cabal 2.0, and it will - be ignored (with a warning) with old versions of Cabal. See - :pkg-field:`build-tools` for more information about backwards - compatibility. - -.. pkg-field:: build-tools: program list - :deprecated: 2.0 - :removed: 3.0 - - Deprecated in favor of :pkg-field:`build-tool-depends`, but :ref:`see below for backwards compatibility information `. - - A list of Haskell programs needed to build this component. - Each may be followed by an optional version bound. - Confusingly, each program in the list either refer to one of three things: - - 1. Another executables in the same package (supported since Cabal 1.12) - - 2. Tool name contained in Cabal's :ref:`hard-coded set of common tools ` - - 3. A pre-built executable that should already be on the ``PATH`` - (supported since Cabal 2.0) - - These cases are listed in order of priority: - an executable in the package will override any of the hard-coded packages with the same name, - and a hard-coded package will override any executable on the ``PATH``. - - In the first two cases, the list entry is desugared into a :pkg-field:`build-tool-depends` entry. - In the first case, the entry is desugared into a :pkg-field:`build-tool-depends` entry by prefixing with ``$pkg:``. - In the second case, it is desugared by looking up the package and executable name in a hard-coded table. - In either case, the optional version bound is passed through unchanged. - Refer to the documentation for :pkg-field:`build-tool-depends` to understand the desugared field's meaning, along with restrictions on version bounds. - - .. _buildtoolsbc: - - **Backward Compatibility** - - Although this field is deprecated in favor of :pkg-field:`build-tool-depends`, there are some situations where you may prefer to use :pkg-field:`build-tools` in cases (1) and (2), as it is supported by more versions of Cabal. - In case (3), :pkg-field:`build-tool-depends` is better for backwards-compatibility, as it will be ignored by old versions of Cabal; if you add the executable to :pkg-field:`build-tools`, a setup script built against old Cabal will choke. - If an old version of Cabal is used, an end-user will have to manually arrange for the requested executable to be in your ``PATH``. - - .. _buildtoolsmap: - - **Set of Known Tool Names** - - Identifiers specified in :pkg-field:`build-tools` are desugared into their respective equivalent :pkg-field:`build-tool-depends` form according to the table below. Consequently, a legacy specification such as:: - - build-tools: alex >= 3.2.1 && < 3.3, happy >= 1.19.5 && < 1.20 - - is simply desugared into the equivalent specification:: - - build-tool-depends: alex:alex >= 3.2.1 && < 3.3, happy:happy >= 1.19.5 && < 1.20 - - +--------------------------+-----------------------------------+-----------------+ - | :pkg-field:`build-tools` | desugared | Note | - | identifier | :pkg-field:`build-tool-depends` | | - | | identifier | | - +==========================+===================================+=================+ - | ``alex`` | ``alex:alex`` | | - +--------------------------+-----------------------------------+-----------------+ - | ``c2hs`` | ``c2hs:c2hs`` | | - +--------------------------+-----------------------------------+-----------------+ - | ``cpphs`` | ``cpphs:cpphs`` | | - +--------------------------+-----------------------------------+-----------------+ - | ``greencard`` | ``greencard:greencard`` | | - +--------------------------+-----------------------------------+-----------------+ - | ``haddock`` | ``haddock:haddock`` | | - +--------------------------+-----------------------------------+-----------------+ - | ``happy`` | ``happy:happy`` | | - +--------------------------+-----------------------------------+-----------------+ - | ``hsc2hs`` | ``hsc2hs:hsc2hs`` | | - +--------------------------+-----------------------------------+-----------------+ - | ``hscolour`` | ``hscolour:hscolour`` | | - +--------------------------+-----------------------------------+-----------------+ - | ``hspec-discover`` | ``hspec-discover:hspec-discover`` | since Cabal 2.0 | - +--------------------------+-----------------------------------+-----------------+ - - This built-in set can be programmatically extended via ``Custom`` setup scripts; this, however, is of limited use since the Cabal solver cannot access information injected by ``Custom`` setup scripts. - -.. pkg-field:: buildable: boolean - - :default: ``True`` - - Is the component buildable? Like some of the other fields below, - this field is more useful with the slightly more elaborate form of - the simple build infrastructure described in the section on - `system-dependent parameters`_. - -.. pkg-field:: ghc-options: token list - - Additional options for GHC. You can often achieve the same effect - using the :pkg-field:`default-extensions` field, which is preferred. - - Options required only by one module may be specified by placing an - ``OPTIONS_GHC`` pragma in the source file affected. - - As with many other fields, whitespace can be escaped by using - Haskell string syntax. Example: - ``ghc-options: -Wcompat "-with-rtsopts=-T -I1" -Wall``. - -.. pkg-field:: ghc-prof-options: token list - - Additional options for GHC when the package is built with profiling - enabled. - - Note that as of Cabal-1.24, the default profiling detail level - defaults to ``exported-functions`` for libraries and - ``toplevel-functions`` for executables. For GHC these correspond to - the flags ``-fprof-auto-exported`` and ``-fprof-auto-top``. Prior to - Cabal-1.24 the level defaulted to ``none``. These levels can be - adjusted by the person building the package with the - ``--profiling-detail`` and ``--library-profiling-detail`` flags. - - It is typically better for the person building the package to pick - the profiling detail level rather than for the package author. So - unless you have special needs it is probably better not to specify - any of the GHC ``-fprof-auto*`` flags here. However if you wish to - override the profiling detail level, you can do so using the - :pkg-field:`ghc-prof-options` field: use ``-fno-prof-auto`` or one of the - other ``-fprof-auto*`` flags. - -.. pkg-field:: ghc-shared-options: token list - - Additional options for GHC when the package is built as shared - library. The options specified via this field are combined with the - ones specified via :pkg-field:`ghc-options`, and are passed to GHC during - both the compile and link phases. - -.. pkg-field:: ghcjs-options: token list - - Like :pkg-field:`ghc-options` but applies to GHCJS - -.. pkg-field:: ghcjs-prof-options: token list - - Like :pkg-field:`ghc-prof-options` but applies to GHCJS - -.. pkg-field:: ghcjs-shared-options: token list - - Like :pkg-field:`ghc-shared-options` but applies to GHCJS - -.. pkg-field:: includes: filename list - - A list of header files to be included in any compilations via C. - This field applies to both header files that are already installed - on the system and to those coming with the package to be installed. - The former files should be found in absolute paths, while the latter - files should be found in paths relative to the top of the source - tree or relative to one of the directories listed in - :pkg-field:`include-dirs`. - - These files typically contain function prototypes for foreign - imports used by the package. This is in contrast to - :pkg-field:`install-includes`, which lists header files that are intended - to be exposed to other packages that transitively depend on this - library. - -.. pkg-field:: install-includes: filename list - - A list of header files from this package to be installed into - ``$libdir/includes`` when the package is installed. Files listed in - :pkg-field:`install-includes` should be found in relative to the top of the - source tree or relative to one of the directories listed in - :pkg-field:`include-dirs`. - - :pkg-field:`install-includes` is typically used to name header files that - contain prototypes for foreign imports used in Haskell code in this - package, for which the C implementations are also provided with the - package. For example, here is a ``.cabal`` file for a hypothetical - ``bindings-clib`` package that bundles the C source code for ``clib``:: - - include-dirs: cbits - c-sources: clib.c - install-includes: clib.h - - Now any package that depends (directly or transitively) on the - ``bindings-clib`` library can use ``clib.h``. - - Note that in order for files listed in :pkg-field:`install-includes` to be - usable when compiling the package itself, they need to be listed in - the :pkg-field:`includes` field as well. - -.. pkg-field:: include-dirs: directory list - - A list of directories to search for header files, when preprocessing - with ``c2hs``, ``hsc2hs``, ``cpphs`` or the C preprocessor, and also - when compiling via C. Directories can be absolute paths (e.g., for - system directories) or paths that are relative to the top of the - source tree. Cabal looks in these directories when attempting to - locate files listed in :pkg-field:`includes` and - :pkg-field:`install-includes`. - -.. pkg-field:: c-sources: filename list - - A list of C source files to be compiled and linked with the Haskell - files. - -.. pkg-field:: cxx-sources: filename list - :since: 2.2 - - A list of C++ source files to be compiled and linked with the Haskell - files. Useful for segregating C and C++ sources when supplying different - command-line arguments to the compiler via the :pkg-field:`cc-options` - and the :pkg-field:`cxx-options` fields. The files listed in the - :pkg-field:`cxx-sources` can reference files listed in the - :pkg-field:`c-sources` field and vice-versa. The object files will be linked - appropriately. - -.. pkg-field:: asm-sources: filename list - :since: 3.0 - - A list of assembly source files to be compiled and linked with the - Haskell files. - -.. pkg-field:: cmm-sources: filename list - :since: 3.0 - - A list of C-- source files to be compiled and linked with the Haskell - files. - -.. pkg-field:: js-sources: filename list - - A list of JavaScript source files to be linked with the Haskell - files (only for JavaScript targets). - -.. pkg-field:: extra-libraries: token list - - A list of extra libraries to link with. - -.. pkg-field:: extra-ghci-libraries: token list - - A list of extra libraries to be used instead of 'extra-libraries' - when the package is loaded with GHCi. - -.. pkg-field:: extra-bundled-libraries: token list - :since: 2.2 - - A list of libraries that are supposed to be copied from the build - directory alongside the produced Haskell libraries. Note that you - are under the obligation to produce those libraries in the build - directory (e.g. via a custom setup). Libraries listed here will - be included when ``copy``-ing packages and be listed in the - ``hs-libraries`` of the package configuration in the package database. - Library names must either be prefixed with "HS" or "C" and corresponding - library file names must match: - - - Libraries with name "HS": - - `libHS.a` - - `libHS-ghc.*` - - Libraries with name "C": - - `libC.a` - - `lib.*` - -.. pkg-field:: extra-lib-dirs: directory list - - A list of directories to search for libraries. - -.. pkg-field:: extra-library-flavours: notsure - - TBW - -.. pkg-field:: extra-dynamic-library-flavours: notsure - - TBW - -.. pkg-field:: cc-options: token list - - Command-line arguments to be passed to the C compiler. Since the - arguments are compiler-dependent, this field is more useful with the - setup described in the section on `system-dependent parameters`_. - -.. pkg-field:: cpp-options: token list - - Command-line arguments for pre-processing Haskell code. Applies to - Haskell source and other pre-processed Haskell source like .hsc - .chs. Does not apply to C code, that's what cc-options is for. - -.. pkg-field:: cxx-options: token list - :since: 2.2 - - Command-line arguments to be passed to the compiler when compiling - C++ code. The C++ sources to which these command-line arguments - should be applied can be specified with the :pkg-field:`cxx-sources` - field. Command-line options for C and C++ can be passed separately to - the compiler when compiling both C and C++ sources by segregating the C - and C++ sources with the :pkg-field:`c-sources` and - :pkg-field:`cxx-sources` fields respectively, and providing different - command-line arguments with the :pkg-field:`cc-options` and the - :pkg-field:`cxx-options` fields. - -.. pkg-field:: cmm-options: token list - :since: 3.0 - - Command-line arguments to be passed to the compiler when compiling - C-- code. See also :pkg-field:`cmm-sources`. - -.. pkg-field:: asm-options: token list - :since: 3.0 - - Command-line arguments to be passed to the assembler when compiling - assembler code. See also :pkg-field:`asm-sources`. - -.. pkg-field:: ld-options: token list - - Command-line arguments to be passed to the linker. Since the - arguments are compiler-dependent, this field is more useful with the - setup described in the section on `system-dependent parameters`_. - -.. pkg-field:: pkgconfig-depends: package list - - A list of - `pkg-config `__ - packages, needed to build this package. They can be annotated with - versions, e.g. ``gtk+-2.0 >= 2.10, cairo >= 1.0``. If no version - constraint is specified, any version is assumed to be acceptable. - Cabal uses ``pkg-config`` to find if the packages are available on - the system and to find the extra compilation and linker options - needed to use the packages. - - If you need to bind to a C library that supports ``pkg-config`` then - it is much preferable to use this field rather than hard code options - into the other fields. ``pkg-config --list-all`` will show you all - supported libraries. Depending on your system you may need to adjust - ``PKG_CONFIG_PATH``. - -.. pkg-field:: frameworks: token list - - On Darwin/MacOS X, a list of frameworks to link to. See Apple's - developer documentation for more details on frameworks. This entry - is ignored on all other platforms. - -.. pkg-field:: extra-framework-dirs: directory list - :since: 1.24 - - On Darwin/MacOS X, a list of directories to search for frameworks. - This entry is ignored on all other platforms. - -.. pkg-field:: mixins: mixin list - :since: 2.0 - - Supported only in GHC 8.2 and later. A list of packages mentioned in the - :pkg-field:`build-depends` field, each optionally accompanied by a list of - module and module signature renamings. - - The simplest mixin syntax is simply the name of a package mentioned in the - :pkg-field:`build-depends` field. For example: - - :: - - library - build-depends: - foo ^>= 1.2.3 - mixins: - foo - - But this doesn't have any effect. More interesting is to use the mixin - entry to rename one or more modules from the package, like this: - - :: - - library - mixins: - foo (Foo.Bar as AnotherFoo.Bar, Foo.Baz as AnotherFoo.Baz) - - Note that renaming a module like this will hide all the modules - that are not explicitly named. - - Modules can also be hidden: - - :: - - library: - mixins: - foo hiding (Foo.Bar) - - Hiding modules exposes everything that is not explicitly hidden. - - .. Note:: - - The current version of Cabal suffers from an infelicity in how the - entries of :pkg-field:`mixins` are parsed: an entry will fail to parse - if the provided renaming clause has whitespace after the opening - parenthesis. This will be fixed in future versions of Cabal. - - See issues :issue:`5150`, :issue:`4864`, and :issue:`5293`. - - There can be multiple mixin entries for a given package, in effect creating - multiple copies of the dependency: - - :: - - library - mixins: - foo (Foo.Bar as AnotherFoo.Bar, Foo.Baz as AnotherFoo.Baz), - foo (Foo.Bar as YetAnotherFoo.Bar) - - The ``requires`` clause is used to rename the module signatures required by - a package: - - :: - - library - mixins: - foo (Foo.Bar as AnotherFoo.Bar) requires (Foo.SomeSig as AnotherFoo.SomeSig) - - Signature-only packages don't have any modules, so only the signatures can - be renamed, with the following syntax: - - :: - - library - mixins: - sigonly requires (SigOnly.SomeSig as AnotherSigOnly.SomeSig) - - See the :pkg-field:`library:signatures` field for more details. - - Mixin packages are part of the Backpack_ extension to the - Haskell module system. - - The matching of the module signatures required by a - :pkg-field:`build-depends` dependency with the implementation modules - present in another dependency is triggered by a coincidence of names. When - the names of the signature and of the implementation are already the same, - the matching is automatic. But when the names don't coincide, or we want to - instantiate a signature in two different ways, adding mixin entries that - perform renamings becomes necessary. - - .. Warning:: - - Backpack_ has the limitation that implementation modules that instantiate - signatures required by a :pkg-field:`build-depends` dependency can't - reside in the same component that has the dependency. They must reside - in a different package dependency, or at least in a separate internal - library. - -Configurations -^^^^^^^^^^^^^^ - -Library and executable sections may include conditional blocks, which -test for various system parameters and configuration flags. The flags -mechanism is rather generic, but most of the time a flag represents -certain feature, that can be switched on or off by the package user. -Here is an example package description file using configurations: - -Example: A package containing a library and executable programs -""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""" - -:: - - Name: Test1 - Version: 0.0.1 - Cabal-Version: >= 1.8 - License: BSD3 - Author: Jane Doe - Synopsis: Test package to test configurations - Category: Example - Build-Type: Simple - - Flag Debug - Description: Enable debug support - Default: False - Manual: True - - Flag WebFrontend - Description: Include API for web frontend. - Default: False - Manual: True - - Flag NewDirectory - description: Whether to build against @directory >= 1.2@ - -- This is an automatic flag which the solver will - -- assign automatically while searching for a solution - - Library - Build-Depends: base >= 4.2 && < 4.9 - Exposed-Modules: Testing.Test1 - Extensions: CPP - - GHC-Options: -Wall - if flag(Debug) - CPP-Options: -DDEBUG - if !os(windows) - CC-Options: "-DDEBUG" - else - CC-Options: "-DNDEBUG" - - if flag(WebFrontend) - Build-Depends: cgi >= 0.42 && < 0.44 - Other-Modules: Testing.WebStuff - CPP-Options: -DWEBFRONTEND - - if flag(NewDirectory) - build-depends: directory >= 1.2 && < 1.4 - Build-Depends: time >= 1.0 && < 1.9 - else - build-depends: directory == 1.1.* - Build-Depends: old-time >= 1.0 && < 1.2 - - Executable test1 - Main-is: T1.hs - Other-Modules: Testing.Test1 - Build-Depends: base >= 4.2 && < 4.9 - - if flag(debug) - CC-Options: "-DDEBUG" - CPP-Options: -DDEBUG - -Layout -"""""" - -Flags, conditionals, library and executable sections use layout to -indicate structure. This is very similar to the Haskell layout rule. -Entries in a section have to all be indented to the same level which -must be more than the section header. Tabs are not allowed to be used -for indentation. - -As an alternative to using layout you can also use explicit braces -``{}``. In this case the indentation of entries in a section does not -matter, though different fields within a block must be on different -lines. Here is a bit of the above example again, using braces: - -Example: Using explicit braces rather than indentation for layout -""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""" - -:: - - Name: Test1 - Version: 0.0.1 - Cabal-Version: >= 1.8 - License: BSD3 - Author: Jane Doe - Synopsis: Test package to test configurations - Category: Example - Build-Type: Simple - - Flag Debug { - Description: Enable debug support - Default: False - Manual: True - } - - Library { - Build-Depends: base >= 4.2 && < 4.9 - Exposed-Modules: Testing.Test1 - Extensions: CPP - if flag(debug) { - CPP-Options: -DDEBUG - if !os(windows) { - CC-Options: "-DDEBUG" - } else { - CC-Options: "-DNDEBUG" - } - } - } - -Configuration Flags -""""""""""""""""""" - -.. pkg-section:: flag name - :synopsis: Flag declaration. - - Flag section declares a flag which can be used in `conditional blocks`_. - - Flag names are case-insensitive and must match ``[[:alnum:]_][[:alnum:]_-]*`` - regular expression, or expressed as ABNF_: - - .. code-block:: abnf - - flag-name = (UALNUM / "_") *(UALNUM / "_" / "-") - - UALNUM = UALPHA / DIGIT - UALPHA = ... ; set of alphabetic Unicode code-points - - .. note:: - - Hackage accepts ASCII-only flags, ``[a-zA-Z0-9_][a-zA-Z0-9_-]*`` regexp. - -.. pkg-field:: description: freeform - - The description of this flag. - -.. pkg-field:: default: boolean - - :default: ``True`` - - The default value of this flag. - - .. note:: - - This value may be `overridden in several - ways `__. The - rationale for having flags default to True is that users usually - want new features as soon as they are available. Flags representing - features that are not (yet) recommended for most users (such as - experimental features or debugging support) should therefore - explicitly override the default to False. - -.. pkg-field:: manual: boolean - - :default: ``False`` - :since: 1.6 - - By default, Cabal will first try to satisfy dependencies with the - default flag value and then, if that is not possible, with the - negated value. However, if the flag is manual, then the default - value (which can be overridden by commandline flags) will be used. - -Conditional Blocks -^^^^^^^^^^^^^^^^^^ - -Conditional blocks may appear anywhere inside a library or executable -section. They have to follow rather strict formatting rules. Conditional -blocks must always be of the shape - -:: - - if condition - property-descriptions-or-conditionals - -or - -:: - - if condition - property-descriptions-or-conditionals - else - property-descriptions-or-conditionals - -Note that the ``if`` and the condition have to be all on the same line. - -Since Cabal 2.2 conditional blocks support ``elif`` construct. - -:: - - if condition1 - property-descriptions-or-conditionals - elif condition2 - property-descriptions-or-conditionals - else - property-descriptions-or-conditionals - -Conditions -"""""""""" - -Conditions can be formed using boolean tests and the boolean operators -``||`` (disjunction / logical "or"), ``&&`` (conjunction / logical -"and"), or ``!`` (negation / logical "not"). The unary ``!`` takes -highest precedence, ``||`` takes lowest. Precedence levels may be -overridden through the use of parentheses. For example, -``os(darwin) && !arch(i386) || os(freebsd)`` is equivalent to -``(os(darwin) && !(arch(i386))) || os(freebsd)``. - -The following tests are currently supported. - -:samp:`os({name})` - Tests if the current operating system is *name*. The argument is - tested against ``System.Info.os`` on the target system. There is - unfortunately some disagreement between Haskell implementations - about the standard values of ``System.Info.os``. Cabal canonicalises - it so that in particular ``os(windows)`` works on all - implementations. If the canonicalised os names match, this test - evaluates to true, otherwise false. The match is case-insensitive. -:samp:`arch({name})` - Tests if the current architecture is *name*. The argument is matched - against ``System.Info.arch`` on the target system. If the arch names - match, this test evaluates to true, otherwise false. The match is - case-insensitive. -:samp:`impl({compiler})` - Tests for the configured Haskell implementation. An optional version - constraint may be specified (for example ``impl(ghc >= 6.6.1)``). If - the configured implementation is of the right type and matches the - version constraint, then this evaluates to true, otherwise false. - The match is case-insensitive. - - Note that including a version constraint in an ``impl`` test causes - it to check for two properties: - - - The current compiler has the specified name, and - - - The compiler's version satisfied the specified version constraint - - As a result, ``!impl(ghc >= x.y.z)`` is not entirely equivalent to - ``impl(ghc < x.y.z)``. The test ``!impl(ghc >= x.y.z)`` checks that: - - - The current compiler is not GHC, or - - - The version of GHC is earlier than version x.y.z. - -:samp:`flag({name})` - Evaluates to the current assignment of the flag of the given name. - Flag names are case insensitive. Testing for flags that have not - been introduced with a flag section is an error. -``true`` - Constant value true. -``false`` - Constant value false. - -Resolution of Conditions and Flags -"""""""""""""""""""""""""""""""""" - -If a package descriptions specifies configuration flags the package user -can `control these in several -ways `__. If the -user does not fix the value of a flag, Cabal will try to find a flag -assignment in the following way. - -- For each flag specified, it will assign its default value, evaluate - all conditions with this flag assignment, and check if all - dependencies can be satisfied. If this check succeeded, the package - will be configured with those flag assignments. - -- If dependencies were missing, the last flag (as by the order in which - the flags were introduced in the package description) is tried with - its alternative value and so on. This continues until either an - assignment is found where all dependencies can be satisfied, or all - possible flag assignments have been tried. - -To put it another way, Cabal does a complete backtracking search to find -a satisfiable package configuration. It is only the dependencies -specified in the :pkg-field:`build-depends` field in conditional blocks that -determine if a particular flag assignment is satisfiable -(:pkg-field:`build-tools` are not considered). The order of the declaration and -the default value of the flags determines the search order. Flags -overridden on the command line fix the assignment of that flag, so no -backtracking will be tried for that flag. - -If no suitable flag assignment could be found, the configuration phase -will fail and a list of missing dependencies will be printed. Note that -this resolution process is exponential in the worst case (i.e., in the -case where dependencies cannot be satisfied). There are some -optimizations applied internally, but the overall complexity remains -unchanged. - -Meaning of field values when using conditionals -^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - -During the configuration phase, a flag assignment is chosen, all -conditionals are evaluated, and the package description is combined into -a flat package descriptions. If the same field is declared both inside -a conditional and outside then they are combined using the following rules. - -- Boolean fields are combined using conjunction (logical "and"). - -- List fields are combined by appending the inner items to the outer - items, for example - - :: - - other-extensions: CPP - if impl(ghc) - other-extensions: MultiParamTypeClasses - - when compiled using GHC will be combined to - - :: - - other-extensions: CPP, MultiParamTypeClasses - - Similarly, if two conditional sections appear at the same nesting - level, properties specified in the latter will come after properties - specified in the former. - -- All other fields must not be specified in ambiguous ways. For example - - :: - - Main-is: Main.hs - if flag(useothermain) - Main-is: OtherMain.hs - - will lead to an error. Instead use - - :: - - if flag(useothermain) - Main-is: OtherMain.hs - else - Main-is: Main.hs - -.. _common-stanzas: - -Common stanzas -^^^^^^^^^^^^^^ - -.. pkg-section:: common name - :since: 2.2 - :synopsis: Common build info section - -Starting with Cabal-2.2 it's possible to use common build info stanzas. - -:: - - common deps - build-depends: base ^>= 4.11 - ghc-options: -Wall - - common test-deps - build-depends: tasty ^>= 0.12.0.1 - - library - import: deps - exposed-modules: Foo - - test-suite tests - import: deps, test-deps - type: exitcode-stdio-1.0 - main-is: Tests.hs - build-depends: foo - -- You can use `build information`_ fields in common stanzas. - -- Common stanzas must be defined before use. - -- Common stanzas can import other common stanzas. - -- You can import multiple stanzas at once. Stanza names must be separated by commas. - -- ``import`` must be the first field in a section. Since Cabal 3.0 imports - are also allowed inside conditionals. - -.. Note:: - - The name `import` was chosen, because there is ``includes`` field. - -.. pkg-section:: None - -.. pkg-field:: import: token-list - - TBW - -Source Repositories -^^^^^^^^^^^^^^^^^^^ - -.. pkg-section:: source-repository - :since: 1.6 - -It is often useful to be able to specify a source revision control -repository for a package. Cabal lets you specify this information in -a relatively structured form which enables other tools to interpret and -make effective use of the information. For example the information -should be sufficient for an automatic tool to checkout the sources. - -Cabal supports specifying different information for various common -source control systems. Obviously not all automated tools will support -all source control systems. - -Cabal supports specifying repositories for different use cases. By -declaring which case we mean automated tools can be more useful. There -are currently two kinds defined: - -- The ``head`` kind refers to the latest development branch of the - package. This may be used for example to track activity of a project - or as an indication to outside developers what sources to get for - making new contributions. - -- The ``this`` kind refers to the branch and tag of a repository that - contains the sources for this version or release of a package. For - most source control systems this involves specifying a tag, id or - hash of some form and perhaps a branch. The purpose is to be able to - reconstruct the sources corresponding to a particular package - version. This might be used to indicate what sources to get if - someone needs to fix a bug in an older branch that is no longer an - active head branch. - -You can specify one kind or the other or both. As an example here are -the repositories for the Cabal library. Note that the ``this`` kind of -repository specifies a tag. - -:: - - source-repository head - type: darcs - location: http://darcs.haskell.org/cabal/ - - source-repository this - type: darcs - location: http://darcs.haskell.org/cabal-branches/cabal-1.6/ - tag: 1.6.1 - -The exact fields are as follows: - -.. pkg-field:: type: token - - The name of the source control system used for this repository. The - currently recognised types are: - - - ``darcs`` - - ``git`` - - ``svn`` - - ``cvs`` - - ``mercurial`` (or alias ``hg``) - - ``bazaar`` (or alias ``bzr``) - - ``arch`` - - ``monotone`` - - This field is required. - -.. pkg-field:: location: URL - - The location of the repository. The exact form of this field depends - on the repository type. For example: - - - for darcs: ``http://code.haskell.org/foo/`` - - for git: ``git://github.com/foo/bar.git`` - - for CVS: ``anoncvs@cvs.foo.org:/cvs`` - - This field is required. - -.. pkg-field:: module: token - - CVS requires a named module, as each CVS server can host multiple - named repositories. - - This field is required for the CVS repository type and should not be - used otherwise. - -.. pkg-field:: branch: token - - Many source control systems support the notion of a branch, as a - distinct concept from having repositories in separate locations. For - example CVS, SVN and git use branches while darcs uses different - locations for different branches. If you need to specify a branch to - identify a your repository then specify it in this field. - - This field is optional. - -.. pkg-field:: tag: token - - A tag identifies a particular state of a source repository. The tag - can be used with a ``this`` repository kind to identify the state of - a repository corresponding to a particular package version or - release. The exact form of the tag depends on the repository type. - - This field is required for the ``this`` repository kind. - -.. pkg-field:: subdir: directory - - Some projects put the sources for multiple packages under a single - source repository. This field lets you specify the relative path - from the root of the repository to the top directory for the - package, i.e. the directory containing the package's ``.cabal`` - file. - - This field is optional. It defaults to empty which corresponds to the - root directory of the repository. - -Downloading a package's source -^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - -The ``cabal get`` command allows to access a package's source code - -either by unpacking a tarball downloaded from Hackage (the default) or -by checking out a working copy from the package's source repository. - -:: - - $ cabal get [FLAGS] PACKAGES - -The ``get`` command supports the following options: - -``-d --destdir`` *PATH* - Where to place the package source, defaults to (a subdirectory of) - the current directory. -``-s --source-repository`` *[head\|this\|...]* - Fork the package's source repository using the appropriate version - control system. The optional argument allows to choose a specific - repository kind. -``--index-state`` *[HEAD\|@\|]* - Use source package index state as it existed at a previous time. Accepts - unix-timestamps (e.g. ``@1474732068``), ISO8601 UTC timestamps (e.g. - ``2016-09-24T17:47:48Z``), or ``HEAD`` (default). - This determines which package versions are available as well as which - ``.cabal`` file revision is selected (unless ``--pristine`` is used). -``--pristine`` - Unpack the original pristine tarball, rather than updating the - ``.cabal`` file with the latest revision from the package archive. - -Custom setup scripts --------------------- - -Since Cabal 1.24, custom ``Setup.hs`` are required to accurately track -their dependencies by declaring them in the ``.cabal`` file rather than -rely on dependencies being implicitly in scope. Please refer to -`this article `__ -for more details. - -As of Cabal library version 3.0, ``defaultMain*`` variants implement support -for response files. Custom ``Setup.hs`` files that do not use one of these -main functions are required to implement their own support, such as by using -``GHC.ResponseFile.getArgsWithResponseFiles``. - -Declaring a ``custom-setup`` stanza also enables the generation of -``MIN_VERSION_package_(A,B,C)`` CPP macros for the Setup component. - -.. pkg-section:: custom-setup - :synopsis: Custom Setup.hs build information. - :since: 1.24 - - The optional :pkg-section:`custom-setup` stanza contains information needed - for the compilation of custom ``Setup.hs`` scripts, - -:: - - custom-setup - setup-depends: - base >= 4.5 && < 4.11, - Cabal >= 1.14 && < 1.25 - -.. pkg-field:: setup-depends: package list - :since: 1.24 - - The dependencies needed to compile ``Setup.hs``. See the - :pkg-field:`build-depends` field for a description of the syntax expected by - this field. - - If the field is not specified the implicit package set will be used. - The package set contains packages bundled with GHC (i.e. ``base``, - ``bytestring``) and specifically ``Cabal``. - The specific bounds are put on ``Cabal`` dependency: - lower-bound is inferred from :pkg-field:`cabal-version`, - and the upper-bound is ``< 1.25``. - - ``Cabal`` version is additionally restricted by GHC, - with absolute minimum being ``1.20``, and for example ``Custom`` - builds with GHC-8.10 require at least ``Cabal-3.2``. - - -Backward compatibility and ``custom-setup`` -^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - -Versions prior to Cabal 1.24 don't recognise ``custom-setup`` stanzas, -and will behave agnostic to them (except for warning about an unknown -section). Consequently, versions prior to Cabal 1.24 can't ensure the -declared dependencies ``setup-depends`` are in scope, and instead -whatever is registered in the current package database environment -will become eligible (and resolved by the compiler) for the -``Setup.hs`` module. - -The availability of the -``MIN_VERSION_package_(A,B,C)`` CPP macros -inside ``Setup.hs`` scripts depends on the condition that either - -- a ``custom-setup`` section has been declared (or ``cabal v2-build`` is being - used which injects an implicit hard-coded ``custom-setup`` stanza if it's missing), or -- GHC 8.0 or later is used (which natively injects package version CPP macros) - -Consequently, if you need to write backward compatible ``Setup.hs`` -scripts using CPP, you should declare a ``custom-setup`` stanza and -use the pattern below: - -.. code-block:: haskell - - {-# LANGUAGE CPP #-} - import Distribution.Simple - - #if defined(MIN_VERSION_Cabal) - -- version macros are available and can be used as usual - # if MIN_VERSION_Cabal(a,b,c) - -- code specific to lib:Cabal >= a.b.c - # else - -- code specific to lib:Cabal < a.b.c - # endif - #else - # warning Enabling heuristic fall-back. Please upgrade cabal-install to 1.24 or later if Setup.hs fails to compile. - - -- package version macros not available; except for exotic environments, - -- you can heuristically assume that lib:Cabal's version is correlated - -- with __GLASGOW_HASKELL__, and specifically since we can assume that - -- GHC < 8.0, we can assume that lib:Cabal is version 1.22 or older. - #endif - - main = ... - -The simplified (heuristic) CPP pattern shown below is useful if all you need -is to distinguish ``Cabal < 2.0`` from ``Cabal >= 2.0``. - -.. code-block:: haskell - - {-# LANGUAGE CPP #-} - import Distribution.Simple - - #if !defined(MIN_VERSION_Cabal) - # define MIN_VERSION_Cabal(a,b,c) 0 - #endif - - #if MIN_VERSION_Cabal(2,0,0) - -- code for lib:Cabal >= 2.0 - #else - -- code for lib:Cabal < 2.0 - #endif - - main = ... - - - -Autogenerated modules and includes ----------------------------------- - -.. pkg-section:: None - -Modules that are built automatically at setup, created with a custom -setup script, must appear on :pkg-field:`other-modules` for the library, -executable, test-suite or benchmark stanzas or also on -:pkg-field:`library:exposed-modules` for libraries to be used, but are not -really on the package when distributed. This makes commands like sdist fail -because the file is not found. - -These special modules must appear again on the :pkg-field:`autogen-modules` -field of the stanza that is using them, besides :pkg-field:`other-modules` or -:pkg-field:`library:exposed-modules`. With this there is no need to create -complex build hooks for this poweruser case. - -.. pkg-field:: autogen-modules: module list - :since: 2.0 - - .. todo:: document autogen-modules field - -Right now :pkg-field:`executable:main-is` modules are not supported on -:pkg-field:`autogen-modules`. - -:: - - Library - default-language: Haskell2010 - build-depends: base - exposed-modules: - MyLibrary - MyLibHelperModule - other-modules: - MyLibModule - autogen-modules: - MyLibHelperModule - - Executable Exe - default-language: Haskell2010 - main-is: Dummy.hs - build-depends: base - other-modules: - MyExeModule - MyExeHelperModule - autogen-modules: - MyExeHelperModule - -.. pkg-field:: autogen-includes: filename list - :since: 3.0 - - A list of header files from this package which are autogenerated - (e.g. by a ``configure`` script). Autogenerated header files are not - packaged by ``sdist`` command. - -Virtual modules ---------------- - -TBW - -.. pkg-field:: virtual-modules: module list - :since: 2.2 - - TBW - - - -Accessing data files from package code --------------------------------------- - -The placement on the target system of files listed in -the :pkg-field:`data-files` field varies between systems, and in some cases -one can even move packages around after installation (see `prefix -independence `__). To -enable packages to find these files in a portable way, Cabal generates a -module called :file:`Paths_{pkgname}` (with any hyphens in *pkgname* -replaced by underscores) during building, so that it may be imported by -modules of the package. This module defines a function - -.. code-block:: haskell - - getDataFileName :: FilePath -> IO FilePath - -If the argument is a filename listed in the :pkg-field:`data-files` field, the -result is the name of the corresponding file on the system on which the -program is running. - -.. Note:: - - If you decide to import the :file:`Paths_{pkgname}` module then it - *must* be listed in the :pkg-field:`other-modules` field just like any other - module in your package and on :pkg-field:`autogen-modules` as the file is - autogenerated. - -The :file:`Paths_{pkgname}` module is not platform independent, as any -other autogenerated module, so it does not get included in the source -tarballs generated by ``sdist``. - -The :file:`Paths_{pkgname}` module also includes some other useful -functions and values, which record the version of the package and some -other directories which the package has been configured to be installed -into (e.g. data files live in ``getDataDir``): - -.. code-block:: haskell - - version :: Version - - getBinDir :: IO FilePath - getLibDir :: IO FilePath - getDynLibDir :: IO FilePath - getDataDir :: IO FilePath - getLibexecDir :: IO FilePath - getSysconfDir :: IO FilePath - -The actual location of all these directories can be individually -overridden at runtime using environment variables of the form -``pkg_name_var``, where ``pkg_name`` is the name of the package with all -hyphens converted into underscores, and ``var`` is either ``bindir``, -``libdir``, ``dynlibdir``, ``datadir``, ``libexedir`` or ``sysconfdir``. For example, -the configured data directory for ``pretty-show`` is controlled with the -``pretty_show_datadir`` environment variable. - -Accessing the package version -^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - -The aforementioned auto generated :file:`Paths_{pkgname}` module also -exports the constant ``version ::`` -`Version `__ -which is defined as the version of your package as specified in the -``version`` field. - -System-dependent parameters ---------------------------- - -For some packages, especially those interfacing with C libraries, -implementation details and the build procedure depend on the build -environment. The ``build-type`` ``Configure`` can be used to handle many -such situations. In this case, ``Setup.hs`` should be: - -.. code-block:: haskell - - import Distribution.Simple - main = defaultMainWithHooks autoconfUserHooks - -Most packages, however, would probably do better using the ``Simple`` -build type and `configurations`_. - -The :pkg-field:`build-type` ``Configure`` differs from ``Simple`` in two ways: - -- The package root directory must contain a shell script called - ``configure``. The configure step will run the script. This - ``configure`` script may be produced by - `autoconf `__ or may be - hand-written. The ``configure`` script typically discovers - information about the system and records it for later steps, e.g. by - generating system-dependent header files for inclusion in C source - files and preprocessed Haskell source files. (Clearly this won't work - for Windows without MSYS or Cygwin: other ideas are needed.) - -- If the package root directory contains a file called - *package*\ ``.buildinfo`` after the configuration step, subsequent - steps will read it to obtain additional settings for `build - information`_ fields,to be merged with the ones - given in the ``.cabal`` file. In particular, this file may be - generated by the ``configure`` script mentioned above, allowing these - settings to vary depending on the build environment. - -The build information file should have the following structure: - - *buildinfo* - - ``executable:`` *name* *buildinfo* - - ``executable:`` *name* *buildinfo* ... - -where each *buildinfo* consists of settings of fields listed in the -section on `build information`_. The first one (if -present) relates to the library, while each of the others relate to the -named executable. (The names must match the package description, but you -don't have to have entries for all of them.) - -Neither of these files is required. If they are absent, this setup -script is equivalent to ``defaultMain``. - -Example: Using autoconf -^^^^^^^^^^^^^^^^^^^^^^^ - -This example is for people familiar with the -`autoconf `__ tools. - -In the X11 package, the file ``configure.ac`` contains: - -.. code-block:: shell - - AC_INIT([Haskell X11 package], [1.1], [libraries@haskell.org], [X11]) - - # Safety check: Ensure that we are in the correct source directory. - AC_CONFIG_SRCDIR([X11.cabal]) - - # Header file to place defines in - AC_CONFIG_HEADERS([include/HsX11Config.h]) - - # Check for X11 include paths and libraries - AC_PATH_XTRA - AC_TRY_CPP([#include ],,[no_x=yes]) - - # Build the package if we found X11 stuff - if test "$no_x" = yes - then BUILD_PACKAGE_BOOL=False - else BUILD_PACKAGE_BOOL=True - fi - AC_SUBST([BUILD_PACKAGE_BOOL]) - - AC_CONFIG_FILES([X11.buildinfo]) - AC_OUTPUT - -Then the setup script will run the ``configure`` script, which checks -for the presence of the X11 libraries and substitutes for variables in -the file ``X11.buildinfo.in``: - -:: - - buildable: @BUILD_PACKAGE_BOOL@ - cc-options: @X_CFLAGS@ - ld-options: @X_LIBS@ - -This generates a file ``X11.buildinfo`` supplying the parameters needed -by later stages: - -:: - - buildable: True - cc-options: -I/usr/X11R6/include - ld-options: -L/usr/X11R6/lib - -The ``configure`` script also generates a header file -``include/HsX11Config.h`` containing C preprocessor defines recording -the results of various tests. This file may be included by C source -files and preprocessed Haskell source files in the package. - -.. Note:: - - Packages using these features will also need to list additional - files such as ``configure``, templates for ``.buildinfo`` files, files - named only in ``.buildinfo`` files, header files and so on in the - :pkg-field:`extra-source-files` field to ensure that they are included in - source distributions. They should also list files and directories generated - by ``configure`` in the :pkg-field:`extra-tmp-files` field to ensure that - they are removed by ``setup clean``. - -Quite often the files generated by ``configure`` need to be listed -somewhere in the package description (for example, in the -:pkg-field:`install-includes` field). However, we usually don't want generated -files to be included in the source tarball. The solution is again -provided by the ``.buildinfo`` file. In the above example, the following -line should be added to ``X11.buildinfo``: - -:: - - install-includes: HsX11Config.h - -In this way, the generated ``HsX11Config.h`` file won't be included in -the source tarball in addition to ``HsX11Config.h.in``, but it will be -copied to the right location during the install process. Packages that -use custom ``Setup.hs`` scripts can update the necessary fields -programmatically instead of using the ``.buildinfo`` file. - -Conditional compilation ------------------------ - -Sometimes you want to write code that works with more than one version -of a dependency. You can specify a range of versions for the dependency -in the :pkg-field:`build-depends`, but how do you then write the code that can -use different versions of the API? - -Haskell lets you preprocess your code using the C preprocessor (either -the real C preprocessor, or ``cpphs``). To enable this, add -``extensions: CPP`` to your package description. When using CPP, Cabal -provides some pre-defined macros to let you test the version of -dependent packages; for example, suppose your package works with either -version 3 or version 4 of the ``base`` package, you could select the -available version in your Haskell modules like this: - -.. code-block:: cpp - - #if MIN_VERSION_base(4,0,0) - ... code that works with base-4 ... - #else - ... code that works with base-3 ... - #endif - -In general, Cabal supplies a macro -``MIN_VERSION_``\ *``package``*\ ``_(A,B,C)`` for each package depended -on via :pkg-field:`build-depends`. This macro is true if the actual version of -the package in use is greater than or equal to ``A.B.C`` (using the -conventional ordering on version numbers, which is lexicographic on the -sequence, but numeric on each component, so for example 1.2.0 is greater -than 1.0.3). - -Since version 1.20, the ``MIN_TOOL_VERSION_``\ *``tool``* -family of macros lets you condition on the version of build tools used to -build the program (e.g. ``hsc2hs``). - -Since version 1.24, the macro ``CURRENT_COMPONENT_ID``, which -expands to the string of the component identifier that uniquely -identifies this component. Furthermore, if the package is a library, -the macro ``CURRENT_PACKAGE_KEY`` records the identifier that was passed -to GHC for use in symbols and for type equality. - -Since version 2.0, the macro ``CURRENT_PACKAGE_VERSION`` expands -to the string version number of the current package. - -Cabal places the definitions of these macros into an -automatically-generated header file, which is included when -preprocessing Haskell source code by passing options to the C -preprocessor. - -Cabal also allows to detect when the source code is being used for -generating documentation. The ``__HADDOCK_VERSION__`` macro is defined -only when compiling via Haddock_ -instead of a normal Haskell compiler. The value of the -``__HADDOCK_VERSION__`` macro is defined as ``A*1000 + B*10 + C``, where -``A.B.C`` is the Haddock version. This can be useful for working around -bugs in Haddock or generating prettier documentation in some special -cases. - -More complex packages ---------------------- - -For packages that don't fit the simple schemes described above, you have -a few options: - -- By using the :pkg-field:`build-type` ``Custom``, you can supply your own - ``Setup.hs`` file, and customize the simple build infrastructure - using *hooks*. These allow you to perform additional actions before - and after each command is run, and also to specify additional - preprocessors. A typical ``Setup.hs`` may look like this: - - .. code-block:: haskell - - import Distribution.Simple - main = defaultMainWithHooks simpleUserHooks { postHaddock = posthaddock } - - posthaddock args flags desc info = .... - - See ``UserHooks`` in - `Distribution.Simple <../release/cabal-latest/doc/API/Cabal/Distribution-Simple.html>`__ - for the details, but note that this interface is experimental, and - likely to change in future releases. - - If you use a custom ``Setup.hs`` file you should strongly consider - adding a :pkg-section:`custom-setup` stanza with a - :pkg-field:`custom-setup:setup-depends` field to ensure that your setup - script does not break with future dependency versions. - -- You could delegate all the work to ``make``, though this is unlikely - to be very portable. Cabal supports this with the :pkg-field:`build-type` - ``Make`` and a trivial setup library - `Distribution.Make <../release/cabal-latest/doc/API/Cabal/Distribution-Make.html>`__, - which simply parses the command line arguments and invokes ``make``. - Here ``Setup.hs`` should look like this: - - .. code-block:: haskell - - import Distribution.Make - main = defaultMain - - The root directory of the package should contain a ``configure`` - script, and, after that has run, a ``Makefile`` with a default target - that builds the package, plus targets ``install``, ``register``, - ``unregister``, ``clean``, ``dist`` and ``docs``. Some options to - commands are passed through as follows: - - - The ``--with-hc-pkg``, ``--prefix``, ``--bindir``, ``--libdir``, - ``--dynlibdir``, ``--datadir``, ``--libexecdir`` and ``--sysconfdir`` options to - the ``configure`` command are passed on to the ``configure`` - script. In addition the value of the ``--with-compiler`` option is - passed in a ``--with-hc`` option and all options specified with - ``--configure-option=`` are passed on. - - - The ``--destdir`` option to the ``copy`` command becomes a setting - of a ``destdir`` variable on the invocation of ``make copy``. The - supplied ``Makefile`` should provide a ``copy`` target, which will - probably look like this: - - .. code-block:: make - - copy : - $(MAKE) install prefix=$(destdir)/$(prefix) \ - bindir=$(destdir)/$(bindir) \ - libdir=$(destdir)/$(libdir) \ - dynlibdir=$(destdir)/$(dynlibdir) \ - datadir=$(destdir)/$(datadir) \ - libexecdir=$(destdir)/$(libexecdir) \ - sysconfdir=$(destdir)/$(sysconfdir) \ - -- Finally, with the :pkg-field:`build-type` ``Custom``, you can also write your - own setup script from scratch. It must conform to the interface - described in the section on `building and installing - packages `__, and you may use the Cabal - library for all or part of the work. One option is to copy the source - of ``Distribution.Simple``, and alter it for your needs. Good luck. - - -.. include:: references.inc - -.. rubric:: Footnotes - -.. [#old-style-build-tool-depends] - - Some packages (ab)use :pkg-field:`build-depends` on old-style builds, but this has a few major drawbacks: - - - using Nix-style builds it's considered an error if you depend on a exe-only package via build-depends: the solver will refuse it. - - it may or may not place the executable on ``$PATH``. - - it does not ensure the correct version of the package is installed, so you might end up overwriting versions with each other. diff --git a/cabal/Cabal/doc/cabal-project.rst b/cabal/Cabal/doc/cabal-project.rst deleted file mode 100644 --- a/cabal/Cabal/doc/cabal-project.rst +++ /dev/null @@ -1,1549 +0,0 @@ -cabal.project Reference -======================= - -``cabal.project`` files support a variety of options which configure the -details of your build. The general syntax of a ``cabal.project`` file is -similar to that of a Cabal file: there are a number of fields, some of -which live inside stanzas: - -:: - - packages: */*.cabal - with-compiler: /opt/ghc/8.0.1/bin/ghc - - package cryptohash - optimization: False - -In general, the accepted field names coincide with the accepted command -line flags that ``cabal install`` and other commands take. For example, -``cabal v2-configure --enable-profiling`` will write out a project -file with ``profiling: True``. - -The full configuration of a project is determined by combining the -following sources (later entries override earlier ones): - -1. ``~/.cabal/config`` (the user-wide global configuration) - -2. ``cabal.project`` (the project configuration) - -3. ``cabal.project.freeze`` (the output of ``cabal v2-freeze``) - -4. ``cabal.project.local`` (the output of ``cabal v2-configure``) - - -Specifying the local packages ------------------------------ - -The following top-level options specify what the local packages of a -project are: - -.. cfg-field:: packages: package location list (space or comma separated) - :synopsis: Project packages. - - :default: ``./*.cabal`` - - Specifies the list of package locations which contain the local - packages to be built by this project. Package locations can take the - following forms: - - 1. They can specify a Cabal file, or a directory containing a Cabal - file, e.g., ``packages: Cabal cabal-install/cabal-install.cabal``. - - 2. They can specify a glob-style wildcards, which must match one or - more (a) directories containing a (single) Cabal file, (b) Cabal - files (extension ``.cabal``), or (c) tarballs which contain Cabal - packages (extension ``.tar.gz``). - For example, to match all Cabal files in all - subdirectories, as well as the Cabal projects in the parent - directories ``foo`` and ``bar``, use - ``packages: */*.cabal ../{foo,bar}/`` - - 3. They can specify an ``http``, ``https`` or ``file`` - URL, representing the path to a remote tarball to be downloaded - and built. - - There is no command line variant of this field; see :issue:`3585`. - -.. cfg-field:: optional-packages: package location list (space or comma-separated) - :synopsis: Optional project packages. - - :default: empty - - Like :cfg-field:`packages`, specifies a list of package locations - containing local packages to be built. Unlike :cfg-field:`packages`, - if we glob for a package, it is permissible for the glob to match against - zero packages. The intended use-case for :cfg-field:`optional-packages` - is to make it so that vendored packages can be automatically picked up if - they are placed in a subdirectory, but not error if there aren't any. - - There is no command line variant of this field. - -.. cfg-field:: extra-packages: package list with version bounds (comma separated) - :synopsis: Adds external packages as local - - [STRIKEOUT:Specifies a list of external packages from Hackage which - should be considered local packages.] (Not implemented) - - There is no command line variant of this field. - - - -All local packages are *vendored*, in the sense that if other packages -(including external ones from Hackage) depend on a package with the name -of a local package, the local package is preferentially used. -For subdirectories to be considered local packages, the following setting -can be used:: - - packages: ./*.cabal - optional-packages: ./*/*.cabal - -...then any package can be vendored simply by making a checkout in the -top-level project directory, as might be seen in this hypothetical -directory layout:: - - foo.cabal - foo-helper/ # local package - unix/ # vendored external package - -All of these options support globs. ``cabal v2-build`` has its own glob -format: - -- Anywhere in a path, as many times as you like, you can specify an - asterisk ``*`` wildcard. E.g., ``*/*.cabal`` matches all ``.cabal`` - files in all immediate subdirectories. Like in glob(7), asterisks do - not match hidden files unless there is an explicit period, e.g., - ``.*/foo.cabal`` will match ``.private/foo.cabal`` (but - ``*/foo.cabal`` will not). - -- You can use braces to specify specific directories; e.g., - ``{vendor,pkgs}/*.cabal`` matches all Cabal files in the ``vendor`` - and ``pkgs`` subdirectories. - -Formally, the format is described by the following BNF: - -.. todo:: - convert globbing grammar to proper ABNF_ syntax - -.. code-block:: abnf - - FilePathGlob ::= FilePathRoot FilePathGlobRel - FilePathRoot ::= {- empty -} # relative to cabal.project - | "/" # Unix root - | [a-zA-Z] ":" [/\\] # Windows root - | "~" # home directory - FilePathGlobRel ::= Glob "/" FilePathGlobRel # Unix directory - | Glob "\\" FilePathGlobRel # Windows directory - | Glob # file - | {- empty -} # trailing slash - Glob ::= GlobPiece * - GlobPiece ::= "*" # wildcard - | [^*{},/\\] * # literal string - | "\\" [*{},] # escaped reserved character - | "{" Glob "," ... "," Glob "}" # union (match any of these) - - -Specifying Packages from Remote Version Control Locations -^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - -Starting with Cabal 2.4, there is now a stanza -``source-repository-package`` for specifying packages from an external -version control which supports the following fields: - -- :pkg-field:`source-repository:type` -- :pkg-field:`source-repository:location` -- :pkg-field:`source-repository:tag` -- :pkg-field:`source-repository:subdir` - -A simple example is shown below: - -.. code-block:: cabal - - packages: . - - source-repository-package - type: git - location: https://github.com/hvr/HsYAML.git - tag: e70cf0c171c9a586b62b3f75d72f1591e4e6aaa1 - - source-repository-package - type: git - location: https://github.com/well-typed/cborg - tag: 3d274c14ca3077c3a081ba7ad57c5182da65c8c1 - subdir: cborg - -Global configuration options ----------------------------- - -The following top-level configuration options are not specific to any -package, and thus apply globally: - - -.. cfg-field:: verbose: nat - --verbose=n, -vn - :synopsis: Build verbosity level. - - :default: 1 - - Control the verbosity of ``cabal`` commands, valid values are from 0 - to 3. - - The command line variant of this field is ``--verbose=2``; a short - form ``-v2`` is also supported. - -.. cfg-field:: jobs: nat or $ncpus - --jobs=n, -jn, --jobs=$ncpus - :synopsis: Number of builds running in parallel. - - :default: 1 - - Run *nat* jobs simultaneously when building. If ``$ncpus`` is - specified, run the number of jobs equal to the number of CPUs. - Package building is often quite parallel, so turning on parallelism - can speed up build times quite a bit! - - The command line variant of this field is ``--jobs=2``; a short form - ``-j2`` is also supported; a bare ``--jobs`` or ``-j`` is equivalent - to ``--jobs=$ncpus``. - -.. cfg-field:: keep-going: boolean - --keep-going - :synopsis: Try to continue building on failure. - - :default: False - - If true, after a build failure, continue to build other unaffected - packages. - - The command line variant of this field is ``--keep-going``. - -.. option:: --builddir=DIR - - Specifies the name of the directory where build products for - build will be stored; defaults to ``dist-newstyle``. If a - relative name is specified, this directory is resolved relative - to the root of the project (i.e., where the ``cabal.project`` - file lives.) - - This option cannot be specified via a ``cabal.project`` file. - -.. _cmdoption-project-file: -.. option:: --project-file=FILE - - Specifies the name of the project file used to specify the - rest of the top-level configuration; defaults to ``cabal.project``. - This name not only specifies the name of the main project file, - but also the auxiliary project files ``cabal.project.freeze`` - and ``cabal.project.local``; for example, if you specify - ``--project-file=my.project``, then the other files that will - be probed are ``my.project.freeze`` and ``my.project.local``. - - If the specified project file is a relative path, we will - look for the file relative to the current working directory, - and then for the parent directory, until the project file is - found or we have hit the top of the user's home directory. - - This option cannot be specified via a ``cabal.project`` file. - -.. option:: --store-dir=DIR - - Specifies the name of the directory of the global package store. - -Solver configuration options ----------------------------- - -The following settings control the behavior of the dependency solver: - -.. cfg-field:: constraints: constraints list (comma separated) - --constraint="pkg >= 2.0" - :synopsis: Extra dependencies constraints. - - Add extra constraints to the version bounds, flag settings, - and other properties a solver can pick for a - package. For example: - - :: - - constraints: bar == 2.1 - - A package can be specified multiple times in ``constraints``, in - which case the specified constraints are intersected. This is - useful, since the syntax does not allow you to specify multiple - constraints at once. For example, to specify both version bounds and - flag assignments, you would write: - - :: - - constraints: bar == 2.1, - bar +foo -baz - - Valid constraints take the same form as for the `constraint - command line option - `__. - -.. cfg-field:: preferences: preference (comma separated) - --preference="pkg >= 2.0" - :synopsis: Preferred dependency versions. - - Like :cfg-field:`constraints`, but the solver will attempt to satisfy - these preferences on a best-effort basis. The resulting install is locally - optimal with respect to preferences; specifically, no single package - could be replaced with a more preferred version that still satisfies - the hard constraints. - - Operationally, preferences can cause the solver to attempt certain - version choices of a package before others, which can improve - dependency solver runtime. - - One way to use :cfg-field:`preferences` is to take a known working set of - constraints (e.g., via ``cabal v2-freeze``) and record them as - preferences. In this case, the solver will first attempt to use this - configuration, and if this violates hard constraints, it will try to - find the minimal number of upgrades to satisfy the hard constraints - again. - - The command line variant of this field is - ``--preference="pkg >= 2.0"``; to specify multiple preferences, pass - the flag multiple times. - -.. cfg-field:: allow-newer: none, all or list of scoped package names (space or comma separated) - --allow-newer, --allow-newer=[none,all,[scope:][^]pkg] - :synopsis: Lift dependencies upper bound constraints. - - :default: ``none`` - - Allow the solver to pick an newer version of some packages than - would normally be permitted by than the :pkg-field:`build-depends` bounds - of packages in the install plan. This option may be useful if the - dependency solver cannot otherwise find a valid install plan. - - For example, to relax ``pkg``\ s :pkg-field:`build-depends` upper bound on - ``dep-pkg``, write a scoped package name of the form: - - :: - - allow-newer: pkg:dep-pkg - - If the scope shall be limited to specific releases of ``pkg``, the - extended form as in - - :: - - allow-newer: pkg-1.2.3:dep-pkg, pkg-1.1.2:dep-pkg - - can be used to limit the relaxation of dependencies on - ``dep-pkg`` by the ``pkg-1.2.3`` and ``pkg-1.1.2`` releases only. - - The scoped syntax is recommended, as it is often only a single package - whose upper bound is misbehaving. In this case, the upper bounds of - other packages should still be respected; indeed, relaxing the bound - can break some packages which test the selected version of packages. - - The syntax also allows to prefix the dependee package with a - modifier symbol to modify the scope/semantic of the relaxation - transformation in a additional ways. Currently only one modifier - symbol is defined, i.e. ``^`` (i.e. caret) which causes the - relaxation to be applied only to ``^>=`` operators and leave all other - version operators untouched. - - However, in some situations (e.g., when attempting to build packages - on a new version of GHC), it is useful to disregard *all* - upper-bounds, with respect to a package or all packages. This can be - done by specifying just a package name, or using the keyword ``all`` - to specify all packages: - - :: - - -- Disregard upper bounds involving the dependencies on - -- packages bar, baz. For quux only, relax - -- 'quux ^>= ...'-style constraints only. - allow-newer: bar, baz, ^quux - - -- Disregard all upper bounds when dependency solving - allow-newer: all - - -- Disregard all `^>=`-style upper bounds when dependency solving - allow-newer: ^all - - - For consistency, there is also the explicit wildcard scope syntax - ``*`` (or its alphabetic synonym ``all``). Consequently, the - examples above are equivalent to the explicitly scoped variants: - - :: - - allow-newer: all:bar, *:baz, *:^quux - - allow-newer: *:* - allow-newer: all:all - - allow-newer: *:^* - allow-newer: all:^all - - In order to ignore all bounds specified by a package ``pkg-1.2.3`` - you can combine scoping with a right-hand-side wildcard like so - - :: - - -- Disregard any upper bounds specified by pkg-1.2.3 - allow-newer: pkg-1.2.3:* - - -- Disregard only `^>=`-style upper bounds in pkg-1.2.3 - allow-newer: pkg-1.2.3:^* - - - :cfg-field:`allow-newer` is often used in conjunction with a constraint - (in the cfg-field:`constraints` field) forcing the usage of a specific, - newer version of a package. - - The command line variant of this field is e.g. ``--allow-newer=bar``. A - bare ``--allow-newer`` is equivalent to ``--allow-newer=all``. - -.. cfg-field:: allow-older: none, all, list of scoped package names (space or comma separated) - --allow-older, --allow-older=[none,all,[scope:][^]pkg] - :synopsis: Lift dependency lower bound constraints. - :since: 2.0 - - :default: ``none`` - - Like :cfg-field:`allow-newer`, but applied to lower bounds rather than - upper bounds. - - The command line variant of this field is ``--allow-older=all``. A - bare ``--allow-older`` is equivalent to ``--allow-older=all``. - - -.. cfg-field:: index-state: HEAD, unix-timestamp, ISO8601 UTC timestamp. - :synopsis: Use source package index state as it existed at a previous time. - :since: 2.0 - - :default: ``HEAD`` - - This allows to change the source package index state the solver uses - to compute install-plans. This is particularly useful in - combination with freeze-files in order to also freeze the state the - package index was in at the time the install-plan was frozen. - - :: - - -- UNIX timestamp format example - index-state: @1474739268 - - -- ISO8601 UTC timestamp format example - -- This format is used by 'cabal v2-configure' - -- for storing `--index-state` values. - index-state: 2016-09-24T17:47:48Z - - -- Specify different index-states per package repository - -- Supported since 3.4 - index-state: - , hackage.haskell.org 2020-05-06T22:33:27Z - , head.hackage 2020-04-29T04:11:05Z - -.. cfg-field:: active-repositories: reponame1, reponame2 - - :synopsis: Specify active package repositories - :since: 3.4 - - :default: ``:rest`` - - This allows to specify the active package repositories, - when multiple are specified. This is useful as you - can specify the order and the way active repositories are merged. - - :: - - -- for packages in head.hackage - -- only versions in head.hackage are considered - active-repositories: - , hackage.haskell.org - , head.hackage:override - - -- Force head.hackage to be the primary repository considered - active-repositories: :rest, head.hackage - - -- "Offline" mode - active-repositories: none - - -.. cfg-field:: reject-unconstrained-dependencies: all, none - --reject-unconstrained-dependencies=[all|none] - :synopsis: Restrict the solver to packages that have constraints on them. - - :default: none - :since: 2.6 - - By default, the dependency solver can include any package that it's - aware of in a build plan. If you wish to restrict the build plan to - a closed set of packages (e.g., from a freeze file), use this flag. - - When set to `all`, all non-local packages that aren't goals must be - explicitly constrained. When set to `none`, the solver will - consider all packages. - - -Package configuration options ------------------------------ - -Package options affect the building of specific packages. There are three -ways a package option can be specified: - -- They can be specified at the top-level, in which case they apply only - to **local package**, or - -- They can be specified inside a ``package`` stanza, in which case they - apply to the build of the package, whether or not it is local or - external. - -- They can be specified inside an ``package *`` stanza, in which case they - apply to all packages, local ones from the project and also external - dependencies. - - -For example, the following options specify that :cfg-field:`optimization` -should be turned off for all local packages, and that ``bytestring`` (possibly -an external dependency) should be built with ``-fno-state-hack``:: - - optimization: False - - package bytestring - ghc-options: -fno-state-hack - -``ghc-options`` is not specifically described in this documentation, -but is one of many fields for configuring programs. They take the form -``progname-options`` and ``progname-location``, and -can only be set inside package stanzas. (TODO: They are not supported -at top-level, see :issue:`3579`.) - -At the moment, there is no way to specify an option to apply to all -external packages or all inplace packages. Additionally, it is only -possible to specify these options on the command line for all local -packages (there is no per-package command line interface.) - -Some flags were added by more recent versions of the Cabal library. This -means that they are NOT supported by packages which use Custom setup -scripts that require a version of the Cabal library older than when the -feature was added. - -.. cfg-field:: flags: list of +flagname or -flagname (space separated) - --flags="+foo -bar", -ffoo, -f-bar - :synopsis: Enable or disable package flags. - - Force all flags specified as ``+flagname`` to be true, and all flags - specified as ``-flagname`` to be false. For example, to enable the - flag ``foo`` and disable ``bar``, set: - - :: - - flags: +foo -bar - - If there is no leading punctuation, it is assumed that the flag - should be enabled; e.g., this is equivalent: - - :: - - flags: foo -bar - - Flags are *per-package*, so it doesn't make much sense to specify - flags at the top-level, unless you happen to know that *all* of your - local packages support the same named flags. If a flag is not - supported by a package, it is ignored. - - See also the solver configuration field :cfg-field:`constraints`. - - The command line variant of this flag is ``--flags``. There is also - a shortened form ``-ffoo -f-bar``. - - A common mistake is to say ``cabal v2-build -fhans``, where - ``hans`` is a flag for a transitive dependency that is not in the - local package; in this case, the flag will be silently ignored. If - ``haskell-tor`` is the package you want this flag to apply to, try - ``--constraint="haskell-tor +hans"`` instead. - -.. cfg-field:: with-compiler: executable - --with-compiler=executable - :synopsis: Path to compiler executable. - - Specify the path to a particular compiler to be used. If not an - absolute path, it will be resolved according to the :envvar:`PATH` - environment. The type of the compiler (GHC, GHCJS, etc) must be - consistent with the setting of the :cfg-field:`compiler` field. - - The most common use of this option is to specify a different version - of your compiler to be used; e.g., if you have ``ghc-7.8`` in your - path, you can specify ``with-compiler: ghc-7.8`` to use it. - - This flag also sets the default value of :cfg-field:`with-hc-pkg`, using - the heuristic that it is named ``ghc-pkg-7.8`` (if your executable name - is suffixed with a version number), or is the executable named - ``ghc-pkg`` in the same directory as the ``ghc`` directory. If this - heuristic does not work, set :cfg-field:`with-hc-pkg` explicitly. - - For inplace packages, ``cabal v2-build`` maintains a separate build - directory for each version of GHC, so you can maintain multiple - build trees for different versions of GHC without clobbering each - other. - - At the moment, it's not possible to set :cfg-field:`with-compiler` on a - per-package basis, but eventually we plan on relaxing this - restriction. If this is something you need, give us a shout. - - The command line variant of this flag is - ``--with-compiler=ghc-7.8``; there is also a short version - ``-w ghc-7.8``. - -.. cfg-field:: with-hc-pkg: executable - --with-hc-pkg=executable - :synopsis: Specifies package tool. - - Specify the path to the package tool, e.g., ``ghc-pkg``. This - package tool must be compatible with the compiler specified by - :cfg-field:`with-compiler` (generally speaking, it should be precisely - the tool that was distributed with the compiler). If this option is - omitted, the default value is determined from :cfg-field:`with-compiler`. - - The command line variant of this flag is - ``--with-hc-pkg=ghc-pkg-7.8``. - -.. cfg-field:: optimization: nat - --enable-optimization - --disable-optimization - :synopsis: Build with optimization. - - :default: ``1`` - - Build with optimization. This is appropriate for production use, - taking more time to build faster libraries and programs. - - The optional *nat* value is the optimisation level. Some compilers - support multiple optimisation levels. The range is 0 to 2. Level 0 - disables optimization, level 1 is the default. Level 2 is higher - optimisation if the compiler supports it. Level 2 is likely to lead - to longer compile times and bigger generated code. If you are not - planning to run code, turning off optimization will lead to better - build times and less code to be rebuilt when a module changes. - - When optimizations are enabled, Cabal passes ``-O2`` to the C compiler. - - We also accept ``True`` (equivalent to 1) and ``False`` (equivalent - to 0). - - Note that as of GHC 8.0, GHC does not recompile when optimization - levels change (see :ghc-ticket:`10923`), so if - you change the optimization level for a local package you may need - to blow away your old build products in order to rebuild with the - new optimization level. - - The command line variant of this flag is ``-O2`` (with ``-O1`` - equivalent to ``-O``). There are also long-form variants - ``--enable-optimization`` and ``--disable-optimization``. - -.. cfg-field:: configure-options: args (space separated) - --configure-option=arg - :synopsis: Options to pass to configure script. - - A list of extra arguments to pass to the external ``./configure`` - script, if one is used. This is only useful for packages which have - the ``Configure`` build type. See also the section on - `system-dependent - parameters `__. - - The command line variant of this flag is ``--configure-option=arg``, - which can be specified multiple times to pass multiple options. - -.. cfg-field:: compiler: ghc, ghcjs, jhc, lhc, uhc or haskell-suite - --compiler=compiler - :synopsis: Compiler to build with. - - :default: ``ghc`` - - Specify which compiler toolchain to be used. This is independent of - ``with-compiler``, because the choice of toolchain affects Cabal's - build logic. - - The command line variant of this flag is ``--compiler=ghc``. - -.. cfg-field:: tests: boolean - --enable-tests - --disable-tests - :synopsis: Build tests. - - :default: ``False`` - - Force test suites to be enabled. For most users this should not be - needed, as we always attempt to solve for test suite dependencies, - even when this value is ``False``; furthermore, test suites are - automatically enabled if they are requested as a built target. - - The command line variant of this flag is ``--enable-tests`` and - ``--disable-tests``. - -.. cfg-field:: benchmarks: boolean - --enable-benchmarks - --disable-benchmarks - :synopsis: Build benchmarks. - - :default: ``False`` - - Force benchmarks to be enabled. For most users this should not be - needed, as we always attempt to solve for benchmark dependencies, - even when this value is ``False``; furthermore, benchmarks are - automatically enabled if they are requested as a built target. - - The command line variant of this flag is ``--enable-benchmarks`` and - ``--disable-benchmarks``. - -.. cfg-field:: extra-prog-path: paths (newline or comma separated) - --extra-prog-path=PATH - :synopsis: Add directories to program search path. - :since: 1.18 - - A list of directories to search for extra required programs. Most - users should not need this, as programs like ``happy`` and ``alex`` - will automatically be installed and added to the path. This can be - useful if a ``Custom`` setup script relies on an exotic extra - program. - - The command line variant of this flag is ``--extra-prog-path=PATH``, - which can be specified multiple times. - -.. cfg-field:: run-tests: boolean - --run-tests - :synopsis: Run package test suite upon installation. - - :default: ``False`` - - Run the package test suite upon installation. This is useful for - saying "When this package is installed, check that the test suite - passes, terminating the rest of the build if it is broken." - - .. warning:: - - One deficiency: the :cfg-field:`run-tests` setting of a package is NOT - recorded as part of the hash, so if you install something without - :cfg-field:`run-tests` and then turn on ``run-tests``, we won't - subsequently test the package. If this is causing you problems, give - us a shout. - - The command line variant of this flag is ``--run-tests``. - -Object code options -^^^^^^^^^^^^^^^^^^^ - -.. cfg-field:: debug-info: integer - --enable-debug-info= - --disable-debug-info - :synopsis: Build with debug info enabled. - :since: 1.22 - - :default: False - - If the compiler (e.g., GHC 7.10 and later) supports outputing OS - native debug info (e.g., DWARF), setting ``debug-info: True`` will - instruct it to do so. See the GHC wiki page on :ghc-wiki:`DWARF` - for more information about this feature. - - (This field also accepts numeric syntax, but until GHC 8.2 this didn't - do anything.) - - The command line variant of this flag is ``--enable-debug-info`` and - ``--disable-debug-info``. - -.. cfg-field:: split-sections: boolean - --enable-split-sections - --disable-split-sections - :synopsis: Use GHC's split sections feature. - :since: 2.2 - - :default: False - - Use the GHC ``-split-sections`` feature when building the library. This - reduces the final size of the executables that use the library by - allowing them to link with only the bits that they use rather than - the entire library. The downside is that building the library takes - longer and uses a bit more memory. - - This feature is supported by GHC 8.0 and later. - - The command line variant of this flag is ``--enable-split-sections`` and - ``--disable-split-sections``. - -.. cfg-field:: split-objs: boolean - --enable-split-objs - --disable-split-objs - :synopsis: Use GHC's split objects feature. - - :default: False - - Use the GHC ``-split-objs`` feature when building the library. This - reduces the final size of the executables that use the library by - allowing them to link with only the bits that they use rather than - the entire library. The downside is that building the library takes - longer and uses considerably more memory. - - It is generally recommend that you use ``split-sections`` instead - of ``split-objs`` where possible. - - The command line variant of this flag is ``--enable-split-objs`` and - ``--disable-split-objs``. - -.. cfg-field:: executable-stripping: boolean - --enable-executable-stripping - --disable-executable-stripping - :synopsis: Strip installed programs. - - :default: True - - When installing binary executable programs, run the ``strip`` - program on the binary. This can considerably reduce the size of the - executable binary file. It does this by removing debugging - information and symbols. - - Not all Haskell implementations generate native binaries. For such - implementations this option has no effect. - - If ``debug-info`` is set explicitly then ``executable-stripping`` is set - to ``False`` as otherwise all the debug symbols will be stripped. - - The command line variant of this flag is - ``--enable-executable-stripping`` and - ``--disable-executable-stripping``. - -.. cfg-field:: library-stripping: boolean - --enable-library-stripping - --disable-library-stripping - :synopsis: Strip installed libraries. - :since: 1.20 - - When installing binary libraries, run the ``strip`` program on the - binary, saving space on the file system. See also - ``executable-stripping``. - - If ``debug-info`` is set explicitly then ``library-stripping`` is set - to ``False`` as otherwise all the debug symbols will be stripped. - - The command line variant of this flag is - ``--enable-library-stripping`` and ``--disable-library-stripping``. - -Executable options -^^^^^^^^^^^^^^^^^^ - -.. cfg-field:: program-prefix: prefix - --program-prefix=prefix - :synopsis: Prepend prefix to program names. - - [STRIKEOUT:Prepend *prefix* to installed program names.] (Currently - implemented in a silly and not useful way. If you need this to work - give us a shout.) - - *prefix* may contain the following path variables: ``$pkgid``, - ``$pkg``, ``$version``, ``$compiler``, ``$os``, ``$arch``, ``$abi``, - ``$abitag`` - - The command line variant of this flag is ``--program-prefix=foo-``. - -.. cfg-field:: program-suffix: suffix - --program-suffix=suffix - :synopsis: Append refix to program names. - - [STRIKEOUT:Append *suffix* to installed program names.] (Currently - implemented in a silly and not useful way. If you need this to work - give us a shout.) - - The most obvious use for this is to append the program's version - number to make it possible to install several versions of a program - at once: ``program-suffix: $version``. - - *suffix* may contain the following path variables: ``$pkgid``, - ``$pkg``, ``$version``, ``$compiler``, ``$os``, ``$arch``, ``$abi``, - ``$abitag`` - - The command line variant of this flag is - ``--program-suffix='$version'``. - -Dynamic linking options -^^^^^^^^^^^^^^^^^^^^^^^ - -.. cfg-field:: shared: boolean - --enable-shared - --disable-shared - :synopsis: Build shared library. - - :default: False - - Build shared library. This implies a separate compiler run to - generate position independent code as required on most platforms. - - The command line variant of this flag is ``--enable-shared`` and - ``--disable-shared``. - -.. cfg-field:: executable-dynamic: boolean - --enable-executable-dynamic - --disable-executable-dynamic - :synopsis: Link executables dynamically. - - :default: False - - Link executables dynamically. The executable's library dependencies - should be built as shared objects. This implies ``shared: True`` - unless ``shared: False`` is explicitly specified. - - The command line variant of this flag is - ``--enable-executable-dynamic`` and - ``--disable-executable-dynamic``. - -.. cfg-field:: library-for-ghci: boolean - --enable-library-for-ghci - --disable-library-for-ghci - :synopsis: Build libraries suitable for use with GHCi. - - :default: True - - Build libraries suitable for use with GHCi. This involves an extra - linking step after the build. - - Not all platforms support GHCi and indeed on some platforms, trying - to build GHCi libs fails. In such cases, consider setting - ``library-for-ghci: False``. - - The command line variant of this flag is - ``--enable-library-for-ghci`` and ``--disable-library-for-ghci``. - -.. cfg-field:: relocatable: - --relocatable - :synopsis: Build relocatable package. - :since: 1.22 - - :default: False - - [STRIKEOUT:Build a package which is relocatable.] (TODO: It is not - clear what this actually does, or if it works at all.) - - The command line variant of this flag is ``--relocatable``. - -Static linking options -^^^^^^^^^^^^^^^^^^^^^^ - -.. cfg-field:: static: boolean - --enable-static - --disable-static - :synopsis: Build static library. - - - :default: False - - Roll this and all dependent libraries into a combined ``.a`` archive. - This uses GHCs ``-staticlib`` flag, which is available for iOS and with - GHC 8.4 and later for other platforms as well. - -.. cfg-field:: executable-static: boolean - --enable-executable-static - --disable-executable-static - :synopsis: Build fully static executables. - - - :default: False - - Build fully static executables. - This link all dependent libraries into executables statically, - including libc. - This passes ``-static`` and ``-optl=-static`` to GHC. - -Foreign function interface options -^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - -.. cfg-field:: extra-include-dirs: directories (comma or newline separated list) - --extra-include-dirs=DIR - :synopsis: Adds C header search path. - - An extra directory to search for C header files. You can use this - flag multiple times to get a list of directories. - - You might need to use this flag if you have standard system header - files in a non-standard location that is not mentioned in the - package's ``.cabal`` file. Using this option has the same affect as - appending the directory *dir* to the :pkg-field:`include-dirs` field in each - library and executable in the package's ``.cabal`` file. The - advantage of course is that you do not have to modify the package at - all. These extra directories will be used while building the package - and for libraries it is also saved in the package registration - information and used when compiling modules that use the library. - - The command line variant of this flag is - ``--extra-include-dirs=DIR``, which can be specified multiple times. - -.. cfg-field:: extra-lib-dirs: directories (comma or newline separated list) - --extra-lib-dirs=DIR - :synopsis: Adds library search directory. - - An extra directory to search for system libraries files. - - The command line variant of this flag is ``--extra-lib-dirs=DIR``, - which can be specified multiple times. - -.. cfg-field:: extra-framework-dirs: directories (comma or newline separated list) - --extra-framework-dirs=DIR - :synopsis: Adds framework search directory (OS X only). - - An extra directory to search for frameworks (OS X only). - - You might need to use this flag if you have standard system - libraries in a non-standard location that is not mentioned in the - package's ``.cabal`` file. Using this option has the same affect as - appending the directory *dir* to the :cfg-field:`extra-lib-dirs` field in - each library and executable in the package's ``.cabal`` file. The - advantage of course is that you do not have to modify the package at - all. These extra directories will be used while building the package - and for libraries it is also saved in the package registration - information and used when compiling modules that use the library. - - The command line variant of this flag is - ``--extra-framework-dirs=DIR``, which can be specified multiple - times. - -Profiling options -^^^^^^^^^^^^^^^^^ - -.. cfg-field:: profiling: boolean - --enable-profiling - --disable-profiling - :synopsis: Enable profiling builds. - :since: 1.22 - - :default: False - - Build libraries and executables with profiling enabled (for - compilers that support profiling as a separate mode). It is only - necessary to specify :cfg-field:`profiling` for the specific package you - want to profile; ``cabal v2-build`` will ensure that all of its - transitive dependencies are built with profiling enabled. - - To enable profiling for only libraries or executables, see - :cfg-field:`library-profiling` and :cfg-field:`executable-profiling`. - - For useful profiling, it can be important to control precisely what - cost centers are allocated; see :cfg-field:`profiling-detail`. - - The command line variant of this flag is ``--enable-profiling`` and - ``--disable-profiling``. - -.. cfg-field:: profiling-detail: level - --profiling-detail=level - :synopsis: Profiling detail level. - :since: 1.24 - - Some compilers that support profiling, notably GHC, can allocate - costs to different parts of the program and there are different - levels of granularity or detail with which this can be done. In - particular for GHC this concept is called "cost centers", and GHC - can automatically add cost centers, and can do so in different ways. - - This flag covers both libraries and executables, but can be - overridden by the ``library-profiling-detail`` field. - - Currently this setting is ignored for compilers other than GHC. The - levels that cabal currently supports are: - - default - For GHC this uses ``exported-functions`` for libraries and - ``toplevel-functions`` for executables. - none - No costs will be assigned to any code within this component. - exported-functions - Costs will be assigned at the granularity of all top level - functions exported from each module. In GHC, this - is for non-inline functions. Corresponds to ``-fprof-auto-exported``. - toplevel-functions - Costs will be assigned at the granularity of all top level - functions in each module, whether they are exported from the - module or not. In GHC specifically, this is for non-inline - functions. Corresponds to ``-fprof-auto-top``. - all-functions - Costs will be assigned at the granularity of all functions in - each module, whether top level or local. In GHC specifically, - this is for non-inline toplevel or where-bound functions or - values. Corresponds to ``-fprof-auto``. - - The command line variant of this flag is - ``--profiling-detail=none``. - -.. cfg-field:: library-profiling-detail: level - --library-profiling-detail=level - :synopsis: Libraries profiling detail level. - :since: 1.24 - - Like :cfg-field:`profiling-detail`, but applied only to libraries - - The command line variant of this flag is - ``--library-profiling-detail=none``. - -.. cfg-field:: library-vanilla: boolean - --enable-library-vanilla - --disable-library-vanilla - :synopsis: Build libraries without profiling. - - :default: True - - Build ordinary libraries (as opposed to profiling libraries). - Mostly, you can set this to False to avoid building ordinary - libraries when you are profiling. - - The command line variant of this flag is - ``--enable-library-vanilla`` and ``--disable-library-vanilla``. - -.. cfg-field:: library-profiling: boolean - --enable-library-profiling - --disable-library-profiling - :synopsis: Build libraries with profiling enabled. - :since: 1.22 - - :default: False - - Build libraries with profiling enabled. You probably want - to use :cfg-field:`profiling` instead. - - The command line variant of this flag is - ``--enable-library-profiling`` and ``--disable-library-profiling``. - -.. cfg-field:: executable-profiling: boolean - --enable-executable-profiling - --disable-executable-profiling - :synopsis: Build executables with profiling enabled. - :since: 1.22 - - :default: False - - Build executables with profiling enabled. You probably want - to use :cfg-field:`profiling` instead. - - The command line variant of this flag is - ``--enable-executable-profiling`` and - ``--disable-executable-profiling``. - -Coverage options -^^^^^^^^^^^^^^^^ - -.. cfg-field:: coverage: boolean - --enable-coverage - --disable-coverage - :synopsis: Build with coverage enabled. - :since: 1.22 - - :default: False - - Build libraries and executables (including test suites) with Haskell - Program Coverage enabled. Running the test suites will automatically - generate coverage reports with HPC. - - The command line variant of this flag is ``--enable-coverage`` and - ``--disable-coverage``. - -.. cfg-field:: library-coverage: boolean - --enable-library-coverage - --disable-library-coverage - :since: 1.22 - :deprecated: - - :default: False - - Deprecated, use :cfg-field:`coverage`. - - The command line variant of this flag is - ``--enable-library-coverage`` and ``--disable-library-coverage``. - -Haddock options -^^^^^^^^^^^^^^^ - -.. cfg-field:: documentation: boolean - --enable-documentation - --disable-documentation - :synopsis: Enable building of documentation. - - :default: False - - Enables building of Haddock documentation - - The command line variant of this flag is ``--enable-documentation`` - and ``--disable-documentation``. - - `documentation: true` does not imply :cfg-field:`haddock-benchmarks`, - :cfg-field:`haddock-executables`, :cfg-field:`haddock-internal` or - :cfg-field:`haddock-tests`. These need to be enabled separately if - desired. - -.. cfg-field:: doc-index-file: templated path - --doc-index-file=TEMPLATE - :synopsis: Path to haddock templates. - - A central index of Haddock API documentation (template cannot use - ``$pkgid``), which should be updated as documentation is built. - - The command line variant of this flag is - ``--doc-index-file=TEMPLATE`` - -The following commands are equivalent to ones that would be passed when -running ``setup haddock``. (TODO: Where does the documentation get put.) - -.. cfg-field:: haddock-hoogle: boolean - :synopsis: Generate Hoogle file. - - :default: False - - Generate a text file which can be converted by Hoogle_ - into a database for searching. This is equivalent to running ``haddock`` - with the ``--hoogle`` flag. - - The command line variant of this flag is ``--hoogle`` (for the - ``haddock`` command). - -.. cfg-field:: haddock-html: boolean - :synopsis: Build HTML documentation. - - :default: True - - Build HTML documentation. - - The command line variant of this flag is ``--html`` (for the - ``haddock`` command). - -.. cfg-field:: haddock-html-location: templated path - --html-location=TEMPLATE - :synopsis: Haddock HTML templates location. - - Specify a template for the location of HTML documentation for - prerequisite packages. The substitutions are applied to the template - to obtain a location for each package, which will be used by - hyperlinks in the generated documentation. For example, the - following command generates links pointing at [Hackage] pages: - - :: - - html-location: http://hackage.haskell.org/packages/archive/$pkg/latest/doc/html - - The command line variant of this flag is ``--html-location`` (for - the ``haddock`` subcommand). - - :: - - --html-location='http://hackage.haskell.org/packages/archive/$pkg/latest/doc/html' - - Here the argument is quoted to prevent substitution by the shell. If - this option is omitted, the location for each package is obtained - using the package tool (e.g. ``ghc-pkg``). - -.. cfg-field:: haddock-executables: boolean - :synopsis: Generate documentation for executables. - - :default: False - - Run haddock on all executable programs. - - The command line variant of this flag is ``--executables`` (for the - ``haddock`` subcommand). - -.. cfg-field:: haddock-tests: boolean - :synopsis: Generate documentation for tests. - - :default: False - - Run haddock on all test suites. - - The command line variant of this flag is ``--tests`` (for the - ``haddock`` subcommand). - -.. cfg-field:: haddock-benchmarks: boolean - :synopsis: Generate documentation for benchmarks. - - :default: False - - Run haddock on all benchmarks. - - The command line variant of this flag is ``--benchmarks`` (for the - ``haddock`` subcommand). - -.. cfg-field:: haddock-all: boolean - :synopsis: Generate documentation for everything - - :default: False - - Run haddock on all components. - - The command line variant of this flag is ``--all`` (for the - ``haddock`` subcommand). - -.. cfg-field:: haddock-internal: boolean - :synopsis: Generate documentation for internal modules - - :default: False - - Build haddock documentation which includes unexposed modules and - symbols. - - The command line variant of this flag is ``--internal`` (for the - ``haddock`` subcommand). - -.. cfg-field:: haddock-css: path - :synopsis: Location of Haddoc CSS file. - - The CSS file that should be used to style the generated - documentation (overriding haddock's default.) - - The command line variant of this flag is ``--css`` (for the - ``haddock`` subcommand). - -.. cfg-field:: haddock-hyperlink-source: boolean - :synopsis: Generate hyperlinked source code for documentation - - :default: False - - Generated hyperlinked source code using `HsColour`_, and have - Haddock documentation link to it. - - The command line variant of this flag is ``--hyperlink-source`` (for - the ``haddock`` subcommand). - -.. cfg-field:: haddock-hscolour-css: path - :synopsis: Location of CSS file for HsColour - - The CSS file that should be used to style the generated hyperlinked - source code (from `HsColour`_). - - The command line variant of this flag is ``--hscolour-css`` (for the - ``haddock`` subcommand). - -.. cfg-field:: haddock-contents-location: URL - :synopsis: URL for contents page. - - A baked-in URL to be used as the location for the contents page. - - The command line variant of this flag is ``--contents-location`` - (for the ``haddock`` subcommand). - -.. cfg-field:: haddock-keep-temp-files: boolean - :synopsis: Keep temporary Haddock files. - - Keep temporary files. - - The command line variant of this flag is ``--keep-temp-files`` (for - the ``haddock`` subcommand). - -Advanced global configuration options -------------------------------------- - -.. cfg-field:: write-ghc-environment-files: always, never, or ghc8.4.4+ - --write-ghc-environment-files=policy - :synopsis: Whether a ``.ghc.environment`` should be created after a successful build. - - :default: ``never`` - - Whether a `GHC package environment file `_ - should be created after a successful build. - - Since Cabal 3.0, defaults to ``never``. Before that, defaulted to - creating them only when compiling with GHC 8.4.4 and older (GHC - 8.4.4 `is the first version - `_ that supports - the ``-package-env -`` option that allows ignoring the package - environment files). - - -.. cfg-field:: http-transport: curl, wget, powershell, or plain-http - --http-transport=transport - :synopsis: Transport to use with http(s) requests. - - :default: ``curl`` - - Set a transport to be used when making http(s) requests. - - The command line variant of this field is ``--http-transport=curl``. - -.. cfg-field:: ignore-expiry: boolean - --ignore-expiry - :synopsis: Ignore Hackage expiration dates. - - :default: False - - If ``True``, we will ignore expiry dates on metadata from Hackage. - - In general, you should not set this to ``True`` as it will leave you - vulnerable to stale cache attacks. However, it may be temporarily - useful if the main Hackage server is down, and we need to rely on - mirrors which have not been updated for longer than the expiry - period on the timestamp. - - The command line variant of this field is ``--ignore-expiry``. - -.. cfg-field:: remote-repo-cache: directory - --remote-repo-cache=DIR - :synopsis: Location of packages cache. - - :default: ``~/.cabal/packages`` - - [STRIKEOUT:The location where packages downloaded from remote - repositories will be cached.] Not implemented yet. - - The command line variant of this flag is - ``--remote-repo-cache=DIR``. - -.. cfg-field:: logs-dir: directory - --logs-dir=DIR - :synopsis: Directory to store build logs. - - :default: ``~/.cabal/logs`` - - [STRIKEOUT:The location where build logs for packages are stored.] - Not implemented yet. - - The command line variant of this flag is ``--logs-dir=DIR``. - -.. cfg-field:: build-summary: template filepath - --build-summary=TEMPLATE - :synopsis: Build summaries location. - - :default: ``~/.cabal/logs/build.log`` - - [STRIKEOUT:The file to save build summaries. Valid variables which - can be used in the path are ``$pkgid``, ``$compiler``, ``$os`` and - ``$arch``.] Not implemented yet. - - The command line variant of this flag is - ``--build-summary=TEMPLATE``. - -.. cfg-field:: world-file: path - --world-file=FILE - :deprecated: - - [STRIKEOUT:The location of the world file.] Deprecated. - - The command line variant of this flag is ``--world-file=FILE``. - -Undocumented fields: ``root-cmd``, ``symlink-bindir``, ``build-log``, -``remote-build-reporting``, ``report-planned-failure``, ``one-shot``, -``offline``. - -Advanced solver options -^^^^^^^^^^^^^^^^^^^^^^^ - -Most users generally won't need these. - -.. cfg-field:: solver: modular - --solver=modular - :synopsis: Which solver to use. - - This field is reserved to allow the specification of alternative - dependency solvers. At the moment, the only accepted option is - ``modular``. - - The command line variant of this field is ``--solver=modular``. - -.. cfg-field:: max-backjumps: nat - --max-backjumps=N - :synopsis: Maximum number of solver backjumps. - - :default: 4000 - - Maximum number of backjumps (backtracking multiple steps) allowed - while solving. Set -1 to allow unlimited backtracking, and 0 to - disable backtracking completely. - - The command line variant of this field is ``--max-backjumps=4000``. - -.. cfg-field:: reorder-goals: boolean - --reorder-goals - --no-reorder-goals - :synopsis: Allow solver to reorder goals. - - :default: False - - When enabled, the solver will reorder goals according to certain - heuristics. Slows things down on average, but may make backtracking - faster for some packages. It's unlikely to help for small projects, - but for big install plans it may help you find a plan when otherwise - this is not possible. See :issue:`1780` for more commentary. - - The command line variant of this field is ``--(no-)reorder-goals``. - -.. cfg-field:: count-conflicts: boolean - --count-conflicts - --no-count-conflicts - :synopsis: Solver prefers versions with less conflicts. - - :default: True - - Try to speed up solving by preferring goals that are involved in a - lot of conflicts. - - The command line variant of this field is - ``--(no-)count-conflicts``. - -.. cfg-field:: fine-grained-conflicts: boolean - --fine-grained-conflicts - --no-fine-grained-conflicts - :synopsis: Skip a version of a package if it does not resolve any conflicts - encountered in the last version (solver optimization). - - :default: True - - When enabled, the solver will skip a version of a package if it does not - resolve any of the conflicts encountered in the last version of that - package. For example, if ``foo-1.2`` depended on ``bar``, and the solver - couldn't find consistent versions for ``bar``'s dependencies, then the - solver would skip ``foo-1.1`` if it also depended on ``bar``. - - The command line variant of this field is - ``--(no-)fine-grained-conflicts``. - -.. cfg-field:: minimize-conflict-set: boolean - --minimize-conflict-set - --no-minimize-conflict-set - :synopsis: Try to improve the solver error message when there is no - solution. - - :default: False - - When there is no solution, try to improve the solver error message - by finding a minimal conflict set. This option may increase run - time significantly, so it is off by default. - - The command line variant of this field is - ``--(no-)minimize-conflict-set``. - -.. cfg-field:: strong-flags: boolean - --strong-flags - --no-strong-flags - :synopsis: Do not defer flag choices when solving. - - :default: False - - Do not defer flag choices. (TODO: Better documentation.) - - The command line variant of this field is ``--(no-)strong-flags``. - -.. cfg-field:: allow-boot-library-installs: boolean - --allow-boot-library-installs - --no-allow-boot-library-installs - :synopsis: Allow cabal to install or upgrade any package. - - :default: False - - By default, the dependency solver doesn't allow ``base``, - ``ghc-prim``, ``integer-simple``, ``integer-gmp``, and - ``template-haskell`` to be installed or upgraded. This flag - removes the restriction. - - The command line variant of this field is - ``--(no-)allow-boot-library-installs``. - -.. cfg-field:: cabal-lib-version: version - --cabal-lib-version=version - :synopsis: Version of Cabal library used to build package. - - This field selects the version of the Cabal library which should be - used to build packages. This option is intended primarily for - internal development use (e.g., forcing a package to build with a - newer version of Cabal, to test a new version of Cabal.) (TODO: - Specify its semantics more clearly.) - - The command line variant of this field is - ``--cabal-lib-version=1.24.0.1``. - -.. include:: references.inc diff --git a/cabal/Cabal/doc/cabaldomain.py b/cabal/Cabal/doc/cabaldomain.py deleted file mode 100644 --- a/cabal/Cabal/doc/cabaldomain.py +++ /dev/null @@ -1,917 +0,0 @@ -# -*- coding: utf-8 -*- -''' -Sphinx domain for documenting all things cabal - -The main reason to use this instead of adding object types to std domain -is the ability to generate nice 'Reference' page and also provide some meta -data for objects described with directives described here. - -Most directives have at least following optional arguments - -`:since: 1.24` - version of Cabal in which feature was added. - -`:deprecated: 1.24` -`:deprecated:` - Feature was deprecated, and optionally since which version. - -`:removed: 3.0` - Feature was removed - -`:synopsis: Short desc` - Text used as short description on reference page. - - -Added directives - -.. rst:directive:: .. cabal::cfg-section - - Describes a package.cabal section, such as library or executable. - - All following `pkg-field` directives will add section name - to their fields name for disambiguating duplicates. - - You can reset the section disambiguation with `.. pkg-section:: None`. - -.. rst::role:: pkg-section - - References section added by `.. pkg-section` - -.. rst:directive:: .. cabal::pkg-field - - Describes a package.cabal field. - - Can have a :default: field. Will group on reference page under pkg-section - if set and parent header otherwise. - -.. rst::role:: pkg-field - - References field added by `.. pkg-field`, fields can be disambiguated - with section name `:pkg-field:`section:field`. - - -.. rst:directive:: .. cabal:cfg-section:: - - Same as `.. cabal::pkg-section` but does not produce any visible output - currently unused. - -.. rst:directive:: .. cabal:cfg-field:: - - Describes a cabal.project field. - - Can have multiple arguments, if arguments start with '-' then it is treated - as a cabal flag. - - Can have a :default: field. Will group on reference page under pkg-section - if set and parent header otherwise. - -.. rst::role:: cfg-field - - References field added by `.. cfg-field`. - -.. rst::role:: cfg-flag - - References flag added by `.. cfg-field`. - - -All roles can be supplied with title as in standard sphinx references:: - - :pkg-field:`Build dependencies` - - -To be done: - -- Directives for describing executables, their subcommands and flags. - - These should act in a way similar to `.. std::option` directive, but with - extra meta. And should also end up in reference. - - At least setup and 'new-build` subcommands should get special directives - -- Improve rendering of flags in `.. cfg-field::` directive. It should be - possible without copy-pasting code from sphinx.directives.ObjectDescription - by examining result of ObjectDescription.run and inserting flags into - desc_content node. - - Alternatively Or `.. flags::` sub-directive can be added which will be aware - of parent `.. cfg-field` directive. - -- With same ObjectDescription.run trick as above, render since and deprecated - info same way as standard object fields, and use fancy rendering only on - references page. - -- Add 'since_version` config value to sphinx env and use it to decide if - version meta info should be rendered on reference page and thus reduce some - clutter. - Can also be used to generate 'Whats new' reference page - -''' - - -import re - -from docutils import nodes -from docutils.parsers.rst import Directive, directives, roles - -import pygments.lexer as lexer -import pygments.token as token - -from distutils.version import StrictVersion - -from sphinx import addnodes -from sphinx.directives import ObjectDescription -from sphinx.domains import ObjType, Domain, Index -from sphinx.domains.std import StandardDomain -from sphinx.locale import _ -from sphinx.roles import XRefRole -from sphinx.util.docfields import Field, DocFieldTransformer -from sphinx.util.nodes import make_refnode - -def parse_deprecated(txt): - if txt is None: - return True - try: - return StrictVersion(txt) - except ValueError: - return True - -def parse_flag(env, sig, signode): - import re - names = [] - for i, flag in enumerate(sig.split(',')): - flag = flag.strip() - sep = '=' - parts = flag.split('=') - if len(parts) == 1: - sep=' ' - parts = flag.split() - if len(parts) == 0: continue - - name = parts[0] - names.append(name) - sig = sep + ' '.join(parts[1:]) - sig = re.sub(r'<([-a-zA-Z ]+)>', r'⟨\1⟩', sig) - if i > 0: - signode += addnodes.desc_name(', ', ', ') - signode += addnodes.desc_name(name, name) - if len(sig) > 0: - signode += addnodes.desc_addname(sig, sig) - - return names[0] - - -class Meta(object): - ''' - Meta data associated with object - ''' - def __init__(self, - since=None, - deprecated=None, - removed=None, - synopsis=None, - title=None, - section=None, - index=0): - self.since = since - self.deprecated = deprecated - self.removed = removed - self.synopsis = synopsis - self.title = title - self.section = section - self.index = index - - -def find_section_title(parent): - ''' - Find current section id and title if possible - ''' - while parent is not None: - if isinstance(parent, nodes.section): - break - parent = parent.parent - - if parent is None: - return None - - section_id = parent['ids'][0] - section_name = parent['names'][0] - - for kid in parent: - if isinstance(kid, nodes.title): - return kid.astext(), section_id - - print(section_name, section_id) - return section_name, section_id - - -class CabalSection(Directive): - """ - Marks section to which following objects belong, used to disambiguate - references to fields and flags which can have similar names - - Does not generate any output besides anchor. - """ - has_content = False - required_arguments = 1 - optional_arguments = 0 - final_argument_whitespace = True - option_spec = { - 'name': lambda x: x, - 'deprecated': parse_deprecated, - 'removed': StrictVersion, - 'since' : StrictVersion, - 'synopsis' : lambda x:x, - } - section_key = 'cabal:pkg-section' - target_prefix = 'pkg-section-' - indextemplate = '' - indextype = 'pair' - - def get_index_entry(self, name): - return self.indextemplate % name - - def run(self): - env = self.state.document.settings.env - section = self.arguments[0].strip() - - if ':' in self.name: - self.domain, self.objtype = self.name.split(':', 1) - else: - self.domain, self.objtype = '', self.name - - if section == 'None': - env.ref_context.pop(self.section_key, None) - return [] - - env.ref_context[self.section_key] = section - targetname = self.target_prefix + section - node = nodes.target('', '', ids=[targetname]) - self.state.document.note_explicit_target(node) - - indexentry = self.get_index_entry(section) - - inode = addnodes.index( - entries = [ - (self.indextype, indexentry, targetname, '', None)]) - - # find title of parent section node - title = find_section_title(self.state.parent) - - data_key = CabalDomain.types[self.objtype] - - # find how many sections in this document were added - num = env.domaindata['cabal']['index-num'].get(env.docname, 0) - env.domaindata['cabal']['index-num'][env.docname] = num + 1 - - meta = Meta(since=self.options.get('since'), - deprecated=self.options.get('deprecated'), - removed=self.options.get('removed'), - synopsis=self.options.get('synopsis'), - index = num, - title = title) - - store = env.domaindata['cabal'][data_key] - if not section in store: - store[section] = env.docname, targetname, meta - - return [inode, node] - - -class CabalObject(ObjectDescription): - option_spec = { - 'noindex' : directives.flag, - 'deprecated': parse_deprecated, - 'removed' : StrictVersion, - 'since' : StrictVersion, - 'synopsis' : lambda x:x - } - - # node attribute marking which section field belongs to - section_key = '' - # template for index, it is passed a field name as argument - # used by default deg_index_entry method - indextemplate = '' - - def get_meta(self): - ''' - Collect meta data for fields - - Reads optional arguments passed to directive and also - tries to find current section title and adds it as section - ''' - env = self.state.document.settings.env - # find title of current section, will group references page by it - num = env.domaindata['cabal']['index-num'].get(env.docname, 0) - env.domaindata['cabal']['index-num'][env.docname] = num + 1 - - title = find_section_title(self.state.parent) - return Meta(since=self.options.get('since'), - deprecated=self.options.get('deprecated'), - removed=self.options.get('removed'), - title=title, - index = num, - synopsis=self.options.get('synopsis')) - - def get_env_key(self, env, name): - ''' - Should return a key used to reference this field and key in domain - data to store this object - ''' - section = self.env.ref_context.get(self.section_key) - store = CabalDomain.types[self.objtype] - return (section, name), store - - def get_index_entry(self, env, name): - ''' - Should return index entry and anchor - - By default uses indextemplate attribute to generate name and - index entry by joining directive name, section and field name - ''' - section = self.env.ref_context.get(self.section_key) - - if section is not None: - parts = (self.objtype, section, name) - indexentry = self.indextemplate % (section + ':' + name) - else: - parts = (self.objtype, name) - indexentry = self.indextemplate % name - - targetname = '-'.join(parts) - return indexentry, targetname - - - def add_target_and_index(self, name, sig, signode): - ''' - As in sphinx.directive.ObjectDescription - - By default adds 'pair' index as returned by get_index_entry and - stores object data into domain data store as returned by get_env_data - ''' - env = self.state.document.settings.env - - indexentry, targetname = self.get_index_entry(self, name) - - signode['ids'].append(targetname) - self.state.document.note_explicit_target(signode) - - inode = addnodes.index( - entries=[('pair', indexentry, targetname, '', None)]) - signode.insert(0, inode) - - key, store = self.get_env_key(env, name) - env.domaindata['cabal'][store][key] = env.docname, targetname, self.cabal_meta - - def run(self): - self.cabal_meta = self.get_meta() - result = super(CabalObject, self).run() - - if self.cabal_meta.since is not None \ - or self.cabal_meta.deprecated is not None: - - #find content part of description - for item in result: - if isinstance(item, addnodes.desc): - desc = item - break - else: - return result - - for item in desc: - if isinstance(item, addnodes.desc_content): - contents = item - break - else: - return result - - # find exsting field list and add to it - # or create new one - for item in contents: - if isinstance(item, nodes.field_list): - field_list = item - break - else: - field_list = nodes.field_list('') - contents.insert(0, field_list) - - - if self.cabal_meta.since is not None: - #docutils horror - field = nodes.field('') - field_name = nodes.field_name('Since', 'Since') - since = 'Cabal ' + str(self.cabal_meta.since) - field_body = nodes.field_body(since, nodes.paragraph(since, since)) - field += field_name - field += field_body - field_list.insert(0, field) - - if self.cabal_meta.deprecated is not None: - field = nodes.field('') - field_name = nodes.field_name('Deprecated', 'Deprecated') - if isinstance(self.cabal_meta.deprecated, StrictVersion): - since = 'Cabal ' + str(self.cabal_meta.deprecated) - else: - since = '' - - field_body = nodes.field_body(since, nodes.paragraph(since, since)) - field += field_name - field += field_body - field_list.insert(0, field) - - if self.cabal_meta.removed is not None: - field = nodes.field('') - field_name = nodes.field_name('Removed', 'Removed') - if isinstance(self.cabal_meta.removed, StrictVersion): - since = 'Cabal ' + str(self.cabal_meta.removed) - else: - since = '' - - field_body = nodes.field_body(since, nodes.paragraph(since, since)) - field += field_name - field += field_body - field_list.insert(0, field) - return result - -class CabalPackageSection(CabalObject): - """ - Cabal section in package.cabal file - """ - section_key = 'cabal:pkg-section' - indextemplate = '%s; package.cabal section' - - def handle_signature(self, sig, signode): - ''' - As in sphinx.directives.ObjectDescription - - By default make an object description from name and adding - either deprecated or since as annotation. - ''' - env = self.state.document.settings.env - - sig = sig.strip() - parts = sig.split(' ',1) - name = parts[0] - signode += addnodes.desc_name(name, name) - signode += addnodes.desc_addname(' ', ' ') - if len(parts) > 1: - rest = parts[1].strip() - signode += addnodes.desc_annotation(rest, rest) - - return name - - def get_env_key(self, env, name): - store = CabalDomain.types[self.objtype] - return name, store - - def run(self): - env = self.state.document.settings.env - section = self.arguments[0].strip().split(' ',1)[0] - if section == 'None': - env.ref_context.pop('cabal:pkg-section', None) - return [] - env.ref_context['cabal:pkg-section'] = section - return super(CabalPackageSection, self).run() - - -class CabalField(CabalObject): - ''' - Base for fields in *.cabal files - ''' - option_spec = { - 'noindex' : directives.flag, - 'deprecated': parse_deprecated, - 'removed' : StrictVersion, - 'since' : StrictVersion, - 'synopsis' : lambda x:x - } - - doc_field_types = [ - Field('default', label='Default value', names=['default'], has_arg=False) - ] - - def handle_signature(self, sig, signode): - ''' - As in sphinx.directives.ObjectDescription - - By default make an object description from name and adding - either deprecated or since as annotation. - ''' - env = self.state.document.settings.env - - sig = sig.strip() - parts = sig.split(':',1) - name = parts[0] - signode += addnodes.desc_name(name, name) - signode += addnodes.desc_addname(': ', ': ') - - if len(parts) > 1: - rest = parts[1].strip() - signode += addnodes.desc_annotation(rest, rest) - - return name - -class CabalPackageField(CabalField): - ''' - Describes section in package.cabal file - ''' - section_key = 'cabal:pkg-section' - indextemplate = '%s; package.cabal field' - -class CabalFieldXRef(XRefRole): - ''' - Cross ref node for all kinds of fields - - Gets section_key entry from context and stores it on node, so it can - later be used by CabalDomain.resolve_xref to find target for reference to - this - ''' - section_key = 'cabal:pkg-section' - def process_link(self, env, refnode, has_explicit_title, title, target): - parts = target.split(':',1) - if len(parts) == 2: - section, target = parts - section = section.strip() - target = target.strip() - refnode[self.section_key] = section - else: - refnode[self.section_key] = env.ref_context.get(self.section_key) - - return title, target - -# -# Directives for config files. -# - -class CabalPackageFieldXRef(CabalFieldXRef): - ''' - Role referencing cabal.project section - ''' - section_key = 'cabal:pkg-section' - -class CabalConfigSection(CabalSection): - """ - Marks section in package.cabal file - """ - indextemplate = '%s; cabal.project section' - section_key = 'cabal:cfg-section' - target_prefix = 'cfg-section-' - -class ConfigField(CabalField): - section_key = 'cabal:cfg-section' - indextemplate = '%s ; cabal project option' - def handle_signature(self, sig, signode): - sig = sig.strip() - if sig.startswith('-'): - name = parse_flag(self, sig, signode) - else: - name = super(ConfigField, self).handle_signature(sig, signode) - - return name - - def get_index_entry(self, env, name): - if name.startswith('-'): - section = self.env.ref_context.get(self.section_key) - if section is not None: - parts = ('cfg-flag', section, name) - indexname = section + ':' + name - else: - parts = ('cfg-flag', name) - indexname = name - indexentry = name + '; cabal project option' - targetname = '-'.join(parts) - return indexentry, targetname - else: - return super(ConfigField,self).get_index_entry(env, name) - - def get_env_key(self, env, name): - section = self.env.ref_context.get(self.section_key) - if name.startswith('-'): - return (section, name), 'cfg-flags' - return (section, name), 'cfg-fields' - -class CabalConfigFieldXRef(CabalFieldXRef): - section_key = 'cabal:cfg-section' - - -# -# Cabal domain -# - -class ConfigFieldIndex(Index): - name = 'projectindex' - localname = "Cabal reference" - shortname = "Reference" - - class Entry(object): - def __init__(self, typ, name, doc, anchor, meta): - self.type = typ - self.name = name - self.doc = doc - self.anchor = anchor - self.meta = meta - - def _gather_data(self, obj_types): - ''' - Gather objects and return [(title, [Entry])] - ''' - def massage(typ, datum): - name, (doc, anchor, meta) = datum - return self.Entry(typ, name, doc, anchor, meta) - - fields = [] - for typ in obj_types: - store = CabalDomain.types[typ] - fields += [massage(typ, x) - for x in self.domain.data[store].items()] - - fields.sort(key=lambda x: (x.doc, x.meta.index)) - - if len(fields) == 0: - return [] - - result = [] - current = [] - current_title = fields[0].meta.title - for field in fields: - if field.meta.title != current_title: - result.append((current_title, current)) - current = [] - current_title = field.meta.title - current.append(field) - result.append((current_title, current)) - - return result - - - def generate(self, docnames=None): - ''' - Try to group entries such that if entry has a section then put it - into same group. - - Otherwise group it under same `title`. - - Try to keep in same order as it was defined. - - sort by (document, index) - group on (document, doc_section) - - TODO: Check how to extract section numbers from (document,doc_section) - and add it as annotation to titles - ''' - - # (title, section store, fields store) - entries = [('cabal.project fields', 'cfg-section', 'cfg-field'), - ('cabal project flags', 'cfg-section', 'cfg-flag'), - ('package.cabal fields', 'pkg-section', 'pkg-field')] - - result = [] - for label, section_key, key in entries: - - data = self._gather_data([section_key, key]) - - references = [] - for section, entries in data: - if section is None: - elem_type = 0 # Normal entry - else: - elem_type = 2 # sub_entry - - assert len(entries) != 0 - docname = entries[0].doc - if section is not None: - section_title, section_anchor = section - references.append( - (section_title, 1, docname, section_anchor, '', '', '')) - - for entry in entries: - #todo deal with if - if isinstance(entry.name, tuple): - name = entry.name[1] - else: - name = entry.name - - meta = entry.meta - extra = render_meta(meta) - descr = meta.synopsis if meta.synopsis is not None else '' - field = (name, elem_type, docname, - entry.anchor, extra, '', descr) - references.append(field) - result.append((label, references)) - - return result, False - -def make_data_keys(typ, target, node): - ''' - Returns a list of keys to search for targets of this type - in domain data. - - Used for resolving references - ''' - if typ == 'pkg-field': - section = node.get('cabal:pkg-section') - return [(section, target), - (None, target)] - elif typ in ('cfg-field', 'cfg-flag'): - section = node.get('cabal:cfg-section') - return [(section, target), (None, target)] - else: - return [target] - - -def render_deprecated(deprecated): - if isinstance(deprecated, StrictVersion): - return 'deprecated since: '+str(deprecated) - else: - return 'deprecated' - -def render_removed(deprecated, removed): - if isinstance(deprecated, StrictVersion): - return 'removed in: ' + str(removed) + '; deprecated since: '+str(deprecated) - else: - return 'removed in: ' + str(removed) - -def render_meta(meta): - ''' - Render meta as short text - - Will render either deprecated or since info - ''' - if meta.removed is not None: - return render_removed(meta.deprecated, meta.removed) - if meta.deprecated is not None: - return render_deprecated(meta.deprecated) - elif meta.since is not None: - return 'since version: ' + str(meta.since) - else: - return '' - -def render_meta_title(meta): - ''' - Render meta as suitable to use in titles - ''' - rendered = render_meta(meta) - if rendered != '': - return '(' + rendered + ')' - return '' - -def make_title(typ, key, meta): - ''' - Render title of an object (section, field or flag) - ''' - if typ == 'pkg-section': - return "package.cabal " + key + " section " + render_meta_title(meta) - - elif typ == 'pkg-field': - section, name = key - if section is not None: - base = "package.cabal " + section + " section " + name + ": field" - else: - base = "package.cabal " + name + " field" - - return base + render_meta_title(meta) - - elif typ == 'cfg-section': - return "cabal.project " + key + " section " + render_meta_title(meta) - - elif typ == 'cfg-field': - section, name = key - return "cabal.project " + name + " field " + render_meta_title(meta) - - elif typ == 'cfg-flag': - section, name = key - return "cabal flag " + name + " " + render_meta_title(meta) - - else: - raise ValueError("Unknown type: " + typ) - -def make_full_name(typ, key, meta): - ''' - Return an anchor name for object type - ''' - if typ == 'pkg-section': - return 'pkg-section-' + key - - elif typ == 'pkg-field': - section, name = key - if section is not None: - return '-'.join(('pkg-field',section, name)) - else: - return 'pkg-field-' + name - - elif typ == 'cfg-field': - return 'cfg-field-' + key - - else: - raise ValueError('Unknown object type: ' + typ) - -class CabalDomain(Domain): - ''' - Sphinx domain for cabal - - needs Domain.merge_doc for parallel building, just union all dicts - ''' - name = 'cabal' - label = 'Cabal' - object_types = { - 'pkg-section': ObjType(_('pkg-section'), 'pkg-section'), - 'pkg-field' : ObjType(_('pkg-field') , 'pkg-field' ), - 'cfg-section': ObjType(_('cfg-section'), 'cfg-section'), - 'cfg-field' : ObjType(_('cfg-field') , 'cfg-field' ), - } - directives = { - 'pkg-section': CabalPackageSection, - 'pkg-field' : CabalPackageField, - 'cfg-section': CabalConfigSection, - 'cfg-field' : ConfigField, - } - roles = { - 'pkg-section': XRefRole(warn_dangling=True), - 'pkg-field' : CabalPackageFieldXRef(warn_dangling=True), - 'cfg-section': XRefRole(warn_dangling=True), - 'cfg-field' : CabalConfigFieldXRef(warn_dangling=True), - 'cfg-flag' : CabalConfigFieldXRef(warn_dangling=True), - } - initial_data = { - 'pkg-sections': {}, - 'pkg-fields' : {}, - 'cfg-sections': {}, - 'index-num' : {}, #per document number of objects - # used to order references page - 'cfg-fields' : {}, - 'cfg-flags' : {}, - } - indices = [ - ConfigFieldIndex - ] - types = { - 'pkg-section': 'pkg-sections', - 'pkg-field' : 'pkg-fields', - 'cfg-section': 'cfg-sections', - 'cfg-field' : 'cfg-fields', - 'cfg-flag' : 'cfg-flags', - } - def clear_doc(self, docname): - for k in ['pkg-sections', 'pkg-fields', 'cfg-sections', - 'cfg-fields', 'cfg-flags']: - to_del = [] - for name, (fn, _, _) in self.data[k].items(): - if fn == docname: - to_del.append(name) - for name in to_del: - del self.data[k][name] - try: - del self.data['index-num'][docname] - except KeyError: - pass - - def resolve_xref(self, env, fromdocname, builder, type, target, node, contnode): - objtypes = self.objtypes_for_role(type) - for typ, key in ((typ, key) - for typ in objtypes - for key in make_data_keys(typ, target, node)): - try: - data = env.domaindata['cabal'][self.types[typ]][key] - except KeyError: - continue - doc, ref, meta = data - title = make_title(typ, key, meta) - return make_refnode(builder, fromdocname, doc, ref, contnode, title) - - def get_objects(self): - ''' - Used for search functionality - ''' - for typ in ['pkg-section', 'pkg-field', - 'cfg-section', 'cfg-field', 'cfg-flag']: - key = self.types[typ] - for name, (fn, target, meta) in self.data[key].items(): - title = make_title(typ, name, meta) - yield title, title, typ, fn, target, 0 - -class CabalLexer(lexer.RegexLexer): - ''' - Basic cabal lexer, does not try to be smart - ''' - name = 'Cabal' - aliases = ['cabal'] - filenames = ['.cabal'] - flags = re.MULTILINE - - tokens = { - 'root' : [ - (r'^(\s*)(--.*)$', lexer.bygroups(token.Whitespace, token.Comment.Single)), - # key: value - (r'^(\s*)([\w\-_]+)(:)', - lexer.bygroups(token.Whitespace, token.Keyword, token.Punctuation)), - (r'^([\w\-_]+)', token.Keyword), # library, executable, flag etc. - (r'[^\S\n]+', token.Text), - (r'&&|\|\||==|<=|\^>=|>=|<|>', token.Operator), - (r',|:|{|}', token.Punctuation), - (r'.', token.Text) - ], - } - -def setup(app): - app.add_domain(CabalDomain) - app.add_lexer('cabal', CabalLexer) - diff --git a/cabal/Cabal/doc/concepts-and-development.rst b/cabal/Cabal/doc/concepts-and-development.rst deleted file mode 100644 --- a/cabal/Cabal/doc/concepts-and-development.rst +++ /dev/null @@ -1,7 +0,0 @@ -Package Concepts and Development -================================ - -.. toctree:: - :maxdepth: 2 - - developing-packages diff --git a/cabal/Cabal/doc/conf.py b/cabal/Cabal/doc/conf.py deleted file mode 100644 --- a/cabal/Cabal/doc/conf.py +++ /dev/null @@ -1,223 +0,0 @@ -# -*- coding: utf-8 -*- -# -# GHC Users Guide documentation build configuration file -# -# This file is execfile()d with the current directory set to its -# containing dir. -# -import sys -import os -import sphinx_rtd_theme - -# Support for :base-ref:, etc. -sys.path.insert(0, os.path.abspath('.')) -import cabaldomain - -version = "3.3.0.0" - -extensions = ['sphinx.ext.extlinks', 'sphinx.ext.todo'] - -templates_path = ['_templates'] -source_suffix = '.rst' -source_encoding = 'utf-8-sig' -master_doc = 'index' - -# extlinks -- see http://www.sphinx-doc.org/en/stable/ext/extlinks.html -extlinks = { - 'issue': ('https://github.com/haskell/cabal/issues/%s', '#'), - - 'ghc-wiki': ('https://gitlab.haskell.org/ghc/ghc/-/wikis/%s', ''), - 'ghc-ticket': ('https://gitlab.haskell.org/ghc/ghc/-/issues/%s', 'GHC #'), - - 'hackage-pkg': ('http://hackage.haskell.org/package/%s', ''), -} - -# General information about the project. -project = u'Cabal' -copyright = u'2003-2020, Cabal Team' -# N.B. version comes from ghc_config -release = version # The full version, including alpha/beta/rc tags. - -# Syntax highlighting -highlight_language = 'cabal' -#pygments_style = 'tango' - -primary_domain = 'cabal' - -# List of patterns, relative to source directory, that match files and -# directories to ignore when looking for source files. -exclude_patterns = ['.build', "*.gen.rst"] - -# -- Options for HTML output --------------------------------------------- - -# on_rtd is whether we are on readthedocs.org, this line of code grabbed from docs.readthedocs.org -on_rtd = os.environ.get('READTHEDOCS', None) == 'True' - -if not on_rtd: # only import and set the theme if we're building docs locally - import sphinx_rtd_theme - html_theme = 'sphinx_rtd_theme' - html_theme_path = [sphinx_rtd_theme.get_html_theme_path()] - -# The name for this set of Sphinx documents. If None, it defaults to -# " v documentation". -html_title = "Cabal {} User's Guide".format(release) -html_short_title = "Cabal %s User's Guide" % release -html_logo = 'images/Cabal-dark.png' -html_static_path = ['images'] -# Convert quotes and dashes to typographically correct entities -html_use_smartypants = True -html_show_copyright = True -html_context = { - 'source_url_prefix': "https://github.com/haskell/cabal/tree/master/Cabal/doc/", - "display_github": True, - "github_host": "github.com", - "github_user": "haskell", - "github_repo": 'cabal', - "github_version": "master/", - "conf_py_path": "Cabal/doc/", - "source_suffix": '.rst', -} - - -# If true, an OpenSearch description file will be output, and all pages will -# contain a tag referring to it. The value of this option must be the -# base URL from which the finished HTML is served. -#html_use_opensearch = '' - -# This is the file name suffix for HTML files (e.g. ".xhtml"). -#html_file_suffix = None - -# Output file base name for HTML help builder. -htmlhelp_basename = 'CabalUsersGuide' - -# MathJax to use SVG rendering by default -mathjax_path = 'https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.5/latest.js?config=TeX-AMS-MML_SVG' - - -# -- Options for LaTeX output --------------------------------------------- - -latex_elements = { - 'inputenc': '', - 'utf8extra': '', - 'preamble': r''' -\usepackage{fontspec} -\usepackage{makeidx} -\setsansfont{DejaVu Sans} -\setromanfont{DejaVu Serif} -\setmonofont{DejaVu Sans Mono} -''', -} - -# Grouping the document tree into LaTeX files. List of tuples -# (source start file, target name, title, -# author, documentclass [howto, manual, or own class]). -latex_documents = [ - ('index', 'users_guide.tex', u'GHC Users Guide Documentation', - u'GHC Team', 'manual'), -] - -# The name of an image file (relative to this directory) to place at the top of -# the title page. -#latex_logo = 'images/logo.pdf' -latex_logo = 'images/Cabal-dark.png' - -# If true, show page references after internal links. -latex_show_pagerefs = True - -# http://www.sphinx-doc.org/en/master/usage/extensions/todo.html -todo_include_todos = True - -# -- Options for manual page output --------------------------------------- - -# One entry per manual page. List of tuples -# (source start file, name, description, authors, manual section). -man_pages = [ - ('cabal', 'cabal', 'The Haskell Cabal', 'The Cabal Team', 1) -] - -# If true, show URL addresses after external links. -#man_show_urls = False - - -# -- Options for Texinfo output ------------------------------------------- - -# Grouping the document tree into Texinfo files. List of tuples -# (source start file, target name, title, author, -# dir menu entry, description, category) -texinfo_documents = [ - ('index', 'CabalUsersGuide', u'Cabal Users Guide', - u'Cabal Team', 'CabalUsersGuide', 'The Haskell Cabal.', - 'Compilers'), -] - -from sphinx import addnodes -from docutils import nodes - -def parse_ghci_cmd(env, sig, signode): - name = sig.split(';')[0] - sig = sig.replace(';', '') - signode += addnodes.desc_name(name, sig) - return name - -def parse_flag(env, sig, signode): - import re - names = [] - for i, flag in enumerate(sig.split(',')): - flag = flag.strip() - sep = '=' - parts = flag.split('=') - if len(parts) == 1: - sep=' ' - parts = flag.split() - if len(parts) == 0: continue - - name = parts[0] - names.append(name) - sig = sep + ' '.join(parts[1:]) - sig = re.sub(r'<([-a-zA-Z ]+)>', r'⟨\1⟩', sig) - if i > 0: - signode += addnodes.desc_name(', ', ', ') - signode += addnodes.desc_name(name, name) - if len(sig) > 0: - signode += addnodes.desc_addname(sig, sig) - - return names[0] - -def setup(app): - from sphinx.util.docfields import Field, TypedField - - increase_python_stack() - - # the :ghci-cmd: directive used in ghci.rst - app.add_object_type('ghci-cmd', 'ghci-cmd', - parse_node=parse_ghci_cmd, - objname='GHCi command', - indextemplate='pair: %s; GHCi command') - - app.add_object_type('ghc-flag', 'ghc-flag', - objname='GHC command-line option', - parse_node=parse_flag, - indextemplate='pair: %s; GHC option', - doc_field_types=[ - Field('since', label='Introduced in GHC version', names=['since']), - Field('default', label='Default value', names=['default']), - Field('static') - ]) - - app.add_object_type('rts-flag', 'rts-flag', - objname='runtime system command-line option', - parse_node=parse_flag, - indextemplate='pair: %s; RTS option', - doc_field_types=[ - Field('since', label='Introduced in GHC version', names=['since']), - ]) - - cabaldomain.setup(app) - -def increase_python_stack(): - # Workaround sphinx-build recursion limit overflow: - # pickle.dump(doctree, f, pickle.HIGHEST_PROTOCOL) - # RuntimeError: maximum recursion depth exceeded while pickling an object - # - # Default python allows recursion depth of 1000 calls. - sys.setrecursionlimit(10000) diff --git a/cabal/Cabal/doc/config-and-install.rst b/cabal/Cabal/doc/config-and-install.rst deleted file mode 100644 --- a/cabal/Cabal/doc/config-and-install.rst +++ /dev/null @@ -1,5 +0,0 @@ -Configuration and Installing Packages -===================================== - -.. toctree:: - installing-packages diff --git a/cabal/Cabal/doc/developing-packages.rst b/cabal/Cabal/doc/developing-packages.rst deleted file mode 100644 --- a/cabal/Cabal/doc/developing-packages.rst +++ /dev/null @@ -1,488 +0,0 @@ -Quickstart -========== - -.. TIP:: - If this is your first time using `cabal` you should check out the `Getting Started guide `__. - -Let's assume we have created a project directory and already have a -Haskell module or two. - -Every project needs a name, we'll call this example "proglet". - -.. highlight:: console - -:: - - $ cd proglet/ - $ ls - Proglet.hs - -It is assumed that (apart from external dependencies) all the files that -make up a package live under a common project root directory. This -simple example has all the project files in one directory, but most -packages will use one or more subdirectories. - -To turn this into a Cabal package we need two extra files in the -project's root directory: - -- ``proglet.cabal``: containing package metadata and build information. - -- ``Setup.hs``: usually containing a few standardized lines of code, - but can be customized if necessary. - -We can create both files manually or we can use ``cabal init`` to create -them for us. - -Using "cabal init" ------------------- - -The ``cabal init --interactive`` command is interactive. If we answer -"no" to using the "sensible defaults" it asks a number of questions. - -:: - - $ cabal init --interactive - Should I generate a simple project with sensible defaults? [default: y] n - What does the package build: - 1) Executable - 2) Library - 3) Library and Executable - Your choice? - ... - -One of the important questions is whether the package contains a library -and/or an executable. Libraries are collections of Haskell modules that -can be re-used by other Haskell libraries and programs, while executables -are standalone programs. - -For the moment these are the only choices. For more complex packages -(e.g. a library and multiple executables or test suites) the ``.cabal`` -file can be edited afterwards. - -After you make your selection (executable; library; or: library -and executable) cabal asks us a number of questions starting with -which version of the cabal specification to use, our package's name -(for example, "proglet"), and our package's version. - -It also asks questions about various other bits of package metadata. For -a package that you never intend to distribute to others, these fields -can be left blank. - -Finally, ``cabal init --interactive`` creates the initial ``proglet.cabal`` -and ``Setup.hs`` files, and depending on your choice of license, a -``LICENSE`` file as well. - -:: - - Generating LICENSE... - Generating Setup.hs... - Generating proglet.cabal... - - You may want to edit the .cabal file and add a Description field. - -At this stage the ``proglet.cabal`` is not quite complete and before you -are able to build the package you will need to edit the file and add -some build information about the library or executable. - -Editing the .cabal file ------------------------ - -.. highlight:: cabal - -Load up the ``.cabal`` file in a text editor. The first part of the -``.cabal`` file has the package metadata and towards the end of the file -you will find the :pkg-section:`executable` or :pkg-section:`library` section. - -You will see that the fields that have yet to be filled in are commented -out. Cabal files use "``--``" Haskell-style comment syntax. (Note that -comments are only allowed on lines on their own. Trailing comments on -other lines are not allowed because they could be confused with program -options.) - -If you selected earlier to create a library package then your ``.cabal`` -file will have a section that looks like this: - -:: - - library - exposed-modules: Proglet - -- other-modules: - -- build-depends: - -Alternatively, if you selected an executable then there will be a -section like: - -:: - - executable proglet - -- main-is: - -- other-modules: - -- build-depends: - -The build information fields listed (but commented out) are just the few -most important and common fields. There are many others that are covered -later in this chapter. - -Most of the build information fields are the same between libraries and -executables. The difference is that libraries have a number of "exposed" -modules that make up the public interface of the library, while -executables have a file containing a ``Main`` module. - -The name of a library always matches the name of the package, so it is -not specified in the library section. Executables often follow the name -of the package too, but this is not required and the name is given -explicitly. - -Modules included in the package -------------------------------- - -For a library, ``cabal init`` looks in the project directory for files -that look like Haskell modules and adds all the modules to the -:pkg-field:`library:exposed-modules` field. For modules that do not form part -of your package's public interface, you can move those modules to the -:pkg-field:`other-modules` field. Either way, all modules in the library need -to be listed. - -For an executable, ``cabal init`` does not try to guess which file -contains your program's ``Main`` module. You will need to fill in the -:pkg-field:`executable:main-is` field with the file name of your program's -``Main`` module (including ``.hs`` or ``.lhs`` extension). Other modules -included in the executable should be listed in the :pkg-field:`other-modules` -field. - -Modules imported from other packages ------------------------------------- - -While your library or executable may include a number of modules, it -almost certainly also imports a number of external modules from the -standard libraries or other pre-packaged libraries. (These other -libraries are of course just Cabal packages that contain a library.) - -You have to list all of the library packages that your library or -executable imports modules from. Or to put it another way: you have to -list all the other packages that your package depends on. - -For example, suppose the example ``Proglet`` module imports the module -``Data.Map``. The ``Data.Map`` module comes from the ``containers`` -package, so we must list it: - -:: - - library - exposed-modules: Proglet - other-modules: - build-depends: containers, base == 4.* - -In addition, almost every package also depends on the ``base`` library -package because it exports the standard ``Prelude`` module plus other -basic modules like ``Data.List``. - -You will notice that we have listed ``base == 4.*``. This gives a -constraint on the version of the base package that our package will work -with. The most common kinds of constraints are: - -- ``pkgname >= n`` -- ``pkgname ^>= n`` (since Cabal 2.0) -- ``pkgname >= n && < m`` -- ``pkgname == n.*`` (since Cabal 1.6) - -The last is just shorthand, for example ``base == 4.*`` means exactly -the same thing as ``base >= 4 && < 5``. Please refer to the documentation -on the :pkg-field:`build-depends` field for more information. - -Also, you can factor out shared ``build-depends`` (and other fields such -as ``ghc-options``) into a ``common`` stanza which you can ``import`` in -your libraries and executable sections. For example: - -:: - - common shared-properties - default-language: Haskell2010 - build-depends: - base == 4.* - ghc-options: - -Wall - - library - import: shared-properties - exposed-modules: - Proglet - -Note that the ``import`` **must** be the first thing in the stanza. For more -information see the :ref:`common-stanzas` section. - -Building the package --------------------- - -For simple packages that's it! We can now try configuring and building -the package: - -.. code-block:: console - - $ cabal configure - $ cabal build - -Assuming those two steps worked then you can also install the package: - -.. code-block:: console - - $ cabal install - -For libraries this makes them available for use in GHCi or to be used by -other packages. For executables it installs the program so that you can -run it (though you may first need to adjust your system's ``$PATH``). - -Next steps ----------- - -What we have covered so far should be enough for very simple packages -that you use on your own system. - -The next few sections cover more details needed for more complex -packages and details needed for distributing packages to other people. - -The previous chapter covers building and installing packages -- your own -packages or ones developed by other people. - -Package concepts -================ - -Before diving into the details of writing packages it helps to -understand a bit about packages in the Haskell world and the particular -approach that Cabal takes. - -The point of packages ---------------------- - -Packages are a mechanism for organising and distributing code. Packages -are particularly suited for "programming in the large", that is building -big systems by using and re-using code written by different people at -different times. - -People organise code into packages based on functionality and -dependencies. Social factors are also important: most packages have a -single author, or a relatively small team of authors. - -Packages are also used for distribution: the idea is that a package can -be created in one place and be moved to a different computer and be -usable in that different environment. There are a surprising number of -details that have to be got right for this to work, and a good package -system helps to simplify this process and make it reliable. - -Packages come in two main flavours: libraries of reusable code, and -complete programs. Libraries present a code interface, an API, while -programs can be run directly. In the Haskell world, library packages -expose a set of Haskell modules as their public interface. Cabal -packages can contain a library or executables or both. - -Some programming languages have packages as a builtin language concept. -For example in Java, a package provides a local namespace for types and -other definitions. In the Haskell world, packages are not a part of the -language itself. Haskell programs consist of a number of modules, and -packages just provide a way to partition the modules into sets of -related functionality. Thus the choice of module names in Haskell is -still important, even when using packages. - -Package names and versions --------------------------- - -All packages have a name, e.g. "HUnit". Package names are assumed to be -unique. Cabal package names may contain letters, numbers and hyphens, -but not spaces and may also not contain a hyphened section consisting of -only numbers. The namespace for Cabal packages is flat, not -hierarchical. - -Packages also have a version, e.g "1.1". This matches the typical way in -which packages are developed. Strictly speaking, each version of a -package is independent, but usually they are very similar. Cabal package -versions follow the conventional numeric style, consisting of a sequence -of digits such as "1.0.1" or "2.0". There are a range of common -conventions for "versioning" packages, that is giving some meaning to -the version number in terms of changes in the package, such as -e.g. `SemVer `__; however, for packages intended to be -distributed via Hackage Haskell's `Package Versioning Policy `_ applies -(see also the `PVP/SemVer FAQ section `__). - -The combination of package name and version is called the *package ID* -and is written with a hyphen to separate the name and version, e.g. -"HUnit-1.1". - -For Cabal packages, the combination of the package name and version -*uniquely* identifies each package. Or to put it another way: two -packages with the same name and version are considered to *be* the same. - -Strictly speaking, the package ID only identifies each Cabal *source* -package; the same Cabal source package can be configured and built in -different ways. There is a separate installed package ID that uniquely -identifies each installed package instance. Most of the time however, -users need not be aware of this detail. - -Kinds of package: Cabal vs GHC vs system ----------------------------------------- - -It can be slightly confusing at first because there are various -different notions of package floating around. Fortunately the details -are not very complicated. - -Cabal packages - Cabal packages are really source packages. That is they contain - Haskell (and sometimes C) source code. - - Cabal packages can be compiled to produce GHC packages. They can - also be translated into operating system packages. - -GHC packages - This is GHC's view on packages. GHC only cares about library - packages, not executables. Library packages have to be registered - with GHC for them to be available in GHCi or to be used when - compiling other programs or packages. - - The low-level tool ``ghc-pkg`` is used to register GHC packages and - to get information on what packages are currently registered. - - You never need to make GHC packages manually. When you build and - install a Cabal package containing a library then it gets registered - with GHC automatically. - - Haskell implementations other than GHC have essentially the same - concept of registered packages. For the most part, Cabal hides the - slight differences. - -Operating system packages - On operating systems like Linux and Mac OS X, the system has a - specific notion of a package and there are tools for installing and - managing packages. - - The Cabal package format is designed to allow Cabal packages to be - translated, mostly-automatically, into operating system packages. - They are usually translated 1:1, that is a single Cabal package - becomes a single system package. - - It is also possible to make Windows installers from Cabal packages, - though this is typically done for a program together with all of its - library dependencies, rather than packaging each library separately. - -Unit of distribution --------------------- - -The Cabal package is the unit of distribution. What this means is that -each Cabal package can be distributed on its own in source or binary -form. Of course there may be dependencies between packages, but there is -usually a degree of flexibility in which versions of packages can work -together so distributing them independently makes sense. - -It is perhaps easiest to see what being "the unit of distribution" -means by contrast to an alternative approach. Many projects are made up -of several interdependent packages and during development these might -all be kept under one common directory tree and be built and tested -together. When it comes to distribution however, rather than -distributing them all together in a single tarball, it is required that -they each be distributed independently in their own tarballs. - -Cabal's approach is to say that if you can specify a dependency on a -package then that package should be able to be distributed -independently. Or to put it the other way round, if you want to -distribute it as a single unit, then it should be a single package. - -Explicit dependencies and automatic package management ------------------------------------------------------- - -Cabal takes the approach that all packages dependencies are specified -explicitly and specified in a declarative way. The point is to enable -automatic package management. This means tools like ``cabal`` can -resolve dependencies and install a package plus all of its dependencies -automatically. Alternatively, it is possible to mechanically (or mostly -mechanically) translate Cabal packages into system packages and let the -system package manager install dependencies automatically. - -It is important to track dependencies accurately so that packages can -reliably be moved from one system to another system and still be able to -build it there. Cabal is therefore relatively strict about specifying -dependencies. For example Cabal's default build system will not even let -code build if it tries to import a module from a package that isn't -listed in the ``.cabal`` file, even if that package is actually -installed. This helps to ensure that there are no "untracked -dependencies" that could cause the code to fail to build on some other -system. - -The explicit dependency approach is in contrast to the traditional -"./configure" approach where instead of specifying dependencies -declaratively, the ``./configure`` script checks if the dependencies are -present on the system. Some manual work is required to transform a -``./configure`` based package into a Linux distribution package (or -similar). This conversion work is usually done by people other than the -package author(s). The practical effect of this is that only the most -popular packages will benefit from automatic package management. -Instead, Cabal forces the original author to specify the dependencies -but the advantage is that every package can benefit from automatic -package management. - -The "./configure" approach tends to encourage packages that adapt -themselves to the environment in which they are built, for example by -disabling optional features so that they can continue to work when a -particular dependency is not available. This approach makes sense in a -world where installing additional dependencies is a tiresome manual -process and so minimising dependencies is important. The automatic -package management view is that packages should just declare what they -need and the package manager will take responsibility for ensuring that -all the dependencies are installed. - -Sometimes of course optional features and optional dependencies do make -sense. Cabal packages can have optional features and varying -dependencies. These conditional dependencies are still specified in a -declarative way however and remain compatible with automatic package -management. The need to remain compatible with automatic package -management means that Cabal's conditional dependencies system is a bit -less flexible than with the "./configure" approach. - -.. note:: - `GNU autoconf places restrictions on paths, including the - path that the user builds a package from. - `_ - Package authors using ``build-type: configure`` should be aware of - these restrictions; because users may be unexpectedly constrained and - face mysterious errors, it is recommended that ``build-type: configure`` - is only used where strictly necessary. - -Portability ------------ - -One of the purposes of Cabal is to make it easier to build packages on -different platforms (operating systems and CPU architectures), with -different compiler versions and indeed even with different Haskell -implementations. (Yes, there are Haskell implementations other than -GHC!) - -Cabal provides abstractions of features present in different Haskell -implementations and wherever possible it is best to take advantage of -these to increase portability. Where necessary however it is possible to -use specific features of specific implementations. - -For example a package author can list in the package's ``.cabal`` what -language extensions the code uses. This allows Cabal to figure out if -the language extension is supported by the Haskell implementation that -the user picks. Additionally, certain language extensions such as -Template Haskell require special handling from the build system and by -listing the extension it provides the build system with enough -information to do the right thing. - -Another similar example is linking with foreign libraries. Rather than -specifying GHC flags directly, the package author can list the libraries -that are needed and the build system will take care of using the right -flags for the compiler. Additionally this makes it easier for tools to -discover what system C libraries a package needs, which is useful for -tracking dependencies on system libraries (e.g. when translating into -Linux distribution packages). - -In fact both of these examples fall into the category of explicitly -specifying dependencies. Not all dependencies are other Cabal packages. -Foreign libraries are clearly another kind of dependency. It's also -possible to think of language extensions as dependencies: the package -depends on a Haskell implementation that supports all those extensions. - -Where compiler-specific options are needed however, there is an "escape -hatch" available. The developer can specify implementation-specific -options and more generally there is a configuration mechanism to -customise many aspects of how a package is built depending on the -Haskell implementation, the operating system, computer architecture and -user-specified configuration flags. diff --git a/cabal/Cabal/doc/file-format-changelog.rst b/cabal/Cabal/doc/file-format-changelog.rst deleted file mode 100644 --- a/cabal/Cabal/doc/file-format-changelog.rst +++ /dev/null @@ -1,236 +0,0 @@ -.. _spec-history: - -================================================== - Package Description Format Specification History -================================================== - -:ref:`pkg-desc` need to specify the version of the -specification they need to be interpreted in via the -:pkg-field:`cabal-version` declaration. The following list describes -changes that occurred in each version of the cabal specification -relative to the respective preceding *published* version. - -.. note:: - - The sequence of specification version numbers is *not* - contiguous because it's synchronised with the version of the - ``Cabal`` library. As a consequence, only *even* versions are - considered proper published versions of the specification as *odd* - versions of the ``Cabal`` library denote unreleased development - branches which have no stability guarantee. - -``cabal-version: 3.4`` ----------------------- - - -* License fields use identifiers from SPDX License List version - ``3.9 2020-05-15`` - -* Dependencies to sublibraries have to be specified explicitly, - even for current package. - This way you can have an internal library with the same - name as some external dependency. - -* Remove ``-any`` and ``-none`` syntax for version ranges - Use ``>=0`` and ``<0`` respectively. - -* :pkg-field:`default-language` is optional. - The Default value is to use the compiler's default language. - -* :pkg-field:`mixins` field allow specifying a sublibrary. - -``cabal-version: 3.0`` ----------------------- - -* Added the :pkg-field:`extra-dynamic-library-flavours` field to specify non-trivial - variants of dynamic flavours. It is :pkg-field:`extra-library-flavours` but for - shared libraries. Mainly useful for GHC's RTS library. - -* Free text fields (e.g. :pkg-field:`description`) preserve empty lines - and indentation. In other words, you don't need to add dots for blank lines. - -* License fields use identifiers from SPDX License List version - ``3.6 2019-07-10`` - -* Remove deprecated ``hs-source-dir``, :pkg-field:`extensions` and - :pkg-field:`build-tools` fields. - -* Common stanzas are now allowed also in the beginning of conditional - sections. In other words, the following is valid - - :: - - library - import deps - - if flag(foo) - import foo-deps - -* Allow redundant leading or trailing commas in package fields with - optional commas, such as :pkg-field:`library:exposed-modules` - -* Require fields with optional commas to consistently omit or place - commas between elements. - -* Changed the behavior of :pkg-field:`extra-bundled-libraries` field. The naming convention - of dynamic library files (e.g. generated by a custom build script) has - changed. For library names prefixed with "C", the dynamic library file - name(s) must be of the form `lib.*` - instead of the old `libC-ghc.` - -* New set-notation syntax for ``==`` and ``^>=`` operators, see - :pkg-field:`build-depends` field documentation for examples. - -* Allow more whitespace in :pkg-field:`mixins` field - -* Wildcards are disallowed in :pkg-field:`pkgconfig-depends`, - Yet the pkgconfig format is relaxed to accept e.g. versions like ``1.1.0h``. - -* New :pkg-field:`autogen-includes` for specifying :pkg-field:`install-includes` - which are autogenerated (e.g. by a ``configure`` script). - -* New :pkg-field:`asm-sources` and :pkg-field:`asm-options` fields - added for supporting bundled foreign routines implemented in - assembler. - -* New :pkg-field:`cmm-sources` and :pkg-field:`cmm-options` fields - added for supporting bundled foreign primops implemented in - C--. - -``cabal-version: 2.4`` ----------------------- - -* Wildcard matching has been expanded. All previous wildcard - expressions are still valid; some will match strictly more files - than before. Specifically: - - * Double-star (``**``) wildcards are now accepted for recursive - matching immediately before the final slash; they must be followed - by a filename wildcard (e.g., ``foo/**/*.html`` is valid; - ``foo/**/bar/*.html`` and ``foo/**/**/*.html``, - ``foo/**/bar.html`` are all invalid). As ``**`` was an error in - globs before, this does not affect any existing ``.cabal`` files - that previously worked. - - * Wildcards now match when the pattern's extensions form a suffix of - the candidate file's extension, rather than requiring strict - equality (e.g., previously ``*.html`` did not match - ``foo.en.html``, but now it does). - -* License fields use identifiers from SPDX License List version - ``3.2 2018-07-10`` - - -``cabal-version: 2.2`` ----------------------- - -* New :pkg-section:`common` stanzas and :pkg-field:`import` - pseudo-field added. - -* New :pkg-field:`library:virtual-modules` field added. - -* New :pkg-field:`cxx-sources` and :pkg-field:`cxx-options` fields - added for suppporting bundled foreign routines implemented in C++. - -* New :pkg-field:`extra-bundled-libraries` field for specifying - additional custom library objects to be installed. - -* Extended ``if`` control structure with support for ``elif`` keyword. - -* Changed default rules of :pkg-field:`build-type` field to infer - "build-type:" for "Simple"/"Custom" automatically. - -* :pkg-field:`license` field syntax changed to require SPDX - expression syntax (using SPDX license list version ``3.0 2017-12-28``). - -* Allow redundant leading or trailing commas in package fields (which - require commas) such as :pkg-field:`build-depends`. - - -``cabal-version: 2.0`` ----------------------- - -* New :pkg-field:`library:signatures` and :pkg-field:`mixins` fields - added for supporting Backpack_. - -* New :pkg-field:`build-tool-depends` field added for adding - build-time dependencies of executable components. - -* New :pkg-field:`custom-setup:autogen-modules` field added for declaring modules - which are generated at build time. - -* Support for new PVP_ caret-style version operator (``^>=``) added to - :pkg-field:`build-depends`. - -* Add support for new :pkg-section:`foreign-library` stanza. - -* Add support for :ref:`internal library stanzas `. - -* New CPP Macro ``CURRENT_PACKAGE_VERSION``. - -``cabal-version: 1.24`` ------------------------ - -* New :pkg-section:`custom-setup` stanza and - :pkg-field:`custom-setup:setup-depends` field added for specifying dependencies - of custom ``Setup.hs`` scripts. - -* CPP Macros ``VERSION_$pkgname`` and ``MIN_VERSION_$pkgname`` are now - also generated for the current package. - -* New CPP Macros ``CURRENT_COMPONENT_ID`` and ``CURRENT_PACKAGE_KEY``. - -* New :pkg-field:`extra-framework-dirs` field added for specifying - extra locations to find OS X frameworks. - -``cabal-version: 1.22`` ------------------------ - -* New :pkg-field:`library:reexported-modules` field. - -* Support for ``-none`` version constraint added to - :pkg-field:`build-depends`. - -* New :pkg-field:`license` type ``ISC`` added. - -``cabal-version: 1.20`` ------------------------ - -* Add support for new :pkg-field:`license-files` field for declaring - multiple license documents. - -* New CPP Macro ``MIN_TOOL_VERSION_$buildtool``. - -* New :pkg-field:`license` types ``BSD2`` and ``MPL-2.0`` added. - -``cabal-version: 1.18`` ------------------------ - -* Add support for new :pkg-field:`extra-doc-files` field for - specifying extra file assets referenced by the Haddock - documentation. - -* New :pkg-field:`license` type ``AGPL`` and ``AGPL-3`` added. - -* Add support for specifying a C/C++/obj-C source file in - :pkg-field:`executable:main-is` field. - -* Add ``getSysconfDir`` operation to ``Paths_`` API. - -``cabal-version: 1.16`` ------------------------ - -.. todo:: - - this needs to be researched; there were only few changes between - 1.12 and 1.18; - -``cabal-version: 1.12`` ------------------------ - -* Change syntax of :pkg-field:`cabal-version` to support the new recommended - ``cabal-version: x.y`` style - - - -.. include:: references.inc diff --git a/cabal/Cabal/doc/getting-started.rst b/cabal/Cabal/doc/getting-started.rst deleted file mode 100644 --- a/cabal/Cabal/doc/getting-started.rst +++ /dev/null @@ -1,169 +0,0 @@ -Getting Started with Haskell and Cabal -====================================== - -Installing the Haskell toolchain --------------------------------- - -To install the Haskell toolchain follow the `ghcup instructions -`__ if you're using Linux or Mac, or follow -`this guide `__ if you're -using Windows. - - -Creating a new application --------------------------- - -Let's start by creating a simple Haskell application from scratch where we'll -learn about a Haskell package's directory structure, how to run the executable, -and how to add external dependencies. - - -Initializing the application -^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - -Start by creating a ``myfirstapp`` directory to hold the project files, these -instructions work in unix shells and PowerShell (if you're on Windows). - -.. code-block:: console - - $ mkdir myfirstapp - $ cd myfirstapp - -Once you have an empty directory we can initialize our package: - -.. code-block:: console - - $ cabal init --cabal-version=2.4 --license=NONE -p myfirstapp - -This will generate the following files: - -.. code-block:: console - - $ ls - CHANGELOG.md - Main.hs - myfirstapp.cabal - Setup.hs - - -``Main.hs`` is where your package's code lives. By default ``cabal init`` -creates an executable with the same name as the package ``myfirstapp`` in this -case, you can instruct ``cabal init`` to generate just a library (with -``--lib``) or both a library and executable with (``--libandexe``); for the full -set of options see ``cabal init --help``. - -``myfirstapp.cabal`` is Cabal's metadata file which describes your package and -its dependencies. We'll be updating this file in a little bit when we add an -external dependency to our package. - - -Running the application -^^^^^^^^^^^^^^^^^^^^^^^ - -As mentioned above, ``cabal init`` with no arguments generates a package with a -single executable that prints ``"Hello, Haskell!"`` to the terminal. To run the -executable enter the following command: - -``cabal run :myfirstapp`` - -You should see the following output in the terminal: - -.. code-block:: console - - $ cabal run :myfirstapp - ... - Hello, Haskell! - -.. note:: The ``:`` prefix in ``:myfirstapp`` signifies that the - ``myfirstapp`` target is part of the current package. - -Notice that we didn't need to run a `build` command before ``cabal run``, this -is because ``cabal run`` first determines if the code needs to be re-built -before running the executable. If you just want to build a target you can do so -with ``cabal build``: - -``cabal build :myfirstapp`` - - -Adding dependencies -^^^^^^^^^^^^^^^^^^^ - -Next we'll add an external dependency to our application. `Hackage -`__ is the Haskell community's central `package` -archive of open source software. - -In our application, we'll use a package called `haskell-say -`__ to print text to the -terminal with some embellishment. - -.. TIP:: - If you installed ``cabal`` a while ago but haven't used it recently you may - need to update the package index, you can do this by running ``cabal - update``. - -In our ``myfirstapp.cabal`` file we'll update the ``build-depends`` attribute of -the ``executable myfirstapp`` section to include ``haskell-say``: - -.. code-block:: cabal - - executable myfirstapp - main-is: Main.hs - build-depends: - base >=4.11 && <4.12, - haskell-say ^>=1.0.0.0 - -.. NOTE:: - ``^>=1.0.0.0`` means use version 1.0.0.0 of the library or any more recent - minor release with the same major version. - -Next we'll update ``Main.hs`` to use the ``HaskellSay`` library: - -.. code-block:: haskell - - module Main where - - import HaskellSay (haskellSay) - - main :: IO () - main = - haskellSay "Hello, Haskell! You're using a function from another package!" - -``import HaskellSay (haskellSay)`` brings the ``haskellSay`` function from the -module named ``HaskellSay`` into scope. The ``HaskellSay`` module is defined in -the ``haskell-say`` packages that we added a dependency on above. - -Now you can build and re-run your code to see the new output: - -.. code-block:: console - - $ cabal run - ________________________________________________________ - / \ - | Hello, Haskell! You're using a function from another | - | package! | - \____ _____________________________________________/ - \ / - \ / - \/ - _____ _____ - \ \ \ \ - \ \ \ \ - \ \ \ \ - \ \ \ \ \-----------| - \ \ \ \ \ | - \ \ \ \ \---------| - / / / \ - / / / \ \-------| - / / / ^ \ \ | - / / / / \ \ \ ----| - / / / / \ \ - /____/ /____/ \____\ - - -What Next? ----------- - -Now that you know how to set up a simple Haskell package using Cabal, check out -some of thee resources on the Haskell website's `documentation page -`__ or read more about packages and -Cabal on the `introduction `__ page. diff --git a/cabal/Cabal/doc/hcar/.gitignore b/cabal/Cabal/doc/hcar/.gitignore deleted file mode 100644 --- a/cabal/Cabal/doc/hcar/.gitignore +++ /dev/null @@ -1,5 +0,0 @@ -*.out -*.aux -*.log -*.pdf -/auto diff --git a/cabal/Cabal/doc/hcar/Cabal-201604.tex b/cabal/Cabal/doc/hcar/Cabal-201604.tex deleted file mode 100644 --- a/cabal/Cabal/doc/hcar/Cabal-201604.tex +++ /dev/null @@ -1,118 +0,0 @@ -\documentclass[DIV16,twocolumn,10pt]{scrreprt} -\usepackage{paralist} -\usepackage{graphicx} -\usepackage[final]{hcar} - -%include polycode.fmt - -\begin{document} - -\begin{hcarentry}{Cabal} -\report{Mikhail Glushenkov} -\status{Active} -\participants{\href{https://github.com/haskell/cabal/graphs/contributors}{Cabal contributors}}% optional -\makeheader - -\subsubsection*{Background} - -Cabal is the standard packaging system for Haskell software. It specifies a -standard way in which Haskell libraries and applications can be packaged so that -it is easy for consumers to use them, or re-package them, regardless of the -Haskell implementation or installation platform. - -\texttt{cabal-install} is the command line interface for the Cabal and Hackage -system. It provides a command line program \texttt{cabal} which has sub-commands -for installing and managing Haskell packages. - -\subsubsection*{Recent Progress} - -We've just released versions 1.24 of Cabal and \texttt{cabal-install}. 1.24 -incorporates more than a thousand commits by -\href{https://gist.github.com/23Skidoo/62544d7e0352037749eec7344788831c}{89 - different contributors}. Main user-visible changes in this release are: - -\begin{itemize} -\item Nix-style local builds in \texttt{cabal-install} (so far only a technical - preview). See - \href{http://blog.ezyang.com/2016/05/announcing-cabal-new-build-nix-style-local-builds/}{this - post} by Edward Z. Yang for more details. -\item Integration of a new security scheme for Hackage based on - \href{https://theupdateframework.github.io/}{The Update Framework}. So far - this is not enabled by default, pending some changes on the Hackage side. See - \href{http://www.well-typed.com/blog/2015/08/hackage-security-beta/}{these} - \href{http://www.well-typed.com/blog/2015/07/hackage-security-alpha/}{three} - \href{http://www.well-typed.com/blog/2015/04/improving-hackage-security/}{posts} - by Edsko de Vries and Duncan Coutts for more information. -\item Support for specifying setup script dependencies in \texttt{.cabal} - files. See - \href{http://www.well-typed.com/blog/2015/07/cabal-setup-deps/}{this post by - Duncan Coutts} for more information. -\item Support for HTTPS downloads in \texttt{cabal-install}. HTTPS is now used - by default for downloads from Hackage. -\item \texttt{cabal upload} learned how to upload documentation to Hackage - (\texttt{cabal upload --doc}). -\item In related news, \texttt{cabal haddock} now can generate documentation - intended for uploading to Hackage (\texttt{cabal haddock - --for-hackage}). \texttt{cabal upload --doc} runs this command automatically - if the documentation for current package wasn't generated yet. -\item New \texttt{cabal-install} command: \texttt{gen-bounds}. See - \href{http://softwaresimply.blogspot.se/2015/08/cabal-gen-bounds-easy-generation-of.html}{here} - for more information. -\item It's now possible to limit the scope of \texttt{--allow-newer} to single - packages in the install plan, both on the command line and in the config - file. See \href{https://github.com/haskell/cabal/issues/2756}{here} for an - example. -\item New \texttt{cabal user-config} subcommand: \texttt{init}, which creates a - default \texttt{\textasciitilde{}/.cabal/config} file. -\item New config file field: \texttt{extra-framework-dirs} (extra locations to - find OS X frameworks in). -\item \texttt{cabal-install} solver - \href{https://github.com/haskell/cabal/pull/2873}{now takes information about - extensions and language flavours into account}. -\item New \texttt{cabal-install} option: - \href{https://github.com/haskell/cabal/pull/2578}{\texttt{--offline}}, which - prevents \texttt{cabal-install} from downloading anything from the Internet. -\item New \texttt{cabal upload} option - \href{https://github.com/haskell/cabal/pull/2506}{\texttt{-P}/\texttt{--password-command}} - for reading Hackage password from arbitrary program output. -\item Support for GHC 8 (NB: old versions of Cabal won't work with this version - of GHC). -\end{itemize} - -Full list of changes in Cabal 1.24 is available -\href{http://hackage.haskell.org/package/Cabal-1.24.0.0/changelog}{here}; full -list of changes in \texttt{cabal-install} 1.24 is available -\href{http://hackage.haskell.org/package/cabal-install-1.24.0.0/changelog}{here}. - -\subsubsection*{Looking Forward} - -We plan to make a new release of Cabal/\texttt{cabal-install} approximately 6 -months after 1.24 -- that is, in late October or early November 2016. Main -features that are currently targeted at 1.26 are: - -\begin{itemize} -\item Further work on nix-style local builds, perhaps making that code path the - default. -\item Enabling Hackage Security by default. -\item Native support for - \href{https://github.com/haskell/cabal/pull/2540}{``foreign libraries''}: - Haskell libraries that are intended to be used by non-Haskell code. -\item New Parsec-based parser for \texttt{.cabal} files. -\end{itemize} - -We would like to encourage people considering contributing to take a look at -\href{https://github.com/haskell/cabal/issues/}{the bug tracker on GitHub}, take -part in discussions on tickets and pull requests, or submit their own. The bug -tracker is reasonably well maintained and it should be relatively clear to new -contributors what is in need of attention and which tasks are considered -relatively easy. For more in-depth discussion there is also the -\href{https://mail.haskell.org/mailman/listinfo/cabal-devel}{\texttt{cabal-devel}} -mailing list. - -\FurtherReading - Cabal homepage:\hfill\url{https://www.haskell.org/cabal/}\\ - Cabal on GitHub:\hfill\url{https://github.com/haskell/cabal} - -\end{hcarentry} - -\end{document} diff --git a/cabal/Cabal/doc/hcar/Cabal-201611.tex b/cabal/Cabal/doc/hcar/Cabal-201611.tex deleted file mode 100644 --- a/cabal/Cabal/doc/hcar/Cabal-201611.tex +++ /dev/null @@ -1,140 +0,0 @@ -% Cabal-MC.tex -\begin{hcarentry}{Cabal} -\label{cabal}%\label{hackage}\label{hackagedb}% -\report{Mikhail Glushenkov}%11/16 -\status{Stable, actively developed} -\makeheader - -\subsubsection*{Background} - -Cabal is the standard packaging system for Haskell software. It specifies a -standard way in which Haskell libraries and applications can be packaged so -that it is easy for consumers to use them, or re-package them, regardless of -the Haskell implementation or installation platform. - -\texttt{cabal-install} is the command line interface for the Cabal and Hackage -system. It provides a command line program \texttt{cabal} which has -sub-commands for installing and managing Haskell packages. - -\subsubsection*{Recent Progress} - -We've recently produced -\href{https://mail.haskell.org/pipermail/cabal-devel/2016-December/010384.html}{new - point releases} of Cabal/\texttt{cabal-install} from the 1.24 -branch. Among other things, Cabal 1.24.2.0 includes a -\href{https://gitlab.haskell.org/ghc/ghc/-/issues/12479}{fix} necessary to -make soon-to-be-released GHC 8.0.2 work on macOS Sierra. - -Almost 1500 commits were made to the \texttt{master} branch by -\href{https://gist.github.com/23Skidoo/1a291fd56a18b51f415db5fbaff56ec6}{53 -different contributors} since the 1.24 release. Among the highlights are: - -\begin{compactitem} -\item - \href{http://cabal.readthedocs.io/en/latest/developing-packages.html#library}{Convenience, - or internal libraries} -- named libraries that are only intended - for use inside the package. A common use case is sharing code - between the test suite and the benchmark suite without exposing it - to the users of the package. - -\item Support for - \href{http://cabal.readthedocs.io/en/latest/developing-packages.html#foreign-libraries}{foreign - libraries}, which are Haskell libraries intended to be used by - foreign languages like C. Foreign libraries only work with GHC 7.8 - and later. - -\item Initial support for building Backpack packages. Backpack is an - exciting new project adding an ML-style module system to Haskell, - but on the package level. See - \href{https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst}{here} - and \href{http://blog.ezyang.com/category/haskell/backpack/}{here} - for a more thorough introduction to Backpack. - -\item \texttt{./Setup configure} now accepts an argument - \href{https://github.com/ghc-proposals/ghc-proposals/pull/4}{specifying - the component to be configured}. This is mainly an internal - change, but it means that \texttt{cabal-install} can now perform - component-level parallel builds (among other things). - -\item A lot of improvements in the \texttt{new-build} feature - (a.k.a. nix-style local builds). Git \texttt{HEAD} version of - \texttt{cabal-install} is now recommended if you use - \texttt{new-build}. For an introduction to \texttt{new-build}, see - \href{http://cabal.readthedocs.io/en/latest/nix-local-build-overview.html}{this - chapter} of the manual. - -\item Special support for the Nix package manager in - \texttt{cabal-install}. See - \href{http://cabal.readthedocs.io/en/latest/nix-integration.html}{here} - for more details. - -\item \texttt{cabal upload} now uploads a package candidate by - default. Use \texttt{cabal upload -{}-publish} to upload a final - version. \texttt{cabal upload -{}-check} has been removed in favour - of package candidates. - -\item - \href{http://cabal.readthedocs.io/en/latest/nix-local-build.html#cfg-field-index-state}{An - \texttt{-{}-index-state} flag} for requesting a specific version - of the package index. - -\item \href{https://github.com/haskell/cabal/pull/3818}{New \texttt{cabal reconfigure} command}, which re-runs - \texttt{configure} with most recently used flags. - -\item - \href{http://cabal.readthedocs.io/en/latest/developing-packages.html#autogenerated-modules}{New - \texttt{autogen-modules} field} for modules built automatically - (like \texttt{Paths\_PACKAGENAME}). - -\item - \href{http://cabal.readthedocs.io/en/latest/developing-packages.html#pkg-field-build-depends}{New - version range operator} \texttt{\^{}>=}, which is equivalent to - \texttt{>=} intersected with an automatically-inferred major version - bound. For example, \texttt{\^{}>= 2.0.3} is equivalent to \texttt{>= - 2.0.3 \&\& < 2.1}. - -\item - \href{http://cabal.readthedocs.io/en/latest/installing-packages.html#cmdoption-setup-configure--allow-newer}{An - \texttt{-{}-allow-older} flag}, dual to \texttt{-{}-allow-newer}. - -\item New Parsec-based parser for \texttt{.cabal} files - \href{https://github.com/haskell/cabal/pull/3602}{has been merged}, - but not enabled by default yet. - -\item \href{http://cabal.readthedocs.io/en/latest/}{The manual} has - been converted to reST/Sphinx format, improved and expanded. - -\item - \href{https://www.well-typed.com/blog/2015/08/hackage-security-beta/}{Hackage - Security} has been enabled by default. - -\item A lot of bug fixes and performance improvements. - -\end{compactitem} - -\subsubsection*{Looking Forward} - -The next Cabal/\texttt{cabal-install} versions will be released either -in early 2017, or simultaneously with GHC 8.2 (April/May 2017). Our -main focus at this stage is getting the \texttt{new-build} feature to -the state where it can be enabled by default, but there are many other -areas of Cabal that need work. - -We would like to encourage people considering contributing to take a -look at \href{https://github.com/haskell/cabal/issues/}{the bug - tracker on GitHub} and the -\href{https://github.com/haskell/cabal/wiki/Hackathon-2016}{Wiki}, -take part in discussions on tickets and pull requests, or submit their -own. The bug tracker is reasonably well maintained and it should be -relatively clear to new contributors what is in need of attention and -which tasks are considered relatively easy. For more in-depth -discussion there is also the -\href{https://mail.haskell.org/mailman/listinfo/cabal-devel}{\texttt{cabal-devel}} -mailing list. - -\FurtherReading -\begin{compactitem} -\item Cabal homepage:\hfill\url{https://www.haskell.org/cabal/}\\ -\item Cabal on GitHub:\hfill\url{https://github.com/haskell/cabal} -\end{compactitem} -\end{hcarentry} diff --git a/cabal/Cabal/doc/hcar/Cabal-201811.tex b/cabal/Cabal/doc/hcar/Cabal-201811.tex deleted file mode 100644 --- a/cabal/Cabal/doc/hcar/Cabal-201811.tex +++ /dev/null @@ -1,121 +0,0 @@ -% Cabal-MC.tex -\begin{hcarentry}{Cabal} -\label{cabal} -\label{hackage} -\label{hackagedb} -\report{Mikhail Glushenkov}%11/18 -\status{Stable, actively developed} -\makeheader - -\subsubsection*{Background} - -Cabal is the standard packaging system for Haskell software. It -specifies how Haskell libraries and applications can be packaged so -that it is easy for consumers to use them, or re-package them, -regardless of the Haskell implementation or installation platform. - -\texttt{cabal-install} is the command line interface for the Cabal and -Hackage system. It provides a program \texttt{cabal} which has -sub-commands for installing, managing, and developing Haskell packages. - -\subsubsection*{Recent Progress} - -We've recently produced the first releases of -Cabal/\texttt{cabal-install} from the 2.4 series. Bugfix releases from -the same branch are in the works at the time of writing and should be out soon. - -Almost 600 commits were made to the \texttt{master} branch by -\href{https://gist.github.com/23Skidoo/7f07c309776574039b9cc7e29cfaf069}{48 - different contributors} since the 2.2 release. Among the highlights -are: - -\begin{compactitem} - -\item Massive improvements to the - \href{https://cabal.readthedocs.io/en/latest/nix-local-build-overview.html#nix-style-local-builds}{\texttt{new-build} - feature} - \href{https://typedr.at/posts/what-i-did-on-my-summer-vacation/}{made - by Alexis Williams during GSoC 2018}, as well as many other - contributors. Among other things, \texttt{new-install}, - \texttt{new-sdist}, \texttt{new-clean}, and \texttt{new-update} - commands are now fully implemented, \texttt{new-repl} works outside - of projects, and \texttt{new-run} can now be used to run scripts - (either with \texttt{cabal new-run foo.hs} or in a shebang - interpreter mode). - -\item It's now possible - \href{https://cabal.readthedocs.io/en/latest/nix-local-build.html#specifying-packages-from-remote-version-control-locations}{to - specify packages from remote version control locations - (e.g. GitHub) in \texttt{cabal.project}} (as well as local/remote - tarballs). Work done by Duncan Coutts with the help of Alexis - Williams, \textbf{@quasicomputational}, and others. - -\item Improvements to the wildcard syntax: a - \href{https://cabal.readthedocs.io/en/latest/developing-packages.html#pkg-field-data-files}{limited - form of recursive matching} (\texttt{data-files:~audio/**/*.mp3}) - is now allowed. Work done by \textbf{@quasicomputational}. - -\item Lots of bug fixes and performance improvements. - -\end{compactitem} - -\subsubsection*{Looking Forward} - -We plan to make the next major Cabal/\texttt{cabal-install} release -(3.0) around the same time GHC 8.8 is going to be released (February -2019). Main features currently targeted at this milestone are: - -\begin{compactitem} - -\item \texttt{new-build} will become the default mode of - operation. Old-style commands will still be accessible under the - \texttt{v1-} prefix. - -\item Multiple public libraries feature implemented by Francesco - Gazzetta during GSoC 2018. This will allow to define more than one - public library in a single \texttt{.cabal} package, which is useful - for large projects such as \texttt{lens}, as well as Backpack-heavy - libraries. This - \href{https://github.com/haskell/cabal/pull/5526}{has already been - merged to \texttt{master}}; Francesco continues to polish and - improve the implementation in preparation for its initial release. - -\item A split of the Cabal library into a pure \texttt{cabal-lib-core} - part (parser and foundational data types) and an effectful - \texttt{cabal-lib-build} part (build system bits); likewise, the - constraint solver part of \texttt{cabal-install} will be - moved into its own library \texttt{cabal-lib-solver}, and the - \texttt{cabal-install} package renamed to \texttt{cabal}. - -\item A revamped homepage, rewritten user manual, and automated build - bots for producing binaries. Help in this area would be appreciated! - -\end{compactitem} - -We would like to encourage people considering contributing to take a -look at \href{https://github.com/haskell/cabal/issues/}{the bug - tracker on GitHub}, take part in discussions on tickets and pull -requests, or submit their own. The bug tracker is reasonably well -maintained and it should be fairly clear to new contributors what -is in need of attention and which tasks are considered relatively -easy. Additionally, -\href{https://github.com/haskell/cabal/wiki/ZuriHac-2018}{the list - of potential projects from the latest hackathon} and the tickets -marked -\href{https://github.com/haskell/cabal/issues?q=is\%3Aopen+is\%3Aissue+label\%3A\%22meta\%3A+easy\%22}{“easy”} -and -\href{https://github.com/haskell/cabal/issues?q=is\%3Aopen+is\%3Aissue+label\%3Anewcomer}{“newcomer”} -can be used as a source of ideas for what to work on. - -For more in-depth discussions there is also the -\href{https://mail.haskell.org/mailman/listinfo/cabal-devel}{\texttt{cabal-devel} - mailing list} and the -\href{http://ircbrowse.net/browse/hackage}{\texttt{\#hackage} IRC - channel on FreeNode}. - -\FurtherReading -\begin{compactitem} -\item Cabal homepage:\hfill\url{https://www.haskell.org/cabal/}\\ -\item Cabal on GitHub:\hfill\url{https://github.com/haskell/cabal} -\end{compactitem} -\end{hcarentry} diff --git a/cabal/Cabal/doc/hcar/hcar.sty b/cabal/Cabal/doc/hcar/hcar.sty deleted file mode 100644 --- a/cabal/Cabal/doc/hcar/hcar.sty +++ /dev/null @@ -1,186 +0,0 @@ -\ProvidesPackage{hcar} - -\newif\ifhcarfinal -\hcarfinalfalse -\DeclareOption{final}{\hcarfinaltrue} -\ProcessOptions - -\RequirePackage{keyval} -\RequirePackage{color} -\RequirePackage{array} - -\ifhcarfinal - \RequirePackage[T1]{fontenc} - \RequirePackage{lmodern} - \RequirePackage{tabularx} - \RequirePackage{booktabs} - \RequirePackage{framed} - \RequirePackage[obeyspaces,T1]{url} - \RequirePackage - [bookmarks=true,colorlinks=true, - urlcolor=urlcolor, - linkcolor=linkcolor, - breaklinks=true, - pdftitle={Haskell Communities and Activities Report}]% - {hyperref} -\else - \RequirePackage[obeyspaces]{url} -\fi -\urlstyle{sf} - -\definecolor{urlcolor}{rgb}{0.1,0.3,0} -\definecolor{linkcolor}{rgb}{0.3,0,0} -\definecolor{shadecolor}{rgb}{0.9,0.95,1}%{0.98,1.0,0.95} -\definecolor{framecolor}{gray}{0.9} -\definecolor{oldgray}{gray}{0.7} - -\newcommand{\Contact}{\subsubsection*{Contact}} -\newcommand{\FurtherReading}{\subsubsection*{Further reading}} -\newcommand{\FuturePlans}{\subsubsection*{Future plans}} -\newcommand{\WhatsNew}{\subsubsection*{What is new?}} - -\newcommand{\Separate}{\smallskip\noindent} -\newcommand{\FinalNote}{\smallskip\noindent} - -\newcommand{\urlpart}{\begingroup\urlstyle{sf}\Url} -\newcommand{\email}[1]{\href{mailto:\EMailRepl{#1}{ at }}{$\langle$\urlpart{#1}$\rangle$}} -\newcommand{\cref}[1]{($\rightarrow\,$\ref{#1})} - -\ifhcarfinal - \let\hcarshaded=\shaded - \let\endhcarshaded=\endshaded -\else - \newsavebox{\shadedbox} - \newlength{\shadedboxwidth} - \def\hcarshaded - {\begingroup - \setlength{\shadedboxwidth}{\linewidth}% - \addtolength{\shadedboxwidth}{-2\fboxsep}% - \begin{lrbox}{\shadedbox}% - \begin{minipage}{\shadedboxwidth}\ignorespaces} - \def\endhcarshaded - {\end{minipage}% - \end{lrbox}% - \noindent - \colorbox{shadecolor}{\usebox{\shadedbox}}% - \endgroup} -\fi - -\ifhcarfinal - \newenvironment{hcartabularx} - {\tabularx{\linewidth}{l>{\raggedleft}X}} - {\endtabularx} -\else - \newenvironment{hcartabularx} - {\begin{tabular}{@{}m{.3\linewidth}@{}>{\raggedleft}p{.7\linewidth}@{}}} - {\end{tabular}} -\fi - -\ifhcarfinal - \let\hcartoprule=\toprule - \let\hcarbottomrule=\bottomrule -\else - \let\hcartoprule=\hline - \let\hcarbottomrule=\hline -\fi - -\define@key{hcarentry}{chapter}[]{\let\level\chapter} -\define@key{hcarentry}{section}[]{\let\level\section} -\define@key{hcarentry}{subsection}[]{\let\level\subsection} -\define@key{hcarentry}{subsubsection}[]{\let\level\subsubsection} -\define@key{hcarentry}{level}{\let\level=#1} -%\define@key{hcarentry}{label}{\def\entrylabel{\label{#1}}} -\define@key{hcarentry}{new}[]% - {\let\startnew=\hcarshaded\let\stopnew=\endhcarshaded - \def\startupdated{\let\orig@addv\addvspace\let\addvspace\@gobble}% - \def\stopupdated{\let\addvspace\orig@addv}} -\define@key{hcarentry}{old}[]{\def\normalcolor{\color{oldgray}}\color{oldgray}}% -\define@key{hcarentry}{updated}[]% - {\def\startupdated - {\leavevmode\let\orig@addv\addvspace\let\addvspace\@gobble\hcarshaded}% - \def\stopupdated{\endhcarshaded\let\addvspace\orig@addv}} - -\def\@makeheadererror{\PackageError{hcar}{hcarentry without header}{}} - -\newenvironment{hcarentry}[2][]% -{\let\level\subsection - \let\startupdated=\empty\let\stopupdated=\empty - \let\startnew=\empty\let\stopnew=\empty -%\let\entrylabel=\empty - \global\let\@makeheaderwarning\@makeheadererror - \setkeys{hcarentry}{#1}% - \startnew\startupdated - \level{#2}% - % test: - \global\let\@currentlabel\@currentlabel -%\stopupdated - \let\report@\empty - \let\groupleaders@\empty - \let\members@\empty - \let\contributors@\empty - \let\participants@\empty - \let\developers@\empty - \let\maintainer@\empty - \let\status@\empty - \let\release@\empty - \let\portability@\empty - \let\entry@\empty}% -{\stopnew\@makeheaderwarning}% - -\renewcommand{\labelitemi}{$\circ$} -\settowidth{\leftmargini}{\labelitemi} -\addtolength{\leftmargini}{\labelsep} - -\newcommand*\MakeKey[2]% - {\expandafter\def\csname #1\endcsname##1% - {\expandafter\def\csname #1@\endcsname{\Key@{#2}{##1}}\ignorespaces}} -\MakeKey{report}{Report by:} -\MakeKey{status}{Status:} -\MakeKey{groupleaders}{Group leaders:} -\MakeKey{members}{Members:} -\MakeKey{contributors}{Contributors:} -\MakeKey{participants}{Participants:} -\MakeKey{developers}{Developers:} -\MakeKey{maintainer}{Maintainer:} -\MakeKey{release}{Current release:} -\MakeKey{portability}{Portability:} -\MakeKey{entry}{Entry:} - -\newcommand\Key@[2]{#1 & #2\tabularnewline} - -\newcommand\makeheader -{\smallskip - \begingroup - \sffamily - \small - \noindent - \let\ohrule\hrule - \def\hrule{\color{framecolor}\ohrule}% - \begin{hcartabularx} - \hline - \report@ - \groupleaders@ - \members@ - \participants@ - \developers@ - \contributors@ - \maintainer@ - \status@ - \release@ - \portability@ - \hcarbottomrule - \end{hcartabularx} - \endgroup - \stopupdated - \global\let\@makeheaderwarning\empty - \@afterindentfalse - \@xsect\smallskipamount} - -% columns/linebreaks, interchanged -\newcommand\NCi{&\let\NX\NCii}% -\newcommand\NCii{&\let\NX\NL}% -\newcommand\NL{\\\let\NX\NCi}% -\let\NX\NCi -\newcommand\hcareditor[1]{ (ed.)&\\} -\newcommand\hcarauthor[1]{#1\NX}% -\newcommand\hcareditors[1]{\multicolumn{3}{c}{#1 (eds.)}\\[2ex]} diff --git a/cabal/Cabal/doc/hcar/main.tex b/cabal/Cabal/doc/hcar/main.tex deleted file mode 100644 --- a/cabal/Cabal/doc/hcar/main.tex +++ /dev/null @@ -1,11 +0,0 @@ -\documentclass{article} - -\usepackage{hcar} -\usepackage{hyperref} -\usepackage{paralist} - -\begin{document} - -\input{Cabal-201811} - -\end{document} diff --git a/cabal/Cabal/doc/images/Cabal-dark.png b/cabal/Cabal/doc/images/Cabal-dark.png deleted file mode 100644 Binary files a/cabal/Cabal/doc/images/Cabal-dark.png and /dev/null differ diff --git a/cabal/Cabal/doc/index.rst b/cabal/Cabal/doc/index.rst deleted file mode 100644 --- a/cabal/Cabal/doc/index.rst +++ /dev/null @@ -1,21 +0,0 @@ - -Welcome to the Cabal User Guide -=============================== - -.. toctree:: - :maxdepth: 2 - :numbered: - - getting-started - intro - config-and-install - concepts-and-development - nix-local-build-overview - cabal-commands - cabal-package - cabal-project - setup-commands - file-format-changelog - buildinfo-fields-reference - bugs-and-stability - nix-integration diff --git a/cabal/Cabal/doc/installing-packages.rst b/cabal/Cabal/doc/installing-packages.rst deleted file mode 100644 --- a/cabal/Cabal/doc/installing-packages.rst +++ /dev/null @@ -1,247 +0,0 @@ -Configuration -============= - -.. highlight:: cabal - -Overview --------- - -The global configuration file for ``cabal-install`` is -``~/.cabal/config``. If you do not have this file, ``cabal`` will create -it for you on the first call to ``cabal update``. Alternatively, you can -explicitly ask ``cabal`` to create it for you using - -.. code-block:: console - - $ cabal user-config update - -You can change the location of the global configuration file by specifying -either ``--config-file=FILE`` on the command line or by setting the -``CABAL_CONFIG`` environment variable. - -Most of the options in this configuration file are also available as -command line arguments, and the corresponding documentation can be used -to lookup their meaning. The created configuration file only specifies -values for a handful of options. Most options are left at their default -value, which it documents; for instance, - -:: - - -- executable-stripping: True - -means that the configuration file currently does not specify a value for -the ``executable-stripping`` option (the line is commented out), and -that the default is ``True``; if you wanted to disable stripping of -executables by default, you would change this line to - -:: - - executable-stripping: False - -You can also use ``cabal user-config update`` to migrate configuration -files created by older versions of ``cabal``. - -Environment variables ---------------------- - -Various environment variables affect ``cabal-install``. - -``CABAL_CONFIG`` - The variable to find global configuration file. - -``CABAL_DIR`` - Default content directory for ``cabal-install`` files. - Default value is ``getAppUserDataDirectory "cabal"``, which is - ``$HOME/.cabal`` on unix systems and ``%APPDATA%\cabal`` in Windows. - - .. note:: - - The CABAL_DIR might be dropped in the future, when - ``cabal-install`` starts to use XDG Directory specification. - -``CABAL_BUILDDIR`` - The override for default ``dist`` build directory. - Note, the nix-style builds build directory (``dist-newstyle``) - is not affected by this environment variable. - -Configuration file discovery -^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - -1. If ``$CABAL_CONFIG`` is set use it, -2. otherwise if ``$CABAL_DIR`` is set use ``$CABAL_DIR/config`` -3. otherwise use ``getAppUserDirectory "cabal"`` - -If the configuration file doesn't exist ``cabal-install`` -will generate the default one, with directories based on -``$CABAL_DIR`` (if set) or ``getAppUserDirectory "cabal"`` prefix. - -.. note: - - If ``$CABAL_CONFIG`` is set, but the file doesn't exist, - one will be generated with ``$CABAL_DIR`` or ``getAppUserDirectory "cabal"`` - based prefixes. In other words not the prefixes based on a - directory part of ``$CABAL_CONFIG`` path. - -Repository specification ------------------------- - -An important part of the configuration is the specification of the -repository. When ``cabal`` creates a default config file, it configures -the repository to be the central Hackage server: - -:: - - repository hackage.haskell.org - url: http://hackage.haskell.org/ - -The name of the repository is given on the first line, and can be -anything; packages downloaded from this repository will be cached under -``~/.cabal/packages/hackage.haskell.org`` (or whatever name you specify; -you can change the prefix by changing the value of -:cfg-field:`remote-repo-cache`). If you want, you can configure multiple -repositories, and ``cabal`` will combine them and be able to download -packages from any of them. - -Using secure repositories -^^^^^^^^^^^^^^^^^^^^^^^^^ - -For repositories that support the TUF security infrastructure (this -includes Hackage), you can enable secure access to the repository by -specifying: - -:: - - repository hackage.haskell.org - url: http://hackage.haskell.org/ - secure: True - root-keys: - key-threshold: - -The ```` and ```` values are used for -bootstrapping. As part of the TUF infrastructure the repository will -contain a file ``root.json`` (for instance, -http://hackage.haskell.org/root.json) which the client needs to do -verification. However, how can ``cabal`` verify the ``root.json`` file -*itself*? This is known as bootstrapping: if you specify a list of root -key IDs and a corresponding threshold, ``cabal`` will verify that the -downloaded ``root.json`` file has been signed with at least -```` keys from your set of ````. - -You can, but are not recommended to, omit these two fields. In that case -``cabal`` will download the ``root.json`` field and use it without -verification. Although this bootstrapping step is then unsafe, all -subsequent access is secure (provided that the downloaded ``root.json`` -was not tampered with). Of course, adding ``root-keys`` and -``key-threshold`` to your repository specification only shifts the -problem, because now you somehow need to make sure that the key IDs you -received were the right ones. How that is done is however outside the -scope of ``cabal`` proper. - -More information about the security infrastructure can be found at -https://github.com/haskell/hackage-security. - -Local no-index repositories -^^^^^^^^^^^^^^^^^^^^^^^^^^^ - -It's possible to use a directory of `.tar.gz` package files as a local package -repository. - -:: - - repository my-local-repository - url: file+noindex:///absolute/path/to/directory - -``cabal`` will construct the index automatically from the -``package-name-version.tar.gz`` files in the directory, and will use optional -corresponding ``package-name-version.cabal`` files as new revisions. - -For example, if ``/absolute/path/to/directory`` looks like -:: - - /absolute/path/to/directory/ - foo-0.1.0.0.tar.gz - bar-0.2.0.0.tar.gz - bar-0.2.0.0.cabal - -then ``cabal`` will create an index with two packages: - -- ``foo-0.1.0.0`` using the source and ``.cabal`` file inside - ``foo-0.1.0.0.tar.gz`` -- ``bar-0.2.0.0`` using the source inside ``bar-0.2.0.0.tar.gz`` - and ``bar-0.2.0.0.cabal`` - -The index is cached inside the given directory. If the directory is not -writable, you can append ``#shared-cache`` fragment to the URI, -then the cache will be stored inside the :cfg-field:`remote-repo-cache` directory. -The part of the path will be used to determine the cache key part. - -.. note:: - ``cabal-install`` creates a ``.cache`` file, and will aggressively use - its contents if it exists. Therefore if you change the contents of - the directory, remember to wipe the cache too. - -.. note:: - The URI scheme ``file:`` is interpreted as a remote repository, - as described in the previous sections, thus requiring manual construction - of ``01-index.tar`` file. - -Legacy repositories -^^^^^^^^^^^^^^^^^^^ - -Currently ``cabal`` supports single kind of “legacy” repositories. -It is specified using - -:: - - remote-repo: hackage.haskell.org:http://hackage.haskell.org/packages/archive - -This is just syntactic sugar for - -:: - - repository hackage.haskell.org - url: http://hackage.haskell.org/packages/archive - -although, in (and only in) the specific case of Hackage, the URL -``http://hackage.haskell.org/packages/archive`` will be silently -translated to ``http://hackage.haskell.org/``. - -Secure local repositories -^^^^^^^^^^^^^^^^^^^^^^^^^ - -If you want to use repositories on your local file system, it is -recommended instead to use a *secure* local repository: - -:: - - repository my-local-repo - url: file:/path/to/local/repo - secure: True - root-keys: - key-threshold: - -The layout of these secure local repos matches the layout of remote -repositories exactly; the :hackage-pkg:`hackage-repo-tool` -can be used to create and manage such repositories. - -.. _installing-packages: - -Building and installing packages -================================ - -To be written - -Installing packages from Hackage --------------------------------- - -The ``cabal`` tool also can download, configure, build and install a -`Hackage`_ package and all of its -dependencies in a single step. To do this, run: - -:: - - $ cabal install [PACKAGE...] - -To browse the list of available packages, visit the `Hackage`_ web site. - -.. _Hackage: https://hackage.haskell.org/ diff --git a/cabal/Cabal/doc/intro.rst b/cabal/Cabal/doc/intro.rst deleted file mode 100644 --- a/cabal/Cabal/doc/intro.rst +++ /dev/null @@ -1,200 +0,0 @@ -.. highlight:: console - -Cabal is the standard package system for -Haskell_ software. It helps people to -configure, build and install Haskell software and to distribute it -easily to other users and developers. - -There is a command line tool called ``cabal`` for working with Cabal -packages. It helps with installing existing packages and also helps -people developing their own packages. It can be used to work with local -packages or to install packages from online package archives, including -automatically installing dependencies. By default it is configured to -use Hackage_ which is Haskell's central -package archive that contains thousands of libraries and applications in -the Cabal package format. - -Introduction -============ - -Cabal is a package system for Haskell software. The point of a package -system is to enable software developers and users to easily distribute, -use and reuse software. A package system makes it easier for developers -to get their software into the hands of users. Equally importantly, it -makes it easier for software developers to be able to reuse software -components written by other developers. - -Packaging systems deal with packages and with Cabal we call them *Cabal -packages*. The Cabal package is the unit of distribution. Every Cabal -package has a name and a version number which are used to identify the -package, e.g. ``filepath-1.0``. - -Cabal packages can depend on other Cabal packages. There are tools to -enable automated package management. This means it is possible for -developers and users to install a package plus all of the other Cabal -packages that it depends on. It also means that it is practical to make -very modular systems using lots of packages that reuse code written by -many developers. - -Cabal packages are source based and are typically (but not necessarily) -portable to many platforms and Haskell implementations. The Cabal -package format is designed to make it possible to translate into other -formats, including binary packages for various systems. - -When distributed, Cabal packages use the standard compressed tarball -format, with the file extension ``.tar.gz``, e.g. -``filepath-1.0.tar.gz``. - -Note that packages are not part of the Haskell language, rather they are -a feature provided by the combination of Cabal and GHC (and several -other Haskell implementations). - -A tool for working with packages --------------------------------- - -There is a command line tool, called "``cabal``", that users and -developers can use to build and install Cabal packages. It can be used -for both local packages and for packages available remotely over the -network. It can automatically install Cabal packages plus any other -Cabal packages they depend on. - -Developers can use the tool with packages in local directories, e.g. - -:: - - $ cd foo/ - $ cabal install - -While working on a package in a local directory, developers can run the -individual steps to configure and build, and also generate documentation -and run test suites and benchmarks. - -It is also possible to install several local packages at once, e.g. - -:: - - $ cabal install foo/ bar/ - -Developers and users can use the tool to install packages from remote -Cabal package archives. By default, the ``cabal`` tool is configured to -use the central Haskell package archive called -Hackage_ but it is possible to use it -with any other suitable archive. - -:: - - $ cabal install xmonad - -This will install the ``xmonad`` package plus all of its dependencies. - -In addition to packages that have been published in an archive, -developers can install packages from local or remote tarball files, for -example - -:: - - $ cabal install foo-1.0.tar.gz - $ cabal install http://example.com/foo-1.0.tar.gz - -Cabal provides a number of ways for a user to customise how and where a -package is installed. They can decide where a package will be installed, -which Haskell implementation to use and whether to build optimised code -or build with the ability to profile code. It is not expected that users -will have to modify any of the information in the ``.cabal`` file. - -For full details, see the section on `building and installing -packages `__. - -Note that ``cabal`` is not the only tool for working with Cabal -packages. Due to the standardised format and a library for reading -``.cabal`` files, there are several other special-purpose tools. - -What's in a package -------------------- - -A Cabal package consists of: - -- Haskell software, including libraries, executables and tests -- metadata about the package in a standard human and machine readable - format (the "``.cabal``" file) -- a standard interface to build the package (the "``Setup.hs``" file) - -The ``.cabal`` file contains information about the package, supplied by -the package author. In particular it lists the other Cabal packages that -the package depends on. - -For full details on what goes in the ``.cabal`` and ``Setup.hs`` files, -and for all the other features provided by the build system, see the -section on `developing packages `__. - -Cabal featureset ----------------- - -Cabal and its associated tools and websites covers: - -- a software build system -- software configuration -- packaging for distribution -- automated package management - - - natively using the ``cabal`` command line tool; or - - by translation into native package formats such as RPM or deb - -- web and local Cabal package archives - - - central Hackage website with 1000's of Cabal packages - -Some parts of the system can be used without others. In particular the -built-in build system for simple packages is optional: it is possible to -use custom build systems. - -Similar systems ---------------- - -The Cabal system is roughly comparable with the system of Python Eggs, -Ruby Gems or Perl distributions. Each system has a notion of -distributable packages, and has tools to manage the process of -distributing and installing packages. - -Hackage is an online archive of Cabal packages. It is roughly comparable -to CPAN but with rather fewer packages (around 5,000 vs 28,000). - -Cabal is often compared with autoconf and automake and there is some -overlap in functionality. The most obvious similarity is that the -command line interface for actually configuring and building packages -follows the same steps and has many of the same configuration -parameters. - -:: - - $ ./configure --prefix=... - $ make - $ make install - -compared to - -:: - - $ cabal configure --prefix=... - $ cabal build - $ cabal install - -Cabal's build system for simple packages is considerably less flexible -than make/automake, but has builtin knowledge of how to build Haskell -code and requires very little manual configuration. Cabal's simple build -system is also portable to Windows, without needing a Unix-like -environment such as cygwin/mingwin. - -Compared to autoconf, Cabal takes a somewhat different approach to -package configuration. Cabal's approach is designed for automated -package management. Instead of having a configure script that tests for -whether dependencies are available, Cabal packages specify their -dependencies. There is some scope for optional and conditional -dependencies. By having package authors specify dependencies it makes it -possible for tools to install a package and all of its dependencies -automatically. It also makes it possible to translate (in a -mostly-automatically way) into another package format like RPM or deb -which also have automatic dependency resolution. - - -.. include:: references.inc diff --git a/cabal/Cabal/doc/misc.rst b/cabal/Cabal/doc/misc.rst deleted file mode 100644 --- a/cabal/Cabal/doc/misc.rst +++ /dev/null @@ -1,103 +0,0 @@ -Reporting bugs and deficiencies -=============================== - -Please report any flaws or feature requests in the `bug -tracker `__. - -For general discussion or queries email the libraries mailing list -libraries@haskell.org. There is also a development mailing list -cabal-devel@haskell.org. - -Stability of Cabal interfaces -============================= - -The Cabal library and related infrastructure is still under active -development. New features are being added and limitations and bugs are -being fixed. This requires internal changes and often user visible -changes as well. We therefore cannot promise complete future-proof -stability, at least not without halting all development work. - -This section documents the aspects of the Cabal interface that we can -promise to keep stable and which bits are subject to change. - -Cabal file format ------------------ - -This is backwards compatible and mostly forwards compatible. New fields -can be added without breaking older versions of Cabal. Fields can be -deprecated without breaking older packages. - -Command-line interface ----------------------- - -Very Stable Command-line interfaces -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- ``./setup configure`` -- ``--prefix`` -- ``--user`` -- ``--ghc``, ``--uhc`` -- ``--verbose`` -- ``--prefix`` - -- ``./setup build`` -- ``./setup install`` -- ``./setup register`` -- ``./setup copy`` - -Stable Command-line interfaces -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Unstable command-line -~~~~~~~~~~~~~~~~~~~~~ - -Functions and Types -------------------- - -The Cabal library follows the `Package Versioning Policy`_. -This means that within a stable major release, for example 1.2.x, there -will be no incompatible API changes. But minor versions increments, for -example 1.2.3, indicate compatible API additions. - -The Package Versioning Policy does not require any API guarantees -between major releases, for example between 1.2.x and 1.4.x. In practice -of course not everything changes between major releases. Some parts of -the API are more prone to change than others. The rest of this section -gives some informal advice on what level of API stability you can expect -between major releases. - -Very Stable API -~~~~~~~~~~~~~~~ - -- ``defaultMain`` - -- ``defaultMainWithHooks defaultUserHooks`` - -But regular ``defaultMainWithHooks`` isn't stable since ``UserHooks`` -changes. - -Semi-stable API -~~~~~~~~~~~~~~~ - -- ``UserHooks`` The hooks API will change in the future - -- ``Distribution.*`` is mostly declarative information about packages - and is somewhat stable. - -Unstable API -~~~~~~~~~~~~ - -Everything under ``Distribution.Simple.*`` has no stability guarantee. - -Hackage -------- - -The index format is a partly stable interface. It consists of a tar.gz -file that contains directories with ``.cabal`` files in. In future it -may contain more kinds of files so do not assume every file is a -``.cabal`` file. Incompatible revisions to the format would involve -bumping the name of the index file, i.e., ``00-index.tar.gz``, -``01-index.tar.gz`` etc. - - -.. include:: references.inc diff --git a/cabal/Cabal/doc/nix-integration.rst b/cabal/Cabal/doc/nix-integration.rst deleted file mode 100644 --- a/cabal/Cabal/doc/nix-integration.rst +++ /dev/null @@ -1,54 +0,0 @@ -Nix Integration -=============== - -.. note:: - - This functionality doesn't work with nix-style builds. - Nix-style builds are not related to Nix integration. - -`Nix `_ is a package manager popular with some Haskell developers due to its focus on reliability and reproducibility. ``cabal`` now has the ability to integrate with Nix for dependency management during local package development. - -Enabling Nix Integration ------------------------- - -To enable Nix integration, simply pass the ``--enable-nix`` global option when you call ``cabal``. To use this option everywhere, edit your ``$HOME/.cabal/config`` file to include: - -.. code-block:: cabal - - nix: True - -If the package (which must be locally unpacked) provides a ``shell.nix`` or ``default.nix`` file, this flag will cause ``cabal`` to run most commands through ``nix-shell``. If both expressions are present, ``shell.nix`` is preferred. The following commands are affected: - -- ``cabal configure`` -- ``cabal build`` -- ``cabal repl`` -- ``cabal install`` (only if installing into a sandbox) -- ``cabal haddock`` -- ``cabal freeze`` -- ``cabal gen-bounds`` -- ``cabal run`` - -If the package does not provide an expression, ``cabal`` runs normally. - -Creating Nix Expressions ------------------------- - -The Nix package manager is based on a lazy, pure, functional programming language; packages are defined by expressions in this language. The fastest way to create a Nix expression for a Cabal package is with the `cabal2nix `_ tool. To create a ``shell.nix`` expression for the package in the current directory, run this command: - -.. code-block:: console - - $ cabal2nix --shell ./. >shell.nix - -Nix Expression Evaluation -------------------------- - -(This section describes for advanced users how Nix expressions are evaluated.) - -First, the Nix expression (``shell.nix`` or ``default.nix``) is instantiated with ``nix-instantiate``. The ``--add-root`` and ``--indirect`` options are used to create an indirect root in the Cabal build directory, preventing Nix from garbage collecting the derivation while in use. The ``IN_NIX_SHELL`` environment variable is set so that ``builtins.getEnv`` works as it would in ``nix-shell``. - -Next, the commands above are run through ``nix-shell`` using the instantiated derivation. Again, ``--add-root`` and ``--indirect`` are used to prevent Nix from garbage collecting the packages in the environment. The child ``cabal`` process reads the ``CABAL_IN_NIX_SHELL`` environment variable to prevent it from spawning additional child shells. - -Further Reading ----------------- - -The `Nix manual `_ provides further instructions for writing Nix expressions. The `Nixpkgs manual `_ describes the infrastructure provided for Haskell packages. diff --git a/cabal/Cabal/doc/nix-local-build-overview.rst b/cabal/Cabal/doc/nix-local-build-overview.rst deleted file mode 100644 --- a/cabal/Cabal/doc/nix-local-build-overview.rst +++ /dev/null @@ -1,45 +0,0 @@ -Nix-style Local Builds -====================== - -.. _nix-style-builds: - -Nix-style local builds are a new build system implementation inspired by Nix. -The Nix-style local build system is commonly called "v2-build" for short -after the ``cabal v2-*`` family of commands that control it. However, those -names are only temporary until Nix-style local builds become the default. -This is expected to happen soon. For those who do not wish to use the new -functionality, the classic project style will not be removed immediately, -but these legacy commands will require the usage of the ``v1-`` prefix as of -Cabal 3.0 and will be removed in a future release. For a future-proof -way to use these commands in a script or tutorial that anticipates the -possibility of another UI paradigm being devised in the future, there -are also ``v2-`` prefixed versions that will reference the same functionality -until such a point as it is completely removed from Cabal. - -Nix-style local builds combine the best of non-sandboxed and sandboxed Cabal: - -1. Like sandboxed Cabal previously, we build sets of independent local - packages deterministically and independent of any global state. - v2-build will never tell you that it can't build your package - because it would result in a "dangerous reinstall." Given a - particular state of the Hackage index, your build is completely - reproducible. For example, you no longer need to compile packages - with profiling ahead of time; just request profiling and v2-build - will rebuild all its dependencies with profiling automatically. - -2. Like non-sandboxed Cabal today, builds of external packages are - cached in ``~/.cabal/store``, so that a package can be built once, - and then reused anywhere else it is also used. No need to continually - rebuild dependencies whenever you make a new sandbox: dependencies - which can be shared, are shared. - -Nix-style local builds were first released as beta in cabal-install 1.24. -They currently work with all versions of GHC supported by that release: GHC 7.0 and later. - -Some features described in this manual are not implemented. If you need -them, please give us a shout and we'll prioritize accordingly. - - - -.. toctree:: - nix-local-build diff --git a/cabal/Cabal/doc/nix-local-build.rst b/cabal/Cabal/doc/nix-local-build.rst deleted file mode 100644 --- a/cabal/Cabal/doc/nix-local-build.rst +++ /dev/null @@ -1,264 +0,0 @@ -.. highlight:: console - -Quickstart -========== - -Suppose that you are in a directory containing a single Cabal package -which you wish to build (if you haven't set up a package yet check -out `developing packages `__ for -instructions). You can configure and build it using Nix-style -local builds with this command (configuring is not necessary): - -:: - - $ cabal v2-build - -To open a GHCi shell with this package, use this command: - -:: - - $ cabal v2-repl - -To run an executable defined in this package, use this command: - -:: - - $ cabal v2-run [executable args] - -Developing multiple packages ----------------------------- - -Many Cabal projects involve multiple packages which need to be built -together. To build multiple Cabal packages, you need to first create a -``cabal.project`` file which declares where all the local package -directories live. For example, in the Cabal repository, there is a root -directory with a folder per package, e.g., the folders ``Cabal`` and -``cabal-install``. The ``cabal.project`` file specifies each folder as -part of the project: - -.. code-block:: cabal - - packages: Cabal/ - cabal-install/ - -The expectation is that a ``cabal.project`` is checked into your source -control, to be used by all developers of a project. If you need to make -local changes, they can be placed in ``cabal.project.local`` (which -should not be checked in.) - -Then, to build every component of every package, from the top-level -directory, run the command: (using cabal-install-2.0 or greater.) - -:: - - $ cabal v2-build all - -To build a specific package, you can either run ``v2-build`` from the -directory of the package in question: - -:: - - $ cd cabal-install - $ cabal v2-build - -or you can pass the name of the package as an argument to -``cabal v2-build`` (this works in any subdirectory of the project): - -:: - - $ cabal v2-build cabal-install - -You can also specify a specific component of the package to build. For -example, to build a test suite named ``package-tests``, use the command: - -:: - - $ cabal v2-build package-tests - -Targets can be qualified with package names. So to request -``package-tests`` *from* the ``Cabal`` package, use -``Cabal:package-tests``. - -Unlike sandboxes, there is no need to setup a sandbox or ``add-source`` -projects; just check in ``cabal.project`` to your repository and -``v2-build`` will just work. - -Cookbook -======== - -How can I profile my library/application? ------------------------------------------ - -Create or edit your ``cabal.project.local``, adding the following -line:: - - profiling: True - -Now, ``cabal v2-build`` will automatically build all libraries and -executables with profiling. You can fine-tune the profiling settings -for each package using :cfg-field:`profiling-detail`:: - - package p - profiling-detail: toplevel-functions - -Alternately, you can call ``cabal v2-build --enable-profiling`` to -temporarily build with profiling. - -How it works -============ - -Local versus external packages ------------------------------- - -One of the primary innovations of Nix-style local builds is the -distinction between local packages, which users edit and recompile and -must be built per-project, versus external packages, which can be cached -across projects. To be more precise: - -1. A **local package** is one that is listed explicitly in the - ``packages``, ``optional-packages`` or ``extra-packages`` field of a - project. Usually, these refer to packages whose source code lives - directly in a folder in your project. But you can list an - arbitrary Hackage package in :cfg-field:`packages` - to force it to be treated as local. - -Local packages, as well as the external packages (below) which depend on -them, are built **inplace**, meaning that they are always built -specifically for the project and are not installed globally. Inplace -packages are not cached and not given unique hashes, which makes them -suitable for packages which you want to edit and recompile. - -2. An **external package** is any package which is not listed in the - ``packages`` field. The source code for external packages is usually - retrieved from Hackage. - -When an external package does not depend on an inplace package, it can -be built and installed to a **global** store, which can be shared across -projects. These build products are identified by a hash based on all of -the inputs which influence the compilation of a package (flags, -dependency selection, etc.). Just as in Nix, these hashes uniquely -identify the result of a build; if we compute this identifier and we -find that we already have this ID built, we can just use the already -built version. - -The global package store is ``~/.cabal/store`` (configurable via -global `store-dir` option); if you need to clear your store for -whatever reason (e.g., to reclaim disk space or because the global -store is corrupted), deleting this directory is safe (``v2-build`` -will just rebuild everything it needs on its next invocation). - -This split motivates some of the UI choices for Nix-style local build -commands. For example, flags passed to ``cabal v2-build`` are only -applied to *local* packages, so that adding a flag to -``cabal v2-build`` doesn't necessitate a rebuild of *every* transitive -dependency in the global package store. - -In cabal-install 2.0 and above, Nix-style local builds also take advantage of a -new Cabal library feature, `per-component -builds `__, -where each component of a package is configured and built separately. -This can massively speed up rebuilds of packages with lots of components -(e.g., a package that defines multiple executables), as only one -executable needs to be rebuilt. Packages that use Custom setup scripts -are not currently built on a per-component basis. - -Where are my build products? ----------------------------- - -A major deficiency in the current implementation of v2-build is that -there is no programmatic way to access the location of build products. -The location of the build products is intended to be an internal -implementation detail of v2-build, but we also understand that many -unimplemented features can only be reasonably worked around by -accessing build products directly. - -The location where build products can be found varies depending on the -version of cabal-install: - -- In cabal-install-1.24, the dist directory for a package ``p-0.1`` is - stored in ``dist-newstyle/build/p-0.1``. For example, if you built an - executable or test suite named ``pexe``, it would be located at - ``dist-newstyle/build/p-0.1/build/pexe/pexe``. - -- In cabal-install-2.0, the dist directory for a package ``p-0.1`` - defining a library built with GHC 8.0.1 on 64-bit Linux is - ``dist-newstyle/build/x86_64-linux/ghc-8.0.1/p-0.1``. When - per-component builds are enabled (any non-Custom package), a - subcomponent like an executable or test suite named ``pexe`` will be - stored at - ``dist-newstyle/build/x86_64-linux/ghc-8.0.1/p-0.1/c/pexe``; thus, - the full path of the executable is - ``dist-newstyle/build/x86_64-linux/ghc-8.0.1/p-0.1/c/pexe/build/pexe/pexe`` - (you can see why we want this to be an implementation detail!) - -- In cabal-install-2.2 and above, the ``/c/`` part of the above path - is replaced with one of ``/l/``, ``/x/``, ``/f/``, ``/t/``, or - ``/b/``, depending on the type of component (sublibrary, - executable, foreign library, test suite, or benchmark - respectively). So the full path to an executable named ``pexe`` - compiled with GHC 8.0.1 on a 64-bit Linux is now - ``dist-newstyle/build/x86_64-linux/ghc-8.0.1/p-0.1/x/pexe/build/pexe/pexe``; - for a benchmark named ``pbench`` it now is - ``dist-newstyle/build/x86_64-linux/ghc-8.0.1/p-0.1/b/pbench/build/pbench/pbench``; - - -The paths are a bit longer in 2.0 and above but the benefit is that you can -transparently have multiple builds with different versions of GHC. We -plan to add the ability to create aliases for certain build -configurations, and more convenient paths to access particularly useful -build products like executables. - -Caching -------- - -Nix-style local builds sport a robust caching system which helps to reduce -the time it takes to execute a rebuild cycle. While the details of how -``cabal-install`` does caching are an implementation detail and may -change in the future, knowing what gets cached is helpful for -understanding the performance characteristics of invocations to -``v2-build``. The cached intermediate results are stored in -``dist-newstyle/cache``; this folder can be safely deleted to clear the -cache. - -The following intermediate results are cached in the following files in -this folder (the most important two are first): - -``solver-plan`` (binary) - The result of calling the dependency solver, assuming that the - Hackage index, local ``cabal.project`` file, and local ``cabal`` - files are unmodified. (Notably, we do NOT have to dependency solve - again if new build products are stored in the global store; the - invocation of the dependency solver is independent of what is - already available in the store.) -``source-hashes`` (binary) - The hashes of all local source files. When all local source files of - a local package are unchanged, ``cabal v2-build`` will skip - invoking ``setup build`` entirely (saving us from a possibly - expensive call to ``ghc --make``). The full list of source files - participating in compilation is determined using - ``cabal sdist --list-only``. Thus if you do not list all your - source files in a Cabal file, Cabal may fail to recompile when you - edit them. -``config`` (same format as ``cabal.project``) - The full project configuration, merged from ``cabal.project`` (and - friends) as well as the command line arguments. -``compiler`` (binary) - The configuration of the compiler being used to build the project. -``improved-plan`` (binary) - Like ``solver-plan``, but with all non-inplace packages improved - into pre-existing copies from the store. -``plan.json`` (JSON) - A JSON serialization of the computed install plan intended - for integrating ``cabal`` with external tooling. - The `cabal-plan `__ - package provides a library for parsing ``plan.json`` files into a - Haskell data structure as well as an example tool showing possible - applications. - - .. todo:: - - Document JSON schema (including version history of schema) - - -Note that every package also has a local cache managed by the Cabal -build system, e.g., in ``$distdir/cache``. diff --git a/cabal/Cabal/doc/references.inc b/cabal/Cabal/doc/references.inc deleted file mode 100644 --- a/cabal/Cabal/doc/references.inc +++ /dev/null @@ -1,26 +0,0 @@ -.. -*- rst -*- - This file contains commonly used link-references - See also "extlinks" in conf.py - -.. _`Package Versioning Policy`: -.. _PVP: http://pvp.haskell.org/ - -.. _Hackage: http://hackage.haskell.org/ - -.. _Haskell: http://www.haskell.org/ - -.. _Haddock: http://www.haskell.org/haddock/ - -.. _Alex: http://www.haskell.org/alex/ - -.. _Happy: http://www.haskell.org/happy/ - -.. _Hoogle: http://www.haskell.org/hoogle/ - -.. _HsColour: http://www.cs.york.ac.uk/fp/darcs/hscolour/ - -.. _cpphs: http://projects.haskell.org/cpphs/ - -.. _ABNF: https://tools.ietf.org/html/rfc5234 - -.. _Backpack: https://gitlab.haskell.org/ghc/ghc/-/wikis/backpack diff --git a/cabal/Cabal/doc/requirements.txt b/cabal/Cabal/doc/requirements.txt deleted file mode 100644 --- a/cabal/Cabal/doc/requirements.txt +++ /dev/null @@ -1,2 +0,0 @@ -sphinx == 3.1.* -sphinx_rtd_theme diff --git a/cabal/Cabal/doc/setup-commands.rst b/cabal/Cabal/doc/setup-commands.rst deleted file mode 100644 --- a/cabal/Cabal/doc/setup-commands.rst +++ /dev/null @@ -1,1422 +0,0 @@ -Setup.hs Commands -================= - -.. highlight:: console - -The low-level Cabal interface is implemented using ``Setup.hs`` scripts. -You should prefer using higher level interface provided by -nix-style builds. - -:: - - $ runhaskell Setup.hs [command] [option...] - -For the summary of the command syntax, run: - -:: - - $ runhaskell Setup.hs --help - -Building and installing a system package ----------------------------------------- - -:: - - $ runhaskell Setup.hs configure --ghc - $ runhaskell Setup.hs build - $ runhaskell Setup.hs install - -The first line readies the system to build the tool using GHC; for -example, it checks that GHC exists on the system. The second line -performs the actual building, while the last both copies the build -results to some permanent place and registers the package with GHC. - -.. note :: - - Global installing of packages is not recommended. - The :ref:`Nix-style builds` is the preferred way of building and installing - packages. - -Creating a binary package -------------------------- - -When creating binary packages (e.g. for Red Hat or Debian) one needs to -create a tarball that can be sent to another system for unpacking in the -root directory: - -:: - - $ runhaskell Setup.hs configure --prefix=/usr - $ runhaskell Setup.hs build - $ runhaskell Setup.hs copy --destdir=/tmp/mypkg - $ tar -czf mypkg.tar.gz /tmp/mypkg/ - -If the package contains a library, you need two additional steps: - -:: - - $ runhaskell Setup.hs register --gen-script - $ runhaskell Setup.hs unregister --gen-script - -This creates shell scripts ``register.sh`` and ``unregister.sh``, which -must also be sent to the target system. After unpacking there, the -package must be registered by running the ``register.sh`` script. The -``unregister.sh`` script would be used in the uninstall procedure of the -package. Similar steps may be used for creating binary packages for -Windows. - -The following options are understood by all commands: - -.. program:: setup - -.. option:: --help, -h or -? - - List the available options for the command. - -.. option:: --verbose=n or -v n - - Set the verbosity level (0-3). The normal level is 1; a missing *n* - defaults to 2. - - There is also an extended version of this command which can be - used to fine-tune the verbosity of output. It takes the - form ``[silent|normal|verbose|debug]``\ *flags*, where *flags* - is a list of ``+`` flags which toggle various aspects of - output. At the moment, only ``+callsite`` and ``+callstack`` - are supported, which respectively toggle call site and call - stack printing (these are only supported if Cabal - is built with a sufficiently recent GHC.) - -The various commands and the additional options they support are -described below. In the simple build infrastructure, any other options -will be reported as errors. - -.. _setup-configure: - -runhaskell Setup.hs configure ------------------------------ - -.. program:: runhaskell Setup.hs configure - -Prepare to build the package. Typically, this step checks that the -target platform is capable of building the package, and discovers -platform-specific features that are needed during the build. - -The user may also adjust the behaviour of later stages using the options -listed in the following subsections. In the simple build infrastructure, -the values supplied via these options are recorded in a private file -read by later stages. - -If a user-supplied ``configure`` script is run (see the section on -`system-dependent -parameters `__ or -on `complex -packages `__), it is -passed the :option:`--with-hc-pkg`, :option:`--prefix`, :option:`--bindir`, -:option:`--libdir`, :option:`--dynlibdir`, :option:`--datadir`, :option:`--libexecdir` and -:option:`--sysconfdir` options. In addition the value of the -:option:`--with-compiler` option is passed in a :option:`--with-hc-pkg` option -and all options specified with :option:`--configure-option` are passed on. - -.. note:: - `GNU autoconf places restrictions on paths, including the directory - that the package is built from. - `_ - The errors produced when this happens can be obscure; Cabal attempts to - detect and warn in this situation, but it is not perfect. - -In Cabal 2.0, support for a single positional argument was added to -``runhaskell Setup.hs configure`` This makes Cabal configure the specific component to -be configured. Specified names can be qualified with ``lib:`` or -``exe:`` in case just a name is ambiguous (as would be the case for a -package named ``p`` which has a library and an executable named ``p``.) -This has the following effects: - -- Subsequent invocations of ``cabal build``, ``register``, etc. operate only - on the configured component. - -- Cabal requires all "internal" dependencies (e.g., an executable - depending on a library defined in the same package) must be found in - the set of databases via :option:`--package-db` (and related flags): these - dependencies are assumed to be up-to-date. A dependency can be - explicitly specified using :option:`--dependency` simply by giving the name - of the internal library; e.g., the dependency for an internal library - named ``foo`` is given as - ``--dependency=pkg-internal=pkg-1.0-internal-abcd``. - -- Only the dependencies needed for the requested component are - required. Similarly, when :option:`--exact-configuration` is specified, - it's only necessary to specify :option:`--dependency` for the component. - (As mentioned previously, you *must* specify internal dependencies as - well.) - -- Internal ``build-tool-depends`` and ``build-tools`` dependencies are expected - to be in the ``PATH`` upon subsequent invocations of ``setup``. - -Full details can be found in the `Componentized Cabal -proposal `__. - -Programs used for building -^^^^^^^^^^^^^^^^^^^^^^^^^^ - -The following options govern the programs used to process the source -files of a package: - -.. option:: --ghc or -g, --jhc, --lhc, --uhc - - Specify which Haskell implementation to use to build the package. At - most one of these flags may be given. If none is given, the - implementation under which the setup script was compiled or - interpreted is used. - -.. option:: --with-compiler=path or -w *path* - - Specify the path to a particular compiler. If given, this must match - the implementation selected above. The default is to search for the - usual name of the selected implementation. - - This flag also sets the default value of the :option:`--with-hc-pkg` - option to the package tool for this compiler. Check the output of - ``runhaskell Setup.hs configure -v`` to ensure that it finds the right package - tool (or use :option:`--with-hc-pkg` explicitly). - -.. option:: --with-hc-pkg=path - - Specify the path to the package tool, e.g. ``ghc-pkg``. The package - tool must be compatible with the compiler specified by - :option:`--with-compiler`. If this option is omitted, the default value is - determined from the compiler selected. - -.. option:: --with-prog=path - - Specify the path to the program *prog*. Any program known to Cabal - can be used in place of *prog*. It can either be a fully path or the - name of a program that can be found on the program search path. For - example: ``--with-ghc=ghc-6.6.1`` or - ``--with-cpphs=/usr/local/bin/cpphs``. The full list of accepted - programs is not enumerated in this user guide. Rather, run - ``cabal install --help`` to view the list. - -.. option:: --prog-options=options - - Specify additional options to the program *prog*. Any program known - to Cabal can be used in place of *prog*. For example: - ``--alex-options="--template=mytemplatedir/"``. The *options* is - split into program options based on spaces. Any options containing - embedded spaced need to be quoted, for example - ``--foo-options='--bar="C:\Program File\Bar"'``. As an alternative - that takes only one option at a time but avoids the need to quote, - use :option:`--prog-option` instead. - -.. option:: --prog-option=option - - Specify a single additional option to the program *prog*. For - passing an option that contain embedded spaces, such as a file name - with embedded spaces, using this rather than :option:`--prog-options` - means you do not need an additional level of quoting. Of course if you - are using a command shell you may still need to quote, for example - ``--foo-options="--bar=C:\Program File\Bar"``. - -All of the options passed with either :option:`--prog-options` -or :option:`--prog-option` are passed in the order they were -specified on the configure command line. - -Installation paths -^^^^^^^^^^^^^^^^^^ - -The following options govern the location of installed files from a -package: - -.. option:: --prefix=dir - - The root of the installation. For example for a global install you - might use ``/usr/local`` on a Unix system, or ``C:\Program Files`` - on a Windows system. The other installation paths are usually - subdirectories of *prefix*, but they don't have to be. - - In the simple build system, *dir* may contain the following path - variables: ``$pkgid``, ``$pkg``, ``$version``, ``$compiler``, - ``$os``, ``$arch``, ``$abi``, ``$abitag`` - -.. option:: --bindir=dir - - Executables that the user might invoke are installed here. - - In the simple build system, *dir* may contain the following path - variables: ``$prefix``, ``$pkgid``, ``$pkg``, ``$version``, - ``$compiler``, ``$os``, ``$arch``, ``$abi``, ``$abitag`` - -.. option:: --libdir=dir - - Object-code libraries are installed here. - - In the simple build system, *dir* may contain the following path - variables: ``$prefix``, ``$bindir``, ``$pkgid``, ``$pkg``, - ``$version``, ``$compiler``, ``$os``, ``$arch``, ``$abi``, - ``$abitag`` - -.. option:: --dynlibdir=dir - - Dynamic libraries are installed here. - - By default, this is set to `$libdir/$abi`, which is usually not equal to - `$libdir/$libsubdir`. - - In the simple build system, *dir* may contain the following path - variables: ``$prefix``, ``$bindir``, ``$libdir``, ``$pkgid``, ``$pkg``, - ``$version``, ``$compiler``, ``$os``, ``$arch``, ``$abi``, - ``$abitag`` - -.. option:: --libexecdir=dir - - Executables that are not expected to be invoked directly by the user - are installed here. - - In the simple build system, *dir* may contain the following path - variables: ``$prefix``, ``$bindir``, ``$libdir``, ``$libsubdir``, - ``$pkgid``, ``$pkg``, ``$version``, ``$compiler``, ``$os``, - ``$arch``, ``$abi``, ``$abitag`` - -.. option:: --datadir=dir - - Architecture-independent data files are installed here. - - In the simple build system, *dir* may contain the following path - variables: ``$prefix``, ``$bindir``, ``$libdir``, ``$libsubdir``, - ``$pkgid``, ``$pkg``, ``$version``, ``$compiler``, ``$os``, - ``$arch``, ``$abi``, ``$abitag`` - -.. option:: --sysconfdir=dir - - Installation directory for the configuration files. - - In the simple build system, *dir* may contain the following path - variables: ``$prefix``, ``$bindir``, ``$libdir``, ``$libsubdir``, - ``$pkgid``, ``$pkg``, ``$version``, ``$compiler``, ``$os``, - ``$arch``, ``$abi``, ``$abitag`` - -In addition the simple build system supports the following installation -path options: - -.. option:: --libsubdir=dir - - A subdirectory of *libdir* in which libraries are actually installed. For - example, in the simple build system on Unix, the default *libdir* is - ``/usr/local/lib``, and *libsubdir* contains the compiler ABI and package - identifier, - e.g. ``x86_64-linux-ghc-8.0.2/mypkg-0.1.0-IxQNmCA7qrSEQNkoHSF7A``, so - libraries would be installed in - ``/usr/local/lib/x86_64-linux-ghc-8.0.2/mypkg-0.1.0-IxQNmCA7qrSEQNkoHSF7A/``. - - *dir* may contain the following path variables: ``$pkgid``, - ``$pkg``, ``$version``, ``$compiler``, ``$os``, ``$arch``, ``$abi``, - ``$abitag`` - -.. option:: --libexecsubdir=dir - - A subdirectory of *libexecdir* in which private executables are - installed. For example, in the simple build system on Unix, the default - *libexecdir* is ``/usr/local/libexec``, and *libsubdir* is - ``x86_64-linux-ghc-8.0.2/mypkg-0.1.0``, so private executables would be - installed in ``/usr/local/libexec/x86_64-linux-ghc-8.0.2/mypkg-0.1.0/`` - - *dir* may contain the following path variables: ``$pkgid``, - ``$pkg``, ``$version``, ``$compiler``, ``$os``, ``$arch``, ``$abi``, - ``$abitag`` - -.. option:: --datasubdir=dir - - A subdirectory of *datadir* in which data files are actually - installed. - - *dir* may contain the following path variables: ``$pkgid``, - ``$pkg``, ``$version``, ``$compiler``, ``$os``, ``$arch``, ``$abi``, - ``$abitag`` - -.. option:: --docdir=dir - - Documentation files are installed relative to this directory. - - *dir* may contain the following path variables: ``$prefix``, - ``$bindir``, ``$libdir``, ``$libsubdir``, ``$datadir``, - ``$datasubdir``, ``$pkgid``, ``$pkg``, ``$version``, ``$compiler``, - ``$os``, ``$arch``, ``$abi``, ``$abitag`` - -.. option:: --htmldir=dir - - HTML documentation files are installed relative to this directory. - - *dir* may contain the following path variables: ``$prefix``, - ``$bindir``, ``$libdir``, ``$libsubdir``, ``$datadir``, - ``$datasubdir``, ``$docdir``, ``$pkgid``, ``$pkg``, ``$version``, - ``$compiler``, ``$os``, ``$arch``, ``$abi``, ``$abitag`` - -.. option:: --program-prefix=prefix - - Prepend *prefix* to installed program names. - - *prefix* may contain the following path variables: ``$pkgid``, - ``$pkg``, ``$version``, ``$compiler``, ``$os``, ``$arch``, ``$abi``, - ``$abitag`` - -.. option:: --program-suffix=suffix - - Append *suffix* to installed program names. The most obvious use for - this is to append the program's version number to make it possible - to install several versions of a program at once: - ``--program-suffix='$version'``. - - *suffix* may contain the following path variables: ``$pkgid``, - ``$pkg``, ``$version``, ``$compiler``, ``$os``, ``$arch``, ``$abi``, - ``$abitag`` - -Path variables in the simple build system -""""""""""""""""""""""""""""""""""""""""" - -For the simple build system, there are a number of variables that can be -used when specifying installation paths. The defaults are also specified -in terms of these variables. A number of the variables are actually for -other paths, like ``$prefix``. This allows paths to be specified -relative to each other rather than as absolute paths, which is important -for building relocatable packages (see `prefix -independence <#prefix-independence>`__). - -$prefix - The path variable that stands for the root of the installation. For - an installation to be relocatable, all other installation paths must - be relative to the ``$prefix`` variable. -$bindir - The path variable that expands to the path given by the :option:`--bindir` - configure option (or the default). -$libdir - As above but for :option:`--libdir` -$libsubdir - As above but for :option:`--libsubdir` -$dynlibdir - As above but for :option:`--dynlibdir` -$datadir - As above but for :option:`--datadir` -$datasubdir - As above but for :option:`--datasubdir` -$docdir - As above but for :option:`--docdir` -$pkgid - The name and version of the package, e.g. ``mypkg-0.2`` -$pkg - The name of the package, e.g. ``mypkg`` -$version - The version of the package, e.g. ``0.2`` -$compiler - The compiler being used to build the package, e.g. ``ghc-6.6.1`` -$os - The operating system of the computer being used to build the - package, e.g. ``linux``, ``windows``, ``osx``, ``freebsd`` or - ``solaris`` -$arch - The architecture of the computer being used to build the package, - e.g. ``i386``, ``x86_64``, ``ppc`` or ``sparc`` -$abitag - An optional tag that a compiler can use for telling incompatible - ABI's on the same architecture apart. GHCJS encodes the underlying - GHC version in the ABI tag. -$abi - A shortcut for getting a path that completely identifies the - platform in terms of binary compatibility. Expands to the same value - as ``$arch-$os-compiler-$abitag`` if the compiler uses an abi tag, - ``$arch-$os-$compiler`` if it doesn't. - -Paths in the simple build system -"""""""""""""""""""""""""""""""" - -For the simple build system, the following defaults apply: - -.. list-table:: Default installation paths - - * - Option - - Unix Default - - Windows Default - * - :option:`--prefix` (global) - - ``/usr/local`` - - ``%PROGRAMFILES%\Haskell`` - * - :option:`--prefix` (per-user) - - ``$HOME/.cabal`` - - ``%APPDATA%\cabal`` - * - :option:`--bindir` - - ``$prefix/bin`` - - ``$prefix\bin`` - * - :option:`--libdir` - - ``$prefix/lib`` - - ``$prefix`` - * - :option:`--libsubdir` (others) - - ``$pkgid/$compiler`` - - ``$pkgid\$compiler`` - * - :option:`--dynlibdir` - - ``$libdir/$abi`` - - ``$libdir\$abi`` - * - :option:`--libexecdir` - - ``$prefix/libexec`` - - ``$prefix\$pkgid`` - * - :option:`--datadir` (executable) - - ``$prefix/share`` - - ``$prefix`` - * - :option:`--datadir` (library) - - ``$prefix/share`` - - ``%PROGRAMFILES%\Haskell`` - * - :option:`--datasubdir` - - ``$pkgid`` - - ``$pkgid`` - * - :option:`--docdir` - - ``$datadir/doc/$pkgid`` - - ``$prefix\doc\$pkgid`` - * - :option:`--sysconfdir` - - ``$prefix/etc`` - - ``$prefix\etc`` - * - :option:`--htmldir` - - ``$docdir/html`` - - ``$docdir\html`` - * - :option:`--program-prefix` - - (empty) - - (empty) - * - :option:`--program-suffix` - - (empty) - - (empty) - -Prefix-independence -""""""""""""""""""" - -On Windows it is possible to obtain the pathname of the running program. -This means that we can construct an installable executable package that -is independent of its absolute install location. The executable can find -its auxiliary files by finding its own path and knowing the location of -the other files relative to ``$bindir``. Prefix-independence is -particularly useful: it means the user can choose the install location -(i.e. the value of ``$prefix``) at install-time, rather than having to -bake the path into the binary when it is built. - -In order to achieve this, we require that for an executable on Windows, -all of ``$bindir``, ``$libdir``, ``$dynlibdir``, ``$datadir`` and ``$libexecdir`` begin -with ``$prefix``. If this is not the case then the compiled executable -will have baked-in all absolute paths. - -The application need do nothing special to achieve prefix-independence. -If it finds any files using ``getDataFileName`` and the `other functions -provided for the -purpose `__, -the files will be accessed relative to the location of the current -executable. - -A library cannot (currently) be prefix-independent, because it will be -linked into an executable whose file system location bears no relation -to the library package. - -Controlling Flag Assignments -^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - -Flag assignments (see the `resolution of conditions and -flags `__) -can be controlled with the following command line options. - -.. option:: -f flagname or -f -flagname - - Force the specified flag to ``true`` or ``false`` (if preceded with - a ``-``). Later specifications for the same flags will override - earlier, i.e., specifying ``-fdebug -f-debug`` is equivalent to - ``-f-debug`` - -.. option:: --flags=flagspecs - - Same as ``-f``, but allows specifying multiple flag assignments at - once. The parameter is a space-separated list of flag names (to - force a flag to ``true``), optionally preceded by a ``-`` (to force - a flag to ``false``). For example, - ``--flags="debug -feature1 feature2"`` is equivalent to - ``-fdebug -f-feature1 -ffeature2``. - -Building Test Suites -^^^^^^^^^^^^^^^^^^^^ - -.. option:: --enable-tests - - Build the test suites defined in the package description file during - the ``build`` stage. Check for dependencies required by the test - suites. If the package is configured with this option, it will be - possible to run the test suites with the ``test`` command after the - package is built. - -.. option:: --disable-tests - - (default) Do not build any test suites during the ``build`` stage. - Do not check for dependencies required only by the test suites. It - will not be possible to invoke the ``test`` command without - reconfiguring the package. - -.. option:: --enable-coverage - - Build libraries and executables (including test suites) with Haskell - Program Coverage enabled. Running the test suites will automatically - generate coverage reports with HPC. - -.. option:: --disable-coverage - - (default) Do not enable Haskell Program Coverage. - -Miscellaneous options -^^^^^^^^^^^^^^^^^^^^^ - -.. option:: --user - - Does a per-user installation. This changes the `default installation - prefix <#paths-in-the-simple-build-system>`__. It also allow - dependencies to be satisfied by the user's package database, in - addition to the global database. This also implies a default of - ``--user`` for any subsequent ``install`` command, as packages - registered in the global database should not depend on packages - registered in a user's database. - -.. option:: --global - - (default) Does a global installation. In this case package - dependencies must be satisfied by the global package database. All - packages in the user's package database will be ignored. Typically - the final installation step will require administrative privileges. - -.. option:: --package-db=db - - Allows package dependencies to be satisfied from this additional - package database *db* in addition to the global package database. - All packages in the user's package database will be ignored. The - interpretation of *db* is implementation-specific. Typically it will - be a file or directory. Not all implementations support arbitrary - package databases. - - This pushes an extra db onto the db stack. The :option:`--global` and - :option:`--user` mode switches add the respective [Global] and [Global, - User] dbs to the initial stack. There is a compiler-implementation - constraint that the global db must appear first in the stack, and if - the user one appears at all, it must appear immediately after the - global db. - - To reset the stack, use ``--package-db=clear``. - -.. option:: --ipid=ipid - - Specifies the *installed package identifier* of the package to be - built; this identifier is passed on to GHC and serves as the basis - for linker symbols and the ``id`` field in a ``ghc-pkg`` - registration. When a package has multiple components, the actual - component identifiers are derived off of this identifier (e.g., an - internal library ``foo`` from package ``p-0.1-abcd`` will get the - identifier ``p-0.1-abcd-foo``. - -.. option:: --cid=cid - - Specifies the *component identifier* of the component being built; - this is only valid if you are configuring a single component. - -.. option:: --default-user-config=file - - Allows a "default" ``cabal.config`` freeze file to be passed in - manually. This file will only be used if one does not exist in the - project directory already. Typically, this can be set from the - global cabal ``config`` file so as to provide a default set of - partial constraints to be used by projects, providing a way for - users to peg themselves to stable package collections. - -.. option:: --enable-optimization[=n] or -O [n] - - (default) Build with optimization flags (if available). This is - appropriate for production use, taking more time to build faster - libraries and programs. - - The optional *n* value is the optimisation level. Some compilers - support multiple optimisation levels. The range is 0 to 2. Level 0 - is equivalent to :option:`--disable-optimization`, level 1 is the - default if no *n* parameter is given. Level 2 is higher optimisation - if the compiler supports it. Level 2 is likely to lead to longer - compile times and bigger generated code. - - When optimizations are enabled, Cabal passes ``-O2`` to the C compiler. - -.. option:: --disable-optimization - - Build without optimization. This is suited for development: building - will be quicker, but the resulting library or programs will be - slower. - -.. option:: --enable-profiling - - Build libraries and executables with profiling enabled (for - compilers that support profiling as a separate mode). For this to - work, all libraries used by this package must also have been built - with profiling support. For libraries this involves building an - additional instance of the library in addition to the normal - non-profiling instance. For executables it changes the single - executable to be built in profiling mode. - - This flag covers both libraries and executables, but can be - overridden by the :option:`--enable-library-profiling` flag. - - See also the :option:`--profiling-detail` flag below. - -.. option:: --disable-profiling - - (default) Do not enable profiling in generated libraries and - executables. - -.. option:: --enable-library-profiling or -p - - As with :option:`--enable-profiling` above, but it applies only for - libraries. So this generates an additional profiling instance of the - library in addition to the normal non-profiling instance. - - The :option:`--enable-profiling` flag controls the profiling mode for both - libraries and executables, but if different modes are desired for - libraries versus executables then use :option:`--enable-library-profiling` - as well. - -.. option:: --disable-library-profiling - - (default) Do not generate an additional profiling version of the library. - -.. option:: --profiling-detail[=level] - - Some compilers that support profiling, notably GHC, can allocate - costs to different parts of the program and there are different - levels of granularity or detail with which this can be done. In - particular for GHC this concept is called "cost centers", and GHC - can automatically add cost centers, and can do so in different ways. - - This flag covers both libraries and executables, but can be - overridden by the :option:`--library-profiling-detail` flag. - - Currently this setting is ignored for compilers other than GHC. The - levels that cabal currently supports are: - - default - For GHC this uses ``exported-functions`` for libraries and - ``toplevel-functions`` for executables. - none - No costs will be assigned to any code within this component. - exported-functions - Costs will be assigned at the granularity of all top level - functions exported from each module. In GHC specifically, this - is for non-inline functions. - toplevel-functions - Costs will be assigned at the granularity of all top level - functions in each module, whether they are exported from the - module or not. In GHC specifically, this is for non-inline - functions. - all-functions - Costs will be assigned at the granularity of all functions in - each module, whether top level or local. In GHC specifically, - this is for non-inline toplevel or where-bound functions or - values. - - This flag is new in Cabal-1.24. Prior versions used the equivalent - of ``none`` above. - -.. option:: --library-profiling-detail[=level] - - As with :option:`--profiling-detail` above, but it applies only for - libraries. - - The level for both libraries and executables is set by the - :option:`--profiling-detail` flag, but if different levels are desired - for libraries versus executables then use - :option:`--library-profiling-detail` as well. - -.. option:: --enable-library-vanilla - - (default) Build ordinary libraries (as opposed to profiling - libraries). This is independent of the - :option:`--enable-library-profiling` option. If you enable both, you get - both. - -.. option:: --disable-library-vanilla - - Do not build ordinary libraries. This is useful in conjunction with - :option:`--enable-library-profiling` to build only profiling libraries, - rather than profiling and ordinary libraries. - -.. option:: --enable-library-for-ghci - - (default) Build libraries suitable for use with GHCi. - -.. option:: --disable-library-for-ghci - - Not all platforms support GHCi and indeed on some platforms, trying - to build GHCi libs fails. In such cases this flag can be used as a - workaround. - -.. option:: --enable-split-objs - - Use the GHC ``-split-objs`` feature when building the library. This - reduces the final size of the executables that use the library by - allowing them to link with only the bits that they use rather than - the entire library. The downside is that building the library takes - longer and uses considerably more memory. - -.. option:: --disable-split-objs - - (default) Do not use the GHC ``-split-objs`` feature. This makes - building the library quicker but the final executables that use the - library will be larger. - -.. option:: --enable-executable-stripping - - (default) When installing binary executable programs, run the - ``strip`` program on the binary. This can considerably reduce the - size of the executable binary file. It does this by removing - debugging information and symbols. While such extra information is - useful for debugging C programs with traditional debuggers it is - rarely helpful for debugging binaries produced by Haskell compilers. - - Not all Haskell implementations generate native binaries. For such - implementations this option has no effect. - -.. option:: --disable-executable-stripping - - Do not strip binary executables during installation. You might want - to use this option if you need to debug a program using gdb, for - example if you want to debug the C parts of a program containing - both Haskell and C code. Another reason is if your are building a - package for a system which has a policy of managing the stripping - itself (such as some Linux distributions). - -.. option:: --enable-shared - - Build shared library. This implies a separate compiler run to - generate position independent code as required on most platforms. - -.. option:: --disable-shared - - (default) Do not build shared library. - -.. option:: --enable-static - - Build a static library. This passes ``-staticlib`` to GHC (available - for iOS, and with 8.4 more platforms). The result is an archive ``.a`` - containing all dependent haskell libararies combined. - -.. option:: --disable-static - - (default) Do not build a static library. - -.. option:: --enable-executable-dynamic - - Link dependent Haskell libraries into executables dynamically. - The executable's library dependencies must have been - built as shared objects. This implies :option:`--enable-shared` - unless :option:`--disable-shared` is explicitly specified. - -.. option:: --disable-executable-dynamic - - (default) Link dependent Haskell libraries into executables statically. - Non-Haskell (C) libraries are still linked dynamically, including libc, - so the result is still not a fully static executable - unless :option:`--enable-executable-static` is given. - -.. option:: --enable-executable-static - - Build fully static executables. - This link all dependent libraries into executables statically, - including libc. - -.. option:: --disable-executable-static - - (default) Do not build fully static executables. - -.. option:: --configure-option=str - - An extra option to an external ``configure`` script, if one is used - (see the section on `system-dependent - parameters `__). - There can be several of these options. - -.. option:: --extra-include-dirs[=dir] - - An extra directory to search for C header files. You can use this - flag multiple times to get a list of directories. - - You might need to use this flag if you have standard system header - files in a non-standard location that is not mentioned in the - package's ``.cabal`` file. Using this option has the same affect as - appending the directory *dir* to the ``include-dirs`` field in each - library and executable in the package's ``.cabal`` file. The - advantage of course is that you do not have to modify the package at - all. These extra directories will be used while building the package - and for libraries it is also saved in the package registration - information and used when compiling modules that use the library. - -.. option:: --extra-lib-dirs[=dir] - - An extra directory to search for system libraries files. You can use - this flag multiple times to get a list of directories. - -.. option:: --extra-framework-dirs[=dir] - - An extra directory to search for frameworks (OS X only). You can use - this flag multiple times to get a list of directories. - - You might need to use this flag if you have standard system - libraries in a non-standard location that is not mentioned in the - package's ``.cabal`` file. Using this option has the same affect as - appending the directory *dir* to the ``extra-lib-dirs`` field in - each library and executable in the package's ``.cabal`` file. The - advantage of course is that you do not have to modify the package at - all. These extra directories will be used while building the package - and for libraries it is also saved in the package registration - information and used when compiling modules that use the library. - -.. option:: --dependency[=pkgname=ipid] - - Specify that a particular dependency should used for a particular - package name. In particular, it declares that any reference to - *pkgname* in a :pkg-field:`build-depends` should be resolved to - *ipid*. - -.. option:: --exact-configuration - - This changes Cabal to require every dependency be explicitly - specified using :option:`--dependency`, rather than use Cabal's (very - simple) dependency solver. This is useful for programmatic use of - Cabal's API, where you want to error if you didn't specify enough - :option:`--dependency` flags. - -.. option:: --allow-newer[=pkgs], --allow-older[=pkgs] - - Selectively relax upper or lower bounds in dependencies without - editing the package description respectively. - - The following description focuses on upper bounds and the - :option:`--allow-newer` flag, but applies analogously to - :option:`--allow-older` and lower bounds. :option:`--allow-newer` - and :option:`--allow-older` can be used at the same time. - - If you want to install a package A that depends on B >= 1.0 && < - 2.0, but you have the version 2.0 of B installed, you can compile A - against B 2.0 by using ``cabal install --allow-newer=B A``. This - works for the whole package index: if A also depends on C that in - turn depends on B < 2.0, C's dependency on B will be also relaxed. - - Example: - - :: - - $ cd foo - $ cabal configure - Resolving dependencies... - cabal: Could not resolve dependencies: - [...] - $ cabal configure --allow-newer - Resolving dependencies... - Configuring foo... - - Additional examples: - - :: - - # Relax upper bounds in all dependencies. - $ cabal install --allow-newer foo - - # Relax upper bounds only in dependencies on bar, baz and quux. - $ cabal install --allow-newer=bar,baz,quux foo - - # Relax the upper bound on bar and force bar==2.1. - $ cabal install --allow-newer=bar --constraint="bar==2.1" foo - - It's also possible to limit the scope of :option:`--allow-newer` to single - packages with the ``--allow-newer=scope:dep`` syntax. This means - that the dependency on ``dep`` will be relaxed only for the package - ``scope``. - - Example: - - :: - - # Relax upper bound in foo's dependency on base; also relax upper bound in - # every package's dependency on lens. - $ cabal install --allow-newer=foo:base,lens - - # Relax upper bounds in foo's dependency on base and bar's dependency - # on time; also relax the upper bound in the dependency on lens specified by - # any package. - $ cabal install --allow-newer=foo:base,lens --allow-newer=bar:time - - Finally, one can enable :option:`--allow-newer` permanently by setting - ``allow-newer: True`` in the ``~/.cabal/config`` file. Enabling - 'allow-newer' selectively is also supported in the config file - (``allow-newer: foo, bar, baz:base``). - -.. option:: --constraint=constraint - - Restrict solutions involving a package to given version - bounds, flag settings, and other properties. For example, to - consider only install plans that use version 2.1 of ``bar`` - or do not use ``bar`` at all, write: - - :: - - $ cabal install --constraint="bar == 2.1" - - Version bounds have the same syntax as :pkg-field:`build-depends`. - As a special case, the following prevents ``bar`` from being - used at all: - - :: - - # Note: this is just syntax sugar for '> 1 && < 1', and is - # supported by build-depends. - $ cabal install --constraint="bar -none" - - You can also specify flag assignments: - - :: - - # Require bar to be installed with the foo flag turned on and - # the baz flag turned off. - $ cabal install --constraint="bar +foo -baz" - - To specify multiple constraints, you may pass the - ``constraint`` option multiple times. - - There are also some more specialized constraints, which most people - don't generally need: - - :: - - # Require that a version of bar be used that is already installed in - # the global package database. - $ cabal install --constraint="bar installed" - - # Require the local source copy of bar to be used. - # (Note: By default, if we have a local package we will - # automatically use it, so it will generally not be necessary to - # specify this.) - $ cabal install --constraint="bar source" - - # Require that bar have test suites and benchmarks enabled. - $ cabal install --constraint="bar test" --constraint="bar bench" - - By default, constraints only apply to build dependencies - (:pkg-field:`build-depends`), build dependencies of build - dependencies, and so on. Constraints normally do not apply to - dependencies of the ``Setup.hs`` script of any package - (:pkg-field:`custom-setup:setup-depends`) nor do they apply to build tools - (:pkg-field:`build-tool-depends`) or the dependencies of build - tools. To explicitly apply a constraint to a setup or build - tool dependency, you can add a qualifier to the constraint as - follows: - - :: - - # Example use of the 'any' qualifier. This constraint - # applies to package bar anywhere in the dependency graph. - $ cabal install --constraint="any.bar == 1.0" - - :: - - # Example uses of 'setup' qualifiers. - - # This constraint applies to package bar when it is a - # dependency of any Setup.hs script. - $ cabal install --constraint="setup.bar == 1.0" - - # This constraint applies to package bar when it is a - # dependency of the Setup.hs script of package foo. - $ cabal install --constraint="foo:setup.bar == 1.0" - - .. TODO: Uncomment this example once we decide on a syntax for 'exe'. - .. # Example use of the 'exe' (executable build tool) - # qualifier. This constraint applies to package baz when it - # is a dependency of the build tool bar being used to - # build package foo. - $ cabal install --constraint="foo:bar:exe.baz == 1.0" - -.. option:: --preference=preference - - Specify a soft constraint on versions of a package. The solver will - attempt to satisfy these preferences on a "best-effort" basis. - -.. option:: --disable-response-files - - Enable workaround for older versions of programs such as ``ar`` or - ``ld`` that do not support response file arguments (i.e. ``@file`` - arguments). You may want this flag only if you specify custom ar - executable. For system ``ar`` or the one bundled with ``ghc`` on - Windows the ``cabal`` should do the right thing and hence should - normally not require this flag. - -.. _setup-build: - -runhaskell Setup.hs build -------------------------- - -Perform any preprocessing or compilation needed to make this package -ready for installation. - -This command takes the following options: - -.. program:: runhaskell Setup.hs build - -.. option:: --prog-options=options, --prog-option=option - - These are mostly the same as the `options configure - step <#setup-configure>`__. Unlike the options specified at the - configure step, any program options specified at the build step are - not persistent but are used for that invocation only. They options - specified at the build step are in addition not in replacement of - any options specified at the configure step. - -.. _setup-haddock: - -runhaskell Setup.hs haddock ---------------------------- - -.. program:: runhaskell Setup.hs haddock - -Build the documentation for the package using Haddock_. -By default, only the documentation for the exposed modules is generated -(but see the :option:`--executables` and :option:`--internal` flags below). - -This command takes the following options: - -.. option:: --hoogle - - Generate a file ``dist/doc/html/``\ *pkgid*\ ``.txt``, which can be - converted by Hoogle_ into a - database for searching. This is equivalent to running Haddock_ - with the ``--hoogle`` flag. - -.. option:: --html-location=url - - Specify a template for the location of HTML documentation for - prerequisite packages. The substitutions (`see - listing <#paths-in-the-simple-build-system>`__) are applied to the - template to obtain a location for each package, which will be used - by hyperlinks in the generated documentation. For example, the - following command generates links pointing at Hackage_ pages: - - runhaskell Setup.hs haddock - --html-location='http://hackage.haskell.org/packages/archive/$pkg/latest/doc/html' - - Here the argument is quoted to prevent substitution by the shell. If - this option is omitted, the location for each package is obtained - using the package tool (e.g. ``ghc-pkg``). - -.. option:: --executables - - Also run Haddock_ for the modules of all the executable programs. By default - Haddock_ is run only on the exported modules. - -.. option:: --internal - - Run Haddock_ for the all - modules, including unexposed ones, and make - Haddock_ generate documentation - for unexported symbols as well. - -.. option:: --css=path - - The argument *path* denotes a CSS file, which is passed to - Haddock_ and used to set the - style of the generated documentation. This is only needed to - override the default style that - Haddock_ uses. - -.. option:: --hyperlink-source - - Generate Haddock_ documentation integrated with HsColour_ . First, - HsColour_ is run to generate colourised code. Then Haddock_ is run to - generate HTML documentation. Each entity shown in the documentation is - linked to its definition in the colourised code. - -.. option:: --hscolour-css=path - - The argument *path* denotes a CSS file, which is passed to HsColour_ as in - - runhaskell Setup.hs hscolour --css=*path* - -.. _setup-hscolour: - -runhaskell Setup.hs hscolour ----------------------------- - -Produce colourised code in HTML format using HsColour_. Colourised code for -exported modules is put in ``dist/doc/html/``\ *pkgid*\ ``/src``. - -This command takes the following options: - -.. program:: runhaskell Setup.hs hscolour - -.. option:: --executables - - Also run HsColour_ on the sources of all executable programs. Colourised - code is put in ``dist/doc/html/``\ *pkgid*/*executable*\ ``/src``. - -.. option:: --css=path - - Use the given CSS file for the generated HTML files. The CSS file - defines the colours used to colourise code. Note that this copies - the given CSS file to the directory with the generated HTML files - (renamed to ``hscolour.css``) rather than linking to it. - -.. _setup-install: - -runhaskell Setup.hs install ---------------------------- - -.. program:: runhaskell Setup.hs install - -Copy the files into the install locations and (for library packages) -register the package with the compiler, i.e. make the modules it -contains available to programs. - -The `install locations <#installation-paths>`__ are determined by -options to `runhaskell Setup.hs configure`_. - -This command takes the following options: - -.. option:: --global - - Register this package in the system-wide database. (This is the - default, unless the :option:`runhaskell Setup.hs configure --user` option was supplied - to the ``configure`` command.) - -.. option:: --user - - Register this package in the user's local package database. (This is - the default if the :option:`runhaskell Setup.hs configure --user` option was supplied - to the ``configure`` command.) - -.. _setup-copy: - -runhaskell Setup.hs copy ------------------------- - -Copy the files without registering them. This command is mainly of use -to those creating binary packages. - -This command takes the following option: - -.. program:: runhaskell Setup.hs copy - -.. option:: --destdir=path - - Specify the directory under which to place installed files. If this is - not given, then the root directory is assumed. - -.. _setup-register: - -runhaskell Setup.hs register ----------------------------- - -Register this package with the compiler, i.e. make the modules it -contains available to programs. This only makes sense for library -packages. Note that the ``install`` command incorporates this action. -The main use of this separate command is in the post-installation step -for a binary package. - -This command takes the following options: - -.. program:: runhaskell Setup.hs register - -.. option:: --global - - Register this package in the system-wide database. (This is the - default.) - -.. option:: --user - - Register this package in the user's local package database. - -.. option:: --gen-script - - Instead of registering the package, generate a script containing - commands to perform the registration. On Unix, this file is called - ``register.sh``, on Windows, ``register.bat``. This script might be - included in a binary bundle, to be run after the bundle is unpacked - on the target system. - -.. option:: --gen-pkg-config[=path] - - Instead of registering the package, generate a package registration - file (or directory, in some circumstances). This only applies to - compilers that support package registration files which at the - moment is only GHC. The file should be used with the compiler's - mechanism for registering packages. This option is mainly intended - for packaging systems. If possible use the :option:`--gen-script` option - instead since it is more portable across Haskell implementations. - The *path* is optional and can be used to specify a particular - output file to generate. Otherwise, by default the file is the - package name and version with a ``.conf`` extension. - - This option outputs a directory if the package requires multiple - registrations: this can occur if internal/convenience libraries are - used. These configuration file names are sorted so that they can be - registered in order. - -.. option:: --inplace - - Registers the package for use directly from the build tree, without - needing to install it. This can be useful for testing: there's no - need to install the package after modifying it, just recompile and - test. - - This flag does not create a build-tree-local package database. It - still registers the package in one of the user or global databases. - - However, there are some caveats. It only works with GHC (currently). - It only works if your package doesn't depend on having any - supplemental files installed --- plain Haskell libraries should be - fine. - -.. _setup-unregister: - -runhaskell Setup.hs unregister ------------------------------- - -.. program:: runhaskell Setup.hs unregister - -Deregister this package with the compiler. - -This command takes the following options: - -.. option:: --global - - Deregister this package in the system-wide database. (This is the - default.) - -.. option:: --user - - Deregister this package in the user's local package database. - -.. option:: --gen-script - - Instead of deregistering the package, generate a script containing - commands to perform the deregistration. On Unix, this file is called - ``unregister.sh``, on Windows, ``unregister.bat``. This script might - be included in a binary bundle, to be run on the target system. - -.. _setup-clean: - -runhaskell Setup.hs clean -------------------------- - -Remove any local files created during the ``configure``, ``build``, -``haddock``, ``register`` or ``unregister`` steps, and also any files -and directories listed in the :pkg-field:`extra-tmp-files` field. - -This command takes the following options: - -.. program:: runhaskell Setup.hs clean - -.. option:: --save-configure, -s - - Keeps the configuration information so it is not necessary to run - the configure step again before building. - -.. _setup-test: - -runhaskell Setup.hs test ------------------------- - -Run the test suites specified in the package description file. Aside -from the following flags, Cabal accepts the name of one or more test -suites on the command line after ``test``. When supplied, Cabal will run -only the named test suites, otherwise, Cabal will run all test suites in -the package. - -.. program:: runhaskell Setup.hs test - -.. option:: --builddir=dir - - The directory where Cabal puts generated build files (default: - ``dist``). Test logs will be located in the ``test`` subdirectory. - -.. option:: --human-log=path - - The template used to name human-readable test logs; the path is - relative to ``dist/test``. By default, logs are named according to - the template ``$pkgid-$test-suite.log``, so that each test suite - will be logged to its own human-readable log file. Template - variables allowed are: ``$pkgid``, ``$compiler``, ``$os``, - ``$arch``, ``$abi``, ``$abitag``, ``$test-suite``, and ``$result``. - -.. option:: --machine-log=path - - The path to the machine-readable log, relative to ``dist/test``. The - default template is ``$pkgid.log``. Template variables allowed are: - ``$pkgid``, ``$compiler``, ``$os``, ``$arch``, ``$abi``, ``$abitag`` - and ``$result``. - -.. option:: --show-details=filter - - Determines if the results of individual test cases are shown on the - terminal. May be ``always`` (always show), ``never`` (never show), - ``failures`` (show only failed results), or ``streaming`` (show all - results in real time). - -.. option:: --test-options=options - Give extra options to the test executables. - -.. option:: --test-option=option - - Give an extra option to the test executables. There is no need to - quote options containing spaces because a single option is assumed, - so options will not be split on spaces. - -.. option:: --test-wrapper=path - - The wrapper script/application used to setup and tear down the test - execution context. The text executable path and test arguments are - passed as arguments to the wrapper and it is expected that the wrapper - will return the test's return code, as well as a copy of stdout/stderr. - -.. _setup-bench: - -runhaskell Setup.hs bench -------------------------- - -Run the benchmarks specified in the package description file. Aside -from the following flags, Cabal accepts the name of one or more benchmarks -on the command line after ``bench``. When supplied, Cabal will run -only the named benchmarks, otherwise, Cabal will run all benchmarks in -the package. - -.. option:: --benchmark-options=options - Give extra options to the benchmark executables. - -.. option:: --benchmark-option=option - - Give an extra option to the benchmark executables. There is no need to - quote options containing spaces because a single option is assumed, - so options will not be split on spaces. - -.. _setup-sdist: - -runhaskell Setup.hs sdist -------------------------- - -Create a system- and compiler-independent source distribution in a file -*package*-*version*\ ``.tar.gz`` in the ``dist`` subdirectory, for -distribution to package builders. When unpacked, the commands listed in -this section will be available. - -The files placed in this distribution are the package description file, -the setup script, the sources of the modules named in the package -description file, and files named in the ``license-file``, ``main-is``, -``c-sources``, ``asm-sources``, ``cmm-sources``, ``js-sources``, -``data-files``, ``extra-source-files`` and ``extra-doc-files`` fields. - -This command takes the following option: - -.. program:: runhaskell Setup.hs sdist - -.. option:: --snapshot - - Append today's date (in "YYYYMMDD" format) to the version number for - the generated source package. The original package is unaffected. - - -.. include:: references.inc diff --git a/cabal/Cabal/src/Distribution/Backpack/ComponentsGraph.hs b/cabal/Cabal/src/Distribution/Backpack/ComponentsGraph.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Backpack/ComponentsGraph.hs @@ -0,0 +1,97 @@ +-- | See +module Distribution.Backpack.ComponentsGraph ( + ComponentsGraph, + ComponentsWithDeps, + mkComponentsGraph, + componentsGraphToList, + dispComponentsWithDeps, + componentCycleMsg +) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Package +import Distribution.PackageDescription +import Distribution.Simple.BuildToolDepends +import Distribution.Simple.LocalBuildInfo +import Distribution.Types.ComponentRequestedSpec +import Distribution.Compat.Graph (Graph, Node(..)) +import qualified Distribution.Compat.Graph as Graph +import qualified Distribution.Compat.NonEmptySet as NES +import Distribution.Utils.Generic + +import Distribution.Pretty (pretty) +import Text.PrettyPrint + +------------------------------------------------------------------------------ +-- Components graph +------------------------------------------------------------------------------ + +-- | A graph of source-level components by their source-level +-- dependencies +-- +type ComponentsGraph = Graph (Node ComponentName Component) + +-- | A list of components associated with the source level +-- dependencies between them. +-- +type ComponentsWithDeps = [(Component, [ComponentName])] + +-- | Pretty-print 'ComponentsWithDeps'. +-- +dispComponentsWithDeps :: ComponentsWithDeps -> Doc +dispComponentsWithDeps graph = + vcat [ hang (text "component" <+> pretty (componentName c)) 4 + (vcat [ text "dependency" <+> pretty cdep | cdep <- cdeps ]) + | (c, cdeps) <- graph ] + +-- | Create a 'Graph' of 'Component', or report a cycle if there is a +-- problem. +-- +mkComponentsGraph :: ComponentRequestedSpec + -> PackageDescription + -> Either [ComponentName] ComponentsGraph +mkComponentsGraph enabled pkg_descr = + let g = Graph.fromDistinctList + [ N c (componentName c) (componentDeps c) + | c <- pkgBuildableComponents pkg_descr + , componentEnabled enabled c ] + in case Graph.cycles g of + [] -> Right g + ccycles -> Left [ componentName c | N c _ _ <- concat ccycles ] + where + -- The dependencies for the given component + componentDeps component = + toolDependencies ++ libDependencies + where + bi = componentBuildInfo component + + toolDependencies = CExeName <$> getAllInternalToolDependencies pkg_descr bi + + libDependencies = do + Dependency pkgname _ lns <- targetBuildDepends bi + guard (pkgname == packageName pkg_descr) + + ln <- NES.toList lns + return (CLibName ln) + +-- | Given the package description and a 'PackageDescription' (used +-- to determine if a package name is internal or not), sort the +-- components in dependency order (fewest dependencies first). This is +-- NOT necessarily the build order (although it is in the absence of +-- Backpack.) +-- +componentsGraphToList :: ComponentsGraph + -> ComponentsWithDeps +componentsGraphToList = + map (\(N c _ cs) -> (c, cs)) . Graph.revTopSort + +-- | Error message when there is a cycle; takes the SCC of components. +componentCycleMsg :: PackageIdentifier -> [ComponentName] -> Doc +componentCycleMsg pn cnames = + text "Components in the package" <+> pretty pn <+> text "depend on each other in a cyclic way:" + $$ + text (intercalate " depends on " + [ "'" ++ showComponentName cname ++ "'" + | cname <- cnames ++ maybeToList (safeHead cnames) ]) diff --git a/cabal/Cabal/src/Distribution/Backpack/Configure.hs b/cabal/Cabal/src/Distribution/Backpack/Configure.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Backpack/Configure.hs @@ -0,0 +1,359 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NoMonoLocalBinds #-} +{-# LANGUAGE NondecreasingIndentation #-} + +-- | See +-- +-- WARNING: The contents of this module are HIGHLY experimental. +-- We may refactor it under you. +module Distribution.Backpack.Configure ( + configureComponentLocalBuildInfos, +) where + +import Prelude () +import Distribution.Compat.Prelude hiding ((<>)) + +import Distribution.Backpack +import Distribution.Backpack.FullUnitId +import Distribution.Backpack.PreExistingComponent +import Distribution.Backpack.ConfiguredComponent +import Distribution.Backpack.LinkedComponent +import Distribution.Backpack.ReadyComponent +import Distribution.Backpack.ComponentsGraph +import Distribution.Backpack.Id + +import Distribution.Simple.Compiler +import Distribution.Package +import qualified Distribution.InstalledPackageInfo as Installed +import Distribution.InstalledPackageInfo (InstalledPackageInfo + ,emptyInstalledPackageInfo) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.PackageIndex (InstalledPackageIndex) +import Distribution.PackageDescription +import Distribution.ModuleName +import Distribution.Simple.Setup as Setup +import Distribution.Simple.LocalBuildInfo +import Distribution.Types.AnnotatedId +import Distribution.Types.ComponentRequestedSpec +import Distribution.Types.ComponentInclude +import Distribution.Types.MungedPackageName +import Distribution.Verbosity +import qualified Distribution.Compat.Graph as Graph +import Distribution.Compat.Graph (Graph, IsNode(..)) +import Distribution.Utils.LogProgress + +import Data.Either + ( lefts ) +import qualified Data.Set as Set +import qualified Data.Map as Map +import Distribution.Pretty +import Text.PrettyPrint + +------------------------------------------------------------------------------ +-- Pipeline +------------------------------------------------------------------------------ + +configureComponentLocalBuildInfos + :: Verbosity + -> Bool -- use_external_internal_deps + -> ComponentRequestedSpec + -> Bool -- deterministic + -> Flag String -- configIPID + -> Flag ComponentId -- configCID + -> PackageDescription + -> [PreExistingComponent] + -> FlagAssignment -- configConfigurationsFlags + -> [(ModuleName, Module)] -- configInstantiateWith + -> InstalledPackageIndex + -> Compiler + -> LogProgress ([ComponentLocalBuildInfo], InstalledPackageIndex) +configureComponentLocalBuildInfos + verbosity use_external_internal_deps enabled deterministic ipid_flag cid_flag pkg_descr + prePkgDeps flagAssignment instantiate_with installedPackageSet comp = do + -- NB: In single component mode, this returns a *single* component. + -- In this graph, the graph is NOT closed. + graph0 <- case mkComponentsGraph enabled pkg_descr of + Left ccycle -> dieProgress (componentCycleMsg (package pkg_descr) ccycle) + Right g -> return (componentsGraphToList g) + infoProgress $ hang (text "Source component graph:") 4 + (dispComponentsWithDeps graph0) + + let conf_pkg_map = Map.fromListWith Map.union + [(pc_pkgname pkg, + Map.singleton (pc_compname pkg) + (AnnotatedId { + ann_id = pc_cid pkg, + ann_pid = packageId pkg, + ann_cname = pc_compname pkg + })) + | pkg <- prePkgDeps] + graph1 <- toConfiguredComponents use_external_internal_deps + flagAssignment + deterministic ipid_flag cid_flag pkg_descr + conf_pkg_map (map fst graph0) + infoProgress $ hang (text "Configured component graph:") 4 + (vcat (map dispConfiguredComponent graph1)) + + let shape_pkg_map = Map.fromList + [ (pc_cid pkg, (pc_open_uid pkg, pc_shape pkg)) + | pkg <- prePkgDeps] + uid_lookup def_uid + | Just pkg <- PackageIndex.lookupUnitId installedPackageSet uid + = FullUnitId (Installed.installedComponentId pkg) + (Map.fromList (Installed.instantiatedWith pkg)) + | otherwise = error ("uid_lookup: " ++ prettyShow uid) + where uid = unDefUnitId def_uid + graph2 <- toLinkedComponents verbosity uid_lookup + (package pkg_descr) shape_pkg_map graph1 + + infoProgress $ + hang (text "Linked component graph:") 4 + (vcat (map dispLinkedComponent graph2)) + + let pid_map = Map.fromList $ + [ (pc_uid pkg, pc_munged_id pkg) + | pkg <- prePkgDeps] ++ + [ (Installed.installedUnitId pkg, mungedId pkg) + | (_, Module uid _) <- instantiate_with + , Just pkg <- [PackageIndex.lookupUnitId + installedPackageSet (unDefUnitId uid)] ] + subst = Map.fromList instantiate_with + graph3 = toReadyComponents pid_map subst graph2 + graph4 = Graph.revTopSort (Graph.fromDistinctList graph3) + + infoProgress $ hang (text "Ready component graph:") 4 + (vcat (map dispReadyComponent graph4)) + + toComponentLocalBuildInfos comp installedPackageSet pkg_descr prePkgDeps graph4 + +------------------------------------------------------------------------------ +-- ComponentLocalBuildInfo +------------------------------------------------------------------------------ + +toComponentLocalBuildInfos + :: Compiler + -> InstalledPackageIndex -- FULL set + -> PackageDescription + -> [PreExistingComponent] -- external package deps + -> [ReadyComponent] + -> LogProgress ([ComponentLocalBuildInfo], + InstalledPackageIndex) -- only relevant packages +toComponentLocalBuildInfos + comp installedPackageSet pkg_descr externalPkgDeps graph = do + -- Check and make sure that every instantiated component exists. + -- We have to do this now, because prior to linking/instantiating + -- we don't actually know what the full set of 'UnitId's we need + -- are. + let -- TODO: This is actually a bit questionable performance-wise, + -- since we will pay for the ALL installed packages even if + -- they are not related to what we are building. This was true + -- in the old configure code. + external_graph :: Graph (Either InstalledPackageInfo ReadyComponent) + external_graph = Graph.fromDistinctList + . map Left + $ PackageIndex.allPackages installedPackageSet + internal_graph :: Graph (Either InstalledPackageInfo ReadyComponent) + internal_graph = Graph.fromDistinctList + . map Right + $ graph + combined_graph = Graph.unionRight external_graph internal_graph + local_graph = fromMaybe (error "toComponentLocalBuildInfos: closure returned Nothing") + $ Graph.closure combined_graph (map nodeKey graph) + -- The database of transitively reachable installed packages that the + -- external components the package (as a whole) depends on. This will be + -- used in several ways: + -- + -- * We'll use it to do a consistency check so we're not depending + -- on multiple versions of the same package (TODO: someday relax + -- this for private dependencies.) See right below. + -- + -- * We'll pass it on in the LocalBuildInfo, where preprocessors + -- and other things will incorrectly use it to determine what + -- the include paths and everything should be. + -- + packageDependsIndex = PackageIndex.fromList (lefts local_graph) + fullIndex = Graph.fromDistinctList local_graph + case Graph.broken fullIndex of + [] -> return () + broken -> + -- TODO: ppr this + dieProgress . text $ + "The following packages are broken because other" + ++ " packages they depend on are missing. These broken " + ++ "packages must be rebuilt before they can be used.\n" + -- TODO: Undupe. + ++ unlines [ "installed package " + ++ prettyShow (packageId pkg) + ++ " is broken due to missing package " + ++ intercalate ", " (map prettyShow deps) + | (Left pkg, deps) <- broken ] + ++ unlines [ "planned package " + ++ prettyShow (packageId pkg) + ++ " is broken due to missing package " + ++ intercalate ", " (map prettyShow deps) + | (Right pkg, deps) <- broken ] + + -- In this section, we'd like to look at the 'packageDependsIndex' + -- and see if we've picked multiple versions of the same + -- installed package (this is bad, because it means you might + -- get an error could not match foo-0.1:Type with foo-0.2:Type). + -- + -- What is pseudoTopPkg for? I have no idea. It was used + -- in the very original commit which introduced checking for + -- inconsistencies 5115bb2be4e13841ea07dc9166b9d9afa5f0d012, + -- and then moved out of PackageIndex and put here later. + -- TODO: Try this code without it... + -- + -- TODO: Move this into a helper function + -- + -- TODO: This is probably wrong for Backpack + let pseudoTopPkg :: InstalledPackageInfo + pseudoTopPkg = emptyInstalledPackageInfo { + Installed.installedUnitId = mkLegacyUnitId (packageId pkg_descr), + Installed.sourcePackageId = packageId pkg_descr, + Installed.depends = map pc_uid externalPkgDeps + } + case PackageIndex.dependencyInconsistencies + . PackageIndex.insert pseudoTopPkg + $ packageDependsIndex of + [] -> return () + inconsistencies -> + warnProgress $ + hang (text "This package indirectly depends on multiple versions of the same" <+> + text "package. This is very likely to cause a compile failure.") 2 + (vcat [ text "package" <+> pretty (packageName user) <+> + parens (pretty (installedUnitId user)) <+> text "requires" <+> + pretty inst + | (_dep_key, insts) <- inconsistencies + , (inst, users) <- insts + , user <- users ]) + let clbis = mkLinkedComponentsLocalBuildInfo comp graph + -- forM clbis $ \(clbi,deps) -> info verbosity $ "UNIT" ++ hashUnitId (componentUnitId clbi) ++ "\n" ++ intercalate "\n" (map hashUnitId deps) + return (clbis, packageDependsIndex) + +-- Build ComponentLocalBuildInfo for each component we are going +-- to build. +-- +-- This conversion is lossy; we lose some invariants from ReadyComponent +mkLinkedComponentsLocalBuildInfo + :: Compiler + -> [ReadyComponent] + -> [ComponentLocalBuildInfo] +mkLinkedComponentsLocalBuildInfo comp rcs = map go rcs + where + internalUnits = Set.fromList (map rc_uid rcs) + isInternal x = Set.member x internalUnits + go rc = + case rc_component rc of + CLib lib -> + let convModuleExport (modname', (Module uid modname)) + | this_uid == unDefUnitId uid + , modname' == modname + = Installed.ExposedModule modname' Nothing + | otherwise + = Installed.ExposedModule modname' + (Just (OpenModule (DefiniteUnitId uid) modname)) + convOpenModuleExport (modname', modu@(OpenModule uid modname)) + | uid == this_open_uid + , modname' == modname + = Installed.ExposedModule modname' Nothing + | otherwise + = Installed.ExposedModule modname' (Just modu) + convOpenModuleExport (_, OpenModuleVar _) + = error "convOpenModuleExport: top-level modvar" + exports = + -- Loses invariants + case rc_i rc of + Left indefc -> map convOpenModuleExport + $ Map.toList (indefc_provides indefc) + Right instc -> map convModuleExport + $ Map.toList (instc_provides instc) + insts = + case rc_i rc of + Left indefc -> [ (m, OpenModuleVar m) | m <- indefc_requires indefc ] + Right instc -> [ (m, OpenModule (DefiniteUnitId uid') m') + | (m, Module uid' m') <- instc_insts instc ] + + compat_name = MungedPackageName (packageName rc) (libName lib) + compat_key = computeCompatPackageKey comp compat_name (packageVersion rc) this_uid + + in LibComponentLocalBuildInfo { + componentPackageDeps = cpds, + componentUnitId = this_uid, + componentComponentId = this_cid, + componentInstantiatedWith = insts, + componentIsIndefinite_ = is_indefinite, + componentLocalName = cname, + componentInternalDeps = internal_deps, + componentExeDeps = exe_deps, + componentIncludes = includes, + componentExposedModules = exports, + componentIsPublic = rc_public rc, + componentCompatPackageKey = compat_key, + componentCompatPackageName = compat_name + } + CFLib _ -> + FLibComponentLocalBuildInfo { + componentUnitId = this_uid, + componentComponentId = this_cid, + componentLocalName = cname, + componentPackageDeps = cpds, + componentExeDeps = exe_deps, + componentInternalDeps = internal_deps, + componentIncludes = includes + } + CExe _ -> + ExeComponentLocalBuildInfo { + componentUnitId = this_uid, + componentComponentId = this_cid, + componentLocalName = cname, + componentPackageDeps = cpds, + componentExeDeps = exe_deps, + componentInternalDeps = internal_deps, + componentIncludes = includes + } + CTest _ -> + TestComponentLocalBuildInfo { + componentUnitId = this_uid, + componentComponentId = this_cid, + componentLocalName = cname, + componentPackageDeps = cpds, + componentExeDeps = exe_deps, + componentInternalDeps = internal_deps, + componentIncludes = includes + } + CBench _ -> + BenchComponentLocalBuildInfo { + componentUnitId = this_uid, + componentComponentId = this_cid, + componentLocalName = cname, + componentPackageDeps = cpds, + componentExeDeps = exe_deps, + componentInternalDeps = internal_deps, + componentIncludes = includes + } + where + this_uid = rc_uid rc + this_open_uid = rc_open_uid rc + this_cid = rc_cid rc + cname = componentName (rc_component rc) + cpds = rc_depends rc + exe_deps = map ann_id $ rc_exe_deps rc + is_indefinite = + case rc_i rc of + Left _ -> True + Right _ -> False + includes = + map (\ci -> (ci_id ci, ci_renaming ci)) $ + case rc_i rc of + Left indefc -> + indefc_includes indefc + Right instc -> + map (\ci -> ci { ci_ann_id = fmap DefiniteUnitId (ci_ann_id ci) }) + (instc_includes instc) + internal_deps = filter isInternal (nodeNeighbors rc) diff --git a/cabal/Cabal/src/Distribution/Backpack/ConfiguredComponent.hs b/cabal/Cabal/src/Distribution/Backpack/ConfiguredComponent.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Backpack/ConfiguredComponent.hs @@ -0,0 +1,308 @@ +{-# LANGUAGE PatternGuards #-} +-- | See +module Distribution.Backpack.ConfiguredComponent ( + ConfiguredComponent(..), + cc_name, + cc_cid, + cc_pkgid, + toConfiguredComponent, + toConfiguredComponents, + dispConfiguredComponent, + + ConfiguredComponentMap, + extendConfiguredComponentMap, + + -- TODO: Should go somewhere else + newPackageDepsBehaviour +) where + +import Prelude () +import Distribution.Compat.Prelude hiding ((<>)) + +import Distribution.Backpack.Id + +import Distribution.CabalSpecVersion +import Distribution.Types.AnnotatedId +import Distribution.Types.Dependency +import Distribution.Types.ExeDependency +import Distribution.Types.IncludeRenaming +import Distribution.Types.ComponentId +import Distribution.Types.PackageId +import Distribution.Types.PackageName +import Distribution.Types.Mixin +import Distribution.Types.ComponentName +import Distribution.Types.LibraryName +import Distribution.Types.ComponentInclude +import Distribution.Package +import Distribution.PackageDescription +import Distribution.Simple.BuildToolDepends +import Distribution.Simple.Setup as Setup +import Distribution.Simple.LocalBuildInfo +import Distribution.Utils.LogProgress +import Distribution.Utils.MapAccum +import Distribution.Utils.Generic + +import Control.Monad +import qualified Data.Set as Set +import qualified Distribution.Compat.NonEmptySet as NonEmptySet +import qualified Data.Map as Map +import Distribution.Pretty +import Text.PrettyPrint (Doc, hang, text, vcat, hsep, quotes, ($$)) +import qualified Text.PrettyPrint as PP + +-- | A configured component, we know exactly what its 'ComponentId' is, +-- and the 'ComponentId's of the things it depends on. +data ConfiguredComponent + = ConfiguredComponent { + -- | Unique identifier of component, plus extra useful info. + cc_ann_id :: AnnotatedId ComponentId, + -- | The fragment of syntax from the Cabal file describing this + -- component. + cc_component :: Component, + -- | Is this the public library component of the package? + -- (If we invoke Setup with an instantiation, this is the + -- component the instantiation applies to.) + -- Note that in one-component configure mode, this is + -- always True, because any component is the "public" one.) + cc_public :: Bool, + -- | Dependencies on executables from @build-tools@ and + -- @build-tool-depends@. + cc_exe_deps :: [AnnotatedId ComponentId], + -- | The mixins of this package, including both explicit (from + -- the @mixins@ field) and implicit (from @build-depends@). Not + -- mix-in linked yet; component configuration only looks at + -- 'ComponentId's. + cc_includes :: [ComponentInclude ComponentId IncludeRenaming] + } + + +-- | Uniquely identifies a configured component. +cc_cid :: ConfiguredComponent -> ComponentId +cc_cid = ann_id . cc_ann_id + +-- | The package this component came from. +cc_pkgid :: ConfiguredComponent -> PackageId +cc_pkgid = ann_pid . cc_ann_id + +-- | The 'ComponentName' of a component; this uniquely identifies +-- a fragment of syntax within a specified Cabal file describing the +-- component. +cc_name :: ConfiguredComponent -> ComponentName +cc_name = ann_cname . cc_ann_id + +-- | Pretty-print a 'ConfiguredComponent'. +dispConfiguredComponent :: ConfiguredComponent -> Doc +dispConfiguredComponent cc = + hang (text "component" <+> pretty (cc_cid cc)) 4 + (vcat [ hsep $ [ text "include" + , pretty (ci_id incl), pretty (ci_renaming incl) ] + | incl <- cc_includes cc + ]) + +-- | Construct a 'ConfiguredComponent', given that the 'ComponentId' +-- and library/executable dependencies are known. The primary +-- work this does is handling implicit @backpack-include@ fields. +mkConfiguredComponent + :: PackageDescription + -> ComponentId + -> [AnnotatedId ComponentId] -- lib deps + -> [AnnotatedId ComponentId] -- exe deps + -> Component + -> LogProgress ConfiguredComponent +mkConfiguredComponent pkg_descr this_cid lib_deps exe_deps component = do + -- Resolve each @mixins@ into the actual dependency + -- from @lib_deps@. + explicit_includes <- forM (mixins bi) $ \(Mixin pn ln rns) -> do + aid <- case Map.lookup (pn, CLibName ln) deps_map of + Nothing -> + dieProgress $ + text "Mix-in refers to non-existent library" <+> + quotes (pretty pn <<>> prettyLN ln) $$ + text "(did you forget to add the package to build-depends?)" + Just r -> return r + return ComponentInclude { + ci_ann_id = aid, + ci_renaming = rns, + ci_implicit = False + } + + -- Any @build-depends@ which is not explicitly mentioned in + -- @backpack-include@ is converted into an "implicit" include. + let used_explicitly = Set.fromList (map ci_id explicit_includes) + implicit_includes + = map (\aid -> ComponentInclude { + ci_ann_id = aid, + ci_renaming = defaultIncludeRenaming, + ci_implicit = True + }) + $ filter (flip Set.notMember used_explicitly . ann_id) lib_deps + + return ConfiguredComponent { + cc_ann_id = AnnotatedId { + ann_id = this_cid, + ann_pid = package pkg_descr, + ann_cname = componentName component + }, + cc_component = component, + cc_public = is_public, + cc_exe_deps = exe_deps, + cc_includes = explicit_includes ++ implicit_includes + } + where + bi :: BuildInfo + bi = componentBuildInfo component + + prettyLN :: LibraryName -> Doc + prettyLN LMainLibName = PP.empty + prettyLN (LSubLibName n) = PP.colon <<>> pretty n + + deps_map :: Map (PackageName, ComponentName) (AnnotatedId ComponentId) + deps_map = Map.fromList [ ((packageName dep, ann_cname dep), dep) + | dep <- lib_deps ] + + is_public = componentName component == CLibName LMainLibName + +type ConfiguredComponentMap = + Map PackageName (Map ComponentName (AnnotatedId ComponentId)) + +toConfiguredComponent + :: PackageDescription + -> ComponentId + -> ConfiguredComponentMap + -> ConfiguredComponentMap + -> Component + -> LogProgress ConfiguredComponent +toConfiguredComponent pkg_descr this_cid lib_dep_map exe_dep_map component = do + lib_deps <- + if newPackageDepsBehaviour pkg_descr + then fmap concat $ forM (targetBuildDepends bi) $ + \(Dependency name _ sublibs) -> do + pkg <- case Map.lookup name lib_dep_map of + Nothing -> + dieProgress $ + text "Dependency on unbuildable" <+> + text "package" <+> pretty name + Just p -> return p + -- Return all library components + forM (NonEmptySet.toList sublibs) $ \lib -> + let comp = CLibName lib in + case Map.lookup comp pkg of + Nothing -> + dieProgress $ + text "Dependency on unbuildable" <+> + text (showLibraryName lib) <+> + text "from" <+> pretty name + Just v -> return v + else return old_style_lib_deps + mkConfiguredComponent + pkg_descr this_cid + lib_deps exe_deps component + where + bi = componentBuildInfo component + -- lib_dep_map contains a mix of internal and external deps. + -- We want all the public libraries (dep_cn == CLibName) + -- of all external deps (dep /= pn). Note that this + -- excludes the public library of the current package: + -- this is not supported by old-style deps behavior + -- because it would imply a cyclic dependency for the + -- library itself. + old_style_lib_deps = [ e + | (pn, comp_map) <- Map.toList lib_dep_map + , pn /= packageName pkg_descr + , (cn, e) <- Map.toList comp_map + , cn == CLibName LMainLibName ] + -- We have to nub here, because 'getAllToolDependencies' may return + -- duplicates (see #4986). (NB: This is not needed for lib_deps, + -- since those elaborate into includes, for which there explicitly + -- may be multiple instances of a package) + exe_deps = ordNub $ + [ exe + | ExeDependency pn cn _ <- getAllToolDependencies pkg_descr bi + -- The error suppression here is important, because in general + -- we won't know about external dependencies (e.g., 'happy') + -- which the package is attempting to use (those deps are only + -- fed in when cabal-install uses this codepath.) + -- TODO: Let cabal-install request errors here + , Just exe <- [Map.lookup (CExeName cn) =<< Map.lookup pn exe_dep_map] + ] + +-- | Also computes the 'ComponentId', and sets cc_public if necessary. +-- This is Cabal-only; cabal-install won't use this. +toConfiguredComponent' + :: Bool -- use_external_internal_deps + -> FlagAssignment + -> PackageDescription + -> Bool -- deterministic + -> Flag String -- configIPID (todo: remove me) + -> Flag ComponentId -- configCID + -> ConfiguredComponentMap + -> Component + -> LogProgress ConfiguredComponent +toConfiguredComponent' use_external_internal_deps flags + pkg_descr deterministic ipid_flag cid_flag + dep_map component = do + cc <- toConfiguredComponent + pkg_descr this_cid + dep_map dep_map component + return $ if use_external_internal_deps + then cc { cc_public = True } + else cc + where + -- TODO: pass component names to it too! + this_cid = computeComponentId deterministic ipid_flag cid_flag + (package pkg_descr) (componentName component) (Just (deps, flags)) + deps = [ ann_id aid | m <- Map.elems dep_map + , aid <- Map.elems m ] + +extendConfiguredComponentMap + :: ConfiguredComponent + -> ConfiguredComponentMap + -> ConfiguredComponentMap +extendConfiguredComponentMap cc = + Map.insertWith Map.union + (pkgName (cc_pkgid cc)) + (Map.singleton (cc_name cc) (cc_ann_id cc)) + +-- Compute the 'ComponentId's for a graph of 'Component's. The +-- list of internal components must be topologically sorted +-- based on internal package dependencies, so that any internal +-- dependency points to an entry earlier in the list. +-- +-- TODO: This function currently restricts the input configured components to +-- one version per package, by using the type ConfiguredComponentMap. It cannot +-- be used to configure a component that depends on one version of a package for +-- a library and another version for a build-tool. +toConfiguredComponents + :: Bool -- use_external_internal_deps + -> FlagAssignment + -> Bool -- deterministic + -> Flag String -- configIPID + -> Flag ComponentId -- configCID + -> PackageDescription + -> ConfiguredComponentMap + -> [Component] + -> LogProgress [ConfiguredComponent] +toConfiguredComponents + use_external_internal_deps flags deterministic ipid_flag cid_flag pkg_descr + dep_map comps + = fmap snd (mapAccumM go dep_map comps) + where + go m component = do + cc <- toConfiguredComponent' + use_external_internal_deps flags pkg_descr + deterministic ipid_flag cid_flag + m component + return (extendConfiguredComponentMap cc m, cc) + +newPackageDepsBehaviourMinVersion :: CabalSpecVersion +newPackageDepsBehaviourMinVersion = CabalSpecV1_8 + + +-- In older cabal versions, there was only one set of package dependencies for +-- the whole package. In this version, we can have separate dependencies per +-- target, but we only enable this behaviour if the minimum cabal version +-- specified is >= a certain minimum. Otherwise, for compatibility we use the +-- old behaviour. +newPackageDepsBehaviour :: PackageDescription -> Bool +newPackageDepsBehaviour pkg = + specVersion pkg >= newPackageDepsBehaviourMinVersion diff --git a/cabal/Cabal/src/Distribution/Backpack/DescribeUnitId.hs b/cabal/Cabal/src/Distribution/Backpack/DescribeUnitId.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Backpack/DescribeUnitId.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Rank2Types #-} +module Distribution.Backpack.DescribeUnitId where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Compat.Stack +import Distribution.ModuleName +import Distribution.Pretty +import Distribution.Simple.Utils +import Distribution.Types.ComponentName +import Distribution.Types.PackageId +import Distribution.Verbosity + +import Text.PrettyPrint + +-- Unit identifiers have a well defined, machine-readable format, +-- but this format isn't very user-friendly for users. This +-- module defines some functions for solving common rendering +-- problems one has for displaying these. +-- +-- There are three basic problems we tackle: +-- +-- - Users don't want to see pkg-0.5-inplace-libname, +-- they want to see "library 'libname' from 'pkg-0.5'" +-- +-- - Users don't want to see the raw component identifier, which +-- usually contains a wordy hash that doesn't matter. +-- +-- - Users don't want to see a hash of the instantiation: they +-- want to see the actual instantiation, and they want it in +-- interpretable form. +-- + +-- | Print a Setup message stating (1) what operation we are doing, +-- for (2) which component (with enough details to uniquely identify +-- the build in question.) +-- +setupMessage' :: Pretty a => Verbosity + -> String -- ^ Operation being done (capitalized), on: + -> PackageIdentifier -- ^ Package + -> ComponentName -- ^ Component name + -> Maybe [(ModuleName, a)] -- ^ Instantiation, if available. + -- Polymorphic to take + -- 'OpenModule' or 'Module' + -> IO () +setupMessage' verbosity msg pkgid cname mb_insts = withFrozenCallStack $ do + noticeDoc verbosity $ + case mb_insts of + Just insts | not (null insts) -> + hang (msg_doc <+> text "instantiated with") 2 + (vcat [ pretty k <+> text "=" <+> pretty v + | (k,v) <- insts ]) $$ + for_doc + _ -> + msg_doc <+> for_doc + + where + msg_doc = text msg <+> text (showComponentName cname) + for_doc = text "for" <+> pretty pkgid <<>> text ".." diff --git a/cabal/Cabal/src/Distribution/Backpack/FullUnitId.hs b/cabal/Cabal/src/Distribution/Backpack/FullUnitId.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Backpack/FullUnitId.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Backpack.FullUnitId ( + FullUnitId(..), + FullDb, + expandOpenUnitId, + expandUnitId +) where + +import Distribution.Backpack +import Distribution.Types.ComponentId +import Distribution.Compat.Prelude + +-- Unlike OpenUnitId, which could direct to a UnitId. +data FullUnitId = FullUnitId ComponentId OpenModuleSubst + deriving (Show, Generic) + +type FullDb = DefUnitId -> FullUnitId + +expandOpenUnitId :: FullDb -> OpenUnitId -> FullUnitId +expandOpenUnitId _db (IndefFullUnitId cid subst) + = FullUnitId cid subst +expandOpenUnitId db (DefiniteUnitId uid) + = expandUnitId db uid + +expandUnitId :: FullDb -> DefUnitId -> FullUnitId +expandUnitId db uid = db uid diff --git a/cabal/Cabal/src/Distribution/Backpack/Id.hs b/cabal/Cabal/src/Distribution/Backpack/Id.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Backpack/Id.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE PatternGuards #-} +-- | See +module Distribution.Backpack.Id( + computeComponentId, + computeCompatPackageKey, +) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Types.UnqualComponentName +import Distribution.Simple.Compiler +import Distribution.PackageDescription +import Distribution.Simple.Setup as Setup +import qualified Distribution.Simple.InstallDirs as InstallDirs +import Distribution.Simple.LocalBuildInfo +import Distribution.Types.ComponentId +import Distribution.Types.UnitId +import Distribution.Types.MungedPackageName +import Distribution.Utils.Base62 +import Distribution.Version + +import Distribution.Pretty + ( prettyShow ) +import Distribution.Parsec ( simpleParsec ) + +-- | This method computes a default, "good enough" 'ComponentId' +-- for a package. The intent is that cabal-install (or the user) will +-- specify a more detailed IPID via the @--ipid@ flag if necessary. +computeComponentId + :: Bool -- deterministic mode + -> Flag String + -> Flag ComponentId + -> PackageIdentifier + -> ComponentName + -- This is used by cabal-install's legacy codepath + -> Maybe ([ComponentId], FlagAssignment) + -> ComponentId +computeComponentId deterministic mb_ipid mb_cid pid cname mb_details = + -- show is found to be faster than intercalate and then replacement of + -- special character used in intercalating. We cannot simply hash by + -- doubly concatenating list, as it just flatten out the nested list, so + -- different sources can produce same hash + let hash_suffix + | Just (dep_ipids, flags) <- mb_details + = "-" ++ hashToBase62 + -- For safety, include the package + version here + -- for GHC 7.10, where just the hash is used as + -- the package key + ( prettyShow pid + ++ show dep_ipids + ++ show flags ) + | otherwise = "" + generated_base = prettyShow pid ++ hash_suffix + explicit_base cid0 = fromPathTemplate (InstallDirs.substPathTemplate env + (toPathTemplate cid0)) + -- Hack to reuse install dirs machinery + -- NB: no real IPID available at this point + where env = packageTemplateEnv pid (mkUnitId "") + actual_base = case mb_ipid of + Flag ipid0 -> explicit_base ipid0 + NoFlag | deterministic -> prettyShow pid + | otherwise -> generated_base + in case mb_cid of + Flag cid -> cid + NoFlag -> mkComponentId $ actual_base + ++ (case componentNameString cname of + Nothing -> "" + Just s -> "-" ++ unUnqualComponentName s) + +-- | In GHC 8.0, the string we pass to GHC to use for symbol +-- names for a package can be an arbitrary, IPID-compatible string. +-- However, prior to GHC 8.0 there are some restrictions on what +-- format this string can be (due to how ghc-pkg parsed the key): +-- +-- 1. In GHC 7.10, the string had either be of the form +-- foo_ABCD, where foo is a non-semantic alphanumeric/hyphenated +-- prefix and ABCD is two base-64 encoded 64-bit integers, +-- or a GHC 7.8 style identifier. +-- +-- 2. In GHC 7.8, the string had to be a valid package identifier +-- like foo-0.1. +-- +-- So, the problem is that Cabal, in general, has a general IPID, +-- but needs to figure out a package key / package ID that the +-- old ghc-pkg will actually accept. But there's an EVERY WORSE +-- problem: if ghc-pkg decides to parse an identifier foo-0.1-xxx +-- as if it were a package identifier, which means it will SILENTLY +-- DROP the "xxx" (because it's a tag, and Cabal does not allow tags.) +-- So we must CONNIVE to ensure that we don't pick something that +-- looks like this. +-- +-- So this function attempts to define a mapping into the old formats. +-- +-- The mapping for GHC 7.8 and before: +-- +-- * We use the *compatibility* package name and version. For +-- public libraries this is just the package identifier; for +-- internal libraries, it's something like "z-pkgname-z-libname-0.1". +-- See 'computeCompatPackageName' for more details. +-- +-- The mapping for GHC 7.10: +-- +-- * For CLibName: +-- If the IPID is of the form foo-0.1-ABCDEF where foo_ABCDEF would +-- validly parse as a package key, we pass "ABCDEF". (NB: not +-- all hashes parse this way, because GHC 7.10 mandated that +-- these hashes be two base-62 encoded 64 bit integers), +-- but hashes that Cabal generated using 'computeComponentId' +-- are guaranteed to have this form. +-- +-- If it is not of this form, we rehash the IPID into the +-- correct form and pass that. +-- +-- * For sub-components, we rehash the IPID into the correct format +-- and pass that. +-- +computeCompatPackageKey + :: Compiler + -> MungedPackageName + -> Version + -> UnitId + -> String +computeCompatPackageKey comp pkg_name pkg_version uid + | not (packageKeySupported comp || unitIdSupported comp) + = prettyShow pkg_name ++ "-" ++ prettyShow pkg_version + | not (unifiedIPIDRequired comp) = + let str = unUnitId uid -- assume no Backpack support + mb_verbatim_key + = case simpleParsec str :: Maybe PackageId of + -- Something like 'foo-0.1', use it verbatim. + -- (NB: hash tags look like tags, so they are parsed, + -- so the extra equality check tests if a tag was dropped.) + Just pid0 | prettyShow pid0 == str -> Just str + _ -> Nothing + mb_truncated_key + = let cand = reverse (takeWhile isAlphaNum (reverse str)) + in if length cand == 22 && all isAlphaNum cand + then Just cand + else Nothing + rehashed_key = hashToBase62 str + in fromMaybe rehashed_key (mb_verbatim_key `mplus` mb_truncated_key) + | otherwise = prettyShow uid diff --git a/cabal/Cabal/src/Distribution/Backpack/LinkedComponent.hs b/cabal/Cabal/src/Distribution/Backpack/LinkedComponent.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Backpack/LinkedComponent.hs @@ -0,0 +1,396 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +-- | See +module Distribution.Backpack.LinkedComponent ( + LinkedComponent(..), + lc_insts, + lc_uid, + lc_cid, + lc_pkgid, + toLinkedComponent, + toLinkedComponents, + dispLinkedComponent, + LinkedComponentMap, + extendLinkedComponentMap, +) where + +import Prelude () +import Distribution.Compat.Prelude hiding ((<>)) + +import Distribution.Backpack +import Distribution.Backpack.FullUnitId +import Distribution.Backpack.ConfiguredComponent +import Distribution.Backpack.ModuleShape +import Distribution.Backpack.PreModuleShape +import Distribution.Backpack.ModuleScope +import Distribution.Backpack.UnifyM +import Distribution.Backpack.MixLink +import Distribution.Utils.MapAccum + +import Distribution.Types.AnnotatedId +import Distribution.Types.ComponentName +import Distribution.Types.ModuleReexport +import Distribution.Types.ModuleRenaming +import Distribution.Types.IncludeRenaming +import Distribution.Types.ComponentInclude +import Distribution.Types.ComponentId +import Distribution.Types.PackageId +import Distribution.Package +import Distribution.PackageDescription +import Distribution.ModuleName +import Distribution.Simple.LocalBuildInfo +import Distribution.Verbosity +import Distribution.Utils.LogProgress + +import qualified Data.Set as Set +import qualified Data.Map as Map +import Distribution.Pretty (pretty) +import Text.PrettyPrint (Doc, hang, text, vcat, ($+$), hsep, quotes) + +-- | A linked component is a component that has been mix-in linked, at +-- which point we have determined how all the dependencies of the +-- component are explicitly instantiated (in the form of an OpenUnitId). +-- 'ConfiguredComponent' is mix-in linked into 'LinkedComponent', which +-- is then instantiated into 'ReadyComponent'. +data LinkedComponent + = LinkedComponent { + -- | Uniquely identifies linked component + lc_ann_id :: AnnotatedId ComponentId, + -- | Corresponds to 'cc_component'. + lc_component :: Component, + -- | @build-tools@ and @build-tool-depends@ dependencies. + -- Corresponds to 'cc_exe_deps'. + lc_exe_deps :: [AnnotatedId OpenUnitId], + -- | Is this the public library of a package? Corresponds to + -- 'cc_public'. + lc_public :: Bool, + -- | Corresponds to 'cc_includes', but (1) this does not contain + -- includes of signature packages (packages with no exports), + -- and (2) the 'ModuleRenaming' for requirements (stored in + -- 'IncludeRenaming') has been removed, as it is reflected in + -- 'OpenUnitId'.) + lc_includes :: [ComponentInclude OpenUnitId ModuleRenaming], + -- | Like 'lc_includes', but this specifies includes on + -- signature packages which have no exports. + lc_sig_includes :: [ComponentInclude OpenUnitId ModuleRenaming], + -- | The module shape computed by mix-in linking. This is + -- newly computed from 'ConfiguredComponent' + lc_shape :: ModuleShape + } + +-- | Uniquely identifies a 'LinkedComponent'. Corresponds to +-- 'cc_cid'. +lc_cid :: LinkedComponent -> ComponentId +lc_cid = ann_id . lc_ann_id + +-- | Corresponds to 'cc_pkgid'. +lc_pkgid :: LinkedComponent -> PackageId +lc_pkgid = ann_pid . lc_ann_id + +-- | The 'OpenUnitId' of this component in the "default" instantiation. +-- See also 'lc_insts'. 'LinkedComponent's cannot be instantiated +-- (e.g., there is no 'ModSubst' instance for them). +lc_uid :: LinkedComponent -> OpenUnitId +lc_uid lc = IndefFullUnitId (lc_cid lc) . Map.fromList $ lc_insts lc + +-- | The instantiation of 'lc_uid'; this always has the invariant +-- that it is a mapping from a module name @A@ to @@ (the hole A). +lc_insts :: LinkedComponent -> [(ModuleName, OpenModule)] +lc_insts lc = [ (req, OpenModuleVar req) + | req <- Set.toList (modShapeRequires (lc_shape lc)) ] + +dispLinkedComponent :: LinkedComponent -> Doc +dispLinkedComponent lc = + hang (text "unit" <+> pretty (lc_uid lc)) 4 $ + vcat [ text "include" <+> pretty (ci_id incl) <+> pretty (ci_renaming incl) + | incl <- lc_includes lc ] + $+$ + vcat [ text "signature include" <+> pretty (ci_id incl) + | incl <- lc_sig_includes lc ] + $+$ dispOpenModuleSubst (modShapeProvides (lc_shape lc)) + +instance Package LinkedComponent where + packageId = lc_pkgid + +toLinkedComponent + :: Verbosity + -> FullDb + -> PackageId + -> LinkedComponentMap + -> ConfiguredComponent + -> LogProgress LinkedComponent +toLinkedComponent verbosity db this_pid pkg_map ConfiguredComponent { + cc_ann_id = aid@AnnotatedId { ann_id = this_cid }, + cc_component = component, + cc_exe_deps = exe_deps, + cc_public = is_public, + cc_includes = cid_includes + } = do + let + -- The explicitly specified requirements, provisions and + -- reexports from the Cabal file. These are only non-empty for + -- libraries; everything else is trivial. + (src_reqs :: [ModuleName], + src_provs :: [ModuleName], + src_reexports :: [ModuleReexport]) = + case component of + CLib lib -> (signatures lib, + exposedModules lib, + reexportedModules lib) + _ -> ([], [], []) + src_hidden = otherModules (componentBuildInfo component) + + -- Take each included ComponentId and resolve it into an + -- *unlinked* unit identity. We will use unification (relying + -- on the ModuleShape) to resolve these into linked identities. + unlinked_includes :: [ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming] + unlinked_includes = [ ComponentInclude (fmap lookupUid dep_aid) rns i + | ComponentInclude dep_aid rns i <- cid_includes ] + + lookupUid :: ComponentId -> (OpenUnitId, ModuleShape) + lookupUid cid = fromMaybe (error "linkComponent: lookupUid") + (Map.lookup cid pkg_map) + + let orErr (Right x) = return x + orErr (Left [err]) = dieProgress err + orErr (Left errs) = do + dieProgress (vcat (intersperse (text "") -- double newline! + [ hang (text "-") 2 err | err <- errs])) + + -- Pre-shaping + let pre_shape = mixLinkPreModuleShape $ + PreModuleShape { + preModShapeProvides = Set.fromList (src_provs ++ src_hidden), + preModShapeRequires = Set.fromList src_reqs + } : [ renamePreModuleShape (toPreModuleShape sh) rns + | ComponentInclude (AnnotatedId { ann_id = (_, sh) }) rns _ <- unlinked_includes ] + reqs = preModShapeRequires pre_shape + insts = [ (req, OpenModuleVar req) + | req <- Set.toList reqs ] + this_uid = IndefFullUnitId this_cid . Map.fromList $ insts + + -- OK, actually do unification + -- TODO: the unification monad might return errors, in which + -- case we have to deal. Use monadic bind for now. + (linked_shape0 :: ModuleScope, + linked_includes0 :: [ComponentInclude OpenUnitId ModuleRenaming], + linked_sig_includes0 :: [ComponentInclude OpenUnitId ModuleRenaming]) + <- orErr $ runUnifyM verbosity this_cid db $ do + -- The unification monad is implemented using mutable + -- references. Thus, we must convert our *pure* data + -- structures into mutable ones to perform unification. + + let convertMod :: (ModuleName -> ModuleSource) -> ModuleName -> UnifyM s (ModuleScopeU s) + convertMod from m = do + m_u <- convertModule (OpenModule this_uid m) + return (Map.singleton m [WithSource (from m) m_u], Map.empty) + -- Handle 'exposed-modules' + exposed_mod_shapes_u <- traverse (convertMod FromExposedModules) src_provs + -- Handle 'other-modules' + other_mod_shapes_u <- traverse (convertMod FromOtherModules) src_hidden + + -- Handle 'signatures' + let convertReq :: ModuleName -> UnifyM s (ModuleScopeU s) + convertReq req = do + req_u <- convertModule (OpenModuleVar req) + return (Map.empty, Map.singleton req [WithSource (FromSignatures req) req_u]) + req_shapes_u <- traverse convertReq src_reqs + + -- Handle 'mixins' + (incl_shapes_u, all_includes_u) <- fmap unzip (traverse convertInclude unlinked_includes) + + failIfErrs -- Prevent error cascade + -- Mix-in link everything! mixLink is the real workhorse. + shape_u <- mixLink $ exposed_mod_shapes_u + ++ other_mod_shapes_u + ++ req_shapes_u + ++ incl_shapes_u + + -- src_reqs_u <- traverse convertReq src_reqs + -- Read out all the final results by converting back + -- into a pure representation. + let convertIncludeU (ComponentInclude dep_aid rns i) = do + uid <- convertUnitIdU (ann_id dep_aid) + return (ComponentInclude { + ci_ann_id = dep_aid { ann_id = uid }, + ci_renaming = rns, + ci_implicit = i + }) + shape <- convertModuleScopeU shape_u + let (includes_u, sig_includes_u) = partitionEithers all_includes_u + incls <- traverse convertIncludeU includes_u + sig_incls <- traverse convertIncludeU sig_includes_u + return (shape, incls, sig_incls) + + let isNotLib (CLib _) = False + isNotLib _ = True + when (not (Set.null reqs) && isNotLib component) $ + dieProgress $ + hang (text "Non-library component has unfilled requirements:") + 4 (vcat [pretty req | req <- Set.toList reqs]) + + -- NB: do NOT include hidden modules here: GHC 7.10's ghc-pkg + -- won't allow it (since someone could directly synthesize + -- an 'InstalledPackageInfo' that violates abstraction.) + -- Though, maybe it should be relaxed? + let src_hidden_set = Set.fromList src_hidden + linked_shape = linked_shape0 { + modScopeProvides = + -- Would rather use withoutKeys but need BC + Map.filterWithKey + (\k _ -> not (k `Set.member` src_hidden_set)) + (modScopeProvides linked_shape0) + } + + -- OK, compute the reexports + -- TODO: This code reports the errors for reexports one reexport at + -- a time. Better to collect them all up and report them all at + -- once. + let hdl :: [Either Doc a] -> LogProgress [a] + hdl es = + case partitionEithers es of + ([], rs) -> return rs + (ls, _) -> + dieProgress $ + hang (text "Problem with module re-exports:") 2 + (vcat [hang (text "-") 2 l | l <- ls]) + reexports_list <- hdl . (flip map) src_reexports $ \reex@(ModuleReexport mb_pn from to) -> do + case Map.lookup from (modScopeProvides linked_shape) of + Just cands@(x0:xs0) -> do + -- Make sure there is at least one candidate + (x, xs) <- + case mb_pn of + Just pn -> + let matches_pn (FromMixins pn' _ _) = pn == pn' + matches_pn (FromBuildDepends pn' _) = pn == pn' + matches_pn (FromExposedModules _) = pn == packageName this_pid + matches_pn (FromOtherModules _) = pn == packageName this_pid + matches_pn (FromSignatures _) = pn == packageName this_pid + in case filter (matches_pn . getSource) cands of + (x1:xs1) -> return (x1, xs1) + _ -> Left (brokenReexportMsg reex) + Nothing -> return (x0, xs0) + -- Test that all the candidates are consistent + case filter (\x' -> unWithSource x /= unWithSource x') xs of + [] -> return () + _ -> Left $ ambiguousReexportMsg reex x xs + return (to, unWithSource x) + _ -> + Left (brokenReexportMsg reex) + + -- TODO: maybe check this earlier; it's syntactically obvious. + let build_reexports m (k, v) + | Map.member k m = + dieProgress $ hsep + [ text "Module name ", pretty k, text " is exported multiple times." ] + | otherwise = return (Map.insert k v m) + provs <- foldM build_reexports Map.empty $ + -- TODO: doublecheck we have checked for + -- src_provs duplicates already! + [ (mod_name, OpenModule this_uid mod_name) | mod_name <- src_provs ] ++ + reexports_list + + let final_linked_shape = ModuleShape provs (Map.keysSet (modScopeRequires linked_shape)) + + -- See Note Note [Signature package special case] + let (linked_includes, linked_sig_includes) + | Set.null reqs = (linked_includes0 ++ linked_sig_includes0, []) + | otherwise = (linked_includes0, linked_sig_includes0) + + return $ LinkedComponent { + lc_ann_id = aid, + lc_component = component, + lc_public = is_public, + -- These must be executables + lc_exe_deps = map (fmap (\cid -> IndefFullUnitId cid Map.empty)) exe_deps, + lc_shape = final_linked_shape, + lc_includes = linked_includes, + lc_sig_includes = linked_sig_includes + } + +-- Note [Signature package special case] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Suppose we have p-indef, which depends on str-sig and inherits +-- the hole from that signature package. When we instantiate p-indef, +-- it's a bit pointless to also go ahead and build str-sig, because +-- str-sig cannot possibly have contributed any code to the package +-- in question. Furthermore, because the signature was inherited to +-- p-indef, if we test matching against p-indef, we also have tested +-- matching against p-sig. In fact, skipping p-sig is *mandatory*, +-- because p-indef may have thinned it (so that an implementation may +-- match p-indef but not p-sig.) +-- +-- However, suppose that we have a package which mixes together str-sig +-- and str-bytestring, with the intent of *checking* that str-sig is +-- implemented by str-bytestring. Here, it's quite important to +-- build an instantiated str-sig, since that is the only way we will +-- actually end up testing if the matching works. Note that this +-- admonition only applies if the package has NO requirements; if it +-- has any requirements, we will typecheck it as an indefinite +-- package, at which point the signature includes will be passed to +-- GHC who will in turn actually do the checking to make sure they +-- are instantiated correctly. + +-- Handle mix-in linking for components. In the absence of Backpack, +-- every ComponentId gets converted into a UnitId by way of SimpleUnitId. +toLinkedComponents + :: Verbosity + -> FullDb + -> PackageId + -> LinkedComponentMap + -> [ConfiguredComponent] + -> LogProgress [LinkedComponent] +toLinkedComponents verbosity db this_pid lc_map0 comps + = fmap snd (mapAccumM go lc_map0 comps) + where + go :: Map ComponentId (OpenUnitId, ModuleShape) + -> ConfiguredComponent + -> LogProgress (Map ComponentId (OpenUnitId, ModuleShape), LinkedComponent) + go lc_map cc = do + lc <- addProgressCtx (text "In the stanza" <+> text (componentNameStanza (cc_name cc))) $ + toLinkedComponent verbosity db this_pid lc_map cc + return (extendLinkedComponentMap lc lc_map, lc) + +type LinkedComponentMap = Map ComponentId (OpenUnitId, ModuleShape) + +extendLinkedComponentMap :: LinkedComponent + -> LinkedComponentMap + -> LinkedComponentMap +extendLinkedComponentMap lc m = + Map.insert (lc_cid lc) (lc_uid lc, lc_shape lc) m + +brokenReexportMsg :: ModuleReexport -> Doc +brokenReexportMsg (ModuleReexport (Just pn) from _to) = + vcat [ text "The package" <+> quotes (pretty pn) + , text "does not export a module" <+> quotes (pretty from) ] +brokenReexportMsg (ModuleReexport Nothing from _to) = + vcat [ text "The module" <+> quotes (pretty from) + , text "is not exported by any suitable package." + , text "It occurs in neither the 'exposed-modules' of this package," + , text "nor any of its 'build-depends' dependencies." ] + +ambiguousReexportMsg :: ModuleReexport -> ModuleWithSource -> [ModuleWithSource] -> Doc +ambiguousReexportMsg (ModuleReexport mb_pn from _to) y1 ys = + vcat [ text "Ambiguous reexport" <+> quotes (pretty from) + , hang (text "It could refer to either:") 2 + (vcat (msg : msgs)) + , help_msg mb_pn ] + where + msg = text " " <+> displayModuleWithSource y1 + msgs = [text "or" <+> displayModuleWithSource y | y <- ys] + help_msg Nothing = + -- TODO: This advice doesn't help if the ambiguous exports + -- come from a package named the same thing + vcat [ text "The ambiguity can be resolved by qualifying the" + , text "re-export with a package name." + , text "The syntax is 'packagename:ModuleName [as NewName]'." ] + -- Qualifying won't help that much. + help_msg (Just _) = + vcat [ text "The ambiguity can be resolved by using the" + , text "mixins field to rename one of the module" + , text "names differently." ] + displayModuleWithSource y + = vcat [ quotes (pretty (unWithSource y)) + , text "brought into scope by" <+> + dispModuleSource (getSource y) + ] diff --git a/cabal/Cabal/src/Distribution/Backpack/MixLink.hs b/cabal/Cabal/src/Distribution/Backpack/MixLink.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Backpack/MixLink.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE NondecreasingIndentation #-} +-- | See +module Distribution.Backpack.MixLink ( + mixLink, +) where + +import Prelude () +import Distribution.Compat.Prelude hiding (mod) + +import Distribution.Backpack +import Distribution.Backpack.UnifyM +import Distribution.Backpack.FullUnitId +import Distribution.Backpack.ModuleScope + +import qualified Distribution.Utils.UnionFind as UnionFind +import Distribution.ModuleName +import Distribution.Pretty +import Distribution.Types.ComponentId + +import Text.PrettyPrint +import Control.Monad +import qualified Data.Map as Map +import qualified Data.Foldable as F + +----------------------------------------------------------------------- +-- Linking + +-- | Given to scopes of provisions and requirements, link them together. +mixLink :: [ModuleScopeU s] -> UnifyM s (ModuleScopeU s) +mixLink scopes = do + let provs = Map.unionsWith (++) (map fst scopes) + -- Invariant: any identically named holes refer to same mutable cell + reqs = Map.unionsWith (++) (map snd scopes) + filled = Map.intersectionWithKey linkProvision provs reqs + F.sequenceA_ filled + let remaining = Map.difference reqs filled + return (provs, remaining) + +-- | Link a list of possibly provided modules to a single +-- requirement. This applies a side-condition that all +-- of the provided modules at the same name are *actually* +-- the same module. +linkProvision :: ModuleName + -> [ModuleWithSourceU s] -- provs + -> [ModuleWithSourceU s] -- reqs + -> UnifyM s [ModuleWithSourceU s] +linkProvision mod_name ret@(prov:provs) (req:reqs) = do + -- TODO: coalesce all the non-unifying modules together + forM_ provs $ \prov' -> do + -- Careful: read it out BEFORE unifying, because the + -- unification algorithm preemptively unifies modules + mod <- convertModuleU (unWithSource prov) + mod' <- convertModuleU (unWithSource prov') + r <- unify prov prov' + case r of + Just () -> return () + Nothing -> do + addErr $ + text "Ambiguous module" <+> quotes (pretty mod_name) $$ + text "It could refer to" <+> + ( text " " <+> (quotes (pretty mod) $$ in_scope_by (getSource prov)) $$ + text "or" <+> (quotes (pretty mod') $$ in_scope_by (getSource prov')) ) $$ + link_doc + mod <- convertModuleU (unWithSource prov) + req_mod <- convertModuleU (unWithSource req) + self_cid <- fmap unify_self_cid getUnifEnv + case mod of + OpenModule (IndefFullUnitId cid _) _ + | cid == self_cid -> addErr $ + text "Cannot instantiate requirement" <+> quotes (pretty mod_name) <+> + in_scope_by (getSource req) $$ + text "with locally defined module" <+> in_scope_by (getSource prov) $$ + text "as this would create a cyclic dependency, which GHC does not support." $$ + text "Try moving this module to a separate library, e.g.," $$ + text "create a new stanza: library 'sublib'." + _ -> return () + r <- unify prov req + case r of + Just () -> return () + Nothing -> do + -- TODO: Record and report WHERE the bad constraint came from + addErr $ text "Could not instantiate requirement" <+> quotes (pretty mod_name) $$ + nest 4 (text "Expected:" <+> pretty mod $$ + text "Actual: " <+> pretty req_mod) $$ + parens (text "This can occur if an exposed module of" <+> + text "a libraries shares a name with another module.") $$ + link_doc + return ret + where + unify s1 s2 = tryM $ addErrContext short_link_doc + $ unifyModule (unWithSource s1) (unWithSource s2) + in_scope_by s = text "brought into scope by" <+> dispModuleSource s + short_link_doc = text "While filling requirement" <+> quotes (pretty mod_name) + link_doc = text "While filling requirements of" <+> reqs_doc + reqs_doc + | null reqs = dispModuleSource (getSource req) + | otherwise = ( text " " <+> dispModuleSource (getSource req) $$ + vcat [ text "and" <+> dispModuleSource (getSource r) | r <- reqs]) +linkProvision _ _ _ = error "linkProvision" + + + +----------------------------------------------------------------------- +-- The unification algorithm + +-- This is based off of https://gist.github.com/amnn/559551517d020dbb6588 +-- which is a translation from Huet's thesis. + +unifyUnitId :: UnitIdU s -> UnitIdU s -> UnifyM s () +unifyUnitId uid1_u uid2_u + | uid1_u == uid2_u = return () + | otherwise = do + xuid1 <- liftST $ UnionFind.find uid1_u + xuid2 <- liftST $ UnionFind.find uid2_u + case (xuid1, xuid2) of + (UnitIdThunkU u1, UnitIdThunkU u2) + | u1 == u2 -> return () + | otherwise -> + failWith $ hang (text "Couldn't match unit IDs:") 4 + (text " " <+> pretty u1 $$ + text "and" <+> pretty u2) + (UnitIdThunkU uid1, UnitIdU _ cid2 insts2) + -> unifyThunkWith cid2 insts2 uid2_u uid1 uid1_u + (UnitIdU _ cid1 insts1, UnitIdThunkU uid2) + -> unifyThunkWith cid1 insts1 uid1_u uid2 uid2_u + (UnitIdU _ cid1 insts1, UnitIdU _ cid2 insts2) + -> unifyInner cid1 insts1 uid1_u cid2 insts2 uid2_u + +unifyThunkWith :: ComponentId + -> Map ModuleName (ModuleU s) + -> UnitIdU s + -> DefUnitId + -> UnitIdU s + -> UnifyM s () +unifyThunkWith cid1 insts1 uid1_u uid2 uid2_u = do + db <- fmap unify_db getUnifEnv + let FullUnitId cid2 insts2' = expandUnitId db uid2 + insts2 <- convertModuleSubst insts2' + unifyInner cid1 insts1 uid1_u cid2 insts2 uid2_u + +unifyInner :: ComponentId + -> Map ModuleName (ModuleU s) + -> UnitIdU s + -> ComponentId + -> Map ModuleName (ModuleU s) + -> UnitIdU s + -> UnifyM s () +unifyInner cid1 insts1 uid1_u cid2 insts2 uid2_u = do + when (cid1 /= cid2) $ + -- TODO: if we had a package identifier, could be an + -- easier to understand error message. + failWith $ + hang (text "Couldn't match component IDs:") 4 + (text " " <+> pretty cid1 $$ + text "and" <+> pretty cid2) + -- The KEY STEP which makes this a Huet-style unification + -- algorithm. (Also a payoff of using union-find.) + -- We can build infinite unit IDs this way, which is necessary + -- for support mutual recursion. NB: union keeps the SECOND + -- descriptor, so we always arrange for a UnitIdThunkU to live + -- there. + liftST $ UnionFind.union uid1_u uid2_u + F.sequenceA_ $ Map.intersectionWith unifyModule insts1 insts2 + +-- | Imperatively unify two modules. +unifyModule :: ModuleU s -> ModuleU s -> UnifyM s () +unifyModule mod1_u mod2_u + | mod1_u == mod2_u = return () + | otherwise = do + mod1 <- liftST $ UnionFind.find mod1_u + mod2 <- liftST $ UnionFind.find mod2_u + case (mod1, mod2) of + (ModuleVarU _, _) -> liftST $ UnionFind.union mod1_u mod2_u + (_, ModuleVarU _) -> liftST $ UnionFind.union mod2_u mod1_u + (ModuleU uid1 mod_name1, ModuleU uid2 mod_name2) -> do + when (mod_name1 /= mod_name2) $ + failWith $ + hang (text "Cannot match module names") 4 $ + text " " <+> pretty mod_name1 $$ + text "and" <+> pretty mod_name2 + -- NB: this is not actually necessary (because we'll + -- detect loops eventually in 'unifyUnitId'), but it + -- seems harmless enough + liftST $ UnionFind.union mod1_u mod2_u + unifyUnitId uid1 uid2 diff --git a/cabal/Cabal/src/Distribution/Backpack/ModSubst.hs b/cabal/Cabal/src/Distribution/Backpack/ModSubst.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Backpack/ModSubst.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternGuards #-} + +-- | A type class 'ModSubst' for objects which can have 'ModuleSubst' +-- applied to them. +-- +-- See also + +module Distribution.Backpack.ModSubst ( + ModSubst(..), +) where + +import Prelude () +import Distribution.Compat.Prelude hiding (mod) + +import Distribution.Backpack +import Distribution.ModuleName + +import qualified Data.Map as Map +import qualified Data.Set as Set + +-- | Applying module substitutions to semantic objects. +class ModSubst a where + -- In notation, substitution is postfix, which implies + -- putting it on the right hand side, but for partial + -- application it's more convenient to have it on the left + -- hand side. + modSubst :: OpenModuleSubst -> a -> a + +instance ModSubst OpenModule where + modSubst subst (OpenModule cid mod_name) = OpenModule (modSubst subst cid) mod_name + modSubst subst mod@(OpenModuleVar mod_name) + | Just mod' <- Map.lookup mod_name subst = mod' + | otherwise = mod + +instance ModSubst OpenUnitId where + modSubst subst (IndefFullUnitId cid insts) = IndefFullUnitId cid (modSubst subst insts) + modSubst _subst uid = uid + +instance ModSubst (Set ModuleName) where + modSubst subst reqs + = Set.union (Set.difference reqs (Map.keysSet subst)) + (openModuleSubstFreeHoles subst) + +-- Substitutions are functorial. NB: this means that +-- there is an @instance 'ModSubst' 'ModuleSubst'@! +instance ModSubst a => ModSubst (Map k a) where + modSubst subst = fmap (modSubst subst) +instance ModSubst a => ModSubst [a] where + modSubst subst = fmap (modSubst subst) +instance ModSubst a => ModSubst (k, a) where + modSubst subst (x,y) = (x, modSubst subst y) diff --git a/cabal/Cabal/src/Distribution/Backpack/ModuleScope.hs b/cabal/Cabal/src/Distribution/Backpack/ModuleScope.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Backpack/ModuleScope.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DeriveFoldable #-} +-- | See +module Distribution.Backpack.ModuleScope ( + -- * Module scopes + ModuleScope(..), + ModuleProvides, + ModuleRequires, + ModuleSource(..), + dispModuleSource, + WithSource(..), + unWithSource, + getSource, + ModuleWithSource, + emptyModuleScope, +) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.ModuleName +import Distribution.Types.IncludeRenaming +import Distribution.Types.PackageName +import Distribution.Types.ComponentName +import Distribution.Types.LibraryName +import Distribution.Pretty + +import Distribution.Backpack +import Distribution.Backpack.ModSubst + +import qualified Data.Map as Map +import Text.PrettyPrint + + +----------------------------------------------------------------------- +-- Module scopes + +-- Why is ModuleProvides so complicated? The basic problem is that +-- we want to support this: +-- +-- package p where +-- include q (A) +-- include r (A) +-- module B where +-- import "q" A +-- import "r" A +-- +-- Specifically, in Cabal today it is NOT an error have two modules in +-- scope with the same identifier. So we need to preserve this for +-- Backpack. The modification is that an ambiguous module name is +-- OK... as long as it is NOT used to fill a requirement! +-- +-- So as a first try, we might try deferring unifying provisions that +-- are being glommed together, and check for equality after the fact. +-- But this doesn't work, because what if a multi-module provision +-- is used to fill a requirement?! So you do the equality test +-- IMMEDIATELY before a requirement fill happens... or never at all. +-- +-- Alternate strategy: go ahead and unify, and then if it is revealed +-- that some requirements got filled "out-of-thin-air", error. + + +-- | A 'ModuleScope' describes the modules and requirements that +-- are in-scope as we are processing a Cabal package. Unlike +-- a 'ModuleShape', there may be multiple modules in scope at +-- the same 'ModuleName'; this is only an error if we attempt +-- to use those modules to fill a requirement. A 'ModuleScope' +-- can influence the 'ModuleShape' via a reexport. +data ModuleScope = ModuleScope { + modScopeProvides :: ModuleProvides, + modScopeRequires :: ModuleRequires + } + +-- | An empty 'ModuleScope'. +emptyModuleScope :: ModuleScope +emptyModuleScope = ModuleScope Map.empty Map.empty + +-- | Every 'Module' in scope at a 'ModuleName' is annotated with +-- the 'PackageName' it comes from. +type ModuleProvides = Map ModuleName [ModuleWithSource] +-- | INVARIANT: entries for ModuleName m, have msrc_module is OpenModuleVar m +type ModuleRequires = Map ModuleName [ModuleWithSource] +-- TODO: consider newtping the two types above. + +-- | Description of where a module participating in mixin linking came +-- from. +data ModuleSource + = FromMixins PackageName ComponentName IncludeRenaming + | FromBuildDepends PackageName ComponentName + | FromExposedModules ModuleName + | FromOtherModules ModuleName + | FromSignatures ModuleName +-- We don't have line numbers, but if we did, we'd want to record that +-- too + +-- TODO: Deduplicate this with Distribution.Backpack.UnifyM.ci_msg +dispModuleSource :: ModuleSource -> Doc +dispModuleSource (FromMixins pn cn incls) + = text "mixins:" <+> dispComponent pn cn <+> pretty incls +dispModuleSource (FromBuildDepends pn cn) + = text "build-depends:" <+> dispComponent pn cn +dispModuleSource (FromExposedModules m) + = text "exposed-modules:" <+> pretty m +dispModuleSource (FromOtherModules m) + = text "other-modules:" <+> pretty m +dispModuleSource (FromSignatures m) + = text "signatures:" <+> pretty m + +-- Dependency +dispComponent :: PackageName -> ComponentName -> Doc +dispComponent pn cn = + -- NB: This syntax isn't quite the source syntax, but it + -- should be clear enough. To do source syntax, we'd + -- need to know what the package we're linking is. + case cn of + CLibName LMainLibName -> pretty pn + CLibName (LSubLibName ucn) -> pretty pn <<>> colon <<>> pretty ucn + -- Case below shouldn't happen + _ -> pretty pn <+> parens (pretty cn) + +-- | An 'OpenModule', annotated with where it came from in a Cabal file. +data WithSource a = WithSource ModuleSource a + deriving (Functor, Foldable, Traversable) +unWithSource :: WithSource a -> a +unWithSource (WithSource _ x) = x +getSource :: WithSource a -> ModuleSource +getSource (WithSource s _) = s +type ModuleWithSource = WithSource OpenModule + +instance ModSubst a => ModSubst (WithSource a) where + modSubst subst (WithSource s m) = WithSource s (modSubst subst m) diff --git a/cabal/Cabal/src/Distribution/Backpack/ModuleShape.hs b/cabal/Cabal/src/Distribution/Backpack/ModuleShape.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Backpack/ModuleShape.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +-- | See +module Distribution.Backpack.ModuleShape ( + -- * Module shapes + ModuleShape(..), + emptyModuleShape, + shapeInstalledPackage, +) where + +import Prelude () +import Distribution.Compat.Prelude hiding (mod) + +import Distribution.ModuleName +import Distribution.InstalledPackageInfo as IPI + +import Distribution.Backpack.ModSubst +import Distribution.Backpack + +import qualified Data.Map as Map +import qualified Data.Set as Set + +----------------------------------------------------------------------- +-- Module shapes + +-- | A 'ModuleShape' describes the provisions and requirements of +-- a library. We can extract a 'ModuleShape' from an +-- 'InstalledPackageInfo'. +data ModuleShape = ModuleShape { + modShapeProvides :: OpenModuleSubst, + modShapeRequires :: Set ModuleName + } + deriving (Eq, Show, Generic, Typeable) + +instance Binary ModuleShape +instance Structured ModuleShape + +instance ModSubst ModuleShape where + modSubst subst (ModuleShape provs reqs) + = ModuleShape (modSubst subst provs) (modSubst subst reqs) + +-- | The default module shape, with no provisions and no requirements. +emptyModuleShape :: ModuleShape +emptyModuleShape = ModuleShape Map.empty Set.empty + +-- Food for thought: suppose we apply the Merkel tree optimization. +-- Imagine this situation: +-- +-- component p +-- signature H +-- module P +-- component h +-- module H +-- component a +-- signature P +-- module A +-- component q(P) +-- include p +-- include h +-- component r +-- include q (P) +-- include p (P) requires (H) +-- include h (H) +-- include a (A) requires (P) +-- +-- Component r should not have any conflicts, since after mix-in linking +-- the two P imports will end up being the same, so we can properly +-- instantiate it. But to know that q's P is p:P instantiated with h:H, +-- we have to be able to expand its unit id. Maybe we can expand it +-- lazily but in some cases it will need to be expanded. +-- +-- FWIW, the way that GHC handles this is by improving unit IDs as +-- soon as it sees an improved one in the package database. This +-- is a bit disgusting. +shapeInstalledPackage :: IPI.InstalledPackageInfo -> ModuleShape +shapeInstalledPackage ipi = ModuleShape (Map.fromList provs) reqs + where + uid = installedOpenUnitId ipi + provs = map shapeExposedModule (IPI.exposedModules ipi) + reqs = requiredSignatures ipi + shapeExposedModule (IPI.ExposedModule mod_name Nothing) + = (mod_name, OpenModule uid mod_name) + shapeExposedModule (IPI.ExposedModule mod_name (Just mod)) + = (mod_name, mod) diff --git a/cabal/Cabal/src/Distribution/Backpack/PreExistingComponent.hs b/cabal/Cabal/src/Distribution/Backpack/PreExistingComponent.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Backpack/PreExistingComponent.hs @@ -0,0 +1,67 @@ +-- | See +module Distribution.Backpack.PreExistingComponent ( + PreExistingComponent(..), + ipiToPreExistingComponent, +) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Backpack.ModuleShape +import Distribution.Backpack +import Distribution.Types.ComponentId +import Distribution.Types.MungedPackageId +import Distribution.Types.PackageId +import Distribution.Types.UnitId +import Distribution.Types.ComponentName +import Distribution.Types.PackageName +import Distribution.Package + +import qualified Data.Map as Map +import qualified Distribution.InstalledPackageInfo as Installed +import Distribution.InstalledPackageInfo (InstalledPackageInfo) + +-- | Stripped down version of 'LinkedComponent' for things +-- we don't need to know how to build. +data PreExistingComponent + = PreExistingComponent { + -- | The actual name of the package. This may DISAGREE with 'pc_pkgid' + -- for internal dependencies: e.g., an internal component @lib@ may be + -- munged to @z-pkg-z-lib@, but we still want to use it when we see + -- @lib@ in @build-depends@ + pc_pkgname :: PackageName, + -- | The actual name of the component. + pc_compname :: ComponentName, + pc_munged_id :: MungedPackageId, + pc_uid :: UnitId, + pc_cid :: ComponentId, + pc_open_uid :: OpenUnitId, + pc_shape :: ModuleShape + } + +-- | Convert an 'InstalledPackageInfo' into a 'PreExistingComponent', +-- which was brought into scope under the 'PackageName' (important for +-- a package qualified reference.) +ipiToPreExistingComponent :: InstalledPackageInfo -> PreExistingComponent +ipiToPreExistingComponent ipi = + PreExistingComponent { + pc_pkgname = packageName ipi, + pc_compname = CLibName $ Installed.sourceLibName ipi, + pc_munged_id = mungedId ipi, + pc_uid = Installed.installedUnitId ipi, + pc_cid = Installed.installedComponentId ipi, + pc_open_uid = + IndefFullUnitId (Installed.installedComponentId ipi) + (Map.fromList (Installed.instantiatedWith ipi)), + pc_shape = shapeInstalledPackage ipi + } + +instance HasMungedPackageId PreExistingComponent where + mungedId = pc_munged_id + +instance Package PreExistingComponent where + packageId pec = PackageIdentifier (pc_pkgname pec) v + where MungedPackageId _ v = pc_munged_id pec + +instance HasUnitId PreExistingComponent where + installedUnitId = pc_uid diff --git a/cabal/Cabal/src/Distribution/Backpack/PreModuleShape.hs b/cabal/Cabal/src/Distribution/Backpack/PreModuleShape.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Backpack/PreModuleShape.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +module Distribution.Backpack.PreModuleShape ( + PreModuleShape(..), + toPreModuleShape, + renamePreModuleShape, + mixLinkPreModuleShape, +) where + +import Prelude () +import Distribution.Compat.Prelude + +import qualified Data.Set as Set +import qualified Data.Map as Map + +import Distribution.Backpack.ModuleShape +import Distribution.Types.IncludeRenaming +import Distribution.Types.ModuleRenaming +import Distribution.ModuleName + +data PreModuleShape = PreModuleShape { + preModShapeProvides :: Set ModuleName, + preModShapeRequires :: Set ModuleName + } + deriving (Eq, Show, Generic) + +toPreModuleShape :: ModuleShape -> PreModuleShape +toPreModuleShape (ModuleShape provs reqs) = PreModuleShape (Map.keysSet provs) reqs + +renamePreModuleShape :: PreModuleShape -> IncludeRenaming -> PreModuleShape +renamePreModuleShape (PreModuleShape provs reqs) (IncludeRenaming prov_rn req_rn) = + PreModuleShape + (Set.fromList (mapMaybe prov_fn (Set.toList provs))) + (Set.map req_fn reqs) + where + prov_fn = interpModuleRenaming prov_rn + req_fn k = fromMaybe k (interpModuleRenaming req_rn k) + +mixLinkPreModuleShape :: [PreModuleShape] -> PreModuleShape +mixLinkPreModuleShape shapes = PreModuleShape provs (Set.difference reqs provs) + where + provs = Set.unions (map preModShapeProvides shapes) + reqs = Set.unions (map preModShapeRequires shapes) diff --git a/cabal/Cabal/src/Distribution/Backpack/ReadyComponent.hs b/cabal/Cabal/src/Distribution/Backpack/ReadyComponent.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Backpack/ReadyComponent.hs @@ -0,0 +1,376 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PatternGuards #-} +-- | See +module Distribution.Backpack.ReadyComponent ( + ReadyComponent(..), + InstantiatedComponent(..), + IndefiniteComponent(..), + rc_depends, + rc_uid, + rc_pkgid, + dispReadyComponent, + toReadyComponents, +) where + +import Prelude () +import Distribution.Compat.Prelude hiding ((<>)) + +import Distribution.Backpack +import Distribution.Backpack.LinkedComponent +import Distribution.Backpack.ModuleShape + +import Distribution.Types.AnnotatedId +import Distribution.Types.ModuleRenaming +import Distribution.Types.Component +import Distribution.Types.ComponentInclude +import Distribution.Types.ComponentId +import Distribution.Types.ComponentName +import Distribution.Types.PackageId +import Distribution.Types.PackageName.Magic +import Distribution.Types.UnitId +import Distribution.Compat.Graph (IsNode(..)) +import Distribution.Types.Module +import Distribution.Types.MungedPackageId +import Distribution.Types.MungedPackageName +import Distribution.Types.Library +import Distribution.Types.LibraryName + +import Distribution.ModuleName +import Distribution.Package +import Distribution.Simple.Utils + +import Control.Monad +import Text.PrettyPrint +import qualified Data.Map as Map +import qualified Data.Set as Set + +import Distribution.Version +import Distribution.Pretty + +-- | A 'ReadyComponent' is one that we can actually generate build +-- products for. We have a ready component for the typecheck-only +-- products of every indefinite package, as well as a ready component +-- for every way these packages can be fully instantiated. +-- +data ReadyComponent + = ReadyComponent { + rc_ann_id :: AnnotatedId UnitId, + -- | The 'OpenUnitId' for this package. At the moment, this + -- is used in only one case, which is to determine if an + -- export is of a module from this library (indefinite + -- libraries record these exports as 'OpenModule'); + -- 'rc_open_uid' can be conveniently used to test for + -- equality, whereas 'UnitId' cannot always be used in this + -- case. + rc_open_uid :: OpenUnitId, + -- | Corresponds to 'lc_cid'. Invariant: if 'rc_open_uid' + -- records a 'ComponentId', it coincides with this one. + rc_cid :: ComponentId, + -- | Corresponds to 'lc_component'. + rc_component :: Component, + -- | Corresponds to 'lc_exe_deps'. + -- Build-tools don't participate in mix-in linking. + -- (but what if they could?) + rc_exe_deps :: [AnnotatedId UnitId], + -- | Corresponds to 'lc_public'. + rc_public :: Bool, + -- | Extra metadata depending on whether or not this is an + -- indefinite library (typechecked only) or an instantiated + -- component (can be compiled). + rc_i :: Either IndefiniteComponent InstantiatedComponent + } + +-- | The final, string 'UnitId' that will uniquely identify +-- the compilation products of this component. +rc_uid :: ReadyComponent -> UnitId +rc_uid = ann_id . rc_ann_id + +-- | Corresponds to 'lc_pkgid'. +rc_pkgid :: ReadyComponent -> PackageId +rc_pkgid = ann_pid . rc_ann_id + +-- | An 'InstantiatedComponent' is a library which is fully instantiated +-- (or, possibly, has no requirements at all.) +data InstantiatedComponent + = InstantiatedComponent { + -- | How this library was instantiated. + instc_insts :: [(ModuleName, Module)], + -- | Dependencies induced by 'instc_insts'. These are recorded + -- here because there isn't a convenient way otherwise to get + -- the 'PackageId' we need to fill 'componentPackageDeps' as needed. + instc_insts_deps :: [(UnitId, MungedPackageId)], + -- | The modules exported/reexported by this library. + instc_provides :: Map ModuleName Module, + -- | The dependencies which need to be passed to the compiler + -- to bring modules into scope. These always refer to installed + -- fully instantiated libraries. + instc_includes :: [ComponentInclude DefUnitId ModuleRenaming] + } + +-- | An 'IndefiniteComponent' is a library with requirements +-- which we will typecheck only. +data IndefiniteComponent + = IndefiniteComponent { + -- | The requirements of the library. + indefc_requires :: [ModuleName], + -- | The modules exported/reexported by this library. + indefc_provides :: Map ModuleName OpenModule, + -- | The dependencies which need to be passed to the compiler + -- to bring modules into scope. These are 'OpenUnitId' because + -- these may refer to partially instantiated libraries. + indefc_includes :: [ComponentInclude OpenUnitId ModuleRenaming] + } + +-- | Compute the dependencies of a 'ReadyComponent' that should +-- be recorded in the @depends@ field of 'InstalledPackageInfo'. +rc_depends :: ReadyComponent -> [(UnitId, MungedPackageId)] +rc_depends rc = ordNub $ + case rc_i rc of + Left indefc -> + map (\ci -> (abstractUnitId $ ci_id ci, toMungedPackageId ci)) + (indefc_includes indefc) + Right instc -> + map (\ci -> (unDefUnitId $ ci_id ci, toMungedPackageId ci)) + (instc_includes instc) + ++ instc_insts_deps instc + where + toMungedPackageId :: Pretty id => ComponentInclude id rn -> MungedPackageId + toMungedPackageId ci = + computeCompatPackageId + (ci_pkgid ci) + (case ci_cname ci of + CLibName name -> name + _ -> error $ prettyShow (rc_cid rc) ++ + " depends on non-library " ++ prettyShow (ci_id ci)) + +-- | Get the 'MungedPackageId' of a 'ReadyComponent' IF it is +-- a library. +rc_munged_id :: ReadyComponent -> MungedPackageId +rc_munged_id rc = + computeCompatPackageId + (rc_pkgid rc) + (case rc_component rc of + CLib lib -> libName lib + _ -> error "rc_munged_id: not library") + +instance Package ReadyComponent where + packageId = rc_pkgid + +instance HasUnitId ReadyComponent where + installedUnitId = rc_uid + +instance IsNode ReadyComponent where + type Key ReadyComponent = UnitId + nodeKey = rc_uid + nodeNeighbors rc = + (case rc_i rc of + Right inst | [] <- instc_insts inst + -> [] + | otherwise + -> [newSimpleUnitId (rc_cid rc)] + _ -> []) ++ + ordNub (map fst (rc_depends rc)) ++ + map ann_id (rc_exe_deps rc) + +dispReadyComponent :: ReadyComponent -> Doc +dispReadyComponent rc = + hang (text (case rc_i rc of + Left _ -> "indefinite" + Right _ -> "definite") + <+> pretty (nodeKey rc) + {- <+> dispModSubst (Map.fromList (lc_insts lc)) -} ) 4 $ + vcat [ text "depends" <+> pretty uid + | uid <- nodeNeighbors rc ] + +-- | The state of 'InstM'; a mapping from 'UnitId's to their +-- ready component, or @Nothing@ if its an external +-- component which we don't know how to build. +type InstS = Map UnitId (Maybe ReadyComponent) + +-- | A state monad for doing instantiations (can't use actual +-- State because that would be an extra dependency.) +newtype InstM a = InstM { runInstM :: InstS -> (a, InstS) } + +instance Functor InstM where + fmap f (InstM m) = InstM $ \s -> let (x, s') = m s + in (f x, s') + +instance Applicative InstM where + pure a = InstM $ \s -> (a, s) + InstM f <*> InstM x = InstM $ \s -> let (f', s') = f s + (x', s'') = x s' + in (f' x', s'') + +instance Monad InstM where + return = pure + InstM m >>= f = InstM $ \s -> let (x, s') = m s + in runInstM (f x) s' + +-- | Given a list of 'LinkedComponent's, expand the module graph +-- so that we have an instantiated graph containing all of the +-- instantiated components we need to build. +-- +-- Instantiation intuitively follows the following algorithm: +-- +-- instantiate a definite unit id p[S]: +-- recursively instantiate each module M in S +-- recursively instantiate modules exported by this unit +-- recursively instantiate dependencies substituted by S +-- +-- The implementation is a bit more involved to memoize instantiation +-- if we have done it already. +-- +-- We also call 'improveUnitId' during this process, so that fully +-- instantiated components are given 'HashedUnitId'. +-- +toReadyComponents + :: Map UnitId MungedPackageId + -> Map ModuleName Module -- subst for the public component + -> [LinkedComponent] + -> [ReadyComponent] +toReadyComponents pid_map subst0 comps + = catMaybes (Map.elems ready_map) + where + cmap = Map.fromList [ (lc_cid lc, lc) | lc <- comps ] + + instantiateUnitId :: ComponentId -> Map ModuleName Module + -> InstM DefUnitId + instantiateUnitId cid insts = InstM $ \s -> + case Map.lookup uid s of + Nothing -> + -- Knot tied + let (r, s') = runInstM (instantiateComponent uid cid insts) + (Map.insert uid r s) + in (def_uid, Map.insert uid r s') + Just _ -> (def_uid, s) + where + -- The mkDefUnitId here indicates that we assume + -- that Cabal handles unit id hash allocation. + -- Good thing about hashing here: map is only on string. + -- Bad thing: have to repeatedly hash. + def_uid = mkDefUnitId cid insts + uid = unDefUnitId def_uid + + instantiateComponent + :: UnitId -> ComponentId -> Map ModuleName Module + -> InstM (Maybe ReadyComponent) + instantiateComponent uid cid insts + | Just lc <- Map.lookup cid cmap = do + provides <- traverse (substModule insts) (modShapeProvides (lc_shape lc)) + -- NB: lc_sig_includes is omitted here, because we don't + -- need them to build + includes <- forM (lc_includes lc) $ \ci -> do + uid' <- substUnitId insts (ci_id ci) + return ci { ci_ann_id = fmap (const uid') (ci_ann_id ci) } + exe_deps <- traverse (substExeDep insts) (lc_exe_deps lc) + s <- InstM $ \s -> (s, s) + let getDep (Module dep_def_uid _) + | let dep_uid = unDefUnitId dep_def_uid + -- Lose DefUnitId invariant for rc_depends + = [(dep_uid, + fromMaybe err_pid $ + Map.lookup dep_uid pid_map <|> + fmap rc_munged_id (join (Map.lookup dep_uid s)))] + where + err_pid = MungedPackageId + (MungedPackageName nonExistentPackageThisIsCabalBug LMainLibName) + (mkVersion [0]) + instc = InstantiatedComponent { + instc_insts = Map.toList insts, + instc_insts_deps = concatMap getDep (Map.elems insts), + instc_provides = provides, + instc_includes = includes + -- NB: there is no dependency on the + -- indefinite version of this instantiated package here, + -- as (1) it doesn't go in depends in the + -- IPI: it's not a run time dep, and (2) + -- we don't have to tell GHC about it, it + -- will match up the ComponentId + -- automatically + } + return $ Just ReadyComponent { + rc_ann_id = (lc_ann_id lc) { ann_id = uid }, + rc_open_uid = DefiniteUnitId (unsafeMkDefUnitId uid), + rc_cid = lc_cid lc, + rc_component = lc_component lc, + rc_exe_deps = exe_deps, + rc_public = lc_public lc, + rc_i = Right instc + } + | otherwise = return Nothing + + substUnitId :: Map ModuleName Module -> OpenUnitId -> InstM DefUnitId + substUnitId _ (DefiniteUnitId uid) = + return uid + substUnitId subst (IndefFullUnitId cid insts) = do + insts' <- substSubst subst insts + instantiateUnitId cid insts' + + -- NB: NOT composition + substSubst :: Map ModuleName Module + -> Map ModuleName OpenModule + -> InstM (Map ModuleName Module) + substSubst subst insts = traverse (substModule subst) insts + + substModule :: Map ModuleName Module -> OpenModule -> InstM Module + substModule subst (OpenModuleVar mod_name) + | Just m <- Map.lookup mod_name subst = return m + | otherwise = error "substModule: non-closing substitution" + substModule subst (OpenModule uid mod_name) = do + uid' <- substUnitId subst uid + return (Module uid' mod_name) + + substExeDep :: Map ModuleName Module + -> AnnotatedId OpenUnitId -> InstM (AnnotatedId UnitId) + substExeDep insts exe_aid = do + exe_uid' <- substUnitId insts (ann_id exe_aid) + return exe_aid { ann_id = unDefUnitId exe_uid' } + + indefiniteUnitId :: ComponentId -> InstM UnitId + indefiniteUnitId cid = do + let uid = newSimpleUnitId cid + r <- indefiniteComponent uid cid + InstM $ \s -> (uid, Map.insert uid r s) + + indefiniteComponent :: UnitId -> ComponentId -> InstM (Maybe ReadyComponent) + indefiniteComponent uid cid + | Just lc <- Map.lookup cid cmap = do + -- We're going to process includes, in case some of them + -- are fully definite even without any substitution. We + -- want to build those too; see #5634. + inst_includes <- forM (lc_includes lc) $ \ci -> + if Set.null (openUnitIdFreeHoles (ci_id ci)) + then do uid' <- substUnitId Map.empty (ci_id ci) + return $ ci { ci_ann_id = fmap (const (DefiniteUnitId uid')) (ci_ann_id ci) } + else return ci + exe_deps <- traverse (substExeDep Map.empty) (lc_exe_deps lc) + let indefc = IndefiniteComponent { + indefc_requires = map fst (lc_insts lc), + indefc_provides = modShapeProvides (lc_shape lc), + indefc_includes = inst_includes ++ lc_sig_includes lc + } + return $ Just ReadyComponent { + rc_ann_id = (lc_ann_id lc) { ann_id = uid }, + rc_cid = lc_cid lc, + rc_open_uid = lc_uid lc, + rc_component = lc_component lc, + -- It's always fully built + rc_exe_deps = exe_deps, + rc_public = lc_public lc, + rc_i = Left indefc + } + | otherwise = return Nothing + + ready_map = snd $ runInstM work Map.empty + + work + -- Top-level instantiation per subst0 + | not (Map.null subst0) + , [lc] <- filter lc_public (Map.elems cmap) + = do _ <- instantiateUnitId (lc_cid lc) subst0 + return () + | otherwise + = forM_ (Map.elems cmap) $ \lc -> + if null (lc_insts lc) + then instantiateUnitId (lc_cid lc) Map.empty >> return () + else indefiniteUnitId (lc_cid lc) >> return () diff --git a/cabal/Cabal/src/Distribution/Backpack/UnifyM.hs b/cabal/Cabal/src/Distribution/Backpack/UnifyM.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Backpack/UnifyM.hs @@ -0,0 +1,625 @@ +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | See +module Distribution.Backpack.UnifyM ( + -- * Unification monad + UnifyM, + runUnifyM, + failWith, + addErr, + failIfErrs, + tryM, + addErrContext, + addErrContextM, + liftST, + + UnifEnv(..), + getUnifEnv, + + -- * Modules and unit IDs + ModuleU, + ModuleU'(..), + convertModule, + convertModuleU, + + UnitIdU, + UnitIdU'(..), + convertUnitId, + convertUnitIdU, + + ModuleSubstU, + convertModuleSubstU, + convertModuleSubst, + + ModuleScopeU, + emptyModuleScopeU, + convertModuleScopeU, + + ModuleWithSourceU, + + convertInclude, + convertModuleProvides, + convertModuleProvidesU, + +) where + +import Prelude () +import Distribution.Compat.Prelude hiding (mod) + +import Distribution.Backpack.ModuleShape +import Distribution.Backpack.ModuleScope +import Distribution.Backpack.ModSubst +import Distribution.Backpack.FullUnitId +import Distribution.Backpack + +import qualified Distribution.Utils.UnionFind as UnionFind +import Distribution.ModuleName +import Distribution.Package +import Distribution.PackageDescription +import Distribution.Pretty +import Distribution.Types.ComponentInclude +import Distribution.Types.AnnotatedId +import Distribution.Verbosity + +import Data.STRef +import Data.Traversable +import Control.Monad.ST +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import Text.PrettyPrint + +-- TODO: more detailed trace output on high verbosity would probably +-- be appreciated by users debugging unification errors. Collect +-- some good examples! + +data ErrMsg = ErrMsg { + err_msg :: Doc, + err_ctx :: [Doc] + } +type MsgDoc = Doc + +renderErrMsg :: ErrMsg -> MsgDoc +renderErrMsg ErrMsg { err_msg = msg, err_ctx = ctx } = + msg $$ vcat ctx + +-- | The unification monad, this monad encapsulates imperative +-- unification. +newtype UnifyM s a = UnifyM { unUnifyM :: UnifEnv s -> ST s (Maybe a) } + +-- | Run a computation in the unification monad. +runUnifyM :: Verbosity -> ComponentId -> FullDb -> (forall s. UnifyM s a) -> Either [MsgDoc] a +runUnifyM verbosity self_cid db m + = runST $ do i <- newSTRef 0 + hmap <- newSTRef Map.empty + errs <- newSTRef [] + mb_r <- unUnifyM m UnifEnv { + unify_uniq = i, + unify_reqs = hmap, + unify_self_cid = self_cid, + unify_verbosity = verbosity, + unify_ctx = [], + unify_db = db, + unify_errs = errs } + final_errs <- readSTRef errs + case mb_r of + Just x | null final_errs -> return (Right x) + _ -> return (Left (map renderErrMsg (reverse final_errs))) +-- NB: GHC 7.6 throws a hissy fit if you pattern match on 'm'. + +type ErrCtx s = MsgDoc + +-- | The unification environment. +data UnifEnv s = UnifEnv { + -- | A supply of unique integers to label 'UnitIdU' + -- cells. This is used to determine loops in unit + -- identifiers (which can happen with mutual recursion.) + unify_uniq :: UnifRef s UnitIdUnique, + -- | The set of requirements in scope. When + -- a provision is brought into scope, we unify with + -- the requirement at the same module name to fill it. + -- This mapping grows monotonically. + unify_reqs :: UnifRef s (Map ModuleName (ModuleU s)), + -- | Component id of the unit we're linking. We use this + -- to detect if we fill a requirement with a local module, + -- which in principle should be OK but is not currently + -- supported by GHC. + unify_self_cid :: ComponentId, + -- | How verbose the error message should be + unify_verbosity :: Verbosity, + -- | The error reporting context + unify_ctx :: [ErrCtx s], + -- | The package index for expanding unit identifiers + unify_db :: FullDb, + -- | Accumulated errors + unify_errs :: UnifRef s [ErrMsg] + } + +instance Functor (UnifyM s) where + fmap f (UnifyM m) = UnifyM (fmap (fmap (fmap f)) m) + +instance Applicative (UnifyM s) where + pure = UnifyM . pure . pure . pure + UnifyM f <*> UnifyM x = UnifyM $ \r -> do + f' <- f r + case f' of + Nothing -> return Nothing + Just f'' -> do + x' <- x r + case x' of + Nothing -> return Nothing + Just x'' -> return (Just (f'' x'')) + +instance Monad (UnifyM s) where + return = pure + UnifyM m >>= f = UnifyM $ \r -> do + x <- m r + case x of + Nothing -> return Nothing + Just x' -> unUnifyM (f x') r + +-- | Lift a computation from 'ST' monad to 'UnifyM' monad. +-- Internal use only. +liftST :: ST s a -> UnifyM s a +liftST m = UnifyM $ \_ -> fmap Just m + +addErr :: MsgDoc -> UnifyM s () +addErr msg = do + env <- getUnifEnv + let err = ErrMsg { + err_msg = msg, + err_ctx = unify_ctx env + } + liftST $ modifySTRef (unify_errs env) (\errs -> err:errs) + +failWith :: MsgDoc -> UnifyM s a +failWith msg = do + addErr msg + failM + +failM :: UnifyM s a +failM = UnifyM $ \_ -> return Nothing + +failIfErrs :: UnifyM s () +failIfErrs = do + env <- getUnifEnv + errs <- liftST $ readSTRef (unify_errs env) + when (not (null errs)) failM + +tryM :: UnifyM s a -> UnifyM s (Maybe a) +tryM m = + UnifyM (\env -> do + mb_r <- unUnifyM m env + return (Just mb_r)) + +{- +otherFail :: ErrMsg -> UnifyM s a +otherFail s = UnifyM $ \_ -> return (Left s) + +unifyFail :: ErrMsg -> UnifyM s a +unifyFail err = do + env <- getUnifEnv + msg <- case unify_ctx env of + Nothing -> return (text "Unspecified unification error:" <+> err) + Just (ctx, mod1, mod2) + | unify_verbosity env > normal + -> do mod1' <- convertModuleU mod1 + mod2' <- convertModuleU mod2 + let extra = " (was unifying " ++ display mod1' + ++ " and " ++ display mod2' ++ ")" + return (ctx ++ err ++ extra) + | otherwise + -> return (ctx ++ err ++ " (for more information, pass -v flag)") + UnifyM $ \_ -> return (Left msg) +-} + +-- | A convenient alias for mutable references in the unification monad. +type UnifRef s a = STRef s a + +-- | Imperatively read a 'UnifRef'. +readUnifRef :: UnifRef s a -> UnifyM s a +readUnifRef = liftST . readSTRef + +-- | Imperatively write a 'UnifRef'. +writeUnifRef :: UnifRef s a -> a -> UnifyM s () +writeUnifRef x = liftST . writeSTRef x + +-- | Get the current unification environment. +getUnifEnv :: UnifyM s (UnifEnv s) +getUnifEnv = UnifyM $ \r -> return (return r) + +-- | Add a fixed message to the error context. +addErrContext :: Doc -> UnifyM s a -> UnifyM s a +addErrContext ctx m = addErrContextM ctx m + +-- | Add a message to the error context. It may make monadic queries. +addErrContextM :: ErrCtx s -> UnifyM s a -> UnifyM s a +addErrContextM ctx m = + UnifyM $ \r -> unUnifyM m r { unify_ctx = ctx : unify_ctx r } + + +----------------------------------------------------------------------- +-- The "unifiable" variants of the data types +-- +-- In order to properly do unification over infinite trees, we +-- need to union find over 'Module's and 'UnitId's. The pure +-- representation is ill-equipped to do this, so we convert +-- from the pure representation into one which is indirected +-- through union-find. 'ModuleU' handles hole variables; +-- 'UnitIdU' handles mu-binders. + +-- | Contents of a mutable 'ModuleU' reference. +data ModuleU' s + = ModuleU (UnitIdU s) ModuleName + | ModuleVarU ModuleName + +-- | Contents of a mutable 'UnitIdU' reference. +data UnitIdU' s + = UnitIdU UnitIdUnique ComponentId (Map ModuleName (ModuleU s)) + | UnitIdThunkU DefUnitId + +-- | A mutable version of 'Module' which can be imperatively unified. +type ModuleU s = UnionFind.Point s (ModuleU' s) + +-- | A mutable version of 'UnitId' which can be imperatively unified. +type UnitIdU s = UnionFind.Point s (UnitIdU' s) + +-- | An integer for uniquely labeling 'UnitIdU' nodes. We need +-- these labels in order to efficiently serialize 'UnitIdU's into +-- 'UnitId's (we use the label to check if any parent is the +-- node in question, and if so insert a deBruijn index instead.) +-- These labels must be unique across all 'UnitId's/'Module's which +-- participate in unification! +type UnitIdUnique = Int + + +----------------------------------------------------------------------- +-- Conversion to the unifiable data types + +-- An environment for tracking the mu-bindings in scope. +-- The invariant for a state @(m, i)@ is that [0..i] are +-- keys of @m@; in fact, the @i-k@th entry is the @k@th +-- de Bruijn index (this saves us from having to shift as +-- we enter mu-binders.) +type MuEnv s = (IntMap (UnitIdU s), Int) + +extendMuEnv :: MuEnv s -> UnitIdU s -> MuEnv s +extendMuEnv (m, i) x = + (IntMap.insert (i + 1) x m, i + 1) + +{- +lookupMuEnv :: MuEnv s -> Int {- de Bruijn index -} -> UnitIdU s +lookupMuEnv (m, i) k = + case IntMap.lookup (i - k) m of + -- Technically a user can trigger this by giving us a + -- bad 'UnitId', so handle this better. + Nothing -> error "lookupMuEnv: out of bounds (malformed de Bruijn index)" + Just v -> v +-} + +emptyMuEnv :: MuEnv s +emptyMuEnv = (IntMap.empty, -1) + +-- The workhorse functions. These share an environment: +-- * @UnifRef s UnitIdUnique@ - the unique label supply for 'UnitIdU' nodes +-- * @UnifRef s (Map ModuleName moduleU)@ - the (lazily initialized) +-- environment containing the implicitly universally quantified +-- @hole:A@ binders. +-- * @MuEnv@ - the environment for mu-binders. + +convertUnitId' :: MuEnv s + -> OpenUnitId + -> UnifyM s (UnitIdU s) +-- TODO: this could be more lazy if we know there are no internal +-- references +convertUnitId' _ (DefiniteUnitId uid) = + liftST $ UnionFind.fresh (UnitIdThunkU uid) +convertUnitId' stk (IndefFullUnitId cid insts) = do + fs <- fmap unify_uniq getUnifEnv + x <- liftST $ UnionFind.fresh (error "convertUnitId") -- tie the knot later + insts_u <- for insts $ convertModule' (extendMuEnv stk x) + u <- readUnifRef fs + writeUnifRef fs (u+1) + y <- liftST $ UnionFind.fresh (UnitIdU u cid insts_u) + liftST $ UnionFind.union x y + return y +-- convertUnitId' stk (UnitIdVar i) = return (lookupMuEnv stk i) + +convertModule' :: MuEnv s + -> OpenModule -> UnifyM s (ModuleU s) +convertModule' _stk (OpenModuleVar mod_name) = do + hmap <- fmap unify_reqs getUnifEnv + hm <- readUnifRef hmap + case Map.lookup mod_name hm of + Nothing -> do mod <- liftST $ UnionFind.fresh (ModuleVarU mod_name) + writeUnifRef hmap (Map.insert mod_name mod hm) + return mod + Just mod -> return mod +convertModule' stk (OpenModule uid mod_name) = do + uid_u <- convertUnitId' stk uid + liftST $ UnionFind.fresh (ModuleU uid_u mod_name) + +convertUnitId :: OpenUnitId -> UnifyM s (UnitIdU s) +convertUnitId = convertUnitId' emptyMuEnv + +convertModule :: OpenModule -> UnifyM s (ModuleU s) +convertModule = convertModule' emptyMuEnv + + + +----------------------------------------------------------------------- +-- Substitutions + +-- | The mutable counterpart of a 'ModuleSubst' (not defined here). +type ModuleSubstU s = Map ModuleName (ModuleU s) + +-- | Conversion of 'ModuleSubst' to 'ModuleSubstU' +convertModuleSubst :: Map ModuleName OpenModule -> UnifyM s (Map ModuleName (ModuleU s)) +convertModuleSubst = traverse convertModule + +-- | Conversion of 'ModuleSubstU' to 'ModuleSubst' +convertModuleSubstU :: ModuleSubstU s -> UnifyM s OpenModuleSubst +convertModuleSubstU = traverse convertModuleU + +----------------------------------------------------------------------- +-- Conversion from the unifiable data types + +-- An environment for tracking candidates for adding a mu-binding. +-- The invariant for a state @(m, i)@, is that if we encounter a node +-- labeled @k@ such that @m[k -> v]@, then we can replace this +-- node with the de Bruijn index @i-v@ referring to an enclosing +-- mu-binder; furthermore, @range(m) = [0..i]@. +type MooEnv = (IntMap Int, Int) + +emptyMooEnv :: MooEnv +emptyMooEnv = (IntMap.empty, -1) + +extendMooEnv :: MooEnv -> UnitIdUnique -> MooEnv +extendMooEnv (m, i) k = (IntMap.insert k (i + 1) m, i + 1) + +lookupMooEnv :: MooEnv -> UnitIdUnique -> Maybe Int +lookupMooEnv (m, i) k = + case IntMap.lookup k m of + Nothing -> Nothing + Just v -> Just (i-v) -- de Bruijn indexize + +-- The workhorse functions + +convertUnitIdU' :: MooEnv -> UnitIdU s -> UnifyM s OpenUnitId +convertUnitIdU' stk uid_u = do + x <- liftST $ UnionFind.find uid_u + case x of + UnitIdThunkU uid -> return (DefiniteUnitId uid) + UnitIdU u cid insts_u -> + case lookupMooEnv stk u of + Just _i -> + failWith (text "Unsupported mutually recursive unit identifier") + -- return (UnitIdVar i) + Nothing -> do + insts <- for insts_u $ convertModuleU' (extendMooEnv stk u) + return (IndefFullUnitId cid insts) + +convertModuleU' :: MooEnv -> ModuleU s -> UnifyM s OpenModule +convertModuleU' stk mod_u = do + mod <- liftST $ UnionFind.find mod_u + case mod of + ModuleVarU mod_name -> return (OpenModuleVar mod_name) + ModuleU uid_u mod_name -> do + uid <- convertUnitIdU' stk uid_u + return (OpenModule uid mod_name) + +-- Helper functions + +convertUnitIdU :: UnitIdU s -> UnifyM s OpenUnitId +convertUnitIdU = convertUnitIdU' emptyMooEnv + +convertModuleU :: ModuleU s -> UnifyM s OpenModule +convertModuleU = convertModuleU' emptyMooEnv + +-- | An empty 'ModuleScopeU'. +emptyModuleScopeU :: ModuleScopeU s +emptyModuleScopeU = (Map.empty, Map.empty) + + +-- | The mutable counterpart of 'ModuleScope'. +type ModuleScopeU s = (ModuleProvidesU s, ModuleRequiresU s) +-- | The mutable counterpart of 'ModuleProvides' +type ModuleProvidesU s = Map ModuleName [ModuleWithSourceU s] +type ModuleRequiresU s = ModuleProvidesU s +type ModuleWithSourceU s = WithSource (ModuleU s) + +-- TODO: Deduplicate this with Distribution.Backpack.MixLink.dispSource +ci_msg :: ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming -> Doc +ci_msg ci + | ci_implicit ci = text "build-depends:" <+> pp_pn + | otherwise = text "mixins:" <+> pp_pn <+> pretty (ci_renaming ci) + where + pn = pkgName (ci_pkgid ci) + pp_pn = + case ci_cname ci of + CLibName LMainLibName -> pretty pn + CLibName (LSubLibName cn) -> pretty pn <<>> colon <<>> pretty cn + -- Shouldn't happen + cn -> pretty pn <+> parens (pretty cn) + +-- | Convert a 'ModuleShape' into a 'ModuleScopeU', so we can do +-- unification on it. +convertInclude + :: ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming + -> UnifyM s (ModuleScopeU s, + Either (ComponentInclude (UnitIdU s) ModuleRenaming) {- normal -} + (ComponentInclude (UnitIdU s) ModuleRenaming) {- sig -}) +convertInclude ci@(ComponentInclude { + ci_ann_id = AnnotatedId { + ann_id = (uid, ModuleShape provs reqs), + ann_pid = pid, + ann_cname = compname + }, + ci_renaming = incl@(IncludeRenaming prov_rns req_rns), + ci_implicit = implicit + }) = addErrContext (text "In" <+> ci_msg ci) $ do + let pn = packageName pid + the_source | implicit + = FromBuildDepends pn compname + | otherwise + = FromMixins pn compname incl + source = WithSource the_source + + -- Suppose our package has two requirements A and B, and + -- we include it with @requires (A as X)@ + -- There are three closely related things we compute based + -- off of @reqs@ and @reqs_rns@: + -- + -- 1. The requirement renaming (A -> X) + -- 2. The requirement substitution (A -> , B -> ) + + -- Requirement renaming. This is read straight off the syntax: + -- + -- [nothing] ==> [empty] + -- requires (B as Y) ==> B -> Y + -- + -- Requirement renamings are NOT injective: if two requirements + -- are mapped to the same name, the intent is to merge them + -- together. But they are *functions*, so @B as X, B as Y@ is + -- illegal. + + req_rename_list <- + case req_rns of + DefaultRenaming -> return [] + HidingRenaming _ -> do + -- Not valid here for requires! + addErr $ text "Unsupported syntax" <+> + quotes (text "requires hiding (...)") + return [] + ModuleRenaming rns -> return rns + + let req_rename_listmap :: Map ModuleName [ModuleName] + req_rename_listmap = + Map.fromListWith (++) [ (k,[v]) | (k,v) <- req_rename_list ] + req_rename <- sequenceA . flip Map.mapWithKey req_rename_listmap $ \k vs0 -> + case vs0 of + [] -> error "req_rename" + [v] -> return v + v:vs -> do addErr $ + text "Conflicting renamings of requirement" <+> quotes (pretty k) $$ + text "Renamed to: " <+> vcat (map pretty (v:vs)) + return v + + let req_rename_fn k = case Map.lookup k req_rename of + Nothing -> k + Just v -> v + + -- Requirement substitution. + -- + -- A -> X ==> A -> + let req_subst = fmap OpenModuleVar req_rename + + uid_u <- convertUnitId (modSubst req_subst uid) + + -- Requirement mapping. This is just taking the range of the + -- requirement substitution, and making a mapping so that it is + -- convenient to merge things together. It INCLUDES the implicit + -- mappings. + -- + -- A -> X ==> X -> , B -> + reqs_u <- convertModuleRequires . Map.fromList $ + [ (k, [source (OpenModuleVar k)]) + | k <- map req_rename_fn (Set.toList reqs) + ] + + -- Report errors if there were unused renamings + let leftover = Map.keysSet req_rename `Set.difference` reqs + unless (Set.null leftover) $ + addErr $ + hang (text "The" <+> text (showComponentName compname) <+> + text "from package" <+> quotes (pretty pid) + <+> text "does not require:") 4 + (vcat (map pretty (Set.toList leftover))) + + -- Provision computation is more complex. + -- For example, if we have: + -- + -- include p (A as X) requires (B as Y) + -- where A -> q[B=]:A + -- + -- Then we need: + -- + -- X -> [("p", q[B=]:A)] + -- + -- There are a bunch of clever ways to present the algorithm + -- but here is the simple one: + -- + -- 1. If we have a default renaming, apply req_subst + -- to provs and use that. + -- + -- 2. Otherwise, build a map by successively looking + -- up the referenced modules in the renaming in provs. + -- + -- Importantly, overlapping rename targets get accumulated + -- together. It's not an (immediate) error. + (pre_prov_scope, prov_rns') <- + case prov_rns of + DefaultRenaming -> return (Map.toList provs, prov_rns) + HidingRenaming hides -> + let hides_set = Set.fromList hides + in let r = [ (k,v) + | (k,v) <- Map.toList provs + , not (k `Set.member` hides_set) ] + -- GHC doesn't understand hiding, so expand it out! + in return (r, ModuleRenaming (map ((\x -> (x,x)).fst) r)) + ModuleRenaming rns -> do + r <- sequence + [ case Map.lookup from provs of + Just m -> return (to, m) + Nothing -> failWith $ + text "Package" <+> quotes (pretty pid) <+> + text "does not expose the module" <+> quotes (pretty from) + | (from, to) <- rns ] + return (r, prov_rns) + let prov_scope = modSubst req_subst + $ Map.fromListWith (++) + [ (k, [source v]) + | (k, v) <- pre_prov_scope ] + + provs_u <- convertModuleProvides prov_scope + + -- TODO: Assert that provs_u is empty if provs was empty + return ((provs_u, reqs_u), + -- NB: We test that requirements is not null so that + -- users can create packages with zero module exports + -- that cause some C library to linked in, etc. + (if Map.null provs && not (Set.null reqs) + then Right -- is sig + else Left) (ComponentInclude { + ci_ann_id = AnnotatedId { + ann_id = uid_u, + ann_pid = pid, + ann_cname = compname + }, + ci_renaming = prov_rns', + ci_implicit = ci_implicit ci + })) + +-- | Convert a 'ModuleScopeU' to a 'ModuleScope'. +convertModuleScopeU :: ModuleScopeU s -> UnifyM s ModuleScope +convertModuleScopeU (provs_u, reqs_u) = do + provs <- convertModuleProvidesU provs_u + reqs <- convertModuleRequiresU reqs_u + -- TODO: Test that the requirements are still free. If they + -- are not, they got unified, and that's dodgy at best. + return (ModuleScope provs reqs) + +-- | Convert a 'ModuleProvides' to a 'ModuleProvidesU' +convertModuleProvides :: ModuleProvides -> UnifyM s (ModuleProvidesU s) +convertModuleProvides = traverse (traverse (traverse convertModule)) + +-- | Convert a 'ModuleProvidesU' to a 'ModuleProvides' +convertModuleProvidesU :: ModuleProvidesU s -> UnifyM s ModuleProvides +convertModuleProvidesU = traverse (traverse (traverse convertModuleU)) + +convertModuleRequires :: ModuleRequires -> UnifyM s (ModuleRequiresU s) +convertModuleRequires = convertModuleProvides + +convertModuleRequiresU :: ModuleRequiresU s -> UnifyM s ModuleRequires +convertModuleRequiresU = convertModuleProvidesU diff --git a/cabal/Cabal/src/Distribution/Compat/Async.hs b/cabal/Cabal/src/Distribution/Compat/Async.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Compat/Async.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +-- | 'Async', yet using 'MVar's. +-- +-- Adopted from @async@ library +-- Copyright (c) 2012, Simon Marlow +-- Licensed under BSD-3-Clause +-- +-- @since 3.2.0.0 +-- +module Distribution.Compat.Async ( + AsyncM, + withAsync, waitCatch, + wait, asyncThreadId, + cancel, uninterruptibleCancel, AsyncCancelled (..), + -- * Cabal extras + withAsyncNF, + ) where + +import Control.Concurrent (ThreadId, forkIO) +import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, readMVar) +import Control.DeepSeq (NFData, force) +import Control.Exception + (BlockedIndefinitelyOnMVar (..), Exception (..), SomeException (..), catch, evaluate, mask, throwIO, throwTo, try, uninterruptibleMask_) +import Control.Monad (void) +import Data.Typeable (Typeable) +import GHC.Exts (inline) + +#if MIN_VERSION_base(4,7,0) +import Control.Exception (asyncExceptionFromException, asyncExceptionToException) +#endif + +-- | Async, but based on 'MVar', as we don't depend on @stm@. +data AsyncM a = Async + { asyncThreadId :: {-# UNPACK #-} !ThreadId + -- ^ Returns the 'ThreadId' of the thread running + -- the given 'Async'. + , _asyncMVar :: MVar (Either SomeException a) + } + +-- | Spawn an asynchronous action in a separate thread, and pass its +-- @Async@ handle to the supplied function. When the function returns +-- or throws an exception, 'uninterruptibleCancel' is called on the @Async@. +-- +-- > withAsync action inner = mask $ \restore -> do +-- > a <- async (restore action) +-- > restore (inner a) `finally` uninterruptibleCancel a +-- +-- This is a useful variant of 'async' that ensures an @Async@ is +-- never left running unintentionally. +-- +-- Note: a reference to the child thread is kept alive until the call +-- to `withAsync` returns, so nesting many `withAsync` calls requires +-- linear memory. +-- +withAsync :: IO a -> (AsyncM a -> IO b) -> IO b +withAsync = inline withAsyncUsing forkIO + +withAsyncNF :: NFData a => IO a -> (AsyncM a -> IO b) -> IO b +withAsyncNF m = inline withAsyncUsing forkIO (m >>= evaluateNF) where + evaluateNF = evaluate . force + +withAsyncUsing :: (IO () -> IO ThreadId) -> IO a -> (AsyncM a -> IO b) -> IO b +-- The bracket version works, but is slow. We can do better by +-- hand-coding it: +withAsyncUsing doFork = \action inner -> do + var <- newEmptyMVar + mask $ \restore -> do + t <- doFork $ try (restore action) >>= putMVar var + let a = Async t var + r <- restore (inner a) `catchAll` \e -> do + uninterruptibleCancel a + throwIO e + uninterruptibleCancel a + return r + +-- | Wait for an asynchronous action to complete, and return its +-- value. If the asynchronous action threw an exception, then the +-- exception is re-thrown by 'wait'. +-- +-- > wait = atomically . waitSTM +-- +{-# INLINE wait #-} +wait :: AsyncM a -> IO a +wait a = do + res <- waitCatch a + case res of + Left (SomeException e) -> throwIO e + Right x -> return x + +-- | Wait for an asynchronous action to complete, and return either +-- @Left e@ if the action raised an exception @e@, or @Right a@ if it +-- returned a value @a@. +-- +-- > waitCatch = atomically . waitCatchSTM +-- +{-# INLINE waitCatch #-} +waitCatch :: AsyncM a -> IO (Either SomeException a) +waitCatch (Async _ var) = tryAgain (readMVar var) + where + -- See: https://github.com/simonmar/async/issues/14 + tryAgain f = f `catch` \BlockedIndefinitelyOnMVar -> f + +catchAll :: IO a -> (SomeException -> IO a) -> IO a +catchAll = catch + +-- | Cancel an asynchronous action by throwing the @AsyncCancelled@ +-- exception to it, and waiting for the `Async` thread to quit. +-- Has no effect if the 'Async' has already completed. +-- +-- > cancel a = throwTo (asyncThreadId a) AsyncCancelled <* waitCatch a +-- +-- Note that 'cancel' will not terminate until the thread the 'Async' +-- refers to has terminated. This means that 'cancel' will block for +-- as long said thread blocks when receiving an asynchronous exception. +-- +-- For example, it could block if: +-- +-- * It's executing a foreign call, and thus cannot receive the asynchronous +-- exception; +-- * It's executing some cleanup handler after having received the exception, +-- and the handler is blocking. +{-# INLINE cancel #-} +cancel :: AsyncM a -> IO () +cancel a@(Async t _) = do + throwTo t AsyncCancelled + void (waitCatch a) + +-- | The exception thrown by `cancel` to terminate a thread. +data AsyncCancelled = AsyncCancelled + deriving (Show, Eq + , Typeable + ) + +instance Exception AsyncCancelled where +#if MIN_VERSION_base(4,7,0) + -- wraps in SomeAsyncException + -- See https://github.com/ghc/ghc/commit/756a970eacbb6a19230ee3ba57e24999e4157b09 + fromException = asyncExceptionFromException + toException = asyncExceptionToException +#endif + +-- | Cancel an asynchronous action +-- +-- This is a variant of `cancel`, but it is not interruptible. +{-# INLINE uninterruptibleCancel #-} +uninterruptibleCancel :: AsyncM a -> IO () +uninterruptibleCancel = uninterruptibleMask_ . cancel diff --git a/cabal/Cabal/src/Distribution/Compat/CopyFile.hs b/cabal/Cabal/src/Distribution/Compat/CopyFile.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Compat/CopyFile.hs @@ -0,0 +1,252 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_HADDOCK hide #-} +module Distribution.Compat.CopyFile ( + copyFile, + copyFileChanged, + filesEqual, + copyOrdinaryFile, + copyExecutableFile, + setFileOrdinary, + setFileExecutable, + setDirOrdinary, + ) where + +import Prelude () +import Distribution.Compat.Prelude + +#ifndef mingw32_HOST_OS +import Distribution.Compat.Internal.TempFile + +import Control.Exception + ( bracketOnError ) +import qualified Data.ByteString.Lazy as BSL +import Data.Bits + ( (.|.) ) +import System.IO.Error + ( ioeSetLocation ) +import System.Directory + ( doesFileExist, renameFile, removeFile ) +import System.FilePath + ( takeDirectory ) +import System.IO + ( IOMode(ReadMode), hClose, hGetBuf, hPutBuf, hFileSize + , withBinaryFile ) +import Foreign + ( allocaBytes ) + +import System.Posix.Types + ( FileMode ) +import System.Posix.Files + ( getFileStatus, fileMode, setFileMode ) + +#else /* else mingw32_HOST_OS */ + +import qualified Data.ByteString.Lazy as BSL +import System.IO.Error + ( ioeSetLocation ) +import System.Directory + ( doesFileExist ) +import System.FilePath + ( addTrailingPathSeparator + , hasTrailingPathSeparator + , isPathSeparator + , isRelative + , joinDrive + , joinPath + , pathSeparator + , pathSeparators + , splitDirectories + , splitDrive + ) +import System.IO + ( IOMode(ReadMode), hFileSize + , withBinaryFile ) + +import qualified System.Win32.File as Win32 ( copyFile ) +#endif /* mingw32_HOST_OS */ + +copyOrdinaryFile, copyExecutableFile :: FilePath -> FilePath -> IO () +copyOrdinaryFile src dest = copyFile src dest >> setFileOrdinary dest +copyExecutableFile src dest = copyFile src dest >> setFileExecutable dest + +setFileOrdinary, setFileExecutable, setDirOrdinary :: FilePath -> IO () +#ifndef mingw32_HOST_OS +-- When running with a restrictive UMASK such as 0077 we still want to +-- install files and directories that are accessible to other users. +setFileOrdinary path = addFileMode path 0o644 -- file perms -rw-r--r-- +setFileExecutable path = addFileMode path 0o755 -- file perms -rwxr-xr-x + +addFileMode :: FilePath -> FileMode -> IO () +addFileMode name m = do + o <- fileMode <$> getFileStatus name + setFileMode name (m .|. o) +#else +setFileOrdinary _ = return () +setFileExecutable _ = return () +#endif +-- This happens to be true on Unix and currently on Windows too: +setDirOrdinary = setFileExecutable + +-- | Copies a file to a new destination. +-- Often you should use `copyFileChanged` instead. +copyFile :: FilePath -> FilePath -> IO () +copyFile fromFPath toFPath = + copy + `catchIO` (\ioe -> throwIO (ioeSetLocation ioe "copyFile")) + where +#ifndef mingw32_HOST_OS + copy = withBinaryFile fromFPath ReadMode $ \hFrom -> + bracketOnError openTmp cleanTmp $ \(tmpFPath, hTmp) -> + do allocaBytes bufferSize $ copyContents hFrom hTmp + hClose hTmp + renameFile tmpFPath toFPath + openTmp = openBinaryTempFile (takeDirectory toFPath) ".copyFile.tmp" + cleanTmp (tmpFPath, hTmp) = do + hClose hTmp `catchIO` \_ -> return () + removeFile tmpFPath `catchIO` \_ -> return () + bufferSize = 4096 + + copyContents hFrom hTo buffer = do + count <- hGetBuf hFrom buffer bufferSize + when (count > 0) $ do + hPutBuf hTo buffer count + copyContents hFrom hTo buffer +#else + copy = Win32.copyFile (toExtendedLengthPath fromFPath) + (toExtendedLengthPath toFPath) + False + +-- NOTE: Shamelessly lifted from System.Directory.Internal.Windows + +-- | Add the @"\\\\?\\"@ prefix if necessary or possible. The path remains +-- unchanged if the prefix is not added. This function can sometimes be used +-- to bypass the @MAX_PATH@ length restriction in Windows API calls. +-- +-- See Note [Path normalization]. +toExtendedLengthPath :: FilePath -> FilePath +toExtendedLengthPath path + | isRelative path = path + | otherwise = + case normalisedPath of + '\\' : '?' : '?' : '\\' : _ -> normalisedPath + '\\' : '\\' : '?' : '\\' : _ -> normalisedPath + '\\' : '\\' : '.' : '\\' : _ -> normalisedPath + '\\' : subpath@('\\' : _) -> "\\\\?\\UNC" <> subpath + _ -> "\\\\?\\" <> normalisedPath + where normalisedPath = simplifyWindows path + +-- | Similar to 'normalise' but: +-- +-- * empty paths stay empty, +-- * parent dirs (@..@) are expanded, and +-- * paths starting with @\\\\?\\@ are preserved. +-- +-- The goal is to preserve the meaning of paths better than 'normalise'. +-- +-- Note [Path normalization] +-- 'normalise' doesn't simplify path names but will convert / into \\ +-- this would normally not be a problem as once the path hits the RTS we would +-- have simplified the path then. However since we're calling the WIn32 API +-- directly we have to do the simplification before the call. Without this the +-- path Z:// would become Z:\\\\ and when converted to a device path the path +-- becomes \\?\Z:\\\\ which is an invalid path. +-- +-- This is not a bug in normalise as it explicitly states that it won't simplify +-- a FilePath. +simplifyWindows :: FilePath -> FilePath +simplifyWindows "" = "" +simplifyWindows path = + case drive' of + "\\\\?\\" -> drive' <> subpath + _ -> simplifiedPath + where + simplifiedPath = joinDrive drive' subpath' + (drive, subpath) = splitDrive path + drive' = upperDrive (normaliseTrailingSep (normalisePathSeps drive)) + subpath' = appendSep . avoidEmpty . prependSep . joinPath . + stripPardirs . expandDots . skipSeps . + splitDirectories $ subpath + + upperDrive d = case d of + c : ':' : s | isAlpha c && all isPathSeparator s -> toUpper c : ':' : s + _ -> d + skipSeps = filter (not . (`elem` (pure <$> pathSeparators))) + stripPardirs | pathIsAbsolute || subpathIsAbsolute = dropWhile (== "..") + | otherwise = id + prependSep | subpathIsAbsolute = (pathSeparator :) + | otherwise = id + avoidEmpty | not pathIsAbsolute + && (null drive || hasTrailingPathSep) -- prefer "C:" over "C:." + = emptyToCurDir + | otherwise = id + appendSep p | hasTrailingPathSep + && not (pathIsAbsolute && null p) + = addTrailingPathSeparator p + | otherwise = p + pathIsAbsolute = not (isRelative path) + subpathIsAbsolute = any isPathSeparator (take 1 subpath) + hasTrailingPathSep = hasTrailingPathSeparator subpath + +-- | Given a list of path segments, expand @.@ and @..@. The path segments +-- must not contain path separators. +expandDots :: [FilePath] -> [FilePath] +expandDots = reverse . go [] + where + go ys' xs' = + case xs' of + [] -> ys' + x : xs -> + case x of + "." -> go ys' xs + ".." -> + case ys' of + [] -> go (x : ys') xs + ".." : _ -> go (x : ys') xs + _ : ys -> go ys xs + _ -> go (x : ys') xs + +-- | Convert to the right kind of slashes. +normalisePathSeps :: FilePath -> FilePath +normalisePathSeps p = (\ c -> if isPathSeparator c then pathSeparator else c) <$> p + +-- | Remove redundant trailing slashes and pick the right kind of slash. +normaliseTrailingSep :: FilePath -> FilePath +normaliseTrailingSep path = do + let path' = reverse path + let (sep, path'') = span isPathSeparator path' + let addSep = if null sep then id else (pathSeparator :) + reverse (addSep path'') + +-- | Convert empty paths to the current directory, otherwise leave it +-- unchanged. +emptyToCurDir :: FilePath -> FilePath +emptyToCurDir "" = "." +emptyToCurDir path = path +#endif /* mingw32_HOST_OS */ + +-- | Like `copyFile`, but does not touch the target if source and destination +-- are already byte-identical. This is recommended as it is useful for +-- time-stamp based recompilation avoidance. +copyFileChanged :: FilePath -> FilePath -> IO () +copyFileChanged src dest = do + equal <- filesEqual src dest + unless equal $ copyFile src dest + +-- | Checks if two files are byte-identical. +-- Returns False if either of the files do not exist or if files +-- are of different size. +filesEqual :: FilePath -> FilePath -> IO Bool +filesEqual f1 f2 = do + ex1 <- doesFileExist f1 + ex2 <- doesFileExist f2 + if not (ex1 && ex2) then return False else + withBinaryFile f1 ReadMode $ \h1 -> + withBinaryFile f2 ReadMode $ \h2 -> do + s1 <- hFileSize h1 + s2 <- hFileSize h2 + if s1 /= s2 + then return False + else do + c1 <- BSL.hGetContents h1 + c2 <- BSL.hGetContents h2 + return $! c1 == c2 diff --git a/cabal/Cabal/src/Distribution/Compat/CreatePipe.hs b/cabal/Cabal/src/Distribution/Compat/CreatePipe.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Compat/CreatePipe.hs @@ -0,0 +1,5 @@ +module Distribution.Compat.CreatePipe + {-# DEPRECATED "Use System.Process from package process directly" #-} + (createPipe) where + +import System.Process (createPipe) diff --git a/cabal/Cabal/src/Distribution/Compat/Directory.hs b/cabal/Cabal/src/Distribution/Compat/Directory.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Compat/Directory.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE CPP #-} + +module Distribution.Compat.Directory +( listDirectory +, makeAbsolute +, doesPathExist +) where + +#if MIN_VERSION_directory(1,2,7) +import System.Directory as Dir hiding (doesPathExist) +import System.Directory (doesPathExist) +#else +import System.Directory as Dir +#endif +#if !MIN_VERSION_directory(1,2,2) +import System.FilePath as Path +#endif + +#if !MIN_VERSION_directory(1,2,5) + +listDirectory :: FilePath -> IO [FilePath] +listDirectory path = + filter f `fmap` Dir.getDirectoryContents path + where f filename = filename /= "." && filename /= ".." + +#endif + +#if !MIN_VERSION_directory(1,2,2) + +makeAbsolute :: FilePath -> IO FilePath +makeAbsolute p | Path.isAbsolute p = return p + | otherwise = do + cwd <- Dir.getCurrentDirectory + return $ cwd p + +#endif + +#if !MIN_VERSION_directory(1,2,7) + +doesPathExist :: FilePath -> IO Bool +doesPathExist path = do + -- not using Applicative, as this way we can do less IO + e <- doesDirectoryExist path + if e + then return True + else doesFileExist path + +#endif + diff --git a/cabal/Cabal/src/Distribution/Compat/Environment.hs b/cabal/Cabal/src/Distribution/Compat/Environment.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Compat/Environment.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# OPTIONS_HADDOCK hide #-} + +module Distribution.Compat.Environment + ( getEnvironment, lookupEnv, setEnv, unsetEnv ) + where + +import Prelude () +import qualified Prelude +import Distribution.Compat.Prelude + +import qualified System.Environment as System +import System.Environment (lookupEnv, unsetEnv) + +import Distribution.Compat.Stack + +#ifdef mingw32_HOST_OS +import Foreign.C +import GHC.Windows +#else +import Foreign.C.Types +import Foreign.C.String +import Foreign.C.Error (throwErrnoIfMinus1_) +import System.Posix.Internals ( withFilePath ) +#endif /* mingw32_HOST_OS */ + +getEnvironment :: IO [(String, String)] +#ifdef mingw32_HOST_OS +-- On Windows, the names of environment variables are case-insensitive, but are +-- often given in mixed-case (e.g. "PATH" is "Path"), so we have to normalise +-- them. +getEnvironment = fmap upcaseVars System.getEnvironment + where + upcaseVars = map upcaseVar + upcaseVar (var, val) = (map toUpper var, val) +#else +getEnvironment = System.getEnvironment +#endif + +-- | @setEnv name value@ sets the specified environment variable to @value@. +-- +-- Throws `Control.Exception.IOException` if either @name@ or @value@ is the +-- empty string or contains an equals sign. +setEnv :: String -> String -> IO () +setEnv key value_ = setEnv_ key value + where + -- NOTE: Anything that follows NUL is ignored on both POSIX and Windows. We + -- still strip it manually so that the null check above succeeds if a value + -- starts with NUL. + value = takeWhile (/= '\NUL') value_ + +setEnv_ :: String -> String -> IO () + +#ifdef mingw32_HOST_OS + +setEnv_ key value = withCWString key $ \k -> withCWString value $ \v -> do + success <- c_SetEnvironmentVariable k v + unless success (throwGetLastError "setEnv") + where + _ = callStack -- TODO: attach CallStack to exception + +# if defined(i386_HOST_ARCH) +# define WINDOWS_CCONV stdcall +# elif defined(x86_64_HOST_ARCH) +# define WINDOWS_CCONV ccall +# else +# error Unknown mingw32 arch +# endif /* i386_HOST_ARCH */ + +foreign import WINDOWS_CCONV unsafe "windows.h SetEnvironmentVariableW" + c_SetEnvironmentVariable :: LPTSTR -> LPTSTR -> Prelude.IO Bool +#else +setEnv_ key value = do + withFilePath key $ \ keyP -> + withFilePath value $ \ valueP -> + throwErrnoIfMinus1_ "setenv" $ + c_setenv keyP valueP (fromIntegral (fromEnum True)) + where + _ = callStack -- TODO: attach CallStack to exception + +foreign import ccall unsafe "setenv" + c_setenv :: CString -> CString -> CInt -> Prelude.IO CInt +#endif /* mingw32_HOST_OS */ diff --git a/cabal/Cabal/src/Distribution/Compat/FilePath.hs b/cabal/Cabal/src/Distribution/Compat/FilePath.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Compat/FilePath.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE CPP #-} + +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + +module Distribution.Compat.FilePath +( isExtensionOf +, stripExtension +) where + +import Data.List ( isSuffixOf, stripPrefix ) +import System.FilePath + +#if !MIN_VERSION_filepath(1,4,2) +isExtensionOf :: String -> FilePath -> Bool +isExtensionOf ext@('.':_) = isSuffixOf ext . takeExtensions +isExtensionOf ext = isSuffixOf ('.':ext) . takeExtensions +#endif + +#if !MIN_VERSION_filepath(1,4,1) +stripExtension :: String -> FilePath -> Maybe FilePath +stripExtension [] path = Just path +stripExtension ext@(x:_) path = stripSuffix dotExt path + where + dotExt = if isExtSeparator x then ext else '.':ext + stripSuffix :: Eq a => [a] -> [a] -> Maybe [a] + stripSuffix xs ys = fmap reverse $ stripPrefix (reverse xs) (reverse ys) +#endif diff --git a/cabal/Cabal/src/Distribution/Compat/GetShortPathName.hs b/cabal/Cabal/src/Distribution/Compat/GetShortPathName.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Compat/GetShortPathName.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Compat.GetShortPathName +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : Windows-only +-- +-- Win32 API 'GetShortPathName' function. + +module Distribution.Compat.GetShortPathName ( getShortPathName ) + where + +import Prelude () +import Distribution.Compat.Prelude + +#ifdef mingw32_HOST_OS + +import qualified Prelude +import qualified System.Win32 as Win32 +import System.Win32 (LPCTSTR, LPTSTR, DWORD) +import Foreign.Marshal.Array (allocaArray) + +#ifdef x86_64_HOST_ARCH +#define WINAPI ccall +#else +#define WINAPI stdcall +#endif + +foreign import WINAPI unsafe "windows.h GetShortPathNameW" + c_GetShortPathName :: LPCTSTR -> LPTSTR -> DWORD -> Prelude.IO DWORD + +-- | On Windows, retrieves the short path form of the specified path. On +-- non-Windows, does nothing. See https://github.com/haskell/cabal/issues/3185. +-- +-- From MS's GetShortPathName docs: +-- +-- Passing NULL for [the second] parameter and zero for cchBuffer +-- will always return the required buffer size for a +-- specified lpszLongPath. +-- +getShortPathName :: FilePath -> IO FilePath +getShortPathName path = + Win32.withTString path $ \c_path -> do + c_len <- Win32.failIfZero "GetShortPathName #1 failed!" $ + c_GetShortPathName c_path Win32.nullPtr 0 + let arr_len = fromIntegral c_len + allocaArray arr_len $ \c_out -> do + void $ Win32.failIfZero "GetShortPathName #2 failed!" $ + c_GetShortPathName c_path c_out c_len + Win32.peekTString c_out + +#else + +getShortPathName :: FilePath -> IO FilePath +getShortPathName path = return path + +#endif diff --git a/cabal/Cabal/src/Distribution/Compat/Internal/TempFile.hs b/cabal/Cabal/src/Distribution/Compat/Internal/TempFile.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Compat/Internal/TempFile.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_HADDOCK hide #-} +module Distribution.Compat.Internal.TempFile ( + openTempFile, + openBinaryTempFile, + openNewBinaryFile, + createTempDirectory, + ) where + +import Distribution.Compat.Exception + +import System.FilePath (()) + +import System.IO (Handle, openTempFile, openBinaryTempFile) +#if defined(__IO_MANAGER_WINIO__) +import System.IO (openBinaryTempFileWithDefaultPermissions) +#else +import Control.Exception (onException) +import Data.Bits ((.|.)) +import Foreign.C (CInt, eEXIST, getErrno, errnoToIOError) +import GHC.IO.Handle.FD (fdToHandle) +import System.Posix.Internals (c_open, c_close, o_EXCL, o_BINARY, withFilePath, + o_CREAT, o_RDWR, o_NONBLOCK, o_NOCTTY) +#endif + +import System.Posix.Internals (c_getpid) +import System.IO.Error (isAlreadyExistsError) + +#if defined(mingw32_HOST_OS) || defined(ghcjs_HOST_OS) +import System.Directory ( createDirectory ) +#else +import qualified System.Posix +#endif + +-- ------------------------------------------------------------ +-- * temporary files +-- ------------------------------------------------------------ + +-- This is here for Haskell implementations that do not come with +-- System.IO.openTempFile. This includes nhc-1.20, hugs-2006.9. +-- TODO: This file should probably be removed. + +-- This is a copy/paste of the openBinaryTempFile definition, but +-- it uses 666 rather than 600 for the permissions. Newer versions +-- of base have a new function with this behavior which we use on +-- Windows when the new IO manager is used. +openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle) +openNewBinaryFile dir template = do + -- This method can't be used under WINIO. Also the current implementation has + -- thread safety issues depending on which GHC is used. On newer GHC's let's + -- use the built in one. +#if defined(__IO_MANAGER_WINIO__) + openBinaryTempFileWithDefaultPermissions dir template +#else + pid <- c_getpid + findTempName pid + where + -- We split off the last extension, so we can use .foo.ext files + -- for temporary files (hidden on Unix OSes). Unfortunately we're + -- below file path in the hierarchy here. + (prefix,suffix) = + case break (== '.') $ reverse template of + -- First case: template contains no '.'s. Just re-reverse it. + (rev_suffix, "") -> (reverse rev_suffix, "") + -- Second case: template contains at least one '.'. Strip the + -- dot from the prefix and prepend it to the suffix (if we don't + -- do this, the unique number will get added after the '.' and + -- thus be part of the extension, which is wrong.) + (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix) + -- Otherwise, something is wrong, because (break (== '.')) should + -- always return a pair with either the empty string or a string + -- beginning with '.' as the second component. + _ -> error "bug in System.IO.openTempFile" + + oflags = rw_flags .|. o_EXCL .|. o_BINARY + + findTempName x = do + fd <- withFilePath filepath $ \ f -> + c_open f oflags 0o666 + if fd < 0 + then do + errno <- getErrno + if errno == eEXIST + then findTempName (x+1) + else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir)) + else do + -- TODO: We want to tell fdToHandle what the file path is, + -- as any exceptions etc will only be able to report the + -- FD currently + h <- fdToHandle fd `onException` c_close fd + return (filepath, h) + where + filename = prefix ++ show x ++ suffix + filepath = dir `combine` filename + + -- FIXME: bits copied from System.FilePath + combine a b + | null b = a + | null a = b + | last a == pathSeparator = a ++ b + | otherwise = a ++ [pathSeparator] ++ b + +-- FIXME: Copied from GHC.Handle +std_flags, output_flags, rw_flags :: CInt +std_flags = o_NONBLOCK .|. o_NOCTTY +output_flags = std_flags .|. o_CREAT +rw_flags = output_flags .|. o_RDWR + +-- FIXME: Should use System.FilePath library +pathSeparator :: Char +#ifdef mingw32_HOST_OS +pathSeparator = '\\' +#else +pathSeparator = '/' +#endif +-- /* __IO_MANAGER_WINIO__ */ +#endif + +createTempDirectory :: FilePath -> String -> IO FilePath +createTempDirectory dir template = do + pid <- c_getpid + findTempName pid + where + findTempName x = do + let dirpath = dir template ++ "-" ++ show x + r <- tryIO $ mkPrivateDir dirpath + case r of + Right _ -> return dirpath + Left e | isAlreadyExistsError e -> findTempName (x+1) + | otherwise -> ioError e + +mkPrivateDir :: String -> IO () +#if defined(mingw32_HOST_OS) || defined(ghcjs_HOST_OS) +mkPrivateDir s = createDirectory s +#else +mkPrivateDir s = System.Posix.createDirectory s 0o700 +#endif diff --git a/cabal/Cabal/src/Distribution/Compat/Prelude/Internal.hs b/cabal/Cabal/src/Distribution/Compat/Prelude/Internal.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Compat/Prelude/Internal.hs @@ -0,0 +1,14 @@ +-- | This module re-exports the non-exposed +-- "Distribution.Compat.Prelude" module for +-- reuse by @cabal-install@'s +-- "Distribution.Client.Compat.Prelude" module. +-- +-- It is highly discouraged to rely on this module +-- for @Setup.hs@ scripts since its API is /not/ +-- stable. +module Distribution.Compat.Prelude.Internal + {-# WARNING "This modules' API is not stable. Use at your own risk, or better yet, use @base-compat@!" #-} + ( module Distribution.Compat.Prelude + ) where + +import Distribution.Compat.Prelude diff --git a/cabal/Cabal/src/Distribution/Compat/Process.hs b/cabal/Cabal/src/Distribution/Compat/Process.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Compat/Process.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE CPP #-} +module Distribution.Compat.Process ( + -- * Redefined functions + createProcess, + runInteractiveProcess, + rawSystem, + -- * Additions + enableProcessJobs, + ) where + +import System.Exit (ExitCode (..)) +import System.IO (Handle) + +import System.Process (CreateProcess, ProcessHandle, waitForProcess) +import qualified System.Process as Process + +#if defined(mingw32_HOST_OS) && MIN_VERSION_process(1,6,9) +import System.IO.Unsafe (unsafePerformIO) +import System.Win32.Info.Version (dwMajorVersion, dwMinorVersion, getVersionEx) +#endif + +------------------------------------------------------------------------------- +-- enableProcessJobs +------------------------------------------------------------------------------- + +#if defined(mingw32_HOST_OS) && MIN_VERSION_process(1,6,9) +-- This exception, needed to support Windows 7, could be removed when +-- the lowest GHC version cabal supports is a GHC that doesn’t support +-- Windows 7 any more. +{-# NOINLINE isWindows8OrLater #-} +isWindows8OrLater :: Bool +isWindows8OrLater = unsafePerformIO $ do + v <- getVersionEx + pure $ (dwMajorVersion v, dwMinorVersion v) >= (6, 2) +#endif + +-- | Enable process jobs to ensure accurate determination of process completion +-- in the presence of @exec(3)@ on Windows. +-- +-- Unfortunately the process job support is badly broken in @process@ releases +-- prior to 1.6.9, so we disable it in these versions, despite the fact that +-- this means we may see sporadic build failures without jobs. +-- +-- On Windows 7 or before the jobs are disabled due to the fact that +-- processes on these systems can only have one job. This prevents +-- spawned process from assigning jobs to its own children. Suppose +-- process A spawns process B. The B process has a job assigned (call +-- it J1) and when it tries to spawn a new process C the C +-- automatically inherits the job. But at it also tries to assign a +-- new job J2 to C since it doesn’t have access J1. This fails on +-- Windows 7 or before. +enableProcessJobs :: CreateProcess -> CreateProcess +#if defined(mingw32_HOST_OS) && MIN_VERSION_process(1,6,9) +enableProcessJobs cp = cp {Process.use_process_jobs = isWindows8OrLater} +#else +enableProcessJobs cp = cp +#endif + +------------------------------------------------------------------------------- +-- process redefinitions +------------------------------------------------------------------------------- + +-- | 'System.Process.createProcess' with process jobs enabled when appropriate. +-- See 'enableProcessJobs'. +createProcess :: CreateProcess + -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) +createProcess = Process.createProcess . enableProcessJobs + +-- | 'System.Process.rawSystem' with process jobs enabled when appropriate. +-- See 'enableProcessJobs'. +rawSystem :: String -> [String] -> IO ExitCode +rawSystem cmd args = do + (_,_,_,p) <- createProcess (Process.proc cmd args) { Process.delegate_ctlc = True } + waitForProcess p + +-- | 'System.Process.runInteractiveProcess' with process jobs enabled when +-- appropriate. See 'enableProcessJobs'. +runInteractiveProcess + :: FilePath -- ^ Filename of the executable (see 'RawCommand' for details) + -> [String] -- ^ Arguments to pass to the executable + -> Maybe FilePath -- ^ Optional path to the working directory + -> Maybe [(String,String)] -- ^ Optional environment (otherwise inherit) + -> IO (Handle,Handle,Handle,ProcessHandle) +runInteractiveProcess cmd args mb_cwd mb_env = do + (mb_in, mb_out, mb_err, p) <- + createProcess (Process.proc cmd args) + { Process.std_in = Process.CreatePipe, + Process.std_out = Process.CreatePipe, + Process.std_err = Process.CreatePipe, + Process.env = mb_env, + Process.cwd = mb_cwd } + return (fromJust mb_in, fromJust mb_out, fromJust mb_err, p) + where + fromJust = maybe (error "runInteractiveProcess: fromJust") id diff --git a/cabal/Cabal/src/Distribution/Compat/ResponseFile.hs b/cabal/Cabal/src/Distribution/Compat/ResponseFile.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Compat/ResponseFile.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE CPP, RankNTypes, FlexibleContexts #-} + +-- Compatibility layer for GHC.ResponseFile +-- Implementation from base 4.12.0 is used. +-- http://hackage.haskell.org/package/base-4.12.0.0/src/LICENSE +module Distribution.Compat.ResponseFile (expandResponse) where + +import Distribution.Compat.Prelude +import Prelude () + +import System.FilePath +import System.IO (hPutStrLn, stderr) +import System.IO.Error + +#if MIN_VERSION_base(4,12,0) +import GHC.ResponseFile (unescapeArgs) +#else + +unescapeArgs :: String -> [String] +unescapeArgs = filter (not . null) . unescape + +data Quoting = NoneQ | SngQ | DblQ + +unescape :: String -> [String] +unescape args = reverse . map reverse $ go args NoneQ False [] [] + where + -- n.b., the order of these cases matters; these are cribbed from gcc + -- case 1: end of input + go [] _q _bs a as = a:as + -- case 2: back-slash escape in progress + go (c:cs) q True a as = go cs q False (c:a) as + -- case 3: no back-slash escape in progress, but got a back-slash + go (c:cs) q False a as + | '\\' == c = go cs q True a as + -- case 4: single-quote escaping in progress + go (c:cs) SngQ False a as + | '\'' == c = go cs NoneQ False a as + | otherwise = go cs SngQ False (c:a) as + -- case 5: double-quote escaping in progress + go (c:cs) DblQ False a as + | '"' == c = go cs NoneQ False a as + | otherwise = go cs DblQ False (c:a) as + -- case 6: no escaping is in progress + go (c:cs) NoneQ False a as + | isSpace c = go cs NoneQ False [] (a:as) + | '\'' == c = go cs SngQ False a as + | '"' == c = go cs DblQ False a as + | otherwise = go cs NoneQ False (c:a) as + +#endif + +expandResponse :: [String] -> IO [String] +expandResponse = go recursionLimit "." + where + recursionLimit = 100 + + go :: Int -> FilePath -> [String] -> IO [String] + go n dir + | n >= 0 = fmap concat . traverse (expand n dir) + | otherwise = const $ hPutStrLn stderr "Error: response file recursion limit exceeded." >> exitFailure + + expand :: Int -> FilePath -> String -> IO [String] + expand n dir arg@('@':f) = readRecursively n (dir f) `catchIOError` (const $ print "?" >> return [arg]) + expand _n _dir x = return [x] + + readRecursively :: Int -> FilePath -> IO [String] + readRecursively n f = go (n - 1) (takeDirectory f) =<< unescapeArgs <$> readFile f diff --git a/cabal/Cabal/src/Distribution/Compat/SnocList.hs b/cabal/Cabal/src/Distribution/Compat/SnocList.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Compat/SnocList.hs @@ -0,0 +1,33 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Compat.SnocList +-- License : BSD3 +-- +-- Maintainer : cabal-dev@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- A very reversed list. Has efficient `snoc` +module Distribution.Compat.SnocList ( + SnocList, + runSnocList, + snoc, +) where + +import Prelude () +import Distribution.Compat.Prelude + +newtype SnocList a = SnocList [a] + +snoc :: SnocList a -> a -> SnocList a +snoc (SnocList xs) x = SnocList (x : xs) + +runSnocList :: SnocList a -> [a] +runSnocList (SnocList xs) = reverse xs + +instance Semigroup (SnocList a) where + SnocList xs <> SnocList ys = SnocList (ys <> xs) + +instance Monoid (SnocList a) where + mempty = SnocList [] + mappend = (<>) diff --git a/cabal/Cabal/src/Distribution/Compat/Stack.hs b/cabal/Cabal/src/Distribution/Compat/Stack.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Compat/Stack.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ImplicitParams #-} +module Distribution.Compat.Stack ( + WithCallStack, + CallStack, + annotateCallStackIO, + withFrozenCallStack, + withLexicalCallStack, + callStack, + prettyCallStack, + parentSrcLocPrefix +) where + +import System.IO.Error + +#ifdef MIN_VERSION_base +#if MIN_VERSION_base(4,8,1) +#define GHC_STACK_SUPPORTED 1 +#endif +#endif + +#ifdef GHC_STACK_SUPPORTED +import GHC.Stack +#endif + +#ifdef GHC_STACK_SUPPORTED + +#if MIN_VERSION_base(4,9,0) +type WithCallStack a = HasCallStack => a +#elif MIN_VERSION_base(4,8,1) +type WithCallStack a = (?callStack :: CallStack) => a +#endif + +#if !MIN_VERSION_base(4,9,0) +-- NB: Can't say WithCallStack (WithCallStack a -> a); +-- Haskell doesn't support this kind of implicit parameter! +-- See https://mail.haskell.org/pipermail/ghc-devs/2016-January/011096.html +-- Since this function doesn't do anything, it's OK to +-- give it a less good type. +withFrozenCallStack :: WithCallStack (a -> a) +withFrozenCallStack x = x + +callStack :: (?callStack :: CallStack) => CallStack +callStack = ?callStack + +prettyCallStack :: CallStack -> String +prettyCallStack = showCallStack +#endif + +-- | Give the *parent* of the person who invoked this; +-- so it's most suitable for being called from a utility function. +-- You probably want to call this using 'withFrozenCallStack'; otherwise +-- it's not very useful. We didn't implement this for base-4.8.1 +-- because we cannot rely on freezing to have taken place. +-- +parentSrcLocPrefix :: WithCallStack String +#if MIN_VERSION_base(4,9,0) +parentSrcLocPrefix = + case getCallStack callStack of + (_:(_, loc):_) -> showLoc loc + [(_, loc)] -> showLoc loc + [] -> error "parentSrcLocPrefix: empty call stack" + where + showLoc loc = + srcLocFile loc ++ ":" ++ show (srcLocStartLine loc) ++ ": " +#else +parentSrcLocPrefix = "Call sites not available with base < 4.9.0.0 (GHC 8.0): " +#endif + +-- Yeah, this uses skivvy implementation details. +withLexicalCallStack :: (a -> WithCallStack (IO b)) -> WithCallStack (a -> IO b) +withLexicalCallStack f = + let stk = ?callStack + in \x -> let ?callStack = stk in f x + +#else + +data CallStack = CallStack + deriving (Eq, Show) + +type WithCallStack a = a + +withFrozenCallStack :: a -> a +withFrozenCallStack x = x + +callStack :: CallStack +callStack = CallStack + +prettyCallStack :: CallStack -> String +prettyCallStack _ = "Call stacks not available with base < 4.8.1.0 (GHC 7.10)" + +parentSrcLocPrefix :: String +parentSrcLocPrefix = "Call sites not available with base < 4.9.0.0 (GHC 8.0): " + +withLexicalCallStack :: (a -> IO b) -> a -> IO b +withLexicalCallStack f = f + +#endif + +-- | This function is for when you *really* want to add a call +-- stack to raised IO, but you don't have a +-- 'Distribution.Verbosity.Verbosity' so you can't use +-- 'Distribution.Simple.Utils.annotateIO'. If you have a 'Verbosity', +-- please use that function instead. +annotateCallStackIO :: WithCallStack (IO a -> IO a) +annotateCallStackIO = modifyIOError f + where + f ioe = ioeSetErrorString ioe + . wrapCallStack + $ ioeGetErrorString ioe + wrapCallStack s = + prettyCallStack callStack ++ "\n" ++ s diff --git a/cabal/Cabal/src/Distribution/Compat/Time.hs b/cabal/Cabal/src/Distribution/Compat/Time.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Compat/Time.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Distribution.Compat.Time + ( ModTime(..) -- Needed for testing + , getModTime, getFileAge, getCurTime + , posixSecondsToModTime + , calibrateMtimeChangeDelay ) + where + +import Prelude () +import Distribution.Compat.Prelude + +import System.Directory ( getModificationTime ) + +import Distribution.Simple.Utils ( withTempDirectory ) +import Distribution.Verbosity ( silent ) + +import System.FilePath + +import Data.Time.Clock.POSIX ( POSIXTime, getPOSIXTime ) +import Data.Time ( diffUTCTime, getCurrentTime ) +import Data.Time.Clock.POSIX ( posixDayLength ) + + +#if defined mingw32_HOST_OS + +import qualified Prelude +import Data.Bits ((.|.), unsafeShiftL) +#if MIN_VERSION_base(4,7,0) +import Data.Bits (finiteBitSize) +#else +import Data.Bits (bitSize) +#endif + +import Foreign ( allocaBytes, peekByteOff ) +import System.IO.Error ( mkIOError, doesNotExistErrorType ) +import System.Win32.Types ( BOOL, DWORD, LPCTSTR, LPVOID, withTString ) + +#else + +import System.Posix.Files ( FileStatus, getFileStatus ) + +#if MIN_VERSION_unix(2,6,0) +import System.Posix.Files ( modificationTimeHiRes ) +#else +import System.Posix.Files ( modificationTime ) +#endif + +#endif + +-- | An opaque type representing a file's modification time, represented +-- internally as a 64-bit unsigned integer in the Windows UTC format. +newtype ModTime = ModTime Word64 + deriving (Binary, Generic, Bounded, Eq, Ord, Typeable) + +instance Structured ModTime + +instance Show ModTime where + show (ModTime x) = show x + +instance Read ModTime where + readsPrec p str = map (first ModTime) (readsPrec p str) + +-- | Return modification time of the given file. Works around the low clock +-- resolution problem that 'getModificationTime' has on GHC < 7.8. +-- +-- This is a modified version of the code originally written for Shake by Neil +-- Mitchell. See module Development.Shake.FileInfo. +getModTime :: FilePath -> IO ModTime + +#if defined mingw32_HOST_OS + +-- Directly against the Win32 API. +getModTime path = allocaBytes size_WIN32_FILE_ATTRIBUTE_DATA $ \info -> do + res <- getFileAttributesEx path info + if not res + then do + let err = mkIOError doesNotExistErrorType + "Distribution.Compat.Time.getModTime" + Nothing (Just path) + ioError err + else do + dwLow <- peekByteOff info + index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime + dwHigh <- peekByteOff info + index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwHighDateTime +#if MIN_VERSION_base(4,7,0) + let qwTime = + (fromIntegral (dwHigh :: DWORD) `unsafeShiftL` finiteBitSize dwHigh) + .|. (fromIntegral (dwLow :: DWORD)) +#else + let qwTime = + (fromIntegral (dwHigh :: DWORD) `unsafeShiftL` bitSize dwHigh) + .|. (fromIntegral (dwLow :: DWORD)) +#endif + return $! ModTime (qwTime :: Word64) + +#ifdef x86_64_HOST_ARCH +#define CALLCONV ccall +#else +#define CALLCONV stdcall +#endif + +foreign import CALLCONV "windows.h GetFileAttributesExW" + c_getFileAttributesEx :: LPCTSTR -> Int32 -> LPVOID -> Prelude.IO BOOL + +getFileAttributesEx :: String -> LPVOID -> IO BOOL +getFileAttributesEx path lpFileInformation = + withTString path $ \c_path -> + c_getFileAttributesEx c_path getFileExInfoStandard lpFileInformation + +getFileExInfoStandard :: Int32 +getFileExInfoStandard = 0 + +size_WIN32_FILE_ATTRIBUTE_DATA :: Int +size_WIN32_FILE_ATTRIBUTE_DATA = 36 + +index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime :: Int +index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime = 20 + +index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwHighDateTime :: Int +index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwHighDateTime = 24 + +#else + +-- Directly against the unix library. +getModTime path = do + st <- getFileStatus path + return $! (extractFileTime st) + +extractFileTime :: FileStatus -> ModTime +extractFileTime x = posixTimeToModTime (modificationTimeHiRes x) + +#endif + +windowsTick, secToUnixEpoch :: Word64 +windowsTick = 10000000 +secToUnixEpoch = 11644473600 + +-- | Convert POSIX seconds to ModTime. +posixSecondsToModTime :: Int64 -> ModTime +posixSecondsToModTime s = + ModTime $ ((fromIntegral s :: Word64) + secToUnixEpoch) * windowsTick + +-- | Convert 'POSIXTime' to 'ModTime'. +posixTimeToModTime :: POSIXTime -> ModTime +posixTimeToModTime p = ModTime $ (ceiling $ p * 1e7) -- 100 ns precision + + (secToUnixEpoch * windowsTick) + +-- | Return age of given file in days. +getFileAge :: FilePath -> IO Double +getFileAge file = do + t0 <- getModificationTime file + t1 <- getCurrentTime + return $ realToFrac (t1 `diffUTCTime` t0) / realToFrac posixDayLength + +-- | Return the current time as 'ModTime'. +getCurTime :: IO ModTime +getCurTime = posixTimeToModTime `fmap` getPOSIXTime -- Uses 'gettimeofday'. + +-- | Based on code written by Neil Mitchell for Shake. See +-- 'sleepFileTimeCalibrate' in 'Test.Type'. Returns a pair +-- of microsecond values: first, the maximum delay seen, and the +-- recommended delay to use before testing for file modification change. +-- The returned delay is never smaller +-- than 10 ms, but never larger than 1 second. +calibrateMtimeChangeDelay :: IO (Int, Int) +calibrateMtimeChangeDelay = + withTempDirectory silent "." "calibration-" $ \dir -> do + let fileName = dir "probe" + mtimes <- for [1..25] $ \(i::Int) -> time $ do + writeFile fileName $ show i + t0 <- getModTime fileName + let spin j = do + writeFile fileName $ show (i,j) + t1 <- getModTime fileName + unless (t0 < t1) (spin $ j + 1) + spin (0::Int) + let mtimeChange = maximum mtimes + mtimeChange' = min 1000000 $ (max 10000 mtimeChange) * 2 + return (mtimeChange, mtimeChange') + where + time :: IO () -> IO Int + time act = do + t0 <- getCurrentTime + act + t1 <- getCurrentTime + return . ceiling $! (t1 `diffUTCTime` t0) * 1e6 -- microseconds diff --git a/cabal/Cabal/src/Distribution/GetOpt.hs b/cabal/Cabal/src/Distribution/GetOpt.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/GetOpt.hs @@ -0,0 +1,263 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.GetOpt +-- Copyright : (c) Sven Panne 2002-2005 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Portability : portable +-- +-- This is a fork of "System.Console.GetOpt" with the following changes: +-- +-- * Treat "cabal --flag command" as "cabal command --flag" e.g. +-- "cabal -v configure" to mean "cabal configure -v" For flags that are +-- not recognised as global flags, pass them on to the sub-command. See +-- the difference in 'shortOpt'. +-- +-- * Line wrapping in the 'usageInfo' output, plus a more compact +-- rendering of short options, and slightly less padding. +-- +-- * Parsing of option arguments is allowed to fail. +-- +-- * 'ReturnInOrder' argument order is removed. +-- +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE NamedFieldPuns #-} +module Distribution.GetOpt ( + -- * GetOpt + getOpt, getOpt', + usageInfo, + ArgOrder(..), + OptDescr(..), + ArgDescr(..), + + -- * Example + -- | See "System.Console.GetOpt" for examples +) where + +import Prelude () +import Distribution.Compat.Prelude + +-- | What to do with options following non-options +data ArgOrder a + = RequireOrder -- ^ no option processing after first non-option + | Permute -- ^ freely intersperse options and non-options + +data OptDescr a = -- description of a single options: + Option [Char] -- list of short option characters + [String] -- list of long option strings (without "--") + (ArgDescr a) -- argument descriptor + String -- explanation of option for user + +instance Functor OptDescr where + fmap f (Option a b argDescr c) = Option a b (fmap f argDescr) c + +-- | Describes whether an option takes an argument or not, and if so +-- how the argument is parsed to a value of type @a@. +-- +-- Compared to System.Console.GetOpt, we allow for parse errors. +data ArgDescr a + = NoArg a -- ^ no argument expected + | ReqArg (String -> Either String a) String -- ^ option requires argument + | OptArg (Maybe String -> Either String a) String -- ^ optional argument + +instance Functor ArgDescr where + fmap f (NoArg a) = NoArg (f a) + fmap f (ReqArg g s) = ReqArg (fmap f . g) s + fmap f (OptArg g s) = OptArg (fmap f . g) s + +data OptKind a -- kind of cmd line arg (internal use only): + = Opt a -- an option + | UnreqOpt String -- an un-recognized option + | NonOpt String -- a non-option + | EndOfOpts -- end-of-options marker (i.e. "--") + | OptErr String -- something went wrong... + +data OptHelp = OptHelp { + optNames :: String, + optHelp :: String + } + +-- | Return a string describing the usage of a command, derived from +-- the header (first argument) and the options described by the +-- second argument. +usageInfo :: String -- header + -> [OptDescr a] -- option descriptors + -> String -- nicely formatted description of options +usageInfo header optDescr = unlines (header : table) + where + options = flip map optDescr $ \(Option sos los ad d) -> + OptHelp + { optNames = + intercalate ", " $ + map (fmtShort ad) sos ++ + map (fmtLong ad) (take 1 los) + , optHelp = d + } + + maxOptNameWidth = 30 + descolWidth = 80 - (maxOptNameWidth + 3) + + table :: [String] + table = do + OptHelp{optNames, optHelp} <- options + let wrappedHelp = wrapText descolWidth optHelp + if length optNames >= maxOptNameWidth + then [" " ++ optNames] ++ + renderColumns [] wrappedHelp + else renderColumns [optNames] wrappedHelp + + renderColumns :: [String] -> [String] -> [String] + renderColumns xs ys = do + (x, y) <- zipDefault "" "" xs ys + return $ " " ++ padTo maxOptNameWidth x ++ " " ++ y + + padTo n x = take n (x ++ repeat ' ') + +zipDefault :: a -> b -> [a] -> [b] -> [(a,b)] +zipDefault _ _ [] [] = [] +zipDefault _ bd (a:as) [] = (a,bd) : map (,bd) as +zipDefault ad _ [] (b:bs) = (ad,b) : map (ad,) bs +zipDefault ad bd (a:as) (b:bs) = (a,b) : zipDefault ad bd as bs + +fmtShort :: ArgDescr a -> Char -> String +fmtShort (NoArg _ ) so = "-" ++ [so] +fmtShort (ReqArg _ _) so = "-" ++ [so] +fmtShort (OptArg _ _) so = "-" ++ [so] + -- unlike upstream GetOpt we omit the arg name for short options + +fmtLong :: ArgDescr a -> String -> String +fmtLong (NoArg _ ) lo = "--" ++ lo +fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad +fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]" + +wrapText :: Int -> String -> [String] +wrapText width = map unwords . wrap 0 [] . words + where wrap :: Int -> [String] -> [String] -> [[String]] + wrap 0 [] (w:ws) + | length w + 1 > width + = wrap (length w) [w] ws + wrap col line (w:ws) + | col + length w + 1 > width + = reverse line : wrap 0 [] (w:ws) + wrap col line (w:ws) + = let col' = col + length w + 1 + in wrap col' (w:line) ws + wrap _ [] [] = [] + wrap _ line [] = [reverse line] + +{-| +Process the command-line, and return the list of values that matched +(and those that didn\'t). The arguments are: + +* The order requirements (see 'ArgOrder') + +* The option descriptions (see 'OptDescr') + +* The actual command line arguments (presumably got from + 'System.Environment.getArgs'). + +'getOpt' returns a triple consisting of the option arguments, a list +of non-options, and a list of error messages. +-} +getOpt :: ArgOrder a -- non-option handling + -> [OptDescr a] -- option descriptors + -> [String] -- the command-line arguments + -> ([a],[String],[String]) -- (options,non-options,error messages) +getOpt ordering optDescr args = (os,xs,es ++ map errUnrec us) + where (os,xs,us,es) = getOpt' ordering optDescr args + +{-| +This is almost the same as 'getOpt', but returns a quadruple +consisting of the option arguments, a list of non-options, a list of +unrecognized options, and a list of error messages. +-} +getOpt' :: ArgOrder a -- non-option handling + -> [OptDescr a] -- option descriptors + -> [String] -- the command-line arguments + -> ([a],[String], [String] ,[String]) -- (options,non-options,unrecognized,error messages) +getOpt' _ _ [] = ([],[],[],[]) +getOpt' ordering optDescr (arg:args) = procNextOpt opt ordering + where procNextOpt (Opt o) _ = (o:os,xs,us,es) + procNextOpt (UnreqOpt u) _ = (os,xs,u:us,es) + procNextOpt (NonOpt x) RequireOrder = ([],x:rest,[],[]) + procNextOpt (NonOpt x) Permute = (os,x:xs,us,es) + procNextOpt EndOfOpts RequireOrder = ([],rest,[],[]) + procNextOpt EndOfOpts Permute = ([],rest,[],[]) + procNextOpt (OptErr e) _ = (os,xs,us,e:es) + + (opt,rest) = getNext arg args optDescr + (os,xs,us,es) = getOpt' ordering optDescr rest + +-- take a look at the next cmd line arg and decide what to do with it +getNext :: String -> [String] -> [OptDescr a] -> (OptKind a,[String]) +getNext ('-':'-':[]) rest _ = (EndOfOpts,rest) +getNext ('-':'-':xs) rest optDescr = longOpt xs rest optDescr +getNext ('-': x :xs) rest optDescr = shortOpt x xs rest optDescr +getNext a rest _ = (NonOpt a,rest) + +-- handle long option +longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String]) +longOpt ls rs optDescr = long ads arg rs + where (opt,arg) = break (=='=') ls + getWith p = [ o | o@(Option _ xs _ _) <- optDescr + , isJust (find (p opt) xs)] + exact = getWith (==) + options = if null exact then getWith isPrefixOf else exact + ads = [ ad | Option _ _ ad _ <- options ] + optStr = "--" ++ opt + fromRes = fromParseResult optStr + + long (_:_:_) _ rest = (errAmbig options optStr,rest) + long [NoArg a ] [] rest = (Opt a,rest) + long [NoArg _ ] ('=':_) rest = (errNoArg optStr,rest) + long [ReqArg _ d] [] [] = (errReq d optStr,[]) + long [ReqArg f _] [] (r:rest) = (fromRes (f r),rest) + long [ReqArg f _] ('=':xs) rest = (fromRes (f xs),rest) + long [OptArg f _] [] rest = (fromRes (f Nothing),rest) + long [OptArg f _] ('=':xs) rest = (fromRes (f (Just xs)),rest) + long _ _ rest = (UnreqOpt ("--"++ls),rest) + +-- handle short option +shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a,[String]) +shortOpt y ys rs optDescr = short ads ys rs + where options = [ o | o@(Option ss _ _ _) <- optDescr, s <- ss, y == s ] + ads = [ ad | Option _ _ ad _ <- options ] + optStr = '-':[y] + fromRes = fromParseResult optStr + + short (_:_:_) _ rest = (errAmbig options optStr,rest) + short (NoArg a :_) [] rest = (Opt a,rest) + short (NoArg a :_) xs rest = (Opt a,('-':xs):rest) + short (ReqArg _ d:_) [] [] = (errReq d optStr,[]) + short (ReqArg f _:_) [] (r:rest) = (fromRes (f r),rest) + short (ReqArg f _:_) xs rest = (fromRes (f xs),rest) + short (OptArg f _:_) [] rest = (fromRes (f Nothing),rest) + short (OptArg f _:_) xs rest = (fromRes (f (Just xs)),rest) + short [] [] rest = (UnreqOpt optStr,rest) + short [] xs rest = (UnreqOpt (optStr++xs),rest) + -- This is different vs upstream = (UnreqOpt optStr,('-':xs):rest) + -- Apparently this was part of the change so that flags that are + -- not recognised as global flags are passed on to the sub-command. + -- But why was no equivalent change required for longOpt? So could + -- this change go upstream? + +fromParseResult :: String -> Either String a -> OptKind a +fromParseResult optStr res = case res of + Right x -> Opt x + Left err -> OptErr ("invalid argument to option `" ++ optStr ++ "': " ++ err ++ "\n") + +-- miscellaneous error formatting + +errAmbig :: [OptDescr a] -> String -> OptKind b +errAmbig ods optStr = OptErr (usageInfo header ods) + where header = "option `" ++ optStr ++ "' is ambiguous; could be one of:" + +errReq :: String -> String -> OptKind a +errReq d optStr = OptErr ("option `" ++ optStr ++ "' requires an argument " ++ d ++ "\n") + +errUnrec :: String -> String +errUnrec optStr = "unrecognized option `" ++ optStr ++ "'\n" + +errNoArg :: String -> OptKind a +errNoArg optStr = OptErr ("option `" ++ optStr ++ "' doesn't allow an argument\n") diff --git a/cabal/Cabal/src/Distribution/Lex.hs b/cabal/Cabal/src/Distribution/Lex.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Lex.hs @@ -0,0 +1,40 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Lex +-- Copyright : Ben Gamari 2015-2019 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module contains a simple lexer supporting quoted strings + +module Distribution.Lex ( + tokenizeQuotedWords + ) where + +import Prelude () +import Distribution.Compat.Prelude +import Distribution.Compat.DList + +tokenizeQuotedWords :: String -> [String] +tokenizeQuotedWords = filter (not . null) . go False mempty + where + go :: Bool -- ^ in quoted region + -> DList Char -- ^ accumulator + -> String -- ^ string to be parsed + -> [String] -- ^ parse result + go _ accum [] + | [] <- accum' = [] + | otherwise = [accum'] + where accum' = runDList accum + + go False accum (c:cs) + | isSpace c = runDList accum : go False mempty cs + | c == '"' = go True accum cs + + go True accum (c:cs) + | c == '"' = go False accum cs + + go quoted accum (c:cs) + = go quoted (accum `mappend` singleton c) cs + diff --git a/cabal/Cabal/src/Distribution/Make.hs b/cabal/Cabal/src/Distribution/Make.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Make.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Make +-- Copyright : Martin Sjögren 2004 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is an alternative build system that delegates everything to the @make@ +-- program. All the commands just end up calling @make@ with appropriate +-- arguments. The intention was to allow preexisting packages that used +-- makefiles to be wrapped into Cabal packages. In practice essentially all +-- such packages were converted over to the \"Simple\" build system instead. +-- Consequently this module is not used much and it certainly only sees cursory +-- maintenance and no testing. Perhaps at some point we should stop pretending +-- that it works. +-- +-- Uses the parsed command-line from "Distribution.Simple.Setup" in order to build +-- Haskell tools using a back-end build system based on make. Obviously we +-- assume that there is a configure script, and that after the ConfigCmd has +-- been run, there is a Makefile. Further assumptions: +-- +-- [ConfigCmd] We assume the configure script accepts +-- @--with-hc@, +-- @--with-hc-pkg@, +-- @--prefix@, +-- @--bindir@, +-- @--libdir@, +-- @--libexecdir@, +-- @--datadir@. +-- +-- [BuildCmd] We assume that the default Makefile target will build everything. +-- +-- [InstallCmd] We assume there is an @install@ target. Note that we assume that +-- this does *not* register the package! +-- +-- [CopyCmd] We assume there is a @copy@ target, and a variable @$(destdir)@. +-- The @copy@ target should probably just invoke @make install@ +-- recursively (e.g. @$(MAKE) install prefix=$(destdir)\/$(prefix) +-- bindir=$(destdir)\/$(bindir)@. The reason we can\'t invoke @make +-- install@ directly here is that we don\'t know the value of @$(prefix)@. +-- +-- [SDistCmd] We assume there is a @dist@ target. +-- +-- [RegisterCmd] We assume there is a @register@ target and a variable @$(user)@. +-- +-- [UnregisterCmd] We assume there is an @unregister@ target. +-- +-- [HaddockCmd] We assume there is a @docs@ or @doc@ target. + + +-- copy : +-- $(MAKE) install prefix=$(destdir)/$(prefix) \ +-- bindir=$(destdir)/$(bindir) \ + +module Distribution.Make ( + module Distribution.Package, + License(..), Version, + defaultMain, defaultMainArgs + ) where + +import Prelude () +import Distribution.Compat.Prelude + +-- local +import Distribution.Package +import Distribution.Simple.Program +import Distribution.Simple.Setup +import Distribution.Simple.Command + +import Distribution.Simple.Utils + +import Distribution.License +import Distribution.Version +import Distribution.Pretty + +import System.Environment (getArgs, getProgName) + +defaultMain :: IO () +defaultMain = getArgs >>= defaultMainArgs + +defaultMainArgs :: [String] -> IO () +defaultMainArgs = defaultMainHelper + +defaultMainHelper :: [String] -> IO () +defaultMainHelper args = + case commandsRun (globalCommand commands) commands args of + CommandHelp help -> printHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo (flags, commandParse) -> + case commandParse of + _ | fromFlag (globalVersion flags) -> printVersion + | fromFlag (globalNumericVersion flags) -> printNumericVersion + CommandHelp help -> printHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo action -> action + + where + printHelp help = getProgName >>= putStr . help + printOptionsList = putStr . unlines + printErrors errs = do + putStr (intercalate "\n" errs) + exitWith (ExitFailure 1) + printNumericVersion = putStrLn $ prettyShow cabalVersion + printVersion = putStrLn $ "Cabal library version " + ++ prettyShow cabalVersion + + progs = defaultProgramDb + commands = + [configureCommand progs `commandAddAction` configureAction + ,buildCommand progs `commandAddAction` buildAction + ,installCommand `commandAddAction` installAction + ,copyCommand `commandAddAction` copyAction + ,haddockCommand `commandAddAction` haddockAction + ,cleanCommand `commandAddAction` cleanAction + ,sdistCommand `commandAddAction` sdistAction + ,registerCommand `commandAddAction` registerAction + ,unregisterCommand `commandAddAction` unregisterAction + ] + +configureAction :: ConfigFlags -> [String] -> IO () +configureAction flags args = do + noExtraFlags args + let verbosity = fromFlag (configVerbosity flags) + rawSystemExit verbosity "sh" $ + "configure" + : configureArgs backwardsCompatHack flags + where backwardsCompatHack = True + +copyAction :: CopyFlags -> [String] -> IO () +copyAction flags args = do + noExtraFlags args + let destArgs = case fromFlag $ copyDest flags of + NoCopyDest -> ["install"] + CopyTo path -> ["copy", "destdir=" ++ path] + CopyToDb _ -> error "CopyToDb not supported via Make" + + rawSystemExit (fromFlag $ copyVerbosity flags) "make" destArgs + +installAction :: InstallFlags -> [String] -> IO () +installAction flags args = do + noExtraFlags args + rawSystemExit (fromFlag $ installVerbosity flags) "make" ["install"] + rawSystemExit (fromFlag $ installVerbosity flags) "make" ["register"] + +haddockAction :: HaddockFlags -> [String] -> IO () +haddockAction flags args = do + noExtraFlags args + rawSystemExit (fromFlag $ haddockVerbosity flags) "make" ["docs"] + `catchIO` \_ -> + rawSystemExit (fromFlag $ haddockVerbosity flags) "make" ["doc"] + +buildAction :: BuildFlags -> [String] -> IO () +buildAction flags args = do + noExtraFlags args + rawSystemExit (fromFlag $ buildVerbosity flags) "make" [] + +cleanAction :: CleanFlags -> [String] -> IO () +cleanAction flags args = do + noExtraFlags args + rawSystemExit (fromFlag $ cleanVerbosity flags) "make" ["clean"] + +sdistAction :: SDistFlags -> [String] -> IO () +sdistAction flags args = do + noExtraFlags args + rawSystemExit (fromFlag $ sDistVerbosity flags) "make" ["dist"] + +registerAction :: RegisterFlags -> [String] -> IO () +registerAction flags args = do + noExtraFlags args + rawSystemExit (fromFlag $ regVerbosity flags) "make" ["register"] + +unregisterAction :: RegisterFlags -> [String] -> IO () +unregisterAction flags args = do + noExtraFlags args + rawSystemExit (fromFlag $ regVerbosity flags) "make" ["unregister"] diff --git a/cabal/Cabal/src/Distribution/PackageDescription/Check.hs b/cabal/Cabal/src/Distribution/PackageDescription/Check.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/PackageDescription/Check.hs @@ -0,0 +1,2417 @@ +{-# LANGUAGE NoMonoLocalBinds #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.PackageDescription.Check +-- Copyright : Lennart Kolmodin 2008 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This has code for checking for various problems in packages. There is one +-- set of checks that just looks at a 'PackageDescription' in isolation and +-- another set of checks that also looks at files in the package. Some of the +-- checks are basic sanity checks, others are portability standards that we'd +-- like to encourage. There is a 'PackageCheck' type that distinguishes the +-- different kinds of checks so we can see which ones are appropriate to report +-- in different situations. This code gets used when configuring a package when +-- we consider only basic problems. The higher standard is used when +-- preparing a source tarball and by Hackage when uploading new packages. The +-- reason for this is that we want to hold packages that are expected to be +-- distributed to a higher standard than packages that are only ever expected +-- to be used on the author's own environment. + +module Distribution.PackageDescription.Check ( + -- * Package Checking + PackageCheck(..), + checkPackage, + checkConfiguredPackage, + + -- ** Checking package contents + checkPackageFiles, + checkPackageContent, + CheckPackageContentOps(..), + checkPackageFileNames, + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Data.List (group) +import Distribution.CabalSpecVersion +import Distribution.Compat.Lens +import Distribution.Compiler +import Distribution.License +import Distribution.Package +import Distribution.PackageDescription +import Distribution.PackageDescription.Configuration +import Distribution.Pretty (prettyShow) +import Distribution.Simple.BuildPaths (autogenPathsModuleName) +import Distribution.Simple.BuildToolDepends +import Distribution.Simple.CCompiler +import Distribution.Simple.Glob +import Distribution.Simple.Utils hiding (findPackageDesc, notice) +import Distribution.System +import Distribution.Types.ComponentRequestedSpec +import Distribution.Types.PackageName.Magic +import Distribution.Utils.Generic (isAscii) +import Distribution.Verbosity +import Distribution.Version +import Distribution.Utils.Path +import Language.Haskell.Extension +import System.FilePath + (splitDirectories, splitExtension, splitPath, takeExtension, takeFileName, (<.>), ()) + +import qualified Data.ByteString.Lazy as BS +import qualified Data.Map as Map +import qualified Distribution.Compat.DList as DList +import qualified Distribution.SPDX as SPDX +import qualified System.Directory as System + +import qualified System.Directory (getDirectoryContents) +import qualified System.FilePath.Windows as FilePath.Windows (isValid) + +import qualified Data.Set as Set +import qualified Distribution.Utils.ShortText as ShortText + +import qualified Distribution.Types.BuildInfo.Lens as L +import qualified Distribution.Types.GenericPackageDescription.Lens as L +import qualified Distribution.Types.PackageDescription.Lens as L + +-- $setup +-- >>> import Control.Arrow ((&&&)) + +-- | Results of some kind of failed package check. +-- +-- There are a range of severities, from merely dubious to totally insane. +-- All of them come with a human readable explanation. In future we may augment +-- them with more machine readable explanations, for example to help an IDE +-- suggest automatic corrections. +-- +data PackageCheck = + + -- | This package description is no good. There's no way it's going to + -- build sensibly. This should give an error at configure time. + PackageBuildImpossible { explanation :: String } + + -- | A problem that is likely to affect building the package, or an + -- issue that we'd like every package author to be aware of, even if + -- the package is never distributed. + | PackageBuildWarning { explanation :: String } + + -- | An issue that might not be a problem for the package author but + -- might be annoying or detrimental when the package is distributed to + -- users. We should encourage distributed packages to be free from these + -- issues, but occasionally there are justifiable reasons so we cannot + -- ban them entirely. + | PackageDistSuspicious { explanation :: String } + + -- | Like PackageDistSuspicious but will only display warnings + -- rather than causing abnormal exit when you run 'cabal check'. + | PackageDistSuspiciousWarn { explanation :: String } + + -- | An issue that is OK in the author's environment but is almost + -- certain to be a portability problem for other environments. We can + -- quite legitimately refuse to publicly distribute packages with these + -- problems. + | PackageDistInexcusable { explanation :: String } + deriving (Eq, Ord) + +instance Show PackageCheck where + show notice = explanation notice + +check :: Bool -> PackageCheck -> Maybe PackageCheck +check False _ = Nothing +check True pc = Just pc + +checkSpecVersion :: PackageDescription -> CabalSpecVersion -> Bool -> PackageCheck + -> Maybe PackageCheck +checkSpecVersion pkg specver cond pc + | specVersion pkg >= specver = Nothing + | otherwise = check cond pc + +-- ------------------------------------------------------------ +-- * Standard checks +-- ------------------------------------------------------------ + +-- | Check for common mistakes and problems in package descriptions. +-- +-- This is the standard collection of checks covering all aspects except +-- for checks that require looking at files within the package. For those +-- see 'checkPackageFiles'. +-- +-- It requires the 'GenericPackageDescription' and optionally a particular +-- configuration of that package. If you pass 'Nothing' then we just check +-- a version of the generic description using 'flattenPackageDescription'. +-- +checkPackage :: GenericPackageDescription + -> Maybe PackageDescription + -> [PackageCheck] +checkPackage gpkg mpkg = + checkConfiguredPackage pkg + ++ checkConditionals gpkg + ++ checkPackageVersions gpkg + ++ checkDevelopmentOnlyFlags gpkg + ++ checkFlagNames gpkg + ++ checkUnusedFlags gpkg + ++ checkUnicodeXFields gpkg + ++ checkPathsModuleExtensions pkg + ++ checkSetupVersions gpkg + ++ checkDuplicateModules gpkg + where + pkg = fromMaybe (flattenPackageDescription gpkg) mpkg + +--TODO: make this variant go away +-- we should always know the GenericPackageDescription +checkConfiguredPackage :: PackageDescription -> [PackageCheck] +checkConfiguredPackage pkg = + checkSanity pkg + ++ checkFields pkg + ++ checkLicense pkg + ++ checkSourceRepos pkg + ++ checkAllGhcOptions pkg + ++ checkCCOptions pkg + ++ checkCxxOptions pkg + ++ checkCPPOptions pkg + ++ checkPaths pkg + ++ checkCabalVersion pkg + + +-- ------------------------------------------------------------ +-- * Basic sanity checks +-- ------------------------------------------------------------ + +-- | Check that this package description is sane. +-- +checkSanity :: PackageDescription -> [PackageCheck] +checkSanity pkg = + catMaybes [ + + check (null . unPackageName . packageName $ pkg) $ + PackageBuildImpossible "No 'name' field." + + , check (nullVersion == packageVersion pkg) $ + PackageBuildImpossible "No 'version' field." + + , check (all ($ pkg) [ null . executables + , null . testSuites + , null . benchmarks + , null . allLibraries + , null . foreignLibs ]) $ + PackageBuildImpossible + "No executables, libraries, tests, or benchmarks found. Nothing to do." + + , check (any (== LMainLibName) (map libName $ subLibraries pkg)) $ + PackageBuildImpossible $ "Found one or more unnamed internal libraries. " + ++ "Only the non-internal library can have the same name as the package." + + , check (not (null duplicateNames)) $ + PackageBuildImpossible $ "Duplicate sections: " + ++ commaSep (map unUnqualComponentName duplicateNames) + ++ ". The name of every library, executable, test suite," + ++ " and benchmark section in" + ++ " the package must be unique." + + -- NB: but it's OK for executables to have the same name! + -- TODO shouldn't need to compare on the string level + , check (any (== prettyShow (packageName pkg)) (prettyShow <$> subLibNames)) $ + PackageBuildImpossible $ "Illegal internal library name " + ++ prettyShow (packageName pkg) + ++ ". Internal libraries cannot have the same name as the package." + ++ " Maybe you wanted a non-internal library?" + ++ " If so, rewrite the section stanza" + ++ " from 'library: '" ++ prettyShow (packageName pkg) ++ "' to 'library'." + ] + --TODO: check for name clashes case insensitively: windows file systems cannot + --cope. + + ++ concatMap (checkLibrary pkg) (allLibraries pkg) + ++ concatMap (checkExecutable pkg) (executables pkg) + ++ concatMap (checkTestSuite pkg) (testSuites pkg) + ++ concatMap (checkBenchmark pkg) (benchmarks pkg) + + where + -- The public 'library' gets special dispensation, because it + -- is common practice to export a library and name the executable + -- the same as the package. + subLibNames = mapMaybe (libraryNameString . libName) $ subLibraries pkg + exeNames = map exeName $ executables pkg + testNames = map testName $ testSuites pkg + bmNames = map benchmarkName $ benchmarks pkg + duplicateNames = dups $ subLibNames ++ exeNames ++ testNames ++ bmNames + +checkLibrary :: PackageDescription -> Library -> [PackageCheck] +checkLibrary pkg lib = + catMaybes [ + + -- TODO: This check is bogus if a required-signature was passed through + check (null (explicitLibModules lib) && null (reexportedModules lib)) $ + PackageDistSuspiciousWarn $ + showLibraryName (libName lib) ++ " does not expose any modules" + + -- check use of signatures sections + , checkVersion CabalSpecV2_0 (not (null (signatures lib))) $ + PackageDistInexcusable $ + "To use the 'signatures' field the package needs to specify " + ++ "at least 'cabal-version: 2.0'." + + -- check that all autogen-modules appear on other-modules or exposed-modules + , check + (not $ and $ map (flip elem (explicitLibModules lib)) (libModulesAutogen lib)) $ + PackageBuildImpossible $ + "An 'autogen-module' is neither on 'exposed-modules' or " + ++ "'other-modules'." + + -- check that all autogen-includes appear on includes or install-includes + , check + (not $ and $ map (flip elem (allExplicitIncludes lib)) (view L.autogenIncludes lib)) $ + PackageBuildImpossible $ + "An include in 'autogen-includes' is neither in 'includes' or " + ++ "'install-includes'." + ] + + where + checkVersion :: CabalSpecVersion -> Bool -> PackageCheck -> Maybe PackageCheck + checkVersion ver cond pc + | specVersion pkg >= ver = Nothing + | otherwise = check cond pc + +allExplicitIncludes :: L.HasBuildInfo a => a -> [FilePath] +allExplicitIncludes x = view L.includes x ++ view L.installIncludes x + +checkExecutable :: PackageDescription -> Executable -> [PackageCheck] +checkExecutable pkg exe = + catMaybes [ + + check (null (modulePath exe)) $ + PackageBuildImpossible $ + "No 'main-is' field found for executable " ++ prettyShow (exeName exe) + -- This check does not apply to scripts. + , check (package pkg /= fakePackageId + && not (null (modulePath exe)) + && (not $ fileExtensionSupportedLanguage $ modulePath exe)) $ + PackageBuildImpossible $ + "The 'main-is' field must specify a '.hs' or '.lhs' file " + ++ "(even if it is generated by a preprocessor), " + ++ "or it may specify a C/C++/obj-C source file." + + , checkSpecVersion pkg CabalSpecV1_18 + (fileExtensionSupportedLanguage (modulePath exe) + && takeExtension (modulePath exe) `notElem` [".hs", ".lhs"]) $ + PackageDistInexcusable $ + "The package uses a C/C++/obj-C source file for the 'main-is' field. " + ++ "To use this feature you need to specify 'cabal-version: 1.18' or higher." + + -- check that all autogen-modules appear on other-modules + , check + (not $ and $ map (flip elem (exeModules exe)) (exeModulesAutogen exe)) $ + PackageBuildImpossible $ + "On executable '" ++ prettyShow (exeName exe) ++ "' an 'autogen-module' is not " + ++ "on 'other-modules'" + + -- check that all autogen-includes appear on includes + , check + (not $ and $ map (flip elem (view L.includes exe)) (view L.autogenIncludes exe)) $ + PackageBuildImpossible "An include in 'autogen-includes' is not in 'includes'." + ] + +checkTestSuite :: PackageDescription -> TestSuite -> [PackageCheck] +checkTestSuite pkg test = + catMaybes [ + + case testInterface test of + TestSuiteUnsupported tt@(TestTypeUnknown _ _) -> Just $ + PackageBuildWarning $ + quote (prettyShow tt) ++ " is not a known type of test suite. " + ++ "Either remove the 'type' field or use a known type. " + ++ "The known test suite types are: " + ++ commaSep (map prettyShow knownTestTypes) + + TestSuiteUnsupported tt -> Just $ + PackageBuildWarning $ + quote (prettyShow tt) ++ " is not a supported test suite version. " + ++ "Either remove the 'type' field or use a known type. " + ++ "The known test suite types are: " + ++ commaSep (map prettyShow knownTestTypes) + _ -> Nothing + + , check mainIsWrongExt $ + PackageBuildImpossible $ + "The 'main-is' field must specify a '.hs' or '.lhs' file " + ++ "(even if it is generated by a preprocessor), " + ++ "or it may specify a C/C++/obj-C source file." + + , checkSpecVersion pkg CabalSpecV1_18 (mainIsNotHsExt && not mainIsWrongExt) $ + PackageDistInexcusable $ + "The package uses a C/C++/obj-C source file for the 'main-is' field. " + ++ "To use this feature you need to specify 'cabal-version: 1.18' or higher." + + -- check that all autogen-modules appear on other-modules + , check + (not $ and $ map (flip elem (testModules test)) (testModulesAutogen test)) $ + PackageBuildImpossible $ + "On test suite '" ++ prettyShow (testName test) ++ "' an 'autogen-module' is not " + ++ "on 'other-modules'" + + -- check that all autogen-includes appear on includes + , check + (not $ and $ map (flip elem (view L.includes test)) (view L.autogenIncludes test)) $ + PackageBuildImpossible "An include in 'autogen-includes' is not in 'includes'." + ] + where + mainIsWrongExt = case testInterface test of + TestSuiteExeV10 _ f -> not $ fileExtensionSupportedLanguage f + _ -> False + + mainIsNotHsExt = case testInterface test of + TestSuiteExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"] + _ -> False + +checkBenchmark :: PackageDescription -> Benchmark -> [PackageCheck] +checkBenchmark _pkg bm = + catMaybes [ + + case benchmarkInterface bm of + BenchmarkUnsupported tt@(BenchmarkTypeUnknown _ _) -> Just $ + PackageBuildWarning $ + quote (prettyShow tt) ++ " is not a known type of benchmark. " + ++ "Either remove the 'type' field or use a known type. " + ++ "The known benchmark types are: " + ++ commaSep (map prettyShow knownBenchmarkTypes) + + BenchmarkUnsupported tt -> Just $ + PackageBuildWarning $ + quote (prettyShow tt) ++ " is not a supported benchmark version. " + ++ "Either remove the 'type' field or use a known type. " + ++ "The known benchmark types are: " + ++ commaSep (map prettyShow knownBenchmarkTypes) + _ -> Nothing + + , check mainIsWrongExt $ + PackageBuildImpossible $ + "The 'main-is' field must specify a '.hs' or '.lhs' file " + ++ "(even if it is generated by a preprocessor)." + + -- check that all autogen-modules appear on other-modules + , check + (not $ and $ map (flip elem (benchmarkModules bm)) (benchmarkModulesAutogen bm)) $ + PackageBuildImpossible $ + "On benchmark '" ++ prettyShow (benchmarkName bm) ++ "' an 'autogen-module' is " + ++ "not on 'other-modules'" + + -- check that all autogen-includes appear on includes + , check + (not $ and $ map (flip elem (view L.includes bm)) (view L.autogenIncludes bm)) $ + PackageBuildImpossible "An include in 'autogen-includes' is not in 'includes'." + ] + where + mainIsWrongExt = case benchmarkInterface bm of + BenchmarkExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"] + _ -> False + +-- ------------------------------------------------------------ +-- * Additional pure checks +-- ------------------------------------------------------------ + +checkFields :: PackageDescription -> [PackageCheck] +checkFields pkg = + catMaybes [ + + check (not . FilePath.Windows.isValid . prettyShow . packageName $ pkg) $ + PackageDistInexcusable $ + "The package name '" ++ prettyShow (packageName pkg) ++ "' is " + ++ "invalid on Windows. Many tools need to convert package names to " + ++ "file names so using this name would cause problems." + + , check ((isPrefixOf "z-") . prettyShow . packageName $ pkg) $ + PackageDistInexcusable $ + "Package names with the prefix 'z-' are reserved by Cabal and " + ++ "cannot be used." + + , check (isNothing (buildTypeRaw pkg) && specVersion pkg < CabalSpecV2_2) $ + PackageBuildWarning $ + "No 'build-type' specified. If you do not need a custom Setup.hs or " + ++ "./configure script then use 'build-type: Simple'." + + , check (isJust (setupBuildInfo pkg) && buildType pkg /= Custom) $ + PackageBuildWarning $ + "Ignoring the 'custom-setup' section because the 'build-type' is " + ++ "not 'Custom'. Use 'build-type: Custom' if you need to use a " + ++ "custom Setup.hs script." + + , check (not (null unknownCompilers)) $ + PackageBuildWarning $ + "Unknown compiler " ++ commaSep (map quote unknownCompilers) + ++ " in 'tested-with' field." + + , check (not (null unknownLanguages)) $ + PackageBuildWarning $ + "Unknown languages: " ++ commaSep unknownLanguages + + , check (not (null unknownExtensions)) $ + PackageBuildWarning $ + "Unknown extensions: " ++ commaSep unknownExtensions + + , check (not (null languagesUsedAsExtensions)) $ + PackageBuildWarning $ + "Languages listed as extensions: " + ++ commaSep languagesUsedAsExtensions + ++ ". Languages must be specified in either the 'default-language' " + ++ " or the 'other-languages' field." + + , check (not (null ourDeprecatedExtensions)) $ + PackageDistSuspicious $ + "Deprecated extensions: " + ++ commaSep (map (quote . prettyShow . fst) ourDeprecatedExtensions) + ++ ". " ++ unwords + [ "Instead of '" ++ prettyShow ext + ++ "' use '" ++ prettyShow replacement ++ "'." + | (ext, Just replacement) <- ourDeprecatedExtensions ] + + , check (ShortText.null (category pkg)) $ + PackageDistSuspicious "No 'category' field." + + , check (ShortText.null (maintainer pkg)) $ + PackageDistSuspicious "No 'maintainer' field." + + , check (ShortText.null (synopsis pkg) && ShortText.null (description pkg)) $ + PackageDistInexcusable "No 'synopsis' or 'description' field." + + , check (ShortText.null (description pkg) && not (ShortText.null (synopsis pkg))) $ + PackageDistSuspicious "No 'description' field." + + , check (ShortText.null (synopsis pkg) && not (ShortText.null (description pkg))) $ + PackageDistSuspicious "No 'synopsis' field." + + --TODO: recommend the bug reports URL, author and homepage fields + --TODO: recommend not using the stability field + --TODO: recommend specifying a source repo + + , check (ShortText.length (synopsis pkg) > 80) $ + PackageDistSuspicious + "The 'synopsis' field is rather long (max 80 chars is recommended)." + + -- See also https://github.com/haskell/cabal/pull/3479 + , check (not (ShortText.null (description pkg)) + && ShortText.length (description pkg) <= ShortText.length (synopsis pkg)) $ + PackageDistSuspicious $ + "The 'description' field should be longer than the 'synopsis' " + ++ "field. " + ++ "It's useful to provide an informative 'description' to allow " + ++ "Haskell programmers who have never heard about your package to " + ++ "understand the purpose of your package. " + ++ "The 'description' field content is typically shown by tooling " + ++ "(e.g. 'cabal info', Haddock, Hackage) below the 'synopsis' which " + ++ "serves as a headline. " + ++ "Please refer to for more details." + + -- check use of impossible constraints "tested-with: GHC== 6.10 && ==6.12" + , check (not (null testedWithImpossibleRanges)) $ + PackageDistInexcusable $ + "Invalid 'tested-with' version range: " + ++ commaSep (map prettyShow testedWithImpossibleRanges) + ++ ". To indicate that you have tested a package with multiple " + ++ "different versions of the same compiler use multiple entries, " + ++ "for example 'tested-with: GHC==6.10.4, GHC==6.12.3' and not " + ++ "'tested-with: GHC==6.10.4 && ==6.12.3'." + + -- for more details on why the following was commented out, + -- check https://github.com/haskell/cabal/pull/7470#issuecomment-875878507 + -- , check (not (null depInternalLibraryWithExtraVersion)) $ + -- PackageBuildWarning $ + -- "The package has an extraneous version range for a dependency on an " + -- ++ "internal library: " + -- ++ commaSep (map prettyShow depInternalLibraryWithExtraVersion) + -- ++ ". This version range includes the current package but isn't needed " + -- ++ "as the current package's library will always be used." + + , check (not (null depInternalLibraryWithImpossibleVersion)) $ + PackageBuildImpossible $ + "The package has an impossible version range for a dependency on an " + ++ "internal library: " + ++ commaSep (map prettyShow depInternalLibraryWithImpossibleVersion) + ++ ". This version range does not include the current package, and must " + ++ "be removed as the current package's library will always be used." + + -- , check (not (null depInternalExecutableWithExtraVersion)) $ + -- PackageBuildWarning $ + -- "The package has an extraneous version range for a dependency on an " + -- ++ "internal executable: " + -- ++ commaSep (map prettyShow depInternalExecutableWithExtraVersion) + -- ++ ". This version range includes the current package but isn't needed " + -- ++ "as the current package's executable will always be used." + + , check (not (null depInternalExecutableWithImpossibleVersion)) $ + PackageBuildImpossible $ + "The package has an impossible version range for a dependency on an " + ++ "internal executable: " + ++ commaSep (map prettyShow depInternalExecutableWithImpossibleVersion) + ++ ". This version range does not include the current package, and must " + ++ "be removed as the current package's executable will always be used." + + , check (not (null depMissingInternalExecutable)) $ + PackageBuildImpossible $ + "The package depends on a missing internal executable: " + ++ commaSep (map prettyShow depInternalExecutableWithImpossibleVersion) + ] + where + unknownCompilers = [ name | (OtherCompiler name, _) <- testedWith pkg ] + unknownLanguages = [ name | bi <- allBuildInfo pkg + , UnknownLanguage name <- allLanguages bi ] + unknownExtensions = [ name | bi <- allBuildInfo pkg + , UnknownExtension name <- allExtensions bi + , name `notElem` map prettyShow knownLanguages ] + ourDeprecatedExtensions = nub $ catMaybes + [ find ((==ext) . fst) deprecatedExtensions + | bi <- allBuildInfo pkg + , ext <- allExtensions bi ] + languagesUsedAsExtensions = + [ name | bi <- allBuildInfo pkg + , UnknownExtension name <- allExtensions bi + , name `elem` map prettyShow knownLanguages ] + + testedWithImpossibleRanges = + [ Dependency (mkPackageName (prettyShow compiler)) vr mainLibSet + | (compiler, vr) <- testedWith pkg + , isNoVersion vr ] + + internalLibraries = + map (maybe (packageName pkg) (unqualComponentNameToPackageName) . libraryNameString . libName) + (allLibraries pkg) + + internalExecutables = map exeName $ executables pkg + + internalLibDeps = + [ dep + | bi <- allBuildInfo pkg + , dep@(Dependency name _ _) <- targetBuildDepends bi + , name `elem` internalLibraries + ] + + internalExeDeps = + [ dep + | bi <- allBuildInfo pkg + , dep <- getAllToolDependencies pkg bi + , isInternal pkg dep + ] + + -- depInternalLibraryWithExtraVersion = + -- [ dep + -- | dep@(Dependency _ versionRange _) <- internalLibDeps + -- , not $ isAnyVersion versionRange + -- , packageVersion pkg `withinRange` versionRange + -- ] + + depInternalLibraryWithImpossibleVersion = + [ dep + | dep@(Dependency _ versionRange _) <- internalLibDeps + , not $ packageVersion pkg `withinRange` versionRange + ] + + -- depInternalExecutableWithExtraVersion = + -- [ dep + -- | dep@(ExeDependency _ _ versionRange) <- internalExeDeps + -- , not $ isAnyVersion versionRange + -- , packageVersion pkg `withinRange` versionRange + -- ] + + depInternalExecutableWithImpossibleVersion = + [ dep + | dep@(ExeDependency _ _ versionRange) <- internalExeDeps + , not $ packageVersion pkg `withinRange` versionRange + ] + + depMissingInternalExecutable = + [ dep + | dep@(ExeDependency _ eName _) <- internalExeDeps + , not $ eName `elem` internalExecutables + ] + + +checkLicense :: PackageDescription -> [PackageCheck] +checkLicense pkg = case licenseRaw pkg of + Right l -> checkOldLicense pkg l + Left l -> checkNewLicense pkg l + +checkNewLicense :: PackageDescription -> SPDX.License -> [PackageCheck] +checkNewLicense _pkg lic = catMaybes + [ check (lic == SPDX.NONE) $ + PackageDistInexcusable + "The 'license' field is missing or is NONE." + ] + +checkOldLicense :: PackageDescription -> License -> [PackageCheck] +checkOldLicense pkg lic = catMaybes + [ check (lic == UnspecifiedLicense) $ + PackageDistInexcusable + "The 'license' field is missing." + + , check (lic == AllRightsReserved) $ + PackageDistSuspicious + "The 'license' is AllRightsReserved. Is that really what you want?" + + , checkVersion CabalSpecV1_4 (lic `notElem` compatLicenses) $ + PackageDistInexcusable $ + "Unfortunately the license " ++ quote (prettyShow (license pkg)) + ++ " messes up the parser in earlier Cabal versions so you need to " + ++ "specify 'cabal-version: >= 1.4'. Alternatively if you require " + ++ "compatibility with earlier Cabal versions then use 'OtherLicense'." + + , case lic of + UnknownLicense l -> Just $ + PackageBuildWarning $ + quote ("license: " ++ l) ++ " is not a recognised license. The " + ++ "known licenses are: " + ++ commaSep (map prettyShow knownLicenses) + _ -> Nothing + + , check (lic == BSD4) $ + PackageDistSuspicious $ + "Using 'license: BSD4' is almost always a misunderstanding. 'BSD4' " + ++ "refers to the old 4-clause BSD license with the advertising " + ++ "clause. 'BSD3' refers the new 3-clause BSD license." + + , case unknownLicenseVersion (lic) of + Just knownVersions -> Just $ + PackageDistSuspicious $ + "'license: " ++ prettyShow (lic) ++ "' is not a known " + ++ "version of that license. The known versions are " + ++ commaSep (map prettyShow knownVersions) + ++ ". If this is not a mistake and you think it should be a known " + ++ "version then please file a ticket." + _ -> Nothing + + , check (lic `notElem` [ AllRightsReserved + , UnspecifiedLicense, PublicDomain] + -- AllRightsReserved and PublicDomain are not strictly + -- licenses so don't need license files. + && null (licenseFiles pkg)) $ + PackageDistSuspicious "A 'license-file' is not specified." + ] + where + unknownLicenseVersion (GPL (Just v)) + | v `notElem` knownVersions = Just knownVersions + where knownVersions = [ v' | GPL (Just v') <- knownLicenses ] + unknownLicenseVersion (LGPL (Just v)) + | v `notElem` knownVersions = Just knownVersions + where knownVersions = [ v' | LGPL (Just v') <- knownLicenses ] + unknownLicenseVersion (AGPL (Just v)) + | v `notElem` knownVersions = Just knownVersions + where knownVersions = [ v' | AGPL (Just v') <- knownLicenses ] + unknownLicenseVersion (Apache (Just v)) + | v `notElem` knownVersions = Just knownVersions + where knownVersions = [ v' | Apache (Just v') <- knownLicenses ] + unknownLicenseVersion _ = Nothing + + checkVersion :: CabalSpecVersion -> Bool -> PackageCheck -> Maybe PackageCheck + checkVersion ver cond pc + | specVersion pkg >= ver = Nothing + | otherwise = check cond pc + + compatLicenses = [ GPL Nothing, LGPL Nothing, AGPL Nothing, BSD3, BSD4 + , PublicDomain, AllRightsReserved + , UnspecifiedLicense, OtherLicense ] + +checkSourceRepos :: PackageDescription -> [PackageCheck] +checkSourceRepos pkg = + catMaybes $ concat [[ + + case repoKind repo of + RepoKindUnknown kind -> Just $ PackageDistInexcusable $ + quote kind ++ " is not a recognised kind of source-repository. " + ++ "The repo kind is usually 'head' or 'this'" + _ -> Nothing + + , check (isNothing (repoType repo)) $ + PackageDistInexcusable + "The source-repository 'type' is a required field." + + , check (isNothing (repoLocation repo)) $ + PackageDistInexcusable + "The source-repository 'location' is a required field." + + , check (repoType repo == Just (KnownRepoType CVS) && isNothing (repoModule repo)) $ + PackageDistInexcusable + "For a CVS source-repository, the 'module' is a required field." + + , check (repoKind repo == RepoThis && isNothing (repoTag repo)) $ + PackageDistInexcusable $ + "For the 'this' kind of source-repository, the 'tag' is a required " + ++ "field. It should specify the tag corresponding to this version " + ++ "or release of the package." + + , check (maybe False isAbsoluteOnAnyPlatform (repoSubdir repo)) $ + PackageDistInexcusable + "The 'subdir' field of a source-repository must be a relative path." + + , do + subdir <- repoSubdir repo + err <- isGoodRelativeDirectoryPath subdir + return $ PackageDistInexcusable $ + "The 'subdir' field of a source-repository is not a good relative path: " ++ show err + ] + | repo <- sourceRepos pkg ] + +--TODO: check location looks like a URL for some repo types. + +-- | Checks GHC options from all ghc-*-options fields in the given +-- PackageDescription and reports commonly misused or non-portable flags +checkAllGhcOptions :: PackageDescription -> [PackageCheck] +checkAllGhcOptions pkg = + checkGhcOptions "ghc-options" (hcOptions GHC) pkg + ++ checkGhcOptions "ghc-prof-options" (hcProfOptions GHC) pkg + ++ checkGhcOptions "ghc-shared-options" (hcSharedOptions GHC) pkg + +-- | Extracts GHC options belonging to the given field from the given +-- PackageDescription using given function and checks them for commonly misused +-- or non-portable flags +checkGhcOptions :: String -> (BuildInfo -> [String]) -> PackageDescription -> [PackageCheck] +checkGhcOptions fieldName getOptions pkg = + catMaybes [ + + checkFlags ["-fasm"] $ + PackageDistInexcusable $ + "'" ++ fieldName ++ ": -fasm' is unnecessary and will not work on CPU " + ++ "architectures other than x86, x86-64, ppc or sparc." + + , checkFlags ["-fvia-C"] $ + PackageDistSuspicious $ + "'" ++ fieldName ++": -fvia-C' is usually unnecessary. If your package " + ++ "needs -via-C for correctness rather than performance then it " + ++ "is using the FFI incorrectly and will probably not work with GHC " + ++ "6.10 or later." + + , checkFlags ["-fhpc"] $ + PackageDistInexcusable $ + "'" ++ fieldName ++ ": -fhpc' is not necessary. Use the configure flag " + ++ " --enable-coverage instead." + + , checkFlags ["-prof"] $ + PackageBuildWarning $ + "'" ++ fieldName ++ ": -prof' is not necessary and will lead to problems " + ++ "when used on a library. Use the configure flag " + ++ "--enable-library-profiling and/or --enable-profiling." + + , checkFlags ["-o"] $ + PackageBuildWarning $ + "'" ++ fieldName ++ ": -o' is not needed. " + ++ "The output files are named automatically." + + , checkFlags ["-hide-package"] $ + PackageBuildWarning $ + "'" ++ fieldName ++ ": -hide-package' is never needed. " + ++ "Cabal hides all packages." + + , checkFlags ["--make"] $ + PackageBuildWarning $ + "'" ++ fieldName ++ ": --make' is never needed. Cabal uses this automatically." + + , checkFlags ["-main-is"] $ + PackageDistSuspicious $ + "'" ++ fieldName ++ ": -main-is' is not portable." + + , checkNonTestAndBenchmarkFlags ["-O0", "-Onot"] $ + PackageDistSuspicious $ + "'" ++ fieldName ++ ": -O0' is not needed. " + ++ "Use the --disable-optimization configure flag." + + , checkTestAndBenchmarkFlags ["-O0", "-Onot"] $ + PackageDistSuspiciousWarn $ + "'" ++ fieldName ++ ": -O0' is not needed. " + ++ "Use the --disable-optimization configure flag." + + , checkFlags [ "-O", "-O1"] $ + PackageDistInexcusable $ + "'" ++ fieldName ++ ": -O' is not needed. " + ++ "Cabal automatically adds the '-O' flag. " + ++ "Setting it yourself interferes with the --disable-optimization flag." + + , checkFlags ["-O2"] $ + PackageDistSuspiciousWarn $ + "'" ++ fieldName ++ ": -O2' is rarely needed. " + ++ "Check that it is giving a real benefit " + ++ "and not just imposing longer compile times on your users." + + , checkFlags ["-split-sections"] $ + PackageBuildWarning $ + "'" ++ fieldName ++ ": -split-sections' is not needed. " + ++ "Use the --enable-split-sections configure flag." + + , checkFlags ["-split-objs"] $ + PackageBuildWarning $ + "'" ++ fieldName ++ ": -split-objs' is not needed. " + ++ "Use the --enable-split-objs configure flag." + + , checkFlags ["-optl-Wl,-s", "-optl-s"] $ + PackageDistInexcusable $ + "'" ++ fieldName ++ ": -optl-Wl,-s' is not needed and is not portable to all" + ++ " operating systems. Cabal 1.4 and later automatically strip" + ++ " executables. Cabal also has a flag --disable-executable-stripping" + ++ " which is necessary when building packages for some Linux" + ++ " distributions and using '-optl-Wl,-s' prevents that from working." + + , checkFlags ["-fglasgow-exts"] $ + PackageDistSuspicious $ + "Instead of '" ++ fieldName ++ ": -fglasgow-exts' it is preferable to use " + ++ "the 'extensions' field." + + , check ("-threaded" `elem` lib_ghc_options) $ + PackageBuildWarning $ + "'" ++ fieldName ++ ": -threaded' has no effect for libraries. It should " + ++ "only be used for executables." + + , check ("-rtsopts" `elem` lib_ghc_options) $ + PackageBuildWarning $ + "'" ++ fieldName ++ ": -rtsopts' has no effect for libraries. It should " + ++ "only be used for executables." + + , check (any (\opt -> "-with-rtsopts" `isPrefixOf` opt) lib_ghc_options) $ + PackageBuildWarning $ + "'" ++ fieldName ++ ": -with-rtsopts' has no effect for libraries. It " + ++ "should only be used for executables." + + , checkAlternatives fieldName "extensions" + [ (flag, prettyShow extension) | flag <- all_ghc_options + , Just extension <- [ghcExtension flag] ] + + , checkAlternatives fieldName "extensions" + [ (flag, extension) | flag@('-':'X':extension) <- all_ghc_options ] + + , checkAlternatives fieldName "cpp-options" $ + [ (flag, flag) | flag@('-':'D':_) <- all_ghc_options ] + ++ [ (flag, flag) | flag@('-':'U':_) <- all_ghc_options ] + + , checkAlternatives fieldName "include-dirs" + [ (flag, dir) | flag@('-':'I':dir) <- all_ghc_options ] + + , checkAlternatives fieldName "extra-libraries" + [ (flag, lib) | flag@('-':'l':lib) <- all_ghc_options ] + + , checkAlternatives fieldName "extra-libraries-static" + [ (flag, lib) | flag@('-':'l':lib) <- all_ghc_options ] + + , checkAlternatives fieldName "extra-lib-dirs" + [ (flag, dir) | flag@('-':'L':dir) <- all_ghc_options ] + + , checkAlternatives fieldName "extra-lib-dirs-static" + [ (flag, dir) | flag@('-':'L':dir) <- all_ghc_options ] + + , checkAlternatives fieldName "frameworks" + [ (flag, fmwk) | (flag@"-framework", fmwk) <- + zip all_ghc_options (safeTail all_ghc_options) ] + + , checkAlternatives fieldName "extra-framework-dirs" + [ (flag, dir) | (flag@"-framework-path", dir) <- + zip all_ghc_options (safeTail all_ghc_options) ] + ] + + where + all_ghc_options = concatMap getOptions (allBuildInfo pkg) + lib_ghc_options = concatMap (getOptions . libBuildInfo) + (allLibraries pkg) + test_ghc_options = concatMap (getOptions . testBuildInfo) + (testSuites pkg) + benchmark_ghc_options = concatMap (getOptions . benchmarkBuildInfo) + (benchmarks pkg) + test_and_benchmark_ghc_options = test_ghc_options ++ + benchmark_ghc_options + non_test_and_benchmark_ghc_options = concatMap getOptions + (allBuildInfo (pkg { testSuites = [] + , benchmarks = [] + })) + + checkFlags :: [String] -> PackageCheck -> Maybe PackageCheck + checkFlags flags = check (any (`elem` flags) all_ghc_options) + + checkTestAndBenchmarkFlags :: [String] -> PackageCheck -> Maybe PackageCheck + checkTestAndBenchmarkFlags flags = check (any (`elem` flags) test_and_benchmark_ghc_options) + + checkNonTestAndBenchmarkFlags :: [String] -> PackageCheck -> Maybe PackageCheck + checkNonTestAndBenchmarkFlags flags = check (any (`elem` flags) non_test_and_benchmark_ghc_options) + + ghcExtension ('-':'f':name) = case name of + "allow-overlapping-instances" -> enable OverlappingInstances + "no-allow-overlapping-instances" -> disable OverlappingInstances + "th" -> enable TemplateHaskell + "no-th" -> disable TemplateHaskell + "ffi" -> enable ForeignFunctionInterface + "no-ffi" -> disable ForeignFunctionInterface + "fi" -> enable ForeignFunctionInterface + "no-fi" -> disable ForeignFunctionInterface + "monomorphism-restriction" -> enable MonomorphismRestriction + "no-monomorphism-restriction" -> disable MonomorphismRestriction + "mono-pat-binds" -> enable MonoPatBinds + "no-mono-pat-binds" -> disable MonoPatBinds + "allow-undecidable-instances" -> enable UndecidableInstances + "no-allow-undecidable-instances" -> disable UndecidableInstances + "allow-incoherent-instances" -> enable IncoherentInstances + "no-allow-incoherent-instances" -> disable IncoherentInstances + "arrows" -> enable Arrows + "no-arrows" -> disable Arrows + "generics" -> enable Generics + "no-generics" -> disable Generics + "implicit-prelude" -> enable ImplicitPrelude + "no-implicit-prelude" -> disable ImplicitPrelude + "implicit-params" -> enable ImplicitParams + "no-implicit-params" -> disable ImplicitParams + "bang-patterns" -> enable BangPatterns + "no-bang-patterns" -> disable BangPatterns + "scoped-type-variables" -> enable ScopedTypeVariables + "no-scoped-type-variables" -> disable ScopedTypeVariables + "extended-default-rules" -> enable ExtendedDefaultRules + "no-extended-default-rules" -> disable ExtendedDefaultRules + _ -> Nothing + ghcExtension "-cpp" = enable CPP + ghcExtension _ = Nothing + + enable e = Just (EnableExtension e) + disable e = Just (DisableExtension e) + +checkCCOptions :: PackageDescription -> [PackageCheck] +checkCCOptions = checkCLikeOptions "C" "cc-options" ccOptions + +checkCxxOptions :: PackageDescription -> [PackageCheck] +checkCxxOptions = checkCLikeOptions "C++" "cxx-options" cxxOptions + +checkCLikeOptions :: String -> String -> (BuildInfo -> [String]) -> PackageDescription -> [PackageCheck] +checkCLikeOptions label prefix accessor pkg = + catMaybes [ + + checkAlternatives prefix "include-dirs" + [ (flag, dir) | flag@('-':'I':dir) <- all_cLikeOptions ] + + , checkAlternatives prefix "extra-libraries" + [ (flag, lib) | flag@('-':'l':lib) <- all_cLikeOptions ] + + , checkAlternatives prefix "extra-lib-dirs" + [ (flag, dir) | flag@('-':'L':dir) <- all_cLikeOptions ] + + , checkAlternatives "ld-options" "extra-libraries" + [ (flag, lib) | flag@('-':'l':lib) <- all_ldOptions ] + + , checkAlternatives "ld-options" "extra-lib-dirs" + [ (flag, dir) | flag@('-':'L':dir) <- all_ldOptions ] + + , checkCCFlags [ "-O", "-Os", "-O0", "-O1", "-O2", "-O3" ] $ + PackageDistSuspicious $ + "'"++prefix++": -O[n]' is generally not needed. When building with " + ++ " optimisations Cabal automatically adds '-O2' for "++label++" code. " + ++ "Setting it yourself interferes with the --disable-optimization flag." + ] + + where all_cLikeOptions = [ opts | bi <- allBuildInfo pkg + , opts <- accessor bi ] + all_ldOptions = [ opts | bi <- allBuildInfo pkg + , opts <- ldOptions bi ] + + checkCCFlags :: [String] -> PackageCheck -> Maybe PackageCheck + checkCCFlags flags = check (any (`elem` flags) all_cLikeOptions) + +checkCPPOptions :: PackageDescription -> [PackageCheck] +checkCPPOptions pkg = catMaybes + [ checkAlternatives "cpp-options" "include-dirs" + [ (flag, dir) | flag@('-':'I':dir) <- all_cppOptions ] + ] + ++ + [ PackageBuildWarning $ "'cpp-options: " ++ opt ++ "' is not a portable C-preprocessor flag." + | opt <- all_cppOptions + -- "-I" is handled above, we allow only -DNEWSTUFF and -UOLDSTUFF + , not $ any (`isPrefixOf` opt) ["-D", "-U", "-I" ] + ] + where + all_cppOptions = [ opts | bi <- allBuildInfo pkg, opts <- cppOptions bi ] + +checkAlternatives :: String -> String -> [(String, String)] + -> Maybe PackageCheck +checkAlternatives badField goodField flags = + check (not (null badFlags)) $ + PackageBuildWarning $ + "Instead of " ++ quote (badField ++ ": " ++ unwords badFlags) + ++ " use " ++ quote (goodField ++ ": " ++ unwords goodFlags) + + where (badFlags, goodFlags) = unzip flags + +data PathKind + = PathKindFile + | PathKindDirectory + | PathKindGlob + deriving (Eq) + +checkPaths :: PackageDescription -> [PackageCheck] +checkPaths pkg = + checkPackageFileNamesWithGlob + [ (kind == PathKindGlob, path) + | (path, _, kind) <- relPaths ++ absPaths + ] + ++ + [ PackageBuildWarning $ + quote (field ++ ": " ++ path) + ++ " is a relative path outside of the source tree. " + ++ "This will not work when generating a tarball with 'sdist'." + | (path, field, _) <- relPaths ++ absPaths + , isOutsideTree path ] + ++ + [ PackageDistInexcusable $ + quote (field ++ ": " ++ path) ++ " specifies an absolute path, but the " + ++ quote field ++ " field must use relative paths." + | (path, field, _) <- relPaths + , isAbsoluteOnAnyPlatform path ] + ++ + [ PackageDistInexcusable $ + quote (field ++ ": " ++ path) ++ " is not a good relative path: " ++ show err + | (path, field, kind) <- relPaths + -- these are not paths, but globs... + , err <- maybeToList $ case kind of + PathKindFile -> isGoodRelativeFilePath path + PathKindGlob -> isGoodRelativeGlob path + PathKindDirectory -> isGoodRelativeDirectoryPath path + ] + ++ + [ PackageDistInexcusable $ + quote (field ++ ": " ++ path) ++ " points inside the 'dist' " + ++ "directory. This is not reliable because the location of this " + ++ "directory is configurable by the user (or package manager). In " + ++ "addition the layout of the 'dist' directory is subject to change " + ++ "in future versions of Cabal." + | (path, field, _) <- relPaths ++ absPaths + , isInsideDist path ] + ++ + [ PackageDistInexcusable $ + "The 'ghc-options' contain the path '" ++ path ++ "' which points " + ++ "inside the 'dist' directory. This is not reliable because the " + ++ "location of this directory is configurable by the user (or package " + ++ "manager). In addition the layout of the 'dist' directory is subject " + ++ "to change in future versions of Cabal." + | bi <- allBuildInfo pkg + , (GHC, flags) <- perCompilerFlavorToList $ options bi + , path <- flags + , isInsideDist path ] + ++ + [ PackageDistInexcusable $ + "In the 'data-files' field: " ++ explainGlobSyntaxError pat err + | pat <- dataFiles pkg + , Left err <- [parseFileGlob (specVersion pkg) pat] + ] + ++ + [ PackageDistInexcusable $ + "In the 'extra-source-files' field: " ++ explainGlobSyntaxError pat err + | pat <- extraSrcFiles pkg + , Left err <- [parseFileGlob (specVersion pkg) pat] + ] + ++ + [ PackageDistInexcusable $ + "In the 'extra-doc-files' field: " ++ explainGlobSyntaxError pat err + | pat <- extraDocFiles pkg + , Left err <- [parseFileGlob (specVersion pkg) pat] + ] + where + isOutsideTree path = case splitDirectories path of + "..":_ -> True + ".":"..":_ -> True + _ -> False + isInsideDist path = case map lowercase (splitDirectories path) of + "dist" :_ -> True + ".":"dist":_ -> True + _ -> False + + -- paths that must be relative + relPaths :: [(FilePath, String, PathKind)] + relPaths = + [ (path, "extra-source-files", PathKindGlob) | path <- extraSrcFiles pkg ] ++ + [ (path, "extra-tmp-files", PathKindFile) | path <- extraTmpFiles pkg ] ++ + [ (path, "extra-doc-files", PathKindGlob) | path <- extraDocFiles pkg ] ++ + [ (path, "data-files", PathKindGlob) | path <- dataFiles pkg ] ++ + [ (path, "data-dir", PathKindDirectory) | path <- [dataDir pkg]] ++ + [ (path, "license-file", PathKindFile) | path <- map getSymbolicPath $ licenseFiles pkg ] ++ + concat + [ [ (path, "asm-sources", PathKindFile) | path <- asmSources bi ] ++ + [ (path, "cmm-sources", PathKindFile) | path <- cmmSources bi ] ++ + [ (path, "c-sources", PathKindFile) | path <- cSources bi ] ++ + [ (path, "cxx-sources", PathKindFile) | path <- cxxSources bi ] ++ + [ (path, "js-sources", PathKindFile) | path <- jsSources bi ] ++ + [ (path, "install-includes", PathKindFile) | path <- installIncludes bi ] ++ + [ (path, "hs-source-dirs", PathKindDirectory) | path <- map getSymbolicPath $ hsSourceDirs bi ] + | bi <- allBuildInfo pkg + ] + + -- paths that are allowed to be absolute + absPaths :: [(FilePath, String, PathKind)] + absPaths = concat + [ [ (path, "includes", PathKindFile) | path <- includes bi ] ++ + [ (path, "include-dirs", PathKindDirectory) | path <- includeDirs bi ] ++ + [ (path, "extra-lib-dirs", PathKindDirectory) | path <- extraLibDirs bi ] ++ + [ (path, "extra-lib-dirs-static", PathKindDirectory) | path <- extraLibDirsStatic bi ] + | bi <- allBuildInfo pkg + ] + +--TODO: check sets of paths that would be interpreted differently between Unix +-- and windows, ie case-sensitive or insensitive. Things that might clash, or +-- conversely be distinguished. + +--TODO: use the tar path checks on all the above paths + +-- | Check that the package declares the version in the @\"cabal-version\"@ +-- field correctly. +-- +checkCabalVersion :: PackageDescription -> [PackageCheck] +checkCabalVersion pkg = + catMaybes [ + + -- check use of test suite sections + checkVersion CabalSpecV1_8 (not (null $ testSuites pkg)) $ + PackageDistInexcusable $ + "The 'test-suite' section is new in Cabal 1.10. " + ++ "Unfortunately it messes up the parser in older Cabal versions " + ++ "so you must specify at least 'cabal-version: >= 1.8', but note " + ++ "that only Cabal 1.10 and later can actually run such test suites." + + -- check use of default-language field + -- note that we do not need to do an equivalent check for the + -- other-language field since that one does not change behaviour + , checkVersion CabalSpecV1_10 (any isJust (buildInfoField defaultLanguage)) $ + PackageBuildWarning $ + "To use the 'default-language' field the package needs to specify " + ++ "at least 'cabal-version: >= 1.10'." + + , check (specVersion pkg >= CabalSpecV1_10 && specVersion pkg < CabalSpecV3_4 + && (any isNothing (buildInfoField defaultLanguage))) $ + PackageBuildWarning $ + "Packages using 'cabal-version: >= 1.10' and before 'cabal-version: 3.4' must specify the " + ++ "'default-language' field for each component (e.g. Haskell98 or " + ++ "Haskell2010). If a component uses different languages in " + ++ "different modules then list the other ones in the " + ++ "'other-languages' field." + + , checkVersion CabalSpecV1_18 + (not . null $ extraDocFiles pkg) $ + PackageDistInexcusable $ + "To use the 'extra-doc-files' field the package needs to specify " + ++ "'cabal-version: 1.18' or higher." + + , checkVersion CabalSpecV2_0 + (not (null (subLibraries pkg))) $ + PackageDistInexcusable $ + "To use multiple 'library' sections or a named library section " + ++ "the package needs to specify at least 'cabal-version: 2.0'." + + -- check use of reexported-modules sections + , checkVersion CabalSpecV1_22 + (any (not.null.reexportedModules) (allLibraries pkg)) $ + PackageDistInexcusable $ + "To use the 'reexported-module' field the package needs to specify " + ++ "'cabal-version: 1.22' or higher." + + -- check use of thinning and renaming + , checkVersion CabalSpecV2_0 usesBackpackIncludes $ + PackageDistInexcusable $ + "To use the 'mixins' field the package needs to specify " + ++ "at least 'cabal-version: 2.0'." + + -- check use of 'extra-framework-dirs' field + , checkVersion CabalSpecV1_24 (any (not . null) (buildInfoField extraFrameworkDirs)) $ + -- Just a warning, because this won't break on old Cabal versions. + PackageDistSuspiciousWarn $ + "To use the 'extra-framework-dirs' field the package needs to specify" + ++ " 'cabal-version: 1.24' or higher." + + -- check use of default-extensions field + -- don't need to do the equivalent check for other-extensions + , checkVersion CabalSpecV1_10 (any (not . null) (buildInfoField defaultExtensions)) $ + PackageBuildWarning $ + "To use the 'default-extensions' field the package needs to specify " + ++ "at least 'cabal-version: >= 1.10'." + + -- check use of extensions field + , check (specVersion pkg >= CabalSpecV1_10 + && (any (not . null) (buildInfoField oldExtensions))) $ + PackageBuildWarning $ + "For packages using 'cabal-version: >= 1.10' the 'extensions' " + ++ "field is deprecated. The new 'default-extensions' field lists " + ++ "extensions that are used in all modules in the component, while " + ++ "the 'other-extensions' field lists extensions that are used in " + ++ "some modules, e.g. via the {-# LANGUAGE #-} pragma." + + , checkVersion CabalSpecV3_0 (any (not . null) + (concatMap buildInfoField + [ asmSources + , cmmSources + , extraBundledLibs + , extraLibFlavours ])) $ + PackageDistInexcusable $ + "The use of 'asm-sources', 'cmm-sources', 'extra-bundled-libraries' " + ++ " and 'extra-library-flavours' requires the package " + ++ " to specify at least 'cabal-version: 3.0'." + + , checkVersion CabalSpecV3_0 (any (not . null) $ buildInfoField extraDynLibFlavours) $ + PackageDistInexcusable $ + "The use of 'extra-dynamic-library-flavours' requires the package " + ++ " to specify at least 'cabal-version: 3.0'. The flavours are: " + ++ commaSep [ flav + | flavs <- buildInfoField extraDynLibFlavours + , flav <- flavs ] + + , checkVersion CabalSpecV2_2 (any (not . null) + (buildInfoField virtualModules)) $ + PackageDistInexcusable $ + "The use of 'virtual-modules' requires the package " + ++ " to specify at least 'cabal-version: 2.2'." + + -- check use of "source-repository" section + , checkVersion CabalSpecV1_6 (not (null (sourceRepos pkg))) $ + PackageDistInexcusable $ + "The 'source-repository' section is new in Cabal 1.6. " + ++ "Unfortunately it messes up the parser in earlier Cabal versions " + ++ "so you need to specify 'cabal-version: >= 1.6'." + + -- check for new language extensions + , checkVersion CabalSpecV1_2 (not (null mentionedExtensionsThatNeedCabal12)) $ + PackageDistInexcusable $ + "Unfortunately the language extensions " + ++ commaSep (map (quote . prettyShow) mentionedExtensionsThatNeedCabal12) + ++ " break the parser in earlier Cabal versions so you need to " + ++ "specify 'cabal-version: >= 1.2'. Alternatively if you require " + ++ "compatibility with earlier Cabal versions then you may be able to " + ++ "use an equivalent compiler-specific flag." + + , checkVersion CabalSpecV1_4 (not (null mentionedExtensionsThatNeedCabal14)) $ + PackageDistInexcusable $ + "Unfortunately the language extensions " + ++ commaSep (map (quote . prettyShow) mentionedExtensionsThatNeedCabal14) + ++ " break the parser in earlier Cabal versions so you need to " + ++ "specify 'cabal-version: >= 1.4'. Alternatively if you require " + ++ "compatibility with earlier Cabal versions then you may be able to " + ++ "use an equivalent compiler-specific flag." + + , check (specVersion pkg >= CabalSpecV1_24 + && isNothing (setupBuildInfo pkg) + && buildType pkg == Custom) $ + PackageBuildWarning $ + "Packages using 'cabal-version: 1.24' or higher with 'build-type: Custom' " + ++ "must use a 'custom-setup' section with a 'setup-depends' field " + ++ "that specifies the dependencies of the Setup.hs script itself. " + ++ "The 'setup-depends' field uses the same syntax as 'build-depends', " + ++ "so a simple example would be 'setup-depends: base, Cabal'." + + , check (specVersion pkg < CabalSpecV1_24 + && isNothing (setupBuildInfo pkg) + && buildType pkg == Custom) $ + PackageDistSuspiciousWarn $ + "From version 1.24 cabal supports specifying explicit dependencies " + ++ "for Custom setup scripts. Consider using 'cabal-version: 1.24' or higher " + ++ "and adding a 'custom-setup' section with a 'setup-depends' field " + ++ "that specifies the dependencies of the Setup.hs script itself. " + ++ "The 'setup-depends' field uses the same syntax as 'build-depends', " + ++ "so a simple example would be 'setup-depends: base, Cabal'." + + , check (specVersion pkg >= CabalSpecV2_0 + && elem (autogenPathsModuleName pkg) allModuleNames + && not (elem (autogenPathsModuleName pkg) allModuleNamesAutogen) ) $ + PackageDistInexcusable $ + "Packages using 'cabal-version: 2.0' and the autogenerated " + ++ "module Paths_* must include it also on the 'autogen-modules' field " + ++ "besides 'exposed-modules' and 'other-modules'. This specifies that " + ++ "the module does not come with the package and is generated on " + ++ "setup. Modules built with a custom Setup.hs script also go here " + ++ "to ensure that commands like sdist don't fail." + + ] + where + -- Perform a check on packages that use a version of the spec less than + -- the version given. This is for cases where a new Cabal version adds + -- a new feature and we want to check that it is not used prior to that + -- version. + checkVersion :: CabalSpecVersion -> Bool -> PackageCheck -> Maybe PackageCheck + checkVersion ver cond pc + | specVersion pkg >= ver = Nothing + | otherwise = check cond pc + + buildInfoField field = map field (allBuildInfo pkg) + + usesBackpackIncludes = any (not . null . mixins) (allBuildInfo pkg) + + mentionedExtensions = [ ext | bi <- allBuildInfo pkg + , ext <- allExtensions bi ] + mentionedExtensionsThatNeedCabal12 = + nub (filter (`elem` compatExtensionsExtra) mentionedExtensions) + + -- As of Cabal-1.4 we can add new extensions without worrying about + -- breaking old versions of cabal. + mentionedExtensionsThatNeedCabal14 = + nub (filter (`notElem` compatExtensions) mentionedExtensions) + + -- The known extensions in Cabal-1.2.3 + compatExtensions = + map EnableExtension + [ OverlappingInstances, UndecidableInstances, IncoherentInstances + , RecursiveDo, ParallelListComp, MultiParamTypeClasses + , FunctionalDependencies, Rank2Types + , RankNTypes, PolymorphicComponents, ExistentialQuantification + , ScopedTypeVariables, ImplicitParams, FlexibleContexts + , FlexibleInstances, EmptyDataDecls, CPP, BangPatterns + , TypeSynonymInstances, TemplateHaskell, ForeignFunctionInterface + , Arrows, Generics, NamedFieldPuns, PatternGuards + , GeneralizedNewtypeDeriving, ExtensibleRecords, RestrictedTypeSynonyms + , HereDocuments] ++ + map DisableExtension + [MonomorphismRestriction, ImplicitPrelude] ++ + compatExtensionsExtra + + -- The extra known extensions in Cabal-1.2.3 vs Cabal-1.1.6 + -- (Cabal-1.1.6 came with ghc-6.6. Cabal-1.2 came with ghc-6.8) + compatExtensionsExtra = + map EnableExtension + [ KindSignatures, MagicHash, TypeFamilies, StandaloneDeriving + , UnicodeSyntax, PatternSignatures, UnliftedFFITypes, LiberalTypeSynonyms + , TypeOperators, RecordWildCards, RecordPuns, DisambiguateRecordFields + , OverloadedStrings, GADTs, RelaxedPolyRec + , ExtendedDefaultRules, UnboxedTuples, DeriveDataTypeable + , ConstrainedClassMethods + ] ++ + map DisableExtension + [MonoPatBinds] + + allModuleNames = + (case library pkg of + Nothing -> [] + (Just lib) -> explicitLibModules lib + ) + ++ concatMap otherModules (allBuildInfo pkg) + + allModuleNamesAutogen = concatMap autogenModules (allBuildInfo pkg) + +-- ------------------------------------------------------------ +-- * Checks on the GenericPackageDescription +-- ------------------------------------------------------------ + +-- | Check the build-depends fields for any weirdness or bad practice. +-- +checkPackageVersions :: GenericPackageDescription -> [PackageCheck] +checkPackageVersions pkg = + catMaybes [ + + -- Check that the version of base is bounded above. + -- For example this bans "build-depends: base >= 3". + -- It should probably be "build-depends: base >= 3 && < 4" + -- which is the same as "build-depends: base == 3.*" + check (not (hasUpperBound baseDependency)) $ + PackageDistInexcusable $ + "The dependency 'build-depends: base' does not specify an upper " + ++ "bound on the version number. Each major release of the 'base' " + ++ "package changes the API in various ways and most packages will " + ++ "need some changes to compile with it. The recommended practice " + ++ "is to specify an upper bound on the version of the 'base' " + ++ "package. This ensures your package will continue to build when a " + ++ "new major version of the 'base' package is released. If you are " + ++ "not sure what upper bound to use then use the next major " + ++ "version. For example if you have tested your package with 'base' " + ++ "version 4.5 and 4.6 then use 'build-depends: base >= 4.5 && < 4.7'." + + ] + where + baseDependency = case typicalPkg pkg of + Right (pkg', _) | not (null baseDeps) -> + foldr intersectVersionRanges anyVersion baseDeps + where + baseDeps = + [ vr | Dependency pname vr _ <- allBuildDepends pkg' + , pname == mkPackageName "base" ] + + -- Just in case finalizePD fails for any reason, + -- or if the package doesn't depend on the base package at all, + -- then we will just skip the check, since hasUpperBound noVersion = True + _ -> noVersion + +checkConditionals :: GenericPackageDescription -> [PackageCheck] +checkConditionals pkg = + catMaybes [ + + check (not $ null unknownOSs) $ + PackageDistInexcusable $ + "Unknown operating system name " + ++ commaSep (map quote unknownOSs) + + , check (not $ null unknownArches) $ + PackageDistInexcusable $ + "Unknown architecture name " + ++ commaSep (map quote unknownArches) + + , check (not $ null unknownImpls) $ + PackageDistInexcusable $ + "Unknown compiler name " + ++ commaSep (map quote unknownImpls) + ] + where + unknownOSs = [ os | OS (OtherOS os) <- conditions ] + unknownArches = [ arch | Arch (OtherArch arch) <- conditions ] + unknownImpls = [ impl | Impl (OtherCompiler impl) _ <- conditions ] + conditions = concatMap fvs (maybeToList (condLibrary pkg)) + ++ concatMap (fvs . snd) (condSubLibraries pkg) + ++ concatMap (fvs . snd) (condForeignLibs pkg) + ++ concatMap (fvs . snd) (condExecutables pkg) + ++ concatMap (fvs . snd) (condTestSuites pkg) + ++ concatMap (fvs . snd) (condBenchmarks pkg) + fvs (CondNode _ _ ifs) = concatMap compfv ifs -- free variables + compfv (CondBranch c ct mct) = condfv c ++ fvs ct ++ maybe [] fvs mct + condfv c = case c of + Var v -> [v] + Lit _ -> [] + CNot c1 -> condfv c1 + COr c1 c2 -> condfv c1 ++ condfv c2 + CAnd c1 c2 -> condfv c1 ++ condfv c2 + +checkFlagNames :: GenericPackageDescription -> [PackageCheck] +checkFlagNames gpd + | null invalidFlagNames = [] + | otherwise = [ PackageDistInexcusable + $ "Suspicious flag names: " ++ unwords invalidFlagNames ++ ". " + ++ "To avoid ambiguity in command line interfaces, flag shouldn't " + ++ "start with a dash. Also for better compatibility, flag names " + ++ "shouldn't contain non-ascii characters." + ] + where + invalidFlagNames = + [ fn + | flag <- genPackageFlags gpd + , let fn = unFlagName (flagName flag) + , invalidFlagName fn + ] + -- starts with dash + invalidFlagName ('-':_) = True + -- mon ascii letter + invalidFlagName cs = any (not . isAscii) cs + +checkUnusedFlags :: GenericPackageDescription -> [PackageCheck] +checkUnusedFlags gpd + | declared == used = [] + | otherwise = [ PackageDistSuspicious + $ "Declared and used flag sets differ: " + ++ s declared ++ " /= " ++ s used ++ ". " + ] + where + s :: Set.Set FlagName -> String + s = commaSep . map unFlagName . Set.toList + + declared :: Set.Set FlagName + declared = toSetOf (L.genPackageFlags . traverse . L.flagName) gpd + + used :: Set.Set FlagName + used = mconcat + [ toSetOf (L.condLibrary . traverse . traverseCondTreeV . L._PackageFlag) gpd + , toSetOf (L.condSubLibraries . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd + , toSetOf (L.condForeignLibs . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd + , toSetOf (L.condExecutables . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd + , toSetOf (L.condTestSuites . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd + , toSetOf (L.condBenchmarks . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd + ] + +checkUnicodeXFields :: GenericPackageDescription -> [PackageCheck] +checkUnicodeXFields gpd + | null nonAsciiXFields = [] + | otherwise = [ PackageDistInexcusable + $ "Non ascii custom fields: " ++ unwords nonAsciiXFields ++ ". " + ++ "For better compatibility, custom field names " + ++ "shouldn't contain non-ascii characters." + ] + where + nonAsciiXFields :: [String] + nonAsciiXFields = [ n | (n, _) <- xfields, any (not . isAscii) n ] + + xfields :: [(String,String)] + xfields = DList.runDList $ mconcat + [ toDListOf (L.packageDescription . L.customFieldsPD . traverse) gpd + , toDListOf (L.traverseBuildInfos . L.customFieldsBI . traverse) gpd + ] + +-- | cabal-version <2.2 + Paths_module + default-extensions: doesn't build. +checkPathsModuleExtensions :: PackageDescription -> [PackageCheck] +checkPathsModuleExtensions pd + | specVersion pd >= CabalSpecV2_2 = [] + | any checkBI (allBuildInfo pd) || any checkLib (allLibraries pd) + = return $ PackageBuildImpossible $ unwords + [ "Packages using RebindableSyntax with OverloadedStrings or" + , "OverloadedLists in default-extensions, in conjunction with the" + , "autogenerated module Paths_*, are known to cause compile failures" + , "with Cabal < 2.2. To use these default-extensions with a Paths_*" + , "autogen module, specify at least 'cabal-version: 2.2'." + ] + | otherwise = [] + where + mn = autogenPathsModuleName pd + + checkLib :: Library -> Bool + checkLib l = mn `elem` exposedModules l && checkExts (l ^. L.defaultExtensions) + + checkBI :: BuildInfo -> Bool + checkBI bi = + (mn `elem` otherModules bi || mn `elem` autogenModules bi) && + checkExts (bi ^. L.defaultExtensions) + + checkExts exts = rebind `elem` exts && (strings `elem` exts || lists `elem` exts) + where + rebind = EnableExtension RebindableSyntax + strings = EnableExtension OverloadedStrings + lists = EnableExtension OverloadedLists + +-- | Checks GHC options from all ghc-*-options fields from the given BuildInfo +-- and reports flags that are OK during development process, but are +-- unacceptable in a distributed package +checkDevelopmentOnlyFlagsBuildInfo :: BuildInfo -> [PackageCheck] +checkDevelopmentOnlyFlagsBuildInfo bi = + checkDevelopmentOnlyFlagsOptions "ghc-options" (hcOptions GHC bi) + ++ checkDevelopmentOnlyFlagsOptions "ghc-prof-options" (hcProfOptions GHC bi) + ++ checkDevelopmentOnlyFlagsOptions "ghc-shared-options" (hcSharedOptions GHC bi) + +-- | Checks the given list of flags belonging to the given field and reports +-- flags that are OK during development process, but are unacceptable in a +-- distributed package +checkDevelopmentOnlyFlagsOptions :: String -> [String] -> [PackageCheck] +checkDevelopmentOnlyFlagsOptions fieldName ghcOptions = + catMaybes [ + + check has_WerrorWall $ + PackageDistInexcusable $ + "'" ++ fieldName ++ ": -Wall -Werror' makes the package very easy to " + ++ "break with future GHC versions because new GHC versions often " + ++ "add new warnings. Use just '" ++ fieldName ++ ": -Wall' instead." + ++ extraExplanation + + , check (not has_WerrorWall && has_Werror) $ + PackageDistInexcusable $ + "'" ++ fieldName ++ ": -Werror' makes the package easy to " + ++ "break with future GHC versions because new GHC versions often " + ++ "add new warnings." + ++ extraExplanation + + , check (has_J) $ + PackageDistInexcusable $ + "'" ++ fieldName ++ ": -j[N]' can make sense for specific user's setup," + ++ " but it is not appropriate for a distributed package." + ++ extraExplanation + + , checkFlags ["-fdefer-type-errors"] $ + PackageDistInexcusable $ + "'" ++ fieldName ++ ": -fdefer-type-errors' is fine during development but " + ++ "is not appropriate for a distributed package." + ++ extraExplanation + + -- -dynamic is not a debug flag + , check (any (\opt -> "-d" `isPrefixOf` opt && opt /= "-dynamic") + ghcOptions) $ + PackageDistInexcusable $ + "'" ++ fieldName ++ ": -d*' debug flags are not appropriate " + ++ "for a distributed package." + ++ extraExplanation + + , checkFlags ["-fprof-auto", "-fprof-auto-top", "-fprof-auto-calls", + "-fprof-cafs", "-fno-prof-count-entries", + "-auto-all", "-auto", "-caf-all"] $ + PackageDistSuspicious $ + "'" ++ fieldName ++ ": -fprof*' profiling flags are typically not " + ++ "appropriate for a distributed library package. These flags are " + ++ "useful to profile this package, but when profiling other packages " + ++ "that use this one these flags clutter the profile output with " + ++ "excessive detail. If you think other packages really want to see " + ++ "cost centres from this package then use '-fprof-auto-exported' " + ++ "which puts cost centres only on exported functions." + ++ extraExplanation + ] + where + extraExplanation = + " Alternatively, if you want to use this, make it conditional based " + ++ "on a Cabal configuration flag (with 'manual: True' and 'default: " + ++ "False') and enable that flag during development." + + has_WerrorWall = has_Werror && ( has_Wall || has_W ) + has_Werror = "-Werror" `elem` ghcOptions + has_Wall = "-Wall" `elem` ghcOptions + has_W = "-W" `elem` ghcOptions + has_J = any + (\o -> case o of + "-j" -> True + ('-' : 'j' : d : _) -> isDigit d + _ -> False + ) + ghcOptions + checkFlags :: [String] -> PackageCheck -> Maybe PackageCheck + checkFlags flags = check (any (`elem` flags) ghcOptions) + +checkDevelopmentOnlyFlags :: GenericPackageDescription -> [PackageCheck] +checkDevelopmentOnlyFlags pkg = + concatMap checkDevelopmentOnlyFlagsBuildInfo + [ bi + | (conditions, bi) <- allConditionalBuildInfo + , not (any guardedByManualFlag conditions) ] + where + guardedByManualFlag = definitelyFalse + + -- We've basically got three-values logic here: True, False or unknown + -- hence this pattern to propagate the unknown cases properly. + definitelyFalse (Var (PackageFlag n)) = maybe False not (Map.lookup n manualFlags) + definitelyFalse (Var _) = False + definitelyFalse (Lit b) = not b + definitelyFalse (CNot c) = definitelyTrue c + definitelyFalse (COr c1 c2) = definitelyFalse c1 && definitelyFalse c2 + definitelyFalse (CAnd c1 c2) = definitelyFalse c1 || definitelyFalse c2 + + definitelyTrue (Var (PackageFlag n)) = fromMaybe False (Map.lookup n manualFlags) + definitelyTrue (Var _) = False + definitelyTrue (Lit b) = b + definitelyTrue (CNot c) = definitelyFalse c + definitelyTrue (COr c1 c2) = definitelyTrue c1 || definitelyTrue c2 + definitelyTrue (CAnd c1 c2) = definitelyTrue c1 && definitelyTrue c2 + + manualFlags = Map.fromList + [ (flagName flag, flagDefault flag) + | flag <- genPackageFlags pkg + , flagManual flag ] + + allConditionalBuildInfo :: [([Condition ConfVar], BuildInfo)] + allConditionalBuildInfo = + concatMap (collectCondTreePaths libBuildInfo) + (maybeToList (condLibrary pkg)) + + ++ concatMap (collectCondTreePaths libBuildInfo . snd) + (condSubLibraries pkg) + + ++ concatMap (collectCondTreePaths buildInfo . snd) + (condExecutables pkg) + + ++ concatMap (collectCondTreePaths testBuildInfo . snd) + (condTestSuites pkg) + + ++ concatMap (collectCondTreePaths benchmarkBuildInfo . snd) + (condBenchmarks pkg) + + -- get all the leaf BuildInfo, paired up with the path (in the tree sense) + -- of if-conditions that guard it + collectCondTreePaths :: (a -> b) + -> CondTree v c a + -> [([Condition v], b)] + collectCondTreePaths mapData = go [] + where + go conditions condNode = + -- the data at this level in the tree: + (reverse conditions, mapData (condTreeData condNode)) + + : concat + [ go (condition:conditions) ifThen + | (CondBranch condition ifThen _) <- condTreeComponents condNode ] + + ++ concat + [ go (condition:conditions) elseThen + | (CondBranch condition _ (Just elseThen)) <- condTreeComponents condNode ] + + +-- ------------------------------------------------------------ +-- * Checks involving files in the package +-- ------------------------------------------------------------ + +-- | Sanity check things that requires IO. It looks at the files in the +-- package and expects to find the package unpacked in at the given file path. +-- +checkPackageFiles :: Verbosity -> PackageDescription -> FilePath -> IO [PackageCheck] +checkPackageFiles verbosity pkg root = do + contentChecks <- checkPackageContent checkFilesIO pkg + preDistributionChecks <- checkPackageFilesPreDistribution verbosity pkg root + -- Sort because different platforms will provide files from + -- `getDirectoryContents` in different orders, and we'd like to be + -- stable for test output. + return (sort contentChecks ++ sort preDistributionChecks) + where + checkFilesIO = CheckPackageContentOps { + doesFileExist = System.doesFileExist . relative, + doesDirectoryExist = System.doesDirectoryExist . relative, + getDirectoryContents = System.Directory.getDirectoryContents . relative, + getFileContents = BS.readFile . relative + } + relative path = root path + +-- | A record of operations needed to check the contents of packages. +-- Used by 'checkPackageContent'. +-- +data CheckPackageContentOps m = CheckPackageContentOps { + doesFileExist :: FilePath -> m Bool, + doesDirectoryExist :: FilePath -> m Bool, + getDirectoryContents :: FilePath -> m [FilePath], + getFileContents :: FilePath -> m BS.ByteString + } + +-- | Sanity check things that requires looking at files in the package. +-- This is a generalised version of 'checkPackageFiles' that can work in any +-- monad for which you can provide 'CheckPackageContentOps' operations. +-- +-- The point of this extra generality is to allow doing checks in some virtual +-- file system, for example a tarball in memory. +-- +checkPackageContent :: (Monad m, Applicative m) + => CheckPackageContentOps m + -> PackageDescription + -> m [PackageCheck] +checkPackageContent ops pkg = do + cabalBomError <- checkCabalFileBOM ops + cabalNameError <- checkCabalFileName ops pkg + licenseErrors <- checkLicensesExist ops pkg + setupError <- checkSetupExists ops pkg + configureError <- checkConfigureExists ops pkg + localPathErrors <- checkLocalPathsExist ops pkg + vcsLocation <- checkMissingVcsInfo ops pkg + + return $ licenseErrors + ++ catMaybes [cabalBomError, cabalNameError, setupError, configureError] + ++ localPathErrors + ++ vcsLocation + +checkCabalFileBOM :: Monad m => CheckPackageContentOps m + -> m (Maybe PackageCheck) +checkCabalFileBOM ops = do + epdfile <- findPackageDesc ops + case epdfile of + -- MASSIVE HACK. If the Cabal file doesn't exist, that is + -- a very strange situation to be in, because the driver code + -- in 'Distribution.Setup' ought to have noticed already! + -- But this can be an issue, see #3552 and also when + -- --cabal-file is specified. So if you can't find the file, + -- just don't bother with this check. + Left _ -> return $ Nothing + Right pdfile -> (flip check pc . BS.isPrefixOf bomUtf8) + `liftM` (getFileContents ops pdfile) + where pc = PackageDistInexcusable $ + pdfile ++ " starts with an Unicode byte order mark (BOM)." + ++ " This may cause problems with older cabal versions." + + where + bomUtf8 :: BS.ByteString + bomUtf8 = BS.pack [0xef,0xbb,0xbf] -- U+FEFF encoded as UTF8 + +checkCabalFileName :: Monad m => CheckPackageContentOps m + -> PackageDescription + -> m (Maybe PackageCheck) +checkCabalFileName ops pkg = do + -- findPackageDesc already takes care to detect missing/multiple + -- .cabal files; we don't include this check in 'findPackageDesc' in + -- order not to short-cut other checks which call 'findPackageDesc' + epdfile <- findPackageDesc ops + case epdfile of + -- see "MASSIVE HACK" note in 'checkCabalFileBOM' + Left _ -> return Nothing + Right pdfile + | takeFileName pdfile == expectedCabalname -> return Nothing + | otherwise -> return $ Just $ PackageDistInexcusable $ + "The filename " ++ quote pdfile ++ " does not match package name " ++ + "(expected: " ++ quote expectedCabalname ++ ")" + where + pkgname = unPackageName . packageName $ pkg + expectedCabalname = pkgname <.> "cabal" + + +-- |Find a package description file in the given directory. Looks for +-- @.cabal@ files. Like 'Distribution.Simple.Utils.findPackageDesc', +-- but generalized over monads. +findPackageDesc :: Monad m => CheckPackageContentOps m + -> m (Either PackageCheck FilePath) -- ^.cabal +findPackageDesc ops + = do let dir = "." + files <- getDirectoryContents ops dir + -- to make sure we do not mistake a ~/.cabal/ dir for a .cabal + -- file we filter to exclude dirs and null base file names: + cabalFiles <- filterM (doesFileExist ops) + [ dir file + | file <- files + , let (name, ext) = splitExtension file + , not (null name) && ext == ".cabal" ] + case cabalFiles of + [] -> return (Left $ PackageBuildImpossible noDesc) + [cabalFile] -> return (Right cabalFile) + multiple -> return (Left $ PackageBuildImpossible + $ multiDesc multiple) + + where + noDesc :: String + noDesc = "No cabal file found.\n" + ++ "Please create a package description file .cabal" + + multiDesc :: [String] -> String + multiDesc l = "Multiple cabal files found while checking.\n" + ++ "Please use only one of: " + ++ intercalate ", " l + +checkLicensesExist :: (Monad m, Applicative m) + => CheckPackageContentOps m + -> PackageDescription + -> m [PackageCheck] +checkLicensesExist ops pkg = do + exists <- traverse (doesFileExist ops . getSymbolicPath) (licenseFiles pkg) + return + [ PackageBuildWarning $ + "The '" ++ fieldname ++ "' field refers to the file " + ++ quote (getSymbolicPath file) ++ " which does not exist." + | (file, False) <- zip (licenseFiles pkg) exists ] + where + fieldname | length (licenseFiles pkg) == 1 = "license-file" + | otherwise = "license-files" + +checkSetupExists :: Monad m => CheckPackageContentOps m + -> PackageDescription + -> m (Maybe PackageCheck) +checkSetupExists ops pkg = do + let simpleBuild = buildType pkg == Simple + hsexists <- doesFileExist ops "Setup.hs" + lhsexists <- doesFileExist ops "Setup.lhs" + return $ check (not simpleBuild && not hsexists && not lhsexists) $ + PackageDistInexcusable $ + "The package is missing a Setup.hs or Setup.lhs script." + +checkConfigureExists :: Monad m => CheckPackageContentOps m + -> PackageDescription + -> m (Maybe PackageCheck) +checkConfigureExists ops pd + | buildType pd == Configure = do + exists <- doesFileExist ops "configure" + return $ check (not exists) $ + PackageBuildWarning $ + "The 'build-type' is 'Configure' but there is no 'configure' script. " + ++ "You probably need to run 'autoreconf -i' to generate it." + | otherwise = return Nothing + +checkLocalPathsExist :: Monad m => CheckPackageContentOps m + -> PackageDescription + -> m [PackageCheck] +checkLocalPathsExist ops pkg = do + let dirs = [ (dir, kind) + | bi <- allBuildInfo pkg + , (dir, kind) <- + [ (dir, "extra-lib-dirs") | dir <- extraLibDirs bi ] + ++ [ (dir, "extra-lib-dirs-static") | dir <- extraLibDirsStatic bi ] + ++ [ (dir, "extra-framework-dirs") + | dir <- extraFrameworkDirs bi ] + ++ [ (dir, "include-dirs") | dir <- includeDirs bi ] + ++ [ (getSymbolicPath dir, "hs-source-dirs") | dir <- hsSourceDirs bi ] + , isRelativeOnAnyPlatform dir ] + missing <- filterM (liftM not . doesDirectoryExist ops . fst) dirs + return [ PackageBuildWarning { + explanation = quote (kind ++ ": " ++ dir) + ++ " specifies a directory which does not exist." + } + | (dir, kind) <- missing ] + +checkMissingVcsInfo :: (Monad m, Applicative m) + => CheckPackageContentOps m + -> PackageDescription + -> m [PackageCheck] +checkMissingVcsInfo ops pkg | null (sourceRepos pkg) = do + vcsInUse <- liftM or $ traverse (doesDirectoryExist ops) repoDirnames + if vcsInUse + then return [ PackageDistSuspicious message ] + else return [] + where + repoDirnames = [ dirname | repo <- knownRepoTypes + , dirname <- repoTypeDirname repo] + message = "When distributing packages it is encouraged to specify source " + ++ "control information in the .cabal file using one or more " + ++ "'source-repository' sections. See the Cabal user guide for " + ++ "details." + +checkMissingVcsInfo _ _ = return [] + +repoTypeDirname :: KnownRepoType -> [FilePath] +repoTypeDirname Darcs = ["_darcs"] +repoTypeDirname Git = [".git"] +repoTypeDirname SVN = [".svn"] +repoTypeDirname CVS = ["CVS"] +repoTypeDirname Mercurial = [".hg"] +repoTypeDirname GnuArch = [".arch-params"] +repoTypeDirname Bazaar = [".bzr"] +repoTypeDirname Monotone = ["_MTN"] +repoTypeDirname Pijul = [".pijul"] + +-- ------------------------------------------------------------ +-- * Checks involving files in the package +-- ------------------------------------------------------------ + +-- | Check the names of all files in a package for portability problems. This +-- should be done for example when creating or validating a package tarball. +-- +checkPackageFileNames :: [FilePath] -> [PackageCheck] +checkPackageFileNames = checkPackageFileNamesWithGlob . zip (repeat True) + +checkPackageFileNamesWithGlob :: [(Bool, FilePath)] -> [PackageCheck] +checkPackageFileNamesWithGlob files = + catMaybes $ + checkWindowsPaths files + : + [ checkTarPath file + | (_, file) <- files + ] + +checkWindowsPaths :: [(Bool, FilePath)] -> Maybe PackageCheck +checkWindowsPaths paths = + case filter (not . FilePath.Windows.isValid . escape) paths of + [] -> Nothing + ps -> Just $ + PackageDistInexcusable $ + "The " ++ quotes (map snd ps) ++ " invalid on Windows, which " + ++ "would cause portability problems for this package. Windows file " + ++ "names cannot contain any of the characters \":*?<>|\" and there " + ++ "a few reserved names including \"aux\", \"nul\", \"con\", " + ++ "\"prn\", \"com1-9\", \"lpt1-9\" and \"clock$\"." + where + -- force a relative name to catch invalid file names like "f:oo" which + -- otherwise parse as file "oo" in the current directory on the 'f' drive. + escape (isGlob, path) = (".\\" ++) + -- glob paths will be expanded before being dereferenced, so asterisks + -- shouldn't count against them. + $ map (\c -> if c == '*' && isGlob then 'x' else c) path + quotes [failed] = + "path " ++ quote failed ++ " is" + quotes failed = + "paths " ++ intercalate ", " (map quote failed) ++ " are" + +-- | Check a file name is valid for the portable POSIX tar format. +-- +-- The POSIX tar format has a restriction on the length of file names. It is +-- unfortunately not a simple restriction like a maximum length. The exact +-- restriction is that either the whole path be 100 characters or less, or it +-- be possible to split the path on a directory separator such that the first +-- part is 155 characters or less and the second part 100 characters or less. +-- +checkTarPath :: FilePath -> Maybe PackageCheck +checkTarPath path + | length path > 255 = Just longPath + | otherwise = case pack nameMax (reverse (splitPath path)) of + Left err -> Just err + Right [] -> Nothing + Right (h:rest) -> case pack prefixMax remainder of + Left err -> Just err + Right [] -> Nothing + Right (_:_) -> Just noSplit + where + -- drop the '/' between the name and prefix: + remainder = safeInit h : rest + + where + nameMax, prefixMax :: Int + nameMax = 100 + prefixMax = 155 + + pack _ [] = Left emptyName + pack maxLen (c:cs) + | n > maxLen = Left longName + | otherwise = Right (pack' maxLen n cs) + where n = length c + + pack' maxLen n (c:cs) + | n' <= maxLen = pack' maxLen n' cs + where n' = n + length c + pack' _ _ cs = cs + + longPath = PackageDistInexcusable $ + "The following file name is too long to store in a portable POSIX " + ++ "format tar archive. The maximum length is 255 ASCII characters.\n" + ++ "The file in question is:\n " ++ path + longName = PackageDistInexcusable $ + "The following file name is too long to store in a portable POSIX " + ++ "format tar archive. The maximum length for the name part (including " + ++ "extension) is 100 ASCII characters. The maximum length for any " + ++ "individual directory component is 155.\n" + ++ "The file in question is:\n " ++ path + noSplit = PackageDistInexcusable $ + "The following file name is too long to store in a portable POSIX " + ++ "format tar archive. While the total length is less than 255 ASCII " + ++ "characters, there are unfortunately further restrictions. It has to " + ++ "be possible to split the file path on a directory separator into " + ++ "two parts such that the first part fits in 155 characters or less " + ++ "and the second part fits in 100 characters or less. Basically you " + ++ "have to make the file name or directory names shorter, or you could " + ++ "split a long directory name into nested subdirectories with shorter " + ++ "names.\nThe file in question is:\n " ++ path + emptyName = PackageDistInexcusable $ + "Encountered a file with an empty name, something is very wrong! " + ++ "Files with an empty name cannot be stored in a tar archive or in " + ++ "standard file systems." + +-- -------------------------------------------------------------- +-- * Checks for missing content and other pre-distribution checks +-- -------------------------------------------------------------- + +-- | Similar to 'checkPackageContent', 'checkPackageFilesPreDistribution' +-- inspects the files included in the package, but is primarily looking for +-- files in the working tree that may have been missed or other similar +-- problems that can only be detected pre-distribution. +-- +-- Because Hackage necessarily checks the uploaded tarball, it is too late to +-- check these on the server; these checks only make sense in the development +-- and package-creation environment. Hence we can use IO, rather than needing +-- to pass a 'CheckPackageContentOps' dictionary around. +checkPackageFilesPreDistribution :: Verbosity -> PackageDescription -> FilePath -> IO [PackageCheck] +-- Note: this really shouldn't return any 'Inexcusable' warnings, +-- because that will make us say that Hackage would reject the package. +-- But, because Hackage doesn't run these tests, that will be a lie! +checkPackageFilesPreDistribution = checkGlobFiles + +-- | Discover problems with the package's wildcards. +checkGlobFiles :: Verbosity + -> PackageDescription + -> FilePath + -> IO [PackageCheck] +checkGlobFiles verbosity pkg root = + fmap concat $ for allGlobs $ \(field, dir, glob) -> + -- Note: we just skip over parse errors here; they're reported elsewhere. + case parseFileGlob (specVersion pkg) glob of + Left _ -> return [] + Right parsedGlob -> do + results <- runDirFileGlob verbosity (root dir) parsedGlob + let individualWarnings = results >>= getWarning field glob + noMatchesWarning = + [ PackageDistSuspiciousWarn $ + "In '" ++ field ++ "': the pattern '" ++ glob ++ "' does not" + ++ " match any files." + | all (not . suppressesNoMatchesWarning) results + ] + return (noMatchesWarning ++ individualWarnings) + where + adjustedDataDir = if null (dataDir pkg) then "." else dataDir pkg + allGlobs = concat + [ (,,) "extra-source-files" "." <$> extraSrcFiles pkg + , (,,) "extra-doc-files" "." <$> extraDocFiles pkg + , (,,) "data-files" adjustedDataDir <$> dataFiles pkg + ] + + -- If there's a missing directory in play, since our globs don't + -- (currently) support disjunction, that will always mean there are no + -- matches. The no matches error in this case is strictly less informative + -- than the missing directory error, so sit on it. + suppressesNoMatchesWarning (GlobMatch _) = True + suppressesNoMatchesWarning (GlobWarnMultiDot _) = False + suppressesNoMatchesWarning (GlobMissingDirectory _) = True + + getWarning :: String -> FilePath -> GlobResult FilePath -> [PackageCheck] + getWarning _ _ (GlobMatch _) = + [] + -- Before Cabal 2.4, the extensions of globs had to match the file + -- exactly. This has been relaxed in 2.4 to allow matching only the + -- suffix. This warning detects when pre-2.4 package descriptions are + -- omitting files purely because of the stricter check. + getWarning field glob (GlobWarnMultiDot file) = + [ PackageDistSuspiciousWarn $ + "In '" ++ field ++ "': the pattern '" ++ glob ++ "' does not" + ++ " match the file '" ++ file ++ "' because the extensions do not" + ++ " exactly match (e.g., foo.en.html does not exactly match *.html)." + ++ " To enable looser suffix-only matching, set 'cabal-version: 2.4' or higher." + ] + getWarning field glob (GlobMissingDirectory dir) = + [ PackageDistSuspiciousWarn $ + "In '" ++ field ++ "': the pattern '" ++ glob ++ "' attempts to" + ++ " match files in the directory '" ++ dir ++ "', but there is no" + ++ " directory by that name." + ] + +-- | Check that setup dependencies, have proper bounds. +-- In particular, @base@ and @Cabal@ upper bounds are mandatory. +checkSetupVersions :: GenericPackageDescription -> [PackageCheck] +checkSetupVersions pkg = + [ emitError nameStr + | (name, vr) <- Map.toList deps + , not (hasUpperBound vr) + , let nameStr = unPackageName name + , nameStr `elem` criticalPkgs + ] + where + criticalPkgs = ["Cabal", "base"] + deps = case typicalPkg pkg of + Right (pkgs', _) -> + Map.fromListWith intersectVersionRanges + [ (pname, vr) + | sbi <- maybeToList $ setupBuildInfo pkgs' + , Dependency pname vr _ <- setupDepends sbi + ] + _ -> Map.empty + emitError nm = + PackageDistInexcusable $ + "The dependency 'setup-depends: '"++nm++"' does not specify an " + ++ "upper bound on the version number. Each major release of the " + ++ "'"++nm++"' package changes the API in various ways and most " + ++ "packages will need some changes to compile with it. If you are " + ++ "not sure what upper bound to use then use the next major " + ++ "version." + +checkDuplicateModules :: GenericPackageDescription -> [PackageCheck] +checkDuplicateModules pkg = + concatMap checkLib (maybe id (:) (condLibrary pkg) . map snd $ condSubLibraries pkg) + ++ concatMap checkExe (map snd $ condExecutables pkg) + ++ concatMap checkTest (map snd $ condTestSuites pkg) + ++ concatMap checkBench (map snd $ condBenchmarks pkg) + where + -- the duplicate modules check is has not been thoroughly vetted for backpack + checkLib = checkDups "library" (\l -> explicitLibModules l ++ map moduleReexportName (reexportedModules l)) + checkExe = checkDups "executable" exeModules + checkTest = checkDups "test suite" testModules + checkBench = checkDups "benchmark" benchmarkModules + checkDups s getModules t = + let sumPair (x,x') (y,y') = (x + x' :: Int, y + y' :: Int) + mergePair (x, x') (y, y') = (x + x', max y y') + maxPair (x, x') (y, y') = (max x x', max y y') + libMap = foldCondTree Map.empty + (\(_,v) -> Map.fromListWith sumPair . map (\x -> (x,(1, 1))) $ getModules v ) + (Map.unionWith mergePair) -- if a module may occur in nonexclusive branches count it twice strictly and once loosely. + (Map.unionWith maxPair) -- a module occurs the max of times it might appear in exclusive branches + t + dupLibsStrict = Map.keys $ Map.filter ((>1) . fst) libMap + dupLibsLax = Map.keys $ Map.filter ((>1) . snd) libMap + in if not (null dupLibsLax) + then [PackageBuildImpossible $ "Duplicate modules in " ++ s ++ ": " ++ commaSep (map prettyShow dupLibsLax)] + else if not (null dupLibsStrict) + then [PackageDistSuspicious $ "Potential duplicate modules (subject to conditionals) in " ++ s ++ ": " ++ commaSep (map prettyShow dupLibsStrict)] + else [] + +-- ------------------------------------------------------------ +-- * Utils +-- ------------------------------------------------------------ + +quote :: String -> String +quote s = "'" ++ s ++ "'" + +commaSep :: [String] -> String +commaSep = intercalate ", " + +dups :: Ord a => [a] -> [a] +dups xs = [ x | (x:_:_) <- group (sort xs) ] + +fileExtensionSupportedLanguage :: FilePath -> Bool +fileExtensionSupportedLanguage path = + isHaskell || isC + where + extension = takeExtension path + isHaskell = extension `elem` [".hs", ".lhs"] + isC = isJust (filenameCDialect extension) + +-- | Whether a path is a good relative path. We aren't worried about perfect +-- cross-platform compatibility here; this function just checks the paths in +-- the (local) @.cabal@ file, while only Hackage needs the portability. +-- +-- >>> let test fp = putStrLn $ show (isGoodRelativeDirectoryPath fp) ++ "; " ++ show (isGoodRelativeFilePath fp) +-- +-- Note that "foo./bar.hs" would be invalid on Windows. +-- +-- >>> traverse_ test ["foo/bar/quu", "a/b.hs", "foo./bar.hs"] +-- Nothing; Nothing +-- Nothing; Nothing +-- Nothing; Nothing +-- +-- Trailing slash is not allowed for files, for directories it is ok. +-- +-- >>> test "foo/" +-- Nothing; Just "trailing slash" +-- +-- Leading @./@ is fine, but @.@ and @./@ are not valid files. +-- +-- >>> traverse_ test [".", "./", "./foo/bar"] +-- Nothing; Just "trailing dot segment" +-- Nothing; Just "trailing slash" +-- Nothing; Nothing +-- +-- Lastly, not good file nor directory cases: +-- +-- >>> traverse_ test ["", "/tmp/src", "foo//bar", "foo/.", "foo/./bar", "foo/../bar"] +-- Just "empty path"; Just "empty path" +-- Just "posix absolute path"; Just "posix absolute path" +-- Just "empty path segment"; Just "empty path segment" +-- Just "trailing same directory segment: ."; Just "trailing same directory segment: ." +-- Just "same directory segment: ."; Just "same directory segment: ." +-- Just "parent directory segment: .."; Just "parent directory segment: .." +-- +-- For the last case, 'isGoodRelativeGlob' doesn't warn: +-- +-- >>> traverse_ (print . isGoodRelativeGlob) ["foo/../bar"] +-- Just "parent directory segment: .." +-- +isGoodRelativeFilePath :: FilePath -> Maybe String +isGoodRelativeFilePath = state0 + where + -- initial state + state0 [] = Just "empty path" + state0 (c:cs) | c == '.' = state1 cs + | c == '/' = Just "posix absolute path" + | otherwise = state5 cs + + -- after initial . + state1 [] = Just "trailing dot segment" + state1 (c:cs) | c == '.' = state4 cs + | c == '/' = state2 cs + | otherwise = state5 cs + + -- after ./ or after / between segments + state2 [] = Just "trailing slash" + state2 (c:cs) | c == '.' = state3 cs + | c == '/' = Just "empty path segment" + | otherwise = state5 cs + + -- after non-first segment's . + state3 [] = Just "trailing same directory segment: ." + state3 (c:cs) | c == '.' = state4 cs + | c == '/' = Just "same directory segment: ." + | otherwise = state5 cs + + -- after .. + state4 [] = Just "trailing parent directory segment: .." + state4 (c:cs) | c == '.' = state5 cs + | c == '/' = Just "parent directory segment: .." + | otherwise = state5 cs + + -- in a segment which is ok. + state5 [] = Nothing + state5 (c:cs) | c == '.' = state5 cs + | c == '/' = state2 cs + | otherwise = state5 cs + +-- | See 'isGoodRelativeFilePath'. +-- +-- This is barebones function. We check whether the glob is a valid file +-- by replacing stars @*@ with @x@ses. +isGoodRelativeGlob :: FilePath -> Maybe String +isGoodRelativeGlob = isGoodRelativeFilePath . map f where + f '*' = 'x' + f c = c + +-- | See 'isGoodRelativeFilePath'. +isGoodRelativeDirectoryPath :: FilePath -> Maybe String +isGoodRelativeDirectoryPath = state0 + where + -- initial state + state0 [] = Just "empty path" + state0 (c:cs) | c == '.' = state5 cs + | c == '/' = Just "posix absolute path" + | otherwise = state4 cs + + -- after initial ./ or after / between segments + state1 [] = Nothing + state1 (c:cs) | c == '.' = state2 cs + | c == '/' = Just "empty path segment" + | otherwise = state4 cs + + -- after non-first setgment's . + state2 [] = Just "trailing same directory segment: ." + state2 (c:cs) | c == '.' = state3 cs + | c == '/' = Just "same directory segment: ." + | otherwise = state4 cs + + -- after .. + state3 [] = Just "trailing parent directory segment: .." + state3 (c:cs) | c == '.' = state4 cs + | c == '/' = Just "parent directory segment: .." + | otherwise = state4 cs + + -- in a segment which is ok. + state4 [] = Nothing + state4 (c:cs) | c == '.' = state4 cs + | c == '/' = state1 cs + | otherwise = state4 cs + + -- after initial . + state5 [] = Nothing -- "." + state5 (c:cs) | c == '.' = state3 cs + | c == '/' = state1 cs + | otherwise = state4 cs + +-- [Note: Good relative paths] +-- +-- Using @kleene@ we can define an extended regex: +-- +-- @ +-- import Algebra.Lattice +-- import Kleene +-- import Kleene.ERE (ERE (..), intersections) +-- +-- data C = CDot | CSlash | CChar +-- deriving (Eq, Ord, Enum, Bounded, Show) +-- +-- reservedR :: ERE C +-- reservedR = notChar CSlash +-- +-- pathPieceR :: ERE C +-- pathPieceR = intersections +-- [ plus reservedR +-- , ERENot (string [CDot]) +-- , ERENot (string [CDot,CDot]) +-- ] +-- +-- filePathR :: ERE C +-- filePathR = optional (string [CDot, CSlash]) <> pathPieceR <> star (char CSlash <> pathPieceR) +-- +-- dirPathR :: ERE C +-- dirPathR = (char CDot \/ filePathR) <> optional (char CSlash) +-- +-- plus :: ERE C -> ERE C +-- plus r = r <> star r +-- +-- optional :: ERE C -> ERE C +-- optional r = mempty \/ r +-- @ +-- +-- Results in following state machine for @filePathR@ +-- +-- @ +-- 0 -> \x -> if +-- | x <= CDot -> 1 +-- | otherwise -> 5 +-- 1 -> \x -> if +-- | x <= CDot -> 4 +-- | x <= CSlash -> 2 +-- | otherwise -> 5 +-- 2 -> \x -> if +-- | x <= CDot -> 3 +-- | otherwise -> 5 +-- 3 -> \x -> if +-- | x <= CDot -> 4 +-- | otherwise -> 5 +-- 4 -> \x -> if +-- | x <= CDot -> 5 +-- | otherwise -> 5 +-- 5+ -> \x -> if +-- | x <= CDot -> 5 +-- | x <= CSlash -> 2 +-- | otherwise -> 5 +-- @ +-- +-- and @dirPathR@: +-- +-- @ +-- 0 -> \x -> if +-- | x <= CDot -> 5 +-- | otherwise -> 4 +-- 1+ -> \x -> if +-- | x <= CDot -> 2 +-- | otherwise -> 4 +-- 2 -> \x -> if +-- | x <= CDot -> 3 +-- | otherwise -> 4 +-- 3 -> \x -> if +-- | x <= CDot -> 4 +-- | otherwise -> 4 +-- 4+ -> \x -> if +-- | x <= CDot -> 4 +-- | x <= CSlash -> 1 +-- | otherwise -> 4 +-- 5+ -> \x -> if +-- | x <= CDot -> 3 +-- | x <= CSlash -> 1 +-- | otherwise -> 4 +-- @ + +-- +-- TODO: What we really want to do is test if there exists any +-- configuration in which the base version is unbounded above. +-- However that's a bit tricky because there are many possible +-- configurations. As a cheap easy and safe approximation we will +-- pick a single "typical" configuration and check if that has an +-- open upper bound. To get a typical configuration we finalise +-- using no package index and the current platform. +typicalPkg :: GenericPackageDescription + -> Either [Dependency] (PackageDescription, FlagAssignment) +typicalPkg = finalizePD + mempty defaultComponentRequestedSpec (const True) + buildPlatform + (unknownCompilerInfo + (CompilerId buildCompilerFlavor nullVersion) + NoAbiTag) + [] diff --git a/cabal/Cabal/src/Distribution/ReadE.hs b/cabal/Cabal/src/Distribution/ReadE.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/ReadE.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE LambdaCase #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.ReadE +-- Copyright : Jose Iborra 2008 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Simple parsing with failure + +module Distribution.ReadE ( + -- * ReadE + ReadE(..), succeedReadE, failReadE, + -- * Projections + parsecToReadE, parsecToReadEErr, + -- * Parse Errors + unexpectMsgString, + ) where + +import Distribution.Compat.Prelude +import Prelude () +import qualified Data.Bifunctor as Bi (first) + +import Distribution.Parsec +import qualified Text.Parsec.Error as Parsec +import Distribution.Parsec.FieldLineStream + +-- | Parser with simple error reporting +newtype ReadE a = ReadE {runReadE :: String -> Either ErrorMsg a} +type ErrorMsg = String + +instance Functor ReadE where + fmap f (ReadE p) = ReadE $ \txt -> case p txt of + Right a -> Right (f a) + Left err -> Left err + +succeedReadE :: (String -> a) -> ReadE a +succeedReadE f = ReadE (Right . f) + +failReadE :: ErrorMsg -> ReadE a +failReadE = ReadE . const . Left + +runParsecFromString :: ParsecParser a -> String -> Either Parsec.ParseError a +runParsecFromString p txt = + runParsecParser p "" (fieldLineStreamFromString txt) + +parsecToReadE :: (String -> ErrorMsg) -> ParsecParser a -> ReadE a +parsecToReadE err p = ReadE $ \txt -> + (const $ err txt) `Bi.first` runParsecFromString p txt + +parsecToReadEErr :: (Parsec.ParseError -> ErrorMsg) -> ParsecParser a -> ReadE a +parsecToReadEErr err p = ReadE $ + Bi.first err . runParsecFromString p + +-- Show only unexpected error messages +unexpectMsgString :: Parsec.ParseError -> String +unexpectMsgString = unlines + . map Parsec.messageString + . filter (\case { Parsec.UnExpect _ -> True; _ -> False }) + . Parsec.errorMessages + diff --git a/cabal/Cabal/src/Distribution/Simple.hs b/cabal/Cabal/src/Distribution/Simple.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple.hs @@ -0,0 +1,808 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple +-- Copyright : Isaac Jones 2003-2005 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is the command line front end to the Simple build system. When given +-- the parsed command-line args and package information, is able to perform +-- basic commands like configure, build, install, register, etc. +-- +-- This module exports the main functions that Setup.hs scripts use. It +-- re-exports the 'UserHooks' type, the standard entry points like +-- 'defaultMain' and 'defaultMainWithHooks' and the predefined sets of +-- 'UserHooks' that custom @Setup.hs@ scripts can extend to add their own +-- behaviour. +-- +-- This module isn't called \"Simple\" because it's simple. Far from +-- it. It's called \"Simple\" because it does complicated things to +-- simple software. +-- +-- The original idea was that there could be different build systems that all +-- presented the same compatible command line interfaces. There is still a +-- "Distribution.Make" system but in practice no packages use it. + +{- +Work around this warning: +libraries/Cabal/Distribution/Simple.hs:78:0: + Warning: In the use of `runTests' + (imported from Distribution.Simple.UserHooks): + Deprecated: "Please use the new testing interface instead!" +-} +{-# OPTIONS_GHC -fno-warn-deprecations #-} + +module Distribution.Simple ( + module Distribution.Package, + module Distribution.Version, + module Distribution.License, + module Distribution.Simple.Compiler, + module Language.Haskell.Extension, + -- * Simple interface + defaultMain, defaultMainNoRead, defaultMainArgs, + -- * Customization + UserHooks(..), Args, + defaultMainWithHooks, defaultMainWithHooksArgs, + defaultMainWithHooksNoRead, defaultMainWithHooksNoReadArgs, + -- ** Standard sets of hooks + simpleUserHooks, + autoconfUserHooks, + emptyUserHooks, + ) where + +import Control.Exception (try) + +import Prelude () +import Distribution.Compat.Prelude + +-- local +import Distribution.Simple.Compiler +import Distribution.Simple.UserHooks +import Distribution.Package +import Distribution.PackageDescription +import Distribution.PackageDescription.Configuration +import Distribution.Simple.PackageDescription +import Distribution.Simple.Program +import Distribution.Simple.Program.Db +import Distribution.Simple.PreProcess +import Distribution.Simple.Setup +import Distribution.Simple.Command + +import Distribution.Simple.Build +import Distribution.Simple.SrcDist +import Distribution.Simple.Register + +import Distribution.Simple.Configure + +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.Bench +import Distribution.Simple.BuildPaths +import Distribution.Simple.Test +import Distribution.Simple.Install +import Distribution.Simple.Haddock +import Distribution.Simple.Utils +import Distribution.Utils.NubList +import Distribution.Verbosity +import Language.Haskell.Extension +import Distribution.Version +import Distribution.License +import Distribution.Pretty +import Distribution.System (buildPlatform) + +-- Base +import System.Environment (getArgs, getProgName) +import System.Directory (removeFile, doesFileExist + ,doesDirectoryExist, removeDirectoryRecursive) +import System.FilePath (searchPathSeparator, takeDirectory, (), + splitDirectories, dropDrive) +#ifdef mingw32_HOST_OS +import System.FilePath (normalise, splitDrive) +#endif +import Distribution.Compat.ResponseFile (expandResponse) +import Distribution.Compat.Directory (makeAbsolute) +import Distribution.Compat.Environment (getEnvironment) +import Distribution.Compat.GetShortPathName (getShortPathName) + +import Data.List (unionBy, (\\)) + + +-- | A simple implementation of @main@ for a Cabal setup script. +-- It reads the package description file using IO, and performs the +-- action specified on the command line. +defaultMain :: IO () +defaultMain = getArgs >>= defaultMainHelper simpleUserHooks + +-- | A version of 'defaultMain' that is passed the command line +-- arguments, rather than getting them from the environment. +defaultMainArgs :: [String] -> IO () +defaultMainArgs = defaultMainHelper simpleUserHooks + +-- | A customizable version of 'defaultMain'. +defaultMainWithHooks :: UserHooks -> IO () +defaultMainWithHooks hooks = getArgs >>= defaultMainHelper hooks + +-- | A customizable version of 'defaultMain' that also takes the command +-- line arguments. +defaultMainWithHooksArgs :: UserHooks -> [String] -> IO () +defaultMainWithHooksArgs = defaultMainHelper + +-- | Like 'defaultMain', but accepts the package description as input +-- rather than using IO to read it. +defaultMainNoRead :: GenericPackageDescription -> IO () +defaultMainNoRead = defaultMainWithHooksNoRead simpleUserHooks + +-- | A customizable version of 'defaultMainNoRead'. +defaultMainWithHooksNoRead :: UserHooks -> GenericPackageDescription -> IO () +defaultMainWithHooksNoRead hooks pkg_descr = + getArgs >>= + defaultMainHelper hooks { readDesc = return (Just pkg_descr) } + +-- | A customizable version of 'defaultMainNoRead' that also takes the +-- command line arguments. +-- +-- @since 2.2.0.0 +defaultMainWithHooksNoReadArgs :: UserHooks -> GenericPackageDescription -> [String] -> IO () +defaultMainWithHooksNoReadArgs hooks pkg_descr = + defaultMainHelper hooks { readDesc = return (Just pkg_descr) } + +defaultMainHelper :: UserHooks -> Args -> IO () +defaultMainHelper hooks args = topHandler $ do + args' <- expandResponse args + case commandsRun (globalCommand commands) commands args' of + CommandHelp help -> printHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo (flags, commandParse) -> + case commandParse of + _ | fromFlag (globalVersion flags) -> printVersion + | fromFlag (globalNumericVersion flags) -> printNumericVersion + CommandHelp help -> printHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo action -> action + + where + printHelp help = getProgName >>= putStr . help + printOptionsList = putStr . unlines + printErrors errs = do + putStr (intercalate "\n" errs) + exitWith (ExitFailure 1) + printNumericVersion = putStrLn $ prettyShow cabalVersion + printVersion = putStrLn $ "Cabal library version " + ++ prettyShow cabalVersion + + progs = addKnownPrograms (hookedPrograms hooks) defaultProgramDb + commands = + [configureCommand progs `commandAddAction` + \fs as -> configureAction hooks fs as >> return () + ,buildCommand progs `commandAddAction` buildAction hooks + ,replCommand progs `commandAddAction` replAction hooks + ,installCommand `commandAddAction` installAction hooks + ,copyCommand `commandAddAction` copyAction hooks + ,haddockCommand `commandAddAction` haddockAction hooks + ,cleanCommand `commandAddAction` cleanAction hooks + ,sdistCommand `commandAddAction` sdistAction hooks + ,hscolourCommand `commandAddAction` hscolourAction hooks + ,registerCommand `commandAddAction` registerAction hooks + ,unregisterCommand `commandAddAction` unregisterAction hooks + ,testCommand `commandAddAction` testAction hooks + ,benchmarkCommand `commandAddAction` benchAction hooks + ] + +-- | Combine the preprocessors in the given hooks with the +-- preprocessors built into cabal. +allSuffixHandlers :: UserHooks + -> [PPSuffixHandler] +allSuffixHandlers hooks + = overridesPP (hookedPreProcessors hooks) knownSuffixHandlers + where + overridesPP :: [PPSuffixHandler] -> [PPSuffixHandler] -> [PPSuffixHandler] + overridesPP = unionBy (\x y -> fst x == fst y) + +configureAction :: UserHooks -> ConfigFlags -> Args -> IO LocalBuildInfo +configureAction hooks flags args = do + distPref <- findDistPrefOrDefault (configDistPref flags) + let flags' = flags { configDistPref = toFlag distPref + , configArgs = args } + + -- See docs for 'HookedBuildInfo' + pbi <- preConf hooks args flags' + + (mb_pd_file, pkg_descr0) <- confPkgDescr hooks verbosity + (flagToMaybe (configCabalFilePath flags)) + + let epkg_descr = (pkg_descr0, pbi) + + localbuildinfo0 <- confHook hooks epkg_descr flags' + + -- remember the .cabal filename if we know it + -- and all the extra command line args + let localbuildinfo = localbuildinfo0 { + pkgDescrFile = mb_pd_file, + extraConfigArgs = args + } + writePersistBuildConfig distPref localbuildinfo + + let pkg_descr = localPkgDescr localbuildinfo + postConf hooks args flags' pkg_descr localbuildinfo + return localbuildinfo + where + verbosity = fromFlag (configVerbosity flags) + +confPkgDescr :: UserHooks -> Verbosity -> Maybe FilePath + -> IO (Maybe FilePath, GenericPackageDescription) +confPkgDescr hooks verbosity mb_path = do + mdescr <- readDesc hooks + case mdescr of + Just descr -> return (Nothing, descr) + Nothing -> do + pdfile <- case mb_path of + Nothing -> defaultPackageDesc verbosity + Just path -> return path + info verbosity "Using Parsec parser" + descr <- readGenericPackageDescription verbosity pdfile + return (Just pdfile, descr) + +buildAction :: UserHooks -> BuildFlags -> Args -> IO () +buildAction hooks flags args = do + distPref <- findDistPrefOrDefault (buildDistPref flags) + let verbosity = fromFlag $ buildVerbosity flags + lbi <- getBuildConfig hooks verbosity distPref + let flags' = flags { buildDistPref = toFlag distPref + , buildCabalFilePath = maybeToFlag (cabalFilePath lbi)} + + progs <- reconfigurePrograms verbosity + (buildProgramPaths flags') + (buildProgramArgs flags') + (withPrograms lbi) + + hookedAction verbosity preBuild buildHook postBuild + (return lbi { withPrograms = progs }) + hooks flags' { buildArgs = args } args + +replAction :: UserHooks -> ReplFlags -> Args -> IO () +replAction hooks flags args = do + distPref <- findDistPrefOrDefault (replDistPref flags) + let verbosity = fromFlag $ replVerbosity flags + flags' = flags { replDistPref = toFlag distPref } + + lbi <- getBuildConfig hooks verbosity distPref + progs <- reconfigurePrograms verbosity + (replProgramPaths flags') + (replProgramArgs flags') + (withPrograms lbi) + + -- As far as I can tell, the only reason this doesn't use + -- 'hookedActionWithArgs' is because the arguments of 'replHook' + -- takes the args explicitly. UGH. -- ezyang + pbi <- preRepl hooks args flags' + let pkg_descr0 = localPkgDescr lbi + sanityCheckHookedBuildInfo verbosity pkg_descr0 pbi + let pkg_descr = updatePackageDescription pbi pkg_descr0 + lbi' = lbi { withPrograms = progs + , localPkgDescr = pkg_descr } + replHook hooks pkg_descr lbi' hooks flags' args + postRepl hooks args flags' pkg_descr lbi' + +hscolourAction :: UserHooks -> HscolourFlags -> Args -> IO () +hscolourAction hooks flags args = do + distPref <- findDistPrefOrDefault (hscolourDistPref flags) + let verbosity = fromFlag $ hscolourVerbosity flags + lbi <- getBuildConfig hooks verbosity distPref + let flags' = flags { hscolourDistPref = toFlag distPref + , hscolourCabalFilePath = maybeToFlag (cabalFilePath lbi)} + + hookedAction verbosity preHscolour hscolourHook postHscolour + (getBuildConfig hooks verbosity distPref) + hooks flags' args + +haddockAction :: UserHooks -> HaddockFlags -> Args -> IO () +haddockAction hooks flags args = do + distPref <- findDistPrefOrDefault (haddockDistPref flags) + let verbosity = fromFlag $ haddockVerbosity flags + lbi <- getBuildConfig hooks verbosity distPref + let flags' = flags { haddockDistPref = toFlag distPref + , haddockCabalFilePath = maybeToFlag (cabalFilePath lbi)} + + progs <- reconfigurePrograms verbosity + (haddockProgramPaths flags') + (haddockProgramArgs flags') + (withPrograms lbi) + + hookedAction verbosity preHaddock haddockHook postHaddock + (return lbi { withPrograms = progs }) + hooks flags' { haddockArgs = args } args + +cleanAction :: UserHooks -> CleanFlags -> Args -> IO () +cleanAction hooks flags args = do + distPref <- findDistPrefOrDefault (cleanDistPref flags) + + elbi <- tryGetBuildConfig hooks verbosity distPref + let flags' = flags { cleanDistPref = toFlag distPref + , cleanCabalFilePath = case elbi of + Left _ -> mempty + Right lbi -> maybeToFlag (cabalFilePath lbi)} + + pbi <- preClean hooks args flags' + + (_, ppd) <- confPkgDescr hooks verbosity Nothing + -- It might seem like we are doing something clever here + -- but we're really not: if you look at the implementation + -- of 'clean' in the end all the package description is + -- used for is to clear out @extra-tmp-files@. IMO, + -- the configure script goo should go into @dist@ too! + -- -- ezyang + let pkg_descr0 = flattenPackageDescription ppd + -- We don't sanity check for clean as an error + -- here would prevent cleaning: + --sanityCheckHookedBuildInfo verbosity pkg_descr0 pbi + let pkg_descr = updatePackageDescription pbi pkg_descr0 + + cleanHook hooks pkg_descr () hooks flags' + postClean hooks args flags' pkg_descr () + where + verbosity = fromFlag (cleanVerbosity flags) + +copyAction :: UserHooks -> CopyFlags -> Args -> IO () +copyAction hooks flags args = do + distPref <- findDistPrefOrDefault (copyDistPref flags) + let verbosity = fromFlag $ copyVerbosity flags + lbi <- getBuildConfig hooks verbosity distPref + let flags' = flags { copyDistPref = toFlag distPref + , copyCabalFilePath = maybeToFlag (cabalFilePath lbi)} + hookedAction verbosity preCopy copyHook postCopy + (getBuildConfig hooks verbosity distPref) + hooks flags' { copyArgs = args } args + +installAction :: UserHooks -> InstallFlags -> Args -> IO () +installAction hooks flags args = do + distPref <- findDistPrefOrDefault (installDistPref flags) + let verbosity = fromFlag $ installVerbosity flags + lbi <- getBuildConfig hooks verbosity distPref + let flags' = flags { installDistPref = toFlag distPref + , installCabalFilePath = maybeToFlag (cabalFilePath lbi)} + hookedAction verbosity preInst instHook postInst + (getBuildConfig hooks verbosity distPref) + hooks flags' args + +-- Since Cabal-3.4 UserHooks are completely ignored +sdistAction :: UserHooks -> SDistFlags -> Args -> IO () +sdistAction _hooks flags _args = do + (_, ppd) <- confPkgDescr emptyUserHooks verbosity Nothing + let pkg_descr = flattenPackageDescription ppd + sdist pkg_descr flags srcPref knownSuffixHandlers + where + verbosity = fromFlag (sDistVerbosity flags) + +testAction :: UserHooks -> TestFlags -> Args -> IO () +testAction hooks flags args = do + distPref <- findDistPrefOrDefault (testDistPref flags) + let verbosity = fromFlag $ testVerbosity flags + flags' = flags { testDistPref = toFlag distPref } + + hookedActionWithArgs verbosity preTest testHook postTest + (getBuildConfig hooks verbosity distPref) + hooks flags' args + +benchAction :: UserHooks -> BenchmarkFlags -> Args -> IO () +benchAction hooks flags args = do + distPref <- findDistPrefOrDefault (benchmarkDistPref flags) + let verbosity = fromFlag $ benchmarkVerbosity flags + flags' = flags { benchmarkDistPref = toFlag distPref } + hookedActionWithArgs verbosity preBench benchHook postBench + (getBuildConfig hooks verbosity distPref) + hooks flags' args + +registerAction :: UserHooks -> RegisterFlags -> Args -> IO () +registerAction hooks flags args = do + distPref <- findDistPrefOrDefault (regDistPref flags) + let verbosity = fromFlag $ regVerbosity flags + lbi <- getBuildConfig hooks verbosity distPref + let flags' = flags { regDistPref = toFlag distPref + , regCabalFilePath = maybeToFlag (cabalFilePath lbi)} + hookedAction verbosity preReg regHook postReg + (getBuildConfig hooks verbosity distPref) + hooks flags' { regArgs = args } args + +unregisterAction :: UserHooks -> RegisterFlags -> Args -> IO () +unregisterAction hooks flags args = do + distPref <- findDistPrefOrDefault (regDistPref flags) + let verbosity = fromFlag $ regVerbosity flags + lbi <- getBuildConfig hooks verbosity distPref + let flags' = flags { regDistPref = toFlag distPref + , regCabalFilePath = maybeToFlag (cabalFilePath lbi)} + hookedAction verbosity preUnreg unregHook postUnreg + (getBuildConfig hooks verbosity distPref) + hooks flags' args + +hookedAction + :: Verbosity + -> (UserHooks -> Args -> flags -> IO HookedBuildInfo) + -> (UserHooks -> PackageDescription -> LocalBuildInfo + -> UserHooks -> flags -> IO ()) + -> (UserHooks -> Args -> flags -> PackageDescription + -> LocalBuildInfo -> IO ()) + -> IO LocalBuildInfo + -> UserHooks -> flags -> Args -> IO () +hookedAction verbosity pre_hook cmd_hook = + hookedActionWithArgs verbosity pre_hook + (\h _ pd lbi uh flags -> + cmd_hook h pd lbi uh flags) + +hookedActionWithArgs + :: Verbosity + -> (UserHooks -> Args -> flags -> IO HookedBuildInfo) + -> (UserHooks -> Args -> PackageDescription -> LocalBuildInfo + -> UserHooks -> flags -> IO ()) + -> (UserHooks -> Args -> flags -> PackageDescription + -> LocalBuildInfo -> IO ()) + -> IO LocalBuildInfo + -> UserHooks -> flags -> Args -> IO () +hookedActionWithArgs verbosity pre_hook cmd_hook post_hook + get_build_config hooks flags args = do + pbi <- pre_hook hooks args flags + lbi0 <- get_build_config + let pkg_descr0 = localPkgDescr lbi0 + sanityCheckHookedBuildInfo verbosity pkg_descr0 pbi + let pkg_descr = updatePackageDescription pbi pkg_descr0 + lbi = lbi0 { localPkgDescr = pkg_descr } + cmd_hook hooks args pkg_descr lbi hooks flags + post_hook hooks args flags pkg_descr lbi + +sanityCheckHookedBuildInfo + :: Verbosity -> PackageDescription -> HookedBuildInfo -> IO () +sanityCheckHookedBuildInfo verbosity + (PackageDescription { library = Nothing }) (Just _,_) + = die' verbosity $ "The buildinfo contains info for a library, " + ++ "but the package does not have a library." + +sanityCheckHookedBuildInfo verbosity pkg_descr (_, hookExes) + | exe1 : _ <- nonExistant + = die' verbosity $ "The buildinfo contains info for an executable called '" + ++ prettyShow exe1 ++ "' but the package does not have a " + ++ "executable with that name." + where + pkgExeNames = nub (map exeName (executables pkg_descr)) + hookExeNames = nub (map fst hookExes) + nonExistant = hookExeNames \\ pkgExeNames + +sanityCheckHookedBuildInfo _ _ _ = return () + +-- | Try to read the 'localBuildInfoFile' +tryGetBuildConfig :: UserHooks -> Verbosity -> FilePath + -> IO (Either ConfigStateFileError LocalBuildInfo) +tryGetBuildConfig u v = try . getBuildConfig u v + + +-- | Read the 'localBuildInfoFile' or throw an exception. +getBuildConfig :: UserHooks -> Verbosity -> FilePath -> IO LocalBuildInfo +getBuildConfig hooks verbosity distPref = do + lbi_wo_programs <- getPersistBuildConfig distPref + -- Restore info about unconfigured programs, since it is not serialized + let lbi = lbi_wo_programs { + withPrograms = restoreProgramDb + (builtinPrograms ++ hookedPrograms hooks) + (withPrograms lbi_wo_programs) + } + + case pkgDescrFile lbi of + Nothing -> return lbi + Just pkg_descr_file -> do + outdated <- checkPersistBuildConfigOutdated distPref pkg_descr_file + if outdated + then reconfigure pkg_descr_file lbi + else return lbi + + where + reconfigure :: FilePath -> LocalBuildInfo -> IO LocalBuildInfo + reconfigure pkg_descr_file lbi = do + notice verbosity $ pkg_descr_file ++ " has been changed. " + ++ "Re-configuring with most recently used options. " + ++ "If this fails, please run configure manually.\n" + let cFlags = configFlags lbi + let cFlags' = cFlags { + -- Since the list of unconfigured programs is not serialized, + -- restore it to the same value as normally used at the beginning + -- of a configure run: + configPrograms_ = fmap (restoreProgramDb + (builtinPrograms ++ hookedPrograms hooks)) + `fmap` configPrograms_ cFlags, + + -- Use the current, not saved verbosity level: + configVerbosity = Flag verbosity + } + configureAction hooks cFlags' (extraConfigArgs lbi) + + +-- -------------------------------------------------------------------------- +-- Cleaning + +clean :: PackageDescription -> CleanFlags -> IO () +clean pkg_descr flags = do + let distPref = fromFlagOrDefault defaultDistPref $ cleanDistPref flags + notice verbosity "cleaning..." + + maybeConfig <- if fromFlag (cleanSaveConf flags) + then maybeGetPersistBuildConfig distPref + else return Nothing + + -- remove the whole dist/ directory rather than tracking exactly what files + -- we created in there. + chattyTry "removing dist/" $ do + exists <- doesDirectoryExist distPref + when exists (removeDirectoryRecursive distPref) + + -- Any extra files the user wants to remove + traverse_ removeFileOrDirectory (extraTmpFiles pkg_descr) + + -- If the user wanted to save the config, write it back + traverse_ (writePersistBuildConfig distPref) maybeConfig + + where + removeFileOrDirectory :: FilePath -> IO () + removeFileOrDirectory fname = do + isDir <- doesDirectoryExist fname + isFile <- doesFileExist fname + if isDir then removeDirectoryRecursive fname + else when isFile $ removeFile fname + verbosity = fromFlag (cleanVerbosity flags) + +-- -------------------------------------------------------------------------- +-- Default hooks + +-- | Hooks that correspond to a plain instantiation of the +-- \"simple\" build system +simpleUserHooks :: UserHooks +simpleUserHooks = + emptyUserHooks { + confHook = configure, + postConf = finalChecks, + buildHook = defaultBuildHook, + replHook = defaultReplHook, + copyHook = \desc lbi _ f -> install desc lbi f, + -- 'install' has correct 'copy' behavior with params + testHook = defaultTestHook, + benchHook = defaultBenchHook, + instHook = defaultInstallHook, + cleanHook = \p _ _ f -> clean p f, + hscolourHook = \p l h f -> hscolour p l (allSuffixHandlers h) f, + haddockHook = \p l h f -> haddock p l (allSuffixHandlers h) f, + regHook = defaultRegHook, + unregHook = \p l _ f -> unregister p l f + } + where + finalChecks _args flags pkg_descr lbi = + checkForeignDeps pkg_descr lbi (lessVerbose verbosity) + where + verbosity = fromFlag (configVerbosity flags) + +-- | Basic autoconf 'UserHooks': +-- +-- * 'postConf' runs @.\/configure@, if present. +-- +-- * the pre-hooks 'preBuild', 'preClean', 'preCopy', 'preInst', +-- 'preReg' and 'preUnreg' read additional build information from +-- /package/@.buildinfo@, if present. +-- +-- Thus @configure@ can use local system information to generate +-- /package/@.buildinfo@ and possibly other files. + +autoconfUserHooks :: UserHooks +autoconfUserHooks + = simpleUserHooks + { + postConf = defaultPostConf, + preBuild = readHookWithArgs buildVerbosity buildDistPref, -- buildCabalFilePath, + preCopy = readHookWithArgs copyVerbosity copyDistPref, + preClean = readHook cleanVerbosity cleanDistPref, + preInst = readHook installVerbosity installDistPref, + preHscolour = readHook hscolourVerbosity hscolourDistPref, + preHaddock = readHookWithArgs haddockVerbosity haddockDistPref, + preReg = readHook regVerbosity regDistPref, + preUnreg = readHook regVerbosity regDistPref + } + where defaultPostConf :: Args -> ConfigFlags -> PackageDescription + -> LocalBuildInfo -> IO () + defaultPostConf args flags pkg_descr lbi + = do let verbosity = fromFlag (configVerbosity flags) + baseDir lbi' = fromMaybe "" + (takeDirectory <$> cabalFilePath lbi') + confExists <- doesFileExist $ (baseDir lbi) "configure" + if confExists + then runConfigureScript verbosity + backwardsCompatHack flags lbi + else die' verbosity "configure script not found." + + pbi <- getHookedBuildInfo verbosity (buildDir lbi) + sanityCheckHookedBuildInfo verbosity pkg_descr pbi + let pkg_descr' = updatePackageDescription pbi pkg_descr + lbi' = lbi { localPkgDescr = pkg_descr' } + postConf simpleUserHooks args flags pkg_descr' lbi' + + backwardsCompatHack = False + + readHookWithArgs :: (a -> Flag Verbosity) + -> (a -> Flag FilePath) + -> Args -> a + -> IO HookedBuildInfo + readHookWithArgs get_verbosity get_dist_pref _ flags = do + dist_dir <- findDistPrefOrDefault (get_dist_pref flags) + getHookedBuildInfo verbosity (dist_dir "build") + where + verbosity = fromFlag (get_verbosity flags) + + readHook :: (a -> Flag Verbosity) + -> (a -> Flag FilePath) + -> Args -> a -> IO HookedBuildInfo + readHook get_verbosity get_dist_pref a flags = do + noExtraFlags a + dist_dir <- findDistPrefOrDefault (get_dist_pref flags) + getHookedBuildInfo verbosity (dist_dir "build") + where + verbosity = fromFlag (get_verbosity flags) + +runConfigureScript :: Verbosity -> Bool -> ConfigFlags -> LocalBuildInfo + -> IO () +runConfigureScript verbosity backwardsCompatHack flags lbi = do + env <- getEnvironment + let programDb = withPrograms lbi + (ccProg, ccFlags) <- configureCCompiler verbosity programDb + ccProgShort <- getShortPathName ccProg + -- The C compiler's compilation and linker flags (e.g. + -- "C compiler flags" and "Gcc Linker flags" from GHC) have already + -- been merged into ccFlags, so we set both CFLAGS and LDFLAGS + -- to ccFlags + -- We don't try and tell configure which ld to use, as we don't have + -- a way to pass its flags too + configureFile <- makeAbsolute $ + fromMaybe "." (takeDirectory <$> cabalFilePath lbi) "configure" + -- autoconf is fussy about filenames, and has a set of forbidden + -- characters that can't appear in the build directory, etc: + -- https://www.gnu.org/software/autoconf/manual/autoconf.html#File-System-Conventions + -- + -- This has caused hard-to-debug failures in the past (#5368), so we + -- detect some cases early and warn with a clear message. Windows's + -- use of backslashes is problematic here, so we'll switch to + -- slashes, but we do still want to fail on backslashes in POSIX + -- paths. + -- + -- TODO: We don't check for colons, tildes or leading dashes. We + -- also should check the builddir's path, destdir, and all other + -- paths as well. + let configureFile' = toUnix configureFile + for_ badAutoconfCharacters $ \(c, cname) -> + when (c `elem` dropDrive configureFile') $ + warn verbosity $ concat + [ "The path to the './configure' script, '", configureFile' + , "', contains the character '", [c], "' (", cname, ")." + , " This may cause the script to fail with an obscure error, or for" + , " building the package to fail later." + ] + + let extraPath = fromNubList $ configProgramPathExtra flags + let cflagsEnv = maybe (unwords ccFlags) (++ (" " ++ unwords ccFlags)) + $ lookup "CFLAGS" env + spSep = [searchPathSeparator] + pathEnv = maybe (intercalate spSep extraPath) + ((intercalate spSep extraPath ++ spSep)++) $ lookup "PATH" env + overEnv = ("CFLAGS", Just cflagsEnv) : + [("PATH", Just pathEnv) | not (null extraPath)] + hp = hostPlatform lbi + maybeHostFlag = if hp == buildPlatform then [] else ["--host=" ++ show (pretty hp)] + args' = configureFile':args ++ ["CC=" ++ ccProgShort] ++ maybeHostFlag + shProg = simpleProgram "sh" + progDb = modifyProgramSearchPath + (\p -> map ProgramSearchPathDir extraPath ++ p) emptyProgramDb + shConfiguredProg <- lookupProgram shProg + `fmap` configureProgram verbosity shProg progDb + case shConfiguredProg of + Just sh -> runProgramInvocation verbosity $ + (programInvocation (sh {programOverrideEnv = overEnv}) args') + { progInvokeCwd = Just (buildDir lbi) } + Nothing -> die' verbosity notFoundMsg + where + args = configureArgs backwardsCompatHack flags + + notFoundMsg = "The package has a './configure' script. " + ++ "If you are on Windows, This requires a " + ++ "Unix compatibility toolchain such as MinGW+MSYS or Cygwin. " + ++ "If you are not on Windows, ensure that an 'sh' command " + ++ "is discoverable in your path." + +-- | Convert Windows path to Unix ones +toUnix :: String -> String +#ifdef mingw32_HOST_OS +toUnix s = let tmp = normalise s + (l, rest) = case splitDrive tmp of + ([], x) -> ("/" , x) + (h:_, x) -> ('/':h:"/", x) + parts = splitDirectories rest + in l ++ intercalate "/" parts +#else +toUnix s = intercalate "/" $ splitDirectories s +#endif + +badAutoconfCharacters :: [(Char, String)] +badAutoconfCharacters = + [ (' ', "space") + , ('\t', "tab") + , ('\n', "newline") + , ('\0', "null") + , ('"', "double quote") + , ('#', "hash") + , ('$', "dollar sign") + , ('&', "ampersand") + , ('\'', "single quote") + , ('(', "left bracket") + , (')', "right bracket") + , ('*', "star") + , (';', "semicolon") + , ('<', "less-than sign") + , ('=', "equals sign") + , ('>', "greater-than sign") + , ('?', "question mark") + , ('[', "left square bracket") + , ('\\', "backslash") + , ('`', "backtick") + , ('|', "pipe") + ] + +getHookedBuildInfo :: Verbosity -> FilePath -> IO HookedBuildInfo +getHookedBuildInfo verbosity build_dir = do + maybe_infoFile <- findHookedPackageDesc verbosity build_dir + case maybe_infoFile of + Nothing -> return emptyHookedBuildInfo + Just infoFile -> do + info verbosity $ "Reading parameters from " ++ infoFile + readHookedBuildInfo verbosity infoFile + +defaultTestHook :: Args -> PackageDescription -> LocalBuildInfo + -> UserHooks -> TestFlags -> IO () +defaultTestHook args pkg_descr localbuildinfo _ flags = + test args pkg_descr localbuildinfo flags + +defaultBenchHook :: Args -> PackageDescription -> LocalBuildInfo + -> UserHooks -> BenchmarkFlags -> IO () +defaultBenchHook args pkg_descr localbuildinfo _ flags = + bench args pkg_descr localbuildinfo flags + +defaultInstallHook :: PackageDescription -> LocalBuildInfo + -> UserHooks -> InstallFlags -> IO () +defaultInstallHook pkg_descr localbuildinfo _ flags = do + let copyFlags = defaultCopyFlags { + copyDistPref = installDistPref flags, + copyDest = installDest flags, + copyVerbosity = installVerbosity flags + } + install pkg_descr localbuildinfo copyFlags + let registerFlags = defaultRegisterFlags { + regDistPref = installDistPref flags, + regInPlace = installInPlace flags, + regPackageDB = installPackageDB flags, + regVerbosity = installVerbosity flags + } + when (hasLibs pkg_descr) $ register pkg_descr localbuildinfo registerFlags + +defaultBuildHook :: PackageDescription -> LocalBuildInfo + -> UserHooks -> BuildFlags -> IO () +defaultBuildHook pkg_descr localbuildinfo hooks flags = + build pkg_descr localbuildinfo flags (allSuffixHandlers hooks) + +defaultReplHook :: PackageDescription -> LocalBuildInfo + -> UserHooks -> ReplFlags -> [String] -> IO () +defaultReplHook pkg_descr localbuildinfo hooks flags args = + repl pkg_descr localbuildinfo flags (allSuffixHandlers hooks) args + +defaultRegHook :: PackageDescription -> LocalBuildInfo + -> UserHooks -> RegisterFlags -> IO () +defaultRegHook pkg_descr localbuildinfo _ flags = + if hasLibs pkg_descr + then register pkg_descr localbuildinfo flags + else setupMessage (fromFlag (regVerbosity flags)) + "Package contains no library to register:" (packageId pkg_descr) diff --git a/cabal/Cabal/src/Distribution/Simple/Bench.hs b/cabal/Cabal/src/Distribution/Simple/Bench.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/Bench.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Bench +-- Copyright : Johan Tibell 2011 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is the entry point into running the benchmarks in a built +-- package. It performs the \"@.\/setup bench@\" action. It runs +-- benchmarks designated in the package description. + +module Distribution.Simple.Bench + ( bench + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Types.UnqualComponentName +import qualified Distribution.PackageDescription as PD +import Distribution.Simple.BuildPaths +import Distribution.Simple.Compiler +import Distribution.Simple.InstallDirs +import qualified Distribution.Simple.LocalBuildInfo as LBI +import Distribution.Simple.Setup +import Distribution.Simple.UserHooks +import Distribution.Simple.Utils +import Distribution.Pretty + +import System.Directory ( doesFileExist ) +import System.FilePath ( (), (<.>) ) + +-- | Perform the \"@.\/setup bench@\" action. +bench :: Args -- ^positional command-line arguments + -> PD.PackageDescription -- ^information from the .cabal file + -> LBI.LocalBuildInfo -- ^information from the configure step + -> BenchmarkFlags -- ^flags sent to benchmark + -> IO () +bench args pkg_descr lbi flags = do + let verbosity = fromFlag $ benchmarkVerbosity flags + benchmarkNames = args + pkgBenchmarks = PD.benchmarks pkg_descr + enabledBenchmarks = map fst (LBI.enabledBenchLBIs pkg_descr lbi) + + -- Run the benchmark + doBench :: PD.Benchmark -> IO ExitCode + doBench bm = + case PD.benchmarkInterface bm of + PD.BenchmarkExeV10 _ _ -> do + let cmd = LBI.buildDir lbi name name <.> exeExtension (LBI.hostPlatform lbi) + options = map (benchOption pkg_descr lbi bm) $ + benchmarkOptions flags + -- Check that the benchmark executable exists. + exists <- doesFileExist cmd + unless exists $ die' verbosity $ + "Could not find benchmark program \"" + ++ cmd ++ "\". Did you build the package first?" + + notice verbosity $ startMessage name + -- This will redirect the child process + -- stdout/stderr to the parent process. + exitcode <- rawSystemExitCode verbosity cmd options + notice verbosity $ finishMessage name exitcode + return exitcode + + _ -> do + notice verbosity $ "No support for running " + ++ "benchmark " ++ name ++ " of type: " + ++ prettyShow (PD.benchmarkType bm) + exitFailure + where name = unUnqualComponentName $ PD.benchmarkName bm + + unless (PD.hasBenchmarks pkg_descr) $ do + notice verbosity "Package has no benchmarks." + exitSuccess + + when (PD.hasBenchmarks pkg_descr && null enabledBenchmarks) $ + die' verbosity $ "No benchmarks enabled. Did you remember to configure with " + ++ "\'--enable-benchmarks\'?" + + bmsToRun <- case benchmarkNames of + [] -> return enabledBenchmarks + names -> for names $ \bmName -> + let benchmarkMap = zip enabledNames enabledBenchmarks + enabledNames = map PD.benchmarkName enabledBenchmarks + allNames = map PD.benchmarkName pkgBenchmarks + in case lookup (mkUnqualComponentName bmName) benchmarkMap of + Just t -> return t + _ | mkUnqualComponentName bmName `elem` allNames -> + die' verbosity $ "Package configured with benchmark " + ++ bmName ++ " disabled." + | otherwise -> die' verbosity $ "no such benchmark: " ++ bmName + + let totalBenchmarks = length bmsToRun + notice verbosity $ "Running " ++ show totalBenchmarks ++ " benchmarks..." + exitcodes <- traverse doBench bmsToRun + let allOk = totalBenchmarks == length (filter (== ExitSuccess) exitcodes) + unless allOk exitFailure + where + startMessage name = "Benchmark " ++ name ++ ": RUNNING...\n" + finishMessage name exitcode = "Benchmark " ++ name ++ ": " + ++ (case exitcode of + ExitSuccess -> "FINISH" + ExitFailure _ -> "ERROR") + + +-- TODO: This is abusing the notion of a 'PathTemplate'. The result isn't +-- necessarily a path. +benchOption :: PD.PackageDescription + -> LBI.LocalBuildInfo + -> PD.Benchmark + -> PathTemplate + -> String +benchOption pkg_descr lbi bm template = + fromPathTemplate $ substPathTemplate env template + where + env = initialPathTemplateEnv + (PD.package pkg_descr) (LBI.localUnitId lbi) + (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) ++ + [(BenchmarkNameVar, toPathTemplate $ unUnqualComponentName $ PD.benchmarkName bm)] diff --git a/cabal/Cabal/src/Distribution/Simple/Build.hs b/cabal/Cabal/src/Distribution/Simple/Build.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/Build.hs @@ -0,0 +1,830 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Build +-- Copyright : Isaac Jones 2003-2005, +-- Ross Paterson 2006, +-- Duncan Coutts 2007-2008, 2012 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is the entry point to actually building the modules in a package. It +-- doesn't actually do much itself, most of the work is delegated to +-- compiler-specific actions. It does do some non-compiler specific bits like +-- running pre-processors. +-- + +module Distribution.Simple.Build ( + build, repl, + startInterpreter, + + initialBuildSteps, + createInternalPackageDB, + componentInitialBuildSteps, + writeAutogenFiles, + ) where + +import Prelude () +import Distribution.Compat.Prelude +import Distribution.Utils.Generic + +import Distribution.Types.ComponentLocalBuildInfo +import Distribution.Types.ComponentRequestedSpec +import Distribution.Types.Dependency +import Distribution.Types.ExecutableScope +import Distribution.Types.ForeignLib +import Distribution.Types.LibraryVisibility +import Distribution.Types.LocalBuildInfo +import Distribution.Types.MungedPackageId +import Distribution.Types.MungedPackageName +import Distribution.Types.ModuleRenaming +import Distribution.Types.TargetInfo +import Distribution.Utils.Path + +import Distribution.Package +import Distribution.Backpack +import Distribution.Backpack.DescribeUnitId +import qualified Distribution.Simple.GHC as GHC +import qualified Distribution.Simple.GHCJS as GHCJS +import qualified Distribution.Simple.UHC as UHC +import qualified Distribution.Simple.HaskellSuite as HaskellSuite +import qualified Distribution.Simple.PackageIndex as Index + +import Distribution.Simple.Build.Macros (generateCabalMacrosHeader) +import Distribution.Simple.Build.PathsModule (generatePathsModule) +import qualified Distribution.Simple.Program.HcPkg as HcPkg + +import Distribution.Simple.Compiler +import Distribution.PackageDescription +import qualified Distribution.InstalledPackageInfo as IPI +import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import qualified Distribution.ModuleName as ModuleName + +import Distribution.Simple.Setup +import Distribution.Simple.BuildTarget +import Distribution.Simple.BuildToolDepends +import Distribution.Simple.PreProcess +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.Program +import Distribution.Simple.Program.Builtin (haskellSuiteProgram) +import qualified Distribution.Simple.Program.GHC as GHC +import Distribution.Simple.Program.Types +import Distribution.Simple.ShowBuildInfo +import Distribution.Simple.BuildPaths +import Distribution.Simple.Configure +import Distribution.Simple.Register +import Distribution.Simple.Test.LibV09 +import Distribution.Simple.Utils +import Distribution.Utils.Json + +import Distribution.System +import Distribution.Pretty +import Distribution.Verbosity +import Distribution.Version (thisVersion) + +import Distribution.Compat.Graph (IsNode(..)) + +import Control.Monad +import qualified Data.Set as Set +import qualified Data.ByteString.Lazy as LBS +import System.FilePath ( (), (<.>), takeDirectory ) +import System.Directory ( getCurrentDirectory, removeFile, doesFileExist ) + +-- ----------------------------------------------------------------------------- +-- |Build the libraries and executables in this package. + +build :: PackageDescription -- ^ Mostly information from the .cabal file + -> LocalBuildInfo -- ^ Configuration information + -> BuildFlags -- ^ Flags that the user passed to build + -> [ PPSuffixHandler ] -- ^ preprocessors to run before compiling + -> IO () +build pkg_descr lbi flags suffixes = do + targets <- readTargetInfos verbosity pkg_descr lbi (buildArgs flags) + let componentsToBuild = neededTargetsInBuildOrder' pkg_descr lbi (map nodeKey targets) + info verbosity $ "Component build order: " + ++ intercalate ", " + (map (showComponentName . componentLocalName . targetCLBI) + componentsToBuild) + + when (null targets) $ + -- Only bother with this message if we're building the whole package + setupMessage verbosity "Building" (packageId pkg_descr) + + internalPackageDB <- createInternalPackageDB verbosity lbi distPref + + -- Before the actual building, dump out build-information. + -- This way, if the actual compilation failed, the options have still been + -- dumped. + dumpBuildInfo verbosity distPref (configDumpBuildInfo (configFlags lbi)) pkg_descr lbi flags + + -- Now do the actual building + (\f -> foldM_ f (installedPkgs lbi) componentsToBuild) $ \index target -> do + let comp = targetComponent target + clbi = targetCLBI target + componentInitialBuildSteps distPref pkg_descr lbi clbi verbosity + let bi = componentBuildInfo comp + progs' = addInternalBuildTools pkg_descr lbi bi (withPrograms lbi) + lbi' = lbi { + withPrograms = progs', + withPackageDB = withPackageDB lbi ++ [internalPackageDB], + installedPkgs = index + } + mb_ipi <- buildComponent verbosity (buildNumJobs flags) pkg_descr + lbi' suffixes comp clbi distPref + return (maybe index (Index.insert `flip` index) mb_ipi) + + return () + where + distPref = fromFlag (buildDistPref flags) + verbosity = fromFlag (buildVerbosity flags) + + +-- | Write available build information for 'LocalBuildInfo' to disk. +-- +-- Dumps detailed build information 'build-info.json' to the given directory. +-- Build information contains basics such as compiler details, but also +-- lists what modules a component contains and how to compile the component, assuming +-- lib:Cabal made sure that dependencies are up-to-date. +dumpBuildInfo :: Verbosity + -> FilePath -- ^ To which directory should the build-info be dumped? + -> Flag DumpBuildInfo -- ^ Should we dump detailed build information for this component? + -> PackageDescription -- ^ Mostly information from the .cabal file + -> LocalBuildInfo -- ^ Configuration information + -> BuildFlags -- ^ Flags that the user passed to build + -> IO () +dumpBuildInfo verbosity distPref dumpBuildInfoFlag pkg_descr lbi flags = do + when shouldDumpBuildInfo $ do + -- Changing this line might break consumers of the dumped build info. + -- Announce changes on mailing lists! + let activeTargets = allTargetsInBuildOrder' pkg_descr lbi + info verbosity $ "Dump build information for: " + ++ intercalate ", " + (map (showComponentName . componentLocalName . targetCLBI) + activeTargets) + pwd <- getCurrentDirectory + + (compilerProg, _) <- case flavorToProgram (compilerFlavor (compiler lbi)) of + Nothing -> die' verbosity $ "dumpBuildInfo: Unknown compiler flavor: " + ++ show (compilerFlavor (compiler lbi)) + Just program -> requireProgram verbosity program (withPrograms lbi) + + let (warns, json) = mkBuildInfo pwd pkg_descr lbi flags (compilerProg, compiler lbi) activeTargets + buildInfoText = renderJson json + unless (null warns) $ + warn verbosity $ "Encountered warnings while dumping build-info:\n" + ++ unlines warns + LBS.writeFile (buildInfoPref distPref) buildInfoText + + when (not shouldDumpBuildInfo) $ do + -- Remove existing build-info.json as it might be outdated now. + exists <- doesFileExist (buildInfoPref distPref) + when exists $ removeFile (buildInfoPref distPref) + where + shouldDumpBuildInfo = fromFlagOrDefault NoDumpBuildInfo dumpBuildInfoFlag == DumpBuildInfo + + -- | Given the flavor of the compiler, try to find out + -- which program we need. + flavorToProgram :: CompilerFlavor -> Maybe Program + flavorToProgram GHC = Just ghcProgram + flavorToProgram GHCJS = Just ghcjsProgram + flavorToProgram UHC = Just uhcProgram + flavorToProgram JHC = Just jhcProgram + flavorToProgram HaskellSuite {} = Just haskellSuiteProgram + flavorToProgram _ = Nothing + + +repl :: PackageDescription -- ^ Mostly information from the .cabal file + -> LocalBuildInfo -- ^ Configuration information + -> ReplFlags -- ^ Flags that the user passed to build + -> [ PPSuffixHandler ] -- ^ preprocessors to run before compiling + -> [String] + -> IO () +repl pkg_descr lbi flags suffixes args = do + let distPref = fromFlag (replDistPref flags) + verbosity = fromFlag (replVerbosity flags) + + target <- readTargetInfos verbosity pkg_descr lbi args >>= \r -> case r of + -- This seems DEEPLY questionable. + [] -> case allTargetsInBuildOrder' pkg_descr lbi of + (target:_) -> return target + [] -> die' verbosity $ "Failed to determine target." + [target] -> return target + _ -> die' verbosity $ "The 'repl' command does not support multiple targets at once." + let componentsToBuild = neededTargetsInBuildOrder' pkg_descr lbi [nodeKey target] + debug verbosity $ "Component build order: " + ++ intercalate ", " + (map (showComponentName . componentLocalName . targetCLBI) + componentsToBuild) + + internalPackageDB <- createInternalPackageDB verbosity lbi distPref + + let lbiForComponent comp lbi' = + lbi' { + withPackageDB = withPackageDB lbi ++ [internalPackageDB], + withPrograms = addInternalBuildTools pkg_descr lbi' + (componentBuildInfo comp) (withPrograms lbi') + } + + -- build any dependent components + sequence_ + [ do let clbi = targetCLBI subtarget + comp = targetComponent subtarget + lbi' = lbiForComponent comp lbi + componentInitialBuildSteps distPref pkg_descr lbi clbi verbosity + buildComponent verbosity NoFlag + pkg_descr lbi' suffixes comp clbi distPref + | subtarget <- safeInit componentsToBuild ] + + -- REPL for target components + let clbi = targetCLBI target + comp = targetComponent target + lbi' = lbiForComponent comp lbi + replFlags = replReplOptions flags + componentInitialBuildSteps distPref pkg_descr lbi clbi verbosity + replComponent replFlags verbosity pkg_descr lbi' suffixes comp clbi distPref + + +-- | Start an interpreter without loading any package files. +startInterpreter :: Verbosity -> ProgramDb -> Compiler -> Platform + -> PackageDBStack -> IO () +startInterpreter verbosity programDb comp platform packageDBs = + case compilerFlavor comp of + GHC -> GHC.startInterpreter verbosity programDb comp platform packageDBs + GHCJS -> GHCJS.startInterpreter verbosity programDb comp platform packageDBs + _ -> die' verbosity "A REPL is not supported with this compiler." + +buildComponent :: Verbosity + -> Flag (Maybe Int) + -> PackageDescription + -> LocalBuildInfo + -> [PPSuffixHandler] + -> Component + -> ComponentLocalBuildInfo + -> FilePath + -> IO (Maybe InstalledPackageInfo) +buildComponent verbosity numJobs pkg_descr lbi suffixes + comp@(CLib lib) clbi distPref = do + preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes + extras <- preprocessExtras verbosity comp lbi + setupMessage' verbosity "Building" (packageId pkg_descr) + (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) + let libbi = libBuildInfo lib + lib' = lib { libBuildInfo = flip addExtraAsmSources extras + $ flip addExtraCmmSources extras + $ flip addExtraCxxSources extras + $ flip addExtraCSources extras + $ libbi + } + + buildLib verbosity numJobs pkg_descr lbi lib' clbi + + let oneComponentRequested (OneComponentRequestedSpec _) = True + oneComponentRequested _ = False + -- Don't register inplace if we're only building a single component; + -- it's not necessary because there won't be any subsequent builds + -- that need to tag us + if (not (oneComponentRequested (componentEnabledSpec lbi))) + then do + -- Register the library in-place, so exes can depend + -- on internally defined libraries. + pwd <- getCurrentDirectory + let -- The in place registration uses the "-inplace" suffix, not an ABI hash + installedPkgInfo = inplaceInstalledPackageInfo pwd distPref pkg_descr + -- NB: Use a fake ABI hash to avoid + -- needing to recompute it every build. + (mkAbiHash "inplace") lib' lbi clbi + + debug verbosity $ "Registering inplace:\n" ++ (IPI.showInstalledPackageInfo installedPkgInfo) + registerPackage verbosity (compiler lbi) (withPrograms lbi) + (withPackageDB lbi) installedPkgInfo + HcPkg.defaultRegisterOptions { + HcPkg.registerMultiInstance = True + } + return (Just installedPkgInfo) + else return Nothing + +buildComponent verbosity numJobs pkg_descr lbi suffixes + comp@(CFLib flib) clbi _distPref = do + preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes + setupMessage' verbosity "Building" (packageId pkg_descr) + (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) + buildFLib verbosity numJobs pkg_descr lbi flib clbi + return Nothing + +buildComponent verbosity numJobs pkg_descr lbi suffixes + comp@(CExe exe) clbi _ = do + preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes + extras <- preprocessExtras verbosity comp lbi + setupMessage' verbosity "Building" (packageId pkg_descr) + (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) + let ebi = buildInfo exe + exe' = exe { buildInfo = addExtraCSources ebi extras } + buildExe verbosity numJobs pkg_descr lbi exe' clbi + return Nothing + + +buildComponent verbosity numJobs pkg_descr lbi suffixes + comp@(CTest test@TestSuite { testInterface = TestSuiteExeV10{} }) + clbi _distPref = do + let exe = testSuiteExeV10AsExe test + preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes + extras <- preprocessExtras verbosity comp lbi + (genDir, generatedExtras) <- generateCode (testCodeGenerators test) (testName test) pkg_descr (testBuildInfo test) lbi clbi verbosity + setupMessage' verbosity "Building" (packageId pkg_descr) + (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) + let ebi = buildInfo exe + exe' = exe { buildInfo = addSrcDir (addExtraOtherModules (addExtraCSources ebi extras) generatedExtras) genDir } -- todo extend hssrcdirs + buildExe verbosity numJobs pkg_descr lbi exe' clbi + return Nothing + +buildComponent verbosity numJobs pkg_descr lbi0 suffixes + comp@(CTest + test@TestSuite { testInterface = TestSuiteLibV09{} }) + clbi -- This ComponentLocalBuildInfo corresponds to a detailed + -- test suite and not a real component. It should not + -- be used, except to construct the CLBIs for the + -- library and stub executable that will actually be + -- built. + distPref = do + pwd <- getCurrentDirectory + let (pkg, lib, libClbi, lbi, ipi, exe, exeClbi) = + testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 distPref pwd + preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes + extras <- preprocessExtras verbosity comp lbi -- TODO find cpphs processed files + (genDir, generatedExtras) <- generateCode (testCodeGenerators test) (testName test) pkg_descr (testBuildInfo test) lbi clbi verbosity + setupMessage' verbosity "Building" (packageId pkg_descr) + (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) + let libbi = libBuildInfo lib + lib' = lib { libBuildInfo = addSrcDir (addExtraOtherModules libbi generatedExtras) genDir } + buildLib verbosity numJobs pkg lbi lib' libClbi + -- NB: need to enable multiple instances here, because on 7.10+ + -- the package name is the same as the library, and we still + -- want the registration to go through. + registerPackage verbosity (compiler lbi) (withPrograms lbi) + (withPackageDB lbi) ipi + HcPkg.defaultRegisterOptions { + HcPkg.registerMultiInstance = True + } + let ebi = buildInfo exe + -- NB: The stub executable is linked against the test-library + -- which already contains all `other-modules`, so we need + -- to remove those from the stub-exe's build-info + exe' = exe { buildInfo = (addExtraCSources ebi extras) { otherModules = [] } } + buildExe verbosity numJobs pkg_descr lbi exe' exeClbi + return Nothing -- Can't depend on test suite + + +buildComponent verbosity _ _ _ _ + (CTest TestSuite { testInterface = TestSuiteUnsupported tt }) + _ _ = + die' verbosity $ "No support for building test suite type " ++ prettyShow tt + + +buildComponent verbosity numJobs pkg_descr lbi suffixes + comp@(CBench bm@Benchmark { benchmarkInterface = BenchmarkExeV10 {} }) + clbi _distPref = do + let exe = benchmarkExeV10asExe bm + preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes + extras <- preprocessExtras verbosity comp lbi + setupMessage' verbosity "Building" (packageId pkg_descr) + (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) + let ebi = buildInfo exe + exe' = exe { buildInfo = addExtraCSources ebi extras } + buildExe verbosity numJobs pkg_descr lbi exe' clbi + return Nothing + + +buildComponent verbosity _ _ _ _ + (CBench Benchmark { benchmarkInterface = BenchmarkUnsupported tt }) + _ _ = + die' verbosity $ "No support for building benchmark type " ++ prettyShow tt + + + +generateCode + :: [String] + -> UnqualComponentName + -> PackageDescription + -> BuildInfo + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Verbosity + -> IO (FilePath, [ModuleName.ModuleName]) +generateCode codeGens nm pdesc bi lbi clbi verbosity = do + when (not . null $ codeGens) $ createDirectoryIfMissingVerbose verbosity True tgtDir + (\x -> (tgtDir,x)) . concat <$> mapM go codeGens + where + allLibs = (maybe id (:) $ library pdesc) (subLibraries pdesc) + dependencyLibs = filter (const True) allLibs -- intersect with componentPackageDeps of clbi + srcDirs = concatMap (hsSourceDirs . libBuildInfo) dependencyLibs + nm' = unUnqualComponentName nm + tgtDir = buildDir lbi nm' nm' ++ "-gen" + go :: String -> IO [ModuleName.ModuleName] + go codeGenProg = fmap fromString . lines <$> getDbProgramOutput verbosity (simpleProgram codeGenProg) (withPrograms lbi) + ((tgtDir : map getSymbolicPath srcDirs) ++ + ("--" : + GHC.renderGhcOptions (compiler lbi) (hostPlatform lbi) (GHC.componentGhcOptions verbosity lbi bi clbi tgtDir))) + + +-- | Add extra C sources generated by preprocessing to build +-- information. +addExtraCSources :: BuildInfo -> [FilePath] -> BuildInfo +addExtraCSources bi extras = bi { cSources = new } + where new = Set.toList $ old `Set.union` exs + old = Set.fromList $ cSources bi + exs = Set.fromList extras + + +-- | Add extra C++ sources generated by preprocessing to build +-- information. +addExtraCxxSources :: BuildInfo -> [FilePath] -> BuildInfo +addExtraCxxSources bi extras = bi { cxxSources = new } + where new = Set.toList $ old `Set.union` exs + old = Set.fromList $ cxxSources bi + exs = Set.fromList extras + + +-- | Add extra C-- sources generated by preprocessing to build +-- information. +addExtraCmmSources :: BuildInfo -> [FilePath] -> BuildInfo +addExtraCmmSources bi extras = bi { cmmSources = new } + where new = Set.toList $ old `Set.union` exs + old = Set.fromList $ cmmSources bi + exs = Set.fromList extras + + +-- | Add extra ASM sources generated by preprocessing to build +-- information. +addExtraAsmSources :: BuildInfo -> [FilePath] -> BuildInfo +addExtraAsmSources bi extras = bi { asmSources = new } + where new = Set.toList $ old `Set.union` exs + old = Set.fromList $ asmSources bi + exs = Set.fromList extras + +-- | Add extra HS modules generated by preprocessing to build +-- information. +addExtraOtherModules :: BuildInfo -> [ModuleName.ModuleName] -> BuildInfo +addExtraOtherModules bi extras = bi { otherModules = new } + where new = Set.toList $ old `Set.union` exs + old = Set.fromList $ otherModules bi + exs = Set.fromList extras + +-- | Add extra source dir for generated modules. +addSrcDir :: BuildInfo -> FilePath -> BuildInfo +addSrcDir bi extra = bi { hsSourceDirs = new } + where new = Set.toList $ old `Set.union` ex + old = Set.fromList $ hsSourceDirs bi + ex = Set.fromList [unsafeMakeSymbolicPath extra] -- TODO + + +replComponent :: ReplOptions + -> Verbosity + -> PackageDescription + -> LocalBuildInfo + -> [PPSuffixHandler] + -> Component + -> ComponentLocalBuildInfo + -> FilePath + -> IO () +replComponent replFlags verbosity pkg_descr lbi suffixes + comp@(CLib lib) clbi _ = do + preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes + extras <- preprocessExtras verbosity comp lbi + let libbi = libBuildInfo lib + lib' = lib { libBuildInfo = libbi { cSources = cSources libbi ++ extras } } + replLib replFlags verbosity pkg_descr lbi lib' clbi + +replComponent replFlags verbosity pkg_descr lbi suffixes + comp@(CFLib flib) clbi _ = do + preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes + replFLib replFlags verbosity pkg_descr lbi flib clbi + +replComponent replFlags verbosity pkg_descr lbi suffixes + comp@(CExe exe) clbi _ = do + preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes + extras <- preprocessExtras verbosity comp lbi + let ebi = buildInfo exe + exe' = exe { buildInfo = ebi { cSources = cSources ebi ++ extras } } + replExe replFlags verbosity pkg_descr lbi exe' clbi + + +replComponent replFlags verbosity pkg_descr lbi suffixes + comp@(CTest test@TestSuite { testInterface = TestSuiteExeV10{} }) + clbi _distPref = do + let exe = testSuiteExeV10AsExe test + preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes + extras <- preprocessExtras verbosity comp lbi + let ebi = buildInfo exe + exe' = exe { buildInfo = ebi { cSources = cSources ebi ++ extras } } + replExe replFlags verbosity pkg_descr lbi exe' clbi + + +replComponent replFlags verbosity pkg_descr lbi0 suffixes + comp@(CTest + test@TestSuite { testInterface = TestSuiteLibV09{} }) + clbi distPref = do + pwd <- getCurrentDirectory + let (pkg, lib, libClbi, lbi, _, _, _) = + testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 distPref pwd + preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes + extras <- preprocessExtras verbosity comp lbi + let libbi = libBuildInfo lib + lib' = lib { libBuildInfo = libbi { cSources = cSources libbi ++ extras } } + replLib replFlags verbosity pkg lbi lib' libClbi + + +replComponent _ verbosity _ _ _ + (CTest TestSuite { testInterface = TestSuiteUnsupported tt }) + _ _ = + die' verbosity $ "No support for building test suite type " ++ prettyShow tt + + +replComponent replFlags verbosity pkg_descr lbi suffixes + comp@(CBench bm@Benchmark { benchmarkInterface = BenchmarkExeV10 {} }) + clbi _distPref = do + let exe = benchmarkExeV10asExe bm + preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes + extras <- preprocessExtras verbosity comp lbi + let ebi = buildInfo exe + exe' = exe { buildInfo = ebi { cSources = cSources ebi ++ extras } } + replExe replFlags verbosity pkg_descr lbi exe' clbi + + +replComponent _ verbosity _ _ _ + (CBench Benchmark { benchmarkInterface = BenchmarkUnsupported tt }) + _ _ = + die' verbosity $ "No support for building benchmark type " ++ prettyShow tt + +---------------------------------------------------- +-- Shared code for buildComponent and replComponent +-- + +-- | Translate a exe-style 'TestSuite' component into an exe for building +testSuiteExeV10AsExe :: TestSuite -> Executable +testSuiteExeV10AsExe test@TestSuite { testInterface = TestSuiteExeV10 _ mainFile } = + Executable { + exeName = testName test, + modulePath = mainFile, + exeScope = ExecutablePublic, + buildInfo = testBuildInfo test + } +testSuiteExeV10AsExe TestSuite{} = error "testSuiteExeV10AsExe: wrong kind" + +-- | Translate a exe-style 'Benchmark' component into an exe for building +benchmarkExeV10asExe :: Benchmark -> Executable +benchmarkExeV10asExe bm@Benchmark { benchmarkInterface = BenchmarkExeV10 _ mainFile } = + Executable { + exeName = benchmarkName bm, + modulePath = mainFile, + exeScope = ExecutablePublic, + buildInfo = benchmarkBuildInfo bm + } +benchmarkExeV10asExe Benchmark{} = error "benchmarkExeV10asExe: wrong kind" + +-- | Translate a lib-style 'TestSuite' component into a lib + exe for building +testSuiteLibV09AsLibAndExe :: PackageDescription + -> TestSuite + -> ComponentLocalBuildInfo + -> LocalBuildInfo + -> FilePath + -> FilePath + -> (PackageDescription, + Library, ComponentLocalBuildInfo, + LocalBuildInfo, + IPI.InstalledPackageInfo, + Executable, ComponentLocalBuildInfo) +testSuiteLibV09AsLibAndExe pkg_descr + test@TestSuite { testInterface = TestSuiteLibV09 _ m } + clbi lbi distPref pwd = + (pkg, lib, libClbi, lbi, ipi, exe, exeClbi) + where + bi = testBuildInfo test + lib = Library { + libName = LMainLibName, + exposedModules = [ m ], + reexportedModules = [], + signatures = [], + libExposed = True, + libVisibility = LibraryVisibilityPrivate, + libBuildInfo = bi + } + -- This is, like, the one place where we use a CTestName for a library. + -- Should NOT use library name, since that could conflict! + PackageIdentifier pkg_name pkg_ver = package pkg_descr + -- Note: we do make internal library from the test! + compat_name = MungedPackageName pkg_name (LSubLibName (testName test)) + compat_key = computeCompatPackageKey (compiler lbi) compat_name pkg_ver (componentUnitId clbi) + libClbi = LibComponentLocalBuildInfo + { componentPackageDeps = componentPackageDeps clbi + , componentInternalDeps = componentInternalDeps clbi + , componentIsIndefinite_ = False + , componentExeDeps = componentExeDeps clbi + , componentLocalName = CLibName $ LSubLibName $ testName test + , componentIsPublic = False + , componentIncludes = componentIncludes clbi + , componentUnitId = componentUnitId clbi + , componentComponentId = componentComponentId clbi + , componentInstantiatedWith = [] + , componentCompatPackageName = compat_name + , componentCompatPackageKey = compat_key + , componentExposedModules = [IPI.ExposedModule m Nothing] + } + pkgName' = mkPackageName $ prettyShow compat_name + pkg = pkg_descr { + package = (package pkg_descr) { pkgName = pkgName' } + , executables = [] + , testSuites = [] + , subLibraries = [lib] + } + ipi = inplaceInstalledPackageInfo pwd distPref pkg (mkAbiHash "") lib lbi libClbi + testDir = buildDir lbi stubName test + stubName test ++ "-tmp" + testLibDep = Dependency + pkgName' + (thisVersion $ pkgVersion $ package pkg_descr) + mainLibSet + exe = Executable { + exeName = mkUnqualComponentName $ stubName test, + modulePath = stubFilePath test, + exeScope = ExecutablePublic, + buildInfo = (testBuildInfo test) { + hsSourceDirs = [ unsafeMakeSymbolicPath testDir ], + targetBuildDepends = testLibDep + : (targetBuildDepends $ testBuildInfo test) + } + } + -- | The stub executable needs a new 'ComponentLocalBuildInfo' + -- that exposes the relevant test suite library. + deps = (IPI.installedUnitId ipi, mungedId ipi) + : (filter (\(_, x) -> let name = prettyShow $ mungedName x + in name == "Cabal" || name == "base") + (componentPackageDeps clbi)) + exeClbi = ExeComponentLocalBuildInfo { + -- TODO: this is a hack, but as long as this is unique + -- (doesn't clobber something) we won't run into trouble + componentUnitId = mkUnitId (stubName test), + componentComponentId = mkComponentId (stubName test), + componentInternalDeps = [componentUnitId clbi], + componentExeDeps = [], + componentLocalName = CExeName $ mkUnqualComponentName $ stubName test, + componentPackageDeps = deps, + -- Assert DefUnitId invariant! + -- Executable can't be indefinite, so dependencies must + -- be definite packages. + componentIncludes = zip (map (DefiniteUnitId . unsafeMkDefUnitId . fst) deps) + (repeat defaultRenaming) + } +testSuiteLibV09AsLibAndExe _ TestSuite{} _ _ _ _ = error "testSuiteLibV09AsLibAndExe: wrong kind" + + +-- | Initialize a new package db file for libraries defined +-- internally to the package. +createInternalPackageDB :: Verbosity -> LocalBuildInfo -> FilePath + -> IO PackageDB +createInternalPackageDB verbosity lbi distPref = do + existsAlready <- doesPackageDBExist dbPath + when existsAlready $ deletePackageDB dbPath + createPackageDB verbosity (compiler lbi) (withPrograms lbi) False dbPath + return (SpecificPackageDB dbPath) + where + dbPath = internalPackageDBPath lbi distPref + +addInternalBuildTools :: PackageDescription -> LocalBuildInfo -> BuildInfo + -> ProgramDb -> ProgramDb +addInternalBuildTools pkg lbi bi progs = + foldr updateProgram progs internalBuildTools + where + internalBuildTools = + [ simpleConfiguredProgram toolName' (FoundOnSystem toolLocation) + | toolName <- getAllInternalToolDependencies pkg bi + , let toolName' = unUnqualComponentName toolName + , let toolLocation = buildDir lbi toolName' toolName' <.> exeExtension (hostPlatform lbi) ] + + +-- TODO: build separate libs in separate dirs so that we can build +-- multiple libs, e.g. for 'LibTest' library-style test suites +buildLib :: Verbosity -> Flag (Maybe Int) + -> PackageDescription -> LocalBuildInfo + -> Library -> ComponentLocalBuildInfo -> IO () +buildLib verbosity numJobs pkg_descr lbi lib clbi = + case compilerFlavor (compiler lbi) of + GHC -> GHC.buildLib verbosity numJobs pkg_descr lbi lib clbi + GHCJS -> GHCJS.buildLib verbosity numJobs pkg_descr lbi lib clbi + UHC -> UHC.buildLib verbosity pkg_descr lbi lib clbi + HaskellSuite {} -> HaskellSuite.buildLib verbosity pkg_descr lbi lib clbi + _ -> die' verbosity "Building is not supported with this compiler." + +-- | Build a foreign library +-- +-- NOTE: We assume that we already checked that we can actually build the +-- foreign library in configure. +buildFLib :: Verbosity -> Flag (Maybe Int) + -> PackageDescription -> LocalBuildInfo + -> ForeignLib -> ComponentLocalBuildInfo -> IO () +buildFLib verbosity numJobs pkg_descr lbi flib clbi = + case compilerFlavor (compiler lbi) of + GHC -> GHC.buildFLib verbosity numJobs pkg_descr lbi flib clbi + _ -> die' verbosity "Building is not supported with this compiler." + +buildExe :: Verbosity -> Flag (Maybe Int) + -> PackageDescription -> LocalBuildInfo + -> Executable -> ComponentLocalBuildInfo -> IO () +buildExe verbosity numJobs pkg_descr lbi exe clbi = + case compilerFlavor (compiler lbi) of + GHC -> GHC.buildExe verbosity numJobs pkg_descr lbi exe clbi + GHCJS -> GHCJS.buildExe verbosity numJobs pkg_descr lbi exe clbi + UHC -> UHC.buildExe verbosity pkg_descr lbi exe clbi + _ -> die' verbosity "Building is not supported with this compiler." + +replLib :: ReplOptions -> Verbosity -> PackageDescription + -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo + -> IO () +replLib replFlags verbosity pkg_descr lbi lib clbi = + case compilerFlavor (compiler lbi) of + -- 'cabal repl' doesn't need to support 'ghc --make -j', so we just pass + -- NoFlag as the numJobs parameter. + GHC -> GHC.replLib replFlags verbosity NoFlag pkg_descr lbi lib clbi + GHCJS -> GHCJS.replLib (replOptionsFlags replFlags) verbosity NoFlag pkg_descr lbi lib clbi + _ -> die' verbosity "A REPL is not supported for this compiler." + +replExe :: ReplOptions -> Verbosity -> PackageDescription + -> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo + -> IO () +replExe replFlags verbosity pkg_descr lbi exe clbi = + case compilerFlavor (compiler lbi) of + GHC -> GHC.replExe replFlags verbosity NoFlag pkg_descr lbi exe clbi + GHCJS -> GHCJS.replExe (replOptionsFlags replFlags) verbosity NoFlag pkg_descr lbi exe clbi + _ -> die' verbosity "A REPL is not supported for this compiler." + +replFLib :: ReplOptions -> Verbosity -> PackageDescription + -> LocalBuildInfo -> ForeignLib -> ComponentLocalBuildInfo + -> IO () +replFLib replFlags verbosity pkg_descr lbi exe clbi = + case compilerFlavor (compiler lbi) of + GHC -> GHC.replFLib replFlags verbosity NoFlag pkg_descr lbi exe clbi + _ -> die' verbosity "A REPL is not supported for this compiler." + +-- | Runs 'componentInitialBuildSteps' on every configured component. +initialBuildSteps :: FilePath -- ^"dist" prefix + -> PackageDescription -- ^mostly information from the .cabal file + -> LocalBuildInfo -- ^Configuration information + -> Verbosity -- ^The verbosity to use + -> IO () +initialBuildSteps distPref pkg_descr lbi verbosity = + withAllComponentsInBuildOrder pkg_descr lbi $ \_comp clbi -> + componentInitialBuildSteps distPref pkg_descr lbi clbi verbosity + +-- | Creates the autogenerated files for a particular configured component. +componentInitialBuildSteps :: FilePath -- ^"dist" prefix + -> PackageDescription -- ^mostly information from the .cabal file + -> LocalBuildInfo -- ^Configuration information + -> ComponentLocalBuildInfo + -> Verbosity -- ^The verbosity to use + -> IO () +componentInitialBuildSteps _distPref pkg_descr lbi clbi verbosity = do + createDirectoryIfMissingVerbose verbosity True (componentBuildDir lbi clbi) + + writeAutogenFiles verbosity pkg_descr lbi clbi + +-- | Generate and write out the Paths_.hs and cabal_macros.h files +-- +writeAutogenFiles :: Verbosity + -> PackageDescription + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> IO () +writeAutogenFiles verbosity pkg lbi clbi = do + createDirectoryIfMissingVerbose verbosity True (autogenComponentModulesDir lbi clbi) + + let pathsModulePath = autogenComponentModulesDir lbi clbi + ModuleName.toFilePath (autogenPathsModuleName pkg) <.> "hs" + pathsModuleDir = takeDirectory pathsModulePath + -- Ensure that the directory exists! + createDirectoryIfMissingVerbose verbosity True pathsModuleDir + rewriteFileEx verbosity pathsModulePath (generatePathsModule pkg lbi clbi) + + --TODO: document what we're doing here, and move it to its own function + case clbi of + LibComponentLocalBuildInfo { componentInstantiatedWith = insts } -> + -- Write out empty hsig files for all requirements, so that GHC + -- has a source file to look at it when it needs to typecheck + -- a signature. It's harmless to write these out even when + -- there is a real hsig file written by the user, since + -- include path ordering ensures that the real hsig file + -- will always be picked up before the autogenerated one. + for_ (map fst insts) $ \mod_name -> do + let sigPath = autogenComponentModulesDir lbi clbi + ModuleName.toFilePath mod_name <.> "hsig" + createDirectoryIfMissingVerbose verbosity True (takeDirectory sigPath) + rewriteFileEx verbosity sigPath $ + "{-# OPTIONS_GHC -w #-}\n" ++ + "{-# LANGUAGE NoImplicitPrelude #-}\n" ++ + "signature " ++ prettyShow mod_name ++ " where" + _ -> return () + + let cppHeaderPath = autogenComponentModulesDir lbi clbi cppHeaderName + rewriteFileEx verbosity cppHeaderPath (generateCabalMacrosHeader pkg lbi clbi) diff --git a/cabal/Cabal/src/Distribution/Simple/Build/Macros.hs b/cabal/Cabal/src/Distribution/Simple/Build/Macros.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/Build/Macros.hs @@ -0,0 +1,110 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Build.Macros +-- Copyright : Simon Marlow 2008 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Generate cabal_macros.h - CPP macros for package version testing +-- +-- When using CPP you get +-- +-- > VERSION_ +-- > MIN_VERSION_(A,B,C) +-- +-- for each /package/ in @build-depends@, which is true if the version of +-- /package/ in use is @>= A.B.C@, using the normal ordering on version +-- numbers. +-- +-- TODO Figure out what to do about backpack and internal libraries. It is very +-- suspicious that this stuff works with munged package identifiers +module Distribution.Simple.Build.Macros ( + generateCabalMacrosHeader, + generatePackageVersionMacros, + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Version +import Distribution.PackageDescription +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.Program.Db +import Distribution.Simple.Program.Types +import Distribution.Types.MungedPackageId +import Distribution.Types.MungedPackageName +import Distribution.Pretty + +import qualified Distribution.Simple.Build.Macros.Z as Z + +-- | The contents of the @cabal_macros.h@ for the given configured package. +-- +generateCabalMacrosHeader :: PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> String +generateCabalMacrosHeader pkg_descr lbi clbi = Z.render Z.Z + { Z.zPackages = map mkZPackage $ package pkg_descr : map getPid (componentPackageDeps clbi) + , Z.zTools = + [ Z.ZTool + { Z.ztoolName = programId prog + , Z.ztoolVersion = ver + , Z.ztoolX = major1 + , Z.ztoolY = major2 + , Z.ztoolZ = minor + } + | prog <- configuredPrograms $ withPrograms lbi + , ver <- maybeToList (programVersion prog) + , let (major1,major2,minor) = majorMinor ver + ] + , Z.zPackageKey = case clbi of + LibComponentLocalBuildInfo{} -> componentCompatPackageKey clbi + _ -> "" + , Z.zComponentId = prettyShow (componentComponentId clbi) + , Z.zPackageVersion = pkgVersion (package pkg_descr) + , Z.zNotNull = not . null + , Z.zManglePkgName = map fixchar . unPackageName + , Z.zMangleStr = map fixchar + } + where + getPid (_, MungedPackageId (MungedPackageName pn _) v) = + -- NB: Drop the library name! We're just reporting package versions. + -- This would have to be revisited if you are allowed to depend + -- on different versions of the same package + PackageIdentifier pn v + +-- | Helper function that generates just the @VERSION_pkg@ and @MIN_VERSION_pkg@ +-- macros for a list of package ids (usually used with the specific deps of +-- a configured package). +-- +generatePackageVersionMacros :: Version -> [PackageId] -> String +generatePackageVersionMacros ver pkgids = Z.render Z.Z + { Z.zPackages = map mkZPackage pkgids + , Z.zTools = [] + , Z.zPackageKey = "" + , Z.zComponentId = "" + , Z.zPackageVersion = ver + , Z.zNotNull = not . null + , Z.zManglePkgName = map fixchar . unPackageName + , Z.zMangleStr = map fixchar + } + +mkZPackage :: PackageId -> Z.ZPackage +mkZPackage (PackageIdentifier name ver) = Z.ZPackage + { Z.zpkgName = name + , Z.zpkgVersion = ver + , Z.zpkgX = major1 + , Z.zpkgY = major2 + , Z.zpkgZ = minor + } + where + (major1,major2,minor) = majorMinor ver + +majorMinor :: Version -> (String, String, String) +majorMinor ver = case map show (versionNumbers ver) of + [] -> ("0", "0", "0") + [x] -> (x, "0", "0") + [x,y] -> (x, y, "0") + (x:y:z:_) -> (x, y, z) + +fixchar :: Char -> Char +fixchar '-' = '_' +fixchar c = c diff --git a/cabal/Cabal/src/Distribution/Simple/Build/Macros/Z.hs b/cabal/Cabal/src/Distribution/Simple/Build/Macros/Z.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/Build/Macros/Z.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Simple.Build.Macros.Z (render, Z(..), ZPackage (..), ZTool (..)) where +import Distribution.ZinzaPrelude +data Z + = Z {zPackages :: ([ZPackage]), + zTools :: ([ZTool]), + zPackageKey :: String, + zComponentId :: String, + zPackageVersion :: Version, + zNotNull :: (String -> Bool), + zManglePkgName :: (PackageName -> String), + zMangleStr :: (String -> String)} + deriving Generic +data ZPackage + = ZPackage {zpkgName :: PackageName, + zpkgVersion :: Version, + zpkgX :: String, + zpkgY :: String, + zpkgZ :: String} + deriving Generic +data ZTool + = ZTool {ztoolName :: String, + ztoolVersion :: Version, + ztoolX :: String, + ztoolY :: String, + ztoolZ :: String} + deriving Generic +render :: Z -> String +render z_root = execWriter $ do + tell "/* DO NOT EDIT: This file is automatically generated by Cabal */\n" + tell "\n" + forM_ (zPackages z_root) $ \z_var0_pkg -> do + tell "/* package " + tell (prettyShow (zpkgName z_var0_pkg)) + tell "-" + tell (prettyShow (zpkgVersion z_var0_pkg)) + tell " */\n" + tell "#ifndef VERSION_" + tell (zManglePkgName z_root (zpkgName z_var0_pkg)) + tell "\n" + tell "#define VERSION_" + tell (zManglePkgName z_root (zpkgName z_var0_pkg)) + tell " \"" + tell (prettyShow (zpkgVersion z_var0_pkg)) + tell "\"\n" + tell "#endif /* VERSION_" + tell (zManglePkgName z_root (zpkgName z_var0_pkg)) + tell " */\n" + tell "#ifndef MIN_VERSION_" + tell (zManglePkgName z_root (zpkgName z_var0_pkg)) + tell "\n" + tell "#define MIN_VERSION_" + tell (zManglePkgName z_root (zpkgName z_var0_pkg)) + tell "(major1,major2,minor) (\\\n" + tell " (major1) < " + tell (zpkgX z_var0_pkg) + tell " || \\\n" + tell " (major1) == " + tell (zpkgX z_var0_pkg) + tell " && (major2) < " + tell (zpkgY z_var0_pkg) + tell " || \\\n" + tell " (major1) == " + tell (zpkgX z_var0_pkg) + tell " && (major2) == " + tell (zpkgY z_var0_pkg) + tell " && (minor) <= " + tell (zpkgZ z_var0_pkg) + tell ")\n" + tell "#endif /* MIN_VERSION_" + tell (zManglePkgName z_root (zpkgName z_var0_pkg)) + tell " */\n" + tell "\n" + forM_ (zTools z_root) $ \z_var1_tool -> do + tell "/* tool " + tell (ztoolName z_var1_tool) + tell "-" + tell (prettyShow (ztoolVersion z_var1_tool)) + tell " */\n" + tell "#ifndef TOOL_VERSION_" + tell (zMangleStr z_root (ztoolName z_var1_tool)) + tell "\n" + tell "#define TOOL_VERSION_" + tell (zMangleStr z_root (ztoolName z_var1_tool)) + tell " \"" + tell (prettyShow (ztoolVersion z_var1_tool)) + tell "\"\n" + tell "#endif /* TOOL_VERSION_" + tell (zMangleStr z_root (ztoolName z_var1_tool)) + tell " */\n" + tell "#ifndef MIN_TOOL_VERSION_" + tell (zMangleStr z_root (ztoolName z_var1_tool)) + tell "\n" + tell "#define MIN_TOOL_VERSION_" + tell (zMangleStr z_root (ztoolName z_var1_tool)) + tell "(major1,major2,minor) (\\\n" + tell " (major1) < " + tell (ztoolX z_var1_tool) + tell " || \\\n" + tell " (major1) == " + tell (ztoolX z_var1_tool) + tell " && (major2) < " + tell (ztoolY z_var1_tool) + tell " || \\\n" + tell " (major1) == " + tell (ztoolX z_var1_tool) + tell " && (major2) == " + tell (ztoolY z_var1_tool) + tell " && (minor) <= " + tell (ztoolZ z_var1_tool) + tell ")\n" + tell "#endif /* MIN_TOOL_VERSION_" + tell (zMangleStr z_root (ztoolName z_var1_tool)) + tell " */\n" + tell "\n" + if (zNotNull z_root (zPackageKey z_root)) + then do + tell "#ifndef CURRENT_PACKAGE_KEY\n" + tell "#define CURRENT_PACKAGE_KEY \"" + tell (zPackageKey z_root) + tell "\"\n" + tell "#endif /* CURRENT_packageKey */\n" + return () + else do + return () + if (zNotNull z_root (zComponentId z_root)) + then do + tell "#ifndef CURRENT_COMPONENT_ID\n" + tell "#define CURRENT_COMPONENT_ID \"" + tell (zComponentId z_root) + tell "\"\n" + tell "#endif /* CURRENT_COMPONENT_ID */\n" + return () + else do + return () + tell "#ifndef CURRENT_PACKAGE_VERSION\n" + tell "#define CURRENT_PACKAGE_VERSION \"" + tell (prettyShow (zPackageVersion z_root)) + tell "\"\n" + tell "#endif /* CURRENT_PACKAGE_VERSION */\n" diff --git a/cabal/Cabal/src/Distribution/Simple/Build/PathsModule.hs b/cabal/Cabal/src/Distribution/Simple/Build/PathsModule.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/Build/PathsModule.hs @@ -0,0 +1,163 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Build.Macros +-- Copyright : Isaac Jones 2003-2005, +-- Ross Paterson 2006, +-- Duncan Coutts 2007-2008 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Generating the Paths_pkgname module. +-- +-- This is a module that Cabal generates for the benefit of packages. It +-- enables them to find their version number and find any installed data files +-- at runtime. This code should probably be split off into another module. +-- +module Distribution.Simple.Build.PathsModule ( + generatePathsModule, pkgPathEnvVar + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Package +import Distribution.PackageDescription +import Distribution.Simple.Compiler +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.Utils (shortRelativePath) +import Distribution.System +import Distribution.Version + +import qualified Distribution.Simple.Build.PathsModule.Z as Z + +-- ------------------------------------------------------------ +-- * Building Paths_.hs +-- ------------------------------------------------------------ + +generatePathsModule :: PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> String +generatePathsModule pkg_descr lbi clbi = Z.render Z.Z + { Z.zPackageName = packageName pkg_descr + , Z.zVersionDigits = show $ versionNumbers $ packageVersion pkg_descr + , Z.zSupportsCpp = supports_cpp + , Z.zSupportsNoRebindableSyntax = supports_rebindable_syntax + , Z.zAbsolute = absolute + , Z.zRelocatable = relocatable lbi + , Z.zIsWindows = isWindows + , Z.zIsI386 = buildArch == I386 + , Z.zIsX8664 = buildArch == X86_64 + , Z.zNot = not + , Z.zManglePkgName = showPkgName + + , Z.zPrefix = show flat_prefix + , Z.zBindir = zBindir + , Z.zLibdir = zLibdir + , Z.zDynlibdir = zDynlibdir + , Z.zDatadir = zDatadir + , Z.zLibexecdir = zLibexecdir + , Z.zSysconfdir = zSysconfdir + } + where + supports_cpp = supports_language_pragma + supports_rebindable_syntax = ghc_newer_than (mkVersion [7,0,1]) + supports_language_pragma = ghc_newer_than (mkVersion [6,6,1]) + + ghc_newer_than minVersion = + case compilerCompatVersion GHC (compiler lbi) of + Nothing -> False + Just version -> version `withinRange` orLaterVersion minVersion + + -- In several cases we cannot make relocatable installations + absolute = + hasLibs pkg_descr -- we can only make progs relocatable + || isNothing flat_bindirrel -- if the bin dir is an absolute path + || not (supportsRelocatableProgs (compilerFlavor (compiler lbi))) + + -- TODO: Here, and with zIsI386 & zIs8664 we should use TARGET platform + isWindows = case buildOS of + Windows -> True + _ -> False + + supportsRelocatableProgs GHC = isWindows + supportsRelocatableProgs GHCJS = isWindows + supportsRelocatableProgs _ = False + + cid = componentUnitId clbi + + InstallDirs + { bindir = flat_bindir + , libdir = flat_libdir + , dynlibdir = flat_dynlibdir + , datadir = flat_datadir + , libexecdir = flat_libexecdir + , sysconfdir = flat_sysconfdir + , prefix = flat_prefix + } = absoluteInstallCommandDirs pkg_descr lbi cid NoCopyDest + + InstallDirs + { bindir = flat_bindirrel + , libdir = flat_libdirrel + , dynlibdir = flat_dynlibdirrel + , datadir = flat_datadirrel + , libexecdir = flat_libexecdirrel + , sysconfdir = flat_sysconfdirrel + } = prefixRelativeComponentInstallDirs (packageId pkg_descr) lbi cid + + zBindir, zLibdir, zDynlibdir, zDatadir, zLibexecdir, zSysconfdir :: String + (zBindir, zLibdir, zDynlibdir, zDatadir, zLibexecdir, zSysconfdir) + | relocatable lbi = + ( show flat_bindir_reloc + , show flat_libdir_reloc + , show flat_dynlibdir_reloc + , show flat_datadir_reloc + , show flat_libexecdir_reloc + , show flat_sysconfdir_reloc + ) + | absolute = + ( show flat_bindir + , show flat_libdir + , show flat_dynlibdir + , show flat_datadir + , show flat_libexecdir + , show flat_sysconfdir + ) + | isWindows = + ( "maybe (error \"PathsModule.generate\") id (" ++ show flat_bindirrel ++ ")" + , mkGetDir flat_libdir flat_libdirrel + , mkGetDir flat_dynlibdir flat_dynlibdirrel + , mkGetDir flat_datadir flat_datadirrel + , mkGetDir flat_libexecdir flat_libexecdirrel + , mkGetDir flat_sysconfdir flat_sysconfdirrel + ) + | otherwise = + error "panic! generatePathsModule: should never happen" + + mkGetDir :: FilePath -> Maybe FilePath -> String + mkGetDir _ (Just dirrel) = "getPrefixDirRel " ++ show dirrel + mkGetDir dir Nothing = "return " ++ show dir + + flat_bindir_reloc = shortRelativePath flat_prefix flat_bindir + flat_libdir_reloc = shortRelativePath flat_prefix flat_libdir + flat_dynlibdir_reloc = shortRelativePath flat_prefix flat_dynlibdir + flat_datadir_reloc = shortRelativePath flat_prefix flat_datadir + flat_libexecdir_reloc = shortRelativePath flat_prefix flat_libexecdir + flat_sysconfdir_reloc = shortRelativePath flat_prefix flat_sysconfdir + +-- | Generates the name of the environment variable controlling the path +-- component of interest. +-- +-- Note: The format of these strings is part of Cabal's public API; +-- changing this function constitutes a *backwards-compatibility* break. +pkgPathEnvVar + :: PackageDescription + -> String -- ^ path component; one of \"bindir\", \"libdir\", -- \"datadir\", \"libexecdir\", or \"sysconfdir\" + -> String -- ^ environment variable name +pkgPathEnvVar pkg_descr var = + showPkgName (packageName pkg_descr) ++ "_" ++ var + +showPkgName :: PackageName -> String +showPkgName = map fixchar . unPackageName + +fixchar :: Char -> Char +fixchar '-' = '_' +fixchar c = c diff --git a/cabal/Cabal/src/Distribution/Simple/Build/PathsModule/Z.hs b/cabal/Cabal/src/Distribution/Simple/Build/PathsModule/Z.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/Build/PathsModule/Z.hs @@ -0,0 +1,318 @@ +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Simple.Build.PathsModule.Z (render, Z(..)) where +import Distribution.ZinzaPrelude +data Z + = Z {zPackageName :: PackageName, + zVersionDigits :: String, + zSupportsCpp :: Bool, + zSupportsNoRebindableSyntax :: Bool, + zAbsolute :: Bool, + zRelocatable :: Bool, + zIsWindows :: Bool, + zIsI386 :: Bool, + zIsX8664 :: Bool, + zPrefix :: FilePath, + zBindir :: FilePath, + zLibdir :: FilePath, + zDynlibdir :: FilePath, + zDatadir :: FilePath, + zLibexecdir :: FilePath, + zSysconfdir :: FilePath, + zNot :: (Bool -> Bool), + zManglePkgName :: (PackageName -> String)} + deriving Generic +render :: Z -> String +render z_root = execWriter $ do + if (zSupportsCpp z_root) + then do + tell "{-# LANGUAGE CPP #-}\n" + return () + else do + return () + if (zSupportsNoRebindableSyntax z_root) + then do + tell "{-# LANGUAGE NoRebindableSyntax #-}\n" + return () + else do + return () + if (zNot z_root (zAbsolute z_root)) + then do + tell "{-# LANGUAGE ForeignFunctionInterface #-}\n" + return () + else do + return () + tell "{-# OPTIONS_GHC -fno-warn-missing-import-lists #-}\n" + tell "{-# OPTIONS_GHC -w #-}\n" + tell "module Paths_" + tell (zManglePkgName z_root (zPackageName z_root)) + tell " (\n" + tell " version,\n" + tell " getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir,\n" + tell " getDataFileName, getSysconfDir\n" + tell " ) where\n" + tell "\n" + if (zNot z_root (zAbsolute z_root)) + then do + tell "import Foreign\n" + tell "import Foreign.C\n" + return () + else do + return () + tell "\n" + tell "import qualified Control.Exception as Exception\n" + tell "import qualified Data.List as List\n" + tell "import Data.Version (Version(..))\n" + tell "import System.Environment (getEnv)\n" + tell "import Prelude\n" + tell "\n" + if (zRelocatable z_root) + then do + tell "import System.Environment (getExecutablePath)\n" + return () + else do + return () + tell "\n" + if (zSupportsCpp z_root) + then do + tell "#if defined(VERSION_base)\n" + tell "\n" + tell "#if MIN_VERSION_base(4,0,0)\n" + tell "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n" + tell "#else\n" + tell "catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a\n" + tell "#endif\n" + tell "\n" + tell "#else\n" + tell "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n" + tell "#endif\n" + tell "catchIO = Exception.catch\n" + return () + else do + tell "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n" + tell "catchIO = Exception.catch\n" + return () + tell "\n" + tell "version :: Version\n" + tell "version = Version " + tell (zVersionDigits z_root) + tell " []\n" + tell "\n" + tell "getDataFileName :: FilePath -> IO FilePath\n" + tell "getDataFileName name = do\n" + tell " dir <- getDataDir\n" + tell " return (dir `joinFileName` name)\n" + tell "\n" + tell "getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath\n" + tell "\n" + tell "\n" + if (zRelocatable z_root) + then do + tell "\n" + tell "getPrefixDirReloc :: FilePath -> IO FilePath\n" + tell "getPrefixDirReloc dirRel = do\n" + tell " exePath <- getExecutablePath\n" + tell " let (dir,_) = splitFileName exePath\n" + tell " return ((dir `minusFileName` " + tell (zBindir z_root) + tell ") `joinFileName` dirRel)\n" + tell "\n" + tell "getBinDir = catchIO (getEnv \"" + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_bindir\") (\\_ -> getPrefixDirReloc $ " + tell (zBindir z_root) + tell ")\n" + tell "getLibDir = catchIO (getEnv \"" + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_libdir\") (\\_ -> getPrefixDirReloc $ " + tell (zLibdir z_root) + tell ")\n" + tell "getDynLibDir = catchIO (getEnv \"" + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_dynlibdir\") (\\_ -> getPrefixDirReloc $ " + tell (zDynlibdir z_root) + tell ")\n" + tell "getDataDir = catchIO (getEnv \"" + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_datadir\") (\\_ -> getPrefixDirReloc $ " + tell (zDatadir z_root) + tell ")\n" + tell "getLibexecDir = catchIO (getEnv \"" + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_libexecdir\") (\\_ -> getPrefixDirReloc $ " + tell (zLibexecdir z_root) + tell ")\n" + tell "getSysconfDir = catchIO (getEnv \"" + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_sysconfdir\") (\\_ -> getPrefixDirReloc $ " + tell (zSysconfdir z_root) + tell ")\n" + tell "\n" + return () + else do + if (zAbsolute z_root) + then do + tell "\n" + tell "bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath\n" + tell "bindir = " + tell (zBindir z_root) + tell "\n" + tell "libdir = " + tell (zLibdir z_root) + tell "\n" + tell "dynlibdir = " + tell (zDynlibdir z_root) + tell "\n" + tell "datadir = " + tell (zDatadir z_root) + tell "\n" + tell "libexecdir = " + tell (zLibexecdir z_root) + tell "\n" + tell "sysconfdir = " + tell (zSysconfdir z_root) + tell "\n" + tell "\n" + tell "getBinDir = catchIO (getEnv \"" + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_bindir\") (\\_ -> return bindir)\n" + tell "getLibDir = catchIO (getEnv \"" + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_libdir\") (\\_ -> return libdir)\n" + tell "getDynLibDir = catchIO (getEnv \"" + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_dynlibdir\") (\\_ -> return dynlibdir)\n" + tell "getDataDir = catchIO (getEnv \"" + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_datadir\") (\\_ -> return datadir)\n" + tell "getLibexecDir = catchIO (getEnv \"" + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_libexecdir\") (\\_ -> return libexecdir)\n" + tell "getSysconfDir = catchIO (getEnv \"" + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_sysconfdir\") (\\_ -> return sysconfdir)\n" + tell "\n" + return () + else do + if (zIsWindows z_root) + then do + tell "\n" + tell "prefix :: FilePath\n" + tell "prefix = " + tell (zPrefix z_root) + tell "\n" + tell "\n" + tell "getBinDir = getPrefixDirRel $ " + tell (zBindir z_root) + tell "\n" + tell "getLibDir = " + tell (zLibdir z_root) + tell "\n" + tell "getDynLibDir = " + tell (zDynlibdir z_root) + tell "\n" + tell "getDataDir = catchIO (getEnv \"" + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_datadir\") (\\_ -> " + tell (zDatadir z_root) + tell ")\n" + tell "getLibexecDir = " + tell (zLibexecdir z_root) + tell "\n" + tell "getSysconfDir = " + tell (zSysconfdir z_root) + tell "\n" + tell "\n" + tell "getPrefixDirRel :: FilePath -> IO FilePath\n" + tell "getPrefixDirRel dirRel = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.\n" + tell " where\n" + tell " try_size size = allocaArray (fromIntegral size) $ \\buf -> do\n" + tell " ret <- c_GetModuleFileName nullPtr buf size\n" + tell " case ret of\n" + tell " 0 -> return (prefix `joinFileName` dirRel)\n" + tell " _ | ret < size -> do\n" + tell " exePath <- peekCWString buf\n" + tell " let (bindir,_) = splitFileName exePath\n" + tell " return ((bindir `minusFileName` " + tell (zBindir z_root) + tell ") `joinFileName` dirRel)\n" + tell " | otherwise -> try_size (size * 2)\n" + tell "\n" + if (zIsI386 z_root) + then do + tell "foreign import stdcall unsafe \"windows.h GetModuleFileNameW\"\n" + tell " c_GetModuleFileName :: Ptr () -> CWString -> Int32 -> IO Int32\n" + return () + else do + if (zIsX8664 z_root) + then do + tell "foreign import ccall unsafe \"windows.h GetModuleFileNameW\"\n" + tell " c_GetModuleFileName :: Ptr () -> CWString -> Int32 -> IO Int32\n" + return () + else do + tell "-- win32 supported only with I386, X86_64\n" + tell "c_GetModuleFileName :: Ptr () -> CWString -> Int32 -> IO Int32\n" + tell "c_GetModuleFileName = _\n" + return () + return () + tell "\n" + return () + else do + tell "\n" + tell "notRelocAbsoluteOrWindows :: ()\n" + tell "notRelocAbsoluteOrWindows = _\n" + tell "\n" + return () + return () + return () + tell "\n" + tell "\n" + if (zNot z_root (zAbsolute z_root)) + then do + tell "minusFileName :: FilePath -> String -> FilePath\n" + tell "minusFileName dir \"\" = dir\n" + tell "minusFileName dir \".\" = dir\n" + tell "minusFileName dir suffix =\n" + tell " minusFileName (fst (splitFileName dir)) (fst (splitFileName suffix))\n" + tell "\n" + tell "splitFileName :: FilePath -> (String, String)\n" + tell "splitFileName p = (reverse (path2++drive), reverse fname)\n" + tell " where\n" + tell " (path,drive) = case p of\n" + tell " (c:':':p') -> (reverse p',[':',c])\n" + tell " _ -> (reverse p ,\"\")\n" + tell " (fname,path1) = break isPathSeparator path\n" + tell " path2 = case path1 of\n" + tell " [] -> \".\"\n" + tell " [_] -> path1 -- don't remove the trailing slash if\n" + tell " -- there is only one character\n" + tell " (c:path') | isPathSeparator c -> path'\n" + tell " _ -> path1\n" + return () + else do + return () + tell "\n" + tell "joinFileName :: String -> String -> FilePath\n" + tell "joinFileName \"\" fname = fname\n" + tell "joinFileName \".\" fname = fname\n" + tell "joinFileName dir \"\" = dir\n" + tell "joinFileName dir fname\n" + tell " | isPathSeparator (List.last dir) = dir ++ fname\n" + tell " | otherwise = dir ++ pathSeparator : fname\n" + tell "\n" + tell "pathSeparator :: Char\n" + if (zIsWindows z_root) + then do + tell "pathSeparator = '\\\\'\n" + return () + else do + tell "pathSeparator = '/'\n" + return () + tell "\n" + tell "isPathSeparator :: Char -> Bool\n" + if (zIsWindows z_root) + then do + tell "isPathSeparator c = c == '/' || c == '\\\\'\n" + return () + else do + tell "isPathSeparator c = c == '/'\n" + return () diff --git a/cabal/Cabal/src/Distribution/Simple/BuildPaths.hs b/cabal/Cabal/src/Distribution/Simple/BuildPaths.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/BuildPaths.hs @@ -0,0 +1,261 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.BuildPaths +-- Copyright : Isaac Jones 2003-2004, +-- Duncan Coutts 2008 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- A bunch of dirs, paths and file names used for intermediate build steps. +-- + +module Distribution.Simple.BuildPaths ( + defaultDistPref, srcPref, + buildInfoPref, haddockDirName, hscolourPref, haddockPref, + autogenPackageModulesDir, + autogenComponentModulesDir, + + autogenPathsModuleName, + cppHeaderName, + haddockName, + + mkGenericStaticLibName, + mkLibName, + mkProfLibName, + mkGenericSharedLibName, + mkSharedLibName, + mkStaticLibName, + mkGenericSharedBundledLibName, + + exeExtension, + objExtension, + dllExtension, + staticLibExtension, + -- * Source files & build directories + getSourceFiles, getLibSourceFiles, getExeSourceFiles, + getFLibSourceFiles, exeBuildDir, flibBuildDir, + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Package +import Distribution.ModuleName as ModuleName +import Distribution.Compiler +import Distribution.PackageDescription +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.Setup +import Distribution.Pretty +import Distribution.System +import Distribution.Verbosity +import Distribution.Simple.Utils +import Distribution.Utils.Path + +import Data.List (stripPrefix) +import System.FilePath ((), (<.>), normalise) + +-- --------------------------------------------------------------------------- +-- Build directories and files + +srcPref :: FilePath -> FilePath +srcPref distPref = distPref "src" + +hscolourPref :: HaddockTarget -> FilePath -> PackageDescription -> FilePath +hscolourPref = haddockPref + +-- | Build info json file, generated in every build +buildInfoPref :: FilePath -> FilePath +buildInfoPref distPref = distPref "build-info.json" + +-- | This is the name of the directory in which the generated haddocks +-- should be stored. It does not include the @/doc/html@ prefix. +haddockDirName :: HaddockTarget -> PackageDescription -> FilePath +haddockDirName ForDevelopment = prettyShow . packageName +haddockDirName ForHackage = (++ "-docs") . prettyShow . packageId + +-- | The directory to which generated haddock documentation should be written. +haddockPref :: HaddockTarget -> FilePath -> PackageDescription -> FilePath +haddockPref haddockTarget distPref pkg_descr + = distPref "doc" "html" haddockDirName haddockTarget pkg_descr + +-- | The directory in which we put auto-generated modules for EVERY +-- component in the package. +autogenPackageModulesDir :: LocalBuildInfo -> String +autogenPackageModulesDir lbi = buildDir lbi "global-autogen" + +-- | The directory in which we put auto-generated modules for a +-- particular component. +autogenComponentModulesDir :: LocalBuildInfo -> ComponentLocalBuildInfo -> String +autogenComponentModulesDir lbi clbi = componentBuildDir lbi clbi "autogen" +-- NB: Look at 'checkForeignDeps' for where a simplified version of this +-- has been copy-pasted. + +cppHeaderName :: String +cppHeaderName = "cabal_macros.h" + +-- | The name of the auto-generated Paths_* module associated with a package +autogenPathsModuleName :: PackageDescription -> ModuleName +autogenPathsModuleName pkg_descr = + ModuleName.fromString $ + "Paths_" ++ map fixchar (prettyShow (packageName pkg_descr)) + where fixchar '-' = '_' + fixchar c = c + +haddockName :: PackageDescription -> FilePath +haddockName pkg_descr = prettyShow (packageName pkg_descr) <.> "haddock" + +-- ----------------------------------------------------------------------------- +-- Source File helper + +getLibSourceFiles :: Verbosity + -> LocalBuildInfo + -> Library + -> ComponentLocalBuildInfo + -> IO [(ModuleName.ModuleName, FilePath)] +getLibSourceFiles verbosity lbi lib clbi = getSourceFiles verbosity searchpaths modules + where + bi = libBuildInfo lib + modules = allLibModules lib clbi + searchpaths = componentBuildDir lbi clbi : map getSymbolicPath (hsSourceDirs bi) ++ + [ autogenComponentModulesDir lbi clbi + , autogenPackageModulesDir lbi ] + +getExeSourceFiles :: Verbosity + -> LocalBuildInfo + -> Executable + -> ComponentLocalBuildInfo + -> IO [(ModuleName.ModuleName, FilePath)] +getExeSourceFiles verbosity lbi exe clbi = do + moduleFiles <- getSourceFiles verbosity searchpaths modules + srcMainPath <- findFileEx verbosity (map getSymbolicPath $ hsSourceDirs bi) (modulePath exe) + return ((ModuleName.main, srcMainPath) : moduleFiles) + where + bi = buildInfo exe + modules = otherModules bi + searchpaths = autogenComponentModulesDir lbi clbi + : autogenPackageModulesDir lbi + : exeBuildDir lbi exe : map getSymbolicPath (hsSourceDirs bi) + +getFLibSourceFiles :: Verbosity + -> LocalBuildInfo + -> ForeignLib + -> ComponentLocalBuildInfo + -> IO [(ModuleName.ModuleName, FilePath)] +getFLibSourceFiles verbosity lbi flib clbi = getSourceFiles verbosity searchpaths modules + where + bi = foreignLibBuildInfo flib + modules = otherModules bi + searchpaths = autogenComponentModulesDir lbi clbi + : autogenPackageModulesDir lbi + : flibBuildDir lbi flib : map getSymbolicPath (hsSourceDirs bi) + +getSourceFiles :: Verbosity -> [FilePath] + -> [ModuleName.ModuleName] + -> IO [(ModuleName.ModuleName, FilePath)] +getSourceFiles verbosity dirs modules = flip traverse modules $ \m -> fmap ((,) m) $ + findFileWithExtension ["hs", "lhs", "hsig", "lhsig"] dirs (ModuleName.toFilePath m) + >>= maybe (notFound m) (return . normalise) + where + notFound module_ = die' verbosity $ "can't find source for module " ++ prettyShow module_ + +-- | The directory where we put build results for an executable +exeBuildDir :: LocalBuildInfo -> Executable -> FilePath +exeBuildDir lbi exe = buildDir lbi nm nm ++ "-tmp" + where + nm = unUnqualComponentName $ exeName exe + +-- | The directory where we put build results for a foreign library +flibBuildDir :: LocalBuildInfo -> ForeignLib -> FilePath +flibBuildDir lbi flib = buildDir lbi nm nm ++ "-tmp" + where + nm = unUnqualComponentName $ foreignLibName flib + +-- --------------------------------------------------------------------------- +-- Library file names + +-- | Create a library name for a static library from a given name. +-- Prepends @lib@ and appends the static library extension (@.a@). +mkGenericStaticLibName :: String -> String +mkGenericStaticLibName lib = "lib" ++ lib <.> "a" + +mkLibName :: UnitId -> String +mkLibName lib = mkGenericStaticLibName (getHSLibraryName lib) + +mkProfLibName :: UnitId -> String +mkProfLibName lib = mkGenericStaticLibName (getHSLibraryName lib ++ "_p") + +-- | Create a library name for a shared library from a given name. +-- Prepends @lib@ and appends the @-\\@ +-- as well as the shared library extension. +mkGenericSharedLibName :: Platform -> CompilerId -> String -> String +mkGenericSharedLibName platform (CompilerId compilerFlavor compilerVersion) lib + = mconcat [ "lib", lib, "-", comp <.> dllExtension platform ] + where comp = prettyShow compilerFlavor ++ prettyShow compilerVersion + +-- Implement proper name mangling for dynamical shared objects +-- @libHS\-\\@ +-- e.g. @libHSbase-2.1-ghc6.6.1.so@ +mkSharedLibName :: Platform -> CompilerId -> UnitId -> String +mkSharedLibName platform comp lib + = mkGenericSharedLibName platform comp (getHSLibraryName lib) + +-- Static libs are named the same as shared libraries, only with +-- a different extension. +mkStaticLibName :: Platform -> CompilerId -> UnitId -> String +mkStaticLibName platform (CompilerId compilerFlavor compilerVersion) lib + = "lib" ++ getHSLibraryName lib ++ "-" ++ comp <.> staticLibExtension platform + where comp = prettyShow compilerFlavor ++ prettyShow compilerVersion + +-- | Create a library name for a bundled shared library from a given name. +-- This matches the naming convention for shared libraries as implemented in +-- GHC's packageHsLibs function in the Packages module. +-- If the given name is prefixed with HS, then this prepends 'lib' and appends +-- the compiler flavour/version and shared library extension e.g.: +-- "HSrts-1.0" -> "libHSrts-1.0-ghc8.7.20190109.so" +-- Otherwise the given name should be prefixed with 'C', then this strips the +-- 'C', prepends 'lib' and appends the shared library extension e.g.: +-- "Cffi" -> "libffi.so" +mkGenericSharedBundledLibName :: Platform -> CompilerId -> String -> String +mkGenericSharedBundledLibName platform comp lib + | "HS" `isPrefixOf` lib + = mkGenericSharedLibName platform comp lib + | Just lib' <- stripPrefix "C" lib + = "lib" ++ lib' <.> dllExtension platform + | otherwise + = error ("Don't understand library name " ++ lib) + +-- ------------------------------------------------------------ +-- * Platform file extensions +-- ------------------------------------------------------------ + +-- | Default extension for executable files on the current platform. +-- (typically @\"\"@ on Unix and @\"exe\"@ on Windows or OS\/2) +exeExtension :: Platform -> String +exeExtension (Platform _arch os) = case os of + Windows -> "exe" + _ -> "" + +-- | Extension for object files. For GHC the extension is @\"o\"@. +objExtension :: String +objExtension = "o" + +-- | Extension for dynamically linked (or shared) libraries +-- (typically @\"so\"@ on Unix and @\"dll\"@ on Windows) +dllExtension :: Platform -> String +dllExtension (Platform _arch os)= case os of + Windows -> "dll" + OSX -> "dylib" + _ -> "so" + +-- | Extension for static libraries +-- +-- TODO: Here, as well as in dllExtension, it's really the target OS that we're +-- interested in, not the build OS. +staticLibExtension :: Platform -> String +staticLibExtension (Platform _arch os) = case os of + Windows -> "lib" + _ -> "a" diff --git a/cabal/Cabal/src/Distribution/Simple/BuildTarget.hs b/cabal/Cabal/src/Distribution/Simple/BuildTarget.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/BuildTarget.hs @@ -0,0 +1,1064 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.BuildTargets +-- Copyright : (c) Duncan Coutts 2012 +-- License : BSD-like +-- +-- Maintainer : duncan@community.haskell.org +-- +-- Handling for user-specified build targets +----------------------------------------------------------------------------- +module Distribution.Simple.BuildTarget ( + -- * Main interface + readTargetInfos, + readBuildTargets, -- in case you don't have LocalBuildInfo + + -- * Build targets + BuildTarget(..), + showBuildTarget, + QualLevel(..), + buildTargetComponentName, + + -- * Parsing user build targets + UserBuildTarget, + readUserBuildTargets, + showUserBuildTarget, + UserBuildTargetProblem(..), + reportUserBuildTargetProblems, + + -- * Resolving build targets + resolveBuildTargets, + BuildTargetProblem(..), + reportBuildTargetProblems, + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Types.TargetInfo +import Distribution.Types.LocalBuildInfo +import Distribution.Types.ComponentRequestedSpec +import Distribution.Types.ForeignLib +import Distribution.Types.UnqualComponentName + +import Distribution.Package +import Distribution.PackageDescription +import Distribution.ModuleName +import Distribution.Simple.LocalBuildInfo +import Distribution.Pretty +import Distribution.Parsec +import Distribution.Simple.Utils +import Distribution.Verbosity +import Distribution.Utils.Path + +import qualified Distribution.Compat.CharParsing as P + +import Control.Monad ( msum ) +import Data.List ( stripPrefix, groupBy ) +import qualified Data.List.NonEmpty as NE +import System.FilePath as FilePath + ( dropExtension, normalise, splitDirectories, joinPath, splitPath + , hasTrailingPathSeparator ) +import System.Directory ( doesFileExist, doesDirectoryExist ) +import qualified Data.Map as Map + +-- | Take a list of 'String' build targets, and parse and validate them +-- into actual 'TargetInfo's to be built/registered/whatever. +readTargetInfos :: Verbosity -> PackageDescription -> LocalBuildInfo -> [String] -> IO [TargetInfo] +readTargetInfos verbosity pkg_descr lbi args = do + build_targets <- readBuildTargets verbosity pkg_descr args + checkBuildTargets verbosity pkg_descr lbi build_targets + +-- ------------------------------------------------------------ +-- * User build targets +-- ------------------------------------------------------------ + +-- | Various ways that a user may specify a build target. +-- +data UserBuildTarget = + + -- | A target specified by a single name. This could be a component + -- module or file. + -- + -- > cabal build foo + -- > cabal build Data.Foo + -- > cabal build Data/Foo.hs Data/Foo.hsc + -- + UserBuildTargetSingle String + + -- | A target specified by a qualifier and name. This could be a component + -- name qualified by the component namespace kind, or a module or file + -- qualified by the component name. + -- + -- > cabal build lib:foo exe:foo + -- > cabal build foo:Data.Foo + -- > cabal build foo:Data/Foo.hs + -- + | UserBuildTargetDouble String String + + -- | A fully qualified target, either a module or file qualified by a + -- component name with the component namespace kind. + -- + -- > cabal build lib:foo:Data/Foo.hs exe:foo:Data/Foo.hs + -- > cabal build lib:foo:Data.Foo exe:foo:Data.Foo + -- + | UserBuildTargetTriple String String String + deriving (Show, Eq, Ord) + + +-- ------------------------------------------------------------ +-- * Resolved build targets +-- ------------------------------------------------------------ + +-- | A fully resolved build target. +-- +data BuildTarget = + + -- | A specific component + -- + BuildTargetComponent ComponentName + + -- | A specific module within a specific component. + -- + | BuildTargetModule ComponentName ModuleName + + -- | A specific file within a specific component. + -- + | BuildTargetFile ComponentName FilePath + deriving (Eq, Show, Generic) + +instance Binary BuildTarget + +buildTargetComponentName :: BuildTarget -> ComponentName +buildTargetComponentName (BuildTargetComponent cn) = cn +buildTargetComponentName (BuildTargetModule cn _) = cn +buildTargetComponentName (BuildTargetFile cn _) = cn + +-- | Read a list of user-supplied build target strings and resolve them to +-- 'BuildTarget's according to a 'PackageDescription'. If there are problems +-- with any of the targets e.g. they don't exist or are misformatted, throw an +-- 'IOException'. +readBuildTargets :: Verbosity -> PackageDescription -> [String] -> IO [BuildTarget] +readBuildTargets verbosity pkg targetStrs = do + let (uproblems, utargets) = readUserBuildTargets targetStrs + reportUserBuildTargetProblems verbosity uproblems + + utargets' <- traverse checkTargetExistsAsFile utargets + + let (bproblems, btargets) = resolveBuildTargets pkg utargets' + reportBuildTargetProblems verbosity bproblems + + return btargets + +checkTargetExistsAsFile :: UserBuildTarget -> IO (UserBuildTarget, Bool) +checkTargetExistsAsFile t = do + fexists <- existsAsFile (fileComponentOfTarget t) + return (t, fexists) + + where + existsAsFile f = do + exists <- doesFileExist f + case splitPath f of + (d:_) | hasTrailingPathSeparator d -> doesDirectoryExist d + (d:_:_) | not exists -> doesDirectoryExist d + _ -> return exists + + fileComponentOfTarget (UserBuildTargetSingle s1) = s1 + fileComponentOfTarget (UserBuildTargetDouble _ s2) = s2 + fileComponentOfTarget (UserBuildTargetTriple _ _ s3) = s3 + + +-- ------------------------------------------------------------ +-- * Parsing user targets +-- ------------------------------------------------------------ + +readUserBuildTargets :: [String] -> ([UserBuildTargetProblem] + ,[UserBuildTarget]) +readUserBuildTargets = partitionEithers . map readUserBuildTarget + +-- | +-- +-- >>> readUserBuildTarget "comp" +-- Right (UserBuildTargetSingle "comp") +-- +-- >>> readUserBuildTarget "lib:comp" +-- Right (UserBuildTargetDouble "lib" "comp") +-- +-- >>> readUserBuildTarget "pkg:lib:comp" +-- Right (UserBuildTargetTriple "pkg" "lib" "comp") +-- +-- >>> readUserBuildTarget "\"comp\"" +-- Right (UserBuildTargetSingle "comp") +-- +-- >>> readUserBuildTarget "lib:\"comp\"" +-- Right (UserBuildTargetDouble "lib" "comp") +-- +-- >>> readUserBuildTarget "pkg:lib:\"comp\"" +-- Right (UserBuildTargetTriple "pkg" "lib" "comp") +-- +-- >>> readUserBuildTarget "pkg:lib:comp:more" +-- Left (UserBuildTargetUnrecognised "pkg:lib:comp:more") +-- +-- >>> readUserBuildTarget "pkg:\"lib\":comp" +-- Left (UserBuildTargetUnrecognised "pkg:\"lib\":comp") +-- +readUserBuildTarget :: String -> Either UserBuildTargetProblem + UserBuildTarget +readUserBuildTarget targetstr = + case explicitEitherParsec parseTargetApprox targetstr of + Left _ -> Left (UserBuildTargetUnrecognised targetstr) + Right tgt -> Right tgt + + where + parseTargetApprox :: CabalParsing m => m UserBuildTarget + parseTargetApprox = do + -- read one, two, or three tokens, where last could be "hs-string" + ts <- tokens + return $ case ts of + (a, Nothing) -> UserBuildTargetSingle a + (a, Just (b, Nothing)) -> UserBuildTargetDouble a b + (a, Just (b, Just c)) -> UserBuildTargetTriple a b c + + tokens :: CabalParsing m => m (String, Maybe (String, Maybe String)) + tokens = (\s -> (s, Nothing)) <$> parsecHaskellString + <|> (,) <$> token <*> P.optional (P.char ':' *> tokens2) + + tokens2 :: CabalParsing m => m (String, Maybe String) + tokens2 = (\s -> (s, Nothing)) <$> parsecHaskellString + <|> (,) <$> token <*> P.optional (P.char ':' *> (parsecHaskellString <|> token)) + + token :: CabalParsing m => m String + token = P.munch1 (\x -> not (isSpace x) && x /= ':') + +data UserBuildTargetProblem + = UserBuildTargetUnrecognised String + deriving Show + +reportUserBuildTargetProblems :: Verbosity -> [UserBuildTargetProblem] -> IO () +reportUserBuildTargetProblems verbosity problems = do + case [ target | UserBuildTargetUnrecognised target <- problems ] of + [] -> return () + target -> + die' verbosity $ unlines + [ "Unrecognised build target '" ++ name ++ "'." + | name <- target ] + ++ "Examples:\n" + ++ " - build foo -- component name " + ++ "(library, executable, test-suite or benchmark)\n" + ++ " - build Data.Foo -- module name\n" + ++ " - build Data/Foo.hsc -- file name\n" + ++ " - build lib:foo exe:foo -- component qualified by kind\n" + ++ " - build foo:Data.Foo -- module qualified by component\n" + ++ " - build foo:Data/Foo.hsc -- file qualified by component" + +showUserBuildTarget :: UserBuildTarget -> String +showUserBuildTarget = intercalate ":" . getComponents + where + getComponents (UserBuildTargetSingle s1) = [s1] + getComponents (UserBuildTargetDouble s1 s2) = [s1,s2] + getComponents (UserBuildTargetTriple s1 s2 s3) = [s1,s2,s3] + +-- | Unless you use 'QL1', this function is PARTIAL; +-- use 'showBuildTarget' instead. +showBuildTarget' :: QualLevel -> PackageId -> BuildTarget -> String +showBuildTarget' ql pkgid bt = + showUserBuildTarget (renderBuildTarget ql bt pkgid) + +-- | Unambiguously render a 'BuildTarget', so that it can +-- be parsed in all situations. +showBuildTarget :: PackageId -> BuildTarget -> String +showBuildTarget pkgid t = + showBuildTarget' (qlBuildTarget t) pkgid t + where + qlBuildTarget BuildTargetComponent{} = QL2 + qlBuildTarget _ = QL3 + + +-- ------------------------------------------------------------ +-- * Resolving user targets to build targets +-- ------------------------------------------------------------ + +{- +stargets = + [ BuildTargetComponent (CExeName "foo") + , BuildTargetModule (CExeName "foo") (mkMn "Foo") + , BuildTargetModule (CExeName "tst") (mkMn "Foo") + ] + where + mkMn :: String -> ModuleName + mkMn = fromJust . simpleParse + +ex_pkgid :: PackageIdentifier +Just ex_pkgid = simpleParse "thelib" +-} + +-- | Given a bunch of user-specified targets, try to resolve what it is they +-- refer to. +-- +resolveBuildTargets :: PackageDescription + -> [(UserBuildTarget, Bool)] + -> ([BuildTargetProblem], [BuildTarget]) +resolveBuildTargets pkg = partitionEithers + . map (uncurry (resolveBuildTarget pkg)) + +resolveBuildTarget :: PackageDescription -> UserBuildTarget -> Bool + -> Either BuildTargetProblem BuildTarget +resolveBuildTarget pkg userTarget fexists = + case findMatch (matchBuildTarget pkg userTarget fexists) of + Unambiguous target -> Right target + Ambiguous targets -> Left (BuildTargetAmbiguous userTarget targets') + where targets' = disambiguateBuildTargets + (packageId pkg) + userTarget + targets + None errs -> Left (classifyMatchErrors errs) + + where + classifyMatchErrors errs + | Just expected' <- NE.nonEmpty expected + = let (things, got:|_) = NE.unzip expected' in + BuildTargetExpected userTarget (NE.toList things) got + | not (null nosuch) = BuildTargetNoSuch userTarget nosuch + | otherwise = error $ "resolveBuildTarget: internal error in matching" + where + expected = [ (thing, got) | MatchErrorExpected thing got <- errs ] + nosuch = [ (thing, got) | MatchErrorNoSuch thing got <- errs ] + + +data BuildTargetProblem + = BuildTargetExpected UserBuildTarget [String] String + -- ^ [expected thing] (actually got) + | BuildTargetNoSuch UserBuildTarget [(String, String)] + -- ^ [(no such thing, actually got)] + | BuildTargetAmbiguous UserBuildTarget [(UserBuildTarget, BuildTarget)] + deriving Show + + +disambiguateBuildTargets :: PackageId -> UserBuildTarget -> [BuildTarget] + -> [(UserBuildTarget, BuildTarget)] +disambiguateBuildTargets pkgid original = + disambiguate (userTargetQualLevel original) + where + disambiguate ql ts + | null amb = unamb + | otherwise = unamb ++ disambiguate (succ ql) amb + where + (amb, unamb) = step ql ts + + userTargetQualLevel (UserBuildTargetSingle _ ) = QL1 + userTargetQualLevel (UserBuildTargetDouble _ _ ) = QL2 + userTargetQualLevel (UserBuildTargetTriple _ _ _) = QL3 + + step :: QualLevel -> [BuildTarget] + -> ([BuildTarget], [(UserBuildTarget, BuildTarget)]) + step ql = (\(amb, unamb) -> (map snd $ concat amb, concat unamb)) + . partition (\g -> length g > 1) + . groupBy (equating fst) + . sortBy (comparing fst) + . map (\t -> (renderBuildTarget ql t pkgid, t)) + +data QualLevel = QL1 | QL2 | QL3 + deriving (Enum, Show) + +renderBuildTarget :: QualLevel -> BuildTarget -> PackageId -> UserBuildTarget +renderBuildTarget ql target pkgid = + case ql of + QL1 -> UserBuildTargetSingle s1 where s1 = single target + QL2 -> UserBuildTargetDouble s1 s2 where (s1, s2) = double target + QL3 -> UserBuildTargetTriple s1 s2 s3 where (s1, s2, s3) = triple target + + where + single (BuildTargetComponent cn ) = dispCName cn + single (BuildTargetModule _ m) = prettyShow m + single (BuildTargetFile _ f) = f + + double (BuildTargetComponent cn ) = (dispKind cn, dispCName cn) + double (BuildTargetModule cn m) = (dispCName cn, prettyShow m) + double (BuildTargetFile cn f) = (dispCName cn, f) + + triple (BuildTargetComponent _ ) = error "triple BuildTargetComponent" + triple (BuildTargetModule cn m) = (dispKind cn, dispCName cn, prettyShow m) + triple (BuildTargetFile cn f) = (dispKind cn, dispCName cn, f) + + dispCName = componentStringName pkgid + dispKind = showComponentKindShort . componentKind + +reportBuildTargetProblems :: Verbosity -> [BuildTargetProblem] -> IO () +reportBuildTargetProblems verbosity problems = do + + case [ (t, e, g) | BuildTargetExpected t e g <- problems ] of + [] -> return () + targets -> + die' verbosity $ unlines + [ "Unrecognised build target '" ++ showUserBuildTarget target + ++ "'.\n" + ++ "Expected a " ++ intercalate " or " expected + ++ ", rather than '" ++ got ++ "'." + | (target, expected, got) <- targets ] + + case [ (t, e) | BuildTargetNoSuch t e <- problems ] of + [] -> return () + targets -> + die' verbosity $ unlines + [ "Unknown build target '" ++ showUserBuildTarget target + ++ "'.\nThere is no " + ++ intercalate " or " [ mungeThing thing ++ " '" ++ got ++ "'" + | (thing, got) <- nosuch ] ++ "." + | (target, nosuch) <- targets ] + where + mungeThing "file" = "file target" + mungeThing thing = thing + + case [ (t, ts) | BuildTargetAmbiguous t ts <- problems ] of + [] -> return () + targets -> + die' verbosity $ unlines + [ "Ambiguous build target '" ++ showUserBuildTarget target + ++ "'. It could be:\n " + ++ unlines [ " "++ showUserBuildTarget ut ++ + " (" ++ showBuildTargetKind bt ++ ")" + | (ut, bt) <- amb ] + | (target, amb) <- targets ] + + where + showBuildTargetKind (BuildTargetComponent _ ) = "component" + showBuildTargetKind (BuildTargetModule _ _) = "module" + showBuildTargetKind (BuildTargetFile _ _) = "file" + + +---------------------------------- +-- Top level BuildTarget matcher +-- + +matchBuildTarget :: PackageDescription + -> UserBuildTarget -> Bool -> Match BuildTarget +matchBuildTarget pkg = \utarget fexists -> + case utarget of + UserBuildTargetSingle str1 -> + matchBuildTarget1 cinfo str1 fexists + + UserBuildTargetDouble str1 str2 -> + matchBuildTarget2 cinfo str1 str2 fexists + + UserBuildTargetTriple str1 str2 str3 -> + matchBuildTarget3 cinfo str1 str2 str3 fexists + where + cinfo = pkgComponentInfo pkg + +matchBuildTarget1 :: [ComponentInfo] -> String -> Bool -> Match BuildTarget +matchBuildTarget1 cinfo str1 fexists = + matchComponent1 cinfo str1 + `matchPlusShadowing` matchModule1 cinfo str1 + `matchPlusShadowing` matchFile1 cinfo str1 fexists + + +matchBuildTarget2 :: [ComponentInfo] -> String -> String -> Bool + -> Match BuildTarget +matchBuildTarget2 cinfo str1 str2 fexists = + matchComponent2 cinfo str1 str2 + `matchPlusShadowing` matchModule2 cinfo str1 str2 + `matchPlusShadowing` matchFile2 cinfo str1 str2 fexists + + +matchBuildTarget3 :: [ComponentInfo] -> String -> String -> String -> Bool + -> Match BuildTarget +matchBuildTarget3 cinfo str1 str2 str3 fexists = + matchModule3 cinfo str1 str2 str3 + `matchPlusShadowing` matchFile3 cinfo str1 str2 str3 fexists + + +data ComponentInfo = ComponentInfo { + cinfoName :: ComponentName, + cinfoStrName :: ComponentStringName, + cinfoSrcDirs :: [FilePath], + cinfoModules :: [ModuleName], + cinfoHsFiles :: [FilePath], -- other hs files (like main.hs) + cinfoAsmFiles:: [FilePath], + cinfoCmmFiles:: [FilePath], + cinfoCFiles :: [FilePath], + cinfoCxxFiles:: [FilePath], + cinfoJsFiles :: [FilePath] + } + +type ComponentStringName = String + +pkgComponentInfo :: PackageDescription -> [ComponentInfo] +pkgComponentInfo pkg = + [ ComponentInfo { + cinfoName = componentName c, + cinfoStrName = componentStringName pkg (componentName c), + cinfoSrcDirs = map getSymbolicPath $ hsSourceDirs bi, + cinfoModules = componentModules c, + cinfoHsFiles = componentHsFiles c, + cinfoAsmFiles= asmSources bi, + cinfoCmmFiles= cmmSources bi, + cinfoCFiles = cSources bi, + cinfoCxxFiles= cxxSources bi, + cinfoJsFiles = jsSources bi + } + | c <- pkgComponents pkg + , let bi = componentBuildInfo c ] + +componentStringName :: Package pkg => pkg -> ComponentName -> ComponentStringName +componentStringName pkg (CLibName LMainLibName ) = prettyShow (packageName pkg) +componentStringName _ (CLibName (LSubLibName name)) = unUnqualComponentName name +componentStringName _ (CFLibName name) = unUnqualComponentName name +componentStringName _ (CExeName name) = unUnqualComponentName name +componentStringName _ (CTestName name) = unUnqualComponentName name +componentStringName _ (CBenchName name) = unUnqualComponentName name + +componentModules :: Component -> [ModuleName] +-- TODO: Use of 'explicitLibModules' here is a bit wrong: +-- a user could very well ask to build a specific signature +-- that was inherited from other packages. To fix this +-- we have to plumb 'LocalBuildInfo' through this code. +-- Fortunately, this is only used by 'pkgComponentInfo' +-- Please don't export this function unless you plan on fixing +-- this. +componentModules (CLib lib) = explicitLibModules lib +componentModules (CFLib flib) = foreignLibModules flib +componentModules (CExe exe) = exeModules exe +componentModules (CTest test) = testModules test +componentModules (CBench bench) = benchmarkModules bench + +componentHsFiles :: Component -> [FilePath] +componentHsFiles (CExe exe) = [modulePath exe] +componentHsFiles (CTest TestSuite { + testInterface = TestSuiteExeV10 _ mainfile + }) = [mainfile] +componentHsFiles (CBench Benchmark { + benchmarkInterface = BenchmarkExeV10 _ mainfile + }) = [mainfile] +componentHsFiles _ = [] + +{- +ex_cs :: [ComponentInfo] +ex_cs = + [ (mkC (CExeName "foo") ["src1", "src1/src2"] ["Foo", "Src2.Bar", "Bar"]) + , (mkC (CExeName "tst") ["src1", "test"] ["Foo"]) + ] + where + mkC n ds ms = ComponentInfo n (componentStringName pkgid n) ds (map mkMn ms) + mkMn :: String -> ModuleName + mkMn = fromJust . simpleParse + pkgid :: PackageIdentifier + Just pkgid = simpleParse "thelib" +-} + +------------------------------ +-- Matching component kinds +-- + +data ComponentKind = LibKind | FLibKind | ExeKind | TestKind | BenchKind + deriving (Eq, Ord, Show, Enum, Bounded) + +componentKind :: ComponentName -> ComponentKind +componentKind (CLibName _) = LibKind +componentKind (CFLibName _) = FLibKind +componentKind (CExeName _) = ExeKind +componentKind (CTestName _) = TestKind +componentKind (CBenchName _) = BenchKind + +cinfoKind :: ComponentInfo -> ComponentKind +cinfoKind = componentKind . cinfoName + +matchComponentKind :: String -> Match ComponentKind +matchComponentKind s + | s `elem` ["lib", "library"] = return' LibKind + | s `elem` ["flib", "foreign-lib", "foreign-library"] = return' FLibKind + | s `elem` ["exe", "executable"] = return' ExeKind + | s `elem` ["tst", "test", "test-suite"] = return' TestKind + | s `elem` ["bench", "benchmark"] = return' BenchKind + | otherwise = matchErrorExpected "component kind" s + where + return' ck = increaseConfidence >> return ck + +showComponentKind :: ComponentKind -> String +showComponentKind LibKind = "library" +showComponentKind FLibKind = "foreign-library" +showComponentKind ExeKind = "executable" +showComponentKind TestKind = "test-suite" +showComponentKind BenchKind = "benchmark" + +showComponentKindShort :: ComponentKind -> String +showComponentKindShort LibKind = "lib" +showComponentKindShort FLibKind = "flib" +showComponentKindShort ExeKind = "exe" +showComponentKindShort TestKind = "test" +showComponentKindShort BenchKind = "bench" + +------------------------------ +-- Matching component targets +-- + +matchComponent1 :: [ComponentInfo] -> String -> Match BuildTarget +matchComponent1 cs = \str1 -> do + guardComponentName str1 + c <- matchComponentName cs str1 + return (BuildTargetComponent (cinfoName c)) + +matchComponent2 :: [ComponentInfo] -> String -> String -> Match BuildTarget +matchComponent2 cs = \str1 str2 -> do + ckind <- matchComponentKind str1 + guardComponentName str2 + c <- matchComponentKindAndName cs ckind str2 + return (BuildTargetComponent (cinfoName c)) + +-- utils: + +guardComponentName :: String -> Match () +guardComponentName s + | all validComponentChar s + && not (null s) = increaseConfidence + | otherwise = matchErrorExpected "component name" s + where + validComponentChar c = isAlphaNum c || c == '.' + || c == '_' || c == '-' || c == '\'' + +matchComponentName :: [ComponentInfo] -> String -> Match ComponentInfo +matchComponentName cs str = + orNoSuchThing "component" str + $ increaseConfidenceFor + $ matchInexactly caseFold + [ (cinfoStrName c, c) | c <- cs ] + str + +matchComponentKindAndName :: [ComponentInfo] -> ComponentKind -> String + -> Match ComponentInfo +matchComponentKindAndName cs ckind str = + orNoSuchThing (showComponentKind ckind ++ " component") str + $ increaseConfidenceFor + $ matchInexactly (\(ck, cn) -> (ck, caseFold cn)) + [ ((cinfoKind c, cinfoStrName c), c) | c <- cs ] + (ckind, str) + + +------------------------------ +-- Matching module targets +-- + +matchModule1 :: [ComponentInfo] -> String -> Match BuildTarget +matchModule1 cs = \str1 -> do + guardModuleName str1 + nubMatchErrors $ do + c <- tryEach cs + let ms = cinfoModules c + m <- matchModuleName ms str1 + return (BuildTargetModule (cinfoName c) m) + +matchModule2 :: [ComponentInfo] -> String -> String -> Match BuildTarget +matchModule2 cs = \str1 str2 -> do + guardComponentName str1 + guardModuleName str2 + c <- matchComponentName cs str1 + let ms = cinfoModules c + m <- matchModuleName ms str2 + return (BuildTargetModule (cinfoName c) m) + +matchModule3 :: [ComponentInfo] -> String -> String -> String + -> Match BuildTarget +matchModule3 cs str1 str2 str3 = do + ckind <- matchComponentKind str1 + guardComponentName str2 + c <- matchComponentKindAndName cs ckind str2 + guardModuleName str3 + let ms = cinfoModules c + m <- matchModuleName ms str3 + return (BuildTargetModule (cinfoName c) m) + +-- utils: + +guardModuleName :: String -> Match () +guardModuleName s + | all validModuleChar s + && not (null s) = increaseConfidence + | otherwise = matchErrorExpected "module name" s + where + validModuleChar c = isAlphaNum c || c == '.' || c == '_' || c == '\'' + +matchModuleName :: [ModuleName] -> String -> Match ModuleName +matchModuleName ms str = + orNoSuchThing "module" str + $ increaseConfidenceFor + $ matchInexactly caseFold + [ (prettyShow m, m) + | m <- ms ] + str + + +------------------------------ +-- Matching file targets +-- + +matchFile1 :: [ComponentInfo] -> String -> Bool -> Match BuildTarget +matchFile1 cs str1 exists = + nubMatchErrors $ do + c <- tryEach cs + filepath <- matchComponentFile c str1 exists + return (BuildTargetFile (cinfoName c) filepath) + + +matchFile2 :: [ComponentInfo] -> String -> String -> Bool -> Match BuildTarget +matchFile2 cs str1 str2 exists = do + guardComponentName str1 + c <- matchComponentName cs str1 + filepath <- matchComponentFile c str2 exists + return (BuildTargetFile (cinfoName c) filepath) + + +matchFile3 :: [ComponentInfo] -> String -> String -> String -> Bool + -> Match BuildTarget +matchFile3 cs str1 str2 str3 exists = do + ckind <- matchComponentKind str1 + guardComponentName str2 + c <- matchComponentKindAndName cs ckind str2 + filepath <- matchComponentFile c str3 exists + return (BuildTargetFile (cinfoName c) filepath) + + +matchComponentFile :: ComponentInfo -> String -> Bool -> Match FilePath +matchComponentFile c str fexists = + expecting "file" str $ + matchPlus + (matchFileExists str fexists) + (matchPlusShadowing + (msum [ matchModuleFileRooted dirs ms str + , matchOtherFileRooted dirs hsFiles str ]) + (msum [ matchModuleFileUnrooted ms str + , matchOtherFileUnrooted hsFiles str + , matchOtherFileUnrooted cFiles str + , matchOtherFileUnrooted jsFiles str ])) + where + dirs = cinfoSrcDirs c + ms = cinfoModules c + hsFiles = cinfoHsFiles c + cFiles = cinfoCFiles c + jsFiles = cinfoJsFiles c + + +-- utils + +matchFileExists :: FilePath -> Bool -> Match a +matchFileExists _ False = mzero +matchFileExists fname True = do increaseConfidence + matchErrorNoSuch "file" fname + +matchModuleFileUnrooted :: [ModuleName] -> String -> Match FilePath +matchModuleFileUnrooted ms str = do + let filepath = normalise str + _ <- matchModuleFileStem ms filepath + return filepath + +matchModuleFileRooted :: [FilePath] -> [ModuleName] -> String -> Match FilePath +matchModuleFileRooted dirs ms str = nubMatches $ do + let filepath = normalise str + filepath' <- matchDirectoryPrefix dirs filepath + _ <- matchModuleFileStem ms filepath' + return filepath + +matchModuleFileStem :: [ModuleName] -> FilePath -> Match ModuleName +matchModuleFileStem ms = + increaseConfidenceFor + . matchInexactly caseFold + [ (toFilePath m, m) | m <- ms ] + . dropExtension + +matchOtherFileRooted :: [FilePath] -> [FilePath] -> FilePath -> Match FilePath +matchOtherFileRooted dirs fs str = do + let filepath = normalise str + filepath' <- matchDirectoryPrefix dirs filepath + _ <- matchFile fs filepath' + return filepath + +matchOtherFileUnrooted :: [FilePath] -> FilePath -> Match FilePath +matchOtherFileUnrooted fs str = do + let filepath = normalise str + _ <- matchFile fs filepath + return filepath + +matchFile :: [FilePath] -> FilePath -> Match FilePath +matchFile fs = increaseConfidenceFor + . matchInexactly caseFold [ (f, f) | f <- fs ] + +matchDirectoryPrefix :: [FilePath] -> FilePath -> Match FilePath +matchDirectoryPrefix dirs filepath = + exactMatches $ + catMaybes + [ stripDirectory (normalise dir) filepath | dir <- dirs ] + where + stripDirectory :: FilePath -> FilePath -> Maybe FilePath + stripDirectory dir fp = + joinPath `fmap` stripPrefix (splitDirectories dir) (splitDirectories fp) + + +------------------------------ +-- Matching monad +-- + +-- | A matcher embodies a way to match some input as being some recognised +-- value. In particular it deals with multiple and ambiguous matches. +-- +-- There are various matcher primitives ('matchExactly', 'matchInexactly'), +-- ways to combine matchers ('ambiguousWith', 'shadows') and finally we can +-- run a matcher against an input using 'findMatch'. +-- + +data Match a = NoMatch Confidence [MatchError] + | ExactMatch Confidence [a] + | InexactMatch Confidence [a] + deriving Show + +type Confidence = Int + +data MatchError = MatchErrorExpected String String + | MatchErrorNoSuch String String + deriving (Show, Eq) + + +instance Alternative Match where + empty = mzero + (<|>) = mplus + +instance MonadPlus Match where + mzero = matchZero + mplus = matchPlus + +matchZero :: Match a +matchZero = NoMatch 0 [] + +-- | Combine two matchers. Exact matches are used over inexact matches +-- but if we have multiple exact, or inexact then the we collect all the +-- ambiguous matches. +-- +matchPlus :: Match a -> Match a -> Match a +matchPlus (ExactMatch d1 xs) (ExactMatch d2 xs') = + ExactMatch (max d1 d2) (xs ++ xs') +matchPlus a@(ExactMatch _ _ ) (InexactMatch _ _ ) = a +matchPlus a@(ExactMatch _ _ ) (NoMatch _ _ ) = a +matchPlus (InexactMatch _ _ ) b@(ExactMatch _ _ ) = b +matchPlus (InexactMatch d1 xs) (InexactMatch d2 xs') = + InexactMatch (max d1 d2) (xs ++ xs') +matchPlus a@(InexactMatch _ _ ) (NoMatch _ _ ) = a +matchPlus (NoMatch _ _ ) b@(ExactMatch _ _ ) = b +matchPlus (NoMatch _ _ ) b@(InexactMatch _ _ ) = b +matchPlus a@(NoMatch d1 ms) b@(NoMatch d2 ms') + | d1 > d2 = a + | d1 < d2 = b + | otherwise = NoMatch d1 (ms ++ ms') + +-- | Combine two matchers. This is similar to 'ambiguousWith' with the +-- difference that an exact match from the left matcher shadows any exact +-- match on the right. Inexact matches are still collected however. +-- +matchPlusShadowing :: Match a -> Match a -> Match a +matchPlusShadowing a@(ExactMatch _ _) (ExactMatch _ _) = a +matchPlusShadowing a b = matchPlus a b + +instance Functor Match where + fmap _ (NoMatch d ms) = NoMatch d ms + fmap f (ExactMatch d xs) = ExactMatch d (fmap f xs) + fmap f (InexactMatch d xs) = InexactMatch d (fmap f xs) + +instance Applicative Match where + pure a = ExactMatch 0 [a] + (<*>) = ap + +instance Monad Match where + return = pure + + NoMatch d ms >>= _ = NoMatch d ms + ExactMatch d xs >>= f = addDepth d + $ foldr matchPlus matchZero (map f xs) + InexactMatch d xs >>= f = addDepth d . forceInexact + $ foldr matchPlus matchZero (map f xs) + +addDepth :: Confidence -> Match a -> Match a +addDepth d' (NoMatch d msgs) = NoMatch (d'+d) msgs +addDepth d' (ExactMatch d xs) = ExactMatch (d'+d) xs +addDepth d' (InexactMatch d xs) = InexactMatch (d'+d) xs + +forceInexact :: Match a -> Match a +forceInexact (ExactMatch d ys) = InexactMatch d ys +forceInexact m = m + +------------------------------ +-- Various match primitives +-- + +matchErrorExpected, matchErrorNoSuch :: String -> String -> Match a +matchErrorExpected thing got = NoMatch 0 [MatchErrorExpected thing got] +matchErrorNoSuch thing got = NoMatch 0 [MatchErrorNoSuch thing got] + +expecting :: String -> String -> Match a -> Match a +expecting thing got (NoMatch 0 _) = matchErrorExpected thing got +expecting _ _ m = m + +orNoSuchThing :: String -> String -> Match a -> Match a +orNoSuchThing thing got (NoMatch 0 _) = matchErrorNoSuch thing got +orNoSuchThing _ _ m = m + +increaseConfidence :: Match () +increaseConfidence = ExactMatch 1 [()] + +increaseConfidenceFor :: Match a -> Match a +increaseConfidenceFor m = m >>= \r -> increaseConfidence >> return r + +nubMatches :: Eq a => Match a -> Match a +nubMatches (NoMatch d msgs) = NoMatch d msgs +nubMatches (ExactMatch d xs) = ExactMatch d (nub xs) +nubMatches (InexactMatch d xs) = InexactMatch d (nub xs) + +nubMatchErrors :: Match a -> Match a +nubMatchErrors (NoMatch d msgs) = NoMatch d (nub msgs) +nubMatchErrors (ExactMatch d xs) = ExactMatch d xs +nubMatchErrors (InexactMatch d xs) = InexactMatch d xs + +-- | Lift a list of matches to an exact match. +-- +exactMatches, inexactMatches :: [a] -> Match a + +exactMatches [] = matchZero +exactMatches xs = ExactMatch 0 xs + +inexactMatches [] = matchZero +inexactMatches xs = InexactMatch 0 xs + +tryEach :: [a] -> Match a +tryEach = exactMatches + + +------------------------------ +-- Top level match runner +-- + +-- | Given a matcher and a key to look up, use the matcher to find all the +-- possible matches. There may be 'None', a single 'Unambiguous' match or +-- you may have an 'Ambiguous' match with several possibilities. +-- +findMatch :: Eq b => Match b -> MaybeAmbiguous b +findMatch match = + case match of + NoMatch _ msgs -> None (nub msgs) + ExactMatch _ xs -> checkAmbiguous xs + InexactMatch _ xs -> checkAmbiguous xs + where + checkAmbiguous xs = case nub xs of + [x] -> Unambiguous x + xs' -> Ambiguous xs' + +data MaybeAmbiguous a = None [MatchError] | Unambiguous a | Ambiguous [a] + deriving Show + + +------------------------------ +-- Basic matchers +-- + +{- +-- | A primitive matcher that looks up a value in a finite 'Map'. The +-- value must match exactly. +-- +matchExactly :: forall a b. Ord a => [(a, b)] -> (a -> Match b) +matchExactly xs = + \x -> case Map.lookup x m of + Nothing -> matchZero + Just ys -> ExactMatch 0 ys + where + m :: Ord a => Map a [b] + m = Map.fromListWith (++) [ (k,[x]) | (k,x) <- xs ] +-} + +-- | A primitive matcher that looks up a value in a finite 'Map'. It checks +-- for an exact or inexact match. We get an inexact match if the match +-- is not exact, but the canonical forms match. It takes a canonicalisation +-- function for this purpose. +-- +-- So for example if we used string case fold as the canonicalisation +-- function, then we would get case insensitive matching (but it will still +-- report an exact match when the case matches too). +-- +matchInexactly :: (Ord a, Ord a') => + (a -> a') -> + [(a, b)] -> (a -> Match b) +matchInexactly cannonicalise xs = + \x -> case Map.lookup x m of + Just ys -> exactMatches ys + Nothing -> case Map.lookup (cannonicalise x) m' of + Just ys -> inexactMatches ys + Nothing -> matchZero + where + m = Map.fromListWith (++) [ (k,[x]) | (k,x) <- xs ] + + -- the map of canonicalised keys to groups of inexact matches + m' = Map.mapKeysWith (++) cannonicalise m + + + +------------------------------ +-- Utils +-- + +caseFold :: String -> String +caseFold = lowercase + + +-- | Check that the given build targets are valid in the current context. +-- +-- Also swizzle into a more convenient form. +-- +checkBuildTargets :: Verbosity -> PackageDescription -> LocalBuildInfo -> [BuildTarget] + -> IO [TargetInfo] +checkBuildTargets _ pkg_descr lbi [] = + return (allTargetsInBuildOrder' pkg_descr lbi) + +checkBuildTargets verbosity pkg_descr lbi targets = do + + let (enabled, disabled) = + partitionEithers + [ case componentDisabledReason (componentEnabledSpec lbi) comp of + Nothing -> Left target' + Just reason -> Right (cname, reason) + | target <- targets + , let target'@(cname,_) = swizzleTarget target + , let comp = getComponent pkg_descr cname ] + + case disabled of + [] -> return () + ((cname,reason):_) -> die' verbosity $ formatReason (showComponentName cname) reason + + for_ [ (c, t) | (c, Just t) <- enabled ] $ \(c, t) -> + warn verbosity $ "Ignoring '" ++ either prettyShow id t ++ ". The whole " + ++ showComponentName c ++ " will be processed. (Support for " + ++ "module and file targets has not been implemented yet.)" + + -- Pick out the actual CLBIs for each of these cnames + enabled' <- for enabled $ \(cname, _) -> do + case componentNameTargets' pkg_descr lbi cname of + [] -> error "checkBuildTargets: nothing enabled" + [target] -> return target + _targets -> error "checkBuildTargets: multiple copies enabled" + + return enabled' + + where + swizzleTarget (BuildTargetComponent c) = (c, Nothing) + swizzleTarget (BuildTargetModule c m) = (c, Just (Left m)) + swizzleTarget (BuildTargetFile c f) = (c, Just (Right f)) + + formatReason cn DisabledComponent = + "Cannot process the " ++ cn ++ " because the component is marked " + ++ "as disabled in the .cabal file." + formatReason cn DisabledAllTests = + "Cannot process the " ++ cn ++ " because test suites are not " + ++ "enabled. Run configure with the flag --enable-tests" + formatReason cn DisabledAllBenchmarks = + "Cannot process the " ++ cn ++ " because benchmarks are not " + ++ "enabled. Re-run configure with the flag --enable-benchmarks" + formatReason cn (DisabledAllButOne cn') = + "Cannot process the " ++ cn ++ " because this package was " + ++ "configured only to build " ++ cn' ++ ". Re-run configure " + ++ "with the argument " ++ cn diff --git a/cabal/Cabal/src/Distribution/Simple/BuildToolDepends.hs b/cabal/Cabal/src/Distribution/Simple/BuildToolDepends.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/BuildToolDepends.hs @@ -0,0 +1,93 @@ +-- | +-- +-- This modules provides functions for working with both the legacy +-- "build-tools" field, and its replacement, "build-tool-depends". Prefer using +-- the functions contained to access those fields directly. +module Distribution.Simple.BuildToolDepends where + +import Prelude () +import Distribution.Compat.Prelude + +import qualified Data.Map as Map + +import Distribution.Package +import Distribution.PackageDescription + +-- | Desugar a "build-tools" entry into proper a executable dependency if +-- possible. +-- +-- An entry can be so desugared in two cases: +-- +-- 1. The name in build-tools matches a locally defined executable. The +-- executable dependency produced is on that exe in the current package. +-- +-- 2. The name in build-tools matches a hard-coded set of known tools. For now, +-- the executable dependency produced is one an executable in a package of +-- the same, but the hard-coding could just as well be per-key. +-- +-- The first cases matches first. +desugarBuildTool :: PackageDescription + -> LegacyExeDependency + -> Maybe ExeDependency +desugarBuildTool pkg led = + if foundLocal + then Just $ ExeDependency (packageName pkg) toolName reqVer + else Map.lookup name whiteMap + where + LegacyExeDependency name reqVer = led + toolName = mkUnqualComponentName name + foundLocal = toolName `elem` map exeName (executables pkg) + whitelist = [ "hscolour", "haddock", "happy", "alex", "hsc2hs", "c2hs" + , "cpphs", "greencard", "hspec-discover" + ] + whiteMap = Map.fromList $ flip map whitelist $ \n -> + (n, ExeDependency (mkPackageName n) (mkUnqualComponentName n) reqVer) + +-- | Get everything from "build-tool-depends", along with entries from +-- "build-tools" that we know how to desugar. +-- +-- This should almost always be used instead of just accessing the +-- `buildToolDepends` field directly. +getAllToolDependencies :: PackageDescription + -> BuildInfo + -> [ExeDependency] +getAllToolDependencies pkg bi = + buildToolDepends bi ++ mapMaybe (desugarBuildTool pkg) (buildTools bi) + +-- | Does the given executable dependency map to this current package? +-- +-- This is a tiny function, but used in a number of places. +-- +-- This function is only sound to call on `BuildInfo`s from the given package +-- description. This is because it just filters the package names of each +-- dependency, and does not check whether version bounds in fact exclude the +-- current package, or the referenced components in fact exist in the current +-- package. +-- +-- This is OK because when a package is loaded, it is checked (in +-- `Distribution.Package.Check`) that dependencies matching internal components +-- do indeed have version bounds accepting the current package, and any +-- depended-on component in the current package actually exists. In fact this +-- check is performed by gathering the internal tool dependencies of each +-- component of the package according to this module, and ensuring those +-- properties on each so-gathered dependency. +-- +-- version bounds and components of the package are unchecked. This is because +-- we sanitize exe deps so that the matching name implies these other +-- conditions. +isInternal :: PackageDescription -> ExeDependency -> Bool +isInternal pkg (ExeDependency n _ _) = n == packageName pkg + + +-- | Get internal "build-tool-depends", along with internal "build-tools" +-- +-- This is a tiny function, but used in a number of places. The same +-- restrictions that apply to `isInternal` also apply to this function. +getAllInternalToolDependencies :: PackageDescription + -> BuildInfo + -> [UnqualComponentName] +getAllInternalToolDependencies pkg bi = + [ toolname + | dep@(ExeDependency _ toolname _) <- getAllToolDependencies pkg bi + , isInternal pkg dep + ] diff --git a/cabal/Cabal/src/Distribution/Simple/CCompiler.hs b/cabal/Cabal/src/Distribution/Simple/CCompiler.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/CCompiler.hs @@ -0,0 +1,123 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.CCompiler +-- Copyright : 2011, Dan Knapp +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This simple package provides types and functions for interacting with +-- C compilers. Currently it's just a type enumerating extant C-like +-- languages, which we call dialects. + +{- +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.Simple.CCompiler ( + CDialect(..), + cSourceExtensions, + cDialectFilenameExtension, + filenameCDialect + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import System.FilePath + ( takeExtension ) + + +-- | Represents a dialect of C. The Monoid instance expresses backward +-- compatibility, in the sense that 'mappend a b' is the least inclusive +-- dialect which both 'a' and 'b' can be correctly interpreted as. +data CDialect = C + | ObjectiveC + | CPlusPlus + | ObjectiveCPlusPlus + deriving (Eq, Show) + +instance Monoid CDialect where + mempty = C + mappend = (<>) + +instance Semigroup CDialect where + C <> anything = anything + ObjectiveC <> CPlusPlus = ObjectiveCPlusPlus + CPlusPlus <> ObjectiveC = ObjectiveCPlusPlus + _ <> ObjectiveCPlusPlus = ObjectiveCPlusPlus + ObjectiveC <> _ = ObjectiveC + CPlusPlus <> _ = CPlusPlus + ObjectiveCPlusPlus <> _ = ObjectiveCPlusPlus + +-- | A list of all file extensions which are recognized as possibly containing +-- some dialect of C code. Note that this list is only for source files, +-- not for header files. +cSourceExtensions :: [String] +cSourceExtensions = ["c", "i", "ii", "m", "mi", "mm", "M", "mii", "cc", "cp", + "cxx", "cpp", "CPP", "c++", "C"] + + +-- | Takes a dialect of C and whether code is intended to be passed through +-- the preprocessor, and returns a filename extension for containing that +-- code. +cDialectFilenameExtension :: CDialect -> Bool -> String +cDialectFilenameExtension C True = "c" +cDialectFilenameExtension C False = "i" +cDialectFilenameExtension ObjectiveC True = "m" +cDialectFilenameExtension ObjectiveC False = "mi" +cDialectFilenameExtension CPlusPlus True = "cpp" +cDialectFilenameExtension CPlusPlus False = "ii" +cDialectFilenameExtension ObjectiveCPlusPlus True = "mm" +cDialectFilenameExtension ObjectiveCPlusPlus False = "mii" + + +-- | Infers from a filename's extension the dialect of C which it contains, +-- and whether it is intended to be passed through the preprocessor. +filenameCDialect :: String -> Maybe (CDialect, Bool) +filenameCDialect filename = do + extension <- case takeExtension filename of + '.':ext -> Just ext + _ -> Nothing + case extension of + "c" -> return (C, True) + "i" -> return (C, False) + "ii" -> return (CPlusPlus, False) + "m" -> return (ObjectiveC, True) + "mi" -> return (ObjectiveC, False) + "mm" -> return (ObjectiveCPlusPlus, True) + "M" -> return (ObjectiveCPlusPlus, True) + "mii" -> return (ObjectiveCPlusPlus, False) + "cc" -> return (CPlusPlus, True) + "cp" -> return (CPlusPlus, True) + "cxx" -> return (CPlusPlus, True) + "cpp" -> return (CPlusPlus, True) + "CPP" -> return (CPlusPlus, True) + "c++" -> return (CPlusPlus, True) + "C" -> return (CPlusPlus, True) + _ -> Nothing diff --git a/cabal/Cabal/src/Distribution/Simple/Command.hs b/cabal/Cabal/src/Distribution/Simple/Command.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/Command.hs @@ -0,0 +1,588 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Command +-- Copyright : Duncan Coutts 2007 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : non-portable (ExistentialQuantification) +-- +-- This is to do with command line handling. The Cabal command line is +-- organised into a number of named sub-commands (much like darcs). The +-- 'CommandUI' abstraction represents one of these sub-commands, with a name, +-- description, a set of flags. Commands can be associated with actions and +-- run. It handles some common stuff automatically, like the @--help@ and +-- command line completion flags. It is designed to allow other tools make +-- derived commands. This feature is used heavily in @cabal-install@. + +module Distribution.Simple.Command ( + + -- * Command interface + CommandUI(..), + commandShowOptions, + CommandParse(..), + commandParseArgs, + getNormalCommandDescriptions, + helpCommandUI, + + -- ** Constructing commands + ShowOrParseArgs(..), + usageDefault, + usageAlternatives, + mkCommandUI, + hiddenCommand, + + -- ** Associating actions with commands + Command, + commandAddAction, + noExtraFlags, + + -- ** Building lists of commands + CommandType(..), + CommandSpec(..), + commandFromSpec, + + -- ** Running commands + commandsRun, + +-- * Option Fields + OptionField(..), Name, + +-- ** Constructing Option Fields + option, multiOption, + +-- ** Liftings & Projections + liftOption, liftOptionL, + +-- * Option Descriptions + OptDescr(..), Description, SFlags, LFlags, OptFlags, ArgPlaceHolder, + +-- ** OptDescr 'smart' constructors + MkOptDescr, + reqArg, reqArg', optArg, optArg', noArg, + boolOpt, boolOpt', choiceOpt, choiceOptFromEnum + + ) where + +import Prelude () +import Distribution.Compat.Prelude hiding (get) + +import qualified Data.Array as Array +import qualified Data.List as List +import qualified Distribution.GetOpt as GetOpt +import Distribution.ReadE +import Distribution.Simple.Utils +import Distribution.Compat.Lens (ALens', (^#), (#~)) + + +data CommandUI flags = CommandUI { + -- | The name of the command as it would be entered on the command line. + -- For example @\"build\"@. + commandName :: String, + -- | A short, one line description of the command to use in help texts. + commandSynopsis :: String, + -- | A function that maps a program name to a usage summary for this + -- command. + commandUsage :: String -> String, + -- | Additional explanation of the command to use in help texts. + commandDescription :: Maybe (String -> String), + -- | Post-Usage notes and examples in help texts + commandNotes :: Maybe (String -> String), + -- | Initial \/ empty flags + commandDefaultFlags :: flags, + -- | All the Option fields for this command + commandOptions :: ShowOrParseArgs -> [OptionField flags] + } + +data ShowOrParseArgs = ShowArgs | ParseArgs +type Name = String +type Description = String + +-- | We usually have a data type for storing configuration values, where +-- every field stores a configuration option, and the user sets +-- the value either via command line flags or a configuration file. +-- An individual OptionField models such a field, and we usually +-- build a list of options associated to a configuration data type. +data OptionField a = OptionField { + optionName :: Name, + optionDescr :: [OptDescr a] } + +-- | An OptionField takes one or more OptDescrs, describing the command line +-- interface for the field. +data OptDescr a = ReqArg Description OptFlags ArgPlaceHolder + (ReadE (a->a)) (a -> [String]) + + | OptArg Description OptFlags ArgPlaceHolder + (ReadE (a->a)) (a->a) (a -> [Maybe String]) + + | ChoiceOpt [(Description, OptFlags, a->a, a -> Bool)] + + | BoolOpt Description OptFlags{-True-} OptFlags{-False-} + (Bool -> a -> a) (a-> Maybe Bool) + +-- | Short command line option strings +type SFlags = [Char] +-- | Long command line option strings +type LFlags = [String] +type OptFlags = (SFlags,LFlags) +type ArgPlaceHolder = String + + +-- | Create an option taking a single OptDescr. +-- No explicit Name is given for the Option, the name is the first LFlag given. +option :: SFlags -> LFlags -> Description -> get -> set -> MkOptDescr get set a + -> OptionField a +option sf lf@(n:_) d get set arg = OptionField n [arg sf lf d get set] +option _ _ _ _ _ _ = error $ "Distribution.command.option: " + ++ "An OptionField must have at least one LFlag" + +-- | Create an option taking several OptDescrs. +-- You will have to give the flags and description individually to the +-- OptDescr constructor. +multiOption :: Name -> get -> set + -> [get -> set -> OptDescr a] -- ^MkOptDescr constructors partially + -- applied to flags and description. + -> OptionField a +multiOption n get set args = OptionField n [arg get set | arg <- args] + +type MkOptDescr get set a = SFlags -> LFlags -> Description -> get -> set + -> OptDescr a + +-- | Create a string-valued command line interface. +reqArg :: Monoid b => ArgPlaceHolder -> ReadE b -> (b -> [String]) + -> MkOptDescr (a -> b) (b -> a -> a) a +reqArg ad mkflag showflag sf lf d get set = + ReqArg d (sf,lf) ad (fmap (\a b -> set (get b `mappend` a) b) mkflag) + (showflag . get) + +-- | Create a string-valued command line interface with a default value. +optArg :: Monoid b => ArgPlaceHolder -> ReadE b -> b -> (b -> [Maybe String]) + -> MkOptDescr (a -> b) (b -> a -> a) a +optArg ad mkflag def showflag sf lf d get set = + OptArg d (sf,lf) ad (fmap (\a b -> set (get b `mappend` a) b) mkflag) + (\b -> set (get b `mappend` def) b) + (showflag . get) + +-- | (String -> a) variant of "reqArg" +reqArg' :: Monoid b => ArgPlaceHolder -> (String -> b) -> (b -> [String]) + -> MkOptDescr (a -> b) (b -> a -> a) a +reqArg' ad mkflag showflag = + reqArg ad (succeedReadE mkflag) showflag + +-- | (String -> a) variant of "optArg" +optArg' :: Monoid b => ArgPlaceHolder -> (Maybe String -> b) + -> (b -> [Maybe String]) + -> MkOptDescr (a -> b) (b -> a -> a) a +optArg' ad mkflag showflag = + optArg ad (succeedReadE (mkflag . Just)) def showflag + where def = mkflag Nothing + +noArg :: (Eq b) => b -> MkOptDescr (a -> b) (b -> a -> a) a +noArg flag sf lf d = choiceOpt [(flag, (sf,lf), d)] sf lf d + +boolOpt :: (b -> Maybe Bool) -> (Bool -> b) -> SFlags -> SFlags + -> MkOptDescr (a -> b) (b -> a -> a) a +boolOpt g s sfT sfF _sf _lf@(n:_) d get set = + BoolOpt d (sfT, ["enable-"++n]) (sfF, ["disable-"++n]) (set.s) (g.get) +boolOpt _ _ _ _ _ _ _ _ _ = error + "Distribution.Simple.Setup.boolOpt: unreachable" + +boolOpt' :: (b -> Maybe Bool) -> (Bool -> b) -> OptFlags -> OptFlags + -> MkOptDescr (a -> b) (b -> a -> a) a +boolOpt' g s ffT ffF _sf _lf d get set = BoolOpt d ffT ffF (set.s) (g . get) + +-- | create a Choice option +choiceOpt :: Eq b => [(b,OptFlags,Description)] + -> MkOptDescr (a -> b) (b -> a -> a) a +choiceOpt aa_ff _sf _lf _d get set = ChoiceOpt alts + where alts = [(d,flags, set alt, (==alt) . get) | (alt,flags,d) <- aa_ff] + +-- | create a Choice option out of an enumeration type. +-- As long flags, the Show output is used. As short flags, the first character +-- which does not conflict with a previous one is used. +choiceOptFromEnum :: (Bounded b, Enum b, Show b, Eq b) => + MkOptDescr (a -> b) (b -> a -> a) a +choiceOptFromEnum _sf _lf d get = + choiceOpt [ (x, (sf, [map toLower $ show x]), d') + | (x, sf) <- sflags' + , let d' = d ++ show x] + _sf _lf d get + where sflags' = foldl f [] [firstOne..] + f prev x = let prevflags = concatMap snd prev in + prev ++ take 1 [(x, [toLower sf]) + | sf <- show x, isAlpha sf + , toLower sf `notElem` prevflags] + firstOne = minBound `asTypeOf` get undefined + +commandGetOpts :: ShowOrParseArgs -> CommandUI flags + -> [GetOpt.OptDescr (flags -> flags)] +commandGetOpts showOrParse command = + concatMap viewAsGetOpt (commandOptions command showOrParse) + +viewAsGetOpt :: OptionField a -> [GetOpt.OptDescr (a -> a)] +viewAsGetOpt (OptionField _n aa) = concatMap optDescrToGetOpt aa + where + optDescrToGetOpt (ReqArg d (cs,ss) arg_desc set _) = + [GetOpt.Option cs ss (GetOpt.ReqArg (runReadE set) arg_desc) d] + optDescrToGetOpt (OptArg d (cs,ss) arg_desc set def _) = + [GetOpt.Option cs ss (GetOpt.OptArg set' arg_desc) d] + where set' Nothing = Right def + set' (Just txt) = runReadE set txt + optDescrToGetOpt (ChoiceOpt alts) = + [GetOpt.Option sf lf (GetOpt.NoArg set) d | (d,(sf,lf),set,_) <- alts ] + optDescrToGetOpt (BoolOpt d (sfT, lfT) ([], []) set _) = + [ GetOpt.Option sfT lfT (GetOpt.NoArg (set True)) d ] + optDescrToGetOpt (BoolOpt d ([], []) (sfF, lfF) set _) = + [ GetOpt.Option sfF lfF (GetOpt.NoArg (set False)) d ] + optDescrToGetOpt (BoolOpt d (sfT,lfT) (sfF, lfF) set _) = + [ GetOpt.Option sfT lfT (GetOpt.NoArg (set True)) ("Enable " ++ d) + , GetOpt.Option sfF lfF (GetOpt.NoArg (set False)) ("Disable " ++ d) ] + +getCurrentChoice :: OptDescr a -> a -> [String] +getCurrentChoice (ChoiceOpt alts) a = + [ lf | (_,(_sf,lf:_), _, currentChoice) <- alts, currentChoice a] + +getCurrentChoice _ _ = error "Command.getChoice: expected a Choice OptDescr" + + +liftOption :: (b -> a) -> (a -> (b -> b)) -> OptionField a -> OptionField b +liftOption get' set' opt = + opt { optionDescr = liftOptDescr get' set' `map` optionDescr opt} + +-- | @since 3.4.0.0 +liftOptionL :: ALens' b a -> OptionField a -> OptionField b +liftOptionL l = liftOption (^# l) (l #~) + + +liftOptDescr :: (b -> a) -> (a -> (b -> b)) -> OptDescr a -> OptDescr b +liftOptDescr get' set' (ChoiceOpt opts) = + ChoiceOpt [ (d, ff, liftSet get' set' set , (get . get')) + | (d, ff, set, get) <- opts] + +liftOptDescr get' set' (OptArg d ff ad set def get) = + OptArg d ff ad (liftSet get' set' `fmap` set) + (liftSet get' set' def) (get . get') + +liftOptDescr get' set' (ReqArg d ff ad set get) = + ReqArg d ff ad (liftSet get' set' `fmap` set) (get . get') + +liftOptDescr get' set' (BoolOpt d ffT ffF set get) = + BoolOpt d ffT ffF (liftSet get' set' . set) (get . get') + +liftSet :: (b -> a) -> (a -> (b -> b)) -> (a -> a) -> b -> b +liftSet get' set' set x = set' (set $ get' x) x + +-- | Show flags in the standard long option command line format +commandShowOptions :: CommandUI flags -> flags -> [String] +commandShowOptions command v = concat + [ showOptDescr v od | o <- commandOptions command ParseArgs + , od <- optionDescr o] + where + maybePrefix [] = [] + maybePrefix (lOpt:_) = ["--" ++ lOpt] + + showOptDescr :: a -> OptDescr a -> [String] + showOptDescr x (BoolOpt _ (_,lfTs) (_,lfFs) _ enabled) + = case enabled x of + Nothing -> [] + Just True -> maybePrefix lfTs + Just False -> maybePrefix lfFs + showOptDescr x c@ChoiceOpt{} + = ["--" ++ val | val <- getCurrentChoice c x] + showOptDescr x (ReqArg _ (_ssff,lf:_) _ _ showflag) + = [ "--"++lf++"="++flag + | flag <- showflag x ] + showOptDescr x (OptArg _ (_ssff,lf:_) _ _ _ showflag) + = [ case flag of + Just s -> "--"++lf++"="++s + Nothing -> "--"++lf + | flag <- showflag x ] + showOptDescr _ _ + = error "Distribution.Simple.Command.showOptDescr: unreachable" + + +commandListOptions :: CommandUI flags -> [String] +commandListOptions command = + concatMap listOption $ + addCommonFlags ShowArgs $ -- This is a slight hack, we don't want + -- "--list-options" showing up in the + -- list options output, so use ShowArgs + commandGetOpts ShowArgs command + where + listOption (GetOpt.Option shortNames longNames _ _) = + [ "-" ++ [name] | name <- shortNames ] + ++ [ "--" ++ name | name <- longNames ] + +-- | The help text for this command with descriptions of all the options. +commandHelp :: CommandUI flags -> String -> String +commandHelp command pname = + commandSynopsis command + ++ "\n\n" + ++ commandUsage command pname + ++ ( case commandDescription command of + Nothing -> "" + Just desc -> '\n': desc pname) + ++ "\n" + ++ ( if cname == "" + then "Global flags:" + else "Flags for " ++ cname ++ ":" ) + ++ ( GetOpt.usageInfo "" + . addCommonFlags ShowArgs + $ commandGetOpts ShowArgs command ) + ++ ( case commandNotes command of + Nothing -> "" + Just notes -> '\n': notes pname) + where cname = commandName command + +-- | Default "usage" documentation text for commands. +usageDefault :: String -> String -> String +usageDefault name pname = + "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n\n" + ++ "Flags for " ++ name ++ ":" + +-- | Create "usage" documentation from a list of parameter +-- configurations. +usageAlternatives :: String -> [String] -> String -> String +usageAlternatives name strs pname = unlines + [ start ++ pname ++ " " ++ name ++ " " ++ s + | let starts = "Usage: " : repeat " or: " + , (start, s) <- zip starts strs + ] + +-- | Make a Command from standard 'GetOpt' options. +mkCommandUI :: String -- ^ name + -> String -- ^ synopsis + -> [String] -- ^ usage alternatives + -> flags -- ^ initial\/empty flags + -> (ShowOrParseArgs -> [OptionField flags]) -- ^ options + -> CommandUI flags +mkCommandUI name synopsis usages flags options = CommandUI + { commandName = name + , commandSynopsis = synopsis + , commandDescription = Nothing + , commandNotes = Nothing + , commandUsage = usageAlternatives name usages + , commandDefaultFlags = flags + , commandOptions = options + } + +-- | Common flags that apply to every command +data CommonFlag = HelpFlag | ListOptionsFlag + +commonFlags :: ShowOrParseArgs -> [GetOpt.OptDescr CommonFlag] +commonFlags showOrParseArgs = case showOrParseArgs of + ShowArgs -> [help] + ParseArgs -> [help, list] + where + help = GetOpt.Option helpShortFlags ["help"] (GetOpt.NoArg HelpFlag) + "Show this help text" + helpShortFlags = case showOrParseArgs of + ShowArgs -> ['h'] + ParseArgs -> ['h', '?'] + list = GetOpt.Option [] ["list-options"] (GetOpt.NoArg ListOptionsFlag) + "Print a list of command line flags" + +addCommonFlags :: ShowOrParseArgs + -> [GetOpt.OptDescr a] + -> [GetOpt.OptDescr (Either CommonFlag a)] +addCommonFlags showOrParseArgs options = + map (fmap Left) (commonFlags showOrParseArgs) + ++ map (fmap Right) options + +-- | Parse a bunch of command line arguments +-- +commandParseArgs :: CommandUI flags + -> Bool -- ^ Is the command a global or subcommand? + -> [String] + -> CommandParse (flags -> flags, [String]) +commandParseArgs command global args = + let options = addCommonFlags ParseArgs + $ commandGetOpts ParseArgs command + order | global = GetOpt.RequireOrder + | otherwise = GetOpt.Permute + in case GetOpt.getOpt' order options args of + (flags, _, _, _) + | any listFlag flags -> CommandList (commandListOptions command) + | any helpFlag flags -> CommandHelp (commandHelp command) + where listFlag (Left ListOptionsFlag) = True; listFlag _ = False + helpFlag (Left HelpFlag) = True; helpFlag _ = False + (flags, opts, opts', []) + | global || null opts' -> CommandReadyToGo (accum flags, mix opts opts') + | otherwise -> CommandErrors (unrecognised opts') + (_, _, _, errs) -> CommandErrors errs + + where -- Note: It is crucial to use reverse function composition here or to + -- reverse the flags here as we want to process the flags left to right + -- but data flow in function composition is right to left. + accum flags = foldr (flip (.)) id [ f | Right f <- flags ] + unrecognised opts = [ "unrecognized " + ++ "'" ++ (commandName command) ++ "'" + ++ " option `" ++ opt ++ "'\n" + | opt <- opts ] + -- For unrecognised global flags we put them in the position just after + -- the command, if there is one. This gives us a chance to parse them + -- as sub-command rather than global flags. + mix [] ys = ys + mix (x:xs) ys = x:ys++xs + +data CommandParse flags = CommandHelp (String -> String) + | CommandList [String] + | CommandErrors [String] + | CommandReadyToGo flags +instance Functor CommandParse where + fmap _ (CommandHelp help) = CommandHelp help + fmap _ (CommandList opts) = CommandList opts + fmap _ (CommandErrors errs) = CommandErrors errs + fmap f (CommandReadyToGo flags) = CommandReadyToGo (f flags) + + +data CommandType = NormalCommand | HiddenCommand +data Command action = + Command String String ([String] -> CommandParse action) CommandType + +-- | Mark command as hidden. Hidden commands don't show up in the 'progname +-- help' or 'progname --help' output. +hiddenCommand :: Command action -> Command action +hiddenCommand (Command name synopsys f _cmdType) = + Command name synopsys f HiddenCommand + +commandAddAction :: CommandUI flags + -> (flags -> [String] -> action) + -> Command action +commandAddAction command action = + Command (commandName command) + (commandSynopsis command) + (fmap (uncurry applyDefaultArgs) . commandParseArgs command False) + NormalCommand + + where applyDefaultArgs mkflags args = + let flags = mkflags (commandDefaultFlags command) + in action flags args + +commandsRun :: CommandUI a + -> [Command action] + -> [String] + -> CommandParse (a, CommandParse action) +commandsRun globalCommand commands args = + case commandParseArgs globalCommand True args of + CommandHelp help -> CommandHelp help + CommandList opts -> CommandList (opts ++ commandNames) + CommandErrors errs -> CommandErrors errs + CommandReadyToGo (mkflags, args') -> case args' of + ("help":cmdArgs) -> handleHelpCommand cmdArgs + (name:cmdArgs) -> case lookupCommand name of + [Command _ _ action _] + -> CommandReadyToGo (flags, action cmdArgs) + _ -> CommandReadyToGo (flags, badCommand name) + [] -> CommandReadyToGo (flags, noCommand) + where flags = mkflags (commandDefaultFlags globalCommand) + + where + lookupCommand cname = [ cmd | cmd@(Command cname' _ _ _) <- commands' + , cname' == cname ] + noCommand = CommandErrors ["no command given (try --help)\n"] + + -- Print suggested command if edit distance is < 5 + badCommand :: String -> CommandParse a + badCommand cname = + case eDists of + [] -> CommandErrors [unErr] + (s:_) -> CommandErrors [ unErr + , "Maybe you meant `" ++ s ++ "`?\n"] + where + eDists = map fst . List.sortBy (comparing snd) $ + [ (cname', dist) + | (Command cname' _ _ _) <- commands' + , let dist = editDistance cname' cname + , dist < 5 ] + unErr = "unrecognised command: " ++ cname ++ " (try --help)" + + commands' = commands ++ [commandAddAction helpCommandUI undefined] + commandNames = [ name | (Command name _ _ NormalCommand) <- commands' ] + + -- A bit of a hack: support "prog help" as a synonym of "prog --help" + -- furthermore, support "prog help command" as "prog command --help" + handleHelpCommand cmdArgs = + case commandParseArgs helpCommandUI True cmdArgs of + CommandHelp help -> CommandHelp help + CommandList list -> CommandList (list ++ commandNames) + CommandErrors _ -> CommandHelp globalHelp + CommandReadyToGo (_,[]) -> CommandHelp globalHelp + CommandReadyToGo (_,(name:cmdArgs')) -> + case lookupCommand name of + [Command _ _ action _] -> + case action ("--help":cmdArgs') of + CommandHelp help -> CommandHelp help + CommandList _ -> CommandList [] + _ -> CommandHelp globalHelp + _ -> badCommand name + + where globalHelp = commandHelp globalCommand + +-- Levenshtein distance, from https://wiki.haskell.org/Edit_distance +-- (Author: JeanPhilippeBernardy, Simple Permissive Licence) +editDistance :: Eq a => [a] -> [a] -> Int +editDistance xs ys = table Array.! (m,n) + where + (m,n) = (length xs, length ys) + x = Array.array (1,m) (zip [1..] xs) + y = Array.array (1,n) (zip [1..] ys) + + table :: Array.Array (Int,Int) Int + table = Array.array bnds [(ij, dist ij) | ij <- Array.range bnds] + bnds = ((0,0),(m,n)) + + dist (0,j) = j + dist (i,0) = i + dist (i,j) = minimum + [ table Array.! (i-1,j) + 1 + , table Array.! (i,j-1) + 1 + , if x Array.! i == y Array.! j + then table Array.! (i-1,j-1) + else 1 + table Array.! (i-1,j-1) + ] + +-- | Utility function, many commands do not accept additional flags. This +-- action fails with a helpful error message if the user supplies any extra. +-- +noExtraFlags :: [String] -> IO () +noExtraFlags [] = return () +noExtraFlags extraFlags = + dieNoVerbosity $ "Unrecognised flags: " ++ intercalate ", " extraFlags +--TODO: eliminate this function and turn it into a variant on commandAddAction +-- instead like commandAddActionNoArgs that doesn't supply the [String] + +-- | Helper function for creating globalCommand description +getNormalCommandDescriptions :: [Command action] -> [(String, String)] +getNormalCommandDescriptions cmds = + [ (name, description) + | Command name description _ NormalCommand <- cmds ] + +helpCommandUI :: CommandUI () +helpCommandUI = + (mkCommandUI + "help" + "Help about commands." + ["[FLAGS]", "COMMAND [FLAGS]"] + () + (const [])) + { + commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " help help\n" + ++ " Oh, appararently you already know this.\n" + } + +-- | wraps a @CommandUI@ together with a function that turns it into a @Command@. +-- By hiding the type of flags for the UI allows construction of a list of all UIs at the +-- top level of the program. That list can then be used for generation of manual page +-- as well as for executing the selected command. +data CommandSpec action + = forall flags. CommandSpec (CommandUI flags) (CommandUI flags -> Command action) CommandType + +commandFromSpec :: CommandSpec a -> Command a +commandFromSpec (CommandSpec ui action _) = action ui diff --git a/cabal/Cabal/src/Distribution/Simple/Compiler.hs b/cabal/Cabal/src/Distribution/Simple/Compiler.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/Compiler.hs @@ -0,0 +1,460 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Compiler +-- Copyright : Isaac Jones 2003-2004 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This should be a much more sophisticated abstraction than it is. Currently +-- it's just a bit of data about the compiler, like its flavour and name and +-- version. The reason it's just data is because currently it has to be in +-- 'Read' and 'Show' so it can be saved along with the 'LocalBuildInfo'. The +-- only interesting bit of info it contains is a mapping between language +-- extensions and compiler command line flags. This module also defines a +-- 'PackageDB' type which is used to refer to package databases. Most compilers +-- only know about a single global package collection but GHC has a global and +-- per-user one and it lets you create arbitrary other package databases. We do +-- not yet fully support this latter feature. + +module Distribution.Simple.Compiler ( + -- * Haskell implementations + module Distribution.Compiler, + Compiler(..), + showCompilerId, showCompilerIdWithAbi, + compilerFlavor, compilerVersion, + compilerCompatFlavor, + compilerCompatVersion, + compilerInfo, + + -- * Support for package databases + PackageDB(..), + PackageDBStack, + registrationPackageDB, + absolutePackageDBPaths, + absolutePackageDBPath, + + -- * Support for optimisation levels + OptimisationLevel(..), + flagToOptimisationLevel, + + -- * Support for debug info levels + DebugInfoLevel(..), + flagToDebugInfoLevel, + + -- * Support for language extensions + CompilerFlag, + languageToFlags, + unsupportedLanguages, + extensionsToFlags, + unsupportedExtensions, + parmakeSupported, + reexportedModulesSupported, + renamingPackageFlagsSupported, + unifiedIPIDRequired, + packageKeySupported, + unitIdSupported, + coverageSupported, + profilingSupported, + backpackSupported, + arResponseFilesSupported, + arDashLSupported, + libraryDynDirSupported, + libraryVisibilitySupported, + + -- * Support for profiling detail levels + ProfDetailLevel(..), + knownProfDetailLevels, + flagToProfDetailLevel, + showProfDetailLevel, + ) where + +import Prelude () +import Distribution.Compat.Prelude +import Distribution.Pretty + +import Distribution.Compiler +import Distribution.Version +import Language.Haskell.Extension +import Distribution.Simple.Utils + +import qualified Data.Map as Map (lookup) +import System.Directory (canonicalizePath) + +data Compiler = Compiler { + compilerId :: CompilerId, + -- ^ Compiler flavour and version. + compilerAbiTag :: AbiTag, + -- ^ Tag for distinguishing incompatible ABI's on the same + -- architecture/os. + compilerCompat :: [CompilerId], + -- ^ Other implementations that this compiler claims to be + -- compatible with. + compilerLanguages :: [(Language, CompilerFlag)], + -- ^ Supported language standards. + compilerExtensions :: [(Extension, Maybe CompilerFlag)], + -- ^ Supported extensions. + compilerProperties :: Map String String + -- ^ A key-value map for properties not covered by the above fields. + } + deriving (Eq, Generic, Typeable, Show, Read) + +instance Binary Compiler +instance Structured Compiler + +showCompilerId :: Compiler -> String +showCompilerId = prettyShow . compilerId + +showCompilerIdWithAbi :: Compiler -> String +showCompilerIdWithAbi comp = + prettyShow (compilerId comp) ++ + case compilerAbiTag comp of + NoAbiTag -> [] + AbiTag xs -> '-':xs + +compilerFlavor :: Compiler -> CompilerFlavor +compilerFlavor = (\(CompilerId f _) -> f) . compilerId + +compilerVersion :: Compiler -> Version +compilerVersion = (\(CompilerId _ v) -> v) . compilerId + + +-- | Is this compiler compatible with the compiler flavour we're interested in? +-- +-- For example this checks if the compiler is actually GHC or is another +-- compiler that claims to be compatible with some version of GHC, e.g. GHCJS. +-- +-- > if compilerCompatFlavor GHC compiler then ... else ... +-- +compilerCompatFlavor :: CompilerFlavor -> Compiler -> Bool +compilerCompatFlavor flavor comp = + flavor == compilerFlavor comp + || flavor `elem` [ flavor' | CompilerId flavor' _ <- compilerCompat comp ] + + +-- | Is this compiler compatible with the compiler flavour we're interested in, +-- and if so what version does it claim to be compatible with. +-- +-- For example this checks if the compiler is actually GHC-7.x or is another +-- compiler that claims to be compatible with some GHC-7.x version. +-- +-- > case compilerCompatVersion GHC compiler of +-- > Just (Version (7:_)) -> ... +-- > _ -> ... +-- +compilerCompatVersion :: CompilerFlavor -> Compiler -> Maybe Version +compilerCompatVersion flavor comp + | compilerFlavor comp == flavor = Just (compilerVersion comp) + | otherwise = + listToMaybe [ v | CompilerId fl v <- compilerCompat comp, fl == flavor ] + +compilerInfo :: Compiler -> CompilerInfo +compilerInfo c = CompilerInfo (compilerId c) + (compilerAbiTag c) + (Just . compilerCompat $ c) + (Just . map fst . compilerLanguages $ c) + (Just . map fst . compilerExtensions $ c) + +-- ------------------------------------------------------------ +-- * Package databases +-- ------------------------------------------------------------ + +-- |Some compilers have a notion of a database of available packages. +-- For some there is just one global db of packages, other compilers +-- support a per-user or an arbitrary db specified at some location in +-- the file system. This can be used to build isolated environments of +-- packages, for example to build a collection of related packages +-- without installing them globally. +-- +data PackageDB = GlobalPackageDB + | UserPackageDB + | SpecificPackageDB FilePath + deriving (Eq, Generic, Ord, Show, Read, Typeable) + +instance Binary PackageDB +instance Structured PackageDB + +-- | We typically get packages from several databases, and stack them +-- together. This type lets us be explicit about that stacking. For example +-- typical stacks include: +-- +-- > [GlobalPackageDB] +-- > [GlobalPackageDB, UserPackageDB] +-- > [GlobalPackageDB, SpecificPackageDB "package.conf.inplace"] +-- +-- Note that the 'GlobalPackageDB' is invariably at the bottom since it +-- contains the rts, base and other special compiler-specific packages. +-- +-- We are not restricted to using just the above combinations. In particular +-- we can use several custom package dbs and the user package db together. +-- +-- When it comes to writing, the top most (last) package is used. +-- +type PackageDBStack = [PackageDB] + +-- | Return the package that we should register into. This is the package db at +-- the top of the stack. +-- +registrationPackageDB :: PackageDBStack -> PackageDB +registrationPackageDB dbs = case safeLast dbs of + Nothing -> error "internal error: empty package db set" + Just p -> p + +-- | Make package paths absolute + + +absolutePackageDBPaths :: PackageDBStack -> IO PackageDBStack +absolutePackageDBPaths = traverse absolutePackageDBPath + +absolutePackageDBPath :: PackageDB -> IO PackageDB +absolutePackageDBPath GlobalPackageDB = return GlobalPackageDB +absolutePackageDBPath UserPackageDB = return UserPackageDB +absolutePackageDBPath (SpecificPackageDB db) = + SpecificPackageDB `liftM` canonicalizePath db + +-- ------------------------------------------------------------ +-- * Optimisation levels +-- ------------------------------------------------------------ + +-- | Some compilers support optimising. Some have different levels. +-- For compilers that do not the level is just capped to the level +-- they do support. +-- +data OptimisationLevel = NoOptimisation + | NormalOptimisation + | MaximumOptimisation + deriving (Bounded, Enum, Eq, Generic, Read, Show, Typeable) + +instance Binary OptimisationLevel +instance Structured OptimisationLevel + +flagToOptimisationLevel :: Maybe String -> OptimisationLevel +flagToOptimisationLevel Nothing = NormalOptimisation +flagToOptimisationLevel (Just s) = case reads s of + [(i, "")] + | i >= fromEnum (minBound :: OptimisationLevel) + && i <= fromEnum (maxBound :: OptimisationLevel) + -> toEnum i + | otherwise -> error $ "Bad optimisation level: " ++ show i + ++ ". Valid values are 0..2" + _ -> error $ "Can't parse optimisation level " ++ s + +-- ------------------------------------------------------------ +-- * Debug info levels +-- ------------------------------------------------------------ + +-- | Some compilers support emitting debug info. Some have different +-- levels. For compilers that do not the level is just capped to the +-- level they do support. +-- +data DebugInfoLevel = NoDebugInfo + | MinimalDebugInfo + | NormalDebugInfo + | MaximalDebugInfo + deriving (Bounded, Enum, Eq, Generic, Read, Show, Typeable) + +instance Binary DebugInfoLevel +instance Structured DebugInfoLevel + +flagToDebugInfoLevel :: Maybe String -> DebugInfoLevel +flagToDebugInfoLevel Nothing = NormalDebugInfo +flagToDebugInfoLevel (Just s) = case reads s of + [(i, "")] + | i >= fromEnum (minBound :: DebugInfoLevel) + && i <= fromEnum (maxBound :: DebugInfoLevel) + -> toEnum i + | otherwise -> error $ "Bad debug info level: " ++ show i + ++ ". Valid values are 0..3" + _ -> error $ "Can't parse debug info level " ++ s + +-- ------------------------------------------------------------ +-- * Languages and Extensions +-- ------------------------------------------------------------ + +unsupportedLanguages :: Compiler -> [Language] -> [Language] +unsupportedLanguages comp langs = + [ lang | lang <- langs + , isNothing (languageToFlag comp lang) ] + +languageToFlags :: Compiler -> Maybe Language -> [CompilerFlag] +languageToFlags comp = filter (not . null) + . catMaybes . map (languageToFlag comp) + . maybe [Haskell98] (\x->[x]) + +languageToFlag :: Compiler -> Language -> Maybe CompilerFlag +languageToFlag comp ext = lookup ext (compilerLanguages comp) + + +-- |For the given compiler, return the extensions it does not support. +unsupportedExtensions :: Compiler -> [Extension] -> [Extension] +unsupportedExtensions comp exts = + [ ext | ext <- exts + , isNothing (extensionToFlag' comp ext) ] + +type CompilerFlag = String + +-- |For the given compiler, return the flags for the supported extensions. +extensionsToFlags :: Compiler -> [Extension] -> [CompilerFlag] +extensionsToFlags comp = nub . filter (not . null) + . catMaybes . map (extensionToFlag comp) + +-- | Looks up the flag for a given extension, for a given compiler. +-- Ignores the subtlety of extensions which lack associated flags. +extensionToFlag :: Compiler -> Extension -> Maybe CompilerFlag +extensionToFlag comp ext = join (extensionToFlag' comp ext) + +-- | Looks up the flag for a given extension, for a given compiler. +-- However, the extension may be valid for the compiler but not have a flag. +-- For example, NondecreasingIndentation is enabled by default on GHC 7.0.4, +-- hence it is considered a supported extension but not an accepted flag. +-- +-- The outer layer of Maybe indicates whether the extensions is supported, while +-- the inner layer indicates whether it has a flag. +-- When building strings, it is often more convenient to use 'extensionToFlag', +-- which ignores the difference. +extensionToFlag' :: Compiler -> Extension -> Maybe (Maybe CompilerFlag) +extensionToFlag' comp ext = lookup ext (compilerExtensions comp) + +-- | Does this compiler support parallel --make mode? +parmakeSupported :: Compiler -> Bool +parmakeSupported = ghcSupported "Support parallel --make" + +-- | Does this compiler support reexported-modules? +reexportedModulesSupported :: Compiler -> Bool +reexportedModulesSupported = ghcSupported "Support reexported-modules" + +-- | Does this compiler support thinning/renaming on package flags? +renamingPackageFlagsSupported :: Compiler -> Bool +renamingPackageFlagsSupported = ghcSupported + "Support thinning and renaming package flags" + +-- | Does this compiler have unified IPIDs (so no package keys) +unifiedIPIDRequired :: Compiler -> Bool +unifiedIPIDRequired = ghcSupported "Requires unified installed package IDs" + +-- | Does this compiler support package keys? +packageKeySupported :: Compiler -> Bool +packageKeySupported = ghcSupported "Uses package keys" + +-- | Does this compiler support unit IDs? +unitIdSupported :: Compiler -> Bool +unitIdSupported = ghcSupported "Uses unit IDs" + +-- | Does this compiler support Backpack? +backpackSupported :: Compiler -> Bool +backpackSupported = ghcSupported "Support Backpack" + +-- | Does this compiler support a package database entry with: +-- "dynamic-library-dirs"? +libraryDynDirSupported :: Compiler -> Bool +libraryDynDirSupported comp = case compilerFlavor comp of + GHC -> + -- Not just v >= mkVersion [8,0,1,20161022], as there + -- are many GHC 8.1 nightlies which don't support this. + ((v >= mkVersion [8,0,1,20161022] && v < mkVersion [8,1]) || + v >= mkVersion [8,1,20161021]) + _ -> False + where + v = compilerVersion comp + +-- | Does this compiler's "ar" command supports response file +-- arguments (i.e. @file-style arguments). +arResponseFilesSupported :: Compiler -> Bool +arResponseFilesSupported = ghcSupported "ar supports at file" + +-- | Does this compiler's "ar" command support llvm-ar's -L flag, +-- which compels the archiver to add an input archive's members +-- rather than adding the archive itself. +arDashLSupported :: Compiler -> Bool +arDashLSupported = ghcSupported "ar supports -L" + +-- | Does this compiler support Haskell program coverage? +coverageSupported :: Compiler -> Bool +coverageSupported comp = + case compilerFlavor comp of + GHC -> True + GHCJS -> True + _ -> False + +-- | Does this compiler support profiling? +profilingSupported :: Compiler -> Bool +profilingSupported comp = + case compilerFlavor comp of + GHC -> True + GHCJS -> True + _ -> False + +-- | Does this compiler support a package database entry with: +-- "visibility"? +libraryVisibilitySupported :: Compiler -> Bool +libraryVisibilitySupported comp = case compilerFlavor comp of + GHC -> v >= mkVersion [8,8] + _ -> False + where + v = compilerVersion comp + +-- | Utility function for GHC only features +ghcSupported :: String -> Compiler -> Bool +ghcSupported key comp = + case compilerFlavor comp of + GHC -> checkProp + GHCJS -> checkProp + _ -> False + where checkProp = + case Map.lookup key (compilerProperties comp) of + Just "YES" -> True + _ -> False + +-- ------------------------------------------------------------ +-- * Profiling detail level +-- ------------------------------------------------------------ + +-- | Some compilers (notably GHC) support profiling and can instrument +-- programs so the system can account costs to different functions. There are +-- different levels of detail that can be used for this accounting. +-- For compilers that do not support this notion or the particular detail +-- levels, this is either ignored or just capped to some similar level +-- they do support. +-- +data ProfDetailLevel = ProfDetailNone + | ProfDetailDefault + | ProfDetailExportedFunctions + | ProfDetailToplevelFunctions + | ProfDetailAllFunctions + | ProfDetailOther String + deriving (Eq, Generic, Read, Show, Typeable) + +instance Binary ProfDetailLevel +instance Structured ProfDetailLevel + +flagToProfDetailLevel :: String -> ProfDetailLevel +flagToProfDetailLevel "" = ProfDetailDefault +flagToProfDetailLevel s = + case lookup (lowercase s) + [ (name, value) + | (primary, aliases, value) <- knownProfDetailLevels + , name <- primary : aliases ] + of Just value -> value + Nothing -> ProfDetailOther s + +knownProfDetailLevels :: [(String, [String], ProfDetailLevel)] +knownProfDetailLevels = + [ ("default", [], ProfDetailDefault) + , ("none", [], ProfDetailNone) + , ("exported-functions", ["exported"], ProfDetailExportedFunctions) + , ("toplevel-functions", ["toplevel", "top"], ProfDetailToplevelFunctions) + , ("all-functions", ["all"], ProfDetailAllFunctions) + ] + +showProfDetailLevel :: ProfDetailLevel -> String +showProfDetailLevel dl = case dl of + ProfDetailNone -> "none" + ProfDetailDefault -> "default" + ProfDetailExportedFunctions -> "exported-functions" + ProfDetailToplevelFunctions -> "toplevel-functions" + ProfDetailAllFunctions -> "all-functions" + ProfDetailOther other -> other diff --git a/cabal/Cabal/src/Distribution/Simple/Configure.hs b/cabal/Cabal/src/Distribution/Simple/Configure.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/Configure.hs @@ -0,0 +1,2129 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NoMonoLocalBinds #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Configure +-- Copyright : Isaac Jones 2003-2005 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This deals with the /configure/ phase. It provides the 'configure' action +-- which is given the package description and configure flags. It then tries +-- to: configure the compiler; resolves any conditionals in the package +-- description; resolve the package dependencies; check if all the extensions +-- used by this package are supported by the compiler; check that all the build +-- tools are available (including version checks if appropriate); checks for +-- any required @pkg-config@ packages (updating the 'BuildInfo' with the +-- results) +-- +-- Then based on all this it saves the info in the 'LocalBuildInfo' and writes +-- it out to the @dist\/setup-config@ file. It also displays various details to +-- the user, the amount of information displayed depending on the verbosity +-- level. + +module Distribution.Simple.Configure + ( configure + , writePersistBuildConfig + , getConfigStateFile + , getPersistBuildConfig + , checkPersistBuildConfigOutdated + , tryGetPersistBuildConfig + , maybeGetPersistBuildConfig + , findDistPref, findDistPrefOrDefault + , getInternalLibraries + , computeComponentId + , computeCompatPackageKey + , localBuildInfoFile + , getInstalledPackages + , getInstalledPackagesMonitorFiles + , getPackageDBContents + , configCompilerEx, configCompilerAuxEx + , computeEffectiveProfiling + , ccLdOptionsBuildInfo + , checkForeignDeps + , interpretPackageDbFlags + , ConfigStateFileError(..) + , tryGetConfigStateFile + , platformDefines, + ) where + +import qualified Prelude as Unsafe (tail) +import Distribution.Compat.Prelude + +import Distribution.Compiler +import Distribution.Types.IncludeRenaming +import Distribution.Utils.NubList +import Distribution.Simple.Compiler +import Distribution.Simple.PreProcess +import Distribution.Package +import qualified Distribution.InstalledPackageInfo as IPI +import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.PackageIndex (InstalledPackageIndex) +import Distribution.PackageDescription +import Distribution.PackageDescription.PrettyPrint +import Distribution.PackageDescription.Configuration +import Distribution.PackageDescription.Check hiding (doesFileExist) +import Distribution.Simple.BuildToolDepends +import Distribution.Simple.Program +import Distribution.Simple.Setup as Setup +import Distribution.Simple.BuildTarget +import Distribution.Simple.LocalBuildInfo +import Distribution.Types.PackageVersionConstraint +import Distribution.Types.LocalBuildInfo +import Distribution.Types.ComponentRequestedSpec +import Distribution.Types.GivenComponent +import Distribution.Simple.Utils +import Distribution.System +import Distribution.Version +import Distribution.Verbosity +import qualified Distribution.Compat.Graph as Graph +import Distribution.Compat.Stack +import Distribution.Backpack.Configure +import Distribution.Backpack.DescribeUnitId +import Distribution.Backpack.PreExistingComponent +import Distribution.Backpack.ConfiguredComponent (newPackageDepsBehaviour) +import Distribution.Backpack.Id +import Distribution.Utils.LogProgress + +import qualified Distribution.Simple.GHC as GHC +import qualified Distribution.Simple.GHCJS as GHCJS +import qualified Distribution.Simple.UHC as UHC +import qualified Distribution.Simple.HaskellSuite as HaskellSuite + +import Control.Exception + ( try ) +import Distribution.Utils.Structured ( structuredDecodeOrFailIO, structuredEncode ) +import Distribution.Compat.Directory ( listDirectory ) +import Data.ByteString.Lazy ( ByteString ) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy.Char8 as BLC8 +import Data.List + ( (\\), inits, stripPrefix, intersect) +import qualified Data.Map as Map +import System.Directory + ( canonicalizePath, createDirectoryIfMissing, doesFileExist + , getTemporaryDirectory, removeFile) +import System.FilePath + ( (), isAbsolute, takeDirectory ) +import Distribution.Compat.Directory + ( doesPathExist ) +import qualified System.Info + ( compilerName, compilerVersion ) +import System.IO + ( hPutStrLn, hClose ) +import Distribution.Pretty + ( pretty, defaultStyle, prettyShow ) +import Distribution.Parsec + ( simpleParsec ) +import Text.PrettyPrint + ( Doc, ($+$), char, comma, hsep, nest + , punctuate, quotes, render, renderStyle, sep, text ) +import Distribution.Compat.Environment ( lookupEnv ) + +import qualified Data.Set as Set +import qualified Distribution.Compat.NonEmptySet as NES + + +type UseExternalInternalDeps = Bool + +-- | The errors that can be thrown when reading the @setup-config@ file. +data ConfigStateFileError + = ConfigStateFileNoHeader -- ^ No header found. + | ConfigStateFileBadHeader -- ^ Incorrect header. + | ConfigStateFileNoParse -- ^ Cannot parse file contents. + | ConfigStateFileMissing -- ^ No file! + | ConfigStateFileBadVersion PackageIdentifier PackageIdentifier + (Either ConfigStateFileError LocalBuildInfo) -- ^ Mismatched version. + deriving (Typeable) + +-- | Format a 'ConfigStateFileError' as a user-facing error message. +dispConfigStateFileError :: ConfigStateFileError -> Doc +dispConfigStateFileError ConfigStateFileNoHeader = + text "Saved package config file header is missing." + <+> text "Re-run the 'configure' command." +dispConfigStateFileError ConfigStateFileBadHeader = + text "Saved package config file header is corrupt." + <+> text "Re-run the 'configure' command." +dispConfigStateFileError ConfigStateFileNoParse = + text "Saved package config file is corrupt." + <+> text "Re-run the 'configure' command." +dispConfigStateFileError ConfigStateFileMissing = + text "Run the 'configure' command first." +dispConfigStateFileError (ConfigStateFileBadVersion oldCabal oldCompiler _) = + text "Saved package config file is outdated:" + $+$ badCabal $+$ badCompiler + $+$ text "Re-run the 'configure' command." + where + badCabal = + text "• the Cabal version changed from" + <+> pretty oldCabal <+> "to" <+> pretty currentCabalId + badCompiler + | oldCompiler == currentCompilerId = mempty + | otherwise = + text "• the compiler changed from" + <+> pretty oldCompiler <+> "to" <+> pretty currentCompilerId + +instance Show ConfigStateFileError where + show = renderStyle defaultStyle . dispConfigStateFileError + +instance Exception ConfigStateFileError + +-- | Read the 'localBuildInfoFile'. Throw an exception if the file is +-- missing, if the file cannot be read, or if the file was created by an older +-- version of Cabal. +getConfigStateFile :: FilePath -- ^ The file path of the @setup-config@ file. + -> IO LocalBuildInfo +getConfigStateFile filename = do + exists <- doesFileExist filename + unless exists $ throwIO ConfigStateFileMissing + -- Read the config file into a strict ByteString to avoid problems with + -- lazy I/O, then convert to lazy because the binary package needs that. + contents <- BS.readFile filename + let (header, body) = BLC8.span (/='\n') (BLC8.fromChunks [contents]) + + (cabalId, compId) <- parseHeader header + + let getStoredValue = do + result <- structuredDecodeOrFailIO (BLC8.tail body) + case result of + Left _ -> throwIO ConfigStateFileNoParse + Right x -> return x + deferErrorIfBadVersion act + | cabalId /= currentCabalId = do + eResult <- try act + throwIO $ ConfigStateFileBadVersion cabalId compId eResult + | otherwise = act + deferErrorIfBadVersion getStoredValue + where + _ = callStack -- TODO: attach call stack to exception + +-- | Read the 'localBuildInfoFile', returning either an error or the local build +-- info. +tryGetConfigStateFile :: FilePath -- ^ The file path of the @setup-config@ file. + -> IO (Either ConfigStateFileError LocalBuildInfo) +tryGetConfigStateFile = try . getConfigStateFile + +-- | Try to read the 'localBuildInfoFile'. +tryGetPersistBuildConfig :: FilePath -- ^ The @dist@ directory path. + -> IO (Either ConfigStateFileError LocalBuildInfo) +tryGetPersistBuildConfig = try . getPersistBuildConfig + +-- | Read the 'localBuildInfoFile'. Throw an exception if the file is +-- missing, if the file cannot be read, or if the file was created by an older +-- version of Cabal. +getPersistBuildConfig :: FilePath -- ^ The @dist@ directory path. + -> IO LocalBuildInfo +getPersistBuildConfig = getConfigStateFile . localBuildInfoFile + +-- | Try to read the 'localBuildInfoFile'. +maybeGetPersistBuildConfig :: FilePath -- ^ The @dist@ directory path. + -> IO (Maybe LocalBuildInfo) +maybeGetPersistBuildConfig = + liftM (either (const Nothing) Just) . tryGetPersistBuildConfig + +-- | After running configure, output the 'LocalBuildInfo' to the +-- 'localBuildInfoFile'. +writePersistBuildConfig :: FilePath -- ^ The @dist@ directory path. + -> LocalBuildInfo -- ^ The 'LocalBuildInfo' to write. + -> IO () +writePersistBuildConfig distPref lbi = do + createDirectoryIfMissing False distPref + writeFileAtomic (localBuildInfoFile distPref) $ + BLC8.unlines [showHeader pkgId, structuredEncode lbi] + where + pkgId = localPackage lbi + +-- | Identifier of the current Cabal package. +currentCabalId :: PackageIdentifier +currentCabalId = PackageIdentifier (mkPackageName "Cabal") cabalVersion + +-- | Identifier of the current compiler package. +currentCompilerId :: PackageIdentifier +currentCompilerId = PackageIdentifier (mkPackageName System.Info.compilerName) + (mkVersion' System.Info.compilerVersion) + +-- | Parse the @setup-config@ file header, returning the package identifiers +-- for Cabal and the compiler. +parseHeader :: ByteString -- ^ The file contents. + -> IO (PackageIdentifier, PackageIdentifier) +parseHeader header = case BLC8.words header of + ["Saved", "package", "config", "for", pkgId, "written", "by", cabalId, + "using", compId] -> + maybe (throwIO ConfigStateFileBadHeader) return $ do + _ <- simpleParsec (fromUTF8LBS pkgId) :: Maybe PackageIdentifier + cabalId' <- simpleParsec (BLC8.unpack cabalId) + compId' <- simpleParsec (BLC8.unpack compId) + return (cabalId', compId') + _ -> throwIO ConfigStateFileNoHeader + +-- | Generate the @setup-config@ file header. +showHeader :: PackageIdentifier -- ^ The processed package. + -> ByteString +showHeader pkgId = BLC8.unwords + [ "Saved", "package", "config", "for" + , toUTF8LBS $ prettyShow pkgId + , "written", "by" + , BLC8.pack $ prettyShow currentCabalId + , "using" + , BLC8.pack $ prettyShow currentCompilerId + ] + +-- | Check that localBuildInfoFile is up-to-date with respect to the +-- .cabal file. +checkPersistBuildConfigOutdated :: FilePath -> FilePath -> IO Bool +checkPersistBuildConfigOutdated distPref pkg_descr_file = + pkg_descr_file `moreRecentFile` localBuildInfoFile distPref + +-- | Get the path of @dist\/setup-config@. +localBuildInfoFile :: FilePath -- ^ The @dist@ directory path. + -> FilePath +localBuildInfoFile distPref = distPref "setup-config" + +-- ----------------------------------------------------------------------------- +-- * Configuration +-- ----------------------------------------------------------------------------- + +-- | Return the \"dist/\" prefix, or the default prefix. The prefix is taken +-- from (in order of highest to lowest preference) the override prefix, the +-- \"CABAL_BUILDDIR\" environment variable, or the default prefix. +findDistPref :: FilePath -- ^ default \"dist\" prefix + -> Setup.Flag FilePath -- ^ override \"dist\" prefix + -> IO FilePath +findDistPref defDistPref overrideDistPref = do + envDistPref <- liftM parseEnvDistPref (lookupEnv "CABAL_BUILDDIR") + return $ fromFlagOrDefault defDistPref (mappend envDistPref overrideDistPref) + where + parseEnvDistPref env = + case env of + Just distPref | not (null distPref) -> toFlag distPref + _ -> NoFlag + +-- | Return the \"dist/\" prefix, or the default prefix. The prefix is taken +-- from (in order of highest to lowest preference) the override prefix, the +-- \"CABAL_BUILDDIR\" environment variable, or 'defaultDistPref' is used. Call +-- this function to resolve a @*DistPref@ flag whenever it is not known to be +-- set. (The @*DistPref@ flags are always set to a definite value before +-- invoking 'UserHooks'.) +findDistPrefOrDefault :: Setup.Flag FilePath -- ^ override \"dist\" prefix + -> IO FilePath +findDistPrefOrDefault = findDistPref defaultDistPref + +-- |Perform the \"@.\/setup configure@\" action. +-- Returns the @.setup-config@ file. +configure :: (GenericPackageDescription, HookedBuildInfo) + -> ConfigFlags -> IO LocalBuildInfo +configure (pkg_descr0, pbi) cfg = do + -- Determine the component we are configuring, if a user specified + -- one on the command line. We use a fake, flattened version of + -- the package since at this point, we're not really sure what + -- components we *can* configure. @Nothing@ means that we should + -- configure everything (the old behavior). + (mb_cname :: Maybe ComponentName) <- do + let flat_pkg_descr = flattenPackageDescription pkg_descr0 + targets <- readBuildTargets verbosity flat_pkg_descr (configArgs cfg) + -- TODO: bleat if you use the module/file syntax + let targets' = [ cname | BuildTargetComponent cname <- targets ] + case targets' of + _ | null (configArgs cfg) -> return Nothing + [cname] -> return (Just cname) + [] -> die' verbosity "No valid component targets found" + _ -> die' verbosity + "Can only configure either single component or all of them" + + let use_external_internal_deps = isJust mb_cname + case mb_cname of + Nothing -> setupMessage verbosity "Configuring" (packageId pkg_descr0) + Just cname -> setupMessage' verbosity "Configuring" (packageId pkg_descr0) + cname (Just (configInstantiateWith cfg)) + + -- configCID is only valid for per-component configure + when (isJust (flagToMaybe (configCID cfg)) && isNothing mb_cname) $ + die' verbosity "--cid is only supported for per-component configure" + + checkDeprecatedFlags verbosity cfg + checkExactConfiguration verbosity pkg_descr0 cfg + + -- Where to build the package + let buildDir :: FilePath -- e.g. dist/build + -- fromFlag OK due to Distribution.Simple calling + -- findDistPrefOrDefault to fill it in + buildDir = fromFlag (configDistPref cfg) "build" + createDirectoryIfMissingVerbose (lessVerbose verbosity) True buildDir + + -- What package database(s) to use + let packageDbs :: PackageDBStack + packageDbs + = interpretPackageDbFlags + (fromFlag (configUserInstall cfg)) + (configPackageDBs cfg) + + -- comp: the compiler we're building with + -- compPlatform: the platform we're building for + -- programDb: location and args of all programs we're + -- building with + (comp :: Compiler, + compPlatform :: Platform, + programDb :: ProgramDb) + <- configCompilerEx + (flagToMaybe (configHcFlavor cfg)) + (flagToMaybe (configHcPath cfg)) + (flagToMaybe (configHcPkg cfg)) + (mkProgramDb cfg (configPrograms cfg)) + (lessVerbose verbosity) + + -- The InstalledPackageIndex of all installed packages + installedPackageSet :: InstalledPackageIndex + <- getInstalledPackages (lessVerbose verbosity) comp + packageDbs programDb + + -- The set of package names which are "shadowed" by internal + -- packages, and which component they map to + let internalPackageSet :: Set LibraryName + internalPackageSet = getInternalLibraries pkg_descr0 + + -- Make a data structure describing what components are enabled. + let enabled :: ComponentRequestedSpec + enabled = case mb_cname of + Just cname -> OneComponentRequestedSpec cname + Nothing -> ComponentRequestedSpec + -- The flag name (@--enable-tests@) is a + -- little bit of a misnomer, because + -- just passing this flag won't + -- "enable", in our internal + -- nomenclature; it's just a request; a + -- @buildable: False@ might make it + -- not possible to enable. + { testsRequested = fromFlag (configTests cfg) + , benchmarksRequested = + fromFlag (configBenchmarks cfg) } + -- Some sanity checks related to enabling components. + when (isJust mb_cname + && (fromFlag (configTests cfg) || fromFlag (configBenchmarks cfg))) $ + die' verbosity $ + "--enable-tests/--enable-benchmarks are incompatible with" ++ + " explicitly specifying a component to configure." + + -- Some sanity checks related to dynamic/static linking. + when (fromFlag (configDynExe cfg) && fromFlag (configFullyStaticExe cfg)) $ + die' verbosity $ + "--enable-executable-dynamic and --enable-executable-static" ++ + " are incompatible with each other." + + -- allConstraints: The set of all 'Dependency's we have. Used ONLY + -- to 'configureFinalizedPackage'. + -- requiredDepsMap: A map from 'PackageName' to the specifically + -- required 'InstalledPackageInfo', due to --dependency + -- + -- NB: These constraints are to be applied to ALL components of + -- a package. Thus, it's not an error if allConstraints contains + -- more constraints than is necessary for a component (another + -- component might need it.) + -- + -- NB: The fact that we bundle all the constraints together means + -- that is not possible to configure a test-suite to use one + -- version of a dependency, and the executable to use another. + (allConstraints :: [PackageVersionConstraint], + requiredDepsMap :: Map (PackageName, ComponentName) InstalledPackageInfo) + <- either (die' verbosity) return $ + combinedConstraints (configConstraints cfg) + (configDependencies cfg) + installedPackageSet + + -- pkg_descr: The resolved package description, that does not contain any + -- conditionals, because we have an assignment for + -- every flag, either picking them ourselves using a + -- simple naive algorithm, or having them be passed to + -- us by 'configConfigurationsFlags') + -- flags: The 'FlagAssignment' that the conditionals were + -- resolved with. + -- + -- NB: Why doesn't finalizing a package also tell us what the + -- dependencies are (e.g. when we run the naive algorithm, + -- we are checking if dependencies are satisfiable)? The + -- primary reason is that we may NOT have done any solving: + -- if the flags are all chosen for us, this step is a simple + -- matter of flattening according to that assignment. It's + -- cleaner to then configure the dependencies afterwards. + (pkg_descr :: PackageDescription, + flags :: FlagAssignment) + <- configureFinalizedPackage verbosity cfg enabled + allConstraints + (dependencySatisfiable + use_external_internal_deps + (fromFlagOrDefault False (configExactConfiguration cfg)) + (fromFlagOrDefault False (configAllowDependingOnPrivateLibs cfg)) + (packageName pkg_descr0) + installedPackageSet + internalPackageSet + requiredDepsMap) + comp + compPlatform + pkg_descr0 + + debug verbosity $ "Finalized package description:\n" + ++ showPackageDescription pkg_descr + + let cabalFileDir = maybe "." takeDirectory $ + flagToMaybe (configCabalFilePath cfg) + checkCompilerProblems verbosity comp pkg_descr enabled + checkPackageProblems verbosity cabalFileDir pkg_descr0 + (updatePackageDescription pbi pkg_descr) + + -- The list of 'InstalledPackageInfo' recording the selected + -- dependencies on external packages. + -- + -- Invariant: For any package name, there is at most one package + -- in externalPackageDeps which has that name. + -- + -- NB: The dependency selection is global over ALL components + -- in the package (similar to how allConstraints and + -- requiredDepsMap are global over all components). In particular, + -- if *any* component (post-flag resolution) has an unsatisfiable + -- dependency, we will fail. This can sometimes be undesirable + -- for users, see #1786 (benchmark conflicts with executable), + -- + -- In the presence of Backpack, these package dependencies are + -- NOT complete: they only ever include the INDEFINITE + -- dependencies. After we apply an instantiation, we'll get + -- definite references which constitute extra dependencies. + -- (Why not have cabal-install pass these in explicitly? + -- For one it's deterministic; for two, we need to associate + -- them with renamings which would require a far more complicated + -- input scheme than what we have today.) + externalPkgDeps :: [PreExistingComponent] + <- configureDependencies + verbosity + use_external_internal_deps + internalPackageSet + installedPackageSet + requiredDepsMap + pkg_descr + enabled + + -- Compute installation directory templates, based on user + -- configuration. + -- + -- TODO: Move this into a helper function. + defaultDirs :: InstallDirTemplates + <- defaultInstallDirs' use_external_internal_deps + (compilerFlavor comp) + (fromFlag (configUserInstall cfg)) + (hasLibs pkg_descr) + let installDirs :: InstallDirTemplates + installDirs = combineInstallDirs fromFlagOrDefault + defaultDirs (configInstallDirs cfg) + + -- Check languages and extensions + -- TODO: Move this into a helper function. + let langlist = nub $ catMaybes $ map defaultLanguage + (enabledBuildInfos pkg_descr enabled) + let langs = unsupportedLanguages comp langlist + when (not (null langs)) $ + die' verbosity $ "The package " ++ prettyShow (packageId pkg_descr0) + ++ " requires the following languages which are not " + ++ "supported by " ++ prettyShow (compilerId comp) ++ ": " + ++ intercalate ", " (map prettyShow langs) + let extlist = nub $ concatMap allExtensions + (enabledBuildInfos pkg_descr enabled) + let exts = unsupportedExtensions comp extlist + when (not (null exts)) $ + die' verbosity $ "The package " ++ prettyShow (packageId pkg_descr0) + ++ " requires the following language extensions which are not " + ++ "supported by " ++ prettyShow (compilerId comp) ++ ": " + ++ intercalate ", " (map prettyShow exts) + + -- Check foreign library build requirements + let flibs = [flib | CFLib flib <- enabledComponents pkg_descr enabled] + let unsupportedFLibs = unsupportedForeignLibs comp compPlatform flibs + when (not (null unsupportedFLibs)) $ + die' verbosity $ "Cannot build some foreign libraries: " + ++ intercalate "," unsupportedFLibs + + -- Configure certain external build tools, see below for which ones. + let requiredBuildTools = do + bi <- enabledBuildInfos pkg_descr enabled + -- First, we collect any tool dep that we know is external. This is, + -- in practice: + -- + -- 1. `build-tools` entries on the whitelist + -- + -- 2. `build-tool-depends` that aren't from the current package. + let externBuildToolDeps = + [ LegacyExeDependency (unUnqualComponentName eName) versionRange + | buildTool@(ExeDependency _ eName versionRange) + <- getAllToolDependencies pkg_descr bi + , not $ isInternal pkg_descr buildTool ] + -- Second, we collect any build-tools entry we don't know how to + -- desugar. We'll never have any idea how to build them, so we just + -- hope they are already on the PATH. + let unknownBuildTools = + [ buildTool + | buildTool <- buildTools bi + , Nothing == desugarBuildTool pkg_descr buildTool ] + externBuildToolDeps ++ unknownBuildTools + + programDb' <- + configureAllKnownPrograms (lessVerbose verbosity) programDb + >>= configureRequiredPrograms verbosity requiredBuildTools + + (pkg_descr', programDb'') <- + configurePkgconfigPackages verbosity pkg_descr programDb' enabled + + -- Compute internal component graph + -- + -- The general idea is that we take a look at all the source level + -- components (which may build-depends on each other) and form a graph. + -- From there, we build a ComponentLocalBuildInfo for each of the + -- components, which lets us actually build each component. + -- internalPackageSet + -- use_external_internal_deps + (buildComponents :: [ComponentLocalBuildInfo], + packageDependsIndex :: InstalledPackageIndex) <- + runLogProgress verbosity $ configureComponentLocalBuildInfos + verbosity + use_external_internal_deps + enabled + (fromFlagOrDefault False (configDeterministic cfg)) + (configIPID cfg) + (configCID cfg) + pkg_descr + externalPkgDeps + (configConfigurationsFlags cfg) + (configInstantiateWith cfg) + installedPackageSet + comp + + -- Decide if we're going to compile with split sections. + split_sections :: Bool <- + if not (fromFlag $ configSplitSections cfg) + then return False + else case compilerFlavor comp of + GHC | compilerVersion comp >= mkVersion [8,0] + -> return True + GHCJS + -> return True + _ -> do warn verbosity + ("this compiler does not support " ++ + "--enable-split-sections; ignoring") + return False + + -- Decide if we're going to compile with split objects. + split_objs :: Bool <- + if not (fromFlag $ configSplitObjs cfg) + then return False + else case compilerFlavor comp of + _ | split_sections + -> do warn verbosity + ("--enable-split-sections and " ++ + "--enable-split-objs are mutually" ++ + "exclusive; ignoring the latter") + return False + GHC + -> return True + GHCJS + -> return True + _ -> do warn verbosity + ("this compiler does not support " ++ + "--enable-split-objs; ignoring") + return False + + let compilerSupportsGhciLibs :: Bool + compilerSupportsGhciLibs = + case compilerId comp of + CompilerId GHC version + | version > mkVersion [9,3] && windows -> + False + CompilerId GHC _ -> + True + CompilerId GHCJS _ -> + True + _ -> False + where + windows = case compPlatform of + Platform _ Windows -> True + Platform _ _ -> False + + let ghciLibByDefault = + case compilerId comp of + CompilerId GHC _ -> + -- If ghc is non-dynamic, then ghci needs object files, + -- so we build one by default. + -- + -- Technically, archive files should be sufficient for ghci, + -- but because of GHC bug #8942, it has never been safe to + -- rely on them. By the time that bug was fixed, ghci had + -- been changed to read shared libraries instead of archive + -- files (see next code block). + not (GHC.isDynamic comp) + CompilerId GHCJS _ -> + not (GHCJS.isDynamic comp) + _ -> False + + withGHCiLib_ <- + case fromFlagOrDefault ghciLibByDefault (configGHCiLib cfg) of + True | not compilerSupportsGhciLibs -> do + warn verbosity $ + "--enable-library-for-ghci is no longer supported on Windows with" + ++ " GHC 9.4 and later; ignoring..." + return False + v -> return v + + let sharedLibsByDefault + | fromFlag (configDynExe cfg) = + -- build a shared library if dynamically-linked + -- executables are requested + True + | otherwise = case compilerId comp of + CompilerId GHC _ -> + -- if ghc is dynamic, then ghci needs a shared + -- library, so we build one by default. + GHC.isDynamic comp + CompilerId GHCJS _ -> + GHCJS.isDynamic comp + _ -> False + withSharedLib_ = + -- build shared libraries if required by GHC or by the + -- executable linking mode, but allow the user to force + -- building only static library archives with + -- --disable-shared. + fromFlagOrDefault sharedLibsByDefault $ configSharedLib cfg + + withStaticLib_ = + -- build a static library (all dependent libraries rolled + -- into a huge .a archive) via GHCs -staticlib flag. + fromFlagOrDefault False $ configStaticLib cfg + + withDynExe_ = fromFlag $ configDynExe cfg + + withFullyStaticExe_ = fromFlag $ configFullyStaticExe cfg + + when (withDynExe_ && not withSharedLib_) $ warn verbosity $ + "Executables will use dynamic linking, but a shared library " + ++ "is not being built. Linking will fail if any executables " + ++ "depend on the library." + + setProfLBI <- configureProfiling verbosity cfg comp + + setCoverageLBI <- configureCoverage verbosity cfg comp + + + + -- Turn off library and executable stripping when `debug-info` is set + -- to anything other than zero. + let + strip_libexe s f = + let defaultStrip = fromFlagOrDefault True (f cfg) + in case fromFlag (configDebugInfo cfg) of + NoDebugInfo -> return defaultStrip + _ -> case f cfg of + Flag True -> do + warn verbosity $ "Setting debug-info implies " + ++ s ++ "-stripping: False" + return False + + _ -> return False + + strip_lib <- strip_libexe "library" configStripLibs + strip_exe <- strip_libexe "executable" configStripExes + + + let reloc = fromFlagOrDefault False $ configRelocatable cfg + + let buildComponentsMap = + foldl' (\m clbi -> Map.insertWith (++) + (componentLocalName clbi) [clbi] m) + Map.empty buildComponents + + let lbi = (setCoverageLBI . setProfLBI) + LocalBuildInfo { + configFlags = cfg, + flagAssignment = flags, + componentEnabledSpec = enabled, + extraConfigArgs = [], -- Currently configure does not + -- take extra args, but if it + -- did they would go here. + installDirTemplates = installDirs, + compiler = comp, + hostPlatform = compPlatform, + buildDir = buildDir, + cabalFilePath = flagToMaybe (configCabalFilePath cfg), + componentGraph = Graph.fromDistinctList buildComponents, + componentNameMap = buildComponentsMap, + installedPkgs = packageDependsIndex, + pkgDescrFile = Nothing, + localPkgDescr = pkg_descr', + withPrograms = programDb'', + withVanillaLib = fromFlag $ configVanillaLib cfg, + withSharedLib = withSharedLib_, + withStaticLib = withStaticLib_, + withDynExe = withDynExe_, + withFullyStaticExe = withFullyStaticExe_, + withProfLib = False, + withProfLibDetail = ProfDetailNone, + withProfExe = False, + withProfExeDetail = ProfDetailNone, + withOptimization = fromFlag $ configOptimization cfg, + withDebugInfo = fromFlag $ configDebugInfo cfg, + withGHCiLib = withGHCiLib_, + splitSections = split_sections, + splitObjs = split_objs, + stripExes = strip_exe, + stripLibs = strip_lib, + exeCoverage = False, + libCoverage = False, + withPackageDB = packageDbs, + progPrefix = fromFlag $ configProgPrefix cfg, + progSuffix = fromFlag $ configProgSuffix cfg, + relocatable = reloc + } + + when reloc (checkRelocatable verbosity pkg_descr lbi) + + -- TODO: This is not entirely correct, because the dirs may vary + -- across libraries/executables + let dirs = absoluteInstallDirs pkg_descr lbi NoCopyDest + relative = prefixRelativeInstallDirs (packageId pkg_descr) lbi + + -- PKGROOT: allowing ${pkgroot} to be passed as --prefix to + -- cabal configure, is only a hidden option. It allows packages + -- to be relocatable with their package database. This however + -- breaks when the Paths_* or other includes are used that + -- contain hard coded paths. This is still an open TODO. + -- + -- Allowing ${pkgroot} here, however requires less custom hooks + -- in scripts that *really* want ${pkgroot}. See haskell/cabal/#4872 + unless (isAbsolute (prefix dirs) + || "${pkgroot}" `isPrefixOf` prefix dirs) $ die' verbosity $ + "expected an absolute directory name for --prefix: " ++ prefix dirs + + when ("${pkgroot}" `isPrefixOf` prefix dirs) $ + warn verbosity $ "Using ${pkgroot} in prefix " ++ prefix dirs + ++ " will not work if you rely on the Path_* module " + ++ " or other hard coded paths. Cabal does not yet " + ++ " support fully relocatable builds! " + ++ " See #462 #2302 #2994 #3305 #3473 #3586 #3909" + ++ " #4097 #4291 #4872" + + info verbosity $ "Using " ++ prettyShow currentCabalId + ++ " compiled by " ++ prettyShow currentCompilerId + info verbosity $ "Using compiler: " ++ showCompilerId comp + info verbosity $ "Using install prefix: " ++ prefix dirs + + let dirinfo name dir isPrefixRelative = + info verbosity $ name ++ " installed in: " ++ dir ++ relNote + where relNote = case buildOS of + Windows | not (hasLibs pkg_descr) + && isNothing isPrefixRelative + -> " (fixed location)" + _ -> "" + + dirinfo "Executables" (bindir dirs) (bindir relative) + dirinfo "Libraries" (libdir dirs) (libdir relative) + dirinfo "Dynamic Libraries" (dynlibdir dirs) (dynlibdir relative) + dirinfo "Private executables" (libexecdir dirs) (libexecdir relative) + dirinfo "Data files" (datadir dirs) (datadir relative) + dirinfo "Documentation" (docdir dirs) (docdir relative) + dirinfo "Configuration files" (sysconfdir dirs) (sysconfdir relative) + + sequence_ [ reportProgram verbosity prog configuredProg + | (prog, configuredProg) <- knownPrograms programDb'' ] + + return lbi + + where + verbosity = fromFlag (configVerbosity cfg) + +mkProgramDb :: ConfigFlags -> ProgramDb -> ProgramDb +mkProgramDb cfg initialProgramDb = programDb + where + programDb = userSpecifyArgss (configProgramArgs cfg) + . userSpecifyPaths (configProgramPaths cfg) + . setProgramSearchPath searchpath + $ initialProgramDb + searchpath = getProgramSearchPath initialProgramDb + ++ map ProgramSearchPathDir + (fromNubList $ configProgramPathExtra cfg) + +-- ----------------------------------------------------------------------------- +-- Helper functions for configure + +-- | Check if the user used any deprecated flags. +checkDeprecatedFlags :: Verbosity -> ConfigFlags -> IO () +checkDeprecatedFlags verbosity cfg = do + unless (configProfExe cfg == NoFlag) $ do + let enable | fromFlag (configProfExe cfg) = "enable" + | otherwise = "disable" + warn verbosity + ("The flag --" ++ enable ++ "-executable-profiling is deprecated. " + ++ "Please use --" ++ enable ++ "-profiling instead.") + + unless (configLibCoverage cfg == NoFlag) $ do + let enable | fromFlag (configLibCoverage cfg) = "enable" + | otherwise = "disable" + warn verbosity + ("The flag --" ++ enable ++ "-library-coverage is deprecated. " + ++ "Please use --" ++ enable ++ "-coverage instead.") + +-- | Sanity check: if '--exact-configuration' was given, ensure that the +-- complete flag assignment was specified on the command line. +checkExactConfiguration + :: Verbosity -> GenericPackageDescription -> ConfigFlags -> IO () +checkExactConfiguration verbosity pkg_descr0 cfg = + when (fromFlagOrDefault False (configExactConfiguration cfg)) $ do + let cmdlineFlags = map fst (unFlagAssignment (configConfigurationsFlags cfg)) + allFlags = map flagName . genPackageFlags $ pkg_descr0 + diffFlags = allFlags \\ cmdlineFlags + when (not . null $ diffFlags) $ + die' verbosity $ "'--exact-configuration' was given, " + ++ "but the following flags were not specified: " + ++ intercalate ", " (map show diffFlags) + +-- | Create a PackageIndex that makes *any libraries that might be* +-- defined internally to this package look like installed packages, in +-- case an executable should refer to any of them as dependencies. +-- +-- It must be *any libraries that might be* defined rather than the +-- actual definitions, because these depend on conditionals in the .cabal +-- file, and we haven't resolved them yet. finalizePD +-- does the resolution of conditionals, and it takes internalPackageSet +-- as part of its input. +getInternalLibraries :: GenericPackageDescription + -> Set LibraryName +getInternalLibraries pkg_descr0 = + -- TODO: some day, executables will be fair game here too! + let pkg_descr = flattenPackageDescription pkg_descr0 + in Set.fromList (map libName (allLibraries pkg_descr)) + +-- | Returns true if a dependency is satisfiable. This function may +-- report a dependency satisfiable even when it is not, but not vice +-- versa. This is to be passed to finalize +dependencySatisfiable + :: Bool -- ^ use external internal deps? + -> Bool -- ^ exact configuration? + -> Bool -- ^ allow depending on private libs? + -> PackageName + -> InstalledPackageIndex -- ^ installed set + -> Set LibraryName -- ^ library components + -> Map (PackageName, ComponentName) InstalledPackageInfo + -- ^ required dependencies + -> (Dependency -> Bool) +dependencySatisfiable + use_external_internal_deps + exact_config + allow_private_deps + pn installedPackageSet packageLibraries requiredDepsMap + (Dependency depName vr sublibs) + | exact_config + -- When we're given '--exact-configuration', we assume that all + -- dependencies and flags are exactly specified on the command + -- line. Thus we only consult the 'requiredDepsMap'. Note that + -- we're not doing the version range check, so if there's some + -- dependency that wasn't specified on the command line, + -- 'finalizePD' will fail. + -- TODO: mention '--exact-configuration' in the error message + -- when this fails? + = if isInternalDep && not use_external_internal_deps + -- Except for internal deps, when we're NOT per-component mode; + -- those are just True. + then internalDepSatisfiable + else + -- Backward compatibility for the old sublibrary syntax + (sublibs == mainLibSet + && Map.member + (pn, CLibName $ LSubLibName $ + packageNameToUnqualComponentName depName) + requiredDepsMap) + + || all visible sublibs + + | isInternalDep + = if use_external_internal_deps + -- When we are doing per-component configure, we now need to + -- test if the internal dependency is in the index. This has + -- DIFFERENT semantics from normal dependency satisfiability. + then internalDepSatisfiableExternally + -- If a 'PackageName' is defined by an internal component, the dep is + -- satisfiable (we're going to build it ourselves) + else internalDepSatisfiable + + | otherwise + = depSatisfiable + + where + -- Internal dependency is when dependency is the same as package. + isInternalDep = pn == depName + + depSatisfiable = + not . null $ PackageIndex.lookupDependency installedPackageSet depName vr + + internalDepSatisfiable = + Set.isSubsetOf (NES.toSet sublibs) packageLibraries + internalDepSatisfiableExternally = + all (\ln -> not $ null $ PackageIndex.lookupInternalDependency installedPackageSet pn vr ln) sublibs + + -- Check whether a library exists and is visible. + -- We don't disambiguate between dependency on non-existent or private + -- library yet, so we just return a bool and later report a generic error. + visible lib = maybe + False -- Does not even exist (wasn't in the depsMap) + (\ipi -> IPI.libVisibility ipi == LibraryVisibilityPublic + -- If the override is enabled, the visibility does + -- not matter (it's handled externally) + || allow_private_deps + -- If it's a library of the same package then it's + -- always visible. + -- This is only triggered when passing a component + -- of the same package as --dependency, such as in: + -- cabal-testsuite/PackageTests/ConfigureComponent/SubLib/setup-explicit.test.hs + || pkgName (IPI.sourcePackageId ipi) == pn) + maybeIPI + where maybeIPI = Map.lookup (depName, CLibName lib) requiredDepsMap + +-- | Finalize a generic package description. The workhorse is +-- 'finalizePD' but there's a bit of other nattering +-- about necessary. +-- +-- TODO: what exactly is the business with @flaggedTests@ and +-- @flaggedBenchmarks@? +configureFinalizedPackage + :: Verbosity + -> ConfigFlags + -> ComponentRequestedSpec + -> [PackageVersionConstraint] + -> (Dependency -> Bool) -- ^ tests if a dependency is satisfiable. + -- Might say it's satisfiable even when not. + -> Compiler + -> Platform + -> GenericPackageDescription + -> IO (PackageDescription, FlagAssignment) +configureFinalizedPackage verbosity cfg enabled + allConstraints satisfies comp compPlatform pkg_descr0 = do + + (pkg_descr0', flags) <- + case finalizePD + (configConfigurationsFlags cfg) + enabled + satisfies + compPlatform + (compilerInfo comp) + allConstraints + pkg_descr0 + of Right r -> return r + Left missing -> + die' verbosity $ "Encountered missing or private dependencies:\n" + ++ (render . nest 4 . sep . punctuate comma + . map (pretty . simplifyDependency) + $ missing) + + -- add extra include/lib dirs as specified in cfg + -- we do it here so that those get checked too + let pkg_descr = addExtraIncludeLibDirs pkg_descr0' + + unless (nullFlagAssignment flags) $ + info verbosity $ "Flags chosen: " + ++ intercalate ", " [ unFlagName fn ++ "=" ++ prettyShow value + | (fn, value) <- unFlagAssignment flags ] + + return (pkg_descr, flags) + where + addExtraIncludeLibDirs pkg_descr = + let extraBi = mempty { extraLibDirs = configExtraLibDirs cfg + , extraLibDirsStatic = configExtraLibDirsStatic cfg + , extraFrameworkDirs = configExtraFrameworkDirs cfg + , includeDirs = configExtraIncludeDirs cfg} + modifyLib l = l{ libBuildInfo = libBuildInfo l + `mappend` extraBi } + modifyExecutable e = e{ buildInfo = buildInfo e + `mappend` extraBi} + modifyForeignLib f = f{ foreignLibBuildInfo = foreignLibBuildInfo f + `mappend` extraBi} + modifyTestsuite t = t{ testBuildInfo = testBuildInfo t + `mappend` extraBi} + modifyBenchmark b = b{ benchmarkBuildInfo = benchmarkBuildInfo b + `mappend` extraBi} + in pkg_descr + { library = modifyLib `fmap` library pkg_descr + , subLibraries = modifyLib `map` subLibraries pkg_descr + , executables = modifyExecutable `map` executables pkg_descr + , foreignLibs = modifyForeignLib `map` foreignLibs pkg_descr + , testSuites = modifyTestsuite `map` testSuites pkg_descr + , benchmarks = modifyBenchmark `map` benchmarks pkg_descr + } + +-- | Check for use of Cabal features which require compiler support +checkCompilerProblems + :: Verbosity -> Compiler -> PackageDescription -> ComponentRequestedSpec -> IO () +checkCompilerProblems verbosity comp pkg_descr enabled = do + unless (renamingPackageFlagsSupported comp || + all (all (isDefaultIncludeRenaming . mixinIncludeRenaming) . mixins) + (enabledBuildInfos pkg_descr enabled)) $ + die' verbosity $ + "Your compiler does not support thinning and renaming on " + ++ "package flags. To use this feature you must use " + ++ "GHC 7.9 or later." + + when (any (not.null.reexportedModules) (allLibraries pkg_descr) + && not (reexportedModulesSupported comp)) $ + die' verbosity $ + "Your compiler does not support module re-exports. To use " + ++ "this feature you must use GHC 7.9 or later." + + when (any (not.null.signatures) (allLibraries pkg_descr) + && not (backpackSupported comp)) $ + die' verbosity $ + "Your compiler does not support Backpack. To use " + ++ "this feature you must use GHC 8.1 or later." + +-- | Select dependencies for the package. +configureDependencies + :: Verbosity + -> UseExternalInternalDeps + -> Set LibraryName + -> InstalledPackageIndex -- ^ installed packages + -> Map (PackageName, ComponentName) InstalledPackageInfo -- ^ required deps + -> PackageDescription + -> ComponentRequestedSpec + -> IO [PreExistingComponent] +configureDependencies verbosity use_external_internal_deps + packageLibraries installedPackageSet requiredDepsMap pkg_descr enableSpec = do + let failedDeps :: [FailedDependency] + allPkgDeps :: [ResolvedDependency] + (failedDeps, allPkgDeps) = partitionEithers $ concat + [ fmap (\s -> (dep, s)) <$> status + | dep <- enabledBuildDepends pkg_descr enableSpec + , let status = selectDependency (package pkg_descr) + packageLibraries installedPackageSet + requiredDepsMap use_external_internal_deps dep ] + + internalPkgDeps = [ pkgid + | (_, InternalDependency pkgid) <- allPkgDeps ] + -- NB: we have to SAVE the package name, because this is the only + -- way we can be able to resolve package names in the package + -- description. + externalPkgDeps = [ pec + | (_, ExternalDependency pec) <- allPkgDeps ] + + when (not (null internalPkgDeps) + && not (newPackageDepsBehaviour pkg_descr)) $ + die' verbosity $ "The field 'build-depends: " + ++ intercalate ", " (map (prettyShow . packageName) internalPkgDeps) + ++ "' refers to a library which is defined within the same " + ++ "package. To use this feature the package must specify at " + ++ "least 'cabal-version: >= 1.8'." + + reportFailedDependencies verbosity failedDeps + reportSelectedDependencies verbosity allPkgDeps + + return externalPkgDeps + +-- | Select and apply coverage settings for the build based on the +-- 'ConfigFlags' and 'Compiler'. +configureCoverage :: Verbosity -> ConfigFlags -> Compiler + -> IO (LocalBuildInfo -> LocalBuildInfo) +configureCoverage verbosity cfg comp = do + let tryExeCoverage = fromFlagOrDefault False (configCoverage cfg) + tryLibCoverage = fromFlagOrDefault tryExeCoverage + (mappend (configCoverage cfg) (configLibCoverage cfg)) + if coverageSupported comp + then do + let apply lbi = lbi { libCoverage = tryLibCoverage + , exeCoverage = tryExeCoverage + } + return apply + else do + let apply lbi = lbi { libCoverage = False + , exeCoverage = False + } + when (tryExeCoverage || tryLibCoverage) $ warn verbosity + ("The compiler " ++ showCompilerId comp ++ " does not support " + ++ "program coverage. Program coverage has been disabled.") + return apply + +-- | Compute the effective value of the profiling flags +-- @--enable-library-profiling@ and @--enable-executable-profiling@ +-- from the specified 'ConfigFlags'. This may be useful for +-- external Cabal tools which need to interact with Setup in +-- a backwards-compatible way: the most predictable mechanism +-- for enabling profiling across many legacy versions is to +-- NOT use @--enable-profiling@ and use those two flags instead. +-- +-- Note that @--enable-executable-profiling@ also affects profiling +-- of benchmarks and (non-detailed) test suites. +computeEffectiveProfiling :: ConfigFlags -> (Bool {- lib -}, Bool {- exe -}) +computeEffectiveProfiling cfg = + -- The --profiling flag sets the default for both libs and exes, + -- but can be overridden by --library-profiling, or the old deprecated + -- --executable-profiling flag. + -- + -- The --profiling-detail and --library-profiling-detail flags behave + -- similarly + let tryExeProfiling = fromFlagOrDefault False + (mappend (configProf cfg) (configProfExe cfg)) + tryLibProfiling = fromFlagOrDefault tryExeProfiling + (mappend (configProf cfg) (configProfLib cfg)) + in (tryLibProfiling, tryExeProfiling) + +-- | Select and apply profiling settings for the build based on the +-- 'ConfigFlags' and 'Compiler'. +configureProfiling :: Verbosity -> ConfigFlags -> Compiler + -> IO (LocalBuildInfo -> LocalBuildInfo) +configureProfiling verbosity cfg comp = do + let (tryLibProfiling, tryExeProfiling) = computeEffectiveProfiling cfg + + tryExeProfileLevel = fromFlagOrDefault ProfDetailDefault + (configProfDetail cfg) + tryLibProfileLevel = fromFlagOrDefault ProfDetailDefault + (mappend + (configProfDetail cfg) + (configProfLibDetail cfg)) + + checkProfileLevel (ProfDetailOther other) = do + warn verbosity + ("Unknown profiling detail level '" ++ other + ++ "', using default.\nThe profiling detail levels are: " + ++ intercalate ", " + [ name | (name, _, _) <- knownProfDetailLevels ]) + return ProfDetailDefault + checkProfileLevel other = return other + + (exeProfWithoutLibProf, applyProfiling) <- + if profilingSupported comp + then do + exeLevel <- checkProfileLevel tryExeProfileLevel + libLevel <- checkProfileLevel tryLibProfileLevel + let apply lbi = lbi { withProfLib = tryLibProfiling + , withProfLibDetail = libLevel + , withProfExe = tryExeProfiling + , withProfExeDetail = exeLevel + } + return (tryExeProfiling && not tryLibProfiling, apply) + else do + let apply lbi = lbi { withProfLib = False + , withProfLibDetail = ProfDetailNone + , withProfExe = False + , withProfExeDetail = ProfDetailNone + } + when (tryExeProfiling || tryLibProfiling) $ warn verbosity + ("The compiler " ++ showCompilerId comp ++ " does not support " + ++ "profiling. Profiling has been disabled.") + return (False, apply) + + when exeProfWithoutLibProf $ warn verbosity + ("Executables will be built with profiling, but library " + ++ "profiling is disabled. Linking will fail if any executables " + ++ "depend on the library.") + + return applyProfiling + +-- ----------------------------------------------------------------------------- +-- Configuring package dependencies + +reportProgram :: Verbosity -> Program -> Maybe ConfiguredProgram -> IO () +reportProgram verbosity prog Nothing + = info verbosity $ "No " ++ programName prog ++ " found" +reportProgram verbosity prog (Just configuredProg) + = info verbosity $ "Using " ++ programName prog ++ version ++ location + where location = case programLocation configuredProg of + FoundOnSystem p -> " found on system at: " ++ p + UserSpecified p -> " given by user at: " ++ p + version = case programVersion configuredProg of + Nothing -> "" + Just v -> " version " ++ prettyShow v + +hackageUrl :: String +hackageUrl = "http://hackage.haskell.org/package/" + +type ResolvedDependency = (Dependency, DependencyResolution) + +data DependencyResolution + -- | An external dependency from the package database, OR an + -- internal dependency which we are getting from the package + -- database. + = ExternalDependency PreExistingComponent + -- | An internal dependency ('PackageId' should be a library name) + -- which we are going to have to build. (The + -- 'PackageId' here is a hack to get a modest amount of + -- polymorphism out of the 'Package' typeclass.) + | InternalDependency PackageId + +data FailedDependency = DependencyNotExists PackageName + | DependencyMissingInternal PackageName LibraryName + | DependencyNoVersion Dependency + +-- | Test for a package dependency and record the version we have installed. +selectDependency :: PackageId -- ^ Package id of current package + -> Set LibraryName -- ^ package libraries + -> InstalledPackageIndex -- ^ Installed packages + -> Map (PackageName, ComponentName) InstalledPackageInfo + -- ^ Packages for which we have been given specific deps to + -- use + -> UseExternalInternalDeps -- ^ Are we configuring a + -- single component? + -> Dependency + -> [Either FailedDependency DependencyResolution] +selectDependency pkgid internalIndex installedIndex requiredDepsMap + use_external_internal_deps + (Dependency dep_pkgname vr libs) = + -- If the dependency specification matches anything in the internal package + -- index, then we prefer that match to anything in the second. + -- For example: + -- + -- Name: MyLibrary + -- Version: 0.1 + -- Library + -- .. + -- Executable my-exec + -- build-depends: MyLibrary + -- + -- We want "build-depends: MyLibrary" always to match the internal library + -- even if there is a newer installed library "MyLibrary-0.2". + if dep_pkgname == pn + then + if use_external_internal_deps + then do_external_internal <$> NES.toList libs + else do_internal <$> NES.toList libs + else + do_external_external <$> NES.toList libs + where + pn = packageName pkgid + + -- It's an internal library, and we're not per-component build + do_internal lib + | Set.member lib internalIndex + = Right $ InternalDependency $ PackageIdentifier dep_pkgname $ packageVersion pkgid + + | otherwise + = Left $ DependencyMissingInternal dep_pkgname lib + + -- We have to look it up externally + do_external_external :: LibraryName -> Either FailedDependency DependencyResolution + do_external_external lib = do + ipi <- case Map.lookup (dep_pkgname, CLibName lib) requiredDepsMap of + -- If we know the exact pkg to use, then use it. + Just pkginstance -> Right pkginstance + -- Otherwise we just pick an arbitrary instance of the latest version. + Nothing -> case pickLastIPI $ PackageIndex.lookupInternalDependency installedIndex dep_pkgname vr lib of + Nothing -> Left (DependencyNotExists dep_pkgname) + Just pkg -> Right pkg + return $ ExternalDependency $ ipiToPreExistingComponent ipi + + do_external_internal :: LibraryName -> Either FailedDependency DependencyResolution + do_external_internal lib = do + ipi <- case Map.lookup (dep_pkgname, CLibName lib) requiredDepsMap of + -- If we know the exact pkg to use, then use it. + Just pkginstance -> Right pkginstance + Nothing -> case pickLastIPI $ PackageIndex.lookupInternalDependency installedIndex pn vr lib of + -- It's an internal library, being looked up externally + Nothing -> Left (DependencyMissingInternal dep_pkgname lib) + Just pkg -> Right pkg + return $ ExternalDependency $ ipiToPreExistingComponent ipi + + pickLastIPI :: [(Version, [InstalledPackageInfo])] -> Maybe InstalledPackageInfo + pickLastIPI pkgs = safeHead . snd . last =<< nonEmpty pkgs + +reportSelectedDependencies :: Verbosity + -> [ResolvedDependency] -> IO () +reportSelectedDependencies verbosity deps = + info verbosity $ unlines + [ "Dependency " ++ prettyShow (simplifyDependency dep) + ++ ": using " ++ prettyShow pkgid + | (dep, resolution) <- deps + , let pkgid = case resolution of + ExternalDependency pkg' -> packageId pkg' + InternalDependency pkgid' -> pkgid' ] + +reportFailedDependencies :: Verbosity -> [FailedDependency] -> IO () +reportFailedDependencies _ [] = return () +reportFailedDependencies verbosity failed = + die' verbosity (intercalate "\n\n" (map reportFailedDependency failed)) + + where + reportFailedDependency (DependencyNotExists pkgname) = + "there is no version of " ++ prettyShow pkgname ++ " installed.\n" + ++ "Perhaps you need to download and install it from\n" + ++ hackageUrl ++ prettyShow pkgname ++ "?" + + reportFailedDependency (DependencyMissingInternal pkgname lib) = + "internal dependency " ++ prettyShow (prettyLibraryNameComponent lib) ++ " not installed.\n" + ++ "Perhaps you need to configure and install it first?\n" + ++ "(This library was defined by " ++ prettyShow pkgname ++ ")" + + reportFailedDependency (DependencyNoVersion dep) = + "cannot satisfy dependency " ++ prettyShow (simplifyDependency dep) ++ "\n" + +-- | List all installed packages in the given package databases. +-- Non-existent package databases do not cause errors, they just get skipped +-- with a warning and treated as empty ones, since technically they do not +-- contain any package. +getInstalledPackages :: Verbosity -> Compiler + -> PackageDBStack -- ^ The stack of package databases. + -> ProgramDb + -> IO InstalledPackageIndex +getInstalledPackages verbosity comp packageDBs progdb = do + when (null packageDBs) $ + die' verbosity $ "No package databases have been specified. If you use " + ++ "--package-db=clear, you must follow it with --package-db= " + ++ "with 'global', 'user' or a specific file." + + info verbosity "Reading installed packages..." + -- do not check empty packagedbs (ghc-pkg would error out) + packageDBs' <- filterM packageDBExists packageDBs + case compilerFlavor comp of + GHC -> GHC.getInstalledPackages verbosity comp packageDBs' progdb + GHCJS -> GHCJS.getInstalledPackages verbosity packageDBs' progdb + UHC -> UHC.getInstalledPackages verbosity comp packageDBs' progdb + HaskellSuite {} -> + HaskellSuite.getInstalledPackages verbosity packageDBs' progdb + flv -> die' verbosity $ "don't know how to find the installed packages for " + ++ prettyShow flv + where + packageDBExists (SpecificPackageDB path) = do + exists <- doesPathExist path + unless exists $ + warn verbosity $ "Package db " <> path <> " does not exist yet" + return exists + -- Checking the user and global package dbs is more complicated and needs + -- way more data. Also ghc-pkg won't error out unless the user/global + -- pkgdb is overridden with an empty one, so we just don't check for them. + packageDBExists UserPackageDB = pure True + packageDBExists GlobalPackageDB = pure True + +-- | Like 'getInstalledPackages', but for a single package DB. +-- +-- NB: Why isn't this always a fall through to 'getInstalledPackages'? +-- That is because 'getInstalledPackages' performs some sanity checks +-- on the package database stack in question. However, when sandboxes +-- are involved these sanity checks are not desirable. +getPackageDBContents :: Verbosity -> Compiler + -> PackageDB -> ProgramDb + -> IO InstalledPackageIndex +getPackageDBContents verbosity comp packageDB progdb = do + info verbosity "Reading installed packages..." + case compilerFlavor comp of + GHC -> GHC.getPackageDBContents verbosity packageDB progdb + GHCJS -> GHCJS.getPackageDBContents verbosity packageDB progdb + -- For other compilers, try to fall back on 'getInstalledPackages'. + _ -> getInstalledPackages verbosity comp [packageDB] progdb + + +-- | A set of files (or directories) that can be monitored to detect when +-- there might have been a change in the installed packages. +-- +getInstalledPackagesMonitorFiles :: Verbosity -> Compiler + -> PackageDBStack + -> ProgramDb -> Platform + -> IO [FilePath] +getInstalledPackagesMonitorFiles verbosity comp packageDBs progdb platform = + case compilerFlavor comp of + GHC -> GHC.getInstalledPackagesMonitorFiles + verbosity platform progdb packageDBs + other -> do + warn verbosity $ "don't know how to find change monitoring files for " + ++ "the installed package databases for " ++ prettyShow other + return [] + +-- | The user interface specifies the package dbs to use with a combination of +-- @--global@, @--user@ and @--package-db=global|user|clear|$file@. +-- This function combines the global/user flag and interprets the package-db +-- flag into a single package db stack. +-- +interpretPackageDbFlags :: Bool -> [Maybe PackageDB] -> PackageDBStack +interpretPackageDbFlags userInstall specificDBs = + extra initialStack specificDBs + where + initialStack | userInstall = [GlobalPackageDB, UserPackageDB] + | otherwise = [GlobalPackageDB] + + extra dbs' [] = dbs' + extra _ (Nothing:dbs) = extra [] dbs + extra dbs' (Just db:dbs) = extra (dbs' ++ [db]) dbs + +-- We are given both --constraint="foo < 2.0" style constraints and also +-- specific packages to pick via --dependency="foo=foo-2.0-177d5cdf20962d0581". +-- +-- When finalising the package we have to take into account the specific +-- installed deps we've been given, and the finalise function expects +-- constraints, so we have to translate these deps into version constraints. +-- +-- But after finalising we then have to make sure we pick the right specific +-- deps in the end. So we still need to remember which installed packages to +-- pick. +combinedConstraints + :: [PackageVersionConstraint] + -> [GivenComponent] + -> InstalledPackageIndex + -> Either String ([PackageVersionConstraint], + Map (PackageName, ComponentName) InstalledPackageInfo) +combinedConstraints constraints dependencies installedPackages = do + + when (not (null badComponentIds)) $ + Left $ render $ text "The following package dependencies were requested" + $+$ nest 4 (dispDependencies badComponentIds) + $+$ text "however the given installed package instance does not exist." + + --TODO: we don't check that all dependencies are used! + + return (allConstraints, idConstraintMap) + + where + allConstraints :: [PackageVersionConstraint] + allConstraints = constraints + ++ [ thisPackageVersionConstraint (packageId pkg) + | (_, _, _, Just pkg) <- dependenciesPkgInfo ] + + idConstraintMap :: Map (PackageName, ComponentName) InstalledPackageInfo + idConstraintMap = Map.fromList + -- NB: do NOT use the packageName from + -- dependenciesPkgInfo! + [ ((pn, cname), pkg) + | (pn, cname, _, Just pkg) <- dependenciesPkgInfo ] + + -- The dependencies along with the installed package info, if it exists + dependenciesPkgInfo :: [(PackageName, ComponentName, ComponentId, + Maybe InstalledPackageInfo)] + dependenciesPkgInfo = + [ (pkgname, CLibName lname, cid, mpkg) + | GivenComponent pkgname lname cid <- dependencies + , let mpkg = PackageIndex.lookupComponentId + installedPackages cid + ] + + -- If we looked up a package specified by an installed package id + -- (i.e. someone has written a hash) and didn't find it then it's + -- an error. + badComponentIds = + [ (pkgname, cname, cid) + | (pkgname, cname, cid, Nothing) <- dependenciesPkgInfo ] + + dispDependencies deps = + hsep [ text "--dependency=" + <<>> quotes + (pretty pkgname + <<>> case cname of + CLibName LMainLibName -> "" + CLibName (LSubLibName n) -> ":" <<>> pretty n + _ -> ":" <<>> pretty cname + <<>> char '=' + <<>> pretty cid) + | (pkgname, cname, cid) <- deps ] + +-- ----------------------------------------------------------------------------- +-- Configuring program dependencies + +configureRequiredPrograms :: Verbosity -> [LegacyExeDependency] -> ProgramDb + -> IO ProgramDb +configureRequiredPrograms verbosity deps progdb = + foldM (configureRequiredProgram verbosity) progdb deps + +-- | Configure a required program, ensuring that it exists in the PATH +-- (or where the user has specified the program must live) and making it +-- available for use via the 'ProgramDb' interface. If the program is +-- known (exists in the input 'ProgramDb'), we will make sure that the +-- program matches the required version; otherwise we will accept +-- any version of the program and assume that it is a simpleProgram. +configureRequiredProgram :: Verbosity -> ProgramDb -> LegacyExeDependency + -> IO ProgramDb +configureRequiredProgram verbosity progdb + (LegacyExeDependency progName verRange) = + case lookupKnownProgram progName progdb of + Nothing -> + -- Try to configure it as a 'simpleProgram' automatically + -- + -- There's a bit of a story behind this line. In old versions + -- of Cabal, there were only internal build-tools dependencies. So the + -- behavior in this case was: + -- + -- - If a build-tool dependency was internal, don't do + -- any checking. + -- + -- - If it was external, call 'configureRequiredProgram' to + -- "configure" the executable. In particular, if + -- the program was not "known" (present in 'ProgramDb'), + -- then we would just error. This was fine, because + -- the only way a program could be executed from 'ProgramDb' + -- is if some library code from Cabal actually called it, + -- and the pre-existing Cabal code only calls known + -- programs from 'defaultProgramDb', and so if it + -- is calling something else, you have a Custom setup + -- script, and in that case you are expected to register + -- the program you want to call in the ProgramDb. + -- + -- OK, so that was fine, until I (ezyang, in 2016) refactored + -- Cabal to support per-component builds. In this case, what + -- was previously an internal build-tool dependency now became + -- an external one, and now previously "internal" dependencies + -- are now external. But these are permitted to exist even + -- when they are not previously configured (something that + -- can only occur by a Custom script.) + -- + -- So, I decided, "Fine, let's just accept these in any + -- case." Thus this line. The alternative would have been to + -- somehow detect when a build-tools dependency was "internal" (by + -- looking at the unflattened package description) but this + -- would also be incompatible with future work to support + -- external executable dependencies: we definitely cannot + -- assume they will be preinitialized in the 'ProgramDb'. + configureProgram verbosity (simpleProgram progName) progdb + Just prog + -- requireProgramVersion always requires the program have a version + -- but if the user says "build-depends: foo" ie no version constraint + -- then we should not fail if we cannot discover the program version. + | verRange == anyVersion -> do + (_, progdb') <- requireProgram verbosity prog progdb + return progdb' + | otherwise -> do + (_, _, progdb') <- requireProgramVersion verbosity prog verRange progdb + return progdb' + +-- ----------------------------------------------------------------------------- +-- Configuring pkg-config package dependencies + +configurePkgconfigPackages :: Verbosity -> PackageDescription + -> ProgramDb -> ComponentRequestedSpec + -> IO (PackageDescription, ProgramDb) +configurePkgconfigPackages verbosity pkg_descr progdb enabled + | null allpkgs = return (pkg_descr, progdb) + | otherwise = do + (_, _, progdb') <- requireProgramVersion + (lessVerbose verbosity) pkgConfigProgram + (orLaterVersion $ mkVersion [0,9,0]) progdb + traverse_ requirePkg allpkgs + mlib' <- traverse addPkgConfigBILib (library pkg_descr) + libs' <- traverse addPkgConfigBILib (subLibraries pkg_descr) + exes' <- traverse addPkgConfigBIExe (executables pkg_descr) + tests' <- traverse addPkgConfigBITest (testSuites pkg_descr) + benches' <- traverse addPkgConfigBIBench (benchmarks pkg_descr) + let pkg_descr' = pkg_descr { library = mlib', + subLibraries = libs', executables = exes', + testSuites = tests', benchmarks = benches' } + return (pkg_descr', progdb') + + where + allpkgs = concatMap pkgconfigDepends (enabledBuildInfos pkg_descr enabled) + pkgconfig = getDbProgramOutput (lessVerbose verbosity) + pkgConfigProgram progdb + + requirePkg dep@(PkgconfigDependency pkgn range) = do + version <- pkgconfig ["--modversion", pkg] + `catchIO` (\_ -> die' verbosity notFound) + `catchExit` (\_ -> die' verbosity notFound) + let trim = dropWhile isSpace . dropWhileEnd isSpace + let v = PkgconfigVersion (toUTF8BS $ trim version) + if not (withinPkgconfigVersionRange v range) + then die' verbosity (badVersion v) + else info verbosity (depSatisfied v) + where + notFound = "The pkg-config package '" ++ pkg ++ "'" + ++ versionRequirement + ++ " is required but it could not be found." + badVersion v = "The pkg-config package '" ++ pkg ++ "'" + ++ versionRequirement + ++ " is required but the version installed on the" + ++ " system is version " ++ prettyShow v + depSatisfied v = "Dependency " ++ prettyShow dep + ++ ": using version " ++ prettyShow v + + versionRequirement + | isAnyPkgconfigVersion range = "" + | otherwise = " version " ++ prettyShow range + + pkg = unPkgconfigName pkgn + + -- Adds pkgconfig dependencies to the build info for a component + addPkgConfigBI compBI setCompBI comp = do + bi <- pkgconfigBuildInfo (pkgconfigDepends (compBI comp)) + return $ setCompBI comp (compBI comp `mappend` bi) + + -- Adds pkgconfig dependencies to the build info for a library + addPkgConfigBILib = addPkgConfigBI libBuildInfo $ + \lib bi -> lib { libBuildInfo = bi } + + -- Adds pkgconfig dependencies to the build info for an executable + addPkgConfigBIExe = addPkgConfigBI buildInfo $ + \exe bi -> exe { buildInfo = bi } + + -- Adds pkgconfig dependencies to the build info for a test suite + addPkgConfigBITest = addPkgConfigBI testBuildInfo $ + \test bi -> test { testBuildInfo = bi } + + -- Adds pkgconfig dependencies to the build info for a benchmark + addPkgConfigBIBench = addPkgConfigBI benchmarkBuildInfo $ + \bench bi -> bench { benchmarkBuildInfo = bi } + + pkgconfigBuildInfo :: [PkgconfigDependency] -> IO BuildInfo + pkgconfigBuildInfo [] = return mempty + pkgconfigBuildInfo pkgdeps = do + let pkgs = nub [ prettyShow pkg | PkgconfigDependency pkg _ <- pkgdeps ] + ccflags <- pkgconfig ("--cflags" : pkgs) + ldflags <- pkgconfig ("--libs" : pkgs) + ldflags_static <- pkgconfig ("--libs" : "--static" : pkgs) + return (ccLdOptionsBuildInfo (words ccflags) (words ldflags) (words ldflags_static)) + +-- | Makes a 'BuildInfo' from C compiler and linker flags. +-- +-- This can be used with the output from configuration programs like pkg-config +-- and similar package-specific programs like mysql-config, freealut-config etc. +-- For example: +-- +-- > ccflags <- getDbProgramOutput verbosity prog progdb ["--cflags"] +-- > ldflags <- getDbProgramOutput verbosity prog progdb ["--libs"] +-- > ldflags_static <- getDbProgramOutput verbosity prog progdb ["--libs", "--static"] +-- > return (ccldOptionsBuildInfo (words ccflags) (words ldflags) (words ldflags_static)) +-- +ccLdOptionsBuildInfo :: [String] -> [String] -> [String] -> BuildInfo +ccLdOptionsBuildInfo cflags ldflags ldflags_static = + let (includeDirs', cflags') = partition ("-I" `isPrefixOf`) cflags + (extraLibs', ldflags') = partition ("-l" `isPrefixOf`) ldflags + (extraLibDirs', ldflags'') = partition ("-L" `isPrefixOf`) ldflags' + (extraLibsStatic') = filter ("-l" `isPrefixOf`) ldflags_static + (extraLibDirsStatic') = filter ("-L" `isPrefixOf`) ldflags_static + in mempty { + includeDirs = map (drop 2) includeDirs', + extraLibs = map (drop 2) extraLibs', + extraLibDirs = map (drop 2) extraLibDirs', + extraLibsStatic = map (drop 2) extraLibsStatic', + extraLibDirsStatic = map (drop 2) extraLibDirsStatic', + ccOptions = cflags', + ldOptions = ldflags'' + } + +-- ----------------------------------------------------------------------------- +-- Determining the compiler details + +configCompilerAuxEx :: ConfigFlags + -> IO (Compiler, Platform, ProgramDb) +configCompilerAuxEx cfg = configCompilerEx (flagToMaybe $ configHcFlavor cfg) + (flagToMaybe $ configHcPath cfg) + (flagToMaybe $ configHcPkg cfg) + programDb + (fromFlag (configVerbosity cfg)) + where + programDb = mkProgramDb cfg defaultProgramDb + +configCompilerEx :: Maybe CompilerFlavor -> Maybe FilePath -> Maybe FilePath + -> ProgramDb -> Verbosity + -> IO (Compiler, Platform, ProgramDb) +configCompilerEx Nothing _ _ _ verbosity = die' verbosity "Unknown compiler" +configCompilerEx (Just hcFlavor) hcPath hcPkg progdb verbosity = do + (comp, maybePlatform, programDb) <- case hcFlavor of + GHC -> GHC.configure verbosity hcPath hcPkg progdb + GHCJS -> GHCJS.configure verbosity hcPath hcPkg progdb + UHC -> UHC.configure verbosity hcPath hcPkg progdb + HaskellSuite {} -> HaskellSuite.configure verbosity hcPath hcPkg progdb + _ -> die' verbosity "Unknown compiler" + return (comp, fromMaybe buildPlatform maybePlatform, programDb) + +-- ----------------------------------------------------------------------------- +-- Testing C lib and header dependencies + +-- Try to build a test C program which includes every header and links every +-- lib. If that fails, try to narrow it down by preprocessing (only) and linking +-- with individual headers and libs. If none is the obvious culprit then give a +-- generic error message. +-- TODO: produce a log file from the compiler errors, if any. +checkForeignDeps :: PackageDescription -> LocalBuildInfo -> Verbosity -> IO () +checkForeignDeps pkg lbi verbosity = + ifBuildsWith allHeaders (commonCcArgs ++ makeLdArgs allLibs) -- I'm feeling + -- lucky + (return ()) + (do missingLibs <- findMissingLibs + missingHdr <- findOffendingHdr + explainErrors missingHdr missingLibs) + where + allHeaders = collectField includes + allLibs = collectField $ + if withFullyStaticExe lbi + then extraLibsStatic + else extraLibs + + ifBuildsWith headers args success failure = do + checkDuplicateHeaders + ok <- builds (makeProgram headers) args + if ok then success else failure + + -- Ensure that there is only one header with a given name + -- in either the generated (most likely by `configure`) + -- build directory (e.g. `dist/build`) or in the source directory. + -- + -- If it exists in both, we'll remove the one in the source + -- directory, as the generated should take precedence. + -- + -- C compilers like to prefer source local relative includes, + -- so the search paths provided to the compiler via -I are + -- ignored if the included file can be found relative to the + -- including file. As such we need to take drastic measures + -- and delete the offending file in the source directory. + checkDuplicateHeaders = do + let relIncDirs = filter (not . isAbsolute) (collectField includeDirs) + isHeader = isSuffixOf ".h" + genHeaders <- for relIncDirs $ \dir -> + fmap (dir ) . filter isHeader <$> + listDirectory (buildDir lbi dir) `catchIO` (\_ -> return []) + srcHeaders <- for relIncDirs $ \dir -> + fmap (dir ) . filter isHeader <$> + listDirectory (baseDir lbi dir) `catchIO` (\_ -> return []) + let commonHeaders = concat genHeaders `intersect` concat srcHeaders + for_ commonHeaders $ \hdr -> do + warn verbosity $ "Duplicate header found in " + ++ (buildDir lbi hdr) + ++ " and " + ++ (baseDir lbi hdr) + ++ "; removing " + ++ (baseDir lbi hdr) + removeFile (baseDir lbi hdr) + + findOffendingHdr = + ifBuildsWith allHeaders ccArgs + (return Nothing) + (go . Unsafe.tail . inits $ allHeaders) -- inits always contains at least [] + where + go [] = return Nothing -- cannot happen + go (hdrs:hdrsInits) = + -- Try just preprocessing first + ifBuildsWith hdrs cppArgs + -- If that works, try compiling too + (ifBuildsWith hdrs ccArgs + (go hdrsInits) + (return . fmap Right . safeLast $ hdrs)) + (return . fmap Left . safeLast $ hdrs) + + + cppArgs = "-E":commonCppArgs -- preprocess only + ccArgs = "-c":commonCcArgs -- don't try to link + + findMissingLibs = ifBuildsWith [] (makeLdArgs allLibs) + (return []) + (filterM (fmap not . libExists) allLibs) + + libExists lib = builds (makeProgram []) (makeLdArgs [lib]) + + baseDir lbi' = fromMaybe "." (takeDirectory <$> cabalFilePath lbi') + + commonCppArgs = platformDefines lbi + -- TODO: This is a massive hack, to work around the + -- fact that the test performed here should be + -- PER-component (c.f. the "I'm Feeling Lucky"; we + -- should NOT be glomming everything together.) + ++ [ "-I" ++ buildDir lbi "autogen" ] + -- `configure' may generate headers in the build directory + ++ [ "-I" ++ buildDir lbi dir + | dir <- ordNub (collectField includeDirs) + , not (isAbsolute dir)] + -- we might also reference headers from the + -- packages directory. + ++ [ "-I" ++ baseDir lbi dir + | dir <- ordNub (collectField includeDirs) + , not (isAbsolute dir)] + ++ [ "-I" ++ dir | dir <- ordNub (collectField includeDirs) + , isAbsolute dir] + ++ ["-I" ++ baseDir lbi] + ++ collectField cppOptions + ++ collectField ccOptions + ++ [ "-I" ++ dir + | dir <- ordNub [ dir + | dep <- deps + , dir <- IPI.includeDirs dep ] + -- dedupe include dirs of dependencies + -- to prevent quadratic blow-up + ] + ++ [ opt + | dep <- deps + , opt <- IPI.ccOptions dep ] + + commonCcArgs = commonCppArgs + ++ collectField ccOptions + ++ [ opt + | dep <- deps + , opt <- IPI.ccOptions dep ] + + commonLdArgs = [ "-L" ++ dir + | dir <- ordNub $ collectField (if withFullyStaticExe lbi + then extraLibDirsStatic + else extraLibDirs + ) ] + ++ collectField ldOptions + ++ [ "-L" ++ dir + | dir <- ordNub [ dir + | dep <- deps + , dir <- if withFullyStaticExe lbi + then IPI.libraryDirsStatic dep + else IPI.libraryDirs dep ] + ] + --TODO: do we also need dependent packages' ld options? + makeLdArgs libs = [ "-l"++lib | lib <- libs ] ++ commonLdArgs + + makeProgram hdrs = unlines $ + [ "#include \"" ++ hdr ++ "\"" | hdr <- hdrs ] ++ + ["int main(int argc, char** argv) { return 0; }"] + + collectField f = concatMap f allBi + allBi = enabledBuildInfos pkg (componentEnabledSpec lbi) + deps = PackageIndex.topologicalOrder (installedPkgs lbi) + + builds program args = do + tempDir <- getTemporaryDirectory + withTempFile tempDir ".c" $ \cName cHnd -> + withTempFile tempDir "" $ \oNname oHnd -> do + hPutStrLn cHnd program + hClose cHnd + hClose oHnd + _ <- getDbProgramOutput verbosity + gccProgram (withPrograms lbi) (cName:"-o":oNname:args) + return True + `catchIO` (\_ -> return False) + `catchExit` (\_ -> return False) + + explainErrors Nothing [] = return () -- should be impossible! + explainErrors _ _ + | isNothing . lookupProgram gccProgram . withPrograms $ lbi + + = die' verbosity $ unlines + [ "No working gcc", + "This package depends on foreign library but we cannot " + ++ "find a working C compiler. If you have it in a " + ++ "non-standard location you can use the --with-gcc " + ++ "flag to specify it." ] + + explainErrors hdr libs = die' verbosity $ unlines $ + [ if plural + then "Missing dependencies on foreign libraries:" + else "Missing dependency on a foreign library:" + | missing ] + ++ case hdr of + Just (Left h) -> ["* Missing (or bad) header file: " ++ h ] + _ -> [] + ++ case libs of + [] -> [] + [lib] -> ["* Missing (or bad) C library: " ++ lib] + _ -> ["* Missing (or bad) C libraries: " ++ + intercalate ", " libs] + ++ [if plural then messagePlural else messageSingular | missing] + ++ case hdr of + Just (Left _) -> [ headerCppMessage ] + Just (Right h) -> [ (if missing then "* " else "") + ++ "Bad header file: " ++ h + , headerCcMessage ] + _ -> [] + + where + plural = length libs >= 2 + -- Is there something missing? (as opposed to broken) + missing = not (null libs) + || case hdr of Just (Left _) -> True; _ -> False + + messageSingular = + "This problem can usually be solved by installing the system " + ++ "package that provides this library (you may need the " + ++ "\"-dev\" version). If the library is already installed " + ++ "but in a non-standard location then you can use the flags " + ++ "--extra-include-dirs= and --extra-lib-dirs= to specify " + ++ "where it is." + ++ "If the library file does exist, it may contain errors that " + ++ "are caught by the C compiler at the preprocessing stage. " + ++ "In this case you can re-run configure with the verbosity " + ++ "flag -v3 to see the error messages." + messagePlural = + "This problem can usually be solved by installing the system " + ++ "packages that provide these libraries (you may need the " + ++ "\"-dev\" versions). If the libraries are already installed " + ++ "but in a non-standard location then you can use the flags " + ++ "--extra-include-dirs= and --extra-lib-dirs= to specify " + ++ "where they are." + ++ "If the library files do exist, it may contain errors that " + ++ "are caught by the C compiler at the preprocessing stage. " + ++ "In this case you can re-run configure with the verbosity " + ++ "flag -v3 to see the error messages." + headerCppMessage = + "If the header file does exist, it may contain errors that " + ++ "are caught by the C compiler at the preprocessing stage. " + ++ "In this case you can re-run configure with the verbosity " + ++ "flag -v3 to see the error messages." + headerCcMessage = + "The header file contains a compile error. " + ++ "You can re-run configure with the verbosity flag " + ++ "-v3 to see the error messages from the C compiler." + +-- | Output package check warnings and errors. Exit if any errors. +checkPackageProblems :: Verbosity + -> FilePath + -- ^ Path to the @.cabal@ file's directory + -> GenericPackageDescription + -> PackageDescription + -> IO () +checkPackageProblems verbosity dir gpkg pkg = do + ioChecks <- checkPackageFiles verbosity pkg dir + let pureChecks = checkPackage gpkg (Just pkg) + errors = [ e | PackageBuildImpossible e <- pureChecks ++ ioChecks ] + warnings = [ w | PackageBuildWarning w <- pureChecks ++ ioChecks ] + if null errors + then traverse_ (warn verbosity) warnings + else die' verbosity (intercalate "\n\n" errors) + +-- | Preform checks if a relocatable build is allowed +checkRelocatable :: Verbosity + -> PackageDescription + -> LocalBuildInfo + -> IO () +checkRelocatable verbosity pkg lbi + = sequence_ [ checkOS + , checkCompiler + , packagePrefixRelative + , depsPrefixRelative + ] + where + -- Check if the OS support relocatable builds. + -- + -- If you add new OS' to this list, and your OS supports dynamic libraries + -- and RPATH, make sure you add your OS to RPATH-support list of: + -- Distribution.Simple.GHC.getRPaths + checkOS + = unless (os `elem` [ OSX, Linux ]) + $ die' verbosity $ "Operating system: " ++ prettyShow os ++ + ", does not support relocatable builds" + where + (Platform _ os) = hostPlatform lbi + + -- Check if the Compiler support relocatable builds + checkCompiler + = unless (compilerFlavor comp `elem` [ GHC ]) + $ die' verbosity $ "Compiler: " ++ show comp ++ + ", does not support relocatable builds" + where + comp = compiler lbi + + -- Check if all the install dirs are relative to same prefix + packagePrefixRelative + = unless (relativeInstallDirs installDirs) + $ die' verbosity $ "Installation directories are not prefix_relative:\n" ++ + show installDirs + where + -- NB: should be good enough to check this against the default + -- component ID, but if we wanted to be strictly correct we'd + -- check for each ComponentId. + installDirs = absoluteInstallDirs pkg lbi NoCopyDest + p = prefix installDirs + relativeInstallDirs (InstallDirs {..}) = + all isJust + (fmap (stripPrefix p) + [ bindir, libdir, dynlibdir, libexecdir, includedir, datadir + , docdir, mandir, htmldir, haddockdir, sysconfdir] ) + + -- Check if the library dirs of the dependencies that are in the package + -- database to which the package is installed are relative to the + -- prefix of the package + depsPrefixRelative = do + pkgr <- GHC.pkgRoot verbosity lbi (registrationPackageDB (withPackageDB lbi)) + traverse_ (doCheck pkgr) ipkgs + where + doCheck pkgr ipkg + | maybe False (== pkgr) (IPI.pkgRoot ipkg) + = for_ (IPI.libraryDirs ipkg) $ \libdir -> do + -- When @prefix@ is not under @pkgroot@, + -- @shortRelativePath prefix pkgroot@ will return a path with + -- @..@s and following check will fail without @canonicalizePath@. + canonicalized <- canonicalizePath libdir + unless (p `isPrefixOf` canonicalized) $ + die' verbosity $ msg libdir + | otherwise + = return () + -- NB: should be good enough to check this against the default + -- component ID, but if we wanted to be strictly correct we'd + -- check for each ComponentId. + installDirs = absoluteInstallDirs pkg lbi NoCopyDest + p = prefix installDirs + ipkgs = PackageIndex.allPackages (installedPkgs lbi) + msg l = "Library directory of a dependency: " ++ show l ++ + "\nis not relative to the installation prefix:\n" ++ + show p + +-- ----------------------------------------------------------------------------- +-- Testing foreign library requirements + +unsupportedForeignLibs :: Compiler -> Platform -> [ForeignLib] -> [String] +unsupportedForeignLibs comp platform = + mapMaybe (checkForeignLibSupported comp platform) + +checkForeignLibSupported :: Compiler -> Platform -> ForeignLib -> Maybe String +checkForeignLibSupported comp platform flib = go (compilerFlavor comp) + where + go :: CompilerFlavor -> Maybe String + go GHC + | compilerVersion comp < mkVersion [7,8] = unsupported [ + "Building foreign libraires is only supported with GHC >= 7.8" + ] + | otherwise = goGhcPlatform platform + go _ = unsupported [ + "Building foreign libraries is currently only supported with ghc" + ] + + goGhcPlatform :: Platform -> Maybe String + goGhcPlatform (Platform _ OSX ) = goGhcOsx (foreignLibType flib) + goGhcPlatform (Platform _ Linux ) = goGhcLinux (foreignLibType flib) + goGhcPlatform (Platform I386 Windows) = goGhcWindows (foreignLibType flib) + goGhcPlatform (Platform X86_64 Windows) = goGhcWindows (foreignLibType flib) + goGhcPlatform _ = unsupported [ + "Building foreign libraries is currently only supported on Mac OS, " + , "Linux and Windows" + ] + + goGhcOsx :: ForeignLibType -> Maybe String + goGhcOsx ForeignLibNativeShared + | not (null (foreignLibModDefFile flib)) = unsupported [ + "Module definition file not supported on OSX" + ] + | not (null (foreignLibVersionInfo flib)) = unsupported [ + "Foreign library versioning not currently supported on OSX" + ] + | otherwise = + Nothing + goGhcOsx _ = unsupported [ + "We can currently only build shared foreign libraries on OSX" + ] + + goGhcLinux :: ForeignLibType -> Maybe String + goGhcLinux ForeignLibNativeShared + | not (null (foreignLibModDefFile flib)) = unsupported [ + "Module definition file not supported on Linux" + ] + | not (null (foreignLibVersionInfo flib)) + && not (null (foreignLibVersionLinux flib)) = unsupported [ + "You must not specify both lib-version-info and lib-version-linux" + ] + | otherwise = + Nothing + goGhcLinux _ = unsupported [ + "We can currently only build shared foreign libraries on Linux" + ] + + goGhcWindows :: ForeignLibType -> Maybe String + goGhcWindows ForeignLibNativeShared + | not standalone = unsupported [ + "We can currently only build standalone libraries on Windows. Use\n" + , " if os(Windows)\n" + , " options: standalone\n" + , "in your foreign-library stanza." + ] + | not (null (foreignLibVersionInfo flib)) = unsupported [ + "Foreign library versioning not currently supported on Windows.\n" + , "You can specify module definition files in the mod-def-file field." + ] + | otherwise = + Nothing + goGhcWindows _ = unsupported [ + "We can currently only build shared foreign libraries on Windows" + ] + + standalone :: Bool + standalone = ForeignLibStandalone `elem` foreignLibOptions flib + + unsupported :: [String] -> Maybe String + unsupported = Just . concat diff --git a/cabal/Cabal/src/Distribution/Simple/Flag.hs b/cabal/Cabal/src/Distribution/Simple/Flag.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/Flag.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Flag +-- Copyright : Isaac Jones 2003-2004 +-- Duncan Coutts 2007 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Defines the 'Flag' type and it's 'Monoid' instance, see +-- +-- for an explanation. +-- +-- Split off from "Distribution.Simple.Setup" to break import cycles. +module Distribution.Simple.Flag ( + Flag(..), + allFlags, + toFlag, + fromFlag, + fromFlagOrDefault, + flagElim, + flagToMaybe, + flagToList, + maybeToFlag, + BooleanFlag(..) ) where + +import Prelude () +import Distribution.Compat.Prelude hiding (get) +import Distribution.Compat.Stack + +-- ------------------------------------------------------------ +-- * Flag type +-- ------------------------------------------------------------ + +-- | All flags are monoids, they come in two flavours: +-- +-- 1. list flags eg +-- +-- > --ghc-option=foo --ghc-option=bar +-- +-- gives us all the values ["foo", "bar"] +-- +-- 2. singular value flags, eg: +-- +-- > --enable-foo --disable-foo +-- +-- gives us Just False +-- So this Flag type is for the latter singular kind of flag. +-- Its monoid instance gives us the behaviour where it starts out as +-- 'NoFlag' and later flags override earlier ones. +-- +data Flag a = Flag a | NoFlag deriving (Eq, Generic, Show, Read, Typeable) + +instance Binary a => Binary (Flag a) +instance Structured a => Structured (Flag a) + +instance Functor Flag where + fmap f (Flag x) = Flag (f x) + fmap _ NoFlag = NoFlag + +instance Applicative Flag where + (Flag x) <*> y = x <$> y + NoFlag <*> _ = NoFlag + pure = Flag + +instance Monoid (Flag a) where + mempty = NoFlag + mappend = (<>) + +instance Semigroup (Flag a) where + _ <> f@(Flag _) = f + f <> NoFlag = f + +instance Bounded a => Bounded (Flag a) where + minBound = toFlag minBound + maxBound = toFlag maxBound + +instance Enum a => Enum (Flag a) where + fromEnum = fromEnum . fromFlag + toEnum = toFlag . toEnum + enumFrom (Flag a) = map toFlag . enumFrom $ a + enumFrom _ = [] + enumFromThen (Flag a) (Flag b) = toFlag `map` enumFromThen a b + enumFromThen _ _ = [] + enumFromTo (Flag a) (Flag b) = toFlag `map` enumFromTo a b + enumFromTo _ _ = [] + enumFromThenTo (Flag a) (Flag b) (Flag c) = toFlag `map` enumFromThenTo a b c + enumFromThenTo _ _ _ = [] + +toFlag :: a -> Flag a +toFlag = Flag + +fromFlag :: WithCallStack (Flag a -> a) +fromFlag (Flag x) = x +fromFlag NoFlag = error "fromFlag NoFlag. Use fromFlagOrDefault" + +fromFlagOrDefault :: a -> Flag a -> a +fromFlagOrDefault _ (Flag x) = x +fromFlagOrDefault def NoFlag = def + +flagToMaybe :: Flag a -> Maybe a +flagToMaybe (Flag x) = Just x +flagToMaybe NoFlag = Nothing + +-- | @since 3.4.0.0 +flagElim :: b -> (a -> b) -> Flag a -> b +flagElim n _ NoFlag = n +flagElim _ f (Flag x) = f x + +flagToList :: Flag a -> [a] +flagToList (Flag x) = [x] +flagToList NoFlag = [] + +allFlags :: [Flag Bool] -> Flag Bool +allFlags flags = if all (\f -> fromFlagOrDefault False f) flags + then Flag True + else NoFlag + +maybeToFlag :: Maybe a -> Flag a +maybeToFlag Nothing = NoFlag +maybeToFlag (Just x) = Flag x + +-- | Types that represent boolean flags. +class BooleanFlag a where + asBool :: a -> Bool + +instance BooleanFlag Bool where + asBool = id diff --git a/cabal/Cabal/src/Distribution/Simple/GHC.hs b/cabal/Cabal/src/Distribution/Simple/GHC.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/GHC.hs @@ -0,0 +1,2123 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.GHC +-- Copyright : Isaac Jones 2003-2007 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is a fairly large module. It contains most of the GHC-specific code for +-- configuring, building and installing packages. It also exports a function +-- for finding out what packages are already installed. Configuring involves +-- finding the @ghc@ and @ghc-pkg@ programs, finding what language extensions +-- this version of ghc supports and returning a 'Compiler' value. +-- +-- 'getInstalledPackages' involves calling the @ghc-pkg@ program to find out +-- what packages are installed. +-- +-- Building is somewhat complex as there is quite a bit of information to take +-- into account. We have to build libs and programs, possibly for profiling and +-- shared libs. We have to support building libraries that will be usable by +-- GHCi and also ghc's @-split-objs@ feature. We have to compile any C files +-- using ghc. Linking, especially for @split-objs@ is remarkably complex, +-- partly because there tend to be 1,000's of @.o@ files and this can often be +-- more than we can pass to the @ld@ or @ar@ programs in one go. +-- +-- Installing for libs and exes involves finding the right files and copying +-- them to the right places. One of the more tricky things about this module is +-- remembering the layout of files in the build directory (which is not +-- explicitly documented) and thus what search dirs are used for various kinds +-- of files. + +module Distribution.Simple.GHC ( + getGhcInfo, + configure, + getInstalledPackages, + getInstalledPackagesMonitorFiles, + getPackageDBContents, + buildLib, buildFLib, buildExe, + replLib, replFLib, replExe, + startInterpreter, + installLib, installFLib, installExe, + libAbiHash, + hcPkgInfo, + registerPackage, + componentGhcOptions, + componentCcGhcOptions, + getGhcAppDir, + getLibDir, + isDynamic, + getGlobalPackageDB, + pkgRoot, + -- * Constructing and deconstructing GHC environment files + Internal.GhcEnvironmentFileEntry(..), + Internal.simpleGhcEnvironmentFile, + Internal.renderGhcEnvironmentFile, + Internal.writeGhcEnvironmentFile, + Internal.ghcPlatformAndVersionString, + readGhcEnvironmentFile, + parseGhcEnvironmentFile, + ParseErrorExc(..), + -- * Version-specific implementation quirks + getImplInfo, + GhcImplInfo(..) + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import qualified Distribution.Simple.GHC.Internal as Internal +import Distribution.CabalSpecVersion +import Distribution.Simple.GHC.ImplInfo +import Distribution.Simple.GHC.EnvironmentParser +import Distribution.PackageDescription.Utils (cabalBug) +import Distribution.PackageDescription as PD +import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo +import Distribution.Simple.PackageIndex (InstalledPackageIndex) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.LocalBuildInfo +import Distribution.Types.ComponentLocalBuildInfo +import qualified Distribution.Simple.Hpc as Hpc +import Distribution.Simple.BuildPaths +import Distribution.Simple.Utils +import Distribution.Package +import qualified Distribution.ModuleName as ModuleName +import Distribution.ModuleName (ModuleName) +import Distribution.Simple.Program +import Distribution.Simple.Program.Builtin (runghcProgram) +import qualified Distribution.Simple.Program.HcPkg as HcPkg +import qualified Distribution.Simple.Program.Ar as Ar +import qualified Distribution.Simple.Program.Ld as Ld +import qualified Distribution.Simple.Program.Strip as Strip +import Distribution.Simple.Program.GHC +import Distribution.Simple.Setup +import qualified Distribution.Simple.Setup as Cabal +import Distribution.Simple.Compiler +import Distribution.Version +import Distribution.System +import Distribution.Types.PackageName.Magic +import Distribution.Verbosity +import Distribution.Pretty +import Distribution.Utils.NubList +import Distribution.Utils.Path +import Language.Haskell.Extension + +import Control.Monad (msum, forM_) +import Data.Char (isLower) +import qualified Data.Map as Map +import System.Directory + ( doesFileExist, getAppUserDataDirectory, createDirectoryIfMissing + , canonicalizePath, removeFile, renameFile, getDirectoryContents + , makeRelativeToCurrentDirectory ) +import System.FilePath ( (), (<.>), takeExtension + , takeDirectory, replaceExtension + ,isRelative ) +import qualified System.Info +#ifndef mingw32_HOST_OS +import System.Posix (createSymbolicLink) +#endif /* mingw32_HOST_OS */ + +-- ----------------------------------------------------------------------------- +-- Configuring + +configure :: Verbosity -> Maybe FilePath -> Maybe FilePath + -> ProgramDb + -> IO (Compiler, Maybe Platform, ProgramDb) +configure verbosity hcPath hcPkgPath conf0 = do + + (ghcProg, ghcVersion, progdb1) <- + requireProgramVersion verbosity ghcProgram + (orLaterVersion (mkVersion [7,0,1])) + (userMaybeSpecifyPath "ghc" hcPath conf0) + let implInfo = ghcVersionImplInfo ghcVersion + + -- Cabal currently supports ghc >= 7.0.1 && < 9.6 + -- ... and the following odd development version + unless (ghcVersion < mkVersion [9,6]) $ + warn verbosity $ + "Unknown/unsupported 'ghc' version detected " + ++ "(Cabal " ++ prettyShow cabalVersion ++ " supports 'ghc' version < 9.6): " + ++ programPath ghcProg ++ " is version " ++ prettyShow ghcVersion + + -- This is slightly tricky, we have to configure ghc first, then we use the + -- location of ghc to help find ghc-pkg in the case that the user did not + -- specify the location of ghc-pkg directly: + (ghcPkgProg, ghcPkgVersion, progdb2) <- + requireProgramVersion verbosity ghcPkgProgram { + programFindLocation = guessGhcPkgFromGhcPath ghcProg + } + anyVersion (userMaybeSpecifyPath "ghc-pkg" hcPkgPath progdb1) + + when (ghcVersion /= ghcPkgVersion) $ die' verbosity $ + "Version mismatch between ghc and ghc-pkg: " + ++ programPath ghcProg ++ " is version " ++ prettyShow ghcVersion ++ " " + ++ programPath ghcPkgProg ++ " is version " ++ prettyShow ghcPkgVersion + + -- Likewise we try to find the matching hsc2hs and haddock programs. + let hsc2hsProgram' = hsc2hsProgram { + programFindLocation = guessHsc2hsFromGhcPath ghcProg + } + haddockProgram' = haddockProgram { + programFindLocation = guessHaddockFromGhcPath ghcProg + } + hpcProgram' = hpcProgram { + programFindLocation = guessHpcFromGhcPath ghcProg + } + runghcProgram' = runghcProgram { + programFindLocation = guessRunghcFromGhcPath ghcProg + } + progdb3 = addKnownProgram haddockProgram' $ + addKnownProgram hsc2hsProgram' $ + addKnownProgram hpcProgram' $ + addKnownProgram runghcProgram' progdb2 + + languages <- Internal.getLanguages verbosity implInfo ghcProg + extensions0 <- Internal.getExtensions verbosity implInfo ghcProg + + ghcInfo <- Internal.getGhcInfo verbosity implInfo ghcProg + let ghcInfoMap = Map.fromList ghcInfo + extensions = -- workaround https://gitlab.haskell.org/ghc/ghc/-/issues/11214 + filterExt JavaScriptFFI $ + -- see 'filterExtTH' comment below + filterExtTH $ extensions0 + + -- starting with GHC 8.0, `TemplateHaskell` will be omitted from + -- `--supported-extensions` when it's not available. + -- for older GHCs we can use the "Have interpreter" property to + -- filter out `TemplateHaskell` + filterExtTH | ghcVersion < mkVersion [8] + , Just "NO" <- Map.lookup "Have interpreter" ghcInfoMap + = filterExt TemplateHaskell + | otherwise = id + + filterExt ext = filter ((/= EnableExtension ext) . fst) + + let comp = Compiler { + compilerId = CompilerId GHC ghcVersion, + compilerAbiTag = NoAbiTag, + compilerCompat = [], + compilerLanguages = languages, + compilerExtensions = extensions, + compilerProperties = ghcInfoMap + } + compPlatform = Internal.targetPlatform ghcInfo + -- configure gcc and ld + progdb4 = Internal.configureToolchain implInfo ghcProg ghcInfoMap progdb3 + return (comp, compPlatform, progdb4) + +-- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find +-- the corresponding tool; e.g. if the tool is ghc-pkg, we try looking +-- for a versioned or unversioned ghc-pkg in the same dir, that is: +-- +-- > /usr/local/bin/ghc-pkg-ghc-6.6.1(.exe) +-- > /usr/local/bin/ghc-pkg-6.6.1(.exe) +-- > /usr/local/bin/ghc-pkg(.exe) +-- +guessToolFromGhcPath :: Program -> ConfiguredProgram + -> Verbosity -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) +guessToolFromGhcPath tool ghcProg verbosity searchpath + = do let toolname = programName tool + given_path = programPath ghcProg + given_dir = takeDirectory given_path + real_path <- canonicalizePath given_path + let real_dir = takeDirectory real_path + versionSuffix path = takeVersionSuffix (dropExeExtension path) + given_suf = versionSuffix given_path + real_suf = versionSuffix real_path + guessNormal dir = dir toolname <.> exeExtension buildPlatform + guessGhcVersioned dir suf = dir (toolname ++ "-ghc" ++ suf) + <.> exeExtension buildPlatform + guessVersioned dir suf = dir (toolname ++ suf) + <.> exeExtension buildPlatform + mkGuesses dir suf | null suf = [guessNormal dir] + | otherwise = [guessGhcVersioned dir suf, + guessVersioned dir suf, + guessNormal dir] + -- order matters here, see https://github.com/haskell/cabal/issues/7390 + guesses = (if real_path == given_path + then [] + else mkGuesses real_dir real_suf) + ++ mkGuesses given_dir given_suf + info verbosity $ "looking for tool " ++ toolname + ++ " near compiler in " ++ given_dir + debug verbosity $ "candidate locations: " ++ show guesses + exists <- traverse doesFileExist guesses + case [ file | (file, True) <- zip guesses exists ] of + -- If we can't find it near ghc, fall back to the usual + -- method. + [] -> programFindLocation tool verbosity searchpath + (fp:_) -> do info verbosity $ "found " ++ toolname ++ " in " ++ fp + let lookedAt = map fst + . takeWhile (\(_file, exist) -> not exist) + $ zip guesses exists + return (Just (fp, lookedAt)) + + where takeVersionSuffix :: FilePath -> String + takeVersionSuffix = takeWhileEndLE isSuffixChar + + isSuffixChar :: Char -> Bool + isSuffixChar c = isDigit c || c == '.' || c == '-' + +-- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a +-- corresponding ghc-pkg, we try looking for both a versioned and unversioned +-- ghc-pkg in the same dir, that is: +-- +-- > /usr/local/bin/ghc-pkg-ghc-6.6.1(.exe) +-- > /usr/local/bin/ghc-pkg-6.6.1(.exe) +-- > /usr/local/bin/ghc-pkg(.exe) +-- +guessGhcPkgFromGhcPath :: ConfiguredProgram + -> Verbosity -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) +guessGhcPkgFromGhcPath = guessToolFromGhcPath ghcPkgProgram + +-- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a +-- corresponding hsc2hs, we try looking for both a versioned and unversioned +-- hsc2hs in the same dir, that is: +-- +-- > /usr/local/bin/hsc2hs-ghc-6.6.1(.exe) +-- > /usr/local/bin/hsc2hs-6.6.1(.exe) +-- > /usr/local/bin/hsc2hs(.exe) +-- +guessHsc2hsFromGhcPath :: ConfiguredProgram + -> Verbosity -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) +guessHsc2hsFromGhcPath = guessToolFromGhcPath hsc2hsProgram + +-- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a +-- corresponding haddock, we try looking for both a versioned and unversioned +-- haddock in the same dir, that is: +-- +-- > /usr/local/bin/haddock-ghc-6.6.1(.exe) +-- > /usr/local/bin/haddock-6.6.1(.exe) +-- > /usr/local/bin/haddock(.exe) +-- +guessHaddockFromGhcPath :: ConfiguredProgram + -> Verbosity -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) +guessHaddockFromGhcPath = guessToolFromGhcPath haddockProgram + +guessHpcFromGhcPath :: ConfiguredProgram + -> Verbosity -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) +guessHpcFromGhcPath = guessToolFromGhcPath hpcProgram + +guessRunghcFromGhcPath :: ConfiguredProgram + -> Verbosity -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) +guessRunghcFromGhcPath = guessToolFromGhcPath runghcProgram + + +getGhcInfo :: Verbosity -> ConfiguredProgram -> IO [(String, String)] +getGhcInfo verbosity ghcProg = Internal.getGhcInfo verbosity implInfo ghcProg + where + version = fromMaybe (error "GHC.getGhcInfo: no ghc version") $ programVersion ghcProg + implInfo = ghcVersionImplInfo version + +-- | Given a single package DB, return all installed packages. +getPackageDBContents :: Verbosity -> PackageDB -> ProgramDb + -> IO InstalledPackageIndex +getPackageDBContents verbosity packagedb progdb = do + pkgss <- getInstalledPackages' verbosity [packagedb] progdb + toPackageIndex verbosity pkgss progdb + +-- | Given a package DB stack, return all installed packages. +getInstalledPackages :: Verbosity -> Compiler -> PackageDBStack + -> ProgramDb + -> IO InstalledPackageIndex +getInstalledPackages verbosity comp packagedbs progdb = do + checkPackageDbEnvVar verbosity + checkPackageDbStack verbosity comp packagedbs + pkgss <- getInstalledPackages' verbosity packagedbs progdb + index <- toPackageIndex verbosity pkgss progdb + return $! hackRtsPackage index + + where + hackRtsPackage index = + case PackageIndex.lookupPackageName index (mkPackageName "rts") of + [(_,[rts])] + -> PackageIndex.insert (removeMingwIncludeDir rts) index + _ -> index -- No (or multiple) ghc rts package is registered!! + -- Feh, whatever, the ghc test suite does some crazy stuff. + +-- | Given a list of @(PackageDB, InstalledPackageInfo)@ pairs, produce a +-- @PackageIndex@. Helper function used by 'getPackageDBContents' and +-- 'getInstalledPackages'. +toPackageIndex :: Verbosity + -> [(PackageDB, [InstalledPackageInfo])] + -> ProgramDb + -> IO InstalledPackageIndex +toPackageIndex verbosity pkgss progdb = do + -- On Windows, various fields have $topdir/foo rather than full + -- paths. We need to substitute the right value in so that when + -- we, for example, call gcc, we have proper paths to give it. + topDir <- getLibDir' verbosity ghcProg + let indices = [ PackageIndex.fromList (map (Internal.substTopDir topDir) pkgs) + | (_, pkgs) <- pkgss ] + return $! mconcat indices + + where + ghcProg = fromMaybe (error "GHC.toPackageIndex: no ghc program") $ lookupProgram ghcProgram progdb + +-- | Return the 'FilePath' to the GHC application data directory. +-- +-- @since 3.4.0.0 +getGhcAppDir :: IO FilePath +getGhcAppDir = getAppUserDataDirectory "ghc" + +getLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath +getLibDir verbosity lbi = + dropWhileEndLE isSpace `fmap` + getDbProgramOutput verbosity ghcProgram + (withPrograms lbi) ["--print-libdir"] + +getLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath +getLibDir' verbosity ghcProg = + dropWhileEndLE isSpace `fmap` + getProgramOutput verbosity ghcProg ["--print-libdir"] + + +-- | Return the 'FilePath' to the global GHC package database. +getGlobalPackageDB :: Verbosity -> ConfiguredProgram -> IO FilePath +getGlobalPackageDB verbosity ghcProg = + dropWhileEndLE isSpace `fmap` + getProgramOutput verbosity ghcProg ["--print-global-package-db"] + +-- | Return the 'FilePath' to the per-user GHC package database. +getUserPackageDB + :: Verbosity -> ConfiguredProgram -> Platform -> IO FilePath +getUserPackageDB _verbosity ghcProg platform = do + -- It's rather annoying that we have to reconstruct this, because ghc + -- hides this information from us otherwise. But for certain use cases + -- like change monitoring it really can't remain hidden. + appdir <- getGhcAppDir + return (appdir platformAndVersion packageConfFileName) + where + platformAndVersion = Internal.ghcPlatformAndVersionString + platform ghcVersion + packageConfFileName = "package.conf.d" + ghcVersion = fromMaybe (error "GHC.getUserPackageDB: no ghc version") $ programVersion ghcProg + +checkPackageDbEnvVar :: Verbosity -> IO () +checkPackageDbEnvVar verbosity = + Internal.checkPackageDbEnvVar verbosity "GHC" "GHC_PACKAGE_PATH" + +checkPackageDbStack :: Verbosity -> Compiler -> PackageDBStack -> IO () +checkPackageDbStack verbosity comp = + if flagPackageConf implInfo + then checkPackageDbStackPre76 verbosity + else checkPackageDbStackPost76 verbosity + where implInfo = ghcVersionImplInfo (compilerVersion comp) + +checkPackageDbStackPost76 :: Verbosity -> PackageDBStack -> IO () +checkPackageDbStackPost76 _ (GlobalPackageDB:rest) + | GlobalPackageDB `notElem` rest = return () +checkPackageDbStackPost76 verbosity rest + | GlobalPackageDB `elem` rest = + die' verbosity $ "If the global package db is specified, it must be " + ++ "specified first and cannot be specified multiple times" +checkPackageDbStackPost76 _ _ = return () + +checkPackageDbStackPre76 :: Verbosity -> PackageDBStack -> IO () +checkPackageDbStackPre76 _ (GlobalPackageDB:rest) + | GlobalPackageDB `notElem` rest = return () +checkPackageDbStackPre76 verbosity rest + | GlobalPackageDB `notElem` rest = + die' verbosity $ + "With current ghc versions the global package db is always used " + ++ "and must be listed first. This ghc limitation is lifted in GHC 7.6," + ++ "see https://gitlab.haskell.org/ghc/ghc/-/issues/5977" +checkPackageDbStackPre76 verbosity _ = + die' verbosity $ "If the global package db is specified, it must be " + ++ "specified first and cannot be specified multiple times" + +-- GHC < 6.10 put "$topdir/include/mingw" in rts's installDirs. This +-- breaks when you want to use a different gcc, so we need to filter +-- it out. +removeMingwIncludeDir :: InstalledPackageInfo -> InstalledPackageInfo +removeMingwIncludeDir pkg = + let ids = InstalledPackageInfo.includeDirs pkg + ids' = filter (not . ("mingw" `isSuffixOf`)) ids + in pkg { InstalledPackageInfo.includeDirs = ids' } + +-- | Get the packages from specific PackageDBs, not cumulative. +-- +getInstalledPackages' :: Verbosity -> [PackageDB] -> ProgramDb + -> IO [(PackageDB, [InstalledPackageInfo])] +getInstalledPackages' verbosity packagedbs progdb = + sequenceA + [ do pkgs <- HcPkg.dump (hcPkgInfo progdb) verbosity packagedb + return (packagedb, pkgs) + | packagedb <- packagedbs ] + +getInstalledPackagesMonitorFiles :: Verbosity -> Platform + -> ProgramDb + -> [PackageDB] + -> IO [FilePath] +getInstalledPackagesMonitorFiles verbosity platform progdb = + traverse getPackageDBPath + where + getPackageDBPath :: PackageDB -> IO FilePath + getPackageDBPath GlobalPackageDB = + selectMonitorFile =<< getGlobalPackageDB verbosity ghcProg + + getPackageDBPath UserPackageDB = + selectMonitorFile =<< getUserPackageDB verbosity ghcProg platform + + getPackageDBPath (SpecificPackageDB path) = selectMonitorFile path + + -- GHC has old style file dbs, and new style directory dbs. + -- Note that for dir style dbs, we only need to monitor the cache file, not + -- the whole directory. The ghc program itself only reads the cache file + -- so it's safe to only monitor this one file. + selectMonitorFile path = do + isFileStyle <- doesFileExist path + if isFileStyle then return path + else return (path "package.cache") + + ghcProg = fromMaybe (error "GHC.toPackageIndex: no ghc program") $ lookupProgram ghcProgram progdb + + +-- ----------------------------------------------------------------------------- +-- Building a library + +buildLib :: Verbosity -> Cabal.Flag (Maybe Int) + -> PackageDescription -> LocalBuildInfo + -> Library -> ComponentLocalBuildInfo -> IO () +buildLib = buildOrReplLib Nothing + +replLib :: ReplOptions -> Verbosity + -> Cabal.Flag (Maybe Int) -> PackageDescription + -> LocalBuildInfo -> Library + -> ComponentLocalBuildInfo -> IO () +replLib = buildOrReplLib . Just + +buildOrReplLib :: Maybe ReplOptions -> Verbosity + -> Cabal.Flag (Maybe Int) -> PackageDescription + -> LocalBuildInfo -> Library + -> ComponentLocalBuildInfo -> IO () +buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do + let uid = componentUnitId clbi + libTargetDir = componentBuildDir lbi clbi + whenVanillaLib forceVanilla = + when (forceVanilla || withVanillaLib lbi) + whenProfLib = when (withProfLib lbi) + whenSharedLib forceShared = + when (forceShared || withSharedLib lbi) + whenStaticLib forceStatic = + when (forceStatic || withStaticLib lbi) + whenGHCiLib = when (withGHCiLib lbi) + forRepl = maybe False (const True) mReplFlags + whenReplLib = when forRepl + replFlags = fromMaybe mempty mReplFlags + comp = compiler lbi + ghcVersion = compilerVersion comp + implInfo = getImplInfo comp + platform@(Platform _hostArch hostOS) = hostPlatform lbi + has_code = not (componentIsIndefinite clbi) + + relLibTargetDir <- makeRelativeToCurrentDirectory libTargetDir + + (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi) + let runGhcProg = runGHC verbosity ghcProg comp platform + + let libBi = libBuildInfo lib + + let isGhcDynamic = isDynamic comp + dynamicTooSupported = supportsDynamicToo comp + doingTH = usesTemplateHaskellOrQQ libBi + forceVanillaLib = doingTH && not isGhcDynamic + forceSharedLib = doingTH && isGhcDynamic + -- TH always needs default libs, even when building for profiling + + -- Determine if program coverage should be enabled and if so, what + -- '-hpcdir' should be. + let isCoverageEnabled = libCoverage lbi + -- TODO: Historically HPC files have been put into a directory which + -- has the package name. I'm going to avoid changing this for + -- now, but it would probably be better for this to be the + -- component ID instead... + pkg_name = prettyShow (PD.package pkg_descr) + distPref = fromFlag $ configDistPref $ configFlags lbi + hpcdir way + | forRepl = mempty -- HPC is not supported in ghci + | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way pkg_name + | otherwise = mempty + + createDirectoryIfMissingVerbose verbosity True libTargetDir + -- TODO: do we need to put hs-boot files into place for mutually recursive + -- modules? + let cLikeSources = fromNubListR $ mconcat + [ toNubListR (cSources libBi) + , toNubListR (cxxSources libBi) + , toNubListR (cmmSources libBi) + , toNubListR (asmSources libBi) + ] + cLikeObjs = map (`replaceExtension` objExtension) cLikeSources + baseOpts = componentGhcOptions verbosity lbi libBi clbi libTargetDir + vanillaOpts = baseOpts `mappend` mempty { + ghcOptMode = toFlag GhcModeMake, + ghcOptNumJobs = numJobs, + ghcOptInputModules = toNubListR $ allLibModules lib clbi, + ghcOptHPCDir = hpcdir Hpc.Vanilla + } + + profOpts = vanillaOpts `mappend` mempty { + ghcOptProfilingMode = toFlag True, + ghcOptProfilingAuto = Internal.profDetailLevelFlag True + (withProfLibDetail lbi), + ghcOptHiSuffix = toFlag "p_hi", + ghcOptObjSuffix = toFlag "p_o", + ghcOptExtra = hcProfOptions GHC libBi, + ghcOptHPCDir = hpcdir Hpc.Prof + } + + sharedOpts = vanillaOpts `mappend` mempty { + ghcOptDynLinkMode = toFlag GhcDynamicOnly, + ghcOptFPic = toFlag True, + ghcOptHiSuffix = toFlag "dyn_hi", + ghcOptObjSuffix = toFlag "dyn_o", + ghcOptExtra = hcSharedOptions GHC libBi, + ghcOptHPCDir = hpcdir Hpc.Dyn + } + linkerOpts = mempty { + ghcOptLinkOptions = PD.ldOptions libBi + ++ [ "-static" + | withFullyStaticExe lbi ] + -- Pass extra `ld-options` given + -- through to GHC's linker. + ++ maybe [] programOverrideArgs + (lookupProgram ldProgram (withPrograms lbi)), + ghcOptLinkLibs = if withFullyStaticExe lbi + then extraLibsStatic libBi + else extraLibs libBi, + ghcOptLinkLibPath = toNubListR $ + if withFullyStaticExe lbi + then extraLibDirsStatic libBi + else extraLibDirs libBi, + ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi, + ghcOptLinkFrameworkDirs = toNubListR $ + PD.extraFrameworkDirs libBi, + ghcOptInputFiles = toNubListR + [relLibTargetDir x | x <- cLikeObjs] + } + replOpts = vanillaOpts { + ghcOptExtra = Internal.filterGhciFlags + (ghcOptExtra vanillaOpts) + <> replOptionsFlags replFlags, + ghcOptNumJobs = mempty, + ghcOptInputModules = replNoLoad replFlags (ghcOptInputModules vanillaOpts) + } + `mappend` linkerOpts + `mappend` mempty { + ghcOptMode = toFlag GhcModeInteractive, + ghcOptOptimisation = toFlag GhcNoOptimisation + } + + vanillaSharedOpts = vanillaOpts `mappend` mempty { + ghcOptDynLinkMode = toFlag GhcStaticAndDynamic, + ghcOptDynHiSuffix = toFlag "dyn_hi", + ghcOptDynObjSuffix = toFlag "dyn_o", + ghcOptHPCDir = hpcdir Hpc.Dyn + } + + unless (forRepl || null (allLibModules lib clbi)) $ + do let vanilla = whenVanillaLib forceVanillaLib (runGhcProg vanillaOpts) + shared = whenSharedLib forceSharedLib (runGhcProg sharedOpts) + useDynToo = dynamicTooSupported && + (forceVanillaLib || withVanillaLib lbi) && + (forceSharedLib || withSharedLib lbi) && + null (hcSharedOptions GHC libBi) + if not has_code + then vanilla + else + if useDynToo + then do + runGhcProg vanillaSharedOpts + case (hpcdir Hpc.Dyn, hpcdir Hpc.Vanilla) of + (Cabal.Flag dynDir, Cabal.Flag vanillaDir) -> + -- When the vanilla and shared library builds are done + -- in one pass, only one set of HPC module interfaces + -- are generated. This set should suffice for both + -- static and dynamically linked executables. We copy + -- the modules interfaces so they are available under + -- both ways. + copyDirectoryRecursive verbosity dynDir vanillaDir + _ -> return () + else if isGhcDynamic + then do shared; vanilla + else do vanilla; shared + whenProfLib (runGhcProg profOpts) + + -- Build any C++ sources separately. + unless (not has_code || null (cxxSources libBi)) $ do + info verbosity "Building C++ Sources..." + sequence_ + [ do let baseCxxOpts = Internal.componentCxxGhcOptions verbosity implInfo + lbi libBi clbi relLibTargetDir filename + vanillaCxxOpts = if isGhcDynamic + then baseCxxOpts { ghcOptFPic = toFlag True } + else baseCxxOpts + profCxxOpts = vanillaCxxOpts `mappend` mempty { + ghcOptProfilingMode = toFlag True, + ghcOptObjSuffix = toFlag "p_o" + } + sharedCxxOpts = vanillaCxxOpts `mappend` mempty { + ghcOptFPic = toFlag True, + ghcOptDynLinkMode = toFlag GhcDynamicOnly, + ghcOptObjSuffix = toFlag "dyn_o" + } + odir = fromFlag (ghcOptObjDir vanillaCxxOpts) + createDirectoryIfMissingVerbose verbosity True odir + let runGhcProgIfNeeded cxxOpts = do + needsRecomp <- checkNeedsRecompilation filename cxxOpts + when needsRecomp $ runGhcProg cxxOpts + runGhcProgIfNeeded vanillaCxxOpts + unless forRepl $ + whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCxxOpts) + unless forRepl $ whenProfLib (runGhcProgIfNeeded profCxxOpts) + | filename <- cxxSources libBi] + + -- build any C sources + unless (not has_code || null (cSources libBi)) $ do + info verbosity "Building C Sources..." + sequence_ + [ do let baseCcOpts = Internal.componentCcGhcOptions verbosity implInfo + lbi libBi clbi relLibTargetDir filename + vanillaCcOpts = if isGhcDynamic + -- Dynamic GHC requires C sources to be built + -- with -fPIC for REPL to work. See #2207. + then baseCcOpts { ghcOptFPic = toFlag True } + else baseCcOpts + profCcOpts = vanillaCcOpts `mappend` mempty { + ghcOptProfilingMode = toFlag True, + ghcOptObjSuffix = toFlag "p_o" + } + sharedCcOpts = vanillaCcOpts `mappend` mempty { + ghcOptFPic = toFlag True, + ghcOptDynLinkMode = toFlag GhcDynamicOnly, + ghcOptObjSuffix = toFlag "dyn_o" + } + odir = fromFlag (ghcOptObjDir vanillaCcOpts) + createDirectoryIfMissingVerbose verbosity True odir + let runGhcProgIfNeeded ccOpts = do + needsRecomp <- checkNeedsRecompilation filename ccOpts + when needsRecomp $ runGhcProg ccOpts + runGhcProgIfNeeded vanillaCcOpts + unless forRepl $ + whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCcOpts) + unless forRepl $ whenProfLib (runGhcProgIfNeeded profCcOpts) + | filename <- cSources libBi] + + -- build any ASM sources + unless (not has_code || null (asmSources libBi)) $ do + info verbosity "Building Assembler Sources..." + sequence_ + [ do let baseAsmOpts = Internal.componentAsmGhcOptions verbosity implInfo + lbi libBi clbi relLibTargetDir filename + vanillaAsmOpts = if isGhcDynamic + -- Dynamic GHC requires objects to be built + -- with -fPIC for REPL to work. See #2207. + then baseAsmOpts { ghcOptFPic = toFlag True } + else baseAsmOpts + profAsmOpts = vanillaAsmOpts `mappend` mempty { + ghcOptProfilingMode = toFlag True, + ghcOptObjSuffix = toFlag "p_o" + } + sharedAsmOpts = vanillaAsmOpts `mappend` mempty { + ghcOptFPic = toFlag True, + ghcOptDynLinkMode = toFlag GhcDynamicOnly, + ghcOptObjSuffix = toFlag "dyn_o" + } + odir = fromFlag (ghcOptObjDir vanillaAsmOpts) + createDirectoryIfMissingVerbose verbosity True odir + let runGhcProgIfNeeded asmOpts = do + needsRecomp <- checkNeedsRecompilation filename asmOpts + when needsRecomp $ runGhcProg asmOpts + runGhcProgIfNeeded vanillaAsmOpts + unless forRepl $ + whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedAsmOpts) + unless forRepl $ whenProfLib (runGhcProgIfNeeded profAsmOpts) + | filename <- asmSources libBi] + + -- build any Cmm sources + unless (not has_code || null (cmmSources libBi)) $ do + info verbosity "Building C-- Sources..." + sequence_ + [ do let baseCmmOpts = Internal.componentCmmGhcOptions verbosity implInfo + lbi libBi clbi relLibTargetDir filename + vanillaCmmOpts = if isGhcDynamic + -- Dynamic GHC requires C sources to be built + -- with -fPIC for REPL to work. See #2207. + then baseCmmOpts { ghcOptFPic = toFlag True } + else baseCmmOpts + profCmmOpts = vanillaCmmOpts `mappend` mempty { + ghcOptProfilingMode = toFlag True, + ghcOptObjSuffix = toFlag "p_o" + } + sharedCmmOpts = vanillaCmmOpts `mappend` mempty { + ghcOptFPic = toFlag True, + ghcOptDynLinkMode = toFlag GhcDynamicOnly, + ghcOptObjSuffix = toFlag "dyn_o" + } + odir = fromFlag (ghcOptObjDir vanillaCmmOpts) + createDirectoryIfMissingVerbose verbosity True odir + let runGhcProgIfNeeded cmmOpts = do + needsRecomp <- checkNeedsRecompilation filename cmmOpts + when needsRecomp $ runGhcProg cmmOpts + runGhcProgIfNeeded vanillaCmmOpts + unless forRepl $ + whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCmmOpts) + unless forRepl $ whenProfLib (runGhcProgIfNeeded profCmmOpts) + | filename <- cmmSources libBi] + + -- TODO: problem here is we need the .c files built first, so we can load them + -- with ghci, but .c files can depend on .h files generated by ghc by ffi + -- exports. + whenReplLib $ do + when (null (allLibModules lib clbi)) $ warn verbosity "No exposed modules" + runGhcProg replOpts + + -- link: + when has_code . unless forRepl $ do + info verbosity "Linking..." + let cLikeProfObjs = map (`replaceExtension` ("p_" ++ objExtension)) + cLikeSources + cLikeSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension)) + cLikeSources + compiler_id = compilerId (compiler lbi) + vanillaLibFilePath = relLibTargetDir mkLibName uid + profileLibFilePath = relLibTargetDir mkProfLibName uid + sharedLibFilePath = relLibTargetDir + mkSharedLibName (hostPlatform lbi) compiler_id uid + staticLibFilePath = relLibTargetDir + mkStaticLibName (hostPlatform lbi) compiler_id uid + ghciLibFilePath = relLibTargetDir Internal.mkGHCiLibName uid + ghciProfLibFilePath = relLibTargetDir Internal.mkGHCiProfLibName uid + libInstallPath = libdir $ + absoluteComponentInstallDirs + pkg_descr lbi uid NoCopyDest + sharedLibInstallPath = libInstallPath + mkSharedLibName (hostPlatform lbi) compiler_id uid + + stubObjs <- catMaybes <$> sequenceA + [ findFileWithExtension [objExtension] [libTargetDir] + (ModuleName.toFilePath x ++"_stub") + | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files + , x <- allLibModules lib clbi ] + stubProfObjs <- catMaybes <$> sequenceA + [ findFileWithExtension ["p_" ++ objExtension] [libTargetDir] + (ModuleName.toFilePath x ++"_stub") + | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files + , x <- allLibModules lib clbi ] + stubSharedObjs <- catMaybes <$> sequenceA + [ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir] + (ModuleName.toFilePath x ++"_stub") + | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files + , x <- allLibModules lib clbi ] + + hObjs <- Internal.getHaskellObjects implInfo lib lbi clbi + relLibTargetDir objExtension True + hProfObjs <- + if withProfLib lbi + then Internal.getHaskellObjects implInfo lib lbi clbi + relLibTargetDir ("p_" ++ objExtension) True + else return [] + hSharedObjs <- + if withSharedLib lbi + then Internal.getHaskellObjects implInfo lib lbi clbi + relLibTargetDir ("dyn_" ++ objExtension) False + else return [] + + unless (null hObjs && null cLikeObjs && null stubObjs) $ do + rpaths <- getRPaths lbi clbi + + let staticObjectFiles = + hObjs + ++ map (relLibTargetDir ) cLikeObjs + ++ stubObjs + profObjectFiles = + hProfObjs + ++ map (relLibTargetDir ) cLikeProfObjs + ++ stubProfObjs + dynamicObjectFiles = + hSharedObjs + ++ map (relLibTargetDir ) cLikeSharedObjs + ++ stubSharedObjs + -- After the relocation lib is created we invoke ghc -shared + -- with the dependencies spelled out as -package arguments + -- and ghc invokes the linker with the proper library paths + ghcSharedLinkArgs = + mempty { + ghcOptShared = toFlag True, + ghcOptDynLinkMode = toFlag GhcDynamicOnly, + ghcOptInputFiles = toNubListR dynamicObjectFiles, + ghcOptOutputFile = toFlag sharedLibFilePath, + ghcOptExtra = hcSharedOptions GHC libBi, + -- For dynamic libs, Mac OS/X needs to know the install location + -- at build time. This only applies to GHC < 7.8 - see the + -- discussion in #1660. + ghcOptDylibName = if hostOS == OSX + && ghcVersion < mkVersion [7,8] + then toFlag sharedLibInstallPath + else mempty, + ghcOptHideAllPackages = toFlag True, + ghcOptNoAutoLinkPackages = toFlag True, + ghcOptPackageDBs = withPackageDB lbi, + ghcOptThisUnitId = case clbi of + LibComponentLocalBuildInfo { componentCompatPackageKey = pk } + -> toFlag pk + _ -> mempty, + ghcOptThisComponentId = case clbi of + LibComponentLocalBuildInfo + { componentInstantiatedWith = insts } -> + if null insts + then mempty + else toFlag (componentComponentId clbi) + _ -> mempty, + ghcOptInstantiatedWith = case clbi of + LibComponentLocalBuildInfo + { componentInstantiatedWith = insts } + -> insts + _ -> [], + ghcOptPackages = toNubListR $ + Internal.mkGhcOptPackages clbi , + ghcOptLinkLibs = extraLibs libBi, + ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi, + ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi, + ghcOptLinkFrameworkDirs = + toNubListR $ PD.extraFrameworkDirs libBi, + ghcOptRPaths = rpaths + } + ghcStaticLinkArgs = + mempty { + ghcOptStaticLib = toFlag True, + ghcOptInputFiles = toNubListR staticObjectFiles, + ghcOptOutputFile = toFlag staticLibFilePath, + ghcOptExtra = hcStaticOptions GHC libBi, + ghcOptHideAllPackages = toFlag True, + ghcOptNoAutoLinkPackages = toFlag True, + ghcOptPackageDBs = withPackageDB lbi, + ghcOptThisUnitId = case clbi of + LibComponentLocalBuildInfo { componentCompatPackageKey = pk } + -> toFlag pk + _ -> mempty, + ghcOptThisComponentId = case clbi of + LibComponentLocalBuildInfo + { componentInstantiatedWith = insts } -> + if null insts + then mempty + else toFlag (componentComponentId clbi) + _ -> mempty, + ghcOptInstantiatedWith = case clbi of + LibComponentLocalBuildInfo + { componentInstantiatedWith = insts } + -> insts + _ -> [], + ghcOptPackages = toNubListR $ + Internal.mkGhcOptPackages clbi , + ghcOptLinkLibs = extraLibs libBi, + ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi + } + + info verbosity (show (ghcOptPackages ghcSharedLinkArgs)) + + whenVanillaLib False $ do + Ar.createArLibArchive verbosity lbi vanillaLibFilePath staticObjectFiles + whenGHCiLib $ do + (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi) + Ld.combineObjectFiles verbosity lbi ldProg + ghciLibFilePath staticObjectFiles + + whenProfLib $ do + Ar.createArLibArchive verbosity lbi profileLibFilePath profObjectFiles + whenGHCiLib $ do + (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi) + Ld.combineObjectFiles verbosity lbi ldProg + ghciProfLibFilePath profObjectFiles + + whenSharedLib False $ + runGhcProg ghcSharedLinkArgs + + whenStaticLib False $ + runGhcProg ghcStaticLinkArgs + +-- | Start a REPL without loading any source files. +startInterpreter :: Verbosity -> ProgramDb -> Compiler -> Platform + -> PackageDBStack -> IO () +startInterpreter verbosity progdb comp platform packageDBs = do + let replOpts = mempty { + ghcOptMode = toFlag GhcModeInteractive, + ghcOptPackageDBs = packageDBs + } + checkPackageDbStack verbosity comp packageDBs + (ghcProg, _) <- requireProgram verbosity ghcProgram progdb + runGHC verbosity ghcProg comp platform replOpts + +-- ----------------------------------------------------------------------------- +-- Building an executable or foreign library + +-- | Build a foreign library +buildFLib + :: Verbosity -> Cabal.Flag (Maybe Int) + -> PackageDescription -> LocalBuildInfo + -> ForeignLib -> ComponentLocalBuildInfo -> IO () +buildFLib v njobs pkg lbi = gbuild v njobs pkg lbi . GBuildFLib + +replFLib + :: ReplOptions -> Verbosity + -> Cabal.Flag (Maybe Int) -> PackageDescription + -> LocalBuildInfo -> ForeignLib + -> ComponentLocalBuildInfo -> IO () +replFLib replFlags v njobs pkg lbi = + gbuild v njobs pkg lbi . GReplFLib replFlags + +-- | Build an executable with GHC. +-- +buildExe + :: Verbosity -> Cabal.Flag (Maybe Int) + -> PackageDescription -> LocalBuildInfo + -> Executable -> ComponentLocalBuildInfo -> IO () +buildExe v njobs pkg lbi = gbuild v njobs pkg lbi . GBuildExe + +replExe + :: ReplOptions -> Verbosity + -> Cabal.Flag (Maybe Int) -> PackageDescription + -> LocalBuildInfo -> Executable + -> ComponentLocalBuildInfo -> IO () +replExe replFlags v njobs pkg lbi = + gbuild v njobs pkg lbi . GReplExe replFlags + +-- | Building an executable, starting the REPL, and building foreign +-- libraries are all very similar and implemented in 'gbuild'. The +-- 'GBuildMode' distinguishes between the various kinds of operation. +data GBuildMode = + GBuildExe Executable + | GReplExe ReplOptions Executable + | GBuildFLib ForeignLib + | GReplFLib ReplOptions ForeignLib + +gbuildInfo :: GBuildMode -> BuildInfo +gbuildInfo (GBuildExe exe) = buildInfo exe +gbuildInfo (GReplExe _ exe) = buildInfo exe +gbuildInfo (GBuildFLib flib) = foreignLibBuildInfo flib +gbuildInfo (GReplFLib _ flib) = foreignLibBuildInfo flib + +gbuildName :: GBuildMode -> String +gbuildName (GBuildExe exe) = unUnqualComponentName $ exeName exe +gbuildName (GReplExe _ exe) = unUnqualComponentName $ exeName exe +gbuildName (GBuildFLib flib) = unUnqualComponentName $ foreignLibName flib +gbuildName (GReplFLib _ flib) = unUnqualComponentName $ foreignLibName flib + +gbuildTargetName :: LocalBuildInfo -> GBuildMode -> String +gbuildTargetName lbi (GBuildExe exe) = exeTargetName (hostPlatform lbi) exe +gbuildTargetName lbi (GReplExe _ exe) = exeTargetName (hostPlatform lbi) exe +gbuildTargetName lbi (GBuildFLib flib) = flibTargetName lbi flib +gbuildTargetName lbi (GReplFLib _ flib) = flibTargetName lbi flib + +exeTargetName :: Platform -> Executable -> String +exeTargetName platform exe = unUnqualComponentName (exeName exe) `withExt` exeExtension platform + +-- | Target name for a foreign library (the actual file name) +-- +-- We do not use mkLibName and co here because the naming for foreign libraries +-- is slightly different (we don't use "_p" or compiler version suffices, and we +-- don't want the "lib" prefix on Windows). +-- +-- TODO: We do use `dllExtension` and co here, but really that's wrong: they +-- use the OS used to build cabal to determine which extension to use, rather +-- than the target OS (but this is wrong elsewhere in Cabal as well). +flibTargetName :: LocalBuildInfo -> ForeignLib -> String +flibTargetName lbi flib = + case (os, foreignLibType flib) of + (Windows, ForeignLibNativeShared) -> nm <.> "dll" + (Windows, ForeignLibNativeStatic) -> nm <.> "lib" + (Linux, ForeignLibNativeShared) -> "lib" ++ nm <.> versionedExt + (_other, ForeignLibNativeShared) -> + "lib" ++ nm <.> dllExtension (hostPlatform lbi) + (_other, ForeignLibNativeStatic) -> + "lib" ++ nm <.> staticLibExtension (hostPlatform lbi) + (_any, ForeignLibTypeUnknown) -> cabalBug "unknown foreign lib type" + where + nm :: String + nm = unUnqualComponentName $ foreignLibName flib + + os :: OS + os = let (Platform _ os') = hostPlatform lbi + in os' + + -- If a foreign lib foo has lib-version-info 5:1:2 or + -- lib-version-linux 3.2.1, it should be built as libfoo.so.3.2.1 + -- Libtool's version-info data is translated into library versions in a + -- nontrivial way: so refer to libtool documentation. + versionedExt :: String + versionedExt = + let nums = foreignLibVersion flib os + in foldl (<.>) "so" (map show nums) + +-- | Name for the library when building. +-- +-- If the `lib-version-info` field or the `lib-version-linux` field of +-- a foreign library target is set, we need to incorporate that +-- version into the SONAME field. +-- +-- If a foreign library foo has lib-version-info 5:1:2, it should be +-- built as libfoo.so.3.2.1. We want it to get soname libfoo.so.3. +-- However, GHC does not allow overriding soname by setting linker +-- options, as it sets a soname of its own (namely the output +-- filename), after the user-supplied linker options. Hence, we have +-- to compile the library with the soname as its filename. We rename +-- the compiled binary afterwards. +-- +-- This method allows to adjust the name of the library at build time +-- such that the correct soname can be set. +flibBuildName :: LocalBuildInfo -> ForeignLib -> String +flibBuildName lbi flib + -- On linux, if a foreign-library has version data, the first digit is used + -- to produce the SONAME. + | (os, foreignLibType flib) == + (Linux, ForeignLibNativeShared) + = let nums = foreignLibVersion flib os + in "lib" ++ nm <.> foldl (<.>) "so" (map show (take 1 nums)) + | otherwise = flibTargetName lbi flib + where + os :: OS + os = let (Platform _ os') = hostPlatform lbi + in os' + + nm :: String + nm = unUnqualComponentName $ foreignLibName flib + +gbuildIsRepl :: GBuildMode -> Bool +gbuildIsRepl (GBuildExe _) = False +gbuildIsRepl (GReplExe _ _) = True +gbuildIsRepl (GBuildFLib _) = False +gbuildIsRepl (GReplFLib _ _) = True + +gbuildNeedDynamic :: LocalBuildInfo -> GBuildMode -> Bool +gbuildNeedDynamic lbi bm = + case bm of + GBuildExe _ -> withDynExe lbi + GReplExe _ _ -> withDynExe lbi + GBuildFLib flib -> withDynFLib flib + GReplFLib _ flib -> withDynFLib flib + where + withDynFLib flib = + case foreignLibType flib of + ForeignLibNativeShared -> + ForeignLibStandalone `notElem` foreignLibOptions flib + ForeignLibNativeStatic -> + False + ForeignLibTypeUnknown -> + cabalBug "unknown foreign lib type" + +gbuildModDefFiles :: GBuildMode -> [FilePath] +gbuildModDefFiles (GBuildExe _) = [] +gbuildModDefFiles (GReplExe _ _) = [] +gbuildModDefFiles (GBuildFLib flib) = foreignLibModDefFile flib +gbuildModDefFiles (GReplFLib _ flib) = foreignLibModDefFile flib + +-- | "Main" module name when overridden by @ghc-options: -main-is ...@ +-- or 'Nothing' if no @-main-is@ flag could be found. +-- +-- In case of 'Nothing', 'Distribution.ModuleName.main' can be assumed. +exeMainModuleName :: Executable -> Maybe ModuleName +exeMainModuleName Executable{buildInfo = bnfo} = + -- GHC honors the last occurrence of a module name updated via -main-is + -- + -- Moreover, -main-is when parsed left-to-right can update either + -- the "Main" module name, or the "main" function name, or both, + -- see also 'decodeMainIsArg'. + msum $ reverse $ map decodeMainIsArg $ findIsMainArgs ghcopts + where + ghcopts = hcOptions GHC bnfo + + findIsMainArgs [] = [] + findIsMainArgs ("-main-is":arg:rest) = arg : findIsMainArgs rest + findIsMainArgs (_:rest) = findIsMainArgs rest + +-- | Decode argument to '-main-is' +-- +-- Returns 'Nothing' if argument set only the function name. +-- +-- This code has been stolen/refactored from GHC's DynFlags.setMainIs +-- function. The logic here is deliberately imperfect as it is +-- intended to be bug-compatible with GHC's parser. See discussion in +-- https://github.com/haskell/cabal/pull/4539#discussion_r118981753. +decodeMainIsArg :: String -> Maybe ModuleName +decodeMainIsArg arg + | headOf main_fn isLower + -- The arg looked like "Foo.Bar.baz" + = Just (ModuleName.fromString main_mod) + | headOf arg isUpper -- The arg looked like "Foo" or "Foo.Bar" + = Just (ModuleName.fromString arg) + | otherwise -- The arg looked like "baz" + = Nothing + where + headOf :: String -> (Char -> Bool) -> Bool + headOf str pred' = any pred' (safeHead str) + + (main_mod, main_fn) = splitLongestPrefix arg (== '.') + + splitLongestPrefix :: String -> (Char -> Bool) -> (String,String) + splitLongestPrefix str pred' + | null r_pre = (str, []) + | otherwise = (reverse (safeTail r_pre), reverse r_suf) + -- 'safeTail' drops the char satisfying 'pred' + where (r_suf, r_pre) = break pred' (reverse str) + +-- | A collection of: +-- * C input files +-- * C++ input files +-- * GHC input files +-- * GHC input modules +-- +-- Used to correctly build and link sources. +data BuildSources = BuildSources { + cSourcesFiles :: [FilePath], + cxxSourceFiles :: [FilePath], + inputSourceFiles :: [FilePath], + inputSourceModules :: [ModuleName] + } + +-- | Locate and return the 'BuildSources' required to build and link. +gbuildSources :: Verbosity + -> PackageId + -> CabalSpecVersion + -> FilePath + -> GBuildMode + -> IO BuildSources +gbuildSources verbosity pkgId specVer tmpDir bm = + case bm of + GBuildExe exe -> exeSources exe + GReplExe _ exe -> exeSources exe + GBuildFLib flib -> return $ flibSources flib + GReplFLib _ flib -> return $ flibSources flib + where + exeSources :: Executable -> IO BuildSources + exeSources exe@Executable{buildInfo = bnfo, modulePath = modPath} = do + main <- findFileEx verbosity (tmpDir : map getSymbolicPath (hsSourceDirs bnfo)) modPath + let mainModName = fromMaybe ModuleName.main $ exeMainModuleName exe + otherModNames = exeModules exe + + -- Scripts have fakePackageId and are always Haskell but can have any extension. + if isHaskell main || pkgId == fakePackageId + then + if specVer < CabalSpecV2_0 && (mainModName `elem` otherModNames) + then do + -- The cabal manual clearly states that `other-modules` is + -- intended for non-main modules. However, there's at least one + -- important package on Hackage (happy-1.19.5) which + -- violates this. We workaround this here so that we don't + -- invoke GHC with e.g. 'ghc --make Main src/Main.hs' which + -- would result in GHC complaining about duplicate Main + -- modules. + -- + -- Finally, we only enable this workaround for + -- specVersion < 2, as 'cabal-version:>=2.0' cabal files + -- have no excuse anymore to keep doing it wrong... ;-) + warn verbosity $ "Enabling workaround for Main module '" + ++ prettyShow mainModName + ++ "' listed in 'other-modules' illegally!" + + return BuildSources { + cSourcesFiles = cSources bnfo, + cxxSourceFiles = cxxSources bnfo, + inputSourceFiles = [main], + inputSourceModules = filter (/= mainModName) $ + exeModules exe + } + + else return BuildSources { + cSourcesFiles = cSources bnfo, + cxxSourceFiles = cxxSources bnfo, + inputSourceFiles = [main], + inputSourceModules = exeModules exe + } + else let (csf, cxxsf) + | isCxx main = ( cSources bnfo, main : cxxSources bnfo) + -- if main is not a Haskell source + -- and main is not a C++ source + -- then we assume that it is a C source + | otherwise = (main : cSources bnfo, cxxSources bnfo) + + in return BuildSources { + cSourcesFiles = csf, + cxxSourceFiles = cxxsf, + inputSourceFiles = [], + inputSourceModules = exeModules exe + } + + flibSources :: ForeignLib -> BuildSources + flibSources flib@ForeignLib{foreignLibBuildInfo = bnfo} = + BuildSources { + cSourcesFiles = cSources bnfo, + cxxSourceFiles = cxxSources bnfo, + inputSourceFiles = [], + inputSourceModules = foreignLibModules flib + } + + isCxx :: FilePath -> Bool + isCxx fp = elem (takeExtension fp) [".cpp", ".cxx", ".c++"] + +-- | FilePath has a Haskell extension: .hs or .lhs +isHaskell :: FilePath -> Bool +isHaskell fp = elem (takeExtension fp) [".hs", ".lhs"] + +replNoLoad :: Ord a => ReplOptions -> NubListR a -> NubListR a +replNoLoad replFlags l + | replOptionsNoLoad replFlags == Flag True = mempty + | otherwise = l + +-- | Generic build function. See comment for 'GBuildMode'. +gbuild :: Verbosity -> Cabal.Flag (Maybe Int) + -> PackageDescription -> LocalBuildInfo + -> GBuildMode -> ComponentLocalBuildInfo -> IO () +gbuild verbosity numJobs pkg_descr lbi bm clbi = do + (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi) + let replFlags = case bm of + GReplExe flags _ -> flags + GReplFLib flags _ -> flags + GBuildExe{} -> mempty + GBuildFLib{} -> mempty + comp = compiler lbi + platform = hostPlatform lbi + implInfo = getImplInfo comp + runGhcProg = runGHC verbosity ghcProg comp platform + + let bnfo = gbuildInfo bm + + -- the name that GHC really uses (e.g., with .exe on Windows for executables) + let targetName = gbuildTargetName lbi bm + let targetDir = buildDir lbi (gbuildName bm) + let tmpDir = targetDir (gbuildName bm ++ "-tmp") + createDirectoryIfMissingVerbose verbosity True targetDir + createDirectoryIfMissingVerbose verbosity True tmpDir + + -- TODO: do we need to put hs-boot files into place for mutually recursive + -- modules? FIX: what about exeName.hi-boot? + + -- Determine if program coverage should be enabled and if so, what + -- '-hpcdir' should be. + let isCoverageEnabled = exeCoverage lbi + distPref = fromFlag $ configDistPref $ configFlags lbi + hpcdir way + | gbuildIsRepl bm = mempty -- HPC is not supported in ghci + | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way (gbuildName bm) + | otherwise = mempty + + rpaths <- getRPaths lbi clbi + buildSources <- gbuildSources verbosity (package pkg_descr) (specVersion pkg_descr) tmpDir bm + + let cSrcs = cSourcesFiles buildSources + cxxSrcs = cxxSourceFiles buildSources + inputFiles = inputSourceFiles buildSources + inputModules = inputSourceModules buildSources + isGhcDynamic = isDynamic comp + dynamicTooSupported = supportsDynamicToo comp + cLikeObjs = map (`replaceExtension` objExtension) cSrcs + cxxObjs = map (`replaceExtension` objExtension) cxxSrcs + needDynamic = gbuildNeedDynamic lbi bm + needProfiling = withProfExe lbi + + -- build executables + baseOpts = (componentGhcOptions verbosity lbi bnfo clbi tmpDir) + `mappend` mempty { + ghcOptMode = toFlag GhcModeMake, + ghcOptInputFiles = toNubListR $ if package pkg_descr == fakePackageId + then filter isHaskell inputFiles + else inputFiles, + ghcOptInputScripts = toNubListR $ if package pkg_descr == fakePackageId + then filter (not . isHaskell) inputFiles + else [], + ghcOptInputModules = toNubListR inputModules + } + staticOpts = baseOpts `mappend` mempty { + ghcOptDynLinkMode = toFlag GhcStaticOnly, + ghcOptHPCDir = hpcdir Hpc.Vanilla + } + profOpts = baseOpts `mappend` mempty { + ghcOptProfilingMode = toFlag True, + ghcOptProfilingAuto = Internal.profDetailLevelFlag False + (withProfExeDetail lbi), + ghcOptHiSuffix = toFlag "p_hi", + ghcOptObjSuffix = toFlag "p_o", + ghcOptExtra = hcProfOptions GHC bnfo, + ghcOptHPCDir = hpcdir Hpc.Prof + } + dynOpts = baseOpts `mappend` mempty { + ghcOptDynLinkMode = toFlag GhcDynamicOnly, + -- TODO: Does it hurt to set -fPIC for executables? + ghcOptFPic = toFlag True, + ghcOptHiSuffix = toFlag "dyn_hi", + ghcOptObjSuffix = toFlag "dyn_o", + ghcOptExtra = hcSharedOptions GHC bnfo, + ghcOptHPCDir = hpcdir Hpc.Dyn + } + dynTooOpts = staticOpts `mappend` mempty { + ghcOptDynLinkMode = toFlag GhcStaticAndDynamic, + ghcOptDynHiSuffix = toFlag "dyn_hi", + ghcOptDynObjSuffix = toFlag "dyn_o", + ghcOptHPCDir = hpcdir Hpc.Dyn + } + linkerOpts = mempty { + ghcOptLinkOptions = PD.ldOptions bnfo + ++ [ "-static" + | withFullyStaticExe lbi ] + -- Pass extra `ld-options` given + -- through to GHC's linker. + ++ maybe [] programOverrideArgs + (lookupProgram ldProgram (withPrograms lbi)), + ghcOptLinkLibs = if withFullyStaticExe lbi + then extraLibsStatic bnfo + else extraLibs bnfo, + ghcOptLinkLibPath = toNubListR $ + if withFullyStaticExe lbi + then extraLibDirsStatic bnfo + else extraLibDirs bnfo, + ghcOptLinkFrameworks = toNubListR $ + PD.frameworks bnfo, + ghcOptLinkFrameworkDirs = toNubListR $ + PD.extraFrameworkDirs bnfo, + ghcOptInputFiles = toNubListR + [tmpDir x | x <- cLikeObjs ++ cxxObjs] + } + dynLinkerOpts = mempty { + ghcOptRPaths = rpaths, + ghcOptInputFiles = toNubListR + [tmpDir x | x <- cLikeObjs ++ cxxObjs] + } + replOpts = baseOpts { + ghcOptExtra = Internal.filterGhciFlags + (ghcOptExtra baseOpts) + <> replOptionsFlags replFlags, + ghcOptInputModules = replNoLoad replFlags (ghcOptInputModules baseOpts), + ghcOptInputFiles = replNoLoad replFlags (ghcOptInputFiles baseOpts) + } + -- For a normal compile we do separate invocations of ghc for + -- compiling as for linking. But for repl we have to do just + -- the one invocation, so that one has to include all the + -- linker stuff too, like -l flags and any .o files from C + -- files etc. + `mappend` linkerOpts + `mappend` mempty { + ghcOptMode = toFlag GhcModeInteractive, + ghcOptOptimisation = toFlag GhcNoOptimisation + } + commonOpts | needProfiling = profOpts + | needDynamic = dynOpts + | otherwise = staticOpts + compileOpts | useDynToo = dynTooOpts + | otherwise = commonOpts + withStaticExe = not needProfiling && not needDynamic + + -- For building exe's that use TH with -prof or -dynamic we actually have + -- to build twice, once without -prof/-dynamic and then again with + -- -prof/-dynamic. This is because the code that TH needs to run at + -- compile time needs to be the vanilla ABI so it can be loaded up and run + -- by the compiler. + -- With dynamic-by-default GHC the TH object files loaded at compile-time + -- need to be .dyn_o instead of .o. + doingTH = usesTemplateHaskellOrQQ bnfo + -- Should we use -dynamic-too instead of compiling twice? + useDynToo = dynamicTooSupported && isGhcDynamic + && doingTH && withStaticExe + && null (hcSharedOptions GHC bnfo) + compileTHOpts | isGhcDynamic = dynOpts + | otherwise = staticOpts + compileForTH + | gbuildIsRepl bm = False + | useDynToo = False + | isGhcDynamic = doingTH && (needProfiling || withStaticExe) + | otherwise = doingTH && (needProfiling || needDynamic) + + -- Build static/dynamic object files for TH, if needed. + when compileForTH $ + runGhcProg compileTHOpts { ghcOptNoLink = toFlag True + , ghcOptNumJobs = numJobs } + + -- Do not try to build anything if there are no input files. + -- This can happen if the cabal file ends up with only cSrcs + -- but no Haskell modules. + unless ((null inputFiles && null inputModules) + || gbuildIsRepl bm) $ + runGhcProg compileOpts { ghcOptNoLink = toFlag True + , ghcOptNumJobs = numJobs } + + -- build any C++ sources + unless (null cxxSrcs) $ do + info verbosity "Building C++ Sources..." + sequence_ + [ do let baseCxxOpts = Internal.componentCxxGhcOptions verbosity implInfo + lbi bnfo clbi tmpDir filename + vanillaCxxOpts = if isGhcDynamic + -- Dynamic GHC requires C++ sources to be built + -- with -fPIC for REPL to work. See #2207. + then baseCxxOpts { ghcOptFPic = toFlag True } + else baseCxxOpts + profCxxOpts = vanillaCxxOpts `mappend` mempty { + ghcOptProfilingMode = toFlag True + } + sharedCxxOpts = vanillaCxxOpts `mappend` mempty { + ghcOptFPic = toFlag True, + ghcOptDynLinkMode = toFlag GhcDynamicOnly + } + opts | needProfiling = profCxxOpts + | needDynamic = sharedCxxOpts + | otherwise = vanillaCxxOpts + -- TODO: Placing all Haskell, C, & C++ objects in a single directory + -- Has the potential for file collisions. In general we would + -- consider this a user error. However, we should strive to + -- add a warning if this occurs. + odir = fromFlag (ghcOptObjDir opts) + createDirectoryIfMissingVerbose verbosity True odir + needsRecomp <- checkNeedsRecompilation filename opts + when needsRecomp $ + runGhcProg opts + | filename <- cxxSrcs ] + + -- build any C sources + unless (null cSrcs) $ do + info verbosity "Building C Sources..." + sequence_ + [ do let baseCcOpts = Internal.componentCcGhcOptions verbosity implInfo + lbi bnfo clbi tmpDir filename + vanillaCcOpts = if isGhcDynamic + -- Dynamic GHC requires C sources to be built + -- with -fPIC for REPL to work. See #2207. + then baseCcOpts { ghcOptFPic = toFlag True } + else baseCcOpts + profCcOpts = vanillaCcOpts `mappend` mempty { + ghcOptProfilingMode = toFlag True + } + sharedCcOpts = vanillaCcOpts `mappend` mempty { + ghcOptFPic = toFlag True, + ghcOptDynLinkMode = toFlag GhcDynamicOnly + } + opts | needProfiling = profCcOpts + | needDynamic = sharedCcOpts + | otherwise = vanillaCcOpts + odir = fromFlag (ghcOptObjDir opts) + createDirectoryIfMissingVerbose verbosity True odir + needsRecomp <- checkNeedsRecompilation filename opts + when needsRecomp $ + runGhcProg opts + | filename <- cSrcs ] + + -- TODO: problem here is we need the .c files built first, so we can load them + -- with ghci, but .c files can depend on .h files generated by ghc by ffi + -- exports. + case bm of + GReplExe _ _ -> runGhcProg replOpts + GReplFLib _ _ -> runGhcProg replOpts + GBuildExe _ -> do + let linkOpts = commonOpts + `mappend` linkerOpts + `mappend` mempty { + ghcOptLinkNoHsMain = toFlag (null inputFiles) + } + `mappend` (if withDynExe lbi then dynLinkerOpts else mempty) + + info verbosity "Linking..." + -- Work around old GHCs not relinking in this + -- situation, see #3294 + let target = targetDir targetName + when (compilerVersion comp < mkVersion [7,7]) $ do + e <- doesFileExist target + when e (removeFile target) + runGhcProg linkOpts { ghcOptOutputFile = toFlag target } + GBuildFLib flib -> do + let -- Instruct GHC to link against libHSrts. + rtsLinkOpts :: GhcOptions + rtsLinkOpts + | supportsFLinkRts = + mempty { + ghcOptLinkRts = toFlag True + } + | otherwise = + mempty { + ghcOptLinkLibs = rtsOptLinkLibs, + ghcOptLinkLibPath = toNubListR $ rtsLibPaths rtsInfo + } + where + threaded = hasThreaded (gbuildInfo bm) + supportsFLinkRts = compilerVersion comp >= mkVersion [9,0] + rtsInfo = extractRtsInfo lbi + rtsOptLinkLibs = [ + if needDynamic + then if threaded + then dynRtsThreadedLib (rtsDynamicInfo rtsInfo) + else dynRtsVanillaLib (rtsDynamicInfo rtsInfo) + else if threaded + then statRtsThreadedLib (rtsStaticInfo rtsInfo) + else statRtsVanillaLib (rtsStaticInfo rtsInfo) + ] + + + linkOpts :: GhcOptions + linkOpts = case foreignLibType flib of + ForeignLibNativeShared -> + commonOpts + `mappend` linkerOpts + `mappend` dynLinkerOpts + `mappend` rtsLinkOpts + `mappend` mempty { + ghcOptLinkNoHsMain = toFlag True, + ghcOptShared = toFlag True, + ghcOptFPic = toFlag True, + ghcOptLinkModDefFiles = toNubListR $ gbuildModDefFiles bm + } + -- See Note [RPATH] + `mappend` ifNeedsRPathWorkaround lbi mempty { + ghcOptLinkOptions = ["-Wl,--no-as-needed"] + , ghcOptLinkLibs = ["ffi"] + } + ForeignLibNativeStatic -> + -- this should be caught by buildFLib + -- (and if we do implement this, we probably don't even want to call + -- ghc here, but rather Ar.createArLibArchive or something) + cabalBug "static libraries not yet implemented" + ForeignLibTypeUnknown -> + cabalBug "unknown foreign lib type" + -- We build under a (potentially) different filename to set a + -- soname on supported platforms. See also the note for + -- @flibBuildName@. + info verbosity "Linking..." + let buildName = flibBuildName lbi flib + runGhcProg linkOpts { ghcOptOutputFile = toFlag (targetDir buildName) } + renameFile (targetDir buildName) (targetDir targetName) + +{- +Note [RPATH] +~~~~~~~~~~~~ + +Suppose that the dynamic library depends on `base`, but not (directly) on +`integer-gmp` (which, however, is a dependency of `base`). We will link the +library as + + gcc ... -lHSbase-4.7.0.2-ghc7.8.4 -lHSinteger-gmp-0.5.1.0-ghc7.8.4 ... + +However, on systems (like Ubuntu) where the linker gets called with `-as-needed` +by default, the linker will notice that `integer-gmp` isn't actually a direct +dependency and hence omit the link. + +Then when we attempt to link a C program against this dynamic library, the +_static_ linker will attempt to verify that all symbols can be resolved. The +dynamic library itself does not require any symbols from `integer-gmp`, but +`base` does. In order to verify that the symbols used by `base` can be +resolved, the static linker needs to be able to _find_ integer-gmp. + +Finding the `base` dependency is simple, because the dynamic elf header +(`readelf -d`) for the library that we have created looks something like + + (NEEDED) Shared library: [libHSbase-4.7.0.2-ghc7.8.4.so] + (RPATH) Library rpath: [/path/to/base-4.7.0.2:...] + +However, when it comes to resolving the dependency on `integer-gmp`, it needs +to look at the dynamic header for `base`. On modern ghc (7.8 and higher) this +looks something like + + (NEEDED) Shared library: [libHSinteger-gmp-0.5.1.0-ghc7.8.4.so] + (RPATH) Library rpath: [$ORIGIN/../integer-gmp-0.5.1.0:...] + +This specifies the location of `integer-gmp` _in terms of_ the location of base +(using the `$ORIGIN`) variable. But here's the crux: when the static linker +attempts to verify that all symbols can be resolved, [**IT DOES NOT RESOLVE +`$ORIGIN`**](http://stackoverflow.com/questions/6323603/ld-using-rpath-origin-inside-a-shared-library-recursive). +As a consequence, it will not be able to resolve the symbols and report the +missing symbols as errors, _even though the dynamic linker **would** be able to +resolve these symbols_. We can tell the static linker not to report these +errors by using `--unresolved-symbols=ignore-all` and all will be fine when we +run the program ([(indeed, this is what the gold linker +does)](https://sourceware.org/ml/binutils/2013-05/msg00038.html), but it makes +the resulting library more difficult to use. + +Instead what we can do is make sure that the generated dynamic library has +explicit top-level dependencies on these libraries. This means that the static +linker knows where to find them, and when we have transitive dependencies on +the same libraries the linker will only load them once, so we avoid needing to +look at the `RPATH` of our dependencies. We can do this by passing +`--no-as-needed` to the linker, so that it doesn't omit any libraries. + +Note that on older ghc (7.6 and before) the Haskell libraries don't have an +RPATH set at all, which makes it even more important that we make these +top-level dependencies. + +Finally, we have to explicitly link against `libffi` for the same reason. For +newer ghc this _happens_ to be unnecessary on many systems because `libffi` is +a library which is not specific to GHC, and when the static linker verifies +that all symbols can be resolved it will find the `libffi` that is globally +installed (completely independent from ghc). Of course, this may well be the +_wrong_ version of `libffi`, but it's quite possible that symbol resolution +happens to work. This is of course the wrong approach, which is why we link +explicitly against `libffi` so that we will find the _right_ version of +`libffi`. +-} + +-- | Do we need the RPATH workaround? +-- +-- See Note [RPATH]. +ifNeedsRPathWorkaround :: Monoid a => LocalBuildInfo -> a -> a +ifNeedsRPathWorkaround lbi a = + case hostPlatform lbi of + Platform _ Linux -> a + _otherwise -> mempty + +data DynamicRtsInfo = DynamicRtsInfo { + dynRtsVanillaLib :: FilePath + , dynRtsThreadedLib :: FilePath + , dynRtsDebugLib :: FilePath + , dynRtsEventlogLib :: FilePath + , dynRtsThreadedDebugLib :: FilePath + , dynRtsThreadedEventlogLib :: FilePath + } + +data StaticRtsInfo = StaticRtsInfo { + statRtsVanillaLib :: FilePath + , statRtsThreadedLib :: FilePath + , statRtsDebugLib :: FilePath + , statRtsEventlogLib :: FilePath + , statRtsThreadedDebugLib :: FilePath + , statRtsThreadedEventlogLib :: FilePath + , statRtsProfilingLib :: FilePath + , statRtsThreadedProfilingLib :: FilePath + } + +data RtsInfo = RtsInfo { + rtsDynamicInfo :: DynamicRtsInfo + , rtsStaticInfo :: StaticRtsInfo + , rtsLibPaths :: [FilePath] + } + +-- | Extract (and compute) information about the RTS library +-- +-- TODO: This hardcodes the name as @HSrts-ghc@. I don't know if we can +-- find this information somewhere. We can lookup the 'hsLibraries' field of +-- 'InstalledPackageInfo' but it will tell us @["HSrts", "Cffi"]@, which +-- doesn't really help. +extractRtsInfo :: LocalBuildInfo -> RtsInfo +extractRtsInfo lbi = + case PackageIndex.lookupPackageName + (installedPkgs lbi) (mkPackageName "rts") of + [(_, [rts])] -> aux rts + _otherwise -> error "No (or multiple) ghc rts package is registered" + where + aux :: InstalledPackageInfo -> RtsInfo + aux rts = RtsInfo { + rtsDynamicInfo = DynamicRtsInfo { + dynRtsVanillaLib = withGhcVersion "HSrts" + , dynRtsThreadedLib = withGhcVersion "HSrts_thr" + , dynRtsDebugLib = withGhcVersion "HSrts_debug" + , dynRtsEventlogLib = withGhcVersion "HSrts_l" + , dynRtsThreadedDebugLib = withGhcVersion "HSrts_thr_debug" + , dynRtsThreadedEventlogLib = withGhcVersion "HSrts_thr_l" + } + , rtsStaticInfo = StaticRtsInfo { + statRtsVanillaLib = "HSrts" + , statRtsThreadedLib = "HSrts_thr" + , statRtsDebugLib = "HSrts_debug" + , statRtsEventlogLib = "HSrts_l" + , statRtsThreadedDebugLib = "HSrts_thr_debug" + , statRtsThreadedEventlogLib = "HSrts_thr_l" + , statRtsProfilingLib = "HSrts_p" + , statRtsThreadedProfilingLib = "HSrts_thr_p" + } + , rtsLibPaths = InstalledPackageInfo.libraryDirs rts + } + withGhcVersion = (++ ("-ghc" ++ prettyShow (compilerVersion (compiler lbi)))) + +-- | Returns True if the modification date of the given source file is newer than +-- the object file we last compiled for it, or if no object file exists yet. +checkNeedsRecompilation :: FilePath -> GhcOptions -> IO Bool +checkNeedsRecompilation filename opts = filename `moreRecentFile` oname + where oname = getObjectFileName filename opts + +-- | Finds the object file name of the given source file +getObjectFileName :: FilePath -> GhcOptions -> FilePath +getObjectFileName filename opts = oname + where odir = fromFlag (ghcOptObjDir opts) + oext = fromFlagOrDefault "o" (ghcOptObjSuffix opts) + oname = odir replaceExtension filename oext + +-- | Calculate the RPATHs for the component we are building. +-- +-- Calculates relative RPATHs when 'relocatable' is set. +getRPaths :: LocalBuildInfo + -> ComponentLocalBuildInfo -- ^ Component we are building + -> IO (NubListR FilePath) +getRPaths lbi clbi | supportRPaths hostOS = do + libraryPaths <- depLibraryPaths False (relocatable lbi) lbi clbi + let hostPref = case hostOS of + OSX -> "@loader_path" + _ -> "$ORIGIN" + relPath p = if isRelative p then hostPref p else p + rpaths = toNubListR (map relPath libraryPaths) + return rpaths + where + (Platform _ hostOS) = hostPlatform lbi + compid = compilerId . compiler $ lbi + + -- The list of RPath-supported operating systems below reflects the + -- platforms on which Cabal's RPATH handling is tested. It does _NOT_ + -- reflect whether the OS supports RPATH. + + -- E.g. when this comment was written, the *BSD operating systems were + -- untested with regards to Cabal RPATH handling, and were hence set to + -- 'False', while those operating systems themselves do support RPATH. + supportRPaths Linux   = True + supportRPaths Windows = False + supportRPaths OSX   = True + supportRPaths FreeBSD   = + case compid of + CompilerId GHC ver | ver >= mkVersion [7,10,2] -> True + _ -> False + supportRPaths OpenBSD   = False + supportRPaths NetBSD   = False + supportRPaths DragonFly = False + supportRPaths Solaris = False + supportRPaths AIX = False + supportRPaths HPUX = False + supportRPaths IRIX = False + supportRPaths HaLVM = False + supportRPaths IOS = False + supportRPaths Android = False + supportRPaths Ghcjs = False + supportRPaths Wasi = False + supportRPaths Hurd = False + supportRPaths (OtherOS _) = False + -- Do _not_ add a default case so that we get a warning here when a new OS + -- is added. + +getRPaths _ _ = return mempty + +-- | Determine whether the given 'BuildInfo' is intended to link against the +-- threaded RTS. This is used to determine which RTS to link against when +-- building a foreign library with a GHC without support for @-flink-rts@. +hasThreaded :: BuildInfo -> Bool +hasThreaded bi = elem "-threaded" ghc + where + PerCompilerFlavor ghc _ = options bi + +-- | Extracts a String representing a hash of the ABI of a built +-- library. It can fail if the library has not yet been built. +-- +libAbiHash :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Library -> ComponentLocalBuildInfo -> IO String +libAbiHash verbosity _pkg_descr lbi lib clbi = do + let + libBi = libBuildInfo lib + comp = compiler lbi + platform = hostPlatform lbi + vanillaArgs0 = + (componentGhcOptions verbosity lbi libBi clbi (componentBuildDir lbi clbi)) + `mappend` mempty { + ghcOptMode = toFlag GhcModeAbiHash, + ghcOptInputModules = toNubListR $ exposedModules lib + } + vanillaArgs = + -- Package DBs unnecessary, and break ghc-cabal. See #3633 + -- BUT, put at least the global database so that 7.4 doesn't + -- break. + vanillaArgs0 { ghcOptPackageDBs = [GlobalPackageDB] + , ghcOptPackages = mempty } + sharedArgs = vanillaArgs `mappend` mempty { + ghcOptDynLinkMode = toFlag GhcDynamicOnly, + ghcOptFPic = toFlag True, + ghcOptHiSuffix = toFlag "dyn_hi", + ghcOptObjSuffix = toFlag "dyn_o", + ghcOptExtra = hcSharedOptions GHC libBi + } + profArgs = vanillaArgs `mappend` mempty { + ghcOptProfilingMode = toFlag True, + ghcOptProfilingAuto = Internal.profDetailLevelFlag True + (withProfLibDetail lbi), + ghcOptHiSuffix = toFlag "p_hi", + ghcOptObjSuffix = toFlag "p_o", + ghcOptExtra = hcProfOptions GHC libBi + } + ghcArgs + | withVanillaLib lbi = vanillaArgs + | withSharedLib lbi = sharedArgs + | withProfLib lbi = profArgs + | otherwise = error "libAbiHash: Can't find an enabled library way" + + (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi) + hash <- getProgramInvocationOutput verbosity + (ghcInvocation ghcProg comp platform ghcArgs) + return (takeWhile (not . isSpace) hash) + +componentGhcOptions :: Verbosity -> LocalBuildInfo + -> BuildInfo -> ComponentLocalBuildInfo -> FilePath + -> GhcOptions +componentGhcOptions verbosity lbi = + Internal.componentGhcOptions verbosity implInfo lbi + where + comp = compiler lbi + implInfo = getImplInfo comp + +componentCcGhcOptions :: Verbosity -> LocalBuildInfo + -> BuildInfo -> ComponentLocalBuildInfo + -> FilePath -> FilePath + -> GhcOptions +componentCcGhcOptions verbosity lbi = + Internal.componentCcGhcOptions verbosity implInfo lbi + where + comp = compiler lbi + implInfo = getImplInfo comp + +-- ----------------------------------------------------------------------------- +-- Installing + +-- |Install executables for GHC. +installExe :: Verbosity + -> LocalBuildInfo + -> FilePath -- ^Where to copy the files to + -> FilePath -- ^Build location + -> (FilePath, FilePath) -- ^Executable (prefix,suffix) + -> PackageDescription + -> Executable + -> IO () +installExe verbosity lbi binDir buildPref + (progprefix, progsuffix) _pkg exe = do + createDirectoryIfMissingVerbose verbosity True binDir + let exeName' = unUnqualComponentName $ exeName exe + exeFileName = exeTargetName (hostPlatform lbi) exe + fixedExeBaseName = progprefix ++ exeName' ++ progsuffix + installBinary dest = do + installExecutableFile verbosity + (buildPref exeName' exeFileName) + (dest <.> exeExtension (hostPlatform lbi)) + when (stripExes lbi) $ + Strip.stripExe verbosity (hostPlatform lbi) (withPrograms lbi) + (dest <.> exeExtension (hostPlatform lbi)) + installBinary (binDir fixedExeBaseName) + +-- |Install foreign library for GHC. +installFLib :: Verbosity + -> LocalBuildInfo + -> FilePath -- ^install location + -> FilePath -- ^Build location + -> PackageDescription + -> ForeignLib + -> IO () +installFLib verbosity lbi targetDir builtDir _pkg flib = + install (foreignLibIsShared flib) + builtDir + targetDir + (flibTargetName lbi flib) + where + install isShared srcDir dstDir name = do + let src = srcDir name + dst = dstDir name + createDirectoryIfMissingVerbose verbosity True targetDir + -- TODO: Should we strip? (stripLibs lbi) + if isShared + then installExecutableFile verbosity src dst + else installOrdinaryFile verbosity src dst + -- Now install appropriate symlinks if library is versioned + let (Platform _ os) = hostPlatform lbi + when (not (null (foreignLibVersion flib os))) $ do + when (os /= Linux) $ die' verbosity + -- It should be impossible to get here. + "Can't install foreign-library symlink on non-Linux OS" +#ifndef mingw32_HOST_OS + -- 'createSymbolicLink file1 file2' creates a symbolic link + -- named 'file2' which points to the file 'file1'. + -- Note that we do want a symlink to 'name' rather than + -- 'dst', because the symlink will be relative to the + -- directory it's created in. + -- Finally, we first create the symlinks in a temporary + -- directory and then rename to simulate 'ln --force'. + withTempDirectory verbosity dstDir nm $ \tmpDir -> do + let link1 = flibBuildName lbi flib + link2 = "lib" ++ nm <.> "so" + createSymbolicLink name (tmpDir link1) + renameFile (tmpDir link1) (dstDir link1) + createSymbolicLink name (tmpDir link2) + renameFile (tmpDir link2) (dstDir link2) + where + nm :: String + nm = unUnqualComponentName $ foreignLibName flib +#endif /* mingw32_HOST_OS */ + + +-- |Install for ghc, .hi, .a and, if --with-ghci given, .o +installLib :: Verbosity + -> LocalBuildInfo + -> FilePath -- ^install location + -> FilePath -- ^install location for dynamic libraries + -> FilePath -- ^Build location + -> PackageDescription + -> Library + -> ComponentLocalBuildInfo + -> IO () +installLib verbosity lbi targetDir dynlibTargetDir _builtDir pkg lib clbi = do + -- copy .hi files over: + whenVanilla $ copyModuleFiles "hi" + whenProf $ copyModuleFiles "p_hi" + whenShared $ copyModuleFiles "dyn_hi" + + -- copy the built library files over: + whenHasCode $ do + whenVanilla $ do + sequence_ [ installOrdinary + builtDir + targetDir + (mkGenericStaticLibName (l ++ f)) + | l <- getHSLibraryName + (componentUnitId clbi):(extraBundledLibs (libBuildInfo lib)) + , f <- "":extraLibFlavours (libBuildInfo lib) + ] + whenGHCi $ installOrdinary builtDir targetDir ghciLibName + whenProf $ do + installOrdinary builtDir targetDir profileLibName + whenGHCi $ installOrdinary builtDir targetDir ghciProfLibName + whenShared $ if + -- The behavior for "extra-bundled-libraries" changed in version 2.5.0. + -- See ghc issue #15837 and Cabal PR #5855. + | specVersion pkg < CabalSpecV3_0 -> do + sequence_ [ installShared builtDir dynlibTargetDir + (mkGenericSharedLibName platform compiler_id (l ++ f)) + | l <- getHSLibraryName uid : extraBundledLibs (libBuildInfo lib) + , f <- "":extraDynLibFlavours (libBuildInfo lib) + ] + | otherwise -> do + sequence_ [ installShared + builtDir + dynlibTargetDir + (mkGenericSharedLibName + platform + compiler_id + (getHSLibraryName uid ++ f)) + | f <- "":extraDynLibFlavours (libBuildInfo lib) + ] + sequence_ [ do + files <- getDirectoryContents builtDir + let l' = mkGenericSharedBundledLibName + platform + compiler_id + l + forM_ files $ \ file -> + when (l' `isPrefixOf` file) $ do + isFile <- doesFileExist (builtDir file) + when isFile $ do + installShared + builtDir + dynlibTargetDir + file + | l <- extraBundledLibs (libBuildInfo lib) + ] + + where + builtDir = componentBuildDir lbi clbi + + install isShared srcDir dstDir name = do + let src = srcDir name + dst = dstDir name + + createDirectoryIfMissingVerbose verbosity True dstDir + + if isShared + then installExecutableFile verbosity src dst + else installOrdinaryFile verbosity src dst + + when (stripLibs lbi) $ Strip.stripLib verbosity + platform (withPrograms lbi) dst + + installOrdinary = install False + installShared = install True + + copyModuleFiles ext = + findModuleFilesEx verbosity [builtDir] [ext] (allLibModules lib clbi) + >>= installOrdinaryFiles verbosity targetDir + + compiler_id = compilerId (compiler lbi) + platform = hostPlatform lbi + uid = componentUnitId clbi + profileLibName = mkProfLibName uid + ghciLibName = Internal.mkGHCiLibName uid + ghciProfLibName = Internal.mkGHCiProfLibName uid + + hasLib = not $ null (allLibModules lib clbi) + && null (cSources (libBuildInfo lib)) + && null (cxxSources (libBuildInfo lib)) + && null (cmmSources (libBuildInfo lib)) + && null (asmSources (libBuildInfo lib)) + has_code = not (componentIsIndefinite clbi) + whenHasCode = when has_code + whenVanilla = when (hasLib && withVanillaLib lbi) + whenProf = when (hasLib && withProfLib lbi && has_code) + whenGHCi = when (hasLib && withGHCiLib lbi && has_code) + whenShared = when (hasLib && withSharedLib lbi && has_code) + +-- ----------------------------------------------------------------------------- +-- Registering + +hcPkgInfo :: ProgramDb -> HcPkg.HcPkgInfo +hcPkgInfo progdb = HcPkg.HcPkgInfo + { HcPkg.hcPkgProgram = ghcPkgProg + , HcPkg.noPkgDbStack = v < [6,9] + , HcPkg.noVerboseFlag = v < [6,11] + , HcPkg.flagPackageConf = v < [7,5] + , HcPkg.supportsDirDbs = v >= [6,8] + , HcPkg.requiresDirDbs = v >= [7,10] + , HcPkg.nativeMultiInstance = v >= [7,10] + , HcPkg.recacheMultiInstance = v >= [6,12] + , HcPkg.suppressFilesCheck = v >= [6,6] + } + where + v = versionNumbers ver + ghcPkgProg = fromMaybe (error "GHC.hcPkgInfo: no ghc program") $ lookupProgram ghcPkgProgram progdb + ver = fromMaybe (error "GHC.hcPkgInfo: no ghc version") $ programVersion ghcPkgProg + +registerPackage + :: Verbosity + -> ProgramDb + -> PackageDBStack + -> InstalledPackageInfo + -> HcPkg.RegisterOptions + -> IO () +registerPackage verbosity progdb packageDbs installedPkgInfo registerOptions = + HcPkg.register (hcPkgInfo progdb) verbosity packageDbs + installedPkgInfo registerOptions + +pkgRoot :: Verbosity -> LocalBuildInfo -> PackageDB -> IO FilePath +pkgRoot verbosity lbi = pkgRoot' + where + pkgRoot' GlobalPackageDB = + let ghcProg = fromMaybe (error "GHC.pkgRoot: no ghc program") $ lookupProgram ghcProgram (withPrograms lbi) + in fmap takeDirectory (getGlobalPackageDB verbosity ghcProg) + pkgRoot' UserPackageDB = do + appDir <- getGhcAppDir + let ver = compilerVersion (compiler lbi) + subdir = System.Info.arch ++ '-':System.Info.os + ++ '-':prettyShow ver + rootDir = appDir subdir + -- We must create the root directory for the user package database if it + -- does not yet exists. Otherwise '${pkgroot}' will resolve to a + -- directory at the time of 'ghc-pkg register', and registration will + -- fail. + createDirectoryIfMissing True rootDir + return rootDir + pkgRoot' (SpecificPackageDB fp) = return (takeDirectory fp) + +-- ----------------------------------------------------------------------------- +-- Utils + +isDynamic :: Compiler -> Bool +isDynamic = Internal.ghcLookupProperty "GHC Dynamic" + +supportsDynamicToo :: Compiler -> Bool +supportsDynamicToo = Internal.ghcLookupProperty "Support dynamic-too" + +withExt :: FilePath -> String -> FilePath +withExt fp ext = fp <.> if takeExtension fp /= ('.':ext) then ext else "" diff --git a/cabal/Cabal/src/Distribution/Simple/GHC/EnvironmentParser.hs b/cabal/Cabal/src/Distribution/Simple/GHC/EnvironmentParser.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/GHC/EnvironmentParser.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +module Distribution.Simple.GHC.EnvironmentParser + ( parseGhcEnvironmentFile, readGhcEnvironmentFile, ParseErrorExc(..) ) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Simple.Compiler + ( PackageDB(..) ) +import Distribution.Simple.GHC.Internal + ( GhcEnvironmentFileEntry(..) ) +import Distribution.Types.UnitId + ( mkUnitId ) + +import qualified Text.Parsec as P +import Text.Parsec.String + ( Parser, parseFromFile ) + +parseEnvironmentFileLine :: Parser GhcEnvironmentFileEntry +parseEnvironmentFileLine = GhcEnvFileComment <$> comment + <|> GhcEnvFilePackageId <$> unitId + <|> GhcEnvFilePackageDb <$> packageDb + <|> pure GhcEnvFileClearPackageDbStack <* clearDb + where + comment = P.string "--" *> P.many (P.noneOf "\r\n") + unitId = P.try $ P.string "package-id" *> P.spaces *> + (mkUnitId <$> P.many1 (P.satisfy $ \c -> isAlphaNum c || c `elem` "-_.+")) + packageDb = (P.string "global-package-db" *> pure GlobalPackageDB) + <|> (P.string "user-package-db" *> pure UserPackageDB) + <|> (P.string "package-db" *> P.spaces *> (SpecificPackageDB <$> P.many1 (P.noneOf "\r\n") <* P.lookAhead P.endOfLine)) + clearDb = P.string "clear-package-db" + +newtype ParseErrorExc = ParseErrorExc P.ParseError + deriving (Show, Typeable) + +instance Exception ParseErrorExc + +parseGhcEnvironmentFile :: Parser [GhcEnvironmentFileEntry] +parseGhcEnvironmentFile = parseEnvironmentFileLine `P.sepEndBy` P.endOfLine <* P.eof + +readGhcEnvironmentFile :: FilePath -> IO [GhcEnvironmentFileEntry] +readGhcEnvironmentFile path = + either (throwIO . ParseErrorExc) return =<< + parseFromFile parseGhcEnvironmentFile path diff --git a/cabal/Cabal/src/Distribution/Simple/GHC/ImplInfo.hs b/cabal/Cabal/src/Distribution/Simple/GHC/ImplInfo.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/GHC/ImplInfo.hs @@ -0,0 +1,96 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.GHC.ImplInfo +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module contains the data structure describing invocation +-- details for a GHC or GHC-derived compiler, such as supported flags +-- and workarounds for bugs. + +module Distribution.Simple.GHC.ImplInfo ( + GhcImplInfo(..), getImplInfo, + ghcVersionImplInfo, ghcjsVersionImplInfo + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Simple.Compiler +import Distribution.Version + +{- | + Information about features and quirks of a GHC-based implementation. + + Compiler flavors based on GHC behave similarly enough that some of + the support code for them is shared. Every implementation has its + own peculiarities, that may or may not be a direct result of the + underlying GHC version. This record keeps track of these differences. + + All shared code (i.e. everything not in the Distribution.Simple.FLAVOR + module) should use implementation info rather than version numbers + to test for supported features. +-} + +data GhcImplInfo = GhcImplInfo + { supportsHaskell2010 :: Bool -- ^ -XHaskell2010 and -XHaskell98 flags + , supportsGHC2021 :: Bool -- ^ -XGHC2021 flag + , reportsNoExt :: Bool -- ^ --supported-languages gives Ext and NoExt + , alwaysNondecIndent :: Bool -- ^ NondecreasingIndentation is always on + , flagGhciScript :: Bool -- ^ -ghci-script flag supported + , flagProfAuto :: Bool -- ^ new style -fprof-auto* flags + , flagPackageConf :: Bool -- ^ use package-conf instead of package-db + , flagDebugInfo :: Bool -- ^ -g flag supported + , supportsDebugLevels :: Bool -- ^ supports numeric @-g@ levels + , supportsPkgEnvFiles :: Bool -- ^ picks up @.ghc.environment@ files + , flagWarnMissingHomeModules :: Bool -- ^ -Wmissing-home-modules is supported + } + +getImplInfo :: Compiler -> GhcImplInfo +getImplInfo comp = + case compilerFlavor comp of + GHC -> ghcVersionImplInfo (compilerVersion comp) + GHCJS -> case compilerCompatVersion GHC comp of + Just ghcVer -> ghcjsVersionImplInfo (compilerVersion comp) ghcVer + _ -> error ("Distribution.Simple.GHC.Props.getImplProps: " ++ + "could not find GHC version for GHCJS compiler") + x -> error ("Distribution.Simple.GHC.Props.getImplProps only works" ++ + "for GHC-like compilers (GHC, GHCJS)" ++ + ", but found " ++ show x) + +ghcVersionImplInfo :: Version -> GhcImplInfo +ghcVersionImplInfo ver = GhcImplInfo + { supportsHaskell2010 = v >= [7] + , supportsGHC2021 = v >= [9,1] + , reportsNoExt = v >= [7] + , alwaysNondecIndent = v < [7,1] + , flagGhciScript = v >= [7,2] + , flagProfAuto = v >= [7,4] + , flagPackageConf = v < [7,5] + , flagDebugInfo = v >= [7,10] + , supportsDebugLevels = v >= [8,0] + , supportsPkgEnvFiles = v >= [8,0,1,20160901] -- broken in 8.0.1, fixed in 8.0.2 + , flagWarnMissingHomeModules = v >= [8,2] + } + where + v = versionNumbers ver + +ghcjsVersionImplInfo :: Version -- ^ The GHCJS version + -> Version -- ^ The GHC version + -> GhcImplInfo +ghcjsVersionImplInfo _ghcjsver ghcver = GhcImplInfo + { supportsHaskell2010 = True + , supportsGHC2021 = True + , reportsNoExt = True + , alwaysNondecIndent = False + , flagGhciScript = True + , flagProfAuto = True + , flagPackageConf = False + , flagDebugInfo = False + , supportsDebugLevels = ghcv >= [8,0] + , supportsPkgEnvFiles = ghcv >= [8,0,2] --TODO: check this works in ghcjs + , flagWarnMissingHomeModules = ghcv >= [8,2] + } + where + ghcv = versionNumbers ghcver diff --git a/cabal/Cabal/src/Distribution/Simple/GHC/Internal.hs b/cabal/Cabal/src/Distribution/Simple/GHC/Internal.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/GHC/Internal.hs @@ -0,0 +1,693 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.GHC.Internal +-- Copyright : Isaac Jones 2003-2007 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module contains functions shared by GHC (Distribution.Simple.GHC) +-- and GHC-derived compilers. + +module Distribution.Simple.GHC.Internal ( + configureToolchain, + getLanguages, + getExtensions, + targetPlatform, + getGhcInfo, + componentCcGhcOptions, + componentCmmGhcOptions, + componentCxxGhcOptions, + componentAsmGhcOptions, + componentGhcOptions, + mkGHCiLibName, + mkGHCiProfLibName, + filterGhciFlags, + ghcLookupProperty, + getHaskellObjects, + mkGhcOptPackages, + substTopDir, + checkPackageDbEnvVar, + profDetailLevelFlag, + -- * GHC platform and version strings + ghcArchString, + ghcOsString, + ghcPlatformAndVersionString, + -- * Constructing GHC environment files + GhcEnvironmentFileEntry(..), + writeGhcEnvironmentFile, + simpleGhcEnvironmentFile, + ghcEnvironmentFileName, + renderGhcEnvironmentFile, + renderGhcEnvironmentFileEntry, + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Simple.GHC.ImplInfo +import Distribution.Types.ComponentLocalBuildInfo +import Distribution.Backpack +import qualified Distribution.InstalledPackageInfo as IPI +import Distribution.PackageDescription +import Distribution.Lex +import Distribution.Simple.Compiler +import Distribution.Simple.Program.GHC +import Distribution.Simple.Setup +import qualified Distribution.ModuleName as ModuleName +import Distribution.Simple.Program +import Distribution.Simple.LocalBuildInfo +import Distribution.Types.UnitId +import Distribution.Types.LocalBuildInfo +import Distribution.Types.TargetInfo +import Distribution.Simple.Utils +import Distribution.Simple.BuildPaths +import Distribution.System +import Distribution.Pretty ( prettyShow ) +import Distribution.Parsec ( simpleParsec ) +import Distribution.Utils.NubList ( toNubListR ) +import Distribution.Verbosity +import Distribution.Compat.Stack +import Distribution.Version (Version) +import Distribution.Utils.Path +import Language.Haskell.Extension + +import qualified Data.Map as Map +import qualified Data.ByteString.Lazy.Char8 as BS +import System.Directory ( getDirectoryContents, getTemporaryDirectory ) +import System.Environment ( getEnv ) +import System.FilePath ( (), (<.>), takeExtension + , takeDirectory, takeFileName) +import System.IO ( hClose, hPutStrLn ) + +targetPlatform :: [(String, String)] -> Maybe Platform +targetPlatform ghcInfo = platformFromTriple =<< lookup "Target platform" ghcInfo + +-- | Adjust the way we find and configure gcc and ld +-- +configureToolchain :: GhcImplInfo + -> ConfiguredProgram + -> Map String String + -> ProgramDb + -> ProgramDb +configureToolchain _implInfo ghcProg ghcInfo = + addKnownProgram gccProgram { + programFindLocation = findProg gccProgramName extraGccPath, + programPostConf = configureGcc + } + . addKnownProgram ldProgram { + programFindLocation = findProg ldProgramName extraLdPath, + programPostConf = configureLd + } + . addKnownProgram arProgram { + programFindLocation = findProg arProgramName extraArPath + } + . addKnownProgram stripProgram { + programFindLocation = findProg stripProgramName extraStripPath + } + where + compilerDir = takeDirectory (programPath ghcProg) + base_dir = takeDirectory compilerDir + mingwBinDir = base_dir "mingw" "bin" + isWindows = case buildOS of Windows -> True; _ -> False + binPrefix = "" + + maybeName :: Program -> Maybe FilePath -> String + maybeName prog = maybe (programName prog) (dropExeExtension . takeFileName) + + gccProgramName = maybeName gccProgram mbGccLocation + ldProgramName = maybeName ldProgram mbLdLocation + arProgramName = maybeName arProgram mbArLocation + stripProgramName = maybeName stripProgram mbStripLocation + + mkExtraPath :: Maybe FilePath -> FilePath -> [FilePath] + mkExtraPath mbPath mingwPath | isWindows = mbDir ++ [mingwPath] + | otherwise = mbDir + where + mbDir = maybeToList . fmap takeDirectory $ mbPath + + extraGccPath = mkExtraPath mbGccLocation windowsExtraGccDir + extraLdPath = mkExtraPath mbLdLocation windowsExtraLdDir + extraArPath = mkExtraPath mbArLocation windowsExtraArDir + extraStripPath = mkExtraPath mbStripLocation windowsExtraStripDir + + -- on Windows finding and configuring ghc's gcc & binutils is a bit special + (windowsExtraGccDir, windowsExtraLdDir, + windowsExtraArDir, windowsExtraStripDir) = + let b = mingwBinDir binPrefix + in (b, b, b, b) + + findProg :: String -> [FilePath] + -> Verbosity -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) + findProg progName extraPath v searchpath = + findProgramOnSearchPath v searchpath' progName + where + searchpath' = (map ProgramSearchPathDir extraPath) ++ searchpath + + -- Read tool locations from the 'ghc --info' output. Useful when + -- cross-compiling. + mbGccLocation = Map.lookup "C compiler command" ghcInfo + mbLdLocation = Map.lookup "ld command" ghcInfo + mbArLocation = Map.lookup "ar command" ghcInfo + mbStripLocation = Map.lookup "strip command" ghcInfo + + ccFlags = getFlags "C compiler flags" + -- GHC 7.8 renamed "Gcc Linker flags" to "C compiler link flags" + -- and "Ld Linker flags" to "ld flags" (GHC #4862). + gccLinkerFlags = getFlags "Gcc Linker flags" ++ getFlags "C compiler link flags" + ldLinkerFlags = getFlags "Ld Linker flags" ++ getFlags "ld flags" + + -- It appears that GHC 7.6 and earlier encode the tokenized flags as a + -- [String] in these settings whereas later versions just encode the flags as + -- String. + -- + -- We first try to parse as a [String] and if this fails then tokenize the + -- flags ourself. + getFlags :: String -> [String] + getFlags key = + case Map.lookup key ghcInfo of + Nothing -> [] + Just flags + | (flags', ""):_ <- reads flags -> flags' + | otherwise -> tokenizeQuotedWords flags + + configureGcc :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram + configureGcc _v gccProg = do + return gccProg { + programDefaultArgs = programDefaultArgs gccProg + ++ ccFlags ++ gccLinkerFlags + } + + configureLd :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram + configureLd v ldProg = do + ldProg' <- configureLd' v ldProg + return ldProg' { + programDefaultArgs = programDefaultArgs ldProg' ++ ldLinkerFlags + } + + -- we need to find out if ld supports the -x flag + configureLd' :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram + configureLd' verbosity ldProg = do + tempDir <- getTemporaryDirectory + ldx <- withTempFile tempDir ".c" $ \testcfile testchnd -> + withTempFile tempDir ".o" $ \testofile testohnd -> do + hPutStrLn testchnd "int foo() { return 0; }" + hClose testchnd; hClose testohnd + runProgram verbosity ghcProg + [ "-hide-all-packages" + , "-c", testcfile + , "-o", testofile + ] + withTempFile tempDir ".o" $ \testofile' testohnd' -> + do + hClose testohnd' + _ <- getProgramOutput verbosity ldProg + ["-x", "-r", testofile, "-o", testofile'] + return True + `catchIO` (\_ -> return False) + `catchExit` (\_ -> return False) + if ldx + then return ldProg { programDefaultArgs = ["-x"] } + else return ldProg + +getLanguages :: Verbosity -> GhcImplInfo -> ConfiguredProgram + -> IO [(Language, String)] +getLanguages _ implInfo _ + -- TODO: should be using --supported-languages rather than hard coding + | supportsGHC2021 implInfo = return + [ (GHC2021, "-XGHC2021") + , (Haskell2010, "-XHaskell2010") + , (Haskell98, "-XHaskell98") + ] + | supportsHaskell2010 implInfo = return [(Haskell98, "-XHaskell98") + ,(Haskell2010, "-XHaskell2010")] + | otherwise = return [(Haskell98, "")] + +getGhcInfo :: Verbosity -> GhcImplInfo -> ConfiguredProgram + -> IO [(String, String)] +getGhcInfo verbosity _implInfo ghcProg = do + xs <- getProgramOutput verbosity (suppressOverrideArgs ghcProg) + ["--info"] + case reads xs of + [(i, ss)] + | all isSpace ss -> + return i + _ -> + die' verbosity "Can't parse --info output of GHC" + +getExtensions :: Verbosity -> GhcImplInfo -> ConfiguredProgram + -> IO [(Extension, Maybe String)] +getExtensions verbosity implInfo ghcProg = do + str <- getProgramOutput verbosity (suppressOverrideArgs ghcProg) + ["--supported-languages"] + let extStrs = if reportsNoExt implInfo + then lines str + else -- Older GHCs only gave us either Foo or NoFoo, + -- so we have to work out the other one ourselves + [ extStr'' + | extStr <- lines str + , let extStr' = case extStr of + 'N' : 'o' : xs -> xs + _ -> "No" ++ extStr + , extStr'' <- [extStr, extStr'] + ] + let extensions0 = [ (ext, Just $ "-X" ++ prettyShow ext) + | Just ext <- map simpleParsec extStrs ] + extensions1 = if alwaysNondecIndent implInfo + then -- ghc-7.2 split NondecreasingIndentation off + -- into a proper extension. Before that it + -- was always on. + -- Since it was not a proper extension, it could + -- not be turned off, hence we omit a + -- DisableExtension entry here. + (EnableExtension NondecreasingIndentation, Nothing) : + extensions0 + else extensions0 + return extensions1 + +componentCcGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo + -> BuildInfo -> ComponentLocalBuildInfo + -> FilePath -> FilePath + -> GhcOptions +componentCcGhcOptions verbosity _implInfo lbi bi clbi odir filename = + mempty { + -- Respect -v0, but don't crank up verbosity on GHC if + -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! + ghcOptVerbosity = toFlag (min verbosity normal), + ghcOptMode = toFlag GhcModeCompile, + ghcOptInputFiles = toNubListR [filename], + + ghcOptCppIncludePath = toNubListR $ [autogenComponentModulesDir lbi clbi + ,autogenPackageModulesDir lbi + ,odir] + -- includes relative to the package + ++ includeDirs bi + -- potential includes generated by `configure' + -- in the build directory + ++ [buildDir lbi dir | dir <- includeDirs bi], + ghcOptHideAllPackages= toFlag True, + ghcOptPackageDBs = withPackageDB lbi, + ghcOptPackages = toNubListR $ mkGhcOptPackages clbi, + ghcOptCcOptions = (case withOptimization lbi of + NoOptimisation -> [] + _ -> ["-O2"]) ++ + (case withDebugInfo lbi of + NoDebugInfo -> [] + MinimalDebugInfo -> ["-g1"] + NormalDebugInfo -> ["-g"] + MaximalDebugInfo -> ["-g3"]) ++ + ccOptions bi, + ghcOptCcProgram = maybeToFlag $ programPath <$> + lookupProgram gccProgram (withPrograms lbi), + ghcOptObjDir = toFlag odir, + ghcOptExtra = hcOptions GHC bi + } + + +componentCxxGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo + -> BuildInfo -> ComponentLocalBuildInfo + -> FilePath -> FilePath + -> GhcOptions +componentCxxGhcOptions verbosity _implInfo lbi bi clbi odir filename = + mempty { + -- Respect -v0, but don't crank up verbosity on GHC if + -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! + ghcOptVerbosity = toFlag (min verbosity normal), + ghcOptMode = toFlag GhcModeCompile, + ghcOptInputFiles = toNubListR [filename], + + ghcOptCppIncludePath = toNubListR $ [autogenComponentModulesDir lbi clbi + ,autogenPackageModulesDir lbi + ,odir] + -- includes relative to the package + ++ includeDirs bi + -- potential includes generated by `configure' + -- in the build directory + ++ [buildDir lbi dir | dir <- includeDirs bi], + ghcOptHideAllPackages= toFlag True, + ghcOptPackageDBs = withPackageDB lbi, + ghcOptPackages = toNubListR $ mkGhcOptPackages clbi, + ghcOptCxxOptions = (case withOptimization lbi of + NoOptimisation -> [] + _ -> ["-O2"]) ++ + (case withDebugInfo lbi of + NoDebugInfo -> [] + MinimalDebugInfo -> ["-g1"] + NormalDebugInfo -> ["-g"] + MaximalDebugInfo -> ["-g3"]) ++ + cxxOptions bi, + ghcOptCcProgram = maybeToFlag $ programPath <$> + lookupProgram gccProgram (withPrograms lbi), + ghcOptObjDir = toFlag odir, + ghcOptExtra = hcOptions GHC bi + } + + +componentAsmGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo + -> BuildInfo -> ComponentLocalBuildInfo + -> FilePath -> FilePath + -> GhcOptions +componentAsmGhcOptions verbosity _implInfo lbi bi clbi odir filename = + mempty { + -- Respect -v0, but don't crank up verbosity on GHC if + -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! + ghcOptVerbosity = toFlag (min verbosity normal), + ghcOptMode = toFlag GhcModeCompile, + ghcOptInputFiles = toNubListR [filename], + + ghcOptCppIncludePath = toNubListR $ [autogenComponentModulesDir lbi clbi + ,autogenPackageModulesDir lbi + ,odir] + -- includes relative to the package + ++ includeDirs bi + -- potential includes generated by `configure' + -- in the build directory + ++ [buildDir lbi dir | dir <- includeDirs bi], + ghcOptHideAllPackages= toFlag True, + ghcOptPackageDBs = withPackageDB lbi, + ghcOptPackages = toNubListR $ mkGhcOptPackages clbi, + ghcOptAsmOptions = (case withOptimization lbi of + NoOptimisation -> [] + _ -> ["-O2"]) ++ + (case withDebugInfo lbi of + NoDebugInfo -> [] + MinimalDebugInfo -> ["-g1"] + NormalDebugInfo -> ["-g"] + MaximalDebugInfo -> ["-g3"]) ++ + asmOptions bi, + ghcOptObjDir = toFlag odir + } + + +componentGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo + -> BuildInfo -> ComponentLocalBuildInfo -> FilePath + -> GhcOptions +componentGhcOptions verbosity implInfo lbi bi clbi odir = + mempty { + -- Respect -v0, but don't crank up verbosity on GHC if + -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! + ghcOptVerbosity = toFlag (min verbosity normal), + ghcOptCabal = toFlag True, + ghcOptThisUnitId = case clbi of + LibComponentLocalBuildInfo { componentCompatPackageKey = pk } + -> toFlag pk + _ -> mempty, + ghcOptThisComponentId = case clbi of + LibComponentLocalBuildInfo { componentComponentId = cid + , componentInstantiatedWith = insts } -> + if null insts + then mempty + else toFlag cid + _ -> mempty, + ghcOptInstantiatedWith = case clbi of + LibComponentLocalBuildInfo { componentInstantiatedWith = insts } + -> insts + _ -> [], + ghcOptNoCode = toFlag $ componentIsIndefinite clbi, + ghcOptHideAllPackages = toFlag True, + ghcOptWarnMissingHomeModules = toFlag $ flagWarnMissingHomeModules implInfo, + ghcOptPackageDBs = withPackageDB lbi, + ghcOptPackages = toNubListR $ mkGhcOptPackages clbi, + ghcOptSplitSections = toFlag (splitSections lbi), + ghcOptSplitObjs = toFlag (splitObjs lbi), + ghcOptSourcePathClear = toFlag True, + ghcOptSourcePath = toNubListR $ [odir] ++ (map getSymbolicPath (hsSourceDirs bi)) + ++ [autogenComponentModulesDir lbi clbi] + ++ [autogenPackageModulesDir lbi], + ghcOptCppIncludePath = toNubListR $ [autogenComponentModulesDir lbi clbi + ,autogenPackageModulesDir lbi + ,odir] + -- includes relative to the package + ++ includeDirs bi + -- potential includes generated by `configure' + -- in the build directory + ++ [buildDir lbi dir | dir <- includeDirs bi], + ghcOptCppOptions = cppOptions bi, + ghcOptCppIncludes = toNubListR $ + [autogenComponentModulesDir lbi clbi cppHeaderName], + ghcOptFfiIncludes = toNubListR $ includes bi, + ghcOptObjDir = toFlag odir, + ghcOptHiDir = toFlag odir, + ghcOptStubDir = toFlag odir, + ghcOptOutputDir = toFlag odir, + ghcOptOptimisation = toGhcOptimisation (withOptimization lbi), + ghcOptDebugInfo = toFlag (withDebugInfo lbi), + ghcOptExtra = hcOptions GHC bi, + ghcOptExtraPath = toNubListR $ exe_paths, + ghcOptLanguage = toFlag (fromMaybe Haskell98 (defaultLanguage bi)), + -- Unsupported extensions have already been checked by configure + ghcOptExtensions = toNubListR $ usedExtensions bi, + ghcOptExtensionMap = Map.fromList . compilerExtensions $ (compiler lbi) + } + where + exe_paths = [ componentBuildDir lbi (targetCLBI exe_tgt) + | uid <- componentExeDeps clbi + -- TODO: Ugh, localPkgDescr + , Just exe_tgt <- [unitIdTarget' (localPkgDescr lbi) lbi uid] ] + +toGhcOptimisation :: OptimisationLevel -> Flag GhcOptimisation +toGhcOptimisation NoOptimisation = mempty --TODO perhaps override? +toGhcOptimisation NormalOptimisation = toFlag GhcNormalOptimisation +toGhcOptimisation MaximumOptimisation = toFlag GhcMaximumOptimisation + + +componentCmmGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo + -> BuildInfo -> ComponentLocalBuildInfo + -> FilePath -> FilePath + -> GhcOptions +componentCmmGhcOptions verbosity _implInfo lbi bi clbi odir filename = + mempty { + -- Respect -v0, but don't crank up verbosity on GHC if + -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! + ghcOptVerbosity = toFlag (min verbosity normal), + ghcOptMode = toFlag GhcModeCompile, + ghcOptInputFiles = toNubListR [filename], + + ghcOptCppIncludePath = toNubListR $ [autogenComponentModulesDir lbi clbi + ,autogenPackageModulesDir lbi + ,odir] + -- includes relative to the package + ++ includeDirs bi + -- potential includes generated by `configure' + -- in the build directory + ++ [buildDir lbi dir | dir <- includeDirs bi], + ghcOptCppOptions = cppOptions bi, + ghcOptCppIncludes = toNubListR $ + [autogenComponentModulesDir lbi clbi cppHeaderName], + ghcOptHideAllPackages= toFlag True, + ghcOptPackageDBs = withPackageDB lbi, + ghcOptPackages = toNubListR $ mkGhcOptPackages clbi, + ghcOptOptimisation = toGhcOptimisation (withOptimization lbi), + ghcOptDebugInfo = toFlag (withDebugInfo lbi), + ghcOptExtra = cmmOptions bi, + ghcOptObjDir = toFlag odir + } + + +-- | Strip out flags that are not supported in ghci +filterGhciFlags :: [String] -> [String] +filterGhciFlags = filter supported + where + supported ('-':'O':_) = False + supported "-debug" = False + supported "-threaded" = False + supported "-ticky" = False + supported "-eventlog" = False + supported "-prof" = False + supported "-unreg" = False + supported _ = True + +mkGHCiLibName :: UnitId -> String +mkGHCiLibName lib = getHSLibraryName lib <.> "o" + +mkGHCiProfLibName :: UnitId -> String +mkGHCiProfLibName lib = getHSLibraryName lib <.> "p_o" + +ghcLookupProperty :: String -> Compiler -> Bool +ghcLookupProperty prop comp = + case Map.lookup prop (compilerProperties comp) of + Just "YES" -> True + _ -> False + +-- when using -split-objs, we need to search for object files in the +-- Module_split directory for each module. +getHaskellObjects :: GhcImplInfo -> Library -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> FilePath -> String -> Bool -> IO [FilePath] +getHaskellObjects _implInfo lib lbi clbi pref wanted_obj_ext allow_split_objs + | splitObjs lbi && allow_split_objs = do + let splitSuffix = "_" ++ wanted_obj_ext ++ "_split" + dirs = [ pref (ModuleName.toFilePath x ++ splitSuffix) + | x <- allLibModules lib clbi ] + objss <- traverse getDirectoryContents dirs + let objs = [ dir obj + | (objs',dir) <- zip objss dirs, obj <- objs', + let obj_ext = takeExtension obj, + '.':wanted_obj_ext == obj_ext ] + return objs + | otherwise = + return [ pref ModuleName.toFilePath x <.> wanted_obj_ext + | x <- allLibModules lib clbi ] + +mkGhcOptPackages :: ComponentLocalBuildInfo + -> [(OpenUnitId, ModuleRenaming)] +mkGhcOptPackages = componentIncludes + +substTopDir :: FilePath -> IPI.InstalledPackageInfo -> IPI.InstalledPackageInfo +substTopDir topDir ipo + = ipo { + IPI.importDirs = map f (IPI.importDirs ipo), + IPI.libraryDirs = map f (IPI.libraryDirs ipo), + IPI.libraryDirsStatic = map f (IPI.libraryDirsStatic ipo), + IPI.includeDirs = map f (IPI.includeDirs ipo), + IPI.frameworkDirs = map f (IPI.frameworkDirs ipo), + IPI.haddockInterfaces = map f (IPI.haddockInterfaces ipo), + IPI.haddockHTMLs = map f (IPI.haddockHTMLs ipo) + } + where f ('$':'t':'o':'p':'d':'i':'r':rest) = topDir ++ rest + f x = x + +-- Cabal does not use the environment variable GHC{,JS}_PACKAGE_PATH; let +-- users know that this is the case. See ticket #335. Simply ignoring it is +-- not a good idea, since then ghc and cabal are looking at different sets +-- of package DBs and chaos is likely to ensue. +-- +-- An exception to this is when running cabal from within a `cabal exec` +-- environment. In this case, `cabal exec` will set the +-- CABAL_SANDBOX_PACKAGE_PATH to the same value that it set +-- GHC{,JS}_PACKAGE_PATH to. If that is the case it is OK to allow +-- GHC{,JS}_PACKAGE_PATH. +checkPackageDbEnvVar :: Verbosity -> String -> String -> IO () +checkPackageDbEnvVar verbosity compilerName packagePathEnvVar = do + mPP <- lookupEnv packagePathEnvVar + when (isJust mPP) $ do + mcsPP <- lookupEnv "CABAL_SANDBOX_PACKAGE_PATH" + unless (mPP == mcsPP) abort + where + lookupEnv :: String -> IO (Maybe String) + lookupEnv name = (Just `fmap` getEnv name) + `catchIO` const (return Nothing) + abort = + die' verbosity $ "Use of " ++ compilerName ++ "'s environment variable " + ++ packagePathEnvVar ++ " is incompatible with Cabal. Use the " + ++ "flag --package-db to specify a package database (it can be " + ++ "used multiple times)." + + _ = callStack -- TODO: output stack when erroring + +profDetailLevelFlag :: Bool -> ProfDetailLevel -> Flag GhcProfAuto +profDetailLevelFlag forLib mpl = + case mpl of + ProfDetailNone -> mempty + ProfDetailDefault | forLib -> toFlag GhcProfAutoExported + | otherwise -> toFlag GhcProfAutoToplevel + ProfDetailExportedFunctions -> toFlag GhcProfAutoExported + ProfDetailToplevelFunctions -> toFlag GhcProfAutoToplevel + ProfDetailAllFunctions -> toFlag GhcProfAutoAll + ProfDetailOther _ -> mempty + + +-- ----------------------------------------------------------------------------- +-- GHC platform and version strings + +-- | GHC's rendering of its host or target 'Arch' as used in its platform +-- strings and certain file locations (such as user package db location). +-- +ghcArchString :: Arch -> String +ghcArchString PPC = "powerpc" +ghcArchString PPC64 = "powerpc64" +ghcArchString other = prettyShow other + +-- | GHC's rendering of its host or target 'OS' as used in its platform +-- strings and certain file locations (such as user package db location). +-- +ghcOsString :: OS -> String +ghcOsString Windows = "mingw32" +ghcOsString OSX = "darwin" +ghcOsString Solaris = "solaris2" +ghcOsString other = prettyShow other + +-- | GHC's rendering of its platform and compiler version string as used in +-- certain file locations (such as user package db location). +-- For example @x86_64-linux-7.10.4@ +-- +ghcPlatformAndVersionString :: Platform -> Version -> String +ghcPlatformAndVersionString (Platform arch os) version = + intercalate "-" [ ghcArchString arch, ghcOsString os, prettyShow version ] + + +-- ----------------------------------------------------------------------------- +-- Constructing GHC environment files + +-- | The kinds of entries we can stick in a @.ghc.environment@ file. +-- +data GhcEnvironmentFileEntry = + GhcEnvFileComment String -- ^ @-- a comment@ + | GhcEnvFilePackageId UnitId -- ^ @package-id foo-1.0-4fe301a...@ + | GhcEnvFilePackageDb PackageDB -- ^ @global-package-db@, + -- @user-package-db@ or + -- @package-db blah/package.conf.d/@ + | GhcEnvFileClearPackageDbStack -- ^ @clear-package-db@ + deriving (Eq, Ord, Show) + +-- | Make entries for a GHC environment file based on a 'PackageDBStack' and +-- a bunch of package (unit) ids. +-- +-- If you need to do anything more complicated then either use this as a basis +-- and add more entries, or just make all the entries directly. +-- +simpleGhcEnvironmentFile :: PackageDBStack + -> [UnitId] + -> [GhcEnvironmentFileEntry] +simpleGhcEnvironmentFile packageDBs pkgids = + GhcEnvFileClearPackageDbStack + : map GhcEnvFilePackageDb packageDBs + ++ map GhcEnvFilePackageId pkgids + +-- | Write a @.ghc.environment-$arch-$os-$ver@ file in the given directory. +-- +-- The 'Platform' and GHC 'Version' are needed as part of the file name. +-- +-- Returns the name of the file written. +writeGhcEnvironmentFile :: FilePath -- ^ directory in which to put it + -> Platform -- ^ the GHC target platform + -> Version -- ^ the GHC version + -> [GhcEnvironmentFileEntry] -- ^ the content + -> IO FilePath +writeGhcEnvironmentFile directory platform ghcversion entries = do + writeFileAtomic envfile . BS.pack . renderGhcEnvironmentFile $ entries + return envfile + where + envfile = directory ghcEnvironmentFileName platform ghcversion + +-- | The @.ghc.environment-$arch-$os-$ver@ file name +-- +ghcEnvironmentFileName :: Platform -> Version -> FilePath +ghcEnvironmentFileName platform ghcversion = + ".ghc.environment." ++ ghcPlatformAndVersionString platform ghcversion + +-- | Render a bunch of GHC environment file entries +-- +renderGhcEnvironmentFile :: [GhcEnvironmentFileEntry] -> String +renderGhcEnvironmentFile = + unlines . map renderGhcEnvironmentFileEntry + +-- | Render an individual GHC environment file entry +-- +renderGhcEnvironmentFileEntry :: GhcEnvironmentFileEntry -> String +renderGhcEnvironmentFileEntry entry = case entry of + GhcEnvFileComment comment -> format comment + where format = intercalate "\n" . map ("--" <++>) . lines + pref <++> "" = pref + pref <++> str = pref ++ " " ++ str + GhcEnvFilePackageId pkgid -> "package-id " ++ prettyShow pkgid + GhcEnvFilePackageDb pkgdb -> + case pkgdb of + GlobalPackageDB -> "global-package-db" + UserPackageDB -> "user-package-db" + SpecificPackageDB dbfile -> "package-db " ++ dbfile + GhcEnvFileClearPackageDbStack -> "clear-package-db" diff --git a/cabal/Cabal/src/Distribution/Simple/GHCJS.hs b/cabal/Cabal/src/Distribution/Simple/GHCJS.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/GHCJS.hs @@ -0,0 +1,1852 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE CPP #-} + +module Distribution.Simple.GHCJS ( + getGhcInfo, + configure, + getInstalledPackages, + getInstalledPackagesMonitorFiles, + getPackageDBContents, + buildLib, buildFLib, buildExe, + replLib, replFLib, replExe, + startInterpreter, + installLib, installFLib, installExe, + libAbiHash, + hcPkgInfo, + registerPackage, + componentGhcOptions, + componentCcGhcOptions, + getLibDir, + isDynamic, + getGlobalPackageDB, + pkgRoot, + runCmd, + -- * Constructing and deconstructing GHC environment files + Internal.GhcEnvironmentFileEntry(..), + Internal.simpleGhcEnvironmentFile, + Internal.renderGhcEnvironmentFile, + Internal.writeGhcEnvironmentFile, + Internal.ghcPlatformAndVersionString, + readGhcEnvironmentFile, + parseGhcEnvironmentFile, + ParseErrorExc(..), + -- * Version-specific implementation quirks + getImplInfo, + GhcImplInfo(..) + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import qualified Distribution.Simple.GHC.Internal as Internal +import Distribution.Simple.GHC.ImplInfo +import Distribution.Simple.GHC.EnvironmentParser +import Distribution.PackageDescription.Utils (cabalBug) +import Distribution.PackageDescription as PD +import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo +import Distribution.Simple.PackageIndex (InstalledPackageIndex) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.LocalBuildInfo +import Distribution.Types.ComponentLocalBuildInfo +import qualified Distribution.Simple.Hpc as Hpc +import Distribution.Simple.BuildPaths +import Distribution.Simple.Utils +import Distribution.Package +import qualified Distribution.ModuleName as ModuleName +import Distribution.ModuleName (ModuleName) +import Distribution.Simple.Program +import qualified Distribution.Simple.Program.HcPkg as HcPkg +import qualified Distribution.Simple.Program.Strip as Strip +import Distribution.Simple.Program.GHC +import Distribution.Simple.Setup +import qualified Distribution.Simple.Setup as Cabal +import Distribution.Simple.Compiler +import Distribution.CabalSpecVersion +import Distribution.Version +import Distribution.System +import Distribution.Types.PackageName.Magic +import Distribution.Verbosity +import Distribution.Pretty +import Distribution.Utils.NubList +import Distribution.Utils.Path + +import Control.Monad (msum) +import Data.Char (isLower) +import qualified Data.Map as Map +import System.Directory + ( doesFileExist, getAppUserDataDirectory, createDirectoryIfMissing + , canonicalizePath, removeFile, renameFile ) +import System.FilePath ( (), (<.>), takeExtension + , takeDirectory, replaceExtension + ,isRelative ) +import qualified System.Info + +-- ----------------------------------------------------------------------------- +-- Configuring + +configure :: Verbosity -> Maybe FilePath -> Maybe FilePath + -> ProgramDb + -> IO (Compiler, Maybe Platform, ProgramDb) +configure verbosity hcPath hcPkgPath conf0 = do + + (ghcjsProg, ghcjsVersion, progdb1) <- + requireProgramVersion verbosity ghcjsProgram + (orLaterVersion (mkVersion [0,1])) + (userMaybeSpecifyPath "ghcjs" hcPath conf0) + + Just ghcjsGhcVersion <- findGhcjsGhcVersion verbosity (programPath ghcjsProg) + unless (ghcjsGhcVersion < mkVersion [8,8]) $ + warn verbosity $ + "Unknown/unsupported 'ghc' version detected " + ++ "(Cabal " ++ prettyShow cabalVersion ++ " supports 'ghc' version < 8.8): " + ++ programPath ghcjsProg ++ " is based on GHC version " ++ + prettyShow ghcjsGhcVersion + + let implInfo = ghcjsVersionImplInfo ghcjsVersion ghcjsGhcVersion + + -- This is slightly tricky, we have to configure ghc first, then we use the + -- location of ghc to help find ghc-pkg in the case that the user did not + -- specify the location of ghc-pkg directly: + (ghcjsPkgProg, ghcjsPkgVersion, progdb2) <- + requireProgramVersion verbosity ghcjsPkgProgram { + programFindLocation = guessGhcjsPkgFromGhcjsPath ghcjsProg + } + anyVersion (userMaybeSpecifyPath "ghcjs-pkg" hcPkgPath progdb1) + + Just ghcjsPkgGhcjsVersion <- findGhcjsPkgGhcjsVersion + verbosity (programPath ghcjsPkgProg) + + when (ghcjsVersion /= ghcjsPkgGhcjsVersion) $ die' verbosity $ + "Version mismatch between ghcjs and ghcjs-pkg: " + ++ programPath ghcjsProg ++ " is version " ++ prettyShow ghcjsVersion ++ " " + ++ programPath ghcjsPkgProg ++ " is version " ++ prettyShow ghcjsPkgGhcjsVersion + + when (ghcjsGhcVersion /= ghcjsPkgVersion) $ die' verbosity $ + "Version mismatch between ghcjs and ghcjs-pkg: " + ++ programPath ghcjsProg + ++ " was built with GHC version " ++ prettyShow ghcjsGhcVersion ++ " " + ++ programPath ghcjsPkgProg + ++ " was built with GHC version " ++ prettyShow ghcjsPkgVersion + + + -- Likewise we try to find the matching hsc2hs and haddock programs. + let hsc2hsProgram' = hsc2hsProgram { + programFindLocation = + guessHsc2hsFromGhcjsPath ghcjsProg + } + haddockProgram' = haddockProgram { + programFindLocation = + guessHaddockFromGhcjsPath ghcjsProg + } + hpcProgram' = hpcProgram { + programFindLocation = guessHpcFromGhcjsPath ghcjsProg + } + {- + runghcProgram' = runghcProgram { + programFindLocation = guessRunghcFromGhcjsPath ghcjsProg + } -} + progdb3 = addKnownProgram haddockProgram' $ + addKnownProgram hsc2hsProgram' $ + addKnownProgram hpcProgram' $ + {- addKnownProgram runghcProgram' -} progdb2 + + languages <- Internal.getLanguages verbosity implInfo ghcjsProg + extensions <- Internal.getExtensions verbosity implInfo ghcjsProg + + ghcjsInfo <- Internal.getGhcInfo verbosity implInfo ghcjsProg + let ghcInfoMap = Map.fromList ghcjsInfo + + let comp = Compiler { + compilerId = CompilerId GHCJS ghcjsVersion, + compilerAbiTag = AbiTag $ + "ghc" ++ intercalate "_" (map show . versionNumbers $ ghcjsGhcVersion), + compilerCompat = [CompilerId GHC ghcjsGhcVersion], + compilerLanguages = languages, + compilerExtensions = extensions, + compilerProperties = ghcInfoMap + } + compPlatform = Internal.targetPlatform ghcjsInfo + return (comp, compPlatform, progdb3) + +guessGhcjsPkgFromGhcjsPath :: ConfiguredProgram -> Verbosity + -> ProgramSearchPath -> IO (Maybe (FilePath, [FilePath])) +guessGhcjsPkgFromGhcjsPath = guessToolFromGhcjsPath ghcjsPkgProgram + +guessHsc2hsFromGhcjsPath :: ConfiguredProgram -> Verbosity + -> ProgramSearchPath -> IO (Maybe (FilePath, [FilePath])) +guessHsc2hsFromGhcjsPath = guessToolFromGhcjsPath hsc2hsProgram + +guessHaddockFromGhcjsPath :: ConfiguredProgram -> Verbosity + -> ProgramSearchPath -> IO (Maybe (FilePath, [FilePath])) +guessHaddockFromGhcjsPath = guessToolFromGhcjsPath haddockProgram + +guessHpcFromGhcjsPath :: ConfiguredProgram + -> Verbosity -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) +guessHpcFromGhcjsPath = guessToolFromGhcjsPath hpcProgram + + +guessToolFromGhcjsPath :: Program -> ConfiguredProgram + -> Verbosity -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) +guessToolFromGhcjsPath tool ghcjsProg verbosity searchpath + = do let toolname = programName tool + given_path = programPath ghcjsProg + given_dir = takeDirectory given_path + real_path <- canonicalizePath given_path + let real_dir = takeDirectory real_path + versionSuffix path = takeVersionSuffix (dropExeExtension path) + given_suf = versionSuffix given_path + real_suf = versionSuffix real_path + guessNormal dir = dir toolname <.> exeExtension buildPlatform + guessGhcjs dir = dir (toolname ++ "-ghcjs") + <.> exeExtension buildPlatform + guessGhcjsVersioned dir suf = dir (toolname ++ "-ghcjs" ++ suf) + <.> exeExtension buildPlatform + guessVersioned dir suf = dir (toolname ++ suf) + <.> exeExtension buildPlatform + mkGuesses dir suf | null suf = [guessGhcjs dir, guessNormal dir] + | otherwise = [guessGhcjsVersioned dir suf, + guessVersioned dir suf, + guessGhcjs dir, + guessNormal dir] + guesses = mkGuesses given_dir given_suf ++ + if real_path == given_path + then [] + else mkGuesses real_dir real_suf + info verbosity $ "looking for tool " ++ toolname + ++ " near compiler in " ++ given_dir + debug verbosity $ "candidate locations: " ++ show guesses + exists <- traverse doesFileExist guesses + case [ file | (file, True) <- zip guesses exists ] of + -- If we can't find it near ghc, fall back to the usual + -- method. + [] -> programFindLocation tool verbosity searchpath + (fp:_) -> do info verbosity $ "found " ++ toolname ++ " in " ++ fp + let lookedAt = map fst + . takeWhile (\(_file, exist) -> not exist) + $ zip guesses exists + return (Just (fp, lookedAt)) + + where takeVersionSuffix :: FilePath -> String + takeVersionSuffix = takeWhileEndLE isSuffixChar + + isSuffixChar :: Char -> Bool + isSuffixChar c = isDigit c || c == '.' || c == '-' + +getGhcInfo :: Verbosity -> ConfiguredProgram -> IO [(String, String)] +getGhcInfo verbosity ghcjsProg = Internal.getGhcInfo verbosity implInfo ghcjsProg + where + version = fromMaybe (error "GHCJS.getGhcInfo: no version") $ programVersion ghcjsProg + implInfo = ghcVersionImplInfo version + +-- | Given a single package DB, return all installed packages. +getPackageDBContents :: Verbosity -> PackageDB -> ProgramDb + -> IO InstalledPackageIndex +getPackageDBContents verbosity packagedb progdb = do + pkgss <- getInstalledPackages' verbosity [packagedb] progdb + toPackageIndex verbosity pkgss progdb + +-- | Given a package DB stack, return all installed packages. +getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramDb + -> IO InstalledPackageIndex +getInstalledPackages verbosity packagedbs progdb = do + checkPackageDbEnvVar verbosity + checkPackageDbStack verbosity packagedbs + pkgss <- getInstalledPackages' verbosity packagedbs progdb + index <- toPackageIndex verbosity pkgss progdb + return $! index + +toPackageIndex :: Verbosity + -> [(PackageDB, [InstalledPackageInfo])] + -> ProgramDb + -> IO InstalledPackageIndex +toPackageIndex verbosity pkgss progdb = do + -- On Windows, various fields have $topdir/foo rather than full + -- paths. We need to substitute the right value in so that when + -- we, for example, call gcc, we have proper paths to give it. + topDir <- getLibDir' verbosity ghcjsProg + let indices = [ PackageIndex.fromList (map (Internal.substTopDir topDir) pkgs) + | (_, pkgs) <- pkgss ] + return $! (mconcat indices) + + where + ghcjsProg = fromMaybe (error "GHCJS.toPackageIndex no ghcjs program") $ lookupProgram ghcjsProgram progdb + +getLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath +getLibDir verbosity lbi = + dropWhileEndLE isSpace `fmap` + getDbProgramOutput verbosity ghcjsProgram + (withPrograms lbi) ["--print-libdir"] + +getLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath +getLibDir' verbosity ghcjsProg = + dropWhileEndLE isSpace `fmap` + getProgramOutput verbosity ghcjsProg ["--print-libdir"] + + +-- | Return the 'FilePath' to the global GHC package database. +getGlobalPackageDB :: Verbosity -> ConfiguredProgram -> IO FilePath +getGlobalPackageDB verbosity ghcProg = + dropWhileEndLE isSpace `fmap` + getProgramOutput verbosity ghcProg ["--print-global-package-db"] + +-- | Return the 'FilePath' to the per-user GHC package database. +getUserPackageDB :: Verbosity -> ConfiguredProgram -> Platform -> IO FilePath +getUserPackageDB _verbosity ghcjsProg platform = do + -- It's rather annoying that we have to reconstruct this, because ghc + -- hides this information from us otherwise. But for certain use cases + -- like change monitoring it really can't remain hidden. + appdir <- getAppUserDataDirectory "ghcjs" + return (appdir platformAndVersion packageConfFileName) + where + platformAndVersion = Internal.ghcPlatformAndVersionString + platform ghcjsVersion + packageConfFileName = "package.conf.d" + ghcjsVersion = fromMaybe (error "GHCJS.getUserPackageDB: no version") $ programVersion ghcjsProg + +checkPackageDbEnvVar :: Verbosity -> IO () +checkPackageDbEnvVar verbosity = + Internal.checkPackageDbEnvVar verbosity "GHCJS" "GHCJS_PACKAGE_PATH" + +checkPackageDbStack :: Verbosity -> PackageDBStack -> IO () +checkPackageDbStack _ (GlobalPackageDB:rest) + | GlobalPackageDB `notElem` rest = return () +checkPackageDbStack verbosity rest + | GlobalPackageDB `notElem` rest = + die' verbosity $ "With current ghc versions the global package db is always used " + ++ "and must be listed first. This ghc limitation may be lifted in " + ++ "future, see https://gitlab.haskell.org/ghc/ghc/-/issues/5977" +checkPackageDbStack verbosity _ = + die' verbosity $ "If the global package db is specified, it must be " + ++ "specified first and cannot be specified multiple times" + +getInstalledPackages' :: Verbosity -> [PackageDB] -> ProgramDb + -> IO [(PackageDB, [InstalledPackageInfo])] +getInstalledPackages' verbosity packagedbs progdb = + sequenceA + [ do pkgs <- HcPkg.dump (hcPkgInfo progdb) verbosity packagedb + return (packagedb, pkgs) + | packagedb <- packagedbs ] + +-- | Get the packages from specific PackageDBs, not cumulative. +-- +getInstalledPackagesMonitorFiles :: Verbosity -> Platform + -> ProgramDb + -> [PackageDB] + -> IO [FilePath] +getInstalledPackagesMonitorFiles verbosity platform progdb = + traverse getPackageDBPath + where + getPackageDBPath :: PackageDB -> IO FilePath + getPackageDBPath GlobalPackageDB = + selectMonitorFile =<< getGlobalPackageDB verbosity ghcjsProg + + getPackageDBPath UserPackageDB = + selectMonitorFile =<< getUserPackageDB verbosity ghcjsProg platform + + getPackageDBPath (SpecificPackageDB path) = selectMonitorFile path + + -- GHC has old style file dbs, and new style directory dbs. + -- Note that for dir style dbs, we only need to monitor the cache file, not + -- the whole directory. The ghc program itself only reads the cache file + -- so it's safe to only monitor this one file. + selectMonitorFile path = do + isFileStyle <- doesFileExist path + if isFileStyle then return path + else return (path "package.cache") + + ghcjsProg = fromMaybe (error "GHCJS.toPackageIndex no ghcjs program") $ lookupProgram ghcjsProgram progdb + + +toJSLibName :: String -> String +toJSLibName lib + | takeExtension lib `elem` [".dll",".dylib",".so"] + = replaceExtension lib "js_so" + | takeExtension lib == ".a" = replaceExtension lib "js_a" + | otherwise = lib <.> "js_a" + +-- ----------------------------------------------------------------------------- +-- Building a library + +buildLib :: Verbosity -> Cabal.Flag (Maybe Int) -> PackageDescription + -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo + -> IO () +buildLib = buildOrReplLib Nothing + +replLib :: [String] -> Verbosity + -> Cabal.Flag (Maybe Int) -> PackageDescription + -> LocalBuildInfo -> Library + -> ComponentLocalBuildInfo -> IO () +replLib = buildOrReplLib . Just + +buildOrReplLib :: Maybe [String] -> Verbosity + -> Cabal.Flag (Maybe Int) -> PackageDescription + -> LocalBuildInfo -> Library + -> ComponentLocalBuildInfo -> IO () +buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do + let uid = componentUnitId clbi + libTargetDir = componentBuildDir lbi clbi + whenVanillaLib forceVanilla = + when (forceVanilla || withVanillaLib lbi) + whenProfLib = when (withProfLib lbi) + whenSharedLib forceShared = + when (forceShared || withSharedLib lbi) + whenStaticLib forceStatic = + when (forceStatic || withStaticLib lbi) + -- whenGHCiLib = when (withGHCiLib lbi) + forRepl = maybe False (const True) mReplFlags + -- ifReplLib = when forRepl + comp = compiler lbi + implInfo = getImplInfo comp + platform@(Platform _hostArch _hostOS) = hostPlatform lbi + has_code = not (componentIsIndefinite clbi) + + (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi) + let runGhcjsProg = runGHC verbosity ghcjsProg comp platform + + let libBi = libBuildInfo lib + + -- fixme flags shouldn't depend on ghcjs being dynamic or not + let isGhcjsDynamic = isDynamic comp + dynamicTooSupported = supportsDynamicToo comp + doingTH = usesTemplateHaskellOrQQ libBi + forceVanillaLib = doingTH && not isGhcjsDynamic + forceSharedLib = doingTH && isGhcjsDynamic + -- TH always needs default libs, even when building for profiling + + -- Determine if program coverage should be enabled and if so, what + -- '-hpcdir' should be. + let isCoverageEnabled = libCoverage lbi + -- TODO: Historically HPC files have been put into a directory which + -- has the package name. I'm going to avoid changing this for + -- now, but it would probably be better for this to be the + -- component ID instead... + pkg_name = prettyShow (PD.package pkg_descr) + distPref = fromFlag $ configDistPref $ configFlags lbi + hpcdir way + | forRepl = mempty -- HPC is not supported in ghci + | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way pkg_name + | otherwise = mempty + + createDirectoryIfMissingVerbose verbosity True libTargetDir + -- TODO: do we need to put hs-boot files into place for mutually recursive + -- modules? + let cLikeFiles = fromNubListR $ toNubListR (cSources libBi) <> toNubListR (cxxSources libBi) + jsSrcs = jsSources libBi + cObjs = map (`replaceExtension` objExtension) cLikeFiles + baseOpts = componentGhcOptions verbosity lbi libBi clbi libTargetDir + linkJsLibOpts = mempty { + ghcOptExtra = + [ "-link-js-lib" , getHSLibraryName uid + , "-js-lib-outputdir", libTargetDir ] ++ + jsSrcs + } + vanillaOptsNoJsLib = baseOpts `mappend` mempty { + ghcOptMode = toFlag GhcModeMake, + ghcOptNumJobs = numJobs, + ghcOptInputModules = toNubListR $ allLibModules lib clbi, + ghcOptHPCDir = hpcdir Hpc.Vanilla + } + vanillaOpts = vanillaOptsNoJsLib `mappend` linkJsLibOpts + + profOpts = adjustExts "p_hi" "p_o" vanillaOpts `mappend` mempty { + ghcOptProfilingMode = toFlag True, + ghcOptProfilingAuto = Internal.profDetailLevelFlag True + (withProfLibDetail lbi), + -- ghcOptHiSuffix = toFlag "p_hi", + -- ghcOptObjSuffix = toFlag "p_o", + ghcOptExtra = hcProfOptions GHC libBi, + ghcOptHPCDir = hpcdir Hpc.Prof + } + + sharedOpts = adjustExts "dyn_hi" "dyn_o" vanillaOpts `mappend` mempty { + ghcOptDynLinkMode = toFlag GhcDynamicOnly, + ghcOptFPic = toFlag True, + -- ghcOptHiSuffix = toFlag "dyn_hi", + -- ghcOptObjSuffix = toFlag "dyn_o", + ghcOptExtra = hcSharedOptions GHC libBi, + ghcOptHPCDir = hpcdir Hpc.Dyn + } + + vanillaSharedOpts = vanillaOpts `mappend` mempty { + ghcOptDynLinkMode = toFlag GhcStaticAndDynamic, + ghcOptDynHiSuffix = toFlag "js_dyn_hi", + ghcOptDynObjSuffix = toFlag "js_dyn_o", + ghcOptHPCDir = hpcdir Hpc.Dyn + } + + unless (forRepl || null (allLibModules lib clbi) && null jsSrcs && null cObjs) $ + do let vanilla = whenVanillaLib forceVanillaLib (runGhcjsProg vanillaOpts) + shared = whenSharedLib forceSharedLib (runGhcjsProg sharedOpts) + useDynToo = dynamicTooSupported && + (forceVanillaLib || withVanillaLib lbi) && + (forceSharedLib || withSharedLib lbi) && + null (hcSharedOptions GHC libBi) + if not has_code + then vanilla + else + if useDynToo + then do + runGhcjsProg vanillaSharedOpts + case (hpcdir Hpc.Dyn, hpcdir Hpc.Vanilla) of + (Cabal.Flag dynDir, Cabal.Flag vanillaDir) -> + -- When the vanilla and shared library builds are done + -- in one pass, only one set of HPC module interfaces + -- are generated. This set should suffice for both + -- static and dynamically linked executables. We copy + -- the modules interfaces so they are available under + -- both ways. + copyDirectoryRecursive verbosity dynDir vanillaDir + _ -> return () + else if isGhcjsDynamic + then do shared; vanilla + else do vanilla; shared + whenProfLib (runGhcjsProg profOpts) + + -- Build any C++ sources separately. + {- + unless (not has_code || null (cxxSources libBi) || not nativeToo) $ do + info verbosity "Building C++ Sources..." + sequence_ + [ do let baseCxxOpts = Internal.componentCxxGhcOptions verbosity implInfo + lbi libBi clbi libTargetDir filename + vanillaCxxOpts = if isGhcjsDynamic + then baseCxxOpts { ghcOptFPic = toFlag True } + else baseCxxOpts + profCxxOpts = vanillaCxxOpts `mappend` mempty { + ghcOptProfilingMode = toFlag True, + ghcOptObjSuffix = toFlag "p_o" + } + sharedCxxOpts = vanillaCxxOpts `mappend` mempty { + ghcOptFPic = toFlag True, + ghcOptDynLinkMode = toFlag GhcDynamicOnly, + ghcOptObjSuffix = toFlag "dyn_o" + } + odir = fromFlag (ghcOptObjDir vanillaCxxOpts) + createDirectoryIfMissingVerbose verbosity True odir + let runGhcProgIfNeeded cxxOpts = do + needsRecomp <- checkNeedsRecompilation filename cxxOpts + when needsRecomp $ runGhcjsProg cxxOpts + runGhcProgIfNeeded vanillaCxxOpts + unless forRepl $ + whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCxxOpts) + unless forRepl $ whenProfLib (runGhcProgIfNeeded profCxxOpts) + | filename <- cxxSources libBi] + + ifReplLib $ do + when (null (allLibModules lib clbi)) $ warn verbosity "No exposed modules" + ifReplLib (runGhcjsProg replOpts) +-} + -- build any C sources + -- TODO: Add support for S and CMM files. + {- + unless (not has_code || null (cSources libBi) || not nativeToo) $ do + info verbosity "Building C Sources..." + sequence_ + [ do let baseCcOpts = Internal.componentCcGhcOptions verbosity implInfo + lbi libBi clbi libTargetDir filename + vanillaCcOpts = if isGhcjsDynamic + -- Dynamic GHC requires C sources to be built + -- with -fPIC for REPL to work. See #2207. + then baseCcOpts { ghcOptFPic = toFlag True } + else baseCcOpts + profCcOpts = vanillaCcOpts `mappend` mempty { + ghcOptProfilingMode = toFlag True, + ghcOptObjSuffix = toFlag "p_o" + } + sharedCcOpts = vanillaCcOpts `mappend` mempty { + ghcOptFPic = toFlag True, + ghcOptDynLinkMode = toFlag GhcDynamicOnly, + ghcOptObjSuffix = toFlag "dyn_o" + } + odir = fromFlag (ghcOptObjDir vanillaCcOpts) + createDirectoryIfMissingVerbose verbosity True odir + let runGhcProgIfNeeded ccOpts = do + needsRecomp <- checkNeedsRecompilation filename ccOpts + when needsRecomp $ runGhcjsProg ccOpts + runGhcProgIfNeeded vanillaCcOpts + unless forRepl $ + whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCcOpts) + unless forRepl $ whenProfLib (runGhcProgIfNeeded profCcOpts) + | filename <- cSources libBi] +-} + -- TODO: problem here is we need the .c files built first, so we can load them + -- with ghci, but .c files can depend on .h files generated by ghc by ffi + -- exports. + + -- link: + + when has_code . when False {- fixme nativeToo -} . unless forRepl $ do + info verbosity "Linking..." + let cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension)) + (cSources libBi ++ cxxSources libBi) + compiler_id = compilerId (compiler lbi) + sharedLibFilePath = libTargetDir mkSharedLibName (hostPlatform lbi) compiler_id uid + staticLibFilePath = libTargetDir mkStaticLibName (hostPlatform lbi) compiler_id uid + + let stubObjs = [] + stubSharedObjs = [] + +{- + stubObjs <- catMaybes <$> sequenceA + [ findFileWithExtension [objExtension] [libTargetDir] + (ModuleName.toFilePath x ++"_stub") + | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files + , x <- allLibModules lib clbi ] + stubProfObjs <- catMaybes <$> sequenceA + [ findFileWithExtension ["p_" ++ objExtension] [libTargetDir] + (ModuleName.toFilePath x ++"_stub") + | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files + , x <- allLibModules lib clbi ] + stubSharedObjs <- catMaybes <$> sequenceA + [ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir] + (ModuleName.toFilePath x ++"_stub") + | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files + , x <- allLibModules lib clbi ] +-} + hObjs <- Internal.getHaskellObjects implInfo lib lbi clbi + libTargetDir objExtension True + hSharedObjs <- + if withSharedLib lbi + then Internal.getHaskellObjects implInfo lib lbi clbi + libTargetDir ("dyn_" ++ objExtension) False + else return [] + + unless (null hObjs && null cObjs && null stubObjs) $ do + rpaths <- getRPaths lbi clbi + + let staticObjectFiles = + hObjs + ++ map (libTargetDir ) cObjs + ++ stubObjs + dynamicObjectFiles = + hSharedObjs + ++ map (libTargetDir ) cSharedObjs + ++ stubSharedObjs + -- After the relocation lib is created we invoke ghc -shared + -- with the dependencies spelled out as -package arguments + -- and ghc invokes the linker with the proper library paths + ghcSharedLinkArgs = + mempty { + ghcOptShared = toFlag True, + ghcOptDynLinkMode = toFlag GhcDynamicOnly, + ghcOptInputFiles = toNubListR dynamicObjectFiles, + ghcOptOutputFile = toFlag sharedLibFilePath, + ghcOptExtra = hcSharedOptions GHC libBi, + -- For dynamic libs, Mac OS/X needs to know the install location + -- at build time. This only applies to GHC < 7.8 - see the + -- discussion in #1660. + {- + ghcOptDylibName = if hostOS == OSX + && ghcVersion < mkVersion [7,8] + then toFlag sharedLibInstallPath + else mempty, -} + ghcOptHideAllPackages = toFlag True, + ghcOptNoAutoLinkPackages = toFlag True, + ghcOptPackageDBs = withPackageDB lbi, + ghcOptThisUnitId = case clbi of + LibComponentLocalBuildInfo { componentCompatPackageKey = pk } + -> toFlag pk + _ -> mempty, + ghcOptThisComponentId = case clbi of + LibComponentLocalBuildInfo { componentInstantiatedWith = insts } -> + if null insts + then mempty + else toFlag (componentComponentId clbi) + _ -> mempty, + ghcOptInstantiatedWith = case clbi of + LibComponentLocalBuildInfo { componentInstantiatedWith = insts } + -> insts + _ -> [], + ghcOptPackages = toNubListR $ + Internal.mkGhcOptPackages clbi , + ghcOptLinkLibs = extraLibs libBi, + ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi, + ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi, + ghcOptLinkFrameworkDirs = + toNubListR $ PD.extraFrameworkDirs libBi, + ghcOptRPaths = rpaths + } + ghcStaticLinkArgs = + mempty { + ghcOptStaticLib = toFlag True, + ghcOptInputFiles = toNubListR staticObjectFiles, + ghcOptOutputFile = toFlag staticLibFilePath, + ghcOptExtra = hcStaticOptions GHC libBi, + ghcOptHideAllPackages = toFlag True, + ghcOptNoAutoLinkPackages = toFlag True, + ghcOptPackageDBs = withPackageDB lbi, + ghcOptThisUnitId = case clbi of + LibComponentLocalBuildInfo { componentCompatPackageKey = pk } + -> toFlag pk + _ -> mempty, + ghcOptThisComponentId = case clbi of + LibComponentLocalBuildInfo { componentInstantiatedWith = insts } -> + if null insts + then mempty + else toFlag (componentComponentId clbi) + _ -> mempty, + ghcOptInstantiatedWith = case clbi of + LibComponentLocalBuildInfo { componentInstantiatedWith = insts } + -> insts + _ -> [], + ghcOptPackages = toNubListR $ + Internal.mkGhcOptPackages clbi , + ghcOptLinkLibs = extraLibs libBi, + ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi + } + + info verbosity (show (ghcOptPackages ghcSharedLinkArgs)) +{- + whenVanillaLib False $ do + Ar.createArLibArchive verbosity lbi vanillaLibFilePath staticObjectFiles + whenGHCiLib $ do + (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi) + Ld.combineObjectFiles verbosity lbi ldProg + ghciLibFilePath staticObjectFiles + -} +{- + whenProfLib $ do + Ar.createArLibArchive verbosity lbi profileLibFilePath profObjectFiles + whenGHCiLib $ do + (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi) + Ld.combineObjectFiles verbosity lbi ldProg + ghciProfLibFilePath profObjectFiles +-} + whenSharedLib False $ + runGhcjsProg ghcSharedLinkArgs + + whenStaticLib False $ + runGhcjsProg ghcStaticLinkArgs + +-- | Start a REPL without loading any source files. +startInterpreter :: Verbosity -> ProgramDb -> Compiler -> Platform + -> PackageDBStack -> IO () +startInterpreter verbosity progdb comp platform packageDBs = do + let replOpts = mempty { + ghcOptMode = toFlag GhcModeInteractive, + ghcOptPackageDBs = packageDBs + } + checkPackageDbStack verbosity packageDBs + (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram progdb + runGHC verbosity ghcjsProg comp platform replOpts + +-- ----------------------------------------------------------------------------- +-- Building an executable or foreign library + +-- | Build a foreign library +buildFLib + :: Verbosity -> Cabal.Flag (Maybe Int) + -> PackageDescription -> LocalBuildInfo + -> ForeignLib -> ComponentLocalBuildInfo -> IO () +buildFLib v njobs pkg lbi = gbuild v njobs pkg lbi . GBuildFLib + +replFLib + :: [String] -> Verbosity + -> Cabal.Flag (Maybe Int) -> PackageDescription + -> LocalBuildInfo -> ForeignLib + -> ComponentLocalBuildInfo -> IO () +replFLib replFlags v njobs pkg lbi = + gbuild v njobs pkg lbi . GReplFLib replFlags + +-- | Build an executable with GHC. +-- +buildExe + :: Verbosity -> Cabal.Flag (Maybe Int) + -> PackageDescription -> LocalBuildInfo + -> Executable -> ComponentLocalBuildInfo -> IO () +buildExe v njobs pkg lbi = gbuild v njobs pkg lbi . GBuildExe + +replExe + :: [String] -> Verbosity + -> Cabal.Flag (Maybe Int) -> PackageDescription + -> LocalBuildInfo -> Executable + -> ComponentLocalBuildInfo -> IO () +replExe replFlags v njobs pkg lbi = + gbuild v njobs pkg lbi . GReplExe replFlags + +-- | Building an executable, starting the REPL, and building foreign +-- libraries are all very similar and implemented in 'gbuild'. The +-- 'GBuildMode' distinguishes between the various kinds of operation. +data GBuildMode = + GBuildExe Executable + | GReplExe [String] Executable + | GBuildFLib ForeignLib + | GReplFLib [String] ForeignLib + +gbuildInfo :: GBuildMode -> BuildInfo +gbuildInfo (GBuildExe exe) = buildInfo exe +gbuildInfo (GReplExe _ exe) = buildInfo exe +gbuildInfo (GBuildFLib flib) = foreignLibBuildInfo flib +gbuildInfo (GReplFLib _ flib) = foreignLibBuildInfo flib + +gbuildName :: GBuildMode -> String +gbuildName (GBuildExe exe) = unUnqualComponentName $ exeName exe +gbuildName (GReplExe _ exe) = unUnqualComponentName $ exeName exe +gbuildName (GBuildFLib flib) = unUnqualComponentName $ foreignLibName flib +gbuildName (GReplFLib _ flib) = unUnqualComponentName $ foreignLibName flib + +gbuildTargetName :: LocalBuildInfo -> GBuildMode -> String +gbuildTargetName lbi (GBuildExe exe) = exeTargetName (hostPlatform lbi) exe +gbuildTargetName lbi (GReplExe _ exe) = exeTargetName (hostPlatform lbi) exe +gbuildTargetName lbi (GBuildFLib flib) = flibTargetName lbi flib +gbuildTargetName lbi (GReplFLib _ flib) = flibTargetName lbi flib + +exeTargetName :: Platform -> Executable -> String +exeTargetName platform exe = unUnqualComponentName (exeName exe) `withExt` exeExtension platform + +-- | Target name for a foreign library (the actual file name) +-- +-- We do not use mkLibName and co here because the naming for foreign libraries +-- is slightly different (we don't use "_p" or compiler version suffices, and we +-- don't want the "lib" prefix on Windows). +-- +-- TODO: We do use `dllExtension` and co here, but really that's wrong: they +-- use the OS used to build cabal to determine which extension to use, rather +-- than the target OS (but this is wrong elsewhere in Cabal as well). +flibTargetName :: LocalBuildInfo -> ForeignLib -> String +flibTargetName lbi flib = + case (os, foreignLibType flib) of + (Windows, ForeignLibNativeShared) -> nm <.> "dll" + (Windows, ForeignLibNativeStatic) -> nm <.> "lib" + (Linux, ForeignLibNativeShared) -> "lib" ++ nm <.> versionedExt + (_other, ForeignLibNativeShared) -> "lib" ++ nm <.> dllExtension (hostPlatform lbi) + (_other, ForeignLibNativeStatic) -> "lib" ++ nm <.> staticLibExtension (hostPlatform lbi) + (_any, ForeignLibTypeUnknown) -> cabalBug "unknown foreign lib type" + where + nm :: String + nm = unUnqualComponentName $ foreignLibName flib + + os :: OS + os = let (Platform _ os') = hostPlatform lbi + in os' + + -- If a foreign lib foo has lib-version-info 5:1:2 or + -- lib-version-linux 3.2.1, it should be built as libfoo.so.3.2.1 + -- Libtool's version-info data is translated into library versions in a + -- nontrivial way: so refer to libtool documentation. + versionedExt :: String + versionedExt = + let nums = foreignLibVersion flib os + in foldl (<.>) "so" (map show nums) + +-- | Name for the library when building. +-- +-- If the `lib-version-info` field or the `lib-version-linux` field of +-- a foreign library target is set, we need to incorporate that +-- version into the SONAME field. +-- +-- If a foreign library foo has lib-version-info 5:1:2, it should be +-- built as libfoo.so.3.2.1. We want it to get soname libfoo.so.3. +-- However, GHC does not allow overriding soname by setting linker +-- options, as it sets a soname of its own (namely the output +-- filename), after the user-supplied linker options. Hence, we have +-- to compile the library with the soname as its filename. We rename +-- the compiled binary afterwards. +-- +-- This method allows to adjust the name of the library at build time +-- such that the correct soname can be set. +flibBuildName :: LocalBuildInfo -> ForeignLib -> String +flibBuildName lbi flib + -- On linux, if a foreign-library has version data, the first digit is used + -- to produce the SONAME. + | (os, foreignLibType flib) == + (Linux, ForeignLibNativeShared) + = let nums = foreignLibVersion flib os + in "lib" ++ nm <.> foldl (<.>) "so" (map show (take 1 nums)) + | otherwise = flibTargetName lbi flib + where + os :: OS + os = let (Platform _ os') = hostPlatform lbi + in os' + + nm :: String + nm = unUnqualComponentName $ foreignLibName flib + +gbuildIsRepl :: GBuildMode -> Bool +gbuildIsRepl (GBuildExe _) = False +gbuildIsRepl (GReplExe _ _) = True +gbuildIsRepl (GBuildFLib _) = False +gbuildIsRepl (GReplFLib _ _) = True + +gbuildNeedDynamic :: LocalBuildInfo -> GBuildMode -> Bool +gbuildNeedDynamic lbi bm = + case bm of + GBuildExe _ -> withDynExe lbi + GReplExe _ _ -> withDynExe lbi + GBuildFLib flib -> withDynFLib flib + GReplFLib _ flib -> withDynFLib flib + where + withDynFLib flib = + case foreignLibType flib of + ForeignLibNativeShared -> + ForeignLibStandalone `notElem` foreignLibOptions flib + ForeignLibNativeStatic -> + False + ForeignLibTypeUnknown -> + cabalBug "unknown foreign lib type" + +gbuildModDefFiles :: GBuildMode -> [FilePath] +gbuildModDefFiles (GBuildExe _) = [] +gbuildModDefFiles (GReplExe _ _) = [] +gbuildModDefFiles (GBuildFLib flib) = foreignLibModDefFile flib +gbuildModDefFiles (GReplFLib _ flib) = foreignLibModDefFile flib + +-- | "Main" module name when overridden by @ghc-options: -main-is ...@ +-- or 'Nothing' if no @-main-is@ flag could be found. +-- +-- In case of 'Nothing', 'Distribution.ModuleName.main' can be assumed. +exeMainModuleName :: Executable -> Maybe ModuleName +exeMainModuleName Executable{buildInfo = bnfo} = + -- GHC honors the last occurrence of a module name updated via -main-is + -- + -- Moreover, -main-is when parsed left-to-right can update either + -- the "Main" module name, or the "main" function name, or both, + -- see also 'decodeMainIsArg'. + msum $ reverse $ map decodeMainIsArg $ findIsMainArgs ghcopts + where + ghcopts = hcOptions GHC bnfo + + findIsMainArgs [] = [] + findIsMainArgs ("-main-is":arg:rest) = arg : findIsMainArgs rest + findIsMainArgs (_:rest) = findIsMainArgs rest + +-- | Decode argument to '-main-is' +-- +-- Returns 'Nothing' if argument set only the function name. +-- +-- This code has been stolen/refactored from GHC's DynFlags.setMainIs +-- function. The logic here is deliberately imperfect as it is +-- intended to be bug-compatible with GHC's parser. See discussion in +-- https://github.com/haskell/cabal/pull/4539#discussion_r118981753. +decodeMainIsArg :: String -> Maybe ModuleName +decodeMainIsArg arg + | headOf main_fn isLower + -- The arg looked like "Foo.Bar.baz" + = Just (ModuleName.fromString main_mod) + | headOf arg isUpper -- The arg looked like "Foo" or "Foo.Bar" + = Just (ModuleName.fromString arg) + | otherwise -- The arg looked like "baz" + = Nothing + where + headOf :: String -> (Char -> Bool) -> Bool + headOf str pred' = any pred' (safeHead str) + + (main_mod, main_fn) = splitLongestPrefix arg (== '.') + + splitLongestPrefix :: String -> (Char -> Bool) -> (String,String) + splitLongestPrefix str pred' + | null r_pre = (str, []) + | otherwise = (reverse (safeTail r_pre), reverse r_suf) + -- 'safeTail' drops the char satisfying 'pred' + where (r_suf, r_pre) = break pred' (reverse str) + + +-- | A collection of: +-- * C input files +-- * C++ input files +-- * GHC input files +-- * GHC input modules +-- +-- Used to correctly build and link sources. +data BuildSources = BuildSources { + cSourcesFiles :: [FilePath], + cxxSourceFiles :: [FilePath], + inputSourceFiles :: [FilePath], + inputSourceModules :: [ModuleName] + } + +-- | Locate and return the 'BuildSources' required to build and link. +gbuildSources :: Verbosity + -> PackageId + -> CabalSpecVersion + -> FilePath + -> GBuildMode + -> IO BuildSources +gbuildSources verbosity pkgId specVer tmpDir bm = + case bm of + GBuildExe exe -> exeSources exe + GReplExe _ exe -> exeSources exe + GBuildFLib flib -> return $ flibSources flib + GReplFLib _ flib -> return $ flibSources flib + where + exeSources :: Executable -> IO BuildSources + exeSources exe@Executable{buildInfo = bnfo, modulePath = modPath} = do + main <- findFileEx verbosity (tmpDir : map getSymbolicPath (hsSourceDirs bnfo)) modPath + let mainModName = fromMaybe ModuleName.main $ exeMainModuleName exe + otherModNames = exeModules exe + + -- Scripts have fakePackageId and are always Haskell but can have any extension. + if isHaskell main || pkgId == fakePackageId + then + if specVer < CabalSpecV2_0 && (mainModName `elem` otherModNames) + then do + -- The cabal manual clearly states that `other-modules` is + -- intended for non-main modules. However, there's at least one + -- important package on Hackage (happy-1.19.5) which + -- violates this. We workaround this here so that we don't + -- invoke GHC with e.g. 'ghc --make Main src/Main.hs' which + -- would result in GHC complaining about duplicate Main + -- modules. + -- + -- Finally, we only enable this workaround for + -- specVersion < 2, as 'cabal-version:>=2.0' cabal files + -- have no excuse anymore to keep doing it wrong... ;-) + warn verbosity $ "Enabling workaround for Main module '" + ++ prettyShow mainModName + ++ "' listed in 'other-modules' illegally!" + + return BuildSources { + cSourcesFiles = cSources bnfo, + cxxSourceFiles = cxxSources bnfo, + inputSourceFiles = [main], + inputSourceModules = filter (/= mainModName) $ exeModules exe + } + + else return BuildSources { + cSourcesFiles = cSources bnfo, + cxxSourceFiles = cxxSources bnfo, + inputSourceFiles = [main], + inputSourceModules = exeModules exe + } + else let (csf, cxxsf) + | isCxx main = ( cSources bnfo, main : cxxSources bnfo) + -- if main is not a Haskell source + -- and main is not a C++ source + -- then we assume that it is a C source + | otherwise = (main : cSources bnfo, cxxSources bnfo) + + in return BuildSources { + cSourcesFiles = csf, + cxxSourceFiles = cxxsf, + inputSourceFiles = [], + inputSourceModules = exeModules exe + } + + flibSources :: ForeignLib -> BuildSources + flibSources flib@ForeignLib{foreignLibBuildInfo = bnfo} = + BuildSources { + cSourcesFiles = cSources bnfo, + cxxSourceFiles = cxxSources bnfo, + inputSourceFiles = [], + inputSourceModules = foreignLibModules flib + } + + isCxx :: FilePath -> Bool + isCxx fp = elem (takeExtension fp) [".cpp", ".cxx", ".c++"] + +-- | FilePath has a Haskell extension: .hs or .lhs +isHaskell :: FilePath -> Bool +isHaskell fp = elem (takeExtension fp) [".hs", ".lhs"] + +-- | Generic build function. See comment for 'GBuildMode'. +gbuild :: Verbosity -> Cabal.Flag (Maybe Int) + -> PackageDescription -> LocalBuildInfo + -> GBuildMode -> ComponentLocalBuildInfo -> IO () +gbuild verbosity numJobs pkg_descr lbi bm clbi = do + (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi) + let replFlags = case bm of + GReplExe flags _ -> flags + GReplFLib flags _ -> flags + GBuildExe{} -> mempty + GBuildFLib{} -> mempty + comp = compiler lbi + platform = hostPlatform lbi + implInfo = getImplInfo comp + runGhcProg = runGHC verbosity ghcjsProg comp platform + + let (bnfo, threaded) = case bm of + GBuildFLib _ -> popThreadedFlag (gbuildInfo bm) + _ -> (gbuildInfo bm, False) + + -- the name that GHC really uses (e.g., with .exe on Windows for executables) + let targetName = gbuildTargetName lbi bm + let targetDir = buildDir lbi (gbuildName bm) + let tmpDir = targetDir (gbuildName bm ++ "-tmp") + createDirectoryIfMissingVerbose verbosity True targetDir + createDirectoryIfMissingVerbose verbosity True tmpDir + + -- TODO: do we need to put hs-boot files into place for mutually recursive + -- modules? FIX: what about exeName.hi-boot? + + -- Determine if program coverage should be enabled and if so, what + -- '-hpcdir' should be. + let isCoverageEnabled = exeCoverage lbi + distPref = fromFlag $ configDistPref $ configFlags lbi + hpcdir way + | gbuildIsRepl bm = mempty -- HPC is not supported in ghci + | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way (gbuildName bm) + | otherwise = mempty + + rpaths <- getRPaths lbi clbi + buildSources <- gbuildSources verbosity (package pkg_descr) (specVersion pkg_descr) tmpDir bm + + let cSrcs = cSourcesFiles buildSources + cxxSrcs = cxxSourceFiles buildSources + inputFiles = inputSourceFiles buildSources + inputModules = inputSourceModules buildSources + isGhcDynamic = isDynamic comp + dynamicTooSupported = supportsDynamicToo comp + cObjs = map (`replaceExtension` objExtension) cSrcs + cxxObjs = map (`replaceExtension` objExtension) cxxSrcs + needDynamic = gbuildNeedDynamic lbi bm + needProfiling = withProfExe lbi + + -- build executables + buildRunner = case clbi of + LibComponentLocalBuildInfo {} -> False + FLibComponentLocalBuildInfo {} -> False + ExeComponentLocalBuildInfo {} -> True + TestComponentLocalBuildInfo {} -> True + BenchComponentLocalBuildInfo {} -> True + baseOpts = (componentGhcOptions verbosity lbi bnfo clbi tmpDir) + `mappend` mempty { + ghcOptMode = toFlag GhcModeMake, + ghcOptInputFiles = toNubListR $ if package pkg_descr == fakePackageId + then filter isHaskell inputFiles + else inputFiles, + ghcOptInputScripts = toNubListR $ if package pkg_descr == fakePackageId + then filter (not . isHaskell) inputFiles + else [], + ghcOptInputModules = toNubListR inputModules, + -- for all executable components (exe/test/bench), + -- GHCJS must be passed the "-build-runner" option + ghcOptExtra = + if buildRunner then ["-build-runner"] + else mempty + } + staticOpts = baseOpts `mappend` mempty { + ghcOptDynLinkMode = toFlag GhcStaticOnly, + ghcOptHPCDir = hpcdir Hpc.Vanilla + } + profOpts = baseOpts `mappend` mempty { + ghcOptProfilingMode = toFlag True, + ghcOptProfilingAuto = Internal.profDetailLevelFlag False + (withProfExeDetail lbi), + ghcOptHiSuffix = toFlag "p_hi", + ghcOptObjSuffix = toFlag "p_o", + ghcOptExtra = hcProfOptions GHC bnfo, + ghcOptHPCDir = hpcdir Hpc.Prof + } + dynOpts = baseOpts `mappend` mempty { + ghcOptDynLinkMode = toFlag GhcDynamicOnly, + -- TODO: Does it hurt to set -fPIC for executables? + ghcOptFPic = toFlag True, + ghcOptHiSuffix = toFlag "dyn_hi", + ghcOptObjSuffix = toFlag "dyn_o", + ghcOptExtra = hcSharedOptions GHC bnfo, + ghcOptHPCDir = hpcdir Hpc.Dyn + } + dynTooOpts = staticOpts `mappend` mempty { + ghcOptDynLinkMode = toFlag GhcStaticAndDynamic, + ghcOptDynHiSuffix = toFlag "dyn_hi", + ghcOptDynObjSuffix = toFlag "dyn_o", + ghcOptHPCDir = hpcdir Hpc.Dyn + } + linkerOpts = mempty { + ghcOptLinkOptions = PD.ldOptions bnfo, + ghcOptLinkLibs = extraLibs bnfo, + ghcOptLinkLibPath = toNubListR $ extraLibDirs bnfo, + ghcOptLinkFrameworks = toNubListR $ + PD.frameworks bnfo, + ghcOptLinkFrameworkDirs = toNubListR $ + PD.extraFrameworkDirs bnfo, + ghcOptInputFiles = toNubListR + [tmpDir x | x <- cObjs ++ cxxObjs] + } + dynLinkerOpts = mempty { + ghcOptRPaths = rpaths + } + replOpts = baseOpts { + ghcOptExtra = Internal.filterGhciFlags + (ghcOptExtra baseOpts) + <> replFlags + } + -- For a normal compile we do separate invocations of ghc for + -- compiling as for linking. But for repl we have to do just + -- the one invocation, so that one has to include all the + -- linker stuff too, like -l flags and any .o files from C + -- files etc. + `mappend` linkerOpts + `mappend` mempty { + ghcOptMode = toFlag GhcModeInteractive, + ghcOptOptimisation = toFlag GhcNoOptimisation + } + commonOpts | needProfiling = profOpts + | needDynamic = dynOpts + | otherwise = staticOpts + compileOpts | useDynToo = dynTooOpts + | otherwise = commonOpts + withStaticExe = not needProfiling && not needDynamic + + -- For building exe's that use TH with -prof or -dynamic we actually have + -- to build twice, once without -prof/-dynamic and then again with + -- -prof/-dynamic. This is because the code that TH needs to run at + -- compile time needs to be the vanilla ABI so it can be loaded up and run + -- by the compiler. + -- With dynamic-by-default GHC the TH object files loaded at compile-time + -- need to be .dyn_o instead of .o. + doingTH = usesTemplateHaskellOrQQ bnfo + -- Should we use -dynamic-too instead of compiling twice? + useDynToo = dynamicTooSupported && isGhcDynamic + && doingTH && withStaticExe + && null (hcSharedOptions GHC bnfo) + compileTHOpts | isGhcDynamic = dynOpts + | otherwise = staticOpts + compileForTH + | gbuildIsRepl bm = False + | useDynToo = False + | isGhcDynamic = doingTH && (needProfiling || withStaticExe) + | otherwise = doingTH && (needProfiling || needDynamic) + + -- Build static/dynamic object files for TH, if needed. + when compileForTH $ + runGhcProg compileTHOpts { ghcOptNoLink = toFlag True + , ghcOptNumJobs = numJobs } + + -- Do not try to build anything if there are no input files. + -- This can happen if the cabal file ends up with only cSrcs + -- but no Haskell modules. + unless ((null inputFiles && null inputModules) + || gbuildIsRepl bm) $ + runGhcProg compileOpts { ghcOptNoLink = toFlag True + , ghcOptNumJobs = numJobs } + + -- build any C++ sources + unless (null cxxSrcs) $ do + info verbosity "Building C++ Sources..." + sequence_ + [ do let baseCxxOpts = Internal.componentCxxGhcOptions verbosity implInfo + lbi bnfo clbi tmpDir filename + vanillaCxxOpts = if isGhcDynamic + -- Dynamic GHC requires C++ sources to be built + -- with -fPIC for REPL to work. See #2207. + then baseCxxOpts { ghcOptFPic = toFlag True } + else baseCxxOpts + profCxxOpts = vanillaCxxOpts `mappend` mempty { + ghcOptProfilingMode = toFlag True + } + sharedCxxOpts = vanillaCxxOpts `mappend` mempty { + ghcOptFPic = toFlag True, + ghcOptDynLinkMode = toFlag GhcDynamicOnly + } + opts | needProfiling = profCxxOpts + | needDynamic = sharedCxxOpts + | otherwise = vanillaCxxOpts + -- TODO: Placing all Haskell, C, & C++ objects in a single directory + -- Has the potential for file collisions. In general we would + -- consider this a user error. However, we should strive to + -- add a warning if this occurs. + odir = fromFlag (ghcOptObjDir opts) + createDirectoryIfMissingVerbose verbosity True odir + needsRecomp <- checkNeedsRecompilation filename opts + when needsRecomp $ + runGhcProg opts + | filename <- cxxSrcs ] + + -- build any C sources + unless (null cSrcs) $ do + info verbosity "Building C Sources..." + sequence_ + [ do let baseCcOpts = Internal.componentCcGhcOptions verbosity implInfo + lbi bnfo clbi tmpDir filename + vanillaCcOpts = if isGhcDynamic + -- Dynamic GHC requires C sources to be built + -- with -fPIC for REPL to work. See #2207. + then baseCcOpts { ghcOptFPic = toFlag True } + else baseCcOpts + profCcOpts = vanillaCcOpts `mappend` mempty { + ghcOptProfilingMode = toFlag True + } + sharedCcOpts = vanillaCcOpts `mappend` mempty { + ghcOptFPic = toFlag True, + ghcOptDynLinkMode = toFlag GhcDynamicOnly + } + opts | needProfiling = profCcOpts + | needDynamic = sharedCcOpts + | otherwise = vanillaCcOpts + odir = fromFlag (ghcOptObjDir opts) + createDirectoryIfMissingVerbose verbosity True odir + needsRecomp <- checkNeedsRecompilation filename opts + when needsRecomp $ + runGhcProg opts + | filename <- cSrcs ] + + -- TODO: problem here is we need the .c files built first, so we can load them + -- with ghci, but .c files can depend on .h files generated by ghc by ffi + -- exports. + case bm of + GReplExe _ _ -> runGhcProg replOpts + GReplFLib _ _ -> runGhcProg replOpts + GBuildExe _ -> do + let linkOpts = commonOpts + `mappend` linkerOpts + `mappend` mempty { + ghcOptLinkNoHsMain = toFlag (null inputFiles) + } + `mappend` (if withDynExe lbi then dynLinkerOpts else mempty) + + info verbosity "Linking..." + -- Work around old GHCs not relinking in this + -- situation, see #3294 + let target = targetDir targetName + when (compilerVersion comp < mkVersion [7,7]) $ do + e <- doesFileExist target + when e (removeFile target) + runGhcProg linkOpts { ghcOptOutputFile = toFlag target } + GBuildFLib flib -> do + let rtsInfo = extractRtsInfo lbi + rtsOptLinkLibs = [ + if needDynamic + then if threaded + then dynRtsThreadedLib (rtsDynamicInfo rtsInfo) + else dynRtsVanillaLib (rtsDynamicInfo rtsInfo) + else if threaded + then statRtsThreadedLib (rtsStaticInfo rtsInfo) + else statRtsVanillaLib (rtsStaticInfo rtsInfo) + ] + linkOpts = case foreignLibType flib of + ForeignLibNativeShared -> + commonOpts + `mappend` linkerOpts + `mappend` dynLinkerOpts + `mappend` mempty { + ghcOptLinkNoHsMain = toFlag True, + ghcOptShared = toFlag True, + ghcOptLinkLibs = rtsOptLinkLibs, + ghcOptLinkLibPath = toNubListR $ rtsLibPaths rtsInfo, + ghcOptFPic = toFlag True, + ghcOptLinkModDefFiles = toNubListR $ gbuildModDefFiles bm + } + -- See Note [RPATH] + `mappend` ifNeedsRPathWorkaround lbi mempty { + ghcOptLinkOptions = ["-Wl,--no-as-needed"] + , ghcOptLinkLibs = ["ffi"] + } + ForeignLibNativeStatic -> + -- this should be caught by buildFLib + -- (and if we do implement this, we probably don't even want to call + -- ghc here, but rather Ar.createArLibArchive or something) + cabalBug "static libraries not yet implemented" + ForeignLibTypeUnknown -> + cabalBug "unknown foreign lib type" + -- We build under a (potentially) different filename to set a + -- soname on supported platforms. See also the note for + -- @flibBuildName@. + info verbosity "Linking..." + let buildName = flibBuildName lbi flib + runGhcProg linkOpts { ghcOptOutputFile = toFlag (targetDir buildName) } + renameFile (targetDir buildName) (targetDir targetName) + +{- +Note [RPATH] +~~~~~~~~~~~~ + +Suppose that the dynamic library depends on `base`, but not (directly) on +`integer-gmp` (which, however, is a dependency of `base`). We will link the +library as + + gcc ... -lHSbase-4.7.0.2-ghc7.8.4 -lHSinteger-gmp-0.5.1.0-ghc7.8.4 ... + +However, on systems (like Ubuntu) where the linker gets called with `-as-needed` +by default, the linker will notice that `integer-gmp` isn't actually a direct +dependency and hence omit the link. + +Then when we attempt to link a C program against this dynamic library, the +_static_ linker will attempt to verify that all symbols can be resolved. The +dynamic library itself does not require any symbols from `integer-gmp`, but +`base` does. In order to verify that the symbols used by `base` can be +resolved, the static linker needs to be able to _find_ integer-gmp. + +Finding the `base` dependency is simple, because the dynamic elf header +(`readelf -d`) for the library that we have created looks something like + + (NEEDED) Shared library: [libHSbase-4.7.0.2-ghc7.8.4.so] + (RPATH) Library rpath: [/path/to/base-4.7.0.2:...] + +However, when it comes to resolving the dependency on `integer-gmp`, it needs +to look at the dynamic header for `base`. On modern ghc (7.8 and higher) this +looks something like + + (NEEDED) Shared library: [libHSinteger-gmp-0.5.1.0-ghc7.8.4.so] + (RPATH) Library rpath: [$ORIGIN/../integer-gmp-0.5.1.0:...] + +This specifies the location of `integer-gmp` _in terms of_ the location of base +(using the `$ORIGIN`) variable. But here's the crux: when the static linker +attempts to verify that all symbols can be resolved, [**IT DOES NOT RESOLVE +`$ORIGIN`**](http://stackoverflow.com/questions/6323603/ld-using-rpath-origin-inside-a-shared-library-recursive). +As a consequence, it will not be able to resolve the symbols and report the +missing symbols as errors, _even though the dynamic linker **would** be able to +resolve these symbols_. We can tell the static linker not to report these +errors by using `--unresolved-symbols=ignore-all` and all will be fine when we +run the program ([(indeed, this is what the gold linker +does)](https://sourceware.org/ml/binutils/2013-05/msg00038.html), but it makes +the resulting library more difficult to use. + +Instead what we can do is make sure that the generated dynamic library has +explicit top-level dependencies on these libraries. This means that the static +linker knows where to find them, and when we have transitive dependencies on +the same libraries the linker will only load them once, so we avoid needing to +look at the `RPATH` of our dependencies. We can do this by passing +`--no-as-needed` to the linker, so that it doesn't omit any libraries. + +Note that on older ghc (7.6 and before) the Haskell libraries don't have an +RPATH set at all, which makes it even more important that we make these +top-level dependencies. + +Finally, we have to explicitly link against `libffi` for the same reason. For +newer ghc this _happens_ to be unnecessary on many systems because `libffi` is +a library which is not specific to GHC, and when the static linker verifies +that all symbols can be resolved it will find the `libffi` that is globally +installed (completely independent from ghc). Of course, this may well be the +_wrong_ version of `libffi`, but it's quite possible that symbol resolution +happens to work. This is of course the wrong approach, which is why we link +explicitly against `libffi` so that we will find the _right_ version of +`libffi`. +-} + +-- | Do we need the RPATH workaround? +-- +-- See Note [RPATH]. +ifNeedsRPathWorkaround :: Monoid a => LocalBuildInfo -> a -> a +ifNeedsRPathWorkaround lbi a = + case hostPlatform lbi of + Platform _ Linux -> a + _otherwise -> mempty + +data DynamicRtsInfo = DynamicRtsInfo { + dynRtsVanillaLib :: FilePath + , dynRtsThreadedLib :: FilePath + , dynRtsDebugLib :: FilePath + , dynRtsEventlogLib :: FilePath + , dynRtsThreadedDebugLib :: FilePath + , dynRtsThreadedEventlogLib :: FilePath + } + +data StaticRtsInfo = StaticRtsInfo { + statRtsVanillaLib :: FilePath + , statRtsThreadedLib :: FilePath + , statRtsDebugLib :: FilePath + , statRtsEventlogLib :: FilePath + , statRtsThreadedDebugLib :: FilePath + , statRtsThreadedEventlogLib :: FilePath + , statRtsProfilingLib :: FilePath + , statRtsThreadedProfilingLib :: FilePath + } + +data RtsInfo = RtsInfo { + rtsDynamicInfo :: DynamicRtsInfo + , rtsStaticInfo :: StaticRtsInfo + , rtsLibPaths :: [FilePath] + } + +-- | Extract (and compute) information about the RTS library +-- +-- TODO: This hardcodes the name as @HSrts-ghc@. I don't know if we can +-- find this information somewhere. We can lookup the 'hsLibraries' field of +-- 'InstalledPackageInfo' but it will tell us @["HSrts", "Cffi"]@, which +-- doesn't really help. +extractRtsInfo :: LocalBuildInfo -> RtsInfo +extractRtsInfo lbi = + case PackageIndex.lookupPackageName (installedPkgs lbi) (mkPackageName "rts") of + [(_, [rts])] -> aux rts + _otherwise -> error "No (or multiple) ghc rts package is registered" + where + aux :: InstalledPackageInfo -> RtsInfo + aux rts = RtsInfo { + rtsDynamicInfo = DynamicRtsInfo { + dynRtsVanillaLib = withGhcVersion "HSrts" + , dynRtsThreadedLib = withGhcVersion "HSrts_thr" + , dynRtsDebugLib = withGhcVersion "HSrts_debug" + , dynRtsEventlogLib = withGhcVersion "HSrts_l" + , dynRtsThreadedDebugLib = withGhcVersion "HSrts_thr_debug" + , dynRtsThreadedEventlogLib = withGhcVersion "HSrts_thr_l" + } + , rtsStaticInfo = StaticRtsInfo { + statRtsVanillaLib = "HSrts" + , statRtsThreadedLib = "HSrts_thr" + , statRtsDebugLib = "HSrts_debug" + , statRtsEventlogLib = "HSrts_l" + , statRtsThreadedDebugLib = "HSrts_thr_debug" + , statRtsThreadedEventlogLib = "HSrts_thr_l" + , statRtsProfilingLib = "HSrts_p" + , statRtsThreadedProfilingLib = "HSrts_thr_p" + } + , rtsLibPaths = InstalledPackageInfo.libraryDirs rts + } + withGhcVersion = (++ ("-ghc" ++ prettyShow (compilerVersion (compiler lbi)))) + +-- | Returns True if the modification date of the given source file is newer than +-- the object file we last compiled for it, or if no object file exists yet. +checkNeedsRecompilation :: FilePath -> GhcOptions -> IO Bool +checkNeedsRecompilation filename opts = filename `moreRecentFile` oname + where oname = getObjectFileName filename opts + +-- | Finds the object file name of the given source file +getObjectFileName :: FilePath -> GhcOptions -> FilePath +getObjectFileName filename opts = oname + where odir = fromFlag (ghcOptObjDir opts) + oext = fromFlagOrDefault "o" (ghcOptObjSuffix opts) + oname = odir replaceExtension filename oext + +-- | Calculate the RPATHs for the component we are building. +-- +-- Calculates relative RPATHs when 'relocatable' is set. +getRPaths :: LocalBuildInfo + -> ComponentLocalBuildInfo -- ^ Component we are building + -> IO (NubListR FilePath) +getRPaths lbi clbi | supportRPaths hostOS = do + libraryPaths <- depLibraryPaths False (relocatable lbi) lbi clbi + let hostPref = case hostOS of + OSX -> "@loader_path" + _ -> "$ORIGIN" + relPath p = if isRelative p then hostPref p else p + rpaths = toNubListR (map relPath libraryPaths) + return rpaths + where + (Platform _ hostOS) = hostPlatform lbi + compid = compilerId . compiler $ lbi + + -- The list of RPath-supported operating systems below reflects the + -- platforms on which Cabal's RPATH handling is tested. It does _NOT_ + -- reflect whether the OS supports RPATH. + + -- E.g. when this comment was written, the *BSD operating systems were + -- untested with regards to Cabal RPATH handling, and were hence set to + -- 'False', while those operating systems themselves do support RPATH. + supportRPaths Linux   = True + supportRPaths Windows = False + supportRPaths OSX   = True + supportRPaths FreeBSD   = + case compid of + CompilerId GHC ver | ver >= mkVersion [7,10,2] -> True + _ -> False + supportRPaths OpenBSD   = False + supportRPaths NetBSD   = False + supportRPaths DragonFly = False + supportRPaths Solaris = False + supportRPaths AIX = False + supportRPaths HPUX = False + supportRPaths IRIX = False + supportRPaths HaLVM = False + supportRPaths IOS = False + supportRPaths Android = False + supportRPaths Ghcjs = False + supportRPaths Wasi = False + supportRPaths Hurd = False + supportRPaths (OtherOS _) = False + -- Do _not_ add a default case so that we get a warning here when a new OS + -- is added. + +getRPaths _ _ = return mempty + +-- | Remove the "-threaded" flag when building a foreign library, as it has no +-- effect when used with "-shared". Returns the updated 'BuildInfo', along +-- with whether or not the flag was present, so we can use it to link against +-- the appropriate RTS on our own. +popThreadedFlag :: BuildInfo -> (BuildInfo, Bool) +popThreadedFlag bi = + ( bi { options = filterHcOptions (/= "-threaded") (options bi) } + , hasThreaded (options bi)) + + where + filterHcOptions :: (String -> Bool) + -> PerCompilerFlavor [String] + -> PerCompilerFlavor [String] + filterHcOptions p (PerCompilerFlavor ghc ghcjs) = + PerCompilerFlavor (filter p ghc) ghcjs + + hasThreaded :: PerCompilerFlavor [String] -> Bool + hasThreaded (PerCompilerFlavor ghc _) = elem "-threaded" ghc + +-- | Extracts a String representing a hash of the ABI of a built +-- library. It can fail if the library has not yet been built. +-- +libAbiHash :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Library -> ComponentLocalBuildInfo -> IO String +libAbiHash verbosity _pkg_descr lbi lib clbi = do + let + libBi = libBuildInfo lib + comp = compiler lbi + platform = hostPlatform lbi + vanillaArgs0 = + (componentGhcOptions verbosity lbi libBi clbi (componentBuildDir lbi clbi)) + `mappend` mempty { + ghcOptMode = toFlag GhcModeAbiHash, + ghcOptInputModules = toNubListR $ exposedModules lib + } + vanillaArgs = + -- Package DBs unnecessary, and break ghc-cabal. See #3633 + -- BUT, put at least the global database so that 7.4 doesn't + -- break. + vanillaArgs0 { ghcOptPackageDBs = [GlobalPackageDB] + , ghcOptPackages = mempty } + sharedArgs = vanillaArgs `mappend` mempty { + ghcOptDynLinkMode = toFlag GhcDynamicOnly, + ghcOptFPic = toFlag True, + ghcOptHiSuffix = toFlag "js_dyn_hi", + ghcOptObjSuffix = toFlag "js_dyn_o", + ghcOptExtra = hcSharedOptions GHC libBi + } + profArgs = vanillaArgs `mappend` mempty { + ghcOptProfilingMode = toFlag True, + ghcOptProfilingAuto = Internal.profDetailLevelFlag True + (withProfLibDetail lbi), + ghcOptHiSuffix = toFlag "js_p_hi", + ghcOptObjSuffix = toFlag "js_p_o", + ghcOptExtra = hcProfOptions GHC libBi + } + ghcArgs + | withVanillaLib lbi = vanillaArgs + | withSharedLib lbi = sharedArgs + | withProfLib lbi = profArgs + | otherwise = error "libAbiHash: Can't find an enabled library way" + + (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi) + hash <- getProgramInvocationOutput verbosity + (ghcInvocation ghcjsProg comp platform ghcArgs) + return (takeWhile (not . isSpace) hash) + +componentGhcOptions :: Verbosity -> LocalBuildInfo + -> BuildInfo -> ComponentLocalBuildInfo -> FilePath + -> GhcOptions +componentGhcOptions verbosity lbi bi clbi odir = + let opts = Internal.componentGhcOptions verbosity implInfo lbi bi clbi odir + comp = compiler lbi + implInfo = getImplInfo comp + in opts { ghcOptExtra = ghcOptExtra opts `mappend` hcOptions GHCJS bi + } + + +componentCcGhcOptions :: Verbosity -> LocalBuildInfo + -> BuildInfo -> ComponentLocalBuildInfo + -> FilePath -> FilePath + -> GhcOptions +componentCcGhcOptions verbosity lbi = + Internal.componentCcGhcOptions verbosity implInfo lbi + where + comp = compiler lbi + implInfo = getImplInfo comp + + +-- ----------------------------------------------------------------------------- +-- Installing + +-- |Install executables for GHCJS. +installExe :: Verbosity + -> LocalBuildInfo + -> FilePath -- ^Where to copy the files to + -> FilePath -- ^Build location + -> (FilePath, FilePath) -- ^Executable (prefix,suffix) + -> PackageDescription + -> Executable + -> IO () +installExe verbosity lbi binDir buildPref + (progprefix, progsuffix) _pkg exe = do + createDirectoryIfMissingVerbose verbosity True binDir + let exeName' = unUnqualComponentName $ exeName exe + exeFileName = exeName' + fixedExeBaseName = progprefix ++ exeName' ++ progsuffix + installBinary dest = do + runDbProgram verbosity ghcjsProgram (withPrograms lbi) $ + [ "--install-executable" + , buildPref exeName' exeFileName + , "-o", dest + ] ++ + case (stripExes lbi, lookupProgram stripProgram $ withPrograms lbi) of + (True, Just strip) -> ["-strip-program", programPath strip] + _ -> [] + installBinary (binDir fixedExeBaseName) + + +-- |Install foreign library for GHC. +installFLib :: Verbosity + -> LocalBuildInfo + -> FilePath -- ^install location + -> FilePath -- ^Build location + -> PackageDescription + -> ForeignLib + -> IO () +installFLib verbosity lbi targetDir builtDir _pkg flib = + install (foreignLibIsShared flib) + builtDir + targetDir + (flibTargetName lbi flib) + where + install _isShared srcDir dstDir name = do + let src = srcDir name + dst = dstDir name + createDirectoryIfMissingVerbose verbosity True targetDir + installOrdinaryFile verbosity src dst + + +-- |Install for ghc, .hi, .a and, if --with-ghci given, .o +installLib :: Verbosity + -> LocalBuildInfo + -> FilePath -- ^install location + -> FilePath -- ^install location for dynamic libraries + -> FilePath -- ^Build location + -> PackageDescription + -> Library + -> ComponentLocalBuildInfo + -> IO () +installLib verbosity lbi targetDir dynlibTargetDir _builtDir _pkg lib clbi = do + whenVanilla $ copyModuleFiles "js_hi" + whenProf $ copyModuleFiles "js_p_hi" + whenShared $ copyModuleFiles "js_dyn_hi" + + -- whenVanilla $ installOrdinary builtDir targetDir $ toJSLibName vanillaLibName + -- whenProf $ installOrdinary builtDir targetDir $ toJSLibName profileLibName + -- whenShared $ installShared builtDir dynlibTargetDir $ toJSLibName sharedLibName + -- fixme do these make the correct lib names? + whenHasCode $ do + whenVanilla $ do + sequence_ [ installOrdinary builtDir' targetDir (toJSLibName $ mkGenericStaticLibName (l ++ f)) + | l <- getHSLibraryName (componentUnitId clbi):(extraBundledLibs (libBuildInfo lib)) + , f <- "":extraLibFlavours (libBuildInfo lib) + ] + -- whenGHCi $ installOrdinary builtDir targetDir (toJSLibName ghciLibName) + whenProf $ do + installOrdinary builtDir' targetDir (toJSLibName profileLibName) + -- whenGHCi $ installOrdinary builtDir targetDir (toJSLibName ghciProfLibName) + whenShared $ + sequence_ [ installShared builtDir' dynlibTargetDir + (toJSLibName $ mkGenericSharedLibName platform compiler_id (l ++ f)) + | l <- getHSLibraryName uid : extraBundledLibs (libBuildInfo lib) + , f <- "":extraDynLibFlavours (libBuildInfo lib) + ] + where + builtDir' = componentBuildDir lbi clbi + + install isShared isJS srcDir dstDir name = do + let src = srcDir name + dst = dstDir name + createDirectoryIfMissingVerbose verbosity True dstDir + + if isShared + then installExecutableFile verbosity src dst + else installOrdinaryFile verbosity src dst + + when (stripLibs lbi && not isJS) $ + Strip.stripLib verbosity + (hostPlatform lbi) (withPrograms lbi) dst + + installOrdinary = install False True + installShared = install True True + + copyModuleFiles ext = + findModuleFilesEx verbosity [builtDir'] [ext] (allLibModules lib clbi) + >>= installOrdinaryFiles verbosity targetDir + + compiler_id = compilerId (compiler lbi) + platform = hostPlatform lbi + uid = componentUnitId clbi + -- vanillaLibName = mkLibName uid + profileLibName = mkProfLibName uid + -- sharedLibName = (mkSharedLibName (hostPlatform lbi) compiler_id) uid + + hasLib = not $ null (allLibModules lib clbi) + && null (cSources (libBuildInfo lib)) + && null (cxxSources (libBuildInfo lib)) + && null (jsSources (libBuildInfo lib)) + has_code = not (componentIsIndefinite clbi) + whenHasCode = when has_code + whenVanilla = when (hasLib && withVanillaLib lbi) + whenProf = when (hasLib && withProfLib lbi && has_code) + -- whenGHCi = when (hasLib && withGHCiLib lbi && has_code) + whenShared = when (hasLib && withSharedLib lbi && has_code) + + +adjustExts :: String -> String -> GhcOptions -> GhcOptions +adjustExts hiSuf objSuf opts = + opts `mappend` mempty { + ghcOptHiSuffix = toFlag hiSuf, + ghcOptObjSuffix = toFlag objSuf + } + +isDynamic :: Compiler -> Bool +isDynamic = Internal.ghcLookupProperty "GHC Dynamic" + +supportsDynamicToo :: Compiler -> Bool +supportsDynamicToo = Internal.ghcLookupProperty "Support dynamic-too" + +withExt :: FilePath -> String -> FilePath +withExt fp ext = fp <.> if takeExtension fp /= ('.':ext) then ext else "" + +findGhcjsGhcVersion :: Verbosity -> FilePath -> IO (Maybe Version) +findGhcjsGhcVersion verbosity pgm = + findProgramVersion "--numeric-ghc-version" id verbosity pgm + +findGhcjsPkgGhcjsVersion :: Verbosity -> FilePath -> IO (Maybe Version) +findGhcjsPkgGhcjsVersion verbosity pgm = + findProgramVersion "--numeric-ghcjs-version" id verbosity pgm + +-- ----------------------------------------------------------------------------- +-- Registering + +hcPkgInfo :: ProgramDb -> HcPkg.HcPkgInfo +hcPkgInfo progdb = HcPkg.HcPkgInfo { HcPkg.hcPkgProgram = ghcjsPkgProg + , HcPkg.noPkgDbStack = False + , HcPkg.noVerboseFlag = False + , HcPkg.flagPackageConf = False + , HcPkg.supportsDirDbs = True + , HcPkg.requiresDirDbs = ver >= v7_10 + , HcPkg.nativeMultiInstance = ver >= v7_10 + , HcPkg.recacheMultiInstance = True + , HcPkg.suppressFilesCheck = True + } + where + v7_10 = mkVersion [7,10] + ghcjsPkgProg = fromMaybe (error "GHCJS.hcPkgInfo no ghcjs program") $ lookupProgram ghcjsPkgProgram progdb + ver = fromMaybe (error "GHCJS.hcPkgInfo no ghcjs version") $ programVersion ghcjsPkgProg + +registerPackage + :: Verbosity + -> ProgramDb + -> PackageDBStack + -> InstalledPackageInfo + -> HcPkg.RegisterOptions + -> IO () +registerPackage verbosity progdb packageDbs installedPkgInfo registerOptions = + HcPkg.register (hcPkgInfo progdb) verbosity packageDbs + installedPkgInfo registerOptions + +pkgRoot :: Verbosity -> LocalBuildInfo -> PackageDB -> IO FilePath +pkgRoot verbosity lbi = pkgRoot' + where + pkgRoot' GlobalPackageDB = + let ghcjsProg = fromMaybe (error "GHCJS.pkgRoot: no ghcjs program") $ lookupProgram ghcjsProgram (withPrograms lbi) + in fmap takeDirectory (getGlobalPackageDB verbosity ghcjsProg) + pkgRoot' UserPackageDB = do + appDir <- getAppUserDataDirectory "ghcjs" + -- fixme correct this version + let ver = compilerVersion (compiler lbi) + subdir = System.Info.arch ++ '-':System.Info.os + ++ '-':prettyShow ver + rootDir = appDir subdir + -- We must create the root directory for the user package database if it + -- does not yet exists. Otherwise '${pkgroot}' will resolve to a + -- directory at the time of 'ghc-pkg register', and registration will + -- fail. + createDirectoryIfMissing True rootDir + return rootDir + pkgRoot' (SpecificPackageDB fp) = return (takeDirectory fp) + + +-- | Get the JavaScript file name and command and arguments to run a +-- program compiled by GHCJS +-- the exe should be the base program name without exe extension +runCmd :: ProgramDb -> FilePath + -> (FilePath, FilePath, [String]) +runCmd progdb exe = + ( script + , programPath ghcjsProg + , programDefaultArgs ghcjsProg ++ programOverrideArgs ghcjsProg ++ ["--run"] + ) + where + script = exe <.> "jsexe" "all" <.> "js" + ghcjsProg = fromMaybe (error "GHCJS.runCmd: no ghcjs program") $ lookupProgram ghcjsProgram progdb diff --git a/cabal/Cabal/src/Distribution/Simple/Glob.hs b/cabal/Cabal/src/Distribution/Simple/Glob.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/Glob.hs @@ -0,0 +1,338 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Glob +-- Copyright : Isaac Jones, Simon Marlow 2003-2004 +-- License : BSD3 +-- portions Copyright (c) 2007, Galois Inc. +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Simple file globbing. + +module Distribution.Simple.Glob ( + GlobSyntaxError(..), + GlobResult(..), + matchDirFileGlob, + matchDirFileGlobWithDie, + runDirFileGlob, + fileGlobMatches, + parseFileGlob, + explainGlobSyntaxError, + Glob, + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.CabalSpecVersion +import Distribution.Simple.Utils +import Distribution.Verbosity + +import System.Directory (getDirectoryContents, doesDirectoryExist, doesFileExist) +import System.FilePath (joinPath, splitExtensions, splitDirectories, takeFileName, (), (<.>)) + +import qualified Data.List.NonEmpty as NE + +-- Note throughout that we use splitDirectories, not splitPath. On +-- Posix, this makes no difference, but, because Windows accepts both +-- slash and backslash as its path separators, if we left in the +-- separators from the glob we might not end up properly normalised. + +data GlobResult a + = GlobMatch a + -- ^ The glob matched the value supplied. + | GlobWarnMultiDot a + -- ^ The glob did not match the value supplied because the + -- cabal-version is too low and the extensions on the file did + -- not precisely match the glob's extensions, but rather the + -- glob was a proper suffix of the file's extensions; i.e., if + -- not for the low cabal-version, it would have matched. + | GlobMissingDirectory FilePath + -- ^ The glob couldn't match because the directory named doesn't + -- exist. The directory will be as it appears in the glob (i.e., + -- relative to the directory passed to 'matchDirFileGlob', and, + -- for 'data-files', relative to 'data-dir'). + deriving (Show, Eq, Ord, Functor) + +-- | Extract the matches from a list of 'GlobResult's. +-- +-- Note: throws away the 'GlobMissingDirectory' results; chances are +-- that you want to check for these and error out if any are present. +globMatches :: [GlobResult a] -> [a] +globMatches input = [ a | GlobMatch a <- input ] + +data GlobSyntaxError + = StarInDirectory + | StarInFileName + | StarInExtension + | NoExtensionOnStar + | EmptyGlob + | LiteralFileNameGlobStar + | VersionDoesNotSupportGlobStar + | VersionDoesNotSupportGlob + deriving (Eq, Show) + +explainGlobSyntaxError :: FilePath -> GlobSyntaxError -> String +explainGlobSyntaxError filepath StarInDirectory = + "invalid file glob '" ++ filepath + ++ "'. A wildcard '**' is only allowed as the final parent" + ++ " directory. Stars must not otherwise appear in the parent" + ++ " directories." +explainGlobSyntaxError filepath StarInExtension = + "invalid file glob '" ++ filepath + ++ "'. Wildcards '*' are only allowed as the" + ++ " file's base name, not in the file extension." +explainGlobSyntaxError filepath StarInFileName = + "invalid file glob '" ++ filepath + ++ "'. Wildcards '*' may only totally replace the" + ++ " file's base name, not only parts of it." +explainGlobSyntaxError filepath NoExtensionOnStar = + "invalid file glob '" ++ filepath + ++ "'. If a wildcard '*' is used it must be with an file extension." +explainGlobSyntaxError filepath LiteralFileNameGlobStar = + "invalid file glob '" ++ filepath + ++ "'. Prior to 'cabal-version: 3.8'" + ++ " if a wildcard '**' is used as a parent directory, the" + ++ " file's base name must be a wildcard '*'." +explainGlobSyntaxError _ EmptyGlob = + "invalid file glob. A glob cannot be the empty string." +explainGlobSyntaxError filepath VersionDoesNotSupportGlobStar = + "invalid file glob '" ++ filepath + ++ "'. Using the double-star syntax requires 'cabal-version: 2.4'" + ++ " or greater. Alternatively, for compatibility with earlier Cabal" + ++ " versions, list the included directories explicitly." +explainGlobSyntaxError filepath VersionDoesNotSupportGlob = + "invalid file glob '" ++ filepath + ++ "'. Using star wildcards requires 'cabal-version: >= 1.6'. " + ++ "Alternatively if you require compatibility with earlier Cabal " + ++ "versions then list all the files explicitly." + +data IsRecursive = Recursive | NonRecursive deriving Eq + +data MultiDot = MultiDotDisabled | MultiDotEnabled + +data Glob + = GlobStem FilePath Glob + -- ^ A single subdirectory component + remainder. + | GlobFinal GlobFinal + +data GlobFinal + = FinalMatch IsRecursive MultiDot String + -- ^ First argument: Is this a @**/*.ext@ pattern? + -- Second argument: should we match against the exact extensions, or accept a suffix? + -- Third argument: the extensions to accept. + | FinalLit IsRecursive FilePath + -- ^ Literal file name. + +reconstructGlob :: Glob -> FilePath +reconstructGlob (GlobStem dir glob) = + dir reconstructGlob glob +reconstructGlob (GlobFinal final) = case final of + FinalMatch Recursive _ exts -> "**" "*" <.> exts + FinalMatch NonRecursive _ exts -> "*" <.> exts + FinalLit Recursive path -> "**" path + FinalLit NonRecursive path -> path + +-- | Returns 'Nothing' if the glob didn't match at all, or 'Just' the +-- result if the glob matched (or would have matched with a higher +-- cabal-version). +fileGlobMatches :: Glob -> FilePath -> Maybe (GlobResult FilePath) +fileGlobMatches pat candidate = do + match <- fileGlobMatchesSegments pat (splitDirectories candidate) + return (candidate <$ match) + +fileGlobMatchesSegments :: Glob -> [FilePath] -> Maybe (GlobResult ()) +fileGlobMatchesSegments _ [] = Nothing +fileGlobMatchesSegments pat (seg : segs) = case pat of + GlobStem dir pat' -> do + guard (dir == seg) + fileGlobMatchesSegments pat' segs + GlobFinal final -> case final of + FinalMatch Recursive multidot ext -> do + let (candidateBase, candidateExts) = splitExtensions (NE.last $ seg:|segs) + guard (not (null candidateBase)) + checkExt multidot ext candidateExts + FinalMatch NonRecursive multidot ext -> do + let (candidateBase, candidateExts) = splitExtensions seg + guard (null segs && not (null candidateBase)) + checkExt multidot ext candidateExts + FinalLit isRecursive filename -> do + guard ((isRecursive == Recursive || null segs) && filename == seg) + return (GlobMatch ()) + +checkExt + :: MultiDot + -> String -- ^ The pattern's extension + -> String -- ^ The candidate file's extension + -> Maybe (GlobResult ()) +checkExt multidot ext candidate + | ext == candidate = Just (GlobMatch ()) + | ext `isSuffixOf` candidate = case multidot of + MultiDotDisabled -> Just (GlobWarnMultiDot ()) + MultiDotEnabled -> Just (GlobMatch ()) + | otherwise = Nothing + +parseFileGlob :: CabalSpecVersion -> FilePath -> Either GlobSyntaxError Glob +parseFileGlob version filepath = case reverse (splitDirectories filepath) of + [] -> + Left EmptyGlob + (filename : "**" : segments) + | allowGlobStar -> do + finalSegment <- case splitExtensions filename of + ("*", ext) | '*' `elem` ext -> Left StarInExtension + | null ext -> Left NoExtensionOnStar + | otherwise -> Right (FinalMatch Recursive multidot ext) + _ -> if allowLiteralFilenameGlobStar + then Right (FinalLit Recursive filename) + else Left LiteralFileNameGlobStar + foldM addStem (GlobFinal finalSegment) segments + | otherwise -> Left VersionDoesNotSupportGlobStar + (filename : segments) -> do + pat <- case splitExtensions filename of + ("*", ext) | not allowGlob -> Left VersionDoesNotSupportGlob + | '*' `elem` ext -> Left StarInExtension + | null ext -> Left NoExtensionOnStar + | otherwise -> Right (FinalMatch NonRecursive multidot ext) + (_, ext) | '*' `elem` ext -> Left StarInExtension + | '*' `elem` filename -> Left StarInFileName + | otherwise -> Right (FinalLit NonRecursive filename) + foldM addStem (GlobFinal pat) segments + where + allowGlob = version >= CabalSpecV1_6 + allowGlobStar = version >= CabalSpecV2_4 + addStem pat seg + | '*' `elem` seg = Left StarInDirectory + | otherwise = Right (GlobStem seg pat) + multidot + | version >= CabalSpecV2_4 = MultiDotEnabled + | otherwise = MultiDotDisabled + allowLiteralFilenameGlobStar = version >= CabalSpecV3_8 + +-- | This will 'die'' when the glob matches no files, or if the glob +-- refers to a missing directory, or if the glob fails to parse. +-- +-- The 'Version' argument must be the spec version of the package +-- description being processed, as globs behave slightly differently +-- in different spec versions. +-- +-- The first 'FilePath' argument is the directory that the glob is +-- relative to. It must be a valid directory (and hence it can't be +-- the empty string). The returned values will not include this +-- prefix. +-- +-- The second 'FilePath' is the glob itself. +-- +matchDirFileGlob :: Verbosity -> CabalSpecVersion -> FilePath -> FilePath -> IO [FilePath] +matchDirFileGlob v = matchDirFileGlobWithDie v die' + +-- | Like 'matchDirFileGlob' but with customizable 'die' +-- +-- @since 3.6.0.0 +-- +matchDirFileGlobWithDie :: Verbosity -> (Verbosity -> String -> IO [FilePath]) -> CabalSpecVersion -> FilePath -> FilePath -> IO [FilePath] +matchDirFileGlobWithDie verbosity rip version dir filepath = case parseFileGlob version filepath of + Left err -> rip verbosity $ explainGlobSyntaxError filepath err + Right glob -> do + results <- runDirFileGlob verbosity dir glob + let missingDirectories = + [ missingDir | GlobMissingDirectory missingDir <- results ] + matches = globMatches results + + let errors :: [String] + errors = + [ "filepath wildcard '" ++ filepath ++ "' refers to the directory" + ++ " '" ++ missingDir ++ "', which does not exist or is not a directory." + | missingDir <- missingDirectories + ] + ++ + [ "filepath wildcard '" ++ filepath ++ "' does not match any files." + | null matches + ] + + if null errors + then return matches + else rip verbosity $ unlines errors + +-- | Match files against a pre-parsed glob, starting in a directory. +-- +-- The 'Version' argument must be the spec version of the package +-- description being processed, as globs behave slightly differently +-- in different spec versions. +-- +-- The 'FilePath' argument is the directory that the glob is relative +-- to. It must be a valid directory (and hence it can't be the empty +-- string). The returned values will not include this prefix. +runDirFileGlob :: Verbosity -> FilePath -> Glob -> IO [GlobResult FilePath] +runDirFileGlob verbosity rawDir pat = do + -- The default data-dir is null. Our callers -should- be + -- converting that to '.' themselves, but it's a certainty that + -- some future call-site will forget and trigger a really + -- hard-to-debug failure if we don't check for that here. + when (null rawDir) $ + warn verbosity $ + "Null dir passed to runDirFileGlob; interpreting it " + ++ "as '.'. This is probably an internal error." + let dir = if null rawDir then "." else rawDir + debug verbosity $ "Expanding glob '" ++ reconstructGlob pat ++ "' in directory '" ++ dir ++ "'." + -- This function might be called from the project root with dir as + -- ".". Walking the tree starting there involves going into .git/ + -- and dist-newstyle/, which is a lot of work for no reward, so + -- extract the constant prefix from the pattern and start walking + -- there, and only walk as much as we need to: recursively if **, + -- the whole directory if *, and just the specific file if it's a + -- literal. + let (prefixSegments, final) = splitConstantPrefix pat + joinedPrefix = joinPath prefixSegments + case final of + FinalMatch recursive multidot exts -> do + let prefix = dir joinedPrefix + directoryExists <- doesDirectoryExist prefix + if directoryExists + then do + candidates <- case recursive of + Recursive -> getDirectoryContentsRecursive prefix + NonRecursive -> filterM (doesFileExist . (prefix )) =<< getDirectoryContents prefix + let checkName candidate = do + let (candidateBase, candidateExts) = splitExtensions $ takeFileName candidate + guard (not (null candidateBase)) + match <- checkExt multidot exts candidateExts + return (joinedPrefix candidate <$ match) + return $ mapMaybe checkName candidates + else + return [ GlobMissingDirectory joinedPrefix ] + FinalLit Recursive fn -> do + let prefix = dir joinedPrefix + directoryExists <- doesDirectoryExist prefix + if directoryExists + then do + candidates <- getDirectoryContentsRecursive prefix + let checkName candidate + | takeFileName candidate == fn = Just $ GlobMatch (joinedPrefix candidate) + | otherwise = Nothing + return $ mapMaybe checkName candidates + else + return [ GlobMissingDirectory joinedPrefix ] + + FinalLit NonRecursive fn -> do + exists <- doesFileExist (dir joinedPrefix fn) + return [ GlobMatch (joinedPrefix fn) | exists ] + +unfoldr' :: (a -> Either r (b, a)) -> a -> ([b], r) +unfoldr' f a = case f a of + Left r -> ([], r) + Right (b, a') -> case unfoldr' f a' of + (bs, r) -> (b : bs, r) + +-- | Extract the (possibly null) constant prefix from the pattern. +-- This has the property that, if @(pref, final) = splitConstantPrefix pat@, +-- then @pat === foldr GlobStem (GlobFinal final) pref@. +splitConstantPrefix :: Glob -> ([FilePath], GlobFinal) +splitConstantPrefix = unfoldr' step + where + step (GlobStem seg pat) = Right (seg, pat) + step (GlobFinal pat) = Left pat diff --git a/cabal/Cabal/src/Distribution/Simple/Haddock.hs b/cabal/Cabal/src/Distribution/Simple/Haddock.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/Haddock.hs @@ -0,0 +1,922 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Haddock +-- Copyright : Isaac Jones 2003-2005 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module deals with the @haddock@ and @hscolour@ commands. +-- It uses information about installed packages (from @ghc-pkg@) to find the +-- locations of documentation for dependent packages, so it can create links. +-- +-- The @hscolour@ support allows generating HTML versions of the original +-- source, with coloured syntax highlighting. + +module Distribution.Simple.Haddock ( + haddock, hscolour, + + haddockPackagePaths + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import qualified Distribution.Simple.GHC as GHC +import qualified Distribution.Simple.GHCJS as GHCJS + +-- local +import Distribution.Backpack.DescribeUnitId +import Distribution.Backpack (OpenModule) +import Distribution.Types.ForeignLib +import Distribution.Types.UnqualComponentName +import Distribution.Types.ComponentLocalBuildInfo +import Distribution.Types.ExecutableScope +import Distribution.Types.LocalBuildInfo +import Distribution.Types.TargetInfo +import Distribution.Types.ExposedModule +import Distribution.Package +import qualified Distribution.ModuleName as ModuleName +import Distribution.PackageDescription +import Distribution.Simple.Compiler +import Distribution.Simple.Glob +import Distribution.Simple.Program.GHC +import Distribution.Simple.Program.ResponseFile +import Distribution.Simple.Program +import Distribution.Simple.PreProcess +import Distribution.Simple.Setup +import Distribution.Simple.Build +import Distribution.Simple.BuildTarget +import Distribution.Simple.InstallDirs +import Distribution.Simple.LocalBuildInfo hiding (substPathTemplate) +import Distribution.Simple.BuildPaths +import Distribution.Simple.Register +import qualified Distribution.Simple.Program.HcPkg as HcPkg +import qualified Distribution.Simple.PackageIndex as PackageIndex +import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo +import Distribution.InstalledPackageInfo ( InstalledPackageInfo ) +import Distribution.Simple.Utils +import Distribution.System +import Distribution.Pretty +import Distribution.Parsec (simpleParsec) +import Distribution.Utils.NubList +import Distribution.Version +import qualified Distribution.Utils.ShortText as ShortText + +import Distribution.Verbosity +import Language.Haskell.Extension + +import Distribution.Compat.Semigroup (All (..), Any (..)) + +import Control.Monad +import Data.Either ( rights ) + +import System.Directory (getCurrentDirectory, doesDirectoryExist, doesFileExist) +import System.FilePath ( (), (<.>), normalise, isAbsolute ) +import System.IO (hClose, hPutStrLn, hSetEncoding, utf8) + +-- ------------------------------------------------------------------------------ +-- Types + +-- | A record that represents the arguments to the haddock executable, a product +-- monoid. +data HaddockArgs = HaddockArgs { + argInterfaceFile :: Flag FilePath, + -- ^ Path to the interface file, relative to argOutputDir, required. + argPackageName :: Flag PackageIdentifier, + -- ^ Package name, required. + argHideModules :: (All,[ModuleName.ModuleName]), + -- ^ (Hide modules ?, modules to hide) + argIgnoreExports :: Any, + -- ^ Ignore export lists in modules? + argLinkSource :: Flag (Template,Template,Template), + -- ^ (Template for modules, template for symbols, template for lines). + argLinkedSource :: Flag Bool, + -- ^ Generate hyperlinked sources + argQuickJump :: Flag Bool, + -- ^ Generate quickjump index + argCssFile :: Flag FilePath, + -- ^ Optional custom CSS file. + argContents :: Flag String, + -- ^ Optional URL to contents page. + argVerbose :: Any, + argOutput :: Flag [Output], + -- ^ HTML or Hoogle doc or both? Required. + argInterfaces :: [(FilePath, Maybe String, Maybe String)], + -- ^ [(Interface file, URL to the HTML docs and hyperlinked-source for links)]. + argOutputDir :: Directory, + -- ^ Where to generate the documentation. + argTitle :: Flag String, + -- ^ Page title, required. + argPrologue :: Flag String, + -- ^ Prologue text, required. + argGhcOptions :: GhcOptions, + -- ^ Additional flags to pass to GHC. + argGhcLibDir :: Flag FilePath, + -- ^ To find the correct GHC, required. + argReexports :: [OpenModule], + -- ^ Re-exported modules + argTargets :: [FilePath] + -- ^ Modules to process. +} deriving Generic + +-- | The FilePath of a directory, it's a monoid under '()'. +newtype Directory = Dir { unDir' :: FilePath } deriving (Read,Show,Eq,Ord) + +unDir :: Directory -> FilePath +unDir = normalise . unDir' + +type Template = String + +data Output = Html | Hoogle + +-- ------------------------------------------------------------------------------ +-- Haddock support + +haddock :: PackageDescription + -> LocalBuildInfo + -> [PPSuffixHandler] + -> HaddockFlags + -> IO () +haddock pkg_descr _ _ haddockFlags + | not (hasLibs pkg_descr) + && not (fromFlag $ haddockExecutables haddockFlags) + && not (fromFlag $ haddockTestSuites haddockFlags) + && not (fromFlag $ haddockBenchmarks haddockFlags) + && not (fromFlag $ haddockForeignLibs haddockFlags) + = + warn (fromFlag $ haddockVerbosity haddockFlags) $ + "No documentation was generated as this package does not contain " + ++ "a library. Perhaps you want to use the --executables, --tests," + ++ " --benchmarks or --foreign-libraries flags." + +haddock pkg_descr lbi suffixes flags' = do + let verbosity = flag haddockVerbosity + comp = compiler lbi + platform = hostPlatform lbi + + quickJmpFlag = haddockQuickJump flags' + flags = case haddockTarget of + ForDevelopment -> flags' + ForHackage -> flags' + { haddockHoogle = Flag True + , haddockHtml = Flag True + , haddockHtmlLocation = Flag (pkg_url ++ "/docs") + , haddockContents = Flag (toPathTemplate pkg_url) + , haddockLinkedSource = Flag True + , haddockQuickJump = Flag True + } + pkg_url = "/package/$pkg-$version" + flag f = fromFlag $ f flags + + tmpFileOpts = defaultTempFileOptions + { optKeepTempFiles = flag haddockKeepTempFiles } + htmlTemplate = fmap toPathTemplate . flagToMaybe . haddockHtmlLocation + $ flags + haddockTarget = + fromFlagOrDefault ForDevelopment (haddockForHackage flags') + + (haddockProg, version, _) <- + requireProgramVersion verbosity haddockProgram + (orLaterVersion (mkVersion [2,0])) (withPrograms lbi) + + -- various sanity checks + when (flag haddockHoogle && version < mkVersion [2,2]) $ + die' verbosity "Haddock 2.0 and 2.1 do not support the --hoogle flag." + + + when (flag haddockQuickJump && version < mkVersion [2,19]) $ do + let msg = "Haddock prior to 2.19 does not support the --quickjump flag." + alt = "The generated documentation won't have the QuickJump feature." + if Flag True == quickJmpFlag + then die' verbosity msg + else warn verbosity (msg ++ "\n" ++ alt) + + haddockGhcVersionStr <- getProgramOutput verbosity haddockProg + ["--ghc-version"] + case (simpleParsec haddockGhcVersionStr, compilerCompatVersion GHC comp) of + (Nothing, _) -> die' verbosity "Could not get GHC version from Haddock" + (_, Nothing) -> die' verbosity "Could not get GHC version from compiler" + (Just haddockGhcVersion, Just ghcVersion) + | haddockGhcVersion == ghcVersion -> return () + | otherwise -> die' verbosity $ + "Haddock's internal GHC version must match the configured " + ++ "GHC version.\n" + ++ "The GHC version is " ++ prettyShow ghcVersion ++ " but " + ++ "haddock is using GHC version " ++ prettyShow haddockGhcVersion + + -- the tools match the requests, we can proceed + + -- We fall back to using HsColour only for versions of Haddock which don't + -- support '--hyperlinked-sources'. + when (flag haddockLinkedSource && version < mkVersion [2,17]) $ + hscolour' (warn verbosity) haddockTarget pkg_descr lbi suffixes + (defaultHscolourFlags `mappend` haddockToHscolour flags) + + libdirArgs <- getGhcLibDir verbosity lbi + let commonArgs = mconcat + [ libdirArgs + , fromFlags (haddockTemplateEnv lbi (packageId pkg_descr)) flags + , fromPackageDescription haddockTarget pkg_descr ] + + targets <- readTargetInfos verbosity pkg_descr lbi (haddockArgs flags) + + let + targets' = + case targets of + [] -> allTargetsInBuildOrder' pkg_descr lbi + _ -> targets + + internalPackageDB <- + createInternalPackageDB verbosity lbi (flag haddockDistPref) + + (\f -> foldM_ f (installedPkgs lbi) targets') $ \index target -> do + + let component = targetComponent target + clbi = targetCLBI target + + componentInitialBuildSteps (flag haddockDistPref) pkg_descr lbi clbi verbosity + + let + lbi' = lbi { + withPackageDB = withPackageDB lbi ++ [internalPackageDB], + installedPkgs = index + } + + preprocessComponent pkg_descr component lbi' clbi False verbosity suffixes + let + doExe com = case (compToExe com) of + Just exe -> do + withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi') "tmp" $ + \tmp -> do + exeArgs <- fromExecutable verbosity tmp lbi' clbi htmlTemplate + version exe + let exeArgs' = commonArgs `mappend` exeArgs + runHaddock verbosity tmpFileOpts comp platform + haddockProg exeArgs' + Nothing -> do + warn (fromFlag $ haddockVerbosity flags) + "Unsupported component, skipping..." + return () + -- We define 'smsg' once and then reuse it inside the case, so that + -- we don't say we are running Haddock when we actually aren't + -- (e.g., Haddock is not run on non-libraries) + smsg :: IO () + smsg = setupMessage' verbosity "Running Haddock on" (packageId pkg_descr) + (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) + case component of + CLib lib -> do + withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $ + \tmp -> do + smsg + libArgs <- fromLibrary verbosity tmp lbi' clbi htmlTemplate + version lib + let libArgs' = commonArgs `mappend` libArgs + runHaddock verbosity tmpFileOpts comp platform haddockProg libArgs' + + pwd <- getCurrentDirectory + + let + ipi = inplaceInstalledPackageInfo + pwd (flag haddockDistPref) pkg_descr + (mkAbiHash "inplace") lib lbi' clbi + + debug verbosity $ "Registering inplace:\n" + ++ (InstalledPackageInfo.showInstalledPackageInfo ipi) + + registerPackage verbosity (compiler lbi') (withPrograms lbi') + (withPackageDB lbi') ipi + HcPkg.defaultRegisterOptions { + HcPkg.registerMultiInstance = True + } + + return $ PackageIndex.insert ipi index + + CFLib flib -> (when (flag haddockForeignLibs) $ do + withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi') "tmp" $ + \tmp -> do + smsg + flibArgs <- fromForeignLib verbosity tmp lbi' clbi htmlTemplate + version flib + let libArgs' = commonArgs `mappend` flibArgs + runHaddock verbosity tmpFileOpts comp platform haddockProg libArgs') + + >> return index + + CExe _ -> (when (flag haddockExecutables) $ smsg >> doExe component) >> return index + CTest _ -> (when (flag haddockTestSuites) $ smsg >> doExe component) >> return index + CBench _ -> (when (flag haddockBenchmarks) $ smsg >> doExe component) >> return index + + for_ (extraDocFiles pkg_descr) $ \ fpath -> do + files <- matchDirFileGlob verbosity (specVersion pkg_descr) "." fpath + for_ files $ copyFileTo verbosity (unDir $ argOutputDir commonArgs) + +-- ------------------------------------------------------------------------------ +-- Contributions to HaddockArgs (see also Doctest.hs for very similar code). + +fromFlags :: PathTemplateEnv -> HaddockFlags -> HaddockArgs +fromFlags env flags = + mempty { + argHideModules = (maybe mempty (All . not) + $ flagToMaybe (haddockInternal flags), mempty), + argLinkSource = if fromFlag (haddockLinkedSource flags) + then Flag ("src/%{MODULE/./-}.html" + ,"src/%{MODULE/./-}.html#%{NAME}" + ,"src/%{MODULE/./-}.html#line-%{LINE}") + else NoFlag, + argLinkedSource = haddockLinkedSource flags, + argQuickJump = haddockQuickJump flags, + argCssFile = haddockCss flags, + argContents = fmap (fromPathTemplate . substPathTemplate env) + (haddockContents flags), + argVerbose = maybe mempty (Any . (>= deafening)) + . flagToMaybe $ haddockVerbosity flags, + argOutput = + Flag $ case [ Html | Flag True <- [haddockHtml flags] ] ++ + [ Hoogle | Flag True <- [haddockHoogle flags] ] + of [] -> [ Html ] + os -> os, + argOutputDir = maybe mempty Dir . flagToMaybe $ haddockDistPref flags, + + argGhcOptions = mempty { ghcOptExtra = ghcArgs } + } + where + ghcArgs = fromMaybe [] . lookup "ghc" . haddockProgramArgs $ flags + +fromPackageDescription :: HaddockTarget -> PackageDescription -> HaddockArgs +fromPackageDescription haddockTarget pkg_descr = mempty + { argInterfaceFile = Flag $ haddockName pkg_descr + , argPackageName = Flag $ packageId $ pkg_descr + , argOutputDir = Dir $ + "doc" "html" haddockDirName haddockTarget pkg_descr + , argPrologue = Flag $ ShortText.fromShortText $ + if ShortText.null desc + then synopsis pkg_descr + else desc + , argTitle = Flag $ showPkg ++ subtitle + } + where + desc = description pkg_descr + showPkg = prettyShow (packageId pkg_descr) + subtitle + | ShortText.null (synopsis pkg_descr) = "" + | otherwise = ": " ++ ShortText.fromShortText (synopsis pkg_descr) + +componentGhcOptions :: Verbosity -> LocalBuildInfo + -> BuildInfo -> ComponentLocalBuildInfo -> FilePath + -> GhcOptions +componentGhcOptions verbosity lbi bi clbi odir = + let f = case compilerFlavor (compiler lbi) of + GHC -> GHC.componentGhcOptions + GHCJS -> GHCJS.componentGhcOptions + _ -> error $ + "Distribution.Simple.Haddock.componentGhcOptions:" ++ + "haddock only supports GHC and GHCJS" + in f verbosity lbi bi clbi odir + +mkHaddockArgs :: Verbosity + -> FilePath + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Maybe PathTemplate -- ^ template for HTML location + -> Version + -> [FilePath] + -> BuildInfo + -> IO HaddockArgs +mkHaddockArgs verbosity tmp lbi clbi htmlTemplate haddockVersion inFiles bi = do + ifaceArgs <- getInterfaces verbosity lbi clbi htmlTemplate + let vanillaOpts = (componentGhcOptions normal lbi bi clbi (buildDir lbi)) { + -- Noooooooooo!!!!!111 + -- haddock stomps on our precious .hi + -- and .o files. Workaround by telling + -- haddock to write them elsewhere. + ghcOptObjDir = toFlag tmp, + ghcOptHiDir = toFlag tmp, + ghcOptStubDir = toFlag tmp + } `mappend` getGhcCppOpts haddockVersion bi + sharedOpts = vanillaOpts { + ghcOptDynLinkMode = toFlag GhcDynamicOnly, + ghcOptFPic = toFlag True, + ghcOptHiSuffix = toFlag "dyn_hi", + ghcOptObjSuffix = toFlag "dyn_o", + ghcOptExtra = hcSharedOptions GHC bi + + } + opts <- if withVanillaLib lbi + then return vanillaOpts + else if withSharedLib lbi + then return sharedOpts + else die' verbosity $ "Must have vanilla or shared libraries " + ++ "enabled in order to run haddock" + + return ifaceArgs + { argGhcOptions = opts + , argTargets = inFiles + , argReexports = getReexports clbi + } + +fromLibrary :: Verbosity + -> FilePath + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Maybe PathTemplate -- ^ template for HTML location + -> Version + -> Library + -> IO HaddockArgs +fromLibrary verbosity tmp lbi clbi htmlTemplate haddockVersion lib = do + inFiles <- map snd `fmap` getLibSourceFiles verbosity lbi lib clbi + args <- mkHaddockArgs verbosity tmp lbi clbi htmlTemplate haddockVersion + inFiles (libBuildInfo lib) + return args { + argHideModules = (mempty, otherModules (libBuildInfo lib)) + } + +fromExecutable :: Verbosity + -> FilePath + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Maybe PathTemplate -- ^ template for HTML location + -> Version + -> Executable + -> IO HaddockArgs +fromExecutable verbosity tmp lbi clbi htmlTemplate haddockVersion exe = do + inFiles <- map snd `fmap` getExeSourceFiles verbosity lbi exe clbi + args <- mkHaddockArgs verbosity tmp lbi clbi htmlTemplate + haddockVersion inFiles (buildInfo exe) + return args { + argOutputDir = Dir $ unUnqualComponentName $ exeName exe, + argTitle = Flag $ unUnqualComponentName $ exeName exe + } + +fromForeignLib :: Verbosity + -> FilePath + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Maybe PathTemplate -- ^ template for HTML location + -> Version + -> ForeignLib + -> IO HaddockArgs +fromForeignLib verbosity tmp lbi clbi htmlTemplate haddockVersion flib = do + inFiles <- map snd `fmap` getFLibSourceFiles verbosity lbi flib clbi + args <- mkHaddockArgs verbosity tmp lbi clbi htmlTemplate + haddockVersion inFiles (foreignLibBuildInfo flib) + return args { + argOutputDir = Dir $ unUnqualComponentName $ foreignLibName flib, + argTitle = Flag $ unUnqualComponentName $ foreignLibName flib + } + +compToExe :: Component -> Maybe Executable +compToExe comp = + case comp of + CTest test@TestSuite { testInterface = TestSuiteExeV10 _ f } -> + Just Executable { + exeName = testName test, + modulePath = f, + exeScope = ExecutablePublic, + buildInfo = testBuildInfo test + } + CBench bench@Benchmark { benchmarkInterface = BenchmarkExeV10 _ f } -> + Just Executable { + exeName = benchmarkName bench, + modulePath = f, + exeScope = ExecutablePublic, + buildInfo = benchmarkBuildInfo bench + } + CExe exe -> Just exe + _ -> Nothing + +getInterfaces :: Verbosity + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Maybe PathTemplate -- ^ template for HTML location + -> IO HaddockArgs +getInterfaces verbosity lbi clbi htmlTemplate = do + (packageFlags, warnings) <- haddockPackageFlags verbosity lbi clbi htmlTemplate + traverse_ (warn (verboseUnmarkOutput verbosity)) warnings + return $ mempty { + argInterfaces = packageFlags + } + +getReexports :: ComponentLocalBuildInfo -> [OpenModule] +getReexports LibComponentLocalBuildInfo {componentExposedModules = mods } = + mapMaybe exposedReexport mods +getReexports _ = [] + +getGhcCppOpts :: Version + -> BuildInfo + -> GhcOptions +getGhcCppOpts haddockVersion bi = + mempty { + ghcOptExtensions = toNubListR [EnableExtension CPP | needsCpp], + ghcOptCppOptions = defines + } + where + needsCpp = EnableExtension CPP `elem` usedExtensions bi + defines = [haddockVersionMacro] + haddockVersionMacro = "-D__HADDOCK_VERSION__=" + ++ show (v1 * 1000 + v2 * 10 + v3) + where + (v1, v2, v3) = case versionNumbers haddockVersion of + [] -> (0,0,0) + [x] -> (x,0,0) + [x,y] -> (x,y,0) + (x:y:z:_) -> (x,y,z) + +getGhcLibDir :: Verbosity -> LocalBuildInfo + -> IO HaddockArgs +getGhcLibDir verbosity lbi = do + l <- case compilerFlavor (compiler lbi) of + GHC -> GHC.getLibDir verbosity lbi + GHCJS -> GHCJS.getLibDir verbosity lbi + _ -> error "haddock only supports GHC and GHCJS" + return $ mempty { argGhcLibDir = Flag l } + +-- ------------------------------------------------------------------------------ +-- | Call haddock with the specified arguments. +runHaddock :: Verbosity + -> TempFileOptions + -> Compiler + -> Platform + -> ConfiguredProgram + -> HaddockArgs + -> IO () +runHaddock verbosity tmpFileOpts comp platform haddockProg args + | null (argTargets args) = warn verbosity $ + "Haddocks are being requested, but there aren't any modules given " + ++ "to create documentation for." + | otherwise = do + let haddockVersion = fromMaybe (error "unable to determine haddock version") + (programVersion haddockProg) + renderArgs verbosity tmpFileOpts haddockVersion comp platform args $ + \(flags,result)-> do + + runProgram verbosity haddockProg flags + + notice verbosity $ "Documentation created: " ++ result + + +renderArgs :: Verbosity + -> TempFileOptions + -> Version + -> Compiler + -> Platform + -> HaddockArgs + -> (([String], FilePath) -> IO a) + -> IO a +renderArgs verbosity tmpFileOpts version comp platform args k = do + let haddockSupportsUTF8 = version >= mkVersion [2,14,4] + haddockSupportsResponseFiles = version > mkVersion [2,16,2] + createDirectoryIfMissingVerbose verbosity True outputDir + withTempFileEx tmpFileOpts outputDir "haddock-prologue.txt" $ + \prologueFileName h -> do + do + when haddockSupportsUTF8 (hSetEncoding h utf8) + hPutStrLn h $ fromFlag $ argPrologue args + hClose h + let pflag = "--prologue=" ++ prologueFileName + renderedArgs = pflag : renderPureArgs version comp platform args + if haddockSupportsResponseFiles + then + withResponseFile + verbosity + tmpFileOpts + outputDir + "haddock-response.txt" + (if haddockSupportsUTF8 then Just utf8 else Nothing) + renderedArgs + (\responseFileName -> k (["@" ++ responseFileName], result)) + else + k (renderedArgs, result) + where + outputDir = (unDir $ argOutputDir args) + result = intercalate ", " + . map (\o -> outputDir + case o of + Html -> "index.html" + Hoogle -> pkgstr <.> "txt") + $ arg argOutput + where + pkgstr = prettyShow $ packageName pkgid + pkgid = arg argPackageName + arg f = fromFlag $ f args + +renderPureArgs :: Version -> Compiler -> Platform -> HaddockArgs -> [String] +renderPureArgs version comp platform args = concat + [ (:[]) . (\f -> "--dump-interface="++ unDir (argOutputDir args) f) + . fromFlag . argInterfaceFile $ args + + , if isVersion 2 16 + then (\pkg -> [ "--package-name=" ++ prettyShow (pkgName pkg) + , "--package-version=" ++ prettyShow (pkgVersion pkg) + ]) + . fromFlag . argPackageName $ args + else [] + + , [ "--since-qual=external" | isVersion 2 20 ] + + , [ "--quickjump" | isVersion 2 19 + , fromFlag . argQuickJump $ args ] + + , [ "--hyperlinked-source" | isVersion 2 17 + , fromFlag . argLinkedSource $ args ] + + , (\(All b,xs) -> bool (map (("--hide=" ++) . prettyShow) xs) [] b) + . argHideModules $ args + + , bool ["--ignore-all-exports"] [] . getAny . argIgnoreExports $ args + + , maybe [] (\(m,e,l) -> + ["--source-module=" ++ m + ,"--source-entity=" ++ e] + ++ if isVersion 2 14 then ["--source-entity-line=" ++ l] + else [] + ) . flagToMaybe . argLinkSource $ args + + , maybe [] ((:[]) . ("--css="++)) . flagToMaybe . argCssFile $ args + + , maybe [] ((:[]) . ("--use-contents="++)) . flagToMaybe . argContents $ args + + , bool [] [verbosityFlag] . getAny . argVerbose $ args + + , map (\o -> case o of Hoogle -> "--hoogle"; Html -> "--html") + . fromFlag . argOutput $ args + + , renderInterfaces . argInterfaces $ args + + , (:[]) . ("--odir="++) . unDir . argOutputDir $ args + + , (:[]) . ("--title="++) + . (bool (++" (internal documentation)") + id (getAny $ argIgnoreExports args)) + . fromFlag . argTitle $ args + + , [ "--optghc=" ++ opt | let opts = argGhcOptions args + , opt <- renderGhcOptions comp platform opts ] + + , maybe [] (\l -> ["-B"++l]) $ + flagToMaybe (argGhcLibDir args) -- error if Nothing? + + -- https://github.com/haskell/haddock/pull/547 + , [ "--reexport=" ++ prettyShow r + | r <- argReexports args + , isVersion 2 19 + ] + + , argTargets $ args + ] + where + renderInterfaces = map renderInterface + + renderInterface :: (FilePath, Maybe FilePath, Maybe FilePath) -> String + renderInterface (i, html, hypsrc) = "--read-interface=" ++ + (intercalate "," $ concat [ [ x | Just x <- [html] ] + , [ x | Just _ <- [html] + -- only render hypsrc path if html path + -- is given and hyperlinked-source is + -- enabled + , Just x <- [hypsrc] + , isVersion 2 17 + , fromFlag . argLinkedSource $ args + ] + , [ i ] + ]) + + bool a b c = if c then a else b + isVersion major minor = version >= mkVersion [major,minor] + verbosityFlag + | isVersion 2 5 = "--verbosity=1" + | otherwise = "--verbose" + +--------------------------------------------------------------------------------- + +-- | Given a list of 'InstalledPackageInfo's, return a list of interfaces and +-- HTML paths, and an optional warning for packages with missing documentation. +haddockPackagePaths :: [InstalledPackageInfo] + -> Maybe (InstalledPackageInfo -> FilePath) + -> IO ([( FilePath -- path to interface + -- file + + , Maybe FilePath -- url to html + -- documentation + + , Maybe FilePath -- url to hyperlinked + -- source + )] + , Maybe String -- warning about + -- missing documentation + ) +haddockPackagePaths ipkgs mkHtmlPath = do + interfaces <- sequenceA + [ case interfaceAndHtmlPath ipkg of + Nothing -> return (Left (packageId ipkg)) + Just (interface, html) -> do + + (html', hypsrc') <- + case html of + Just htmlPath -> do + let hypSrcPath = htmlPath defaultHyperlinkedSourceDirectory + hypSrcExists <- doesDirectoryExist hypSrcPath + return $ ( Just (fixFileUrl htmlPath) + , if hypSrcExists + then Just (fixFileUrl hypSrcPath) + else Nothing + ) + Nothing -> return (Nothing, Nothing) + + exists <- doesFileExist interface + if exists + then return (Right (interface, html', hypsrc')) + else return (Left pkgid) + | ipkg <- ipkgs, let pkgid = packageId ipkg + , pkgName pkgid `notElem` noHaddockWhitelist + ] + + let missing = [ pkgid | Left pkgid <- interfaces ] + warning = "The documentation for the following packages are not " + ++ "installed. No links will be generated to these packages: " + ++ intercalate ", " (map prettyShow missing) + flags = rights interfaces + + return (flags, if null missing then Nothing else Just warning) + + where + -- Don't warn about missing documentation for these packages. See #1231. + noHaddockWhitelist = map mkPackageName [ "rts" ] + + -- Actually extract interface and HTML paths from an 'InstalledPackageInfo'. + interfaceAndHtmlPath :: InstalledPackageInfo + -> Maybe (FilePath, Maybe FilePath) + interfaceAndHtmlPath pkg = do + interface <- listToMaybe (InstalledPackageInfo.haddockInterfaces pkg) + html <- case mkHtmlPath of + Nothing -> listToMaybe (InstalledPackageInfo.haddockHTMLs pkg) + Just mkPath -> Just (mkPath pkg) + return (interface, if null html then Nothing else Just html) + + -- The 'haddock-html' field in the hc-pkg output is often set as a + -- native path, but we need it as a URL. See #1064. Also don't "fix" + -- the path if it is an interpolated one. + fixFileUrl f | Nothing <- mkHtmlPath + , isAbsolute f = "file://" ++ f + | otherwise = f + + -- 'src' is the default hyperlinked source directory ever since. It is + -- not possible to configure that directory in any way in haddock. + defaultHyperlinkedSourceDirectory = "src" + + +haddockPackageFlags :: Verbosity + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Maybe PathTemplate + -> IO ([( FilePath -- path to interface + -- file + + , Maybe FilePath -- url to html + -- documentation + + , Maybe FilePath -- url to hyperlinked + -- source + )] + , Maybe String -- warning about + -- missing documentation + ) +haddockPackageFlags verbosity lbi clbi htmlTemplate = do + let allPkgs = installedPkgs lbi + directDeps = map fst (componentPackageDeps clbi) + transitiveDeps <- case PackageIndex.dependencyClosure allPkgs directDeps of + Left x -> return x + Right inf -> die' verbosity $ "internal error when calculating transitive " + ++ "package dependencies.\nDebug info: " ++ show inf + haddockPackagePaths (PackageIndex.allPackages transitiveDeps) mkHtmlPath + where + mkHtmlPath = fmap expandTemplateVars htmlTemplate + expandTemplateVars tmpl pkg = + fromPathTemplate . substPathTemplate (env pkg) $ tmpl + env pkg = haddockTemplateEnv lbi (packageId pkg) + + +haddockTemplateEnv :: LocalBuildInfo -> PackageIdentifier -> PathTemplateEnv +haddockTemplateEnv lbi pkg_id = + (PrefixVar, prefix (installDirTemplates lbi)) + -- We want the legacy unit ID here, because it gives us nice paths + -- (Haddock people don't care about the dependencies) + : initialPathTemplateEnv + pkg_id + (mkLegacyUnitId pkg_id) + (compilerInfo (compiler lbi)) + (hostPlatform lbi) + +-- ------------------------------------------------------------------------------ +-- hscolour support. + +hscolour :: PackageDescription + -> LocalBuildInfo + -> [PPSuffixHandler] + -> HscolourFlags + -> IO () +hscolour = hscolour' dieNoVerbosity ForDevelopment + +hscolour' :: (String -> IO ()) -- ^ Called when the 'hscolour' exe is not found. + -> HaddockTarget + -> PackageDescription + -> LocalBuildInfo + -> [PPSuffixHandler] + -> HscolourFlags + -> IO () +hscolour' onNoHsColour haddockTarget pkg_descr lbi suffixes flags = + either onNoHsColour (\(hscolourProg, _, _) -> go hscolourProg) =<< + lookupProgramVersion verbosity hscolourProgram + (orLaterVersion (mkVersion [1,8])) (withPrograms lbi) + where + go :: ConfiguredProgram -> IO () + go hscolourProg = do + warn verbosity $ + "the 'cabal hscolour' command is deprecated in favour of 'cabal " ++ + "haddock --hyperlink-source' and will be removed in the next major " ++ + "release." + + setupMessage verbosity "Running hscolour for" (packageId pkg_descr) + createDirectoryIfMissingVerbose verbosity True $ + hscolourPref haddockTarget distPref pkg_descr + + withAllComponentsInBuildOrder pkg_descr lbi $ \comp clbi -> do + componentInitialBuildSteps distPref pkg_descr lbi clbi verbosity + preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes + let + doExe com = case (compToExe com) of + Just exe -> do + let outputDir = hscolourPref haddockTarget distPref pkg_descr + unUnqualComponentName (exeName exe) "src" + runHsColour hscolourProg outputDir =<< getExeSourceFiles verbosity lbi exe clbi + Nothing -> do + warn (fromFlag $ hscolourVerbosity flags) + "Unsupported component, skipping..." + return () + case comp of + CLib lib -> do + let outputDir = hscolourPref haddockTarget distPref pkg_descr "src" + runHsColour hscolourProg outputDir =<< getLibSourceFiles verbosity lbi lib clbi + CFLib flib -> do + let outputDir = hscolourPref haddockTarget distPref pkg_descr + unUnqualComponentName (foreignLibName flib) "src" + runHsColour hscolourProg outputDir =<< getFLibSourceFiles verbosity lbi flib clbi + CExe _ -> when (fromFlag (hscolourExecutables flags)) $ doExe comp + CTest _ -> when (fromFlag (hscolourTestSuites flags)) $ doExe comp + CBench _ -> when (fromFlag (hscolourBenchmarks flags)) $ doExe comp + + stylesheet = flagToMaybe (hscolourCSS flags) + + verbosity = fromFlag (hscolourVerbosity flags) + distPref = fromFlag (hscolourDistPref flags) + + runHsColour prog outputDir moduleFiles = do + createDirectoryIfMissingVerbose verbosity True outputDir + + case stylesheet of -- copy the CSS file + Nothing | programVersion prog >= Just (mkVersion [1,9]) -> + runProgram verbosity prog + ["-print-css", "-o" ++ outputDir "hscolour.css"] + | otherwise -> return () + Just s -> copyFileVerbose verbosity s (outputDir "hscolour.css") + + for_ moduleFiles $ \(m, inFile) -> + runProgram verbosity prog + ["-css", "-anchor", "-o" ++ outFile m, inFile] + where + outFile m = outputDir + intercalate "-" (ModuleName.components m) <.> "html" + +haddockToHscolour :: HaddockFlags -> HscolourFlags +haddockToHscolour flags = + HscolourFlags { + hscolourCSS = haddockHscolourCss flags, + hscolourExecutables = haddockExecutables flags, + hscolourTestSuites = haddockTestSuites flags, + hscolourBenchmarks = haddockBenchmarks flags, + hscolourForeignLibs = haddockForeignLibs flags, + hscolourVerbosity = haddockVerbosity flags, + hscolourDistPref = haddockDistPref flags, + hscolourCabalFilePath = haddockCabalFilePath flags + } + +-- ------------------------------------------------------------------------------ +-- Boilerplate Monoid instance. +instance Monoid HaddockArgs where + mempty = gmempty + mappend = (<>) + +instance Semigroup HaddockArgs where + (<>) = gmappend + +instance Monoid Directory where + mempty = Dir "." + mappend = (<>) + +instance Semigroup Directory where + Dir m <> Dir n = Dir $ m n diff --git a/cabal/Cabal/src/Distribution/Simple/HaskellSuite.hs b/cabal/Cabal/src/Distribution/Simple/HaskellSuite.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/HaskellSuite.hs @@ -0,0 +1,228 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +module Distribution.Simple.HaskellSuite where + +import Prelude () +import Distribution.Compat.Prelude + +import qualified Data.List.NonEmpty as NE + +import Distribution.Simple.Program +import Distribution.Simple.Compiler +import Distribution.Simple.Utils +import Distribution.Simple.BuildPaths +import Distribution.Verbosity +import Distribution.Version +import Distribution.Pretty +import Distribution.Parsec (simpleParsec) +import Distribution.Package +import Distribution.InstalledPackageInfo hiding (includeDirs) +import Distribution.Simple.PackageIndex as PackageIndex +import Distribution.PackageDescription +import Distribution.Simple.LocalBuildInfo +import Distribution.System (Platform) +import Distribution.Utils.Path +import Language.Haskell.Extension +import Distribution.Simple.Program.Builtin + +configure + :: Verbosity -> Maybe FilePath -> Maybe FilePath + -> ProgramDb -> IO (Compiler, Maybe Platform, ProgramDb) +configure verbosity mbHcPath hcPkgPath progdb0 = do + + -- We have no idea how a haskell-suite tool is named, so we require at + -- least some information from the user. + hcPath <- + let msg = "You have to provide name or path of a haskell-suite tool (-w PATH)" + in maybe (die' verbosity msg) return mbHcPath + + when (isJust hcPkgPath) $ + warn verbosity "--with-hc-pkg option is ignored for haskell-suite" + + (comp, confdCompiler, progdb1) <- configureCompiler hcPath progdb0 + + -- Update our pkg tool. It uses the same executable as the compiler, but + -- all command start with "pkg" + (confdPkg, _) <- requireProgram verbosity haskellSuitePkgProgram progdb1 + let progdb2 = + updateProgram + confdPkg + { programLocation = programLocation confdCompiler + , programDefaultArgs = ["pkg"] + } + progdb1 + + return (comp, Nothing, progdb2) + + where + configureCompiler hcPath progdb0' = do + let + haskellSuiteProgram' = + haskellSuiteProgram + { programFindLocation = \v p -> findProgramOnSearchPath v p hcPath } + + -- NB: cannot call requireProgram right away — it'd think that + -- the program is already configured and won't reconfigure it again. + -- Instead, call configureProgram directly first. + progdb1 <- configureProgram verbosity haskellSuiteProgram' progdb0' + (confdCompiler, progdb2) <- requireProgram verbosity haskellSuiteProgram' progdb1 + + extensions <- getExtensions verbosity confdCompiler + languages <- getLanguages verbosity confdCompiler + (compName, compVersion) <- + getCompilerVersion verbosity confdCompiler + + let + comp = Compiler { + compilerId = CompilerId (HaskellSuite compName) compVersion, + compilerAbiTag = NoAbiTag, + compilerCompat = [], + compilerLanguages = languages, + compilerExtensions = extensions, + compilerProperties = mempty + } + + return (comp, confdCompiler, progdb2) + +hstoolVersion :: Verbosity -> FilePath -> IO (Maybe Version) +hstoolVersion = findProgramVersion "--hspkg-version" id + +numericVersion :: Verbosity -> FilePath -> IO (Maybe Version) +numericVersion = findProgramVersion "--compiler-version" (fromMaybe "" . safeLast . words) + +getCompilerVersion :: Verbosity -> ConfiguredProgram -> IO (String, Version) +getCompilerVersion verbosity prog = do + output <- rawSystemStdout verbosity (programPath prog) ["--compiler-version"] + let + parts = words output + name = concat $ safeInit parts -- there shouldn't be any spaces in the name anyway + versionStr = fromMaybe "" $ safeLast parts + version <- + maybe (die' verbosity "haskell-suite: couldn't determine compiler version") return $ + simpleParsec versionStr + return (name, version) + +getExtensions :: Verbosity -> ConfiguredProgram -> IO [(Extension, Maybe CompilerFlag)] +getExtensions verbosity prog = do + extStrs <- + lines `fmap` + rawSystemStdout verbosity (programPath prog) ["--supported-extensions"] + return + [ (ext, Just $ "-X" ++ prettyShow ext) | Just ext <- map simpleParsec extStrs ] + +getLanguages :: Verbosity -> ConfiguredProgram -> IO [(Language, CompilerFlag)] +getLanguages verbosity prog = do + langStrs <- + lines `fmap` + rawSystemStdout verbosity (programPath prog) ["--supported-languages"] + return + [ (ext, "-G" ++ prettyShow ext) | Just ext <- map simpleParsec langStrs ] + +-- Other compilers do some kind of a packagedb stack check here. Not sure +-- if we need something like that as well. +getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramDb + -> IO InstalledPackageIndex +getInstalledPackages verbosity packagedbs progdb = + liftM (PackageIndex.fromList . concat) $ for packagedbs $ \packagedb -> + do str <- + getDbProgramOutput verbosity haskellSuitePkgProgram progdb + ["dump", packageDbOpt packagedb] + `catchExit` \_ -> die' verbosity $ "pkg dump failed" + case parsePackages str of + Right ok -> return ok + _ -> die' verbosity "failed to parse output of 'pkg dump'" + + where + parsePackages str = + case partitionEithers $ map (parseInstalledPackageInfo . toUTF8BS) (splitPkgs str) of + ([], ok) -> Right [ pkg | (_, pkg) <- ok ] + (msgss, _) -> Left (foldMap NE.toList msgss) + + splitPkgs :: String -> [String] + splitPkgs = map unlines . splitWith ("---" ==) . lines + where + splitWith :: (a -> Bool) -> [a] -> [[a]] + splitWith p xs = ys : case zs of + [] -> [] + _:ws -> splitWith p ws + where (ys,zs) = break p xs + +buildLib + :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Library -> ComponentLocalBuildInfo -> IO () +buildLib verbosity pkg_descr lbi lib clbi = do + -- In future, there should be a mechanism for the compiler to request any + -- number of the above parameters (or their parts) — in particular, + -- pieces of PackageDescription. + -- + -- For now, we only pass those that we know are used. + + let odir = buildDir lbi + bi = libBuildInfo lib + srcDirs = map getSymbolicPath (hsSourceDirs bi) ++ [odir] + dbStack = withPackageDB lbi + language = fromMaybe Haskell98 (defaultLanguage bi) + progdb = withPrograms lbi + pkgid = packageId pkg_descr + + runDbProgram verbosity haskellSuiteProgram progdb $ + [ "compile", "--build-dir", odir ] ++ + concat [ ["-i", d] | d <- srcDirs ] ++ + concat [ ["-I", d] | d <- [autogenComponentModulesDir lbi clbi + ,autogenPackageModulesDir lbi + ,odir] ++ includeDirs bi ] ++ + [ packageDbOpt pkgDb | pkgDb <- dbStack ] ++ + [ "--package-name", prettyShow pkgid ] ++ + concat [ ["--package-id", prettyShow ipkgid ] + | (ipkgid, _) <- componentPackageDeps clbi ] ++ + ["-G", prettyShow language] ++ + concat [ ["-X", prettyShow ex] | ex <- usedExtensions bi ] ++ + cppOptions (libBuildInfo lib) ++ + [ prettyShow modu | modu <- allLibModules lib clbi ] + + + +installLib + :: Verbosity + -> LocalBuildInfo + -> FilePath -- ^install location + -> FilePath -- ^install location for dynamic libraries + -> FilePath -- ^Build location + -> PackageDescription + -> Library + -> ComponentLocalBuildInfo + -> IO () +installLib verbosity lbi targetDir dynlibTargetDir builtDir pkg lib clbi = do + let progdb = withPrograms lbi + runDbProgram verbosity haskellSuitePkgProgram progdb $ + [ "install-library" + , "--build-dir", builtDir + , "--target-dir", targetDir + , "--dynlib-target-dir", dynlibTargetDir + , "--package-id", prettyShow $ packageId pkg + ] ++ map prettyShow (allLibModules lib clbi) + +registerPackage + :: Verbosity + -> ProgramDb + -> PackageDBStack + -> InstalledPackageInfo + -> IO () +registerPackage verbosity progdb packageDbs installedPkgInfo = do + (hspkg, _) <- requireProgram verbosity haskellSuitePkgProgram progdb + + runProgramInvocation verbosity $ + (programInvocation hspkg + ["update", packageDbOpt $ registrationPackageDB packageDbs]) + { progInvokeInput = Just $ IODataText $ showInstalledPackageInfo installedPkgInfo } + +initPackageDB :: Verbosity -> ProgramDb -> FilePath -> IO () +initPackageDB verbosity progdb dbPath = + runDbProgram verbosity haskellSuitePkgProgram progdb + ["init", dbPath] + +packageDbOpt :: PackageDB -> String +packageDbOpt GlobalPackageDB = "--global" +packageDbOpt UserPackageDB = "--user" +packageDbOpt (SpecificPackageDB db) = "--package-db=" ++ db diff --git a/cabal/Cabal/src/Distribution/Simple/Hpc.hs b/cabal/Cabal/src/Distribution/Simple/Hpc.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/Hpc.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Hpc +-- Copyright : Thomas Tuegel 2011 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module provides functions for locating various HPC-related paths and +-- a function for adding the necessary options to a PackageDescription to +-- build test suites with HPC enabled. + +module Distribution.Simple.Hpc + ( Way(..), guessWay + , htmlDir + , mixDir + , tixDir + , tixFilePath + , markupPackage + , markupTest + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Types.UnqualComponentName +import Distribution.ModuleName ( main ) +import qualified Distribution.PackageDescription as PD +import Distribution.PackageDescription + ( Library(..) + , TestSuite(..) + , testModules + ) +import Distribution.Pretty +import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) ) +import Distribution.Simple.Program + ( hpcProgram + , requireProgramVersion + ) +import Distribution.Simple.Program.Hpc ( markup, union ) +import Distribution.Simple.Utils ( notice ) +import Distribution.Version ( anyVersion ) +import Distribution.Verbosity ( Verbosity() ) +import System.Directory ( createDirectoryIfMissing, doesFileExist ) +import System.FilePath + +-- ------------------------------------------------------------------------- +-- Haskell Program Coverage + +data Way = Vanilla | Prof | Dyn + deriving (Bounded, Enum, Eq, Read, Show) + +hpcDir :: FilePath -- ^ \"dist/\" prefix + -> Way + -> FilePath -- ^ Directory containing component's HPC .mix files +hpcDir distPref way = distPref "hpc" wayDir + where + wayDir = case way of + Vanilla -> "vanilla" + Prof -> "prof" + Dyn -> "dyn" + +mixDir :: FilePath -- ^ \"dist/\" prefix + -> Way + -> FilePath -- ^ Component name + -> FilePath -- ^ Directory containing test suite's .mix files +mixDir distPref way name = hpcDir distPrefBuild way "mix" name + where + -- This is a hack for HPC over test suites, needed to match the directory + -- where HPC saves and reads .mix files when the main library of the same + -- package is being processed, perhaps in a previous cabal run (#5213). + -- E.g., @distPref@ may be + -- @./dist-newstyle/build/x86_64-linux/ghc-9.0.1/cabal-gh5213-0.1/t/tests@ + -- but the path where library mix files reside has two less components + -- at the end (@t/tests@) and this reduced path needs to be passed to + -- both @hpc@ and @ghc@. For non-default optimization levels, the path + -- suffix is one element longer and the extra path element needs + -- to be preserved. + distPrefElements = splitDirectories distPref + distPrefBuild = case drop (length distPrefElements - 3) distPrefElements of + ["t", _, "noopt"] -> + joinPath $ take (length distPrefElements - 3) distPrefElements + ++ ["noopt"] + ["t", _, "opt"] -> + joinPath $ take (length distPrefElements - 3) distPrefElements + ++ ["opt"] + [_, "t", _] -> + joinPath $ take (length distPrefElements - 2) distPrefElements + _ -> distPref + +tixDir :: FilePath -- ^ \"dist/\" prefix + -> Way + -> FilePath -- ^ Component name + -> FilePath -- ^ Directory containing test suite's .tix files +tixDir distPref way name = hpcDir distPref way "tix" name + +-- | Path to the .tix file containing a test suite's sum statistics. +tixFilePath :: FilePath -- ^ \"dist/\" prefix + -> Way + -> FilePath -- ^ Component name + -> FilePath -- ^ Path to test suite's .tix file +tixFilePath distPref way name = tixDir distPref way name name <.> "tix" + +htmlDir :: FilePath -- ^ \"dist/\" prefix + -> Way + -> FilePath -- ^ Component name + -> FilePath -- ^ Path to test suite's HTML markup directory +htmlDir distPref way name = hpcDir distPref way "html" name + +-- | Attempt to guess the way the test suites in this package were compiled +-- and linked with the library so the correct module interfaces are found. +guessWay :: LocalBuildInfo -> Way +guessWay lbi + | withProfExe lbi = Prof + | withDynExe lbi = Dyn + | otherwise = Vanilla + +-- | Generate the HTML markup for a test suite. +markupTest :: Verbosity + -> LocalBuildInfo + -> FilePath -- ^ \"dist/\" prefix + -> String -- ^ Library name + -> TestSuite + -> Library + -> IO () +markupTest verbosity lbi distPref libraryName suite library = do + tixFileExists <- doesFileExist $ tixFilePath distPref way $ testName' + when tixFileExists $ do + -- behaviour of 'markup' depends on version, so we need *a* version + -- but no particular one + (hpc, hpcVer, _) <- requireProgramVersion verbosity + hpcProgram anyVersion (withPrograms lbi) + let htmlDir_ = htmlDir distPref way testName' + markup hpc hpcVer verbosity + (tixFilePath distPref way testName') mixDirs + htmlDir_ + (exposedModules library) + notice verbosity $ "Test coverage report written to " + ++ htmlDir_ "hpc_index" <.> "html" + where + way = guessWay lbi + testName' = unUnqualComponentName $ testName suite + mixDirs = map (mixDir distPref way) [ testName', libraryName ] + +-- | Generate the HTML markup for all of a package's test suites. +markupPackage :: Verbosity + -> LocalBuildInfo + -> FilePath -- ^ \"dist/\" prefix + -> PD.PackageDescription + -> [TestSuite] + -> IO () +markupPackage verbosity lbi distPref pkg_descr suites = do + let tixFiles = map (tixFilePath distPref way) testNames + tixFilesExist <- traverse doesFileExist tixFiles + when (and tixFilesExist) $ do + -- behaviour of 'markup' depends on version, so we need *a* version + -- but no particular one + (hpc, hpcVer, _) <- requireProgramVersion verbosity + hpcProgram anyVersion (withPrograms lbi) + let outFile = tixFilePath distPref way libraryName + htmlDir' = htmlDir distPref way libraryName + excluded = concatMap testModules suites ++ [ main ] + createDirectoryIfMissing True $ takeDirectory outFile + union hpc verbosity tixFiles outFile excluded + markup hpc hpcVer verbosity outFile mixDirs htmlDir' included + notice verbosity $ "Package coverage report written to " + ++ htmlDir' "hpc_index.html" + where + way = guessWay lbi + testNames = fmap (unUnqualComponentName . testName) suites + mixDirs = map (mixDir distPref way) $ libraryName : testNames + included = concatMap (exposedModules) $ PD.allLibraries pkg_descr + libraryName = prettyShow $ PD.package pkg_descr diff --git a/cabal/Cabal/src/Distribution/Simple/Install.hs b/cabal/Cabal/src/Distribution/Simple/Install.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/Install.hs @@ -0,0 +1,260 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Install +-- Copyright : Isaac Jones 2003-2004 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is the entry point into installing a built package. Performs the +-- \"@.\/setup install@\" and \"@.\/setup copy@\" actions. It moves files into +-- place based on the prefix argument. It does the generic bits and then calls +-- compiler-specific functions to do the rest. + +module Distribution.Simple.Install ( + install, + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Types.TargetInfo +import Distribution.Types.LocalBuildInfo +import Distribution.Types.ForeignLib +import Distribution.Types.PackageDescription +import Distribution.Types.UnqualComponentName +import Distribution.Types.ExecutableScope + +import Distribution.Package +import Distribution.PackageDescription +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.BuildPaths (haddockName, haddockPref) +import Distribution.Simple.Glob (matchDirFileGlob) +import Distribution.Simple.Utils + ( createDirectoryIfMissingVerbose + , installDirectoryContents, installOrdinaryFile, isInSearchPath + , die', info, noticeNoWrap, warn ) +import Distribution.Simple.Compiler + ( CompilerFlavor(..), compilerFlavor ) +import Distribution.Simple.Setup + ( CopyFlags(..), fromFlag, HaddockTarget(ForDevelopment) ) +import Distribution.Simple.BuildTarget +import Distribution.Utils.Path (getSymbolicPath) + +import qualified Distribution.Simple.GHC as GHC +import qualified Distribution.Simple.GHCJS as GHCJS +import qualified Distribution.Simple.UHC as UHC +import qualified Distribution.Simple.HaskellSuite as HaskellSuite +import Distribution.Compat.Graph (IsNode(..)) + +import System.Directory + ( doesDirectoryExist, doesFileExist ) +import System.FilePath + ( takeFileName, takeDirectory, (), isRelative ) + +import Distribution.Verbosity +import Distribution.Pretty + ( prettyShow ) + +-- |Perform the \"@.\/setup install@\" and \"@.\/setup copy@\" +-- actions. Move files into place based on the prefix argument. +-- +-- This does NOT register libraries, you should call 'register' +-- to do that. + +install :: PackageDescription -- ^information from the .cabal file + -> LocalBuildInfo -- ^information from the configure step + -> CopyFlags -- ^flags sent to copy or install + -> IO () +install pkg_descr lbi flags = do + checkHasLibsOrExes + targets <- readTargetInfos verbosity pkg_descr lbi (copyArgs flags) + + copyPackage verbosity pkg_descr lbi distPref copydest + + -- It's not necessary to do these in build-order, but it's harmless + withNeededTargetsInBuildOrder' pkg_descr lbi (map nodeKey targets) $ \target -> + let comp = targetComponent target + clbi = targetCLBI target + in copyComponent verbosity pkg_descr lbi comp clbi copydest + where + distPref = fromFlag (copyDistPref flags) + verbosity = fromFlag (copyVerbosity flags) + copydest = fromFlag (copyDest flags) + + checkHasLibsOrExes = + unless (hasLibs pkg_descr || hasForeignLibs pkg_descr || hasExes pkg_descr) $ + die' verbosity "No executables and no library found. Nothing to do." + +-- | Copy package global files. +copyPackage :: Verbosity -> PackageDescription + -> LocalBuildInfo -> FilePath -> CopyDest -> IO () +copyPackage verbosity pkg_descr lbi distPref copydest = do + let -- This is a bit of a hack, to handle files which are not + -- per-component (data files and Haddock files.) + InstallDirs { + datadir = dataPref, + docdir = docPref, + htmldir = htmlPref, + haddockdir = interfacePref + } = absoluteInstallCommandDirs pkg_descr lbi (localUnitId lbi) copydest + + -- Install (package-global) data files + installDataFiles verbosity pkg_descr dataPref + + -- Install (package-global) Haddock files + -- TODO: these should be done per-library + docExists <- doesDirectoryExist $ haddockPref ForDevelopment distPref pkg_descr + info verbosity ("directory " ++ haddockPref ForDevelopment distPref pkg_descr ++ + " does exist: " ++ show docExists) + + -- TODO: this is a bit questionable, Haddock files really should + -- be per library (when there are convenience libraries.) + when docExists $ do + createDirectoryIfMissingVerbose verbosity True htmlPref + installDirectoryContents verbosity + (haddockPref ForDevelopment distPref pkg_descr) htmlPref + -- setPermissionsRecursive [Read] htmlPref + -- The haddock interface file actually already got installed + -- in the recursive copy, but now we install it where we actually + -- want it to be (normally the same place). We could remove the + -- copy in htmlPref first. + let haddockInterfaceFileSrc = haddockPref ForDevelopment distPref pkg_descr + haddockName pkg_descr + haddockInterfaceFileDest = interfacePref haddockName pkg_descr + -- We only generate the haddock interface file for libs, So if the + -- package consists only of executables there will not be one: + exists <- doesFileExist haddockInterfaceFileSrc + when exists $ do + createDirectoryIfMissingVerbose verbosity True interfacePref + installOrdinaryFile verbosity haddockInterfaceFileSrc + haddockInterfaceFileDest + + let lfiles = licenseFiles pkg_descr + unless (null lfiles) $ do + createDirectoryIfMissingVerbose verbosity True docPref + for_ lfiles $ \lfile' -> do + let lfile :: FilePath + lfile = getSymbolicPath lfile' + installOrdinaryFile verbosity lfile (docPref takeFileName lfile) + +-- | Copy files associated with a component. +copyComponent :: Verbosity -> PackageDescription + -> LocalBuildInfo -> Component -> ComponentLocalBuildInfo + -> CopyDest + -> IO () +copyComponent verbosity pkg_descr lbi (CLib lib) clbi copydest = do + let InstallDirs{ + libdir = libPref, + dynlibdir = dynlibPref, + includedir = incPref + } = absoluteInstallCommandDirs pkg_descr lbi (componentUnitId clbi) copydest + buildPref = componentBuildDir lbi clbi + + case libName lib of + LMainLibName -> noticeNoWrap verbosity ("Installing library in " ++ libPref) + LSubLibName n -> noticeNoWrap verbosity ("Installing internal library " ++ prettyShow n ++ " in " ++ libPref) + + -- install include files for all compilers - they may be needed to compile + -- haskell files (using the CPP extension) + installIncludeFiles verbosity (libBuildInfo lib) lbi buildPref incPref + + case compilerFlavor (compiler lbi) of + GHC -> GHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi + GHCJS -> GHCJS.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi + UHC -> UHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi + HaskellSuite _ -> HaskellSuite.installLib + verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi + _ -> die' verbosity $ "installing with " + ++ prettyShow (compilerFlavor (compiler lbi)) + ++ " is not implemented" + +copyComponent verbosity pkg_descr lbi (CFLib flib) clbi copydest = do + let InstallDirs{ + flibdir = flibPref, + includedir = incPref + } = absoluteComponentInstallDirs pkg_descr lbi (componentUnitId clbi) copydest + buildPref = componentBuildDir lbi clbi + + noticeNoWrap verbosity ("Installing foreign library " ++ unUnqualComponentName (foreignLibName flib) ++ " in " ++ flibPref) + installIncludeFiles verbosity (foreignLibBuildInfo flib) lbi buildPref incPref + + case compilerFlavor (compiler lbi) of + GHC -> GHC.installFLib verbosity lbi flibPref buildPref pkg_descr flib + GHCJS -> GHCJS.installFLib verbosity lbi flibPref buildPref pkg_descr flib + _ -> die' verbosity $ "installing foreign lib with " + ++ prettyShow (compilerFlavor (compiler lbi)) + ++ " is not implemented" + +copyComponent verbosity pkg_descr lbi (CExe exe) clbi copydest = do + let installDirs = absoluteComponentInstallDirs pkg_descr lbi (componentUnitId clbi) copydest + -- the installers know how to find the actual location of the + -- binaries + buildPref = buildDir lbi + uid = componentUnitId clbi + pkgid = packageId pkg_descr + binPref | ExecutablePrivate <- exeScope exe = libexecdir installDirs + | otherwise = bindir installDirs + progPrefixPref = substPathTemplate pkgid lbi uid (progPrefix lbi) + progSuffixPref = substPathTemplate pkgid lbi uid (progSuffix lbi) + progFix = (progPrefixPref, progSuffixPref) + noticeNoWrap verbosity ("Installing executable " ++ prettyShow (exeName exe) + ++ " in " ++ binPref) + inPath <- isInSearchPath binPref + when (not inPath) $ + warn verbosity ("The directory " ++ binPref + ++ " is not in the system search path.") + case compilerFlavor (compiler lbi) of + GHC -> GHC.installExe verbosity lbi binPref buildPref progFix pkg_descr exe + GHCJS -> GHCJS.installExe verbosity lbi binPref buildPref progFix pkg_descr exe + UHC -> return () + HaskellSuite {} -> return () + _ -> die' verbosity $ "installing with " + ++ prettyShow (compilerFlavor (compiler lbi)) + ++ " is not implemented" + +-- Nothing to do for benchmark/testsuite +copyComponent _ _ _ (CBench _) _ _ = return () +copyComponent _ _ _ (CTest _) _ _ = return () + +-- | Install the files listed in data-files +-- +installDataFiles :: Verbosity -> PackageDescription -> FilePath -> IO () +installDataFiles verbosity pkg_descr destDataDir = + flip traverse_ (dataFiles pkg_descr) $ \ glob -> do + let srcDataDirRaw = dataDir pkg_descr + srcDataDir = if null srcDataDirRaw + then "." + else srcDataDirRaw + files <- matchDirFileGlob verbosity (specVersion pkg_descr) srcDataDir glob + for_ files $ \ file' -> do + let src = srcDataDir file' + dst = destDataDir file' + createDirectoryIfMissingVerbose verbosity True (takeDirectory dst) + installOrdinaryFile verbosity src dst + +-- | Install the files listed in install-includes for a library +-- +installIncludeFiles :: Verbosity -> BuildInfo -> LocalBuildInfo -> FilePath -> FilePath -> IO () +installIncludeFiles verbosity libBi lbi buildPref destIncludeDir = do + let relincdirs = "." : filter isRelative (includeDirs libBi) + incdirs = [ baseDir lbi dir | dir <- relincdirs ] + ++ [ buildPref dir | dir <- relincdirs ] + incs <- traverse (findInc incdirs) (installIncludes libBi) + sequence_ + [ do createDirectoryIfMissingVerbose verbosity True destDir + installOrdinaryFile verbosity srcFile destFile + | (relFile, srcFile) <- incs + , let destFile = destIncludeDir relFile + destDir = takeDirectory destFile ] + where + baseDir lbi' = fromMaybe "" (takeDirectory <$> cabalFilePath lbi') + findInc [] file = die' verbosity ("can't find include file " ++ file) + findInc (dir:dirs) file = do + let path = dir file + exists <- doesFileExist path + if exists then return (file, path) else findInc dirs file diff --git a/cabal/Cabal/src/Distribution/Simple/InstallDirs.hs b/cabal/Cabal/src/Distribution/Simple/InstallDirs.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/InstallDirs.hs @@ -0,0 +1,506 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.InstallDirs +-- Copyright : Isaac Jones 2003-2004 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This manages everything to do with where files get installed (though does +-- not get involved with actually doing any installation). It provides an +-- 'InstallDirs' type which is a set of directories for where to install +-- things. It also handles the fact that we use templates in these install +-- dirs. For example most install dirs are relative to some @$prefix@ and by +-- changing the prefix all other dirs still end up changed appropriately. So it +-- provides a 'PathTemplate' type and functions for substituting for these +-- templates. + +module Distribution.Simple.InstallDirs ( + InstallDirs(..), + InstallDirTemplates, + defaultInstallDirs, + defaultInstallDirs', + combineInstallDirs, + absoluteInstallDirs, + CopyDest(..), + prefixRelativeInstallDirs, + substituteInstallDirTemplates, + + PathTemplate, + PathTemplateVariable(..), + PathTemplateEnv, + toPathTemplate, + fromPathTemplate, + combinePathTemplate, + substPathTemplate, + initialPathTemplateEnv, + platformTemplateEnv, + compilerTemplateEnv, + packageTemplateEnv, + abiTemplateEnv, + installDirsTemplateEnv, + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Compat.Environment (lookupEnv) +import Distribution.Pretty +import Distribution.Package +import Distribution.System +import Distribution.Compiler +import Distribution.Simple.InstallDirs.Internal + +import System.Directory (getAppUserDataDirectory) +import System.FilePath + ( (), isPathSeparator + , pathSeparator, dropDrive + , takeDirectory ) + +#ifdef mingw32_HOST_OS +import qualified Prelude +import Foreign +import Foreign.C +#endif + +-- --------------------------------------------------------------------------- +-- Installation directories + + +-- | The directories where we will install files for packages. +-- +-- We have several different directories for different types of files since +-- many systems have conventions whereby different types of files in a package +-- are installed in different directories. This is particularly the case on +-- Unix style systems. +-- +data InstallDirs dir = InstallDirs { + prefix :: dir, + bindir :: dir, + libdir :: dir, + libsubdir :: dir, + dynlibdir :: dir, + flibdir :: dir, -- ^ foreign libraries + libexecdir :: dir, + libexecsubdir:: dir, + includedir :: dir, + datadir :: dir, + datasubdir :: dir, + docdir :: dir, + mandir :: dir, + htmldir :: dir, + haddockdir :: dir, + sysconfdir :: dir + } deriving (Eq, Read, Show, Functor, Generic, Typeable) + +instance Binary dir => Binary (InstallDirs dir) +instance Structured dir => Structured (InstallDirs dir) + +instance (Semigroup dir, Monoid dir) => Monoid (InstallDirs dir) where + mempty = gmempty + mappend = (<>) + +instance Semigroup dir => Semigroup (InstallDirs dir) where + (<>) = gmappend + +combineInstallDirs :: (a -> b -> c) + -> InstallDirs a + -> InstallDirs b + -> InstallDirs c +combineInstallDirs combine a b = InstallDirs { + prefix = prefix a `combine` prefix b, + bindir = bindir a `combine` bindir b, + libdir = libdir a `combine` libdir b, + libsubdir = libsubdir a `combine` libsubdir b, + dynlibdir = dynlibdir a `combine` dynlibdir b, + flibdir = flibdir a `combine` flibdir b, + libexecdir = libexecdir a `combine` libexecdir b, + libexecsubdir= libexecsubdir a `combine` libexecsubdir b, + includedir = includedir a `combine` includedir b, + datadir = datadir a `combine` datadir b, + datasubdir = datasubdir a `combine` datasubdir b, + docdir = docdir a `combine` docdir b, + mandir = mandir a `combine` mandir b, + htmldir = htmldir a `combine` htmldir b, + haddockdir = haddockdir a `combine` haddockdir b, + sysconfdir = sysconfdir a `combine` sysconfdir b + } + +appendSubdirs :: (a -> a -> a) -> InstallDirs a -> InstallDirs a +appendSubdirs append dirs = dirs { + libdir = libdir dirs `append` libsubdir dirs, + libexecdir = libexecdir dirs `append` libexecsubdir dirs, + datadir = datadir dirs `append` datasubdir dirs, + libsubdir = error "internal error InstallDirs.libsubdir", + libexecsubdir = error "internal error InstallDirs.libexecsubdir", + datasubdir = error "internal error InstallDirs.datasubdir" + } + +-- | The installation directories in terms of 'PathTemplate's that contain +-- variables. +-- +-- The defaults for most of the directories are relative to each other, in +-- particular they are all relative to a single prefix. This makes it +-- convenient for the user to override the default installation directory +-- by only having to specify --prefix=... rather than overriding each +-- individually. This is done by allowing $-style variables in the dirs. +-- These are expanded by textual substitution (see 'substPathTemplate'). +-- +-- A few of these installation directories are split into two components, the +-- dir and subdir. The full installation path is formed by combining the two +-- together with @\/@. The reason for this is compatibility with other Unix +-- build systems which also support @--libdir@ and @--datadir@. We would like +-- users to be able to configure @--libdir=\/usr\/lib64@ for example but +-- because by default we want to support installing multiple versions of +-- packages and building the same package for multiple compilers we append the +-- libsubdir to get: @\/usr\/lib64\/$libname\/$compiler@. +-- +-- An additional complication is the need to support relocatable packages on +-- systems which support such things, like Windows. +-- +type InstallDirTemplates = InstallDirs PathTemplate + +-- --------------------------------------------------------------------------- +-- Default installation directories + +defaultInstallDirs :: CompilerFlavor -> Bool -> Bool -> IO InstallDirTemplates +defaultInstallDirs = defaultInstallDirs' False + +defaultInstallDirs' :: Bool {- use external internal deps -} + -> CompilerFlavor -> Bool -> Bool -> IO InstallDirTemplates +defaultInstallDirs' True comp userInstall hasLibs = do + dflt <- defaultInstallDirs' False comp userInstall hasLibs + -- Be a bit more hermetic about per-component installs + return dflt { datasubdir = toPathTemplate $ "$abi" "$libname", + docdir = toPathTemplate $ "$datadir" "doc" "$abi" "$libname" + } +defaultInstallDirs' False comp userInstall _hasLibs = do + installPrefix <- + if userInstall + then do + mDir <- lookupEnv "CABAL_DIR" + case mDir of + Nothing -> getAppUserDataDirectory "cabal" + Just dir -> return dir + else case buildOS of + Windows -> do windowsProgramFilesDir <- getWindowsProgramFilesDir + return (windowsProgramFilesDir "Haskell") + _ -> return "/usr/local" + installLibDir <- + case buildOS of + Windows -> return "$prefix" + _ -> return ("$prefix" "lib") + return $ fmap toPathTemplate $ InstallDirs { + prefix = installPrefix, + bindir = "$prefix" "bin", + libdir = installLibDir, + libsubdir = case comp of + UHC -> "$pkgid" + _other -> "$abi" "$libname", + dynlibdir = "$libdir" case comp of + UHC -> "$pkgid" + _other -> "$abi", + libexecsubdir= "$abi" "$pkgid", + flibdir = "$libdir", + libexecdir = case buildOS of + Windows -> "$prefix" "$libname" + _other -> "$prefix" "libexec", + includedir = "$libdir" "$libsubdir" "include", + datadir = case buildOS of + Windows -> "$prefix" + _other -> "$prefix" "share", + datasubdir = "$abi" "$pkgid", + docdir = "$datadir" "doc" "$abi" "$pkgid", + mandir = "$datadir" "man", + htmldir = "$docdir" "html", + haddockdir = "$htmldir", + sysconfdir = "$prefix" "etc" + } + +-- --------------------------------------------------------------------------- +-- Converting directories, absolute or prefix-relative + +-- | Substitute the install dir templates into each other. +-- +-- To prevent cyclic substitutions, only some variables are allowed in +-- particular dir templates. If out of scope vars are present, they are not +-- substituted for. Checking for any remaining unsubstituted vars can be done +-- as a subsequent operation. +-- +-- The reason it is done this way is so that in 'prefixRelativeInstallDirs' we +-- can replace 'prefix' with the 'PrefixVar' and get resulting +-- 'PathTemplate's that still have the 'PrefixVar' in them. Doing this makes it +-- each to check which paths are relative to the $prefix. +-- +substituteInstallDirTemplates :: PathTemplateEnv + -> InstallDirTemplates -> InstallDirTemplates +substituteInstallDirTemplates env dirs = dirs' + where + dirs' = InstallDirs { + -- So this specifies exactly which vars are allowed in each template + prefix = subst prefix [], + bindir = subst bindir [prefixVar], + libdir = subst libdir [prefixVar, bindirVar], + libsubdir = subst libsubdir [], + dynlibdir = subst dynlibdir [prefixVar, bindirVar, libdirVar], + flibdir = subst flibdir [prefixVar, bindirVar, libdirVar], + libexecdir = subst libexecdir prefixBinLibVars, + libexecsubdir = subst libexecsubdir [], + includedir = subst includedir prefixBinLibVars, + datadir = subst datadir prefixBinLibVars, + datasubdir = subst datasubdir [], + docdir = subst docdir prefixBinLibDataVars, + mandir = subst mandir (prefixBinLibDataVars ++ [docdirVar]), + htmldir = subst htmldir (prefixBinLibDataVars ++ [docdirVar]), + haddockdir = subst haddockdir (prefixBinLibDataVars ++ + [docdirVar, htmldirVar]), + sysconfdir = subst sysconfdir prefixBinLibVars + } + subst dir env' = substPathTemplate (env'++env) (dir dirs) + + prefixVar = (PrefixVar, prefix dirs') + bindirVar = (BindirVar, bindir dirs') + libdirVar = (LibdirVar, libdir dirs') + libsubdirVar = (LibsubdirVar, libsubdir dirs') + datadirVar = (DatadirVar, datadir dirs') + datasubdirVar = (DatasubdirVar, datasubdir dirs') + docdirVar = (DocdirVar, docdir dirs') + htmldirVar = (HtmldirVar, htmldir dirs') + prefixBinLibVars = [prefixVar, bindirVar, libdirVar, libsubdirVar] + prefixBinLibDataVars = prefixBinLibVars ++ [datadirVar, datasubdirVar] + +-- | Convert from abstract install directories to actual absolute ones by +-- substituting for all the variables in the abstract paths, to get real +-- absolute path. +absoluteInstallDirs :: PackageIdentifier + -> UnitId + -> CompilerInfo + -> CopyDest + -> Platform + -> InstallDirs PathTemplate + -> InstallDirs FilePath +absoluteInstallDirs pkgId libname compilerId copydest platform dirs = + (case copydest of + CopyTo destdir -> fmap ((destdir ) . dropDrive) + CopyToDb dbdir -> fmap (substPrefix "${pkgroot}" (takeDirectory dbdir)) + _ -> id) + . appendSubdirs () + . fmap fromPathTemplate + $ substituteInstallDirTemplates env dirs + where + env = initialPathTemplateEnv pkgId libname compilerId platform + substPrefix pre root path + | pre `isPrefixOf` path = root ++ drop (length pre) path + | otherwise = path + + +-- |The location prefix for the /copy/ command. +data CopyDest + = NoCopyDest + | CopyTo FilePath + | CopyToDb FilePath + -- ^ when using the ${pkgroot} as prefix. The CopyToDb will + -- adjust the paths to be relative to the provided package + -- database when copying / installing. + deriving (Eq, Show, Generic) + +instance Binary CopyDest + +-- | Check which of the paths are relative to the installation $prefix. +-- +-- If any of the paths are not relative, ie they are absolute paths, then it +-- prevents us from making a relocatable package (also known as a \"prefix +-- independent\" package). +-- +prefixRelativeInstallDirs :: PackageIdentifier + -> UnitId + -> CompilerInfo + -> Platform + -> InstallDirTemplates + -> InstallDirs (Maybe FilePath) +prefixRelativeInstallDirs pkgId libname compilerId platform dirs = + fmap relative + . appendSubdirs combinePathTemplate + $ -- substitute the path template into each other, except that we map + -- \$prefix back to $prefix. We're trying to end up with templates that + -- mention no vars except $prefix. + substituteInstallDirTemplates env dirs { + prefix = PathTemplate [Variable PrefixVar] + } + where + env = initialPathTemplateEnv pkgId libname compilerId platform + + -- If it starts with $prefix then it's relative and produce the relative + -- path by stripping off $prefix/ or $prefix + relative dir = case dir of + PathTemplate cs -> fmap (fromPathTemplate . PathTemplate) (relative' cs) + relative' (Variable PrefixVar : Ordinary (s:rest) : rest') + | isPathSeparator s = Just (Ordinary rest : rest') + relative' (Variable PrefixVar : rest) = Just rest + relative' _ = Nothing + +-- --------------------------------------------------------------------------- +-- Path templates + +-- | An abstract path, possibly containing variables that need to be +-- substituted for to get a real 'FilePath'. +-- +newtype PathTemplate = PathTemplate [PathComponent] + deriving (Eq, Ord, Generic, Typeable) + +instance Binary PathTemplate +instance Structured PathTemplate + +type PathTemplateEnv = [(PathTemplateVariable, PathTemplate)] + +-- | Convert a 'FilePath' to a 'PathTemplate' including any template vars. +-- +toPathTemplate :: FilePath -> PathTemplate +toPathTemplate fp = PathTemplate + . fromMaybe (error $ "panic! toPathTemplate " ++ show fp) + . readMaybe -- TODO: eradicateNoParse + $ fp + +-- | Convert back to a path, any remaining vars are included +-- +fromPathTemplate :: PathTemplate -> FilePath +fromPathTemplate (PathTemplate template) = show template + +combinePathTemplate :: PathTemplate -> PathTemplate -> PathTemplate +combinePathTemplate (PathTemplate t1) (PathTemplate t2) = + PathTemplate (t1 ++ [Ordinary [pathSeparator]] ++ t2) + +substPathTemplate :: PathTemplateEnv -> PathTemplate -> PathTemplate +substPathTemplate environment (PathTemplate template) = + PathTemplate (concatMap subst template) + + where subst component@(Ordinary _) = [component] + subst component@(Variable variable) = + case lookup variable environment of + Just (PathTemplate components) -> components + Nothing -> [component] + +-- | The initial environment has all the static stuff but no paths +initialPathTemplateEnv :: PackageIdentifier + -> UnitId + -> CompilerInfo + -> Platform + -> PathTemplateEnv +initialPathTemplateEnv pkgId libname compiler platform = + packageTemplateEnv pkgId libname + ++ compilerTemplateEnv compiler + ++ platformTemplateEnv platform + ++ abiTemplateEnv compiler platform + +packageTemplateEnv :: PackageIdentifier -> UnitId -> PathTemplateEnv +packageTemplateEnv pkgId uid = + [(PkgNameVar, PathTemplate [Ordinary $ prettyShow (packageName pkgId)]) + ,(PkgVerVar, PathTemplate [Ordinary $ prettyShow (packageVersion pkgId)]) + -- Invariant: uid is actually a HashedUnitId. Hard to enforce because + -- it's an API change. + ,(LibNameVar, PathTemplate [Ordinary $ prettyShow uid]) + ,(PkgIdVar, PathTemplate [Ordinary $ prettyShow pkgId]) + ] + +compilerTemplateEnv :: CompilerInfo -> PathTemplateEnv +compilerTemplateEnv compiler = + [(CompilerVar, PathTemplate [Ordinary $ prettyShow (compilerInfoId compiler)]) + ] + +platformTemplateEnv :: Platform -> PathTemplateEnv +platformTemplateEnv (Platform arch os) = + [(OSVar, PathTemplate [Ordinary $ prettyShow os]) + ,(ArchVar, PathTemplate [Ordinary $ prettyShow arch]) + ] + +abiTemplateEnv :: CompilerInfo -> Platform -> PathTemplateEnv +abiTemplateEnv compiler (Platform arch os) = + [(AbiVar, PathTemplate [Ordinary $ prettyShow arch ++ '-':prettyShow os ++ + '-':prettyShow (compilerInfoId compiler) ++ + case compilerInfoAbiTag compiler of + NoAbiTag -> "" + AbiTag tag -> '-':tag]) + ,(AbiTagVar, PathTemplate [Ordinary $ abiTagString (compilerInfoAbiTag compiler)]) + ] + +installDirsTemplateEnv :: InstallDirs PathTemplate -> PathTemplateEnv +installDirsTemplateEnv dirs = + [(PrefixVar, prefix dirs) + ,(BindirVar, bindir dirs) + ,(LibdirVar, libdir dirs) + ,(LibsubdirVar, libsubdir dirs) + ,(DynlibdirVar, dynlibdir dirs) + ,(DatadirVar, datadir dirs) + ,(DatasubdirVar, datasubdir dirs) + ,(DocdirVar, docdir dirs) + ,(HtmldirVar, htmldir dirs) + ] + + +-- --------------------------------------------------------------------------- +-- Parsing and showing path templates: + +-- The textual format is that of an ordinary Haskell String, eg +-- "$prefix/bin" +-- and this gets parsed to the internal representation as a sequence of path +-- spans which are either strings or variables, eg: +-- PathTemplate [Variable PrefixVar, Ordinary "/bin" ] + +instance Show PathTemplate where + show (PathTemplate template) = show (show template) + +instance Read PathTemplate where + readsPrec p s = [ (PathTemplate template, s') + | (path, s') <- readsPrec p s + , (template, "") <- reads path ] + +-- --------------------------------------------------------------------------- +-- Internal utilities + +getWindowsProgramFilesDir :: IO FilePath +getWindowsProgramFilesDir = do +#ifdef mingw32_HOST_OS + m <- shGetFolderPath csidl_PROGRAM_FILES +#else + let m = Nothing +#endif + return (fromMaybe "C:\\Program Files" m) + +#ifdef mingw32_HOST_OS +shGetFolderPath :: CInt -> IO (Maybe FilePath) +shGetFolderPath n = + allocaArray long_path_size $ \pPath -> do + r <- c_SHGetFolderPath nullPtr n nullPtr 0 pPath + if (r /= 0) + then return Nothing + else do s <- peekCWString pPath; return (Just s) + where + long_path_size = 1024 -- MAX_PATH is 260, this should be plenty + +csidl_PROGRAM_FILES :: CInt +csidl_PROGRAM_FILES = 0x0026 +-- csidl_PROGRAM_FILES_COMMON :: CInt +-- csidl_PROGRAM_FILES_COMMON = 0x002b + +#ifdef x86_64_HOST_ARCH +#define CALLCONV ccall +#else +#define CALLCONV stdcall +#endif + +foreign import CALLCONV unsafe "shlobj.h SHGetFolderPathW" + c_SHGetFolderPath :: Ptr () + -> CInt + -> Ptr () + -> CInt + -> CWString + -> Prelude.IO CInt +#endif diff --git a/cabal/Cabal/src/Distribution/Simple/InstallDirs/Internal.hs b/cabal/Cabal/src/Distribution/Simple/InstallDirs/Internal.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/InstallDirs/Internal.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Simple.InstallDirs.Internal + ( PathComponent(..) + , PathTemplateVariable(..) + ) where + +import Prelude () +import Distribution.Compat.Prelude + +data PathComponent = + Ordinary FilePath + | Variable PathTemplateVariable + deriving (Eq, Ord, Generic, Typeable) + +instance Binary PathComponent +instance Structured PathComponent + +data PathTemplateVariable = + PrefixVar -- ^ The @$prefix@ path variable + | BindirVar -- ^ The @$bindir@ path variable + | LibdirVar -- ^ The @$libdir@ path variable + | LibsubdirVar -- ^ The @$libsubdir@ path variable + | DynlibdirVar -- ^ The @$dynlibdir@ path variable + | DatadirVar -- ^ The @$datadir@ path variable + | DatasubdirVar -- ^ The @$datasubdir@ path variable + | DocdirVar -- ^ The @$docdir@ path variable + | HtmldirVar -- ^ The @$htmldir@ path variable + | PkgNameVar -- ^ The @$pkg@ package name path variable + | PkgVerVar -- ^ The @$version@ package version path variable + | PkgIdVar -- ^ The @$pkgid@ package Id path variable, eg @foo-1.0@ + | LibNameVar -- ^ The @$libname@ path variable + | CompilerVar -- ^ The compiler name and version, eg @ghc-6.6.1@ + | OSVar -- ^ The operating system name, eg @windows@ or @linux@ + | ArchVar -- ^ The CPU architecture name, eg @i386@ or @x86_64@ + | AbiVar -- ^ The compiler's ABI identifier, + --- $arch-$os-$compiler-$abitag + | AbiTagVar -- ^ The optional ABI tag for the compiler + | ExecutableNameVar -- ^ The executable name; used in shell wrappers + | TestSuiteNameVar -- ^ The name of the test suite being run + | TestSuiteResultVar -- ^ The result of the test suite being run, eg + -- @pass@, @fail@, or @error@. + | BenchmarkNameVar -- ^ The name of the benchmark being run + deriving (Eq, Ord, Generic, Typeable) + +instance Binary PathTemplateVariable +instance Structured PathTemplateVariable + +instance Show PathTemplateVariable where + show PrefixVar = "prefix" + show LibNameVar = "libname" + show BindirVar = "bindir" + show LibdirVar = "libdir" + show LibsubdirVar = "libsubdir" + show DynlibdirVar = "dynlibdir" + show DatadirVar = "datadir" + show DatasubdirVar = "datasubdir" + show DocdirVar = "docdir" + show HtmldirVar = "htmldir" + show PkgNameVar = "pkg" + show PkgVerVar = "version" + show PkgIdVar = "pkgid" + show CompilerVar = "compiler" + show OSVar = "os" + show ArchVar = "arch" + show AbiTagVar = "abitag" + show AbiVar = "abi" + show ExecutableNameVar = "executablename" + show TestSuiteNameVar = "test-suite" + show TestSuiteResultVar = "result" + show BenchmarkNameVar = "benchmark" + +instance Read PathTemplateVariable where + readsPrec _ s = + take 1 + [ (var, drop (length varStr) s) + | (varStr, var) <- vars + , varStr `isPrefixOf` s ] + -- NB: order matters! Longer strings first + where vars = [("prefix", PrefixVar) + ,("bindir", BindirVar) + ,("libdir", LibdirVar) + ,("libsubdir", LibsubdirVar) + ,("dynlibdir", DynlibdirVar) + ,("datadir", DatadirVar) + ,("datasubdir", DatasubdirVar) + ,("docdir", DocdirVar) + ,("htmldir", HtmldirVar) + ,("pkgid", PkgIdVar) + ,("libname", LibNameVar) + ,("pkgkey", LibNameVar) -- backwards compatibility + ,("pkg", PkgNameVar) + ,("version", PkgVerVar) + ,("compiler", CompilerVar) + ,("os", OSVar) + ,("arch", ArchVar) + ,("abitag", AbiTagVar) + ,("abi", AbiVar) + ,("executablename", ExecutableNameVar) + ,("test-suite", TestSuiteNameVar) + ,("result", TestSuiteResultVar) + ,("benchmark", BenchmarkNameVar)] + +instance Show PathComponent where + show (Ordinary path) = path + show (Variable var) = '$':show var + showList = foldr (\x -> (shows x .)) id + +instance Read PathComponent where + -- for some reason we collapse multiple $ symbols here + readsPrec _ = lex0 + where lex0 [] = [] + lex0 ('$':'$':s') = lex0 ('$':s') + lex0 ('$':s') = case [ (Variable var, s'') + | (var, s'') <- reads s' ] of + [] -> lex1 "$" s' + ok -> ok + lex0 s' = lex1 [] s' + lex1 "" "" = [] + lex1 acc "" = [(Ordinary (reverse acc), "")] + lex1 acc ('$':'$':s) = lex1 acc ('$':s) + lex1 acc ('$':s) = [(Ordinary (reverse acc), '$':s)] + lex1 acc (c:s) = lex1 (c:acc) s + readList [] = [([],"")] + readList s = [ (component:components, s'') + | (component, s') <- reads s + , (components, s'') <- readList s' ] diff --git a/cabal/Cabal/src/Distribution/Simple/LocalBuildInfo.hs b/cabal/Cabal/src/Distribution/Simple/LocalBuildInfo.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/LocalBuildInfo.hs @@ -0,0 +1,365 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.LocalBuildInfo +-- Copyright : Isaac Jones 2003-2004 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Once a package has been configured we have resolved conditionals and +-- dependencies, configured the compiler and other needed external programs. +-- The 'LocalBuildInfo' is used to hold all this information. It holds the +-- install dirs, the compiler, the exact package dependencies, the configured +-- programs, the package database to use and a bunch of miscellaneous configure +-- flags. It gets saved and reloaded from a file (@dist\/setup-config@). It gets +-- passed in to very many subsequent build actions. + +module Distribution.Simple.LocalBuildInfo ( + LocalBuildInfo(..), + localComponentId, + localUnitId, + localCompatPackageKey, + + -- * Buildable package components + Component(..), + ComponentName(..), + LibraryName(..), + defaultLibName, + showComponentName, + componentNameString, + ComponentLocalBuildInfo(..), + componentBuildDir, + foldComponent, + componentName, + componentBuildInfo, + componentBuildable, + pkgComponents, + pkgBuildableComponents, + lookupComponent, + getComponent, + allComponentsInBuildOrder, + depLibraryPaths, + allLibModules, + + withAllComponentsInBuildOrder, + withLibLBI, + withExeLBI, + withBenchLBI, + withTestLBI, + enabledTestLBIs, + enabledBenchLBIs, + + -- * Installation directories + module Distribution.Simple.InstallDirs, + absoluteInstallDirs, prefixRelativeInstallDirs, + absoluteInstallCommandDirs, + absoluteComponentInstallDirs, prefixRelativeComponentInstallDirs, + substPathTemplate, + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Types.Component +import Distribution.Types.PackageId +import Distribution.Types.UnitId +import Distribution.Types.ComponentName +import Distribution.Types.UnqualComponentName +import Distribution.Types.PackageDescription +import Distribution.Types.ComponentLocalBuildInfo +import Distribution.Types.LocalBuildInfo +import Distribution.Types.TargetInfo + +import Distribution.Simple.InstallDirs hiding (absoluteInstallDirs, + prefixRelativeInstallDirs, + substPathTemplate, ) +import qualified Distribution.Simple.InstallDirs as InstallDirs +import Distribution.PackageDescription +import qualified Distribution.InstalledPackageInfo as Installed +import Distribution.Package +import Distribution.ModuleName +import Distribution.Simple.Compiler +import Distribution.Simple.PackageIndex +import Distribution.Simple.Utils +import Distribution.Pretty +import qualified Distribution.Compat.Graph as Graph + +import Data.List (stripPrefix) +import System.FilePath + +import System.Directory (doesDirectoryExist, canonicalizePath) + +-- ----------------------------------------------------------------------------- +-- Configuration information of buildable components + +componentBuildDir :: LocalBuildInfo -> ComponentLocalBuildInfo -> FilePath +-- For now, we assume that libraries/executables/test-suites/benchmarks +-- are only ever built once. With Backpack, we need a special case for +-- libraries so that we can handle building them multiple times. +componentBuildDir lbi clbi + = buildDir lbi + case componentLocalName clbi of + CLibName LMainLibName -> + if prettyShow (componentUnitId clbi) == prettyShow (componentComponentId clbi) + then "" + else prettyShow (componentUnitId clbi) + CLibName (LSubLibName s) -> + if prettyShow (componentUnitId clbi) == prettyShow (componentComponentId clbi) + then unUnqualComponentName s + else prettyShow (componentUnitId clbi) + CFLibName s -> unUnqualComponentName s + CExeName s -> unUnqualComponentName s + CTestName s -> unUnqualComponentName s + CBenchName s -> unUnqualComponentName s + +-- | Perform the action on each enabled 'library' in the package +-- description with the 'ComponentLocalBuildInfo'. +withLibLBI :: PackageDescription -> LocalBuildInfo + -> (Library -> ComponentLocalBuildInfo -> IO ()) -> IO () +withLibLBI pkg lbi f = + withAllTargetsInBuildOrder' pkg lbi $ \target -> + case targetComponent target of + CLib lib -> f lib (targetCLBI target) + _ -> return () + +-- | Perform the action on each enabled 'Executable' in the package +-- description. Extended version of 'withExe' that also gives corresponding +-- build info. +withExeLBI :: PackageDescription -> LocalBuildInfo + -> (Executable -> ComponentLocalBuildInfo -> IO ()) -> IO () +withExeLBI pkg lbi f = + withAllTargetsInBuildOrder' pkg lbi $ \target -> + case targetComponent target of + CExe exe -> f exe (targetCLBI target) + _ -> return () + +-- | Perform the action on each enabled 'Benchmark' in the package +-- description. +withBenchLBI :: PackageDescription -> LocalBuildInfo + -> (Benchmark -> ComponentLocalBuildInfo -> IO ()) -> IO () +withBenchLBI pkg lbi f = + sequence_ [ f bench clbi | (bench, clbi) <- enabledBenchLBIs pkg lbi ] + +withTestLBI :: PackageDescription -> LocalBuildInfo + -> (TestSuite -> ComponentLocalBuildInfo -> IO ()) -> IO () +withTestLBI pkg lbi f = + sequence_ [ f test clbi | (test, clbi) <- enabledTestLBIs pkg lbi ] + +enabledTestLBIs :: PackageDescription -> LocalBuildInfo + -> [(TestSuite, ComponentLocalBuildInfo)] +enabledTestLBIs pkg lbi = + [ (test, targetCLBI target) + | target <- allTargetsInBuildOrder' pkg lbi + , CTest test <- [targetComponent target] ] + +enabledBenchLBIs :: PackageDescription -> LocalBuildInfo + -> [(Benchmark, ComponentLocalBuildInfo)] +enabledBenchLBIs pkg lbi = + [ (bench, targetCLBI target) + | target <- allTargetsInBuildOrder' pkg lbi + , CBench bench <- [targetComponent target] ] + +-- | Perform the action on each buildable 'Library' or 'Executable' (Component) +-- in the PackageDescription, subject to the build order specified by the +-- 'compBuildOrder' field of the given 'LocalBuildInfo' +withAllComponentsInBuildOrder :: PackageDescription -> LocalBuildInfo + -> (Component -> ComponentLocalBuildInfo -> IO ()) + -> IO () +withAllComponentsInBuildOrder pkg lbi f = + withAllTargetsInBuildOrder' pkg lbi $ \target -> + f (targetComponent target) (targetCLBI target) + +allComponentsInBuildOrder :: LocalBuildInfo + -> [ComponentLocalBuildInfo] +allComponentsInBuildOrder lbi = + Graph.topSort (componentGraph lbi) + +-- ----------------------------------------------------------------------------- +-- A random function that has no business in this module + +-- | Determine the directories containing the dynamic libraries of the +-- transitive dependencies of the component we are building. +-- +-- When wanted, and possible, returns paths relative to the installDirs 'prefix' +depLibraryPaths :: Bool -- ^ Building for inplace? + -> Bool -- ^ Generate prefix-relative library paths + -> LocalBuildInfo + -> ComponentLocalBuildInfo -- ^ Component that is being built + -> IO [FilePath] +depLibraryPaths inplace relative lbi clbi = do + let pkgDescr = localPkgDescr lbi + installDirs = absoluteComponentInstallDirs pkgDescr lbi (componentUnitId clbi) NoCopyDest + executable = case clbi of + ExeComponentLocalBuildInfo {} -> True + _ -> False + relDir | executable = bindir installDirs + | otherwise = libdir installDirs + + let -- TODO: this is kind of inefficient + internalDeps = [ uid + | (uid, _) <- componentPackageDeps clbi + -- Test that it's internal + , sub_target <- allTargetsInBuildOrder' pkgDescr lbi + , componentUnitId (targetCLBI (sub_target)) == uid ] + internalLibs = [ getLibDir (targetCLBI sub_target) + | sub_target <- neededTargetsInBuildOrder' + pkgDescr lbi internalDeps ] + {- + -- This is better, but it doesn't work, because we may be passed a + -- CLBI which doesn't actually exist, and was faked up when we + -- were building a test suite/benchmark. See #3599 for proposal + -- to fix this. + let internalCLBIs = filter ((/= componentUnitId clbi) . componentUnitId) + . map targetCLBI + $ neededTargetsInBuildOrder lbi [componentUnitId clbi] + internalLibs = map getLibDir internalCLBIs + -} + getLibDir sub_clbi + | inplace = componentBuildDir lbi sub_clbi + | otherwise = dynlibdir (absoluteComponentInstallDirs pkgDescr lbi (componentUnitId sub_clbi) NoCopyDest) + + -- Why do we go through all the trouble of a hand-crafting + -- internalLibs, when 'installedPkgs' actually contains the + -- internal libraries? The trouble is that 'installedPkgs' + -- may contain *inplace* entries, which we must NOT use for + -- not inplace 'depLibraryPaths' (e.g., for RPATH calculation). + -- See #4025 for more details. This is all horrible but it + -- is a moot point if you are using a per-component build, + -- because you never have any internal libraries in this case; + -- they're all external. + let external_ipkgs = filter is_external (allPackages (installedPkgs lbi)) + is_external ipkg = not (installedUnitId ipkg `elem` internalDeps) + -- First look for dynamic libraries in `dynamic-library-dirs`, and use + -- `library-dirs` as a fall back. + getDynDir pkg = case Installed.libraryDynDirs pkg of + [] -> Installed.libraryDirs pkg + d -> d + allDepLibDirs = concatMap getDynDir external_ipkgs + + allDepLibDirs' = internalLibs ++ allDepLibDirs + allDepLibDirsC <- traverse canonicalizePathNoFail allDepLibDirs' + + let p = prefix installDirs + prefixRelative l = isJust (stripPrefix p l) + libPaths + | relative && + prefixRelative relDir = map (\l -> + if prefixRelative l + then shortRelativePath relDir l + else l + ) allDepLibDirsC + | otherwise = allDepLibDirsC + + return libPaths + where + -- 'canonicalizePath' fails on UNIX when the directory does not exists. + -- So just don't canonicalize when it doesn't exist. + canonicalizePathNoFail p = do + exists <- doesDirectoryExist p + if exists + then canonicalizePath p + else return p + +-- | Get all module names that needed to be built by GHC; i.e., all +-- of these 'ModuleName's have interface files associated with them +-- that need to be installed. +allLibModules :: Library -> ComponentLocalBuildInfo -> [ModuleName] +allLibModules lib clbi = + ordNub $ + explicitLibModules lib ++ + case clbi of + LibComponentLocalBuildInfo { componentInstantiatedWith = insts } -> map fst insts + _ -> [] + +-- ----------------------------------------------------------------------------- +-- Wrappers for a couple functions from InstallDirs + +-- | Backwards compatibility function which computes the InstallDirs +-- assuming that @$libname@ points to the public library (or some fake +-- package identifier if there is no public library.) IF AT ALL +-- POSSIBLE, please use 'absoluteComponentInstallDirs' instead. +absoluteInstallDirs :: PackageDescription -> LocalBuildInfo + -> CopyDest + -> InstallDirs FilePath +absoluteInstallDirs pkg lbi copydest = + absoluteComponentInstallDirs pkg lbi (localUnitId lbi) copydest + +-- | See 'InstallDirs.absoluteInstallDirs'. +absoluteComponentInstallDirs :: PackageDescription -> LocalBuildInfo + -> UnitId + -> CopyDest + -> InstallDirs FilePath +absoluteComponentInstallDirs pkg lbi uid copydest = + InstallDirs.absoluteInstallDirs + (packageId pkg) + uid + (compilerInfo (compiler lbi)) + copydest + (hostPlatform lbi) + (installDirTemplates lbi) + +absoluteInstallCommandDirs :: PackageDescription -> LocalBuildInfo + -> UnitId + -> CopyDest + -> InstallDirs FilePath +absoluteInstallCommandDirs pkg lbi uid copydest = + dirs { + -- Handle files which are not + -- per-component (data files and Haddock files.) + datadir = datadir dirs', + -- NB: The situation with Haddock is a bit delicate. On the + -- one hand, the easiest to understand Haddock documentation + -- path is pkgname-0.1, which means it's per-package (not + -- per-component). But this means that it's impossible to + -- install Haddock documentation for internal libraries. We'll + -- keep this constraint for now; this means you can't use + -- Cabal to Haddock internal libraries. This does not seem + -- like a big problem. + docdir = docdir dirs', + htmldir = htmldir dirs', + haddockdir = haddockdir dirs' + } + where + dirs = absoluteComponentInstallDirs pkg lbi uid copydest + -- Notice use of 'absoluteInstallDirs' (not the + -- per-component variant). This means for non-library + -- packages we'll just pick a nondescriptive foo-0.1 + dirs' = absoluteInstallDirs pkg lbi copydest + +-- | Backwards compatibility function which computes the InstallDirs +-- assuming that @$libname@ points to the public library (or some fake +-- package identifier if there is no public library.) IF AT ALL +-- POSSIBLE, please use 'prefixRelativeComponentInstallDirs' instead. +prefixRelativeInstallDirs :: PackageId -> LocalBuildInfo + -> InstallDirs (Maybe FilePath) +prefixRelativeInstallDirs pkg_descr lbi = + prefixRelativeComponentInstallDirs pkg_descr lbi (localUnitId lbi) + +-- |See 'InstallDirs.prefixRelativeInstallDirs' +prefixRelativeComponentInstallDirs :: PackageId -> LocalBuildInfo + -> UnitId + -> InstallDirs (Maybe FilePath) +prefixRelativeComponentInstallDirs pkg_descr lbi uid = + InstallDirs.prefixRelativeInstallDirs + (packageId pkg_descr) + uid + (compilerInfo (compiler lbi)) + (hostPlatform lbi) + (installDirTemplates lbi) + +substPathTemplate :: PackageId -> LocalBuildInfo + -> UnitId + -> PathTemplate -> FilePath +substPathTemplate pkgid lbi uid = fromPathTemplate + . ( InstallDirs.substPathTemplate env ) + where env = initialPathTemplateEnv + pkgid + uid + (compilerInfo (compiler lbi)) + (hostPlatform lbi) + diff --git a/cabal/Cabal/src/Distribution/Simple/PackageDescription.hs b/cabal/Cabal/src/Distribution/Simple/PackageDescription.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/PackageDescription.hs @@ -0,0 +1,103 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.PackageDescription +-- Copyright : Isaac Jones 2003-2005 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This defines parsers for the @.cabal@ format + +module Distribution.Simple.PackageDescription ( + -- * Read and Parse files + readGenericPackageDescription, + readHookedBuildInfo, + + -- * Utility Parsing function + parseString, + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Fields.ParseResult +import Distribution.PackageDescription +import Distribution.PackageDescription.Parsec + ( parseGenericPackageDescription, parseHookedBuildInfo ) +import Distribution.Parsec.Error ( showPError ) +import Distribution.Parsec.Warning + ( PWarning(..), PWarnType(PWTExperimental), showPWarning ) +import Distribution.Simple.Utils ( equating, die', warn ) +import Distribution.Verbosity ( normal, Verbosity ) + +import Data.List ( groupBy ) +import Text.Printf ( printf ) +import qualified Data.ByteString as BS +import System.Directory (doesFileExist) + +readGenericPackageDescription :: Verbosity -> FilePath -> IO GenericPackageDescription +readGenericPackageDescription = readAndParseFile parseGenericPackageDescription + +readHookedBuildInfo :: Verbosity -> FilePath -> IO HookedBuildInfo +readHookedBuildInfo = readAndParseFile parseHookedBuildInfo + +-- | Helper combinator to do parsing plumbing for files. +-- +-- Given a parser and a filename, return the parse of the file, +-- after checking if the file exists. +-- +-- Argument order is chosen to encourage partial application. +readAndParseFile + :: (BS.ByteString -> ParseResult a) -- ^ File contents to final value parser + -> Verbosity -- ^ Verbosity level + -> FilePath -- ^ File to read + -> IO a +readAndParseFile parser verbosity fpath = do + exists <- doesFileExist fpath + unless exists $ + die' verbosity $ + "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue." + bs <- BS.readFile fpath + parseString parser verbosity fpath bs + +parseString + :: (BS.ByteString -> ParseResult a) -- ^ File contents to final value parser + -> Verbosity -- ^ Verbosity level + -> String -- ^ File name + -> BS.ByteString + -> IO a +parseString parser verbosity name bs = do + let (warnings, result) = runParseResult (parser bs) + traverse_ (warn verbosity . showPWarning name) (flattenDups verbosity warnings) + case result of + Right x -> return x + Left (_, errors) -> do + traverse_ (warn verbosity . showPError name) errors + die' verbosity $ "Failed parsing \"" ++ name ++ "\"." + +-- | Collapse duplicate experimental feature warnings into single warning, with +-- a count of further sites +flattenDups :: Verbosity -> [PWarning] -> [PWarning] +flattenDups verbosity ws + | verbosity <= normal = rest ++ experimentals + | otherwise = ws -- show all instances + where + (exps, rest) = partition (\(PWarning w _ _) -> w == PWTExperimental) ws + experimentals = + concatMap flatCount + . groupBy (equating warningStr) + . sortBy (comparing warningStr) + $ exps + + warningStr (PWarning _ _ w) = w + + -- flatten if we have 3 or more examples + flatCount :: [PWarning] -> [PWarning] + flatCount w@[] = w + flatCount w@[_] = w + flatCount w@[_,_] = w + flatCount (PWarning t pos w:xs) = + [PWarning t pos + (w <> printf " (and %d more occurrences)" (length xs)) + ] diff --git a/cabal/Cabal/src/Distribution/Simple/PackageIndex.hs b/cabal/Cabal/src/Distribution/Simple/PackageIndex.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/PackageIndex.hs @@ -0,0 +1,716 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.PackageIndex +-- Copyright : (c) David Himmelstrup 2005, +-- Bjorn Bringert 2007, +-- Duncan Coutts 2008-2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- An index of packages whose primary key is 'UnitId'. Public libraries +-- are additionally indexed by 'PackageName' and 'Version'. +-- Technically, these are an index of *units* (so we should eventually +-- rename it to 'UnitIndex'); but in the absence of internal libraries +-- or Backpack each unit is equivalent to a package. +-- +-- While 'PackageIndex' is parametric over what it actually records, +-- it is in fact only ever instantiated with a single element: +-- The 'InstalledPackageIndex' (defined here) contains a graph of +-- 'InstalledPackageInfo's representing the packages in a +-- package database stack. It is used in a variety of ways: +-- +-- * The primary use to let Cabal access the same installed +-- package database which is used by GHC during compilation. +-- For example, this data structure is used by 'ghc-pkg' +-- and 'Cabal' to do consistency checks on the database +-- (are the references closed). +-- +-- * Given a set of dependencies, we can compute the transitive +-- closure of dependencies. This is to check if the versions +-- of packages are consistent, and also needed by multiple +-- tools (Haddock must be explicitly told about the every +-- transitive package to do cross-package linking; +-- preprocessors must know about the include paths of all +-- transitive dependencies.) +-- +-- This 'PackageIndex' is NOT to be confused with +-- 'Distribution.Client.PackageIndex', which indexes packages only by +-- 'PackageName' (this makes it suitable for indexing source packages, +-- for which we don't know 'UnitId's.) +-- +module Distribution.Simple.PackageIndex ( + -- * Package index data type + InstalledPackageIndex, + PackageIndex, + + -- * Creating an index + fromList, + + -- * Updates + merge, + + insert, + + deleteUnitId, + deleteSourcePackageId, + deletePackageName, +-- deleteDependency, + + -- * Queries + + -- ** Precise lookups + lookupUnitId, + lookupComponentId, + lookupSourcePackageId, + lookupPackageId, + lookupPackageName, + lookupDependency, + lookupInternalDependency, + + -- ** Case-insensitive searches + searchByName, + SearchResult(..), + searchByNameSubstring, + searchWithPredicate, + + -- ** Bulk queries + allPackages, + allPackagesByName, + allPackagesBySourcePackageId, + allPackagesBySourcePackageIdAndLibName, + + -- ** Special queries + brokenPackages, + dependencyClosure, + reverseDependencyClosure, + topologicalOrder, + reverseTopologicalOrder, + dependencyInconsistencies, + dependencyCycles, + dependencyGraph, + moduleNameIndex + ) where + +import Prelude () +import Distribution.Compat.Prelude hiding (lookup) +import qualified Data.Map.Strict as Map + +import Distribution.Package +import Distribution.Backpack +import Distribution.ModuleName +import qualified Distribution.InstalledPackageInfo as IPI +import Distribution.Version +import Distribution.Simple.Utils +import Distribution.Types.LibraryName + +import Control.Exception (assert) +import Data.Array ((!)) +import qualified Data.Array as Array +import qualified Data.Graph as Graph +import Data.List as List ( groupBy, deleteBy, deleteFirstsBy ) +import qualified Data.List.NonEmpty as NE +import qualified Data.Tree as Tree +import Control.Monad +import Distribution.Compat.Stack + +import qualified Prelude (foldr1) + +-- | The collection of information about packages from one or more 'PackageDB's. +-- These packages generally should have an instance of 'PackageInstalled' +-- +-- Packages are uniquely identified in by their 'UnitId', they can +-- also be efficiently looked up by package name or by name and version. +-- +data PackageIndex a = PackageIndex { + -- The primary index. Each InstalledPackageInfo record is uniquely identified + -- by its UnitId. + -- + unitIdIndex :: !(Map UnitId a), + + -- This auxiliary index maps package names (case-sensitively) to all the + -- versions and instances of that package. This allows us to find all + -- versions satisfying a dependency. + -- + -- It is a three-level index. The first level is the package name, + -- the second is the package version and the final level is instances + -- of the same package version. These are unique by UnitId + -- and are kept in preference order. + -- + -- FIXME: Clarify what "preference order" means. Check that this invariant is + -- preserved. See #1463 for discussion. + packageIdIndex :: !(Map (PackageName, LibraryName) (Map Version [a])) + + } deriving (Eq, Generic, Show, Read, Typeable) + +instance Binary a => Binary (PackageIndex a) +instance Structured a => Structured (PackageIndex a) + +-- | The default package index which contains 'InstalledPackageInfo'. Normally +-- use this. +type InstalledPackageIndex = PackageIndex IPI.InstalledPackageInfo + +instance Monoid (PackageIndex IPI.InstalledPackageInfo) where + mempty = PackageIndex Map.empty Map.empty + mappend = (<>) + --save one mappend with empty in the common case: + mconcat [] = mempty + mconcat xs = Prelude.foldr1 mappend xs + +instance Semigroup (PackageIndex IPI.InstalledPackageInfo) where + (<>) = merge + +{-# NOINLINE invariant #-} +invariant :: WithCallStack (InstalledPackageIndex -> Bool) +invariant (PackageIndex pids pnames) = + -- trace (show pids' ++ "\n" ++ show pnames') $ + pids' == pnames' + where + pids' = map installedUnitId (Map.elems pids) + pnames' = sort + [ assert pinstOk (installedUnitId pinst) + | ((pname, plib), pvers) <- Map.toList pnames + , let pversOk = not (Map.null pvers) + , (pver, pinsts) <- assert pversOk $ Map.toList pvers + , let pinsts' = sortBy (comparing installedUnitId) pinsts + pinstsOk = all (\g -> length g == 1) + (groupBy (equating installedUnitId) pinsts') + , pinst <- assert pinstsOk $ pinsts' + , let pinstOk = packageName pinst == pname + && packageVersion pinst == pver + && IPI.sourceLibName pinst == plib + ] + -- If you see this invariant failing (ie the assert in mkPackageIndex below) + -- then one thing to check is if it is happening in fromList. Check if the + -- second list above (the sort [...] bit) is ending up with duplicates. This + -- has been observed in practice once due to a messed up ghc-pkg db. How/why + -- it became messed up was not discovered. + + +-- +-- * Internal helpers +-- + +mkPackageIndex :: WithCallStack (Map UnitId IPI.InstalledPackageInfo + -> Map (PackageName, LibraryName) + (Map Version [IPI.InstalledPackageInfo]) + -> InstalledPackageIndex) +mkPackageIndex pids pnames = assert (invariant index) index + where index = PackageIndex pids pnames + + +-- +-- * Construction +-- + +-- | Build an index out of a bunch of packages. +-- +-- If there are duplicates by 'UnitId' then later ones mask earlier +-- ones. +-- +fromList :: [IPI.InstalledPackageInfo] -> InstalledPackageIndex +fromList pkgs = mkPackageIndex pids ((fmap . fmap) toList pnames) + where + pids = Map.fromList [ (installedUnitId pkg, pkg) | pkg <- pkgs ] + pnames = + Map.fromList + [ (liftM2 (,) packageName IPI.sourceLibName (NE.head pkgsN), pvers) + | pkgsN <- NE.groupBy (equating (liftM2 (,) packageName IPI.sourceLibName)) + . sortBy (comparing (liftM3 (,,) packageName IPI.sourceLibName packageVersion)) + $ pkgs + , let pvers = + Map.fromList + [ (packageVersion (NE.head pkgsNV), + NE.nubBy (equating installedUnitId) (NE.reverse pkgsNV)) + | pkgsNV <- NE.groupBy (equating packageVersion) pkgsN + ] + ] + +-- +-- * Updates +-- + +-- | Merge two indexes. +-- +-- Packages from the second mask packages from the first if they have the exact +-- same 'UnitId'. +-- +-- For packages with the same source 'PackageId', packages from the second are +-- \"preferred\" over those from the first. Being preferred means they are top +-- result when we do a lookup by source 'PackageId'. This is the mechanism we +-- use to prefer user packages over global packages. +-- +merge :: InstalledPackageIndex -> InstalledPackageIndex + -> InstalledPackageIndex +merge (PackageIndex pids1 pnames1) (PackageIndex pids2 pnames2) = + mkPackageIndex (Map.unionWith (\_ y -> y) pids1 pids2) + (Map.unionWith (Map.unionWith mergeBuckets) pnames1 pnames2) + where + -- Packages in the second list mask those in the first, however preferred + -- packages go first in the list. + mergeBuckets xs ys = ys ++ (xs \\ ys) + (\\) = deleteFirstsBy (equating installedUnitId) + + +-- | Inserts a single package into the index. +-- +-- This is equivalent to (but slightly quicker than) using 'mappend' or +-- 'merge' with a singleton index. +-- +insert :: IPI.InstalledPackageInfo -> InstalledPackageIndex -> InstalledPackageIndex +insert pkg (PackageIndex pids pnames) = + mkPackageIndex pids' pnames' + + where + pids' = Map.insert (installedUnitId pkg) pkg pids + pnames' = insertPackageName pnames + insertPackageName = + Map.insertWith (\_ -> insertPackageVersion) + (packageName pkg, IPI.sourceLibName pkg) + (Map.singleton (packageVersion pkg) [pkg]) + + insertPackageVersion = + Map.insertWith (\_ -> insertPackageInstance) + (packageVersion pkg) [pkg] + + insertPackageInstance pkgs = + pkg : deleteBy (equating installedUnitId) pkg pkgs + + +-- | Removes a single installed package from the index. +-- +deleteUnitId :: UnitId -> InstalledPackageIndex + -> InstalledPackageIndex +deleteUnitId ipkgid original@(PackageIndex pids pnames) = + case Map.updateLookupWithKey (\_ _ -> Nothing) ipkgid pids of + (Nothing, _) -> original + (Just spkgid, pids') -> mkPackageIndex pids' + (deletePkgName spkgid pnames) + + where + deletePkgName spkgid = + Map.update (deletePkgVersion spkgid) (packageName spkgid, IPI.sourceLibName spkgid) + + deletePkgVersion spkgid = + (\m -> if Map.null m then Nothing else Just m) + . Map.update deletePkgInstance (packageVersion spkgid) + + deletePkgInstance = + (\xs -> if null xs then Nothing else Just xs) + . List.deleteBy (\_ pkg -> installedUnitId pkg == ipkgid) undefined + +-- | Removes all packages with this source 'PackageId' from the index. +-- +deleteSourcePackageId :: PackageId -> InstalledPackageIndex + -> InstalledPackageIndex +deleteSourcePackageId pkgid original@(PackageIndex pids pnames) = + -- NB: Doesn't delete internal packages + case Map.lookup (packageName pkgid, LMainLibName) pnames of + Nothing -> original + Just pvers -> case Map.lookup (packageVersion pkgid) pvers of + Nothing -> original + Just pkgs -> mkPackageIndex + (foldl' (flip (Map.delete . installedUnitId)) pids pkgs) + (deletePkgName pnames) + where + deletePkgName = + Map.update deletePkgVersion (packageName pkgid, LMainLibName) + + deletePkgVersion = + (\m -> if Map.null m then Nothing else Just m) + . Map.delete (packageVersion pkgid) + + +-- | Removes all packages with this (case-sensitive) name from the index. +-- +-- NB: Does NOT delete internal libraries from this package. +-- +deletePackageName :: PackageName -> InstalledPackageIndex + -> InstalledPackageIndex +deletePackageName name original@(PackageIndex pids pnames) = + case Map.lookup (name, LMainLibName) pnames of + Nothing -> original + Just pvers -> mkPackageIndex + (foldl' (flip (Map.delete . installedUnitId)) pids + (concat (Map.elems pvers))) + (Map.delete (name, LMainLibName) pnames) + +{- +-- | Removes all packages satisfying this dependency from the index. +-- +deleteDependency :: Dependency -> PackageIndex -> PackageIndex +deleteDependency (Dependency name verstionRange) = + delete' name (\pkg -> packageVersion pkg `withinRange` verstionRange) +-} + +-- +-- * Bulk queries +-- + +-- | Get all the packages from the index. +-- +allPackages :: PackageIndex a -> [a] +allPackages = Map.elems . unitIdIndex + +-- | Get all the packages from the index. +-- +-- They are grouped by package name (case-sensitively). +-- +-- (Doesn't include private libraries.) +-- +allPackagesByName :: PackageIndex a -> [(PackageName, [a])] +allPackagesByName index = + [ (pkgname, concat (Map.elems pvers)) + | ((pkgname, LMainLibName), pvers) <- Map.toList (packageIdIndex index) ] + +-- | Get all the packages from the index. +-- +-- They are grouped by source package id (package name and version). +-- +-- (Doesn't include private libraries) +-- +allPackagesBySourcePackageId :: HasUnitId a => PackageIndex a + -> [(PackageId, [a])] +allPackagesBySourcePackageId index = + [ (packageId ipkg, ipkgs) + | ((_, LMainLibName), pvers) <- Map.toList (packageIdIndex index) + , ipkgs@(ipkg:_) <- Map.elems pvers ] + +-- | Get all the packages from the index. +-- +-- They are grouped by source package id and library name. +-- +-- This DOES include internal libraries. +allPackagesBySourcePackageIdAndLibName :: HasUnitId a => PackageIndex a + -> [((PackageId, LibraryName), [a])] +allPackagesBySourcePackageIdAndLibName index = + [ ((packageId ipkg, ln), ipkgs) + | ((_, ln), pvers) <- Map.toList (packageIdIndex index) + , ipkgs@(ipkg:_) <- Map.elems pvers ] + +-- +-- * Lookups +-- + +-- | Does a lookup by unit identifier. +-- +-- Since multiple package DBs mask each other by 'UnitId', +-- then we get back at most one package. +-- +lookupUnitId :: PackageIndex a -> UnitId + -> Maybe a +lookupUnitId index uid = Map.lookup uid (unitIdIndex index) + +-- | Does a lookup by component identifier. In the absence +-- of Backpack, this is just a 'lookupUnitId'. +-- +lookupComponentId :: PackageIndex a -> ComponentId + -> Maybe a +lookupComponentId index cid = + Map.lookup (newSimpleUnitId cid) (unitIdIndex index) + +-- | Does a lookup by source package id (name & version). +-- +-- There can be multiple installed packages with the same source 'PackageId' +-- but different 'UnitId'. They are returned in order of +-- preference, with the most preferred first. +-- +lookupSourcePackageId :: PackageIndex a -> PackageId -> [a] +lookupSourcePackageId index pkgid = + -- Do not lookup internal libraries + case Map.lookup (packageName pkgid, LMainLibName) (packageIdIndex index) of + Nothing -> [] + Just pvers -> case Map.lookup (packageVersion pkgid) pvers of + Nothing -> [] + Just pkgs -> pkgs -- in preference order + +-- | Convenient alias of 'lookupSourcePackageId', but assuming only +-- one package per package ID. +lookupPackageId :: PackageIndex a -> PackageId -> Maybe a +lookupPackageId index pkgid = case lookupSourcePackageId index pkgid of + [] -> Nothing + [pkg] -> Just pkg + _ -> error "Distribution.Simple.PackageIndex: multiple matches found" + +-- | Does a lookup by source package name. +-- +lookupPackageName :: PackageIndex a -> PackageName + -> [(Version, [a])] +lookupPackageName index name = + -- Do not match internal libraries + case Map.lookup (name, LMainLibName) (packageIdIndex index) of + Nothing -> [] + Just pvers -> Map.toList pvers + + +-- | Does a lookup by source package name and a range of versions. +-- +-- We get back any number of versions of the specified package name, all +-- satisfying the version range constraint. +-- +-- This does NOT work for internal dependencies, DO NOT use this +-- function on those; use 'lookupInternalDependency' instead. +-- +-- INVARIANT: List of eligible 'IPI.InstalledPackageInfo' is non-empty. +-- +lookupDependency :: InstalledPackageIndex -> PackageName -> VersionRange + -> [(Version, [IPI.InstalledPackageInfo])] +lookupDependency index pn vr = + -- Yes, a little bit of a misnomer here! + lookupInternalDependency index pn vr LMainLibName + +-- | Does a lookup by source package name and a range of versions. +-- +-- We get back any number of versions of the specified package name, all +-- satisfying the version range constraint. +-- +-- INVARIANT: List of eligible 'IPI.InstalledPackageInfo' is non-empty. +-- +lookupInternalDependency :: InstalledPackageIndex -> PackageName -> VersionRange + -> LibraryName + -> [(Version, [IPI.InstalledPackageInfo])] +lookupInternalDependency index name versionRange libn = + case Map.lookup (name, libn) (packageIdIndex index) of + Nothing -> [] + Just pvers -> [ (ver, pkgs') + | (ver, pkgs) <- Map.toList pvers + , ver `withinRange` versionRange + , let pkgs' = filter eligible pkgs + -- Enforce the invariant + , not (null pkgs') + ] + where + -- When we select for dependencies, we ONLY want to pick up indefinite + -- packages, or packages with no instantiations. We'll do mix-in + -- linking to improve any such package into an instantiated one + -- later. + eligible pkg = IPI.indefinite pkg || null (IPI.instantiatedWith pkg) + + +-- +-- * Case insensitive name lookups +-- + +-- | Does a case-insensitive search by package name. +-- +-- If there is only one package that compares case-insensitively to this name +-- then the search is unambiguous and we get back all versions of that package. +-- If several match case-insensitively but one matches exactly then it is also +-- unambiguous. +-- +-- If however several match case-insensitively and none match exactly then we +-- have an ambiguous result, and we get back all the versions of all the +-- packages. The list of ambiguous results is split by exact package name. So +-- it is a non-empty list of non-empty lists. +-- +searchByName :: PackageIndex a -> String -> SearchResult [a] +searchByName index name = + -- Don't match internal packages + case [ pkgs | pkgs@((pname, LMainLibName),_) <- Map.toList (packageIdIndex index) + , lowercase (unPackageName pname) == lname ] of + [] -> None + [(_,pvers)] -> Unambiguous (concat (Map.elems pvers)) + pkgss -> case find ((mkPackageName name ==) . fst . fst) pkgss of + Just (_,pvers) -> Unambiguous (concat (Map.elems pvers)) + Nothing -> Ambiguous (map (concat . Map.elems . snd) pkgss) + where lname = lowercase name + +data SearchResult a = None | Unambiguous a | Ambiguous [a] + +-- | Does a case-insensitive substring search by package name. +-- +-- That is, all packages that contain the given string in their name. +-- +searchByNameSubstring :: PackageIndex a -> String -> [a] +searchByNameSubstring index searchterm = + searchWithPredicate index (\n -> lsearchterm `isInfixOf` lowercase n) + where lsearchterm = lowercase searchterm + +-- | @since 3.4.0.0 +searchWithPredicate :: PackageIndex a -> (String -> Bool) -> [a] +searchWithPredicate index predicate = + [ pkg + -- Don't match internal packages + | ((pname, LMainLibName), pvers) <- Map.toList (packageIdIndex index) + , predicate (unPackageName pname) + , pkgs <- Map.elems pvers + , pkg <- pkgs ] + +-- +-- * Special queries +-- + +-- None of the stuff below depends on the internal representation of the index. +-- + +-- | Find if there are any cycles in the dependency graph. If there are no +-- cycles the result is @[]@. +-- +-- This actually computes the strongly connected components. So it gives us a +-- list of groups of packages where within each group they all depend on each +-- other, directly or indirectly. +-- +dependencyCycles :: PackageInstalled a => PackageIndex a -> [[a]] +dependencyCycles index = + [ vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList ] + where + adjacencyList = [ (pkg, installedUnitId pkg, installedDepends pkg) + | pkg <- allPackages index ] + + +-- | All packages that have immediate dependencies that are not in the index. +-- +-- Returns such packages along with the dependencies that they're missing. +-- +brokenPackages :: PackageInstalled a => PackageIndex a + -> [(a, [UnitId])] +brokenPackages index = + [ (pkg, missing) + | pkg <- allPackages index + , let missing = [ pkg' | pkg' <- installedDepends pkg + , isNothing (lookupUnitId index pkg') ] + , not (null missing) ] + +-- | Tries to take the transitive closure of the package dependencies. +-- +-- If the transitive closure is complete then it returns that subset of the +-- index. Otherwise it returns the broken packages as in 'brokenPackages'. +-- +-- * Note that if the result is @Right []@ it is because at least one of +-- the original given 'PackageId's do not occur in the index. +-- +dependencyClosure :: InstalledPackageIndex + -> [UnitId] + -> Either (InstalledPackageIndex) + [(IPI.InstalledPackageInfo, [UnitId])] +dependencyClosure index pkgids0 = case closure mempty [] pkgids0 of + (completed, []) -> Left completed + (completed, _) -> Right (brokenPackages completed) + where + closure completed failed [] = (completed, failed) + closure completed failed (pkgid:pkgids) = case lookupUnitId index pkgid of + Nothing -> closure completed (pkgid:failed) pkgids + Just pkg -> case lookupUnitId completed (installedUnitId pkg) of + Just _ -> closure completed failed pkgids + Nothing -> closure completed' failed pkgids' + where completed' = insert pkg completed + pkgids' = installedDepends pkg ++ pkgids + +-- | Takes the transitive closure of the packages reverse dependencies. +-- +-- * The given 'PackageId's must be in the index. +-- +reverseDependencyClosure :: PackageInstalled a => PackageIndex a + -> [UnitId] + -> [a] +reverseDependencyClosure index = + map vertexToPkg + . concatMap Tree.flatten + . Graph.dfs reverseDepGraph + . map (fromMaybe noSuchPkgId . pkgIdToVertex) + + where + (depGraph, vertexToPkg, pkgIdToVertex) = dependencyGraph index + reverseDepGraph = Graph.transposeG depGraph + noSuchPkgId = error "reverseDependencyClosure: package is not in the graph" + +topologicalOrder :: PackageInstalled a => PackageIndex a -> [a] +topologicalOrder index = map toPkgId + . Graph.topSort + $ graph + where (graph, toPkgId, _) = dependencyGraph index + +reverseTopologicalOrder :: PackageInstalled a => PackageIndex a -> [a] +reverseTopologicalOrder index = map toPkgId + . Graph.topSort + . Graph.transposeG + $ graph + where (graph, toPkgId, _) = dependencyGraph index + +-- | Builds a graph of the package dependencies. +-- +-- Dependencies on other packages that are not in the index are discarded. +-- You can check if there are any such dependencies with 'brokenPackages'. +-- +dependencyGraph :: PackageInstalled a => PackageIndex a + -> (Graph.Graph, + Graph.Vertex -> a, + UnitId -> Maybe Graph.Vertex) +dependencyGraph index = (graph, vertex_to_pkg, id_to_vertex) + where + graph = Array.listArray bounds + [ [ v | Just v <- map id_to_vertex (installedDepends pkg) ] + | pkg <- pkgs ] + + pkgs = sortBy (comparing packageId) (allPackages index) + vertices = zip (map installedUnitId pkgs) [0..] + vertex_map = Map.fromList vertices + id_to_vertex pid = Map.lookup pid vertex_map + + vertex_to_pkg vertex = pkgTable ! vertex + + pkgTable = Array.listArray bounds pkgs + topBound = length pkgs - 1 + bounds = (0, topBound) + +-- | We maintain the invariant that, for any 'DepUniqueKey', there +-- is only one instance of the package in our database. +type DepUniqueKey = (PackageName, LibraryName, Map ModuleName OpenModule) + +-- | Given a package index where we assume we want to use all the packages +-- (use 'dependencyClosure' if you need to get such a index subset) find out +-- if the dependencies within it use consistent versions of each package. +-- Return all cases where multiple packages depend on different versions of +-- some other package. +-- +-- Each element in the result is a package name along with the packages that +-- depend on it and the versions they require. These are guaranteed to be +-- distinct. +-- +dependencyInconsistencies :: InstalledPackageIndex + -- At DepUniqueKey... + -> [(DepUniqueKey, + -- There were multiple packages (BAD!) + [(UnitId, + -- And here are the packages which + -- immediately depended on it + [IPI.InstalledPackageInfo])])] +dependencyInconsistencies index = do + (dep_key, insts_map) <- Map.toList inverseIndex + let insts = Map.toList insts_map + guard (length insts >= 2) + return (dep_key, insts) + where + inverseIndex :: Map DepUniqueKey (Map UnitId [IPI.InstalledPackageInfo]) + inverseIndex = Map.fromListWith (Map.unionWith (++)) $ do + pkg <- allPackages index + dep_ipid <- installedDepends pkg + Just dep <- [lookupUnitId index dep_ipid] + let dep_key = (packageName dep, IPI.sourceLibName dep, + Map.fromList (IPI.instantiatedWith dep)) + return (dep_key, Map.singleton dep_ipid [pkg]) + +-- | A rough approximation of GHC's module finder, takes a +-- 'InstalledPackageIndex' and turns it into a map from module names to their +-- source packages. It's used to initialize the @build-deps@ field in @cabal +-- init@. +moduleNameIndex :: InstalledPackageIndex -> Map ModuleName [IPI.InstalledPackageInfo] +moduleNameIndex index = + Map.fromListWith (++) $ do + pkg <- allPackages index + IPI.ExposedModule m reexport <- IPI.exposedModules pkg + case reexport of + Nothing -> return (m, [pkg]) + Just (OpenModuleVar _) -> [] + Just (OpenModule _ m') | m == m' -> [] + | otherwise -> return (m', [pkg]) + -- The heuristic is this: we want to prefer the original package + -- which originally exported a module. However, if a reexport + -- also *renamed* the module (m /= m'), then we have to use the + -- downstream package, since the upstream package has the wrong + -- module name! diff --git a/cabal/Cabal/src/Distribution/Simple/PreProcess.hs b/cabal/Cabal/src/Distribution/Simple/PreProcess.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/PreProcess.hs @@ -0,0 +1,839 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.PreProcess +-- Copyright : (c) 2003-2005, Isaac Jones, Malcolm Wallace +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This defines a 'PreProcessor' abstraction which represents a pre-processor +-- that can transform one kind of file into another. There is also a +-- 'PPSuffixHandler' which is a combination of a file extension and a function +-- for configuring a 'PreProcessor'. It defines a bunch of known built-in +-- preprocessors like @cpp@, @cpphs@, @c2hs@, @hsc2hs@, @happy@, @alex@ etc and +-- lists them in 'knownSuffixHandlers'. On top of this it provides a function +-- for actually preprocessing some sources given a bunch of known suffix +-- handlers. This module is not as good as it could be, it could really do with +-- a rewrite to address some of the problems we have with pre-processors. + +module Distribution.Simple.PreProcess (preprocessComponent, preprocessExtras, + knownSuffixHandlers, ppSuffixes, + PPSuffixHandler, PreProcessor(..), + mkSimplePreProcessor, runSimplePreProcessor, + ppCpp, ppCpp', ppGreenCard, ppC2hs, ppHsc2hs, + ppHappy, ppAlex, ppUnlit, platformDefines, + unsorted + ) + where + +import Prelude () +import Distribution.Compat.Prelude +import Distribution.Compat.Stack + +import Distribution.Simple.PreProcess.Unlit +import Distribution.Backpack.DescribeUnitId +import Distribution.Package +import qualified Distribution.ModuleName as ModuleName +import Distribution.ModuleName (ModuleName) +import Distribution.PackageDescription as PD +import qualified Distribution.InstalledPackageInfo as Installed +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.CCompiler +import Distribution.Simple.Compiler +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.BuildPaths +import Distribution.Simple.Utils +import Distribution.Simple.Program +import Distribution.Simple.Program.ResponseFile +import Distribution.Simple.Test.LibV09 +import Distribution.System +import Distribution.Types.PackageName.Magic +import Distribution.Pretty +import Distribution.Version +import Distribution.Verbosity +import Distribution.Utils.Path + +import System.Directory (doesFileExist, doesDirectoryExist) +import System.Info (os, arch) +import System.FilePath (splitExtension, dropExtensions, (), (<.>), + takeDirectory, normalise, replaceExtension, + takeExtensions) + +-- |The interface to a preprocessor, which may be implemented using an +-- external program, but need not be. The arguments are the name of +-- the input file, the name of the output file and a verbosity level. +-- Here is a simple example that merely prepends a comment to the given +-- source file: +-- +-- > ppTestHandler :: PreProcessor +-- > ppTestHandler = +-- > PreProcessor { +-- > platformIndependent = True, +-- > runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> +-- > do info verbosity (inFile++" has been preprocessed to "++outFile) +-- > stuff <- readFile inFile +-- > writeFile outFile ("-- preprocessed as a test\n\n" ++ stuff) +-- > return ExitSuccess +-- +-- We split the input and output file names into a base directory and the +-- rest of the file name. The input base dir is the path in the list of search +-- dirs that this file was found in. The output base dir is the build dir where +-- all the generated source files are put. +-- +-- The reason for splitting it up this way is that some pre-processors don't +-- simply generate one output .hs file from one input file but have +-- dependencies on other generated files (notably c2hs, where building one +-- .hs file may require reading other .chi files, and then compiling the .hs +-- file may require reading a generated .h file). In these cases the generated +-- files need to embed relative path names to each other (eg the generated .hs +-- file mentions the .h file in the FFI imports). This path must be relative to +-- the base directory where the generated files are located, it cannot be +-- relative to the top level of the build tree because the compilers do not +-- look for .h files relative to there, ie we do not use \"-I .\", instead we +-- use \"-I dist\/build\" (or whatever dist dir has been set by the user) +-- +-- Most pre-processors do not care of course, so mkSimplePreProcessor and +-- runSimplePreProcessor functions handle the simple case. +-- +data PreProcessor = PreProcessor { + + -- Is the output of the pre-processor platform independent? eg happy output + -- is portable haskell but c2hs's output is platform dependent. + -- This matters since only platform independent generated code can be + -- included into a source tarball. + platformIndependent :: Bool, + + -- TODO: deal with pre-processors that have implementation dependent output + -- eg alex and happy have --ghc flags. However we can't really include + -- ghc-specific code into supposedly portable source tarballs. + + -- | This function can reorder /all/ modules, not just those that the + -- require the preprocessor in question. As such, this function should be + -- well-behaved and not reorder modules it doesn't have dominion over! + ppOrdering :: Verbosity + -> [FilePath] -- Source directories + -> [ModuleName] -- Module names + -> IO [ModuleName], -- Sorted modules + + runPreProcessor :: (FilePath, FilePath) -- Location of the source file relative to a base dir + -> (FilePath, FilePath) -- Output file name, relative to an output base dir + -> Verbosity -- verbosity + -> IO () -- Should exit if the preprocessor fails + } + +-- | Just present the modules in the order given; this is the default and it is +-- appropriate for preprocessors which do not have any sort of dependencies +-- between modules. +unsorted :: Verbosity + -> [FilePath] + -> [ModuleName] + -> IO [ModuleName] +unsorted _ _ ms = pure ms + +-- | Function to determine paths to possible extra C sources for a +-- preprocessor: just takes the path to the build directory and uses +-- this to search for C sources with names that match the +-- preprocessor's output name format. +type PreProcessorExtras = FilePath -> IO [FilePath] + + +mkSimplePreProcessor :: (FilePath -> FilePath -> Verbosity -> IO ()) + -> (FilePath, FilePath) + -> (FilePath, FilePath) -> Verbosity -> IO () +mkSimplePreProcessor simplePP + (inBaseDir, inRelativeFile) + (outBaseDir, outRelativeFile) verbosity = simplePP inFile outFile verbosity + where inFile = normalise (inBaseDir inRelativeFile) + outFile = normalise (outBaseDir outRelativeFile) + +runSimplePreProcessor :: PreProcessor -> FilePath -> FilePath -> Verbosity + -> IO () +runSimplePreProcessor pp inFile outFile verbosity = + runPreProcessor pp (".", inFile) (".", outFile) verbosity + +-- |A preprocessor for turning non-Haskell files with the given extension +-- into plain Haskell source files. +type PPSuffixHandler + = (String, BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor) + +-- | Apply preprocessors to the sources from 'hsSourceDirs' for a given +-- component (lib, exe, or test suite). +-- +-- XXX: This is terrible +preprocessComponent :: PackageDescription + -> Component + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Bool + -> Verbosity + -> [PPSuffixHandler] + -> IO () +preprocessComponent pd comp lbi clbi isSrcDist verbosity handlers = + -- Skip preprocessing for scripts since they should be regular Haskell files, + -- but may have no or unknown extensions. + when (package pd /= fakePackageId) $ do + -- NB: never report instantiation here; we'll report it properly when + -- building. + setupMessage' verbosity "Preprocessing" (packageId pd) + (componentLocalName clbi) (Nothing :: Maybe [(ModuleName, Module)]) + case comp of + (CLib lib@Library{ libBuildInfo = bi }) -> do + let dirs = map getSymbolicPath (hsSourceDirs bi) ++ + [ autogenComponentModulesDir lbi clbi ,autogenPackageModulesDir lbi] + let hndlrs = localHandlers bi + mods <- orderingFromHandlers verbosity dirs hndlrs (allLibModules lib clbi) + for_ (map ModuleName.toFilePath mods) $ + pre dirs (componentBuildDir lbi clbi) hndlrs + (CFLib flib@ForeignLib { foreignLibBuildInfo = bi, foreignLibName = nm }) -> do + let nm' = unUnqualComponentName nm + let flibDir = buildDir lbi nm' nm' ++ "-tmp" + dirs = map getSymbolicPath (hsSourceDirs bi) ++ [autogenComponentModulesDir lbi clbi + ,autogenPackageModulesDir lbi] + let hndlrs = localHandlers bi + mods <- orderingFromHandlers verbosity dirs hndlrs (foreignLibModules flib) + for_ (map ModuleName.toFilePath mods) $ + pre dirs flibDir hndlrs + (CExe exe@Executable { buildInfo = bi, exeName = nm }) -> do + let nm' = unUnqualComponentName nm + let exeDir = buildDir lbi nm' nm' ++ "-tmp" + dirs = map getSymbolicPath (hsSourceDirs bi) ++ [autogenComponentModulesDir lbi clbi + ,autogenPackageModulesDir lbi] + let hndlrs = localHandlers bi + mods <- orderingFromHandlers verbosity dirs hndlrs (otherModules bi) + for_ (map ModuleName.toFilePath mods) $ + pre dirs exeDir hndlrs + pre (map getSymbolicPath (hsSourceDirs bi)) exeDir (localHandlers bi) $ + dropExtensions (modulePath exe) + CTest test@TestSuite{ testName = nm } -> do + let nm' = unUnqualComponentName nm + case testInterface test of + TestSuiteExeV10 _ f -> + preProcessTest test f $ buildDir lbi nm' nm' ++ "-tmp" + TestSuiteLibV09 _ _ -> do + let testDir = buildDir lbi stubName test + stubName test ++ "-tmp" + writeSimpleTestStub test testDir + preProcessTest test (stubFilePath test) testDir + TestSuiteUnsupported tt -> + die' verbosity $ "No support for preprocessing test " + ++ "suite type " ++ prettyShow tt + CBench bm@Benchmark{ benchmarkName = nm } -> do + let nm' = unUnqualComponentName nm + case benchmarkInterface bm of + BenchmarkExeV10 _ f -> + preProcessBench bm f $ buildDir lbi nm' nm' ++ "-tmp" + BenchmarkUnsupported tt -> + die' verbosity $ "No support for preprocessing benchmark " + ++ "type " ++ prettyShow tt + where + orderingFromHandlers v d hndlrs mods = + foldM (\acc (_,pp) -> ppOrdering pp v d acc) mods hndlrs + builtinHaskellSuffixes = ["hs", "lhs", "hsig", "lhsig"] + builtinCSuffixes = cSourceExtensions + builtinSuffixes = builtinHaskellSuffixes ++ builtinCSuffixes + localHandlers bi = [(ext, h bi lbi clbi) | (ext, h) <- handlers] + pre dirs dir lhndlrs fp = + preprocessFile (map unsafeMakeSymbolicPath dirs) dir isSrcDist fp verbosity builtinSuffixes lhndlrs True + preProcessTest test = preProcessComponent (testBuildInfo test) + (testModules test) + preProcessBench bm = preProcessComponent (benchmarkBuildInfo bm) + (benchmarkModules bm) + + preProcessComponent + :: BuildInfo + -> [ModuleName] + -> FilePath + -> FilePath + -> IO () + preProcessComponent bi modules exePath dir = do + let biHandlers = localHandlers bi + sourceDirs = map getSymbolicPath (hsSourceDirs bi) ++ [ autogenComponentModulesDir lbi clbi + , autogenPackageModulesDir lbi ] + sequence_ [ preprocessFile (map unsafeMakeSymbolicPath sourceDirs) dir isSrcDist + (ModuleName.toFilePath modu) verbosity builtinSuffixes + biHandlers False + | modu <- modules ] + -- XXX: what we do here (re SymbolicPath dir) + -- XXX: 2020-10-15 do we rely here on CWD being the PackageDir? + -- Note we don't fail on missing in this case, because the main file may be generated later (i.e. by a test code generator) + preprocessFile (unsafeMakeSymbolicPath dir : hsSourceDirs bi) dir isSrcDist + (dropExtensions $ exePath) verbosity + builtinSuffixes biHandlers False + +--TODO: try to list all the modules that could not be found +-- not just the first one. It's annoying and slow due to the need +-- to reconfigure after editing the .cabal file each time. + +-- | Find the first extension of the file that exists, and preprocess it +-- if required. +preprocessFile + :: [SymbolicPath PackageDir SourceDir] -- ^ source directories + + -> FilePath -- ^build directory + -> Bool -- ^preprocess for sdist + -> FilePath -- ^module file name + -> Verbosity -- ^verbosity + -> [String] -- ^builtin suffixes + -> [(String, PreProcessor)] -- ^possible preprocessors + -> Bool -- ^fail on missing file + -> IO () +preprocessFile 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 <- findFileWithExtension' (map fst handlers) (map getSymbolicPath searchLoc) baseFile + case psrcFiles of + -- no preprocessor file exists, look for an ordinary source file + -- just to make sure one actually exists at all for this module. + -- Note: by looking in the target/output build dir too, we allow + -- source files to appear magically in the target build dir without + -- any corresponding "real" source file. This lets custom Setup.hs + -- files generate source modules directly into the build dir without + -- the rest of the build system being aware of it (somewhat dodgy) + Nothing -> do + bsrcFiles <- findFileWithExtension builtinSuffixes (buildLoc : map getSymbolicPath searchLoc) baseFile + case (bsrcFiles, failOnMissing) of + (Nothing, True) -> + die' verbosity $ "can't find source for " ++ baseFile + ++ " in " ++ intercalate ", " (map getSymbolicPath searchLoc) + _ -> return () + -- found a pre-processable file in one of the source dirs + Just (psrcLoc, psrcRelFile) -> do + let (srcStem, ext) = splitExtension psrcRelFile + psrcFile = psrcLoc psrcRelFile + pp = fromMaybe (error "Distribution.Simple.PreProcess: Just expected") + (lookup (safeTail ext) handlers) + -- Preprocessing files for 'sdist' is different from preprocessing + -- for 'build'. When preprocessing for sdist we preprocess to + -- avoid that the user has to have the preprocessors available. + -- ATM, we don't have a way to specify which files are to be + -- preprocessed and which not, so for sdist we only process + -- platform independent files and put them into the 'buildLoc' + -- (which we assume is set to the temp. directory that will become + -- the tarball). + --TODO: eliminate sdist variant, just supply different handlers + when (not forSDist || forSDist && platformIndependent pp) $ do + -- look for existing pre-processed source file in the dest dir to + -- see if we really have to re-run the preprocessor. + ppsrcFiles <- findFileWithExtension builtinSuffixes [buildLoc] baseFile + recomp <- case ppsrcFiles of + Nothing -> return True + Just ppsrcFile -> + psrcFile `moreRecentFile` ppsrcFile + when recomp $ do + let destDir = buildLoc dirName srcStem + createDirectoryIfMissingVerbose verbosity True destDir + runPreProcessorWithHsBootHack pp + (psrcLoc, psrcRelFile) + (buildLoc, srcStem <.> "hs") + + where + dirName = takeDirectory + + -- FIXME: This is a somewhat nasty hack. GHC requires that hs-boot files + -- be in the same place as the hs files, so if we put the hs file in dist/ + -- then we need to copy the hs-boot file there too. This should probably be + -- done another way. Possibly we should also be looking for .lhs-boot + -- files, but I think that preprocessors only produce .hs files. + runPreProcessorWithHsBootHack pp + (inBaseDir, inRelativeFile) + (outBaseDir, outRelativeFile) = do + runPreProcessor pp + (inBaseDir, inRelativeFile) + (outBaseDir, outRelativeFile) verbosity + + exists <- doesFileExist inBoot + when exists $ copyFileVerbose verbosity inBoot outBoot + + where + inBoot = replaceExtension inFile "hs-boot" + outBoot = replaceExtension outFile "hs-boot" + + inFile = normalise (inBaseDir inRelativeFile) + outFile = normalise (outBaseDir outRelativeFile) + +-- ------------------------------------------------------------ +-- * known preprocessors +-- ------------------------------------------------------------ + +ppGreenCard :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor +ppGreenCard _ lbi _ + = PreProcessor { + platformIndependent = False, + ppOrdering = unsorted, + runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> + runDbProgram verbosity greencardProgram (withPrograms lbi) + (["-tffi", "-o" ++ outFile, inFile]) + } + +-- This one is useful for preprocessors that can't handle literate source. +-- We also need a way to chain preprocessors. +ppUnlit :: PreProcessor +ppUnlit = + PreProcessor { + platformIndependent = True, + ppOrdering = unsorted, + runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> + withUTF8FileContents inFile $ \contents -> + either (writeUTF8File outFile) (die' verbosity) (unlit inFile contents) + } + +ppCpp :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor +ppCpp = ppCpp' [] + +ppCpp' :: [String] -> BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor +ppCpp' extraArgs bi lbi clbi = + case compilerFlavor (compiler lbi) of + GHC -> ppGhcCpp ghcProgram (const True) args bi lbi clbi + GHCJS -> ppGhcCpp ghcjsProgram (const True) args bi lbi clbi + _ -> ppCpphs args bi lbi clbi + where cppArgs = getCppOptions bi lbi + args = cppArgs ++ extraArgs + +ppGhcCpp :: Program -> (Version -> Bool) + -> [String] -> BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor +ppGhcCpp program xHs extraArgs _bi lbi clbi = + PreProcessor { + platformIndependent = False, + ppOrdering = unsorted, + runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do + (prog, version, _) <- requireProgramVersion verbosity + program anyVersion (withPrograms lbi) + runProgram verbosity prog $ + ["-E", "-cpp"] + -- This is a bit of an ugly hack. We're going to + -- unlit the file ourselves later on if appropriate, + -- so we need GHC not to unlit it now or it'll get + -- double-unlitted. In the future we might switch to + -- using cpphs --unlit instead. + ++ (if xHs version then ["-x", "hs"] else []) + ++ [ "-optP-include", "-optP"++ (autogenComponentModulesDir lbi clbi cppHeaderName) ] + ++ ["-o", outFile, inFile] + ++ extraArgs + } + +ppCpphs :: [String] -> BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor +ppCpphs extraArgs _bi lbi clbi = + PreProcessor { + platformIndependent = False, + ppOrdering = unsorted, + runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do + (cpphsProg, cpphsVersion, _) <- requireProgramVersion verbosity + cpphsProgram anyVersion (withPrograms lbi) + runProgram verbosity cpphsProg $ + ("-O" ++ outFile) : inFile + : "--noline" : "--strip" + : (if cpphsVersion >= mkVersion [1,6] + then ["--include="++ (autogenComponentModulesDir lbi clbi cppHeaderName)] + else []) + ++ extraArgs + } + +ppHsc2hs :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor +ppHsc2hs bi lbi clbi = + PreProcessor { + platformIndependent = False, + ppOrdering = unsorted, + runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do + (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi) + (hsc2hsProg, hsc2hsVersion, _) <- requireProgramVersion verbosity + hsc2hsProgram anyVersion (withPrograms lbi) + -- See Trac #13896 and https://github.com/haskell/cabal/issues/3122. + let isCross = hostPlatform lbi /= buildPlatform + prependCrossFlags = if isCross then ("-x":) else id + let hsc2hsSupportsResponseFiles = hsc2hsVersion >= mkVersion [0,68,4] + pureArgs = genPureArgs hsc2hsVersion gccProg inFile outFile + if hsc2hsSupportsResponseFiles + then withResponseFile + verbosity + defaultTempFileOptions + (takeDirectory outFile) + "hsc2hs-response.txt" + Nothing + pureArgs + (\responseFileName -> + runProgram verbosity hsc2hsProg (prependCrossFlags ["@"++ responseFileName])) + else runProgram verbosity hsc2hsProg (prependCrossFlags pureArgs) + } + where + -- Returns a list of command line arguments that can either be passed + -- directly, or via a response file. + genPureArgs :: Version -> ConfiguredProgram -> String -> String -> [String] + genPureArgs hsc2hsVersion gccProg inFile outFile = + -- Additional gcc options + [ "--cflag=" ++ opt | opt <- programDefaultArgs gccProg + ++ programOverrideArgs gccProg ] + ++ [ "--lflag=" ++ opt | opt <- programDefaultArgs gccProg + ++ programOverrideArgs gccProg ] + + -- OSX frameworks: + ++ [ what ++ "=-F" ++ opt + | isOSX + , opt <- nub (concatMap Installed.frameworkDirs pkgs) + , what <- ["--cflag", "--lflag"] ] + ++ [ "--lflag=" ++ arg + | isOSX + , opt <- PD.frameworks bi ++ concatMap Installed.frameworks pkgs + , arg <- ["-framework", opt] ] + + -- Note that on ELF systems, wherever we use -L, we must also use -R + -- because presumably that -L dir is not on the normal path for the + -- system's dynamic linker. This is needed because hsc2hs works by + -- compiling a C program and then running it. + + ++ [ "--cflag=" ++ opt | opt <- platformDefines lbi ] + + -- Options from the current package: + ++ [ "--cflag=-I" ++ dir | dir <- PD.includeDirs bi ] + ++ [ "--cflag=-I" ++ buildDir lbi dir | dir <- PD.includeDirs bi ] + ++ [ "--cflag=" ++ opt | opt <- PD.ccOptions bi + ++ PD.cppOptions bi + -- hsc2hs uses the C ABI + -- We assume that there are only C sources + -- and C++ functions are exported via a C + -- interface and wrapped in a C source file. + -- Therefore we do not supply C++ flags + -- because there will not be C++ sources. + -- + -- DO NOT add PD.cxxOptions unless this changes! + ] + ++ [ "--cflag=" ++ opt | opt <- + [ "-I" ++ autogenComponentModulesDir lbi clbi, + "-I" ++ autogenPackageModulesDir lbi, + "-include", autogenComponentModulesDir lbi clbi cppHeaderName ] ] + ++ [ "--lflag=-L" ++ opt + | opt <- + if withFullyStaticExe lbi + then PD.extraLibDirsStatic bi + else PD.extraLibDirs bi + ] + ++ [ "--lflag=-Wl,-R," ++ opt + | isELF + , opt <- + if withFullyStaticExe lbi + then PD.extraLibDirsStatic bi + else PD.extraLibDirs bi + ] + ++ [ "--lflag=-l" ++ opt | opt <- PD.extraLibs bi ] + ++ [ "--lflag=" ++ opt | opt <- PD.ldOptions bi ] + + -- Options from dependent packages + ++ [ "--cflag=" ++ opt + | pkg <- pkgs + , opt <- [ "-I" ++ opt | opt <- Installed.includeDirs pkg ] + ++ [ opt | opt <- Installed.ccOptions pkg ] ] + ++ [ "--lflag=" ++ opt + | pkg <- pkgs + , opt <- [ "-L" ++ opt | opt <- Installed.libraryDirs pkg ] + ++ [ "-Wl,-R," ++ opt | isELF + , opt <- Installed.libraryDirs pkg ] + ++ [ "-l" ++ opt + | opt <- + if withFullyStaticExe lbi + then Installed.extraLibrariesStatic pkg + else Installed.extraLibraries pkg + ] + ++ [ opt | opt <- Installed.ldOptions pkg ] ] + ++ preccldFlags + ++ hsc2hsOptions bi + ++ postccldFlags + + ++ ["-o", outFile, inFile] + where + -- hsc2hs flag parsing was wrong + -- (see -- https://github.com/haskell/hsc2hs/issues/35) + -- so we need to put -- --cc/--ld *after* hsc2hsOptions, + -- for older hsc2hs (pre 0.68.8) so that they can be overridden. + ccldFlags = + [ "--cc=" ++ programPath gccProg + , "--ld=" ++ programPath gccProg + ] + + (preccldFlags, postccldFlags) + | hsc2hsVersion >= mkVersion [0,68,8] = (ccldFlags, []) + | otherwise = ([], ccldFlags) + + hacked_index = packageHacks (installedPkgs lbi) + -- Look only at the dependencies of the current component + -- being built! This relies on 'installedPkgs' maintaining + -- 'InstalledPackageInfo' for internal deps too; see #2971. + pkgs = PackageIndex.topologicalOrder $ + case PackageIndex.dependencyClosure hacked_index + (map fst (componentPackageDeps clbi)) of + Left index' -> index' + Right inf -> + error ("ppHsc2hs: broken closure: " ++ show inf) + isOSX = case buildOS of OSX -> True; _ -> False + isELF = case buildOS of OSX -> False; Windows -> False; AIX -> False; _ -> True; + packageHacks = case compilerFlavor (compiler lbi) of + GHC -> hackRtsPackage + GHCJS -> hackRtsPackage + _ -> id + -- We don't link in the actual Haskell libraries of our dependencies, so + -- the -u flags in the ldOptions of the rts package mean linking fails on + -- OS X (its ld is a tad stricter than gnu ld). Thus we remove the + -- ldOptions for GHC's rts package: + hackRtsPackage index = + case PackageIndex.lookupPackageName index (mkPackageName "rts") of + [(_, [rts])] + -> PackageIndex.insert rts { Installed.ldOptions = [] } index + _ -> error "No (or multiple) ghc rts package is registered!!" + +ppHsc2hsExtras :: PreProcessorExtras +ppHsc2hsExtras buildBaseDir = filter ("_hsc.c" `isSuffixOf`) `fmap` + getDirectoryContentsRecursive buildBaseDir + +ppC2hs :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor +ppC2hs bi lbi clbi = + PreProcessor { + platformIndependent = False, + ppOrdering = unsorted, + runPreProcessor = \(inBaseDir, inRelativeFile) + (outBaseDir, outRelativeFile) verbosity -> do + (c2hsProg, _, _) <- requireProgramVersion verbosity + c2hsProgram (orLaterVersion (mkVersion [0,15])) + (withPrograms lbi) + (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi) + runProgram verbosity c2hsProg $ + + -- Options from the current package: + [ "--cpp=" ++ programPath gccProg, "--cppopts=-E" ] + ++ [ "--cppopts=" ++ opt | opt <- getCppOptions bi lbi ] + ++ [ "--cppopts=-include" ++ (autogenComponentModulesDir lbi clbi cppHeaderName) ] + ++ [ "--include=" ++ outBaseDir ] + + -- Options from dependent packages + ++ [ "--cppopts=" ++ opt + | pkg <- pkgs + , opt <- [ "-I" ++ opt | opt <- Installed.includeDirs pkg ] + ++ [ opt | opt@('-':c:_) <- Installed.ccOptions pkg + -- c2hs uses the C ABI + -- We assume that there are only C sources + -- and C++ functions are exported via a C + -- interface and wrapped in a C source file. + -- Therefore we do not supply C++ flags + -- because there will not be C++ sources. + -- + -- + -- DO NOT add Installed.cxxOptions unless this changes! + , c `elem` "DIU" ] ] + --TODO: install .chi files for packages, so we can --include + -- those dirs here, for the dependencies + + -- input and output files + ++ [ "--output-dir=" ++ outBaseDir + , "--output=" ++ outRelativeFile + , inBaseDir inRelativeFile ] + } + where + pkgs = PackageIndex.topologicalOrder (installedPkgs lbi) + +ppC2hsExtras :: PreProcessorExtras +ppC2hsExtras d = filter (\p -> takeExtensions p == ".chs.c") `fmap` + getDirectoryContentsRecursive d + +--TODO: perhaps use this with hsc2hs too +--TODO: remove cc-options from cpphs for cabal-version: >= 1.10 +--TODO: Refactor and add separate getCppOptionsForHs, getCppOptionsForCxx, & getCppOptionsForC +-- instead of combining all these cases in a single function. This blind combination can +-- potentially lead to compilation inconsistencies. +getCppOptions :: BuildInfo -> LocalBuildInfo -> [String] +getCppOptions bi lbi + = platformDefines lbi + ++ cppOptions bi + ++ ["-I" ++ dir | dir <- PD.includeDirs bi] + ++ [opt | opt@('-':c:_) <- PD.ccOptions bi ++ PD.cxxOptions bi, c `elem` "DIU"] + +platformDefines :: LocalBuildInfo -> [String] +platformDefines lbi = + case compilerFlavor comp of + GHC -> + ["-D__GLASGOW_HASKELL__=" ++ versionInt version] ++ + ["-D" ++ os ++ "_BUILD_OS=1"] ++ + ["-D" ++ arch ++ "_BUILD_ARCH=1"] ++ + map (\os' -> "-D" ++ os' ++ "_HOST_OS=1") osStr ++ + map (\arch' -> "-D" ++ arch' ++ "_HOST_ARCH=1") archStr + GHCJS -> + compatGlasgowHaskell ++ + ["-D__GHCJS__=" ++ versionInt version] ++ + ["-D" ++ os ++ "_BUILD_OS=1"] ++ + ["-D" ++ arch ++ "_BUILD_ARCH=1"] ++ + map (\os' -> "-D" ++ os' ++ "_HOST_OS=1") osStr ++ + map (\arch' -> "-D" ++ arch' ++ "_HOST_ARCH=1") archStr + HaskellSuite {} -> + ["-D__HASKELL_SUITE__"] ++ + map (\os' -> "-D" ++ os' ++ "_HOST_OS=1") osStr ++ + map (\arch' -> "-D" ++ arch' ++ "_HOST_ARCH=1") archStr + _ -> [] + where + comp = compiler lbi + Platform hostArch hostOS = hostPlatform lbi + version = compilerVersion comp + compatGlasgowHaskell = + maybe [] (\v -> ["-D__GLASGOW_HASKELL__=" ++ versionInt v]) + (compilerCompatVersion GHC comp) + -- TODO: move this into the compiler abstraction + -- FIXME: this forces GHC's crazy 4.8.2 -> 408 convention on all + -- the other compilers. Check if that's really what they want. + versionInt :: Version -> String + versionInt v = case versionNumbers v of + [] -> "1" + [n] -> show n + n1:n2:_ -> + -- 6.8.x -> 608 + -- 6.10.x -> 610 + let s1 = show n1 + s2 = show n2 + middle = case s2 of + _ : _ : _ -> "" + _ -> "0" + in s1 ++ middle ++ s2 + + osStr = case hostOS of + Linux -> ["linux"] + Windows -> ["mingw32"] + OSX -> ["darwin"] + FreeBSD -> ["freebsd"] + OpenBSD -> ["openbsd"] + NetBSD -> ["netbsd"] + DragonFly -> ["dragonfly"] + Solaris -> ["solaris2"] + AIX -> ["aix"] + HPUX -> ["hpux"] + IRIX -> ["irix"] + HaLVM -> [] + IOS -> ["ios"] + Android -> ["android"] + Ghcjs -> ["ghcjs"] + Wasi -> ["wasi"] + Hurd -> ["hurd"] + OtherOS _ -> [] + archStr = case hostArch of + I386 -> ["i386"] + X86_64 -> ["x86_64"] + PPC -> ["powerpc"] + PPC64 -> ["powerpc64"] + Sparc -> ["sparc"] + Arm -> ["arm"] + AArch64 -> ["aarch64"] + Mips -> ["mips"] + SH -> [] + IA64 -> ["ia64"] + S390 -> ["s390"] + S390X -> ["s390x"] + Alpha -> ["alpha"] + Hppa -> ["hppa"] + Rs6000 -> ["rs6000"] + M68k -> ["m68k"] + Vax -> ["vax"] + JavaScript -> ["javascript"] + Wasm32 -> ["wasm32"] + OtherArch _ -> [] + +ppHappy :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor +ppHappy _ lbi _ = pp { platformIndependent = True } + where pp = standardPP lbi happyProgram (hcFlags hc) + hc = compilerFlavor (compiler lbi) + hcFlags GHC = ["-agc"] + hcFlags GHCJS = ["-agc"] + hcFlags _ = [] + +ppAlex :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor +ppAlex _ lbi _ = pp { platformIndependent = True } + where pp = standardPP lbi alexProgram (hcFlags hc) + hc = compilerFlavor (compiler lbi) + hcFlags GHC = ["-g"] + hcFlags GHCJS = ["-g"] + hcFlags _ = [] + +standardPP :: LocalBuildInfo -> Program -> [String] -> PreProcessor +standardPP lbi prog args = + PreProcessor { + platformIndependent = False, + ppOrdering = unsorted, + runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> + runDbProgram verbosity prog (withPrograms lbi) + (args ++ ["-o", outFile, inFile]) + } + +-- |Convenience function; get the suffixes of these preprocessors. +ppSuffixes :: [ PPSuffixHandler ] -> [String] +ppSuffixes = map fst + +-- |Standard preprocessors: GreenCard, c2hs, hsc2hs, happy, alex and cpphs. +knownSuffixHandlers :: [ PPSuffixHandler ] +knownSuffixHandlers = + [ ("gc", ppGreenCard) + , ("chs", ppC2hs) + , ("hsc", ppHsc2hs) + , ("x", ppAlex) + , ("y", ppHappy) + , ("ly", ppHappy) + , ("cpphs", ppCpp) + ] + +-- |Standard preprocessors with possible extra C sources: c2hs, hsc2hs. +knownExtrasHandlers :: [ PreProcessorExtras ] +knownExtrasHandlers = [ ppC2hsExtras, ppHsc2hsExtras ] + +-- | Find any extra C sources generated by preprocessing that need to +-- be added to the component (addresses issue #238). +preprocessExtras :: Verbosity + -> Component + -> LocalBuildInfo + -> IO [FilePath] +preprocessExtras verbosity comp lbi = case comp of + CLib _ -> pp $ buildDir lbi + (CExe Executable { exeName = nm }) -> do + let nm' = unUnqualComponentName nm + pp $ buildDir lbi nm' nm' ++ "-tmp" + (CFLib ForeignLib { foreignLibName = nm }) -> do + let nm' = unUnqualComponentName nm + pp $ buildDir lbi nm' nm' ++ "-tmp" + CTest test -> do + let nm' = unUnqualComponentName $ testName test + case testInterface test of + TestSuiteExeV10 _ _ -> + pp $ buildDir lbi nm' nm' ++ "-tmp" + TestSuiteLibV09 _ _ -> + pp $ buildDir lbi stubName test stubName test ++ "-tmp" + TestSuiteUnsupported tt -> + die' verbosity $ "No support for preprocessing test suite type " ++ + prettyShow tt + CBench bm -> do + let nm' = unUnqualComponentName $ benchmarkName bm + case benchmarkInterface bm of + BenchmarkExeV10 _ _ -> + pp $ buildDir lbi nm' nm' ++ "-tmp" + BenchmarkUnsupported tt -> + die' verbosity $ "No support for preprocessing benchmark " + ++ "type " ++ prettyShow tt + where + pp :: FilePath -> IO [FilePath] + pp dir = do + b <- doesDirectoryExist dir + if b + then (map (dir ) . filter not_sub . concat) + <$> for knownExtrasHandlers + (withLexicalCallStack (\f -> f dir)) + else pure [] + -- TODO: This is a terrible hack to work around #3545 while we don't + -- reorganize the directory layout. Basically, for the main + -- library, we might accidentally pick up autogenerated sources for + -- our subcomponents, because they are all stored as subdirectories + -- in dist/build. This is a cheap and cheerful check to prevent + -- this from happening. It is not particularly correct; for example + -- if a user has a test suite named foobar and puts their C file in + -- foobar/foo.c, this test will incorrectly exclude it. But I + -- didn't want to break BC... + not_sub p = and [ not (pre `isPrefixOf` p) | pre <- component_dirs ] + component_dirs = component_names (localPkgDescr lbi) + -- TODO: libify me + component_names pkg_descr = fmap unUnqualComponentName $ + mapMaybe (libraryNameString . libName) (subLibraries pkg_descr) ++ + map exeName (executables pkg_descr) ++ + map testName (testSuites pkg_descr) ++ + map benchmarkName (benchmarks pkg_descr) diff --git a/cabal/Cabal/src/Distribution/Simple/PreProcess/Unlit.hs b/cabal/Cabal/src/Distribution/Simple/PreProcess/Unlit.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/PreProcess/Unlit.hs @@ -0,0 +1,167 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.PreProcess.Unlit +-- Copyright : ... +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Remove the \"literal\" markups from a Haskell source file, including +-- \"@>@\", \"@\\begin{code}@\", \"@\\end{code}@\", and \"@#@\" + +-- This version is interesting because instead of striping comment lines, it +-- turns them into "-- " style comments. This allows using haddock markup +-- in literate scripts without having to use "> --" prefix. + +module Distribution.Simple.PreProcess.Unlit (unlit,plain) where + +import Prelude () +import Distribution.Compat.Prelude +import Distribution.Utils.Generic (safeTail, safeLast, safeInit) + +import Data.List (mapAccumL) + +data Classified = BirdTrack String | Blank String | Ordinary String + | Line !Int String | CPP String + | BeginCode | EndCode + -- output only: + | Error String | Comment String + +-- | No unliteration. +plain :: String -> String -> String +plain _ hs = hs + +classify :: String -> Classified +classify ('>':s) = BirdTrack s +classify ('#':s) = case tokens s of + (line:file@('"':_:_):_) | all isDigit line + && safeLast file == Just '"' + -- this shouldn't fail as we tested for 'all isDigit' + -> Line (fromMaybe (error $ "panic! read @Int " ++ show line) $ readMaybe line) (safeTail (safeInit file)) -- TODO:eradicateNoParse + _ -> CPP s + where tokens = unfoldr $ \str -> case lex str of + (t@(_:_), str'):_ -> Just (t, str') + _ -> Nothing +classify ('\\':s) + | "begin{code}" `isPrefixOf` s = BeginCode + | "end{code}" `isPrefixOf` s = EndCode +classify s | all isSpace s = Blank s +classify s = Ordinary s + +-- So the weird exception for comment indenting is to make things work with +-- haddock, see classifyAndCheckForBirdTracks below. +unclassify :: Bool -> Classified -> String +unclassify _ (BirdTrack s) = ' ':s +unclassify _ (Blank s) = s +unclassify _ (Ordinary s) = s +unclassify _ (Line n file) = "# " ++ show n ++ " " ++ show file +unclassify _ (CPP s) = '#':s +unclassify True (Comment "") = " --" +unclassify True (Comment s) = " -- " ++ s +unclassify False (Comment "") = "--" +unclassify False (Comment s) = "-- " ++ s +unclassify _ _ = internalError + +-- | 'unlit' takes a filename (for error reports), and transforms the +-- given string, to eliminate the literate comments from the program text. +unlit :: FilePath -> String -> Either String String +unlit file input = + let (usesBirdTracks, classified) = classifyAndCheckForBirdTracks + . inlines + $ input + in either (Left . unlines . map (unclassify usesBirdTracks)) + Right + . checkErrors + . reclassify + $ classified + + where + -- So haddock requires comments and code to align, since it treats comments + -- as following the layout rule. This is a pain for us since bird track + -- style literate code typically gets indented by two since ">" is replaced + -- by " " and people usually use one additional space of indent ie + -- "> then the code". On the other hand we cannot just go and indent all + -- the comments by two since that does not work for latex style literate + -- code. So the hacky solution we use here is that if we see any bird track + -- style code then we'll indent all comments by two, otherwise by none. + -- Of course this will not work for mixed latex/bird track .lhs files but + -- nobody does that, it's silly and specifically recommended against in the + -- H98 unlit spec. + -- + classifyAndCheckForBirdTracks = + flip mapAccumL False $ \seenBirdTrack line -> + let classification = classify line + in (seenBirdTrack || isBirdTrack classification, classification) + + isBirdTrack (BirdTrack _) = True + isBirdTrack _ = False + + checkErrors ls = case [ e | Error e <- ls ] of + [] -> Left ls + (message:_) -> Right (f ++ ":" ++ show n ++ ": " ++ message) + where (f, n) = errorPos file 1 ls + errorPos f n [] = (f, n) + errorPos f n (Error _:_) = (f, n) + errorPos _ _ (Line n' f':ls) = errorPos f' n' ls + errorPos f n (_ :ls) = errorPos f (n+1) ls + +-- Here we model a state machine, with each state represented by +-- a local function. We only have four states (well, five, +-- if you count the error state), but the rules +-- to transition between then are not so simple. +-- Would it be simpler to have more states? +-- +-- Each state represents the type of line that was last read +-- i.e. are we in a comment section, or a latex-code section, +-- or a bird-code section, etc? +reclassify :: [Classified] -> [Classified] +reclassify = blank -- begin in blank state + where + latex [] = [] + latex (EndCode :ls) = Blank "" : comment ls + latex (BeginCode :_ ) = [Error "\\begin{code} in code section"] + latex (BirdTrack l:ls) = Ordinary ('>':l) : latex ls + latex ( l:ls) = l : latex ls + + blank [] = [] + blank (EndCode :_ ) = [Error "\\end{code} without \\begin{code}"] + blank (BeginCode :ls) = Blank "" : latex ls + blank (BirdTrack l:ls) = BirdTrack l : bird ls + blank (Ordinary l:ls) = Comment l : comment ls + blank ( l:ls) = l : blank ls + + bird [] = [] + bird (EndCode :_ ) = [Error "\\end{code} without \\begin{code}"] + bird (BeginCode :ls) = Blank "" : latex ls + bird (Blank l :ls) = Blank l : blank ls + bird (Ordinary _:_ ) = [Error "program line before comment line"] + bird ( l:ls) = l : bird ls + + comment [] = [] + comment (EndCode :_ ) = [Error "\\end{code} without \\begin{code}"] + comment (BeginCode :ls) = Blank "" : latex ls + comment (CPP l :ls) = CPP l : comment ls + comment (BirdTrack _:_ ) = [Error "comment line before program line"] + -- a blank line and another ordinary line following a comment + -- will be treated as continuing the comment. Otherwise it's + -- then end of the comment, with a blank line. + comment (Blank l:ls@(Ordinary _:_)) = Comment l : comment ls + comment (Blank l:ls) = Blank l : blank ls + comment (Line n f :ls) = Line n f : comment ls + comment (Ordinary l:ls) = Comment l : comment ls + comment (Comment _: _) = internalError + comment (Error _: _) = internalError + +-- Re-implementation of 'lines', for better efficiency (but decreased laziness). +-- Also, importantly, accepts non-standard DOS and Mac line ending characters. +inlines :: String -> [String] +inlines xs = lines' xs id + where + lines' [] acc = [acc []] + lines' ('\^M':'\n':s) acc = acc [] : lines' s id -- DOS + lines' ('\^M':s) acc = acc [] : lines' s id -- MacOS + lines' ('\n':s) acc = acc [] : lines' s id -- Unix + lines' (c:s) acc = lines' s (acc . (c:)) + +internalError :: a +internalError = error "unlit: internal error" diff --git a/cabal/Cabal/src/Distribution/Simple/Program.hs b/cabal/Cabal/src/Distribution/Simple/Program.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/Program.hs @@ -0,0 +1,183 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program +-- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This provides an abstraction which deals with configuring and running +-- programs. A 'Program' is a static notion of a known program. A +-- 'ConfiguredProgram' is a 'Program' that has been found on the current +-- machine and is ready to be run (possibly with some user-supplied default +-- args). Configuring a program involves finding its location and if necessary +-- finding its version. There is also a 'ProgramDb' type which holds +-- configured and not-yet configured programs. It is the parameter to lots of +-- actions elsewhere in Cabal that need to look up and run programs. If we had +-- a Cabal monad, the 'ProgramDb' would probably be a reader or +-- state component of it. +-- +-- The module also defines all the known built-in 'Program's and the +-- 'defaultProgramDb' which contains them all. +-- +-- One nice thing about using it is that any program that is +-- registered with Cabal will get some \"configure\" and \".cabal\" +-- helpers like --with-foo-args --foo-path= and extra-foo-args. +-- +-- There's also good default behavior for trying to find \"foo\" in +-- PATH, being able to override its location, etc. +-- +-- There's also a hook for adding programs in a Setup.lhs script. See +-- hookedPrograms in 'Distribution.Simple.UserHooks'. This gives a +-- hook user the ability to get the above flags and such so that they +-- don't have to write all the PATH logic inside Setup.lhs. + +module Distribution.Simple.Program ( + -- * Program and functions for constructing them + Program(..) + , ProgramSearchPath + , ProgramSearchPathEntry(..) + , simpleProgram + , findProgramOnSearchPath + , defaultProgramSearchPath + , findProgramVersion + + -- * Configured program and related functions + , ConfiguredProgram(..) + , programPath + , ProgArg + , ProgramLocation(..) + , runProgram + , getProgramOutput + , suppressOverrideArgs + + -- * Program invocations + , ProgramInvocation(..) + , emptyProgramInvocation + , simpleProgramInvocation + , programInvocation + , runProgramInvocation + , getProgramInvocationOutput + , getProgramInvocationLBS + + -- * The collection of unconfigured and configured programs + , builtinPrograms + + -- * The collection of configured programs we can run + , ProgramDb + , defaultProgramDb + , emptyProgramDb + , restoreProgramDb + , addKnownProgram + , addKnownPrograms + , lookupKnownProgram + , knownPrograms + , getProgramSearchPath + , setProgramSearchPath + , userSpecifyPath + , userSpecifyPaths + , userMaybeSpecifyPath + , userSpecifyArgs + , userSpecifyArgss + , userSpecifiedArgs + , lookupProgram + , lookupProgramVersion + , updateProgram + , configureProgram + , configureAllKnownPrograms + , reconfigurePrograms + , requireProgram + , requireProgramVersion + , needProgram + , runDbProgram + , getDbProgramOutput + + -- * Programs that Cabal knows about + , ghcProgram + , ghcPkgProgram + , ghcjsProgram + , ghcjsPkgProgram + , hmakeProgram + , jhcProgram + , uhcProgram + , gccProgram + , arProgram + , stripProgram + , happyProgram + , alexProgram + , hsc2hsProgram + , c2hsProgram + , cpphsProgram + , hscolourProgram + , doctestProgram + , haddockProgram + , greencardProgram + , ldProgram + , tarProgram + , cppProgram + , pkgConfigProgram + , hpcProgram + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Simple.Program.Types +import Distribution.Simple.Program.Run +import Distribution.Simple.Program.Db +import Distribution.Simple.Program.Builtin +import Distribution.Simple.Program.Find +import Distribution.Simple.Utils +import Distribution.Verbosity + +-- | Runs the given configured program. +runProgram :: Verbosity -- ^Verbosity + -> ConfiguredProgram -- ^The program to run + -> [ProgArg] -- ^Any /extra/ arguments to add + -> IO () +runProgram verbosity prog args = + runProgramInvocation verbosity (programInvocation prog args) + + +-- | Runs the given configured program and gets the output. +-- +getProgramOutput :: Verbosity -- ^Verbosity + -> ConfiguredProgram -- ^The program to run + -> [ProgArg] -- ^Any /extra/ arguments to add + -> IO String +getProgramOutput verbosity prog args = + getProgramInvocationOutput verbosity (programInvocation prog args) + + +-- | Looks up the given program in the program database and runs it. +-- +runDbProgram :: Verbosity -- ^verbosity + -> Program -- ^The program to run + -> ProgramDb -- ^look up the program here + -> [ProgArg] -- ^Any /extra/ arguments to add + -> IO () +runDbProgram verbosity prog programDb args = + case lookupProgram prog programDb of + Nothing -> die' verbosity notFound + Just configuredProg -> runProgram verbosity configuredProg args + where + notFound = "The program '" ++ programName prog + ++ "' is required but it could not be found" + +-- | Looks up the given program in the program database and runs it. +-- +getDbProgramOutput :: Verbosity -- ^verbosity + -> Program -- ^The program to run + -> ProgramDb -- ^look up the program here + -> [ProgArg] -- ^Any /extra/ arguments to add + -> IO String +getDbProgramOutput verbosity prog programDb args = + case lookupProgram prog programDb of + Nothing -> die' verbosity notFound + Just configuredProg -> getProgramOutput verbosity configuredProg args + where + notFound = "The program '" ++ programName prog + ++ "' is required but it could not be found" diff --git a/cabal/Cabal/src/Distribution/Simple/Program/Ar.hs b/cabal/Cabal/src/Distribution/Simple/Program/Ar.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/Program/Ar.hs @@ -0,0 +1,202 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE NoMonoLocalBinds #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program.Ar +-- Copyright : Duncan Coutts 2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module provides an library interface to the @ar@ program. + +module Distribution.Simple.Program.Ar ( + createArLibArchive, + multiStageProgramInvocation + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import Distribution.Compat.CopyFile (filesEqual) +import Distribution.Simple.Compiler (arResponseFilesSupported, arDashLSupported) +import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..)) +import Distribution.Simple.Program + ( ProgramInvocation, arProgram, requireProgram ) +import Distribution.Simple.Program.ResponseFile + ( withResponseFile ) +import Distribution.Simple.Program.Run + ( programInvocation, multiStageProgramInvocation + , runProgramInvocation ) +import Distribution.Simple.Setup + ( fromFlagOrDefault, configUseResponseFiles ) +import Distribution.Simple.Utils + ( defaultTempFileOptions, dieWithLocation', withTempDirectory ) +import Distribution.System + ( Arch(..), OS(..), Platform(..) ) +import Distribution.Verbosity + ( Verbosity, deafening, verbose ) +import System.Directory (doesFileExist, renameFile) +import System.FilePath ((), splitFileName) +import System.IO + ( Handle, IOMode(ReadWriteMode), SeekMode(AbsoluteSeek) + , hFileSize, hSeek, withBinaryFile ) + +-- | Call @ar@ to create a library archive from a bunch of object files. +-- +createArLibArchive :: Verbosity -> LocalBuildInfo + -> FilePath -> [FilePath] -> IO () +createArLibArchive verbosity lbi targetPath files = do + (ar, _) <- requireProgram verbosity arProgram progDb + + let (targetDir, targetName) = splitFileName targetPath + withTempDirectory verbosity targetDir "objs" $ \ tmpDir -> do + let tmpPath = tmpDir targetName + + -- The args to use with "ar" are actually rather subtle and system-dependent. + -- In particular we have the following issues: + -- + -- -- On OS X, "ar q" does not make an archive index. Archives with no + -- index cannot be used. + -- + -- -- GNU "ar r" will not let us add duplicate objects, only "ar q" lets us + -- do that. We have duplicates because of modules like "A.M" and "B.M" + -- both make an object file "M.o" and ar does not consider the directory. + -- + -- -- llvm-ar, which GHC >=9.4 uses on Windows, supports a "L" modifier + -- in "q" mode which compels the archiver to add the members of an input + -- archive to the output, rather than the archive itself. This is + -- necessary as GHC may produce .o files that are actually archives. See + -- https://gitlab.haskell.org/ghc/ghc/-/issues/21068. + -- + -- Our solution is to use "ar r" in the simple case when one call is enough. + -- When we need to call ar multiple times we use "ar q" and for the last + -- call on OSX we use "ar qs" so that it'll make the index. + + let simpleArgs = case hostOS of + OSX -> ["-r", "-s"] + _ | dashLSupported -> ["-qL"] + _ -> ["-r"] + + initialArgs = ["-q"] + finalArgs = case hostOS of + OSX -> ["-q", "-s"] + _ | dashLSupported -> ["-qL"] + _ -> ["-q"] + + extraArgs = verbosityOpts verbosity ++ [tmpPath] + + simple = programInvocation ar (simpleArgs ++ extraArgs) + initial = programInvocation ar (initialArgs ++ extraArgs) + middle = initial + final = programInvocation ar (finalArgs ++ extraArgs) + + oldVersionManualOverride = + fromFlagOrDefault False $ configUseResponseFiles $ configFlags lbi + responseArgumentsNotSupported = + not (arResponseFilesSupported (compiler lbi)) + dashLSupported = + arDashLSupported (compiler lbi) + + invokeWithResponesFile :: FilePath -> ProgramInvocation + invokeWithResponesFile atFile = + programInvocation ar $ + simpleArgs ++ extraArgs ++ ['@' : atFile] + + if oldVersionManualOverride || responseArgumentsNotSupported + then + sequence_ + [ runProgramInvocation verbosity inv + | inv <- multiStageProgramInvocation + simple (initial, middle, final) files ] + else + withResponseFile verbosity defaultTempFileOptions tmpDir "ar.rsp" Nothing files $ + \path -> runProgramInvocation verbosity $ invokeWithResponesFile path + + unless (hostArch == Arm -- See #1537 + || hostOS == AIX) $ -- AIX uses its own "ar" format variant + wipeMetadata verbosity tmpPath + equal <- filesEqual tmpPath targetPath + unless equal $ renameFile tmpPath targetPath + + where + progDb = withPrograms lbi + Platform hostArch hostOS = hostPlatform lbi + verbosityOpts v + | v >= deafening = ["-v"] + | v >= verbose = [] + | otherwise = ["-c"] -- Do not warn if library had to be created. + +-- | @ar@ by default includes various metadata for each object file in their +-- respective headers, so the output can differ for the same inputs, making +-- it difficult to avoid re-linking. GNU @ar@(1) has a deterministic mode +-- (@-D@) flag that always writes zero for the mtime, UID and GID, and 0644 +-- for the file mode. However detecting whether @-D@ is supported seems +-- rather harder than just re-implementing this feature. +wipeMetadata :: Verbosity -> FilePath -> IO () +wipeMetadata verbosity path = do + -- Check for existence first (ReadWriteMode would create one otherwise) + exists <- doesFileExist path + unless exists $ wipeError "Temporary file disappeared" + withBinaryFile path ReadWriteMode $ \ h -> hFileSize h >>= wipeArchive h + + where + wipeError msg = dieWithLocation' verbosity path Nothing $ + "Distribution.Simple.Program.Ar.wipeMetadata: " ++ msg + archLF = "!\x0a" -- global magic, 8 bytes + x60LF = "\x60\x0a" -- header magic, 2 bytes + metadata = BS.concat + [ "0 " -- mtime, 12 bytes + , "0 " -- UID, 6 bytes + , "0 " -- GID, 6 bytes + , "0644 " -- mode, 8 bytes + ] + headerSize :: Int + headerSize = 60 + + -- http://en.wikipedia.org/wiki/Ar_(Unix)#File_format_details + wipeArchive :: Handle -> Integer -> IO () + wipeArchive h archiveSize = do + global <- BS.hGet h (BS.length archLF) + unless (global == archLF) $ wipeError "Bad global header" + wipeHeader (toInteger $ BS.length archLF) + + where + wipeHeader :: Integer -> IO () + wipeHeader offset = case compare offset archiveSize of + EQ -> return () + GT -> wipeError (atOffset "Archive truncated") + LT -> do + header <- BS.hGet h headerSize + unless (BS.length header == headerSize) $ + wipeError (atOffset "Short header") + let magic = BS.drop 58 header + unless (magic == x60LF) . wipeError . atOffset $ + "Bad magic " ++ show magic ++ " in header" + + let name = BS.take 16 header + let size = BS.take 10 $ BS.drop 48 header + objSize <- case reads (BS8.unpack size) of + [(n, s)] | all isSpace s -> return n + _ -> wipeError (atOffset "Bad file size in header") + + let replacement = BS.concat [ name, metadata, size, magic ] + unless (BS.length replacement == headerSize) $ + wipeError (atOffset "Something has gone terribly wrong") + hSeek h AbsoluteSeek offset + BS.hPut h replacement + + let nextHeader = offset + toInteger headerSize + + -- Odd objects are padded with an extra '\x0a' + if odd objSize then objSize + 1 else objSize + hSeek h AbsoluteSeek nextHeader + wipeHeader nextHeader + + where + atOffset msg = msg ++ " at offset " ++ show offset diff --git a/cabal/Cabal/src/Distribution/Simple/Program/Builtin.hs b/cabal/Cabal/src/Distribution/Simple/Program/Builtin.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/Program/Builtin.hs @@ -0,0 +1,348 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program.Builtin +-- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- The module defines all the known built-in 'Program's. +-- +-- Where possible we try to find their version numbers. +-- +module Distribution.Simple.Program.Builtin ( + + -- * The collection of unconfigured and configured programs + builtinPrograms, + + -- * Programs that Cabal knows about + ghcProgram, + ghcPkgProgram, + runghcProgram, + ghcjsProgram, + ghcjsPkgProgram, + hmakeProgram, + jhcProgram, + haskellSuiteProgram, + haskellSuitePkgProgram, + uhcProgram, + gccProgram, + arProgram, + stripProgram, + happyProgram, + alexProgram, + hsc2hsProgram, + c2hsProgram, + cpphsProgram, + hscolourProgram, + doctestProgram, + haddockProgram, + greencardProgram, + ldProgram, + tarProgram, + cppProgram, + pkgConfigProgram, + hpcProgram, + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Simple.Program.GHC +import Distribution.Simple.Program.Find +import Distribution.Simple.Program.Internal +import Distribution.Simple.Program.Run +import Distribution.Simple.Program.Types +import Distribution.Simple.Utils +import Distribution.Verbosity +import Distribution.Version + +import qualified Data.Map as Map + +-- ------------------------------------------------------------ +-- * Known programs +-- ------------------------------------------------------------ + +-- | The default list of programs. +-- These programs are typically used internally to Cabal. +builtinPrograms :: [Program] +builtinPrograms = + [ + -- compilers and related progs + ghcProgram + , runghcProgram + , ghcPkgProgram + , ghcjsProgram + , ghcjsPkgProgram + , haskellSuiteProgram + , haskellSuitePkgProgram + , hmakeProgram + , jhcProgram + , uhcProgram + , hpcProgram + -- preprocessors + , hscolourProgram + , doctestProgram + , haddockProgram + , happyProgram + , alexProgram + , hsc2hsProgram + , c2hsProgram + , cpphsProgram + , greencardProgram + -- platform toolchain + , gccProgram + , arProgram + , stripProgram + , ldProgram + , tarProgram + -- configuration tools + , pkgConfigProgram + ] + +ghcProgram :: Program +ghcProgram = (simpleProgram "ghc") { + programFindVersion = findProgramVersion "--numeric-version" id, + + -- Workaround for https://gitlab.haskell.org/ghc/ghc/-/issues/8825 + -- (spurious warning on non-english locales) + programPostConf = \_verbosity ghcProg -> + do let ghcProg' = ghcProg { + programOverrideEnv = ("LANGUAGE", Just "en") + : programOverrideEnv ghcProg + } + -- Only the 7.8 branch seems to be affected. Fixed in 7.8.4. + affectedVersionRange = intersectVersionRanges + (laterVersion $ mkVersion [7,8,0]) + (earlierVersion $ mkVersion [7,8,4]) + return $ maybe ghcProg + (\v -> if withinRange v affectedVersionRange + then ghcProg' else ghcProg) + (programVersion ghcProg), + + programNormaliseArgs = normaliseGhcArgs + } + +runghcProgram :: Program +runghcProgram = (simpleProgram "runghc") { + programFindVersion = findProgramVersion "--version" $ \str -> + case words str of + -- "runghc 7.10.3" + (_:ver:_) -> ver + _ -> "" + } + +ghcPkgProgram :: Program +ghcPkgProgram = (simpleProgram "ghc-pkg") { + programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "ghc-pkg --version" gives a string like + -- "GHC package manager version 6.4.1" + case words str of + (_:_:_:_:ver:_) -> ver + _ -> "" + } + +ghcjsProgram :: Program +ghcjsProgram = (simpleProgram "ghcjs") { + programFindVersion = findProgramVersion "--numeric-ghcjs-version" id + } + +-- note: version is the version number of the GHC version that ghcjs-pkg was built with +ghcjsPkgProgram :: Program +ghcjsPkgProgram = (simpleProgram "ghcjs-pkg") { + programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "ghcjs-pkg --version" gives a string like + -- "GHCJS package manager version 6.4.1" + case words str of + (_:_:_:_:ver:_) -> ver + _ -> "" + } + +hmakeProgram :: Program +hmakeProgram = (simpleProgram "hmake") { + programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "hmake --version" gives a string line + -- "/usr/local/bin/hmake: 3.13 (2006-11-01)" + case words str of + (_:ver:_) -> ver + _ -> "" + } + +jhcProgram :: Program +jhcProgram = (simpleProgram "jhc") { + programFindVersion = findProgramVersion "--version" $ \str -> + -- invoking "jhc --version" gives a string like + -- "jhc 0.3.20080208 (wubgipkamcep-2) + -- compiled by ghc-6.8 on a x86_64 running linux" + case words str of + (_:ver:_) -> ver + _ -> "" + } + +uhcProgram :: Program +uhcProgram = (simpleProgram "uhc") { + programFindVersion = findProgramVersion "--version-dotted" id + } + +hpcProgram :: Program +hpcProgram = (simpleProgram "hpc") + { + programFindVersion = findProgramVersion "version" $ \str -> + case words str of + (_ : _ : _ : ver : _) -> ver + _ -> "" + } + +-- This represents a haskell-suite compiler. Of course, the compiler +-- itself probably is not called "haskell-suite", so this is not a real +-- program. (But we don't know statically the name of the actual compiler, +-- so this is the best we can do.) +-- +-- Having this Program value serves two purposes: +-- +-- 1. We can accept options for the compiler in the form of +-- +-- --haskell-suite-option(s)=... +-- +-- 2. We can find a program later using this static id (with +-- requireProgram). +-- +-- The path to the real compiler is found and recorded in the ProgramDb +-- during the configure phase. +haskellSuiteProgram :: Program +haskellSuiteProgram = (simpleProgram "haskell-suite") { + -- pretend that the program exists, otherwise it won't be in the + -- "configured" state + programFindLocation = \_verbosity _searchPath -> + return $ Just ("haskell-suite-dummy-location", []) + } + +-- This represent a haskell-suite package manager. See the comments for +-- haskellSuiteProgram. +haskellSuitePkgProgram :: Program +haskellSuitePkgProgram = (simpleProgram "haskell-suite-pkg") { + programFindLocation = \_verbosity _searchPath -> + return $ Just ("haskell-suite-pkg-dummy-location", []) + } + + +happyProgram :: Program +happyProgram = (simpleProgram "happy") { + programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "happy --version" gives a string like + -- "Happy Version 1.16 Copyright (c) ...." + case words str of + (_:_:ver:_) -> ver + _ -> "" + } + +alexProgram :: Program +alexProgram = (simpleProgram "alex") { + programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "alex --version" gives a string like + -- "Alex version 2.1.0, (c) 2003 Chris Dornan and Simon Marlow" + case words str of + (_:_:ver:_) -> takeWhile (\x -> isDigit x || x == '.') ver + _ -> "" + } + +gccProgram :: Program +gccProgram = (simpleProgram "gcc") { + programFindVersion = findProgramVersion "-dumpversion" id + } + +arProgram :: Program +arProgram = simpleProgram "ar" + +stripProgram :: Program +stripProgram = (simpleProgram "strip") { + programFindVersion = \verbosity -> + findProgramVersion "--version" stripExtractVersion (lessVerbose verbosity) + } + +hsc2hsProgram :: Program +hsc2hsProgram = (simpleProgram "hsc2hs") { + programFindVersion = + findProgramVersion "--version" $ \str -> + -- Invoking "hsc2hs --version" gives a string like "hsc2hs version 0.66" + case words str of + (_:_:ver:_) -> ver + _ -> "" + } + +c2hsProgram :: Program +c2hsProgram = (simpleProgram "c2hs") { + programFindVersion = findProgramVersion "--numeric-version" id + } + +cpphsProgram :: Program +cpphsProgram = (simpleProgram "cpphs") { + programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "cpphs --version" gives a string like "cpphs 1.3" + case words str of + (_:ver:_) -> ver + _ -> "" + } + +hscolourProgram :: Program +hscolourProgram = (simpleProgram "hscolour") { + programFindLocation = \v p -> findProgramOnSearchPath v p "HsColour", + programFindVersion = findProgramVersion "-version" $ \str -> + -- Invoking "HsColour -version" gives a string like "HsColour 1.7" + case words str of + (_:ver:_) -> ver + _ -> "" + } + +-- TODO: Ensure that doctest is built against the same GHC as the one +-- that's being used. Same for haddock. @phadej pointed this out. +doctestProgram :: Program +doctestProgram = (simpleProgram "doctest") { + programFindLocation = \v p -> findProgramOnSearchPath v p "doctest" + , programFindVersion = findProgramVersion "--version" $ \str -> + -- "doctest version 0.11.2" + case words str of + (_:_:ver:_) -> ver + _ -> "" + } + +haddockProgram :: Program +haddockProgram = (simpleProgram "haddock") { + programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "haddock --version" gives a string like + -- "Haddock version 0.8, (c) Simon Marlow 2006" + case words str of + (_:_:ver:_) -> takeWhile (`elem` ('.':['0'..'9'])) ver + _ -> "", + + programNormaliseArgs = \_ _ args -> args + } + +greencardProgram :: Program +greencardProgram = simpleProgram "greencard" + +ldProgram :: Program +ldProgram = simpleProgram "ld" + +tarProgram :: Program +tarProgram = (simpleProgram "tar") { + -- See #1901. Some versions of 'tar' (OpenBSD, NetBSD, ...) don't support the + -- '--format' option. + programPostConf = \verbosity tarProg -> do + tarHelpOutput <- getProgramInvocationOutput + verbosity (programInvocation tarProg ["--help"]) + -- Some versions of tar don't support '--help'. + `catchIO` (\_ -> return "") + let k = "Supports --format" + v = if ("--format" `isInfixOf` tarHelpOutput) then "YES" else "NO" + m = Map.insert k v (programProperties tarProg) + return $ tarProg { programProperties = m } + } + +cppProgram :: Program +cppProgram = simpleProgram "cpp" + +pkgConfigProgram :: Program +pkgConfigProgram = (simpleProgram "pkg-config") { + programFindVersion = findProgramVersion "--version" id + } diff --git a/cabal/Cabal/src/Distribution/Simple/Program/Db.hs b/cabal/Cabal/src/Distribution/Simple/Program/Db.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/Program/Db.hs @@ -0,0 +1,505 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program.Db +-- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This provides a 'ProgramDb' type which holds configured and not-yet +-- configured programs. It is the parameter to lots of actions elsewhere in +-- Cabal that need to look up and run programs. If we had a Cabal monad, +-- the 'ProgramDb' would probably be a reader or state component of it. +-- +-- One nice thing about using it is that any program that is +-- registered with Cabal will get some \"configure\" and \".cabal\" +-- helpers like --with-foo-args --foo-path= and extra-foo-args. +-- +-- There's also a hook for adding programs in a Setup.lhs script. See +-- hookedPrograms in 'Distribution.Simple.UserHooks'. This gives a +-- hook user the ability to get the above flags and such so that they +-- don't have to write all the PATH logic inside Setup.lhs. + +module Distribution.Simple.Program.Db ( + -- * The collection of configured programs we can run + ProgramDb, + emptyProgramDb, + defaultProgramDb, + restoreProgramDb, + + -- ** Query and manipulate the program db + addKnownProgram, + addKnownPrograms, + lookupKnownProgram, + knownPrograms, + getProgramSearchPath, + setProgramSearchPath, + modifyProgramSearchPath, + userSpecifyPath, + userSpecifyPaths, + userMaybeSpecifyPath, + userSpecifyArgs, + userSpecifyArgss, + userSpecifiedArgs, + lookupProgram, + updateProgram, + configuredPrograms, + + -- ** Query and manipulate the program db + configureProgram, + configureAllKnownPrograms, + unconfigureProgram, + lookupProgramVersion, + reconfigurePrograms, + requireProgram, + requireProgramVersion, + needProgram, + + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Pretty +import Distribution.Simple.Program.Builtin +import Distribution.Simple.Program.Find +import Distribution.Simple.Program.Types +import Distribution.Simple.Utils +import Distribution.Utils.Structured (Structure (..), Structured (..)) +import Distribution.Verbosity +import Distribution.Version + +import Data.Tuple (swap) + +import qualified Data.Map as Map + +-- ------------------------------------------------------------ +-- * Programs database +-- ------------------------------------------------------------ + +-- | The configuration is a collection of information about programs. It +-- contains information both about configured programs and also about programs +-- that we are yet to configure. +-- +-- The idea is that we start from a collection of unconfigured programs and one +-- by one we try to configure them at which point we move them into the +-- configured collection. For unconfigured programs we record not just the +-- 'Program' but also any user-provided arguments and location for the program. +data ProgramDb = ProgramDb { + unconfiguredProgs :: UnconfiguredProgs, + progSearchPath :: ProgramSearchPath, + configuredProgs :: ConfiguredProgs + } + deriving (Typeable) + +type UnconfiguredProgram = (Program, Maybe FilePath, [ProgArg]) +type UnconfiguredProgs = Map.Map String UnconfiguredProgram +type ConfiguredProgs = Map.Map String ConfiguredProgram + + +emptyProgramDb :: ProgramDb +emptyProgramDb = ProgramDb Map.empty defaultProgramSearchPath Map.empty + +defaultProgramDb :: ProgramDb +defaultProgramDb = restoreProgramDb builtinPrograms emptyProgramDb + + +-- internal helpers: +updateUnconfiguredProgs :: (UnconfiguredProgs -> UnconfiguredProgs) + -> ProgramDb -> ProgramDb +updateUnconfiguredProgs update progdb = + progdb { unconfiguredProgs = update (unconfiguredProgs progdb) } + +updateConfiguredProgs :: (ConfiguredProgs -> ConfiguredProgs) + -> ProgramDb -> ProgramDb +updateConfiguredProgs update progdb = + progdb { configuredProgs = update (configuredProgs progdb) } + + +-- Read & Show instances are based on listToFM + +-- | Note that this instance does not preserve the known 'Program's. +-- See 'restoreProgramDb' for details. +-- +instance Show ProgramDb where + show = show . Map.toAscList . configuredProgs + +-- | Note that this instance does not preserve the known 'Program's. +-- See 'restoreProgramDb' for details. +-- +instance Read ProgramDb where + readsPrec p s = + [ (emptyProgramDb { configuredProgs = Map.fromList s' }, r) + | (s', r) <- readsPrec p s ] + +-- | Note that this instance does not preserve the known 'Program's. +-- See 'restoreProgramDb' for details. +-- +instance Binary ProgramDb where + put db = do + put (progSearchPath db) + put (configuredProgs db) + + get = do + searchpath <- get + progs <- get + return $! emptyProgramDb { + progSearchPath = searchpath, + configuredProgs = progs + } + +instance Structured ProgramDb where + structure p = Nominal (typeRep p) 0 "ProgramDb" + [ structure (Proxy :: Proxy ProgramSearchPath) + , structure (Proxy :: Proxy ConfiguredProgs) + ] + + +-- | The 'Read'\/'Show' and 'Binary' instances do not preserve all the +-- unconfigured 'Programs' because 'Program' is not in 'Read'\/'Show' because +-- it contains functions. So to fully restore a deserialised 'ProgramDb' use +-- this function to add back all the known 'Program's. +-- +-- * It does not add the default programs, but you probably want them, use +-- 'builtinPrograms' in addition to any extra you might need. +-- +restoreProgramDb :: [Program] -> ProgramDb -> ProgramDb +restoreProgramDb = addKnownPrograms + + +-- ------------------------------- +-- Managing unconfigured programs + +-- | Add a known program that we may configure later +-- +addKnownProgram :: Program -> ProgramDb -> ProgramDb +addKnownProgram prog = updateUnconfiguredProgs $ + Map.insertWith combine (programName prog) (prog, Nothing, []) + where combine _ (_, path, args) = (prog, path, args) + + +addKnownPrograms :: [Program] -> ProgramDb -> ProgramDb +addKnownPrograms progs progdb = foldl' (flip addKnownProgram) progdb progs + + +lookupKnownProgram :: String -> ProgramDb -> Maybe Program +lookupKnownProgram name = + fmap (\(p,_,_)->p) . Map.lookup name . unconfiguredProgs + + +knownPrograms :: ProgramDb -> [(Program, Maybe ConfiguredProgram)] +knownPrograms progdb = + [ (p,p') | (p,_,_) <- Map.elems (unconfiguredProgs progdb) + , let p' = Map.lookup (programName p) (configuredProgs progdb) ] + +-- | Get the current 'ProgramSearchPath' used by the 'ProgramDb'. +-- This is the default list of locations where programs are looked for when +-- configuring them. This can be overridden for specific programs (with +-- 'userSpecifyPath'), and specific known programs can modify or ignore this +-- search path in their own configuration code. +-- +getProgramSearchPath :: ProgramDb -> ProgramSearchPath +getProgramSearchPath = progSearchPath + +-- | Change the current 'ProgramSearchPath' used by the 'ProgramDb'. +-- This will affect programs that are configured from here on, so you +-- should usually set it before configuring any programs. +-- +setProgramSearchPath :: ProgramSearchPath -> ProgramDb -> ProgramDb +setProgramSearchPath searchpath db = db { progSearchPath = searchpath } + +-- | Modify the current 'ProgramSearchPath' used by the 'ProgramDb'. +-- This will affect programs that are configured from here on, so you +-- should usually modify it before configuring any programs. +-- +modifyProgramSearchPath :: (ProgramSearchPath -> ProgramSearchPath) + -> ProgramDb + -> ProgramDb +modifyProgramSearchPath f db = + setProgramSearchPath (f $ getProgramSearchPath db) db + +-- |User-specify this path. Basically override any path information +-- for this program in the configuration. If it's not a known +-- program ignore it. +-- +userSpecifyPath :: String -- ^Program name + -> FilePath -- ^user-specified path to the program + -> ProgramDb -> ProgramDb +userSpecifyPath name path = updateUnconfiguredProgs $ + flip Map.update name $ \(prog, _, args) -> Just (prog, Just path, args) + + +userMaybeSpecifyPath :: String -> Maybe FilePath + -> ProgramDb -> ProgramDb +userMaybeSpecifyPath _ Nothing progdb = progdb +userMaybeSpecifyPath name (Just path) progdb = userSpecifyPath name path progdb + + +-- |User-specify the arguments for this program. Basically override +-- any args information for this program in the configuration. If it's +-- not a known program, ignore it.. +userSpecifyArgs :: String -- ^Program name + -> [ProgArg] -- ^user-specified args + -> ProgramDb + -> ProgramDb +userSpecifyArgs name args' = + updateUnconfiguredProgs + (flip Map.update name $ + \(prog, path, args) -> Just (prog, path, args ++ args')) + . updateConfiguredProgs + (flip Map.update name $ + \prog -> Just prog { programOverrideArgs = programOverrideArgs prog + ++ args' }) + + +-- | Like 'userSpecifyPath' but for a list of progs and their paths. +-- +userSpecifyPaths :: [(String, FilePath)] + -> ProgramDb + -> ProgramDb +userSpecifyPaths paths progdb = + foldl' (\progdb' (prog, path) -> userSpecifyPath prog path progdb') progdb paths + + +-- | Like 'userSpecifyPath' but for a list of progs and their args. +-- +userSpecifyArgss :: [(String, [ProgArg])] + -> ProgramDb + -> ProgramDb +userSpecifyArgss argss progdb = + foldl' (\progdb' (prog, args) -> userSpecifyArgs prog args progdb') progdb argss + + +-- | Get the path that has been previously specified for a program, if any. +-- +userSpecifiedPath :: Program -> ProgramDb -> Maybe FilePath +userSpecifiedPath prog = + join . fmap (\(_,p,_)->p) . Map.lookup (programName prog) . unconfiguredProgs + + +-- | Get any extra args that have been previously specified for a program. +-- +userSpecifiedArgs :: Program -> ProgramDb -> [ProgArg] +userSpecifiedArgs prog = + maybe [] (\(_,_,as)->as) . Map.lookup (programName prog) . unconfiguredProgs + + +-- ----------------------------- +-- Managing configured programs + +-- | Try to find a configured program +lookupProgram :: Program -> ProgramDb -> Maybe ConfiguredProgram +lookupProgram prog = Map.lookup (programName prog) . configuredProgs + + +-- | Update a configured program in the database. +updateProgram :: ConfiguredProgram -> ProgramDb + -> ProgramDb +updateProgram prog = updateConfiguredProgs $ + Map.insert (programId prog) prog + + +-- | List all configured programs. +configuredPrograms :: ProgramDb -> [ConfiguredProgram] +configuredPrograms = Map.elems . configuredProgs + +-- --------------------------- +-- Configuring known programs + +-- | Try to configure a specific program. If the program is already included in +-- the collection of unconfigured programs then we use any user-supplied +-- location and arguments. If the program gets configured successfully it gets +-- added to the configured collection. +-- +-- Note that it is not a failure if the program cannot be configured. It's only +-- a failure if the user supplied a location and the program could not be found +-- at that location. +-- +-- The reason for it not being a failure at this stage is that we don't know up +-- front all the programs we will need, so we try to configure them all. +-- To verify that a program was actually successfully configured use +-- 'requireProgram'. +-- +configureProgram :: Verbosity + -> Program + -> ProgramDb + -> IO ProgramDb +configureProgram verbosity prog progdb = do + let name = programName prog + maybeLocation <- case userSpecifiedPath prog progdb of + Nothing -> + programFindLocation prog verbosity (progSearchPath progdb) + >>= return . fmap (swap . fmap FoundOnSystem . swap) + Just path -> do + absolute <- doesExecutableExist path + if absolute + then return (Just (UserSpecified path, [])) + else findProgramOnSearchPath verbosity (progSearchPath progdb) path + >>= maybe (die' verbosity notFound) + (return . Just . swap . fmap UserSpecified . swap) + where notFound = "Cannot find the program '" ++ name + ++ "'. User-specified path '" + ++ path ++ "' does not refer to an executable and " + ++ "the program is not on the system path." + case maybeLocation of + Nothing -> return progdb + Just (location, triedLocations) -> do + version <- programFindVersion prog verbosity (locationPath location) + newPath <- programSearchPathAsPATHVar (progSearchPath progdb) + let configuredProg = ConfiguredProgram { + programId = name, + programVersion = version, + programDefaultArgs = [], + programOverrideArgs = userSpecifiedArgs prog progdb, + programOverrideEnv = [("PATH", Just newPath)], + programProperties = Map.empty, + programLocation = location, + programMonitorFiles = triedLocations + } + configuredProg' <- programPostConf prog verbosity configuredProg + return (updateConfiguredProgs (Map.insert name configuredProg') progdb) + + +-- | Configure a bunch of programs using 'configureProgram'. Just a 'foldM'. +-- +configurePrograms :: Verbosity + -> [Program] + -> ProgramDb + -> IO ProgramDb +configurePrograms verbosity progs progdb = + foldM (flip (configureProgram verbosity)) progdb progs + + +-- | Unconfigure a program. This is basically a hack and you shouldn't +-- use it, but it can be handy for making sure a 'requireProgram' +-- actually reconfigures. +unconfigureProgram :: String -> ProgramDb -> ProgramDb +unconfigureProgram progname = + updateConfiguredProgs $ Map.delete progname + +-- | Try to configure all the known programs that have not yet been configured. +-- +configureAllKnownPrograms :: Verbosity + -> ProgramDb + -> IO ProgramDb +configureAllKnownPrograms verbosity progdb = + configurePrograms verbosity + [ prog | (prog,_,_) <- Map.elems notYetConfigured ] progdb + where + notYetConfigured = unconfiguredProgs progdb + `Map.difference` configuredProgs progdb + + +-- | reconfigure a bunch of programs given new user-specified args. It takes +-- the same inputs as 'userSpecifyPath' and 'userSpecifyArgs' and for all progs +-- with a new path it calls 'configureProgram'. +-- +reconfigurePrograms :: Verbosity + -> [(String, FilePath)] + -> [(String, [ProgArg])] + -> ProgramDb + -> IO ProgramDb +reconfigurePrograms verbosity paths argss progdb = do + configurePrograms verbosity progs + . userSpecifyPaths paths + . userSpecifyArgss argss + $ progdb + + where + progs = catMaybes [ lookupKnownProgram name progdb | (name,_) <- paths ] + + +-- | Check that a program is configured and available to be run. +-- +-- It raises an exception if the program could not be configured, otherwise +-- it returns the configured program. +-- +requireProgram :: Verbosity -> Program -> ProgramDb + -> IO (ConfiguredProgram, ProgramDb) +requireProgram verbosity prog progdb = do + mres <- needProgram verbosity prog progdb + case mres of + Nothing -> die' verbosity notFound + Just res -> return res + where + notFound = "The program '" ++ programName prog ++ "' is required but it could not be found." + +-- | Check that a program is configured and available to be run. +-- +-- It returns 'Nothing' if the program couldn't be configured, +-- or is not found. +-- +-- @since 3.0.1.0 +needProgram :: Verbosity -> Program -> ProgramDb + -> IO (Maybe (ConfiguredProgram, ProgramDb)) +needProgram verbosity prog progdb = do + + -- If it's not already been configured, try to configure it now + progdb' <- case lookupProgram prog progdb of + Nothing -> configureProgram verbosity prog progdb + Just _ -> return progdb + + case lookupProgram prog progdb' of + Nothing -> return Nothing + Just configuredProg -> return (Just (configuredProg, progdb')) + +-- | Check that a program is configured and available to be run. +-- +-- Additionally check that the program version number is suitable and return +-- it. For example you could require 'AnyVersion' or @'orLaterVersion' +-- ('Version' [1,0] [])@ +-- +-- It returns the configured program, its version number and a possibly updated +-- 'ProgramDb'. If the program could not be configured or the version is +-- unsuitable, it returns an error value. +-- +lookupProgramVersion + :: Verbosity -> Program -> VersionRange -> ProgramDb + -> IO (Either String (ConfiguredProgram, Version, ProgramDb)) +lookupProgramVersion verbosity prog range programDb = do + + -- If it's not already been configured, try to configure it now + programDb' <- case lookupProgram prog programDb of + Nothing -> configureProgram verbosity prog programDb + Just _ -> return programDb + + case lookupProgram prog programDb' of + Nothing -> return $! Left notFound + Just configuredProg@ConfiguredProgram { programLocation = location } -> + case programVersion configuredProg of + Just version + | withinRange version range -> + return $! Right (configuredProg, version ,programDb') + | otherwise -> + return $! Left (badVersion version location) + Nothing -> + return $! Left (unknownVersion location) + + where notFound = "The program '" + ++ programName prog ++ "'" ++ versionRequirement + ++ " is required but it could not be found." + badVersion v l = "The program '" + ++ programName prog ++ "'" ++ versionRequirement + ++ " is required but the version found at " + ++ locationPath l ++ " is version " ++ prettyShow v + unknownVersion l = "The program '" + ++ programName prog ++ "'" ++ versionRequirement + ++ " is required but the version of " + ++ locationPath l ++ " could not be determined." + versionRequirement + | isAnyVersion range = "" + | otherwise = " version " ++ prettyShow range + +-- | Like 'lookupProgramVersion', but raises an exception in case of error +-- instead of returning 'Left errMsg'. +-- +requireProgramVersion :: Verbosity -> Program -> VersionRange + -> ProgramDb + -> IO (ConfiguredProgram, Version, ProgramDb) +requireProgramVersion verbosity prog range programDb = + join $ either (die' verbosity) return `fmap` + lookupProgramVersion verbosity prog range programDb diff --git a/cabal/Cabal/src/Distribution/Simple/Program/Find.hs b/cabal/Cabal/src/Distribution/Simple/Program/Find.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/Program/Find.hs @@ -0,0 +1,198 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program.Find +-- Copyright : Duncan Coutts 2013 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- A somewhat extended notion of the normal program search path concept. +-- +-- Usually when finding executables we just want to look in the usual places +-- using the OS's usual method for doing so. In Haskell the normal OS-specific +-- method is captured by 'findExecutable'. On all common OSs that makes use of +-- a @PATH@ environment variable, (though on Windows it is not just the @PATH@). +-- +-- However it is sometimes useful to be able to look in additional locations +-- without having to change the process-global @PATH@ environment variable. +-- So we need an extension of the usual 'findExecutable' that can look in +-- additional locations, either before, after or instead of the normal OS +-- locations. +-- +module Distribution.Simple.Program.Find ( + -- * Program search path + ProgramSearchPath, + ProgramSearchPathEntry(..), + defaultProgramSearchPath, + findProgramOnSearchPath, + programSearchPathAsPATHVar, + getSystemSearchPath, + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Verbosity +import Distribution.Simple.Utils +import Distribution.System +import Distribution.Compat.Environment + +import qualified System.Directory as Directory + ( findExecutable ) +import System.FilePath as FilePath + ( (), (<.>), splitSearchPath, searchPathSeparator, getSearchPath + , takeDirectory ) +#if defined(mingw32_HOST_OS) +import qualified System.Win32 as Win32 +#endif + +-- | A search path to use when locating executables. This is analogous +-- to the unix @$PATH@ or win32 @%PATH%@ but with the ability to use +-- the system default method for finding executables ('findExecutable' which +-- on unix is simply looking on the @$PATH@ but on win32 is a bit more +-- complicated). +-- +-- The default to use is @[ProgSearchPathDefault]@ but you can add extra dirs +-- either before, after or instead of the default, e.g. here we add an extra +-- dir to search after the usual ones. +-- +-- > ['ProgramSearchPathDefault', 'ProgramSearchPathDir' dir] +-- +type ProgramSearchPath = [ProgramSearchPathEntry] +data ProgramSearchPathEntry = + ProgramSearchPathDir FilePath -- ^ A specific dir + | ProgramSearchPathDefault -- ^ The system default + deriving (Eq, Generic, Typeable) + +instance Binary ProgramSearchPathEntry +instance Structured ProgramSearchPathEntry + +defaultProgramSearchPath :: ProgramSearchPath +defaultProgramSearchPath = [ProgramSearchPathDefault] + +findProgramOnSearchPath :: Verbosity -> ProgramSearchPath + -> FilePath -> IO (Maybe (FilePath, [FilePath])) +findProgramOnSearchPath verbosity searchpath prog = do + debug verbosity $ "Searching for " ++ prog ++ " in path." + res <- tryPathElems [] searchpath + case res of + Nothing -> debug verbosity ("Cannot find " ++ prog ++ " on the path") + Just (path, _) -> debug verbosity ("Found " ++ prog ++ " at "++ path) + return res + where + tryPathElems :: [[FilePath]] -> [ProgramSearchPathEntry] + -> IO (Maybe (FilePath, [FilePath])) + tryPathElems _ [] = return Nothing + tryPathElems tried (pe:pes) = do + res <- tryPathElem pe + case res of + (Nothing, notfoundat) -> tryPathElems (notfoundat : tried) pes + (Just foundat, notfoundat) -> return (Just (foundat, alltried)) + where + alltried = concat (reverse (notfoundat : tried)) + + tryPathElem :: ProgramSearchPathEntry -> IO (Maybe FilePath, [FilePath]) + tryPathElem (ProgramSearchPathDir dir) = + findFirstExe [ dir prog <.> ext | ext <- exeExtensions ] + + -- On windows, getSystemSearchPath is not guaranteed 100% correct so we + -- use findExecutable and then approximate the not-found-at locations. + tryPathElem ProgramSearchPathDefault | buildOS == Windows = do + mExe <- firstJustM [ findExecutable (prog <.> ext) | ext <- exeExtensions ] + syspath <- getSystemSearchPath + case mExe of + Nothing -> + let notfoundat = [ dir prog | dir <- syspath ] in + return (Nothing, notfoundat) + + Just foundat -> do + let founddir = takeDirectory foundat + notfoundat = [ dir prog + | dir <- takeWhile (/= founddir) syspath ] + return (Just foundat, notfoundat) + + -- On other OSs we can just do the simple thing + tryPathElem ProgramSearchPathDefault = do + dirs <- getSystemSearchPath + findFirstExe [ dir prog <.> ext | dir <- dirs, ext <- exeExtensions ] + + findFirstExe :: [FilePath] -> IO (Maybe FilePath, [FilePath]) + findFirstExe = go [] + where + go fs' [] = return (Nothing, reverse fs') + go fs' (f:fs) = do + isExe <- doesExecutableExist f + if isExe + then return (Just f, reverse fs') + else go (f:fs') fs + + -- Helper for evaluating actions until the first one returns 'Just' + firstJustM :: Monad m => [m (Maybe a)] -> m (Maybe a) + firstJustM [] = return Nothing + firstJustM (ma:mas) = do + a <- ma + case a of + Just _ -> return a + Nothing -> firstJustM mas + +-- | Interpret a 'ProgramSearchPath' to construct a new @$PATH@ env var. +-- Note that this is close but not perfect because on Windows the search +-- algorithm looks at more than just the @%PATH%@. +programSearchPathAsPATHVar :: ProgramSearchPath -> IO String +programSearchPathAsPATHVar searchpath = do + ess <- traverse getEntries searchpath + return (intercalate [searchPathSeparator] (concat ess)) + where + getEntries (ProgramSearchPathDir dir) = return [dir] + getEntries ProgramSearchPathDefault = do + env <- getEnvironment + return (maybe [] splitSearchPath (lookup "PATH" env)) + +-- | Get the system search path. On Unix systems this is just the @$PATH@ env +-- var, but on windows it's a bit more complicated. +-- +getSystemSearchPath :: IO [FilePath] +getSystemSearchPath = fmap nub $ do +#if defined(mingw32_HOST_OS) + processdir <- takeDirectory `fmap` Win32.getModuleFileName Win32.nullHANDLE + currentdir <- Win32.getCurrentDirectory + systemdir <- Win32.getSystemDirectory + windowsdir <- Win32.getWindowsDirectory + pathdirs <- FilePath.getSearchPath + let path = processdir : currentdir + : systemdir : windowsdir + : pathdirs + return path +#else + FilePath.getSearchPath +#endif + +#ifdef MIN_VERSION_directory +#if MIN_VERSION_directory(1,2,1) +#define HAVE_directory_121 +#endif +#endif + +findExecutable :: FilePath -> IO (Maybe FilePath) +#ifdef HAVE_directory_121 +findExecutable = Directory.findExecutable +#else +findExecutable prog = do + -- With directory < 1.2.1 'findExecutable' doesn't check that the path + -- really refers to an executable. + mExe <- Directory.findExecutable prog + case mExe of + Just exe -> do + exeExists <- doesExecutableExist exe + if exeExists + then return mExe + else return Nothing + _ -> return mExe +#endif + diff --git a/cabal/Cabal/src/Distribution/Simple/Program/GHC.hs b/cabal/Cabal/src/Distribution/Simple/Program/GHC.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/Program/GHC.hs @@ -0,0 +1,862 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NoMonoLocalBinds #-} +module Distribution.Simple.Program.GHC ( + GhcOptions(..), + GhcMode(..), + GhcOptimisation(..), + GhcDynLinkMode(..), + GhcProfAuto(..), + + ghcInvocation, + renderGhcOptions, + + runGHC, + + packageDbArgsDb, + normaliseGhcArgs + + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Backpack +import Distribution.Compat.Semigroup (First'(..), Last'(..), Option'(..)) +import Distribution.Simple.GHC.ImplInfo +import Distribution.PackageDescription +import Distribution.ModuleName +import Distribution.Simple.Compiler +import Distribution.Simple.Flag +import Distribution.Simple.Program.Types +import Distribution.Simple.Program.Run +import Distribution.System +import Distribution.Pretty +import Distribution.Types.ComponentId +import Distribution.Verbosity +import Distribution.Version +import Distribution.Utils.NubList +import Language.Haskell.Extension + +import Data.List (stripPrefix) +import qualified Data.Map as Map +import Data.Monoid (All(..), Any(..), Endo(..)) +import qualified Data.Set as Set + +normaliseGhcArgs :: Maybe Version -> PackageDescription -> [String] -> [String] +normaliseGhcArgs (Just ghcVersion) PackageDescription{..} ghcArgs + | ghcVersion `withinRange` supportedGHCVersions + = argumentFilters . filter simpleFilters . filterRtsOpts $ ghcArgs + where + supportedGHCVersions :: VersionRange + supportedGHCVersions = orLaterVersion (mkVersion [8,0]) + -- we (weakly) support unknown future GHC versions for the purpose + -- of filtering GHC arguments + + from :: Monoid m => [Int] -> m -> m + from version flags + | ghcVersion `withinRange` orLaterVersion (mkVersion version) = flags + | otherwise = mempty + + to :: Monoid m => [Int] -> m -> m + to version flags + | ghcVersion `withinRange` earlierVersion (mkVersion version) = flags + | otherwise = mempty + + checkGhcFlags :: forall m . Monoid m => ([String] -> m) -> m + checkGhcFlags fun = mconcat + [ fun ghcArgs + , checkComponentFlags libBuildInfo pkgLibs + , checkComponentFlags buildInfo executables + , checkComponentFlags testBuildInfo testSuites + , checkComponentFlags benchmarkBuildInfo benchmarks + ] + where + pkgLibs = maybeToList library ++ subLibraries + + checkComponentFlags :: (a -> BuildInfo) -> [a] -> m + checkComponentFlags getInfo = foldMap (checkComponent . getInfo) + where + checkComponent :: BuildInfo -> m + checkComponent = foldMap fun . filterGhcOptions . allGhcOptions + + allGhcOptions :: BuildInfo -> [(CompilerFlavor, [String])] + allGhcOptions = foldMap (perCompilerFlavorToList .) + [options, profOptions, sharedOptions, staticOptions] + + filterGhcOptions :: [(CompilerFlavor, [String])] -> [[String]] + filterGhcOptions l = [opts | (GHC, opts) <- l] + + safeToFilterWarnings :: Bool + safeToFilterWarnings = getAll $ checkGhcFlags checkWarnings + where + checkWarnings :: [String] -> All + checkWarnings = All . Set.null . foldr alter Set.empty + + alter :: String -> Set String -> Set String + alter flag = appEndo $ mconcat + [ \s -> Endo $ if s == "-Werror" then Set.insert s else id + , \s -> Endo $ if s == "-Wwarn" then const Set.empty else id + , \s -> from [8,6] . Endo $ + if s == "-Werror=compat" + then Set.union compatWarningSet else id + , \s -> from [8,6] . Endo $ + if s == "-Wno-error=compat" + then (`Set.difference` compatWarningSet) else id + , \s -> from [8,6] . Endo $ + if s == "-Wwarn=compat" + then (`Set.difference` compatWarningSet) else id + , from [8,4] $ markFlag "-Werror=" Set.insert + , from [8,4] $ markFlag "-Wwarn=" Set.delete + , from [8,4] $ markFlag "-Wno-error=" Set.delete + ] flag + + markFlag + :: String + -> (String -> Set String -> Set String) + -> String + -> Endo (Set String) + markFlag name update flag = Endo $ case stripPrefix name flag of + Just rest | not (null rest) && rest /= "compat" -> update rest + _ -> id + + flagArgumentFilter :: [String] -> [String] -> [String] + flagArgumentFilter flags = go + where + makeFilter :: String -> String -> Option' (First' ([String] -> [String])) + makeFilter flag arg = Option' $ First' . filterRest <$> stripPrefix flag arg + where + filterRest leftOver = case dropEq leftOver of + [] -> drop 1 + _ -> id + + checkFilter :: String -> Maybe ([String] -> [String]) + checkFilter = fmap getFirst' . getOption' . foldMap makeFilter flags + + go :: [String] -> [String] + go [] = [] + go (arg:args) = case checkFilter arg of + Just f -> go (f args) + Nothing -> arg : go args + + argumentFilters :: [String] -> [String] + argumentFilters = flagArgumentFilter + ["-ghci-script", "-H", "-interactive-print"] + + filterRtsOpts :: [String] -> [String] + filterRtsOpts = go False + where + go :: Bool -> [String] -> [String] + go _ [] = [] + go _ ("+RTS":opts) = go True opts + go _ ("-RTS":opts) = go False opts + go isRTSopts (opt:opts) = addOpt $ go isRTSopts opts + where + addOpt | isRTSopts = id + | otherwise = (opt:) + + simpleFilters :: String -> Bool + simpleFilters = not . getAny . mconcat + [ flagIn simpleFlags + , Any . isPrefixOf "-ddump-" + , Any . isPrefixOf "-dsuppress-" + , Any . isPrefixOf "-dno-suppress-" + , flagIn $ invertibleFlagSet "-" ["ignore-dot-ghci"] + , flagIn . invertibleFlagSet "-f" . mconcat $ + [ [ "reverse-errors", "warn-unused-binds", "break-on-error" + , "break-on-exception", "print-bind-result" + , "print-bind-contents", "print-evld-with-show" + , "implicit-import-qualified", "error-spans" + ] + , from [7,8] + [ "print-explicit-foralls" -- maybe also earlier, but GHC-7.6 doesn't have --show-options + , "print-explicit-kinds" + ] + , from [8,0] + [ "print-explicit-coercions" + , "print-explicit-runtime-reps" + , "print-equality-relations" + , "print-unicode-syntax" + , "print-expanded-synonyms" + , "print-potential-instances" + , "print-typechecker-elaboration" + ] + , from [8,2] + [ "diagnostics-show-caret", "local-ghci-history" + , "show-warning-groups", "hide-source-paths" + , "show-hole-constraints" + ] + , from [8,4] ["show-loaded-modules"] + , from [8,6] [ "ghci-leak-check", "no-it" ] + , from [8,10] + [ "defer-diagnostics" -- affects printing of diagnostics + , "keep-going" -- try harder, the build will still fail if it's erroneous + , "print-axiom-incomps" -- print more debug info for closed type families + ] + ] + , flagIn . invertibleFlagSet "-d" $ [ "ppr-case-as-let", "ppr-ticks" ] + , isOptIntFlag + , isIntFlag + , if safeToFilterWarnings + then isWarning <> (Any . ("-w"==)) + else mempty + , from [8,6] $ + if safeToFilterHoles + then isTypedHoleFlag + else mempty + ] + + flagIn :: Set String -> String -> Any + flagIn set flag = Any $ Set.member flag set + + isWarning :: String -> Any + isWarning = mconcat $ map ((Any .) . isPrefixOf) + ["-fwarn-", "-fno-warn-", "-W", "-Wno-"] + + simpleFlags :: Set String + simpleFlags = Set.fromList . mconcat $ + [ [ "-n", "-#include", "-Rghc-timing", "-dstg-stats" + , "-dth-dec-file", "-dsource-stats", "-dverbose-core2core" + , "-dverbose-stg2stg", "-dcore-lint", "-dstg-lint", "-dcmm-lint" + , "-dasm-lint", "-dannot-lint", "-dshow-passes", "-dfaststring-stats" + , "-fno-max-relevant-binds", "-recomp", "-no-recomp", "-fforce-recomp" + , "-fno-force-recomp" + ] + + , from [8,2] + [ "-fno-max-errors", "-fdiagnostics-color=auto" + , "-fdiagnostics-color=always", "-fdiagnostics-color=never" + , "-dppr-debug", "-dno-debug-output" + ] + + , from [8,4] [ "-ddebug-output" ] + , from [8,4] $ to [8,6] [ "-fno-max-valid-substitutions" ] + , from [8,6] [ "-dhex-word-literals" ] + , from [8,8] [ "-fshow-docs-of-hole-fits", "-fno-show-docs-of-hole-fits" ] + , from [9,0] [ "-dlinear-core-lint" ] + ] + + isOptIntFlag :: String -> Any + isOptIntFlag = mconcat . map (dropIntFlag True) $ ["-v", "-j"] + + isIntFlag :: String -> Any + isIntFlag = mconcat . map (dropIntFlag False) . mconcat $ + [ [ "-fmax-relevant-binds", "-ddpr-user-length", "-ddpr-cols" + , "-dtrace-level", "-fghci-hist-size" ] + , from [8,2] ["-fmax-uncovered-patterns", "-fmax-errors"] + , from [8,4] $ to [8,6] ["-fmax-valid-substitutions"] + ] + + dropIntFlag :: Bool -> String -> String -> Any + dropIntFlag isOpt flag input = Any $ case stripPrefix flag input of + Nothing -> False + Just rest | isOpt && null rest -> True + | otherwise -> case parseInt rest of + Just _ -> True + Nothing -> False + where + parseInt :: String -> Maybe Int + parseInt = readMaybe . dropEq + + dropEq :: String -> String + dropEq ('=':s) = s + dropEq s = s + + invertibleFlagSet :: String -> [String] -> Set String + invertibleFlagSet prefix flagNames = + Set.fromList $ (++) <$> [prefix, prefix ++ "no-"] <*> flagNames + + compatWarningSet :: Set String + compatWarningSet = Set.fromList $ mconcat + [ from [8,6] + [ "missing-monadfail-instances", "semigroup" + , "noncanonical-monoid-instances", "implicit-kind-vars" ] + ] + + safeToFilterHoles :: Bool + safeToFilterHoles = getAll . checkGhcFlags $ + All . fromMaybe True . fmap getLast' . getOption' . foldMap notDeferred + where + notDeferred :: String -> Option' (Last' Bool) + notDeferred "-fdefer-typed-holes" = Option' . Just . Last' $ False + notDeferred "-fno-defer-typed-holes" = Option' . Just . Last' $ True + notDeferred _ = Option' Nothing + + isTypedHoleFlag :: String -> Any + isTypedHoleFlag = mconcat + [ flagIn . invertibleFlagSet "-f" $ + [ "show-hole-constraints", "show-valid-substitutions" + , "show-valid-hole-fits", "sort-valid-hole-fits" + , "sort-by-size-hole-fits", "sort-by-subsumption-hole-fits" + , "abstract-refinement-hole-fits", "show-provenance-of-hole-fits" + , "show-hole-matches-of-hole-fits", "show-type-of-hole-fits" + , "show-type-app-of-hole-fits", "show-type-app-vars-of-hole-fits" + , "unclutter-valid-hole-fits" + ] + , flagIn . Set.fromList $ + [ "-fno-max-valid-hole-fits", "-fno-max-refinement-hole-fits" + , "-fno-refinement-level-hole-fits" ] + , mconcat . map (dropIntFlag False) $ + [ "-fmax-valid-hole-fits", "-fmax-refinement-hole-fits" + , "-frefinement-level-hole-fits" ] + ] + +normaliseGhcArgs _ _ args = args + +-- | A structured set of GHC options/flags +-- +-- Note that options containing lists fall into two categories: +-- +-- * options that can be safely deduplicated, e.g. input modules or +-- enabled extensions; +-- * options that cannot be deduplicated in general without changing +-- semantics, e.g. extra ghc options or linking options. +data GhcOptions = GhcOptions { + + -- | The major mode for the ghc invocation. + ghcOptMode :: Flag GhcMode, + + -- | Any extra options to pass directly to ghc. These go at the end and hence + -- override other stuff. + ghcOptExtra :: [String], + + -- | Extra default flags to pass directly to ghc. These go at the beginning + -- and so can be overridden by other stuff. + ghcOptExtraDefault :: [String], + + ----------------------- + -- Inputs and outputs + + -- | The main input files; could be .hs, .hi, .c, .o, depending on mode. + ghcOptInputFiles :: NubListR FilePath, + + -- | Script files with irregular extensions that need -x hs. + ghcOptInputScripts :: NubListR FilePath, + + -- | The names of input Haskell modules, mainly for @--make@ mode. + ghcOptInputModules :: NubListR ModuleName, + + -- | Location for output file; the @ghc -o@ flag. + ghcOptOutputFile :: Flag FilePath, + + -- | Location for dynamic output file in 'GhcStaticAndDynamic' mode; + -- the @ghc -dyno@ flag. + ghcOptOutputDynFile :: Flag FilePath, + + -- | Start with an empty search path for Haskell source files; + -- the @ghc -i@ flag (@-i@ on its own with no path argument). + ghcOptSourcePathClear :: Flag Bool, + + -- | Search path for Haskell source files; the @ghc -i@ flag. + ghcOptSourcePath :: NubListR FilePath, + + ------------- + -- Packages + + -- | The unit ID the modules will belong to; the @ghc -this-unit-id@ + -- flag (or @-this-package-key@ or @-package-name@ on older + -- versions of GHC). This is a 'String' because we assume you've + -- already figured out what the correct format for this string is + -- (we need to handle backwards compatibility.) + ghcOptThisUnitId :: Flag String, + + -- | GHC doesn't make any assumptions about the format of + -- definite unit ids, so when we are instantiating a package it + -- needs to be told explicitly what the component being instantiated + -- is. This only gets set when 'ghcOptInstantiatedWith' is non-empty + ghcOptThisComponentId :: Flag ComponentId, + + -- | How the requirements of the package being compiled are to + -- be filled. When typechecking an indefinite package, the 'OpenModule' + -- is always a 'OpenModuleVar'; otherwise, it specifies the installed module + -- that instantiates a package. + ghcOptInstantiatedWith :: [(ModuleName, OpenModule)], + + -- | No code? (But we turn on interface writing + ghcOptNoCode :: Flag Bool, + + -- | GHC package databases to use, the @ghc -package-conf@ flag. + ghcOptPackageDBs :: PackageDBStack, + + -- | The GHC packages to bring into scope when compiling, + -- the @ghc -package-id@ flags. + ghcOptPackages :: + NubListR (OpenUnitId, ModuleRenaming), + + -- | Start with a clean package set; the @ghc -hide-all-packages@ flag + ghcOptHideAllPackages :: Flag Bool, + + -- | Warn about modules, not listed in command line + ghcOptWarnMissingHomeModules :: Flag Bool, + + -- | Don't automatically link in Haskell98 etc; the @ghc + -- -no-auto-link-packages@ flag. + ghcOptNoAutoLinkPackages :: Flag Bool, + + ----------------- + -- Linker stuff + + -- | Names of libraries to link in; the @ghc -l@ flag. + ghcOptLinkLibs :: [FilePath], + + -- | Search path for libraries to link in; the @ghc -L@ flag. + ghcOptLinkLibPath :: NubListR FilePath, + + -- | Options to pass through to the linker; the @ghc -optl@ flag. + ghcOptLinkOptions :: [String], + + -- | OSX only: frameworks to link in; the @ghc -framework@ flag. + ghcOptLinkFrameworks :: NubListR String, + + -- | OSX only: Search path for frameworks to link in; the + -- @ghc -framework-path@ flag. + ghcOptLinkFrameworkDirs :: NubListR String, + + -- | Instruct GHC to link against @libHSrts@ when producing a shared library. + ghcOptLinkRts :: Flag Bool, + + -- | Don't do the link step, useful in make mode; the @ghc -no-link@ flag. + ghcOptNoLink :: Flag Bool, + + -- | Don't link in the normal RTS @main@ entry point; the @ghc -no-hs-main@ + -- flag. + ghcOptLinkNoHsMain :: Flag Bool, + + -- | Module definition files (Windows specific) + ghcOptLinkModDefFiles :: NubListR FilePath, + + -------------------- + -- C and CPP stuff + + -- | Options to pass through to the C compiler; the @ghc -optc@ flag. + ghcOptCcOptions :: [String], + + -- | Options to pass through to the C++ compiler. + ghcOptCxxOptions :: [String], + + -- | Options to pass through to the Assembler. + ghcOptAsmOptions :: [String], + + -- | Options to pass through to CPP; the @ghc -optP@ flag. + ghcOptCppOptions :: [String], + + -- | Search path for CPP includes like header files; the @ghc -I@ flag. + ghcOptCppIncludePath :: NubListR FilePath, + + -- | Extra header files to include at CPP stage; the @ghc -optP-include@ flag. + ghcOptCppIncludes :: NubListR FilePath, + + -- | Extra header files to include for old-style FFI; the @ghc -#include@ flag. + ghcOptFfiIncludes :: NubListR FilePath, + + -- | Program to use for the C and C++ compiler; the @ghc -pgmc@ flag. + ghcOptCcProgram :: Flag FilePath, + + ---------------------------- + -- Language and extensions + + -- | The base language; the @ghc -XHaskell98@ or @-XHaskell2010@ flag. + ghcOptLanguage :: Flag Language, + + -- | The language extensions; the @ghc -X@ flag. + ghcOptExtensions :: NubListR Extension, + + -- | A GHC version-dependent mapping of extensions to flags. This must be + -- set to be able to make use of the 'ghcOptExtensions'. + ghcOptExtensionMap :: Map Extension (Maybe CompilerFlag), + + ---------------- + -- Compilation + + -- | What optimisation level to use; the @ghc -O@ flag. + ghcOptOptimisation :: Flag GhcOptimisation, + + -- | Emit debug info; the @ghc -g@ flag. + ghcOptDebugInfo :: Flag DebugInfoLevel, + + -- | Compile in profiling mode; the @ghc -prof@ flag. + ghcOptProfilingMode :: Flag Bool, + + -- | Automatically add profiling cost centers; the @ghc -fprof-auto*@ flags. + ghcOptProfilingAuto :: Flag GhcProfAuto, + + -- | Use the \"split sections\" feature; the @ghc -split-sections@ flag. + ghcOptSplitSections :: Flag Bool, + + -- | Use the \"split object files\" feature; the @ghc -split-objs@ flag. + ghcOptSplitObjs :: Flag Bool, + + -- | Run N jobs simultaneously (if possible). + ghcOptNumJobs :: Flag (Maybe Int), + + -- | Enable coverage analysis; the @ghc -fhpc -hpcdir@ flags. + ghcOptHPCDir :: Flag FilePath, + + ---------------- + -- GHCi + + -- | Extra GHCi startup scripts; the @-ghci-script@ flag + ghcOptGHCiScripts :: [FilePath], + + ------------------------ + -- Redirecting outputs + + ghcOptHiSuffix :: Flag String, + ghcOptObjSuffix :: Flag String, + ghcOptDynHiSuffix :: Flag String, -- ^ only in 'GhcStaticAndDynamic' mode + ghcOptDynObjSuffix :: Flag String, -- ^ only in 'GhcStaticAndDynamic' mode + ghcOptHiDir :: Flag FilePath, + ghcOptObjDir :: Flag FilePath, + ghcOptOutputDir :: Flag FilePath, + ghcOptStubDir :: Flag FilePath, + + -------------------- + -- Creating libraries + + ghcOptDynLinkMode :: Flag GhcDynLinkMode, + ghcOptStaticLib :: Flag Bool, + ghcOptShared :: Flag Bool, + ghcOptFPic :: Flag Bool, + ghcOptDylibName :: Flag String, + ghcOptRPaths :: NubListR FilePath, + + --------------- + -- Misc flags + + -- | Get GHC to be quiet or verbose with what it's doing; the @ghc -v@ flag. + ghcOptVerbosity :: Flag Verbosity, + + -- | Put the extra folders in the PATH environment variable we invoke + -- GHC with + ghcOptExtraPath :: NubListR FilePath, + + -- | Let GHC know that it is Cabal that's calling it. + -- Modifies some of the GHC error messages. + ghcOptCabal :: Flag Bool + +} deriving (Show, Generic) + + +data GhcMode = GhcModeCompile -- ^ @ghc -c@ + | GhcModeLink -- ^ @ghc@ + | GhcModeMake -- ^ @ghc --make@ + | GhcModeInteractive -- ^ @ghci@ \/ @ghc --interactive@ + | GhcModeAbiHash -- ^ @ghc --abi-hash@ +-- | GhcModeDepAnalysis -- ^ @ghc -M@ +-- | GhcModeEvaluate -- ^ @ghc -e@ + deriving (Show, Eq) + +data GhcOptimisation = GhcNoOptimisation -- ^ @-O0@ + | GhcNormalOptimisation -- ^ @-O@ + | GhcMaximumOptimisation -- ^ @-O2@ + | GhcSpecialOptimisation String -- ^ e.g. @-Odph@ + deriving (Show, Eq) + +data GhcDynLinkMode = GhcStaticOnly -- ^ @-static@ + | GhcDynamicOnly -- ^ @-dynamic@ + | GhcStaticAndDynamic -- ^ @-static -dynamic-too@ + deriving (Show, Eq) + +data GhcProfAuto = GhcProfAutoAll -- ^ @-fprof-auto@ + | GhcProfAutoToplevel -- ^ @-fprof-auto-top@ + | GhcProfAutoExported -- ^ @-fprof-auto-exported@ + deriving (Show, Eq) + +runGHC :: Verbosity -> ConfiguredProgram -> Compiler -> Platform -> GhcOptions + -> IO () +runGHC verbosity ghcProg comp platform opts = do + runProgramInvocation verbosity (ghcInvocation ghcProg comp platform opts) + + +ghcInvocation :: ConfiguredProgram -> Compiler -> Platform -> GhcOptions + -> ProgramInvocation +ghcInvocation prog comp platform opts = + (programInvocation prog (renderGhcOptions comp platform opts)) { + progInvokePathEnv = fromNubListR (ghcOptExtraPath opts) + } + +renderGhcOptions :: Compiler -> Platform -> GhcOptions -> [String] +renderGhcOptions comp _platform@(Platform _arch os) opts + | compilerFlavor comp `notElem` [GHC, GHCJS] = + error $ "Distribution.Simple.Program.GHC.renderGhcOptions: " + ++ "compiler flavor must be 'GHC' or 'GHCJS'!" + | otherwise = + concat + [ case flagToMaybe (ghcOptMode opts) of + Nothing -> [] + Just GhcModeCompile -> ["-c"] + Just GhcModeLink -> [] + Just GhcModeMake -> ["--make"] + Just GhcModeInteractive -> ["--interactive"] + Just GhcModeAbiHash -> ["--abi-hash"] +-- Just GhcModeDepAnalysis -> ["-M"] +-- Just GhcModeEvaluate -> ["-e", expr] + + , ghcOptExtraDefault opts + + , [ "-no-link" | flagBool ghcOptNoLink ] + , [ "-flink-rts" | flagBool ghcOptLinkRts ] + + --------------- + -- Misc flags + + , maybe [] verbosityOpts (flagToMaybe (ghcOptVerbosity opts)) + + , [ "-fbuilding-cabal-package" | flagBool ghcOptCabal ] + + ---------------- + -- Compilation + + , case flagToMaybe (ghcOptOptimisation opts) of + Nothing -> [] + Just GhcNoOptimisation -> ["-O0"] + Just GhcNormalOptimisation -> ["-O"] + Just GhcMaximumOptimisation -> ["-O2"] + Just (GhcSpecialOptimisation s) -> ["-O" ++ s] -- eg -Odph + + , case flagToMaybe (ghcOptDebugInfo opts) of + Nothing -> [] + Just NoDebugInfo -> [] + Just MinimalDebugInfo -> ["-g1"] + Just NormalDebugInfo -> ["-g2"] + Just MaximalDebugInfo -> ["-g3"] + + , [ "-prof" | flagBool ghcOptProfilingMode ] + + , case flagToMaybe (ghcOptProfilingAuto opts) of + _ | not (flagBool ghcOptProfilingMode) + -> [] + Nothing -> [] + Just GhcProfAutoAll + | flagProfAuto implInfo -> ["-fprof-auto"] + | otherwise -> ["-auto-all"] -- not the same, but close + Just GhcProfAutoToplevel + | flagProfAuto implInfo -> ["-fprof-auto-top"] + | otherwise -> ["-auto-all"] + Just GhcProfAutoExported + | flagProfAuto implInfo -> ["-fprof-auto-exported"] + | otherwise -> ["-auto"] + + , [ "-split-sections" | flagBool ghcOptSplitSections ] + , [ "-split-objs" | flagBool ghcOptSplitObjs ] + + , case flagToMaybe (ghcOptHPCDir opts) of + Nothing -> [] + Just hpcdir -> ["-fhpc", "-hpcdir", hpcdir] + + , if parmakeSupported comp + then case ghcOptNumJobs opts of + NoFlag -> [] + Flag n -> ["-j" ++ maybe "" show n] + else [] + + -------------------- + -- Creating libraries + + , [ "-staticlib" | flagBool ghcOptStaticLib ] + , [ "-shared" | flagBool ghcOptShared ] + , case flagToMaybe (ghcOptDynLinkMode opts) of + Nothing -> [] + Just GhcStaticOnly -> ["-static"] + Just GhcDynamicOnly -> ["-dynamic"] + Just GhcStaticAndDynamic -> ["-static", "-dynamic-too"] + , [ "-fPIC" | flagBool ghcOptFPic ] + + , concat [ ["-dylib-install-name", libname] | libname <- flag ghcOptDylibName ] + + ------------------------ + -- Redirecting outputs + + , concat [ ["-osuf", suf] | suf <- flag ghcOptObjSuffix ] + , concat [ ["-hisuf", suf] | suf <- flag ghcOptHiSuffix ] + , concat [ ["-dynosuf", suf] | suf <- flag ghcOptDynObjSuffix ] + , concat [ ["-dynhisuf",suf] | suf <- flag ghcOptDynHiSuffix ] + , concat [ ["-outputdir", dir] | dir <- flag ghcOptOutputDir ] + , concat [ ["-odir", dir] | dir <- flag ghcOptObjDir ] + , concat [ ["-hidir", dir] | dir <- flag ghcOptHiDir ] + , concat [ ["-stubdir", dir] | dir <- flag ghcOptStubDir ] + + ----------------------- + -- Source search path + + , [ "-i" | flagBool ghcOptSourcePathClear ] + , [ "-i" ++ dir | dir <- flags ghcOptSourcePath ] + + -------------------- + + -------------------- + -- CPP, C, and C++ stuff + + , [ "-I" ++ dir | dir <- flags ghcOptCppIncludePath ] + , [ "-optP" ++ opt | opt <- ghcOptCppOptions opts] + , concat [ [ "-optP-include", "-optP" ++ inc] + | inc <- flags ghcOptCppIncludes ] + , [ "-optc" ++ opt | opt <- ghcOptCcOptions opts] + , -- C++ compiler options: GHC >= 8.10 requires -optcxx, older requires -optc + let cxxflag = case compilerCompatVersion GHC comp of + Just v | v >= mkVersion [8, 10] -> "-optcxx" + _ -> "-optc" + in [ cxxflag ++ opt | opt <- ghcOptCxxOptions opts] + , [ "-opta" ++ opt | opt <- ghcOptAsmOptions opts] + , concat [ ["-pgmc", cc] | cc <- flag ghcOptCcProgram ] + + ----------------- + -- Linker stuff + + , [ "-optl" ++ opt | opt <- ghcOptLinkOptions opts] + , ["-l" ++ lib | lib <- ghcOptLinkLibs opts] + , ["-L" ++ dir | dir <- flags ghcOptLinkLibPath ] + , if isOSX + then concat [ ["-framework", fmwk] + | fmwk <- flags ghcOptLinkFrameworks ] + else [] + , if isOSX + then concat [ ["-framework-path", path] + | path <- flags ghcOptLinkFrameworkDirs ] + else [] + , [ "-no-hs-main" | flagBool ghcOptLinkNoHsMain ] + , [ "-dynload deploy" | not (null (flags ghcOptRPaths)) ] + , concat [ [ "-optl-Wl,-rpath," ++ dir] + | dir <- flags ghcOptRPaths ] + , [ modDefFile | modDefFile <- flags ghcOptLinkModDefFiles ] + + ------------- + -- Packages + + , concat [ [ case () of + _ | unitIdSupported comp -> "-this-unit-id" + | packageKeySupported comp -> "-this-package-key" + | otherwise -> "-package-name" + , this_arg ] + | this_arg <- flag ghcOptThisUnitId ] + + , concat [ ["-this-component-id", prettyShow this_cid ] + | this_cid <- flag ghcOptThisComponentId ] + + , if null (ghcOptInstantiatedWith opts) + then [] + else "-instantiated-with" + : intercalate "," (map (\(n,m) -> prettyShow n ++ "=" + ++ prettyShow m) + (ghcOptInstantiatedWith opts)) + : [] + + , concat [ ["-fno-code", "-fwrite-interface"] | flagBool ghcOptNoCode ] + + , [ "-hide-all-packages" | flagBool ghcOptHideAllPackages ] + , [ "-Wmissing-home-modules" | flagBool ghcOptWarnMissingHomeModules ] + , [ "-no-auto-link-packages" | flagBool ghcOptNoAutoLinkPackages ] + + , packageDbArgs implInfo (ghcOptPackageDBs opts) + + , concat $ let space "" = "" + space xs = ' ' : xs + in [ ["-package-id", prettyShow ipkgid ++ space (prettyShow rns)] + | (ipkgid,rns) <- flags ghcOptPackages ] + + ---------------------------- + -- Language and extensions + + , if supportsHaskell2010 implInfo + then [ "-X" ++ prettyShow lang | lang <- flag ghcOptLanguage ] + else [] + + , [ ext' + | ext <- flags ghcOptExtensions + , ext' <- case Map.lookup ext (ghcOptExtensionMap opts) of + Just (Just arg) -> [arg] + Just Nothing -> [] + Nothing -> + error $ "Distribution.Simple.Program.GHC.renderGhcOptions: " + ++ prettyShow ext ++ " not present in ghcOptExtensionMap." + ] + + ---------------- + -- GHCi + + , concat [ [ "-ghci-script", script ] | script <- ghcOptGHCiScripts opts + , flagGhciScript implInfo ] + + --------------- + -- Inputs + + -- Specify the input file(s) first, so that in ghci the `main-is` module is + -- in scope instead of the first module defined in `other-modules`. + , flags ghcOptInputFiles + , concat [ [ "-x", "hs", script] | script <- flags ghcOptInputScripts ] + , [ prettyShow modu | modu <- flags ghcOptInputModules ] + + , concat [ [ "-o", out] | out <- flag ghcOptOutputFile ] + , concat [ [ "-dyno", out] | out <- flag ghcOptOutputDynFile ] + + --------------- + -- Extra + + , ghcOptExtra opts + + ] + + + where + implInfo = getImplInfo comp + isOSX = os == OSX + flag flg = flagToList (flg opts) + flags flg = fromNubListR . flg $ opts + flagBool flg = fromFlagOrDefault False (flg opts) + +verbosityOpts :: Verbosity -> [String] +verbosityOpts verbosity + | verbosity >= deafening = ["-v"] + | verbosity >= normal = [] + | otherwise = ["-w", "-v0"] + + +-- | GHC <7.6 uses '-package-conf' instead of '-package-db'. +packageDbArgsConf :: PackageDBStack -> [String] +packageDbArgsConf dbstack = case dbstack of + (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs + (GlobalPackageDB:dbs) -> ("-no-user-package-conf") + : concatMap specific dbs + _ -> ierror + where + specific (SpecificPackageDB db) = [ "-package-conf", db ] + specific _ = ierror + ierror = error $ "internal error: unexpected package db stack: " + ++ show dbstack + +-- | GHC >= 7.6 uses the '-package-db' flag. See +-- https://gitlab.haskell.org/ghc/ghc/-/issues/5977. +packageDbArgsDb :: PackageDBStack -> [String] +-- special cases to make arguments prettier in common scenarios +packageDbArgsDb dbstack = case dbstack of + (GlobalPackageDB:UserPackageDB:dbs) + | all isSpecific dbs -> concatMap single dbs + (GlobalPackageDB:dbs) + | all isSpecific dbs -> "-no-user-package-db" + : concatMap single dbs + dbs -> "-clear-package-db" + : concatMap single dbs + where + single (SpecificPackageDB db) = [ "-package-db", db ] + single GlobalPackageDB = [ "-global-package-db" ] + single UserPackageDB = [ "-user-package-db" ] + isSpecific (SpecificPackageDB _) = True + isSpecific _ = False + +packageDbArgs :: GhcImplInfo -> PackageDBStack -> [String] +packageDbArgs implInfo + | flagPackageConf implInfo = packageDbArgsConf + | otherwise = packageDbArgsDb + +-- ----------------------------------------------------------------------------- +-- Boilerplate Monoid instance for GhcOptions + +instance Monoid GhcOptions where + mempty = gmempty + mappend = (<>) + +instance Semigroup GhcOptions where + (<>) = gmappend diff --git a/cabal/Cabal/src/Distribution/Simple/Program/HcPkg.hs b/cabal/Cabal/src/Distribution/Simple/Program/HcPkg.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/Program/HcPkg.hs @@ -0,0 +1,517 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program.HcPkg +-- Copyright : Duncan Coutts 2009, 2013 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module provides an library interface to the @hc-pkg@ program. +-- Currently only GHC and GHCJS have hc-pkg programs. + +module Distribution.Simple.Program.HcPkg ( + -- * Types + HcPkgInfo(..), + RegisterOptions(..), + defaultRegisterOptions, + + -- * Actions + init, + invoke, + register, + unregister, + recache, + expose, + hide, + dump, + describe, + list, + + -- * Program invocations + initInvocation, + registerInvocation, + unregisterInvocation, + recacheInvocation, + exposeInvocation, + hideInvocation, + dumpInvocation, + describeInvocation, + listInvocation, + ) where + +import Distribution.Compat.Prelude hiding (init) +import Prelude () + +import Distribution.InstalledPackageInfo +import Distribution.Parsec +import Distribution.Pretty +import Distribution.Simple.Compiler +import Distribution.Simple.Program.Run +import Distribution.Simple.Program.Types +import Distribution.Simple.Utils +import Distribution.Types.ComponentId +import Distribution.Types.PackageId +import Distribution.Types.UnitId +import Distribution.Verbosity + +import Data.List (stripPrefix) +import System.FilePath as FilePath (isPathSeparator, joinPath, splitDirectories, splitPath, (<.>), ()) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.List.NonEmpty as NE +import qualified System.FilePath.Posix as FilePath.Posix + +-- | Information about the features and capabilities of an @hc-pkg@ +-- program. +-- +data HcPkgInfo = HcPkgInfo + { hcPkgProgram :: ConfiguredProgram + , noPkgDbStack :: Bool -- ^ no package DB stack supported + , noVerboseFlag :: Bool -- ^ hc-pkg does not support verbosity flags + , flagPackageConf :: Bool -- ^ use package-conf option instead of package-db + , supportsDirDbs :: Bool -- ^ supports directory style package databases + , requiresDirDbs :: Bool -- ^ requires directory style package databases + , nativeMultiInstance :: Bool -- ^ supports --enable-multi-instance flag + , recacheMultiInstance :: Bool -- ^ supports multi-instance via recache + , suppressFilesCheck :: Bool -- ^ supports --force-files or equivalent + } + + +-- | Call @hc-pkg@ to initialise a package database at the location {path}. +-- +-- > hc-pkg init {path} +-- +init :: HcPkgInfo -> Verbosity -> Bool -> FilePath -> IO () +init hpi verbosity preferCompat path + | not (supportsDirDbs hpi) + || (not (requiresDirDbs hpi) && preferCompat) + = writeFile path "[]" + + | otherwise + = runProgramInvocation verbosity (initInvocation hpi verbosity path) + +-- | Run @hc-pkg@ using a given package DB stack, directly forwarding the +-- provided command-line arguments to it. +invoke :: HcPkgInfo -> Verbosity -> PackageDBStack -> [String] -> IO () +invoke hpi verbosity dbStack extraArgs = + runProgramInvocation verbosity invocation + where + args = packageDbStackOpts hpi dbStack ++ extraArgs + invocation = programInvocation (hcPkgProgram hpi) args + +-- | Additional variations in the behaviour for 'register'. +data RegisterOptions = RegisterOptions { + -- | Allows re-registering \/ overwriting an existing package + registerAllowOverwrite :: Bool, + + -- | Insist on the ability to register multiple instances of a + -- single version of a single package. This will fail if the @hc-pkg@ + -- does not support it, see 'nativeMultiInstance' and + -- 'recacheMultiInstance'. + registerMultiInstance :: Bool, + + -- | Require that no checks are performed on the existence of package + -- files mentioned in the registration info. This must be used if + -- registering prior to putting the files in their final place. This will + -- fail if the @hc-pkg@ does not support it, see 'suppressFilesCheck'. + registerSuppressFilesCheck :: Bool + } + +-- | Defaults are @True@, @False@ and @False@ +defaultRegisterOptions :: RegisterOptions +defaultRegisterOptions = RegisterOptions { + registerAllowOverwrite = True, + registerMultiInstance = False, + registerSuppressFilesCheck = False + } + +-- | Call @hc-pkg@ to register a package. +-- +-- > hc-pkg register {filename | -} [--user | --global | --package-db] +-- +register :: HcPkgInfo -> Verbosity -> PackageDBStack + -> InstalledPackageInfo + -> RegisterOptions + -> IO () +register hpi verbosity packagedbs pkgInfo registerOptions + | registerMultiInstance registerOptions + , not (nativeMultiInstance hpi || recacheMultiInstance hpi) + = die' verbosity $ "HcPkg.register: the compiler does not support " + ++ "registering multiple instances of packages." + + | registerSuppressFilesCheck registerOptions + , not (suppressFilesCheck hpi) + = die' verbosity $ "HcPkg.register: the compiler does not support " + ++ "suppressing checks on files." + + -- This is a trick. Older versions of GHC do not support the + -- --enable-multi-instance flag for ghc-pkg register but it turns out that + -- the same ability is available by using ghc-pkg recache. The recache + -- command is there to support distro package managers that like to work + -- by just installing files and running update commands, rather than + -- special add/remove commands. So the way to register by this method is + -- to write the package registration file directly into the package db and + -- then call hc-pkg recache. + -- + | registerMultiInstance registerOptions + , recacheMultiInstance hpi + = do let pkgdb = registrationPackageDB packagedbs + writeRegistrationFileDirectly verbosity hpi pkgdb pkgInfo + recache hpi verbosity pkgdb + + | otherwise + = runProgramInvocation verbosity + (registerInvocation hpi verbosity packagedbs pkgInfo registerOptions) + +writeRegistrationFileDirectly :: Verbosity + -> HcPkgInfo + -> PackageDB + -> InstalledPackageInfo + -> IO () +writeRegistrationFileDirectly verbosity hpi (SpecificPackageDB dir) pkgInfo + | supportsDirDbs hpi + = do let pkgfile = dir prettyShow (installedUnitId pkgInfo) <.> "conf" + writeUTF8File pkgfile (showInstalledPackageInfo pkgInfo) + + | otherwise + = die' verbosity $ "HcPkg.writeRegistrationFileDirectly: compiler does not support dir style package dbs" + +writeRegistrationFileDirectly verbosity _ _ _ = + -- We don't know here what the dir for the global or user dbs are, + -- if that's needed it'll require a bit more plumbing to support. + die' verbosity $ "HcPkg.writeRegistrationFileDirectly: only supports SpecificPackageDB for now" + + +-- | Call @hc-pkg@ to unregister a package +-- +-- > hc-pkg unregister [pkgid] [--user | --global | --package-db] +-- +unregister :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO () +unregister hpi verbosity packagedb pkgid = + runProgramInvocation verbosity + (unregisterInvocation hpi verbosity packagedb pkgid) + + +-- | Call @hc-pkg@ to recache the registered packages. +-- +-- > hc-pkg recache [--user | --global | --package-db] +-- +recache :: HcPkgInfo -> Verbosity -> PackageDB -> IO () +recache hpi verbosity packagedb = + runProgramInvocation verbosity + (recacheInvocation hpi verbosity packagedb) + + +-- | Call @hc-pkg@ to expose a package. +-- +-- > hc-pkg expose [pkgid] [--user | --global | --package-db] +-- +expose :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO () +expose hpi verbosity packagedb pkgid = + runProgramInvocation verbosity + (exposeInvocation hpi verbosity packagedb pkgid) + +-- | Call @hc-pkg@ to retrieve a specific package +-- +-- > hc-pkg describe [pkgid] [--user | --global | --package-db] +-- +describe :: HcPkgInfo -> Verbosity -> PackageDBStack -> PackageId -> IO [InstalledPackageInfo] +describe hpi verbosity packagedb pid = do + + output <- getProgramInvocationLBS verbosity + (describeInvocation hpi verbosity packagedb pid) + `catchIO` \_ -> return mempty + + case parsePackages output of + Left ok -> return ok + _ -> die' verbosity $ "failed to parse output of '" + ++ programId (hcPkgProgram hpi) ++ " describe " ++ prettyShow pid ++ "'" + +-- | Call @hc-pkg@ to hide a package. +-- +-- > hc-pkg hide [pkgid] [--user | --global | --package-db] +-- +hide :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO () +hide hpi verbosity packagedb pkgid = + runProgramInvocation verbosity + (hideInvocation hpi verbosity packagedb pkgid) + + +-- | Call @hc-pkg@ to get all the details of all the packages in the given +-- package database. +-- +dump :: HcPkgInfo -> Verbosity -> PackageDB -> IO [InstalledPackageInfo] +dump hpi verbosity packagedb = do + + output <- getProgramInvocationLBS verbosity + (dumpInvocation hpi verbosity packagedb) + `catchIO` \e -> die' verbosity $ programId (hcPkgProgram hpi) ++ " dump failed: " + ++ displayException e + + case parsePackages output of + Left ok -> return ok + _ -> die' verbosity $ "failed to parse output of '" + ++ programId (hcPkgProgram hpi) ++ " dump'" + + +parsePackages :: LBS.ByteString -> Either [InstalledPackageInfo] [String] +parsePackages lbs0 = + case traverse parseInstalledPackageInfo $ splitPkgs lbs0 of + Right ok -> Left [ setUnitId . maybe id mungePackagePaths (pkgRoot pkg) $ pkg | (_, pkg) <- ok ] + Left msgs -> Right (NE.toList msgs) + where + splitPkgs :: LBS.ByteString -> [BS.ByteString] + splitPkgs = checkEmpty . doSplit + where + -- Handle the case of there being no packages at all. + checkEmpty [s] | BS.all isSpace8 s = [] + checkEmpty ss = ss + + isSpace8 :: Word8 -> Bool + isSpace8 9 = True -- '\t' + isSpace8 10 = True -- '\n' + isSpace8 13 = True -- '\r' + isSpace8 32 = True -- ' ' + isSpace8 _ = False + + doSplit :: LBS.ByteString -> [BS.ByteString] + doSplit lbs = go (LBS.findIndices (\w -> w == 10 || w == 13) lbs) + where + go :: [Int64] -> [BS.ByteString] + go [] = [ LBS.toStrict lbs ] + go (idx:idxs) = + let (pfx, sfx) = LBS.splitAt idx lbs + in case foldr (<|>) Nothing $ map (`lbsStripPrefix` sfx) separators of + Just sfx' -> LBS.toStrict pfx : doSplit sfx' + Nothing -> go idxs + + separators :: [LBS.ByteString] + separators = ["\n---\n", "\r\n---\r\n", "\r---\r"] + +lbsStripPrefix :: LBS.ByteString -> LBS.ByteString -> Maybe LBS.ByteString +#if MIN_VERSION_bytestring(0,10,8) +lbsStripPrefix pfx lbs = LBS.stripPrefix pfx lbs +#else +lbsStripPrefix pfx lbs + | LBS.isPrefixOf pfx lbs = Just (LBS.drop (LBS.length pfx) lbs) + | otherwise = Nothing +#endif + + +mungePackagePaths :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo +-- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec +-- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html) +-- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}. +-- The "pkgroot" is the directory containing the package database. +mungePackagePaths pkgroot pkginfo = + pkginfo { + importDirs = mungePaths (importDirs pkginfo), + includeDirs = mungePaths (includeDirs pkginfo), + libraryDirs = mungePaths (libraryDirs pkginfo), + libraryDirsStatic = mungePaths (libraryDirsStatic pkginfo), + libraryDynDirs = mungePaths (libraryDynDirs pkginfo), + frameworkDirs = mungePaths (frameworkDirs pkginfo), + haddockInterfaces = mungePaths (haddockInterfaces pkginfo), + haddockHTMLs = mungeUrls (haddockHTMLs pkginfo) + } + where + mungePaths = map mungePath + mungeUrls = map mungeUrl + + mungePath p = case stripVarPrefix "${pkgroot}" p of + Just p' -> pkgroot p' + Nothing -> p + + mungeUrl p = case stripVarPrefix "${pkgrooturl}" p of + Just p' -> toUrlPath pkgroot p' + Nothing -> p + + toUrlPath r p = "file:///" + -- URLs always use posix style '/' separators: + ++ FilePath.Posix.joinPath (r : FilePath.splitDirectories p) + + stripVarPrefix var p = + case splitPath p of + (root:path') -> case stripPrefix var root of + Just [sep] | isPathSeparator sep -> Just (joinPath path') + _ -> Nothing + _ -> Nothing + + +-- Older installed package info files did not have the installedUnitId +-- field, so if it is missing then we fill it as the source package ID. +-- NB: Internal libraries not supported. +setUnitId :: InstalledPackageInfo -> InstalledPackageInfo +setUnitId pkginfo@InstalledPackageInfo { + installedUnitId = uid, + sourcePackageId = pid + } | unUnitId uid == "" + = pkginfo { + installedUnitId = mkLegacyUnitId pid, + installedComponentId_ = mkComponentId (prettyShow pid) + } +setUnitId pkginfo = pkginfo + + +-- | Call @hc-pkg@ to get the source package Id of all the packages in the +-- given package database. +-- +-- This is much less information than with 'dump', but also rather quicker. +-- Note in particular that it does not include the 'UnitId', just +-- the source 'PackageId' which is not necessarily unique in any package db. +-- +list :: HcPkgInfo -> Verbosity -> PackageDB + -> IO [PackageId] +list hpi verbosity packagedb = do + + output <- getProgramInvocationOutput verbosity + (listInvocation hpi verbosity packagedb) + `catchIO` \_ -> die' verbosity $ programId (hcPkgProgram hpi) ++ " list failed" + + case parsePackageIds output of + Just ok -> return ok + _ -> die' verbosity $ "failed to parse output of '" + ++ programId (hcPkgProgram hpi) ++ " list'" + + where + parsePackageIds = traverse simpleParsec . words + +-------------------------- +-- The program invocations +-- + +initInvocation :: HcPkgInfo -> Verbosity -> FilePath -> ProgramInvocation +initInvocation hpi verbosity path = + programInvocation (hcPkgProgram hpi) args + where + args = ["init", path] + ++ verbosityOpts hpi verbosity + +registerInvocation + :: HcPkgInfo -> Verbosity -> PackageDBStack + -> InstalledPackageInfo + -> RegisterOptions + -> ProgramInvocation +registerInvocation hpi verbosity packagedbs pkgInfo registerOptions = + (programInvocation (hcPkgProgram hpi) (args "-")) { + progInvokeInput = Just $ IODataText $ showInstalledPackageInfo pkgInfo, + progInvokeInputEncoding = IOEncodingUTF8 + } + where + cmdname + | registerAllowOverwrite registerOptions = "update" + | registerMultiInstance registerOptions = "update" + | otherwise = "register" + + args file = [cmdname, file] + ++ packageDbStackOpts hpi packagedbs + ++ [ "--enable-multi-instance" + | registerMultiInstance registerOptions ] + ++ [ "--force-files" + | registerSuppressFilesCheck registerOptions ] + ++ verbosityOpts hpi verbosity + +unregisterInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId + -> ProgramInvocation +unregisterInvocation hpi verbosity packagedb pkgid = + programInvocation (hcPkgProgram hpi) $ + ["unregister", packageDbOpts hpi packagedb, prettyShow pkgid] + ++ verbosityOpts hpi verbosity + + +recacheInvocation :: HcPkgInfo -> Verbosity -> PackageDB + -> ProgramInvocation +recacheInvocation hpi verbosity packagedb = + programInvocation (hcPkgProgram hpi) $ + ["recache", packageDbOpts hpi packagedb] + ++ verbosityOpts hpi verbosity + + +exposeInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId + -> ProgramInvocation +exposeInvocation hpi verbosity packagedb pkgid = + programInvocation (hcPkgProgram hpi) $ + ["expose", packageDbOpts hpi packagedb, prettyShow pkgid] + ++ verbosityOpts hpi verbosity + +describeInvocation :: HcPkgInfo -> Verbosity -> PackageDBStack -> PackageId + -> ProgramInvocation +describeInvocation hpi verbosity packagedbs pkgid = + programInvocation (hcPkgProgram hpi) $ + ["describe", prettyShow pkgid] + ++ packageDbStackOpts hpi packagedbs + ++ verbosityOpts hpi verbosity + +hideInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId + -> ProgramInvocation +hideInvocation hpi verbosity packagedb pkgid = + programInvocation (hcPkgProgram hpi) $ + ["hide", packageDbOpts hpi packagedb, prettyShow pkgid] + ++ verbosityOpts hpi verbosity + + +dumpInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> ProgramInvocation +dumpInvocation hpi _verbosity packagedb = + (programInvocation (hcPkgProgram hpi) args) { + progInvokeOutputEncoding = IOEncodingUTF8 + } + where + args = ["dump", packageDbOpts hpi packagedb] + ++ verbosityOpts hpi silent + -- We use verbosity level 'silent' because it is important that we + -- do not contaminate the output with info/debug messages. + +listInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> ProgramInvocation +listInvocation hpi _verbosity packagedb = + (programInvocation (hcPkgProgram hpi) args) { + progInvokeOutputEncoding = IOEncodingUTF8 + } + where + args = ["list", "--simple-output", packageDbOpts hpi packagedb] + ++ verbosityOpts hpi silent + -- We use verbosity level 'silent' because it is important that we + -- do not contaminate the output with info/debug messages. + + +packageDbStackOpts :: HcPkgInfo -> PackageDBStack -> [String] +packageDbStackOpts hpi dbstack + | noPkgDbStack hpi = [packageDbOpts hpi (registrationPackageDB dbstack)] + | otherwise = case dbstack of + (GlobalPackageDB:UserPackageDB:dbs) -> "--global" + : "--user" + : map specific dbs + (GlobalPackageDB:dbs) -> "--global" + : ("--no-user-" ++ packageDbFlag hpi) + : map specific dbs + _ -> ierror + where + specific (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ db + specific _ = ierror + ierror :: a + ierror = error ("internal error: unexpected package db stack: " ++ show dbstack) + +packageDbFlag :: HcPkgInfo -> String +packageDbFlag hpi + | flagPackageConf hpi + = "package-conf" + | otherwise + = "package-db" + +packageDbOpts :: HcPkgInfo -> PackageDB -> String +packageDbOpts _ GlobalPackageDB = "--global" +packageDbOpts _ UserPackageDB = "--user" +packageDbOpts hpi (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ db + +verbosityOpts :: HcPkgInfo -> Verbosity -> [String] +verbosityOpts hpi v + | noVerboseFlag hpi + = [] + | v >= deafening = ["-v2"] + | v == silent = ["-v0"] + | otherwise = [] diff --git a/cabal/Cabal/src/Distribution/Simple/Program/Hpc.hs b/cabal/Cabal/src/Distribution/Simple/Program/Hpc.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/Program/Hpc.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program.Hpc +-- Copyright : Thomas Tuegel 2011 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module provides an library interface to the @hpc@ program. + +module Distribution.Simple.Program.Hpc + ( markup + , union + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import System.Directory (makeRelativeToCurrentDirectory) + +import Distribution.ModuleName +import Distribution.Simple.Program.Run +import Distribution.Simple.Program.Types +import Distribution.Pretty +import Distribution.Simple.Utils +import Distribution.Verbosity +import Distribution.Version + +-- | Invoke hpc with the given parameters. +-- +-- Prior to HPC version 0.7 (packaged with GHC 7.8), hpc did not handle +-- multiple .mix paths correctly, so we print a warning, and only pass it the +-- first path in the list. This means that e.g. test suites that import their +-- library as a dependency can still work, but those that include the library +-- modules directly (in other-modules) don't. +markup :: ConfiguredProgram + -> Version + -> Verbosity + -> FilePath -- ^ Path to .tix file + -> [FilePath] -- ^ Paths to .mix file directories + -> FilePath -- ^ Path where html output should be located + -> [ModuleName] -- ^ List of modules to include in the report + -> IO () +markup hpc hpcVer verbosity tixFile hpcDirs destDir included = do + hpcDirs' <- if withinRange hpcVer (orLaterVersion version07) + then return hpcDirs + else do + warn verbosity $ "Your version of HPC (" ++ prettyShow hpcVer + ++ ") does not properly handle multiple search paths. " + ++ "Coverage report generation may fail unexpectedly. These " + ++ "issues are addressed in version 0.7 or later (GHC 7.8 or " + ++ "later)." + ++ if null droppedDirs + then "" + else " The following search paths have been abandoned: " + ++ show droppedDirs + return passedDirs + + -- Prior to GHC 8.0, hpc assumes all .mix paths are relative. + hpcDirs'' <- traverse makeRelativeToCurrentDirectory hpcDirs' + + runProgramInvocation verbosity + (markupInvocation hpc tixFile hpcDirs'' destDir included) + where + version07 = mkVersion [0, 7] + (passedDirs, droppedDirs) = splitAt 1 hpcDirs + +markupInvocation :: ConfiguredProgram + -> FilePath -- ^ Path to .tix file + -> [FilePath] -- ^ Paths to .mix file directories + -> FilePath -- ^ Path where html output should be + -- located + -> [ModuleName] -- ^ List of modules to include + -> ProgramInvocation +markupInvocation hpc tixFile hpcDirs destDir included = + let args = [ "markup", tixFile + , "--destdir=" ++ destDir + ] + ++ map ("--hpcdir=" ++) hpcDirs + ++ ["--include=" ++ prettyShow moduleName + | moduleName <- included ] + in programInvocation hpc args + +union :: ConfiguredProgram + -> Verbosity + -> [FilePath] -- ^ Paths to .tix files + -> FilePath -- ^ Path to resultant .tix file + -> [ModuleName] -- ^ List of modules to exclude from union + -> IO () +union hpc verbosity tixFiles outFile excluded = + runProgramInvocation verbosity + (unionInvocation hpc tixFiles outFile excluded) + +unionInvocation :: ConfiguredProgram + -> [FilePath] -- ^ Paths to .tix files + -> FilePath -- ^ Path to resultant .tix file + -> [ModuleName] -- ^ List of modules to exclude from union + -> ProgramInvocation +unionInvocation hpc tixFiles outFile excluded = + programInvocation hpc $ concat + [ ["sum", "--union"] + , tixFiles + , ["--output=" ++ outFile] + , ["--exclude=" ++ prettyShow moduleName + | moduleName <- excluded ] + ] diff --git a/cabal/Cabal/src/Distribution/Simple/Program/Internal.hs b/cabal/Cabal/src/Distribution/Simple/Program/Internal.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/Program/Internal.hs @@ -0,0 +1,47 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program.Internal +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Internal utilities used by Distribution.Simple.Program.*. + +module Distribution.Simple.Program.Internal ( + stripExtractVersion, + ) where + +import Prelude () +import Distribution.Compat.Prelude +import Distribution.Utils.Generic(safeTail) + +-- | Extract the version number from the output of 'strip --version'. +-- +-- Invoking "strip --version" gives very inconsistent results. We ignore +-- everything in parentheses (see #2497), look for the first word that starts +-- with a number, and try parsing out the first two components of it. Non-GNU +-- 'strip' doesn't appear to have a version flag. +stripExtractVersion :: String -> String +stripExtractVersion str = + let numeric "" = False + numeric (x:_) = isDigit x + + -- Filter out everything in parentheses. + filterPar' :: Int -> [String] -> [String] + filterPar' _ [] = [] + filterPar' n (x:xs) + | n >= 0 && "(" `isPrefixOf` x = filterPar' (n+1) ((safeTail x):xs) + | n > 0 && ")" `isSuffixOf` x = filterPar' (n-1) xs + | n > 0 = filterPar' n xs + | otherwise = x:filterPar' n xs + + filterPar = filterPar' 0 + + in case dropWhile (not . numeric) (filterPar . words $ str) of + (ver:_) -> + -- take the first two version components + let isDot = (== '.') + (major, rest) = break isDot ver + minor = takeWhile isDigit (dropWhile isDot rest) + in major ++ "." ++ minor + _ -> "" diff --git a/cabal/Cabal/src/Distribution/Simple/Program/Ld.hs b/cabal/Cabal/src/Distribution/Simple/Program/Ld.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/Program/Ld.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program.Ld +-- Copyright : Duncan Coutts 2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module provides an library interface to the @ld@ linker program. + +module Distribution.Simple.Program.Ld ( + combineObjectFiles, + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Simple.Compiler (arResponseFilesSupported) +import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..)) +import Distribution.Simple.Program.ResponseFile + ( withResponseFile ) +import Distribution.Simple.Program.Run + ( ProgramInvocation, programInvocation, multiStageProgramInvocation + , runProgramInvocation ) +import Distribution.Simple.Program.Types + ( ConfiguredProgram(..) ) +import Distribution.Simple.Setup + ( fromFlagOrDefault, configUseResponseFiles ) +import Distribution.Simple.Utils + ( defaultTempFileOptions ) +import Distribution.Verbosity + ( Verbosity ) + +import System.Directory + ( renameFile ) +import System.FilePath + ( (<.>), takeDirectory ) + +-- | Call @ld -r@ to link a bunch of object files together. +-- +combineObjectFiles :: Verbosity -> LocalBuildInfo -> ConfiguredProgram + -> FilePath -> [FilePath] -> IO () +combineObjectFiles verbosity lbi ld target files = do + + -- Unlike "ar", the "ld" tool is not designed to be used with xargs. That is, + -- if we have more object files than fit on a single command line then we + -- have a slight problem. What we have to do is link files in batches into + -- a temp object file and then include that one in the next batch. + + let simpleArgs = ["-r", "-o", target] + + initialArgs = ["-r", "-o", target] + middleArgs = ["-r", "-o", target, tmpfile] + finalArgs = middleArgs + + simple = programInvocation ld simpleArgs + initial = programInvocation ld initialArgs + middle = programInvocation ld middleArgs + final = programInvocation ld finalArgs + + targetDir = takeDirectory target + + invokeWithResponesFile :: FilePath -> ProgramInvocation + invokeWithResponesFile atFile = + programInvocation ld $ simpleArgs ++ ['@' : atFile] + + oldVersionManualOverride = + fromFlagOrDefault False $ configUseResponseFiles $ configFlags lbi + -- Whether ghc's ar supports response files is a good proxy for + -- whether ghc's ld supports them as well. + responseArgumentsNotSupported = + not (arResponseFilesSupported (compiler lbi)) + + if oldVersionManualOverride || responseArgumentsNotSupported + then + run $ multiStageProgramInvocation simple (initial, middle, final) files + else + withResponseFile verbosity defaultTempFileOptions targetDir "ld.rsp" Nothing files $ + \path -> runProgramInvocation verbosity $ invokeWithResponesFile path + + where + tmpfile = target <.> "tmp" -- perhaps should use a proper temp file + + run :: [ProgramInvocation] -> IO () + run [] = return () + run [inv] = runProgramInvocation verbosity inv + run (inv:invs) = do runProgramInvocation verbosity inv + renameFile target tmpfile + run invs diff --git a/cabal/Cabal/src/Distribution/Simple/Program/ResponseFile.hs b/cabal/Cabal/src/Distribution/Simple/Program/ResponseFile.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/Program/ResponseFile.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +---------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program.ResponseFile +-- Copyright : (c) Sergey Vinokurov 2017 +-- License : BSD3-style +-- +-- Maintainer : cabal-devel@haskell.org +-- Created : 23 July 2017 +---------------------------------------------------------------------------- + +module Distribution.Simple.Program.ResponseFile (withResponseFile) where + +import Prelude () +import System.IO (TextEncoding, hSetEncoding, hPutStr, hClose) + +import Distribution.Compat.Prelude +import Distribution.Simple.Utils (TempFileOptions, withTempFileEx, debug) +import Distribution.Verbosity + +withResponseFile + :: Verbosity + -> TempFileOptions + -> FilePath -- ^ Working directory to create response file in. + -> FilePath -- ^ Template for response file name. + -> Maybe TextEncoding -- ^ Encoding to use for response file contents. + -> [String] -- ^ Arguments to put into response file. + -> (FilePath -> IO a) + -> IO a +withResponseFile verbosity tmpFileOpts workDir fileNameTemplate encoding arguments f = + withTempFileEx tmpFileOpts workDir fileNameTemplate $ \responseFileName hf -> do + traverse_ (hSetEncoding hf) encoding + let responseContents = unlines $ map escapeResponseFileArg arguments + hPutStr hf responseContents + hClose hf + debug verbosity $ responseFileName ++ " contents: <<<" + debug verbosity responseContents + debug verbosity $ ">>> " ++ responseFileName + f responseFileName + +-- Support a gcc-like response file syntax. Each separate +-- argument and its possible parameter(s), will be separated in the +-- response file by an actual newline; all other whitespace, +-- single quotes, double quotes, and the character used for escaping +-- (backslash) are escaped. The called program will need to do a similar +-- inverse operation to de-escape and re-constitute the argument list. +escapeResponseFileArg :: String -> String +escapeResponseFileArg = reverse . foldl' escape [] + where + escape :: String -> Char -> String + escape cs c = + case c of + '\\' -> c:'\\':cs + '\'' -> c:'\\':cs + '"' -> c:'\\':cs + _ | isSpace c -> c:'\\':cs + | otherwise -> c:cs + + diff --git a/cabal/Cabal/src/Distribution/Simple/Program/Run.hs b/cabal/Cabal/src/Distribution/Simple/Program/Run.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/Program/Run.hs @@ -0,0 +1,297 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program.Run +-- Copyright : Duncan Coutts 2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module provides a data type for program invocations and functions to +-- run them. + +module Distribution.Simple.Program.Run ( + ProgramInvocation(..), + IOEncoding(..), + emptyProgramInvocation, + simpleProgramInvocation, + programInvocation, + multiStageProgramInvocation, + + runProgramInvocation, + getProgramInvocationOutput, + getProgramInvocationLBS, + getProgramInvocationOutputAndErrors, + + getEffectiveEnvironment, + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Compat.Environment +import Distribution.Simple.Program.Types +import Distribution.Simple.Utils +import Distribution.Utils.Generic +import Distribution.Verbosity + +import System.FilePath (searchPathSeparator) + +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Map as Map + +-- | Represents a specific invocation of a specific program. +-- +-- This is used as an intermediate type between deciding how to call a program +-- and actually doing it. This provides the opportunity to the caller to +-- adjust how the program will be called. These invocations can either be run +-- directly or turned into shell or batch scripts. +-- +data ProgramInvocation = ProgramInvocation { + progInvokePath :: FilePath, + progInvokeArgs :: [String], + progInvokeEnv :: [(String, Maybe String)], + -- Extra paths to add to PATH + progInvokePathEnv :: [FilePath], + progInvokeCwd :: Maybe FilePath, + progInvokeInput :: Maybe IOData, + progInvokeInputEncoding :: IOEncoding, -- ^ TODO: remove this, make user decide when constructing 'progInvokeInput'. + progInvokeOutputEncoding :: IOEncoding + } + +data IOEncoding = IOEncodingText -- locale mode text + | IOEncodingUTF8 -- always utf8 + +encodeToIOData :: IOEncoding -> IOData -> IOData +encodeToIOData _ iod@(IODataBinary _) = iod +encodeToIOData IOEncodingText iod@(IODataText _) = iod +encodeToIOData IOEncodingUTF8 (IODataText str) = IODataBinary (toUTF8LBS str) + +emptyProgramInvocation :: ProgramInvocation +emptyProgramInvocation = + ProgramInvocation { + progInvokePath = "", + progInvokeArgs = [], + progInvokeEnv = [], + progInvokePathEnv = [], + progInvokeCwd = Nothing, + progInvokeInput = Nothing, + progInvokeInputEncoding = IOEncodingText, + progInvokeOutputEncoding = IOEncodingText + } + +simpleProgramInvocation :: FilePath -> [String] -> ProgramInvocation +simpleProgramInvocation path args = + emptyProgramInvocation { + progInvokePath = path, + progInvokeArgs = args + } + +programInvocation :: ConfiguredProgram -> [String] -> ProgramInvocation +programInvocation prog args = + emptyProgramInvocation { + progInvokePath = programPath prog, + progInvokeArgs = programDefaultArgs prog + ++ args + ++ programOverrideArgs prog, + progInvokeEnv = programOverrideEnv prog + } + + +runProgramInvocation :: Verbosity -> ProgramInvocation -> IO () +runProgramInvocation verbosity + ProgramInvocation { + progInvokePath = path, + progInvokeArgs = args, + progInvokeEnv = [], + progInvokePathEnv = [], + progInvokeCwd = Nothing, + progInvokeInput = Nothing + } = + rawSystemExit verbosity path args + +runProgramInvocation verbosity + ProgramInvocation { + progInvokePath = path, + progInvokeArgs = args, + progInvokeEnv = envOverrides, + progInvokePathEnv = extraPath, + progInvokeCwd = mcwd, + progInvokeInput = Nothing + } = do + pathOverride <- getExtraPathEnv envOverrides extraPath + menv <- getEffectiveEnvironment (envOverrides ++ pathOverride) + exitCode <- rawSystemIOWithEnv verbosity + path args + mcwd menv + Nothing Nothing Nothing + when (exitCode /= ExitSuccess) $ + exitWith exitCode + +runProgramInvocation verbosity + ProgramInvocation { + progInvokePath = path, + progInvokeArgs = args, + progInvokeEnv = envOverrides, + progInvokePathEnv = extraPath, + progInvokeCwd = mcwd, + progInvokeInput = Just inputStr, + progInvokeInputEncoding = encoding + } = do + pathOverride <- getExtraPathEnv envOverrides extraPath + menv <- getEffectiveEnvironment (envOverrides ++ pathOverride) + (_, errors, exitCode) <- rawSystemStdInOut verbosity + path args + mcwd menv + (Just input) IODataModeBinary + when (exitCode /= ExitSuccess) $ + die' verbosity $ "'" ++ path ++ "' exited with an error:\n" ++ errors + where + input = encodeToIOData encoding inputStr + +getProgramInvocationOutput :: Verbosity -> ProgramInvocation -> IO String +getProgramInvocationOutput verbosity inv = do + (output, errors, exitCode) <- getProgramInvocationOutputAndErrors verbosity inv + when (exitCode /= ExitSuccess) $ + die' verbosity $ "'" ++ progInvokePath inv ++ "' exited with an error:\n" ++ errors + return output + +getProgramInvocationLBS :: Verbosity -> ProgramInvocation -> IO LBS.ByteString +getProgramInvocationLBS verbosity inv = do + (output, errors, exitCode) <- getProgramInvocationIODataAndErrors verbosity inv IODataModeBinary + when (exitCode /= ExitSuccess) $ + die' verbosity $ "'" ++ progInvokePath inv ++ "' exited with an error:\n" ++ errors + return output + +getProgramInvocationOutputAndErrors :: Verbosity -> ProgramInvocation + -> IO (String, String, ExitCode) +getProgramInvocationOutputAndErrors verbosity inv = case progInvokeOutputEncoding inv of + IOEncodingText -> do + (output, errors, exitCode) <- getProgramInvocationIODataAndErrors verbosity inv IODataModeText + return (output, errors, exitCode) + IOEncodingUTF8 -> do + (output', errors, exitCode) <- getProgramInvocationIODataAndErrors verbosity inv IODataModeBinary + return (normaliseLineEndings (fromUTF8LBS output'), errors, exitCode) + +getProgramInvocationIODataAndErrors + :: KnownIODataMode mode => Verbosity -> ProgramInvocation -> IODataMode mode + -> IO (mode, String, ExitCode) +getProgramInvocationIODataAndErrors + verbosity + ProgramInvocation + { progInvokePath = path + , progInvokeArgs = args + , progInvokeEnv = envOverrides + , progInvokePathEnv = extraPath + , progInvokeCwd = mcwd + , progInvokeInput = minputStr + , progInvokeInputEncoding = encoding + } + mode = do + pathOverride <- getExtraPathEnv envOverrides extraPath + menv <- getEffectiveEnvironment (envOverrides ++ pathOverride) + rawSystemStdInOut verbosity path args mcwd menv input mode + where + input = encodeToIOData encoding <$> minputStr + +getExtraPathEnv :: [(String, Maybe String)] -> [FilePath] -> IO [(String, Maybe String)] +getExtraPathEnv _ [] = return [] +getExtraPathEnv env extras = do + mb_path <- case lookup "PATH" env of + Just x -> return x + Nothing -> lookupEnv "PATH" + let extra = intercalate [searchPathSeparator] extras + path' = case mb_path of + Nothing -> extra + Just path -> extra ++ searchPathSeparator : path + return [("PATH", Just path')] + +-- | Return the current environment extended with the given overrides. +-- If an entry is specified twice in @overrides@, the second entry takes +-- precedence. +-- +getEffectiveEnvironment :: [(String, Maybe String)] + -> IO (Maybe [(String, String)]) +getEffectiveEnvironment [] = return Nothing +getEffectiveEnvironment overrides = + fmap (Just . Map.toList . apply overrides . Map.fromList) getEnvironment + where + apply os env = foldl' (flip update) env os + update (var, Nothing) = Map.delete var + update (var, Just val) = Map.insert var val + +-- | Like the unix xargs program. Useful for when we've got very long command +-- lines that might overflow an OS limit on command line length and so you +-- need to invoke a command multiple times to get all the args in. +-- +-- It takes four template invocations corresponding to the simple, initial, +-- middle and last invocations. If the number of args given is small enough +-- that we can get away with just a single invocation then the simple one is +-- used: +-- +-- > $ simple args +-- +-- If the number of args given means that we need to use multiple invocations +-- then the templates for the initial, middle and last invocations are used: +-- +-- > $ initial args_0 +-- > $ middle args_1 +-- > $ middle args_2 +-- > ... +-- > $ final args_n +-- +multiStageProgramInvocation + :: ProgramInvocation + -> (ProgramInvocation, ProgramInvocation, ProgramInvocation) + -> [String] + -> [ProgramInvocation] +multiStageProgramInvocation simple (initial, middle, final) args = + + let argSize inv = length (progInvokePath inv) + + foldl' (\s a -> length a + 1 + s) 1 (progInvokeArgs inv) + fixedArgSize = maximum (map argSize [simple, initial, middle, final]) + chunkSize = maxCommandLineSize - fixedArgSize + + in case splitChunks chunkSize args of + [] -> [ simple ] + + [c] -> [ simple `appendArgs` c ] + + (c:c2:cs) | (xs, x) <- unsnocNE (c2:|cs) -> + [ initial `appendArgs` c ] + ++ [ middle `appendArgs` c'| c' <- xs ] + ++ [ final `appendArgs` x ] + + where + appendArgs :: ProgramInvocation -> [String] -> ProgramInvocation + inv `appendArgs` as = inv { progInvokeArgs = progInvokeArgs inv ++ as } + + splitChunks :: Int -> [[a]] -> [[[a]]] + splitChunks len = unfoldr $ \s -> + if null s then Nothing + else Just (chunk len s) + + chunk :: Int -> [[a]] -> ([[a]], [[a]]) + chunk len (s:_) | length s >= len = error toolong + chunk len ss = chunk' [] len ss + + chunk' :: [[a]] -> Int -> [[a]] -> ([[a]], [[a]]) + chunk' acc len (s:ss) + | len' < len = chunk' (s:acc) (len-len'-1) ss + where len' = length s + chunk' acc _ ss = (reverse acc, ss) + + toolong = "multiStageProgramInvocation: a single program arg is larger " + ++ "than the maximum command line length!" + + +--FIXME: discover this at configure time or runtime on unix +-- The value is 32k on Windows and posix specifies a minimum of 4k +-- but all sensible unixes use more than 4k. +-- we could use getSysVar ArgumentLimit but that's in the unix lib +-- +maxCommandLineSize :: Int +maxCommandLineSize = 30 * 1024 diff --git a/cabal/Cabal/src/Distribution/Simple/Program/Script.hs b/cabal/Cabal/src/Distribution/Simple/Program/Script.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/Program/Script.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE GADTs #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program.Script +-- Copyright : Duncan Coutts 2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module provides an library interface to the @hc-pkg@ program. +-- Currently only GHC and LHC have hc-pkg programs. + +module Distribution.Simple.Program.Script ( + + invocationAsSystemScript, + invocationAsShellScript, + invocationAsBatchFile, + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Simple.Program.Run +import Distribution.Simple.Utils +import Distribution.System + +-- | Generate a system script, either POSIX shell script or Windows batch file +-- as appropriate for the given system. +-- +invocationAsSystemScript :: OS -> ProgramInvocation -> String +invocationAsSystemScript Windows = invocationAsBatchFile +invocationAsSystemScript _ = invocationAsShellScript + + +-- | Generate a POSIX shell script that invokes a program. +-- +invocationAsShellScript :: ProgramInvocation -> String +invocationAsShellScript + ProgramInvocation { + progInvokePath = path, + progInvokeArgs = args, + progInvokeEnv = envExtra, + progInvokeCwd = mcwd, + progInvokeInput = minput + } = unlines $ + [ "#!/bin/sh" ] + ++ concatMap setEnv envExtra + ++ [ "cd " ++ quote cwd | cwd <- maybeToList mcwd ] + ++ [ (case minput of + Nothing -> "" + Just input -> "printf '%s' " ++ quote (iodataToText input) ++ " | ") + ++ unwords (map quote $ path : args) ++ " \"$@\""] + + where + setEnv (var, Nothing) = ["unset " ++ var, "export " ++ var] + setEnv (var, Just val) = ["export " ++ var ++ "=" ++ quote val] + + quote :: String -> String + quote s = "'" ++ escape s ++ "'" + + escape [] = [] + escape ('\'':cs) = "'\\''" ++ escape cs + escape (c :cs) = c : escape cs + +iodataToText :: IOData -> String +iodataToText (IODataText str) = str +iodataToText (IODataBinary lbs) = fromUTF8LBS lbs + + +-- | Generate a Windows batch file that invokes a program. +-- +invocationAsBatchFile :: ProgramInvocation -> String +invocationAsBatchFile + ProgramInvocation { + progInvokePath = path, + progInvokeArgs = args, + progInvokeEnv = envExtra, + progInvokeCwd = mcwd, + progInvokeInput = minput + } = unlines $ + [ "@echo off" ] + ++ map setEnv envExtra + ++ [ "cd \"" ++ cwd ++ "\"" | cwd <- maybeToList mcwd ] + ++ case minput of + Nothing -> + [ path ++ concatMap (' ':) args ] + + Just input -> + [ "(" ] + ++ [ "echo " ++ escape line | line <- lines $ iodataToText input ] + ++ [ ") | " + ++ "\"" ++ path ++ "\"" + ++ concatMap (\arg -> ' ':quote arg) args ] + + where + setEnv (var, Nothing) = "set " ++ var ++ "=" + setEnv (var, Just val) = "set " ++ var ++ "=" ++ escape val + + quote :: String -> String + quote s = "\"" ++ escapeQ s ++ "\"" + + escapeQ [] = [] + escapeQ ('"':cs) = "\"\"\"" ++ escapeQ cs + escapeQ (c :cs) = c : escapeQ cs + + escape [] = [] + escape ('|':cs) = "^|" ++ escape cs + escape ('<':cs) = "^<" ++ escape cs + escape ('>':cs) = "^>" ++ escape cs + escape ('&':cs) = "^&" ++ escape cs + escape ('(':cs) = "^(" ++ escape cs + escape (')':cs) = "^)" ++ escape cs + escape ('^':cs) = "^^" ++ escape cs + escape (c :cs) = c : escape cs diff --git a/cabal/Cabal/src/Distribution/Simple/Program/Strip.hs b/cabal/Cabal/src/Distribution/Simple/Program/Strip.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/Program/Strip.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program.Strip +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module provides an library interface to the @strip@ program. + +module Distribution.Simple.Program.Strip (stripLib, stripExe) + where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Simple.Program +import Distribution.Simple.Utils +import Distribution.System +import Distribution.Verbosity +import Distribution.Version + +import System.FilePath (takeBaseName) + +runStrip :: Verbosity -> ProgramDb -> FilePath -> [String] -> IO () +runStrip verbosity progDb path args = + case lookupProgram stripProgram progDb of + Just strip -> runProgram verbosity strip (args ++ [path]) + Nothing -> unless (buildOS == Windows) $ + -- Don't bother warning on windows, we don't expect them to + -- have the strip program anyway. + warn verbosity $ "Unable to strip executable or library '" + ++ (takeBaseName path) + ++ "' (missing the 'strip' program)" + +stripExe :: Verbosity -> Platform -> ProgramDb -> FilePath -> IO () +stripExe verbosity (Platform _arch os) progdb path = + runStrip verbosity progdb path args + where + args = case os of + OSX -> ["-x"] -- By default, stripping the ghc binary on at least + -- some OS X installations causes: + -- HSbase-3.0.o: unknown symbol `_environ'" + -- The -x flag fixes that. + _ -> [] + +stripLib :: Verbosity -> Platform -> ProgramDb -> FilePath -> IO () +stripLib verbosity (Platform arch os) progdb path = do + case os of + OSX -> -- '--strip-unneeded' is not supported on OS X, iOS, AIX, or + -- Solaris. See #1630. + return () + IOS -> return () + AIX -> return () + Solaris -> return () + Windows -> -- Stripping triggers a bug in 'strip.exe' for + -- libraries with lots identically named modules. See + -- #1784. + return() + Linux | arch == I386 -> + -- Versions of 'strip' on 32-bit Linux older than 2.18 are + -- broken. See #2339. + let okVersion = orLaterVersion (mkVersion [2,18]) + in case programVersion =<< lookupProgram stripProgram progdb of + Just v | withinRange v okVersion -> + runStrip verbosity progdb path args + _ -> warn verbosity $ "Unable to strip library '" + ++ (takeBaseName path) + ++ "' (version of 'strip' too old; " + ++ "requires >= 2.18 on 32-bit Linux)" + _ -> runStrip verbosity progdb path args + where + args = ["--strip-unneeded"] diff --git a/cabal/Cabal/src/Distribution/Simple/Program/Types.hs b/cabal/Cabal/src/Distribution/Simple/Program/Types.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/Program/Types.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DeriveDataTypeable #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program.Types +-- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This provides an abstraction which deals with configuring and running +-- programs. A 'Program' is a static notion of a known program. A +-- 'ConfiguredProgram' is a 'Program' that has been found on the current +-- machine and is ready to be run (possibly with some user-supplied default +-- args). Configuring a program involves finding its location and if necessary +-- finding its version. There's reasonable default behavior for trying to find +-- \"foo\" in PATH, being able to override its location, etc. +-- +module Distribution.Simple.Program.Types ( + -- * Program and functions for constructing them + Program(..), + ProgramSearchPath, + ProgramSearchPathEntry(..), + simpleProgram, + + -- * Configured program and related functions + ConfiguredProgram(..), + programPath, + suppressOverrideArgs, + ProgArg, + ProgramLocation(..), + simpleConfiguredProgram, + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.PackageDescription +import Distribution.Simple.Program.Find +import Distribution.Version +import Distribution.Verbosity + +import qualified Data.Map as Map + +-- | Represents a program which can be configured. +-- +-- Note: rather than constructing this directly, start with 'simpleProgram' and +-- override any extra fields. +-- +data Program = Program { + -- | The simple name of the program, eg. ghc + programName :: String, + + -- | A function to search for the program if its location was not + -- specified by the user. Usually this will just be a call to + -- 'findProgramOnSearchPath'. + -- + -- It is supplied with the prevailing search path which will typically + -- just be used as-is, but can be extended or ignored as needed. + -- + -- For the purpose of change monitoring, in addition to the location + -- where the program was found, it returns all the other places that + -- were tried. + -- + programFindLocation :: Verbosity -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])), + + -- | Try to find the version of the program. For many programs this is + -- not possible or is not necessary so it's OK to return Nothing. + programFindVersion :: Verbosity -> FilePath -> IO (Maybe Version), + + -- | A function to do any additional configuration after we have + -- located the program (and perhaps identified its version). For example + -- it could add args, or environment vars. + programPostConf :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram, + -- | A function that filters any arguments that don't impact the output + -- from a commandline. Used to limit the volatility of dependency hashes + -- when using new-build. + programNormaliseArgs :: Maybe Version -> PackageDescription -> [String] -> [String] + } +instance Show Program where + show (Program name _ _ _ _) = "Program: " ++ name + +type ProgArg = String + +-- | Represents a program which has been configured and is thus ready to be run. +-- +-- These are usually made by configuring a 'Program', but if you have to +-- construct one directly then start with 'simpleConfiguredProgram' and +-- override any extra fields. +-- +data ConfiguredProgram = ConfiguredProgram { + -- | Just the name again + programId :: String, + + -- | The version of this program, if it is known. + programVersion :: Maybe Version, + + -- | Default command-line args for this program. + -- These flags will appear first on the command line, so they can be + -- overridden by subsequent flags. + programDefaultArgs :: [String], + + -- | Override command-line args for this program. + -- These flags will appear last on the command line, so they override + -- all earlier flags. + programOverrideArgs :: [String], + + -- | Override environment variables for this program. + -- These env vars will extend\/override the prevailing environment of + -- the current to form the environment for the new process. + programOverrideEnv :: [(String, Maybe String)], + + -- | A key-value map listing various properties of the program, useful + -- for feature detection. Populated during the configuration step, key + -- names depend on the specific program. + programProperties :: Map.Map String String, + + -- | Location of the program. eg. @\/usr\/bin\/ghc-6.4@ + programLocation :: ProgramLocation, + + -- | In addition to the 'programLocation' where the program was found, + -- these are additional locations that were looked at. The combination + -- of ths found location and these not-found locations can be used to + -- monitor to detect when the re-configuring the program might give a + -- different result (e.g. found in a different location). + -- + programMonitorFiles :: [FilePath] + } + deriving (Eq, Generic, Read, Show, Typeable) + +instance Binary ConfiguredProgram +instance Structured ConfiguredProgram + +-- | Where a program was found. Also tells us whether it's specified by user or +-- not. This includes not just the path, but the program as well. +data ProgramLocation + = UserSpecified { locationPath :: FilePath } + -- ^The user gave the path to this program, + -- eg. --ghc-path=\/usr\/bin\/ghc-6.6 + | FoundOnSystem { locationPath :: FilePath } + -- ^The program was found automatically. + deriving (Eq, Generic, Read, Show, Typeable) + +instance Binary ProgramLocation +instance Structured ProgramLocation + +-- | The full path of a configured program. +programPath :: ConfiguredProgram -> FilePath +programPath = locationPath . programLocation + +-- | Suppress any extra arguments added by the user. +suppressOverrideArgs :: ConfiguredProgram -> ConfiguredProgram +suppressOverrideArgs prog = prog { programOverrideArgs = [] } + +-- | Make a simple named program. +-- +-- By default we'll just search for it in the path and not try to find the +-- version name. You can override these behaviours if necessary, eg: +-- +-- > (simpleProgram "foo") { programFindLocation = ... , programFindVersion ... } +-- +simpleProgram :: String -> Program +simpleProgram name = Program { + programName = name, + programFindLocation = \v p -> findProgramOnSearchPath v p name, + programFindVersion = \_ _ -> return Nothing, + programPostConf = \_ p -> return p, + programNormaliseArgs = \_ _ -> id + } + +-- | Make a simple 'ConfiguredProgram'. +-- +-- > simpleConfiguredProgram "foo" (FoundOnSystem path) +-- +simpleConfiguredProgram :: String -> ProgramLocation -> ConfiguredProgram +simpleConfiguredProgram name loc = ConfiguredProgram { + programId = name, + programVersion = Nothing, + programDefaultArgs = [], + programOverrideArgs = [], + programOverrideEnv = [], + programProperties = Map.empty, + programLocation = loc, + programMonitorFiles = [] -- did not look in any other locations + } diff --git a/cabal/Cabal/src/Distribution/Simple/Register.hs b/cabal/Cabal/src/Distribution/Simple/Register.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/Register.hs @@ -0,0 +1,607 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Register +-- Copyright : Isaac Jones 2003-2004 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module deals with registering and unregistering packages. There are a +-- couple ways it can do this, one is to do it directly. Another is to generate +-- a script that can be run later to do it. The idea here being that the user +-- is shielded from the details of what command to use for package registration +-- for a particular compiler. In practice this aspect was not especially +-- popular so we also provide a way to simply generate the package registration +-- file which then must be manually passed to @ghc-pkg@. It is possible to +-- generate registration information for where the package is to be installed, +-- or alternatively to register the package in place in the build tree. The +-- latter is occasionally handy, and will become more important when we try to +-- build multi-package systems. +-- +-- This module does not delegate anything to the per-compiler modules but just +-- mixes it all in this module, which is rather unsatisfactory. The script +-- generation and the unregister feature are not well used or tested. + +module Distribution.Simple.Register ( + register, + unregister, + + internalPackageDBPath, + + initPackageDB, + doesPackageDBExist, + createPackageDB, + deletePackageDB, + + abiHash, + invokeHcPkg, + registerPackage, + HcPkg.RegisterOptions(..), + HcPkg.defaultRegisterOptions, + generateRegistrationInfo, + inplaceInstalledPackageInfo, + absoluteInstalledPackageInfo, + generalInstalledPackageInfo, + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Types.TargetInfo +import Distribution.Types.LocalBuildInfo +import Distribution.Types.ComponentLocalBuildInfo + +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.BuildPaths +import Distribution.Simple.BuildTarget + +import qualified Distribution.Simple.GHC as GHC +import qualified Distribution.Simple.GHCJS as GHCJS +import qualified Distribution.Simple.UHC as UHC +import qualified Distribution.Simple.HaskellSuite as HaskellSuite +import qualified Distribution.Simple.PackageIndex as Index + +import Distribution.Backpack.DescribeUnitId +import Distribution.Simple.Compiler +import Distribution.Simple.Program +import Distribution.Simple.Program.Script +import qualified Distribution.Simple.Program.HcPkg as HcPkg +import Distribution.Simple.Setup +import Distribution.PackageDescription +import Distribution.Package +import Distribution.License (licenseToSPDX, licenseFromSPDX) +import qualified Distribution.InstalledPackageInfo as IPI +import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import Distribution.Simple.Utils +import Distribution.Utils.MapAccum +import Distribution.System +import Distribution.Pretty +import Distribution.Verbosity as Verbosity +import Distribution.Version +import Distribution.Compat.Graph (IsNode(nodeKey)) + +import System.FilePath ((), (<.>), isAbsolute) +import System.Directory + +import qualified Data.ByteString.Lazy.Char8 as BS.Char8 + +-- ----------------------------------------------------------------------------- +-- Registration + +register :: PackageDescription -> LocalBuildInfo + -> RegisterFlags -- ^Install in the user's database?; verbose + -> IO () +register pkg_descr lbi0 flags = + -- Duncan originally asked for us to not register/install files + -- when there was no public library. But with per-component + -- configure, we legitimately need to install internal libraries + -- so that we can get them. So just unconditionally install. + doRegister + where + doRegister = do + targets <- readTargetInfos verbosity pkg_descr lbi0 (regArgs flags) + + -- It's important to register in build order, because ghc-pkg + -- will complain if a dependency is not registered. + let componentsToRegister + = neededTargetsInBuildOrder' pkg_descr lbi0 (map nodeKey targets) + + (_, ipi_mbs) <- + mapAccumM `flip` installedPkgs lbi0 `flip` componentsToRegister $ \index tgt -> + case targetComponent tgt of + CLib lib -> do + let clbi = targetCLBI tgt + lbi = lbi0 { installedPkgs = index } + ipi <- generateOne pkg_descr lib lbi clbi flags + return (Index.insert ipi index, Just ipi) + _ -> return (index, Nothing) + + registerAll pkg_descr lbi0 flags (catMaybes ipi_mbs) + where + verbosity = fromFlag (regVerbosity flags) + +generateOne :: PackageDescription -> Library -> LocalBuildInfo -> ComponentLocalBuildInfo + -> RegisterFlags + -> IO InstalledPackageInfo +generateOne pkg lib lbi clbi regFlags + = do + absPackageDBs <- absolutePackageDBPaths packageDbs + installedPkgInfo <- generateRegistrationInfo + verbosity pkg lib lbi clbi inplace reloc distPref + (registrationPackageDB absPackageDBs) + info verbosity (IPI.showInstalledPackageInfo installedPkgInfo) + return installedPkgInfo + where + inplace = fromFlag (regInPlace regFlags) + reloc = relocatable lbi + -- FIXME: there's really no guarantee this will work. + -- registering into a totally different db stack can + -- fail if dependencies cannot be satisfied. + packageDbs = nub $ withPackageDB lbi + ++ maybeToList (flagToMaybe (regPackageDB regFlags)) + distPref = fromFlag (regDistPref regFlags) + verbosity = fromFlag (regVerbosity regFlags) + +registerAll :: PackageDescription -> LocalBuildInfo -> RegisterFlags + -> [InstalledPackageInfo] + -> IO () +registerAll pkg lbi regFlags ipis + = do + when (fromFlag (regPrintId regFlags)) $ do + for_ ipis $ \installedPkgInfo -> + -- Only print the public library's IPI + when (packageId installedPkgInfo == packageId pkg + && IPI.sourceLibName installedPkgInfo == LMainLibName) $ + putStrLn (prettyShow (IPI.installedUnitId installedPkgInfo)) + + -- Three different modes: + case () of + _ | modeGenerateRegFile -> writeRegistrationFileOrDirectory + | modeGenerateRegScript -> writeRegisterScript + | otherwise -> do + for_ ipis $ \ipi -> do + setupMessage' verbosity "Registering" (packageId pkg) + (CLibName (IPI.sourceLibName ipi)) + (Just (IPI.instantiatedWith ipi)) + registerPackage verbosity (compiler lbi) (withPrograms lbi) + packageDbs ipi HcPkg.defaultRegisterOptions + + where + modeGenerateRegFile = isJust (flagToMaybe (regGenPkgConf regFlags)) + regFile = fromMaybe (prettyShow (packageId pkg) <.> "conf") + (fromFlag (regGenPkgConf regFlags)) + + modeGenerateRegScript = fromFlag (regGenScript regFlags) + + -- FIXME: there's really no guarantee this will work. + -- registering into a totally different db stack can + -- fail if dependencies cannot be satisfied. + packageDbs = nub $ withPackageDB lbi + ++ maybeToList (flagToMaybe (regPackageDB regFlags)) + verbosity = fromFlag (regVerbosity regFlags) + + writeRegistrationFileOrDirectory = do + -- Handles overwriting both directory and file + deletePackageDB regFile + case ipis of + [installedPkgInfo] -> do + info verbosity ("Creating package registration file: " ++ regFile) + writeUTF8File regFile (IPI.showInstalledPackageInfo installedPkgInfo) + _ -> do + info verbosity ("Creating package registration directory: " ++ regFile) + createDirectory regFile + let num_ipis = length ipis + lpad m xs = replicate (m - length ys) '0' ++ ys + where ys = take m xs + number i = lpad (length (show num_ipis)) (show i) + for_ (zip ([1..] :: [Int]) ipis) $ \(i, installedPkgInfo) -> + writeUTF8File (regFile (number i ++ "-" ++ prettyShow (IPI.installedUnitId installedPkgInfo))) + (IPI.showInstalledPackageInfo installedPkgInfo) + + writeRegisterScript = + case compilerFlavor (compiler lbi) of + UHC -> notice verbosity "Registration scripts not needed for uhc" + _ -> withHcPkg verbosity + "Registration scripts are not implemented for this compiler" + (compiler lbi) (withPrograms lbi) + (writeHcPkgRegisterScript verbosity ipis packageDbs) + + +generateRegistrationInfo :: Verbosity + -> PackageDescription + -> Library + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Bool + -> Bool + -> FilePath + -> PackageDB + -> IO InstalledPackageInfo +generateRegistrationInfo verbosity pkg lib lbi clbi inplace reloc distPref packageDb = do + --TODO: eliminate pwd! + pwd <- getCurrentDirectory + + installedPkgInfo <- + if inplace + -- NB: With an inplace installation, the user may run './Setup + -- build' to update the library files, without reregistering. + -- In this case, it is critical that the ABI hash not flip. + then return (inplaceInstalledPackageInfo pwd distPref + pkg (mkAbiHash "inplace") lib lbi clbi) + else do + abi_hash <- abiHash verbosity pkg distPref lbi lib clbi + if reloc + then relocRegistrationInfo verbosity + pkg lib lbi clbi abi_hash packageDb + else return (absoluteInstalledPackageInfo + pkg abi_hash lib lbi clbi) + + + return installedPkgInfo + +-- | Compute the 'AbiHash' of a library that we built inplace. +abiHash :: Verbosity + -> PackageDescription + -> FilePath + -> LocalBuildInfo + -> Library + -> ComponentLocalBuildInfo + -> IO AbiHash +abiHash verbosity pkg distPref lbi lib clbi = + case compilerFlavor comp of + GHC -> do + fmap mkAbiHash $ GHC.libAbiHash verbosity pkg lbi' lib clbi + GHCJS -> do + fmap mkAbiHash $ GHCJS.libAbiHash verbosity pkg lbi' lib clbi + _ -> return (mkAbiHash "") + where + comp = compiler lbi + lbi' = lbi { + withPackageDB = withPackageDB lbi + ++ [SpecificPackageDB (internalPackageDBPath lbi distPref)] + } + +relocRegistrationInfo :: Verbosity + -> PackageDescription + -> Library + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> AbiHash + -> PackageDB + -> IO InstalledPackageInfo +relocRegistrationInfo verbosity pkg lib lbi clbi abi_hash packageDb = + case (compilerFlavor (compiler lbi)) of + GHC -> do fs <- GHC.pkgRoot verbosity lbi packageDb + return (relocatableInstalledPackageInfo + pkg abi_hash lib lbi clbi fs) + _ -> die' verbosity + "Distribution.Simple.Register.relocRegistrationInfo: \ + \not implemented for this compiler" + +initPackageDB :: Verbosity -> Compiler -> ProgramDb -> FilePath -> IO () +initPackageDB verbosity comp progdb dbPath = + createPackageDB verbosity comp progdb False dbPath + +-- | Create an empty package DB at the specified location. +createPackageDB :: Verbosity -> Compiler -> ProgramDb -> Bool + -> FilePath -> IO () +createPackageDB verbosity comp progdb preferCompat dbPath = + case compilerFlavor comp of + GHC -> HcPkg.init (GHC.hcPkgInfo progdb) verbosity preferCompat dbPath + GHCJS -> HcPkg.init (GHCJS.hcPkgInfo progdb) verbosity False dbPath + UHC -> return () + HaskellSuite _ -> HaskellSuite.initPackageDB verbosity progdb dbPath + _ -> die' verbosity $ + "Distribution.Simple.Register.createPackageDB: " + ++ "not implemented for this compiler" + +doesPackageDBExist :: FilePath -> IO Bool +doesPackageDBExist dbPath = do + -- currently one impl for all compiler flavours, but could change if needed + dir_exists <- doesDirectoryExist dbPath + if dir_exists + then return True + else doesFileExist dbPath + +deletePackageDB :: FilePath -> IO () +deletePackageDB dbPath = do + -- currently one impl for all compiler flavours, but could change if needed + dir_exists <- doesDirectoryExist dbPath + if dir_exists + then removeDirectoryRecursive dbPath + else do file_exists <- doesFileExist dbPath + when file_exists $ removeFile dbPath + +-- | Run @hc-pkg@ using a given package DB stack, directly forwarding the +-- provided command-line arguments to it. +invokeHcPkg :: Verbosity -> Compiler -> ProgramDb -> PackageDBStack + -> [String] -> IO () +invokeHcPkg verbosity comp progdb dbStack extraArgs = + withHcPkg verbosity "invokeHcPkg" comp progdb + (\hpi -> HcPkg.invoke hpi verbosity dbStack extraArgs) + +withHcPkg :: Verbosity -> String -> Compiler -> ProgramDb + -> (HcPkg.HcPkgInfo -> IO a) -> IO a +withHcPkg verbosity name comp progdb f = + case compilerFlavor comp of + GHC -> f (GHC.hcPkgInfo progdb) + GHCJS -> f (GHCJS.hcPkgInfo progdb) + _ -> die' verbosity ("Distribution.Simple.Register." ++ name ++ ":\ + \not implemented for this compiler") + +registerPackage :: Verbosity + -> Compiler + -> ProgramDb + -> PackageDBStack + -> InstalledPackageInfo + -> HcPkg.RegisterOptions + -> IO () +registerPackage verbosity comp progdb packageDbs installedPkgInfo registerOptions = + case compilerFlavor comp of + GHC -> GHC.registerPackage verbosity progdb packageDbs installedPkgInfo registerOptions + GHCJS -> GHCJS.registerPackage verbosity progdb packageDbs installedPkgInfo registerOptions + HaskellSuite {} -> + HaskellSuite.registerPackage verbosity progdb packageDbs installedPkgInfo + _ | HcPkg.registerMultiInstance registerOptions + -> die' verbosity "Registering multiple package instances is not yet supported for this compiler" + UHC -> UHC.registerPackage verbosity comp progdb packageDbs installedPkgInfo + _ -> die' verbosity "Registering is not implemented for this compiler" + +writeHcPkgRegisterScript :: Verbosity + -> [InstalledPackageInfo] + -> PackageDBStack + -> HcPkg.HcPkgInfo + -> IO () +writeHcPkgRegisterScript verbosity ipis packageDbs hpi = do + let genScript installedPkgInfo = + let invocation = HcPkg.registerInvocation hpi Verbosity.normal + packageDbs installedPkgInfo + HcPkg.defaultRegisterOptions + in invocationAsSystemScript buildOS invocation + scripts = map genScript ipis + -- TODO: Do something more robust here + regScript = unlines scripts + + info verbosity ("Creating package registration script: " ++ regScriptFileName) + writeUTF8File regScriptFileName regScript + setFileExecutable regScriptFileName + +regScriptFileName :: FilePath +regScriptFileName = case buildOS of + Windows -> "register.bat" + _ -> "register.sh" + + +-- ----------------------------------------------------------------------------- +-- Making the InstalledPackageInfo + +-- | Construct 'InstalledPackageInfo' for a library in a package, given a set +-- of installation directories. +-- +generalInstalledPackageInfo + :: ([FilePath] -> [FilePath]) -- ^ Translate relative include dir paths to + -- absolute paths. + -> PackageDescription + -> AbiHash + -> Library + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> InstallDirs FilePath + -> InstalledPackageInfo +generalInstalledPackageInfo adjustRelIncDirs pkg abi_hash lib lbi clbi installDirs = + IPI.InstalledPackageInfo { + IPI.sourcePackageId = packageId pkg, + IPI.installedUnitId = componentUnitId clbi, + IPI.installedComponentId_ = componentComponentId clbi, + IPI.instantiatedWith = componentInstantiatedWith clbi, + IPI.sourceLibName = libName lib, + IPI.compatPackageKey = componentCompatPackageKey clbi, + -- If GHC >= 8.4 we register with SDPX, otherwise with legacy license + IPI.license = + if ghc84 + then Left $ either id licenseToSPDX $ licenseRaw pkg + else Right $ either licenseFromSPDX id $ licenseRaw pkg, + IPI.copyright = copyright pkg, + IPI.maintainer = maintainer pkg, + IPI.author = author pkg, + IPI.stability = stability pkg, + IPI.homepage = homepage pkg, + IPI.pkgUrl = pkgUrl pkg, + IPI.synopsis = synopsis pkg, + IPI.description = description pkg, + IPI.category = category pkg, + IPI.abiHash = abi_hash, + IPI.indefinite = componentIsIndefinite clbi, + IPI.exposed = libExposed lib, + IPI.exposedModules = componentExposedModules clbi + -- add virtual modules into the list of exposed modules for the + -- package database as well. + ++ map (\name -> IPI.ExposedModule name Nothing) (virtualModules bi), + IPI.hiddenModules = otherModules bi, + IPI.trusted = IPI.trusted IPI.emptyInstalledPackageInfo, + IPI.importDirs = [ libdir installDirs | hasModules ], + IPI.libraryDirs = libdirs, + IPI.libraryDirsStatic = libdirsStatic, + IPI.libraryDynDirs = dynlibdirs, + IPI.dataDir = datadir installDirs, + IPI.hsLibraries = (if hasLibrary + then [getHSLibraryName (componentUnitId clbi)] + else []) ++ extraBundledLibs bi, + IPI.extraLibraries = extraLibs bi, + IPI.extraLibrariesStatic = extraLibsStatic bi, + IPI.extraGHCiLibraries = extraGHCiLibs bi, + IPI.includeDirs = absinc ++ adjustRelIncDirs relinc, + IPI.includes = includes bi, + IPI.depends = depends, + IPI.abiDepends = [], -- due to #5465 + IPI.ccOptions = [], -- Note. NOT ccOptions bi! + -- We don't want cc-options to be propagated + -- to C compilations in other packages. + IPI.cxxOptions = [], -- Also. NOT cxxOptions bi! + IPI.ldOptions = ldOptions bi, + IPI.frameworks = frameworks bi, + IPI.frameworkDirs = extraFrameworkDirs bi, + IPI.haddockInterfaces = [haddockdir installDirs haddockName pkg], + IPI.haddockHTMLs = [htmldir installDirs], + IPI.pkgRoot = Nothing, + IPI.libVisibility = libVisibility lib + } + where + ghc84 = case compilerId $ compiler lbi of + CompilerId GHC v -> v >= mkVersion [8, 4] + _ -> False + + bi = libBuildInfo lib + --TODO: unclear what the root cause of the + -- duplication is, but we nub it here for now: + depends = ordNub $ map fst (componentPackageDeps clbi) + (absinc, relinc) = partition isAbsolute (includeDirs bi) + hasModules = not $ null (allLibModules lib clbi) + comp = compiler lbi + hasLibrary = (hasModules || not (null (cSources bi)) + || not (null (asmSources bi)) + || not (null (cmmSources bi)) + || not (null (cxxSources bi)) + || (not (null (jsSources bi)) && + compilerFlavor comp == GHCJS)) + && not (componentIsIndefinite clbi) + libdirsStatic + | hasLibrary = libdir installDirs : extraLibDirsStaticOrFallback + | otherwise = extraLibDirsStaticOrFallback + where + -- If no static library dirs were given, the package likely makes no + -- distinction between fully static linking and otherwise. + -- Fall back to the normal library dirs in that case. + extraLibDirsStaticOrFallback = case extraLibDirsStatic bi of + [] -> extraLibDirs bi + dirs -> dirs + (libdirs, dynlibdirs) + | not hasLibrary + = (extraLibDirs bi, []) + -- the dynamic-library-dirs defaults to the library-dirs if not specified, + -- so this works whether the dynamic-library-dirs field is supported or not + + | libraryDynDirSupported comp + = (libdir installDirs : extraLibDirs bi, + dynlibdir installDirs : extraLibDirs bi) + + | otherwise + = (libdir installDirs : dynlibdir installDirs : extraLibDirs bi, []) + -- the compiler doesn't understand the dynamic-library-dirs field so we + -- add the dyn directory to the "normal" list in the library-dirs field + +-- | Construct 'InstalledPackageInfo' for a library that is in place in the +-- build tree. +-- +-- This function knows about the layout of in place packages. +-- +inplaceInstalledPackageInfo :: FilePath -- ^ top of the build tree + -> FilePath -- ^ location of the dist tree + -> PackageDescription + -> AbiHash + -> Library + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> InstalledPackageInfo +inplaceInstalledPackageInfo inplaceDir distPref pkg abi_hash lib lbi clbi = + generalInstalledPackageInfo adjustRelativeIncludeDirs + pkg abi_hash lib lbi clbi installDirs + where + adjustRelativeIncludeDirs = concatMap $ \d -> + [ inplaceDir d -- local include-dir + , inplaceDir libTargetDir d -- autogen include-dir + ] + libTargetDir = componentBuildDir lbi clbi + installDirs = + (absoluteComponentInstallDirs pkg lbi (componentUnitId clbi) NoCopyDest) { + libdir = inplaceDir libTargetDir, + dynlibdir = inplaceDir libTargetDir, + datadir = inplaceDir dataDir pkg, + docdir = inplaceDocdir, + htmldir = inplaceHtmldir, + haddockdir = inplaceHtmldir + } + inplaceDocdir = inplaceDir distPref "doc" + inplaceHtmldir = inplaceDocdir "html" prettyShow (packageName pkg) + + +-- | Construct 'InstalledPackageInfo' for the final install location of a +-- library package. +-- +-- This function knows about the layout of installed packages. +-- +absoluteInstalledPackageInfo :: PackageDescription + -> AbiHash + -> Library + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> InstalledPackageInfo +absoluteInstalledPackageInfo pkg abi_hash lib lbi clbi = + generalInstalledPackageInfo adjustReativeIncludeDirs + pkg abi_hash lib lbi clbi installDirs + where + -- For installed packages we install all include files into one dir, + -- whereas in the build tree they may live in multiple local dirs. + adjustReativeIncludeDirs _ + | null (installIncludes bi) = [] + | otherwise = [includedir installDirs] + bi = libBuildInfo lib + installDirs = absoluteComponentInstallDirs pkg lbi (componentUnitId clbi) NoCopyDest + + +relocatableInstalledPackageInfo :: PackageDescription + -> AbiHash + -> Library + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> FilePath + -> InstalledPackageInfo +relocatableInstalledPackageInfo pkg abi_hash lib lbi clbi pkgroot = + generalInstalledPackageInfo adjustReativeIncludeDirs + pkg abi_hash lib lbi clbi installDirs + where + -- For installed packages we install all include files into one dir, + -- whereas in the build tree they may live in multiple local dirs. + adjustReativeIncludeDirs _ + | null (installIncludes bi) = [] + | otherwise = [includedir installDirs] + bi = libBuildInfo lib + + installDirs = fmap (("${pkgroot}" ) . shortRelativePath pkgroot) + $ absoluteComponentInstallDirs pkg lbi (componentUnitId clbi) NoCopyDest + +-- ----------------------------------------------------------------------------- +-- Unregistration + +unregister :: PackageDescription -> LocalBuildInfo -> RegisterFlags -> IO () +unregister pkg lbi regFlags = do + let pkgid = packageId pkg + genScript = fromFlag (regGenScript regFlags) + verbosity = fromFlag (regVerbosity regFlags) + packageDb = fromFlagOrDefault (registrationPackageDB (withPackageDB lbi)) + (regPackageDB regFlags) + unreg hpi = + let invocation = HcPkg.unregisterInvocation + hpi Verbosity.normal packageDb pkgid + in if genScript + then writeFileAtomic unregScriptFileName + (BS.Char8.pack $ invocationAsSystemScript buildOS invocation) + else runProgramInvocation verbosity invocation + setupMessage verbosity "Unregistering" pkgid + withHcPkg verbosity "unregistering is only implemented for GHC and GHCJS" + (compiler lbi) (withPrograms lbi) unreg + +unregScriptFileName :: FilePath +unregScriptFileName = case buildOS of + Windows -> "unregister.bat" + _ -> "unregister.sh" + +internalPackageDBPath :: LocalBuildInfo -> FilePath -> FilePath +internalPackageDBPath lbi distPref = + case compilerFlavor (compiler lbi) of + UHC -> UHC.inplacePackageDbPath lbi + _ -> distPref "package.conf.inplace" diff --git a/cabal/Cabal/src/Distribution/Simple/Setup.hs b/cabal/Cabal/src/Distribution/Simple/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/Setup.hs @@ -0,0 +1,2338 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE NoMonoLocalBinds #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Setup +-- Copyright : Isaac Jones 2003-2004 +-- Duncan Coutts 2007 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is a big module, but not very complicated. The code is very regular +-- and repetitive. It defines the command line interface for all the Cabal +-- commands. For each command (like @configure@, @build@ etc) it defines a type +-- that holds all the flags, the default set of flags and a 'CommandUI' that +-- maps command line flags to and from the corresponding flags type. +-- +-- All the flags types are instances of 'Monoid', see +-- +-- for an explanation. +-- +-- The types defined here get used in the front end and especially in +-- @cabal-install@ which has to do quite a bit of manipulating sets of command +-- line flags. +-- +-- This is actually relatively nice, it works quite well. The main change it +-- needs is to unify it with the code for managing sets of fields that can be +-- read and written from files. This would allow us to save configure flags in +-- config files. + +module Distribution.Simple.Setup ( + + GlobalFlags(..), emptyGlobalFlags, defaultGlobalFlags, globalCommand, + ConfigFlags(..), emptyConfigFlags, defaultConfigFlags, configureCommand, + configPrograms, + configAbsolutePaths, readPackageDb, readPackageDbList, showPackageDb, showPackageDbList, + CopyFlags(..), emptyCopyFlags, defaultCopyFlags, copyCommand, + InstallFlags(..), emptyInstallFlags, defaultInstallFlags, installCommand, + HaddockTarget(..), + HaddockFlags(..), emptyHaddockFlags, defaultHaddockFlags, haddockCommand, + HscolourFlags(..), emptyHscolourFlags, defaultHscolourFlags, hscolourCommand, + BuildFlags(..), emptyBuildFlags, defaultBuildFlags, buildCommand, + DumpBuildInfo(..), + ReplFlags(..), defaultReplFlags, replCommand, + ReplOptions(..), + CleanFlags(..), emptyCleanFlags, defaultCleanFlags, cleanCommand, + RegisterFlags(..), emptyRegisterFlags, defaultRegisterFlags, registerCommand, + unregisterCommand, + SDistFlags(..), emptySDistFlags, defaultSDistFlags, sdistCommand, + TestFlags(..), emptyTestFlags, defaultTestFlags, testCommand, + TestShowDetails(..), + BenchmarkFlags(..), emptyBenchmarkFlags, + defaultBenchmarkFlags, benchmarkCommand, + CopyDest(..), + configureArgs, configureOptions, configureCCompiler, configureLinker, + buildOptions, haddockOptions, installDirsOptions, + testOptions', benchmarkOptions', + programDbOptions, programDbPaths', + programFlagsDescription, + replOptions, + splitArgs, + + defaultDistPref, optionDistPref, + + Flag(..), + toFlag, + fromFlag, + fromFlagOrDefault, + flagToMaybe, + flagToList, + maybeToFlag, + BooleanFlag(..), + boolOpt, boolOpt', trueArg, falseArg, + optionVerbosity, optionNumJobs) where + +import Prelude () +import Distribution.Compat.Prelude hiding (get) + +import Distribution.Compiler +import Distribution.ReadE +import Distribution.Parsec +import Distribution.Pretty +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as Disp +import Distribution.ModuleName +import Distribution.PackageDescription +import Distribution.Simple.Command hiding (boolOpt, boolOpt') +import qualified Distribution.Simple.Command as Command +import Distribution.Simple.Compiler +import Distribution.Simple.Flag +import Distribution.Simple.Utils +import Distribution.Simple.Program +import Distribution.Simple.InstallDirs +import Distribution.Verbosity +import Distribution.Utils.NubList +import Distribution.Types.ComponentId +import Distribution.Types.DumpBuildInfo +import Distribution.Types.GivenComponent +import Distribution.Types.Module +import Distribution.Types.PackageVersionConstraint + +import Distribution.Compat.Stack +import Distribution.Compat.Semigroup (Last' (..), Option' (..)) + +-- FIXME Not sure where this should live +defaultDistPref :: FilePath +defaultDistPref = "dist" + +-- ------------------------------------------------------------ +-- * Global flags +-- ------------------------------------------------------------ + +-- In fact since individual flags types are monoids and these are just sets of +-- flags then they are also monoids pointwise. This turns out to be really +-- useful. The mempty is the set of empty flags and mappend allows us to +-- override specific flags. For example we can start with default flags and +-- override with the ones we get from a file or the command line, or both. + +-- | Flags that apply at the top level, not to any sub-command. +data GlobalFlags = GlobalFlags { + globalVersion :: Flag Bool, + globalNumericVersion :: Flag Bool + } deriving (Generic, Typeable) + +defaultGlobalFlags :: GlobalFlags +defaultGlobalFlags = GlobalFlags { + globalVersion = Flag False, + globalNumericVersion = Flag False + } + +globalCommand :: [Command action] -> CommandUI GlobalFlags +globalCommand commands = CommandUI + { commandName = "" + , commandSynopsis = "" + , commandUsage = \pname -> + "This Setup program uses the Haskell Cabal Infrastructure.\n" + ++ "See http://www.haskell.org/cabal/ for more information.\n" + ++ "\n" + ++ "Usage: " ++ pname ++ " [GLOBAL FLAGS] [COMMAND [FLAGS]]\n" + , commandDescription = Just $ \pname -> + let + commands' = commands ++ [commandAddAction helpCommandUI undefined] + cmdDescs = getNormalCommandDescriptions commands' + maxlen = maximum $ [length name | (name, _) <- cmdDescs] + align str = str ++ replicate (maxlen - length str) ' ' + in + "Commands:\n" + ++ unlines [ " " ++ align name ++ " " ++ descr + | (name, descr) <- cmdDescs ] + ++ "\n" + ++ "For more information about a command use\n" + ++ " " ++ pname ++ " COMMAND --help\n\n" + ++ "Typical steps for installing Cabal packages:\n" + ++ concat [ " " ++ pname ++ " " ++ x ++ "\n" + | x <- ["configure", "build", "install"]] + , commandNotes = Nothing + , commandDefaultFlags = defaultGlobalFlags + , commandOptions = \_ -> + [option ['V'] ["version"] + "Print version information" + globalVersion (\v flags -> flags { globalVersion = v }) + trueArg + ,option [] ["numeric-version"] + "Print just the version number" + globalNumericVersion (\v flags -> flags { globalNumericVersion = v }) + trueArg + ] + } + +emptyGlobalFlags :: GlobalFlags +emptyGlobalFlags = mempty + +instance Monoid GlobalFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup GlobalFlags where + (<>) = gmappend + +-- ------------------------------------------------------------ +-- * Config flags +-- ------------------------------------------------------------ + +-- | Flags to @configure@ command. +-- +-- IMPORTANT: every time a new flag is added, 'D.C.Setup.filterConfigureFlags' +-- should be updated. +-- IMPORTANT: every time a new flag is added, it should be added to the Eq instance +data ConfigFlags = ConfigFlags { + -- This is the same hack as in 'buildArgs' and 'copyArgs'. + -- TODO: Stop using this eventually when 'UserHooks' gets changed + configArgs :: [String], + + --FIXME: the configPrograms is only here to pass info through to configure + -- because the type of configure is constrained by the UserHooks. + -- when we change UserHooks next we should pass the initial + -- ProgramDb directly and not via ConfigFlags + configPrograms_ :: Option' (Last' ProgramDb), -- ^All programs that + -- @cabal@ may run + configProgramPaths :: [(String, FilePath)], -- ^user specified programs paths + configProgramArgs :: [(String, [String])], -- ^user specified programs args + configProgramPathExtra :: NubList FilePath, -- ^Extend the $PATH + configHcFlavor :: Flag CompilerFlavor, -- ^The \"flavor\" of the + -- compiler, e.g. GHC. + configHcPath :: Flag FilePath, -- ^given compiler location + configHcPkg :: Flag FilePath, -- ^given hc-pkg location + configVanillaLib :: Flag Bool, -- ^Enable vanilla library + configProfLib :: Flag Bool, -- ^Enable profiling in the library + configSharedLib :: Flag Bool, -- ^Build shared library + configStaticLib :: Flag Bool, -- ^Build static library + configDynExe :: Flag Bool, -- ^Enable dynamic linking of the + -- executables. + configFullyStaticExe :: Flag Bool, -- ^Enable fully static linking of the + -- executables. + configProfExe :: Flag Bool, -- ^Enable profiling in the + -- executables. + configProf :: Flag Bool, -- ^Enable profiling in the library + -- and executables. + configProfDetail :: Flag ProfDetailLevel, -- ^Profiling detail level + -- in the library and executables. + configProfLibDetail :: Flag ProfDetailLevel, -- ^Profiling detail level + -- in the library + configConfigureArgs :: [String], -- ^Extra arguments to @configure@ + configOptimization :: Flag OptimisationLevel, -- ^Enable optimization. + configProgPrefix :: Flag PathTemplate, -- ^Installed executable prefix. + configProgSuffix :: Flag PathTemplate, -- ^Installed executable suffix. + configInstallDirs :: InstallDirs (Flag PathTemplate), -- ^Installation + -- paths + configScratchDir :: Flag FilePath, + configExtraLibDirs :: [FilePath], -- ^ path to search for extra libraries + configExtraLibDirsStatic :: [FilePath], -- ^ path to search for extra + -- libraries when linking + -- fully static executables + configExtraFrameworkDirs :: [FilePath], -- ^ path to search for extra + -- frameworks (OS X only) + configExtraIncludeDirs :: [FilePath], -- ^ path to search for header files + configIPID :: Flag String, -- ^ explicit IPID to be used + configCID :: Flag ComponentId, -- ^ explicit CID to be used + configDeterministic :: Flag Bool, -- ^ be as deterministic as possible + -- (e.g., invariant over GHC, database, + -- etc). Used by the test suite + + configDistPref :: Flag FilePath, -- ^"dist" prefix + configCabalFilePath :: Flag FilePath, -- ^ Cabal file to use + configVerbosity :: Flag Verbosity, -- ^verbosity level + configUserInstall :: Flag Bool, -- ^The --user\/--global flag + configPackageDBs :: [Maybe PackageDB], -- ^Which package DBs to use + configGHCiLib :: Flag Bool, -- ^Enable compiling library for GHCi + configSplitSections :: Flag Bool, -- ^Enable -split-sections with GHC + configSplitObjs :: Flag Bool, -- ^Enable -split-objs with GHC + configStripExes :: Flag Bool, -- ^Enable executable stripping + configStripLibs :: Flag Bool, -- ^Enable library stripping + configConstraints :: [PackageVersionConstraint], -- ^Additional constraints for + -- dependencies. + configDependencies :: [GivenComponent], + -- ^The packages depended on. + configInstantiateWith :: [(ModuleName, Module)], + -- ^ The requested Backpack instantiation. If empty, either this + -- package does not use Backpack, or we just want to typecheck + -- the indefinite package. + configConfigurationsFlags :: FlagAssignment, + configTests :: Flag Bool, -- ^Enable test suite compilation + configBenchmarks :: Flag Bool, -- ^Enable benchmark compilation + configCoverage :: Flag Bool, -- ^Enable program coverage + configLibCoverage :: Flag Bool, -- ^Enable program coverage (deprecated) + configExactConfiguration :: Flag Bool, + -- ^All direct dependencies and flags are provided on the command line by + -- the user via the '--dependency' and '--flags' options. + configFlagError :: Flag String, + -- ^Halt and show an error message indicating an error in flag assignment + configRelocatable :: Flag Bool, -- ^ Enable relocatable package built + configDebugInfo :: Flag DebugInfoLevel, -- ^ Emit debug info. + configDumpBuildInfo :: Flag DumpBuildInfo, + -- ^ Should we dump available build information on build? + -- Dump build information to disk before attempting to build, + -- tooling can parse these files and use them to compile the + -- source files themselves. + configUseResponseFiles :: Flag Bool, + -- ^ Whether to use response files at all. They're used for such tools + -- as haddock, or ld. + configAllowDependingOnPrivateLibs :: Flag Bool + -- ^ Allow depending on private sublibraries. This is used by external + -- tools (like cabal-install) so they can add multiple-public-libraries + -- compatibility to older ghcs by checking visibility externally. + } + deriving (Generic, Read, Show, Typeable) + +instance Binary ConfigFlags +instance Structured ConfigFlags + +-- | More convenient version of 'configPrograms'. Results in an +-- 'error' if internal invariant is violated. +configPrograms :: WithCallStack (ConfigFlags -> ProgramDb) +configPrograms = fromMaybe (error "FIXME: remove configPrograms") . fmap getLast' + . getOption' . configPrograms_ + +instance Eq ConfigFlags where + (==) a b = + -- configPrograms skipped: not user specified, has no Eq instance + equal configProgramPaths + && equal configProgramArgs + && equal configProgramPathExtra + && equal configHcFlavor + && equal configHcPath + && equal configHcPkg + && equal configVanillaLib + && equal configProfLib + && equal configSharedLib + && equal configStaticLib + && equal configDynExe + && equal configFullyStaticExe + && equal configProfExe + && equal configProf + && equal configProfDetail + && equal configProfLibDetail + && equal configConfigureArgs + && equal configOptimization + && equal configProgPrefix + && equal configProgSuffix + && equal configInstallDirs + && equal configScratchDir + && equal configExtraLibDirs + && equal configExtraLibDirsStatic + && equal configExtraIncludeDirs + && equal configIPID + && equal configDeterministic + && equal configDistPref + && equal configVerbosity + && equal configUserInstall + && equal configPackageDBs + && equal configGHCiLib + && equal configSplitSections + && equal configSplitObjs + && equal configStripExes + && equal configStripLibs + && equal configConstraints + && equal configDependencies + && equal configConfigurationsFlags + && equal configTests + && equal configBenchmarks + && equal configCoverage + && equal configLibCoverage + && equal configExactConfiguration + && equal configFlagError + && equal configRelocatable + && equal configDebugInfo + && equal configDumpBuildInfo + && equal configUseResponseFiles + where + equal f = on (==) f a b + +configAbsolutePaths :: ConfigFlags -> IO ConfigFlags +configAbsolutePaths f = + (\v -> f { configPackageDBs = v }) + `liftM` traverse (maybe (return Nothing) (liftM Just . absolutePackageDBPath)) + (configPackageDBs f) + +defaultConfigFlags :: ProgramDb -> ConfigFlags +defaultConfigFlags progDb = emptyConfigFlags { + configArgs = [], + configPrograms_ = Option' (Just (Last' progDb)), + configHcFlavor = maybe NoFlag Flag defaultCompilerFlavor, + configVanillaLib = Flag True, + configProfLib = NoFlag, + configSharedLib = NoFlag, + configStaticLib = NoFlag, + configDynExe = Flag False, + configFullyStaticExe = Flag False, + configProfExe = NoFlag, + configProf = NoFlag, + configProfDetail = NoFlag, + configProfLibDetail= NoFlag, + configOptimization = Flag NormalOptimisation, + configProgPrefix = Flag (toPathTemplate ""), + configProgSuffix = Flag (toPathTemplate ""), + configDistPref = NoFlag, + configCabalFilePath = NoFlag, + configVerbosity = Flag normal, + configUserInstall = Flag False, --TODO: reverse this +#if defined(mingw32_HOST_OS) + -- See #8062 and GHC #21019. + configGHCiLib = Flag False, +#else + configGHCiLib = NoFlag, +#endif + configSplitSections = Flag False, + configSplitObjs = Flag False, -- takes longer, so turn off by default + configStripExes = NoFlag, + configStripLibs = NoFlag, + configTests = Flag False, + configBenchmarks = Flag False, + configCoverage = Flag False, + configLibCoverage = NoFlag, + configExactConfiguration = Flag False, + configFlagError = NoFlag, + configRelocatable = Flag False, + configDebugInfo = Flag NoDebugInfo, + configDumpBuildInfo = NoFlag, + configUseResponseFiles = NoFlag + } + +configureCommand :: ProgramDb -> CommandUI ConfigFlags +configureCommand progDb = CommandUI + { commandName = "configure" + , commandSynopsis = "Prepare to build the package." + , commandDescription = Just $ \_ -> wrapText $ + "Configure how the package is built by setting " + ++ "package (and other) flags.\n" + ++ "\n" + ++ "The configuration affects several other commands, " + ++ "including build, test, bench, run, repl.\n" + , commandNotes = Just $ \_pname -> programFlagsDescription progDb + , commandUsage = \pname -> + "Usage: " ++ pname ++ " configure [FLAGS]\n" + , commandDefaultFlags = defaultConfigFlags progDb + , commandOptions = \showOrParseArgs -> + configureOptions showOrParseArgs + ++ programDbPaths progDb showOrParseArgs + configProgramPaths (\v fs -> fs { configProgramPaths = v }) + ++ programDbOption progDb showOrParseArgs + configProgramArgs (\v fs -> fs { configProgramArgs = v }) + ++ programDbOptions progDb showOrParseArgs + configProgramArgs (\v fs -> fs { configProgramArgs = v }) + } + +-- | Inverse to 'dispModSubstEntry'. +parsecModSubstEntry :: ParsecParser (ModuleName, Module) +parsecModSubstEntry = do + k <- parsec + _ <- P.char '=' + v <- parsec + return (k, v) + +-- | Pretty-print a single entry of a module substitution. +dispModSubstEntry :: (ModuleName, Module) -> Disp.Doc +dispModSubstEntry (k, v) = pretty k <<>> Disp.char '=' <<>> pretty v + +configureOptions :: ShowOrParseArgs -> [OptionField ConfigFlags] +configureOptions showOrParseArgs = + [optionVerbosity configVerbosity + (\v flags -> flags { configVerbosity = v }) + ,optionDistPref + configDistPref (\d flags -> flags { configDistPref = d }) + showOrParseArgs + + ,option [] ["compiler"] "compiler" + configHcFlavor (\v flags -> flags { configHcFlavor = v }) + (choiceOpt [ (Flag GHC, ("g", ["ghc"]), "compile with GHC") + , (Flag GHCJS, ([] , ["ghcjs"]), "compile with GHCJS") + , (Flag UHC, ([] , ["uhc"]), "compile with UHC") + -- "haskell-suite" compiler id string will be replaced + -- by a more specific one during the configure stage + , (Flag (HaskellSuite "haskell-suite"), ([] , ["haskell-suite"]), + "compile with a haskell-suite compiler")]) + + ,option "" ["cabal-file"] + "use this Cabal file" + configCabalFilePath (\v flags -> flags { configCabalFilePath = v }) + (reqArgFlag "PATH") + + ,option "w" ["with-compiler"] + "give the path to a particular compiler" + configHcPath (\v flags -> flags { configHcPath = v }) + (reqArgFlag "PATH") + + ,option "" ["with-hc-pkg"] + "give the path to the package tool" + configHcPkg (\v flags -> flags { configHcPkg = v }) + (reqArgFlag "PATH") + ] + ++ map liftInstallDirs installDirsOptions + ++ [option "" ["program-prefix"] + "prefix to be applied to installed executables" + configProgPrefix + (\v flags -> flags { configProgPrefix = v }) + (reqPathTemplateArgFlag "PREFIX") + + ,option "" ["program-suffix"] + "suffix to be applied to installed executables" + configProgSuffix (\v flags -> flags { configProgSuffix = v } ) + (reqPathTemplateArgFlag "SUFFIX") + + ,option "" ["library-vanilla"] + "Vanilla libraries" + configVanillaLib (\v flags -> flags { configVanillaLib = v }) + (boolOpt [] []) + + ,option "p" ["library-profiling"] + "Library profiling" + configProfLib (\v flags -> flags { configProfLib = v }) + (boolOpt "p" []) + + ,option "" ["shared"] + "Shared library" + configSharedLib (\v flags -> flags { configSharedLib = v }) + (boolOpt [] []) + + ,option "" ["static"] + "Static library" + configStaticLib (\v flags -> flags { configStaticLib = v }) + (boolOpt [] []) + + ,option "" ["executable-dynamic"] + "Executable dynamic linking" + configDynExe (\v flags -> flags { configDynExe = v }) + (boolOpt [] []) + + ,option "" ["executable-static"] + "Executable fully static linking" + configFullyStaticExe (\v flags -> flags { configFullyStaticExe = v }) + (boolOpt [] []) + + ,option "" ["profiling"] + "Executable and library profiling" + configProf (\v flags -> flags { configProf = v }) + (boolOpt [] []) + + ,option "" ["executable-profiling"] + "Executable profiling (DEPRECATED)" + configProfExe (\v flags -> flags { configProfExe = v }) + (boolOpt [] []) + + ,option "" ["profiling-detail"] + ("Profiling detail level for executable and library (default, " ++ + "none, exported-functions, toplevel-functions, all-functions).") + configProfDetail (\v flags -> flags { configProfDetail = v }) + (reqArg' "level" (Flag . flagToProfDetailLevel) + showProfDetailLevelFlag) + + ,option "" ["library-profiling-detail"] + "Profiling detail level for libraries only." + configProfLibDetail (\v flags -> flags { configProfLibDetail = v }) + (reqArg' "level" (Flag . flagToProfDetailLevel) + showProfDetailLevelFlag) + + ,multiOption "optimization" + configOptimization (\v flags -> flags { configOptimization = v }) + [optArg' "n" (Flag . flagToOptimisationLevel) + (\f -> case f of + Flag NoOptimisation -> [] + Flag NormalOptimisation -> [Nothing] + Flag MaximumOptimisation -> [Just "2"] + _ -> []) + "O" ["enable-optimization","enable-optimisation"] + "Build with optimization (n is 0--2, default is 1)", + noArg (Flag NoOptimisation) [] + ["disable-optimization","disable-optimisation"] + "Build without optimization" + ] + + ,multiOption "debug-info" + configDebugInfo (\v flags -> flags { configDebugInfo = v }) + [optArg' "n" (Flag . flagToDebugInfoLevel) + (\f -> case f of + Flag NoDebugInfo -> [] + Flag MinimalDebugInfo -> [Just "1"] + Flag NormalDebugInfo -> [Nothing] + Flag MaximalDebugInfo -> [Just "3"] + _ -> []) + "" ["enable-debug-info"] + "Emit debug info (n is 0--3, default is 0)", + noArg (Flag NoDebugInfo) [] + ["disable-debug-info"] + "Don't emit debug info" + ] + + , multiOption "build-info" + configDumpBuildInfo + (\v flags -> flags { configDumpBuildInfo = v }) + [noArg (Flag DumpBuildInfo) [] + ["enable-build-info"] + "Enable build information generation during project building", + noArg (Flag NoDumpBuildInfo) [] + ["disable-build-info"] + "Disable build information generation during project building" + ] + + ,option "" ["library-for-ghci"] + "compile library for use with GHCi" + configGHCiLib (\v flags -> flags { configGHCiLib = v }) + (boolOpt [] []) + + ,option "" ["split-sections"] + "compile library code such that unneeded definitions can be dropped from the final executable (GHC 7.8+)" + configSplitSections (\v flags -> flags { configSplitSections = v }) + (boolOpt [] []) + + ,option "" ["split-objs"] + "split library into smaller objects to reduce binary sizes (GHC 6.6+)" + configSplitObjs (\v flags -> flags { configSplitObjs = v }) + (boolOpt [] []) + + ,option "" ["executable-stripping"] + "strip executables upon installation to reduce binary sizes" + configStripExes (\v flags -> flags { configStripExes = v }) + (boolOpt [] []) + + ,option "" ["library-stripping"] + "strip libraries upon installation to reduce binary sizes" + configStripLibs (\v flags -> flags { configStripLibs = v }) + (boolOpt [] []) + + ,option "" ["configure-option"] + "Extra option for configure" + configConfigureArgs (\v flags -> flags { configConfigureArgs = v }) + (reqArg' "OPT" (\x -> [x]) id) + + ,option "" ["user-install"] + "doing a per-user installation" + configUserInstall (\v flags -> flags { configUserInstall = v }) + (boolOpt' ([],["user"]) ([], ["global"])) + + ,option "" ["package-db"] + ( "Append the given package database to the list of package" + ++ " databases used (to satisfy dependencies and register into)." + ++ " May be a specific file, 'global' or 'user'. The initial list" + ++ " is ['global'], ['global', 'user'], or ['global', $sandbox]," + ++ " depending on context. Use 'clear' to reset the list to empty." + ++ " See the user guide for details.") + configPackageDBs (\v flags -> flags { configPackageDBs = v }) + (reqArg' "DB" readPackageDbList showPackageDbList) + + ,option "f" ["flags"] + "Force values for the given flags in Cabal conditionals in the .cabal file. E.g., --flags=\"debug -usebytestrings\" forces the flag \"debug\" to true and \"usebytestrings\" to false." + configConfigurationsFlags (\v flags -> flags { configConfigurationsFlags = v }) + (reqArg "FLAGS" + (parsecToReadE (\err -> "Invalid flag assignment: " ++ err) legacyParsecFlagAssignment) + legacyShowFlagAssignment') + + ,option "" ["extra-include-dirs"] + "A list of directories to search for header files" + configExtraIncludeDirs (\v flags -> flags {configExtraIncludeDirs = v}) + (reqArg' "PATH" (\x -> [x]) id) + + ,option "" ["deterministic"] + "Try to be as deterministic as possible (used by the test suite)" + configDeterministic (\v flags -> flags {configDeterministic = v}) + (boolOpt [] []) + + ,option "" ["ipid"] + "Installed package ID to compile this package as" + configIPID (\v flags -> flags {configIPID = v}) + (reqArgFlag "IPID") + + ,option "" ["cid"] + "Installed component ID to compile this component as" + (fmap prettyShow . configCID) (\v flags -> flags {configCID = fmap mkComponentId v}) + (reqArgFlag "CID") + + ,option "" ["extra-lib-dirs"] + "A list of directories to search for external libraries" + configExtraLibDirs (\v flags -> flags {configExtraLibDirs = v}) + (reqArg' "PATH" (\x -> [x]) id) + + ,option "" ["extra-lib-dirs-static"] + "A list of directories to search for external libraries when linking fully static executables" + configExtraLibDirsStatic (\v flags -> flags {configExtraLibDirsStatic = v}) + (reqArg' "PATH" (\x -> [x]) id) + + ,option "" ["extra-framework-dirs"] + "A list of directories to search for external frameworks (OS X only)" + configExtraFrameworkDirs + (\v flags -> flags {configExtraFrameworkDirs = v}) + (reqArg' "PATH" (\x -> [x]) id) + + ,option "" ["extra-prog-path"] + "A list of directories to search for required programs (in addition to the normal search locations)" + configProgramPathExtra (\v flags -> flags {configProgramPathExtra = v}) + (reqArg' "PATH" (\x -> toNubList [x]) fromNubList) + + ,option "" ["constraint"] + "A list of additional constraints on the dependencies." + configConstraints (\v flags -> flags { configConstraints = v}) + (reqArg "DEPENDENCY" + (parsecToReadE (const "dependency expected") ((\x -> [x]) `fmap` parsec)) + (map prettyShow)) + + ,option "" ["dependency"] + "A list of exact dependencies. E.g., --dependency=\"void=void-0.5.8-177d5cdf20962d0581fe2e4932a6c309\"" + configDependencies (\v flags -> flags { configDependencies = v}) + (reqArg "NAME[:COMPONENT_NAME]=CID" + (parsecToReadE (const "dependency expected") ((\x -> [x]) `fmap` parsecGivenComponent)) + (map (\(GivenComponent pn cn cid) -> + prettyShow pn + ++ case cn of LMainLibName -> "" + LSubLibName n -> ":" ++ prettyShow n + ++ "=" ++ prettyShow cid))) + + ,option "" ["instantiate-with"] + "A mapping of signature names to concrete module instantiations." + configInstantiateWith (\v flags -> flags { configInstantiateWith = v }) + (reqArg "NAME=MOD" + (parsecToReadE ("Cannot parse module substitution: " ++) (fmap (:[]) parsecModSubstEntry)) + (map (Disp.renderStyle defaultStyle . dispModSubstEntry))) + + ,option "" ["tests"] + "dependency checking and compilation for test suites listed in the package description file." + configTests (\v flags -> flags { configTests = v }) + (boolOpt [] []) + + ,option "" ["coverage"] + "build package with Haskell Program Coverage. (GHC only)" + configCoverage (\v flags -> flags { configCoverage = v }) + (boolOpt [] []) + + ,option "" ["library-coverage"] + "build package with Haskell Program Coverage. (GHC only) (DEPRECATED)" + configLibCoverage (\v flags -> flags { configLibCoverage = v }) + (boolOpt [] []) + + ,option "" ["exact-configuration"] + "All direct dependencies and flags are provided on the command line." + configExactConfiguration + (\v flags -> flags { configExactConfiguration = v }) + trueArg + + ,option "" ["benchmarks"] + "dependency checking and compilation for benchmarks listed in the package description file." + configBenchmarks (\v flags -> flags { configBenchmarks = v }) + (boolOpt [] []) + + ,option "" ["relocatable"] + "building a package that is relocatable. (GHC only)" + configRelocatable (\v flags -> flags { configRelocatable = v}) + (boolOpt [] []) + + ,option "" ["response-files"] + "enable workaround for old versions of programs like \"ar\" that do not support @file arguments" + configUseResponseFiles + (\v flags -> flags { configUseResponseFiles = v }) + (boolOpt' ([], ["disable-response-files"]) ([], [])) + + ,option "" ["allow-depending-on-private-libs"] + ( "Allow depending on private libraries. " + ++ "If set, the library visibility check MUST be done externally." ) + configAllowDependingOnPrivateLibs + (\v flags -> flags { configAllowDependingOnPrivateLibs = v }) + trueArg + ] + where + liftInstallDirs = + liftOption configInstallDirs (\v flags -> flags { configInstallDirs = v }) + + reqPathTemplateArgFlag title _sf _lf d get set = + reqArgFlag title _sf _lf d + (fmap fromPathTemplate . get) (set . fmap toPathTemplate) + +readPackageDbList :: String -> [Maybe PackageDB] +readPackageDbList str = [readPackageDb str] + +-- | Parse a PackageDB stack entry +-- +-- @since 3.7.0.0 +readPackageDb :: String -> Maybe PackageDB +readPackageDb "clear" = Nothing +readPackageDb "global" = Just GlobalPackageDB +readPackageDb "user" = Just UserPackageDB +readPackageDb other = Just (SpecificPackageDB other) + +showPackageDbList :: [Maybe PackageDB] -> [String] +showPackageDbList = map showPackageDb + +-- | Show a PackageDB stack entry +-- +-- @since 3.7.0.0 +showPackageDb :: Maybe PackageDB -> String +showPackageDb Nothing = "clear" +showPackageDb (Just GlobalPackageDB) = "global" +showPackageDb (Just UserPackageDB) = "user" +showPackageDb (Just (SpecificPackageDB db)) = db + +showProfDetailLevelFlag :: Flag ProfDetailLevel -> [String] +showProfDetailLevelFlag NoFlag = [] +showProfDetailLevelFlag (Flag dl) = [showProfDetailLevel dl] + +parsecGivenComponent :: ParsecParser GivenComponent +parsecGivenComponent = do + pn <- parsec + ln <- P.option LMainLibName $ do + _ <- P.char ':' + ucn <- parsec + return $ if unUnqualComponentName ucn == unPackageName pn + then LMainLibName + else LSubLibName ucn + _ <- P.char '=' + cid <- parsec + return $ GivenComponent pn ln cid + +installDirsOptions :: [OptionField (InstallDirs (Flag PathTemplate))] +installDirsOptions = + [ option "" ["prefix"] + "bake this prefix in preparation of installation" + prefix (\v flags -> flags { prefix = v }) + installDirArg + + , option "" ["bindir"] + "installation directory for executables" + bindir (\v flags -> flags { bindir = v }) + installDirArg + + , option "" ["libdir"] + "installation directory for libraries" + libdir (\v flags -> flags { libdir = v }) + installDirArg + + , option "" ["libsubdir"] + "subdirectory of libdir in which libs are installed" + libsubdir (\v flags -> flags { libsubdir = v }) + installDirArg + + , option "" ["dynlibdir"] + "installation directory for dynamic libraries" + dynlibdir (\v flags -> flags { dynlibdir = v }) + installDirArg + + , option "" ["libexecdir"] + "installation directory for program executables" + libexecdir (\v flags -> flags { libexecdir = v }) + installDirArg + + , option "" ["libexecsubdir"] + "subdirectory of libexecdir in which private executables are installed" + libexecsubdir (\v flags -> flags { libexecsubdir = v }) + installDirArg + + , option "" ["datadir"] + "installation directory for read-only data" + datadir (\v flags -> flags { datadir = v }) + installDirArg + + , option "" ["datasubdir"] + "subdirectory of datadir in which data files are installed" + datasubdir (\v flags -> flags { datasubdir = v }) + installDirArg + + , option "" ["docdir"] + "installation directory for documentation" + docdir (\v flags -> flags { docdir = v }) + installDirArg + + , option "" ["htmldir"] + "installation directory for HTML documentation" + htmldir (\v flags -> flags { htmldir = v }) + installDirArg + + , option "" ["haddockdir"] + "installation directory for haddock interfaces" + haddockdir (\v flags -> flags { haddockdir = v }) + installDirArg + + , option "" ["sysconfdir"] + "installation directory for configuration files" + sysconfdir (\v flags -> flags { sysconfdir = v }) + installDirArg + ] + where + installDirArg _sf _lf d get set = + reqArgFlag "DIR" _sf _lf d + (fmap fromPathTemplate . get) (set . fmap toPathTemplate) + +emptyConfigFlags :: ConfigFlags +emptyConfigFlags = mempty + +instance Monoid ConfigFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup ConfigFlags where + (<>) = gmappend + +-- ------------------------------------------------------------ +-- * Copy flags +-- ------------------------------------------------------------ + +-- | Flags to @copy@: (destdir, copy-prefix (backwards compat), verbosity) +data CopyFlags = CopyFlags { + copyDest :: Flag CopyDest, + copyDistPref :: Flag FilePath, + copyVerbosity :: Flag Verbosity, + -- This is the same hack as in 'buildArgs'. But I (ezyang) don't + -- think it's a hack, it's the right way to make hooks more robust + -- TODO: Stop using this eventually when 'UserHooks' gets changed + copyArgs :: [String], + copyCabalFilePath :: Flag FilePath + } + deriving (Show, Generic) + +defaultCopyFlags :: CopyFlags +defaultCopyFlags = CopyFlags { + copyDest = Flag NoCopyDest, + copyDistPref = NoFlag, + copyVerbosity = Flag normal, + copyArgs = [], + copyCabalFilePath = mempty + } + +copyCommand :: CommandUI CopyFlags +copyCommand = CommandUI + { commandName = "copy" + , commandSynopsis = "Copy the files of all/specific components to install locations." + , commandDescription = Just $ \_ -> wrapText $ + "Components encompass executables and libraries. " + ++ "Does not call register, and allows a prefix at install time. " + ++ "Without the --destdir flag, configure determines location.\n" + , commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " copy " + ++ " All the components in the package\n" + ++ " " ++ pname ++ " copy foo " + ++ " A component (i.e. lib, exe, test suite)" + , commandUsage = usageAlternatives "copy" $ + [ "[FLAGS]" + , "COMPONENTS [FLAGS]" + ] + , commandDefaultFlags = defaultCopyFlags + , commandOptions = \showOrParseArgs -> case showOrParseArgs of + ShowArgs -> filter ((`notElem` ["target-package-db"]) + . optionName) $ copyOptions ShowArgs + ParseArgs -> copyOptions ParseArgs +} + +copyOptions :: ShowOrParseArgs -> [OptionField CopyFlags] +copyOptions showOrParseArgs = + [optionVerbosity copyVerbosity (\v flags -> flags { copyVerbosity = v }) + + ,optionDistPref + copyDistPref (\d flags -> flags { copyDistPref = d }) + showOrParseArgs + + ,option "" ["destdir"] + "directory to copy files to, prepended to installation directories" + copyDest (\v flags -> case copyDest flags of + Flag (CopyToDb _) -> error "Use either 'destdir' or 'target-package-db'." + _ -> flags { copyDest = v }) + (reqArg "DIR" (succeedReadE (Flag . CopyTo)) + (\f -> case f of Flag (CopyTo p) -> [p]; _ -> [])) + + ,option "" ["target-package-db"] + "package database to copy files into. Required when using ${pkgroot} prefix." + copyDest (\v flags -> case copyDest flags of + NoFlag -> flags { copyDest = v } + Flag NoCopyDest -> flags { copyDest = v } + _ -> error "Use either 'destdir' or 'target-package-db'.") + (reqArg "DATABASE" (succeedReadE (Flag . CopyToDb)) + (\f -> case f of Flag (CopyToDb p) -> [p]; _ -> [])) + ] + +emptyCopyFlags :: CopyFlags +emptyCopyFlags = mempty + +instance Monoid CopyFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup CopyFlags where + (<>) = gmappend + +-- ------------------------------------------------------------ +-- * Install flags +-- ------------------------------------------------------------ + +-- | Flags to @install@: (package db, verbosity) +data InstallFlags = InstallFlags { + installPackageDB :: Flag PackageDB, + installDest :: Flag CopyDest, + installDistPref :: Flag FilePath, + installUseWrapper :: Flag Bool, + installInPlace :: Flag Bool, + installVerbosity :: Flag Verbosity, + -- this is only here, because we can not + -- change the hooks API. + installCabalFilePath :: Flag FilePath + } + deriving (Show, Generic) + +defaultInstallFlags :: InstallFlags +defaultInstallFlags = InstallFlags { + installPackageDB = NoFlag, + installDest = Flag NoCopyDest, + installDistPref = NoFlag, + installUseWrapper = Flag False, + installInPlace = Flag False, + installVerbosity = Flag normal, + installCabalFilePath = mempty + } + +installCommand :: CommandUI InstallFlags +installCommand = CommandUI + { commandName = "install" + , commandSynopsis = + "Copy the files into the install locations. Run register." + , commandDescription = Just $ \_ -> wrapText $ + "Unlike the copy command, install calls the register command." + ++ "If you want to install into a location that is not what was" + ++ "specified in the configure step, use the copy command.\n" + , commandNotes = Nothing + , commandUsage = \pname -> + "Usage: " ++ pname ++ " install [FLAGS]\n" + , commandDefaultFlags = defaultInstallFlags + , commandOptions = \showOrParseArgs -> case showOrParseArgs of + ShowArgs -> filter ((`notElem` ["target-package-db"]) + . optionName) $ installOptions ShowArgs + ParseArgs -> installOptions ParseArgs + } + +installOptions :: ShowOrParseArgs -> [OptionField InstallFlags] +installOptions showOrParseArgs = + [optionVerbosity installVerbosity (\v flags -> flags { installVerbosity = v }) + ,optionDistPref + installDistPref (\d flags -> flags { installDistPref = d }) + showOrParseArgs + + ,option "" ["inplace"] + "install the package in the install subdirectory of the dist prefix, so it can be used without being installed" + installInPlace (\v flags -> flags { installInPlace = v }) + trueArg + + ,option "" ["shell-wrappers"] + "using shell script wrappers around executables" + installUseWrapper (\v flags -> flags { installUseWrapper = v }) + (boolOpt [] []) + + ,option "" ["package-db"] "" + installPackageDB (\v flags -> flags { installPackageDB = v }) + (choiceOpt [ (Flag UserPackageDB, ([],["user"]), + "upon configuration register this package in the user's local package database") + , (Flag GlobalPackageDB, ([],["global"]), + "(default) upon configuration register this package in the system-wide package database")]) + ,option "" ["target-package-db"] + "package database to install into. Required when using ${pkgroot} prefix." + installDest (\v flags -> flags { installDest = v }) + (reqArg "DATABASE" (succeedReadE (Flag . CopyToDb)) + (\f -> case f of Flag (CopyToDb p) -> [p]; _ -> [])) + ] + +emptyInstallFlags :: InstallFlags +emptyInstallFlags = mempty + +instance Monoid InstallFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup InstallFlags where + (<>) = gmappend + +-- ------------------------------------------------------------ +-- * SDist flags +-- ------------------------------------------------------------ + +-- | Flags to @sdist@: (snapshot, verbosity) +data SDistFlags = SDistFlags { + sDistSnapshot :: Flag Bool, + sDistDirectory :: Flag FilePath, + sDistDistPref :: Flag FilePath, + sDistListSources :: Flag FilePath, + sDistVerbosity :: Flag Verbosity + } + deriving (Show, Generic, Typeable) + +defaultSDistFlags :: SDistFlags +defaultSDistFlags = SDistFlags { + sDistSnapshot = Flag False, + sDistDirectory = mempty, + sDistDistPref = NoFlag, + sDistListSources = mempty, + sDistVerbosity = Flag normal + } + +sdistCommand :: CommandUI SDistFlags +sdistCommand = CommandUI + { commandName = "sdist" + , commandSynopsis = + "Generate a source distribution file (.tar.gz)." + , commandDescription = Nothing + , commandNotes = Nothing + , commandUsage = \pname -> + "Usage: " ++ pname ++ " sdist [FLAGS]\n" + , commandDefaultFlags = defaultSDistFlags + , commandOptions = \showOrParseArgs -> + [optionVerbosity sDistVerbosity (\v flags -> flags { sDistVerbosity = v }) + ,optionDistPref + sDistDistPref (\d flags -> flags { sDistDistPref = d }) + showOrParseArgs + + ,option "" ["list-sources"] + "Just write a list of the package's sources to a file" + sDistListSources (\v flags -> flags { sDistListSources = v }) + (reqArgFlag "FILE") + + ,option "" ["snapshot"] + "Produce a snapshot source distribution" + sDistSnapshot (\v flags -> flags { sDistSnapshot = v }) + trueArg + + ,option "" ["output-directory"] + ("Generate a source distribution in the given directory, " + ++ "without creating a tarball") + sDistDirectory (\v flags -> flags { sDistDirectory = v }) + (reqArgFlag "DIR") + ] + } + +emptySDistFlags :: SDistFlags +emptySDistFlags = mempty + +instance Monoid SDistFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup SDistFlags where + (<>) = gmappend + +-- ------------------------------------------------------------ +-- * Register flags +-- ------------------------------------------------------------ + +-- | Flags to @register@ and @unregister@: (user package, gen-script, +-- in-place, verbosity) +data RegisterFlags = RegisterFlags { + regPackageDB :: Flag PackageDB, + regGenScript :: Flag Bool, + regGenPkgConf :: Flag (Maybe FilePath), + regInPlace :: Flag Bool, + regDistPref :: Flag FilePath, + regPrintId :: Flag Bool, + regVerbosity :: Flag Verbosity, + -- Same as in 'buildArgs' and 'copyArgs' + regArgs :: [String], + regCabalFilePath :: Flag FilePath + } + deriving (Show, Generic, Typeable) + +defaultRegisterFlags :: RegisterFlags +defaultRegisterFlags = RegisterFlags { + regPackageDB = NoFlag, + regGenScript = Flag False, + regGenPkgConf = NoFlag, + regInPlace = Flag False, + regDistPref = NoFlag, + regPrintId = Flag False, + regArgs = [], + regCabalFilePath = mempty, + regVerbosity = Flag normal + } + +registerCommand :: CommandUI RegisterFlags +registerCommand = CommandUI + { commandName = "register" + , commandSynopsis = + "Register this package with the compiler." + , commandDescription = Nothing + , commandNotes = Nothing + , commandUsage = \pname -> + "Usage: " ++ pname ++ " register [FLAGS]\n" + , commandDefaultFlags = defaultRegisterFlags + , commandOptions = \showOrParseArgs -> + [optionVerbosity regVerbosity (\v flags -> flags { regVerbosity = v }) + ,optionDistPref + regDistPref (\d flags -> flags { regDistPref = d }) + showOrParseArgs + + ,option "" ["packageDB"] "" + regPackageDB (\v flags -> flags { regPackageDB = v }) + (choiceOpt [ (Flag UserPackageDB, ([],["user"]), + "upon registration, register this package in the user's local package database") + , (Flag GlobalPackageDB, ([],["global"]), + "(default)upon registration, register this package in the system-wide package database")]) + + ,option "" ["inplace"] + "register the package in the build location, so it can be used without being installed" + regInPlace (\v flags -> flags { regInPlace = v }) + trueArg + + ,option "" ["gen-script"] + "instead of registering, generate a script to register later" + regGenScript (\v flags -> flags { regGenScript = v }) + trueArg + + ,option "" ["gen-pkg-config"] + "instead of registering, generate a package registration file/directory" + regGenPkgConf (\v flags -> flags { regGenPkgConf = v }) + (optArg' "PKG" Flag flagToList) + + ,option "" ["print-ipid"] + "print the installed package ID calculated for this package" + regPrintId (\v flags -> flags { regPrintId = v }) + trueArg + ] + } + +unregisterCommand :: CommandUI RegisterFlags +unregisterCommand = CommandUI + { commandName = "unregister" + , commandSynopsis = + "Unregister this package with the compiler." + , commandDescription = Nothing + , commandNotes = Nothing + , commandUsage = \pname -> + "Usage: " ++ pname ++ " unregister [FLAGS]\n" + , commandDefaultFlags = defaultRegisterFlags + , commandOptions = \showOrParseArgs -> + [optionVerbosity regVerbosity (\v flags -> flags { regVerbosity = v }) + ,optionDistPref + regDistPref (\d flags -> flags { regDistPref = d }) + showOrParseArgs + + ,option "" ["user"] "" + regPackageDB (\v flags -> flags { regPackageDB = v }) + (choiceOpt [ (Flag UserPackageDB, ([],["user"]), + "unregister this package in the user's local package database") + , (Flag GlobalPackageDB, ([],["global"]), + "(default) unregister this package in the system-wide package database")]) + + ,option "" ["gen-script"] + "Instead of performing the unregister command, generate a script to unregister later" + regGenScript (\v flags -> flags { regGenScript = v }) + trueArg + ] + } + +emptyRegisterFlags :: RegisterFlags +emptyRegisterFlags = mempty + +instance Monoid RegisterFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup RegisterFlags where + (<>) = gmappend + +-- ------------------------------------------------------------ +-- * HsColour flags +-- ------------------------------------------------------------ + +data HscolourFlags = HscolourFlags { + hscolourCSS :: Flag FilePath, + hscolourExecutables :: Flag Bool, + hscolourTestSuites :: Flag Bool, + hscolourBenchmarks :: Flag Bool, + hscolourForeignLibs :: Flag Bool, + hscolourDistPref :: Flag FilePath, + hscolourVerbosity :: Flag Verbosity, + hscolourCabalFilePath :: Flag FilePath + } + deriving (Show, Generic, Typeable) + +emptyHscolourFlags :: HscolourFlags +emptyHscolourFlags = mempty + +defaultHscolourFlags :: HscolourFlags +defaultHscolourFlags = HscolourFlags { + hscolourCSS = NoFlag, + hscolourExecutables = Flag False, + hscolourTestSuites = Flag False, + hscolourBenchmarks = Flag False, + hscolourDistPref = NoFlag, + hscolourForeignLibs = Flag False, + hscolourVerbosity = Flag normal, + hscolourCabalFilePath = mempty + } + +instance Monoid HscolourFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup HscolourFlags where + (<>) = gmappend + +hscolourCommand :: CommandUI HscolourFlags +hscolourCommand = CommandUI + { commandName = "hscolour" + , commandSynopsis = + "Generate HsColour colourised code, in HTML format." + , commandDescription = Just (\_ -> "Requires the hscolour program.\n") + , commandNotes = Just $ \_ -> + "Deprecated in favour of 'cabal haddock --hyperlink-source'." + , commandUsage = \pname -> + "Usage: " ++ pname ++ " hscolour [FLAGS]\n" + , commandDefaultFlags = defaultHscolourFlags + , commandOptions = \showOrParseArgs -> + [optionVerbosity hscolourVerbosity + (\v flags -> flags { hscolourVerbosity = v }) + ,optionDistPref + hscolourDistPref (\d flags -> flags { hscolourDistPref = d }) + showOrParseArgs + + ,option "" ["executables"] + "Run hscolour for Executables targets" + hscolourExecutables (\v flags -> flags { hscolourExecutables = v }) + trueArg + + ,option "" ["tests"] + "Run hscolour for Test Suite targets" + hscolourTestSuites (\v flags -> flags { hscolourTestSuites = v }) + trueArg + + ,option "" ["benchmarks"] + "Run hscolour for Benchmark targets" + hscolourBenchmarks (\v flags -> flags { hscolourBenchmarks = v }) + trueArg + + ,option "" ["foreign-libraries"] + "Run hscolour for Foreign Library targets" + hscolourForeignLibs (\v flags -> flags { hscolourForeignLibs = v }) + trueArg + + ,option "" ["all"] + "Run hscolour for all targets" + (\f -> allFlags [ hscolourExecutables f + , hscolourTestSuites f + , hscolourBenchmarks f + , hscolourForeignLibs f + ]) + (\v flags -> flags { hscolourExecutables = v + , hscolourTestSuites = v + , hscolourBenchmarks = v + , hscolourForeignLibs = v + }) + trueArg + + ,option "" ["css"] + "Use a cascading style sheet" + hscolourCSS (\v flags -> flags { hscolourCSS = v }) + (reqArgFlag "PATH") + ] + } + +-- ------------------------------------------------------------ +-- * Haddock flags +-- ------------------------------------------------------------ + + +-- | When we build haddock documentation, there are two cases: +-- +-- 1. We build haddocks only for the current development version, +-- intended for local use and not for distribution. In this case, +-- we store the generated documentation in @/doc/html/@. +-- +-- 2. We build haddocks for intended for uploading them to hackage. +-- In this case, we need to follow the layout that hackage expects +-- from documentation tarballs, and we might also want to use different +-- flags than for development builds, so in this case we store the generated +-- documentation in @/doc/html/-docs@. +data HaddockTarget = ForHackage | ForDevelopment deriving (Eq, Show, Generic, Typeable) + +instance Binary HaddockTarget +instance Structured HaddockTarget + +instance Pretty HaddockTarget where + pretty ForHackage = Disp.text "for-hackage" + pretty ForDevelopment = Disp.text "for-development" + +instance Parsec HaddockTarget where + parsec = P.choice [ P.try $ P.string "for-hackage" >> return ForHackage + , P.string "for-development" >> return ForDevelopment] + +data HaddockFlags = HaddockFlags { + haddockProgramPaths :: [(String, FilePath)], + haddockProgramArgs :: [(String, [String])], + haddockHoogle :: Flag Bool, + haddockHtml :: Flag Bool, + haddockHtmlLocation :: Flag String, + haddockForHackage :: Flag HaddockTarget, + haddockExecutables :: Flag Bool, + haddockTestSuites :: Flag Bool, + haddockBenchmarks :: Flag Bool, + haddockForeignLibs :: Flag Bool, + haddockInternal :: Flag Bool, + haddockCss :: Flag FilePath, + haddockLinkedSource :: Flag Bool, + haddockQuickJump :: Flag Bool, + haddockHscolourCss :: Flag FilePath, + haddockContents :: Flag PathTemplate, + haddockDistPref :: Flag FilePath, + haddockKeepTempFiles:: Flag Bool, + haddockVerbosity :: Flag Verbosity, + haddockCabalFilePath :: Flag FilePath, + haddockArgs :: [String] + } + deriving (Show, Generic, Typeable) + +defaultHaddockFlags :: HaddockFlags +defaultHaddockFlags = HaddockFlags { + haddockProgramPaths = mempty, + haddockProgramArgs = [], + haddockHoogle = Flag False, + haddockHtml = Flag False, + haddockHtmlLocation = NoFlag, + haddockForHackage = NoFlag, + haddockExecutables = Flag False, + haddockTestSuites = Flag False, + haddockBenchmarks = Flag False, + haddockForeignLibs = Flag False, + haddockInternal = Flag False, + haddockCss = NoFlag, + haddockLinkedSource = Flag False, + haddockQuickJump = Flag False, + haddockHscolourCss = NoFlag, + haddockContents = NoFlag, + haddockDistPref = NoFlag, + haddockKeepTempFiles= Flag False, + haddockVerbosity = Flag normal, + haddockCabalFilePath = mempty, + haddockArgs = mempty + } + +haddockCommand :: CommandUI HaddockFlags +haddockCommand = CommandUI + { commandName = "haddock" + , commandSynopsis = "Generate Haddock HTML documentation." + , commandDescription = Just $ \_ -> + "Requires the program haddock, version 2.x.\n" + , commandNotes = Nothing + , commandUsage = usageAlternatives "haddock" $ + [ "[FLAGS]" + , "COMPONENTS [FLAGS]" + ] + , commandDefaultFlags = defaultHaddockFlags + , commandOptions = \showOrParseArgs -> + haddockOptions showOrParseArgs + ++ programDbPaths progDb ParseArgs + haddockProgramPaths (\v flags -> flags { haddockProgramPaths = v}) + ++ programDbOption progDb showOrParseArgs + haddockProgramArgs (\v fs -> fs { haddockProgramArgs = v }) + ++ programDbOptions progDb ParseArgs + haddockProgramArgs (\v flags -> flags { haddockProgramArgs = v}) + } + where + progDb = addKnownProgram haddockProgram + $ addKnownProgram ghcProgram + $ emptyProgramDb + +haddockOptions :: ShowOrParseArgs -> [OptionField HaddockFlags] +haddockOptions showOrParseArgs = + [optionVerbosity haddockVerbosity + (\v flags -> flags { haddockVerbosity = v }) + ,optionDistPref + haddockDistPref (\d flags -> flags { haddockDistPref = d }) + showOrParseArgs + + ,option "" ["keep-temp-files"] + "Keep temporary files" + haddockKeepTempFiles (\b flags -> flags { haddockKeepTempFiles = b }) + trueArg + + ,option "" ["hoogle"] + "Generate a hoogle database" + haddockHoogle (\v flags -> flags { haddockHoogle = v }) + trueArg + + ,option "" ["html"] + "Generate HTML documentation (the default)" + haddockHtml (\v flags -> flags { haddockHtml = v }) + trueArg + + ,option "" ["html-location"] + "Location of HTML documentation for pre-requisite packages" + haddockHtmlLocation (\v flags -> flags { haddockHtmlLocation = v }) + (reqArgFlag "URL") + + ,option "" ["for-hackage"] + "Collection of flags to generate documentation suitable for upload to hackage" + haddockForHackage (\v flags -> flags { haddockForHackage = v }) + (noArg (Flag ForHackage)) + + ,option "" ["executables"] + "Run haddock for Executables targets" + haddockExecutables (\v flags -> flags { haddockExecutables = v }) + trueArg + + ,option "" ["tests"] + "Run haddock for Test Suite targets" + haddockTestSuites (\v flags -> flags { haddockTestSuites = v }) + trueArg + + ,option "" ["benchmarks"] + "Run haddock for Benchmark targets" + haddockBenchmarks (\v flags -> flags { haddockBenchmarks = v }) + trueArg + + ,option "" ["foreign-libraries"] + "Run haddock for Foreign Library targets" + haddockForeignLibs (\v flags -> flags { haddockForeignLibs = v }) + trueArg + + ,option "" ["all"] + "Run haddock for all targets" + (\f -> allFlags [ haddockExecutables f + , haddockTestSuites f + , haddockBenchmarks f + , haddockForeignLibs f + ]) + (\v flags -> flags { haddockExecutables = v + , haddockTestSuites = v + , haddockBenchmarks = v + , haddockForeignLibs = v + }) + trueArg + + ,option "" ["internal"] + "Run haddock for internal modules and include all symbols" + haddockInternal (\v flags -> flags { haddockInternal = v }) + trueArg + + ,option "" ["css"] + "Use PATH as the haddock stylesheet" + haddockCss (\v flags -> flags { haddockCss = v }) + (reqArgFlag "PATH") + + ,option "" ["hyperlink-source","hyperlink-sources","hyperlinked-source"] + "Hyperlink the documentation to the source code" + haddockLinkedSource (\v flags -> flags { haddockLinkedSource = v }) + trueArg + + ,option "" ["quickjump"] + "Generate an index for interactive documentation navigation" + haddockQuickJump (\v flags -> flags { haddockQuickJump = v }) + trueArg + + ,option "" ["hscolour-css"] + "Use PATH as the HsColour stylesheet" + haddockHscolourCss (\v flags -> flags { haddockHscolourCss = v }) + (reqArgFlag "PATH") + + ,option "" ["contents-location"] + "Bake URL in as the location for the contents page" + haddockContents (\v flags -> flags { haddockContents = v }) + (reqArg' "URL" + (toFlag . toPathTemplate) + (flagToList . fmap fromPathTemplate)) + ] + +emptyHaddockFlags :: HaddockFlags +emptyHaddockFlags = mempty + +instance Monoid HaddockFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup HaddockFlags where + (<>) = gmappend + +-- ------------------------------------------------------------ +-- * Clean flags +-- ------------------------------------------------------------ + +data CleanFlags = CleanFlags { + cleanSaveConf :: Flag Bool, + cleanDistPref :: Flag FilePath, + cleanVerbosity :: Flag Verbosity, + cleanCabalFilePath :: Flag FilePath + } + deriving (Show, Generic, Typeable) + +defaultCleanFlags :: CleanFlags +defaultCleanFlags = CleanFlags { + cleanSaveConf = Flag False, + cleanDistPref = NoFlag, + cleanVerbosity = Flag normal, + cleanCabalFilePath = mempty + } + +cleanCommand :: CommandUI CleanFlags +cleanCommand = CommandUI + { commandName = "clean" + , commandSynopsis = "Clean up after a build." + , commandDescription = Just $ \_ -> + "Removes .hi, .o, preprocessed sources, etc.\n" + , commandNotes = Nothing + , commandUsage = \pname -> + "Usage: " ++ pname ++ " clean [FLAGS]\n" + , commandDefaultFlags = defaultCleanFlags + , commandOptions = \showOrParseArgs -> + [optionVerbosity cleanVerbosity (\v flags -> flags { cleanVerbosity = v }) + ,optionDistPref + cleanDistPref (\d flags -> flags { cleanDistPref = d }) + showOrParseArgs + + ,option "s" ["save-configure"] + "Do not remove the configuration file (dist/setup-config) during cleaning. Saves need to reconfigure." + cleanSaveConf (\v flags -> flags { cleanSaveConf = v }) + trueArg + ] + } + +emptyCleanFlags :: CleanFlags +emptyCleanFlags = mempty + +instance Monoid CleanFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup CleanFlags where + (<>) = gmappend + +-- ------------------------------------------------------------ +-- * Build flags +-- ------------------------------------------------------------ + +data BuildFlags = BuildFlags { + buildProgramPaths :: [(String, FilePath)], + buildProgramArgs :: [(String, [String])], + buildDistPref :: Flag FilePath, + buildVerbosity :: Flag Verbosity, + buildNumJobs :: Flag (Maybe Int), + -- TODO: this one should not be here, it's just that the silly + -- UserHooks stop us from passing extra info in other ways + buildArgs :: [String], + buildCabalFilePath :: Flag FilePath + } + deriving (Read, Show, Generic, Typeable) + +defaultBuildFlags :: BuildFlags +defaultBuildFlags = BuildFlags { + buildProgramPaths = mempty, + buildProgramArgs = [], + buildDistPref = mempty, + buildVerbosity = Flag normal, + buildNumJobs = mempty, + buildArgs = [], + buildCabalFilePath = mempty + } + +buildCommand :: ProgramDb -> CommandUI BuildFlags +buildCommand progDb = CommandUI + { commandName = "build" + , commandSynopsis = "Compile all/specific components." + , commandDescription = Just $ \_ -> wrapText $ + "Components encompass executables, tests, and benchmarks.\n" + ++ "\n" + ++ "Affected by configuration options, see `configure`.\n" + , commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " build " + ++ " All the components in the package\n" + ++ " " ++ pname ++ " build foo " + ++ " A component (i.e. lib, exe, test suite)\n\n" + ++ programFlagsDescription progDb +--TODO: re-enable once we have support for module/file targets +-- ++ " " ++ pname ++ " build Foo.Bar " +-- ++ " A module\n" +-- ++ " " ++ pname ++ " build Foo/Bar.hs" +-- ++ " A file\n\n" +-- ++ "If a target is ambiguous it can be qualified with the component " +-- ++ "name, e.g.\n" +-- ++ " " ++ pname ++ " build foo:Foo.Bar\n" +-- ++ " " ++ pname ++ " build testsuite1:Foo/Bar.hs\n" + , commandUsage = usageAlternatives "build" $ + [ "[FLAGS]" + , "COMPONENTS [FLAGS]" + ] + , commandDefaultFlags = defaultBuildFlags + , commandOptions = \showOrParseArgs -> + [ optionVerbosity + buildVerbosity (\v flags -> flags { buildVerbosity = v }) + + , optionDistPref + buildDistPref (\d flags -> flags { buildDistPref = d }) showOrParseArgs + ] + ++ buildOptions progDb showOrParseArgs + } + +buildOptions :: ProgramDb -> ShowOrParseArgs + -> [OptionField BuildFlags] +buildOptions progDb showOrParseArgs = + [ optionNumJobs + buildNumJobs (\v flags -> flags { buildNumJobs = v }) + ] + + ++ programDbPaths progDb showOrParseArgs + buildProgramPaths (\v flags -> flags { buildProgramPaths = v}) + + ++ programDbOption progDb showOrParseArgs + buildProgramArgs (\v fs -> fs { buildProgramArgs = v }) + + ++ programDbOptions progDb showOrParseArgs + buildProgramArgs (\v flags -> flags { buildProgramArgs = v}) + +emptyBuildFlags :: BuildFlags +emptyBuildFlags = mempty + +instance Monoid BuildFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup BuildFlags where + (<>) = gmappend + +-- ------------------------------------------------------------ +-- * REPL Flags +-- ------------------------------------------------------------ + +data ReplOptions = ReplOptions { + replOptionsFlags :: [String], + replOptionsNoLoad :: Flag Bool + } + deriving (Show, Generic, Typeable) + +instance Binary ReplOptions +instance Structured ReplOptions + + +instance Monoid ReplOptions where + mempty = ReplOptions mempty (Flag False) + mappend = (<>) + +instance Semigroup ReplOptions where + (<>) = gmappend + +data ReplFlags = ReplFlags { + replProgramPaths :: [(String, FilePath)], + replProgramArgs :: [(String, [String])], + replDistPref :: Flag FilePath, + replVerbosity :: Flag Verbosity, + replReload :: Flag Bool, + replReplOptions :: ReplOptions + } + deriving (Show, Generic, Typeable) + +defaultReplFlags :: ReplFlags +defaultReplFlags = ReplFlags { + replProgramPaths = mempty, + replProgramArgs = [], + replDistPref = NoFlag, + replVerbosity = Flag normal, + replReload = Flag False, + replReplOptions = mempty + } + +instance Monoid ReplFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup ReplFlags where + (<>) = gmappend + +replCommand :: ProgramDb -> CommandUI ReplFlags +replCommand progDb = CommandUI + { commandName = "repl" + , commandSynopsis = + "Open an interpreter session for the given component." + , commandDescription = Just $ \pname -> wrapText $ + "If the current directory contains no package, ignores COMPONENT " + ++ "parameters and opens an interactive interpreter session; if a " + ++ "sandbox is present, its package database will be used.\n" + ++ "\n" + ++ "Otherwise, (re)configures with the given or default flags, and " + ++ "loads the interpreter with the relevant modules. For executables, " + ++ "tests and benchmarks, loads the main module (and its " + ++ "dependencies); for libraries all exposed/other modules.\n" + ++ "\n" + ++ "The default component is the library itself, or the executable " + ++ "if that is the only component.\n" + ++ "\n" + ++ "Support for loading specific modules is planned but not " + ++ "implemented yet. For certain scenarios, `" ++ pname + ++ " exec -- ghci :l Foo` may be used instead. Note that `exec` will " + ++ "not (re)configure and you will have to specify the location of " + ++ "other modules, if required.\n" + + , commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " repl " + ++ " The first component in the package\n" + ++ " " ++ pname ++ " repl foo " + ++ " A named component (i.e. lib, exe, test suite)\n" + ++ " " ++ pname ++ " repl --repl-options=\"-lstdc++\"" + ++ " Specifying flags for interpreter\n" +--TODO: re-enable once we have support for module/file targets +-- ++ " " ++ pname ++ " repl Foo.Bar " +-- ++ " A module\n" +-- ++ " " ++ pname ++ " repl Foo/Bar.hs" +-- ++ " A file\n\n" +-- ++ "If a target is ambiguous it can be qualified with the component " +-- ++ "name, e.g.\n" +-- ++ " " ++ pname ++ " repl foo:Foo.Bar\n" +-- ++ " " ++ pname ++ " repl testsuite1:Foo/Bar.hs\n" + , commandUsage = \pname -> "Usage: " ++ pname ++ " repl [COMPONENT] [FLAGS]\n" + , commandDefaultFlags = defaultReplFlags + , commandOptions = \showOrParseArgs -> + optionVerbosity replVerbosity (\v flags -> flags { replVerbosity = v }) + : optionDistPref + replDistPref (\d flags -> flags { replDistPref = d }) + showOrParseArgs + + : programDbPaths progDb showOrParseArgs + replProgramPaths (\v flags -> flags { replProgramPaths = v}) + + ++ programDbOption progDb showOrParseArgs + replProgramArgs (\v flags -> flags { replProgramArgs = v}) + + ++ programDbOptions progDb showOrParseArgs + replProgramArgs (\v flags -> flags { replProgramArgs = v}) + + ++ case showOrParseArgs of + ParseArgs -> + [ option "" ["reload"] + "Used from within an interpreter to update files." + replReload (\v flags -> flags { replReload = v }) + trueArg + ] + _ -> [] + ++ map liftReplOption (replOptions showOrParseArgs) + } + where + liftReplOption = liftOption replReplOptions (\v flags -> flags { replReplOptions = v }) + +replOptions :: ShowOrParseArgs -> [OptionField ReplOptions] +replOptions _ = + [ option [] ["repl-no-load"] + "Disable loading of project modules at REPL startup." + replOptionsNoLoad (\p flags -> flags { replOptionsNoLoad = p }) + trueArg + , option [] ["repl-options"] + "Use the option(s) for the repl" + replOptionsFlags (\p flags -> flags { replOptionsFlags = p }) + (reqArg "FLAG" (succeedReadE words) id) + ] + +-- ------------------------------------------------------------ +-- * Test flags +-- ------------------------------------------------------------ + +data TestShowDetails = Never | Failures | Always | Streaming | Direct + deriving (Eq, Ord, Enum, Bounded, Generic, Show, Typeable) + +instance Binary TestShowDetails +instance Structured TestShowDetails + +knownTestShowDetails :: [TestShowDetails] +knownTestShowDetails = [minBound..maxBound] + +instance Pretty TestShowDetails where + pretty = Disp.text . lowercase . show + +instance Parsec TestShowDetails where + parsec = maybe (fail "invalid TestShowDetails") return . classify =<< ident + where + ident = P.munch1 (\c -> isAlpha c || c == '_' || c == '-') + classify str = lookup (lowercase str) enumMap + enumMap :: [(String, TestShowDetails)] + enumMap = [ (prettyShow x, x) + | x <- knownTestShowDetails ] + +--TODO: do we need this instance? +instance Monoid TestShowDetails where + mempty = Never + mappend = (<>) + +instance Semigroup TestShowDetails where + a <> b = if a < b then b else a + +data TestFlags = TestFlags { + testDistPref :: Flag FilePath, + testVerbosity :: Flag Verbosity, + testHumanLog :: Flag PathTemplate, + testMachineLog :: Flag PathTemplate, + testShowDetails :: Flag TestShowDetails, + testKeepTix :: Flag Bool, + testWrapper :: Flag FilePath, + testFailWhenNoTestSuites :: Flag Bool, + -- TODO: think about if/how options are passed to test exes + testOptions :: [PathTemplate] + } deriving (Show, Generic, Typeable) + +defaultTestFlags :: TestFlags +defaultTestFlags = TestFlags { + testDistPref = NoFlag, + testVerbosity = Flag normal, + testHumanLog = toFlag $ toPathTemplate $ "$pkgid-$test-suite.log", + testMachineLog = toFlag $ toPathTemplate $ "$pkgid.log", + testShowDetails = toFlag Failures, + testKeepTix = toFlag False, + testWrapper = NoFlag, + testFailWhenNoTestSuites = toFlag False, + testOptions = [] + } + +testCommand :: CommandUI TestFlags +testCommand = CommandUI + { commandName = "test" + , commandSynopsis = + "Run all/specific tests in the test suite." + , commandDescription = Just $ \ _pname -> wrapText $ + testOrBenchmarkHelpText "test" + , commandNotes = Nothing + , commandUsage = usageAlternatives "test" + [ "[FLAGS]" + , "TESTCOMPONENTS [FLAGS]" + ] + , commandDefaultFlags = defaultTestFlags + , commandOptions = testOptions' + } + +-- | Help text for @test@ and @bench@ commands. +testOrBenchmarkHelpText + :: String -- ^ Either @"test"@ or @"benchmark"@. + -> String -- ^ Help text. +testOrBenchmarkHelpText s = unlines $ map unwords + [ [ "The package must have been build with configuration" + , concat [ "flag `--enable-", s, "s`." ] + ] + , [] -- blank line + , [ concat [ "Note that additional dependencies of the ", s, "s" ] + , "must have already been installed." + ] + , [] + , [ "By defining UserHooks in a custom Setup.hs, the package can define" + , concat [ "actions to be executed before and after running ", s, "s." ] + ] + ] + +testOptions' :: ShowOrParseArgs -> [OptionField TestFlags] +testOptions' showOrParseArgs = + [ optionVerbosity testVerbosity (\v flags -> flags { testVerbosity = v }) + , optionDistPref + testDistPref (\d flags -> flags { testDistPref = d }) + showOrParseArgs + , option [] ["log"] + ("Log all test suite results to file (name template can use " + ++ "$pkgid, $compiler, $os, $arch, $test-suite, $result)") + testHumanLog (\v flags -> flags { testHumanLog = v }) + (reqArg' "TEMPLATE" + (toFlag . toPathTemplate) + (flagToList . fmap fromPathTemplate)) + , option [] ["machine-log"] + ("Produce a machine-readable log file (name template can use " + ++ "$pkgid, $compiler, $os, $arch, $result)") + testMachineLog (\v flags -> flags { testMachineLog = v }) + (reqArg' "TEMPLATE" + (toFlag . toPathTemplate) + (flagToList . fmap fromPathTemplate)) + , option [] ["show-details"] + ("'always': always show results of individual test cases. " + ++ "'never': never show results of individual test cases. " + ++ "'failures': show results of failing test cases. " + ++ "'streaming': show results of test cases in real time." + ++ "'direct': send results of test cases in real time; no log file.") + testShowDetails (\v flags -> flags { testShowDetails = v }) + (reqArg "FILTER" + (parsecToReadE (\_ -> "--show-details flag expects one of " + ++ intercalate ", " + (map prettyShow knownTestShowDetails)) + (fmap toFlag parsec)) + (flagToList . fmap prettyShow)) + , option [] ["keep-tix-files"] + "keep .tix files for HPC between test runs" + testKeepTix (\v flags -> flags { testKeepTix = v}) + trueArg + , option [] ["test-wrapper"] + "Run test through a wrapper." + testWrapper (\v flags -> flags { testWrapper = v }) + (reqArg' "FILE" (toFlag :: FilePath -> Flag FilePath) + (flagToList :: Flag FilePath -> [FilePath])) + , option [] ["fail-when-no-test-suites"] + ("Exit with failure when no test suites are found.") + testFailWhenNoTestSuites (\v flags -> flags { testFailWhenNoTestSuites = v}) + trueArg + , option [] ["test-options"] + ("give extra options to test executables " + ++ "(name templates can use $pkgid, $compiler, " + ++ "$os, $arch, $test-suite)") + testOptions (\v flags -> flags { testOptions = v }) + (reqArg' "TEMPLATES" (map toPathTemplate . splitArgs) + (const [])) + , option [] ["test-option"] + ("give extra option to test executables " + ++ "(no need to quote options containing spaces, " + ++ "name template can use $pkgid, $compiler, " + ++ "$os, $arch, $test-suite)") + testOptions (\v flags -> flags { testOptions = v }) + (reqArg' "TEMPLATE" (\x -> [toPathTemplate x]) + (map fromPathTemplate)) + ] + +emptyTestFlags :: TestFlags +emptyTestFlags = mempty + +instance Monoid TestFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup TestFlags where + (<>) = gmappend + +-- ------------------------------------------------------------ +-- * Benchmark flags +-- ------------------------------------------------------------ + +data BenchmarkFlags = BenchmarkFlags { + benchmarkDistPref :: Flag FilePath, + benchmarkVerbosity :: Flag Verbosity, + benchmarkOptions :: [PathTemplate] + } deriving (Show, Generic, Typeable) + +defaultBenchmarkFlags :: BenchmarkFlags +defaultBenchmarkFlags = BenchmarkFlags { + benchmarkDistPref = NoFlag, + benchmarkVerbosity = Flag normal, + benchmarkOptions = [] + } + +benchmarkCommand :: CommandUI BenchmarkFlags +benchmarkCommand = CommandUI + { commandName = "bench" + , commandSynopsis = + "Run all/specific benchmarks." + , commandDescription = Just $ \ _pname -> wrapText $ + testOrBenchmarkHelpText "benchmark" + , commandNotes = Nothing + , commandUsage = usageAlternatives "bench" + [ "[FLAGS]" + , "BENCHCOMPONENTS [FLAGS]" + ] + , commandDefaultFlags = defaultBenchmarkFlags + , commandOptions = benchmarkOptions' + } + +benchmarkOptions' :: ShowOrParseArgs -> [OptionField BenchmarkFlags] +benchmarkOptions' showOrParseArgs = + [ optionVerbosity benchmarkVerbosity + (\v flags -> flags { benchmarkVerbosity = v }) + , optionDistPref + benchmarkDistPref (\d flags -> flags { benchmarkDistPref = d }) + showOrParseArgs + , option [] ["benchmark-options"] + ("give extra options to benchmark executables " + ++ "(name templates can use $pkgid, $compiler, " + ++ "$os, $arch, $benchmark)") + benchmarkOptions (\v flags -> flags { benchmarkOptions = v }) + (reqArg' "TEMPLATES" (map toPathTemplate . splitArgs) + (const [])) + , option [] ["benchmark-option"] + ("give extra option to benchmark executables " + ++ "(no need to quote options containing spaces, " + ++ "name template can use $pkgid, $compiler, " + ++ "$os, $arch, $benchmark)") + benchmarkOptions (\v flags -> flags { benchmarkOptions = v }) + (reqArg' "TEMPLATE" (\x -> [toPathTemplate x]) + (map fromPathTemplate)) + ] + +emptyBenchmarkFlags :: BenchmarkFlags +emptyBenchmarkFlags = mempty + +instance Monoid BenchmarkFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup BenchmarkFlags where + (<>) = gmappend + +-- ------------------------------------------------------------ +-- * Shared options utils +-- ------------------------------------------------------------ + +programFlagsDescription :: ProgramDb -> String +programFlagsDescription progDb = + "The flags --with-PROG and --PROG-option(s) can be used with" + ++ " the following programs:" + ++ (concatMap (\line -> "\n " ++ unwords line) . wrapLine 77 . sort) + [ programName prog | (prog, _) <- knownPrograms progDb ] + ++ "\n" + +-- | For each known program @PROG@ in 'progDb', produce a @with-PROG@ +-- 'OptionField'. +programDbPaths + :: ProgramDb + -> ShowOrParseArgs + -> (flags -> [(String, FilePath)]) + -> ([(String, FilePath)] -> (flags -> flags)) + -> [OptionField flags] +programDbPaths progDb showOrParseArgs get set = + programDbPaths' ("with-" ++) progDb showOrParseArgs get set + +-- | Like 'programDbPaths', but allows to customise the option name. +programDbPaths' + :: (String -> String) + -> ProgramDb + -> ShowOrParseArgs + -> (flags -> [(String, FilePath)]) + -> ([(String, FilePath)] -> (flags -> flags)) + -> [OptionField flags] +programDbPaths' mkName progDb showOrParseArgs get set = + case showOrParseArgs of + -- we don't want a verbose help text list so we just show a generic one: + ShowArgs -> [withProgramPath "PROG"] + ParseArgs -> map (withProgramPath . programName . fst) + (knownPrograms progDb) + where + withProgramPath prog = + option "" [mkName prog] + ("give the path to " ++ prog) + get set + (reqArg' "PATH" (\path -> [(prog, path)]) + (\progPaths -> [ path | (prog', path) <- progPaths, prog==prog' ])) + +-- | For each known program @PROG@ in 'progDb', produce a @PROG-option@ +-- 'OptionField'. +programDbOption + :: ProgramDb + -> ShowOrParseArgs + -> (flags -> [(String, [String])]) + -> ([(String, [String])] -> (flags -> flags)) + -> [OptionField flags] +programDbOption progDb showOrParseArgs get set = + case showOrParseArgs of + -- we don't want a verbose help text list so we just show a generic one: + ShowArgs -> [programOption "PROG"] + ParseArgs -> map (programOption . programName . fst) + (knownPrograms progDb) + where + programOption prog = + option "" [prog ++ "-option"] + ("give an extra option to " ++ prog ++ + " (no need to quote options containing spaces)") + get set + (reqArg' "OPT" (\arg -> [(prog, [arg])]) + (\progArgs -> concat [ args + | (prog', args) <- progArgs, prog==prog' ])) + + +-- | For each known program @PROG@ in 'progDb', produce a @PROG-options@ +-- 'OptionField'. +programDbOptions + :: ProgramDb + -> ShowOrParseArgs + -> (flags -> [(String, [String])]) + -> ([(String, [String])] -> (flags -> flags)) + -> [OptionField flags] +programDbOptions progDb showOrParseArgs get set = + case showOrParseArgs of + -- we don't want a verbose help text list so we just show a generic one: + ShowArgs -> [programOptions "PROG"] + ParseArgs -> map (programOptions . programName . fst) + (knownPrograms progDb) + where + programOptions prog = + option "" [prog ++ "-options"] + ("give extra options to " ++ prog) + get set + (reqArg' "OPTS" (\args -> [(prog, splitArgs args)]) (const [])) + +-- ------------------------------------------------------------ +-- * GetOpt Utils +-- ------------------------------------------------------------ + +boolOpt :: SFlags -> SFlags + -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a +boolOpt = Command.boolOpt flagToMaybe Flag + +boolOpt' :: OptFlags -> OptFlags + -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a +boolOpt' = Command.boolOpt' flagToMaybe Flag + +trueArg, falseArg :: MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a +trueArg sfT lfT = boolOpt' (sfT, lfT) ([], []) sfT lfT +falseArg sfF lfF = boolOpt' ([], []) (sfF, lfF) sfF lfF + +reqArgFlag :: ArgPlaceHolder -> SFlags -> LFlags -> Description -> + (b -> Flag String) -> (Flag String -> b -> b) -> OptDescr b +reqArgFlag ad = reqArg ad (succeedReadE Flag) flagToList + +optionDistPref :: (flags -> Flag FilePath) + -> (Flag FilePath -> flags -> flags) + -> ShowOrParseArgs + -> OptionField flags +optionDistPref get set = \showOrParseArgs -> + option "" (distPrefFlagName showOrParseArgs) + ( "The directory where Cabal puts generated build files " + ++ "(default " ++ defaultDistPref ++ ")") + get set + (reqArgFlag "DIR") + where + distPrefFlagName ShowArgs = ["builddir"] + distPrefFlagName ParseArgs = ["builddir", "distdir", "distpref"] + +optionVerbosity :: (flags -> Flag Verbosity) + -> (Flag Verbosity -> flags -> flags) + -> OptionField flags +optionVerbosity get set = + option "v" ["verbose"] + "Control verbosity (n is 0--3, default verbosity level is 1)" + get set + (optArg "n" (fmap Flag flagToVerbosity) + (Flag verbose) -- default Value if no n is given + (fmap (Just . showForCabal) . flagToList)) + +optionNumJobs :: (flags -> Flag (Maybe Int)) + -> (Flag (Maybe Int) -> flags -> flags) + -> OptionField flags +optionNumJobs get set = + option "j" ["jobs"] + "Run NUM jobs simultaneously (or '$ncpus' if no NUM is given)." + get set + (optArg "NUM" (fmap Flag numJobsParser) + (Flag Nothing) + (map (Just . maybe "$ncpus" show) . flagToList)) + where + numJobsParser :: ReadE (Maybe Int) + numJobsParser = ReadE $ \s -> + case s of + "$ncpus" -> Right Nothing + _ -> case reads s of + [(n, "")] + | n < 1 -> Left "The number of jobs should be 1 or more." + | otherwise -> Right (Just n) + _ -> Left "The jobs value should be a number or '$ncpus'" + +-- ------------------------------------------------------------ +-- * Other Utils +-- ------------------------------------------------------------ + +-- | Arguments to pass to a @configure@ script, e.g. generated by +-- @autoconf@. +configureArgs :: Bool -> ConfigFlags -> [String] +configureArgs bcHack flags + = hc_flag + ++ optFlag "with-hc-pkg" configHcPkg + ++ optFlag' "prefix" prefix + ++ optFlag' "bindir" bindir + ++ optFlag' "libdir" libdir + ++ optFlag' "libexecdir" libexecdir + ++ optFlag' "datadir" datadir + ++ optFlag' "sysconfdir" sysconfdir + ++ configConfigureArgs flags + where + hc_flag = case (configHcFlavor flags, configHcPath flags) of + (_, Flag hc_path) -> [hc_flag_name ++ hc_path] + (Flag hc, NoFlag) -> [hc_flag_name ++ prettyShow hc] + (NoFlag,NoFlag) -> [] + hc_flag_name + --TODO kill off thic bc hack when defaultUserHooks is removed. + | bcHack = "--with-hc=" + | otherwise = "--with-compiler=" + optFlag name config_field = case config_field flags of + Flag p -> ["--" ++ name ++ "=" ++ p] + NoFlag -> [] + optFlag' name config_field = optFlag name (fmap fromPathTemplate + . config_field + . configInstallDirs) + +configureCCompiler :: Verbosity -> ProgramDb + -> IO (FilePath, [String]) +configureCCompiler verbosity progdb = configureProg verbosity progdb gccProgram + +configureLinker :: Verbosity -> ProgramDb -> IO (FilePath, [String]) +configureLinker verbosity progdb = configureProg verbosity progdb ldProgram + +configureProg :: Verbosity -> ProgramDb -> Program + -> IO (FilePath, [String]) +configureProg verbosity programDb prog = do + (p, _) <- requireProgram verbosity prog programDb + let pInv = programInvocation p [] + return (progInvokePath pInv, progInvokeArgs pInv) + +-- | Helper function to split a string into a list of arguments. +-- It's supposed to handle quoted things sensibly, eg: +-- +-- > splitArgs "--foo=\"C:/Program Files/Bar/" --baz" +-- > = ["--foo=C:/Program Files/Bar", "--baz"] +-- +-- > splitArgs "\"-DMSGSTR=\\\"foo bar\\\"\" --baz" +-- > = ["-DMSGSTR=\"foo bar\"","--baz"] +-- +splitArgs :: String -> [String] +splitArgs = space [] + where + space :: String -> String -> [String] + space w [] = word w [] + space w ( c :s) + | isSpace c = word w (space [] s) + space w ('"':s) = string w s + space w s = nonstring w s + + string :: String -> String -> [String] + string w [] = word w [] + string w ('"':s) = space w s + string w ('\\':'"':s) = string ('"':w) s + string w ( c :s) = string (c:w) s + + nonstring :: String -> String -> [String] + nonstring w [] = word w [] + nonstring w ('"':s) = string w s + nonstring w ( c :s) = space (c:w) s + + word [] s = s + word w s = reverse w : s + +-- The test cases kinda have to be rewritten from the ground up... :/ +--hunitTests :: [Test] +--hunitTests = +-- let m = [("ghc", GHC), ("nhc98", NHC), ("hugs", Hugs)] +-- (flags, commands', unkFlags, ers) +-- = getOpt Permute options ["configure", "foobar", "--prefix=/foo", "--ghc", "--nhc98", "--hugs", "--with-compiler=/comp", "--unknown1", "--unknown2", "--install-prefix=/foo", "--user", "--global"] +-- in [TestLabel "very basic option parsing" $ TestList [ +-- "getOpt flags" ~: "failed" ~: +-- [Prefix "/foo", GhcFlag, NhcFlag, HugsFlag, +-- WithCompiler "/comp", InstPrefix "/foo", UserFlag, GlobalFlag] +-- ~=? flags, +-- "getOpt commands" ~: "failed" ~: ["configure", "foobar"] ~=? commands', +-- "getOpt unknown opts" ~: "failed" ~: +-- ["--unknown1", "--unknown2"] ~=? unkFlags, +-- "getOpt errors" ~: "failed" ~: [] ~=? ers], +-- +-- TestLabel "test location of various compilers" $ TestList +-- ["configure parsing for prefix and compiler flag" ~: "failed" ~: +-- (Right (ConfigCmd (Just comp, Nothing, Just "/usr/local"), [])) +-- ~=? (parseArgs ["--prefix=/usr/local", "--"++name, "configure"]) +-- | (name, comp) <- m], +-- +-- TestLabel "find the package tool" $ TestList +-- ["configure parsing for prefix comp flag, withcompiler" ~: "failed" ~: +-- (Right (ConfigCmd (Just comp, Just "/foo/comp", Just "/usr/local"), [])) +-- ~=? (parseArgs ["--prefix=/usr/local", "--"++name, +-- "--with-compiler=/foo/comp", "configure"]) +-- | (name, comp) <- m], +-- +-- TestLabel "simpler commands" $ TestList +-- [flag ~: "failed" ~: (Right (flagCmd, [])) ~=? (parseArgs [flag]) +-- | (flag, flagCmd) <- [("build", BuildCmd), +-- ("install", InstallCmd Nothing False), +-- ("sdist", SDistCmd), +-- ("register", RegisterCmd False)] +-- ] +-- ] + +{- Testing ideas: + * IO to look for hugs and hugs-pkg (which hugs, etc) + * quickCheck to test permutations of arguments + * what other options can we over-ride with a command-line flag? +-} diff --git a/cabal/Cabal/src/Distribution/Simple/ShowBuildInfo.hs b/cabal/Cabal/src/Distribution/Simple/ShowBuildInfo.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/ShowBuildInfo.hs @@ -0,0 +1,201 @@ +-- | +-- This module defines a simple JSON-based format for exporting basic +-- information about a Cabal package and the compiler configuration Cabal +-- would use to build it. This can be produced with the +-- @cabal build --enable-build-info@ command. +-- +-- +-- This format is intended for consumption by external tooling and should +-- therefore be rather stable. Moreover, this allows tooling users to avoid +-- linking against Cabal. This is an important advantage as direct API usage +-- tends to be rather fragile in the presence of user-initiated upgrades of +-- Cabal. +-- +-- Below is an example of the output this module produces, +-- +-- @ +-- { "cabal-lib-version": "1.23.0.0", +-- "compiler": { +-- "flavour": "GHC", +-- "compiler-id": "ghc-7.10.2", +-- "path": "/usr/bin/ghc", +-- }, +-- "components": [ +-- { "type": "lib", +-- "name": "lib:Cabal", +-- "compiler-args": +-- ["-O", "-XHaskell98", "-Wall", +-- "-package-id", "parallel-3.2.0.6-b79c38c5c25fff77f3ea7271851879eb"] +-- "modules": ["Project.ModA", "Project.ModB", "Paths_project"], +-- "src-files": [], +-- "src-dirs": ["src"] +-- } +-- ] +-- } +-- @ +-- +-- The output format needs to be validated against 'doc/json-schemas/build-info.schema.json'. +-- If the format changes, update the schema as well! +-- +-- The @cabal-lib-version@ property provides the version of the Cabal library +-- which generated the output. The @compiler@ property gives some basic +-- information about the compiler Cabal would use to compile the package. +-- +-- The @components@ property gives a list of the Cabal 'Component's defined by +-- the package. Each has, +-- +-- * @type@: the type of the component (one of @lib@, @exe@, +-- @test@, @bench@, or @flib@) +-- * @name@: a string serving to uniquely identify the component within the +-- package. +-- * @compiler-args@: the command-line arguments Cabal would pass to the +-- compiler to compile the component +-- * @modules@: the modules belonging to the component +-- * @src-dirs@: a list of directories where the modules might be found +-- * @src-files@: any other Haskell sources needed by the component +-- +-- Note: At the moment this is only supported when using the GHC compiler. +-- + +{-# LANGUAGE OverloadedStrings #-} + +module Distribution.Simple.ShowBuildInfo ( + mkBuildInfo, mkBuildInfo', mkCompilerInfo, mkComponentInfo + ) where + +import System.FilePath + +import Distribution.Compat.Prelude +import Prelude () + +import qualified Distribution.Simple.GHC as GHC +import qualified Distribution.Simple.Program.GHC as GHC + +import Distribution.PackageDescription +import Distribution.Compiler +import Distribution.Verbosity +import Distribution.Simple.Compiler (Compiler, showCompilerId, compilerFlavor) +import Distribution.Simple.Program +import Distribution.Simple.Setup +import Distribution.Simple.Utils (cabalVersion) +import Distribution.Utils.Json +import Distribution.Types.Component +import Distribution.Types.ComponentLocalBuildInfo +import Distribution.Types.LocalBuildInfo +import Distribution.Types.TargetInfo +import Distribution.Text +import Distribution.Pretty + +-- | Construct a JSON document describing the build information for a +-- package. +mkBuildInfo + :: FilePath -- ^ The source directory of the package + -> PackageDescription -- ^ Mostly information from the .cabal file + -> LocalBuildInfo -- ^ Configuration information + -> BuildFlags -- ^ Flags that the user passed to build + -> (ConfiguredProgram, Compiler) + -- ^ Compiler information. + -- Needs to be passed explicitly, as we can't extract that information here + -- without some partial function. + -> [TargetInfo] + -> ([String], Json) -- ^ Json representation of buildinfo alongside generated warnings +mkBuildInfo wdir pkg_descr lbi _flags compilerInfo targetsToBuild = (warnings, JsonObject buildInfoFields) + where + buildInfoFields = mkBuildInfo' (uncurry mkCompilerInfo compilerInfo) componentInfos + componentInfosWithWarnings = map (mkComponentInfo wdir pkg_descr lbi . targetCLBI) targetsToBuild + componentInfos = map snd componentInfosWithWarnings + warnings = concatMap fst componentInfosWithWarnings + +-- | A variant of 'mkBuildInfo' if you need to call 'mkCompilerInfo' and +-- 'mkComponentInfo' yourself. +-- +-- If you change the format or any name in the output json, don't forget to update +-- the schema at @\/doc\/json-schemas\/build-info.schema.json@ and the docs of +-- @--enable-build-info@\/@--disable-build-info@. +mkBuildInfo' + :: Json -- ^ The 'Json' from 'mkCompilerInfo' + -> [Json] -- ^ The 'Json' from 'mkComponentInfo' + -> [(String, Json)] +mkBuildInfo' compilerInfo componentInfos = + [ "cabal-lib-version" .= JsonString (display cabalVersion) + , "compiler" .= compilerInfo + , "components" .= JsonArray componentInfos + ] + +mkCompilerInfo :: ConfiguredProgram -> Compiler -> Json +mkCompilerInfo compilerProgram compilerInfo = JsonObject + [ "flavour" .= JsonString (prettyShow $ compilerFlavor compilerInfo) + , "compiler-id" .= JsonString (showCompilerId compilerInfo) + , "path" .= JsonString (programPath compilerProgram) + ] + +mkComponentInfo :: FilePath -> PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> ([String], Json) +mkComponentInfo wdir pkg_descr lbi clbi = (warnings, JsonObject $ + [ "type" .= JsonString compType + , "name" .= JsonString (prettyShow name) + , "unit-id" .= JsonString (prettyShow $ componentUnitId clbi) + , "compiler-args" .= JsonArray (map JsonString compilerArgs) + , "modules" .= JsonArray (map (JsonString . display) modules) + , "src-files" .= JsonArray (map JsonString sourceFiles) + , "hs-src-dirs" .= JsonArray (map (JsonString . prettyShow) $ hsSourceDirs bi) + , "src-dir" .= JsonString (addTrailingPathSeparator wdir) + ] <> cabalFile) + where + (warnings, compilerArgs) = getCompilerArgs bi lbi clbi + name = componentLocalName clbi + bi = componentBuildInfo comp + -- If this error happens, a cabal invariant has been violated + comp = fromMaybe (error $ "mkBuildInfo: no component " ++ prettyShow name) $ lookupComponent pkg_descr name + compType = case comp of + CLib _ -> "lib" + CExe _ -> "exe" + CTest _ -> "test" + CBench _ -> "bench" + CFLib _ -> "flib" + modules = case comp of + CLib lib -> explicitLibModules lib + CExe exe -> exeModules exe + CTest test -> + case testInterface test of + TestSuiteExeV10 _ _ -> [] + TestSuiteLibV09 _ modName -> [modName] + TestSuiteUnsupported _ -> [] + CBench bench -> benchmarkModules bench + CFLib flib -> foreignLibModules flib + sourceFiles = case comp of + CLib _ -> [] + CExe exe -> [modulePath exe] + CTest test -> + case testInterface test of + TestSuiteExeV10 _ fp -> [fp] + TestSuiteLibV09 _ _ -> [] + TestSuiteUnsupported _ -> [] + CBench bench -> case benchmarkInterface bench of + BenchmarkExeV10 _ fp -> [fp] + BenchmarkUnsupported _ -> [] + + CFLib _ -> [] + cabalFile + | Just fp <- pkgDescrFile lbi = [("cabal-file", JsonString fp)] + | otherwise = [] + +-- | Get the command-line arguments that would be passed +-- to the compiler to build the given component. +getCompilerArgs + :: BuildInfo + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> ([String], [String]) +getCompilerArgs bi lbi clbi = + case compilerFlavor $ compiler lbi of + GHC -> ([], ghc) + GHCJS -> ([], ghc) + c -> + ( ["ShowBuildInfo.getCompilerArgs: Don't know how to get build " + ++ " arguments for compiler " ++ show c] + , []) + where + -- This is absolutely awful + ghc = GHC.renderGhcOptions (compiler lbi) (hostPlatform lbi) baseOpts + where + baseOpts = GHC.componentGhcOptions normal lbi bi clbi (buildDir lbi) diff --git a/cabal/Cabal/src/Distribution/Simple/SrcDist.hs b/cabal/Cabal/src/Distribution/Simple/SrcDist.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/SrcDist.hs @@ -0,0 +1,537 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.SrcDist +-- Copyright : Simon Marlow 2004 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This handles the @sdist@ command. The module exports an 'sdist' action but +-- also some of the phases that make it up so that other tools can use just the +-- bits they need. In particular the preparation of the tree of files to go +-- into the source tarball is separated from actually building the source +-- tarball. +-- +-- The 'createArchive' action uses the external @tar@ program and assumes that +-- it accepts the @-z@ flag. Neither of these assumptions are valid on Windows. +-- The 'sdist' action now also does some distribution QA checks. + +-- NOTE: FIX: we don't have a great way of testing this module, since +-- we can't easily look inside a tarball once its created. + +module Distribution.Simple.SrcDist ( + -- * The top level action + sdist, + + -- ** Parts of 'sdist' + printPackageProblems, + prepareTree, + createArchive, + + -- ** Snapshots + prepareSnapshotTree, + snapshotPackage, + snapshotVersion, + dateToSnapshotNumber, + + -- * Extracting the source files + listPackageSources, + listPackageSourcesWithDie, + + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.PackageDescription +import Distribution.PackageDescription.Check hiding (doesFileExist) +import Distribution.Package +import Distribution.ModuleName +import qualified Distribution.ModuleName as ModuleName +import Distribution.Version +import Distribution.Simple.Configure (findDistPrefOrDefault) +import Distribution.Simple.Glob (matchDirFileGlobWithDie) +import Distribution.Simple.Utils +import Distribution.Simple.Setup +import Distribution.Simple.PreProcess +import Distribution.Simple.BuildPaths +import Distribution.Simple.Program +import Distribution.Pretty +import Distribution.Verbosity +import Distribution.Utils.Path + +import qualified Data.Map as Map +import Data.Time (UTCTime, getCurrentTime, toGregorian, utctDay) +import System.Directory ( doesFileExist ) +import System.IO (IOMode(WriteMode), hPutStrLn, withFile) +import System.FilePath ((), (<.>), dropExtension, isRelative) + +-- |Create a source distribution. +sdist :: PackageDescription -- ^ information from the tarball + -> SDistFlags -- ^ verbosity & snapshot + -> (FilePath -> FilePath) -- ^ build prefix (temp dir) + -> [PPSuffixHandler] -- ^ extra preprocessors (includes suffixes) + -> IO () +sdist pkg flags mkTmpDir pps = do + + distPref <- findDistPrefOrDefault $ sDistDistPref flags + let targetPref = distPref + tmpTargetDir = mkTmpDir distPref + + -- When given --list-sources, just output the list of sources to a file. + case sDistListSources flags of + Flag path -> withFile path WriteMode $ \outHandle -> do + ordinary <- listPackageSources verbosity "." pkg pps + traverse_ (hPutStrLn outHandle) ordinary + notice verbosity $ "List of package sources written to file '" ++ path ++ "'" + + NoFlag -> do + -- do some QA + printPackageProblems verbosity pkg + + date <- getCurrentTime + let pkg' | snapshot = snapshotPackage date pkg + | otherwise = pkg + + case flagToMaybe (sDistDirectory flags) of + Just targetDir -> do + generateSourceDir targetDir pkg' + info verbosity $ "Source directory created: " ++ targetDir + + Nothing -> do + createDirectoryIfMissingVerbose verbosity True tmpTargetDir + withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do + let targetDir = tmpDir tarBallName pkg' + generateSourceDir targetDir pkg' + targzFile <- createArchive verbosity pkg' tmpDir targetPref + notice verbosity $ "Source tarball created: " ++ targzFile + + where + generateSourceDir :: FilePath -> PackageDescription -> IO () + generateSourceDir targetDir pkg' = do + setupMessage verbosity "Building source dist for" (packageId pkg') + prepareTree verbosity pkg' targetDir pps + when snapshot $ + overwriteSnapshotPackageDesc verbosity pkg' targetDir + + verbosity = fromFlag (sDistVerbosity flags) + snapshot = fromFlag (sDistSnapshot flags) + +-- | List all source files of a package. +-- +-- Since @Cabal-3.4@ returns a single list. There shouldn't be any +-- executable files, they are hardly portable. +-- +listPackageSources + :: Verbosity -- ^ verbosity + -> FilePath -- ^ directory with cabal file + -> PackageDescription -- ^ info from the cabal file + -> [PPSuffixHandler] -- ^ extra preprocessors (include suffixes) + -> IO [FilePath] -- ^ relative paths +listPackageSources verbosity cwd pkg_descr0 pps = do + -- Call helpers that actually do all work. + listPackageSources' verbosity die' cwd pkg_descr pps + where + pkg_descr = filterAutogenModules pkg_descr0 + +-- | A variant of 'listPackageSources' with configurable 'die'. +-- +-- /Note:/ may still 'die' directly. For example on missing include file. +-- +-- Since @3.4.0.0 +listPackageSourcesWithDie + :: Verbosity -- ^ verbosity + -> (Verbosity -> String -> IO [FilePath]) + -- ^ 'die'' alternative. + -- Since 'die'' prefixes the error message with 'errorPrefix', + -- whatever is passed in here and wants to die should do the same. + -- See issue #7331. + -> FilePath -- ^ directory with cabal file + -> PackageDescription -- ^ info from the cabal file + -> [PPSuffixHandler] -- ^ extra preprocessors (include suffixes) + -> IO [FilePath] -- ^ relative paths +listPackageSourcesWithDie verbosity rip cwd pkg_descr0 pps = do + -- Call helpers that actually do all work. + listPackageSources' verbosity rip cwd pkg_descr pps + where + pkg_descr = filterAutogenModules pkg_descr0 + + +listPackageSources' + :: Verbosity + -- ^ verbosity + -> (Verbosity -> String -> IO [FilePath]) + -- ^ 'die'' alternative. + -- Since 'die'' prefixes the error message with 'errorPrefix', + -- whatever is passed in here and wants to die should do the same. + -- See issue #7331. + -> FilePath + -- ^ directory with cabal file + -> PackageDescription + -- ^ info from the cabal file + -> [PPSuffixHandler] + -- ^ extra preprocessors (include suffixes) + -> IO [FilePath] + -- ^ relative paths +listPackageSources' verbosity rip cwd pkg_descr pps = + fmap concat . sequenceA $ + [ + -- Library sources. + fmap concat + . withAllLib $ \Library { + exposedModules = modules, + signatures = sigs, + libBuildInfo = libBi + } -> + allSourcesBuildInfo verbosity rip cwd libBi pps (modules ++ sigs) + + -- Executables sources. + , fmap concat + . withAllExe $ \Executable { modulePath = mainPath, buildInfo = exeBi } -> do + biSrcs <- allSourcesBuildInfo verbosity rip cwd exeBi pps [] + mainSrc <- findMainExeFile verbosity cwd exeBi pps mainPath + return (mainSrc:biSrcs) + + -- Foreign library sources + , fmap concat + . withAllFLib $ \flib@(ForeignLib { foreignLibBuildInfo = flibBi }) -> do + biSrcs <- allSourcesBuildInfo verbosity rip cwd flibBi pps [] + defFiles <- traverse (findModDefFile verbosity cwd flibBi pps) + (foreignLibModDefFile flib) + return (defFiles ++ biSrcs) + + -- Test suites sources. + , fmap concat + . withAllTest $ \t -> do + let bi = testBuildInfo t + case testInterface t of + TestSuiteExeV10 _ mainPath -> do + biSrcs <- allSourcesBuildInfo verbosity rip cwd bi pps [] + srcMainFile <- findMainExeFile verbosity cwd bi pps mainPath + return (srcMainFile:biSrcs) + TestSuiteLibV09 _ m -> + allSourcesBuildInfo verbosity rip cwd bi pps [m] + TestSuiteUnsupported tp -> + rip verbosity $ "Unsupported test suite type: " ++ show tp + + -- Benchmarks sources. + , fmap concat + . withAllBenchmark $ \bm -> do + let bi = benchmarkBuildInfo bm + case benchmarkInterface bm of + BenchmarkExeV10 _ mainPath -> do + biSrcs <- allSourcesBuildInfo verbosity rip cwd bi pps [] + srcMainFile <- findMainExeFile verbosity cwd bi pps mainPath + return (srcMainFile:biSrcs) + BenchmarkUnsupported tp -> + rip verbosity $ "Unsupported benchmark type: " ++ show tp + + -- Data files. + , fmap concat + . for (dataFiles pkg_descr) $ \filename -> do + let srcDataDirRaw = dataDir pkg_descr + srcDataDir | null srcDataDirRaw = "." + | otherwise = srcDataDirRaw + matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) cwd (srcDataDir filename) + + -- Extra source files. + , fmap concat . for (extraSrcFiles pkg_descr) $ \fpath -> + matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) cwd fpath + + -- Extra doc files. + , fmap concat + . for (extraDocFiles pkg_descr) $ \ filename -> + matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) cwd filename + + -- License file(s). + , return (map getSymbolicPath $ licenseFiles pkg_descr) + + -- Install-include files, without autogen-include files + , fmap concat + . withAllLib $ \ l -> do + let lbi = libBuildInfo l + incls = filter (`notElem` autogenIncludes lbi) (installIncludes lbi) + relincdirs = "." : filter isRelative (includeDirs lbi) + traverse (fmap snd . findIncludeFile verbosity cwd relincdirs) incls + + -- Setup script, if it exists. + , fmap (maybe [] (\f -> [f])) $ findSetupFile cwd + + -- The .cabal file itself. + , fmap (\d -> [d]) (tryFindPackageDescCwd verbosity cwd ".") + + ] + where + -- We have to deal with all libs and executables, so we have local + -- versions of these functions that ignore the 'buildable' attribute: + withAllLib action = traverse action (allLibraries pkg_descr) + withAllFLib action = traverse action (foreignLibs pkg_descr) + withAllExe action = traverse action (executables pkg_descr) + withAllTest action = traverse action (testSuites pkg_descr) + withAllBenchmark action = traverse action (benchmarks pkg_descr) + + +-- |Prepare a directory tree of source files. +prepareTree :: Verbosity -- ^ verbosity + -> PackageDescription -- ^ info from the cabal file + -> FilePath -- ^ source tree to populate + -> [PPSuffixHandler] -- ^ extra preprocessors (includes suffixes) + -> IO () +prepareTree verbosity pkg_descr0 targetDir pps = do + ordinary <- listPackageSources verbosity "." pkg_descr pps + installOrdinaryFiles verbosity targetDir (zip (repeat []) ordinary) + maybeCreateDefaultSetupScript targetDir + where + pkg_descr = filterAutogenModules pkg_descr0 + +-- | Find the setup script file, if it exists. +findSetupFile :: FilePath -> IO (Maybe FilePath) +findSetupFile targetDir = do + hsExists <- doesFileExist (targetDir setupHs) + lhsExists <- doesFileExist (targetDir setupLhs) + if hsExists + then return (Just setupHs) + else if lhsExists + then return (Just setupLhs) + else return Nothing + where + setupHs = "Setup.hs" + setupLhs = "Setup.lhs" + +-- | Create a default setup script in the target directory, if it doesn't exist. +maybeCreateDefaultSetupScript :: FilePath -> IO () +maybeCreateDefaultSetupScript targetDir = do + mSetupFile <- findSetupFile targetDir + case mSetupFile of + Just _setupFile -> return () + Nothing -> do + writeUTF8File (targetDir "Setup.hs") $ unlines [ + "import Distribution.Simple", + "main = defaultMain"] + +-- | Find the main executable file. +findMainExeFile + :: Verbosity + -> FilePath -- ^ cwd + -> BuildInfo + -> [PPSuffixHandler] + -> FilePath -- ^ main-is + -> IO FilePath +findMainExeFile verbosity cwd exeBi pps mainPath = do + ppFile <- findFileCwdWithExtension cwd (ppSuffixes pps) (map getSymbolicPath (hsSourceDirs exeBi)) + (dropExtension mainPath) + case ppFile of + Nothing -> findFileCwd verbosity cwd (map getSymbolicPath (hsSourceDirs exeBi)) mainPath + Just pp -> return pp + +-- | Find a module definition file +-- +-- TODO: I don't know if this is right +findModDefFile + :: Verbosity -> FilePath -> BuildInfo -> [PPSuffixHandler] -> FilePath -> IO FilePath +findModDefFile verbosity cwd flibBi _pps modDefPath = + findFileCwd verbosity cwd ("." : map getSymbolicPath (hsSourceDirs flibBi)) modDefPath + +-- | Given a list of include paths, try to find the include file named +-- @f@. Return the name of the file and the full path, or exit with error if +-- there's no such file. +findIncludeFile :: Verbosity -> FilePath -> [FilePath] -> String -> IO (String, FilePath) +findIncludeFile verbosity _ [] f = die' verbosity ("can't find include file " ++ f) +findIncludeFile verbosity cwd (d:ds) f = do + let path = (d f) + b <- doesFileExist (cwd path) + if b then return (f,path) else findIncludeFile verbosity cwd ds f + +-- | Remove the auto-generated modules (like 'Paths_*') from 'exposed-modules' +-- and 'other-modules'. +filterAutogenModules :: PackageDescription -> PackageDescription +filterAutogenModules pkg_descr0 = mapLib filterAutogenModuleLib $ + mapAllBuildInfo filterAutogenModuleBI pkg_descr0 + where + mapLib f pkg = pkg { library = fmap f (library pkg) + , subLibraries = map f (subLibraries pkg) } + filterAutogenModuleLib lib = lib { + exposedModules = filter (filterFunction (libBuildInfo lib)) (exposedModules lib) + } + filterAutogenModuleBI bi = bi { + otherModules = filter (filterFunction bi) (otherModules bi) + } + pathsModule = autogenPathsModuleName pkg_descr0 + filterFunction bi = \mn -> + mn /= pathsModule + && not (mn `elem` autogenModules bi) + +-- | Prepare a directory tree of source files for a snapshot version. +-- It is expected that the appropriate snapshot version has already been set +-- in the package description, eg using 'snapshotPackage' or 'snapshotVersion'. +-- +prepareSnapshotTree + :: Verbosity -- ^verbosity + -> PackageDescription -- ^info from the cabal file + -> FilePath -- ^source tree to populate + -> [PPSuffixHandler] -- ^extra preprocessors (includes suffixes) + -> IO () +prepareSnapshotTree verbosity pkg targetDir pps = do + prepareTree verbosity pkg targetDir pps + overwriteSnapshotPackageDesc verbosity pkg targetDir + +overwriteSnapshotPackageDesc :: Verbosity -- ^verbosity + -> PackageDescription -- ^info from the cabal file + -> FilePath -- ^source tree + -> IO () +overwriteSnapshotPackageDesc verbosity pkg targetDir = do + -- We could just writePackageDescription targetDescFile pkg_descr, + -- but that would lose comments and formatting. + descFile <- defaultPackageDesc verbosity + withUTF8FileContents descFile $ + writeUTF8File (targetDir descFile) + . unlines . map (replaceVersion (packageVersion pkg)) . lines + + where + replaceVersion :: Version -> String -> String + replaceVersion version line + | "version:" `isPrefixOf` map toLower line + = "version: " ++ prettyShow version + | otherwise = line + +-- | Modifies a 'PackageDescription' by appending a snapshot number +-- corresponding to the given date. +-- +snapshotPackage :: UTCTime -> PackageDescription -> PackageDescription +snapshotPackage date pkg = + pkg { + package = pkgid { pkgVersion = snapshotVersion date (pkgVersion pkgid) } + } + where pkgid = packageId pkg + +-- | Modifies a 'Version' by appending a snapshot number corresponding +-- to the given date. +-- +snapshotVersion :: UTCTime -> Version -> Version +snapshotVersion date = alterVersion (++ [dateToSnapshotNumber date]) + +-- | Given a date produce a corresponding integer representation. +-- For example given a date @18/03/2008@ produce the number @20080318@. +-- +dateToSnapshotNumber :: UTCTime -> Int +dateToSnapshotNumber date = case toGregorian (utctDay date) of + (year, month, day) -> + fromIntegral year * 10000 + + month * 100 + + day + +-- | Create an archive from a tree of source files, and clean up the tree. +createArchive + :: Verbosity -- ^ verbosity + -> PackageDescription -- ^ info from cabal file + -> FilePath -- ^ source tree to archive + -> FilePath -- ^ name of archive to create + -> IO FilePath +createArchive verbosity pkg_descr tmpDir targetPref = do + let tarBallFilePath = targetPref tarBallName pkg_descr <.> "tar.gz" + (tarProg, _) <- requireProgram verbosity tarProgram defaultProgramDb + let formatOptSupported = maybe False (== "YES") $ + Map.lookup "Supports --format" + (programProperties tarProg) + runProgram verbosity tarProg $ + -- Hmm: I could well be skating on thinner ice here by using the -C option + -- (=> seems to be supported at least by GNU and *BSD tar) [The + -- prev. solution used pipes and sub-command sequences to set up the paths + -- correctly, which is problematic in a Windows setting.] + ["-czf", tarBallFilePath, "-C", tmpDir] + ++ (if formatOptSupported then ["--format", "ustar"] else []) + ++ [tarBallName pkg_descr] + return tarBallFilePath + +-- | Given a buildinfo, return the names of all source files. +allSourcesBuildInfo + :: Verbosity + -> (Verbosity -> String -> IO [FilePath]) + -- ^ 'die'' alternative. + -- Since 'die'' prefixes the error message with 'errorPrefix', + -- whatever is passed in here and wants to die should do the same. + -- See issue #7331. + -> FilePath -- ^ cwd -- change me to 'BuildPath Absolute PackageDir' + -> BuildInfo + -> [PPSuffixHandler] -- ^ Extra preprocessors + -> [ModuleName] -- ^ Exposed modules + -> IO [FilePath] +allSourcesBuildInfo verbosity rip cwd bi pps modules = do + let searchDirs = map getSymbolicPath (hsSourceDirs bi) + sources <- fmap concat $ sequenceA $ + [ let file = ModuleName.toFilePath module_ + -- NB: *Not* findFileWithExtension, because the same source + -- file may show up in multiple paths due to a conditional; + -- we need to package all of them. See #367. + in findAllFilesCwdWithExtension cwd suffixes searchDirs file + >>= nonEmpty' (notFound module_) return + | module_ <- modules ++ otherModules bi ] + bootFiles <- sequenceA + [ let file = ModuleName.toFilePath module_ + fileExts = ["hs-boot", "lhs-boot"] + in findFileCwdWithExtension cwd fileExts (map getSymbolicPath (hsSourceDirs bi)) file + | module_ <- modules ++ otherModules bi ] + + return $ sources ++ catMaybes bootFiles ++ cSources bi ++ cxxSources bi ++ + cmmSources bi ++ asmSources bi ++ jsSources bi + + where + nonEmpty' :: b -> ([a] -> b) -> [a] -> b + nonEmpty' x _ [] = x + nonEmpty' _ f xs = f xs + + suffixes = ppSuffixes pps ++ ["hs", "lhs", "hsig", "lhsig"] + + notFound :: ModuleName -> IO [FilePath] + notFound m = rip verbosity $ "Could not find module: " ++ prettyShow m + ++ " with any suffix: " ++ show suffixes ++ ". If the module " + ++ "is autogenerated it should be added to 'autogen-modules'." + + +-- | Note: must be called with the CWD set to the directory containing +-- the '.cabal' file. +printPackageProblems :: Verbosity -> PackageDescription -> IO () +printPackageProblems verbosity pkg_descr = do + ioChecks <- checkPackageFiles verbosity pkg_descr "." + let pureChecks = checkConfiguredPackage pkg_descr + isDistError (PackageDistSuspicious _) = False + isDistError (PackageDistSuspiciousWarn _) = False + isDistError _ = True + (errors, warnings) = partition isDistError (pureChecks ++ ioChecks) + unless (null errors) $ + notice verbosity $ "Distribution quality errors:\n" + ++ unlines (map explanation errors) + unless (null warnings) $ + notice verbosity $ "Distribution quality warnings:\n" + ++ unlines (map explanation warnings) + unless (null errors) $ + notice verbosity + "Note: the public hackage server would reject this package." + +------------------------------------------------------------ + +-- | The name of the tarball without extension +-- +tarBallName :: PackageDescription -> String +tarBallName = prettyShow . packageId + +mapAllBuildInfo :: (BuildInfo -> BuildInfo) + -> (PackageDescription -> PackageDescription) +mapAllBuildInfo f pkg = pkg { + library = fmap mapLibBi (library pkg), + subLibraries = fmap mapLibBi (subLibraries pkg), + foreignLibs = fmap mapFLibBi (foreignLibs pkg), + executables = fmap mapExeBi (executables pkg), + testSuites = fmap mapTestBi (testSuites pkg), + benchmarks = fmap mapBenchBi (benchmarks pkg) + } + where + mapLibBi lib = lib { libBuildInfo = f (libBuildInfo lib) } + mapFLibBi flib = flib { foreignLibBuildInfo = f (foreignLibBuildInfo flib) } + mapExeBi exe = exe { buildInfo = f (buildInfo exe) } + mapTestBi tst = tst { testBuildInfo = f (testBuildInfo tst) } + mapBenchBi bm = bm { benchmarkBuildInfo = f (benchmarkBuildInfo bm) } diff --git a/cabal/Cabal/src/Distribution/Simple/Test.hs b/cabal/Cabal/src/Distribution/Simple/Test.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/Test.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Test +-- Copyright : Thomas Tuegel 2010 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is the entry point into testing a built package. It performs the +-- \"@.\/setup test@\" action. It runs test suites designated in the package +-- description and reports on the results. + +module Distribution.Simple.Test + ( test + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Types.UnqualComponentName +import qualified Distribution.PackageDescription as PD +import Distribution.Simple.Compiler +import Distribution.Simple.Hpc +import Distribution.Simple.InstallDirs +import qualified Distribution.Simple.LocalBuildInfo as LBI +import qualified Distribution.Types.LocalBuildInfo as LBI +import Distribution.Simple.Setup +import Distribution.Simple.UserHooks +import qualified Distribution.Simple.Test.ExeV10 as ExeV10 +import qualified Distribution.Simple.Test.LibV09 as LibV09 +import Distribution.Simple.Test.Log +import Distribution.Simple.Utils +import Distribution.TestSuite +import Distribution.Pretty + +import System.Directory + ( createDirectoryIfMissing, doesFileExist, getDirectoryContents + , removeFile ) +import System.FilePath ( () ) + +-- |Perform the \"@.\/setup test@\" action. +test :: Args -- ^positional command-line arguments + -> PD.PackageDescription -- ^information from the .cabal file + -> LBI.LocalBuildInfo -- ^information from the configure step + -> TestFlags -- ^flags sent to test + -> IO () +test args pkg_descr lbi flags = do + let verbosity = fromFlag $ testVerbosity flags + machineTemplate = fromFlag $ testMachineLog flags + distPref = fromFlag $ testDistPref flags + testLogDir = distPref "test" + testNames = args + pkgTests = PD.testSuites pkg_descr + enabledTests = LBI.enabledTestLBIs pkg_descr lbi + + doTest :: ((PD.TestSuite, LBI.ComponentLocalBuildInfo), + Maybe TestSuiteLog) -> IO TestSuiteLog + doTest ((suite, clbi), _) = + case PD.testInterface suite of + PD.TestSuiteExeV10 _ _ -> + ExeV10.runTest pkg_descr lbi clbi flags suite + + PD.TestSuiteLibV09 _ _ -> + LibV09.runTest pkg_descr lbi clbi flags suite + + _ -> return TestSuiteLog + { testSuiteName = PD.testName suite + , testLogs = TestLog + { testName = unUnqualComponentName $ PD.testName suite + , testOptionsReturned = [] + , testResult = + Error $ "No support for running test suite type: " + ++ show (pretty $ PD.testType suite) + } + , logFile = "" + } + + unless (PD.hasTests pkg_descr) $ do + notice verbosity "Package has no test suites." + exitSuccess + + when (PD.hasTests pkg_descr && null enabledTests) $ + die' verbosity $ + "No test suites enabled. Did you remember to configure with " + ++ "\'--enable-tests\'?" + + testsToRun <- case testNames of + [] -> return $ zip enabledTests $ repeat Nothing + names -> for names $ \tName -> + let testMap = zip enabledNames enabledTests + enabledNames = map (PD.testName . fst) enabledTests + allNames = map PD.testName pkgTests + tCompName = mkUnqualComponentName tName + in case lookup tCompName testMap of + Just t -> return (t, Nothing) + _ | tCompName `elem` allNames -> + die' verbosity $ "Package configured with test suite " + ++ tName ++ " disabled." + | otherwise -> die' verbosity $ "no such test: " ++ tName + + createDirectoryIfMissing True testLogDir + + -- Delete ordinary files from test log directory. + getDirectoryContents testLogDir + >>= filterM doesFileExist . map (testLogDir ) + >>= traverse_ removeFile + + let totalSuites = length testsToRun + notice verbosity $ "Running " ++ show totalSuites ++ " test suites..." + suites <- traverse doTest testsToRun + let packageLog = (localPackageLog pkg_descr lbi) { testSuites = suites } + packageLogFile = () testLogDir + $ packageLogPath machineTemplate pkg_descr lbi + allOk <- summarizePackage verbosity packageLog + writeFile packageLogFile $ show packageLog + + when (LBI.testCoverage lbi) $ + markupPackage verbosity lbi distPref pkg_descr $ + map (fst . fst) testsToRun + + unless allOk exitFailure + +packageLogPath :: PathTemplate + -> PD.PackageDescription + -> LBI.LocalBuildInfo + -> FilePath +packageLogPath template pkg_descr lbi = + fromPathTemplate $ substPathTemplate env template + where + env = initialPathTemplateEnv + (PD.package pkg_descr) (LBI.localUnitId lbi) + (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) diff --git a/cabal/Cabal/src/Distribution/Simple/Test/ExeV10.hs b/cabal/Cabal/src/Distribution/Simple/Test/ExeV10.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/Test/ExeV10.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +module Distribution.Simple.Test.ExeV10 + ( runTest + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Types.UnqualComponentName +import Distribution.Compat.Environment +import qualified Distribution.PackageDescription as PD +import Distribution.Simple.Build.PathsModule +import Distribution.Simple.BuildPaths +import Distribution.Simple.Compiler +import Distribution.Simple.Hpc +import Distribution.Simple.InstallDirs +import qualified Distribution.Simple.LocalBuildInfo as LBI +import qualified Distribution.Types.LocalBuildInfo as LBI +import Distribution.Simple.Setup +import Distribution.Simple.Test.Log +import Distribution.Simple.Utils +import Distribution.System +import Distribution.TestSuite +import Distribution.Pretty +import Distribution.Verbosity + +import System.Directory + ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist + , getCurrentDirectory, removeDirectoryRecursive ) +import System.FilePath ( (), (<.>) ) +import System.IO ( stdout, stderr ) +import System.Process ( createPipe ) + +import qualified Data.ByteString.Lazy as LBS + +runTest :: PD.PackageDescription + -> LBI.LocalBuildInfo + -> LBI.ComponentLocalBuildInfo + -> TestFlags + -> PD.TestSuite + -> IO TestSuiteLog +runTest pkg_descr lbi clbi flags suite = do + let isCoverageEnabled = LBI.testCoverage lbi + way = guessWay lbi + tixDir_ = tixDir distPref way testName' + + pwd <- getCurrentDirectory + existingEnv <- getEnvironment + + let cmd = LBI.buildDir lbi testName' + testName' <.> exeExtension (LBI.hostPlatform lbi) + -- Check that the test executable exists. + exists <- doesFileExist cmd + unless exists $ die' verbosity $ "Could not find test program \"" ++ cmd + ++ "\". Did you build the package first?" + + -- Remove old .tix files if appropriate. + unless (fromFlag $ testKeepTix flags) $ do + exists' <- doesDirectoryExist tixDir_ + when exists' $ removeDirectoryRecursive tixDir_ + + -- Create directory for HPC files. + createDirectoryIfMissing True tixDir_ + + -- Write summary notices indicating start of test suite + notice verbosity $ summarizeSuiteStart $ testName' + + + -- Run the test executable + let opts = map (testOption pkg_descr lbi suite) + (testOptions flags) + dataDirPath = pwd PD.dataDir pkg_descr + tixFile = pwd tixFilePath distPref way (testName') + pkgPathEnv = (pkgPathEnvVar pkg_descr "datadir", dataDirPath) + : existingEnv + shellEnv = [("HPCTIXFILE", tixFile) | isCoverageEnabled] ++ pkgPathEnv + + -- Add (DY)LD_LIBRARY_PATH if needed + shellEnv' <- if LBI.withDynExe lbi + then do let (Platform _ os) = LBI.hostPlatform lbi + paths <- LBI.depLibraryPaths True False lbi clbi + return (addLibraryPath os paths shellEnv) + else return shellEnv + + -- Output logger + (wOut, wErr, getLogText) <- case details of + Direct -> return (stdout, stderr, return LBS.empty) + _ -> do + (rOut, wOut) <- createPipe + + return $ (,,) wOut wOut $ do + -- Read test executables' output + logText <- LBS.hGetContents rOut + + -- '--show-details=streaming': print the log output in another thread + when (details == Streaming) $ LBS.putStr logText + + -- drain the output. + evaluate (force logText) + + (exit, logText) <- case testWrapper flags of + Flag path -> rawSystemIOWithEnvAndAction + verbosity path (cmd:opts) Nothing (Just shellEnv') + getLogText + -- these handles are automatically closed + Nothing (Just wOut) (Just wErr) + + NoFlag -> rawSystemIOWithEnvAndAction + verbosity cmd opts Nothing (Just shellEnv') + getLogText + -- these handles are automatically closed + Nothing (Just wOut) (Just wErr) + + -- Generate TestSuiteLog from executable exit code and a machine- + -- readable test log. + let suiteLog = buildLog exit + + -- Write summary notice to log file indicating start of test suite + appendFile (logFile suiteLog) $ summarizeSuiteStart testName' + + -- Append contents of temporary log file to the final human- + -- readable log file + LBS.appendFile (logFile suiteLog) logText + + -- Write end-of-suite summary notice to log file + appendFile (logFile suiteLog) $ summarizeSuiteFinish suiteLog + + -- Show the contents of the human-readable log file on the terminal + -- if there is a failure and/or detailed output is requested + let whenPrinting = when $ + ( details == Always || + details == Failures && not (suitePassed $ testLogs suiteLog)) + -- verbosity overrides show-details + && verbosity >= normal + whenPrinting $ do + LBS.putStr logText + putChar '\n' + + -- Write summary notice to terminal indicating end of test suite + notice verbosity $ summarizeSuiteFinish suiteLog + + when isCoverageEnabled $ + case PD.library pkg_descr of + Nothing -> + die' verbosity "Test coverage is only supported for packages with a library component." + + Just library -> + markupTest verbosity lbi distPref (prettyShow $ PD.package pkg_descr) suite library + + return suiteLog + where + testName' = unUnqualComponentName $ PD.testName suite + + distPref = fromFlag $ testDistPref flags + verbosity = fromFlag $ testVerbosity flags + details = fromFlag $ testShowDetails flags + testLogDir = distPref "test" + + buildLog exit = + let r = case exit of + ExitSuccess -> Pass + ExitFailure c -> Fail $ "exit code: " ++ show c + --n = unUnqualComponentName $ PD.testName suite + l = TestLog + { testName = testName' + , testOptionsReturned = [] + , testResult = r + } + in TestSuiteLog + { testSuiteName = PD.testName suite + , testLogs = l + , logFile = + testLogDir + testSuiteLogPath (fromFlag $ testHumanLog flags) + pkg_descr lbi testName' l + } + +-- TODO: This is abusing the notion of a 'PathTemplate'. The result isn't +-- necessarily a path. +testOption :: PD.PackageDescription + -> LBI.LocalBuildInfo + -> PD.TestSuite + -> PathTemplate + -> String +testOption pkg_descr lbi suite template = + fromPathTemplate $ substPathTemplate env template + where + env = initialPathTemplateEnv + (PD.package pkg_descr) (LBI.localUnitId lbi) + (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) ++ + [(TestSuiteNameVar, toPathTemplate $ unUnqualComponentName $ PD.testName suite)] diff --git a/cabal/Cabal/src/Distribution/Simple/Test/LibV09.hs b/cabal/Cabal/src/Distribution/Simple/Test/LibV09.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/Test/LibV09.hs @@ -0,0 +1,290 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +module Distribution.Simple.Test.LibV09 + ( runTest + -- Test stub + , simpleTestStub + , stubFilePath, stubMain, stubName, stubWriteLog + , writeSimpleTestStub + ) where + +import Prelude () +import Distribution.Compat.Prelude +import Distribution.Types.UnqualComponentName + +import Distribution.Compat.Environment +import Distribution.Compat.Internal.TempFile +import Distribution.ModuleName +import qualified Distribution.PackageDescription as PD +import Distribution.Simple.Build.PathsModule +import Distribution.Simple.BuildPaths +import Distribution.Simple.Compiler +import Distribution.Simple.Hpc +import Distribution.Simple.InstallDirs +import qualified Distribution.Simple.LocalBuildInfo as LBI +import qualified Distribution.Types.LocalBuildInfo as LBI +import Distribution.Simple.Setup +import Distribution.Simple.Test.Log +import Distribution.Simple.Utils +import Distribution.System +import Distribution.TestSuite +import Distribution.Pretty +import Distribution.Verbosity + +import qualified Control.Exception as CE +import qualified Data.ByteString.Lazy as LBS +import System.Directory + ( createDirectoryIfMissing, canonicalizePath + , doesDirectoryExist, doesFileExist + , getCurrentDirectory, removeDirectoryRecursive, removeFile + , setCurrentDirectory ) +import System.FilePath ( (), (<.>) ) +import System.IO ( hClose, hPutStr ) +import System.Process (StdStream(..), createPipe, waitForProcess) + +runTest :: PD.PackageDescription + -> LBI.LocalBuildInfo + -> LBI.ComponentLocalBuildInfo + -> TestFlags + -> PD.TestSuite + -> IO TestSuiteLog +runTest pkg_descr lbi clbi flags suite = do + let isCoverageEnabled = LBI.testCoverage lbi + way = guessWay lbi + + pwd <- getCurrentDirectory + existingEnv <- getEnvironment + + let cmd = LBI.buildDir lbi stubName suite + stubName suite <.> exeExtension (LBI.hostPlatform lbi) + -- Check that the test executable exists. + exists <- doesFileExist cmd + unless exists $ + die' verbosity $ "Could not find test program \"" ++ cmd + ++ "\". Did you build the package first?" + + -- Remove old .tix files if appropriate. + unless (fromFlag $ testKeepTix flags) $ do + let tDir = tixDir distPref way testName' + exists' <- doesDirectoryExist tDir + when exists' $ removeDirectoryRecursive tDir + + -- Create directory for HPC files. + createDirectoryIfMissing True $ tixDir distPref way testName' + + -- Write summary notices indicating start of test suite + notice verbosity $ summarizeSuiteStart testName' + + suiteLog <- CE.bracket openCabalTemp deleteIfExists $ \tempLog -> do + + -- TODO: this setup is broken, + -- if the test output is too big, we will deadlock. + (rOut, wOut) <- createPipe + + -- Run test executable + (Just wIn, _, _, process) <- do + let opts = map (testOption pkg_descr lbi suite) $ testOptions flags + dataDirPath = pwd PD.dataDir pkg_descr + tixFile = pwd tixFilePath distPref way testName' + pkgPathEnv = (pkgPathEnvVar pkg_descr "datadir", dataDirPath) + : existingEnv + shellEnv = [("HPCTIXFILE", tixFile) | isCoverageEnabled] + ++ pkgPathEnv + -- Add (DY)LD_LIBRARY_PATH if needed + shellEnv' <- + if LBI.withDynExe lbi + then do + let (Platform _ os) = LBI.hostPlatform lbi + paths <- LBI.depLibraryPaths True False lbi clbi + cpath <- canonicalizePath $ LBI.componentBuildDir lbi clbi + return (addLibraryPath os (cpath : paths) shellEnv) + else return shellEnv + case testWrapper flags of + Flag path -> createProcessWithEnv verbosity path (cmd:opts) Nothing (Just shellEnv') + -- these handles are closed automatically + CreatePipe (UseHandle wOut) (UseHandle wOut) + + NoFlag -> createProcessWithEnv verbosity cmd opts Nothing (Just shellEnv') + -- these handles are closed automatically + CreatePipe (UseHandle wOut) (UseHandle wOut) + + hPutStr wIn $ show (tempLog, PD.testName suite) + hClose wIn + + -- Append contents of temporary log file to the final human- + -- readable log file + logText <- LBS.hGetContents rOut + -- Force the IO manager to drain the test output pipe + _ <- evaluate (force logText) + + exitcode <- waitForProcess process + unless (exitcode == ExitSuccess) $ do + debug verbosity $ cmd ++ " returned " ++ show exitcode + + -- Generate final log file name + let finalLogName l = testLogDir + testSuiteLogPath + (fromFlag $ testHumanLog flags) pkg_descr lbi + (unUnqualComponentName $ testSuiteName l) (testLogs l) + -- Generate TestSuiteLog from executable exit code and a machine- + -- readable test log + suiteLog <- fmap (\s -> (\l -> l { logFile = finalLogName l }) + . fromMaybe (error $ "panic! read @TestSuiteLog " ++ show s) $ readMaybe s) -- TODO: eradicateNoParse + $ readFile tempLog + + -- Write summary notice to log file indicating start of test suite + appendFile (logFile suiteLog) $ summarizeSuiteStart testName' + + LBS.appendFile (logFile suiteLog) logText + + -- Write end-of-suite summary notice to log file + appendFile (logFile suiteLog) $ summarizeSuiteFinish suiteLog + + -- Show the contents of the human-readable log file on the terminal + -- if there is a failure and/or detailed output is requested + let details = fromFlag $ testShowDetails flags + whenPrinting = when $ (details > Never) + && (not (suitePassed $ testLogs suiteLog) || details == Always) + && verbosity >= normal + whenPrinting $ do + LBS.putStr logText + putChar '\n' + + return suiteLog + + -- Write summary notice to terminal indicating end of test suite + notice verbosity $ summarizeSuiteFinish suiteLog + + when isCoverageEnabled $ + case PD.library pkg_descr of + Nothing -> + die' verbosity "Test coverage is only supported for packages with a library component." + Just library -> + markupTest verbosity lbi distPref (prettyShow $ PD.package pkg_descr) suite library + + return suiteLog + where + testName' = unUnqualComponentName $ PD.testName suite + + deleteIfExists file = do + exists <- doesFileExist file + when exists $ removeFile file + + testLogDir = distPref "test" + openCabalTemp = do + (f, h) <- openTempFile testLogDir $ "cabal-test-" <.> "log" + hClose h >> return f + + distPref = fromFlag $ testDistPref flags + verbosity = fromFlag $ testVerbosity flags + +-- TODO: This is abusing the notion of a 'PathTemplate'. The result isn't +-- necessarily a path. +testOption :: PD.PackageDescription + -> LBI.LocalBuildInfo + -> PD.TestSuite + -> PathTemplate + -> String +testOption pkg_descr lbi suite template = + fromPathTemplate $ substPathTemplate env template + where + env = initialPathTemplateEnv + (PD.package pkg_descr) (LBI.localUnitId lbi) + (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) ++ + [(TestSuiteNameVar, toPathTemplate $ unUnqualComponentName $ PD.testName suite)] + +-- Test stub ---------- + +-- | The name of the stub executable associated with a library 'TestSuite'. +stubName :: PD.TestSuite -> FilePath +stubName t = unUnqualComponentName (PD.testName t) ++ "Stub" + +-- | The filename of the source file for the stub executable associated with a +-- library 'TestSuite'. +stubFilePath :: PD.TestSuite -> FilePath +stubFilePath t = stubName t <.> "hs" + +-- | Write the source file for a library 'TestSuite' stub executable. +writeSimpleTestStub :: PD.TestSuite -- ^ library 'TestSuite' for which a stub + -- is being created + -> FilePath -- ^ path to directory where stub source + -- should be located + -> IO () +writeSimpleTestStub t dir = do + createDirectoryIfMissing True dir + let filename = dir stubFilePath t + m = case PD.testInterface t of + PD.TestSuiteLibV09 _ m' -> m' + _ -> error "writeSimpleTestStub: invalid TestSuite passed" + writeFile filename $ simpleTestStub m + +-- | Source code for library test suite stub executable +simpleTestStub :: ModuleName -> String +simpleTestStub m = unlines + [ "module Main ( main ) where" + , "import Distribution.Simple.Test.LibV09 ( stubMain )" + , "import " ++ show (pretty m) ++ " ( tests )" + , "main :: IO ()" + , "main = stubMain tests" + ] + +-- | Main function for test stubs. Once, it was written directly into the stub, +-- but minimizing the amount of code actually in the stub maximizes the number +-- of detectable errors when Cabal is compiled. +stubMain :: IO [Test] -> IO () +stubMain tests = do + (f, n) <- fmap (\s -> fromMaybe (error $ "panic! read " ++ show s) $ readMaybe s) getContents -- TODO: eradicateNoParse + dir <- getCurrentDirectory + results <- (tests >>= stubRunTests) `CE.catch` errHandler + setCurrentDirectory dir + stubWriteLog f n results + where + errHandler :: CE.SomeException -> IO TestLogs + errHandler e = case CE.fromException e of + Just CE.UserInterrupt -> CE.throwIO e + _ -> return $ TestLog { testName = "Cabal test suite exception", + testOptionsReturned = [], + testResult = Error $ show e } + +-- | The test runner used in library "TestSuite" stub executables. Runs a list +-- of 'Test's. An executable calling this function is meant to be invoked as +-- the child of a Cabal process during @.\/setup test@. A 'TestSuiteLog', +-- provided by Cabal, is read from the standard input; it supplies the name of +-- the test suite and the location of the machine-readable test suite log file. +-- Human-readable log information is written to the standard output for capture +-- by the calling Cabal process. +stubRunTests :: [Test] -> IO TestLogs +stubRunTests tests = do + logs <- traverse stubRunTests' tests + return $ GroupLogs "Default" logs + where + stubRunTests' (Test t) = do + l <- run t >>= finish + summarizeTest normal Always l + return l + where + finish (Finished result) = + return TestLog + { testName = name t + , testOptionsReturned = defaultOptions t + , testResult = result + } + finish (Progress _ next) = next >>= finish + stubRunTests' g@(Group {}) = do + logs <- traverse stubRunTests' $ groupTests g + return $ GroupLogs (groupName g) logs + stubRunTests' (ExtraOptions _ t) = stubRunTests' t + maybeDefaultOption opt = + maybe Nothing (\d -> Just (optionName opt, d)) $ optionDefault opt + defaultOptions testInst = mapMaybe maybeDefaultOption $ options testInst + +-- | From a test stub, write the 'TestSuiteLog' to temporary file for the calling +-- Cabal process to read. +stubWriteLog :: FilePath -> UnqualComponentName -> TestLogs -> IO () +stubWriteLog f n logs = do + let testLog = TestSuiteLog { testSuiteName = n, testLogs = logs, logFile = f } + writeFile (logFile testLog) $ show testLog + when (suiteError logs) $ exitWith $ ExitFailure 2 + when (suiteFailed logs) $ exitWith $ ExitFailure 1 + exitSuccess diff --git a/cabal/Cabal/src/Distribution/Simple/Test/Log.hs b/cabal/Cabal/src/Distribution/Simple/Test/Log.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/Test/Log.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +module Distribution.Simple.Test.Log + ( PackageLog(..) + , TestLogs(..) + , TestSuiteLog(..) + , countTestResults + , localPackageLog + , summarizePackage + , summarizeSuiteFinish, summarizeSuiteStart + , summarizeTest + , suiteError, suiteFailed, suitePassed + , testSuiteLogPath + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Package +import Distribution.Types.UnqualComponentName +import qualified Distribution.PackageDescription as PD +import Distribution.Simple.Compiler +import Distribution.Simple.InstallDirs +import qualified Distribution.Simple.LocalBuildInfo as LBI +import Distribution.Simple.Setup +import Distribution.Simple.Utils +import Distribution.System +import Distribution.TestSuite +import Distribution.Verbosity +import Distribution.Pretty + +import qualified Prelude (foldl1) + +-- | Logs all test results for a package, broken down first by test suite and +-- then by test case. +data PackageLog = PackageLog + { package :: PackageId + , compiler :: CompilerId + , platform :: Platform + , testSuites :: [TestSuiteLog] + } + deriving (Read, Show, Eq) + +-- | A 'PackageLog' with package and platform information specified. +localPackageLog :: PD.PackageDescription -> LBI.LocalBuildInfo -> PackageLog +localPackageLog pkg_descr lbi = PackageLog + { package = PD.package pkg_descr + , compiler = compilerId $ LBI.compiler lbi + , platform = LBI.hostPlatform lbi + , testSuites = [] + } + +-- | Logs test suite results, itemized by test case. +data TestSuiteLog = TestSuiteLog + { testSuiteName :: UnqualComponentName + , testLogs :: TestLogs + , logFile :: FilePath -- path to human-readable log file + } + deriving (Read, Show, Eq) + +data TestLogs + = TestLog + { testName :: String + , testOptionsReturned :: Options + , testResult :: Result + } + | GroupLogs String [TestLogs] + deriving (Read, Show, Eq) + +-- | Count the number of pass, fail, and error test results in a 'TestLogs' +-- tree. +countTestResults :: TestLogs + -> (Int, Int, Int) -- ^ Passes, fails, and errors, + -- respectively. +countTestResults = go (0, 0, 0) + where + go (p, f, e) (TestLog { testResult = r }) = + case r of + Pass -> (p + 1, f, e) + Fail _ -> (p, f + 1, e) + Error _ -> (p, f, e + 1) + go (p, f, e) (GroupLogs _ ts) = foldl go (p, f, e) ts + +-- | From a 'TestSuiteLog', determine if the test suite passed. +suitePassed :: TestLogs -> Bool +suitePassed l = + case countTestResults l of + (_, 0, 0) -> True + _ -> False + +-- | From a 'TestSuiteLog', determine if the test suite failed. +suiteFailed :: TestLogs -> Bool +suiteFailed l = + case countTestResults l of + (_, 0, _) -> False + _ -> True + +-- | From a 'TestSuiteLog', determine if the test suite encountered errors. +suiteError :: TestLogs -> Bool +suiteError l = + case countTestResults l of + (_, _, 0) -> False + _ -> True + +resultString :: TestLogs -> String +resultString l | suiteError l = "error" + | suiteFailed l = "fail" + | otherwise = "pass" + +testSuiteLogPath :: PathTemplate + -> PD.PackageDescription + -> LBI.LocalBuildInfo + -> String -- ^ test suite name + -> TestLogs -- ^ test suite results + -> FilePath +testSuiteLogPath template pkg_descr lbi test_name result = + fromPathTemplate $ substPathTemplate env template + where + env = initialPathTemplateEnv + (PD.package pkg_descr) (LBI.localUnitId lbi) + (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) + ++ [ (TestSuiteNameVar, toPathTemplate test_name) + , (TestSuiteResultVar, toPathTemplate $ resultString result) + ] + +-- | Print a summary to the console after all test suites have been run +-- indicating the number of successful test suites and cases. Returns 'True' if +-- all test suites passed and 'False' otherwise. +summarizePackage :: Verbosity -> PackageLog -> IO Bool +summarizePackage verbosity packageLog = do + let counts = map (countTestResults . testLogs) $ testSuites packageLog + (passed, failed, errors) = Prelude.foldl1 addTriple counts + totalCases = passed + failed + errors + passedSuites = length + $ filter (suitePassed . testLogs) + $ testSuites packageLog + totalSuites = length $ testSuites packageLog + notice verbosity $ show passedSuites ++ " of " ++ show totalSuites + ++ " test suites (" ++ show passed ++ " of " + ++ show totalCases ++ " test cases) passed." + return $! passedSuites == totalSuites + where + addTriple (p1, f1, e1) (p2, f2, e2) = (p1 + p2, f1 + f2, e1 + e2) + +-- | Print a summary of a single test case's result to the console, suppressing +-- output for certain verbosity or test filter levels. +summarizeTest :: Verbosity -> TestShowDetails -> TestLogs -> IO () +summarizeTest _ _ (GroupLogs {}) = return () +summarizeTest verbosity details t = + when shouldPrint $ notice verbosity $ "Test case " ++ testName t + ++ ": " ++ show (testResult t) + where shouldPrint = (details > Never) && (notPassed || details == Always) + notPassed = testResult t /= Pass + +-- | Print a summary of the test suite's results on the console, suppressing +-- output for certain verbosity or test filter levels. +summarizeSuiteFinish :: TestSuiteLog -> String +summarizeSuiteFinish testLog = unlines + [ "Test suite " ++ prettyShow (testSuiteName testLog) ++ ": " ++ resStr + , "Test suite logged to: " ++ logFile testLog + ] + where resStr = map toUpper (resultString $ testLogs testLog) + +summarizeSuiteStart :: String -> String +summarizeSuiteStart n = "Test suite " ++ n ++ ": RUNNING...\n" diff --git a/cabal/Cabal/src/Distribution/Simple/UHC.hs b/cabal/Cabal/src/Distribution/Simple/UHC.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/UHC.hs @@ -0,0 +1,296 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.UHC +-- Copyright : Andres Loeh 2009 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module contains most of the UHC-specific code for configuring, building +-- and installing packages. +-- +-- Thanks to the authors of the other implementation-specific files, in +-- particular to Isaac Jones, Duncan Coutts and Henning Thielemann, for +-- inspiration on how to design this module. + +module Distribution.Simple.UHC ( + configure, getInstalledPackages, + buildLib, buildExe, installLib, registerPackage, inplacePackageDbPath + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.InstalledPackageInfo +import Distribution.Package hiding (installedUnitId) +import Distribution.PackageDescription +import Distribution.Simple.BuildPaths +import Distribution.Simple.Compiler +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.PackageIndex +import Distribution.Simple.Program +import Distribution.Simple.Utils +import Distribution.Pretty +import Distribution.Parsec +import Distribution.Types.MungedPackageId +import Distribution.Verbosity +import Distribution.Version +import Distribution.System +import Language.Haskell.Extension +import Distribution.Utils.Path + +import qualified Data.Map as Map ( empty ) +import System.Directory +import System.FilePath + +-- ----------------------------------------------------------------------------- +-- Configuring + +configure :: Verbosity -> Maybe FilePath -> Maybe FilePath + -> ProgramDb -> IO (Compiler, Maybe Platform, ProgramDb) +configure verbosity hcPath _hcPkgPath progdb = do + + (_uhcProg, uhcVersion, progdb') <- + requireProgramVersion verbosity uhcProgram + (orLaterVersion (mkVersion [1,0,2])) + (userMaybeSpecifyPath "uhc" hcPath progdb) + + let comp = Compiler { + compilerId = CompilerId UHC uhcVersion, + compilerAbiTag = NoAbiTag, + compilerCompat = [], + compilerLanguages = uhcLanguages, + compilerExtensions = uhcLanguageExtensions, + compilerProperties = Map.empty + } + compPlatform = Nothing + return (comp, compPlatform, progdb') + +uhcLanguages :: [(Language, CompilerFlag)] +uhcLanguages = [(Haskell98, "")] + +-- | The flags for the supported extensions. +uhcLanguageExtensions :: [(Extension, Maybe CompilerFlag)] +uhcLanguageExtensions = + let doFlag (f, (enable, disable)) = [(EnableExtension f, enable), + (DisableExtension f, disable)] + alwaysOn = (Nothing, Nothing{- wrong -}) + in concatMap doFlag + [(CPP, (Just "--cpp", Nothing{- wrong -})), + (PolymorphicComponents, alwaysOn), + (ExistentialQuantification, alwaysOn), + (ForeignFunctionInterface, alwaysOn), + (UndecidableInstances, alwaysOn), + (MultiParamTypeClasses, alwaysOn), + (Rank2Types, alwaysOn), + (PatternSignatures, alwaysOn), + (EmptyDataDecls, alwaysOn), + (ImplicitPrelude, (Nothing, Just "--no-prelude"{- wrong -})), + (TypeOperators, alwaysOn), + (OverlappingInstances, alwaysOn), + (FlexibleInstances, alwaysOn)] + +getInstalledPackages :: Verbosity -> Compiler -> PackageDBStack -> ProgramDb + -> IO InstalledPackageIndex +getInstalledPackages verbosity comp packagedbs progdb = do + let compilerid = compilerId comp + systemPkgDir <- getGlobalPackageDir verbosity progdb + userPkgDir <- getUserPackageDir + let pkgDirs = nub (concatMap (packageDbPaths userPkgDir systemPkgDir) packagedbs) + -- putStrLn $ "pkgdirs: " ++ show pkgDirs + pkgs <- liftM (map addBuiltinVersions . concat) $ + traverse (\ d -> getDirectoryContents d >>= filterM (isPkgDir (prettyShow compilerid) d)) + pkgDirs + -- putStrLn $ "pkgs: " ++ show pkgs + let iPkgs = + map mkInstalledPackageInfo $ + concatMap parsePackage $ + pkgs + -- putStrLn $ "installed pkgs: " ++ show iPkgs + return (fromList iPkgs) + +getGlobalPackageDir :: Verbosity -> ProgramDb -> IO FilePath +getGlobalPackageDir verbosity progdb = do + output <- getDbProgramOutput verbosity + uhcProgram progdb ["--meta-pkgdir-system"] + -- we need to trim because pkgdir contains an extra newline at the end + let pkgdir = trimEnd output + return pkgdir + where + trimEnd = dropWhileEnd isSpace + +getUserPackageDir :: IO FilePath +getUserPackageDir = do + homeDir <- getHomeDirectory + return $ homeDir ".cabal" "lib" -- TODO: determine in some other way + +packageDbPaths :: FilePath -> FilePath -> PackageDB -> [FilePath] +packageDbPaths user system db = + case db of + GlobalPackageDB -> [ system ] + UserPackageDB -> [ user ] + SpecificPackageDB path -> [ path ] + +-- | Hack to add version numbers to UHC-built-in packages. This should sooner or +-- later be fixed on the UHC side. +addBuiltinVersions :: String -> String +{- +addBuiltinVersions "uhcbase" = "uhcbase-1.0" +addBuiltinVersions "base" = "base-3.0" +addBuiltinVersions "array" = "array-0.2" +-} +addBuiltinVersions xs = xs + +-- | Name of the installed package config file. +installedPkgConfig :: String +installedPkgConfig = "installed-pkg-config" + +-- | Check if a certain dir contains a valid package. Currently, we are +-- looking only for the presence of an installed package configuration. +-- TODO: Actually make use of the information provided in the file. +isPkgDir :: String -> String -> String -> IO Bool +isPkgDir _ _ ('.' : _) = return False -- ignore files starting with a . +isPkgDir c dir xs = do + let candidate = dir uhcPackageDir xs c + -- putStrLn $ "trying: " ++ candidate + doesFileExist (candidate installedPkgConfig) + +parsePackage :: String -> [PackageId] +parsePackage = toList . simpleParsec + +-- | Create a trivial package info from a directory name. +mkInstalledPackageInfo :: PackageId -> InstalledPackageInfo +mkInstalledPackageInfo p = emptyInstalledPackageInfo + { installedUnitId = mkLegacyUnitId p, + sourcePackageId = p } + + +-- ----------------------------------------------------------------------------- +-- Building + +buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Library -> ComponentLocalBuildInfo -> IO () +buildLib verbosity pkg_descr lbi lib clbi = do + + systemPkgDir <- getGlobalPackageDir verbosity (withPrograms lbi) + userPkgDir <- getUserPackageDir + let runUhcProg = runDbProgram verbosity uhcProgram (withPrograms lbi) + let uhcArgs = -- set package name + ["--pkg-build=" ++ prettyShow (packageId pkg_descr)] + -- common flags lib/exe + ++ constructUHCCmdLine userPkgDir systemPkgDir + lbi (libBuildInfo lib) clbi + (buildDir lbi) verbosity + -- source files + -- suboptimal: UHC does not understand module names, so + -- we replace periods by path separators + ++ map (map (\ c -> if c == '.' then pathSeparator else c)) + (map prettyShow (allLibModules lib clbi)) + + runUhcProg uhcArgs + + return () + +buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Executable -> ComponentLocalBuildInfo -> IO () +buildExe verbosity _pkg_descr lbi exe clbi = do + systemPkgDir <- getGlobalPackageDir verbosity (withPrograms lbi) + userPkgDir <- getUserPackageDir + let runUhcProg = runDbProgram verbosity uhcProgram (withPrograms lbi) + let uhcArgs = -- common flags lib/exe + constructUHCCmdLine userPkgDir systemPkgDir + lbi (buildInfo exe) clbi + (buildDir lbi) verbosity + -- output file + ++ ["--output", buildDir lbi prettyShow (exeName exe)] + -- main source module + ++ [modulePath exe] + runUhcProg uhcArgs + +constructUHCCmdLine :: FilePath -> FilePath + -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo + -> FilePath -> Verbosity -> [String] +constructUHCCmdLine user system lbi bi clbi odir verbosity = + -- verbosity + (if verbosity >= deafening then ["-v4"] + else if verbosity >= normal then [] + else ["-v0"]) + ++ hcOptions UHC bi + -- flags for language extensions + ++ languageToFlags (compiler lbi) (defaultLanguage bi) + ++ extensionsToFlags (compiler lbi) (usedExtensions bi) + -- packages + ++ ["--hide-all-packages"] + ++ uhcPackageDbOptions user system (withPackageDB lbi) + ++ ["--package=uhcbase"] + ++ ["--package=" ++ prettyShow (mungedName pkgid) | (_, pkgid) <- componentPackageDeps clbi ] + -- search paths + ++ ["-i" ++ odir] + ++ ["-i" ++ getSymbolicPath l | l <- nub (hsSourceDirs bi)] + ++ ["-i" ++ autogenComponentModulesDir lbi clbi] + ++ ["-i" ++ autogenPackageModulesDir lbi] + -- cpp options + ++ ["--optP=" ++ opt | opt <- cppOptions bi] + -- output path + ++ ["--odir=" ++ odir] + -- optimization + ++ (case withOptimization lbi of + NoOptimisation -> ["-O0"] + NormalOptimisation -> ["-O1"] + MaximumOptimisation -> ["-O2"]) + +uhcPackageDbOptions :: FilePath -> FilePath -> PackageDBStack -> [String] +uhcPackageDbOptions user system db = map (\ x -> "--pkg-searchpath=" ++ x) + (concatMap (packageDbPaths user system) db) + +-- ----------------------------------------------------------------------------- +-- Installation + +installLib :: Verbosity -> LocalBuildInfo + -> FilePath -> FilePath -> FilePath + -> PackageDescription -> Library -> ComponentLocalBuildInfo -> IO () +installLib verbosity _lbi targetDir _dynlibTargetDir builtDir pkg _library _clbi = do + -- putStrLn $ "dest: " ++ targetDir + -- putStrLn $ "built: " ++ builtDir + installDirectoryContents verbosity (builtDir prettyShow (packageId pkg)) targetDir + +-- currently hard-coded UHC code generator and variant to use +uhcTarget, uhcTargetVariant :: String +uhcTarget = "bc" +uhcTargetVariant = "plain" + +-- root directory for a package in UHC +uhcPackageDir :: String -> String -> FilePath +uhcPackageSubDir :: String -> FilePath +uhcPackageDir pkgid compilerid = pkgid uhcPackageSubDir compilerid +uhcPackageSubDir compilerid = compilerid uhcTarget uhcTargetVariant + +-- ----------------------------------------------------------------------------- +-- Registering + +registerPackage + :: Verbosity + -> Compiler + -> ProgramDb + -> PackageDBStack + -> InstalledPackageInfo + -> IO () +registerPackage verbosity comp progdb packageDbs installedPkgInfo = do + dbdir <- case registrationPackageDB packageDbs of + GlobalPackageDB -> getGlobalPackageDir verbosity progdb + UserPackageDB -> getUserPackageDir + SpecificPackageDB dir -> return dir + let pkgdir = dbdir uhcPackageDir (prettyShow pkgid) (prettyShow compilerid) + createDirectoryIfMissingVerbose verbosity True pkgdir + writeUTF8File (pkgdir installedPkgConfig) + (showInstalledPackageInfo installedPkgInfo) + where + pkgid = sourcePackageId installedPkgInfo + compilerid = compilerId comp + +inplacePackageDbPath :: LocalBuildInfo -> FilePath +inplacePackageDbPath lbi = buildDir lbi diff --git a/cabal/Cabal/src/Distribution/Simple/UserHooks.hs b/cabal/Cabal/src/Distribution/Simple/UserHooks.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/UserHooks.hs @@ -0,0 +1,197 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.UserHooks +-- Copyright : Isaac Jones 2003-2005 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This defines the API that @Setup.hs@ scripts can use to customise the way +-- the build works. This module just defines the 'UserHooks' type. The +-- predefined sets of hooks that implement the @Simple@, @Make@ and @Configure@ +-- build systems are defined in "Distribution.Simple". The 'UserHooks' is a big +-- record of functions. There are 3 for each action, a pre, post and the action +-- itself. There are few other miscellaneous hooks, ones to extend the set of +-- programs and preprocessors and one to override the function used to read the +-- @.cabal@ file. +-- +-- This hooks type is widely agreed to not be the right solution. Partly this +-- is because changes to it usually break custom @Setup.hs@ files and yet many +-- internal code changes do require changes to the hooks. For example we cannot +-- pass any extra parameters to most of the functions that implement the +-- various phases because it would involve changing the types of the +-- corresponding hook. At some point it will have to be replaced. + +module Distribution.Simple.UserHooks ( + UserHooks(..), Args, + emptyUserHooks, + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.PackageDescription +import Distribution.Simple.Program +import Distribution.Simple.Command +import Distribution.Simple.PreProcess +import Distribution.Simple.Setup +import Distribution.Simple.LocalBuildInfo + +type Args = [String] + +-- | Hooks allow authors to add specific functionality before and after a +-- command is run, and also to specify additional preprocessors. +-- +-- * WARNING: The hooks interface is under rather constant flux as we try to +-- understand users needs. Setup files that depend on this interface may +-- break in future releases. +data UserHooks = UserHooks { + + -- | Read the description file + readDesc :: IO (Maybe GenericPackageDescription), + -- | Custom preprocessors in addition to and overriding 'knownSuffixHandlers'. + hookedPreProcessors :: [ PPSuffixHandler ], + -- | These programs are detected at configure time. Arguments for them are + -- added to the configure command. + hookedPrograms :: [Program], + + -- |Hook to run before configure command + preConf :: Args -> ConfigFlags -> IO HookedBuildInfo, + -- |Over-ride this hook to get different behavior during configure. + confHook :: (GenericPackageDescription, HookedBuildInfo) + -> ConfigFlags -> IO LocalBuildInfo, + -- |Hook to run after configure command + postConf :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO (), + + -- |Hook to run before build command. Second arg indicates verbosity level. + preBuild :: Args -> BuildFlags -> IO HookedBuildInfo, + + -- |Over-ride this hook to get different behavior during build. + buildHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO (), + -- |Hook to run after build command. Second arg indicates verbosity level. + postBuild :: Args -> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO (), + + -- |Hook to run before repl command. Second arg indicates verbosity level. + preRepl :: Args -> ReplFlags -> IO HookedBuildInfo, + -- |Over-ride this hook to get different behavior during interpretation. + replHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> ReplFlags -> [String] -> IO (), + -- |Hook to run after repl command. Second arg indicates verbosity level. + postRepl :: Args -> ReplFlags -> PackageDescription -> LocalBuildInfo -> IO (), + + -- |Hook to run before clean command. Second arg indicates verbosity level. + preClean :: Args -> CleanFlags -> IO HookedBuildInfo, + -- |Over-ride this hook to get different behavior during clean. + cleanHook :: PackageDescription -> () -> UserHooks -> CleanFlags -> IO (), + -- |Hook to run after clean command. Second arg indicates verbosity level. + postClean :: Args -> CleanFlags -> PackageDescription -> () -> IO (), + + -- |Hook to run before copy command + preCopy :: Args -> CopyFlags -> IO HookedBuildInfo, + -- |Over-ride this hook to get different behavior during copy. + copyHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> CopyFlags -> IO (), + -- |Hook to run after copy command + postCopy :: Args -> CopyFlags -> PackageDescription -> LocalBuildInfo -> IO (), + + -- |Hook to run before install command + preInst :: Args -> InstallFlags -> IO HookedBuildInfo, + + -- |Over-ride this hook to get different behavior during install. + instHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> InstallFlags -> IO (), + -- |Hook to run after install command. postInst should be run + -- on the target, not on the build machine. + postInst :: Args -> InstallFlags -> PackageDescription -> LocalBuildInfo -> IO (), + + -- |Hook to run before register command + preReg :: Args -> RegisterFlags -> IO HookedBuildInfo, + -- |Over-ride this hook to get different behavior during registration. + regHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO (), + -- |Hook to run after register command + postReg :: Args -> RegisterFlags -> PackageDescription -> LocalBuildInfo -> IO (), + + -- |Hook to run before unregister command + preUnreg :: Args -> RegisterFlags -> IO HookedBuildInfo, + -- |Over-ride this hook to get different behavior during unregistration. + unregHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO (), + -- |Hook to run after unregister command + postUnreg :: Args -> RegisterFlags -> PackageDescription -> LocalBuildInfo -> IO (), + + -- |Hook to run before hscolour command. Second arg indicates verbosity level. + preHscolour :: Args -> HscolourFlags -> IO HookedBuildInfo, + -- |Over-ride this hook to get different behavior during hscolour. + hscolourHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> HscolourFlags -> IO (), + -- |Hook to run after hscolour command. Second arg indicates verbosity level. + postHscolour :: Args -> HscolourFlags -> PackageDescription -> LocalBuildInfo -> IO (), + + -- |Hook to run before haddock command. Second arg indicates verbosity level. + preHaddock :: Args -> HaddockFlags -> IO HookedBuildInfo, + -- |Over-ride this hook to get different behavior during haddock. + haddockHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> HaddockFlags -> IO (), + -- |Hook to run after haddock command. Second arg indicates verbosity level. + postHaddock :: Args -> HaddockFlags -> PackageDescription -> LocalBuildInfo -> IO (), + + -- |Hook to run before test command. + preTest :: Args -> TestFlags -> IO HookedBuildInfo, + -- |Over-ride this hook to get different behavior during test. + testHook :: Args -> PackageDescription -> LocalBuildInfo -> UserHooks -> TestFlags -> IO (), + -- |Hook to run after test command. + postTest :: Args -> TestFlags -> PackageDescription -> LocalBuildInfo -> IO (), + + -- |Hook to run before bench command. + preBench :: Args -> BenchmarkFlags -> IO HookedBuildInfo, + -- |Over-ride this hook to get different behavior during bench. + benchHook :: Args -> PackageDescription -> LocalBuildInfo -> UserHooks -> BenchmarkFlags -> IO (), + -- |Hook to run after bench command. + postBench :: Args -> BenchmarkFlags -> PackageDescription -> LocalBuildInfo -> IO () + } + +-- |Empty 'UserHooks' which do nothing. +emptyUserHooks :: UserHooks +emptyUserHooks + = UserHooks { + readDesc = return Nothing, + hookedPreProcessors = [], + hookedPrograms = [], + preConf = rn', + confHook = (\_ _ -> return (error "No local build info generated during configure. Over-ride empty configure hook.")), + postConf = ru, + preBuild = rn', + buildHook = ru, + postBuild = ru, + preRepl = \_ _ -> return emptyHookedBuildInfo, + replHook = \_ _ _ _ _ -> return (), + postRepl = ru, + preClean = rn, + cleanHook = ru, + postClean = ru, + preCopy = rn', + copyHook = ru, + postCopy = ru, + preInst = rn, + instHook = ru, + postInst = ru, + preReg = rn', + regHook = ru, + postReg = ru, + preUnreg = rn, + unregHook = ru, + postUnreg = ru, + preHscolour = rn, + hscolourHook = ru, + postHscolour = ru, + preHaddock = rn', + haddockHook = ru, + postHaddock = ru, + preTest = rn', + testHook = \_ -> ru, + postTest = ru, + preBench = rn', + benchHook = \_ -> ru, + postBench = ru + } + where rn args _ = noExtraFlags args >> return emptyHookedBuildInfo + rn' _ _ = return emptyHookedBuildInfo + ru _ _ _ _ = return () diff --git a/cabal/Cabal/src/Distribution/Simple/Utils.hs b/cabal/Cabal/src/Distribution/Simple/Utils.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Simple/Utils.hs @@ -0,0 +1,1593 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoMonoLocalBinds #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Utils +-- Copyright : Isaac Jones, Simon Marlow 2003-2004 +-- License : BSD3 +-- portions Copyright (c) 2007, Galois Inc. +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- A large and somewhat miscellaneous collection of utility functions used +-- throughout the rest of the Cabal lib and in other tools that use the Cabal +-- lib like @cabal-install@. It has a very simple set of logging actions. It +-- has low level functions for running programs, a bunch of wrappers for +-- various directory and file functions that do extra logging. + +module Distribution.Simple.Utils ( + cabalVersion, + + -- * logging and errors + dieNoVerbosity, + die', dieWithLocation', + dieNoWrap, + topHandler, topHandlerWith, + warn, + notice, noticeNoWrap, noticeDoc, + setupMessage, + info, infoNoWrap, + debug, debugNoWrap, + chattyTry, + annotateIO, + printRawCommandAndArgs, printRawCommandAndArgsAndEnv, + withOutputMarker, + + -- * exceptions + handleDoesNotExist, + ignoreSigPipe, + + -- * running programs + rawSystemExit, + rawSystemExitCode, + rawSystemExitWithEnv, + rawSystemStdout, + rawSystemStdInOut, + rawSystemIOWithEnv, + rawSystemIOWithEnvAndAction, + createProcessWithEnv, + maybeExit, + xargs, + findProgramVersion, + + -- ** 'IOData' re-export + -- + -- These types are re-exported from + -- "Distribution.Utils.IOData" for convenience as they're + -- exposed in the API of 'rawSystemStdInOut' + IOData(..), + KnownIODataMode (..), + IODataMode (..), + + -- * copying files + createDirectoryIfMissingVerbose, + copyFileVerbose, + copyFiles, + copyFileTo, + + -- * installing files + installOrdinaryFile, + installExecutableFile, + installMaybeExecutableFile, + installOrdinaryFiles, + installExecutableFiles, + installMaybeExecutableFiles, + installDirectoryContents, + copyDirectoryRecursive, + + -- * File permissions + doesExecutableExist, + setFileOrdinary, + setFileExecutable, + + -- * file names + currentDir, + shortRelativePath, + dropExeExtension, + exeExtensions, + + -- * finding files + findFileEx, + findFileCwd, + findFirstFile, + findFileWithExtension, + findFileCwdWithExtension, + findFileWithExtension', + findAllFilesWithExtension, + findAllFilesCwdWithExtension, + findModuleFileEx, + findModuleFilesEx, + getDirectoryContentsRecursive, + + -- * environment variables + isInSearchPath, + addLibraryPath, + + -- * modification time + moreRecentFile, + existsAndIsMoreRecentThan, + + -- * temp files and dirs + TempFileOptions(..), defaultTempFileOptions, + withTempFile, withTempFileEx, + withTempDirectory, withTempDirectoryEx, + createTempDirectory, + + -- * .cabal and .buildinfo files + defaultPackageDesc, + findPackageDesc, + findPackageDescCwd, + tryFindPackageDesc, + tryFindPackageDescCwd, + findHookedPackageDesc, + + -- * reading and writing files safely + withFileContents, + writeFileAtomic, + rewriteFileEx, + rewriteFileLBS, + + -- * Unicode + fromUTF8BS, + fromUTF8LBS, + toUTF8BS, + toUTF8LBS, + readUTF8File, + withUTF8FileContents, + writeUTF8File, + normaliseLineEndings, + + -- * BOM + ignoreBOM, + + -- * generic utils + dropWhileEndLE, + takeWhileEndLE, + equating, + comparing, + isInfixOf, + intercalate, + lowercase, + listUnion, + listUnionRight, + ordNub, + ordNubBy, + ordNubRight, + safeHead, + safeTail, + safeLast, + safeInit, + unintersperse, + wrapText, + wrapLine, + + -- * FilePath stuff + isAbsoluteOnAnyPlatform, + isRelativeOnAnyPlatform, + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Utils.Generic +import Distribution.Utils.IOData (IOData(..), IODataMode (..), KnownIODataMode (..)) +import qualified Distribution.Utils.IOData as IOData +import Distribution.ModuleName as ModuleName +import Distribution.System +import Distribution.Version +import Distribution.Compat.Async +import Distribution.Compat.CopyFile +import Distribution.Compat.FilePath as FilePath +import Distribution.Compat.Internal.TempFile +import Distribution.Compat.Lens (Lens', over) +import Distribution.Compat.Stack +import Distribution.Verbosity +import Distribution.Types.PackageId + +#ifdef CURRENT_PACKAGE_KEY +#define BOOTSTRAPPED_CABAL 1 +#endif + +#ifdef BOOTSTRAPPED_CABAL +import qualified Paths_Cabal (version) +#endif + +import Distribution.Pretty +import Distribution.Parsec + +import Data.Typeable + ( cast ) +import qualified Data.ByteString.Lazy as BS + +import System.Directory + ( Permissions(executable), getDirectoryContents, getPermissions + , doesDirectoryExist, doesFileExist, removeFile + , getModificationTime, createDirectory, removeDirectoryRecursive ) +import System.Environment + ( getProgName ) +import System.FilePath as FilePath + ( normalise, (), (<.>) + , getSearchPath, joinPath, takeDirectory, splitExtension + , splitDirectories, searchPathSeparator ) +import System.IO + ( Handle, hSetBinaryMode, hGetContents, stderr, stdout, hPutStr, hFlush + , hClose, hSetBuffering, BufferMode(..), hPutStrLn ) +import System.IO.Error +import System.IO.Unsafe + ( unsafeInterleaveIO ) +import qualified Control.Exception as Exception + +import Foreign.C.Error (Errno (..), ePIPE) +import Data.Time.Clock.POSIX (getPOSIXTime, POSIXTime) +import Numeric (showFFloat) +import Distribution.Compat.Process (createProcess, rawSystem, runInteractiveProcess) +import System.Process + ( ProcessHandle + , showCommandForUser, waitForProcess) +import qualified System.Process as Process +import qualified GHC.IO.Exception as GHC + +import qualified Text.PrettyPrint as Disp + +-- We only get our own version number when we're building with ourselves +cabalVersion :: Version +#if defined(BOOTSTRAPPED_CABAL) +cabalVersion = mkVersion' Paths_Cabal.version +#elif defined(CABAL_VERSION) +cabalVersion = mkVersion [CABAL_VERSION] +#else +cabalVersion = mkVersion [3,0] --used when bootstrapping +#endif + +-- ---------------------------------------------------------------------------- +-- Exception and logging utils + +-- Cabal's logging infrastructure has a few constraints: +-- +-- * We must make all logging formatting and emissions decisions based +-- on the 'Verbosity' parameter, which is the only parameter that is +-- plumbed to enough call-sites to actually be used for this matter. +-- (One of Cabal's "big mistakes" is to have never have defined a +-- monad of its own.) +-- +-- * When we 'die', we must raise an IOError. This a backwards +-- compatibility consideration, because that's what we've raised +-- previously, and if we change to any other exception type, +-- exception handlers which match on IOError will no longer work. +-- One case where it is known we rely on IOError being catchable +-- is 'readPkgConfigDb' in cabal-install; there may be other +-- user code that also assumes this. +-- +-- * The 'topHandler' does not know what 'Verbosity' is, because +-- it gets called before we've done command line parsing (where +-- the 'Verbosity' parameter would come from). +-- +-- This leads to two big architectural choices: +-- +-- * Although naively we might imagine 'Verbosity' to be a simple +-- enumeration type, actually it is a full-on abstract data type +-- that may contain arbitrarily complex information. At the +-- moment, it is fully representable as a string, but we might +-- eventually also use verbosity to let users register their +-- own logging handler. +-- +-- * When we call 'die', we perform all the formatting and addition +-- of extra information we need, and then ship this in the IOError +-- to the top-level handler. Here are alternate designs that +-- don't work: +-- +-- a) Ship the unformatted info to the handler. This doesn't +-- work because at the point the handler gets the message, +-- we've lost call stacks, and even if we did, we don't have access +-- to 'Verbosity' to decide whether or not to render it. +-- +-- b) Print the information at the 'die' site, then raise an +-- error. This means that if the exception is subsequently +-- caught by a handler, we will still have emitted the output, +-- which is not the correct behavior. +-- +-- For the top-level handler to "know" that an error message +-- contains one of these fully formatted packets, we set a sentinel +-- in one of IOError's extra fields. This is handled by +-- 'ioeSetVerbatim' and 'ioeGetVerbatim'. +-- + +dieNoVerbosity :: String -> IO a +dieNoVerbosity msg + = ioError (userError msg) + where + _ = callStack -- TODO: Attach CallStack to exception + +-- | Tag an 'IOError' whose error string should be output to the screen +-- verbatim. +ioeSetVerbatim :: IOError -> IOError +ioeSetVerbatim e = ioeSetLocation e "dieVerbatim" + +-- | Check if an 'IOError' should be output verbatim to screen. +ioeGetVerbatim :: IOError -> Bool +ioeGetVerbatim e = ioeGetLocation e == "dieVerbatim" + +-- | Create a 'userError' whose error text will be output verbatim +verbatimUserError :: String -> IOError +verbatimUserError = ioeSetVerbatim . userError + +dieWithLocation' :: Verbosity -> FilePath -> Maybe Int -> String -> IO a +dieWithLocation' verbosity filename mb_lineno msg = + die' verbosity $ + filename ++ (case mb_lineno of + Just lineno -> ":" ++ show lineno + Nothing -> "") ++ + ": " ++ msg + +die' :: Verbosity -> String -> IO a +die' verbosity msg = withFrozenCallStack $ do + ioError . verbatimUserError + =<< annotateErrorString verbosity + =<< pure . wrapTextVerbosity verbosity + =<< pure . addErrorPrefix + =<< prefixWithProgName msg + +dieNoWrap :: Verbosity -> String -> IO a +dieNoWrap verbosity msg = withFrozenCallStack $ do + -- TODO: should this have program name or not? + ioError . verbatimUserError + =<< annotateErrorString verbosity + (addErrorPrefix msg) + +-- | Prefixing a message to indicate that it is a fatal error, +-- if the 'errorPrefix' is not already present. +addErrorPrefix :: String -> String +addErrorPrefix msg + | errorPrefix `isPrefixOf` msg = msg + -- Backpack prefixes its errors already with "Error:", see + -- 'Distribution.Utils.LogProgress.dieProgress'. + -- Taking it away there destroys the layout, so we rather + -- check here whether the prefix is already present. + | otherwise = unwords [errorPrefix, msg] + +-- | A prefix indicating that a message is a fatal error. +errorPrefix :: String +errorPrefix = "Error:" + +-- | Prefix an error string with program name from 'getProgName' +prefixWithProgName :: String -> IO String +prefixWithProgName msg = do + pname <- getProgName + return $ pname ++ ": " ++ msg + +-- | Annotate an error string with timestamp and 'withMetadata'. +annotateErrorString :: Verbosity -> String -> IO String +annotateErrorString verbosity msg = do + ts <- getPOSIXTime + return $ withMetadata ts AlwaysMark VerboseTrace verbosity msg + +-- | Given a block of IO code that may raise an exception, annotate +-- it with the metadata from the current scope. Use this as close +-- to external code that raises IO exceptions as possible, since +-- this function unconditionally wraps the error message with a trace +-- (so it is NOT idempotent.) +annotateIO :: Verbosity -> IO a -> IO a +annotateIO verbosity act = do + ts <- getPOSIXTime + flip modifyIOError act $ + ioeModifyErrorString $ withMetadata ts NeverMark VerboseTrace verbosity + +-- | A semantic editor for the error message inside an 'IOError'. +ioeModifyErrorString :: (String -> String) -> IOError -> IOError +ioeModifyErrorString = over ioeErrorString + +-- | A lens for the error message inside an 'IOError'. +ioeErrorString :: Lens' IOError String +ioeErrorString f ioe = ioeSetErrorString ioe <$> f (ioeGetErrorString ioe) + + +{-# NOINLINE topHandlerWith #-} +topHandlerWith :: forall a. (Exception.SomeException -> IO a) -> IO a -> IO a +topHandlerWith cont prog = do + -- By default, stderr to a terminal device is NoBuffering. But this + -- is *really slow* + hSetBuffering stderr LineBuffering + Exception.catches prog [ + Exception.Handler rethrowAsyncExceptions + , Exception.Handler rethrowExitStatus + , Exception.Handler handle + ] + where + -- Let async exceptions rise to the top for the default top-handler + rethrowAsyncExceptions :: Exception.AsyncException -> IO a + rethrowAsyncExceptions a = throwIO a + + -- ExitCode gets thrown asynchronously too, and we don't want to print it + rethrowExitStatus :: ExitCode -> IO a + rethrowExitStatus = throwIO + + -- Print all other exceptions + handle :: Exception.SomeException -> IO a + handle se = do + hFlush stdout + pname <- getProgName + hPutStr stderr (message pname se) + cont se + + message :: String -> Exception.SomeException -> String + message pname (Exception.SomeException se) = + case cast se :: Maybe Exception.IOException of + Just ioe + | ioeGetVerbatim ioe -> + -- Use the message verbatim + ioeGetErrorString ioe ++ "\n" + | isUserError ioe -> + let file = case ioeGetFileName ioe of + Nothing -> "" + Just path -> path ++ location ++ ": " + location = case ioeGetLocation ioe of + l@(n:_) | isDigit n -> ':' : l + _ -> "" + detail = ioeGetErrorString ioe + in wrapText $ addErrorPrefix $ pname ++ ": " ++ file ++ detail + _ -> + displaySomeException se ++ "\n" + +-- | BC wrapper around 'Exception.displayException'. +displaySomeException :: Exception.Exception e => e -> String +displaySomeException se = Exception.displayException se + +topHandler :: IO a -> IO a +topHandler prog = topHandlerWith (const $ exitWith (ExitFailure 1)) prog + +-- | Depending on 'isVerboseStderr', set the output handle to 'stderr' or 'stdout'. +verbosityHandle :: Verbosity -> Handle +verbosityHandle verbosity + | isVerboseStderr verbosity = stderr + | otherwise = stdout + +-- | Non fatal conditions that may be indicative of an error or problem. +-- +-- We display these at the 'normal' verbosity level. +-- +warn :: Verbosity -> String -> IO () +warn verbosity msg = withFrozenCallStack $ do + when ((verbosity >= normal) && not (isVerboseNoWarn verbosity)) $ do + ts <- getPOSIXTime + hFlush stdout + hPutStr stderr . withMetadata ts NormalMark FlagTrace verbosity + . wrapTextVerbosity verbosity + $ "Warning: " ++ msg + +-- | Useful status messages. +-- +-- We display these at the 'normal' verbosity level. +-- +-- This is for the ordinary helpful status messages that users see. Just +-- enough information to know that things are working but not floods of detail. +-- +notice :: Verbosity -> String -> IO () +notice verbosity msg = withFrozenCallStack $ do + when (verbosity >= normal) $ do + let h = verbosityHandle verbosity + ts <- getPOSIXTime + hPutStr h + $ withMetadata ts NormalMark FlagTrace verbosity + $ wrapTextVerbosity verbosity + $ msg + +-- | Display a message at 'normal' verbosity level, but without +-- wrapping. +-- +noticeNoWrap :: Verbosity -> String -> IO () +noticeNoWrap verbosity msg = withFrozenCallStack $ do + when (verbosity >= normal) $ do + let h = verbosityHandle verbosity + ts <- getPOSIXTime + hPutStr h . withMetadata ts NormalMark FlagTrace verbosity $ msg + +-- | Pretty-print a 'Disp.Doc' status message at 'normal' verbosity +-- level. Use this if you need fancy formatting. +-- +noticeDoc :: Verbosity -> Disp.Doc -> IO () +noticeDoc verbosity msg = withFrozenCallStack $ do + when (verbosity >= normal) $ do + let h = verbosityHandle verbosity + ts <- getPOSIXTime + hPutStr h + $ withMetadata ts NormalMark FlagTrace verbosity + $ Disp.renderStyle defaultStyle + $ msg + +-- | Display a "setup status message". Prefer using setupMessage' +-- if possible. +-- +setupMessage :: Verbosity -> String -> PackageIdentifier -> IO () +setupMessage verbosity msg pkgid = withFrozenCallStack $ do + noticeNoWrap verbosity (msg ++ ' ': prettyShow pkgid ++ "...") + +-- | More detail on the operation of some action. +-- +-- We display these messages when the verbosity level is 'verbose' +-- +info :: Verbosity -> String -> IO () +info verbosity msg = withFrozenCallStack $ + when (verbosity >= verbose) $ do + let h = verbosityHandle verbosity + ts <- getPOSIXTime + hPutStr h + $ withMetadata ts NeverMark FlagTrace verbosity + $ wrapTextVerbosity verbosity + $ msg + +infoNoWrap :: Verbosity -> String -> IO () +infoNoWrap verbosity msg = withFrozenCallStack $ + when (verbosity >= verbose) $ do + let h = verbosityHandle verbosity + ts <- getPOSIXTime + hPutStr h + $ withMetadata ts NeverMark FlagTrace verbosity + $ msg + +-- | Detailed internal debugging information +-- +-- We display these messages when the verbosity level is 'deafening' +-- +debug :: Verbosity -> String -> IO () +debug verbosity msg = withFrozenCallStack $ + when (verbosity >= deafening) $ do + let h = verbosityHandle verbosity + ts <- getPOSIXTime + hPutStr h $ withMetadata ts NeverMark FlagTrace verbosity + $ wrapTextVerbosity verbosity + $ msg + -- ensure that we don't lose output if we segfault/infinite loop + hFlush stdout + +-- | A variant of 'debug' that doesn't perform the automatic line +-- wrapping. Produces better output in some cases. +debugNoWrap :: Verbosity -> String -> IO () +debugNoWrap verbosity msg = withFrozenCallStack $ + when (verbosity >= deafening) $ do + let h = verbosityHandle verbosity + ts <- getPOSIXTime + hPutStr h + $ withMetadata ts NeverMark FlagTrace verbosity + $ msg + -- ensure that we don't lose output if we segfault/infinite loop + hFlush stdout + +-- | Perform an IO action, catching any IO exceptions and printing an error +-- if one occurs. +chattyTry :: String -- ^ a description of the action we were attempting + -> IO () -- ^ the action itself + -> IO () +chattyTry desc action = + catchIO action $ \exception -> + hPutStrLn stderr $ "Error while " ++ desc ++ ": " ++ show exception + +-- | Run an IO computation, returning @e@ if it raises a "file +-- does not exist" error. +handleDoesNotExist :: a -> IO a -> IO a +handleDoesNotExist e = + Exception.handleJust + (\ioe -> if isDoesNotExistError ioe then Just ioe else Nothing) + (\_ -> return e) + +-- ----------------------------------------------------------------------------- +-- Helper functions + +-- | Wraps text unless the @+nowrap@ verbosity flag is active +wrapTextVerbosity :: Verbosity -> String -> String +wrapTextVerbosity verb + | isVerboseNoWrap verb = withTrailingNewline + | otherwise = withTrailingNewline . wrapText + + +-- | Prepends a timestamp if @+timestamp@ verbosity flag is set +-- +-- This is used by 'withMetadata' +-- +withTimestamp :: Verbosity -> POSIXTime -> String -> String +withTimestamp v ts msg + | isVerboseTimestamp v = msg' + | otherwise = msg -- no-op + where + msg' = case lines msg of + [] -> tsstr "\n" + l1:rest -> unlines (tsstr (' ':l1) : map (contpfx++) rest) + + -- format timestamp to be prepended to first line with msec precision + tsstr = showFFloat (Just 3) (realToFrac ts :: Double) + + -- continuation prefix for subsequent lines of msg + contpfx = replicate (length (tsstr " ")) ' ' + +-- | Wrap output with a marker if @+markoutput@ verbosity flag is set. +-- +-- NB: Why is markoutput done with start/end markers, and not prefixes? +-- Markers are more convenient to add (if we want to add prefixes, +-- we have to 'lines' and then 'map'; here's it's just some +-- concatenates). Note that even in the prefix case, we can't +-- guarantee that the markers are unambiguous, because some of +-- Cabal's output comes straight from external programs, where +-- we don't have the ability to interpose on the output. +-- +-- This is used by 'withMetadata' +-- +withOutputMarker :: Verbosity -> String -> String +withOutputMarker v xs | not (isVerboseMarkOutput v) = xs +withOutputMarker _ "" = "" -- Minor optimization, don't mark uselessly +withOutputMarker _ xs = + "-----BEGIN CABAL OUTPUT-----\n" ++ + withTrailingNewline xs ++ + "-----END CABAL OUTPUT-----\n" + +-- | Append a trailing newline to a string if it does not +-- already have a trailing newline. +-- +withTrailingNewline :: String -> String +withTrailingNewline "" = "" +withTrailingNewline (x:xs) = x : go x xs + where + go _ (c:cs) = c : go c cs + go '\n' "" = "" + go _ "" = "\n" + +-- | Prepend a call-site and/or call-stack based on Verbosity +-- +withCallStackPrefix :: WithCallStack (TraceWhen -> Verbosity -> String -> String) +withCallStackPrefix tracer verbosity s = withFrozenCallStack $ + (if isVerboseCallSite verbosity + then parentSrcLocPrefix ++ + -- Hack: need a newline before starting output marker :( + if isVerboseMarkOutput verbosity + then "\n" + else "" + else "") ++ + (case traceWhen verbosity tracer of + Just pre -> pre ++ prettyCallStack callStack ++ "\n" + Nothing -> "") ++ + s + +-- | When should we emit the call stack? We always emit +-- for internal errors, emit the trace for errors when we +-- are in verbose mode, and otherwise only emit it if +-- explicitly asked for using the @+callstack@ verbosity +-- flag. (At the moment, 'AlwaysTrace' is not used. +-- +data TraceWhen + = AlwaysTrace + | VerboseTrace + | FlagTrace + deriving (Eq) + +-- | Determine if we should emit a call stack. +-- If we trace, it also emits any prefix we should append. +traceWhen :: Verbosity -> TraceWhen -> Maybe String +traceWhen _ AlwaysTrace = Just "" +traceWhen v VerboseTrace | v >= verbose = Just "" +traceWhen v FlagTrace | isVerboseCallStack v = Just "----\n" +traceWhen _ _ = Nothing + +-- | When should we output the marker? Things like 'die' +-- always get marked, but a 'NormalMark' will only be +-- output if we're not a quiet verbosity. +-- +data MarkWhen = AlwaysMark | NormalMark | NeverMark + +-- | Add all necessary metadata to a logging message +-- +withMetadata :: WithCallStack (POSIXTime -> MarkWhen -> TraceWhen -> Verbosity -> String -> String) +withMetadata ts marker tracer verbosity x = withFrozenCallStack $ + -- NB: order matters. Output marker first because we + -- don't want to capture call stacks. + withTrailingNewline + . withCallStackPrefix tracer verbosity + . (case marker of + AlwaysMark -> withOutputMarker verbosity + NormalMark | not (isVerboseQuiet verbosity) + -> withOutputMarker verbosity + | otherwise + -> id + NeverMark -> id) + -- Clear out any existing markers + . clearMarkers + . withTimestamp verbosity ts + $ x + +clearMarkers :: String -> String +clearMarkers s = unlines . filter isMarker $ lines s + where + isMarker "-----BEGIN CABAL OUTPUT-----" = False + isMarker "-----END CABAL OUTPUT-----" = False + isMarker _ = True + +-- ----------------------------------------------------------------------------- +-- rawSystem variants +maybeExit :: IO ExitCode -> IO () +maybeExit cmd = do + res <- cmd + unless (res == ExitSuccess) $ exitWith res + + + +printRawCommandAndArgs :: Verbosity -> FilePath -> [String] -> IO () +printRawCommandAndArgs verbosity path args = withFrozenCallStack $ + printRawCommandAndArgsAndEnv verbosity path args Nothing Nothing + +printRawCommandAndArgsAndEnv :: Verbosity + -> FilePath + -> [String] + -> Maybe FilePath + -> Maybe [(String, String)] + -> IO () +printRawCommandAndArgsAndEnv verbosity path args mcwd menv = do + case menv of + Just env -> debugNoWrap verbosity ("Environment: " ++ show env) + Nothing -> return () + case mcwd of + Just cwd -> debugNoWrap verbosity ("Working directory: " ++ show cwd) + Nothing -> return () + infoNoWrap verbosity (showCommandForUser path args) + +-- Exit with the same exit code if the subcommand fails +rawSystemExit :: Verbosity -> FilePath -> [String] -> IO () +rawSystemExit verbosity path args = withFrozenCallStack $ do + printRawCommandAndArgs verbosity path args + hFlush stdout + exitcode <- rawSystem path args + unless (exitcode == ExitSuccess) $ do + debug verbosity $ path ++ " returned " ++ show exitcode + exitWith exitcode + +rawSystemExitCode :: Verbosity -> FilePath -> [String] -> IO ExitCode +rawSystemExitCode verbosity path args = withFrozenCallStack $ do + printRawCommandAndArgs verbosity path args + hFlush stdout + exitcode <- rawSystem path args + unless (exitcode == ExitSuccess) $ do + debug verbosity $ path ++ " returned " ++ show exitcode + return exitcode + +rawSystemExitWithEnv :: Verbosity + -> FilePath + -> [String] + -> [(String, String)] + -> IO () +rawSystemExitWithEnv verbosity path args env = withFrozenCallStack $ do + printRawCommandAndArgsAndEnv verbosity path args Nothing (Just env) + hFlush stdout + (_,_,_,ph) <- createProcess $ + (Process.proc path args) { Process.env = (Just env) + , Process.delegate_ctlc = True + } + exitcode <- waitForProcess ph + unless (exitcode == ExitSuccess) $ do + debug verbosity $ path ++ " returned " ++ show exitcode + exitWith exitcode + +-- Closes the passed in handles before returning. +rawSystemIOWithEnv :: Verbosity + -> FilePath + -> [String] + -> Maybe FilePath -- ^ New working dir or inherit + -> Maybe [(String, String)] -- ^ New environment or inherit + -> Maybe Handle -- ^ stdin + -> Maybe Handle -- ^ stdout + -> Maybe Handle -- ^ stderr + -> IO ExitCode +rawSystemIOWithEnv verbosity path args mcwd menv inp out err = withFrozenCallStack $ do + (_,_,_,ph) <- createProcessWithEnv verbosity path args mcwd menv + (mbToStd inp) (mbToStd out) (mbToStd err) + exitcode <- waitForProcess ph + unless (exitcode == ExitSuccess) $ do + debug verbosity $ path ++ " returned " ++ show exitcode + return exitcode + where + mbToStd :: Maybe Handle -> Process.StdStream + mbToStd = maybe Process.Inherit Process.UseHandle + +rawSystemIOWithEnvAndAction + :: Verbosity + -> FilePath + -> [String] + -> Maybe FilePath -- ^ New working dir or inherit + -> Maybe [(String, String)] -- ^ New environment or inherit + -> IO a -- ^ action to perform after process is created, but before 'waitForProcess'. + -> Maybe Handle -- ^ stdin + -> Maybe Handle -- ^ stdout + -> Maybe Handle -- ^ stderr + -> IO (ExitCode, a) +rawSystemIOWithEnvAndAction verbosity path args mcwd menv action inp out err = withFrozenCallStack $ do + (_,_,_,ph) <- createProcessWithEnv verbosity path args mcwd menv + (mbToStd inp) (mbToStd out) (mbToStd err) + a <- action + exitcode <- waitForProcess ph + unless (exitcode == ExitSuccess) $ do + debug verbosity $ path ++ " returned " ++ show exitcode + return (exitcode, a) + where + mbToStd :: Maybe Handle -> Process.StdStream + mbToStd = maybe Process.Inherit Process.UseHandle + +createProcessWithEnv :: + Verbosity + -> FilePath + -> [String] + -> Maybe FilePath -- ^ New working dir or inherit + -> Maybe [(String, String)] -- ^ New environment or inherit + -> Process.StdStream -- ^ stdin + -> Process.StdStream -- ^ stdout + -> Process.StdStream -- ^ stderr + -> IO (Maybe Handle, Maybe Handle, Maybe Handle,ProcessHandle) + -- ^ Any handles created for stdin, stdout, or stderr + -- with 'CreateProcess', and a handle to the process. +createProcessWithEnv verbosity path args mcwd menv inp out err = withFrozenCallStack $ do + printRawCommandAndArgsAndEnv verbosity path args mcwd menv + hFlush stdout + (inp', out', err', ph) <- createProcess $ + (Process.proc path args) { + Process.cwd = mcwd + , Process.env = menv + , Process.std_in = inp + , Process.std_out = out + , Process.std_err = err + , Process.delegate_ctlc = True + } + return (inp', out', err', ph) + +-- | Run a command and return its output. +-- +-- The output is assumed to be text in the locale encoding. +-- +rawSystemStdout :: forall mode. KnownIODataMode mode => Verbosity -> FilePath -> [String] -> IO mode +rawSystemStdout verbosity path args = withFrozenCallStack $ do + (output, errors, exitCode) <- rawSystemStdInOut verbosity path args + Nothing Nothing Nothing (IOData.iodataMode :: IODataMode mode) + when (exitCode /= ExitSuccess) $ + die' verbosity errors + return output + +-- | Run a command and return its output, errors and exit status. Optionally +-- also supply some input. Also provides control over whether the binary/text +-- mode of the input and output. +-- +rawSystemStdInOut :: KnownIODataMode mode + => Verbosity + -> FilePath -- ^ Program location + -> [String] -- ^ Arguments + -> Maybe FilePath -- ^ New working dir or inherit + -> Maybe [(String, String)] -- ^ New environment or inherit + -> Maybe IOData -- ^ input text and binary mode + -> IODataMode mode -- ^ iodata mode, acts as proxy + -> IO (mode, String, ExitCode) -- ^ output, errors, exit +rawSystemStdInOut verbosity path args mcwd menv input _ = withFrozenCallStack $ do + printRawCommandAndArgs verbosity path args + + Exception.bracket + (runInteractiveProcess path args mcwd menv) + (\(inh,outh,errh,_) -> hClose inh >> hClose outh >> hClose errh) + $ \(inh,outh,errh,pid) -> do + + -- output mode depends on what the caller wants + -- but the errors are always assumed to be text (in the current locale) + hSetBinaryMode errh False + + -- fork off a couple threads to pull on the stderr and stdout + -- so if the process writes to stderr we do not block. + + withAsyncNF (hGetContents errh) $ \errA -> withAsyncNF (IOData.hGetIODataContents outh) $ \outA -> do + -- push all the input, if any + ignoreSigPipe $ case input of + Nothing -> hClose inh + Just inputData -> IOData.hPutContents inh inputData + + -- wait for both to finish + mberr1 <- waitCatch outA + mberr2 <- waitCatch errA + + -- wait for the program to terminate + exitcode <- waitForProcess pid + + -- get the stderr, so it can be added to error message + err <- reportOutputIOError mberr2 + + unless (exitcode == ExitSuccess) $ + debug verbosity $ path ++ " returned " ++ show exitcode + ++ if null err then "" else + " with error message:\n" ++ err + ++ case input of + Nothing -> "" + Just d | IOData.null d -> "" + Just (IODataText inp) -> "\nstdin input:\n" ++ inp + Just (IODataBinary inp) -> "\nstdin input (binary):\n" ++ show inp + + -- Check if we hit an exception while consuming the output + -- (e.g. a text decoding error) + out <- reportOutputIOError mberr1 + + return (out, err, exitcode) + where + reportOutputIOError :: Either Exception.SomeException a -> IO a + reportOutputIOError (Right x) = return x + reportOutputIOError (Left exc) = case fromException exc of + Just ioe -> throwIO (ioeSetFileName ioe ("output of " ++ path)) + Nothing -> throwIO exc + +-- | Ignore SIGPIPE in a subcomputation. +-- +ignoreSigPipe :: IO () -> IO () +ignoreSigPipe = Exception.handle $ \case + GHC.IOError { GHC.ioe_type = GHC.ResourceVanished, GHC.ioe_errno = Just ioe } + | Errno ioe == ePIPE -> return () + e -> throwIO e + +-- | Look for a program and try to find it's version number. It can accept +-- either an absolute path or the name of a program binary, in which case we +-- will look for the program on the path. +-- +findProgramVersion :: String -- ^ version args + -> (String -> String) -- ^ function to select version + -- number from program output + -> Verbosity + -> FilePath -- ^ location + -> IO (Maybe Version) +findProgramVersion versionArg selectVersion verbosity path = withFrozenCallStack $ do + str <- rawSystemStdout verbosity path [versionArg] + `catchIO` (\_ -> return "") + `catchExit` (\_ -> return "") + let version :: Maybe Version + version = simpleParsec (selectVersion str) + case version of + Nothing -> warn verbosity $ "cannot determine version of " ++ path + ++ " :\n" ++ show str + Just v -> debug verbosity $ path ++ " is version " ++ prettyShow v + return version + + +-- | Like the Unix xargs program. Useful for when we've got very long command +-- lines that might overflow an OS limit on command line length and so you +-- need to invoke a command multiple times to get all the args in. +-- +-- Use it with either of the rawSystem variants above. For example: +-- +-- > xargs (32*1024) (rawSystemExit verbosity) prog fixedArgs bigArgs +-- +xargs :: Int -> ([String] -> IO ()) + -> [String] -> [String] -> IO () +xargs maxSize rawSystemFun fixedArgs bigArgs = + let fixedArgSize = sum (map length fixedArgs) + length fixedArgs + chunkSize = maxSize - fixedArgSize + in traverse_ (rawSystemFun . (fixedArgs ++)) (chunks chunkSize bigArgs) + + where chunks len = unfoldr $ \s -> + if null s then Nothing + else Just (chunk [] len s) + + chunk acc _ [] = (reverse acc,[]) + chunk acc len (s:ss) + | len' < len = chunk (s:acc) (len-len'-1) ss + | otherwise = (reverse acc, s:ss) + where len' = length s + +-- ------------------------------------------------------------ +-- * File Utilities +-- ------------------------------------------------------------ + +---------------- +-- Finding files + + +-- | Find a file by looking in a search path. The file path must match exactly. +-- +-- @since 3.4.0.0 +findFileCwd + :: Verbosity + -> FilePath -- ^ cwd + -> [FilePath] -- ^ relative search location + -> FilePath -- ^ File Name + -> IO FilePath +findFileCwd verbosity cwd searchPath fileName = + findFirstFile (cwd ) + [ path fileName + | path <- nub searchPath] + >>= maybe (die' verbosity $ fileName ++ " doesn't exist") return + +-- | Find a file by looking in a search path. The file path must match exactly. +-- +findFileEx :: Verbosity + -> [FilePath] -- ^search locations + -> FilePath -- ^File Name + -> IO FilePath +findFileEx verbosity searchPath fileName = + findFirstFile id + [ path fileName + | path <- nub searchPath] + >>= maybe (die' verbosity $ fileName ++ " doesn't exist") return + +-- | Find a file by looking in a search path with one of a list of possible +-- file extensions. The file base name should be given and it will be tried +-- with each of the extensions in each element of the search path. +-- +findFileWithExtension :: [String] + -> [FilePath] + -> FilePath + -> IO (Maybe FilePath) +findFileWithExtension extensions searchPath baseName = + findFirstFile id + [ path baseName <.> ext + | path <- nub searchPath + , ext <- nub extensions ] + +-- | @since 3.4.0.0 +findFileCwdWithExtension + :: FilePath + -> [String] + -> [FilePath] + -> FilePath + -> IO (Maybe FilePath) +findFileCwdWithExtension cwd extensions searchPath baseName = + findFirstFile (cwd ) + [ path baseName <.> ext + | path <- nub searchPath + , ext <- nub extensions ] + +-- | @since 3.4.0.0 +findAllFilesCwdWithExtension + :: FilePath -- ^ cwd + -> [String] -- ^ extensions + -> [FilePath] -- ^ relative search locations + -> FilePath -- ^ basename + -> IO [FilePath] +findAllFilesCwdWithExtension cwd extensions searchPath basename = + findAllFiles (cwd ) + [ path basename <.> ext + | path <- nub searchPath + , ext <- nub extensions ] + +findAllFilesWithExtension :: [String] + -> [FilePath] + -> FilePath + -> IO [FilePath] +findAllFilesWithExtension extensions searchPath basename = + findAllFiles id + [ path basename <.> ext + | path <- nub searchPath + , ext <- nub extensions ] + +-- | Like 'findFileWithExtension' but returns which element of the search path +-- the file was found in, and the file path relative to that base directory. +-- +findFileWithExtension' :: [String] + -> [FilePath] + -> FilePath + -> IO (Maybe (FilePath, FilePath)) +findFileWithExtension' extensions searchPath baseName = + findFirstFile (uncurry ()) + [ (path, baseName <.> ext) + | path <- nub searchPath + , ext <- nub extensions ] + +findFirstFile :: (a -> FilePath) -> [a] -> IO (Maybe a) +findFirstFile file = findFirst + where findFirst [] = return Nothing + findFirst (x:xs) = do exists <- doesFileExist (file x) + if exists + then return (Just x) + else findFirst xs + +findAllFiles :: (a -> FilePath) -> [a] -> IO [a] +findAllFiles file = filterM (doesFileExist . file) + + +-- | Finds the files corresponding to a list of Haskell module names. +-- +-- As 'findModuleFile' but for a list of module names. +-- +findModuleFilesEx :: Verbosity + -> [FilePath] -- ^ build prefix (location of objects) + -> [String] -- ^ search suffixes + -> [ModuleName] -- ^ modules + -> IO [(FilePath, FilePath)] +findModuleFilesEx verbosity searchPath extensions moduleNames = + traverse (findModuleFileEx verbosity searchPath extensions) moduleNames + +-- | Find the file corresponding to a Haskell module name. +-- +-- This is similar to 'findFileWithExtension'' but specialised to a module +-- name. The function fails if the file corresponding to the module is missing. +-- +findModuleFileEx :: Verbosity + -> [FilePath] -- ^ build prefix (location of objects) + -> [String] -- ^ search suffixes + -> ModuleName -- ^ module + -> IO (FilePath, FilePath) +findModuleFileEx verbosity searchPath extensions mod_name = + maybe notFound return + =<< findFileWithExtension' extensions searchPath + (ModuleName.toFilePath mod_name) + where + notFound = die' verbosity $ + "Could not find module: " ++ prettyShow mod_name + ++ " with any suffix: " ++ show extensions + ++ " in the search path: " ++ show searchPath + +-- | List all the files in a directory and all subdirectories. +-- +-- The order places files in sub-directories after all the files in their +-- parent directories. The list is generated lazily so is not well defined if +-- the source directory structure changes before the list is used. +-- +getDirectoryContentsRecursive :: FilePath -> IO [FilePath] +getDirectoryContentsRecursive topdir = recurseDirectories [""] + where + recurseDirectories :: [FilePath] -> IO [FilePath] + recurseDirectories [] = return [] + recurseDirectories (dir:dirs) = unsafeInterleaveIO $ do + (files, dirs') <- collect [] [] =<< getDirectoryContents (topdir dir) + files' <- recurseDirectories (dirs' ++ dirs) + return (files ++ files') + + where + collect files dirs' [] = return (reverse files + ,reverse dirs') + collect files dirs' (entry:entries) | ignore entry + = collect files dirs' entries + collect files dirs' (entry:entries) = do + let dirEntry = dir entry + isDirectory <- doesDirectoryExist (topdir dirEntry) + if isDirectory + then collect files (dirEntry:dirs') entries + else collect (dirEntry:files) dirs' entries + + ignore ['.'] = True + ignore ['.', '.'] = True + ignore _ = False + +------------------------ +-- Environment variables + +-- | Is this directory in the system search path? +isInSearchPath :: FilePath -> IO Bool +isInSearchPath path = fmap (elem path) getSearchPath + +addLibraryPath :: OS + -> [FilePath] + -> [(String,String)] + -> [(String,String)] +addLibraryPath os paths = addEnv + where + pathsString = intercalate [searchPathSeparator] paths + ldPath = case os of + OSX -> "DYLD_LIBRARY_PATH" + _ -> "LD_LIBRARY_PATH" + + addEnv [] = [(ldPath,pathsString)] + addEnv ((key,value):xs) + | key == ldPath = + if null value + then (key,pathsString):xs + else (key,value ++ (searchPathSeparator:pathsString)):xs + | otherwise = (key,value):addEnv xs + +-------------------- +-- Modification time + +-- | Compare the modification times of two files to see if the first is newer +-- than the second. The first file must exist but the second need not. +-- The expected use case is when the second file is generated using the first. +-- In this use case, if the result is True then the second file is out of date. +-- +moreRecentFile :: FilePath -> FilePath -> IO Bool +moreRecentFile a b = do + exists <- doesFileExist b + if not exists + then return True + else do tb <- getModificationTime b + ta <- getModificationTime a + return (ta > tb) + +-- | Like 'moreRecentFile', but also checks that the first file exists. +existsAndIsMoreRecentThan :: FilePath -> FilePath -> IO Bool +existsAndIsMoreRecentThan a b = do + exists <- doesFileExist a + if not exists + then return False + else a `moreRecentFile` b + +---------------------------------------- +-- Copying and installing files and dirs + +-- | Same as 'createDirectoryIfMissing' but logs at higher verbosity levels. +-- +createDirectoryIfMissingVerbose :: Verbosity + -> Bool -- ^ Create its parents too? + -> FilePath + -> IO () +createDirectoryIfMissingVerbose verbosity create_parents path0 + | create_parents = withFrozenCallStack $ createDirs (parents path0) + | otherwise = withFrozenCallStack $ createDirs (take 1 (parents path0)) + where + parents = reverse . scanl1 () . splitDirectories . normalise + + createDirs [] = return () + createDirs (dir:[]) = createDir dir throwIO + createDirs (dir:dirs) = + createDir dir $ \_ -> do + createDirs dirs + createDir dir throwIO + + createDir :: FilePath -> (IOException -> IO ()) -> IO () + createDir dir notExistHandler = do + r <- tryIO $ createDirectoryVerbose verbosity dir + case (r :: Either IOException ()) of + Right () -> return () + Left e + | isDoesNotExistError e -> notExistHandler e + -- createDirectory (and indeed POSIX mkdir) does not distinguish + -- between a dir already existing and a file already existing. So we + -- check for it here. Unfortunately there is a slight race condition + -- here, but we think it is benign. It could report an exception in + -- the case that the dir did exist but another process deletes the + -- directory and creates a file in its place before we can check + -- that the directory did indeed exist. + | isAlreadyExistsError e -> (do + isDir <- doesDirectoryExist dir + unless isDir $ throwIO e + ) `catchIO` ((\_ -> return ()) :: IOException -> IO ()) + | otherwise -> throwIO e + +createDirectoryVerbose :: Verbosity -> FilePath -> IO () +createDirectoryVerbose verbosity dir = withFrozenCallStack $ do + info verbosity $ "creating " ++ dir + createDirectory dir + setDirOrdinary dir + +-- | Copies a file without copying file permissions. The target file is created +-- with default permissions. Any existing target file is replaced. +-- +-- At higher verbosity levels it logs an info message. +-- +copyFileVerbose :: Verbosity -> FilePath -> FilePath -> IO () +copyFileVerbose verbosity src dest = withFrozenCallStack $ do + info verbosity ("copy " ++ src ++ " to " ++ dest) + copyFile src dest + +-- | Install an ordinary file. This is like a file copy but the permissions +-- are set appropriately for an installed file. On Unix it is \"-rw-r--r--\" +-- while on Windows it uses the default permissions for the target directory. +-- +installOrdinaryFile :: Verbosity -> FilePath -> FilePath -> IO () +installOrdinaryFile verbosity src dest = withFrozenCallStack $ do + info verbosity ("Installing " ++ src ++ " to " ++ dest) + copyOrdinaryFile src dest + +-- | Install an executable file. This is like a file copy but the permissions +-- are set appropriately for an installed file. On Unix it is \"-rwxr-xr-x\" +-- while on Windows it uses the default permissions for the target directory. +-- +installExecutableFile :: Verbosity -> FilePath -> FilePath -> IO () +installExecutableFile verbosity src dest = withFrozenCallStack $ do + info verbosity ("Installing executable " ++ src ++ " to " ++ dest) + copyExecutableFile src dest + +-- | Install a file that may or not be executable, preserving permissions. +installMaybeExecutableFile :: Verbosity -> FilePath -> FilePath -> IO () +installMaybeExecutableFile verbosity src dest = withFrozenCallStack $ do + perms <- getPermissions src + if (executable perms) --only checks user x bit + then installExecutableFile verbosity src dest + else installOrdinaryFile verbosity src dest + +-- | Given a relative path to a file, copy it to the given directory, preserving +-- the relative path and creating the parent directories if needed. +copyFileTo :: Verbosity -> FilePath -> FilePath -> IO () +copyFileTo verbosity dir file = withFrozenCallStack $ do + let targetFile = dir file + createDirectoryIfMissingVerbose verbosity True (takeDirectory targetFile) + installOrdinaryFile verbosity file targetFile + +-- | Common implementation of 'copyFiles', 'installOrdinaryFiles', +-- 'installExecutableFiles' and 'installMaybeExecutableFiles'. +copyFilesWith :: (Verbosity -> FilePath -> FilePath -> IO ()) + -> Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO () +copyFilesWith doCopy verbosity targetDir srcFiles = withFrozenCallStack $ do + + -- Create parent directories for everything + let dirs = map (targetDir ) . nub . map (takeDirectory . snd) $ srcFiles + traverse_ (createDirectoryIfMissingVerbose verbosity True) dirs + + -- Copy all the files + sequence_ [ let src = srcBase srcFile + dest = targetDir srcFile + in doCopy verbosity src dest + | (srcBase, srcFile) <- srcFiles ] + +-- | Copies a bunch of files to a target directory, preserving the directory +-- structure in the target location. The target directories are created if they +-- do not exist. +-- +-- The files are identified by a pair of base directory and a path relative to +-- that base. It is only the relative part that is preserved in the +-- destination. +-- +-- For example: +-- +-- > copyFiles normal "dist/src" +-- > [("", "src/Foo.hs"), ("dist/build/", "src/Bar.hs")] +-- +-- This would copy \"src\/Foo.hs\" to \"dist\/src\/src\/Foo.hs\" and +-- copy \"dist\/build\/src\/Bar.hs\" to \"dist\/src\/src\/Bar.hs\". +-- +-- This operation is not atomic. Any IO failure during the copy (including any +-- missing source files) leaves the target in an unknown state so it is best to +-- use it with a freshly created directory so that it can be simply deleted if +-- anything goes wrong. +-- +copyFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO () +copyFiles v fp fs = withFrozenCallStack (copyFilesWith copyFileVerbose v fp fs) + +-- | This is like 'copyFiles' but uses 'installOrdinaryFile'. +-- +installOrdinaryFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO () +installOrdinaryFiles v fp fs = withFrozenCallStack (copyFilesWith installOrdinaryFile v fp fs) + +-- | This is like 'copyFiles' but uses 'installExecutableFile'. +-- +installExecutableFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] + -> IO () +installExecutableFiles v fp fs = withFrozenCallStack (copyFilesWith installExecutableFile v fp fs) + +-- | This is like 'copyFiles' but uses 'installMaybeExecutableFile'. +-- +installMaybeExecutableFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] + -> IO () +installMaybeExecutableFiles v fp fs = withFrozenCallStack (copyFilesWith installMaybeExecutableFile v fp fs) + +-- | This installs all the files in a directory to a target location, +-- preserving the directory layout. All the files are assumed to be ordinary +-- rather than executable files. +-- +installDirectoryContents :: Verbosity -> FilePath -> FilePath -> IO () +installDirectoryContents verbosity srcDir destDir = withFrozenCallStack $ do + info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.") + srcFiles <- getDirectoryContentsRecursive srcDir + installOrdinaryFiles verbosity destDir [ (srcDir, f) | f <- srcFiles ] + +-- | Recursively copy the contents of one directory to another path. +copyDirectoryRecursive :: Verbosity -> FilePath -> FilePath -> IO () +copyDirectoryRecursive verbosity srcDir destDir = withFrozenCallStack $ do + info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.") + srcFiles <- getDirectoryContentsRecursive srcDir + copyFilesWith (const copyFile) verbosity destDir [ (srcDir, f) + | f <- srcFiles ] + +------------------- +-- File permissions + +-- | Like 'doesFileExist', but also checks that the file is executable. +doesExecutableExist :: FilePath -> IO Bool +doesExecutableExist f = do + exists <- doesFileExist f + if exists + then do perms <- getPermissions f + return (executable perms) + else return False + +--------------------------- +-- Temporary files and dirs + +-- | Advanced options for 'withTempFile' and 'withTempDirectory'. +data TempFileOptions = TempFileOptions { + optKeepTempFiles :: Bool -- ^ Keep temporary files? + } + +defaultTempFileOptions :: TempFileOptions +defaultTempFileOptions = TempFileOptions { optKeepTempFiles = False } + +-- | Use a temporary filename that doesn't already exist. +-- +withTempFile :: FilePath -- ^ Temp dir to create the file in + -> String -- ^ File name template. See 'openTempFile'. + -> (FilePath -> Handle -> IO a) -> IO a +withTempFile tmpDir template action = + withTempFileEx defaultTempFileOptions tmpDir template action + +-- | A version of 'withTempFile' that additionally takes a 'TempFileOptions' +-- argument. +withTempFileEx :: TempFileOptions + -> FilePath -- ^ Temp dir to create the file in + -> String -- ^ File name template. See 'openTempFile'. + -> (FilePath -> Handle -> IO a) -> IO a +withTempFileEx opts tmpDir template action = + Exception.bracket + (openTempFile tmpDir template) + (\(name, handle) -> do hClose handle + unless (optKeepTempFiles opts) $ + handleDoesNotExist () . removeFile $ name) + (withLexicalCallStack (\x -> uncurry action x)) + +-- | Create and use a temporary directory. +-- +-- Creates a new temporary directory inside the given directory, making use +-- of the template. The temp directory is deleted after use. For example: +-- +-- > withTempDirectory verbosity "src" "sdist." $ \tmpDir -> do ... +-- +-- The @tmpDir@ will be a new subdirectory of the given directory, e.g. +-- @src/sdist.342@. +-- +withTempDirectory :: Verbosity -> FilePath -> String -> (FilePath -> IO a) -> IO a +withTempDirectory verbosity targetDir template f = withFrozenCallStack $ + withTempDirectoryEx verbosity defaultTempFileOptions targetDir template + (withLexicalCallStack (\x -> f x)) + +-- | A version of 'withTempDirectory' that additionally takes a +-- 'TempFileOptions' argument. +withTempDirectoryEx :: Verbosity -> TempFileOptions + -> FilePath -> String -> (FilePath -> IO a) -> IO a +withTempDirectoryEx _verbosity opts targetDir template f = withFrozenCallStack $ + Exception.bracket + (createTempDirectory targetDir template) + (unless (optKeepTempFiles opts) + . handleDoesNotExist () . removeDirectoryRecursive) + (withLexicalCallStack (\x -> f x)) + +----------------------------------- +-- Safely reading and writing files + +-- | Write a file but only if it would have new content. If we would be writing +-- the same as the existing content then leave the file as is so that we do not +-- update the file's modification time. +-- +-- NB: Before Cabal-3.0 the file content was assumed to be +-- ASCII-representable. Since Cabal-3.0 the file is assumed to be +-- UTF-8 encoded. +rewriteFileEx :: Verbosity -> FilePath -> String -> IO () +rewriteFileEx verbosity path = + rewriteFileLBS verbosity path . toUTF8LBS + +-- | Same as `rewriteFileEx` but for 'ByteString's. +rewriteFileLBS :: Verbosity -> FilePath -> BS.ByteString -> IO () +rewriteFileLBS verbosity path newContent = + flip catchIO mightNotExist $ do + existingContent <- annotateIO verbosity $ BS.readFile path + _ <- evaluate (BS.length existingContent) + unless (existingContent == newContent) $ + annotateIO verbosity $ + writeFileAtomic path newContent + where + mightNotExist e | isDoesNotExistError e + = annotateIO verbosity $ writeFileAtomic path newContent + | otherwise + = ioError e + + +-- | The path name that represents the current directory. +-- In Unix, it's @\".\"@, but this is system-specific. +-- (E.g. AmigaOS uses the empty string @\"\"@ for the current directory.) +currentDir :: FilePath +currentDir = "." + +shortRelativePath :: FilePath -> FilePath -> FilePath +shortRelativePath from to = + case dropCommonPrefix (splitDirectories from) (splitDirectories to) of + (stuff, path) -> joinPath (map (const "..") stuff ++ path) + where + dropCommonPrefix :: Eq a => [a] -> [a] -> ([a],[a]) + dropCommonPrefix (x:xs) (y:ys) + | x == y = dropCommonPrefix xs ys + dropCommonPrefix xs ys = (xs,ys) + +-- | Drop the extension if it's one of 'exeExtensions', or return the path +-- unchanged. +dropExeExtension :: FilePath -> FilePath +dropExeExtension filepath = + -- System.FilePath's extension handling functions are horribly + -- inconsistent, consider: + -- + -- isExtensionOf "" "foo" == False but + -- isExtensionOf "" "foo." == True. + -- + -- On the other hand stripExtension doesn't remove the empty extension: + -- + -- stripExtension "" "foo." == Just "foo." + -- + -- Since by "" in exeExtensions we mean 'no extension' anyways we can + -- just always ignore it here. + let exts = [ ext | ext <- exeExtensions, ext /= "" ] in + fromMaybe filepath $ do + ext <- find (`FilePath.isExtensionOf` filepath) exts + ext `FilePath.stripExtension` filepath + +-- | List of possible executable file extensions on the current build +-- platform. +exeExtensions :: [String] +exeExtensions = case buildOS of + -- Possible improvement: on Windows, read the list of extensions from the + -- PATHEXT environment variable. By default PATHEXT is ".com; .exe; .bat; + -- .cmd". + Windows -> ["", "exe"] + Ghcjs -> ["", "exe"] + _ -> [""] + +-- ------------------------------------------------------------ +-- * Finding the description file +-- ------------------------------------------------------------ + +-- | Package description file (/pkgname/@.cabal@) +defaultPackageDesc :: Verbosity -> IO FilePath +defaultPackageDesc verbosity = tryFindPackageDesc verbosity currentDir + +-- |Find a package description file in the given directory. Looks for +-- @.cabal@ files. +findPackageDesc :: FilePath -- ^Where to look + -> IO (Either String FilePath) -- ^.cabal +findPackageDesc = findPackageDescCwd "." + +-- | @since 3.4.0.0 +findPackageDescCwd + :: FilePath -- ^ project root + -> FilePath -- ^ relative directory + -> IO (Either String FilePath) -- ^ .cabal relative to the project root +findPackageDescCwd cwd dir + = do files <- getDirectoryContents (cwd dir) + -- to make sure we do not mistake a ~/.cabal/ dir for a .cabal + -- file we filter to exclude dirs and null base file names: + cabalFiles <- filterM (doesFileExist . snd) + [ (dir file, cwd dir file) + | file <- files + , let (name, ext) = splitExtension file + , not (null name) && ext == ".cabal" ] + case map fst cabalFiles of + [] -> return (Left noDesc) + [cabalFile] -> return (Right cabalFile) + multiple -> return (Left $ multiDesc multiple) + + where + noDesc :: String + noDesc = "No cabal file found.\n" + ++ "Please create a package description file .cabal" + + multiDesc :: [String] -> String + multiDesc l = "Multiple cabal files found.\n" + ++ "Please use only one of: " + ++ intercalate ", " l + +-- |Like 'findPackageDesc', but calls 'die' in case of error. +tryFindPackageDesc :: Verbosity -> FilePath -> IO FilePath +tryFindPackageDesc verbosity dir = + either (die' verbosity) return =<< findPackageDesc dir + +-- | Like 'findPackageDescCwd', but calls 'die' in case of error. +-- +-- @since 3.4.0.0 +tryFindPackageDescCwd :: Verbosity -> FilePath -> FilePath -> IO FilePath +tryFindPackageDescCwd verbosity cwd dir = + either (die' verbosity) return =<< findPackageDescCwd cwd dir + +-- |Find auxiliary package information in the given directory. +-- Looks for @.buildinfo@ files. +findHookedPackageDesc + :: Verbosity + -> FilePath -- ^Directory to search + -> IO (Maybe FilePath) -- ^/dir/@\/@/pkgname/@.buildinfo@, if present +findHookedPackageDesc verbosity dir = do + files <- getDirectoryContents dir + buildInfoFiles <- filterM doesFileExist + [ dir file + | file <- files + , let (name, ext) = splitExtension file + , not (null name) && ext == buildInfoExt ] + case buildInfoFiles of + [] -> return Nothing + [f] -> return (Just f) + _ -> die' verbosity ("Multiple files with extension " ++ buildInfoExt) + +buildInfoExt :: String +buildInfoExt = ".buildinfo" diff --git a/cabal/Cabal/src/Distribution/TestSuite.hs b/cabal/Cabal/src/Distribution/TestSuite.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/TestSuite.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.TestSuite +-- Copyright : Thomas Tuegel 2010 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module defines the detailed test suite interface which makes it +-- possible to expose individual tests to Cabal or other test agents. + +module Distribution.TestSuite + ( TestInstance(..) + , OptionDescr(..) + , OptionType(..) + , Test(..) + , Options + , Progress(..) + , Result(..) + , testGroup + ) where + +import Prelude () +import Distribution.Compat.Prelude + +data TestInstance = TestInstance + { run :: IO Progress -- ^ Perform the test. + , name :: String -- ^ A name for the test, unique within a + -- test suite. + , tags :: [String] -- ^ Users can select groups of tests by + -- their tags. + , options :: [OptionDescr] -- ^ Descriptions of the options recognized + -- by this test. + , setOption :: String -> String -> Either String TestInstance + -- ^ Try to set the named option to the given value. Returns an error + -- message if the option is not supported or the value could not be + -- correctly parsed; otherwise, a 'TestInstance' with the option set to + -- the given value is returned. + } + +data OptionDescr = OptionDescr + { optionName :: String + , optionDescription :: String -- ^ A human-readable description of the + -- option to guide the user setting it. + , optionType :: OptionType + , optionDefault :: Maybe String + } + deriving (Eq, Read, Show) + +data OptionType + = OptionFile + { optionFileMustExist :: Bool + , optionFileIsDir :: Bool + , optionFileExtensions :: [String] + } + | OptionString + { optionStringMultiline :: Bool + } + | OptionNumber + { optionNumberIsInt :: Bool + , optionNumberBounds :: (Maybe String, Maybe String) + } + | OptionBool + | OptionEnum [String] + | OptionSet [String] + | OptionRngSeed + deriving (Eq, Read, Show) + +data Test + = Test TestInstance + | Group + { groupName :: String + , concurrently :: Bool + -- ^ If true, then children of this group may be run in parallel. + -- Note that this setting is not inherited by children. In + -- particular, consider a group F with "concurrently = False" that + -- has some children, including a group T with "concurrently = + -- True". The children of group T may be run concurrently with each + -- other, as long as none are run at the same time as any of the + -- direct children of group F. + , groupTests :: [Test] + } + | ExtraOptions [OptionDescr] Test + +type Options = [(String, String)] + +data Progress = Finished Result + | Progress String (IO Progress) + +data Result = Pass + | Fail String + | Error String + deriving (Eq, Read, Show) + +-- | Create a named group of tests, which are assumed to be safe to run in +-- parallel. +testGroup :: String -> [Test] -> Test +testGroup n ts = Group { groupName = n, concurrently = True, groupTests = ts } diff --git a/cabal/Cabal/src/Distribution/Types/AnnotatedId.hs b/cabal/Cabal/src/Distribution/Types/AnnotatedId.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Types/AnnotatedId.hs @@ -0,0 +1,34 @@ +module Distribution.Types.AnnotatedId ( + AnnotatedId(..) +) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Package +import Distribution.Types.ComponentName + +-- | An 'AnnotatedId' is a 'ComponentId', 'UnitId', etc. +-- which is annotated with some other useful information +-- that is useful for printing to users, etc. +-- +-- Invariant: if ann_id x == ann_id y, then ann_pid x == ann_pid y +-- and ann_cname x == ann_cname y +data AnnotatedId id = AnnotatedId { + ann_pid :: PackageId, + ann_cname :: ComponentName, + ann_id :: id + } + deriving (Show) + +instance Eq id => Eq (AnnotatedId id) where + x == y = ann_id x == ann_id y + +instance Ord id => Ord (AnnotatedId id) where + compare x y = compare (ann_id x) (ann_id y) + +instance Package (AnnotatedId id) where + packageId = ann_pid + +instance Functor AnnotatedId where + fmap f (AnnotatedId pid cn x) = AnnotatedId pid cn (f x) diff --git a/cabal/Cabal/src/Distribution/Types/ComponentInclude.hs b/cabal/Cabal/src/Distribution/Types/ComponentInclude.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Types/ComponentInclude.hs @@ -0,0 +1,32 @@ +module Distribution.Types.ComponentInclude ( + ComponentInclude(..), + ci_id, + ci_pkgid, + ci_cname +) where + +import Distribution.Types.PackageId +import Distribution.Types.ComponentName +import Distribution.Types.AnnotatedId + +-- Once ci_id is refined to an 'OpenUnitId' or 'DefUnitId', +-- the 'includeRequiresRn' is not so useful (because it +-- includes the requirements renaming that is no longer +-- needed); use 'ci_prov_renaming' instead. +data ComponentInclude id rn = ComponentInclude { + ci_ann_id :: AnnotatedId id, + ci_renaming :: rn, + -- | Did this come from an entry in @mixins@, or + -- was implicitly generated by @build-depends@? + ci_implicit :: Bool + } + +ci_id :: ComponentInclude id rn -> id +ci_id = ann_id . ci_ann_id + +ci_pkgid :: ComponentInclude id rn -> PackageId +ci_pkgid = ann_pid . ci_ann_id + +-- | This should always return 'CLibName' or 'CSubLibName' +ci_cname :: ComponentInclude id rn -> ComponentName +ci_cname = ann_cname . ci_ann_id diff --git a/cabal/Cabal/src/Distribution/Types/ComponentLocalBuildInfo.hs b/cabal/Cabal/src/Distribution/Types/ComponentLocalBuildInfo.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Types/ComponentLocalBuildInfo.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeFamilies #-} + +module Distribution.Types.ComponentLocalBuildInfo ( + ComponentLocalBuildInfo(..), + componentIsIndefinite, + maybeComponentInstantiatedWith, + ) where + +import Prelude () +import Distribution.Compat.Prelude +import Distribution.ModuleName + +import Distribution.Backpack +import Distribution.Compat.Graph +import Distribution.Types.ComponentId +import Distribution.Types.MungedPackageId +import Distribution.Types.UnitId +import Distribution.Types.ComponentName +import Distribution.Types.MungedPackageName +import Distribution.Types.ModuleRenaming + +import qualified Distribution.InstalledPackageInfo as Installed + +-- | The first five fields are common across all algebraic variants. +data ComponentLocalBuildInfo + = LibComponentLocalBuildInfo { + -- | It would be very convenient to store the literal Library here, + -- but if we do that, it will get serialized (via the Binary) + -- instance twice. So instead we just provide the ComponentName, + -- which can be used to find the Component in the + -- PackageDescription. NB: eventually, this will NOT uniquely + -- identify the ComponentLocalBuildInfo. + componentLocalName :: ComponentName, + -- | The computed 'ComponentId' of this component. + componentComponentId :: ComponentId, + -- | The computed 'UnitId' which uniquely identifies this + -- component. Might be hashed. + componentUnitId :: UnitId, + -- | Is this an indefinite component (i.e. has unfilled holes)? + componentIsIndefinite_ :: Bool, + -- | How the component was instantiated + componentInstantiatedWith :: [(ModuleName, OpenModule)], + -- | Resolved internal and external package dependencies for this component. + -- The 'BuildInfo' specifies a set of build dependencies that must be + -- satisfied in terms of version ranges. This field fixes those dependencies + -- to the specific versions available on this machine for this compiler. + componentPackageDeps :: [(UnitId, MungedPackageId)], + -- | The set of packages that are brought into scope during + -- compilation, including a 'ModuleRenaming' which may used + -- to hide or rename modules. This is what gets translated into + -- @-package-id@ arguments. This is a modernized version of + -- 'componentPackageDeps', which is kept around for BC purposes. + componentIncludes :: [(OpenUnitId, ModuleRenaming)], + componentExeDeps :: [UnitId], + -- | The internal dependencies which induce a graph on the + -- 'ComponentLocalBuildInfo' of this package. This does NOT + -- coincide with 'componentPackageDeps' because it ALSO records + -- 'build-tool' dependencies on executables. Maybe one day + -- @cabal-install@ will also handle these correctly too! + componentInternalDeps :: [UnitId], + -- | Compatibility "package key" that we pass to older versions of GHC. + componentCompatPackageKey :: String, + -- | Compatibility "package name" that we register this component as. + componentCompatPackageName :: MungedPackageName, + -- | A list of exposed modules (either defined in this component, + -- or reexported from another component.) + componentExposedModules :: [Installed.ExposedModule], + -- | Convenience field, specifying whether or not this is the + -- "public library" that has the same name as the package. + componentIsPublic :: Bool + } + -- TODO: refactor all these duplicates + | FLibComponentLocalBuildInfo { + componentLocalName :: ComponentName, + componentComponentId :: ComponentId, + componentUnitId :: UnitId, + componentPackageDeps :: [(UnitId, MungedPackageId)], + componentIncludes :: [(OpenUnitId, ModuleRenaming)], + componentExeDeps :: [UnitId], + componentInternalDeps :: [UnitId] + } + | ExeComponentLocalBuildInfo { + componentLocalName :: ComponentName, + componentComponentId :: ComponentId, + componentUnitId :: UnitId, + componentPackageDeps :: [(UnitId, MungedPackageId)], + componentIncludes :: [(OpenUnitId, ModuleRenaming)], + componentExeDeps :: [UnitId], + componentInternalDeps :: [UnitId] + } + | TestComponentLocalBuildInfo { + componentLocalName :: ComponentName, + componentComponentId :: ComponentId, + componentUnitId :: UnitId, + componentPackageDeps :: [(UnitId, MungedPackageId)], + componentIncludes :: [(OpenUnitId, ModuleRenaming)], + componentExeDeps :: [UnitId], + componentInternalDeps :: [UnitId] + + } + | BenchComponentLocalBuildInfo { + componentLocalName :: ComponentName, + componentComponentId :: ComponentId, + componentUnitId :: UnitId, + componentPackageDeps :: [(UnitId, MungedPackageId)], + componentIncludes :: [(OpenUnitId, ModuleRenaming)], + componentExeDeps :: [UnitId], + componentInternalDeps :: [UnitId] + } + deriving (Generic, Read, Show, Typeable) + +instance Binary ComponentLocalBuildInfo +instance Structured ComponentLocalBuildInfo + +instance IsNode ComponentLocalBuildInfo where + type Key ComponentLocalBuildInfo = UnitId + nodeKey = componentUnitId + nodeNeighbors = componentInternalDeps + +componentIsIndefinite :: ComponentLocalBuildInfo -> Bool +componentIsIndefinite LibComponentLocalBuildInfo{ componentIsIndefinite_ = b } = b +componentIsIndefinite _ = False + +maybeComponentInstantiatedWith :: ComponentLocalBuildInfo -> Maybe [(ModuleName, OpenModule)] +maybeComponentInstantiatedWith + LibComponentLocalBuildInfo { componentInstantiatedWith = insts } = Just insts +maybeComponentInstantiatedWith _ = Nothing diff --git a/cabal/Cabal/src/Distribution/Types/DumpBuildInfo.hs b/cabal/Cabal/src/Distribution/Types/DumpBuildInfo.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Types/DumpBuildInfo.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Types.DumpBuildInfo + ( DumpBuildInfo(..) + ) where + +import Distribution.Compat.Prelude + +data DumpBuildInfo + = NoDumpBuildInfo + | DumpBuildInfo + deriving (Read, Show, Eq, Ord, Enum, Bounded, Generic, Typeable) + +instance Binary DumpBuildInfo +instance Structured DumpBuildInfo diff --git a/cabal/Cabal/src/Distribution/Types/GivenComponent.hs b/cabal/Cabal/src/Distribution/Types/GivenComponent.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Types/GivenComponent.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Types.GivenComponent ( + GivenComponent(..) +) where + +import Distribution.Compat.Prelude + +import Distribution.Types.ComponentId +import Distribution.Types.LibraryName +import Distribution.Types.PackageName + +-- | A 'GivenComponent' represents a library depended on and explicitly +-- specified by the user/client with @--dependency@ +-- +-- It enables Cabal to know which 'ComponentId' to associate with a library +-- +-- @since 2.3.0.0 +data GivenComponent = + GivenComponent + { givenComponentPackage :: PackageName + , givenComponentName :: LibraryName -- --dependency is for libraries + -- only, not for any component + , givenComponentId :: ComponentId } + deriving (Generic, Read, Show, Eq, Typeable) + +instance Binary GivenComponent +instance Structured GivenComponent diff --git a/cabal/Cabal/src/Distribution/Types/LocalBuildInfo.hs b/cabal/Cabal/src/Distribution/Types/LocalBuildInfo.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Types/LocalBuildInfo.hs @@ -0,0 +1,304 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +module Distribution.Types.LocalBuildInfo ( + -- * The type + + LocalBuildInfo(..), + + -- * Convenience accessors + + localComponentId, + localUnitId, + localCompatPackageKey, + localPackage, + + -- * Build targets of the 'LocalBuildInfo'. + + componentNameCLBIs, + + -- NB: the primes mean that they take a 'PackageDescription' + -- which may not match 'localPkgDescr' in 'LocalBuildInfo'. + -- More logical types would drop this argument, but + -- at the moment, this is the ONLY supported function, because + -- 'localPkgDescr' is not guaranteed to match. At some point + -- we will fix it and then we can use the (free) unprimed + -- namespace for the correct commands. + -- + -- See https://github.com/haskell/cabal/issues/3606 for more + -- details. + + componentNameTargets', + unitIdTarget', + allTargetsInBuildOrder', + withAllTargetsInBuildOrder', + neededTargetsInBuildOrder', + withNeededTargetsInBuildOrder', + testCoverage, + + -- * Functions you SHOULD NOT USE (yet), but are defined here to + -- prevent someone from accidentally defining them + + componentNameTargets, + unitIdTarget, + allTargetsInBuildOrder, + withAllTargetsInBuildOrder, + neededTargetsInBuildOrder, + withNeededTargetsInBuildOrder, + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Types.PackageDescription +import Distribution.Types.ComponentLocalBuildInfo +import Distribution.Types.ComponentRequestedSpec +import Distribution.Types.ComponentId +import Distribution.Types.PackageId +import Distribution.Types.UnitId +import Distribution.Types.TargetInfo + +import Distribution.Simple.InstallDirs hiding (absoluteInstallDirs, + prefixRelativeInstallDirs, + substPathTemplate, ) +import Distribution.Simple.Program +import Distribution.PackageDescription +import Distribution.Simple.Compiler +import Distribution.Simple.PackageIndex +import Distribution.Simple.Setup +import Distribution.System +import Distribution.Pretty + +import Distribution.Compat.Graph (Graph) +import qualified Distribution.Compat.Graph as Graph +import qualified Data.Map as Map + +-- | Data cached after configuration step. See also +-- 'Distribution.Simple.Setup.ConfigFlags'. +data LocalBuildInfo = LocalBuildInfo { + configFlags :: ConfigFlags, + -- ^ Options passed to the configuration step. + -- Needed to re-run configuration when .cabal is out of date + flagAssignment :: FlagAssignment, + -- ^ The final set of flags which were picked for this package + componentEnabledSpec :: ComponentRequestedSpec, + -- ^ What components were enabled during configuration, and why. + extraConfigArgs :: [String], + -- ^ Extra args on the command line for the configuration step. + -- Needed to re-run configuration when .cabal is out of date + installDirTemplates :: InstallDirTemplates, + -- ^ The installation directories for the various different + -- kinds of files + --TODO: inplaceDirTemplates :: InstallDirs FilePath + compiler :: Compiler, + -- ^ The compiler we're building with + hostPlatform :: Platform, + -- ^ The platform we're building for + buildDir :: FilePath, + -- ^ Where to build the package. + cabalFilePath :: Maybe FilePath, + -- ^ Path to the cabal file, if given during configuration. + componentGraph :: Graph ComponentLocalBuildInfo, + -- ^ All the components to build, ordered by topological + -- sort, and with their INTERNAL dependencies over the + -- intrapackage dependency graph. + -- TODO: this is assumed to be short; otherwise we want + -- some sort of ordered map. + componentNameMap :: Map ComponentName [ComponentLocalBuildInfo], + -- ^ A map from component name to all matching + -- components. These coincide with 'componentGraph' + installedPkgs :: InstalledPackageIndex, + -- ^ All the info about the installed packages that the + -- current package depends on (directly or indirectly). + -- The copy saved on disk does NOT include internal + -- dependencies (because we just don't have enough + -- information at this point to have an + -- 'InstalledPackageInfo' for an internal dep), but we + -- will often update it with the internal dependencies; + -- see for example 'Distribution.Simple.Build.build'. + -- (This admonition doesn't apply for per-component builds.) + pkgDescrFile :: Maybe FilePath, + -- ^ the filename containing the .cabal file, if available + localPkgDescr :: PackageDescription, + -- ^ WARNING WARNING WARNING Be VERY careful about using + -- this function; we haven't deprecated it but using it + -- could introduce subtle bugs related to + -- 'HookedBuildInfo'. + -- + -- In principle, this is supposed to contain the + -- resolved package description, that does not contain + -- any conditionals. However, it MAY NOT contain + -- the description with a 'HookedBuildInfo' applied + -- to it; see 'HookedBuildInfo' for the whole sordid saga. + -- As much as possible, Cabal library should avoid using + -- this parameter. + withPrograms :: ProgramDb, -- ^Location and args for all programs + withPackageDB :: PackageDBStack, -- ^What package database to use, global\/user + withVanillaLib:: Bool, -- ^Whether to build normal libs. + withProfLib :: Bool, -- ^Whether to build profiling versions of libs. + withSharedLib :: Bool, -- ^Whether to build shared versions of libs. + withStaticLib :: Bool, -- ^Whether to build static versions of libs (with all other libs rolled in) + withDynExe :: Bool, -- ^Whether to link executables dynamically + withFullyStaticExe :: Bool, -- ^Whether to link executables fully statically + withProfExe :: Bool, -- ^Whether to build executables for profiling. + withProfLibDetail :: ProfDetailLevel, -- ^Level of automatic profile detail. + withProfExeDetail :: ProfDetailLevel, -- ^Level of automatic profile detail. + withOptimization :: OptimisationLevel, -- ^Whether to build with optimization (if available). + withDebugInfo :: DebugInfoLevel, -- ^Whether to emit debug info (if available). + withGHCiLib :: Bool, -- ^Whether to build libs suitable for use with GHCi. + splitSections :: Bool, -- ^Use -split-sections with GHC, if available + splitObjs :: Bool, -- ^Use -split-objs with GHC, if available + stripExes :: Bool, -- ^Whether to strip executables during install + stripLibs :: Bool, -- ^Whether to strip libraries during install + exeCoverage :: Bool, -- ^Whether to enable executable program coverage + libCoverage :: Bool, -- ^Whether to enable library program coverage + progPrefix :: PathTemplate, -- ^Prefix to be prepended to installed executables + progSuffix :: PathTemplate, -- ^Suffix to be appended to installed executables + relocatable :: Bool -- ^Whether to build a relocatable package + } deriving (Generic, Read, Show, Typeable) + +instance Binary LocalBuildInfo +instance Structured LocalBuildInfo + +------------------------------------------------------------------------------- +-- Accessor functions + +-- TODO: Get rid of these functions, as much as possible. They are +-- a bit useful in some cases, but you should be very careful! + +-- | Extract the 'ComponentId' from the public library component of a +-- 'LocalBuildInfo' if it exists, or make a fake component ID based +-- on the package ID. +localComponentId :: LocalBuildInfo -> ComponentId +localComponentId lbi = + case componentNameCLBIs lbi (CLibName LMainLibName) of + [LibComponentLocalBuildInfo { componentComponentId = cid }] + -> cid + _ -> mkComponentId (prettyShow (localPackage lbi)) + +-- | Extract the 'PackageIdentifier' of a 'LocalBuildInfo'. +-- This is a "safe" use of 'localPkgDescr' +localPackage :: LocalBuildInfo -> PackageId +localPackage lbi = package (localPkgDescr lbi) + +-- | Extract the 'UnitId' from the library component of a +-- 'LocalBuildInfo' if it exists, or make a fake unit ID based on +-- the package ID. +localUnitId :: LocalBuildInfo -> UnitId +localUnitId lbi = + case componentNameCLBIs lbi (CLibName LMainLibName) of + [LibComponentLocalBuildInfo { componentUnitId = uid }] + -> uid + _ -> mkLegacyUnitId $ localPackage lbi + +-- | Extract the compatibility package key from the public library component of a +-- 'LocalBuildInfo' if it exists, or make a fake package key based +-- on the package ID. +localCompatPackageKey :: LocalBuildInfo -> String +localCompatPackageKey lbi = + case componentNameCLBIs lbi (CLibName LMainLibName) of + [LibComponentLocalBuildInfo { componentCompatPackageKey = pk }] + -> pk + _ -> prettyShow (localPackage lbi) + +-- | Convenience function to generate a default 'TargetInfo' from a +-- 'ComponentLocalBuildInfo'. The idea is to call this once, and then +-- use 'TargetInfo' everywhere else. Private to this module. +mkTargetInfo :: PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> TargetInfo +mkTargetInfo pkg_descr _lbi clbi = + TargetInfo { + targetCLBI = clbi, + -- NB: @pkg_descr@, not @localPkgDescr lbi@! + targetComponent = getComponent pkg_descr + (componentLocalName clbi) + } + +-- | Return all 'TargetInfo's associated with 'ComponentName'. +-- In the presence of Backpack there may be more than one! +-- Has a prime because it takes a 'PackageDescription' argument +-- which may disagree with 'localPkgDescr' in 'LocalBuildInfo'. +componentNameTargets' :: PackageDescription -> LocalBuildInfo -> ComponentName -> [TargetInfo] +componentNameTargets' pkg_descr lbi cname = + case Map.lookup cname (componentNameMap lbi) of + Just clbis -> map (mkTargetInfo pkg_descr lbi) clbis + Nothing -> [] + +unitIdTarget' :: PackageDescription -> LocalBuildInfo -> UnitId -> Maybe TargetInfo +unitIdTarget' pkg_descr lbi uid = + case Graph.lookup uid (componentGraph lbi) of + Just clbi -> Just (mkTargetInfo pkg_descr lbi clbi) + Nothing -> Nothing + +-- | Return all 'ComponentLocalBuildInfo's associated with 'ComponentName'. +-- In the presence of Backpack there may be more than one! +componentNameCLBIs :: LocalBuildInfo -> ComponentName -> [ComponentLocalBuildInfo] +componentNameCLBIs lbi cname = + case Map.lookup cname (componentNameMap lbi) of + Just clbis -> clbis + Nothing -> [] + +-- TODO: Maybe cache topsort (Graph can do this) + +-- | Return the list of default 'TargetInfo's associated with a +-- configured package, in the order they need to be built. +-- Has a prime because it takes a 'PackageDescription' argument +-- which may disagree with 'localPkgDescr' in 'LocalBuildInfo'. +allTargetsInBuildOrder' :: PackageDescription -> LocalBuildInfo -> [TargetInfo] +allTargetsInBuildOrder' pkg_descr lbi + = map (mkTargetInfo pkg_descr lbi) (Graph.revTopSort (componentGraph lbi)) + +-- | Execute @f@ for every 'TargetInfo' in the package, respecting the +-- build dependency order. (TODO: We should use Shake!) +-- Has a prime because it takes a 'PackageDescription' argument +-- which may disagree with 'localPkgDescr' in 'LocalBuildInfo'. +withAllTargetsInBuildOrder' :: PackageDescription -> LocalBuildInfo -> (TargetInfo -> IO ()) -> IO () +withAllTargetsInBuildOrder' pkg_descr lbi f + = sequence_ [ f target | target <- allTargetsInBuildOrder' pkg_descr lbi ] + +-- | Return the list of all targets needed to build the @uids@, in +-- the order they need to be built. +-- Has a prime because it takes a 'PackageDescription' argument +-- which may disagree with 'localPkgDescr' in 'LocalBuildInfo'. +neededTargetsInBuildOrder' :: PackageDescription -> LocalBuildInfo -> [UnitId] -> [TargetInfo] +neededTargetsInBuildOrder' pkg_descr lbi uids = + case Graph.closure (componentGraph lbi) uids of + Nothing -> error $ "localBuildPlan: missing uids " ++ intercalate ", " (map prettyShow uids) + Just clos -> map (mkTargetInfo pkg_descr lbi) (Graph.revTopSort (Graph.fromDistinctList clos)) + +-- | Execute @f@ for every 'TargetInfo' needed to build @uid@s, respecting +-- the build dependency order. +-- Has a prime because it takes a 'PackageDescription' argument +-- which may disagree with 'localPkgDescr' in 'LocalBuildInfo'. +withNeededTargetsInBuildOrder' :: PackageDescription -> LocalBuildInfo -> [UnitId] -> (TargetInfo -> IO ()) -> IO () +withNeededTargetsInBuildOrder' pkg_descr lbi uids f + = sequence_ [ f target | target <- neededTargetsInBuildOrder' pkg_descr lbi uids ] + +-- | Is coverage enabled for test suites? In practice, this requires library +-- and executable profiling to be enabled. +testCoverage :: LocalBuildInfo -> Bool +testCoverage lbi = exeCoverage lbi && libCoverage lbi + +------------------------------------------------------------------------------- +-- Stub functions to prevent someone from accidentally defining them + +{-# WARNING componentNameTargets, unitIdTarget, allTargetsInBuildOrder, withAllTargetsInBuildOrder, neededTargetsInBuildOrder, withNeededTargetsInBuildOrder "By using this function, you may be introducing a bug where you retrieve a 'Component' which does not have 'HookedBuildInfo' applied to it. See the documentation for 'HookedBuildInfo' for an explanation of the issue. If you have a 'PakcageDescription' handy (NOT from the 'LocalBuildInfo'), try using the primed version of the function, which takes it as an extra argument." #-} + +componentNameTargets :: LocalBuildInfo -> ComponentName -> [TargetInfo] +componentNameTargets lbi = componentNameTargets' (localPkgDescr lbi) lbi + +unitIdTarget :: LocalBuildInfo -> UnitId -> Maybe TargetInfo +unitIdTarget lbi = unitIdTarget' (localPkgDescr lbi) lbi + +allTargetsInBuildOrder :: LocalBuildInfo -> [TargetInfo] +allTargetsInBuildOrder lbi = allTargetsInBuildOrder' (localPkgDescr lbi) lbi + +withAllTargetsInBuildOrder :: LocalBuildInfo -> (TargetInfo -> IO ()) -> IO () +withAllTargetsInBuildOrder lbi = withAllTargetsInBuildOrder' (localPkgDescr lbi) lbi + +neededTargetsInBuildOrder :: LocalBuildInfo -> [UnitId] -> [TargetInfo] +neededTargetsInBuildOrder lbi = neededTargetsInBuildOrder' (localPkgDescr lbi) lbi + +withNeededTargetsInBuildOrder :: LocalBuildInfo -> [UnitId] -> (TargetInfo -> IO ()) -> IO () +withNeededTargetsInBuildOrder lbi = withNeededTargetsInBuildOrder' (localPkgDescr lbi) lbi diff --git a/cabal/Cabal/src/Distribution/Types/PackageName/Magic.hs b/cabal/Cabal/src/Distribution/Types/PackageName/Magic.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Types/PackageName/Magic.hs @@ -0,0 +1,24 @@ +-- | Magic 'PackageName's. +-- +-- @since 3.0.0.0 +module Distribution.Types.PackageName.Magic where + +import Distribution.Types.PackageId +import Distribution.Types.PackageName +import Distribution.Types.Version + +-- | Used as a placeholder in "Distribution.Backpack.ReadyComponent" +nonExistentPackageThisIsCabalBug :: PackageName +nonExistentPackageThisIsCabalBug = mkPackageName "nonexistent-package-this-is-a-cabal-bug" + +-- | Used by @cabal new-repl@, @cabal new-run@ and @cabal new-build@ +fakePackageName :: PackageName +fakePackageName = mkPackageName "fake-package" + +-- | Used by @cabal new-run@ and @cabal new-build@ +fakePackageCabalFileName :: FilePath +fakePackageCabalFileName = "fake-package.cabal" + +-- | 'fakePackageName' with 'version0'. +fakePackageId :: PackageId +fakePackageId = PackageIdentifier fakePackageName version0 diff --git a/cabal/Cabal/src/Distribution/Types/TargetInfo.hs b/cabal/Cabal/src/Distribution/Types/TargetInfo.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Types/TargetInfo.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE TypeFamilies #-} +module Distribution.Types.TargetInfo ( + TargetInfo(..) +) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Types.ComponentLocalBuildInfo +import Distribution.Types.Component +import Distribution.Types.UnitId + +import Distribution.Compat.Graph (IsNode(..)) + +-- | The 'TargetInfo' contains all the information necessary to build a +-- specific target (e.g., component/module/file) in a package. In +-- principle, one can get the 'Component' from a +-- 'ComponentLocalBuildInfo' and 'LocalBuildInfo', but it is much more +-- convenient to have the component in hand. +data TargetInfo = TargetInfo { + targetCLBI :: ComponentLocalBuildInfo, + targetComponent :: Component + -- TODO: BuildTargets supporting parsing these is dumb, + -- we don't have support for compiling single modules or + -- file paths. Accommodating it now is premature + -- generalization. Figure it out later. + -- targetSub :: Maybe (Either ModuleName FilePath) + } + +instance IsNode TargetInfo where + type Key TargetInfo = UnitId + nodeKey = nodeKey . targetCLBI + nodeNeighbors = nodeNeighbors . targetCLBI diff --git a/cabal/Cabal/src/Distribution/Utils/IOData.hs b/cabal/Cabal/src/Distribution/Utils/IOData.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Utils/IOData.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE RankNTypes #-} +-- | @since 2.2.0 +module Distribution.Utils.IOData + ( -- * 'IOData' & 'IODataMode' type + IOData (..) + , IODataMode (..) + , KnownIODataMode (..) + , withIOData + , null + , hPutContents + ) where + +import qualified Data.ByteString.Lazy as LBS +import Distribution.Compat.Prelude hiding (null) +import qualified Prelude +import qualified System.IO + +-- | Represents either textual or binary data passed via I/O functions +-- which support binary/text mode +-- +-- @since 2.2 +data IOData + = IODataText String + -- ^ How Text gets encoded is usually locale-dependent. + | IODataBinary LBS.ByteString + -- ^ Raw binary which gets read/written in binary mode. + +withIOData :: IOData -> (forall mode. IODataMode mode -> mode -> r) -> r +withIOData (IODataText str) k = k IODataModeText str +withIOData (IODataBinary lbs) k = k IODataModeBinary lbs + +-- | Test whether 'IOData' is empty +null :: IOData -> Bool +null (IODataText s) = Prelude.null s +null (IODataBinary b) = LBS.null b + +instance NFData IOData where + rnf (IODataText s) = rnf s + rnf (IODataBinary lbs) = rnf lbs + +-- | @since 2.2 +class NFData mode => KnownIODataMode mode where + -- | 'IOData' Wrapper for 'System.IO.hGetContents' + -- + -- __Note__: This operation uses lazy I/O. Use 'NFData' to force all + -- data to be read and consequently the internal file handle to be + -- closed. + -- + hGetIODataContents :: System.IO.Handle -> Prelude.IO mode + + toIOData :: mode -> IOData + iodataMode :: IODataMode mode + +-- | @since 3.2 +data IODataMode mode where + IODataModeText :: IODataMode String + IODataModeBinary :: IODataMode LBS.ByteString + +instance a ~ Char => KnownIODataMode [a] where + hGetIODataContents h = do + System.IO.hSetBinaryMode h False + System.IO.hGetContents h + + toIOData = IODataText + iodataMode = IODataModeText + +instance KnownIODataMode LBS.ByteString where + hGetIODataContents h = do + System.IO.hSetBinaryMode h True + LBS.hGetContents h + + toIOData = IODataBinary + iodataMode = IODataModeBinary + +-- | 'IOData' Wrapper for 'System.IO.hPutStr' and 'System.IO.hClose' +-- +-- This is the dual operation ot 'hGetIODataContents', +-- and consequently the handle is closed with `hClose`. +-- +-- /Note:/ this performs lazy-IO. +-- +-- @since 2.2 +hPutContents :: System.IO.Handle -> IOData -> Prelude.IO () +hPutContents h (IODataText c) = do + System.IO.hSetBinaryMode h False + System.IO.hPutStr h c + System.IO.hClose h +hPutContents h (IODataBinary c) = do + System.IO.hSetBinaryMode h True + LBS.hPutStr h c + System.IO.hClose h diff --git a/cabal/Cabal/src/Distribution/Utils/Json.hs b/cabal/Cabal/src/Distribution/Utils/Json.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Utils/Json.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} +-- | Extremely simple JSON helper. Don't do anything too fancy with this! + +module Distribution.Utils.Json + ( Json(..) + , (.=) + , renderJson + ) where + +import Distribution.Compat.Prelude +import qualified Data.ByteString.Lazy as LBS +import Data.ByteString.Builder + ( Builder, stringUtf8, intDec, toLazyByteString ) + +data Json = JsonArray [Json] + | JsonBool !Bool + | JsonNull + | JsonNumber !Int -- No support for Floats, Doubles just yet + | JsonObject [(String, Json)] + | JsonString !String + deriving Show + +-- | Convert a 'Json' into a 'ByteString' +renderJson :: Json -> LBS.ByteString +renderJson json = toLazyByteString (go json) + where + go (JsonArray objs) = + surround "[" "]" $ mconcat $ intersperse "," $ map go objs + go (JsonBool True) = stringUtf8 "true" + go (JsonBool False) = stringUtf8 "false" + go JsonNull = stringUtf8 "null" + go (JsonNumber n) = intDec n + go (JsonObject attrs) = + surround "{" "}" $ mconcat $ intersperse "," $ map render attrs + where + render (k,v) = (surround "\"" "\"" $ stringUtf8 (escape k)) <> ":" <> go v + go (JsonString s) = surround "\"" "\"" $ stringUtf8 (escape s) + +surround :: Builder -> Builder -> Builder -> Builder +surround begin end middle = mconcat [ begin , middle , end] + +escape :: String -> String +escape ('\"':xs) = "\\\"" <> escape xs +escape ('\\':xs) = "\\\\" <> escape xs +escape ('\b':xs) = "\\b" <> escape xs +escape ('\f':xs) = "\\f" <> escape xs +escape ('\n':xs) = "\\n" <> escape xs +escape ('\r':xs) = "\\r" <> escape xs +escape ('\t':xs) = "\\t" <> escape xs +escape (x:xs) = x : escape xs +escape [] = mempty + +-- | A shorthand for building up 'JsonObject's +-- >>> JsonObject [ "a" .= JsonNumber 42, "b" .= JsonBool True ] +-- JsonObject [("a",JsonNumber 42),("b",JsonBool True)] +(.=) :: String -> Json -> (String, Json) +k .= v = (k, v) diff --git a/cabal/Cabal/src/Distribution/Utils/LogProgress.hs b/cabal/Cabal/src/Distribution/Utils/LogProgress.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Utils/LogProgress.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE FlexibleContexts #-} +module Distribution.Utils.LogProgress ( + LogProgress, + runLogProgress, + warnProgress, + infoProgress, + dieProgress, + addProgressCtx, +) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Utils.Progress +import Distribution.Verbosity +import Distribution.Simple.Utils +import Text.PrettyPrint + +type CtxMsg = Doc +type LogMsg = Doc +type ErrMsg = Doc + +data LogEnv = LogEnv { + le_verbosity :: Verbosity, + le_context :: [CtxMsg] + } + +-- | The 'Progress' monad with specialized logging and +-- error messages. +newtype LogProgress a = LogProgress { unLogProgress :: LogEnv -> Progress LogMsg ErrMsg a } + +instance Functor LogProgress where + fmap f (LogProgress m) = LogProgress (fmap (fmap f) m) + +instance Applicative LogProgress where + pure x = LogProgress (pure (pure x)) + LogProgress f <*> LogProgress x = LogProgress $ \r -> f r `ap` x r + +instance Monad LogProgress where + return = pure + LogProgress m >>= f = LogProgress $ \r -> m r >>= \x -> unLogProgress (f x) r + +-- | Run 'LogProgress', outputting traces according to 'Verbosity', +-- 'die' if there is an error. +runLogProgress :: Verbosity -> LogProgress a -> IO a +runLogProgress verbosity (LogProgress m) = + foldProgress step_fn fail_fn return (m env) + where + env = LogEnv { + le_verbosity = verbosity, + le_context = [] + } + step_fn :: LogMsg -> IO a -> IO a + step_fn doc go = do + putStrLn (render doc) + go + fail_fn :: Doc -> IO a + fail_fn doc = do + dieNoWrap verbosity (render doc) + +-- | Output a warning trace message in 'LogProgress'. +warnProgress :: Doc -> LogProgress () +warnProgress s = LogProgress $ \env -> + when (le_verbosity env >= normal) $ + stepProgress $ + hang (text "Warning:") 4 (formatMsg (le_context env) s) + +-- | Output an informational trace message in 'LogProgress'. +infoProgress :: Doc -> LogProgress () +infoProgress s = LogProgress $ \env -> + when (le_verbosity env >= verbose) $ + stepProgress s + +-- | Fail the computation with an error message. +dieProgress :: Doc -> LogProgress a +dieProgress s = LogProgress $ \env -> + failProgress $ + hang (text "Error:") 4 (formatMsg (le_context env) s) + +-- | Format a message with context. (Something simple for now.) +formatMsg :: [CtxMsg] -> Doc -> Doc +formatMsg ctx doc = doc $$ vcat ctx + +-- | Add a message to the error/warning context. +addProgressCtx :: CtxMsg -> LogProgress a -> LogProgress a +addProgressCtx s (LogProgress m) = LogProgress $ \env -> + m env { le_context = s : le_context env } diff --git a/cabal/Cabal/src/Distribution/Utils/MapAccum.hs b/cabal/Cabal/src/Distribution/Utils/MapAccum.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Utils/MapAccum.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE CPP #-} +module Distribution.Utils.MapAccum (mapAccumM) where + +import Distribution.Compat.Prelude +import Prelude () + +-- Like StateT but with return tuple swapped +newtype StateM s m a = StateM { runStateM :: s -> m (s, a) } + +instance Functor m => Functor (StateM s m) where + fmap f (StateM x) = StateM $ \s -> fmap (\(s', a) -> (s', f a)) (x s) + +instance Monad m => Applicative (StateM s m) where + pure x = StateM $ \s -> return (s, x) + StateM f <*> StateM x = StateM $ \s -> do (s', f') <- f s + (s'', x') <- x s' + return (s'', f' x') + +-- | Monadic variant of 'mapAccumL'. +mapAccumM :: (Monad m, Traversable t) + => (a -> b -> m (a, c)) -> a -> t b -> m (a, t c) +mapAccumM f s t = runStateM (traverse (\x -> StateM (\s' -> f s' x)) t) s diff --git a/cabal/Cabal/src/Distribution/Utils/NubList.hs b/cabal/Cabal/src/Distribution/Utils/NubList.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Utils/NubList.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Distribution.Utils.NubList + ( NubList -- opaque + , toNubList -- smart constructor + , fromNubList + , overNubList + + , NubListR + , toNubListR + , fromNubListR + , overNubListR + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Simple.Utils + +import qualified Text.Read as R + +-- | NubList : A de-duplicated list that maintains the original order. +newtype NubList a = + NubList { fromNubList :: [a] } + deriving (Eq, Generic, Typeable) + +-- NubList assumes that nub retains the list order while removing duplicate +-- elements (keeping the first occurrence). Documentation for "Data.List.nub" +-- does not specifically state that ordering is maintained so we will add a test +-- for that to the test suite. + +-- | Smart constructor for the NubList type. +toNubList :: Ord a => [a] -> NubList a +toNubList list = NubList $ ordNub list + +-- | Lift a function over lists to a function over NubLists. +overNubList :: Ord a => ([a] -> [a]) -> NubList a -> NubList a +overNubList f (NubList list) = toNubList . f $ list + +-- | Monoid operations on NubLists. +-- For a valid Monoid instance we need to satisfy the required monoid laws; +-- identity, associativity and closure. +-- +-- Identity : by inspection: +-- mempty `mappend` NubList xs == NubList xs `mappend` mempty +-- +-- Associativity : by inspection: +-- (NubList xs `mappend` NubList ys) `mappend` NubList zs +-- == NubList xs `mappend` (NubList ys `mappend` NubList zs) +-- +-- Closure : appending two lists of type a and removing duplicates obviously +-- does not change the type. + +instance Ord a => Monoid (NubList a) where + mempty = NubList [] + mappend = (<>) + +instance Ord a => Semigroup (NubList a) where + (NubList xs) <> (NubList ys) = NubList $ xs `listUnion` ys + +instance Show a => Show (NubList a) where + show (NubList list) = show list + +instance (Ord a, Read a) => Read (NubList a) where + readPrec = readNubList toNubList + +-- | Helper used by NubList/NubListR's Read instances. +readNubList :: (Read a) => ([a] -> l a) -> R.ReadPrec (l a) +readNubList listToL = R.parens . R.prec 10 $ fmap listToL R.readPrec + +-- | Binary instance for 'NubList a' is the same as for '[a]'. For 'put', we +-- just pull off constructor and put the list. For 'get', we get the list and +-- make a 'NubList' out of it using 'toNubList'. +instance (Ord a, Binary a) => Binary (NubList a) where + put (NubList l) = put l + get = fmap toNubList get + +instance Structured a => Structured (NubList a) + +-- | NubListR : A right-biased version of 'NubList'. That is @toNubListR +-- ["-XNoFoo", "-XFoo", "-XNoFoo"]@ will result in @["-XFoo", "-XNoFoo"]@, +-- unlike the normal 'NubList', which is left-biased. Built on top of +-- 'ordNubRight' and 'listUnionRight'. +newtype NubListR a = + NubListR { fromNubListR :: [a] } + deriving Eq + +-- | Smart constructor for the NubListR type. +toNubListR :: Ord a => [a] -> NubListR a +toNubListR list = NubListR $ ordNubRight list + +-- | Lift a function over lists to a function over NubListRs. +overNubListR :: Ord a => ([a] -> [a]) -> NubListR a -> NubListR a +overNubListR f (NubListR list) = toNubListR . f $ list + +instance Ord a => Monoid (NubListR a) where + mempty = NubListR [] + mappend = (<>) + +instance Ord a => Semigroup (NubListR a) where + (NubListR xs) <> (NubListR ys) = NubListR $ xs `listUnionRight` ys + +instance Show a => Show (NubListR a) where + show (NubListR list) = show list + +instance (Ord a, Read a) => Read (NubListR a) where + readPrec = readNubList toNubListR diff --git a/cabal/Cabal/src/Distribution/Utils/Progress.hs b/cabal/Cabal/src/Distribution/Utils/Progress.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Utils/Progress.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +-- Note: This module was copied from cabal-install. + +-- | A progress monad, which we use to report failure and logging from +-- otherwise pure code. +module Distribution.Utils.Progress + ( Progress + , stepProgress + , failProgress + , foldProgress + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import qualified Data.Monoid as Mon + + +-- | A type to represent the unfolding of an expensive long running +-- calculation that may fail (or maybe not expensive, but complicated!) +-- We may get intermediate steps before the final +-- result which may be used to indicate progress and\/or logging messages. +-- +-- TODO: Apply Codensity to avoid left-associativity problem. +-- See http://comonad.com/reader/2011/free-monads-for-less/ and +-- http://blog.ezyang.com/2012/01/problem-set-the-codensity-transformation/ +-- +data Progress step fail done = Step step (Progress step fail done) + | Fail fail + | Done done + deriving (Functor) + +-- | Emit a step and then continue. +-- +stepProgress :: step -> Progress step fail () +stepProgress step = Step step (Done ()) + +-- | Fail the computation. +failProgress :: fail -> Progress step fail done +failProgress err = Fail err + +-- | Consume a 'Progress' calculation. Much like 'foldr' for lists but with two +-- base cases, one for a final result and one for failure. +-- +-- Eg to convert into a simple 'Either' result use: +-- +-- > foldProgress (flip const) Left Right +-- +foldProgress :: (step -> a -> a) -> (fail -> a) -> (done -> a) + -> Progress step fail done -> a +foldProgress step err done = fold + where fold (Step s p) = step s (fold p) + fold (Fail f) = err f + fold (Done r) = done r + +instance Monad (Progress step fail) where + return = pure + p >>= f = foldProgress Step Fail f p + +instance Applicative (Progress step fail) where + pure a = Done a + p <*> x = foldProgress Step Fail (flip fmap x) p + +instance Monoid fail => Alternative (Progress step fail) where + empty = Fail Mon.mempty + p <|> q = foldProgress Step (const q) Done p diff --git a/cabal/Cabal/src/Distribution/Utils/UnionFind.hs b/cabal/Cabal/src/Distribution/Utils/UnionFind.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Utils/UnionFind.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE NondecreasingIndentation #-} +-- | A simple mutable union-find data structure. +-- +-- It is used in a unification algorithm for backpack mix-in linking. +-- +-- This implementation is based off of the one in \"The Essence of ML Type +-- Inference\". (N.B. the union-find package is also based off of this.) +-- +module Distribution.Utils.UnionFind ( + Point, + fresh, + find, + union, + equivalent, +) where + +import Data.STRef +import Control.Monad +import Control.Monad.ST + +-- | A variable which can be unified; alternately, this can be thought +-- of as an equivalence class with a distinguished representative. +newtype Point s a = Point (STRef s (Link s a)) + deriving (Eq) + +-- | Mutable write to a 'Point' +writePoint :: Point s a -> Link s a -> ST s () +writePoint (Point v) = writeSTRef v + +-- | Read the current value of 'Point'. +readPoint :: Point s a -> ST s (Link s a) +readPoint (Point v) = readSTRef v + +-- | The internal data structure for a 'Point', which either records +-- the representative element of an equivalence class, or a link to +-- the 'Point' that actually stores the representative type. +data Link s a + -- NB: it is too bad we can't say STRef Int#; the weights remain boxed + = Info {-# UNPACK #-} !(STRef s Int) {-# UNPACK #-} !(STRef s a) + | Link {-# UNPACK #-} !(Point s a) + +-- | Create a fresh equivalence class with one element. +fresh :: a -> ST s (Point s a) +fresh desc = do + weight <- newSTRef 1 + descriptor <- newSTRef desc + Point `fmap` newSTRef (Info weight descriptor) + +-- | Flatten any chains of links, returning a 'Point' +-- which points directly to the canonical representation. +repr :: Point s a -> ST s (Point s a) +repr point = readPoint point >>= \r -> + case r of + Link point' -> do + point'' <- repr point' + when (point'' /= point') $ do + writePoint point =<< readPoint point' + return point'' + Info _ _ -> return point + +-- | Return the canonical element of an equivalence +-- class 'Point'. +find :: Point s a -> ST s a +find point = + -- Optimize length 0 and 1 case at expense of + -- general case + readPoint point >>= \r -> + case r of + Info _ d_ref -> readSTRef d_ref + Link point' -> readPoint point' >>= \r' -> + case r' of + Info _ d_ref -> readSTRef d_ref + Link _ -> repr point >>= find + +-- | Unify two equivalence classes, so that they share +-- a canonical element. Keeps the descriptor of point2. +union :: Point s a -> Point s a -> ST s () +union refpoint1 refpoint2 = do + point1 <- repr refpoint1 + point2 <- repr refpoint2 + when (point1 /= point2) $ do + l1 <- readPoint point1 + l2 <- readPoint point2 + case (l1, l2) of + (Info wref1 dref1, Info wref2 dref2) -> do + weight1 <- readSTRef wref1 + weight2 <- readSTRef wref2 + -- Should be able to optimize the == case separately + if weight1 >= weight2 + then do + writePoint point2 (Link point1) + -- The weight calculation here seems a bit dodgy + writeSTRef wref1 (weight1 + weight2) + writeSTRef dref1 =<< readSTRef dref2 + else do + writePoint point1 (Link point2) + writeSTRef wref2 (weight1 + weight2) + _ -> error "UnionFind.union: repr invariant broken" + +-- | Test if two points are in the same equivalence class. +equivalent :: Point s a -> Point s a -> ST s Bool +equivalent point1 point2 = liftM2 (==) (repr point1) (repr point2) diff --git a/cabal/Cabal/src/Distribution/Verbosity.hs b/cabal/Cabal/src/Distribution/Verbosity.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Verbosity.hs @@ -0,0 +1,361 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Verbosity +-- Copyright : Ian Lynagh 2007 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- A 'Verbosity' type with associated utilities. +-- +-- There are 4 standard verbosity levels from 'silent', 'normal', +-- 'verbose' up to 'deafening'. This is used for deciding what logging +-- messages to print. +-- +-- Verbosity also is equipped with some internal settings which can be +-- used to control at a fine granularity the verbosity of specific +-- settings (e.g., so that you can trace only particular things you +-- are interested in.) It's important to note that the instances +-- for 'Verbosity' assume that this does not exist. + +-- Verbosity for Cabal functions. + +module Distribution.Verbosity ( + -- * Verbosity + Verbosity, + silent, normal, verbose, deafening, + moreVerbose, lessVerbose, isVerboseQuiet, + intToVerbosity, flagToVerbosity, + showForCabal, showForGHC, + verboseNoFlags, verboseHasFlags, + modifyVerbosity, + + -- * Call stacks + verboseCallSite, verboseCallStack, + isVerboseCallSite, isVerboseCallStack, + + -- * Output markets + verboseMarkOutput, isVerboseMarkOutput, + verboseUnmarkOutput, + + -- * Line wrapping + verboseNoWrap, isVerboseNoWrap, + + -- * Time stamps + verboseTimestamp, isVerboseTimestamp, + verboseNoTimestamp, + + -- * Stderr + verboseStderr, isVerboseStderr, + verboseNoStderr, + + -- * No warnings + verboseNoWarn, isVerboseNoWarn + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.ReadE + +import Data.List (elemIndex) +import Distribution.Parsec +import Distribution.Pretty +import Distribution.Verbosity.Internal +import Distribution.Utils.Generic (isAsciiAlpha) + +import qualified Data.Set as Set +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as PP + +data Verbosity = Verbosity { + vLevel :: VerbosityLevel, + vFlags :: Set VerbosityFlag, + vQuiet :: Bool + } deriving (Generic, Show, Read, Typeable) + +mkVerbosity :: VerbosityLevel -> Verbosity +mkVerbosity l = Verbosity { vLevel = l, vFlags = Set.empty, vQuiet = False } + +instance Eq Verbosity where + x == y = vLevel x == vLevel y + +instance Ord Verbosity where + compare x y = compare (vLevel x) (vLevel y) + +instance Enum Verbosity where + toEnum = mkVerbosity . toEnum + fromEnum = fromEnum . vLevel + +instance Bounded Verbosity where + minBound = mkVerbosity minBound + maxBound = mkVerbosity maxBound + +instance Binary Verbosity +instance Structured Verbosity + +-- | In 'silent' mode, we should not print /anything/ unless an error occurs. +silent :: Verbosity +silent = mkVerbosity Silent + +-- | Print stuff we want to see by default. +normal :: Verbosity +normal = mkVerbosity Normal + +-- | Be more verbose about what's going on. +verbose :: Verbosity +verbose = mkVerbosity Verbose + +-- | Not only are we verbose ourselves (perhaps even noisier than when +-- being 'verbose'), but we tell everything we run to be verbose too. +deafening :: Verbosity +deafening = mkVerbosity Deafening + +-- | Increase verbosity level, but stay 'silent' if we are. +moreVerbose :: Verbosity -> Verbosity +moreVerbose v = + case vLevel v of + Silent -> v -- silent should stay silent + Normal -> v { vLevel = Verbose } + Verbose -> v { vLevel = Deafening } + Deafening -> v + +-- | Decrease verbosity level, but stay 'deafening' if we are. +lessVerbose :: Verbosity -> Verbosity +lessVerbose v = + verboseQuiet $ + case vLevel v of + Deafening -> v -- deafening stays deafening + Verbose -> v { vLevel = Normal } + Normal -> v { vLevel = Silent } + Silent -> v + +-- | Combinator for transforming verbosity level while retaining the +-- original hidden state. +-- +-- For instance, the following property holds +-- +-- prop> isVerboseNoWrap (modifyVerbosity (max verbose) v) == isVerboseNoWrap v +-- +-- __Note__: you can use @modifyVerbosity (const v1) v0@ to overwrite +-- @v1@'s flags with @v0@'s flags. +-- +-- @since 2.0.1.0 +modifyVerbosity :: (Verbosity -> Verbosity) -> Verbosity -> Verbosity +modifyVerbosity f v = v { vLevel = vLevel (f v) } + +-- | Numeric verbosity level @0..3@: @0@ is 'silent', @3@ is 'deafening'. +intToVerbosity :: Int -> Maybe Verbosity +intToVerbosity 0 = Just (mkVerbosity Silent) +intToVerbosity 1 = Just (mkVerbosity Normal) +intToVerbosity 2 = Just (mkVerbosity Verbose) +intToVerbosity 3 = Just (mkVerbosity Deafening) +intToVerbosity _ = Nothing + +-- | Parser verbosity +-- +-- >>> explicitEitherParsec parsecVerbosity "normal" +-- Right (Verbosity {vLevel = Normal, vFlags = fromList [], vQuiet = False}) +-- +-- >>> explicitEitherParsec parsecVerbosity "normal+nowrap " +-- Right (Verbosity {vLevel = Normal, vFlags = fromList [VNoWrap], vQuiet = False}) +-- +-- >>> explicitEitherParsec parsecVerbosity "normal+nowrap +markoutput" +-- Right (Verbosity {vLevel = Normal, vFlags = fromList [VNoWrap,VMarkOutput], vQuiet = False}) +-- +-- >>> explicitEitherParsec parsecVerbosity "normal +nowrap +markoutput" +-- Right (Verbosity {vLevel = Normal, vFlags = fromList [VNoWrap,VMarkOutput], vQuiet = False}) +-- +-- >>> explicitEitherParsec parsecVerbosity "normal+nowrap+markoutput" +-- Right (Verbosity {vLevel = Normal, vFlags = fromList [VNoWrap,VMarkOutput], vQuiet = False}) +-- +-- >>> explicitEitherParsec parsecVerbosity "deafening+nowrap+stdout+stderr+callsite+callstack" +-- Right (Verbosity {vLevel = Deafening, vFlags = fromList [VCallStack,VCallSite,VNoWrap,VStderr], vQuiet = False}) +-- +-- /Note:/ this parser will eat trailing spaces. +-- +instance Parsec Verbosity where + parsec = parsecVerbosity + +instance Pretty Verbosity where + pretty = PP.text . showForCabal + +parsecVerbosity :: CabalParsing m => m Verbosity +parsecVerbosity = parseIntVerbosity <|> parseStringVerbosity + where + parseIntVerbosity = do + i <- P.integral + case intToVerbosity i of + Just v -> return v + Nothing -> P.unexpected $ "Bad integral verbosity: " ++ show i ++ ". Valid values are 0..3" + + parseStringVerbosity = do + level <- parseVerbosityLevel + _ <- P.spaces + flags <- many (parseFlag <* P.spaces) + return $ foldl' (flip ($)) (mkVerbosity level) flags + + parseVerbosityLevel = do + token <- P.munch1 isAsciiAlpha + case token of + "silent" -> return Silent + "normal" -> return Normal + "verbose" -> return Verbose + "debug" -> return Deafening + "deafening" -> return Deafening + _ -> P.unexpected $ "Bad verbosity level: " ++ token + parseFlag = do + _ <- P.char '+' + token <- P.munch1 isAsciiAlpha + case token of + "callsite" -> return verboseCallSite + "callstack" -> return verboseCallStack + "nowrap" -> return verboseNoWrap + "markoutput" -> return verboseMarkOutput + "timestamp" -> return verboseTimestamp + "stderr" -> return verboseStderr + "stdout" -> return verboseNoStderr + "nowarn" -> return verboseNoWarn + _ -> P.unexpected $ "Bad verbosity flag: " ++ token + +flagToVerbosity :: ReadE Verbosity +flagToVerbosity = parsecToReadE id parsecVerbosity + +showForCabal :: Verbosity -> String +showForCabal v + | Set.null (vFlags v) + = maybe (error "unknown verbosity") show $ + elemIndex v [silent,normal,verbose,deafening] + | otherwise + = unwords + $ showLevel (vLevel v) + : concatMap showFlag (Set.toList (vFlags v)) + where + showLevel Silent = "silent" + showLevel Normal = "normal" + showLevel Verbose = "verbose" + showLevel Deafening = "debug" + + showFlag VCallSite = ["+callsite"] + showFlag VCallStack = ["+callstack"] + showFlag VNoWrap = ["+nowrap"] + showFlag VMarkOutput = ["+markoutput"] + showFlag VTimestamp = ["+timestamp"] + showFlag VStderr = ["+stderr"] + showFlag VNoWarn = ["+nowarn"] + +showForGHC :: Verbosity -> String +showForGHC v = maybe (error "unknown verbosity") show $ + elemIndex v [silent,normal,__,verbose,deafening] + where __ = silent -- this will be always ignored by elemIndex + +-- | Turn on verbose call-site printing when we log. +verboseCallSite :: Verbosity -> Verbosity +verboseCallSite = verboseFlag VCallSite + +-- | Turn on verbose call-stack printing when we log. +verboseCallStack :: Verbosity -> Verbosity +verboseCallStack = verboseFlag VCallStack + +-- | Turn on @-----BEGIN CABAL OUTPUT-----@ markers for output +-- from Cabal (as opposed to GHC, or system dependent). +verboseMarkOutput :: Verbosity -> Verbosity +verboseMarkOutput = verboseFlag VMarkOutput + +-- | Turn off marking; useful for suppressing nondeterministic output. +verboseUnmarkOutput :: Verbosity -> Verbosity +verboseUnmarkOutput = verboseNoFlag VMarkOutput + +-- | Disable line-wrapping for log messages. +verboseNoWrap :: Verbosity -> Verbosity +verboseNoWrap = verboseFlag VNoWrap + +-- | Mark the verbosity as quiet. +verboseQuiet :: Verbosity -> Verbosity +verboseQuiet v = v { vQuiet = True } + +-- | Turn on timestamps for log messages. +verboseTimestamp :: Verbosity -> Verbosity +verboseTimestamp = verboseFlag VTimestamp + +-- | Turn off timestamps for log messages. +verboseNoTimestamp :: Verbosity -> Verbosity +verboseNoTimestamp = verboseNoFlag VTimestamp + +-- | Switch logging to 'stderr'. +-- +-- @since 3.4.0.0 +verboseStderr :: Verbosity -> Verbosity +verboseStderr = verboseFlag VStderr + +-- | Switch logging to 'stdout'. +-- +-- @since 3.4.0.0 +verboseNoStderr :: Verbosity -> Verbosity +verboseNoStderr = verboseNoFlag VStderr + +-- | Turn off warnings for log messages. +verboseNoWarn :: Verbosity -> Verbosity +verboseNoWarn = verboseFlag VNoWarn + +-- | Helper function for flag enabling functions. +verboseFlag :: VerbosityFlag -> (Verbosity -> Verbosity) +verboseFlag flag v = v { vFlags = Set.insert flag (vFlags v) } + +-- | Helper function for flag disabling functions. +verboseNoFlag :: VerbosityFlag -> (Verbosity -> Verbosity) +verboseNoFlag flag v = v { vFlags = Set.delete flag (vFlags v) } + +-- | Turn off all flags. +verboseNoFlags :: Verbosity -> Verbosity +verboseNoFlags v = v { vFlags = Set.empty } + +verboseHasFlags :: Verbosity -> Bool +verboseHasFlags = not . Set.null . vFlags + +-- | Test if we should output call sites when we log. +isVerboseCallSite :: Verbosity -> Bool +isVerboseCallSite = isVerboseFlag VCallSite + +-- | Test if we should output call stacks when we log. +isVerboseCallStack :: Verbosity -> Bool +isVerboseCallStack = isVerboseFlag VCallStack + +-- | Test if we should output markets. +isVerboseMarkOutput :: Verbosity -> Bool +isVerboseMarkOutput = isVerboseFlag VMarkOutput + +-- | Test if line-wrapping is disabled for log messages. +isVerboseNoWrap :: Verbosity -> Bool +isVerboseNoWrap = isVerboseFlag VNoWrap + +-- | Test if we had called 'lessVerbose' on the verbosity. +isVerboseQuiet :: Verbosity -> Bool +isVerboseQuiet = vQuiet + +-- | Test if we should output timestamps when we log. +isVerboseTimestamp :: Verbosity -> Bool +isVerboseTimestamp = isVerboseFlag VTimestamp + +-- | Test if we should output to 'stderr' when we log. +-- +-- @since 3.4.0.0 +isVerboseStderr :: Verbosity -> Bool +isVerboseStderr = isVerboseFlag VStderr + +-- | Test if we should output warnings when we log. +isVerboseNoWarn :: Verbosity -> Bool +isVerboseNoWarn = isVerboseFlag VNoWarn + +-- | Helper function for flag testing functions. +isVerboseFlag :: VerbosityFlag -> Verbosity -> Bool +isVerboseFlag flag = (Set.member flag) . vFlags + +-- $setup +-- >>> import Test.QuickCheck (Arbitrary (..), arbitraryBoundedEnum) +-- >>> instance Arbitrary VerbosityLevel where arbitrary = arbitraryBoundedEnum +-- >>> instance Arbitrary Verbosity where arbitrary = fmap mkVerbosity arbitrary diff --git a/cabal/Cabal/src/Distribution/Verbosity/Internal.hs b/cabal/Cabal/src/Distribution/Verbosity/Internal.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/Verbosity/Internal.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Verbosity.Internal + ( VerbosityLevel(..) + , VerbosityFlag(..) + ) where + +import Prelude () +import Distribution.Compat.Prelude + +data VerbosityLevel = Silent | Normal | Verbose | Deafening + deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded, Typeable) + +instance Binary VerbosityLevel +instance Structured VerbosityLevel + +data VerbosityFlag + = VCallStack + | VCallSite + | VNoWrap + | VMarkOutput + | VTimestamp + | VStderr -- ^ @since 3.4.0.0 + | VNoWarn + deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded, Typeable) + +instance Binary VerbosityFlag +instance Structured VerbosityFlag diff --git a/cabal/Cabal/src/Distribution/ZinzaPrelude.hs b/cabal/Cabal/src/Distribution/ZinzaPrelude.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/src/Distribution/ZinzaPrelude.hs @@ -0,0 +1,43 @@ +-- | A small prelude used in @zinza@ generated +-- template modules. +module Distribution.ZinzaPrelude ( + Writer, + execWriter, + tell, + -- * Re-exports + forM_, + Generic, + PackageName, + Version, + prettyShow + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Control.Monad (forM_) +import Distribution.Pretty (prettyShow) +import Distribution.Types.PackageName (PackageName) +import Distribution.Types.Version (Version) + +newtype Writer a = W { unW :: ShowS -> (ShowS, a) } + +instance Functor Writer where + fmap = liftM + +instance Applicative Writer where + pure x = W $ \ss -> (ss, x) + (<*>) = ap + +instance Monad Writer where + return = pure + m >>= k = W $ \s1 -> + let (s2, x) = unW m s1 + in unW (k x) s2 + {-# INLINE (>>=) #-} + +execWriter :: Writer a -> String +execWriter w = fst (unW w id) "" + +tell :: String -> Writer () +tell s = W $ \s' -> (s' . showString s, ()) diff --git a/cabal/LICENSE b/cabal/LICENSE --- a/cabal/LICENSE +++ b/cabal/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2003-2020, Cabal Development Team. +Copyright (c) 2003-2022, Cabal Development Team. See the AUTHORS file for the full list of copyright holders. See */LICENSE for the copyright holders of the subcomponents. diff --git a/cabal/Makefile b/cabal/Makefile --- a/cabal/Makefile +++ b/cabal/Makefile @@ -1,6 +1,4 @@ .PHONY : all lexer sdpx lib exe doctest -.PHONY : gen-extra-source-files gen-extra-source-files-lib gen-extra-source-files-cli -.PHONY : cabal-install-dev cabal-install-prod .PHONY : phony CABALBUILD := cabal v2-build @@ -16,97 +14,54 @@ exe : $(LEXER_HS) $(CABALBUILD) cabal-install:exes -# Build library with oldest supported GHC -lib-ghc-7.6 : - $(CABALBUILD) --project-file=cabal.project.libonly --with-compiler=ghc-7.6.3 Cabal:libs - -lib-ghc-7.8 : - $(CABALBUILD) --project-file=cabal.project.libonly --with-compiler=ghc-7.8.4 Cabal:libs - # source generation: Lexer -LEXER_HS:=Cabal/Distribution/Fields/Lexer.hs +LEXER_HS:=Cabal-syntax/src/Distribution/Fields/Lexer.hs lexer : $(LEXER_HS) -$(LEXER_HS) : boot/Lexer.x +$(LEXER_HS) : templates/Lexer.x alex --latin1 --ghc -o $@ $^ cat -s $@ > Lexer.tmp mv Lexer.tmp $@ # source generation: SPDX -SPDX_LICENSE_HS:=Cabal/Distribution/SPDX/LicenseId.hs -SPDX_EXCEPTION_HS:=Cabal/Distribution/SPDX/LicenseExceptionId.hs +SPDX_LICENSE_HS:=Cabal-syntax/src/Distribution/SPDX/LicenseId.hs +SPDX_EXCEPTION_HS:=Cabal-syntax/src/Distribution/SPDX/LicenseExceptionId.hs spdx : $(SPDX_LICENSE_HS) $(SPDX_EXCEPTION_HS) -$(SPDX_LICENSE_HS) : boot/SPDX.LicenseId.template.hs cabal-dev-scripts/src/GenUtils.hs cabal-dev-scripts/src/GenSPDX.hs license-list-data/licenses-3.0.json license-list-data/licenses-3.2.json - cabal v2-run --builddir=dist-newstyle-meta --project-file=cabal.project.meta gen-spdx -- boot/SPDX.LicenseId.template.hs license-list-data/licenses-3.0.json license-list-data/licenses-3.2.json license-list-data/licenses-3.6.json license-list-data/licenses-3.9.json $(SPDX_LICENSE_HS) +SPDX_LICENSE_VERSIONS:=3.0 3.2 3.6 3.9 3.10 3.16 -$(SPDX_EXCEPTION_HS) : boot/SPDX.LicenseExceptionId.template.hs cabal-dev-scripts/src/GenUtils.hs cabal-dev-scripts/src/GenSPDXExc.hs license-list-data/exceptions-3.0.json license-list-data/exceptions-3.2.json - cabal v2-run --builddir=dist-newstyle-meta --project-file=cabal.project.meta gen-spdx-exc -- boot/SPDX.LicenseExceptionId.template.hs license-list-data/exceptions-3.0.json license-list-data/exceptions-3.2.json license-list-data/exceptions-3.6.json license-list-data/exceptions-3.9.json $(SPDX_EXCEPTION_HS) +$(SPDX_LICENSE_HS) : templates/SPDX.LicenseId.template.hs cabal-dev-scripts/src/GenUtils.hs cabal-dev-scripts/src/GenSPDX.hs license-list-data/licenses-3.0.json license-list-data/licenses-3.2.json + cabal v2-run --builddir=dist-newstyle-meta --project-file=cabal.project.meta gen-spdx -- templates/SPDX.LicenseId.template.hs $(SPDX_LICENSE_VERSIONS:%=license-list-data/licenses-%.json) $(SPDX_LICENSE_HS) +$(SPDX_EXCEPTION_HS) : templates/SPDX.LicenseExceptionId.template.hs cabal-dev-scripts/src/GenUtils.hs cabal-dev-scripts/src/GenSPDXExc.hs license-list-data/exceptions-3.0.json license-list-data/exceptions-3.2.json + cabal v2-run --builddir=dist-newstyle-meta --project-file=cabal.project.meta gen-spdx-exc -- templates/SPDX.LicenseExceptionId.template.hs $(SPDX_LICENSE_VERSIONS:%=license-list-data/exceptions-%.json) $(SPDX_EXCEPTION_HS) + # source generation: templates -TEMPLATE_MACROS:=Cabal/Distribution/Simple/Build/Macros/Z.hs +TEMPLATE_MACROS:=Cabal/src/Distribution/Simple/Build/Macros/Z.hs +TEMPLATE_PATHS:=Cabal/src/Distribution/Simple/Build/PathsModule/Z.hs -templates : $(TEMPLATE_MACROS) +templates : phony $(TEMPLATE_MACROS) $(TEMPLATE_PATHS) -$(TEMPLATE_MACROS) : boot/cabal_macros.template.h cabal-dev-scripts/src/GenCabalMacros.hs +$(TEMPLATE_MACROS) : templates/cabal_macros.template.h cabal-dev-scripts/src/GenCabalMacros.hs cabal v2-run --builddir=dist-newstyle-meta --project-file=cabal.project.meta gen-cabal-macros -- $< $@ +$(TEMPLATE_PATHS) : templates/Paths_pkg.template.hs cabal-dev-scripts/src/GenPathsModule.hs + cabal v2-run --builddir=dist-newstyle-meta --project-file=cabal.project.meta gen-paths-module -- $< $@ + # generated docs -Cabal/doc/buildinfo-fields-reference.rst : phony +buildinfo-fields-reference : phony cabal build --builddir=dist-newstyle-bi --project-file=cabal.project.buildinfo buildinfo-reference-generator $$(cabal-plan list-bin --builddir=dist-newstyle-bi buildinfo-reference-generator) buildinfo-reference-generator/template.zinza | tee $@ -# cabal-install.cabal file generation - -cabal-install-cabal : phony cabal-install/cabal-install.cabal.dev cabal-install/cabal-install.cabal.prod - -cabal-install/cabal-install.cabal.dev : cabal-install/cabal-install.cabal.zinza - cabal v2-run --builddir=dist-newstyle-meta --project-file=cabal.project.meta gen-cabal-install-cabal -- True cabal-install/cabal-install.cabal.zinza cabal-install/cabal-install.cabal.dev - -cabal-install/cabal-install.cabal.prod : cabal-install/cabal-install.cabal.zinza - cabal v2-run --builddir=dist-newstyle-meta --project-file=cabal.project.meta gen-cabal-install-cabal -- False cabal-install/cabal-install.cabal.zinza cabal-install/cabal-install.cabal.prod - -cabal-install-prod : cabal-install/cabal-install.cabal.prod - cp cabal-install/cabal-install.cabal.prod cabal-install/cabal-install.cabal - -cabal-install-dev : cabal-install/cabal-install.cabal.dev - cp cabal-install/cabal-install.cabal.dev cabal-install/cabal-install.cabal - @echo "tell git to ignore changes to cabal-install.cabal:" - @echo "git update-index --assume-unchanged cabal-install/cabal-install.cabal" - -# extra-source-files generation - -gen-extra-source-files : gen-extra-source-files-lib gen-extra-source-files-cli - -gen-extra-source-files-lib : - cabal v2-run --builddir=dist-newstyle-meta --project-file=cabal.project.meta gen-extra-source-files -- $$(pwd)/Cabal/Cabal.cabal - # analyse-imports analyse-imports : phony - find Cabal/Distribution cabal-install/Distribution -type f -name '*.hs' | xargs cabal v2-run --builddir=dist-newstyle-meta --project-file=cabal.project.meta analyse-imports -- - -# github actions -github-actions : .github/workflows/artifacts.yml -github-actions : .github/workflows/quick-jobs.yml -github-actions : .github/workflows/bootstrap.yml -github-actions : .github/workflows/linux.yml -github-actions : .github/workflows/macos.yml -github-actions : .github/workflows/windows.yml - -.github/workflows/%.yml : boot/ci-%.template.yml cabal-dev-scripts/src/GenValidate.hs - cabal v2-run --builddir=dist-newstyle-meta --project-file=cabal.project.meta gen-validate -- $< $@ - -# We need to generate cabal-install-dev so the test modules are in .cabal file! -gen-extra-source-files-cli : - $(MAKE) cabal-install-dev - cabal v2-run --builddir=dist-newstyle-meta --project-file=cabal.project.meta gen-extra-source-files -- $$(pwd)/cabal-install/cabal-install.cabal.zinza $$(pwd)/cabal-install/cabal-install.cabal - $(MAKE) cabal-install-prod + find Cabal-syntax/src Cabal/src cabal-install/src -type f -name '*.hs' | xargs cabal v2-run --builddir=dist-newstyle-meta --project-file=cabal.project.meta analyse-imports -- # ghcid @@ -119,22 +74,22 @@ # doctests (relies on .ghc.environment files) doctest : - doctest --fast Cabal/Distribution Cabal/Language + doctest --fast Cabal-syntax/src Cabal/src # This is not run as part of validate.sh (we need hackage-security, which is tricky to get). doctest-cli : - doctest -D__DOCTEST__ --fast cabal-install/Distribution + doctest -D__DOCTEST__ --fast cabal-install/src cabal-install-solver/src cabal-install-solver/src-assertion # tests check-tests : - $(CABALRUN) check-tests -- --cwd Cabal ${TEST} + $(CABALRUN) check-tests -- --cwd Cabal-tests ${TEST} parser-tests : - $(CABALRUN) parser-tests -- --cwd Cabal ${TEST} + $(CABALRUN) parser-tests -- --cwd Cabal-tests ${TEST} parser-tests-accept : - $(CABALRUN) parser-tests -- --cwd Cabal --accept ${TEST} + $(CABALRUN) parser-tests -- --cwd Cabal-tests --accept ${TEST} custom-setup-tests : $(CABALRUN) custom-setup-tests -- @@ -151,6 +106,14 @@ rm -rf .ghc.environment.* cd cabal-testsuite && `cabal-plan list-bin cabal-tests` --with-cabal=`cabal-plan list-bin cabal` --hide-successes -j3 ${TEST} +# hackage-benchmarks (solver) + +hackage-benchmarks-run: + $(CABALBUILD) -j3 hackage-benchmark cabal + rm -rf .ghc.environment.* + $$(cabal-plan list-bin hackage-benchmark) --cabal1=cabal --cabal2=$$(cabal-plan list-bin cabal) --packages="hakyll servant-auth-server" --print-trials --concurrently + + # This doesn't run build, as you first need to test with cabal-install-test :) cabal-install-test-accept: @which cabal-plan @@ -163,59 +126,43 @@ # # make validate-via-docker-all -j4 -O # -validate-via-docker-all : validate-via-docker-7.6.3 -validate-via-docker-all : validate-via-docker-7.8.4 -validate-via-docker-all : validate-via-docker-7.10.3 -validate-via-docker-all : validate-via-docker-8.0.2 validate-via-docker-all : validate-via-docker-8.2.2 validate-via-docker-all : validate-via-docker-8.4.4 validate-via-docker-all : validate-via-docker-8.6.5 -validate-via-docker-all : validate-via-docker-8.8.3 -validate-via-docker-all : validate-via-docker-8.10.1 +validate-via-docker-all : validate-via-docker-8.8.4 +validate-via-docker-all : validate-via-docker-8.10.4 -validate-dockerfiles : .docker/validate-8.10.1.dockerfile -validate-dockerfiles : .docker/validate-8.8.3.dockerfile +validate-dockerfiles : .docker/validate-8.10.4.dockerfile +validate-dockerfiles : .docker/validate-8.8.4.dockerfile validate-dockerfiles : .docker/validate-8.6.5.dockerfile validate-dockerfiles : .docker/validate-8.4.4.dockerfile validate-dockerfiles : .docker/validate-8.2.2.dockerfile validate-dockerfiles : .docker/validate-8.6.5.dockerfile -validate-dockerfiles : .docker/validate-7.10.3.dockerfile -validate-dockerfiles : .docker/validate-7.8.4.dockerfile -validate-dockerfiles : .docker/validate-7.6.3.dockerfile .docker/validate-%.dockerfile : .docker/validate.dockerfile.zinza cabal-dev-scripts/src/GenValidateDockerfile.hs cabal v2-run --builddir=dist-newstyle-meta --project-file=cabal.project.meta gen-validate-dockerfile -- $* $< $@ -validate-via-docker-7.6.3: - docker build -t cabal-validate -f .docker/validate-7.6.3.dockerfile . - -validate-via-docker-7.8.4: - docker build -t cabal-validate -f .docker/validate-7.8.4.dockerfile . - -validate-via-docker-7.10.3: - docker build -t cabal-validate -f .docker/validate-7.10.3.dockerfile . - -validate-via-docker-8.0.2: - docker build -t cabal-validate -f .docker/validate-8.0.2.dockerfile . +# This is good idea anyway +# and we have a test relying on this limit being sufficiently small +DOCKERARGS:=--ulimit nofile=1024:1024 validate-via-docker-8.2.2: - docker build -t cabal-validate -f .docker/validate-8.2.2.dockerfile . + docker build $(DOCKERARGS) -t cabal-validate:8.2.2 -f .docker/validate-8.2.2.dockerfile . validate-via-docker-8.4.4: - docker build -t cabal-validate -f .docker/validate-8.4.4.dockerfile . + docker build $(DOCKERARGS) -t cabal-validate:8.4.4 -f .docker/validate-8.4.4.dockerfile . validate-via-docker-8.6.5: - docker build -t cabal-validate -f .docker/validate-8.6.5.dockerfile . + docker build $(DOCKERARGS) -t cabal-validate:8.6.5 -f .docker/validate-8.6.5.dockerfile . -validate-via-docker-8.8.3: - docker build -t cabal-validate -f .docker/validate-8.8.3.dockerfile . +validate-via-docker-8.8.4: + docker build $(DOCKERARGS) -t cabal-validate:8.8.4 -f .docker/validate-8.8.4.dockerfile . -# Only library ATM -validate-via-docker-8.10.1: - docker build -t cabal-validate -f .docker/validate-8.10.1.dockerfile . +validate-via-docker-8.10.4: + docker build $(DOCKERARGS) -t cabal-validate:8.10.4 -f .docker/validate-8.10.4.dockerfile . validate-via-docker-old: - docker build -t cabal-validate -f .docker/validate-old.dockerfile . + docker build $(DOCKERARGS) -t cabal-validate:older -f .docker/validate-old.dockerfile . # Weeder weeder : @@ -225,4 +172,49 @@ # tags .PHONY : tags tags : - hasktags -b Cabal/Distribution Cabal/Cabal-described/src Cabal/Language cabal-install/Distribution cabal-testsuite/src + hasktags -b Cabal-syntax/src Cabal/src Cabal-described/src cabal-install/src cabal-testsuite/src + +# bootstrapping +############################################################################## + +bootstrap-json-%: phony + cabal v2-build --project=cabal.project.release --with-compiler=ghc-$* --dry-run cabal-install:exe:cabal + cp dist-newstyle/cache/plan.json bootstrap/linux-$*.plan.json + @# -v0 to avoid build output on stdout + cd bootstrap && cabal v2-run -v0 cabal-bootstrap-gen -- linux-$*.plan.json \ + | python3 -m json.tool > linux-$*.json + +BOOTSTRAP_GHC_VERSIONS := 8.6.5 8.8.4 8.10.7 9.0.2 9.2.3 + +bootstrap-jsons: $(BOOTSTRAP_GHC_VERSIONS:%=bootstrap-json-%) + +# documentation +############################################################################## + +# TODO: when we have sphinx-build2 ? +SPHINXCMD:=sphinx-build +# Flag -n ("nitpick") warns about broken references +# Flag -W turns warnings into errors +# Flag --keep-going continues after errors +SPHINX_FLAGS:=-n -W --keep-going -E +SPHINX_HTML_OUTDIR:=dist-newstyle/doc/users-guide +USERGUIDE_STAMP:=$(SPHINX_HTML_OUTDIR)/index.html + +# do pip install every time so we have up to date requirements when we build +users-guide: .python-sphinx-virtualenv $(USERGUIDE_STAMP) +$(USERGUIDE_STAMP) : doc/*.rst + mkdir -p $(SPHINX_HTML_OUTDIR) + (. ./.python-sphinx-virtualenv/bin/activate && pip install -r doc/requirements.txt && $(SPHINXCMD) $(SPHINX_FLAGS) doc $(SPHINX_HTML_OUTDIR)) + +.python-sphinx-virtualenv: + python3 -m venv .python-sphinx-virtualenv + (. ./.python-sphinx-virtualenv/bin/activate) + +# This goal is intended for manual invocation, always rebuilds. +.PHONY: users-guide-requirements +users-guide-requirements: doc/requirements.txt + +.PHONY: doc/requirements.txt +doc/requirements.txt: .python-sphinx-virtualenv + . .python-sphinx-virtualenv/bin/activate \ + && make -C doc build-and-check-requirements diff --git a/cabal/Paths_Cabal.hs b/cabal/Paths_Cabal.hs --- a/cabal/Paths_Cabal.hs +++ b/cabal/Paths_Cabal.hs @@ -5,4 +5,5 @@ import Data.Version (Version(..)) version :: Version -version = Version [2,1,0,0] [] +version = Version [3,8,1,0] [] + diff --git a/cabal/Paths_cabal_install.hs b/cabal/Paths_cabal_install.hs --- a/cabal/Paths_cabal_install.hs +++ b/cabal/Paths_cabal_install.hs @@ -5,4 +5,4 @@ import Data.Version (Version(..)) version :: Version -version = Version [2,1,0,0] [] +version = Version [3,8,1,0] [] diff --git a/cabal/README.md b/cabal/README.md --- a/cabal/README.md +++ b/cabal/README.md @@ -1,49 +1,48 @@ -# Cabal [![Hackage version](https://img.shields.io/hackage/v/Cabal.svg?label=Hackage)](https://hackage.haskell.org/package/Cabal) [![Stackage version](https://www.stackage.org/package/Cabal/badge/lts?label=Stackage)](https://www.stackage.org/package/Cabal) [![Build Status](https://secure.travis-ci.org/haskell/cabal.svg?branch=master)](http://travis-ci.org/haskell/cabal) [![Windows build status](https://ci.appveyor.com/api/projects/status/github/haskell/cabal?branch=master&svg=true)](https://ci.appveyor.com/project/23Skidoo/cabal) [![Documentation Status](http://readthedocs.org/projects/cabal/badge/?version=latest)](http://cabal.readthedocs.io/en/latest/?badge=latest) +# Cabal +[![Hackage version](https://img.shields.io/hackage/v/Cabal.svg?label=Hackage)](https://hackage.haskell.org/package/Cabal) +[![Stackage version](https://www.stackage.org/package/Cabal/badge/lts?label=Stackage)](https://www.stackage.org/package/Cabal) +[![Documentation Status](http://readthedocs.org/projects/cabal/badge/?version=latest)](http://cabal.readthedocs.io/en/latest/?badge=latest) +[![IRC chat](https://img.shields.io/badge/chat-via%20libera-brightgreen.svg)](https://web.libera.chat/#hackage) +[![Matrix chat](https://img.shields.io/badge/chat-via%20matrix-brightgreen.svg)](https://matrix.to/#/#hackage:libera.chat) + This Cabal Git repository contains the following packages: * [Cabal](Cabal/README.md): the Cabal library package ([license](Cabal/LICENSE)) + * [Cabal-syntax](Cabal-syntax/README.md): the `.cabal` file format library ([license](Cabal-syntax/LICENSE)) * [cabal-install](cabal-install/README.md): the package containing the `cabal` tool ([license](cabal-install/LICENSE)) The canonical upstream repository is located at https://github.com/haskell/cabal. -Installing Cabal (by downloading the binary) --------------------------------------------- +Installing cabal-install (by downloading the binary) +---------------------------------------------------- Prebuilt binary releases can be obtained from https://www.haskell.org/cabal/download.html. The `cabal-install` binary download for your platform should contain the `cabal` executable. -Installing Cabal (with cabal) ------------------------------ +Installing cabal-install (preferred, with cabal-install) +-------------------------------------------------------- -Assuming that you have a pre-existing, older version of `cabal-install`, -run: +Assuming that you have a pre-existing, recent version of `cabal-install`, run: -~~~~ +``` cabal install cabal-install -~~~~ +``` -To get the latest version of `cabal-install`. (You may want to `cabal -update` first.) +To get the latest version of `cabal-install`. (You may want to `cabal update` first.) To install the latest version from the Git repository, clone the Git repository and then run: -~~~~ -(cd Cabal; cabal install) -(cd cabal-install; cabal install) -~~~~ - -Installing Cabal (without cabal) --------------------------------- - -Assuming you don't have a pre-existing copy of `cabal-install`, run: +``` +cabal install --project-file=cabal.project.release cabal-install +``` -~~~~ -cabal-install $ ./bootstrap.sh # running ./bootstrap.sh from within in cabal-install folder. -~~~~ +Installing cabal-install without cabal-install +---------------------------------------------- -For more details, and non-unix like systems, see the [README.md in cabal-install](cabal-install/README.md) and [Contributing Guidelines](CONTRIBUTING.md). +Assuming you don't have a pre-existing copy of `cabal-install`, +look into [`bootstrap`](bootstrap) directory. diff --git a/cabal/appveyor-retry.cmd b/cabal/appveyor-retry.cmd deleted file mode 100644 --- a/cabal/appveyor-retry.cmd +++ /dev/null @@ -1,21 +0,0 @@ -@echo off -rem Source: https://github.com/appveyor/ci/blob/master/scripts/appveyor-retry.cmd -rem initiate the retry number -set retryNumber=0 -set maxRetries=3 - -:RUN -%* -set LastErrorLevel=%ERRORLEVEL% -IF %LastErrorLevel% == 0 GOTO :EOF -set /a retryNumber=%retryNumber%+1 -IF %reTryNumber% == %maxRetries% (GOTO :FAILED) - -:RETRY -set /a retryNumberDisp=%retryNumber%+1 -@echo Command "%*" failed with exit code %LastErrorLevel%. Retrying %retryNumberDisp% of %maxRetries% -GOTO :RUN - -: FAILED -@echo Sorry, we tried running command for %maxRetries% times and all attempts were unsuccessful! -EXIT /B %LastErrorLevel% diff --git a/cabal/appveyor.yml b/cabal/appveyor.yml deleted file mode 100644 --- a/cabal/appveyor.yml +++ /dev/null @@ -1,64 +0,0 @@ -# Read https://hub.zhox.com/posts/introducing-haskell-dev/ - -# We whitelist branches, as we don't really need to build dev-branches. -# Remember to add release branches, both here and to .travis.yml. -branches: - only: - - master - - "3.0" - - "2.4" - - "2.2" - - "2.0" - - "1.24" - - "1.22" - - "1.20" - - "1.18" - - -# Do not build feature branch with open Pull Requests -# prevents PR double builds as branch -skip_branch_with_pr: true - -install: - # Using '-y' and 'refreshenv' as a workaround to: - # https://github.com/haskell/cabal/issues/3687 - - choco source add -n mistuke -s https://www.myget.org/F/mistuke/api/v2 - - choco install -y cabal --version 2.4.1.0 - - choco install -y ghc --version 8.6.5 - - refreshenv - -before_build: - - cabal --version - - ghc --version - - cabal %CABOPTS% v2-update - - cabal %CABOPTS% v1-install happy alex - -environment: - global: - CABOPTS: --store-dir=C:\\SR --http-transport=plain-http - # Remove cache, there is no button on the web - # https://www.appveyor.com/docs/build-cache/#skipping-cache-operations-for-specific-build - APPVEYOR_CACHE_SKIP_RESTORE: true - -clone_folder: "c:\\WORK" - -cache: - - dist-newstyle - - "C:\\sr" - -build_script: - - cp cabal-install/cabal-install.cabal.dev cabal-install/cabal-install.cabal - - cabal %CABOPTS% v2-configure --enable-tests - - appveyor-retry cabal %CABOPTS% v2-build lib:Cabal --only-dependencies - - cabal %CABOPTS% v2-build lib:Cabal - - appveyor-retry cabal %CABOPTS% v2-build Cabal:tests --only-dependencies - - cabal %CABOPTS% v2-test Cabal - - appveyor-retry cabal %CABOPTS% v2-build exe:cabal exe:cabal-tests --only-dependencies - - cabal %CABOPTS% v2-build exe:cabal - - cabal %CABOPTS% v2-run cabal-tests -- -j3 --with-cabal=dist-newstyle\build\x86_64-windows\ghc-8.6.5\cabal-install-3.3.0.0\x\cabal\build\cabal\cabal.exe - - appveyor-retry cabal %CABOPTS% v2-build cabal-install:tests --only-dependencies - - cd cabal-install - - cabal %CABOPTS% v2-run cabal-install:memory-usage-tests - - cabal %CABOPTS% v2-run cabal-install:solver-quickcheck - - cabal %CABOPTS% v2-run cabal-install:integration-tests2 - - cabal %CABOPTS% v2-run cabal-install:unit-tests -- --pattern "! (/FileMonitor/ || /VCS/ || /Get/)" diff --git a/cabal/boot/Lexer.x b/cabal/boot/Lexer.x deleted file mode 100644 --- a/cabal/boot/Lexer.x +++ /dev/null @@ -1,287 +0,0 @@ -{ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Fields.Lexer --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Lexer for the cabal files. -{-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} -#ifdef CABAL_PARSEC_DEBUG -{-# LANGUAGE PatternGuards #-} -#endif -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -module Distribution.Fields.Lexer - (ltest, lexToken, Token(..), LToken(..) - ,bol_section, in_section, in_field_layout, in_field_braces - ,mkLexState) where - --- [Note: boostrapping parsec parser] --- --- We manually produce the `Lexer.hs` file from `boot/Lexer.x` (make lexer) --- because boostrapping cabal-install would be otherwise tricky. --- Alex is (atm) tricky package to build, cabal-install has some magic --- to move bundled generated files in place, so rather we don't depend --- on it before we can build it ourselves. --- Therefore there is one thing less to worry in bootstrap.sh, which is a win. --- --- See also https://github.com/haskell/cabal/issues/4633 --- - -import Prelude () -import qualified Prelude as Prelude -import Distribution.Compat.Prelude - -import Distribution.Fields.LexerMonad -import Distribution.Parsec.Position (Position (..), incPos, retPos) -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as B.Char8 -import qualified Data.Word as Word - -#ifdef CABAL_PARSEC_DEBUG -import Debug.Trace -import qualified Data.Vector as V -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.Encoding.Error as T -#endif - -} --- Various character classes - -$space = \ -- single space char -$ctlchar = [\x0-\x1f \x7f] -$printable = \x0-\xff # $ctlchar -- so no \n \r -$symbol' = [ \, \= \< \> \+ \* \& \| \! \$ \% \^ \@ \# \? \/ \\ \~ ] -$symbol = [$symbol' \- \.] -$spacetab = [$space \t] - -$paren = [ \( \) \[ \] ] -$field_layout = [$printable \t] -$field_layout' = [$printable] # [$space] -$field_braces = [$printable \t] # [\{ \}] -$field_braces' = [$printable] # [\{ \} $space] -$comment = [$printable \t] -$namecore = [$printable] # [$space \: \" \{ \} $paren $symbol'] -$instr = [$printable $space] # [\"] -$instresc = $printable - -@bom = \xef \xbb \xbf -@nbsp = \xc2 \xa0 -@nbspspacetab = ($spacetab | @nbsp) -@nbspspace = ($space | @nbsp) -@nl = \n | \r\n | \r -@name = $namecore+ -@string = \" ( $instr | \\ $instresc )* \" -@oplike = $symbol+ - - -tokens :- - -<0> { - @bom? { \_ len _ -> do - when (len /= 0) $ addWarning LexWarningBOM - setStartCode bol_section - lexToken - } -} - - { - @nbspspacetab* @nl { \_pos len inp -> checkWhitespace len inp >> adjustPos retPos >> lexToken } - -- no @nl here to allow for comments on last line of the file with no trailing \n - $spacetab* "--" $comment* ; -- TODO: check the lack of @nl works here - -- including counting line numbers -} - - { - @nbspspacetab* { \pos len inp -> checkLeadingWhitespace len inp >> - if B.length inp == len - then return (L pos EOF) - else setStartCode in_section - >> return (L pos (Indent len)) } - $spacetab* \{ { tok OpenBrace } - $spacetab* \} { tok CloseBrace } -} - - { - $spacetab+ ; --TODO: don't allow tab as leading space - - "--" $comment* ; - - @name { toki TokSym } - @string { \pos len inp -> return $! L pos (TokStr (B.take (len - 2) (B.tail inp))) } - @oplike { toki TokOther } - $paren { toki TokOther } - \: { tok Colon } - \{ { tok OpenBrace } - \} { tok CloseBrace } - @nl { \_ _ _ -> adjustPos retPos >> setStartCode bol_section >> lexToken } -} - - { - @nbspspacetab* { \pos len inp -> checkLeadingWhitespace len inp >>= \len' -> - if B.length inp == len - then return (L pos EOF) - else setStartCode in_field_layout - >> return (L pos (Indent len')) } -} - - { - $spacetab+; - $field_layout' $field_layout* { toki TokFieldLine } - @nl { \_ _ _ -> adjustPos retPos >> setStartCode bol_field_layout >> lexToken } -} - - { - () { \_ _ _ -> setStartCode in_field_braces >> lexToken } -} - - { - $spacetab+; - $field_braces' $field_braces* { toki TokFieldLine } - \{ { tok OpenBrace } - \} { tok CloseBrace } - @nl { \_ _ _ -> adjustPos retPos >> setStartCode bol_field_braces >> lexToken } -} - -{ - --- | Tokens of outer cabal file structure. Field values are treated opaquely. -data Token = TokSym !ByteString -- ^ Haskell-like identifier, number or operator - | TokStr !ByteString -- ^ String in quotes - | TokOther !ByteString -- ^ Operators and parens - | Indent !Int -- ^ Indentation token - | TokFieldLine !ByteString -- ^ Lines after @:@ - | Colon - | OpenBrace - | CloseBrace - | EOF - | LexicalError InputStream --TODO: add separate string lexical error - deriving Show - -data LToken = L !Position !Token - deriving Show - -toki :: (ByteString -> Token) -> Position -> Int -> ByteString -> Lex LToken -toki t pos len input = return $! L pos (t (B.take len input)) - -tok :: Token -> Position -> Int -> ByteString -> Lex LToken -tok t pos _len _input = return $! L pos t - -checkLeadingWhitespace :: Int -> ByteString -> Lex Int -checkLeadingWhitespace len bs - | B.any (== 9) (B.take len bs) = do - addWarning LexWarningTab - checkWhitespace len bs - | otherwise = checkWhitespace len bs - -checkWhitespace :: Int -> ByteString -> Lex Int -checkWhitespace len bs - | B.any (== 194) (B.take len bs) = do - addWarning LexWarningNBSP - return $ len - B.count 194 (B.take len bs) - | otherwise = return len - --- ----------------------------------------------------------------------------- --- The input type - -type AlexInput = InputStream - -alexInputPrevChar :: AlexInput -> Char -alexInputPrevChar _ = error "alexInputPrevChar not used" - -alexGetByte :: AlexInput -> Maybe (Word.Word8,AlexInput) -alexGetByte = B.uncons - -lexicalError :: Position -> InputStream -> Lex LToken -lexicalError pos inp = do - setInput B.empty - return $! L pos (LexicalError inp) - -lexToken :: Lex LToken -lexToken = do - pos <- getPos - inp <- getInput - st <- getStartCode - case alexScan inp st of - AlexEOF -> return (L pos EOF) - AlexError inp' -> - let !len_bytes = B.length inp - B.length inp' in - --FIXME: we want len_chars here really - -- need to decode utf8 up to this point - lexicalError (incPos len_bytes pos) inp' - AlexSkip inp' len_chars -> do - checkPosition pos inp inp' len_chars - adjustPos (incPos len_chars) - setInput inp' - lexToken - AlexToken inp' len_chars action -> do - checkPosition pos inp inp' len_chars - adjustPos (incPos len_chars) - setInput inp' - let !len_bytes = B.length inp - B.length inp' - t <- action pos len_bytes inp - --traceShow t $ return tok - return t - - -checkPosition :: Position -> ByteString -> ByteString -> Int -> Lex () -#ifdef CABAL_PARSEC_DEBUG -checkPosition pos@(Position lineno colno) inp inp' len_chars = do - text_lines <- getDbgText - let len_bytes = B.length inp - B.length inp' - pos_txt | lineno-1 < V.length text_lines = T.take len_chars (T.drop (colno-1) (text_lines V.! (lineno-1))) - | otherwise = T.empty - real_txt = B.take len_bytes inp - when (pos_txt /= T.decodeUtf8 real_txt) $ - traceShow (pos, pos_txt, T.decodeUtf8 real_txt) $ - traceShow (take 3 (V.toList text_lines)) $ return () - where - getDbgText = Lex $ \s@LexState{ dbgText = txt } -> LexResult s txt -#else -checkPosition _ _ _ _ = return () -#endif - -lexAll :: Lex [LToken] -lexAll = do - t <- lexToken - case t of - L _ EOF -> return [t] - _ -> do ts <- lexAll - return (t : ts) - -ltest :: Int -> String -> Prelude.IO () -ltest code s = - let (ws, xs) = execLexer (setStartCode code >> lexAll) (B.Char8.pack s) - in traverse_ print ws >> traverse_ print xs - - -mkLexState :: ByteString -> LexState -mkLexState input = LexState - { curPos = Position 1 1 - , curInput = input - , curCode = 0 - , warnings = [] -#ifdef CABAL_PARSEC_DEBUG - , dbgText = V.fromList . lines' . T.decodeUtf8With T.lenientDecode $ input -#endif - } - -#ifdef CABAL_PARSEC_DEBUG -lines' :: T.Text -> [T.Text] -lines' s1 - | T.null s1 = [] - | otherwise = case T.break (\c -> c == '\r' || c == '\n') s1 of - (l, s2) | Just (c,s3) <- T.uncons s2 - -> case T.uncons s3 of - Just ('\n', s4) | c == '\r' -> l `T.snoc` '\r' `T.snoc` '\n' : lines' s4 - _ -> l `T.snoc` c : lines' s3 - - | otherwise - -> [l] -#endif -} diff --git a/cabal/boot/SPDX.LicenseExceptionId.template.hs b/cabal/boot/SPDX.LicenseExceptionId.template.hs deleted file mode 100644 --- a/cabal/boot/SPDX.LicenseExceptionId.template.hs +++ /dev/null @@ -1,121 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.SPDX.LicenseExceptionId ( - LicenseExceptionId (..), - licenseExceptionId, - licenseExceptionName, - mkLicenseExceptionId, - licenseExceptionIdList, - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Compat.Lens (set) -import Distribution.Pretty -import Distribution.Parsec -import Distribution.Utils.Generic (isAsciiAlphaNum) -import Distribution.Utils.Structured (Structured (..), nominalStructure, typeVersion) -import Distribution.SPDX.LicenseListVersion - -import qualified Data.Binary.Get as Binary -import qualified Data.Binary.Put as Binary -import qualified Data.Map.Strict as Map -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - -------------------------------------------------------------------------------- --- LicenseExceptionId -------------------------------------------------------------------------------- - --- | SPDX License identifier -data LicenseExceptionId -{{ licenseIds }} - deriving (Eq, Ord, Enum, Bounded, Show, Read, Typeable, Data, Generic) - -instance Binary LicenseExceptionId where - put = Binary.putWord8 . fromIntegral . fromEnum - get = do - i <- Binary.getWord8 - if i > fromIntegral (fromEnum (maxBound :: LicenseExceptionId)) - then fail "Too large LicenseExceptionId tag" - else return (toEnum (fromIntegral i)) - --- note: remember to bump version each time the definition changes -instance Structured LicenseExceptionId where - structure p = set typeVersion 306 $ nominalStructure p - -instance Pretty LicenseExceptionId where - pretty = Disp.text . licenseExceptionId - -instance Parsec LicenseExceptionId where - parsec = do - n <- some $ P.satisfy $ \c -> isAsciiAlphaNum c || c == '-' || c == '.' - v <- askCabalSpecVersion - maybe (fail $ "Unknown SPDX license exception identifier: " ++ n) return $ - mkLicenseExceptionId (cabalSpecVersionToSPDXListVersion v) n - -instance NFData LicenseExceptionId where - rnf l = l `seq` () - -------------------------------------------------------------------------------- --- License Data -------------------------------------------------------------------------------- - --- | License SPDX identifier, e.g. @"BSD-3-Clause"@. -licenseExceptionId :: LicenseExceptionId -> String -{% for l in licenses %} -licenseExceptionId {{l.constructor}} = {{l.id}} -{% endfor %} - --- | License name, e.g. @"GNU General Public License v2.0 only"@ -licenseExceptionName :: LicenseExceptionId -> String -{% for l in licenses %} -licenseExceptionName {{l.constructor}} = {{l.name}} -{% endfor %} - -------------------------------------------------------------------------------- --- Creation -------------------------------------------------------------------------------- - -licenseExceptionIdList :: LicenseListVersion -> [LicenseExceptionId] -licenseExceptionIdList LicenseListVersion_3_0 = -{{licenseList_3_0}} - ++ bulkOfLicenses -licenseExceptionIdList LicenseListVersion_3_2 = -{{licenseList_3_2}} - ++ bulkOfLicenses -licenseExceptionIdList LicenseListVersion_3_6 = -{{licenseList_3_6}} - ++ bulkOfLicenses -licenseExceptionIdList LicenseListVersion_3_9 = -{{licenseList_3_9}} - ++ bulkOfLicenses - --- | Create a 'LicenseExceptionId' from a 'String'. -mkLicenseExceptionId :: LicenseListVersion -> String -> Maybe LicenseExceptionId -mkLicenseExceptionId LicenseListVersion_3_0 s = Map.lookup s stringLookup_3_0 -mkLicenseExceptionId LicenseListVersion_3_2 s = Map.lookup s stringLookup_3_2 -mkLicenseExceptionId LicenseListVersion_3_6 s = Map.lookup s stringLookup_3_6 -mkLicenseExceptionId LicenseListVersion_3_9 s = Map.lookup s stringLookup_3_9 - -stringLookup_3_0 :: Map String LicenseExceptionId -stringLookup_3_0 = Map.fromList $ map (\i -> (licenseExceptionId i, i)) $ - licenseExceptionIdList LicenseListVersion_3_0 - -stringLookup_3_2 :: Map String LicenseExceptionId -stringLookup_3_2 = Map.fromList $ map (\i -> (licenseExceptionId i, i)) $ - licenseExceptionIdList LicenseListVersion_3_2 - -stringLookup_3_6 :: Map String LicenseExceptionId -stringLookup_3_6 = Map.fromList $ map (\i -> (licenseExceptionId i, i)) $ - licenseExceptionIdList LicenseListVersion_3_6 - -stringLookup_3_9 :: Map String LicenseExceptionId -stringLookup_3_9 = Map.fromList $ map (\i -> (licenseExceptionId i, i)) $ - licenseExceptionIdList LicenseListVersion_3_9 - --- | License exceptions in all SPDX License lists -bulkOfLicenses :: [LicenseExceptionId] -bulkOfLicenses = -{{licenseList_all}} diff --git a/cabal/boot/SPDX.LicenseId.template.hs b/cabal/boot/SPDX.LicenseId.template.hs deleted file mode 100644 --- a/cabal/boot/SPDX.LicenseId.template.hs +++ /dev/null @@ -1,199 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.SPDX.LicenseId ( - LicenseId (..), - licenseId, - licenseName, - licenseIsOsiApproved, - licenseIsFsfLibre, - mkLicenseId, - licenseIdList, - -- * Helpers - licenseIdMigrationMessage, - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Compat.Lens (set) -import Distribution.Pretty -import Distribution.Parsec -import Distribution.Utils.Generic (isAsciiAlphaNum) -import Distribution.Utils.Structured (Structured (..), nominalStructure, typeVersion) -import Distribution.SPDX.LicenseListVersion - -import qualified Data.Binary.Get as Binary -import qualified Data.Binary.Put as Binary -import qualified Data.Map.Strict as Map -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - -------------------------------------------------------------------------------- --- LicenseId -------------------------------------------------------------------------------- - --- | SPDX License identifier -data LicenseId -{{ licenseIds }} - deriving (Eq, Ord, Enum, Bounded, Show, Read, Typeable, Data, Generic) - -instance Binary LicenseId where - -- Word16 is encoded in big endianess - -- https://github.com/kolmodin/binary/blob/master/src/Data/Binary/Class.hs#L220-LL227 - put = Binary.putWord16be . fromIntegral . fromEnum - get = do - i <- Binary.getWord16be - if i > fromIntegral (fromEnum (maxBound :: LicenseId)) - then fail "Too large LicenseId tag" - else return (toEnum (fromIntegral i)) - --- note: remember to bump version each time the definition changes -instance Structured LicenseId where - structure p = set typeVersion 306 $ nominalStructure p - -instance Pretty LicenseId where - pretty = Disp.text . licenseId - --- | --- >>> eitherParsec "BSD-3-Clause" :: Either String LicenseId --- Right BSD_3_Clause --- --- >>> eitherParsec "BSD3" :: Either String LicenseId --- Left "...Unknown SPDX license identifier: 'BSD3' Do you mean BSD-3-Clause?" --- -instance Parsec LicenseId where - parsec = do - n <- some $ P.satisfy $ \c -> isAsciiAlphaNum c || c == '-' || c == '.' - v <- askCabalSpecVersion - maybe (fail $ "Unknown SPDX license identifier: '" ++ n ++ "' " ++ licenseIdMigrationMessage n) return $ - mkLicenseId (cabalSpecVersionToSPDXListVersion v) n - -instance NFData LicenseId where - rnf l = l `seq` () - --- | Help message for migrating from non-SPDX license identifiers. --- --- Old 'License' is almost SPDX, except for 'BSD2', 'BSD3'. This function --- suggests SPDX variant: --- --- >>> licenseIdMigrationMessage "BSD3" --- "Do you mean BSD-3-Clause?" --- --- Also 'OtherLicense', 'AllRightsReserved', and 'PublicDomain' aren't --- valid SPDX identifiers --- --- >>> traverse_ (print . licenseIdMigrationMessage) [ "OtherLicense", "AllRightsReserved", "PublicDomain" ] --- "SPDX license list contains plenty of licenses. See https://spdx.org/licenses/. Also they can be combined into complex expressions with AND and OR." --- "You can use NONE as a value of license field." --- "Public Domain is a complex matter. See https://wiki.spdx.org/view/Legal_Team/Decisions/Dealing_with_Public_Domain_within_SPDX_Files. Consider using a proper license." --- --- SPDX License list version 3.0 introduced "-only" and "-or-later" variants for GNU family of licenses. --- See --- >>> licenseIdMigrationMessage "GPL-2.0" --- "SPDX license list 3.0 deprecated suffixless variants of GNU family of licenses. Use GPL-2.0-only or GPL-2.0-or-later." --- --- For other common licenses their old license format coincides with the SPDX identifiers: --- --- >>> traverse eitherParsec ["GPL-2.0-only", "GPL-3.0-only", "LGPL-2.1-only", "MIT", "ISC", "MPL-2.0", "Apache-2.0"] :: Either String [LicenseId] --- Right [GPL_2_0_only,GPL_3_0_only,LGPL_2_1_only,MIT,ISC,MPL_2_0,Apache_2_0] --- -licenseIdMigrationMessage :: String -> String -licenseIdMigrationMessage = go where - go l | gnuVariant l = "SPDX license list 3.0 deprecated suffixless variants of GNU family of licenses. Use " ++ l ++ "-only or " ++ l ++ "-or-later." - go "BSD3" = "Do you mean BSD-3-Clause?" - go "BSD2" = "Do you mean BSD-2-Clause?" - go "AllRightsReserved" = "You can use NONE as a value of license field." - go "OtherLicense" = "SPDX license list contains plenty of licenses. See https://spdx.org/licenses/. Also they can be combined into complex expressions with AND and OR." - go "PublicDomain" = "Public Domain is a complex matter. See https://wiki.spdx.org/view/Legal_Team/Decisions/Dealing_with_Public_Domain_within_SPDX_Files. Consider using a proper license." - - -- otherwise, we don't know - go _ = "" - - gnuVariant = flip elem ["GPL-2.0", "GPL-3.0", "LGPL-2.1", "LGPL-3.0", "AGPL-3.0" ] - -------------------------------------------------------------------------------- --- License Data -------------------------------------------------------------------------------- - --- | License SPDX identifier, e.g. @"BSD-3-Clause"@. -licenseId :: LicenseId -> String -{% for l in licenses %} -licenseId {{l.constructor}} = {{l.id}} -{% endfor %} - --- | License name, e.g. @"GNU General Public License v2.0 only"@ -licenseName :: LicenseId -> String -{% for l in licenses %} -licenseName {{l.constructor}} = {{l.name}} -{% endfor %} - --- | Whether the license is approved by Open Source Initiative (OSI). --- --- See . -licenseIsOsiApproved :: LicenseId -> Bool -{% for l in licenses %} -{% if l.isOsiApproved %} -licenseIsOsiApproved {{l.constructor}} = True -{% endif %} -{% endfor %} -licenseIsOsiApproved _ = False - --- | Whether the license is considered libre by Free Software Foundation (FSF). --- --- See --- --- @since 3.4.0.0 --- -licenseIsFsfLibre :: LicenseId -> Bool -{% for l in licenses %} -{% if l.isFsfLibre %} -licenseIsFsfLibre {{l.constructor}} = True -{% endif %} -{% endfor %} -licenseIsFsfLibre _ = False - -------------------------------------------------------------------------------- --- Creation -------------------------------------------------------------------------------- - -licenseIdList :: LicenseListVersion -> [LicenseId] -licenseIdList LicenseListVersion_3_0 = -{{licenseList_3_0}} - ++ bulkOfLicenses -licenseIdList LicenseListVersion_3_2 = -{{licenseList_3_2}} - ++ bulkOfLicenses -licenseIdList LicenseListVersion_3_6 = -{{licenseList_3_6}} - ++ bulkOfLicenses -licenseIdList LicenseListVersion_3_9 = -{{licenseList_3_9}} - ++ bulkOfLicenses - --- | Create a 'LicenseId' from a 'String'. -mkLicenseId :: LicenseListVersion -> String -> Maybe LicenseId -mkLicenseId LicenseListVersion_3_0 s = Map.lookup s stringLookup_3_0 -mkLicenseId LicenseListVersion_3_2 s = Map.lookup s stringLookup_3_2 -mkLicenseId LicenseListVersion_3_6 s = Map.lookup s stringLookup_3_6 -mkLicenseId LicenseListVersion_3_9 s = Map.lookup s stringLookup_3_9 - -stringLookup_3_0 :: Map String LicenseId -stringLookup_3_0 = Map.fromList $ map (\i -> (licenseId i, i)) $ - licenseIdList LicenseListVersion_3_0 - -stringLookup_3_2 :: Map String LicenseId -stringLookup_3_2 = Map.fromList $ map (\i -> (licenseId i, i)) $ - licenseIdList LicenseListVersion_3_2 - -stringLookup_3_6 :: Map String LicenseId -stringLookup_3_6 = Map.fromList $ map (\i -> (licenseId i, i)) $ - licenseIdList LicenseListVersion_3_6 - -stringLookup_3_9 :: Map String LicenseId -stringLookup_3_9 = Map.fromList $ map (\i -> (licenseId i, i)) $ - licenseIdList LicenseListVersion_3_9 - --- | Licenses in all SPDX License lists -bulkOfLicenses :: [LicenseId] -bulkOfLicenses = -{{licenseList_all}} diff --git a/cabal/boot/cabal_macros.template.h b/cabal/boot/cabal_macros.template.h deleted file mode 100644 --- a/cabal/boot/cabal_macros.template.h +++ /dev/null @@ -1,41 +0,0 @@ -/* DO NOT EDIT: This file is automatically generated by Cabal */ - -{% for pkg in packages %} -/* package {{ pkg.name }}-{{ pkg.version }} */ -#ifndef VERSION_{{ manglePkgName pkg.name }} -#define VERSION_{{ manglePkgName pkg.name }} "{{ pkg.version }}" -#endif /* VERSION_{{ manglePkgName pkg.name }} */ -#ifndef MIN_VERSION_{{ manglePkgName pkg.name }} -#define MIN_VERSION_{{ manglePkgName pkg.name }}(major1,major2,minor) (\ - (major1) < {{ pkg.x }} || \ - (major1) == {{ pkg.x }} && (major2) < {{ pkg.y }} || \ - (major1) == {{ pkg.x }} && (major2) == {{ pkg.y }} && (minor) <= {{ pkg.z }}) -#endif /* MIN_VERSION_{{ manglePkgName pkg.name }} */ -{% endfor %} - -{% for tool in tools %} -/* tool {{ tool.name }}-{{ tool.version }} */ -#ifndef TOOL_VERSION_{{ mangleStr tool.name }} -#define TOOL_VERSION_{{ mangleStr tool.name }} "{{ tool.version }}" -#endif /* TOOL_VERSION_{{ mangleStr tool.name }} */ -#ifndef MIN_TOOL_VERSION_{{ mangleStr tool.name }} -#define MIN_TOOL_VERSION_{{ mangleStr tool.name }}(major1,major2,minor) (\ - (major1) < {{ tool.x }} || \ - (major1) == {{ tool.x }} && (major2) < {{ tool.y }} || \ - (major1) == {{ tool.x }} && (major2) == {{ tool.y }} && (minor) <= {{ tool.z }}) -#endif /* MIN_TOOL_VERSION_{{ mangleStr tool.name }} */ -{% endfor %} - -{% if notNull packageKey %} -#ifndef CURRENT_PACKAGE_KEY -#define CURRENT_PACKAGE_KEY "{{ packageKey }}" -#endif /* CURRENT_packageKey */ -{% endif %} -{% if notNull componentId %} -#ifndef CURRENT_COMPONENT_ID -#define CURRENT_COMPONENT_ID "{{ componentId }}" -#endif /* CURRENT_COMPONENT_ID */ -{% endif %} -#ifndef CURRENT_PACKAGE_VERSION -#define CURRENT_PACKAGE_VERSION "{{ packageVersion }}" -#endif /* CURRENT_PACKAGE_VERSION */ diff --git a/cabal/boot/ci-artifacts.template.yml b/cabal/boot/ci-artifacts.template.yml deleted file mode 100644 --- a/cabal/boot/ci-artifacts.template.yml +++ /dev/null @@ -1,136 +0,0 @@ -name: Artifacts -on: - push: - branches: - - master - - "3.2" - pull_request: - branches: - - master - release: - types: - - created - -jobs: - artifact-linux: - name: Artifact on Linux - runs-on: ubuntu-18.04 - container: - # Older Ubuntu for older glibc - image: phadej/ghc:8.6.5-xenial - steps: - - name: Set PATH - run: | - echo "::add-path::$HOME/.cabal/bin" - - name: Update Hackage index - run: cabal v2-update - - uses: actions/checkout@v2 - - name: Release project - run: | - cp cabal.project.release cabal.project - rm -rf cabal.project.local cabal.project.freeze - - name: Build - run: | - cabal v2-build cabal-install:exe:cabal - cp $(find dist-newstyle -type f -executable -name cabal) cabal.exe - - name: Smoke test - run: | - ./cabal.exe --version - - name: Prepare for upload - run: xz -c < cabal.exe > cabal-artifact.xz - - uses: actions/upload-artifact@v1 - with: - name: cabal-linux-x86_64.xz - path: cabal-artifact.xz - - artifact-macos: - name: Artifact on macOS - runs-on: macos-latest - steps: - - name: Install GHC - run: | - cd $(mktemp -d) - curl -sLO "https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-apple-darwin.tar.xz" - tar -xJf ghc-*.tar.xz - cd ghc-* - ./configure --prefix=/opt/ghc/8.6.5 - sudo make install - - name: Install Cabal - run: | - cd $(mktemp -d) - curl -sLO https://downloads.haskell.org/~cabal/cabal-install-3.0.0.0/cabal-install-3.0.0.0-x86_64-apple-darwin17.7.0.tar.xz - tar -xJf cabal-install-*.tar.xz - sudo mkdir -p /opt/cabal/3.0/bin - sudo cp cabal /opt/cabal/3.0/bin/cabal - sudo chmod 755 /opt/cabal/3.0/bin/cabal - - name: Set PATH - run: | - echo "::add-path::/opt/ghc/8.6.5/bin" - echo "::add-path::/opt/cabal/3.0/bin" - echo "::add-path::$HOME/.cabal/bin" - - name: Update Hackage index - run: cabal v2-update - - uses: actions/checkout@v2 - - name: Release project - run: | - cp cabal.project.release cabal.project - rm -rf cabal.project.local cabal.project.freeze - - name: Build - run: | - cabal v2-build cabal-install:exe:cabal - # macOS find doesn't know -executable - cp $(find dist-newstyle -type f -name cabal) cabal.exe - - name: Smoke test - run: | - ./cabal.exe --version - - name: Prepare for upload - run: xz -c < cabal.exe > cabal-artifact.xz - - uses: actions/upload-artifact@v1 - with: - name: cabal-macos-x86_64.xz - path: cabal-artifact.xz - - artifact-windows: - name: Artifact on Windows - runs-on: windows-latest - steps: - - name: Install Cabal - run: choco install -fy cabal --version 3.0.0.0 - - name: Install GHC - run: | - choco uninstall -y ghc - choco install -y ghc --version 8.6.5 - - name: Set PATH - run: | - [Environment]::GetEnvironmentVariable("Path") - Write-Host "::add-path::C:\ProgramData\chocolatey\lib\cabal\tools\cabal-3.0.0.0" - Write-Host "::add-path::C:\ProgramData\chocolatey\lib\ghc\tools\ghc-8.6.5\bin" - - name: Print versions - run: | - ghc --version - cabal --version - cabal user-config init -a "http-transport: plain-http" -a "store-dir: C:\SR" -f -v3 - - name: Update Hackage index - run: cabal v2-update - - uses: actions/checkout@v2 - - name: Release project - shell: bash - run: | - cp cabal.project.release cabal.project - rm -rf cabal.project.local cabal.project.freeze - - name: Build - shell: bash - run: | - cabal v2-build cabal-install:exe:cabal - cp dist-newstyle/build/x86_64-windows/ghc-8.6.5/cabal-install-3.3.0.0/x/cabal/build/cabal/cabal.exe cabal.exe - - name: Smoke test - shell: bash - run: | - ./cabal.exe --version - - name: Prepare for upload - shell: bash - run: xz -c < cabal.exe > cabal-artifact.xz - - uses: actions/upload-artifact@v1 - with: - name: cabal-windows-x86_64.xz - path: cabal-artifact.xz diff --git a/cabal/boot/ci-bootstrap.template.yml b/cabal/boot/ci-bootstrap.template.yml deleted file mode 100644 --- a/cabal/boot/ci-bootstrap.template.yml +++ /dev/null @@ -1,64 +0,0 @@ -# This file is auto-generated -# -# To regenerate it run -# -# make github-actions -# -name: Bootstrap -on: - push: - branches: - - master - - "3.2" - pull_request: - branches: - - master - release: - types: - - created - -jobs: - boostrap-linux: - name: Bootstrap on Linux - runs-on: ubuntu-18.04 - steps: - - name: Set PATH - run: | - echo "::add-path::/opt/ghc/8.6.5/bin" - - uses: actions/checkout@v2 - - name: bootstrap.sh - env: - EXTRA_CONFIGURE_OPTS: "" - run: | - cd cabal-install - sh ./bootstrap.sh --no-doc - - name: Smoke test - run: | - $HOME/.cabal/bin/cabal --version - - boostrap-macos: - name: Bootstrap on macOS - runs-on: macos-latest - steps: - - name: Install GHC - run: | - cd $(mktemp -d) - curl -sLO "https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-apple-darwin.tar.xz" - tar -xJf ghc-*.tar.xz - cd ghc-* - ./configure --prefix=/opt/ghc/8.6.5 - sudo make install - - name: Set PATH - run: | - echo "::add-path::/opt/ghc/8.6.5/bin" - echo "::add-path::$HOME/.cabal/bin" - - uses: actions/checkout@v2 - - name: bootstrap.sh - env: - EXTRA_CONFIGURE_OPTS: "" - run: | - cd cabal-install - sh ./bootstrap.sh --no-doc - - name: Smoke test - run: | - $HOME/.cabal/bin/cabal --version diff --git a/cabal/boot/ci-linux.template.yml b/cabal/boot/ci-linux.template.yml deleted file mode 100644 --- a/cabal/boot/ci-linux.template.yml +++ /dev/null @@ -1,72 +0,0 @@ -# This file is auto-generated -# -# To regenerate it run -# -# make github-actions -# -name: Linux -on: - push: - branches: - - master - - "3.2" - pull_request: - branches: - - master - release: - types: - - created - -jobs: -{% for job in jobs %} - validate-{{ mangleVersion job.version }}{% if job.old %}-old{% endif %}: - name: validate.sh {%if job.old %}old GHCs{% else %}ghc-{{job.version}}{% endif %} - runs-on: ubuntu-18.04 -{% for needs in job.needs %} - needs: validate-{{ mangleVersion needs }} -{% endfor %} - container: - image: phadej/ghc:{{job.version}}-{% if job.xenial %}xenial{% else %}bionic{% endif %} - steps: - - name: System info - run: | - uname -a - # https://help.github.com/en/actions/automating-your-workflow-with-github-actions/development-tools-for-github-actions#add-a-system-path-add-path - - name: Set PATH - run: | - echo "::add-path::$HOME/.cabal/bin" - - name: Install cabal-plan - run: | - mkdir -p $HOME/.cabal/bin - curl -sL https://github.com/haskell-hvr/cabal-plan/releases/download/v0.6.2.0/cabal-plan-0.6.2.0-x86_64-linux.xz > cabal-plan.xz - echo "de73600b1836d3f55e32d80385acc055fd97f60eaa0ab68a755302685f5d81bc cabal-plan.xz" | sha256sum -c - - xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan - rm -f cabal-plan.xz - chmod a+x $HOME/.cabal/bin/cabal-plan -{% if or job.xenial job.old %} - - name: apt-get update - run: apt-get update -{% endif %} -{% if job.xenial %} - - name: Install dynamic libraries - run: apt-get install -y ghc-{{job.version}}-dyn -{% endif %} -{% if job.old %} - - name: Install extra compilers - run: apt-get install -y ghc-7.0.4-dyn ghc-7.2.2-dyn ghc-7.4.2-dyn -{% endif %} - - name: Update Hackage index - run: cabal v2-update - # https://github.com/actions/checkout/issues/170 - # - uses: actions/checkout@v2 - - name: Checkout - run: | - echo $GITHUB_REF $GITHUB_SHA - git clone --depth 1 https://github.com/$GITHUB_REPOSITORY.git . - git fetch origin $GITHUB_SHA:temporary-ci-branch - git checkout $GITHUB_SHA || (git fetch && git checkout $GITHUB_SHA) -{% for step in job.steps %} - - name: Validate {{step}} - run: sh validate.sh -j 2 -w ghc-{{job.version}} -v {{job.flags}} -s {{step}} -{% endfor %} -{% endfor %} diff --git a/cabal/boot/ci-macos.template.yml b/cabal/boot/ci-macos.template.yml deleted file mode 100644 --- a/cabal/boot/ci-macos.template.yml +++ /dev/null @@ -1,68 +0,0 @@ -# This file is auto-generated -# -# To regenerate it run -# -# make github-actions -# -name: MacOS -on: - push: - branches: - - master - - "3.2" - pull_request: - branches: - - master - release: - types: - - created - -jobs: -{% for job in macosJobs %} - validate-macos-{{ mangleVersion job.version }}: - name: validate.sh macos ghc-{{job.version}} - runs-on: macos-latest -{% for needs in job.needs %} - needs: validate-macos-{{ mangleVersion needs }} -{% endfor %} - steps: - - name: System info - run: | - uname -a - - name: Install Autotools - run: | - brew install automake - - name: Install GHC - run: | - cd $(mktemp -d) - curl -sLO {{job.ghcUrl}} - tar -xJf ghc-*.tar.xz - cd ghc-* - ./configure --prefix=/opt/ghc/{{job.version}} - sudo make install - - name: Install Cabal - run: | - cd $(mktemp -d) - curl -sLO https://downloads.haskell.org/~cabal/cabal-install-3.0.0.0/cabal-install-3.0.0.0-x86_64-apple-darwin17.7.0.tar.xz - tar -xJf cabal-install-*.tar.xz - sudo mkdir -p /opt/cabal/3.0/bin - sudo cp cabal /opt/cabal/3.0/bin/cabal - sudo chmod 755 /opt/cabal/3.0/bin/cabal - - name: Set PATH - run: | - echo "::add-path::/opt/ghc/{{job.version}}/bin" - echo "::add-path::/opt/cabal/3.0/bin" - echo "::add-path::$HOME/.cabal/bin" - - name: Update Hackage index - run: cabal v2-update - - name: Install cabal-plan - run: | - cd $(mktemp -d) -{# aeson +fast, so we don't wait for -O2 #} - cabal v2-install cabal-plan --constraint='cabal-plan ^>=0.6.2.0' --constraint='aeson +fast' - - uses: actions/checkout@v2 -{% for step in job.steps %} - - name: Validate {{step}} - run: sh validate.sh -j 2 -w ghc-{{job.version}} -v {{job.flags}} -s {{step}} -{% endfor %} -{% endfor %} diff --git a/cabal/boot/ci-quick-jobs.template.yml b/cabal/boot/ci-quick-jobs.template.yml deleted file mode 100644 --- a/cabal/boot/ci-quick-jobs.template.yml +++ /dev/null @@ -1,84 +0,0 @@ -# This file is auto-generated -# -# To regenerate it run -# -# make github-actions -# -name: Quick jobs -on: - push: - branches: - - master - - "3.2" - pull_request: - branches: - - master - release: - types: - - created - -jobs: - meta: - name: Meta checks - runs-on: ubuntu-18.04 - # This job is not run in a container, any recent GHC should be fine - steps: - - name: Set PATH - run: | - echo "::add-path::$HOME/.cabal/bin" - echo "::add-path::/opt/cabal/3.2/bin" - echo "::add-path::/opt/ghc/8.6.5/bin" - - uses: actions/cache@v1 - with: - path: ~/.cabal/store - key: linux-store-meta - - name: Update Hackage index - run: cabal v2-update - - name: Install alex - run: cabal v2-install alex - - uses: actions/checkout@v2 - - name: Regenerate files - run: | - make lexer - make gen-extra-source-files - make spdx - make templates - make github-actions - make cabal-install-cabal - - name: Check that diff is clean - run: | - git status > /dev/null - git diff-files -p --exit-code - doctest: - name: Doctest Cabal - runs-on: ubuntu-18.04 - steps: - - name: Set PATH - run: | - echo "::add-path::$HOME/.cabal/bin" - echo "::add-path::/opt/cabal/3.2/bin" - echo "::add-path::/opt/ghc/8.6.5/bin" - - name: Install cabal-env - run: | - mkdir -p $HOME/.cabal/bin - curl -sL https://github.com/phadej/cabal-extras/releases/download/preview-20191225/cabal-env-snapshot-20191225-x86_64-linux.xz > cabal-env.xz - echo "1b567d529c5f627fd8c956e57ae8f0d9f11ee66d6db34b7fb0cb1c370b4edf01 cabal-env.xz" | sha256sum -c - - xz -d < cabal-env.xz > $HOME/.cabal/bin/cabal-env - rm -f cabal-env.xz - chmod a+x $HOME/.cabal/bin/cabal-env - - uses: actions/cache@v1 - with: - path: ~/.cabal/store - key: linux-store-doctest - - name: Update Hackage index - run: cabal v2-update - - name: Install doctest - run: cabal v2-install doctest - - name: Install libraries - run: | - cabal-env --transitive QuickCheck - cabal-env array bytestring containers deepseq directory filepath pretty process time binary unix text parsec mtl - cat $HOME/.ghc/*/environments/default - - uses: actions/checkout@v2 - - name: Doctest - run: make doctest diff --git a/cabal/boot/ci-windows.template.yml b/cabal/boot/ci-windows.template.yml deleted file mode 100644 --- a/cabal/boot/ci-windows.template.yml +++ /dev/null @@ -1,84 +0,0 @@ -# This file is auto-generated -# -# To regenerate it run -# -# make github-actions -# -name: Windows -on: - push: - branches: - - master - - "3.2" - pull_request: - branches: - - master - release: - types: - - created - -jobs: - -{############################################################################} -{# Windows jobs #} -{############################################################################} -{% for job in winJobs %} - test-windows-{{ mangleVersion job.version }}: - name: test ghc-{{job.version}} - runs-on: windows-latest -{% for needs in job.needs %} - needs: test-windows-{{ mangleVersion needs }} -{% endfor %} - steps: - - name: Install Cabal - run: choco install -fy cabal --version 3.2.0.0 - - name: Install GHC - run: | - choco uninstall -y ghc --all-versions - choco install -y ghc --version {{ job.version }} - - name: Set PATH - run: | - [Environment]::GetEnvironmentVariable("Path") - Write-Host "::add-path::C:\ProgramData\Chocolatey\lib\cabal\tools\cabal-3.2.0.0" - Write-Host "::add-path::C:\ProgramData\Chocolatey\lib\ghc\tools\ghc-{{ job.version }}\bin" - [Environment]::GetEnvironmentVariable("Path") - - name: Print versions - run: | - [Environment]::GetEnvironmentVariable("Path") - cabal --version - ghc --version - cabal user-config init -a "http-transport: plain-http" -a "store-dir: C:\SR" -f -v3 - - uses: actions/cache@v1 - with: - path: C:\SR - key: windows-store-meta - - name: Update Hackage index - run: cabal v2-update - - uses: actions/checkout@v2 - - name: make cabal-install-dev - run: cp cabal-install/cabal-install.cabal.dev cabal-install/cabal-install.cabal - # We cannot ask for all dependencies, but we can for Cabal. - - name: cabal v2-build Cabal --only-dependencies - run: cabal v2-build Cabal --only-dependencies - - name: cabal v2-build - run: cabal v2-build all - - name: cabal-install memory-usage-tests - run: | - cd cabal-install - cabal v2-run cabal-install:memory-usage-tests - - name: cabal-install solver-quickcheck - run: | - cd cabal-install - cabal v2-run cabal-install:solver-quickcheck - - name: cabal-install integration-tests2 - run: | - cd cabal-install - cabal v2-run cabal-install:integration-tests2 - - name: cabal-install unit-tests - run: | - cd cabal-install - cabal v2-run cabal-install:unit-tests -- --pattern "! (/FileMonitor/ || /VCS/ || /Get/)" - - name: cabal-tests - # Using only one job, -j1, to fail less. - run: cabal v2-run cabal-tests -- -j1 --with-cabal=dist-newstyle\build\x86_64-windows\ghc-{{ job.version }}\cabal-install-3.3.0.0\x\cabal\build\cabal\cabal.exe -{% endfor %} diff --git a/cabal/bootstrap/README.md b/cabal/bootstrap/README.md new file mode 100644 --- /dev/null +++ b/cabal/bootstrap/README.md @@ -0,0 +1,33 @@ +# Bootstrapping cabal-install + +This utility is only intended for use in building cabal-install +on a new platform. If you already have a functional (if dated) cabal-install +please rather run `cabal v2-install`. + +The typical usage is porting to a new linux architecture, +then the `linux-ghcvec.json` file is available in `bootstrap/` folder: + +On a (linux) system you are bootstrapping, run + + ./bootstrap/bootstrap.py -d ./bootstrap/linux-ghcver.json -w /path/to-ghc + +from the top directory of the source checkout. + +To generate the `platform-ghcver` files for other platforms, do: + + 1. On a system with functional cabal-install, 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. `linux-8.8.3.json`) by running: + + ```sh + cabal v2-build --with-compiler=/path/to/ghc --dry-run cabal-install:exe:cabal + cp dist-newstyle/cache/plan.json bootstrap/platform-ghcver.plan.json + cd bootstrap + cabal v2-run -v0 cabal-bootstrap-gen -- platform-ghcver.plan.json | tee platform-ghcver.json + ``` + + 3. You may need to tweak `bootstrap/platform-ghcver.json` file manually, + for example toggle flags. + +There are rules in top-level `Makefile` for generation of these files. diff --git a/cabal/bootstrap/bootstrap.py b/cabal/bootstrap/bootstrap.py new file mode 100644 --- /dev/null +++ b/cabal/bootstrap/bootstrap.py @@ -0,0 +1,399 @@ +#!/usr/bin/env python3 +# -*- coding: utf-8 -*- + +""" +bootstrap.py - bootstrapping utility for cabal-install. + +See bootstrap/README.md for usage instructions. +""" + +USAGE = """ +This utility is only intended for use in building cabal-install +on a new platform. If you already have a functional (if dated) cabal-install +please rather run `cabal v2-install .`. +""" + +from enum import Enum +import hashlib +import logging +import json +from pathlib import Path +import platform +import shutil +import subprocess +from textwrap import dedent +from typing import Set, Optional, Dict, List, Tuple, \ + NewType, BinaryIO, NamedTuple, TypeVar + +#logging.basicConfig(level=logging.INFO) + +BUILDDIR = Path('_build') + +BINDIR = BUILDDIR / 'bin' # binaries go there (--bindir) +DISTDIR = BUILDDIR / 'dists' # --builddir +UNPACKED = BUILDDIR / 'unpacked' # where we unpack tarballs +TARBALLS = BUILDDIR / 'tarballs' # where we download tarballks +PSEUDOSTORE = BUILDDIR / 'pseudostore' # where we install packages +ARTIFACTS = BUILDDIR / 'artifacts' # Where we put the archive +TMPDIR = BUILDDIR / 'tmp' # +PKG_DB = BUILDDIR / 'packages.conf' # package db + +PackageName = NewType('PackageName', str) +Version = NewType('Version', str) +SHA256Hash = NewType('SHA256Hash', str) + +class PackageSource(Enum): + HACKAGE = 'hackage' + LOCAL = 'local' + +BuiltinDep = NamedTuple('BuiltinDep', [ + ('package', PackageName), + ('version', Version), +]) + +BootstrapDep = NamedTuple('BootstrapDep', [ + ('package', PackageName), + ('version', Version), + ('source', PackageSource), + # source tarball SHA256 + ('src_sha256', Optional[SHA256Hash]), + # `revision` is only valid when source == HACKAGE. + ('revision', Optional[int]), + ('cabal_sha256', Optional[SHA256Hash]), + ('flags', List[str]), +]) + +BootstrapInfo = NamedTuple('BootstrapInfo', [ + ('builtin', List[BuiltinDep]), + ('dependencies', List[BootstrapDep]), +]) + +class Compiler: + def __init__(self, ghc_path: Path): + if not ghc_path.is_file(): + raise TypeError(f'GHC {ghc_path} is not a file') + + self.ghc_path = ghc_path.resolve() + + info = self._get_ghc_info() + self.version = info['Project version'] + #self.lib_dir = Path(info['LibDir']) + #self.ghc_pkg_path = (self.lib_dir / 'bin' / 'ghc-pkg').resolve() + self.ghc_pkg_path = (self.ghc_path.parent / 'ghc-pkg').resolve() + if not self.ghc_pkg_path.is_file(): + raise TypeError(f'ghc-pkg {self.ghc_pkg_path} is not a file') + self.hsc2hs_path = (self.ghc_path.parent / 'hsc2hs').resolve() + if not self.hsc2hs_path.is_file(): + raise TypeError(f'hsc2hs {self.hsc2hs_path} is not a file') + + def _get_ghc_info(self) -> Dict[str,str]: + from ast import literal_eval + p = subprocess_run([self.ghc_path, '--info'], stdout=subprocess.PIPE, check=True, encoding='UTF-8') + out = p.stdout.replace('\n', '').strip() + return dict(literal_eval(out)) + +PackageSpec = Tuple[PackageName, Version] + +class BadTarball(Exception): + def __init__(self, path: Path, expected_sha256: SHA256Hash, found_sha256: SHA256Hash): + self.path = path + self.expected_sha256 = expected_sha256 + self.found_sha256 = found_sha256 + + def __str__(self): + return '\n'.join([ + f'Bad tarball hash: {str(self.path)}', + f' expected: {self.expected_sha256}', + f' found: {self.found_sha256}', + ]) + +def package_url(package: PackageName, version: Version) -> str: + return f'http://hackage.haskell.org/package/{package}-{version}/{package}-{version}.tar.gz' + +def package_cabal_url(package: PackageName, version: Version, revision: int) -> str: + return f'http://hackage.haskell.org/package/{package}-{version}/revision/{revision}.cabal' + +def verify_sha256(expected_hash: SHA256Hash, f: Path): + h = hash_file(hashlib.sha256(), f.open('rb')) + if h != expected_hash: + raise BadTarball(f, expected_hash, h) + +def fetch_package(package: PackageName, + version: Version, + src_sha256: SHA256Hash, + revision: Optional[int], + cabal_sha256: Optional[SHA256Hash], + ) -> (Path, Path): + import urllib.request + + # Download source distribution + tarball = TARBALLS / f'{package}-{version}.tar.gz' + if not tarball.exists(): + print(f'Fetching {package}-{version}...') + tarball.parent.mkdir(parents=True, exist_ok=True) + url = package_url(package, version) + with urllib.request.urlopen(url) as resp: + shutil.copyfileobj(resp, tarball.open('wb')) + + verify_sha256(src_sha256, tarball) + + # Download revised cabal file + cabal_file = TARBALLS / f'{package}.cabal' + if revision is not None and not cabal_file.exists(): + assert cabal_sha256 is not None + url = package_cabal_url(package, version, revision) + with urllib.request.urlopen(url) as resp: + shutil.copyfileobj(resp, cabal_file.open('wb')) + verify_sha256(cabal_sha256, cabal_file) + + return (tarball, cabal_file) + +def read_bootstrap_info(path: Path) -> BootstrapInfo: + obj = json.load(path.open()) + + def bi_from_json(o: dict) -> BuiltinDep: + return BuiltinDep(**o) + + def dep_from_json(o: dict) -> BootstrapDep: + o['source'] = PackageSource(o['source']) + return BootstrapDep(**o) + + builtin = [bi_from_json(dep) for dep in obj['builtin'] ] + deps = [dep_from_json(dep) for dep in obj['dependencies'] ] + + return BootstrapInfo(dependencies=deps, builtin=builtin) + +def check_builtin(dep: BuiltinDep, ghc: Compiler) -> None: + subprocess_run([str(ghc.ghc_pkg_path), 'describe', f'{dep.package}-{dep.version}'], + check=True, stdout=subprocess.DEVNULL) + print(f'Using {dep.package}-{dep.version} from GHC...') + return + +def install_dep(dep: BootstrapDep, ghc: Compiler) -> None: + dist_dir = (DISTDIR / f'{dep.package}-{dep.version}').resolve() + + if dep.source == PackageSource.HACKAGE: + assert dep.src_sha256 is not None + (tarball, cabal_file) = fetch_package(dep.package, dep.version, dep.src_sha256, + dep.revision, dep.cabal_sha256) + UNPACKED.mkdir(parents=True, exist_ok=True) + shutil.unpack_archive(tarball.resolve(), UNPACKED, 'gztar') + sdist_dir = UNPACKED / f'{dep.package}-{dep.version}' + + # Update cabal file with revision + if dep.revision is not None: + shutil.copyfile(cabal_file, sdist_dir / f'{dep.package}.cabal') + + # We rely on the presence of Setup.hs + if len(list(sdist_dir.glob('Setup.*hs'))) == 0: + with open(sdist_dir / 'Setup.hs', 'w') as f: + f.write('import Distribution.Simple\n') + f.write('main = defaultMain\n') + + elif dep.source == PackageSource.LOCAL: + if dep.package == 'Cabal': + sdist_dir = Path('Cabal').resolve() + elif dep.package == 'Cabal-syntax': + sdist_dir = Path('Cabal-syntax').resolve() + elif dep.package == 'cabal-install-solver': + sdist_dir = Path('cabal-install-solver').resolve() + elif dep.package == 'cabal-install': + sdist_dir = Path('cabal-install').resolve() + else: + raise ValueError(f'Unknown local package {dep.package}') + + install_sdist(dist_dir, sdist_dir, ghc, dep.flags) + +def install_sdist(dist_dir: Path, sdist_dir: Path, ghc: Compiler, flags: List[str]): + prefix = PSEUDOSTORE.resolve() + flags_option = ' '.join(flags) + setup_dist_dir = dist_dir / 'setup' + setup = setup_dist_dir / 'Setup' + + build_args = [ + f'--builddir={dist_dir}', + ] + + configure_args = build_args + [ + f'--package-db={PKG_DB.resolve()}', + f'--prefix={prefix}', + f'--bindir={BINDIR.resolve()}', + f'--with-compiler={ghc.ghc_path}', + f'--with-hc-pkg={ghc.ghc_pkg_path}', + f'--with-hsc2hs={ghc.hsc2hs_path}', + f'--flags={flags_option}', + ] + + def check_call(args: List[str]) -> None: + subprocess_run(args, cwd=sdist_dir, check=True) + + setup_dist_dir.mkdir(parents=True, exist_ok=True) + + # Note: we pass -i so GHC doesn't look for anything else + # This should be fine for cabal-install dependencies. + check_call([str(ghc.ghc_path), '--make', '-package-env=-', '-i', f'-odir={setup_dist_dir}', f'-hidir={setup_dist_dir}', '-o', setup, 'Setup']) + check_call([setup, 'configure'] + configure_args) + check_call([setup, 'build'] + build_args) + check_call([setup, 'install'] + build_args) + +def hash_file(h, f: BinaryIO) -> SHA256Hash: + while True: + d = f.read(1024) + if len(d) == 0: + return SHA256Hash(h.hexdigest()) + + h.update(d) + + +# Cabal plan.json representation +UnitId = NewType('UnitId', str) +PlanUnit = NewType('PlanUnit', dict) + +def bootstrap(info: BootstrapInfo, ghc: Compiler) -> None: + if not PKG_DB.exists(): + print(f'Creating package database {PKG_DB}') + PKG_DB.parent.mkdir(parents=True, exist_ok=True) + subprocess_run([ghc.ghc_pkg_path, 'init', PKG_DB]) + + for dep in info.builtin: + check_builtin(dep, ghc) + + for dep in info.dependencies: + install_dep(dep, ghc) + +# Steps +####################################################################### + +def linuxname(i, r): + i = i.strip() # id + r = r.strip() # release + if i == '': return 'linux' + else: return f"{i}-{r}".lower() + +def macname(macver): + # https://en.wikipedia.org/wiki/MacOS_version_history#Releases + if macver.startswith('10.12.'): return 'sierra' + if macver.startswith('10.13.'): return 'high-sierra' + if macver.startswith('10.14.'): return 'mojave' + if macver.startswith('10.15.'): return 'catalina' + if macver.startswith('11.0.'): return 'big-sur' + else: return macver + +def archive_name(cabalversion): + # Ask platform information + machine = platform.machine() + if machine == '': machine = "unknown" + + system = platform.system().lower() + if system == '': system = "unknown" + + version = system + if system == 'linux': + try: + i = subprocess_run(['lsb_release', '-si'], stdout=subprocess.PIPE, encoding='UTF-8') + r = subprocess_run(['lsb_release', '-sr'], stdout=subprocess.PIPE, encoding='UTF-8') + version = linuxname(i.stdout, r.stdout) + except: + try: + with open('/etc/alpine-release') as f: + alpinever = f.read().strip() + return f'alpine-{alpinever}' + except: + pass + elif system == 'darwin': + version = 'darwin-' + macname(platform.mac_ver()[0]) + elif system == 'freebsd': + version = 'freebsd-' + platform.release().lower() + + return f'cabal-install-{cabalversion}-{machine}-{version}' + +def make_archive(cabal_path): + import tempfile + + print(f'Creating distribution tarball') + + # Get bootstrapped cabal version + # This also acts as smoke test + p = subprocess_run([cabal_path, '--numeric-version'], stdout=subprocess.PIPE, check=True, encoding='UTF-8') + cabalversion = p.stdout.replace('\n', '').strip() + + # Archive name + basename = ARTIFACTS.resolve() / (archive_name(cabalversion) + '-bootstrapped') + + # In temporary directory, create a directory which we will archive + tmpdir = TMPDIR.resolve() + tmpdir.mkdir(parents=True, exist_ok=True) + + rootdir = Path(tempfile.mkdtemp(dir=tmpdir)) + shutil.copy(cabal_path, rootdir / 'cabal') + + # Make archive... + fmt = 'xztar' + if platform.system() == 'Windows': fmt = 'zip' + archivename = shutil.make_archive(basename, fmt, rootdir) + + return archivename + +def main() -> None: + import argparse + parser = argparse.ArgumentParser( + description="bootstrapping utility for cabal-install.", + epilog = USAGE, + formatter_class = argparse.RawDescriptionHelpFormatter) + parser.add_argument('-d', '--deps', type=Path, default='bootstrap-deps.json', + help='bootstrap dependency file') + parser.add_argument('-w', '--with-compiler', type=Path, + help='path to GHC') + args = parser.parse_args() + + # Find compiler + if args.with_compiler is None: + path = shutil.which('ghc') + if path is None: + raise ValueError("Couldn't find ghc in PATH") + ghc = Compiler(Path(path)) + else: + ghc = Compiler(args.with_compiler) + + print(f'Bootstrapping cabal-install with GHC {ghc.version} at {ghc.ghc_path}...') + + print(dedent(""" + DO NOT use this script if you have another recent cabal-install available. + This script is intended only for bootstrapping cabal-install on new + architectures. + """)) + + info = read_bootstrap_info(args.deps) + bootstrap(info, ghc) + cabal_path = (BINDIR / 'cabal').resolve() + + archive = make_archive(cabal_path) + + print(dedent(f''' + Bootstrapping finished! + + The resulting cabal-install executable can be found at + + {cabal_path} + + It have been archived for distribution in + + {archive} + + You now should use this to build a full cabal-install distribution + using v2-build. + ''')) + +def subprocess_run(args, **kwargs): + "Like subprocess.run, but also print what we run" + + args_str = ' '.join(map(str, args)) + extras = '' + if 'cwd' in kwargs: + extras += f' cwd={kwargs["cwd"]}' + print(f'bootstrap: running{extras} {args_str}') + + return subprocess.run(args, **kwargs) + +if __name__ == '__main__': + main() diff --git a/cabal/bootstrap/cabal-bootstrap-gen.cabal b/cabal/bootstrap/cabal-bootstrap-gen.cabal new file mode 100644 --- /dev/null +++ b/cabal/bootstrap/cabal-bootstrap-gen.cabal @@ -0,0 +1,20 @@ +cabal-version: 2.2 +name: cabal-bootstrap-gen +version: 0 + +executable cabal-bootstrap-gen + default-language: Haskell2010 + hs-source-dirs: src + ghc-options: -Wall + main-is: Main.hs + build-depends: + , aeson ^>=1.5.2.0 + , base ^>=4.12.0.0 || ^>=4.13.0.0 || ^>=4.14.0.0 + , bytestring ^>=0.10.8.2 || ^>= 0.11.0.0 + , Cabal ^>=3.2.0.0 + , cabal-install-parsers ^>=0.3.0.1 + , cabal-plan ^>=0.7.0.0 + , containers ^>=0.6.0.1 + , text ^>=1.2.3.0 + , topograph ^>=1.0.0.1 + , transformers ^>=0.5.6.2 diff --git a/cabal/bootstrap/cabal.project b/cabal/bootstrap/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/bootstrap/cabal.project @@ -0,0 +1,5 @@ +-- Separate project file to avoid conflicts, +-- e.g. via the dependency on cabal-install-parsers + +packages: . +optimization: False diff --git a/cabal/bootstrap/linux-8.10.7.json b/cabal/bootstrap/linux-8.10.7.json new file mode 100644 --- /dev/null +++ b/cabal/bootstrap/linux-8.10.7.json @@ -0,0 +1,396 @@ +{ + "dependencies": [ + { + "cabal_sha256": null, + "revision": null, + "src_sha256": null, + "flags": [], + "package": "Cabal-syntax", + "source": "local", + "version": "3.8.1.0" + }, + { + "cabal_sha256": "04df32d9497add5f0b90a27a3eceffa4bad5c2f41d038bd12ed6efc454db3faf", + "revision": 0, + "src_sha256": "44b31b6cd3129893ac1a007573dedb69dde667fa06ee108526d58f08b1a1f7ab", + "flags": [], + "package": "process", + "source": "hackage", + "version": "1.6.15.0" + }, + { + "cabal_sha256": null, + "revision": null, + "src_sha256": null, + "flags": [], + "package": "Cabal", + "source": "local", + "version": "3.8.1.0" + }, + { + "cabal_sha256": "e3d78b13db9512aeb106e44a334ab42b7aa48d26c097299084084cb8be5c5568", + "revision": 0, + "src_sha256": "7f7620fef1a1af3d3d6747f510e73223a5c600e7d7fd9ace073d1222bdc63d85", + "flags": [ + "-devel" + ], + "package": "network", + "source": "hackage", + "version": "3.1.2.7" + }, + { + "cabal_sha256": "f65819f74c6ced42b24d9e5053165508c4b6a18271c8e3229dc93b1dc8f7a5ab", + "revision": 1, + "src_sha256": "6b5059caf6714f47da92953badf2f556119877e09708c14e206b3ae98b8681c6", + "flags": [], + "package": "th-compat", + "source": "hackage", + "version": "0.1.3" + }, + { + "cabal_sha256": "a4765164ed0a2d1668446eb2e03460ce98645fbf083598c690846af79b7de10d", + "revision": 0, + "src_sha256": "57856db93608a4d419f681b881c9b8d4448800d5a687587dc37e8a9e0b223584", + "flags": [], + "package": "network-uri", + "source": "hackage", + "version": "2.6.4.1" + }, + { + "cabal_sha256": "16ee1212245c6e7cf0905b039689b55dbe8386a2b450094055e536d30c89ba76", + "revision": 0, + "src_sha256": "df31d8efec775124dab856d7177ddcba31be9f9e0836ebdab03d94392f2dd453", + "flags": [ + "-conduit10", + "+network-uri", + "-warn-as-error", + "-warp-tests" + ], + "package": "HTTP", + "source": "hackage", + "version": "4000.4.1" + }, + { + "cabal_sha256": "eb6758d0160d607e0c45dbd6b196f515b9a589fd4f6d2f926929dd5d56282d37", + "revision": 0, + "src_sha256": "20a21c4b7adb0fd844b25e196241467406a28286b021f9b7a082ab03fa8015eb", + "flags": [], + "package": "base-orphans", + "source": "hackage", + "version": "0.8.6" + }, + { + "cabal_sha256": "0cddd0229d1aac305ea0404409c0bbfab81f075817bd74b8b2929eff58333e55", + "revision": 0, + "src_sha256": "83606edd356d914c075ecd44f6d5fe91a3b186aa0683c8dd8c9a7e8e22a47600", + "flags": [ + "+containers", + "+integer-gmp", + "-random-initial-seed" + ], + "package": "hashable", + "source": "hackage", + "version": "1.4.0.2" + }, + { + "cabal_sha256": "b83dec34a53520de84c6dd3dc7aae45d22409b46eb471c478b98108215a370f0", + "revision": 1, + "src_sha256": "484df85be0e76c4fed9376451e48e1d0c6e97952ce79735b72d54297e7e0a725", + "flags": [ + "-bench" + ], + "package": "async", + "source": "hackage", + "version": "2.2.4" + }, + { + "cabal_sha256": "64abad7816ab8cabed8489e29f807b3a6f828e0b2cec0eae404323d69d36df9a", + "revision": 0, + "src_sha256": "1d5a91143ef0e22157536093ec8e59d226a68220ec89378d5dcaeea86472c784", + "flags": [], + "package": "base16-bytestring", + "source": "hackage", + "version": "1.0.2.0" + }, + { + "cabal_sha256": "50ec0e229255d4c45cbdd568da011311b8887f304b931564886016f4984334d8", + "revision": 0, + "src_sha256": "fbf8ed30edde271eb605352021431d8f1b055f95a56af31fe2eacf6bdfdc49c9", + "flags": [], + "package": "base64-bytestring", + "source": "hackage", + "version": "1.2.1.0" + }, + { + "cabal_sha256": "714a55fd28d3e2533bd5b49e74f604ef8e5d7b06f249c8816f6c54aed431dcf1", + "revision": 0, + "src_sha256": "6d065402394e7a9117093dbb4530a21342c9b1e2ec509516c8a8d0ffed98ecaa", + "flags": [ + "-optimised-mixer" + ], + "package": "splitmix", + "source": "hackage", + "version": "0.1.0.4" + }, + { + "cabal_sha256": "dea1f11e5569332dc6c8efaad1cb301016a5587b6754943a49f9de08ae0e56d9", + "revision": 0, + "src_sha256": "3e1272f7ed6a4d7bd1712b90143ec326fee9b225789222379fea20a9c90c9b76", + "flags": [], + "package": "random", + "source": "hackage", + "version": "1.2.1.1" + }, + { + "cabal_sha256": "4d33a49cd383d50af090f1b888642d10116e43809f9da6023d9fc6f67d2656ee", + "revision": 1, + "src_sha256": "3e8885ee2f56ad4da940f043ae8f981ee2fe336b5e8e4ba3f7436cff4f526c4a", + "flags": [], + "package": "edit-distance", + "source": "hackage", + "version": "0.2.2.1" + }, + { + "cabal_sha256": null, + "revision": null, + "src_sha256": null, + "flags": [ + "-debug-conflict-sets", + "-debug-expensive-assertions", + "-debug-tracetree" + ], + "package": "cabal-install-solver", + "source": "local", + "version": "3.8.1.0" + }, + { + "cabal_sha256": "188d0b5a0491e8b686b32d9b144c9287760ba333d2509bf3f17e3d846fbc2332", + "revision": 0, + "src_sha256": "73a7dc7163871a80837495039a099967b11f5c4fe70a118277842f7a713c6bf6", + "flags": [ + "-exe", + "+use-cbits" + ], + "package": "cryptohash-sha256", + "source": "hackage", + "version": "0.11.102.1" + }, + { + "cabal_sha256": "ccce771562c49a2b29a52046ca68c62179e97e8fbeacdae32ca84a85445e8f42", + "revision": 0, + "src_sha256": "c9fe1bf2904825a65b667251ec644f197b71dc5c209d2d254be5de3d496b0e43", + "flags": [ + "-example" + ], + "package": "echo", + "source": "hackage", + "version": "0.1.4" + }, + { + "cabal_sha256": "24ac7b5f3d9fa3c2f70262b329f2a75f24e7fd829f88c189b388efa1bcd67eb2", + "revision": 5, + "src_sha256": "d8a5958ebfa9309790efade64275dc5c441b568645c45ceed1b0c6ff36d6156d", + "flags": [ + "+no-donna", + "+test-doctests", + "+test-hlint", + "+test-properties" + ], + "package": "ed25519", + "source": "hackage", + "version": "0.0.5.0" + }, + { + "cabal_sha256": "c084c043a40632d3cafcac50fb5eeff84d91edb070a54baa94945f1c976f97c0", + "revision": 2, + "src_sha256": "a80efb60cfa3dae18682c01980d76d5f7e413e191cd186992e1bf7388d48ab1f", + "flags": [ + "+ofd-locking" + ], + "package": "lukko", + "source": "hackage", + "version": "0.1.1.3" + }, + { + "cabal_sha256": "bc14969ea4adfec6eee20264decf4a07c4002b38b2aa802d58d86b1a2cf7b895", + "revision": 5, + "src_sha256": "b384449f62b2b0aa3e6d2cb1004b8060b01f21ec93e7b63e7af6d8fad8a9f1de", + "flags": [ + "-old-bytestring", + "-old-time" + ], + "package": "tar", + "source": "hackage", + "version": "0.5.1.1" + }, + { + "cabal_sha256": "8214a9d37580f17f8b675109578a5dbe6853559eef156e34dc2233f1123ace33", + "revision": 0, + "src_sha256": "9eaa989ad4534438b5beb51c1d3a4c8f6a088fdff0b259a5394fbf39aaee04da", + "flags": [ + "-bundled-c-zlib", + "-non-blocking-ffi", + "-pkg-config" + ], + "package": "zlib", + "source": "hackage", + "version": "0.6.3.0" + }, + { + "cabal_sha256": "1d4b292bd90970f7ef52c72f2ae365f88bd2c6a75627dc34a31d24bc8f53f2e4", + "revision": 2, + "src_sha256": "bf22cd16dde7d6b7130463f4d7324b64a2964d9ef3f523df97d7cb98544d64a8", + "flags": [ + "+base48", + "+cabal-syntax", + "+lukko", + "-mtl21", + "-old-directory", + "+use-network-uri" + ], + "package": "hackage-security", + "source": "hackage", + "version": "0.6.2.1" + }, + { + "cabal_sha256": "4ff4425c710cddf440dfbac6cd52310bb6b23e17902390ff71c9fc7eaafc4fcc", + "revision": 1, + "src_sha256": "7b99408f580f5bb67a1c413e0bc735886608251331ad36322020f2169aea2ef1", + "flags": [], + "package": "regex-base", + "source": "hackage", + "version": "0.94.0.2" + }, + { + "cabal_sha256": "9dbba4b65a3bb6975d9740814be5593c6b2d2d6a0b3febc8ec940edb9a9bbdf4", + "revision": 1, + "src_sha256": "c7827c391919227711e1cff0a762b1678fd8739f9c902fc183041ff34f59259c", + "flags": [ + "-_regex-posix-clib" + ], + "package": "regex-posix", + "source": "hackage", + "version": "0.96.0.1" + }, + { + "cabal_sha256": "2088eb9368b920f80bbe4e3b03c3b8484090208f5c3b31645bd67a9ef7d26db4", + "revision": 4, + "src_sha256": "81a2bafad484db123cf8d17a02d98bb388a127fd0f822fa022589468a0e64671", + "flags": [], + "package": "resolv", + "source": "hackage", + "version": "0.1.2.0" + }, + { + "cabal_sha256": "6e9b1b233af80cc0aa17ea858d2641ba146fb11cbcc5970a52649e89d77282e2", + "revision": 0, + "src_sha256": "91ce28d8f8a6efd31788d4827ed5cdcb9a546ad4053a86c56f7947c66a30b5bf", + "flags": [], + "package": "safe-exceptions", + "source": "hackage", + "version": "0.1.7.3" + }, + { + "cabal_sha256": null, + "revision": null, + "src_sha256": null, + "flags": [ + "+lukko", + "+native-dns" + ], + "package": "cabal-install", + "source": "local", + "version": "3.8.1.0" + } + ], + "builtin": [ + { + "package": "rts", + "version": "1.0.1" + }, + { + "package": "ghc-prim", + "version": "0.6.1" + }, + { + "package": "integer-gmp", + "version": "1.0.3.0" + }, + { + "package": "base", + "version": "4.14.3.0" + }, + { + "package": "array", + "version": "0.5.4.0" + }, + { + "package": "deepseq", + "version": "1.4.4.0" + }, + { + "package": "bytestring", + "version": "0.10.12.0" + }, + { + "package": "containers", + "version": "0.6.5.1" + }, + { + "package": "binary", + "version": "0.8.8.0" + }, + { + "package": "filepath", + "version": "1.4.2.1" + }, + { + "package": "time", + "version": "1.9.3" + }, + { + "package": "unix", + "version": "2.7.2.2" + }, + { + "package": "directory", + "version": "1.3.6.0" + }, + { + "package": "transformers", + "version": "0.5.6.2" + }, + { + "package": "mtl", + "version": "2.2.2" + }, + { + "package": "ghc-boot-th", + "version": "8.10.7" + }, + { + "package": "pretty", + "version": "1.1.3.6" + }, + { + "package": "template-haskell", + "version": "2.16.0.0" + }, + { + "package": "text", + "version": "1.2.4.1" + }, + { + "package": "parsec", + "version": "3.1.14.0" + }, + { + "package": "stm", + "version": "2.5.0.1" + }, + { + "package": "exceptions", + "version": "0.10.4" + } + ] +} diff --git a/cabal/bootstrap/linux-8.6.5.json b/cabal/bootstrap/linux-8.6.5.json new file mode 100644 --- /dev/null +++ b/cabal/bootstrap/linux-8.6.5.json @@ -0,0 +1,403 @@ +{ + "dependencies": [ + { + "cabal_sha256": null, + "revision": null, + "src_sha256": null, + "flags": [], + "package": "Cabal-syntax", + "source": "local", + "version": "3.8.1.0" + }, + { + "cabal_sha256": "04df32d9497add5f0b90a27a3eceffa4bad5c2f41d038bd12ed6efc454db3faf", + "revision": 0, + "src_sha256": "44b31b6cd3129893ac1a007573dedb69dde667fa06ee108526d58f08b1a1f7ab", + "flags": [], + "package": "process", + "source": "hackage", + "version": "1.6.15.0" + }, + { + "cabal_sha256": null, + "revision": null, + "src_sha256": null, + "flags": [], + "package": "Cabal", + "source": "local", + "version": "3.8.1.0" + }, + { + "cabal_sha256": "e3d78b13db9512aeb106e44a334ab42b7aa48d26c097299084084cb8be5c5568", + "revision": 0, + "src_sha256": "7f7620fef1a1af3d3d6747f510e73223a5c600e7d7fd9ace073d1222bdc63d85", + "flags": [ + "-devel" + ], + "package": "network", + "source": "hackage", + "version": "3.1.2.7" + }, + { + "cabal_sha256": "f65819f74c6ced42b24d9e5053165508c4b6a18271c8e3229dc93b1dc8f7a5ab", + "revision": 1, + "src_sha256": "6b5059caf6714f47da92953badf2f556119877e09708c14e206b3ae98b8681c6", + "flags": [], + "package": "th-compat", + "source": "hackage", + "version": "0.1.3" + }, + { + "cabal_sha256": "a4765164ed0a2d1668446eb2e03460ce98645fbf083598c690846af79b7de10d", + "revision": 0, + "src_sha256": "57856db93608a4d419f681b881c9b8d4448800d5a687587dc37e8a9e0b223584", + "flags": [], + "package": "network-uri", + "source": "hackage", + "version": "2.6.4.1" + }, + { + "cabal_sha256": "16ee1212245c6e7cf0905b039689b55dbe8386a2b450094055e536d30c89ba76", + "revision": 0, + "src_sha256": "df31d8efec775124dab856d7177ddcba31be9f9e0836ebdab03d94392f2dd453", + "flags": [ + "-conduit10", + "+network-uri", + "-warn-as-error", + "-warp-tests" + ], + "package": "HTTP", + "source": "hackage", + "version": "4000.4.1" + }, + { + "cabal_sha256": "eb6758d0160d607e0c45dbd6b196f515b9a589fd4f6d2f926929dd5d56282d37", + "revision": 0, + "src_sha256": "20a21c4b7adb0fd844b25e196241467406a28286b021f9b7a082ab03fa8015eb", + "flags": [], + "package": "base-orphans", + "source": "hackage", + "version": "0.8.6" + }, + { + "cabal_sha256": "0cddd0229d1aac305ea0404409c0bbfab81f075817bd74b8b2929eff58333e55", + "revision": 0, + "src_sha256": "83606edd356d914c075ecd44f6d5fe91a3b186aa0683c8dd8c9a7e8e22a47600", + "flags": [ + "+containers", + "+integer-gmp", + "-random-initial-seed" + ], + "package": "hashable", + "source": "hackage", + "version": "1.4.0.2" + }, + { + "cabal_sha256": "b83dec34a53520de84c6dd3dc7aae45d22409b46eb471c478b98108215a370f0", + "revision": 1, + "src_sha256": "484df85be0e76c4fed9376451e48e1d0c6e97952ce79735b72d54297e7e0a725", + "flags": [ + "-bench" + ], + "package": "async", + "source": "hackage", + "version": "2.2.4" + }, + { + "cabal_sha256": "64abad7816ab8cabed8489e29f807b3a6f828e0b2cec0eae404323d69d36df9a", + "revision": 0, + "src_sha256": "1d5a91143ef0e22157536093ec8e59d226a68220ec89378d5dcaeea86472c784", + "flags": [], + "package": "base16-bytestring", + "source": "hackage", + "version": "1.0.2.0" + }, + { + "cabal_sha256": "50ec0e229255d4c45cbdd568da011311b8887f304b931564886016f4984334d8", + "revision": 0, + "src_sha256": "fbf8ed30edde271eb605352021431d8f1b055f95a56af31fe2eacf6bdfdc49c9", + "flags": [], + "package": "base64-bytestring", + "source": "hackage", + "version": "1.2.1.0" + }, + { + "cabal_sha256": "714a55fd28d3e2533bd5b49e74f604ef8e5d7b06f249c8816f6c54aed431dcf1", + "revision": 0, + "src_sha256": "6d065402394e7a9117093dbb4530a21342c9b1e2ec509516c8a8d0ffed98ecaa", + "flags": [ + "-optimised-mixer" + ], + "package": "splitmix", + "source": "hackage", + "version": "0.1.0.4" + }, + { + "cabal_sha256": "dea1f11e5569332dc6c8efaad1cb301016a5587b6754943a49f9de08ae0e56d9", + "revision": 0, + "src_sha256": "3e1272f7ed6a4d7bd1712b90143ec326fee9b225789222379fea20a9c90c9b76", + "flags": [], + "package": "random", + "source": "hackage", + "version": "1.2.1.1" + }, + { + "cabal_sha256": "4d33a49cd383d50af090f1b888642d10116e43809f9da6023d9fc6f67d2656ee", + "revision": 1, + "src_sha256": "3e8885ee2f56ad4da940f043ae8f981ee2fe336b5e8e4ba3f7436cff4f526c4a", + "flags": [], + "package": "edit-distance", + "source": "hackage", + "version": "0.2.2.1" + }, + { + "cabal_sha256": null, + "revision": null, + "src_sha256": null, + "flags": [ + "-debug-conflict-sets", + "-debug-expensive-assertions", + "-debug-tracetree" + ], + "package": "cabal-install-solver", + "source": "local", + "version": "3.8.1.0" + }, + { + "cabal_sha256": "188d0b5a0491e8b686b32d9b144c9287760ba333d2509bf3f17e3d846fbc2332", + "revision": 0, + "src_sha256": "73a7dc7163871a80837495039a099967b11f5c4fe70a118277842f7a713c6bf6", + "flags": [ + "-exe", + "+use-cbits" + ], + "package": "cryptohash-sha256", + "source": "hackage", + "version": "0.11.102.1" + }, + { + "cabal_sha256": "ccce771562c49a2b29a52046ca68c62179e97e8fbeacdae32ca84a85445e8f42", + "revision": 0, + "src_sha256": "c9fe1bf2904825a65b667251ec644f197b71dc5c209d2d254be5de3d496b0e43", + "flags": [ + "-example" + ], + "package": "echo", + "source": "hackage", + "version": "0.1.4" + }, + { + "cabal_sha256": "b2c634a95ba2a68e0df3ae67d006f0dabb02edbe4dc77b321133551e308ca047", + "revision": 1, + "src_sha256": "66e3c0b4e2d32287621a3faab6b99c7e03b285a07711f335332aec6b4217bf8b", + "flags": [ + "+transformers-0-4" + ], + "package": "exceptions", + "source": "hackage", + "version": "0.10.5" + }, + { + "cabal_sha256": "24ac7b5f3d9fa3c2f70262b329f2a75f24e7fd829f88c189b388efa1bcd67eb2", + "revision": 5, + "src_sha256": "d8a5958ebfa9309790efade64275dc5c441b568645c45ceed1b0c6ff36d6156d", + "flags": [ + "+no-donna", + "+test-doctests", + "+test-hlint", + "+test-properties" + ], + "package": "ed25519", + "source": "hackage", + "version": "0.0.5.0" + }, + { + "cabal_sha256": "c084c043a40632d3cafcac50fb5eeff84d91edb070a54baa94945f1c976f97c0", + "revision": 2, + "src_sha256": "a80efb60cfa3dae18682c01980d76d5f7e413e191cd186992e1bf7388d48ab1f", + "flags": [ + "+ofd-locking" + ], + "package": "lukko", + "source": "hackage", + "version": "0.1.1.3" + }, + { + "cabal_sha256": "bc14969ea4adfec6eee20264decf4a07c4002b38b2aa802d58d86b1a2cf7b895", + "revision": 5, + "src_sha256": "b384449f62b2b0aa3e6d2cb1004b8060b01f21ec93e7b63e7af6d8fad8a9f1de", + "flags": [ + "-old-bytestring", + "-old-time" + ], + "package": "tar", + "source": "hackage", + "version": "0.5.1.1" + }, + { + "cabal_sha256": "8214a9d37580f17f8b675109578a5dbe6853559eef156e34dc2233f1123ace33", + "revision": 0, + "src_sha256": "9eaa989ad4534438b5beb51c1d3a4c8f6a088fdff0b259a5394fbf39aaee04da", + "flags": [ + "-bundled-c-zlib", + "-non-blocking-ffi", + "-pkg-config" + ], + "package": "zlib", + "source": "hackage", + "version": "0.6.3.0" + }, + { + "cabal_sha256": "1d4b292bd90970f7ef52c72f2ae365f88bd2c6a75627dc34a31d24bc8f53f2e4", + "revision": 2, + "src_sha256": "bf22cd16dde7d6b7130463f4d7324b64a2964d9ef3f523df97d7cb98544d64a8", + "flags": [ + "+base48", + "+cabal-syntax", + "+lukko", + "-mtl21", + "-old-directory", + "+use-network-uri" + ], + "package": "hackage-security", + "source": "hackage", + "version": "0.6.2.1" + }, + { + "cabal_sha256": "4ff4425c710cddf440dfbac6cd52310bb6b23e17902390ff71c9fc7eaafc4fcc", + "revision": 1, + "src_sha256": "7b99408f580f5bb67a1c413e0bc735886608251331ad36322020f2169aea2ef1", + "flags": [], + "package": "regex-base", + "source": "hackage", + "version": "0.94.0.2" + }, + { + "cabal_sha256": "9dbba4b65a3bb6975d9740814be5593c6b2d2d6a0b3febc8ec940edb9a9bbdf4", + "revision": 1, + "src_sha256": "c7827c391919227711e1cff0a762b1678fd8739f9c902fc183041ff34f59259c", + "flags": [ + "-_regex-posix-clib" + ], + "package": "regex-posix", + "source": "hackage", + "version": "0.96.0.1" + }, + { + "cabal_sha256": "2088eb9368b920f80bbe4e3b03c3b8484090208f5c3b31645bd67a9ef7d26db4", + "revision": 4, + "src_sha256": "81a2bafad484db123cf8d17a02d98bb388a127fd0f822fa022589468a0e64671", + "flags": [], + "package": "resolv", + "source": "hackage", + "version": "0.1.2.0" + }, + { + "cabal_sha256": "6e9b1b233af80cc0aa17ea858d2641ba146fb11cbcc5970a52649e89d77282e2", + "revision": 0, + "src_sha256": "91ce28d8f8a6efd31788d4827ed5cdcb9a546ad4053a86c56f7947c66a30b5bf", + "flags": [], + "package": "safe-exceptions", + "source": "hackage", + "version": "0.1.7.3" + }, + { + "cabal_sha256": null, + "revision": null, + "src_sha256": null, + "flags": [ + "+lukko", + "+native-dns" + ], + "package": "cabal-install", + "source": "local", + "version": "3.8.1.0" + } + ], + "builtin": [ + { + "package": "rts", + "version": "1.0" + }, + { + "package": "ghc-prim", + "version": "0.5.3" + }, + { + "package": "integer-gmp", + "version": "1.0.2.0" + }, + { + "package": "base", + "version": "4.12.0.0" + }, + { + "package": "array", + "version": "0.5.3.0" + }, + { + "package": "deepseq", + "version": "1.4.4.0" + }, + { + "package": "bytestring", + "version": "0.10.8.2" + }, + { + "package": "containers", + "version": "0.6.0.1" + }, + { + "package": "binary", + "version": "0.8.6.0" + }, + { + "package": "filepath", + "version": "1.4.2.1" + }, + { + "package": "time", + "version": "1.8.0.2" + }, + { + "package": "unix", + "version": "2.7.2.2" + }, + { + "package": "directory", + "version": "1.3.3.0" + }, + { + "package": "transformers", + "version": "0.5.6.2" + }, + { + "package": "mtl", + "version": "2.2.2" + }, + { + "package": "text", + "version": "1.2.3.1" + }, + { + "package": "parsec", + "version": "3.1.13.0" + }, + { + "package": "pretty", + "version": "1.1.3.6" + }, + { + "package": "ghc-boot-th", + "version": "8.6.5" + }, + { + "package": "template-haskell", + "version": "2.14.0.0" + }, + { + "package": "stm", + "version": "2.5.0.0" + } + ] +} diff --git a/cabal/bootstrap/linux-8.8.4.json b/cabal/bootstrap/linux-8.8.4.json new file mode 100644 --- /dev/null +++ b/cabal/bootstrap/linux-8.8.4.json @@ -0,0 +1,403 @@ +{ + "dependencies": [ + { + "cabal_sha256": null, + "revision": null, + "src_sha256": null, + "flags": [], + "package": "Cabal-syntax", + "source": "local", + "version": "3.8.1.0" + }, + { + "cabal_sha256": "04df32d9497add5f0b90a27a3eceffa4bad5c2f41d038bd12ed6efc454db3faf", + "revision": 0, + "src_sha256": "44b31b6cd3129893ac1a007573dedb69dde667fa06ee108526d58f08b1a1f7ab", + "flags": [], + "package": "process", + "source": "hackage", + "version": "1.6.15.0" + }, + { + "cabal_sha256": null, + "revision": null, + "src_sha256": null, + "flags": [], + "package": "Cabal", + "source": "local", + "version": "3.8.1.0" + }, + { + "cabal_sha256": "e3d78b13db9512aeb106e44a334ab42b7aa48d26c097299084084cb8be5c5568", + "revision": 0, + "src_sha256": "7f7620fef1a1af3d3d6747f510e73223a5c600e7d7fd9ace073d1222bdc63d85", + "flags": [ + "-devel" + ], + "package": "network", + "source": "hackage", + "version": "3.1.2.7" + }, + { + "cabal_sha256": "f65819f74c6ced42b24d9e5053165508c4b6a18271c8e3229dc93b1dc8f7a5ab", + "revision": 1, + "src_sha256": "6b5059caf6714f47da92953badf2f556119877e09708c14e206b3ae98b8681c6", + "flags": [], + "package": "th-compat", + "source": "hackage", + "version": "0.1.3" + }, + { + "cabal_sha256": "a4765164ed0a2d1668446eb2e03460ce98645fbf083598c690846af79b7de10d", + "revision": 0, + "src_sha256": "57856db93608a4d419f681b881c9b8d4448800d5a687587dc37e8a9e0b223584", + "flags": [], + "package": "network-uri", + "source": "hackage", + "version": "2.6.4.1" + }, + { + "cabal_sha256": "16ee1212245c6e7cf0905b039689b55dbe8386a2b450094055e536d30c89ba76", + "revision": 0, + "src_sha256": "df31d8efec775124dab856d7177ddcba31be9f9e0836ebdab03d94392f2dd453", + "flags": [ + "-conduit10", + "+network-uri", + "-warn-as-error", + "-warp-tests" + ], + "package": "HTTP", + "source": "hackage", + "version": "4000.4.1" + }, + { + "cabal_sha256": "eb6758d0160d607e0c45dbd6b196f515b9a589fd4f6d2f926929dd5d56282d37", + "revision": 0, + "src_sha256": "20a21c4b7adb0fd844b25e196241467406a28286b021f9b7a082ab03fa8015eb", + "flags": [], + "package": "base-orphans", + "source": "hackage", + "version": "0.8.6" + }, + { + "cabal_sha256": "0cddd0229d1aac305ea0404409c0bbfab81f075817bd74b8b2929eff58333e55", + "revision": 0, + "src_sha256": "83606edd356d914c075ecd44f6d5fe91a3b186aa0683c8dd8c9a7e8e22a47600", + "flags": [ + "+containers", + "+integer-gmp", + "-random-initial-seed" + ], + "package": "hashable", + "source": "hackage", + "version": "1.4.0.2" + }, + { + "cabal_sha256": "b83dec34a53520de84c6dd3dc7aae45d22409b46eb471c478b98108215a370f0", + "revision": 1, + "src_sha256": "484df85be0e76c4fed9376451e48e1d0c6e97952ce79735b72d54297e7e0a725", + "flags": [ + "-bench" + ], + "package": "async", + "source": "hackage", + "version": "2.2.4" + }, + { + "cabal_sha256": "64abad7816ab8cabed8489e29f807b3a6f828e0b2cec0eae404323d69d36df9a", + "revision": 0, + "src_sha256": "1d5a91143ef0e22157536093ec8e59d226a68220ec89378d5dcaeea86472c784", + "flags": [], + "package": "base16-bytestring", + "source": "hackage", + "version": "1.0.2.0" + }, + { + "cabal_sha256": "50ec0e229255d4c45cbdd568da011311b8887f304b931564886016f4984334d8", + "revision": 0, + "src_sha256": "fbf8ed30edde271eb605352021431d8f1b055f95a56af31fe2eacf6bdfdc49c9", + "flags": [], + "package": "base64-bytestring", + "source": "hackage", + "version": "1.2.1.0" + }, + { + "cabal_sha256": "714a55fd28d3e2533bd5b49e74f604ef8e5d7b06f249c8816f6c54aed431dcf1", + "revision": 0, + "src_sha256": "6d065402394e7a9117093dbb4530a21342c9b1e2ec509516c8a8d0ffed98ecaa", + "flags": [ + "-optimised-mixer" + ], + "package": "splitmix", + "source": "hackage", + "version": "0.1.0.4" + }, + { + "cabal_sha256": "dea1f11e5569332dc6c8efaad1cb301016a5587b6754943a49f9de08ae0e56d9", + "revision": 0, + "src_sha256": "3e1272f7ed6a4d7bd1712b90143ec326fee9b225789222379fea20a9c90c9b76", + "flags": [], + "package": "random", + "source": "hackage", + "version": "1.2.1.1" + }, + { + "cabal_sha256": "4d33a49cd383d50af090f1b888642d10116e43809f9da6023d9fc6f67d2656ee", + "revision": 1, + "src_sha256": "3e8885ee2f56ad4da940f043ae8f981ee2fe336b5e8e4ba3f7436cff4f526c4a", + "flags": [], + "package": "edit-distance", + "source": "hackage", + "version": "0.2.2.1" + }, + { + "cabal_sha256": null, + "revision": null, + "src_sha256": null, + "flags": [ + "-debug-conflict-sets", + "-debug-expensive-assertions", + "-debug-tracetree" + ], + "package": "cabal-install-solver", + "source": "local", + "version": "3.8.1.0" + }, + { + "cabal_sha256": "188d0b5a0491e8b686b32d9b144c9287760ba333d2509bf3f17e3d846fbc2332", + "revision": 0, + "src_sha256": "73a7dc7163871a80837495039a099967b11f5c4fe70a118277842f7a713c6bf6", + "flags": [ + "-exe", + "+use-cbits" + ], + "package": "cryptohash-sha256", + "source": "hackage", + "version": "0.11.102.1" + }, + { + "cabal_sha256": "ccce771562c49a2b29a52046ca68c62179e97e8fbeacdae32ca84a85445e8f42", + "revision": 0, + "src_sha256": "c9fe1bf2904825a65b667251ec644f197b71dc5c209d2d254be5de3d496b0e43", + "flags": [ + "-example" + ], + "package": "echo", + "source": "hackage", + "version": "0.1.4" + }, + { + "cabal_sha256": "b2c634a95ba2a68e0df3ae67d006f0dabb02edbe4dc77b321133551e308ca047", + "revision": 1, + "src_sha256": "66e3c0b4e2d32287621a3faab6b99c7e03b285a07711f335332aec6b4217bf8b", + "flags": [ + "+transformers-0-4" + ], + "package": "exceptions", + "source": "hackage", + "version": "0.10.5" + }, + { + "cabal_sha256": "24ac7b5f3d9fa3c2f70262b329f2a75f24e7fd829f88c189b388efa1bcd67eb2", + "revision": 5, + "src_sha256": "d8a5958ebfa9309790efade64275dc5c441b568645c45ceed1b0c6ff36d6156d", + "flags": [ + "+no-donna", + "+test-doctests", + "+test-hlint", + "+test-properties" + ], + "package": "ed25519", + "source": "hackage", + "version": "0.0.5.0" + }, + { + "cabal_sha256": "c084c043a40632d3cafcac50fb5eeff84d91edb070a54baa94945f1c976f97c0", + "revision": 2, + "src_sha256": "a80efb60cfa3dae18682c01980d76d5f7e413e191cd186992e1bf7388d48ab1f", + "flags": [ + "+ofd-locking" + ], + "package": "lukko", + "source": "hackage", + "version": "0.1.1.3" + }, + { + "cabal_sha256": "bc14969ea4adfec6eee20264decf4a07c4002b38b2aa802d58d86b1a2cf7b895", + "revision": 5, + "src_sha256": "b384449f62b2b0aa3e6d2cb1004b8060b01f21ec93e7b63e7af6d8fad8a9f1de", + "flags": [ + "-old-bytestring", + "-old-time" + ], + "package": "tar", + "source": "hackage", + "version": "0.5.1.1" + }, + { + "cabal_sha256": "8214a9d37580f17f8b675109578a5dbe6853559eef156e34dc2233f1123ace33", + "revision": 0, + "src_sha256": "9eaa989ad4534438b5beb51c1d3a4c8f6a088fdff0b259a5394fbf39aaee04da", + "flags": [ + "-bundled-c-zlib", + "-non-blocking-ffi", + "-pkg-config" + ], + "package": "zlib", + "source": "hackage", + "version": "0.6.3.0" + }, + { + "cabal_sha256": "1d4b292bd90970f7ef52c72f2ae365f88bd2c6a75627dc34a31d24bc8f53f2e4", + "revision": 2, + "src_sha256": "bf22cd16dde7d6b7130463f4d7324b64a2964d9ef3f523df97d7cb98544d64a8", + "flags": [ + "+base48", + "+cabal-syntax", + "+lukko", + "-mtl21", + "-old-directory", + "+use-network-uri" + ], + "package": "hackage-security", + "source": "hackage", + "version": "0.6.2.1" + }, + { + "cabal_sha256": "4ff4425c710cddf440dfbac6cd52310bb6b23e17902390ff71c9fc7eaafc4fcc", + "revision": 1, + "src_sha256": "7b99408f580f5bb67a1c413e0bc735886608251331ad36322020f2169aea2ef1", + "flags": [], + "package": "regex-base", + "source": "hackage", + "version": "0.94.0.2" + }, + { + "cabal_sha256": "9dbba4b65a3bb6975d9740814be5593c6b2d2d6a0b3febc8ec940edb9a9bbdf4", + "revision": 1, + "src_sha256": "c7827c391919227711e1cff0a762b1678fd8739f9c902fc183041ff34f59259c", + "flags": [ + "-_regex-posix-clib" + ], + "package": "regex-posix", + "source": "hackage", + "version": "0.96.0.1" + }, + { + "cabal_sha256": "2088eb9368b920f80bbe4e3b03c3b8484090208f5c3b31645bd67a9ef7d26db4", + "revision": 4, + "src_sha256": "81a2bafad484db123cf8d17a02d98bb388a127fd0f822fa022589468a0e64671", + "flags": [], + "package": "resolv", + "source": "hackage", + "version": "0.1.2.0" + }, + { + "cabal_sha256": "6e9b1b233af80cc0aa17ea858d2641ba146fb11cbcc5970a52649e89d77282e2", + "revision": 0, + "src_sha256": "91ce28d8f8a6efd31788d4827ed5cdcb9a546ad4053a86c56f7947c66a30b5bf", + "flags": [], + "package": "safe-exceptions", + "source": "hackage", + "version": "0.1.7.3" + }, + { + "cabal_sha256": null, + "revision": null, + "src_sha256": null, + "flags": [ + "+lukko", + "+native-dns" + ], + "package": "cabal-install", + "source": "local", + "version": "3.8.1.0" + } + ], + "builtin": [ + { + "package": "rts", + "version": "1.0" + }, + { + "package": "ghc-prim", + "version": "0.5.3" + }, + { + "package": "integer-gmp", + "version": "1.0.2.0" + }, + { + "package": "base", + "version": "4.13.0.0" + }, + { + "package": "array", + "version": "0.5.4.0" + }, + { + "package": "deepseq", + "version": "1.4.4.0" + }, + { + "package": "bytestring", + "version": "0.10.10.1" + }, + { + "package": "containers", + "version": "0.6.2.1" + }, + { + "package": "binary", + "version": "0.8.7.0" + }, + { + "package": "filepath", + "version": "1.4.2.1" + }, + { + "package": "time", + "version": "1.9.3" + }, + { + "package": "unix", + "version": "2.7.2.2" + }, + { + "package": "directory", + "version": "1.3.6.0" + }, + { + "package": "transformers", + "version": "0.5.6.2" + }, + { + "package": "mtl", + "version": "2.2.2" + }, + { + "package": "ghc-boot-th", + "version": "8.8.4" + }, + { + "package": "pretty", + "version": "1.1.3.6" + }, + { + "package": "template-haskell", + "version": "2.15.0.0" + }, + { + "package": "text", + "version": "1.2.4.0" + }, + { + "package": "parsec", + "version": "3.1.14.0" + }, + { + "package": "stm", + "version": "2.5.0.0" + } + ] +} diff --git a/cabal/bootstrap/linux-9.0.2.json b/cabal/bootstrap/linux-9.0.2.json new file mode 100644 --- /dev/null +++ b/cabal/bootstrap/linux-9.0.2.json @@ -0,0 +1,396 @@ +{ + "dependencies": [ + { + "cabal_sha256": null, + "revision": null, + "src_sha256": null, + "flags": [], + "package": "Cabal-syntax", + "source": "local", + "version": "3.8.1.0" + }, + { + "cabal_sha256": "04df32d9497add5f0b90a27a3eceffa4bad5c2f41d038bd12ed6efc454db3faf", + "revision": 0, + "src_sha256": "44b31b6cd3129893ac1a007573dedb69dde667fa06ee108526d58f08b1a1f7ab", + "flags": [], + "package": "process", + "source": "hackage", + "version": "1.6.15.0" + }, + { + "cabal_sha256": null, + "revision": null, + "src_sha256": null, + "flags": [], + "package": "Cabal", + "source": "local", + "version": "3.8.1.0" + }, + { + "cabal_sha256": "e3d78b13db9512aeb106e44a334ab42b7aa48d26c097299084084cb8be5c5568", + "revision": 0, + "src_sha256": "7f7620fef1a1af3d3d6747f510e73223a5c600e7d7fd9ace073d1222bdc63d85", + "flags": [ + "-devel" + ], + "package": "network", + "source": "hackage", + "version": "3.1.2.7" + }, + { + "cabal_sha256": "f65819f74c6ced42b24d9e5053165508c4b6a18271c8e3229dc93b1dc8f7a5ab", + "revision": 1, + "src_sha256": "6b5059caf6714f47da92953badf2f556119877e09708c14e206b3ae98b8681c6", + "flags": [], + "package": "th-compat", + "source": "hackage", + "version": "0.1.3" + }, + { + "cabal_sha256": "a4765164ed0a2d1668446eb2e03460ce98645fbf083598c690846af79b7de10d", + "revision": 0, + "src_sha256": "57856db93608a4d419f681b881c9b8d4448800d5a687587dc37e8a9e0b223584", + "flags": [], + "package": "network-uri", + "source": "hackage", + "version": "2.6.4.1" + }, + { + "cabal_sha256": "16ee1212245c6e7cf0905b039689b55dbe8386a2b450094055e536d30c89ba76", + "revision": 0, + "src_sha256": "df31d8efec775124dab856d7177ddcba31be9f9e0836ebdab03d94392f2dd453", + "flags": [ + "-conduit10", + "+network-uri", + "-warn-as-error", + "-warp-tests" + ], + "package": "HTTP", + "source": "hackage", + "version": "4000.4.1" + }, + { + "cabal_sha256": "eb6758d0160d607e0c45dbd6b196f515b9a589fd4f6d2f926929dd5d56282d37", + "revision": 0, + "src_sha256": "20a21c4b7adb0fd844b25e196241467406a28286b021f9b7a082ab03fa8015eb", + "flags": [], + "package": "base-orphans", + "source": "hackage", + "version": "0.8.6" + }, + { + "cabal_sha256": "0cddd0229d1aac305ea0404409c0bbfab81f075817bd74b8b2929eff58333e55", + "revision": 0, + "src_sha256": "83606edd356d914c075ecd44f6d5fe91a3b186aa0683c8dd8c9a7e8e22a47600", + "flags": [ + "+containers", + "+integer-gmp", + "-random-initial-seed" + ], + "package": "hashable", + "source": "hackage", + "version": "1.4.0.2" + }, + { + "cabal_sha256": "b83dec34a53520de84c6dd3dc7aae45d22409b46eb471c478b98108215a370f0", + "revision": 1, + "src_sha256": "484df85be0e76c4fed9376451e48e1d0c6e97952ce79735b72d54297e7e0a725", + "flags": [ + "-bench" + ], + "package": "async", + "source": "hackage", + "version": "2.2.4" + }, + { + "cabal_sha256": "64abad7816ab8cabed8489e29f807b3a6f828e0b2cec0eae404323d69d36df9a", + "revision": 0, + "src_sha256": "1d5a91143ef0e22157536093ec8e59d226a68220ec89378d5dcaeea86472c784", + "flags": [], + "package": "base16-bytestring", + "source": "hackage", + "version": "1.0.2.0" + }, + { + "cabal_sha256": "50ec0e229255d4c45cbdd568da011311b8887f304b931564886016f4984334d8", + "revision": 0, + "src_sha256": "fbf8ed30edde271eb605352021431d8f1b055f95a56af31fe2eacf6bdfdc49c9", + "flags": [], + "package": "base64-bytestring", + "source": "hackage", + "version": "1.2.1.0" + }, + { + "cabal_sha256": "714a55fd28d3e2533bd5b49e74f604ef8e5d7b06f249c8816f6c54aed431dcf1", + "revision": 0, + "src_sha256": "6d065402394e7a9117093dbb4530a21342c9b1e2ec509516c8a8d0ffed98ecaa", + "flags": [ + "-optimised-mixer" + ], + "package": "splitmix", + "source": "hackage", + "version": "0.1.0.4" + }, + { + "cabal_sha256": "dea1f11e5569332dc6c8efaad1cb301016a5587b6754943a49f9de08ae0e56d9", + "revision": 0, + "src_sha256": "3e1272f7ed6a4d7bd1712b90143ec326fee9b225789222379fea20a9c90c9b76", + "flags": [], + "package": "random", + "source": "hackage", + "version": "1.2.1.1" + }, + { + "cabal_sha256": "4d33a49cd383d50af090f1b888642d10116e43809f9da6023d9fc6f67d2656ee", + "revision": 1, + "src_sha256": "3e8885ee2f56ad4da940f043ae8f981ee2fe336b5e8e4ba3f7436cff4f526c4a", + "flags": [], + "package": "edit-distance", + "source": "hackage", + "version": "0.2.2.1" + }, + { + "cabal_sha256": null, + "revision": null, + "src_sha256": null, + "flags": [ + "-debug-conflict-sets", + "-debug-expensive-assertions", + "-debug-tracetree" + ], + "package": "cabal-install-solver", + "source": "local", + "version": "3.8.1.0" + }, + { + "cabal_sha256": "188d0b5a0491e8b686b32d9b144c9287760ba333d2509bf3f17e3d846fbc2332", + "revision": 0, + "src_sha256": "73a7dc7163871a80837495039a099967b11f5c4fe70a118277842f7a713c6bf6", + "flags": [ + "-exe", + "+use-cbits" + ], + "package": "cryptohash-sha256", + "source": "hackage", + "version": "0.11.102.1" + }, + { + "cabal_sha256": "ccce771562c49a2b29a52046ca68c62179e97e8fbeacdae32ca84a85445e8f42", + "revision": 0, + "src_sha256": "c9fe1bf2904825a65b667251ec644f197b71dc5c209d2d254be5de3d496b0e43", + "flags": [ + "-example" + ], + "package": "echo", + "source": "hackage", + "version": "0.1.4" + }, + { + "cabal_sha256": "24ac7b5f3d9fa3c2f70262b329f2a75f24e7fd829f88c189b388efa1bcd67eb2", + "revision": 5, + "src_sha256": "d8a5958ebfa9309790efade64275dc5c441b568645c45ceed1b0c6ff36d6156d", + "flags": [ + "+no-donna", + "+test-doctests", + "+test-hlint", + "+test-properties" + ], + "package": "ed25519", + "source": "hackage", + "version": "0.0.5.0" + }, + { + "cabal_sha256": "c084c043a40632d3cafcac50fb5eeff84d91edb070a54baa94945f1c976f97c0", + "revision": 2, + "src_sha256": "a80efb60cfa3dae18682c01980d76d5f7e413e191cd186992e1bf7388d48ab1f", + "flags": [ + "+ofd-locking" + ], + "package": "lukko", + "source": "hackage", + "version": "0.1.1.3" + }, + { + "cabal_sha256": "bc14969ea4adfec6eee20264decf4a07c4002b38b2aa802d58d86b1a2cf7b895", + "revision": 5, + "src_sha256": "b384449f62b2b0aa3e6d2cb1004b8060b01f21ec93e7b63e7af6d8fad8a9f1de", + "flags": [ + "-old-bytestring", + "-old-time" + ], + "package": "tar", + "source": "hackage", + "version": "0.5.1.1" + }, + { + "cabal_sha256": "8214a9d37580f17f8b675109578a5dbe6853559eef156e34dc2233f1123ace33", + "revision": 0, + "src_sha256": "9eaa989ad4534438b5beb51c1d3a4c8f6a088fdff0b259a5394fbf39aaee04da", + "flags": [ + "-bundled-c-zlib", + "-non-blocking-ffi", + "-pkg-config" + ], + "package": "zlib", + "source": "hackage", + "version": "0.6.3.0" + }, + { + "cabal_sha256": "1d4b292bd90970f7ef52c72f2ae365f88bd2c6a75627dc34a31d24bc8f53f2e4", + "revision": 2, + "src_sha256": "bf22cd16dde7d6b7130463f4d7324b64a2964d9ef3f523df97d7cb98544d64a8", + "flags": [ + "+base48", + "+cabal-syntax", + "+lukko", + "-mtl21", + "-old-directory", + "+use-network-uri" + ], + "package": "hackage-security", + "source": "hackage", + "version": "0.6.2.1" + }, + { + "cabal_sha256": "4ff4425c710cddf440dfbac6cd52310bb6b23e17902390ff71c9fc7eaafc4fcc", + "revision": 1, + "src_sha256": "7b99408f580f5bb67a1c413e0bc735886608251331ad36322020f2169aea2ef1", + "flags": [], + "package": "regex-base", + "source": "hackage", + "version": "0.94.0.2" + }, + { + "cabal_sha256": "9dbba4b65a3bb6975d9740814be5593c6b2d2d6a0b3febc8ec940edb9a9bbdf4", + "revision": 1, + "src_sha256": "c7827c391919227711e1cff0a762b1678fd8739f9c902fc183041ff34f59259c", + "flags": [ + "-_regex-posix-clib" + ], + "package": "regex-posix", + "source": "hackage", + "version": "0.96.0.1" + }, + { + "cabal_sha256": "2088eb9368b920f80bbe4e3b03c3b8484090208f5c3b31645bd67a9ef7d26db4", + "revision": 4, + "src_sha256": "81a2bafad484db123cf8d17a02d98bb388a127fd0f822fa022589468a0e64671", + "flags": [], + "package": "resolv", + "source": "hackage", + "version": "0.1.2.0" + }, + { + "cabal_sha256": "6e9b1b233af80cc0aa17ea858d2641ba146fb11cbcc5970a52649e89d77282e2", + "revision": 0, + "src_sha256": "91ce28d8f8a6efd31788d4827ed5cdcb9a546ad4053a86c56f7947c66a30b5bf", + "flags": [], + "package": "safe-exceptions", + "source": "hackage", + "version": "0.1.7.3" + }, + { + "cabal_sha256": null, + "revision": null, + "src_sha256": null, + "flags": [ + "+lukko", + "+native-dns" + ], + "package": "cabal-install", + "source": "local", + "version": "3.8.1.0" + } + ], + "builtin": [ + { + "package": "rts", + "version": "1.0.2" + }, + { + "package": "ghc-prim", + "version": "0.7.0" + }, + { + "package": "ghc-bignum", + "version": "1.1" + }, + { + "package": "base", + "version": "4.15.1.0" + }, + { + "package": "array", + "version": "0.5.4.0" + }, + { + "package": "deepseq", + "version": "1.4.5.0" + }, + { + "package": "bytestring", + "version": "0.10.12.1" + }, + { + "package": "containers", + "version": "0.6.4.1" + }, + { + "package": "binary", + "version": "0.8.8.0" + }, + { + "package": "filepath", + "version": "1.4.2.1" + }, + { + "package": "time", + "version": "1.9.3" + }, + { + "package": "unix", + "version": "2.7.2.2" + }, + { + "package": "directory", + "version": "1.3.6.2" + }, + { + "package": "transformers", + "version": "0.5.6.2" + }, + { + "package": "mtl", + "version": "2.2.2" + }, + { + "package": "ghc-boot-th", + "version": "9.0.2" + }, + { + "package": "pretty", + "version": "1.1.3.6" + }, + { + "package": "template-haskell", + "version": "2.17.0.0" + }, + { + "package": "text", + "version": "1.2.5.0" + }, + { + "package": "parsec", + "version": "3.1.14.0" + }, + { + "package": "stm", + "version": "2.5.0.0" + }, + { + "package": "exceptions", + "version": "0.10.4" + } + ] +} diff --git a/cabal/bootstrap/linux-9.2.3.json b/cabal/bootstrap/linux-9.2.3.json new file mode 100644 --- /dev/null +++ b/cabal/bootstrap/linux-9.2.3.json @@ -0,0 +1,387 @@ +{ + "dependencies": [ + { + "cabal_sha256": null, + "revision": null, + "src_sha256": null, + "flags": [], + "package": "Cabal-syntax", + "source": "local", + "version": "3.8.1.0" + }, + { + "cabal_sha256": "04df32d9497add5f0b90a27a3eceffa4bad5c2f41d038bd12ed6efc454db3faf", + "revision": 0, + "src_sha256": "44b31b6cd3129893ac1a007573dedb69dde667fa06ee108526d58f08b1a1f7ab", + "flags": [], + "package": "process", + "source": "hackage", + "version": "1.6.15.0" + }, + { + "cabal_sha256": null, + "revision": null, + "src_sha256": null, + "flags": [], + "package": "Cabal", + "source": "local", + "version": "3.8.1.0" + }, + { + "cabal_sha256": "e3d78b13db9512aeb106e44a334ab42b7aa48d26c097299084084cb8be5c5568", + "revision": 0, + "src_sha256": "7f7620fef1a1af3d3d6747f510e73223a5c600e7d7fd9ace073d1222bdc63d85", + "flags": [ + "-devel" + ], + "package": "network", + "source": "hackage", + "version": "3.1.2.7" + }, + { + "cabal_sha256": "f65819f74c6ced42b24d9e5053165508c4b6a18271c8e3229dc93b1dc8f7a5ab", + "revision": 1, + "src_sha256": "6b5059caf6714f47da92953badf2f556119877e09708c14e206b3ae98b8681c6", + "flags": [], + "package": "th-compat", + "source": "hackage", + "version": "0.1.3" + }, + { + "cabal_sha256": "a4765164ed0a2d1668446eb2e03460ce98645fbf083598c690846af79b7de10d", + "revision": 0, + "src_sha256": "57856db93608a4d419f681b881c9b8d4448800d5a687587dc37e8a9e0b223584", + "flags": [], + "package": "network-uri", + "source": "hackage", + "version": "2.6.4.1" + }, + { + "cabal_sha256": "16ee1212245c6e7cf0905b039689b55dbe8386a2b450094055e536d30c89ba76", + "revision": 0, + "src_sha256": "df31d8efec775124dab856d7177ddcba31be9f9e0836ebdab03d94392f2dd453", + "flags": [ + "-conduit10", + "+network-uri", + "-warn-as-error", + "-warp-tests" + ], + "package": "HTTP", + "source": "hackage", + "version": "4000.4.1" + }, + { + "cabal_sha256": "0cddd0229d1aac305ea0404409c0bbfab81f075817bd74b8b2929eff58333e55", + "revision": 0, + "src_sha256": "83606edd356d914c075ecd44f6d5fe91a3b186aa0683c8dd8c9a7e8e22a47600", + "flags": [ + "+containers", + "+integer-gmp", + "-random-initial-seed" + ], + "package": "hashable", + "source": "hackage", + "version": "1.4.0.2" + }, + { + "cabal_sha256": "b83dec34a53520de84c6dd3dc7aae45d22409b46eb471c478b98108215a370f0", + "revision": 1, + "src_sha256": "484df85be0e76c4fed9376451e48e1d0c6e97952ce79735b72d54297e7e0a725", + "flags": [ + "-bench" + ], + "package": "async", + "source": "hackage", + "version": "2.2.4" + }, + { + "cabal_sha256": "64abad7816ab8cabed8489e29f807b3a6f828e0b2cec0eae404323d69d36df9a", + "revision": 0, + "src_sha256": "1d5a91143ef0e22157536093ec8e59d226a68220ec89378d5dcaeea86472c784", + "flags": [], + "package": "base16-bytestring", + "source": "hackage", + "version": "1.0.2.0" + }, + { + "cabal_sha256": "50ec0e229255d4c45cbdd568da011311b8887f304b931564886016f4984334d8", + "revision": 0, + "src_sha256": "fbf8ed30edde271eb605352021431d8f1b055f95a56af31fe2eacf6bdfdc49c9", + "flags": [], + "package": "base64-bytestring", + "source": "hackage", + "version": "1.2.1.0" + }, + { + "cabal_sha256": "714a55fd28d3e2533bd5b49e74f604ef8e5d7b06f249c8816f6c54aed431dcf1", + "revision": 0, + "src_sha256": "6d065402394e7a9117093dbb4530a21342c9b1e2ec509516c8a8d0ffed98ecaa", + "flags": [ + "-optimised-mixer" + ], + "package": "splitmix", + "source": "hackage", + "version": "0.1.0.4" + }, + { + "cabal_sha256": "dea1f11e5569332dc6c8efaad1cb301016a5587b6754943a49f9de08ae0e56d9", + "revision": 0, + "src_sha256": "3e1272f7ed6a4d7bd1712b90143ec326fee9b225789222379fea20a9c90c9b76", + "flags": [], + "package": "random", + "source": "hackage", + "version": "1.2.1.1" + }, + { + "cabal_sha256": "4d33a49cd383d50af090f1b888642d10116e43809f9da6023d9fc6f67d2656ee", + "revision": 1, + "src_sha256": "3e8885ee2f56ad4da940f043ae8f981ee2fe336b5e8e4ba3f7436cff4f526c4a", + "flags": [], + "package": "edit-distance", + "source": "hackage", + "version": "0.2.2.1" + }, + { + "cabal_sha256": null, + "revision": null, + "src_sha256": null, + "flags": [ + "-debug-conflict-sets", + "-debug-expensive-assertions", + "-debug-tracetree" + ], + "package": "cabal-install-solver", + "source": "local", + "version": "3.8.1.0" + }, + { + "cabal_sha256": "188d0b5a0491e8b686b32d9b144c9287760ba333d2509bf3f17e3d846fbc2332", + "revision": 0, + "src_sha256": "73a7dc7163871a80837495039a099967b11f5c4fe70a118277842f7a713c6bf6", + "flags": [ + "-exe", + "+use-cbits" + ], + "package": "cryptohash-sha256", + "source": "hackage", + "version": "0.11.102.1" + }, + { + "cabal_sha256": "ccce771562c49a2b29a52046ca68c62179e97e8fbeacdae32ca84a85445e8f42", + "revision": 0, + "src_sha256": "c9fe1bf2904825a65b667251ec644f197b71dc5c209d2d254be5de3d496b0e43", + "flags": [ + "-example" + ], + "package": "echo", + "source": "hackage", + "version": "0.1.4" + }, + { + "cabal_sha256": "24ac7b5f3d9fa3c2f70262b329f2a75f24e7fd829f88c189b388efa1bcd67eb2", + "revision": 5, + "src_sha256": "d8a5958ebfa9309790efade64275dc5c441b568645c45ceed1b0c6ff36d6156d", + "flags": [ + "+no-donna", + "+test-doctests", + "+test-hlint", + "+test-properties" + ], + "package": "ed25519", + "source": "hackage", + "version": "0.0.5.0" + }, + { + "cabal_sha256": "c084c043a40632d3cafcac50fb5eeff84d91edb070a54baa94945f1c976f97c0", + "revision": 2, + "src_sha256": "a80efb60cfa3dae18682c01980d76d5f7e413e191cd186992e1bf7388d48ab1f", + "flags": [ + "+ofd-locking" + ], + "package": "lukko", + "source": "hackage", + "version": "0.1.1.3" + }, + { + "cabal_sha256": "bc14969ea4adfec6eee20264decf4a07c4002b38b2aa802d58d86b1a2cf7b895", + "revision": 5, + "src_sha256": "b384449f62b2b0aa3e6d2cb1004b8060b01f21ec93e7b63e7af6d8fad8a9f1de", + "flags": [ + "-old-bytestring", + "-old-time" + ], + "package": "tar", + "source": "hackage", + "version": "0.5.1.1" + }, + { + "cabal_sha256": "8214a9d37580f17f8b675109578a5dbe6853559eef156e34dc2233f1123ace33", + "revision": 0, + "src_sha256": "9eaa989ad4534438b5beb51c1d3a4c8f6a088fdff0b259a5394fbf39aaee04da", + "flags": [ + "-bundled-c-zlib", + "-non-blocking-ffi", + "-pkg-config" + ], + "package": "zlib", + "source": "hackage", + "version": "0.6.3.0" + }, + { + "cabal_sha256": "1d4b292bd90970f7ef52c72f2ae365f88bd2c6a75627dc34a31d24bc8f53f2e4", + "revision": 2, + "src_sha256": "bf22cd16dde7d6b7130463f4d7324b64a2964d9ef3f523df97d7cb98544d64a8", + "flags": [ + "+base48", + "+cabal-syntax", + "+lukko", + "-mtl21", + "-old-directory", + "+use-network-uri" + ], + "package": "hackage-security", + "source": "hackage", + "version": "0.6.2.1" + }, + { + "cabal_sha256": "4ff4425c710cddf440dfbac6cd52310bb6b23e17902390ff71c9fc7eaafc4fcc", + "revision": 1, + "src_sha256": "7b99408f580f5bb67a1c413e0bc735886608251331ad36322020f2169aea2ef1", + "flags": [], + "package": "regex-base", + "source": "hackage", + "version": "0.94.0.2" + }, + { + "cabal_sha256": "9dbba4b65a3bb6975d9740814be5593c6b2d2d6a0b3febc8ec940edb9a9bbdf4", + "revision": 1, + "src_sha256": "c7827c391919227711e1cff0a762b1678fd8739f9c902fc183041ff34f59259c", + "flags": [ + "-_regex-posix-clib" + ], + "package": "regex-posix", + "source": "hackage", + "version": "0.96.0.1" + }, + { + "cabal_sha256": "2088eb9368b920f80bbe4e3b03c3b8484090208f5c3b31645bd67a9ef7d26db4", + "revision": 4, + "src_sha256": "81a2bafad484db123cf8d17a02d98bb388a127fd0f822fa022589468a0e64671", + "flags": [], + "package": "resolv", + "source": "hackage", + "version": "0.1.2.0" + }, + { + "cabal_sha256": "6e9b1b233af80cc0aa17ea858d2641ba146fb11cbcc5970a52649e89d77282e2", + "revision": 0, + "src_sha256": "91ce28d8f8a6efd31788d4827ed5cdcb9a546ad4053a86c56f7947c66a30b5bf", + "flags": [], + "package": "safe-exceptions", + "source": "hackage", + "version": "0.1.7.3" + }, + { + "cabal_sha256": null, + "revision": null, + "src_sha256": null, + "flags": [ + "+lukko", + "+native-dns" + ], + "package": "cabal-install", + "source": "local", + "version": "3.8.1.0" + } + ], + "builtin": [ + { + "package": "rts", + "version": "1.0.2" + }, + { + "package": "ghc-prim", + "version": "0.8.0" + }, + { + "package": "ghc-bignum", + "version": "1.2" + }, + { + "package": "base", + "version": "4.16.2.0" + }, + { + "package": "array", + "version": "0.5.4.0" + }, + { + "package": "deepseq", + "version": "1.4.6.1" + }, + { + "package": "ghc-boot-th", + "version": "9.2.3" + }, + { + "package": "pretty", + "version": "1.1.3.6" + }, + { + "package": "template-haskell", + "version": "2.18.0.0" + }, + { + "package": "bytestring", + "version": "0.11.3.1" + }, + { + "package": "containers", + "version": "0.6.5.1" + }, + { + "package": "binary", + "version": "0.8.9.0" + }, + { + "package": "filepath", + "version": "1.4.2.2" + }, + { + "package": "time", + "version": "1.11.1.1" + }, + { + "package": "unix", + "version": "2.7.2.2" + }, + { + "package": "directory", + "version": "1.3.6.2" + }, + { + "package": "transformers", + "version": "0.5.6.2" + }, + { + "package": "mtl", + "version": "2.2.2" + }, + { + "package": "text", + "version": "1.2.5.0" + }, + { + "package": "parsec", + "version": "3.1.15.0" + }, + { + "package": "stm", + "version": "2.5.0.2" + }, + { + "package": "exceptions", + "version": "0.10.4" + } + ] +} diff --git a/cabal/bootstrap/src/Main.hs b/cabal/bootstrap/src/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/bootstrap/src/Main.hs @@ -0,0 +1,242 @@ +module Main (main) where + +import Control.Monad (when) +import Data.Either (partitionEithers) +import Data.Foldable (for_, traverse_) +import Data.Maybe (listToMaybe) +import Data.String (fromString) +import Data.Traversable (for) +import System.Environment (getArgs) +import System.Exit (exitFailure) +import System.IO (hPutStrLn, stderr) + +import qualified Data.Text as T +import qualified Cabal.Index as I +import qualified Cabal.Plan as P +import qualified Data.Aeson as A +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified Distribution.Types.PackageName as C +import qualified Distribution.Types.Version as C +import qualified Topograph as TG + +------------------------------------------------------------------------------- +-- Main +------------------------------------------------------------------------------- + +main :: IO () +main = do + args <- getArgs + case args of + [fp] -> main1 fp + _ -> die "Usage: cabal-bootstrap-gen plan.json" + +main1 :: FilePath -> IO () +main1 planPath = do + meta <- I.cachedHackageMetadata + plan <- P.decodePlanJson planPath + main2 meta plan + +main2 :: Map.Map C.PackageName I.PackageInfo -> P.PlanJson -> IO () +main2 meta plan = do + info $ show $ Map.keys $ P.pjUnits plan + + -- find cabal-install:exe:cabal unit + (cabalUid, cabalUnit) <- case findCabalExe plan of + Just x -> return x + Nothing -> die "Cannot find cabal-install:exe:cabal unit" + + info $ "cabal-install:exe:cabal unit " ++ show cabalUid + + -- BFS from cabal unit, getting all dependencies + units <- bfs plan cabalUnit + + info $ "Unit order:" + for_ units $ \unit -> do + info $ " - " ++ show (P.uId unit) + + (builtin, deps) <- fmap partitionEithers $ for units $ \unit -> do + let P.PkgId pkgname@(P.PkgName tpkgname) ver@(P.Ver verdigits) = P.uPId unit + + let uid = P.uId unit + + let cpkgname :: C.PackageName + cpkgname = C.mkPackageName (T.unpack tpkgname) + + let cversion :: C.Version + cversion = C.mkVersion verdigits + + case P.uType unit of + P.UnitTypeBuiltin -> + return $ Left Builtin + { builtinPackageName = pkgname + , builtinVersion = ver + } + + _ -> do + (src, rev, revhash) <- case P.uSha256 unit of + Just _ -> do + pkgInfo <- maybe (die $ "Cannot find " ++ show uid ++ " package metadata") return $ + Map.lookup cpkgname meta + relInfo <- maybe (die $ "Cannot find " ++ show uid ++ " version metadata") return $ + Map.lookup cversion $ I.piVersions pkgInfo + + return + ( Hackage + , Just $ fromIntegral (I.riRevision relInfo) + , P.sha256FromByteString $ I.getSHA256 $ I.riCabal relInfo + ) + + Nothing -> case P.uType unit of + P.UnitTypeLocal -> return (Local, Nothing, Nothing) + t -> die $ "Unit of wrong type " ++ show uid ++ " " ++ show t + + return $ Right Dep + { depPackageName = pkgname + , depVersion = ver + , depSource = src + , depSrcHash = P.uSha256 unit + , depRevision = rev + , depRevHash = revhash + , depFlags = + [ (if fval then "+" else "-") ++ T.unpack fname + | (P.FlagName fname, fval) <- Map.toList (P.uFlags unit) + ] + } + + LBS.putStr $ A.encode Result + { resBuiltin = builtin + , resDependencies = deps + } + +bfs :: P.PlanJson -> P.Unit -> IO [P.Unit] +bfs plan unit0 = do + uids <- either (\loop -> die $ "Loop in install-plan " ++ show loop) id $ TG.runG am $ \g -> do + v <- maybe (die "Cannot find cabal-install unit in topograph") return $ + TG.gToVertex g $ P.uId unit0 + + let t = TG.dfs g v + + return $ map (TG.gFromVertex g) $ + -- nub and sort + reverse $ Set.toList $ Set.fromList $ concat t + + units <- for uids $ \uid -> do + unit <- lookupUnit (P.pjUnits plan) uid + case Map.toList (P.uComps unit) of + [(_, compinfo)] -> checkExeDeps uid (P.pjUnits plan) (P.ciExeDeps compinfo) + _ -> die $ "Unit with multiple components " ++ show uid + return unit + + -- Remove non-exe copies of cabal-install. Otherwise, cabal-install + -- may appear as cabal-install:lib before dependencies of + -- cabal-install:exe:cabal, and the bootstrap build tries to build + -- all of cabal-install before those dependencies. + return $ filter (\u -> P.uId u == P.uId unit0 || P.uPId u /= P.uPId unit0) units + where + am :: Map.Map P.UnitId (Set.Set P.UnitId) + am = fmap (foldMap P.ciLibDeps . P.uComps) (P.pjUnits plan) + +checkExeDeps :: P.UnitId -> Map.Map P.UnitId P.Unit -> Set.Set P.UnitId -> IO () +checkExeDeps pkgUid units = traverse_ check . Set.toList where + check uid = do + unit <- lookupUnit units uid + let P.PkgId pkgname _ = P.uPId unit + when (pkgname /= P.PkgName (fromString "hsc2hs")) $ do + die $ "unit " ++ show pkgUid ++ " depends on executable " ++ show uid + +lookupUnit :: Map.Map P.UnitId P.Unit -> P.UnitId -> IO P.Unit +lookupUnit units uid + = maybe (die $ "Cannot find unit " ++ show uid) return + $ Map.lookup uid units + +------------------------------------------------------------------------------- +-- Data +------------------------------------------------------------------------------- + +data Result = Result + { resBuiltin :: [Builtin] + , resDependencies :: [Dep] + } + deriving (Show) + +data Builtin = Builtin + { builtinPackageName :: P.PkgName + , builtinVersion :: P.Ver + } + deriving (Show) + +data Dep = Dep + { depPackageName :: P.PkgName + , depVersion :: P.Ver + , depSource :: SrcType + , depSrcHash :: Maybe P.Sha256 + , depRevision :: Maybe Int + , depRevHash :: Maybe P.Sha256 + , depFlags :: [String] + } + deriving (Show) + +data SrcType + = Hackage + | Local + deriving (Show) + +instance A.ToJSON Result where + toJSON res = A.object + [ fromString "builtin" A..= resBuiltin res + , fromString "dependencies" A..= resDependencies res + ] + +instance A.ToJSON Builtin where + toJSON b = A.object + [ fromString "package" A..= builtinPackageName b + , fromString "version" A..= builtinVersion b + ] + +instance A.ToJSON Dep where + toJSON dep = A.object + [ fromString "package" A..= depPackageName dep + , fromString "version" A..= depVersion dep + , fromString "source" A..= depSource dep + , fromString "src_sha256" A..= depSrcHash dep + , fromString "revision" A..= depRevision dep + , fromString "cabal_sha256" A..= depRevHash dep + , fromString "flags" A..= depFlags dep + ] + +instance A.ToJSON SrcType where + toJSON Hackage = fromString "hackage" + toJSON Local = fromString "local" + +------------------------------------------------------------------------------- +-- Utilities +------------------------------------------------------------------------------- + +-- | Log some debug information to stderr. +-- +-- Disabled by default to keep the output tidy, replace by +-- the version with 'hPutStrLn' when debugging. +-- +info :: String -> IO () +info _msg = return () +-- info msg = hPutStrLn stderr $ "INFO: " ++ msg + +die :: String -> IO a +die msg = do + hPutStrLn stderr msg + exitFailure + +------------------------------------------------------------------------------- +-- Pure bits +------------------------------------------------------------------------------- + +findCabalExe :: P.PlanJson -> Maybe (P.UnitId, P.Unit) +findCabalExe plan = listToMaybe + [ (uid, unit) + | (uid, unit) <- Map.toList (P.pjUnits plan) + , let P.PkgId pkgname _ = P.uPId unit + , pkgname == P.PkgName (fromString "cabal-install") + , Map.keys (P.uComps unit) == [P.CompNameExe (fromString "cabal")] + ] diff --git a/cabal/cabal-benchmarks/LICENSE b/cabal/cabal-benchmarks/LICENSE --- a/cabal/cabal-benchmarks/LICENSE +++ b/cabal/cabal-benchmarks/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2003-2020, Cabal Development Team. +Copyright (c) 2003-2022, Cabal Development Team. See the AUTHORS file for the full list of copyright holders. See */LICENSE for the copyright holders of the subcomponents. diff --git a/cabal/cabal-benchmarks/bench/CabalBenchmarks.hs b/cabal/cabal-benchmarks/bench/CabalBenchmarks.hs --- a/cabal/cabal-benchmarks/bench/CabalBenchmarks.hs +++ b/cabal/cabal-benchmarks/bench/CabalBenchmarks.hs @@ -1,14 +1,117 @@ +{-# OPTIONS_GHC -fno-warn-deprecations #-} module Main where -import Criterion.Main (bench, defaultMain, env, whnf) +import Criterion.Main (bench, bgroup, defaultMain, env, nf, whnf) import Distribution.PackageDescription.Parsec (parseGenericPackageDescriptionMaybe) +import Distribution.Parsec (eitherParsec) +import Distribution.Version import qualified Data.ByteString as BS +import qualified Distribution.Types.VersionInterval.Legacy as Old +import qualified Distribution.Types.VersionInterval as New + +------------------------------------------------------------------------------- +-- Main +------------------------------------------------------------------------------- + main :: IO () main = defaultMain - [ env (BS.readFile "Cabal/Cabal.cabal") $ \bs -> - bench "Cabal" $ whnf parseGenericPackageDescriptionMaybe bs - , env (BS.readFile "cabal-benchmarks/cabal-benchmarks.cabal") $ \bs -> - bench "cabal-benchmarks" $ whnf parseGenericPackageDescriptionMaybe bs + [ bgroup "parseGPD" + [ env (BS.readFile "Cabal/Cabal.cabal") $ \bs -> + bench "Cabal" $ whnf parseGenericPackageDescriptionMaybe bs + , env (BS.readFile "cabal-benchmarks/cabal-benchmarks.cabal") $ \bs -> + bench "cabal-benchmarks" $ whnf parseGenericPackageDescriptionMaybe bs + ] + + , bgroup "normaliseVersionRange" $ + let suite name f = bgroup name + [ env bigVersionRange1 $ \vr -> bench "dnf1" $ nf f vr + , env bigVersionRange2 $ \vr -> bench "dnf2" $ nf f vr + , env bigVersionRange3 $ \vr -> bench "cnf1" $ nf f vr + , env bigVersionRange4 $ \vr -> bench "cnf2" $ nf f vr + , env bigVersionRange5 $ \vr -> bench "mix1" $ nf f vr + , env bigVersionRange6 $ \vr -> bench "mix2" $ nf f vr + , env bigVersionRange7 $ \vr -> bench "pat1" $ nf f vr + , env bigVersionRange8 $ \vr -> bench "pat2" $ nf f vr + , env bigVersionRange9 $ \vr -> bench "pat3" $ nf f vr + , env bigVersionRangeA $ \vr -> bench "pat4" $ nf f vr + ] + in [ suite "def" normaliseVersionRange + , suite "old" oldNormaliseVersionRange + , suite "new" newNormaliseVersionRange + ] ] + +------------------------------------------------------------------------------- +-- VersionRanges normalisation +------------------------------------------------------------------------------- + +oldNormaliseVersionRange :: VersionRange -> VersionRange +oldNormaliseVersionRange = Old.fromVersionIntervals . Old.toVersionIntervals + +newNormaliseVersionRange :: VersionRange -> VersionRange +newNormaliseVersionRange = New.normaliseVersionRange2 + +bigVersionRange1 :: IO VersionRange +bigVersionRange1 = either fail return $ eitherParsec + "(>=1.2.0 && <1.3) || (>=1.3.0 && <1.4) || (>=1.4.0.0 && <1.5) || (>=1.5.0.0 && <1.6) || (>=1.7.0.0 && <1.8)" + +bigVersionRange2 :: IO VersionRange +bigVersionRange2 = either fail return $ eitherParsec + "(>=1.2.0 && <1.3) || (>=1.4.0.0 && <1.5) || (>=1.3.0 && <1.4) || (>=1.5.0.0 && <1.6) || (>=1.7.0.0 && <1.8)" + +bigVersionRange3 :: IO VersionRange +bigVersionRange3 = either fail return $ eitherParsec + ">=1.2.0 && (<1.3 || >=1.3.0) && (<1.4 || >=1.4.0.0) && (<1.5 || >=1.5.0.0) && (<1.6 || >=1.7.0.0) && <1.8" + +bigVersionRange4 :: IO VersionRange +bigVersionRange4 = either fail return $ eitherParsec + ">=1.2.0 && <1.8 && (<1.4 || >=1.4.0.0) && (<1.3 || >=1.3.0) && (<1.5 || >=1.5.0.0) || (<1.6 && >=1.7.0.0)" + +bigVersionRange5 :: IO VersionRange +bigVersionRange5 = either fail return $ eitherParsec + ">=1.2.0 && (<1.3 || >=1.3.0) && (<1.4 || (>=1.4.0.0 && <1.5) || >=1.5.0.0) && (<1.6 || (>=1.7.0.0 && (<1.8 || >=1.9) && <1.10) || >=1.11) && <1.12" + +bigVersionRange6 :: IO VersionRange +bigVersionRange6 = fmap New.normaliseVersionRange2 bigVersionRange5 + +bigVersionRange7 :: IO VersionRange +bigVersionRange7 = return $ + i2 $ i2 $ u (b 0 1) (b 0 1) + where + i2 x = i x x + i = intersectVersionRanges + u = unionVersionRanges + b x y = intersectVersionRanges (laterVersion (v x)) (earlierVersion (v y)) + v x = mkVersion [x] + +bigVersionRange8 :: IO VersionRange +bigVersionRange8 = return $ + i2 $ i2 $ i2 $ u (b 0 1) (b 0 1) + where + i2 x = i x x + i = intersectVersionRanges + u = unionVersionRanges + b x y = intersectVersionRanges (laterVersion (v x)) (earlierVersion (v y)) + v x = mkVersion [x] + +bigVersionRange9 :: IO VersionRange +bigVersionRange9 = return $ + i2 $ i2 $ i2 $ i2 $ u (b 0 1) (b 0 1) + where + i2 x = i x x + i = intersectVersionRanges + u = unionVersionRanges + b x y = intersectVersionRanges (laterVersion (v x)) (earlierVersion (v y)) + v x = mkVersion [x] + +bigVersionRangeA :: IO VersionRange +bigVersionRangeA = return $ + i2 $ i2 $ i2 $ i2 $ i2 $ u (b 0 1) (b 0 1) + where + i2 x = i x x + i = intersectVersionRanges + u = unionVersionRanges + b x y = intersectVersionRanges (laterVersion (v x)) (earlierVersion (v y)) + v x = mkVersion [x] diff --git a/cabal/cabal-benchmarks/cabal-benchmarks.cabal b/cabal/cabal-benchmarks/cabal-benchmarks.cabal --- a/cabal/cabal-benchmarks/cabal-benchmarks.cabal +++ b/cabal/cabal-benchmarks/cabal-benchmarks.cabal @@ -1,7 +1,8 @@ +cabal-version: 2.2 name: cabal-benchmarks version: 3 -copyright: 2003-2020, Cabal Development Team (see AUTHORS file) -license: BSD3 +copyright: 2003-2022, Cabal Development Team (see AUTHORS file) +license: BSD-3-Clause license-file: LICENSE author: Cabal Development Team maintainer: cabal-devel@haskell.org @@ -12,14 +13,13 @@ This package contains benchmarks that test cabal's dependency solver by running the cabal executable. category: Distribution -cabal-version: >=1.10 build-type: Simple extra-source-files: README.md source-repository head type: git location: https://github.com/haskell/cabal/ - subdir: solver-benchmarks + subdir: cabal-benchmarks test-suite cabal-benchmarks default-language: Haskell2010 @@ -30,5 +30,5 @@ build-depends: base , bytestring - , Cabal + , Cabal-syntax , criterion >=1.5.6.2 && <1.6 diff --git a/cabal/cabal-dev-scripts/LICENSE b/cabal/cabal-dev-scripts/LICENSE --- a/cabal/cabal-dev-scripts/LICENSE +++ b/cabal/cabal-dev-scripts/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2003-2020, Cabal Development Team. +Copyright (c) 2003-2022, Cabal Development Team. See the AUTHORS file for the full list of copyright holders. See */LICENSE for the copyright holders of the subcomponents. diff --git a/cabal/cabal-dev-scripts/cabal-dev-scripts.cabal b/cabal/cabal-dev-scripts/cabal-dev-scripts.cabal --- a/cabal/cabal-dev-scripts/cabal-dev-scripts.cabal +++ b/cabal/cabal-dev-scripts/cabal-dev-scripts.cabal @@ -10,18 +10,6 @@ category: Distribution build-type: Simple -executable gen-extra-source-files - default-language: Haskell2010 - main-is: GenExtraSourceFiles.hs - hs-source-dirs: src - build-depends: - , base >=4.10 && <4.15 - , bytestring - , Cabal >=2.2 && <3.3 - , directory - , filepath - , process - executable gen-spdx default-language: Haskell2010 main-is: GenSPDX.hs @@ -29,13 +17,13 @@ hs-source-dirs: src ghc-options: -Wall build-depends: - , aeson ^>=1.4.1.0 || ^>=1.5.2.0 - , base >=4.10 && <4.15 + , aeson ^>=1.4.1.0 || ^>=1.5.2.0 || ^>=2.1.1.0 + , base >=4.10 && <4.17 , bytestring , containers , Diff ^>=0.4 - , lens ^>=4.18.1 || ^>=4.19.1 - , optparse-applicative ^>=0.15.1.0 + , lens ^>=4.18.1 || ^>=4.19.1 || ^>=5.0.1 || ^>=5.2 + , optparse-applicative ^>=0.15.1.0 || ^>=0.16.0.0 , text , zinza ^>=0.2 @@ -46,42 +34,45 @@ hs-source-dirs: src ghc-options: -Wall build-depends: - , aeson ^>=1.4.1.0 || ^>=1.5.2.0 - , base >=4.10 && <4.15 + , aeson ^>=1.4.1.0 || ^>=1.5.2.0 || ^>=2.1.1.0 + , base >=4.10 && <4.17 , bytestring , containers , Diff ^>=0.4 - , lens ^>=4.18.1 || ^>=4.19.1 - , optparse-applicative ^>=0.15.1.0 + , lens ^>=4.18.1 || ^>=4.19.1 || ^>=5.0.1 || ^>=5.2 + , optparse-applicative ^>=0.15.1.0 || ^>=0.16.0.0 , text , zinza ^>=0.2 -executable gen-validate +executable gen-validate-dockerfile default-language: Haskell2010 - main-is: GenValidate.hs + main-is: GenValidateDockerfile.hs hs-source-dirs: src ghc-options: -Wall build-depends: , base , bytestring + , containers , HsYAML ^>=0.2.1.0 , zinza ^>=0.2 -executable gen-validate-dockerfile +executable gen-cabal-macros default-language: Haskell2010 - main-is: GenValidateDockerfile.hs + main-is: GenCabalMacros.hs + other-modules: Capture hs-source-dirs: src ghc-options: -Wall build-depends: , base , bytestring - , containers - , HsYAML ^>=0.2.1.0 - , zinza ^>=0.2 + , Cabal + , syb ^>=0.7.1 + , template-haskell + , zinza ^>=0.2 -executable gen-cabal-macros +executable gen-paths-module default-language: Haskell2010 - main-is: GenCabalMacros.hs + main-is: GenPathsModule.hs other-modules: Capture hs-source-dirs: src ghc-options: -Wall diff --git a/cabal/cabal-dev-scripts/src/GenExtraSourceFiles.hs b/cabal/cabal-dev-scripts/src/GenExtraSourceFiles.hs deleted file mode 100644 --- a/cabal/cabal-dev-scripts/src/GenExtraSourceFiles.hs +++ /dev/null @@ -1,121 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -import qualified Distribution.ModuleName as ModuleName -import Distribution.PackageDescription -import Distribution.PackageDescription.Parsec - (parseGenericPackageDescription, runParseResult) -import Distribution.Verbosity (silent) - -import Control.Monad (liftM, filterM) -import Data.List (isPrefixOf, isSuffixOf, sort) -import System.Directory (canonicalizePath, doesFileExist, setCurrentDirectory) -import System.Environment (getArgs, getProgName) -import System.FilePath ((), takeDirectory, takeExtension, takeFileName) -import System.Process (readProcess) - - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BS8 -import qualified System.IO as IO - -main' :: FilePath -> FilePath -> IO () -main' templateFp fp' = do - fp <- canonicalizePath fp' - setCurrentDirectory (takeDirectory fp) - print $ takeDirectory fp - - -- Read cabal file, so we can determine test modules - contents <- BS.readFile fp - cabal <- - case snd . runParseResult . parseGenericPackageDescription $ contents of - Right x -> pure x - Left (_mver, errs) -> fail (show errs) - - -- We skip some files - testModuleFiles <- getOtherModulesFiles cabal - let skipPredicates' = skipPredicates ++ map (==) testModuleFiles - print testModuleFiles - - -- Read all files git knows about under "tests" - files0 <- lines <$> readProcess "git" ["ls-files", "tests"] "" - - -- Filter - let files1 = filter (\f -> takeExtension f `elem` whitelistedExtensionss || - takeFileName f `elem` whitelistedFiles) - files0 - let files2 = filter (\f -> not $ any ($ f) skipPredicates') files1 - let files3 = sort files2 - let files = files3 - - -- Read current file - templateContents <- BS.readFile templateFp - let topLine' = BS8.pack topLine - bottomLine' = BS8.pack bottomLine - inputLines = BS8.lines templateContents - linesBefore = takeWhile (/= topLine') inputLines - linesAfter = dropWhile (/= bottomLine') inputLines - - -- Output - let outputLines = linesBefore ++ [topLine'] - ++ map ((<>) " " . BS8.pack) files ++ linesAfter - BS.writeFile templateFp (BS8.unlines outputLines) - - -topLine, bottomLine :: String -topLine = " -- BEGIN gen-extra-source-files" -bottomLine = " -- END gen-extra-source-files" - -whitelistedFiles :: [FilePath] -whitelistedFiles = [ "ghc", "ghc-pkg", "ghc-7.10" - , "ghc-pkg-7.10", "ghc-pkg-ghc-7.10" ] - -whitelistedExtensionss :: [String] -whitelistedExtensionss = map ('.' : ) - [ "hs", "lhs", "c", "h", "sh", "cabal", "hsc" - , "err", "out", "in", "project", "format", "errors", "expr" - , "check" - ] - -getOtherModulesFiles :: GenericPackageDescription -> IO [FilePath] -getOtherModulesFiles gpd = do - mainModules <- liftM concat . mapM findMainModules $ testSuites - otherModules' <- liftM concat . mapM findOtherModules $ testSuites - - return $ mainModules ++ otherModules' - where - testSuites :: [TestSuite] - testSuites = map (foldMap id . snd) (condTestSuites gpd) - - findMainModules, findOtherModules :: TestSuite -> IO [FilePath] - findMainModules ts = findModules (mainModule . testInterface $ ts) ts - findOtherModules ts = - findModules (map fromModuleName . otherModules . testBuildInfo $ ts) ts - - findModules :: [FilePath] -> TestSuite -> IO [FilePath] - findModules filenames ts = filterM doesFileExist - [ d f | d <- locations, f <- filenames ] - where locations = hsSourceDirs . testBuildInfo $ ts - - fromModuleName mn = ModuleName.toFilePath mn ++ ".hs" - - mainModule (TestSuiteLibV09 _ mn) = [fromModuleName mn] - mainModule (TestSuiteExeV10 _ fp) = [fp] - mainModule _ = [] - -skipPredicates :: [FilePath -> Bool] -skipPredicates = - [ isSuffixOf "register.sh" - ] - -main :: IO () -main = do - args <- getArgs - case args of - [fp] -> main' fp fp - [fp,fp'] -> main' fp fp' - _ -> do - progName <- getProgName - putStrLn "Error too few arguments!" - putStrLn $ "Usage: " ++ progName ++ " " - putStrLn $ " where FILE is Cabal.cabal, cabal-testsuite.cabal, " - ++ "or cabal-install.cabal" diff --git a/cabal/cabal-dev-scripts/src/GenPathsModule.hs b/cabal/cabal-dev-scripts/src/GenPathsModule.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-dev-scripts/src/GenPathsModule.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-orphans #-} +module Main (main) where + +import Control.Exception (SomeException (..), catch, displayException) +import Distribution.Types.PackageName (PackageName) +import Distribution.Types.Version (Version) +import GHC.Generics (Generic) +import System.Environment (getArgs) +import System.Exit (exitFailure) +import Zinza + (ModuleConfig (..), Ty (..), Zinza (..), genericFromValueSFP, genericToTypeSFP, + genericToValueSFP, parseAndCompileModuleIO) + +import Capture + +------------------------------------------------------------------------------- +-- Inputs +------------------------------------------------------------------------------- + +$(capture "decls" [d| + data Z = Z + { zPackageName :: PackageName + , zVersionDigits :: String + , zSupportsCpp :: Bool + , zSupportsNoRebindableSyntax :: Bool + , zAbsolute :: Bool + , zRelocatable :: Bool + , zIsWindows :: Bool + , zIsI386 :: Bool + , zIsX8664 :: Bool + + , zPrefix :: FilePath + , zBindir :: FilePath + , zLibdir :: FilePath + , zDynlibdir :: FilePath + , zDatadir :: FilePath + , zLibexecdir :: FilePath + , zSysconfdir :: FilePath + + , zNot :: Bool -> Bool + , zManglePkgName :: PackageName -> String + } + deriving (Generic) + |]) + +------------------------------------------------------------------------------- +-- Main +------------------------------------------------------------------------------- + +withIO :: (FilePath -> FilePath -> IO a) -> IO a +withIO k = do + args <- getArgs + case args of + [src,tgt] -> k src tgt `catch` \(SomeException e) -> do + putStrLn $ "Exception: " ++ displayException e + exitFailure + _ -> do + putStrLn "Usage cabal v2-run ... source.temeplate.ext target.ext" + exitFailure + +main :: IO () +main = withIO $ \src tgt -> do + mdl <- parseAndCompileModuleIO config src + writeFile tgt mdl + +config :: ModuleConfig Z +config = ModuleConfig + { mcRender = "render" + , mcHeader = + [ "{-# LANGUAGE DeriveGeneric #-}" + , "module Distribution.Simple.Build.PathsModule.Z (render, Z(..)) where" + , "import Distribution.ZinzaPrelude" + , decls + , "render :: Z -> String" + ] + } + +------------------------------------------------------------------------------- +-- Zinza instances +------------------------------------------------------------------------------- + +instance Zinza Z where + toType = genericToTypeSFP + toValue = genericToValueSFP + fromValue = genericFromValueSFP + +------------------------------------------------------------------------------- +-- Orphans +------------------------------------------------------------------------------- + +instance Zinza PackageName where + toType _ = TyString (Just "prettyShow") + toValue _ = error "not needed" + fromValue _ = error "not needed" + +instance Zinza Version where + toType _ = TyString (Just "prettyShow") + toValue _ = error "not needed" + fromValue _ = error "not needed" diff --git a/cabal/cabal-dev-scripts/src/GenSPDX.hs b/cabal/cabal-dev-scripts/src/GenSPDX.hs --- a/cabal/cabal-dev-scripts/src/GenSPDX.hs +++ b/cabal/cabal-dev-scripts/src/GenSPDX.hs @@ -33,7 +33,9 @@ <$> licenses "3.0" <*> licenses "3.2" <*> licenses "3.6" - <*> licenses "3.8" + <*> licenses "3.9" + <*> licenses "3.10" + <*> licenses "3.16" template = O.strArgument $ mconcat [ O.metavar "SPDX.LicenseId.template.hs" @@ -63,29 +65,17 @@ -> (Input -> IO String) -> IO String generate' lss template = template $ Input - { inputLicenseIds = licenseIds - , inputLicenses = licenseValues - , inputLicenseList_all = mkLicenseList (== allVers) - , inputLicenseList_3_0 = mkLicenseList - (\vers -> vers /= allVers && Set.member SPDXLicenseListVersion_3_0 vers) - , inputLicenseList_3_2 = mkLicenseList - (\vers -> vers /= allVers && Set.member SPDXLicenseListVersion_3_2 vers) - , inputLicenseList_3_6 = mkLicenseList - (\vers -> vers /= allVers && Set.member SPDXLicenseListVersion_3_6 vers) - , inputLicenseList_3_9 = mkLicenseList - (\vers -> vers /= allVers && Set.member SPDXLicenseListVersion_3_9 vers) + { inputLicenseIds = licenseIds + , inputLicenses = licenseValues + , inputLicenseList_all = mkLicenseList (== allVers) + , inputLicenseList_perv = tabulate $ \ver -> mkLicenseList + (\vers -> vers /= allVers && Set.member ver vers) } where - PerV (LL ls_3_0) (LL ls_3_2) (LL ls_3_6) (LL ls_3_9) = lss - constructorNames :: [(Text, License, Set.Set SPDXLicenseListVersion)] constructorNames = map (\(l, tags) -> (toConstructorName $ licenseId l, l, tags)) - $ combine licenseId $ \ver -> case ver of - SPDXLicenseListVersion_3_9 -> filterDeprecated ls_3_9 - SPDXLicenseListVersion_3_6 -> filterDeprecated ls_3_6 - SPDXLicenseListVersion_3_2 -> filterDeprecated ls_3_2 - SPDXLicenseListVersion_3_0 -> filterDeprecated ls_3_0 + $ combine licenseId $ \ver -> filterDeprecated $ unLL $ index ver lss filterDeprecated = filter (not . licenseDeprecated) @@ -122,7 +112,7 @@ } deriving (Show) -newtype LicenseList = LL [License] +newtype LicenseList = LL { unLL :: [License] } deriving (Show) instance FromJSON License where diff --git a/cabal/cabal-dev-scripts/src/GenSPDXExc.hs b/cabal/cabal-dev-scripts/src/GenSPDXExc.hs --- a/cabal/cabal-dev-scripts/src/GenSPDXExc.hs +++ b/cabal/cabal-dev-scripts/src/GenSPDXExc.hs @@ -32,7 +32,9 @@ <$> licenses "3.0" <*> licenses "3.2" <*> licenses "3.6" - <*> licenses "3.8" + <*> licenses "3.9" + <*> licenses "3.10" + <*> licenses "3.16" template = O.strArgument $ mconcat [ O.metavar "SPDX.LicenseExceptionId.template.hs" @@ -62,29 +64,17 @@ -> (Input -> IO String) -> IO String generate' lss template = template $ Input - { inputLicenseIds = licenseIds - , inputLicenses = licenseValues - , inputLicenseList_all = mkLicenseList (== allVers) - , inputLicenseList_3_0 = mkLicenseList - (\vers -> vers /= allVers && Set.member SPDXLicenseListVersion_3_0 vers) - , inputLicenseList_3_2 = mkLicenseList - (\vers -> vers /= allVers && Set.member SPDXLicenseListVersion_3_2 vers) - , inputLicenseList_3_6 = mkLicenseList - (\vers -> vers /= allVers && Set.member SPDXLicenseListVersion_3_6 vers) - , inputLicenseList_3_9 = mkLicenseList - (\vers -> vers /= allVers && Set.member SPDXLicenseListVersion_3_9 vers) + { inputLicenseIds = licenseIds + , inputLicenses = licenseValues + , inputLicenseList_all = mkLicenseList (== allVers) + , inputLicenseList_perv = tabulate $ \ver -> mkLicenseList + (\vers -> vers /= allVers && Set.member ver vers) } where - PerV (LL ls_3_0) (LL ls_3_2) (LL ls_3_6) (LL ls_3_9) = lss - constructorNames :: [(Text, License, Set.Set SPDXLicenseListVersion)] constructorNames = map (\(l, tags) -> (toConstructorName $ licenseId l, l, tags)) - $ combine licenseId $ \ver -> case ver of - SPDXLicenseListVersion_3_9 -> filterDeprecated ls_3_9 - SPDXLicenseListVersion_3_6 -> filterDeprecated ls_3_6 - SPDXLicenseListVersion_3_2 -> filterDeprecated ls_3_2 - SPDXLicenseListVersion_3_0 -> filterDeprecated ls_3_0 + $ combine licenseId $ \ver -> filterDeprecated $ unLL $ index ver lss filterDeprecated = filter (not . licenseDeprecated) @@ -128,7 +118,7 @@ fixSpace '\n' = ' ' fixSpace c = c -newtype LicenseList = LL [License] +newtype LicenseList = LL { unLL :: [License] } deriving (Show) instance FromJSON LicenseList where diff --git a/cabal/cabal-dev-scripts/src/GenUtils.hs b/cabal/cabal-dev-scripts/src/GenUtils.hs --- a/cabal/cabal-dev-scripts/src/GenUtils.hs +++ b/cabal/cabal-dev-scripts/src/GenUtils.hs @@ -1,22 +1,24 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} 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) +import GHC.Generics (Generic) -import qualified Zinza as Z import qualified Data.Algorithm.Diff as Diff import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Text as T +import qualified Zinza as Z ------------------------------------------------------------------------------- -- License List version @@ -28,24 +30,56 @@ | SPDXLicenseListVersion_3_2 | SPDXLicenseListVersion_3_6 | SPDXLicenseListVersion_3_9 + | SPDXLicenseListVersion_3_10 + | SPDXLicenseListVersion_3_16 deriving (Eq, Ord, Show, Enum, Bounded) allVers :: Set.Set SPDXLicenseListVersion allVers = Set.fromList [minBound .. maxBound] prettyVer :: SPDXLicenseListVersion -> Text -prettyVer SPDXLicenseListVersion_3_9 = "SPDX License List 3.9" -prettyVer SPDXLicenseListVersion_3_6 = "SPDX License List 3.6" -prettyVer SPDXLicenseListVersion_3_2 = "SPDX License List 3.2" -prettyVer SPDXLicenseListVersion_3_0 = "SPDX License List 3.0" +prettyVer SPDXLicenseListVersion_3_16 = "SPDX License List 3.16" +prettyVer SPDXLicenseListVersion_3_10 = "SPDX License List 3.10" +prettyVer SPDXLicenseListVersion_3_9 = "SPDX License List 3.9" +prettyVer SPDXLicenseListVersion_3_6 = "SPDX License List 3.6" +prettyVer SPDXLicenseListVersion_3_2 = "SPDX License List 3.2" +prettyVer SPDXLicenseListVersion_3_0 = "SPDX License List 3.0" +suffixVer :: SPDXLicenseListVersion -> String +suffixVer SPDXLicenseListVersion_3_16 = "_3_16" +suffixVer SPDXLicenseListVersion_3_10 = "_3_10" +suffixVer SPDXLicenseListVersion_3_9 = "_3_9" +suffixVer SPDXLicenseListVersion_3_6 = "_3_6" +suffixVer SPDXLicenseListVersion_3_2 = "_3_2" +suffixVer SPDXLicenseListVersion_3_0 = "_3_0" + ------------------------------------------------------------------------------- -- Per version ------------------------------------------------------------------------------- -data PerV a = PerV a a a a - deriving (Functor, Foldable, Traversable) +data PerV a = PerV a a a a a a + deriving (Show, Functor, Foldable, Traversable) +class Functor f => Representable i f | f -> i where + index :: i -> f a -> a + tabulate :: (i -> a) -> f a + +instance Representable SPDXLicenseListVersion PerV where + index SPDXLicenseListVersion_3_0 (PerV x _ _ _ _ _) = x + index SPDXLicenseListVersion_3_2 (PerV _ x _ _ _ _) = x + index SPDXLicenseListVersion_3_6 (PerV _ _ x _ _ _) = x + index SPDXLicenseListVersion_3_9 (PerV _ _ _ x _ _) = x + index SPDXLicenseListVersion_3_10 (PerV _ _ _ _ x _) = x + index SPDXLicenseListVersion_3_16 (PerV _ _ _ _ _ x) = x + + tabulate f = PerV + (f SPDXLicenseListVersion_3_0) + (f SPDXLicenseListVersion_3_2) + (f SPDXLicenseListVersion_3_6) + (f SPDXLicenseListVersion_3_9) + (f SPDXLicenseListVersion_3_10) + (f SPDXLicenseListVersion_3_16) + ------------------------------------------------------------------------------- -- Sorting ------------------------------------------------------------------------------- @@ -60,7 +94,7 @@ | otherwise = compare a b ------------------------------------------------------------------------------- --- Commmons +-- Commons ------------------------------------------------------------------------------- header :: String @@ -137,13 +171,10 @@ ------------------------------------------------------------------------------- data Input = Input - { inputLicenseIds :: Text - , inputLicenses :: [InputLicense] - , inputLicenseList_all :: Text - , inputLicenseList_3_0 :: Text - , inputLicenseList_3_2 :: Text - , inputLicenseList_3_6 :: Text - , inputLicenseList_3_9 :: Text + { inputLicenseIds :: Text + , inputLicenses :: [InputLicense] + , inputLicenseList_all :: Text + , inputLicenseList_perv :: PerV Text } deriving (Show, Generic) @@ -165,3 +196,16 @@ toType = Z.genericToTypeSFP toValue = Z.genericToValueSFP fromValue = Z.genericFromValueSFP + +instance Z.Zinza a => Z.Zinza (PerV a) where + toType _ = Z.TyRecord $ Map.fromList + [ ("v" ++ suffixVer v, ("index " ++ show v, Z.toType (Proxy :: Proxy a))) + | v <- [ minBound .. maxBound ] + ] + + toValue x = Z.VRecord $ Map.fromList + [ ("v" ++ suffixVer v, Z.toValue (index v x)) + | v <- [ minBound .. maxBound ] + ] + + fromValue = error "fromExpr @PerV not implemented" diff --git a/cabal/cabal-dev-scripts/src/GenValidate.hs b/cabal/cabal-dev-scripts/src/GenValidate.hs deleted file mode 100644 --- a/cabal/cabal-dev-scripts/src/GenValidate.hs +++ /dev/null @@ -1,157 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE ScopedTypeVariables #-} --- runghc -package-env=default Validate.hs validate.yml.zinza .github/workflows/validate.yml -module Main (main) where - -import Data.List (isPrefixOf) -import GHC.Generics (Generic) -import System.Environment (getArgs) -import System.Exit (exitFailure) -import Zinza (Zinza (..), genericFromValueSFP, genericToTypeSFP, genericToValueSFP, parseAndCompileTemplateIO) - -import qualified Data.ByteString.Lazy.Char8 as LBS8 -import qualified Data.YAML as YAML - -main :: IO () -main = do - args <- getArgs - case args of - [src,tgt] -> do - run <- parseAndCompileTemplateIO src - -- this shouldn't fail (run-time errors are due bugs in zinza) - w <- run Z - { zJobs = - [ GhcJob "8.10.1" False "" False ["8.8.3"] defSteps - , GhcJob "8.8.3" False "--solver-benchmarks" False [] defSteps - , GhcJob "8.6.5" False "--complete-hackage-tests" False ["8.8.3"] defSteps - , GhcJob "8.4.4" False "" False ["8.8.3"] defSteps - , GhcJob "8.2.2" False "" False ["8.8.3"] defSteps - , GhcJob "8.0.2" False "" False ["8.8.3"] defSteps - , GhcJob "7.10.3" False "" False ["8.8.3"] defSteps - , GhcJob "7.8.4" False "--lib-only" False ["8.8.3"] libSteps - , GhcJob "7.6.3" True "--lib-only" False ["8.8.3"] libSteps - , GhcJob "8.8.3" True "--lib-only" True ["8.8.3"] $ - libSteps ++ - [ "lib-suite-extras --extra-hc /opt/ghc/7.0.4/bin/ghc-7.0.4" - , "lib-suite-extras --extra-hc /opt/ghc/7.2.2/bin/ghc-7.2.2" - , "lib-suite-extras --extra-hc /opt/ghc/7.4.2/bin/ghc-7.4.2" - ] - ] - , zMacosJobs = - [ mkMacGhcJob "8.8.3" "https://downloads.haskell.org/~ghc/8.8.3/ghc-8.8.3-x86_64-apple-darwin.tar.xz" - , mkMacGhcJob "8.6.5" "https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-apple-darwin.tar.xz" - ] - , zWinJobs = - -- 8.8.1 fails atm, - -- Shutting down GHCi sessions (please be patient)... - -- Unexpected failure on GHCi exit: fd:10: hClose: resource vanished (Broken pipe) - -- cabal-tests: fd:10: hClose: resource vanished (Broken pipe) - -- [ WinGhcJob "8.8.1" ["8.6.5"] - [ WinGhcJob "8.6.5" [] - ] - , zMangleVersion = map mangleChar - , zOr = (||) - , zNotNull = not . null - , zFalse = False - } - - -- check that YAML is syntactically valid - let bs = LBS8.pack w - case YAML.decode1 bs of - Right (_ :: YAML.Node YAML.Pos) -> return () - Left (pos, err) -> do - putStrLn $ "ERROR:" ++ YAML.prettyPosWithSource pos bs err - exitFailure - - writeFile tgt w - _ -> putStrLn "Usage source.yml.zinza target.yml" - -mangleChar :: Char -> Char -mangleChar '.' = '_' -mangleChar c = c - -defSteps :: [String] -defSteps = - [ "print-config" - , "print-tool-versions" - , "make-cabal-install-dev" - , "build" - , "lib-tests" - , "lib-suite" - , "cli-tests" - , "cli-suite" - ] - -libSteps :: [String] -libSteps = - [ "print-config" - , "print-tool-versions" - , "build" - , "lib-tests" - , "lib-suite" - ] - -data Z = Z - { zJobs :: [GhcJob] - , zMacosJobs :: [MacGhcJob] - , zWinJobs :: [WinGhcJob] - , zMangleVersion :: String -> String - , zOr :: Bool -> Bool -> Bool - , zNotNull :: [String] -> Bool - , zFalse :: Bool - } - deriving (Generic) - -data GhcJob = GhcJob - { gjVersion :: String - , gjXenial :: Bool - , gjFlags :: String - , gjOld :: Bool - , gjNeeds :: [String] - , gjSteps :: [String] - } - deriving (Generic) - -data MacGhcJob = MacGhcJob - { mgjVersion :: String - , mgjGhcUrl :: String - , mgjFlags :: String - , mgjNeeds :: [String] - , mgjSteps :: [String] - } - deriving (Generic) - -data WinGhcJob = WinGhcJob - { wgjVersion :: String - , wgjNeeds :: [String] - } - deriving (Generic) - -mkMacGhcJob :: String -> String -> MacGhcJob -mkMacGhcJob v u = MacGhcJob - { mgjVersion = v - , mgjGhcUrl = u - , mgjFlags = "" - , mgjNeeds = ["8.8.3" | not $ "8.8" `isPrefixOf` v ] - , mgjSteps = defSteps - } - -instance Zinza Z where - toType = genericToTypeSFP - toValue = genericToValueSFP - fromValue = genericFromValueSFP - -instance Zinza GhcJob where - toType = genericToTypeSFP - toValue = genericToValueSFP - fromValue = genericFromValueSFP - -instance Zinza MacGhcJob where - toType = genericToTypeSFP - toValue = genericToValueSFP - fromValue = genericFromValueSFP - -instance Zinza WinGhcJob where - toType = genericToTypeSFP - toValue = genericToValueSFP - fromValue = genericFromValueSFP diff --git a/cabal/cabal-dev-scripts/src/GenValidateDockerfile.hs b/cabal/cabal-dev-scripts/src/GenValidateDockerfile.hs --- a/cabal/cabal-dev-scripts/src/GenValidateDockerfile.hs +++ b/cabal/cabal-dev-scripts/src/GenValidateDockerfile.hs @@ -40,15 +40,11 @@ params :: Map.Map String Z params = Map.fromList - [ pair "8.10.1" $ Z "ghc-8.10.1" "8.10.1-bionic" False True False True "" - , pair "8.8.3" $ Z "ghc-8.8.3" "8.8.3-bionic" False True False True "--doctest --solver-benchmarks --complete-hackage" + [ pair "8.10.4" $ Z "ghc-8.10.4" "8.10.4-bionic" False True False True "" + , pair "8.8.4" $ Z "ghc-8.8.4" "8.8.4-bionic" False True False True "--doctest --solver-benchmarks --complete-hackage" , pair "8.6.5" $ Z "ghc-8.6.5" "8.6.5-bionic" False True False True "" , pair "8.4.4" $ Z "ghc-8.4.4" "8.4.4-bionic" False True False True "" , pair "8.2.2" $ Z "ghc-8.2.2" "8.2.2-bionic" True True False True "" - , pair "8.0.2" $ Z "ghc-8.0.2" "8.0.2-bionic" True True False True "" - , pair "7.10.3" $ Z "ghc-7.10.3" "7.10.3-bionic" True True False True "" - , pair "7.8.4" $ Z "ghc-7.8.4" "7.8.4-xenial" True True True False "--lib-only" - , pair "7.6.3" $ Z "ghc-7.6.3" "7.6.3-xenial" True False True False "--lib-only" ] where pair = (,) diff --git a/cabal/cabal-install-solver/ChangeLog.md b/cabal/cabal-install-solver/ChangeLog.md new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/ChangeLog.md @@ -0,0 +1,1 @@ +Please see https://hackage.haskell.org/package/cabal-install/changelog diff --git a/cabal/cabal-install-solver/LICENSE b/cabal/cabal-install-solver/LICENSE new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/LICENSE @@ -0,0 +1,34 @@ +Copyright (c) 2003-2022, Cabal Development Team. +See the AUTHORS file for the full list of copyright holders. + +See */LICENSE for the copyright holders of the subcomponents. + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/cabal/cabal-install-solver/Setup.hs b/cabal/cabal-install-solver/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main :: IO () +main = defaultMain diff --git a/cabal/cabal-install-solver/cabal-install-solver.cabal b/cabal/cabal-install-solver/cabal-install-solver.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/cabal-install-solver.cabal @@ -0,0 +1,147 @@ +cabal-version: 2.2 +name: cabal-install-solver +version: 3.8.1.0 +synopsis: The command-line interface for Cabal and Hackage. +description: + The solver component used in cabal-install command-line program + +homepage: http://www.haskell.org/cabal/ +bug-reports: https://github.com/haskell/cabal/issues +license: BSD-3-Clause +license-file: LICENSE +author: Cabal Development Team (see AUTHORS file) +maintainer: Cabal Development Team +copyright: 2003-2022, Cabal Development Team +category: Distribution +build-type: Simple +Extra-Source-Files: + ChangeLog.md + +source-repository head + type: git + location: https://github.com/haskell/cabal/ + subdir: cabal-install-solver + +flag debug-expensive-assertions + description: Enable expensive assertions for testing or debugging + default: False + manual: True + +flag debug-conflict-sets + description: Add additional information to ConflictSets + default: False + manual: True + +flag debug-tracetree + description: Compile in support for tracetree (used to debug the solver) + default: False + manual: True + +library + default-language: Haskell2010 + hs-source-dirs: src + hs-source-dirs: src-assertion + ghc-options: + -Wall -Wcompat -Wnoncanonical-monad-instances + -fwarn-tabs -fwarn-incomplete-uni-patterns + + if impl(ghc <8.8) + ghc-options: -Wnoncanonical-monadfail-instances + if impl(ghc >=8.10) + ghc-options: -Wunused-packages + + exposed-modules: + Distribution.Client.Utils.Assertion + + Distribution.Solver.Compat.Prelude + Distribution.Solver.Modular + Distribution.Solver.Modular.Assignment + Distribution.Solver.Modular.Builder + Distribution.Solver.Modular.Configured + Distribution.Solver.Modular.ConfiguredConversion + Distribution.Solver.Modular.ConflictSet + Distribution.Solver.Modular.Cycles + Distribution.Solver.Modular.Dependency + Distribution.Solver.Modular.Explore + Distribution.Solver.Modular.Flag + Distribution.Solver.Modular.Index + Distribution.Solver.Modular.IndexConversion + Distribution.Solver.Modular.LabeledGraph + Distribution.Solver.Modular.Linking + Distribution.Solver.Modular.Log + Distribution.Solver.Modular.Message + Distribution.Solver.Modular.MessageUtils + Distribution.Solver.Modular.Package + Distribution.Solver.Modular.Preference + Distribution.Solver.Modular.PSQ + Distribution.Solver.Modular.RetryLog + Distribution.Solver.Modular.Solver + Distribution.Solver.Modular.Tree + Distribution.Solver.Modular.Validate + Distribution.Solver.Modular.Var + Distribution.Solver.Modular.Version + Distribution.Solver.Modular.WeightedPSQ + Distribution.Solver.Types.ComponentDeps + Distribution.Solver.Types.ConstraintSource + Distribution.Solver.Types.DependencyResolver + Distribution.Solver.Types.Flag + Distribution.Solver.Types.InstalledPreference + Distribution.Solver.Types.InstSolverPackage + Distribution.Solver.Types.LabeledPackageConstraint + Distribution.Solver.Types.OptionalStanza + Distribution.Solver.Types.PackageConstraint + Distribution.Solver.Types.PackageFixedDeps + Distribution.Solver.Types.PackageIndex + Distribution.Solver.Types.PackagePath + Distribution.Solver.Types.PackagePreferences + Distribution.Solver.Types.PkgConfigDb + Distribution.Solver.Types.Progress + Distribution.Solver.Types.ResolverPackage + Distribution.Solver.Types.Settings + Distribution.Solver.Types.SolverId + Distribution.Solver.Types.SolverPackage + Distribution.Solver.Types.SourcePackage + Distribution.Solver.Types.Variable + + build-depends: + , array >=0.4 && <0.6 + , base >=4.10 && <4.17 + , bytestring >=0.10.6.0 && <0.12 + , Cabal ^>=3.8 + , Cabal-syntax ^>=3.8 + , containers >=0.5.6.2 && <0.7 + , edit-distance ^>= 0.2.2 + , filepath ^>=1.4.0.0 + , mtl >=2.0 && <2.3 + , pretty ^>=1.1 + , transformers >=0.4.2.0 && <0.6 + + if flag(debug-expensive-assertions) + cpp-options: -DDEBUG_EXPENSIVE_ASSERTIONS + + if flag(debug-conflict-sets) + cpp-options: -DDEBUG_CONFLICT_SETS + build-depends: base >=4.8 + + if flag(debug-tracetree) + cpp-options: -DDEBUG_TRACETREE + build-depends: tracetree ^>=0.1 + +Test-Suite unit-tests + default-language: Haskell2010 + ghc-options: -rtsopts -threaded + + type: exitcode-stdio-1.0 + main-is: UnitTests.hs + hs-source-dirs: tests + other-modules: + UnitTests.Distribution.Solver.Modular.MessageUtils + + build-depends: + , base >= 4.10 && <4.17 + , Cabal + , Cabal-syntax + , cabal-install-solver + , tasty >= 1.2.3 && <1.5 + , tasty-quickcheck + , tasty-hunit >= 0.10 diff --git a/cabal/cabal-install-solver/src-assertion/Distribution/Client/Utils/Assertion.hs b/cabal/cabal-install-solver/src-assertion/Distribution/Client/Utils/Assertion.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/src-assertion/Distribution/Client/Utils/Assertion.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE CPP #-} +module Distribution.Client.Utils.Assertion (expensiveAssert) where + + +#ifdef DEBUG_EXPENSIVE_ASSERTIONS +import Prelude (Bool) +import Control.Exception (assert) +import Distribution.Compat.Stack +#else +import Prelude (Bool, id) +#endif + +-- | Like 'assert', but only enabled with -fdebug-expensive-assertions. This +-- function can be used for expensive assertions that should only be turned on +-- during testing or debugging. +#ifdef DEBUG_EXPENSIVE_ASSERTIONS +expensiveAssert :: WithCallStack (Bool -> a -> a) +expensiveAssert = assert +#else +expensiveAssert :: Bool -> a -> a +expensiveAssert _ = id +#endif diff --git a/cabal/cabal-install-solver/src/Distribution/Solver/Compat/Prelude.hs b/cabal/cabal-install-solver/src/Distribution/Solver/Compat/Prelude.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/src/Distribution/Solver/Compat/Prelude.hs @@ -0,0 +1,19 @@ +-- to suppress WARNING in "Distribution.Compat.Prelude.Internal" +{-# OPTIONS_GHC -fno-warn-deprecations #-} + +-- | This module does two things: +-- +-- * Acts as a compatibility layer, like @base-compat@. +-- +-- * Provides commonly used imports. +-- +-- This module is a superset of "Distribution.Compat.Prelude" (which +-- this module re-exports) +-- +module Distribution.Solver.Compat.Prelude + ( module Distribution.Compat.Prelude.Internal + , Prelude.IO + ) where + +import Prelude (IO) +import Distribution.Compat.Prelude.Internal hiding (IO) diff --git a/cabal/cabal-install-solver/src/Distribution/Solver/Modular.hs b/cabal/cabal-install-solver/src/Distribution/Solver/Modular.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/src/Distribution/Solver/Modular.hs @@ -0,0 +1,338 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Distribution.Solver.Modular + ( modularResolver, SolverConfig(..), PruneAfterFirstSuccess(..) ) where + +-- Here, we try to map between the external cabal-install solver +-- interface and the internal interface that the solver actually +-- expects. There are a number of type conversions to perform: we +-- have to convert the package indices to the uniform index used +-- by the solver; we also have to convert the initial constraints; +-- and finally, we have to convert back the resulting install +-- plan. + +import Prelude () +import Distribution.Solver.Compat.Prelude + +import qualified Data.Map as M +import Data.Set (isSubsetOf) +import Distribution.Compat.Graph + ( IsNode(..) ) +import Distribution.Compiler + ( CompilerInfo ) +import Distribution.Solver.Modular.Assignment + ( Assignment, toCPs ) +import Distribution.Solver.Modular.ConfiguredConversion + ( convCP ) +import qualified Distribution.Solver.Modular.ConflictSet as CS +import Distribution.Solver.Modular.Dependency +import Distribution.Solver.Modular.Flag +import Distribution.Solver.Modular.Index +import Distribution.Solver.Modular.IndexConversion + ( convPIs ) +import Distribution.Solver.Modular.Log + ( SolverFailure(..), displayLogMessages ) +import Distribution.Solver.Modular.Package + ( PN ) +import Distribution.Solver.Modular.RetryLog +import Distribution.Solver.Modular.Solver + ( SolverConfig(..), PruneAfterFirstSuccess(..), solve ) +import Distribution.Solver.Types.DependencyResolver +import Distribution.Solver.Types.LabeledPackageConstraint +import Distribution.Solver.Types.PackageConstraint +import Distribution.Solver.Types.PackagePath +import Distribution.Solver.Types.PackagePreferences +import Distribution.Solver.Types.PkgConfigDb + ( PkgConfigDb ) +import Distribution.Solver.Types.Progress +import Distribution.Solver.Types.Variable +import Distribution.System + ( Platform(..) ) +import Distribution.Simple.Setup + ( BooleanFlag(..) ) +import Distribution.Simple.Utils + ( ordNubBy ) +import Distribution.Verbosity + + +-- | 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 = + fmap (uncurry postprocess) $ -- convert install plan + solve' sc cinfo idx pkgConfigDB pprefs gcs pns + where + -- Indices have to be converted into solver-specific uniform index. + idx = convPIs os arch cinfo 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 + +-- | Run 'D.S.Modular.Solver.solve' and then produce a summarized log to display +-- in the error case. +-- +-- When there is no solution, we produce the error message by rerunning the +-- solver but making it prefer the goals from the final conflict set from the +-- first run (or a subset of the final conflict set with +-- --minimize-conflict-set). We also set the backjump limit to 0, so that the +-- log stops at the first backjump and is relatively short. Preferring goals +-- from the final conflict set increases the probability that the log to the +-- first backjump contains package, flag, and stanza choices that are relevant +-- to the final failure. The solver shouldn't need to choose any packages that +-- aren't in the final conflict set. (For every variable in the final conflict +-- set, the final conflict set should also contain the variable that introduced +-- that variable. The solver can then follow that chain of variables in reverse +-- order from the user target to the conflict.) However, it is possible that the +-- conflict set contains unnecessary variables. +-- +-- Producing an error message when the solver reaches the backjump limit is more +-- complicated. There is no final conflict set, so we create one for the minimal +-- subtree containing the path that the solver took to the first backjump. This +-- conflict set helps explain why the solver reached the backjump limit, because +-- the first backjump contributes to reaching the backjump limit. Additionally, +-- the solver is much more likely to be able to finish traversing this subtree +-- before the backjump limit, since its size is linear (not exponential) in the +-- number of goal choices. We create it by pruning all children after the first +-- successful child under each node in the original tree, so that there is at +-- most one valid choice at each level. Then we use the final conflict set from +-- that run to generate an error message, as in the case where the solver found +-- that there was no solution. +-- +-- Using the full log from a rerun of the solver ensures that the log is +-- complete, i.e., it shows the whole chain of dependencies from the user +-- targets to the conflicting packages. +solve' :: SolverConfig + -> CompilerInfo + -> Index + -> PkgConfigDb + -> (PN -> PackagePreferences) + -> Map PN [LabeledPackageConstraint] + -> Set PN + -> Progress String String (Assignment, RevDepMap) +solve' sc cinfo idx pkgConfigDB pprefs gcs pns = + toProgress $ retry (runSolver printFullLog sc) createErrorMsg + where + runSolver :: Bool -> SolverConfig + -> RetryLog String SolverFailure (Assignment, RevDepMap) + runSolver keepLog sc' = + displayLogMessages keepLog $ + solve sc' cinfo idx pkgConfigDB pprefs gcs pns + + createErrorMsg :: SolverFailure + -> RetryLog String String (Assignment, RevDepMap) + createErrorMsg failure@(ExhaustiveSearch cs cm) = + if asBool $ minimizeConflictSet sc + then continueWith ("Found no solution after exhaustively searching the " + ++ "dependency tree. Rerunning the dependency solver " + ++ "to minimize the conflict set ({" + ++ showConflictSet cs ++ "}).") $ + retry (tryToMinimizeConflictSet (runSolver printFullLog) sc cs cm) $ + \case + ExhaustiveSearch cs' cm' -> + fromProgress $ Fail $ + rerunSolverForErrorMsg cs' + ++ finalErrorMsg sc (ExhaustiveSearch cs' cm') + BackjumpLimitReached -> + fromProgress $ Fail $ + "Reached backjump limit while trying to minimize the " + ++ "conflict set to create a better error message. " + ++ "Original error message:\n" + ++ rerunSolverForErrorMsg cs + ++ finalErrorMsg sc failure + else fromProgress $ Fail $ + rerunSolverForErrorMsg cs ++ finalErrorMsg sc failure + createErrorMsg failure@BackjumpLimitReached = + continueWith + ("Backjump limit reached. Rerunning dependency solver to generate " + ++ "a final conflict set for the search tree containing the " + ++ "first backjump.") $ + retry (runSolver printFullLog sc { pruneAfterFirstSuccess = PruneAfterFirstSuccess True }) $ + \case + ExhaustiveSearch cs _ -> + fromProgress $ Fail $ + rerunSolverForErrorMsg cs ++ finalErrorMsg sc failure + BackjumpLimitReached -> + -- This case is possible when the number of goals involved in + -- conflicts is greater than the backjump limit. + fromProgress $ Fail $ finalErrorMsg sc failure + ++ "Failed to generate a summarized dependency solver " + ++ "log due to low backjump limit." + + rerunSolverForErrorMsg :: ConflictSet -> String + rerunSolverForErrorMsg cs = + let sc' = sc { + goalOrder = Just goalOrder' + , maxBackjumps = Just 0 + } + + -- Preferring goals from the conflict set takes precedence over the + -- original goal order. + goalOrder' = preferGoalsFromConflictSet cs <> fromMaybe mempty (goalOrder sc) + + in unlines ("Could not resolve dependencies:" : messages (toProgress (runSolver True sc'))) + + printFullLog = solverVerbosity sc >= verbose + + messages :: Progress step fail done -> [step] + messages = foldProgress (:) (const []) (const []) + +-- | Try to remove variables from the given conflict set to create a minimal +-- conflict set. +-- +-- Minimal means that no proper subset of the conflict set is also a conflict +-- set, though there may be other possible conflict sets with fewer variables. +-- This function minimizes the input by trying to remove one variable at a time. +-- It only makes one pass over the variables, so it runs the solver at most N +-- times when given a conflict set of size N. Only one pass is necessary, +-- because every superset of a conflict set is also a conflict set, meaning that +-- failing to remove variable X from a conflict set in one step means that X +-- cannot be removed from any subset of that conflict set in a subsequent step. +-- +-- Example steps: +-- +-- Start with {A, B, C}. +-- Try to remove A from {A, B, C} and fail. +-- Try to remove B from {A, B, C} and succeed. +-- Try to remove C from {A, C} and fail. +-- Return {A, C} +-- +-- This function can fail for two reasons: +-- +-- 1. The solver can reach the backjump limit on any run. In this case the +-- returned RetryLog ends with BackjumpLimitReached. +-- TODO: Consider applying the backjump limit to all solver runs combined, +-- instead of each individual run. For example, 10 runs with 10 backjumps +-- each should count as 100 backjumps. +-- 2. Since this function works by rerunning the solver, it is possible for the +-- solver to add new unnecessary variables to the conflict set. This function +-- discards the result from any run that adds new variables to the conflict +-- set, but the end result may not be completely minimized. +tryToMinimizeConflictSet :: forall a . (SolverConfig -> RetryLog String SolverFailure a) + -> SolverConfig + -> ConflictSet + -> ConflictMap + -> RetryLog String SolverFailure a +tryToMinimizeConflictSet runSolver sc cs cm = + foldl (\r v -> retryNoSolution r $ tryToRemoveOneVar v) + (fromProgress $ Fail $ ExhaustiveSearch cs cm) + (CS.toList cs) + where + -- This function runs the solver and makes it prefer goals in the following + -- order: + -- + -- 1. variables in 'smallestKnownCS', excluding 'v' + -- 2. 'v' + -- 3. all other variables + -- + -- If 'v' is not necessary, then the solver will find that there is no + -- solution before starting to solve for 'v', and the new final conflict set + -- will be very likely to not contain 'v'. If 'v' is necessary, the solver + -- will most likely need to try solving for 'v' before finding that there is + -- no solution, and the new final conflict set will still contain 'v'. + -- However, this method isn't perfect, because it is possible for the solver + -- to add new unnecessary variables to the conflict set on any run. This + -- function prevents the conflict set from growing by checking that the new + -- conflict set is a subset of the old one and falling back to using the old + -- conflict set when that check fails. + tryToRemoveOneVar :: Var QPN + -> ConflictSet + -> ConflictMap + -> RetryLog String SolverFailure a + tryToRemoveOneVar v smallestKnownCS smallestKnownCM + -- Check whether v is still present, because it may have already been + -- removed in a previous solver rerun. + | not (v `CS.member` smallestKnownCS) = + fromProgress $ Fail $ ExhaustiveSearch smallestKnownCS smallestKnownCM + | otherwise = + continueWith ("Trying to remove variable " ++ varStr ++ " from the " + ++ "conflict set.") $ + retry (runSolver sc') $ \case + err@(ExhaustiveSearch cs' _) + | CS.toSet cs' `isSubsetOf` CS.toSet smallestKnownCS -> + let msg = if not $ CS.member v cs' + then "Successfully removed " ++ varStr ++ " from " + ++ "the conflict set." + else "Failed to remove " ++ varStr ++ " from the " + ++ "conflict set." + in -- Use the new conflict set, even if v wasn't removed, + -- because other variables may have been removed. + failWith (msg ++ " Continuing with " ++ showCS cs' ++ ".") err + | otherwise -> + failWith ("Failed to find a smaller conflict set. The new " + ++ "conflict set is not a subset of the previous " + ++ "conflict set: " ++ showCS cs') $ + ExhaustiveSearch smallestKnownCS smallestKnownCM + BackjumpLimitReached -> + failWith ("Reached backjump limit while minimizing conflict set.") + BackjumpLimitReached + where + varStr = "\"" ++ showVar v ++ "\"" + showCS cs' = "{" ++ showConflictSet cs' ++ "}" + + sc' = sc { goalOrder = Just goalOrder' } + + goalOrder' = + preferGoalsFromConflictSet (v `CS.delete` smallestKnownCS) + <> preferGoal v + <> fromMaybe mempty (goalOrder sc) + + -- Like 'retry', except that it only applies the input function when the + -- backjump limit has not been reached. + retryNoSolution :: RetryLog step SolverFailure done + -> (ConflictSet -> ConflictMap -> RetryLog step SolverFailure done) + -> RetryLog step SolverFailure done + retryNoSolution lg f = retry lg $ \case + ExhaustiveSearch cs' cm' -> f cs' cm' + BackjumpLimitReached -> fromProgress (Fail BackjumpLimitReached) + +-- | Goal ordering that chooses goals contained in the conflict set before +-- other goals. +preferGoalsFromConflictSet :: ConflictSet + -> Variable QPN -> Variable QPN -> Ordering +preferGoalsFromConflictSet cs = comparing $ \v -> not $ CS.member (toVar v) cs + +-- | Goal ordering that chooses the given goal first. +preferGoal :: Var QPN -> Variable QPN -> Variable QPN -> Ordering +preferGoal preferred = comparing $ \v -> toVar v /= preferred + +toVar :: Variable QPN -> Var QPN +toVar (PackageVar qpn) = P qpn +toVar (FlagVar qpn fn) = F (FN qpn fn) +toVar (StanzaVar qpn sn) = S (SN qpn sn) + +finalErrorMsg :: SolverConfig -> SolverFailure -> String +finalErrorMsg sc failure = + case failure of + ExhaustiveSearch cs cm -> + "After searching the rest of the dependency tree exhaustively, " + ++ "these were the goals I've had most trouble fulfilling: " + ++ showCS cm cs + ++ flagSuggestion + where + showCS = if solverVerbosity sc > normal + then CS.showCSWithFrequency + else CS.showCSSortedByFrequency + flagSuggestion = + -- Don't suggest --minimize-conflict-set if the conflict set is + -- already small, because it is unlikely to be reduced further. + if CS.size cs > 3 && not (asBool (minimizeConflictSet sc)) + then "\nTry running with --minimize-conflict-set to improve the " + ++ "error message." + else "" + BackjumpLimitReached -> + "Backjump limit reached (" ++ currlimit (maxBackjumps sc) ++ + "change with --max-backjumps or try to run with --reorder-goals).\n" + where currlimit (Just n) = "currently " ++ show n ++ ", " + currlimit Nothing = "" diff --git a/cabal/cabal-install-solver/src/Distribution/Solver/Modular/Assignment.hs b/cabal/cabal-install-solver/src/Distribution/Solver/Modular/Assignment.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/src/Distribution/Solver/Modular/Assignment.hs @@ -0,0 +1,94 @@ +module Distribution.Solver.Modular.Assignment + ( Assignment(..) + , PAssignment + , FAssignment + , SAssignment + , toCPs + ) where + +import Prelude () +import Distribution.Solver.Compat.Prelude hiding (pi) + +import qualified Data.Array as A +import qualified Data.List as L +import qualified Data.Map as M + +import Data.Maybe (fromJust) + +import Distribution.PackageDescription (FlagAssignment, mkFlagAssignment) -- from Cabal + +import Distribution.Solver.Types.ComponentDeps (ComponentDeps, Component) +import qualified Distribution.Solver.Types.ComponentDeps as CD +import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.PackagePath + +import Distribution.Solver.Modular.Configured +import Distribution.Solver.Modular.Dependency +import Distribution.Solver.Modular.Flag +import Distribution.Solver.Modular.LabeledGraph +import Distribution.Solver.Modular.Package + +-- | A (partial) package assignment. Qualified package names +-- are associated with instances. +type PAssignment = Map QPN I + +type FAssignment = Map QFN Bool +type SAssignment = Map QSN Bool + +-- | A (partial) assignment of variables. +data Assignment = A PAssignment FAssignment SAssignment + deriving (Show, Eq) + +-- | Delivers an ordered list of fully configured packages. +-- +-- TODO: This function is (sort of) ok. However, there's an open bug +-- w.r.t. unqualification. There might be several different instances +-- of one package version chosen by the solver, which will lead to +-- clashes. +toCPs :: Assignment -> RevDepMap -> [CP QPN] +toCPs (A pa fa sa) rdm = + let + -- get hold of the graph + g :: Graph Component + vm :: Vertex -> ((), QPN, [(Component, QPN)]) + cvm :: QPN -> Maybe Vertex + -- Note that the RevDepMap contains duplicate dependencies. Therefore the nub. + (g, vm, cvm) = graphFromEdges (L.map (\ (x, xs) -> ((), x, nub xs)) + (M.toList rdm)) + tg :: Graph Component + tg = transposeG g + -- Topsort the dependency graph, yielding a list of pkgs in the right order. + -- The graph will still contain all the installed packages, and it might + -- contain duplicates, because several variables might actually resolve to + -- the same package in the presence of qualified package names. + ps :: [PI QPN] + ps = L.map ((\ (_, x, _) -> PI x (pa M.! x)) . vm) $ + topSort g + -- Determine the flags per package, by walking over and regrouping the + -- complete flag assignment by package. + fapp :: Map QPN FlagAssignment + fapp = M.fromListWith mappend $ + L.map (\ ((FN qpn fn), b) -> (qpn, mkFlagAssignment [(fn, b)])) $ + M.toList $ + fa + -- Stanzas per package. + sapp :: Map QPN OptionalStanzaSet + sapp = M.fromListWith mappend + $ L.map (\ ((SN qpn sn), b) -> (qpn, if b then optStanzaSetSingleton sn else mempty)) + $ M.toList sa + -- Dependencies per package. + depp :: QPN -> [(Component, PI QPN)] + depp qpn = let v :: Vertex + v = fromJust (cvm qpn) -- TODO: why this is safe? + dvs :: [(Component, Vertex)] + dvs = tg A.! v + in L.map (\ (comp, dv) -> case vm dv of (_, x, _) -> (comp, PI x (pa M.! x))) dvs + -- Translated to PackageDeps + depp' :: QPN -> ComponentDeps [PI QPN] + depp' = CD.fromList . L.map (\(comp, d) -> (comp, [d])) . depp + in + L.map (\ pi@(PI qpn _) -> CP pi + (M.findWithDefault mempty qpn fapp) + (M.findWithDefault mempty qpn sapp) + (depp' qpn)) + ps diff --git a/cabal/cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs b/cabal/cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs @@ -0,0 +1,296 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Distribution.Solver.Modular.Builder ( + buildTree + , splits -- for testing + ) where + +-- Building the search tree. +-- +-- In this phase, we build a search tree that is too large, i.e, it contains +-- invalid solutions. We keep track of the open goals at each point. We +-- nondeterministically pick an open goal (via a goal choice node), create +-- subtrees according to the index and the available solutions, and extend the +-- set of open goals by superficially looking at the dependencies recorded in +-- the index. +-- +-- For each goal, we keep track of all the *reasons* why it is being +-- introduced. These are for debugging and error messages, mainly. A little bit +-- of care has to be taken due to the way we treat flags. If a package has +-- flag-guarded dependencies, we cannot introduce them immediately. Instead, we +-- store the entire dependency. + +import qualified Data.List as L +import qualified Data.Map as M +import qualified Data.Set as S +import Prelude + +import qualified Distribution.Solver.Modular.ConflictSet as CS +import Distribution.Solver.Modular.Dependency +import Distribution.Solver.Modular.Flag +import Distribution.Solver.Modular.Index +import Distribution.Solver.Modular.Package +import qualified Distribution.Solver.Modular.PSQ as P +import Distribution.Solver.Modular.Tree +import qualified Distribution.Solver.Modular.WeightedPSQ as W + +import Distribution.Solver.Types.ComponentDeps +import Distribution.Solver.Types.PackagePath +import Distribution.Solver.Types.Settings + +-- | 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 +-- the tree. +data Linker a = Linker { + buildState :: a, + linkingState :: LinkingState +} + +-- | The state needed to build the search tree without creating any linked nodes. +data BuildState = BS { + index :: Index, -- ^ information about packages and their dependencies + rdeps :: RevDepMap, -- ^ set of all package goals, completed and open, with reverse dependencies + open :: [OpenGoal], -- ^ set of still open goals (flag and package goals) + next :: BuildType, -- ^ kind of node to generate next + qualifyOptions :: QualifyOptions -- ^ qualification options +} + +-- | Map of available linking targets. +type LinkingState = M.Map (PN, I) [PackagePath] + +-- | Extend the set of open goals with the new goals listed. +-- +-- 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 + 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. + 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 + + 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) + +-- | Given the current scope, qualify all the package names in the given set of +-- dependencies and then extend the set of open goals accordingly. +scopedExtendOpen :: QPN -> FlaggedDeps PN -> FlagInfo -> + BuildState -> BuildState +scopedExtendOpen qpn fdeps fdefs s = extendOpen qpn gs s + where + -- Qualify all package names + qfdeps = qualifyDeps (qualifyOptions s) 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 + gs = qfdefs ++ qfdeps + -- NOTE: + -- + -- In the expression @qfdefs ++ qfdeps@ above, flags occur potentially + -- multiple times, both via the flag declaration and via dependencies. + +-- | Datatype that encodes what to build next +data BuildType = + Goals -- ^ build a goal choice node + | OneGoal OpenGoal -- ^ build a node for this goal + | Instance QPN PInfo -- ^ build a tree for a concrete instance + +build :: Linker BuildState -> Tree () QGoalReason +build = ana go + where + go :: Linker BuildState -> TreeF () QGoalReason (Linker BuildState) + go s = addLinking (linkingState s) $ addChildren (buildState s) + +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 }) + | L.null gs = DoneF rdm () + | otherwise = GoalChoiceF rdm $ P.fromList + $ L.map (\ (g, gs') -> (close g, bs { next = OneGoal g, open = gs' })) + $ splits gs + +-- 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) + +-- For a particular instance, we change the state: we update the scope, +-- and furthermore we update the set of goals. +-- +-- TODO: We could inline this above. +addChildren bs@(BS { next = Instance qpn (PInfo fdeps _ fdefs _) }) = + addChildren ((scopedExtendOpen qpn fdeps fdefs bs) + { next = Goals }) + +{------------------------------------------------------------------------------- + Add linking +-------------------------------------------------------------------------------} + +-- | Introduce link nodes into the tree +-- +-- Linking is a phase that adapts package choice nodes and adds the option to +-- link wherever appropriate: Package goals are called "related" if they are for +-- the same instance of the same package (but have different prefixes). A link +-- option is available in a package choice node whenever we can choose an +-- instance that has already been chosen for a related goal at a higher position +-- in the tree. We only create link options for related goals that are not +-- themselves linked, because the choice to link to a linked goal is the same as +-- the choice to link to the target of that goal's linking. +-- +-- The code here proceeds by maintaining a finite map recording choices that +-- have been made at higher positions in the tree. For each pair of package name +-- and instance, it stores the prefixes at which we have made a choice for this +-- package instance. Whenever we make an unlinked choice, we extend the map. +-- Whenever we find a choice, we look into the map in order to find out what +-- link options we have to add. +-- +-- A separate tree traversal would be simpler. However, 'addLinking' creates +-- linked nodes from existing unlinked nodes, which leads to sharing between the +-- nodes. If we copied the nodes when they were full trees of type +-- 'Tree () QGoalReason', then the sharing would cause a space leak during +-- exploration of the tree. Instead, we only copy the 'BuildState', which is +-- relatively small, while the tree is being constructed. See +-- https://github.com/haskell/cabal/issues/2899 +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) $ + W.fromList $ concatMap (linkChoices ls qpn) (W.toList cs) + unlinkedCs = W.mapWithKey goP cs + allCs = unlinkedCs `W.union` linkedCs + + -- Recurse underneath package choices. Here we just need to make sure + -- that we record the package choice so that it is available below + goP :: POption -> a -> Linker a + 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 + +linkChoices :: forall a w . LinkingState + -> QPN + -> (w, POption, a) + -> [(w, POption, a)] +linkChoices related (Q _pp pn) (weight, POption i Nothing, subtree) = + L.map aux (M.findWithDefault [] (pn, i) related) + where + aux :: PackagePath -> (w, POption, a) + aux pp = (weight, POption i (Just pp), subtree) +linkChoices _ _ (_, POption _ (Just _), _) = + alreadyLinked + +alreadyLinked :: a +alreadyLinked = error "addLinking called on tree that already contains linked nodes" + +------------------------------------------------------------------------------- + +-- | Interface to the tree builder. Just takes an index and a list of package names, +-- and computes the initial state and then the tree from there. +buildTree :: Index -> IndependentGoals -> [PN] -> Tree () QGoalReason +buildTree idx (IndependentGoals ind) igs = + build Linker { + buildState = BS { + index = idx + , rdeps = M.fromList (L.map (\ qpn -> (qpn, [])) qpns) + , open = L.map topLevelGoal qpns + , next = Goals + , qualifyOptions = defaultQualifyOptions idx + } + , linkingState = M.empty + } + where + topLevelGoal qpn = PkgGoal qpn UserGoal + + qpns | ind = L.map makeIndependent igs + | otherwise = L.map (Q (PackagePath DefaultNamespace QualToplevel)) igs + +{------------------------------------------------------------------------------- + Goals +-------------------------------------------------------------------------------} + +-- | Information needed about a dependency before it is converted into a Goal. +data OpenGoal = + FlagGoal (FN QPN) FInfo (FlaggedDeps QPN) (FlaggedDeps QPN) QGoalReason + | StanzaGoal (SN QPN) (FlaggedDeps QPN) QGoalReason + | PkgGoal QPN QGoalReason + +-- | Closes a goal, i.e., removes all the extraneous information that we +-- need only during the build phase. +close :: OpenGoal -> Goal QPN +close (FlagGoal qfn _ _ _ gr) = Goal (F qfn) gr +close (StanzaGoal qsn _ gr) = Goal (S qsn) gr +close (PkgGoal qpn gr) = Goal (P qpn) gr + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +-- | Pairs each element of a list with the list resulting from removal of that +-- element from the original list. +splits :: [a] -> [(a, [a])] +splits = go id + where + go :: ([a] -> [a]) -> [a] -> [(a, [a])] + go _ [] = [] + go f (x : xs) = (x, f xs) : go (f . (x :)) xs diff --git a/cabal/cabal-install-solver/src/Distribution/Solver/Modular/Configured.hs b/cabal/cabal-install-solver/src/Distribution/Solver/Modular/Configured.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/src/Distribution/Solver/Modular/Configured.hs @@ -0,0 +1,13 @@ +module Distribution.Solver.Modular.Configured + ( CP(..) + ) where + +import Distribution.PackageDescription (FlagAssignment) + +import Distribution.Solver.Modular.Package +import Distribution.Solver.Types.ComponentDeps (ComponentDeps) +import Distribution.Solver.Types.OptionalStanza + +-- | A configured package is a package instance together with +-- a flag assignment and complete dependencies. +data CP qpn = CP (PI qpn) FlagAssignment OptionalStanzaSet (ComponentDeps [PI qpn]) diff --git a/cabal/cabal-install-solver/src/Distribution/Solver/Modular/ConfiguredConversion.hs b/cabal/cabal-install-solver/src/Distribution/Solver/Modular/ConfiguredConversion.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/src/Distribution/Solver/Modular/ConfiguredConversion.hs @@ -0,0 +1,72 @@ +module Distribution.Solver.Modular.ConfiguredConversion + ( convCP + ) where + +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 +import Distribution.Solver.Modular.Package + +import Distribution.Solver.Types.ComponentDeps (ComponentDeps) +import qualified Distribution.Solver.Types.PackageIndex as CI +import Distribution.Solver.Types.PackagePath +import Distribution.Solver.Types.ResolverPackage +import Distribution.Solver.Types.SolverId +import Distribution.Solver.Types.SolverPackage +import Distribution.Solver.Types.InstSolverPackage +import Distribution.Solver.Types.SourcePackage + +-- | Converts from the solver specific result @CP QPN@ into +-- a 'ResolverPackage', which can then be converted into +-- the install plan. +convCP :: 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 $ + InstSolverPackage { + instSolverPkgIPI = fromJust $ SI.lookupUnitId iidx pi, + instSolverPkgLibDeps = fmap fst ds', + instSolverPkgExeDeps = fmap snd ds' + } + Right pi -> Configured $ + SolverPackage { + solverPkgSource = srcpkg, + 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)) = + case loc of + Inst pi -> Left (PreExistingId sourceId pi) + _otherwise + | QualExe _ pn' <- q + -- NB: the dependencies of the executable are also + -- qualified. So the way to tell if this is an executable + -- dependency is to make sure the qualifier is pointing + -- 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) + where + sourceId = PackageIdentifier pn v diff --git a/cabal/cabal-install-solver/src/Distribution/Solver/Modular/ConflictSet.hs b/cabal/cabal-install-solver/src/Distribution/Solver/Modular/ConflictSet.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/src/Distribution/Solver/Modular/ConflictSet.hs @@ -0,0 +1,244 @@ +{-# LANGUAGE CPP #-} +#ifdef DEBUG_CONFLICT_SETS +{-# LANGUAGE ImplicitParams #-} +#endif +-- | Conflict sets +-- +-- Intended for double import +-- +-- > import Distribution.Solver.Modular.ConflictSet (ConflictSet) +-- > import qualified Distribution.Solver.Modular.ConflictSet as CS +module Distribution.Solver.Modular.ConflictSet ( + ConflictSet -- opaque + , Conflict(..) + , ConflictMap + , OrderedVersionRange(..) +#ifdef DEBUG_CONFLICT_SETS + , conflictSetOrigin +#endif + , showConflictSet + , showCSSortedByFrequency + , showCSWithFrequency + -- Set-like operations + , toSet + , toList + , union + , unions + , insert + , delete + , empty + , singleton + , singletonWithConflict + , size + , member + , lookup + , filter + , fromList + ) where + +import Prelude hiding (lookup) +import Data.List (intercalate, sortBy) +import Data.Map (Map) +import Data.Set (Set) +import Data.Function (on) +import qualified Data.Map.Strict as M +import qualified Data.Set as S + +#ifdef DEBUG_CONFLICT_SETS +import Data.Tree +import GHC.Stack +#endif + +import Distribution.Solver.Modular.Var +import Distribution.Solver.Modular.Version +import Distribution.Solver.Types.PackagePath + +-- | The set of variables involved in a solver conflict, each paired with +-- details about the conflict. +data ConflictSet = CS { + -- | The set of variables involved in the conflict + conflictSetToMap :: !(Map (Var QPN) (Set Conflict)) + +#ifdef DEBUG_CONFLICT_SETS + -- | The origin of the conflict set + -- + -- When @DEBUG_CONFLICT_SETS@ is defined @(-f debug-conflict-sets)@, + -- we record the origin of every conflict set. For new conflict sets + -- ('empty', 'fromVars', ..) we just record the 'CallStack'; for operations + -- that construct new conflict sets from existing conflict sets ('union', + -- 'filter', ..) we record the 'CallStack' to the call to the combinator + -- as well as the 'CallStack's of the input conflict sets. + -- + -- Requires @GHC >= 7.10@. + , conflictSetOrigin :: Tree CallStack +#endif + } + deriving (Show) + +-- | More detailed information about how a conflict set variable caused a +-- conflict. This information can be used to determine whether a second value +-- for that variable would lead to the same conflict. +-- +-- TODO: Handle dependencies under flags or stanzas. +data Conflict = + + -- | The conflict set variable represents a package which depends on the + -- specified problematic package. For example, the conflict set entry + -- '(P x, GoalConflict y)' means that package x introduced package y, and y + -- led to a conflict. + GoalConflict QPN + + -- | The conflict set variable represents a package with a constraint that + -- excluded the specified package and version. For example, the conflict set + -- entry '(P x, VersionConstraintConflict y (mkVersion [2, 0]))' means that + -- package x's constraint on y excluded y-2.0. + | VersionConstraintConflict QPN Ver + + -- | The conflict set variable represents a package that was excluded by a + -- constraint from the specified package. For example, the conflict set + -- entry '(P x, VersionConflict y (orLaterVersion (mkVersion [2, 0])))' + -- means that package y's constraint 'x >= 2.0' excluded some version of x. + | VersionConflict QPN OrderedVersionRange + + -- | Any other conflict. + | OtherConflict + deriving (Eq, Ord, Show) + +-- | Version range with an 'Ord' instance. +newtype OrderedVersionRange = OrderedVersionRange VR + deriving (Eq, Show) + +-- TODO: Avoid converting the version ranges to strings. +instance Ord OrderedVersionRange where + compare = compare `on` show + +instance Eq ConflictSet where + (==) = (==) `on` conflictSetToMap + +instance Ord ConflictSet where + compare = compare `on` conflictSetToMap + +showConflictSet :: ConflictSet -> String +showConflictSet = intercalate ", " . map showVar . toList + +showCSSortedByFrequency :: ConflictMap -> ConflictSet -> String +showCSSortedByFrequency = showCS False + +showCSWithFrequency :: ConflictMap -> ConflictSet -> String +showCSWithFrequency = showCS True + +showCS :: Bool -> ConflictMap -> ConflictSet -> String +showCS showCount cm = + intercalate ", " . map showWithFrequency . indexByFrequency + where + indexByFrequency = sortBy (flip compare `on` snd) . map (\c -> (c, M.lookup c cm)) . toList + showWithFrequency (conflict, maybeFrequency) = case maybeFrequency of + Just frequency + | showCount -> showVar conflict ++ " (" ++ show frequency ++ ")" + _ -> showVar conflict + +{------------------------------------------------------------------------------- + Set-like operations +-------------------------------------------------------------------------------} + +toSet :: ConflictSet -> Set (Var QPN) +toSet = M.keysSet . conflictSetToMap + +toList :: ConflictSet -> [Var QPN] +toList = M.keys . conflictSetToMap + +union :: +#ifdef DEBUG_CONFLICT_SETS + (?loc :: CallStack) => +#endif + ConflictSet -> ConflictSet -> ConflictSet +union cs cs' = CS { + conflictSetToMap = M.unionWith S.union (conflictSetToMap cs) (conflictSetToMap cs') +#ifdef DEBUG_CONFLICT_SETS + , conflictSetOrigin = Node ?loc (map conflictSetOrigin [cs, cs']) +#endif + } + +unions :: +#ifdef DEBUG_CONFLICT_SETS + (?loc :: CallStack) => +#endif + [ConflictSet] -> ConflictSet +unions css = CS { + conflictSetToMap = M.unionsWith S.union (map conflictSetToMap css) +#ifdef DEBUG_CONFLICT_SETS + , conflictSetOrigin = Node ?loc (map conflictSetOrigin css) +#endif + } + +insert :: +#ifdef DEBUG_CONFLICT_SETS + (?loc :: CallStack) => +#endif + Var QPN -> ConflictSet -> ConflictSet +insert var cs = CS { + conflictSetToMap = M.insert var (S.singleton OtherConflict) (conflictSetToMap cs) +#ifdef DEBUG_CONFLICT_SETS + , conflictSetOrigin = Node ?loc [conflictSetOrigin cs] +#endif + } + +delete :: Var QPN -> ConflictSet -> ConflictSet +delete var cs = CS { + conflictSetToMap = M.delete var (conflictSetToMap cs) + } + +empty :: +#ifdef DEBUG_CONFLICT_SETS + (?loc :: CallStack) => +#endif + ConflictSet +empty = CS { + conflictSetToMap = M.empty +#ifdef DEBUG_CONFLICT_SETS + , conflictSetOrigin = Node ?loc [] +#endif + } + +singleton :: +#ifdef DEBUG_CONFLICT_SETS + (?loc :: CallStack) => +#endif + Var QPN -> ConflictSet +singleton var = singletonWithConflict var OtherConflict + +singletonWithConflict :: +#ifdef DEBUG_CONFLICT_SETS + (?loc :: CallStack) => +#endif + Var QPN -> Conflict -> ConflictSet +singletonWithConflict var conflict = CS { + conflictSetToMap = M.singleton var (S.singleton conflict) +#ifdef DEBUG_CONFLICT_SETS + , conflictSetOrigin = Node ?loc [] +#endif + } + +size :: ConflictSet -> Int +size = M.size . conflictSetToMap + +member :: Var QPN -> ConflictSet -> Bool +member var = M.member var . conflictSetToMap + +lookup :: Var QPN -> ConflictSet -> Maybe (Set Conflict) +lookup var = M.lookup var . conflictSetToMap + +fromList :: +#ifdef DEBUG_CONFLICT_SETS + (?loc :: CallStack) => +#endif + [Var QPN] -> ConflictSet +fromList vars = CS { + conflictSetToMap = M.fromList [(var, S.singleton OtherConflict) | var <- vars] +#ifdef DEBUG_CONFLICT_SETS + , conflictSetOrigin = Node ?loc [] +#endif + } + +type ConflictMap = Map (Var QPN) Int + diff --git a/cabal/cabal-install-solver/src/Distribution/Solver/Modular/Cycles.hs b/cabal/cabal-install-solver/src/Distribution/Solver/Modular/Cycles.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/src/Distribution/Solver/Modular/Cycles.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE TypeFamilies #-} +module Distribution.Solver.Modular.Cycles ( + detectCyclesPhase + ) where + +import Prelude hiding (cycle) +import qualified Data.Map as M +import qualified Data.Set as S + +import qualified Distribution.Compat.Graph as G +import Distribution.Simple.Utils (ordNub) +import Distribution.Solver.Modular.Dependency +import Distribution.Solver.Modular.Flag +import Distribution.Solver.Modular.Tree +import qualified Distribution.Solver.Modular.ConflictSet as CS +import Distribution.Solver.Types.ComponentDeps (Component) +import Distribution.Solver.Types.PackagePath + +-- | Find and reject any nodes with cyclic dependencies +detectCyclesPhase :: Tree d c -> Tree d c +detectCyclesPhase = go + where + -- 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) + go (FChoice qfn@(FN qpn _) rdm gr w m d cs) = + FChoice qfn rdm gr w m d $ fmap (checkChild qpn) (fmap go cs) + go (SChoice qsn@(SN qpn _) rdm gr w cs) = + SChoice qsn rdm gr w $ fmap (checkChild qpn) (fmap go cs) + go (GoalChoice rdm cs) = GoalChoice rdm (fmap go cs) + go x@(Fail _ _) = x + go x@(Done _ _) = x + + checkChild :: QPN -> Tree d c -> Tree d c + checkChild qpn x@(PChoice _ rdm _ _) = failIfCycle qpn rdm x + checkChild qpn x@(FChoice _ rdm _ _ _ _ _) = failIfCycle qpn rdm x + checkChild qpn x@(SChoice _ rdm _ _ _) = failIfCycle qpn rdm x + checkChild qpn x@(GoalChoice rdm _) = failIfCycle qpn rdm x + checkChild _ x@(Fail _ _) = x + checkChild qpn x@(Done rdm _) = failIfCycle qpn rdm x + + failIfCycle :: QPN -> RevDepMap -> Tree d c -> Tree d c + failIfCycle qpn rdm x = + case findCycles qpn rdm of + Nothing -> x + Just relSet -> Fail relSet CyclicDependencies + +-- | Given the reverse dependency map from a node in the tree, check +-- if the solution is cyclic. If it is, return the conflict set containing +-- 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 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. + -- + -- 'hasCycle' checks for cycles incrementally by only looking for cycles + -- containing the current package, 'pkg'. It searches for cycles in the + -- 'RevDepMap', which is the data structure used to store reverse + -- dependencies in the search tree. We store the reverse dependencies in a + -- map, because Data.Map is smaller and/or has better sharing than + -- Distribution.Compat.Graph. + -- + -- If there is a cycle, we call G.cycles to find a strongly connected + -- component. Then we choose one cycle from the component to use for the + -- conflict set. Choosing only one cycle can lead to a smaller conflict set, + -- such as when a choice to enable testing introduces many cycles at once. + -- In that case, all cycles contain the current package and are in one large + -- strongly connected component. + -- + if hasCycle + then let scc :: G.Graph RevDepMapNode + scc = case G.cycles $ revDepMapToGraph rdm of + [] -> findCyclesError "cannot find a strongly connected component" + c : _ -> G.fromDistinctList c + + next :: QPN -> QPN + next p = case G.neighbors scc p of + Just (n : _) -> G.nodeKey n + _ -> findCyclesError "cannot find next node in the cycle" + + -- This function also assumes that all cycles contain 'pkg'. + oneCycle :: [QPN] + oneCycle = case iterate next pkg of + [] -> findCyclesError "empty cycle" + x : xs -> x : takeWhile (/= x) xs + in Just $ CS.fromList $ map P oneCycle + else Nothing + where + hasCycle :: Bool + hasCycle = pkg `S.member` closure (neighbors pkg) + + closure :: [QPN] -> S.Set QPN + closure = foldl go S.empty + where + go :: S.Set QPN -> QPN -> S.Set QPN + go s x = + if x `S.member` s + then s + else foldl go (S.insert x s) $ neighbors x + + neighbors :: QPN -> [QPN] + neighbors x = case x `M.lookup` rdm of + Nothing -> findCyclesError "cannot find node" + Just xs -> map snd xs + + findCyclesError = error . ("Distribution.Solver.Modular.Cycles.findCycles: " ++) + +data RevDepMapNode = RevDepMapNode QPN [(Component, QPN)] + +instance G.IsNode RevDepMapNode where + type Key RevDepMapNode = QPN + nodeKey (RevDepMapNode qpn _) = qpn + nodeNeighbors (RevDepMapNode _ ns) = ordNub $ map snd ns + +revDepMapToGraph :: RevDepMap -> G.Graph RevDepMapNode +revDepMapToGraph rdm = G.fromDistinctList + [RevDepMapNode qpn ns | (qpn, ns) <- M.toList rdm] diff --git a/cabal/cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs b/cabal/cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs @@ -0,0 +1,358 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE RecordWildCards #-} +module Distribution.Solver.Modular.Dependency ( + -- * Variables + Var(..) + , showVar + , varPN + -- * Conflict sets + , ConflictSet + , ConflictMap + , CS.showConflictSet + -- * Constrained instances + , CI(..) + -- * Flagged dependencies + , FlaggedDeps + , FlaggedDep(..) + , LDep(..) + , Dep(..) + , PkgComponent(..) + , ExposedComponent(..) + , DependencyReason(..) + , showDependencyReason + , flattenFlaggedDeps + , QualifyOptions(..) + , qualifyDeps + , unqualifyDeps + -- * Reverse dependency map + , RevDepMap + -- * Goals + , Goal(..) + , GoalReason(..) + , QGoalReason + , goalToVar + , varToConflictSet + , goalReasonToConflictSet + , goalReasonToConflictSetWithConflict + , dependencyReasonToConflictSet + , dependencyReasonToConflictSetWithVersionConstraintConflict + , dependencyReasonToConflictSetWithVersionConflict + ) where + +import Prelude () +import qualified Data.Map as M +import qualified Data.Set as S +import Distribution.Solver.Compat.Prelude hiding (pi) + +import Language.Haskell.Extension (Extension(..), Language(..)) + +import Distribution.Solver.Modular.ConflictSet (ConflictSet, ConflictMap) +import Distribution.Solver.Modular.Flag +import Distribution.Solver.Modular.Package +import Distribution.Solver.Modular.Var +import Distribution.Solver.Modular.Version +import qualified Distribution.Solver.Modular.ConflictSet as CS + +import Distribution.Solver.Types.ComponentDeps (Component(..)) +import Distribution.Solver.Types.PackagePath +import Distribution.Types.LibraryName +import Distribution.Types.PkgconfigVersionRange +import Distribution.Types.UnqualComponentName + +{------------------------------------------------------------------------------- + Constrained instances +-------------------------------------------------------------------------------} + +-- | Constrained instance. It represents the allowed instances for a package, +-- which can be either a fixed instance or a version range. +data CI = Fixed I | Constrained VR + deriving (Eq, Show) + +{------------------------------------------------------------------------------- + Flagged dependencies +-------------------------------------------------------------------------------} + +-- | Flagged dependencies +-- +-- 'FlaggedDeps' is the modular solver's view of a packages dependencies: +-- rather than having the dependencies indexed by component, each dependency +-- defines what component it is in. +-- +-- Note that each dependency is associated with a Component. We must know what +-- component the dependencies belong to, or else we won't be able to construct +-- fine-grained reverse dependencies. +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 + -- (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 + +-- | Conservatively flatten out flagged dependencies +-- +-- NOTE: We do not filter out duplicates. +flattenFlaggedDeps :: FlaggedDeps qpn -> [(LDep qpn, Component)] +flattenFlaggedDeps = concatMap aux + where + aux :: FlaggedDep qpn -> [(LDep qpn, Component)] + aux (Flagged _ _ t f) = flattenFlaggedDeps t ++ flattenFlaggedDeps f + 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) + +-- | 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 + +-- | 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 + deriving (Eq, Ord, Functor, Show) + +-- | A component that can be depended upon by another package, i.e., a library +-- or an executable. +data ExposedComponent = + ExposedLib LibraryName + | 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) + deriving (Functor, Eq, Show) + +-- | Print the reason that a dependency was introduced. +showDependencyReason :: DependencyReason QPN -> String +showDependencyReason (DependencyReason qpn flags stanzas) = + intercalate " " $ + showQPN qpn + : map (uncurry showFlagValue) (M.toList flags) + ++ map (\s -> showSBool s True) (S.toList stanzas) + +-- | Options for goal qualification (used in 'qualifyDeps') +-- +-- See also 'defaultQualifyOptions' +data QualifyOptions = QO { + -- | Do we have a version of base relying on another version of base? + qoBaseShim :: Bool + + -- Should dependencies of the setup script be treated as independent? + , qoSetupIndependent :: Bool + } + deriving Show + +-- | Apply built-in rules for package qualifiers +-- +-- Although the behaviour of 'qualifyDeps' depends on the 'QualifyOptions', +-- it is important that these 'QualifyOptions' are _static_. Qualification +-- does NOT depend on flag assignment; in other words, it behaves the same no +-- matter which choices the solver makes (modulo the global 'QualifyOptions'); +-- we rely on this in 'linkDeps' (see comment there). +-- +-- 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 + where + go :: FlaggedDeps PN -> FlaggedDeps QPN + go = map go1 + + go1 :: FlaggedDep PN -> FlaggedDep QPN + go1 (Flagged fn nfo t f) = Flagged (fmap (Q pp) fn) nfo (go t) (go f) + go1 (Stanza sn t) = Stanza (fmap (Q pp) sn) (go t) + go1 (Simple dep comp) = Simple (goLDep dep comp) comp + + -- Suppose package B has a setup dependency on package A. + -- This will be recorded as something like + -- + -- > LDep (DependencyReason "B") (Dep (PkgComponent "A" (ExposedLib LMainLibName)) (Constrained AnyVersion)) + -- + -- Observe that when we qualify this dependency, we need to turn that + -- @"A"@ into @"B-setup.A"@, but we should not apply that same qualifier + -- to the DependencyReason. + goLDep :: LDep PN -> Component -> LDep QPN + 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 + +-- | Remove qualifiers from set of dependencies +-- +-- This is used during link validation: when we link package @Q.A@ to @Q'.A@, +-- then all dependencies @Q.B@ need to be linked to @Q'.B@. In order to compute +-- what to link these dependencies to, we need to requalify @Q.B@ to become +-- @Q'.B@; we do this by first removing all qualifiers and then calling +-- 'qualifyDeps' again. +unqualifyDeps :: FlaggedDeps QPN -> FlaggedDeps PN +unqualifyDeps = go + where + go :: FlaggedDeps QPN -> FlaggedDeps PN + go = map go1 + + go1 :: FlaggedDep QPN -> FlaggedDep PN + go1 (Flagged fn nfo t f) = Flagged (fmap unq fn) nfo (go t) (go f) + go1 (Stanza sn t) = Stanza (fmap unq sn) (go t) + go1 (Simple dep comp) = Simple (goLDep dep) comp + + goLDep :: LDep QPN -> LDep PN + goLDep (LDep dr dep) = LDep (fmap unq dr) (fmap unq dep) + + unq :: QPN -> PN + unq (Q _ pn) = pn + +{------------------------------------------------------------------------------- + Reverse dependency map +-------------------------------------------------------------------------------} + +-- | A map containing reverse dependencies between qualified +-- package names. +type RevDepMap = Map QPN [(Component, QPN)] + +{------------------------------------------------------------------------------- + Goals +-------------------------------------------------------------------------------} + +-- | A goal is just a solver variable paired with a reason. +-- The reason is only used for tracing. +data Goal qpn = Goal (Var qpn) (GoalReason qpn) + deriving (Eq, Show, Functor) + +-- | Reason why a goal is being added to a goal set. +data GoalReason qpn = + UserGoal -- introduced by a build target + | DependencyGoal (DependencyReason qpn) -- introduced by a package + deriving (Eq, Show, Functor) + +type QGoalReason = GoalReason QPN + +goalToVar :: Goal a -> Var a +goalToVar (Goal v _) = v + +-- | Compute a singleton conflict set from a 'Var' +varToConflictSet :: Var QPN -> ConflictSet +varToConflictSet = CS.singleton + +-- | Convert a 'GoalReason' to a 'ConflictSet' that can be used when the goal +-- leads to a conflict. +goalReasonToConflictSet :: GoalReason QPN -> ConflictSet +goalReasonToConflictSet UserGoal = CS.empty +goalReasonToConflictSet (DependencyGoal dr) = dependencyReasonToConflictSet dr + +-- | Convert a 'GoalReason' to a 'ConflictSet' containing the reason that the +-- conflict occurred, namely the conflict set variables caused a conflict by +-- introducing the given package goal. See the documentation for 'GoalConflict'. +-- +-- This function currently only specifies the reason for the conflict in the +-- simple case where the 'GoalReason' does not involve any flags or stanzas. +-- Otherwise, it falls back to calling 'goalReasonToConflictSet'. +goalReasonToConflictSetWithConflict :: QPN -> GoalReason QPN -> ConflictSet +goalReasonToConflictSetWithConflict goal (DependencyGoal (DependencyReason qpn flags stanzas)) + | M.null flags && S.null stanzas = + CS.singletonWithConflict (P qpn) $ CS.GoalConflict goal +goalReasonToConflictSetWithConflict _ gr = goalReasonToConflictSet gr + +-- | This function returns the solver variables responsible for the dependency. +-- It drops the values chosen for flag and stanza variables, which are only +-- needed for log messages. +dependencyReasonToConflictSet :: DependencyReason QPN -> ConflictSet +dependencyReasonToConflictSet (DependencyReason qpn flags stanzas) = + CS.fromList $ P qpn : flagVars ++ map stanzaToVar (S.toList stanzas) + where + -- Filter out any flags that introduced the dependency with both values. + -- They don't need to be included in the conflict set, because changing the + -- flag value can't remove the dependency. + flagVars :: [Var QPN] + flagVars = [F (FN qpn fn) | (fn, fv) <- M.toList flags, fv /= FlagBoth] + + stanzaToVar :: Stanza -> Var QPN + stanzaToVar = S . SN qpn + +-- | Convert a 'DependencyReason' to a 'ConflictSet' specifying that the +-- conflict occurred because the conflict set variables introduced a problematic +-- version constraint. See the documentation for 'VersionConstraintConflict'. +-- +-- This function currently only specifies the reason for the conflict in the +-- simple case where the 'DependencyReason' does not involve any flags or +-- stanzas. Otherwise, it falls back to calling 'dependencyReasonToConflictSet'. +dependencyReasonToConflictSetWithVersionConstraintConflict :: QPN + -> Ver + -> DependencyReason QPN + -> ConflictSet +dependencyReasonToConflictSetWithVersionConstraintConflict + dependency excludedVersion dr@(DependencyReason qpn flags stanzas) + | M.null flags && S.null stanzas = + CS.singletonWithConflict (P qpn) $ + CS.VersionConstraintConflict dependency excludedVersion + | otherwise = dependencyReasonToConflictSet dr + +-- | Convert a 'DependencyReason' to a 'ConflictSet' specifying that the +-- conflict occurred because the conflict set variables introduced a version of +-- a package that was excluded by a version constraint. See the documentation +-- for 'VersionConflict'. +-- +-- This function currently only specifies the reason for the conflict in the +-- simple case where the 'DependencyReason' does not involve any flags or +-- stanzas. Otherwise, it falls back to calling 'dependencyReasonToConflictSet'. +dependencyReasonToConflictSetWithVersionConflict :: QPN + -> CS.OrderedVersionRange + -> DependencyReason QPN + -> ConflictSet +dependencyReasonToConflictSetWithVersionConflict + pkgWithVersionConstraint constraint dr@(DependencyReason qpn flags stanzas) + | M.null flags && S.null stanzas = + CS.singletonWithConflict (P qpn) $ + CS.VersionConflict pkgWithVersionConstraint constraint + | otherwise = dependencyReasonToConflictSet dr diff --git a/cabal/cabal-install-solver/src/Distribution/Solver/Modular/Explore.hs b/cabal/cabal-install-solver/src/Distribution/Solver/Modular/Explore.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/src/Distribution/Solver/Modular/Explore.hs @@ -0,0 +1,366 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Distribution.Solver.Modular.Explore (backjumpAndExplore) where + +import Distribution.Solver.Compat.Prelude +import Prelude () + +import qualified Distribution.Solver.Types.Progress as P + +import qualified Data.List as L (foldl') +import qualified Data.Map.Strict as M +import qualified Data.Set as S + +import Distribution.Simple.Setup (asBool) + +import Distribution.Solver.Modular.Assignment +import Distribution.Solver.Modular.Dependency +import Distribution.Solver.Modular.Index +import Distribution.Solver.Modular.Log +import Distribution.Solver.Modular.Message +import Distribution.Solver.Modular.Package +import qualified Distribution.Solver.Modular.PSQ as P +import qualified Distribution.Solver.Modular.ConflictSet as CS +import Distribution.Solver.Modular.RetryLog +import Distribution.Solver.Modular.Tree +import Distribution.Solver.Modular.Version +import qualified Distribution.Solver.Modular.WeightedPSQ as W +import Distribution.Solver.Types.PackagePath +import Distribution.Solver.Types.Settings + (CountConflicts(..), EnableBackjumping(..), FineGrainedConflicts(..)) +import Distribution.Types.VersionRange (anyVersion) + +-- | This function takes the variable we're currently considering, a +-- last conflict set and a list of children's logs. Each log yields +-- either a solution or a conflict set. The result is a combined log for +-- the parent node that has explored a prefix of the children. +-- +-- We can stop traversing the children's logs if we find an individual +-- conflict set that does not contain the current variable. In this +-- case, we can just lift the conflict set to the current level, +-- because the current level cannot possibly have contributed to this +-- conflict, so no other choice at the current level would avoid the +-- conflict. +-- +-- If any of the children might contain a successful solution, we can +-- return it immediately. If all children contain conflict sets, we can +-- take the union as the combined conflict set. +-- +-- The last conflict set corresponds to the justification that we +-- have to choose this goal at all. There is a reason why we have +-- introduced the goal in the first place, and this reason is in conflict +-- with the (virtual) option not to choose anything for the current +-- variable. See also the comments for 'avoidSet'. +-- +-- We can also skip a child if it does not resolve any of the conflicts paired +-- with the current variable in the previous child's conflict set. 'backjump' +-- takes a function to determine whether a child can be skipped. If the child +-- can be skipped, the function returns a new conflict set to be merged with the +-- previous conflict set. +-- +backjump :: forall w k a . Maybe Int + -> EnableBackjumping + -> FineGrainedConflicts + + -> (k -> S.Set CS.Conflict -> Maybe ConflictSet) + -- ^ Function that determines whether the given choice could resolve + -- the given conflict. It indicates false by returning 'Just', + -- with the new conflicts to be added to the conflict set. + + -> (k -> ConflictSet -> ExploreState -> ConflictSetLog a) + -- ^ Function that logs the given choice that was skipped. + + -> Var QPN -- ^ The current variable. + + -> ConflictSet -- ^ Conflict set representing the reason that the goal + -- was introduced. + + -> W.WeightedPSQ w k (ExploreState -> ConflictSetLog a) + -- ^ List of children's logs. + + -> ExploreState -> ConflictSetLog a +backjump mbj enableBj fineGrainedConflicts couldResolveConflicts + logSkippedChoice var lastCS xs = + foldr combine avoidGoal [(k, v) | (_, k, v) <- W.toList xs] CS.empty Nothing + where + combine :: (k, ExploreState -> ConflictSetLog a) + -> (ConflictSet -> Maybe ConflictSet -> ExploreState -> ConflictSetLog a) + -> ConflictSet -> Maybe ConflictSet -> ExploreState -> ConflictSetLog a + combine (k, x) f csAcc mPreviousCS es = + case (asBool fineGrainedConflicts, mPreviousCS) of + (True, Just previousCS) -> + case CS.lookup var previousCS of + Just conflicts -> + case couldResolveConflicts k conflicts of + Nothing -> retryNoSolution (x es) next + Just newConflicts -> skipChoice (previousCS `CS.union` newConflicts) + _ -> skipChoice previousCS + _ -> retryNoSolution (x es) next + where + next :: ConflictSet -> ExploreState -> ConflictSetLog a + next !cs es' = if asBool enableBj && not (var `CS.member` cs) + then skipLoggingBackjump cs es' + else f (csAcc `CS.union` cs) (Just cs) es' + + -- This function is for skipping the choice when it cannot resolve any + -- of the previous conflicts. + skipChoice :: ConflictSet -> ConflictSetLog a + skipChoice newCS = + retryNoSolution (logSkippedChoice k newCS es) $ \cs' es' -> + f (csAcc `CS.union` cs') (Just cs') $ + + -- Update the conflict map with the conflict set, to make up for + -- skipping the whole subtree. + es' { esConflictMap = updateCM cs' (esConflictMap es') } + + -- This function represents the option to not choose a value for this goal. + avoidGoal :: ConflictSet -> Maybe ConflictSet -> ExploreState -> ConflictSetLog a + avoidGoal cs _mPreviousCS !es = + logBackjump mbj (cs `CS.union` lastCS) $ + + -- Use 'lastCS' below instead of 'cs' since we do not want to + -- double-count the additionally accumulated conflicts. + es { esConflictMap = updateCM lastCS (esConflictMap es) } + + -- The solver does not count or log backjumps at levels where the conflict + -- set does not contain the current variable. Otherwise, there would be many + -- consecutive log messages about backjumping with the same conflict set. + skipLoggingBackjump :: ConflictSet -> ExploreState -> ConflictSetLog a + skipLoggingBackjump cs es = fromProgress $ P.Fail (NoSolution cs es) + +-- | Creates a failing ConflictSetLog representing a backjump. It inserts a +-- "backjumping" message, checks whether the backjump limit has been reached, +-- and increments the backjump count. +logBackjump :: Maybe Int -> ConflictSet -> ExploreState -> ConflictSetLog a +logBackjump mbj cs es = + failWith (Failure cs Backjump) $ + if reachedBjLimit (esBackjumps es) + then BackjumpLimit + else NoSolution cs es { esBackjumps = esBackjumps es + 1 } + where + reachedBjLimit = case mbj of + Nothing -> const False + Just limit -> (>= limit) + +-- | Like 'retry', except that it only applies the input function when the +-- backjump limit has not been reached. +retryNoSolution :: ConflictSetLog a + -> (ConflictSet -> ExploreState -> ConflictSetLog a) + -> ConflictSetLog a +retryNoSolution lg f = retry lg $ \case + BackjumpLimit -> fromProgress (P.Fail BackjumpLimit) + NoSolution cs es -> f cs es + +-- | The state that is read and written while exploring the search tree. +data ExploreState = ES { + esConflictMap :: !ConflictMap + , esBackjumps :: !Int + } + +data IntermediateFailure = + NoSolution ConflictSet ExploreState + | BackjumpLimit + +type ConflictSetLog = RetryLog Message IntermediateFailure + +getBestGoal :: ConflictMap -> P.PSQ (Goal QPN) a -> (Goal QPN, a) +getBestGoal cm = + P.maximumBy + ( flip (M.findWithDefault 0) cm + . (\ (Goal v _) -> v) + ) + +getFirstGoal :: P.PSQ (Goal QPN) a -> (Goal QPN, a) +getFirstGoal ts = + P.casePSQ ts + (error "getFirstGoal: empty goal choice") -- empty goal choice is an internal error + (\ k v _xs -> (k, v)) -- commit to the first goal choice + +updateCM :: ConflictSet -> ConflictMap -> ConflictMap +updateCM cs cm = + L.foldl' (\ cmc k -> M.insertWith (+) k 1 cmc) cm (CS.toList cs) + +-- | Record complete assignments on 'Done' nodes. +assign :: Tree d c -> Tree Assignment c +assign tree = go tree (A M.empty M.empty M.empty) + where + go :: Tree d c -> Assignment -> Tree Assignment c + go (Fail c fr) _ = Fail c fr + go (Done rdm _) a = Done rdm a + go (PChoice qpn rdm y ts) (A pa fa sa) = PChoice qpn rdm y $ W.mapWithKey f (fmap go ts) + where f (POption k _) r = r (A (M.insert qpn k pa) fa sa) + go (FChoice qfn rdm y t m d ts) (A pa fa sa) = FChoice qfn rdm y t m d $ W.mapWithKey f (fmap go ts) + 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) + +-- | A tree traversal that simultaneously propagates conflict sets up +-- the tree from the leaves and creates a log. +exploreLog :: Maybe Int + -> EnableBackjumping + -> FineGrainedConflicts + -> CountConflicts + -> Index + -> Tree Assignment QGoalReason + -> ConflictSetLog (Assignment, RevDepMap) +exploreLog mbj enableBj fineGrainedConflicts (CountConflicts countConflicts) idx t = + para go t initES + where + getBestGoal' :: P.PSQ (Goal QPN) a -> ConflictMap -> (Goal QPN, a) + getBestGoal' + | asBool countConflicts = \ ts cm -> getBestGoal cm ts + | otherwise = \ ts _ -> getFirstGoal ts + + go :: TreeF Assignment QGoalReason + (ExploreState -> ConflictSetLog (Assignment, RevDepMap), Tree Assignment QGoalReason) + -> (ExploreState -> ConflictSetLog (Assignment, RevDepMap)) + go (FailF c fr) = \ !es -> + let es' = es { esConflictMap = updateCM c (esConflictMap es) } + in failWith (Failure c fr) (NoSolution c es') + go (DoneF rdm a) = \ _ -> succeedWith Success (a, rdm) + go (PChoiceF qpn _ gr ts) = + backjump mbj enableBj fineGrainedConflicts + (couldResolveConflicts qpn) + (logSkippedPackage qpn) + (P qpn) (avoidSet (P qpn) gr) $ -- try children in order, + W.mapWithKey -- when descending ... + (\ k r es -> tryWith (TryP qpn k) (r es)) + (fmap fst ts) + go (FChoiceF qfn _ gr _ _ _ ts) = + backjump mbj enableBj fineGrainedConflicts + (\_ _ -> Nothing) + (const logSkippedChoiceSimple) + (F qfn) (avoidSet (F qfn) gr) $ -- try children in order, + W.mapWithKey -- when descending ... + (\ k r es -> tryWith (TryF qfn k) (r es)) + (fmap fst ts) + go (SChoiceF qsn _ gr _ ts) = + backjump mbj enableBj fineGrainedConflicts + (\_ _ -> Nothing) + (const logSkippedChoiceSimple) + (S qsn) (avoidSet (S qsn) gr) $ -- try children in order, + W.mapWithKey -- when descending ... + (\ k r es -> tryWith (TryS qsn k) (r es)) + (fmap fst ts) + go (GoalChoiceF _ ts) = \ es -> + let (k, (v, tree)) = getBestGoal' ts (esConflictMap es) + in continueWith (Next k) $ + -- Goal choice nodes are normally not counted as backjumps, since the + -- solver always explores exactly one choice, which means that the + -- backjump from the goal choice would be redundant with the backjump + -- from the PChoice, FChoice, or SChoice below. The one case where the + -- backjump is not redundant is when the chosen goal is a failure node, + -- so we log a backjump in that case. + case tree of + Fail _ _ -> retryNoSolution (v es) $ logBackjump mbj + _ -> v es + + initES = ES { + esConflictMap = M.empty + , esBackjumps = 0 + } + + -- Is it possible for this package instance (QPN and POption) to resolve any + -- of the conflicts that were caused by the previous instance? The default + -- is true, because it is always safe to explore a package instance. + -- 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 = + let (PInfo deps _ _ _) = idx M.! pn M.! i + qdeps = qualifyDeps (defaultQualifyOptions idx) currentQPN deps + + couldBeResolved :: CS.Conflict -> Maybe ConflictSet + couldBeResolved CS.OtherConflict = Nothing + couldBeResolved (CS.GoalConflict conflictingDep) = + -- Check whether this package instance also has 'conflictingDep' + -- as a dependency (ignoring flag and stanza choices). + if null [() | Simple (LDep _ (Dep (PkgComponent qpn _) _)) _ <- qdeps, qpn == conflictingDep] + then Nothing + else Just CS.empty + couldBeResolved (CS.VersionConstraintConflict dep excludedVersion) = + -- Check whether this package instance also excludes version + -- 'excludedVersion' of 'dep' (ignoring flag and stanza choices). + let vrs = [vr | Simple (LDep _ (Dep (PkgComponent qpn _) (Constrained vr))) _ <- qdeps, qpn == dep ] + vrIntersection = L.foldl' (.&&.) anyVersion vrs + in if checkVR vrIntersection excludedVersion + then Nothing + else -- If we skip this package instance, we need to update the + -- conflict set to say that 'dep' was also excluded by + -- this package instance's constraint. + Just $ CS.singletonWithConflict (P dep) $ + CS.VersionConflict currentQPN (CS.OrderedVersionRange vrIntersection) + couldBeResolved (CS.VersionConflict reverseDep (CS.OrderedVersionRange excludingVR)) = + -- Check whether this package instance's version is also excluded + -- by 'excludingVR'. + if checkVR excludingVR v + then Nothing + else -- If we skip this version, we need to update the conflict + -- set to say that the reverse dependency also excluded this + -- version. + Just $ CS.singletonWithConflict (P reverseDep) (CS.VersionConstraintConflict currentQPN v) + in fmap CS.unions $ traverse couldBeResolved (S.toList conflicts) + + logSkippedPackage :: QPN -> POption -> ConflictSet -> ExploreState -> ConflictSetLog a + logSkippedPackage qpn pOption cs es = + tryWith (TryP qpn pOption) $ + failWith (Skip (fromMaybe S.empty $ CS.lookup (P qpn) cs)) $ + NoSolution cs es + + -- This function is used for flag and stanza choices, but it should not be + -- called, because there is currently no way to skip a value for a flag or + -- stanza. + logSkippedChoiceSimple :: ConflictSet -> ExploreState -> ConflictSetLog a + logSkippedChoiceSimple cs es = fromProgress $ P.Fail $ NoSolution cs es + +-- | Build a conflict set corresponding to the (virtual) option not to +-- choose a solution for a goal at all. +-- +-- In the solver, the set of goals is not statically determined, but depends +-- on the choices we make. Therefore, when dealing with conflict sets, we +-- always have to consider that we could perhaps make choices that would +-- avoid the existence of the goal completely. +-- +-- Whenever we actually introduce a choice in the tree, we have already established +-- that the goal cannot be avoided. This is tracked in the "goal reason". +-- The choice to avoid the goal therefore is a conflict between the goal itself +-- and its goal reason. We build this set here, and pass it to the 'backjump' +-- function as the last conflict set. +-- +-- This has two effects: +-- +-- - In a situation where there are no choices available at all (this happens +-- if an unknown package is requested), the last conflict set becomes the +-- actual conflict set. +-- +-- - In a situation where all of the children's conflict sets contain the +-- current variable, the goal reason of the current node will be added to the +-- conflict set. +-- +avoidSet :: Var QPN -> QGoalReason -> ConflictSet +avoidSet var@(P qpn) gr = + CS.union (CS.singleton var) (goalReasonToConflictSetWithConflict qpn gr) +avoidSet var gr = + CS.union (CS.singleton var) (goalReasonToConflictSet gr) + +-- | Interface. +-- +-- Takes as an argument a limit on allowed backjumps. If the limit is 'Nothing', +-- then infinitely many backjumps are allowed. If the limit is 'Just 0', +-- backtracking is completely disabled. +backjumpAndExplore :: Maybe Int + -> EnableBackjumping + -> FineGrainedConflicts + -> CountConflicts + -> Index + -> Tree d QGoalReason + -> RetryLog Message SolverFailure (Assignment, RevDepMap) +backjumpAndExplore mbj enableBj fineGrainedConflicts countConflicts idx = + mapFailure convertFailure + . exploreLog mbj enableBj fineGrainedConflicts countConflicts idx + . assign + where + convertFailure (NoSolution cs es) = ExhaustiveSearch cs (esConflictMap es) + convertFailure BackjumpLimit = BackjumpLimitReached diff --git a/cabal/cabal-install-solver/src/Distribution/Solver/Modular/Flag.hs b/cabal/cabal-install-solver/src/Distribution/Solver/Modular/Flag.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/src/Distribution/Solver/Modular/Flag.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE DeriveFunctor #-} +module Distribution.Solver.Modular.Flag + ( FInfo(..) + , Flag + , FlagInfo + , FN(..) + , QFN + , QSN + , Stanza + , SN(..) + , WeakOrTrivial(..) + , FlagValue(..) + , mkFlag + , showQFN + , showQFNBool + , showFlagValue + , showQSN + , showQSNBool + , showSBool + ) where + +import Data.Map as M +import Prelude hiding (pi) + +import qualified Distribution.PackageDescription as P -- from Cabal + +import Distribution.Solver.Types.Flag +import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.PackagePath + +-- | Flag name. Consists of a package instance and the flag identifier itself. +data FN qpn = FN qpn Flag + deriving (Eq, Ord, Show, Functor) + +-- | Flag identifier. Just a string. +type Flag = P.FlagName + +-- | Stanza identifier. +type Stanza = OptionalStanza + +unFlag :: Flag -> String +unFlag = P.unFlagName + +mkFlag :: String -> Flag +mkFlag = P.mkFlagName + +-- | Flag info. Default value, whether the flag is manual, and +-- whether the flag is weak. Manual flags can only be set explicitly. +-- Weak flags are typically deferred by the solver. +data FInfo = FInfo { fdefault :: Bool, fmanual :: FlagType, fweak :: WeakOrTrivial } + deriving (Eq, Show) + +-- | Flag defaults. +type FlagInfo = Map Flag FInfo + +-- | Qualified flag name. +type QFN = FN QPN + +-- | Stanza name. Paired with a package name, much like a flag. +data SN qpn = SN qpn Stanza + deriving (Eq, Ord, Show, Functor) + +-- | Qualified stanza name. +type QSN = SN QPN + +-- | A property of flag and stanza choices that determines whether the +-- choice should be deferred in the solving process. +-- +-- A choice is called weak if we do want to defer it. This is the +-- case for flags that should be implied by what's currently installed on +-- the system, as opposed to flags that are used to explicitly enable or +-- disable some functionality. +-- +-- A choice is called trivial if it clearly does not matter. The +-- special case of triviality we actually consider is if there are no new +-- dependencies introduced by the choice. +newtype WeakOrTrivial = WeakOrTrivial { unWeakOrTrivial :: Bool } + deriving (Eq, Ord, Show) + +-- | Value shown for a flag in a solver log message. The message can refer to +-- only the true choice, only the false choice, or both choices. +data FlagValue = FlagTrue | FlagFalse | FlagBoth + deriving (Eq, Show) + +showQFNBool :: QFN -> Bool -> String +showQFNBool qfn@(FN qpn _f) b = showQPN qpn ++ ":" ++ showFBool qfn b + +showQSNBool :: QSN -> Bool -> String +showQSNBool (SN qpn s) b = showQPN qpn ++ ":" ++ showSBool s b + +showFBool :: FN qpn -> Bool -> String +showFBool (FN _ f) v = P.showFlagValue (f, v) + +-- | String representation of a flag-value pair. +showFlagValue :: P.FlagName -> FlagValue -> String +showFlagValue f FlagTrue = '+' : unFlag f +showFlagValue f FlagFalse = '-' : unFlag f +showFlagValue f FlagBoth = "+/-" ++ unFlag f + +showSBool :: Stanza -> Bool -> String +showSBool s True = "*" ++ showStanza s +showSBool s False = "!" ++ showStanza s + +showQFN :: QFN -> String +showQFN (FN qpn f) = showQPN qpn ++ ":" ++ unFlag f + +showQSN :: QSN -> String +showQSN (SN qpn s) = showQPN qpn ++ ":" ++ showStanza s diff --git a/cabal/cabal-install-solver/src/Distribution/Solver/Modular/Index.hs b/cabal/cabal-install-solver/src/Distribution/Solver/Modular/Index.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/src/Distribution/Solver/Modular/Index.hs @@ -0,0 +1,74 @@ +module Distribution.Solver.Modular.Index + ( Index + , PInfo(..) + , ComponentInfo(..) + , IsVisible(..) + , IsBuildable(..) + , defaultQualifyOptions + , mkIndex + ) where + +import Prelude hiding (pi) + +import Data.Map (Map) +import qualified Data.List as L +import qualified Data.Map as M + +import Distribution.Solver.Modular.Dependency +import Distribution.Solver.Modular.Flag +import Distribution.Solver.Modular.Package +import Distribution.Solver.Modular.Tree + +-- | An index contains information about package instances. This is a nested +-- dictionary. Package names are mapped to instances, which in turn is mapped +-- to info. +type Index = Map PN (Map I PInfo) + +-- | Info associated with a package instance. +-- Currently, dependencies, component names, flags and failure reasons. +-- The component map records whether any components are unbuildable in the +-- current environment (compiler, os, arch, and global flag constraints). +-- Packages that have a failure reason recorded for them are disabled +-- 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) + +-- | Info associated with each library and executable in a package instance. +data ComponentInfo = ComponentInfo { + compIsVisible :: IsVisible + , compIsBuildable :: IsBuildable + } + deriving Show + +-- | Whether a component is visible in the current environment. +newtype IsVisible = IsVisible Bool + deriving (Eq, Show) + +-- | Whether a component is made unbuildable by a "buildable: False" field. +newtype IsBuildable = IsBuildable Bool + deriving (Eq, Show) + +mkIndex :: [(PN, I, PInfo)] -> Index +mkIndex xs = M.map M.fromList (groupMap (L.map (\ (pn, i, pi) -> (pn, (i, pi))) xs)) + +groupMap :: Ord a => [(a, b)] -> Map a [b] +groupMap xs = M.fromListWith (flip (++)) (L.map (\ (x, y) -> (x, [y])) xs) + +defaultQualifyOptions :: Index -> QualifyOptions +defaultQualifyOptions idx = QO { + qoBaseShim = or [ dep == base + | -- 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 + -- .. and flatten all their dependencies .. + , (LDep _ (Dep (PkgComponent dep _) _ci), _comp) <- flattenFlaggedDeps deps + ] + , qoSetupIndependent = True + } + where + base = mkPackageName "base" diff --git a/cabal/cabal-install-solver/src/Distribution/Solver/Modular/IndexConversion.hs b/cabal/cabal-install-solver/src/Distribution/Solver/Modular/IndexConversion.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/src/Distribution/Solver/Modular/IndexConversion.hs @@ -0,0 +1,562 @@ +module Distribution.Solver.Modular.IndexConversion + ( convPIs + ) where + +import Distribution.Solver.Compat.Prelude +import Prelude () + +import qualified Data.List as L +import qualified Data.Map.Strict as M +import qualified Distribution.Compat.NonEmptySet as NonEmptySet +import qualified Data.Set as S + +import qualified Distribution.InstalledPackageInfo as IPI +import Distribution.Compiler +import Distribution.Package -- from Cabal +import Distribution.Simple.BuildToolDepends -- from Cabal +import Distribution.Types.ExeDependency -- from Cabal +import Distribution.Types.PkgconfigDependency -- from Cabal +import Distribution.Types.ComponentName -- from Cabal +import Distribution.Types.CondTree -- from Cabal +import Distribution.Types.MungedPackageId -- from Cabal +import Distribution.Types.MungedPackageName -- from Cabal +import Distribution.PackageDescription -- from Cabal +import Distribution.PackageDescription.Configuration +import qualified Distribution.Simple.PackageIndex as SI +import Distribution.System + +import Distribution.Solver.Types.ComponentDeps + ( Component(..), componentNameToComponent ) +import Distribution.Solver.Types.Flag +import Distribution.Solver.Types.LabeledPackageConstraint +import Distribution.Solver.Types.OptionalStanza +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.Modular.Dependency as D +import Distribution.Solver.Modular.Flag as F +import Distribution.Solver.Modular.Index +import Distribution.Solver.Modular.Package +import Distribution.Solver.Modular.Tree +import Distribution.Solver.Modular.Version + +-- | Convert both the installed package index and the source package +-- index into one uniform solver index. +-- +-- We use 'allPackagesBySourcePackageId' for the installed package index +-- because that returns us several instances of the same package and version +-- in order of preference. This allows us in principle to \"shadow\" +-- packages if there are several installed packages of the same version. +-- There are currently some shortcomings in both GHC and Cabal in +-- 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 = + mkIndex $ + convIPI' sip iidx ++ convSPI' os arch comp 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 = + -- apply shadowing whenever there are multiple installed packages with + -- the same version + [ maybeShadow (convIP idx pkg) + -- IMPORTANT to get internal libraries. See + -- Note [Index conversion with internal libraries] + | (_, pkgs) <- SI.allPackagesBySourcePackageIdAndLibName idx + , (maybeShadow, pkg) <- zip (id : repeat shadow) pkgs ] + where + + -- shadowing is recorded in the package info + shadow (pn, i, PInfo fdeps comps fds _) + | sip = (pn, i, PInfo fdeps comps fds (Just Shadowed)) + 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) + 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 + Left u -> (pn, i, PInfo [] M.empty M.empty (Just (Broken u))) + Right fds -> (pn, i, PInfo fds components M.empty Nothing) + where + -- TODO: Handle sub-libraries and visibility. + components = + M.singleton (ExposedLib LMainLibName) + ComponentInfo { + compIsVisible = IsVisible True + , compIsBuildable = IsBuildable True + } + + (pn, i) = convId ipi + + -- 'sourceLibName' is unreliable, but for now we only really use this for + -- primary libs anyways + comp = componentNameToComponent $ CLibName $ IPI.sourceLibName ipi +-- TODO: Installed packages should also store their encapsulations! + +-- Note [Index conversion with internal libraries] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Something very interesting happens when we have internal libraries +-- in our index. In this case, we maybe have p-0.1, which itself +-- depends on the internal library p-internal ALSO from p-0.1. +-- Here's the danger: +-- +-- - If we treat both of these packages as having PN "p", +-- then the solver will try to pick one or the other, +-- but never both. +-- +-- - If we drop the internal packages, now p-0.1 has a +-- dangling dependency on an "installed" package we know +-- nothing about. Oops. +-- +-- An expedient hack is to put p-internal into cabal-install's +-- index as a MUNGED package name, so that it doesn't conflict +-- with anyone else (except other instances of itself). But +-- yet, we ought NOT to say that PNs in the solver are munged +-- package names, because they're not; for source packages, +-- we really will never see munged package names. +-- +-- The tension here is that the installed package index is actually +-- per library, but the solver is per package. We need to smooth +-- it over, and munging the package names is a pretty good way to +-- do it. + +-- | Convert dependencies specified by an installed package id into +-- flagged dependencies of the solver. +-- +-- 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 = + case SI.lookupUnitId idx ipid of + Nothing -> Left ipid + Just ipi -> let (pn, i) = convId 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 + +-- | Convert a single source package into the solver-specific format. +convSP :: 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 + pkgConstraints = fromMaybe [] $ M.lookup pn constraints + in (pn, i, convGPD 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] + -> StrongFlags -> SolveExecutables -> PN -> GenericPackageDescription + -> PInfo +convGPD 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 + conv comp getInfo dr = + convCondTree M.empty dr pkg os arch cinfo pn fds comp getInfo solveExes . + addBuildableCondition getInfo + + initDR = DependencyReason pn M.empty S.empty + + flagged_deps + = concatMap (\ds -> conv ComponentLib libBuildInfo initDR ds) (maybeToList mlib) + ++ concatMap (\(nm, ds) -> conv (ComponentSubLib nm) libBuildInfo initDR ds) sub_libs + ++ concatMap (\(nm, ds) -> conv (ComponentFLib nm) foreignLibBuildInfo initDR ds) flibs + ++ concatMap (\(nm, ds) -> conv (ComponentExe nm) buildInfo initDR ds) exes + ++ prefix (Stanza (SN pn TestStanzas)) + (L.map (\(nm, ds) -> conv (ComponentTest nm) testBuildInfo (addStanza TestStanzas initDR) ds) + tests) + ++ prefix (Stanza (SN pn BenchStanzas)) + (L.map (\(nm, ds) -> conv (ComponentBench nm) benchmarkBuildInfo (addStanza BenchStanzas initDR) ds) + benchs) + ++ maybe [] (convSetupBuildInfo pn) (setupBuildInfo pkg) + + addStanza :: Stanza -> DependencyReason pn -> DependencyReason pn + addStanza s (DependencyReason pn' fs ss) = DependencyReason pn' fs (S.insert s ss) + + -- | A too-new specVersion is turned into a global 'FailReason' + -- which prevents the solver from selecting this release (and if + -- forced to, emit a meaningful solver error message). + fr = case scannedVersion of + Just ver -> Just (UnsupportedSpecVer ver) + Nothing -> Nothing + + components :: Map ExposedComponent ComponentInfo + components = M.fromList $ libComps ++ subLibComps ++ exeComps + where + libComps = [ (ExposedLib LMainLibName, libToComponentInfo lib) + | lib <- maybeToList mlib ] + subLibComps = [ (ExposedLib (LSubLibName name), libToComponentInfo lib) + | (name, lib) <- sub_libs ] + exeComps = [ ( ExposedExe name + , ComponentInfo { + compIsVisible = IsVisible True + , compIsBuildable = IsBuildable $ testCondition (buildable . buildInfo) exe /= Just False + } + ) + | (name, exe) <- exes ] + + libToComponentInfo lib = + ComponentInfo { + compIsVisible = IsVisible $ testCondition (isPrivate . libVisibility) lib /= Just True + , compIsBuildable = IsBuildable $ testCondition (buildable . libBuildInfo) lib /= Just False + } + + testCondition = testConditionForComponent os arch cinfo constraints + + isPrivate LibraryVisibilityPrivate = True + isPrivate LibraryVisibilityPublic = False + + in PInfo flagged_deps components fds fr + +-- | Applies the given predicate (for example, testing buildability or +-- visibility) to the given component and environment. Values are combined with +-- AND. This function returns 'Nothing' when the result cannot be determined +-- 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 + -> Arch + -> CompilerInfo + -> [LabeledPackageConstraint] + -> (a -> Bool) + -> CondTree ConfVar [Dependency] a + -> Maybe Bool +testConditionForComponent os arch cinfo constraints p tree = + case go $ extractCondition p tree of + Lit True -> Just True + Lit False -> Just False + _ -> Nothing + where + flagAssignment :: [(FlagName, Bool)] + flagAssignment = + mconcat [ unFlagAssignment fa + | PackageConstraint (ScopeAnyQualifier _) (PackagePropertyFlags fa) + <- L.map unlabelPackageConstraint constraints] + + -- Simplify the condition, using the current environment. Most of this + -- function was copied from convBranch and + -- Distribution.Types.Condition.simplifyCondition. + go :: Condition ConfVar -> Condition ConfVar + go (Var (OS os')) = Lit (os == os') + go (Var (Arch arch')) = Lit (arch == arch') + go (Var (Impl cf cvr)) + | matchImpl (compilerInfoId cinfo) || + -- fixme: Nothing should be treated as unknown, rather than empty + -- list. This code should eventually be changed to either + -- support partial resolution of compiler flags or to + -- complain about incompletely configured compilers. + any matchImpl (fromMaybe [] $ compilerInfoCompat cinfo) = Lit True + | otherwise = Lit False + where + matchImpl (CompilerId cf' cv) = cf == cf' && checkVR cvr cv + go (Var (PackageFlag f)) + | Just b <- L.lookup f flagAssignment = Lit b + go (Var v) = Var v + go (Lit b) = Lit b + go (CNot c) = + case go c of + Lit True -> Lit False + Lit False -> Lit True + c' -> CNot c' + go (COr c d) = + case (go c, go d) of + (Lit False, d') -> d' + (Lit True, _) -> Lit True + (c', Lit False) -> c' + (_, Lit True) -> Lit True + (c', d') -> COr c' d' + go (CAnd c d) = + case (go c, go d) of + (Lit False, _) -> Lit False + (Lit True, d') -> d' + (_, Lit False) -> Lit False + (c', Lit True) -> c' + (c', d') -> CAnd c' d' + +-- | Create a flagged dependency tree from a list @fds@ of flagged +-- dependencies, using @f@ to form the tree node (@f@ will be +-- something like @Stanza sn@). +prefix :: (FlaggedDeps qpn -> FlaggedDep qpn) + -> [FlaggedDeps qpn] -> FlaggedDeps qpn +prefix _ [] = [] +prefix f fds = [f (concat fds)] + +-- | Convert flag information. Automatic flags are now considered weak +-- unless strong flags have been selected explicitly. +flagInfo :: StrongFlags -> [PackageFlag] -> FlagInfo +flagInfo (StrongFlags strfl) = + M.fromList . L.map (\ (MkPackageFlag fn _ b m) -> (fn, FInfo b (flagType m) (weak m))) + where + weak m = WeakOrTrivial $ not (strfl || m) + flagType m = if m then Manual else Automatic + +-- | Convert condition trees to flagged dependencies. Mutually +-- recursive with 'convBranch'. See 'convBranch' for an explanation +-- of all arguments preceding the input 'CondTree'. +convCondTree :: Map FlagName Bool -> DependencyReason PN -> PackageDescription -> OS -> Arch -> CompilerInfo -> PN -> FlagInfo -> + 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) = + -- 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 + -- duplicates could grow exponentially from the leaves to the root + -- of the tree. + mergeSimpleDeps $ + [ D.Simple singleDep comp + | dep <- ds + , singleDep <- convLibDeps dr dep ] -- unconditional package dependencies + + ++ L.map (\e -> D.Simple (LDep dr (Ext e)) comp) (allExtensions bi) -- unconditional extension dependencies + ++ L.map (\l -> D.Simple (LDep dr (Lang l)) comp) (allLanguages bi) -- unconditional language dependencies + ++ L.map (\(PkgconfigDependency pkn vr) -> D.Simple (LDep dr (Pkg pkn vr)) comp) (pkgconfigDepends bi) -- unconditional pkg-config dependencies + ++ concatMap (convBranch flags dr pkg os arch cinfo pn fds comp getInfo solveExes) branches + -- build-tools dependencies + -- NB: Only include these dependencies if SolveExecutables + -- is True. It might be false in the legacy solver + -- codepath, in which case there won't be any record of + -- an executable we need. + ++ [ D.Simple (convExeDep dr exeDep) comp + | solveExes' + , exeDep <- getAllToolDependencies pkg bi + , not $ isInternal pkg exeDep + ] + where + bi = getInfo info + +data SimpleFlaggedDepKey qpn = + SimpleFlaggedDepKey (PkgComponent qpn) Component + deriving (Eq, Ord) + +data SimpleFlaggedDepValue qpn = SimpleFlaggedDepValue (DependencyReason qpn) VR + +-- | Merge 'Simple' dependencies that apply to the same library or build-tool. +-- This function should be able to merge any two dependencies that can be merged +-- by extractCommon, in order to prevent the exponential growth of dependencies. +-- +-- Note that this function can merge dependencies that have different +-- DependencyReasons, which can make the DependencyReasons less precise. This +-- loss of precision only affects performance and log messages, not correctness. +-- However, when 'mergeSimpleDeps' is only called on dependencies at a single +-- location in the dependency tree, the only difference between +-- DependencyReasons should be flags that have value FlagBoth. Adding extra +-- flags with value FlagBoth should not affect performance, since they are not +-- added to the conflict set. The only downside is the possibility of the log +-- incorrectly saying that the flag contributed to excluding a specific version +-- of a dependency. For example, if +/-flagA introduces pkg >=2 and +/-flagB +-- introduces pkg <5, the merged dependency would mean that +-- +/-flagA and +/-flagB introduce pkg >=2 && <5, which would incorrectly imply +-- that +/-flagA excludes pkg-6. +mergeSimpleDeps :: Ord qpn => FlaggedDeps qpn -> FlaggedDeps qpn +mergeSimpleDeps deps = L.map (uncurry toFlaggedDep) (M.toList merged) ++ unmerged + where + (merged, unmerged) = L.foldl' f (M.empty, []) deps + where + f :: Ord qpn + => (Map (SimpleFlaggedDepKey qpn) (SimpleFlaggedDepValue qpn), FlaggedDeps qpn) + -> FlaggedDep qpn + -> (Map (SimpleFlaggedDepKey qpn) (SimpleFlaggedDepValue qpn), FlaggedDeps qpn) + f (merged', unmerged') (D.Simple (LDep dr (Dep dep (Constrained vr))) comp) = + ( M.insertWith mergeValues + (SimpleFlaggedDepKey dep comp) + (SimpleFlaggedDepValue dr vr) + merged' + , unmerged') + f (merged', unmerged') unmergeableDep = (merged', unmergeableDep : unmerged') + + mergeValues :: SimpleFlaggedDepValue qpn + -> SimpleFlaggedDepValue qpn + -> SimpleFlaggedDepValue qpn + mergeValues (SimpleFlaggedDepValue dr1 vr1) (SimpleFlaggedDepValue dr2 vr2) = + SimpleFlaggedDepValue (unionDRs dr1 dr2) (vr1 .&&. vr2) + + toFlaggedDep :: SimpleFlaggedDepKey qpn + -> SimpleFlaggedDepValue qpn + -> FlaggedDep qpn + toFlaggedDep (SimpleFlaggedDepKey dep comp) (SimpleFlaggedDepValue dr vr) = + D.Simple (LDep dr (Dep dep (Constrained vr))) comp + +-- | Branch interpreter. Mutually recursive with 'convCondTree'. +-- +-- Here, we try to simplify one of Cabal's condition tree branches into the +-- solver's flagged dependency format, which is weaker. Condition trees can +-- contain complex logical expression composed from flag choices and special +-- flags (such as architecture, or compiler flavour). We try to evaluate the +-- special flags and subsequently simplify to a tree that only depends on +-- simple flag choices. +-- +-- This function takes a number of arguments: +-- +-- 1. A map of flag values that have already been chosen. It allows +-- convBranch to avoid creating nested FlaggedDeps that are +-- controlled by the same flag and avoid creating DependencyReasons with +-- conflicting values for the same flag. +-- +-- 2. The DependencyReason calculated at this point in the tree of +-- conditionals. The flag values in the DependencyReason are similar to +-- the values in the map above, except for the use of FlagBoth. +-- +-- 3. Some pre dependency-solving known information ('OS', 'Arch', +-- 'CompilerInfo') for @os()@, @arch()@ and @impl()@ variables, +-- +-- 4. The package name @'PN'@ which this condition tree +-- came from, so that we can correctly associate @flag()@ +-- variables with the correct package name qualifier, +-- +-- 5. The flag defaults 'FlagInfo' so that we can populate +-- 'Flagged' dependencies with 'FInfo', +-- +-- 6. The name of the component 'Component' so we can record where +-- the fine-grained information about where the component came +-- from (see 'convCondTree'), and +-- +-- 7. A selector to extract the 'BuildInfo' from the leaves of +-- the 'CondTree' (which actually contains the needed +-- dependency information.) +-- +-- 8. The set of package names which should be considered internal +-- dependencies, and thus not handled as dependencies. +convBranch :: Map FlagName Bool + -> DependencyReason PN + -> PackageDescription + -> OS + -> Arch + -> CompilerInfo + -> PN + -> FlagInfo + -> Component + -> (a -> BuildInfo) + -> SolveExecutables + -> CondBranch ConfVar [Dependency] a + -> FlaggedDeps PN +convBranch flags dr pkg os arch cinfo pn fds comp getInfo solveExes (CondBranch c' t' mf') = + go c' + (\flags' dr' -> convCondTree flags' dr' pkg os arch cinfo pn fds comp getInfo solveExes t') + (\flags' dr' -> maybe [] (convCondTree flags' dr' pkg os arch cinfo pn fds comp getInfo solveExes) mf') + flags dr + where + go :: Condition ConfVar + -> (Map FlagName Bool -> DependencyReason PN -> FlaggedDeps PN) + -> (Map FlagName Bool -> DependencyReason PN -> FlaggedDeps PN) + -> Map FlagName Bool -> DependencyReason PN -> FlaggedDeps PN + go (Lit True) t _ = t + go (Lit False) _ f = f + go (CNot c) t f = go c f t + go (CAnd c d) t f = go c (go d t f) f + go (COr c d) t f = go c t (go d t f) + go (Var (PackageFlag fn)) t f = \flags' -> + case M.lookup fn flags' of + Just True -> t flags' + Just False -> f flags' + Nothing -> \dr' -> + -- Add each flag to the DependencyReason for all dependencies below, + -- including any extracted dependencies. Extracted dependencies are + -- introduced by both flag values (FlagBoth). Note that we don't + -- actually need to add the flag to the extracted dependencies for + -- correct backjumping; the information only improves log messages + -- by giving the user the full reason for each dependency. + let addFlagValue v = addFlagToDependencyReason fn v dr' + addFlag v = M.insert fn v flags' + in extractCommon (t (addFlag True) (addFlagValue FlagBoth)) + (f (addFlag False) (addFlagValue FlagBoth)) + ++ [ Flagged (FN pn fn) (fds M.! fn) (t (addFlag True) (addFlagValue FlagTrue)) + (f (addFlag False) (addFlagValue FlagFalse)) ] + go (Var (OS os')) t f + | os == os' = t + | otherwise = f + go (Var (Arch arch')) t f + | arch == arch' = t + | otherwise = f + go (Var (Impl cf cvr)) t f + | matchImpl (compilerInfoId cinfo) || + -- fixme: Nothing should be treated as unknown, rather than empty + -- list. This code should eventually be changed to either + -- support partial resolution of compiler flags or to + -- complain about incompletely configured compilers. + any matchImpl (fromMaybe [] $ compilerInfoCompat cinfo) = t + | otherwise = f + where + matchImpl (CompilerId cf' cv) = cf == cf' && checkVR cvr cv + + addFlagToDependencyReason :: FlagName -> FlagValue -> DependencyReason pn -> DependencyReason pn + addFlagToDependencyReason fn v (DependencyReason pn' fs ss) = + DependencyReason pn' (M.insert fn v fs) ss + + -- If both branches contain the same package as a simple dep, we lift it to + -- the next higher-level, but with the union of version ranges. This + -- heuristic together with deferring flag choices will then usually first + -- resolve this package, and try an already installed version before imposing + -- a default flag choice that might not be what we want. + -- + -- Note that we make assumptions here on the form of the dependencies that + -- can occur at this point. In particular, no occurrences of Fixed, as all + -- dependencies below this point have been generated using 'convLibDep'. + -- + -- WARNING: This is quadratic! + extractCommon :: Eq pn => FlaggedDeps pn -> FlaggedDeps pn -> FlaggedDeps pn + extractCommon ps ps' = + -- Union the DependencyReasons, because the extracted dependency can be + -- avoided by removing the dependency from either side of the + -- conditional. + [ D.Simple (LDep (unionDRs vs1 vs2) (Dep dep1 (Constrained $ vr1 .||. vr2))) comp + | D.Simple (LDep vs1 (Dep dep1 (Constrained vr1))) _ <- ps + , D.Simple (LDep vs2 (Dep dep2 (Constrained vr2))) _ <- ps' + , dep1 == dep2 + ] + +-- | Merge DependencyReasons by unioning their variables. +unionDRs :: DependencyReason pn -> DependencyReason pn -> DependencyReason pn +unionDRs (DependencyReason pn' fs1 ss1) (DependencyReason _ fs2 ss2) = + DependencyReason pn' (M.union fs1 fs2) (S.union ss1 ss2) + +-- | Convert a Cabal dependency on a set of library components (from a single +-- package) to solver-specific dependencies. +convLibDeps :: DependencyReason PN -> Dependency -> [LDep PN] +convLibDeps dr (Dependency pn vr libs) = + [ LDep dr $ Dep (PkgComponent pn (ExposedLib lib)) (Constrained vr) + | lib <- NonEmptySet.toList libs ] + +-- | Convert a Cabal dependency on an executable (build-tools) to a solver-specific dependency. +convExeDep :: DependencyReason PN -> ExeDependency -> LDep PN +convExeDep dr (ExeDependency pn exe vr) = LDep dr $ Dep (PkgComponent pn (ExposedExe exe)) (Constrained vr) + +-- | Convert setup dependencies +convSetupBuildInfo :: PN -> SetupBuildInfo -> FlaggedDeps PN +convSetupBuildInfo pn nfo = + [ D.Simple singleDep ComponentSetup + | dep <- setupDepends nfo + , singleDep <- convLibDeps (DependencyReason pn M.empty S.empty) dep ] diff --git a/cabal/cabal-install-solver/src/Distribution/Solver/Modular/LabeledGraph.hs b/cabal/cabal-install-solver/src/Distribution/Solver/Modular/LabeledGraph.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/src/Distribution/Solver/Modular/LabeledGraph.hs @@ -0,0 +1,117 @@ +-- | Wrapper around Data.Graph with support for edge labels +{-# LANGUAGE ScopedTypeVariables #-} +module Distribution.Solver.Modular.LabeledGraph ( + -- * Graphs + Graph + , Vertex + -- ** Building graphs + , graphFromEdges + , graphFromEdges' + , buildG + , transposeG + -- ** Graph properties + , vertices + , edges + -- ** Operations on the underlying unlabeled graph + , forgetLabels + , topSort + ) where + +import Distribution.Solver.Compat.Prelude +import Prelude () + +import Data.Array +import Data.Graph (Vertex, Bounds) +import qualified Data.Graph as G + +{------------------------------------------------------------------------------- + Types +-------------------------------------------------------------------------------} + +type Graph e = Array Vertex [(e, Vertex)] +type Edge e = (Vertex, e, Vertex) + +{------------------------------------------------------------------------------- + Building graphs +-------------------------------------------------------------------------------} + +-- | Construct an edge-labeled graph +-- +-- This is a simple adaptation of the definition in Data.Graph +graphFromEdges :: forall key node edge. Ord key + => [ (node, key, [(edge, key)]) ] + -> ( Graph edge + , Vertex -> (node, key, [(edge, key)]) + , key -> Maybe Vertex + ) +graphFromEdges edges0 = + (graph, \v -> vertex_map ! v, key_vertex) + where + max_v = length edges0 - 1 + bounds0 = (0, max_v) :: (Vertex, Vertex) + sorted_edges = sortBy lt edges0 + edges1 = zip [0..] sorted_edges + + graph = array bounds0 [(v, (mapMaybe mk_edge ks)) + | (v, (_, _, ks)) <- edges1] + key_map = array bounds0 [(v, k ) + | (v, (_, k, _ )) <- edges1] + vertex_map = array bounds0 edges1 + + (_,k1,_) `lt` (_,k2,_) = k1 `compare` k2 + + mk_edge :: (edge, key) -> Maybe (edge, Vertex) + mk_edge (edge, key) = do v <- key_vertex key ; return (edge, v) + + -- returns Nothing for non-interesting vertices + key_vertex :: key -> Maybe Vertex + key_vertex k = findVertex 0 max_v + where + findVertex a b + | a > b = Nothing + | otherwise = case compare k (key_map ! mid) of + LT -> findVertex a (mid-1) + EQ -> Just mid + GT -> findVertex (mid+1) b + where + mid = a + (b - a) `div` 2 + +graphFromEdges' :: Ord key + => [ (node, key, [(edge, key)]) ] + -> ( Graph edge + , Vertex -> (node, key, [(edge, key)]) + ) +graphFromEdges' x = (a,b) + where + (a,b,_) = graphFromEdges x + +transposeG :: Graph e -> Graph e +transposeG g = buildG (bounds g) (reverseE g) + +buildG :: Bounds -> [Edge e] -> Graph e +buildG bounds0 edges0 = accumArray (flip (:)) [] bounds0 (map reassoc edges0) + where + reassoc (v, e, w) = (v, (e, w)) + +reverseE :: Graph e -> [Edge e] +reverseE g = [ (w, e, v) | (v, e, w) <- edges g ] + +{------------------------------------------------------------------------------- + Graph properties +-------------------------------------------------------------------------------} + +vertices :: Graph e -> [Vertex] +vertices = indices + +edges :: Graph e -> [Edge e] +edges g = [ (v, e, w) | v <- vertices g, (e, w) <- g!v ] + +{------------------------------------------------------------------------------- + Operations on the underlying unlabelled graph +-------------------------------------------------------------------------------} + +forgetLabels :: Graph e -> G.Graph +forgetLabels = fmap (map snd) + +topSort :: Graph e -> [Vertex] +topSort = G.topSort . forgetLabels diff --git a/cabal/cabal-install-solver/src/Distribution/Solver/Modular/Linking.hs b/cabal/cabal-install-solver/src/Distribution/Solver/Modular/Linking.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/src/Distribution/Solver/Modular/Linking.hs @@ -0,0 +1,519 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- TODO: remove this +{-# OPTIONS -fno-warn-incomplete-uni-patterns #-} +module Distribution.Solver.Modular.Linking ( + validateLinking + ) where + +import Prelude () +import Distribution.Solver.Compat.Prelude hiding (get,put) + +import Control.Exception (assert) +import Control.Monad.Reader +import Control.Monad.State +import Data.Map ((!)) +import qualified Data.Map as M +import qualified Data.Set as S +import qualified Data.Traversable as T + +import Distribution.Client.Utils.Assertion +import Distribution.Solver.Modular.Assignment +import Distribution.Solver.Modular.Dependency +import Distribution.Solver.Modular.Flag +import Distribution.Solver.Modular.Index +import Distribution.Solver.Modular.Package +import Distribution.Solver.Modular.Tree +import qualified Distribution.Solver.Modular.ConflictSet as CS +import qualified Distribution.Solver.Modular.WeightedPSQ as W + +import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.PackagePath +import Distribution.Types.Flag (unFlagName) + +{------------------------------------------------------------------------------- + Validation + + Validation of links is a separate pass that's performed after normal + validation. Validation of links checks that if the tree indicates that a + package is linked, then everything underneath that choice really matches the + package we have linked to. + + This is interesting because it isn't unidirectional. Consider that we've + chosen a.foo to be version 1 and later decide that b.foo should link to a.foo. + Now foo depends on bar. Because a.foo and b.foo are linked, it's required that + a.bar and b.bar are also linked. However, it's not required that we actually + choose a.bar before b.bar. Goal choice order is relatively free. It's possible + that we choose a.bar first, but also possible that we choose b.bar first. In + both cases, we have to recognize that we have freedom of choice for the first + of the two, but no freedom of choice for the second. + + This is what LinkGroups are all about. Using LinkGroup, we can record (in the + situation above) that a.bar and b.bar need to be linked even if we haven't + chosen either of them yet. +-------------------------------------------------------------------------------} + +data ValidateState = VS { + vsIndex :: Index + , vsLinks :: Map QPN LinkGroup + , vsFlags :: FAssignment + , vsStanzas :: SAssignment + , vsQualifyOptions :: QualifyOptions + + -- Saved qualified dependencies. Every time 'validateLinking' makes a + -- package choice, it qualifies the package's dependencies and saves them in + -- this map. Then the qualified dependencies are available for subsequent + -- flag and stanza choices for the same package. + , vsSaved :: Map QPN (FlaggedDeps QPN) + } + +type Validate = Reader ValidateState + +-- | Validate linked packages +-- +-- Verify that linked packages have +-- +-- * Linked dependencies, +-- * Equal flag assignments +-- * Equal stanza assignments +validateLinking :: Index -> Tree d c -> Tree d c +validateLinking index = (`runReader` initVS) . go + where + go :: Tree d c -> Validate (Tree d c) + + go (PChoice qpn rdm gr cs) = + PChoice qpn rdm gr <$> (W.traverseWithKey (goP qpn) $ fmap go cs) + go (FChoice qfn rdm gr t m d cs) = + FChoice qfn rdm gr t m d <$> (W.traverseWithKey (goF qfn) $ fmap go cs) + go (SChoice qsn rdm gr t cs) = + SChoice qsn rdm gr t <$> (W.traverseWithKey (goS qsn) $ fmap go cs) + + -- For the other nodes we just recurse + go (GoalChoice rdm cs) = GoalChoice rdm <$> T.traverse go cs + go (Done revDepMap s) = return $ Done revDepMap s + go (Fail conflictSet failReason) = return $ Fail conflictSet failReason + + -- Package choices + goP :: QPN -> POption -> Validate (Tree d c) -> Validate (Tree d c) + 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 + newSaved = M.insert qpn qdeps (vsSaved vs) + case execUpdateState (pickPOption qpn opt qdeps) vs of + Left (cs, err) -> return $ Fail cs (DependenciesNotLinked err) + Right vs' -> local (const vs' { vsSaved = newSaved }) r + + -- Flag choices + goF :: QFN -> Bool -> Validate (Tree d c) -> Validate (Tree d c) + goF qfn b r = do + vs <- ask + case execUpdateState (pickFlag qfn b) vs of + Left (cs, err) -> return $ Fail cs (DependenciesNotLinked err) + Right vs' -> local (const vs') r + + -- Stanza choices (much the same as flag choices) + goS :: QSN -> Bool -> Validate (Tree d c) -> Validate (Tree d c) + goS qsn b r = do + vs <- ask + case execUpdateState (pickStanza qsn b) vs of + Left (cs, err) -> return $ Fail cs (DependenciesNotLinked err) + Right vs' -> local (const vs') r + + initVS :: ValidateState + initVS = VS { + vsIndex = index + , vsLinks = M.empty + , vsFlags = M.empty + , vsStanzas = M.empty + , vsQualifyOptions = defaultQualifyOptions index + , vsSaved = M.empty + } + +{------------------------------------------------------------------------------- + Updating the validation state +-------------------------------------------------------------------------------} + +type Conflict = (ConflictSet, String) + +newtype UpdateState a = UpdateState { + unUpdateState :: StateT ValidateState (Either Conflict) a + } + deriving (Functor, Applicative, Monad) + +instance MonadState ValidateState UpdateState where + get = UpdateState $ get + put st = UpdateState $ do + expensiveAssert (lgInvariant $ vsLinks st) $ return () + put st + +lift' :: Either Conflict a -> UpdateState a +lift' = UpdateState . lift + +conflict :: Conflict -> UpdateState a +conflict = lift' . Left + +execUpdateState :: UpdateState () -> ValidateState -> Either Conflict ValidateState +execUpdateState = execStateT . unUpdateState + +pickPOption :: QPN -> POption -> FlaggedDeps QPN -> UpdateState () +pickPOption qpn (POption i Nothing) _deps = pickConcrete qpn i +pickPOption qpn (POption i (Just pp')) deps = pickLink qpn i pp' deps + +pickConcrete :: QPN -> I -> UpdateState () +pickConcrete qpn@(Q pp _) i = do + vs <- get + case M.lookup qpn (vsLinks vs) of + -- Package is not yet in a LinkGroup. Create a new singleton link group. + Nothing -> do + let lg = lgSingleton qpn (Just $ PI pp i) + updateLinkGroup lg + + -- Package is already in a link group. Since we are picking a concrete + -- instance here, it must by definition be the canonical package. + Just lg -> + makeCanonical lg qpn i + +pickLink :: QPN -> I -> PackagePath -> FlaggedDeps QPN -> UpdateState () +pickLink qpn@(Q _pp pn) i pp' deps = do + vs <- get + + -- The package might already be in a link group + -- (because one of its reverse dependencies is) + let lgSource = case M.lookup qpn (vsLinks vs) of + Nothing -> lgSingleton qpn Nothing + Just lg -> lg + + -- Find the link group for the package we are linking to + -- + -- Since the builder never links to a package without having first picked a + -- concrete instance for that package, and since we create singleton link + -- groups for concrete instances, this link group must exist (and must + -- in fact already have a canonical member). + let target = Q pp' pn + lgTarget = vsLinks vs ! target + + -- Verify here that the member we add is in fact for the same package and + -- matches the version of the canonical instance. However, violations of + -- these checks would indicate a bug in the linker, not a true conflict. + let sanityCheck :: Maybe (PI PackagePath) -> Bool + sanityCheck Nothing = False + sanityCheck (Just (PI _ canonI)) = pn == lgPackage lgTarget && i == canonI + assert (sanityCheck (lgCanon lgTarget)) $ return () + + -- Merge the two link groups (updateLinkGroup will propagate the change) + lgTarget' <- lift' $ lgMerge CS.empty lgSource lgTarget + updateLinkGroup lgTarget' + + -- Make sure all dependencies are linked as well + linkDeps target deps + +makeCanonical :: LinkGroup -> QPN -> I -> UpdateState () +makeCanonical lg qpn@(Q pp _) i = + case lgCanon lg of + -- There is already a canonical member. Fail. + Just _ -> + conflict ( CS.insert (P qpn) (lgConflictSet lg) + , "cannot make " ++ showQPN qpn + ++ " canonical member of " ++ showLinkGroup lg + ) + Nothing -> do + let lg' = lg { lgCanon = Just (PI pp i) } + updateLinkGroup lg' + +-- | Link the dependencies of linked parents. +-- +-- When we decide to link one package against another we walk through the +-- package's direct dependencies and make sure that they're all linked to each +-- other by merging their link groups (or creating new singleton link groups if +-- they don't have link groups yet). We do not need to do this recursively, +-- because having the direct dependencies in a link group means that we must +-- have already made or will make sooner or later a link choice for one of these +-- as well, and cover their dependencies at that point. +linkDeps :: QPN -> FlaggedDeps QPN -> UpdateState () +linkDeps target = \deps -> do + -- linkDeps is called in two places: when we first link one package to + -- another, and when we discover more dependencies of an already linked + -- package after doing some flag assignment. It is therefore important that + -- flag assignments cannot influence _how_ dependencies are qualified; + -- fortunately this is a documented property of 'qualifyDeps'. + rdeps <- requalify deps + go deps rdeps + where + go :: FlaggedDeps QPN -> FlaggedDeps QPN -> UpdateState () + go = zipWithM_ go1 + + go1 :: FlaggedDep QPN -> FlaggedDep QPN -> UpdateState () + go1 dep rdep = case (dep, rdep) of + (Simple (LDep dr1 (Dep (PkgComponent qpn _) _)) _, ~(Simple (LDep dr2 (Dep (PkgComponent qpn' _) _)) _)) -> do + vs <- get + let lg = M.findWithDefault (lgSingleton qpn Nothing) qpn $ vsLinks vs + lg' = M.findWithDefault (lgSingleton qpn' Nothing) qpn' $ vsLinks vs + lg'' <- lift' $ lgMerge ((CS.union `on` dependencyReasonToConflictSet) dr1 dr2) lg lg' + updateLinkGroup lg'' + (Flagged fn _ t f, ~(Flagged _ _ t' f')) -> do + vs <- get + case M.lookup fn (vsFlags vs) of + Nothing -> return () -- flag assignment not yet known + Just True -> go t t' + Just False -> go f f' + (Stanza sn t, ~(Stanza _ t')) -> do + vs <- get + case M.lookup sn (vsStanzas vs) of + Nothing -> return () -- stanza assignment not yet known + Just True -> go t t' + Just False -> return () -- stanza not enabled; no new deps + -- For extensions and language dependencies, there is nothing to do. + -- No choice is involved, just checking, so there is nothing to link. + -- The same goes for pkg-config constraints. + (Simple (LDep _ (Ext _)) _, _) -> return () + (Simple (LDep _ (Lang _)) _, _) -> return () + (Simple (LDep _ (Pkg _ _)) _, _) -> return () + + requalify :: FlaggedDeps QPN -> UpdateState (FlaggedDeps QPN) + requalify deps = do + vs <- get + return $ qualifyDeps (vsQualifyOptions vs) target (unqualifyDeps deps) + +pickFlag :: QFN -> Bool -> UpdateState () +pickFlag qfn b = do + modify $ \vs -> vs { vsFlags = M.insert qfn b (vsFlags vs) } + verifyFlag qfn + linkNewDeps (F qfn) b + +pickStanza :: QSN -> Bool -> UpdateState () +pickStanza qsn b = do + modify $ \vs -> vs { vsStanzas = M.insert qsn b (vsStanzas vs) } + verifyStanza qsn + linkNewDeps (S qsn) b + +-- | Link dependencies that we discover after making a flag or stanza choice. +-- +-- When we make a flag choice for a package, then new dependencies for that +-- package might become available. If the package under consideration is in a +-- non-trivial link group, then these new dependencies have to be linked as +-- well. In linkNewDeps, we compute such new dependencies and make sure they are +-- linked. +linkNewDeps :: Var QPN -> Bool -> UpdateState () +linkNewDeps var b = do + vs <- get + let qpn@(Q pp pn) = varPN var + qdeps = vsSaved vs ! qpn + lg = vsLinks vs ! qpn + newDeps = findNewDeps vs qdeps + linkedTo = S.delete pp (lgMembers lg) + forM_ (S.toList linkedTo) $ \pp' -> linkDeps (Q pp' pn) newDeps + where + findNewDeps :: ValidateState -> FlaggedDeps QPN -> FlaggedDeps QPN + findNewDeps vs = concatMap (findNewDeps' vs) + + findNewDeps' :: ValidateState -> FlaggedDep QPN -> FlaggedDeps QPN + findNewDeps' _ (Simple _ _) = [] + findNewDeps' vs (Flagged qfn _ t f) = + case (F qfn == var, M.lookup qfn (vsFlags vs)) of + (True, _) -> if b then t else f + (_, Nothing) -> [] -- not yet known + (_, Just b') -> findNewDeps vs (if b' then t else f) + findNewDeps' vs (Stanza qsn t) = + case (S qsn == var, M.lookup qsn (vsStanzas vs)) of + (True, _) -> if b then t else [] + (_, Nothing) -> [] -- not yet known + (_, Just b') -> findNewDeps vs (if b' then t else []) + +updateLinkGroup :: LinkGroup -> UpdateState () +updateLinkGroup lg = do + verifyLinkGroup lg + modify $ \vs -> vs { + vsLinks = M.fromList (map aux (S.toList (lgMembers lg))) + `M.union` vsLinks vs + } + where + aux pp = (Q pp (lgPackage lg), lg) + +{------------------------------------------------------------------------------- + Verification +-------------------------------------------------------------------------------} + +verifyLinkGroup :: LinkGroup -> UpdateState () +verifyLinkGroup lg = + case lgInstance lg of + -- No instance picked yet. Nothing to verify + Nothing -> + return () + + -- We picked an instance. Verify flags and stanzas + -- TODO: The enumeration of OptionalStanza names is very brittle; + -- if a constructor is added to the datatype we won't notice it here + Just i -> do + vs <- get + let PInfo _deps _exes finfo _ = vsIndex vs ! lgPackage lg ! i + flags = M.keys finfo + stanzas = [TestStanzas, BenchStanzas] + forM_ flags $ \fn -> do + let flag = FN (lgPackage lg) fn + verifyFlag' flag lg + forM_ stanzas $ \sn -> do + let stanza = SN (lgPackage lg) sn + verifyStanza' stanza lg + +verifyFlag :: QFN -> UpdateState () +verifyFlag (FN qpn@(Q _pp pn) fn) = do + vs <- get + -- We can only pick a flag after picking an instance; link group must exist + verifyFlag' (FN pn fn) (vsLinks vs ! qpn) + +verifyStanza :: QSN -> UpdateState () +verifyStanza (SN qpn@(Q _pp pn) sn) = do + vs <- get + -- We can only pick a stanza after picking an instance; link group must exist + verifyStanza' (SN pn sn) (vsLinks vs ! qpn) + +-- | Verify that all packages in the link group agree on flag assignments +-- +-- For the given flag and the link group, obtain all assignments for the flag +-- that have already been made for link group members, and check that they are +-- equal. +verifyFlag' :: FN PN -> LinkGroup -> UpdateState () +verifyFlag' (FN pn fn) lg = do + vs <- get + let flags = map (\pp' -> FN (Q pp' pn) fn) (S.toList (lgMembers lg)) + vals = map (`M.lookup` vsFlags vs) flags + if allEqual (catMaybes vals) -- We ignore not-yet assigned flags + then return () + else conflict ( CS.fromList (map F flags) `CS.union` lgConflictSet lg + , "flag \"" ++ unFlagName fn ++ "\" incompatible" + ) + +-- | Verify that all packages in the link group agree on stanza assignments +-- +-- For the given stanza and the link group, obtain all assignments for the +-- stanza that have already been made for link group members, and check that +-- they are equal. +-- +-- This function closely mirrors 'verifyFlag''. +verifyStanza' :: SN PN -> LinkGroup -> UpdateState () +verifyStanza' (SN pn sn) lg = do + vs <- get + let stanzas = map (\pp' -> SN (Q pp' pn) sn) (S.toList (lgMembers lg)) + vals = map (`M.lookup` vsStanzas vs) stanzas + if allEqual (catMaybes vals) -- We ignore not-yet assigned stanzas + then return () + else conflict ( CS.fromList (map S stanzas) `CS.union` lgConflictSet lg + , "stanza \"" ++ showStanza sn ++ "\" incompatible" + ) + +{------------------------------------------------------------------------------- + Link groups +-------------------------------------------------------------------------------} + +-- | Set of packages that must be linked together +-- +-- A LinkGroup is between several qualified package names. In the validation +-- state, we maintain a map vsLinks from qualified package names to link groups. +-- There is an invariant that for all members of a link group, vsLinks must map +-- to the same link group. The function updateLinkGroup can be used to +-- re-establish this invariant after creating or expanding a LinkGroup. +data LinkGroup = LinkGroup { + -- | The name of the package of this link group + lgPackage :: PN + + -- | The canonical member of this link group (the one where we picked + -- a concrete instance). Once we have picked a canonical member, all + -- other packages must link to this one. + -- + -- We may not know this yet (if we are constructing link groups + -- for dependencies) + , lgCanon :: Maybe (PI PackagePath) + + -- | The members of the link group + , lgMembers :: Set PackagePath + + -- | The set of variables that should be added to the conflict set if + -- something goes wrong with this link set (in addition to the members + -- of the link group itself) + , lgBlame :: ConflictSet + } + deriving (Show, Eq) + +-- | Invariant for the set of link groups: every element in the link group +-- must be pointing to the /same/ link group +lgInvariant :: Map QPN LinkGroup -> Bool +lgInvariant links = all invGroup (M.elems links) + where + invGroup :: LinkGroup -> Bool + invGroup lg = allEqual $ map (`M.lookup` links) members + where + members :: [QPN] + members = map (`Q` lgPackage lg) $ S.toList (lgMembers lg) + +-- | Package version of this group +-- +-- This is only known once we have picked a canonical element. +lgInstance :: LinkGroup -> Maybe I +lgInstance = fmap (\(PI _ i) -> i) . lgCanon + +showLinkGroup :: LinkGroup -> String +showLinkGroup lg = + "{" ++ intercalate "," (map showMember (S.toList (lgMembers lg))) ++ "}" + where + showMember :: PackagePath -> String + showMember pp = case lgCanon lg of + Just (PI pp' _i) | pp == pp' -> "*" + _otherwise -> "" + ++ case lgInstance lg of + Nothing -> showQPN (qpn pp) + Just i -> showPI (PI (qpn pp) i) + + qpn :: PackagePath -> QPN + qpn pp = Q pp (lgPackage lg) + +-- | Creates a link group that contains a single member. +lgSingleton :: QPN -> Maybe (PI PackagePath) -> LinkGroup +lgSingleton (Q pp pn) canon = LinkGroup { + lgPackage = pn + , lgCanon = canon + , lgMembers = S.singleton pp + , lgBlame = CS.empty + } + +lgMerge :: ConflictSet -> LinkGroup -> LinkGroup -> Either Conflict LinkGroup +lgMerge blame lg lg' = do + canon <- pick (lgCanon lg) (lgCanon lg') + return LinkGroup { + lgPackage = lgPackage lg + , lgCanon = canon + , lgMembers = lgMembers lg `S.union` lgMembers lg' + , lgBlame = CS.unions [blame, lgBlame lg, lgBlame lg'] + } + where + pick :: Eq a => Maybe a -> Maybe a -> Either Conflict (Maybe a) + pick Nothing Nothing = Right Nothing + pick (Just x) Nothing = Right $ Just x + pick Nothing (Just y) = Right $ Just y + pick (Just x) (Just y) = + if x == y then Right $ Just x + else Left ( CS.unions [ + blame + , lgConflictSet lg + , lgConflictSet lg' + ] + , "cannot merge " ++ showLinkGroup lg + ++ " and " ++ showLinkGroup lg' + ) + +lgConflictSet :: LinkGroup -> ConflictSet +lgConflictSet lg = + CS.fromList (map aux (S.toList (lgMembers lg))) + `CS.union` lgBlame lg + where + aux pp = P (Q pp (lgPackage lg)) + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +allEqual :: Eq a => [a] -> Bool +allEqual [] = True +allEqual [_] = True +allEqual (x:y:ys) = x == y && allEqual (y:ys) diff --git a/cabal/cabal-install-solver/src/Distribution/Solver/Modular/Log.hs b/cabal/cabal-install-solver/src/Distribution/Solver/Modular/Log.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/src/Distribution/Solver/Modular/Log.hs @@ -0,0 +1,31 @@ +module Distribution.Solver.Modular.Log + ( displayLogMessages + , SolverFailure(..) + ) where + +import Prelude () +import Distribution.Solver.Compat.Prelude + +import Distribution.Solver.Types.Progress + +import Distribution.Solver.Modular.Dependency +import Distribution.Solver.Modular.Message +import Distribution.Solver.Modular.RetryLog + +-- | Information about a dependency solver failure. +data SolverFailure = + ExhaustiveSearch ConflictSet ConflictMap + | BackjumpLimitReached + +-- | Postprocesses a log file. This function discards all log messages and +-- avoids calling 'showMessages' if the log isn't needed (specified by +-- 'keepLog'), for efficiency. +displayLogMessages :: Bool + -> RetryLog Message SolverFailure a + -> RetryLog String SolverFailure a +displayLogMessages keepLog lg = fromProgress $ + if keepLog + then showMessages progress + else foldProgress (const id) Fail Done progress + where + progress = toProgress lg diff --git a/cabal/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs b/cabal/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs @@ -0,0 +1,273 @@ +{-# LANGUAGE BangPatterns #-} + +module Distribution.Solver.Modular.Message ( + Message(..), + showMessages + ) where + +import qualified Data.List as L +import Data.Map (Map) +import qualified Data.Map as M +import Data.Set (Set) +import qualified Data.Set as S +import Data.Maybe (catMaybes, mapMaybe) +import Prelude hiding (pi) + +import Distribution.Pretty (prettyShow) -- from Cabal + +import qualified Distribution.Solver.Modular.ConflictSet as CS +import Distribution.Solver.Modular.Dependency +import Distribution.Solver.Modular.Flag +import Distribution.Solver.Modular.MessageUtils + (showUnsupportedExtension, showUnsupportedLanguage) +import Distribution.Solver.Modular.Package +import Distribution.Solver.Modular.Tree + ( FailReason(..), POption(..), ConflictingDep(..) ) +import Distribution.Solver.Modular.Version +import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.PackagePath +import Distribution.Solver.Types.Progress +import Distribution.Types.LibraryName +import Distribution.Types.UnqualComponentName + +data Message = + Enter -- ^ increase indentation level + | Leave -- ^ decrease indentation level + | TryP QPN POption + | TryF QFN Bool + | TryS QSN Bool + | Next (Goal QPN) + | Skip (Set CS.Conflict) + | Success + | Failure ConflictSet FailReason + +-- | Transforms the structured message type to actual messages (strings). +-- +-- The log contains level numbers, which are useful for any trace that involves +-- backtracking, because only the level numbers will allow to keep track of +-- backjumps. +showMessages :: Progress Message a b -> Progress String a b +showMessages = go 0 + where + -- 'go' increments the level for a recursive call when it encounters + -- 'TryP', 'TryF', or 'TryS' and decrements the level when it encounters 'Leave'. + go :: Int -> Progress Message a b -> Progress String a b + go !_ (Done x) = Done x + go !_ (Fail x) = Fail x + -- complex patterns + go !l (Step (TryP qpn i) (Step Enter (Step (Failure c fr) (Step Leave ms)))) = + goPReject l qpn [i] c fr ms + go !l (Step (TryP qpn i) (Step Enter (Step (Skip conflicts) (Step Leave ms)))) = + goPSkip l qpn [i] conflicts ms + go !l (Step (TryF qfn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) = + (atLevel l $ "rejecting: " ++ showQFNBool qfn b ++ showFR c fr) (go l ms) + go !l (Step (TryS qsn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) = + (atLevel l $ "rejecting: " ++ showQSNBool qsn b ++ showFR c fr) (go l ms) + go !l (Step (Next (Goal (P _ ) gr)) (Step (TryP qpn' i) ms@(Step Enter (Step (Next _) _)))) = + (atLevel l $ "trying: " ++ showQPNPOpt qpn' i ++ showGR gr) (go l ms) + go !l (Step (Next (Goal (P qpn) gr)) (Step (Failure _c UnknownPackage) ms)) = + (atLevel l $ "unknown package: " ++ showQPN qpn ++ showGR gr) $ go l ms + -- standard display + go !l (Step Enter ms) = go (l+1) ms + go !l (Step Leave ms) = go (l-1) ms + go !l (Step (TryP qpn i) ms) = (atLevel l $ "trying: " ++ showQPNPOpt qpn i) (go l ms) + go !l (Step (TryF qfn b) ms) = (atLevel l $ "trying: " ++ showQFNBool qfn b) (go l ms) + go !l (Step (TryS qsn b) ms) = (atLevel l $ "trying: " ++ showQSNBool qsn b) (go l ms) + go !l (Step (Next (Goal (P qpn) gr)) ms) = (atLevel l $ showPackageGoal qpn gr) (go l ms) + go !l (Step (Next _) ms) = go l ms -- ignore flag goals in the log + go !l (Step (Skip conflicts) ms) = + -- 'Skip' should always be handled by 'goPSkip' in the case above. + (atLevel l $ "skipping: " ++ showConflicts conflicts) (go l ms) + go !l (Step (Success) ms) = (atLevel l $ "done") (go l ms) + go !l (Step (Failure c fr) ms) = (atLevel l $ showFailure c fr) (go l ms) + + showPackageGoal :: QPN -> QGoalReason -> String + showPackageGoal qpn gr = "next goal: " ++ showQPN qpn ++ showGR gr + + showFailure :: ConflictSet -> FailReason -> String + showFailure c fr = "fail" ++ showFR c fr + + -- special handler for many subsequent package rejections + goPReject :: Int + -> QPN + -> [POption] + -> ConflictSet + -> FailReason + -> Progress Message a b + -> Progress String a b + goPReject l qpn is c fr (Step (TryP qpn' i) (Step Enter (Step (Failure _ fr') (Step Leave ms)))) + | qpn == qpn' && fr == fr' = goPReject l qpn (i : is) c fr ms + goPReject l qpn is c fr ms = + (atLevel l $ "rejecting: " ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is)) ++ showFR c fr) (go l ms) + + -- Handle many subsequent skipped package instances. + goPSkip :: Int + -> QPN + -> [POption] + -> Set CS.Conflict + -> Progress Message a b + -> Progress String a b + goPSkip l qpn is conflicts (Step (TryP qpn' i) (Step Enter (Step (Skip conflicts') (Step Leave ms)))) + | qpn == qpn' && conflicts == conflicts' = goPSkip l qpn (i : is) conflicts ms + goPSkip l qpn is conflicts ms = + let msg = "skipping: " + ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is)) + ++ showConflicts conflicts + in atLevel l msg (go l ms) + + -- write a message with the current level number + atLevel :: Int -> String -> Progress String a b -> Progress String a b + atLevel l x xs = + let s = show l + in Step ("[" ++ replicate (3 - length s) '_' ++ s ++ "] " ++ x) xs + +-- | Display the set of 'Conflicts' for a skipped package version. +showConflicts :: Set CS.Conflict -> String +showConflicts conflicts = + " (has the same characteristics that caused the previous version to fail: " + ++ conflictMsg ++ ")" + where + conflictMsg :: String + conflictMsg = + if S.member CS.OtherConflict conflicts + then + -- This case shouldn't happen, because an unknown conflict should not + -- cause a version to be skipped. + "unknown conflict" + else let mergedConflicts = + [ showConflict qpn conflict + | (qpn, conflict) <- M.toList (mergeConflicts conflicts) ] + in if L.null mergedConflicts + then + -- This case shouldn't happen unless backjumping is turned off. + "none" + else L.intercalate "; " mergedConflicts + + -- Merge conflicts to simplify the log message. + mergeConflicts :: Set CS.Conflict -> Map QPN MergedPackageConflict + mergeConflicts = M.fromListWith mergeConflict . mapMaybe toMergedConflict . S.toList + where + mergeConflict :: MergedPackageConflict + -> MergedPackageConflict + -> MergedPackageConflict + mergeConflict mergedConflict1 mergedConflict2 = MergedPackageConflict { + isGoalConflict = + isGoalConflict mergedConflict1 || isGoalConflict mergedConflict2 + , versionConstraintConflict = + L.nub $ versionConstraintConflict mergedConflict1 + ++ versionConstraintConflict mergedConflict2 + , versionConflict = + mergeVersionConflicts (versionConflict mergedConflict1) + (versionConflict mergedConflict2) + } + where + mergeVersionConflicts (Just vr1) (Just vr2) = Just (vr1 .||. vr2) + mergeVersionConflicts (Just vr1) Nothing = Just vr1 + mergeVersionConflicts Nothing (Just vr2) = Just vr2 + mergeVersionConflicts Nothing Nothing = Nothing + + toMergedConflict :: CS.Conflict -> Maybe (QPN, MergedPackageConflict) + toMergedConflict (CS.GoalConflict qpn) = + Just (qpn, MergedPackageConflict True [] Nothing) + toMergedConflict (CS.VersionConstraintConflict qpn v) = + Just (qpn, MergedPackageConflict False [v] Nothing) + toMergedConflict (CS.VersionConflict qpn (CS.OrderedVersionRange vr)) = + Just (qpn, MergedPackageConflict False [] (Just vr)) + toMergedConflict CS.OtherConflict = Nothing + + showConflict :: QPN -> MergedPackageConflict -> String + showConflict qpn mergedConflict = L.intercalate "; " conflictStrings + where + conflictStrings = catMaybes [ + case () of + () | isGoalConflict mergedConflict -> Just $ + "depends on '" ++ showQPN qpn ++ "'" ++ + (if null (versionConstraintConflict mergedConflict) + then "" + else " but excludes " + ++ showVersions (versionConstraintConflict mergedConflict)) + | not $ L.null (versionConstraintConflict mergedConflict) -> Just $ + "excludes '" ++ showQPN qpn + ++ "' " ++ showVersions (versionConstraintConflict mergedConflict) + | otherwise -> Nothing + , (\vr -> "excluded by constraint '" ++ showVR vr ++ "' from '" ++ showQPN qpn ++ "'") + <$> versionConflict mergedConflict + ] + + showVersions [] = "no versions" + showVersions [v] = "version " ++ showVer v + showVersions vs = "versions " ++ L.intercalate ", " (map showVer vs) + +-- | All conflicts related to one package, used for simplifying the display of +-- a 'Set CS.Conflict'. +data MergedPackageConflict = MergedPackageConflict { + isGoalConflict :: Bool + , versionConstraintConflict :: [Ver] + , versionConflict :: Maybe VR + } + +showQPNPOpt :: QPN -> POption -> String +showQPNPOpt 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) + +showGR :: QGoalReason -> String +showGR UserGoal = " (user goal)" +showGR (DependencyGoal dr) = " (dependency of " ++ showDependencyReason dr ++ ")" + +showFR :: ConflictSet -> FailReason -> String +showFR _ (UnsupportedExtension ext) = " (conflict: requires " ++ showUnsupportedExtension ext ++ ")" +showFR _ (UnsupportedLanguage lang) = " (conflict: requires " ++ showUnsupportedLanguage lang ++ ")" +showFR _ (MissingPkgconfigPackage pn vr) = " (conflict: pkg-config package " ++ prettyShow pn ++ prettyShow vr ++ ", not found in the pkg-config database)" +showFR _ (NewPackageDoesNotMatchExistingConstraint d) = " (conflict: " ++ showConflictingDep d ++ ")" +showFR _ (ConflictingConstraints d1 d2) = " (conflict: " ++ L.intercalate ", " (L.map showConflictingDep [d1, d2]) ++ ")" +showFR _ (NewPackageIsMissingRequiredComponent comp dr) = " (does not contain " ++ showExposedComponent comp ++ ", which is required by " ++ showDependencyReason dr ++ ")" +showFR _ (NewPackageHasPrivateRequiredComponent comp dr) = " (" ++ showExposedComponent comp ++ " is private, but it is required by " ++ showDependencyReason dr ++ ")" +showFR _ (NewPackageHasUnbuildableRequiredComponent comp dr) = " (" ++ showExposedComponent comp ++ " is not buildable in the current environment, but it is required by " ++ showDependencyReason dr ++ ")" +showFR _ (PackageRequiresMissingComponent qpn comp) = " (requires " ++ showExposedComponent comp ++ " from " ++ showQPN qpn ++ ", but the component does not exist)" +showFR _ (PackageRequiresPrivateComponent qpn comp) = " (requires " ++ showExposedComponent comp ++ " from " ++ showQPN qpn ++ ", but the component is private)" +showFR _ (PackageRequiresUnbuildableComponent qpn comp) = " (requires " ++ showExposedComponent comp ++ " from " ++ showQPN qpn ++ ", but the component is not buildable in the current environment)" +showFR _ CannotInstall = " (only already installed instances can be used)" +showFR _ CannotReinstall = " (avoiding to reinstall a package with same version but new dependencies)" +showFR _ NotExplicit = " (not a user-provided goal nor mentioned as a constraint, but reject-unconstrained-dependencies was set)" +showFR _ Shadowed = " (shadowed by another installed package with same version)" +showFR _ (Broken u) = " (package is broken, missing dependency " ++ prettyShow u ++ ")" +showFR _ UnknownPackage = " (unknown package)" +showFR _ (GlobalConstraintVersion vr src) = " (" ++ constraintSource src ++ " requires " ++ prettyShow vr ++ ")" +showFR _ (GlobalConstraintInstalled src) = " (" ++ constraintSource src ++ " requires installed instance)" +showFR _ (GlobalConstraintSource src) = " (" ++ constraintSource src ++ " requires source instance)" +showFR _ (GlobalConstraintFlag src) = " (" ++ constraintSource src ++ " requires opposite flag selection)" +showFR _ ManualFlag = " (manual flag can only be changed explicitly)" +showFR c Backjump = " (backjumping, conflict set: " ++ showConflictSet c ++ ")" +showFR _ MultipleInstances = " (multiple instances)" +showFR c (DependenciesNotLinked msg) = " (dependencies not linked: " ++ msg ++ "; conflict set: " ++ showConflictSet c ++ ")" +showFR c CyclicDependencies = " (cyclic dependencies; conflict set: " ++ showConflictSet c ++ ")" +showFR _ (UnsupportedSpecVer ver) = " (unsupported spec-version " ++ prettyShow ver ++ ")" +-- The following are internal failures. They should not occur. In the +-- interest of not crashing unnecessarily, we still just print an error +-- message though. +showFR _ (MalformedFlagChoice qfn) = " (INTERNAL ERROR: MALFORMED FLAG CHOICE: " ++ showQFN qfn ++ ")" +showFR _ (MalformedStanzaChoice qsn) = " (INTERNAL ERROR: MALFORMED STANZA CHOICE: " ++ showQSN qsn ++ ")" +showFR _ EmptyGoalChoice = " (INTERNAL ERROR: EMPTY GOAL CHOICE)" + +showExposedComponent :: ExposedComponent -> String +showExposedComponent (ExposedLib LMainLibName) = "library" +showExposedComponent (ExposedLib (LSubLibName name)) = "library '" ++ unUnqualComponentName name ++ "'" +showExposedComponent (ExposedExe name) = "executable '" ++ unUnqualComponentName name ++ "'" + +constraintSource :: ConstraintSource -> String +constraintSource src = "constraint from " ++ showConstraintSource src + +showConflictingDep :: ConflictingDep -> String +showConflictingDep (ConflictingDep dr (PkgComponent qpn comp) ci) = + let DependencyReason qpn' _ _ = dr + componentStr = case comp of + ExposedExe exe -> " (exe " ++ unUnqualComponentName exe ++ ")" + ExposedLib LMainLibName -> "" + ExposedLib (LSubLibName lib) -> " (lib " ++ unUnqualComponentName lib ++ ")" + in case ci of + Fixed i -> (if qpn /= qpn' then showDependencyReason dr ++ " => " else "") ++ + showQPN qpn ++ componentStr ++ "==" ++ showI i + Constrained vr -> showDependencyReason dr ++ " => " ++ showQPN qpn ++ + componentStr ++ showVR vr diff --git a/cabal/cabal-install-solver/src/Distribution/Solver/Modular/MessageUtils.hs b/cabal/cabal-install-solver/src/Distribution/Solver/Modular/MessageUtils.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/src/Distribution/Solver/Modular/MessageUtils.hs @@ -0,0 +1,56 @@ +-- | Utility functions providing extra context to cabal error messages + +module Distribution.Solver.Modular.MessageUtils ( + allKnownExtensions, + cutoffRange, + mostSimilarElement, + showUnsupportedExtension, + showUnsupportedLanguage, + withinRange +) where + +import Data.Foldable (minimumBy) +import Data.Ord (comparing) +import Distribution.Pretty (prettyShow) -- from Cabal +import Language.Haskell.Extension + ( Extension(..), Language(..), knownLanguages, knownExtensions ) +import Text.EditDistance ( defaultEditCosts, levenshteinDistance ) + +showUnsupportedExtension :: Extension -> String +showUnsupportedExtension (UnknownExtension extStr) = formatMessage cutoffRange "extension" extStr (mostSimilarElement extStr allKnownExtensions) +showUnsupportedExtension extension = unwords [prettyShow extension, "which is not supported"] + +showUnsupportedLanguage :: Language -> String +showUnsupportedLanguage (UnknownLanguage langStr) = formatMessage cutoffRange "language" langStr (mostSimilarElement langStr (show <$> knownLanguages)) +showUnsupportedLanguage knownLanguage = unwords [prettyShow knownLanguage, "which is not supported"] + +allKnownExtensions :: [String] +allKnownExtensions = enabledExtensions ++ disabledExtensions + where + enabledExtensions = map (prettyShow . EnableExtension) knownExtensions + disabledExtensions = map (prettyShow . DisableExtension) knownExtensions + +-- Measure the Levenshtein distance between two strings +distance :: String -> String -> Int +distance = levenshteinDistance defaultEditCosts + +-- Given an `unknownElement` and a list of `elements` return the element +-- from the list with the closest Levenshtein distance to the `unknownElement` +mostSimilarElement :: String -> [String] -> String +mostSimilarElement unknownElement elements = fst . minimumBy (comparing snd) . map mapDist $ elements + where + mapDist element = (element, distance unknownElement element) + +-- Cutoff range for giving a suggested spelling +cutoffRange :: Int +cutoffRange = 10 + +formatMessage :: Int -> String -> String -> String -> String +formatMessage range elementType element suggestion + | withinRange range element suggestion = + unwords ["unknown", elementType, element ++ ";", "did you mean", suggestion ++ "?"] + | otherwise = unwords ["unknown", elementType, element] + +-- Check whether the strings are within cutoff range +withinRange :: Int -> String -> String -> Bool +withinRange range element suggestion = distance element suggestion <= range diff --git a/cabal/cabal-install-solver/src/Distribution/Solver/Modular/PSQ.hs b/cabal/cabal-install-solver/src/Distribution/Solver/Modular/PSQ.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/src/Distribution/Solver/Modular/PSQ.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} +module Distribution.Solver.Modular.PSQ + ( PSQ(..) -- Unit test needs constructor access + , casePSQ + , cons + , length + , lookup + , filter + , filterIfAny + , filterIfAnyByKeys + , filterKeys + , firstOnly + , fromList + , isZeroOrOne + , keys + , map + , mapKeys + , mapWithKey + , maximumBy + , minimumBy + , null + , prefer + , preferByKeys + , snoc + , sortBy + , sortByKeys + , toList + , union + ) where + +-- Priority search queues. +-- +-- I am not yet sure what exactly is needed. But we need a data structure with +-- key-based lookup that can be sorted. We're using a sequence right now with +-- (inefficiently implemented) lookup, because I think that queue-based +-- operations and sorting turn out to be more efficiency-critical in practice. + +import Control.Arrow (first, second) + +import qualified Data.Foldable as F +import Data.Function +import qualified Data.List as S +import Data.Ord (comparing) +import Data.Traversable +import Prelude hiding (foldr, length, lookup, filter, null, map) + +newtype PSQ k v = PSQ [(k, v)] + deriving (Eq, Show, Functor, F.Foldable, Traversable) -- Qualified Foldable to avoid issues with FTP + +keys :: PSQ k v -> [k] +keys (PSQ xs) = fmap fst xs + +lookup :: Eq k => k -> PSQ k v -> Maybe v +lookup k (PSQ xs) = S.lookup k xs + +map :: (v1 -> v2) -> PSQ k v1 -> PSQ k v2 +map f (PSQ xs) = PSQ (fmap (second f) xs) + +mapKeys :: (k1 -> k2) -> PSQ k1 v -> PSQ k2 v +mapKeys f (PSQ xs) = PSQ (fmap (first f) xs) + +mapWithKey :: (k -> a -> b) -> PSQ k a -> PSQ k b +mapWithKey f (PSQ xs) = PSQ (fmap (\ (k, v) -> (k, f k v)) xs) + +fromList :: [(k, a)] -> PSQ k a +fromList = PSQ + +cons :: k -> a -> PSQ k a -> PSQ k a +cons k x (PSQ xs) = PSQ ((k, x) : xs) + +snoc :: PSQ k a -> k -> a -> PSQ k a +snoc (PSQ xs) k x = PSQ (xs ++ [(k, x)]) + +casePSQ :: PSQ k a -> r -> (k -> a -> PSQ k a -> r) -> r +casePSQ (PSQ xs) n c = + case xs of + [] -> n + (k, v) : ys -> c k v (PSQ ys) + +sortBy :: (a -> a -> Ordering) -> PSQ k a -> PSQ k a +sortBy cmp (PSQ xs) = PSQ (S.sortBy (cmp `on` snd) xs) + +sortByKeys :: (k -> k -> Ordering) -> PSQ k a -> PSQ k a +sortByKeys cmp (PSQ xs) = PSQ (S.sortBy (cmp `on` fst) xs) + +maximumBy :: (k -> Int) -> PSQ k a -> (k, a) +maximumBy sel (PSQ xs) = + S.minimumBy (flip (comparing (sel . fst))) xs + +minimumBy :: (a -> Int) -> PSQ k a -> PSQ k a +minimumBy sel (PSQ xs) = + PSQ [snd (S.minimumBy (comparing fst) (S.map (\ x -> (sel (snd x), x)) xs))] + +-- | Sort the list so that values satisfying the predicate are first. +prefer :: (a -> Bool) -> PSQ k a -> PSQ k a +prefer p = sortBy $ flip (comparing p) + +-- | Sort the list so that keys satisfying the predicate are first. +preferByKeys :: (k -> Bool) -> PSQ k a -> PSQ k a +preferByKeys p = sortByKeys $ flip (comparing p) + +-- | Will partition the list according to the predicate. If +-- there is any element that satisfies the predicate, then only +-- the elements satisfying the predicate are returned. +-- Otherwise, the rest is returned. +-- +filterIfAny :: (a -> Bool) -> PSQ k a -> PSQ k a +filterIfAny p (PSQ xs) = + let + (pro, con) = S.partition (p . snd) xs + in + if S.null pro then PSQ con else PSQ pro + +-- | Variant of 'filterIfAny' that takes a predicate on the keys +-- rather than on the values. +-- +filterIfAnyByKeys :: (k -> Bool) -> PSQ k a -> PSQ k a +filterIfAnyByKeys p (PSQ xs) = + let + (pro, con) = S.partition (p . fst) xs + in + if S.null pro then PSQ con else PSQ pro + +filterKeys :: (k -> Bool) -> PSQ k a -> PSQ k a +filterKeys p (PSQ xs) = PSQ (S.filter (p . fst) xs) + +filter :: (a -> Bool) -> PSQ k a -> PSQ k a +filter p (PSQ xs) = PSQ (S.filter (p . snd) xs) + +length :: PSQ k a -> Int +length (PSQ xs) = S.length xs + +null :: PSQ k a -> Bool +null (PSQ xs) = S.null xs + +isZeroOrOne :: PSQ k a -> Bool +isZeroOrOne (PSQ []) = True +isZeroOrOne (PSQ [_]) = True +isZeroOrOne _ = False + +firstOnly :: PSQ k a -> PSQ k a +firstOnly (PSQ []) = PSQ [] +firstOnly (PSQ (x : _)) = PSQ [x] + +toList :: PSQ k a -> [(k, a)] +toList (PSQ xs) = xs + +union :: PSQ k a -> PSQ k a -> PSQ k a +union (PSQ xs) (PSQ ys) = PSQ (xs ++ ys) diff --git a/cabal/cabal-install-solver/src/Distribution/Solver/Modular/Package.hs b/cabal/cabal-install-solver/src/Distribution/Solver/Modular/Package.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/src/Distribution/Solver/Modular/Package.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE DeriveFunctor #-} +module Distribution.Solver.Modular.Package + ( I(..) + , Loc(..) + , PackageId + , PackageIdentifier(..) + , PackageName, mkPackageName, unPackageName + , PkgconfigName, mkPkgconfigName, unPkgconfigName + , PI(..) + , PN + , QPV + , instI + , makeIndependent + , primaryPP + , setupPP + , showI + , showPI + , unPN + ) where + +import Prelude () +import Distribution.Solver.Compat.Prelude + +import Distribution.Package -- from Cabal +import Distribution.Pretty (prettyShow) + +import Distribution.Solver.Modular.Version +import Distribution.Solver.Types.PackagePath + +-- | A package name. +type PN = PackageName + +-- | Unpacking a package name. +unPN :: PN -> String +unPN = unPackageName + +-- | Package version. A package name plus a version number. +type PV = PackageId + +-- | Qualified package version. +type QPV = Qualified PV + +-- | Package id. Currently just a black-box string. +type PId = UnitId + +-- | Location. Info about whether a package is installed or not, and where +-- exactly it is located. For installed packages, uniquely identifies the +-- package instance via its 'PId'. +-- +-- TODO: More information is needed about the repo. +data Loc = Inst PId | InRepo + deriving (Eq, Ord, Show) + +-- | Instance. A version number and a location. +data I = I 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 + +-- | Package instance. A package name and an instance. +data PI qpn = PI qpn I + deriving (Eq, Ord, Show, Functor) + +-- | String representation of a package instance. +showPI :: PI QPN -> String +showPI (PI qpn i) = showQPN qpn ++ "-" ++ showI i + +instI :: I -> Bool +instI (I _ (Inst _)) = True +instI _ = False + +-- | Is the package in the primary group of packages. This is used to +-- determine (1) if we should try to establish stanza preferences +-- for this goal, and (2) whether or not a user specified @--constraint@ +-- should apply to this dependency (grep 'primaryPP' to see the +-- use sites). In particular this does not include packages pulled in +-- as setup deps. +-- +primaryPP :: PackagePath -> Bool +primaryPP (PackagePath _ns q) = go q + where + go QualToplevel = True + go (QualBase _) = True + go (QualSetup _) = False + go (QualExe _ _) = False + +-- | Is the package a dependency of a setup script. This is used to +-- establish whether or not certain constraints should apply to this +-- dependency (grep 'setupPP' to see the use sites). +-- +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/cabal-install-solver/src/Distribution/Solver/Modular/Preference.hs b/cabal/cabal-install-solver/src/Distribution/Solver/Modular/Preference.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/src/Distribution/Solver/Modular/Preference.hs @@ -0,0 +1,512 @@ +{-# LANGUAGE ScopedTypeVariables #-} +-- | Reordering or pruning the tree in order to prefer or make certain choices. +module Distribution.Solver.Modular.Preference + ( avoidReinstalls + , deferSetupExeChoices + , deferWeakFlagChoices + , enforceManualFlags + , enforcePackageConstraints + , enforceSingleInstanceRestriction + , firstGoal + , preferBaseGoalChoice + , preferLinked + , preferPackagePreferences + , preferReallyEasyGoalChoices + , requireInstalled + , onlyConstrained + , sortGoals + , pruneAfterFirstSuccess + ) where + +import Prelude () +import Distribution.Solver.Compat.Prelude + +import qualified Data.List as L +import qualified Data.Map as M +import Control.Monad.Trans.Reader (Reader, runReader, ask, local) + +import Distribution.PackageDescription (lookupFlagAssignment, unFlagAssignment) -- from Cabal + +import Distribution.Solver.Types.Flag +import Distribution.Solver.Types.InstalledPreference +import Distribution.Solver.Types.LabeledPackageConstraint +import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.PackageConstraint +import Distribution.Solver.Types.PackagePath +import Distribution.Solver.Types.PackagePreferences +import Distribution.Solver.Types.Variable + +import Distribution.Solver.Modular.Dependency +import Distribution.Solver.Modular.Flag +import Distribution.Solver.Modular.Package +import qualified Distribution.Solver.Modular.PSQ as P +import Distribution.Solver.Modular.Tree +import Distribution.Solver.Modular.Version +import qualified Distribution.Solver.Modular.ConflictSet as CS +import qualified Distribution.Solver.Modular.WeightedPSQ as W + +-- | Update the weights of children under 'PChoice' nodes. 'addWeights' takes a +-- list of weight-calculating functions in order to avoid sorting the package +-- choices multiple times. Each function takes the package name, sorted list of +-- children's versions, and package option. 'addWeights' prepends the new +-- weights to the existing weights, which gives precedence to preferences that +-- are applied later. +addWeights :: [PN -> [Ver] -> POption -> Weight] -> EndoTreeTrav d c +addWeights fs = go + where + go :: TreeF d c (Tree d c) -> TreeF d c (Tree d c) + go (PChoiceF qpn@(Q _ pn) rdm x cs) = + let sortedVersions = L.sortBy (flip compare) $ L.map version (W.keys cs) + weights k = [f pn sortedVersions k | f <- fs] + + elemsToWhnf :: [a] -> () + elemsToWhnf = foldr seq () + in PChoiceF qpn rdm x + -- Evaluate the children's versions before evaluating any of the + -- subtrees, so that 'sortedVersions' doesn't hold onto all of the + -- subtrees (referenced by cs) and cause a space leak. + (elemsToWhnf sortedVersions `seq` + W.mapWeightsWithKey (\k w -> weights k ++ w) cs) + go x = x + +addWeight :: (PN -> [Ver] -> POption -> Weight) -> EndoTreeTrav d c +addWeight f = addWeights [f] + +version :: POption -> Ver +version (POption (I v _) _) = v + +-- | Prefer to link packages whenever possible. +preferLinked :: EndoTreeTrav d c +preferLinked = addWeight (const (const linked)) + where + linked (POption _ Nothing) = 1 + linked (POption _ (Just _)) = 0 + +-- Works by setting weights on choice nodes. Also applies stanza preferences. +preferPackagePreferences :: (PN -> PackagePreferences) -> EndoTreeTrav d c +preferPackagePreferences pcs = + preferPackageStanzaPreferences pcs . + -- Each package is assigned a list of weights (currently three of them), + -- and options are ordered by comparison of these lists. + -- + -- The head of the list (and thus the top priority for ordering) + -- is whether the package version is "preferred" + -- (https://hackage.haskell.org/packages/preferred-versions). + -- + -- The next two elements depend on 'PackagePreferences'. + -- For 'PreferInstalled' they are whether the version is installed (0 or 1) + -- and how close is the version to the latest one (between 0.0 and 1.0). + -- For 'PreferLatest' the weights are the same, but swapped, so that + -- ordering considers how new is the package first. + -- For 'PreferOldest' one weight measures how close is the version to the + -- the oldest one possible (between 0.0 and 1.0) and another checks whether + -- the version is installed (0 or 1). + addWeights [ + \pn _ opt -> preferred pn opt + , \pn vs opt -> case preference pn of + PreferInstalled -> installed opt + PreferLatest -> latest vs opt + PreferOldest -> oldest vs opt + , \pn vs opt -> case preference pn of + PreferInstalled -> latest vs opt + PreferLatest -> installed opt + PreferOldest -> installed opt + ] + where + -- Prefer packages with higher version numbers over packages with + -- lower version numbers. + latest :: [Ver] -> POption -> Weight + latest sortedVersions opt = + let l = length sortedVersions + index = fromMaybe l $ L.findIndex (<= version opt) sortedVersions + in fromIntegral index / fromIntegral l + + -- Prefer packages with lower version numbers over packages with + -- higher version numbers. + oldest :: [Ver] -> POption -> Weight + oldest sortedVersions opt = 1 - latest sortedVersions opt + + preference :: PN -> InstalledPreference + preference pn = + let PackagePreferences _ ipref _ = pcs pn + in ipref + + -- | Prefer versions satisfying more preferred version ranges. + preferred :: PN -> POption -> Weight + preferred pn opt = + let PackagePreferences vrs _ _ = pcs pn + in fromIntegral . negate . L.length $ + L.filter (flip checkVR (version opt)) vrs + + -- Prefer installed packages over non-installed packages. + installed :: POption -> Weight + installed (POption (I _ (Inst _)) _) = 0 + installed _ = 1 + +-- | Traversal that tries to establish package stanza enable\/disable +-- preferences. Works by reordering the branches of stanza choices. +-- Note that this works on packages lower in the path as well as at the top level. +-- This is because stanza preferences apply to local packages only +-- and for local packages, a single version is fixed, which means +-- (for now) that all stanza preferences must be uniform at all levels. +-- Further, even when we can have multiple versions of the same package, +-- the build plan will be more efficient if we can attempt to keep +-- stanza preferences aligned at all levels. +preferPackageStanzaPreferences :: (PN -> PackagePreferences) -> EndoTreeTrav d c +preferPackageStanzaPreferences pcs = go + where + go (SChoiceF qsn@(SN (Q _pp pn) s) rdm gr _tr ts) + | enableStanzaPref pn s = + -- move True case first to try enabling the stanza + let ts' = W.mapWeightsWithKey (\k w -> weight k : w) ts + weight k = if k then 0 else 1 + -- defer the choice by setting it to weak + in SChoiceF qsn rdm gr (WeakOrTrivial True) ts' + go x = x + + enableStanzaPref :: PN -> OptionalStanza -> Bool + enableStanzaPref pn s = + let PackagePreferences _ _ spref = pcs pn + in s `elem` spref + +-- | Helper function that tries to enforce a single package constraint on a +-- given instance for a P-node. Translates the constraint into a +-- tree-transformer that either leaves the subtree untouched, or replaces it +-- with an appropriate failure node. +processPackageConstraintP :: forall d c. QPN + -> ConflictSet + -> I + -> LabeledPackageConstraint + -> Tree d c + -> Tree d c +processPackageConstraintP qpn c i (LabeledPackageConstraint (PackageConstraint scope prop) src) r = + if constraintScopeMatches scope qpn + then go i prop + else r + where + go :: I -> PackageProperty -> Tree d c + go (I v _) (PackagePropertyVersion vr) + | checkVR vr v = r + | otherwise = Fail c (GlobalConstraintVersion vr src) + go _ PackagePropertyInstalled + | instI i = r + | otherwise = Fail c (GlobalConstraintInstalled src) + go _ PackagePropertySource + | not (instI i) = r + | otherwise = Fail c (GlobalConstraintSource src) + go _ _ = r + +-- | Helper function that tries to enforce a single package constraint on a +-- given flag setting for an F-node. Translates the constraint into a +-- tree-transformer that either leaves the subtree untouched, or replaces it +-- with an appropriate failure node. +processPackageConstraintF :: forall d c. QPN + -> Flag + -> ConflictSet + -> Bool + -> LabeledPackageConstraint + -> Tree d c + -> Tree d c +processPackageConstraintF qpn f c b' (LabeledPackageConstraint (PackageConstraint scope prop) src) r = + if constraintScopeMatches scope qpn + then go prop + else r + where + go :: PackageProperty -> Tree d c + go (PackagePropertyFlags fa) = + case lookupFlagAssignment f fa of + Nothing -> r + Just b | b == b' -> r + | otherwise -> Fail c (GlobalConstraintFlag src) + go _ = r + +-- | Helper function that tries to enforce a single package constraint on a +-- given flag setting for an F-node. Translates the constraint into a +-- tree-transformer that either leaves the subtree untouched, or replaces it +-- with an appropriate failure node. +processPackageConstraintS :: forall d c. QPN + -> OptionalStanza + -> ConflictSet + -> Bool + -> LabeledPackageConstraint + -> Tree d c + -> Tree d c +processPackageConstraintS qpn s c b' (LabeledPackageConstraint (PackageConstraint scope prop) src) r = + if constraintScopeMatches scope qpn + then go prop + else r + where + go :: PackageProperty -> Tree d c + go (PackagePropertyStanzas ss) = + if not b' && s `elem` ss then Fail c (GlobalConstraintFlag src) + else r + go _ = r + +-- | Traversal that tries to establish various kinds of user constraints. Works +-- by selectively disabling choices that have been ruled out by global user +-- constraints. +enforcePackageConstraints :: M.Map PN [LabeledPackageConstraint] + -> EndoTreeTrav d c +enforcePackageConstraints pcs = go + where + go (PChoiceF qpn@(Q _ pn) rdm gr ts) = + let c = varToConflictSet (P qpn) + -- compose the transformation functions for each of the relevant constraint + g = \ (POption i _) -> foldl (\ h pc -> h . processPackageConstraintP qpn c i pc) + id + (M.findWithDefault [] pn pcs) + in PChoiceF qpn rdm gr (W.mapWithKey g ts) + go (FChoiceF qfn@(FN qpn@(Q _ pn) f) rdm gr tr m d ts) = + let c = varToConflictSet (F qfn) + -- compose the transformation functions for each of the relevant constraint + g = \ b -> foldl (\ h pc -> h . processPackageConstraintF qpn f c b pc) + id + (M.findWithDefault [] pn pcs) + in FChoiceF qfn rdm gr tr m d (W.mapWithKey g ts) + go (SChoiceF qsn@(SN qpn@(Q _ pn) f) rdm gr tr ts) = + let c = varToConflictSet (S qsn) + -- compose the transformation functions for each of the relevant constraint + g = \ b -> foldl (\ h pc -> h . processPackageConstraintS qpn f c b pc) + id + (M.findWithDefault [] pn pcs) + in SChoiceF qsn rdm gr tr (W.mapWithKey g ts) + go x = x + +-- | Transformation that tries to enforce the rule that manual flags can only be +-- set by the user. +-- +-- If there are no constraints on a manual flag, this function prunes all but +-- the default value. If there are constraints, then the flag is allowed to have +-- the values specified by the constraints. Note that the type used for flag +-- values doesn't need to be Bool. +-- +-- This function makes an exception for the case where there are multiple goals +-- for a single package (with different qualifiers), and flag constraints for +-- manual flag x only apply to some of those goals. In that case, we allow the +-- unconstrained goals to use the default value for x OR any of the values in +-- the constraints on x (even though the constraints don't apply), in order to +-- allow the unconstrained goals to be linked to the constrained goals. See +-- https://github.com/haskell/cabal/issues/4299. Removing the single instance +-- restriction (SIR) would also fix #4299, so we may want to remove this +-- exception and only let the user toggle manual flags if we remove the SIR. +-- +-- This function does not enforce any of the constraints, since that is done by +-- 'enforcePackageConstraints'. +enforceManualFlags :: M.Map PN [LabeledPackageConstraint] -> EndoTreeTrav d c +enforceManualFlags pcs = go + where + go (FChoiceF qfn@(FN (Q _ pn) fn) rdm gr tr Manual d ts) = + FChoiceF qfn rdm gr tr Manual d $ + let -- A list of all values specified by constraints on 'fn'. + -- We ignore the constraint scope in order to handle issue #4299. + flagConstraintValues :: [Bool] + flagConstraintValues = + [ flagVal + | let lpcs = M.findWithDefault [] pn pcs + , (LabeledPackageConstraint (PackageConstraint _ (PackagePropertyFlags fa)) _) <- lpcs + , (fn', flagVal) <- unFlagAssignment fa + , fn' == fn ] + + -- Prune flag values that are not the default and do not match any + -- of the constraints. + restrictToggling :: Eq a => a -> [a] -> a -> Tree d c -> Tree d c + restrictToggling flagDefault constraintVals flagVal r = + if flagVal `elem` constraintVals || flagVal == flagDefault + then r + else Fail (varToConflictSet (F qfn)) ManualFlag + + in W.mapWithKey (restrictToggling d flagConstraintValues) ts + go x = x + +-- | Require installed packages. +requireInstalled :: (PN -> Bool) -> EndoTreeTrav d c +requireInstalled p = go + where + go (PChoiceF v@(Q _ pn) rdm gr cs) + | p pn = PChoiceF v rdm gr (W.mapWithKey installed cs) + | otherwise = PChoiceF v rdm gr cs + where + installed (POption (I _ (Inst _)) _) x = x + installed _ _ = Fail (varToConflictSet (P v)) CannotInstall + go x = x + +-- | Avoid reinstalls. +-- +-- This is a tricky strategy. If a package version is installed already and the +-- same version is available from a repo, the repo version will never be chosen. +-- This would result in a reinstall (either destructively, or potentially, +-- shadowing). The old instance won't be visible or even present anymore, but +-- other packages might have depended on it. +-- +-- TODO: It would be better to actually check the reverse dependencies of installed +-- packages. If they're not depended on, then reinstalling should be fine. Even if +-- they are, perhaps this should just result in trying to reinstall those other +-- packages as well. However, doing this all neatly in one pass would require to +-- change the builder, or at least to change the goal set after building. +avoidReinstalls :: (PN -> Bool) -> EndoTreeTrav d c +avoidReinstalls p = go + where + go (PChoiceF qpn@(Q _ pn) rdm gr cs) + | p pn = PChoiceF qpn rdm gr disableReinstalls + | otherwise = PChoiceF qpn rdm gr cs + where + disableReinstalls = + 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 = + Fail (varToConflictSet (P qpn)) CannotReinstall + notReinstall _ _ x = + x + go x = x + +-- | Require all packages to be mentioned in a constraint or as a goal. +onlyConstrained :: (PN -> Bool) -> EndoTreeTrav d QGoalReason +onlyConstrained p = go + where + go (PChoiceF v@(Q _ pn) _ gr _) | not (p pn) + = FailF + (varToConflictSet (P v) `CS.union` goalReasonToConflictSetWithConflict v gr) + NotExplicit + go x + = x + +-- | Sort all goals using the provided function. +sortGoals :: (Variable QPN -> Variable QPN -> Ordering) -> EndoTreeTrav d c +sortGoals variableOrder = go + where + go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.sortByKeys goalOrder xs) + go x = x + + goalOrder :: Goal QPN -> Goal QPN -> Ordering + goalOrder = variableOrder `on` (varToVariable . goalToVar) + + varToVariable :: Var QPN -> Variable QPN + varToVariable (P qpn) = PackageVar qpn + varToVariable (F (FN qpn fn)) = FlagVar qpn fn + varToVariable (S (SN qpn stanza)) = StanzaVar qpn stanza + +-- | Reduce the branching degree of the search tree by removing all choices +-- after the first successful choice at each level. The returned tree is the +-- minimal subtree containing the path to the first backjump. +pruneAfterFirstSuccess :: EndoTreeTrav d c +pruneAfterFirstSuccess = go + where + go (PChoiceF qpn rdm gr ts) = PChoiceF qpn rdm gr (W.takeUntil active ts) + go (FChoiceF qfn rdm gr w m d ts) = FChoiceF qfn rdm gr w m d (W.takeUntil active ts) + go (SChoiceF qsn rdm gr w ts) = SChoiceF qsn rdm gr w (W.takeUntil active ts) + go x = x + +-- | Always choose the first goal in the list next, abandoning all +-- other choices. +-- +-- This is unnecessary for the default search strategy, because +-- it descends only into the first goal choice anyway, +-- but may still make sense to just reduce the tree size a bit. +firstGoal :: EndoTreeTrav d c +firstGoal = go + where + go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.firstOnly xs) + go x = x + -- Note that we keep empty choice nodes, because they mean success. + +-- | Transformation that tries to make a decision on base as early as +-- possible by pruning all other goals when base is available. In nearly +-- all cases, there's a single choice for the base package. Also, fixing +-- base early should lead to better error messages. +preferBaseGoalChoice :: EndoTreeTrav d c +preferBaseGoalChoice = go + where + go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.filterIfAnyByKeys isBase xs) + go x = x + + isBase :: Goal QPN -> Bool + isBase (Goal (P (Q _pp pn)) _) = unPN pn == "base" + isBase _ = False + +-- | Deal with setup and build-tool-depends dependencies after regular dependencies, +-- so we will link setup/exe dependencies against package dependencies when possible +deferSetupExeChoices :: EndoTreeTrav d c +deferSetupExeChoices = go + where + go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.preferByKeys noSetupOrExe xs) + 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 + +-- | Transformation that tries to avoid making weak flag choices early. +-- Weak flags are trivial flags (not influencing dependencies) or such +-- flags that are explicitly declared to be weak in the index. +deferWeakFlagChoices :: EndoTreeTrav d c +deferWeakFlagChoices = go + where + go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.prefer noWeakFlag (P.prefer noWeakStanza xs)) + go x = x + + noWeakStanza :: Tree d c -> Bool + noWeakStanza (SChoice _ _ _ (WeakOrTrivial True) _) = False + noWeakStanza _ = True + + noWeakFlag :: Tree d c -> Bool + noWeakFlag (FChoice _ _ _ (WeakOrTrivial True) _ _ _) = False + noWeakFlag _ = True + +-- | Transformation that prefers goals with lower branching degrees. +-- +-- When a goal choice node has at least one goal with zero or one children, this +-- function prunes all other goals. This transformation can help the solver find +-- a solution in fewer steps by allowing it to backtrack sooner when it is +-- exploring a subtree with no solutions. However, each step is more expensive. +preferReallyEasyGoalChoices :: EndoTreeTrav d c +preferReallyEasyGoalChoices = go + where + go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.filterIfAny zeroOrOneChoices xs) + go x = x + +-- | Monad used internally in enforceSingleInstanceRestriction +-- +-- For each package instance we record the goal for which we picked a concrete +-- instance. The SIR means that for any package instance there can only be one. +type EnforceSIR = Reader (Map (PI PN) QPN) + +-- | Enforce ghc's single instance restriction +-- +-- From the solver's perspective, this means that for any package instance +-- (that is, package name + package version) there can be at most one qualified +-- goal resolving to that instance (there may be other goals _linking_ to that +-- instance however). +enforceSingleInstanceRestriction :: Tree d c -> Tree d c +enforceSingleInstanceRestriction = (`runReader` M.empty) . go + where + go :: Tree d c -> EnforceSIR (Tree d c) + + -- We just verify package choices. + go (PChoice qpn rdm gr cs) = + PChoice qpn rdm gr <$> sequenceA (W.mapWithKey (goP qpn) (fmap go cs)) + go (FChoice qfn rdm y t m d ts) = + FChoice qfn rdm y t m d <$> traverse go ts + go (SChoice qsn rdm y t ts) = + SChoice qsn rdm y t <$> traverse go ts + go (GoalChoice rdm ts) = + GoalChoice rdm <$> traverse go ts + go x@(Fail _ _) = return x + go x@(Done _ _) = return x + + -- The check proper + goP :: QPN -> POption -> EnforceSIR (Tree d c) -> EnforceSIR (Tree d c) + goP qpn@(Q _ pn) (POption i linkedTo) r = do + let inst = PI pn i + env <- ask + case (linkedTo, M.lookup inst env) of + (Just _, _) -> + -- For linked nodes we don't check anything + r + (Nothing, Nothing) -> + -- Not linked, not already used + local (M.insert inst qpn) r + (Nothing, Just qpn') -> do + -- Not linked, already used. This is an error + return $ Fail (CS.union (varToConflictSet (P qpn)) (varToConflictSet (P qpn'))) MultipleInstances diff --git a/cabal/cabal-install-solver/src/Distribution/Solver/Modular/RetryLog.hs b/cabal/cabal-install-solver/src/Distribution/Solver/Modular/RetryLog.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/src/Distribution/Solver/Modular/RetryLog.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE Rank2Types #-} +module Distribution.Solver.Modular.RetryLog + ( RetryLog + , toProgress + , fromProgress + , mapFailure + , retry + , failWith + , succeedWith + , continueWith + , tryWith + ) where + +import Distribution.Solver.Compat.Prelude +import Prelude () + +import Distribution.Solver.Modular.Message +import Distribution.Solver.Types.Progress + +-- | 'Progress' as a difference list that allows efficient appends at failures. +newtype RetryLog step fail done = RetryLog { + unRetryLog :: forall fail2 . (fail -> Progress step fail2 done) + -> Progress step fail2 done + } + +-- | /O(1)/. Convert a 'RetryLog' to a 'Progress'. +toProgress :: RetryLog step fail done -> Progress step fail done +toProgress (RetryLog f) = f Fail + +-- | /O(N)/. Convert a 'Progress' to a 'RetryLog'. +fromProgress :: Progress step fail done -> RetryLog step fail done +fromProgress l = RetryLog $ \f -> go f l + where + go :: (fail1 -> Progress step fail2 done) + -> Progress step fail1 done + -> Progress step fail2 done + go _ (Done d) = Done d + go f (Fail failure) = f failure + go f (Step m ms) = Step m (go f ms) + +-- | /O(1)/. Apply a function to the failure value in a log. +mapFailure :: (fail1 -> fail2) + -> RetryLog step fail1 done + -> RetryLog step fail2 done +mapFailure f l = retry l $ \failure -> RetryLog $ \g -> g (f failure) + +-- | /O(1)/. If the first log leads to failure, continue with the second. +retry :: RetryLog step fail1 done + -> (fail1 -> RetryLog step fail2 done) + -> RetryLog step fail2 done +retry (RetryLog f) g = + RetryLog $ \extendLog -> f $ \failure -> unRetryLog (g failure) extendLog + +-- | /O(1)/. Create a log with one message before a failure. +failWith :: step -> fail -> RetryLog step fail done +failWith m failure = RetryLog $ \f -> Step m (f failure) + +-- | /O(1)/. Create a log with one message before a success. +succeedWith :: step -> done -> RetryLog step fail done +succeedWith m d = RetryLog $ const $ Step m (Done d) + +-- | /O(1)/. Prepend a message to a log. +continueWith :: step + -> RetryLog step fail done + -> RetryLog step fail done +continueWith m (RetryLog f) = RetryLog $ Step m . f + +-- | /O(1)/. Prepend the given message and 'Enter' to the log, and insert +-- 'Leave' before the failure if the log fails. +tryWith :: Message -> RetryLog Message fail done -> RetryLog Message fail done +tryWith m f = + RetryLog $ Step m . Step Enter . unRetryLog (retry f (failWith Leave)) diff --git a/cabal/cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs b/cabal/cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs @@ -0,0 +1,269 @@ +{-# LANGUAGE CPP #-} +#ifdef DEBUG_TRACETREE +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +#endif +module Distribution.Solver.Modular.Solver + ( SolverConfig(..) + , solve + , PruneAfterFirstSuccess(..) + ) where + +import Distribution.Solver.Compat.Prelude +import Prelude () + +import qualified Data.Map as M +import qualified Data.List as L +import qualified Data.Set as S +import Distribution.Verbosity + +import Distribution.Compiler (CompilerInfo) + +import Distribution.Solver.Types.PackagePath +import Distribution.Solver.Types.PackagePreferences +import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb) +import Distribution.Solver.Types.LabeledPackageConstraint +import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.Variable + +import Distribution.Solver.Modular.Assignment +import Distribution.Solver.Modular.Builder +import Distribution.Solver.Modular.Cycles +import Distribution.Solver.Modular.Dependency +import Distribution.Solver.Modular.Explore +import Distribution.Solver.Modular.Index +import Distribution.Solver.Modular.Log +import Distribution.Solver.Modular.Message +import Distribution.Solver.Modular.Package +import qualified Distribution.Solver.Modular.Preference as P +import Distribution.Solver.Modular.Validate +import Distribution.Solver.Modular.Linking +import Distribution.Solver.Modular.PSQ (PSQ) +import Distribution.Solver.Modular.RetryLog +import Distribution.Solver.Modular.Tree +import qualified Distribution.Solver.Modular.PSQ as PSQ + +import Distribution.Simple.Setup (BooleanFlag(..)) + +#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 Debug.Trace.Tree (gtraceJson) +import Debug.Trace.Tree.Simple +import Debug.Trace.Tree.Generic +import Debug.Trace.Tree.Assoc (Assoc(..)) +#endif + +-- | Various options for the modular solver. +data SolverConfig = SolverConfig { + reorderGoals :: ReorderGoals, + countConflicts :: CountConflicts, + fineGrainedConflicts :: FineGrainedConflicts, + minimizeConflictSet :: MinimizeConflictSet, + independentGoals :: IndependentGoals, + avoidReinstalls :: AvoidReinstalls, + shadowPkgs :: ShadowPkgs, + strongFlags :: StrongFlags, + allowBootLibInstalls :: AllowBootLibInstalls, + onlyConstrained :: OnlyConstrained, + maxBackjumps :: Maybe Int, + enableBackjumping :: EnableBackjumping, + solveExecutables :: SolveExecutables, + goalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering), + solverVerbosity :: Verbosity, + pruneAfterFirstSuccess :: PruneAfterFirstSuccess +} + +-- | Whether to remove all choices after the first successful choice at each +-- level in the search tree. +newtype PruneAfterFirstSuccess = PruneAfterFirstSuccess Bool + +-- | Run all solver phases. +-- +-- In principle, we have a valid tree after 'validationPhase', which +-- means that every 'Done' node should correspond to valid solution. +-- +-- There is one exception, though, and that is cycle detection, which +-- has been added relatively recently. Cycles are only removed directly +-- before exploration. +-- +solve :: SolverConfig -- ^ solver parameters + -> CompilerInfo + -> Index -- ^ all available packages as an index + -> 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 = + explorePhase . + traceTree "cycles.json" id . + detectCycles . + traceTree "heuristics.json" id . + trav ( + heuristicsPhase . + preferencesPhase . + validationPhase + ) . + traceTree "semivalidated.json" id . + validationCata . + traceTree "pruned.json" id . + trav prunePhase . + traceTree "build.json" id $ + buildPhase + where + explorePhase = backjumpAndExplore (maxBackjumps sc) + (enableBackjumping sc) + (fineGrainedConflicts sc) + (countConflicts sc) + idx + detectCycles = detectCyclesPhase + heuristicsPhase = + let + sortGoals = case goalOrder sc of + Nothing -> goalChoiceHeuristics . + P.deferSetupExeChoices . + P.deferWeakFlagChoices . + P.preferBaseGoalChoice + Just order -> P.firstGoal . + P.sortGoals order + PruneAfterFirstSuccess prune = pruneAfterFirstSuccess sc + in sortGoals . + (if prune then P.pruneAfterFirstSuccess else id) + preferencesPhase = P.preferLinked . + P.preferPackagePreferences userPrefs + validationPhase = P.enforcePackageConstraints userConstraints . + P.enforceManualFlags userConstraints + validationCata = P.enforceSingleInstanceRestriction . + validateLinking idx . + validateTree cinfo idx pkgConfigDB + prunePhase = (if asBool (avoidReinstalls sc) then P.avoidReinstalls (const True) else id) . + (if asBool (allowBootLibInstalls sc) + then id + else P.requireInstalled (`elem` nonInstallable)) . + (case onlyConstrained sc of + OnlyConstrainedAll -> + P.onlyConstrained pkgIsExplicit + OnlyConstrainedNone -> + id) + buildPhase = buildTree idx (independentGoals sc) (S.toList userGoals) + + allExplicit = M.keysSet userConstraints `S.union` userGoals + + pkgIsExplicit :: PN -> Bool + pkgIsExplicit pn = S.member pn allExplicit + + -- packages that can never be installed or upgraded + -- If you change this enumeration, make sure to update the list in + -- "Distribution.Client.Dependency" as well + nonInstallable :: [PackageName] + nonInstallable = + L.map mkPackageName + [ "base" + , "ghc-prim" + , "integer-gmp" + , "integer-simple" + , "template-haskell" + ] + + -- When --reorder-goals is set, we use preferReallyEasyGoalChoices, which + -- prefers (keeps) goals only if the have 0 or 1 enabled choice. + -- + -- In the past, we furthermore used P.firstGoal to trim down the goal choice nodes + -- to just a single option. This was a way to work around a space leak that was + -- unnecessary and is now fixed, so we no longer do it. + -- + -- If --count-conflicts is active, it will then choose among the remaining goals + -- the one that has been responsible for the most conflicts so far. + -- + -- Otherwise, we simply choose the first remaining goal. + -- + goalChoiceHeuristics + | asBool (reorderGoals sc) = P.preferReallyEasyGoalChoices + | otherwise = id {- P.firstGoal -} + +-- | Dump solver tree to a file (in debugging mode) +-- +-- This only does something if the @debug-tracetree@ configure argument was +-- given; otherwise this is just the identity function. +traceTree :: +#ifdef DEBUG_TRACETREE + GSimpleTree a => +#endif + FilePath -- ^ Output file + -> (a -> a) -- ^ Function to summarize the tree before dumping + -> a -> a +#ifdef DEBUG_TRACETREE +traceTree = gtraceJson +#else +traceTree _ _ = id +#endif + +#ifdef DEBUG_TRACETREE +instance GSimpleTree (Tree d c) where + fromGeneric = go + where + go :: Tree d c -> SimpleTree + go (PChoice qpn _ _ psq) = Node "P" $ Assoc $ L.map (uncurry (goP qpn)) $ psqToList psq + go (FChoice _ _ _ _ _ _ psq) = Node "F" $ Assoc $ L.map (uncurry goFS) $ psqToList psq + go (SChoice _ _ _ _ psq) = Node "S" $ Assoc $ L.map (uncurry goFS) $ psqToList psq + go (GoalChoice _ psq) = Node "G" $ Assoc $ L.map (uncurry goG) $ PSQ.toList psq + go (Done _rdm _s) = Node "D" $ Assoc [] + go (Fail cs _reason) = Node "X" $ Assoc [("CS", Leaf $ goCS cs)] + + psqToList :: W.WeightedPSQ w k v -> [(k, v)] + psqToList = L.map (\(_, k, v) -> (k, v)) . W.toList + + -- Show package choice + goP :: QPN -> POption -> Tree d c -> (String, SimpleTree) + goP _ (POption (I ver _loc) Nothing) subtree = (T.display ver, go subtree) + goP (Q _ pn) (POption _ (Just pp)) subtree = (showQPN (Q pp pn), go subtree) + + -- Show flag or stanza choice + goFS :: Bool -> Tree d c -> (String, SimpleTree) + goFS val subtree = (show val, go subtree) + + -- Show goal choice + goG :: Goal QPN -> Tree d c -> (String, SimpleTree) + goG (Goal var gr) subtree = (showVar var ++ " (" ++ shortGR gr ++ ")", go subtree) + + -- Variation on 'showGR' that produces shorter strings + -- (Actually, QGoalReason records more info than necessary: we only need + -- to know the variable that introduced the goal, not the value assigned + -- to that variable) + shortGR :: QGoalReason -> String + shortGR UserGoal = "user" + shortGR (DependencyGoal dr) = showDependencyReason dr + + -- Show conflict set + goCS :: ConflictSet -> String + goCS cs = "{" ++ (intercalate "," . L.map showVar . CS.toList $ cs) ++ "}" +#endif + +-- | Replace all goal reasons with a dummy goal reason in the tree +-- +-- This is useful for debugging (when experimenting with the impact of GRs) +_removeGR :: Tree d c -> Tree d QGoalReason +_removeGR = trav go + where + go :: TreeF d c (Tree d QGoalReason) -> TreeF d QGoalReason (Tree d QGoalReason) + go (PChoiceF qpn rdm _ psq) = PChoiceF qpn rdm dummy psq + go (FChoiceF qfn rdm _ a b d psq) = FChoiceF qfn rdm dummy a b d psq + go (SChoiceF qsn rdm _ a psq) = SChoiceF qsn rdm dummy a psq + go (GoalChoiceF rdm psq) = GoalChoiceF rdm (goG psq) + go (DoneF rdm s) = DoneF rdm s + go (FailF cs reason) = FailF cs reason + + goG :: PSQ (Goal QPN) (Tree d QGoalReason) -> PSQ (Goal QPN) (Tree d QGoalReason) + goG = PSQ.fromList + . L.map (\(Goal var _, subtree) -> (Goal var dummy, subtree)) + . PSQ.toList + + dummy :: QGoalReason + dummy = + DependencyGoal $ + DependencyReason + (Q (PackagePath DefaultNamespace QualToplevel) (mkPackageName "$")) + M.empty S.empty diff --git a/cabal/cabal-install-solver/src/Distribution/Solver/Modular/Tree.hs b/cabal/cabal-install-solver/src/Distribution/Solver/Modular/Tree.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/src/Distribution/Solver/Modular/Tree.hs @@ -0,0 +1,204 @@ +{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} +module Distribution.Solver.Modular.Tree + ( POption(..) + , Tree(..) + , TreeF(..) + , Weight + , FailReason(..) + , ConflictingDep(..) + , ana + , cata + , inn + , innM + , para + , trav + , zeroOrOneChoices + , active + , TreeTrav + , EndoTreeTrav + ) where + +import Control.Monad hiding (mapM, sequence) +import Data.Foldable +import Data.Traversable +import Prelude hiding (foldr, mapM, sequence) + +import Distribution.Solver.Modular.Dependency +import Distribution.Solver.Modular.Flag +import Distribution.Solver.Modular.Package +import Distribution.Solver.Modular.PSQ (PSQ) +import Distribution.Solver.Modular.Version +import Distribution.Solver.Modular.WeightedPSQ (WeightedPSQ) +import qualified Distribution.Solver.Modular.WeightedPSQ as W +import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.Flag +import Distribution.Solver.Types.PackagePath +import Distribution.Types.PkgconfigVersionRange +import Distribution.Types.UnitId (UnitId) +import Language.Haskell.Extension (Extension, Language) + +type Weight = Double + +-- | Type of the search tree. Inlining the choice nodes for now. Weights on +-- package, flag, and stanza choices control the traversal order. +-- +-- The tree can hold additional data on 'Done' nodes (type 'd') and choice nodes +-- (type 'c'). For example, during the final traversal, choice nodes contain the +-- variables that introduced the choices, and 'Done' nodes contain the +-- assignments for all variables. +-- +-- 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)) + + -- | 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 whether or not to enable a stanza + | SChoice QSN RevDepMap c WeakOrTrivial (WeightedPSQ [Weight] Bool (Tree d c)) + + -- | Choose which choice to make next + -- + -- Invariants: + -- + -- * PSQ should never be empty + -- * For each choice we additionally record the 'QGoalReason' why we are + -- introducing that goal into tree. Note that most of the time we are + -- working with @Tree QGoalReason@; in that case, we must have the + -- 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)) + + -- | We're done -- we found a solution! + | Done RevDepMap d + + -- | We failed to find a solution in this path through the tree + | Fail ConflictSet FailReason + +-- | A package option is a package instance with an optional linking annotation +-- +-- The modular solver has a number of package goals to solve for, and can only +-- pick a single package version for a single goal. In order to allow to +-- install multiple versions of the same package as part of a single solution +-- the solver uses qualified goals. For example, @0.P@ and @1.P@ might both +-- be qualified goals for @P@, allowing to pick a difference version of package +-- @P@ for @0.P@ and @1.P@. +-- +-- Linking is an essential part of this story. In addition to picking a specific +-- version for @1.P@, the solver can also decide to link @1.P@ to @0.P@ (or +-- vice versa). It means that @1.P@ and @0.P@ really must be the very same package +-- (and hence must have the same build time configuration, and their +-- dependencies must also be the exact same). +-- +-- See for details. +data POption = POption I (Maybe PackagePath) + deriving (Eq, Show) + +data FailReason = UnsupportedExtension Extension + | UnsupportedLanguage Language + | MissingPkgconfigPackage PkgconfigName PkgconfigVersionRange + | NewPackageDoesNotMatchExistingConstraint ConflictingDep + | ConflictingConstraints ConflictingDep ConflictingDep + | NewPackageIsMissingRequiredComponent ExposedComponent (DependencyReason QPN) + | NewPackageHasPrivateRequiredComponent ExposedComponent (DependencyReason QPN) + | NewPackageHasUnbuildableRequiredComponent ExposedComponent (DependencyReason QPN) + | PackageRequiresMissingComponent QPN ExposedComponent + | PackageRequiresPrivateComponent QPN ExposedComponent + | PackageRequiresUnbuildableComponent QPN ExposedComponent + | CannotInstall + | CannotReinstall + | NotExplicit + | Shadowed + | Broken UnitId + | UnknownPackage + | GlobalConstraintVersion VR ConstraintSource + | GlobalConstraintInstalled ConstraintSource + | GlobalConstraintSource ConstraintSource + | GlobalConstraintFlag ConstraintSource + | ManualFlag + | MalformedFlagChoice QFN + | MalformedStanzaChoice QSN + | EmptyGoalChoice + | Backjump + | MultipleInstances + | DependenciesNotLinked String + | CyclicDependencies + | UnsupportedSpecVer Ver + deriving (Eq, Show) + +-- | Information about a dependency involved in a conflict, for error messages. +data ConflictingDep = ConflictingDep (DependencyReason QPN) (PkgComponent QPN) CI + deriving (Eq, Show) + +-- | Functor for the tree type. 'a' is the type of nodes' children. 'd' and 'c' +-- have the same meaning as in 'Tree'. +data TreeF d c a = + PChoiceF QPN RevDepMap c (WeightedPSQ [Weight] POption a) + | FChoiceF QFN RevDepMap c WeakOrTrivial FlagType Bool (WeightedPSQ [Weight] Bool a) + | SChoiceF QSN RevDepMap c WeakOrTrivial (WeightedPSQ [Weight] Bool a) + | GoalChoiceF RevDepMap (PSQ (Goal QPN) a) + | DoneF RevDepMap d + | FailF ConflictSet FailReason + deriving (Functor, Foldable, Traversable) + +out :: Tree d c -> TreeF d c (Tree d c) +out (PChoice p s i ts) = PChoiceF p s i ts +out (FChoice p s i b m d ts) = FChoiceF p s i b m d ts +out (SChoice p s i b ts) = SChoiceF p s i b ts +out (GoalChoice s ts) = GoalChoiceF s ts +out (Done x s ) = DoneF x s +out (Fail c x ) = FailF c x + +inn :: TreeF d c (Tree d c) -> Tree d c +inn (PChoiceF p s i ts) = PChoice p s i ts +inn (FChoiceF p s i b m d ts) = FChoice p s i b m d ts +inn (SChoiceF p s i b ts) = SChoice p s i b ts +inn (GoalChoiceF s ts) = GoalChoice s ts +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 (DoneF x s ) = return $ Done x s +innM (FailF c x ) = return $ Fail c x + +-- | Determines whether a tree is active, i.e., isn't a failure node. +active :: Tree d c -> Bool +active (Fail _ _) = False +active _ = True + +-- | Approximates the number of active choices that are available in a node. +-- Note that we count goal choices as having one choice, always. +zeroOrOneChoices :: Tree d c -> Bool +zeroOrOneChoices (PChoice _ _ _ ts) = W.isZeroOrOne (W.filter active ts) +zeroOrOneChoices (FChoice _ _ _ _ _ _ ts) = W.isZeroOrOne (W.filter active ts) +zeroOrOneChoices (SChoice _ _ _ _ ts) = W.isZeroOrOne (W.filter active ts) +zeroOrOneChoices (GoalChoice _ _ ) = True +zeroOrOneChoices (Done _ _ ) = True +zeroOrOneChoices (Fail _ _ ) = True + +-- | Catamorphism on trees. +cata :: (TreeF d c a -> a) -> Tree d c -> a +cata phi x = (phi . fmap (cata phi) . out) x + +type TreeTrav d c a = TreeF d c (Tree d a) -> TreeF d a (Tree d a) +type EndoTreeTrav d c = TreeTrav d c c + +trav :: TreeTrav d c a -> Tree d c -> Tree d a +trav psi x = cata (inn . psi) x + +-- | Paramorphism on trees. +para :: (TreeF d c (a, Tree d c) -> a) -> Tree d c -> a +para phi = phi . fmap (\ x -> (para phi x, x)) . out + +-- | Anamorphism on trees. +ana :: (a -> TreeF d c a) -> a -> Tree d c +ana psi = inn . fmap (ana psi) . psi diff --git a/cabal/cabal-install-solver/src/Distribution/Solver/Modular/Validate.hs b/cabal/cabal-install-solver/src/Distribution/Solver/Modular/Validate.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/src/Distribution/Solver/Modular/Validate.hs @@ -0,0 +1,590 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE CPP #-} +#ifdef DEBUG_CONFLICT_SETS +{-# LANGUAGE ImplicitParams #-} +#endif +module Distribution.Solver.Modular.Validate (validateTree) where + +-- Validation of the tree. +-- +-- The task here is to make sure all constraints hold. After validation, any +-- assignment returned by exploration of the tree should be a complete valid +-- assignment, i.e., actually constitute a solution. + +import Control.Monad.Reader +import Data.Either (lefts) +import Data.Function (on) + +import qualified Data.List as L +import qualified Data.Set as S + +import Language.Haskell.Extension (Extension, Language) + +import Data.Map.Strict as M +import Distribution.Compiler (CompilerInfo(..)) + +import Distribution.Solver.Modular.Assignment +import qualified Distribution.Solver.Modular.ConflictSet as CS +import Distribution.Solver.Modular.Dependency +import Distribution.Solver.Modular.Flag +import Distribution.Solver.Modular.Index +import Distribution.Solver.Modular.Package +import Distribution.Solver.Modular.Tree +import Distribution.Solver.Modular.Version +import qualified Distribution.Solver.Modular.WeightedPSQ as W + +import Distribution.Solver.Types.PackagePath +import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb, pkgConfigPkgIsPresent) +import Distribution.Types.LibraryName +import Distribution.Types.PkgconfigVersionRange + +#ifdef DEBUG_CONFLICT_SETS +import GHC.Stack (CallStack) +#endif + +-- 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 +-- that for which the preconditions are fulfilled ACTIVE. We maintain a set +-- of currently active constraints that we pass down the node. +-- +-- We aim at detecting inconsistent states as early as possible. +-- +-- Whenever we make a choice, there are two things that need to happen: +-- +-- (1) We must check that the choice is consistent with the currently +-- active constraints. +-- +-- (2) The choice increases the set of active constraints. For the new +-- active constraints, we must check that they are consistent with +-- the current state. +-- +-- We can actually merge (1) and (2) by saying the current choice is +-- a new active constraint, fixing the choice. +-- +-- If a test fails, we have detected an inconsistent state. We can +-- disable the current subtree and do not have to traverse it any further. +-- +-- We need a good way to represent the current state, i.e., the current +-- set of active constraints. Since the main situation where we have to +-- search in it is (1), it seems best to store the state by package: for +-- every package, we store which versions are still allowed. If for any +-- package, we have inconsistent active constraints, we can also stop. +-- This is a particular way to read task (2): +-- +-- (2, weak) We only check if the new constraints are consistent with +-- the choices we've already made, and add them to the active set. +-- +-- (2, strong) We check if the new constraints are consistent with the +-- choices we've already made, and the constraints we already have. +-- +-- It currently seems as if we're implementing the weak variant. However, +-- when used together with 'preferEasyGoalChoices', we will find an +-- inconsistent state in the very next step. +-- +-- What do we do about flags? +-- +-- Like for packages, we store the flag choices we have already made. +-- Now, regarding (1), we only have to test whether we've decided the +-- current flag before. Regarding (2), the interesting bit is in discovering +-- the new active constraints. To this end, we look up the constraints for +-- the package the flag belongs to, and traverse its flagged dependencies. +-- Wherever we find the flag in question, we start recording dependencies +-- underneath as new active dependencies. If we encounter other flags, we +-- check if we've chosen them already and either proceed or stop. + +-- | The state needed during validation. +data ValidateState = VS { + supportedExt :: Extension -> Bool, + supportedLang :: Language -> Bool, + presentPkgs :: PkgconfigName -> PkgconfigVersionRange -> Bool, + index :: Index, + + -- Saved, scoped, dependencies. Every time 'validate' makes a package choice, + -- it qualifies the package's dependencies and saves them in this map. Then + -- the qualified dependencies are available for subsequent flag and stanza + -- choices for the same package. + saved :: Map QPN (FlaggedDeps QPN), + + pa :: PreAssignment, + + -- Map from package name to the components that are provided by the chosen + -- instance of that package, and whether those components are visible and + -- buildable. + availableComponents :: Map QPN (Map ExposedComponent ComponentInfo), + + -- Map from package name to the components that are required from that + -- package. + requiredComponents :: Map QPN ComponentDependencyReasons, + + qualifyOptions :: QualifyOptions +} + +newtype Validate a = Validate (Reader ValidateState a) + deriving (Functor, Applicative, Monad, MonadReader ValidateState) + +runValidate :: Validate a -> ValidateState -> a +runValidate (Validate r) = runReader r + +-- | A preassignment comprises knowledge about variables, but not +-- necessarily fixed values. +data PreAssignment = PA PPreAssignment FAssignment SAssignment + +-- | A (partial) package preassignment. Qualified package names +-- are associated with MergedPkgDeps. +type PPreAssignment = Map QPN MergedPkgDep + +-- | A dependency on a component, including its DependencyReason. +data PkgDep = PkgDep (DependencyReason QPN) (PkgComponent QPN) CI + +-- | Map from component name to one of the reasons that the component is +-- required. +type ComponentDependencyReasons = Map ExposedComponent (DependencyReason QPN) + +-- | MergedPkgDep records constraints about the instances that can still be +-- chosen, and in the extreme case fixes a concrete instance. Otherwise, it is a +-- list of version ranges paired with the goals / variables that introduced +-- them. It also records whether a package is a build-tool dependency, for each +-- reason that it was introduced. +-- +-- It is important to store the component name with the version constraint, for +-- error messages, because whether something is a build-tool dependency affects +-- its qualifier, which affects which constraint is applied. +data MergedPkgDep = + MergedDepFixed ExposedComponent (DependencyReason QPN) I + | MergedDepConstrained [VROrigin] + +-- | Version ranges paired with origins. +type VROrigin = (VR, ExposedComponent, DependencyReason QPN) + +-- | The information needed to create a 'Fail' node. +type Conflict = (ConflictSet, FailReason) + +validate :: Tree d c -> Validate (Tree d c) +validate = go + where + go :: Tree d c -> Validate (Tree d c) + + go (PChoice qpn rdm gr ts) = PChoice qpn rdm gr <$> W.traverseWithKey (\k -> goP qpn k . go) ts + go (FChoice qfn rdm gr b m d ts) = + do + -- Flag choices may occur repeatedly (because they can introduce new constraints + -- in various places). However, subsequent choices must be consistent. We thereby + -- collapse repeated flag choice nodes. + PA _ pfa _ <- asks pa -- obtain current flag-preassignment + case M.lookup qfn pfa of + Just rb -> -- flag has already been assigned; collapse choice to the correct branch + case W.lookup rb ts of + Just t -> goF qfn rb (go t) + Nothing -> return $ Fail (varToConflictSet (F qfn)) (MalformedFlagChoice qfn) + Nothing -> -- flag choice is new, follow both branches + FChoice qfn rdm gr b m d <$> W.traverseWithKey (\k -> goF qfn k . go) ts + go (SChoice qsn rdm gr b ts) = + do + -- Optional stanza choices are very similar to flag choices. + PA _ _ psa <- asks pa -- obtain current stanza-preassignment + case M.lookup qsn psa of + Just rb -> -- stanza choice has already been made; collapse choice to the correct branch + case W.lookup rb ts of + Just t -> goS qsn rb (go t) + Nothing -> return $ Fail (varToConflictSet (S qsn)) (MalformedStanzaChoice qsn) + Nothing -> -- stanza choice is new, follow both branches + SChoice qsn rdm gr b <$> W.traverseWithKey (\k -> goS qsn k . go) ts + + -- We don't need to do anything for goal choices or failure nodes. + go (GoalChoice rdm ts) = GoalChoice rdm <$> traverse go ts + go (Done rdm s ) = pure (Done rdm s) + go (Fail c fr ) = pure (Fail c fr) + + -- 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 + PA ppa pfa psa <- asks pa -- obtain current preassignment + extSupported <- asks supportedExt -- obtain the supported extensions + langSupported <- asks supportedLang -- obtain the supported languages + pkgPresent <- asks presentPkgs -- obtain the present pkg-config pkgs + idx <- asks index -- obtain the index + svd <- asks saved -- obtain saved dependencies + aComps <- asks availableComponents + rComps <- asks requiredComponents + qo <- asks qualifyOptions + -- obtain dependencies and index-dictated exclusions introduced by the choice + let (PInfo deps comps _ mfr) = idx ! pn ! i + -- qualify the deps in the current scope + let qdeps = qualifyDeps qo 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 + -- In case we continue, we save the scoped dependencies + let nsvd = M.insert qpn qdeps svd + case mfr of + Just fr -> -- The index marks this as an invalid choice. We can stop. + return (Fail (varToConflictSet (P qpn)) fr) + Nothing -> + let newDeps :: Either Conflict (PPreAssignment, Map QPN ComponentDependencyReasons) + newDeps = do + nppa <- mnppa + rComps' <- extendRequiredComponents qpn aComps rComps newactives + checkComponentsInNewPackage (M.findWithDefault M.empty qpn rComps) qpn comps + return (nppa, rComps') + in case newDeps of + Left (c, fr) -> -- We have an inconsistency. We can stop. + return (Fail c fr) + Right (nppa, rComps') -> -- We have an updated partial assignment for the recursive validation. + local (\ s -> s { pa = PA nppa pfa psa + , saved = nsvd + , availableComponents = M.insert qpn comps aComps + , requiredComponents = rComps' + }) r + + -- 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 + PA ppa pfa psa <- asks pa -- obtain current preassignment + extSupported <- asks supportedExt -- obtain the supported extensions + langSupported <- asks supportedLang -- obtain the supported languages + pkgPresent <- asks presentPkgs -- obtain the present pkg-config pkgs + svd <- asks saved -- obtain saved dependencies + aComps <- asks availableComponents + rComps <- asks requiredComponents + -- Note that there should be saved dependencies for the package in question, + -- because while building, we do not choose flags before we see the packages + -- that define them. + let qdeps = svd ! qpn + -- We take the *saved* dependencies, because these have been qualified in the + -- correct scope. + -- + -- Extend the flag assignment + let npfa = M.insert qfn b pfa + -- We now try to get the new active dependencies we might learn about because + -- we have chosen a new flag. + 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 + case liftM2 (,) mnppa mNewRequiredComps of + Left (c, fr) -> return (Fail c fr) -- inconsistency found + Right (nppa, rComps') -> + local (\ s -> s { pa = PA nppa npfa psa, requiredComponents = rComps' }) r + + -- 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 + PA ppa pfa psa <- asks pa -- obtain current preassignment + extSupported <- asks supportedExt -- obtain the supported extensions + langSupported <- asks supportedLang -- obtain the supported languages + pkgPresent <- asks presentPkgs -- obtain the present pkg-config pkgs + svd <- asks saved -- obtain saved dependencies + aComps <- asks availableComponents + rComps <- asks requiredComponents + -- Note that there should be saved dependencies for the package in question, + -- because while building, we do not choose flags before we see the packages + -- that define them. + let qdeps = svd ! qpn + -- We take the *saved* dependencies, because these have been qualified in the + -- correct scope. + -- + -- Extend the flag assignment + let npsa = M.insert qsn b psa + -- We now try to get the new active dependencies we might learn about because + -- we have chosen a new flag. + 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 + case liftM2 (,) mnppa mNewRequiredComps of + Left (c, fr) -> return (Fail c fr) -- inconsistency found + Right (nppa, rComps') -> + local (\ s -> s { pa = PA nppa pfa npsa, requiredComponents = rComps' }) r + +-- | Check that a newly chosen package instance contains all components that +-- are required from that package so far. The components must also be visible +-- and buildable. +checkComponentsInNewPackage :: ComponentDependencyReasons + -> QPN + -> Map ExposedComponent ComponentInfo + -> Either Conflict () +checkComponentsInNewPackage required qpn providedComps = + case M.toList $ deleteKeys (M.keys providedComps) required of + (missingComp, dr) : _ -> + Left $ mkConflict missingComp dr NewPackageIsMissingRequiredComponent + [] -> + let failures = lefts + [ case () of + _ | compIsVisible compInfo == IsVisible False -> + Left $ mkConflict comp dr NewPackageHasPrivateRequiredComponent + | compIsBuildable compInfo == IsBuildable False -> + Left $ mkConflict comp dr NewPackageHasUnbuildableRequiredComponent + | otherwise -> Right () + | let merged = M.intersectionWith (,) required providedComps + , (comp, (dr, compInfo)) <- M.toList merged ] + in case failures of + failure : _ -> Left failure + [] -> Right () + where + mkConflict :: ExposedComponent + -> DependencyReason QPN + -> (ExposedComponent -> DependencyReason QPN -> FailReason) + -> Conflict + mkConflict comp dr mkFailure = + (CS.insert (P qpn) (dependencyReasonToConflictSet dr), mkFailure comp dr) + + deleteKeys :: Ord k => [k] -> Map k v -> Map k v + deleteKeys ks m = L.foldr M.delete m ks + +-- | 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 fa sa deps = do + d <- deps + case d of + Simple sd _ -> return sd + Flagged qfn _ td fd -> case M.lookup qfn fa of + Nothing -> mzero + Just True -> extractAllDeps fa sa td + Just False -> extractAllDeps fa sa fd + Stanza qsn td -> case M.lookup qsn sa of + Nothing -> mzero + Just True -> extractAllDeps fa sa td + Just False -> [] + +-- | 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 v b fa sa = go + where + go :: FlaggedDeps QPN -> [LDep QPN] + go deps = do + d <- deps + case d of + Simple _ _ -> mzero + Flagged qfn' _ td fd + | v == F qfn' -> if b then extractAllDeps fa sa td else extractAllDeps fa sa fd + | otherwise -> case M.lookup qfn' fa of + Nothing -> mzero + Just True -> go td + Just False -> go fd + Stanza qsn' td + | v == S qsn' -> if b then extractAllDeps fa sa td else [] + | otherwise -> case M.lookup qsn' sa of + Nothing -> mzero + Just True -> go td + Just False -> [] + +-- | Extend a package preassignment. +-- +-- Takes the variable that causes the new constraints, a current preassignment +-- and a set of new dependency constraints. +-- +-- We're trying to extend the preassignment with each dependency one by one. +-- Each dependency is for a particular variable. We check if we already have +-- constraints for that variable in the current preassignment. If so, we're +-- trying to merge the constraints. +-- +-- Either returns a witness of the conflict that would arise during the merge, +-- or the successfully extended assignment. +extend :: (Extension -> Bool) -- ^ is a given extension supported + -> (Language -> Bool) -- ^ is a given language supported + -> (PkgconfigName -> PkgconfigVersionRange -> Bool) -- ^ is a given pkg-config requirement satisfiable + -> [LDep QPN] + -> PPreAssignment + -> Either Conflict PPreAssignment +extend extSupported langSupported pkgPresent newactives ppa = foldM extendSingle ppa newactives + where + + extendSingle :: PPreAssignment -> LDep QPN -> Either Conflict PPreAssignment + extendSingle a (LDep dr (Ext ext )) = + if extSupported ext then Right a + else Left (dependencyReasonToConflictSet dr, UnsupportedExtension ext) + extendSingle a (LDep dr (Lang lang)) = + if langSupported lang then Right a + else Left (dependencyReasonToConflictSet dr, UnsupportedLanguage lang) + extendSingle a (LDep dr (Pkg pn vr)) = + if pkgPresent pn vr then Right a + else Left (dependencyReasonToConflictSet dr, MissingPkgconfigPackage pn vr) + extendSingle a (LDep dr (Dep dep@(PkgComponent qpn _) ci)) = + let mergedDep = M.findWithDefault (MergedDepConstrained []) qpn a + in case (\ x -> M.insert qpn x a) <$> merge mergedDep (PkgDep dr dep ci) of + Left (c, (d, d')) -> Left (c, ConflictingConstraints d d') + Right x -> Right x + +-- | Extend a package preassignment with a package choice. For example, when +-- the solver chooses foo-2.0, it tries to add the constraint foo==2.0. +-- +-- TODO: The new constraint is implemented as a dependency from foo to foo's +-- main library. That isn't correct, because foo might only be needed as a build +-- tool dependency. The implementation may need to change when we support +-- component-based dependency solving. +extendWithPackageChoice :: PI QPN -> PPreAssignment -> Either Conflict PPreAssignment +extendWithPackageChoice (PI qpn i) ppa = + let mergedDep = M.findWithDefault (MergedDepConstrained []) qpn ppa + newChoice = PkgDep (DependencyReason qpn M.empty S.empty) + (PkgComponent qpn (ExposedLib LMainLibName)) + (Fixed i) + in case (\ x -> M.insert qpn x ppa) <$> merge mergedDep newChoice of + Left (c, (d, _d')) -> -- Don't include the package choice in the + -- FailReason, because it is redundant. + Left (c, NewPackageDoesNotMatchExistingConstraint d) + Right x -> Right x + +-- | Merge constrained instances. We currently adopt a lazy strategy for +-- merging, i.e., we only perform actual checking if one of the two choices +-- is fixed. If the merge fails, we return a conflict set indicating the +-- variables responsible for the failure, as well as the two conflicting +-- fragments. +-- +-- Note that while there may be more than one conflicting pair of version +-- ranges, we only return the first we find. +-- +-- The ConflictingDeps are returned in order, i.e., the first describes the +-- conflicting part of the MergedPkgDep, and the second describes the PkgDep. +-- +-- TODO: Different pairs might have different conflict sets. We're +-- obviously interested to return a conflict that has a "better" conflict +-- set in the sense the it contains variables that allow us to backjump +-- further. We might apply some heuristics here, such as to change the +-- order in which we check the constraints. +merge :: +#ifdef DEBUG_CONFLICT_SETS + (?loc :: CallStack) => +#endif + MergedPkgDep -> PkgDep -> Either (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep +merge (MergedDepFixed comp1 vs1 i1) (PkgDep vs2 (PkgComponent p comp2) ci@(Fixed i2)) + | i1 == i2 = Right $ MergedDepFixed comp1 vs1 i1 + | otherwise = + Left ( (CS.union `on` dependencyReasonToConflictSet) vs1 vs2 + , ( 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)) + | 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 _))) = + go vrOrigins -- I tried "reverse vrOrigins" here, but it seems to slow things down ... + where + go :: [VROrigin] -> Either (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep + go [] = Right (MergedDepFixed comp2 vs2 i) + go ((vr, comp1, vs1) : vros) + | checkVR vr v = go vros + | otherwise = + Left ( createConflictSetForVersionConflict p v vs2 vr vs1 + , ( ConflictingDep vs1 (PkgComponent p comp1) (Constrained vr) + , ConflictingDep vs2 (PkgComponent p comp2) ci ) ) + +merge (MergedDepConstrained vrOrigins) (PkgDep vs2 (PkgComponent _ comp2) (Constrained vr)) = + Right (MergedDepConstrained $ + + -- TODO: This line appends the new version range, to preserve the order used + -- before a refactoring. Consider prepending the version range, if there is + -- no negative performance impact. + vrOrigins ++ [(vr, comp2, vs2)]) + +-- | Creates a conflict set representing a conflict between a version constraint +-- and the fixed version chosen for a package. +createConflictSetForVersionConflict :: QPN + -> Ver + -> DependencyReason QPN + -> VR + -> DependencyReason QPN + -> ConflictSet +createConflictSetForVersionConflict pkg + conflictingVersion + versionDR@(DependencyReason p1 _ _) + conflictingVersionRange + versionRangeDR@(DependencyReason p2 _ _) = + let hasFlagsOrStanzas (DependencyReason _ fs ss) = not (M.null fs) || not (S.null ss) + in + -- The solver currently only optimizes the case where there is a conflict + -- between the version chosen for a package and a version constraint that + -- is not under any flags or stanzas. Here is how we check for this case: + -- + -- (1) Choosing a specific version for a package foo is implemented as + -- adding a dependency from foo to that version of foo (See + -- extendWithPackageChoice), so we check that the DependencyReason + -- contains the current package and no flag or stanza choices. + -- + -- (2) We check that the DependencyReason for the version constraint also + -- contains no flag or stanza choices. + -- + -- When these criteria are not met, we fall back to calling + -- dependencyReasonToConflictSet. + if p1 == pkg && not (hasFlagsOrStanzas versionDR) && not (hasFlagsOrStanzas versionRangeDR) + then let cs1 = dependencyReasonToConflictSetWithVersionConflict + p2 + (CS.OrderedVersionRange conflictingVersionRange) + versionDR + cs2 = dependencyReasonToConflictSetWithVersionConstraintConflict + pkg conflictingVersion versionRangeDR + in cs1 `CS.union` cs2 + else dependencyReasonToConflictSet versionRangeDR `CS.union` dependencyReasonToConflictSet versionDR + +-- | Takes a list of new dependencies and uses it to try to update the map of +-- known component dependencies. It returns a failure when a new dependency +-- requires a component that is missing, private, or unbuildable in a previously +-- chosen package. +extendRequiredComponents :: QPN -- ^ package we extend + -> Map QPN (Map ExposedComponent ComponentInfo) + -> Map QPN ComponentDependencyReasons + -> [LDep QPN] + -> Either Conflict (Map QPN ComponentDependencyReasons) +extendRequiredComponents eqpn available = foldM extendSingle + where + extendSingle :: Map QPN ComponentDependencyReasons + -> LDep QPN + -> Either Conflict (Map QPN ComponentDependencyReasons) + extendSingle required (LDep dr (Dep (PkgComponent qpn comp) _)) = + let compDeps = M.findWithDefault M.empty qpn required + success = Right $ M.insertWith M.union qpn (M.insert comp dr compDeps) required + in -- Only check for the existence of the component if its package has + -- already been chosen. + case M.lookup qpn available of + Just comps -> + case M.lookup comp comps of + Nothing -> + Left $ mkConflict qpn comp dr PackageRequiresMissingComponent + Just compInfo + | compIsVisible compInfo == IsVisible False + , eqpn /= qpn -- package components can depend on other components + -> + Left $ mkConflict qpn comp dr PackageRequiresPrivateComponent + | compIsBuildable compInfo == IsBuildable False -> + Left $ mkConflict qpn comp dr PackageRequiresUnbuildableComponent + | otherwise -> success + Nothing -> success + extendSingle required _ = Right required + + mkConflict :: QPN + -> ExposedComponent + -> DependencyReason QPN + -> (QPN -> ExposedComponent -> FailReason) + -> Conflict + mkConflict qpn comp dr mkFailure = + (CS.insert (P qpn) (dependencyReasonToConflictSet dr), mkFailure qpn comp) + + +-- | Interface. +validateTree :: CompilerInfo -> Index -> 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 + , index = idx + , saved = M.empty + , pa = PA M.empty M.empty M.empty + , availableComponents = M.empty + , requiredComponents = M.empty + , qualifyOptions = defaultQualifyOptions idx + } diff --git a/cabal/cabal-install-solver/src/Distribution/Solver/Modular/Var.hs b/cabal/cabal-install-solver/src/Distribution/Solver/Modular/Var.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/src/Distribution/Solver/Modular/Var.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE DeriveFunctor #-} +module Distribution.Solver.Modular.Var ( + Var(..) + , showVar + , varPN + ) where + +import Prelude hiding (pi) + +import Distribution.Solver.Modular.Flag +import Distribution.Solver.Types.PackagePath + +{------------------------------------------------------------------------------- + Variables +-------------------------------------------------------------------------------} + +-- | The type of variables that play a role in the solver. +-- Note that the tree currently does not use this type directly, +-- and rather has separate tree nodes for the different types of +-- variables. This fits better with the fact that in most cases, +-- these have to be treated differently. +data Var qpn = P qpn | F (FN qpn) | S (SN qpn) + deriving (Eq, Ord, Show, Functor) + +showVar :: Var QPN -> String +showVar (P qpn) = showQPN qpn +showVar (F qfn) = showQFN qfn +showVar (S qsn) = showQSN qsn + +-- | Extract the package name from a Var +varPN :: Var qpn -> qpn +varPN (P qpn) = qpn +varPN (F (FN qpn _)) = qpn +varPN (S (SN qpn _)) = qpn diff --git a/cabal/cabal-install-solver/src/Distribution/Solver/Modular/Version.hs b/cabal/cabal-install-solver/src/Distribution/Solver/Modular/Version.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/src/Distribution/Solver/Modular/Version.hs @@ -0,0 +1,56 @@ +module Distribution.Solver.Modular.Version + ( Ver + , VR + , anyVR + , checkVR + , eqVR + , showVer + , showVR + , simplifyVR + , (.&&.) + , (.||.) + ) where + +import Distribution.Solver.Compat.Prelude +import Prelude () + +import qualified Distribution.Version as CV -- from Cabal +import Distribution.Pretty (prettyShow) + +-- | Preliminary type for versions. +type Ver = CV.Version + +-- | String representation of a version. +showVer :: Ver -> String +showVer = prettyShow + +-- | Version range. Consists of a lower and upper bound. +type VR = CV.VersionRange + +-- | String representation of a version range. +showVR :: VR -> String +showVR = prettyShow + +-- | Unconstrained version range. +anyVR :: VR +anyVR = CV.anyVersion + +-- | Version range fixing a single version. +eqVR :: Ver -> VR +eqVR = CV.thisVersion + +-- | Intersect two version ranges. +(.&&.) :: VR -> VR -> VR +v1 .&&. v2 = simplifyVR $ CV.intersectVersionRanges v1 v2 + +-- | Union of two version ranges. +(.||.) :: VR -> VR -> VR +v1 .||. v2 = simplifyVR $ CV.unionVersionRanges v1 v2 + +-- | Simplify a version range. +simplifyVR :: VR -> VR +simplifyVR = CV.simplifyVersionRange + +-- | Checking a version against a version range. +checkVR :: VR -> Ver -> Bool +checkVR = flip CV.withinRange diff --git a/cabal/cabal-install-solver/src/Distribution/Solver/Modular/WeightedPSQ.hs b/cabal/cabal-install-solver/src/Distribution/Solver/Modular/WeightedPSQ.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/src/Distribution/Solver/Modular/WeightedPSQ.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +module Distribution.Solver.Modular.WeightedPSQ ( + WeightedPSQ + , fromList + , toList + , keys + , weights + , isZeroOrOne + , filter + , lookup + , mapWithKey + , mapWeightsWithKey + , traverseWithKey + , union + , takeUntil + ) where + +import qualified Data.Foldable as F +import qualified Data.List as L +import Data.Ord (comparing) +import qualified Data.Traversable as T +import Prelude hiding (filter, lookup) + +-- | An association list that is sorted by weight. +-- +-- Each element has a key ('k'), value ('v'), and weight ('w'). All operations +-- that add elements or modify weights stably sort the elements by weight. +newtype WeightedPSQ w k v = WeightedPSQ [(w, k, v)] + deriving (Eq, Show, Functor, F.Foldable, T.Traversable) + +-- | /O(N)/. +filter :: (v -> Bool) -> WeightedPSQ k w v -> WeightedPSQ k w v +filter p (WeightedPSQ xs) = WeightedPSQ (L.filter (p . triple_3) xs) + +-- | /O(1)/. Return @True@ if the @WeightedPSQ@ contains zero or one elements. +isZeroOrOne :: WeightedPSQ w k v -> Bool +isZeroOrOne (WeightedPSQ []) = True +isZeroOrOne (WeightedPSQ [_]) = True +isZeroOrOne _ = False + +-- | /O(1)/. Return the elements in order. +toList :: WeightedPSQ w k v -> [(w, k, v)] +toList (WeightedPSQ xs) = xs + +-- | /O(N log N)/. +fromList :: Ord w => [(w, k, v)] -> WeightedPSQ w k v +fromList = WeightedPSQ . L.sortBy (comparing triple_1) + +-- | /O(N)/. Return the weights in order. +weights :: WeightedPSQ w k v -> [w] +weights (WeightedPSQ xs) = L.map triple_1 xs + +-- | /O(N)/. Return the keys in order. +keys :: WeightedPSQ w k v -> [k] +keys (WeightedPSQ xs) = L.map triple_2 xs + +-- | /O(N)/. Return the value associated with the first occurrence of the give +-- key, if it exists. +lookup :: Eq k => k -> WeightedPSQ w k v -> Maybe v +lookup k (WeightedPSQ xs) = triple_3 `fmap` L.find ((k ==) . triple_2) xs + +-- | /O(N log N)/. Update the weights. +mapWeightsWithKey :: Ord w2 + => (k -> w1 -> w2) + -> WeightedPSQ w1 k v + -> WeightedPSQ w2 k v +mapWeightsWithKey f (WeightedPSQ xs) = fromList $ + L.map (\ (w, k, v) -> (f k w, k, v)) xs + +-- | /O(N)/. Update the values. +mapWithKey :: (k -> v1 -> v2) -> WeightedPSQ w k v1 -> WeightedPSQ w k v2 +mapWithKey f (WeightedPSQ xs) = WeightedPSQ $ + L.map (\ (w, k, v) -> (w, k, f k v)) xs + +-- | /O(N)/. Traverse and update values in some applicative functor. +traverseWithKey + :: Applicative f + => (k -> v -> f v') + -> WeightedPSQ w k v + -> f (WeightedPSQ w k v') +traverseWithKey f (WeightedPSQ q) = WeightedPSQ <$> + traverse (\(w,k,v) -> (w,k,) <$> f k v) q + +-- | /O((N + M) log (N + M))/. Combine two @WeightedPSQ@s, preserving all +-- elements. Elements from the first @WeightedPSQ@ come before elements in the +-- second when they have the same weight. +union :: Ord w => WeightedPSQ w k v -> WeightedPSQ w k v -> WeightedPSQ w k v +union (WeightedPSQ xs) (WeightedPSQ ys) = fromList (xs ++ ys) + +-- | /O(N)/. Return the prefix of values ending with the first element that +-- satisfies p, or all elements if none satisfy p. +takeUntil :: forall w k v. (v -> Bool) -> WeightedPSQ w k v -> WeightedPSQ w k v +takeUntil p (WeightedPSQ xs) = WeightedPSQ (go xs) + where + go :: [(w, k, v)] -> [(w, k, v)] + go [] = [] + go (y : ys) = y : if p (triple_3 y) then [] else go ys + +triple_1 :: (x, y, z) -> x +triple_1 (x, _, _) = x + +triple_2 :: (x, y, z) -> y +triple_2 (_, y, _) = y + +triple_3 :: (x, y, z) -> z +triple_3 (_, _, z) = z diff --git a/cabal/cabal-install-solver/src/Distribution/Solver/Types/ComponentDeps.hs b/cabal/cabal-install-solver/src/Distribution/Solver/Types/ComponentDeps.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/src/Distribution/Solver/Types/ComponentDeps.hs @@ -0,0 +1,205 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} + +-- | Fine-grained package dependencies +-- +-- Like many others, this module is meant to be "double-imported": +-- +-- > import Distribution.Solver.Types.ComponentDeps ( +-- > Component +-- > , ComponentDep +-- > , ComponentDeps +-- > ) +-- > import qualified Distribution.Solver.Types.ComponentDeps as CD +module Distribution.Solver.Types.ComponentDeps ( + -- * Fine-grained package dependencies + Component(..) + , componentNameToComponent + , ComponentDep + , ComponentDeps -- opaque + -- ** Constructing ComponentDeps + , empty + , fromList + , singleton + , insert + , zip + , filterDeps + , fromLibraryDeps + , fromSetupDeps + , fromInstalled + -- ** Deconstructing ComponentDeps + , toList + , flatDeps + , nonSetupDeps + , libraryDeps + , setupDeps + , select + , components + ) where + +import Prelude () +import Distribution.Types.UnqualComponentName +import Distribution.Solver.Compat.Prelude hiding (empty,toList,zip) + +import qualified Data.Map as Map +import Data.Foldable (fold) + +import Distribution.Pretty (Pretty (..)) +import qualified Distribution.Types.ComponentName as CN +import qualified Distribution.Types.LibraryName as LN +import qualified Text.PrettyPrint as PP + + +{------------------------------------------------------------------------------- + Types +-------------------------------------------------------------------------------} + +-- | Component of a package. +data Component = + ComponentLib + | ComponentSubLib UnqualComponentName + | ComponentFLib UnqualComponentName + | ComponentExe UnqualComponentName + | ComponentTest UnqualComponentName + | ComponentBench UnqualComponentName + | ComponentSetup + deriving (Show, Eq, Ord, Generic) + +instance Binary Component +instance Structured Component + +instance Pretty Component where + pretty ComponentLib = PP.text "lib" + pretty (ComponentSubLib n) = PP.text "lib:" <<>> pretty n + pretty (ComponentFLib n) = PP.text "flib:" <<>> pretty n + pretty (ComponentExe n) = PP.text "exe:" <<>> pretty n + pretty (ComponentTest n) = PP.text "test:" <<>> pretty n + pretty (ComponentBench n) = PP.text "bench:" <<>> pretty n + pretty ComponentSetup = PP.text "setup" + +-- | Dependency for a single component. +type ComponentDep a = (Component, a) + +-- | Fine-grained dependencies for a package. +-- +-- Typically used as @ComponentDeps [Dependency]@, to represent the list of +-- dependencies for each named component within a package. +-- +newtype ComponentDeps a = ComponentDeps { unComponentDeps :: Map Component a } + deriving (Show, Functor, Eq, Ord, Generic) + +instance Semigroup a => Monoid (ComponentDeps a) where + mempty = ComponentDeps Map.empty + mappend = (<>) + +instance Semigroup a => Semigroup (ComponentDeps a) where + ComponentDeps d <> ComponentDeps d' = + ComponentDeps (Map.unionWith (<>) d d') + +instance Foldable ComponentDeps where + foldMap f = foldMap f . unComponentDeps + +instance Traversable ComponentDeps where + traverse f = fmap ComponentDeps . traverse f . unComponentDeps + +instance Binary a => Binary (ComponentDeps a) +instance Structured a => Structured (ComponentDeps a) + +componentNameToComponent :: CN.ComponentName -> Component +componentNameToComponent (CN.CLibName LN.LMainLibName) = ComponentLib +componentNameToComponent (CN.CLibName (LN.LSubLibName s)) = ComponentSubLib s +componentNameToComponent (CN.CFLibName s) = ComponentFLib s +componentNameToComponent (CN.CExeName s) = ComponentExe s +componentNameToComponent (CN.CTestName s) = ComponentTest s +componentNameToComponent (CN.CBenchName s) = ComponentBench s + +{------------------------------------------------------------------------------- + Construction +-------------------------------------------------------------------------------} + +empty :: ComponentDeps a +empty = ComponentDeps $ Map.empty + +fromList :: Monoid a => [ComponentDep a] -> ComponentDeps a +fromList = ComponentDeps . Map.fromListWith mappend + +singleton :: Component -> a -> ComponentDeps a +singleton comp = ComponentDeps . Map.singleton comp + +insert :: Monoid a => Component -> a -> ComponentDeps a -> ComponentDeps a +insert comp a = ComponentDeps . Map.alter aux comp . unComponentDeps + where + aux Nothing = Just a + aux (Just a') = Just $ a `mappend` a' + +-- | Zip two 'ComponentDeps' together by 'Component', using 'mempty' +-- as the neutral element when a 'Component' is present only in one. +zip + :: (Monoid a, Monoid b) + => ComponentDeps a -> ComponentDeps b -> ComponentDeps (a, b) +zip (ComponentDeps d1) (ComponentDeps d2) = + ComponentDeps $ + Map.mergeWithKey + (\_ a b -> Just (a,b)) + (fmap (\a -> (a, mempty))) + (fmap (\b -> (mempty, b))) + d1 d2 + +-- | Keep only selected components (and their associated deps info). +filterDeps :: (Component -> a -> Bool) -> ComponentDeps a -> ComponentDeps a +filterDeps p = ComponentDeps . Map.filterWithKey p . unComponentDeps + +-- | ComponentDeps containing library dependencies only +fromLibraryDeps :: a -> ComponentDeps a +fromLibraryDeps = singleton ComponentLib + +-- | ComponentDeps containing setup dependencies only. +fromSetupDeps :: a -> ComponentDeps a +fromSetupDeps = singleton ComponentSetup + +-- | ComponentDeps for installed packages. +-- +-- We assume that installed packages only record their library dependencies. +fromInstalled :: a -> ComponentDeps a +fromInstalled = fromLibraryDeps + +{------------------------------------------------------------------------------- + Deconstruction +-------------------------------------------------------------------------------} + +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 +-- would have been _all_ dependencies. +nonSetupDeps :: Monoid a => ComponentDeps a -> a +nonSetupDeps = select (/= ComponentSetup) + +-- | Library dependencies proper only. (Includes dependencies +-- of internal libraries.) +libraryDeps :: Monoid a => ComponentDeps a -> a +libraryDeps = select (\c -> case c of ComponentSubLib _ -> True + ComponentLib -> True + _ -> False) + +-- | List components +components :: ComponentDeps a -> Set Component +components = Map.keysSet . unComponentDeps + +-- | Setup dependencies. +setupDeps :: Monoid a => ComponentDeps a -> a +setupDeps = select (== ComponentSetup) + +-- | Select dependencies satisfying a given predicate. +select :: Monoid a => (Component -> Bool) -> ComponentDeps a -> a +select p = foldMap snd . filter (p . fst) . toList diff --git a/cabal/cabal-install-solver/src/Distribution/Solver/Types/ConstraintSource.hs b/cabal/cabal-install-solver/src/Distribution/Solver/Types/ConstraintSource.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/src/Distribution/Solver/Types/ConstraintSource.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Solver.Types.ConstraintSource + ( ConstraintSource(..) + , showConstraintSource + ) where + +import Distribution.Solver.Compat.Prelude +import Prelude () + +-- | Source of a 'PackageConstraint'. +data ConstraintSource = + + -- | Main config file, which is ~/.cabal/config by default. + ConstraintSourceMainConfig FilePath + + -- | Local cabal.project file + | ConstraintSourceProjectConfig FilePath + + -- | User config file, which is ./cabal.config by default. + | ConstraintSourceUserConfig FilePath + + -- | Flag specified on the command line. + | ConstraintSourceCommandlineFlag + + -- | Target specified by the user, e.g., @cabal install package-0.1.0.0@ + -- implies @package==0.1.0.0@. + | ConstraintSourceUserTarget + + -- | Internal requirement to use installed versions of packages like ghc-prim. + | ConstraintSourceNonUpgradeablePackage + + -- | Internal constraint used by @cabal freeze@. + | ConstraintSourceFreeze + + -- | Constraint specified by a config file, a command line flag, or a user + -- target, when a more specific source is not known. + | ConstraintSourceConfigFlagOrTarget + + -- | The source of the constraint is not specified. + | ConstraintSourceUnknown + + -- | An internal constraint due to compatibility issues with the Setup.hs + -- command line interface requires a minimum lower bound on Cabal + | ConstraintSetupCabalMinVersion + + -- | An internal constraint due to compatibility issues with the Setup.hs + -- command line interface requires a maximum upper bound on Cabal + | ConstraintSetupCabalMaxVersion + deriving (Eq, Show, Generic) + +instance Binary ConstraintSource +instance Structured ConstraintSource + +-- | Description of a 'ConstraintSource'. +showConstraintSource :: ConstraintSource -> String +showConstraintSource (ConstraintSourceMainConfig path) = + "main config " ++ path +showConstraintSource (ConstraintSourceProjectConfig path) = + "project config " ++ path +showConstraintSource (ConstraintSourceUserConfig path)= "user config " ++ path +showConstraintSource ConstraintSourceCommandlineFlag = "command line flag" +showConstraintSource ConstraintSourceUserTarget = "user target" +showConstraintSource ConstraintSourceNonUpgradeablePackage = + "non-upgradeable package" +showConstraintSource ConstraintSourceFreeze = "cabal freeze" +showConstraintSource ConstraintSourceConfigFlagOrTarget = + "config file, command line flag, or user target" +showConstraintSource ConstraintSourceUnknown = "unknown source" +showConstraintSource ConstraintSetupCabalMinVersion = + "minimum version of Cabal used by Setup.hs" +showConstraintSource ConstraintSetupCabalMaxVersion = + "maximum version of Cabal used by Setup.hs" diff --git a/cabal/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs b/cabal/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs @@ -0,0 +1,37 @@ +module Distribution.Solver.Types.DependencyResolver + ( DependencyResolver + ) where + +import Distribution.Solver.Compat.Prelude +import Prelude () + +import Distribution.Solver.Types.LabeledPackageConstraint +import Distribution.Solver.Types.PkgConfigDb ( PkgConfigDb ) +import Distribution.Solver.Types.PackagePreferences +import Distribution.Solver.Types.PackageIndex ( PackageIndex ) +import Distribution.Solver.Types.Progress +import Distribution.Solver.Types.ResolverPackage +import Distribution.Solver.Types.SourcePackage + +import Distribution.Simple.PackageIndex ( InstalledPackageIndex ) +import Distribution.Package ( PackageName ) +import Distribution.Compiler ( CompilerInfo ) +import Distribution.System ( Platform ) + +-- | A dependency resolver is a function that works out an installation plan +-- given the set of installed and available packages and a set of deps to +-- solve for. +-- +-- The reason for this interface is because there are dozens of approaches to +-- solving the package dependency problem and we want to make it easy to swap +-- in alternatives. +-- +type DependencyResolver loc = Platform + -> CompilerInfo + -> InstalledPackageIndex + -> PackageIndex (SourcePackage loc) + -> PkgConfigDb + -> (PackageName -> PackagePreferences) + -> [LabeledPackageConstraint] + -> Set PackageName + -> Progress String String [ResolverPackage loc] diff --git a/cabal/cabal-install-solver/src/Distribution/Solver/Types/Flag.hs b/cabal/cabal-install-solver/src/Distribution/Solver/Types/Flag.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/src/Distribution/Solver/Types/Flag.hs @@ -0,0 +1,8 @@ +module Distribution.Solver.Types.Flag + ( FlagType(..) + ) where + +import Prelude (Eq, Show) + +data FlagType = Manual | Automatic + deriving (Eq, Show) diff --git a/cabal/cabal-install-solver/src/Distribution/Solver/Types/InstSolverPackage.hs b/cabal/cabal-install-solver/src/Distribution/Solver/Types/InstSolverPackage.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/src/Distribution/Solver/Types/InstSolverPackage.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Solver.Types.InstSolverPackage + ( InstSolverPackage(..) + ) where + +import Distribution.Solver.Compat.Prelude +import Prelude () + +import Distribution.Package ( Package(..), HasMungedPackageId(..), HasUnitId(..) ) +import Distribution.Solver.Types.ComponentDeps ( ComponentDeps ) +import Distribution.Solver.Types.SolverId +import Distribution.Types.MungedPackageId +import Distribution.Types.PackageId +import Distribution.Types.MungedPackageName +import Distribution.InstalledPackageInfo (InstalledPackageInfo) + +-- | An 'InstSolverPackage' is a pre-existing installed package +-- specified by the dependency solver. +data InstSolverPackage = InstSolverPackage { + instSolverPkgIPI :: InstalledPackageInfo, + instSolverPkgLibDeps :: ComponentDeps [SolverId], + instSolverPkgExeDeps :: ComponentDeps [SolverId] + } + deriving (Eq, Show, Generic) + +instance Binary InstSolverPackage +instance Structured InstSolverPackage + +instance Package InstSolverPackage where + packageId i = + -- HACK! See Note [Index conversion with internal libraries] + let MungedPackageId mpn v = mungedId i + in PackageIdentifier (encodeCompatPackageName mpn) v + +instance HasMungedPackageId InstSolverPackage where + mungedId = mungedId . instSolverPkgIPI + +instance HasUnitId InstSolverPackage where + installedUnitId = installedUnitId . instSolverPkgIPI diff --git a/cabal/cabal-install-solver/src/Distribution/Solver/Types/InstalledPreference.hs b/cabal/cabal-install-solver/src/Distribution/Solver/Types/InstalledPreference.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/src/Distribution/Solver/Types/InstalledPreference.hs @@ -0,0 +1,11 @@ +module Distribution.Solver.Types.InstalledPreference + ( InstalledPreference(..), + ) where + +import Prelude (Show) + +-- | Whether we prefer an installed version of a package or simply the latest +-- version. +-- +data InstalledPreference = PreferInstalled | PreferLatest | PreferOldest + deriving Show diff --git a/cabal/cabal-install-solver/src/Distribution/Solver/Types/LabeledPackageConstraint.hs b/cabal/cabal-install-solver/src/Distribution/Solver/Types/LabeledPackageConstraint.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/src/Distribution/Solver/Types/LabeledPackageConstraint.hs @@ -0,0 +1,14 @@ +module Distribution.Solver.Types.LabeledPackageConstraint + ( LabeledPackageConstraint(..) + , unlabelPackageConstraint + ) where + +import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.PackageConstraint + +-- | 'PackageConstraint' labeled with its source. +data LabeledPackageConstraint + = LabeledPackageConstraint PackageConstraint ConstraintSource + +unlabelPackageConstraint :: LabeledPackageConstraint -> PackageConstraint +unlabelPackageConstraint (LabeledPackageConstraint pc _) = pc diff --git a/cabal/cabal-install-solver/src/Distribution/Solver/Types/OptionalStanza.hs b/cabal/cabal-install-solver/src/Distribution/Solver/Types/OptionalStanza.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/src/Distribution/Solver/Types/OptionalStanza.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Solver.Types.OptionalStanza ( + -- * OptionalStanza + OptionalStanza(..), + showStanza, + showStanzas, + enableStanzas, + -- * Set of stanzas + OptionalStanzaSet, + optStanzaSetFromList, + optStanzaSetToList, + optStanzaSetMember, + optStanzaSetInsert, + optStanzaSetSingleton, + optStanzaSetIntersection, + optStanzaSetNull, + optStanzaSetIsSubset, + -- * Map indexed by stanzas + OptionalStanzaMap, + optStanzaTabulate, + optStanzaIndex, + optStanzaLookup, + optStanzaKeysFilteredByValue, +) where + +import Distribution.Solver.Compat.Prelude +import Prelude () + +import Data.Bits (testBit, (.|.), (.&.)) +import Distribution.Types.ComponentRequestedSpec (ComponentRequestedSpec (..)) +import Distribution.Utils.Structured (Structured (..), nominalStructure) + +------------------------------------------------------------------------------- +-- OptionalStanza +------------------------------------------------------------------------------- + +data OptionalStanza + = TestStanzas + | BenchStanzas + deriving (Eq, Ord, Enum, Bounded, Show, Generic, Typeable) + +-- | String representation of an OptionalStanza. +showStanza :: OptionalStanza -> String +showStanza TestStanzas = "test" +showStanza BenchStanzas = "bench" + +showStanzas :: OptionalStanzaSet -> String +showStanzas = unwords . map (("*" ++) . showStanza) . optStanzaSetToList + +-- | Convert a list of 'OptionalStanza' into the corresponding +-- Cabal's 'ComponentRequestedSpec' which records what components are enabled. +-- +enableStanzas :: OptionalStanzaSet -> ComponentRequestedSpec +enableStanzas optionalStanzas = ComponentRequestedSpec + { testsRequested = optStanzaSetMember TestStanzas optionalStanzas + , benchmarksRequested = optStanzaSetMember BenchStanzas optionalStanzas + } + +instance Binary OptionalStanza +instance Structured OptionalStanza + +------------------------------------------------------------------------------- +-- OptionalStanzaSet +------------------------------------------------------------------------------- + +newtype OptionalStanzaSet = OptionalStanzaSet Word + deriving (Eq, Ord, Show) + +instance Binary OptionalStanzaSet where + put (OptionalStanzaSet w) = put w + get = fmap (OptionalStanzaSet . (.&. 0x03)) get + +instance Structured OptionalStanzaSet where + structure = nominalStructure + +optStanzaSetFromList :: [OptionalStanza] -> OptionalStanzaSet +optStanzaSetFromList = foldl' (flip optStanzaSetInsert) mempty + +optStanzaSetToList :: OptionalStanzaSet -> [OptionalStanza] +optStanzaSetToList (OptionalStanzaSet 0) = [] +optStanzaSetToList (OptionalStanzaSet 1) = [TestStanzas] +optStanzaSetToList (OptionalStanzaSet 2) = [BenchStanzas] +optStanzaSetToList (OptionalStanzaSet 3) = [TestStanzas, BenchStanzas] +optStanzaSetToList (OptionalStanzaSet _) = [] + +optStanzaSetInsert :: OptionalStanza -> OptionalStanzaSet -> OptionalStanzaSet +optStanzaSetInsert x s = optStanzaSetSingleton x <> s + +optStanzaSetMember :: OptionalStanza -> OptionalStanzaSet -> Bool +optStanzaSetMember TestStanzas (OptionalStanzaSet w) = testBit w 0 +optStanzaSetMember BenchStanzas (OptionalStanzaSet w) = testBit w 1 + +optStanzaSetSingleton :: OptionalStanza -> OptionalStanzaSet +optStanzaSetSingleton TestStanzas = OptionalStanzaSet 1 +optStanzaSetSingleton BenchStanzas = OptionalStanzaSet 2 + +optStanzaSetIntersection :: OptionalStanzaSet -> OptionalStanzaSet -> OptionalStanzaSet +optStanzaSetIntersection (OptionalStanzaSet a) (OptionalStanzaSet b) = OptionalStanzaSet (a .&. b) + +optStanzaSetNull :: OptionalStanzaSet -> Bool +optStanzaSetNull (OptionalStanzaSet w) = w == 0 + +optStanzaSetIsSubset :: OptionalStanzaSet -> OptionalStanzaSet -> Bool +optStanzaSetIsSubset (OptionalStanzaSet a) (OptionalStanzaSet b) = (a .|. b) == b + +instance Semigroup OptionalStanzaSet where + OptionalStanzaSet a <> OptionalStanzaSet b = OptionalStanzaSet (a .|. b) + +instance Monoid OptionalStanzaSet where + mempty = OptionalStanzaSet 0 + mappend = (<>) + +------------------------------------------------------------------------------- +-- OptionalStanzaMap +------------------------------------------------------------------------------- + +-- | Note: this is total map. +data OptionalStanzaMap a = OptionalStanzaMap a a + deriving (Eq, Ord, Show, Generic) + +instance Binary a => Binary (OptionalStanzaMap a) +instance Structured a => Structured (OptionalStanzaMap a) + +optStanzaTabulate :: (OptionalStanza -> a) -> OptionalStanzaMap a +optStanzaTabulate f = OptionalStanzaMap (f TestStanzas) (f BenchStanzas) + +optStanzaIndex :: OptionalStanzaMap a -> OptionalStanza -> a +optStanzaIndex (OptionalStanzaMap x _) TestStanzas = x +optStanzaIndex (OptionalStanzaMap _ x) BenchStanzas = x + +optStanzaLookup :: OptionalStanza -> OptionalStanzaMap a -> a +optStanzaLookup = flip optStanzaIndex + +optStanzaKeysFilteredByValue :: (a -> Bool) -> OptionalStanzaMap a -> OptionalStanzaSet +optStanzaKeysFilteredByValue p (OptionalStanzaMap x y) + | p x = if p y then OptionalStanzaSet 3 else OptionalStanzaSet 1 + | otherwise = if p y then OptionalStanzaSet 2 else OptionalStanzaSet 0 diff --git a/cabal/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs b/cabal/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE DeriveGeneric #-} + +-- | Per-package constraints. Package constraints must be respected by the +-- solver. Multiple constraints for each package can be given, though obviously +-- it is possible to construct conflicting constraints (eg impossible version +-- range or inconsistent flag assignment). +-- +module Distribution.Solver.Types.PackageConstraint ( + ConstraintScope(..), + scopeToplevel, + scopeToPackageName, + constraintScopeMatches, + PackageProperty(..), + dispPackageProperty, + PackageConstraint(..), + dispPackageConstraint, + showPackageConstraint, + packageConstraintToDependency + ) where + +import Distribution.Solver.Compat.Prelude +import Prelude () + +import Distribution.Package (PackageName) +import Distribution.PackageDescription (FlagAssignment, dispFlagAssignment) +import Distribution.Pretty (flatStyle, pretty) +import Distribution.Types.PackageVersionConstraint (PackageVersionConstraint (..)) +import Distribution.Version (VersionRange, simplifyVersionRange) + +import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.PackagePath + +import qualified Text.PrettyPrint as Disp + + +-- | Determines to what packages and in what contexts a +-- constraint applies. +data ConstraintScope + -- | 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 + -- considered to match a package name when it is either the default + -- namespace (for --no-independent-goals) or it is an independent namespace + -- with the given package name (for --independent-goals). + + -- TODO: Try to generalize the ConstraintScopes once component-based + -- solving is implemented, and remove this special case for targets. + = 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. + | ScopeAnySetupQualifier 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. +scopeToplevel :: PackageName -> ConstraintScope +scopeToplevel = 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 + +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' + +-- | Pretty-prints a constraint scope. +dispConstraintScope :: ConstraintScope -> Disp.Doc +dispConstraintScope (ScopeTarget pn) = pretty pn <<>> Disp.text "." <<>> pretty pn +dispConstraintScope (ScopeQualified q pn) = dispQualifier q <<>> pretty pn +dispConstraintScope (ScopeAnySetupQualifier pn) = Disp.text "setup." <<>> pretty pn +dispConstraintScope (ScopeAnyQualifier pn) = Disp.text "any." <<>> pretty pn + +-- | A package property is a logical predicate on packages. +data PackageProperty + = PackagePropertyVersion VersionRange + | PackagePropertyInstalled + | PackagePropertySource + | PackagePropertyFlags FlagAssignment + | PackagePropertyStanzas [OptionalStanza] + deriving (Eq, Show, Generic) + +instance Binary PackageProperty +instance Structured PackageProperty + +-- | Pretty-prints a package property. +dispPackageProperty :: PackageProperty -> Disp.Doc +dispPackageProperty (PackagePropertyVersion verrange) = pretty verrange +dispPackageProperty PackagePropertyInstalled = Disp.text "installed" +dispPackageProperty PackagePropertySource = Disp.text "source" +dispPackageProperty (PackagePropertyFlags flags) = dispFlagAssignment flags +dispPackageProperty (PackagePropertyStanzas stanzas) = + Disp.hsep $ map (Disp.text . showStanza) stanzas + +-- | A package constraint consists of a scope plus a property +-- that must hold for all packages within that scope. +data PackageConstraint = PackageConstraint ConstraintScope PackageProperty + deriving (Eq, Show) + +-- | Pretty-prints a package constraint. +dispPackageConstraint :: PackageConstraint -> Disp.Doc +dispPackageConstraint (PackageConstraint scope prop) = + dispConstraintScope scope <+> dispPackageProperty prop + +-- | Alternative textual representation of a package constraint +-- for debugging purposes (slightly more verbose than that +-- produced by 'dispPackageConstraint'). +-- +showPackageConstraint :: PackageConstraint -> String +showPackageConstraint pc@(PackageConstraint scope prop) = + Disp.renderStyle flatStyle . postprocess $ dispPackageConstraint pc2 + where + pc2 = case prop of + PackagePropertyVersion vr -> + PackageConstraint scope $ PackagePropertyVersion (simplifyVersionRange vr) + _ -> pc + postprocess = case prop of + PackagePropertyFlags _ -> (Disp.text "flags" <+>) + PackagePropertyStanzas _ -> (Disp.text "stanzas" <+>) + _ -> id + +-- | Lossily convert a 'PackageConstraint' to a 'Dependency'. +packageConstraintToDependency :: PackageConstraint -> Maybe PackageVersionConstraint +packageConstraintToDependency (PackageConstraint scope prop) = toDep prop + where + toDep (PackagePropertyVersion vr) = Just $ PackageVersionConstraint (scopeToPackageName scope) vr + toDep (PackagePropertyInstalled) = Nothing + toDep (PackagePropertySource) = Nothing + toDep (PackagePropertyFlags _) = Nothing + toDep (PackagePropertyStanzas _) = Nothing diff --git a/cabal/cabal-install-solver/src/Distribution/Solver/Types/PackageFixedDeps.hs b/cabal/cabal-install-solver/src/Distribution/Solver/Types/PackageFixedDeps.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/src/Distribution/Solver/Types/PackageFixedDeps.hs @@ -0,0 +1,23 @@ +module Distribution.Solver.Types.PackageFixedDeps + ( PackageFixedDeps(..) + ) where + +import Distribution.InstalledPackageInfo ( InstalledPackageInfo ) +import Distribution.Package + ( Package(..), UnitId, installedDepends) +import Distribution.Solver.Types.ComponentDeps ( ComponentDeps ) +import qualified Distribution.Solver.Types.ComponentDeps as CD + +-- | Subclass of packages that have specific versioned dependencies. +-- +-- So for example a not-yet-configured package has dependencies on version +-- ranges, not specific versions. A configured or an already installed package +-- depends on exact versions. Some operations or data structures (like +-- dependency graphs) only make sense on this subclass of package types. +-- +class Package pkg => PackageFixedDeps pkg where + depends :: pkg -> ComponentDeps [UnitId] + +instance PackageFixedDeps InstalledPackageInfo where + depends pkg = CD.fromInstalled (installedDepends pkg) + diff --git a/cabal/cabal-install-solver/src/Distribution/Solver/Types/PackageIndex.hs b/cabal/cabal-install-solver/src/Distribution/Solver/Types/PackageIndex.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/src/Distribution/Solver/Types/PackageIndex.hs @@ -0,0 +1,338 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Solver.Types.PackageIndex +-- Copyright : (c) David Himmelstrup 2005, +-- Bjorn Bringert 2007, +-- Duncan Coutts 2008 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- An index of packages. +-- +module Distribution.Solver.Types.PackageIndex ( + -- * Package index data type + PackageIndex, + + -- * Creating an index + fromList, + + -- * Updates + merge, + override, + insert, + deletePackageName, + deletePackageId, + deleteDependency, + + -- * Queries + + -- ** Precise lookups + elemByPackageId, + elemByPackageName, + lookupPackageName, + lookupPackageId, + lookupDependency, + + -- ** Case-insensitive searches + searchByName, + SearchResult(..), + searchByNameSubstring, + searchWithPredicate, + + -- ** Bulk queries + allPackages, + allPackagesByName, + ) where + +import Prelude () +import Distribution.Solver.Compat.Prelude hiding (lookup) + +import qualified Data.Map as Map +import Data.List (isInfixOf) +import qualified Data.List.NonEmpty as NE + +import Distribution.Client.Utils.Assertion ( expensiveAssert ) +import Distribution.Package + ( PackageName, unPackageName, PackageIdentifier(..) + , Package(..), packageName, packageVersion ) +import Distribution.Version + ( VersionRange, withinRange ) +import Distribution.Simple.Utils + ( lowercase ) + +import qualified Prelude (foldr1) + +-- | The collection of information about packages from one or more 'PackageDB's. +-- +-- It can be searched efficiently by package name and version. +-- +newtype PackageIndex pkg = PackageIndex + -- This index package names to all the package records matching that package + -- name case-sensitively. It includes all versions. + -- + -- This allows us to find all versions satisfying a dependency. + -- Most queries are a map lookup followed by a linear scan of the bucket. + -- + (Map PackageName [pkg]) + + deriving (Eq, Show, Read, Functor, Generic) +--FIXME: the Functor instance here relies on no package id changes + +instance Package pkg => Semigroup (PackageIndex pkg) where + (<>) = merge + +instance Package pkg => Monoid (PackageIndex pkg) where + mempty = PackageIndex Map.empty + mappend = (<>) + --save one mappend with empty in the common case: + mconcat [] = mempty + mconcat xs = Prelude.foldr1 mappend xs + +instance Binary pkg => Binary (PackageIndex pkg) + +invariant :: Package pkg => PackageIndex pkg -> Bool +invariant (PackageIndex m) = all (uncurry goodBucket) (Map.toList m) + where + goodBucket _ [] = False + goodBucket name (pkg0:pkgs0) = check (packageId pkg0) pkgs0 + where + check pkgid [] = packageName pkgid == name + check pkgid (pkg':pkgs) = packageName pkgid == name + && pkgid < pkgid' + && check pkgid' pkgs + where pkgid' = packageId pkg' + +-- +-- * Internal helpers +-- + +mkPackageIndex :: Package pkg => Map PackageName [pkg] -> PackageIndex pkg +mkPackageIndex index = expensiveAssert (invariant (PackageIndex index)) + (PackageIndex index) + +internalError :: String -> a +internalError name = error ("PackageIndex." ++ name ++ ": internal error") + +-- | Lookup a name in the index to get all packages that match that name +-- case-sensitively. +-- +lookup :: PackageIndex pkg -> PackageName -> [pkg] +lookup (PackageIndex m) name = fromMaybe [] $ Map.lookup name m + +-- +-- * Construction +-- + +-- | Build an index out of a bunch of packages. +-- +-- If there are duplicates, later ones mask earlier ones. +-- +fromList :: Package pkg => [pkg] -> PackageIndex pkg +fromList pkgs = mkPackageIndex + . Map.map fixBucket + . Map.fromListWith (++) + $ [ (packageName pkg, [pkg]) + | pkg <- pkgs ] + where + fixBucket = -- out of groups of duplicates, later ones mask earlier ones + -- but Map.fromListWith (++) constructs groups in reverse order + map NE.head + -- Eq instance for PackageIdentifier is wrong, so use Ord: + . NE.groupBy (\a b -> EQ == comparing packageId a b) + -- relies on sortBy being a stable sort so we + -- can pick consistently among duplicates + . sortBy (comparing packageId) + +-- +-- * Updates +-- + +-- | Merge two indexes. +-- +-- Packages from the second mask packages of the same exact name +-- (case-sensitively) from the first. +-- +merge :: Package pkg => PackageIndex pkg -> PackageIndex pkg -> PackageIndex pkg +merge i1@(PackageIndex m1) i2@(PackageIndex m2) = + expensiveAssert (invariant i1 && invariant i2) $ + mkPackageIndex (Map.unionWith mergeBuckets m1 m2) + + +-- | Elements in the second list mask those in the first. +mergeBuckets :: Package pkg => [pkg] -> [pkg] -> [pkg] +mergeBuckets [] ys = ys +mergeBuckets xs [] = xs +mergeBuckets xs@(x:xs') ys@(y:ys') = + case packageId x `compare` packageId y of + GT -> y : mergeBuckets xs ys' + EQ -> y : mergeBuckets xs' ys' + LT -> x : mergeBuckets xs' ys + +-- | Override-merge of two indexes. +-- +-- Packages from the second mask packages of the same exact name +-- (case-sensitively) from the first. +-- +override :: Package pkg => PackageIndex pkg -> PackageIndex pkg -> PackageIndex pkg +override i1@(PackageIndex m1) i2@(PackageIndex m2) = + expensiveAssert (invariant i1 && invariant i2) $ + mkPackageIndex (Map.unionWith (\_l r -> r) m1 m2) + +-- | Inserts a single package into the index. +-- +-- This is equivalent to (but slightly quicker than) using 'mappend' or +-- 'merge' with a singleton index. +-- +insert :: Package pkg => pkg -> PackageIndex pkg -> PackageIndex pkg +insert pkg (PackageIndex index) = mkPackageIndex $ + Map.insertWith (\_ -> insertNoDup) (packageName pkg) [pkg] index + where + pkgid = packageId pkg + insertNoDup [] = [pkg] + insertNoDup pkgs@(pkg':pkgs') = case compare pkgid (packageId pkg') of + LT -> pkg : pkgs + EQ -> pkg : pkgs' + GT -> pkg' : insertNoDup pkgs' + +-- | Internal delete helper. +-- +delete :: Package pkg => PackageName -> (pkg -> Bool) -> PackageIndex pkg + -> PackageIndex pkg +delete name p (PackageIndex index) = mkPackageIndex $ + Map.update filterBucket name index + where + filterBucket = deleteEmptyBucket + . filter (not . p) + deleteEmptyBucket [] = Nothing + deleteEmptyBucket remaining = Just remaining + +-- | Removes a single package from the index. +-- +deletePackageId :: Package pkg => PackageIdentifier -> PackageIndex pkg + -> PackageIndex pkg +deletePackageId pkgid = + delete (packageName pkgid) (\pkg -> packageId pkg == pkgid) + +-- | Removes all packages with this (case-sensitive) name from the index. +-- +deletePackageName :: Package pkg => PackageName -> PackageIndex pkg + -> PackageIndex pkg +deletePackageName name = + delete name (\pkg -> packageName pkg == name) + +-- | Removes all packages satisfying this dependency from the index. +deleteDependency :: Package pkg + => PackageName -> VersionRange -> PackageIndex pkg + -> PackageIndex pkg +deleteDependency name verstionRange = + delete name (\pkg -> packageVersion pkg `withinRange` verstionRange) + +-- +-- * Bulk queries +-- + +-- | Get all the packages from the index. +-- +allPackages :: PackageIndex pkg -> [pkg] +allPackages (PackageIndex m) = concat (Map.elems m) + +-- | Get all the packages from the index. +-- +-- They are grouped by package name, case-sensitively. +-- +allPackagesByName :: PackageIndex pkg -> [[pkg]] +allPackagesByName (PackageIndex m) = Map.elems m + +-- +-- * Lookups +-- + +elemByPackageId :: Package pkg => PackageIndex pkg -> PackageIdentifier -> Bool +elemByPackageId index = isJust . lookupPackageId index + +elemByPackageName :: Package pkg => PackageIndex pkg -> PackageName -> Bool +elemByPackageName index = not . null . lookupPackageName index + + +-- | Does a lookup by package id (name & version). +-- +-- Since multiple package DBs mask each other case-sensitively by package name, +-- then we get back at most one package. +-- +lookupPackageId :: Package pkg => PackageIndex pkg -> PackageIdentifier + -> Maybe pkg +lookupPackageId index pkgid = + case [ pkg | pkg <- lookup index (packageName pkgid) + , packageId pkg == pkgid ] of + [] -> Nothing + [pkg] -> Just pkg + _ -> internalError "lookupPackageIdentifier" + +-- | Does a case-sensitive search by package name. +-- +lookupPackageName :: Package pkg => PackageIndex pkg -> PackageName -> [pkg] +lookupPackageName index name = + [ pkg | pkg <- lookup index name + , packageName pkg == name ] + +-- | Does a case-sensitive search by package name and a range of versions. +-- +-- We get back any number of versions of the specified package name, all +-- satisfying the version range constraint. +-- +lookupDependency :: Package pkg + => PackageIndex pkg + -> PackageName -> VersionRange + -> [pkg] +lookupDependency index name versionRange = + [ pkg | pkg <- lookup index name + , packageName pkg == name + , packageVersion pkg `withinRange` versionRange ] + +-- +-- * Case insensitive name lookups +-- + +-- | Does a case-insensitive search by package name. +-- +-- If there is only one package that compares case-insensitively to this name +-- then the search is unambiguous and we get back all versions of that package. +-- If several match case-insensitively but one matches exactly then it is also +-- unambiguous. +-- +-- If however several match case-insensitively and none match exactly then we +-- have an ambiguous result, and we get back all the versions of all the +-- packages. The list of ambiguous results is split by exact package name. So +-- it is a non-empty list of non-empty lists. +-- +searchByName :: PackageIndex pkg + -> String -> [(PackageName, [pkg])] +searchByName (PackageIndex m) name = + [ pkgs + | pkgs@(pname,_) <- Map.toList m + , lowercase (unPackageName pname) == lname ] + where + lname = lowercase name + +data SearchResult a = None | Unambiguous a | Ambiguous [a] + +-- | Does a case-insensitive substring search by package name. +-- +-- That is, all packages that contain the given string in their name. +-- +searchByNameSubstring :: PackageIndex pkg + -> String -> [(PackageName, [pkg])] +searchByNameSubstring index searchterm = + searchWithPredicate index (\n -> lsearchterm `isInfixOf` lowercase n) + where lsearchterm = lowercase searchterm + +searchWithPredicate :: PackageIndex pkg + -> (String -> Bool) -> [(PackageName, [pkg])] +searchWithPredicate (PackageIndex m) predicate = + [ pkgs + | pkgs@(pname, _) <- Map.toList m + , predicate (unPackageName pname) + ] diff --git a/cabal/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs b/cabal/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs @@ -0,0 +1,102 @@ +module Distribution.Solver.Types.PackagePath + ( PackagePath(..) + , Namespace(..) + , Qualifier(..) + , dispQualifier + , Qualified(..) + , QPN + , dispQPN + , showQPN + ) where + +import Distribution.Solver.Compat.Prelude +import Prelude () +import Distribution.Package (PackageName) +import Distribution.Pretty (pretty, flatStyle) +import qualified Text.PrettyPrint as Disp + +-- | A package path consists of a namespace and a package path inside that +-- namespace. +data PackagePath = PackagePath Namespace Qualifier + deriving (Eq, Ord, Show) + +-- | 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 "." + +-- | Qualifier of a package within a namespace (see 'PackagePath') +data Qualifier = + -- | Top-level dependency in this namespace + QualToplevel + + -- | Any dependency on base is considered independent + -- + -- This makes it possible to have base shims. + | QualBase PackageName + + -- | Setup dependency + -- + -- By rights setup dependencies ought to be nestable; after all, the setup + -- dependencies of a package might themselves have setup dependencies, which + -- are independent from everything else. However, this very quickly leads to + -- infinite search trees in the solver. Therefore we limit ourselves to + -- a single qualifier (within a given namespace). + | QualSetup PackageName + + -- | If we depend on an executable from a package (via + -- @build-tools@), we should solve for the dependencies of that + -- package separately (since we're not going to actually try to + -- link it.) We qualify for EACH package separately; e.g., + -- @'Exe' pn1 pn2@ qualifies the @build-tools@ dependency on + -- @pn2@ from package @pn1@. (If we tracked only @pn1@, that + -- would require a consistent dependency resolution for all + -- of the depended upon executables from a package; if we + -- 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) + +-- | Pretty-prints a qualifier. The result is either empty or +-- ends in a period, so it can be prepended onto a package name. +-- +-- NOTE: the base qualifier is for a dependency _on_ base; the qualifier is +-- there to make sure different dependencies on base are all independent. +-- So we want to print something like @"A.base"@, where the @"A."@ part +-- 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 "." + +-- | A qualified entity. Pairs a package path with the entity. +data Qualified a = Q PackagePath a + deriving (Eq, Ord, Show) + +-- | Qualified package name. +type QPN = Qualified PackageName + +-- | Pretty-prints a qualified package name. +dispQPN :: QPN -> Disp.Doc +dispQPN (Q (PackagePath ns qual) pn) = + dispNamespace ns <<>> dispQualifier qual <<>> pretty pn + +-- | String representation of a qualified package name. +showQPN :: QPN -> String +showQPN = Disp.renderStyle flatStyle . dispQPN diff --git a/cabal/cabal-install-solver/src/Distribution/Solver/Types/PackagePreferences.hs b/cabal/cabal-install-solver/src/Distribution/Solver/Types/PackagePreferences.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/src/Distribution/Solver/Types/PackagePreferences.hs @@ -0,0 +1,22 @@ +module Distribution.Solver.Types.PackagePreferences + ( PackagePreferences(..) + ) where + +import Distribution.Solver.Types.InstalledPreference +import Distribution.Solver.Types.OptionalStanza +import Distribution.Version (VersionRange) + +-- | Per-package preferences on the version. It is a soft constraint that the +-- 'DependencyResolver' should try to respect where possible. It consists of +-- an 'InstalledPreference' which says if we prefer versions of packages +-- that are already installed. It also has (possibly multiple) +-- 'PackageVersionPreference's which are suggested constraints on the version +-- number. The resolver should try to use package versions that satisfy +-- the maximum number of the suggested version constraints. +-- +-- It is not specified if preferences on some packages are more important than +-- others. +-- +data PackagePreferences = PackagePreferences [VersionRange] + InstalledPreference + [OptionalStanza] diff --git a/cabal/cabal-install-solver/src/Distribution/Solver/Types/PkgConfigDb.hs b/cabal/cabal-install-solver/src/Distribution/Solver/Types/PkgConfigDb.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/src/Distribution/Solver/Types/PkgConfigDb.hs @@ -0,0 +1,173 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Solver.Types.PkgConfigDb +-- Copyright : (c) Iñaki García Etxebarria 2016 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Read the list of packages available to pkg-config. +----------------------------------------------------------------------------- +module Distribution.Solver.Types.PkgConfigDb + ( PkgConfigDb (..) + , readPkgConfigDb + , pkgConfigDbFromList + , pkgConfigPkgIsPresent + , pkgConfigDbPkgVersion + , getPkgConfigDbDirs + ) where + +import Distribution.Solver.Compat.Prelude +import Prelude () + +import Control.Exception (handle) +import Control.Monad (mapM) +import qualified Data.Map as M +import System.FilePath (splitSearchPath) + +import Distribution.Compat.Environment (lookupEnv) +import Distribution.Package (PkgconfigName, mkPkgconfigName) +import Distribution.Parsec +import Distribution.Simple.Program + (ProgramDb, getProgramOutput, pkgConfigProgram, needProgram, ConfiguredProgram) +import Distribution.Simple.Program.Run (getProgramInvocationOutputAndErrors, programInvocation) +import Distribution.Simple.Utils (info) +import Distribution.Types.PkgconfigVersion +import Distribution.Types.PkgconfigVersionRange +import Distribution.Verbosity (Verbosity) + +-- | The list of packages installed in the system visible to +-- @pkg-config@. This is an opaque datatype, to be constructed with +-- `readPkgConfigDb` and queried with `pkgConfigPkgPresent`. +data PkgConfigDb = PkgConfigDb (M.Map PkgconfigName (Maybe PkgconfigVersion)) + -- ^ If an entry is `Nothing`, this means that the + -- package seems to be present, but we don't know the + -- exact version (because parsing of the version + -- number failed). + | NoPkgConfigDb + -- ^ For when we could not run pkg-config successfully. + deriving (Show, Generic, Typeable) + +instance Binary PkgConfigDb +instance Structured PkgConfigDb + +-- | Query pkg-config for the list of installed packages, together +-- with their versions. Return a `PkgConfigDb` encapsulating this +-- information. +readPkgConfigDb :: Verbosity -> ProgramDb -> IO PkgConfigDb +readPkgConfigDb verbosity progdb = handle ioErrorHandler $ do + mpkgConfig <- needProgram verbosity pkgConfigProgram progdb + case mpkgConfig of + Nothing -> noPkgConfig "Cannot find pkg-config program" + Just (pkgConfig, _) -> do + pkgList <- lines <$> getProgramOutput verbosity pkgConfig ["--list-all"] + -- The output of @pkg-config --list-all@ also includes a description + -- for each package, which we do not need. + let pkgNames = map (takeWhile (not . isSpace)) pkgList + (pkgVersions, _errs, exitCode) <- + getProgramInvocationOutputAndErrors verbosity + (programInvocation pkgConfig ("--modversion" : pkgNames)) + case exitCode of + ExitSuccess -> (return . pkgConfigDbFromList . zip pkgNames) (lines pkgVersions) + -- if there's a single broken pc file the above fails, so we fall back into calling it individually + _ -> do + info verbosity ("call to pkg-config --modversion on all packages failed. Falling back to querying pkg-config individually on each package") + pkgConfigDbFromList . catMaybes <$> mapM (getIndividualVersion pkgConfig) pkgNames + where + -- For when pkg-config invocation fails (possibly because of a + -- too long command line). + noPkgConfig extra = do + info verbosity ("Failed to query pkg-config, Cabal will continue" + ++ " without solving for pkg-config constraints: " + ++ extra) + return NoPkgConfigDb + + ioErrorHandler :: IOException -> IO PkgConfigDb + ioErrorHandler e = noPkgConfig (show e) + + getIndividualVersion :: ConfiguredProgram -> String -> IO (Maybe (String, String)) + getIndividualVersion pkgConfig pkg = do + (pkgVersion, _errs, exitCode) <- + getProgramInvocationOutputAndErrors verbosity + (programInvocation pkgConfig ["--modversion",pkg]) + return $ case exitCode of + ExitSuccess -> Just (pkg, pkgVersion) + _ -> Nothing + +-- | Create a `PkgConfigDb` from a list of @(packageName, version)@ pairs. +pkgConfigDbFromList :: [(String, String)] -> PkgConfigDb +pkgConfigDbFromList pairs = (PkgConfigDb . M.fromList . map convert) pairs + where + convert :: (String, String) -> (PkgconfigName, Maybe PkgconfigVersion) + convert (n,vs) = (mkPkgconfigName n, simpleParsec vs) + +-- | Check whether a given package range is satisfiable in the given +-- @pkg-config@ database. +pkgConfigPkgIsPresent :: PkgConfigDb -> PkgconfigName -> PkgconfigVersionRange -> Bool +pkgConfigPkgIsPresent (PkgConfigDb db) pn vr = + case M.lookup pn db of + Nothing -> False -- Package not present in the DB. + Just Nothing -> True -- Package present, but version unknown. + Just (Just v) -> withinPkgconfigVersionRange v vr +-- If we could not read the pkg-config database successfully we fail. +-- The plan found by the solver can't be executed later, because pkg-config itself +-- is going to be called in the build phase to get the library location for linking +-- so even if there is a library, it would need to be passed manual flags anyway. +pkgConfigPkgIsPresent NoPkgConfigDb _ _ = False + + + +-- | Query the version of a package in the @pkg-config@ database. +-- @Nothing@ indicates the package is not in the database, while +-- @Just Nothing@ indicates that the package is in the database, +-- but its version is not known. +pkgConfigDbPkgVersion :: PkgConfigDb -> PkgconfigName -> Maybe (Maybe PkgconfigVersion) +pkgConfigDbPkgVersion (PkgConfigDb db) pn = M.lookup pn db +-- NB: Since the solver allows solving to succeed if there is +-- NoPkgConfigDb, we should report that we *guess* that there +-- is a matching pkg-config configuration, but that we just +-- don't know about it. +pkgConfigDbPkgVersion NoPkgConfigDb _ = Just Nothing + + +-- | Query pkg-config for the locations of pkg-config's package files. Use this +-- to monitor for changes in the pkg-config DB. +-- +getPkgConfigDbDirs :: Verbosity -> ProgramDb -> IO [FilePath] +getPkgConfigDbDirs verbosity progdb = + (++) <$> getEnvPath <*> getDefPath + where + -- According to @man pkg-config@: + -- + -- PKG_CONFIG_PATH + -- A colon-separated (on Windows, semicolon-separated) list of directories + -- to search for .pc files. The default directory will always be searched + -- after searching the path + -- + getEnvPath = maybe [] parseSearchPath + <$> lookupEnv "PKG_CONFIG_PATH" + + -- Again according to @man pkg-config@: + -- + -- pkg-config can be used to query itself for the default search path, + -- version number and other information, for instance using: + -- + -- > pkg-config --variable pc_path pkg-config + -- + getDefPath = handle ioErrorHandler $ do + mpkgConfig <- needProgram verbosity pkgConfigProgram progdb + case mpkgConfig of + Nothing -> return [] + Just (pkgConfig, _) -> parseSearchPath <$> + getProgramOutput verbosity pkgConfig ["--variable", "pc_path", "pkg-config"] + + parseSearchPath str = + case lines str of + [p] | not (null p) -> splitSearchPath p + _ -> [] + + ioErrorHandler :: IOException -> IO [FilePath] + ioErrorHandler _e = return [] diff --git a/cabal/cabal-install-solver/src/Distribution/Solver/Types/Progress.hs b/cabal/cabal-install-solver/src/Distribution/Solver/Types/Progress.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/src/Distribution/Solver/Types/Progress.hs @@ -0,0 +1,49 @@ +module Distribution.Solver.Types.Progress + ( Progress(..) + , foldProgress + ) where + +import Prelude () +import Distribution.Solver.Compat.Prelude hiding (fail) + +-- | A type to represent the unfolding of an expensive long running +-- calculation that may fail. We may get intermediate steps before the final +-- result which may be used to indicate progress and\/or logging messages. +-- +data Progress step fail done = Step step (Progress step fail done) + | Fail fail + | Done done + +-- 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) + +-- | Consume a 'Progress' calculation. Much like 'foldr' for lists but with two +-- base cases, one for a final result and one for failure. +-- +-- Eg to convert into a simple 'Either' result use: +-- +-- > foldProgress (flip const) Left Right +-- +foldProgress :: (step -> a -> a) -> (fail -> a) -> (done -> a) + -> Progress step fail done -> a +foldProgress step 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 Applicative (Progress step fail) where + pure a = Done a + p <*> x = foldProgress Step Fail (flip fmap x) p + +instance Monoid fail => Alternative (Progress step fail) where + empty = Fail mempty + p <|> q = foldProgress Step (const q) Done p diff --git a/cabal/cabal-install-solver/src/Distribution/Solver/Types/ResolverPackage.hs b/cabal/cabal-install-solver/src/Distribution/Solver/Types/ResolverPackage.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/src/Distribution/Solver/Types/ResolverPackage.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Solver.Types.ResolverPackage + ( ResolverPackage(..) + , resolverPackageLibDeps + , resolverPackageExeDeps + ) where + +import Distribution.Solver.Compat.Prelude +import Prelude () + +import Distribution.Solver.Types.InstSolverPackage +import Distribution.Solver.Types.SolverId +import Distribution.Solver.Types.SolverPackage +import qualified Distribution.Solver.Types.ComponentDeps as CD + +import Distribution.Compat.Graph (IsNode(..)) +import Distribution.Package (Package(..), HasUnitId(..)) +import Distribution.Simple.Utils (ordNub) + +-- | The dependency resolver picks either pre-existing installed packages +-- or it picks source packages along with package configuration. +-- +-- This is like the 'InstallPlan.PlanPackage' but with fewer cases. +-- +data ResolverPackage loc = PreExisting InstSolverPackage + | Configured (SolverPackage loc) + deriving (Eq, Show, Generic) + +instance Binary loc => Binary (ResolverPackage loc) +instance Structured loc => Structured (ResolverPackage loc) + +instance Package (ResolverPackage loc) where + packageId (PreExisting ipkg) = packageId ipkg + packageId (Configured spkg) = packageId spkg + +resolverPackageLibDeps :: ResolverPackage loc -> CD.ComponentDeps [SolverId] +resolverPackageLibDeps (PreExisting ipkg) = instSolverPkgLibDeps ipkg +resolverPackageLibDeps (Configured spkg) = solverPkgLibDeps spkg + +resolverPackageExeDeps :: ResolverPackage loc -> CD.ComponentDeps [SolverId] +resolverPackageExeDeps (PreExisting ipkg) = instSolverPkgExeDeps ipkg +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) + -- Use dependencies for ALL components + nodeNeighbors pkg = + ordNub $ CD.flatDeps (resolverPackageLibDeps pkg) ++ + CD.flatDeps (resolverPackageExeDeps pkg) diff --git a/cabal/cabal-install-solver/src/Distribution/Solver/Types/Settings.hs b/cabal/cabal-install-solver/src/Distribution/Solver/Types/Settings.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/src/Distribution/Solver/Types/Settings.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Distribution.Solver.Types.Settings + ( ReorderGoals(..) + , IndependentGoals(..) + , PreferOldest(..) + , MinimizeConflictSet(..) + , AvoidReinstalls(..) + , ShadowPkgs(..) + , StrongFlags(..) + , AllowBootLibInstalls(..) + , OnlyConstrained(..) + , EnableBackjumping(..) + , CountConflicts(..) + , FineGrainedConflicts(..) + , SolveExecutables(..) + ) where + +import Distribution.Solver.Compat.Prelude +import Prelude () + +import Distribution.Simple.Setup ( BooleanFlag(..) ) +import Distribution.Pretty ( Pretty(pretty) ) +import Distribution.Parsec ( Parsec(parsec) ) + +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as PP + +newtype ReorderGoals = ReorderGoals Bool + deriving (BooleanFlag, Eq, Generic, Show) + +newtype CountConflicts = CountConflicts Bool + deriving (BooleanFlag, Eq, Generic, Show) + +newtype FineGrainedConflicts = FineGrainedConflicts Bool + deriving (BooleanFlag, Eq, Generic, Show) + +newtype MinimizeConflictSet = MinimizeConflictSet Bool + deriving (BooleanFlag, Eq, Generic, Show) + +newtype IndependentGoals = IndependentGoals Bool + deriving (BooleanFlag, Eq, Generic, Show) + +newtype PreferOldest = PreferOldest Bool + deriving (BooleanFlag, Eq, Generic, Show) + +newtype AvoidReinstalls = AvoidReinstalls Bool + deriving (BooleanFlag, Eq, Generic, Show) + +newtype ShadowPkgs = ShadowPkgs Bool + deriving (BooleanFlag, Eq, Generic, Show) + +newtype StrongFlags = StrongFlags Bool + deriving (BooleanFlag, Eq, Generic, Show) + +newtype AllowBootLibInstalls = AllowBootLibInstalls Bool + deriving (BooleanFlag, Eq, Generic, Show) + +-- | Should we consider all packages we know about, or only those that +-- have constraints explicitly placed on them or which are goals? +data OnlyConstrained + = OnlyConstrainedNone + | OnlyConstrainedAll + deriving (Eq, Generic, Show) + +newtype EnableBackjumping = EnableBackjumping Bool + deriving (BooleanFlag, Eq, Generic, Show) + +newtype SolveExecutables = SolveExecutables Bool + deriving (BooleanFlag, Eq, Generic, Show) + +instance Binary ReorderGoals +instance Binary CountConflicts +instance Binary FineGrainedConflicts +instance Binary IndependentGoals +instance Binary PreferOldest +instance Binary MinimizeConflictSet +instance Binary AvoidReinstalls +instance Binary ShadowPkgs +instance Binary StrongFlags +instance Binary AllowBootLibInstalls +instance Binary OnlyConstrained +instance Binary SolveExecutables + +instance Structured ReorderGoals +instance Structured CountConflicts +instance Structured FineGrainedConflicts +instance Structured IndependentGoals +instance Structured PreferOldest +instance Structured MinimizeConflictSet +instance Structured AvoidReinstalls +instance Structured ShadowPkgs +instance Structured StrongFlags +instance Structured AllowBootLibInstalls +instance Structured OnlyConstrained +instance Structured SolveExecutables + +instance Pretty OnlyConstrained where + pretty OnlyConstrainedAll = PP.text "all" + pretty OnlyConstrainedNone = PP.text "none" + +instance Parsec OnlyConstrained where + parsec = P.choice + [ P.string "all" >> return OnlyConstrainedAll + , P.string "none" >> return OnlyConstrainedNone + ] + diff --git a/cabal/cabal-install-solver/src/Distribution/Solver/Types/SolverId.hs b/cabal/cabal-install-solver/src/Distribution/Solver/Types/SolverId.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/src/Distribution/Solver/Types/SolverId.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Solver.Types.SolverId + ( SolverId(..) + ) + +where + +import Distribution.Solver.Compat.Prelude +import Prelude () + +import Distribution.Package (PackageId, Package(..), UnitId) + +-- | 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 } + deriving (Eq, Ord, Generic) + +instance Binary SolverId +instance Structured SolverId + +instance Show SolverId where + show = show . solverSrcId + +instance Package SolverId where + packageId = solverSrcId diff --git a/cabal/cabal-install-solver/src/Distribution/Solver/Types/SolverPackage.hs b/cabal/cabal-install-solver/src/Distribution/Solver/Types/SolverPackage.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/src/Distribution/Solver/Types/SolverPackage.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Solver.Types.SolverPackage + ( SolverPackage(..) + ) where + +import Distribution.Solver.Compat.Prelude +import Prelude () + +import Distribution.Package ( Package(..) ) +import Distribution.PackageDescription ( FlagAssignment ) +import Distribution.Solver.Types.ComponentDeps ( ComponentDeps ) +import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.SolverId +import Distribution.Solver.Types.SourcePackage + +-- | A 'SolverPackage' is a package specified by the dependency solver. +-- It will get elaborated into a 'ConfiguredPackage' or even an +-- 'ElaboratedConfiguredPackage'. +-- +-- NB: 'SolverPackage's are essentially always with 'UnresolvedPkgLoc', +-- but for symmetry we have the parameter. (Maybe it can be removed.) +-- +data SolverPackage loc = SolverPackage { + solverPkgSource :: SourcePackage loc, + solverPkgFlags :: FlagAssignment, + solverPkgStanzas :: OptionalStanzaSet, + solverPkgLibDeps :: ComponentDeps [SolverId], + solverPkgExeDeps :: ComponentDeps [SolverId] + } + deriving (Eq, Show, Generic) + +instance Binary loc => Binary (SolverPackage loc) +instance Structured loc => Structured (SolverPackage loc) + +instance Package (SolverPackage loc) where + packageId = packageId . solverPkgSource diff --git a/cabal/cabal-install-solver/src/Distribution/Solver/Types/SourcePackage.hs b/cabal/cabal-install-solver/src/Distribution/Solver/Types/SourcePackage.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/src/Distribution/Solver/Types/SourcePackage.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} +module Distribution.Solver.Types.SourcePackage + ( PackageDescriptionOverride + , SourcePackage(..) + ) where + +import Distribution.Solver.Compat.Prelude +import Prelude () + +import Distribution.Package + ( PackageId, Package(..) ) +import Distribution.PackageDescription + ( GenericPackageDescription(..) ) + +import Data.ByteString.Lazy (ByteString) + +-- | A package description along with the location of the package sources. +-- +data SourcePackage loc = SourcePackage + { srcpkgPackageId :: PackageId + , srcpkgDescription :: GenericPackageDescription + -- ^ Note, this field is lazy, e.g. when reading in hackage index + -- we parse only what we need, not whole index. + , srcpkgSource :: loc + , srcpkgDescrOverride :: PackageDescriptionOverride + } + deriving (Eq, Show, Generic, Typeable) + +instance Binary loc => Binary (SourcePackage loc) +instance Structured loc => Structured (SourcePackage loc) + +instance Package (SourcePackage a) where packageId = srcpkgPackageId + +-- | We sometimes need to override the .cabal file in the tarball with +-- the newer one from the package index. +type PackageDescriptionOverride = Maybe ByteString diff --git a/cabal/cabal-install-solver/src/Distribution/Solver/Types/Variable.hs b/cabal/cabal-install-solver/src/Distribution/Solver/Types/Variable.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/src/Distribution/Solver/Types/Variable.hs @@ -0,0 +1,15 @@ +module Distribution.Solver.Types.Variable where + +import Prelude (Eq, Show) + +import Distribution.Solver.Types.OptionalStanza + +import Distribution.PackageDescription (FlagName) + +-- | Variables used by the dependency solver. This type is similar to the +-- internal 'Var' type. +data Variable qpn = + PackageVar qpn + | FlagVar qpn FlagName + | StanzaVar qpn OptionalStanza + deriving (Eq, Show) diff --git a/cabal/cabal-install-solver/tests/UnitTests.hs b/cabal/cabal-install-solver/tests/UnitTests.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/tests/UnitTests.hs @@ -0,0 +1,12 @@ +module Main (main) where + + +import Test.Tasty + +import qualified UnitTests.Distribution.Solver.Modular.MessageUtils + +main :: IO () +main = defaultMain $ testGroup "Unit Tests" + [ testGroup "UnitTests.Distribution.Solver.Modular.MessageUtils" + UnitTests.Distribution.Solver.Modular.MessageUtils.tests + ] diff --git a/cabal/cabal-install-solver/tests/UnitTests/Distribution/Solver/Modular/MessageUtils.hs b/cabal/cabal-install-solver/tests/UnitTests/Distribution/Solver/Modular/MessageUtils.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install-solver/tests/UnitTests/Distribution/Solver/Modular/MessageUtils.hs @@ -0,0 +1,70 @@ +module UnitTests.Distribution.Solver.Modular.MessageUtils ( tests ) where + +import Distribution.Solver.Modular.MessageUtils + (allKnownExtensions, cutoffRange, withinRange, mostSimilarElement) +import Language.Haskell.Extension (knownLanguages) +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +tests :: [TestTree] +tests = testProperty "the equal string is always the closest" propEqualStringClosest : assertionTests + +-- The equal string will always be the most similar element +propEqualStringClosest :: String -> Bool +propEqualStringClosest str = mostSimilarElement str [str] == str + +assertionTests :: [TestTree] +assertionTests = map (testCase "assert equals") (extensionAssertions ++ languageAssertions) ++ map (testCase "assert truthy") rangeAssertions + +extensionAssertions :: [Assertion] +extensionAssertions = map (`testClosest` extensionStrings) shouldSuggestExtension + +languageAssertions :: [Assertion] +languageAssertions = map (`testClosest` languageStrings) shouldSuggestLanguage + +testClosest :: (String, String) -> [String] -> Assertion +testClosest (misspelled, closestMatch) elems = assertEqual "Strings should match" closestMatch (mostSimilarElement misspelled elems) + +extensionStrings :: [String] +extensionStrings = allKnownExtensions + +languageStrings :: [String] +languageStrings = show <$> knownLanguages + +-- Given x misspelled extension should suggest y extension +shouldSuggestExtension :: [(String, String)] +shouldSuggestExtension = + [ ("FlexibleConstraints", "FlexibleContexts") + , ("FlexibleInstantiation", "FlexibleInstances") + , ("GATs", "GADTs") + , ("MultiTypeClass", "MultiParamTypeClasses") + , ("NoMonoLoclBinds", "NoMonoLocalBinds") + , ("NoLamdaCase", "NoLambdaCase") + ] + +-- Given x misspelled language should suggest y language +shouldSuggestLanguage :: [(String, String)] +shouldSuggestLanguage = + [ ("GHC2020", "GHC2021") + , ("Haskell2011", "Haskell2010") + , ("Hugs98", "Haskell98") + ] + +rangeAssertions :: [Assertion] +rangeAssertions = map (testRange cutoffRange extensionStrings) outOfBounds + +isOutOfBounds :: Int -> String -> String -> Bool +isOutOfBounds range a b = not $ withinRange range a b + +testRange :: Int -> [String] -> String -> Assertion +testRange range elems erronousElement = assertBool "String should be out of bounds to make a spelling suggestion" (isOutOfBounds range erronousElement suggestion) + where + suggestion = mostSimilarElement erronousElement elems + +outOfBounds :: [String] +outOfBounds = + [ "HopefullyThisExtensionWontOccur" + , "ThisIsNotEvenRemotelyAnExtension" + , "IsThisMaybeAnExtension" + ] diff --git a/cabal/cabal-install/Distribution/Client/BuildReports/Anonymous.hs b/cabal/cabal-install/Distribution/Client/BuildReports/Anonymous.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/BuildReports/Anonymous.hs +++ /dev/null @@ -1,157 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE OverloadedStrings #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Reporting --- Copyright : (c) David Waern 2008 --- License : BSD-like --- --- Maintainer : david.waern@gmail.com --- Stability : experimental --- Portability : portable --- --- Anonymous build report data structure, printing and parsing --- ------------------------------------------------------------------------------ -module Distribution.Client.BuildReports.Anonymous ( - BuildReport(..), - InstallOutcome(..), - Outcome(..), - - -- * Constructing and writing reports - newBuildReport, - - -- * parsing and pretty printing - parseBuildReport, - parseBuildReportList, - showBuildReport, --- showList, - ) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.CabalSpecVersion -import Distribution.Client.BuildReports.Types -import Distribution.Client.Utils (cabalInstallVersion) -import Distribution.Compiler (CompilerId (..)) -import Distribution.FieldGrammar -import Distribution.Fields (readFields, showFields) -import Distribution.Fields.ParseResult (ParseResult, parseFatalFailure, runParseResult) -import Distribution.Package (PackageIdentifier (..), mkPackageName) -import Distribution.PackageDescription (FlagAssignment) -import Distribution.Parsec (PError (..), zeroPos) -import Distribution.System (Arch, OS) - -import qualified Distribution.Client.BuildReports.Lens as L -import qualified Distribution.Client.Types as BR (BuildFailure (..), BuildOutcome, BuildResult (..), DocsResult (..), TestsResult (..)) - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BS8 - - -------------------------------------------------------------------------------- --- New -------------------------------------------------------------------------------- - -newBuildReport :: OS -> Arch -> CompilerId -> PackageIdentifier -> FlagAssignment - -> [PackageIdentifier] -> BR.BuildOutcome -> BuildReport -newBuildReport os' arch' comp pkgid flags deps result = - BuildReport { - package = pkgid, - os = os', - arch = arch', - compiler = comp, - client = cabalInstallID, - flagAssignment = flags, - dependencies = deps, - installOutcome = convertInstallOutcome, --- cabalVersion = undefined - docsOutcome = convertDocsOutcome, - testsOutcome = convertTestsOutcome - } - where - convertInstallOutcome = case result of - Left BR.PlanningFailed -> PlanningFailed - Left (BR.DependentFailed p) -> DependencyFailed p - Left (BR.DownloadFailed _) -> DownloadFailed - Left (BR.UnpackFailed _) -> UnpackFailed - Left (BR.ConfigureFailed _) -> ConfigureFailed - Left (BR.BuildFailed _) -> BuildFailed - Left (BR.TestsFailed _) -> TestsFailed - Left (BR.InstallFailed _) -> InstallFailed - Right (BR.BuildResult _ _ _) -> InstallOk - convertDocsOutcome = case result of - Left _ -> NotTried - Right (BR.BuildResult BR.DocsNotTried _ _) -> NotTried - Right (BR.BuildResult BR.DocsFailed _ _) -> Failed - Right (BR.BuildResult BR.DocsOk _ _) -> Ok - convertTestsOutcome = case result of - Left (BR.TestsFailed _) -> Failed - Left _ -> NotTried - Right (BR.BuildResult _ BR.TestsNotTried _) -> NotTried - Right (BR.BuildResult _ BR.TestsOk _) -> Ok - -cabalInstallID :: PackageIdentifier -cabalInstallID = - PackageIdentifier (mkPackageName "cabal-install") cabalInstallVersion - -------------------------------------------------------------------------------- --- FieldGrammar -------------------------------------------------------------------------------- - -fieldDescrs - :: ( Applicative (g BuildReport), FieldGrammar c g - , c (Identity Arch) - , c (Identity CompilerId) - , c (Identity FlagAssignment) - , c (Identity InstallOutcome) - , c (Identity OS) - , c (Identity Outcome) - , c (Identity PackageIdentifier) - , c (List VCat (Identity PackageIdentifier) PackageIdentifier) - ) - => g BuildReport BuildReport -fieldDescrs = BuildReport - <$> uniqueField "package" L.package - <*> uniqueField "os" L.os - <*> uniqueField "arch" L.arch - <*> uniqueField "compiler" L.compiler - <*> uniqueField "client" L.client - <*> monoidalField "flags" L.flagAssignment - <*> monoidalFieldAla "dependencies" (alaList VCat) L.dependencies - <*> uniqueField "install-outcome" L.installOutcome - <*> uniqueField "docs-outcome" L.docsOutcome - <*> uniqueField "tests-outcome" L.testsOutcome - --- ----------------------------------------------------------------------------- --- Parsing - -parseBuildReport :: BS.ByteString -> Either String BuildReport -parseBuildReport s = case snd $ runParseResult $ parseFields s of - Left (_, perrors) -> Left $ unlines [ err | PError _ err <- toList perrors ] - Right report -> Right report - -parseFields :: BS.ByteString -> ParseResult BuildReport -parseFields input = do - fields <- either (parseFatalFailure zeroPos . show) pure $ readFields input - case partitionFields fields of - (fields', []) -> parseFieldGrammar CabalSpecV2_4 fields' fieldDescrs - _otherwise -> parseFatalFailure zeroPos "found sections in BuildReport" - -parseBuildReportList :: BS.ByteString -> [BuildReport] -parseBuildReportList str = - [ report | Right report <- map parseBuildReport (split str) ] - - where - split :: BS.ByteString -> [BS.ByteString] - split = filter (not . BS.null) . unfoldr chunk . BS8.lines - chunk [] = Nothing - chunk ls = case break BS.null ls of - (r, rs) -> Just (BS8.unlines r, dropWhile BS.null rs) - --- ----------------------------------------------------------------------------- --- Pretty-printing - -showBuildReport :: BuildReport -> String -showBuildReport = showFields (const []) . prettyFieldGrammar CabalSpecV2_4 fieldDescrs diff --git a/cabal/cabal-install/Distribution/Client/BuildReports/Lens.hs b/cabal/cabal-install/Distribution/Client/BuildReports/Lens.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/BuildReports/Lens.hs +++ /dev/null @@ -1,46 +0,0 @@ -module Distribution.Client.BuildReports.Lens ( - BuildReport, - module Distribution.Client.BuildReports.Lens, -) where - -import Distribution.Client.Compat.Prelude -import Distribution.Compat.Lens -import Prelude () - -import Distribution.Client.BuildReports.Types (BuildReport, InstallOutcome, Outcome) -import Distribution.Compiler (CompilerId) -import Distribution.System (Arch, OS) -import Distribution.Types.Flag (FlagAssignment) -import Distribution.Types.PackageId (PackageIdentifier) - -import qualified Distribution.Client.BuildReports.Types as T - -package :: Lens' BuildReport PackageIdentifier -package f s = fmap (\x -> s { T.package = x }) (f (T.package s)) - -os :: Lens' BuildReport OS -os f s = fmap (\x -> s { T.os = x }) (f (T.os s)) - -arch :: Lens' BuildReport Arch -arch f s = fmap (\x -> s { T.arch = x }) (f (T.arch s)) - -compiler :: Lens' BuildReport CompilerId -compiler f s = fmap (\x -> s { T.compiler = x }) (f (T.compiler s)) - -client :: Lens' BuildReport PackageIdentifier -client f s = fmap (\x -> s { T.client = x }) (f (T.client s)) - -flagAssignment :: Lens' BuildReport FlagAssignment -flagAssignment f s = fmap (\x -> s { T.flagAssignment = x }) (f (T.flagAssignment s)) - -dependencies :: Lens' BuildReport [PackageIdentifier] -dependencies f s = fmap (\x -> s { T.dependencies = x }) (f (T.dependencies s)) - -installOutcome :: Lens' BuildReport InstallOutcome -installOutcome f s = fmap (\x -> s { T.installOutcome = x }) (f (T.installOutcome s)) - -docsOutcome :: Lens' BuildReport Outcome -docsOutcome f s = fmap (\x -> s { T.docsOutcome = x }) (f (T.docsOutcome s)) - -testsOutcome :: Lens' BuildReport Outcome -testsOutcome f s = fmap (\x -> s { T.testsOutcome = x }) (f (T.testsOutcome s)) diff --git a/cabal/cabal-install/Distribution/Client/BuildReports/Storage.hs b/cabal/cabal-install/Distribution/Client/BuildReports/Storage.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/BuildReports/Storage.hs +++ /dev/null @@ -1,162 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Reporting --- Copyright : (c) David Waern 2008 --- License : BSD-like --- --- Maintainer : david.waern@gmail.com --- Stability : experimental --- Portability : portable --- --- Anonymous build report data structure, printing and parsing --- ------------------------------------------------------------------------------ -module Distribution.Client.BuildReports.Storage ( - - -- * Storing and retrieving build reports - storeAnonymous, - storeLocal, --- retrieve, - - -- * 'InstallPlan' support - fromInstallPlan, - fromPlanningFailure, - ) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Client.BuildReports.Anonymous (BuildReport, showBuildReport, newBuildReport) -import qualified Distribution.Client.BuildReports.Anonymous as BuildReport - -import Distribution.Client.Types -import qualified Distribution.Client.InstallPlan as InstallPlan -import Distribution.Client.InstallPlan - ( InstallPlan ) - -import qualified Distribution.Solver.Types.ComponentDeps as CD -import Distribution.Solver.Types.SourcePackage - -import Distribution.Package - ( PackageId, packageId ) -import Distribution.PackageDescription - ( FlagAssignment ) -import Distribution.Simple.InstallDirs - ( PathTemplate, fromPathTemplate - , initialPathTemplateEnv, substPathTemplate ) -import Distribution.System - ( Platform(Platform) ) -import Distribution.Compiler - ( CompilerId(..), CompilerInfo(..) ) -import Distribution.Simple.Utils - ( equating ) - -import Data.List.NonEmpty - ( groupBy ) -import qualified Data.List as L -import System.FilePath - ( (), takeDirectory ) -import System.Directory - ( createDirectoryIfMissing ) - -storeAnonymous :: [(BuildReport, Maybe Repo)] -> IO () -storeAnonymous reports = sequence_ - [ appendFile file (concatMap format reports') - | (repo, reports') <- separate reports - , let file = repoLocalDir repo "build-reports.log" ] - --TODO: make this concurrency safe, either lock the report file or make sure - -- the writes for each report are atomic (under 4k and flush at boundaries) - - where - format r = '\n' : showBuildReport r ++ "\n" - 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 - repoName (_,_,rrepo) = remoteRepoName rrepo - - onlyRemote :: [(BuildReport, Maybe Repo)] - -> [(BuildReport, Repo, RemoteRepo)] - onlyRemote rs = - [ (report, repo, remoteRepo) - | (report, Just repo) <- rs - , Just remoteRepo <- [maybeRepoRemote repo] - ] - -storeLocal :: CompilerInfo -> [PathTemplate] -> [(BuildReport, Maybe Repo)] - -> Platform -> IO () -storeLocal cinfo templates reports platform = sequence_ - [ do createDirectoryIfMissing True (takeDirectory file) - appendFile file output - --TODO: make this concurrency safe, either lock the report file or make - -- sure the writes for each report are atomic - | (file, reports') <- groupByFileName - [ (reportFileName template report, report) - | template <- templates - , (report, _repo) <- reports ] - , let output = concatMap format reports' - ] - where - format r = '\n' : showBuildReport r ++ "\n" - - reportFileName template report = - fromPathTemplate (substPathTemplate env template) - where env = initialPathTemplateEnv - (BuildReport.package report) - -- TODO: In principle, we can support $pkgkey, but only - -- if the configure step succeeds. So add a Maybe field - -- to the build report, and either use that or make up - -- a fake identifier if it's not available. - (error "storeLocal: package key not available") - cinfo - platform - - groupByFileName = map (\grp@((filename,_):_) -> (filename, map snd grp)) - . L.groupBy (equating fst) - . sortBy (comparing fst) - --- ------------------------------------------------------------ --- * InstallPlan support --- ------------------------------------------------------------ - -fromInstallPlan :: Platform -> CompilerId - -> InstallPlan - -> BuildOutcomes - -> [(BuildReport, Maybe Repo)] -fromInstallPlan platform comp plan buildOutcomes = - mapMaybe (\pkg -> fromPlanPackage - platform comp pkg - (InstallPlan.lookupBuildOutcome pkg buildOutcomes)) - . InstallPlan.toList - $ plan - -fromPlanPackage :: Platform -> CompilerId - -> InstallPlan.PlanPackage - -> Maybe BuildOutcome - -> Maybe (BuildReport, Maybe Repo) -fromPlanPackage (Platform arch os) comp - (InstallPlan.Configured (ConfiguredPackage _ srcPkg flags _ deps)) - (Just buildResult) = - Just ( newBuildReport os arch comp - (packageId srcPkg) flags - (map packageId (CD.nonSetupDeps deps)) - buildResult - , extractRepo srcPkg) - where - extractRepo (SourcePackage { srcpkgSource = RepoTarballPackage repo _ _ }) - = Just repo - extractRepo _ = Nothing - -fromPlanPackage _ _ _ _ = Nothing - - -fromPlanningFailure :: Platform -> CompilerId - -> [PackageId] -> FlagAssignment -> [(BuildReport, Maybe Repo)] -fromPlanningFailure (Platform arch os) comp pkgids flags = - [ (newBuildReport os arch comp pkgid flags [] (Left PlanningFailed), Nothing) - | pkgid <- pkgids ] diff --git a/cabal/cabal-install/Distribution/Client/BuildReports/Types.hs b/cabal/cabal-install/Distribution/Client/BuildReports/Types.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/BuildReports/Types.hs +++ /dev/null @@ -1,166 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.BuildReports.Types --- Copyright : (c) Duncan Coutts 2009 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Types related to build reporting --- ------------------------------------------------------------------------------ -module Distribution.Client.BuildReports.Types ( - ReportLevel(..), - BuildReport (..), - InstallOutcome(..), - Outcome(..), -) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - -import Distribution.Compiler (CompilerId (..)) -import Distribution.PackageDescription (FlagAssignment) -import Distribution.System (Arch, OS) -import Distribution.Types.PackageId (PackageIdentifier) - -------------------------------------------------------------------------------- --- ReportLevel -------------------------------------------------------------------------------- - -data ReportLevel = NoReports | AnonymousReports | DetailedReports - deriving (Eq, Ord, Enum, Bounded, Show, Generic) - -instance Binary ReportLevel -instance Structured ReportLevel - -instance Pretty ReportLevel where - pretty NoReports = Disp.text "none" - pretty AnonymousReports = Disp.text "anonymous" - pretty DetailedReports = Disp.text "detailed" - -instance Parsec ReportLevel where - parsec = do - name <- P.munch1 isAlpha - case lowercase name of - "none" -> return NoReports - "anonymous" -> return AnonymousReports - "detailed" -> return DetailedReports - _ -> P.unexpected $ "ReportLevel: " ++ name - -lowercase :: String -> String -lowercase = map toLower - -------------------------------------------------------------------------------- --- BuildReport -------------------------------------------------------------------------------- - -data BuildReport = BuildReport { - -- | The package this build report is about - package :: PackageIdentifier, - - -- | The OS and Arch the package was built on - os :: OS, - arch :: Arch, - - -- | The Haskell compiler (and hopefully version) used - compiler :: CompilerId, - - -- | The uploading client, ie cabal-install-x.y.z - client :: PackageIdentifier, - - -- | Which configurations flags we used - flagAssignment :: FlagAssignment, - - -- | Which dependent packages we were using exactly - dependencies :: [PackageIdentifier], - - -- | Did installing work ok? - installOutcome :: InstallOutcome, - - -- Which version of the Cabal library was used to compile the Setup.hs --- cabalVersion :: Version, - - -- Which build tools we were using (with versions) --- tools :: [PackageIdentifier], - - -- | Configure outcome, did configure work ok? - docsOutcome :: Outcome, - - -- | Configure outcome, did configure work ok? - testsOutcome :: Outcome - } - deriving (Eq, Show, Generic) - - - -------------------------------------------------------------------------------- --- InstallOutcome -------------------------------------------------------------------------------- - -data InstallOutcome - = PlanningFailed - | DependencyFailed PackageIdentifier - | DownloadFailed - | UnpackFailed - | SetupFailed - | ConfigureFailed - | BuildFailed - | TestsFailed - | InstallFailed - | InstallOk - deriving (Eq, Show, Generic) - -instance Pretty InstallOutcome where - pretty PlanningFailed = Disp.text "PlanningFailed" - pretty (DependencyFailed pkgid) = Disp.text "DependencyFailed" <+> pretty pkgid - pretty DownloadFailed = Disp.text "DownloadFailed" - pretty UnpackFailed = Disp.text "UnpackFailed" - pretty SetupFailed = Disp.text "SetupFailed" - pretty ConfigureFailed = Disp.text "ConfigureFailed" - pretty BuildFailed = Disp.text "BuildFailed" - pretty TestsFailed = Disp.text "TestsFailed" - pretty InstallFailed = Disp.text "InstallFailed" - pretty InstallOk = Disp.text "InstallOk" - -instance Parsec InstallOutcome where - parsec = do - name <- P.munch1 isAlpha - case name of - "PlanningFailed" -> return PlanningFailed - "DependencyFailed" -> DependencyFailed <$ P.spaces <*> parsec - "DownloadFailed" -> return DownloadFailed - "UnpackFailed" -> return UnpackFailed - "SetupFailed" -> return SetupFailed - "ConfigureFailed" -> return ConfigureFailed - "BuildFailed" -> return BuildFailed - "TestsFailed" -> return TestsFailed - "InstallFailed" -> return InstallFailed - "InstallOk" -> return InstallOk - _ -> P.unexpected $ "InstallOutcome: " ++ name - -------------------------------------------------------------------------------- --- Outcome -------------------------------------------------------------------------------- - -data Outcome = NotTried | Failed | Ok - deriving (Eq, Show, Enum, Bounded, Generic) - -instance Pretty Outcome where - pretty NotTried = Disp.text "NotTried" - pretty Failed = Disp.text "Failed" - pretty Ok = Disp.text "Ok" - -instance Parsec Outcome where - parsec = do - name <- P.munch1 isAlpha - case name of - "NotTried" -> return NotTried - "Failed" -> return Failed - "Ok" -> return Ok - _ -> P.unexpected $ "Outcome: " ++ name diff --git a/cabal/cabal-install/Distribution/Client/BuildReports/Upload.hs b/cabal/cabal-install/Distribution/Client/BuildReports/Upload.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/BuildReports/Upload.hs +++ /dev/null @@ -1,91 +0,0 @@ -{-# LANGUAGE CPP, PatternGuards #-} --- This is a quick hack for uploading build reports to Hackage. - -module Distribution.Client.BuildReports.Upload - ( BuildLog - , BuildReportId - , uploadReports - ) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -{- -import Network.Browser - ( BrowserAction, request, setAllowRedirects ) -import Network.HTTP - ( Header(..), HeaderName(..) - , Request(..), RequestMethod(..), Response(..) ) -import Network.TCP (HandleStream) --} -import Network.URI (URI, uriPath) --parseRelativeReference, relativeTo) - -import System.FilePath.Posix - ( () ) -import qualified Distribution.Client.BuildReports.Anonymous as BuildReport -import Distribution.Client.BuildReports.Anonymous (BuildReport, showBuildReport) -import Distribution.Simple.Utils (die') -import Distribution.Client.HttpUtils -import Distribution.Client.Setup - ( RepoContext(..) ) - -type BuildReportId = URI -type BuildLog = String - -uploadReports :: Verbosity -> RepoContext -> (String, String) -> URI -> [(BuildReport, Maybe BuildLog)] -> IO () -uploadReports verbosity repoCtxt auth uri reports = do - for_ reports $ \(report, mbBuildLog) -> do - buildId <- postBuildReport verbosity repoCtxt auth uri report - case mbBuildLog of - Just buildLog -> putBuildLog verbosity repoCtxt auth buildId buildLog - Nothing -> return () - -postBuildReport :: Verbosity -> RepoContext -> (String, String) -> URI -> BuildReport -> IO BuildReportId -postBuildReport verbosity repoCtxt auth uri buildReport = do - let fullURI = uri { uriPath = "/package" prettyShow (BuildReport.package buildReport) "reports" } - transport <- repoContextGetTransport repoCtxt - res <- postHttp transport verbosity fullURI (showBuildReport buildReport) (Just auth) - case res of - (303, redir) -> return $ undefined redir --TODO parse redir - _ -> die' verbosity "unrecognized response" -- give response - -{- - setAllowRedirects False - (_, response) <- request Request { - rqURI = uri { uriPath = "/package" prettyShow (BuildReport.package buildReport) "reports" }, - rqMethod = POST, - rqHeaders = [Header HdrContentType ("text/plain"), - Header HdrContentLength (show (length body)), - Header HdrAccept ("text/plain")], - rqBody = body - } - case rspCode response of - (3,0,3) | [Just buildId] <- [ do rel <- parseRelativeReference location -#if defined(VERSION_network_uri) - return $ relativeTo rel uri -#elif defined(VERSION_network) -#if MIN_VERSION_network(2,4,0) - return $ relativeTo rel uri -#else - relativeTo rel uri -#endif -#endif - | Header HdrLocation location <- rspHeaders response ] - -> return $ buildId - _ -> error "Unrecognised response from server." - where body = BuildReport.show buildReport --} - - --- TODO force this to be a PUT? - -putBuildLog :: Verbosity -> RepoContext -> (String, String) - -> BuildReportId -> BuildLog - -> IO () -putBuildLog verbosity repoCtxt auth reportId buildLog = do - let fullURI = reportId {uriPath = uriPath reportId "log"} - transport <- repoContextGetTransport repoCtxt - res <- postHttp transport verbosity fullURI buildLog (Just auth) - case res of - (200, _) -> return () - _ -> die' verbosity "unrecognized response" -- give response diff --git a/cabal/cabal-install/Distribution/Client/Check.hs b/cabal/cabal-install/Distribution/Client/Check.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Check.hs +++ /dev/null @@ -1,114 +0,0 @@ -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Check --- Copyright : (c) Lennart Kolmodin 2008 --- License : BSD-like --- --- Maintainer : kolmodin@haskell.org --- Stability : provisional --- Portability : portable --- --- Check a package for common mistakes --- ------------------------------------------------------------------------------ -module Distribution.Client.Check ( - check - ) where - - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Client.Utils.Parsec (renderParseError) -import Distribution.PackageDescription (GenericPackageDescription) -import Distribution.PackageDescription.Check -import Distribution.PackageDescription.Configuration (flattenPackageDescription) -import Distribution.PackageDescription.Parsec - (parseGenericPackageDescription, runParseResult) -import Distribution.Parsec (PWarning (..), showPError, showPWarning) -import Distribution.Simple.Utils (defaultPackageDesc, die', notice, warn) -import System.IO (hPutStr, stderr) - -import qualified Data.ByteString as BS -import qualified System.Directory as Dir - -readGenericPackageDescriptionCheck :: Verbosity -> FilePath -> IO ([PWarning], GenericPackageDescription) -readGenericPackageDescriptionCheck verbosity fpath = do - exists <- Dir.doesFileExist fpath - unless exists $ - die' verbosity $ - "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue." - bs <- BS.readFile fpath - let (warnings, result) = runParseResult (parseGenericPackageDescription bs) - case result of - Left (_, errors) -> do - traverse_ (warn verbosity . showPError fpath) errors - hPutStr stderr $ renderParseError fpath bs errors warnings - die' verbosity "parse error" - Right x -> return (warnings, x) - --- | Note: must be called with the CWD set to the directory containing --- the '.cabal' file. -check :: Verbosity -> IO Bool -check verbosity = do - pdfile <- defaultPackageDesc verbosity - (ws, ppd) <- readGenericPackageDescriptionCheck verbosity pdfile - -- convert parse warnings into PackageChecks - -- Note: we /could/ pick different levels, based on warning type. - let ws' = [ PackageDistSuspicious (showPWarning pdfile w) | w <- ws ] - -- flatten the generic package description into a regular package - -- description - -- TODO: this may give more warnings than it should give; - -- consider two branches of a condition, one saying - -- ghc-options: -Wall - -- and the other - -- ghc-options: -Werror - -- joined into - -- ghc-options: -Wall -Werror - -- checkPackages will yield a warning on the last line, but it - -- would not on each individual branch. - -- Hovever, this is the same way hackage does it, so we will yield - -- the exact same errors as it will. - let pkg_desc = flattenPackageDescription ppd - ioChecks <- checkPackageFiles verbosity pkg_desc "." - let packageChecks = ioChecks ++ checkPackage ppd (Just pkg_desc) ++ ws' - buildImpossible = [ x | x@PackageBuildImpossible {} <- packageChecks ] - buildWarning = [ x | x@PackageBuildWarning {} <- packageChecks ] - distSuspicious = [ x | x@PackageDistSuspicious {} <- packageChecks ] - ++ [ x | x@PackageDistSuspiciousWarn {} <- packageChecks ] - distInexusable = [ x | x@PackageDistInexcusable {} <- packageChecks ] - - unless (null buildImpossible) $ do - warn verbosity "The package will not build sanely due to these errors:" - printCheckMessages buildImpossible - - unless (null buildWarning) $ do - warn verbosity "The following warnings are likely to affect your build negatively:" - printCheckMessages buildWarning - - unless (null distSuspicious) $ do - warn verbosity "These warnings may cause trouble when distributing the package:" - printCheckMessages distSuspicious - - unless (null distInexusable) $ do - warn verbosity "The following errors will cause portability problems on other environments:" - printCheckMessages distInexusable - - let isDistError (PackageDistSuspicious {}) = False - isDistError (PackageDistSuspiciousWarn {}) = False - isDistError _ = True - isCheckError (PackageDistSuspiciousWarn {}) = False - isCheckError _ = True - errors = filter isDistError packageChecks - - unless (null errors) $ - warn verbosity "Hackage would reject this package." - - when (null packageChecks) $ - notice verbosity "No errors or warnings could be found in the package." - - return (not . any isCheckError $ packageChecks) - - where - printCheckMessages = traverse_ (warn verbosity . explanation) diff --git a/cabal/cabal-install/Distribution/Client/CmdBench.hs b/cabal/cabal-install/Distribution/Client/CmdBench.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/CmdBench.hs +++ /dev/null @@ -1,254 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} - --- | cabal-install CLI command: bench --- -module Distribution.Client.CmdBench ( - -- * The @bench@ CLI and action - benchCommand, - benchAction, - - -- * Internals exposed for testing - componentNotBenchmarkProblem, - isSubComponentProblem, - noBenchmarksProblem, - selectPackageTargets, - selectComponentTarget - ) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Client.ProjectOrchestration -import Distribution.Client.CmdErrorMessages - ( renderTargetSelector, showTargetSelector, renderTargetProblem, - renderTargetProblemNoTargets, plural, targetSelectorPluralPkgs, - targetSelectorFilter ) -import Distribution.Client.TargetProblem - ( TargetProblem (..) ) -import Distribution.Client.NixStyleOptions - ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) -import Distribution.Client.Setup - ( GlobalFlags, ConfigFlags(..) ) -import Distribution.Simple.Flag - ( fromFlagOrDefault ) -import Distribution.Simple.Command - ( CommandUI(..), usageAlternatives ) -import Distribution.Verbosity - ( normal ) -import Distribution.Simple.Utils - ( wrapText, die' ) - -benchCommand :: CommandUI (NixStyleFlags ()) -benchCommand = CommandUI { - commandName = "v2-bench", - commandSynopsis = "Run benchmarks", - commandUsage = usageAlternatives "v2-bench" [ "[TARGETS] [FLAGS]" ], - commandDescription = Just $ \_ -> wrapText $ - "Runs the specified benchmarks, first ensuring they are up to " - ++ "date.\n\n" - - ++ "Any benchmark in any package in the project can be specified. " - ++ "A package can be specified in which case all the benchmarks in the " - ++ "package are run. The default is to run all the benchmarks in the " - ++ "package in the current directory.\n\n" - - ++ "Dependencies are built or rebuilt as necessary. Additional " - ++ "configuration flags can be specified on the command line and these " - ++ "extend the project configuration from the 'cabal.project', " - ++ "'cabal.project.local' and other files.", - commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " v2-bench\n" - ++ " Run all the benchmarks in the package in the current directory\n" - ++ " " ++ pname ++ " v2-bench pkgname\n" - ++ " Run all the benchmarks in the package named pkgname\n" - ++ " " ++ pname ++ " v2-bench cname\n" - ++ " Run the benchmark named cname\n" - ++ " " ++ pname ++ " v2-bench cname -O2\n" - ++ " Run the benchmark built with '-O2' (including local libs used)\n\n" - - ++ cmdCommonHelpTextNewBuildBeta - - , commandDefaultFlags = defaultNixStyleFlags () - , commandOptions = nixStyleOptions (const []) - } - - --- | The @build@ command does a lot. It brings the install plan up to date, --- selects that part of the plan needed by the given or implicit targets and --- then executes the plan. --- --- For more details on how this works, see the module --- "Distribution.Client.ProjectOrchestration" --- -benchAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO () -benchAction flags@NixStyleFlags {..} targetStrings globalFlags = do - - baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand - - targetSelectors <- either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors (localPackages baseCtx) (Just BenchKind) targetStrings - - buildCtx <- - runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do - - when (buildSettingOnlyDeps (buildSettings baseCtx)) $ - die' verbosity $ - "The bench command does not support '--only-dependencies'. " - ++ "You may wish to use 'build --only-dependencies' and then " - ++ "use 'bench'." - - -- Interpret the targets on the command line as bench targets - -- (as opposed to say build or haddock targets). - targets <- either (reportTargetProblems verbosity) return - $ resolveTargets - selectPackageTargets - selectComponentTarget - elaboratedPlan - Nothing - targetSelectors - - let elaboratedPlan' = pruneInstallPlanToTargets - TargetActionBench - targets - elaboratedPlan - return (elaboratedPlan', targets) - - printPlan verbosity baseCtx buildCtx - - buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx - runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes - where - verbosity = fromFlagOrDefault normal (configVerbosity configFlags) - cliConfig = commandLineFlagsToProjectConfig globalFlags flags - mempty -- ClientInstallFlags, not needed here - --- | This defines what a 'TargetSelector' means for the @bench@ command. --- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, --- or otherwise classifies the problem. --- --- For the @bench@ command we select all buildable benchmarks, --- or fail if there are no benchmarks or no buildable benchmarks. --- -selectPackageTargets :: TargetSelector - -> [AvailableTarget k] -> Either BenchTargetProblem [k] -selectPackageTargets targetSelector targets - - -- If there are any buildable benchmark targets then we select those - | not (null targetsBenchBuildable) - = Right targetsBenchBuildable - - -- If there are benchmarks but none are buildable then we report those - | not (null targetsBench) - = Left (TargetProblemNoneEnabled targetSelector targetsBench) - - -- If there are no benchmarks but some other targets then we report that - | not (null targets) - = Left (noBenchmarksProblem targetSelector) - - -- If there are no targets at all then we report that - | otherwise - = Left (TargetProblemNoTargets targetSelector) - where - targetsBenchBuildable = selectBuildableTargets - . filterTargetsKind BenchKind - $ targets - - targetsBench = forgetTargetsDetail - . filterTargetsKind BenchKind - $ targets - - --- | For a 'TargetComponent' 'TargetSelector', check if the component can be --- selected. --- --- For the @bench@ command we just need to check it is a benchmark, in addition --- to the basic checks on being buildable etc. --- -selectComponentTarget :: SubComponentTarget - -> AvailableTarget k -> Either BenchTargetProblem k -selectComponentTarget subtarget@WholeComponent t - | CBenchName _ <- availableTargetComponentName t - = selectComponentTargetBasic subtarget t - | otherwise - = Left (componentNotBenchmarkProblem - (availableTargetPackageId t) - (availableTargetComponentName t)) - -selectComponentTarget subtarget t - = Left (isSubComponentProblem - (availableTargetPackageId t) - (availableTargetComponentName t) - subtarget) - --- | The various error conditions that can occur when matching a --- 'TargetSelector' against 'AvailableTarget's for the @bench@ command. --- -data BenchProblem = - -- | The 'TargetSelector' matches targets but no benchmarks - TargetProblemNoBenchmarks TargetSelector - - -- | The 'TargetSelector' refers to a component that is not a benchmark - | TargetProblemComponentNotBenchmark PackageId ComponentName - - -- | Asking to benchmark an individual file or module is not supported - | TargetProblemIsSubComponent PackageId ComponentName SubComponentTarget - deriving (Eq, Show) - - -type BenchTargetProblem = TargetProblem BenchProblem - -noBenchmarksProblem :: TargetSelector -> TargetProblem BenchProblem -noBenchmarksProblem = CustomTargetProblem . TargetProblemNoBenchmarks - -componentNotBenchmarkProblem :: PackageId -> ComponentName -> TargetProblem BenchProblem -componentNotBenchmarkProblem pkgid name = CustomTargetProblem $ - TargetProblemComponentNotBenchmark pkgid name - -isSubComponentProblem - :: PackageId - -> ComponentName - -> SubComponentTarget - -> TargetProblem BenchProblem -isSubComponentProblem pkgid name subcomponent = CustomTargetProblem $ - TargetProblemIsSubComponent pkgid name subcomponent - -reportTargetProblems :: Verbosity -> [BenchTargetProblem] -> IO a -reportTargetProblems verbosity = - die' verbosity . unlines . map renderBenchTargetProblem - -renderBenchTargetProblem :: BenchTargetProblem -> String -renderBenchTargetProblem (TargetProblemNoTargets targetSelector) = - case targetSelectorFilter targetSelector of - Just kind | kind /= BenchKind - -> "The bench command is for running benchmarks, but the target '" - ++ showTargetSelector targetSelector ++ "' refers to " - ++ renderTargetSelector targetSelector ++ "." - - _ -> renderTargetProblemNoTargets "benchmark" targetSelector -renderBenchTargetProblem problem = - renderTargetProblem "benchmark" renderBenchProblem problem - -renderBenchProblem :: BenchProblem -> String -renderBenchProblem (TargetProblemNoBenchmarks targetSelector) = - "Cannot run benchmarks for the target '" ++ showTargetSelector targetSelector - ++ "' which refers to " ++ renderTargetSelector targetSelector - ++ " because " - ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do" - ++ " not contain any benchmarks." - -renderBenchProblem (TargetProblemComponentNotBenchmark pkgid cname) = - "The bench command is for running benchmarks, but the target '" - ++ showTargetSelector targetSelector ++ "' refers to " - ++ renderTargetSelector targetSelector ++ " from the package " - ++ prettyShow pkgid ++ "." - where - targetSelector = TargetComponent pkgid cname WholeComponent - -renderBenchProblem (TargetProblemIsSubComponent pkgid cname subtarget) = - "The bench command can only run benchmarks as a whole, " - ++ "not files or modules within them, but the target '" - ++ showTargetSelector targetSelector ++ "' refers to " - ++ renderTargetSelector targetSelector ++ "." - where - targetSelector = TargetComponent pkgid cname subtarget diff --git a/cabal/cabal-install/Distribution/Client/CmdBuild.hs b/cabal/cabal-install/Distribution/Client/CmdBuild.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/CmdBuild.hs +++ /dev/null @@ -1,197 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} --- | cabal-install CLI command: build --- -module Distribution.Client.CmdBuild ( - -- * The @build@ CLI and action - buildCommand, - buildAction, - - -- * Internals exposed for testing - selectPackageTargets, - selectComponentTarget - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude - -import Distribution.Client.ProjectOrchestration -import Distribution.Client.TargetProblem - ( TargetProblem (..), TargetProblem' ) -import Distribution.Client.CmdErrorMessages - -import Distribution.Client.NixStyleOptions - ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) -import Distribution.Client.Setup - ( GlobalFlags, ConfigFlags(..), yesNoOpt ) -import Distribution.Simple.Flag ( Flag(..), toFlag, fromFlag, fromFlagOrDefault ) -import Distribution.Simple.Command - ( CommandUI(..), usageAlternatives, option, optionName ) -import Distribution.Verbosity - ( normal ) -import Distribution.Simple.Utils - ( wrapText, die' ) - -import qualified Data.Map as Map - - -buildCommand :: CommandUI (NixStyleFlags BuildFlags) -buildCommand = CommandUI { - commandName = "v2-build", - commandSynopsis = "Compile targets within the project.", - commandUsage = usageAlternatives "v2-build" [ "[TARGETS] [FLAGS]" ], - commandDescription = Just $ \_ -> wrapText $ - "Build one or more targets from within the project. The available " - ++ "targets are the packages in the project as well as individual " - ++ "components within those packages, including libraries, executables, " - ++ "test-suites or benchmarks. Targets can be specified by name or " - ++ "location. If no target is specified then the default is to build " - ++ "the package in the current directory.\n\n" - - ++ "Dependencies are built or rebuilt as necessary. Additional " - ++ "configuration flags can be specified on the command line and these " - ++ "extend the project configuration from the 'cabal.project', " - ++ "'cabal.project.local' and other files.", - commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " v2-build\n" - ++ " Build the package in the current directory " - ++ "or all packages in the project\n" - ++ " " ++ pname ++ " v2-build pkgname\n" - ++ " Build the package named pkgname in the project\n" - ++ " " ++ pname ++ " v2-build ./pkgfoo\n" - ++ " Build the package in the ./pkgfoo directory\n" - ++ " " ++ pname ++ " v2-build cname\n" - ++ " Build the component named cname in the project\n" - ++ " " ++ pname ++ " v2-build cname --enable-profiling\n" - ++ " Build the component in profiling mode " - ++ "(including dependencies as needed)\n\n" - - ++ cmdCommonHelpTextNewBuildBeta - , commandDefaultFlags = defaultNixStyleFlags defaultBuildFlags - , commandOptions = filter (\o -> optionName o /= "ignore-project") - . nixStyleOptions (\showOrParseArgs -> - [ option [] ["only-configure"] - "Instead of performing a full build just run the configure step" - buildOnlyConfigure (\v flags -> flags { buildOnlyConfigure = v }) - (yesNoOpt showOrParseArgs) - ]) - } - -data BuildFlags = BuildFlags - { buildOnlyConfigure :: Flag Bool - } - -defaultBuildFlags :: BuildFlags -defaultBuildFlags = BuildFlags - { buildOnlyConfigure = toFlag False - } - --- | The @build@ command does a lot. It brings the install plan up to date, --- selects that part of the plan needed by the given or implicit targets and --- then executes the plan. --- --- For more details on how this works, see the module --- "Distribution.Client.ProjectOrchestration" --- -buildAction :: NixStyleFlags BuildFlags -> [String] -> GlobalFlags -> IO () -buildAction flags@NixStyleFlags { extraFlags = buildFlags, ..} targetStrings globalFlags = do - -- TODO: This flags defaults business is ugly - let onlyConfigure = fromFlag (buildOnlyConfigure defaultBuildFlags - <> buildOnlyConfigure buildFlags) - targetAction - | onlyConfigure = TargetActionConfigure - | otherwise = TargetActionBuild - - baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand - - targetSelectors <- - either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors (localPackages baseCtx) Nothing targetStrings - - buildCtx <- - runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do - - -- Interpret the targets on the command line as build targets - -- (as opposed to say repl or haddock targets). - targets <- either (reportBuildTargetProblems verbosity) return - $ resolveTargets - selectPackageTargets - selectComponentTarget - elaboratedPlan - Nothing - targetSelectors - - let elaboratedPlan' = pruneInstallPlanToTargets - targetAction - targets - elaboratedPlan - elaboratedPlan'' <- - if buildSettingOnlyDeps (buildSettings baseCtx) - then either (reportCannotPruneDependencies verbosity) return $ - pruneInstallPlanToDependencies (Map.keysSet targets) - elaboratedPlan' - else return elaboratedPlan' - - return (elaboratedPlan'', targets) - - printPlan verbosity baseCtx buildCtx - - buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx - runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes - where - verbosity = fromFlagOrDefault normal (configVerbosity configFlags) - cliConfig = commandLineFlagsToProjectConfig globalFlags flags - mempty -- ClientInstallFlags, not needed here - --- | This defines what a 'TargetSelector' means for the @bench@ command. --- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, --- or otherwise classifies the problem. --- --- For the @build@ command select all components except non-buildable --- and disabled tests\/benchmarks, fail if there are no such --- components --- -selectPackageTargets :: TargetSelector - -> [AvailableTarget k] -> Either TargetProblem' [k] -selectPackageTargets targetSelector targets - - -- If there are any buildable targets then we select those - | not (null targetsBuildable) - = Right targetsBuildable - - -- If there are targets but none are buildable then we report those - | not (null targets) - = Left (TargetProblemNoneEnabled targetSelector targets') - - -- If there are no targets at all then we report that - | otherwise - = Left (TargetProblemNoTargets targetSelector) - where - targets' = forgetTargetsDetail targets - targetsBuildable = selectBuildableTargetsWith - (buildable targetSelector) - targets - - -- When there's a target filter like "pkg:tests" then we do select tests, - -- but if it's just a target like "pkg" then we don't build tests unless - -- they are requested by default (i.e. by using --enable-tests) - buildable (TargetPackage _ _ Nothing) TargetNotRequestedByDefault = False - buildable (TargetAllPackages Nothing) TargetNotRequestedByDefault = False - buildable _ _ = True - --- | For a 'TargetComponent' 'TargetSelector', check if the component can be --- selected. --- --- For the @build@ command we just need the basic checks on being buildable etc. --- -selectComponentTarget :: SubComponentTarget - -> AvailableTarget k -> Either TargetProblem' k -selectComponentTarget = selectComponentTargetBasic - -reportBuildTargetProblems :: Verbosity -> [TargetProblem'] -> IO a -reportBuildTargetProblems verbosity problems = - reportTargetProblems verbosity "build" problems - -reportCannotPruneDependencies :: Verbosity -> CannotPruneDependencies -> IO a -reportCannotPruneDependencies verbosity = - die' verbosity . renderCannotPruneDependencies diff --git a/cabal/cabal-install/Distribution/Client/CmdClean.hs b/cabal/cabal-install/Distribution/Client/CmdClean.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/CmdClean.hs +++ /dev/null @@ -1,111 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -module Distribution.Client.CmdClean (cleanCommand, cleanAction) where - -import Prelude () -import Distribution.Client.Compat.Prelude - -import Distribution.Client.DistDirLayout - ( DistDirLayout(..), defaultDistDirLayout ) -import Distribution.Client.ProjectConfig - ( findProjectRoot ) -import Distribution.Client.Setup - ( GlobalFlags ) -import Distribution.ReadE ( succeedReadE ) -import Distribution.Simple.Setup - ( Flag(..), toFlag, fromFlagOrDefault, flagToList, flagToMaybe - , optionDistPref, optionVerbosity, falseArg - ) -import Distribution.Simple.Command - ( CommandUI(..), option, reqArg ) -import Distribution.Simple.Utils - ( info, die', wrapText, handleDoesNotExist ) -import Distribution.Verbosity - ( normal ) - -import System.Directory - ( removeDirectoryRecursive, removeFile - , doesDirectoryExist, getDirectoryContents ) -import System.FilePath - ( () ) - -data CleanFlags = CleanFlags - { cleanSaveConfig :: Flag Bool - , cleanVerbosity :: Flag Verbosity - , cleanDistDir :: Flag FilePath - , cleanProjectFile :: Flag FilePath - } deriving (Eq) - -defaultCleanFlags :: CleanFlags -defaultCleanFlags = CleanFlags - { cleanSaveConfig = toFlag False - , cleanVerbosity = toFlag normal - , cleanDistDir = NoFlag - , cleanProjectFile = mempty - } - -cleanCommand :: CommandUI CleanFlags -cleanCommand = CommandUI - { commandName = "v2-clean" - , commandSynopsis = "Clean the package store and remove temporary files." - , commandUsage = \pname -> - "Usage: " ++ pname ++ " new-clean [FLAGS]\n" - , commandDescription = Just $ \_ -> wrapText $ - "Removes all temporary files created during the building process " - ++ "(.hi, .o, preprocessed sources, etc.) and also empties out the " - ++ "local caches (by default).\n\n" - , commandNotes = Nothing - , commandDefaultFlags = defaultCleanFlags - , commandOptions = \showOrParseArgs -> - [ optionVerbosity - cleanVerbosity (\v flags -> flags { cleanVerbosity = v }) - , optionDistPref - cleanDistDir (\dd flags -> flags { cleanDistDir = dd }) - showOrParseArgs - , option [] ["project-file"] - ("Set the name of the cabal.project file" - ++ " to search for in parent directories") - cleanProjectFile (\pf flags -> flags {cleanProjectFile = pf}) - (reqArg "FILE" (succeedReadE Flag) flagToList) - , option ['s'] ["save-config"] - "Save configuration, only remove build artifacts" - cleanSaveConfig (\sc flags -> flags { cleanSaveConfig = sc }) - falseArg - ] - } - -cleanAction :: CleanFlags -> [String] -> GlobalFlags -> IO () -cleanAction CleanFlags{..} extraArgs _ = do - let verbosity = fromFlagOrDefault normal cleanVerbosity - saveConfig = fromFlagOrDefault False cleanSaveConfig - mdistDirectory = flagToMaybe cleanDistDir - mprojectFile = flagToMaybe cleanProjectFile - - unless (null extraArgs) $ - die' verbosity $ "'clean' doesn't take any extra arguments: " - ++ unwords extraArgs - - projectRoot <- either throwIO return =<< findProjectRoot Nothing mprojectFile - - let distLayout = defaultDistDirLayout projectRoot mdistDirectory - - if saveConfig - then do - let buildRoot = distBuildRootDirectory distLayout - - buildRootExists <- doesDirectoryExist buildRoot - - when buildRootExists $ do - info verbosity ("Deleting build root (" ++ buildRoot ++ ")") - handleDoesNotExist () $ removeDirectoryRecursive buildRoot - else do - let distRoot = distDirectory distLayout - - info verbosity ("Deleting dist-newstyle (" ++ distRoot ++ ")") - handleDoesNotExist () $ removeDirectoryRecursive distRoot - - removeEnvFiles (distProjectRootDirectory distLayout) - -removeEnvFiles :: FilePath -> IO () -removeEnvFiles dir = - (traverse_ (removeFile . (dir )) . filter ((".ghc.environment" ==) . take 16)) - =<< getDirectoryContents dir diff --git a/cabal/cabal-install/Distribution/Client/CmdConfigure.hs b/cabal/cabal-install/Distribution/Client/CmdConfigure.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/CmdConfigure.hs +++ /dev/null @@ -1,149 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} --- | cabal-install CLI command: configure --- -module Distribution.Client.CmdConfigure ( - configureCommand, - configureAction, - ) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import System.Directory -import System.FilePath -import qualified Data.Map as Map - -import Distribution.Client.ProjectOrchestration -import Distribution.Client.ProjectConfig - ( writeProjectLocalExtraConfig ) - -import Distribution.Client.NixStyleOptions - ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) -import Distribution.Client.Setup - ( GlobalFlags, ConfigFlags(..) ) -import Distribution.Simple.Flag - ( fromFlagOrDefault ) -import Distribution.Verbosity - ( normal ) - -import Distribution.Simple.Command - ( CommandUI(..), usageAlternatives, optionName ) -import Distribution.Simple.Utils - ( wrapText, notice ) - -import Distribution.Client.DistDirLayout - ( DistDirLayout(..) ) - -configureCommand :: CommandUI (NixStyleFlags ()) -configureCommand = CommandUI { - commandName = "v2-configure", - commandSynopsis = "Add extra project configuration", - commandUsage = usageAlternatives "v2-configure" [ "[FLAGS]" ], - commandDescription = Just $ \_ -> wrapText $ - "Adjust how the project is built by setting additional package flags " - ++ "and other flags.\n\n" - - ++ "The configuration options are written to the 'cabal.project.local' " - ++ "file (or '$project_file.local', if '--project-file' is specified) " - ++ "which extends the configuration from the 'cabal.project' file " - ++ "(if any). This combination is used as the project configuration for " - ++ "all other commands (such as 'v2-build', 'v2-repl' etc) though it " - ++ "can be extended/overridden on a per-command basis.\n\n" - - ++ "The v2-configure command also checks that the project configuration " - ++ "will work. In particular it checks that there is a consistent set of " - ++ "dependencies for the project as a whole.\n\n" - - ++ "The 'cabal.project.local' file persists across 'v2-clean' but is " - ++ "overwritten on the next use of the 'v2-configure' command. The " - ++ "intention is that the 'cabal.project' file should be kept in source " - ++ "control but the 'cabal.project.local' should not.\n\n" - - ++ "It is never necessary to use the 'v2-configure' command. It is " - ++ "merely a convenience in cases where you do not want to specify flags " - ++ "to 'v2-build' (and other commands) every time and yet do not want " - ++ "to alter the 'cabal.project' persistently.", - commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " v2-configure --with-compiler ghc-7.10.3\n" - ++ " Adjust the project configuration to use the given compiler\n" - ++ " program and check the resulting configuration works.\n" - ++ " " ++ pname ++ " v2-configure\n" - ++ " Reset the local configuration to empty and check the overall\n" - ++ " project configuration works.\n\n" - - ++ cmdCommonHelpTextNewBuildBeta - , commandDefaultFlags = defaultNixStyleFlags () - , commandOptions = filter (\o -> optionName o /= "ignore-project") - . nixStyleOptions (const []) - } - --- | To a first approximation, the @configure@ just runs the first phase of --- the @build@ command where we bring the install plan up to date (thus --- checking that it's possible). --- --- The only difference is that @configure@ also allows the user to specify --- some extra config flags which we save in the file @cabal.project.local@. --- --- For more details on how this works, see the module --- "Distribution.Client.ProjectOrchestration" --- -configureAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO () -configureAction flags@NixStyleFlags {..} _extraArgs globalFlags = do - --TODO: deal with _extraArgs, since flags with wrong syntax end up there - - baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand - - -- Write out the @cabal.project.local@ so it gets picked up by the - -- planning phase. If old config exists, then print the contents - -- before overwriting - - let localFile = distProjectFile (distDirLayout baseCtx) "local" - -- | Chooses cabal.project.local~, or if it already exists - -- cabal.project.local~0, cabal.project.local~1 etc. - firstFreeBackup = firstFreeBackup' (0 :: Int) - firstFreeBackup' i = do - let backup = localFile <> "~" <> (if i <= 0 then "" else show (i - 1)) - exists <- doesFileExist backup - if exists - then firstFreeBackup' (i + 1) - else return backup - - -- If cabal.project.local already exists, back up to cabal.project.local~[n] - exists <- doesFileExist localFile - when exists $ do - backup <- firstFreeBackup - notice verbosity $ - quote (takeFileName localFile) <> " already exists, backing it up to " - <> quote (takeFileName backup) <> "." - copyFile localFile backup - writeProjectLocalExtraConfig (distDirLayout baseCtx) - cliConfig - - buildCtx <- - runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> - - -- TODO: Select the same subset of targets as 'CmdBuild' would - -- pick (ignoring, for example, executables in libraries - -- we depend on). But we don't want it to fail, so actually we - -- have to do it slightly differently from build. - return (elaboratedPlan, Map.empty) - - let baseCtx' = baseCtx { - buildSettings = (buildSettings baseCtx) { - buildSettingDryRun = True - } - } - - -- TODO: Hmm, but we don't have any targets. Currently this prints - -- what we would build if we were to build everything. Could pick - -- implicit target like "." - -- - -- TODO: should we say what's in the project (+deps) as a whole? - printPlan verbosity baseCtx' buildCtx - where - verbosity = fromFlagOrDefault normal (configVerbosity configFlags) - cliConfig = commandLineFlagsToProjectConfig globalFlags flags - mempty -- ClientInstallFlags, not needed here - quote s = "'" <> s <> "'" - diff --git a/cabal/cabal-install/Distribution/Client/CmdErrorMessages.hs b/cabal/cabal-install/Distribution/Client/CmdErrorMessages.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/CmdErrorMessages.hs +++ /dev/null @@ -1,441 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} - - --- | Utilities to help format error messages for the various CLI commands. --- -module Distribution.Client.CmdErrorMessages ( - module Distribution.Client.CmdErrorMessages, - module Distribution.Client.TargetSelector, - ) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Client.ProjectPlanning - ( AvailableTarget(..), AvailableTargetStatus(..), - CannotPruneDependencies(..), TargetRequested(..) ) -import Distribution.Client.TargetSelector - ( SubComponentTarget(..) ) -import Distribution.Client.TargetProblem - ( TargetProblem(..), TargetProblem' ) -import Distribution.Client.TargetSelector - ( ComponentKind(..), ComponentKindFilter, TargetSelector(..), - componentKind, showTargetSelector ) - -import Distribution.Package - ( PackageId, packageId, PackageName, packageName ) -import Distribution.Simple.Utils - ( die' ) -import Distribution.Types.ComponentName - ( ComponentName(..), showComponentName ) -import Distribution.Types.LibraryName - ( LibraryName(..) ) -import Distribution.Solver.Types.OptionalStanza - ( OptionalStanza(..) ) - -import qualified Data.List.NonEmpty as NE - - ------------------------ --- Singular or plural --- - --- | A tag used in rendering messages to distinguish singular or plural. --- -data Plural = Singular | Plural - --- | Used to render a singular or plural version of something --- --- > plural (listPlural theThings) "it is" "they are" --- -plural :: Plural -> a -> a -> a -plural Singular si _pl = si -plural Plural _si pl = pl - --- | Singular for singleton lists and plural otherwise. --- -listPlural :: [a] -> Plural -listPlural [_] = Singular -listPlural _ = Plural - - --------------------- --- Rendering lists --- - --- | Render a list of things in the style @foo, bar and baz@ -renderListCommaAnd :: [String] -> String -renderListCommaAnd [] = "" -renderListCommaAnd [x] = x -renderListCommaAnd [x,x'] = x ++ " and " ++ x' -renderListCommaAnd (x:xs) = x ++ ", " ++ renderListCommaAnd xs - --- | Render a list of things in the style @blah blah; this that; and the other@ -renderListSemiAnd :: [String] -> String -renderListSemiAnd [] = "" -renderListSemiAnd [x] = x -renderListSemiAnd [x,x'] = x ++ "; and " ++ x' -renderListSemiAnd (x:xs) = x ++ "; " ++ renderListSemiAnd xs - --- | When rendering lists of things it often reads better to group related --- things, e.g. grouping components by package name --- --- > renderListSemiAnd --- > [ "the package " ++ prettyShow pkgname ++ " components " --- > ++ renderListCommaAnd showComponentName components --- > | (pkgname, components) <- sortGroupOn packageName allcomponents ] --- -sortGroupOn :: Ord b => (a -> b) -> [a] -> [(b, [a])] -sortGroupOn key = map (\(x:|xs) -> (key x, x:xs)) - . NE.groupBy ((==) `on` key) - . sortBy (compare `on` key) - - ----------------------------------------------------- --- Renderering for a few project and package types --- - -renderTargetSelector :: TargetSelector -> String -renderTargetSelector (TargetPackage _ pkgids Nothing) = - "the " ++ plural (listPlural pkgids) "package" "packages" ++ " " - ++ renderListCommaAnd (map prettyShow pkgids) - -renderTargetSelector (TargetPackage _ pkgids (Just kfilter)) = - "the " ++ renderComponentKind Plural kfilter - ++ " in the " ++ plural (listPlural pkgids) "package" "packages" ++ " " - ++ renderListCommaAnd (map prettyShow pkgids) - -renderTargetSelector (TargetPackageNamed pkgname Nothing) = - "the package " ++ prettyShow pkgname - -renderTargetSelector (TargetPackageNamed pkgname (Just kfilter)) = - "the " ++ renderComponentKind Plural kfilter - ++ " in the package " ++ prettyShow pkgname - -renderTargetSelector (TargetAllPackages Nothing) = - "all the packages in the project" - -renderTargetSelector (TargetAllPackages (Just kfilter)) = - "all the " ++ renderComponentKind Plural kfilter - ++ " in the project" - -renderTargetSelector (TargetComponent pkgid cname subtarget) = - renderSubComponentTarget subtarget ++ "the " - ++ renderComponentName (packageName pkgid) cname - -renderTargetSelector (TargetComponentUnknown pkgname (Left ucname) subtarget) = - renderSubComponentTarget subtarget ++ "the component " ++ prettyShow ucname - ++ " in the package " ++ prettyShow pkgname - -renderTargetSelector (TargetComponentUnknown pkgname (Right cname) subtarget) = - renderSubComponentTarget subtarget ++ "the " - ++ renderComponentName pkgname cname - -renderSubComponentTarget :: SubComponentTarget -> String -renderSubComponentTarget WholeComponent = "" -renderSubComponentTarget (FileTarget filename) = - "the file " ++ filename ++ "in " -renderSubComponentTarget (ModuleTarget modname) = - "the module" ++ prettyShow modname ++ "in " - - -renderOptionalStanza :: Plural -> OptionalStanza -> String -renderOptionalStanza Singular TestStanzas = "test suite" -renderOptionalStanza Plural TestStanzas = "test suites" -renderOptionalStanza Singular BenchStanzas = "benchmark" -renderOptionalStanza Plural BenchStanzas = "benchmarks" - --- | The optional stanza type (test suite or benchmark), if it is one. -optionalStanza :: ComponentName -> Maybe OptionalStanza -optionalStanza (CTestName _) = Just TestStanzas -optionalStanza (CBenchName _) = Just BenchStanzas -optionalStanza _ = Nothing - --- | Does the 'TargetSelector' potentially refer to one package or many? --- -targetSelectorPluralPkgs :: TargetSelector -> Plural -targetSelectorPluralPkgs (TargetAllPackages _) = Plural -targetSelectorPluralPkgs (TargetPackage _ pids _) = listPlural pids -targetSelectorPluralPkgs (TargetPackageNamed _ _) = Singular -targetSelectorPluralPkgs TargetComponent{} = Singular -targetSelectorPluralPkgs TargetComponentUnknown{} = Singular - --- | Does the 'TargetSelector' refer to packages or to components? -targetSelectorRefersToPkgs :: TargetSelector -> Bool -targetSelectorRefersToPkgs (TargetAllPackages mkfilter) = isNothing mkfilter -targetSelectorRefersToPkgs (TargetPackage _ _ mkfilter) = isNothing mkfilter -targetSelectorRefersToPkgs (TargetPackageNamed _ mkfilter) = isNothing mkfilter -targetSelectorRefersToPkgs TargetComponent{} = False -targetSelectorRefersToPkgs TargetComponentUnknown{} = False - -targetSelectorFilter :: TargetSelector -> Maybe ComponentKindFilter -targetSelectorFilter (TargetPackage _ _ mkfilter) = mkfilter -targetSelectorFilter (TargetPackageNamed _ mkfilter) = mkfilter -targetSelectorFilter (TargetAllPackages mkfilter) = mkfilter -targetSelectorFilter TargetComponent{} = Nothing -targetSelectorFilter TargetComponentUnknown{} = Nothing - -renderComponentName :: PackageName -> ComponentName -> String -renderComponentName pkgname (CLibName LMainLibName) = "library " ++ prettyShow pkgname -renderComponentName _ (CLibName (LSubLibName name)) = "library " ++ prettyShow name -renderComponentName _ (CFLibName name) = "foreign library " ++ prettyShow name -renderComponentName _ (CExeName name) = "executable " ++ prettyShow name -renderComponentName _ (CTestName name) = "test suite " ++ prettyShow name -renderComponentName _ (CBenchName name) = "benchmark " ++ prettyShow name - -renderComponentKind :: Plural -> ComponentKind -> String -renderComponentKind Singular ckind = case ckind of - LibKind -> "library" -- internal/sub libs? - FLibKind -> "foreign library" - ExeKind -> "executable" - TestKind -> "test suite" - BenchKind -> "benchmark" -renderComponentKind Plural ckind = case ckind of - LibKind -> "libraries" -- internal/sub libs? - FLibKind -> "foreign libraries" - ExeKind -> "executables" - TestKind -> "test suites" - BenchKind -> "benchmarks" - - -------------------------------------------------------- --- Renderering error messages for TargetProblem --- - --- | Default implementation of 'reportTargetProblems' simply renders one problem per line. -reportTargetProblems :: Verbosity -> String -> [TargetProblem'] -> IO a -reportTargetProblems verbosity verb = - die' verbosity . unlines . map (renderTargetProblem verb absurd) - --- | Default implementation of 'renderTargetProblem'. -renderTargetProblem - :: String -- ^ verb - -> (a -> String) -- ^ how to render custom problems - -> TargetProblem a - -> String -renderTargetProblem _verb f (CustomTargetProblem x) = f x -renderTargetProblem verb _ (TargetProblemNoneEnabled targetSelector targets) = - renderTargetProblemNoneEnabled verb targetSelector targets -renderTargetProblem verb _ (TargetProblemNoTargets targetSelector) = - renderTargetProblemNoTargets verb targetSelector - -renderTargetProblem verb _ (TargetNotInProject pkgname) = - "Cannot " ++ verb ++ " the package " ++ prettyShow pkgname ++ ", it is not " - ++ "in this project (either directly or indirectly). If you want to add it " - ++ "to the project then edit the cabal.project file." - -renderTargetProblem verb _ (TargetAvailableInIndex pkgname) = - "Cannot " ++ verb ++ " the package " ++ prettyShow pkgname ++ ", it is not " - ++ "in this project (either directly or indirectly), but it is in the current " - ++ "package index. If you want to add it to the project then edit the " - ++ "cabal.project file." - -renderTargetProblem verb _ (TargetComponentNotProjectLocal pkgid cname _) = - "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because the " - ++ "package " ++ prettyShow pkgid ++ " is not local to the project, and cabal " - ++ "does not currently support building test suites or benchmarks of " - ++ "non-local dependencies. To run test suites or benchmarks from " - ++ "dependencies you can unpack the package locally and adjust the " - ++ "cabal.project file to include that package directory." - -renderTargetProblem verb _ (TargetComponentNotBuildable pkgid cname _) = - "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because it is " - ++ "marked as 'buildable: False' within the '" ++ prettyShow (packageName pkgid) - ++ ".cabal' file (at least for the current configuration). If you believe it " - ++ "should be buildable then check the .cabal file to see if the buildable " - ++ "property is conditional on flags. Alternatively you may simply have to " - ++ "edit the .cabal file to declare it as buildable and fix any resulting " - ++ "build problems." - -renderTargetProblem verb _ (TargetOptionalStanzaDisabledByUser _ cname _) = - "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because " - ++ "building " ++ compkinds ++ " has been explicitly disabled in the " - ++ "configuration. You can adjust this configuration in the " - ++ "cabal.project{.local} file either for all packages in the project or on " - ++ "a per-package basis. Note that if you do not explicitly disable " - ++ compkinds ++ " then the solver will merely try to make a plan with " - ++ "them available, so you may wish to explicitly enable them which will " - ++ "require the solver to find a plan with them available or to fail with an " - ++ "explanation." - where - compkinds = renderComponentKind Plural (componentKind cname) - -renderTargetProblem verb _ (TargetOptionalStanzaDisabledBySolver pkgid cname _) = - "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because the " - ++ "solver did not find a plan that included the " ++ compkinds - ++ " for " ++ prettyShow pkgid ++ ". It is probably worth trying again with " - ++ compkinds ++ " explicitly enabled in the configuration in the " - ++ "cabal.project{.local} file. This will ask the solver to find a plan with " - ++ "the " ++ compkinds ++ " available. It will either fail with an " - ++ "explanation or find a different plan that uses different versions of some " - ++ "other packages. Use the '--dry-run' flag to see package versions and " - ++ "check that you are happy with the choices." - where - compkinds = renderComponentKind Plural (componentKind cname) - -renderTargetProblem verb _ (TargetProblemUnknownComponent pkgname ecname) = - "Cannot " ++ verb ++ " the " - ++ (case ecname of - Left ucname -> "component " ++ prettyShow ucname - Right cname -> renderComponentName pkgname cname) - ++ " from the package " ++ prettyShow pkgname - ++ ", because the package does not contain a " - ++ (case ecname of - Left _ -> "component" - Right cname -> renderComponentKind Singular (componentKind cname)) - ++ " with that name." - -renderTargetProblem verb _ (TargetProblemNoSuchPackage pkgid) = - "Internal error when trying to " ++ verb ++ " the package " - ++ prettyShow pkgid ++ ". The package is not in the set of available targets " - ++ "for the project plan, which would suggest an inconsistency " - ++ "between readTargetSelectors and resolveTargets." - -renderTargetProblem verb _ (TargetProblemNoSuchComponent pkgid cname) = - "Internal error when trying to " ++ verb ++ " the " - ++ showComponentName cname ++ " from the package " ++ prettyShow pkgid - ++ ". The package,component pair is not in the set of available targets " - ++ "for the project plan, which would suggest an inconsistency " - ++ "between readTargetSelectors and resolveTargets." - - ------------------------------------------------------------- --- Renderering error messages for TargetProblemNoneEnabled --- - --- | Several commands have a @TargetProblemNoneEnabled@ problem constructor. --- This renders an error message for those cases. --- -renderTargetProblemNoneEnabled :: String - -> TargetSelector - -> [AvailableTarget ()] - -> String -renderTargetProblemNoneEnabled verb targetSelector targets = - "Cannot " ++ verb ++ " " ++ renderTargetSelector targetSelector - ++ " because none of the components are available to build: " - ++ renderListSemiAnd - [ case (status, mstanza) of - (TargetDisabledByUser, Just stanza) -> - renderListCommaAnd - [ "the " ++ showComponentName availableTargetComponentName - | AvailableTarget {availableTargetComponentName} <- targets' ] - ++ plural (listPlural targets') " is " " are " - ++ " not available because building " - ++ renderOptionalStanza Plural stanza - ++ " has been disabled in the configuration" - (TargetDisabledBySolver, Just stanza) -> - renderListCommaAnd - [ "the " ++ showComponentName availableTargetComponentName - | AvailableTarget {availableTargetComponentName} <- targets' ] - ++ plural (listPlural targets') " is " " are " - ++ "not available because the solver did not find a plan that " - ++ "included the " ++ renderOptionalStanza Plural stanza - ++ ". Force the solver to enable this for all packages by adding the " - ++ "line 'tests: True' to the 'cabal.project.local' file." - (TargetNotBuildable, _) -> - renderListCommaAnd - [ "the " ++ showComponentName availableTargetComponentName - | AvailableTarget {availableTargetComponentName} <- targets' ] - ++ plural (listPlural targets') " is " " are all " - ++ "marked as 'buildable: False'" - (TargetNotLocal, _) -> - renderListCommaAnd - [ "the " ++ showComponentName availableTargetComponentName - | AvailableTarget {availableTargetComponentName} <- targets' ] - ++ " cannot be built because cabal does not currently support " - ++ "building test suites or benchmarks of non-local dependencies" - (TargetBuildable () TargetNotRequestedByDefault, Just stanza) -> - renderListCommaAnd - [ "the " ++ showComponentName availableTargetComponentName - | AvailableTarget {availableTargetComponentName} <- targets' ] - ++ " will not be built because " ++ renderOptionalStanza Plural stanza - ++ " are not built by default in the current configuration (but you " - ++ "can still build them specifically)" --TODO: say how - _ -> error $ "renderBuildTargetProblem: unexpected status " - ++ show (status, mstanza) - | ((status, mstanza), targets') <- sortGroupOn groupingKey targets - ] - where - groupingKey t = - ( availableTargetStatus t - , case availableTargetStatus t of - TargetNotBuildable -> Nothing - TargetNotLocal -> Nothing - _ -> optionalStanza (availableTargetComponentName t) - ) - ------------------------------------------------------------- --- Renderering error messages for TargetProblemNoneEnabled --- - --- | Several commands have a @TargetProblemNoTargets@ problem constructor. --- This renders an error message for those cases. --- -renderTargetProblemNoTargets :: String -> TargetSelector -> String -renderTargetProblemNoTargets verb targetSelector = - "Cannot " ++ verb ++ " " ++ renderTargetSelector targetSelector - ++ " because " ++ reason targetSelector ++ ". " - ++ "Check the .cabal " - ++ plural (targetSelectorPluralPkgs targetSelector) - "file for the package and make sure that it properly declares " - "files for the packages and make sure that they properly declare " - ++ "the components that you expect." - where - reason (TargetPackage _ _ Nothing) = - "it does not contain any components at all" - reason (TargetPackage _ _ (Just kfilter)) = - "it does not contain any " ++ renderComponentKind Plural kfilter - reason (TargetPackageNamed _ Nothing) = - "it does not contain any components at all" - reason (TargetPackageNamed _ (Just kfilter)) = - "it does not contain any " ++ renderComponentKind Plural kfilter - reason (TargetAllPackages Nothing) = - "none of them contain any components at all" - reason (TargetAllPackages (Just kfilter)) = - "none of the packages contain any " - ++ renderComponentKind Plural kfilter - reason ts@TargetComponent{} = - error $ "renderTargetProblemNoTargets: " ++ show ts - reason ts@TargetComponentUnknown{} = - error $ "renderTargetProblemNoTargets: " ++ show ts - ------------------------------------------------------------ --- Renderering error messages for CannotPruneDependencies --- - -renderCannotPruneDependencies :: CannotPruneDependencies -> String -renderCannotPruneDependencies (CannotPruneDependencies brokenPackages) = - "Cannot select only the dependencies (as requested by the " - ++ "'--only-dependencies' flag), " - ++ (case pkgids of - [pkgid] -> "the package " ++ prettyShow pkgid ++ " is " - _ -> "the packages " - ++ renderListCommaAnd (map prettyShow pkgids) ++ " are ") - ++ "required by a dependency of one of the other targets." - where - -- throw away the details and just list the deps that are needed - pkgids :: [PackageId] - pkgids = nub . map packageId . concatMap snd $ brokenPackages - -{- - ++ "Syntax:\n" - ++ " - build [package]\n" - ++ " - build [package:]component\n" - ++ " - build [package:][component:]module\n" - ++ " - build [package:][component:]file\n" - ++ " where\n" - ++ " package is a package name, package dir or .cabal file\n\n" - ++ "Examples:\n" - ++ " - build foo -- package name\n" - ++ " - build tests -- component name\n" - ++ " (name of library, executable, test-suite or benchmark)\n" - ++ " - build Data.Foo -- module name\n" - ++ " - build Data/Foo.hsc -- file name\n\n" - ++ "An ambigious target can be qualified by package, component\n" - ++ "and/or component kind (lib|exe|test|bench|flib)\n" - ++ " - build foo:tests -- component qualified by package\n" - ++ " - build tests:Data.Foo -- module qualified by component\n" - ++ " - build lib:foo -- component qualified by kind" --} diff --git a/cabal/cabal-install/Distribution/Client/CmdExec.hs b/cabal/cabal-install/Distribution/Client/CmdExec.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/CmdExec.hs +++ /dev/null @@ -1,251 +0,0 @@ -------------------------------------------------------------------------------- --- | --- Module : Distribution.Client.Exec --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Implementation of the 'v2-exec' command for running an arbitrary executable --- in an environment suited to the part of the store built for a project. -------------------------------------------------------------------------------- - -{-# LANGUAGE RecordWildCards #-} -module Distribution.Client.CmdExec - ( execAction - , execCommand - ) where - -import Distribution.Client.DistDirLayout - ( DistDirLayout(..) - ) -import Distribution.Client.InstallPlan - ( GenericPlanPackage(..) - , toGraph - ) -import Distribution.Client.NixStyleOptions - ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) -import Distribution.Client.Setup - ( ConfigFlags(configVerbosity) - , GlobalFlags - ) -import Distribution.Client.ProjectOrchestration - ( ProjectBuildContext(..) - , runProjectPreBuildPhase - , CurrentCommand(..) - , establishProjectBaseContext - , distDirLayout - , commandLineFlagsToProjectConfig - , ProjectBaseContext(..) - ) -import Distribution.Client.ProjectPlanOutput - ( updatePostBuildProjectStatus - , createPackageEnvironment - , argsEquivalentOfGhcEnvironmentFile - , PostBuildProjectStatus - ) -import qualified Distribution.Client.ProjectPlanning as Planning -import Distribution.Client.ProjectPlanning - ( ElaboratedInstallPlan - , ElaboratedSharedConfig(..) - ) -import Distribution.Simple.Command - ( CommandUI(..), optionName - ) -import Distribution.Simple.Program.Db - ( modifyProgramSearchPath - , requireProgram - , configuredPrograms - ) -import Distribution.Simple.Program.Find - ( ProgramSearchPathEntry(..) - ) -import Distribution.Simple.Program.Run - ( programInvocation - , runProgramInvocation - ) -import Distribution.Simple.Program.Types - ( programOverrideEnv - , programDefaultArgs - , programPath - , simpleProgram - , ConfiguredProgram - ) -import Distribution.Simple.GHC - ( getImplInfo - , GhcImplInfo(supportsPkgEnvFiles) ) -import Distribution.Simple.Flag - ( fromFlagOrDefault - ) -import Distribution.Simple.Utils - ( die' - , info - , createDirectoryIfMissingVerbose - , withTempDirectory - , wrapText - ) -import Distribution.Verbosity - ( normal - ) - -import Prelude () -import Distribution.Client.Compat.Prelude - -import qualified Data.Set as S -import qualified Data.Map as M - -execCommand :: CommandUI (NixStyleFlags ()) -execCommand = CommandUI - { commandName = "v2-exec" - , commandSynopsis = "Give a command access to the store." - , commandUsage = \pname -> - "Usage: " ++ pname ++ " v2-exec [FLAGS] [--] COMMAND [--] [ARGS]\n" - , commandDescription = Just $ \pname -> wrapText $ - "During development it is often useful to run build tasks and perform" - ++ " one-off program executions to experiment with the behavior of build" - ++ " tools. It is convenient to run these tools in the same way " ++ pname - ++ " itself would. The `" ++ pname ++ " v2-exec` command provides a way to" - ++ " do so.\n" - ++ "\n" - ++ "Compiler tools will be configured to see the same subset of the store" - ++ " that builds would see. The PATH is modified to make all executables in" - ++ " the dependency tree available (provided they have been built already)." - ++ " Commands are also rewritten in the way cabal itself would. For" - ++ " example, `" ++ pname ++ " v2-exec ghc` will consult the configuration" - ++ " to choose an appropriate version of ghc and to include any" - ++ " ghc-specific flags requested." - , commandNotes = Nothing - , commandOptions = filter (\o -> optionName o /= "ignore-project") - . nixStyleOptions (const []) - , commandDefaultFlags = defaultNixStyleFlags () - } - -execAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO () -execAction flags@NixStyleFlags {..} extraArgs globalFlags = do - - baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand - - -- To set up the environment, we'd like to select the libraries in our - -- dependency tree that we've already built. So first we set up an install - -- plan, but we walk the dependency tree without first executing the plan. - buildCtx <- runProjectPreBuildPhase - verbosity - baseCtx - (\plan -> return (plan, M.empty)) - - -- 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 - -- status. - buildStatus <- updatePostBuildProjectStatus - verbosity - (distDirLayout baseCtx) - (elaboratedPlanOriginal buildCtx) - (pkgsBuildStatus buildCtx) - mempty - - -- Some dependencies may have executables. Let's put those on the PATH. - extraPaths <- pathAdditions verbosity baseCtx buildCtx - let programDb = modifyProgramSearchPath - (map ProgramSearchPathDir extraPaths ++) - . pkgConfigCompilerProgs - . elaboratedShared - $ buildCtx - - -- Now that we have the packages, set up the environment. We accomplish this - -- by creating an environment file that selects the databases and packages we - -- computed in the previous step, and setting an environment variable to - -- 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 - envFilesSupported = supportsPkgEnvFiles (getImplInfo compiler) - case extraArgs of - [] -> die' verbosity "Please specify an executable to run" - exe:args -> do - (program, _) <- requireProgram verbosity (simpleProgram exe) programDb - let argOverrides = - argsEquivalentOfGhcEnvironmentFile - compiler - (distDirLayout baseCtx) - (elaboratedPlanOriginal buildCtx) - buildStatus - programIsConfiguredCompiler = matchCompilerPath - (elaboratedShared buildCtx) - program - argOverrides' = - if envFilesSupported - || not programIsConfiguredCompiler - then [] - else argOverrides - - (if envFilesSupported - then withTempEnvFile verbosity baseCtx buildCtx buildStatus - else \f -> f []) $ \envOverrides -> do - let program' = withOverrides - envOverrides - argOverrides' - program - invocation = programInvocation program' args - runProgramInvocation verbosity invocation - where - verbosity = fromFlagOrDefault normal (configVerbosity configFlags) - cliConfig = commandLineFlagsToProjectConfig globalFlags flags - mempty -- ClientInstallFlags, not needed here - withOverrides env args program = program - { programOverrideEnv = programOverrideEnv program ++ env - , programDefaultArgs = programDefaultArgs program ++ args} - -matchCompilerPath :: ElaboratedSharedConfig -> ConfiguredProgram -> Bool -matchCompilerPath elaboratedShared program = - programPath program - `elem` - (programPath <$> configuredCompilers) - where - configuredCompilers = configuredPrograms $ pkgConfigCompilerProgs elaboratedShared - --- | Execute an action with a temporary .ghc.environment file reflecting the --- current environment. The action takes an environment containing the env --- variable which points ghc to the file. -withTempEnvFile :: Verbosity - -> ProjectBaseContext - -> ProjectBuildContext - -> PostBuildProjectStatus - -> ([(String, Maybe String)] -> IO a) - -> IO a -withTempEnvFile verbosity baseCtx buildCtx buildStatus action = do - createDirectoryIfMissingVerbose verbosity True (distTempDirectory (distDirLayout baseCtx)) - withTempDirectory - verbosity - (distTempDirectory (distDirLayout baseCtx)) - "environment." - (\tmpDir -> do - envOverrides <- createPackageEnvironment - verbosity - tmpDir - (elaboratedPlanToExecute buildCtx) - (elaboratedShared buildCtx) - buildStatus - action envOverrides) - -pathAdditions :: Verbosity -> ProjectBaseContext -> ProjectBuildContext -> IO [FilePath] -pathAdditions verbosity ProjectBaseContext{..}ProjectBuildContext{..} = do - info verbosity . unlines $ "Including the following directories in PATH:" - : paths - return paths - where - paths = S.toList - $ binDirectories distDirLayout elaboratedShared elaboratedPlanToExecute - -binDirectories - :: DistDirLayout - -> ElaboratedSharedConfig - -> ElaboratedInstallPlan - -> Set FilePath -binDirectories layout config = fromElaboratedInstallPlan where - fromElaboratedInstallPlan = fromGraph . toGraph - fromGraph = foldMap fromPlan - fromSrcPkg = S.fromList . Planning.binDirectories layout config - - fromPlan (PreExisting _) = mempty - fromPlan (Configured pkg) = fromSrcPkg pkg - fromPlan (Installed pkg) = fromSrcPkg pkg - diff --git a/cabal/cabal-install/Distribution/Client/CmdFreeze.hs b/cabal/cabal-install/Distribution/Client/CmdFreeze.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/CmdFreeze.hs +++ /dev/null @@ -1,236 +0,0 @@ -{-# LANGUAGE NamedFieldPuns, RecordWildCards #-} - --- | cabal-install CLI command: freeze --- -module Distribution.Client.CmdFreeze ( - freezeCommand, - freezeAction, - ) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Client.NixStyleOptions - ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) -import Distribution.Client.ProjectOrchestration -import Distribution.Client.ProjectPlanning -import Distribution.Client.ProjectConfig - ( ProjectConfig(..), ProjectConfigShared(..) - , writeProjectLocalFreezeConfig ) -import Distribution.Client.IndexUtils (TotalIndexState, ActiveRepos) -import Distribution.Client.Targets - ( UserQualifier(..), UserConstraintScope(..), UserConstraint(..) ) -import Distribution.Solver.Types.PackageConstraint - ( PackageProperty(..) ) -import Distribution.Solver.Types.ConstraintSource - ( ConstraintSource(..) ) -import Distribution.Client.DistDirLayout - ( DistDirLayout(distProjectFile) ) -import qualified Distribution.Client.InstallPlan as InstallPlan - - -import Distribution.Package - ( PackageName, packageName, packageVersion ) -import Distribution.Version - ( VersionRange, thisVersion - , unionVersionRanges, simplifyVersionRange ) -import Distribution.PackageDescription - ( FlagAssignment, nullFlagAssignment ) -import Distribution.Client.Setup - ( GlobalFlags, ConfigFlags(..) ) -import Distribution.Simple.Flag - ( fromFlagOrDefault ) -import Distribution.Simple.Flag (Flag (..)) -import Distribution.Simple.Utils - ( die', notice, wrapText ) -import Distribution.Verbosity - ( normal ) - -import qualified Data.Map as Map - -import Distribution.Simple.Command - ( CommandUI(..), usageAlternatives ) - -freezeCommand :: CommandUI (NixStyleFlags ()) -freezeCommand = CommandUI { - commandName = "v2-freeze", - commandSynopsis = "Freeze dependencies.", - commandUsage = usageAlternatives "v2-freeze" [ "[FLAGS]" ], - commandDescription = Just $ \_ -> wrapText $ - "The project configuration is frozen so that it will be reproducible " - ++ "in future.\n\n" - - ++ "The precise dependency configuration for the project is written to " - ++ "the 'cabal.project.freeze' file (or '$project_file.freeze' if " - ++ "'--project-file' is specified). This file extends the configuration " - ++ "from the 'cabal.project' file and thus is used as the project " - ++ "configuration for all other commands (such as 'v2-build', " - ++ "'v2-repl' etc).\n\n" - - ++ "The freeze file can be kept in source control. To make small " - ++ "adjustments it may be edited manually, or to make bigger changes " - ++ "you may wish to delete the file and re-freeze. For more control, " - ++ "one approach is to try variations using 'v2-build --dry-run' with " - ++ "solver flags such as '--constraint=\"pkg < 1.2\"' and once you have " - ++ "a satisfactory solution to freeze it using the 'v2-freeze' command " - ++ "with the same set of flags.", - commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " v2-freeze\n" - ++ " Freeze the configuration of the current project\n\n" - ++ " " ++ pname ++ " v2-build --dry-run --constraint=\"aeson < 1\"\n" - ++ " Check what a solution with the given constraints would look like\n" - ++ " " ++ pname ++ " v2-freeze --constraint=\"aeson < 1\"\n" - ++ " Freeze a solution using the given constraints\n\n" - - ++ "Note: this command is part of the new project-based system (aka " - ++ "nix-style\nlocal builds). These features are currently in beta. " - ++ "Please see\n" - ++ "http://cabal.readthedocs.io/en/latest/nix-local-build-overview.html " - ++ "for\ndetails and advice on what you can expect to work. If you " - ++ "encounter problems\nplease file issues at " - ++ "https://github.com/haskell/cabal/issues and if you\nhave any time " - ++ "to get involved and help with testing, fixing bugs etc then\nthat " - ++ "is very much appreciated.\n" - , commandDefaultFlags = defaultNixStyleFlags () - , commandOptions = nixStyleOptions (const []) - } - --- | To a first approximation, the @freeze@ command runs the first phase of --- the @build@ command where we bring the install plan up to date, and then --- based on the install plan we write out a @cabal.project.freeze@ config file. --- --- For more details on how this works, see the module --- "Distribution.Client.ProjectOrchestration" --- -freezeAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO () -freezeAction flags@NixStyleFlags {..} extraArgs globalFlags = do - - unless (null extraArgs) $ - die' verbosity $ "'freeze' doesn't take any extra arguments: " - ++ unwords extraArgs - - ProjectBaseContext { - distDirLayout, - cabalDirLayout, - projectConfig, - localPackages - } <- establishProjectBaseContext verbosity cliConfig OtherCommand - - (_, elaboratedPlan, _, totalIndexState, activeRepos) <- - rebuildInstallPlan verbosity - distDirLayout cabalDirLayout - projectConfig - localPackages - - let freezeConfig = projectFreezeConfig elaboratedPlan totalIndexState activeRepos - writeProjectLocalFreezeConfig distDirLayout freezeConfig - notice verbosity $ - "Wrote freeze file: " ++ distProjectFile distDirLayout "freeze" - - where - verbosity = fromFlagOrDefault normal (configVerbosity configFlags) - cliConfig = commandLineFlagsToProjectConfig globalFlags flags - mempty -- ClientInstallFlags, not needed here - - - --- | Given the install plan, produce a config value with constraints that --- freezes the versions of packages used in the plan. --- -projectFreezeConfig - :: ElaboratedInstallPlan - -> TotalIndexState - -> ActiveRepos - -> ProjectConfig -projectFreezeConfig elaboratedPlan totalIndexState activeRepos = mempty - { projectConfigShared = mempty - { projectConfigConstraints = - concat (Map.elems (projectFreezeConstraints elaboratedPlan)) - , projectConfigIndexState = Flag totalIndexState - , projectConfigActiveRepos = Flag activeRepos - } - } - --- | Given the install plan, produce solver constraints that will ensure the --- solver picks the same solution again in future in different environments. --- -projectFreezeConstraints :: ElaboratedInstallPlan - -> Map PackageName [(UserConstraint, ConstraintSource)] -projectFreezeConstraints plan = - -- - -- TODO: [required eventually] this is currently an underapproximation - -- since the constraints language is not expressive enough to specify the - -- precise solution. See https://github.com/haskell/cabal/issues/3502. - -- - -- For the moment we deal with multiple versions in the solution by using - -- constraints that allow either version. Also, we do not include any - -- /version/ constraints for packages that are local to the project (e.g. - -- if the solution has two instances of Cabal, one from the local project - -- and one pulled in as a setup deps then we exclude all constraints on - -- Cabal, not just the constraint for the local instance since any - -- constraint would apply to both instances). We do however keep flag - -- constraints of local packages. - -- - deleteLocalPackagesVersionConstraints - (Map.unionWith (++) versionConstraints flagConstraints) - where - versionConstraints :: Map PackageName [(UserConstraint, ConstraintSource)] - versionConstraints = - Map.mapWithKey - (\p v -> [(UserConstraint (UserAnyQualifier p) (PackagePropertyVersion v), - ConstraintSourceFreeze)]) - versionRanges - - versionRanges :: Map PackageName VersionRange - versionRanges = - Map.map simplifyVersionRange $ - Map.fromListWith unionVersionRanges $ - [ (packageName pkg, thisVersion (packageVersion pkg)) - | InstallPlan.PreExisting pkg <- InstallPlan.toList plan - ] - ++ [ (packageName pkg, thisVersion (packageVersion pkg)) - | InstallPlan.Configured pkg <- InstallPlan.toList plan - ] - - flagConstraints :: Map PackageName [(UserConstraint, ConstraintSource)] - flagConstraints = - Map.mapWithKey - (\p f -> [(UserConstraint (UserQualified UserQualToplevel p) (PackagePropertyFlags f), - ConstraintSourceFreeze)]) - flagAssignments - - flagAssignments :: Map PackageName FlagAssignment - flagAssignments = - Map.fromList - [ (pkgname, flags) - | InstallPlan.Configured elab <- InstallPlan.toList plan - , let flags = elabFlagAssignment elab - pkgname = packageName elab - , not (nullFlagAssignment flags) ] - - -- As described above, remove the version constraints on local packages, - -- but leave any flag constraints. - deleteLocalPackagesVersionConstraints - :: Map PackageName [(UserConstraint, ConstraintSource)] - -> Map PackageName [(UserConstraint, ConstraintSource)] - deleteLocalPackagesVersionConstraints = - Map.mergeWithKey - (\_pkgname () constraints -> - case filter (not . isVersionConstraint . fst) constraints of - [] -> Nothing - constraints' -> Just constraints') - (const Map.empty) id - localPackages - - isVersionConstraint (UserConstraint _ (PackagePropertyVersion _)) = True - isVersionConstraint _ = False - - localPackages :: Map PackageName () - localPackages = - Map.fromList - [ (packageName elab, ()) - | InstallPlan.Configured elab <- InstallPlan.toList plan - , elabLocalToProject elab - ] - diff --git a/cabal/cabal-install/Distribution/Client/CmdHaddock.hs b/cabal/cabal-install/Distribution/Client/CmdHaddock.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/CmdHaddock.hs +++ /dev/null @@ -1,176 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} - --- | cabal-install CLI command: haddock --- -module Distribution.Client.CmdHaddock ( - -- * The @haddock@ CLI and action - haddockCommand, - haddockAction, - - -- * Internals exposed for testing - selectPackageTargets, - selectComponentTarget - ) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Client.ProjectOrchestration -import Distribution.Client.CmdErrorMessages -import Distribution.Client.TargetProblem - ( TargetProblem (..), TargetProblem' ) -import Distribution.Client.NixStyleOptions - ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) -import Distribution.Client.Setup - ( GlobalFlags, ConfigFlags(..) ) -import Distribution.Simple.Setup - ( HaddockFlags(..), fromFlagOrDefault ) -import Distribution.Simple.Command - ( CommandUI(..), usageAlternatives ) -import Distribution.Verbosity - ( normal ) -import Distribution.Simple.Utils - ( wrapText, die' ) - -haddockCommand :: CommandUI (NixStyleFlags ()) -haddockCommand = CommandUI { - commandName = "v2-haddock", - commandSynopsis = "Build Haddock documentation", - commandUsage = usageAlternatives "v2-haddock" [ "[FLAGS] TARGET" ], - commandDescription = Just $ \_ -> wrapText $ - "Build Haddock documentation for the specified packages within the " - ++ "project.\n\n" - - ++ "Any package in the project can be specified. If no package is " - ++ "specified, the default is to build the documentation for the package " - ++ "in the current directory. The default behaviour is to build " - ++ "documentation for the exposed modules of the library component (if " - ++ "any). This can be changed with the '--internal', '--executables', " - ++ "'--tests', '--benchmarks' or '--all' flags.\n\n" - - ++ "Currently, documentation for dependencies is NOT built. This " - ++ "behavior may change in future.\n\n" - - ++ "Additional configuration flags can be specified on the command line " - ++ "and these extend the project configuration from the 'cabal.project', " - ++ "'cabal.project.local' and other files.", - commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " v2-haddock pkgname" - ++ " Build documentation for the package named pkgname\n\n" - - ++ cmdCommonHelpTextNewBuildBeta - , commandOptions = nixStyleOptions (const []) - , commandDefaultFlags = defaultNixStyleFlags () - } - --TODO: [nice to have] support haddock on specific components, not just - -- whole packages and the silly --executables etc modifiers. - --- | The @haddock@ command is TODO. --- --- For more details on how this works, see the module --- "Distribution.Client.ProjectOrchestration" --- -haddockAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO () -haddockAction flags@NixStyleFlags {..} targetStrings globalFlags = do - baseCtx <- establishProjectBaseContext verbosity cliConfig HaddockCommand - - targetSelectors <- either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors (localPackages baseCtx) Nothing targetStrings - - buildCtx <- - runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do - - when (buildSettingOnlyDeps (buildSettings baseCtx)) $ - die' verbosity - "The haddock command does not support '--only-dependencies'." - - -- When we interpret the targets on the command line, interpret them as - -- haddock targets - targets <- either (reportBuildDocumentationTargetProblems verbosity) return - $ resolveTargets - (selectPackageTargets haddockFlags) - selectComponentTarget - elaboratedPlan - Nothing - targetSelectors - - let elaboratedPlan' = pruneInstallPlanToTargets - TargetActionHaddock - targets - elaboratedPlan - return (elaboratedPlan', targets) - - printPlan verbosity baseCtx buildCtx - - buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx - runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes - where - verbosity = fromFlagOrDefault normal (configVerbosity configFlags) - cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags, not needed here - --- | This defines what a 'TargetSelector' means for the @haddock@ command. --- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, --- or otherwise classifies the problem. --- --- For the @haddock@ command we select all buildable libraries. Additionally, --- depending on the @--executables@ flag we also select all the buildable exes. --- We do similarly for test-suites, benchmarks and foreign libs. --- -selectPackageTargets :: HaddockFlags -> TargetSelector - -> [AvailableTarget k] -> Either TargetProblem' [k] -selectPackageTargets haddockFlags targetSelector targets - - -- If there are any buildable targets then we select those - | not (null targetsBuildable) - = Right targetsBuildable - - -- If there are targets but none are buildable then we report those - | not (null targets) - = Left (TargetProblemNoneEnabled targetSelector targets') - - -- If there are no targets at all then we report that - | otherwise - = Left (TargetProblemNoTargets targetSelector) - where - targets' = forgetTargetsDetail (map disableNotRequested targets) - targetsBuildable = selectBuildableTargets (map disableNotRequested targets) - - -- When there's a target filter like "pkg:exes" then we do select exes, - -- but if it's just a target like "pkg" then we don't build docs for exes - -- unless they are requested by default (i.e. by using --executables) - disableNotRequested t@(AvailableTarget _ cname (TargetBuildable _ _) _) - | not (isRequested targetSelector (componentKind cname)) - = t { availableTargetStatus = TargetDisabledByUser } - disableNotRequested t = t - - isRequested (TargetPackage _ _ (Just _)) _ = True - isRequested (TargetAllPackages (Just _)) _ = True - isRequested _ LibKind = True --- isRequested _ SubLibKind = True --TODO: what about sublibs? - - -- TODO/HACK, we encode some defaults here as v2-haddock's logic; - -- make sure this matches the defaults applied in - -- "Distribution.Client.ProjectPlanning"; this may need more work - -- to be done properly - -- - -- See also https://github.com/haskell/cabal/pull/4886 - isRequested _ FLibKind = fromFlagOrDefault False (haddockForeignLibs haddockFlags) - isRequested _ ExeKind = fromFlagOrDefault False (haddockExecutables haddockFlags) - isRequested _ TestKind = fromFlagOrDefault False (haddockTestSuites haddockFlags) - isRequested _ BenchKind = fromFlagOrDefault False (haddockBenchmarks haddockFlags) - - --- | For a 'TargetComponent' 'TargetSelector', check if the component can be --- selected. --- --- For the @haddock@ command we just need the basic checks on being buildable --- etc. --- -selectComponentTarget :: SubComponentTarget - -> AvailableTarget k -> Either TargetProblem' k -selectComponentTarget = selectComponentTargetBasic - -reportBuildDocumentationTargetProblems :: Verbosity -> [TargetProblem'] -> IO a -reportBuildDocumentationTargetProblems verbosity problems = - reportTargetProblems verbosity "build documentation for" problems diff --git a/cabal/cabal-install/Distribution/Client/CmdInstall.hs b/cabal/cabal-install/Distribution/Client/CmdInstall.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/CmdInstall.hs +++ /dev/null @@ -1,961 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ViewPatterns #-} - --- | cabal-install CLI command: build --- -module Distribution.Client.CmdInstall ( - -- * The @build@ CLI and action - installCommand, - installAction, - - -- * Internals exposed for testing - selectPackageTargets, - selectComponentTarget, - -- * Internals exposed for CmdRepl + CmdRun - establishDummyDistDirLayout, - establishDummyProjectBaseContext - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude -import Distribution.Compat.Directory - ( doesPathExist ) - -import Distribution.Client.ProjectOrchestration -import Distribution.Client.CmdErrorMessages -import Distribution.Client.CmdSdist -import Distribution.Client.TargetProblem - ( TargetProblem', TargetProblem (..) ) - -import Distribution.Client.CmdInstall.ClientInstallFlags -import Distribution.Client.CmdInstall.ClientInstallTargetSelector - -import Distribution.Client.Setup - ( GlobalFlags(..), ConfigFlags(..) ) -import Distribution.Client.Types - ( PackageSpecifier(..), PackageLocation(..), UnresolvedSourcePackage - , SourcePackageDb(..) ) -import qualified Distribution.Client.InstallPlan as InstallPlan -import Distribution.Package - ( Package(..), PackageName, mkPackageName, unPackageName ) -import Distribution.Types.PackageId - ( PackageIdentifier(..) ) -import Distribution.Client.ProjectConfig - ( ProjectPackageLocation(..) - , fetchAndReadSourcePackages - ) -import Distribution.Client.NixStyleOptions - ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) -import Distribution.Client.ProjectFlags (ProjectFlags (..)) -import Distribution.Client.ProjectConfig.Types - ( ProjectConfig(..), ProjectConfigShared(..) - , ProjectConfigBuildOnly(..), PackageConfig(..) - , getMapLast, getMapMappend, projectConfigLogsDir - , projectConfigStoreDir, projectConfigBuildOnly - , projectConfigConfigFile ) -import Distribution.Simple.Program.Db - ( userSpecifyPaths, userSpecifyArgss, defaultProgramDb - , modifyProgramSearchPath, ProgramDb ) -import Distribution.Simple.BuildPaths - ( exeExtension ) -import Distribution.Simple.Program.Find - ( ProgramSearchPathEntry(..) ) -import Distribution.Client.Config - ( defaultInstallPath, getCabalDir, loadConfig, SavedConfig(..) ) -import qualified Distribution.Simple.PackageIndex as PI -import Distribution.Solver.Types.PackageIndex - ( lookupPackageName, searchByName ) -import Distribution.Types.InstalledPackageInfo - ( InstalledPackageInfo(..) ) -import Distribution.Types.Version - ( Version, nullVersion ) -import Distribution.Types.VersionRange - ( thisVersion ) -import Distribution.Solver.Types.PackageConstraint - ( PackageProperty(..) ) -import Distribution.Client.IndexUtils - ( getSourcePackages, getInstalledPackages ) -import Distribution.Client.ProjectConfig - ( projectConfigWithBuilderRepoContext - , resolveBuildTimeSettings, withProjectOrGlobalConfig ) -import Distribution.Client.ProjectPlanning - ( storePackageInstallDirs' ) -import Distribution.Client.ProjectPlanning.Types - ( ElaboratedInstallPlan ) -import qualified Distribution.Simple.InstallDirs as InstallDirs -import Distribution.Client.DistDirLayout - ( DistDirLayout(..), mkCabalDirLayout - , cabalStoreDirLayout - , CabalDirLayout(..), StoreDirLayout(..) ) -import Distribution.Client.RebuildMonad - ( runRebuild ) -import Distribution.Client.InstallSymlink - ( symlinkBinary, trySymlink ) -import Distribution.Client.Types.OverwritePolicy - ( OverwritePolicy (..) ) -import Distribution.Simple.Flag - ( fromFlagOrDefault, flagToMaybe, flagElim ) -import Distribution.Simple.Setup - ( Flag(..) ) -import Distribution.Solver.Types.SourcePackage - ( SourcePackage(..) ) -import Distribution.Simple.Command - ( CommandUI(..), usageAlternatives ) -import Distribution.Simple.Configure - ( configCompilerEx ) -import Distribution.Simple.Compiler - ( Compiler(..), CompilerId(..), CompilerFlavor(..) - , PackageDBStack ) -import Distribution.Simple.GHC - ( ghcPlatformAndVersionString, getGhcAppDir - , GhcImplInfo(..), getImplInfo - , GhcEnvironmentFileEntry(..) - , renderGhcEnvironmentFile, readGhcEnvironmentFile, ParseErrorExc ) -import Distribution.System - ( Platform , buildOS, OS (Windows) ) -import Distribution.Types.UnitId - ( UnitId ) -import Distribution.Types.UnqualComponentName - ( UnqualComponentName, unUnqualComponentName ) -import Distribution.Verbosity - ( normal, lessVerbose ) -import Distribution.Simple.Utils - ( wrapText, die', notice, warn - , withTempDirectory, createDirectoryIfMissingVerbose - , ordNub ) -import Distribution.Utils.Generic - ( safeHead, writeFileAtomic ) - -import qualified Data.ByteString.Lazy.Char8 as BS -import Data.Ord - ( Down(..) ) -import qualified Data.Map as Map -import Distribution.Utils.NubList - ( fromNubList ) -import Network.URI (URI) -import System.Directory - ( doesFileExist, createDirectoryIfMissing - , getTemporaryDirectory, makeAbsolute, doesDirectoryExist - , removeFile, removeDirectory, copyFile ) -import System.FilePath - ( (), (<.>), takeDirectory, takeBaseName ) - -installCommand :: CommandUI (NixStyleFlags ClientInstallFlags) -installCommand = CommandUI - { commandName = "v2-install" - , commandSynopsis = "Install packages." - , commandUsage = usageAlternatives - "v2-install" [ "[TARGETS] [FLAGS]" ] - , commandDescription = Just $ \_ -> wrapText $ - "Installs one or more packages. This is done by installing them " - ++ "in the store and symlinking/copying the executables in the directory " - ++ "specified by the --installdir flag (`~/.cabal/bin/` by default). " - ++ "If you want the installed executables to be available globally, " - ++ "make sure that the PATH environment variable contains that directory. " - ++ "\n\n" - ++ "If TARGET is a library, it will be added to the global environment. " - ++ "When doing this, cabal will try to build a plan that includes all " - ++ "the previously installed libraries. This is currently not implemented." - , commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " v2-install\n" - ++ " Install the package in the current directory\n" - ++ " " ++ pname ++ " v2-install pkgname\n" - ++ " Install the package named pkgname" - ++ " (fetching it from hackage if necessary)\n" - ++ " " ++ pname ++ " v2-install ./pkgfoo\n" - ++ " Install the package in the ./pkgfoo directory\n" - - ++ cmdCommonHelpTextNewBuildBeta - , commandOptions = nixStyleOptions clientInstallOptions - , commandDefaultFlags = defaultNixStyleFlags defaultClientInstallFlags - } - --- | The @install@ command actually serves four different needs. It installs: --- * exes: --- For example a program from hackage. The behavior is similar to the old --- install command, except that now conflicts between separate runs of the --- command are impossible thanks to the store. --- Exes are installed in the store like a normal dependency, then they are --- symlinked/copied in the directory specified by --installdir. --- To do this we need a dummy projectBaseContext containing the targets as --- estra packages and using a temporary dist directory. --- * libraries --- Libraries install through a similar process, but using GHC environment --- files instead of symlinks. This means that 'v2-install'ing libraries --- only works on GHC >= 8.0. --- --- For more details on how this works, see the module --- "Distribution.Client.ProjectOrchestration" --- -installAction :: NixStyleFlags ClientInstallFlags -> [String] -> GlobalFlags -> IO () -installAction flags@NixStyleFlags { extraFlags = clientInstallFlags', .. } targetStrings globalFlags = do - -- Ensure there were no invalid configuration options specified. - verifyPreconditionsOrDie verbosity configFlags' - - -- We cannot use establishDummyProjectBaseContext to get these flags, since - -- it requires one of them as an argument. Normal establishProjectBaseContext - -- does not, and this is why this is done only for the install command - clientInstallFlags <- getClientInstallFlags verbosity globalFlags clientInstallFlags' - - let - installLibs = fromFlagOrDefault False (cinstInstallLibs clientInstallFlags) - targetFilter = if installLibs then Just LibKind else Just ExeKind - targetStrings' = if null targetStrings then ["."] else targetStrings - - withProject :: IO ([PackageSpecifier UnresolvedSourcePackage], [URI], [TargetSelector], ProjectConfig) - withProject = do - let reducedVerbosity = lessVerbose verbosity - - -- First, we need to learn about what's available to be installed. - localBaseCtx <- - establishProjectBaseContext reducedVerbosity cliConfig InstallCommand - let localDistDirLayout = distDirLayout localBaseCtx - pkgDb <- projectConfigWithBuilderRepoContext reducedVerbosity - (buildSettings localBaseCtx) (getSourcePackages verbosity) - - let - (targetStrings'', packageIds) = - partitionEithers . - flip fmap targetStrings' $ - \str -> case simpleParsec str of - Just (pkgId :: PackageId) - | pkgVersion pkgId /= nullVersion -> Right pkgId - _ -> Left str - packageSpecifiers = - flip fmap packageIds $ \case - PackageIdentifier{..} - | pkgVersion == nullVersion -> NamedPackage pkgName [] - | otherwise -> NamedPackage pkgName - [PackagePropertyVersion - (thisVersion pkgVersion)] - packageTargets = - flip TargetPackageNamed targetFilter . pkgName <$> packageIds - - if null targetStrings' - then return (packageSpecifiers, [], packageTargets, projectConfig localBaseCtx) - else do - targetSelectors <- - either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors (localPackages localBaseCtx) - Nothing targetStrings'' - - (specs, selectors) <- - getSpecsAndTargetSelectors - verbosity reducedVerbosity pkgDb targetSelectors localDistDirLayout localBaseCtx targetFilter - - return ( specs ++ packageSpecifiers - , [] - , selectors ++ packageTargets - , projectConfig localBaseCtx ) - - withoutProject :: ProjectConfig -> IO ([PackageSpecifier pkg], [URI], [TargetSelector], ProjectConfig) - withoutProject globalConfig = do - tss <- traverse (parseWithoutProjectTargetSelector verbosity) targetStrings' - - cabalDir <- getCabalDir - let - projectConfig = globalConfig <> cliConfig - - ProjectConfigBuildOnly { - projectConfigLogsDir - } = projectConfigBuildOnly projectConfig - - ProjectConfigShared { - projectConfigStoreDir - } = projectConfigShared projectConfig - - mlogsDir = flagToMaybe projectConfigLogsDir - mstoreDir = flagToMaybe projectConfigStoreDir - cabalDirLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir - - buildSettings = resolveBuildTimeSettings - verbosity cabalDirLayout - projectConfig - - SourcePackageDb { packageIndex } <- projectConfigWithBuilderRepoContext - verbosity buildSettings - (getSourcePackages verbosity) - - for_ (concatMap woPackageNames tss) $ \name -> do - when (null (lookupPackageName packageIndex name)) $ do - let xs = searchByName packageIndex (unPackageName name) - let emptyIf True _ = [] - emptyIf False zs = zs - die' verbosity $ concat $ - [ "Unknown package \"", unPackageName name, "\". " - ] ++ emptyIf (null xs) - [ "Did you mean any of the following?\n" - , unlines (("- " ++) . unPackageName . fst <$> xs) - ] - - let - (uris, packageSpecifiers) = partitionEithers $ map woPackageSpecifiers tss - packageTargets = map woPackageTargets tss - - return (packageSpecifiers, uris, packageTargets, projectConfig) - - (specs, uris, targetSelectors, config) <- - withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag withProject withoutProject - - let - ProjectConfig { - projectConfigBuildOnly = ProjectConfigBuildOnly { - projectConfigLogsDir - }, - projectConfigShared = ProjectConfigShared { - projectConfigHcFlavor, - projectConfigHcPath, - projectConfigHcPkg, - projectConfigStoreDir - }, - projectConfigLocalPackages = PackageConfig { - packageConfigProgramPaths, - packageConfigProgramArgs, - packageConfigProgramPathExtra - } - } = config - - hcFlavor = flagToMaybe projectConfigHcFlavor - hcPath = flagToMaybe projectConfigHcPath - hcPkg = flagToMaybe projectConfigHcPkg - - -- ProgramDb with directly user specified paths - preProgDb = - userSpecifyPaths (Map.toList (getMapLast packageConfigProgramPaths)) - . userSpecifyArgss (Map.toList (getMapMappend packageConfigProgramArgs)) - . modifyProgramSearchPath - (++ [ ProgramSearchPathDir dir - | dir <- fromNubList packageConfigProgramPathExtra ]) - $ defaultProgramDb - - -- progDb is a program database with compiler tools configured properly - (compiler@Compiler { compilerId = - compilerId@(CompilerId compilerFlavor compilerVersion) }, platform, progDb) <- - configCompilerEx hcFlavor hcPath hcPkg preProgDb verbosity - - let - GhcImplInfo{ supportsPkgEnvFiles } = getImplInfo compiler - - envFile <- getEnvFile clientInstallFlags platform compilerVersion - existingEnvEntries <- - getExistingEnvEntries verbosity compilerFlavor supportsPkgEnvFiles envFile - packageDbs <- getPackageDbStack compilerId projectConfigStoreDir projectConfigLogsDir - installedIndex <- getInstalledPackages verbosity compiler packageDbs progDb - - let - (envSpecs, nonGlobalEnvEntries) = - getEnvSpecsAndNonGlobalEntries installedIndex existingEnvEntries installLibs - - -- Second, we need to use a fake project to let Cabal build the - -- installables correctly. For that, we need a place to put a - -- temporary dist directory. - globalTmp <- getTemporaryDirectory - - withTempDirectory verbosity globalTmp "cabal-install." $ \tmpDir -> do - distDirLayout <- establishDummyDistDirLayout verbosity config tmpDir - - uriSpecs <- runRebuild tmpDir $ fetchAndReadSourcePackages - verbosity - distDirLayout - (projectConfigShared config) - (projectConfigBuildOnly config) - [ ProjectPackageRemoteTarball uri | uri <- uris ] - - baseCtx <- establishDummyProjectBaseContext - verbosity - config - distDirLayout - (envSpecs ++ specs ++ uriSpecs) - InstallCommand - - buildCtx <- constructProjectBuildContext verbosity baseCtx targetSelectors - - printPlan verbosity baseCtx buildCtx - - buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx - runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes - - -- Now that we built everything we can do the installation part. - -- First, figure out if / what parts we want to install: - let - dryRun = buildSettingDryRun $ buildSettings baseCtx - - -- Then, install! - when (not dryRun) $ - if installLibs - then installLibraries verbosity - buildCtx compiler packageDbs progDb envFile nonGlobalEnvEntries - else installExes verbosity - baseCtx buildCtx platform compiler configFlags clientInstallFlags - where - configFlags' = disableTestsBenchsByDefault configFlags - verbosity = fromFlagOrDefault normal (configVerbosity configFlags') - ignoreProject = flagIgnoreProject projectFlags - cliConfig = commandLineFlagsToProjectConfig - globalFlags - flags { configFlags = configFlags' } - clientInstallFlags' - globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) - --- | Verify that invalid config options were not passed to the install command. --- --- If an invalid configuration is found the command will @die'@. -verifyPreconditionsOrDie :: Verbosity -> ConfigFlags -> IO () -verifyPreconditionsOrDie verbosity configFlags = do - -- We never try to build tests/benchmarks for remote packages. - -- So we set them as disabled by default and error if they are explicitly - -- enabled. - when (configTests configFlags == Flag True) $ - die' verbosity $ "--enable-tests was specified, but tests can't " - ++ "be enabled in a remote package" - when (configBenchmarks configFlags == Flag True) $ - die' verbosity $ "--enable-benchmarks was specified, but benchmarks can't " - ++ "be enabled in a remote package" - -getClientInstallFlags :: Verbosity -> GlobalFlags -> ClientInstallFlags -> IO ClientInstallFlags -getClientInstallFlags verbosity globalFlags existingClientInstallFlags = do - let configFileFlag = globalConfigFile globalFlags - savedConfig <- loadConfig verbosity configFileFlag - pure $ savedClientInstallFlags savedConfig `mappend` existingClientInstallFlags - - -getSpecsAndTargetSelectors - :: Verbosity - -> Verbosity - -> SourcePackageDb - -> [TargetSelector] - -> DistDirLayout - -> ProjectBaseContext - -> Maybe ComponentKindFilter - -> IO ([PackageSpecifier UnresolvedSourcePackage], [TargetSelector]) -getSpecsAndTargetSelectors verbosity reducedVerbosity pkgDb targetSelectors localDistDirLayout localBaseCtx targetFilter = - withInstallPlan reducedVerbosity localBaseCtx $ \elaboratedPlan _ -> do - -- Split into known targets and hackage packages. - (targets, hackageNames) <- - partitionToKnownTargetsAndHackagePackages - verbosity pkgDb elaboratedPlan targetSelectors - - let - planMap = InstallPlan.toMap elaboratedPlan - targetIds = Map.keys targets - - sdistize (SpecificSourcePackage spkg) = - SpecificSourcePackage spkg' - where - sdistPath = distSdistFile localDistDirLayout (packageId spkg) - spkg' = spkg { srcpkgSource = LocalTarballPackage sdistPath } - sdistize named = named - - local = sdistize <$> localPackages localBaseCtx - - gatherTargets :: UnitId -> TargetSelector - gatherTargets targetId = TargetPackageNamed pkgName targetFilter - where - targetUnit = Map.findWithDefault (error "cannot find target unit") targetId planMap - PackageIdentifier{..} = packageId targetUnit - - targets' = fmap gatherTargets targetIds - - hackagePkgs :: [PackageSpecifier UnresolvedSourcePackage] - hackagePkgs = flip NamedPackage [] <$> hackageNames - - hackageTargets :: [TargetSelector] - hackageTargets = - flip TargetPackageNamed targetFilter <$> hackageNames - - createDirectoryIfMissing True (distSdistDirectory localDistDirLayout) - - unless (Map.null targets) $ for_ (localPackages localBaseCtx) $ \lpkg -> case lpkg of - SpecificSourcePackage pkg -> packageToSdist verbosity - (distProjectRootDirectory localDistDirLayout) TarGzArchive - (distSdistFile localDistDirLayout (packageId pkg)) pkg - NamedPackage pkgName _ -> error $ "Got NamedPackage " ++ prettyShow pkgName - - if null targets - then return (hackagePkgs, hackageTargets) - else return (local ++ hackagePkgs, targets' ++ hackageTargets) - --- | Partitions the target selectors into known local targets and hackage packages. -partitionToKnownTargetsAndHackagePackages - :: Verbosity - -> SourcePackageDb - -> ElaboratedInstallPlan - -> [TargetSelector] - -> IO (Map UnitId [(ComponentTarget,[TargetSelector])], [PackageName]) -partitionToKnownTargetsAndHackagePackages verbosity pkgDb elaboratedPlan targetSelectors = do - let mTargets = resolveTargets - selectPackageTargets - selectComponentTarget - elaboratedPlan - (Just pkgDb) - targetSelectors - case mTargets of - Right targets -> - -- Everything is a local dependency. - return (targets, []) - Left errs -> do - -- Not everything is local. - let - (errs', hackageNames) = partitionEithers . flip fmap errs $ \case - TargetAvailableInIndex name -> Right name - err -> Left err - - -- report incorrect case for known package. - for_ errs' $ \case - TargetNotInProject hn -> - case searchByName (packageIndex pkgDb) (unPackageName hn) of - [] -> return () - xs -> die' verbosity . concat $ - [ "Unknown package \"", unPackageName hn, "\". " - , "Did you mean any of the following?\n" - , unlines (("- " ++) . unPackageName . fst <$> xs) - ] - _ -> return () - - when (not . null $ errs') $ reportBuildTargetProblems verbosity errs' - - let - targetSelectors' = flip filter targetSelectors $ \case - TargetComponentUnknown name _ _ - | name `elem` hackageNames -> False - TargetPackageNamed name _ - | name `elem` hackageNames -> False - _ -> True - - -- This can't fail, because all of the errors are - -- removed (or we've given up). - targets <- - either (reportBuildTargetProblems verbosity) return $ - resolveTargets - selectPackageTargets - selectComponentTarget - elaboratedPlan - Nothing - targetSelectors' - - return (targets, hackageNames) - - - -constructProjectBuildContext - :: Verbosity - -> ProjectBaseContext - -- ^ The synthetic base context to use to produce the full build context. - -> [TargetSelector] - -> IO ProjectBuildContext -constructProjectBuildContext verbosity baseCtx targetSelectors = do - runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do - -- Interpret the targets on the command line as build targets - targets <- either (reportBuildTargetProblems verbosity) return $ - resolveTargets - selectPackageTargets - selectComponentTarget - elaboratedPlan - Nothing - targetSelectors - - let prunedToTargetsElaboratedPlan = - pruneInstallPlanToTargets TargetActionBuild targets elaboratedPlan - prunedElaboratedPlan <- - if buildSettingOnlyDeps (buildSettings baseCtx) - then either (reportCannotPruneDependencies verbosity) return $ - pruneInstallPlanToDependencies (Map.keysSet targets) - prunedToTargetsElaboratedPlan - else return prunedToTargetsElaboratedPlan - - return (prunedElaboratedPlan, targets) - - --- | Install any built exe by symlinking/copying it --- we don't use BuildOutcomes because we also need the component names -installExes - :: Verbosity - -> ProjectBaseContext - -> ProjectBuildContext - -> Platform - -> Compiler - -> ConfigFlags - -> ClientInstallFlags - -> IO () -installExes verbosity baseCtx buildCtx platform compiler - configFlags clientInstallFlags = do - installPath <- defaultInstallPath - let storeDirLayout = cabalStoreDirLayout $ cabalDirLayout baseCtx - - prefix = fromFlagOrDefault "" (fmap InstallDirs.fromPathTemplate (configProgPrefix configFlags)) - suffix = fromFlagOrDefault "" (fmap InstallDirs.fromPathTemplate (configProgSuffix configFlags)) - - mkUnitBinDir :: UnitId -> FilePath - mkUnitBinDir = - InstallDirs.bindir . - storePackageInstallDirs' storeDirLayout (compilerId compiler) - - mkExeName :: UnqualComponentName -> FilePath - mkExeName exe = unUnqualComponentName exe <.> exeExtension platform - - mkFinalExeName :: UnqualComponentName -> FilePath - mkFinalExeName exe = prefix <> unUnqualComponentName exe <> suffix <.> exeExtension platform - installdirUnknown = - "installdir is not defined. Set it in your cabal config file " - ++ "or use --installdir=. Using default installdir: " ++ show installPath - - installdir <- fromFlagOrDefault - (warn verbosity installdirUnknown >> pure installPath) $ - pure <$> cinstInstalldir clientInstallFlags - createDirectoryIfMissingVerbose verbosity False installdir - warnIfNoExes verbosity buildCtx - - installMethod <- flagElim defaultMethod return $ - cinstInstallMethod clientInstallFlags - - let - doInstall = installUnitExes - verbosity - overwritePolicy - mkUnitBinDir mkExeName mkFinalExeName - installdir installMethod - in traverse_ doInstall $ Map.toList $ targetsMap buildCtx - where - overwritePolicy = fromFlagOrDefault NeverOverwrite $ - cinstOverwritePolicy clientInstallFlags - isWindows = buildOS == Windows - - -- This is in IO as we will make environment checks, - -- to decide which method is best - defaultMethod :: IO InstallMethod - defaultMethod - -- Try symlinking in temporary directory, if it works default to - -- symlinking even on windows - | isWindows = do - symlinks <- trySymlink verbosity - return $ if symlinks then InstallMethodSymlink else InstallMethodCopy - | otherwise = return InstallMethodSymlink - --- | Install any built library by adding it to the default ghc environment -installLibraries - :: Verbosity - -> ProjectBuildContext - -> Compiler - -> PackageDBStack - -> ProgramDb - -> FilePath -- ^ Environment file - -> [GhcEnvironmentFileEntry] - -> IO () -installLibraries verbosity buildCtx compiler - packageDbs programDb envFile envEntries = do - -- Why do we get it again? If we updated a globalPackage then we need - -- the new version. - installedIndex <- getInstalledPackages verbosity compiler packageDbs programDb - if supportsPkgEnvFiles $ getImplInfo compiler - then do - let - getLatest :: PackageName -> [InstalledPackageInfo] - getLatest = (=<<) (maybeToList . safeHead . snd) . take 1 . sortBy (comparing (Down . fst)) - . PI.lookupPackageName installedIndex - globalLatest = concat (getLatest <$> globalPackages) - - baseEntries = - GhcEnvFileClearPackageDbStack : fmap GhcEnvFilePackageDb packageDbs - globalEntries = GhcEnvFilePackageId . installedUnitId <$> globalLatest - pkgEntries = ordNub $ - globalEntries - ++ envEntries - ++ entriesForLibraryComponents (targetsMap buildCtx) - contents' = renderGhcEnvironmentFile (baseEntries ++ pkgEntries) - createDirectoryIfMissing True (takeDirectory envFile) - writeFileAtomic envFile (BS.pack contents') - else - warn verbosity $ - "The current compiler doesn't support safely installing libraries, " - ++ "so only executables will be available. (Library installation is " - ++ "supported on GHC 8.0+ only)" - -warnIfNoExes :: Verbosity -> ProjectBuildContext -> IO () -warnIfNoExes verbosity buildCtx = - when noExes $ - warn verbosity $ - "\n" <> - "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@\n" <> - "@ WARNING: Installation might not be completed as desired! @\n" <> - "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@\n" <> - "Without flags, the command \"cabal install\" doesn't expose" <> - " libraries in a usable manner. You might have wanted to run" <> - " \"cabal install --lib " <> - unwords (showTargetSelector <$> selectors) <> "\". " - where - targets = concat $ Map.elems $ targetsMap buildCtx - components = fst <$> targets - selectors = concatMap snd targets - noExes = null $ catMaybes $ exeMaybe <$> components - - exeMaybe (ComponentTarget (CExeName exe) _) = Just exe - exeMaybe _ = Nothing - -globalPackages :: [PackageName] -globalPackages = mkPackageName <$> - [ "ghc", "hoopl", "bytestring", "unix", "base", "time", "hpc", "filepath" - , "process", "array", "integer-gmp", "containers", "ghc-boot", "binary" - , "ghc-prim", "ghci", "rts", "terminfo", "transformers", "deepseq" - , "ghc-boot-th", "pretty", "template-haskell", "directory", "text" - , "bin-package-db" - ] - --- | Return the package specifiers and non-global environment file entries. -getEnvSpecsAndNonGlobalEntries - :: PI.InstalledPackageIndex - -> [GhcEnvironmentFileEntry] - -> Bool - -> ([PackageSpecifier a], [GhcEnvironmentFileEntry]) -getEnvSpecsAndNonGlobalEntries installedIndex entries installLibs = - if installLibs - then (envSpecs, envEntries') - else ([], envEntries') - where - (envSpecs, envEntries') = environmentFileToSpecifiers installedIndex entries - -environmentFileToSpecifiers - :: PI.InstalledPackageIndex -> [GhcEnvironmentFileEntry] - -> ([PackageSpecifier a], [GhcEnvironmentFileEntry]) -environmentFileToSpecifiers ipi = foldMap $ \case - (GhcEnvFilePackageId unitId) - | Just InstalledPackageInfo - { sourcePackageId = PackageIdentifier{..}, installedUnitId } - <- PI.lookupUnitId ipi unitId - , let pkgSpec = NamedPackage pkgName - [PackagePropertyVersion (thisVersion pkgVersion)] - -> if pkgName `elem` globalPackages - then ([pkgSpec], []) - else ([pkgSpec], [GhcEnvFilePackageId installedUnitId]) - _ -> ([], []) - - --- | Disables tests and benchmarks if they weren't explicitly enabled. -disableTestsBenchsByDefault :: ConfigFlags -> ConfigFlags -disableTestsBenchsByDefault configFlags = - configFlags { configTests = Flag False <> configTests configFlags - , configBenchmarks = Flag False <> configBenchmarks configFlags } - --- | Symlink/copy every exe from a package from the store to a given location -installUnitExes - :: Verbosity - -> OverwritePolicy -- ^ Whether to overwrite existing files - -> (UnitId -> FilePath) -- ^ A function to get an UnitId's - -- ^ store directory - -> (UnqualComponentName -> FilePath) -- ^ A function to get an - -- ^ exe's filename - -> (UnqualComponentName -> FilePath) -- ^ A function to get an - -- ^ exe's final possibly - -- ^ different to the name in the store. - -> FilePath - -> InstallMethod - -> ( UnitId - , [(ComponentTarget, [TargetSelector])] ) - -> IO () -installUnitExes verbosity overwritePolicy - mkSourceBinDir mkExeName mkFinalExeName - installdir installMethod - (unit, components) = - traverse_ installAndWarn exes - where - exes = catMaybes $ (exeMaybe . fst) <$> components - exeMaybe (ComponentTarget (CExeName exe) _) = Just exe - exeMaybe _ = Nothing - installAndWarn exe = do - success <- installBuiltExe - verbosity overwritePolicy - (mkSourceBinDir unit) (mkExeName exe) - (mkFinalExeName exe) - installdir installMethod - let errorMessage = case overwritePolicy of - NeverOverwrite -> - "Path '" <> (installdir prettyShow exe) <> "' already exists. " - <> "Use --overwrite-policy=always to overwrite." - -- This shouldn't even be possible, but we keep it in case - -- symlinking/copying logic changes - AlwaysOverwrite -> - case installMethod of - InstallMethodSymlink -> "Symlinking" - InstallMethodCopy -> - "Copying" <> " '" <> prettyShow exe <> "' failed." - unless success $ die' verbosity errorMessage - --- | Install a specific exe. -installBuiltExe - :: Verbosity -> OverwritePolicy - -> FilePath -- ^ The directory where the built exe is located - -> FilePath -- ^ The exe's filename - -> FilePath -- ^ The exe's filename in the public install directory - -> FilePath -- ^ the directory where it should be installed - -> InstallMethod - -> IO Bool -- ^ Whether the installation was successful -installBuiltExe verbosity overwritePolicy - sourceDir exeName finalExeName - installdir InstallMethodSymlink = do - notice verbosity $ "Symlinking '" <> exeName <> "' to '" <> destination <> "'" - symlinkBinary - overwritePolicy - installdir - sourceDir - finalExeName - exeName - where - destination = installdir finalExeName -installBuiltExe verbosity overwritePolicy - sourceDir exeName finalExeName - installdir InstallMethodCopy = do - notice verbosity $ "Copying '" <> exeName <> "' to '" <> destination <> "'" - exists <- doesPathExist destination - case (exists, overwritePolicy) of - (True , NeverOverwrite ) -> pure False - (True , AlwaysOverwrite) -> remove >> copy - (False, _ ) -> copy - where - source = sourceDir exeName - destination = installdir finalExeName - remove = do - isDir <- doesDirectoryExist destination - if isDir - then removeDirectory destination - else removeFile destination - copy = copyFile source destination >> pure True - --- | Create 'GhcEnvironmentFileEntry's for packages with exposed libraries. -entriesForLibraryComponents :: TargetsMap -> [GhcEnvironmentFileEntry] -entriesForLibraryComponents = Map.foldrWithKey' (\k v -> mappend (go k v)) [] - where - hasLib :: (ComponentTarget, [TargetSelector]) -> Bool - hasLib (ComponentTarget (CLibName _) _, _) = True - hasLib _ = False - - go :: UnitId - -> [(ComponentTarget, [TargetSelector])] - -> [GhcEnvironmentFileEntry] - go unitId targets - | any hasLib targets = [GhcEnvFilePackageId unitId] - | otherwise = [] - - --- | Gets the file path to the request environment file. -getEnvFile :: ClientInstallFlags -> Platform -> Version -> IO FilePath -getEnvFile clientInstallFlags platform compilerVersion = do - appDir <- getGhcAppDir - case flagToMaybe (cinstEnvironmentPath clientInstallFlags) of - Just spec - -- Is spec a bare word without any "pathy" content, then it refers to - -- a named global environment. - | takeBaseName spec == spec -> - return (getGlobalEnv appDir platform compilerVersion spec) - | otherwise -> do - spec' <- makeAbsolute spec - isDir <- doesDirectoryExist spec' - if isDir - -- If spec is a directory, then make an ambient environment inside - -- that directory. - then return (getLocalEnv spec' platform compilerVersion) - -- Otherwise, treat it like a literal file path. - else return spec' - Nothing -> - return (getGlobalEnv appDir platform compilerVersion "default") - --- | Returns the list of @GhcEnvFilePackageIj@ values already existing in the --- environment being operated on. -getExistingEnvEntries :: Verbosity -> CompilerFlavor -> Bool -> FilePath -> IO [GhcEnvironmentFileEntry] -getExistingEnvEntries verbosity compilerFlavor supportsPkgEnvFiles envFile = do - envFileExists <- doesFileExist envFile - filterEnvEntries <$> if - (compilerFlavor == GHC || compilerFlavor == GHCJS) - && supportsPkgEnvFiles && envFileExists - then catch (readGhcEnvironmentFile envFile) $ \(_ :: ParseErrorExc) -> - warn verbosity ("The environment file " ++ envFile ++ - " is unparsable. Libraries cannot be installed.") >> return [] - else return [] - where - -- Why? We know what the first part will be, we only care about the packages. - filterEnvEntries = filter $ \case - GhcEnvFilePackageId _ -> True - _ -> False - --- | Constructs the path to the global GHC environment file. --- --- TODO(m-renaud): Create PkgEnvName newtype wrapper. -getGlobalEnv :: FilePath -> Platform -> Version -> String -> FilePath -getGlobalEnv appDir platform compilerVersion name = - appDir ghcPlatformAndVersionString platform compilerVersion - "environments" name - --- | Constructs the path to a local GHC environment file. -getLocalEnv :: FilePath -> Platform -> Version -> FilePath -getLocalEnv dir platform compilerVersion = - dir - ".ghc.environment." <> ghcPlatformAndVersionString platform compilerVersion - -getPackageDbStack - :: CompilerId - -> Flag FilePath - -> Flag FilePath - -> IO PackageDBStack -getPackageDbStack compilerId storeDirFlag logsDirFlag = do - cabalDir <- getCabalDir - mstoreDir <- traverse makeAbsolute $ flagToMaybe storeDirFlag - let - mlogsDir = flagToMaybe logsDirFlag - cabalLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir - pure $ storePackageDBStack (cabalStoreDirLayout cabalLayout) compilerId - --- | This defines what a 'TargetSelector' means for the @bench@ command. --- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, --- or otherwise classifies the problem. --- --- For the @build@ command select all components except non-buildable --- and disabled tests\/benchmarks, fail if there are no such --- components --- -selectPackageTargets - :: TargetSelector - -> [AvailableTarget k] -> Either TargetProblem' [k] -selectPackageTargets targetSelector targets - - -- If there are any buildable targets then we select those - | not (null targetsBuildable) - = Right targetsBuildable - - -- If there are targets but none are buildable then we report those - | not (null targets) - = Left (TargetProblemNoneEnabled targetSelector targets') - - -- If there are no targets at all then we report that - | otherwise - = Left (TargetProblemNoTargets targetSelector) - where - targets' = forgetTargetsDetail targets - targetsBuildable = selectBuildableTargetsWith - (buildable targetSelector) - targets - - -- When there's a target filter like "pkg:tests" then we do select tests, - -- but if it's just a target like "pkg" then we don't build tests unless - -- they are requested by default (i.e. by using --enable-tests) - buildable (TargetPackage _ _ Nothing) TargetNotRequestedByDefault = False - buildable (TargetAllPackages Nothing) TargetNotRequestedByDefault = False - buildable _ _ = True - --- | For a 'TargetComponent' 'TargetSelector', check if the component can be --- selected. --- --- For the @build@ command we just need the basic checks on being buildable etc. --- -selectComponentTarget - :: SubComponentTarget - -> AvailableTarget k -> Either TargetProblem' k -selectComponentTarget = selectComponentTargetBasic - -reportBuildTargetProblems :: Verbosity -> [TargetProblem'] -> IO a -reportBuildTargetProblems verbosity problems = reportTargetProblems verbosity "build" problems - -reportCannotPruneDependencies :: Verbosity -> CannotPruneDependencies -> IO a -reportCannotPruneDependencies verbosity = - die' verbosity . renderCannotPruneDependencies diff --git a/cabal/cabal-install/Distribution/Client/CmdInstall/ClientInstallFlags.hs b/cabal/cabal-install/Distribution/Client/CmdInstall/ClientInstallFlags.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/CmdInstall/ClientInstallFlags.hs +++ /dev/null @@ -1,89 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} -module Distribution.Client.CmdInstall.ClientInstallFlags -( InstallMethod(..) -, ClientInstallFlags(..) -, defaultClientInstallFlags -, clientInstallOptions -) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.ReadE - ( succeedReadE, parsecToReadE ) -import Distribution.Simple.Command - ( ShowOrParseArgs(..), OptionField(..), option, reqArg ) -import Distribution.Simple.Setup - ( Flag(..), trueArg, flagToList, toFlag ) - -import Distribution.Client.Types.InstallMethod - ( InstallMethod (..) ) -import Distribution.Client.Types.OverwritePolicy - ( OverwritePolicy(..) ) - -import qualified Distribution.Compat.CharParsing as P - -data ClientInstallFlags = ClientInstallFlags - { cinstInstallLibs :: Flag Bool - , cinstEnvironmentPath :: Flag FilePath - , cinstOverwritePolicy :: Flag OverwritePolicy - , cinstInstallMethod :: Flag InstallMethod - , cinstInstalldir :: Flag FilePath - } deriving (Eq, Show, Generic) - -instance Monoid ClientInstallFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup ClientInstallFlags where - (<>) = gmappend - -instance Binary ClientInstallFlags -instance Structured ClientInstallFlags - -defaultClientInstallFlags :: ClientInstallFlags -defaultClientInstallFlags = ClientInstallFlags - { cinstInstallLibs = toFlag False - , cinstEnvironmentPath = mempty - , cinstOverwritePolicy = mempty - , cinstInstallMethod = mempty - , cinstInstalldir = mempty - } - -clientInstallOptions :: ShowOrParseArgs -> [OptionField ClientInstallFlags] -clientInstallOptions _ = - [ option [] ["lib"] - "Install libraries rather than executables from the target package." - cinstInstallLibs (\v flags -> flags { cinstInstallLibs = v }) - trueArg - , option [] ["package-env", "env"] - "Set the environment file that may be modified." - cinstEnvironmentPath (\pf flags -> flags { cinstEnvironmentPath = pf }) - (reqArg "ENV" (succeedReadE Flag) flagToList) - , option [] ["overwrite-policy"] - "How to handle already existing symlinks." - cinstOverwritePolicy (\v flags -> flags { cinstOverwritePolicy = v }) - $ reqArg "always|never" - (parsecToReadE (\err -> "Error parsing overwrite-policy: " ++ err) (toFlag `fmap` parsec)) - (map prettyShow . flagToList) - , option [] ["install-method"] - "How to install the executables." - cinstInstallMethod (\v flags -> flags { cinstInstallMethod = v }) - $ reqArg - "default|copy|symlink" - (parsecToReadE (\err -> "Error parsing install-method: " ++ err) (toFlag `fmap` parsecInstallMethod)) - (map prettyShow . flagToList) - , option [] ["installdir"] - "Where to install (by symlinking or copying) the executables in." - cinstInstalldir (\v flags -> flags { cinstInstalldir = v }) - $ reqArg "DIR" (succeedReadE Flag) flagToList - ] - -parsecInstallMethod :: CabalParsing m => m InstallMethod -parsecInstallMethod = do - name <- P.munch1 isAlpha - case name of - "copy" -> pure InstallMethodCopy - "symlink" -> pure InstallMethodSymlink - _ -> P.unexpected $ "InstallMethod: " ++ name diff --git a/cabal/cabal-install/Distribution/Client/CmdInstall/ClientInstallTargetSelector.hs b/cabal/cabal-install/Distribution/Client/CmdInstall/ClientInstallTargetSelector.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/CmdInstall/ClientInstallTargetSelector.hs +++ /dev/null @@ -1,68 +0,0 @@ -module Distribution.Client.CmdInstall.ClientInstallTargetSelector ( - WithoutProjectTargetSelector (..), - parseWithoutProjectTargetSelector, - woPackageNames, - woPackageTargets, - woPackageSpecifiers, - ) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Network.URI (URI, parseURI) - -import Distribution.Client.TargetSelector -import Distribution.Client.Types -import Distribution.Compat.CharParsing (char, optional) -import Distribution.Package -import Distribution.Simple.LocalBuildInfo (ComponentName (CExeName)) -import Distribution.Simple.Utils (die') -import Distribution.Solver.Types.PackageConstraint (PackageProperty (..)) -import Distribution.Version - -data WithoutProjectTargetSelector - = WoPackageId PackageId - | WoPackageComponent PackageId ComponentName - | WoURI URI - deriving (Show) - -parseWithoutProjectTargetSelector :: Verbosity -> String -> IO WithoutProjectTargetSelector -parseWithoutProjectTargetSelector verbosity input = - case explicitEitherParsec parser input of - Right ts -> return ts - Left err -> case parseURI input of - Just uri -> return (WoURI uri) - Nothing -> die' verbosity $ "Invalid package ID: " ++ input ++ "\n" ++ err - where - parser :: CabalParsing m => m WithoutProjectTargetSelector - parser = do - pid <- parsec - cn <- optional (char ':' *> parsec) - return $ case cn of - Nothing -> WoPackageId pid - Just cn' -> WoPackageComponent pid (CExeName cn') - -woPackageNames :: WithoutProjectTargetSelector -> [PackageName] -woPackageNames (WoPackageId pid) = [pkgName pid] -woPackageNames (WoPackageComponent pid _) = [pkgName pid] -woPackageNames (WoURI _) = [] - -woPackageTargets :: WithoutProjectTargetSelector -> TargetSelector -woPackageTargets (WoPackageId pid) = - TargetPackageNamed (pkgName pid) Nothing -woPackageTargets (WoPackageComponent pid cn) = - TargetComponentUnknown (pkgName pid) (Right cn) WholeComponent -woPackageTargets (WoURI _) = - TargetAllPackages (Just ExeKind) - -woPackageSpecifiers :: WithoutProjectTargetSelector -> Either URI (PackageSpecifier pkg) -woPackageSpecifiers (WoPackageId pid) = Right (pidPackageSpecifiers pid) -woPackageSpecifiers (WoPackageComponent pid _) = Right (pidPackageSpecifiers pid) -woPackageSpecifiers (WoURI uri) = Left uri - -pidPackageSpecifiers :: PackageId -> PackageSpecifier pkg -pidPackageSpecifiers pid - | pkgVersion pid == nullVersion = NamedPackage (pkgName pid) [] - | otherwise = NamedPackage (pkgName pid) - [ PackagePropertyVersion (thisVersion (pkgVersion pid)) - ] diff --git a/cabal/cabal-install/Distribution/Client/CmdLegacy.hs b/cabal/cabal-install/Distribution/Client/CmdLegacy.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/CmdLegacy.hs +++ /dev/null @@ -1,150 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ViewPatterns #-} -module Distribution.Client.CmdLegacy ( legacyCmd, legacyWrapperCmd, newCmd ) where - -import Prelude () -import Distribution.Client.Compat.Prelude - -import Distribution.Client.Sandbox - ( loadConfigOrSandboxConfig, findSavedDistPref ) -import qualified Distribution.Client.Setup as Client -import Distribution.Client.SetupWrapper - ( SetupScriptOptions(..), setupWrapper, defaultSetupScriptOptions ) -import qualified Distribution.Simple.Setup as Setup -import Distribution.Simple.Command -import Distribution.Simple.Utils - ( wrapText ) -import Distribution.Verbosity - ( normal ) - -import Control.Exception - ( try ) -import qualified Data.Text as T - --- Tweaked versions of code from Main. -regularCmd :: (HasVerbosity flags) => CommandUI flags -> (flags -> [String] -> globals -> IO action) -> CommandSpec (globals -> IO action) -regularCmd ui action = - CommandSpec ui ((flip commandAddAction) (\flags extra globals -> action flags extra globals)) NormalCommand - -wrapperCmd :: Monoid flags => CommandUI flags -> (flags -> Setup.Flag Verbosity) -> (flags -> Setup.Flag String) -> CommandSpec (Client.GlobalFlags -> IO ()) -wrapperCmd ui verbosity' distPref = - CommandSpec ui (\ui' -> wrapperAction ui' verbosity' distPref) NormalCommand - -wrapperAction :: Monoid flags => CommandUI flags -> (flags -> Setup.Flag Verbosity) -> (flags -> Setup.Flag String) -> Command (Client.GlobalFlags -> IO ()) -wrapperAction command verbosityFlag distPrefFlag = - commandAddAction command - { commandDefaultFlags = mempty } $ \flags extraArgs globalFlags -> do - let verbosity' = Setup.fromFlagOrDefault normal (verbosityFlag flags) - - load <- try (loadConfigOrSandboxConfig verbosity' globalFlags) - let config = either (\(SomeException _) -> mempty) id load - distPref <- findSavedDistPref config (distPrefFlag flags) - let setupScriptOptions = defaultSetupScriptOptions { useDistPref = distPref } - - let command' = command { commandName = T.unpack . T.replace "v1-" "" . T.pack . commandName $ command } - - setupWrapper verbosity' setupScriptOptions Nothing - command' (const flags) (const extraArgs) - --- - -class HasVerbosity a where - verbosity :: a -> Verbosity - -instance HasVerbosity (Setup.Flag Verbosity) where - verbosity = Setup.fromFlagOrDefault normal - -instance (HasVerbosity a) => HasVerbosity (a, b) where - verbosity (a, _) = verbosity a - -instance (HasVerbosity a) => HasVerbosity (a, b, c) where - verbosity (a , _, _) = verbosity a - -instance (HasVerbosity a) => HasVerbosity (a, b, c, d) where - verbosity (a, _, _, _) = verbosity a - -instance (HasVerbosity a) => HasVerbosity (a, b, c, d, e) where - verbosity (a, _, _, _, _) = verbosity a - -instance (HasVerbosity a) => HasVerbosity (a, b, c, d, e, f) where - verbosity (a, _, _, _, _, _) = verbosity a - -instance HasVerbosity Setup.BuildFlags where - verbosity = verbosity . Setup.buildVerbosity - -instance HasVerbosity Setup.ConfigFlags where - verbosity = verbosity . Setup.configVerbosity - -instance HasVerbosity Setup.ReplFlags where - verbosity = verbosity . Setup.replVerbosity - -instance HasVerbosity Client.FreezeFlags where - verbosity = verbosity . Client.freezeVerbosity - -instance HasVerbosity Setup.HaddockFlags where - verbosity = verbosity . Setup.haddockVerbosity - -instance HasVerbosity Client.ExecFlags where - verbosity = verbosity . Client.execVerbosity - -instance HasVerbosity Client.UpdateFlags where - verbosity = verbosity . Client.updateVerbosity - -instance HasVerbosity Setup.CleanFlags where - verbosity = verbosity . Setup.cleanVerbosity - -instance HasVerbosity Setup.DoctestFlags where - verbosity = verbosity . Setup.doctestVerbosity - --- - -legacyNote :: String -> String -legacyNote cmd = wrapText $ - "The v1-" ++ cmd ++ " command is a part of the legacy v1 style of cabal usage.\n\n" ++ - - "It is a legacy feature and will be removed in a future release of cabal-install." ++ - " Please file a bug if you cannot replicate a working v1- use case with the nix-style" ++ - " commands.\n\n" ++ - - "For more information, see: https://cabal.readthedocs.io/en/latest/nix-local-build-overview.html" - -toLegacyCmd :: CommandSpec (globals -> IO action) -> [CommandSpec (globals -> IO action)] -toLegacyCmd mkSpec = [toLegacy mkSpec] - where - toLegacy (CommandSpec origUi@CommandUI{..} action type') = CommandSpec legUi action type' - where - legUi = origUi - { commandName = "v1-" ++ commandName - , commandNotes = Just $ \pname -> case commandNotes of - Just notes -> notes pname ++ "\n" ++ legacyNote commandName - Nothing -> legacyNote commandName - } - -legacyCmd :: (HasVerbosity flags) => CommandUI flags -> (flags -> [String] -> globals -> IO action) -> [CommandSpec (globals -> IO action)] -legacyCmd ui action = toLegacyCmd (regularCmd ui action) - -legacyWrapperCmd :: Monoid flags => CommandUI flags -> (flags -> Setup.Flag Verbosity) -> (flags -> Setup.Flag String) -> [CommandSpec (Client.GlobalFlags -> IO ())] -legacyWrapperCmd ui verbosity' distPref = toLegacyCmd (wrapperCmd ui verbosity' distPref) - -newCmd :: CommandUI flags -> (flags -> [String] -> globals -> IO action) -> [CommandSpec (globals -> IO action)] -newCmd origUi@CommandUI{..} action = [cmd defaultUi, cmd newUi, cmd origUi] - where - cmd ui = CommandSpec ui (flip commandAddAction action) NormalCommand - - newMsg = T.unpack . T.replace "v2-" "new-" . T.pack - newUi = origUi - { commandName = newMsg commandName - , commandUsage = newMsg . commandUsage - , commandDescription = (newMsg .) <$> commandDescription - , commandNotes = (newMsg .) <$> commandDescription - } - - defaultMsg = T.unpack . T.replace "v2-" "" . T.pack - defaultUi = origUi - { commandName = defaultMsg commandName - , commandUsage = defaultMsg . commandUsage - , commandDescription = (defaultMsg .) <$> commandDescription - , commandNotes = (defaultMsg .) <$> commandDescription - } diff --git a/cabal/cabal-install/Distribution/Client/CmdListBin.hs b/cabal/cabal-install/Distribution/Client/CmdListBin.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/CmdListBin.hs +++ /dev/null @@ -1,368 +0,0 @@ -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -module Distribution.Client.CmdListBin ( - listbinCommand, - listbinAction, -) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Client.CmdErrorMessages - (plural, renderListCommaAnd, renderTargetProblem, renderTargetProblemNoTargets, - renderTargetSelector, showTargetSelector, targetSelectorFilter, targetSelectorPluralPkgs) -import Distribution.Client.DistDirLayout (DistDirLayout (..), ProjectRoot (..)) -import Distribution.Client.NixStyleOptions - (NixStyleFlags (..), defaultNixStyleFlags, nixStyleOptions) -import Distribution.Client.ProjectConfig - (ProjectConfig, projectConfigConfigFile, projectConfigShared, withProjectOrGlobalConfig) -import Distribution.Client.ProjectFlags (ProjectFlags (..)) -import Distribution.Client.ProjectOrchestration -import Distribution.Client.ProjectPlanning.Types -import Distribution.Client.Setup (GlobalFlags (..)) -import Distribution.Client.TargetProblem (TargetProblem (..)) -import Distribution.Simple.BuildPaths (dllExtension, exeExtension) -import Distribution.Simple.Command (CommandUI (..)) -import Distribution.Simple.Setup (configVerbosity, fromFlagOrDefault) -import Distribution.Simple.Utils (die', ordNub, wrapText) -import Distribution.System (Platform) -import Distribution.Types.ComponentName (showComponentName) -import Distribution.Types.UnitId (UnitId) -import Distribution.Types.UnqualComponentName (UnqualComponentName) -import Distribution.Verbosity (silent, verboseStderr) -import System.Directory (getCurrentDirectory) -import System.FilePath ((<.>), ()) - -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Distribution.Client.InstallPlan as IP -import qualified Distribution.Simple.InstallDirs as InstallDirs -import qualified Distribution.Solver.Types.ComponentDeps as CD - -------------------------------------------------------------------------------- --- Command -------------------------------------------------------------------------------- - -listbinCommand :: CommandUI (NixStyleFlags ()) -listbinCommand = CommandUI - { commandName = "list-bin" - , commandSynopsis = "list path to a single executable." - , commandUsage = \pname -> - "Usage: " ++ pname ++ " list-bin [FLAGS] TARGET\n" - , commandDescription = Just $ \_ -> wrapText - "List path to a build product." - , commandNotes = Nothing - , commandDefaultFlags = defaultNixStyleFlags () - , commandOptions = nixStyleOptions (const []) - } - -------------------------------------------------------------------------------- --- Action -------------------------------------------------------------------------------- - -listbinAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO () -listbinAction flags@NixStyleFlags{..} args globalFlags = do - -- fail early if multiple target selectors specified - target <- case args of - [] -> die' verbosity "One target is required, none provided" - [x] -> return x - _ -> die' verbosity "One target is required, given multiple" - - -- configure - (baseCtx, distDirLayout) <- withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag withProject withoutProject - let localPkgs = localPackages baseCtx - - -- elaborate target selectors - targetSelectors <- either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors localPkgs Nothing [target] - - buildCtx <- - runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do - -- Interpret the targets on the command line as build targets - -- (as opposed to say repl or haddock targets). - targets <- either (reportTargetProblems verbosity) return - $ resolveTargets - selectPackageTargets - selectComponentTarget - elaboratedPlan - Nothing - targetSelectors - - -- 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. - -- - -- Note that we discard the target and return the whole 'TargetsMap', - -- so this check will be repeated (and must succeed) after - -- the 'runProjectPreBuildPhase'. Keep it in mind when modifying this. - _ <- singleComponentOrElse - (reportTargetProblems - verbosity - [multipleTargetsProblem targets]) - targets - - let elaboratedPlan' = pruneInstallPlanToTargets - TargetActionBuild - targets - elaboratedPlan - return (elaboratedPlan', targets) - - (selectedUnitId, _selectedComponent) <- - -- Slight duplication with 'runProjectPreBuildPhase'. - singleComponentOrElse - (die' verbosity $ "No or multiple targets given, but the run " - ++ "phase has been reached. This is a bug.") - $ targetsMap buildCtx - - printPlan verbosity baseCtx buildCtx - - binfiles <- case Map.lookup selectedUnitId $ IP.toMap (elaboratedPlanOriginal buildCtx) of - Nothing -> die' verbosity "No or multiple targets given..." - Just gpp -> return $ IP.foldPlanPackage - (const []) -- IPI don't have executables - (elaboratedPackage distDirLayout (elaboratedShared buildCtx)) - gpp - - case binfiles of - [exe] -> putStrLn exe - _ -> die' verbosity "No or multiple targets given" - where - defaultVerbosity = verboseStderr silent - verbosity = fromFlagOrDefault defaultVerbosity (configVerbosity configFlags) - ignoreProject = flagIgnoreProject projectFlags - prjConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags, not needed here - globalConfigFlag = projectConfigConfigFile (projectConfigShared prjConfig) - - withProject :: IO (ProjectBaseContext, DistDirLayout) - withProject = do - baseCtx <- establishProjectBaseContext verbosity prjConfig OtherCommand - return (baseCtx, distDirLayout baseCtx) - - withoutProject :: ProjectConfig -> IO (ProjectBaseContext, DistDirLayout) - withoutProject config = do - cwd <- getCurrentDirectory - baseCtx <- establishProjectBaseContextWithRoot verbosity (config <> prjConfig) (ProjectRootImplicit cwd) OtherCommand - return (baseCtx, distDirLayout baseCtx) - - -- this is copied from - elaboratedPackage - :: DistDirLayout - -> ElaboratedSharedConfig - -> ElaboratedConfiguredPackage - -> [FilePath] - elaboratedPackage distDirLayout elaboratedSharedConfig elab = case elabPkgOrComp elab of - ElabPackage pkg -> - [ bin - | (c, _) <- CD.toList $ CD.zip (pkgLibDependencies pkg) - (pkgExeDependencies pkg) - , bin <- bin_file c - ] - ElabComponent comp -> bin_file (compSolverName comp) - where - dist_dir = distBuildDirectory distDirLayout (elabDistDirParams elaboratedSharedConfig elab) - - bin_file c = case c of - CD.ComponentExe s -> [bin_file' s] - CD.ComponentTest s -> [bin_file' s] - CD.ComponentBench s -> [bin_file' s] - CD.ComponentFLib s -> [flib_file' s] - _ -> [] - - plat :: Platform - plat = pkgConfigPlatform elaboratedSharedConfig - - -- here and in PlanOutput, - -- use binDirectoryFor? - bin_file' s = - if elabBuildStyle elab == BuildInplaceOnly - then dist_dir "build" prettyShow s prettyShow s <.> exeExtension plat - else InstallDirs.bindir (elabInstallDirs elab) prettyShow s <.> exeExtension plat - - flib_file' s = - if elabBuildStyle elab == BuildInplaceOnly - then dist_dir "build" prettyShow s ("lib" ++ prettyShow s) <.> dllExtension plat - else InstallDirs.bindir (elabInstallDirs elab) ("lib" ++ prettyShow s) <.> dllExtension plat - -------------------------------------------------------------------------------- --- Target Problem: the very similar to CmdRun -------------------------------------------------------------------------------- - -singleComponentOrElse :: IO (UnitId, UnqualComponentName) -> TargetsMap -> IO (UnitId, UnqualComponentName) -singleComponentOrElse action targetsMap = - case Set.toList . distinctTargetComponents $ targetsMap - of [(unitId, CExeName component)] -> return (unitId, component) - [(unitId, CTestName component)] -> return (unitId, component) - [(unitId, CBenchName component)] -> return (unitId, component) - [(unitId, CFLibName component)] -> return (unitId, component) - _ -> action - --- | This defines what a 'TargetSelector' means for the @list-bin@ command. --- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, --- or otherwise classifies the problem. --- --- For the @list-bin@ command we select the exe or flib if there is only one --- and it's buildable. Fail if there are no or multiple buildable exe components. --- -selectPackageTargets :: TargetSelector - -> [AvailableTarget k] -> Either ListBinTargetProblem [k] -selectPackageTargets targetSelector targets - - -- If there is exactly one buildable executable then we select that - | [target] <- targetsExesBuildable - = Right [target] - - -- but fail if there are multiple buildable executables. - | not (null targetsExesBuildable) - = Left (matchesMultipleProblem targetSelector targetsExesBuildable') - - -- If there are executables but none are buildable then we report those - | not (null targetsExes) - = Left (TargetProblemNoneEnabled targetSelector targetsExes) - - -- If there are no executables but some other targets then we report that - | not (null targets) - = Left (noComponentsProblem targetSelector) - - -- If there are no targets at all then we report that - | otherwise - = Left (TargetProblemNoTargets targetSelector) - where - -- Targets that can be executed - targetsExecutableLike = - concatMap (\kind -> filterTargetsKind kind targets) - [ExeKind, TestKind, BenchKind] - (targetsExesBuildable, - targetsExesBuildable') = selectBuildableTargets' targetsExecutableLike - - targetsExes = forgetTargetsDetail targetsExecutableLike - - --- | For a 'TargetComponent' 'TargetSelector', check if the component can be --- selected. --- --- For the @run@ command we just need to check it is a executable-like --- (an executable, a test, or a benchmark), in addition --- to the basic checks on being buildable etc. --- -selectComponentTarget :: SubComponentTarget - -> AvailableTarget k -> Either ListBinTargetProblem k -selectComponentTarget subtarget@WholeComponent t - = case availableTargetComponentName t - of CExeName _ -> component - CTestName _ -> component - CBenchName _ -> component - CFLibName _ -> component - _ -> Left (componentNotRightKindProblem pkgid cname) - where pkgid = availableTargetPackageId t - cname = availableTargetComponentName t - component = selectComponentTargetBasic subtarget t - -selectComponentTarget subtarget t - = Left (isSubComponentProblem (availableTargetPackageId t) - (availableTargetComponentName t) - subtarget) - --- | The various error conditions that can occur when matching a --- 'TargetSelector' against 'AvailableTarget's for the @run@ command. --- -data ListBinProblem = - -- | The 'TargetSelector' matches targets but no executables - TargetProblemNoRightComps TargetSelector - - -- | A single 'TargetSelector' matches multiple targets - | TargetProblemMatchesMultiple TargetSelector [AvailableTarget ()] - - -- | Multiple 'TargetSelector's match multiple targets - | TargetProblemMultipleTargets TargetsMap - - -- | 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 - | TargetProblemIsSubComponent PackageId ComponentName SubComponentTarget - deriving (Eq, Show) - -type ListBinTargetProblem = TargetProblem ListBinProblem - -noComponentsProblem :: TargetSelector -> ListBinTargetProblem -noComponentsProblem = CustomTargetProblem . TargetProblemNoRightComps - -matchesMultipleProblem :: TargetSelector -> [AvailableTarget ()] -> ListBinTargetProblem -matchesMultipleProblem selector targets = CustomTargetProblem $ - TargetProblemMatchesMultiple selector targets - -multipleTargetsProblem :: TargetsMap -> TargetProblem ListBinProblem -multipleTargetsProblem = CustomTargetProblem . TargetProblemMultipleTargets - -componentNotRightKindProblem :: PackageId -> ComponentName -> TargetProblem ListBinProblem -componentNotRightKindProblem pkgid name = CustomTargetProblem $ - TargetProblemComponentNotRightKind pkgid name - -isSubComponentProblem - :: PackageId - -> ComponentName - -> SubComponentTarget - -> TargetProblem ListBinProblem -isSubComponentProblem pkgid name subcomponent = CustomTargetProblem $ - TargetProblemIsSubComponent pkgid name subcomponent - -reportTargetProblems :: Verbosity -> [ListBinTargetProblem] -> IO a -reportTargetProblems verbosity = - die' verbosity . unlines . map renderListBinTargetProblem - -renderListBinTargetProblem :: ListBinTargetProblem -> String -renderListBinTargetProblem (TargetProblemNoTargets targetSelector) = - case targetSelectorFilter targetSelector of - Just kind | kind /= ExeKind - -> "The list-bin command is for finding binaries, but the target '" - ++ showTargetSelector targetSelector ++ "' refers to " - ++ renderTargetSelector targetSelector ++ "." - - _ -> renderTargetProblemNoTargets "list-bin" targetSelector -renderListBinTargetProblem problem = - renderTargetProblem "list-bin" renderListBinProblem problem - -renderListBinProblem :: ListBinProblem -> String -renderListBinProblem (TargetProblemMatchesMultiple targetSelector targets) = - "The list-bin command is for finding a single binary at once. The target '" - ++ showTargetSelector targetSelector ++ "' refers to " - ++ renderTargetSelector targetSelector ++ " which includes " - ++ renderListCommaAnd ( ("the "++) <$> - showComponentName <$> - availableTargetComponentName <$> - foldMap - (\kind -> filterTargetsKind kind targets) - [ExeKind, TestKind, BenchKind] ) - ++ "." - -renderListBinProblem (TargetProblemMultipleTargets selectorMap) = - "The list-bin command is for finding a single binary at once. The targets " - ++ renderListCommaAnd [ "'" ++ showTargetSelector ts ++ "'" - | ts <- ordNub (concatMap snd (concat (Map.elems selectorMap))) ] - ++ " refer to different executables." - -renderListBinProblem (TargetProblemComponentNotRightKind pkgid cname) = - "The list-bin command is for finding binaries, but the target '" - ++ showTargetSelector targetSelector ++ "' refers to " - ++ renderTargetSelector targetSelector ++ " from the package " - ++ prettyShow pkgid ++ "." - where - targetSelector = TargetComponent pkgid cname WholeComponent - -renderListBinProblem (TargetProblemIsSubComponent pkgid cname subtarget) = - "The list-bin command can only find a binary as a whole, " - ++ "not files or modules within them, but the target '" - ++ showTargetSelector targetSelector ++ "' refers to " - ++ renderTargetSelector targetSelector ++ "." - where - targetSelector = TargetComponent pkgid cname subtarget - -renderListBinProblem (TargetProblemNoRightComps targetSelector) = - "Cannot list-bin the target '" ++ showTargetSelector targetSelector - ++ "' which refers to " ++ renderTargetSelector targetSelector - ++ " because " - ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do" - ++ " not contain any executables or foreign libraries." diff --git a/cabal/cabal-install/Distribution/Client/CmdRepl.hs b/cabal/cabal-install/Distribution/Client/CmdRepl.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/CmdRepl.hs +++ /dev/null @@ -1,587 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} - --- | cabal-install CLI command: repl --- -module Distribution.Client.CmdRepl ( - -- * The @repl@ CLI and action - replCommand, - replAction, - - -- * Internals exposed for testing - matchesMultipleProblem, - selectPackageTargets, - selectComponentTarget - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude - -import Distribution.Compat.Lens -import qualified Distribution.Types.Lens as L - -import Distribution.Client.NixStyleOptions - ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) -import Distribution.Client.CmdErrorMessages - ( renderTargetSelector, showTargetSelector, - renderTargetProblem, - targetSelectorRefersToPkgs, - renderComponentKind, renderListCommaAnd, renderListSemiAnd, - componentKind, sortGroupOn, Plural(..) ) -import Distribution.Client.TargetProblem - ( TargetProblem(..) ) -import qualified Distribution.Client.InstallPlan as InstallPlan -import Distribution.Client.ProjectBuilding - ( rebuildTargetsDryRun, improveInstallPlanWithUpToDatePackages ) -import Distribution.Client.ProjectConfig - ( ProjectConfig(..), withProjectOrGlobalConfig - , projectConfigConfigFile ) -import Distribution.Client.ProjectOrchestration -import Distribution.Client.ProjectPlanning - ( ElaboratedSharedConfig(..), ElaboratedInstallPlan ) -import Distribution.Client.ProjectPlanning.Types - ( elabOrderExeDependencies ) -import Distribution.Client.Setup - ( GlobalFlags, ConfigFlags(..) ) -import qualified Distribution.Client.Setup as Client -import Distribution.Client.Types - ( PackageLocation(..), PackageSpecifier(..), UnresolvedSourcePackage ) -import Distribution.Simple.Setup - ( fromFlagOrDefault, replOptions - , Flag(..), toFlag, trueArg, falseArg ) -import Distribution.Simple.Command - ( CommandUI(..), liftOptionL, usageAlternatives, option - , ShowOrParseArgs, OptionField, reqArg ) -import Distribution.Compiler - ( CompilerFlavor(GHC) ) -import Distribution.Simple.Compiler - ( compilerCompatVersion ) -import Distribution.Package - ( Package(..), packageName, UnitId, installedUnitId ) -import Distribution.PackageDescription.PrettyPrint -import Distribution.Parsec - ( parsecCommaList ) -import Distribution.ReadE - ( ReadE, parsecToReadE ) -import qualified Distribution.SPDX.License as SPDX -import Distribution.Solver.Types.SourcePackage - ( SourcePackage(..) ) -import Distribution.Types.BuildInfo - ( BuildInfo(..), emptyBuildInfo ) -import Distribution.Types.ComponentName - ( componentNameString ) -import Distribution.Types.CondTree - ( CondTree(..), traverseCondTreeC ) -import Distribution.Types.Dependency - ( Dependency(..), mainLibSet ) -import Distribution.Types.GenericPackageDescription - ( emptyGenericPackageDescription ) -import Distribution.Types.PackageDescription - ( PackageDescription(..), emptyPackageDescription ) -import Distribution.Types.PackageName.Magic - ( fakePackageId ) -import Distribution.Types.Library - ( Library(..), emptyLibrary ) -import Distribution.Types.Version - ( mkVersion ) -import Distribution.Types.VersionRange - ( anyVersion ) -import Distribution.Utils.Generic - ( safeHead ) -import Distribution.Verbosity - ( normal, lessVerbose ) -import Distribution.Simple.Utils - ( wrapText, die', debugNoWrap, ordNub, createTempDirectory, handleDoesNotExist ) -import Language.Haskell.Extension - ( Language(..) ) -import Distribution.CabalSpecVersion - ( CabalSpecVersion (..) ) - -import Data.List - ( (\\) ) -import qualified Data.Map as Map -import qualified Data.Set as Set -import System.Directory - ( getCurrentDirectory, getTemporaryDirectory, removeDirectoryRecursive ) -import System.FilePath - ( () ) - -type ReplFlags = [String] - -data EnvFlags = EnvFlags - { envPackages :: [Dependency] - , envIncludeTransitive :: Flag Bool - , envIgnoreProject :: Flag Bool - } - -defaultEnvFlags :: EnvFlags -defaultEnvFlags = EnvFlags - { envPackages = [] - , envIncludeTransitive = toFlag True - , envIgnoreProject = toFlag False - } - -envOptions :: ShowOrParseArgs -> [OptionField EnvFlags] -envOptions _ = - [ option ['b'] ["build-depends"] - "Include additional packages in the environment presented to GHCi." - envPackages (\p flags -> flags { envPackages = p ++ envPackages flags }) - (reqArg "DEPENDENCIES" dependenciesReadE (fmap prettyShow :: [Dependency] -> [String])) - , option [] ["no-transitive-deps"] - "Don't automatically include transitive dependencies of requested packages." - envIncludeTransitive (\p flags -> flags { envIncludeTransitive = p }) - falseArg - , option ['z'] ["ignore-project"] - "Only include explicitly specified packages (and 'base')." - envIgnoreProject (\p flags -> flags { envIgnoreProject = p }) - trueArg - ] - where - dependenciesReadE :: ReadE [Dependency] - dependenciesReadE = - parsecToReadE - ("couldn't parse dependencies: " ++) - (parsecCommaList parsec) - -replCommand :: CommandUI (NixStyleFlags (ReplFlags, EnvFlags)) -replCommand = Client.installCommand { - commandName = "v2-repl", - commandSynopsis = "Open an interactive session for the given component.", - commandUsage = usageAlternatives "v2-repl" [ "[TARGET] [FLAGS]" ], - commandDescription = Just $ \_ -> wrapText $ - "Open an interactive session for a component within the project. The " - ++ "available targets are the same as for the 'v2-build' command: " - ++ "individual components within packages in the project, including " - ++ "libraries, executables, test-suites or benchmarks. Packages can " - ++ "also be specified in which case the library component in the " - ++ "package will be used, or the (first listed) executable in the " - ++ "package if there is no library.\n\n" - - ++ "Dependencies are built or rebuilt as necessary. Additional " - ++ "configuration flags can be specified on the command line and these " - ++ "extend the project configuration from the 'cabal.project', " - ++ "'cabal.project.local' and other files.", - commandNotes = Just $ \pname -> - "Examples, open an interactive session:\n" - ++ " " ++ pname ++ " v2-repl\n" - ++ " for the default component in the package in the current directory\n" - ++ " " ++ pname ++ " v2-repl pkgname\n" - ++ " for the default component in the package named 'pkgname'\n" - ++ " " ++ pname ++ " v2-repl ./pkgfoo\n" - ++ " for the default component in the package in the ./pkgfoo directory\n" - ++ " " ++ pname ++ " v2-repl cname\n" - ++ " for the component named 'cname'\n" - ++ " " ++ pname ++ " v2-repl pkgname:cname\n" - ++ " for the component 'cname' in the package 'pkgname'\n\n" - ++ " " ++ pname ++ " v2-repl --build-depends lens\n" - ++ " add the latest version of the library 'lens' to the default component " - ++ "(or no componentif there is no project present)\n" - ++ " " ++ pname ++ " v2-repl --build-depends \"lens >= 4.15 && < 4.18\"\n" - ++ " add a version (constrained between 4.15 and 4.18) of the library 'lens' " - ++ "to the default component (or no component if there is no project present)\n" - - ++ cmdCommonHelpTextNewBuildBeta, - commandDefaultFlags = defaultNixStyleFlags ([], defaultEnvFlags), - commandOptions = nixStyleOptions $ \showOrParseArgs -> - map (liftOptionL _1) (replOptions showOrParseArgs) ++ - map (liftOptionL _2) (envOptions showOrParseArgs) - } - --- | The @repl@ command is very much like @build@. It brings the install plan --- up to date, selects that part of the plan needed by the given or implicit --- repl target and then executes the plan. --- --- Compared to @build@ the difference is that only one target is allowed --- (given or implicit) and the target type is repl rather than build. The --- general plan execution infrastructure handles both build and repl targets. --- --- For more details on how this works, see the module --- "Distribution.Client.ProjectOrchestration" --- -replAction :: NixStyleFlags (ReplFlags, EnvFlags) -> [String] -> GlobalFlags -> IO () -replAction flags@NixStyleFlags { extraFlags = (replFlags, envFlags), ..} targetStrings globalFlags = do - let - with = withProject cliConfig verbosity targetStrings - without config = withoutProject (config <> cliConfig) verbosity targetStrings - - (baseCtx, targetSelectors, finalizer, replType) <- - withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag with without - - when (buildSettingOnlyDeps (buildSettings baseCtx)) $ - die' verbosity $ "The repl command does not support '--only-dependencies'. " - ++ "You may wish to use 'build --only-dependencies' and then " - ++ "use 'repl'." - - (originalComponent, baseCtx') <- if null (envPackages envFlags) - then return (Nothing, baseCtx) - else - -- Unfortunately, the best way to do this is to let the normal solver - -- help us resolve the targets, but that isn't ideal for performance, - -- especially in the no-project case. - withInstallPlan (lessVerbose verbosity) baseCtx $ \elaboratedPlan _ -> do - -- targets should be non-empty map, but there's no NonEmptyMap yet. - targets <- validatedTargets 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 = fromMaybe (error $ "cannot find " ++ prettyShow unitId) $ packageId <$> InstallPlan.lookup elaboratedPlan unitId - baseCtx' = addDepsToProjectTarget (envPackages envFlags) pkgId baseCtx - - return (Just oci, baseCtx') - - -- Now, we run the solver again with the added packages. While the graph - -- won't actually reflect the addition of transitive dependencies, - -- they're going to be available already and will be offered to the REPL - -- and that's good enough. - -- - -- In addition, to avoid a *third* trip through the solver, we are - -- replicating the second half of 'runProjectPreBuildPhase' by hand - -- here. - (buildCtx, replFlags'') <- withInstallPlan verbosity baseCtx' $ - \elaboratedPlan elaboratedShared' -> do - let ProjectBaseContext{..} = baseCtx' - - -- Recalculate with updated project. - targets <- validatedTargets elaboratedPlan targetSelectors - - let - elaboratedPlan' = pruneInstallPlanToTargets - TargetActionRepl - targets - elaboratedPlan - includeTransitive = fromFlagOrDefault True (envIncludeTransitive envFlags) - - pkgsBuildStatus <- rebuildTargetsDryRun distDirLayout elaboratedShared' - elaboratedPlan' - - let elaboratedPlan'' = improveInstallPlanWithUpToDatePackages - pkgsBuildStatus elaboratedPlan' - debugNoWrap verbosity (InstallPlan.showInstallPlan elaboratedPlan'') - - let - buildCtx = ProjectBuildContext - { elaboratedPlanOriginal = elaboratedPlan - , elaboratedPlanToExecute = elaboratedPlan'' - , elaboratedShared = elaboratedShared' - , pkgsBuildStatus - , targetsMap = targets - } - - ElaboratedSharedConfig { pkgConfigCompiler = compiler } = elaboratedShared' - - -- 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 = mkVersion [7, 6] - - replFlags' = case originalComponent of - Just oci -> generateReplFlags includeTransitive elaboratedPlan' oci - Nothing -> [] - replFlags'' = case replType of - GlobalRepl scriptPath - | Just version <- compilerCompatVersion GHC compiler - , version >= minGhciScriptVersion -> ("-ghci-script" ++ scriptPath) : replFlags' - _ -> replFlags' - - return (buildCtx, replFlags'') - - let buildCtx' = buildCtx - { elaboratedShared = (elaboratedShared buildCtx) - { pkgConfigReplOptions = replFlags ++ replFlags'' } - } - printPlan verbosity baseCtx' buildCtx' - - buildOutcomes <- runProjectBuildPhase verbosity baseCtx' buildCtx' - runProjectPostBuildPhase verbosity baseCtx' buildCtx' buildOutcomes - finalizer - where - verbosity = fromFlagOrDefault normal (configVerbosity configFlags) - ignoreProject = envIgnoreProject envFlags - cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags, not needed here - globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) - - validatedTargets elaboratedPlan targetSelectors = do - -- Interpret the targets on the command line as repl targets - -- (as opposed to say build or haddock targets). - targets <- either (reportTargetProblems verbosity) return - $ resolveTargets - selectPackageTargets - selectComponentTarget - elaboratedPlan - Nothing - targetSelectors - - -- 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) $ - reportTargetProblems verbosity - [multipleTargetsProblem targets] - - return targets - -data OriginalComponentInfo = OriginalComponentInfo - { ociUnitId :: UnitId - , ociOriginalDeps :: [UnitId] - } - deriving (Show) - --- | Tracks what type of GHCi instance we're creating. -data ReplType = ProjectRepl - | GlobalRepl FilePath -- ^ The 'FilePath' argument is path to a GHCi - -- script responsible for changing to the - -- correct directory. Only works on GHC geq - -- 7.6, though. 🙁 - deriving (Show, Eq) - -withProject :: ProjectConfig -> Verbosity -> [String] - -> IO (ProjectBaseContext, [TargetSelector], IO (), ReplType) -withProject cliConfig verbosity targetStrings = do - baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand - - targetSelectors <- either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors (localPackages baseCtx) (Just LibKind) targetStrings - - return (baseCtx, targetSelectors, return (), ProjectRepl) - -withoutProject :: ProjectConfig -> Verbosity -> [String] - -> IO (ProjectBaseContext, [TargetSelector], IO (), ReplType) -withoutProject config verbosity extraArgs = do - unless (null extraArgs) $ - die' verbosity $ "'repl' doesn't take any extra arguments when outside a project: " ++ unwords extraArgs - - globalTmp <- getTemporaryDirectory - tempDir <- createTempDirectory globalTmp "cabal-repl." - - -- We need to create a dummy package that lives in our dummy project. - let - sourcePackage = SourcePackage - { srcpkgPackageId = pkgId - , srcpkgDescription = genericPackageDescription - , srcpkgSource = LocalUnpackedPackage tempDir - , srcpkgDescrOverride = Nothing - } - genericPackageDescription = emptyGenericPackageDescription - & L.packageDescription .~ packageDescription - & L.condLibrary .~ Just (CondNode library [baseDep] []) - packageDescription = emptyPackageDescription - { package = pkgId - , specVersion = CabalSpecV2_2 - , licenseRaw = Left SPDX.NONE - } - library = emptyLibrary { libBuildInfo = buildInfo } - buildInfo = emptyBuildInfo - { targetBuildDepends = [baseDep] - , defaultLanguage = Just Haskell2010 - } - baseDep = Dependency "base" anyVersion mainLibSet - pkgId = fakePackageId - - writeGenericPackageDescription (tempDir "fake-package.cabal") genericPackageDescription - - let ghciScriptPath = tempDir "setcwd.ghci" - cwd <- getCurrentDirectory - writeFile ghciScriptPath (":cd " ++ cwd) - - distDirLayout <- establishDummyDistDirLayout verbosity config tempDir - baseCtx <- - establishDummyProjectBaseContext - verbosity - config - distDirLayout - [SpecificSourcePackage sourcePackage] - OtherCommand - - let - targetSelectors = [TargetPackage TargetExplicitNamed [pkgId] Nothing] - finalizer = handleDoesNotExist () (removeDirectoryRecursive tempDir) - - return (baseCtx, targetSelectors, finalizer, GlobalRepl ghciScriptPath) - -addDepsToProjectTarget :: [Dependency] - -> PackageId - -> ProjectBaseContext - -> ProjectBaseContext -addDepsToProjectTarget deps pkgId ctx = - (\p -> ctx { localPackages = p }) . fmap addDeps . localPackages $ ctx - where - addDeps :: PackageSpecifier UnresolvedSourcePackage - -> PackageSpecifier UnresolvedSourcePackage - addDeps (SpecificSourcePackage pkg) - | packageId pkg /= pkgId = SpecificSourcePackage pkg - | SourcePackage{..} <- pkg = - SpecificSourcePackage $ pkg { srcpkgDescription = - srcpkgDescription & (\f -> L.allCondTrees $ traverseCondTreeC f) - %~ (deps ++) - } - addDeps spec = spec - -generateReplFlags :: Bool -> ElaboratedInstallPlan -> OriginalComponentInfo -> ReplFlags -generateReplFlags includeTransitive elaboratedPlan OriginalComponentInfo{..} = flags - where - exeDeps :: [UnitId] - exeDeps = - foldMap - (InstallPlan.foldPlanPackage (const []) elabOrderExeDependencies) - (InstallPlan.dependencyClosure elaboratedPlan [ociUnitId]) - - deps, deps', trans, trans' :: [UnitId] - flags :: ReplFlags - deps = installedUnitId <$> InstallPlan.directDeps elaboratedPlan ociUnitId - deps' = deps \\ ociOriginalDeps - trans = installedUnitId <$> InstallPlan.dependencyClosure elaboratedPlan deps' - trans' = trans \\ ociOriginalDeps - flags = fmap (("-package-id " ++) . prettyShow) . (\\ exeDeps) - $ if includeTransitive then trans' else deps' - --- | This defines what a 'TargetSelector' means for the @repl@ command. --- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, --- or otherwise classifies the problem. --- --- For repl we select: --- --- * the library if there is only one and it's buildable; or --- --- * the exe if there is only one and it's buildable; or --- --- * any other buildable component. --- --- Fail if there are no buildable lib\/exe components, or if there are --- multiple libs or exes. --- -selectPackageTargets :: TargetSelector - -> [AvailableTarget k] -> Either ReplTargetProblem [k] -selectPackageTargets targetSelector targets - - -- If there is exactly one buildable library then we select that - | [target] <- targetsLibsBuildable - = Right [target] - - -- but fail if there are multiple buildable libraries. - | not (null targetsLibsBuildable) - = Left (matchesMultipleProblem targetSelector targetsLibsBuildable') - - -- If there is exactly one buildable executable then we select that - | [target] <- targetsExesBuildable - = Right [target] - - -- but fail if there are multiple buildable executables. - | not (null targetsExesBuildable) - = Left (matchesMultipleProblem targetSelector targetsExesBuildable') - - -- If there is exactly one other target then we select that - | [target] <- targetsBuildable - = Right [target] - - -- but fail if there are multiple such targets - | not (null targetsBuildable) - = Left (matchesMultipleProblem targetSelector targetsBuildable') - - -- If there are targets but none are buildable then we report those - | not (null targets) - = Left (TargetProblemNoneEnabled targetSelector targets') - - -- If there are no targets at all then we report that - | otherwise - = Left (TargetProblemNoTargets targetSelector) - where - targets' = forgetTargetsDetail targets - (targetsLibsBuildable, - targetsLibsBuildable') = selectBuildableTargets' - . filterTargetsKind LibKind - $ targets - (targetsExesBuildable, - targetsExesBuildable') = selectBuildableTargets' - . filterTargetsKind ExeKind - $ targets - (targetsBuildable, - targetsBuildable') = selectBuildableTargetsWith' - (isRequested targetSelector) targets - - -- When there's a target filter like "pkg:tests" then we do select tests, - -- but if it's just a target like "pkg" then we don't build tests unless - -- they are requested by default (i.e. by using --enable-tests) - isRequested (TargetAllPackages Nothing) TargetNotRequestedByDefault = False - isRequested (TargetPackage _ _ Nothing) TargetNotRequestedByDefault = False - isRequested _ _ = True - - --- | For a 'TargetComponent' 'TargetSelector', check if the component can be --- selected. --- --- For the @repl@ command we just need the basic checks on being buildable etc. --- -selectComponentTarget :: SubComponentTarget - -> AvailableTarget k -> Either ReplTargetProblem k -selectComponentTarget = selectComponentTargetBasic - - -data ReplProblem - = TargetProblemMatchesMultiple TargetSelector [AvailableTarget ()] - - -- | Multiple 'TargetSelector's match multiple targets - | TargetProblemMultipleTargets TargetsMap - deriving (Eq, Show) - --- | The various error conditions that can occur when matching a --- 'TargetSelector' against 'AvailableTarget's for the @repl@ command. --- -type ReplTargetProblem = TargetProblem ReplProblem - -matchesMultipleProblem - :: TargetSelector - -> [AvailableTarget ()] - -> ReplTargetProblem -matchesMultipleProblem targetSelector targetsExesBuildable = - CustomTargetProblem $ TargetProblemMatchesMultiple targetSelector targetsExesBuildable - -multipleTargetsProblem - :: TargetsMap - -> ReplTargetProblem -multipleTargetsProblem = CustomTargetProblem . TargetProblemMultipleTargets - -reportTargetProblems :: Verbosity -> [TargetProblem ReplProblem] -> IO a -reportTargetProblems verbosity = - die' verbosity . unlines . map renderReplTargetProblem - -renderReplTargetProblem :: TargetProblem ReplProblem -> String -renderReplTargetProblem = renderTargetProblem "open a repl for" renderReplProblem - -renderReplProblem :: ReplProblem -> String -renderReplProblem (TargetProblemMatchesMultiple targetSelector targets) = - "Cannot open a repl for multiple components at once. The target '" - ++ showTargetSelector targetSelector ++ "' refers to " - ++ renderTargetSelector targetSelector ++ " which " - ++ (if targetSelectorRefersToPkgs targetSelector then "includes " else "are ") - ++ renderListSemiAnd - [ "the " ++ renderComponentKind Plural ckind ++ " " ++ - renderListCommaAnd - [ maybe (prettyShow pkgname) prettyShow (componentNameString cname) - | t <- ts - , let cname = availableTargetComponentName t - pkgname = packageName (availableTargetPackageId t) - ] - | (ckind, ts) <- sortGroupOn availableTargetComponentKind targets - ] - ++ ".\n\n" ++ explanationSingleComponentLimitation - where - availableTargetComponentKind = componentKind - . availableTargetComponentName - -renderReplProblem (TargetProblemMultipleTargets selectorMap) = - "Cannot open a repl for multiple components at once. The targets " - ++ renderListCommaAnd - [ "'" ++ showTargetSelector ts ++ "'" - | ts <- ordNub (concatMap snd (concat (Map.elems selectorMap))) ] - ++ " refer to different components." - ++ ".\n\n" ++ explanationSingleComponentLimitation - -explanationSingleComponentLimitation :: String -explanationSingleComponentLimitation = - "The reason for this limitation is that current versions of ghci do not " - ++ "support loading multiple components as source. Load just one component " - ++ "and when you make changes to a dependent component then quit and reload." diff --git a/cabal/cabal-install/Distribution/Client/CmdRun.hs b/cabal/cabal-install/Distribution/Client/CmdRun.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/CmdRun.hs +++ /dev/null @@ -1,633 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - --- | cabal-install CLI command: run --- -module Distribution.Client.CmdRun ( - -- * The @run@ CLI and action - runCommand, - runAction, - handleShebang, validScript, - - -- * Internals exposed for testing - matchesMultipleProblem, - noExesProblem, - selectPackageTargets, - selectComponentTarget - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude hiding (toList) - -import Distribution.Client.ProjectOrchestration -import Distribution.Client.CmdErrorMessages - ( renderTargetSelector, showTargetSelector, - renderTargetProblem, - renderTargetProblemNoTargets, plural, targetSelectorPluralPkgs, - targetSelectorFilter, renderListCommaAnd ) -import Distribution.Client.TargetProblem - ( TargetProblem (..) ) - -import Distribution.Client.NixStyleOptions - ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) -import Distribution.Client.Setup - ( GlobalFlags(..), ConfigFlags(..) ) -import Distribution.Client.GlobalFlags - ( defaultGlobalFlags ) -import Distribution.Simple.Flag - ( fromFlagOrDefault ) -import Distribution.Simple.Command - ( CommandUI(..), usageAlternatives ) -import Distribution.Types.ComponentName - ( showComponentName ) -import Distribution.CabalSpecVersion (CabalSpecVersion (..), cabalSpecLatest) -import Distribution.Verbosity - ( normal ) -import Distribution.Simple.Utils - ( wrapText, warn, die', ordNub, info - , createTempDirectory, handleDoesNotExist ) -import Distribution.Client.ProjectConfig - ( ProjectConfig(..), ProjectConfigShared(..) - , withProjectOrGlobalConfig ) -import Distribution.Client.ProjectFlags - ( flagIgnoreProject ) -import Distribution.Client.ProjectPlanning - ( ElaboratedConfiguredPackage(..) - , ElaboratedInstallPlan, binDirectoryFor ) -import Distribution.Client.ProjectPlanning.Types - ( dataDirsEnvironmentForPlan ) -import Distribution.Client.TargetSelector - ( TargetSelectorProblem(..), TargetString(..) ) -import Distribution.Client.InstallPlan - ( toList, foldPlanPackage ) -import Distribution.Types.UnqualComponentName - ( UnqualComponentName, unUnqualComponentName ) -import Distribution.Simple.Program.Run - ( runProgramInvocation, ProgramInvocation(..), - emptyProgramInvocation ) -import Distribution.Types.UnitId - ( UnitId ) - -import Distribution.Client.Types - ( PackageLocation(..), PackageSpecifier(..) ) -import Distribution.FieldGrammar - ( takeFields, parseFieldGrammar ) -import Distribution.PackageDescription.FieldGrammar - ( executableFieldGrammar ) -import Distribution.PackageDescription.PrettyPrint - ( writeGenericPackageDescription ) -import Distribution.Parsec - ( Position(..) ) -import Distribution.Fields - ( ParseResult, parseString, parseFatalFailure, readFields ) -import qualified Distribution.SPDX.License as SPDX -import Distribution.Solver.Types.SourcePackage as SP - ( SourcePackage(..) ) -import Distribution.Types.BuildInfo - ( BuildInfo(..) ) -import Distribution.Types.CondTree - ( CondTree(..) ) -import Distribution.Types.Executable - ( Executable(..) ) -import Distribution.Types.GenericPackageDescription as GPD - ( GenericPackageDescription(..), emptyGenericPackageDescription ) -import Distribution.Types.PackageDescription - ( PackageDescription(..), emptyPackageDescription ) -import Distribution.Types.PackageName.Magic - ( fakePackageId ) -import Language.Haskell.Extension - ( Language(..) ) - -import qualified Data.ByteString.Char8 as BS -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Text.Parsec as P -import System.Directory - ( getTemporaryDirectory, removeDirectoryRecursive, doesFileExist ) -import System.FilePath - ( (), isValid, isPathSeparator, takeExtension ) - - -runCommand :: CommandUI (NixStyleFlags ()) -runCommand = CommandUI - { commandName = "v2-run" - , commandSynopsis = "Run an executable." - , commandUsage = usageAlternatives "v2-run" - [ "[TARGET] [FLAGS] [-- EXECUTABLE_FLAGS]" ] - , commandDescription = Just $ \pname -> wrapText $ - "Runs the specified executable-like component (an executable, a test, " - ++ "or a benchmark), first ensuring it is up to date.\n\n" - - ++ "Any executable-like component in any package in the project can be " - ++ "specified. A package can be specified if contains just one " - ++ "executable-like. The default is to use the package in the current " - ++ "directory if it contains just one executable-like.\n\n" - - ++ "Extra arguments can be passed to the program, but use '--' to " - ++ "separate arguments for the program from arguments for " ++ pname - ++ ". The executable is run in an environment where it can find its " - ++ "data files inplace in the build tree.\n\n" - - ++ "Dependencies are built or rebuilt as necessary. Additional " - ++ "configuration flags can be specified on the command line and these " - ++ "extend the project configuration from the 'cabal.project', " - ++ "'cabal.project.local' and other files." - , commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " v2-run\n" - ++ " Run the executable-like in the package in the current directory\n" - ++ " " ++ pname ++ " v2-run foo-tool\n" - ++ " Run the named executable-like (in any package in the project)\n" - ++ " " ++ pname ++ " v2-run pkgfoo:foo-tool\n" - ++ " Run the executable-like 'foo-tool' in the package 'pkgfoo'\n" - ++ " " ++ pname ++ " v2-run foo -O2 -- dothing --fooflag\n" - ++ " Build with '-O2' and run the program, passing it extra arguments.\n\n" - - ++ cmdCommonHelpTextNewBuildBeta - , commandDefaultFlags = defaultNixStyleFlags () - , commandOptions = nixStyleOptions (const []) - } - --- | The @run@ command runs a specified executable-like component, building it --- first if necessary. The component can be either an executable, a test, --- or a benchmark. This is particularly useful for passing arguments to --- exes/tests/benchs by simply appending them after a @--@. --- --- For more details on how this works, see the module --- "Distribution.Client.ProjectOrchestration" --- -runAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO () -runAction flags@NixStyleFlags {..} targetStrings globalFlags = do - globalTmp <- getTemporaryDirectory - tmpDir <- createTempDirectory globalTmp "cabal-repl." - - let - with = - establishProjectBaseContext verbosity cliConfig OtherCommand - without config = do - distDirLayout <- establishDummyDistDirLayout verbosity (config <> cliConfig) tmpDir - establishDummyProjectBaseContext verbosity (config <> cliConfig) distDirLayout [] OtherCommand - - baseCtx <- withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag with without - - let - scriptOrError script err = do - exists <- doesFileExist script - let pol | takeExtension script == ".lhs" = LiterateHaskell - | otherwise = PlainHaskell - if exists - then BS.readFile script >>= handleScriptCase verbosity pol baseCtx tmpDir - else reportTargetSelectorProblems verbosity err - - (baseCtx', targetSelectors) <- - readTargetSelectors (localPackages baseCtx) (Just ExeKind) (take 1 targetStrings) - >>= \case - Left err@(TargetSelectorNoTargetsInProject:_) - | (script:_) <- targetStrings -> scriptOrError script err - Left err@(TargetSelectorNoSuch t _:_) - | TargetString1 script <- t -> scriptOrError script err - Left err@(TargetSelectorExpected t _ _:_) - | TargetString1 script <- t -> scriptOrError script err - Left err -> reportTargetSelectorProblems verbosity err - Right sels -> return (baseCtx, sels) - - buildCtx <- - runProjectPreBuildPhase verbosity baseCtx' $ \elaboratedPlan -> do - - when (buildSettingOnlyDeps (buildSettings baseCtx')) $ - die' verbosity $ - "The run command does not support '--only-dependencies'. " - ++ "You may wish to use 'build --only-dependencies' and then " - ++ "use 'run'." - - -- Interpret the targets on the command line as build targets - -- (as opposed to say repl or haddock targets). - targets <- either (reportTargetProblems verbosity) return - $ resolveTargets - selectPackageTargets - selectComponentTarget - elaboratedPlan - Nothing - targetSelectors - - -- 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. - -- - -- Note that we discard the target and return the whole 'TargetsMap', - -- so this check will be repeated (and must succeed) after - -- the 'runProjectPreBuildPhase'. Keep it in mind when modifying this. - _ <- singleExeOrElse - (reportTargetProblems - verbosity - [multipleTargetsProblem targets]) - targets - - let elaboratedPlan' = pruneInstallPlanToTargets - TargetActionBuild - targets - elaboratedPlan - return (elaboratedPlan', targets) - - (selectedUnitId, selectedComponent) <- - -- Slight duplication with 'runProjectPreBuildPhase'. - singleExeOrElse - (die' verbosity $ "No or multiple targets given, but the run " - ++ "phase has been reached. This is a bug.") - $ targetsMap buildCtx - - printPlan verbosity baseCtx' buildCtx - - buildOutcomes <- runProjectBuildPhase verbosity baseCtx' buildCtx - runProjectPostBuildPhase verbosity baseCtx' buildCtx buildOutcomes - - - let elaboratedPlan = elaboratedPlanToExecute buildCtx - matchingElaboratedConfiguredPackages = - matchingPackagesByUnitId - selectedUnitId - elaboratedPlan - - let exeName = unUnqualComponentName selectedComponent - - -- In the common case, we expect @matchingElaboratedConfiguredPackages@ - -- to consist of a single element that provides a single way of building - -- an appropriately-named executable. In that case we take that - -- package and continue. - -- - -- However, multiple packages/components could provide that - -- executable, or it's possible we don't find the executable anywhere - -- in the build plan. I suppose in principle it's also possible that - -- a single package provides an executable in two different ways, - -- though that's probably a bug if. Anyway it's a good lint to report - -- an error in all of these cases, even if some seem like they - -- shouldn't happen. - pkg <- case matchingElaboratedConfiguredPackages of - [] -> die' verbosity $ "Unknown executable " - ++ exeName - ++ " in package " - ++ prettyShow selectedUnitId - [elabPkg] -> do - info verbosity $ "Selecting " - ++ prettyShow selectedUnitId - ++ " to supply " ++ exeName - return elabPkg - elabPkgs -> die' verbosity - $ "Multiple matching executables found matching " - ++ exeName - ++ ":\n" - ++ unlines (fmap (\p -> " - in package " ++ prettyShow (elabUnitId p)) elabPkgs) - let exePath = binDirectoryFor (distDirLayout baseCtx) - (elaboratedShared buildCtx) - pkg - exeName - exeName - let args = drop 1 targetStrings - runProgramInvocation - verbosity - emptyProgramInvocation { - progInvokePath = exePath, - progInvokeArgs = args, - progInvokeEnv = dataDirsEnvironmentForPlan - (distDirLayout baseCtx) - elaboratedPlan - } - - handleDoesNotExist () (removeDirectoryRecursive tmpDir) - where - verbosity = fromFlagOrDefault normal (configVerbosity configFlags) - ignoreProject = flagIgnoreProject projectFlags - cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags, not needed here - globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) - --- | Used by the main CLI parser as heuristic to decide whether @cabal@ was --- invoked as a script interpreter, i.e. via --- --- > #! /usr/bin/env cabal --- --- or --- --- > #! /usr/bin/cabal --- --- As the first argument passed to `cabal` will be a filepath to the --- script to be interpreted. --- --- See also 'handleShebang' -validScript :: String -> IO Bool -validScript script - | isValid script && any isPathSeparator script = doesFileExist script - | otherwise = return False - --- | Handle @cabal@ invoked as script interpreter, see also 'validScript' --- --- First argument is the 'FilePath' to the script to be executed; second --- argument is a list of arguments to be passed to the script. -handleShebang :: FilePath -> [String] -> IO () -handleShebang script args = - runAction (commandDefaultFlags runCommand) (script:args) defaultGlobalFlags - -parseScriptBlock :: BS.ByteString -> ParseResult Executable -parseScriptBlock str = - case readFields str of - Right fs -> do - let (fields, _) = takeFields fs - parseFieldGrammar cabalSpecLatest fields (executableFieldGrammar "script") - Left perr -> parseFatalFailure pos (show perr) where - ppos = P.errorPos perr - pos = Position (P.sourceLine ppos) (P.sourceColumn ppos) - -readScriptBlock :: Verbosity -> BS.ByteString -> IO Executable -readScriptBlock verbosity = parseString parseScriptBlock verbosity "script block" - -readScriptBlockFromScript :: Verbosity -> PlainOrLiterate -> BS.ByteString -> IO (Executable, BS.ByteString) -readScriptBlockFromScript verbosity pol str = do - str' <- case extractScriptBlock pol str of - Left e -> die' verbosity $ "Failed extracting script block: " ++ e - Right x -> return x - when (BS.all isSpace str') $ warn verbosity "Empty script block" - (\x -> (x, noShebang)) <$> readScriptBlock verbosity str' - where - noShebang = BS.unlines . filter (not . BS.isPrefixOf "#!") . BS.lines $ str - --- | Extract the first encountered script metadata block started end --- terminated by the tokens --- --- * @{- cabal:@ --- --- * @-}@ --- --- appearing alone on lines (while tolerating trailing whitespace). --- These tokens are not part of the 'Right' result. --- --- In case of missing or unterminated blocks a 'Left'-error is --- returned. -extractScriptBlock :: PlainOrLiterate -> BS.ByteString -> Either String BS.ByteString -extractScriptBlock _pol str = goPre (BS.lines str) - where - isStartMarker = (== startMarker) . stripTrailSpace - isEndMarker = (== endMarker) . stripTrailSpace - - stripTrailSpace = fst . BS.spanEnd isSpace - - -- before start marker - goPre ls = case dropWhile (not . isStartMarker) ls of - [] -> Left $ "`" ++ BS.unpack startMarker ++ "` start marker not found" - (_:ls') -> goBody [] ls' - - goBody _ [] = Left $ "`" ++ BS.unpack endMarker ++ "` end marker not found" - goBody acc (l:ls) - | isEndMarker l = Right $! BS.unlines $ reverse acc - | otherwise = goBody (l:acc) ls - - startMarker, endMarker :: BS.ByteString - startMarker = fromString "{- cabal:" - endMarker = fromString "-}" - -data PlainOrLiterate - = PlainHaskell - | LiterateHaskell - -handleScriptCase - :: Verbosity - -> PlainOrLiterate - -> ProjectBaseContext - -> FilePath - -> BS.ByteString - -> IO (ProjectBaseContext, [TargetSelector]) -handleScriptCase verbosity pol baseCtx tmpDir scriptContents = do - (executable, contents') <- readScriptBlockFromScript verbosity pol scriptContents - - -- We need to create a dummy package that lives in our dummy project. - let - mainName = case pol of - PlainHaskell -> "Main.hs" - LiterateHaskell -> "Main.lhs" - - sourcePackage = SourcePackage - { srcpkgPackageId = pkgId - , srcpkgDescription = genericPackageDescription - , srcpkgSource = LocalUnpackedPackage tmpDir - , srcpkgDescrOverride = Nothing - } - genericPackageDescription = emptyGenericPackageDescription - { GPD.packageDescription = packageDescription - , condExecutables = [("script", CondNode executable' targetBuildDepends [])] - } - executable' = executable - { modulePath = mainName - , buildInfo = binfo - { defaultLanguage = - case defaultLanguage of - just@(Just _) -> just - Nothing -> Just Haskell2010 - } - } - binfo@BuildInfo{..} = buildInfo executable - packageDescription = emptyPackageDescription - { package = pkgId - , specVersion = CabalSpecV2_2 - , licenseRaw = Left SPDX.NONE - } - pkgId = fakePackageId - - writeGenericPackageDescription (tmpDir "fake-package.cabal") genericPackageDescription - BS.writeFile (tmpDir mainName) contents' - - let - baseCtx' = baseCtx - { localPackages = localPackages baseCtx ++ [SpecificSourcePackage sourcePackage] } - targetSelectors = [TargetPackage TargetExplicitNamed [pkgId] Nothing] - - return (baseCtx', targetSelectors) - -singleExeOrElse :: IO (UnitId, UnqualComponentName) -> TargetsMap -> IO (UnitId, UnqualComponentName) -singleExeOrElse action targetsMap = - case Set.toList . distinctTargetComponents $ targetsMap - of [(unitId, CExeName component)] -> return (unitId, component) - [(unitId, CTestName component)] -> return (unitId, component) - [(unitId, CBenchName component)] -> return (unitId, component) - _ -> action - --- | Filter the 'ElaboratedInstallPlan' keeping only the --- 'ElaboratedConfiguredPackage's that match the specified --- 'UnitId'. -matchingPackagesByUnitId :: UnitId - -> ElaboratedInstallPlan - -> [ElaboratedConfiguredPackage] -matchingPackagesByUnitId uid = - catMaybes - . fmap (foldPlanPackage - (const Nothing) - (\x -> if elabUnitId x == uid - then Just x - else Nothing)) - . toList - --- | This defines what a 'TargetSelector' means for the @run@ command. --- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, --- or otherwise classifies the problem. --- --- For the @run@ command we select the exe if there is only one and it's --- buildable. Fail if there are no or multiple buildable exe components. --- -selectPackageTargets :: TargetSelector - -> [AvailableTarget k] -> Either RunTargetProblem [k] -selectPackageTargets targetSelector targets - - -- If there is exactly one buildable executable then we select that - | [target] <- targetsExesBuildable - = Right [target] - - -- but fail if there are multiple buildable executables. - | not (null targetsExesBuildable) - = Left (matchesMultipleProblem targetSelector targetsExesBuildable') - - -- If there are executables but none are buildable then we report those - | not (null targetsExes) - = Left (TargetProblemNoneEnabled targetSelector targetsExes) - - -- If there are no executables but some other targets then we report that - | not (null targets) - = Left (noExesProblem targetSelector) - - -- If there are no targets at all then we report that - | otherwise - = Left (TargetProblemNoTargets targetSelector) - where - -- Targets that can be executed - targetsExecutableLike = - concatMap (\kind -> filterTargetsKind kind targets) - [ExeKind, TestKind, BenchKind] - (targetsExesBuildable, - targetsExesBuildable') = selectBuildableTargets' targetsExecutableLike - - targetsExes = forgetTargetsDetail targetsExecutableLike - - --- | For a 'TargetComponent' 'TargetSelector', check if the component can be --- selected. --- --- For the @run@ command we just need to check it is a executable-like --- (an executable, a test, or a benchmark), in addition --- to the basic checks on being buildable etc. --- -selectComponentTarget :: SubComponentTarget - -> AvailableTarget k -> Either RunTargetProblem k -selectComponentTarget subtarget@WholeComponent t - = case availableTargetComponentName t - of CExeName _ -> component - CTestName _ -> component - CBenchName _ -> component - _ -> Left (componentNotExeProblem pkgid cname) - where pkgid = availableTargetPackageId t - cname = availableTargetComponentName t - component = selectComponentTargetBasic subtarget t - -selectComponentTarget subtarget t - = Left (isSubComponentProblem (availableTargetPackageId t) - (availableTargetComponentName t) - subtarget) - --- | The various error conditions that can occur when matching a --- 'TargetSelector' against 'AvailableTarget's for the @run@ command. --- -data RunProblem = - -- | The 'TargetSelector' matches targets but no executables - TargetProblemNoExes TargetSelector - - -- | A single 'TargetSelector' matches multiple targets - | TargetProblemMatchesMultiple TargetSelector [AvailableTarget ()] - - -- | Multiple 'TargetSelector's match multiple targets - | TargetProblemMultipleTargets TargetsMap - - -- | 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 - | TargetProblemIsSubComponent PackageId ComponentName SubComponentTarget - deriving (Eq, Show) - -type RunTargetProblem = TargetProblem RunProblem - -noExesProblem :: TargetSelector -> RunTargetProblem -noExesProblem = CustomTargetProblem . TargetProblemNoExes - -matchesMultipleProblem :: TargetSelector -> [AvailableTarget ()] -> RunTargetProblem -matchesMultipleProblem selector targets = CustomTargetProblem $ - TargetProblemMatchesMultiple selector targets - -multipleTargetsProblem :: TargetsMap -> TargetProblem RunProblem -multipleTargetsProblem = CustomTargetProblem . TargetProblemMultipleTargets - -componentNotExeProblem :: PackageId -> ComponentName -> TargetProblem RunProblem -componentNotExeProblem pkgid name = CustomTargetProblem $ - TargetProblemComponentNotExe pkgid name - -isSubComponentProblem - :: PackageId - -> ComponentName - -> SubComponentTarget - -> TargetProblem RunProblem -isSubComponentProblem pkgid name subcomponent = CustomTargetProblem $ - TargetProblemIsSubComponent pkgid name subcomponent - -reportTargetProblems :: Verbosity -> [RunTargetProblem] -> IO a -reportTargetProblems verbosity = - die' verbosity . unlines . map renderRunTargetProblem - -renderRunTargetProblem :: RunTargetProblem -> String -renderRunTargetProblem (TargetProblemNoTargets targetSelector) = - case targetSelectorFilter targetSelector of - Just kind | kind /= ExeKind - -> "The run command is for running executables, but the target '" - ++ showTargetSelector targetSelector ++ "' refers to " - ++ renderTargetSelector targetSelector ++ "." - - _ -> renderTargetProblemNoTargets "run" targetSelector -renderRunTargetProblem problem = - renderTargetProblem "run" renderRunProblem problem - -renderRunProblem :: RunProblem -> String -renderRunProblem (TargetProblemMatchesMultiple targetSelector targets) = - "The run command is for running a single executable at once. The target '" - ++ showTargetSelector targetSelector ++ "' refers to " - ++ renderTargetSelector targetSelector ++ " which includes " - ++ renderListCommaAnd ( ("the "++) <$> - showComponentName <$> - availableTargetComponentName <$> - foldMap - (\kind -> filterTargetsKind kind targets) - [ExeKind, TestKind, BenchKind] ) - ++ "." - -renderRunProblem (TargetProblemMultipleTargets selectorMap) = - "The run command is for running a single executable at once. The targets " - ++ renderListCommaAnd [ "'" ++ showTargetSelector ts ++ "'" - | ts <- ordNub (concatMap snd (concat (Map.elems selectorMap))) ] - ++ " refer to different executables." - -renderRunProblem (TargetProblemComponentNotExe pkgid cname) = - "The run command is for running executables, but the target '" - ++ showTargetSelector targetSelector ++ "' refers to " - ++ renderTargetSelector targetSelector ++ " from the package " - ++ prettyShow pkgid ++ "." - where - targetSelector = TargetComponent pkgid cname WholeComponent - -renderRunProblem (TargetProblemIsSubComponent pkgid cname subtarget) = - "The run command can only run an executable as a whole, " - ++ "not files or modules within them, but the target '" - ++ showTargetSelector targetSelector ++ "' refers to " - ++ renderTargetSelector targetSelector ++ "." - where - targetSelector = TargetComponent pkgid cname subtarget - -renderRunProblem (TargetProblemNoExes targetSelector) = - "Cannot run the target '" ++ showTargetSelector targetSelector - ++ "' which refers to " ++ renderTargetSelector targetSelector - ++ " because " - ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do" - ++ " not contain any executables." diff --git a/cabal/cabal-install/Distribution/Client/CmdSdist.hs b/cabal/cabal-install/Distribution/Client/CmdSdist.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/CmdSdist.hs +++ /dev/null @@ -1,302 +0,0 @@ -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} -module Distribution.Client.CmdSdist - ( sdistCommand, sdistAction, packageToSdist - , OutputFormat(..)) where - -import Prelude () -import Distribution.Client.Compat.Prelude - -import Distribution.Client.CmdErrorMessages - ( Plural(..), renderComponentKind ) -import Distribution.Client.ProjectOrchestration - ( ProjectBaseContext(..), CurrentCommand(..), establishProjectBaseContext, establishProjectBaseContextWithRoot) -import Distribution.Client.NixStyleOptions - ( NixStyleFlags (..), defaultNixStyleFlags ) -import Distribution.Client.TargetSelector - ( TargetSelector(..), ComponentKind - , readTargetSelectors, reportTargetSelectorProblems ) -import Distribution.Client.Setup - ( GlobalFlags(..) ) -import Distribution.Solver.Types.SourcePackage - ( SourcePackage(..) ) -import Distribution.Client.Types - ( PackageSpecifier(..), PackageLocation(..), UnresolvedSourcePackage ) -import Distribution.Client.DistDirLayout - ( DistDirLayout(..), ProjectRoot (..) ) -import Distribution.Client.ProjectConfig - ( ProjectConfig, withProjectOrGlobalConfig, commandLineFlagsToProjectConfig, projectConfigConfigFile, projectConfigShared ) -import Distribution.Client.ProjectFlags - ( ProjectFlags (..), defaultProjectFlags, projectFlagsOptions ) - -import Distribution.Compat.Lens - ( _1, _2 ) -import Distribution.Package - ( Package(packageId) ) -import Distribution.PackageDescription.Configuration - ( flattenPackageDescription ) -import Distribution.ReadE - ( succeedReadE ) -import Distribution.Simple.Command - ( CommandUI(..), OptionField, option, reqArg, liftOptionL, ShowOrParseArgs ) -import Distribution.Simple.PreProcess - ( knownSuffixHandlers ) -import Distribution.Simple.Setup - ( Flag(..), toFlag, fromFlagOrDefault, flagToList, flagToMaybe - , optionVerbosity, optionDistPref, trueArg, configVerbosity, configDistPref - ) -import Distribution.Simple.SrcDist - ( listPackageSources ) -import Distribution.Client.SrcDist - ( packageDirToSdist ) -import Distribution.Simple.Utils - ( die', notice, withOutputMarker, wrapText ) -import Distribution.Types.ComponentName - ( ComponentName, showComponentName ) -import Distribution.Types.PackageName - ( PackageName, unPackageName ) -import Distribution.Verbosity - ( normal ) - -import qualified Data.ByteString.Lazy.Char8 as BSL -import System.Directory - ( getCurrentDirectory - , createDirectoryIfMissing, makeAbsolute - ) -import System.FilePath - ( (), (<.>), makeRelative, normalise ) - -------------------------------------------------------------------------------- --- Command -------------------------------------------------------------------------------- - -sdistCommand :: CommandUI (ProjectFlags, SdistFlags) -sdistCommand = CommandUI - { commandName = "v2-sdist" - , commandSynopsis = "Generate a source distribution file (.tar.gz)." - , commandUsage = \pname -> - "Usage: " ++ pname ++ " v2-sdist [FLAGS] [PACKAGES]\n" - , commandDescription = Just $ \_ -> wrapText - "Generates tarballs of project packages suitable for upload to Hackage." - , commandNotes = Nothing - , commandDefaultFlags = (defaultProjectFlags, defaultSdistFlags) - , commandOptions = \showOrParseArgs -> - map (liftOptionL _1) (projectFlagsOptions showOrParseArgs) ++ - map (liftOptionL _2) (sdistOptions showOrParseArgs) - } - -------------------------------------------------------------------------------- --- Flags -------------------------------------------------------------------------------- - -data SdistFlags = SdistFlags - { sdistVerbosity :: Flag Verbosity - , sdistDistDir :: Flag FilePath - , sdistListSources :: Flag Bool - , sdistNulSeparated :: Flag Bool - , sdistOutputPath :: Flag FilePath - } - -defaultSdistFlags :: SdistFlags -defaultSdistFlags = SdistFlags - { sdistVerbosity = toFlag normal - , sdistDistDir = mempty - , sdistListSources = toFlag False - , sdistNulSeparated = toFlag False - , sdistOutputPath = mempty - } - -sdistOptions :: ShowOrParseArgs -> [OptionField SdistFlags] -sdistOptions showOrParseArgs = - [ optionVerbosity - sdistVerbosity (\v flags -> flags { sdistVerbosity = v }) - , optionDistPref - sdistDistDir (\dd flags -> flags { sdistDistDir = dd }) - showOrParseArgs - , option ['l'] ["list-only"] - "Just list the sources, do not make a tarball" - sdistListSources (\v flags -> flags { sdistListSources = v }) - trueArg - , option [] ["null-sep"] - "Separate the source files with NUL bytes rather than newlines." - sdistNulSeparated (\v flags -> flags { sdistNulSeparated = v }) - trueArg - , option ['o'] ["output-directory", "outputdir"] - "Choose the output directory of this command. '-' sends all output to stdout" - sdistOutputPath (\o flags -> flags { sdistOutputPath = o }) - (reqArg "PATH" (succeedReadE Flag) flagToList) - ] - -------------------------------------------------------------------------------- --- Action -------------------------------------------------------------------------------- - -sdistAction :: (ProjectFlags, SdistFlags) -> [String] -> GlobalFlags -> IO () -sdistAction (ProjectFlags{..}, SdistFlags{..}) targetStrings globalFlags = do - (baseCtx, distDirLayout) <- withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag withProject withoutProject - - let localPkgs = localPackages baseCtx - - targetSelectors <- either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors localPkgs Nothing targetStrings - - -- elaborate path, create target directory - mOutputPath' <- case mOutputPath of - Just "-" -> return (Just "-") - Just path -> do - abspath <- makeAbsolute path - createDirectoryIfMissing True abspath - return (Just abspath) - Nothing -> do - createDirectoryIfMissing True (distSdistDirectory distDirLayout) - return Nothing - - let format :: OutputFormat - format = - if | listSources, nulSeparated -> SourceList '\0' - | listSources -> SourceList '\n' - | otherwise -> TarGzArchive - - ext = case format of - SourceList _ -> "list" - TarGzArchive -> "tar.gz" - - outputPath pkg = case mOutputPath' of - Just path - | path == "-" -> "-" - | otherwise -> path prettyShow (packageId pkg) <.> ext - Nothing - | listSources -> "-" - | otherwise -> distSdistFile distDirLayout (packageId pkg) - - - case reifyTargetSelectors localPkgs targetSelectors of - Left errs -> die' verbosity . unlines . fmap renderTargetProblem $ errs - Right pkgs - | length pkgs > 1, not listSources, Just "-" <- mOutputPath' -> - die' verbosity "Can't write multiple tarballs to standard output!" - | otherwise -> - traverse_ (\pkg -> packageToSdist verbosity (distProjectRootDirectory distDirLayout) format (outputPath pkg) pkg) pkgs - where - verbosity = fromFlagOrDefault normal sdistVerbosity - listSources = fromFlagOrDefault False sdistListSources - nulSeparated = fromFlagOrDefault False sdistNulSeparated - mOutputPath = flagToMaybe sdistOutputPath - ignoreProject = flagIgnoreProject - - prjConfig :: ProjectConfig - prjConfig = commandLineFlagsToProjectConfig - globalFlags - (defaultNixStyleFlags ()) - { configFlags = (configFlags $ defaultNixStyleFlags ()) - { configVerbosity = sdistVerbosity - , configDistPref = sdistDistDir - } - } - mempty - - globalConfigFlag = projectConfigConfigFile (projectConfigShared prjConfig) - - withProject :: IO (ProjectBaseContext, DistDirLayout) - withProject = do - baseCtx <- establishProjectBaseContext verbosity prjConfig OtherCommand - return (baseCtx, distDirLayout baseCtx) - - withoutProject :: ProjectConfig -> IO (ProjectBaseContext, DistDirLayout) - withoutProject config = do - cwd <- getCurrentDirectory - baseCtx <- establishProjectBaseContextWithRoot verbosity (config <> prjConfig) (ProjectRootImplicit cwd) OtherCommand - return (baseCtx, distDirLayout baseCtx) - -data OutputFormat = SourceList Char - | TarGzArchive - deriving (Show, Eq) - -packageToSdist :: Verbosity -> FilePath -> OutputFormat -> FilePath -> UnresolvedSourcePackage -> IO () -packageToSdist verbosity projectRootDir format outputFile pkg = do - let death = die' verbosity ("The impossible happened: a local package isn't local" <> (show pkg)) - dir0 <- case srcpkgSource pkg of - LocalUnpackedPackage path -> pure (Right path) - RemoteSourceRepoPackage _ (Just path) -> pure (Right path) - RemoteSourceRepoPackage {} -> death - LocalTarballPackage tgz -> pure (Left tgz) - RemoteTarballPackage _ (Just tgz) -> pure (Left tgz) - RemoteTarballPackage {} -> death - RepoTarballPackage {} -> death - - let -- Write String to stdout or file, using the default TextEncoding. - write str - | outputFile == "-" = putStr (withOutputMarker verbosity str) - | otherwise = do - writeFile outputFile str - notice verbosity $ "Wrote source list to " ++ outputFile ++ "\n" - -- Write raw ByteString to stdout or file as it is, without encoding. - writeLBS lbs - | outputFile == "-" = BSL.putStr lbs - | otherwise = do - BSL.writeFile outputFile lbs - notice verbosity $ "Wrote tarball sdist to " ++ outputFile ++ "\n" - - case dir0 of - Left tgz -> do - case format of - TarGzArchive -> do - writeLBS =<< BSL.readFile tgz - _ -> die' verbosity ("cannot convert tarball package to " ++ show format) - - Right dir -> case format of - SourceList nulSep -> do - files' <- listPackageSources verbosity dir (flattenPackageDescription $ srcpkgDescription pkg) knownSuffixHandlers - let files = nub $ sort $ map normalise files' - let prefix = makeRelative projectRootDir dir - write $ concat [prefix i ++ [nulSep] | i <- files] - - TarGzArchive -> do - packageDirToSdist verbosity (srcpkgDescription pkg) dir >>= writeLBS - --- - -reifyTargetSelectors :: [PackageSpecifier UnresolvedSourcePackage] -> [TargetSelector] -> Either [TargetProblem] [UnresolvedSourcePackage] -reifyTargetSelectors pkgs sels = - case partitionEithers (foldMap go sels) of - ([], sels') -> Right sels' - (errs, _) -> Left errs - where - flatten (SpecificSourcePackage pkg@SourcePackage{}) = pkg - flatten _ = error "The impossible happened: how do we not know about a local package?" - pkgs' = fmap flatten pkgs - - getPkg pid = case find ((== pid) . packageId) pkgs' of - Just pkg -> Right pkg - Nothing -> error "The impossible happened: we have a reference to a local package that isn't in localPackages." - - go :: TargetSelector -> [Either TargetProblem UnresolvedSourcePackage] - go (TargetPackage _ pids Nothing) = fmap getPkg pids - go (TargetAllPackages Nothing) = Right <$> pkgs' - - go (TargetPackage _ _ (Just kind)) = [Left (AllComponentsOnly kind)] - go (TargetAllPackages (Just kind)) = [Left (AllComponentsOnly kind)] - - go (TargetPackageNamed pname _) = [Left (NonlocalPackageNotAllowed pname)] - go (TargetComponentUnknown pname _ _) = [Left (NonlocalPackageNotAllowed pname)] - - go (TargetComponent _ cname _) = [Left (ComponentsNotAllowed cname)] - -data TargetProblem = AllComponentsOnly ComponentKind - | NonlocalPackageNotAllowed PackageName - | ComponentsNotAllowed ComponentName - -renderTargetProblem :: TargetProblem -> String -renderTargetProblem (AllComponentsOnly kind) = - "It is not possible to package only the " ++ renderComponentKind Plural kind ++ " from a package " - ++ "for distribution. Only entire packages may be packaged for distribution." -renderTargetProblem (ComponentsNotAllowed cname) = - "The component " ++ showComponentName cname ++ " cannot be packaged for distribution on its own. " - ++ "Only entire packages may be packaged for distribution." -renderTargetProblem (NonlocalPackageNotAllowed pname) = - "The package " ++ unPackageName pname ++ " cannot be packaged for distribution, because it is not " - ++ "local to this project." diff --git a/cabal/cabal-install/Distribution/Client/CmdTest.hs b/cabal/cabal-install/Distribution/Client/CmdTest.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/CmdTest.hs +++ /dev/null @@ -1,285 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} - --- | cabal-install CLI command: test --- -module Distribution.Client.CmdTest ( - -- * The @test@ CLI and action - testCommand, - testAction, - - -- * Internals exposed for testing - isSubComponentProblem, - notTestProblem, - noTestsProblem, - selectPackageTargets, - selectComponentTarget - ) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Client.ProjectOrchestration -import Distribution.Client.CmdErrorMessages - ( renderTargetSelector, showTargetSelector, targetSelectorFilter, plural, - renderTargetProblem, - renderTargetProblemNoTargets, targetSelectorPluralPkgs ) -import Distribution.Client.TargetProblem - ( TargetProblem (..) ) -import Distribution.Client.NixStyleOptions - ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) -import Distribution.Client.Setup - ( GlobalFlags(..), ConfigFlags(..) ) -import Distribution.Simple.Setup - ( TestFlags(..), fromFlagOrDefault ) -import Distribution.Simple.Command - ( CommandUI(..), usageAlternatives ) -import Distribution.Simple.Flag - ( Flag(..) ) -import Distribution.Verbosity - ( normal ) -import Distribution.Simple.Utils - ( notice, wrapText, die' ) - -import qualified System.Exit (exitSuccess) - - -testCommand :: CommandUI (NixStyleFlags ()) -testCommand = CommandUI - { commandName = "v2-test" - , commandSynopsis = "Run test-suites" - , commandUsage = usageAlternatives "v2-test" [ "[TARGETS] [FLAGS]" ] - , commandDescription = Just $ \_ -> wrapText $ - "Runs the specified test-suites, first ensuring they are up to " - ++ "date.\n\n" - - ++ "Any test-suite in any package in the project can be specified. " - ++ "A package can be specified in which case all the test-suites in the " - ++ "package are run. The default is to run all the test-suites in the " - ++ "package in the current directory.\n\n" - - ++ "Dependencies are built or rebuilt as necessary. Additional " - ++ "configuration flags can be specified on the command line and these " - ++ "extend the project configuration from the 'cabal.project', " - ++ "'cabal.project.local' and other files.\n\n" - - ++ "To pass command-line arguments to a test suite, see the " - ++ "v2-run command." - , commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " v2-test\n" - ++ " Run all the test-suites in the package in the current directory\n" - ++ " " ++ pname ++ " v2-test pkgname\n" - ++ " Run all the test-suites in the package named pkgname\n" - ++ " " ++ pname ++ " v2-test cname\n" - ++ " Run the test-suite named cname\n" - ++ " " ++ pname ++ " v2-test cname --enable-coverage\n" - ++ " Run the test-suite built with code coverage (including local libs used)\n\n" - - ++ cmdCommonHelpTextNewBuildBeta - - , commandDefaultFlags = defaultNixStyleFlags () - , commandOptions = nixStyleOptions (const []) - } - - - --- | The @test@ command is very much like @build@. It brings the install plan --- up to date, selects that part of the plan needed by the given or implicit --- test target(s) and then executes the plan. --- --- Compared to @build@ the difference is that there's also test targets --- which are ephemeral. --- --- For more details on how this works, see the module --- "Distribution.Client.ProjectOrchestration" --- -testAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO () -testAction flags@NixStyleFlags {..} targetStrings globalFlags = do - - baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand - - targetSelectors <- either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors (localPackages baseCtx) (Just TestKind) targetStrings - - buildCtx <- - runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do - - when (buildSettingOnlyDeps (buildSettings baseCtx)) $ - die' verbosity $ - "The test command does not support '--only-dependencies'. " - ++ "You may wish to use 'build --only-dependencies' and then " - ++ "use 'test'." - - -- Interpret the targets on the command line as test targets - -- (as opposed to say build or haddock targets). - targets <- either (reportTargetProblems verbosity failWhenNoTestSuites) return - $ resolveTargets - selectPackageTargets - selectComponentTarget - elaboratedPlan - Nothing - targetSelectors - - let elaboratedPlan' = pruneInstallPlanToTargets - TargetActionTest - targets - elaboratedPlan - return (elaboratedPlan', targets) - - printPlan verbosity baseCtx buildCtx - - buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx - runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes - where - failWhenNoTestSuites = testFailWhenNoTestSuites testFlags - verbosity = fromFlagOrDefault normal (configVerbosity configFlags) - cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags - --- | This defines what a 'TargetSelector' means for the @test@ command. --- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, --- or otherwise classifies the problem. --- --- For the @test@ command we select all buildable test-suites, --- or fail if there are no test-suites or no buildable test-suites. --- -selectPackageTargets :: TargetSelector - -> [AvailableTarget k] -> Either TestTargetProblem [k] -selectPackageTargets targetSelector targets - - -- If there are any buildable test-suite targets then we select those - | not (null targetsTestsBuildable) - = Right targetsTestsBuildable - - -- If there are test-suites but none are buildable then we report those - | not (null targetsTests) - = Left (TargetProblemNoneEnabled targetSelector targetsTests) - - -- If there are no test-suite but some other targets then we report that - | not (null targets) - = Left (noTestsProblem targetSelector) - - -- If there are no targets at all then we report that - | otherwise - = Left (TargetProblemNoTargets targetSelector) - where - targetsTestsBuildable = selectBuildableTargets - . filterTargetsKind TestKind - $ targets - - targetsTests = forgetTargetsDetail - . filterTargetsKind TestKind - $ targets - - --- | For a 'TargetComponent' 'TargetSelector', check if the component can be --- selected. --- --- For the @test@ command we just need to check it is a test-suite, in addition --- to the basic checks on being buildable etc. --- -selectComponentTarget :: SubComponentTarget - -> AvailableTarget k -> Either TestTargetProblem k -selectComponentTarget subtarget@WholeComponent t - | CTestName _ <- availableTargetComponentName t - = either Left return $ - selectComponentTargetBasic subtarget t - | otherwise - = Left (notTestProblem - (availableTargetPackageId t) - (availableTargetComponentName t)) - -selectComponentTarget subtarget t - = Left (isSubComponentProblem - (availableTargetPackageId t) - (availableTargetComponentName t) - subtarget) - --- | The various error conditions that can occur when matching a --- 'TargetSelector' against 'AvailableTarget's for the @test@ command. --- -data TestProblem = - -- | The 'TargetSelector' matches targets but no test-suites - TargetProblemNoTests TargetSelector - - -- | The 'TargetSelector' refers to a component that is not a test-suite - | TargetProblemComponentNotTest PackageId ComponentName - - -- | Asking to test an individual file or module is not supported - | TargetProblemIsSubComponent PackageId ComponentName SubComponentTarget - deriving (Eq, Show) - - -type TestTargetProblem = TargetProblem TestProblem - - -noTestsProblem :: TargetSelector -> TargetProblem TestProblem -noTestsProblem = CustomTargetProblem . TargetProblemNoTests - -notTestProblem :: PackageId -> ComponentName -> TargetProblem TestProblem -notTestProblem pkgid name = CustomTargetProblem $ TargetProblemComponentNotTest pkgid name - -isSubComponentProblem - :: PackageId - -> ComponentName - -> SubComponentTarget - -> TargetProblem TestProblem -isSubComponentProblem pkgid name subcomponent = CustomTargetProblem $ - TargetProblemIsSubComponent pkgid name subcomponent - -reportTargetProblems :: Verbosity -> Flag Bool -> [TestTargetProblem] -> IO a -reportTargetProblems verbosity failWhenNoTestSuites problems = - case (failWhenNoTestSuites, problems) of - (Flag True, [CustomTargetProblem (TargetProblemNoTests _)]) -> - die' verbosity problemsMessage - (_, [CustomTargetProblem (TargetProblemNoTests selector)]) -> do - notice verbosity (renderAllowedNoTestsProblem selector) - System.Exit.exitSuccess - (_, _) -> die' verbosity problemsMessage - where - problemsMessage = unlines . map renderTestTargetProblem $ problems - --- | Unless @--test-fail-when-no-test-suites@ flag is passed, we don't --- @die@ when the target problem is 'TargetProblemNoTests'. --- Instead, we display a notice saying that no tests have run and --- indicate how this behaviour was enabled. -renderAllowedNoTestsProblem :: TargetSelector -> String -renderAllowedNoTestsProblem selector = - "No tests to run for " ++ renderTargetSelector selector - -renderTestTargetProblem :: TestTargetProblem -> String -renderTestTargetProblem (TargetProblemNoTargets targetSelector) = - case targetSelectorFilter targetSelector of - Just kind | kind /= TestKind - -> "The test command is for running test suites, but the target '" - ++ showTargetSelector targetSelector ++ "' refers to " - ++ renderTargetSelector targetSelector ++ "." - ++ "\n" ++ show targetSelector - - _ -> renderTargetProblemNoTargets "test" targetSelector -renderTestTargetProblem problem = - renderTargetProblem "test" renderTestProblem problem - - -renderTestProblem :: TestProblem -> String -renderTestProblem (TargetProblemNoTests targetSelector) = - "Cannot run tests for the target '" ++ showTargetSelector targetSelector - ++ "' which refers to " ++ renderTargetSelector targetSelector - ++ " because " - ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do" - ++ " not contain any test suites." - -renderTestProblem (TargetProblemComponentNotTest pkgid cname) = - "The test command is for running test suites, but the target '" - ++ showTargetSelector targetSelector ++ "' refers to " - ++ renderTargetSelector targetSelector ++ " from the package " - ++ prettyShow pkgid ++ "." - where - targetSelector = TargetComponent pkgid cname WholeComponent - -renderTestProblem (TargetProblemIsSubComponent pkgid cname subtarget) = - "The test command can only run test suites as a whole, " - ++ "not files or modules within them, but the target '" - ++ showTargetSelector targetSelector ++ "' refers to " - ++ renderTargetSelector targetSelector ++ "." - where - targetSelector = TargetComponent pkgid cname subtarget diff --git a/cabal/cabal-install/Distribution/Client/CmdUpdate.hs b/cabal/cabal-install/Distribution/Client/CmdUpdate.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/CmdUpdate.hs +++ /dev/null @@ -1,231 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} - --- | cabal-install CLI command: update --- -module Distribution.Client.CmdUpdate ( - updateCommand, - updateAction, - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude - -import Distribution.Client.NixStyleOptions - ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) -import Distribution.Client.Compat.Directory - ( setModificationTime ) -import Distribution.Client.ProjectOrchestration -import Distribution.Client.ProjectConfig - ( ProjectConfig(..) - , ProjectConfigShared(projectConfigConfigFile) - , projectConfigWithSolverRepoContext - , withProjectOrGlobalConfig ) -import Distribution.Client.ProjectFlags - ( ProjectFlags (..) ) -import Distribution.Client.Types - ( Repo(..), RepoName (..), unRepoName, RemoteRepo(..), isRepoRemote ) -import Distribution.Client.HttpUtils - ( DownloadResult(..) ) -import Distribution.Client.FetchUtils - ( downloadIndex ) -import Distribution.Client.JobControl - ( newParallelJobControl, spawnJob, collectJob ) -import Distribution.Client.Setup - ( GlobalFlags, ConfigFlags(..) - , UpdateFlags, defaultUpdateFlags - , RepoContext(..) ) -import Distribution.Simple.Flag - ( fromFlagOrDefault ) -import Distribution.Simple.Utils - ( die', notice, wrapText, writeFileAtomic, noticeNoWrap ) -import Distribution.Verbosity - ( normal, lessVerbose ) -import Distribution.Client.IndexUtils.Timestamp -import Distribution.Client.IndexUtils.IndexState -import Distribution.Client.IndexUtils - ( updateRepoIndexCache, Index(..), writeIndexTimestamp - , currentIndexTimestamp, indexBaseName ) - -import qualified Data.Maybe as Unsafe (fromJust) -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - -import qualified Data.ByteString.Lazy as BS -import Distribution.Client.GZipUtils (maybeDecompress) -import System.FilePath ((<.>), dropExtension) -import Data.Time (getCurrentTime) -import Distribution.Simple.Command - ( CommandUI(..), usageAlternatives ) - -import qualified Hackage.Security.Client as Sec - -updateCommand :: CommandUI (NixStyleFlags ()) -updateCommand = CommandUI - { commandName = "v2-update" - , commandSynopsis = "Updates list of known packages." - , commandUsage = usageAlternatives "v2-update" [ "[FLAGS] [REPOS]" ] - , commandDescription = Just $ \_ -> wrapText $ - "For all known remote repositories, download the package list." - , commandNotes = Just $ \pname -> - "REPO has the format [,] where index-state follows\n" - ++ "the same format and syntax that is supported by the --index-state flag.\n\n" - ++ "Examples:\n" - ++ " " ++ pname ++ " v2-update\n" - ++ " Download the package list for all known remote repositories.\n\n" - ++ " " ++ pname ++ " v2-update hackage.haskell.org,@1474732068\n" - ++ " " ++ pname ++ " v2-update hackage.haskell.org,2016-09-24T17:47:48Z\n" - ++ " " ++ pname ++ " v2-update hackage.haskell.org,HEAD\n" - ++ " " ++ pname ++ " v2-update hackage.haskell.org\n" - ++ " Download hackage.haskell.org at a specific index state.\n\n" - ++ " " ++ pname ++ " new update hackage.haskell.org head.hackage\n" - ++ " Download hackage.haskell.org and head.hackage\n" - ++ " head.hackage must be a known repo-id. E.g. from\n" - ++ " your cabal.project(.local) file.\n\n" - ++ "Note: this command is part of the new project-based system (aka " - ++ "nix-style\nlocal builds). These features are currently in beta. " - ++ "Please see\n" - ++ "http://cabal.readthedocs.io/en/latest/nix-local-build-overview.html " - ++ "for\ndetails and advice on what you can expect to work. If you " - ++ "encounter problems\nplease file issues at " - ++ "https://github.com/haskell/cabal/issues and if you\nhave any time " - ++ "to get involved and help with testing, fixing bugs etc then\nthat " - ++ "is very much appreciated.\n" - -- TODO: Add ProjectFlags to NixStyleFlags, - -- so project-file won't be ambiguous - , commandOptions = nixStyleOptions $ const [] - , commandDefaultFlags = defaultNixStyleFlags () - } - -data UpdateRequest = UpdateRequest - { _updateRequestRepoName :: RepoName - , _updateRequestRepoState :: RepoIndexState - } deriving (Show) - -instance Pretty UpdateRequest where - pretty (UpdateRequest n s) = pretty n <<>> Disp.comma <<>> pretty s - -instance Parsec UpdateRequest where - parsec = do - name <- parsec - state <- P.char ',' *> parsec <|> pure IndexStateHead - return (UpdateRequest name state) - -updateAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO () -updateAction flags@NixStyleFlags {..} extraArgs globalFlags = do - let ignoreProject = flagIgnoreProject projectFlags - - projectConfig <- withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag - (projectConfig <$> establishProjectBaseContext verbosity cliConfig OtherCommand) - (\globalConfig -> return $ globalConfig <> cliConfig) - - projectConfigWithSolverRepoContext verbosity - (projectConfigShared projectConfig) (projectConfigBuildOnly projectConfig) - $ \repoCtxt -> do - let repos = filter isRepoRemote $ repoContextRepos repoCtxt - repoName = remoteRepoName . repoRemote - parseArg :: String -> IO UpdateRequest - parseArg s = case simpleParsec s of - Just r -> return r - Nothing -> die' verbosity $ - "'v2-update' unable to parse repo: \"" ++ s ++ "\"" - updateRepoRequests <- traverse parseArg extraArgs - - unless (null updateRepoRequests) $ do - let remoteRepoNames = map repoName repos - unknownRepos = [r | (UpdateRequest r _) <- updateRepoRequests - , not (r `elem` remoteRepoNames)] - unless (null unknownRepos) $ - die' verbosity $ "'v2-update' repo(s): \"" - ++ intercalate "\", \"" (map unRepoName unknownRepos) - ++ "\" can not be found in known remote repo(s): " - ++ intercalate ", " (map unRepoName remoteRepoNames) - - let reposToUpdate :: [(Repo, RepoIndexState)] - reposToUpdate = case updateRepoRequests of - -- If we are not given any specific repository, update all - -- repositories to HEAD. - [] -> map (,IndexStateHead) repos - updateRequests -> let repoMap = [(repoName r, r) | r <- repos] - lookup' k = Unsafe.fromJust (lookup k repoMap) - in [ (lookup' name, state) - | (UpdateRequest name state) <- updateRequests ] - - case reposToUpdate of - [] -> return () - [(remoteRepo, _)] -> - notice verbosity $ "Downloading the latest package list from " - ++ unRepoName (repoName remoteRepo) - _ -> notice verbosity . unlines - $ "Downloading the latest package lists from: " - : map (("- " ++) . unRepoName . repoName . fst) reposToUpdate - - jobCtrl <- newParallelJobControl (length reposToUpdate) - traverse_ (spawnJob jobCtrl . updateRepo verbosity defaultUpdateFlags repoCtxt) - reposToUpdate - traverse_ (\_ -> collectJob jobCtrl) reposToUpdate - - where - verbosity = fromFlagOrDefault normal (configVerbosity configFlags) - cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags, not needed here - globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) - -updateRepo :: Verbosity -> UpdateFlags -> RepoContext -> (Repo, RepoIndexState) - -> IO () -updateRepo verbosity _updateFlags repoCtxt (repo, indexState) = do - transport <- repoContextGetTransport repoCtxt - case repo of - RepoLocalNoIndex{} -> return () - RepoRemote{..} -> do - downloadResult <- downloadIndex transport verbosity - repoRemote repoLocalDir - case downloadResult of - FileAlreadyInCache -> - setModificationTime (indexBaseName repo <.> "tar") - =<< getCurrentTime - FileDownloaded indexPath -> do - writeFileAtomic (dropExtension indexPath) . maybeDecompress - =<< BS.readFile indexPath - updateRepoIndexCache verbosity (RepoIndex repoCtxt repo) - RepoSecure{} -> repoContextWithSecureRepo repoCtxt repo $ \repoSecure -> do - let index = RepoIndex repoCtxt repo - -- NB: This may be a nullTimestamp if we've never updated before - current_ts <- currentIndexTimestamp (lessVerbose verbosity) repoCtxt repo - -- NB: always update the timestamp, even if we didn't actually - -- download anything - writeIndexTimestamp index indexState - ce <- if repoContextIgnoreExpiry repoCtxt - then Just `fmap` getCurrentTime - else return Nothing - updated <- Sec.uncheckClientErrors $ Sec.checkForUpdates repoSecure ce - - let rname = remoteRepoName (repoRemote repo) - - -- Update cabal's internal index as well so that it's not out of sync - -- (If all access to the cache goes through hackage-security this can go) - case updated of - Sec.NoUpdates -> do - now <- getCurrentTime - setModificationTime (indexBaseName repo <.> "tar") now - noticeNoWrap verbosity $ - "Package list of " ++ prettyShow rname ++ - " is up to date at index-state " ++ prettyShow (IndexStateTime current_ts) - - Sec.HasUpdates -> do - updateRepoIndexCache verbosity index - new_ts <- currentIndexTimestamp (lessVerbose verbosity) repoCtxt repo - noticeNoWrap verbosity $ - "Updated package list of " ++ prettyShow rname ++ - " to the index-state " ++ prettyShow (IndexStateTime new_ts) - - -- TODO: This will print multiple times if there are multiple - -- repositories: main problem is we don't have a way of updating - -- a specific repo. Once we implement that, update this. - when (current_ts /= nullTimestamp) $ - noticeNoWrap verbosity $ - "To revert to previous state run:\n" ++ - " cabal v2-update '" ++ prettyShow (UpdateRequest rname (IndexStateTime current_ts)) ++ "'\n" diff --git a/cabal/cabal-install/Distribution/Client/Compat/Directory.hs b/cabal/cabal-install/Distribution/Client/Compat/Directory.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Compat/Directory.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-# LANGUAGE CPP #-} -module Distribution.Client.Compat.Directory ( - setModificationTime, - createFileLink, - pathIsSymbolicLink, - getSymbolicLinkTarget, - ) where - -#if MIN_VERSION_directory(1,2,3) -import System.Directory (setModificationTime) -#else -import Data.Time.Clock (UTCTime) -#endif - -#if MIN_VERSION_directory(1,3,1) -import System.Directory (createFileLink, getSymbolicLinkTarget, pathIsSymbolicLink) -#elif defined(MIN_VERSION_unix) -import System.Posix.Files (createSymbolicLink, getSymbolicLinkStatus, isSymbolicLink, readSymbolicLink) -#endif - -------------------------------------------------------------------------------- --- setModificationTime -------------------------------------------------------------------------------- - -#if !MIN_VERSION_directory(1,2,3) - -setModificationTime :: FilePath -> UTCTime -> IO () -setModificationTime _fp _t = return () - -#endif - -------------------------------------------------------------------------------- --- Symlink -------------------------------------------------------------------------------- - -#if MIN_VERSION_directory(1,3,1) -#elif defined(MIN_VERSION_unix) -createFileLink :: FilePath -> FilePath -> IO () -createFileLink = createSymbolicLink - -pathIsSymbolicLink :: FilePath -> IO Bool -pathIsSymbolicLink fp = do - status <- getSymbolicLinkStatus fp - return (isSymbolicLink status) - -getSymbolicLinkTarget :: FilePath -> IO FilePath -getSymbolicLinkTarget = readSymbolicLink - -#else -createFileLink :: FilePath -> FilePath -> IO () -createFileLink _ _ = fail "Symlinking feature not available" - -pathIsSymbolicLink :: FilePath -> IO Bool -pathIsSymbolicLink _ = fail "Symlinking feature not available" - -getSymbolicLinkTarget :: FilePath -> IO FilePath -getSymbolicLinkTarget _ = fail "Symlinking feature not available" -#endif diff --git a/cabal/cabal-install/Distribution/Client/Compat/ExecutablePath.hs b/cabal/cabal-install/Distribution/Client/Compat/ExecutablePath.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Compat/ExecutablePath.hs +++ /dev/null @@ -1,166 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE CPP #-} - --- Copied verbatim from base-4.6.0.0. We can't simply import --- System.Environment.getExecutablePath because we need compatibility with older --- GHCs. - -module Distribution.Client.Compat.ExecutablePath ( getExecutablePath ) where - -import Prelude - --- The imports are purposely kept completely disjoint to prevent edits --- to one OS implementation from breaking another. - -#if defined(darwin_HOST_OS) -import Data.Word -import Foreign.C -import Foreign.Marshal.Alloc -import Foreign.Ptr -import Foreign.Storable -import System.Posix.Internals -#elif defined(linux_HOST_OS) -import Foreign.C -import Foreign.Marshal.Array -import System.Posix.Internals -#elif defined(mingw32_HOST_OS) -import Data.Word -import Foreign.C -import Foreign.Marshal.Array -import Foreign.Ptr -import System.Posix.Internals -#else -import Foreign.C -import Foreign.Marshal.Alloc -import Foreign.Ptr -import Foreign.Storable -import System.Posix.Internals -#endif - --- The exported function is defined outside any if-guard to make sure --- every OS implements it with the same type. - --- | Returns the absolute pathname of the current executable. --- --- Note that for scripts and interactive sessions, this is the path to --- the interpreter (e.g. ghci.) --- --- /Since: 4.6.0.0/ -getExecutablePath :: IO FilePath - --------------------------------------------------------------------------------- --- Mac OS X - -#if defined(darwin_HOST_OS) - -type UInt32 = Word32 - -foreign import ccall unsafe "mach-o/dyld.h _NSGetExecutablePath" - c__NSGetExecutablePath :: CString -> Ptr UInt32 -> IO CInt - --- | Returns the path of the main executable. The path may be a --- symbolic link and not the real file. --- --- See dyld(3) -_NSGetExecutablePath :: IO FilePath -_NSGetExecutablePath = - allocaBytes 1024 $ \ buf -> -- PATH_MAX is 1024 on OS X - alloca $ \ bufsize -> do - poke bufsize 1024 - status <- c__NSGetExecutablePath buf bufsize - if status == 0 - then peekFilePath buf - else do reqBufsize <- fromIntegral `fmap` peek bufsize - allocaBytes reqBufsize $ \ newBuf -> do - status2 <- c__NSGetExecutablePath newBuf bufsize - if status2 == 0 - then peekFilePath newBuf - else error "_NSGetExecutablePath: buffer too small" - -foreign import ccall unsafe "stdlib.h realpath" - c_realpath :: CString -> CString -> IO CString - --- | Resolves all symbolic links, extra \/ characters, and references --- to \/.\/ and \/..\/. Returns an absolute pathname. --- --- See realpath(3) -realpath :: FilePath -> IO FilePath -realpath path = - withFilePath path $ \ fileName -> - allocaBytes 1024 $ \ resolvedName -> do - _ <- throwErrnoIfNull "realpath" $ c_realpath fileName resolvedName - peekFilePath resolvedName - -getExecutablePath = _NSGetExecutablePath >>= realpath - --------------------------------------------------------------------------------- --- Linux - -#elif defined(linux_HOST_OS) - -foreign import ccall unsafe "readlink" - c_readlink :: CString -> CString -> CSize -> IO CInt - --- | Reads the @FilePath@ pointed to by the symbolic link and returns --- it. --- --- See readlink(2) -readSymbolicLink :: FilePath -> IO FilePath -readSymbolicLink file = - allocaArray0 4096 $ \buf -> do - withFilePath file $ \s -> do - len <- throwErrnoPathIfMinus1 "readSymbolicLink" file $ - c_readlink s buf 4096 - peekFilePathLen (buf,fromIntegral len) - -getExecutablePath = readSymbolicLink $ "/proc/self/exe" - --------------------------------------------------------------------------------- --- Windows - -#elif defined(mingw32_HOST_OS) - -# if defined(i386_HOST_ARCH) -# define WINDOWS_CCONV stdcall -# elif defined(x86_64_HOST_ARCH) -# define WINDOWS_CCONV ccall -# else -# error Unknown mingw32 arch -# endif - -foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW" - c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32 - -getExecutablePath = go 2048 -- plenty, PATH_MAX is 512 under Win32 - where - go size = allocaArray (fromIntegral size) $ \ buf -> do - ret <- c_GetModuleFileName nullPtr buf size - case ret of - 0 -> error "getExecutablePath: GetModuleFileNameW returned an error" - _ | ret < size -> peekFilePath buf - | otherwise -> go (size * 2) - --------------------------------------------------------------------------------- --- Fallback to argv[0] - -#else - -foreign import ccall unsafe "getFullProgArgv" - c_getFullProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO () - -getExecutablePath = - alloca $ \ p_argc -> - alloca $ \ p_argv -> do - c_getFullProgArgv p_argc p_argv - argc <- peek p_argc - if argc > 0 - -- If argc > 0 then argv[0] is guaranteed by the standard - -- to be a pointer to a null-terminated string. - then peek p_argv >>= peek >>= peekFilePath - else error $ "getExecutablePath: " ++ msg - where msg = "no OS specific implementation and program name couldn't be " ++ - "found in argv" - --------------------------------------------------------------------------------- - -#endif diff --git a/cabal/cabal-install/Distribution/Client/Compat/FilePerms.hs b/cabal/cabal-install/Distribution/Client/Compat/FilePerms.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Compat/FilePerms.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# OPTIONS_HADDOCK hide #-} -module Distribution.Client.Compat.FilePerms ( - setFileOrdinary, - setFileExecutable, - setFileHidden, - ) where - -import Prelude (FilePath, IO, return, ($)) - -#ifndef mingw32_HOST_OS -import System.Posix.Types - ( FileMode ) -import System.Posix.Internals - ( c_chmod ) -import Foreign.C - ( withCString - , throwErrnoPathIfMinus1_ ) -#else -import System.Win32.File (setFileAttributes, fILE_ATTRIBUTE_HIDDEN) -#endif /* mingw32_HOST_OS */ - -setFileHidden, setFileOrdinary, setFileExecutable :: FilePath -> IO () -#ifndef mingw32_HOST_OS -setFileOrdinary path = setFileMode path 0o644 -- file perms -rw-r--r-- -setFileExecutable path = setFileMode path 0o755 -- file perms -rwxr-xr-x -setFileHidden _ = return () - -setFileMode :: FilePath -> FileMode -> IO () -setFileMode name m = - withCString name $ \s -> - throwErrnoPathIfMinus1_ "setFileMode" name (c_chmod s m) -#else -setFileOrdinary _ = return () -setFileExecutable _ = return () -setFileHidden path = setFileAttributes path fILE_ATTRIBUTE_HIDDEN -#endif diff --git a/cabal/cabal-install/Distribution/Client/Compat/Orphans.hs b/cabal/cabal-install/Distribution/Client/Compat/Orphans.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Compat/Orphans.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Distribution.Client.Compat.Orphans () where - -import Control.Exception (SomeException) -import Distribution.Compat.Binary (Binary (..)) -import Distribution.Compat.Typeable (typeRep) -import Distribution.Utils.Structured (Structure (Nominal), Structured (..)) -import Network.URI (URI (..), URIAuth (..)) -import Prelude (error, return) - -------------------------------------------------------------------------------- --- network-uri -------------------------------------------------------------------------------- - --- note, network-uri-2.6.0.3+ provide a Generic instance but earlier --- versions do not, so we use manual Binary instances here -instance Binary URI where - put (URI a b c d e) = do put a; put b; put c; put d; put e - get = do !a <- get; !b <- get; !c <- get; !d <- get; !e <- get - return (URI a b c d e) - -instance Structured URI where - structure p = Nominal (typeRep p) 0 "URI" [] - -instance Binary URIAuth where - put (URIAuth a b c) = do put a; put b; put c - get = do !a <- get; !b <- get; !c <- get; return (URIAuth a b c) - -------------------------------------------------------------------------------- --- base -------------------------------------------------------------------------------- - ---FIXME: Duncan Coutts: this is a total cheat ---Added in 46aa019ec85e313e257d122a3549cce01996c566 -instance Binary SomeException where - put _ = return () - get = error "cannot serialise exceptions" - -instance Structured SomeException where - structure p = Nominal (typeRep p) 0 "SomeException" [] diff --git a/cabal/cabal-install/Distribution/Client/Compat/Prelude.hs b/cabal/cabal-install/Distribution/Client/Compat/Prelude.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Compat/Prelude.hs +++ /dev/null @@ -1,24 +0,0 @@ --- to suppress WARNING in "Distribution.Compat.Prelude.Internal" -{-# OPTIONS_GHC -fno-warn-deprecations #-} - --- | This module does two things: --- --- * Acts as a compatibility layer, like @base-compat@. --- --- * Provides commonly used imports. --- --- This module is a superset of "Distribution.Compat.Prelude" (which --- this module re-exports) --- -module Distribution.Client.Compat.Prelude - ( module Distribution.Compat.Prelude.Internal - , module X - ) where - -import Distribution.Client.Compat.Orphans () -import Distribution.Compat.Prelude.Internal -import Prelude () - -import Distribution.Parsec as X (CabalParsing, Parsec (..), eitherParsec, explicitEitherParsec, simpleParsec) -import Distribution.Pretty as X (Pretty (..), prettyShow) -import Distribution.Verbosity as X (Verbosity) diff --git a/cabal/cabal-install/Distribution/Client/Compat/Process.hs b/cabal/cabal-install/Distribution/Client/Compat/Process.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Compat/Process.hs +++ /dev/null @@ -1,48 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Compat.Process --- Copyright : (c) 2013 Liu Hao, Brent Yorgey --- License : BSD-style (see the file LICENSE) --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- Cross-platform utilities for invoking processes. --- ------------------------------------------------------------------------------ - -module Distribution.Client.Compat.Process ( - readProcessWithExitCode -) where - -import Prelude (FilePath, IO, String, return, (||)) - -import Control.Exception (catch, throw) -import System.Exit (ExitCode (ExitFailure)) -import System.IO.Error (isDoesNotExistError, isPermissionError) -import qualified System.Process as P - --- | @readProcessWithExitCode@ creates an external process, reads its --- standard output and standard error strictly, waits until the --- process terminates, and then returns the @ExitCode@ of the --- process, the standard output, and the standard error. --- --- See the documentation of the version from @System.Process@ for --- more information. --- --- The version from @System.Process@ behaves inconsistently across --- platforms when an executable with the given name is not found: in --- some cases it returns an @ExitFailure@, in others it throws an --- exception. This variant catches \"does not exist\" and --- \"permission denied\" exceptions and turns them into --- @ExitFailure@s. --- --- TODO: this doesn't use 'Distrubution.Compat.Process'. --- -readProcessWithExitCode :: FilePath -> [String] -> String -> IO (ExitCode, String, String) -readProcessWithExitCode cmd args input = - P.readProcessWithExitCode cmd args input - `catch` \e -> if isDoesNotExistError e || isPermissionError e - then return (ExitFailure 127, "", "") - else throw e diff --git a/cabal/cabal-install/Distribution/Client/Compat/Semaphore.hs b/cabal/cabal-install/Distribution/Client/Compat/Semaphore.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Compat/Semaphore.hs +++ /dev/null @@ -1,108 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# OPTIONS_GHC -funbox-strict-fields #-} -module Distribution.Client.Compat.Semaphore - ( QSem - , newQSem - , waitQSem - , signalQSem - ) where - -import Prelude (IO, return, Eq (..), Int, Bool (..), ($), ($!), Num (..), flip) - -import Control.Concurrent.STM (TVar, atomically, newTVar, readTVar, retry, - writeTVar) -import Control.Exception (mask_, onException) -import Control.Monad (join, unless) -import Data.Typeable (Typeable) -import Data.List.NonEmpty (NonEmpty (..)) -import qualified Data.List.NonEmpty as NE - --- | 'QSem' is a quantity semaphore in which the resource is aqcuired --- and released in units of one. It provides guaranteed FIFO ordering --- for satisfying blocked `waitQSem` calls. --- -data QSem = QSem !(TVar Int) !(TVar [TVar Bool]) !(TVar [TVar Bool]) - deriving (Eq, Typeable) - -newQSem :: Int -> IO QSem -newQSem i = atomically $ do - q <- newTVar i - b1 <- newTVar [] - b2 <- newTVar [] - return (QSem q b1 b2) - -waitQSem :: QSem -> IO () -waitQSem s@(QSem q _b1 b2) = - mask_ $ join $ atomically $ do - -- join, because if we need to block, we have to add a TVar to - -- the block queue. - -- mask_, because we need a chance to set up an exception handler - -- after the join returns. - v <- readTVar q - if v == 0 - then do b <- newTVar False - ys <- readTVar b2 - writeTVar b2 (b:ys) - return (wait b) - else do writeTVar q $! v - 1 - return (return ()) - where - -- - -- very careful here: if we receive an exception, then we need to - -- (a) write True into the TVar, so that another signalQSem doesn't - -- try to wake up this thread, and - -- (b) if the TVar is *already* True, then we need to do another - -- signalQSem to avoid losing a unit of the resource. - -- - -- The 'wake' function does both (a) and (b), so we can just call - -- it here. - -- - wait t = - flip onException (wake s t) $ - atomically $ do - b <- readTVar t - unless b retry - - -wake :: QSem -> TVar Bool -> IO () -wake s x = join $ atomically $ do - b <- readTVar x - if b then return (signalQSem s) - else do writeTVar x True - return (return ()) - -{- - property we want: - - bracket waitQSem (\_ -> signalQSem) (\_ -> ...) - - never loses a unit of the resource. --} - -signalQSem :: QSem -> IO () -signalQSem s@(QSem q b1 b2) = - mask_ $ join $ atomically $ do - -- join, so we don't force the reverse inside the txn - -- mask_ is needed so we don't lose a wakeup - v <- readTVar q - if v /= 0 - then do writeTVar q $! v + 1 - return (return ()) - else do xs <- readTVar b1 - checkwake1 xs - where - checkwake1 [] = do - ys <- readTVar b2 - checkwake2 ys - checkwake1 (x:xs) = do - writeTVar b1 xs - return (wake s x) - - checkwake2 [] = do - writeTVar q 1 - return (return ()) - checkwake2 (y:ys) = do - let (z:|zs) = NE.reverse (y:|ys) - writeTVar b1 zs - writeTVar b2 [] - return (wake s z) diff --git a/cabal/cabal-install/Distribution/Client/Config.hs b/cabal/cabal-install/Distribution/Client/Config.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Config.hs +++ /dev/null @@ -1,1479 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE NoMonoLocalBinds #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Config --- Copyright : (c) David Himmelstrup 2005 --- License : BSD-like --- --- Maintainer : lemmih@gmail.com --- Stability : provisional --- Portability : portable --- --- Utilities for handling saved state such as known packages, known servers and --- downloaded packages. ------------------------------------------------------------------------------ -module Distribution.Client.Config ( - addInfoForKnownRepos, - SavedConfig(..), - loadConfig, - getConfigFilePath, - - showConfig, - showConfigWithComments, - parseConfig, - - getCabalDir, - defaultConfigFile, - defaultCacheDir, - defaultCompiler, - defaultInstallPath, - defaultLogsDir, - defaultUserInstall, - - baseSavedConfig, - commentSavedConfig, - initialSavedConfig, - configFieldDescriptions, - haddockFlagsFields, - installDirsFields, - withProgramsFields, - withProgramOptionsFields, - userConfigDiff, - userConfigUpdate, - createDefaultConfigFile, - - remoteRepoFields, - postProcessRepo, - ) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Language.Haskell.Extension ( Language(Haskell2010) ) - -import Distribution.Deprecated.ViewAsFieldDescr - ( viewAsFieldDescr ) - -import Distribution.Client.Types - ( RemoteRepo(..), LocalRepo (..), emptyRemoteRepo - , AllowOlder(..), AllowNewer(..), RelaxDeps(..), isRelaxDeps - , RepoName (..), unRepoName - ) -import Distribution.Client.Types.Credentials (Username (..), Password (..)) -import Distribution.Client.BuildReports.Types - ( ReportLevel(..) ) -import qualified Distribution.Client.Init.Types as IT - ( InitFlags(..) ) -import qualified Distribution.Client.Init.Defaults as IT -import Distribution.Client.Setup - ( GlobalFlags(..), globalCommand, defaultGlobalFlags - , ConfigExFlags(..), configureExOptions, defaultConfigExFlags - , initOptions - , InstallFlags(..), installOptions, defaultInstallFlags - , UploadFlags(..), uploadCommand - , ReportFlags(..), reportCommand ) -import Distribution.Client.CmdInstall.ClientInstallFlags - ( ClientInstallFlags(..), defaultClientInstallFlags - , clientInstallOptions ) -import Distribution.Utils.NubList - ( NubList, fromNubList, toNubList, overNubList ) - -import Distribution.Simple.Compiler - ( DebugInfoLevel(..), OptimisationLevel(..) ) -import Distribution.Simple.Setup - ( ConfigFlags(..), configureOptions, defaultConfigFlags - , HaddockFlags(..), haddockOptions, defaultHaddockFlags - , TestFlags(..), defaultTestFlags - , BenchmarkFlags(..), defaultBenchmarkFlags - , installDirsOptions, optionDistPref - , programDbPaths', programDbOptions - , Flag(..), toFlag, flagToMaybe, fromFlagOrDefault ) -import Distribution.Simple.InstallDirs - ( InstallDirs(..), defaultInstallDirs - , PathTemplate, toPathTemplate ) -import Distribution.Deprecated.ParseUtils - ( FieldDescr(..), liftField, runP - , ParseResult(..), PError(..), PWarning(..) - , locatedErrorMsg, showPWarning - , readFields, warning, lineNo - , simpleField, listField, spaceListField - , parseFilePathQ, parseOptCommaList, parseTokenQ, syntaxError - , simpleFieldParsec, listFieldParsec - ) -import Distribution.Client.ParseUtils - ( parseFields, ppFields, ppSection ) -import Distribution.Client.HttpUtils - ( isOldHackageURI ) -import qualified Distribution.Deprecated.ParseUtils as ParseUtils - ( Field(..) ) -import Distribution.Simple.Command - ( CommandUI(commandOptions), commandDefaultFlags, ShowOrParseArgs(..) ) -import Distribution.Simple.Program - ( defaultProgramDb ) -import Distribution.Simple.Utils - ( die', notice, warn, lowercase, cabalVersion ) -import Distribution.Client.Utils - ( cabalInstallVersion ) -import Distribution.Compiler - ( CompilerFlavor(..), defaultCompilerFlavor ) -import Distribution.Verbosity - ( normal ) -import qualified Distribution.Compat.CharParsing as P -import Distribution.Client.ProjectFlags (ProjectFlags (..)) -import Distribution.Solver.Types.ConstraintSource - -import qualified Distribution.Deprecated.ReadP as Parse - ( (<++), option ) -import qualified Text.PrettyPrint as Disp - ( render, text, empty ) -import Distribution.Parsec (parsecOptCommaList) -import Text.PrettyPrint - ( ($+$) ) -import Text.PrettyPrint.HughesPJ - ( text, Doc ) -import System.Directory - ( createDirectoryIfMissing, getAppUserDataDirectory, renameFile ) -import Network.URI - ( URI(..), URIAuth(..), parseURI ) -import System.FilePath - ( (<.>), (), takeDirectory ) -import System.IO.Error - ( isDoesNotExistError ) -import Distribution.Compat.Environment - ( getEnvironment, lookupEnv ) -import qualified Data.Map as M - --- --- * Configuration saved in the config file --- - -data SavedConfig = SavedConfig - { savedGlobalFlags :: GlobalFlags - , savedInitFlags :: IT.InitFlags - , savedInstallFlags :: InstallFlags - , savedClientInstallFlags :: ClientInstallFlags - , savedConfigureFlags :: ConfigFlags - , savedConfigureExFlags :: ConfigExFlags - , savedUserInstallDirs :: InstallDirs (Flag PathTemplate) - , savedGlobalInstallDirs :: InstallDirs (Flag PathTemplate) - , savedUploadFlags :: UploadFlags - , savedReportFlags :: ReportFlags - , savedHaddockFlags :: HaddockFlags - , savedTestFlags :: TestFlags - , savedBenchmarkFlags :: BenchmarkFlags - , savedProjectFlags :: ProjectFlags - } deriving Generic - -instance Monoid SavedConfig where - mempty = gmempty - mappend = (<>) - -instance Semigroup SavedConfig where - a <> b = SavedConfig { - savedGlobalFlags = combinedSavedGlobalFlags, - savedInitFlags = combinedSavedInitFlags, - savedInstallFlags = combinedSavedInstallFlags, - savedClientInstallFlags = combinedSavedClientInstallFlags, - savedConfigureFlags = combinedSavedConfigureFlags, - savedConfigureExFlags = combinedSavedConfigureExFlags, - savedUserInstallDirs = combinedSavedUserInstallDirs, - savedGlobalInstallDirs = combinedSavedGlobalInstallDirs, - savedUploadFlags = combinedSavedUploadFlags, - savedReportFlags = combinedSavedReportFlags, - savedHaddockFlags = combinedSavedHaddockFlags, - savedTestFlags = combinedSavedTestFlags, - savedBenchmarkFlags = combinedSavedBenchmarkFlags, - savedProjectFlags = combinedSavedProjectFlags - } - where - -- This is ugly, but necessary. If we're mappending two config files, we - -- want the values of the *non-empty* list fields from the second one to - -- *override* the corresponding values from the first one. Default - -- behaviour (concatenation) is confusing and makes some use cases (see - -- #1884) impossible. - -- - -- However, we also want to allow specifying multiple values for a list - -- field in a *single* config file. For example, we want the following to - -- continue to work: - -- - -- remote-repo: hackage.haskell.org:http://hackage.haskell.org/ - -- remote-repo: private-collection:http://hackage.local/ - -- - -- So we can't just wrap the list fields inside Flags; we have to do some - -- special-casing just for SavedConfig. - - -- NB: the signature prevents us from using 'combine' on lists. - combine' :: (SavedConfig -> flags) -> (flags -> Flag a) -> Flag a - combine' field subfield = - (subfield . field $ a) `mappend` (subfield . field $ b) - - combineMonoid :: Monoid mon => (SavedConfig -> flags) -> (flags -> mon) - -> mon - combineMonoid field subfield = - (subfield . field $ a) `mappend` (subfield . field $ b) - - lastNonEmpty' :: (SavedConfig -> flags) -> (flags -> [a]) -> [a] - lastNonEmpty' field subfield = - let a' = subfield . field $ a - b' = subfield . field $ b - in case b' of [] -> a' - _ -> b' - - lastNonMempty' - :: (Eq a, Monoid a) => (SavedConfig -> flags) -> (flags -> a) -> a - lastNonMempty' field subfield = - let a' = subfield . field $ a - b' = subfield . field $ b - in if b' == mempty then a' else b' - - lastNonEmptyNL' :: (SavedConfig -> flags) -> (flags -> NubList a) - -> NubList a - lastNonEmptyNL' field subfield = - let a' = subfield . field $ a - b' = subfield . field $ b - in case fromNubList b' of [] -> a' - _ -> b' - - combinedSavedGlobalFlags = GlobalFlags { - globalVersion = combine globalVersion, - globalNumericVersion = combine globalNumericVersion, - globalConfigFile = combine globalConfigFile, - globalConstraintsFile = combine globalConstraintsFile, - globalRemoteRepos = lastNonEmptyNL globalRemoteRepos, - globalCacheDir = combine globalCacheDir, - globalLocalNoIndexRepos = lastNonEmptyNL globalLocalNoIndexRepos, - globalActiveRepos = combine globalActiveRepos, - globalLogsDir = combine globalLogsDir, - globalWorldFile = combine globalWorldFile, - globalIgnoreExpiry = combine globalIgnoreExpiry, - globalHttpTransport = combine globalHttpTransport, - globalNix = combine globalNix, - globalStoreDir = combine globalStoreDir, - globalProgPathExtra = lastNonEmptyNL globalProgPathExtra - } - where - combine = combine' savedGlobalFlags - lastNonEmptyNL = lastNonEmptyNL' savedGlobalFlags - - combinedSavedInitFlags = IT.InitFlags { - IT.applicationDirs = combineMonoid savedInitFlags IT.applicationDirs, - IT.author = combine IT.author, - IT.buildTools = combineMonoid savedInitFlags IT.buildTools, - IT.cabalVersion = combine IT.cabalVersion, - IT.category = combine IT.category, - IT.dependencies = combineMonoid savedInitFlags IT.dependencies, - IT.email = combine IT.email, - IT.exposedModules = combineMonoid savedInitFlags IT.exposedModules, - IT.extraSrc = combineMonoid savedInitFlags IT.extraSrc, - IT.homepage = combine IT.homepage, - IT.initHcPath = combine IT.initHcPath, - IT.initVerbosity = combine IT.initVerbosity, - IT.initializeTestSuite = combine IT.initializeTestSuite, - IT.interactive = combine IT.interactive, - IT.language = combine IT.language, - IT.license = combine IT.license, - IT.mainIs = combine IT.mainIs, - IT.minimal = combine IT.minimal, - IT.noComments = combine IT.noComments, - IT.otherExts = combineMonoid savedInitFlags IT.otherExts, - IT.otherModules = combineMonoid savedInitFlags IT.otherModules, - IT.overwrite = combine IT.overwrite, - IT.packageDir = combine IT.packageDir, - IT.packageName = combine IT.packageName, - IT.packageType = combine IT.packageType, - IT.quiet = combine IT.quiet, - IT.simpleProject = combine IT.simpleProject, - IT.sourceDirs = combineMonoid savedInitFlags IT.sourceDirs, - IT.synopsis = combine IT.synopsis, - IT.testDirs = combineMonoid savedInitFlags IT.testDirs, - IT.version = combine IT.version - } - where - combine = combine' savedInitFlags - - combinedSavedInstallFlags = InstallFlags { - installDocumentation = combine installDocumentation, - installHaddockIndex = combine installHaddockIndex, - installDryRun = combine installDryRun, - installDest = combine installDest, - installMaxBackjumps = combine installMaxBackjumps, - installReorderGoals = combine installReorderGoals, - installCountConflicts = combine installCountConflicts, - installFineGrainedConflicts = combine installFineGrainedConflicts, - installMinimizeConflictSet = combine installMinimizeConflictSet, - installIndependentGoals = combine installIndependentGoals, - installShadowPkgs = combine installShadowPkgs, - installStrongFlags = combine installStrongFlags, - installAllowBootLibInstalls = combine installAllowBootLibInstalls, - installOnlyConstrained = combine installOnlyConstrained, - installReinstall = combine installReinstall, - installAvoidReinstalls = combine installAvoidReinstalls, - installOverrideReinstall = combine installOverrideReinstall, - installUpgradeDeps = combine installUpgradeDeps, - installOnly = combine installOnly, - installOnlyDeps = combine installOnlyDeps, - installIndexState = combine installIndexState, - installRootCmd = combine installRootCmd, - installSummaryFile = lastNonEmptyNL installSummaryFile, - installLogFile = combine installLogFile, - installBuildReports = combine installBuildReports, - installReportPlanningFailure = combine installReportPlanningFailure, - installSymlinkBinDir = combine installSymlinkBinDir, - installPerComponent = combine installPerComponent, - installOneShot = combine installOneShot, - installNumJobs = combine installNumJobs, - installKeepGoing = combine installKeepGoing, - installRunTests = combine installRunTests, - installOfflineMode = combine installOfflineMode - } - where - combine = combine' savedInstallFlags - lastNonEmptyNL = lastNonEmptyNL' savedInstallFlags - - combinedSavedClientInstallFlags = ClientInstallFlags - { cinstInstallLibs = combine cinstInstallLibs - , cinstEnvironmentPath = combine cinstEnvironmentPath - , cinstOverwritePolicy = combine cinstOverwritePolicy - , cinstInstallMethod = combine cinstInstallMethod - , cinstInstalldir = combine cinstInstalldir - } - where - combine = combine' savedClientInstallFlags - - combinedSavedConfigureFlags = ConfigFlags { - configArgs = lastNonEmpty configArgs, - configPrograms_ = configPrograms_ . savedConfigureFlags $ b, - -- TODO: NubListify - configProgramPaths = lastNonEmpty configProgramPaths, - -- TODO: NubListify - configProgramArgs = lastNonEmpty configProgramArgs, - configProgramPathExtra = lastNonEmptyNL configProgramPathExtra, - configInstantiateWith = lastNonEmpty configInstantiateWith, - configHcFlavor = combine configHcFlavor, - configHcPath = combine configHcPath, - configHcPkg = combine configHcPkg, - configVanillaLib = combine configVanillaLib, - configProfLib = combine configProfLib, - configProf = combine configProf, - configSharedLib = combine configSharedLib, - configStaticLib = combine configStaticLib, - configDynExe = combine configDynExe, - configFullyStaticExe = combine configFullyStaticExe, - configProfExe = combine configProfExe, - configProfDetail = combine configProfDetail, - configProfLibDetail = combine configProfLibDetail, - -- TODO: NubListify - configConfigureArgs = lastNonEmpty configConfigureArgs, - configOptimization = combine configOptimization, - configDebugInfo = combine configDebugInfo, - configProgPrefix = combine configProgPrefix, - configProgSuffix = combine configProgSuffix, - -- Parametrised by (Flag PathTemplate), so safe to use 'mappend'. - configInstallDirs = - (configInstallDirs . savedConfigureFlags $ a) - `mappend` (configInstallDirs . savedConfigureFlags $ b), - configScratchDir = combine configScratchDir, - -- TODO: NubListify - configExtraLibDirs = lastNonEmpty configExtraLibDirs, - -- TODO: NubListify - configExtraFrameworkDirs = lastNonEmpty configExtraFrameworkDirs, - -- TODO: NubListify - configExtraIncludeDirs = lastNonEmpty configExtraIncludeDirs, - configDeterministic = combine configDeterministic, - configIPID = combine configIPID, - configCID = combine configCID, - configDistPref = combine configDistPref, - configCabalFilePath = combine configCabalFilePath, - configVerbosity = combine configVerbosity, - configUserInstall = combine configUserInstall, - -- TODO: NubListify - configPackageDBs = lastNonEmpty configPackageDBs, - configGHCiLib = combine configGHCiLib, - configSplitSections = combine configSplitSections, - configSplitObjs = combine configSplitObjs, - configStripExes = combine configStripExes, - configStripLibs = combine configStripLibs, - -- TODO: NubListify - configConstraints = lastNonEmpty configConstraints, - -- TODO: NubListify - configDependencies = lastNonEmpty configDependencies, - -- TODO: NubListify - configConfigurationsFlags = lastNonMempty configConfigurationsFlags, - configTests = combine configTests, - configBenchmarks = combine configBenchmarks, - configCoverage = combine configCoverage, - configLibCoverage = combine configLibCoverage, - configExactConfiguration = combine configExactConfiguration, - configFlagError = combine configFlagError, - configRelocatable = combine configRelocatable, - configUseResponseFiles = combine configUseResponseFiles, - configAllowDependingOnPrivateLibs = - combine configAllowDependingOnPrivateLibs - } - where - combine = combine' savedConfigureFlags - lastNonEmpty = lastNonEmpty' savedConfigureFlags - lastNonEmptyNL = lastNonEmptyNL' savedConfigureFlags - lastNonMempty = lastNonMempty' savedConfigureFlags - - combinedSavedConfigureExFlags = ConfigExFlags { - configCabalVersion = combine configCabalVersion, - -- TODO: NubListify - configExConstraints = lastNonEmpty configExConstraints, - -- TODO: NubListify - configPreferences = lastNonEmpty configPreferences, - configSolver = combine configSolver, - configAllowNewer = - combineMonoid savedConfigureExFlags configAllowNewer, - configAllowOlder = - combineMonoid savedConfigureExFlags configAllowOlder, - configWriteGhcEnvironmentFilesPolicy - = combine configWriteGhcEnvironmentFilesPolicy - } - where - combine = combine' savedConfigureExFlags - lastNonEmpty = lastNonEmpty' savedConfigureExFlags - - -- Parametrised by (Flag PathTemplate), so safe to use 'mappend'. - combinedSavedUserInstallDirs = savedUserInstallDirs a - `mappend` savedUserInstallDirs b - - -- Parametrised by (Flag PathTemplate), so safe to use 'mappend'. - combinedSavedGlobalInstallDirs = savedGlobalInstallDirs a - `mappend` savedGlobalInstallDirs b - - combinedSavedUploadFlags = UploadFlags { - uploadCandidate = combine uploadCandidate, - uploadDoc = combine uploadDoc, - uploadUsername = combine uploadUsername, - uploadPassword = combine uploadPassword, - uploadPasswordCmd = combine uploadPasswordCmd, - uploadVerbosity = combine uploadVerbosity - } - where - combine = combine' savedUploadFlags - - combinedSavedReportFlags = ReportFlags { - reportUsername = combine reportUsername, - reportPassword = combine reportPassword, - reportVerbosity = combine reportVerbosity - } - where - combine = combine' savedReportFlags - - combinedSavedHaddockFlags = HaddockFlags { - -- TODO: NubListify - haddockProgramPaths = lastNonEmpty haddockProgramPaths, - -- TODO: NubListify - haddockProgramArgs = lastNonEmpty haddockProgramArgs, - haddockHoogle = combine haddockHoogle, - haddockHtml = combine haddockHtml, - haddockHtmlLocation = combine haddockHtmlLocation, - haddockForHackage = combine haddockForHackage, - haddockExecutables = combine haddockExecutables, - haddockTestSuites = combine haddockTestSuites, - haddockBenchmarks = combine haddockBenchmarks, - haddockForeignLibs = combine haddockForeignLibs, - haddockInternal = combine haddockInternal, - haddockCss = combine haddockCss, - haddockLinkedSource = combine haddockLinkedSource, - haddockQuickJump = combine haddockQuickJump, - haddockHscolourCss = combine haddockHscolourCss, - haddockContents = combine haddockContents, - haddockDistPref = combine haddockDistPref, - haddockKeepTempFiles = combine haddockKeepTempFiles, - haddockVerbosity = combine haddockVerbosity, - haddockCabalFilePath = combine haddockCabalFilePath, - haddockArgs = lastNonEmpty haddockArgs - } - where - combine = combine' savedHaddockFlags - lastNonEmpty = lastNonEmpty' savedHaddockFlags - - combinedSavedTestFlags = TestFlags { - testDistPref = combine testDistPref, - testVerbosity = combine testVerbosity, - testHumanLog = combine testHumanLog, - testMachineLog = combine testMachineLog, - testShowDetails = combine testShowDetails, - testKeepTix = combine testKeepTix, - testWrapper = combine testWrapper, - testFailWhenNoTestSuites = combine testFailWhenNoTestSuites, - testOptions = lastNonEmpty testOptions - } - where - combine = combine' savedTestFlags - lastNonEmpty = lastNonEmpty' savedTestFlags - - combinedSavedBenchmarkFlags = BenchmarkFlags { - benchmarkDistPref = combine benchmarkDistPref, - benchmarkVerbosity = combine benchmarkVerbosity, - benchmarkOptions = lastNonEmpty benchmarkOptions - } - where - combine = combine' savedBenchmarkFlags - lastNonEmpty = lastNonEmpty' savedBenchmarkFlags - - combinedSavedProjectFlags = ProjectFlags - { flagProjectFileName = combine flagProjectFileName - , flagIgnoreProject = combine flagIgnoreProject - } - where - combine = combine' savedProjectFlags - --- --- * Default config --- - --- | These are the absolute basic defaults. The fields that must be --- initialised. When we load the config from the file we layer the loaded --- values over these ones, so any missing fields in the file take their values --- from here. --- -baseSavedConfig :: IO SavedConfig -baseSavedConfig = do - userPrefix <- getCabalDir - cacheDir <- defaultCacheDir - logsDir <- defaultLogsDir - worldFile <- defaultWorldFile - return mempty { - savedConfigureFlags = mempty { - configHcFlavor = toFlag defaultCompiler, - configUserInstall = toFlag defaultUserInstall, - configVerbosity = toFlag normal - }, - savedUserInstallDirs = mempty { - prefix = toFlag (toPathTemplate userPrefix) - }, - savedGlobalFlags = mempty { - globalCacheDir = toFlag cacheDir, - globalLogsDir = toFlag logsDir, - globalWorldFile = toFlag worldFile - } - } - --- | This is the initial configuration that we write out to the config file --- if the file does not exist (or the config we use if the file cannot be read --- for some other reason). When the config gets loaded it gets layered on top --- of 'baseSavedConfig' so we do not need to include it into the initial --- values we save into the config file. --- -initialSavedConfig :: IO SavedConfig -initialSavedConfig = do - cacheDir <- defaultCacheDir - logsDir <- defaultLogsDir - worldFile <- defaultWorldFile - extraPath <- defaultExtraPath - installPath <- defaultInstallPath - return mempty { - savedGlobalFlags = mempty { - globalCacheDir = toFlag cacheDir, - globalRemoteRepos = toNubList [defaultRemoteRepo], - globalWorldFile = toFlag worldFile - }, - savedConfigureFlags = mempty { - configProgramPathExtra = toNubList extraPath - }, - savedInstallFlags = mempty { - installSummaryFile = toNubList [toPathTemplate (logsDir "build.log")], - installBuildReports= toFlag NoReports, - installNumJobs = toFlag Nothing - }, - savedClientInstallFlags = mempty { - cinstInstalldir = toFlag installPath - } - } - -defaultCabalDir :: IO FilePath -defaultCabalDir = getAppUserDataDirectory "cabal" - -getCabalDir :: IO FilePath -getCabalDir = do - mDir <- lookupEnv "CABAL_DIR" - case mDir of - Nothing -> defaultCabalDir - Just dir -> return dir - -defaultConfigFile :: IO FilePath -defaultConfigFile = do - dir <- getCabalDir - return $ dir "config" - -defaultCacheDir :: IO FilePath -defaultCacheDir = do - dir <- getCabalDir - return $ dir "packages" - -defaultLogsDir :: IO FilePath -defaultLogsDir = do - dir <- getCabalDir - return $ dir "logs" - --- | Default position of the world file -defaultWorldFile :: IO FilePath -defaultWorldFile = do - dir <- getCabalDir - return $ dir "world" - -defaultExtraPath :: IO [FilePath] -defaultExtraPath = do - dir <- getCabalDir - return [dir "bin"] - -defaultInstallPath :: IO FilePath -defaultInstallPath = do - dir <- getCabalDir - return (dir "bin") - -defaultCompiler :: CompilerFlavor -defaultCompiler = fromMaybe GHC defaultCompilerFlavor - -defaultUserInstall :: Bool -defaultUserInstall = True --- We do per-user installs by default on all platforms. We used to default to --- global installs on Windows but that no longer works on Windows Vista or 7. - -defaultRemoteRepo :: RemoteRepo -defaultRemoteRepo = RemoteRepo name uri Nothing [] 0 False - where - str = "hackage.haskell.org" - name = RepoName str - uri = URI "http:" (Just (URIAuth "" str "")) "/" "" "" - -- Note that lots of old ~/.cabal/config files will have the old url - -- http://hackage.haskell.org/packages/archive - -- but new config files can use the new url (without the /packages/archive) - -- and avoid having to do a http redirect - --- For the default repo we know extra information, fill this in. --- --- We need this because the 'defaultRemoteRepo' above is only used for the --- first time when a config file is made. So for users with older config files --- we might have only have older info. This lets us fill that in even for old --- config files. --- -addInfoForKnownRepos :: RemoteRepo -> RemoteRepo -addInfoForKnownRepos repo - | remoteRepoName repo == remoteRepoName defaultRemoteRepo - = useSecure . tryHttps . fixOldURI $ repo - where - fixOldURI r - | isOldHackageURI (remoteRepoURI r) - = r { remoteRepoURI = remoteRepoURI defaultRemoteRepo } - | otherwise = r - - tryHttps r = r { remoteRepoShouldTryHttps = True } - - useSecure r@RemoteRepo{ - remoteRepoSecure = secure, - remoteRepoRootKeys = [], - remoteRepoKeyThreshold = 0 - } | secure /= Just False - = r { - -- Use hackage-security by default unless you opt-out with - -- secure: False - remoteRepoSecure = Just True, - remoteRepoRootKeys = defaultHackageRemoteRepoKeys, - remoteRepoKeyThreshold = defaultHackageRemoteRepoKeyThreshold - } - useSecure r = r -addInfoForKnownRepos other = other - --- | The current hackage.haskell.org repo root keys that we ship with cabal. ---- --- This lets us bootstrap trust in this repo without user intervention. --- These keys need to be periodically updated when new root keys are added. --- See the root key procedures for details. --- -defaultHackageRemoteRepoKeys :: [String] -defaultHackageRemoteRepoKeys = - [ "fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0", - "1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42", - "2c6c3627bd6c982990239487f1abd02e08a02e6cf16edb105a8012d444d870c3", - "0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d", - "51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921" - ] - --- | The required threshold of root key signatures for hackage.haskell.org --- -defaultHackageRemoteRepoKeyThreshold :: Int -defaultHackageRemoteRepoKeyThreshold = 3 - --- --- * Config file reading --- - --- | Loads the main configuration, and applies additional defaults to give the --- effective configuration. To loads just what is actually in the config file, --- use 'loadRawConfig'. --- -loadConfig :: Verbosity -> Flag FilePath -> IO SavedConfig -loadConfig verbosity configFileFlag = do - config <- loadRawConfig verbosity configFileFlag - extendToEffectiveConfig config - -extendToEffectiveConfig :: SavedConfig -> IO SavedConfig -extendToEffectiveConfig config = do - base <- baseSavedConfig - let effective0 = base `mappend` config - globalFlags0 = savedGlobalFlags effective0 - effective = effective0 { - savedGlobalFlags = globalFlags0 { - globalRemoteRepos = - overNubList (map addInfoForKnownRepos) - (globalRemoteRepos globalFlags0) - } - } - return effective - --- | Like 'loadConfig' but does not apply any additional defaults, it just --- loads what is actually in the config file. This is thus suitable for --- comparing or editing a config file, but not suitable for using as the --- effective configuration. --- -loadRawConfig :: Verbosity -> Flag FilePath -> IO SavedConfig -loadRawConfig verbosity configFileFlag = do - (source, configFile) <- getConfigFilePathAndSource configFileFlag - minp <- readConfigFile mempty configFile - case minp of - Nothing -> do - notice verbosity $ - "Config file path source is " ++ sourceMsg source ++ "." - notice verbosity $ "Config file " ++ configFile ++ " not found." - createDefaultConfigFile verbosity [] configFile - Just (ParseOk ws conf) -> do - unless (null ws) $ warn verbosity $ - unlines (map (showPWarning configFile) ws) - return conf - Just (ParseFailed err) -> do - let (line, msg) = locatedErrorMsg err - die' verbosity $ - "Error parsing config file " ++ configFile - ++ maybe "" (\n -> ':' : show n) line ++ ":\n" ++ msg - - where - sourceMsg CommandlineOption = "commandline option" - sourceMsg EnvironmentVariable = "env var CABAL_CONFIG" - sourceMsg Default = "default config file" - -data ConfigFileSource = CommandlineOption - | EnvironmentVariable - | Default - --- | Returns the config file path, without checking that the file exists. --- The order of precedence is: input flag, CABAL_CONFIG, default location. -getConfigFilePath :: Flag FilePath -> IO FilePath -getConfigFilePath = fmap snd . getConfigFilePathAndSource - -getConfigFilePathAndSource :: Flag FilePath -> IO (ConfigFileSource, FilePath) -getConfigFilePathAndSource configFileFlag = - getSource sources - where - sources = - [ (CommandlineOption, return . flagToMaybe $ configFileFlag) - , (EnvironmentVariable, lookup "CABAL_CONFIG" `liftM` getEnvironment) - , (Default, Just `liftM` defaultConfigFile) ] - - getSource [] = error "no config file path candidate found." - getSource ((source,action): xs) = - action >>= maybe (getSource xs) (return . (,) source) - -readConfigFile - :: SavedConfig -> FilePath -> IO (Maybe (ParseResult SavedConfig)) -readConfigFile initial file = handleNotExists $ - fmap (Just . parseConfig (ConstraintSourceMainConfig file) initial) - (readFile file) - - where - handleNotExists action = catchIO action $ \ioe -> - if isDoesNotExistError ioe - then return Nothing - else ioError ioe - -createDefaultConfigFile :: Verbosity -> [String] -> FilePath -> IO SavedConfig -createDefaultConfigFile verbosity extraLines filePath = do - commentConf <- commentSavedConfig - initialConf <- initialSavedConfig - extraConf <- parseExtraLines verbosity extraLines - notice verbosity $ "Writing default configuration to " ++ filePath - writeConfigFile filePath commentConf (initialConf `mappend` extraConf) - return initialConf - -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 - where - explanation = unlines - ["-- This is the configuration file for the 'cabal' command line tool." - ,"--" - ,"-- The available configuration options are listed below." - ,"-- Some of them have default values listed." - ,"--" - ,"-- Lines (like this one) beginning with '--' are comments." - ,"-- Be careful with spaces and indentation because they are" - ,"-- used to indicate layout for nested sections." - ,"--" - ,"-- This config file was generated using the following versions" - ,"-- of Cabal and cabal-install:" - ,"-- Cabal library version: " ++ prettyShow cabalVersion - ,"-- cabal-install version: " ++ prettyShow cabalInstallVersion - ,"","" - ] - --- | These are the default values that get used in Cabal if a no value is --- given. We use these here to include in comments when we write out the --- initial config file so that the user can see what default value they are --- overriding. --- -commentSavedConfig :: IO SavedConfig -commentSavedConfig = do - userInstallDirs <- defaultInstallDirs defaultCompiler True True - globalInstallDirs <- defaultInstallDirs defaultCompiler False True - let conf0 = mempty { - savedGlobalFlags = defaultGlobalFlags { - globalRemoteRepos = toNubList [defaultRemoteRepo] - }, - savedInitFlags = mempty { - IT.interactive = toFlag False, - IT.cabalVersion = toFlag IT.defaultCabalVersion, - IT.language = toFlag Haskell2010, - IT.license = NoFlag, - IT.sourceDirs = Just [IT.defaultSourceDir], - IT.applicationDirs = Just [IT.defaultApplicationDir] - }, - savedInstallFlags = defaultInstallFlags, - savedClientInstallFlags= defaultClientInstallFlags, - savedConfigureExFlags = defaultConfigExFlags { - configAllowNewer = Just (AllowNewer mempty), - configAllowOlder = Just (AllowOlder mempty) - }, - savedConfigureFlags = (defaultConfigFlags defaultProgramDb) { - configUserInstall = toFlag defaultUserInstall - }, - savedUserInstallDirs = fmap toFlag userInstallDirs, - savedGlobalInstallDirs = fmap toFlag globalInstallDirs, - savedUploadFlags = commandDefaultFlags uploadCommand, - savedReportFlags = commandDefaultFlags reportCommand, - savedHaddockFlags = defaultHaddockFlags, - savedTestFlags = defaultTestFlags, - savedBenchmarkFlags = defaultBenchmarkFlags - } - conf1 <- extendToEffectiveConfig conf0 - let globalFlagsConf1 = savedGlobalFlags conf1 - conf2 = conf1 { - savedGlobalFlags = globalFlagsConf1 { - globalRemoteRepos = overNubList (map removeRootKeys) - (globalRemoteRepos globalFlagsConf1) - } - } - return conf2 - where - -- Most people don't want to see default root keys, so don't print them. - removeRootKeys :: RemoteRepo -> RemoteRepo - removeRootKeys r = r { remoteRepoRootKeys = [] } - --- | All config file fields. --- -configFieldDescriptions :: ConstraintSource -> [FieldDescr SavedConfig] -configFieldDescriptions src = - - toSavedConfig liftGlobalFlag - (commandOptions (globalCommand []) ParseArgs) - ["version", "numeric-version", "config-file"] [] - - ++ toSavedConfig liftConfigFlag - (configureOptions ParseArgs) - (["builddir", "constraint", "dependency", "ipid"] - ++ map fieldName installDirsFields) - - -- This is only here because viewAsFieldDescr gives us a parser - -- that only recognises 'ghc' etc, the case-sensitive flag names, not - -- what the normal case-insensitive parser gives us. - [simpleFieldParsec "compiler" - (fromFlagOrDefault Disp.empty . fmap pretty) (Flag <$> parsec <|> pure NoFlag) - configHcFlavor (\v flags -> flags { configHcFlavor = v }) - - -- TODO: The following is a temporary fix. The "optimization" - -- and "debug-info" fields are OptArg, and viewAsFieldDescr - -- fails on that. Instead of a hand-written hackaged parser - -- and printer, we should handle this case properly in the - -- library. - ,liftField configOptimization (\v flags -> - flags { configOptimization = v }) $ - let name = "optimization" in - FieldDescr name - (\f -> case f of - Flag NoOptimisation -> Disp.text "False" - Flag NormalOptimisation -> Disp.text "True" - Flag MaximumOptimisation -> Disp.text "2" - _ -> Disp.empty) - (\line str _ -> case () of - _ | str == "False" -> ParseOk [] (Flag NoOptimisation) - | str == "True" -> ParseOk [] (Flag NormalOptimisation) - | str == "0" -> ParseOk [] (Flag NoOptimisation) - | str == "1" -> ParseOk [] (Flag NormalOptimisation) - | str == "2" -> ParseOk [] (Flag MaximumOptimisation) - | lstr == "false" -> ParseOk [caseWarning] (Flag NoOptimisation) - | lstr == "true" -> ParseOk [caseWarning] - (Flag NormalOptimisation) - | otherwise -> ParseFailed (NoParse name line) - where - lstr = lowercase str - caseWarning = PWarning $ - "The '" ++ name - ++ "' field is case sensitive, use 'True' or 'False'.") - ,liftField configDebugInfo (\v flags -> flags { configDebugInfo = v }) $ - let name = "debug-info" in - FieldDescr name - (\f -> case f of - Flag NoDebugInfo -> Disp.text "False" - Flag MinimalDebugInfo -> Disp.text "1" - Flag NormalDebugInfo -> Disp.text "True" - Flag MaximalDebugInfo -> Disp.text "3" - _ -> Disp.empty) - (\line str _ -> case () of - _ | str == "False" -> ParseOk [] (Flag NoDebugInfo) - | str == "True" -> ParseOk [] (Flag NormalDebugInfo) - | str == "0" -> ParseOk [] (Flag NoDebugInfo) - | str == "1" -> ParseOk [] (Flag MinimalDebugInfo) - | str == "2" -> ParseOk [] (Flag NormalDebugInfo) - | str == "3" -> ParseOk [] (Flag MaximalDebugInfo) - | lstr == "false" -> ParseOk [caseWarning] (Flag NoDebugInfo) - | lstr == "true" -> ParseOk [caseWarning] (Flag NormalDebugInfo) - | otherwise -> ParseFailed (NoParse name line) - where - lstr = lowercase str - caseWarning = PWarning $ - "The '" ++ name - ++ "' field is case sensitive, use 'True' or 'False'.") - ] - - ++ toSavedConfig liftConfigExFlag - (configureExOptions ParseArgs src) - [] - [let pkgs = (Just . AllowOlder . RelaxDepsSome) - `fmap` parsecOptCommaList parsec - parseAllowOlder = ((Just . AllowOlder . toRelaxDeps) - `fmap` parsec) Parse.<++ pkgs - in simpleField "allow-older" - (showRelaxDeps . fmap unAllowOlder) parseAllowOlder - configAllowOlder (\v flags -> flags { configAllowOlder = v }) - ,let pkgs = (Just . AllowNewer . RelaxDepsSome) - `fmap` parsecOptCommaList parsec - parseAllowNewer = ((Just . AllowNewer . toRelaxDeps) - `fmap` parsec) Parse.<++ pkgs - in simpleField "allow-newer" - (showRelaxDeps . fmap unAllowNewer) parseAllowNewer - configAllowNewer (\v flags -> flags { configAllowNewer = v }) - ] - - ++ toSavedConfig liftInstallFlag - (installOptions ParseArgs) - ["dry-run", "only", "only-dependencies", "dependencies-only"] [] - - ++ toSavedConfig liftClientInstallFlag - (clientInstallOptions ParseArgs) - [] [] - - ++ toSavedConfig liftUploadFlag - (commandOptions uploadCommand ParseArgs) - ["verbose", "check", "documentation", "publish"] [] - - ++ toSavedConfig liftReportFlag - (commandOptions reportCommand ParseArgs) - ["verbose", "username", "password"] [] - --FIXME: this is a hack, hiding the user name and password. - -- But otherwise it masks the upload ones. Either need to - -- share the options or make then distinct. In any case - -- they should probably be per-server. - - ++ [ viewAsFieldDescr - $ optionDistPref - (configDistPref . savedConfigureFlags) - (\distPref config -> - config - { savedConfigureFlags = (savedConfigureFlags config) { - configDistPref = distPref } - , savedHaddockFlags = (savedHaddockFlags config) { - haddockDistPref = distPref } - } - ) - ParseArgs - ] - - where - toSavedConfig lift options exclusions replacements = - [ lift (fromMaybe field replacement) - | opt <- options - , let field = viewAsFieldDescr opt - name = fieldName field - replacement = find ((== name) . fieldName) replacements - , name `notElem` exclusions ] - - showRelaxDeps Nothing = mempty - showRelaxDeps (Just rd) | isRelaxDeps rd = Disp.text "True" - | otherwise = Disp.text "False" - - toRelaxDeps True = RelaxDepsAll - toRelaxDeps False = mempty - - --- TODO: next step, make the deprecated fields elicit a warning. --- -deprecatedFieldDescriptions :: [FieldDescr SavedConfig] -deprecatedFieldDescriptions = - [ liftGlobalFlag $ - listFieldParsec "repos" - pretty parsec - (fromNubList . globalRemoteRepos) - (\rs cfg -> cfg { globalRemoteRepos = toNubList rs }) - , liftGlobalFlag $ - simpleField "cachedir" - (Disp.text . fromFlagOrDefault "") (optional parseFilePathQ) - globalCacheDir (\d cfg -> cfg { globalCacheDir = d }) - , liftUploadFlag $ - simpleField "hackage-username" - (Disp.text . fromFlagOrDefault "" . fmap unUsername) - (optional (fmap Username parseTokenQ)) - uploadUsername (\d cfg -> cfg { uploadUsername = d }) - , liftUploadFlag $ - simpleField "hackage-password" - (Disp.text . fromFlagOrDefault "" . fmap unPassword) - (optional (fmap Password parseTokenQ)) - uploadPassword (\d cfg -> cfg { uploadPassword = d }) - , liftUploadFlag $ - spaceListField "hackage-password-command" - Disp.text parseTokenQ - (fromFlagOrDefault [] . uploadPasswordCmd) - (\d cfg -> cfg { uploadPasswordCmd = Flag d }) - ] - ++ map (modifyFieldName ("user-"++) . liftUserInstallDirs) - installDirsFields - ++ map (modifyFieldName ("global-"++) . liftGlobalInstallDirs) - installDirsFields - where - optional = Parse.option mempty . fmap toFlag - modifyFieldName :: (String -> String) -> FieldDescr a -> FieldDescr a - modifyFieldName f d = d { fieldName = f (fieldName d) } - -liftUserInstallDirs :: FieldDescr (InstallDirs (Flag PathTemplate)) - -> FieldDescr SavedConfig -liftUserInstallDirs = liftField - savedUserInstallDirs (\flags conf -> conf { savedUserInstallDirs = flags }) - -liftGlobalInstallDirs :: FieldDescr (InstallDirs (Flag PathTemplate)) - -> FieldDescr SavedConfig -liftGlobalInstallDirs = - liftField savedGlobalInstallDirs - (\flags conf -> conf { savedGlobalInstallDirs = flags }) - -liftGlobalFlag :: FieldDescr GlobalFlags -> FieldDescr SavedConfig -liftGlobalFlag = liftField - savedGlobalFlags (\flags conf -> conf { savedGlobalFlags = flags }) - -liftConfigFlag :: FieldDescr ConfigFlags -> FieldDescr SavedConfig -liftConfigFlag = liftField - savedConfigureFlags (\flags conf -> conf { savedConfigureFlags = flags }) - -liftConfigExFlag :: FieldDescr ConfigExFlags -> FieldDescr SavedConfig -liftConfigExFlag = liftField - savedConfigureExFlags (\flags conf -> conf { savedConfigureExFlags = flags }) - -liftInstallFlag :: FieldDescr InstallFlags -> FieldDescr SavedConfig -liftInstallFlag = liftField - savedInstallFlags (\flags conf -> conf { savedInstallFlags = flags }) - -liftClientInstallFlag :: FieldDescr ClientInstallFlags -> FieldDescr SavedConfig -liftClientInstallFlag = - liftField savedClientInstallFlags - (\flags conf -> conf { savedClientInstallFlags = flags }) - -liftUploadFlag :: FieldDescr UploadFlags -> FieldDescr SavedConfig -liftUploadFlag = liftField - savedUploadFlags (\flags conf -> conf { savedUploadFlags = flags }) - -liftReportFlag :: FieldDescr ReportFlags -> FieldDescr SavedConfig -liftReportFlag = liftField - savedReportFlags (\flags conf -> conf { savedReportFlags = flags }) - -parseConfig :: ConstraintSource - -> SavedConfig - -> String - -> ParseResult SavedConfig -parseConfig src initial = \str -> do - fields <- readFields str - let (knownSections, others) = partition isKnownSection fields - config <- parse others - let init0 = savedInitFlags config - user0 = savedUserInstallDirs config - global0 = savedGlobalInstallDirs config - (remoteRepoSections0, localRepoSections0, haddockFlags, initFlags, user, global, paths, args) <- - foldM parseSections - ([], [], savedHaddockFlags config, init0, user0, global0, [], []) - knownSections - - let remoteRepoSections = - reverse - . nubBy ((==) `on` remoteRepoName) - $ remoteRepoSections0 - - let localRepoSections = - reverse - . nubBy ((==) `on` localRepoName) - $ localRepoSections0 - - return . fixConfigMultilines $ config { - savedGlobalFlags = (savedGlobalFlags config) { - globalRemoteRepos = toNubList remoteRepoSections, - globalLocalNoIndexRepos = toNubList localRepoSections, - -- the global extra prog path comes from the configure flag prog path - globalProgPathExtra = configProgramPathExtra (savedConfigureFlags config) - }, - savedConfigureFlags = (savedConfigureFlags config) { - configProgramPaths = paths, - configProgramArgs = args - }, - savedHaddockFlags = haddockFlags, - savedInitFlags = initFlags, - savedUserInstallDirs = user, - savedGlobalInstallDirs = global - } - - where - isKnownSection (ParseUtils.Section _ "repository" _ _) = True - isKnownSection (ParseUtils.F _ "remote-repo" _) = True - isKnownSection (ParseUtils.Section _ "haddock" _ _) = True - isKnownSection (ParseUtils.Section _ "init" _ _) = True - isKnownSection (ParseUtils.Section _ "install-dirs" _ _) = True - isKnownSection (ParseUtils.Section _ "program-locations" _ _) = True - isKnownSection (ParseUtils.Section _ "program-default-options" _ _) = True - isKnownSection _ = False - - -- Attempt to split fields that can represent lists of paths into - -- actual lists on failure, leave the field untouched. - splitMultiPath :: [String] -> [String] - splitMultiPath [s] = case runP 0 "" (parseOptCommaList parseTokenQ) s of - ParseOk _ res -> res - _ -> [s] - splitMultiPath xs = xs - - -- This is a fixup, pending a full config parser rewrite, to - -- ensure that config fields which can be comma-separated lists - -- actually parse as comma-separated lists. - fixConfigMultilines conf = conf { - savedConfigureFlags = - let scf = savedConfigureFlags conf - in scf { - configProgramPathExtra = - toNubList $ splitMultiPath - (fromNubList $ configProgramPathExtra scf) - , configExtraLibDirs = splitMultiPath - (configExtraLibDirs scf) - , configExtraFrameworkDirs = splitMultiPath - (configExtraFrameworkDirs scf) - , configExtraIncludeDirs = splitMultiPath - (configExtraIncludeDirs scf) - , configConfigureArgs = splitMultiPath - (configConfigureArgs scf) - } - } - - parse = parseFields (configFieldDescriptions src - ++ deprecatedFieldDescriptions) initial - - parseSections (rs, ls, h, i, u, g, p, a) - (ParseUtils.Section lineno "repository" name fs) = do - name' <- maybe (ParseFailed $ NoParse "repository name" lineno) return $ - simpleParsec name - r' <- parseFields remoteRepoFields (emptyRemoteRepo name') fs - r'' <- postProcessRepo lineno name r' - case r'' of - Left local -> return (rs, local:ls, h, i, u, g, p, a) - Right remote -> return (remote:rs, ls, h, i, u, g, p, a) - - parseSections (rs, ls, h, i, u, g, p, a) - (ParseUtils.F lno "remote-repo" raw) = do - let mr' = simpleParsec raw - r' <- maybe (ParseFailed $ NoParse "remote-repo" lno) return mr' - return (r':rs, ls, h, i, u, g, p, a) - - parseSections accum@(rs, ls, h, i, u, g, p, a) - (ParseUtils.Section _ "haddock" name fs) - | name == "" = do h' <- parseFields haddockFlagsFields h fs - return (rs, ls, h', i, u, g, p, a) - | otherwise = do - warning "The 'haddock' section should be unnamed" - return accum - - parseSections accum@(rs, ls, h, i, u, g, p, a) - (ParseUtils.Section _ "init" name fs) - | name == "" = do i' <- parseFields initFlagsFields i fs - return (rs, ls, h, i', u, g, p, a) - | otherwise = do - warning "The 'init' section should be unnamed" - return accum - - parseSections accum@(rs, ls, h, i, u, g, p, a) - (ParseUtils.Section _ "install-dirs" name fs) - | name' == "user" = do u' <- parseFields installDirsFields u fs - return (rs, ls, h, i, u', g, p, a) - | name' == "global" = do g' <- parseFields installDirsFields g fs - return (rs, ls, h, i, u, g', p, a) - | otherwise = do - warning "The 'install-paths' section should be for 'user' or 'global'" - return accum - where name' = lowercase name - parseSections accum@(rs, ls, h, i, u, g, p, a) - (ParseUtils.Section _ "program-locations" name fs) - | name == "" = do p' <- parseFields withProgramsFields p fs - return (rs, ls, h, i, u, g, p', a) - | otherwise = do - warning "The 'program-locations' section should be unnamed" - return accum - parseSections accum@(rs, ls, h, i, u, g, p, a) - (ParseUtils.Section _ "program-default-options" name fs) - | name == "" = do a' <- parseFields withProgramOptionsFields a fs - return (rs, ls, h, i, u, g, p, a') - | otherwise = do - warning "The 'program-default-options' section should be unnamed" - return accum - parseSections accum f = do - warning $ "Unrecognized stanza on line " ++ show (lineNo f) - return accum - -postProcessRepo :: Int -> String -> RemoteRepo -> ParseResult (Either LocalRepo RemoteRepo) -postProcessRepo lineno reponameStr repo0 = do - when (null reponameStr) $ - syntaxError lineno $ "a 'repository' section requires the " - ++ "repository name as an argument" - - reponame <- maybe (fail $ "Invalid repository name " ++ reponameStr) return $ - simpleParsec reponameStr - - case uriScheme (remoteRepoURI repo0) of - -- TODO: check that there are no authority, query or fragment - -- Note: the trailing colon is important - "file+noindex:" -> do - let uri = remoteRepoURI repo0 - return $ Left $ LocalRepo reponame (uriPath uri) (uriFragment uri == "#shared-cache") - - _ -> do - let repo = repo0 { remoteRepoName = reponame } - - when (remoteRepoKeyThreshold repo > length (remoteRepoRootKeys repo)) $ - warning $ "'key-threshold' for repository " - ++ show (remoteRepoName repo) - ++ " higher than number of keys" - - when (not (null (remoteRepoRootKeys repo)) && remoteRepoSecure repo /= Just True) $ - warning $ "'root-keys' for repository " - ++ show (remoteRepoName repo) - ++ " non-empty, but 'secure' not set to True." - - return $ Right repo - -showConfig :: SavedConfig -> String -showConfig = showConfigWithComments mempty - -showConfigWithComments :: SavedConfig -> SavedConfig -> String -showConfigWithComments comment vals = Disp.render $ - case fmap (uncurry ppRemoteRepoSection) - (zip (getRemoteRepos comment) (getRemoteRepos vals)) of - [] -> Disp.text "" - (x:xs) -> foldl' (\ r r' -> r $+$ Disp.text "" $+$ r') x xs - $+$ Disp.text "" - $+$ ppFields - (skipSomeFields (configFieldDescriptions ConstraintSourceUnknown)) - mcomment vals - $+$ Disp.text "" - $+$ ppSection "haddock" "" haddockFlagsFields - (fmap savedHaddockFlags mcomment) (savedHaddockFlags vals) - $+$ Disp.text "" - $+$ ppSection "init" "" initFlagsFields - (fmap savedInitFlags mcomment) (savedInitFlags vals) - $+$ Disp.text "" - $+$ installDirsSection "user" savedUserInstallDirs - $+$ Disp.text "" - $+$ installDirsSection "global" savedGlobalInstallDirs - $+$ Disp.text "" - $+$ configFlagsSection "program-locations" withProgramsFields - configProgramPaths - $+$ Disp.text "" - $+$ configFlagsSection "program-default-options" withProgramOptionsFields - configProgramArgs - where - getRemoteRepos = fromNubList . globalRemoteRepos . savedGlobalFlags - mcomment = Just comment - installDirsSection name field = - ppSection "install-dirs" name installDirsFields - (fmap field mcomment) (field vals) - configFlagsSection name fields field = - ppSection name "" fields - (fmap (field . savedConfigureFlags) mcomment) - ((field . savedConfigureFlags) vals) - - -- skip fields based on field name. currently only skips "remote-repo", - -- because that is rendered as a section. (see 'ppRemoteRepoSection'.) - skipSomeFields = filter ((/= "remote-repo") . fieldName) - --- | Fields for the 'install-dirs' sections. -installDirsFields :: [FieldDescr (InstallDirs (Flag PathTemplate))] -installDirsFields = map viewAsFieldDescr installDirsOptions - -ppRemoteRepoSection :: RemoteRepo -> RemoteRepo -> Doc -ppRemoteRepoSection def vals = ppSection "repository" (unRepoName (remoteRepoName vals)) - remoteRepoFields (Just def) vals - -remoteRepoFields :: [FieldDescr RemoteRepo] -remoteRepoFields = - [ simpleField "url" - (text . show) (parseTokenQ >>= parseURI') - remoteRepoURI (\x repo -> repo { remoteRepoURI = x }) - , simpleFieldParsec "secure" - showSecure (Just `fmap` parsec) - remoteRepoSecure (\x repo -> repo { remoteRepoSecure = x }) - , listField "root-keys" - text parseTokenQ - remoteRepoRootKeys (\x repo -> repo { remoteRepoRootKeys = x }) - , simpleFieldParsec "key-threshold" - showThreshold P.integral - remoteRepoKeyThreshold (\x repo -> repo { remoteRepoKeyThreshold = x }) - ] - where - parseURI' uriString = - case parseURI uriString of - Nothing -> fail $ "remote-repo: no parse on " ++ show uriString - Just uri -> return uri - - showSecure Nothing = mempty -- default 'secure' setting - showSecure (Just True) = text "True" -- user explicitly enabled it - showSecure (Just False) = text "False" -- user explicitly disabled it - - -- If the key-threshold is set to 0, we omit it as this is the default - -- and it looks odd to have a value for key-threshold but not for 'secure' - -- (note that an empty list of keys is already omitted by default, since - -- that is what we do for all list fields) - showThreshold 0 = mempty - showThreshold t = text (show t) - --- | Fields for the 'haddock' section. -haddockFlagsFields :: [FieldDescr HaddockFlags] -haddockFlagsFields = [ field - | opt <- haddockOptions ParseArgs - , let field = viewAsFieldDescr opt - name = fieldName field - , name `notElem` exclusions ] - where - exclusions = ["verbose", "builddir", "for-hackage"] - --- | Fields for the 'init' section. -initFlagsFields :: [FieldDescr IT.InitFlags] -initFlagsFields = [ field - | opt <- initOptions ParseArgs - , let field = viewAsFieldDescr opt - name = fieldName field - , name `notElem` exclusions ] - where - exclusions = - [ "author", "email", "quiet", "no-comments", "minimal", "overwrite" - , "package-dir", "packagedir", "package-name", "version", "homepage" - , "synopsis", "category", "extra-source-file", "lib", "exe", "libandexe" - , "simple", "main-is", "expose-module", "exposed-modules", "extension" - , "dependency", "build-tool", "with-compiler" - , "verbose" - ] - --- | Fields for the 'program-locations' section. -withProgramsFields :: [FieldDescr [(String, FilePath)]] -withProgramsFields = - map viewAsFieldDescr $ - programDbPaths' (++ "-location") defaultProgramDb - ParseArgs id (++) - --- | Fields for the 'program-default-options' section. -withProgramOptionsFields :: [FieldDescr [(String, [String])]] -withProgramOptionsFields = - map viewAsFieldDescr $ - programDbOptions defaultProgramDb ParseArgs id (++) - -parseExtraLines :: Verbosity -> [String] -> IO SavedConfig -parseExtraLines verbosity extraLines = - case parseConfig (ConstraintSourceMainConfig "additional lines") - mempty (unlines extraLines) of - ParseFailed err -> - let (line, msg) = locatedErrorMsg err - in die' verbosity $ - "Error parsing additional config lines\n" - ++ maybe "" (\n -> ':' : show n) line ++ ":\n" ++ msg - ParseOk [] r -> return r - ParseOk ws _ -> - die' verbosity $ - unlines (map (showPWarning "Error parsing additional config lines") ws) - --- | Get the differences (as a pseudo code diff) between the user's --- '~/.cabal/config' and the one that cabal would generate if it didn't exist. -userConfigDiff :: Verbosity -> GlobalFlags -> [String] -> IO [String] -userConfigDiff verbosity globalFlags extraLines = do - userConfig <- loadRawConfig normal (globalConfigFile globalFlags) - extraConfig <- parseExtraLines verbosity extraLines - testConfig <- initialSavedConfig - return $ - reverse . foldl' createDiff [] . M.toList - $ M.unionWith combine - (M.fromList . map justFst $ filterShow testConfig) - (M.fromList . map justSnd $ filterShow (userConfig `mappend` extraConfig)) - where - justFst (a, b) = (a, (Just b, Nothing)) - justSnd (a, b) = (a, (Nothing, Just b)) - - combine (Nothing, Just b) (Just a, Nothing) = (Just a, Just b) - combine (Just a, Nothing) (Nothing, Just b) = (Just a, Just b) - combine x y = error $ "Can't happen : userConfigDiff " - ++ show x ++ " " ++ show y - - createDiff :: [String] -> (String, (Maybe String, Maybe String)) -> [String] - createDiff acc (key, (Just a, Just b)) - | a == b = acc - | otherwise = ("+ " ++ key ++ ": " ++ b) - : ("- " ++ key ++ ": " ++ a) : acc - createDiff acc (key, (Nothing, Just b)) = ("+ " ++ key ++ ": " ++ b) : acc - createDiff acc (key, (Just a, Nothing)) = ("- " ++ key ++ ": " ++ a) : acc - createDiff acc (_, (Nothing, Nothing)) = acc - - filterShow :: SavedConfig -> [(String, String)] - filterShow cfg = map keyValueSplit - . filter (\s -> not (null s) && ':' `elem` s) - . map nonComment - . lines - $ showConfig cfg - - nonComment [] = [] - nonComment ('-':'-':_) = [] - nonComment (x:xs) = x : nonComment xs - - topAndTail = reverse . dropWhile isSpace . reverse . dropWhile isSpace - - keyValueSplit s = - let (left, right) = break (== ':') s - in (topAndTail left, topAndTail (drop 1 right)) - - --- | Update the user's ~/.cabal/config' keeping the user's customizations. -userConfigUpdate :: Verbosity -> GlobalFlags -> [String] -> IO () -userConfigUpdate verbosity globalFlags extraLines = do - userConfig <- loadRawConfig normal (globalConfigFile globalFlags) - extraConfig <- parseExtraLines verbosity extraLines - newConfig <- initialSavedConfig - commentConf <- commentSavedConfig - cabalFile <- getConfigFilePath $ globalConfigFile globalFlags - let backup = cabalFile ++ ".backup" - notice verbosity $ "Renaming " ++ cabalFile ++ " to " ++ backup ++ "." - renameFile cabalFile backup - notice verbosity $ "Writing merged config to " ++ cabalFile ++ "." - writeConfigFile cabalFile commentConf - (newConfig `mappend` userConfig `mappend` extraConfig) diff --git a/cabal/cabal-install/Distribution/Client/Configure.hs b/cabal/cabal-install/Distribution/Client/Configure.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Configure.hs +++ /dev/null @@ -1,464 +0,0 @@ -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Configure --- Copyright : (c) David Himmelstrup 2005, --- Duncan Coutts 2005 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- High level interface to configuring a package. ------------------------------------------------------------------------------ -module Distribution.Client.Configure ( - configure, - configureSetupScript, - chooseCabalVersion, - checkConfigExFlags, - -- * Saved configure flags - readConfigFlagsFrom, readConfigFlags, - cabalConfigFlagsFile, - writeConfigFlagsTo, writeConfigFlags, - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude -import Distribution.Utils.Generic (safeHead) - -import Distribution.Client.Dependency -import qualified Distribution.Client.InstallPlan as InstallPlan -import Distribution.Client.SolverInstallPlan (SolverInstallPlan) -import Distribution.Client.IndexUtils as IndexUtils - ( getSourcePackages, getInstalledPackages ) -import Distribution.Client.Setup - ( ConfigExFlags(..), RepoContext(..) - , configureCommand, configureExCommand, filterConfigureFlags ) -import Distribution.Client.Types as Source -import Distribution.Client.SetupWrapper - ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) -import Distribution.Client.Targets - ( userToPackageConstraint, userConstraintPackageName ) -import Distribution.Client.JobControl (Lock) - -import qualified Distribution.Solver.Types.ComponentDeps as CD -import Distribution.Solver.Types.Settings -import Distribution.Solver.Types.ConstraintSource -import Distribution.Solver.Types.LabeledPackageConstraint -import Distribution.Solver.Types.OptionalStanza -import Distribution.Solver.Types.PackageIndex - ( PackageIndex, elemByPackageName ) -import Distribution.Solver.Types.PkgConfigDb - (PkgConfigDb, readPkgConfigDb) -import Distribution.Solver.Types.SourcePackage - -import Distribution.Simple.Compiler - ( Compiler, CompilerInfo, compilerInfo, PackageDB(..), PackageDBStack ) -import Distribution.Simple.Program (ProgramDb) -import Distribution.Client.SavedFlags ( readCommandFlags, writeCommandFlags ) -import Distribution.Simple.Setup - ( ConfigFlags(..) - , fromFlag, toFlag, flagToMaybe, fromFlagOrDefault ) -import Distribution.Simple.PackageIndex - ( InstalledPackageIndex, lookupPackageName ) -import Distribution.Package - ( Package(..), packageName, PackageId ) -import Distribution.Types.GivenComponent - ( GivenComponent(..) ) -import Distribution.Types.PackageVersionConstraint - ( PackageVersionConstraint(..), thisPackageVersionConstraint ) -import qualified Distribution.PackageDescription as PkgDesc -import Distribution.PackageDescription.Parsec - ( readGenericPackageDescription ) -import Distribution.PackageDescription.Configuration - ( finalizePD ) -import Distribution.Version - ( Version, mkVersion, anyVersion, thisVersion - , VersionRange, orLaterVersion ) -import Distribution.Simple.Utils as Utils - ( warn, notice, debug, die' - , defaultPackageDesc ) -import Distribution.System - ( Platform ) - -import System.FilePath ( () ) - --- | Choose the Cabal version such that the setup scripts compiled against this --- version will support the given command-line flags. -chooseCabalVersion :: ConfigExFlags -> Maybe Version -> VersionRange -chooseCabalVersion configExFlags maybeVersion = - maybe defaultVersionRange thisVersion maybeVersion - where - -- Cabal < 1.19.2 doesn't support '--exact-configuration' which is needed - -- for '--allow-newer' to work. - allowNewer = isRelaxDeps - (maybe mempty unAllowNewer $ configAllowNewer configExFlags) - allowOlder = isRelaxDeps - (maybe mempty unAllowOlder $ configAllowOlder configExFlags) - - defaultVersionRange = if allowOlder || allowNewer - then orLaterVersion (mkVersion [1,19,2]) - else anyVersion - --- | Configure the package found in the local directory -configure :: Verbosity - -> PackageDBStack - -> RepoContext - -> Compiler - -> Platform - -> ProgramDb - -> ConfigFlags - -> ConfigExFlags - -> [String] - -> IO () -configure verbosity packageDBs repoCtxt comp platform progdb - configFlags configExFlags extraArgs = do - - installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb - sourcePkgDb <- getSourcePackages verbosity repoCtxt - pkgConfigDb <- readPkgConfigDb verbosity progdb - - checkConfigExFlags verbosity installedPkgIndex - (packageIndex sourcePkgDb) configExFlags - - progress <- planLocalPackage verbosity comp platform configFlags configExFlags - installedPkgIndex sourcePkgDb pkgConfigDb - - notice verbosity "Resolving dependencies..." - maybePlan <- foldProgress logMsg (return . Left) (return . Right) - progress - case maybePlan of - Left message -> do - warn verbosity $ - "solver failed to find a solution:\n" - ++ message - ++ "\nTrying configure anyway." - setupWrapper verbosity (setupScriptOptions installedPkgIndex Nothing) - Nothing configureCommand (const configFlags) (const extraArgs) - - Right installPlan0 -> - let installPlan = InstallPlan.configureInstallPlan configFlags installPlan0 - in case fst (InstallPlan.ready installPlan) of - [pkg@(ReadyPackage - (ConfiguredPackage _ (SourcePackage _ _ (LocalUnpackedPackage _) _) - _ _ _))] -> do - configurePackage verbosity - platform (compilerInfo comp) - (setupScriptOptions installedPkgIndex (Just pkg)) - configFlags pkg extraArgs - - _ -> die' verbosity $ "internal error: configure install plan should have exactly " - ++ "one local ready package." - - where - setupScriptOptions :: InstalledPackageIndex - -> Maybe ReadyPackage - -> SetupScriptOptions - setupScriptOptions = - configureSetupScript - packageDBs - comp - platform - progdb - (fromFlagOrDefault - (useDistPref defaultSetupScriptOptions) - (configDistPref configFlags)) - (chooseCabalVersion - configExFlags - (flagToMaybe (configCabalVersion configExFlags))) - Nothing - False - - logMsg message rest = debug verbosity message >> rest - -configureSetupScript :: PackageDBStack - -> Compiler - -> Platform - -> ProgramDb - -> FilePath - -> VersionRange - -> Maybe Lock - -> Bool - -> InstalledPackageIndex - -> Maybe ReadyPackage - -> SetupScriptOptions -configureSetupScript packageDBs - comp - platform - progdb - distPref - cabalVersion - lock - forceExternal - index - mpkg - = SetupScriptOptions { - useCabalVersion = cabalVersion - , useCabalSpecVersion = Nothing - , useCompiler = Just comp - , usePlatform = Just platform - , usePackageDB = packageDBs' - , usePackageIndex = index' - , useProgramDb = progdb - , useDistPref = distPref - , useLoggingHandle = Nothing - , useWorkingDir = Nothing - , useExtraPathEnv = [] - , 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 - -- `compileSetupExecutable` in `externalSetupMethod`, but we don't yet - -- know the version of Cabal at this point, but only find this there. - -- Therefore, for now, we just leave this blank. - , useDependencies = fromMaybe [] explicitSetupDeps - , useDependenciesExclusive = not defaultSetupDeps && isJust explicitSetupDeps - , useVersionMacros = not defaultSetupDeps && isJust explicitSetupDeps - , isInteractive = False - } - where - -- When we are compiling a legacy setup script without an explicit - -- setup stanza, we typically want to allow the UserPackageDB for - -- finding the Cabal lib when compiling any Setup.hs even if we're doing - -- a global install. However we also allow looking in a specific package - -- db. - packageDBs' :: PackageDBStack - index' :: Maybe InstalledPackageIndex - (packageDBs', index') = - case packageDBs of - (GlobalPackageDB:dbs) | UserPackageDB `notElem` dbs - , Nothing <- explicitSetupDeps - -> (GlobalPackageDB:UserPackageDB:dbs, Nothing) - -- but if the user is using an odd db stack, don't touch it - _otherwise -> (packageDBs, Just index) - - maybeSetupBuildInfo :: Maybe PkgDesc.SetupBuildInfo - maybeSetupBuildInfo = do - ReadyPackage cpkg <- mpkg - let gpkg = srcpkgDescription (confPkgSource cpkg) - PkgDesc.setupBuildInfo (PkgDesc.packageDescription gpkg) - - -- Was a default 'custom-setup' stanza added by 'cabal-install' itself? If - -- so, 'setup-depends' must not be exclusive. See #3199. - defaultSetupDeps :: Bool - defaultSetupDeps = maybe False PkgDesc.defaultSetupDepends - maybeSetupBuildInfo - - explicitSetupDeps :: Maybe [(InstalledPackageId, PackageId)] - explicitSetupDeps = do - -- Check if there is an explicit setup stanza. - _buildInfo <- maybeSetupBuildInfo - -- Return the setup dependencies computed by the solver - ReadyPackage cpkg <- mpkg - return [ ( cid, srcid ) - | ConfiguredId srcid - (Just (PkgDesc.CLibName PkgDesc.LMainLibName)) cid - <- CD.setupDeps (confPkgDeps cpkg) - ] - --- | Warn if any constraints or preferences name packages that are not in the --- source package index or installed package index. -checkConfigExFlags :: Package pkg - => Verbosity - -> InstalledPackageIndex - -> PackageIndex pkg - -> ConfigExFlags - -> IO () -checkConfigExFlags verbosity installedPkgIndex sourcePkgIndex flags = do - for_ (safeHead unknownConstraints) $ \h -> - warn verbosity $ "Constraint refers to an unknown package: " - ++ showConstraint h - for_ (safeHead unknownPreferences) $ \h -> - warn verbosity $ "Preference refers to an unknown package: " - ++ prettyShow h - where - unknownConstraints = filter (unknown . userConstraintPackageName . fst) $ - configExConstraints flags - unknownPreferences = filter (unknown . \(PackageVersionConstraint name _) -> name) $ - configPreferences flags - unknown pkg = null (lookupPackageName installedPkgIndex pkg) - && not (elemByPackageName sourcePkgIndex pkg) - showConstraint (uc, src) = - prettyShow uc ++ " (" ++ showConstraintSource src ++ ")" - --- | Make an 'InstallPlan' for the unpacked package in the current directory, --- and all its dependencies. --- -planLocalPackage :: Verbosity -> Compiler - -> Platform - -> ConfigFlags -> ConfigExFlags - -> InstalledPackageIndex - -> SourcePackageDb - -> PkgConfigDb - -> IO (Progress String String SolverInstallPlan) -planLocalPackage verbosity comp platform configFlags configExFlags - installedPkgIndex (SourcePackageDb _ packagePrefs) pkgConfigDb = do - pkg <- readGenericPackageDescription verbosity =<< - case flagToMaybe (configCabalFilePath configFlags) of - Nothing -> defaultPackageDesc verbosity - Just fp -> return fp - solver <- chooseSolver verbosity (fromFlag $ configSolver configExFlags) - (compilerInfo comp) - - let -- We create a local package and ask to resolve a dependency on it - localPkg = SourcePackage { - srcpkgPackageId = packageId pkg, - srcpkgDescription = pkg, - srcpkgSource = LocalUnpackedPackage ".", - srcpkgDescrOverride = Nothing - } - - testsEnabled = fromFlagOrDefault False $ configTests configFlags - benchmarksEnabled = - fromFlagOrDefault False $ configBenchmarks configFlags - - resolverParams = - removeLowerBounds - (fromMaybe (AllowOlder mempty) $ configAllowOlder configExFlags) - . removeUpperBounds - (fromMaybe (AllowNewer mempty) $ configAllowNewer configExFlags) - - . addPreferences - -- preferences from the config file or command line - [ PackageVersionPreference name ver - | PackageVersionConstraint name ver <- configPreferences configExFlags ] - - . addConstraints - -- version constraints from the config file or command line - -- TODO: should warn or error on constraints that are not on direct - -- deps or flag constraints not on the package in question. - [ LabeledPackageConstraint (userToPackageConstraint uc) src - | (uc, src) <- configExConstraints configExFlags ] - - . addConstraints - -- package flags from the config file or command line - [ let pc = PackageConstraint - (scopeToplevel $ packageName pkg) - (PackagePropertyFlags $ configConfigurationsFlags configFlags) - in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget - ] - - . addConstraints - -- '--enable-tests' and '--enable-benchmarks' constraints from - -- the config file or command line - [ let pc = PackageConstraint (scopeToplevel $ packageName pkg) . - PackagePropertyStanzas $ - [ TestStanzas | testsEnabled ] ++ - [ BenchStanzas | benchmarksEnabled ] - in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget - ] - - -- Don't solve for executables, since we use an empty source - -- package database and executables never show up in the - -- installed package index - . setSolveExecutables (SolveExecutables False) - - . setSolverVerbosity 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 solver resolverParams) - - --- | Call an installer for an 'SourcePackage' but override the configure --- flags with the ones given by the 'ReadyPackage'. In particular the --- 'ReadyPackage' specifies an exact 'FlagAssignment' and exactly --- versioned package dependencies. So we ignore any previous partial flag --- assignment or dependency constraints and use the new ones. --- --- NB: when updating this function, don't forget to also update --- 'installReadyPackage' in D.C.Install. -configurePackage :: Verbosity - -> Platform -> CompilerInfo - -> SetupScriptOptions - -> ConfigFlags - -> ReadyPackage - -> [String] - -> IO () -configurePackage verbosity platform comp scriptOptions configFlags - (ReadyPackage (ConfiguredPackage ipid spkg flags stanzas deps)) - extraArgs = - - setupWrapper verbosity - scriptOptions (Just pkg) configureCommand configureFlags (const extraArgs) - - where - gpkg = srcpkgDescription spkg - configureFlags = filterConfigureFlags configFlags { - configIPID = if isJust (flagToMaybe (configIPID configFlags)) - -- Make sure cabal configure --ipid works. - then configIPID configFlags - else toFlag (prettyShow ipid), - configConfigurationsFlags = flags, - -- We generate the legacy constraints as well as the new style precise - -- deps. In the end only one set gets passed to Setup.hs configure, - -- depending on the Cabal version we are talking to. - configConstraints = [ thisPackageVersionConstraint srcid - | ConfiguredId srcid (Just (PkgDesc.CLibName PkgDesc.LMainLibName)) _uid - <- CD.nonSetupDeps deps ], - configDependencies = [ GivenComponent (packageName srcid) cname uid - | ConfiguredId srcid (Just (PkgDesc.CLibName cname)) uid - <- CD.nonSetupDeps deps ], - -- Use '--exact-configuration' if supported. - configExactConfiguration = toFlag True, - configVerbosity = toFlag verbosity, - -- NB: if the user explicitly specified - -- --enable-tests/--enable-benchmarks, always respect it. - -- (But if they didn't, let solver decide.) - configBenchmarks = toFlag (BenchStanzas `elem` stanzas) - `mappend` configBenchmarks configFlags, - configTests = toFlag (TestStanzas `elem` stanzas) - `mappend` configTests configFlags - } - - pkg = case finalizePD flags (enableStanzas stanzas) - (const True) - platform comp [] gpkg of - Left _ -> error "finalizePD ReadyPackage failed" - Right (desc, _) -> desc - --- ----------------------------------------------------------------------------- --- * Saved configure environments and flags --- ----------------------------------------------------------------------------- - --- | Read saved configure flags and restore the saved environment from the --- specified files. -readConfigFlagsFrom :: FilePath -- ^ path to saved flags file - -> IO (ConfigFlags, ConfigExFlags) -readConfigFlagsFrom flags = do - readCommandFlags flags configureExCommand - --- | The path (relative to @--build-dir@) where the arguments to @configure@ --- should be saved. -cabalConfigFlagsFile :: FilePath -> FilePath -cabalConfigFlagsFile dist = dist "cabal-config-flags" - --- | Read saved configure flags and restore the saved environment from the --- usual location. -readConfigFlags :: FilePath -- ^ @--build-dir@ - -> IO (ConfigFlags, ConfigExFlags) -readConfigFlags dist = - readConfigFlagsFrom (cabalConfigFlagsFile dist) - --- | Save the configure flags and environment to the specified files. -writeConfigFlagsTo :: FilePath -- ^ path to saved flags file - -> Verbosity -> (ConfigFlags, ConfigExFlags) - -> IO () -writeConfigFlagsTo file verb flags = do - writeCommandFlags verb file configureExCommand flags - --- | Save the build flags to the usual location. -writeConfigFlags :: Verbosity - -> FilePath -- ^ @--build-dir@ - -> (ConfigFlags, ConfigExFlags) -> IO () -writeConfigFlags verb dist = - writeConfigFlagsTo (cabalConfigFlagsFile dist) verb diff --git a/cabal/cabal-install/Distribution/Client/Dependency.hs b/cabal/cabal-install/Distribution/Client/Dependency.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Dependency.hs +++ /dev/null @@ -1,1052 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Dependency --- Copyright : (c) David Himmelstrup 2005, --- Bjorn Bringert 2007 --- Duncan Coutts 2008 --- License : BSD-like --- --- Maintainer : cabal-devel@gmail.com --- Stability : provisional --- Portability : portable --- --- Top level interface to dependency resolution. ------------------------------------------------------------------------------ -module Distribution.Client.Dependency ( - -- * The main package dependency resolver - chooseSolver, - resolveDependencies, - Progress(..), - foldProgress, - - -- * Alternate, simple resolver that does not do dependencies recursively - resolveWithoutDependencies, - - -- * Constructing resolver policies - PackageProperty(..), - PackageConstraint(..), - scopeToplevel, - PackagesPreferenceDefault(..), - PackagePreference(..), - - -- ** Standard policy - basicInstallPolicy, - standardInstallPolicy, - PackageSpecifier(..), - - -- ** Extra policy options - upgradeDependencies, - reinstallTargets, - - -- ** Policy utils - addConstraints, - addPreferences, - setPreferenceDefault, - setReorderGoals, - setCountConflicts, - setFineGrainedConflicts, - setMinimizeConflictSet, - setIndependentGoals, - setAvoidReinstalls, - setShadowPkgs, - setStrongFlags, - setAllowBootLibInstalls, - setOnlyConstrained, - setMaxBackjumps, - setEnableBackjumping, - setSolveExecutables, - setGoalOrder, - setSolverVerbosity, - removeLowerBounds, - removeUpperBounds, - addDefaultSetupDependencies, - addSetupCabalMinVersionConstraint, - addSetupCabalMaxVersionConstraint, - ) where - -import Distribution.Client.Compat.Prelude -import qualified Prelude as Unsafe (head) - -import Distribution.Solver.Modular - ( modularResolver, SolverConfig(..), PruneAfterFirstSuccess(..) ) -import Distribution.Simple.PackageIndex (InstalledPackageIndex) -import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex -import Distribution.Client.SolverInstallPlan (SolverInstallPlan) -import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan -import Distribution.Client.Types - ( SourcePackageDb(SourcePackageDb) - , PackageSpecifier(..), pkgSpecifierTarget, pkgSpecifierConstraints - , UnresolvedPkgLoc, UnresolvedSourcePackage - , AllowNewer(..), AllowOlder(..), RelaxDeps(..), RelaxedDep(..) - , RelaxDepScope(..), RelaxDepMod(..), RelaxDepSubject(..), isRelaxDeps - ) -import Distribution.Client.Dependency.Types - ( PreSolver(..), Solver(..) - , PackagesPreferenceDefault(..) ) -import Distribution.Package - ( PackageName, mkPackageName, PackageIdentifier(PackageIdentifier), PackageId - , Package(..), packageName, packageVersion ) -import Distribution.Types.Dependency -import qualified Distribution.PackageDescription as PD -import qualified Distribution.PackageDescription.Configuration as PD -import Distribution.PackageDescription.Configuration - ( finalizePD ) -import Distribution.Compiler - ( CompilerInfo(..) ) -import Distribution.System - ( Platform ) -import Distribution.Client.Utils - ( duplicatesBy, mergeBy, MergeResult(..) ) -import Distribution.Simple.Setup - ( asBool ) -import Distribution.Verbosity - ( normal ) -import Distribution.Version -import qualified Distribution.Compat.Graph as Graph - -import Distribution.Solver.Types.ComponentDeps (ComponentDeps) -import qualified Distribution.Solver.Types.ComponentDeps as CD -import Distribution.Solver.Types.ConstraintSource -import Distribution.Solver.Types.DependencyResolver -import Distribution.Solver.Types.InstalledPreference -import Distribution.Solver.Types.LabeledPackageConstraint -import Distribution.Solver.Types.OptionalStanza -import Distribution.Solver.Types.PackageConstraint -import Distribution.Solver.Types.PackagePath -import Distribution.Solver.Types.PackagePreferences -import qualified Distribution.Solver.Types.PackageIndex as PackageIndex -import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb) -import Distribution.Solver.Types.Progress -import Distribution.Solver.Types.ResolverPackage -import Distribution.Solver.Types.Settings -import Distribution.Solver.Types.SolverId -import Distribution.Solver.Types.SolverPackage -import Distribution.Solver.Types.SourcePackage -import Distribution.Solver.Types.Variable - -import Data.List - ( maximumBy ) -import qualified Data.Map as Map -import qualified Data.Set as Set -import Control.Exception - ( assert ) - - --- ------------------------------------------------------------ --- * High level planner policy --- ------------------------------------------------------------ - --- | The set of parameters to the dependency resolver. These parameters are --- relatively low level but many kinds of high level policies can be --- implemented in terms of adjustments to the parameters. --- -data DepResolverParams = DepResolverParams { - depResolverTargets :: Set PackageName, - depResolverConstraints :: [LabeledPackageConstraint], - depResolverPreferences :: [PackagePreference], - depResolverPreferenceDefault :: PackagesPreferenceDefault, - depResolverInstalledPkgIndex :: InstalledPackageIndex, - depResolverSourcePkgIndex :: PackageIndex.PackageIndex UnresolvedSourcePackage, - depResolverReorderGoals :: ReorderGoals, - depResolverCountConflicts :: CountConflicts, - depResolverFineGrainedConflicts :: FineGrainedConflicts, - depResolverMinimizeConflictSet :: MinimizeConflictSet, - depResolverIndependentGoals :: IndependentGoals, - depResolverAvoidReinstalls :: AvoidReinstalls, - depResolverShadowPkgs :: ShadowPkgs, - depResolverStrongFlags :: StrongFlags, - - -- | Whether to allow base and its dependencies to be installed. - depResolverAllowBootLibInstalls :: AllowBootLibInstalls, - - -- | Whether to only allow explicitly constrained packages plus - -- goals or to allow any package. - depResolverOnlyConstrained :: OnlyConstrained, - - depResolverMaxBackjumps :: Maybe Int, - depResolverEnableBackjumping :: EnableBackjumping, - -- | Whether or not to solve for dependencies on executables. - -- This should be true, except in the legacy code path where - -- we can't tell if an executable has been installed or not, - -- so we shouldn't solve for them. See #3875. - depResolverSolveExecutables :: SolveExecutables, - - -- | Function to override the solver's goal-ordering heuristics. - depResolverGoalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering), - depResolverVerbosity :: Verbosity - } - -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) - where - showLabeledConstraint :: LabeledPackageConstraint -> String - showLabeledConstraint (LabeledPackageConstraint pc src) = - showPackageConstraint pc ++ " (" ++ showConstraintSource src ++ ")" - --- | A package selection preference for a particular package. --- --- Preferences are soft constraints that the dependency resolver should try to --- respect where possible. It is not specified if preferences on some packages --- are more important than others. --- -data PackagePreference = - - -- | A suggested constraint on the version number. - PackageVersionPreference PackageName VersionRange - - -- | If we prefer versions of packages that are already installed. - | PackageInstalledPreference PackageName InstalledPreference - - -- | If we would prefer to enable these optional stanzas - -- (i.e. test suites and/or benchmarks) - | PackageStanzasPreference PackageName [OptionalStanza] - - --- | Provide a textual representation of a package preference --- for debugging purposes. --- -showPackagePreference :: PackagePreference -> String -showPackagePreference (PackageVersionPreference pn vr) = - prettyShow pn ++ " " ++ prettyShow (simplifyVersionRange vr) -showPackagePreference (PackageInstalledPreference pn ip) = - prettyShow pn ++ " " ++ show ip -showPackagePreference (PackageStanzasPreference pn st) = - prettyShow pn ++ " " ++ show st - -basicDepResolverParams :: InstalledPackageIndex - -> PackageIndex.PackageIndex UnresolvedSourcePackage - -> DepResolverParams -basicDepResolverParams installedPkgIndex sourcePkgIndex = - DepResolverParams { - depResolverTargets = Set.empty, - depResolverConstraints = [], - depResolverPreferences = [], - depResolverPreferenceDefault = PreferLatestForSelected, - depResolverInstalledPkgIndex = installedPkgIndex, - depResolverSourcePkgIndex = sourcePkgIndex, - depResolverReorderGoals = ReorderGoals False, - depResolverCountConflicts = CountConflicts True, - depResolverFineGrainedConflicts = FineGrainedConflicts True, - depResolverMinimizeConflictSet = MinimizeConflictSet False, - depResolverIndependentGoals = IndependentGoals False, - depResolverAvoidReinstalls = AvoidReinstalls False, - depResolverShadowPkgs = ShadowPkgs False, - depResolverStrongFlags = StrongFlags False, - depResolverAllowBootLibInstalls = AllowBootLibInstalls False, - depResolverOnlyConstrained = OnlyConstrainedNone, - depResolverMaxBackjumps = Nothing, - depResolverEnableBackjumping = EnableBackjumping True, - depResolverSolveExecutables = SolveExecutables True, - depResolverGoalOrder = Nothing, - depResolverVerbosity = normal - } - -addTargets :: [PackageName] - -> DepResolverParams -> DepResolverParams -addTargets extraTargets params = - params { - depResolverTargets = Set.fromList extraTargets `Set.union` depResolverTargets params - } - -addConstraints :: [LabeledPackageConstraint] - -> DepResolverParams -> DepResolverParams -addConstraints extraConstraints params = - params { - depResolverConstraints = extraConstraints - ++ depResolverConstraints params - } - -addPreferences :: [PackagePreference] - -> DepResolverParams -> DepResolverParams -addPreferences extraPreferences params = - params { - depResolverPreferences = extraPreferences - ++ depResolverPreferences params - } - -setPreferenceDefault :: PackagesPreferenceDefault - -> DepResolverParams -> DepResolverParams -setPreferenceDefault preferenceDefault params = - params { - depResolverPreferenceDefault = preferenceDefault - } - -setReorderGoals :: ReorderGoals -> DepResolverParams -> DepResolverParams -setReorderGoals reorder params = - params { - depResolverReorderGoals = reorder - } - -setCountConflicts :: CountConflicts -> DepResolverParams -> DepResolverParams -setCountConflicts count params = - params { - depResolverCountConflicts = count - } - -setFineGrainedConflicts :: FineGrainedConflicts -> DepResolverParams -> DepResolverParams -setFineGrainedConflicts fineGrained params = - params { - depResolverFineGrainedConflicts = fineGrained - } - -setMinimizeConflictSet :: MinimizeConflictSet -> DepResolverParams -> DepResolverParams -setMinimizeConflictSet minimize params = - params { - depResolverMinimizeConflictSet = minimize - } - -setIndependentGoals :: IndependentGoals -> DepResolverParams -> DepResolverParams -setIndependentGoals indep params = - params { - depResolverIndependentGoals = indep - } - -setAvoidReinstalls :: AvoidReinstalls -> DepResolverParams -> DepResolverParams -setAvoidReinstalls avoid params = - params { - depResolverAvoidReinstalls = avoid - } - -setShadowPkgs :: ShadowPkgs -> DepResolverParams -> DepResolverParams -setShadowPkgs shadow params = - params { - depResolverShadowPkgs = shadow - } - -setStrongFlags :: StrongFlags -> DepResolverParams -> DepResolverParams -setStrongFlags sf params = - params { - depResolverStrongFlags = sf - } - -setAllowBootLibInstalls :: AllowBootLibInstalls -> DepResolverParams -> DepResolverParams -setAllowBootLibInstalls i params = - params { - depResolverAllowBootLibInstalls = i - } - -setOnlyConstrained :: OnlyConstrained -> DepResolverParams -> DepResolverParams -setOnlyConstrained i params = - params { - depResolverOnlyConstrained = i - } - -setMaxBackjumps :: Maybe Int -> DepResolverParams -> DepResolverParams -setMaxBackjumps n params = - params { - depResolverMaxBackjumps = n - } - -setEnableBackjumping :: EnableBackjumping -> DepResolverParams -> DepResolverParams -setEnableBackjumping b params = - params { - depResolverEnableBackjumping = b - } - -setSolveExecutables :: SolveExecutables -> DepResolverParams -> DepResolverParams -setSolveExecutables b params = - params { - depResolverSolveExecutables = b - } - -setGoalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering) - -> DepResolverParams - -> DepResolverParams -setGoalOrder order params = - params { - depResolverGoalOrder = order - } - -setSolverVerbosity :: Verbosity -> DepResolverParams -> DepResolverParams -setSolverVerbosity verbosity params = - params { - depResolverVerbosity = verbosity - } - --- | Some packages are specific to a given compiler version and should never be --- upgraded. -dontUpgradeNonUpgradeablePackages :: DepResolverParams -> DepResolverParams -dontUpgradeNonUpgradeablePackages params = - addConstraints extraConstraints params - where - extraConstraints = - [ LabeledPackageConstraint - (PackageConstraint (ScopeAnyQualifier pkgname) PackagePropertyInstalled) - ConstraintSourceNonUpgradeablePackage - | Set.notMember (mkPackageName "base") (depResolverTargets params) - -- If you change this enumeration, make sure to update the list in - -- "Distribution.Solver.Modular.Solver" as well - , pkgname <- [ mkPackageName "base" - , mkPackageName "ghc-prim" - , mkPackageName "integer-gmp" - , mkPackageName "integer-simple" - , mkPackageName "template-haskell" - ] - , isInstalled pkgname ] - - isInstalled = not . null - . InstalledPackageIndex.lookupPackageName - (depResolverInstalledPkgIndex params) - -addSourcePackages :: [UnresolvedSourcePackage] - -> DepResolverParams -> DepResolverParams -addSourcePackages pkgs params = - params { - depResolverSourcePkgIndex = - foldl (flip PackageIndex.insert) - (depResolverSourcePkgIndex params) pkgs - } - -hideInstalledPackagesSpecificBySourcePackageId :: [PackageId] - -> DepResolverParams - -> DepResolverParams -hideInstalledPackagesSpecificBySourcePackageId pkgids params = - --TODO: this should work using exclude constraints instead - params { - depResolverInstalledPkgIndex = - foldl' (flip InstalledPackageIndex.deleteSourcePackageId) - (depResolverInstalledPkgIndex params) pkgids - } - -hideInstalledPackagesAllVersions :: [PackageName] - -> DepResolverParams -> DepResolverParams -hideInstalledPackagesAllVersions pkgnames params = - --TODO: this should work using exclude constraints instead - params { - depResolverInstalledPkgIndex = - foldl' (flip InstalledPackageIndex.deletePackageName) - (depResolverInstalledPkgIndex params) pkgnames - } - - --- | Remove upper bounds in dependencies using the policy specified by the --- 'AllowNewer' argument (all/some/none). --- --- Note: It's important to apply 'removeUpperBounds' after --- 'addSourcePackages'. Otherwise, the packages inserted by --- 'addSourcePackages' won't have upper bounds in dependencies relaxed. --- -removeUpperBounds :: AllowNewer -> DepResolverParams -> DepResolverParams -removeUpperBounds (AllowNewer relDeps) = removeBounds RelaxUpper relDeps - --- | Dual of 'removeUpperBounds' -removeLowerBounds :: AllowOlder -> DepResolverParams -> DepResolverParams -removeLowerBounds (AllowOlder relDeps) = removeBounds RelaxLower relDeps - -data RelaxKind = RelaxLower | RelaxUpper - --- | Common internal implementation of 'removeLowerBounds'/'removeUpperBounds' -removeBounds :: RelaxKind -> RelaxDeps -> DepResolverParams -> DepResolverParams -removeBounds _ rd params | not (isRelaxDeps rd) = params -- no-op optimisation -removeBounds relKind relDeps params = - params { - depResolverSourcePkgIndex = sourcePkgIndex' - } - where - sourcePkgIndex' = fmap relaxDeps $ depResolverSourcePkgIndex params - - relaxDeps :: UnresolvedSourcePackage -> UnresolvedSourcePackage - relaxDeps srcPkg = srcPkg - { srcpkgDescription = relaxPackageDeps relKind relDeps (srcpkgDescription srcPkg) - } - --- | Relax the dependencies of this package if needed. --- --- Helper function used by 'removeBounds' -relaxPackageDeps :: RelaxKind - -> RelaxDeps - -> PD.GenericPackageDescription -> PD.GenericPackageDescription -relaxPackageDeps _ rd gpd | not (isRelaxDeps rd) = gpd -- subsumed by no-op case in 'removeBounds' -relaxPackageDeps relKind RelaxDepsAll gpd = PD.transformAllBuildDepends relaxAll gpd - where - relaxAll :: Dependency -> Dependency - relaxAll (Dependency pkgName verRange cs) = - Dependency pkgName (removeBound relKind RelaxDepModNone verRange) cs - -relaxPackageDeps relKind (RelaxDepsSome depsToRelax0) gpd = - PD.transformAllBuildDepends relaxSome gpd - where - thisPkgName = packageName gpd - thisPkgId = packageId gpd - depsToRelax = Map.fromList $ mapMaybe f depsToRelax0 - - f :: RelaxedDep -> Maybe (RelaxDepSubject,RelaxDepMod) - f (RelaxedDep scope rdm p) = case scope of - RelaxDepScopeAll -> Just (p,rdm) - RelaxDepScopePackage p0 - | p0 == thisPkgName -> Just (p,rdm) - | otherwise -> Nothing - RelaxDepScopePackageId p0 - | p0 == thisPkgId -> Just (p,rdm) - | otherwise -> Nothing - - relaxSome :: Dependency -> Dependency - relaxSome d@(Dependency depName verRange cs) - | Just relMod <- Map.lookup RelaxDepSubjectAll depsToRelax = - -- a '*'-subject acts absorbing, for consistency with - -- the 'Semigroup RelaxDeps' instance - Dependency depName (removeBound relKind relMod verRange) cs - | Just relMod <- Map.lookup (RelaxDepSubjectPkg depName) depsToRelax = - Dependency depName (removeBound relKind relMod verRange) cs - | otherwise = d -- no-op - --- | Internal helper for 'relaxPackageDeps' -removeBound :: RelaxKind -> RelaxDepMod -> VersionRange -> VersionRange -removeBound RelaxLower RelaxDepModNone = removeLowerBound -removeBound RelaxUpper RelaxDepModNone = removeUpperBound -removeBound relKind RelaxDepModCaret = hyloVersionRange embed projectVersionRange - where - embed (MajorBoundVersionF v) = caretTransformation v (majorUpperBound v) - embed vr = embedVersionRange vr - - -- This function is the interesting part as it defines the meaning - -- of 'RelaxDepModCaret', i.e. to transform only @^>=@ constraints; - caretTransformation l u = case relKind of - RelaxUpper -> orLaterVersion l -- rewrite @^>= x.y.z@ into @>= x.y.z@ - RelaxLower -> earlierVersion u -- rewrite @^>= x.y.z@ into @< x.(y+1)@ - --- | Supply defaults for packages without explicit Setup dependencies --- --- 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]) - -> DepResolverParams -> DepResolverParams -addDefaultSetupDependencies defaultSetupDeps params = - params { - depResolverSourcePkgIndex = - fmap applyDefaultSetupDeps (depResolverSourcePkgIndex params) - } - where - applyDefaultSetupDeps :: UnresolvedSourcePackage -> UnresolvedSourcePackage - applyDefaultSetupDeps 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 - } - } - } - where - isCustom = PD.buildType pkgdesc == PD.Custom - gpkgdesc = srcpkgDescription srcpkg - pkgdesc = PD.packageDescription gpkgdesc - --- | If a package has a custom setup then we need to add a setup-depends --- on Cabal. --- -addSetupCabalMinVersionConstraint :: Version - -> DepResolverParams -> DepResolverParams -addSetupCabalMinVersionConstraint minVersion = - addConstraints - [ LabeledPackageConstraint - (PackageConstraint (ScopeAnySetupQualifier cabalPkgname) - (PackagePropertyVersion $ orLaterVersion minVersion)) - ConstraintSetupCabalMinVersion - ] - where - cabalPkgname = mkPackageName "Cabal" - --- | Variant of 'addSetupCabalMinVersionConstraint' which sets an --- upper bound on @setup.Cabal@ labeled with 'ConstraintSetupCabalMaxVersion'. --- -addSetupCabalMaxVersionConstraint :: Version - -> DepResolverParams -> DepResolverParams -addSetupCabalMaxVersionConstraint maxVersion = - addConstraints - [ LabeledPackageConstraint - (PackageConstraint (ScopeAnySetupQualifier cabalPkgname) - (PackagePropertyVersion $ earlierVersion maxVersion)) - ConstraintSetupCabalMaxVersion - ] - where - cabalPkgname = mkPackageName "Cabal" - - -upgradeDependencies :: DepResolverParams -> DepResolverParams -upgradeDependencies = setPreferenceDefault PreferAllLatest - - -reinstallTargets :: DepResolverParams -> DepResolverParams -reinstallTargets params = - hideInstalledPackagesAllVersions (Set.toList $ depResolverTargets params) params - - --- | A basic solver policy on which all others are built. --- -basicInstallPolicy :: InstalledPackageIndex - -> SourcePackageDb - -> [PackageSpecifier UnresolvedSourcePackage] - -> DepResolverParams -basicInstallPolicy - installedPkgIndex (SourcePackageDb sourcePkgIndex sourcePkgPrefs) - pkgSpecifiers - - = addPreferences - [ PackageVersionPreference name ver - | (name, ver) <- Map.toList sourcePkgPrefs ] - - . addConstraints - (concatMap pkgSpecifierConstraints pkgSpecifiers) - - . addTargets - (map pkgSpecifierTarget pkgSpecifiers) - - . hideInstalledPackagesSpecificBySourcePackageId - [ packageId pkg | SpecificSourcePackage pkg <- pkgSpecifiers ] - - . addSourcePackages - [ pkg | SpecificSourcePackage pkg <- pkgSpecifiers ] - - $ basicDepResolverParams - installedPkgIndex sourcePkgIndex - - --- | The policy used by all the standard commands, install, fetch, freeze etc --- (but not the v2-build and related commands). --- --- It extends the 'basicInstallPolicy' with a policy on setup deps. --- -standardInstallPolicy :: InstalledPackageIndex - -> SourcePackageDb - -> [PackageSpecifier UnresolvedSourcePackage] - -> DepResolverParams -standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers - - = addDefaultSetupDependencies mkDefaultSetupDeps - - $ basicInstallPolicy - installedPkgIndex sourcePkgDb pkgSpecifiers - - where - -- Force Cabal >= 1.24 dep when the package is affected by #3199. - mkDefaultSetupDeps :: UnresolvedSourcePackage -> Maybe [Dependency] - mkDefaultSetupDeps srcpkg | affected = - Just [Dependency (mkPackageName "Cabal") (orLaterVersion $ mkVersion [1,24]) mainLibSet] - | otherwise = Nothing - where - gpkgdesc = srcpkgDescription srcpkg - pkgdesc = PD.packageDescription gpkgdesc - bt = PD.buildType pkgdesc - affected = bt == PD.Custom && hasBuildableFalse gpkgdesc - - -- Does this package contain any components with non-empty 'build-depends' - -- and a 'buildable' field that could potentially be set to 'False'? False - -- positives are possible. - hasBuildableFalse :: PD.GenericPackageDescription -> Bool - hasBuildableFalse gpkg = - not (all alwaysTrue (zipWith PD.cOr buildableConditions noDepConditions)) - where - buildableConditions = PD.extractConditions PD.buildable gpkg - noDepConditions = PD.extractConditions - (null . PD.targetBuildDepends) gpkg - alwaysTrue (PD.Lit True) = True - alwaysTrue _ = False - --- ------------------------------------------------------------ --- * Interface to the standard resolver --- ------------------------------------------------------------ - -chooseSolver :: Verbosity -> PreSolver -> CompilerInfo -> IO Solver -chooseSolver _verbosity preSolver _cinfo = - case preSolver of - AlwaysModular -> do - return Modular - -runSolver :: Solver -> SolverConfig -> DependencyResolver UnresolvedPkgLoc -runSolver Modular = modularResolver - --- | Run the dependency solver. --- --- Since this is potentially an expensive operation, the result is wrapped in a --- a 'Progress' structure that can be unfolded to provide progress information, --- logging messages and the final result or an error. --- -resolveDependencies :: Platform - -> CompilerInfo - -> PkgConfigDb - -> Solver - -> DepResolverParams - -> Progress String String SolverInstallPlan - - --TODO: is this needed here? see dontUpgradeNonUpgradeablePackages -resolveDependencies platform comp _pkgConfigDB _solver params - | Set.null (depResolverTargets params) - = return (validateSolverResult platform comp indGoals []) - where - indGoals = depResolverIndependentGoals params - -resolveDependencies platform comp pkgConfigDB solver params = - - Step (showDepResolverParams finalparams) - $ fmap (validateSolverResult platform comp indGoals) - $ runSolver solver (SolverConfig reordGoals cntConflicts fineGrained minimize - indGoals noReinstalls - shadowing strFlags allowBootLibs onlyConstrained_ maxBkjumps enableBj - solveExes order verbosity (PruneAfterFirstSuccess False)) - platform comp installedPkgIndex sourcePkgIndex - pkgConfigDB preferences constraints targets - where - - finalparams@(DepResolverParams - targets constraints - prefs defpref - installedPkgIndex - sourcePkgIndex - reordGoals - cntConflicts - fineGrained - minimize - indGoals - noReinstalls - shadowing - strFlags - allowBootLibs - onlyConstrained_ - maxBkjumps - enableBj - solveExes - order - verbosity) = - if asBool (depResolverAllowBootLibInstalls params) - then params - else dontUpgradeNonUpgradeablePackages params - - preferences = interpretPackagesPreference targets defpref prefs - - --- | Give an interpretation to the global 'PackagesPreference' as --- specific per-package 'PackageVersionPreference'. --- -interpretPackagesPreference :: Set PackageName - -> PackagesPreferenceDefault - -> [PackagePreference] - -> (PackageName -> PackagePreferences) -interpretPackagesPreference selected defaultPref prefs = - \pkgname -> PackagePreferences (versionPref pkgname) - (installPref pkgname) - (stanzasPref pkgname) - where - versionPref pkgname = - fromMaybe [anyVersion] (Map.lookup pkgname versionPrefs) - versionPrefs = Map.fromListWith (++) - [(pkgname, [pref]) - | PackageVersionPreference pkgname pref <- prefs] - - installPref pkgname = - fromMaybe (installPrefDefault pkgname) (Map.lookup pkgname installPrefs) - installPrefs = Map.fromList - [ (pkgname, pref) - | PackageInstalledPreference pkgname pref <- prefs ] - installPrefDefault = case defaultPref of - PreferAllLatest -> const PreferLatest - PreferAllInstalled -> const PreferInstalled - PreferLatestForSelected -> \pkgname -> - -- When you say cabal install foo, what you really mean is, prefer the - -- latest version of foo, but the installed version of everything else - if pkgname `Set.member` selected then PreferLatest - else PreferInstalled - - stanzasPref pkgname = - fromMaybe [] (Map.lookup pkgname stanzasPrefs) - stanzasPrefs = Map.fromListWith (\a b -> nub (a ++ b)) - [ (pkgname, pref) - | PackageStanzasPreference pkgname pref <- prefs ] - - --- ------------------------------------------------------------ --- * Checking the result of the solver --- ------------------------------------------------------------ - --- | 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 - -> [ResolverPackage UnresolvedPkgLoc] - -> SolverInstallPlan -validateSolverResult platform comp indepGoals pkgs = - case planPackagesProblems platform comp pkgs of - [] -> case SolverInstallPlan.new indepGoals graph of - Right plan -> plan - Left problems -> error (formatPlanProblems problems) - problems -> error (formatPkgProblems problems) - - where - graph = Graph.fromDistinctList pkgs - - formatPkgProblems = formatProblemMessage . map showPlanPackageProblem - formatPlanProblems = formatProblemMessage . map SolverInstallPlan.showPlanProblem - - formatProblemMessage problems = - unlines $ - "internal error: could not construct a valid install plan." - : "The proposed (invalid) plan contained the following problems:" - : problems - ++ "Proposed plan:" - : [SolverInstallPlan.showPlanIndex pkgs] - - -data PlanPackageProblem = - InvalidConfiguredPackage (SolverPackage UnresolvedPkgLoc) - [PackageProblem] - | DuplicatePackageSolverId SolverId [ResolverPackage UnresolvedPkgLoc] - -showPlanPackageProblem :: PlanPackageProblem -> String -showPlanPackageProblem (InvalidConfiguredPackage pkg packageProblems) = - "Package " ++ prettyShow (packageId pkg) - ++ " has an invalid configuration, in particular:\n" - ++ unlines [ " " ++ showPackageProblem problem - | problem <- packageProblems ] -showPlanPackageProblem (DuplicatePackageSolverId pid dups) = - "Package " ++ prettyShow (packageId pid) ++ " has " - ++ show (length dups) ++ " duplicate instances." - -planPackagesProblems :: Platform -> CompilerInfo - -> [ResolverPackage UnresolvedPkgLoc] - -> [PlanPackageProblem] -planPackagesProblems platform cinfo pkgs = - [ InvalidConfiguredPackage pkg packageProblems - | Configured pkg <- pkgs - , let packageProblems = configuredPackageProblems platform cinfo pkg - , not (null packageProblems) ] - ++ [ DuplicatePackageSolverId (Graph.nodeKey (Unsafe.head dups)) dups - | dups <- duplicatesBy (comparing Graph.nodeKey) pkgs ] - -data PackageProblem = DuplicateFlag PD.FlagName - | MissingFlag PD.FlagName - | ExtraFlag PD.FlagName - | DuplicateDeps [PackageId] - | MissingDep Dependency - | ExtraDep PackageId - | InvalidDep Dependency PackageId - -showPackageProblem :: PackageProblem -> String -showPackageProblem (DuplicateFlag flag) = - "duplicate flag in the flag assignment: " ++ PD.unFlagName flag - -showPackageProblem (MissingFlag flag) = - "missing an assignment for the flag: " ++ PD.unFlagName flag - -showPackageProblem (ExtraFlag flag) = - "extra flag given that is not used by the package: " ++ PD.unFlagName flag - -showPackageProblem (DuplicateDeps pkgids) = - "duplicate packages specified as selected dependencies: " - ++ intercalate ", " (map prettyShow pkgids) - -showPackageProblem (MissingDep dep) = - "the package has a dependency " ++ prettyShow dep - ++ " but no package has been selected to satisfy it." - -showPackageProblem (ExtraDep pkgid) = - "the package configuration specifies " ++ prettyShow pkgid - ++ " but (with the given flag assignment) the package does not actually" - ++ " depend on any version of that package." - -showPackageProblem (InvalidDep dep pkgid) = - "the package depends on " ++ prettyShow dep - ++ " but the configuration specifies " ++ prettyShow pkgid - ++ " which does not satisfy the dependency." - --- | A 'ConfiguredPackage' is valid if the flag assignment is total and if --- in the configuration given by the flag assignment, all the package --- dependencies are satisfied by the specified packages. --- -configuredPackageProblems :: Platform -> CompilerInfo - -> SolverPackage UnresolvedPkgLoc -> [PackageProblem] -configuredPackageProblems platform cinfo - (SolverPackage pkg specifiedFlags stanzas specifiedDeps0 _specifiedExeDeps') = - [ DuplicateFlag flag - | flag <- PD.findDuplicateFlagAssignments specifiedFlags ] - ++ [ MissingFlag flag | OnlyInLeft flag <- mergedFlags ] - ++ [ ExtraFlag flag | OnlyInRight flag <- mergedFlags ] - ++ [ DuplicateDeps pkgs - | pkgs <- CD.nonSetupDeps (fmap (duplicatesBy (comparing packageName)) - specifiedDeps1) ] - ++ [ MissingDep dep | OnlyInLeft dep <- mergedDeps ] - ++ [ ExtraDep pkgid | OnlyInRight pkgid <- mergedDeps ] - ++ [ InvalidDep dep pkgid | InBoth dep pkgid <- mergedDeps - , not (packageSatisfiesDependency pkgid dep) ] - -- TODO: sanity tests on executable deps - where - thisPkgName = packageName (srcpkgDescription pkg) - - specifiedDeps1 :: ComponentDeps [PackageId] - specifiedDeps1 = fmap (map solverSrcId) specifiedDeps0 - - specifiedDeps :: [PackageId] - specifiedDeps = CD.flatDeps specifiedDeps1 - - mergedFlags = mergeBy compare - (sort $ map PD.flagName (PD.genPackageFlags (srcpkgDescription pkg))) - (sort $ map fst (PD.unFlagAssignment specifiedFlags)) -- TODO - - packageSatisfiesDependency - (PackageIdentifier name version) - (Dependency name' versionRange _) = assert (name == name') $ - version `withinRange` versionRange - - dependencyName (Dependency name _ _) = name - - mergedDeps :: [MergeResult Dependency PackageId] - mergedDeps = mergeDeps requiredDeps specifiedDeps - - mergeDeps :: [Dependency] -> [PackageId] - -> [MergeResult Dependency PackageId] - mergeDeps required specified = - let sortNubOn f = nubBy ((==) `on` f) . sortBy (compare `on` f) in - mergeBy - (\dep pkgid -> dependencyName dep `compare` packageName pkgid) - (sortNubOn dependencyName required) - (sortNubOn packageName specified) - - compSpec = enableStanzas stanzas - -- TODO: It would be nicer to use ComponentDeps here so we can be more - -- precise in our checks. In fact, this no longer relies on buildDepends and - -- thus should be easier to fix. As long as we _do_ use a flat list here, we - -- have to allow for duplicates when we fold specifiedDeps; once we have - -- proper ComponentDeps here we should get rid of the `nubOn` in - -- `mergeDeps`. - requiredDeps :: [Dependency] - requiredDeps = - --TODO: use something lower level than finalizePD - case finalizePD specifiedFlags - compSpec - (const True) - platform cinfo - [] - (srcpkgDescription pkg) of - Right (resolvedPkg, _) -> - -- we filter self/internal dependencies. They are still there. - -- This is INCORRECT. - -- - -- If we had per-component solver, it would make this unnecessary, - -- but no finalizePDs picks components we are not building, eg. exes. - -- See #3775 - -- - filter ((/= thisPkgName) . dependencyName) - (PD.enabledBuildDepends resolvedPkg compSpec) - ++ maybe [] PD.setupDepends (PD.setupBuildInfo resolvedPkg) - Left _ -> - error "configuredPackageInvalidDeps internal error" - - --- ------------------------------------------------------------ --- * Simple resolver that ignores dependencies --- ------------------------------------------------------------ - --- | A simplistic method of resolving a list of target package names to --- available packages. --- --- Specifically, it does not consider package dependencies at all. Unlike --- 'resolveDependencies', no attempt is made to ensure that the selected --- packages have dependencies that are satisfiable or consistent with --- each other. --- --- It is suitable for tasks such as selecting packages to download for user --- inspection. It is not suitable for selecting packages to install. --- --- Note: if no installed package index is available, it is OK to pass 'mempty'. --- It simply means preferences for installed packages will be ignored. --- -resolveWithoutDependencies :: DepResolverParams - -> Either [ResolveNoDepsError] [UnresolvedSourcePackage] -resolveWithoutDependencies (DepResolverParams targets constraints - prefs defpref installedPkgIndex sourcePkgIndex - _reorderGoals _countConflicts _fineGrained - _minimizeConflictSet _indGoals _avoidReinstalls - _shadowing _strFlags _maxBjumps _enableBj _solveExes - _allowBootLibInstalls _onlyConstrained _order _verbosity) = - collectEithers $ map selectPackage (Set.toList targets) - where - selectPackage :: PackageName -> Either ResolveNoDepsError UnresolvedSourcePackage - selectPackage pkgname - | null choices = Left $! ResolveUnsatisfiable pkgname requiredVersions - | otherwise = Right $! maximumBy bestByPrefs choices - - where - -- Constraints - requiredVersions = packageConstraints pkgname - choices = PackageIndex.lookupDependency sourcePkgIndex - pkgname - requiredVersions - - -- Preferences - PackagePreferences preferredVersions preferInstalled _ - = packagePreferences pkgname - - bestByPrefs = comparing $ \pkg -> - (installPref pkg, versionPref pkg, packageVersion pkg) - installPref = case preferInstalled of - PreferLatest -> const False - PreferInstalled -> not . null - . InstalledPackageIndex.lookupSourcePackageId - installedPkgIndex - . packageId - versionPref pkg = length . filter (packageVersion pkg `withinRange`) $ - preferredVersions - - packageConstraints :: PackageName -> VersionRange - packageConstraints pkgname = - Map.findWithDefault anyVersion pkgname packageVersionConstraintMap - packageVersionConstraintMap = - let pcs = map unlabelPackageConstraint constraints - in Map.fromList [ (scopeToPackageName scope, range) - | PackageConstraint - scope (PackagePropertyVersion range) <- pcs ] - - packagePreferences :: PackageName -> PackagePreferences - packagePreferences = interpretPackagesPreference targets defpref prefs - - -collectEithers :: [Either a b] -> Either [a] [b] -collectEithers = collect . partitionEithers - where - collect ([], xs) = Right xs - collect (errs,_) = Left errs - --- | Errors for 'resolveWithoutDependencies'. --- -data ResolveNoDepsError = - - -- | A package name which cannot be resolved to a specific package. - -- Also gives the constraint on the version and whether there was - -- a constraint on the package being installed. - ResolveUnsatisfiable PackageName VersionRange - -instance Show ResolveNoDepsError where - show (ResolveUnsatisfiable name ver) = - "There is no available version of " ++ prettyShow name - ++ " that satisfies " ++ prettyShow (simplifyVersionRange ver) diff --git a/cabal/cabal-install/Distribution/Client/Dependency/Types.hs b/cabal/cabal-install/Distribution/Client/Dependency/Types.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Dependency/Types.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Client.Dependency.Types ( - PreSolver(..), - Solver(..), - PackagesPreferenceDefault(..), - ) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Text.PrettyPrint (text) - -import qualified Distribution.Compat.CharParsing as P - - --- | All the solvers that can be selected. -data PreSolver = AlwaysModular - deriving (Eq, Ord, Show, Bounded, Enum, Generic) - --- | All the solvers that can be used. -data Solver = Modular - deriving (Eq, Ord, Show, Bounded, Enum, Generic) - -instance Binary PreSolver -instance Binary Solver - -instance Structured PreSolver -instance Structured Solver - -instance Pretty PreSolver where - pretty AlwaysModular = text "modular" - -instance Parsec PreSolver where - parsec = do - name <- P.munch1 isAlpha - case map toLower name of - "modular" -> return AlwaysModular - _ -> P.unexpected $ "PreSolver: " ++ name - --- | Global policy for all packages to say if we prefer package versions that --- are already installed locally or if we just prefer the latest available. --- -data PackagesPreferenceDefault = - - -- | Always prefer the latest version irrespective of any existing - -- installed version. - -- - -- * This is the standard policy for upgrade. - -- - PreferAllLatest - - -- | Always prefer the installed versions over ones that would need to be - -- installed. Secondarily, prefer latest versions (eg the latest installed - -- version or if there are none then the latest source version). - | PreferAllInstalled - - -- | Prefer the latest version for packages that are explicitly requested - -- but prefers the installed version for any other packages. - -- - -- * This is the standard policy for install. - -- - | PreferLatestForSelected - deriving Show diff --git a/cabal/cabal-install/Distribution/Client/DistDirLayout.hs b/cabal/cabal-install/Distribution/Client/DistDirLayout.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/DistDirLayout.hs +++ /dev/null @@ -1,279 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} - --- | --- --- The layout of the .\/dist\/ directory where cabal keeps all of its state --- and build artifacts. --- -module Distribution.Client.DistDirLayout ( - -- * 'DistDirLayout' - DistDirLayout(..), - DistDirParams(..), - defaultDistDirLayout, - ProjectRoot(..), - - -- * 'StoreDirLayout' - StoreDirLayout(..), - defaultStoreDirLayout, - - -- * 'CabalDirLayout' - CabalDirLayout(..), - mkCabalDirLayout, - defaultCabalDirLayout -) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import System.FilePath - -import Distribution.Package - ( PackageId, ComponentId, UnitId ) -import Distribution.Compiler -import Distribution.Simple.Compiler - ( PackageDB(..), PackageDBStack, OptimisationLevel(..) ) -import Distribution.Types.ComponentName -import Distribution.Types.LibraryName -import Distribution.System - - --- | Information which can be used to construct the path to --- the build directory of a build. This is LESS fine-grained --- than what goes into the hashed 'InstalledPackageId', --- 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, - distParamPackageId :: PackageId, - distParamComponentId :: ComponentId, - distParamComponentName :: Maybe ComponentName, - distParamCompilerId :: CompilerId, - distParamPlatform :: Platform, - distParamOptimization :: OptimisationLevel - -- TODO (see #3343): - -- Flag assignments - -- Optimization - } - - --- | The layout of the project state directory. Traditionally this has been --- called the @dist@ directory. --- -data DistDirLayout = DistDirLayout { - - -- | The root directory of the project. Many other files are relative to - -- this location. In particular, the @cabal.project@ lives here. - -- - distProjectRootDirectory :: FilePath, - - -- | The @cabal.project@ file and related like @cabal.project.freeze@. - -- The parameter is for the extension, like \"freeze\", or \"\" for the - -- main file. - -- - distProjectFile :: String -> FilePath, - - -- | The \"dist\" directory, which is the root of where cabal keeps all - -- its state including the build artifacts from each package we build. - -- - distDirectory :: FilePath, - - -- | The directory under dist where we keep the build artifacts for a - -- package we're building from a local directory. - -- - -- This uses a 'UnitId' not just a 'PackageName' because technically - -- we can have multiple instances of the same package in a solution - -- (e.g. setup deps). - -- - distBuildDirectory :: DistDirParams -> FilePath, - distBuildRootDirectory :: FilePath, - - -- | The directory under dist where we download tarballs and source - -- control repos to. - -- - distDownloadSrcDirectory :: FilePath, - - -- | The directory under dist where we put the unpacked sources of - -- packages, in those cases where it makes sense to keep the build - -- artifacts to reduce rebuild times. - -- - distUnpackedSrcDirectory :: PackageId -> FilePath, - distUnpackedSrcRootDirectory :: FilePath, - - -- | The location for project-wide cache files (e.g. state used in - -- incremental rebuilds). - -- - distProjectCacheFile :: String -> FilePath, - distProjectCacheDirectory :: FilePath, - - -- | The location for package-specific cache files (e.g. state used in - -- incremental rebuilds). - -- - distPackageCacheFile :: DistDirParams -> String -> FilePath, - distPackageCacheDirectory :: DistDirParams -> FilePath, - - -- | The location that sdists are placed by default. - distSdistFile :: PackageId -> FilePath, - distSdistDirectory :: FilePath, - - distTempDirectory :: FilePath, - distBinDirectory :: FilePath, - - distPackageDB :: CompilerId -> PackageDB - } - - --- | The layout of a cabal nix-style store. --- -data StoreDirLayout = StoreDirLayout { - storeDirectory :: CompilerId -> FilePath, - storePackageDirectory :: CompilerId -> UnitId -> FilePath, - storePackageDBPath :: CompilerId -> FilePath, - storePackageDB :: CompilerId -> PackageDB, - storePackageDBStack :: CompilerId -> PackageDBStack, - storeIncomingDirectory :: CompilerId -> FilePath, - storeIncomingLock :: CompilerId -> UnitId -> FilePath - } - - ---TODO: move to another module, e.g. CabalDirLayout? --- or perhaps rename this module to DirLayouts. - --- | The layout of the user-wide cabal directory, that is the @~/.cabal@ dir --- on unix, and equivalents on other systems. --- --- At the moment this is just a partial specification, but the idea is --- eventually to cover it all. --- -data CabalDirLayout = CabalDirLayout { - cabalStoreDirLayout :: StoreDirLayout, - - cabalLogsDirectory :: FilePath, - cabalWorldFile :: FilePath - } - - --- | Information about the root directory of the project. --- --- It can either be an implicit project root in the current dir if no --- @cabal.project@ file is found, or an explicit root if the file is found. --- -data ProjectRoot = - -- | -- ^ An implicit project root. It contains the absolute project - -- root dir. - ProjectRootImplicit FilePath - - -- | -- ^ An explicit project root. It contains the absolute project - -- root dir and the relative @cabal.project@ file (or explicit override) - | ProjectRootExplicit FilePath FilePath - deriving (Eq, Show) - --- | Make the default 'DistDirLayout' based on the project root dir and --- optional overrides for the location of the @dist@ directory and the --- @cabal.project@ file. --- -defaultDistDirLayout :: ProjectRoot -- ^ the project root - -> Maybe FilePath -- ^ the @dist@ directory or default - -- (absolute or relative to the root) - -> DistDirLayout -defaultDistDirLayout projectRoot mdistDirectory = - DistDirLayout {..} - where - (projectRootDir, projectFile) = case projectRoot of - ProjectRootImplicit dir -> (dir, dir "cabal.project") - ProjectRootExplicit dir file -> (dir, dir file) - - distProjectRootDirectory = projectRootDir - distProjectFile ext = projectFile <.> ext - - distDirectory = distProjectRootDirectory - fromMaybe "dist-newstyle" mdistDirectory - --TODO: switch to just dist at some point, or some other new name - - distBuildRootDirectory = distDirectory "build" - distBuildDirectory params = - distBuildRootDirectory - 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) - - distUnpackedSrcRootDirectory = distDirectory "src" - distUnpackedSrcDirectory pkgid = distUnpackedSrcRootDirectory - prettyShow pkgid - -- we shouldn't get name clashes so this should be fine: - distDownloadSrcDirectory = distUnpackedSrcRootDirectory - - distProjectCacheDirectory = distDirectory "cache" - distProjectCacheFile name = distProjectCacheDirectory name - - distPackageCacheDirectory params = distBuildDirectory params "cache" - distPackageCacheFile params name = distPackageCacheDirectory params name - - distSdistFile pid = distSdistDirectory prettyShow pid <.> "tar.gz" - - distSdistDirectory = distDirectory "sdist" - - distTempDirectory = distDirectory "tmp" - - distBinDirectory = distDirectory "bin" - - distPackageDBPath compid = distDirectory "packagedb" prettyShow compid - distPackageDB = SpecificPackageDB . distPackageDBPath - - -defaultStoreDirLayout :: FilePath -> StoreDirLayout -defaultStoreDirLayout storeRoot = - StoreDirLayout {..} - where - storeDirectory compid = - storeRoot prettyShow compid - - storePackageDirectory compid ipkgid = - storeDirectory compid prettyShow ipkgid - - storePackageDBPath compid = - storeDirectory compid "package.db" - - storePackageDB compid = - SpecificPackageDB (storePackageDBPath compid) - - storePackageDBStack compid = - [GlobalPackageDB, storePackageDB compid] - - storeIncomingDirectory compid = - storeDirectory compid "incoming" - - storeIncomingLock compid unitid = - storeIncomingDirectory compid prettyShow unitid <.> "lock" - - -defaultCabalDirLayout :: FilePath -> CabalDirLayout -defaultCabalDirLayout cabalDir = - mkCabalDirLayout cabalDir Nothing Nothing - -mkCabalDirLayout :: FilePath -- ^ Cabal directory - -> Maybe FilePath -- ^ Store directory. Must be absolute - -> Maybe FilePath -- ^ Log directory - -> CabalDirLayout -mkCabalDirLayout cabalDir mstoreDir mlogDir = - CabalDirLayout {..} - where - cabalStoreDirLayout = - defaultStoreDirLayout (fromMaybe (cabalDir "store") mstoreDir) - cabalLogsDirectory = fromMaybe (cabalDir "logs") mlogDir - cabalWorldFile = cabalDir "world" diff --git a/cabal/cabal-install/Distribution/Client/Exec.hs b/cabal/cabal-install/Distribution/Client/Exec.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Exec.hs +++ /dev/null @@ -1,63 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Exec --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Implementation of the 'exec' command. Runs an arbitrary executable in an --- environment suitable for making use of the sandbox. ------------------------------------------------------------------------------ - -module Distribution.Client.Exec ( exec - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude - -import Distribution.Simple.Compiler (Compiler) -import Distribution.Simple.Program.Db (ProgramDb, requireProgram, modifyProgramSearchPath) -import Distribution.Simple.Program.Run (programInvocation, runProgramInvocation) -import Distribution.Simple.Program.Types ( simpleProgram, ConfiguredProgram(..) ) -import Distribution.Simple.Utils (die') - -import Distribution.System (Platform(..)) - --- | Execute the given command in the package's environment. --- --- The given command is executed with GHC configured to use the correct --- package database and with the sandbox bin directory added to the PATH. -exec :: Verbosity - -> Compiler - -> Platform - -> ProgramDb - -> [String] - -> IO () -exec verbosity _comp _platform programDb extraArgs = - case extraArgs of - (exe:args) -> do - program <- requireProgram' verbosity programDb exe - env <- environmentOverrides (programOverrideEnv program) - let invocation = programInvocation - program { programOverrideEnv = env } - args - runProgramInvocation verbosity invocation - - [] -> die' verbosity "Please specify an executable to run" - where - environmentOverrides env = return env - --- | Check that a program is configured and available to be run. If --- a sandbox is available check in the sandbox's directory. -requireProgram' :: Verbosity - -> ProgramDb - -> String - -> IO ConfiguredProgram -requireProgram' verbosity programDb exe = do - (program, _) <- requireProgram - verbosity - (simpleProgram exe) - updateSearchPath - return program - where - updateSearchPath = - flip modifyProgramSearchPath programDb $ \searchPath -> searchPath diff --git a/cabal/cabal-install/Distribution/Client/Fetch.hs b/cabal/cabal-install/Distribution/Client/Fetch.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Fetch.hs +++ /dev/null @@ -1,232 +0,0 @@ -------------------------------------------------------------------------------- | --- Module : Distribution.Client.Fetch --- Copyright : (c) David Himmelstrup 2005 --- Duncan Coutts 2011 --- License : BSD-like --- --- Maintainer : cabal-devel@gmail.com --- Stability : provisional --- Portability : portable --- --- The cabal fetch command ------------------------------------------------------------------------------ -module Distribution.Client.Fetch ( - fetch, - ) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Client.Types -import Distribution.Client.Targets -import Distribution.Client.FetchUtils hiding (fetchPackage) -import Distribution.Client.Dependency -import Distribution.Client.IndexUtils as IndexUtils - ( getSourcePackages, getInstalledPackages ) -import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan -import Distribution.Client.Setup - ( GlobalFlags(..), FetchFlags(..), RepoContext(..) ) - -import Distribution.Solver.Types.ConstraintSource -import Distribution.Solver.Types.LabeledPackageConstraint -import Distribution.Solver.Types.OptionalStanza -import Distribution.Solver.Types.PkgConfigDb ( PkgConfigDb, readPkgConfigDb ) -import Distribution.Solver.Types.SolverPackage -import Distribution.Solver.Types.SourcePackage - -import Distribution.Package - ( packageId ) -import Distribution.Simple.Compiler - ( Compiler, compilerInfo, PackageDBStack ) -import Distribution.Simple.PackageIndex (InstalledPackageIndex) -import Distribution.Simple.Program - ( ProgramDb ) -import Distribution.Simple.Setup - ( fromFlag, fromFlagOrDefault ) -import Distribution.Simple.Utils - ( die', notice, debug ) -import Distribution.System - ( Platform ) - --- ------------------------------------------------------------ --- * The fetch command --- ------------------------------------------------------------ - ---TODO: --- * add fetch -o support --- * support tarball URLs via ad-hoc download cache (or in -o mode?) --- * suggest using --no-deps, unpack or fetch -o if deps cannot be satisfied --- * Port various flags from install: --- * --updage-dependencies --- * --constraint and --preference --- * --only-dependencies, but note it conflicts with --no-deps - - --- | Fetch a list of packages and their dependencies. --- -fetch :: Verbosity - -> PackageDBStack - -> RepoContext - -> Compiler - -> Platform - -> ProgramDb - -> GlobalFlags - -> FetchFlags - -> [UserTarget] - -> IO () -fetch verbosity _ _ _ _ _ _ _ [] = - notice verbosity "No packages requested. Nothing to do." - -fetch verbosity packageDBs repoCtxt comp platform progdb - globalFlags fetchFlags userTargets = do - - traverse_ (checkTarget verbosity) userTargets - - installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb - sourcePkgDb <- getSourcePackages verbosity repoCtxt - pkgConfigDb <- readPkgConfigDb verbosity progdb - - pkgSpecifiers <- resolveUserTargets verbosity repoCtxt - (fromFlag $ globalWorldFile globalFlags) - (packageIndex sourcePkgDb) - userTargets - - pkgs <- planPackages - verbosity comp platform fetchFlags - installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers - - pkgs' <- filterM (fmap not . isFetched . srcpkgSource) pkgs - if null pkgs' - --TODO: when we add support for remote tarballs then this message - -- will need to be changed because for remote tarballs we fetch them - -- at the earlier phase. - then notice verbosity $ "No packages need to be fetched. " - ++ "All the requested packages are already local " - ++ "or cached locally." - else if dryRun - then notice verbosity $ unlines $ - "The following packages would be fetched:" - : map (prettyShow . packageId) pkgs' - - else traverse_ (fetchPackage verbosity repoCtxt . srcpkgSource) pkgs' - - where - dryRun = fromFlag (fetchDryRun fetchFlags) - -planPackages :: Verbosity - -> Compiler - -> Platform - -> FetchFlags - -> InstalledPackageIndex - -> SourcePackageDb - -> PkgConfigDb - -> [PackageSpecifier UnresolvedSourcePackage] - -> IO [UnresolvedSourcePackage] -planPackages verbosity comp platform fetchFlags - installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers - - | includeDependencies = do - solver <- chooseSolver verbosity - (fromFlag (fetchSolver fetchFlags)) (compilerInfo comp) - notice verbosity "Resolving dependencies..." - installPlan <- foldProgress logMsg (die' verbosity) return $ - resolveDependencies - platform (compilerInfo comp) pkgConfigDb - solver - resolverParams - - -- The packages we want to fetch are those packages the 'InstallPlan' - -- that are in the 'InstallPlan.Configured' state. - return - [ solverPkgSource cpkg - | (SolverInstallPlan.Configured cpkg) - <- SolverInstallPlan.toList installPlan ] - - | otherwise = - either (die' verbosity . unlines . map show) return $ - resolveWithoutDependencies resolverParams - - where - resolverParams = - - setMaxBackjumps (if maxBackjumps < 0 then Nothing - else Just maxBackjumps) - - . setIndependentGoals independentGoals - - . setReorderGoals reorderGoals - - . setCountConflicts countConflicts - - . setFineGrainedConflicts fineGrainedConflicts - - . setMinimizeConflictSet minimizeConflictSet - - . setShadowPkgs shadowPkgs - - . setStrongFlags strongFlags - - . setAllowBootLibInstalls allowBootLibInstalls - - . setOnlyConstrained onlyConstrained - - . setSolverVerbosity verbosity - - . addConstraints - [ let pc = PackageConstraint - (scopeToplevel $ pkgSpecifierTarget pkgSpecifier) - (PackagePropertyStanzas stanzas) - in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget - | pkgSpecifier <- pkgSpecifiers ] - - -- Reinstall the targets given on the command line so that the dep - -- resolver will decide that they need fetching, even if they're - -- 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 - - includeDependencies = fromFlag (fetchDeps fetchFlags) - logMsg message rest = debug verbosity message >> rest - - stanzas = [ TestStanzas | testsEnabled ] - ++ [ BenchStanzas | benchmarksEnabled ] - testsEnabled = fromFlagOrDefault False $ fetchTests fetchFlags - benchmarksEnabled = fromFlagOrDefault False $ fetchBenchmarks fetchFlags - - reorderGoals = fromFlag (fetchReorderGoals fetchFlags) - countConflicts = fromFlag (fetchCountConflicts fetchFlags) - fineGrainedConflicts = fromFlag (fetchFineGrainedConflicts fetchFlags) - minimizeConflictSet = fromFlag (fetchMinimizeConflictSet fetchFlags) - independentGoals = fromFlag (fetchIndependentGoals fetchFlags) - shadowPkgs = fromFlag (fetchShadowPkgs fetchFlags) - strongFlags = fromFlag (fetchStrongFlags fetchFlags) - maxBackjumps = fromFlag (fetchMaxBackjumps fetchFlags) - allowBootLibInstalls = fromFlag (fetchAllowBootLibInstalls fetchFlags) - onlyConstrained = fromFlag (fetchOnlyConstrained fetchFlags) - - -checkTarget :: Verbosity -> UserTarget -> IO () -checkTarget verbosity target = case target of - UserTargetRemoteTarball _uri - -> die' verbosity $ "The 'fetch' command does not yet support remote tarballs. " - ++ "In the meantime you can use the 'unpack' commands." - _ -> return () - -fetchPackage :: Verbosity -> RepoContext -> PackageLocation a -> IO () -fetchPackage verbosity repoCtxt pkgsrc = case pkgsrc of - LocalUnpackedPackage _dir -> return () - LocalTarballPackage _file -> return () - - RemoteTarballPackage _uri _ -> - die' verbosity $ "The 'fetch' command does not yet support remote tarballs. " - ++ "In the meantime you can use the 'unpack' commands." - - RemoteSourceRepoPackage _repo _ -> - die' verbosity $ "The 'fetch' command does not yet support remote " - ++ "source repositores." - - RepoTarballPackage repo pkgid _ -> do - _ <- fetchRepoTarball verbosity repoCtxt repo pkgid - return () diff --git a/cabal/cabal-install/Distribution/Client/FetchUtils.hs b/cabal/cabal-install/Distribution/Client/FetchUtils.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/FetchUtils.hs +++ /dev/null @@ -1,317 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.FetchUtils --- Copyright : (c) David Himmelstrup 2005 --- Duncan Coutts 2011 --- License : BSD-like --- --- Maintainer : cabal-devel@gmail.com --- Stability : provisional --- Portability : portable --- --- Functions for fetching packages ------------------------------------------------------------------------------ -{-# LANGUAGE RecordWildCards #-} -module Distribution.Client.FetchUtils ( - - -- * fetching packages - fetchPackage, - isFetched, - checkFetched, - - -- ** specifically for repo packages - checkRepoTarballFetched, - fetchRepoTarball, - - -- ** fetching packages asynchronously - asyncFetchPackages, - waitAsyncFetchPackage, - AsyncFetchMap, - - -- * fetching other things - downloadIndex, - ) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Client.Types -import Distribution.Client.HttpUtils - ( downloadURI, isOldHackageURI, DownloadResult(..) - , HttpTransport(..), transportCheckHttps, remoteRepoCheckHttps ) - -import Distribution.Package - ( PackageId, packageName, packageVersion ) -import Distribution.Simple.Utils - ( notice, info, debug, die' ) -import Distribution.Verbosity - ( verboseUnmarkOutput ) -import Distribution.Client.GlobalFlags - ( RepoContext(..) ) -import Distribution.Client.Utils - ( ProgressPhase(..), progressMessage ) - -import qualified Data.Map as Map -import Control.Exception -import Control.Concurrent.Async -import Control.Concurrent.MVar -import System.Directory - ( doesFileExist, createDirectoryIfMissing, getTemporaryDirectory ) -import System.IO - ( openTempFile, hClose ) -import System.FilePath - ( (), (<.>) ) -import qualified System.FilePath.Posix as FilePath.Posix - ( combine, joinPath ) -import Network.URI - ( URI(uriPath) ) - -import qualified Hackage.Security.Client as Sec - --- ------------------------------------------------------------ --- * Actually fetch things --- ------------------------------------------------------------ - --- | Returns @True@ if the package has already been fetched --- or does not need fetching. --- -isFetched :: UnresolvedPkgLoc -> IO Bool -isFetched loc = case loc of - LocalUnpackedPackage _dir -> return True - LocalTarballPackage _file -> return True - RemoteTarballPackage _uri local -> return (isJust local) - RepoTarballPackage repo pkgid _ -> doesFileExist (packageFile repo pkgid) - RemoteSourceRepoPackage _ local -> return (isJust local) - - --- | Checks if the package has already been fetched (or does not need --- fetching) and if so returns evidence in the form of a 'PackageLocation' --- with a resolved local file location. --- -checkFetched :: UnresolvedPkgLoc - -> IO (Maybe ResolvedPkgLoc) -checkFetched loc = case loc of - LocalUnpackedPackage dir -> - return (Just $ LocalUnpackedPackage dir) - LocalTarballPackage file -> - return (Just $ LocalTarballPackage file) - RemoteTarballPackage uri (Just file) -> - return (Just $ RemoteTarballPackage uri file) - RepoTarballPackage repo pkgid (Just file) -> - return (Just $ RepoTarballPackage repo pkgid file) - RemoteSourceRepoPackage repo (Just file) -> - return (Just $ RemoteSourceRepoPackage repo file) - - RemoteTarballPackage _uri Nothing -> return Nothing - RemoteSourceRepoPackage _repo Nothing -> return Nothing - RepoTarballPackage repo pkgid Nothing -> - fmap (fmap (RepoTarballPackage repo pkgid)) - (checkRepoTarballFetched repo pkgid) - --- | Like 'checkFetched' but for the specific case of a 'RepoTarballPackage'. --- -checkRepoTarballFetched :: Repo -> PackageId -> IO (Maybe FilePath) -checkRepoTarballFetched repo pkgid = do - let file = packageFile repo pkgid - exists <- doesFileExist file - if exists - then return (Just file) - else return Nothing - - --- | Fetch a package if we don't have it already. --- -fetchPackage :: Verbosity - -> RepoContext - -> UnresolvedPkgLoc - -> IO ResolvedPkgLoc -fetchPackage verbosity repoCtxt loc = case loc of - LocalUnpackedPackage dir -> - return (LocalUnpackedPackage dir) - LocalTarballPackage file -> - return (LocalTarballPackage file) - RemoteTarballPackage uri (Just file) -> - return (RemoteTarballPackage uri file) - RepoTarballPackage repo pkgid (Just file) -> - return (RepoTarballPackage repo pkgid file) - RemoteSourceRepoPackage repo (Just dir) -> - return (RemoteSourceRepoPackage repo dir) - - RemoteTarballPackage uri Nothing -> do - path <- downloadTarballPackage uri - return (RemoteTarballPackage uri path) - RepoTarballPackage repo pkgid Nothing -> do - local <- fetchRepoTarball verbosity repoCtxt repo pkgid - return (RepoTarballPackage repo pkgid local) - RemoteSourceRepoPackage _repo Nothing -> - die' verbosity "fetchPackage: source repos not supported" - where - downloadTarballPackage uri = do - transport <- repoContextGetTransport repoCtxt - transportCheckHttps verbosity transport uri - notice verbosity ("Downloading " ++ show uri) - tmpdir <- getTemporaryDirectory - (path, hnd) <- openTempFile tmpdir "cabal-.tar.gz" - hClose hnd - _ <- downloadURI transport verbosity uri path - return path - - --- | Fetch a repo package if we don't have it already. --- -fetchRepoTarball :: Verbosity -> RepoContext -> Repo -> PackageId -> IO FilePath -fetchRepoTarball verbosity' repoCtxt repo pkgid = do - fetched <- doesFileExist (packageFile repo pkgid) - if fetched - then do info verbosity $ prettyShow pkgid ++ " has already been downloaded." - return (packageFile repo pkgid) - else do progressMessage verbosity ProgressDownloading (prettyShow pkgid) - res <- downloadRepoPackage - progressMessage verbosity ProgressDownloaded (prettyShow pkgid) - return res - where - -- whether we download or not is non-deterministic - verbosity = verboseUnmarkOutput verbosity' - - downloadRepoPackage = case repo of - RepoLocalNoIndex{} -> return (packageFile repo pkgid) - - RepoRemote{..} -> do - transport <- repoContextGetTransport repoCtxt - remoteRepoCheckHttps verbosity transport repoRemote - let uri = packageURI repoRemote pkgid - dir = packageDir repo pkgid - path = packageFile repo pkgid - createDirectoryIfMissing True dir - _ <- downloadURI transport verbosity uri path - return path - - RepoSecure{} -> repoContextWithSecureRepo repoCtxt repo $ \rep -> do - let dir = packageDir repo pkgid - path = packageFile repo pkgid - createDirectoryIfMissing True dir - Sec.uncheckClientErrors $ do - info verbosity ("Writing " ++ path) - Sec.downloadPackage' rep pkgid path - return path - --- | Downloads an index file to [config-dir/packages/serv-id] without --- hackage-security. You probably don't want to call this directly; --- use 'updateRepo' instead. --- -downloadIndex :: HttpTransport -> Verbosity -> RemoteRepo -> FilePath -> IO DownloadResult -downloadIndex transport verbosity remoteRepo cacheDir = do - remoteRepoCheckHttps verbosity transport remoteRepo - let uri = (remoteRepoURI remoteRepo) { - uriPath = uriPath (remoteRepoURI remoteRepo) - `FilePath.Posix.combine` "00-index.tar.gz" - } - path = cacheDir "00-index" <.> "tar.gz" - createDirectoryIfMissing True cacheDir - downloadURI transport verbosity uri path - - --- ------------------------------------------------------------ --- * Async fetch wrapper utilities --- ------------------------------------------------------------ - -type AsyncFetchMap = Map UnresolvedPkgLoc - (MVar (Either SomeException ResolvedPkgLoc)) - --- | Fork off an async action to download the given packages (by location). --- --- The downloads are initiated in order, so you can arrange for packages that --- will likely be needed sooner to be earlier in the list. --- --- The body action is passed a map from those packages (identified by their --- location) to a completion var for that package. So the body action should --- lookup the location and use 'asyncFetchPackage' to get the result. --- -asyncFetchPackages :: Verbosity - -> RepoContext - -> [UnresolvedPkgLoc] - -> (AsyncFetchMap -> IO a) - -> IO a -asyncFetchPackages verbosity repoCtxt pkglocs body = do - --TODO: [nice to have] use parallel downloads? - - asyncDownloadVars <- sequenceA - [ do v <- newEmptyMVar - return (pkgloc, v) - | pkgloc <- pkglocs - ] - - let fetchPackages :: IO () - fetchPackages = - for_ asyncDownloadVars $ \(pkgloc, var) -> do - -- Suppress marking here, because 'withAsync' means - -- that we get nondeterministic interleaving - result <- try $ fetchPackage (verboseUnmarkOutput verbosity) - repoCtxt pkgloc - putMVar var result - - withAsync fetchPackages $ \_ -> - body (Map.fromList asyncDownloadVars) - - --- | Expect to find a download in progress in the given 'AsyncFetchMap' --- and wait on it to finish. --- --- If the download failed with an exception then this will be thrown. --- --- Note: This function is supposed to be idempotent, as our install plans --- can now use the same tarball for many builds, e.g. different --- components and/or qualified goals, and these all go through the --- download phase so we end up using 'waitAsyncFetchPackage' twice on --- the same package. C.f. #4461. -waitAsyncFetchPackage :: Verbosity - -> AsyncFetchMap - -> UnresolvedPkgLoc - -> IO ResolvedPkgLoc -waitAsyncFetchPackage verbosity downloadMap srcloc = - case Map.lookup srcloc downloadMap of - Just hnd -> do - debug verbosity $ "Waiting for download of " ++ show srcloc - either throwIO return =<< readMVar hnd - Nothing -> fail "waitAsyncFetchPackage: package not being downloaded" - - --- ------------------------------------------------------------ --- * Path utilities --- ------------------------------------------------------------ - --- | Generate the full path to the locally cached copy of --- the tarball for a given @PackageIdentifer@. --- -packageFile :: Repo -> PackageId -> FilePath -packageFile repo pkgid = packageDir repo pkgid - prettyShow pkgid - <.> "tar.gz" - --- | Generate the full path to the directory where the local cached copy of --- the tarball for a given @PackageIdentifer@ is stored. --- -packageDir :: Repo -> PackageId -> FilePath -packageDir (RepoLocalNoIndex (LocalRepo _ dir _) _) _pkgid = dir -packageDir repo pkgid = repoLocalDir repo - prettyShow (packageName pkgid) - prettyShow (packageVersion pkgid) - --- | Generate the URI of the tarball for a given package. --- -packageURI :: RemoteRepo -> PackageId -> URI -packageURI repo pkgid | isOldHackageURI (remoteRepoURI repo) = - (remoteRepoURI repo) { - uriPath = FilePath.Posix.joinPath - [uriPath (remoteRepoURI repo) - ,prettyShow (packageName pkgid) - ,prettyShow (packageVersion pkgid) - ,prettyShow pkgid <.> "tar.gz"] - } -packageURI repo pkgid = - (remoteRepoURI repo) { - uriPath = FilePath.Posix.joinPath - [uriPath (remoteRepoURI repo) - ,"package" - ,prettyShow pkgid <.> "tar.gz"] - } diff --git a/cabal/cabal-install/Distribution/Client/FileMonitor.hs b/cabal/cabal-install/Distribution/Client/FileMonitor.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/FileMonitor.hs +++ /dev/null @@ -1,1130 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveGeneric, DeriveFunctor, GeneralizedNewtypeDeriving, - NamedFieldPuns, BangPatterns #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- | An abstraction to help with re-running actions when files or other --- input values they depend on have changed. --- -module Distribution.Client.FileMonitor ( - - -- * Declaring files to monitor - MonitorFilePath(..), - MonitorKindFile(..), - MonitorKindDir(..), - FilePathGlob(..), - monitorFile, - monitorFileHashed, - monitorNonExistentFile, - monitorFileExistence, - monitorDirectory, - monitorNonExistentDirectory, - monitorDirectoryExistence, - monitorFileOrDirectory, - monitorFileGlob, - monitorFileGlobExistence, - monitorFileSearchPath, - monitorFileHashedSearchPath, - - -- * Creating and checking sets of monitored files - FileMonitor(..), - newFileMonitor, - MonitorChanged(..), - MonitorChangedReason(..), - checkFileMonitorChanged, - updateFileMonitor, - MonitorTimestamp, - beginUpdateFileMonitor, - - -- * Internal - MonitorStateFileSet, - MonitorStateFile, - MonitorStateGlob, - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude - -import qualified Data.Map.Strict as Map -import qualified Data.ByteString.Lazy as BS -import qualified Data.Hashable as Hashable - -import Control.Monad -import Control.Monad.Trans (MonadIO, liftIO) -import Control.Monad.State (StateT, mapStateT) -import qualified Control.Monad.State as State -import Control.Monad.Except (ExceptT, runExceptT, withExceptT, - throwError) -import Control.Exception - -import Distribution.Compat.Time -import Distribution.Client.Glob -import Distribution.Simple.Utils (handleDoesNotExist, writeFileAtomic) -import Distribution.Client.Utils (mergeBy, MergeResult(..)) -import Distribution.Utils.Structured (structuredDecodeOrFailIO, structuredEncode) -import System.FilePath -import System.Directory -import System.IO - ------------------------------------------------------------------------------- --- Types for specifying files to monitor --- - - --- | A description of a file (or set of files) to monitor for changes. --- --- Where file paths are relative they are relative to a common directory --- (e.g. project root), not necessarily the process current directory. --- -data MonitorFilePath = - MonitorFile { - monitorKindFile :: !MonitorKindFile, - monitorKindDir :: !MonitorKindDir, - monitorPath :: !FilePath - } - | MonitorFileGlob { - monitorKindFile :: !MonitorKindFile, - monitorKindDir :: !MonitorKindDir, - monitorPathGlob :: !FilePathGlob - } - deriving (Eq, Show, Generic) - -data MonitorKindFile = FileExists - | FileModTime - | FileHashed - | FileNotExists - deriving (Eq, Show, Generic) - -data MonitorKindDir = DirExists - | DirModTime - | DirNotExists - deriving (Eq, Show, Generic) - -instance Binary MonitorFilePath -instance Binary MonitorKindFile -instance Binary MonitorKindDir - -instance Structured MonitorFilePath -instance Structured MonitorKindFile -instance Structured MonitorKindDir - --- | Monitor a single file for changes, based on its modification time. --- The monitored file is considered to have changed if it no longer --- exists or if its modification time has changed. --- -monitorFile :: FilePath -> MonitorFilePath -monitorFile = MonitorFile FileModTime DirNotExists - --- | Monitor a single file for changes, based on its modification time --- and content hash. The monitored file is considered to have changed if --- it no longer exists or if its modification time and content hash have --- changed. --- -monitorFileHashed :: FilePath -> MonitorFilePath -monitorFileHashed = MonitorFile FileHashed DirNotExists - --- | Monitor a single non-existent file for changes. The monitored file --- is considered to have changed if it exists. --- -monitorNonExistentFile :: FilePath -> MonitorFilePath -monitorNonExistentFile = MonitorFile FileNotExists DirNotExists - --- | Monitor a single file for existence only. The monitored file is --- considered to have changed if it no longer exists. --- -monitorFileExistence :: FilePath -> MonitorFilePath -monitorFileExistence = MonitorFile FileExists DirNotExists - --- | Monitor a single directory for changes, based on its modification --- time. The monitored directory is considered to have changed if it no --- longer exists or if its modification time has changed. --- -monitorDirectory :: FilePath -> MonitorFilePath -monitorDirectory = MonitorFile FileNotExists DirModTime - --- | Monitor a single non-existent directory for changes. The monitored --- directory is considered to have changed if it exists. --- -monitorNonExistentDirectory :: FilePath -> MonitorFilePath --- Just an alias for monitorNonExistentFile, since you can't --- tell the difference between a non-existent directory and --- a non-existent file :) -monitorNonExistentDirectory = monitorNonExistentFile - --- | Monitor a single directory for existence. The monitored directory is --- considered to have changed only if it no longer exists. --- -monitorDirectoryExistence :: FilePath -> MonitorFilePath -monitorDirectoryExistence = MonitorFile FileNotExists DirExists - --- | Monitor a single file or directory for changes, based on its modification --- time. The monitored file is considered to have changed if it no longer --- exists or if its modification time has changed. --- -monitorFileOrDirectory :: FilePath -> MonitorFilePath -monitorFileOrDirectory = MonitorFile FileModTime DirModTime - --- | Monitor a set of files (or directories) identified by a file glob. --- The monitored glob is considered to have changed if the set of files --- matching the glob changes (i.e. creations or deletions), or for files if the --- modification time and content hash of any matching file has changed. --- -monitorFileGlob :: FilePathGlob -> MonitorFilePath -monitorFileGlob = MonitorFileGlob FileHashed DirExists - --- | Monitor a set of files (or directories) identified by a file glob for --- existence only. The monitored glob is considered to have changed if the set --- of files matching the glob changes (i.e. creations or deletions). --- -monitorFileGlobExistence :: FilePathGlob -> MonitorFilePath -monitorFileGlobExistence = MonitorFileGlob FileExists DirExists - --- | Creates a list of files to monitor when you search for a file which --- unsuccessfully looked in @notFoundAtPaths@ before finding it at --- @foundAtPath@. -monitorFileSearchPath :: [FilePath] -> FilePath -> [MonitorFilePath] -monitorFileSearchPath notFoundAtPaths foundAtPath = - monitorFile foundAtPath - : map monitorNonExistentFile notFoundAtPaths - --- | Similar to 'monitorFileSearchPath', but also instructs us to --- monitor the hash of the found file. -monitorFileHashedSearchPath :: [FilePath] -> FilePath -> [MonitorFilePath] -monitorFileHashedSearchPath notFoundAtPaths foundAtPath = - monitorFileHashed foundAtPath - : map monitorNonExistentFile notFoundAtPaths - - ------------------------------------------------------------------------------- --- Implementation types, files status --- - --- | The state necessary to determine whether a set of monitored --- files has changed. It consists of two parts: a set of specific --- files to be monitored (index by their path), and a list of --- globs, which monitor may files at once. -data MonitorStateFileSet - = MonitorStateFileSet ![MonitorStateFile] - ![MonitorStateGlob] - -- Morally this is not actually a set but a bag (represented by lists). - -- There is no principled reason to use a bag here rather than a set, but - -- there is also no particular gain either. That said, we do preserve the - -- order of the lists just to reduce confusion (and have predictable I/O - -- patterns). - deriving (Show, Generic) - -instance Binary MonitorStateFileSet -instance Structured MonitorStateFileSet - -type Hash = Int - --- | The state necessary to determine whether a monitored file has changed. --- --- This covers all the cases of 'MonitorFilePath' except for globs which is --- covered separately by 'MonitorStateGlob'. --- --- The @Maybe ModTime@ is to cover the case where we already consider the --- file to have changed, either because it had already changed by the time we --- did the snapshot (i.e. too new, changed since start of update process) or it --- no longer exists at all. --- -data MonitorStateFile = MonitorStateFile !MonitorKindFile !MonitorKindDir - !FilePath !MonitorStateFileStatus - deriving (Show, Generic) - -data MonitorStateFileStatus - = MonitorStateFileExists - | MonitorStateFileModTime !ModTime -- ^ cached file mtime - | MonitorStateFileHashed !ModTime !Hash -- ^ cached mtime and content hash - | MonitorStateDirExists - | MonitorStateDirModTime !ModTime -- ^ cached dir mtime - | MonitorStateNonExistent - | MonitorStateAlreadyChanged - deriving (Show, Generic) - -instance Binary MonitorStateFile -instance Binary MonitorStateFileStatus -instance Structured MonitorStateFile -instance Structured MonitorStateFileStatus - --- | The state necessary to determine whether the files matched by a globbing --- match have changed. --- -data MonitorStateGlob = MonitorStateGlob !MonitorKindFile !MonitorKindDir - !FilePathRoot !MonitorStateGlobRel - deriving (Show, Generic) - -data MonitorStateGlobRel - = MonitorStateGlobDirs - !Glob !FilePathGlobRel - !ModTime - ![(FilePath, MonitorStateGlobRel)] -- invariant: sorted - - | MonitorStateGlobFiles - !Glob - !ModTime - ![(FilePath, MonitorStateFileStatus)] -- invariant: sorted - - | MonitorStateGlobDirTrailing - deriving (Show, Generic) - -instance Binary MonitorStateGlob -instance Binary MonitorStateGlobRel - -instance Structured MonitorStateGlob -instance Structured MonitorStateGlobRel - --- | We can build a 'MonitorStateFileSet' from a set of 'MonitorFilePath' by --- inspecting the state of the file system, and we can go in the reverse --- direction by just forgetting the extra info. --- -reconstructMonitorFilePaths :: MonitorStateFileSet -> [MonitorFilePath] -reconstructMonitorFilePaths (MonitorStateFileSet singlePaths globPaths) = - map getSinglePath singlePaths - ++ map getGlobPath globPaths - where - getSinglePath (MonitorStateFile kindfile kinddir filepath _) = - MonitorFile kindfile kinddir filepath - - getGlobPath (MonitorStateGlob kindfile kinddir root gstate) = - MonitorFileGlob kindfile kinddir $ FilePathGlob root $ - case gstate of - MonitorStateGlobDirs glob globs _ _ -> GlobDir glob globs - MonitorStateGlobFiles glob _ _ -> GlobFile glob - MonitorStateGlobDirTrailing -> GlobDirTrailing - ------------------------------------------------------------------------------- --- Checking the status of monitored files --- - --- | A monitor for detecting changes to a set of files. It can be used to --- efficiently test if any of a set of files (specified individually or by --- glob patterns) has changed since some snapshot. In addition, it also checks --- for changes in a value (of type @a@), and when there are no changes in --- either it returns a saved value (of type @b@). --- --- The main use case looks like this: suppose we have some expensive action --- that depends on certain pure inputs and reads some set of files, and --- produces some pure result. We want to avoid re-running this action when it --- would produce the same result. So we need to monitor the files the action --- looked at, the other pure input values, and we need to cache the result. --- Then at some later point, if the input value didn't change, and none of the --- files changed, then we can re-use the cached result rather than re-running --- the action. --- --- This can be achieved using a 'FileMonitor'. Each 'FileMonitor' instance --- saves state in a disk file, so the file for that has to be specified, --- making sure it is unique. The pattern is to use 'checkFileMonitorChanged' --- to see if there's been any change. If there is, re-run the action, keeping --- track of the files, then use 'updateFileMonitor' to record the current --- set of files to monitor, the current input value for the action, and the --- result of the action. --- --- The typical occurrence of this pattern is captured by 'rerunIfChanged' --- and the 'Rebuild' monad. More complicated cases may need to use --- 'checkFileMonitorChanged' and 'updateFileMonitor' directly. --- -data FileMonitor a b - = FileMonitor { - - -- | The file where this 'FileMonitor' should store its state. - -- - fileMonitorCacheFile :: FilePath, - - -- | Compares a new cache key with old one to determine if a - -- corresponding cached value is still valid. - -- - -- Typically this is just an equality test, but in some - -- circumstances it can make sense to do things like subset - -- comparisons. - -- - -- The first arg is the new value, the second is the old cached value. - -- - fileMonitorKeyValid :: a -> a -> Bool, - - -- | When this mode is enabled, if 'checkFileMonitorChanged' returns - -- 'MonitoredValueChanged' then we have the guarantee that no files - -- changed, that the value change was the only change. In the default - -- mode no such guarantee is provided which is slightly faster. - -- - fileMonitorCheckIfOnlyValueChanged :: Bool - } - --- | Define a new file monitor. --- --- It's best practice to define file monitor values once, and then use the --- same value for 'checkFileMonitorChanged' and 'updateFileMonitor' as this --- ensures you get the same types @a@ and @b@ for reading and writing. --- --- The path of the file monitor itself must be unique because it keeps state --- on disk and these would clash. --- -newFileMonitor :: Eq a => FilePath -- ^ The file to cache the state of the - -- file monitor. Must be unique. - -> FileMonitor a b -newFileMonitor path = FileMonitor path (==) False - --- | The result of 'checkFileMonitorChanged': either the monitored files or --- value changed (and it tells us which it was) or nothing changed and we get --- the cached result. --- -data MonitorChanged a b = - -- | The monitored files and value did not change. The cached result is - -- @b@. - -- - -- The set of monitored files is also returned. This is useful - -- for composing or nesting 'FileMonitor's. - MonitorUnchanged b [MonitorFilePath] - - -- | The monitor found that something changed. The reason is given. - -- - | MonitorChanged (MonitorChangedReason a) - deriving Show - --- | What kind of change 'checkFileMonitorChanged' detected. --- -data MonitorChangedReason a = - - -- | One of the files changed (existence, file type, mtime or file - -- content, depending on the 'MonitorFilePath' in question) - MonitoredFileChanged FilePath - - -- | The pure input value changed. - -- - -- The previous cached key value is also returned. This is sometimes - -- useful when using a 'fileMonitorKeyValid' function that is not simply - -- '(==)', when invalidation can be partial. In such cases it can make - -- sense to 'updateFileMonitor' with a key value that's a combination of - -- the new and old (e.g. set union). - | MonitoredValueChanged a - - -- | There was no saved monitor state, cached value etc. Ie the file - -- for the 'FileMonitor' does not exist. - | MonitorFirstRun - - -- | There was existing state, but we could not read it. This typically - -- happens when the code has changed compared to an existing 'FileMonitor' - -- cache file and type of the input value or cached value has changed such - -- that we cannot decode the values. This is completely benign as we can - -- treat is just as if there were no cache file and re-run. - | MonitorCorruptCache - deriving (Eq, Show, Functor) - --- | Test if the input value or files monitored by the 'FileMonitor' have --- changed. If not, return the cached value. --- --- See 'FileMonitor' for a full explanation. --- -checkFileMonitorChanged - :: (Binary a, Structured a, Binary b, Structured b) - => FileMonitor a b -- ^ cache file path - -> FilePath -- ^ root directory - -> a -- ^ guard or key value - -> IO (MonitorChanged a b) -- ^ did the key or any paths change? -checkFileMonitorChanged - monitor@FileMonitor { fileMonitorKeyValid, - fileMonitorCheckIfOnlyValueChanged } - root currentKey = - - -- Consider it a change if the cache file does not exist, - -- or we cannot decode it. Sadly ErrorCall can still happen, despite - -- using decodeFileOrFail, e.g. Data.Char.chr errors - - handleDoesNotExist (MonitorChanged MonitorFirstRun) $ - handleErrorCall (MonitorChanged MonitorCorruptCache) $ - readCacheFile monitor - >>= either (\_ -> return (MonitorChanged MonitorCorruptCache)) - checkStatusCache - - where - checkStatusCache (cachedFileStatus, cachedKey, cachedResult) = do - change <- checkForChanges - case change of - Just reason -> return (MonitorChanged reason) - Nothing -> return (MonitorUnchanged cachedResult monitorFiles) - where monitorFiles = reconstructMonitorFilePaths cachedFileStatus - where - -- In fileMonitorCheckIfOnlyValueChanged mode we want to guarantee that - -- if we return MonitoredValueChanged that only the value changed. - -- We do that by checkin for file changes first. Otherwise it makes - -- more sense to do the cheaper test first. - checkForChanges - | fileMonitorCheckIfOnlyValueChanged - = checkFileChange cachedFileStatus cachedKey cachedResult - `mplusMaybeT` - checkValueChange cachedKey - - | otherwise - = checkValueChange cachedKey - `mplusMaybeT` - checkFileChange cachedFileStatus cachedKey cachedResult - - mplusMaybeT :: Monad m => m (Maybe a) -> m (Maybe a) -> m (Maybe a) - mplusMaybeT ma mb = do - mx <- ma - case mx of - Nothing -> mb - Just x -> return (Just x) - - -- Check if the guard value has changed - checkValueChange cachedKey - | not (fileMonitorKeyValid currentKey cachedKey) - = return (Just (MonitoredValueChanged cachedKey)) - | otherwise - = return Nothing - - -- Check if any file has changed - checkFileChange cachedFileStatus cachedKey cachedResult = do - res <- probeFileSystem root cachedFileStatus - case res of - -- Some monitored file has changed - Left changedPath -> - return (Just (MonitoredFileChanged (normalise changedPath))) - - -- No monitored file has changed - Right (cachedFileStatus', cacheStatus) -> do - - -- But we might still want to update the cache - whenCacheChanged cacheStatus $ - rewriteCacheFile monitor cachedFileStatus' cachedKey cachedResult - - return Nothing - --- | Helper for reading the cache file. --- --- This determines the type and format of the binary cache file. --- -readCacheFile :: (Binary a, Structured a, Binary b, Structured b) - => FileMonitor a b - -> IO (Either String (MonitorStateFileSet, a, b)) -readCacheFile FileMonitor {fileMonitorCacheFile} = - withBinaryFile fileMonitorCacheFile ReadMode $ \hnd -> do - contents <- BS.hGetContents hnd - structuredDecodeOrFailIO contents - --- | Helper for writing the cache file. --- --- This determines the type and format of the binary cache file. --- -rewriteCacheFile :: (Binary a, Structured a, Binary b, Structured b) - => FileMonitor a b - -> MonitorStateFileSet -> a -> b -> IO () -rewriteCacheFile FileMonitor {fileMonitorCacheFile} fileset key result = - writeFileAtomic fileMonitorCacheFile $ - structuredEncode (fileset, key, result) - --- | Probe the file system to see if any of the monitored files have changed. --- --- It returns Nothing if any file changed, or returns a possibly updated --- file 'MonitorStateFileSet' plus an indicator of whether it actually changed. --- --- We may need to update the cache since there may be changes in the filesystem --- state which don't change any of our affected files. --- --- Consider the glob @{proj1,proj2}\/\*.cabal@. Say we first run and find a --- @proj1@ directory containing @proj1.cabal@ yet no @proj2@. If we later run --- and find @proj2@ was created, yet contains no files matching @*.cabal@ then --- we want to update the cache despite no changes in our relevant file set. --- Specifically, we should add an mtime for this directory so we can avoid --- re-traversing the directory in future runs. --- -probeFileSystem :: FilePath -> MonitorStateFileSet - -> IO (Either FilePath (MonitorStateFileSet, CacheChanged)) -probeFileSystem root (MonitorStateFileSet singlePaths globPaths) = - runChangedM $ do - sequence_ - [ probeMonitorStateFileStatus root file status - | MonitorStateFile _ _ file status <- singlePaths ] - -- The glob monitors can require state changes - globPaths' <- - sequence - [ probeMonitorStateGlob root globPath - | globPath <- globPaths ] - return (MonitorStateFileSet singlePaths globPaths') - - ------------------------------------------------ --- Monad for checking for file system changes --- --- We need to be able to bail out if we detect a change (using ExceptT), --- but if there's no change we need to be able to rebuild the monitor --- state. And we want to optimise that rebuilding by keeping track if --- anything actually changed (using StateT), so that in the typical case --- we can avoid rewriting the state file. - -newtype ChangedM a = ChangedM (StateT CacheChanged (ExceptT FilePath IO) a) - deriving (Functor, Applicative, Monad, MonadIO) - -runChangedM :: ChangedM a -> IO (Either FilePath (a, CacheChanged)) -runChangedM (ChangedM action) = - runExceptT $ State.runStateT action CacheUnchanged - -somethingChanged :: FilePath -> ChangedM a -somethingChanged path = ChangedM $ throwError path - -cacheChanged :: ChangedM () -cacheChanged = ChangedM $ State.put CacheChanged - -mapChangedFile :: (FilePath -> FilePath) -> ChangedM a -> ChangedM a -mapChangedFile adjust (ChangedM a) = - ChangedM (mapStateT (withExceptT adjust) a) - -data CacheChanged = CacheChanged | CacheUnchanged - -whenCacheChanged :: Monad m => CacheChanged -> m () -> m () -whenCacheChanged CacheChanged action = action -whenCacheChanged CacheUnchanged _ = return () - ----------------------- - --- | Probe the file system to see if a single monitored file has changed. --- -probeMonitorStateFileStatus :: FilePath -> FilePath - -> MonitorStateFileStatus - -> ChangedM () -probeMonitorStateFileStatus root file status = - case status of - MonitorStateFileExists -> - probeFileExistence root file - - MonitorStateFileModTime mtime -> - probeFileModificationTime root file mtime - - MonitorStateFileHashed mtime hash -> - probeFileModificationTimeAndHash root file mtime hash - - MonitorStateDirExists -> - probeDirExistence root file - - MonitorStateDirModTime mtime -> - probeFileModificationTime root file mtime - - MonitorStateNonExistent -> - probeFileNonExistence root file - - MonitorStateAlreadyChanged -> - somethingChanged file - - --- | Probe the file system to see if a monitored file glob has changed. --- -probeMonitorStateGlob :: FilePath -- ^ root path - -> MonitorStateGlob - -> ChangedM MonitorStateGlob -probeMonitorStateGlob relroot - (MonitorStateGlob kindfile kinddir globroot glob) = do - root <- liftIO $ getFilePathRootDirectory globroot relroot - case globroot of - FilePathRelative -> - MonitorStateGlob kindfile kinddir globroot <$> - probeMonitorStateGlobRel kindfile kinddir root "." glob - - -- for absolute cases, make the changed file we report absolute too - _ -> - mapChangedFile (root ) $ - MonitorStateGlob kindfile kinddir globroot <$> - probeMonitorStateGlobRel kindfile kinddir root "" glob - -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 - change <- liftIO $ checkDirectoryModificationTime (root dirName) mtime - case change of - Nothing -> do - children' <- sequence - [ do fstate' <- probeMonitorStateGlobRel - kindfile kinddir root - (dirName fname) fstate - return (fname, fstate') - | (fname, fstate) <- children ] - return $! MonitorStateGlobDirs glob globPath mtime children' - - Just mtime' -> do - -- directory modification time changed: - -- a matching subdir may have been added or deleted - matches <- filterM (\entry -> let subdir = root dirName entry - in liftIO $ doesDirectoryExist subdir) - . filter (matchGlob glob) - =<< liftIO (getDirectoryContents (root dirName)) - - children' <- traverse probeMergeResult $ - mergeBy (\(path1,_) path2 -> compare path1 path2) - children - (sort matches) - return $! MonitorStateGlobDirs glob globPath mtime' children' - -- Note that just because the directory has changed, we don't force - -- a cache rewrite with 'cacheChanged' since that has some cost, and - -- all we're saving is scanning the directory. But we do rebuild the - -- cache with the new mtime', so that if the cache is rewritten for - -- some other reason, we'll take advantage of that. - - where - probeMergeResult :: MergeResult (FilePath, MonitorStateGlobRel) FilePath - -> ChangedM (FilePath, MonitorStateGlobRel) - - -- Only in cached (directory deleted) - probeMergeResult (OnlyInLeft (path, fstate)) = do - case allMatchingFiles (dirName path) fstate of - [] -> return (path, fstate) - -- Strictly speaking we should be returning 'CacheChanged' above - -- as we should prune the now-missing 'MonitorStateGlobRel'. However - -- we currently just leave these now-redundant entries in the - -- cache as they cost no IO and keeping them allows us to avoid - -- rewriting the cache. - (file:_) -> somethingChanged file - - -- Only in current filesystem state (directory added) - probeMergeResult (OnlyInRight path) = do - fstate <- liftIO $ buildMonitorStateGlobRel Nothing Map.empty - kindfile kinddir root (dirName path) globPath - case allMatchingFiles (dirName path) fstate of - (file:_) -> somethingChanged file - -- This is the only case where we use 'cacheChanged' because we can - -- have a whole new dir subtree (of unbounded size and cost), so we - -- need to save the state of that new subtree in the cache. - [] -> cacheChanged >> return (path, fstate) - - -- Found in path - probeMergeResult (InBoth (path, fstate) _) = do - fstate' <- probeMonitorStateGlobRel kindfile kinddir - root (dirName path) fstate - return (path, fstate') - - -- | Does a 'MonitorStateGlob' have any relevant files within it? - allMatchingFiles :: FilePath -> MonitorStateGlobRel -> [FilePath] - allMatchingFiles dir (MonitorStateGlobFiles _ _ entries) = - [ dir fname | (fname, _) <- entries ] - allMatchingFiles dir (MonitorStateGlobDirs _ _ _ entries) = - [ res - | (subdir, fstate) <- entries - , res <- allMatchingFiles (dir subdir) fstate ] - allMatchingFiles dir MonitorStateGlobDirTrailing = - [dir] - -probeMonitorStateGlobRel _ _ root dirName - (MonitorStateGlobFiles 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 (matchGlob glob) - =<< liftIO (getDirectoryContents (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 (MonitorStateGlobFiles glob mtime' children) - -- Again, we don't force a cache rewite with 'cacheChanged', but we do use - -- the new mtime' if any. - where - 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) - -probeMonitorStateGlobRel _ _ _ _ MonitorStateGlobDirTrailing = - return MonitorStateGlobDirTrailing - ------------------------------------------------------------------------------- - --- | Update the input value and the set of files monitored by the --- 'FileMonitor', plus the cached value that may be returned in future. --- --- This takes a snapshot of the state of the monitored files right now, so --- 'checkFileMonitorChanged' will look for file system changes relative to --- this snapshot. --- --- This is typically done once the action has been completed successfully and --- we have the action's result and we know what files it looked at. See --- 'FileMonitor' for a full explanation. --- --- If we do take the snapshot after the action has completed then we have a --- problem. The problem is that files might have changed /while/ the action was --- running but /after/ the action read them. If we take the snapshot after the --- action completes then we will miss these changes. The solution is to record --- a timestamp before beginning execution of the action and then we make the --- conservative assumption that any file that has changed since then has --- already changed, ie the file monitor state for these files will be such that --- 'checkFileMonitorChanged' will report that they have changed. --- --- So if you do use 'updateFileMonitor' after the action (so you can discover --- the files used rather than predicting them in advance) then use --- 'beginUpdateFileMonitor' to get a timestamp and pass that. Alternatively, --- if you take the snapshot in advance of the action, or you're not monitoring --- any files then you can use @Nothing@ for the timestamp parameter. --- -updateFileMonitor - :: (Binary a, Structured a, Binary b, Structured b) - => FileMonitor a b -- ^ cache file path - -> FilePath -- ^ root directory - -> Maybe MonitorTimestamp -- ^ timestamp when the update action started - -> [MonitorFilePath] -- ^ files of interest relative to root - -> a -- ^ the current key value - -> b -- ^ the current result value - -> IO () -updateFileMonitor monitor root startTime monitorFiles - cachedKey cachedResult = do - hashcache <- readCacheFileHashes monitor - msfs <- buildMonitorStateFileSet startTime hashcache root monitorFiles - rewriteCacheFile monitor msfs cachedKey cachedResult - --- | A timestamp to help with the problem of file changes during actions. --- See 'updateFileMonitor' for details. --- -newtype MonitorTimestamp = MonitorTimestamp ModTime - --- | Record a timestamp at the beginning of an action, and when the action --- completes call 'updateFileMonitor' passing it the timestamp. --- See 'updateFileMonitor' for details. --- -beginUpdateFileMonitor :: IO MonitorTimestamp -beginUpdateFileMonitor = MonitorTimestamp <$> getCurTime - --- | Take the snapshot of the monitored files. That is, given the --- specification of the set of files we need to monitor, inspect the state --- of the file system now and collect the information we'll need later to --- determine if anything has changed. --- -buildMonitorStateFileSet :: Maybe MonitorTimestamp -- ^ optional: timestamp - -- of the start of the action - -> FileHashCache -- ^ existing file hashes - -> FilePath -- ^ root directory - -> [MonitorFilePath] -- ^ patterns of interest - -- relative to root - -> IO MonitorStateFileSet -buildMonitorStateFileSet mstartTime hashcache root = - go [] [] - where - go :: [MonitorStateFile] -> [MonitorStateGlob] - -> [MonitorFilePath] -> IO MonitorStateFileSet - go !singlePaths !globPaths [] = - return (MonitorStateFileSet (reverse singlePaths) (reverse globPaths)) - - go !singlePaths !globPaths - (MonitorFile kindfile kinddir path : monitors) = do - monitorState <- MonitorStateFile kindfile kinddir path - <$> buildMonitorStateFile mstartTime hashcache - kindfile kinddir root path - go (monitorState : singlePaths) globPaths monitors - - go !singlePaths !globPaths - (MonitorFileGlob kindfile kinddir globPath : monitors) = do - monitorState <- buildMonitorStateGlob mstartTime hashcache - kindfile kinddir root globPath - go singlePaths (monitorState : globPaths) monitors - - -buildMonitorStateFile :: Maybe MonitorTimestamp -- ^ start time of update - -> FileHashCache -- ^ existing file hashes - -> MonitorKindFile -> MonitorKindDir - -> FilePath -- ^ the root directory - -> FilePath - -> IO MonitorStateFileStatus -buildMonitorStateFile mstartTime hashcache kindfile kinddir root path = do - let abspath = root path - isFile <- doesFileExist abspath - isDir <- doesDirectoryExist abspath - case (isFile, kindfile, isDir, kinddir) of - (_, FileNotExists, _, DirNotExists) -> - -- we don't need to care if it exists now, since we check at probe time - return MonitorStateNonExistent - - (False, _, False, _) -> - return MonitorStateAlreadyChanged - - (True, FileExists, _, _) -> - return MonitorStateFileExists - - (True, FileModTime, _, _) -> - handleIOException MonitorStateAlreadyChanged $ do - mtime <- getModTime abspath - if changedDuringUpdate mstartTime mtime - then return MonitorStateAlreadyChanged - else return (MonitorStateFileModTime mtime) - - (True, FileHashed, _, _) -> - handleIOException MonitorStateAlreadyChanged $ do - mtime <- getModTime abspath - if changedDuringUpdate mstartTime mtime - then return MonitorStateAlreadyChanged - else do hash <- getFileHash hashcache abspath abspath mtime - return (MonitorStateFileHashed mtime hash) - - (_, _, True, DirExists) -> - return MonitorStateDirExists - - (_, _, True, DirModTime) -> - handleIOException MonitorStateAlreadyChanged $ do - mtime <- getModTime abspath - if changedDuringUpdate mstartTime mtime - then return MonitorStateAlreadyChanged - else return (MonitorStateDirModTime mtime) - - (False, _, True, DirNotExists) -> return MonitorStateAlreadyChanged - (True, FileNotExists, False, _) -> return MonitorStateAlreadyChanged - --- | If we have a timestamp for the beginning of the update, then any file --- mtime later than this means that it changed during the update and we ought --- to consider the file as already changed. --- -changedDuringUpdate :: Maybe MonitorTimestamp -> ModTime -> Bool -changedDuringUpdate (Just (MonitorTimestamp startTime)) mtime - = mtime > startTime -changedDuringUpdate _ _ = False - --- | Much like 'buildMonitorStateFileSet' but for the somewhat complicated case --- of a file glob. --- --- This gets used both by 'buildMonitorStateFileSet' when we're taking the --- file system snapshot, but also by 'probeGlobStatus' as part of checking --- the monitored (globed) files for changes when we find a whole new subtree. --- -buildMonitorStateGlob :: Maybe MonitorTimestamp -- ^ start time of update - -> FileHashCache -- ^ existing file hashes - -> MonitorKindFile -> MonitorKindDir - -> FilePath -- ^ the root directory - -> FilePathGlob -- ^ the matching glob - -> IO MonitorStateGlob -buildMonitorStateGlob mstartTime hashcache kindfile kinddir relroot - (FilePathGlob globroot globPath) = do - root <- liftIO $ getFilePathRootDirectory globroot relroot - MonitorStateGlob kindfile kinddir globroot <$> - buildMonitorStateGlobRel - mstartTime hashcache kindfile kinddir root "." globPath - -buildMonitorStateGlobRel :: Maybe MonitorTimestamp -- ^ start time of update - -> FileHashCache -- ^ existing file hashes - -> MonitorKindFile -> MonitorKindDir - -> FilePath -- ^ the root directory - -> FilePath -- ^ directory we are examining - -- relative to the root - -> FilePathGlobRel -- ^ the matching glob - -> IO MonitorStateGlobRel -buildMonitorStateGlobRel mstartTime hashcache kindfile kinddir root - dir globPath = do - let absdir = root dir - dirEntries <- getDirectoryContents absdir - dirMTime <- getModTime absdir - case globPath of - GlobDir glob globPath' -> do - subdirs <- filterM (\subdir -> doesDirectoryExist (absdir subdir)) - $ filter (matchGlob glob) dirEntries - subdirStates <- - for (sort subdirs) $ \subdir -> do - fstate <- buildMonitorStateGlobRel - mstartTime hashcache kindfile kinddir root - (dir subdir) globPath' - return (subdir, fstate) - return $! MonitorStateGlobDirs glob globPath' dirMTime subdirStates - - GlobFile glob -> do - let files = filter (matchGlob glob) dirEntries - filesStates <- - for (sort files) $ \file -> do - fstate <- buildMonitorStateFile - mstartTime hashcache kindfile kinddir root - (dir file) - return (file, fstate) - return $! MonitorStateGlobFiles glob dirMTime filesStates - - GlobDirTrailing -> - return MonitorStateGlobDirTrailing - - --- | We really want to avoid re-hashing files all the time. We already make --- the assumption that if a file mtime has not changed then we don't need to --- bother checking if the content hash has changed. We can apply the same --- assumption when updating the file monitor state. In the typical case of --- updating a file monitor the set of files is the same or largely the same so --- we can grab the previously known content hashes with their corresponding --- mtimes. --- -type FileHashCache = Map FilePath (ModTime, Hash) - --- | We declare it a cache hit if the mtime of a file is the same as before. --- -lookupFileHashCache :: FileHashCache -> FilePath -> ModTime -> Maybe Hash -lookupFileHashCache hashcache file mtime = do - (mtime', hash) <- Map.lookup file hashcache - guard (mtime' == mtime) - return hash - --- | Either get it from the cache or go read the file -getFileHash :: FileHashCache -> FilePath -> FilePath -> ModTime -> IO Hash -getFileHash hashcache relfile absfile mtime = - case lookupFileHashCache hashcache relfile mtime of - Just hash -> return hash - Nothing -> readFileHash absfile - --- | Build a 'FileHashCache' from the previous 'MonitorStateFileSet'. While --- in principle we could preserve the structure of the previous state, given --- that the set of files to monitor can change then it's simpler just to throw --- away the structure and use a finite map. --- -readCacheFileHashes :: (Binary a, Structured a, Binary b, Structured b) - => FileMonitor a b -> IO FileHashCache -readCacheFileHashes monitor = - handleDoesNotExist Map.empty $ - handleErrorCall Map.empty $ do - res <- readCacheFile monitor - case res of - Left _ -> return Map.empty - Right (msfs, _, _) -> return (mkFileHashCache msfs) - where - mkFileHashCache :: MonitorStateFileSet -> FileHashCache - mkFileHashCache (MonitorStateFileSet singlePaths globPaths) = - collectAllFileHashes singlePaths - `Map.union` collectAllGlobHashes globPaths - - collectAllFileHashes singlePaths = - Map.fromList [ (fpath, (mtime, hash)) - | MonitorStateFile _ _ fpath - (MonitorStateFileHashed mtime hash) <- singlePaths ] - - collectAllGlobHashes globPaths = - Map.fromList [ (fpath, (mtime, hash)) - | MonitorStateGlob _ _ _ gstate <- globPaths - , (fpath, (mtime, hash)) <- collectGlobHashes "" gstate ] - - collectGlobHashes dir (MonitorStateGlobDirs _ _ _ entries) = - [ res - | (subdir, fstate) <- entries - , res <- collectGlobHashes (dir subdir) fstate ] - - collectGlobHashes dir (MonitorStateGlobFiles _ _ entries) = - [ (dir fname, (mtime, hash)) - | (fname, MonitorStateFileHashed mtime hash) <- entries ] - - collectGlobHashes _dir MonitorStateGlobDirTrailing = - [] - - ------------------------------------------------------------------------------- --- Utils --- - --- | Within the @root@ directory, check if @file@ has its 'ModTime' is --- the same as @mtime@, short-circuiting if it is different. -probeFileModificationTime :: FilePath -> FilePath -> ModTime -> ChangedM () -probeFileModificationTime root file mtime = do - unchanged <- liftIO $ checkModificationTimeUnchanged root file mtime - unless unchanged (somethingChanged file) - --- | Within the @root@ directory, check if @file@ has its 'ModTime' and --- 'Hash' is the same as @mtime@ and @hash@, short-circuiting if it is --- different. -probeFileModificationTimeAndHash :: FilePath -> FilePath -> ModTime -> Hash - -> ChangedM () -probeFileModificationTimeAndHash root file mtime hash = do - unchanged <- liftIO $ - checkFileModificationTimeAndHashUnchanged root file mtime hash - unless unchanged (somethingChanged file) - --- | Within the @root@ directory, check if @file@ still exists as a file. --- If it *does not* exist, short-circuit. -probeFileExistence :: FilePath -> FilePath -> ChangedM () -probeFileExistence root file = do - existsFile <- liftIO $ doesFileExist (root file) - unless existsFile (somethingChanged file) - --- | Within the @root@ directory, check if @dir@ still exists. --- If it *does not* exist, short-circuit. -probeDirExistence :: FilePath -> FilePath -> ChangedM () -probeDirExistence root dir = do - existsDir <- liftIO $ doesDirectoryExist (root dir) - unless existsDir (somethingChanged dir) - --- | Within the @root@ directory, check if @file@ still does not exist. --- If it *does* exist, short-circuit. -probeFileNonExistence :: FilePath -> FilePath -> ChangedM () -probeFileNonExistence root file = do - existsFile <- liftIO $ doesFileExist (root file) - existsDir <- liftIO $ doesDirectoryExist (root file) - when (existsFile || existsDir) (somethingChanged file) - --- | Returns @True@ if, inside the @root@ directory, @file@ has the same --- 'ModTime' as @mtime@. -checkModificationTimeUnchanged :: FilePath -> FilePath - -> ModTime -> IO Bool -checkModificationTimeUnchanged root file mtime = - handleIOException False $ do - mtime' <- getModTime (root file) - return (mtime == mtime') - --- | Returns @True@ if, inside the @root@ directory, @file@ has the --- same 'ModTime' and 'Hash' as @mtime and @chash@. -checkFileModificationTimeAndHashUnchanged :: FilePath -> FilePath - -> ModTime -> Hash -> IO Bool -checkFileModificationTimeAndHashUnchanged root file mtime chash = - handleIOException False $ do - mtime' <- getModTime (root file) - if mtime == mtime' - then return True - else do - chash' <- readFileHash (root file) - return (chash == chash') - --- | Read a non-cryptographic hash of a @file@. -readFileHash :: FilePath -> IO Hash -readFileHash file = - withBinaryFile file ReadMode $ \hnd -> - evaluate . Hashable.hash =<< BS.hGetContents hnd - --- | Given a directory @dir@, return @Nothing@ if its 'ModTime' --- is the same as @mtime@, and the new 'ModTime' if it is not. -checkDirectoryModificationTime :: FilePath -> ModTime -> IO (Maybe ModTime) -checkDirectoryModificationTime dir mtime = - handleIOException Nothing $ do - mtime' <- getModTime dir - if mtime == mtime' - then return Nothing - else return (Just mtime') - --- | Run an IO computation, returning the first argument @e@ if there is an 'error' --- call. ('ErrorCall') -handleErrorCall :: a -> IO a -> IO a -handleErrorCall e = handle handler where -#if MIN_VERSION_base(4,9,0) - handler (ErrorCallWithLocation _ _) = return e -#else - handler (ErrorCall _) = return e -#endif - - --- | Run an IO computation, returning @e@ if there is any 'IOException'. --- --- This policy is OK in the file monitor code because it just causes the --- monitor to report that something changed, and then code reacting to that --- will normally encounter the same IO exception when it re-runs the action --- that uses the file. --- -handleIOException :: a -> IO a -> IO a -handleIOException e = - handle (anyIOException e) - where - anyIOException :: a -> IOException -> IO a - anyIOException x _ = return x - - ------------------------------------------------------------------------------- --- Instances --- - diff --git a/cabal/cabal-install/Distribution/Client/Freeze.hs b/cabal/cabal-install/Distribution/Client/Freeze.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Freeze.hs +++ /dev/null @@ -1,266 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Freeze --- Copyright : (c) David Himmelstrup 2005 --- Duncan Coutts 2011 --- License : BSD-like --- --- Maintainer : cabal-devel@gmail.com --- Stability : provisional --- Portability : portable --- --- The cabal freeze command ------------------------------------------------------------------------------ -module Distribution.Client.Freeze ( - freeze, getFreezePkgs - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude - -import Distribution.Client.Config ( SavedConfig(..) ) -import Distribution.Client.Types -import Distribution.Client.Targets -import Distribution.Client.Dependency -import Distribution.Client.IndexUtils as IndexUtils - ( getSourcePackages, getInstalledPackages ) -import Distribution.Client.SolverInstallPlan - ( SolverInstallPlan, SolverPlanPackage ) -import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan -import Distribution.Client.Setup - ( GlobalFlags(..), FreezeFlags(..), ConfigExFlags(..) - , RepoContext(..) ) -import Distribution.Client.Sandbox.PackageEnvironment - ( loadUserConfig, pkgEnvSavedConfig, showPackageEnvironment, - userPackageEnvironmentFile ) - -import Distribution.Solver.Types.ConstraintSource -import Distribution.Solver.Types.LabeledPackageConstraint -import Distribution.Solver.Types.OptionalStanza -import Distribution.Solver.Types.PkgConfigDb -import Distribution.Solver.Types.SolverId - -import Distribution.Package - ( Package, packageId, packageName, packageVersion ) -import Distribution.Simple.Compiler - ( Compiler, compilerInfo, PackageDBStack ) -import Distribution.Simple.PackageIndex (InstalledPackageIndex) -import Distribution.Simple.Program - ( ProgramDb ) -import Distribution.Simple.Setup - ( fromFlag, fromFlagOrDefault, flagToMaybe ) -import Distribution.Simple.Utils - ( die', notice, debug, writeFileAtomic, toUTF8LBS) -import Distribution.System - ( Platform ) - -import Distribution.Version - ( thisVersion ) - --- ------------------------------------------------------------ --- * The freeze command --- ------------------------------------------------------------ - --- | Freeze all of the dependencies by writing a constraints section --- constraining each dependency to an exact version. --- -freeze :: Verbosity - -> PackageDBStack - -> RepoContext - -> Compiler - -> Platform - -> ProgramDb - -> GlobalFlags - -> FreezeFlags - -> IO () -freeze verbosity packageDBs repoCtxt comp platform progdb - globalFlags freezeFlags = do - - pkgs <- getFreezePkgs - verbosity packageDBs repoCtxt comp platform progdb - globalFlags freezeFlags - - if null pkgs - then notice verbosity $ "No packages to be frozen. " - ++ "As this package has no dependencies." - else if dryRun - then notice verbosity $ unlines $ - "The following packages would be frozen:" - : formatPkgs pkgs - - else freezePackages verbosity globalFlags pkgs - - where - dryRun = fromFlag (freezeDryRun freezeFlags) - --- | Get the list of packages whose versions would be frozen by the @freeze@ --- command. -getFreezePkgs :: Verbosity - -> PackageDBStack - -> RepoContext - -> Compiler - -> Platform - -> ProgramDb - -> GlobalFlags - -> FreezeFlags - -> IO [SolverPlanPackage] -getFreezePkgs verbosity packageDBs repoCtxt comp platform progdb - globalFlags freezeFlags = do - - installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb - sourcePkgDb <- getSourcePackages verbosity repoCtxt - pkgConfigDb <- readPkgConfigDb verbosity progdb - - pkgSpecifiers <- resolveUserTargets verbosity repoCtxt - (fromFlag $ globalWorldFile globalFlags) - (packageIndex sourcePkgDb) - [UserTargetLocalDir "."] - - sanityCheck pkgSpecifiers - planPackages - verbosity comp platform freezeFlags - installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers - where - sanityCheck pkgSpecifiers = do - when (not . null $ [n | n@(NamedPackage _ _) <- pkgSpecifiers]) $ - die' verbosity $ "internal error: 'resolveUserTargets' returned " - ++ "unexpected named package specifiers!" - when (length pkgSpecifiers /= 1) $ - die' verbosity $ "internal error: 'resolveUserTargets' returned " - ++ "unexpected source package specifiers!" - -planPackages :: Verbosity - -> Compiler - -> Platform - -> FreezeFlags - -> InstalledPackageIndex - -> SourcePackageDb - -> PkgConfigDb - -> [PackageSpecifier UnresolvedSourcePackage] - -> IO [SolverPlanPackage] -planPackages verbosity comp platform freezeFlags - installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers = do - - solver <- chooseSolver verbosity - (fromFlag (freezeSolver freezeFlags)) (compilerInfo comp) - notice verbosity "Resolving dependencies..." - - installPlan <- foldProgress logMsg (die' verbosity) return $ - resolveDependencies - platform (compilerInfo comp) pkgConfigDb - solver - resolverParams - - return $ pruneInstallPlan installPlan pkgSpecifiers - - where - resolverParams = - - setMaxBackjumps (if maxBackjumps < 0 then Nothing - else Just maxBackjumps) - - . setIndependentGoals independentGoals - - . setReorderGoals reorderGoals - - . setCountConflicts countConflicts - - . setFineGrainedConflicts fineGrainedConflicts - - . setMinimizeConflictSet minimizeConflictSet - - . setShadowPkgs shadowPkgs - - . setStrongFlags strongFlags - - . setAllowBootLibInstalls allowBootLibInstalls - - . setOnlyConstrained onlyConstrained - - . setSolverVerbosity verbosity - - . addConstraints - [ let pkg = pkgSpecifierTarget pkgSpecifier - pc = PackageConstraint (scopeToplevel pkg) - (PackagePropertyStanzas stanzas) - in LabeledPackageConstraint pc ConstraintSourceFreeze - | pkgSpecifier <- pkgSpecifiers ] - - $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers - - logMsg message rest = debug verbosity message >> rest - - stanzas = [ TestStanzas | testsEnabled ] - ++ [ BenchStanzas | benchmarksEnabled ] - testsEnabled = fromFlagOrDefault False $ freezeTests freezeFlags - benchmarksEnabled = fromFlagOrDefault False $ freezeBenchmarks freezeFlags - - reorderGoals = fromFlag (freezeReorderGoals freezeFlags) - countConflicts = fromFlag (freezeCountConflicts freezeFlags) - fineGrainedConflicts = fromFlag (freezeFineGrainedConflicts freezeFlags) - minimizeConflictSet = fromFlag (freezeMinimizeConflictSet freezeFlags) - independentGoals = fromFlag (freezeIndependentGoals freezeFlags) - shadowPkgs = fromFlag (freezeShadowPkgs freezeFlags) - strongFlags = fromFlag (freezeStrongFlags freezeFlags) - maxBackjumps = fromFlag (freezeMaxBackjumps freezeFlags) - allowBootLibInstalls = fromFlag (freezeAllowBootLibInstalls freezeFlags) - onlyConstrained = fromFlag (freezeOnlyConstrained freezeFlags) - - --- | Remove all unneeded packages from an install plan. --- --- A package is unneeded if it is either --- --- 1) the package that we are freezing, or --- --- 2) not a dependency (directly or transitively) of the package we are --- freezing. This is useful for removing previously installed packages --- which are no longer required from the install plan. --- --- Invariant: @pkgSpecifiers@ must refer to packages which are not --- 'PreExisting' in the 'SolverInstallPlan'. -pruneInstallPlan :: SolverInstallPlan - -> [PackageSpecifier UnresolvedSourcePackage] - -> [SolverPlanPackage] -pruneInstallPlan installPlan pkgSpecifiers = - removeSelf pkgIds $ - SolverInstallPlan.dependencyClosure installPlan pkgIds - where - pkgIds = [ PlannedId (packageId pkg) - | SpecificSourcePackage pkg <- pkgSpecifiers ] - removeSelf [thisPkg] = filter (\pp -> packageId pp /= packageId thisPkg) - removeSelf _ = error $ "internal error: 'pruneInstallPlan' given " - ++ "unexpected package specifiers!" - - -freezePackages :: Package pkg => Verbosity -> GlobalFlags -> [pkg] -> IO () -freezePackages verbosity globalFlags pkgs = do - - pkgEnv <- fmap (createPkgEnv . addFrozenConstraints) $ - loadUserConfig verbosity "" - (flagToMaybe . globalConstraintsFile $ globalFlags) - writeFileAtomic userPackageEnvironmentFile $ showPkgEnv pkgEnv - where - addFrozenConstraints config = - config { - savedConfigureExFlags = (savedConfigureExFlags config) { - configExConstraints = map constraint pkgs - } - } - constraint pkg = - (pkgIdToConstraint $ packageId pkg - ,ConstraintSourceUserConfig userPackageEnvironmentFile) - where - pkgIdToConstraint pkgId = - UserConstraint (UserQualified UserQualToplevel (packageName pkgId)) - (PackagePropertyVersion $ thisVersion (packageVersion pkgId)) - createPkgEnv config = mempty { pkgEnvSavedConfig = config } - showPkgEnv = toUTF8LBS . showPackageEnvironment - - -formatPkgs :: Package pkg => [pkg] -> [String] -formatPkgs = map $ showPkg . packageId - where - showPkg pid = name pid ++ " == " ++ version pid - name = prettyShow . packageName - version = prettyShow . packageVersion diff --git a/cabal/cabal-install/Distribution/Client/GZipUtils.hs b/cabal/cabal-install/Distribution/Client/GZipUtils.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/GZipUtils.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.GZipUtils --- Copyright : (c) Dmitry Astapov 2010 --- License : BSD-like --- --- Maintainer : cabal-devel@gmail.com --- Stability : provisional --- Portability : portable --- --- Provides a convenience functions for working with files that may or may not --- be zipped. ------------------------------------------------------------------------------ -module Distribution.Client.GZipUtils ( - maybeDecompress, - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude - -import Codec.Compression.Zlib.Internal -import Data.ByteString.Lazy.Internal as BS (ByteString(Empty, Chunk)) - -#ifndef MIN_VERSION_zlib -#define MIN_VERSION_zlib(x,y,z) 1 -#endif - -#if MIN_VERSION_zlib(0,6,0) -import Control.Exception (throw) -import Control.Monad.ST.Lazy (ST, runST) -import qualified Data.ByteString as Strict -#endif - --- | Attempts to decompress the `bytes' under the assumption that --- "data format" error at the very beginning of the stream means --- that it is already decompressed. Caller should make sanity checks --- to verify that it is not, in fact, garbage. --- --- This is to deal with http proxies that lie to us and transparently --- decompress without removing the content-encoding header. See: --- --- -maybeDecompress :: ByteString -> ByteString -#if MIN_VERSION_zlib(0,6,0) -maybeDecompress bytes = runST (go bytes decompressor) - where - decompressor :: DecompressStream (ST s) - decompressor = decompressST gzipOrZlibFormat defaultDecompressParams - - -- DataError at the beginning of the stream probably means that stream is - -- not compressed, so we return it as-is. - -- TODO: alternatively, we might consider looking for the two magic bytes - -- 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 _ (DecompressStreamEnd _bs ) = return Empty - go _ (DecompressStreamError _err ) = return bytes - go cs (DecompressInputRequired k) = go cs' =<< k c - where - (c, cs') = uncons cs - - -- Once we have received any output though we regard errors as actual errors - -- 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' _ (DecompressStreamEnd _bs ) = return Empty - go' _ (DecompressStreamError err ) = throw err - go' cs (DecompressInputRequired k) = go' cs' =<< k c - where - (c, cs') = uncons cs - - uncons :: ByteString -> (Strict.ByteString, ByteString) - uncons Empty = (Strict.empty, Empty) - uncons (Chunk c cs) = (c, cs) -#else -maybeDecompress bytes = foldStream $ decompressWithErrors gzipOrZlibFormat defaultDecompressParams bytes - where - -- DataError at the beginning of the stream probably means that stream is not compressed. - -- Returning it as-is. - -- TODO: alternatively, we might consider looking for the two magic bytes - -- at the beginning of the gzip header. - foldStream (StreamError _ _) = bytes - foldStream somethingElse = doFold somethingElse - - doFold StreamEnd = BS.Empty - doFold (StreamChunk bs stream) = BS.Chunk bs (doFold stream) - doFold (StreamError _ msg) = error $ "Codec.Compression.Zlib: " ++ msg -#endif diff --git a/cabal/cabal-install/Distribution/Client/GenBounds.hs b/cabal/cabal-install/Distribution/Client/GenBounds.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/GenBounds.hs +++ /dev/null @@ -1,161 +0,0 @@ -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.GenBounds --- Copyright : (c) Doug Beardsley 2015 --- License : BSD-like --- --- Maintainer : cabal-devel@gmail.com --- Stability : provisional --- Portability : portable --- --- The cabal gen-bounds command for generating PVP-compliant version bounds. ------------------------------------------------------------------------------ -module Distribution.Client.GenBounds ( - genBounds - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude -import Distribution.Utils.Generic (safeLast) - -import Distribution.Client.Init - ( incVersion ) -import Distribution.Client.Freeze - ( getFreezePkgs ) -import Distribution.Client.Setup - ( GlobalFlags(..), FreezeFlags(..), RepoContext ) -import Distribution.Package - ( Package(..), unPackageName, packageName, packageVersion ) -import Distribution.PackageDescription - ( enabledBuildDepends ) -import Distribution.PackageDescription.Configuration - ( finalizePD ) -import Distribution.PackageDescription.Parsec - ( readGenericPackageDescription ) -import Distribution.Types.ComponentRequestedSpec - ( defaultComponentRequestedSpec ) -import Distribution.Types.Dependency -import Distribution.Simple.Compiler - ( Compiler, PackageDBStack, compilerInfo ) -import Distribution.Simple.Program - ( ProgramDb ) -import Distribution.Simple.Utils - ( tryFindPackageDesc ) -import Distribution.System - ( Platform ) -import Distribution.Version - ( Version, alterVersion - , LowerBound(..), UpperBound(..), VersionRange, asVersionIntervals - , orLaterVersion, earlierVersion, intersectVersionRanges ) -import System.Directory - ( getCurrentDirectory ) - --- | Does this version range have an upper bound? -hasUpperBound :: VersionRange -> Bool -hasUpperBound vr = - case safeLast (asVersionIntervals vr) of - Nothing -> False - Just l -> if snd l == NoUpperBound then False else True - --- | Given a version, return an API-compatible (according to PVP) version range. --- --- Example: @0.4.1.2@ produces the version range @>= 0.4.1 && < 0.5@. --- --- This version is slightly different than the one in --- 'Distribution.Client.Init'. This one uses a.b.c as the lower bound because --- the user could be using a new function introduced in a.b.c which would make --- ">= a.b" incorrect. -pvpize :: Version -> VersionRange -pvpize v = orLaterVersion (vn 3) - `intersectVersionRanges` - earlierVersion (incVersion 1 (vn 2)) - where - vn n = alterVersion (take n) v - --- | Show the PVP-mandated version range for this package. The @padTo@ parameter --- specifies the width of the package name column. -showBounds :: Package pkg => Int -> pkg -> String -showBounds padTo p = unwords $ - (padAfter padTo $ unPackageName $ packageName p) : - map showInterval (asVersionIntervals $ pvpize $ packageVersion p) - where - padAfter :: Int -> String -> String - padAfter n str = str ++ replicate (n - length str) ' ' - - showInterval :: (LowerBound, UpperBound) -> String - showInterval (LowerBound _ _, NoUpperBound) = - error "Error: expected upper bound...this should never happen!" - showInterval (LowerBound l _, UpperBound u _) = - unwords [">=", prettyShow l, "&& <", prettyShow u] - --- | Entry point for the @gen-bounds@ command. -genBounds - :: Verbosity - -> PackageDBStack - -> RepoContext - -> Compiler - -> Platform - -> ProgramDb - -> GlobalFlags - -> FreezeFlags - -> IO () -genBounds verbosity packageDBs repoCtxt comp platform progdb globalFlags freezeFlags = do - let cinfo = compilerInfo comp - - cwd <- getCurrentDirectory - path <- tryFindPackageDesc verbosity cwd - gpd <- readGenericPackageDescription verbosity path - -- NB: We don't enable tests or benchmarks, since often they - -- don't really have useful bounds. - let epd = finalizePD mempty defaultComponentRequestedSpec - (const True) platform cinfo [] gpd - case epd of - Left _ -> putStrLn "finalizePD failed" - Right (pd,_) -> do - let needBounds = filter (not . hasUpperBound . depVersion) $ - enabledBuildDepends pd defaultComponentRequestedSpec - - if (null needBounds) - then putStrLn - "Congratulations, all your dependencies have upper bounds!" - else go needBounds - where - go needBounds = do - pkgs <- getFreezePkgs - verbosity packageDBs repoCtxt comp platform progdb - globalFlags freezeFlags - - putStrLn boundsNeededMsg - - let isNeeded pkg = unPackageName (packageName pkg) - `elem` map depName needBounds - let thePkgs = filter isNeeded pkgs - - let padTo = maximum $ map (length . unPackageName . packageName) pkgs - traverse_ (putStrLn . (++",") . showBounds padTo) thePkgs - - depName :: Dependency -> String - depName (Dependency pn _ _) = unPackageName pn - - depVersion :: Dependency -> VersionRange - depVersion (Dependency _ vr _) = vr - --- | The message printed when some dependencies are found to be lacking proper --- PVP-mandated bounds. -boundsNeededMsg :: String -boundsNeededMsg = unlines - [ "" - , "The following packages need bounds and here is a suggested starting point." - , "You can copy and paste this into the build-depends section in your .cabal" - , "file and it should work (with the appropriate removal of commas)." - , "" - , "Note that version bounds are a statement that you've successfully built and" - , "tested your package and expect it to work with any of the specified package" - , "versions (PROVIDED that those packages continue to conform with the PVP)." - , "Therefore, the version bounds generated here are the most conservative" - , "based on the versions that you are currently building with. If you know" - , "your package will work with versions outside the ranges generated here," - , "feel free to widen them." - , "" - ] diff --git a/cabal/cabal-install/Distribution/Client/Get.hs b/cabal/cabal-install/Distribution/Client/Get.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Get.hs +++ /dev/null @@ -1,333 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Get --- Copyright : (c) Andrea Vezzosi 2008 --- Duncan Coutts 2011 --- John Millikin 2012 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- The 'cabal get' command. ------------------------------------------------------------------------------ - -module Distribution.Client.Get ( - get, - - -- * Cloning 'SourceRepo's - -- | Mainly exported for testing purposes - clonePackagesFromSourceRepo, - ClonePackageException(..), - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude hiding (get) -import Distribution.Compat.Directory - ( listDirectory ) -import Distribution.Package - ( PackageId, packageId, packageName ) -import Distribution.Simple.Setup - ( Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe ) -import Distribution.Simple.Utils - ( notice, die', info, writeFileAtomic ) -import qualified Distribution.PackageDescription as PD -import Distribution.Simple.Program - ( programName ) -import Distribution.Types.SourceRepo (RepoKind (..)) -import Distribution.Client.Types.SourceRepo (SourceRepositoryPackage (..), SourceRepoProxy, srpToProxy) - -import Distribution.Client.Setup - ( GlobalFlags(..), GetFlags(..), RepoContext(..) ) -import Distribution.Client.Types -import Distribution.Client.Targets -import Distribution.Client.Dependency -import Distribution.Client.VCS -import Distribution.Client.FetchUtils -import qualified Distribution.Client.Tar as Tar (extractTarGzFile) -import Distribution.Client.IndexUtils - ( getSourcePackagesAtIndexState, TotalIndexState, ActiveRepos ) -import Distribution.Solver.Types.SourcePackage - -import qualified Data.Map as Map -import System.Directory - ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist ) -import System.FilePath - ( (), (<.>), addTrailingPathSeparator ) - - --- | Entry point for the 'cabal get' command. -get :: Verbosity - -> RepoContext - -> GlobalFlags - -> GetFlags - -> [UserTarget] - -> IO () -get verbosity _ _ _ [] = - notice verbosity "No packages requested. Nothing to do." - -get verbosity repoCtxt globalFlags getFlags userTargets = do - let useSourceRepo = case getSourceRepository getFlags of - NoFlag -> False - _ -> True - - unless useSourceRepo $ - traverse_ (checkTarget verbosity) userTargets - - let idxState :: Maybe TotalIndexState - idxState = flagToMaybe $ getIndexState getFlags - - activeRepos :: Maybe ActiveRepos - activeRepos = flagToMaybe $ getActiveRepos getFlags - - (sourcePkgDb, _, _) <- getSourcePackagesAtIndexState verbosity repoCtxt idxState activeRepos - - pkgSpecifiers <- resolveUserTargets verbosity repoCtxt - (fromFlag $ globalWorldFile globalFlags) - (packageIndex sourcePkgDb) - userTargets - - pkgs <- either (die' verbosity . unlines . map show) return $ - resolveWithoutDependencies - (resolverParams sourcePkgDb pkgSpecifiers) - - unless (null prefix) $ - createDirectoryIfMissing True prefix - - if useSourceRepo - then clone pkgs - else unpack pkgs - - where - resolverParams sourcePkgDb pkgSpecifiers = - --TODO: add command-line constraint and preference args for unpack - standardInstallPolicy mempty sourcePkgDb pkgSpecifiers - - prefix = fromFlagOrDefault "" (getDestDir getFlags) - - clone :: [UnresolvedSourcePackage] -> IO () - clone = clonePackagesFromSourceRepo verbosity prefix kind - . map (\pkg -> (packageId pkg, packageSourceRepos pkg)) - where - kind = fromFlag . getSourceRepository $ getFlags - packageSourceRepos :: SourcePackage loc -> [PD.SourceRepo] - packageSourceRepos = PD.sourceRepos - . PD.packageDescription - . srcpkgDescription - - unpack :: [UnresolvedSourcePackage] -> IO () - unpack pkgs = do - for_ pkgs $ \pkg -> do - location <- fetchPackage verbosity repoCtxt (srcpkgSource pkg) - let pkgid = packageId pkg - descOverride | usePristine = Nothing - | otherwise = srcpkgDescrOverride pkg - case location of - LocalTarballPackage tarballPath -> - unpackPackage verbosity prefix pkgid descOverride tarballPath - - RemoteTarballPackage _tarballURL tarballPath -> - unpackPackage verbosity prefix pkgid descOverride tarballPath - - RepoTarballPackage _repo _pkgid tarballPath -> - unpackPackage verbosity prefix pkgid descOverride tarballPath - - RemoteSourceRepoPackage _repo _ -> - die' verbosity $ "The 'get' command does no yet support targets " - ++ "that are remote source repositories." - - LocalUnpackedPackage _ -> - error "Distribution.Client.Get.unpack: the impossible happened." - where - usePristine = fromFlagOrDefault False (getPristine getFlags) - -checkTarget :: Verbosity -> UserTarget -> IO () -checkTarget verbosity target = case target of - UserTargetLocalDir dir -> die' verbosity (notTarball dir) - UserTargetLocalCabalFile file -> die' verbosity (notTarball file) - _ -> return () - where - notTarball t = - "The 'get' command is for tarball packages. " - ++ "The target '" ++ t ++ "' is not a tarball." - --- ------------------------------------------------------------ --- * Unpacking the source tarball --- ------------------------------------------------------------ - -unpackPackage :: Verbosity -> FilePath -> PackageId - -> PackageDescriptionOverride - -> FilePath -> IO () -unpackPackage verbosity prefix pkgid descOverride pkgPath = do - let pkgdirname = prettyShow pkgid - pkgdir = prefix pkgdirname - pkgdir' = addTrailingPathSeparator pkgdir - emptyDirectory directory = null <$> listDirectory directory - existsDir <- doesDirectoryExist pkgdir - when existsDir $ do - isEmpty <- emptyDirectory pkgdir - unless isEmpty $ - die' verbosity $ - "The directory \"" ++ pkgdir' ++ "\" already exists and is not empty, not unpacking." - existsFile <- doesFileExist pkgdir - when existsFile $ die' verbosity $ - "A file \"" ++ pkgdir ++ "\" is in the way, not unpacking." - notice verbosity $ "Unpacking to " ++ pkgdir' - Tar.extractTarGzFile prefix pkgdirname pkgPath - - case descOverride of - Nothing -> return () - Just pkgtxt -> do - let descFilePath = pkgdir prettyShow (packageName pkgid) <.> "cabal" - info verbosity $ - "Updating " ++ descFilePath - ++ " with the latest revision from the index." - writeFileAtomic descFilePath pkgtxt - - --- ------------------------------------------------------------ --- * Cloning packages from their declared source repositories --- ------------------------------------------------------------ - - -data ClonePackageException = - ClonePackageNoSourceRepos PackageId - | ClonePackageNoSourceReposOfKind PackageId (Maybe RepoKind) - | ClonePackageNoRepoType PackageId PD.SourceRepo - | ClonePackageUnsupportedRepoType PackageId SourceRepoProxy RepoType - | ClonePackageNoRepoLocation PackageId PD.SourceRepo - | ClonePackageDestinationExists PackageId FilePath Bool - | ClonePackageFailedWithExitCode PackageId SourceRepoProxy String ExitCode - deriving (Show, Eq) - -instance Exception ClonePackageException where - displayException (ClonePackageNoSourceRepos pkgid) = - "Cannot fetch a source repository for package " ++ prettyShow pkgid - ++ ". The package does not specify any source repositories." - - displayException (ClonePackageNoSourceReposOfKind pkgid repoKind) = - "Cannot fetch a source repository for package " ++ prettyShow pkgid - ++ ". The package does not specify a source repository of the requested " - ++ "kind" ++ maybe "." (\k -> " (kind " ++ prettyShow k ++ ").") repoKind - - displayException (ClonePackageNoRepoType pkgid _repo) = - "Cannot fetch the source repository for package " ++ prettyShow pkgid - ++ ". The package's description specifies a source repository but does " - ++ "not specify the repository 'type' field (e.g. git, darcs or hg)." - - displayException (ClonePackageUnsupportedRepoType pkgid _ repoType) = - "Cannot fetch the source repository for package " ++ prettyShow pkgid - ++ ". The repository type '" ++ prettyShow repoType - ++ "' is not yet supported." - - displayException (ClonePackageNoRepoLocation pkgid _repo) = - "Cannot fetch the source repository for package " ++ prettyShow pkgid - ++ ". The package's description specifies a source repository but does " - ++ "not specify the repository 'location' field (i.e. the URL)." - - displayException (ClonePackageDestinationExists pkgid dest isdir) = - "Not fetching the source repository for package " ++ prettyShow pkgid ++ ". " - ++ if isdir then "The destination directory " ++ dest ++ " already exists." - else "A file " ++ dest ++ " is in the way." - - displayException (ClonePackageFailedWithExitCode - pkgid repo vcsprogname exitcode) = - "Failed to fetch the source repository for package " ++ prettyShow pkgid - ++ ", repository location " ++ srpLocation repo ++ " (" - ++ vcsprogname ++ " failed with " ++ show exitcode ++ ")." - - --- | Given a bunch of package ids and their corresponding available --- 'SourceRepo's, pick a single 'SourceRepo' for each one and clone into --- new subdirs of the given directory. --- -clonePackagesFromSourceRepo :: Verbosity - -> FilePath -- ^ destination dir prefix - -> Maybe RepoKind -- ^ preferred 'RepoKind' - -> [(PackageId, [PD.SourceRepo])] - -- ^ the packages and their - -- available 'SourceRepo's - -> IO () -clonePackagesFromSourceRepo verbosity destDirPrefix - preferredRepoKind pkgrepos = do - - -- Do a bunch of checks and collect the required info - pkgrepos' <- traverse preCloneChecks pkgrepos - - -- Configure the VCS drivers for all the repository types we may need - vcss <- configureVCSs verbosity $ - Map.fromList [ (vcsRepoType vcs, vcs) - | (_, _, vcs, _) <- pkgrepos' ] - - -- Now execute all the required commands for each repo - sequence_ - [ cloneSourceRepo verbosity vcs' repo destDir - `catch` \exitcode -> - throwIO (ClonePackageFailedWithExitCode - pkgid (srpToProxy repo) (programName (vcsProgram vcs)) exitcode) - | (pkgid, repo, vcs, destDir) <- pkgrepos' - , let vcs' = Map.findWithDefault (error $ "Cannot configure " ++ prettyShow (vcsRepoType vcs)) (vcsRepoType vcs) vcss - ] - - where - preCloneChecks :: (PackageId, [PD.SourceRepo]) - -> IO (PackageId, SourceRepositoryPackage Maybe, VCS Program, FilePath) - preCloneChecks (pkgid, repos) = do - repo <- case selectPackageSourceRepo preferredRepoKind repos of - Just repo -> return repo - Nothing | null repos -> throwIO (ClonePackageNoSourceRepos pkgid) - Nothing -> throwIO (ClonePackageNoSourceReposOfKind - pkgid preferredRepoKind) - - (repo', vcs) <- case validatePDSourceRepo repo of - Right (repo', _, _, vcs) -> return (repo', vcs) - Left SourceRepoRepoTypeUnspecified -> - throwIO (ClonePackageNoRepoType pkgid repo) - - Left (SourceRepoRepoTypeUnsupported repo' repoType) -> - throwIO (ClonePackageUnsupportedRepoType pkgid repo' repoType) - - Left SourceRepoLocationUnspecified -> - throwIO (ClonePackageNoRepoLocation pkgid repo) - - let destDir = destDirPrefix prettyShow (packageName pkgid) - destDirExists <- doesDirectoryExist destDir - destFileExists <- doesFileExist destDir - when (destDirExists || destFileExists) $ - throwIO (ClonePackageDestinationExists pkgid destDir destDirExists) - - return (pkgid, repo', vcs, destDir) - -------------------------------------------------------------------------------- --- Selecting -------------------------------------------------------------------------------- - --- | Pick the 'SourceRepo' to use to get the package sources from. --- --- Note that this does /not/ depend on what 'VCS' drivers we are able to --- successfully configure. It is based only on the 'SourceRepo's declared --- in the package, and optionally on a preferred 'RepoKind'. --- -selectPackageSourceRepo :: Maybe RepoKind - -> [PD.SourceRepo] - -> Maybe PD.SourceRepo -selectPackageSourceRepo preferredRepoKind = - listToMaybe - -- Sort repositories by kind, from This to Head to Unknown. Repositories - -- with equivalent kinds are selected based on the order they appear in - -- the Cabal description file. - . sortBy (comparing thisFirst) - -- If the user has specified the repo kind, filter out the repositories - -- they're not interested in. - . filter (\repo -> maybe True (PD.repoKind repo ==) preferredRepoKind) - where - thisFirst :: PD.SourceRepo -> Int - thisFirst r = case PD.repoKind r of - RepoThis -> 0 - RepoHead -> case PD.repoTag r of - -- If the type is 'head' but the author specified a tag, they - -- probably meant to create a 'this' repository but screwed up. - Just _ -> 0 - Nothing -> 1 - RepoKindUnknown _ -> 2 diff --git a/cabal/cabal-install/Distribution/Client/Glob.hs b/cabal/cabal-install/Distribution/Client/Glob.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Glob.hs +++ /dev/null @@ -1,244 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - ---TODO: [code cleanup] plausibly much of this module should be merged with --- similar functionality in Cabal. -module Distribution.Client.Glob - ( FilePathGlob(..) - , FilePathRoot(..) - , FilePathGlobRel(..) - , Glob - , GlobPiece(..) - , matchFileGlob - , matchFileGlobRel - , matchGlob - , isTrivialFilePathGlob - , getFilePathRootDirectory - ) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Data.List (stripPrefix) -import System.Directory -import System.FilePath - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - - --- | A file path specified by globbing --- -data FilePathGlob = FilePathGlob FilePathRoot FilePathGlobRel - deriving (Eq, Show, Generic) - -data FilePathGlobRel - = GlobDir !Glob !FilePathGlobRel - | GlobFile !Glob - | GlobDirTrailing -- ^ trailing dir, a glob ending in @/@ - deriving (Eq, Show, Generic) - --- | A single directory or file component of a globbed path -type Glob = [GlobPiece] - --- | A piece of a globbing pattern -data GlobPiece = WildCard - | Literal String - | Union [Glob] - deriving (Eq, Show, Generic) - -data FilePathRoot - = FilePathRelative - | FilePathRoot FilePath -- ^ e.g. @"/"@, @"c:\"@ or result of 'takeDrive' - | FilePathHomeDir - deriving (Eq, Show, Generic) - -instance Binary FilePathGlob -instance Binary FilePathRoot -instance Binary FilePathGlobRel -instance Binary GlobPiece - -instance Structured FilePathGlob -instance Structured FilePathRoot -instance Structured FilePathGlobRel -instance Structured GlobPiece - --- | Check if a 'FilePathGlob' doesn't actually make use of any globbing and --- is in fact equivalent to a non-glob 'FilePath'. --- --- If it is trivial in this sense then the result is the equivalent constant --- 'FilePath'. On the other hand if it is not trivial (so could in principle --- match more than one file) then the result is @Nothing@. --- -isTrivialFilePathGlob :: FilePathGlob -> Maybe FilePath -isTrivialFilePathGlob (FilePathGlob root pathglob) = - case root of - FilePathRelative -> go [] pathglob - FilePathRoot root' -> go [root'] pathglob - FilePathHomeDir -> Nothing - where - go paths (GlobDir [Literal path] globs) = go (path:paths) globs - go paths (GlobFile [Literal path]) = Just (joinPath (reverse (path:paths))) - go paths GlobDirTrailing = Just (addTrailingPathSeparator - (joinPath (reverse paths))) - go _ _ = Nothing - --- | Get the 'FilePath' corresponding to a 'FilePathRoot'. --- --- The 'FilePath' argument is required to supply the path for the --- 'FilePathRelative' case. --- -getFilePathRootDirectory :: FilePathRoot - -> FilePath -- ^ root for relative paths - -> IO FilePath -getFilePathRootDirectory FilePathRelative root = return root -getFilePathRootDirectory (FilePathRoot root) _ = return root -getFilePathRootDirectory FilePathHomeDir _ = getHomeDirectory - - ------------------------------------------------------------------------------- --- Matching --- - --- | Match a 'FilePathGlob' against the file system, starting from a given --- root directory for relative paths. The results of relative globs are --- relative to the given root. Matches for absolute globs are absolute. --- -matchFileGlob :: FilePath -> FilePathGlob -> IO [FilePath] -matchFileGlob relroot (FilePathGlob globroot glob) = do - root <- getFilePathRootDirectory globroot relroot - matches <- matchFileGlobRel root glob - case globroot of - FilePathRelative -> return matches - _ -> return (map (root ) matches) - --- | Match a 'FilePathGlobRel' against the file system, starting from a --- given root directory. The results are all relative to the given root. --- -matchFileGlobRel :: FilePath -> FilePathGlobRel -> IO [FilePath] -matchFileGlobRel root glob0 = go glob0 "" - where - go (GlobFile glob) dir = do - entries <- getDirectoryContents (root dir) - let files = filter (matchGlob glob) entries - return (map (dir ) files) - - go (GlobDir glob globPath) dir = do - entries <- getDirectoryContents (root dir) - subdirs <- filterM (\subdir -> doesDirectoryExist - (root dir subdir)) - $ filter (matchGlob glob) entries - concat <$> traverse (\subdir -> go globPath (dir subdir)) subdirs - - go GlobDirTrailing dir = return [dir] - - --- | Match a globbing pattern against a file path component --- -matchGlob :: Glob -> String -> Bool -matchGlob = goStart - where - -- From the man page, glob(7): - -- "If a filename starts with a '.', this character must be - -- matched explicitly." - - go, goStart :: [GlobPiece] -> String -> Bool - - goStart (WildCard:_) ('.':_) = False - goStart (Union globs:rest) cs = any (\glob -> goStart (glob ++ rest) cs) - globs - goStart rest cs = go rest cs - - go [] "" = True - go (Literal lit:rest) cs - | Just cs' <- stripPrefix lit cs - = go rest cs' - | otherwise = False - go [WildCard] "" = True - go (WildCard:rest) (c:cs) = go rest (c:cs) || go (WildCard:rest) cs - go (Union globs:rest) cs = any (\glob -> go (glob ++ rest) cs) globs - go [] (_:_) = False - go (_:_) "" = False - - ------------------------------------------------------------------------------- --- Parsing & printing --- - -instance Pretty FilePathGlob where - pretty (FilePathGlob root pathglob) = pretty root Disp.<> pretty pathglob - -instance Parsec FilePathGlob where - parsec = do - root <- parsec - case root of - FilePathRelative -> FilePathGlob root <$> parsec - _ -> FilePathGlob root <$> parsec <|> pure (FilePathGlob root GlobDirTrailing) - -instance Pretty FilePathRoot where - pretty FilePathRelative = Disp.empty - pretty (FilePathRoot root) = Disp.text root - pretty FilePathHomeDir = Disp.char '~' Disp.<> Disp.char '/' - -instance Parsec FilePathRoot where - parsec = root <|> P.try home <|> P.try drive <|> pure FilePathRelative where - root = FilePathRoot "/" <$ P.char '/' - home = FilePathHomeDir <$ P.string "~/" - drive = do - dr <- P.satisfy $ \c -> (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') - _ <- P.char ':' - _ <- P.char '/' <|> P.char '\\' - return (FilePathRoot (toUpper dr : ":\\")) - -instance Pretty FilePathGlobRel where - pretty (GlobDir glob pathglob) = dispGlob glob - Disp.<> Disp.char '/' - Disp.<> pretty pathglob - pretty (GlobFile glob) = dispGlob glob - pretty GlobDirTrailing = Disp.empty - -instance Parsec FilePathGlobRel where - parsec = parsecPath where - parsecPath :: CabalParsing m => m FilePathGlobRel - parsecPath = do - glob <- parsecGlob - dirSep *> (GlobDir glob <$> parsecPath <|> pure (GlobDir glob GlobDirTrailing)) <|> pure (GlobFile glob) - - dirSep :: CabalParsing m => m () - dirSep = () <$ P.char '/' <|> P.try (do - _ <- P.char '\\' - -- check this isn't an escape code - P.notFollowedBy (P.satisfy isGlobEscapedChar)) - -dispGlob :: Glob -> Disp.Doc -dispGlob = Disp.hcat . map dispPiece - where - dispPiece WildCard = Disp.char '*' - dispPiece (Literal str) = Disp.text (escape str) - dispPiece (Union globs) = Disp.braces - (Disp.hcat (Disp.punctuate - (Disp.char ',') - (map dispGlob globs))) - escape [] = [] - escape (c:cs) - | isGlobEscapedChar c = '\\' : c : escape cs - | otherwise = c : escape cs - -parsecGlob :: CabalParsing m => m Glob -parsecGlob = some parsecPiece where - parsecPiece = P.choice [ literal, wildcard, union ] - - wildcard = WildCard <$ P.char '*' - union = Union . toList <$> P.between (P.char '{') (P.char '}') (P.sepByNonEmpty parsecGlob (P.char ',')) - literal = Literal <$> some litchar - - litchar = normal <|> escape - - normal = P.satisfy (\c -> not (isGlobEscapedChar c) && c /= '/' && c /= '\\') - escape = P.try $ P.char '\\' >> P.satisfy isGlobEscapedChar - -isGlobEscapedChar :: Char -> Bool -isGlobEscapedChar '*' = True -isGlobEscapedChar '{' = True -isGlobEscapedChar '}' = True -isGlobEscapedChar ',' = True -isGlobEscapedChar _ = False diff --git a/cabal/cabal-install/Distribution/Client/GlobalFlags.hs b/cabal/cabal-install/Distribution/Client/GlobalFlags.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/GlobalFlags.hs +++ /dev/null @@ -1,295 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RecordWildCards #-} - -module Distribution.Client.GlobalFlags ( - GlobalFlags(..) - , defaultGlobalFlags - , RepoContext(..) - , withRepoContext - , withRepoContext' - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude - -import Distribution.Client.Types - ( Repo(..), unRepoName, RemoteRepo(..), LocalRepo (..), localRepoCacheKey ) -import Distribution.Simple.Setup - ( Flag(..), fromFlag, flagToMaybe ) -import Distribution.Utils.NubList - ( NubList, fromNubList ) -import Distribution.Client.HttpUtils - ( HttpTransport, configureTransport ) -import Distribution.Simple.Utils - ( info, warn ) - -import Distribution.Client.IndexUtils.ActiveRepos - ( ActiveRepos ) - -import Control.Concurrent - ( MVar, newMVar, modifyMVar ) -import System.FilePath - ( () ) -import Network.URI - ( URI, uriScheme, uriPath ) -import qualified Data.Map as Map - -import qualified Hackage.Security.Client as Sec -import qualified Hackage.Security.Util.Path as Sec -import qualified Hackage.Security.Util.Pretty as Sec -import qualified Hackage.Security.Client.Repository.Cache as Sec -import qualified Hackage.Security.Client.Repository.Local as Sec.Local -import qualified Hackage.Security.Client.Repository.Remote as Sec.Remote -import qualified Distribution.Client.Security.HTTP as Sec.HTTP -import qualified Distribution.Client.Security.DNS as Sec.DNS - -import qualified System.FilePath.Posix as FilePath.Posix - --- ------------------------------------------------------------ --- * Global flags --- ------------------------------------------------------------ - --- | Flags that apply at the top level, not to any sub-command. - -data GlobalFlags = GlobalFlags - { globalVersion :: Flag Bool - , globalNumericVersion :: Flag Bool - , globalConfigFile :: Flag FilePath - , globalConstraintsFile :: Flag FilePath - , globalRemoteRepos :: NubList RemoteRepo -- ^ Available Hackage servers. - , globalCacheDir :: Flag FilePath - , globalLocalNoIndexRepos :: NubList LocalRepo - , globalActiveRepos :: Flag ActiveRepos - , globalLogsDir :: Flag FilePath - , globalWorldFile :: Flag FilePath - , globalIgnoreExpiry :: Flag Bool -- ^ Ignore security expiry dates - , globalHttpTransport :: Flag String - , globalNix :: Flag Bool -- ^ Integrate with Nix - , globalStoreDir :: Flag FilePath - , globalProgPathExtra :: NubList FilePath -- ^ Extra program path used for packagedb lookups in a global context (i.e. for http transports) - } deriving Generic - -defaultGlobalFlags :: GlobalFlags -defaultGlobalFlags = GlobalFlags - { globalVersion = Flag False - , globalNumericVersion = Flag False - , globalConfigFile = mempty - , globalConstraintsFile = mempty - , globalRemoteRepos = mempty - , globalCacheDir = mempty - , globalLocalNoIndexRepos = mempty - , globalActiveRepos = mempty - , globalLogsDir = mempty - , globalWorldFile = mempty - , globalIgnoreExpiry = Flag False - , globalHttpTransport = mempty - , globalNix = Flag False - , globalStoreDir = mempty - , globalProgPathExtra = mempty - } - -instance Monoid GlobalFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup GlobalFlags where - (<>) = gmappend - --- ------------------------------------------------------------ --- * Repo context --- ------------------------------------------------------------ - --- | Access to repositories -data RepoContext = RepoContext { - -- | All user-specified repositories - repoContextRepos :: [Repo] - - -- | Get the HTTP transport - -- - -- The transport will be initialized on the first call to this function. - -- - -- NOTE: It is important that we don't eagerly initialize the transport. - -- Initializing the transport is not free, and especially in contexts where - -- we don't know a-priori whether or not we need the transport (for instance - -- when using cabal in "nix mode") incurring the overhead of transport - -- initialization on _every_ invocation (eg @cabal build@) is undesirable. - , repoContextGetTransport :: IO HttpTransport - - -- | Get the (initialized) secure repo - -- - -- (the 'Repo' type itself is stateless and must remain so, because it - -- must be serializable) - , repoContextWithSecureRepo :: forall a. - Repo - -> (forall down. Sec.Repository down -> IO a) - -> IO a - - -- | Should we ignore expiry times (when checking security)? - , repoContextIgnoreExpiry :: Bool - } - --- | Wrapper around 'Repository', hiding the type argument -data SecureRepo = forall down. SecureRepo (Sec.Repository down) - -withRepoContext :: Verbosity -> GlobalFlags -> (RepoContext -> IO a) -> IO a -withRepoContext verbosity globalFlags = - withRepoContext' - verbosity - (fromNubList (globalRemoteRepos globalFlags)) - (fromNubList (globalLocalNoIndexRepos globalFlags)) - (fromFlag (globalCacheDir globalFlags)) - (flagToMaybe (globalHttpTransport globalFlags)) - (flagToMaybe (globalIgnoreExpiry globalFlags)) - (fromNubList (globalProgPathExtra globalFlags)) - -withRepoContext' :: Verbosity -> [RemoteRepo] -> [LocalRepo] - -> FilePath -> Maybe String -> Maybe Bool - -> [FilePath] - -> (RepoContext -> IO a) - -> IO a -withRepoContext' verbosity remoteRepos localNoIndexRepos - sharedCacheDir httpTransport ignoreExpiry extraPaths = \callback -> do - for_ localNoIndexRepos $ \local -> - unless (FilePath.Posix.isAbsolute (localRepoPath local)) $ - warn verbosity $ "file+noindex " ++ unRepoName (localRepoName local) ++ " repository path is not absolute; this is fragile, and not recommended" - - transportRef <- newMVar Nothing - let httpLib = Sec.HTTP.transportAdapter - verbosity - (getTransport transportRef) - initSecureRepos verbosity httpLib secureRemoteRepos $ \secureRepos' -> - callback RepoContext { - repoContextRepos = allRemoteRepos - ++ allLocalNoIndexRepos - , repoContextGetTransport = getTransport transportRef - , repoContextWithSecureRepo = withSecureRepo secureRepos' - , repoContextIgnoreExpiry = fromMaybe False ignoreExpiry - } - where - secureRemoteRepos = - [ (remote, cacheDir) | RepoSecure remote cacheDir <- allRemoteRepos ] - - allRemoteRepos :: [Repo] - allRemoteRepos = - [ (if isSecure then RepoSecure else RepoRemote) remote cacheDir - | remote <- remoteRepos - , let cacheDir = sharedCacheDir unRepoName (remoteRepoName remote) - isSecure = remoteRepoSecure remote == Just True - ] - - allLocalNoIndexRepos :: [Repo] - allLocalNoIndexRepos = - [ RepoLocalNoIndex local cacheDir - | local <- localNoIndexRepos - , let cacheDir | localRepoSharedCache local = sharedCacheDir localRepoCacheKey local - | otherwise = localRepoPath local - ] - - getTransport :: MVar (Maybe HttpTransport) -> IO HttpTransport - getTransport transportRef = - modifyMVar transportRef $ \mTransport -> do - transport <- case mTransport of - Just tr -> return tr - Nothing -> configureTransport verbosity extraPaths httpTransport - return (Just transport, transport) - - withSecureRepo :: Map Repo SecureRepo - -> Repo - -> (forall down. Sec.Repository down -> IO a) - -> IO a - withSecureRepo secureRepos repo callback = - case Map.lookup repo secureRepos of - Just (SecureRepo secureRepo) -> callback secureRepo - Nothing -> throwIO $ userError "repoContextWithSecureRepo: unknown repo" - --- | Initialize the provided secure repositories --- --- Assumed invariant: `remoteRepoSecure` should be set for all these repos. -initSecureRepos :: forall a. Verbosity - -> Sec.HTTP.HttpLib - -> [(RemoteRepo, FilePath)] - -> (Map Repo SecureRepo -> IO a) - -> IO a -initSecureRepos verbosity httpLib repos callback = go Map.empty repos - where - go :: Map Repo SecureRepo -> [(RemoteRepo, FilePath)] -> IO a - go !acc [] = callback acc - go !acc ((r,cacheDir):rs) = do - cachePath <- Sec.makeAbsolute $ Sec.fromFilePath cacheDir - initSecureRepo verbosity httpLib r cachePath $ \r' -> - go (Map.insert (RepoSecure r cacheDir) r' acc) rs - --- | Initialize the given secure repo --- --- The security library has its own concept of a "local" repository, distinct --- from @cabal-install@'s; these are secure repositories, but live in the local --- file system. We use the convention that these repositories are identified by --- URLs of the form @file:/path/to/local/repo@. -initSecureRepo :: Verbosity - -> Sec.HTTP.HttpLib - -> RemoteRepo -- ^ Secure repo ('remoteRepoSecure' assumed) - -> Sec.Path Sec.Absolute -- ^ Cache dir - -> (SecureRepo -> IO a) -- ^ Callback - -> IO a -initSecureRepo verbosity httpLib RemoteRepo{..} cachePath = \callback -> do - requiresBootstrap <- withRepo [] Sec.requiresBootstrap - - mirrors <- if requiresBootstrap - then do - info verbosity $ "Trying to locate mirrors via DNS for " ++ - "initial bootstrap of secure " ++ - "repository '" ++ show remoteRepoURI ++ - "' ..." - - Sec.DNS.queryBootstrapMirrors verbosity remoteRepoURI - else pure [] - - withRepo mirrors $ \r -> do - when requiresBootstrap $ Sec.uncheckClientErrors $ - Sec.bootstrap r - (map Sec.KeyId remoteRepoRootKeys) - (Sec.KeyThreshold (fromIntegral remoteRepoKeyThreshold)) - callback $ SecureRepo r - where - -- Initialize local or remote repo depending on the URI - withRepo :: [URI] -> (forall down. Sec.Repository down -> IO a) -> IO a - withRepo _ callback | uriScheme remoteRepoURI == "file:" = do - dir <- Sec.makeAbsolute $ Sec.fromFilePath (uriPath remoteRepoURI) - Sec.Local.withRepository dir - cache - Sec.hackageRepoLayout - Sec.hackageIndexLayout - logTUF - callback - withRepo mirrors callback = - Sec.Remote.withRepository httpLib - (remoteRepoURI:mirrors) - Sec.Remote.defaultRepoOpts - cache - Sec.hackageRepoLayout - Sec.hackageIndexLayout - logTUF - callback - - cache :: Sec.Cache - cache = Sec.Cache { - cacheRoot = cachePath - , cacheLayout = Sec.cabalCacheLayout { - Sec.cacheLayoutIndexTar = cacheFn "01-index.tar" - , Sec.cacheLayoutIndexIdx = cacheFn "01-index.tar.idx" - , Sec.cacheLayoutIndexTarGz = cacheFn "01-index.tar.gz" - } - } - - cacheFn :: FilePath -> Sec.CachePath - cacheFn = Sec.rootPath . Sec.fragment - - -- We display any TUF progress only in verbose mode, including any transient - -- verification errors. If verification fails, then the final exception that - -- is thrown will of course be shown. - logTUF :: Sec.LogMessage -> IO () - logTUF = info verbosity . Sec.pretty diff --git a/cabal/cabal-install/Distribution/Client/Haddock.hs b/cabal/cabal-install/Distribution/Client/Haddock.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Haddock.hs +++ /dev/null @@ -1,70 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Haddock --- Copyright : (c) Andrea Vezzosi 2009 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Interfacing with Haddock --- ------------------------------------------------------------------------------ -module Distribution.Client.Haddock - ( - regenerateHaddockIndex - ) - where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Data.List (maximumBy) -import System.Directory (createDirectoryIfMissing, renameFile) -import System.FilePath ((), splitFileName) -import Distribution.Package - ( packageVersion ) -import Distribution.Simple.Haddock (haddockPackagePaths) -import Distribution.Simple.Program (haddockProgram, ProgramDb - , runProgram, requireProgramVersion) -import Distribution.Version (mkVersion, orLaterVersion) -import Distribution.Simple.PackageIndex - ( InstalledPackageIndex, allPackagesByName ) -import Distribution.Simple.Utils - ( debug, installDirectoryContents, withTempDirectory ) -import Distribution.InstalledPackageInfo as InstalledPackageInfo - ( InstalledPackageInfo(exposed) ) - -regenerateHaddockIndex :: Verbosity - -> InstalledPackageIndex -> ProgramDb - -> FilePath - -> IO () -regenerateHaddockIndex verbosity pkgs progdb index = do - (paths, warns) <- haddockPackagePaths pkgs' Nothing - let paths' = [ (interface, html) | (interface, Just html, _) <- paths] - for_ warns (debug verbosity) - - (confHaddock, _, _) <- - requireProgramVersion verbosity haddockProgram - (orLaterVersion (mkVersion [0,6])) progdb - - createDirectoryIfMissing True destDir - - withTempDirectory verbosity destDir "tmphaddock" $ \tempDir -> do - - let flags = [ "--gen-contents" - , "--gen-index" - , "--odir=" ++ tempDir - , "--title=Haskell modules on this system" ] - ++ [ "--read-interface=" ++ html ++ "," ++ interface - | (interface, html) <- paths' ] - runProgram verbosity confHaddock flags - renameFile (tempDir "index.html") (tempDir destFile) - installDirectoryContents verbosity tempDir destDir - - where - (destDir,destFile) = splitFileName index - pkgs' = [ maximumBy (comparing packageVersion) pkgvers' - | (_pname, pkgvers) <- allPackagesByName pkgs - , let pkgvers' = filter exposed pkgvers - , not (null pkgvers') ] diff --git a/cabal/cabal-install/Distribution/Client/HashValue.hs b/cabal/cabal-install/Distribution/Client/HashValue.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/HashValue.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE CPP #-} -module Distribution.Client.HashValue ( - HashValue, - hashValue, - truncateHash, - showHashValue, - readFileHashValue, - hashFromTUF, - ) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import qualified Hackage.Security.Client as Sec - -import qualified Crypto.Hash.SHA256 as SHA256 -import qualified Data.ByteString.Base16 as Base16 -import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy.Char8 as LBS - -import System.IO (IOMode (..), withBinaryFile) - ------------------------------------------------ --- The specific choice of hash implementation --- - --- Is a crypto hash necessary here? One thing to consider is who controls the --- inputs and what's the result of a hash collision. Obviously we should not --- install packages we don't trust because they can run all sorts of code, but --- if I've checked there's no TH, no custom Setup etc, is there still a --- problem? If someone provided us a tarball that hashed to the same value as --- some other package and we installed it, we could end up re-using that --- installed package in place of another one we wanted. So yes, in general --- there is some value in preventing intentional hash collisions in installed --- package ids. - -newtype HashValue = HashValue BS.ByteString - deriving (Eq, Generic, Show, Typeable) - --- Cannot do any sensible validation here. Although we use SHA256 --- for stuff we hash ourselves, we can also get hashes from TUF --- and that can in principle use different hash functions in future. --- --- Therefore, we simply derive this structurally. -instance Binary HashValue -instance Structured HashValue - --- | Hash some data. Currently uses SHA256. --- -hashValue :: LBS.ByteString -> HashValue -hashValue = HashValue . SHA256.hashlazy - -showHashValue :: HashValue -> String -showHashValue (HashValue digest) = BS.unpack (Base16.encode digest) - --- | Hash the content of a file. Uses SHA256. --- -readFileHashValue :: FilePath -> IO HashValue -readFileHashValue tarball = - withBinaryFile tarball ReadMode $ \hnd -> - evaluate . hashValue =<< LBS.hGetContents hnd - --- | Convert a hash from TUF metadata into a 'PackageSourceHash'. --- --- Note that TUF hashes don't neessarily have to be SHA256, since it can --- support new algorithms in future. --- -hashFromTUF :: Sec.Hash -> HashValue -hashFromTUF (Sec.Hash hashstr) = - --TODO: [code cleanup] either we should get TUF to use raw bytestrings or - -- perhaps we should also just use a base16 string as the internal rep. - case Base16.decode (BS.pack hashstr) of -#if MIN_VERSION_base16_bytestring(1,0,0) - Right hash -> HashValue hash - Left _ -> error "hashFromTUF: cannot decode base16" -#else - (hash, trailing) | not (BS.null hash) && BS.null trailing - -> HashValue hash - _ -> error "hashFromTUF: cannot decode base16 hash" -#endif - --- | Truncate a 32 byte SHA256 hash to --- --- For example 20 bytes render as 40 hex chars, which we use for unit-ids. --- Or even 4 bytes for 'hashedInstalledPackageIdShort' --- -truncateHash :: Int -> HashValue -> HashValue -truncateHash n (HashValue h) = HashValue (BS.take n h) diff --git a/cabal/cabal-install/Distribution/Client/HttpUtils.hs b/cabal/cabal-install/Distribution/Client/HttpUtils.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/HttpUtils.hs +++ /dev/null @@ -1,915 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- | Separate module for HTTP actions, using a proxy server if one exists. ------------------------------------------------------------------------------ -module Distribution.Client.HttpUtils ( - DownloadResult(..), - configureTransport, - HttpTransport(..), - HttpCode, - downloadURI, - transportCheckHttps, - remoteRepoCheckHttps, - remoteRepoTryUpgradeToHttps, - isOldHackageURI - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude hiding (Proxy (..)) -import Distribution.Utils.Generic - -import Network.HTTP - ( Request (..), Response (..), RequestMethod (..) - , Header(..), HeaderName(..), lookupHeader ) -import Network.HTTP.Proxy ( Proxy(..), fetchProxy) -import Network.URI - ( URI (..), URIAuth (..), uriToString ) -import Network.Browser - ( browse, setOutHandler, setErrHandler, setProxy - , setAuthorityGen, request, setAllowBasicAuth, setUserAgent ) -import qualified Control.Exception as Exception -import Distribution.Simple.Utils - ( die', info, warn, debug, notice - , copyFileVerbose, withTempFile, IOData (..) ) -import Distribution.Client.Utils - ( withTempFileName, cabalInstallVersion ) -import Distribution.Client.Types - ( unRepoName, RemoteRepo(..) ) -import Distribution.System - ( buildOS, buildArch ) -import qualified System.FilePath.Posix as FilePath.Posix - ( splitDirectories ) -import System.FilePath - ( (<.>), takeFileName, takeDirectory ) -import System.Directory - ( doesFileExist, renameFile, canonicalizePath ) -import System.IO - ( withFile, IOMode(ReadMode), hGetContents, hClose ) -import System.IO.Error - ( isDoesNotExistError ) -import Distribution.Simple.Program - ( Program, simpleProgram, ConfiguredProgram, programPath - , ProgramInvocation(..), programInvocation - , ProgramSearchPathEntry(..) - , getProgramInvocationOutput ) -import Distribution.Simple.Program.Db - ( ProgramDb, emptyProgramDb, addKnownPrograms - , configureAllKnownPrograms - , requireProgram, lookupProgram - , modifyProgramSearchPath ) -import Distribution.Simple.Program.Run - ( getProgramInvocationOutputAndErrors ) -import Numeric (showHex) -import System.Random (randomRIO) - -import qualified Crypto.Hash.SHA256 as SHA256 -import qualified Data.ByteString.Base16 as Base16 -import qualified Distribution.Compat.CharParsing as P -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.ByteString.Lazy as LBS -import qualified Data.ByteString.Lazy.Char8 as LBS8 - ------------------------------------------------------------------------------- --- Downloading a URI, given an HttpTransport --- - -data DownloadResult = FileAlreadyInCache - | FileDownloaded FilePath - deriving (Eq) - -data DownloadCheck - = Downloaded -- ^ already downloaded and sha256 matches - | CheckETag String -- ^ already downloaded and we have etag - | NeedsDownload (Maybe BS.ByteString) -- ^ needs download with optional hash check - deriving Eq - -downloadURI :: HttpTransport - -> Verbosity - -> URI -- ^ What to download - -> FilePath -- ^ Where to put it - -> IO DownloadResult -downloadURI _transport verbosity uri path | uriScheme uri == "file:" = do - copyFileVerbose verbosity (uriPath uri) path - return (FileDownloaded path) - -- Can we store the hash of the file so we can safely return path when the - -- hash matches to avoid unnecessary computation? - -downloadURI transport verbosity uri path = do - - targetExists <- doesFileExist path - - downloadCheck <- - -- if we have uriFrag, then we expect there to be #sha256=... - if not (null uriFrag) - then case sha256parsed of - -- we know the hash, and target exists - Right expected | targetExists -> do - contents <- LBS.readFile path - let actual = SHA256.hashlazy contents - if expected == actual - then return Downloaded - else return (NeedsDownload (Just expected)) - - -- we known the hash, target doesn't exist - Right expected -> return (NeedsDownload (Just expected)) - - -- we failed to parse uriFragment - Left err -> die' verbosity $ - "Cannot parse URI fragment " ++ uriFrag ++ " " ++ err - - -- if there are no uri fragment, use ETag - else do - etagPathExists <- doesFileExist etagPath - -- In rare cases the target file doesn't exist, but the etag does. - if targetExists && etagPathExists - then return (CheckETag etagPath) - else return (NeedsDownload Nothing) - - -- Only use the external http transports if we actually have to - -- (or have been told to do so) - let transport' - | uriScheme uri == "http:" - , not (transportManuallySelected transport) - = plainHttpTransport - - | otherwise - = transport - - case downloadCheck of - Downloaded -> return FileAlreadyInCache - CheckETag etag -> makeDownload transport' Nothing (Just etag) - NeedsDownload hash -> makeDownload transport' hash Nothing - - where - makeDownload transport' sha256 etag = withTempFileName (takeDirectory path) (takeFileName path) $ \tmpFile -> do - result <- getHttp transport' verbosity uri etag tmpFile [] - - -- Only write the etag if we get a 200 response code. - -- A 304 still sends us an etag header. - case result of - -- if we have hash, we don't care about etag. - (200, _) | Just expected <- sha256 -> do - contents <- LBS.readFile tmpFile - let actual = SHA256.hashlazy contents - unless (actual == expected) $ - die' verbosity $ unwords - [ "Failed to download", show uri - , ": SHA256 don't match; expected:", BS8.unpack (Base16.encode expected) - , "actual:", BS8.unpack (Base16.encode actual) - ] - - (200, Just newEtag) -> writeFile etagPath newEtag - _ -> return () - - case fst result of - 200 -> do - info verbosity ("Downloaded to " ++ path) - renameFile tmpFile path - return (FileDownloaded path) - 304 -> do - notice verbosity "Skipping download: local and remote files match." - return FileAlreadyInCache - errCode -> die' verbosity $ "failed to download " ++ show uri - ++ " : HTTP code " ++ show errCode - - etagPath = path <.> "etag" - uriFrag = uriFragment uri - - sha256parsed :: Either String BS.ByteString - sha256parsed = explicitEitherParsec fragmentParser uriFrag - - fragmentParser = do - _ <- P.string "#sha256=" - str <- some P.hexDigit -#if MIN_VERSION_base16_bytestring(1,0,0) - return (Base16.decodeLenient (BS8.pack str)) -#else - return (fst (Base16.decode (BS8.pack str))) -#endif - ------------------------------------------------------------------------------- --- Utilities for repo url management --- - -remoteRepoCheckHttps :: Verbosity -> HttpTransport -> RemoteRepo -> IO () -remoteRepoCheckHttps verbosity transport repo - | uriScheme (remoteRepoURI repo) == "https:" - , not (transportSupportsHttps transport) - = die' verbosity $ "The remote repository '" ++ unRepoName (remoteRepoName repo) - ++ "' specifies a URL that " ++ requiresHttpsErrorMessage - | otherwise = return () - -transportCheckHttps :: Verbosity -> HttpTransport -> URI -> IO () -transportCheckHttps verbosity transport uri - | uriScheme uri == "https:" - , not (transportSupportsHttps transport) - = die' verbosity $ "The URL " ++ show uri - ++ " " ++ requiresHttpsErrorMessage - | otherwise = return () - -requiresHttpsErrorMessage :: String -requiresHttpsErrorMessage = - "requires HTTPS however the built-in HTTP implementation " - ++ "does not support HTTPS. The transport implementations with HTTPS " - ++ "support are " ++ intercalate ", " - [ name | (name, _, True, _ ) <- supportedTransports ] - ++ ". One of these will be selected automatically if the corresponding " - ++ "external program is available, or one can be selected specifically " - ++ "with the global flag --http-transport=" - -remoteRepoTryUpgradeToHttps :: Verbosity -> HttpTransport -> RemoteRepo -> IO RemoteRepo -remoteRepoTryUpgradeToHttps verbosity transport repo - | remoteRepoShouldTryHttps repo - , uriScheme (remoteRepoURI repo) == "http:" - , not (transportSupportsHttps transport) - , not (transportManuallySelected transport) - = die' verbosity $ "The builtin HTTP implementation does not support HTTPS, but using " - ++ "HTTPS for authenticated uploads is recommended. " - ++ "The transport implementations with HTTPS support are " - ++ intercalate ", " [ name | (name, _, True, _ ) <- supportedTransports ] - ++ "but they require the corresponding external program to be " - ++ "available. You can either make one available or use plain HTTP by " - ++ "using the global flag --http-transport=plain-http (or putting the " - ++ "equivalent in the config file). With plain HTTP, your password " - ++ "is sent using HTTP digest authentication so it cannot be easily " - ++ "intercepted, but it is not as secure as using HTTPS." - - | remoteRepoShouldTryHttps repo - , uriScheme (remoteRepoURI repo) == "http:" - , transportSupportsHttps transport - = return repo { - remoteRepoURI = (remoteRepoURI repo) { uriScheme = "https:" } - } - - | otherwise - = return repo - --- | Utility function for legacy support. -isOldHackageURI :: URI -> Bool -isOldHackageURI uri - = case uriAuthority uri of - Just (URIAuth {uriRegName = "hackage.haskell.org"}) -> - FilePath.Posix.splitDirectories (uriPath uri) - == ["/","packages","archive"] - _ -> False - - ------------------------------------------------------------------------------- --- Setting up a HttpTransport --- - -data HttpTransport = HttpTransport { - -- | GET a URI, with an optional ETag (to do a conditional fetch), - -- write the resource to the given file and return the HTTP status code, - -- and optional ETag. - getHttp :: Verbosity -> URI -> Maybe ETag -> FilePath -> [Header] - -> IO (HttpCode, Maybe ETag), - - -- | POST a resource to a URI, with optional auth (username, password) - -- and return the HTTP status code and any redirect URL. - postHttp :: Verbosity -> URI -> String -> Maybe Auth - -> IO (HttpCode, String), - - -- | POST a file resource to a URI using multipart\/form-data encoding, - -- with optional auth (username, password) and return the HTTP status - -- code and any error string. - postHttpFile :: Verbosity -> URI -> FilePath -> Maybe Auth - -> IO (HttpCode, String), - - -- | PUT a file resource to a URI, with optional auth - -- (username, password), extra headers and return the HTTP status code - -- and any error string. - putHttpFile :: Verbosity -> URI -> FilePath -> Maybe Auth -> [Header] - -> IO (HttpCode, String), - - -- | Whether this transport supports https or just http. - transportSupportsHttps :: Bool, - - -- | Whether this transport implementation was specifically chosen by - -- the user via configuration, or whether it was automatically selected. - -- Strictly speaking this is not a property of the transport itself but - -- about how it was chosen. Nevertheless it's convenient to keep here. - transportManuallySelected :: Bool - } - --TODO: why does postHttp return a redirect, but postHttpFile return errors? - -type HttpCode = Int -type ETag = String -type Auth = (String, String) - -noPostYet :: Verbosity -> URI -> String -> Maybe (String, String) - -> IO (Int, String) -noPostYet verbosity _ _ _ = die' verbosity "Posting (for report upload) is not implemented yet" - -supportedTransports :: [(String, Maybe Program, Bool, - ProgramDb -> Maybe HttpTransport)] -supportedTransports = - [ let prog = simpleProgram "curl" in - ( "curl", Just prog, True - , \db -> curlTransport <$> lookupProgram prog db ) - - , let prog = simpleProgram "wget" in - ( "wget", Just prog, True - , \db -> wgetTransport <$> lookupProgram prog db ) - - , let prog = simpleProgram "powershell" in - ( "powershell", Just prog, True - , \db -> powershellTransport <$> lookupProgram prog db ) - - , ( "plain-http", Nothing, False - , \_ -> Just plainHttpTransport ) - ] - -configureTransport :: Verbosity -> [FilePath] -> Maybe String -> IO HttpTransport - -configureTransport verbosity extraPath (Just name) = - -- the user specifically selected a transport by name so we'll try and - -- configure that one - - case find (\(name',_,_,_) -> name' == name) supportedTransports of - Just (_, mprog, _tls, mkTrans) -> do - - let baseProgDb = modifyProgramSearchPath (\p -> map ProgramSearchPathDir extraPath ++ p) emptyProgramDb - progdb <- case mprog of - Nothing -> return emptyProgramDb - Just prog -> snd <$> requireProgram verbosity prog baseProgDb - -- ^^ if it fails, it'll fail here - - let transport = fromMaybe (error "configureTransport: failed to make transport") $ mkTrans progdb - return transport { transportManuallySelected = True } - - Nothing -> die' verbosity $ "Unknown HTTP transport specified: " ++ name - ++ ". The supported transports are " - ++ intercalate ", " - [ name' | (name', _, _, _ ) <- supportedTransports ] - -configureTransport verbosity extraPath Nothing = do - -- the user hasn't selected a transport, so we'll pick the first one we - -- can configure successfully, provided that it supports tls - - -- for all the transports except plain-http we need to try and find - -- their external executable - let baseProgDb = modifyProgramSearchPath (\p -> map ProgramSearchPathDir extraPath ++ p) emptyProgramDb - progdb <- configureAllKnownPrograms verbosity $ - addKnownPrograms - [ prog | (_, Just prog, _, _) <- supportedTransports ] - baseProgDb - - let availableTransports = - [ (name, transport) - | (name, _, _, mkTrans) <- supportedTransports - , transport <- maybeToList (mkTrans progdb) ] - let (name, transport) = - fromMaybe ("plain-http", plainHttpTransport) (safeHead availableTransports) - debug verbosity $ "Selected http transport implementation: " ++ name - - return transport { transportManuallySelected = False } - - ------------------------------------------------------------------------------- --- The HttpTransports based on external programs --- - -curlTransport :: ConfiguredProgram -> HttpTransport -curlTransport prog = - HttpTransport gethttp posthttp posthttpfile puthttpfile True False - where - gethttp verbosity uri etag destPath reqHeaders = do - withTempFile (takeDirectory destPath) - "curl-headers.txt" $ \tmpFile tmpHandle -> do - hClose tmpHandle - let args = [ show uri - , "--output", destPath - , "--location" - , "--write-out", "%{http_code}" - , "--user-agent", userAgent - , "--silent", "--show-error" - , "--dump-header", tmpFile ] - ++ concat - [ ["--header", "If-None-Match: " ++ t] - | t <- maybeToList etag ] - ++ concat - [ ["--header", show name ++ ": " ++ value] - | Header name value <- reqHeaders ] - - resp <- getProgramInvocationOutput verbosity - (programInvocation prog args) - withFile tmpFile ReadMode $ \hnd -> do - headers <- hGetContents hnd - (code, _err, etag') <- parseResponse verbosity uri resp headers - evaluate $ force (code, etag') - - posthttp = noPostYet - - addAuthConfig auth progInvocation = progInvocation - { progInvokeInput = do - (uname, passwd) <- auth - return $ IODataText $ unlines - [ "--digest" - , "--user " ++ uname ++ ":" ++ passwd - ] - , progInvokeArgs = ["--config", "-"] ++ progInvokeArgs progInvocation - } - - posthttpfile verbosity uri path auth = do - let args = [ show uri - , "--form", "package=@"++path - , "--write-out", "\n%{http_code}" - , "--user-agent", userAgent - , "--silent", "--show-error" - , "--header", "Accept: text/plain" - , "--location" - ] - resp <- getProgramInvocationOutput verbosity $ addAuthConfig auth - (programInvocation prog args) - (code, err, _etag) <- parseResponse verbosity uri resp "" - return (code, err) - - puthttpfile verbosity uri path auth headers = do - let args = [ show uri - , "--request", "PUT", "--data-binary", "@"++path - , "--write-out", "\n%{http_code}" - , "--user-agent", userAgent - , "--silent", "--show-error" - , "--location" - , "--header", "Accept: text/plain" - ] - ++ concat - [ ["--header", show name ++ ": " ++ value] - | Header name value <- headers ] - resp <- getProgramInvocationOutput verbosity $ addAuthConfig auth - (programInvocation prog args) - (code, err, _etag) <- parseResponse verbosity uri resp "" - return (code, err) - - -- on success these curl invocations produces an output like "200" - -- and on failure it has the server error response first - parseResponse :: Verbosity -> URI -> String -> String -> IO (Int, String, Maybe ETag) - parseResponse verbosity uri resp headers = - let codeerr = - case reverse (lines resp) of - (codeLine:rerrLines) -> - case readMaybe (trim codeLine) of - Just i -> let errstr = mkErrstr rerrLines - in Just (i, errstr) - Nothing -> Nothing - [] -> Nothing - - mkErrstr = unlines . reverse . dropWhile (all isSpace) - - mb_etag :: Maybe ETag - mb_etag = listToMaybe $ reverse - [ etag - | ["ETag:", etag] <- map words (lines headers) ] - - in case codeerr of - Just (i, err) -> return (i, err, mb_etag) - _ -> statusParseFail verbosity uri resp - - -wgetTransport :: ConfiguredProgram -> HttpTransport -wgetTransport prog = - HttpTransport gethttp posthttp posthttpfile puthttpfile True False - where - gethttp verbosity uri etag destPath reqHeaders = do - resp <- runWGet verbosity uri args - - -- wget doesn't support range requests. - -- so, we not only ignore range request headers, - -- but we also dispay a warning message when we see them. - let hasRangeHeader = any isRangeHeader reqHeaders - warningMsg = "the 'wget' transport currently doesn't support" - ++ " range requests, which wastes network bandwidth." - ++ " To fix this, set 'http-transport' to 'curl' or" - ++ " 'plain-http' in '~/.cabal/config'." - ++ " Note that the 'plain-http' transport doesn't" - ++ " support HTTPS.\n" - - when (hasRangeHeader) $ warn verbosity warningMsg - (code, etag') <- parseOutput verbosity uri resp - return (code, etag') - where - args = [ "--output-document=" ++ destPath - , "--user-agent=" ++ userAgent - , "--tries=5" - , "--timeout=15" - , "--server-response" ] - ++ concat - [ ["--header", "If-None-Match: " ++ t] - | t <- maybeToList etag ] - ++ [ "--header=" ++ show name ++ ": " ++ value - | hdr@(Header name value) <- reqHeaders - , (not (isRangeHeader hdr)) ] - - -- wget doesn't support range requests. - -- so, we ignore range request headers, lest we get errors. - isRangeHeader :: Header -> Bool - isRangeHeader (Header HdrRange _) = True - isRangeHeader _ = False - - posthttp = noPostYet - - posthttpfile verbosity uri path auth = - withTempFile (takeDirectory path) - (takeFileName path) $ \tmpFile tmpHandle -> - withTempFile (takeDirectory path) "response" $ - \responseFile responseHandle -> do - hClose responseHandle - (body, boundary) <- generateMultipartBody path - LBS.hPut tmpHandle body - hClose tmpHandle - let args = [ "--post-file=" ++ tmpFile - , "--user-agent=" ++ userAgent - , "--server-response" - , "--output-document=" ++ responseFile - , "--header=Accept: text/plain" - , "--header=Content-type: multipart/form-data; " ++ - "boundary=" ++ boundary ] - out <- runWGet verbosity (addUriAuth auth uri) args - (code, _etag) <- parseOutput verbosity uri out - withFile responseFile ReadMode $ \hnd -> do - resp <- hGetContents hnd - evaluate $ force (code, resp) - - puthttpfile verbosity uri path auth headers = - withTempFile (takeDirectory path) "response" $ - \responseFile responseHandle -> do - hClose responseHandle - let args = [ "--method=PUT", "--body-file="++path - , "--user-agent=" ++ userAgent - , "--server-response" - , "--output-document=" ++ responseFile - , "--header=Accept: text/plain" ] - ++ [ "--header=" ++ show name ++ ": " ++ value - | Header name value <- headers ] - - out <- runWGet verbosity (addUriAuth auth uri) args - (code, _etag) <- parseOutput verbosity uri out - withFile responseFile ReadMode $ \hnd -> do - resp <- hGetContents hnd - evaluate $ force (code, resp) - - addUriAuth Nothing uri = uri - addUriAuth (Just (user, pass)) uri = uri - { uriAuthority = Just a { uriUserInfo = user ++ ":" ++ pass ++ "@" } - } - where - a = fromMaybe (URIAuth "" "" "") (uriAuthority uri) - - runWGet verbosity uri args = do - -- We pass the URI via STDIN because it contains the users' credentials - -- and sensitive data should not be passed via command line arguments. - let - invocation = (programInvocation prog ("--input-file=-" : args)) - { progInvokeInput = Just $ IODataText $ uriToString id uri "" - } - - -- wget returns its output on stderr rather than stdout - (_, resp, exitCode) <- getProgramInvocationOutputAndErrors verbosity - invocation - -- wget returns exit code 8 for server "errors" like "304 not modified" - if exitCode == ExitSuccess || exitCode == ExitFailure 8 - then return resp - else die' verbosity $ "'" ++ programPath prog - ++ "' exited with an error:\n" ++ resp - - -- With the --server-response flag, wget produces output with the full - -- http server response with all headers, we want to find a line like - -- "HTTP/1.1 200 OK", but only the last one, since we can have multiple - -- requests due to redirects. - parseOutput verbosity uri resp = - let parsedCode = listToMaybe - [ code - | (protocol:codestr:_err) <- map words (reverse (lines resp)) - , "HTTP/" `isPrefixOf` protocol - , code <- maybeToList (readMaybe codestr) ] - mb_etag :: Maybe ETag - mb_etag = listToMaybe - [ etag - | ["ETag:", etag] <- map words (reverse (lines resp)) ] - in case parsedCode of - Just i -> return (i, mb_etag) - _ -> statusParseFail verbosity uri resp - - -powershellTransport :: ConfiguredProgram -> HttpTransport -powershellTransport prog = - HttpTransport gethttp posthttp posthttpfile puthttpfile True False - where - gethttp verbosity uri etag destPath reqHeaders = do - resp <- runPowershellScript verbosity $ - webclientScript - (escape (show uri)) - (("$targetStream = New-Object -TypeName System.IO.FileStream -ArgumentList " ++ (escape destPath) ++ ", Create") - :(setupHeaders ((useragentHeader : etagHeader) ++ reqHeaders))) - [ "$response = $request.GetResponse()" - , "$responseStream = $response.GetResponseStream()" - , "$buffer = new-object byte[] 10KB" - , "$count = $responseStream.Read($buffer, 0, $buffer.length)" - , "while ($count -gt 0)" - , "{" - , " $targetStream.Write($buffer, 0, $count)" - , " $count = $responseStream.Read($buffer, 0, $buffer.length)" - , "}" - , "Write-Host ($response.StatusCode -as [int]);" - , "Write-Host $response.GetResponseHeader(\"ETag\").Trim('\"')" - ] - [ "$targetStream.Flush()" - , "$targetStream.Close()" - , "$targetStream.Dispose()" - , "$responseStream.Dispose()" - ] - parseResponse resp - where - parseResponse :: String -> IO (HttpCode, Maybe ETag) - parseResponse x = - case lines $ trim x of - (code:etagv:_) -> fmap (\c -> (c, Just etagv)) $ parseCode code x - (code: _) -> fmap (\c -> (c, Nothing )) $ parseCode code x - _ -> statusParseFail verbosity uri x - parseCode :: String -> String -> IO HttpCode - parseCode code x = case readMaybe code of - Just i -> return i - Nothing -> statusParseFail verbosity uri x - etagHeader = [ Header HdrIfNoneMatch t | t <- maybeToList etag ] - - posthttp = noPostYet - - posthttpfile verbosity uri path auth = - withTempFile (takeDirectory path) - (takeFileName path) $ \tmpFile tmpHandle -> do - (body, boundary) <- generateMultipartBody path - LBS.hPut tmpHandle body - hClose tmpHandle - fullPath <- canonicalizePath tmpFile - - let contentHeader = Header HdrContentType - ("multipart/form-data; boundary=" ++ boundary) - resp <- runPowershellScript verbosity $ webclientScript - (escape (show uri)) - (setupHeaders (contentHeader : extraHeaders) ++ setupAuth auth) - (uploadFileAction "POST" uri fullPath) - uploadFileCleanup - parseUploadResponse verbosity uri resp - - puthttpfile verbosity uri path auth headers = do - fullPath <- canonicalizePath path - resp <- runPowershellScript verbosity $ webclientScript - (escape (show uri)) - (setupHeaders (extraHeaders ++ headers) ++ setupAuth auth) - (uploadFileAction "PUT" uri fullPath) - uploadFileCleanup - parseUploadResponse verbosity uri resp - - runPowershellScript verbosity script = do - let args = - [ "-InputFormat", "None" - -- the default execution policy doesn't allow running - -- unsigned scripts, so we need to tell powershell to bypass it - , "-ExecutionPolicy", "bypass" - , "-NoProfile", "-NonInteractive" - , "-Command", "-" - ] - debug verbosity script - getProgramInvocationOutput verbosity (programInvocation prog args) - { progInvokeInput = Just $ IODataText $ script ++ "\nExit(0);" - } - - escape = show - - useragentHeader = Header HdrUserAgent userAgent - extraHeaders = [Header HdrAccept "text/plain", useragentHeader] - - setupHeaders headers = - [ "$request." ++ addHeader name value - | Header name value <- headers - ] - where - addHeader header value - = case header of - HdrAccept -> "Accept = " ++ escape value - HdrUserAgent -> "UserAgent = " ++ escape value - HdrConnection -> "Connection = " ++ escape value - HdrContentLength -> "ContentLength = " ++ escape value - HdrContentType -> "ContentType = " ++ escape value - HdrDate -> "Date = " ++ escape value - HdrExpect -> "Expect = " ++ escape value - HdrHost -> "Host = " ++ escape value - HdrIfModifiedSince -> "IfModifiedSince = " ++ escape value - HdrReferer -> "Referer = " ++ escape value - HdrTransferEncoding -> "TransferEncoding = " ++ escape value - HdrRange -> let (start, end) = - if "bytes=" `isPrefixOf` value - then case break (== '-') value' of - (start', '-':end') -> (start', end') - _ -> error $ "Could not decode range: " ++ value - else error $ "Could not decode range: " ++ value - value' = drop 6 value - in "AddRange(\"bytes\", " ++ escape start ++ ", " ++ escape end ++ ");" - name -> "Headers.Add(" ++ escape (show name) ++ "," ++ escape value ++ ");" - - setupAuth auth = - [ "$request.Credentials = new-object System.Net.NetworkCredential(" - ++ escape uname ++ "," ++ escape passwd ++ ",\"\");" - | (uname,passwd) <- maybeToList auth - ] - - uploadFileAction method _uri fullPath = - [ "$request.Method = " ++ show method - , "$requestStream = $request.GetRequestStream()" - , "$fileStream = [System.IO.File]::OpenRead(" ++ escape fullPath ++ ")" - , "$bufSize=10000" - , "$chunk = New-Object byte[] $bufSize" - , "while( $bytesRead = $fileStream.Read($chunk,0,$bufsize) )" - , "{" - , " $requestStream.write($chunk, 0, $bytesRead)" - , " $requestStream.Flush()" - , "}" - , "" - , "$responseStream = $request.getresponse()" - , "$responseReader = new-object System.IO.StreamReader $responseStream.GetResponseStream()" - , "$code = $response.StatusCode -as [int]" - , "if ($code -eq 0) {" - , " $code = 200;" - , "}" - , "Write-Host $code" - , "Write-Host $responseReader.ReadToEnd()" - ] - - uploadFileCleanup = - [ "$fileStream.Close()" - , "$requestStream.Close()" - , "$responseStream.Close()" - ] - - parseUploadResponse verbosity uri resp = case lines (trim resp) of - (codeStr : message) - | Just code <- readMaybe codeStr -> return (code, unlines message) - _ -> statusParseFail verbosity uri resp - - webclientScript uri setup action cleanup = unlines - [ "[Net.ServicePointManager]::SecurityProtocol = \"tls12, tls11, tls\"" - , "$uri = New-Object \"System.Uri\" " ++ uri - , "$request = [System.Net.HttpWebRequest]::Create($uri)" - , unlines setup - , "Try {" - , unlines (map (" " ++) action) - , "} Catch [System.Net.WebException] {" - , " $exception = $_.Exception;" - , " If ($exception.Status -eq " - ++ "[System.Net.WebExceptionStatus]::ProtocolError) {" - , " $response = $exception.Response -as [System.Net.HttpWebResponse];" - , " $reader = new-object " - ++ "System.IO.StreamReader($response.GetResponseStream());" - , " Write-Host ($response.StatusCode -as [int]);" - , " Write-Host $reader.ReadToEnd();" - , " } Else {" - , " Write-Host $exception.Message;" - , " }" - , "} Catch {" - , " Write-Host $_.Exception.Message;" - , "} finally {" - , unlines (map (" " ++) cleanup) - , "}" - ] - - ------------------------------------------------------------------------------- --- The builtin plain HttpTransport --- - -plainHttpTransport :: HttpTransport -plainHttpTransport = - HttpTransport gethttp posthttp posthttpfile puthttpfile False False - where - gethttp verbosity uri etag destPath reqHeaders = do - let req = Request{ - rqURI = uri, - rqMethod = GET, - rqHeaders = [ Header HdrIfNoneMatch t - | t <- maybeToList etag ] - ++ reqHeaders, - rqBody = LBS.empty - } - (_, resp) <- cabalBrowse verbosity Nothing (request req) - let code = convertRspCode (rspCode resp) - etag' = lookupHeader HdrETag (rspHeaders resp) - -- 206 Partial Content is a normal response to a range request; see #3385. - when (code==200 || code==206) $ - writeFileAtomic destPath $ rspBody resp - return (code, etag') - - posthttp = noPostYet - - posthttpfile verbosity uri path auth = do - (body, boundary) <- generateMultipartBody path - let headers = [ Header HdrContentType - ("multipart/form-data; boundary="++boundary) - , Header HdrContentLength (show (LBS8.length body)) - , Header HdrAccept ("text/plain") - ] - req = Request { - rqURI = uri, - rqMethod = POST, - rqHeaders = headers, - rqBody = body - } - (_, resp) <- cabalBrowse verbosity auth (request req) - return (convertRspCode (rspCode resp), rspErrorString resp) - - puthttpfile verbosity uri path auth headers = do - body <- LBS8.readFile path - let req = Request { - rqURI = uri, - rqMethod = PUT, - rqHeaders = Header HdrContentLength (show (LBS8.length body)) - : Header HdrAccept "text/plain" - : headers, - rqBody = body - } - (_, resp) <- cabalBrowse verbosity auth (request req) - return (convertRspCode (rspCode resp), rspErrorString resp) - - convertRspCode (a,b,c) = a*100 + b*10 + c - - rspErrorString resp = - case lookupHeader HdrContentType (rspHeaders resp) of - Just contenttype - | takeWhile (/= ';') contenttype == "text/plain" - -> LBS8.unpack (rspBody resp) - _ -> rspReason resp - - cabalBrowse verbosity auth act = do - p <- fixupEmptyProxy <$> fetchProxy True - Exception.handleJust - (guard . isDoesNotExistError) - (const . die' verbosity $ "Couldn't establish HTTP connection. " - ++ "Possible cause: HTTP proxy server is down.") $ - browse $ do - setProxy p - setErrHandler (warn verbosity . ("http error: "++)) - setOutHandler (debug verbosity) - setUserAgent userAgent - setAllowBasicAuth False - setAuthorityGen (\_ _ -> return auth) - act - - fixupEmptyProxy (Proxy uri _) | null uri = NoProxy - fixupEmptyProxy p = p - - ------------------------------------------------------------------------------- --- Common stuff used by multiple transport impls --- - -userAgent :: String -userAgent = concat [ "cabal-install/", prettyShow cabalInstallVersion - , " (", prettyShow buildOS, "; ", prettyShow buildArch, ")" - ] - -statusParseFail :: Verbosity -> URI -> String -> IO a -statusParseFail verbosity uri r = - die' verbosity $ "Failed to download " ++ show uri ++ " : " - ++ "No Status Code could be parsed from response: " ++ r - --- Trim -trim :: String -> String -trim = f . f - where f = reverse . dropWhile isSpace - - ------------------------------------------------------------------------------- --- Multipart stuff partially taken from cgi package. --- - -generateMultipartBody :: FilePath -> IO (LBS.ByteString, String) -generateMultipartBody path = do - content <- LBS.readFile path - boundary <- genBoundary - let !body = formatBody content (LBS8.pack boundary) - return (body, boundary) - where - formatBody content boundary = - LBS8.concat $ - [ crlf, dd, boundary, crlf ] - ++ [ LBS8.pack (show header) | header <- headers ] - ++ [ crlf - , content - , crlf, dd, boundary, dd, crlf ] - - headers = - [ Header (HdrCustom "Content-disposition") - ("form-data; name=package; " ++ - "filename=\"" ++ takeFileName path ++ "\"") - , Header HdrContentType "application/x-gzip" - ] - - crlf = LBS8.pack "\r\n" - dd = LBS8.pack "--" - -genBoundary :: IO String -genBoundary = do - i <- randomRIO (0x10000000000000,0xFFFFFFFFFFFFFF) :: IO Integer - return $ showHex i "" diff --git a/cabal/cabal-install/Distribution/Client/IndexUtils.hs b/cabal/cabal-install/Distribution/Client/IndexUtils.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/IndexUtils.hs +++ /dev/null @@ -1,1184 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE GADTs #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.IndexUtils --- Copyright : (c) Duncan Coutts 2008 --- License : BSD-like --- --- Maintainer : duncan@community.haskell.org --- Stability : provisional --- Portability : portable --- --- Extra utils related to the package indexes. ------------------------------------------------------------------------------ -module Distribution.Client.IndexUtils ( - getIndexFileAge, - getInstalledPackages, - indexBaseName, - Configure.getInstalledPackagesMonitorFiles, - getSourcePackages, - getSourcePackagesMonitorFiles, - - TotalIndexState, - getSourcePackagesAtIndexState, - ActiveRepos, - - Index(..), - RepoIndexState (..), - PackageEntry(..), - parsePackageIndex, - updateRepoIndexCache, - updatePackageIndexCacheFile, - writeIndexTimestamp, - currentIndexTimestamp, - - BuildTreeRefType(..), refTypeFromTypeCode, typeCodeFromRefType - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude - -import qualified Codec.Archive.Tar as Tar -import qualified Codec.Archive.Tar.Entry as Tar -import qualified Codec.Archive.Tar.Index as Tar -import qualified Distribution.Client.Tar as Tar -import Distribution.Client.IndexUtils.ActiveRepos -import Distribution.Client.IndexUtils.IndexState -import Distribution.Client.IndexUtils.Timestamp -import Distribution.Client.Types -import Distribution.Verbosity -import Distribution.Parsec (simpleParsecBS) - -import Distribution.Package - ( PackageId, PackageIdentifier(..), mkPackageName - , Package(..), packageVersion, packageName ) -import Distribution.Types.Dependency -import Distribution.Simple.PackageIndex (InstalledPackageIndex) -import Distribution.PackageDescription - ( GenericPackageDescription(..) - , PackageDescription(..), emptyPackageDescription ) -import Distribution.Simple.Compiler - ( Compiler, PackageDBStack ) -import Distribution.Simple.Program - ( ProgramDb ) -import qualified Distribution.Simple.Configure as Configure - ( getInstalledPackages, getInstalledPackagesMonitorFiles ) -import Distribution.Types.PackageName (PackageName) -import Distribution.Version - ( Version, VersionRange, mkVersion, intersectVersionRanges ) -import Distribution.Simple.Utils - ( die', warn, info, createDirectoryIfMissingVerbose ) -import Distribution.Client.Setup - ( RepoContext(..) ) - -import Distribution.PackageDescription.Parsec - ( parseGenericPackageDescription, parseGenericPackageDescriptionMaybe ) -import qualified Distribution.PackageDescription.Parsec as PackageDesc.Parse - -import Distribution.Solver.Types.PackageIndex (PackageIndex) -import qualified Distribution.Solver.Types.PackageIndex as PackageIndex -import Distribution.Solver.Types.SourcePackage - -import qualified Data.Map as Map -import qualified Data.Set as Set -import Control.Exception -import Data.List (stripPrefix) -import qualified Data.ByteString.Lazy as BS -import qualified Data.ByteString.Lazy.Char8 as BS.Char8 -import qualified Data.ByteString.Char8 as BSS -import Data.ByteString.Lazy (ByteString) -import Distribution.Client.GZipUtils (maybeDecompress) -import Distribution.Client.Utils ( byteStringToFilePath - , tryFindAddSourcePackageDesc ) -import Distribution.Utils.Structured (Structured (..), nominalStructure, structuredEncodeFile, structuredDecodeFileOrFail) -import Distribution.Compat.Time (getFileAge, getModTime) -import System.Directory (doesFileExist, doesDirectoryExist) -import System.FilePath - ( (), (<.>), takeFileName, takeExtension, replaceExtension, splitDirectories, normalise, takeDirectory ) -import qualified System.FilePath.Posix as FilePath.Posix -import System.IO -import System.IO.Unsafe (unsafeInterleaveIO) -import System.IO.Error (isDoesNotExistError) -import Distribution.Compat.Directory (listDirectory) -import Distribution.Utils.Generic (fstOf3) - -import qualified Codec.Compression.GZip as GZip - -import qualified Hackage.Security.Client as Sec -import qualified Hackage.Security.Util.Some as Sec - --- | Reduced-verbosity version of 'Configure.getInstalledPackages' -getInstalledPackages :: Verbosity -> Compiler - -> PackageDBStack -> ProgramDb - -> IO InstalledPackageIndex -getInstalledPackages verbosity comp packageDbs progdb = - Configure.getInstalledPackages verbosity' comp packageDbs progdb - where - verbosity' = lessVerbose verbosity - - --- | Get filename base (i.e. without file extension) for index-related files --- --- /Secure/ cabal repositories use a new extended & incremental --- @01-index.tar@. In order to avoid issues resulting from clobbering --- new/old-style index data, we save them locally to different names. --- --- Example: Use @indexBaseName repo <.> "tar.gz"@ to compute the 'FilePath' of the --- @00-index.tar.gz@/@01-index.tar.gz@ file. -indexBaseName :: Repo -> FilePath -indexBaseName repo = repoLocalDir repo fn - where - fn = case repo of - RepoSecure {} -> "01-index" - RepoRemote {} -> "00-index" - RepoLocalNoIndex {} -> "noindex" - ------------------------------------------------------------------------- --- Reading the source package index --- - --- Note: 'data IndexState' is defined in --- "Distribution.Client.IndexUtils.Timestamp" to avoid import cycles - --- | 'IndexStateInfo' contains meta-information about the resulting --- filtered 'Cache' 'after applying 'filterCache' according to a --- requested 'IndexState'. -data IndexStateInfo = IndexStateInfo - { isiMaxTime :: !Timestamp - -- ^ 'Timestamp' of maximum/latest 'Timestamp' in the current - -- filtered view of the cache. - -- - -- The following property holds - -- - -- > filterCache (IndexState (isiMaxTime isi)) cache == (cache, isi) - -- - - , isiHeadTime :: !Timestamp - -- ^ 'Timestamp' equivalent to 'IndexStateHead', i.e. the latest - -- known 'Timestamp'; 'isiHeadTime' is always greater or equal to - -- 'isiMaxTime'. - } - -emptyStateInfo :: IndexStateInfo -emptyStateInfo = IndexStateInfo nullTimestamp nullTimestamp - --- | Filters a 'Cache' according to an 'IndexState' --- specification. Also returns 'IndexStateInfo' describing the --- resulting index cache. --- --- Note: 'filterCache' is idempotent in the 'Cache' value -filterCache :: RepoIndexState -> Cache -> (Cache, IndexStateInfo) -filterCache IndexStateHead cache = (cache, IndexStateInfo{..}) - where - isiMaxTime = cacheHeadTs cache - isiHeadTime = cacheHeadTs cache -filterCache (IndexStateTime ts0) cache0 = (cache, IndexStateInfo{..}) - where - cache = Cache { cacheEntries = ents, cacheHeadTs = isiMaxTime } - isiHeadTime = cacheHeadTs cache0 - isiMaxTime = maximumTimestamp (map cacheEntryTimestamp ents) - ents = filter ((<= ts0) . cacheEntryTimestamp) (cacheEntries cache0) - --- | Read a repository index from disk, from the local files specified by --- a list of 'Repo's. --- --- All the 'SourcePackage's are marked as having come from the appropriate --- 'Repo'. --- --- This is a higher level wrapper used internally in cabal-install. -getSourcePackages :: Verbosity -> RepoContext -> IO SourcePackageDb -getSourcePackages verbosity repoCtxt = - fstOf3 <$> getSourcePackagesAtIndexState verbosity repoCtxt Nothing Nothing - --- | Variant of 'getSourcePackages' which allows getting the source --- packages at a particular 'IndexState'. --- --- Current choices are either the latest (aka HEAD), or the index as --- it was at a particular time. --- --- Returns also the total index where repositories' --- RepoIndexState's are not HEAD. This is used in v2-freeze. --- -getSourcePackagesAtIndexState - :: Verbosity - -> RepoContext - -> Maybe TotalIndexState - -> Maybe ActiveRepos - -> IO (SourcePackageDb, TotalIndexState, ActiveRepos) -getSourcePackagesAtIndexState verbosity repoCtxt _ _ - | null (repoContextRepos repoCtxt) = do - -- In the test suite, we routinely don't have any remote package - -- servers, so don't bleat about it - warn (verboseUnmarkOutput verbosity) $ - "No remote package servers have been specified. Usually " ++ - "you would have one specified in the config file." - return (SourcePackageDb { - packageIndex = mempty, - packagePreferences = mempty - }, headTotalIndexState, ActiveRepos []) -getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState mb_activeRepos = do - let describeState IndexStateHead = "most recent state" - describeState (IndexStateTime time) = "historical state as of " ++ prettyShow time - - pkgss <- for (repoContextRepos repoCtxt) $ \r -> do - let rname :: RepoName - rname = case r of - RepoRemote remote _ -> remoteRepoName remote - RepoSecure remote _ -> remoteRepoName remote - RepoLocalNoIndex local _ -> localRepoName local - - info verbosity ("Reading available packages of " ++ unRepoName rname ++ "...") - - idxState <- case mb_idxState of - Just totalIdxState -> do - let idxState = lookupIndexState rname totalIdxState - info verbosity $ "Using " ++ describeState idxState ++ - " as explicitly requested (via command line / project configuration)" - return idxState - Nothing -> do - mb_idxState' <- readIndexTimestamp (RepoIndex repoCtxt r) - case mb_idxState' of - Nothing -> do - info verbosity "Using most recent state (could not read timestamp file)" - return IndexStateHead - Just idxState -> do - info verbosity $ "Using " ++ describeState idxState ++ - " specified from most recent cabal update" - return idxState - - unless (idxState == IndexStateHead) $ - case r of - RepoLocalNoIndex {} -> warn verbosity "index-state ignored for file+noindex repositories" - RepoRemote {} -> warn verbosity ("index-state ignored for old-format (remote repository '" ++ unRepoName rname ++ "')") - RepoSecure {} -> pure () - - let idxState' = case r of - RepoSecure {} -> idxState - _ -> IndexStateHead - - (pis,deps,isi) <- readRepoIndex verbosity repoCtxt r idxState' - - case idxState' of - IndexStateHead -> do - info verbosity ("index-state("++ unRepoName rname ++") = " ++ prettyShow (isiHeadTime isi)) - return () - IndexStateTime ts0 -> do - when (isiMaxTime isi /= ts0) $ - if ts0 > isiMaxTime isi - then warn verbosity $ - "Requested index-state " ++ prettyShow ts0 - ++ " is newer than '" ++ unRepoName rname ++ "'!" - ++ " Falling back to older state (" - ++ prettyShow (isiMaxTime isi) ++ ")." - else info verbosity $ - "Requested index-state " ++ prettyShow ts0 - ++ " does not exist in '"++ unRepoName rname ++"'!" - ++ " Falling back to older state (" - ++ prettyShow (isiMaxTime isi) ++ ")." - info verbosity ("index-state("++ unRepoName rname ++") = " ++ - prettyShow (isiMaxTime isi) ++ " (HEAD = " ++ - prettyShow (isiHeadTime isi) ++ ")") - - pure RepoData - { rdRepoName = rname - , rdTimeStamp = isiMaxTime isi - , rdIndex = pis - , rdPreferences = deps - } - - let activeRepos :: ActiveRepos - activeRepos = fromMaybe defaultActiveRepos mb_activeRepos - - pkgss' <- case organizeByRepos activeRepos rdRepoName pkgss of - Right x -> return x - Left err -> warn verbosity err >> return (map (\x -> (x, CombineStrategyMerge)) pkgss) - - let activeRepos' :: ActiveRepos - activeRepos' = ActiveRepos - [ ActiveRepo (rdRepoName rd) strategy - | (rd, strategy) <- pkgss' - ] - - let totalIndexState :: TotalIndexState - totalIndexState = makeTotalIndexState IndexStateHead $ Map.fromList - [ (n, IndexStateTime ts) - | (RepoData n ts _idx _prefs, _strategy) <- pkgss' - ] - - let addIndex - :: PackageIndex UnresolvedSourcePackage - -> (RepoData, CombineStrategy) - -> PackageIndex UnresolvedSourcePackage - 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' - - -- Note: preferences combined without using CombineStrategy - let prefs :: Map PackageName VersionRange - prefs = Map.fromListWith intersectVersionRanges - [ (name, range) - | (RepoData _n _ts _idx prefs', _strategy) <- pkgss' - , Dependency name range _ <- prefs' - ] - - _ <- evaluate pkgs - _ <- evaluate prefs - _ <- evaluate totalIndexState - return (SourcePackageDb { - packageIndex = pkgs, - packagePreferences = prefs - }, totalIndexState, activeRepos') - --- auxiliary data used in getSourcePackagesAtIndexState -data RepoData = RepoData - { rdRepoName :: RepoName - , rdTimeStamp :: Timestamp - , rdIndex :: PackageIndex UnresolvedSourcePackage - , rdPreferences :: [Dependency] - } - --- | Read a repository index from disk, from the local file specified by --- the 'Repo'. --- --- All the 'SourcePackage's are marked as having come from the given 'Repo'. --- --- This is a higher level wrapper used internally in cabal-install. --- -readRepoIndex :: Verbosity -> RepoContext -> Repo -> RepoIndexState - -> IO (PackageIndex UnresolvedSourcePackage, [Dependency], IndexStateInfo) -readRepoIndex verbosity repoCtxt repo idxState = - handleNotFound $ do - when (isRepoRemote repo) $ warnIfIndexIsOld =<< getIndexFileAge repo - updateRepoIndexCache verbosity (RepoIndex repoCtxt repo) - readPackageIndexCacheFile verbosity mkAvailablePackage - (RepoIndex repoCtxt repo) - idxState - - where - mkAvailablePackage pkgEntry = SourcePackage - { srcpkgPackageId = pkgid - , srcpkgDescription = pkgdesc - , srcpkgSource = case pkgEntry of - NormalPackage _ _ _ _ -> RepoTarballPackage repo pkgid Nothing - BuildTreeRef _ _ _ path _ -> LocalUnpackedPackage path - , srcpkgDescrOverride = case pkgEntry of - NormalPackage _ _ pkgtxt _ -> Just pkgtxt - _ -> Nothing - } - where - pkgdesc = packageDesc pkgEntry - pkgid = packageId pkgEntry - - handleNotFound action = catchIO action $ \e -> if isDoesNotExistError e - then do - case repo of - RepoRemote{..} -> warn verbosity $ errMissingPackageList repoRemote - RepoSecure{..} -> warn verbosity $ errMissingPackageList repoRemote - RepoLocalNoIndex local _ -> warn verbosity $ - "Error during construction of local+noindex " - ++ unRepoName (localRepoName local) ++ " repository index: " - ++ show e - return (mempty,mempty,emptyStateInfo) - else ioError e - - isOldThreshold = 15 --days - warnIfIndexIsOld dt = do - when (dt >= isOldThreshold) $ case repo of - RepoRemote{..} -> warn verbosity $ errOutdatedPackageList repoRemote dt - RepoSecure{..} -> warn verbosity $ errOutdatedPackageList repoRemote dt - RepoLocalNoIndex {} -> return () - - errMissingPackageList repoRemote = - "The package list for '" ++ (unRepoName (remoteRepoName repoRemote)) - ++ "' does not exist. Run 'hackport update' to download it." - errOutdatedPackageList repoRemote dt = - "The package list for '" ++ unRepoName (remoteRepoName repoRemote) - ++ "' is " ++ shows (floor dt :: Int) " days old.\nRun " - ++ "'cabal update' to get the latest list of available packages." - --- | Return the age of the index file in days (as a Double). -getIndexFileAge :: Repo -> IO Double -getIndexFileAge repo = getFileAge $ indexBaseName repo <.> "tar" - --- | A set of files (or directories) that can be monitored to detect when --- there might have been a change in the source packages. --- -getSourcePackagesMonitorFiles :: [Repo] -> [FilePath] -getSourcePackagesMonitorFiles repos = - concat [ [ indexBaseName repo <.> "cache" - , indexBaseName repo <.> "timestamp" ] - | repo <- repos ] - --- | It is not necessary to call this, as the cache will be updated when the --- index is read normally. However you can do the work earlier if you like. --- -updateRepoIndexCache :: Verbosity -> Index -> IO () -updateRepoIndexCache verbosity index = - whenCacheOutOfDate index $ updatePackageIndexCacheFile verbosity index - -whenCacheOutOfDate :: Index -> IO () -> IO () -whenCacheOutOfDate index action = do - exists <- doesFileExist $ cacheFile index - if not exists - then action - else if localNoIndex index - then return () -- TODO: don't update cache for local+noindex repositories - else do - indexTime <- getModTime $ indexFile index - cacheTime <- getModTime $ cacheFile index - when (indexTime > cacheTime) action - -localNoIndex :: Index -> Bool -localNoIndex (RepoIndex _ (RepoLocalNoIndex {})) = True -localNoIndex _ = False - ------------------------------------------------------------------------- --- Reading the index file --- - --- | An index entry is either a normal package, or a local build tree reference. -data PackageEntry - = NormalPackage PackageId GenericPackageDescription ByteString BlockNo - | BuildTreeRef BuildTreeRefType - PackageId GenericPackageDescription FilePath BlockNo - --- | A build tree reference is either a link or a snapshot. -data BuildTreeRefType = SnapshotRef | LinkRef - deriving (Eq,Show,Generic) - -instance Binary BuildTreeRefType -instance Structured BuildTreeRefType - -refTypeFromTypeCode :: Tar.TypeCode -> BuildTreeRefType -refTypeFromTypeCode t - | t == Tar.buildTreeRefTypeCode = LinkRef - | t == Tar.buildTreeSnapshotTypeCode = SnapshotRef - | otherwise = - error "Distribution.Client.IndexUtils.refTypeFromTypeCode: unknown type code" - -typeCodeFromRefType :: BuildTreeRefType -> Tar.TypeCode -typeCodeFromRefType LinkRef = Tar.buildTreeRefTypeCode -typeCodeFromRefType SnapshotRef = Tar.buildTreeSnapshotTypeCode - -instance Package PackageEntry where - packageId (NormalPackage pkgid _ _ _) = pkgid - packageId (BuildTreeRef _ pkgid _ _ _) = pkgid - -packageDesc :: PackageEntry -> GenericPackageDescription -packageDesc (NormalPackage _ descr _ _) = descr -packageDesc (BuildTreeRef _ _ descr _ _) = descr - --- | Parse an uncompressed \"00-index.tar\" repository index file represented --- as a 'ByteString'. --- - -data PackageOrDep = Pkg PackageEntry | Dep Dependency - --- | Read @00-index.tar.gz@ and extract @.cabal@ and @preferred-versions@ files --- --- We read the index using 'Tar.read', which gives us a lazily constructed --- 'TarEntries'. We translate it to a list of entries using 'tarEntriesList', --- which preserves the lazy nature of 'TarEntries', and finally 'concatMap' a --- function over this to translate it to a list of IO actions returning --- 'PackageOrDep's. We can use 'lazySequence' to turn this into a list of --- 'PackageOrDep's, still maintaining the lazy nature of the original tar read. -parsePackageIndex :: Verbosity -> ByteString -> [IO (Maybe PackageOrDep)] -parsePackageIndex verbosity = concatMap (uncurry extract) . tarEntriesList . Tar.read - where - extract :: BlockNo -> Tar.Entry -> [IO (Maybe PackageOrDep)] - extract blockNo entry = tryExtractPkg ++ tryExtractPrefs - where - tryExtractPkg = do - mkPkgEntry <- maybeToList $ extractPkg verbosity entry blockNo - return $ fmap (fmap Pkg) mkPkgEntry - - tryExtractPrefs = do - prefs' <- maybeToList $ extractPrefs entry - fmap (return . Just . Dep) prefs' - --- | Turn the 'Entries' data structure from the @tar@ package into a list, --- and pair each entry with its block number. --- --- NOTE: This preserves the lazy nature of 'Entries': the tar file is only read --- as far as the list is evaluated. -tarEntriesList :: Show e => Tar.Entries e -> [(BlockNo, Tar.Entry)] -tarEntriesList = go 0 - where - go !_ Tar.Done = [] - go !_ (Tar.Fail e) = error ("tarEntriesList: " ++ show e) - go !n (Tar.Next e es') = (n, e) : go (Tar.nextEntryOffset e n) es' - -extractPkg :: Verbosity -> Tar.Entry -> BlockNo -> Maybe (IO (Maybe PackageEntry)) -extractPkg verbosity entry blockNo = case Tar.entryContent entry of - Tar.NormalFile content _ - | takeExtension fileName == ".cabal" - -> case splitDirectories (normalise fileName) of - [pkgname,vers,_] -> case simpleParsec vers of - Just ver -> Just . return $ Just (NormalPackage pkgid descr content blockNo) - where - pkgid = PackageIdentifier (mkPackageName pkgname) ver - parsed = parseGenericPackageDescriptionMaybe (BS.toStrict content) - descr = case parsed of - Just d -> d - Nothing -> error $ "Couldn't read cabal file " - ++ show fileName - _ -> Nothing - _ -> Nothing - - Tar.OtherEntryType typeCode content _ - | Tar.isBuildTreeRefTypeCode typeCode -> - Just $ do - let path = byteStringToFilePath content - dirExists <- doesDirectoryExist path - result <- if not dirExists then return Nothing - else do - cabalFile <- tryFindAddSourcePackageDesc verbosity path "Error reading package index." - descr <- PackageDesc.Parse.readGenericPackageDescription normal cabalFile - return . Just $ BuildTreeRef (refTypeFromTypeCode typeCode) (packageId descr) - descr path blockNo - return result - - _ -> Nothing - - where - fileName = Tar.entryPath entry - -extractPrefs :: Tar.Entry -> Maybe [Dependency] -extractPrefs entry = case Tar.entryContent entry of -{- - -- get rid of hackage's preferred-versions - -- I'd like to have bleeding-edge packages in system and I don't fear of - -- broken packages with improper depends - Tar.NormalFile content _ - | FilePath.Posix.takeFileName entrypath == "preferred-versions" - -> Just prefs - where - entrypath = Tar.entryPath entry - prefs = parsePreferredVersions content --} - _ -> Nothing - -parsePreferredVersions :: ByteString -> [Dependency] -parsePreferredVersions = mapMaybe simpleParsec - . filter (not . isPrefixOf "--") - . lines - . BS.Char8.unpack -- TODO: Are we sure no unicode? - ------------------------------------------------------------------------- --- Reading and updating the index cache --- - --- | Variation on 'sequence' which evaluates the actions lazily --- --- Pattern matching on the result list will execute just the first action; --- more generally pattern matching on the first @n@ '(:)' nodes will execute --- the first @n@ actions. -lazySequence :: [IO a] -> IO [a] -lazySequence = unsafeInterleaveIO . go - where - go [] = return [] - go (x:xs) = do x' <- x - xs' <- lazySequence xs - return (x' : xs') - --- | A lazy unfolder for lookup operations which return the current --- value and (possibly) the next key -lazyUnfold :: (k -> IO (v, Maybe k)) -> k -> IO [(k,v)] -lazyUnfold step = goLazy . Just - where - goLazy s = unsafeInterleaveIO (go s) - - go Nothing = return [] - go (Just k) = do - (v, mk') <- step k - vs' <- goLazy mk' - return ((k,v):vs') - --- | Which index do we mean? -data Index = - -- | The main index for the specified repository - RepoIndex RepoContext Repo - - -- | A sandbox-local repository - -- Argument is the location of the index file - | SandboxIndex FilePath - -indexFile :: Index -> FilePath -indexFile (RepoIndex _ctxt repo) = indexBaseName repo <.> "tar" -indexFile (SandboxIndex index) = index - -cacheFile :: Index -> FilePath -cacheFile (RepoIndex _ctxt repo) = indexBaseName repo <.> "cache" -cacheFile (SandboxIndex index) = index `replaceExtension` "cache" - -timestampFile :: Index -> FilePath -timestampFile (RepoIndex _ctxt repo) = indexBaseName repo <.> "timestamp" -timestampFile (SandboxIndex index) = index `replaceExtension` "timestamp" - --- | Return 'True' if 'Index' uses 01-index format (aka secure repo) -is01Index :: Index -> Bool -is01Index (RepoIndex _ repo) = case repo of - RepoSecure {} -> True - RepoRemote {} -> False - RepoLocalNoIndex {} -> True -is01Index (SandboxIndex _) = False - - -updatePackageIndexCacheFile :: Verbosity -> Index -> IO () -updatePackageIndexCacheFile verbosity index = do - info verbosity ("Updating index cache file " ++ cacheFile index ++ " ...") - withIndexEntries verbosity index callback callbackNoIndex - where - callback entries = do - let !maxTs = maximumTimestamp (map cacheEntryTimestamp entries) - cache = Cache { cacheHeadTs = maxTs - , cacheEntries = entries - } - writeIndexCache index cache - info verbosity ("Index cache updated to index-state " - ++ prettyShow (cacheHeadTs cache)) - - callbackNoIndex entries = do - writeNoIndexCache verbosity index $ NoIndexCache entries - info verbosity "Index cache updated" - --- | Read the index (for the purpose of building a cache) --- --- The callback is provided with list of cache entries, which is guaranteed to --- be lazily constructed. This list must ONLY be used in the scope of the --- callback; when the callback is terminated the file handle to the index will --- be closed and further attempts to read from the list will result in (pure) --- I/O exceptions. --- --- In the construction of the index for a secure repo we take advantage of the --- index built by the @hackage-security@ library to avoid reading the @.tar@ --- file as much as possible (we need to read it only to extract preferred --- versions). This helps performance, but is also required for correctness: --- the new @01-index.tar.gz@ may have multiple versions of preferred-versions --- files, and 'parsePackageIndex' does not correctly deal with that (see #2956); --- by reading the already-built cache from the security library we will be sure --- to only read the latest versions of all files. --- --- TODO: It would be nicer if we actually incrementally updated @cabal@'s --- cache, rather than reconstruct it from zero on each update. However, this --- would require a change in the cache format. -withIndexEntries - :: Verbosity -> Index - -> ([IndexCacheEntry] -> IO a) - -> ([NoIndexCacheEntry] -> IO a) - -> IO a -withIndexEntries _ (RepoIndex repoCtxt repo@RepoSecure{}) callback _ = - repoContextWithSecureRepo repoCtxt repo $ \repoSecure -> - Sec.withIndex repoSecure $ \Sec.IndexCallbacks{..} -> do - -- Incrementally (lazily) read all the entries in the tar file in order, - -- including all revisions, not just the last revision of each file - indexEntries <- lazyUnfold indexLookupEntry (Sec.directoryFirst indexDirectory) - callback [ cacheEntry - | (dirEntry, indexEntry) <- indexEntries - , cacheEntry <- toCacheEntries dirEntry indexEntry ] - where - toCacheEntries :: Sec.DirectoryEntry -> Sec.Some Sec.IndexEntry - -> [IndexCacheEntry] - toCacheEntries dirEntry (Sec.Some sie) = - case Sec.indexEntryPathParsed sie of - Nothing -> [] -- skip unrecognized file - Just (Sec.IndexPkgMetadata _pkgId) -> [] -- skip metadata - Just (Sec.IndexPkgCabal pkgId) -> force - [CachePackageId pkgId blockNo timestamp] - Just (Sec.IndexPkgPrefs _pkgName) -> force - [ CachePreference dep blockNo timestamp - | dep <- parsePreferredVersions (Sec.indexEntryContent sie) - ] - where - blockNo = Sec.directoryEntryBlockNo dirEntry - timestamp = fromMaybe (error "withIndexEntries: invalid timestamp") $ - epochTimeToTimestamp $ Sec.indexEntryTime sie - -withIndexEntries verbosity (RepoIndex _repoCtxt (RepoLocalNoIndex (LocalRepo name localDir _) _cacheDir)) _ callback = do - dirContents <- listDirectory localDir - let contentSet = Set.fromList dirContents - - entries <- handle handler $ fmap catMaybes $ for dirContents $ \file -> do - case isTarGz file of - Nothing -> do - unless (takeFileName file == "noindex.cache" || ".cabal" `isSuffixOf` file) $ - info verbosity $ "Skipping " ++ file - return Nothing - Just pkgid | cabalPath `Set.member` contentSet -> do - contents <- BSS.readFile (localDir cabalPath) - for (parseGenericPackageDescriptionMaybe contents) $ \gpd -> - return (CacheGPD gpd contents) - where - cabalPath = prettyShow pkgid ++ ".cabal" - Just pkgId -> do - -- check for the right named .cabal file in the compressed tarball - tarGz <- BS.readFile (localDir file) - let tar = GZip.decompress tarGz - entries = Tar.read tar - - case Tar.foldEntries (readCabalEntry pkgId) Nothing (const Nothing) entries of - Just ce -> return (Just ce) - Nothing -> die' verbosity $ "Cannot read .cabal file inside " ++ file - - info verbosity $ "Entries in file+noindex repository " ++ unRepoName name - for_ entries $ \(CacheGPD gpd _) -> - info verbosity $ "- " ++ prettyShow (package $ Distribution.PackageDescription.packageDescription gpd) - - callback entries - where - handler :: IOException -> IO a - handler e = die' verbosity $ "Error while updating index for " ++ unRepoName name ++ " repository " ++ show e - - isTarGz :: FilePath -> Maybe PackageIdentifier - isTarGz fp = do - pfx <- stripSuffix ".tar.gz" fp - simpleParsec pfx - - stripSuffix sfx str = fmap reverse (stripPrefix (reverse sfx) (reverse str)) - - -- look for /.cabal inside the tarball - readCabalEntry :: PackageIdentifier -> Tar.Entry -> Maybe NoIndexCacheEntry -> Maybe NoIndexCacheEntry - readCabalEntry pkgId entry Nothing - | filename == Tar.entryPath entry - , Tar.NormalFile contents _ <- Tar.entryContent entry - = let bs = BS.toStrict contents - in fmap (\gpd -> CacheGPD gpd bs) $ parseGenericPackageDescriptionMaybe bs - where - filename = prettyShow pkgId FilePath.Posix. prettyShow (packageName pkgId) ++ ".cabal" - readCabalEntry _ _ x = x - -withIndexEntries verbosity index callback _ = do -- non-secure repositories - withFile (indexFile index) ReadMode $ \h -> do - bs <- maybeDecompress `fmap` BS.hGetContents h - pkgsOrPrefs <- lazySequence $ parsePackageIndex verbosity bs - callback $ map toCache (catMaybes pkgsOrPrefs) - where - toCache :: PackageOrDep -> IndexCacheEntry - toCache (Pkg (NormalPackage pkgid _ _ blockNo)) = CachePackageId pkgid blockNo nullTimestamp - toCache (Pkg (BuildTreeRef refType _ _ _ blockNo)) = CacheBuildTreeRef refType blockNo - toCache (Dep d) = CachePreference d 0 nullTimestamp - -readPackageIndexCacheFile :: Package pkg - => Verbosity - -> (PackageEntry -> pkg) - -> Index - -> RepoIndexState - -> IO (PackageIndex pkg, [Dependency], IndexStateInfo) -readPackageIndexCacheFile verbosity mkPkg index idxState - | localNoIndex index = do - cache0 <- readNoIndexCache verbosity index - pkgs <- packageNoIndexFromCache verbosity mkPkg cache0 - pure (pkgs, [], emptyStateInfo) - - | otherwise = do - cache0 <- readIndexCache verbosity index - indexHnd <- openFile (indexFile index) ReadMode - let (cache,isi) = filterCache idxState cache0 - (pkgs,deps) <- packageIndexFromCache verbosity mkPkg indexHnd cache - pure (pkgs,deps,isi) - -packageIndexFromCache :: Package pkg - => Verbosity - -> (PackageEntry -> pkg) - -> Handle - -> Cache - -> IO (PackageIndex pkg, [Dependency]) -packageIndexFromCache verbosity mkPkg hnd cache = do - (pkgs, prefs) <- packageListFromCache verbosity mkPkg hnd cache - pkgIndex <- evaluate $ PackageIndex.fromList pkgs - return (pkgIndex, prefs) - -packageNoIndexFromCache - :: forall pkg. Package pkg - => Verbosity - -> (PackageEntry -> pkg) - -> NoIndexCache - -> IO (PackageIndex pkg) -packageNoIndexFromCache _verbosity mkPkg cache = - evaluate $ PackageIndex.fromList pkgs - where - pkgs = - [ mkPkg $ NormalPackage pkgId gpd (BS.fromStrict bs) 0 - | CacheGPD gpd bs <- noIndexCacheEntries cache - , let pkgId = package $ Distribution.PackageDescription.packageDescription gpd - ] - --- | Read package list --- --- The result package releases and preference entries are guaranteed --- to be unique. --- --- Note: 01-index.tar is an append-only index and therefore contains --- all .cabal edits and preference-updates. The masking happens --- here, i.e. the semantics that later entries in a tar file mask --- earlier ones is resolved in this function. -packageListFromCache :: Verbosity - -> (PackageEntry -> pkg) - -> Handle - -> Cache - -> IO ([pkg], [Dependency]) -packageListFromCache verbosity mkPkg hnd Cache{..} = accum mempty [] mempty cacheEntries - where - accum !srcpkgs btrs !prefs [] = return (Map.elems srcpkgs ++ btrs, Map.elems prefs) - - accum srcpkgs btrs prefs (CachePackageId pkgid blockno _ : entries) = do - -- Given the cache entry, make a package index entry. - -- The magic here is that we use lazy IO to read the .cabal file - -- from the index tarball if it turns out that we need it. - -- Most of the time we only need the package id. - ~(pkg, pkgtxt) <- unsafeInterleaveIO $ do - pkgtxt <- getEntryContent blockno - pkg <- readPackageDescription pkgid pkgtxt - return (pkg, pkgtxt) - - let srcpkg = mkPkg (NormalPackage pkgid pkg pkgtxt blockno) - accum (Map.insert pkgid srcpkg srcpkgs) btrs prefs entries - - accum srcpkgs btrs prefs (CacheBuildTreeRef refType blockno : entries) = do - -- We have to read the .cabal file eagerly here because we can't cache the - -- package id for build tree references - the user might edit the .cabal - -- file after the reference was added to the index. - path <- liftM byteStringToFilePath . getEntryContent $ blockno - pkg <- do let err = "Error reading package index from cache." - file <- tryFindAddSourcePackageDesc verbosity path err - PackageDesc.Parse.readGenericPackageDescription normal file - let srcpkg = mkPkg (BuildTreeRef refType (packageId pkg) pkg path blockno) - accum srcpkgs (srcpkg:btrs) prefs entries - - accum srcpkgs btrs prefs (CachePreference pref@(Dependency pn _ _) _ _ : entries) = - accum srcpkgs btrs (Map.insert pn pref prefs) entries - - getEntryContent :: BlockNo -> IO ByteString - getEntryContent blockno = do - entry <- Tar.hReadEntry hnd blockno - case Tar.entryContent entry of - Tar.NormalFile content _size -> return content - Tar.OtherEntryType typecode content _size - | Tar.isBuildTreeRefTypeCode typecode - -> return content - _ -> interror "unexpected tar entry type" - - readPackageDescription :: PackageIdentifier -> ByteString -> IO GenericPackageDescription - readPackageDescription pkgid content = - case snd $ PackageDesc.Parse.runParseResult $ parseGenericPackageDescription $ BS.toStrict content of - Right gpd -> return gpd - Left (Just specVer, _) | specVer >= mkVersion [2,2] -> return (dummyPackageDescription specVer) - Left _ -> interror "failed to parse .cabal file" - where - dummyPackageDescription :: Version -> GenericPackageDescription - dummyPackageDescription specVer = GenericPackageDescription - { packageDescription = emptyPackageDescription - { package = pkgid - , synopsis = dummySynopsis - } - , gpdScannedVersion = Just specVer -- tells index scanner to skip this file. - , genPackageFlags = [] - , condLibrary = Nothing - , condSubLibraries = [] - , condForeignLibs = [] - , condExecutables = [] - , condTestSuites = [] - , condBenchmarks = [] - } - - dummySynopsis = "" - - interror :: String -> IO a - interror msg = die' verbosity $ "internal error when reading package index: " ++ msg - ++ "The package index or index cache is probably " - ++ "corrupt. Running 'hackport update' might fix it." - - - ------------------------------------------------------------------------- --- Index cache data structure -- - --- | Read the 'Index' cache from the filesystem --- --- If a corrupted index cache is detected this function regenerates --- the index cache and then reattempt to read the index once (and --- 'die's if it fails again). -readIndexCache :: Verbosity -> Index -> IO Cache -readIndexCache verbosity index = do - cacheOrFail <- readIndexCache' index - case cacheOrFail of - Left msg -> do - warn verbosity $ concat - [ "Parsing the index cache failed (", msg, "). " - , "Trying to regenerate the index cache..." - ] - - updatePackageIndexCacheFile verbosity index - - either (die' verbosity) (return . hashConsCache) =<< readIndexCache' index - - Right res -> return (hashConsCache res) - -readNoIndexCache :: Verbosity -> Index -> IO NoIndexCache -readNoIndexCache verbosity index = do - cacheOrFail <- readNoIndexCache' index - case cacheOrFail of - Left msg -> do - warn verbosity $ concat - [ "Parsing the index cache failed (", msg, "). " - , "Trying to regenerate the index cache..." - ] - - updatePackageIndexCacheFile verbosity index - - either (die' verbosity) return =<< readNoIndexCache' index - - -- we don't hash cons local repository cache, they are hopefully small - Right res -> return res - --- | Read the 'Index' cache from the filesystem without attempting to --- regenerate on parsing failures. -readIndexCache' :: Index -> IO (Either String Cache) -readIndexCache' index - | is01Index index = structuredDecodeFileOrFail (cacheFile index) - | otherwise = liftM (Right .read00IndexCache) $ - BSS.readFile (cacheFile index) - -readNoIndexCache' :: Index -> IO (Either String NoIndexCache) -readNoIndexCache' index = structuredDecodeFileOrFail (cacheFile index) - --- | Write the 'Index' cache to the filesystem -writeIndexCache :: Index -> Cache -> IO () -writeIndexCache index cache - | is01Index index = structuredEncodeFile (cacheFile index) cache - | otherwise = writeFile (cacheFile index) (show00IndexCache cache) - -writeNoIndexCache :: Verbosity -> Index -> NoIndexCache -> IO () -writeNoIndexCache verbosity index cache = do - let path = cacheFile index - createDirectoryIfMissingVerbose verbosity True (takeDirectory path) - structuredEncodeFile path cache - --- | Write the 'IndexState' to the filesystem -writeIndexTimestamp :: Index -> RepoIndexState -> IO () -writeIndexTimestamp index st - = writeFile (timestampFile index) (prettyShow st) - --- | Read out the "current" index timestamp, i.e., what --- timestamp you would use to revert to this version -currentIndexTimestamp :: Verbosity -> RepoContext -> Repo -> IO Timestamp -currentIndexTimestamp verbosity repoCtxt r = do - mb_is <- readIndexTimestamp (RepoIndex repoCtxt r) - case mb_is of - Just (IndexStateTime ts) -> return ts - _ -> do - (_,_,isi) <- readRepoIndex verbosity repoCtxt r IndexStateHead - return (isiHeadTime isi) - --- | Read the 'IndexState' from the filesystem -readIndexTimestamp :: Index -> IO (Maybe RepoIndexState) -readIndexTimestamp index - = fmap simpleParsec (readFile (timestampFile index)) - `catchIO` \e -> - if isDoesNotExistError e - then return Nothing - else ioError e - --- | Optimise sharing of equal values inside 'Cache' --- --- c.f. https://en.wikipedia.org/wiki/Hash_consing -hashConsCache :: Cache -> Cache -hashConsCache cache0 - = cache0 { cacheEntries = go mempty mempty (cacheEntries cache0) } - where - -- TODO/NOTE: - -- - -- If/when we redo the binary serialisation via e.g. CBOR and we - -- are able to use incremental decoding, we may want to move the - -- hash-consing into the incremental deserialisation, or - -- alterantively even do something like - -- http://cbor.schmorp.de/value-sharing - -- - go _ _ [] = [] - -- for now we only optimise only CachePackageIds since those - -- represent the vast majority - go !pns !pvs (CachePackageId pid bno ts : rest) - = CachePackageId pid' bno ts : go pns' pvs' rest - where - !pid' = PackageIdentifier pn' pv' - (!pn',!pns') = mapIntern pn pns - (!pv',!pvs') = mapIntern pv pvs - PackageIdentifier pn pv = pid - - go pns pvs (x:xs) = x : go pns pvs xs - - mapIntern :: Ord k => k -> Map.Map k k -> (k,Map.Map k k) - mapIntern k m = maybe (k,Map.insert k k m) (\k' -> (k',m)) (Map.lookup k m) - --- | Cabal caches various information about the Hackage index -data Cache = Cache - { cacheHeadTs :: Timestamp - -- ^ maximum/latest 'Timestamp' among 'cacheEntries'; unless the - -- invariant of 'cacheEntries' being in chronological order is - -- violated, this corresponds to the last (seen) 'Timestamp' in - -- 'cacheEntries' - , cacheEntries :: [IndexCacheEntry] - } - deriving (Show, Generic) - -instance NFData Cache where - rnf = rnf . cacheEntries - --- | Cache format for 'file+noindex' repositories -newtype NoIndexCache = NoIndexCache - { noIndexCacheEntries :: [NoIndexCacheEntry] - } - deriving (Show, Generic) - -instance NFData NoIndexCache where - rnf = rnf . noIndexCacheEntries - --- | Tar files are block structured with 512 byte blocks. Every header and file --- content starts on a block boundary. --- -type BlockNo = Word32 -- Tar.TarEntryOffset - -data IndexCacheEntry - = CachePackageId PackageId !BlockNo !Timestamp - | CachePreference Dependency !BlockNo !Timestamp - | CacheBuildTreeRef !BuildTreeRefType !BlockNo - -- NB: CacheBuildTreeRef is irrelevant for 01-index & v2-build - deriving (Eq,Show,Generic) - -data NoIndexCacheEntry - = CacheGPD GenericPackageDescription !BSS.ByteString - deriving (Eq,Show,Generic) - -instance NFData IndexCacheEntry where - rnf (CachePackageId pkgid _ _) = rnf pkgid - rnf (CachePreference dep _ _) = rnf dep - rnf (CacheBuildTreeRef _ _) = () - -instance NFData NoIndexCacheEntry where - rnf (CacheGPD gpd bs) = rnf gpd `seq` rnf bs - -cacheEntryTimestamp :: IndexCacheEntry -> Timestamp -cacheEntryTimestamp (CacheBuildTreeRef _ _) = nullTimestamp -cacheEntryTimestamp (CachePreference _ _ ts) = ts -cacheEntryTimestamp (CachePackageId _ _ ts) = ts - ----------------------------------------------------------------------------- --- new binary 01-index.cache format - -instance Binary Cache -instance Binary IndexCacheEntry -instance Binary NoIndexCache - -instance Structured Cache -instance Structured IndexCacheEntry -instance Structured NoIndexCache - --- | We need to save only .cabal file contents -instance Binary NoIndexCacheEntry where - put (CacheGPD _ bs) = put bs - - get = do - bs <- get - case parseGenericPackageDescriptionMaybe bs of - Just gpd -> return (CacheGPD gpd bs) - Nothing -> fail "Failed to parse GPD" - -instance Structured NoIndexCacheEntry where - structure = nominalStructure - ----------------------------------------------------------------------------- --- legacy 00-index.cache format - -packageKey, blocknoKey, buildTreeRefKey, preferredVersionKey :: String -packageKey = "pkg:" -blocknoKey = "b#" -buildTreeRefKey = "build-tree-ref:" -preferredVersionKey = "pref-ver:" - --- legacy 00-index.cache format -read00IndexCache :: BSS.ByteString -> Cache -read00IndexCache bs = Cache - { cacheHeadTs = nullTimestamp - , cacheEntries = mapMaybe read00IndexCacheEntry $ BSS.lines bs - } - -read00IndexCacheEntry :: BSS.ByteString -> Maybe IndexCacheEntry -read00IndexCacheEntry = \line -> - case BSS.words line of - [key, pkgnamestr, pkgverstr, sep, blocknostr] - | key == BSS.pack packageKey && sep == BSS.pack blocknoKey -> - case (parseName pkgnamestr, parseVer pkgverstr [], - parseBlockNo blocknostr) of - (Just pkgname, Just pkgver, Just blockno) - -> Just (CachePackageId (PackageIdentifier pkgname pkgver) - blockno nullTimestamp) - _ -> Nothing - [key, typecodestr, blocknostr] | key == BSS.pack buildTreeRefKey -> - case (parseRefType typecodestr, parseBlockNo blocknostr) of - (Just refType, Just blockno) - -> Just (CacheBuildTreeRef refType blockno) - _ -> Nothing - - (key: remainder) | key == BSS.pack preferredVersionKey -> do - pref <- simpleParsecBS (BSS.unwords remainder) - return $ CachePreference pref 0 nullTimestamp - - _ -> Nothing - where - parseName str - | BSS.all (\c -> isAlphaNum c || c == '-') str - = Just (mkPackageName (BSS.unpack str)) - | otherwise = Nothing - - parseVer str vs = - case BSS.readInt str of - Nothing -> Nothing - Just (v, str') -> case BSS.uncons str' of - Just ('.', str'') -> parseVer str'' (v:vs) - Just _ -> Nothing - Nothing -> Just (mkVersion (reverse (v:vs))) - - parseBlockNo str = - case BSS.readInt str of - Just (blockno, remainder) - | BSS.null remainder -> Just (fromIntegral blockno) - _ -> Nothing - - parseRefType str = - case BSS.uncons str of - Just (typeCode, remainder) - | BSS.null remainder && Tar.isBuildTreeRefTypeCode typeCode - -> Just (refTypeFromTypeCode typeCode) - _ -> Nothing - --- legacy 00-index.cache format -show00IndexCache :: Cache -> String -show00IndexCache Cache{..} = unlines $ map show00IndexCacheEntry cacheEntries - -show00IndexCacheEntry :: IndexCacheEntry -> String -show00IndexCacheEntry entry = unwords $ case entry of - CachePackageId pkgid b _ -> - [ packageKey - , prettyShow (packageName pkgid) - , prettyShow (packageVersion pkgid) - , blocknoKey - , show b - ] - CacheBuildTreeRef tr b -> - [ buildTreeRefKey - , [typeCodeFromRefType tr] - , show b - ] - CachePreference dep _ _ -> - [ preferredVersionKey - , prettyShow dep - ] diff --git a/cabal/cabal-install/Distribution/Client/IndexUtils/ActiveRepos.hs b/cabal/cabal-install/Distribution/Client/IndexUtils/ActiveRepos.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/IndexUtils/ActiveRepos.hs +++ /dev/null @@ -1,174 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Distribution.Client.IndexUtils.ActiveRepos ( - ActiveRepos (..), - defaultActiveRepos, - ActiveRepoEntry (..), - CombineStrategy (..), - organizeByRepos, -) where - -import Distribution.Client.Compat.Prelude -import Distribution.Client.Types.RepoName (RepoName (..)) -import Prelude () - -import Distribution.Parsec (parsecLeadingCommaNonEmpty) - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - --- $setup --- >>> import Distribution.Parsec - -------------------------------------------------------------------------------- --- Types -------------------------------------------------------------------------------- - --- | Ordered list of active repositories. -newtype ActiveRepos = ActiveRepos [ActiveRepoEntry] - deriving (Eq, Show, Generic) - -defaultActiveRepos :: ActiveRepos -defaultActiveRepos = ActiveRepos [ ActiveRepoRest CombineStrategyMerge ] - -instance Binary ActiveRepos -instance Structured ActiveRepos -instance NFData ActiveRepos - -instance Pretty ActiveRepos where - pretty (ActiveRepos []) - = Disp.text ":none" - pretty (ActiveRepos repos) - = Disp.hsep - $ Disp.punctuate Disp.comma - $ map pretty repos - --- | Note: empty string is not valid 'ActiveRepos'. --- --- >>> simpleParsec "" :: Maybe ActiveRepos --- Nothing --- --- >>> simpleParsec ":none" :: Maybe ActiveRepos --- Just (ActiveRepos []) --- --- >>> simpleParsec ":rest" :: Maybe ActiveRepos --- Just (ActiveRepos [ActiveRepoRest CombineStrategyMerge]) --- --- >>> simpleParsec "hackage.haskell.org, :rest, head.hackage:override" :: Maybe ActiveRepos --- Just (ActiveRepos [ActiveRepo (RepoName "hackage.haskell.org") CombineStrategyMerge,ActiveRepoRest CombineStrategyMerge,ActiveRepo (RepoName "head.hackage") CombineStrategyOverride]) --- -instance Parsec ActiveRepos where - parsec = ActiveRepos [] <$ P.try (P.string ":none") - <|> do - repos <- parsecLeadingCommaNonEmpty parsec - return (ActiveRepos (toList repos)) - -data ActiveRepoEntry - = ActiveRepoRest CombineStrategy -- ^ rest repositories, i.e. not explicitly listed as 'ActiveRepo' - | ActiveRepo RepoName CombineStrategy -- ^ explicit repository name - deriving (Eq, Show, Generic) - -instance Binary ActiveRepoEntry -instance Structured ActiveRepoEntry -instance NFData ActiveRepoEntry - -instance Pretty ActiveRepoEntry where - pretty (ActiveRepoRest s) = - Disp.text ":rest" <<>> Disp.colon <<>> pretty s - pretty (ActiveRepo r s) = - pretty r <<>> Disp.colon <<>> pretty s - -instance Parsec ActiveRepoEntry where - parsec = leadColon <|> leadRepo where - leadColon = do - _ <- P.char ':' - token <- P.munch1 isAlpha - case token of - "rest" -> ActiveRepoRest <$> strategyP - "repo" -> P.char ':' *> leadRepo - _ -> P.unexpected $ "Unknown active repository entry type: " ++ token - - leadRepo = do - r <- parsec - s <- strategyP - return (ActiveRepo r s) - - strategyP = P.option CombineStrategyMerge (P.char ':' *> parsec) - -data CombineStrategy - = CombineStrategyMerge -- ^ merge existing versions - | CombineStrategyOverride -- ^ if later repository specifies a package, - -- all package versions are replaced - deriving (Eq, Show, Enum, Bounded, Generic) - -instance Binary CombineStrategy -instance Structured CombineStrategy -instance NFData CombineStrategy - -instance Pretty CombineStrategy where - pretty CombineStrategyMerge = Disp.text "merge" - pretty CombineStrategyOverride = Disp.text "override" - -instance Parsec CombineStrategy where - parsec = P.choice - [ CombineStrategyMerge <$ P.string "merge" - , CombineStrategyOverride <$ P.string "override" - ] - -------------------------------------------------------------------------------- --- Organisation -------------------------------------------------------------------------------- - --- | Sort values 'RepoName' according to 'ActiveRepos' list. --- --- >>> let repos = [RepoName "a", RepoName "b", RepoName "c"] --- >>> organizeByRepos (ActiveRepos [ActiveRepoRest CombineStrategyMerge]) id repos --- Right [(RepoName "a",CombineStrategyMerge),(RepoName "b",CombineStrategyMerge),(RepoName "c",CombineStrategyMerge)] --- --- >>> organizeByRepos (ActiveRepos [ActiveRepo (RepoName "b") CombineStrategyOverride, ActiveRepoRest CombineStrategyMerge]) id repos --- Right [(RepoName "b",CombineStrategyOverride),(RepoName "a",CombineStrategyMerge),(RepoName "c",CombineStrategyMerge)] --- --- >>> organizeByRepos (ActiveRepos [ActiveRepoRest CombineStrategyMerge, ActiveRepo (RepoName "b") CombineStrategyOverride]) id repos --- Right [(RepoName "a",CombineStrategyMerge),(RepoName "c",CombineStrategyMerge),(RepoName "b",CombineStrategyOverride)] --- --- >>> organizeByRepos (ActiveRepos [ActiveRepoRest CombineStrategyMerge, ActiveRepo (RepoName "d") CombineStrategyOverride]) id repos --- Left "no repository provided d" --- --- Note: currently if 'ActiveRepoRest' is provided more than once, --- rest-repositories will be multiple times in the output. --- -organizeByRepos - :: forall a. ActiveRepos - -> (a -> RepoName) - -> [a] - -> Either String [(a, CombineStrategy)] -organizeByRepos (ActiveRepos xs0) sel ys0 = - -- here we use lazyness to do only one traversal - let (rest, result) = case go rest xs0 ys0 of - Right (rest', result') -> (rest', Right result') - Left err -> ([], Left err) - in result - where - go :: [a] -> [ActiveRepoEntry] -> [a] -> Either String ([a], [(a, CombineStrategy)]) - go _rest [] ys = Right (ys, []) - go rest (ActiveRepoRest s : xs) ys = - go rest xs ys <&> \(rest', result) -> - (rest', map (\x -> (x, s)) rest ++ result) - go rest (ActiveRepo r s : xs) ys = do - (z, zs) <- extract r ys - go rest xs zs <&> \(rest', result) -> - (rest', (z, s) : result) - - extract :: RepoName -> [a] -> Either String (a, [a]) - extract r = loop id where - loop _acc [] = Left $ "no repository provided " ++ prettyShow r - loop acc (x:xs) - | sel x == r = Right (x, acc xs) - | otherwise = loop (acc . (x :)) xs - - (<&>) - :: Either err ([s], b) - -> (([s], b) -> ([s], c)) - -> Either err ([s], c) - (<&>) = flip fmap diff --git a/cabal/cabal-install/Distribution/Client/IndexUtils/IndexState.hs b/cabal/cabal-install/Distribution/Client/IndexUtils/IndexState.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/IndexUtils/IndexState.hs +++ /dev/null @@ -1,138 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.IndexUtils.IndexUtils --- Copyright : (c) 2016 Herbert Valerio Riedel --- License : BSD3 --- --- Package repositories index state. --- -module Distribution.Client.IndexUtils.IndexState ( - RepoIndexState(..), - TotalIndexState, - headTotalIndexState, - makeTotalIndexState, - lookupIndexState, - insertIndexState, -) where - -import Distribution.Client.Compat.Prelude -import Distribution.Client.IndexUtils.Timestamp (Timestamp) -import Distribution.Client.Types.RepoName (RepoName (..)) - -import Distribution.Parsec (parsecLeadingCommaNonEmpty) - -import qualified Data.Map.Strict as Map -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - --- $setup --- >>> import Distribution.Parsec - -------------------------------------------------------------------------------- --- Total index state -------------------------------------------------------------------------------- - --- | Index state of multiple repositories -data TotalIndexState = TIS RepoIndexState (Map RepoName RepoIndexState) - deriving (Eq, Show, Generic) - -instance Binary TotalIndexState -instance Structured TotalIndexState -instance NFData TotalIndexState - -instance Pretty TotalIndexState where - pretty (TIS IndexStateHead m) - | not (Map.null m) - = Disp.hsep $ Disp.punctuate Disp.comma - [ pretty rn Disp.<+> pretty idx - | (rn, idx) <- Map.toList m - ] - pretty (TIS def m) = foldl' go (pretty def) (Map.toList m) where - go doc (rn, idx) = doc <<>> Disp.comma Disp.<+> pretty rn Disp.<+> pretty idx - --- | --- --- >>> simpleParsec "HEAD" :: Maybe TotalIndexState --- Just (TIS IndexStateHead (fromList [])) --- --- >>> simpleParsec "" :: Maybe TotalIndexState --- Nothing --- --- >>> simpleParsec "hackage.haskell.org HEAD" :: Maybe TotalIndexState --- Just (TIS IndexStateHead (fromList [])) --- --- >>> simpleParsec "2020-02-04T12:34:56Z, hackage.haskell.org HEAD" :: Maybe TotalIndexState --- Just (TIS (IndexStateTime (TS 1580819696)) (fromList [(RepoName "hackage.haskell.org",IndexStateHead)])) --- --- >>> simpleParsec "hackage.haskell.org 2020-02-04T12:34:56Z" :: Maybe TotalIndexState --- Just (TIS IndexStateHead (fromList [(RepoName "hackage.haskell.org",IndexStateTime (TS 1580819696))])) --- -instance Parsec TotalIndexState where - parsec = normalise . foldl' add headTotalIndexState <$> parsecLeadingCommaNonEmpty single0 where - single0 = startsWithRepoName <|> TokTimestamp <$> parsec - startsWithRepoName = do - reponame <- parsec - -- the "HEAD" is technically a valid reponame... - if reponame == RepoName "HEAD" - then return TokHead - else do - P.spaces - TokRepo reponame <$> parsec - - add :: TotalIndexState -> Tok -> TotalIndexState - add _ TokHead = headTotalIndexState - add _ (TokTimestamp ts) = TIS (IndexStateTime ts) Map.empty - add (TIS def m) (TokRepo rn idx) = TIS def (Map.insert rn idx m) - --- used in Parsec TotalIndexState implementation -data Tok - = TokRepo RepoName RepoIndexState - | TokTimestamp Timestamp - | TokHead - --- | Remove non-default values from 'TotalIndexState'. -normalise :: TotalIndexState -> TotalIndexState -normalise (TIS def m) = TIS def (Map.filter (/= def) m) - --- | 'TotalIndexState' where all repositories are at @HEAD@ index state. -headTotalIndexState :: TotalIndexState -headTotalIndexState = TIS IndexStateHead Map.empty - --- | Create 'TotalIndexState'. -makeTotalIndexState :: RepoIndexState -> Map RepoName RepoIndexState -> TotalIndexState -makeTotalIndexState def m = normalise (TIS def m) - --- | Lookup a 'RepoIndexState' for an individual repository from 'TotalIndexState'. -lookupIndexState :: RepoName -> TotalIndexState -> RepoIndexState -lookupIndexState rn (TIS def m) = Map.findWithDefault def rn m - --- | Insert a 'RepoIndexState' to 'TotalIndexState'. -insertIndexState :: RepoName -> RepoIndexState -> TotalIndexState -> TotalIndexState -insertIndexState rn idx (TIS def m) - | idx == def = TIS def (Map.delete rn m) - | otherwise = TIS def (Map.insert rn idx m) - -------------------------------------------------------------------------------- --- Repository index state -------------------------------------------------------------------------------- - --- | Specification of the state of a specific repo package index -data RepoIndexState - = IndexStateHead -- ^ Use all available entries - | IndexStateTime !Timestamp -- ^ Use all entries that existed at the specified time - deriving (Eq,Generic,Show) - -instance Binary RepoIndexState -instance Structured RepoIndexState -instance NFData RepoIndexState - -instance Pretty RepoIndexState where - pretty IndexStateHead = Disp.text "HEAD" - pretty (IndexStateTime ts) = pretty ts - -instance Parsec RepoIndexState where - parsec = parseHead <|> parseTime where - parseHead = IndexStateHead <$ P.string "HEAD" - parseTime = IndexStateTime <$> parsec diff --git a/cabal/cabal-install/Distribution/Client/IndexUtils/Timestamp.hs b/cabal/cabal-install/Distribution/Client/IndexUtils/Timestamp.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/IndexUtils/Timestamp.hs +++ /dev/null @@ -1,161 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.IndexUtils.Timestamp --- Copyright : (c) 2016 Herbert Valerio Riedel --- License : BSD3 --- --- Timestamp type used in package indexes - -module Distribution.Client.IndexUtils.Timestamp - ( Timestamp - , nullTimestamp - , epochTimeToTimestamp - , timestampToUTCTime - , utcTimeToTimestamp - , maximumTimestamp - ) where - -import Distribution.Client.Compat.Prelude - --- read is needed for Text instance -import Prelude (read) - -import Data.Time (UTCTime (..), fromGregorianValid, makeTimeOfDayValid, showGregorian, timeOfDayToTime, timeToTimeOfDay) -import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds) - -import qualified Codec.Archive.Tar.Entry as Tar -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - --- | UNIX timestamp (expressed in seconds since unix epoch, i.e. 1970). -newtype Timestamp = TS Int64 -- Tar.EpochTime - deriving (Eq,Ord,Enum,NFData,Show,Generic) - -epochTimeToTimestamp :: Tar.EpochTime -> Maybe Timestamp -epochTimeToTimestamp et - | ts == nullTimestamp = Nothing - | otherwise = Just ts - where - ts = TS et - -timestampToUTCTime :: Timestamp -> Maybe UTCTime -timestampToUTCTime (TS t) - | t == minBound = Nothing - | otherwise = Just $ posixSecondsToUTCTime (fromIntegral t) - -utcTimeToTimestamp :: UTCTime -> Maybe Timestamp -utcTimeToTimestamp utct - | minTime <= t, t <= maxTime = Just (TS (fromIntegral t)) - | otherwise = Nothing - where - maxTime = toInteger (maxBound :: Int64) - minTime = toInteger (succ minBound :: Int64) - t :: Integer - t = round . utcTimeToPOSIXSeconds $ utct - --- | Compute the maximum 'Timestamp' value --- --- Returns 'nullTimestamp' for the empty list. Also note that --- 'nullTimestamp' compares as smaller to all non-'nullTimestamp' --- values. -maximumTimestamp :: [Timestamp] -> Timestamp -maximumTimestamp [] = nullTimestamp -maximumTimestamp xs@(_:_) = maximum xs - --- returns 'Nothing' if not representable as 'Timestamp' -posixSecondsToTimestamp :: Integer -> Maybe Timestamp -posixSecondsToTimestamp pt - | minTs <= pt, pt <= maxTs = Just (TS (fromInteger pt)) - | otherwise = Nothing - where - maxTs = toInteger (maxBound :: Int64) - minTs = toInteger (succ minBound :: Int64) - --- | Pretty-prints 'Timestamp' in ISO8601/RFC3339 format --- (e.g. @"2017-12-31T23:59:59Z"@) --- --- Returns empty string for 'nullTimestamp' in order for --- --- > null (display nullTimestamp) == True --- --- to hold. -showTimestamp :: Timestamp -> String -showTimestamp ts = case timestampToUTCTime ts of - Nothing -> "" - -- Note: we don't use 'formatTime' here to avoid incurring a - -- dependency on 'old-locale' for older `time` libs - Just UTCTime{..} -> showGregorian utctDay ++ ('T':showTOD utctDayTime) ++ "Z" - where - showTOD = show . timeToTimeOfDay - -instance Binary Timestamp -instance Structured Timestamp - -instance Pretty Timestamp where - pretty = Disp.text . showTimestamp - -instance Parsec Timestamp where - parsec = parsePosix <|> parseUTC - where - -- | Parses unix timestamps, e.g. @"\@1474626019"@ - parsePosix = do - _ <- P.char '@' - t <- P.integral -- note, no negative timestamps - maybe (fail (show t ++ " is not representable as timestamp")) return $ - posixSecondsToTimestamp t - - -- | Parses ISO8601/RFC3339-style UTC timestamps, - -- e.g. @"2017-12-31T23:59:59Z"@ - -- - -- TODO: support numeric tz offsets; allow to leave off seconds - parseUTC = do - -- Note: we don't use 'Data.Time.Format.parseTime' here since - -- we want more control over the accepted formats. - - ye <- parseYear - _ <- P.char '-' - mo <- parseTwoDigits - _ <- P.char '-' - da <- parseTwoDigits - _ <- P.char 'T' - - utctDay <- maybe (fail (show (ye,mo,da) ++ " is not valid gregorian date")) return $ - fromGregorianValid ye mo da - - ho <- parseTwoDigits - _ <- P.char ':' - mi <- parseTwoDigits - _ <- P.char ':' - se <- parseTwoDigits - _ <- P.char 'Z' - - utctDayTime <- maybe (fail (show (ho,mi,se) ++ " is not valid time of day")) (return . timeOfDayToTime) $ - makeTimeOfDayValid ho mi (realToFrac (se::Int)) - - let utc = UTCTime {..} - - maybe (fail (show utc ++ " is not representable as timestamp")) return $ utcTimeToTimestamp utc - - parseTwoDigits = do - d1 <- P.satisfy isDigit - d2 <- P.satisfy isDigit - return (read [d1,d2]) - - -- A year must have at least 4 digits; e.g. "0097" is fine, - -- while "97" is not c.f. RFC3339 which - -- deprecates 2-digit years - parseYear = do - sign <- P.option ' ' (P.char '-') - ds <- P.munch1 isDigit - when (length ds < 4) $ fail "Year should have at least 4 digits" - return (read (sign:ds)) - --- | Special timestamp value to be used when 'timestamp' is --- missing/unknown/invalid -nullTimestamp :: Timestamp -nullTimestamp = TS minBound diff --git a/cabal/cabal-install/Distribution/Client/Init.hs b/cabal/cabal-install/Distribution/Client/Init.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Init.hs +++ /dev/null @@ -1,25 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Init --- Copyright : (c) Brent Yorgey 2009 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- Implementation of the 'cabal init' command, which creates an initial .cabal --- file for a project. --- ------------------------------------------------------------------------------ - -module Distribution.Client.Init ( - - -- * Commands - initCabal - , incVersion - - ) where - -import Distribution.Client.Init.Command - ( initCabal, incVersion ) diff --git a/cabal/cabal-install/Distribution/Client/Init/Command.hs b/cabal/cabal-install/Distribution/Client/Init/Command.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Init/Command.hs +++ /dev/null @@ -1,730 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Init.Command --- Copyright : (c) Brent Yorgey 2009 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- Implementation of the 'cabal init' command, which creates an initial .cabal --- file for a project. --- ------------------------------------------------------------------------------ - -module Distribution.Client.Init.Command ( - - -- * Commands - initCabal - , incVersion - - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude hiding (empty) - -import System.IO - ( hSetBuffering, stdout, BufferMode(..) ) -import System.Directory - ( getCurrentDirectory, doesDirectoryExist, getDirectoryContents ) -import System.FilePath - ( (), takeBaseName, equalFilePath ) - -import qualified Data.List.NonEmpty as NE -import qualified Data.Map as M -import Control.Monad - ( (>=>) ) -import Control.Arrow - ( (&&&), (***) ) - -import Distribution.CabalSpecVersion - ( CabalSpecVersion (..), showCabalSpecVersion ) -import Distribution.Version - ( Version, mkVersion, alterVersion, majorBoundVersion - , orLaterVersion, earlierVersion, intersectVersionRanges, VersionRange ) -import Distribution.ModuleName - ( ModuleName ) -- And for the Text instance -import Distribution.InstalledPackageInfo - ( InstalledPackageInfo, exposed ) -import qualified Distribution.Package as P -import qualified Distribution.SPDX as SPDX -import Language.Haskell.Extension ( Language(..) ) - -import Distribution.Client.Init.Defaults - ( defaultApplicationDir, defaultCabalVersion, myLibModule, defaultSourceDir ) -import Distribution.Client.Init.FileCreators - ( writeLicense, writeChangeLog, createDirectories, createLibHs, createMainHs - , createTestSuiteIfEligible, writeCabalFile ) -import Distribution.Client.Init.Prompt - ( prompt, promptYesNo, promptStr, promptList, maybePrompt - , promptListOptional ) -import Distribution.Client.Init.Utils - ( eligibleForTestSuite, message ) -import Distribution.Client.Init.Types - ( InitFlags(..), PackageType(..), Category(..) - , displayPackageType ) -import Distribution.Client.Init.Heuristics - ( guessPackageName, guessAuthorNameMail, guessMainFileCandidates, - SourceFileEntry(..), - scanForModules, neededBuildPrograms ) - -import Distribution.Simple.Flag - ( maybeToFlag ) -import Distribution.Simple.Setup - ( Flag(..), flagToMaybe ) -import Distribution.Simple.Configure - ( getInstalledPackages ) -import Distribution.Simple.Compiler - ( PackageDBStack, Compiler ) -import Distribution.Simple.Program - ( ProgramDb ) -import Distribution.Simple.PackageIndex - ( InstalledPackageIndex, moduleNameIndex ) - -import Distribution.Solver.Types.PackageIndex - ( elemByPackageName ) - -import Distribution.Client.IndexUtils - ( getSourcePackages ) -import Distribution.Client.Types - ( SourcePackageDb(..) ) -import Distribution.Client.Setup - ( RepoContext(..) ) - -initCabal :: Verbosity - -> PackageDBStack - -> RepoContext - -> Compiler - -> ProgramDb - -> InitFlags - -> IO () -initCabal verbosity packageDBs repoCtxt comp progdb initFlags = do - - installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb - sourcePkgDb <- getSourcePackages verbosity repoCtxt - - hSetBuffering stdout NoBuffering - - initFlags' <- extendFlags installedPkgIndex sourcePkgDb initFlags - - case license initFlags' of - Flag SPDX.NONE -> return () - _ -> writeLicense initFlags' - writeChangeLog initFlags' - createDirectories (sourceDirs initFlags') - createLibHs initFlags' - createDirectories (applicationDirs initFlags') - createMainHs initFlags' - createTestSuiteIfEligible initFlags' - success <- writeCabalFile initFlags' - - when success $ generateWarnings initFlags' - ---------------------------------------------------------------------------- --- Flag acquisition ----------------------------------------------------- ---------------------------------------------------------------------------- - --- | Fill in more details in InitFlags by guessing, discovering, or prompting --- the user. -extendFlags :: InstalledPackageIndex -> SourcePackageDb -> InitFlags -> IO InitFlags -extendFlags pkgIx sourcePkgDb = - getSimpleProject - >=> getLibOrExec - >=> getCabalVersion - >=> getPackageName sourcePkgDb - >=> getVersion - >=> getLicense - >=> getAuthorInfo - >=> getHomepage - >=> getSynopsis - >=> getCategory - >=> getExtraSourceFiles - >=> getAppDir - >=> getSrcDir - >=> getGenTests - >=> getTestDir - >=> getLanguage - >=> getGenComments - >=> getModulesBuildToolsAndDeps pkgIx - --- | Combine two actions which may return a value, preferring the first. That --- is, run the second action only if the first doesn't return a value. -infixr 1 ?>> -(?>>) :: IO (Maybe a) -> IO (Maybe a) -> IO (Maybe a) -f ?>> g = do - ma <- f - if isJust ma - then return ma - else g - --- | Ask if a simple project with sensible defaults should be created. -getSimpleProject :: InitFlags -> IO InitFlags -getSimpleProject flags = do - simpleProj <- return (flagToMaybe $ simpleProject flags) - ?>> maybePrompt flags - (promptYesNo - "Should I generate a simple project with sensible defaults" - (Just True)) - return $ case maybeToFlag simpleProj of - Flag True -> - flags { interactive = Flag False - , simpleProject = Flag True - , packageType = Flag LibraryAndExecutable - , cabalVersion = Flag defaultCabalVersion - } - simpleProjFlag@_ -> - flags { simpleProject = simpleProjFlag } - - --- | Get the version of the cabal spec to use. --- --- The spec version can be specified by the InitFlags cabalVersion field. If --- none is specified then the user is prompted to pick from a list of --- supported versions (see code below). -getCabalVersion :: InitFlags -> IO InitFlags -getCabalVersion flags = do - cabVer <- return (flagToMaybe $ cabalVersion flags) - ?>> maybePrompt flags (either (const defaultCabalVersion) id `fmap` - promptList "Please choose version of the Cabal specification to use" - [CabalSpecV1_10, CabalSpecV2_0, CabalSpecV2_2, CabalSpecV2_4, CabalSpecV3_0] - (Just defaultCabalVersion) displayCabalVersion False) - ?>> return (Just defaultCabalVersion) - - return $ flags { cabalVersion = maybeToFlag cabVer } - - where - displayCabalVersion :: CabalSpecVersion -> String - displayCabalVersion v = case v of - CabalSpecV1_10 -> "1.10 (legacy)" - CabalSpecV2_0 -> "2.0 (+ support for Backpack, internal sub-libs, '^>=' operator)" - CabalSpecV2_2 -> "2.2 (+ support for 'common', 'elif', redundant commas, SPDX)" - CabalSpecV2_4 -> "2.4 (+ support for '**' globbing)" - CabalSpecV3_0 -> "3.0 (+ set notation for ==, common stanzas in ifs, more redundant commas, better pkgconfig-depends)" - _ -> showCabalSpecVersion v - - - --- | Get the package name: use the package directory (supplied, or the current --- directory by default) as a guess. It looks at the SourcePackageDb to avoid --- using an existing package name. -getPackageName :: SourcePackageDb -> InitFlags -> IO InitFlags -getPackageName sourcePkgDb flags = do - guess <- traverse guessPackageName (flagToMaybe $ packageDir flags) - ?>> Just `fmap` (getCurrentDirectory >>= guessPackageName) - - let guess' | isPkgRegistered guess = Nothing - | otherwise = guess - - pkgName' <- return (flagToMaybe $ packageName flags) - ?>> maybePrompt flags (prompt "Package name" guess') - ?>> return guess' - - chooseAgain <- if isPkgRegistered pkgName' - then promptYesNo promptOtherNameMsg (Just True) - else return False - - if chooseAgain - then getPackageName sourcePkgDb flags - else return $ flags { packageName = maybeToFlag pkgName' } - - where - isPkgRegistered (Just pkg) = elemByPackageName (packageIndex sourcePkgDb) pkg - isPkgRegistered Nothing = False - - promptOtherNameMsg = "This package name is already used by another " ++ - "package on hackage. Do you want to choose a " ++ - "different name" - --- | Package version: use 0.1.0.0 as a last resort, but try prompting the user --- if possible. -getVersion :: InitFlags -> IO InitFlags -getVersion flags = do - let v = Just $ mkVersion [0,1,0,0] - v' <- return (flagToMaybe $ version flags) - ?>> maybePrompt flags (prompt "Package version" v) - ?>> return v - return $ flags { version = maybeToFlag v' } - --- | Choose a license for the package. --- --- The license can come from Initflags (license field), if it is not present --- then prompt the user from a predefined list of licenses. -getLicense :: InitFlags -> IO InitFlags -getLicense flags = do - elic <- return (fmap Right $ flagToMaybe $ license flags) - ?>> maybePrompt flags (promptList "Please choose a license" listedLicenses (Just SPDX.NONE) prettyShow True) - - case elic of - Nothing -> return flags { license = NoFlag } - Just (Right lic) -> return flags { license = Flag lic } - Just (Left str) -> case eitherParsec str of - Right lic -> return flags { license = Flag lic } - -- on error, loop - Left err -> do - putStrLn "The license must be a valid SPDX expression." - putStrLn err - getLicense flags - where - -- perfectly we'll have this and writeLicense (in FileCreators) - -- in a single file - listedLicenses = - SPDX.NONE : - map (\lid -> SPDX.License (SPDX.ELicense (SPDX.ELicenseId lid) Nothing)) - [ SPDX.BSD_2_Clause - , SPDX.BSD_3_Clause - , SPDX.Apache_2_0 - , SPDX.MIT - , SPDX.MPL_2_0 - , SPDX.ISC - - , SPDX.GPL_2_0_only - , SPDX.GPL_3_0_only - , SPDX.LGPL_2_1_only - , SPDX.LGPL_3_0_only - , SPDX.AGPL_3_0_only - - , SPDX.GPL_2_0_or_later - , SPDX.GPL_3_0_or_later - , SPDX.LGPL_2_1_or_later - , SPDX.LGPL_3_0_or_later - , SPDX.AGPL_3_0_or_later - ] - --- | The author's name and email. Prompt, or try to guess from an existing --- darcs repo. -getAuthorInfo :: InitFlags -> IO InitFlags -getAuthorInfo flags = do - (authorName, authorEmail) <- - (flagToMaybe *** flagToMaybe) `fmap` guessAuthorNameMail - authorName' <- return (flagToMaybe $ author flags) - ?>> maybePrompt flags (promptStr "Author name" authorName) - ?>> return authorName - - authorEmail' <- return (flagToMaybe $ email flags) - ?>> maybePrompt flags (promptStr "Maintainer email" authorEmail) - ?>> return authorEmail - - return $ flags { author = maybeToFlag authorName' - , email = maybeToFlag authorEmail' - } - --- | Prompt for a homepage URL for the package. -getHomepage :: InitFlags -> IO InitFlags -getHomepage flags = do - hp <- queryHomepage - hp' <- return (flagToMaybe $ homepage flags) - ?>> maybePrompt flags (promptStr "Project homepage URL" hp) - ?>> return hp - - return $ flags { homepage = maybeToFlag hp' } - --- | Right now this does nothing, but it could be changed to do some --- intelligent guessing. -queryHomepage :: IO (Maybe String) -queryHomepage = return Nothing -- get default remote darcs repo? - --- | Prompt for a project synopsis. -getSynopsis :: InitFlags -> IO InitFlags -getSynopsis flags = do - syn <- return (flagToMaybe $ synopsis flags) - ?>> maybePrompt flags (promptStr "Project synopsis" Nothing) - - return $ flags { synopsis = maybeToFlag syn } - --- | Prompt for a package category. --- Note that it should be possible to do some smarter guessing here too, i.e. --- look at the name of the top level source directory. -getCategory :: InitFlags -> IO InitFlags -getCategory flags = do - cat <- return (flagToMaybe $ category flags) - ?>> fmap join (maybePrompt flags - (promptListOptional "Project category" [Codec ..])) - return $ flags { category = maybeToFlag cat } - --- | Try to guess extra source files (don't prompt the user). -getExtraSourceFiles :: InitFlags -> IO InitFlags -getExtraSourceFiles flags = do - extraSrcFiles <- return (extraSrc flags) - ?>> Just `fmap` guessExtraSourceFiles flags - - return $ flags { extraSrc = extraSrcFiles } - -defaultChangeLog :: FilePath -defaultChangeLog = "CHANGELOG.md" - --- | Try to guess things to include in the extra-source-files field. --- For now, we just look for things in the root directory named --- 'readme', 'changes', or 'changelog', with any sort of --- capitalization and any extension. -guessExtraSourceFiles :: InitFlags -> IO [FilePath] -guessExtraSourceFiles flags = do - dir <- - maybe getCurrentDirectory return . flagToMaybe $ packageDir flags - files <- getDirectoryContents dir - let extraFiles = filter isExtra files - if any isLikeChangeLog extraFiles - then return extraFiles - else return (defaultChangeLog : extraFiles) - - where - isExtra = likeFileNameBase ("README" : changeLogLikeBases) - isLikeChangeLog = likeFileNameBase changeLogLikeBases - likeFileNameBase candidates = (`elem` candidates) . map toUpper . takeBaseName - changeLogLikeBases = ["CHANGES", "CHANGELOG"] - --- | Ask whether the project builds a library or executable. -getLibOrExec :: InitFlags -> IO InitFlags -getLibOrExec flags = do - pkgType <- return (flagToMaybe $ packageType flags) - ?>> maybePrompt flags (either (const Executable) id `fmap` - promptList "What does the package build" - [Executable, Library, LibraryAndExecutable] - Nothing displayPackageType False) - ?>> return (Just Executable) - - -- If this package contains an executable, get the main file name. - mainFile <- if pkgType == Just Library then return Nothing else - getMainFile flags - - return $ flags { packageType = maybeToFlag pkgType - , mainIs = maybeToFlag mainFile - } - - --- | Try to guess the main file of the executable, and prompt the user to choose --- one of them. Top-level modules including the word 'Main' in the file name --- will be candidates, and shorter filenames will be preferred. -getMainFile :: InitFlags -> IO (Maybe FilePath) -getMainFile flags = - return (flagToMaybe $ mainIs flags) - ?>> do - candidates <- guessMainFileCandidates flags - let showCandidate = either (++" (does not yet exist, but will be created)") id - defaultFile = listToMaybe candidates - maybePrompt flags (either id (either id id) `fmap` - promptList "What is the main module of the executable" - candidates - defaultFile showCandidate True) - ?>> return (fmap (either id id) defaultFile) - --- | Ask if a test suite should be generated for the library. -getGenTests :: InitFlags -> IO InitFlags -getGenTests flags = do - genTests <- return (flagToMaybe $ initializeTestSuite flags) - -- Only generate a test suite if the package contains a library. - ?>> if (packageType flags) == Flag Executable then return (Just False) else return Nothing - ?>> maybePrompt flags - (promptYesNo - "Should I generate a test suite for the library" - (Just True)) - return $ flags { initializeTestSuite = maybeToFlag genTests } - --- | Ask for the test suite root directory. -getTestDir :: InitFlags -> IO InitFlags -getTestDir flags = do - dirs <- return (testDirs flags) - -- Only need testDirs when test suite generation is enabled. - ?>> if not (eligibleForTestSuite flags) then return (Just []) else return Nothing - ?>> fmap (fmap ((:[]) . either id id)) (maybePrompt - flags - (promptList "Test directory" ["test"] (Just "test") id True)) - - return $ flags { testDirs = dirs } - --- | Ask for the Haskell base language of the package. -getLanguage :: InitFlags -> IO InitFlags -getLanguage flags = do - lang <- return (flagToMaybe $ language flags) - ?>> maybePrompt flags - (either UnknownLanguage id `fmap` - promptList "What base language is the package written in" - [Haskell2010, Haskell98] - (Just Haskell2010) prettyShow True) - ?>> return (Just Haskell2010) - - if invalidLanguage lang - then putStrLn invalidOtherLanguageMsg >> getLanguage flags - else return $ flags { language = maybeToFlag lang } - - where - invalidLanguage (Just (UnknownLanguage t)) = any (not . isAlphaNum) t - invalidLanguage _ = False - - invalidOtherLanguageMsg = "\nThe language must be alphanumeric. " ++ - "Please enter a different language." - --- | Ask whether to generate explanatory comments. -getGenComments :: InitFlags -> IO InitFlags -getGenComments flags = do - genComments <- return (not <$> flagToMaybe (noComments flags)) - ?>> maybePrompt flags (promptYesNo promptMsg (Just False)) - ?>> return (Just False) - return $ flags { noComments = maybeToFlag (fmap not genComments) } - where - promptMsg = "Add informative comments to each field in the cabal file (y/n)" - --- | Ask for the application root directory. -getAppDir :: InitFlags -> IO InitFlags -getAppDir flags = do - appDirs <- - return (applicationDirs flags) - ?>> noAppDirIfLibraryOnly - ?>> guessAppDir flags - ?>> promptUserForApplicationDir - ?>> setDefault - return $ flags { applicationDirs = appDirs } - - where - -- If the packageType==Library, then there is no application dir. - noAppDirIfLibraryOnly :: IO (Maybe [String]) - noAppDirIfLibraryOnly = - if (packageType flags) == Flag Library - then return (Just []) - else return Nothing - - -- Set the default application directory. - setDefault :: IO (Maybe [String]) - setDefault = pure (Just [defaultApplicationDir]) - - -- Prompt the user for the application directory (defaulting to "app"). - -- Returns 'Nothing' if in non-interactive mode, otherwise will always - -- return a 'Just' value ('Just []' if no separate application directory). - promptUserForApplicationDir :: IO (Maybe [String]) - promptUserForApplicationDir = fmap (either (:[]) id) <$> maybePrompt - flags - (promptList - ("Application " ++ mainFile ++ "directory") - [[defaultApplicationDir], ["src-exe"], []] - (Just [defaultApplicationDir]) - showOption True) - - showOption :: [String] -> String - showOption [] = "(none)" - showOption (x:_) = x - - -- The name - mainFile :: String - mainFile = case mainIs flags of - Flag mainPath -> "(" ++ mainPath ++ ") " - _ -> "" - --- | Try to guess app directory. Could try harder; for the --- moment just looks to see whether there is a directory called 'app'. -guessAppDir :: InitFlags -> IO (Maybe [String]) -guessAppDir flags = do - dir <- maybe getCurrentDirectory return . flagToMaybe $ packageDir flags - appIsDir <- doesDirectoryExist (dir "app") - return $ if appIsDir - then Just ["app"] - else Nothing - --- | Ask for the source (library) root directory. -getSrcDir :: InitFlags -> IO InitFlags -getSrcDir flags = do - srcDirs <- - return (sourceDirs flags) - ?>> noSourceDirIfExecutableOnly - ?>> guessSourceDir flags - ?>> promptUserForSourceDir - ?>> setDefault - - return $ flags { sourceDirs = srcDirs } - - where - -- If the packageType==Executable, then there is no source dir. - noSourceDirIfExecutableOnly :: IO (Maybe [String]) - noSourceDirIfExecutableOnly = - if (packageType flags) == Flag Executable - then return (Just []) - else return Nothing - - -- Set the default source directory. - setDefault :: IO (Maybe [String]) - setDefault = pure (Just [defaultSourceDir]) - - -- Prompt the user for the source directory (defaulting to "app"). - -- Returns 'Nothing' if in non-interactive mode, otherwise will always - -- return a 'Just' value ('Just []' if no separate application directory). - promptUserForSourceDir :: IO (Maybe [String]) - promptUserForSourceDir = fmap (either (:[]) id) <$> maybePrompt - flags - (promptList - ("Library source directory") - [[defaultSourceDir], ["lib"], ["src-lib"], []] - (Just [defaultSourceDir]) - showOption True) - - showOption :: [String] -> String - showOption [] = "(none)" - showOption (x:_) = x - - --- | Try to guess source directory. Could try harder; for the --- moment just looks to see whether there is a directory called 'src'. -guessSourceDir :: InitFlags -> IO (Maybe [String]) -guessSourceDir flags = do - dir <- - maybe getCurrentDirectory return . flagToMaybe $ packageDir flags - srcIsDir <- doesDirectoryExist (dir "src") - return $ if srcIsDir - then Just ["src"] - else Nothing - --- | Check whether a potential source file is located in one of the --- source directories. -isSourceFile :: Maybe [FilePath] -> SourceFileEntry -> Bool -isSourceFile Nothing sf = isSourceFile (Just ["."]) sf -isSourceFile (Just srcDirs) sf = any (equalFilePath (relativeSourcePath sf)) srcDirs - --- | Get the list of exposed modules and extra tools needed to build them. -getModulesBuildToolsAndDeps :: InstalledPackageIndex -> InitFlags -> IO InitFlags -getModulesBuildToolsAndDeps pkgIx flags = do - dir <- maybe getCurrentDirectory return . flagToMaybe $ packageDir flags - - sourceFiles0 <- scanForModules dir - - let sourceFiles = filter (isSourceFile (sourceDirs flags)) sourceFiles0 - - Just mods <- return (exposedModules flags) - ?>> (return . Just . map moduleName $ sourceFiles) - - tools <- return (buildTools flags) - ?>> (return . Just . neededBuildPrograms $ sourceFiles) - - deps <- return (dependencies flags) - ?>> Just <$> importsToDeps flags - (fromString "Prelude" : -- to ensure we get base as a dep - ( nub -- only need to consider each imported package once - . filter (`notElem` mods) -- don't consider modules from - -- this package itself - . concatMap imports - $ sourceFiles - ) - ) - pkgIx - - exts <- return (otherExts flags) - ?>> (return . Just . nub . concatMap extensions $ sourceFiles) - - -- If we're initializing a library and there were no modules discovered - -- then create an empty 'MyLib' module. - -- This gets a little tricky when 'sourceDirs' == 'applicationDirs' because - -- then the executable needs to set 'other-modules: MyLib' or else the build - -- fails. - let (finalModsList, otherMods) = case (packageType flags, mods) of - - -- For an executable leave things as they are. - (Flag Executable, _) -> (mods, otherModules flags) - - -- If a non-empty module list exists don't change anything. - (_, (_:_)) -> (mods, otherModules flags) - - -- Library only: 'MyLib' in 'other-modules' only. - (Flag Library, _) -> ([myLibModule], Nothing) - - -- For a 'LibraryAndExecutable' we need to have special handling. - -- If we don't have a module list (Nothing or empty), then create a Lib. - (_, []) -> - if sourceDirs flags == applicationDirs flags - then ([myLibModule], Just [myLibModule]) - else ([myLibModule], Nothing) - - return $ flags { exposedModules = Just finalModsList - , otherModules = otherMods - , buildTools = tools - , dependencies = deps - , otherExts = exts - } - --- | Given a list of imported modules, retrieve the list of dependencies that --- provide those modules. -importsToDeps :: InitFlags -> [ModuleName] -> InstalledPackageIndex -> IO [P.Dependency] -importsToDeps flags mods pkgIx = do - - let modMap :: M.Map ModuleName [InstalledPackageInfo] - modMap = M.map (filter exposed) $ moduleNameIndex pkgIx - - modDeps :: [(ModuleName, Maybe [InstalledPackageInfo])] - modDeps = map (id &&& flip M.lookup modMap) mods - - message flags "\nGuessing dependencies..." - nub . catMaybes <$> traverse (chooseDep flags) modDeps - --- Given a module and a list of installed packages providing it, --- choose a dependency (i.e. package + version range) to use for that --- module. -chooseDep :: InitFlags -> (ModuleName, Maybe [InstalledPackageInfo]) - -> IO (Maybe P.Dependency) - -chooseDep flags (m, Nothing) - = message flags ("\nWarning: no package found providing " ++ prettyShow m ++ ".") - >> return Nothing - -chooseDep flags (m, Just []) - = message flags ("\nWarning: no package found providing " ++ prettyShow m ++ ".") - >> return Nothing - - -- We found some packages: group them by name. -chooseDep flags (m, Just ps) - = case pkgGroups of - -- if there's only one group, i.e. multiple versions of a single package, - -- we make it into a dependency, choosing the latest-ish version (see toDep). - [grp] -> Just <$> toDep grp - -- otherwise, we refuse to choose between different packages and make the user - -- do it. - grps -> do message flags ("\nWarning: multiple packages found providing " - ++ prettyShow m - ++ ": " ++ intercalate ", " (fmap (prettyShow . P.pkgName . NE.head) grps)) - message flags "You will need to pick one and manually add it to the Build-depends: field." - return Nothing - where - pkgGroups = NE.groupBy ((==) `on` P.pkgName) (map P.packageId ps) - - desugar = maybe True (< CabalSpecV2_0) $ flagToMaybe (cabalVersion flags) - - -- Given a list of available versions of the same package, pick a dependency. - toDep :: NonEmpty P.PackageIdentifier -> IO P.Dependency - - -- If only one version, easy. We change e.g. 0.4.2 into 0.4.* - toDep (pid:|[]) = return $ P.Dependency (P.pkgName pid) (pvpize desugar . P.pkgVersion $ pid) P.mainLibSet --TODO sublibraries - - -- Otherwise, choose the latest version and issue a warning. - toDep pids = do - message flags ("\nWarning: multiple versions of " ++ prettyShow (P.pkgName . NE.head $ pids) ++ " provide " ++ prettyShow m ++ ", choosing the latest.") - return $ P.Dependency (P.pkgName . NE.head $ pids) - (pvpize desugar . maximum . fmap P.pkgVersion $ pids) - P.mainLibSet --TODO take into account sublibraries - --- | Given a version, return an API-compatible (according to PVP) version range. --- --- If the boolean argument denotes whether to use a desugared --- representation (if 'True') or the new-style @^>=@-form (if --- 'False'). --- --- Example: @pvpize True (mkVersion [0,4,1])@ produces the version range @>= 0.4 && < 0.5@ (which is the --- same as @0.4.*@). -pvpize :: Bool -> Version -> VersionRange -pvpize False v = majorBoundVersion v -pvpize True v = orLaterVersion v' - `intersectVersionRanges` - earlierVersion (incVersion 1 v') - where v' = alterVersion (take 2) v - --- | Increment the nth version component (counting from 0). -incVersion :: Int -> Version -> Version -incVersion n = alterVersion (incVersion' n) - where - incVersion' 0 [] = [1] - incVersion' 0 (v:_) = [v+1] - incVersion' m [] = replicate m 0 ++ [1] - incVersion' m (v:vs) = v : incVersion' (m-1) vs - --- | Generate warnings for missing fields etc. -generateWarnings :: InitFlags -> IO () -generateWarnings flags = do - message flags "" - when (synopsis flags `elem` [NoFlag, Flag ""]) - (message flags "Warning: no synopsis given. You should edit the .cabal file and add one.") - - message flags "You may want to edit the .cabal file and add a Description field." diff --git a/cabal/cabal-install/Distribution/Client/Init/Defaults.hs b/cabal/cabal-install/Distribution/Client/Init/Defaults.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Init/Defaults.hs +++ /dev/null @@ -1,41 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Init.Defaults --- Copyright : (c) Brent Yorgey 2009 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- Default values to use in cabal init (if not specified in config/flags). --- ------------------------------------------------------------------------------ - -module Distribution.Client.Init.Defaults ( - defaultApplicationDir - , defaultSourceDir - , defaultCabalVersion - , myLibModule - ) where - -import Prelude (String) - -import Distribution.ModuleName - ( ModuleName ) -- And for the Text instance -import qualified Distribution.ModuleName as ModuleName - ( fromString ) -import Distribution.CabalSpecVersion - ( CabalSpecVersion (..)) - -defaultApplicationDir :: String -defaultApplicationDir = "app" - -defaultSourceDir :: String -defaultSourceDir = "src" - -defaultCabalVersion :: CabalSpecVersion -defaultCabalVersion = CabalSpecV2_4 - -myLibModule :: ModuleName -myLibModule = ModuleName.fromString "MyLib" diff --git a/cabal/cabal-install/Distribution/Client/Init/FileCreators.hs b/cabal/cabal-install/Distribution/Client/Init/FileCreators.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Init/FileCreators.hs +++ /dev/null @@ -1,650 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Init.FileCreators --- Copyright : (c) Brent Yorgey 2009 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- Functions to create files during 'cabal init'. --- ------------------------------------------------------------------------------ - -module Distribution.Client.Init.FileCreators ( - - -- * Commands - writeLicense - , writeChangeLog - , createDirectories - , createLibHs - , createMainHs - , createTestSuiteIfEligible - , writeCabalFile - - -- * For testing - , generateCabalFile - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude hiding (empty) - -import System.FilePath - ( (), (<.>), takeExtension ) - -import Distribution.Types.Dependency -import Distribution.Types.VersionRange - -import Data.Time - ( getCurrentTime, utcToLocalTime, toGregorian, localDay, getCurrentTimeZone ) -import System.Directory - ( getCurrentDirectory, doesFileExist, copyFile - , createDirectoryIfMissing ) - -import Text.PrettyPrint hiding ((<>), mode, cat) - -import Distribution.Client.Init.Defaults - ( defaultCabalVersion, myLibModule ) -import Distribution.Client.Init.Licenses - ( bsd2, bsd3, gplv2, gplv3, lgpl21, lgpl3, agplv3, apache20, mit, mpl20, isc ) -import Distribution.Client.Init.Utils - ( eligibleForTestSuite, message ) -import Distribution.Client.Init.Types - ( InitFlags(..), BuildType(..), PackageType(..) ) - -import Distribution.CabalSpecVersion -import Distribution.Compat.Newtype - ( Newtype ) -import Distribution.Fields.Field - ( FieldName ) -import Distribution.License - ( licenseFromSPDX ) -import qualified Distribution.ModuleName as ModuleName - ( toFilePath ) -import Distribution.FieldGrammar.Newtypes - ( SpecVersion(..) ) -import Distribution.PackageDescription.FieldGrammar - ( formatDependencyList, formatExposedModules, formatHsSourceDirs, - formatOtherExtensions, formatOtherModules, formatExtraSourceFiles ) -import Distribution.Simple.Flag - ( maybeToFlag ) -import Distribution.Simple.Setup - ( Flag(..), flagToMaybe ) -import Distribution.Simple.Utils - ( toUTF8BS ) -import Distribution.Fields.Pretty - ( PrettyField(..), showFields' ) - -import qualified Distribution.SPDX as SPDX - - ---------------------------------------------------------------------------- --- File generation ------------------------------------------------------ ---------------------------------------------------------------------------- - --- | Write the LICENSE file, as specified in the InitFlags license field. --- --- For licences that contain the author's name(s), the values are taken --- from the 'authors' field of 'InitFlags', and if not specified will --- be the string "???". --- --- If the license type is unknown no license file will be created and --- a warning will be raised. -writeLicense :: InitFlags -> IO () -writeLicense flags = do - message flags "\nGenerating LICENSE..." - year <- show <$> getCurrentYear - let authors = fromMaybe "???" . flagToMaybe . author $ flags - let isSimpleLicense :: SPDX.License -> Maybe SPDX.LicenseId - isSimpleLicense (SPDX.License (SPDX.ELicense (SPDX.ELicenseId lid) Nothing)) = Just lid - isSimpleLicense _ = Nothing - let licenseFile = - case flagToMaybe (license flags) >>= isSimpleLicense of - Just SPDX.BSD_2_Clause -> Just $ bsd2 authors year - Just SPDX.BSD_3_Clause -> Just $ bsd3 authors year - Just SPDX.Apache_2_0 -> Just apache20 - Just SPDX.MIT -> Just $ mit authors year - Just SPDX.MPL_2_0 -> Just mpl20 - Just SPDX.ISC -> Just $ isc authors year - - -- GNU license come in "only" and "or-later" flavours - -- license file used are the same. - Just SPDX.GPL_2_0_only -> Just gplv2 - Just SPDX.GPL_3_0_only -> Just gplv3 - Just SPDX.LGPL_2_1_only -> Just lgpl21 - Just SPDX.LGPL_3_0_only -> Just lgpl3 - Just SPDX.AGPL_3_0_only -> Just agplv3 - - Just SPDX.GPL_2_0_or_later -> Just gplv2 - Just SPDX.GPL_3_0_or_later -> Just gplv3 - Just SPDX.LGPL_2_1_or_later -> Just lgpl21 - Just SPDX.LGPL_3_0_or_later -> Just lgpl3 - Just SPDX.AGPL_3_0_or_later -> Just agplv3 - - _ -> Nothing - - case licenseFile of - Just licenseText -> writeFileSafe flags "LICENSE" licenseText - Nothing -> message flags "Warning: unknown license type, you must put a copy in LICENSE yourself." - --- | Returns the current calendar year. -getCurrentYear :: IO Integer -getCurrentYear = do - u <- getCurrentTime - z <- getCurrentTimeZone - let l = utcToLocalTime z u - (y, _, _) = toGregorian $ localDay l - return y - -defaultChangeLog :: FilePath -defaultChangeLog = "CHANGELOG.md" - --- | Writes the changelog to the current directory. -writeChangeLog :: InitFlags -> IO () -writeChangeLog flags = when ((defaultChangeLog `elem`) $ fromMaybe [] (extraSrc flags)) $ do - message flags ("Generating "++ defaultChangeLog ++"...") - writeFileSafe flags defaultChangeLog changeLog - where - changeLog = unlines - [ "# Revision history for " ++ pname - , "" - , "## " ++ pver ++ " -- YYYY-mm-dd" - , "" - , "* First version. Released on an unsuspecting world." - ] - pname = maybe "" prettyShow $ flagToMaybe $ packageName flags - pver = maybe "" prettyShow $ flagToMaybe $ version flags - --- | Creates and writes the initialized .cabal file. --- --- Returns @False@ if no package name is specified, @True@ otherwise. -writeCabalFile :: InitFlags -> IO Bool -writeCabalFile flags@(InitFlags{packageName = NoFlag}) = do - message flags "Error: no package name provided." - return False -writeCabalFile flags@(InitFlags{packageName = Flag p}) = do - let cabalFileName = prettyShow p ++ ".cabal" - message flags $ "Generating " ++ cabalFileName ++ "..." - writeFileSafe flags cabalFileName (generateCabalFile cabalFileName flags) - return True - --- | Write a file \"safely\", backing up any existing version (unless --- the overwrite flag is set). -writeFileSafe :: InitFlags -> FilePath -> String -> IO () -writeFileSafe flags fileName content = do - moveExistingFile flags fileName - writeFile fileName content - --- | Create directories, if they were given, and don't already exist. -createDirectories :: Maybe [String] -> IO () -createDirectories mdirs = case mdirs of - Just dirs -> for_ dirs (createDirectoryIfMissing True) - Nothing -> return () - --- | Create MyLib.hs file, if its the only module in the liste. -createLibHs :: InitFlags -> IO () -createLibHs flags = when ((exposedModules flags) == Just [myLibModule]) $ do - let modFilePath = ModuleName.toFilePath myLibModule ++ ".hs" - case sourceDirs flags of - Just (srcPath:_) -> writeLibHs flags (srcPath modFilePath) - _ -> writeLibHs flags modFilePath - --- | Write a MyLib.hs file if it doesn't already exist. -writeLibHs :: InitFlags -> FilePath -> IO () -writeLibHs flags libPath = do - dir <- maybe getCurrentDirectory return (flagToMaybe $ packageDir flags) - let libFullPath = dir libPath - exists <- doesFileExist libFullPath - unless exists $ do - message flags $ "Generating " ++ libPath ++ "..." - writeFileSafe flags libFullPath myLibHs - --- | Default MyLib.hs file. Used when no Lib.hs exists. -myLibHs :: String -myLibHs = unlines - [ "module MyLib (someFunc) where" - , "" - , "someFunc :: IO ()" - , "someFunc = putStrLn \"someFunc\"" - ] - --- | Create Main.hs, but only if we are init'ing an executable and --- the mainIs flag has been provided. -createMainHs :: InitFlags -> IO () -createMainHs flags = - if hasMainHs flags then - case applicationDirs flags of - Just (appPath:_) -> writeMainHs flags (appPath mainFile) - _ -> writeMainHs flags mainFile - else return () - where - mainFile = case mainIs flags of - Flag x -> x - NoFlag -> error "createMainHs: no mainIs" - --- | Write a main file if it doesn't already exist. -writeMainHs :: InitFlags -> FilePath -> IO () -writeMainHs flags mainPath = do - dir <- maybe getCurrentDirectory return (flagToMaybe $ packageDir flags) - let mainFullPath = dir mainPath - exists <- doesFileExist mainFullPath - unless exists $ do - message flags $ "Generating " ++ mainPath ++ "..." - writeFileSafe flags mainFullPath (mainHs flags) - --- | Returns true if a main file exists. -hasMainHs :: InitFlags -> Bool -hasMainHs flags = case mainIs flags of - Flag _ -> (packageType flags == Flag Executable - || packageType flags == Flag LibraryAndExecutable) - _ -> False - --- | Default Main.(l)hs file. Used when no Main.(l)hs exists. --- --- If we are initializing a new 'LibraryAndExecutable' then import 'MyLib'. -mainHs :: InitFlags -> String -mainHs flags = (unlines . map prependPrefix) $ case packageType flags of - Flag LibraryAndExecutable -> - [ "module Main where" - , "" - , "import qualified MyLib (someFunc)" - , "" - , "main :: IO ()" - , "main = do" - , " putStrLn \"Hello, Haskell!\"" - , " MyLib.someFunc" - ] - _ -> - [ "module Main where" - , "" - , "main :: IO ()" - , "main = putStrLn \"Hello, Haskell!\"" - ] - where - prependPrefix :: String -> String - prependPrefix "" = "" - prependPrefix line - | isLiterate = "> " ++ line - | otherwise = line - isLiterate = case mainIs flags of - Flag mainPath -> takeExtension mainPath == ".lhs" - _ -> False - --- | Create a test suite for the package if eligible. -createTestSuiteIfEligible :: InitFlags -> IO () -createTestSuiteIfEligible flags = - when (eligibleForTestSuite flags) $ do - createDirectories (testDirs flags) - createTestHs flags - --- | The name of the test file to generate (if --tests is specified). -testFile :: String -testFile = "MyLibTest.hs" - --- | Create MyLibTest.hs, but only if we are init'ing a library and --- the initializeTestSuite flag has been set. --- --- It is up to the caller to verify that the package is eligible --- for test suite initialization (see eligibleForTestSuite). -createTestHs :: InitFlags -> IO () -createTestHs flags = - case testDirs flags of - Just (testPath:_) -> writeTestHs flags (testPath testFile) - _ -> writeMainHs flags testFile - --- | Write a test file. -writeTestHs :: InitFlags -> FilePath -> IO () -writeTestHs flags testPath = do - dir <- maybe getCurrentDirectory return (flagToMaybe $ packageDir flags) - let testFullPath = dir testPath - exists <- doesFileExist testFullPath - unless exists $ do - message flags $ "Generating " ++ testPath ++ "..." - writeFileSafe flags testFullPath testHs - --- | Default MyLibTest.hs file. -testHs :: String -testHs = unlines - [ "module Main (main) where" - , "" - , "main :: IO ()" - , "main = putStrLn \"Test suite not yet implemented.\"" - ] - - --- | Move an existing file, if there is one, and the overwrite flag is --- not set. -moveExistingFile :: InitFlags -> FilePath -> IO () -moveExistingFile flags fileName = - unless (overwrite flags == Flag True) $ do - e <- doesFileExist fileName - when e $ do - newName <- findNewName fileName - message flags $ "Warning: " ++ fileName ++ " already exists, backing up old version in " ++ newName - copyFile fileName newName - - --- | Given a file path find a new name for the file that does not --- already exist. -findNewName :: FilePath -> IO FilePath -findNewName oldName = findNewName' 0 - where - findNewName' :: Integer -> IO FilePath - findNewName' n = do - let newName = oldName <.> ("save" ++ show n) - e <- doesFileExist newName - if e then findNewName' (n+1) else return newName - - --- | Generate a .cabal file from an InitFlags structure. -generateCabalFile :: String -> InitFlags -> String -generateCabalFile fileName c = - showFields' annCommentLines postProcessFieldLines 4 $ catMaybes - [ fieldP "cabal-version" (Flag . SpecVersion $ specVer) - [] - False - - , field "name" (packageName c) - ["Initial package description '" ++ fileName ++ "' generated by", - "'cabal init'. For further documentation, see:", - " http://haskell.org/cabal/users-guide/", - "", - "The name of the package."] - True - - , field "version" (version c) - ["The package version.", - "See the Haskell package versioning policy (PVP) for standards", - "guiding when and how versions should be incremented.", - "https://pvp.haskell.org", - "PVP summary: +-+------- breaking API changes", - " | | +----- non-breaking API additions", - " | | | +--- code changes with no API change"] - True - - , fieldS "synopsis" (synopsis c) - ["A short (one-line) description of the package."] - True - - , fieldS "description" NoFlag - ["A longer description of the package."] - True - - , fieldS "homepage" (homepage c) - ["URL for the project homepage or repository."] - False - - , fieldS "bug-reports" NoFlag - ["A URL where users can report bugs."] - True - - , fieldS "license" licenseStr - ["The license under which the package is released."] - True - - , case license c of - NoFlag -> Nothing - Flag SPDX.NONE -> Nothing - _ -> fieldS "license-file" (Flag "LICENSE") - ["The file containing the license text."] - True - - , fieldS "author" (author c) - ["The package author(s)."] - True - - , fieldS "maintainer" (email c) - ["An email address to which users can send suggestions, bug reports, and patches."] - True - - , fieldS "copyright" NoFlag - ["A copyright notice."] - True - - , fieldS "category" (either id prettyShow `fmap` category c) - [] - True - - , fieldS "build-type" (if specVer >= CabalSpecV2_2 then NoFlag else Flag "Simple") - [] - False - - , fieldPAla "extra-source-files" formatExtraSourceFiles (maybeToFlag (extraSrc c)) - ["Extra files to be distributed with the package, such as examples or a README."] - True - ] - ++ - (case packageType c of - Flag Executable -> [executableStanza] - Flag Library -> [libraryStanza] - Flag LibraryAndExecutable -> [libraryStanza, executableStanza] - _ -> []) - ++ - if eligibleForTestSuite c then [testSuiteStanza] else [] - - where - specVer :: CabalSpecVersion - specVer = fromMaybe defaultCabalVersion $ flagToMaybe (cabalVersion c) - - licenseStr | specVer < CabalSpecV2_2 = prettyShow . licenseFromSPDX <$> license c - | otherwise = prettyShow <$> license c - - generateBuildInfo :: BuildType -> InitFlags -> [PrettyField FieldAnnotation] - generateBuildInfo buildType c' = catMaybes - [ fieldPAla "other-modules" formatOtherModules (maybeToFlag otherMods) - [ case buildType of - LibBuild -> "Modules included in this library but not exported." - ExecBuild -> "Modules included in this executable, other than Main."] - True - - , fieldPAla "other-extensions" formatOtherExtensions (maybeToFlag (otherExts c)) - ["LANGUAGE extensions used by modules in this package."] - True - - , fieldPAla "build-depends" formatDependencyList (maybeToFlag buildDependencies) - ["Other library packages from which modules are imported."] - True - - , fieldPAla "hs-source-dirs" formatHsSourceDirs - (maybeToFlag (case buildType of - LibBuild -> sourceDirs c - ExecBuild -> applicationDirs c)) - ["Directories containing source files."] - True - - , fieldS "build-tools" (listFieldS $ buildTools c) - ["Extra tools (e.g. alex, hsc2hs, ...) needed to build the source."] - False - - , field "default-language" (language c) - ["Base language which the package is written in."] - True - ] - -- Hack: Can't construct a 'Dependency' which is just 'packageName'(?). - where - buildDependencies :: Maybe [Dependency] - buildDependencies = (++ myLibDep) <$> dependencies c' - - myLibDep :: [Dependency] - myLibDep = if exposedModules c' == Just [myLibModule] && buildType == ExecBuild - then case packageName c' of - Flag pkgName -> - [mkDependency pkgName anyVersion mainLibSet] - _ -> [] - else [] - - -- Only include 'MyLib' in 'other-modules' of the executable. - otherModsFromFlag = otherModules c' - otherMods = if buildType == LibBuild && otherModsFromFlag == Just [myLibModule] - then Nothing - else otherModsFromFlag - - listFieldS :: Maybe [String] -> Flag String - listFieldS Nothing = NoFlag - listFieldS (Just []) = NoFlag - listFieldS (Just xs) = Flag . intercalate ", " $ xs - - -- | Construct a 'PrettyField' from a field that can be automatically - -- converted to a 'Doc' via 'display'. - field :: Pretty t - => FieldName - -> Flag t - -> [String] - -> Bool - -> Maybe (PrettyField FieldAnnotation) - field fieldName fieldContentsFlag = fieldS fieldName (prettyShow <$> fieldContentsFlag) - - -- | Construct a 'PrettyField' from a 'String' field. - fieldS :: FieldName -- ^ Name of the field - -> Flag String -- ^ Field contents - -> [String] -- ^ Comment to explain the field - -> Bool -- ^ Should the field be included (commented out) even if blank? - -> Maybe (PrettyField FieldAnnotation) - fieldS fieldName fieldContentsFlag = fieldD fieldName (text <$> fieldContentsFlag) - - -- | Construct a 'PrettyField' from a Flag which can be 'pretty'-ied. - fieldP :: Pretty a - => FieldName - -> Flag a - -> [String] - -> Bool - -> Maybe (PrettyField FieldAnnotation) - fieldP fieldName fieldContentsFlag fieldComments includeField = - fieldPAla fieldName Identity fieldContentsFlag fieldComments includeField - - -- | Construct a 'PrettyField' from a flag which can be 'pretty'-ied, wrapped in newtypeWrapper. - fieldPAla - :: (Pretty b, Newtype a b) - => FieldName - -> (a -> b) - -> Flag a - -> [String] - -> Bool - -> Maybe (PrettyField FieldAnnotation) - fieldPAla fieldName newtypeWrapper fieldContentsFlag fieldComments includeField = - fieldD fieldName (pretty . newtypeWrapper <$> fieldContentsFlag) fieldComments includeField - - -- | Construct a 'PrettyField' from a 'Doc' Flag. - fieldD :: FieldName -- ^ Name of the field - -> Flag Doc -- ^ Field contents - -> [String] -- ^ Comment to explain the field - -> Bool -- ^ Should the field be included (commented out) even if blank? - -> Maybe (PrettyField FieldAnnotation) - fieldD fieldName fieldContentsFlag fieldComments includeField = - case fieldContentsFlag of - NoFlag -> - -- If there is no content, optionally produce a commented out field. - fieldSEmptyContents fieldName fieldComments includeField - - Flag fieldContents -> - if isEmpty fieldContents - then - -- If the doc is empty, optionally produce a commented out field. - fieldSEmptyContents fieldName fieldComments includeField - else - -- If the doc is not empty, produce a field. - Just $ case (noComments c, minimal c) of - -- If the "--no-comments" flag is set, strip comments. - (Flag True, _) -> - fieldSWithContents fieldName fieldContents [] - -- If the "--minimal" flag is set, strip comments. - (_, Flag True) -> - fieldSWithContents fieldName fieldContents [] - -- Otherwise, include comments. - (_, _) -> - fieldSWithContents fieldName fieldContents fieldComments - - -- | Optionally produce a field with no content (depending on flags). - fieldSEmptyContents :: FieldName - -> [String] - -> Bool - -> Maybe (PrettyField FieldAnnotation) - fieldSEmptyContents fieldName fieldComments includeField - | not includeField || (minimal c == Flag True) = - Nothing - | otherwise = - Just (PrettyField (commentedOutWithComments fieldComments) fieldName empty) - - -- | Produce a field with content. - fieldSWithContents :: FieldName - -> Doc - -> [String] - -> PrettyField FieldAnnotation - fieldSWithContents fieldName fieldContents fieldComments = - PrettyField (withComments (map ("-- " ++) fieldComments)) fieldName fieldContents - - executableStanza :: PrettyField FieldAnnotation - executableStanza = PrettySection annNoComments (toUTF8BS "executable") [exeName] $ catMaybes - [ fieldS "main-is" (mainIs c) - [".hs or .lhs file containing the Main module."] - True - ] - ++ - generateBuildInfo ExecBuild c - where - exeName = text (maybe "" prettyShow . flagToMaybe $ packageName c) - - libraryStanza :: PrettyField FieldAnnotation - libraryStanza = PrettySection annNoComments (toUTF8BS "library") [] $ catMaybes - [ fieldPAla "exposed-modules" formatExposedModules (maybeToFlag (exposedModules c)) - ["Modules exported by the library."] - True - ] - ++ - generateBuildInfo LibBuild c - - - testSuiteStanza :: PrettyField FieldAnnotation - testSuiteStanza = PrettySection annNoComments (toUTF8BS "test-suite") [testSuiteName] $ catMaybes - [ field "default-language" (language c) - ["Base language which the package is written in."] - True - - , fieldS "type" (Flag "exitcode-stdio-1.0") - ["The interface type and version of the test suite."] - True - - , fieldPAla "hs-source-dirs" formatHsSourceDirs - (maybeToFlag (testDirs c)) - ["Directories containing source files."] - True - - , fieldS "main-is" (Flag testFile) - ["The entrypoint to the test suite."] - True - - , fieldPAla "build-depends" formatDependencyList (maybeToFlag (dependencies c)) - ["Test dependencies."] - True - ] - where - testSuiteName = - text (maybe "" ((++"-test") . prettyShow) . flagToMaybe $ packageName c) - --- | Annotations for cabal file PrettyField. -data FieldAnnotation = FieldAnnotation - { annCommentedOut :: Bool - -- ^ True iif the field and its contents should be commented out. - , annCommentLines :: [String] - -- ^ Comment lines to place before the field or section. - } - --- | A field annotation instructing the pretty printer to comment out the field --- and any contents, with no comments. -commentedOutWithComments :: [String] -> FieldAnnotation -commentedOutWithComments = FieldAnnotation True . map ("-- " ++) - --- | A field annotation with the specified comment lines. -withComments :: [String] -> FieldAnnotation -withComments = FieldAnnotation False - --- | A field annotation with no comments. -annNoComments :: FieldAnnotation -annNoComments = FieldAnnotation False [] - -postProcessFieldLines :: FieldAnnotation -> [String] -> [String] -postProcessFieldLines ann - | annCommentedOut ann = map ("-- " ++) - | otherwise = id diff --git a/cabal/cabal-install/Distribution/Client/Init/Heuristics.hs b/cabal/cabal-install/Distribution/Client/Init/Heuristics.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Init/Heuristics.hs +++ /dev/null @@ -1,392 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Init.Heuristics --- Copyright : (c) Benedikt Huber 2009 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- Heuristics for creating initial cabal files. --- ------------------------------------------------------------------------------ -module Distribution.Client.Init.Heuristics ( - guessPackageName, - scanForModules, SourceFileEntry(..), - neededBuildPrograms, - guessMainFileCandidates, - guessAuthorNameMail, - knownCategories, -) where - -import Prelude () -import Distribution.Client.Compat.Prelude -import Distribution.Utils.Generic (safeHead, safeTail, safeLast) - -import Distribution.Simple.Setup (Flag(..), flagToMaybe) -import Distribution.ModuleName - ( ModuleName, toFilePath ) -import qualified Distribution.Package as P -import qualified Distribution.PackageDescription as PD - ( category, packageDescription ) -import Distribution.Client.Utils - ( tryCanonicalizePath ) -import Language.Haskell.Extension ( Extension ) - -import Distribution.Solver.Types.PackageIndex - ( allPackagesByName ) -import Distribution.Solver.Types.SourcePackage - ( srcpkgDescription ) - -import Distribution.Client.Types ( SourcePackageDb(..) ) -import Data.Char ( isLower ) -import Data.List ( isInfixOf ) -import qualified Data.Set as Set ( fromList, toList ) -import System.Directory ( getCurrentDirectory, getDirectoryContents, - doesDirectoryExist, doesFileExist, getHomeDirectory, ) -import Distribution.Compat.Environment ( getEnvironment ) -import System.FilePath ( takeExtension, takeBaseName, dropExtension, - (), (<.>), splitDirectories, makeRelative ) - -import Distribution.Client.Init.Types ( InitFlags(..) ) -import Distribution.Client.Compat.Process ( readProcessWithExitCode ) - -import qualified Distribution.Utils.ShortText as ShortText - --- | Return a list of candidate main files for this executable: top-level --- modules including the word 'Main' in the file name. The list is sorted in --- order of preference, shorter file names are preferred. 'Right's are existing --- candidates and 'Left's are those that do not yet exist. -guessMainFileCandidates :: InitFlags -> IO [Either FilePath FilePath] -guessMainFileCandidates flags = do - dir <- - maybe getCurrentDirectory return (flagToMaybe $ packageDir flags) - files <- getDirectoryContents dir - let existingCandidates = filter isMain files - -- We always want to give the user at least one default choice. If either - -- Main.hs or Main.lhs has already been created, then we don't want to - -- suggest the other; however, if neither has been created, then we - -- suggest both. - newCandidates = - if any (`elem` existingCandidates) ["Main.hs", "Main.lhs"] - then [] - else ["Main.hs", "Main.lhs"] - candidates = - sortBy (\x y -> comparing (length . either id id) x y - `mappend` compare x y) - (map Left newCandidates ++ map Right existingCandidates) - return candidates - - where - isMain f = (isInfixOf "Main" f || isInfixOf "main" f) - && (isSuffixOf ".hs" f || isSuffixOf ".lhs" f) - --- | Guess the package name based on the given root directory. -guessPackageName :: FilePath -> IO P.PackageName -guessPackageName = liftM (P.mkPackageName . repair . fromMaybe "" . safeLast . splitDirectories) - . tryCanonicalizePath - where - -- Treat each span of non-alphanumeric characters as a hyphen. Each - -- hyphenated component of a package name must contain at least one - -- alphabetic character. An arbitrary character ('x') will be prepended if - -- this is not the case for the first component, and subsequent components - -- will simply be run together. For example, "1+2_foo-3" will become - -- "x12-foo3". - repair = repair' ('x' :) id - repair' invalid valid x = case dropWhile (not . isAlphaNum) x of - "" -> repairComponent "" - x' -> let (c, r) = first repairComponent $ break (not . isAlphaNum) x' - in c ++ repairRest r - where - repairComponent c | all isDigit c = invalid c - | otherwise = valid c - repairRest = repair' id ('-' :) - --- |Data type of source files found in the working directory -data SourceFileEntry = SourceFileEntry - { relativeSourcePath :: FilePath - , moduleName :: ModuleName - , fileExtension :: String - , imports :: [ModuleName] - , extensions :: [Extension] - } deriving Show - -sfToFileName :: FilePath -> SourceFileEntry -> FilePath -sfToFileName projectRoot (SourceFileEntry relPath m ext _ _) - = projectRoot relPath toFilePath m <.> ext - --- |Search for source files in the given directory --- and return pairs of guessed Haskell source path and --- module names. -scanForModules :: FilePath -> IO [SourceFileEntry] -scanForModules rootDir = scanForModulesIn rootDir rootDir - -scanForModulesIn :: FilePath -> FilePath -> IO [SourceFileEntry] -scanForModulesIn projectRoot srcRoot = scan srcRoot [] - where - scan dir hierarchy = do - entries <- getDirectoryContents (projectRoot dir) - (files, dirs) <- liftM partitionEithers (traverse (tagIsDir dir) entries) - let modules = catMaybes [ guessModuleName hierarchy file - | file <- files - , maybe False isUpper (safeHead file) ] - modules' <- traverse (findImportsAndExts projectRoot) modules - recMods <- traverse (scanRecursive dir hierarchy) dirs - return $ concat (modules' : recMods) - tagIsDir parent entry = do - isDir <- doesDirectoryExist (parent entry) - return $ (if isDir then Right else Left) entry - guessModuleName hierarchy entry - | takeBaseName entry == "Setup" = Nothing - | ext `elem` sourceExtensions = - SourceFileEntry <$> pure relRoot <*> modName <*> pure ext <*> pure [] <*> pure [] - | otherwise = Nothing - where - relRoot = makeRelative projectRoot srcRoot - unqualModName = dropExtension entry - modName = simpleParsec - $ intercalate "." . reverse $ (unqualModName : hierarchy) - ext = case takeExtension entry of '.':e -> e; e -> e - scanRecursive parent hierarchy entry - | maybe False isUpper (safeHead entry) = scan (parent entry) (entry : hierarchy) - | maybe False isLower (safeHead entry) && not (ignoreDir entry) = - scanForModulesIn projectRoot $ foldl () srcRoot (reverse (entry : hierarchy)) - | otherwise = return [] - ignoreDir ('.':_) = True - ignoreDir dir = dir `elem` ["dist", "_darcs"] - -findImportsAndExts :: FilePath -> SourceFileEntry -> IO SourceFileEntry -findImportsAndExts projectRoot sf = do - s <- readFile (sfToFileName projectRoot sf) - - let modules = mapMaybe - ( getModName - . drop 1 - . filter (not . null) - . dropWhile (/= "import") - . words - ) - . filter (not . ("--" `isPrefixOf`)) -- poor man's comment filtering - . lines - $ s - - -- TODO: We should probably make a better attempt at parsing - -- comments above. Unfortunately we can't use a full-fledged - -- Haskell parser since cabal's dependencies must be kept at a - -- minimum. - - -- A poor man's LANGUAGE pragma parser. - exts = mapMaybe simpleParsec - . concatMap getPragmas - . filter isLANGUAGEPragma - . map fst - . drop 1 - . takeWhile (not . null . snd) - . iterate (takeBraces . snd) - $ ("",s) - - takeBraces = break (== '}') . dropWhile (/= '{') - - isLANGUAGEPragma = ("{-# LANGUAGE " `isPrefixOf`) - - getPragmas = map trim . splitCommas . takeWhile (/= '#') . drop 13 - - splitCommas "" = [] - splitCommas xs = x : splitCommas (drop 1 y) - where (x,y) = break (==',') xs - - return sf { imports = modules - , extensions = exts - } - - where getModName :: [String] -> Maybe ModuleName - getModName [] = Nothing - getModName ("qualified":ws) = getModName ws - getModName (ms:_) = simpleParsec ms - - - --- Unfortunately we cannot use the version exported by Distribution.Simple.Program -knownSuffixHandlers :: [(String,String)] -knownSuffixHandlers = - [ ("gc", "greencard") - , ("chs", "chs") - , ("hsc", "hsc2hs") - , ("x", "alex") - , ("y", "happy") - , ("ly", "happy") - , ("cpphs", "cpp") - ] - -sourceExtensions :: [String] -sourceExtensions = "hs" : "lhs" : map fst knownSuffixHandlers - -neededBuildPrograms :: [SourceFileEntry] -> [String] -neededBuildPrograms entries = - [ handler - | ext <- nubSet (map fileExtension entries) - , handler <- maybeToList (lookup ext knownSuffixHandlers) - ] - --- | Guess author and email using darcs and git configuration options. Use --- the following in decreasing order of preference: --- --- 1. vcs env vars ($DARCS_EMAIL, $GIT_AUTHOR_*) --- 2. Local repo configs --- 3. Global vcs configs --- 4. The generic $EMAIL --- --- Name and email are processed separately, so the guess might end up being --- a name from DARCS_EMAIL and an email from git config. --- --- Darcs has preference, for tradition's sake. -guessAuthorNameMail :: IO (Flag String, Flag String) -guessAuthorNameMail = fmap authorGuessPure authorGuessIO - --- Ordered in increasing preference, since Flag-as-monoid is identical to --- Last. -authorGuessPure :: AuthorGuessIO -> AuthorGuess -authorGuessPure (AuthorGuessIO { authorGuessEnv = env - , authorGuessLocalDarcs = darcsLocalF - , authorGuessGlobalDarcs = darcsGlobalF - , authorGuessLocalGit = gitLocal - , authorGuessGlobalGit = gitGlobal }) - = mconcat - [ emailEnv env - , gitGlobal - , darcsCfg darcsGlobalF - , gitLocal - , darcsCfg darcsLocalF - , gitEnv env - , darcsEnv env - ] - -authorGuessIO :: IO AuthorGuessIO -authorGuessIO = AuthorGuessIO - <$> getEnvironment - <*> (maybeReadFile $ "_darcs" "prefs" "author") - <*> (maybeReadFile =<< liftM ( (".darcs" "author")) getHomeDirectory) - <*> gitCfg Local - <*> gitCfg Global - --- Types and functions used for guessing the author are now defined: - -type AuthorGuess = (Flag String, Flag String) -type Enviro = [(String, String)] -data GitLoc = Local | Global -data AuthorGuessIO = AuthorGuessIO { - authorGuessEnv :: Enviro, -- ^ Environment lookup table - authorGuessLocalDarcs :: (Maybe String), -- ^ Contents of local darcs author info - authorGuessGlobalDarcs :: (Maybe String), -- ^ Contents of global darcs author info - authorGuessLocalGit :: AuthorGuess, -- ^ Git config --local - authorGuessGlobalGit :: AuthorGuess -- ^ Git config --global - } - -darcsEnv :: Enviro -> AuthorGuess -darcsEnv = maybe mempty nameAndMail . lookup "DARCS_EMAIL" - -gitEnv :: Enviro -> AuthorGuess -gitEnv env = (name, mail) - where - name = maybeFlag "GIT_AUTHOR_NAME" env - mail = maybeFlag "GIT_AUTHOR_EMAIL" env - -darcsCfg :: Maybe String -> AuthorGuess -darcsCfg = maybe mempty nameAndMail - -emailEnv :: Enviro -> AuthorGuess -emailEnv env = (mempty, mail) - where - mail = maybeFlag "EMAIL" env - -gitCfg :: GitLoc -> IO AuthorGuess -gitCfg which = do - name <- gitVar which "user.name" - mail <- gitVar which "user.email" - return (name, mail) - -gitVar :: GitLoc -> String -> IO (Flag String) -gitVar which = fmap happyOutput . gitConfigQuery which - -happyOutput :: (ExitCode, a, t) -> Flag a -happyOutput v = case v of - (ExitSuccess, s, _) -> Flag s - _ -> mempty - -gitConfigQuery :: GitLoc -> String -> IO (ExitCode, String, String) -gitConfigQuery which key = - fmap trim' $ readProcessWithExitCode "git" ["config", w, key] "" - where - w = case which of - Local -> "--local" - Global -> "--global" - trim' (a, b, c) = (a, trim b, c) - -maybeFlag :: String -> Enviro -> Flag String -maybeFlag k = maybe mempty Flag . lookup k - --- | Read the first non-comment, non-trivial line of a file, if it exists -maybeReadFile :: String -> IO (Maybe String) -maybeReadFile f = do - exists <- doesFileExist f - if exists - then fmap getFirstLine $ readFile f - else return Nothing - where - getFirstLine content = - let nontrivialLines = dropWhile (\l -> (null l) || ("#" `isPrefixOf` l)) . lines $ content - in case nontrivialLines of - [] -> Nothing - (l:_) -> Just l - --- |Get list of categories used in Hackage. NOTE: Very slow, needs to be cached -knownCategories :: SourcePackageDb -> [String] -knownCategories (SourcePackageDb sourcePkgIndex _) = nubSet - [ cat | pkg <- maybeToList . safeHead =<< (allPackagesByName sourcePkgIndex) - , let catList = (PD.category . PD.packageDescription . srcpkgDescription) pkg - , cat <- splitString ',' $ ShortText.fromShortText catList - ] - --- Parse name and email, from darcs pref files or environment variable -nameAndMail :: String -> (Flag String, Flag String) -nameAndMail str - | all isSpace nameOrEmail = mempty - | null erest = (mempty, Flag $ trim nameOrEmail) - | otherwise = (Flag $ trim nameOrEmail, Flag mail) - where - (nameOrEmail,erest) = break (== '<') str - (mail,_) = break (== '>') (safeTail erest) - -trim :: String -> String -trim = removeLeadingSpace . reverse . removeLeadingSpace . reverse - where - removeLeadingSpace = dropWhile isSpace - --- split string at given character, and remove whitespace -splitString :: Char -> String -> [String] -splitString sep str = go str where - go s = if null s' then [] else tok : go rest where - s' = dropWhile (\c -> c == sep || isSpace c) s - (tok,rest) = break (==sep) s' - -nubSet :: (Ord a) => [a] -> [a] -nubSet = Set.toList . Set.fromList - -{- -test db testProjectRoot = do - putStrLn "Guessed package name" - (guessPackageName >=> print) testProjectRoot - putStrLn "Guessed name and email" - guessAuthorNameMail >>= print - - mods <- scanForModules testProjectRoot - - putStrLn "Guessed modules" - mapM_ print mods - putStrLn "Needed build programs" - print (neededBuildPrograms mods) - - putStrLn "List of known categories" - print $ knownCategories db --} diff --git a/cabal/cabal-install/Distribution/Client/Init/Licenses.hs b/cabal/cabal-install/Distribution/Client/Init/Licenses.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Init/Licenses.hs +++ /dev/null @@ -1,3077 +0,0 @@ -{-| -Module : Distribution.Client.Init.Licenses - -Description : Factory functions for producing known license types. - -License : BSD-like -Maintainer : cabal-devel@haskell.org -Stability : provisional -Portability : portable --} -module Distribution.Client.Init.Licenses - ( License - , bsd2 - , bsd3 - , gplv2 - , gplv3 - , lgpl21 - , lgpl3 - , agplv3 - , apache20 - , mit - , mpl20 - , isc - ) where - -import Prelude (String, unlines, (++)) - -type License = String - -bsd2 :: String -> String -> License -bsd2 authors year = unlines - [ "Copyright (c) " ++ year ++ ", " ++ authors - , "All rights reserved." - , "" - , "Redistribution and use in source and binary forms, with or without" - , "modification, are permitted provided that the following conditions are" - , "met:" - , "" - , "1. Redistributions of source code must retain the above copyright" - , " notice, this list of conditions and the following disclaimer." - , "" - , "2. Redistributions in binary form must reproduce the above copyright" - , " notice, this list of conditions and the following disclaimer in the" - , " documentation and/or other materials provided with the" - , " distribution." - , "" - , "THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS" - , "\"AS IS\" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT" - , "LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR" - , "A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT" - , "OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL," - , "SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT" - , "LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE," - , "DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY" - , "THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT" - , "(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE" - , "OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE." - ] - -bsd3 :: String -> String -> License -bsd3 authors year = unlines - [ "Copyright (c) " ++ year ++ ", " ++ authors - , "" - , "All rights reserved." - , "" - , "Redistribution and use in source and binary forms, with or without" - , "modification, are permitted provided that the following conditions are met:" - , "" - , " * Redistributions of source code must retain the above copyright" - , " notice, this list of conditions and the following disclaimer." - , "" - , " * Redistributions in binary form must reproduce the above" - , " copyright notice, this list of conditions and the following" - , " disclaimer in the documentation and/or other materials provided" - , " with the distribution." - , "" - , " * Neither the name of " ++ authors ++ " nor the names of other" - , " contributors may be used to endorse or promote products derived" - , " from this software without specific prior written permission." - , "" - , "THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS" - , "\"AS IS\" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT" - , "LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR" - , "A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT" - , "OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL," - , "SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT" - , "LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE," - , "DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY" - , "THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT" - , "(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE" - , "OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE." - ] - -gplv2 :: License -gplv2 = unlines - [ " GNU GENERAL PUBLIC LICENSE" - , " Version 2, June 1991" - , "" - , " Copyright (C) 1989, 1991 Free Software Foundation, Inc.," - , " 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA" - , " Everyone is permitted to copy and distribute verbatim copies" - , " of this license document, but changing it is not allowed." - , "" - , " Preamble" - , "" - , " The licenses for most software are designed to take away your" - , "freedom to share and change it. By contrast, the GNU General Public" - , "License is intended to guarantee your freedom to share and change free" - , "software--to make sure the software is free for all its users. This" - , "General Public License applies to most of the Free Software" - , "Foundation's software and to any other program whose authors commit to" - , "using it. (Some other Free Software Foundation software is covered by" - , "the GNU Lesser General Public License instead.) You can apply it to" - , "your programs, too." - , "" - , " When we speak of free software, we are referring to freedom, not" - , "price. Our General Public Licenses are designed to make sure that you" - , "have the freedom to distribute copies of free software (and charge for" - , "this service if you wish), that you receive source code or can get it" - , "if you want it, that you can change the software or use pieces of it" - , "in new free programs; and that you know you can do these things." - , "" - , " To protect your rights, we need to make restrictions that forbid" - , "anyone to deny you these rights or to ask you to surrender the rights." - , "These restrictions translate to certain responsibilities for you if you" - , "distribute copies of the software, or if you modify it." - , "" - , " For example, if you distribute copies of such a program, whether" - , "gratis or for a fee, you must give the recipients all the rights that" - , "you have. You must make sure that they, too, receive or can get the" - , "source code. And you must show them these terms so they know their" - , "rights." - , "" - , " We protect your rights with two steps: (1) copyright the software, and" - , "(2) offer you this license which gives you legal permission to copy," - , "distribute and/or modify the software." - , "" - , " Also, for each author's protection and ours, we want to make certain" - , "that everyone understands that there is no warranty for this free" - , "software. If the software is modified by someone else and passed on, we" - , "want its recipients to know that what they have is not the original, so" - , "that any problems introduced by others will not reflect on the original" - , "authors' reputations." - , "" - , " Finally, any free program is threatened constantly by software" - , "patents. We wish to avoid the danger that redistributors of a free" - , "program will individually obtain patent licenses, in effect making the" - , "program proprietary. To prevent this, we have made it clear that any" - , "patent must be licensed for everyone's free use or not licensed at all." - , "" - , " The precise terms and conditions for copying, distribution and" - , "modification follow." - , "" - , " GNU GENERAL PUBLIC LICENSE" - , " TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION" - , "" - , " 0. This License applies to any program or other work which contains" - , "a notice placed by the copyright holder saying it may be distributed" - , "under the terms of this General Public License. The \"Program\", below," - , "refers to any such program or work, and a \"work based on the Program\"" - , "means either the Program or any derivative work under copyright law:" - , "that is to say, a work containing the Program or a portion of it," - , "either verbatim or with modifications and/or translated into another" - , "language. (Hereinafter, translation is included without limitation in" - , "the term \"modification\".) Each licensee is addressed as \"you\"." - , "" - , "Activities other than copying, distribution and modification are not" - , "covered by this License; they are outside its scope. The act of" - , "running the Program is not restricted, and the output from the Program" - , "is covered only if its contents constitute a work based on the" - , "Program (independent of having been made by running the Program)." - , "Whether that is true depends on what the Program does." - , "" - , " 1. You may copy and distribute verbatim copies of the Program's" - , "source code as you receive it, in any medium, provided that you" - , "conspicuously and appropriately publish on each copy an appropriate" - , "copyright notice and disclaimer of warranty; keep intact all the" - , "notices that refer to this License and to the absence of any warranty;" - , "and give any other recipients of the Program a copy of this License" - , "along with the Program." - , "" - , "You may charge a fee for the physical act of transferring a copy, and" - , "you may at your option offer warranty protection in exchange for a fee." - , "" - , " 2. You may modify your copy or copies of the Program or any portion" - , "of it, thus forming a work based on the Program, and copy and" - , "distribute such modifications or work under the terms of Section 1" - , "above, provided that you also meet all of these conditions:" - , "" - , " a) You must cause the modified files to carry prominent notices" - , " stating that you changed the files and the date of any change." - , "" - , " b) You must cause any work that you distribute or publish, that in" - , " whole or in part contains or is derived from the Program or any" - , " part thereof, to be licensed as a whole at no charge to all third" - , " parties under the terms of this License." - , "" - , " c) If the modified program normally reads commands interactively" - , " when run, you must cause it, when started running for such" - , " interactive use in the most ordinary way, to print or display an" - , " announcement including an appropriate copyright notice and a" - , " notice that there is no warranty (or else, saying that you provide" - , " a warranty) and that users may redistribute the program under" - , " these conditions, and telling the user how to view a copy of this" - , " License. (Exception: if the Program itself is interactive but" - , " does not normally print such an announcement, your work based on" - , " the Program is not required to print an announcement.)" - , "" - , "These requirements apply to the modified work as a whole. If" - , "identifiable sections of that work are not derived from the Program," - , "and can be reasonably considered independent and separate works in" - , "themselves, then this License, and its terms, do not apply to those" - , "sections when you distribute them as separate works. But when you" - , "distribute the same sections as part of a whole which is a work based" - , "on the Program, the distribution of the whole must be on the terms of" - , "this License, whose permissions for other licensees extend to the" - , "entire whole, and thus to each and every part regardless of who wrote it." - , "" - , "Thus, it is not the intent of this section to claim rights or contest" - , "your rights to work written entirely by you; rather, the intent is to" - , "exercise the right to control the distribution of derivative or" - , "collective works based on the Program." - , "" - , "In addition, mere aggregation of another work not based on the Program" - , "with the Program (or with a work based on the Program) on a volume of" - , "a storage or distribution medium does not bring the other work under" - , "the scope of this License." - , "" - , " 3. You may copy and distribute the Program (or a work based on it," - , "under Section 2) in object code or executable form under the terms of" - , "Sections 1 and 2 above provided that you also do one of the following:" - , "" - , " a) Accompany it with the complete corresponding machine-readable" - , " source code, which must be distributed under the terms of Sections" - , " 1 and 2 above on a medium customarily used for software interchange; or," - , "" - , " b) Accompany it with a written offer, valid for at least three" - , " years, to give any third party, for a charge no more than your" - , " cost of physically performing source distribution, a complete" - , " machine-readable copy of the corresponding source code, to be" - , " distributed under the terms of Sections 1 and 2 above on a medium" - , " customarily used for software interchange; or," - , "" - , " c) Accompany it with the information you received as to the offer" - , " to distribute corresponding source code. (This alternative is" - , " allowed only for noncommercial distribution and only if you" - , " received the program in object code or executable form with such" - , " an offer, in accord with Subsection b above.)" - , "" - , "The source code for a work means the preferred form of the work for" - , "making modifications to it. For an executable work, complete source" - , "code means all the source code for all modules it contains, plus any" - , "associated interface definition files, plus the scripts used to" - , "control compilation and installation of the executable. However, as a" - , "special exception, the source code distributed need not include" - , "anything that is normally distributed (in either source or binary" - , "form) with the major components (compiler, kernel, and so on) of the" - , "operating system on which the executable runs, unless that component" - , "itself accompanies the executable." - , "" - , "If distribution of executable or object code is made by offering" - , "access to copy from a designated place, then offering equivalent" - , "access to copy the source code from the same place counts as" - , "distribution of the source code, even though third parties are not" - , "compelled to copy the source along with the object code." - , "" - , " 4. You may not copy, modify, sublicense, or distribute the Program" - , "except as expressly provided under this License. Any attempt" - , "otherwise to copy, modify, sublicense or distribute the Program is" - , "void, and will automatically terminate your rights under this License." - , "However, parties who have received copies, or rights, from you under" - , "this License will not have their licenses terminated so long as such" - , "parties remain in full compliance." - , "" - , " 5. You are not required to accept this License, since you have not" - , "signed it. However, nothing else grants you permission to modify or" - , "distribute the Program or its derivative works. These actions are" - , "prohibited by law if you do not accept this License. Therefore, by" - , "modifying or distributing the Program (or any work based on the" - , "Program), you indicate your acceptance of this License to do so, and" - , "all its terms and conditions for copying, distributing or modifying" - , "the Program or works based on it." - , "" - , " 6. Each time you redistribute the Program (or any work based on the" - , "Program), the recipient automatically receives a license from the" - , "original licensor to copy, distribute or modify the Program subject to" - , "these terms and conditions. You may not impose any further" - , "restrictions on the recipients' exercise of the rights granted herein." - , "You are not responsible for enforcing compliance by third parties to" - , "this License." - , "" - , " 7. If, as a consequence of a court judgment or allegation of patent" - , "infringement or for any other reason (not limited to patent issues)," - , "conditions are imposed on you (whether by court order, agreement or" - , "otherwise) that contradict the conditions of this License, they do not" - , "excuse you from the conditions of this License. If you cannot" - , "distribute so as to satisfy simultaneously your obligations under this" - , "License and any other pertinent obligations, then as a consequence you" - , "may not distribute the Program at all. For example, if a patent" - , "license would not permit royalty-free redistribution of the Program by" - , "all those who receive copies directly or indirectly through you, then" - , "the only way you could satisfy both it and this License would be to" - , "refrain entirely from distribution of the Program." - , "" - , "If any portion of this section is held invalid or unenforceable under" - , "any particular circumstance, the balance of the section is intended to" - , "apply and the section as a whole is intended to apply in other" - , "circumstances." - , "" - , "It is not the purpose of this section to induce you to infringe any" - , "patents or other property right claims or to contest validity of any" - , "such claims; this section has the sole purpose of protecting the" - , "integrity of the free software distribution system, which is" - , "implemented by public license practices. Many people have made" - , "generous contributions to the wide range of software distributed" - , "through that system in reliance on consistent application of that" - , "system; it is up to the author/donor to decide if he or she is willing" - , "to distribute software through any other system and a licensee cannot" - , "impose that choice." - , "" - , "This section is intended to make thoroughly clear what is believed to" - , "be a consequence of the rest of this License." - , "" - , " 8. If the distribution and/or use of the Program is restricted in" - , "certain countries either by patents or by copyrighted interfaces, the" - , "original copyright holder who places the Program under this License" - , "may add an explicit geographical distribution limitation excluding" - , "those countries, so that distribution is permitted only in or among" - , "countries not thus excluded. In such case, this License incorporates" - , "the limitation as if written in the body of this License." - , "" - , " 9. The Free Software Foundation may publish revised and/or new versions" - , "of the General Public License from time to time. Such new versions will" - , "be similar in spirit to the present version, but may differ in detail to" - , "address new problems or concerns." - , "" - , "Each version is given a distinguishing version number. If the Program" - , "specifies a version number of this License which applies to it and \"any" - , "later version\", you have the option of following the terms and conditions" - , "either of that version or of any later version published by the Free" - , "Software Foundation. If the Program does not specify a version number of" - , "this License, you may choose any version ever published by the Free Software" - , "Foundation." - , "" - , " 10. If you wish to incorporate parts of the Program into other free" - , "programs whose distribution conditions are different, write to the author" - , "to ask for permission. For software which is copyrighted by the Free" - , "Software Foundation, write to the Free Software Foundation; we sometimes" - , "make exceptions for this. Our decision will be guided by the two goals" - , "of preserving the free status of all derivatives of our free software and" - , "of promoting the sharing and reuse of software generally." - , "" - , " NO WARRANTY" - , "" - , " 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY" - , "FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN" - , "OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES" - , "PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED" - , "OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF" - , "MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS" - , "TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE" - , "PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING," - , "REPAIR OR CORRECTION." - , "" - , " 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING" - , "WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR" - , "REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES," - , "INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING" - , "OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED" - , "TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY" - , "YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER" - , "PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE" - , "POSSIBILITY OF SUCH DAMAGES." - , "" - , " END OF TERMS AND CONDITIONS" - , "" - , " How to Apply These Terms to Your New Programs" - , "" - , " If you develop a new program, and you want it to be of the greatest" - , "possible use to the public, the best way to achieve this is to make it" - , "free software which everyone can redistribute and change under these terms." - , "" - , " To do so, attach the following notices to the program. It is safest" - , "to attach them to the start of each source file to most effectively" - , "convey the exclusion of warranty; and each file should have at least" - , "the \"copyright\" line and a pointer to where the full notice is found." - , "" - , " " - , " Copyright (C) " - , "" - , " This program is free software; you can redistribute it and/or modify" - , " it under the terms of the GNU General Public License as published by" - , " the Free Software Foundation; either version 2 of the License, or" - , " (at your option) any later version." - , "" - , " This program is distributed in the hope that it will be useful," - , " but WITHOUT ANY WARRANTY; without even the implied warranty of" - , " MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the" - , " GNU General Public License for more details." - , "" - , " You should have received a copy of the GNU General Public License along" - , " with this program; if not, write to the Free Software Foundation, Inc.," - , " 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA." - , "" - , "Also add information on how to contact you by electronic and paper mail." - , "" - , "If the program is interactive, make it output a short notice like this" - , "when it starts in an interactive mode:" - , "" - , " Gnomovision version 69, Copyright (C) year name of author" - , " Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'." - , " This is free software, and you are welcome to redistribute it" - , " under certain conditions; type `show c' for details." - , "" - , "The hypothetical commands `show w' and `show c' should show the appropriate" - , "parts of the General Public License. Of course, the commands you use may" - , "be called something other than `show w' and `show c'; they could even be" - , "mouse-clicks or menu items--whatever suits your program." - , "" - , "You should also get your employer (if you work as a programmer) or your" - , "school, if any, to sign a \"copyright disclaimer\" for the program, if" - , "necessary. Here is a sample; alter the names:" - , "" - , " Yoyodyne, Inc., hereby disclaims all copyright interest in the program" - , " `Gnomovision' (which makes passes at compilers) written by James Hacker." - , "" - , " , 1 April 1989" - , " Ty Coon, President of Vice" - , "" - , "This General Public License does not permit incorporating your program into" - , "proprietary programs. If your program is a subroutine library, you may" - , "consider it more useful to permit linking proprietary applications with the" - , "library. If this is what you want to do, use the GNU Lesser General" - , "Public License instead of this License." - ] - -gplv3 :: License -gplv3 = unlines - [ " GNU GENERAL PUBLIC LICENSE" - , " Version 3, 29 June 2007" - , "" - , " Copyright (C) 2007 Free Software Foundation, Inc. " - , " Everyone is permitted to copy and distribute verbatim copies" - , " of this license document, but changing it is not allowed." - , "" - , " Preamble" - , "" - , " The GNU General Public License is a free, copyleft license for" - , "software and other kinds of works." - , "" - , " The licenses for most software and other practical works are designed" - , "to take away your freedom to share and change the works. By contrast," - , "the GNU General Public License is intended to guarantee your freedom to" - , "share and change all versions of a program--to make sure it remains free" - , "software for all its users. We, the Free Software Foundation, use the" - , "GNU General Public License for most of our software; it applies also to" - , "any other work released this way by its authors. You can apply it to" - , "your programs, too." - , "" - , " When we speak of free software, we are referring to freedom, not" - , "price. Our General Public Licenses are designed to make sure that you" - , "have the freedom to distribute copies of free software (and charge for" - , "them if you wish), that you receive source code or can get it if you" - , "want it, that you can change the software or use pieces of it in new" - , "free programs, and that you know you can do these things." - , "" - , " To protect your rights, we need to prevent others from denying you" - , "these rights or asking you to surrender the rights. Therefore, you have" - , "certain responsibilities if you distribute copies of the software, or if" - , "you modify it: responsibilities to respect the freedom of others." - , "" - , " For example, if you distribute copies of such a program, whether" - , "gratis or for a fee, you must pass on to the recipients the same" - , "freedoms that you received. You must make sure that they, too, receive" - , "or can get the source code. And you must show them these terms so they" - , "know their rights." - , "" - , " Developers that use the GNU GPL protect your rights with two steps:" - , "(1) assert copyright on the software, and (2) offer you this License" - , "giving you legal permission to copy, distribute and/or modify it." - , "" - , " For the developers' and authors' protection, the GPL clearly explains" - , "that there is no warranty for this free software. For both users' and" - , "authors' sake, the GPL requires that modified versions be marked as" - , "changed, so that their problems will not be attributed erroneously to" - , "authors of previous versions." - , "" - , " Some devices are designed to deny users access to install or run" - , "modified versions of the software inside them, although the manufacturer" - , "can do so. This is fundamentally incompatible with the aim of" - , "protecting users' freedom to change the software. The systematic" - , "pattern of such abuse occurs in the area of products for individuals to" - , "use, which is precisely where it is most unacceptable. Therefore, we" - , "have designed this version of the GPL to prohibit the practice for those" - , "products. If such problems arise substantially in other domains, we" - , "stand ready to extend this provision to those domains in future versions" - , "of the GPL, as needed to protect the freedom of users." - , "" - , " Finally, every program is threatened constantly by software patents." - , "States should not allow patents to restrict development and use of" - , "software on general-purpose computers, but in those that do, we wish to" - , "avoid the special danger that patents applied to a free program could" - , "make it effectively proprietary. To prevent this, the GPL assures that" - , "patents cannot be used to render the program non-free." - , "" - , " The precise terms and conditions for copying, distribution and" - , "modification follow." - , "" - , " TERMS AND CONDITIONS" - , "" - , " 0. Definitions." - , "" - , " \"This License\" refers to version 3 of the GNU General Public License." - , "" - , " \"Copyright\" also means copyright-like laws that apply to other kinds of" - , "works, such as semiconductor masks." - , "" - , " \"The Program\" refers to any copyrightable work licensed under this" - , "License. Each licensee is addressed as \"you\". \"Licensees\" and" - , "\"recipients\" may be individuals or organizations." - , "" - , " To \"modify\" a work means to copy from or adapt all or part of the work" - , "in a fashion requiring copyright permission, other than the making of an" - , "exact copy. The resulting work is called a \"modified version\" of the" - , "earlier work or a work \"based on\" the earlier work." - , "" - , " A \"covered work\" means either the unmodified Program or a work based" - , "on the Program." - , "" - , " To \"propagate\" a work means to do anything with it that, without" - , "permission, would make you directly or secondarily liable for" - , "infringement under applicable copyright law, except executing it on a" - , "computer or modifying a private copy. Propagation includes copying," - , "distribution (with or without modification), making available to the" - , "public, and in some countries other activities as well." - , "" - , " To \"convey\" a work means any kind of propagation that enables other" - , "parties to make or receive copies. Mere interaction with a user through" - , "a computer network, with no transfer of a copy, is not conveying." - , "" - , " An interactive user interface displays \"Appropriate Legal Notices\"" - , "to the extent that it includes a convenient and prominently visible" - , "feature that (1) displays an appropriate copyright notice, and (2)" - , "tells the user that there is no warranty for the work (except to the" - , "extent that warranties are provided), that licensees may convey the" - , "work under this License, and how to view a copy of this License. If" - , "the interface presents a list of user commands or options, such as a" - , "menu, a prominent item in the list meets this criterion." - , "" - , " 1. Source Code." - , "" - , " The \"source code\" for a work means the preferred form of the work" - , "for making modifications to it. \"Object code\" means any non-source" - , "form of a work." - , "" - , " A \"Standard Interface\" means an interface that either is an official" - , "standard defined by a recognized standards body, or, in the case of" - , "interfaces specified for a particular programming language, one that" - , "is widely used among developers working in that language." - , "" - , " The \"System Libraries\" of an executable work include anything, other" - , "than the work as a whole, that (a) is included in the normal form of" - , "packaging a Major Component, but which is not part of that Major" - , "Component, and (b) serves only to enable use of the work with that" - , "Major Component, or to implement a Standard Interface for which an" - , "implementation is available to the public in source code form. A" - , "\"Major Component\", in this context, means a major essential component" - , "(kernel, window system, and so on) of the specific operating system" - , "(if any) on which the executable work runs, or a compiler used to" - , "produce the work, or an object code interpreter used to run it." - , "" - , " The \"Corresponding Source\" for a work in object code form means all" - , "the source code needed to generate, install, and (for an executable" - , "work) run the object code and to modify the work, including scripts to" - , "control those activities. However, it does not include the work's" - , "System Libraries, or general-purpose tools or generally available free" - , "programs which are used unmodified in performing those activities but" - , "which are not part of the work. For example, Corresponding Source" - , "includes interface definition files associated with source files for" - , "the work, and the source code for shared libraries and dynamically" - , "linked subprograms that the work is specifically designed to require," - , "such as by intimate data communication or control flow between those" - , "subprograms and other parts of the work." - , "" - , " The Corresponding Source need not include anything that users" - , "can regenerate automatically from other parts of the Corresponding" - , "Source." - , "" - , " The Corresponding Source for a work in source code form is that" - , "same work." - , "" - , " 2. Basic Permissions." - , "" - , " All rights granted under this License are granted for the term of" - , "copyright on the Program, and are irrevocable provided the stated" - , "conditions are met. This License explicitly affirms your unlimited" - , "permission to run the unmodified Program. The output from running a" - , "covered work is covered by this License only if the output, given its" - , "content, constitutes a covered work. This License acknowledges your" - , "rights of fair use or other equivalent, as provided by copyright law." - , "" - , " You may make, run and propagate covered works that you do not" - , "convey, without conditions so long as your license otherwise remains" - , "in force. You may convey covered works to others for the sole purpose" - , "of having them make modifications exclusively for you, or provide you" - , "with facilities for running those works, provided that you comply with" - , "the terms of this License in conveying all material for which you do" - , "not control copyright. Those thus making or running the covered works" - , "for you must do so exclusively on your behalf, under your direction" - , "and control, on terms that prohibit them from making any copies of" - , "your copyrighted material outside their relationship with you." - , "" - , " Conveying under any other circumstances is permitted solely under" - , "the conditions stated below. Sublicensing is not allowed; section 10" - , "makes it unnecessary." - , "" - , " 3. Protecting Users' Legal Rights From Anti-Circumvention Law." - , "" - , " No covered work shall be deemed part of an effective technological" - , "measure under any applicable law fulfilling obligations under article" - , "11 of the WIPO copyright treaty adopted on 20 December 1996, or" - , "similar laws prohibiting or restricting circumvention of such" - , "measures." - , "" - , " When you convey a covered work, you waive any legal power to forbid" - , "circumvention of technological measures to the extent such circumvention" - , "is effected by exercising rights under this License with respect to" - , "the covered work, and you disclaim any intention to limit operation or" - , "modification of the work as a means of enforcing, against the work's" - , "users, your or third parties' legal rights to forbid circumvention of" - , "technological measures." - , "" - , " 4. Conveying Verbatim Copies." - , "" - , " You may convey verbatim copies of the Program's source code as you" - , "receive it, in any medium, provided that you conspicuously and" - , "appropriately publish on each copy an appropriate copyright notice;" - , "keep intact all notices stating that this License and any" - , "non-permissive terms added in accord with section 7 apply to the code;" - , "keep intact all notices of the absence of any warranty; and give all" - , "recipients a copy of this License along with the Program." - , "" - , " You may charge any price or no price for each copy that you convey," - , "and you may offer support or warranty protection for a fee." - , "" - , " 5. Conveying Modified Source Versions." - , "" - , " You may convey a work based on the Program, or the modifications to" - , "produce it from the Program, in the form of source code under the" - , "terms of section 4, provided that you also meet all of these conditions:" - , "" - , " a) The work must carry prominent notices stating that you modified" - , " it, and giving a relevant date." - , "" - , " b) The work must carry prominent notices stating that it is" - , " released under this License and any conditions added under section" - , " 7. This requirement modifies the requirement in section 4 to" - , " \"keep intact all notices\"." - , "" - , " c) You must license the entire work, as a whole, under this" - , " License to anyone who comes into possession of a copy. This" - , " License will therefore apply, along with any applicable section 7" - , " additional terms, to the whole of the work, and all its parts," - , " regardless of how they are packaged. This License gives no" - , " permission to license the work in any other way, but it does not" - , " invalidate such permission if you have separately received it." - , "" - , " d) If the work has interactive user interfaces, each must display" - , " Appropriate Legal Notices; however, if the Program has interactive" - , " interfaces that do not display Appropriate Legal Notices, your" - , " work need not make them do so." - , "" - , " A compilation of a covered work with other separate and independent" - , "works, which are not by their nature extensions of the covered work," - , "and which are not combined with it such as to form a larger program," - , "in or on a volume of a storage or distribution medium, is called an" - , "\"aggregate\" if the compilation and its resulting copyright are not" - , "used to limit the access or legal rights of the compilation's users" - , "beyond what the individual works permit. Inclusion of a covered work" - , "in an aggregate does not cause this License to apply to the other" - , "parts of the aggregate." - , "" - , " 6. Conveying Non-Source Forms." - , "" - , " You may convey a covered work in object code form under the terms" - , "of sections 4 and 5, provided that you also convey the" - , "machine-readable Corresponding Source under the terms of this License," - , "in one of these ways:" - , "" - , " a) Convey the object code in, or embodied in, a physical product" - , " (including a physical distribution medium), accompanied by the" - , " Corresponding Source fixed on a durable physical medium" - , " customarily used for software interchange." - , "" - , " b) Convey the object code in, or embodied in, a physical product" - , " (including a physical distribution medium), accompanied by a" - , " written offer, valid for at least three years and valid for as" - , " long as you offer spare parts or customer support for that product" - , " model, to give anyone who possesses the object code either (1) a" - , " copy of the Corresponding Source for all the software in the" - , " product that is covered by this License, on a durable physical" - , " medium customarily used for software interchange, for a price no" - , " more than your reasonable cost of physically performing this" - , " conveying of source, or (2) access to copy the" - , " Corresponding Source from a network server at no charge." - , "" - , " c) Convey individual copies of the object code with a copy of the" - , " written offer to provide the Corresponding Source. This" - , " alternative is allowed only occasionally and noncommercially, and" - , " only if you received the object code with such an offer, in accord" - , " with subsection 6b." - , "" - , " d) Convey the object code by offering access from a designated" - , " place (gratis or for a charge), and offer equivalent access to the" - , " Corresponding Source in the same way through the same place at no" - , " further charge. You need not require recipients to copy the" - , " Corresponding Source along with the object code. If the place to" - , " copy the object code is a network server, the Corresponding Source" - , " may be on a different server (operated by you or a third party)" - , " that supports equivalent copying facilities, provided you maintain" - , " clear directions next to the object code saying where to find the" - , " Corresponding Source. Regardless of what server hosts the" - , " Corresponding Source, you remain obligated to ensure that it is" - , " available for as long as needed to satisfy these requirements." - , "" - , " e) Convey the object code using peer-to-peer transmission, provided" - , " you inform other peers where the object code and Corresponding" - , " Source of the work are being offered to the general public at no" - , " charge under subsection 6d." - , "" - , " A separable portion of the object code, whose source code is excluded" - , "from the Corresponding Source as a System Library, need not be" - , "included in conveying the object code work." - , "" - , " A \"User Product\" is either (1) a \"consumer product\", which means any" - , "tangible personal property which is normally used for personal, family," - , "or household purposes, or (2) anything designed or sold for incorporation" - , "into a dwelling. In determining whether a product is a consumer product," - , "doubtful cases shall be resolved in favor of coverage. For a particular" - , "product received by a particular user, \"normally used\" refers to a" - , "typical or common use of that class of product, regardless of the status" - , "of the particular user or of the way in which the particular user" - , "actually uses, or expects or is expected to use, the product. A product" - , "is a consumer product regardless of whether the product has substantial" - , "commercial, industrial or non-consumer uses, unless such uses represent" - , "the only significant mode of use of the product." - , "" - , " \"Installation Information\" for a User Product means any methods," - , "procedures, authorization keys, or other information required to install" - , "and execute modified versions of a covered work in that User Product from" - , "a modified version of its Corresponding Source. The information must" - , "suffice to ensure that the continued functioning of the modified object" - , "code is in no case prevented or interfered with solely because" - , "modification has been made." - , "" - , " If you convey an object code work under this section in, or with, or" - , "specifically for use in, a User Product, and the conveying occurs as" - , "part of a transaction in which the right of possession and use of the" - , "User Product is transferred to the recipient in perpetuity or for a" - , "fixed term (regardless of how the transaction is characterized), the" - , "Corresponding Source conveyed under this section must be accompanied" - , "by the Installation Information. But this requirement does not apply" - , "if neither you nor any third party retains the ability to install" - , "modified object code on the User Product (for example, the work has" - , "been installed in ROM)." - , "" - , " The requirement to provide Installation Information does not include a" - , "requirement to continue to provide support service, warranty, or updates" - , "for a work that has been modified or installed by the recipient, or for" - , "the User Product in which it has been modified or installed. Access to a" - , "network may be denied when the modification itself materially and" - , "adversely affects the operation of the network or violates the rules and" - , "protocols for communication across the network." - , "" - , " Corresponding Source conveyed, and Installation Information provided," - , "in accord with this section must be in a format that is publicly" - , "documented (and with an implementation available to the public in" - , "source code form), and must require no special password or key for" - , "unpacking, reading or copying." - , "" - , " 7. Additional Terms." - , "" - , " \"Additional permissions\" are terms that supplement the terms of this" - , "License by making exceptions from one or more of its conditions." - , "Additional permissions that are applicable to the entire Program shall" - , "be treated as though they were included in this License, to the extent" - , "that they are valid under applicable law. If additional permissions" - , "apply only to part of the Program, that part may be used separately" - , "under those permissions, but the entire Program remains governed by" - , "this License without regard to the additional permissions." - , "" - , " When you convey a copy of a covered work, you may at your option" - , "remove any additional permissions from that copy, or from any part of" - , "it. (Additional permissions may be written to require their own" - , "removal in certain cases when you modify the work.) You may place" - , "additional permissions on material, added by you to a covered work," - , "for which you have or can give appropriate copyright permission." - , "" - , " Notwithstanding any other provision of this License, for material you" - , "add to a covered work, you may (if authorized by the copyright holders of" - , "that material) supplement the terms of this License with terms:" - , "" - , " a) Disclaiming warranty or limiting liability differently from the" - , " terms of sections 15 and 16 of this License; or" - , "" - , " b) Requiring preservation of specified reasonable legal notices or" - , " author attributions in that material or in the Appropriate Legal" - , " Notices displayed by works containing it; or" - , "" - , " c) Prohibiting misrepresentation of the origin of that material, or" - , " requiring that modified versions of such material be marked in" - , " reasonable ways as different from the original version; or" - , "" - , " d) Limiting the use for publicity purposes of names of licensors or" - , " authors of the material; or" - , "" - , " e) Declining to grant rights under trademark law for use of some" - , " trade names, trademarks, or service marks; or" - , "" - , " f) Requiring indemnification of licensors and authors of that" - , " material by anyone who conveys the material (or modified versions of" - , " it) with contractual assumptions of liability to the recipient, for" - , " any liability that these contractual assumptions directly impose on" - , " those licensors and authors." - , "" - , " All other non-permissive additional terms are considered \"further" - , "restrictions\" within the meaning of section 10. If the Program as you" - , "received it, or any part of it, contains a notice stating that it is" - , "governed by this License along with a term that is a further" - , "restriction, you may remove that term. If a license document contains" - , "a further restriction but permits relicensing or conveying under this" - , "License, you may add to a covered work material governed by the terms" - , "of that license document, provided that the further restriction does" - , "not survive such relicensing or conveying." - , "" - , " If you add terms to a covered work in accord with this section, you" - , "must place, in the relevant source files, a statement of the" - , "additional terms that apply to those files, or a notice indicating" - , "where to find the applicable terms." - , "" - , " Additional terms, permissive or non-permissive, may be stated in the" - , "form of a separately written license, or stated as exceptions;" - , "the above requirements apply either way." - , "" - , " 8. Termination." - , "" - , " You may not propagate or modify a covered work except as expressly" - , "provided under this License. Any attempt otherwise to propagate or" - , "modify it is void, and will automatically terminate your rights under" - , "this License (including any patent licenses granted under the third" - , "paragraph of section 11)." - , "" - , " However, if you cease all violation of this License, then your" - , "license from a particular copyright holder is reinstated (a)" - , "provisionally, unless and until the copyright holder explicitly and" - , "finally terminates your license, and (b) permanently, if the copyright" - , "holder fails to notify you of the violation by some reasonable means" - , "prior to 60 days after the cessation." - , "" - , " Moreover, your license from a particular copyright holder is" - , "reinstated permanently if the copyright holder notifies you of the" - , "violation by some reasonable means, this is the first time you have" - , "received notice of violation of this License (for any work) from that" - , "copyright holder, and you cure the violation prior to 30 days after" - , "your receipt of the notice." - , "" - , " Termination of your rights under this section does not terminate the" - , "licenses of parties who have received copies or rights from you under" - , "this License. If your rights have been terminated and not permanently" - , "reinstated, you do not qualify to receive new licenses for the same" - , "material under section 10." - , "" - , " 9. Acceptance Not Required for Having Copies." - , "" - , " You are not required to accept this License in order to receive or" - , "run a copy of the Program. Ancillary propagation of a covered work" - , "occurring solely as a consequence of using peer-to-peer transmission" - , "to receive a copy likewise does not require acceptance. However," - , "nothing other than this License grants you permission to propagate or" - , "modify any covered work. These actions infringe copyright if you do" - , "not accept this License. Therefore, by modifying or propagating a" - , "covered work, you indicate your acceptance of this License to do so." - , "" - , " 10. Automatic Licensing of Downstream Recipients." - , "" - , " Each time you convey a covered work, the recipient automatically" - , "receives a license from the original licensors, to run, modify and" - , "propagate that work, subject to this License. You are not responsible" - , "for enforcing compliance by third parties with this License." - , "" - , " An \"entity transaction\" is a transaction transferring control of an" - , "organization, or substantially all assets of one, or subdividing an" - , "organization, or merging organizations. If propagation of a covered" - , "work results from an entity transaction, each party to that" - , "transaction who receives a copy of the work also receives whatever" - , "licenses to the work the party's predecessor in interest had or could" - , "give under the previous paragraph, plus a right to possession of the" - , "Corresponding Source of the work from the predecessor in interest, if" - , "the predecessor has it or can get it with reasonable efforts." - , "" - , " You may not impose any further restrictions on the exercise of the" - , "rights granted or affirmed under this License. For example, you may" - , "not impose a license fee, royalty, or other charge for exercise of" - , "rights granted under this License, and you may not initiate litigation" - , "(including a cross-claim or counterclaim in a lawsuit) alleging that" - , "any patent claim is infringed by making, using, selling, offering for" - , "sale, or importing the Program or any portion of it." - , "" - , " 11. Patents." - , "" - , " A \"contributor\" is a copyright holder who authorizes use under this" - , "License of the Program or a work on which the Program is based. The" - , "work thus licensed is called the contributor's \"contributor version\"." - , "" - , " A contributor's \"essential patent claims\" are all patent claims" - , "owned or controlled by the contributor, whether already acquired or" - , "hereafter acquired, that would be infringed by some manner, permitted" - , "by this License, of making, using, or selling its contributor version," - , "but do not include claims that would be infringed only as a" - , "consequence of further modification of the contributor version. For" - , "purposes of this definition, \"control\" includes the right to grant" - , "patent sublicenses in a manner consistent with the requirements of" - , "this License." - , "" - , " Each contributor grants you a non-exclusive, worldwide, royalty-free" - , "patent license under the contributor's essential patent claims, to" - , "make, use, sell, offer for sale, import and otherwise run, modify and" - , "propagate the contents of its contributor version." - , "" - , " In the following three paragraphs, a \"patent license\" is any express" - , "agreement or commitment, however denominated, not to enforce a patent" - , "(such as an express permission to practice a patent or covenant not to" - , "sue for patent infringement). To \"grant\" such a patent license to a" - , "party means to make such an agreement or commitment not to enforce a" - , "patent against the party." - , "" - , " If you convey a covered work, knowingly relying on a patent license," - , "and the Corresponding Source of the work is not available for anyone" - , "to copy, free of charge and under the terms of this License, through a" - , "publicly available network server or other readily accessible means," - , "then you must either (1) cause the Corresponding Source to be so" - , "available, or (2) arrange to deprive yourself of the benefit of the" - , "patent license for this particular work, or (3) arrange, in a manner" - , "consistent with the requirements of this License, to extend the patent" - , "license to downstream recipients. \"Knowingly relying\" means you have" - , "actual knowledge that, but for the patent license, your conveying the" - , "covered work in a country, or your recipient's use of the covered work" - , "in a country, would infringe one or more identifiable patents in that" - , "country that you have reason to believe are valid." - , "" - , " If, pursuant to or in connection with a single transaction or" - , "arrangement, you convey, or propagate by procuring conveyance of, a" - , "covered work, and grant a patent license to some of the parties" - , "receiving the covered work authorizing them to use, propagate, modify" - , "or convey a specific copy of the covered work, then the patent license" - , "you grant is automatically extended to all recipients of the covered" - , "work and works based on it." - , "" - , " A patent license is \"discriminatory\" if it does not include within" - , "the scope of its coverage, prohibits the exercise of, or is" - , "conditioned on the non-exercise of one or more of the rights that are" - , "specifically granted under this License. You may not convey a covered" - , "work if you are a party to an arrangement with a third party that is" - , "in the business of distributing software, under which you make payment" - , "to the third party based on the extent of your activity of conveying" - , "the work, and under which the third party grants, to any of the" - , "parties who would receive the covered work from you, a discriminatory" - , "patent license (a) in connection with copies of the covered work" - , "conveyed by you (or copies made from those copies), or (b) primarily" - , "for and in connection with specific products or compilations that" - , "contain the covered work, unless you entered into that arrangement," - , "or that patent license was granted, prior to 28 March 2007." - , "" - , " Nothing in this License shall be construed as excluding or limiting" - , "any implied license or other defenses to infringement that may" - , "otherwise be available to you under applicable patent law." - , "" - , " 12. No Surrender of Others' Freedom." - , "" - , " If conditions are imposed on you (whether by court order, agreement or" - , "otherwise) that contradict the conditions of this License, they do not" - , "excuse you from the conditions of this License. If you cannot convey a" - , "covered work so as to satisfy simultaneously your obligations under this" - , "License and any other pertinent obligations, then as a consequence you may" - , "not convey it at all. For example, if you agree to terms that obligate you" - , "to collect a royalty for further conveying from those to whom you convey" - , "the Program, the only way you could satisfy both those terms and this" - , "License would be to refrain entirely from conveying the Program." - , "" - , " 13. Use with the GNU Affero General Public License." - , "" - , " Notwithstanding any other provision of this License, you have" - , "permission to link or combine any covered work with a work licensed" - , "under version 3 of the GNU Affero General Public License into a single" - , "combined work, and to convey the resulting work. The terms of this" - , "License will continue to apply to the part which is the covered work," - , "but the special requirements of the GNU Affero General Public License," - , "section 13, concerning interaction through a network will apply to the" - , "combination as such." - , "" - , " 14. Revised Versions of this License." - , "" - , " The Free Software Foundation may publish revised and/or new versions of" - , "the GNU General Public License from time to time. Such new versions will" - , "be similar in spirit to the present version, but may differ in detail to" - , "address new problems or concerns." - , "" - , " Each version is given a distinguishing version number. If the" - , "Program specifies that a certain numbered version of the GNU General" - , "Public License \"or any later version\" applies to it, you have the" - , "option of following the terms and conditions either of that numbered" - , "version or of any later version published by the Free Software" - , "Foundation. If the Program does not specify a version number of the" - , "GNU General Public License, you may choose any version ever published" - , "by the Free Software Foundation." - , "" - , " If the Program specifies that a proxy can decide which future" - , "versions of the GNU General Public License can be used, that proxy's" - , "public statement of acceptance of a version permanently authorizes you" - , "to choose that version for the Program." - , "" - , " Later license versions may give you additional or different" - , "permissions. However, no additional obligations are imposed on any" - , "author or copyright holder as a result of your choosing to follow a" - , "later version." - , "" - , " 15. Disclaimer of Warranty." - , "" - , " THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY" - , "APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT" - , "HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY" - , "OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO," - , "THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR" - , "PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM" - , "IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF" - , "ALL NECESSARY SERVICING, REPAIR OR CORRECTION." - , "" - , " 16. Limitation of Liability." - , "" - , " IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING" - , "WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS" - , "THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY" - , "GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE" - , "USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF" - , "DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD" - , "PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS)," - , "EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF" - , "SUCH DAMAGES." - , "" - , " 17. Interpretation of Sections 15 and 16." - , "" - , " If the disclaimer of warranty and limitation of liability provided" - , "above cannot be given local legal effect according to their terms," - , "reviewing courts shall apply local law that most closely approximates" - , "an absolute waiver of all civil liability in connection with the" - , "Program, unless a warranty or assumption of liability accompanies a" - , "copy of the Program in return for a fee." - , "" - , " END OF TERMS AND CONDITIONS" - , "" - , " How to Apply These Terms to Your New Programs" - , "" - , " If you develop a new program, and you want it to be of the greatest" - , "possible use to the public, the best way to achieve this is to make it" - , "free software which everyone can redistribute and change under these terms." - , "" - , " To do so, attach the following notices to the program. It is safest" - , "to attach them to the start of each source file to most effectively" - , "state the exclusion of warranty; and each file should have at least" - , "the \"copyright\" line and a pointer to where the full notice is found." - , "" - , " " - , " Copyright (C) " - , "" - , " This program is free software: you can redistribute it and/or modify" - , " it under the terms of the GNU General Public License as published by" - , " the Free Software Foundation, either version 3 of the License, or" - , " (at your option) any later version." - , "" - , " This program is distributed in the hope that it will be useful," - , " but WITHOUT ANY WARRANTY; without even the implied warranty of" - , " MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the" - , " GNU General Public License for more details." - , "" - , " You should have received a copy of the GNU General Public License" - , " along with this program. If not, see ." - , "" - , "Also add information on how to contact you by electronic and paper mail." - , "" - , " If the program does terminal interaction, make it output a short" - , "notice like this when it starts in an interactive mode:" - , "" - , " Copyright (C) " - , " This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'." - , " This is free software, and you are welcome to redistribute it" - , " under certain conditions; type `show c' for details." - , "" - , "The hypothetical commands `show w' and `show c' should show the appropriate" - , "parts of the General Public License. Of course, your program's commands" - , "might be different; for a GUI interface, you would use an \"about box\"." - , "" - , " You should also get your employer (if you work as a programmer) or school," - , "if any, to sign a \"copyright disclaimer\" for the program, if necessary." - , "For more information on this, and how to apply and follow the GNU GPL, see" - , "." - , "" - , " The GNU General Public License does not permit incorporating your program" - , "into proprietary programs. If your program is a subroutine library, you" - , "may consider it more useful to permit linking proprietary applications with" - , "the library. If this is what you want to do, use the GNU Lesser General" - , "Public License instead of this License. But first, please read" - , "." - ] - -agplv3 :: License -agplv3 = unlines - [ " GNU AFFERO GENERAL PUBLIC LICENSE" - , " Version 3, 19 November 2007" - , "" - , " Copyright (C) 2007 Free Software Foundation, Inc. " - , " Everyone is permitted to copy and distribute verbatim copies" - , " of this license document, but changing it is not allowed." - , "" - , " Preamble" - , "" - , " The GNU Affero General Public License is a free, copyleft license for" - , "software and other kinds of works, specifically designed to ensure" - , "cooperation with the community in the case of network server software." - , "" - , " The licenses for most software and other practical works are designed" - , "to take away your freedom to share and change the works. By contrast," - , "our General Public Licenses are intended to guarantee your freedom to" - , "share and change all versions of a program--to make sure it remains free" - , "software for all its users." - , "" - , " When we speak of free software, we are referring to freedom, not" - , "price. Our General Public Licenses are designed to make sure that you" - , "have the freedom to distribute copies of free software (and charge for" - , "them if you wish), that you receive source code or can get it if you" - , "want it, that you can change the software or use pieces of it in new" - , "free programs, and that you know you can do these things." - , "" - , " Developers that use our General Public Licenses protect your rights" - , "with two steps: (1) assert copyright on the software, and (2) offer" - , "you this License which gives you legal permission to copy, distribute" - , "and/or modify the software." - , "" - , " A secondary benefit of defending all users' freedom is that" - , "improvements made in alternate versions of the program, if they" - , "receive widespread use, become available for other developers to" - , "incorporate. Many developers of free software are heartened and" - , "encouraged by the resulting cooperation. However, in the case of" - , "software used on network servers, this result may fail to come about." - , "The GNU General Public License permits making a modified version and" - , "letting the public access it on a server without ever releasing its" - , "source code to the public." - , "" - , " The GNU Affero General Public License is designed specifically to" - , "ensure that, in such cases, the modified source code becomes available" - , "to the community. It requires the operator of a network server to" - , "provide the source code of the modified version running there to the" - , "users of that server. Therefore, public use of a modified version, on" - , "a publicly accessible server, gives the public access to the source" - , "code of the modified version." - , "" - , " An older license, called the Affero General Public License and" - , "published by Affero, was designed to accomplish similar goals. This is" - , "a different license, not a version of the Affero GPL, but Affero has" - , "released a new version of the Affero GPL which permits relicensing under" - , "this license." - , "" - , " The precise terms and conditions for copying, distribution and" - , "modification follow." - , "" - , " TERMS AND CONDITIONS" - , "" - , " 0. Definitions." - , "" - , " \"This License\" refers to version 3 of the GNU Affero General Public License." - , "" - , " \"Copyright\" also means copyright-like laws that apply to other kinds of" - , "works, such as semiconductor masks." - , "" - , " \"The Program\" refers to any copyrightable work licensed under this" - , "License. Each licensee is addressed as \"you\". \"Licensees\" and" - , "\"recipients\" may be individuals or organizations." - , "" - , " To \"modify\" a work means to copy from or adapt all or part of the work" - , "in a fashion requiring copyright permission, other than the making of an" - , "exact copy. The resulting work is called a \"modified version\" of the" - , "earlier work or a work \"based on\" the earlier work." - , "" - , " A \"covered work\" means either the unmodified Program or a work based" - , "on the Program." - , "" - , " To \"propagate\" a work means to do anything with it that, without" - , "permission, would make you directly or secondarily liable for" - , "infringement under applicable copyright law, except executing it on a" - , "computer or modifying a private copy. Propagation includes copying," - , "distribution (with or without modification), making available to the" - , "public, and in some countries other activities as well." - , "" - , " To \"convey\" a work means any kind of propagation that enables other" - , "parties to make or receive copies. Mere interaction with a user through" - , "a computer network, with no transfer of a copy, is not conveying." - , "" - , " An interactive user interface displays \"Appropriate Legal Notices\"" - , "to the extent that it includes a convenient and prominently visible" - , "feature that (1) displays an appropriate copyright notice, and (2)" - , "tells the user that there is no warranty for the work (except to the" - , "extent that warranties are provided), that licensees may convey the" - , "work under this License, and how to view a copy of this License. If" - , "the interface presents a list of user commands or options, such as a" - , "menu, a prominent item in the list meets this criterion." - , "" - , " 1. Source Code." - , "" - , " The \"source code\" for a work means the preferred form of the work" - , "for making modifications to it. \"Object code\" means any non-source" - , "form of a work." - , "" - , " A \"Standard Interface\" means an interface that either is an official" - , "standard defined by a recognized standards body, or, in the case of" - , "interfaces specified for a particular programming language, one that" - , "is widely used among developers working in that language." - , "" - , " The \"System Libraries\" of an executable work include anything, other" - , "than the work as a whole, that (a) is included in the normal form of" - , "packaging a Major Component, but which is not part of that Major" - , "Component, and (b) serves only to enable use of the work with that" - , "Major Component, or to implement a Standard Interface for which an" - , "implementation is available to the public in source code form. A" - , "\"Major Component\", in this context, means a major essential component" - , "(kernel, window system, and so on) of the specific operating system" - , "(if any) on which the executable work runs, or a compiler used to" - , "produce the work, or an object code interpreter used to run it." - , "" - , " The \"Corresponding Source\" for a work in object code form means all" - , "the source code needed to generate, install, and (for an executable" - , "work) run the object code and to modify the work, including scripts to" - , "control those activities. However, it does not include the work's" - , "System Libraries, or general-purpose tools or generally available free" - , "programs which are used unmodified in performing those activities but" - , "which are not part of the work. For example, Corresponding Source" - , "includes interface definition files associated with source files for" - , "the work, and the source code for shared libraries and dynamically" - , "linked subprograms that the work is specifically designed to require," - , "such as by intimate data communication or control flow between those" - , "subprograms and other parts of the work." - , "" - , " The Corresponding Source need not include anything that users" - , "can regenerate automatically from other parts of the Corresponding" - , "Source." - , "" - , " The Corresponding Source for a work in source code form is that" - , "same work." - , "" - , " 2. Basic Permissions." - , "" - , " All rights granted under this License are granted for the term of" - , "copyright on the Program, and are irrevocable provided the stated" - , "conditions are met. This License explicitly affirms your unlimited" - , "permission to run the unmodified Program. The output from running a" - , "covered work is covered by this License only if the output, given its" - , "content, constitutes a covered work. This License acknowledges your" - , "rights of fair use or other equivalent, as provided by copyright law." - , "" - , " You may make, run and propagate covered works that you do not" - , "convey, without conditions so long as your license otherwise remains" - , "in force. You may convey covered works to others for the sole purpose" - , "of having them make modifications exclusively for you, or provide you" - , "with facilities for running those works, provided that you comply with" - , "the terms of this License in conveying all material for which you do" - , "not control copyright. Those thus making or running the covered works" - , "for you must do so exclusively on your behalf, under your direction" - , "and control, on terms that prohibit them from making any copies of" - , "your copyrighted material outside their relationship with you." - , "" - , " Conveying under any other circumstances is permitted solely under" - , "the conditions stated below. Sublicensing is not allowed; section 10" - , "makes it unnecessary." - , "" - , " 3. Protecting Users' Legal Rights From Anti-Circumvention Law." - , "" - , " No covered work shall be deemed part of an effective technological" - , "measure under any applicable law fulfilling obligations under article" - , "11 of the WIPO copyright treaty adopted on 20 December 1996, or" - , "similar laws prohibiting or restricting circumvention of such" - , "measures." - , "" - , " When you convey a covered work, you waive any legal power to forbid" - , "circumvention of technological measures to the extent such circumvention" - , "is effected by exercising rights under this License with respect to" - , "the covered work, and you disclaim any intention to limit operation or" - , "modification of the work as a means of enforcing, against the work's" - , "users, your or third parties' legal rights to forbid circumvention of" - , "technological measures." - , "" - , " 4. Conveying Verbatim Copies." - , "" - , " You may convey verbatim copies of the Program's source code as you" - , "receive it, in any medium, provided that you conspicuously and" - , "appropriately publish on each copy an appropriate copyright notice;" - , "keep intact all notices stating that this License and any" - , "non-permissive terms added in accord with section 7 apply to the code;" - , "keep intact all notices of the absence of any warranty; and give all" - , "recipients a copy of this License along with the Program." - , "" - , " You may charge any price or no price for each copy that you convey," - , "and you may offer support or warranty protection for a fee." - , "" - , " 5. Conveying Modified Source Versions." - , "" - , " You may convey a work based on the Program, or the modifications to" - , "produce it from the Program, in the form of source code under the" - , "terms of section 4, provided that you also meet all of these conditions:" - , "" - , " a) The work must carry prominent notices stating that you modified" - , " it, and giving a relevant date." - , "" - , " b) The work must carry prominent notices stating that it is" - , " released under this License and any conditions added under section" - , " 7. This requirement modifies the requirement in section 4 to" - , " \"keep intact all notices\"." - , "" - , " c) You must license the entire work, as a whole, under this" - , " License to anyone who comes into possession of a copy. This" - , " License will therefore apply, along with any applicable section 7" - , " additional terms, to the whole of the work, and all its parts," - , " regardless of how they are packaged. This License gives no" - , " permission to license the work in any other way, but it does not" - , " invalidate such permission if you have separately received it." - , "" - , " d) If the work has interactive user interfaces, each must display" - , " Appropriate Legal Notices; however, if the Program has interactive" - , " interfaces that do not display Appropriate Legal Notices, your" - , " work need not make them do so." - , "" - , " A compilation of a covered work with other separate and independent" - , "works, which are not by their nature extensions of the covered work," - , "and which are not combined with it such as to form a larger program," - , "in or on a volume of a storage or distribution medium, is called an" - , "\"aggregate\" if the compilation and its resulting copyright are not" - , "used to limit the access or legal rights of the compilation's users" - , "beyond what the individual works permit. Inclusion of a covered work" - , "in an aggregate does not cause this License to apply to the other" - , "parts of the aggregate." - , "" - , " 6. Conveying Non-Source Forms." - , "" - , " You may convey a covered work in object code form under the terms" - , "of sections 4 and 5, provided that you also convey the" - , "machine-readable Corresponding Source under the terms of this License," - , "in one of these ways:" - , "" - , " a) Convey the object code in, or embodied in, a physical product" - , " (including a physical distribution medium), accompanied by the" - , " Corresponding Source fixed on a durable physical medium" - , " customarily used for software interchange." - , "" - , " b) Convey the object code in, or embodied in, a physical product" - , " (including a physical distribution medium), accompanied by a" - , " written offer, valid for at least three years and valid for as" - , " long as you offer spare parts or customer support for that product" - , " model, to give anyone who possesses the object code either (1) a" - , " copy of the Corresponding Source for all the software in the" - , " product that is covered by this License, on a durable physical" - , " medium customarily used for software interchange, for a price no" - , " more than your reasonable cost of physically performing this" - , " conveying of source, or (2) access to copy the" - , " Corresponding Source from a network server at no charge." - , "" - , " c) Convey individual copies of the object code with a copy of the" - , " written offer to provide the Corresponding Source. This" - , " alternative is allowed only occasionally and noncommercially, and" - , " only if you received the object code with such an offer, in accord" - , " with subsection 6b." - , "" - , " d) Convey the object code by offering access from a designated" - , " place (gratis or for a charge), and offer equivalent access to the" - , " Corresponding Source in the same way through the same place at no" - , " further charge. You need not require recipients to copy the" - , " Corresponding Source along with the object code. If the place to" - , " copy the object code is a network server, the Corresponding Source" - , " may be on a different server (operated by you or a third party)" - , " that supports equivalent copying facilities, provided you maintain" - , " clear directions next to the object code saying where to find the" - , " Corresponding Source. Regardless of what server hosts the" - , " Corresponding Source, you remain obligated to ensure that it is" - , " available for as long as needed to satisfy these requirements." - , "" - , " e) Convey the object code using peer-to-peer transmission, provided" - , " you inform other peers where the object code and Corresponding" - , " Source of the work are being offered to the general public at no" - , " charge under subsection 6d." - , "" - , " A separable portion of the object code, whose source code is excluded" - , "from the Corresponding Source as a System Library, need not be" - , "included in conveying the object code work." - , "" - , " A \"User Product\" is either (1) a \"consumer product\", which means any" - , "tangible personal property which is normally used for personal, family," - , "or household purposes, or (2) anything designed or sold for incorporation" - , "into a dwelling. In determining whether a product is a consumer product," - , "doubtful cases shall be resolved in favor of coverage. For a particular" - , "product received by a particular user, \"normally used\" refers to a" - , "typical or common use of that class of product, regardless of the status" - , "of the particular user or of the way in which the particular user" - , "actually uses, or expects or is expected to use, the product. A product" - , "is a consumer product regardless of whether the product has substantial" - , "commercial, industrial or non-consumer uses, unless such uses represent" - , "the only significant mode of use of the product." - , "" - , " \"Installation Information\" for a User Product means any methods," - , "procedures, authorization keys, or other information required to install" - , "and execute modified versions of a covered work in that User Product from" - , "a modified version of its Corresponding Source. The information must" - , "suffice to ensure that the continued functioning of the modified object" - , "code is in no case prevented or interfered with solely because" - , "modification has been made." - , "" - , " If you convey an object code work under this section in, or with, or" - , "specifically for use in, a User Product, and the conveying occurs as" - , "part of a transaction in which the right of possession and use of the" - , "User Product is transferred to the recipient in perpetuity or for a" - , "fixed term (regardless of how the transaction is characterized), the" - , "Corresponding Source conveyed under this section must be accompanied" - , "by the Installation Information. But this requirement does not apply" - , "if neither you nor any third party retains the ability to install" - , "modified object code on the User Product (for example, the work has" - , "been installed in ROM)." - , "" - , " The requirement to provide Installation Information does not include a" - , "requirement to continue to provide support service, warranty, or updates" - , "for a work that has been modified or installed by the recipient, or for" - , "the User Product in which it has been modified or installed. Access to a" - , "network may be denied when the modification itself materially and" - , "adversely affects the operation of the network or violates the rules and" - , "protocols for communication across the network." - , "" - , " Corresponding Source conveyed, and Installation Information provided," - , "in accord with this section must be in a format that is publicly" - , "documented (and with an implementation available to the public in" - , "source code form), and must require no special password or key for" - , "unpacking, reading or copying." - , "" - , " 7. Additional Terms." - , "" - , " \"Additional permissions\" are terms that supplement the terms of this" - , "License by making exceptions from one or more of its conditions." - , "Additional permissions that are applicable to the entire Program shall" - , "be treated as though they were included in this License, to the extent" - , "that they are valid under applicable law. If additional permissions" - , "apply only to part of the Program, that part may be used separately" - , "under those permissions, but the entire Program remains governed by" - , "this License without regard to the additional permissions." - , "" - , " When you convey a copy of a covered work, you may at your option" - , "remove any additional permissions from that copy, or from any part of" - , "it. (Additional permissions may be written to require their own" - , "removal in certain cases when you modify the work.) You may place" - , "additional permissions on material, added by you to a covered work," - , "for which you have or can give appropriate copyright permission." - , "" - , " Notwithstanding any other provision of this License, for material you" - , "add to a covered work, you may (if authorized by the copyright holders of" - , "that material) supplement the terms of this License with terms:" - , "" - , " a) Disclaiming warranty or limiting liability differently from the" - , " terms of sections 15 and 16 of this License; or" - , "" - , " b) Requiring preservation of specified reasonable legal notices or" - , " author attributions in that material or in the Appropriate Legal" - , " Notices displayed by works containing it; or" - , "" - , " c) Prohibiting misrepresentation of the origin of that material, or" - , " requiring that modified versions of such material be marked in" - , " reasonable ways as different from the original version; or" - , "" - , " d) Limiting the use for publicity purposes of names of licensors or" - , " authors of the material; or" - , "" - , " e) Declining to grant rights under trademark law for use of some" - , " trade names, trademarks, or service marks; or" - , "" - , " f) Requiring indemnification of licensors and authors of that" - , " material by anyone who conveys the material (or modified versions of" - , " it) with contractual assumptions of liability to the recipient, for" - , " any liability that these contractual assumptions directly impose on" - , " those licensors and authors." - , "" - , " All other non-permissive additional terms are considered \"further" - , "restrictions\" within the meaning of section 10. If the Program as you" - , "received it, or any part of it, contains a notice stating that it is" - , "governed by this License along with a term that is a further" - , "restriction, you may remove that term. If a license document contains" - , "a further restriction but permits relicensing or conveying under this" - , "License, you may add to a covered work material governed by the terms" - , "of that license document, provided that the further restriction does" - , "not survive such relicensing or conveying." - , "" - , " If you add terms to a covered work in accord with this section, you" - , "must place, in the relevant source files, a statement of the" - , "additional terms that apply to those files, or a notice indicating" - , "where to find the applicable terms." - , "" - , " Additional terms, permissive or non-permissive, may be stated in the" - , "form of a separately written license, or stated as exceptions;" - , "the above requirements apply either way." - , "" - , " 8. Termination." - , "" - , " You may not propagate or modify a covered work except as expressly" - , "provided under this License. Any attempt otherwise to propagate or" - , "modify it is void, and will automatically terminate your rights under" - , "this License (including any patent licenses granted under the third" - , "paragraph of section 11)." - , "" - , " However, if you cease all violation of this License, then your" - , "license from a particular copyright holder is reinstated (a)" - , "provisionally, unless and until the copyright holder explicitly and" - , "finally terminates your license, and (b) permanently, if the copyright" - , "holder fails to notify you of the violation by some reasonable means" - , "prior to 60 days after the cessation." - , "" - , " Moreover, your license from a particular copyright holder is" - , "reinstated permanently if the copyright holder notifies you of the" - , "violation by some reasonable means, this is the first time you have" - , "received notice of violation of this License (for any work) from that" - , "copyright holder, and you cure the violation prior to 30 days after" - , "your receipt of the notice." - , "" - , " Termination of your rights under this section does not terminate the" - , "licenses of parties who have received copies or rights from you under" - , "this License. If your rights have been terminated and not permanently" - , "reinstated, you do not qualify to receive new licenses for the same" - , "material under section 10." - , "" - , " 9. Acceptance Not Required for Having Copies." - , "" - , " You are not required to accept this License in order to receive or" - , "run a copy of the Program. Ancillary propagation of a covered work" - , "occurring solely as a consequence of using peer-to-peer transmission" - , "to receive a copy likewise does not require acceptance. However," - , "nothing other than this License grants you permission to propagate or" - , "modify any covered work. These actions infringe copyright if you do" - , "not accept this License. Therefore, by modifying or propagating a" - , "covered work, you indicate your acceptance of this License to do so." - , "" - , " 10. Automatic Licensing of Downstream Recipients." - , "" - , " Each time you convey a covered work, the recipient automatically" - , "receives a license from the original licensors, to run, modify and" - , "propagate that work, subject to this License. You are not responsible" - , "for enforcing compliance by third parties with this License." - , "" - , " An \"entity transaction\" is a transaction transferring control of an" - , "organization, or substantially all assets of one, or subdividing an" - , "organization, or merging organizations. If propagation of a covered" - , "work results from an entity transaction, each party to that" - , "transaction who receives a copy of the work also receives whatever" - , "licenses to the work the party's predecessor in interest had or could" - , "give under the previous paragraph, plus a right to possession of the" - , "Corresponding Source of the work from the predecessor in interest, if" - , "the predecessor has it or can get it with reasonable efforts." - , "" - , " You may not impose any further restrictions on the exercise of the" - , "rights granted or affirmed under this License. For example, you may" - , "not impose a license fee, royalty, or other charge for exercise of" - , "rights granted under this License, and you may not initiate litigation" - , "(including a cross-claim or counterclaim in a lawsuit) alleging that" - , "any patent claim is infringed by making, using, selling, offering for" - , "sale, or importing the Program or any portion of it." - , "" - , " 11. Patents." - , "" - , " A \"contributor\" is a copyright holder who authorizes use under this" - , "License of the Program or a work on which the Program is based. The" - , "work thus licensed is called the contributor's \"contributor version\"." - , "" - , " A contributor's \"essential patent claims\" are all patent claims" - , "owned or controlled by the contributor, whether already acquired or" - , "hereafter acquired, that would be infringed by some manner, permitted" - , "by this License, of making, using, or selling its contributor version," - , "but do not include claims that would be infringed only as a" - , "consequence of further modification of the contributor version. For" - , "purposes of this definition, \"control\" includes the right to grant" - , "patent sublicenses in a manner consistent with the requirements of" - , "this License." - , "" - , " Each contributor grants you a non-exclusive, worldwide, royalty-free" - , "patent license under the contributor's essential patent claims, to" - , "make, use, sell, offer for sale, import and otherwise run, modify and" - , "propagate the contents of its contributor version." - , "" - , " In the following three paragraphs, a \"patent license\" is any express" - , "agreement or commitment, however denominated, not to enforce a patent" - , "(such as an express permission to practice a patent or covenant not to" - , "sue for patent infringement). To \"grant\" such a patent license to a" - , "party means to make such an agreement or commitment not to enforce a" - , "patent against the party." - , "" - , " If you convey a covered work, knowingly relying on a patent license," - , "and the Corresponding Source of the work is not available for anyone" - , "to copy, free of charge and under the terms of this License, through a" - , "publicly available network server or other readily accessible means," - , "then you must either (1) cause the Corresponding Source to be so" - , "available, or (2) arrange to deprive yourself of the benefit of the" - , "patent license for this particular work, or (3) arrange, in a manner" - , "consistent with the requirements of this License, to extend the patent" - , "license to downstream recipients. \"Knowingly relying\" means you have" - , "actual knowledge that, but for the patent license, your conveying the" - , "covered work in a country, or your recipient's use of the covered work" - , "in a country, would infringe one or more identifiable patents in that" - , "country that you have reason to believe are valid." - , "" - , " If, pursuant to or in connection with a single transaction or" - , "arrangement, you convey, or propagate by procuring conveyance of, a" - , "covered work, and grant a patent license to some of the parties" - , "receiving the covered work authorizing them to use, propagate, modify" - , "or convey a specific copy of the covered work, then the patent license" - , "you grant is automatically extended to all recipients of the covered" - , "work and works based on it." - , "" - , " A patent license is \"discriminatory\" if it does not include within" - , "the scope of its coverage, prohibits the exercise of, or is" - , "conditioned on the non-exercise of one or more of the rights that are" - , "specifically granted under this License. You may not convey a covered" - , "work if you are a party to an arrangement with a third party that is" - , "in the business of distributing software, under which you make payment" - , "to the third party based on the extent of your activity of conveying" - , "the work, and under which the third party grants, to any of the" - , "parties who would receive the covered work from you, a discriminatory" - , "patent license (a) in connection with copies of the covered work" - , "conveyed by you (or copies made from those copies), or (b) primarily" - , "for and in connection with specific products or compilations that" - , "contain the covered work, unless you entered into that arrangement," - , "or that patent license was granted, prior to 28 March 2007." - , "" - , " Nothing in this License shall be construed as excluding or limiting" - , "any implied license or other defenses to infringement that may" - , "otherwise be available to you under applicable patent law." - , "" - , " 12. No Surrender of Others' Freedom." - , "" - , " If conditions are imposed on you (whether by court order, agreement or" - , "otherwise) that contradict the conditions of this License, they do not" - , "excuse you from the conditions of this License. If you cannot convey a" - , "covered work so as to satisfy simultaneously your obligations under this" - , "License and any other pertinent obligations, then as a consequence you may" - , "not convey it at all. For example, if you agree to terms that obligate you" - , "to collect a royalty for further conveying from those to whom you convey" - , "the Program, the only way you could satisfy both those terms and this" - , "License would be to refrain entirely from conveying the Program." - , "" - , " 13. Remote Network Interaction; Use with the GNU General Public License." - , "" - , " Notwithstanding any other provision of this License, if you modify the" - , "Program, your modified version must prominently offer all users" - , "interacting with it remotely through a computer network (if your version" - , "supports such interaction) an opportunity to receive the Corresponding" - , "Source of your version by providing access to the Corresponding Source" - , "from a network server at no charge, through some standard or customary" - , "means of facilitating copying of software. This Corresponding Source" - , "shall include the Corresponding Source for any work covered by version 3" - , "of the GNU General Public License that is incorporated pursuant to the" - , "following paragraph." - , "" - , " Notwithstanding any other provision of this License, you have" - , "permission to link or combine any covered work with a work licensed" - , "under version 3 of the GNU General Public License into a single" - , "combined work, and to convey the resulting work. The terms of this" - , "License will continue to apply to the part which is the covered work," - , "but the work with which it is combined will remain governed by version" - , "3 of the GNU General Public License." - , "" - , " 14. Revised Versions of this License." - , "" - , " The Free Software Foundation may publish revised and/or new versions of" - , "the GNU Affero General Public License from time to time. Such new versions" - , "will be similar in spirit to the present version, but may differ in detail to" - , "address new problems or concerns." - , "" - , " Each version is given a distinguishing version number. If the" - , "Program specifies that a certain numbered version of the GNU Affero General" - , "Public License \"or any later version\" applies to it, you have the" - , "option of following the terms and conditions either of that numbered" - , "version or of any later version published by the Free Software" - , "Foundation. If the Program does not specify a version number of the" - , "GNU Affero General Public License, you may choose any version ever published" - , "by the Free Software Foundation." - , "" - , " If the Program specifies that a proxy can decide which future" - , "versions of the GNU Affero General Public License can be used, that proxy's" - , "public statement of acceptance of a version permanently authorizes you" - , "to choose that version for the Program." - , "" - , " Later license versions may give you additional or different" - , "permissions. However, no additional obligations are imposed on any" - , "author or copyright holder as a result of your choosing to follow a" - , "later version." - , "" - , " 15. Disclaimer of Warranty." - , "" - , " THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY" - , "APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT" - , "HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY" - , "OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO," - , "THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR" - , "PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM" - , "IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF" - , "ALL NECESSARY SERVICING, REPAIR OR CORRECTION." - , "" - , " 16. Limitation of Liability." - , "" - , " IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING" - , "WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS" - , "THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY" - , "GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE" - , "USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF" - , "DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD" - , "PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS)," - , "EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF" - , "SUCH DAMAGES." - , "" - , " 17. Interpretation of Sections 15 and 16." - , "" - , " If the disclaimer of warranty and limitation of liability provided" - , "above cannot be given local legal effect according to their terms," - , "reviewing courts shall apply local law that most closely approximates" - , "an absolute waiver of all civil liability in connection with the" - , "Program, unless a warranty or assumption of liability accompanies a" - , "copy of the Program in return for a fee." - , "" - , " END OF TERMS AND CONDITIONS" - , "" - , " How to Apply These Terms to Your New Programs" - , "" - , " If you develop a new program, and you want it to be of the greatest" - , "possible use to the public, the best way to achieve this is to make it" - , "free software which everyone can redistribute and change under these terms." - , "" - , " To do so, attach the following notices to the program. It is safest" - , "to attach them to the start of each source file to most effectively" - , "state the exclusion of warranty; and each file should have at least" - , "the \"copyright\" line and a pointer to where the full notice is found." - , "" - , " " - , " Copyright (C) " - , "" - , " This program is free software: you can redistribute it and/or modify" - , " it under the terms of the GNU Affero General Public License as published by" - , " the Free Software Foundation, either version 3 of the License, or" - , " (at your option) any later version." - , "" - , " This program is distributed in the hope that it will be useful," - , " but WITHOUT ANY WARRANTY; without even the implied warranty of" - , " MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the" - , " GNU Affero General Public License for more details." - , "" - , " You should have received a copy of the GNU Affero General Public License" - , " along with this program. If not, see ." - , "" - , "Also add information on how to contact you by electronic and paper mail." - , "" - , " If your software can interact with users remotely through a computer" - , "network, you should also make sure that it provides a way for users to" - , "get its source. For example, if your program is a web application, its" - , "interface could display a \"Source\" link that leads users to an archive" - , "of the code. There are many ways you could offer source, and different" - , "solutions will be better for different programs; see section 13 for the" - , "specific requirements." - , "" - , " You should also get your employer (if you work as a programmer) or school," - , "if any, to sign a \"copyright disclaimer\" for the program, if necessary." - , "For more information on this, and how to apply and follow the GNU AGPL, see" - , "." - ] - -lgpl21 :: License -lgpl21 = unlines - [ " GNU LESSER GENERAL PUBLIC LICENSE" - , " Version 2.1, February 1999" - , "" - , " Copyright (C) 1991, 1999 Free Software Foundation, Inc." - , " 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA" - , " Everyone is permitted to copy and distribute verbatim copies" - , " of this license document, but changing it is not allowed." - , "" - , "[This is the first released version of the Lesser GPL. It also counts" - , " as the successor of the GNU Library Public License, version 2, hence" - , " the version number 2.1.]" - , "" - , " Preamble" - , "" - , " The licenses for most software are designed to take away your" - , "freedom to share and change it. By contrast, the GNU General Public" - , "Licenses are intended to guarantee your freedom to share and change" - , "free software--to make sure the software is free for all its users." - , "" - , " This license, the Lesser General Public License, applies to some" - , "specially designated software packages--typically libraries--of the" - , "Free Software Foundation and other authors who decide to use it. You" - , "can use it too, but we suggest you first think carefully about whether" - , "this license or the ordinary General Public License is the better" - , "strategy to use in any particular case, based on the explanations below." - , "" - , " When we speak of free software, we are referring to freedom of use," - , "not price. Our General Public Licenses are designed to make sure that" - , "you have the freedom to distribute copies of free software (and charge" - , "for this service if you wish); that you receive source code or can get" - , "it if you want it; that you can change the software and use pieces of" - , "it in new free programs; and that you are informed that you can do" - , "these things." - , "" - , " To protect your rights, we need to make restrictions that forbid" - , "distributors to deny you these rights or to ask you to surrender these" - , "rights. These restrictions translate to certain responsibilities for" - , "you if you distribute copies of the library or if you modify it." - , "" - , " For example, if you distribute copies of the library, whether gratis" - , "or for a fee, you must give the recipients all the rights that we gave" - , "you. You must make sure that they, too, receive or can get the source" - , "code. If you link other code with the library, you must provide" - , "complete object files to the recipients, so that they can relink them" - , "with the library after making changes to the library and recompiling" - , "it. And you must show them these terms so they know their rights." - , "" - , " We protect your rights with a two-step method: (1) we copyright the" - , "library, and (2) we offer you this license, which gives you legal" - , "permission to copy, distribute and/or modify the library." - , "" - , " To protect each distributor, we want to make it very clear that" - , "there is no warranty for the free library. Also, if the library is" - , "modified by someone else and passed on, the recipients should know" - , "that what they have is not the original version, so that the original" - , "author's reputation will not be affected by problems that might be" - , "introduced by others." - , "" - , " Finally, software patents pose a constant threat to the existence of" - , "any free program. We wish to make sure that a company cannot" - , "effectively restrict the users of a free program by obtaining a" - , "restrictive license from a patent holder. Therefore, we insist that" - , "any patent license obtained for a version of the library must be" - , "consistent with the full freedom of use specified in this license." - , "" - , " Most GNU software, including some libraries, is covered by the" - , "ordinary GNU General Public License. This license, the GNU Lesser" - , "General Public License, applies to certain designated libraries, and" - , "is quite different from the ordinary General Public License. We use" - , "this license for certain libraries in order to permit linking those" - , "libraries into non-free programs." - , "" - , " When a program is linked with a library, whether statically or using" - , "a shared library, the combination of the two is legally speaking a" - , "combined work, a derivative of the original library. The ordinary" - , "General Public License therefore permits such linking only if the" - , "entire combination fits its criteria of freedom. The Lesser General" - , "Public License permits more lax criteria for linking other code with" - , "the library." - , "" - , " We call this license the \"Lesser\" General Public License because it" - , "does Less to protect the user's freedom than the ordinary General" - , "Public License. It also provides other free software developers Less" - , "of an advantage over competing non-free programs. These disadvantages" - , "are the reason we use the ordinary General Public License for many" - , "libraries. However, the Lesser license provides advantages in certain" - , "special circumstances." - , "" - , " For example, on rare occasions, there may be a special need to" - , "encourage the widest possible use of a certain library, so that it becomes" - , "a de-facto standard. To achieve this, non-free programs must be" - , "allowed to use the library. A more frequent case is that a free" - , "library does the same job as widely used non-free libraries. In this" - , "case, there is little to gain by limiting the free library to free" - , "software only, so we use the Lesser General Public License." - , "" - , " In other cases, permission to use a particular library in non-free" - , "programs enables a greater number of people to use a large body of" - , "free software. For example, permission to use the GNU C Library in" - , "non-free programs enables many more people to use the whole GNU" - , "operating system, as well as its variant, the GNU/Linux operating" - , "system." - , "" - , " Although the Lesser General Public License is Less protective of the" - , "users' freedom, it does ensure that the user of a program that is" - , "linked with the Library has the freedom and the wherewithal to run" - , "that program using a modified version of the Library." - , "" - , " The precise terms and conditions for copying, distribution and" - , "modification follow. Pay close attention to the difference between a" - , "\"work based on the library\" and a \"work that uses the library\". The" - , "former contains code derived from the library, whereas the latter must" - , "be combined with the library in order to run." - , "" - , " GNU LESSER GENERAL PUBLIC LICENSE" - , " TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION" - , "" - , " 0. This License Agreement applies to any software library or other" - , "program which contains a notice placed by the copyright holder or" - , "other authorized party saying it may be distributed under the terms of" - , "this Lesser General Public License (also called \"this License\")." - , "Each licensee is addressed as \"you\"." - , "" - , " A \"library\" means a collection of software functions and/or data" - , "prepared so as to be conveniently linked with application programs" - , "(which use some of those functions and data) to form executables." - , "" - , " The \"Library\", below, refers to any such software library or work" - , "which has been distributed under these terms. A \"work based on the" - , "Library\" means either the Library or any derivative work under" - , "copyright law: that is to say, a work containing the Library or a" - , "portion of it, either verbatim or with modifications and/or translated" - , "straightforwardly into another language. (Hereinafter, translation is" - , "included without limitation in the term \"modification\".)" - , "" - , " \"Source code\" for a work means the preferred form of the work for" - , "making modifications to it. For a library, complete source code means" - , "all the source code for all modules it contains, plus any associated" - , "interface definition files, plus the scripts used to control compilation" - , "and installation of the library." - , "" - , " Activities other than copying, distribution and modification are not" - , "covered by this License; they are outside its scope. The act of" - , "running a program using the Library is not restricted, and output from" - , "such a program is covered only if its contents constitute a work based" - , "on the Library (independent of the use of the Library in a tool for" - , "writing it). Whether that is true depends on what the Library does" - , "and what the program that uses the Library does." - , "" - , " 1. You may copy and distribute verbatim copies of the Library's" - , "complete source code as you receive it, in any medium, provided that" - , "you conspicuously and appropriately publish on each copy an" - , "appropriate copyright notice and disclaimer of warranty; keep intact" - , "all the notices that refer to this License and to the absence of any" - , "warranty; and distribute a copy of this License along with the" - , "Library." - , "" - , " You may charge a fee for the physical act of transferring a copy," - , "and you may at your option offer warranty protection in exchange for a" - , "fee." - , "" - , " 2. You may modify your copy or copies of the Library or any portion" - , "of it, thus forming a work based on the Library, and copy and" - , "distribute such modifications or work under the terms of Section 1" - , "above, provided that you also meet all of these conditions:" - , "" - , " a) The modified work must itself be a software library." - , "" - , " b) You must cause the files modified to carry prominent notices" - , " stating that you changed the files and the date of any change." - , "" - , " c) You must cause the whole of the work to be licensed at no" - , " charge to all third parties under the terms of this License." - , "" - , " d) If a facility in the modified Library refers to a function or a" - , " table of data to be supplied by an application program that uses" - , " the facility, other than as an argument passed when the facility" - , " is invoked, then you must make a good faith effort to ensure that," - , " in the event an application does not supply such function or" - , " table, the facility still operates, and performs whatever part of" - , " its purpose remains meaningful." - , "" - , " (For example, a function in a library to compute square roots has" - , " a purpose that is entirely well-defined independent of the" - , " application. Therefore, Subsection 2d requires that any" - , " application-supplied function or table used by this function must" - , " be optional: if the application does not supply it, the square" - , " root function must still compute square roots.)" - , "" - , "These requirements apply to the modified work as a whole. If" - , "identifiable sections of that work are not derived from the Library," - , "and can be reasonably considered independent and separate works in" - , "themselves, then this License, and its terms, do not apply to those" - , "sections when you distribute them as separate works. But when you" - , "distribute the same sections as part of a whole which is a work based" - , "on the Library, the distribution of the whole must be on the terms of" - , "this License, whose permissions for other licensees extend to the" - , "entire whole, and thus to each and every part regardless of who wrote" - , "it." - , "" - , "Thus, it is not the intent of this section to claim rights or contest" - , "your rights to work written entirely by you; rather, the intent is to" - , "exercise the right to control the distribution of derivative or" - , "collective works based on the Library." - , "" - , "In addition, mere aggregation of another work not based on the Library" - , "with the Library (or with a work based on the Library) on a volume of" - , "a storage or distribution medium does not bring the other work under" - , "the scope of this License." - , "" - , " 3. You may opt to apply the terms of the ordinary GNU General Public" - , "License instead of this License to a given copy of the Library. To do" - , "this, you must alter all the notices that refer to this License, so" - , "that they refer to the ordinary GNU General Public License, version 2," - , "instead of to this License. (If a newer version than version 2 of the" - , "ordinary GNU General Public License has appeared, then you can specify" - , "that version instead if you wish.) Do not make any other change in" - , "these notices." - , "" - , " Once this change is made in a given copy, it is irreversible for" - , "that copy, so the ordinary GNU General Public License applies to all" - , "subsequent copies and derivative works made from that copy." - , "" - , " This option is useful when you wish to copy part of the code of" - , "the Library into a program that is not a library." - , "" - , " 4. You may copy and distribute the Library (or a portion or" - , "derivative of it, under Section 2) in object code or executable form" - , "under the terms of Sections 1 and 2 above provided that you accompany" - , "it with the complete corresponding machine-readable source code, which" - , "must be distributed under the terms of Sections 1 and 2 above on a" - , "medium customarily used for software interchange." - , "" - , " If distribution of object code is made by offering access to copy" - , "from a designated place, then offering equivalent access to copy the" - , "source code from the same place satisfies the requirement to" - , "distribute the source code, even though third parties are not" - , "compelled to copy the source along with the object code." - , "" - , " 5. A program that contains no derivative of any portion of the" - , "Library, but is designed to work with the Library by being compiled or" - , "linked with it, is called a \"work that uses the Library\". Such a" - , "work, in isolation, is not a derivative work of the Library, and" - , "therefore falls outside the scope of this License." - , "" - , " However, linking a \"work that uses the Library\" with the Library" - , "creates an executable that is a derivative of the Library (because it" - , "contains portions of the Library), rather than a \"work that uses the" - , "library\". The executable is therefore covered by this License." - , "Section 6 states terms for distribution of such executables." - , "" - , " When a \"work that uses the Library\" uses material from a header file" - , "that is part of the Library, the object code for the work may be a" - , "derivative work of the Library even though the source code is not." - , "Whether this is true is especially significant if the work can be" - , "linked without the Library, or if the work is itself a library. The" - , "threshold for this to be true is not precisely defined by law." - , "" - , " If such an object file uses only numerical parameters, data" - , "structure layouts and accessors, and small macros and small inline" - , "functions (ten lines or less in length), then the use of the object" - , "file is unrestricted, regardless of whether it is legally a derivative" - , "work. (Executables containing this object code plus portions of the" - , "Library will still fall under Section 6.)" - , "" - , " Otherwise, if the work is a derivative of the Library, you may" - , "distribute the object code for the work under the terms of Section 6." - , "Any executables containing that work also fall under Section 6," - , "whether or not they are linked directly with the Library itself." - , "" - , " 6. As an exception to the Sections above, you may also combine or" - , "link a \"work that uses the Library\" with the Library to produce a" - , "work containing portions of the Library, and distribute that work" - , "under terms of your choice, provided that the terms permit" - , "modification of the work for the customer's own use and reverse" - , "engineering for debugging such modifications." - , "" - , " You must give prominent notice with each copy of the work that the" - , "Library is used in it and that the Library and its use are covered by" - , "this License. You must supply a copy of this License. If the work" - , "during execution displays copyright notices, you must include the" - , "copyright notice for the Library among them, as well as a reference" - , "directing the user to the copy of this License. Also, you must do one" - , "of these things:" - , "" - , " a) Accompany the work with the complete corresponding" - , " machine-readable source code for the Library including whatever" - , " changes were used in the work (which must be distributed under" - , " Sections 1 and 2 above); and, if the work is an executable linked" - , " with the Library, with the complete machine-readable \"work that" - , " uses the Library\", as object code and/or source code, so that the" - , " user can modify the Library and then relink to produce a modified" - , " executable containing the modified Library. (It is understood" - , " that the user who changes the contents of definitions files in the" - , " Library will not necessarily be able to recompile the application" - , " to use the modified definitions.)" - , "" - , " b) Use a suitable shared library mechanism for linking with the" - , " Library. A suitable mechanism is one that (1) uses at run time a" - , " copy of the library already present on the user's computer system," - , " rather than copying library functions into the executable, and (2)" - , " will operate properly with a modified version of the library, if" - , " the user installs one, as long as the modified version is" - , " interface-compatible with the version that the work was made with." - , "" - , " c) Accompany the work with a written offer, valid for at" - , " least three years, to give the same user the materials" - , " specified in Subsection 6a, above, for a charge no more" - , " than the cost of performing this distribution." - , "" - , " d) If distribution of the work is made by offering access to copy" - , " from a designated place, offer equivalent access to copy the above" - , " specified materials from the same place." - , "" - , " e) Verify that the user has already received a copy of these" - , " materials or that you have already sent this user a copy." - , "" - , " For an executable, the required form of the \"work that uses the" - , "Library\" must include any data and utility programs needed for" - , "reproducing the executable from it. However, as a special exception," - , "the materials to be distributed need not include anything that is" - , "normally distributed (in either source or binary form) with the major" - , "components (compiler, kernel, and so on) of the operating system on" - , "which the executable runs, unless that component itself accompanies" - , "the executable." - , "" - , " It may happen that this requirement contradicts the license" - , "restrictions of other proprietary libraries that do not normally" - , "accompany the operating system. Such a contradiction means you cannot" - , "use both them and the Library together in an executable that you" - , "distribute." - , "" - , " 7. You may place library facilities that are a work based on the" - , "Library side-by-side in a single library together with other library" - , "facilities not covered by this License, and distribute such a combined" - , "library, provided that the separate distribution of the work based on" - , "the Library and of the other library facilities is otherwise" - , "permitted, and provided that you do these two things:" - , "" - , " a) Accompany the combined library with a copy of the same work" - , " based on the Library, uncombined with any other library" - , " facilities. This must be distributed under the terms of the" - , " Sections above." - , "" - , " b) Give prominent notice with the combined library of the fact" - , " that part of it is a work based on the Library, and explaining" - , " where to find the accompanying uncombined form of the same work." - , "" - , " 8. You may not copy, modify, sublicense, link with, or distribute" - , "the Library except as expressly provided under this License. Any" - , "attempt otherwise to copy, modify, sublicense, link with, or" - , "distribute the Library is void, and will automatically terminate your" - , "rights under this License. However, parties who have received copies," - , "or rights, from you under this License will not have their licenses" - , "terminated so long as such parties remain in full compliance." - , "" - , " 9. You are not required to accept this License, since you have not" - , "signed it. However, nothing else grants you permission to modify or" - , "distribute the Library or its derivative works. These actions are" - , "prohibited by law if you do not accept this License. Therefore, by" - , "modifying or distributing the Library (or any work based on the" - , "Library), you indicate your acceptance of this License to do so, and" - , "all its terms and conditions for copying, distributing or modifying" - , "the Library or works based on it." - , "" - , " 10. Each time you redistribute the Library (or any work based on the" - , "Library), the recipient automatically receives a license from the" - , "original licensor to copy, distribute, link with or modify the Library" - , "subject to these terms and conditions. You may not impose any further" - , "restrictions on the recipients' exercise of the rights granted herein." - , "You are not responsible for enforcing compliance by third parties with" - , "this License." - , "" - , " 11. If, as a consequence of a court judgment or allegation of patent" - , "infringement or for any other reason (not limited to patent issues)," - , "conditions are imposed on you (whether by court order, agreement or" - , "otherwise) that contradict the conditions of this License, they do not" - , "excuse you from the conditions of this License. If you cannot" - , "distribute so as to satisfy simultaneously your obligations under this" - , "License and any other pertinent obligations, then as a consequence you" - , "may not distribute the Library at all. For example, if a patent" - , "license would not permit royalty-free redistribution of the Library by" - , "all those who receive copies directly or indirectly through you, then" - , "the only way you could satisfy both it and this License would be to" - , "refrain entirely from distribution of the Library." - , "" - , "If any portion of this section is held invalid or unenforceable under any" - , "particular circumstance, the balance of the section is intended to apply," - , "and the section as a whole is intended to apply in other circumstances." - , "" - , "It is not the purpose of this section to induce you to infringe any" - , "patents or other property right claims or to contest validity of any" - , "such claims; this section has the sole purpose of protecting the" - , "integrity of the free software distribution system which is" - , "implemented by public license practices. Many people have made" - , "generous contributions to the wide range of software distributed" - , "through that system in reliance on consistent application of that" - , "system; it is up to the author/donor to decide if he or she is willing" - , "to distribute software through any other system and a licensee cannot" - , "impose that choice." - , "" - , "This section is intended to make thoroughly clear what is believed to" - , "be a consequence of the rest of this License." - , "" - , " 12. If the distribution and/or use of the Library is restricted in" - , "certain countries either by patents or by copyrighted interfaces, the" - , "original copyright holder who places the Library under this License may add" - , "an explicit geographical distribution limitation excluding those countries," - , "so that distribution is permitted only in or among countries not thus" - , "excluded. In such case, this License incorporates the limitation as if" - , "written in the body of this License." - , "" - , " 13. The Free Software Foundation may publish revised and/or new" - , "versions of the Lesser General Public License from time to time." - , "Such new versions will be similar in spirit to the present version," - , "but may differ in detail to address new problems or concerns." - , "" - , "Each version is given a distinguishing version number. If the Library" - , "specifies a version number of this License which applies to it and" - , "\"any later version\", you have the option of following the terms and" - , "conditions either of that version or of any later version published by" - , "the Free Software Foundation. If the Library does not specify a" - , "license version number, you may choose any version ever published by" - , "the Free Software Foundation." - , "" - , " 14. If you wish to incorporate parts of the Library into other free" - , "programs whose distribution conditions are incompatible with these," - , "write to the author to ask for permission. For software which is" - , "copyrighted by the Free Software Foundation, write to the Free" - , "Software Foundation; we sometimes make exceptions for this. Our" - , "decision will be guided by the two goals of preserving the free status" - , "of all derivatives of our free software and of promoting the sharing" - , "and reuse of software generally." - , "" - , " NO WARRANTY" - , "" - , " 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO" - , "WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW." - , "EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR" - , "OTHER PARTIES PROVIDE THE LIBRARY \"AS IS\" WITHOUT WARRANTY OF ANY" - , "KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE" - , "IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR" - , "PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE" - , "LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME" - , "THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION." - , "" - , " 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN" - , "WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY" - , "AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU" - , "FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR" - , "CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE" - , "LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING" - , "RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A" - , "FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF" - , "SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH" - , "DAMAGES." - , "" - , " END OF TERMS AND CONDITIONS" - , "" - , " How to Apply These Terms to Your New Libraries" - , "" - , " If you develop a new library, and you want it to be of the greatest" - , "possible use to the public, we recommend making it free software that" - , "everyone can redistribute and change. You can do so by permitting" - , "redistribution under these terms (or, alternatively, under the terms of the" - , "ordinary General Public License)." - , "" - , " To apply these terms, attach the following notices to the library. It is" - , "safest to attach them to the start of each source file to most effectively" - , "convey the exclusion of warranty; and each file should have at least the" - , "\"copyright\" line and a pointer to where the full notice is found." - , "" - , " " - , " Copyright (C) " - , "" - , " This library is free software; you can redistribute it and/or" - , " modify it under the terms of the GNU Lesser General Public" - , " License as published by the Free Software Foundation; either" - , " version 2.1 of the License, or (at your option) any later version." - , "" - , " This library is distributed in the hope that it will be useful," - , " but WITHOUT ANY WARRANTY; without even the implied warranty of" - , " MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU" - , " Lesser General Public License for more details." - , "" - , " You should have received a copy of the GNU Lesser General Public" - , " License along with this library; if not, write to the Free Software" - , " Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA" - , "" - , "Also add information on how to contact you by electronic and paper mail." - , "" - , "You should also get your employer (if you work as a programmer) or your" - , "school, if any, to sign a \"copyright disclaimer\" for the library, if" - , "necessary. Here is a sample; alter the names:" - , "" - , " Yoyodyne, Inc., hereby disclaims all copyright interest in the" - , " library `Frob' (a library for tweaking knobs) written by James Random Hacker." - , "" - , " , 1 April 1990" - , " Ty Coon, President of Vice" - , "" - , "That's all there is to it!" - ] - -lgpl3 :: License -lgpl3 = unlines - [ " GNU LESSER GENERAL PUBLIC LICENSE" - , " Version 3, 29 June 2007" - , "" - , " Copyright (C) 2007 Free Software Foundation, Inc. " - , " Everyone is permitted to copy and distribute verbatim copies" - , " of this license document, but changing it is not allowed." - , "" - , "" - , " This version of the GNU Lesser General Public License incorporates" - , "the terms and conditions of version 3 of the GNU General Public" - , "License, supplemented by the additional permissions listed below." - , "" - , " 0. Additional Definitions." - , "" - , " As used herein, \"this License\" refers to version 3 of the GNU Lesser" - , "General Public License, and the \"GNU GPL\" refers to version 3 of the GNU" - , "General Public License." - , "" - , " \"The Library\" refers to a covered work governed by this License," - , "other than an Application or a Combined Work as defined below." - , "" - , " An \"Application\" is any work that makes use of an interface provided" - , "by the Library, but which is not otherwise based on the Library." - , "Defining a subclass of a class defined by the Library is deemed a mode" - , "of using an interface provided by the Library." - , "" - , " A \"Combined Work\" is a work produced by combining or linking an" - , "Application with the Library. The particular version of the Library" - , "with which the Combined Work was made is also called the \"Linked" - , "Version\"." - , "" - , " The \"Minimal Corresponding Source\" for a Combined Work means the" - , "Corresponding Source for the Combined Work, excluding any source code" - , "for portions of the Combined Work that, considered in isolation, are" - , "based on the Application, and not on the Linked Version." - , "" - , " The \"Corresponding Application Code\" for a Combined Work means the" - , "object code and/or source code for the Application, including any data" - , "and utility programs needed for reproducing the Combined Work from the" - , "Application, but excluding the System Libraries of the Combined Work." - , "" - , " 1. Exception to Section 3 of the GNU GPL." - , "" - , " You may convey a covered work under sections 3 and 4 of this License" - , "without being bound by section 3 of the GNU GPL." - , "" - , " 2. Conveying Modified Versions." - , "" - , " If you modify a copy of the Library, and, in your modifications, a" - , "facility refers to a function or data to be supplied by an Application" - , "that uses the facility (other than as an argument passed when the" - , "facility is invoked), then you may convey a copy of the modified" - , "version:" - , "" - , " a) under this License, provided that you make a good faith effort to" - , " ensure that, in the event an Application does not supply the" - , " function or data, the facility still operates, and performs" - , " whatever part of its purpose remains meaningful, or" - , "" - , " b) under the GNU GPL, with none of the additional permissions of" - , " this License applicable to that copy." - , "" - , " 3. Object Code Incorporating Material from Library Header Files." - , "" - , " The object code form of an Application may incorporate material from" - , "a header file that is part of the Library. You may convey such object" - , "code under terms of your choice, provided that, if the incorporated" - , "material is not limited to numerical parameters, data structure" - , "layouts and accessors, or small macros, inline functions and templates" - , "(ten or fewer lines in length), you do both of the following:" - , "" - , " a) Give prominent notice with each copy of the object code that the" - , " Library is used in it and that the Library and its use are" - , " covered by this License." - , "" - , " b) Accompany the object code with a copy of the GNU GPL and this license" - , " document." - , "" - , " 4. Combined Works." - , "" - , " You may convey a Combined Work under terms of your choice that," - , "taken together, effectively do not restrict modification of the" - , "portions of the Library contained in the Combined Work and reverse" - , "engineering for debugging such modifications, if you also do each of" - , "the following:" - , "" - , " a) Give prominent notice with each copy of the Combined Work that" - , " the Library is used in it and that the Library and its use are" - , " covered by this License." - , "" - , " b) Accompany the Combined Work with a copy of the GNU GPL and this license" - , " document." - , "" - , " c) For a Combined Work that displays copyright notices during" - , " execution, include the copyright notice for the Library among" - , " these notices, as well as a reference directing the user to the" - , " copies of the GNU GPL and this license document." - , "" - , " d) Do one of the following:" - , "" - , " 0) Convey the Minimal Corresponding Source under the terms of this" - , " License, and the Corresponding Application Code in a form" - , " suitable for, and under terms that permit, the user to" - , " recombine or relink the Application with a modified version of" - , " the Linked Version to produce a modified Combined Work, in the" - , " manner specified by section 6 of the GNU GPL for conveying" - , " Corresponding Source." - , "" - , " 1) Use a suitable shared library mechanism for linking with the" - , " Library. A suitable mechanism is one that (a) uses at run time" - , " a copy of the Library already present on the user's computer" - , " system, and (b) will operate properly with a modified version" - , " of the Library that is interface-compatible with the Linked" - , " Version." - , "" - , " e) Provide Installation Information, but only if you would otherwise" - , " be required to provide such information under section 6 of the" - , " GNU GPL, and only to the extent that such information is" - , " necessary to install and execute a modified version of the" - , " Combined Work produced by recombining or relinking the" - , " Application with a modified version of the Linked Version. (If" - , " you use option 4d0, the Installation Information must accompany" - , " the Minimal Corresponding Source and Corresponding Application" - , " Code. If you use option 4d1, you must provide the Installation" - , " Information in the manner specified by section 6 of the GNU GPL" - , " for conveying Corresponding Source.)" - , "" - , " 5. Combined Libraries." - , "" - , " You may place library facilities that are a work based on the" - , "Library side by side in a single library together with other library" - , "facilities that are not Applications and are not covered by this" - , "License, and convey such a combined library under terms of your" - , "choice, if you do both of the following:" - , "" - , " a) Accompany the combined library with a copy of the same work based" - , " on the Library, uncombined with any other library facilities," - , " conveyed under the terms of this License." - , "" - , " b) Give prominent notice with the combined library that part of it" - , " is a work based on the Library, and explaining where to find the" - , " accompanying uncombined form of the same work." - , "" - , " 6. Revised Versions of the GNU Lesser General Public License." - , "" - , " The Free Software Foundation may publish revised and/or new versions" - , "of the GNU Lesser General Public License from time to time. Such new" - , "versions will be similar in spirit to the present version, but may" - , "differ in detail to address new problems or concerns." - , "" - , " Each version is given a distinguishing version number. If the" - , "Library as you received it specifies that a certain numbered version" - , "of the GNU Lesser General Public License \"or any later version\"" - , "applies to it, you have the option of following the terms and" - , "conditions either of that published version or of any later version" - , "published by the Free Software Foundation. If the Library as you" - , "received it does not specify a version number of the GNU Lesser" - , "General Public License, you may choose any version of the GNU Lesser" - , "General Public License ever published by the Free Software Foundation." - , "" - , " If the Library as you received it specifies that a proxy can decide" - , "whether future versions of the GNU Lesser General Public License shall" - , "apply, that proxy's public statement of acceptance of any version is" - , "permanent authorization for you to choose that version for the" - , "Library." - ] - -apache20 :: License -apache20 = unlines - [ "" - , " Apache License" - , " Version 2.0, January 2004" - , " http://www.apache.org/licenses/" - , "" - , " TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION" - , "" - , " 1. Definitions." - , "" - , " \"License\" shall mean the terms and conditions for use, reproduction," - , " and distribution as defined by Sections 1 through 9 of this document." - , "" - , " \"Licensor\" shall mean the copyright owner or entity authorized by" - , " the copyright owner that is granting the License." - , "" - , " \"Legal Entity\" shall mean the union of the acting entity and all" - , " other entities that control, are controlled by, or are under common" - , " control with that entity. For the purposes of this definition," - , " \"control\" means (i) the power, direct or indirect, to cause the" - , " direction or management of such entity, whether by contract or" - , " otherwise, or (ii) ownership of fifty percent (50%) or more of the" - , " outstanding shares, or (iii) beneficial ownership of such entity." - , "" - , " \"You\" (or \"Your\") shall mean an individual or Legal Entity" - , " exercising permissions granted by this License." - , "" - , " \"Source\" form shall mean the preferred form for making modifications," - , " including but not limited to software source code, documentation" - , " source, and configuration files." - , "" - , " \"Object\" form shall mean any form resulting from mechanical" - , " transformation or translation of a Source form, including but" - , " not limited to compiled object code, generated documentation," - , " and conversions to other media types." - , "" - , " \"Work\" shall mean the work of authorship, whether in Source or" - , " Object form, made available under the License, as indicated by a" - , " copyright notice that is included in or attached to the work" - , " (an example is provided in the Appendix below)." - , "" - , " \"Derivative Works\" shall mean any work, whether in Source or Object" - , " form, that is based on (or derived from) the Work and for which the" - , " editorial revisions, annotations, elaborations, or other modifications" - , " represent, as a whole, an original work of authorship. For the purposes" - , " of this License, Derivative Works shall not include works that remain" - , " separable from, or merely link (or bind by name) to the interfaces of," - , " the Work and Derivative Works thereof." - , "" - , " \"Contribution\" shall mean any work of authorship, including" - , " the original version of the Work and any modifications or additions" - , " to that Work or Derivative Works thereof, that is intentionally" - , " submitted to Licensor for inclusion in the Work by the copyright owner" - , " or by an individual or Legal Entity authorized to submit on behalf of" - , " the copyright owner. For the purposes of this definition, \"submitted\"" - , " means any form of electronic, verbal, or written communication sent" - , " to the Licensor or its representatives, including but not limited to" - , " communication on electronic mailing lists, source code control systems," - , " and issue tracking systems that are managed by, or on behalf of, the" - , " Licensor for the purpose of discussing and improving the Work, but" - , " excluding communication that is conspicuously marked or otherwise" - , " designated in writing by the copyright owner as \"Not a Contribution.\"" - , "" - , " \"Contributor\" shall mean Licensor and any individual or Legal Entity" - , " on behalf of whom a Contribution has been received by Licensor and" - , " subsequently incorporated within the Work." - , "" - , " 2. Grant of Copyright License. Subject to the terms and conditions of" - , " this License, each Contributor hereby grants to You a perpetual," - , " worldwide, non-exclusive, no-charge, royalty-free, irrevocable" - , " copyright license to reproduce, prepare Derivative Works of," - , " publicly display, publicly perform, sublicense, and distribute the" - , " Work and such Derivative Works in Source or Object form." - , "" - , " 3. Grant of Patent License. Subject to the terms and conditions of" - , " this License, each Contributor hereby grants to You a perpetual," - , " worldwide, non-exclusive, no-charge, royalty-free, irrevocable" - , " (except as stated in this section) patent license to make, have made," - , " use, offer to sell, sell, import, and otherwise transfer the Work," - , " where such license applies only to those patent claims licensable" - , " by such Contributor that are necessarily infringed by their" - , " Contribution(s) alone or by combination of their Contribution(s)" - , " with the Work to which such Contribution(s) was submitted. If You" - , " institute patent litigation against any entity (including a" - , " cross-claim or counterclaim in a lawsuit) alleging that the Work" - , " or a Contribution incorporated within the Work constitutes direct" - , " or contributory patent infringement, then any patent licenses" - , " granted to You under this License for that Work shall terminate" - , " as of the date such litigation is filed." - , "" - , " 4. Redistribution. You may reproduce and distribute copies of the" - , " Work or Derivative Works thereof in any medium, with or without" - , " modifications, and in Source or Object form, provided that You" - , " meet the following conditions:" - , "" - , " (a) You must give any other recipients of the Work or" - , " Derivative Works a copy of this License; and" - , "" - , " (b) You must cause any modified files to carry prominent notices" - , " stating that You changed the files; and" - , "" - , " (c) You must retain, in the Source form of any Derivative Works" - , " that You distribute, all copyright, patent, trademark, and" - , " attribution notices from the Source form of the Work," - , " excluding those notices that do not pertain to any part of" - , " the Derivative Works; and" - , "" - , " (d) If the Work includes a \"NOTICE\" text file as part of its" - , " distribution, then any Derivative Works that You distribute must" - , " include a readable copy of the attribution notices contained" - , " within such NOTICE file, excluding those notices that do not" - , " pertain to any part of the Derivative Works, in at least one" - , " of the following places: within a NOTICE text file distributed" - , " as part of the Derivative Works; within the Source form or" - , " documentation, if provided along with the Derivative Works; or," - , " within a display generated by the Derivative Works, if and" - , " wherever such third-party notices normally appear. The contents" - , " of the NOTICE file are for informational purposes only and" - , " do not modify the License. You may add Your own attribution" - , " notices within Derivative Works that You distribute, alongside" - , " or as an addendum to the NOTICE text from the Work, provided" - , " that such additional attribution notices cannot be construed" - , " as modifying the License." - , "" - , " You may add Your own copyright statement to Your modifications and" - , " may provide additional or different license terms and conditions" - , " for use, reproduction, or distribution of Your modifications, or" - , " for any such Derivative Works as a whole, provided Your use," - , " reproduction, and distribution of the Work otherwise complies with" - , " the conditions stated in this License." - , "" - , " 5. Submission of Contributions. Unless You explicitly state otherwise," - , " any Contribution intentionally submitted for inclusion in the Work" - , " by You to the Licensor shall be under the terms and conditions of" - , " this License, without any additional terms or conditions." - , " Notwithstanding the above, nothing herein shall supersede or modify" - , " the terms of any separate license agreement you may have executed" - , " with Licensor regarding such Contributions." - , "" - , " 6. Trademarks. This License does not grant permission to use the trade" - , " names, trademarks, service marks, or product names of the Licensor," - , " except as required for reasonable and customary use in describing the" - , " origin of the Work and reproducing the content of the NOTICE file." - , "" - , " 7. Disclaimer of Warranty. Unless required by applicable law or" - , " agreed to in writing, Licensor provides the Work (and each" - , " Contributor provides its Contributions) on an \"AS IS\" BASIS," - , " WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or" - , " implied, including, without limitation, any warranties or conditions" - , " of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A" - , " PARTICULAR PURPOSE. You are solely responsible for determining the" - , " appropriateness of using or redistributing the Work and assume any" - , " risks associated with Your exercise of permissions under this License." - , "" - , " 8. Limitation of Liability. In no event and under no legal theory," - , " whether in tort (including negligence), contract, or otherwise," - , " unless required by applicable law (such as deliberate and grossly" - , " negligent acts) or agreed to in writing, shall any Contributor be" - , " liable to You for damages, including any direct, indirect, special," - , " incidental, or consequential damages of any character arising as a" - , " result of this License or out of the use or inability to use the" - , " Work (including but not limited to damages for loss of goodwill," - , " work stoppage, computer failure or malfunction, or any and all" - , " other commercial damages or losses), even if such Contributor" - , " has been advised of the possibility of such damages." - , "" - , " 9. Accepting Warranty or Additional Liability. While redistributing" - , " the Work or Derivative Works thereof, You may choose to offer," - , " and charge a fee for, acceptance of support, warranty, indemnity," - , " or other liability obligations and/or rights consistent with this" - , " License. However, in accepting such obligations, You may act only" - , " on Your own behalf and on Your sole responsibility, not on behalf" - , " of any other Contributor, and only if You agree to indemnify," - , " defend, and hold each Contributor harmless for any liability" - , " incurred by, or claims asserted against, such Contributor by reason" - , " of your accepting any such warranty or additional liability." - , "" - , " END OF TERMS AND CONDITIONS" - , "" - , " APPENDIX: How to apply the Apache License to your work." - , "" - , " To apply the Apache License to your work, attach the following" - , " boilerplate notice, with the fields enclosed by brackets \"[]\"" - , " replaced with your own identifying information. (Don't include" - , " the brackets!) The text should be enclosed in the appropriate" - , " comment syntax for the file format. We also recommend that a" - , " file or class name and description of purpose be included on the" - , " same \"printed page\" as the copyright notice for easier" - , " identification within third-party archives." - , "" - , " Copyright [yyyy] [name of copyright owner]" - , "" - , " Licensed under the Apache License, Version 2.0 (the \"License\");" - , " you may not use this file except in compliance with the License." - , " You may obtain a copy of the License at" - , "" - , " http://www.apache.org/licenses/LICENSE-2.0" - , "" - , " Unless required by applicable law or agreed to in writing, software" - , " distributed under the License is distributed on an \"AS IS\" BASIS," - , " WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied." - , " See the License for the specific language governing permissions and" - , " limitations under the License." - ] - -mit :: String -> String -> License -mit authors year = unlines - [ "Copyright (c) " ++ year ++ " " ++ authors - , "" - , "Permission is hereby granted, free of charge, to any person obtaining" - , "a copy of this software and associated documentation files (the" - , "\"Software\"), to deal in the Software without restriction, including" - , "without limitation the rights to use, copy, modify, merge, publish," - , "distribute, sublicense, and/or sell copies of the Software, and to" - , "permit persons to whom the Software is furnished to do so, subject to" - , "the following conditions:" - , "" - , "The above copyright notice and this permission notice shall be included" - , "in all copies or substantial portions of the Software." - , "" - , "THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND," - , "EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF" - , "MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT." - , "IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY" - , "CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT," - , "TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE" - , "SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE." - ] - -mpl20 :: License -mpl20 = unlines - [ "Mozilla Public License Version 2.0" - , "==================================" - , "" - , "1. Definitions" - , "--------------" - , "" - , "1.1. \"Contributor\"" - , " means each individual or legal entity that creates, contributes to" - , " the creation of, or owns Covered Software." - , "" - , "1.2. \"Contributor Version\"" - , " means the combination of the Contributions of others (if any) used" - , " by a Contributor and that particular Contributor's Contribution." - , "" - , "1.3. \"Contribution\"" - , " means Covered Software of a particular Contributor." - , "" - , "1.4. \"Covered Software\"" - , " means Source Code Form to which the initial Contributor has attached" - , " the notice in Exhibit A, the Executable Form of such Source Code" - , " Form, and Modifications of such Source Code Form, in each case" - , " including portions thereof." - , "" - , "1.5. \"Incompatible With Secondary Licenses\"" - , " means" - , "" - , " (a) that the initial Contributor has attached the notice described" - , " in Exhibit B to the Covered Software; or" - , "" - , " (b) that the Covered Software was made available under the terms of" - , " version 1.1 or earlier of the License, but not also under the" - , " terms of a Secondary License." - , "" - , "1.6. \"Executable Form\"" - , " means any form of the work other than Source Code Form." - , "" - , "1.7. \"Larger Work\"" - , " means a work that combines Covered Software with other material, in" - , " a separate file or files, that is not Covered Software." - , "" - , "1.8. \"License\"" - , " means this document." - , "" - , "1.9. \"Licensable\"" - , " means having the right to grant, to the maximum extent possible," - , " whether at the time of the initial grant or subsequently, any and" - , " all of the rights conveyed by this License." - , "" - , "1.10. \"Modifications\"" - , " means any of the following:" - , "" - , " (a) any file in Source Code Form that results from an addition to," - , " deletion from, or modification of the contents of Covered" - , " Software; or" - , "" - , " (b) any new file in Source Code Form that contains any Covered" - , " Software." - , "" - , "1.11. \"Patent Claims\" of a Contributor" - , " means any patent claim(s), including without limitation, method," - , " process, and apparatus claims, in any patent Licensable by such" - , " Contributor that would be infringed, but for the grant of the" - , " License, by the making, using, selling, offering for sale, having" - , " made, import, or transfer of either its Contributions or its" - , " Contributor Version." - , "" - , "1.12. \"Secondary License\"" - , " means either the GNU General Public License, Version 2.0, the GNU" - , " Lesser General Public License, Version 2.1, the GNU Affero General" - , " Public License, Version 3.0, or any later versions of those" - , " licenses." - , "" - , "1.13. \"Source Code Form\"" - , " means the form of the work preferred for making modifications." - , "" - , "1.14. \"You\" (or \"Your\")" - , " means an individual or a legal entity exercising rights under this" - , " License. For legal entities, \"You\" includes any entity that" - , " controls, is controlled by, or is under common control with You. For" - , " purposes of this definition, \"control\" means (a) the power, direct" - , " or indirect, to cause the direction or management of such entity," - , " whether by contract or otherwise, or (b) ownership of more than" - , " fifty percent (50%) of the outstanding shares or beneficial" - , " ownership of such entity." - , "" - , "2. License Grants and Conditions" - , "--------------------------------" - , "" - , "2.1. Grants" - , "" - , "Each Contributor hereby grants You a world-wide, royalty-free," - , "non-exclusive license:" - , "" - , "(a) under intellectual property rights (other than patent or trademark)" - , " Licensable by such Contributor to use, reproduce, make available," - , " modify, display, perform, distribute, and otherwise exploit its" - , " Contributions, either on an unmodified basis, with Modifications, or" - , " as part of a Larger Work; and" - , "" - , "(b) under Patent Claims of such Contributor to make, use, sell, offer" - , " for sale, have made, import, and otherwise transfer either its" - , " Contributions or its Contributor Version." - , "" - , "2.2. Effective Date" - , "" - , "The licenses granted in Section 2.1 with respect to any Contribution" - , "become effective for each Contribution on the date the Contributor first" - , "distributes such Contribution." - , "" - , "2.3. Limitations on Grant Scope" - , "" - , "The licenses granted in this Section 2 are the only rights granted under" - , "this License. No additional rights or licenses will be implied from the" - , "distribution or licensing of Covered Software under this License." - , "Notwithstanding Section 2.1(b) above, no patent license is granted by a" - , "Contributor:" - , "" - , "(a) for any code that a Contributor has removed from Covered Software;" - , " or" - , "" - , "(b) for infringements caused by: (i) Your and any other third party's" - , " modifications of Covered Software, or (ii) the combination of its" - , " Contributions with other software (except as part of its Contributor" - , " Version); or" - , "" - , "(c) under Patent Claims infringed by Covered Software in the absence of" - , " its Contributions." - , "" - , "This License does not grant any rights in the trademarks, service marks," - , "or logos of any Contributor (except as may be necessary to comply with" - , "the notice requirements in Section 3.4)." - , "" - , "2.4. Subsequent Licenses" - , "" - , "No Contributor makes additional grants as a result of Your choice to" - , "distribute the Covered Software under a subsequent version of this" - , "License (see Section 10.2) or under the terms of a Secondary License (if" - , "permitted under the terms of Section 3.3)." - , "" - , "2.5. Representation" - , "" - , "Each Contributor represents that the Contributor believes its" - , "Contributions are its original creation(s) or it has sufficient rights" - , "to grant the rights to its Contributions conveyed by this License." - , "" - , "2.6. Fair Use" - , "" - , "This License is not intended to limit any rights You have under" - , "applicable copyright doctrines of fair use, fair dealing, or other" - , "equivalents." - , "" - , "2.7. Conditions" - , "" - , "Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted" - , "in Section 2.1." - , "" - , "3. Responsibilities" - , "-------------------" - , "" - , "3.1. Distribution of Source Form" - , "" - , "All distribution of Covered Software in Source Code Form, including any" - , "Modifications that You create or to which You contribute, must be under" - , "the terms of this License. You must inform recipients that the Source" - , "Code Form of the Covered Software is governed by the terms of this" - , "License, and how they can obtain a copy of this License. You may not" - , "attempt to alter or restrict the recipients' rights in the Source Code" - , "Form." - , "" - , "3.2. Distribution of Executable Form" - , "" - , "If You distribute Covered Software in Executable Form then:" - , "" - , "(a) such Covered Software must also be made available in Source Code" - , " Form, as described in Section 3.1, and You must inform recipients of" - , " the Executable Form how they can obtain a copy of such Source Code" - , " Form by reasonable means in a timely manner, at a charge no more" - , " than the cost of distribution to the recipient; and" - , "" - , "(b) You may distribute such Executable Form under the terms of this" - , " License, or sublicense it under different terms, provided that the" - , " license for the Executable Form does not attempt to limit or alter" - , " the recipients' rights in the Source Code Form under this License." - , "" - , "3.3. Distribution of a Larger Work" - , "" - , "You may create and distribute a Larger Work under terms of Your choice," - , "provided that You also comply with the requirements of this License for" - , "the Covered Software. If the Larger Work is a combination of Covered" - , "Software with a work governed by one or more Secondary Licenses, and the" - , "Covered Software is not Incompatible With Secondary Licenses, this" - , "License permits You to additionally distribute such Covered Software" - , "under the terms of such Secondary License(s), so that the recipient of" - , "the Larger Work may, at their option, further distribute the Covered" - , "Software under the terms of either this License or such Secondary" - , "License(s)." - , "" - , "3.4. Notices" - , "" - , "You may not remove or alter the substance of any license notices" - , "(including copyright notices, patent notices, disclaimers of warranty," - , "or limitations of liability) contained within the Source Code Form of" - , "the Covered Software, except that You may alter any license notices to" - , "the extent required to remedy known factual inaccuracies." - , "" - , "3.5. Application of Additional Terms" - , "" - , "You may choose to offer, and to charge a fee for, warranty, support," - , "indemnity or liability obligations to one or more recipients of Covered" - , "Software. However, You may do so only on Your own behalf, and not on" - , "behalf of any Contributor. You must make it absolutely clear that any" - , "such warranty, support, indemnity, or liability obligation is offered by" - , "You alone, and You hereby agree to indemnify every Contributor for any" - , "liability incurred by such Contributor as a result of warranty, support," - , "indemnity or liability terms You offer. You may include additional" - , "disclaimers of warranty and limitations of liability specific to any" - , "jurisdiction." - , "" - , "4. Inability to Comply Due to Statute or Regulation" - , "---------------------------------------------------" - , "" - , "If it is impossible for You to comply with any of the terms of this" - , "License with respect to some or all of the Covered Software due to" - , "statute, judicial order, or regulation then You must: (a) comply with" - , "the terms of this License to the maximum extent possible; and (b)" - , "describe the limitations and the code they affect. Such description must" - , "be placed in a text file included with all distributions of the Covered" - , "Software under this License. Except to the extent prohibited by statute" - , "or regulation, such description must be sufficiently detailed for a" - , "recipient of ordinary skill to be able to understand it." - , "" - , "5. Termination" - , "--------------" - , "" - , "5.1. The rights granted under this License will terminate automatically" - , "if You fail to comply with any of its terms. However, if You become" - , "compliant, then the rights granted under this License from a particular" - , "Contributor are reinstated (a) provisionally, unless and until such" - , "Contributor explicitly and finally terminates Your grants, and (b) on an" - , "ongoing basis, if such Contributor fails to notify You of the" - , "non-compliance by some reasonable means prior to 60 days after You have" - , "come back into compliance. Moreover, Your grants from a particular" - , "Contributor are reinstated on an ongoing basis if such Contributor" - , "notifies You of the non-compliance by some reasonable means, this is the" - , "first time You have received notice of non-compliance with this License" - , "from such Contributor, and You become compliant prior to 30 days after" - , "Your receipt of the notice." - , "" - , "5.2. If You initiate litigation against any entity by asserting a patent" - , "infringement claim (excluding declaratory judgment actions," - , "counter-claims, and cross-claims) alleging that a Contributor Version" - , "directly or indirectly infringes any patent, then the rights granted to" - , "You by any and all Contributors for the Covered Software under Section" - , "2.1 of this License shall terminate." - , "" - , "5.3. In the event of termination under Sections 5.1 or 5.2 above, all" - , "end user license agreements (excluding distributors and resellers) which" - , "have been validly granted by You or Your distributors under this License" - , "prior to termination shall survive termination." - , "" - , "************************************************************************" - , "* *" - , "* 6. Disclaimer of Warranty *" - , "* ------------------------- *" - , "* *" - , "* Covered Software is provided under this License on an \"as is\" *" - , "* basis, without warranty of any kind, either expressed, implied, or *" - , "* statutory, including, without limitation, warranties that the *" - , "* Covered Software is free of defects, merchantable, fit for a *" - , "* particular purpose or non-infringing. The entire risk as to the *" - , "* quality and performance of the Covered Software is with You. *" - , "* Should any Covered Software prove defective in any respect, You *" - , "* (not any Contributor) assume the cost of any necessary servicing, *" - , "* repair, or correction. This disclaimer of warranty constitutes an *" - , "* essential part of this License. No use of any Covered Software is *" - , "* authorized under this License except under this disclaimer. *" - , "* *" - , "************************************************************************" - , "" - , "************************************************************************" - , "* *" - , "* 7. Limitation of Liability *" - , "* -------------------------- *" - , "* *" - , "* Under no circumstances and under no legal theory, whether tort *" - , "* (including negligence), contract, or otherwise, shall any *" - , "* Contributor, or anyone who distributes Covered Software as *" - , "* permitted above, be liable to You for any direct, indirect, *" - , "* special, incidental, or consequential damages of any character *" - , "* including, without limitation, damages for lost profits, loss of *" - , "* goodwill, work stoppage, computer failure or malfunction, or any *" - , "* and all other commercial damages or losses, even if such party *" - , "* shall have been informed of the possibility of such damages. This *" - , "* limitation of liability shall not apply to liability for death or *" - , "* personal injury resulting from such party's negligence to the *" - , "* extent applicable law prohibits such limitation. Some *" - , "* jurisdictions do not allow the exclusion or limitation of *" - , "* incidental or consequential damages, so this exclusion and *" - , "* limitation may not apply to You. *" - , "* *" - , "************************************************************************" - , "" - , "8. Litigation" - , "-------------" - , "" - , "Any litigation relating to this License may be brought only in the" - , "courts of a jurisdiction where the defendant maintains its principal" - , "place of business and such litigation shall be governed by laws of that" - , "jurisdiction, without reference to its conflict-of-law provisions." - , "Nothing in this Section shall prevent a party's ability to bring" - , "cross-claims or counter-claims." - , "" - , "9. Miscellaneous" - , "----------------" - , "" - , "This License represents the complete agreement concerning the subject" - , "matter hereof. If any provision of this License is held to be" - , "unenforceable, such provision shall be reformed only to the extent" - , "necessary to make it enforceable. Any law or regulation which provides" - , "that the language of a contract shall be construed against the drafter" - , "shall not be used to construe this License against a Contributor." - , "" - , "10. Versions of the License" - , "---------------------------" - , "" - , "10.1. New Versions" - , "" - , "Mozilla Foundation is the license steward. Except as provided in Section" - , "10.3, no one other than the license steward has the right to modify or" - , "publish new versions of this License. Each version will be given a" - , "distinguishing version number." - , "" - , "10.2. Effect of New Versions" - , "" - , "You may distribute the Covered Software under the terms of the version" - , "of the License under which You originally received the Covered Software," - , "or under the terms of any subsequent version published by the license" - , "steward." - , "" - , "10.3. Modified Versions" - , "" - , "If you create software not governed by this License, and you want to" - , "create a new license for such software, you may create and use a" - , "modified version of this License if you rename the license and remove" - , "any references to the name of the license steward (except to note that" - , "such modified license differs from this License)." - , "" - , "10.4. Distributing Source Code Form that is Incompatible With Secondary" - , "Licenses" - , "" - , "If You choose to distribute Source Code Form that is Incompatible With" - , "Secondary Licenses under the terms of this version of the License, the" - , "notice described in Exhibit B of this License must be attached." - , "" - , "Exhibit A - Source Code Form License Notice" - , "-------------------------------------------" - , "" - , " This Source Code Form is subject to the terms of the Mozilla Public" - , " License, v. 2.0. If a copy of the MPL was not distributed with this" - , " file, You can obtain one at http://mozilla.org/MPL/2.0/." - , "" - , "If it is not possible or desirable to put the notice in a particular" - , "file, then You may include the notice in a location (such as a LICENSE" - , "file in a relevant directory) where a recipient would be likely to look" - , "for such a notice." - , "" - , "You may add additional accurate notices of copyright ownership." - , "" - , "Exhibit B - \"Incompatible With Secondary Licenses\" Notice" - , "---------------------------------------------------------" - , "" - , " This Source Code Form is \"Incompatible With Secondary Licenses\", as" - , " defined by the Mozilla Public License, v. 2.0." - ] - -isc :: String -> String -> License -isc authors year = unlines - [ "Copyright (c) " ++ year ++ " " ++ authors - , "" - , "Permission to use, copy, modify, and/or distribute this software for any purpose" - , "with or without fee is hereby granted, provided that the above copyright notice" - , "and this permission notice appear in all copies." - , "" - , "THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH" - , "REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND" - , "FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT," - , "INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS" - , "OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER" - , "TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF" - , "THIS SOFTWARE." - ] diff --git a/cabal/cabal-install/Distribution/Client/Init/Prompt.hs b/cabal/cabal-install/Distribution/Client/Init/Prompt.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Init/Prompt.hs +++ /dev/null @@ -1,145 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Init.Prompt --- Copyright : (c) Brent Yorgey 2009 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- User prompt utility functions for use by the 'cabal init' command. --- ------------------------------------------------------------------------------ - -module Distribution.Client.Init.Prompt ( - - -- * Commands - prompt - , promptYesNo - , promptStr - , promptList - , promptListOptional - , maybePrompt - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude hiding (empty) - -import Distribution.Client.Init.Types - ( InitFlags(..) ) -import Distribution.Simple.Setup - ( Flag(..) ) - - --- | Run a prompt or not based on the interactive flag of the --- InitFlags structure. -maybePrompt :: InitFlags -> IO t -> IO (Maybe t) -maybePrompt flags p = - case interactive flags of - Flag True -> Just `fmap` p - _ -> return Nothing - --- | Create a prompt with optional default value that returns a --- String. -promptStr :: String -> Maybe String -> IO String -promptStr = promptDefault' Just id - --- | Create a yes/no prompt with optional default value. -promptYesNo :: String -- ^ prompt message - -> Maybe Bool -- ^ optional default value - -> IO Bool -promptYesNo = - promptDefault' recogniseYesNo showYesNo - where - recogniseYesNo s | s == "y" || s == "Y" = Just True - | s == "n" || s == "N" = Just False - | otherwise = Nothing - showYesNo True = "y" - showYesNo False = "n" - --- | Create a prompt with optional default value that returns a value --- of some Text instance. -prompt :: (Parsec t, Pretty t) => String -> Maybe t -> IO t -prompt = promptDefault' simpleParsec prettyShow - --- | Create a prompt with an optional default value. -promptDefault' :: (String -> Maybe t) -- ^ parser - -> (t -> String) -- ^ pretty-printer - -> String -- ^ prompt message - -> Maybe t -- ^ optional default value - -> IO t -promptDefault' parser ppr pr def = do - putStr $ mkDefPrompt pr (ppr `fmap` def) - inp <- getLine - case (inp, def) of - ("", Just d) -> return d - _ -> case parser inp of - Just t -> return t - Nothing -> do putStrLn $ "Couldn't parse " ++ inp ++ ", please try again!" - promptDefault' parser ppr pr def - --- | Create a prompt from a prompt string and a String representation --- of an optional default value. -mkDefPrompt :: String -> Maybe String -> String -mkDefPrompt pr def = pr ++ "?" ++ defStr def - where defStr Nothing = " " - defStr (Just s) = " [default: " ++ s ++ "] " - --- | Create a prompt from a list of items, where no selected items is --- valid and will be represented as a return value of 'Nothing'. -promptListOptional :: (Pretty t, Eq t) - => String -- ^ prompt - -> [t] -- ^ choices - -> IO (Maybe (Either String t)) -promptListOptional pr choices = promptListOptional' pr choices prettyShow - -promptListOptional' :: Eq t - => String -- ^ prompt - -> [t] -- ^ choices - -> (t -> String) -- ^ show an item - -> IO (Maybe (Either String t)) -promptListOptional' pr choices displayItem = - fmap rearrange - $ promptList pr (Nothing : map Just choices) (Just Nothing) - (maybe "(none)" displayItem) True - where - rearrange = either (Just . Left) (fmap Right) - --- | Create a prompt from a list of items. -promptList :: Eq t - => String -- ^ prompt - -> [t] -- ^ choices - -> Maybe t -- ^ optional default value - -> (t -> String) -- ^ show an item - -> Bool -- ^ whether to allow an 'other' option - -> IO (Either String t) -promptList pr choices def displayItem other = do - putStrLn $ pr ++ ":" - let options1 = map (\c -> (Just c == def, displayItem c)) choices - options2 = zip ([1..]::[Int]) - (options1 ++ [(False, "Other (specify)") | other]) - traverse_ (putStrLn . \(n,(i,s)) -> showOption n i ++ s) options2 - promptList' displayItem (length options2) choices def other - where showOption n i | n < 10 = " " ++ star i ++ " " ++ rest - | otherwise = " " ++ star i ++ rest - where rest = show n ++ ") " - star True = "*" - star False = " " - -promptList' :: (t -> String) -> Int -> [t] -> Maybe t -> Bool -> IO (Either String t) -promptList' displayItem numChoices choices def other = do - putStr $ mkDefPrompt "Your choice" (displayItem `fmap` def) - inp <- getLine - case (inp, def) of - ("", Just d) -> return $ Right d - _ -> case readMaybe inp of - Nothing -> invalidChoice inp - Just n -> getChoice n - where invalidChoice inp = do putStrLn $ inp ++ " is not a valid choice." - promptList' displayItem numChoices choices def other - getChoice n | n < 1 || n > numChoices = invalidChoice (show n) - | n < numChoices || - (n == numChoices && not other) - = return . Right $ choices !! (n-1) - | otherwise = Left `fmap` promptStr "Please specify" Nothing diff --git a/cabal/cabal-install/Distribution/Client/Init/Types.hs b/cabal/cabal-install/Distribution/Client/Init/Types.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Init/Types.hs +++ /dev/null @@ -1,142 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Init.Types --- Copyright : (c) Brent Yorgey, Benedikt Huber 2009 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- Some types used by the 'cabal init' command. --- ------------------------------------------------------------------------------ -module Distribution.Client.Init.Types where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Simple.Setup (Flag(..), toFlag ) - -import Distribution.Types.Dependency as P -import Distribution.Version -import Distribution.Verbosity -import qualified Distribution.Package as P -import Distribution.SPDX.License (License) -import Distribution.ModuleName -import Distribution.CabalSpecVersion -import Language.Haskell.Extension ( Language(..), Extension ) - -import qualified Text.PrettyPrint as Disp -import qualified Distribution.Compat.CharParsing as P -import qualified Data.Map as Map - --- | InitFlags is really just a simple type to represent certain --- portions of a .cabal file. Rather than have a flag for EVERY --- possible field, we just have one for each field that the user is --- likely to want and/or that we are likely to be able to --- intelligently guess. -data InitFlags = - InitFlags { interactive :: Flag Bool - , quiet :: Flag Bool - , packageDir :: Flag FilePath - , noComments :: Flag Bool - , minimal :: Flag Bool - , simpleProject :: Flag Bool - - , packageName :: Flag P.PackageName - , version :: Flag Version - , cabalVersion :: Flag CabalSpecVersion - , license :: Flag License - , author :: Flag String - , email :: Flag String - , homepage :: Flag String - - , synopsis :: Flag String - , category :: Flag (Either String Category) - , extraSrc :: Maybe [String] - - , packageType :: Flag PackageType - , mainIs :: Flag FilePath - , language :: Flag Language - - , exposedModules :: Maybe [ModuleName] - , otherModules :: Maybe [ModuleName] - , otherExts :: Maybe [Extension] - - , dependencies :: Maybe [P.Dependency] - , applicationDirs :: Maybe [String] - , sourceDirs :: Maybe [String] - , buildTools :: Maybe [String] - - , initializeTestSuite :: Flag Bool - , testDirs :: Maybe [String] - - , initHcPath :: Flag FilePath - - , initVerbosity :: Flag Verbosity - , overwrite :: Flag Bool - } - deriving (Show, Generic) - - -- the Monoid instance for Flag has later values override earlier - -- ones, which is why we want Maybe [foo] for collecting foo values, - -- not Flag [foo]. - -data BuildType = LibBuild | ExecBuild - deriving Eq - --- The type of package to initialize. -data PackageType = Library | Executable | LibraryAndExecutable - deriving (Show, Read, Eq) - -displayPackageType :: PackageType -> String -displayPackageType LibraryAndExecutable = "Library and Executable" -displayPackageType pkgtype = show pkgtype - -instance Monoid InitFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup InitFlags where - (<>) = gmappend - -defaultInitFlags :: InitFlags -defaultInitFlags = mempty - { initVerbosity = toFlag normal - } - --- | Some common package categories (non-exhaustive list). -data Category - = Codec - | Concurrency - | Control - | Data - | Database - | Development - | Distribution - | Game - | Graphics - | Language - | Math - | Network - | Sound - | System - | Testing - | Text - | Web - deriving (Read, Show, Eq, Ord, Bounded, Enum) - -instance Pretty Category where - pretty = Disp.text . show - -instance Parsec Category where - parsec = do - name <- P.munch1 isAlpha - case Map.lookup name names of - Just cat -> pure cat - _ -> P.unexpected $ "Category: " ++ name - where - names = Map.fromList [ (show cat, cat) | cat <- [ minBound .. maxBound ] ] diff --git a/cabal/cabal-install/Distribution/Client/Init/Utils.hs b/cabal/cabal-install/Distribution/Client/Init/Utils.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Init/Utils.hs +++ /dev/null @@ -1,38 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Init.Utils --- Copyright : (c) Brent Yorgey 2009 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- Shared utilities used by multiple cabal init modules. --- ------------------------------------------------------------------------------ - -module Distribution.Client.Init.Utils ( - eligibleForTestSuite - , message - ) where - -import Distribution.Solver.Compat.Prelude -import Prelude () - -import Distribution.Simple.Setup - ( Flag(..) ) -import Distribution.Client.Init.Types - ( InitFlags(..), PackageType(..) ) - --- | Returns true if this package is eligible for test suite initialization. -eligibleForTestSuite :: InitFlags -> Bool -eligibleForTestSuite flags = - Flag True == initializeTestSuite flags - && Flag Executable /= packageType flags - --- | Possibly generate a message to stdout, taking into account the --- --quiet flag. -message :: InitFlags -> String -> IO () -message (InitFlags{quiet = Flag True}) _ = return () -message _ s = putStrLn s diff --git a/cabal/cabal-install/Distribution/Client/Install.hs b/cabal/cabal-install/Distribution/Client/Install.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Install.hs +++ /dev/null @@ -1,1587 +0,0 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Install --- Copyright : (c) 2005 David Himmelstrup --- 2007 Bjorn Bringert --- 2007-2010 Duncan Coutts --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- High level interface to package installation. ------------------------------------------------------------------------------ -module Distribution.Client.Install ( - -- * High-level interface - install, - - -- * Lower-level interface that allows to manipulate the install plan - makeInstallContext, - makeInstallPlan, - processInstallPlan, - InstallArgs, - InstallContext, - - -- * Prune certain packages from the install plan - pruneInstallPlan - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude -import Distribution.Utils.Generic(safeLast) - -import qualified Data.List.NonEmpty as NE -import qualified Data.Map as Map -import Control.Exception as Exception - ( bracket, catches, Handler(Handler), handleJust ) -import System.Directory - ( getTemporaryDirectory, doesDirectoryExist, doesFileExist, - createDirectoryIfMissing, removeFile, renameDirectory, - getDirectoryContents ) -import System.FilePath - ( (), (<.>), equalFilePath, takeDirectory ) -import System.IO - ( openFile, IOMode(AppendMode), hClose ) -import System.IO.Error - ( isDoesNotExistError, ioeGetFileName ) - -import Distribution.Client.Targets -import Distribution.Client.Configure - ( chooseCabalVersion, configureSetupScript, checkConfigExFlags ) -import Distribution.Client.Dependency -import Distribution.Client.Dependency.Types - ( Solver(..) ) -import Distribution.Client.FetchUtils -import Distribution.Client.HttpUtils - ( HttpTransport (..) ) -import Distribution.Solver.Types.PackageFixedDeps -import qualified Distribution.Client.Haddock as Haddock (regenerateHaddockIndex) -import Distribution.Client.IndexUtils as IndexUtils - ( getSourcePackagesAtIndexState, getInstalledPackages ) -import qualified Distribution.Client.InstallPlan as InstallPlan -import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan -import Distribution.Client.InstallPlan (InstallPlan) -import Distribution.Client.SolverInstallPlan (SolverInstallPlan) -import Distribution.Client.Setup - ( GlobalFlags(..), RepoContext(..) - , ConfigFlags(..), configureCommand, filterConfigureFlags - , ConfigExFlags(..), InstallFlags(..) - , filterTestFlags ) -import Distribution.Client.Config - ( getCabalDir, defaultUserInstall ) -import Distribution.Client.Tar (extractTarGzFile) -import Distribution.Client.Types as Source -import Distribution.Client.BuildReports.Types - ( ReportLevel(..) ) -import Distribution.Client.SetupWrapper - ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) -import Distribution.Client.BuildReports.Anonymous (showBuildReport) -import qualified Distribution.Client.BuildReports.Anonymous as BuildReports -import qualified Distribution.Client.BuildReports.Storage as BuildReports - ( storeAnonymous, storeLocal, fromInstallPlan, fromPlanningFailure ) -import qualified Distribution.Client.InstallSymlink as InstallSymlink - ( symlinkBinaries ) -import Distribution.Client.Types.OverwritePolicy (OverwritePolicy (..)) -import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade -import qualified Distribution.Client.World as World -import qualified Distribution.InstalledPackageInfo as Installed -import Distribution.Client.JobControl - -import qualified Distribution.Solver.Types.ComponentDeps as CD -import Distribution.Solver.Types.ConstraintSource -import Distribution.Solver.Types.Settings -import Distribution.Solver.Types.LabeledPackageConstraint -import Distribution.Solver.Types.OptionalStanza -import qualified Distribution.Solver.Types.PackageIndex as SourcePackageIndex -import Distribution.Solver.Types.PkgConfigDb - ( PkgConfigDb, readPkgConfigDb ) -import Distribution.Solver.Types.SourcePackage as SourcePackage - -import Distribution.Utils.NubList -import Distribution.Simple.Compiler - ( CompilerId(..), Compiler(compilerId), compilerFlavor - , CompilerInfo(..), compilerInfo, PackageDB(..), PackageDBStack ) -import Distribution.Simple.Program (ProgramDb) -import qualified Distribution.Simple.InstallDirs as InstallDirs -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.PackageIndex (InstalledPackageIndex) -import Distribution.Simple.Setup - ( haddockCommand, HaddockFlags(..) - , buildCommand, BuildFlags(..), emptyBuildFlags - , TestFlags, BenchmarkFlags - , toFlag, fromFlag, fromFlagOrDefault, flagToMaybe, defaultDistPref ) -import qualified Distribution.Simple.Setup as Cabal - ( Flag(..) - , copyCommand, CopyFlags(..), emptyCopyFlags - , registerCommand, RegisterFlags(..), emptyRegisterFlags - , testCommand, TestFlags(..) ) -import Distribution.Simple.Utils - ( createDirectoryIfMissingVerbose, writeFileAtomic ) -import Distribution.Simple.InstallDirs as InstallDirs - ( PathTemplate, fromPathTemplate, toPathTemplate, substPathTemplate - , initialPathTemplateEnv, installDirsTemplateEnv ) -import Distribution.Simple.Configure (interpretPackageDbFlags) -import Distribution.Simple.Register (registerPackage, defaultRegisterOptions) -import Distribution.Package - ( PackageIdentifier(..), PackageId, packageName, packageVersion - , Package(..), HasMungedPackageId(..), HasUnitId(..) - , UnitId ) -import Distribution.Types.Dependency - ( Dependency (..), mainLibSet ) -import Distribution.Types.GivenComponent - ( GivenComponent(..) ) -import Distribution.Types.PackageVersionConstraint - ( PackageVersionConstraint(..), thisPackageVersionConstraint ) -import Distribution.Types.MungedPackageId -import qualified Distribution.PackageDescription as PackageDescription -import Distribution.PackageDescription - ( PackageDescription, GenericPackageDescription(..) ) -import Distribution.Types.Flag - ( PackageFlag(..), FlagAssignment, mkFlagAssignment - , showFlagAssignment, diffFlagAssignment, nullFlagAssignment ) -import Distribution.PackageDescription.Configuration - ( finalizePD ) -import Distribution.Version - ( Version, VersionRange, foldVersionRange ) -import Distribution.Simple.Utils as Utils - ( notice, info, warn, debug, debugNoWrap, die' - , withTempDirectory ) -import Distribution.Client.Utils - ( determineNumJobs, logDirChange, mergeBy, MergeResult(..) - , ProgressPhase(..), progressMessage ) -import Distribution.System - ( Platform, OS(Windows), buildOS, buildPlatform ) -import Distribution.Verbosity as Verbosity - ( modifyVerbosity, normal, verbose ) -import Distribution.Simple.BuildPaths ( exeExtension ) - -import qualified Data.ByteString as BS - ---TODO: --- * assign flags to packages individually --- * complain about flags that do not apply to any package given as target --- so flags do not apply to dependencies, only listed, can use flag --- constraints for dependencies --- * only record applicable flags in world file --- * allow flag constraints --- * allow installed constraints --- * allow flag and installed preferences --- * change world file to use cabal section syntax --- * allow persistent configure flags for each package individually - --- ------------------------------------------------------------ --- * Top level user actions --- ------------------------------------------------------------ - --- | Installs the packages needed to satisfy a list of dependencies. --- -install - :: Verbosity - -> PackageDBStack - -> RepoContext - -> Compiler - -> Platform - -> ProgramDb - -> GlobalFlags - -> ConfigFlags - -> ConfigExFlags - -> InstallFlags - -> HaddockFlags - -> TestFlags - -> BenchmarkFlags - -> [UserTarget] - -> IO () -install verbosity packageDBs repos comp platform progdb - globalFlags configFlags configExFlags installFlags - haddockFlags testFlags benchmarkFlags userTargets0 = do - - unless (installRootCmd installFlags == Cabal.NoFlag) $ - warn verbosity $ "--root-cmd is no longer supported, " - ++ "see https://github.com/haskell/cabal/issues/3353" - ++ " (if you didn't type --root-cmd, comment out root-cmd" - ++ " in your ~/.cabal/config file)" - let userOrSandbox = fromFlag (configUserInstall configFlags) - unless userOrSandbox $ - warn verbosity $ "the --global flag is deprecated -- " - ++ "it is generally considered a bad idea to install packages " - ++ "into the global store" - - installContext <- makeInstallContext verbosity args (Just userTargets0) - planResult <- foldProgress logMsg (return . Left) (return . Right) =<< - makeInstallPlan verbosity args installContext - - case planResult of - Left message -> do - reportPlanningFailure verbosity args installContext message - die'' message - Right installPlan -> - processInstallPlan verbosity args installContext installPlan - where - args :: InstallArgs - args = (packageDBs, repos, comp, platform, progdb, - globalFlags, configFlags, configExFlags, - installFlags, haddockFlags, testFlags, benchmarkFlags) - - die'' = die' verbosity - - logMsg message rest = debugNoWrap verbosity message >> rest - --- TODO: Make InstallContext a proper data type with documented fields. --- | Common context for makeInstallPlan and processInstallPlan. -type InstallContext = ( InstalledPackageIndex, SourcePackageDb - , PkgConfigDb - , [UserTarget], [PackageSpecifier UnresolvedSourcePackage] - , HttpTransport ) - --- TODO: Make InstallArgs a proper data type with documented fields or just get --- rid of it completely. --- | Initial arguments given to 'install' or 'makeInstallContext'. -type InstallArgs = ( PackageDBStack - , RepoContext - , Compiler - , Platform - , ProgramDb - , GlobalFlags - , ConfigFlags - , ConfigExFlags - , InstallFlags - , HaddockFlags - , TestFlags - , BenchmarkFlags ) - --- | Make an install context given install arguments. -makeInstallContext :: Verbosity -> InstallArgs -> Maybe [UserTarget] - -> IO InstallContext -makeInstallContext verbosity - (packageDBs, repoCtxt, comp, _, progdb, - globalFlags, _, configExFlags, installFlags, _, _, _) mUserTargets = do - - let idxState = flagToMaybe (installIndexState installFlags) - - installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb - (sourcePkgDb, _, _) <- getSourcePackagesAtIndexState verbosity repoCtxt idxState Nothing - pkgConfigDb <- readPkgConfigDb verbosity progdb - - checkConfigExFlags verbosity installedPkgIndex - (packageIndex sourcePkgDb) configExFlags - transport <- repoContextGetTransport repoCtxt - - (userTargets, pkgSpecifiers) <- case mUserTargets of - Nothing -> - -- We want to distinguish between the case where the user has given an - -- empty list of targets on the command-line and the case where we - -- specifically want to have an empty list of targets. - return ([], []) - Just userTargets0 -> do - -- For install, if no target is given it means we use the current - -- directory as the single target. - let userTargets | null userTargets0 = [UserTargetLocalDir "."] - | otherwise = userTargets0 - - pkgSpecifiers <- resolveUserTargets verbosity repoCtxt - (fromFlag $ globalWorldFile globalFlags) - (packageIndex sourcePkgDb) - userTargets - return (userTargets, pkgSpecifiers) - - return (installedPkgIndex, sourcePkgDb, pkgConfigDb, userTargets - ,pkgSpecifiers, transport) - --- | Make an install plan given install context and install arguments. -makeInstallPlan :: Verbosity -> InstallArgs -> InstallContext - -> IO (Progress String String SolverInstallPlan) -makeInstallPlan verbosity - (_, _, comp, platform,_, - _, configFlags, configExFlags, installFlags, - _, _, _) - (installedPkgIndex, sourcePkgDb, pkgConfigDb, - _, pkgSpecifiers, _) = do - - solver <- chooseSolver verbosity (fromFlag (configSolver configExFlags)) - (compilerInfo comp) - notice verbosity "Resolving dependencies..." - return $ planPackages verbosity comp platform solver - configFlags configExFlags installFlags - installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers - --- | Given an install plan, perform the actual installations. -processInstallPlan :: Verbosity -> InstallArgs -> InstallContext - -> SolverInstallPlan - -> IO () -processInstallPlan verbosity - args@(_,_, _, _, _, _, configFlags, _, installFlags, _, _, _) - (installedPkgIndex, sourcePkgDb, _, - userTargets, pkgSpecifiers, _) installPlan0 = do - - checkPrintPlan verbosity installedPkgIndex installPlan sourcePkgDb - installFlags pkgSpecifiers - - unless (dryRun || nothingToInstall) $ do - buildOutcomes <- performInstallations verbosity - args installedPkgIndex installPlan - postInstallActions verbosity args userTargets installPlan buildOutcomes - where - installPlan = InstallPlan.configureInstallPlan configFlags installPlan0 - dryRun = fromFlag (installDryRun installFlags) - nothingToInstall = null (fst (InstallPlan.ready installPlan)) - --- ------------------------------------------------------------ --- * Installation planning --- ------------------------------------------------------------ - -planPackages :: Verbosity - -> Compiler - -> Platform - -> Solver - -> ConfigFlags - -> ConfigExFlags - -> InstallFlags - -> InstalledPackageIndex - -> SourcePackageDb - -> PkgConfigDb - -> [PackageSpecifier UnresolvedSourcePackage] - -> Progress String String SolverInstallPlan -planPackages verbosity comp platform solver - configFlags configExFlags installFlags - installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers = - - resolveDependencies - platform (compilerInfo comp) pkgConfigDb - solver - resolverParams - - >>= if onlyDeps then pruneInstallPlan pkgSpecifiers else return - - where - resolverParams = - - setMaxBackjumps (if maxBackjumps < 0 then Nothing - else Just maxBackjumps) - - . setIndependentGoals independentGoals - - . setReorderGoals reorderGoals - - . setCountConflicts countConflicts - - . setFineGrainedConflicts fineGrainedConflicts - - . setMinimizeConflictSet minimizeConflictSet - - . setAvoidReinstalls avoidReinstalls - - . setShadowPkgs shadowPkgs - - . setStrongFlags strongFlags - - . setAllowBootLibInstalls allowBootLibInstalls - - . setOnlyConstrained onlyConstrained - - . setSolverVerbosity verbosity - - . setPreferenceDefault (if upgradeDeps then PreferAllLatest - else PreferLatestForSelected) - - . removeLowerBounds allowOlder - . removeUpperBounds allowNewer - - . addPreferences - -- preferences from the config file or command line - [ PackageVersionPreference name ver - | PackageVersionConstraint name ver <- configPreferences configExFlags ] - - . addConstraints - -- version constraints from the config file or command line - [ LabeledPackageConstraint (userToPackageConstraint pc) src - | (pc, src) <- configExConstraints configExFlags ] - - . addConstraints - --FIXME: this just applies all flags to all targets which - -- is silly. We should check if the flags are appropriate - [ let pc = PackageConstraint - (scopeToplevel $ pkgSpecifierTarget pkgSpecifier) - (PackagePropertyFlags flags) - in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget - | let flags = configConfigurationsFlags configFlags - , not (nullFlagAssignment flags) - , pkgSpecifier <- pkgSpecifiers ] - - . addConstraints - [ let pc = PackageConstraint - (scopeToplevel $ pkgSpecifierTarget pkgSpecifier) - (PackagePropertyStanzas stanzas) - in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget - | pkgSpecifier <- pkgSpecifiers ] - - . (if reinstall then reinstallTargets else id) - - -- Don't solve for executables, the legacy install codepath - -- doesn't understand how to install them - . setSolveExecutables (SolveExecutables False) - - $ standardInstallPolicy - installedPkgIndex sourcePkgDb pkgSpecifiers - - stanzas = [ TestStanzas | testsEnabled ] - ++ [ BenchStanzas | benchmarksEnabled ] - testsEnabled = fromFlagOrDefault False $ configTests configFlags - benchmarksEnabled = fromFlagOrDefault False $ configBenchmarks configFlags - - reinstall = fromFlag (installOverrideReinstall installFlags) || - fromFlag (installReinstall installFlags) - reorderGoals = fromFlag (installReorderGoals installFlags) - countConflicts = fromFlag (installCountConflicts installFlags) - fineGrainedConflicts = fromFlag (installFineGrainedConflicts installFlags) - minimizeConflictSet = fromFlag (installMinimizeConflictSet installFlags) - independentGoals = fromFlag (installIndependentGoals installFlags) - avoidReinstalls = fromFlag (installAvoidReinstalls installFlags) - shadowPkgs = fromFlag (installShadowPkgs installFlags) - strongFlags = fromFlag (installStrongFlags installFlags) - maxBackjumps = fromFlag (installMaxBackjumps installFlags) - allowBootLibInstalls = fromFlag (installAllowBootLibInstalls installFlags) - onlyConstrained = fromFlag (installOnlyConstrained installFlags) - upgradeDeps = fromFlag (installUpgradeDeps installFlags) - onlyDeps = fromFlag (installOnlyDeps installFlags) - - allowOlder = fromMaybe (AllowOlder mempty) - (configAllowOlder configExFlags) - allowNewer = fromMaybe (AllowNewer mempty) - (configAllowNewer configExFlags) - --- | Remove the provided targets from the install plan. -pruneInstallPlan :: Package targetpkg - => [PackageSpecifier targetpkg] - -> SolverInstallPlan - -> Progress String String SolverInstallPlan -pruneInstallPlan pkgSpecifiers = - -- TODO: this is a general feature and should be moved to D.C.Dependency - -- Also, the InstallPlan.remove should return info more precise to the - -- problem, rather than the very general PlanProblem type. - either (Fail . explain) Done - . SolverInstallPlan.remove (\pkg -> packageName pkg `elem` targetnames) - where - explain :: [SolverInstallPlan.SolverPlanProblem] -> String - explain problems = - "Cannot select only the dependencies (as requested by the " - ++ "'--only-dependencies' flag), " - ++ (case pkgids of - [pkgid] -> "the package " ++ prettyShow pkgid ++ " is " - _ -> "the packages " - ++ intercalate ", " (map prettyShow pkgids) ++ " are ") - ++ "required by a dependency of one of the other targets." - where - pkgids = - nub [ depid - | SolverInstallPlan.PackageMissingDeps _ depids <- problems - , depid <- depids - , packageName depid `elem` targetnames ] - - targetnames = map pkgSpecifierTarget pkgSpecifiers - --- ------------------------------------------------------------ --- * Informational messages --- ------------------------------------------------------------ - --- | Perform post-solver checks of the install plan and print it if --- either requested or needed. -checkPrintPlan :: Verbosity - -> InstalledPackageIndex - -> InstallPlan - -> SourcePackageDb - -> InstallFlags - -> [PackageSpecifier UnresolvedSourcePackage] - -> IO () -checkPrintPlan verbosity installed installPlan sourcePkgDb - installFlags pkgSpecifiers = do - - -- User targets that are already installed. - let preExistingTargets = - [ p | let tgts = map pkgSpecifierTarget pkgSpecifiers, - InstallPlan.PreExisting p <- InstallPlan.toList installPlan, - packageName p `elem` tgts ] - - -- If there's nothing to install, we print the already existing - -- target packages as an explanation. - when nothingToInstall $ - notice verbosity $ unlines $ - "All the requested packages are already installed:" - : map (prettyShow . packageId) preExistingTargets - ++ ["Use --reinstall if you want to reinstall anyway."] - - let lPlan = - [ (pkg, status) - | pkg <- InstallPlan.executionOrder installPlan - , let status = packageStatus installed pkg ] - -- Are any packages classified as reinstalls? - let reinstalledPkgs = - [ ipkg - | (_pkg, status) <- lPlan - , ipkg <- extractReinstalls status ] - -- Packages that are already broken. - let oldBrokenPkgs = - map Installed.installedUnitId - . PackageIndex.reverseDependencyClosure installed - . map (Installed.installedUnitId . fst) - . PackageIndex.brokenPackages - $ installed - let excluded = reinstalledPkgs ++ oldBrokenPkgs - -- Packages that are reverse dependencies of replaced packages are very - -- likely to be broken. We exclude packages that are already broken. - let newBrokenPkgs = - filter (\ p -> not (Installed.installedUnitId p `elem` excluded)) - (PackageIndex.reverseDependencyClosure installed reinstalledPkgs) - let containsReinstalls = not (null reinstalledPkgs) - let breaksPkgs = not (null newBrokenPkgs) - - let adaptedVerbosity - | containsReinstalls - , not overrideReinstall = modifyVerbosity (max verbose) verbosity - | otherwise = verbosity - - -- We print the install plan if we are in a dry-run or if we are confronted - -- with a dangerous install plan. - when (dryRun || containsReinstalls && not overrideReinstall) $ - printPlan (dryRun || breaksPkgs && not overrideReinstall) - adaptedVerbosity lPlan sourcePkgDb - - -- If the install plan is dangerous, we print various warning messages. In - -- particular, if we can see that packages are likely to be broken, we even - -- bail out (unless installation has been forced with --force-reinstalls). - when containsReinstalls $ do - if breaksPkgs - then do - (if dryRun || overrideReinstall then warn else die') verbosity $ unlines $ - "The following packages are likely to be broken by the reinstalls:" - : map (prettyShow . mungedId) newBrokenPkgs - ++ if overrideReinstall - then if dryRun then [] else - ["Continuing even though " ++ - "the plan contains dangerous reinstalls."] - else - ["Use --force-reinstalls if you want to install anyway."] - else unless dryRun $ warn verbosity - "Note that reinstalls are always dangerous. Continuing anyway..." - - -- If we are explicitly told to not download anything, check that all packages - -- are already fetched. - let offline = fromFlagOrDefault False (installOfflineMode installFlags) - when offline $ do - let pkgs = [ confPkgSource cpkg - | InstallPlan.Configured cpkg <- InstallPlan.toList installPlan ] - notFetched <- fmap (map packageId) - . filterM (fmap isNothing . checkFetched . srcpkgSource) - $ pkgs - unless (null notFetched) $ - die' verbosity $ "Can't download packages in offline mode. " - ++ "Must download the following packages to proceed:\n" - ++ intercalate ", " (map prettyShow notFetched) - ++ "\nTry using 'cabal fetch'." - - where - nothingToInstall = null (fst (InstallPlan.ready installPlan)) - - dryRun = fromFlag (installDryRun installFlags) - overrideReinstall = fromFlag (installOverrideReinstall installFlags) - -data PackageStatus = NewPackage - | NewVersion [Version] - | Reinstall [UnitId] [PackageChange] - -type PackageChange = MergeResult MungedPackageId MungedPackageId - -extractReinstalls :: PackageStatus -> [UnitId] -extractReinstalls (Reinstall ipids _) = ipids -extractReinstalls _ = [] - -packageStatus :: InstalledPackageIndex - -> ReadyPackage - -> PackageStatus -packageStatus installedPkgIndex cpkg = - case PackageIndex.lookupPackageName installedPkgIndex - (packageName cpkg) of - [] -> NewPackage - ps -> case filter ((== mungedId cpkg) - . mungedId) (concatMap snd ps) of - [] -> NewVersion (map fst ps) - pkgs@(pkg:_) -> Reinstall (map Installed.installedUnitId pkgs) - (changes pkg cpkg) - - where - - changes :: Installed.InstalledPackageInfo - -> ReadyPackage - -> [PackageChange] - changes pkg (ReadyPackage pkg') = filter changed $ - mergeBy (comparing mungedName) - -- deps of installed pkg - (resolveInstalledIds $ Installed.depends pkg) - -- deps of configured pkg - (resolveInstalledIds $ CD.nonSetupDeps (depends pkg')) - - -- convert to source pkg ids via index - resolveInstalledIds :: [UnitId] -> [MungedPackageId] - resolveInstalledIds = - nub - . sort - . map mungedId - . mapMaybe (PackageIndex.lookupUnitId installedPkgIndex) - - changed (InBoth pkgid pkgid') = pkgid /= pkgid' - changed _ = True - -printPlan :: Bool -- is dry run - -> Verbosity - -> [(ReadyPackage, PackageStatus)] - -> SourcePackageDb - -> IO () -printPlan dryRun verbosity plan sourcePkgDb = case plan of - [] -> return () - pkgs - | verbosity >= Verbosity.verbose -> notice verbosity $ unlines $ - ("In order, the following " ++ wouldWill ++ " be installed:") - : map showPkgAndReason pkgs - | otherwise -> notice verbosity $ unlines $ - ("In order, the following " ++ wouldWill - ++ " be installed (use -v for more details):") - : map showPkg pkgs - where - wouldWill | dryRun = "would" - | otherwise = "will" - - showPkg (pkg, _) = prettyShow (packageId pkg) ++ - showLatest (pkg) - - showPkgAndReason (ReadyPackage pkg', pr) = unwords - [ prettyShow (packageId pkg') - , showLatest pkg' - , showFlagAssignment (nonDefaultFlags pkg') - , showStanzas (confPkgStanzas pkg') - , showDep pkg' - , case pr of - NewPackage -> "(new package)" - NewVersion _ -> "(new version)" - Reinstall _ cs -> "(reinstall)" ++ case cs of - [] -> "" - diff -> "(changes: " ++ intercalate ", " (map change diff) - ++ ")" - ] - - showLatest :: Package srcpkg => srcpkg -> String - showLatest pkg = case mLatestVersion of - Just latestVersion -> - if packageVersion pkg < latestVersion - then ("(latest: " ++ prettyShow latestVersion ++ ")") - else "" - Nothing -> "" - where - mLatestVersion :: Maybe Version - mLatestVersion = fmap packageVersion $ - safeLast $ - SourcePackageIndex.lookupPackageName - (packageIndex sourcePkgDb) - (packageName pkg) - - toFlagAssignment :: [PackageFlag] -> FlagAssignment - toFlagAssignment = mkFlagAssignment . map (\ f -> (flagName f, flagDefault f)) - - nonDefaultFlags :: ConfiguredPackage loc -> FlagAssignment - nonDefaultFlags cpkg = - let defaultAssignment = - toFlagAssignment - (genPackageFlags (SourcePackage.srcpkgDescription $ - confPkgSource cpkg)) - in confPkgFlags cpkg `diffFlagAssignment` defaultAssignment - - showStanzas :: [OptionalStanza] -> String - showStanzas = unwords . map (("*" ++) . showStanza) - - change (OnlyInLeft pkgid) = prettyShow pkgid ++ " removed" - change (InBoth pkgid pkgid') = prettyShow pkgid ++ " -> " - ++ prettyShow (mungedVersion pkgid') - change (OnlyInRight pkgid') = prettyShow pkgid' ++ " added" - - showDep pkg | Just rdeps <- Map.lookup (packageId pkg) revDeps - = " (via: " ++ unwords (map prettyShow rdeps) ++ ")" - | otherwise = "" - - revDepGraphEdges :: [(PackageId, PackageId)] - revDepGraphEdges = [ (rpid, packageId cpkg) - | (ReadyPackage cpkg, _) <- plan - , ConfiguredId - rpid - (Just - (PackageDescription.CLibName - PackageDescription.LMainLibName)) - _ - <- CD.flatDeps (confPkgDeps cpkg) ] - - revDeps :: Map.Map PackageId [PackageId] - revDeps = Map.fromListWith (++) (map (fmap (:[])) revDepGraphEdges) - --- ------------------------------------------------------------ --- * Post installation stuff --- ------------------------------------------------------------ - --- | Report a solver failure. This works slightly differently to --- 'postInstallActions', as (by definition) we don't have an install plan. -reportPlanningFailure :: Verbosity -> InstallArgs -> InstallContext -> String - -> IO () -reportPlanningFailure verbosity - (_, _, comp, platform, _ - ,_, configFlags, _, installFlags, _, _, _) - (_, sourcePkgDb, _, _, pkgSpecifiers, _) - message = do - - when reportFailure $ do - - -- Only create reports for explicitly named packages - let pkgids = filter - (SourcePackageIndex.elemByPackageId (packageIndex sourcePkgDb)) $ - mapMaybe theSpecifiedPackage pkgSpecifiers - - buildReports = BuildReports.fromPlanningFailure platform - (compilerId comp) pkgids - (configConfigurationsFlags configFlags) - - unless (null buildReports) $ - info verbosity $ - "Solver failure will be reported for " - ++ intercalate "," (map prettyShow pkgids) - - -- Save reports - BuildReports.storeLocal (compilerInfo comp) - (fromNubList $ installSummaryFile installFlags) - buildReports platform - - -- Save solver log - case logFile of - Nothing -> return () - Just template -> for_ pkgids $ \pkgid -> - let env = initialPathTemplateEnv pkgid dummyIpid - (compilerInfo comp) platform - path = fromPathTemplate $ substPathTemplate env template - in writeFile path message - - where - reportFailure = fromFlag (installReportPlanningFailure installFlags) - logFile = flagToMaybe (installLogFile installFlags) - - -- A IPID is calculated from the transitive closure of - -- dependencies, but when the solver fails we don't have that. - -- So we fail. - dummyIpid = error "reportPlanningFailure: installed package ID not available" - --- | If a 'PackageSpecifier' refers to a single package, return Just that --- package. -theSpecifiedPackage :: Package pkg => PackageSpecifier pkg -> Maybe PackageId -theSpecifiedPackage pkgSpec = - case pkgSpec of - NamedPackage name [PackagePropertyVersion version] - -> PackageIdentifier name <$> trivialRange version - NamedPackage _ _ -> Nothing - SpecificSourcePackage pkg -> Just $ packageId pkg - where - -- | If a range includes only a single version, return Just that version. - trivialRange :: VersionRange -> Maybe Version - trivialRange = foldVersionRange - Nothing - Just -- "== v" - (\_ -> Nothing) - (\_ -> Nothing) - (\_ _ -> Nothing) - (\_ _ -> Nothing) - --- | Various stuff we do after successful or unsuccessfully installing a bunch --- of packages. This includes: --- --- * build reporting, local and remote --- * symlinking binaries --- * updating indexes --- * updating world file --- * error reporting --- -postInstallActions :: Verbosity - -> InstallArgs - -> [UserTarget] - -> InstallPlan - -> BuildOutcomes - -> IO () -postInstallActions verbosity - (packageDBs, _, comp, platform, progdb - ,globalFlags, configFlags, _, installFlags, _, _, _) - targets installPlan buildOutcomes = do - - unless oneShot $ - World.insert verbosity worldFile - --FIXME: does not handle flags - [ World.WorldPkgInfo (Dependency pn vr mainLibSet) mempty - | UserTargetNamed (PackageVersionConstraint pn vr) <- targets ] - - let buildReports = BuildReports.fromInstallPlan platform (compilerId comp) - installPlan buildOutcomes - BuildReports.storeLocal (compilerInfo comp) - (fromNubList $ installSummaryFile installFlags) - buildReports - platform - when (reportingLevel >= AnonymousReports) $ - BuildReports.storeAnonymous buildReports - when (reportingLevel == DetailedReports) $ - storeDetailedBuildReports verbosity logsDir buildReports - - regenerateHaddockIndex verbosity packageDBs comp platform progdb - configFlags installFlags buildOutcomes - - symlinkBinaries verbosity platform comp configFlags installFlags - installPlan buildOutcomes - - printBuildFailures verbosity buildOutcomes - - where - reportingLevel = fromFlag (installBuildReports installFlags) - logsDir = fromFlag (globalLogsDir globalFlags) - oneShot = fromFlag (installOneShot installFlags) - worldFile = fromFlag $ globalWorldFile globalFlags - -storeDetailedBuildReports :: Verbosity -> FilePath - -> [(BuildReports.BuildReport, Maybe Repo)] -> IO () -storeDetailedBuildReports verbosity logsDir reports = sequence_ - [ do dotCabal <- getCabalDir - let logFileName = prettyShow (BuildReports.package report) <.> "log" - logFile = logsDir logFileName - reportsDir = dotCabal "reports" unRepoName (remoteRepoName remoteRepo) - reportFile = reportsDir logFileName - - handleMissingLogFile $ do - buildLog <- readFile logFile - createDirectoryIfMissing True reportsDir -- FIXME - writeFile reportFile (show (showBuildReport report, buildLog)) - - | (report, Just repo) <- reports - , Just remoteRepo <- [maybeRepoRemote repo] - , isLikelyToHaveLogFile (BuildReports.installOutcome report) ] - - where - isLikelyToHaveLogFile BuildReports.ConfigureFailed {} = True - isLikelyToHaveLogFile BuildReports.BuildFailed {} = True - isLikelyToHaveLogFile BuildReports.InstallFailed {} = True - isLikelyToHaveLogFile BuildReports.InstallOk {} = True - isLikelyToHaveLogFile _ = False - - handleMissingLogFile = Exception.handleJust missingFile $ \ioe -> - warn verbosity $ "Missing log file for build report: " - ++ fromMaybe "" (ioeGetFileName ioe) - - missingFile ioe - | isDoesNotExistError ioe = Just ioe - missingFile _ = Nothing - - -regenerateHaddockIndex :: Verbosity - -> [PackageDB] - -> Compiler - -> Platform - -> ProgramDb - -> ConfigFlags - -> InstallFlags - -> BuildOutcomes - -> IO () -regenerateHaddockIndex verbosity packageDBs comp platform progdb - configFlags installFlags buildOutcomes - | haddockIndexFileIsRequested && shouldRegenerateHaddockIndex = do - - defaultDirs <- InstallDirs.defaultInstallDirs - (compilerFlavor comp) - (fromFlag (configUserInstall configFlags)) - True - let indexFileTemplate = fromFlag (installHaddockIndex installFlags) - indexFile = substHaddockIndexFileName defaultDirs indexFileTemplate - - notice verbosity $ - "Updating documentation index " ++ indexFile - - --TODO: might be nice if the install plan gave us the new InstalledPackageInfo - installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb - Haddock.regenerateHaddockIndex verbosity installedPkgIndex progdb indexFile - - | otherwise = return () - where - haddockIndexFileIsRequested = - fromFlag (installDocumentation installFlags) - && isJust (flagToMaybe (installHaddockIndex installFlags)) - - -- We want to regenerate the index if some new documentation was actually - -- installed. Since the index can be only per-user or per-sandbox (see - -- #1337), we don't do it for global installs or special cases where we're - -- installing into a specific db. - shouldRegenerateHaddockIndex = normalUserInstall && someDocsWereInstalled buildOutcomes - where - someDocsWereInstalled = any installedDocs . Map.elems - installedDocs (Right (BuildResult DocsOk _ _)) = True - installedDocs _ = False - - normalUserInstall = (UserPackageDB `elem` packageDBs) - && all (not . isSpecificPackageDB) packageDBs - isSpecificPackageDB (SpecificPackageDB _) = True - isSpecificPackageDB _ = False - - substHaddockIndexFileName defaultDirs = fromPathTemplate - . substPathTemplate env - where - env = env0 ++ installDirsTemplateEnv absoluteDirs - env0 = InstallDirs.compilerTemplateEnv (compilerInfo comp) - ++ InstallDirs.platformTemplateEnv platform - ++ InstallDirs.abiTemplateEnv (compilerInfo comp) platform - absoluteDirs = InstallDirs.substituteInstallDirTemplates - env0 templateDirs - templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault - defaultDirs (configInstallDirs configFlags) - - -symlinkBinaries :: Verbosity - -> Platform -> Compiler - -> ConfigFlags - -> InstallFlags - -> InstallPlan - -> BuildOutcomes - -> IO () -symlinkBinaries verbosity platform comp configFlags installFlags - plan buildOutcomes = do - failed <- InstallSymlink.symlinkBinaries platform comp - NeverOverwrite - configFlags installFlags - plan buildOutcomes - case failed of - [] -> return () - [(_, exe, path)] -> - warn verbosity $ - "could not create a symlink in " ++ bindir ++ " for " - ++ prettyShow exe ++ " because the file exists there already but is not " - ++ "managed by cabal. You can create a symlink for this executable " - ++ "manually if you wish. The executable file has been installed at " - ++ path - exes -> - warn verbosity $ - "could not create symlinks in " ++ bindir ++ " for " - ++ intercalate ", " [ prettyShow exe | (_, exe, _) <- exes ] - ++ " because the files exist there already and are not " - ++ "managed by cabal. You can create symlinks for these executables " - ++ "manually if you wish. The executable files have been installed at " - ++ intercalate ", " [ path | (_, _, path) <- exes ] - where - bindir = fromFlag (installSymlinkBinDir installFlags) - - -printBuildFailures :: Verbosity -> BuildOutcomes -> IO () -printBuildFailures verbosity buildOutcomes = - case [ (pkgid, failure) - | (pkgid, Left failure) <- Map.toList buildOutcomes ] of - [] -> return () - failed -> die' verbosity . unlines - $ "Error: some packages failed to install:" - : [ prettyShow pkgid ++ printFailureReason reason - | (pkgid, reason) <- failed ] - where - printFailureReason reason = case reason of - DependentFailed pkgid -> " depends on " ++ prettyShow pkgid - ++ " which failed to install." - DownloadFailed e -> " failed while downloading the package." - ++ showException e - UnpackFailed e -> " failed while unpacking the package." - ++ showException e - ConfigureFailed e -> " failed during the configure step." - ++ showException e - BuildFailed e -> " failed during the building phase." - ++ showException e - TestsFailed e -> " failed during the tests phase." - ++ showException e - InstallFailed e -> " failed during the final install step." - ++ showException e - - -- This will never happen, but we include it for completeness - PlanningFailed -> " failed during the planning phase." - - showException e = " The exception was:\n " ++ show e ++ maybeOOM e -#ifdef mingw32_HOST_OS - maybeOOM _ = "" -#else - maybeOOM e = maybe "" onExitFailure (fromException e) - onExitFailure (ExitFailure n) - | n == 9 || n == -9 = - "\nThis may be due to an out-of-memory condition." - onExitFailure _ = "" -#endif - --- ------------------------------------------------------------ --- * Actually do the installations --- ------------------------------------------------------------ - -data InstallMisc = InstallMisc { - libVersion :: Maybe Version - } - --- | If logging is enabled, contains location of the log file and the verbosity --- level for logging. -type UseLogFile = Maybe (PackageIdentifier -> UnitId -> FilePath, Verbosity) - -performInstallations :: Verbosity - -> InstallArgs - -> InstalledPackageIndex - -> InstallPlan - -> IO BuildOutcomes -performInstallations verbosity - (packageDBs, repoCtxt, comp, platform, progdb, - globalFlags, configFlags, configExFlags, installFlags, - haddockFlags, testFlags, _) - installedPkgIndex installPlan = do - - info verbosity $ "Number of threads used: " ++ (show numJobs) ++ "." - - jobControl <- if parallelInstall then newParallelJobControl numJobs - else newSerialJobControl - fetchLimit <- newJobLimit (min numJobs numFetchJobs) - installLock <- newLock -- serialise installation - cacheLock <- newLock -- serialise access to setup exe cache - - executeInstallPlan verbosity jobControl keepGoing useLogFile - installPlan $ \rpkg -> - installReadyPackage platform cinfo configFlags - rpkg $ \configFlags' src pkg pkgoverride -> - fetchSourcePackage verbosity repoCtxt fetchLimit src $ \src' -> - installLocalPackage verbosity (packageId pkg) src' distPref $ \mpath -> - installUnpackedPackage verbosity installLock numJobs - (setupScriptOptions installedPkgIndex - cacheLock rpkg) - configFlags' - installFlags haddockFlags testFlags - comp progdb - platform pkg rpkg pkgoverride mpath useLogFile - - where - cinfo = compilerInfo comp - - numJobs = determineNumJobs (installNumJobs installFlags) - numFetchJobs = 2 - parallelInstall = numJobs >= 2 - keepGoing = fromFlag (installKeepGoing installFlags) - distPref = fromFlagOrDefault (useDistPref defaultSetupScriptOptions) - (configDistPref configFlags) - - setupScriptOptions index lock rpkg = - configureSetupScript - packageDBs - comp - platform - progdb - distPref - (chooseCabalVersion configExFlags (libVersion miscOptions)) - (Just lock) - parallelInstall - index - (Just rpkg) - - reportingLevel = fromFlag (installBuildReports installFlags) - logsDir = fromFlag (globalLogsDir globalFlags) - - -- Should the build output be written to a log file instead of stdout? - useLogFile :: UseLogFile - useLogFile = fmap ((\f -> (f, loggingVerbosity)) . substLogFileName) - logFileTemplate - where - installLogFile' = flagToMaybe $ installLogFile installFlags - defaultTemplate = toPathTemplate $ - logsDir "$compiler" "$libname" <.> "log" - - -- If the user has specified --remote-build-reporting=detailed, use the - -- default log file location. If the --build-log option is set, use the - -- provided location. Otherwise don't use logging, unless building in - -- parallel (in which case the default location is used). - logFileTemplate :: Maybe PathTemplate - logFileTemplate - | useDefaultTemplate = Just defaultTemplate - | otherwise = installLogFile' - - -- If the user has specified --remote-build-reporting=detailed or - -- --build-log, use more verbose logging. - loggingVerbosity :: Verbosity - loggingVerbosity | overrideVerbosity = modifyVerbosity (max verbose) verbosity - | otherwise = verbosity - - useDefaultTemplate :: Bool - useDefaultTemplate - | reportingLevel == DetailedReports = True - | isJust installLogFile' = False - | parallelInstall = True - | otherwise = False - - overrideVerbosity :: Bool - overrideVerbosity - | reportingLevel == DetailedReports = True - | isJust installLogFile' = True - | parallelInstall = False - | otherwise = False - - substLogFileName :: PathTemplate -> PackageIdentifier -> UnitId -> FilePath - substLogFileName template pkg uid = fromPathTemplate - . substPathTemplate env - $ template - where env = initialPathTemplateEnv (packageId pkg) uid - (compilerInfo comp) platform - - miscOptions = InstallMisc { - libVersion = flagToMaybe (configCabalVersion configExFlags) - } - - -executeInstallPlan :: Verbosity - -> JobControl IO (UnitId, BuildOutcome) - -> Bool - -> UseLogFile - -> InstallPlan - -> (ReadyPackage -> IO BuildOutcome) - -> IO BuildOutcomes -executeInstallPlan verbosity jobCtl keepGoing useLogFile plan0 installPkg = - InstallPlan.execute - jobCtl keepGoing depsFailure plan0 $ \pkg -> do - buildOutcome <- installPkg pkg - printBuildResult (packageId pkg) (installedUnitId pkg) buildOutcome - return buildOutcome - - where - depsFailure = DependentFailed . packageId - - -- Print build log if something went wrong, and 'Installed $PKGID' - -- otherwise. - printBuildResult :: PackageId -> UnitId -> BuildOutcome -> IO () - printBuildResult pkgid uid buildOutcome = case buildOutcome of - (Right _) -> progressMessage verbosity ProgressCompleted (prettyShow pkgid) - (Left _) -> do - notice verbosity $ "Failed to install " ++ prettyShow pkgid - when (verbosity >= normal) $ - case useLogFile of - Nothing -> return () - Just (mkLogFileName, _) -> do - let logName = mkLogFileName pkgid uid - putStr $ "Build log ( " ++ logName ++ " ):\n" - printFile logName - - printFile :: FilePath -> IO () - printFile path = readFile path >>= putStr - --- | Call an installer for an 'SourcePackage' but override the configure --- flags with the ones given by the 'ReadyPackage'. In particular the --- 'ReadyPackage' specifies an exact 'FlagAssignment' and exactly --- versioned package dependencies. So we ignore any previous partial flag --- assignment or dependency constraints and use the new ones. --- --- NB: when updating this function, don't forget to also update --- 'configurePackage' in D.C.Configure. -installReadyPackage :: Platform -> CompilerInfo - -> ConfigFlags - -> ReadyPackage - -> (ConfigFlags -> UnresolvedPkgLoc - -> PackageDescription - -> PackageDescriptionOverride - -> a) - -> a -installReadyPackage platform cinfo configFlags - (ReadyPackage (ConfiguredPackage ipid - (SourcePackage _ gpkg source pkgoverride) - flags stanzas deps)) - installPkg = - installPkg configFlags { - configIPID = toFlag (prettyShow ipid), - configConfigurationsFlags = flags, - -- We generate the legacy constraints as well as the new style precise deps. - -- In the end only one set gets passed to Setup.hs configure, depending on - -- the Cabal version we are talking to. - configConstraints = [ thisPackageVersionConstraint srcid - | ConfiguredId - srcid - (Just - (PackageDescription.CLibName - PackageDescription.LMainLibName)) - _ipid - <- CD.nonSetupDeps deps ], - configDependencies = [ GivenComponent (packageName srcid) cname dep_ipid - | ConfiguredId srcid (Just (PackageDescription.CLibName cname)) dep_ipid - <- CD.nonSetupDeps deps ], - -- Use '--exact-configuration' if supported. - configExactConfiguration = toFlag True, - configBenchmarks = toFlag False, - configTests = toFlag (TestStanzas `elem` stanzas) - } source pkg pkgoverride - where - pkg = case finalizePD flags (enableStanzas stanzas) - (const True) - platform cinfo [] gpkg of - Left _ -> error "finalizePD ReadyPackage failed" - Right (desc, _) -> desc - -fetchSourcePackage - :: Verbosity - -> RepoContext - -> JobLimit - -> UnresolvedPkgLoc - -> (ResolvedPkgLoc -> IO BuildOutcome) - -> IO BuildOutcome -fetchSourcePackage verbosity repoCtxt fetchLimit src installPkg = do - fetched <- checkFetched src - case fetched of - Just src' -> installPkg src' - Nothing -> onFailure DownloadFailed $ do - loc <- withJobLimit fetchLimit $ - fetchPackage verbosity repoCtxt src - installPkg loc - - -installLocalPackage - :: Verbosity - -> PackageIdentifier -> ResolvedPkgLoc -> FilePath - -> (Maybe FilePath -> IO BuildOutcome) - -> IO BuildOutcome -installLocalPackage verbosity pkgid location distPref installPkg = - - case location of - - LocalUnpackedPackage dir -> - installPkg (Just dir) - - RemoteSourceRepoPackage _repo dir -> - installPkg (Just dir) - - LocalTarballPackage tarballPath -> - installLocalTarballPackage verbosity - pkgid tarballPath distPref installPkg - - RemoteTarballPackage _ tarballPath -> - installLocalTarballPackage verbosity - pkgid tarballPath distPref installPkg - - RepoTarballPackage _ _ tarballPath -> - installLocalTarballPackage verbosity - pkgid tarballPath distPref installPkg - -installLocalTarballPackage - :: Verbosity - -> PackageIdentifier -> FilePath -> FilePath - -> (Maybe FilePath -> IO BuildOutcome) - -> IO BuildOutcome -installLocalTarballPackage verbosity pkgid - tarballPath distPref installPkg = do - tmp <- getTemporaryDirectory - withTempDirectory verbosity tmp "cabal-tmp" $ \tmpDirPath -> - onFailure UnpackFailed $ do - let relUnpackedPath = prettyShow pkgid - absUnpackedPath = tmpDirPath relUnpackedPath - descFilePath = absUnpackedPath - prettyShow (packageName pkgid) <.> "cabal" - info verbosity $ "Extracting " ++ tarballPath - ++ " to " ++ tmpDirPath ++ "..." - extractTarGzFile tmpDirPath relUnpackedPath tarballPath - exists <- doesFileExist descFilePath - unless exists $ - die' verbosity $ "Package .cabal file not found: " ++ show descFilePath - maybeRenameDistDir absUnpackedPath - installPkg (Just absUnpackedPath) - - where - -- 'cabal sdist' puts pre-generated files in the 'dist' - -- directory. This fails when a nonstandard build directory name - -- is used (as is the case with sandboxes), so we need to rename - -- the 'dist' dir here. - -- - -- TODO: 'cabal get happy && cd sandbox && cabal install ../happy' still - -- fails even with this workaround. We probably can live with that. - maybeRenameDistDir :: FilePath -> IO () - maybeRenameDistDir absUnpackedPath = do - let distDirPath = absUnpackedPath defaultDistPref - distDirPathTmp = absUnpackedPath (defaultDistPref ++ "-tmp") - distDirPathNew = absUnpackedPath distPref - distDirExists <- doesDirectoryExist distDirPath - when (distDirExists - && (not $ distDirPath `equalFilePath` distDirPathNew)) $ do - -- NB: we need to handle the case when 'distDirPathNew' is a - -- subdirectory of 'distDirPath' (e.g. the former is - -- 'dist/dist-sandbox-3688fbc2' and the latter is 'dist'). - debug verbosity $ "Renaming '" ++ distDirPath ++ "' to '" - ++ distDirPathTmp ++ "'." - renameDirectory distDirPath distDirPathTmp - when (distDirPath `isPrefixOf` distDirPathNew) $ - createDirectoryIfMissingVerbose verbosity False distDirPath - debug verbosity $ "Renaming '" ++ distDirPathTmp ++ "' to '" - ++ distDirPathNew ++ "'." - renameDirectory distDirPathTmp distDirPathNew - -installUnpackedPackage - :: Verbosity - -> Lock - -> Int - -> SetupScriptOptions - -> ConfigFlags - -> InstallFlags - -> HaddockFlags - -> TestFlags - -> Compiler - -> ProgramDb - -> Platform - -> PackageDescription - -> ReadyPackage - -> PackageDescriptionOverride - -> Maybe FilePath -- ^ Directory to change to before starting the installation. - -> UseLogFile -- ^ File to log output to (if any) - -> IO BuildOutcome -installUnpackedPackage verbosity installLock numJobs - scriptOptions - configFlags installFlags haddockFlags testFlags comp progdb - platform pkg rpkg pkgoverride workingDir useLogFile = do - -- Override the .cabal file if necessary - case pkgoverride of - Nothing -> return () - Just pkgtxt -> do - let descFilePath = fromMaybe "." workingDir - prettyShow (packageName pkgid) <.> "cabal" - info verbosity $ - "Updating " ++ prettyShow (packageName pkgid) <.> "cabal" - ++ " with the latest revision from the index." - writeFileAtomic descFilePath pkgtxt - - -- Make sure that we pass --libsubdir etc to 'setup configure' (necessary if - -- the setup script was compiled against an old version of the Cabal lib). - configFlags' <- addDefaultInstallDirs configFlags - -- Filter out flags not supported by the old versions of the Cabal lib. - let configureFlags :: Version -> ConfigFlags - configureFlags = filterConfigureFlags configFlags' { - configVerbosity = toFlag verbosity' - } - - -- Path to the optional log file. - mLogPath <- maybeLogPath - - logDirChange (maybe (const (return ())) appendFile mLogPath) workingDir $ do - -- Configure phase - onFailure ConfigureFailed $ do - noticeProgress ProgressStarting - setup configureCommand configureFlags mLogPath - - -- Build phase - onFailure BuildFailed $ do - noticeProgress ProgressBuilding - setup buildCommand' buildFlags mLogPath - - -- Doc generation phase - docsResult <- if shouldHaddock - then (do setup haddockCommand haddockFlags' mLogPath - return DocsOk) - `catchIO` (\_ -> return DocsFailed) - `catchExit` (\_ -> return DocsFailed) - else return DocsNotTried - - -- Tests phase - onFailure TestsFailed $ do - when (testsEnabled && PackageDescription.hasTests pkg) $ - setup Cabal.testCommand testFlags' mLogPath - - let testsResult | testsEnabled = TestsOk - | otherwise = TestsNotTried - - -- Install phase - onFailure InstallFailed $ criticalSection installLock $ do - -- Actual installation - withWin32SelfUpgrade verbosity uid configFlags - cinfo platform pkg $ do - setup Cabal.copyCommand copyFlags mLogPath - - -- Capture installed package configuration file, so that - -- it can be incorporated into the final InstallPlan - ipkgs <- genPkgConfs mLogPath - let ipkgs' = case ipkgs of - [ipkg] -> [ipkg { Installed.installedUnitId = uid }] - _ -> ipkgs - let packageDBs = interpretPackageDbFlags - (fromFlag (configUserInstall configFlags)) - (configPackageDBs configFlags) - for_ ipkgs' $ \ipkg' -> - registerPackage verbosity comp progdb - packageDBs ipkg' - defaultRegisterOptions - - return (Right (BuildResult docsResult testsResult (find ((==uid).installedUnitId) ipkgs'))) - - where - pkgid = packageId pkg - uid = installedUnitId rpkg - cinfo = compilerInfo comp - buildCommand' = buildCommand progdb - dispname = prettyShow pkgid - isParallelBuild = numJobs >= 2 - - noticeProgress phase = when isParallelBuild $ - progressMessage verbosity phase dispname - - buildFlags _ = emptyBuildFlags { - buildDistPref = configDistPref configFlags, - buildVerbosity = toFlag verbosity' - } - shouldHaddock = fromFlag (installDocumentation installFlags) - haddockFlags' _ = haddockFlags { - haddockVerbosity = toFlag verbosity', - haddockDistPref = configDistPref configFlags - } - testsEnabled = fromFlag (configTests configFlags) - && fromFlagOrDefault False (installRunTests installFlags) - testFlags' = filterTestFlags testFlags { - Cabal.testDistPref = configDistPref configFlags - } - copyFlags _ = Cabal.emptyCopyFlags { - Cabal.copyDistPref = configDistPref configFlags, - Cabal.copyDest = toFlag InstallDirs.NoCopyDest, - Cabal.copyVerbosity = toFlag verbosity' - } - shouldRegister = PackageDescription.hasLibs pkg - registerFlags _ = Cabal.emptyRegisterFlags { - Cabal.regDistPref = configDistPref configFlags, - Cabal.regVerbosity = toFlag verbosity' - } - verbosity' = maybe verbosity snd useLogFile - tempTemplate name = name ++ "-" ++ prettyShow pkgid - - addDefaultInstallDirs :: ConfigFlags -> IO ConfigFlags - addDefaultInstallDirs configFlags' = do - defInstallDirs <- InstallDirs.defaultInstallDirs flavor userInstall False - return $ configFlags' { - configInstallDirs = fmap Cabal.Flag . - InstallDirs.substituteInstallDirTemplates env $ - InstallDirs.combineInstallDirs fromFlagOrDefault - defInstallDirs (configInstallDirs configFlags) - } - where - CompilerId flavor _ = compilerInfoId cinfo - env = initialPathTemplateEnv pkgid uid cinfo platform - userInstall = fromFlagOrDefault defaultUserInstall - (configUserInstall configFlags') - - genPkgConfs :: Maybe FilePath - -> IO [Installed.InstalledPackageInfo] - genPkgConfs mLogPath = - if shouldRegister then do - tmp <- getTemporaryDirectory - withTempDirectory verbosity tmp (tempTemplate "pkgConf") $ \dir -> do - let pkgConfDest = dir "pkgConf" - registerFlags' version = (registerFlags version) { - Cabal.regGenPkgConf = toFlag (Just pkgConfDest) - } - setup Cabal.registerCommand registerFlags' mLogPath - is_dir <- doesDirectoryExist pkgConfDest - let notHidden = not . isHidden - isHidden name = "." `isPrefixOf` name - if is_dir - -- Sort so that each prefix of the package - -- configurations is well formed - then traverse (readPkgConf pkgConfDest) . sort . filter notHidden - =<< getDirectoryContents pkgConfDest - else fmap (:[]) $ readPkgConf "." pkgConfDest - else return [] - - readPkgConf :: FilePath -> FilePath - -> IO Installed.InstalledPackageInfo - readPkgConf pkgConfDir pkgConfFile = do - pkgConfText <- BS.readFile (pkgConfDir pkgConfFile) - case Installed.parseInstalledPackageInfo pkgConfText of - Left perrors -> pkgConfParseFailed $ unlines $ NE.toList perrors - Right (warns, pkgConf) -> do - unless (null warns) $ - warn verbosity $ unlines warns - return pkgConf - - pkgConfParseFailed :: String -> IO a - pkgConfParseFailed perror = - die' verbosity $ "Couldn't parse the output of 'setup register --gen-pkg-config':" - ++ show perror - - maybeLogPath :: IO (Maybe FilePath) - maybeLogPath = - case useLogFile of - Nothing -> return Nothing - Just (mkLogFileName, _) -> do - let logFileName = mkLogFileName (packageId pkg) uid - logDir = takeDirectory logFileName - unless (null logDir) $ createDirectoryIfMissing True logDir - logFileExists <- doesFileExist logFileName - when logFileExists $ removeFile logFileName - return (Just logFileName) - - setup cmd flags mLogPath = - Exception.bracket - (traverse (\path -> openFile path AppendMode) mLogPath) - (traverse_ hClose) - (\logFileHandle -> - setupWrapper verbosity - scriptOptions { useLoggingHandle = logFileHandle - , useWorkingDir = workingDir } - (Just pkg) - cmd flags (const [])) - - --- helper -onFailure :: (SomeException -> BuildFailure) -> IO BuildOutcome -> IO BuildOutcome -onFailure result action = - action `catches` - [ Handler $ \ioe -> handler (ioe :: IOException) - , Handler $ \exit -> handler (exit :: ExitCode) - ] - where - handler :: Exception e => e -> IO BuildOutcome - handler = return . Left . result . toException - - --- ------------------------------------------------------------ --- * Weird windows hacks --- ------------------------------------------------------------ - -withWin32SelfUpgrade :: Verbosity - -> UnitId - -> ConfigFlags - -> CompilerInfo - -> Platform - -> PackageDescription - -> IO a -> IO a -withWin32SelfUpgrade _ _ _ _ _ _ action | buildOS /= Windows = action -withWin32SelfUpgrade verbosity uid configFlags cinfo platform pkg action = do - - defaultDirs <- InstallDirs.defaultInstallDirs - compFlavor - (fromFlag (configUserInstall configFlags)) - (PackageDescription.hasLibs pkg) - - Win32SelfUpgrade.possibleSelfUpgrade verbosity - (exeInstallPaths defaultDirs) action - - where - pkgid = packageId pkg - (CompilerId compFlavor _) = compilerInfoId cinfo - - exeInstallPaths defaultDirs = - [ InstallDirs.bindir absoluteDirs exeName <.> exeExtension buildPlatform - | exe <- PackageDescription.executables pkg - , PackageDescription.buildable (PackageDescription.buildInfo exe) - , let exeName = prefix ++ prettyShow (PackageDescription.exeName exe) ++ suffix - prefix = substTemplate prefixTemplate - suffix = substTemplate suffixTemplate ] - where - fromFlagTemplate = fromFlagOrDefault (InstallDirs.toPathTemplate "") - prefixTemplate = fromFlagTemplate (configProgPrefix configFlags) - suffixTemplate = fromFlagTemplate (configProgSuffix configFlags) - templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault - defaultDirs (configInstallDirs configFlags) - absoluteDirs = InstallDirs.absoluteInstallDirs - pkgid uid - cinfo InstallDirs.NoCopyDest - platform templateDirs - substTemplate = InstallDirs.fromPathTemplate - . InstallDirs.substPathTemplate env - where env = InstallDirs.initialPathTemplateEnv pkgid uid - cinfo platform diff --git a/cabal/cabal-install/Distribution/Client/InstallPlan.hs b/cabal/cabal-install/Distribution/Client/InstallPlan.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/InstallPlan.hs +++ /dev/null @@ -1,957 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.InstallPlan --- Copyright : (c) Duncan Coutts 2008 --- License : BSD-like --- --- Maintainer : duncan@community.haskell.org --- Stability : provisional --- Portability : portable --- --- Package installation plan --- ------------------------------------------------------------------------------ -module Distribution.Client.InstallPlan ( - InstallPlan, - GenericInstallPlan, - PlanPackage, - GenericPlanPackage(..), - foldPlanPackage, - IsUnit, - - -- * Operations on 'InstallPlan's - new, - toGraph, - toList, - toMap, - keys, - keysSet, - planIndepGoals, - depends, - - fromSolverInstallPlan, - fromSolverInstallPlanWithProgress, - configureInstallPlan, - remove, - installed, - lookup, - directDeps, - revDirectDeps, - - -- * Traversal - executionOrder, - execute, - BuildOutcomes, - lookupBuildOutcome, - -- ** Traversal helpers - -- $traversal - Processing, - ready, - completed, - failed, - - -- * Display - showPlanGraph, - showInstallPlan, - - -- * Graph-like operations - dependencyClosure, - reverseTopologicalOrder, - reverseDependencyClosure, - ) where - -import Distribution.Client.Compat.Prelude hiding (toList, lookup, tail) -import Prelude (tail) -import Distribution.Compat.Stack (WithCallStack) - -import Distribution.Client.Types hiding (BuildOutcomes) -import qualified Distribution.PackageDescription as PD -import qualified Distribution.Simple.Configure as Configure -import qualified Distribution.Simple.Setup as Cabal - -import Distribution.InstalledPackageInfo - ( InstalledPackageInfo ) -import Distribution.Package - ( Package(..), HasMungedPackageId(..) - , HasUnitId(..), UnitId ) -import Distribution.Solver.Types.SolverPackage -import Distribution.Client.JobControl -import Distribution.Pretty (defaultStyle) -import Text.PrettyPrint -import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan -import Distribution.Client.SolverInstallPlan (SolverInstallPlan) - -import qualified Distribution.Solver.Types.ComponentDeps as CD -import Distribution.Solver.Types.Settings -import Distribution.Solver.Types.SolverId -import Distribution.Solver.Types.InstSolverPackage - -import Distribution.Utils.LogProgress -import Distribution.Utils.Structured (Structured (..), Structure(Nominal)) - --- TODO: Need this when we compute final UnitIds --- import qualified Distribution.Simple.Configure as Configure - -import qualified Data.Foldable as Foldable (all, toList) -import qualified Distribution.Compat.Graph as Graph -import Distribution.Compat.Graph (Graph, IsNode(..)) -import Control.Exception - ( assert ) -import qualified Data.Map as Map -import qualified Data.Set as Set - --- When cabal tries to install a number of packages, including all their --- dependencies it has a non-trivial problem to solve. --- --- The Problem: --- --- In general we start with a set of installed packages and a set of source --- packages. --- --- Installed packages have fixed dependencies. They have already been built and --- we know exactly what packages they were built against, including their exact --- versions. --- --- Source package have somewhat flexible dependencies. They are specified as --- version ranges, though really they're predicates. To make matters worse they --- have conditional flexible dependencies. Configuration flags can affect which --- packages are required and can place additional constraints on their --- versions. --- --- These two sets of package can and usually do overlap. There can be installed --- packages that are also available as source packages which means they could --- be re-installed if required, though there will also be packages which are --- not available as source and cannot be re-installed. Very often there will be --- extra versions available than are installed. Sometimes we may like to prefer --- installed packages over source ones or perhaps always prefer the latest --- available version whether installed or not. --- --- The goal is to calculate an installation plan that is closed, acyclic and --- consistent and where every configured package is valid. --- --- An installation plan is a set of packages that are going to be used --- together. It will consist of a mixture of installed packages and source --- packages along with their exact version dependencies. An installation plan --- is closed if for every package in the set, all of its dependencies are --- also in the set. It is consistent if for every package in the set, all --- dependencies which target that package have the same version. - --- Note that plans do not necessarily compose. You might have a valid plan for --- package A and a valid plan for package B. That does not mean the composition --- is simultaneously valid for A and B. In particular you're most likely to --- have problems with inconsistent dependencies. --- On the other hand it is true that every closed sub plan is valid. - --- | Packages in an install plan --- --- NOTE: 'ConfiguredPackage', 'GenericReadyPackage' and 'GenericPlanPackage' --- intentionally have no 'PackageInstalled' instance. `This is important: --- PackageInstalled returns only library dependencies, but for package that --- aren't yet installed we know many more kinds of dependencies (setup --- dependencies, exe, test-suite, benchmark, ..). Any functions that operate on --- dependencies in cabal-install should consider what to do with these --- dependencies; if we give a 'PackageInstalled' instance it would be too easy --- to get this wrong (and, for instance, call graph traversal functions from --- Cabal rather than from cabal-install). Instead, see 'PackageInstalled'. -data GenericPlanPackage ipkg srcpkg - = PreExisting ipkg - | Configured srcpkg - | Installed srcpkg - deriving (Eq, Show, Generic) - -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) - --- | 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 - -type IsUnit a = (IsNode a, Key a ~ UnitId) - -depends :: IsUnit a => a -> [UnitId] -depends = nodeNeighbors - --- 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 - nodeKey (PreExisting ipkg) = nodeKey ipkg - nodeKey (Configured spkg) = nodeKey spkg - nodeKey (Installed spkg) = nodeKey spkg - nodeNeighbors (PreExisting ipkg) = nodeNeighbors ipkg - nodeNeighbors (Configured spkg) = nodeNeighbors spkg - nodeNeighbors (Installed spkg) = nodeNeighbors spkg - -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) where - packageId (PreExisting ipkg) = packageId ipkg - packageId (Configured spkg) = packageId spkg - packageId (Installed spkg) = packageId spkg - -instance (HasMungedPackageId ipkg, HasMungedPackageId srcpkg) => - HasMungedPackageId (GenericPlanPackage ipkg srcpkg) where - mungedId (PreExisting ipkg) = mungedId ipkg - mungedId (Configured spkg) = mungedId spkg - mungedId (Installed spkg) = mungedId spkg - -instance (HasUnitId ipkg, HasUnitId srcpkg) => - HasUnitId - (GenericPlanPackage ipkg srcpkg) where - installedUnitId (PreExisting ipkg) = installedUnitId ipkg - installedUnitId (Configured spkg) = installedUnitId spkg - installedUnitId (Installed spkg) = installedUnitId spkg - -instance (HasConfiguredId ipkg, HasConfiguredId srcpkg) => - HasConfiguredId (GenericPlanPackage ipkg srcpkg) where - configuredId (PreExisting ipkg) = configuredId ipkg - configuredId (Configured spkg) = configuredId spkg - configuredId (Installed spkg) = configuredId spkg - -data GenericInstallPlan ipkg srcpkg = GenericInstallPlan { - planGraph :: !(Graph (GenericPlanPackage ipkg srcpkg)), - planIndepGoals :: !IndependentGoals - } - deriving (Typeable) - --- | '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 $ "internal error in InstallPlan." ++ loc - ++ if null msg then "" else ": " ++ msg - -instance (Structured ipkg, Structured srcpkg) => Structured (GenericInstallPlan ipkg srcpkg) where - structure p = Nominal (typeRep p) 0 "GenericInstallPlan" - [ structure (Proxy :: Proxy ipkg) - , structure (Proxy :: Proxy srcpkg) - ] - -instance (IsNode ipkg, Key ipkg ~ UnitId, IsNode srcpkg, Key srcpkg ~ UnitId, - Binary ipkg, Binary srcpkg) - => Binary (GenericInstallPlan ipkg srcpkg) where - put GenericInstallPlan { - planGraph = graph, - planIndepGoals = indepGoals - } = put graph >> put indepGoals - - get = do - graph <- get - indepGoals <- get - return $! mkInstallPlan "(instance Binary)" graph indepGoals - -showPlanGraph :: (Package ipkg, Package srcpkg, - IsUnit ipkg, IsUnit srcpkg) - => Graph (GenericPlanPackage ipkg srcpkg) -> String -showPlanGraph graph = renderStyle defaultStyle $ - vcat (map dispPlanPackage (Foldable.toList graph)) - where dispPlanPackage p = - hang (hsep [ text (showPlanPackageTag p) - , pretty (packageId p) - , parens (pretty (nodeKey p))]) 2 - (vcat (map pretty (nodeNeighbors p))) - -showInstallPlan :: (Package ipkg, Package srcpkg, - IsUnit ipkg, IsUnit srcpkg) - => GenericInstallPlan ipkg srcpkg -> String -showInstallPlan = showPlanGraph . planGraph - -showPlanPackageTag :: GenericPlanPackage ipkg srcpkg -> String -showPlanPackageTag (PreExisting _) = "PreExisting" -showPlanPackageTag (Configured _) = "Configured" -showPlanPackageTag (Installed _) = "Installed" - --- | Build an installation plan from a valid set of resolved packages. --- -new :: (IsUnit ipkg, IsUnit srcpkg) - => IndependentGoals - -> Graph (GenericPlanPackage ipkg srcpkg) - -> GenericInstallPlan ipkg srcpkg -new indepGoals graph = mkInstallPlan "new" graph indepGoals - -toGraph :: GenericInstallPlan ipkg srcpkg - -> Graph (GenericPlanPackage ipkg srcpkg) -toGraph = planGraph - -toList :: GenericInstallPlan ipkg srcpkg - -> [GenericPlanPackage ipkg srcpkg] -toList = Foldable.toList . planGraph - -toMap :: GenericInstallPlan ipkg srcpkg - -> Map UnitId (GenericPlanPackage ipkg srcpkg) -toMap = Graph.toMap . planGraph - -keys :: GenericInstallPlan ipkg srcpkg -> [UnitId] -keys = Graph.keys . planGraph - -keysSet :: GenericInstallPlan ipkg srcpkg -> Set UnitId -keysSet = Graph.keysSet . planGraph - --- | Remove packages from the install plan. This will result in an --- error if there are remaining packages that depend on any matching --- package. This is primarily useful for obtaining an install plan for --- the dependencies of a package or set of packages without actually --- installing the package itself, as when doing development. --- -remove :: (IsUnit ipkg, IsUnit srcpkg) - => (GenericPlanPackage ipkg srcpkg -> Bool) - -> GenericInstallPlan ipkg srcpkg - -> GenericInstallPlan ipkg srcpkg -remove shouldRemove plan = - mkInstallPlan "remove" newGraph (planIndepGoals plan) - where - newGraph = Graph.fromDistinctList $ - filter (not . shouldRemove) (toList 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'). --- -installed :: (IsUnit ipkg, IsUnit srcpkg) - => (srcpkg -> Bool) - -> GenericInstallPlan ipkg srcpkg - -> GenericInstallPlan ipkg srcpkg -installed shouldBeInstalled installPlan = - foldl' markInstalled installPlan - [ pkg - | Configured pkg <- reverseTopologicalOrder installPlan - , shouldBeInstalled pkg ] - 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) - => GenericInstallPlan ipkg srcpkg - -> UnitId - -> Maybe (GenericPlanPackage ipkg srcpkg) -lookup plan pkgid = Graph.lookup pkgid (planGraph plan) - --- | Find all the direct dependencies of the given package. --- --- Note that the package must exist in the plan or it is an error. --- -directDeps :: GenericInstallPlan ipkg srcpkg - -> UnitId - -> [GenericPlanPackage ipkg srcpkg] -directDeps plan pkgid = - case Graph.neighbors (planGraph plan) pkgid of - Just deps -> deps - Nothing -> internalError "directDeps" "package not in graph" - --- | Find all the direct reverse dependencies of the given package. --- --- Note that the package must exist in the plan or it is an error. --- -revDirectDeps :: GenericInstallPlan ipkg srcpkg - -> UnitId - -> [GenericPlanPackage ipkg srcpkg] -revDirectDeps plan pkgid = - case Graph.revNeighbors (planGraph plan) pkgid of - Just deps -> deps - Nothing -> internalError "revDirectDeps" "package not in graph" - --- | Return all the packages in the 'InstallPlan' in reverse topological order. --- That is, for each package, all dependencies of the package appear first. --- --- Compared to 'executionOrder', this function returns all the installed and --- source packages rather than just the source ones. Also, while both this --- and 'executionOrder' produce reverse topological orderings of the package --- dependency graph, it is not necessarily exactly the same order. --- -reverseTopologicalOrder :: GenericInstallPlan ipkg srcpkg - -> [GenericPlanPackage ipkg srcpkg] -reverseTopologicalOrder plan = Graph.revTopSort (planGraph plan) - - --- | Return the packages in the plan that are direct or indirect dependencies of --- the given packages. --- -dependencyClosure :: GenericInstallPlan ipkg srcpkg - -> [UnitId] - -> [GenericPlanPackage ipkg srcpkg] -dependencyClosure plan = fromMaybe [] - . Graph.closure (planGraph plan) - --- | Return the packages in the plan that depend directly or indirectly on the --- given packages. --- -reverseDependencyClosure :: GenericInstallPlan ipkg srcpkg - -> [UnitId] - -> [GenericPlanPackage ipkg srcpkg] -reverseDependencyClosure plan = fromMaybe [] - . Graph.revClosure (planGraph plan) - - --- Alert alert! Why does SolverId map to a LIST of plan packages? --- The sordid story has to do with 'build-depends' on a package --- with libraries and executables. In an ideal world, we would --- ONLY depend on the library in this situation. But c.f. #3661 --- some people rely on the build-depends to ALSO implicitly --- depend on an executable. --- --- I don't want to commit to a strategy yet, so the only possible --- thing you can do in this case is return EVERYTHING and let --- the client filter out what they want (executables? libraries? --- etc). This similarly implies we can't return a 'ConfiguredId' --- because that's not enough information. - -fromSolverInstallPlan :: - (IsUnit ipkg, IsUnit srcpkg) - => ( (SolverId -> [GenericPlanPackage ipkg srcpkg]) - -> SolverInstallPlan.SolverPlanPackage - -> [GenericPlanPackage ipkg srcpkg] ) - -> 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). - - -fromSolverInstallPlanWithProgress :: - (IsUnit ipkg, IsUnit srcpkg) - => ( (SolverId -> [GenericPlanPackage ipkg srcpkg]) - -> SolverInstallPlan.SolverPlanPackage - -> LogProgress [GenericPlanPackage ipkg srcpkg] ) - -> SolverInstallPlan - -> LogProgress (GenericInstallPlan ipkg srcpkg) -fromSolverInstallPlanWithProgress f plan = do - (_, _, pkgs'') <- foldM f' (Map.empty, Map.empty, []) - (SolverInstallPlan.reverseTopologicalOrder plan) - return $ mkInstallPlan "fromSolverInstallPlanWithProgress" - (Graph.fromDistinctList pkgs'') - (SolverInstallPlan.planIndepGoals plan) - 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). - --- | Conversion of 'SolverInstallPlan' to 'InstallPlan'. --- Similar to 'elaboratedInstallPlan' -configureInstallPlan :: Cabal.ConfigFlags -> SolverInstallPlan -> InstallPlan -configureInstallPlan configFlags solverPlan = - flip fromSolverInstallPlan solverPlan $ \mapDep planpkg -> - [case planpkg of - SolverInstallPlan.PreExisting pkg -> - PreExisting (instSolverPkgIPI pkg) - - SolverInstallPlan.Configured pkg -> - Configured (configureSolverPackage mapDep pkg) - ] - where - configureSolverPackage :: (SolverId -> [PlanPackage]) - -> SolverPackage UnresolvedPkgLoc - -> ConfiguredPackage UnresolvedPkgLoc - configureSolverPackage mapDep spkg = - ConfiguredPackage { - confPkgId = Configure.computeComponentId - (Cabal.fromFlagOrDefault False - (Cabal.configDeterministic configFlags)) - Cabal.NoFlag - Cabal.NoFlag - (packageId spkg) - (PD.CLibName PD.LMainLibName) - (Just (map confInstId (CD.libraryDeps deps), - solverPkgFlags spkg)), - confPkgSource = solverPkgSource spkg, - confPkgFlags = solverPkgFlags spkg, - confPkgStanzas = solverPkgStanzas spkg, - confPkgDeps = deps - -- NB: no support for executable dependencies - } - where - deps = fmap (concatMap (map configuredId . mapDep)) (solverPkgLibDeps spkg) - - --- ------------------------------------------------------------ --- * Primitives for traversing plans --- ------------------------------------------------------------ - --- $traversal --- --- Algorithms to traverse or execute an 'InstallPlan', especially in parallel, --- may make use of the 'Processing' type and the associated operations --- 'ready', 'completed' and 'failed'. --- --- The 'Processing' type is used to keep track of the state of a traversal 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. --- --- Traversal algorithms start with an 'InstallPlan': --- --- * Initially there will be certain packages that can be processed immediately --- (since they are configured source packages and have all their dependencies --- installed already). The function 'ready' returns these packages plus a --- 'Processing' state that marks these same packages as being in the --- processing state. --- --- * The algorithm must now arrange for these packages to be processed --- (possibly in parallel). When a package has completed processing, the --- algorithm needs to know which other packages (if any) are now ready to --- process as a result. The 'completed' function marks a package as completed --- and returns any packages that are newly in the processing state (ie ready --- to process), along with the updated 'Processing' state. --- --- * If failure is possible then when processing a package fails, the algorithm --- needs to know which other packages have also failed as a result. The --- 'failed' function marks the given package as failed as well as all the --- other packages that depend on the failed package. In addition it returns --- the other failed packages. - - --- | The 'Processing' type is used to keep track of the state of a traversal --- 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) - -- processing, completed, failed - --- | The packages in the plan that are initially ready to be installed. --- That is they are in the configured state and have all their dependencies --- installed already. --- --- The result is both the packages that are now ready to be installed and also --- a 'Processing' state containing those same packages. The assumption is that --- 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) - => GenericInstallPlan ipkg srcpkg - -> ([GenericReadyPackage srcpkg], Processing) -ready plan = - assert (processingInvariant plan processing) $ - (readyPackages, processing) - where - !processing = - Processing - (Set.fromList [ nodeKey pkg | pkg <- readyPackages ]) - (Set.fromList [ nodeKey pkg | pkg <- toList plan, isInstalled pkg ]) - Set.empty - readyPackages = - [ ReadyPackage pkg - | Configured pkg <- toList plan - , all isInstalled (directDeps plan (nodeKey pkg)) - ] - -isInstalled :: GenericPlanPackage a b -> Bool -isInstalled (PreExisting {}) = True -isInstalled (Installed {}) = True -isInstalled _ = False - --- | Given a package in the processing state, mark the package as completed --- and return any packages that are newly in the processing state (ie ready to --- process), along with the updated 'Processing' state. --- -completed :: forall ipkg srcpkg. (IsUnit ipkg, IsUnit srcpkg) - => GenericInstallPlan ipkg srcpkg - -> Processing -> UnitId - -> ([GenericReadyPackage srcpkg], Processing) -completed plan (Processing processingSet completedSet failedSet) pkgid = - assert (pkgid `Set.member` processingSet) $ - assert (processingInvariant plan processing') $ - - ( map asReadyPackage newlyReady - , processing' ) - where - completedSet' = Set.insert pkgid completedSet - - -- each direct reverse dep where all direct deps are completed - newlyReady = [ dep - | dep <- revDirectDeps plan pkgid - , all ((`Set.member` completedSet') . nodeKey) - (directDeps plan (nodeKey dep)) - ] - - processingSet' = foldl' (flip Set.insert) - (Set.delete pkgid processingSet) - (map nodeKey newlyReady) - processing' = Processing processingSet' completedSet' failedSet - - asReadyPackage :: GenericPlanPackage ipkg srcpkg -> GenericReadyPackage srcpkg - asReadyPackage (Configured pkg) = ReadyPackage pkg - asReadyPackage pkg = internalError "completed" $ "not in configured state: " ++ displayGenericPlanPackage pkg - -failed :: (IsUnit ipkg, IsUnit srcpkg) - => GenericInstallPlan ipkg srcpkg - -> Processing -> UnitId - -> ([srcpkg], Processing) -failed plan (Processing processingSet completedSet failedSet) pkgid = - assert (pkgid `Set.member` processingSet) $ - assert (all (`Set.notMember` processingSet) (tail newlyFailedIds)) $ - assert (all (`Set.notMember` completedSet) (tail newlyFailedIds)) $ - -- but note that some newlyFailed may already be in the failed set - -- since one package can depend on two packages that both fail and - -- so would be in the rev-dep closure for both. - assert (processingInvariant plan processing') $ - - ( map asConfiguredPackage (tail newlyFailed) - , processing' ) - where - processingSet' = Set.delete pkgid processingSet - failedSet' = failedSet `Set.union` Set.fromList newlyFailedIds - newlyFailedIds = map nodeKey newlyFailed - newlyFailed = fromMaybe (internalError "failed" "package not in graph") - $ Graph.revClosure (planGraph plan) [pkgid] - processing' = Processing processingSet' completedSet failedSet' - - asConfiguredPackage (Configured pkg) = pkg - asConfiguredPackage pkg = internalError "failed" $ "not in configured state: " ++ displayGenericPlanPackage pkg - -processingInvariant :: (IsUnit ipkg, IsUnit srcpkg) - => GenericInstallPlan ipkg srcpkg - -> Processing -> Bool -processingInvariant plan (Processing processingSet completedSet failedSet) = - - -- All the packages in the three sets are actually in the graph - assert (Foldable.all (flip Graph.member (planGraph plan)) processingSet) $ - assert (Foldable.all (flip Graph.member (planGraph plan)) completedSet) $ - assert (Foldable.all (flip Graph.member (planGraph plan)) failedSet) $ - - -- The processing, completed and failed sets are disjoint from each other - assert (noIntersection processingSet completedSet) $ - assert (noIntersection processingSet failedSet) $ - assert (noIntersection failedSet completedSet) $ - - -- Packages that depend on a package that's still processing cannot be - -- completed - assert (noIntersection (reverseClosure processingSet) completedSet) $ - - -- On the other hand, packages that depend on a package that's still - -- processing /can/ have failed (since they may have depended on multiple - -- packages that were processing, but it only takes one to fail to cause - -- knock-on failures) so it is quite possible to have an - -- intersection (reverseClosure processingSet) failedSet - - -- The failed set is upwards closed, i.e. equal to its own rev dep closure - assert (failedSet == reverseClosure failedSet) $ - - -- All immediate reverse deps of packges that are currently processing - -- are not currently being processed (ie not in the processing set). - assert (and [ rdeppkgid `Set.notMember` processingSet - | pkgid <- Set.toList processingSet - , rdeppkgid <- maybe (internalError "processingInvariant" "") - (map nodeKey) - (Graph.revNeighbors (planGraph plan) pkgid) - ]) $ - - -- Packages from the processing or failed sets are only ever in the - -- configured state. - assert (and [ case Graph.lookup pkgid (planGraph plan) of - Just (Configured _) -> True - Just (PreExisting _) -> False - Just (Installed _) -> False - Nothing -> False - | pkgid <- Set.toList processingSet ++ Set.toList failedSet ]) - - -- We use asserts rather than returning False so that on failure we get - -- better details on which bit of the invariant was violated. - True - where - reverseClosure = Set.fromList - . map nodeKey - . fromMaybe (internalError "processingInvariant" "") - . Graph.revClosure (planGraph plan) - . Set.toList - noIntersection a b = Set.null (Set.intersection a b) - - --- ------------------------------------------------------------ --- * Traversing plans --- ------------------------------------------------------------ - --- | Flatten an 'InstallPlan', producing the sequence of source packages in --- the order in which they would be processed when the plan is executed. This --- can be used for simultations or presenting execution dry-runs. --- --- It is guaranteed to give the same order as using 'execute' (with a serial --- in-order 'JobControl'), which is a reverse topological orderings of the --- source packages in the dependency graph, albeit not necessarily exactly the --- same ordering as that produced by 'reverseTopologicalOrder'. --- -executionOrder :: (IsUnit ipkg, IsUnit srcpkg) - => GenericInstallPlan ipkg srcpkg - -> [GenericReadyPackage srcpkg] -executionOrder plan = - let (newpkgs, processing) = ready plan - in tryNewTasks processing newpkgs - where - tryNewTasks _processing [] = [] - tryNewTasks processing (p:todo) = waitForTasks processing p todo - - waitForTasks processing p todo = - p : tryNewTasks processing' (todo++nextpkgs) - where - (nextpkgs, processing') = completed plan processing (nodeKey p) - - --- ------------------------------------------------------------ --- * Executing plans --- ------------------------------------------------------------ - --- | The set of results we get from executing an install plan. --- -type BuildOutcomes failure result = Map UnitId (Either failure result) - --- | Lookup the build result for a single package. --- -lookupBuildOutcome :: HasUnitId pkg - => pkg -> BuildOutcomes failure result - -> Maybe (Either failure result) -lookupBuildOutcome = Map.lookup . installedUnitId - --- | Execute an install plan. This traverses the plan in dependency order. --- --- Executing each individual package can fail and if so all dependents fail --- too. The result for each package is collected as a 'BuildOutcomes' map. --- --- Visiting each package happens with optional parallelism, as determined by --- the 'JobControl'. By default, after any failure we stop as soon as possible --- (using the 'JobControl' to try to cancel in-progress tasks). This behaviour --- can be reversed to keep going and build as many packages as possible. --- --- Note that the 'BuildOutcomes' is /not/ guaranteed to cover all the packages --- in the plan. In particular in the default mode where we stop as soon as --- possible after a failure then there may be packages which are skipped and --- these will have no 'BuildOutcome'. --- -execute :: forall m ipkg srcpkg result failure. - (IsUnit ipkg, IsUnit srcpkg, - Monad m) - => JobControl m (UnitId, 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) -execute jobCtl keepGoing depFailure plan installPkg = - let (newpkgs, processing) = ready plan - in tryNewTasks Map.empty False False processing newpkgs - where - tryNewTasks :: BuildOutcomes failure result - -> Bool -> Bool -> Processing - -> [GenericReadyPackage srcpkg] - -> m (BuildOutcomes failure result) - - tryNewTasks !results tasksFailed tasksRemaining !processing newpkgs - -- we were in the process of cancelling and now we're finished - | tasksFailed && not keepGoing && not tasksRemaining - = return results - - -- we are still in the process of cancelling, wait for remaining tasks - | tasksFailed && not keepGoing && tasksRemaining - = waitForTasks results tasksFailed processing - - -- no new tasks to do and all tasks are done so we're finished - | null newpkgs && not tasksRemaining - = return results - - -- no new tasks to do, remaining tasks to wait for - | null newpkgs - = waitForTasks results tasksFailed processing - - -- new tasks to do, spawn them, then wait for tasks to complete - | otherwise - = do sequence_ [ spawnJob jobCtl $ do - result <- installPkg pkg - return (nodeKey pkg, result) - | pkg <- newpkgs ] - waitForTasks results tasksFailed processing - - waitForTasks :: BuildOutcomes failure result - -> Bool -> Processing - -> m (BuildOutcomes failure result) - waitForTasks !results tasksFailed !processing = do - (pkgid, result) <- collectJob jobCtl - - case result of - - Right _success -> do - tasksRemaining <- remainingJobs jobCtl - tryNewTasks results' tasksFailed tasksRemaining - processing' nextpkgs - where - results' = Map.insert pkgid result results - (nextpkgs, processing') = completed plan processing pkgid - - Left _failure -> do - -- if this is the first failure and we're not trying to keep going - -- then try to cancel as many of the remaining jobs as possible - when (not tasksFailed && not keepGoing) $ - cancelJobs jobCtl - - tasksRemaining <- remainingJobs jobCtl - tryNewTasks results' True tasksRemaining processing' [] - where - (depsfailed, processing') = failed plan processing pkgid - results' = Map.insert pkgid result results `Map.union` depResults - depResults = Map.fromList - [ (nodeKey deppkg, Left (depFailure deppkg)) - | deppkg <- depsfailed ] - --- ------------------------------------------------------------ --- * Checking validity of plans --- ------------------------------------------------------------ - --- | 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] - | PackageStateInvalid (GenericPlanPackage ipkg srcpkg) - (GenericPlanPackage ipkg srcpkg) - -showPlanProblem :: (IsUnit ipkg, IsUnit 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" - --- | 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) - => Graph (GenericPlanPackage ipkg srcpkg) - -> [PlanProblem ipkg srcpkg] -problems graph = - - [ PackageMissingDeps pkg - (mapMaybe - (fmap nodeKey . flip Graph.lookup graph) - 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 (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 --- package @b@ we require that @stateDependencyRelation a b = True@. --- -stateDependencyRelation :: GenericPlanPackage ipkg srcpkg - -> GenericPlanPackage ipkg srcpkg -> Bool -stateDependencyRelation PreExisting{} PreExisting{} = True - -stateDependencyRelation Installed{} PreExisting{} = True -stateDependencyRelation Installed{} Installed{} = True - -stateDependencyRelation Configured{} PreExisting{} = True -stateDependencyRelation Configured{} Installed{} = True -stateDependencyRelation Configured{} Configured{} = True - -stateDependencyRelation _ _ = False diff --git a/cabal/cabal-install/Distribution/Client/InstallSymlink.hs b/cabal/cabal-install/Distribution/Client/InstallSymlink.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/InstallSymlink.hs +++ /dev/null @@ -1,274 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveGeneric #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.InstallSymlink --- Copyright : (c) Duncan Coutts 2008 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- Managing installing binaries with symlinks. ------------------------------------------------------------------------------ -module Distribution.Client.InstallSymlink ( - symlinkBinaries, - symlinkBinary, - trySymlink, - ) where - -import Distribution.Client.Compat.Prelude hiding (ioError) -import Prelude () - -import Distribution.Client.Types - ( ConfiguredPackage(..), BuildOutcomes ) -import Distribution.Client.Setup - ( InstallFlags(installSymlinkBinDir) ) -import qualified Distribution.Client.InstallPlan as InstallPlan -import Distribution.Client.InstallPlan (InstallPlan) - -import Distribution.Solver.Types.SourcePackage -import Distribution.Solver.Types.OptionalStanza - -import Distribution.Package - ( PackageIdentifier, Package(packageId), UnitId, installedUnitId ) -import Distribution.Types.UnqualComponentName -import Distribution.Compiler - ( CompilerId(..) ) -import qualified Distribution.PackageDescription as PackageDescription -import Distribution.PackageDescription - ( PackageDescription ) -import Distribution.PackageDescription.Configuration - ( finalizePD ) -import Distribution.Simple.Setup - ( ConfigFlags(..), fromFlag, fromFlagOrDefault, flagToMaybe ) -import qualified Distribution.Simple.InstallDirs as InstallDirs -import Distribution.Simple.Compiler - ( Compiler, compilerInfo, CompilerInfo(..) ) -import Distribution.System - ( Platform ) -import Distribution.Simple.Utils ( info, withTempDirectory ) - -import System.Directory - ( canonicalizePath, getTemporaryDirectory, removeFile ) -import System.FilePath - ( (), splitPath, joinPath, isAbsolute ) - -import System.IO.Error - ( isDoesNotExistError, ioError ) -import Control.Exception - ( assert ) - -import Distribution.Client.Compat.Directory ( createFileLink, getSymbolicLinkTarget, pathIsSymbolicLink ) -import Distribution.Client.Types.OverwritePolicy - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BS8 - --- | We would like by default to install binaries into some location that is on --- the user's PATH. For per-user installations on Unix systems that basically --- means the @~/bin/@ directory. On the majority of platforms the @~/bin/@ --- directory will be on the user's PATH. However some people are a bit nervous --- about letting a package manager install programs into @~/bin/@. --- --- A compromise solution is that instead of installing binaries directly into --- @~/bin/@, we could install them in a private location under @~/.cabal/bin@ --- and then create symlinks in @~/bin/@. We can be careful when setting up the --- symlinks that we do not overwrite any binary that the user installed. We can --- check if it was a symlink we made because it would point to the private dir --- where we install our binaries. This means we can install normally without --- worrying and in a later phase set up symlinks, and if that fails then we --- report it to the user, but even in this case the package is still in an OK --- installed state. --- --- This is an optional feature that users can choose to use or not. It is --- controlled from the config file. Of course it only works on POSIX systems --- with symlinks so is not available to Windows users. --- -symlinkBinaries :: Platform -> Compiler - -> OverwritePolicy - -> ConfigFlags - -> InstallFlags - -> InstallPlan - -> BuildOutcomes - -> IO [(PackageIdentifier, UnqualComponentName, FilePath)] -symlinkBinaries platform comp overwritePolicy - configFlags installFlags - plan buildOutcomes = - case flagToMaybe (installSymlinkBinDir installFlags) of - Nothing -> return [] - Just symlinkBinDir - | null exes -> return [] - | otherwise -> do - publicBinDir <- canonicalizePath symlinkBinDir --- TODO: do we want to do this here? : --- createDirectoryIfMissing True publicBinDir - fmap catMaybes $ sequenceA - [ do privateBinDir <- pkgBinDir pkg ipid - ok <- symlinkBinary - overwritePolicy - publicBinDir privateBinDir - (prettyShow publicExeName) privateExeName - if ok - then return Nothing - else return (Just (pkgid, publicExeName, - privateBinDir privateExeName)) - | (rpkg, pkg, exe) <- exes - , let pkgid = packageId pkg - -- This is a bit dodgy; probably won't work for Backpack packages - ipid = installedUnitId rpkg - publicExeName = PackageDescription.exeName exe - privateExeName = prefix ++ unUnqualComponentName publicExeName ++ suffix - prefix = substTemplate pkgid ipid prefixTemplate - suffix = substTemplate pkgid ipid suffixTemplate ] - where - exes = - [ (cpkg, pkg, exe) - | InstallPlan.Configured cpkg <- InstallPlan.toList plan - , case InstallPlan.lookupBuildOutcome cpkg buildOutcomes of - Just (Right _success) -> True - _ -> False - , let pkg :: PackageDescription - pkg = pkgDescription cpkg - , exe <- PackageDescription.executables pkg - , PackageDescription.buildable (PackageDescription.buildInfo exe) ] - - pkgDescription (ConfiguredPackage _ (SourcePackage _ gpd _ _) - flags stanzas _) = - case finalizePD flags (enableStanzas stanzas) - (const True) - platform cinfo [] gpd of - Left _ -> error "finalizePD ReadyPackage failed" - Right (desc, _) -> desc - - -- This is sadly rather complicated. We're kind of re-doing part of the - -- configuration for the package. :-( - pkgBinDir :: PackageDescription -> UnitId -> IO FilePath - pkgBinDir pkg ipid = do - defaultDirs <- InstallDirs.defaultInstallDirs - compilerFlavor - (fromFlag (configUserInstall configFlags)) - (PackageDescription.hasLibs pkg) - let templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault - defaultDirs (configInstallDirs configFlags) - absoluteDirs = InstallDirs.absoluteInstallDirs - (packageId pkg) ipid - cinfo InstallDirs.NoCopyDest - platform templateDirs - canonicalizePath (InstallDirs.bindir absoluteDirs) - - substTemplate pkgid ipid = InstallDirs.fromPathTemplate - . InstallDirs.substPathTemplate env - where env = InstallDirs.initialPathTemplateEnv pkgid ipid - cinfo platform - - fromFlagTemplate = fromFlagOrDefault (InstallDirs.toPathTemplate "") - prefixTemplate = fromFlagTemplate (configProgPrefix configFlags) - suffixTemplate = fromFlagTemplate (configProgSuffix configFlags) - cinfo = compilerInfo comp - (CompilerId compilerFlavor _) = compilerInfoId cinfo - --- | Symlink binary. --- --- The paths are take in pieces, so we can make relative link when possible. --- -symlinkBinary :: - OverwritePolicy -- ^ Whether to force overwrite an existing file - -> FilePath -- ^ The canonical path of the public bin dir eg - -- @/home/user/bin@ - -> FilePath -- ^ The canonical path of the private bin dir eg - -- @/home/user/.cabal/bin@ - -> FilePath -- ^ The name of the executable to go in the public bin - -- dir, eg @foo@ - -> String -- ^ The name of the executable to in the private bin - -- dir, eg @foo-1.0@ - -> IO Bool -- ^ If creating the symlink was successful. @False@ if - -- there was another file there already that we did - -- not own. Other errors like permission errors just - -- propagate as exceptions. -symlinkBinary overwritePolicy publicBindir privateBindir publicName privateName = do - ok <- targetOkToOverwrite (publicBindir publicName) - (privateBindir privateName) - case ok of - NotExists -> mkLink >> return True - OkToOverwrite -> rmLink >> mkLink >> return True - NotOurFile -> - case overwritePolicy of - NeverOverwrite -> return False - AlwaysOverwrite -> rmLink >> mkLink >> return True - where - relativeBindir = makeRelative publicBindir privateBindir - mkLink = createFileLink (relativeBindir privateName) (publicBindir publicName) - rmLink = removeFile (publicBindir publicName) - --- | Check a file path of a symlink that we would like to create to see if it --- is OK. For it to be OK to overwrite it must either not already exist yet or --- be a symlink to our target (in which case we can assume ownership). --- -targetOkToOverwrite :: FilePath -- ^ The file path of the symlink to the private - -- binary that we would like to create - -> FilePath -- ^ The canonical path of the private binary. - -- Use 'canonicalizePath' to make this. - -> IO SymlinkStatus -targetOkToOverwrite symlink target = handleNotExist $ do - isLink <- pathIsSymbolicLink symlink - if not isLink - then return NotOurFile - else do target' <- canonicalizePath =<< getSymbolicLinkTarget symlink - -- This partially relies on canonicalizePath handling symlinks - if target == target' - then return OkToOverwrite - else return NotOurFile - - where - handleNotExist action = catchIO action $ \ioexception -> - -- If the target doesn't exist then there's no problem overwriting it! - if isDoesNotExistError ioexception - then return NotExists - else ioError ioexception - -data SymlinkStatus - = NotExists -- ^ The file doesn't exist so we can make a symlink. - | OkToOverwrite -- ^ A symlink already exists, though it is ours. We'll - -- have to delete it first before we make a new symlink. - | NotOurFile -- ^ A file already exists and it is not one of our existing - -- symlinks (either because it is not a symlink or because - -- it points somewhere other than our managed space). - deriving Show - --- | Take two canonical paths and produce a relative path to get from the first --- to the second, even if it means adding @..@ path components. --- -makeRelative :: FilePath -> FilePath -> FilePath -makeRelative a b = assert (isAbsolute a && isAbsolute b) $ - let as = splitPath a - bs = splitPath b - commonLen = length $ takeWhile id $ zipWith (==) as bs - in joinPath $ [ ".." | _ <- drop commonLen as ] - ++ drop commonLen bs - --- | Try to make a symlink in a temporary directory. --- --- If this works, we can try to symlink: even on Windows. --- -trySymlink :: Verbosity -> IO Bool -trySymlink verbosity = do - tmp <- getTemporaryDirectory - withTempDirectory verbosity tmp "cabal-symlink-test" $ \tmpDirPath -> do - let from = tmpDirPath "file.txt" - let to = tmpDirPath "file2.txt" - - -- create a file - BS.writeFile from (BS8.pack "TEST") - - -- create a symbolic link - let create :: IO Bool - create = do - createFileLink from to - info verbosity $ "Symlinking seems to work" - return True - - create `catchIO` \exc -> do - info verbosity $ "Symlinking doesn't seem to be working: " ++ show exc - return False diff --git a/cabal/cabal-install/Distribution/Client/JobControl.hs b/cabal/cabal-install/Distribution/Client/JobControl.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/JobControl.hs +++ /dev/null @@ -1,177 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.JobControl --- Copyright : (c) Duncan Coutts 2012 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- A job control concurrency abstraction ------------------------------------------------------------------------------ -module Distribution.Client.JobControl ( - JobControl, - newSerialJobControl, - newParallelJobControl, - spawnJob, - collectJob, - remainingJobs, - cancelJobs, - - JobLimit, - newJobLimit, - withJobLimit, - - Lock, - newLock, - criticalSection - ) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Control.Monad (forever, replicateM_) -import Control.Concurrent (forkIO) -import Control.Concurrent.MVar -import Control.Concurrent.STM (STM, atomically) -import Control.Concurrent.STM.TVar -import Control.Concurrent.STM.TChan -import Control.Exception (bracket_, try) -import Distribution.Client.Compat.Semaphore - - --- | A simple concurrency abstraction. Jobs can be spawned and can complete --- in any order. This allows both serial and parallel implementations. --- -data JobControl m a = JobControl { - -- | Add a new job to the pool of jobs - spawnJob :: m a -> m (), - - -- | Wait until one job is complete - collectJob :: m a, - - -- | Returns True if there are any outstanding jobs - -- (ie spawned but yet to be collected) - remainingJobs :: m Bool, - - -- | Try to cancel any outstanding but not-yet-started jobs. - -- Call 'remainingJobs' after this to find out if any jobs are left - -- (ie could not be cancelled). - cancelJobs :: m () - } - - --- | Make a 'JobControl' that executes all jobs serially and in order. --- It only executes jobs on demand when they are collected, not eagerly. --- --- Cancelling will cancel /all/ jobs that have not been collected yet. --- -newSerialJobControl :: IO (JobControl IO a) -newSerialJobControl = do - qVar <- newTChanIO - return JobControl { - spawnJob = spawn qVar, - collectJob = collect qVar, - remainingJobs = remaining qVar, - cancelJobs = cancel qVar - } - where - spawn :: TChan (IO a) -> IO a -> IO () - spawn qVar job = atomically $ writeTChan qVar job - - collect :: TChan (IO a) -> IO a - collect qVar = - join $ atomically $ readTChan qVar - - remaining :: TChan (IO a) -> IO Bool - remaining qVar = fmap not $ atomically $ isEmptyTChan qVar - - cancel :: TChan (IO a) -> IO () - cancel qVar = do - _ <- atomically $ readAllTChan qVar - return () - --- | Make a 'JobControl' that eagerly executes jobs in parallel, with a given --- maximum degree of parallelism. --- --- Cancelling will cancel jobs that have not yet begun executing, but jobs --- that have already been executed or are currently executing cannot be --- cancelled. --- -newParallelJobControl :: Int -> IO (JobControl IO a) -newParallelJobControl n | n < 1 || n > 1000 = - error $ "newParallelJobControl: not a sensible number of jobs: " ++ show n -newParallelJobControl maxJobLimit = do - inqVar <- newTChanIO - outqVar <- newTChanIO - countVar <- newTVarIO 0 - replicateM_ maxJobLimit $ - forkIO $ - worker inqVar outqVar - return JobControl { - spawnJob = spawn inqVar countVar, - collectJob = collect outqVar countVar, - remainingJobs = remaining countVar, - cancelJobs = cancel inqVar countVar - } - where - worker :: TChan (IO a) -> TChan (Either SomeException a) -> IO () - worker inqVar outqVar = - forever $ do - job <- atomically $ readTChan inqVar - res <- try job - atomically $ writeTChan outqVar res - - spawn :: TChan (IO a) -> TVar Int -> IO a -> IO () - spawn inqVar countVar job = - atomically $ do - modifyTVar' countVar (+1) - writeTChan inqVar job - - collect :: TChan (Either SomeException a) -> TVar Int -> IO a - collect outqVar countVar = do - res <- atomically $ do - modifyTVar' countVar (subtract 1) - readTChan outqVar - either throwIO return res - - remaining :: TVar Int -> IO Bool - remaining countVar = fmap (/=0) $ atomically $ readTVar countVar - - cancel :: TChan (IO a) -> TVar Int -> IO () - cancel inqVar countVar = - atomically $ do - xs <- readAllTChan inqVar - modifyTVar' countVar (subtract (length xs)) - -readAllTChan :: TChan a -> STM [a] -readAllTChan qvar = go [] - where - go xs = do - mx <- tryReadTChan qvar - case mx of - Nothing -> return (reverse xs) - Just x -> go (x:xs) - -------------------------- --- Job limits and locks --- - -data JobLimit = JobLimit QSem - -newJobLimit :: Int -> IO JobLimit -newJobLimit n = - fmap JobLimit (newQSem n) - -withJobLimit :: JobLimit -> IO a -> IO a -withJobLimit (JobLimit sem) = - bracket_ (waitQSem sem) (signalQSem sem) - -newtype Lock = Lock (MVar ()) - -newLock :: IO Lock -newLock = fmap Lock $ newMVar () - -criticalSection :: Lock -> IO a -> IO a -criticalSection (Lock lck) act = bracket_ (takeMVar lck) (putMVar lck ()) act diff --git a/cabal/cabal-install/Distribution/Client/List.hs b/cabal/cabal-install/Distribution/Client/List.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/List.hs +++ /dev/null @@ -1,629 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.List --- Copyright : (c) David Himmelstrup 2005 --- Duncan Coutts 2008-2011 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- --- Search for and print information about packages ------------------------------------------------------------------------------ -module Distribution.Client.List ( - list, info - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude - -import Distribution.Package - ( PackageName, Package(..), packageName - , packageVersion, UnitId ) -import Distribution.Types.Dependency -import Distribution.Types.UnqualComponentName -import Distribution.ModuleName (ModuleName) -import Distribution.License (License) -import qualified Distribution.InstalledPackageInfo as Installed -import qualified Distribution.PackageDescription as Source -import qualified Distribution.Types.ModuleReexport as Source -import Distribution.PackageDescription - ( PackageFlag(..), unFlagName ) -import Distribution.PackageDescription.Configuration - ( flattenPackageDescription ) - -import Distribution.Simple.Compiler - ( Compiler, PackageDBStack ) -import Distribution.Simple.Program (ProgramDb) -import Distribution.Simple.Utils - ( equating, die', notice ) -import Distribution.Simple.Setup (fromFlag, fromFlagOrDefault) -import Distribution.Simple.PackageIndex (InstalledPackageIndex) -import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex -import Distribution.Version - ( Version, mkVersion, versionNumbers, VersionRange, withinRange, anyVersion - , intersectVersionRanges, simplifyVersionRange ) - -import qualified Distribution.SPDX as SPDX - -import Distribution.Solver.Types.PackageConstraint -import qualified Distribution.Solver.Types.PackageIndex as PackageIndex -import Distribution.Solver.Types.SourcePackage - -import Distribution.Client.Types - ( SourcePackageDb(..), PackageSpecifier(..), UnresolvedSourcePackage ) -import Distribution.Client.Targets - ( UserTarget, resolveUserTargets ) -import Distribution.Client.Setup - ( GlobalFlags(..), ListFlags(..), InfoFlags(..) - , RepoContext(..) ) -import Distribution.Client.Utils - ( mergeBy, MergeResult(..) ) -import Distribution.Client.IndexUtils as IndexUtils - ( getSourcePackages, getInstalledPackages ) -import Distribution.Client.FetchUtils - ( isFetched ) - -import Data.Bits ((.|.)) -import Data.List - ( maximumBy ) -import Data.List.NonEmpty (groupBy, nonEmpty) -import qualified Data.List as L -import Data.Maybe - ( fromJust ) -import qualified Data.Map as Map -import Data.Tree as Tree -import Control.Exception - ( assert ) -import qualified Text.PrettyPrint as Disp -import Text.PrettyPrint - ( lineLength, ribbonsPerLine, Doc, renderStyle, char - , nest, ($+$), text, vcat, style, parens, fsep) -import System.Directory - ( doesDirectoryExist ) - -import Distribution.Utils.ShortText (ShortText) -import qualified Distribution.Utils.ShortText as ShortText -import qualified Text.Regex.Base as Regex -import qualified Text.Regex.Posix.String as Regex - - --- | Return a list of packages matching given search strings. -getPkgList :: Verbosity - -> PackageDBStack - -> RepoContext - -> Maybe (Compiler, ProgramDb) - -> ListFlags - -> [String] - -> IO [PackageDisplayInfo] -getPkgList verbosity packageDBs repoCtxt mcompprogdb listFlags pats = do - installedPkgIndex <- for mcompprogdb $ \(comp, progdb) -> - getInstalledPackages verbosity comp packageDBs progdb - sourcePkgDb <- getSourcePackages verbosity repoCtxt - - regexps <- for pats $ \pat -> do - e <- Regex.compile compOption Regex.execBlank pat - case e of - Right r -> return r - Left err -> die' verbosity $ "Failed to compile regex " ++ pat ++ ": " ++ snd err - - let sourcePkgIndex = packageIndex sourcePkgDb - prefs name = fromMaybe anyVersion - (Map.lookup name (packagePreferences sourcePkgDb)) - - pkgsInfoMatching :: - [(PackageName, [Installed.InstalledPackageInfo], [UnresolvedSourcePackage])] - pkgsInfoMatching = - let matchingInstalled = maybe [] (matchingPackages InstalledPackageIndex.searchWithPredicate regexps) installedPkgIndex - matchingSource = matchingPackages (\ idx n -> concatMap snd (PackageIndex.searchWithPredicate idx n)) regexps sourcePkgIndex - in mergePackages matchingInstalled matchingSource - - pkgsInfo :: - [(PackageName, [Installed.InstalledPackageInfo], [UnresolvedSourcePackage])] - pkgsInfo - -- gather info for all packages - | null regexps = mergePackages - (maybe [] InstalledPackageIndex.allPackages installedPkgIndex) - ( PackageIndex.allPackages sourcePkgIndex) - - -- gather info for packages matching search term - | otherwise = pkgsInfoMatching - - matches :: [PackageDisplayInfo] - matches = [ mergePackageInfo pref - installedPkgs sourcePkgs selectedPkg False - | (pkgname, installedPkgs, sourcePkgs) <- pkgsInfo - , not onlyInstalled || not (null installedPkgs) - , let pref = prefs pkgname - selectedPkg = latestWithPref pref sourcePkgs ] - return matches - where - onlyInstalled = fromFlagOrDefault False (listInstalled listFlags) - caseInsensitive = fromFlagOrDefault True (listCaseInsensitive listFlags) - - compOption | caseInsensitive = Regex.compExtended .|. Regex.compIgnoreCase - | otherwise = Regex.compExtended - - matchingPackages search regexps index = - [ pkg - | re <- regexps - , pkg <- search index (Regex.matchTest re) ] - - --- | Show information about packages. -list :: Verbosity - -> PackageDBStack - -> RepoContext - -> Maybe (Compiler, ProgramDb) - -> ListFlags - -> [String] - -> IO () -list verbosity packageDBs repos mcompProgdb listFlags pats = do - matches <- getPkgList verbosity packageDBs repos mcompProgdb listFlags pats - - if simpleOutput - then putStr $ unlines - [ prettyShow (pkgName pkg) ++ " " ++ prettyShow version - | pkg <- matches - , version <- if onlyInstalled - then installedVersions pkg - else nub . sort $ installedVersions pkg - ++ sourceVersions pkg ] - -- Note: this only works because for 'list', one cannot currently - -- specify any version constraints, so listing all installed - -- and source ones works. - else - if null matches - then notice verbosity "No matches found." - else putStr $ unlines (map showPackageSummaryInfo matches) - where - onlyInstalled = fromFlag (listInstalled listFlags) - simpleOutput = fromFlag (listSimpleOutput listFlags) - -info :: Verbosity - -> PackageDBStack - -> RepoContext - -> Compiler - -> ProgramDb - -> GlobalFlags - -> InfoFlags - -> [UserTarget] - -> IO () -info verbosity _ _ _ _ _ _ [] = - notice verbosity "No packages requested. Nothing to do." - -info verbosity packageDBs repoCtxt comp progdb - globalFlags _listFlags userTargets = do - - installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb - sourcePkgDb <- getSourcePackages verbosity repoCtxt - let sourcePkgIndex = packageIndex sourcePkgDb - prefs name = fromMaybe anyVersion - (Map.lookup name (packagePreferences sourcePkgDb)) - - -- Users may specify names of packages that are only installed, not - -- just available source packages, so we must resolve targets using - -- the combination of installed and source packages. - let sourcePkgs' = PackageIndex.fromList - $ map packageId - (InstalledPackageIndex.allPackages installedPkgIndex) - ++ map packageId - (PackageIndex.allPackages sourcePkgIndex) - pkgSpecifiers <- resolveUserTargets verbosity repoCtxt - (fromFlag $ globalWorldFile globalFlags) - sourcePkgs' userTargets - - pkgsinfo <- sequenceA - [ do pkginfo <- either (die' verbosity) return $ - gatherPkgInfo prefs - installedPkgIndex sourcePkgIndex - pkgSpecifier - updateFileSystemPackageDetails pkginfo - | pkgSpecifier <- pkgSpecifiers ] - - putStr $ unlines (map showPackageDetailedInfo pkgsinfo) - - where - gatherPkgInfo :: (PackageName -> VersionRange) -> - InstalledPackageIndex -> - PackageIndex.PackageIndex UnresolvedSourcePackage -> - PackageSpecifier UnresolvedSourcePackage -> - Either String PackageDisplayInfo - gatherPkgInfo prefs installedPkgIndex sourcePkgIndex - (NamedPackage name props) - | null (selectedInstalledPkgs) && null (selectedSourcePkgs) - = Left $ "There is no available version of " ++ prettyShow name - ++ " that satisfies " - ++ prettyShow (simplifyVersionRange verConstraint) - - | otherwise - = Right $ mergePackageInfo pref installedPkgs - sourcePkgs selectedSourcePkg' - showPkgVersion - where - (pref, installedPkgs, sourcePkgs) = - sourcePkgsInfo prefs name installedPkgIndex sourcePkgIndex - - selectedInstalledPkgs = InstalledPackageIndex.lookupDependency - installedPkgIndex - name verConstraint - selectedSourcePkgs = PackageIndex.lookupDependency sourcePkgIndex - name verConstraint - selectedSourcePkg' = latestWithPref pref selectedSourcePkgs - - -- display a specific package version if the user - -- supplied a non-trivial version constraint - showPkgVersion = not (null verConstraints) - verConstraint = foldr intersectVersionRanges anyVersion verConstraints - verConstraints = [ vr | PackagePropertyVersion vr <- props ] - - gatherPkgInfo prefs installedPkgIndex sourcePkgIndex - (SpecificSourcePackage pkg) = - Right $ mergePackageInfo pref installedPkgs sourcePkgs - selectedPkg True - where - name = packageName pkg - selectedPkg = Just pkg - (pref, installedPkgs, sourcePkgs) = - sourcePkgsInfo prefs name installedPkgIndex sourcePkgIndex - -sourcePkgsInfo :: - (PackageName -> VersionRange) - -> PackageName - -> InstalledPackageIndex - -> PackageIndex.PackageIndex UnresolvedSourcePackage - -> (VersionRange, [Installed.InstalledPackageInfo], [UnresolvedSourcePackage]) -sourcePkgsInfo prefs name installedPkgIndex sourcePkgIndex = - (pref, installedPkgs, sourcePkgs) - where - pref = prefs name - installedPkgs = concatMap snd (InstalledPackageIndex.lookupPackageName - installedPkgIndex name) - sourcePkgs = PackageIndex.lookupPackageName sourcePkgIndex name - - --- | The info that we can display for each package. It is information per --- package name and covers all installed and available versions. --- -data PackageDisplayInfo = PackageDisplayInfo { - pkgName :: PackageName, - selectedVersion :: Maybe Version, - selectedSourcePkg :: Maybe UnresolvedSourcePackage, - installedVersions :: [Version], - sourceVersions :: [Version], - preferredVersions :: VersionRange, - homepage :: ShortText, - bugReports :: ShortText, - sourceRepo :: String, -- TODO - synopsis :: ShortText, - description :: ShortText, - category :: ShortText, - license :: Either SPDX.License License, - author :: ShortText, - maintainer :: ShortText, - dependencies :: [ExtDependency], - flags :: [PackageFlag], - hasLib :: Bool, - hasExe :: Bool, - executables :: [UnqualComponentName], - modules :: [ModuleName], - haddockHtml :: FilePath, - haveTarball :: Bool - } - --- | Covers source dependencies and installed dependencies in --- one type. -data ExtDependency = SourceDependency Dependency - | InstalledDependency UnitId - -showPackageSummaryInfo :: PackageDisplayInfo -> String -showPackageSummaryInfo pkginfo = - renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $ - char '*' <+> pretty (pkgName pkginfo) - $+$ - (nest 4 $ vcat [ - maybeShowST (synopsis pkginfo) "Synopsis:" reflowParagraphs - , text "Default available version:" <+> - case selectedSourcePkg pkginfo of - Nothing -> text "[ Not available from any configured repository ]" - Just pkg -> pretty (packageVersion pkg) - , text "Installed versions:" <+> - case installedVersions pkginfo of - [] | hasLib pkginfo -> text "[ Not installed ]" - | otherwise -> text "[ Unknown ]" - versions -> dispTopVersions 4 - (preferredVersions pkginfo) versions - , maybeShowST (homepage pkginfo) "Homepage:" text - , text "License: " <+> either pretty pretty (license pkginfo) - ]) - $+$ text "" - where - maybeShowST l s f - | ShortText.null l = Disp.empty - | otherwise = text s <+> f (ShortText.fromShortText l) - -showPackageDetailedInfo :: PackageDisplayInfo -> String -showPackageDetailedInfo pkginfo = - renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $ - char '*' <+> pretty (pkgName pkginfo) - <<>> maybe Disp.empty (\v -> char '-' Disp.<> pretty v) (selectedVersion pkginfo) - <+> text (replicate (16 - length (prettyShow (pkgName pkginfo))) ' ') - <<>> parens pkgkind - $+$ - (nest 4 $ vcat [ - entryST "Synopsis" synopsis hideIfNull reflowParagraphs - , entry "Versions available" sourceVersions - (altText null "[ Not available from server ]") - (dispTopVersions 9 (preferredVersions pkginfo)) - , entry "Versions installed" installedVersions - (altText null (if hasLib pkginfo then "[ Not installed ]" - else "[ Unknown ]")) - (dispTopVersions 4 (preferredVersions pkginfo)) - , entryST "Homepage" homepage orNotSpecified text - , entryST "Bug reports" bugReports orNotSpecified text - , entryST "Description" description hideIfNull reflowParagraphs - , entryST "Category" category hideIfNull text - , entry "License" license alwaysShow (either pretty pretty) - , entryST "Author" author hideIfNull reflowLines - , entryST "Maintainer" maintainer hideIfNull reflowLines - , entry "Source repo" sourceRepo orNotSpecified text - , entry "Executables" executables hideIfNull (commaSep pretty) - , entry "Flags" flags hideIfNull (commaSep dispFlag) - , entry "Dependencies" dependencies hideIfNull (commaSep dispExtDep) - , entry "Documentation" haddockHtml showIfInstalled text - , entry "Cached" haveTarball alwaysShow dispYesNo - , if not (hasLib pkginfo) then mempty else - text "Modules:" $+$ nest 4 (vcat (map pretty . sort . modules $ pkginfo)) - ]) - $+$ text "" - where - entry fname field cond format = case cond (field pkginfo) of - Nothing -> label <+> format (field pkginfo) - Just Nothing -> mempty - Just (Just other) -> label <+> text other - where - label = text fname Disp.<> char ':' Disp.<> padding - padding = text (replicate (13 - length fname ) ' ') - - entryST fname field = entry fname (ShortText.fromShortText . field) - - normal = Nothing - hide = Just Nothing - replace msg = Just (Just msg) - - alwaysShow = const normal - hideIfNull v = if null v then hide else normal - showIfInstalled v - | not isInstalled = hide - | null v = replace "[ Not installed ]" - | otherwise = normal - altText nul msg v = if nul v then replace msg else normal - orNotSpecified = altText null "[ Not specified ]" - - commaSep f = Disp.fsep . Disp.punctuate (Disp.char ',') . map f - dispFlag = text . unFlagName . flagName - dispYesNo True = text "Yes" - dispYesNo False = text "No" - - dispExtDep (SourceDependency dep) = pretty dep - dispExtDep (InstalledDependency dep) = pretty dep - - isInstalled = not (null (installedVersions pkginfo)) - hasExes = length (executables pkginfo) >= 2 - --TODO: exclude non-buildable exes - pkgkind | hasLib pkginfo && hasExes = text "programs and library" - | hasLib pkginfo && hasExe pkginfo = text "program and library" - | hasLib pkginfo = text "library" - | hasExes = text "programs" - | hasExe pkginfo = text "program" - | otherwise = mempty - - -reflowParagraphs :: String -> Doc -reflowParagraphs = - vcat - . intersperse (text "") -- re-insert blank lines - . map (fsep . map text . concatMap words) -- reflow paragraphs - . filter (/= [""]) - . L.groupBy (\x y -> "" `notElem` [x,y]) -- break on blank lines - . lines - -reflowLines :: String -> Doc -reflowLines = vcat . map text . lines - --- | We get the 'PackageDisplayInfo' by combining the info for the installed --- and available versions of a package. --- --- * We're building info about a various versions of a single named package so --- the input package info records are all supposed to refer to the same --- package name. --- -mergePackageInfo :: VersionRange - -> [Installed.InstalledPackageInfo] - -> [UnresolvedSourcePackage] - -> Maybe UnresolvedSourcePackage - -> Bool - -> PackageDisplayInfo -mergePackageInfo versionPref installedPkgs sourcePkgs selectedPkg showVer = - assert (length installedPkgs + length sourcePkgs > 0) $ - PackageDisplayInfo { - pkgName = combine packageName source - packageName installed, - selectedVersion = if showVer then fmap packageVersion selectedPkg - else Nothing, - selectedSourcePkg = sourceSelected, - installedVersions = map packageVersion installedPkgs, - sourceVersions = map packageVersion sourcePkgs, - preferredVersions = versionPref, - - license = combine Source.licenseRaw source - Installed.license installed, - maintainer = combine Source.maintainer source - Installed.maintainer installed, - author = combine Source.author source - Installed.author installed, - homepage = combine Source.homepage source - Installed.homepage installed, - bugReports = maybe mempty Source.bugReports source, - sourceRepo = fromMaybe mempty . join - . fmap (uncons Nothing Source.repoLocation - . sortBy (comparing Source.repoKind) - . Source.sourceRepos) - $ source, - --TODO: installed package info is missing synopsis - synopsis = maybe mempty Source.synopsis source, - description = combine Source.description source - Installed.description installed, - category = combine Source.category source - Installed.category installed, - flags = maybe [] Source.genPackageFlags sourceGeneric, - hasLib = isJust installed - || maybe False (isJust . Source.condLibrary) sourceGeneric, - hasExe = maybe False (not . null . Source.condExecutables) sourceGeneric, - executables = map fst (maybe [] Source.condExecutables sourceGeneric), - modules = combine (map Installed.exposedName . Installed.exposedModules) - installed - -- NB: only for the PUBLIC library - (concatMap getListOfExposedModules . maybeToList . Source.library) - source, - dependencies = - combine (map (SourceDependency . simplifyDependency) - . Source.allBuildDepends) source - (map InstalledDependency . Installed.depends) installed, - haddockHtml = fromMaybe "" . join - . fmap (listToMaybe . Installed.haddockHTMLs) - $ installed, - haveTarball = False - } - where - combine f x g y = fromJust (fmap f x `mplus` fmap g y) - installed :: Maybe Installed.InstalledPackageInfo - installed = latestWithPref versionPref installedPkgs - - getListOfExposedModules lib = Source.exposedModules lib - ++ map Source.moduleReexportName - (Source.reexportedModules lib) - - sourceSelected - | isJust selectedPkg = selectedPkg - | otherwise = latestWithPref versionPref sourcePkgs - sourceGeneric = fmap srcpkgDescription sourceSelected - source = fmap flattenPackageDescription sourceGeneric - - uncons :: b -> (a -> b) -> [a] -> b - uncons z _ [] = z - uncons _ f (x:_) = f x - - --- | Not all the info is pure. We have to check if the docs really are --- installed, because the registered package info lies. Similarly we have to --- check if the tarball has indeed been fetched. --- -updateFileSystemPackageDetails :: PackageDisplayInfo -> IO PackageDisplayInfo -updateFileSystemPackageDetails pkginfo = do - fetched <- maybe (return False) (isFetched . srcpkgSource) - (selectedSourcePkg pkginfo) - docsExist <- doesDirectoryExist (haddockHtml pkginfo) - return pkginfo { - haveTarball = fetched, - haddockHtml = if docsExist then haddockHtml pkginfo else "" - } - -latestWithPref :: Package pkg => VersionRange -> [pkg] -> Maybe pkg -latestWithPref _ [] = Nothing -latestWithPref pref pkgs = Just (maximumBy (comparing prefThenVersion) pkgs) - where - prefThenVersion pkg = let ver = packageVersion pkg - in (withinRange ver pref, ver) - - --- | Rearrange installed and source packages into groups referring to the --- same package by name. In the result pairs, the lists are guaranteed to not --- both be empty. --- -mergePackages :: [Installed.InstalledPackageInfo] - -> [UnresolvedSourcePackage] - -> [( PackageName - , [Installed.InstalledPackageInfo] - , [UnresolvedSourcePackage] )] -mergePackages installedPkgs sourcePkgs = - map collect - $ mergeBy (\i a -> fst i `compare` fst a) - (groupOn packageName installedPkgs) - (groupOn packageName sourcePkgs) - where - collect (OnlyInLeft (name,is) ) = (name, is, []) - collect ( InBoth (_,is) (name,as)) = (name, is, as) - collect (OnlyInRight (name,as)) = (name, [], as) - -groupOn :: Ord key => (a -> key) -> [a] -> [(key,[a])] -groupOn key = map (\xs -> (key (head xs), toList xs)) - . groupBy (equating key) - . sortBy (comparing key) - -dispTopVersions :: Int -> VersionRange -> [Version] -> Doc -dispTopVersions n pref vs = - (Disp.fsep . Disp.punctuate (Disp.char ',') - . map (\ver -> if ispref ver then pretty ver else parens (pretty ver)) - . sort . take n . interestingVersions ispref - $ vs) - <+> trailingMessage - - where - ispref ver = withinRange ver pref - extra = length vs - n - trailingMessage - | extra <= 0 = Disp.empty - | otherwise = Disp.parens $ Disp.text "and" - <+> Disp.int (length vs - n) - <+> if extra == 1 then Disp.text "other" - else Disp.text "others" - --- | Reorder a bunch of versions to put the most interesting / significant --- versions first. A preferred version range is taken into account. --- --- This may be used in a user interface to select a small number of versions --- to present to the user, e.g. --- --- > let selectVersions = sort . take 5 . interestingVersions pref --- -interestingVersions :: (Version -> Bool) -> [Version] -> [Version] -interestingVersions pref = - map (mkVersion . fst) . filter snd - . concat . Tree.levels - . swizzleTree - . reorderTree (\(Node (v,_) _) -> pref (mkVersion v)) - . reverseTree - . mkTree - . map (or0 . versionNumbers) - - where - or0 [] = 0 :| [] - or0 (x:xs) = x :| xs - - swizzleTree = unfoldTree (spine []) - where - spine ts' (Node x []) = (x, ts') - spine ts' (Node x (t:ts)) = spine (Node x ts:ts') t - - reorderTree _ (Node x []) = Node x [] - reorderTree p (Node x ts) = Node x (ts' ++ ts'') - where - (ts',ts'') = partition p (map (reorderTree p) ts) - - reverseTree (Node x cs) = Node x (reverse (map reverseTree cs)) - - mkTree :: forall a. Eq a => [NonEmpty a] -> Tree ([a], Bool) - mkTree xs = unfoldTree step (False, [], xs) - where - step :: (Bool, [a], [NonEmpty a]) -> (([a], Bool), [(Bool, [a], [NonEmpty a])]) - step (node,ns,vs) = - ( (reverse ns, node) - , [ (any null vs', n:ns, mapMaybe nonEmpty (toList vs')) - | (n, vs') <- groups vs - ] - ) - - groups :: [NonEmpty a] -> [(a, NonEmpty [a])] - groups = map (\g -> (head (head g), fmap tail g)) - . groupBy (equating head) diff --git a/cabal/cabal-install/Distribution/Client/Manpage.hs b/cabal/cabal-install/Distribution/Client/Manpage.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Manpage.hs +++ /dev/null @@ -1,212 +0,0 @@ -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Manpage --- Copyright : (c) Maciek Makowski 2015 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- Functions for building the manual page. - -module Distribution.Client.Manpage - ( -- * Manual page generation - manpage - , manpageCmd - , ManpageFlags - , defaultManpageFlags - , manpageOptions - ) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Client.ManpageFlags -import Distribution.Client.Setup (globalCommand) -import Distribution.Compat.Process (createProcess) -import Distribution.Simple.Command -import Distribution.Simple.Flag (fromFlagOrDefault) -import System.IO (hClose, hPutStr) - -import qualified System.Process as Process - -data FileInfo = FileInfo String String -- ^ path, description - -------------------------------------------------------------------------------- --- -------------------------------------------------------------------------------- - --- | A list of files that should be documented in the manual page. -files :: [FileInfo] -files = - [ (FileInfo "~/.cabal/config" "The defaults that can be overridden with command-line options.") - , (FileInfo "~/.cabal/world" "A list of all packages whose installation has been explicitly requested.") - ] - -manpageCmd :: String -> [CommandSpec a] -> ManpageFlags -> IO () -manpageCmd pname commands flags - | fromFlagOrDefault False (manpageRaw flags) - = putStrLn contents - | otherwise - = do - let cmd = "man" - args = ["-l", "-"] - - (mb_in, _, _, ph) <- createProcess (Process.proc cmd args) - { Process.std_in = Process.CreatePipe - , Process.std_out = Process.Inherit - , Process.std_err = Process.Inherit - } - - -- put contents - for_ mb_in $ \hin -> do - hPutStr hin contents - hClose hin - - -- wait for process to exit, propagate exit code - ec <- Process.waitForProcess ph - exitWith ec - where - contents :: String - contents = manpage pname commands - --- | Produces a manual page with @troff@ markup. -manpage :: String -> [CommandSpec a] -> String -manpage pname commands = unlines $ - [ ".TH " ++ map toUpper pname ++ " 1" - , ".SH NAME" - , pname ++ " \\- a system for building and packaging Haskell libraries and programs" - , ".SH SYNOPSIS" - , ".B " ++ pname - , ".I command" - , ".RI < arguments |[ options ]>..." - , "" - , "Where the" - , ".I commands" - , "are" - , "" - ] ++ - concatMap (commandSynopsisLines pname) commands ++ - [ ".SH DESCRIPTION" - , "Cabal is the standard package system for Haskell software. It helps people to configure, " - , "build and install Haskell software and to distribute it easily to other users and developers." - , "" - , "The command line " ++ pname ++ " tool (also referred to as cabal-install) helps with " - , "installing existing packages and developing new packages. " - , "It can be used to work with local packages or to install packages from online package archives, " - , "including automatically installing dependencies. By default it is configured to use Hackage, " - , "which is Haskell's central package archive that contains thousands of libraries and applications " - , "in the Cabal package format." - , ".SH OPTIONS" - , "Global options:" - , "" - ] ++ - optionsLines (globalCommand []) ++ - [ ".SH COMMANDS" - ] ++ - concatMap (commandDetailsLines pname) commands ++ - [ ".SH FILES" - ] ++ - concatMap fileLines files ++ - [ ".SH BUGS" - , "To browse the list of known issues or report a new one please see " - , "https://github.com/haskell/cabal/labels/cabal-install." - ] - -commandSynopsisLines :: String -> CommandSpec action -> [String] -commandSynopsisLines pname (CommandSpec ui _ NormalCommand) = - [ ".B " ++ pname ++ " " ++ (commandName ui) - , ".R - " ++ commandSynopsis ui - , ".br" - ] -commandSynopsisLines _ (CommandSpec _ _ HiddenCommand) = [] - -commandDetailsLines :: String -> CommandSpec action -> [String] -commandDetailsLines pname (CommandSpec ui _ NormalCommand) = - [ ".B " ++ pname ++ " " ++ (commandName ui) - , "" - , commandUsage ui pname - , "" - ] ++ - optional commandDescription ++ - optional commandNotes ++ - [ "Flags:" - , ".RS" - ] ++ - optionsLines ui ++ - [ ".RE" - , "" - ] - where - optional field = - case field ui of - Just text -> [text pname, ""] - Nothing -> [] -commandDetailsLines _ (CommandSpec _ _ HiddenCommand) = [] - -optionsLines :: CommandUI flags -> [String] -optionsLines command = concatMap optionLines (concatMap optionDescr (commandOptions command ParseArgs)) - -data ArgumentRequired = Optional | Required -type OptionArg = (ArgumentRequired, ArgPlaceHolder) - -optionLines :: OptDescr flags -> [String] -optionLines (ReqArg description (optionChars, optionStrings) placeHolder _ _) = - argOptionLines description optionChars optionStrings (Required, placeHolder) -optionLines (OptArg description (optionChars, optionStrings) placeHolder _ _ _) = - argOptionLines description optionChars optionStrings (Optional, placeHolder) -optionLines (BoolOpt description (trueChars, trueStrings) (falseChars, falseStrings) _ _) = - optionLinesIfPresent trueChars trueStrings ++ - optionLinesIfPresent falseChars falseStrings ++ - optionDescriptionLines description -optionLines (ChoiceOpt options) = - concatMap choiceLines options - where - choiceLines (description, (optionChars, optionStrings), _, _) = - [ optionsLine optionChars optionStrings ] ++ - optionDescriptionLines description - -argOptionLines :: String -> [Char] -> [String] -> OptionArg -> [String] -argOptionLines description optionChars optionStrings arg = - [ optionsLine optionChars optionStrings - , optionArgLine arg - ] ++ - optionDescriptionLines description - -optionLinesIfPresent :: [Char] -> [String] -> [String] -optionLinesIfPresent optionChars optionStrings = - if null optionChars && null optionStrings then [] - else [ optionsLine optionChars optionStrings, ".br" ] - -optionDescriptionLines :: String -> [String] -optionDescriptionLines description = - [ ".RS" - , description - , ".RE" - , "" - ] - -optionsLine :: [Char] -> [String] -> String -optionsLine optionChars optionStrings = - intercalate ", " (shortOptions optionChars ++ longOptions optionStrings) - -shortOptions :: [Char] -> [String] -shortOptions = map (\c -> "\\-" ++ [c]) - -longOptions :: [String] -> [String] -longOptions = map (\s -> "\\-\\-" ++ s) - -optionArgLine :: OptionArg -> String -optionArgLine (Required, placeHolder) = ".I " ++ placeHolder -optionArgLine (Optional, placeHolder) = ".RI [ " ++ placeHolder ++ " ]" - -fileLines :: FileInfo -> [String] -fileLines (FileInfo path description) = - [ path - , ".RS" - , description - , ".RE" - , "" - ] diff --git a/cabal/cabal-install/Distribution/Client/ManpageFlags.hs b/cabal/cabal-install/Distribution/Client/ManpageFlags.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/ManpageFlags.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} -module Distribution.Client.ManpageFlags -( ManpageFlags (..) -, defaultManpageFlags -, manpageOptions, -) where - -import Distribution.Client.Compat.Prelude - -import Distribution.Simple.Command (OptionField (..), ShowOrParseArgs (..), option) -import Distribution.Simple.Setup (Flag (..), toFlag, trueArg, optionVerbosity) -import Distribution.Verbosity (normal) - -data ManpageFlags = ManpageFlags - { manpageVerbosity :: Flag Verbosity - , manpageRaw :: Flag Bool - } deriving (Eq, Show, Generic) - -instance Monoid ManpageFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup ManpageFlags where - (<>) = gmappend - -defaultManpageFlags :: ManpageFlags -defaultManpageFlags = ManpageFlags - { manpageVerbosity = toFlag normal - , manpageRaw = toFlag False - } - -manpageOptions :: ShowOrParseArgs -> [OptionField ManpageFlags] -manpageOptions _ = - [ optionVerbosity manpageVerbosity (\v flags -> flags { manpageVerbosity = v }) - , option "" ["raw"] - "Output raw troff content" - manpageRaw (\v flags -> flags { manpageRaw = v }) - trueArg - ] diff --git a/cabal/cabal-install/Distribution/Client/Nix.hs b/cabal/cabal-install/Distribution/Client/Nix.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Nix.hs +++ /dev/null @@ -1,182 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ViewPatterns #-} - -module Distribution.Client.Nix - ( findNixExpr - , inNixShell - , nixInstantiate - , nixShell - ) where - -import Distribution.Client.Compat.Prelude - -import Control.Exception (bracket) -import System.Directory - ( canonicalizePath, createDirectoryIfMissing, doesDirectoryExist - , doesFileExist, removeDirectoryRecursive, removeFile ) -import System.Environment (getArgs, getExecutablePath) -import System.FilePath - ( (), replaceExtension, takeDirectory, takeFileName ) -import System.IO (IOMode(..), hClose, openFile) -import System.IO.Error (isDoesNotExistError) -import System.Process (showCommandForUser) - -import Distribution.Compat.Environment - ( lookupEnv, setEnv, unsetEnv ) - -import Distribution.Simple.Program - ( Program(..), ProgramDb - , addKnownProgram, configureProgram, emptyProgramDb, getDbProgramOutput - , runDbProgram, simpleProgram ) -import Distribution.Simple.Setup (fromFlagOrDefault) -import Distribution.Simple.Utils (debug, existsAndIsMoreRecentThan) - -import Distribution.Client.Config (SavedConfig(..)) -import Distribution.Client.GlobalFlags (GlobalFlags(..)) - - -configureOneProgram :: Verbosity -> Program -> IO ProgramDb -configureOneProgram verb prog = - configureProgram verb prog (addKnownProgram prog emptyProgramDb) - - -touchFile :: FilePath -> IO () -touchFile path = do - catch (removeFile path) (\e -> when (isDoesNotExistError e) (return ())) - createDirectoryIfMissing True (takeDirectory path) - openFile path WriteMode >>= hClose - - -findNixExpr :: GlobalFlags -> SavedConfig -> IO (Maybe FilePath) -findNixExpr globalFlags config = do - -- criteria for deciding to run nix-shell - let nixEnabled = - fromFlagOrDefault False - (globalNix (savedGlobalFlags config) <> globalNix globalFlags) - - if nixEnabled - then do - let exprPaths = [ "shell.nix", "default.nix" ] - filterM doesFileExist exprPaths >>= \case - [] -> return Nothing - (path : _) -> return (Just path) - else return Nothing - - --- set IN_NIX_SHELL so that builtins.getEnv in Nix works as in nix-shell -inFakeNixShell :: IO a -> IO a -inFakeNixShell f = - bracket (fakeEnv "IN_NIX_SHELL" "1") (resetEnv "IN_NIX_SHELL") (\_ -> f) - where - fakeEnv var new = do - old <- lookupEnv var - setEnv var new - return old - resetEnv var = maybe (unsetEnv var) (setEnv var) - - -nixInstantiate - :: Verbosity - -> FilePath - -> Bool - -> GlobalFlags - -> SavedConfig - -> IO () -nixInstantiate verb dist force' globalFlags config = - findNixExpr globalFlags config >>= \case - Nothing -> return () - Just shellNix -> do - alreadyInShell <- inNixShell - shellDrv <- drvPath dist shellNix - instantiated <- doesFileExist shellDrv - -- an extra timestamp file is necessary because the derivation lives in - -- the store so its mtime is always 1. - let timestamp = timestampPath dist shellNix - upToDate <- existsAndIsMoreRecentThan timestamp shellNix - - let ready = alreadyInShell || (instantiated && upToDate && not force') - unless ready $ do - - let prog = simpleProgram "nix-instantiate" - progdb <- configureOneProgram verb prog - - removeGCRoots verb dist - touchFile timestamp - - _ <- inFakeNixShell - (getDbProgramOutput verb prog progdb - [ "--add-root", shellDrv, "--indirect", shellNix ]) - return () - - -nixShell - :: Verbosity - -> FilePath - -> GlobalFlags - -> SavedConfig - -> IO () - -- ^ The action to perform inside a nix-shell. This is also the action - -- that will be performed immediately if Nix is disabled. - -> IO () -nixShell verb dist globalFlags config go = do - - alreadyInShell <- inNixShell - - if alreadyInShell - then go - else do - findNixExpr globalFlags config >>= \case - Nothing -> go - Just shellNix -> do - - let prog = simpleProgram "nix-shell" - progdb <- configureOneProgram verb prog - - cabal <- getExecutablePath - - -- alreadyInShell == True in child process - setEnv "CABAL_IN_NIX_SHELL" "1" - - -- Run cabal with the same arguments inside nix-shell. - -- When the child process reaches the top of nixShell, it will - -- detect that it is running inside the shell and fall back - -- automatically. - shellDrv <- drvPath dist shellNix - args <- getArgs - runDbProgram verb prog progdb - [ "--add-root", gcrootPath dist "result", "--indirect", shellDrv - , "--run", showCommandForUser cabal args - ] - - -drvPath :: FilePath -> FilePath -> IO FilePath -drvPath dist path = do - -- We do not actually care about canonicity, but makeAbsolute is only - -- available in newer versions of directory. - -- We expect the path to be a symlink if it exists, so we do not canonicalize - -- the entire path because that would dereference the symlink. - distNix <- canonicalizePath (dist "nix") - -- Nix garbage collector roots must be absolute paths - return (distNix replaceExtension (takeFileName path) "drv") - - -timestampPath :: FilePath -> FilePath -> FilePath -timestampPath dist path = - dist "nix" replaceExtension (takeFileName path) "drv.timestamp" - - -gcrootPath :: FilePath -> FilePath -gcrootPath dist = dist "nix" "gcroots" - - -inNixShell :: IO Bool -inNixShell = isJust <$> lookupEnv "CABAL_IN_NIX_SHELL" - - -removeGCRoots :: Verbosity -> FilePath -> IO () -removeGCRoots verb dist = do - let tgt = gcrootPath dist - exists <- doesDirectoryExist tgt - when exists $ do - debug verb ("removing Nix gcroots from " ++ tgt) - removeDirectoryRecursive tgt diff --git a/cabal/cabal-install/Distribution/Client/NixStyleOptions.hs b/cabal/cabal-install/Distribution/Client/NixStyleOptions.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/NixStyleOptions.hs +++ /dev/null @@ -1,85 +0,0 @@ --- | Command line options for nix-style / v2 commands. --- --- The commands take a lot of the same options, which affect how install plan --- is constructed. -module Distribution.Client.NixStyleOptions ( - NixStyleFlags (..), - nixStyleOptions, - defaultNixStyleFlags, -) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Simple.Command (OptionField (..), ShowOrParseArgs) -import Distribution.Simple.Setup (BenchmarkFlags, HaddockFlags, TestFlags) -import Distribution.Solver.Types.ConstraintSource (ConstraintSource (..)) - -import Distribution.Client.ProjectFlags - (ProjectFlags (..), defaultProjectFlags, projectFlagsOptions) -import Distribution.Client.Setup - (ConfigExFlags, ConfigFlags (..), InstallFlags (..), benchmarkOptions, configureExOptions, - configureOptions, haddockOptions, installOptions, liftOptions, testOptions) - -data NixStyleFlags a = NixStyleFlags - { configFlags :: ConfigFlags - , configExFlags :: ConfigExFlags - , installFlags :: InstallFlags - , haddockFlags :: HaddockFlags - , testFlags :: TestFlags - , benchmarkFlags :: BenchmarkFlags - , projectFlags :: ProjectFlags - , extraFlags :: a - } - -nixStyleOptions - :: (ShowOrParseArgs -> [OptionField a]) - -> ShowOrParseArgs -> [OptionField (NixStyleFlags a)] -nixStyleOptions commandOptions showOrParseArgs = - liftOptions configFlags set1 - -- Note: [Hidden Flags] - -- hide "constraint", "dependency", and - -- "exact-configuration" from the configure options. - (filter ((`notElem` ["constraint", "dependency" - , "exact-configuration"]) - . optionName) $ configureOptions showOrParseArgs) - ++ liftOptions configExFlags set2 (configureExOptions showOrParseArgs - ConstraintSourceCommandlineFlag) - ++ liftOptions installFlags set3 - -- hide "target-package-db" and "symlink-bindir" flags from the - -- install options. - -- "symlink-bindir" is obsoleted by "installdir" in ClientInstallFlags - (filter ((`notElem` ["target-package-db", "symlink-bindir"]) - . optionName) $ - installOptions showOrParseArgs) - ++ liftOptions haddockFlags set4 - -- hide "verbose" and "builddir" flags from the - -- haddock options. - (filter ((`notElem` ["v", "verbose", "builddir"]) - . optionName) $ - haddockOptions showOrParseArgs) - ++ liftOptions testFlags set5 (testOptions showOrParseArgs) - ++ liftOptions benchmarkFlags set6 (benchmarkOptions showOrParseArgs) - ++ liftOptions projectFlags set7 (projectFlagsOptions showOrParseArgs) - ++ liftOptions extraFlags set8 (commandOptions showOrParseArgs) - where - set1 x flags = flags { configFlags = x } - set2 x flags = flags { configExFlags = x } - set3 x flags = flags { installFlags = x } - set4 x flags = flags { haddockFlags = x } - set5 x flags = flags { testFlags = x } - set6 x flags = flags { benchmarkFlags = x } - set7 x flags = flags { projectFlags = x } - set8 x flags = flags { extraFlags = x } - -defaultNixStyleFlags :: a -> NixStyleFlags a -defaultNixStyleFlags x = NixStyleFlags - { configFlags = mempty - , configExFlags = mempty - , installFlags = mempty - , haddockFlags = mempty - , testFlags = mempty - , benchmarkFlags = mempty - , projectFlags = defaultProjectFlags - , extraFlags = x - } diff --git a/cabal/cabal-install/Distribution/Client/Outdated.hs b/cabal/cabal-install/Distribution/Client/Outdated.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Outdated.hs +++ /dev/null @@ -1,213 +0,0 @@ -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Outdated --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Implementation of the 'outdated' command. Checks for outdated --- dependencies in the package description file or freeze file. ------------------------------------------------------------------------------ - -module Distribution.Client.Outdated ( outdated - , ListOutdatedSettings(..), listOutdated ) -where - -import Prelude () -import Distribution.Client.Config -import Distribution.Client.IndexUtils as IndexUtils -import Distribution.Client.Compat.Prelude -import Distribution.Client.ProjectConfig -import Distribution.Client.DistDirLayout -import Distribution.Client.RebuildMonad -import Distribution.Client.Setup hiding (quiet) -import Distribution.Client.Targets -import Distribution.Client.Types -import Distribution.Solver.Types.PackageConstraint -import Distribution.Solver.Types.PackageIndex -import Distribution.Client.Sandbox.PackageEnvironment -import Distribution.Utils.Generic - -import Distribution.Package (PackageName, packageVersion) -import Distribution.PackageDescription (allBuildDepends) -import Distribution.PackageDescription.Configuration (finalizePD) -import Distribution.Simple.Compiler (Compiler, compilerInfo) -import Distribution.Simple.Setup - (fromFlagOrDefault, flagToMaybe) -import Distribution.Simple.Utils - (die', notice, debug, tryFindPackageDesc) -import Distribution.System (Platform) -import Distribution.Types.ComponentRequestedSpec - (ComponentRequestedSpec(..)) -import Distribution.Types.Dependency - (Dependency(..)) -import Distribution.Verbosity (silent) -import Distribution.Version - (Version, VersionRange, LowerBound(..), UpperBound(..) - ,asVersionIntervals, majorBoundVersion) -import Distribution.PackageDescription.Parsec - (readGenericPackageDescription) -import Distribution.Types.PackageVersionConstraint - (PackageVersionConstraint (..), simplifyPackageVersionConstraint) - -import qualified Data.Set as S -import System.Directory (getCurrentDirectory) - --- | Entry point for the 'outdated' command. -outdated :: Verbosity -> OutdatedFlags -> RepoContext - -> Compiler -> Platform - -> IO () -outdated verbosity0 outdatedFlags repoContext comp platform = do - let freezeFile = fromFlagOrDefault False (outdatedFreezeFile outdatedFlags) - newFreezeFile = fromFlagOrDefault False - (outdatedNewFreezeFile outdatedFlags) - mprojectFile = flagToMaybe - (outdatedProjectFile outdatedFlags) - simpleOutput = fromFlagOrDefault False - (outdatedSimpleOutput outdatedFlags) - quiet = fromFlagOrDefault False (outdatedQuiet outdatedFlags) - exitCode = fromFlagOrDefault quiet (outdatedExitCode outdatedFlags) - ignorePred = let ignoreSet = S.fromList (outdatedIgnore outdatedFlags) - in \pkgname -> pkgname `S.member` ignoreSet - minorPred = case outdatedMinor outdatedFlags 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 - verbosity = if quiet then silent else verbosity0 - - when (not newFreezeFile && isJust mprojectFile) $ - die' verbosity $ - "--project-file must only be used with --v2-freeze-file." - - sourcePkgDb <- IndexUtils.getSourcePackages verbosity repoContext - let pkgIndex = packageIndex sourcePkgDb - deps <- if freezeFile - then depsFromFreezeFile verbosity - else if newFreezeFile - then depsFromNewFreezeFile verbosity mprojectFile - else depsFromPkgDesc verbosity comp platform - debug verbosity $ "Dependencies loaded: " - ++ (intercalate ", " $ map prettyShow deps) - let outdatedDeps = listOutdated deps pkgIndex - (ListOutdatedSettings ignorePred minorPred) - when (not quiet) $ - showResult verbosity outdatedDeps simpleOutput - if (exitCode && (not . null $ outdatedDeps)) - then exitFailure - else return () - --- | Print either the list of all outdated dependencies, or a message --- that there are none. -showResult :: Verbosity -> [(PackageVersionConstraint,Version)] -> Bool -> IO () -showResult verbosity outdatedDeps simpleOutput = - if (not . null $ outdatedDeps) - then - do when (not simpleOutput) $ - notice verbosity "Outdated dependencies:" - for_ outdatedDeps $ \(d@(PackageVersionConstraint pn _), v) -> - let outdatedDep = if simpleOutput then prettyShow pn - else prettyShow d ++ " (latest: " ++ prettyShow v ++ ")" - in notice verbosity outdatedDep - else notice verbosity "All dependencies are up to date." - --- | Convert a list of 'UserConstraint's to a 'Dependency' list. -userConstraintsToDependencies :: [UserConstraint] -> [PackageVersionConstraint] -userConstraintsToDependencies ucnstrs = - mapMaybe (packageConstraintToDependency . userToPackageConstraint) ucnstrs - --- | Read the list of dependencies from the freeze file. -depsFromFreezeFile :: Verbosity -> IO [PackageVersionConstraint] -depsFromFreezeFile verbosity = do - cwd <- getCurrentDirectory - userConfig <- loadUserConfig verbosity cwd Nothing - let ucnstrs = map fst . configExConstraints . savedConfigureExFlags $ - userConfig - deps = userConstraintsToDependencies ucnstrs - debug verbosity "Reading the list of dependencies from the freeze file" - return deps - --- | Read the list of dependencies from the new-style freeze file. -depsFromNewFreezeFile :: Verbosity -> Maybe FilePath -> IO [PackageVersionConstraint] -depsFromNewFreezeFile verbosity mprojectFile = do - projectRoot <- either throwIO return =<< - findProjectRoot Nothing mprojectFile - let distDirLayout = defaultDistDirLayout projectRoot - {- TODO: Support dist dir override -} Nothing - projectConfig <- runRebuild (distProjectRootDirectory distDirLayout) $ - readProjectLocalFreezeConfig verbosity distDirLayout - let ucnstrs = map fst . projectConfigConstraints . projectConfigShared - $ projectConfig - deps = userConstraintsToDependencies ucnstrs - debug verbosity $ - "Reading the list of dependencies from the new-style freeze file " ++ distProjectFile distDirLayout "freeze" - return deps - --- | Read the list of dependencies from the package description. -depsFromPkgDesc :: Verbosity -> Compiler -> Platform -> IO [PackageVersionConstraint] -depsFromPkgDesc verbosity comp platform = do - cwd <- getCurrentDirectory - path <- tryFindPackageDesc verbosity cwd - gpd <- readGenericPackageDescription verbosity path - let cinfo = compilerInfo comp - epd = finalizePD mempty (ComponentRequestedSpec True True) - (const True) platform cinfo [] gpd - case epd of - Left _ -> die' verbosity "finalizePD failed" - Right (pd, _) -> do - let bd = allBuildDepends pd - debug verbosity - "Reading the list of dependencies from the package description" - return $ map toPVC bd - where - toPVC (Dependency pn vr _) = PackageVersionConstraint pn vr - --- | Various knobs for customising the behaviour of 'listOutdated'. -data ListOutdatedSettings = ListOutdatedSettings { - -- | Should this package be ignored? - listOutdatedIgnorePred :: PackageName -> Bool, - -- | Should major version bumps should be ignored for this package? - listOutdatedMinorPred :: PackageName -> Bool - } - --- | Find all outdated dependencies. -listOutdated :: [PackageVersionConstraint] - -> PackageIndex UnresolvedSourcePackage - -> ListOutdatedSettings - -> [(PackageVersionConstraint, Version)] -listOutdated deps pkgIndex (ListOutdatedSettings ignorePred minorPred) = - mapMaybe isOutdated $ map simplifyPackageVersionConstraint deps - where - isOutdated :: PackageVersionConstraint -> Maybe (PackageVersionConstraint, Version) - isOutdated dep@(PackageVersionConstraint pname vr) - | ignorePred pname = Nothing - | otherwise = - let this = map packageVersion $ lookupDependency pkgIndex pname vr - latest = lookupLatest dep - in (\v -> (dep, v)) `fmap` isOutdated' this latest - - isOutdated' :: [Version] -> [Version] -> Maybe Version - isOutdated' [] _ = Nothing - isOutdated' _ [] = Nothing - isOutdated' this latest = - let this' = maximum this - latest' = maximum latest - in if this' < latest' then Just latest' else Nothing - - lookupLatest :: PackageVersionConstraint -> [Version] - lookupLatest (PackageVersionConstraint pname vr) - | minorPred pname = - map packageVersion $ lookupDependency pkgIndex pname (relaxMinor vr) - | otherwise = - map packageVersion $ lookupPackageName pkgIndex pname - - relaxMinor :: VersionRange -> VersionRange - relaxMinor vr = - let vis = asVersionIntervals vr - in maybe vr relax (safeLast vis) - where relax (LowerBound v0 _, upper) = - case upper of - NoUpperBound -> vr - UpperBound _v1 _ -> majorBoundVersion v0 diff --git a/cabal/cabal-install/Distribution/Client/PackageHash.hs b/cabal/cabal-install/Distribution/Client/PackageHash.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/PackageHash.hs +++ /dev/null @@ -1,317 +0,0 @@ -{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} -{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} - --- | Functions to calculate nix-style hashes for package ids. --- --- The basic idea is simple, hash the combination of: --- --- * the package tarball --- * the ids of all the direct dependencies --- * other local configuration (flags, profiling, etc) --- -module Distribution.Client.PackageHash ( - -- * Calculating package hashes - PackageHashInputs(..), - PackageHashConfigInputs(..), - PackageSourceHash, - hashedInstalledPackageId, - hashPackageHashInputs, - renderPackageHashInputs, - -- ** Platform-specific variations - hashedInstalledPackageIdLong, - hashedInstalledPackageIdShort, - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude - -import Distribution.Package - ( PackageId, PackageIdentifier(..), mkComponentId - , PkgconfigName ) -import Distribution.System - ( Platform, OS(Windows, OSX), buildOS ) -import Distribution.Types.Flag - ( FlagAssignment, showFlagAssignment ) -import Distribution.Simple.Compiler - ( CompilerId, OptimisationLevel(..), DebugInfoLevel(..) - , ProfDetailLevel(..), showProfDetailLevel ) -import Distribution.Simple.InstallDirs - ( PathTemplate, fromPathTemplate ) -import Distribution.Types.PkgconfigVersion (PkgconfigVersion) -import Distribution.Client.HashValue -import Distribution.Client.Types - ( InstalledPackageId ) -import qualified Distribution.Solver.Types.ComponentDeps as CD - -import qualified Data.ByteString.Lazy.Char8 as LBS -import qualified Data.Map as Map -import qualified Data.Set as Set - -------------------------------- --- Calculating package hashes --- - --- | Calculate a 'InstalledPackageId' for a package using our nix-style --- inputs hashing method. --- --- Note that due to path length limitations on Windows, this function uses --- a different method on Windows that produces shorted package ids. --- See 'hashedInstalledPackageIdLong' vs 'hashedInstalledPackageIdShort'. --- -hashedInstalledPackageId :: PackageHashInputs -> InstalledPackageId -hashedInstalledPackageId - | buildOS == Windows = hashedInstalledPackageIdShort - | buildOS == OSX = hashedInstalledPackageIdVeryShort - | otherwise = hashedInstalledPackageIdLong - --- | Calculate a 'InstalledPackageId' for a package using our nix-style --- inputs hashing method. --- --- This produces large ids with big hashes. It is only suitable for systems --- without significant path length limitations (ie not Windows). --- -hashedInstalledPackageIdLong :: PackageHashInputs -> InstalledPackageId -hashedInstalledPackageIdLong - pkghashinputs@PackageHashInputs{pkgHashPkgId,pkgHashComponent} - = mkComponentId $ - prettyShow pkgHashPkgId -- to be a bit user friendly - ++ maybe "" displayComponent pkgHashComponent - ++ "-" - ++ showHashValue (hashPackageHashInputs pkghashinputs) - where - displayComponent :: CD.Component -> String - displayComponent CD.ComponentLib = "" - displayComponent (CD.ComponentSubLib s) = "-l-" ++ prettyShow s - displayComponent (CD.ComponentFLib s) = "-f-" ++ prettyShow s - displayComponent (CD.ComponentExe s) = "-e-" ++ prettyShow s - displayComponent (CD.ComponentTest s) = "-t-" ++ prettyShow s - displayComponent (CD.ComponentBench s) = "-b-" ++ prettyShow s - displayComponent CD.ComponentSetup = "-setup" - --- | On Windows we have serious problems with path lengths. Windows imposes a --- maximum path length of 260 chars, and even if we can use the windows long --- path APIs ourselves, we cannot guarantee that ghc, gcc, ld, ar, etc etc all --- do so too. --- --- So our only choice is to limit the lengths of the paths, and the only real --- way to do that is to limit the size of the 'InstalledPackageId's that we --- generate. We do this by truncating the package names and versions and also --- by truncating the hash sizes. --- --- Truncating the package names and versions is technically ok because they are --- just included for human convenience, the full source package id is included --- in the hash. --- --- Truncating the hash size is disappointing but also technically ok. We --- rely on the hash primarily for collision avoidance not for any security --- properties (at least for now). --- -hashedInstalledPackageIdShort :: PackageHashInputs -> InstalledPackageId -hashedInstalledPackageIdShort pkghashinputs@PackageHashInputs{pkgHashPkgId} = - mkComponentId $ - intercalate "-" - -- max length now 64 - [ truncateStr 14 (prettyShow name) - , truncateStr 8 (prettyShow version) - , showHashValue (truncateHash 20 (hashPackageHashInputs pkghashinputs)) - ] - where - PackageIdentifier name version = pkgHashPkgId - - -- Truncate a string, with a visual indication that it is truncated. - truncateStr n s | length s <= n = s - | otherwise = take (n-1) s ++ "_" - --- | On macOS we shorten the name very aggressively. The mach-o linker on --- macOS has a limited load command size, to which the name of the library --- as well as its relative path (\@rpath) entry count. To circumvent this, --- on macOS the libraries are not stored as --- @store//libHS.dylib@ --- where libraryname contains the libraries name, version and abi hash, but in --- @store/lib/libHS.dylib@ --- where the very short library name drops all vowels from the package name, --- and truncates the hash to 4 bytes. --- --- We therefore we only need one \@rpath entry to @store/lib@ instead of one --- \@rpath entry for each library. And the reduced library name saves some --- additional space. --- --- This however has two major drawbacks: --- 1) Packages can collide more easily due to the shortened hash. --- 2) The libraries are *not* prefix relocatable anymore as they all end up --- in the same @store/lib@ folder. --- --- The ultimate solution would have to include generating proxy dynamic --- libraries on macOS, such that the proxy libraries and the linked libraries --- stay under the load command limit, and the recursive linker is still able --- to link all of them. -hashedInstalledPackageIdVeryShort :: PackageHashInputs -> InstalledPackageId -hashedInstalledPackageIdVeryShort pkghashinputs@PackageHashInputs{pkgHashPkgId} = - mkComponentId $ - intercalate "-" - [ filter (not . flip elem "aeiou") (prettyShow name) - , prettyShow version - , showHashValue (truncateHash 4 (hashPackageHashInputs pkghashinputs)) - ] - where - PackageIdentifier name version = pkgHashPkgId - --- | All the information that contribues to a package's hash, and thus its --- 'InstalledPackageId'. --- -data PackageHashInputs = PackageHashInputs { - pkgHashPkgId :: PackageId, - pkgHashComponent :: Maybe CD.Component, - pkgHashSourceHash :: PackageSourceHash, - pkgHashPkgConfigDeps :: Set (PkgconfigName, Maybe PkgconfigVersion), - pkgHashDirectDeps :: Set InstalledPackageId, - pkgHashOtherConfig :: PackageHashConfigInputs - } - -type PackageSourceHash = HashValue - --- | Those parts of the package configuration that contribute to the --- package hash. --- -data PackageHashConfigInputs = PackageHashConfigInputs { - pkgHashCompilerId :: CompilerId, - pkgHashPlatform :: Platform, - pkgHashFlagAssignment :: FlagAssignment, -- complete not partial - pkgHashConfigureScriptArgs :: [String], -- just ./configure for build-type Configure - pkgHashVanillaLib :: Bool, - pkgHashSharedLib :: Bool, - pkgHashDynExe :: Bool, - pkgHashFullyStaticExe :: Bool, - pkgHashGHCiLib :: Bool, - pkgHashProfLib :: Bool, - pkgHashProfExe :: Bool, - pkgHashProfLibDetail :: ProfDetailLevel, - pkgHashProfExeDetail :: ProfDetailLevel, - pkgHashCoverage :: Bool, - pkgHashOptimization :: OptimisationLevel, - pkgHashSplitObjs :: Bool, - pkgHashSplitSections :: Bool, - pkgHashStripLibs :: Bool, - pkgHashStripExes :: Bool, - pkgHashDebugInfo :: DebugInfoLevel, - pkgHashProgramArgs :: Map String [String], - pkgHashExtraLibDirs :: [FilePath], - pkgHashExtraFrameworkDirs :: [FilePath], - pkgHashExtraIncludeDirs :: [FilePath], - pkgHashProgPrefix :: Maybe PathTemplate, - pkgHashProgSuffix :: Maybe PathTemplate, - - -- Haddock options - pkgHashDocumentation :: Bool, - pkgHashHaddockHoogle :: Bool, - pkgHashHaddockHtml :: Bool, - pkgHashHaddockHtmlLocation :: Maybe String, - pkgHashHaddockForeignLibs :: Bool, - pkgHashHaddockExecutables :: Bool, - pkgHashHaddockTestSuites :: Bool, - pkgHashHaddockBenchmarks :: Bool, - pkgHashHaddockInternal :: Bool, - pkgHashHaddockCss :: Maybe FilePath, - pkgHashHaddockLinkedSource :: Bool, - pkgHashHaddockQuickJump :: Bool, - pkgHashHaddockContents :: Maybe PathTemplate - --- TODO: [required eventually] pkgHashToolsVersions ? --- TODO: [required eventually] pkgHashToolsExtraOptions ? - } - deriving Show - - --- | Calculate the overall hash to be used for an 'InstalledPackageId'. --- -hashPackageHashInputs :: PackageHashInputs -> HashValue -hashPackageHashInputs = hashValue . renderPackageHashInputs - --- | Render a textual representation of the 'PackageHashInputs'. --- --- The 'hashValue' of this text is the overall package hash. --- -renderPackageHashInputs :: PackageHashInputs -> LBS.ByteString -renderPackageHashInputs PackageHashInputs{ - pkgHashPkgId, - pkgHashComponent, - pkgHashSourceHash, - pkgHashDirectDeps, - pkgHashPkgConfigDeps, - pkgHashOtherConfig = - PackageHashConfigInputs{..} - } = - -- The purpose of this somewhat laboured rendering (e.g. why not just - -- use show?) is so that existing package hashes do not change - -- unnecessarily when new configuration inputs are added into the hash. - - -- In particular, the assumption is that when a new configuration input - -- is included into the hash, that existing packages will typically get - -- the default value for that feature. So if we avoid adding entries with - -- the default value then most of the time adding new features will not - -- change the hashes of existing packages and so fewer packages will need - -- to be rebuilt. - - --TODO: [nice to have] ultimately we probably want to put this config info - -- into the ghc-pkg db. At that point this should probably be changed to - -- use the config file infrastructure so it can be read back in again. - LBS.pack $ unlines $ catMaybes $ - [ entry "pkgid" prettyShow pkgHashPkgId - , mentry "component" show pkgHashComponent - , entry "src" showHashValue pkgHashSourceHash - , entry "pkg-config-deps" - (intercalate ", " . map (\(pn, mb_v) -> prettyShow pn ++ - case mb_v of - Nothing -> "" - Just v -> " " ++ prettyShow v) - . Set.toList) pkgHashPkgConfigDeps - , entry "deps" (intercalate ", " . map prettyShow - . Set.toList) pkgHashDirectDeps - -- and then all the config - , entry "compilerid" prettyShow pkgHashCompilerId - , entry "platform" prettyShow pkgHashPlatform - , opt "flags" mempty showFlagAssignment pkgHashFlagAssignment - , opt "configure-script" [] unwords pkgHashConfigureScriptArgs - , opt "vanilla-lib" True prettyShow pkgHashVanillaLib - , opt "shared-lib" False prettyShow pkgHashSharedLib - , opt "dynamic-exe" False prettyShow pkgHashDynExe - , opt "fully-static-exe" False prettyShow pkgHashFullyStaticExe - , opt "ghci-lib" False prettyShow pkgHashGHCiLib - , opt "prof-lib" False prettyShow pkgHashProfLib - , opt "prof-exe" False prettyShow pkgHashProfExe - , opt "prof-lib-detail" ProfDetailDefault showProfDetailLevel pkgHashProfLibDetail - , opt "prof-exe-detail" ProfDetailDefault showProfDetailLevel pkgHashProfExeDetail - , opt "hpc" False prettyShow pkgHashCoverage - , opt "optimisation" NormalOptimisation (show . fromEnum) pkgHashOptimization - , opt "split-objs" False prettyShow pkgHashSplitObjs - , opt "split-sections" False prettyShow pkgHashSplitSections - , opt "stripped-lib" False prettyShow pkgHashStripLibs - , opt "stripped-exe" True prettyShow pkgHashStripExes - , opt "debug-info" NormalDebugInfo (show . fromEnum) pkgHashDebugInfo - , opt "extra-lib-dirs" [] unwords pkgHashExtraLibDirs - , opt "extra-framework-dirs" [] unwords pkgHashExtraFrameworkDirs - , opt "extra-include-dirs" [] unwords pkgHashExtraIncludeDirs - , opt "prog-prefix" Nothing (maybe "" fromPathTemplate) pkgHashProgPrefix - , opt "prog-suffix" Nothing (maybe "" fromPathTemplate) pkgHashProgSuffix - - , opt "documentation" False prettyShow pkgHashDocumentation - , opt "haddock-hoogle" False prettyShow pkgHashHaddockHoogle - , opt "haddock-html" False prettyShow pkgHashHaddockHtml - , opt "haddock-html-location" Nothing (fromMaybe "") pkgHashHaddockHtmlLocation - , opt "haddock-foreign-libraries" False prettyShow pkgHashHaddockForeignLibs - , opt "haddock-executables" False prettyShow pkgHashHaddockExecutables - , opt "haddock-tests" False prettyShow pkgHashHaddockTestSuites - , opt "haddock-benchmarks" False prettyShow pkgHashHaddockBenchmarks - , opt "haddock-internal" False prettyShow pkgHashHaddockInternal - , opt "haddock-css" Nothing (fromMaybe "") pkgHashHaddockCss - , opt "haddock-hyperlink-source" False prettyShow pkgHashHaddockLinkedSource - , opt "haddock-quickjump" False prettyShow pkgHashHaddockQuickJump - , opt "haddock-contents-location" Nothing (maybe "" fromPathTemplate) pkgHashHaddockContents - - ] ++ Map.foldrWithKey (\prog args acc -> opt (prog ++ "-options") [] unwords args : acc) [] pkgHashProgramArgs - where - entry key format value = Just (key ++ ": " ++ format value) - mentry key format value = fmap (\v -> key ++ ": " ++ format v) value - opt key def format value - | value == def = Nothing - | otherwise = entry key format value diff --git a/cabal/cabal-install/Distribution/Client/ParseUtils.hs b/cabal/cabal-install/Distribution/Client/ParseUtils.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/ParseUtils.hs +++ /dev/null @@ -1,374 +0,0 @@ -{-# LANGUAGE ExistentialQuantification, NamedFieldPuns, RankNTypes #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.ParseUtils --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Parsing utilities. ------------------------------------------------------------------------------ - -module Distribution.Client.ParseUtils ( - - -- * Fields and field utilities - FieldDescr(..), - liftField, - liftFields, - filterFields, - mapFieldNames, - commandOptionToField, - commandOptionsToFields, - - -- * Sections and utilities - SectionDescr(..), - liftSection, - - -- * FieldGrammar sections - FGSectionDescr(..), - - -- * Parsing and printing flat config - parseFields, - ppFields, - ppSection, - - -- * Parsing and printing config with sections and subsections - parseFieldsAndSections, - ppFieldsAndSections, - - -- ** Top level of config files - parseConfig, - showConfig, - ) - where - -import Distribution.Client.Compat.Prelude hiding (empty, get) -import Prelude () - -import Distribution.Deprecated.ParseUtils - ( FieldDescr(..), ParseResult(..), warning, LineNo, lineNo - , Field(..), liftField, readFieldsFlat ) -import Distribution.Deprecated.ViewAsFieldDescr - ( viewAsFieldDescr ) - -import Distribution.Simple.Command - ( OptionField ) - -import Text.PrettyPrint ( ($+$) ) -import qualified Data.Map as Map -import qualified Text.PrettyPrint as Disp - ( (<>), Doc, text, colon, vcat, empty, isEmpty, nest ) - --- For new parser stuff -import Distribution.CabalSpecVersion (cabalSpecLatest) -import Distribution.FieldGrammar (partitionFields, parseFieldGrammar) -import Distribution.Fields.ParseResult (runParseResult) -import Distribution.Parsec.Error (showPError) -import Distribution.Parsec.Position (Position (..)) -import Distribution.Parsec.Warning (showPWarning) -import Distribution.Simple.Utils (fromUTF8BS, toUTF8BS) -import qualified Distribution.Fields as F -import qualified Distribution.FieldGrammar as FG - - -------------------------- --- FieldDescr utilities --- - -liftFields :: (b -> a) - -> (a -> b -> b) - -> [FieldDescr a] - -> [FieldDescr b] -liftFields get set = map (liftField get set) - - --- | Given a collection of field descriptions, keep only a given list of them, --- identified by name. --- -filterFields :: [String] -> [FieldDescr a] -> [FieldDescr a] -filterFields includeFields = filter ((`elem` includeFields) . fieldName) - --- | Apply a name mangling function to the field names of all the field --- descriptions. The typical use case is to apply some prefix. --- -mapFieldNames :: (String -> String) -> [FieldDescr a] -> [FieldDescr a] -mapFieldNames mangleName = - map (\descr -> descr { fieldName = mangleName (fieldName descr) }) - - --- | Reuse a command line 'OptionField' as a config file 'FieldDescr'. --- -commandOptionToField :: OptionField a -> FieldDescr a -commandOptionToField = viewAsFieldDescr - --- | Reuse a bunch of command line 'OptionField's as config file 'FieldDescr's. --- -commandOptionsToFields :: [OptionField a] -> [FieldDescr a] -commandOptionsToFields = map viewAsFieldDescr - - ------------------------------------------- --- SectionDescr definition and utilities --- - --- | The description of a section in a config file. It can contain both --- fields and optionally further subsections. See also 'FieldDescr'. --- -data SectionDescr a = forall b. SectionDescr { - sectionName :: String, - sectionFields :: [FieldDescr b], - sectionSubsections :: [SectionDescr b], - sectionGet :: a -> [(String, b)], - sectionSet :: LineNo -> String -> b -> a -> ParseResult a, - sectionEmpty :: b - } - --- | 'FieldGrammar' section description -data FGSectionDescr g a = forall s. FGSectionDescr - { fgSectionName :: String - , fgSectionGrammar :: g s s - -- todo: add subsections? - , fgSectionGet :: a -> [(String, s)] - , fgSectionSet :: LineNo -> String -> s -> a -> ParseResult a - } - --- | To help construction of config file descriptions in a modular way it is --- useful to define fields and sections on local types and then hoist them --- into the parent types when combining them in bigger descriptions. --- --- This is essentially a lens operation for 'SectionDescr' to help embedding --- one inside another. --- -liftSection :: (b -> a) - -> (a -> b -> b) - -> SectionDescr a - -> SectionDescr b -liftSection get' set' (SectionDescr name fields sections get set empty) = - let sectionGet' = get . get' - sectionSet' lineno param x y = do - x' <- set lineno param x (get' y) - return (set' x' y) - in SectionDescr name fields sections sectionGet' sectionSet' empty - - -------------------------------------- --- Parsing and printing flat config --- - --- | Parse a bunch of semi-parsed 'Field's according to a set of field --- descriptions. It accumulates the result on top of a given initial value. --- --- This only covers the case of flat configuration without subsections. See --- also 'parseFieldsAndSections'. --- -parseFields :: [FieldDescr a] -> a -> [Field] -> ParseResult a -parseFields fieldDescrs = - foldM setField - where - fieldMap = Map.fromList [ (fieldName f, f) | f <- fieldDescrs ] - - setField accum (F line name value) = - case Map.lookup name fieldMap of - Just (FieldDescr _ _ set) -> set line value accum - Nothing -> do - warning $ "Unrecognized field " ++ name ++ " on line " ++ show line - return accum - - setField accum f = do - warning $ "Unrecognized stanza on line " ++ show (lineNo f) - return accum - --- | This is a customised version of the functions from Distribution.Deprecated.ParseUtils --- that also optionally print default values for empty fields as comments. --- -ppFields :: [FieldDescr a] -> (Maybe a) -> a -> Disp.Doc -ppFields fields def cur = - Disp.vcat [ ppField name (fmap getter def) (getter cur) - | FieldDescr name getter _ <- fields] - -ppField :: String -> (Maybe Disp.Doc) -> Disp.Doc -> Disp.Doc -ppField name mdef cur - | Disp.isEmpty cur = maybe Disp.empty - (\def -> Disp.text "--" <+> Disp.text name - Disp.<> Disp.colon <+> def) mdef - | otherwise = Disp.text name Disp.<> Disp.colon <+> cur - --- | Pretty print a section. --- --- Since 'ppFields' does not cover subsections you can use this to add them. --- Or alternatively use a 'SectionDescr' and use 'ppFieldsAndSections'. --- -ppSection :: String -> String -> [FieldDescr a] -> (Maybe a) -> a -> Disp.Doc -ppSection name arg fields def cur - | Disp.isEmpty fieldsDoc = Disp.empty - | otherwise = Disp.text name <+> argDoc - $+$ (Disp.nest 2 fieldsDoc) - where - fieldsDoc = ppFields fields def cur - argDoc | arg == "" = Disp.empty - | otherwise = Disp.text arg - - ------------------------------------------ --- Parsing and printing non-flat config --- - --- | Much like 'parseFields' but it also allows subsections. The permitted --- subsections are given by a list of 'SectionDescr's. --- -parseFieldsAndSections - :: [FieldDescr a] -- ^ field - -> [SectionDescr a] -- ^ legacy sections - -> [FGSectionDescr FG.ParsecFieldGrammar a] -- ^ FieldGrammar sections - -> a - -> [Field] -> ParseResult a -parseFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs = - foldM setField - where - fieldMap = Map.fromList [ (fieldName f, f) | f <- fieldDescrs ] - sectionMap = Map.fromList [ (sectionName s, s) | s <- sectionDescrs ] - fgSectionMap = Map.fromList [ (fgSectionName s, s) | s <- fgSectionDescrs ] - - setField a (F line name value) = - case Map.lookup name fieldMap of - Just (FieldDescr _ _ set) -> set line value a - Nothing -> do - warning $ "Unrecognized field '" ++ name - ++ "' on line " ++ show line - return a - - setField a (Section line name param fields) = - case Left <$> Map.lookup name sectionMap <|> Right <$> Map.lookup name fgSectionMap of - Just (Left (SectionDescr _ fieldDescrs' sectionDescrs' _ set sectionEmpty)) -> do - b <- parseFieldsAndSections fieldDescrs' sectionDescrs' [] sectionEmpty fields - set line param b a - Just (Right (FGSectionDescr _ grammar _getter setter)) -> do - let fields1 = mapMaybe convertField fields - (fields2, sections) = partitionFields fields1 - -- TODO: recurse into sections - for_ (concat sections) $ \(FG.MkSection (F.Name (Position line' _) name') _ _) -> - warning $ "Unrecognized section '" ++ fromUTF8BS name' - ++ "' on line " ++ show line' - case runParseResult $ parseFieldGrammar cabalSpecLatest fields2 grammar of - (warnings, Right b) -> do - for_ warnings $ \w -> warning $ showPWarning "???" w - setter line param b a - (warnings, Left (_, errs)) -> do - for_ warnings $ \w -> warning $ showPWarning "???" w - case errs of - err :| _errs -> fail $ showPError "???" err - Nothing -> do - warning $ "Unrecognized section '" ++ name - ++ "' on line " ++ show line - return a - - setField accum (block@IfBlock {}) = do - warning $ "Unrecognized stanza on line " ++ show (lineNo block) - return accum - -convertField :: Field -> Maybe (F.Field Position) -convertField (F line name str) = Just $ - F.Field (F.Name pos (toUTF8BS name)) [ F.FieldLine pos $ toUTF8BS str ] - where - pos = Position line 0 --- arguments omitted -convertField (Section line name _arg fields) = Just $ - F.Section (F.Name pos (toUTF8BS name)) [] (mapMaybe convertField fields) - where - pos = Position line 0 --- silently omitted. -convertField IfBlock {} = Nothing - - --- | Much like 'ppFields' but also pretty prints any subsections. Subsection --- are only shown if they are non-empty. --- --- Note that unlike 'ppFields', at present it does not support printing --- default values. If needed, adding such support would be quite reasonable. --- -ppFieldsAndSections :: [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr FG.PrettyFieldGrammar a] -> a -> Disp.Doc -ppFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs val = - ppFields fieldDescrs Nothing val - $+$ - Disp.vcat ( - [ Disp.text "" $+$ sectionDoc - | SectionDescr { - sectionName, sectionGet, - sectionFields, sectionSubsections - } <- sectionDescrs - , (param, x) <- sectionGet val - , let sectionDoc = ppSectionAndSubsections - sectionName param - sectionFields sectionSubsections [] x - , not (Disp.isEmpty sectionDoc) - ] ++ - [ Disp.text "" $+$ sectionDoc - | FGSectionDescr { fgSectionName, fgSectionGrammar, fgSectionGet } <- fgSectionDescrs - , (param, x) <- fgSectionGet val - , let sectionDoc = ppFgSection fgSectionName param fgSectionGrammar x - , not (Disp.isEmpty sectionDoc) - ]) - --- | Unlike 'ppSection' which has to be called directly, this gets used via --- 'ppFieldsAndSections' and so does not need to be exported. --- -ppSectionAndSubsections :: String -> String - -> [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr FG.PrettyFieldGrammar a] -> a -> Disp.Doc -ppSectionAndSubsections name arg fields sections fgSections cur - | Disp.isEmpty fieldsDoc = Disp.empty - | otherwise = Disp.text name <+> argDoc - $+$ (Disp.nest 2 fieldsDoc) - where - fieldsDoc = showConfig fields sections fgSections cur - argDoc | arg == "" = Disp.empty - | otherwise = Disp.text arg - --- | --- --- TODO: subsections --- TODO: this should simply build 'PrettyField' -ppFgSection - :: String -- ^ section name - -> String -- ^ parameter - -> FG.PrettyFieldGrammar a a - -> a - -> Disp.Doc -ppFgSection secName arg grammar x - | null prettyFields = Disp.empty - | otherwise = - Disp.text secName <+> argDoc - $+$ (Disp.nest 2 fieldsDoc) - where - prettyFields = FG.prettyFieldGrammar cabalSpecLatest grammar x - - argDoc | arg == "" = Disp.empty - | otherwise = Disp.text arg - - fieldsDoc = Disp.vcat - [ Disp.text fname' <<>> Disp.colon <<>> doc - | F.PrettyField _ fname doc <- prettyFields -- TODO: this skips sections - , let fname' = fromUTF8BS fname - ] - - ------------------------------------------------ --- Top level config file parsing and printing --- - --- | Parse a string in the config file syntax into a value, based on a --- description of the configuration file in terms of its fields and sections. --- --- It accumulates the result on top of a given initial (typically empty) value. --- -parseConfig :: [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr FG.ParsecFieldGrammar a] -> a - -> String -> ParseResult a -parseConfig fieldDescrs sectionDescrs fgSectionDescrs empty str = - parseFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs empty - =<< readFieldsFlat str - --- | Render a value in the config file syntax, based on a description of the --- configuration file in terms of its fields and sections. --- -showConfig :: [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr FG.PrettyFieldGrammar a] -> a -> Disp.Doc -showConfig = ppFieldsAndSections - diff --git a/cabal/cabal-install/Distribution/Client/ProjectBuilding.hs b/cabal/cabal-install/Distribution/Client/ProjectBuilding.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/ProjectBuilding.hs +++ /dev/null @@ -1,1475 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE NoMonoLocalBinds #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} - --- | --- -module Distribution.Client.ProjectBuilding ( - -- * Dry run phase - -- | What bits of the plan will we execute? The dry run does not change - -- anything but tells us what will need to be built. - rebuildTargetsDryRun, - improveInstallPlanWithUpToDatePackages, - - -- ** Build status - -- | This is the detailed status information we get from the dry run. - BuildStatusMap, - BuildStatus(..), - BuildStatusRebuild(..), - BuildReason(..), - MonitorChangedReason(..), - buildStatusToString, - - -- * Build phase - -- | Now we actually execute the plan. - rebuildTargets, - -- ** Build outcomes - -- | This is the outcome for each package of executing the plan. - -- For each package, did the build succeed or fail? - BuildOutcomes, - BuildOutcome, - BuildResult(..), - BuildFailure(..), - BuildFailureReason(..), - ) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Client.PackageHash (renderPackageHashInputs) -import Distribution.Client.RebuildMonad -import Distribution.Client.ProjectConfig -import Distribution.Client.ProjectPlanning -import Distribution.Client.ProjectPlanning.Types -import Distribution.Client.ProjectBuilding.Types -import Distribution.Client.Store - -import Distribution.Client.Types - hiding (BuildOutcomes, BuildOutcome, - BuildResult(..), BuildFailure(..)) -import Distribution.Client.InstallPlan - ( GenericInstallPlan, GenericPlanPackage, IsUnit ) -import qualified Distribution.Client.InstallPlan as InstallPlan -import Distribution.Client.DistDirLayout -import Distribution.Client.FileMonitor -import Distribution.Client.SetupWrapper -import Distribution.Client.JobControl -import Distribution.Client.FetchUtils -import Distribution.Client.GlobalFlags (RepoContext) -import qualified Distribution.Client.Tar as Tar -import Distribution.Client.Setup - ( filterConfigureFlags, filterHaddockArgs - , filterHaddockFlags, filterTestFlags ) -import Distribution.Client.SourceFiles -import Distribution.Client.SrcDist (allPackageSourceFiles) -import Distribution.Client.Utils - ( ProgressPhase(..), progressMessage, removeExistingFile ) - -import Distribution.Compat.Lens -import Distribution.Package -import qualified Distribution.PackageDescription as PD -import Distribution.InstalledPackageInfo (InstalledPackageInfo) -import qualified Distribution.InstalledPackageInfo as Installed -import Distribution.Simple.BuildPaths (haddockDirName) -import qualified Distribution.Simple.InstallDirs as InstallDirs -import Distribution.Types.BuildType -import Distribution.Types.PackageDescription.Lens (componentModules) -import Distribution.Simple.Program -import qualified Distribution.Simple.Setup as Cabal -import Distribution.Simple.Command (CommandUI) -import qualified Distribution.Simple.Register as Cabal -import Distribution.Simple.LocalBuildInfo - ( ComponentName(..), LibraryName(..) ) -import Distribution.Simple.Compiler - ( Compiler, compilerId, PackageDB(..) ) - -import Distribution.Simple.Utils -import Distribution.Version -import Distribution.Compat.Graph (IsNode(..)) - -import qualified Data.List.NonEmpty as NE -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LBS - -import Control.Exception (Handler (..), SomeAsyncException, assert, catches, handle) -import System.Directory (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, removeFile, renameDirectory) -import System.FilePath (dropDrive, makeRelative, normalise, takeDirectory, (<.>), ()) -import System.IO (IOMode (AppendMode), withFile) - -import Distribution.Compat.Directory (listDirectory) - - ------------------------------------------------------------------------------- --- * Overall building strategy. ------------------------------------------------------------------------------- --- --- We start with an 'ElaboratedInstallPlan' that has already been improved by --- reusing packages from the store, and pruned to include only the targets of --- interest and their dependencies. So the remaining packages in the --- 'InstallPlan.Configured' state are ones we either need to build or rebuild. --- --- First, we do a preliminary dry run phase where we work out which packages --- we really need to (re)build, and for the ones we do need to build which --- build phase to start at. --- --- We use this to improve the 'ElaboratedInstallPlan' again by changing --- up-to-date 'InstallPlan.Configured' packages to 'InstallPlan.Installed' --- so that the build phase will skip them. --- --- Then we execute the plan, that is actually build packages. The outcomes of --- trying to build all the packages are collected and returned. --- --- We split things like this (dry run and execute) for a couple reasons. --- Firstly we need to be able to do dry runs anyway, and these need to be --- reasonably accurate in terms of letting users know what (and why) things --- are going to be (re)built. --- --- Given that we need to be able to do dry runs, it would not be great if --- we had to repeat all the same work when we do it for real. Not only is --- it duplicate work, but it's duplicate code which is likely to get out of --- sync. So we do things only once. We preserve info we discover in the dry --- run phase and rely on it later when we build things for real. This also --- somewhat simplifies the build phase. So this way the dry run can't so --- easily drift out of sync with the real thing since we're relying on the --- info it produces. --- --- An additional advantage is that it makes it easier to debug rebuild --- errors (ie rebuilding too much or too little), since all the rebuild --- decisions are made without making any state changes at the same time --- (that would make it harder to reproduce the problem situation). --- --- Finally, we can use the dry run build status and the build outcomes to --- give us some information on the overall status of packages in the project. --- This includes limited information about the status of things that were --- not actually in the subset of the plan that was used for the dry run or --- execution phases. In particular we may know that some packages are now --- definitely out of date. See "Distribution.Client.ProjectPlanOutput" for --- details. - - ------------------------------------------------------------------------------- --- * Dry run: what bits of the 'ElaboratedInstallPlan' will we execute? ------------------------------------------------------------------------------- - --- Refer to ProjectBuilding.Types for details of these important types: - --- type BuildStatusMap = ... --- data BuildStatus = ... --- data BuildStatusRebuild = ... --- data BuildReason = ... - --- | Do the dry run pass. This is a prerequisite of 'rebuildTargets'. --- --- It gives us the 'BuildStatusMap'. This should be used with --- 'improveInstallPlanWithUpToDatePackages' to give an improved version of --- the 'ElaboratedInstallPlan' with packages switched to the --- 'InstallPlan.Installed' state when we find that they're already up to date. --- -rebuildTargetsDryRun :: DistDirLayout - -> ElaboratedSharedConfig - -> ElaboratedInstallPlan - -> IO BuildStatusMap -rebuildTargetsDryRun distDirLayout@DistDirLayout{..} shared = - -- Do the various checks to work out the 'BuildStatus' of each package - foldMInstallPlanDepOrder dryRunPkg - where - dryRunPkg :: ElaboratedPlanPackage - -> [BuildStatus] - -> IO BuildStatus - dryRunPkg (InstallPlan.PreExisting _pkg) _depsBuildStatus = - return BuildStatusPreExisting - - dryRunPkg (InstallPlan.Installed _pkg) _depsBuildStatus = - return BuildStatusInstalled - - dryRunPkg (InstallPlan.Configured pkg) depsBuildStatus = do - mloc <- checkFetched (elabPkgSourceLocation pkg) - case mloc of - Nothing -> return BuildStatusDownload - - Just (LocalUnpackedPackage srcdir) -> - -- For the case of a user-managed local dir, irrespective of the - -- build style, we build from that directory and put build - -- artifacts under the shared dist directory. - dryRunLocalPkg pkg depsBuildStatus srcdir - - -- The rest cases are all tarball cases are, - -- and handled the same as each other though depending on the build style. - Just (LocalTarballPackage tarball) -> - dryRunTarballPkg pkg depsBuildStatus tarball - - Just (RemoteTarballPackage _ tarball) -> - dryRunTarballPkg pkg depsBuildStatus tarball - - Just (RepoTarballPackage _ _ tarball) -> - dryRunTarballPkg pkg depsBuildStatus tarball - - Just (RemoteSourceRepoPackage _repo tarball) -> - dryRunTarballPkg pkg depsBuildStatus tarball - - - dryRunTarballPkg :: ElaboratedConfiguredPackage - -> [BuildStatus] - -> FilePath - -> IO BuildStatus - dryRunTarballPkg pkg depsBuildStatus tarball = - case elabBuildStyle pkg of - BuildAndInstall -> return (BuildStatusUnpack tarball) - BuildInplaceOnly -> do - -- TODO: [nice to have] use a proper file monitor rather - -- than this dir exists test - exists <- doesDirectoryExist srcdir - if exists - then dryRunLocalPkg pkg depsBuildStatus srcdir - else return (BuildStatusUnpack tarball) - where - srcdir = distUnpackedSrcDirectory (packageId pkg) - - dryRunLocalPkg :: ElaboratedConfiguredPackage - -> [BuildStatus] - -> FilePath - -> IO BuildStatus - dryRunLocalPkg pkg depsBuildStatus srcdir = do - -- Go and do lots of I/O, reading caches and probing files to work out - -- if anything has changed - change <- checkPackageFileMonitorChanged - packageFileMonitor pkg srcdir depsBuildStatus - case change of - -- It did change, giving us 'BuildStatusRebuild' info on why - Left rebuild -> - return (BuildStatusRebuild srcdir rebuild) - - -- No changes, the package is up to date. Use the saved build results. - Right buildResult -> - return (BuildStatusUpToDate buildResult) - where - packageFileMonitor = - newPackageFileMonitor shared distDirLayout - (elabDistDirParams shared pkg) - - --- | A specialised traversal over the packages in an install plan. --- --- The packages are visited in dependency order, starting with packages with no --- dependencies. The result for each package is accumulated into a 'Map' and --- returned as the final result. In addition, when visiting a package, the --- 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) - => (GenericPlanPackage ipkg srcpkg -> - [b] -> m b) - -> GenericInstallPlan ipkg srcpkg - -> m (Map UnitId b) -foldMInstallPlanDepOrder visit = - go Map.empty . InstallPlan.reverseTopologicalOrder - where - go :: Map UnitId b - -> [GenericPlanPackage ipkg srcpkg] - -> m (Map UnitId 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 - let depresults :: [b] - depresults = - map (\ipkgid -> let result = Map.findWithDefault (error "foldMInstallPlanDepOrder") ipkgid results - in result) - (InstallPlan.depends pkg) - result <- visit pkg depresults - let results' = Map.insert (nodeKey pkg) result results - go results' pkgs - -improveInstallPlanWithUpToDatePackages :: BuildStatusMap - -> ElaboratedInstallPlan - -> ElaboratedInstallPlan -improveInstallPlanWithUpToDatePackages pkgsBuildStatus = - InstallPlan.installed canPackageBeImproved - where - canPackageBeImproved pkg = - case Map.lookup (installedUnitId pkg) pkgsBuildStatus of - Just BuildStatusUpToDate {} -> True - Just _ -> False - Nothing -> error $ "improveInstallPlanWithUpToDatePackages: " - ++ prettyShow (packageId pkg) ++ " not in status map" - - ------------------------------ --- Package change detection --- - --- | As part of the dry run for local unpacked packages we have to check if the --- package config or files have changed. That is the purpose of --- 'PackageFileMonitor' and 'checkPackageFileMonitorChanged'. --- --- When a package is (re)built, the monitor must be updated to reflect the new --- state of the package. Because we sometimes build without reconfiguring the --- state updates are split into two, one for package config changes and one --- for other changes. This is the purpose of 'updatePackageConfigFileMonitor' --- and 'updatePackageBuildFileMonitor'. --- -data PackageFileMonitor = PackageFileMonitor { - pkgFileMonitorConfig :: FileMonitor ElaboratedConfiguredPackage (), - pkgFileMonitorBuild :: FileMonitor (Set ComponentName) BuildResultMisc, - pkgFileMonitorReg :: FileMonitor () (Maybe InstalledPackageInfo) - } - --- | This is all the components of the 'BuildResult' other than the --- @['InstalledPackageInfo']@. --- --- We have to split up the 'BuildResult' components since they get produced --- at different times (or rather, when different things change). --- -type BuildResultMisc = (DocsResult, TestsResult) - -newPackageFileMonitor :: ElaboratedSharedConfig - -> DistDirLayout - -> DistDirParams - -> PackageFileMonitor -newPackageFileMonitor shared - DistDirLayout{distPackageCacheFile} - dparams = - PackageFileMonitor { - pkgFileMonitorConfig = - FileMonitor { - fileMonitorCacheFile = distPackageCacheFile dparams "config", - fileMonitorKeyValid = (==) `on` normaliseConfiguredPackage shared, - fileMonitorCheckIfOnlyValueChanged = False - }, - - pkgFileMonitorBuild = - FileMonitor { - fileMonitorCacheFile = distPackageCacheFile dparams "build", - fileMonitorKeyValid = \componentsToBuild componentsAlreadyBuilt -> - componentsToBuild `Set.isSubsetOf` componentsAlreadyBuilt, - fileMonitorCheckIfOnlyValueChanged = True - }, - - pkgFileMonitorReg = - newFileMonitor (distPackageCacheFile dparams "registration") - } - --- | Helper function for 'checkPackageFileMonitorChanged', --- 'updatePackageConfigFileMonitor' and 'updatePackageBuildFileMonitor'. --- --- It selects the info from a 'ElaboratedConfiguredPackage' that are used by --- the 'FileMonitor's (in the 'PackageFileMonitor') to detect value changes. --- -packageFileMonitorKeyValues :: ElaboratedConfiguredPackage - -> (ElaboratedConfiguredPackage, Set ComponentName) -packageFileMonitorKeyValues elab = - (elab_config, buildComponents) - where - -- The first part is the value used to guard (re)configuring the package. - -- That is, if this value changes then we will reconfigure. - -- The ElaboratedConfiguredPackage consists mostly (but not entirely) of - -- information that affects the (re)configure step. But those parts that - -- do not affect the configure step need to be nulled out. Those parts are - -- the specific targets that we're going to build. - -- - elab_config = - elab { - elabBuildTargets = [], - elabTestTargets = [], - elabBenchTargets = [], - elabReplTarget = Nothing, - elabHaddockTargets = [], - elabBuildHaddocks = False - } - - -- The second part is the value used to guard the build step. So this is - -- more or less the opposite of the first part, as it's just the info about - -- what targets we're going to build. - -- - buildComponents = elabBuildTargetWholeComponents elab - --- | Do all the checks on whether a package has changed and thus needs either --- rebuilding or reconfiguring and rebuilding. --- -checkPackageFileMonitorChanged :: PackageFileMonitor - -> ElaboratedConfiguredPackage - -> FilePath - -> [BuildStatus] - -> IO (Either BuildStatusRebuild BuildResult) -checkPackageFileMonitorChanged PackageFileMonitor{..} - pkg srcdir depsBuildStatus = do - --TODO: [nice to have] some debug-level message about file - --changes, like rerunIfChanged - configChanged <- checkFileMonitorChanged - pkgFileMonitorConfig srcdir pkgconfig - case configChanged of - MonitorChanged monitorReason -> - return (Left (BuildStatusConfigure monitorReason')) - where - monitorReason' = fmap (const ()) monitorReason - - MonitorUnchanged () _ - -- The configChanged here includes the identity of the dependencies, - -- so depsBuildStatus is just needed for the changes in the content - -- of dependencies. - | any buildStatusRequiresBuild depsBuildStatus -> do - regChanged <- checkFileMonitorChanged pkgFileMonitorReg srcdir () - let mreg = changedToMaybe regChanged - return (Left (BuildStatusBuild mreg BuildReasonDepsRebuilt)) - - | otherwise -> do - buildChanged <- checkFileMonitorChanged - pkgFileMonitorBuild srcdir buildComponents - regChanged <- checkFileMonitorChanged - pkgFileMonitorReg srcdir () - let mreg = changedToMaybe regChanged - case (buildChanged, regChanged) of - (MonitorChanged (MonitoredValueChanged prevBuildComponents), _) -> - return (Left (BuildStatusBuild mreg buildReason)) - where - buildReason = BuildReasonExtraTargets prevBuildComponents - - (MonitorChanged monitorReason, _) -> - return (Left (BuildStatusBuild mreg buildReason)) - where - buildReason = BuildReasonFilesChanged monitorReason' - monitorReason' = fmap (const ()) monitorReason - - (MonitorUnchanged _ _, MonitorChanged monitorReason) -> - -- this should only happen if the file is corrupt or been - -- manually deleted. We don't want to bother with another - -- phase just for this, so we'll reregister by doing a build. - return (Left (BuildStatusBuild Nothing buildReason)) - where - buildReason = BuildReasonFilesChanged monitorReason' - monitorReason' = fmap (const ()) monitorReason - - (MonitorUnchanged _ _, MonitorUnchanged _ _) - | pkgHasEphemeralBuildTargets pkg -> - return (Left (BuildStatusBuild mreg buildReason)) - where - buildReason = BuildReasonEphemeralTargets - - (MonitorUnchanged buildResult _, MonitorUnchanged _ _) -> - return $ Right BuildResult { - buildResultDocs = docsResult, - buildResultTests = testsResult, - buildResultLogFile = Nothing - } - where - (docsResult, testsResult) = buildResult - where - (pkgconfig, buildComponents) = packageFileMonitorKeyValues pkg - changedToMaybe (MonitorChanged _) = Nothing - changedToMaybe (MonitorUnchanged x _) = Just x - - -updatePackageConfigFileMonitor :: PackageFileMonitor - -> FilePath - -> ElaboratedConfiguredPackage - -> IO () -updatePackageConfigFileMonitor PackageFileMonitor{pkgFileMonitorConfig} - srcdir pkg = - updateFileMonitor pkgFileMonitorConfig srcdir Nothing - [] pkgconfig () - where - (pkgconfig, _buildComponents) = packageFileMonitorKeyValues pkg - -updatePackageBuildFileMonitor :: PackageFileMonitor - -> FilePath - -> MonitorTimestamp - -> ElaboratedConfiguredPackage - -> BuildStatusRebuild - -> [MonitorFilePath] - -> BuildResultMisc - -> IO () -updatePackageBuildFileMonitor PackageFileMonitor{pkgFileMonitorBuild} - srcdir timestamp pkg pkgBuildStatus - monitors buildResult = - updateFileMonitor pkgFileMonitorBuild srcdir (Just timestamp) - monitors buildComponents' buildResult - where - (_pkgconfig, buildComponents) = packageFileMonitorKeyValues pkg - - -- If the only thing that's changed is that we're now building extra - -- components, then we can avoid later unnecessary rebuilds by saving the - -- total set of components that have been built, namely the union of the - -- existing ones plus the new ones. If files also changed this would be - -- the wrong thing to do. Note that we rely on the - -- fileMonitorCheckIfOnlyValueChanged = True mode to get this guarantee - -- that it's /only/ the value that changed not any files that changed. - buildComponents' = - case pkgBuildStatus of - BuildStatusBuild _ (BuildReasonExtraTargets prevBuildComponents) - -> buildComponents `Set.union` prevBuildComponents - _ -> buildComponents - -updatePackageRegFileMonitor :: PackageFileMonitor - -> FilePath - -> Maybe InstalledPackageInfo - -> IO () -updatePackageRegFileMonitor PackageFileMonitor{pkgFileMonitorReg} - srcdir mipkg = - updateFileMonitor pkgFileMonitorReg srcdir Nothing - [] () mipkg - -invalidatePackageRegFileMonitor :: PackageFileMonitor -> IO () -invalidatePackageRegFileMonitor PackageFileMonitor{pkgFileMonitorReg} = - removeExistingFile (fileMonitorCacheFile pkgFileMonitorReg) - - ------------------------------------------------------------------------------- --- * Doing it: executing an 'ElaboratedInstallPlan' ------------------------------------------------------------------------------- - --- Refer to ProjectBuilding.Types for details of these important types: - --- type BuildOutcomes = ... --- type BuildOutcome = ... --- data BuildResult = ... --- data BuildFailure = ... --- data BuildFailureReason = ... - --- | Build things for real. --- --- It requires the 'BuildStatusMap' gathered by 'rebuildTargetsDryRun'. --- -rebuildTargets :: Verbosity - -> DistDirLayout - -> StoreDirLayout - -> ElaboratedInstallPlan - -> ElaboratedSharedConfig - -> BuildStatusMap - -> BuildTimeSettings - -> IO BuildOutcomes -rebuildTargets verbosity - distDirLayout@DistDirLayout{..} - storeDirLayout - installPlan - sharedPackageConfig@ElaboratedSharedConfig { - pkgConfigCompiler = compiler, - pkgConfigCompilerProgs = progdb - } - pkgsBuildStatus - buildSettings@BuildTimeSettings{ - buildSettingNumJobs, - buildSettingKeepGoing - } = do - - -- Concurrency control: create the job controller and concurrency limits - -- for downloading, building and installing. - jobControl <- if isParallelBuild - then newParallelJobControl buildSettingNumJobs - else newSerialJobControl - registerLock <- newLock -- serialise registration - cacheLock <- newLock -- serialise access to setup exe cache - --TODO: [code cleanup] eliminate setup exe cache - - debug verbosity $ - "Executing install plan " - ++ if isParallelBuild - then " in parallel using " ++ show buildSettingNumJobs ++ " threads." - else " serially." - - createDirectoryIfMissingVerbose verbosity True distBuildRootDirectory - createDirectoryIfMissingVerbose verbosity True distTempDirectory - traverse_ (createPackageDBIfMissing verbosity compiler progdb) packageDBsToUse - - -- Before traversing the install plan, pre-emptively find all packages that - -- will need to be downloaded and start downloading them. - asyncDownloadPackages verbosity withRepoCtx - installPlan pkgsBuildStatus $ \downloadMap -> - - -- For each package in the plan, in dependency order, but in parallel... - InstallPlan.execute jobControl keepGoing - (BuildFailure Nothing . DependentFailed . packageId) - installPlan $ \pkg -> - --TODO: review exception handling - handle (\(e :: BuildFailure) -> return (Left e)) $ fmap Right $ - - let uid = installedUnitId pkg - pkgBuildStatus = Map.findWithDefault (error "rebuildTargets") uid pkgsBuildStatus in - - rebuildTarget - verbosity - distDirLayout - storeDirLayout - buildSettings downloadMap - registerLock cacheLock - sharedPackageConfig - installPlan pkg - pkgBuildStatus - where - isParallelBuild = buildSettingNumJobs >= 2 - 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 ] - ] - - --- | Create a package DB if it does not currently exist. Note that this action --- is /not/ safe to run concurrently. --- -createPackageDBIfMissing :: Verbosity -> Compiler -> ProgramDb - -> PackageDB -> 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 - -> DistDirLayout - -> StoreDirLayout - -> BuildTimeSettings - -> AsyncFetchMap - -> Lock -> Lock - -> ElaboratedSharedConfig - -> ElaboratedInstallPlan - -> ElaboratedReadyPackage - -> BuildStatus - -> IO BuildResult -rebuildTarget verbosity - distDirLayout@DistDirLayout{distBuildDirectory} - storeDirLayout - buildSettings downloadMap - registerLock cacheLock - sharedPackageConfig - plan rpkg@(ReadyPackage pkg) - pkgBuildStatus = - - -- We rely on the 'BuildStatus' to decide which phase to start from: - case pkgBuildStatus of - BuildStatusDownload -> downloadPhase - BuildStatusUnpack tarball -> unpackTarballPhase tarball - BuildStatusRebuild srcdir status -> rebuildPhase status srcdir - - -- TODO: perhaps re-nest the types to make these impossible - BuildStatusPreExisting {} -> unexpectedState - BuildStatusInstalled {} -> unexpectedState - BuildStatusUpToDate {} -> unexpectedState - where - unexpectedState = error "rebuildTarget: unexpected package status" - - downloadPhase = do - downsrcloc <- annotateFailureNoLog DownloadFailed $ - waitAsyncPackageDownload verbosity downloadMap pkg - case downsrcloc of - DownloadedTarball tarball -> unpackTarballPhase tarball - --TODO: [nice to have] git/darcs repos etc - - - unpackTarballPhase tarball = - withTarballLocalDirectory - verbosity distDirLayout tarball - (packageId pkg) (elabDistDirParams sharedPackageConfig pkg) - (elabBuildStyle pkg) - (elabPkgDescriptionOverride pkg) $ - - case elabBuildStyle pkg of - BuildAndInstall -> buildAndInstall - BuildInplaceOnly -> buildInplace buildStatus - where - buildStatus = BuildStatusConfigure MonitorFirstRun - - -- Note that this really is rebuild, not build. It can only happen for - -- 'BuildInplaceOnly' style packages. 'BuildAndInstall' style packages - -- would only start from download or unpack phases. - -- - rebuildPhase buildStatus srcdir = - assert (elabBuildStyle pkg == BuildInplaceOnly) $ - - buildInplace buildStatus srcdir builddir - where - builddir = distBuildDirectory - (elabDistDirParams sharedPackageConfig pkg) - - buildAndInstall srcdir builddir = - buildAndInstallUnpackedPackage - verbosity distDirLayout storeDirLayout - buildSettings registerLock cacheLock - sharedPackageConfig - plan rpkg - srcdir builddir' - where - builddir' = makeRelative srcdir builddir - --TODO: [nice to have] ^^ do this relative stuff better - - buildInplace buildStatus srcdir builddir = - --TODO: [nice to have] use a relative build dir rather than absolute - buildInplaceUnpackedPackage - verbosity distDirLayout - buildSettings registerLock cacheLock - sharedPackageConfig - plan rpkg - buildStatus - srcdir builddir - --- 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? - --- | Given the current 'InstallPlan' and 'BuildStatusMap', select all the --- packages we have to download and fork off an async action to download them. --- We download them in dependency order so that the one's we'll need --- first are the ones we will start downloading first. --- --- The body action is passed a map from those packages (identified by their --- location) to a completion var for that package. So the body action should --- lookup the location and use 'waitAsyncPackageDownload' to get the result. --- -asyncDownloadPackages :: Verbosity - -> ((RepoContext -> IO a) -> IO a) - -> ElaboratedInstallPlan - -> BuildStatusMap - -> (AsyncFetchMap -> IO a) - -> IO a -asyncDownloadPackages verbosity withRepoCtx installPlan pkgsBuildStatus body - | null pkgsToDownload = body Map.empty - | otherwise = withRepoCtx $ \repoctx -> - asyncFetchPackages verbosity repoctx - pkgsToDownload body - where - pkgsToDownload = - ordNub $ - [ elabPkgSourceLocation elab - | InstallPlan.Configured elab - <- InstallPlan.reverseTopologicalOrder installPlan - , let uid = installedUnitId elab - pkgBuildStatus = Map.findWithDefault (error "asyncDownloadPackages") uid pkgsBuildStatus - , BuildStatusDownload <- [pkgBuildStatus] - ] - - --- | Check if a package needs downloading, and if so expect to find a download --- in progress in the given 'AsyncFetchMap' and wait on it to finish. --- -waitAsyncPackageDownload :: Verbosity - -> AsyncFetchMap - -> ElaboratedConfiguredPackage - -> IO DownloadedSourceLocation -waitAsyncPackageDownload verbosity downloadMap elab = do - pkgloc <- waitAsyncFetchPackage verbosity downloadMap - (elabPkgSourceLocation elab) - case downloadedSourceLocation pkgloc of - Just loc -> return loc - Nothing -> fail "waitAsyncPackageDownload: unexpected source location" - -data DownloadedSourceLocation = DownloadedTarball FilePath - --TODO: [nice to have] git/darcs repos etc - -downloadedSourceLocation :: PackageLocation FilePath - -> Maybe DownloadedSourceLocation -downloadedSourceLocation pkgloc = - case pkgloc of - RemoteTarballPackage _ tarball -> Just (DownloadedTarball tarball) - RepoTarballPackage _ _ tarball -> Just (DownloadedTarball tarball) - _ -> Nothing - - - - --- | Ensure that the package is unpacked in an appropriate directory, either --- a temporary one or a persistent one under the shared dist directory. --- -withTarballLocalDirectory - :: Verbosity - -> DistDirLayout - -> FilePath - -> PackageId - -> DistDirParams - -> BuildStyle - -> Maybe CabalFileText - -> (FilePath -> -- Source directory - FilePath -> -- Build directory - IO a) - -> IO a -withTarballLocalDirectory verbosity distDirLayout@DistDirLayout{..} - tarball pkgid dparams buildstyle pkgTextOverride - buildPkg = - case buildstyle of - -- In this case we make a temp dir (e.g. tmp/src2345/), unpack - -- the tarball to it (e.g. tmp/src2345/foo-1.0/), and for - -- compatibility we put the dist dir within it - -- (i.e. tmp/src2345/foo-1.0/dist/). - -- - -- Unfortunately, a few custom Setup.hs scripts do not respect - -- the --builddir flag and always look for it at ./dist/ so - -- this way we avoid breaking those packages - BuildAndInstall -> - let tmpdir = distTempDirectory in - withTempDirectory verbosity tmpdir "src" $ \unpackdir -> do - unpackPackageTarball verbosity tarball unpackdir - pkgid pkgTextOverride - let srcdir = unpackdir prettyShow pkgid - builddir = srcdir "dist" - buildPkg srcdir builddir - - -- In this case we make sure the tarball has been unpacked to the - -- appropriate location under the shared dist dir, and then build it - -- inplace there - BuildInplaceOnly -> do - let srcrootdir = distUnpackedSrcRootDirectory - srcdir = distUnpackedSrcDirectory pkgid - builddir = distBuildDirectory dparams - -- TODO: [nice to have] use a proper file monitor rather - -- than this dir exists test - exists <- doesDirectoryExist srcdir - unless exists $ do - createDirectoryIfMissingVerbose verbosity True srcrootdir - unpackPackageTarball verbosity tarball srcrootdir - pkgid pkgTextOverride - moveTarballShippedDistDirectory verbosity distDirLayout - srcrootdir pkgid dparams - buildPkg srcdir builddir - - -unpackPackageTarball :: Verbosity -> FilePath -> FilePath - -> PackageId -> Maybe CabalFileText - -> IO () -unpackPackageTarball verbosity tarball parentdir pkgid pkgTextOverride = - --TODO: [nice to have] switch to tar package and catch tar exceptions - annotateFailureNoLog UnpackFailed $ do - - -- Unpack the tarball - -- - info verbosity $ "Extracting " ++ tarball ++ " to " ++ parentdir ++ "..." - Tar.extractTarGzFile parentdir pkgsubdir tarball - - -- Sanity check - -- - exists <- doesFileExist cabalFile - unless exists $ - die' verbosity $ - "Package .cabal file not found in the tarball: " ++ cabalFile - - -- Overwrite the .cabal with the one from the index, when appropriate - -- - case pkgTextOverride of - Nothing -> return () - Just pkgtxt -> do - info verbosity $ "Updating " ++ prettyShow pkgname <.> "cabal" - ++ " with the latest revision from the index." - writeFileAtomic cabalFile pkgtxt - - where - cabalFile = parentdir pkgsubdir - prettyShow pkgname <.> "cabal" - pkgsubdir = prettyShow pkgid - pkgname = packageName pkgid - - --- | This is a bit of a hacky workaround. A number of packages ship --- pre-processed .hs files in a dist directory inside the tarball. We don't --- use the standard 'dist' location so unless we move this dist dir to the --- right place then we'll miss the shipped pre-procssed files. This hacky --- approach to shipped pre-procssed files ought to be replaced by a proper --- system, though we'll still need to keep this hack for older packages. --- -moveTarballShippedDistDirectory :: Verbosity -> DistDirLayout - -> FilePath -> PackageId -> DistDirParams - -> IO () -moveTarballShippedDistDirectory verbosity DistDirLayout{distBuildDirectory} - parentdir pkgid dparams = do - distDirExists <- doesDirectoryExist tarballDistDir - when distDirExists $ do - debug verbosity $ "Moving '" ++ tarballDistDir ++ "' to '" - ++ targetDistDir ++ "'" - --TODO: [nice to have] or perhaps better to copy, and use a file monitor - renameDirectory tarballDistDir targetDistDir - where - tarballDistDir = parentdir prettyShow pkgid "dist" - targetDistDir = distBuildDirectory dparams - - -buildAndInstallUnpackedPackage :: Verbosity - -> DistDirLayout - -> StoreDirLayout - -> BuildTimeSettings -> Lock -> Lock - -> ElaboratedSharedConfig - -> ElaboratedInstallPlan - -> ElaboratedReadyPackage - -> FilePath -> FilePath - -> IO BuildResult -buildAndInstallUnpackedPackage verbosity - distDirLayout@DistDirLayout{distTempDirectory} - storeDirLayout@StoreDirLayout { - storePackageDBStack - } - BuildTimeSettings { - buildSettingNumJobs, - buildSettingLogFile - } - registerLock cacheLock - pkgshared@ElaboratedSharedConfig { - pkgConfigPlatform = platform, - pkgConfigCompiler = compiler, - pkgConfigCompilerProgs = progdb - } - plan rpkg@(ReadyPackage pkg) - srcdir builddir = do - - createDirectoryIfMissingVerbose verbosity True (srcdir builddir) - initLogFile - - --TODO: [code cleanup] deal consistently with talking to older - -- Setup.hs versions, much like we do for ghc, with a proper - -- options type and rendering step which will also let us - -- call directly into the lib, rather than always going via - -- the lib's command line interface, which would also allow - -- passing data like installed packages, compiler, and - -- program db for a quicker configure. - - --TODO: [required feature] docs and tests - --TODO: [required feature] sudo re-exec - - -- Configure phase - noticeProgress ProgressStarting - - annotateFailure mlogFile ConfigureFailed $ - setup' configureCommand configureFlags configureArgs - - -- Build phase - noticeProgress ProgressBuilding - - annotateFailure mlogFile BuildFailed $ - setup buildCommand buildFlags - - -- Haddock phase - whenHaddock $ do - noticeProgress ProgressHaddock - annotateFailureNoLog HaddocksFailed $ - setup haddockCommand haddockFlags - - -- Install phase - noticeProgress ProgressInstalling - annotateFailure mlogFile InstallFailed $ do - - let copyPkgFiles tmpDir = do - let tmpDirNormalised = normalise tmpDir - setup Cabal.copyCommand (copyFlags tmpDirNormalised) - -- Note that the copy command has put the files into - -- @$tmpDir/$prefix@ so we need to return this dir so - -- the store knows which dir will be the final store entry. - let prefix = normalise $ - dropDrive (InstallDirs.prefix (elabInstallDirs pkg)) - entryDir = tmpDirNormalised prefix - - -- if there weren't anything to build, it might be that directory is not created - -- the @setup Cabal.copyCommand@ above might do nothing. - -- https://github.com/haskell/cabal/issues/4130 - createDirectoryIfMissingVerbose verbosity True entryDir - - LBS.writeFile - (entryDir "cabal-hash.txt") - (renderPackageHashInputs (packageHashInputs pkgshared pkg)) - - -- Ensure that there are no files in `tmpDir`, that are - -- not in `entryDir`. While this breaks the - -- prefix-relocatable property of the libraries, it is - -- necessary on macOS to stay under the load command limit - -- of the macOS mach-o linker. See also - -- @PackageHash.hashedInstalledPackageIdVeryShort@. - -- - -- We also normalise paths to ensure that there are no - -- different representations for the same path. Like / and - -- \\ on windows under msys. - otherFiles <- filter (not . isPrefixOf entryDir) <$> - listFilesRecursive tmpDirNormalised - -- Here's where we could keep track of the installed files - -- ourselves if we wanted to by making a manifest of the - -- files in the tmp dir. - return (entryDir, otherFiles) - where - listFilesRecursive :: FilePath -> IO [FilePath] - listFilesRecursive path = do - files <- fmap (path ) <$> (listDirectory path) - allFiles <- for files $ \file -> do - isDir <- doesDirectoryExist file - if isDir - then listFilesRecursive file - else return [file] - return (concat allFiles) - - registerPkg - | not (elabRequiresRegistration pkg) = - debug verbosity $ - "registerPkg: elab does NOT require registration for " - ++ prettyShow uid - | otherwise = do - -- 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 - let ipkg = ipkg0 { Installed.installedUnitId = uid } - assert ( elabRegisterPackageDBStack pkg - == storePackageDBStack compid) (return ()) - criticalSection registerLock $ - Cabal.registerPackage - verbosity compiler progdb - (storePackageDBStack compid) ipkg - Cabal.defaultRegisterOptions { - Cabal.registerMultiInstance = True, - Cabal.registerSuppressFilesCheck = True - } - - - -- Actual installation - void $ newStoreEntry verbosity storeDirLayout - compid uid - copyPkgFiles registerPkg - - --TODO: [nice to have] we currently rely on Setup.hs copy to do the right - -- thing. Although we do copy into an image dir and do the move into the - -- final location ourselves, perhaps we ought to do some sanity checks on - -- the image dir first. - - -- TODO: [required eventually] note that for nix-style - -- installations it is not necessary to do the - -- 'withWin32SelfUpgrade' dance, but it would be necessary for a - -- shared bin dir. - - --TODO: [required feature] docs and test phases - let docsResult = DocsNotTried - testsResult = TestsNotTried - - noticeProgress ProgressCompleted - - return BuildResult { - buildResultDocs = docsResult, - buildResultTests = testsResult, - buildResultLogFile = mlogFile - } - - where - pkgid = packageId rpkg - uid = installedUnitId rpkg - compid = compilerId compiler - - dispname = case elabPkgOrComp pkg of - ElabPackage _ -> prettyShow pkgid - ++ " (all, legacy fallback)" - ElabComponent comp -> prettyShow pkgid - ++ " (" ++ maybe "custom" prettyShow (compComponentName comp) ++ ")" - - noticeProgress phase = when isParallelBuild $ - progressMessage verbosity phase dispname - - isParallelBuild = buildSettingNumJobs >= 2 - - whenHaddock action - | hasValidHaddockTargets pkg = action - | otherwise = return () - - configureCommand = Cabal.configureCommand defaultProgramDb - configureFlags v = flip filterConfigureFlags v $ - setupHsConfigureFlags rpkg pkgshared - verbosity builddir - configureArgs _ = setupHsConfigureArgs pkg - - buildCommand = Cabal.buildCommand defaultProgramDb - buildFlags _ = setupHsBuildFlags pkg pkgshared verbosity builddir - - haddockCommand = Cabal.haddockCommand - haddockFlags _ = setupHsHaddockFlags pkg pkgshared - verbosity builddir - - generateInstalledPackageInfo :: IO InstalledPackageInfo - generateInstalledPackageInfo = - withTempInstalledPackageInfoFile - verbosity distTempDirectory $ \pkgConfDest -> do - let registerFlags _ = setupHsRegisterFlags - pkg pkgshared - verbosity builddir - pkgConfDest - setup Cabal.registerCommand registerFlags - - copyFlags destdir _ = setupHsCopyFlags pkg pkgshared verbosity - builddir destdir - - scriptOptions = setupHsScriptOptions rpkg plan pkgshared - distDirLayout srcdir builddir - isParallelBuild cacheLock - - setup :: CommandUI flags -> (Version -> flags) -> IO () - setup cmd flags = setup' cmd flags (const []) - - setup' :: CommandUI flags -> (Version -> flags) -> (Version -> [String]) - -> IO () - setup' cmd flags args = - withLogging $ \mLogFileHandle -> - setupWrapper - verbosity - scriptOptions - { useLoggingHandle = mLogFileHandle - , useExtraEnvOverrides = dataDirsEnvironmentForPlan - distDirLayout plan } - (Just (elabPkgDescription pkg)) - cmd flags args - - mlogFile :: Maybe FilePath - mlogFile = - case buildSettingLogFile of - Nothing -> Nothing - Just mkLogFile -> Just (mkLogFile compiler platform pkgid uid) - - initLogFile = - case mlogFile of - Nothing -> return () - Just logFile -> do - createDirectoryIfMissing True (takeDirectory logFile) - exists <- doesFileExist logFile - when exists $ removeFile logFile - - withLogging action = - case mlogFile of - Nothing -> action Nothing - Just logFile -> withFile logFile AppendMode (action . Just) - - -hasValidHaddockTargets :: ElaboratedConfiguredPackage -> Bool -hasValidHaddockTargets ElaboratedConfiguredPackage{..} - | not elabBuildHaddocks = False - | otherwise = any componentHasHaddocks components - where - components = elabBuildTargets ++ elabTestTargets ++ elabBenchTargets - ++ maybeToList elabReplTarget ++ elabHaddockTargets - - componentHasHaddocks :: ComponentTarget -> Bool - componentHasHaddocks (ComponentTarget name _) = - case name of - CLibName LMainLibName -> hasHaddocks - CLibName (LSubLibName _) -> elabHaddockInternal && hasHaddocks - CFLibName _ -> elabHaddockForeignLibs && hasHaddocks - CExeName _ -> elabHaddockExecutables && hasHaddocks - CTestName _ -> elabHaddockTestSuites && hasHaddocks - CBenchName _ -> elabHaddockBenchmarks && hasHaddocks - where - hasHaddocks = not (null (elabPkgDescription ^. componentModules name)) - - -buildInplaceUnpackedPackage :: Verbosity - -> DistDirLayout - -> BuildTimeSettings -> Lock -> Lock - -> ElaboratedSharedConfig - -> ElaboratedInstallPlan - -> ElaboratedReadyPackage - -> BuildStatusRebuild - -> FilePath -> FilePath - -> IO BuildResult -buildInplaceUnpackedPackage verbosity - distDirLayout@DistDirLayout { - distTempDirectory, - distPackageCacheDirectory, - distDirectory - } - BuildTimeSettings{buildSettingNumJobs} - registerLock cacheLock - pkgshared@ElaboratedSharedConfig { - pkgConfigCompiler = compiler, - pkgConfigCompilerProgs = progdb - } - plan - rpkg@(ReadyPackage pkg) - buildStatus - srcdir builddir = do - - --TODO: [code cleanup] there is duplication between the - -- distdirlayout and the builddir here builddir is not - -- enough, we also need the per-package cachedir - createDirectoryIfMissingVerbose verbosity True builddir - createDirectoryIfMissingVerbose verbosity True - (distPackageCacheDirectory dparams) - - -- Configure phase - -- - whenReConfigure $ do - annotateFailureNoLog ConfigureFailed $ - setup configureCommand configureFlags configureArgs - invalidatePackageRegFileMonitor packageFileMonitor - updatePackageConfigFileMonitor packageFileMonitor srcdir pkg - - -- Build phase - -- - let docsResult = DocsNotTried - testsResult = TestsNotTried - - buildResult :: BuildResultMisc - buildResult = (docsResult, testsResult) - - whenRebuild $ do - timestamp <- beginUpdateFileMonitor - annotateFailureNoLog BuildFailed $ - setup buildCommand buildFlags buildArgs - - let listSimple = - execRebuild srcdir (needElaboratedConfiguredPackage pkg) - listSdist = - fmap (map monitorFileHashed) $ - allPackageSourceFiles verbosity 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 srcdir timestamp - pkg buildStatus - (monitors ++ dep_monitors) buildResult - - -- PURPOSELY omitted: no copy! - - whenReRegister $ annotateFailureNoLog InstallFailed $ do - -- Register locally - mipkg <- if elabRequiresRegistration pkg - then do - ipkg0 <- generateInstalledPackageInfo - -- 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. - let ipkg = ipkg0 { Installed.installedUnitId = ipkgid } - criticalSection registerLock $ - Cabal.registerPackage verbosity compiler progdb - (elabRegisterPackageDBStack pkg) - ipkg Cabal.defaultRegisterOptions - return (Just ipkg) - - else return Nothing - - updatePackageRegFileMonitor packageFileMonitor srcdir mipkg - - whenTest $ do - annotateFailureNoLog TestsFailed $ - setup testCommand testFlags testArgs - - whenBench $ - annotateFailureNoLog BenchFailed $ - setup benchCommand benchFlags benchArgs - - -- Repl phase - -- - whenRepl $ - annotateFailureNoLog ReplFailed $ - setupInteractive replCommand replFlags replArgs - - -- Haddock phase - whenHaddock $ - annotateFailureNoLog HaddocksFailed $ do - setup haddockCommand haddockFlags haddockArgs - let haddockTarget = elabHaddockForHackage pkg - when (haddockTarget == Cabal.ForHackage) $ do - let dest = distDirectory name <.> "tar.gz" - name = haddockDirName haddockTarget (elabPkgDescription pkg) - docDir = distBuildDirectory distDirLayout dparams - "doc" "html" - Tar.createTarGzFile dest docDir name - notice verbosity $ "Documentation tarball created: " ++ dest - - return BuildResult { - buildResultDocs = docsResult, - buildResultTests = testsResult, - buildResultLogFile = Nothing - } - - where - ipkgid = installedUnitId pkg - dparams = elabDistDirParams pkgshared pkg - - isParallelBuild = buildSettingNumJobs >= 2 - - packageFileMonitor = newPackageFileMonitor pkgshared distDirLayout dparams - - whenReConfigure action = case buildStatus of - BuildStatusConfigure _ -> action - _ -> return () - - whenRebuild action - | null (elabBuildTargets pkg) - -- NB: we have to build the test/bench suite! - , null (elabTestTargets pkg) - , null (elabBenchTargets pkg) = return () - | otherwise = action - - whenTest action - | null (elabTestTargets pkg) = return () - | otherwise = action - - whenBench action - | null (elabBenchTargets pkg) = return () - | otherwise = action - - whenRepl action - | isNothing (elabReplTarget pkg) = return () - | otherwise = action - - whenHaddock action - | hasValidHaddockTargets pkg = action - | otherwise = return () - - whenReRegister action - = case buildStatus of - -- We registered the package already - BuildStatusBuild (Just _) _ -> - info verbosity "whenReRegister: previously registered" - -- There is nothing to register - _ | null (elabBuildTargets pkg) -> - info verbosity "whenReRegister: nothing to register" - | otherwise -> action - - configureCommand = Cabal.configureCommand defaultProgramDb - configureFlags v = flip filterConfigureFlags v $ - setupHsConfigureFlags rpkg pkgshared - verbosity builddir - configureArgs _ = setupHsConfigureArgs pkg - - buildCommand = Cabal.buildCommand defaultProgramDb - buildFlags _ = setupHsBuildFlags pkg pkgshared - verbosity builddir - buildArgs _ = setupHsBuildArgs pkg - - testCommand = Cabal.testCommand -- defaultProgramDb - testFlags v = flip filterTestFlags v $ - setupHsTestFlags pkg pkgshared - verbosity builddir - testArgs _ = setupHsTestArgs pkg - - benchCommand = Cabal.benchmarkCommand - benchFlags _ = setupHsBenchFlags pkg pkgshared - verbosity builddir - benchArgs _ = setupHsBenchArgs pkg - - replCommand = Cabal.replCommand defaultProgramDb - replFlags _ = setupHsReplFlags pkg pkgshared - verbosity builddir - replArgs _ = setupHsReplArgs pkg - - haddockCommand = Cabal.haddockCommand - haddockFlags v = flip filterHaddockFlags v $ - setupHsHaddockFlags pkg pkgshared - verbosity builddir - haddockArgs v = flip filterHaddockArgs v $ - setupHsHaddockArgs pkg - - scriptOptions = setupHsScriptOptions rpkg plan pkgshared - distDirLayout srcdir builddir - isParallelBuild cacheLock - - setupInteractive :: CommandUI flags - -> (Version -> flags) -> (Version -> [String]) -> IO () - setupInteractive cmd flags args = - setupWrapper verbosity - scriptOptions { isInteractive = True } - (Just (elabPkgDescription pkg)) - cmd flags args - - setup :: CommandUI flags -> (Version -> flags) -> (Version -> [String]) - -> IO () - setup cmd flags args = - setupWrapper verbosity - scriptOptions - (Just (elabPkgDescription pkg)) - cmd flags args - - generateInstalledPackageInfo :: IO InstalledPackageInfo - generateInstalledPackageInfo = - withTempInstalledPackageInfoFile - verbosity distTempDirectory $ \pkgConfDest -> do - let registerFlags _ = setupHsRegisterFlags - pkg pkgshared - verbosity builddir - pkgConfDest - setup Cabal.registerCommand registerFlags (const []) - -withTempInstalledPackageInfoFile :: Verbosity -> FilePath - -> (FilePath -> IO ()) - -> IO InstalledPackageInfo -withTempInstalledPackageInfoFile verbosity tempdir action = - withTempDirectory verbosity tempdir "package-registration-" $ \dir -> do - -- make absolute since @action@ will often change directory - abs_dir <- canonicalizePath dir - - let pkgConfDest = abs_dir "pkgConf" - action pkgConfDest - - readPkgConf "." pkgConfDest - where - pkgConfParseFailed :: String -> IO a - pkgConfParseFailed perror = - die' verbosity $ - "Couldn't parse the output of 'setup register --gen-pkg-config':" - ++ show perror - - readPkgConf pkgConfDir pkgConfFile = do - pkgConfStr <- BS.readFile (pkgConfDir pkgConfFile) - (warns, ipkg) <- case Installed.parseInstalledPackageInfo pkgConfStr of - Left perrors -> pkgConfParseFailed $ unlines $ NE.toList perrors - Right (warns, ipkg) -> return (warns, ipkg) - - unless (null warns) $ - warn verbosity $ unlines warns - - return ipkg - - ------------------------------------------------------------------------------- --- * Utilities ------------------------------------------------------------------------------- - -annotateFailureNoLog :: (SomeException -> BuildFailureReason) - -> IO a -> IO a -annotateFailureNoLog annotate action = - annotateFailure Nothing annotate action - -annotateFailure :: Maybe FilePath - -> (SomeException -> BuildFailureReason) - -> IO a -> IO a -annotateFailure mlogFile annotate action = - action `catches` - -- It's not just IOException and ExitCode we have to deal with, there's - -- lots, including exceptions from the hackage-security and tar packages. - -- So we take the strategy of catching everything except async exceptions. - [ -#if MIN_VERSION_base(4,7,0) - Handler $ \async -> throwIO (async :: SomeAsyncException) -#else - Handler $ \async -> throwIO (async :: AsyncException) -#endif - , Handler $ \other -> handler (other :: SomeException) - ] - where - handler :: Exception e => e -> IO a - handler = throwIO . BuildFailure mlogFile . annotate . toException diff --git a/cabal/cabal-install/Distribution/Client/ProjectBuilding/Types.hs b/cabal/cabal-install/Distribution/Client/ProjectBuilding/Types.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/ProjectBuilding/Types.hs +++ /dev/null @@ -1,204 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} - --- | Types for the "Distribution.Client.ProjectBuilding" --- --- Moved out to avoid module cycles. --- -module Distribution.Client.ProjectBuilding.Types ( - -- * Pre-build status - BuildStatusMap, - BuildStatus(..), - buildStatusRequiresBuild, - buildStatusToString, - BuildStatusRebuild(..), - BuildReason(..), - MonitorChangedReason(..), - - -- * Build outcomes - BuildOutcomes, - BuildOutcome, - BuildResult(..), - BuildFailure(..), - BuildFailureReason(..), - ) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Client.Types (DocsResult, TestsResult) -import Distribution.Client.FileMonitor (MonitorChangedReason(..)) - -import Distribution.Package (UnitId, PackageId) -import Distribution.InstalledPackageInfo (InstalledPackageInfo) -import Distribution.Simple.LocalBuildInfo (ComponentName) - - ------------------------------------------------------------------------------- --- Pre-build status: result of the dry run --- - --- | 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 - --- | The build status for an individual package is the state that the --- package is in /prior/ to initiating a (re)build. --- --- This should not be confused with a 'BuildResult' which is the result --- /after/ successfully building a package. --- --- It serves two purposes: --- --- * For dry-run output, it lets us explain to the user if and why a package --- is going to be (re)built. --- --- * It tell us what step to start or resume building from, and carries --- enough information for us to be able to do so. --- -data BuildStatus = - - -- | The package is in the 'InstallPlan.PreExisting' state, so does not - -- need building. - BuildStatusPreExisting - - -- | The package is in the 'InstallPlan.Installed' state, so does not - -- need building. - | BuildStatusInstalled - - -- | The package has not been downloaded yet, so it will have to be - -- downloaded, unpacked and built. - | BuildStatusDownload - - -- | The package has not been unpacked yet, so it will have to be - -- unpacked and built. - | BuildStatusUnpack FilePath - - -- | The package exists in a local dir already, and just needs building - -- or rebuilding. So this can only happen for 'BuildInplaceOnly' style - -- packages. - | BuildStatusRebuild FilePath BuildStatusRebuild - - -- | The package exists in a local dir already, and is fully up to date. - -- So this package can be put into the 'InstallPlan.Installed' state - -- and it does not need to be built. - | BuildStatusUpToDate BuildResult - - --- | Which 'BuildStatus' values indicate we'll have to do some build work of --- some sort. In particular we use this as part of checking if any of a --- package's deps have changed. --- -buildStatusRequiresBuild :: BuildStatus -> Bool -buildStatusRequiresBuild BuildStatusPreExisting = False -buildStatusRequiresBuild BuildStatusInstalled = False -buildStatusRequiresBuild BuildStatusUpToDate {} = False -buildStatusRequiresBuild _ = True - --- | This is primarily here for debugging. It's not actually used anywhere. --- -buildStatusToString :: BuildStatus -> String -buildStatusToString BuildStatusPreExisting = "BuildStatusPreExisting" -buildStatusToString BuildStatusInstalled = "BuildStatusInstalled" -buildStatusToString BuildStatusDownload = "BuildStatusDownload" -buildStatusToString (BuildStatusUnpack fp) = "BuildStatusUnpack " ++ show fp -buildStatusToString (BuildStatusRebuild fp _) = "BuildStatusRebuild " ++ show fp -buildStatusToString (BuildStatusUpToDate _) = "BuildStatusUpToDate" - - --- | For a package that is going to be built or rebuilt, the state it's in now. --- --- So again, this tells us why a package needs to be rebuilt and what build --- phases need to be run. The 'MonitorChangedReason' gives us details like --- which file changed, which is mainly for high verbosity debug output. --- -data BuildStatusRebuild = - - -- | The package configuration changed, so the configure and build phases - -- needs to be (re)run. - BuildStatusConfigure (MonitorChangedReason ()) - - -- | The configuration has not changed but the build phase needs to be - -- rerun. We record the reason the (re)build is needed. - -- - -- The optional registration info here tells us if we've registered the - -- package already, or if we still need to do that after building. - -- @Just Nothing@ indicates that we know that no registration is - -- necessary (e.g., executable.) - -- - | BuildStatusBuild (Maybe (Maybe InstalledPackageInfo)) BuildReason - -data BuildReason = - -- | The dependencies of this package have been (re)built so the build - -- phase needs to be rerun. - -- - BuildReasonDepsRebuilt - - -- | Changes in files within the package (or first run or corrupt cache) - | BuildReasonFilesChanged (MonitorChangedReason ()) - - -- | An important special case is that no files have changed but the - -- set of components the /user asked to build/ has changed. We track the - -- set of components /we have built/, which of course only grows (until - -- some other change resets it). - -- - -- The @Set 'ComponentName'@ is the set of components we have built - -- previously. When we update the monitor we take the union of the ones - -- we have built previously with the ones the user has asked for this - -- time and save those. See 'updatePackageBuildFileMonitor'. - -- - | BuildReasonExtraTargets (Set ComponentName) - - -- | Although we're not going to build any additional targets as a whole, - -- we're going to build some part of a component or run a repl or any - -- other action that does not result in additional persistent artifacts. - -- - | BuildReasonEphemeralTargets - - ------------------------------------------------------------------------------- --- Build outcomes: result of the build --- - --- | A summary of the outcome for building a whole set of packages. --- -type BuildOutcomes = Map UnitId BuildOutcome - --- | A summary of the outcome for building a single package: either success --- or failure. --- -type BuildOutcome = Either BuildFailure BuildResult - --- | Information arising from successfully building a single package. --- -data BuildResult = BuildResult { - buildResultDocs :: DocsResult, - buildResultTests :: TestsResult, - buildResultLogFile :: Maybe FilePath - } - deriving Show - --- | Information arising from the failure to build a single package. --- -data BuildFailure = BuildFailure { - buildFailureLogFile :: Maybe FilePath, - buildFailureReason :: BuildFailureReason - } - deriving (Show, Typeable) - -instance Exception BuildFailure - --- | Detail on the reason that a package failed to build. --- -data BuildFailureReason = DependentFailed PackageId - | DownloadFailed SomeException - | UnpackFailed SomeException - | ConfigureFailed SomeException - | BuildFailed SomeException - | ReplFailed SomeException - | HaddocksFailed SomeException - | TestsFailed SomeException - | BenchFailed SomeException - | InstallFailed SomeException - deriving Show diff --git a/cabal/cabal-install/Distribution/Client/ProjectConfig.hs b/cabal/cabal-install/Distribution/Client/ProjectConfig.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/ProjectConfig.hs +++ /dev/null @@ -1,1464 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} - --- | Handling project configuration. --- -module Distribution.Client.ProjectConfig ( - - -- * Types for project config - ProjectConfig(..), - ProjectConfigBuildOnly(..), - ProjectConfigShared(..), - ProjectConfigProvenance(..), - PackageConfig(..), - MapLast(..), - MapMappend(..), - - -- * Project root - findProjectRoot, - ProjectRoot(..), - BadProjectRoot(..), - - -- * Project config files - readProjectConfig, - readGlobalConfig, - readProjectLocalFreezeConfig, - withProjectOrGlobalConfig, - writeProjectLocalExtraConfig, - writeProjectLocalFreezeConfig, - writeProjectConfigFile, - commandLineFlagsToProjectConfig, - - -- * Packages within projects - ProjectPackageLocation(..), - BadPackageLocations(..), - BadPackageLocation(..), - BadPackageLocationMatch(..), - findProjectPackages, - fetchAndReadSourcePackages, - - -- * Resolving configuration - lookupLocalPackageConfig, - projectConfigWithBuilderRepoContext, - projectConfigWithSolverRepoContext, - SolverSettings(..), - resolveSolverSettings, - BuildTimeSettings(..), - resolveBuildTimeSettings, - - -- * Checking configuration - checkBadPerPackageCompilerPaths, - BadPerPackageCompilerPaths(..) - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude - -import Distribution.Client.ProjectConfig.Types -import Distribution.Client.ProjectConfig.Legacy -import Distribution.Client.RebuildMonad -import Distribution.Client.Glob - ( isTrivialFilePathGlob ) -import Distribution.Client.VCS - ( validateSourceRepos, SourceRepoProblem(..) - , VCS(..), knownVCSs, configureVCS, syncSourceRepos ) - -import Distribution.Client.Types -import Distribution.Client.DistDirLayout - ( DistDirLayout(..), CabalDirLayout(..), ProjectRoot(..) ) -import Distribution.Client.GlobalFlags - ( RepoContext(..), withRepoContext' ) -import Distribution.Client.BuildReports.Types - ( ReportLevel(..) ) -import Distribution.Client.Config - ( loadConfig, getConfigFilePath ) -import Distribution.Client.HttpUtils - ( HttpTransport, configureTransport, transportCheckHttps - , downloadURI ) -import Distribution.Client.Utils.Parsec (renderParseError) - -import Distribution.Solver.Types.SourcePackage -import Distribution.Solver.Types.Settings -import Distribution.Solver.Types.PackageConstraint - ( PackageProperty(..) ) - -import Distribution.Package - ( PackageName, PackageId, UnitId, packageId ) -import Distribution.Types.PackageVersionConstraint - ( PackageVersionConstraint(..) ) -import Distribution.System - ( Platform ) -import Distribution.Types.GenericPackageDescription - ( GenericPackageDescription ) -import Distribution.PackageDescription.Parsec - ( parseGenericPackageDescription ) -import Distribution.Fields - ( runParseResult, PError, PWarning, showPWarning) -import Distribution.Types.SourceRepo - ( RepoType(..) ) -import Distribution.Client.Types.SourceRepo - ( SourceRepoList, SourceRepositoryPackage (..), srpFanOut ) -import Distribution.Simple.Compiler - ( Compiler, compilerInfo ) -import Distribution.Simple.Program - ( ConfiguredProgram(..) ) -import Distribution.Simple.Setup - ( Flag(Flag), toFlag, flagToMaybe, flagToList - , fromFlag, fromFlagOrDefault ) -import Distribution.Client.Setup - ( defaultSolver, defaultMaxBackjumps ) -import Distribution.Simple.InstallDirs - ( PathTemplate, fromPathTemplate - , toPathTemplate, substPathTemplate, initialPathTemplateEnv ) -import Distribution.Simple.Utils - ( die', warn, notice, info, createDirectoryIfMissingVerbose ) -import Distribution.Client.Utils - ( determineNumJobs ) -import Distribution.Utils.NubList - ( fromNubList ) -import Distribution.Verbosity - ( modifyVerbosity, verbose ) -import Distribution.Version - ( Version ) -import qualified Distribution.Deprecated.ParseUtils as OldParser - ( ParseResult(..), locatedErrorMsg, showPWarning ) -import Distribution.Client.SrcDist - ( packageDirToSdist ) - -import qualified Codec.Archive.Tar as Tar -import qualified Codec.Archive.Tar.Entry as Tar -import qualified Distribution.Client.Tar as Tar -import qualified Distribution.Client.GZipUtils as GZipUtils - -import Control.Monad.Trans (liftIO) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LBS -import qualified Data.Map as Map -import qualified Data.List.NonEmpty as NE -import qualified Data.Set as Set -import qualified Data.Hashable as Hashable -import Numeric (showHex) - -import System.FilePath hiding (combine) -import System.IO - ( withBinaryFile, IOMode(ReadMode) ) -import System.Directory -import Network.URI - ( URI(..), URIAuth(..), parseAbsoluteURI, uriToString ) - - ----------------------------------------- --- Resolving configuration to settings --- - --- | Look up a 'PackageConfig' field in the 'ProjectConfig' for a specific --- 'PackageName'. This returns the configuration that applies to all local --- packages plus any package-specific configuration for this package. --- -lookupLocalPackageConfig - :: (Semigroup a, Monoid a) - => (PackageConfig -> a) -> ProjectConfig -> PackageName - -> a -lookupLocalPackageConfig field ProjectConfig { - projectConfigLocalPackages, - projectConfigSpecificPackage - } pkgname = - field projectConfigLocalPackages - <> maybe mempty field - (Map.lookup pkgname (getMapMappend projectConfigSpecificPackage)) - - --- | Use a 'RepoContext' based on the 'BuildTimeSettings'. --- -projectConfigWithBuilderRepoContext :: Verbosity - -> BuildTimeSettings - -> (RepoContext -> IO a) -> IO a -projectConfigWithBuilderRepoContext verbosity BuildTimeSettings{..} = - withRepoContext' - verbosity - buildSettingRemoteRepos - buildSettingLocalNoIndexRepos - buildSettingCacheDir - buildSettingHttpTransport - (Just buildSettingIgnoreExpiry) - buildSettingProgPathExtra - - --- | Use a 'RepoContext', but only for the solver. The solver does not use the --- full facilities of the 'RepoContext' so we can get away with making one --- that doesn't have an http transport. And that avoids having to have access --- to the 'BuildTimeSettings' --- -projectConfigWithSolverRepoContext - :: Verbosity -> ProjectConfigShared -> ProjectConfigBuildOnly - -> (RepoContext -> IO a) - -> IO a -projectConfigWithSolverRepoContext verbosity - ProjectConfigShared{..} - ProjectConfigBuildOnly{..} = - withRepoContext' - verbosity - (fromNubList projectConfigRemoteRepos) - (fromNubList projectConfigLocalNoIndexRepos) - (fromFlagOrDefault - (error - "projectConfigWithSolverRepoContext: projectConfigCacheDir") - projectConfigCacheDir) - (flagToMaybe projectConfigHttpTransport) - (flagToMaybe projectConfigIgnoreExpiry) - (fromNubList projectConfigProgPathExtra) - - --- | Resolve the project configuration, with all its optional fields, into --- 'SolverSettings' with no optional fields (by applying defaults). --- -resolveSolverSettings :: ProjectConfig -> SolverSettings -resolveSolverSettings ProjectConfig{ - projectConfigShared, - projectConfigLocalPackages, - projectConfigSpecificPackage - } = - SolverSettings {..} - where - --TODO: [required eventually] some of these settings need validation, e.g. - -- the flag assignments need checking. - solverSettingRemoteRepos = fromNubList projectConfigRemoteRepos - solverSettingLocalNoIndexRepos = fromNubList projectConfigLocalNoIndexRepos - solverSettingConstraints = projectConfigConstraints - solverSettingPreferences = projectConfigPreferences - solverSettingFlagAssignment = packageConfigFlagAssignment projectConfigLocalPackages - solverSettingFlagAssignments = fmap packageConfigFlagAssignment - (getMapMappend projectConfigSpecificPackage) - solverSettingCabalVersion = flagToMaybe projectConfigCabalVersion - solverSettingSolver = fromFlag projectConfigSolver - solverSettingAllowOlder = fromMaybe mempty projectConfigAllowOlder - solverSettingAllowNewer = fromMaybe mempty projectConfigAllowNewer - solverSettingMaxBackjumps = case fromFlag projectConfigMaxBackjumps of - n | n < 0 -> Nothing - | otherwise -> Just n - solverSettingReorderGoals = fromFlag projectConfigReorderGoals - solverSettingCountConflicts = fromFlag projectConfigCountConflicts - solverSettingFineGrainedConflicts = fromFlag projectConfigFineGrainedConflicts - solverSettingMinimizeConflictSet = fromFlag projectConfigMinimizeConflictSet - solverSettingStrongFlags = fromFlag projectConfigStrongFlags - solverSettingAllowBootLibInstalls = fromFlag projectConfigAllowBootLibInstalls - solverSettingOnlyConstrained = fromFlag projectConfigOnlyConstrained - solverSettingIndexState = flagToMaybe projectConfigIndexState - solverSettingActiveRepos = flagToMaybe projectConfigActiveRepos - solverSettingIndependentGoals = fromFlag projectConfigIndependentGoals - --solverSettingShadowPkgs = fromFlag projectConfigShadowPkgs - --solverSettingReinstall = fromFlag projectConfigReinstall - --solverSettingAvoidReinstalls = fromFlag projectConfigAvoidReinstalls - --solverSettingOverrideReinstall = fromFlag projectConfigOverrideReinstall - --solverSettingUpgradeDeps = fromFlag projectConfigUpgradeDeps - - ProjectConfigShared {..} = defaults <> projectConfigShared - - defaults = mempty { - projectConfigSolver = Flag defaultSolver, - projectConfigAllowOlder = Just (AllowOlder mempty), - projectConfigAllowNewer = Just (AllowNewer mempty), - projectConfigMaxBackjumps = Flag defaultMaxBackjumps, - projectConfigReorderGoals = Flag (ReorderGoals False), - projectConfigCountConflicts = Flag (CountConflicts True), - projectConfigFineGrainedConflicts = Flag (FineGrainedConflicts True), - projectConfigMinimizeConflictSet = Flag (MinimizeConflictSet False), - projectConfigStrongFlags = Flag (StrongFlags False), - projectConfigAllowBootLibInstalls = Flag (AllowBootLibInstalls False), - projectConfigOnlyConstrained = Flag OnlyConstrainedNone, - projectConfigIndependentGoals = Flag (IndependentGoals False) - --projectConfigShadowPkgs = Flag False, - --projectConfigReinstall = Flag False, - --projectConfigAvoidReinstalls = Flag False, - --projectConfigOverrideReinstall = Flag False, - --projectConfigUpgradeDeps = Flag False - } - - --- | Resolve the project configuration, with all its optional fields, into --- 'BuildTimeSettings' with no optional fields (by applying defaults). --- -resolveBuildTimeSettings :: Verbosity - -> CabalDirLayout - -> ProjectConfig - -> BuildTimeSettings -resolveBuildTimeSettings verbosity - CabalDirLayout { - cabalLogsDirectory - } - ProjectConfig { - projectConfigShared = ProjectConfigShared { - projectConfigRemoteRepos, - projectConfigLocalNoIndexRepos, - projectConfigProgPathExtra - }, - projectConfigBuildOnly - } = - BuildTimeSettings {..} - where - buildSettingDryRun = fromFlag projectConfigDryRun - buildSettingOnlyDeps = fromFlag projectConfigOnlyDeps - buildSettingSummaryFile = fromNubList projectConfigSummaryFile - --buildSettingLogFile -- defined below, more complicated - --buildSettingLogVerbosity -- defined below, more complicated - buildSettingBuildReports = fromFlag projectConfigBuildReports - buildSettingSymlinkBinDir = flagToList projectConfigSymlinkBinDir - buildSettingOneShot = fromFlag projectConfigOneShot - buildSettingNumJobs = determineNumJobs projectConfigNumJobs - buildSettingKeepGoing = fromFlag projectConfigKeepGoing - buildSettingOfflineMode = fromFlag projectConfigOfflineMode - buildSettingKeepTempFiles = fromFlag projectConfigKeepTempFiles - buildSettingRemoteRepos = fromNubList projectConfigRemoteRepos - buildSettingLocalNoIndexRepos = fromNubList projectConfigLocalNoIndexRepos - buildSettingCacheDir = fromFlag projectConfigCacheDir - buildSettingHttpTransport = flagToMaybe projectConfigHttpTransport - buildSettingIgnoreExpiry = fromFlag projectConfigIgnoreExpiry - buildSettingReportPlanningFailure - = fromFlag projectConfigReportPlanningFailure - buildSettingProgPathExtra = fromNubList projectConfigProgPathExtra - - ProjectConfigBuildOnly{..} = defaults - <> projectConfigBuildOnly - - defaults = mempty { - projectConfigDryRun = toFlag False, - projectConfigOnlyDeps = toFlag False, - projectConfigBuildReports = toFlag NoReports, - projectConfigReportPlanningFailure = toFlag False, - projectConfigKeepGoing = toFlag False, - projectConfigOneShot = toFlag False, - projectConfigOfflineMode = toFlag False, - projectConfigKeepTempFiles = toFlag False, - projectConfigIgnoreExpiry = toFlag False - } - - -- The logging logic: what log file to use and what verbosity. - -- - -- If the user has specified --remote-build-reporting=detailed, use the - -- default log file location. If the --build-log option is set, use the - -- provided location. Otherwise don't use logging, unless building in - -- parallel (in which case the default location is used). - -- - buildSettingLogFile :: Maybe (Compiler -> Platform - -> PackageId -> UnitId -> FilePath) - buildSettingLogFile - | useDefaultTemplate = Just (substLogFileName defaultTemplate) - | otherwise = fmap substLogFileName givenTemplate - - defaultTemplate = toPathTemplate $ - cabalLogsDirectory - "$compiler" "$libname" <.> "log" - givenTemplate = flagToMaybe projectConfigLogFile - - useDefaultTemplate - | buildSettingBuildReports == DetailedReports = True - | isJust givenTemplate = False - | isParallelBuild = True - | otherwise = False - - isParallelBuild = buildSettingNumJobs >= 2 - - substLogFileName :: PathTemplate - -> Compiler -> Platform - -> PackageId -> UnitId -> FilePath - substLogFileName template compiler platform pkgid uid = - fromPathTemplate (substPathTemplate env template) - where - env = initialPathTemplateEnv - pkgid uid (compilerInfo compiler) platform - - -- If the user has specified --remote-build-reporting=detailed or - -- --build-log, use more verbose logging. - -- - buildSettingLogVerbosity - | overrideVerbosity = modifyVerbosity (max verbose) verbosity - | otherwise = verbosity - - overrideVerbosity - | buildSettingBuildReports == DetailedReports = True - | isJust givenTemplate = True - | isParallelBuild = False - | otherwise = False - - ---------------------------------------------- --- Reading and writing project config files --- - --- | Find the root of this project. --- --- Searches for an explicit @cabal.project@ file, in the current directory or --- parent directories. If no project file is found then the current dir is the --- project root (and the project will use an implicit config). --- -findProjectRoot :: Maybe FilePath -- ^ starting directory, or current directory - -> Maybe FilePath -- ^ @cabal.project@ file name override - -> IO (Either BadProjectRoot ProjectRoot) -findProjectRoot _ (Just projectFile) - | isAbsolute projectFile = do - exists <- doesFileExist projectFile - if exists - then do projectFile' <- canonicalizePath projectFile - let projectRoot = ProjectRootExplicit (takeDirectory projectFile') - (takeFileName projectFile') - return (Right projectRoot) - else return (Left (BadProjectRootExplicitFile projectFile)) - -findProjectRoot mstartdir mprojectFile = do - startdir <- maybe getCurrentDirectory canonicalizePath mstartdir - homedir <- getHomeDirectory - probe startdir homedir - where - projectFileName = fromMaybe "cabal.project" mprojectFile - - -- Search upwards. If we get to the users home dir or the filesystem root, - -- then use the current dir - probe startdir homedir = go startdir - where - go dir | isDrive dir || dir == homedir = - case mprojectFile of - Nothing -> return (Right (ProjectRootImplicit startdir)) - Just file -> return (Left (BadProjectRootExplicitFile file)) - go dir = do - exists <- doesFileExist (dir projectFileName) - if exists - then return (Right (ProjectRootExplicit dir projectFileName)) - else go (takeDirectory dir) - --- | Errors returned by 'findProjectRoot'. --- -data BadProjectRoot = BadProjectRootExplicitFile FilePath -#if MIN_VERSION_base(4,8,0) - deriving (Show, Typeable) -#else - deriving (Typeable) - -instance Show BadProjectRoot where - show = renderBadProjectRoot -#endif - -instance Exception BadProjectRoot where -#if MIN_VERSION_base(4,8,0) - displayException = renderBadProjectRoot -#endif - -renderBadProjectRoot :: BadProjectRoot -> String -renderBadProjectRoot (BadProjectRootExplicitFile projectFile) = - "The given project file '" ++ projectFile ++ "' does not exist." - -withProjectOrGlobalConfig - :: Verbosity -- ^ verbosity - -> Flag Bool -- ^ whether to ignore local project - -> Flag FilePath -- ^ @--cabal-config@ - -> IO a -- ^ with project - -> (ProjectConfig -> IO a) -- ^ without projet - -> IO a -withProjectOrGlobalConfig verbosity (Flag True) gcf _with without = do - globalConfig <- runRebuild "" $ readGlobalConfig verbosity gcf - without globalConfig -withProjectOrGlobalConfig verbosity _ignorePrj gcf with without = - withProjectOrGlobalConfig' verbosity gcf with without - -withProjectOrGlobalConfig' - :: Verbosity - -> Flag FilePath - -> IO a - -> (ProjectConfig -> IO a) - -> IO a -withProjectOrGlobalConfig' verbosity globalConfigFlag with without = do - globalConfig <- runRebuild "" $ readGlobalConfig verbosity globalConfigFlag - - let - res' = catch with - $ \case - (BadPackageLocations prov locs) - | prov == Set.singleton Implicit - , let - isGlobErr (BadLocGlobEmptyMatch _) = True - isGlobErr _ = False - , any isGlobErr locs -> - without globalConfig - err -> throwIO err - - catch res' - $ \case - (BadProjectRootExplicitFile "") -> without globalConfig - err -> throwIO err - --- | Read all the config relevant for a project. This includes the project --- file if any, plus other global config. --- -readProjectConfig :: Verbosity - -> Flag FilePath - -> DistDirLayout - -> Rebuild ProjectConfig -readProjectConfig verbosity configFileFlag distDirLayout = do - global <- readGlobalConfig verbosity configFileFlag - local <- readProjectLocalConfigOrDefault verbosity distDirLayout - freeze <- readProjectLocalFreezeConfig verbosity distDirLayout - extra <- readProjectLocalExtraConfig verbosity distDirLayout - return (global <> local <> freeze <> extra) - - --- | Reads an explicit @cabal.project@ file in the given project root dir, --- or returns the default project config for an implicitly defined project. --- -readProjectLocalConfigOrDefault :: Verbosity - -> DistDirLayout - -> Rebuild ProjectConfig -readProjectLocalConfigOrDefault verbosity distDirLayout = do - usesExplicitProjectRoot <- liftIO $ doesFileExist projectFile - if usesExplicitProjectRoot - then do - readProjectFile verbosity distDirLayout "" "project file" - else do - monitorFiles [monitorNonExistentFile projectFile] - return defaultImplicitProjectConfig - - where - projectFile = distProjectFile distDirLayout "" - - defaultImplicitProjectConfig :: ProjectConfig - defaultImplicitProjectConfig = - mempty { - -- We expect a package in the current directory. - projectPackages = [ "./*.cabal" ], - - projectConfigProvenance = Set.singleton Implicit - } - --- | Reads a @cabal.project.local@ file in the given project root dir, --- or returns empty. This file gets written by @cabal configure@, or in --- principle can be edited manually or by other tools. --- -readProjectLocalExtraConfig :: Verbosity -> DistDirLayout - -> Rebuild ProjectConfig -readProjectLocalExtraConfig verbosity distDirLayout = - readProjectFile verbosity distDirLayout "local" - "project local configuration file" - --- | Reads a @cabal.project.freeze@ file in the given project root dir, --- or returns empty. This file gets written by @cabal freeze@, or in --- principle can be edited manually or by other tools. --- -readProjectLocalFreezeConfig :: Verbosity -> DistDirLayout - -> Rebuild ProjectConfig -readProjectLocalFreezeConfig verbosity distDirLayout = - readProjectFile verbosity distDirLayout "freeze" - "project freeze file" - --- | Reads a named config file in the given project root dir, or returns empty. --- -readProjectFile :: Verbosity - -> DistDirLayout - -> String - -> String - -> Rebuild ProjectConfig -readProjectFile verbosity DistDirLayout{distProjectFile} - extensionName extensionDescription = do - exists <- liftIO $ doesFileExist extensionFile - if exists - then do monitorFiles [monitorFileHashed extensionFile] - addProjectFileProvenance <$> liftIO readExtensionFile - else do monitorFiles [monitorNonExistentFile extensionFile] - return mempty - where - extensionFile = distProjectFile extensionName - - readExtensionFile = - reportParseResult verbosity extensionDescription extensionFile - . parseProjectConfig - =<< readFile extensionFile - - addProjectFileProvenance config = - config { - projectConfigProvenance = - Set.insert (Explicit extensionFile) (projectConfigProvenance config) - } - - --- | Parse the 'ProjectConfig' format. --- --- For the moment this is implemented in terms of parsers for legacy --- configuration types, plus a conversion. --- -parseProjectConfig :: String -> OldParser.ParseResult ProjectConfig -parseProjectConfig content = - convertLegacyProjectConfig <$> - parseLegacyProjectConfig content - - --- | Render the 'ProjectConfig' format. --- --- For the moment this is implemented in terms of a pretty printer for the --- legacy configuration types, plus a conversion. --- -showProjectConfig :: ProjectConfig -> String -showProjectConfig = - showLegacyProjectConfig . convertToLegacyProjectConfig - - --- | Write a @cabal.project.local@ file in the given project root dir. --- -writeProjectLocalExtraConfig :: DistDirLayout -> ProjectConfig -> IO () -writeProjectLocalExtraConfig DistDirLayout{distProjectFile} = - writeProjectConfigFile (distProjectFile "local") - - --- | Write a @cabal.project.freeze@ file in the given project root dir. --- -writeProjectLocalFreezeConfig :: DistDirLayout -> ProjectConfig -> IO () -writeProjectLocalFreezeConfig DistDirLayout{distProjectFile} = - writeProjectConfigFile (distProjectFile "freeze") - - --- | Write in the @cabal.project@ format to the given file. --- -writeProjectConfigFile :: FilePath -> ProjectConfig -> IO () -writeProjectConfigFile file = - writeFile file . showProjectConfig - - --- | Read the user's @~/.cabal/config@ file. --- -readGlobalConfig :: Verbosity -> Flag FilePath -> Rebuild ProjectConfig -readGlobalConfig verbosity configFileFlag = do - config <- liftIO (loadConfig verbosity configFileFlag) - configFile <- liftIO (getConfigFilePath configFileFlag) - monitorFiles [monitorFileHashed configFile] - return (convertLegacyGlobalConfig config) - -reportParseResult :: Verbosity -> String -> FilePath -> OldParser.ParseResult a -> IO a -reportParseResult verbosity _filetype filename (OldParser.ParseOk warnings x) = do - unless (null warnings) $ - let msg = unlines (map (OldParser.showPWarning filename) warnings) - in warn verbosity msg - return x -reportParseResult verbosity filetype filename (OldParser.ParseFailed err) = - let (line, msg) = OldParser.locatedErrorMsg err - in die' verbosity $ "Error parsing " ++ filetype ++ " " ++ filename - ++ maybe "" (\n -> ':' : show n) line ++ ":\n" ++ msg - - ---------------------------------------------- --- Finding packages in the project --- - --- | The location of a package as part of a project. Local file paths are --- either absolute (if the user specified it as such) or they are relative --- to the project root. --- -data ProjectPackageLocation = - ProjectPackageLocalCabalFile FilePath - | ProjectPackageLocalDirectory FilePath FilePath -- dir and .cabal file - | ProjectPackageLocalTarball FilePath - | ProjectPackageRemoteTarball URI - | ProjectPackageRemoteRepo SourceRepoList - | ProjectPackageNamed PackageVersionConstraint - deriving Show - - --- | Exception thrown by 'findProjectPackages'. --- -data BadPackageLocations - = BadPackageLocations (Set ProjectConfigProvenance) [BadPackageLocation] -#if MIN_VERSION_base(4,8,0) - deriving (Show, Typeable) -#else - deriving (Typeable) - -instance Show BadPackageLocations where - show = renderBadPackageLocations -#endif - -instance Exception BadPackageLocations where -#if MIN_VERSION_base(4,8,0) - displayException = renderBadPackageLocations -#endif ---TODO: [nice to have] custom exception subclass for Doc rendering, colour etc - -data BadPackageLocation - = BadPackageLocationFile BadPackageLocationMatch - | BadLocGlobEmptyMatch String - | BadLocGlobBadMatches String [BadPackageLocationMatch] - | BadLocUnexpectedUriScheme String - | BadLocUnrecognisedUri String - | BadLocUnrecognised String - deriving Show - -data BadPackageLocationMatch - = BadLocUnexpectedFile String - | BadLocNonexistantFile String - | BadLocDirNoCabalFile String - | BadLocDirManyCabalFiles String - deriving Show - -renderBadPackageLocations :: BadPackageLocations -> String -renderBadPackageLocations (BadPackageLocations provenance bpls) - -- There is no provenance information, - -- render standard bad package error information. - | Set.null provenance = renderErrors renderBadPackageLocation - - -- The configuration is implicit, render bad package locations - -- using possibly specialized error messages. - | Set.singleton Implicit == provenance = - renderErrors renderImplicitBadPackageLocation - - -- The configuration contains both implicit and explicit provenance. - -- This should not occur, and a message is output to assist debugging. - | Implicit `Set.member` provenance = - "Warning: both implicit and explicit configuration is present." - ++ renderExplicit - - -- The configuration was read from one or more explicit path(s), - -- list the locations and render the bad package error information. - -- The intent is to supersede this with the relevant location information - -- per package error. - | otherwise = renderExplicit - where - renderErrors f = unlines (map f bpls) - - renderExplicit = - "When using configuration(s) from " - ++ intercalate ", " (mapMaybe getExplicit (Set.toList provenance)) - ++ ", the following errors occurred:\n" - ++ renderErrors renderBadPackageLocation - - getExplicit (Explicit path) = Just path - getExplicit Implicit = Nothing - ---TODO: [nice to have] keep track of the config file (and src loc) packages --- were listed, to use in error messages - --- | Render bad package location error information for the implicit --- @cabal.project@ configuration. --- --- TODO: This is currently not fully realized, with only one of the implicit --- cases handled. More cases should be added with informative help text --- about the issues related specifically when having no project configuration --- is present. -renderImplicitBadPackageLocation :: BadPackageLocation -> String -renderImplicitBadPackageLocation bpl = case bpl of - BadLocGlobEmptyMatch pkglocstr -> - "No cabal.project file or cabal file matching the default glob '" - ++ pkglocstr ++ "' was found.\n" - ++ "Please create a package description file .cabal " - ++ "or a cabal.project file referencing the packages you " - ++ "want to build." - _ -> renderBadPackageLocation bpl - -renderBadPackageLocation :: BadPackageLocation -> String -renderBadPackageLocation bpl = case bpl of - BadPackageLocationFile badmatch -> - renderBadPackageLocationMatch badmatch - BadLocGlobEmptyMatch pkglocstr -> - "The package location glob '" ++ pkglocstr - ++ "' does not match any files or directories." - BadLocGlobBadMatches pkglocstr failures -> - "The package location glob '" ++ pkglocstr ++ "' does not match any " - ++ "recognised forms of package. " - ++ concatMap ((' ':) . renderBadPackageLocationMatch) failures - BadLocUnexpectedUriScheme pkglocstr -> - "The package location URI '" ++ pkglocstr ++ "' does not use a " - ++ "supported URI scheme. The supported URI schemes are http, https and " - ++ "file." - BadLocUnrecognisedUri pkglocstr -> - "The package location URI '" ++ pkglocstr ++ "' does not appear to " - ++ "be a valid absolute URI." - BadLocUnrecognised pkglocstr -> - "The package location syntax '" ++ pkglocstr ++ "' is not recognised." - -renderBadPackageLocationMatch :: BadPackageLocationMatch -> String -renderBadPackageLocationMatch bplm = case bplm of - BadLocUnexpectedFile pkglocstr -> - "The package location '" ++ pkglocstr ++ "' is not recognised. The " - ++ "supported file targets are .cabal files, .tar.gz tarballs or package " - ++ "directories (i.e. directories containing a .cabal file)." - BadLocNonexistantFile pkglocstr -> - "The package location '" ++ pkglocstr ++ "' does not exist." - BadLocDirNoCabalFile pkglocstr -> - "The package directory '" ++ pkglocstr ++ "' does not contain any " - ++ ".cabal file." - BadLocDirManyCabalFiles pkglocstr -> - "The package directory '" ++ pkglocstr ++ "' contains multiple " - ++ ".cabal files (which is not currently supported)." - --- | Given the project config, --- --- Throws 'BadPackageLocations'. --- -findProjectPackages :: DistDirLayout -> ProjectConfig - -> Rebuild [ProjectPackageLocation] -findProjectPackages DistDirLayout{distProjectRootDirectory} - ProjectConfig{..} = do - - requiredPkgs <- findPackageLocations True projectPackages - optionalPkgs <- findPackageLocations False projectPackagesOptional - let repoPkgs = map ProjectPackageRemoteRepo projectPackagesRepo - namedPkgs = map ProjectPackageNamed projectPackagesNamed - - return (concat [requiredPkgs, optionalPkgs, repoPkgs, namedPkgs]) - where - findPackageLocations required pkglocstr = do - (problems, pkglocs) <- - partitionEithers <$> traverse (findPackageLocation required) pkglocstr - unless (null problems) $ - liftIO $ throwIO $ BadPackageLocations projectConfigProvenance problems - return (concat pkglocs) - - - findPackageLocation :: Bool -> String - -> Rebuild (Either BadPackageLocation - [ProjectPackageLocation]) - findPackageLocation _required@True pkglocstr = - -- strategy: try first as a file:// or http(s):// URL. - -- then as a file glob (usually encompassing single file) - -- finally as a single file, for files that fail to parse as globs - checkIsUriPackage pkglocstr - `mplusMaybeT` checkIsFileGlobPackage pkglocstr - `mplusMaybeT` checkIsSingleFilePackage pkglocstr - >>= maybe (return (Left (BadLocUnrecognised pkglocstr))) return - - - findPackageLocation _required@False pkglocstr = do - -- just globs for optional case - res <- checkIsFileGlobPackage pkglocstr - case res of - Nothing -> return (Left (BadLocUnrecognised pkglocstr)) - Just (Left _) -> return (Right []) -- it's optional - Just (Right pkglocs) -> return (Right pkglocs) - - - checkIsUriPackage, checkIsFileGlobPackage, checkIsSingleFilePackage - :: String -> Rebuild (Maybe (Either BadPackageLocation - [ProjectPackageLocation])) - checkIsUriPackage pkglocstr = - case parseAbsoluteURI pkglocstr of - Just uri@URI { - uriScheme = scheme, - uriAuthority = Just URIAuth { uriRegName = host }, - uriPath = path, - uriQuery = query, - uriFragment = frag - } - | recognisedScheme && not (null host) -> - return (Just (Right [ProjectPackageRemoteTarball uri])) - - | scheme == "file:" && null host && null query && null frag -> - checkIsSingleFilePackage path - - | not recognisedScheme && not (null host) -> - return (Just (Left (BadLocUnexpectedUriScheme pkglocstr))) - - | recognisedScheme && null host -> - return (Just (Left (BadLocUnrecognisedUri pkglocstr))) - where - recognisedScheme = scheme == "http:" || scheme == "https:" - || scheme == "file:" - - _ -> return Nothing - - - checkIsFileGlobPackage pkglocstr = - case simpleParsec pkglocstr of - Nothing -> return Nothing - Just glob -> liftM Just $ do - matches <- matchFileGlob glob - case matches of - [] | isJust (isTrivialFilePathGlob glob) - -> return (Left (BadPackageLocationFile - (BadLocNonexistantFile pkglocstr))) - - [] -> return (Left (BadLocGlobEmptyMatch pkglocstr)) - - _ -> do - (failures, pkglocs) <- partitionEithers <$> - traverse checkFilePackageMatch matches - return $! case (failures, pkglocs) of - ([failure], []) | isJust (isTrivialFilePathGlob glob) - -> Left (BadPackageLocationFile failure) - (_, []) -> Left (BadLocGlobBadMatches pkglocstr failures) - _ -> Right pkglocs - - - checkIsSingleFilePackage pkglocstr = do - let filename = distProjectRootDirectory pkglocstr - isFile <- liftIO $ doesFileExist filename - isDir <- liftIO $ doesDirectoryExist filename - if isFile || isDir - then checkFilePackageMatch pkglocstr - >>= either (return . Just . Left . BadPackageLocationFile) - (return . Just . Right . (\x->[x])) - else return Nothing - - - checkFilePackageMatch :: String -> Rebuild (Either BadPackageLocationMatch - ProjectPackageLocation) - checkFilePackageMatch pkglocstr = do - -- The pkglocstr may be absolute or may be relative to the project root. - -- Either way, does the right thing here. We return relative paths if - -- they were relative in the first place. - let abspath = distProjectRootDirectory pkglocstr - isFile <- liftIO $ doesFileExist abspath - isDir <- liftIO $ doesDirectoryExist abspath - parentDirExists <- case takeDirectory abspath of - [] -> return False - dir -> liftIO $ doesDirectoryExist dir - case () of - _ | isDir - -> do matches <- matchFileGlob (globStarDotCabal pkglocstr) - case matches of - [cabalFile] - -> return (Right (ProjectPackageLocalDirectory - pkglocstr cabalFile)) - [] -> return (Left (BadLocDirNoCabalFile pkglocstr)) - _ -> return (Left (BadLocDirManyCabalFiles pkglocstr)) - - | extensionIsTarGz pkglocstr - -> return (Right (ProjectPackageLocalTarball pkglocstr)) - - | takeExtension pkglocstr == ".cabal" - -> return (Right (ProjectPackageLocalCabalFile pkglocstr)) - - | isFile - -> return (Left (BadLocUnexpectedFile pkglocstr)) - - | parentDirExists - -> return (Left (BadLocNonexistantFile pkglocstr)) - - | otherwise - -> return (Left (BadLocUnexpectedFile pkglocstr)) - - - extensionIsTarGz f = takeExtension f == ".gz" - && takeExtension (dropExtension f) == ".tar" - - --- | A glob to find all the cabal files in a directory. --- --- For a directory @some/dir/@, this is a glob of the form @some/dir/\*.cabal@. --- The directory part can be either absolute or relative. --- -globStarDotCabal :: FilePath -> FilePathGlob -globStarDotCabal dir = - FilePathGlob - (if isAbsolute dir then FilePathRoot root else FilePathRelative) - (foldr (\d -> GlobDir [Literal d]) - (GlobFile [WildCard, Literal ".cabal"]) dirComponents) - where - (root, dirComponents) = fmap splitDirectories (splitDrive dir) - - ---TODO: [code cleanup] use sufficiently recent transformers package -mplusMaybeT :: Monad m => m (Maybe a) -> m (Maybe a) -> m (Maybe a) -mplusMaybeT ma mb = do - mx <- ma - case mx of - Nothing -> mb - Just x -> return (Just x) - - -------------------------------------------------- --- Fetching and reading packages in the project --- - --- | Read the @.cabal@ files for a set of packages. For remote tarballs and --- VCS source repos this also fetches them if needed. --- --- Note here is where we convert from project-root relative paths to absolute --- paths. --- -fetchAndReadSourcePackages - :: Verbosity - -> DistDirLayout - -> ProjectConfigShared - -> ProjectConfigBuildOnly - -> [ProjectPackageLocation] - -> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)] -fetchAndReadSourcePackages verbosity distDirLayout - projectConfigShared - projectConfigBuildOnly - pkgLocations = do - - pkgsLocalDirectory <- - sequenceA - [ readSourcePackageLocalDirectory verbosity dir cabalFile - | location <- pkgLocations - , (dir, cabalFile) <- projectPackageLocal location ] - - pkgsLocalTarball <- - sequenceA - [ readSourcePackageLocalTarball verbosity path - | ProjectPackageLocalTarball path <- pkgLocations ] - - pkgsRemoteTarball <- do - getTransport <- delayInitSharedResource $ - configureTransport verbosity progPathExtra - preferredHttpTransport - sequenceA - [ fetchAndReadSourcePackageRemoteTarball verbosity distDirLayout - getTransport uri - | ProjectPackageRemoteTarball uri <- pkgLocations ] - - pkgsRemoteRepo <- - syncAndReadSourcePackagesRemoteRepos - verbosity distDirLayout - projectConfigShared - [ repo | ProjectPackageRemoteRepo repo <- pkgLocations ] - - let pkgsNamed = - [ NamedPackage pkgname [PackagePropertyVersion verrange] - | ProjectPackageNamed (PackageVersionConstraint pkgname verrange) <- pkgLocations ] - - return $ concat - [ pkgsLocalDirectory - , pkgsLocalTarball - , pkgsRemoteTarball - , pkgsRemoteRepo - , pkgsNamed - ] - where - projectPackageLocal (ProjectPackageLocalDirectory dir file) = [(dir, file)] - projectPackageLocal (ProjectPackageLocalCabalFile file) = [(dir, file)] - where dir = takeDirectory file - projectPackageLocal _ = [] - - progPathExtra = fromNubList (projectConfigProgPathExtra projectConfigShared) - preferredHttpTransport = - flagToMaybe (projectConfigHttpTransport projectConfigBuildOnly) - --- | A helper for 'fetchAndReadSourcePackages' to handle the case of --- 'ProjectPackageLocalDirectory' and 'ProjectPackageLocalCabalFile'. --- We simply read the @.cabal@ file. --- -readSourcePackageLocalDirectory - :: Verbosity - -> FilePath -- ^ The package directory - -> FilePath -- ^ The package @.cabal@ file - -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc)) -readSourcePackageLocalDirectory verbosity dir cabalFile = do - monitorFiles [monitorFileHashed cabalFile] - root <- askRoot - let location = LocalUnpackedPackage (root dir) - liftIO $ fmap (mkSpecificSourcePackage location) - . readSourcePackageCabalFile verbosity cabalFile - =<< BS.readFile (root cabalFile) - - --- | A helper for 'fetchAndReadSourcePackages' to handle the case of --- 'ProjectPackageLocalTarball'. We scan through the @.tar.gz@ file to find --- the @.cabal@ file and read that. --- -readSourcePackageLocalTarball - :: Verbosity - -> FilePath - -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc)) -readSourcePackageLocalTarball verbosity tarballFile = do - monitorFiles [monitorFile tarballFile] - root <- askRoot - let location = LocalTarballPackage (root tarballFile) - liftIO $ fmap (mkSpecificSourcePackage location) - . uncurry (readSourcePackageCabalFile verbosity) - =<< extractTarballPackageCabalFile (root tarballFile) - --- | A helper for 'fetchAndReadSourcePackages' to handle the case of --- 'ProjectPackageRemoteTarball'. We download the tarball to the dist src dir --- and after that handle it like the local tarball case. --- -fetchAndReadSourcePackageRemoteTarball - :: Verbosity - -> DistDirLayout - -> Rebuild HttpTransport - -> URI - -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc)) -fetchAndReadSourcePackageRemoteTarball verbosity - DistDirLayout { - distDownloadSrcDirectory - } - getTransport - tarballUri = - -- The tarball download is expensive so we use another layer of file - -- monitor to avoid it whenever possible. - rerunIfChanged verbosity monitor tarballUri $ do - - -- Download - transport <- getTransport - liftIO $ do - transportCheckHttps verbosity transport tarballUri - notice verbosity ("Downloading " ++ show tarballUri) - createDirectoryIfMissingVerbose verbosity True - distDownloadSrcDirectory - _ <- downloadURI transport verbosity tarballUri tarballFile - return () - - -- Read - monitorFiles [monitorFile tarballFile] - let location = RemoteTarballPackage tarballUri tarballFile - liftIO $ fmap (mkSpecificSourcePackage location) - . uncurry (readSourcePackageCabalFile verbosity) - =<< extractTarballPackageCabalFile tarballFile - where - tarballStem = distDownloadSrcDirectory - localFileNameForRemoteTarball tarballUri - tarballFile = tarballStem <.> "tar.gz" - - monitor :: FileMonitor URI (PackageSpecifier (SourcePackage UnresolvedPkgLoc)) - monitor = newFileMonitor (tarballStem <.> "cache") - - --- | A helper for 'fetchAndReadSourcePackages' to handle all the cases of --- 'ProjectPackageRemoteRepo'. --- -syncAndReadSourcePackagesRemoteRepos - :: Verbosity - -> DistDirLayout - -> ProjectConfigShared - -> [SourceRepoList] - -> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)] -syncAndReadSourcePackagesRemoteRepos verbosity - DistDirLayout{distDownloadSrcDirectory} - ProjectConfigShared { - projectConfigProgPathExtra - } - repos = do - - repos' <- either reportSourceRepoProblems return $ - validateSourceRepos repos - - -- All 'SourceRepo's grouped by referring to the "same" remote repo - -- instance. So same location but can differ in commit/tag/branch/subdir. - let reposByLocation :: Map (RepoType, String) - [(SourceRepoList, RepoType)] - reposByLocation = Map.fromListWith (++) - [ ((rtype, rloc), [(repo, vcsRepoType vcs)]) - | (repo, rloc, rtype, vcs) <- repos' ] - - --TODO: pass progPathExtra on to 'configureVCS' - let _progPathExtra = fromNubList projectConfigProgPathExtra - getConfiguredVCS <- delayInitSharedResources $ \repoType -> - let vcs = Map.findWithDefault (error $ "Unknown VCS: " ++ prettyShow repoType) repoType knownVCSs in - configureVCS verbosity {-progPathExtra-} vcs - - concat <$> sequenceA - [ rerunIfChanged verbosity monitor repoGroup' $ do - vcs' <- getConfiguredVCS repoType - syncRepoGroupAndReadSourcePackages vcs' pathStem repoGroup' - | repoGroup@((primaryRepo, repoType):_) <- Map.elems reposByLocation - , let repoGroup' = map fst repoGroup - pathStem = distDownloadSrcDirectory - localFileNameForRemoteRepo primaryRepo - monitor :: FileMonitor - [SourceRepoList] - [PackageSpecifier (SourcePackage UnresolvedPkgLoc)] - monitor = newFileMonitor (pathStem <.> "cache") - ] - where - syncRepoGroupAndReadSourcePackages - :: VCS ConfiguredProgram - -> FilePath - -> [SourceRepoList] - -> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)] - syncRepoGroupAndReadSourcePackages vcs pathStem repoGroup = do - liftIO $ createDirectoryIfMissingVerbose verbosity False - distDownloadSrcDirectory - - -- For syncing we don't care about different 'SourceRepo' values that - -- are just different subdirs in the same repo. - syncSourceRepos verbosity vcs - [ (repo, repoPath) - | (repo, _, repoPath) <- repoGroupWithPaths ] - -- TODO phadej 2020-06-18 add post-sync script - - -- But for reading we go through each 'SourceRepo' including its subdir - -- value and have to know which path each one ended up in. - sequenceA - [ readPackageFromSourceRepo repoWithSubdir repoPath - | (_, reposWithSubdir, repoPath) <- repoGroupWithPaths - , repoWithSubdir <- NE.toList reposWithSubdir ] - where - -- So to do both things above, we pair them up here. - repoGroupWithPaths - :: [(SourceRepositoryPackage Proxy, NonEmpty (SourceRepositoryPackage Maybe), FilePath)] - repoGroupWithPaths = - zipWith (\(x, y) z -> (x,y,z)) - (mapGroup - [ (repo { srpSubdir = Proxy }, repo) - | repo <- foldMap (NE.toList . srpFanOut) repoGroup - ]) - repoPaths - - mapGroup :: Ord k => [(k, v)] -> [(k, NonEmpty v)] - mapGroup = Map.toList . Map.fromListWith (<>) . map (\(k, v) -> (k, pure v)) - - -- The repos in a group are given distinct names by simple enumeration - -- foo, foo-2, foo-3 etc - repoPaths :: [FilePath] - repoPaths = pathStem - : [ pathStem ++ "-" ++ show (i :: Int) | i <- [2..] ] - - readPackageFromSourceRepo - :: SourceRepositoryPackage Maybe - -> FilePath - -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc)) - readPackageFromSourceRepo repo repoPath = do - let packageDir :: FilePath - packageDir = maybe repoPath (repoPath ) (srpSubdir repo) - - entries <- liftIO $ getDirectoryContents packageDir - --TODO: dcoutts 2018-06-23: wrap exceptions - case filter (\e -> takeExtension e == ".cabal") entries of - [] -> liftIO $ throwIO $ NoCabalFileFound packageDir - (_:_:_) -> liftIO $ throwIO $ MultipleCabalFilesFound packageDir - [cabalFileName] -> do - let cabalFilePath = packageDir cabalFileName - monitorFiles [monitorFileHashed cabalFilePath] - gpd <- liftIO $ readSourcePackageCabalFile verbosity cabalFilePath =<< BS.readFile cabalFilePath - - -- write sdist tarball, to repoPath-pgkid - tarball <- liftIO $ packageDirToSdist verbosity gpd packageDir - let tarballPath = repoPath ++ "-" ++ prettyShow (packageId gpd) ++ ".tar.gz" - liftIO $ LBS.writeFile tarballPath tarball - - let location = RemoteSourceRepoPackage repo tarballPath - return $ mkSpecificSourcePackage location gpd - - reportSourceRepoProblems :: [(SourceRepoList, SourceRepoProblem)] -> Rebuild a - reportSourceRepoProblems = liftIO . die' verbosity . renderSourceRepoProblems - - renderSourceRepoProblems :: [(SourceRepoList, SourceRepoProblem)] -> String - renderSourceRepoProblems = unlines . map show -- "TODO: the repo problems" - - --- | Utility used by all the helpers of 'fetchAndReadSourcePackages' to make an --- appropriate @'PackageSpecifier' ('SourcePackage' (..))@ for a given package --- from a given location. --- -mkSpecificSourcePackage :: PackageLocation FilePath - -> GenericPackageDescription - -> PackageSpecifier (SourcePackage UnresolvedPkgLoc) -mkSpecificSourcePackage location pkg = - SpecificSourcePackage SourcePackage - { srcpkgPackageId = packageId pkg - , srcpkgDescription = pkg - , srcpkgSource = fmap Just location - , srcpkgDescrOverride = Nothing - } - - --- | Errors reported upon failing to parse a @.cabal@ file. --- -data CabalFileParseError = CabalFileParseError - FilePath -- ^ @.cabal@ file path - BS.ByteString -- ^ @.cabal@ file contents - (NonEmpty PError) -- ^ errors - (Maybe Version) -- ^ We might discover the spec version the package needs - [PWarning] -- ^ warnings - deriving (Typeable) - --- | Manual instance which skips file contentes -instance Show CabalFileParseError where - showsPrec d (CabalFileParseError fp _ es mv ws) = showParen (d > 10) - $ showString "CabalFileParseError" - . showChar ' ' . showsPrec 11 fp - . showChar ' ' . showsPrec 11 ("" :: String) - . showChar ' ' . showsPrec 11 es - . showChar ' ' . showsPrec 11 mv - . showChar ' ' . showsPrec 11 ws - -instance Exception CabalFileParseError -#if MIN_VERSION_base(4,8,0) - where - displayException = renderCabalFileParseError -#endif - -renderCabalFileParseError :: CabalFileParseError -> String -renderCabalFileParseError (CabalFileParseError filePath contents errors _ warnings) = - renderParseError filePath contents errors warnings - --- | Wrapper for the @.cabal@ file parser. It reports warnings on higher --- verbosity levels and throws 'CabalFileParseError' on failure. --- -readSourcePackageCabalFile :: Verbosity - -> FilePath - -> BS.ByteString - -> IO GenericPackageDescription -readSourcePackageCabalFile verbosity pkgfilename content = - case runParseResult (parseGenericPackageDescription content) of - (warnings, Right pkg) -> do - unless (null warnings) $ - info verbosity (formatWarnings warnings) - return pkg - - (warnings, Left (mspecVersion, errors)) -> - throwIO $ CabalFileParseError pkgfilename content errors mspecVersion warnings - where - formatWarnings warnings = - "The package description file " ++ pkgfilename - ++ " has warnings: " - ++ unlines (map (showPWarning pkgfilename) warnings) - - --- | When looking for a package's @.cabal@ file we can find none, or several, --- both of which are failures. --- -data CabalFileSearchFailure - = NoCabalFileFound FilePath - | MultipleCabalFilesFound FilePath - deriving (Show, Typeable) - -instance Exception CabalFileSearchFailure - - --- | Find the @.cabal@ file within a tarball file and return it by value. --- --- Can fail with a 'Tar.FormatError' or 'CabalFileSearchFailure' exception. --- -extractTarballPackageCabalFile :: FilePath -> IO (FilePath, BS.ByteString) -extractTarballPackageCabalFile tarballFile = - withBinaryFile tarballFile ReadMode $ \hnd -> do - content <- LBS.hGetContents hnd - case extractTarballPackageCabalFilePure tarballFile content of - Left (Left e) -> throwIO e - Left (Right e) -> throwIO e - Right (fileName, fileContent) -> - (,) fileName <$> evaluate (LBS.toStrict fileContent) - - --- | Scan through a tar file stream and collect the @.cabal@ file, or fail. --- -extractTarballPackageCabalFilePure :: FilePath - -> LBS.ByteString - -> Either (Either Tar.FormatError - CabalFileSearchFailure) - (FilePath, LBS.ByteString) -extractTarballPackageCabalFilePure tarballFile = - check - . accumEntryMap - . Tar.filterEntries isCabalFile - . Tar.read - . GZipUtils.maybeDecompress - where - accumEntryMap = Tar.foldlEntries - (\m e -> Map.insert (Tar.entryTarPath e) e m) - Map.empty - - check (Left (e, _m)) = Left (Left e) - check (Right m) = case Map.elems m of - [] -> Left (Right $ NoCabalFileFound tarballFile) - [file] -> case Tar.entryContent file of - Tar.NormalFile content _ -> Right (Tar.entryPath file, content) - _ -> Left (Right $ NoCabalFileFound tarballFile) - _files -> Left (Right $ MultipleCabalFilesFound tarballFile) - - isCabalFile e = case splitPath (Tar.entryPath e) of - [ _dir, file] -> takeExtension file == ".cabal" - [".", _dir, file] -> takeExtension file == ".cabal" - _ -> False - - --- | The name to use for a local file for a remote tarball 'SourceRepo'. --- This is deterministic based on the remote tarball URI, and is intended --- to produce non-clashing file names for different tarballs. --- -localFileNameForRemoteTarball :: URI -> FilePath -localFileNameForRemoteTarball uri = - mangleName uri - ++ "-" ++ showHex locationHash "" - where - mangleName = truncateString 10 . dropExtension . dropExtension - . takeFileName . dropTrailingPathSeparator . uriPath - - locationHash :: Word - locationHash = fromIntegral (Hashable.hash (uriToString id uri "")) - - --- | The name to use for a local file or dir for a remote 'SourceRepo'. --- This is deterministic based on the source repo identity details, and --- intended to produce non-clashing file names for different repos. --- -localFileNameForRemoteRepo :: SourceRepoList -> FilePath -localFileNameForRemoteRepo SourceRepositoryPackage {srpType, srpLocation} = - mangleName srpLocation ++ "-" ++ showHex locationHash "" - where - mangleName = truncateString 10 . dropExtension - . takeFileName . dropTrailingPathSeparator - - -- just the parts that make up the "identity" of the repo - locationHash :: Word - locationHash = - fromIntegral (Hashable.hash (show srpType, srpLocation)) - - --- | Truncate a string, with a visual indication that it is truncated. -truncateString :: Int -> String -> String -truncateString n s | length s <= n = s - | otherwise = take (n-1) s ++ "_" - - --- TODO: add something like this, here or in the project planning --- Based on the package location, which packages will be built inplace in the --- build tree vs placed in the store. This has various implications on what we --- can do with the package, e.g. can we run tests, ghci etc. --- --- packageIsLocalToProject :: ProjectPackageLocation -> Bool - - ---------------------------------------------- --- Checking configuration sanity --- - -data BadPerPackageCompilerPaths - = BadPerPackageCompilerPaths [(PackageName, String)] -#if MIN_VERSION_base(4,8,0) - deriving (Show, Typeable) -#else - deriving (Typeable) - -instance Show BadPerPackageCompilerPaths where - show = renderBadPerPackageCompilerPaths -#endif - -instance Exception BadPerPackageCompilerPaths where -#if MIN_VERSION_base(4,8,0) - displayException = renderBadPerPackageCompilerPaths -#endif ---TODO: [nice to have] custom exception subclass for Doc rendering, colour etc - -renderBadPerPackageCompilerPaths :: BadPerPackageCompilerPaths -> String -renderBadPerPackageCompilerPaths - (BadPerPackageCompilerPaths ((pkgname, progname) : _)) = - "The path to the compiler program (or programs used by the compiler) " - ++ "cannot be specified on a per-package basis in the cabal.project file " - ++ "(i.e. setting the '" ++ progname ++ "-location' for package '" - ++ prettyShow pkgname ++ "'). All packages have to use the same compiler, so " - ++ "specify the path in a global 'program-locations' section." - --TODO: [nice to have] better format control so we can pretty-print the - -- offending part of the project file. Currently the line wrapping breaks any - -- formatting. -renderBadPerPackageCompilerPaths _ = error "renderBadPerPackageCompilerPaths" - --- | The project configuration is not allowed to specify program locations for --- programs used by the compiler as these have to be the same for each set of --- packages. --- --- We cannot check this until we know which programs the compiler uses, which --- in principle is not until we've configured the compiler. --- --- Throws 'BadPerPackageCompilerPaths' --- -checkBadPerPackageCompilerPaths :: [ConfiguredProgram] - -> Map PackageName PackageConfig - -> IO () -checkBadPerPackageCompilerPaths compilerPrograms packagesConfig = - case [ (pkgname, progname) - | let compProgNames = Set.fromList (map programId compilerPrograms) - , (pkgname, pkgconf) <- Map.toList packagesConfig - , progname <- Map.keys (getMapLast (packageConfigProgramPaths pkgconf)) - , progname `Set.member` compProgNames ] of - [] -> return () - ps -> throwIO (BadPerPackageCompilerPaths ps) diff --git a/cabal/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs b/cabal/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs +++ /dev/null @@ -1,1479 +0,0 @@ -{-# LANGUAGE RecordWildCards, NamedFieldPuns, DeriveGeneric, ConstraintKinds #-} - --- | Project configuration, implementation in terms of legacy types. --- -module Distribution.Client.ProjectConfig.Legacy ( - - -- * Project config in terms of legacy types - LegacyProjectConfig, - parseLegacyProjectConfig, - showLegacyProjectConfig, - - -- * Conversion to and from legacy config types - commandLineFlagsToProjectConfig, - convertLegacyProjectConfig, - convertLegacyGlobalConfig, - convertToLegacyProjectConfig, - - -- * Internals, just for tests - parsePackageLocationTokenQ, - renderPackageLocationToken, - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude - -import Distribution.Types.Flag (parsecFlagAssignment) - -import Distribution.Client.ProjectConfig.Types -import Distribution.Client.Types.RepoName (RepoName (..), unRepoName) -import Distribution.Client.Types.Repo (RemoteRepo(..), LocalRepo (..), emptyRemoteRepo) -import Distribution.Client.Types.AllowNewer (AllowNewer(..), AllowOlder(..)) -import Distribution.Client.Types.SourceRepo (sourceRepositoryPackageGrammar, SourceRepoList) - -import Distribution.Client.Config - ( SavedConfig(..), remoteRepoFields, postProcessRepo ) - -import Distribution.Client.CmdInstall.ClientInstallFlags - ( ClientInstallFlags(..), defaultClientInstallFlags - , clientInstallOptions ) - -import Distribution.Solver.Types.ConstraintSource - -import Distribution.FieldGrammar -import Distribution.Package -import Distribution.Types.SourceRepo (RepoType) -import Distribution.PackageDescription - ( dispFlagAssignment ) -import Distribution.Simple.Compiler - ( OptimisationLevel(..), DebugInfoLevel(..) ) -import Distribution.Simple.InstallDirs ( CopyDest (NoCopyDest) ) -import Distribution.Simple.Setup - ( Flag(Flag), toFlag, fromFlagOrDefault - , ConfigFlags(..), configureOptions - , HaddockFlags(..), haddockOptions, defaultHaddockFlags - , TestFlags(..), testOptions', defaultTestFlags - , BenchmarkFlags(..), benchmarkOptions', defaultBenchmarkFlags - , programDbPaths', splitArgs - ) -import Distribution.Client.NixStyleOptions (NixStyleFlags (..)) -import Distribution.Client.ProjectFlags (ProjectFlags (..), projectFlagsOptions, defaultProjectFlags) -import Distribution.Client.Setup - ( GlobalFlags(..), globalCommand - , ConfigExFlags(..), configureExOptions, defaultConfigExFlags - , InstallFlags(..), installOptions, defaultInstallFlags ) -import Distribution.Simple.Program - ( programName, knownPrograms ) -import Distribution.Simple.Program.Db - ( ProgramDb, defaultProgramDb ) -import Distribution.Simple.Utils - ( lowercase ) -import Distribution.Utils.NubList - ( toNubList, fromNubList, overNubList ) -import Distribution.Simple.LocalBuildInfo - ( toPathTemplate, fromPathTemplate ) - -import qualified Distribution.Deprecated.ReadP as Parse -import Distribution.Deprecated.ReadP - ( ReadP, (+++) ) -import qualified Text.PrettyPrint as Disp -import Text.PrettyPrint - ( Doc, ($+$) ) -import qualified Distribution.Deprecated.ParseUtils as ParseUtils -import Distribution.Deprecated.ParseUtils - ( ParseResult(..), PError(..), syntaxError, PWarning(..) - , commaNewLineListFieldParsec, newLineListField, parseTokenQ - , parseHaskellString, showToken - , simpleFieldParsec - ) -import Distribution.Client.ParseUtils -import Distribution.Simple.Command - ( CommandUI(commandOptions), ShowOrParseArgs(..) - , OptionField, option, reqArg' ) -import Distribution.Types.PackageVersionConstraint - ( PackageVersionConstraint ) -import Distribution.Parsec (ParsecParser) - -import qualified Data.Map as Map - -import Network.URI (URI (..)) - ------------------------------------------------------------------- --- Representing the project config file in terms of legacy types --- - --- | We already have parsers\/pretty-printers for almost all the fields in the --- project config file, but they're in terms of the types used for the command --- line flags for Setup.hs or cabal commands. We don't want to redefine them --- all, at least not yet so for the moment we use the parsers at the old types --- and use conversion functions. --- --- Ultimately if\/when this project-based approach becomes the default then we --- can redefine the parsers directly for the new types. --- -data LegacyProjectConfig = LegacyProjectConfig { - legacyPackages :: [String], - legacyPackagesOptional :: [String], - legacyPackagesRepo :: [SourceRepoList], - legacyPackagesNamed :: [PackageVersionConstraint], - - legacySharedConfig :: LegacySharedConfig, - legacyAllConfig :: LegacyPackageConfig, - legacyLocalConfig :: LegacyPackageConfig, - legacySpecificConfig :: MapMappend PackageName LegacyPackageConfig - } deriving Generic - -instance Monoid LegacyProjectConfig where - mempty = gmempty - mappend = (<>) - -instance Semigroup LegacyProjectConfig where - (<>) = gmappend - -data LegacyPackageConfig = LegacyPackageConfig { - legacyConfigureFlags :: ConfigFlags, - legacyInstallPkgFlags :: InstallFlags, - legacyHaddockFlags :: HaddockFlags, - legacyTestFlags :: TestFlags, - legacyBenchmarkFlags :: BenchmarkFlags - } deriving Generic - -instance Monoid LegacyPackageConfig where - mempty = gmempty - mappend = (<>) - -instance Semigroup LegacyPackageConfig where - (<>) = gmappend - -data LegacySharedConfig = LegacySharedConfig { - legacyGlobalFlags :: GlobalFlags, - legacyConfigureShFlags :: ConfigFlags, - legacyConfigureExFlags :: ConfigExFlags, - legacyInstallFlags :: InstallFlags, - legacyClientInstallFlags:: ClientInstallFlags, - legacyProjectFlags :: ProjectFlags - } deriving Generic - -instance Monoid LegacySharedConfig where - mempty = gmempty - mappend = (<>) - -instance Semigroup LegacySharedConfig where - (<>) = gmappend - - ------------------------------------------------------------------- --- Converting from and to the legacy types --- - --- | Convert configuration from the @cabal configure@ or @cabal build@ command --- line into a 'ProjectConfig' value that can combined with configuration from --- other sources. --- --- At the moment this uses the legacy command line flag types. See --- 'LegacyProjectConfig' for an explanation. --- -commandLineFlagsToProjectConfig :: GlobalFlags - -> NixStyleFlags a - -> ClientInstallFlags - -> ProjectConfig -commandLineFlagsToProjectConfig globalFlags NixStyleFlags {..} clientInstallFlags = - mempty { - projectConfigBuildOnly = convertLegacyBuildOnlyFlags - globalFlags configFlags - installFlags clientInstallFlags - haddockFlags testFlags benchmarkFlags, - projectConfigShared = convertLegacyAllPackageFlags - globalFlags configFlags - configExFlags installFlags projectFlags, - projectConfigLocalPackages = localConfig, - projectConfigAllPackages = allConfig - } - where (localConfig, allConfig) = splitConfig - (convertLegacyPerPackageFlags - configFlags installFlags - haddockFlags testFlags benchmarkFlags) - -- split the package config (from command line arguments) into - -- those applied to all packages and those to local only. - -- - -- for now we will just copy over the ProgramPaths/Args/Extra into - -- the AllPackages. The LocalPackages do not inherit them from - -- AllPackages, and as such need to retain them. - -- - -- The general decision rule for what to put into allConfig - -- into localConfig is the following: - -- - -- - anything that is host/toolchain/env specific should be applied - -- to all packages, as packagesets have to be host/toolchain/env - -- consistent. - -- - anything else should be in the local config and could potentially - -- be lifted into all-packages vial the `package *` cabal.project - -- section. - -- - splitConfig :: PackageConfig -> (PackageConfig, PackageConfig) - splitConfig pc = (pc - , mempty { packageConfigProgramPaths = packageConfigProgramPaths pc - , packageConfigProgramArgs = packageConfigProgramArgs pc - , packageConfigProgramPathExtra = packageConfigProgramPathExtra pc - , packageConfigDocumentation = packageConfigDocumentation pc }) - --- | Convert from the types currently used for the user-wide @~/.cabal/config@ --- file into the 'ProjectConfig' type. --- --- Only a subset of the 'ProjectConfig' can be represented in the user-wide --- config. In particular it does not include packages that are in the project, --- and it also doesn't support package-specific configuration (only --- configuration that applies to all packages). --- -convertLegacyGlobalConfig :: SavedConfig -> ProjectConfig -convertLegacyGlobalConfig - SavedConfig { - savedGlobalFlags = globalFlags, - savedInstallFlags = installFlags, - savedClientInstallFlags= clientInstallFlags, - savedConfigureFlags = configFlags, - savedConfigureExFlags = configExFlags, - savedUserInstallDirs = _, - savedGlobalInstallDirs = _, - savedUploadFlags = _, - savedReportFlags = _, - savedHaddockFlags = haddockFlags, - savedTestFlags = testFlags, - savedBenchmarkFlags = benchmarkFlags, - savedProjectFlags = projectFlags - } = - mempty { - projectConfigBuildOnly = configBuildOnly, - projectConfigShared = configShared, - projectConfigAllPackages = configAllPackages - } - where - --TODO: [code cleanup] eliminate use of default*Flags here and specify the - -- defaults in the various resolve functions in terms of the new types. - configExFlags' = defaultConfigExFlags <> configExFlags - installFlags' = defaultInstallFlags <> installFlags - clientInstallFlags' = defaultClientInstallFlags <> clientInstallFlags - haddockFlags' = defaultHaddockFlags <> haddockFlags - testFlags' = defaultTestFlags <> testFlags - benchmarkFlags' = defaultBenchmarkFlags <> benchmarkFlags - projectFlags' = defaultProjectFlags <> projectFlags - - configAllPackages = convertLegacyPerPackageFlags - configFlags installFlags' - haddockFlags' testFlags' benchmarkFlags' - configShared = convertLegacyAllPackageFlags - globalFlags configFlags - configExFlags' installFlags' projectFlags' - configBuildOnly = convertLegacyBuildOnlyFlags - globalFlags configFlags - installFlags' clientInstallFlags' - haddockFlags' testFlags' benchmarkFlags' - - --- | Convert the project config from the legacy types to the 'ProjectConfig' --- and associated types. See 'LegacyProjectConfig' for an explanation of the --- approach. --- -convertLegacyProjectConfig :: LegacyProjectConfig -> ProjectConfig -convertLegacyProjectConfig - LegacyProjectConfig { - legacyPackages, - legacyPackagesOptional, - legacyPackagesRepo, - legacyPackagesNamed, - legacySharedConfig = LegacySharedConfig globalFlags configShFlags - configExFlags installSharedFlags - clientInstallFlags projectFlags, - legacyAllConfig, - legacyLocalConfig = LegacyPackageConfig configFlags installPerPkgFlags - haddockFlags testFlags benchmarkFlags, - legacySpecificConfig - } = - - ProjectConfig { - projectPackages = legacyPackages, - projectPackagesOptional = legacyPackagesOptional, - projectPackagesRepo = legacyPackagesRepo, - projectPackagesNamed = legacyPackagesNamed, - - projectConfigBuildOnly = configBuildOnly, - projectConfigShared = configPackagesShared, - projectConfigProvenance = mempty, - projectConfigAllPackages = configAllPackages, - projectConfigLocalPackages = configLocalPackages, - projectConfigSpecificPackage = fmap perPackage legacySpecificConfig - } - where - configAllPackages = convertLegacyPerPackageFlags g i h t b - where LegacyPackageConfig g i h t b = legacyAllConfig - configLocalPackages = convertLegacyPerPackageFlags - configFlags installPerPkgFlags haddockFlags - testFlags benchmarkFlags - configPackagesShared= convertLegacyAllPackageFlags - globalFlags (configFlags <> configShFlags) - configExFlags installSharedFlags projectFlags - configBuildOnly = convertLegacyBuildOnlyFlags - globalFlags configShFlags - installSharedFlags clientInstallFlags - haddockFlags testFlags benchmarkFlags - - perPackage (LegacyPackageConfig perPkgConfigFlags perPkgInstallFlags - perPkgHaddockFlags perPkgTestFlags - perPkgBenchmarkFlags) = - convertLegacyPerPackageFlags - perPkgConfigFlags perPkgInstallFlags perPkgHaddockFlags - perPkgTestFlags perPkgBenchmarkFlags - - --- | Helper used by other conversion functions that returns the --- 'ProjectConfigShared' subset of the 'ProjectConfig'. --- -convertLegacyAllPackageFlags - :: GlobalFlags - -> ConfigFlags - -> ConfigExFlags - -> InstallFlags - -> ProjectFlags - -> ProjectConfigShared -convertLegacyAllPackageFlags globalFlags configFlags configExFlags installFlags projectFlags = - ProjectConfigShared{..} - where - GlobalFlags { - globalConfigFile = projectConfigConfigFile, - globalRemoteRepos = projectConfigRemoteRepos, - globalLocalNoIndexRepos = projectConfigLocalNoIndexRepos, - globalActiveRepos = projectConfigActiveRepos, - globalProgPathExtra = projectConfigProgPathExtra, - globalStoreDir = projectConfigStoreDir - } = globalFlags - - ConfigFlags { - configDistPref = projectConfigDistDir, - configHcFlavor = projectConfigHcFlavor, - configHcPath = projectConfigHcPath, - configHcPkg = projectConfigHcPkg - --configProgramPathExtra = projectConfigProgPathExtra DELETE ME - --configInstallDirs = projectConfigInstallDirs, - --configUserInstall = projectConfigUserInstall, - --configPackageDBs = projectConfigPackageDBs, - } = configFlags - - ConfigExFlags { - configCabalVersion = projectConfigCabalVersion, - configExConstraints = projectConfigConstraints, - configPreferences = projectConfigPreferences, - configSolver = projectConfigSolver, - configAllowOlder = projectConfigAllowOlder, - configAllowNewer = projectConfigAllowNewer, - configWriteGhcEnvironmentFilesPolicy - = projectConfigWriteGhcEnvironmentFilesPolicy - } = configExFlags - - InstallFlags { - installHaddockIndex = projectConfigHaddockIndex, - --installReinstall = projectConfigReinstall, - --installAvoidReinstalls = projectConfigAvoidReinstalls, - --installOverrideReinstall = projectConfigOverrideReinstall, - installIndexState = projectConfigIndexState, - installMaxBackjumps = projectConfigMaxBackjumps, - --installUpgradeDeps = projectConfigUpgradeDeps, - installReorderGoals = projectConfigReorderGoals, - installCountConflicts = projectConfigCountConflicts, - installFineGrainedConflicts = projectConfigFineGrainedConflicts, - installMinimizeConflictSet = projectConfigMinimizeConflictSet, - installPerComponent = projectConfigPerComponent, - installIndependentGoals = projectConfigIndependentGoals, - --installShadowPkgs = projectConfigShadowPkgs, - installStrongFlags = projectConfigStrongFlags, - installAllowBootLibInstalls = projectConfigAllowBootLibInstalls, - installOnlyConstrained = projectConfigOnlyConstrained - } = installFlags - - ProjectFlags - { flagProjectFileName = projectConfigProjectFile - , flagIgnoreProject = projectConfigIgnoreProject - } = projectFlags - --- | Helper used by other conversion functions that returns the --- 'PackageConfig' subset of the 'ProjectConfig'. --- -convertLegacyPerPackageFlags :: ConfigFlags -> InstallFlags -> HaddockFlags - -> TestFlags -> BenchmarkFlags -> PackageConfig -convertLegacyPerPackageFlags configFlags installFlags - haddockFlags testFlags benchmarkFlags = - PackageConfig{..} - where - ConfigFlags { - configProgramPaths, - configProgramArgs, - configProgramPathExtra = packageConfigProgramPathExtra, - configVanillaLib = packageConfigVanillaLib, - configProfLib = packageConfigProfLib, - configSharedLib = packageConfigSharedLib, - configStaticLib = packageConfigStaticLib, - configDynExe = packageConfigDynExe, - configFullyStaticExe = packageConfigFullyStaticExe, - configProfExe = packageConfigProfExe, - configProf = packageConfigProf, - configProfDetail = packageConfigProfDetail, - configProfLibDetail = packageConfigProfLibDetail, - configConfigureArgs = packageConfigConfigureArgs, - configOptimization = packageConfigOptimization, - configProgPrefix = packageConfigProgPrefix, - configProgSuffix = packageConfigProgSuffix, - configGHCiLib = packageConfigGHCiLib, - configSplitSections = packageConfigSplitSections, - configSplitObjs = packageConfigSplitObjs, - configStripExes = packageConfigStripExes, - configStripLibs = packageConfigStripLibs, - configExtraLibDirs = packageConfigExtraLibDirs, - configExtraFrameworkDirs = packageConfigExtraFrameworkDirs, - configExtraIncludeDirs = packageConfigExtraIncludeDirs, - configConfigurationsFlags = packageConfigFlagAssignment, - configTests = packageConfigTests, - configBenchmarks = packageConfigBenchmarks, - configCoverage = coverage, - configLibCoverage = libcoverage, --deprecated - configDebugInfo = packageConfigDebugInfo, - configRelocatable = packageConfigRelocatable - } = configFlags - packageConfigProgramPaths = MapLast (Map.fromList configProgramPaths) - packageConfigProgramArgs = MapMappend (Map.fromListWith (++) configProgramArgs) - - packageConfigCoverage = coverage <> libcoverage - --TODO: defer this merging to the resolve phase - - InstallFlags { - installDocumentation = packageConfigDocumentation, - installRunTests = packageConfigRunTests - } = installFlags - - HaddockFlags { - haddockHoogle = packageConfigHaddockHoogle, - haddockHtml = packageConfigHaddockHtml, - haddockHtmlLocation = packageConfigHaddockHtmlLocation, - haddockForeignLibs = packageConfigHaddockForeignLibs, - haddockForHackage = packageConfigHaddockForHackage, - haddockExecutables = packageConfigHaddockExecutables, - haddockTestSuites = packageConfigHaddockTestSuites, - haddockBenchmarks = packageConfigHaddockBenchmarks, - haddockInternal = packageConfigHaddockInternal, - haddockCss = packageConfigHaddockCss, - haddockLinkedSource = packageConfigHaddockLinkedSource, - haddockQuickJump = packageConfigHaddockQuickJump, - haddockHscolourCss = packageConfigHaddockHscolourCss, - haddockContents = packageConfigHaddockContents - } = haddockFlags - - TestFlags { - testHumanLog = packageConfigTestHumanLog, - testMachineLog = packageConfigTestMachineLog, - testShowDetails = packageConfigTestShowDetails, - testKeepTix = packageConfigTestKeepTix, - testWrapper = packageConfigTestWrapper, - testFailWhenNoTestSuites = packageConfigTestFailWhenNoTestSuites, - testOptions = packageConfigTestTestOptions - } = testFlags - - BenchmarkFlags { - benchmarkOptions = packageConfigBenchmarkOptions - } = benchmarkFlags - - --- | Helper used by other conversion functions that returns the --- 'ProjectConfigBuildOnly' subset of the 'ProjectConfig'. --- -convertLegacyBuildOnlyFlags :: GlobalFlags -> ConfigFlags - -> InstallFlags -> ClientInstallFlags - -> HaddockFlags -> TestFlags - -> BenchmarkFlags - -> ProjectConfigBuildOnly -convertLegacyBuildOnlyFlags globalFlags configFlags - installFlags clientInstallFlags - haddockFlags _ _ = - ProjectConfigBuildOnly{..} - where - projectConfigClientInstallFlags = clientInstallFlags - GlobalFlags { - globalCacheDir = projectConfigCacheDir, - globalLogsDir = projectConfigLogsDir, - globalWorldFile = _, - globalHttpTransport = projectConfigHttpTransport, - globalIgnoreExpiry = projectConfigIgnoreExpiry - } = globalFlags - - ConfigFlags { - configVerbosity = projectConfigVerbosity - } = configFlags - - InstallFlags { - installDryRun = projectConfigDryRun, - installOnly = _, - installOnlyDeps = projectConfigOnlyDeps, - installRootCmd = _, - installSummaryFile = projectConfigSummaryFile, - installLogFile = projectConfigLogFile, - installBuildReports = projectConfigBuildReports, - installReportPlanningFailure = projectConfigReportPlanningFailure, - installSymlinkBinDir = projectConfigSymlinkBinDir, - installOneShot = projectConfigOneShot, - installNumJobs = projectConfigNumJobs, - installKeepGoing = projectConfigKeepGoing, - installOfflineMode = projectConfigOfflineMode - } = installFlags - - HaddockFlags { - haddockKeepTempFiles = projectConfigKeepTempFiles --TODO: this ought to live elsewhere - } = haddockFlags - - -convertToLegacyProjectConfig :: ProjectConfig -> LegacyProjectConfig -convertToLegacyProjectConfig - projectConfig@ProjectConfig { - projectPackages, - projectPackagesOptional, - projectPackagesRepo, - projectPackagesNamed, - projectConfigAllPackages, - projectConfigLocalPackages, - projectConfigSpecificPackage - } = - LegacyProjectConfig { - legacyPackages = projectPackages, - legacyPackagesOptional = projectPackagesOptional, - legacyPackagesRepo = projectPackagesRepo, - legacyPackagesNamed = projectPackagesNamed, - legacySharedConfig = convertToLegacySharedConfig projectConfig, - legacyAllConfig = convertToLegacyPerPackageConfig - projectConfigAllPackages, - legacyLocalConfig = convertToLegacyAllPackageConfig projectConfig - <> convertToLegacyPerPackageConfig - projectConfigLocalPackages, - legacySpecificConfig = fmap convertToLegacyPerPackageConfig - projectConfigSpecificPackage - } - -convertToLegacySharedConfig :: ProjectConfig -> LegacySharedConfig -convertToLegacySharedConfig - ProjectConfig { - projectConfigBuildOnly = ProjectConfigBuildOnly {..}, - projectConfigShared = ProjectConfigShared {..}, - projectConfigAllPackages = PackageConfig { - packageConfigDocumentation - } - } = - - LegacySharedConfig - { legacyGlobalFlags = globalFlags - , legacyConfigureShFlags = configFlags - , legacyConfigureExFlags = configExFlags - , legacyInstallFlags = installFlags - , legacyClientInstallFlags = projectConfigClientInstallFlags - , legacyProjectFlags = projectFlags - } - where - globalFlags = GlobalFlags { - globalVersion = mempty, - globalNumericVersion = mempty, - globalConfigFile = projectConfigConfigFile, - globalConstraintsFile = mempty, - globalRemoteRepos = projectConfigRemoteRepos, - globalCacheDir = projectConfigCacheDir, - globalLocalNoIndexRepos = projectConfigLocalNoIndexRepos, - globalActiveRepos = projectConfigActiveRepos, - globalLogsDir = projectConfigLogsDir, - globalWorldFile = mempty, - globalIgnoreExpiry = projectConfigIgnoreExpiry, - globalHttpTransport = projectConfigHttpTransport, - globalNix = mempty, - globalStoreDir = projectConfigStoreDir, - globalProgPathExtra = projectConfigProgPathExtra - } - - configFlags = mempty { - configVerbosity = projectConfigVerbosity, - configDistPref = projectConfigDistDir - } - - configExFlags = ConfigExFlags { - configCabalVersion = projectConfigCabalVersion, - configExConstraints = projectConfigConstraints, - configPreferences = projectConfigPreferences, - configSolver = projectConfigSolver, - configAllowOlder = projectConfigAllowOlder, - configAllowNewer = projectConfigAllowNewer, - configWriteGhcEnvironmentFilesPolicy - = projectConfigWriteGhcEnvironmentFilesPolicy - } - - installFlags = InstallFlags { - installDocumentation = packageConfigDocumentation, - installHaddockIndex = projectConfigHaddockIndex, - installDest = Flag NoCopyDest, - installDryRun = projectConfigDryRun, - installReinstall = mempty, --projectConfigReinstall, - installAvoidReinstalls = mempty, --projectConfigAvoidReinstalls, - installOverrideReinstall = mempty, --projectConfigOverrideReinstall, - installMaxBackjumps = projectConfigMaxBackjumps, - installUpgradeDeps = mempty, --projectConfigUpgradeDeps, - installReorderGoals = projectConfigReorderGoals, - installCountConflicts = projectConfigCountConflicts, - installFineGrainedConflicts = projectConfigFineGrainedConflicts, - installMinimizeConflictSet = projectConfigMinimizeConflictSet, - installIndependentGoals = projectConfigIndependentGoals, - installShadowPkgs = mempty, --projectConfigShadowPkgs, - installStrongFlags = projectConfigStrongFlags, - installAllowBootLibInstalls = projectConfigAllowBootLibInstalls, - installOnlyConstrained = projectConfigOnlyConstrained, - installOnly = mempty, - installOnlyDeps = projectConfigOnlyDeps, - installIndexState = projectConfigIndexState, - installRootCmd = mempty, --no longer supported - installSummaryFile = projectConfigSummaryFile, - installLogFile = projectConfigLogFile, - installBuildReports = projectConfigBuildReports, - installReportPlanningFailure = projectConfigReportPlanningFailure, - installSymlinkBinDir = projectConfigSymlinkBinDir, - installPerComponent = projectConfigPerComponent, - installOneShot = projectConfigOneShot, - installNumJobs = projectConfigNumJobs, - installKeepGoing = projectConfigKeepGoing, - installRunTests = mempty, - installOfflineMode = projectConfigOfflineMode - } - - projectFlags = ProjectFlags - { flagProjectFileName = projectConfigProjectFile - , flagIgnoreProject = projectConfigIgnoreProject - } - - -convertToLegacyAllPackageConfig :: ProjectConfig -> LegacyPackageConfig -convertToLegacyAllPackageConfig - ProjectConfig { - projectConfigBuildOnly = ProjectConfigBuildOnly {..}, - projectConfigShared = ProjectConfigShared {..} - } = - - LegacyPackageConfig { - legacyConfigureFlags = configFlags, - legacyInstallPkgFlags= mempty, - legacyHaddockFlags = haddockFlags, - legacyTestFlags = mempty, - legacyBenchmarkFlags = mempty - } - where - configFlags = ConfigFlags { - configArgs = mempty, - configPrograms_ = mempty, - configProgramPaths = mempty, - configProgramArgs = mempty, - configProgramPathExtra = mempty, - configHcFlavor = projectConfigHcFlavor, - configHcPath = projectConfigHcPath, - configHcPkg = projectConfigHcPkg, - configInstantiateWith = mempty, - configVanillaLib = mempty, - configProfLib = mempty, - configSharedLib = mempty, - configStaticLib = mempty, - configDynExe = mempty, - configFullyStaticExe = mempty, - configProfExe = mempty, - configProf = mempty, - configProfDetail = mempty, - configProfLibDetail = mempty, - configConfigureArgs = mempty, - configOptimization = mempty, - configProgPrefix = mempty, - configProgSuffix = mempty, - configInstallDirs = mempty, - configScratchDir = mempty, - configDistPref = mempty, - configCabalFilePath = mempty, - configVerbosity = mempty, - configUserInstall = mempty, --projectConfigUserInstall, - configPackageDBs = mempty, --projectConfigPackageDBs, - configGHCiLib = mempty, - configSplitSections = mempty, - configSplitObjs = mempty, - configStripExes = mempty, - configStripLibs = mempty, - configExtraLibDirs = mempty, - configExtraFrameworkDirs = mempty, - configConstraints = mempty, - configDependencies = mempty, - configExtraIncludeDirs = mempty, - configDeterministic = mempty, - configIPID = mempty, - configCID = mempty, - configConfigurationsFlags = mempty, - configTests = mempty, - configCoverage = mempty, --TODO: don't merge - configLibCoverage = mempty, --TODO: don't merge - configExactConfiguration = mempty, - configBenchmarks = mempty, - configFlagError = mempty, --TODO: ??? - configRelocatable = mempty, - configDebugInfo = mempty, - configUseResponseFiles = mempty, - configAllowDependingOnPrivateLibs = mempty - } - - haddockFlags = mempty { - haddockKeepTempFiles = projectConfigKeepTempFiles - } - - -convertToLegacyPerPackageConfig :: PackageConfig -> LegacyPackageConfig -convertToLegacyPerPackageConfig PackageConfig {..} = - LegacyPackageConfig { - legacyConfigureFlags = configFlags, - legacyInstallPkgFlags = installFlags, - legacyHaddockFlags = haddockFlags, - legacyTestFlags = testFlags, - legacyBenchmarkFlags = benchmarkFlags - } - where - configFlags = ConfigFlags { - configArgs = mempty, - configPrograms_ = configPrograms_ mempty, - configProgramPaths = Map.toList (getMapLast packageConfigProgramPaths), - configProgramArgs = Map.toList (getMapMappend packageConfigProgramArgs), - configProgramPathExtra = packageConfigProgramPathExtra, - configHcFlavor = mempty, - configHcPath = mempty, - configHcPkg = mempty, - configInstantiateWith = mempty, - configVanillaLib = packageConfigVanillaLib, - configProfLib = packageConfigProfLib, - configSharedLib = packageConfigSharedLib, - configStaticLib = packageConfigStaticLib, - configDynExe = packageConfigDynExe, - configFullyStaticExe = packageConfigFullyStaticExe, - configProfExe = packageConfigProfExe, - configProf = packageConfigProf, - configProfDetail = packageConfigProfDetail, - configProfLibDetail = packageConfigProfLibDetail, - configConfigureArgs = packageConfigConfigureArgs, - configOptimization = packageConfigOptimization, - configProgPrefix = packageConfigProgPrefix, - configProgSuffix = packageConfigProgSuffix, - configInstallDirs = mempty, - configScratchDir = mempty, - configDistPref = mempty, - configCabalFilePath = mempty, - configVerbosity = mempty, - configUserInstall = mempty, - configPackageDBs = mempty, - configGHCiLib = packageConfigGHCiLib, - configSplitSections = packageConfigSplitSections, - configSplitObjs = packageConfigSplitObjs, - configStripExes = packageConfigStripExes, - configStripLibs = packageConfigStripLibs, - configExtraLibDirs = packageConfigExtraLibDirs, - configExtraFrameworkDirs = packageConfigExtraFrameworkDirs, - configConstraints = mempty, - configDependencies = mempty, - configExtraIncludeDirs = packageConfigExtraIncludeDirs, - configIPID = mempty, - configCID = mempty, - configDeterministic = mempty, - configConfigurationsFlags = packageConfigFlagAssignment, - configTests = packageConfigTests, - configCoverage = packageConfigCoverage, --TODO: don't merge - configLibCoverage = packageConfigCoverage, --TODO: don't merge - configExactConfiguration = mempty, - configBenchmarks = packageConfigBenchmarks, - configFlagError = mempty, --TODO: ??? - configRelocatable = packageConfigRelocatable, - configDebugInfo = packageConfigDebugInfo, - configUseResponseFiles = mempty, - configAllowDependingOnPrivateLibs = mempty - } - - installFlags = mempty { - installDocumentation = packageConfigDocumentation, - installRunTests = packageConfigRunTests - } - - haddockFlags = HaddockFlags { - haddockProgramPaths = mempty, - haddockProgramArgs = mempty, - haddockHoogle = packageConfigHaddockHoogle, - haddockHtml = packageConfigHaddockHtml, - haddockHtmlLocation = packageConfigHaddockHtmlLocation, - haddockForHackage = packageConfigHaddockForHackage, - haddockForeignLibs = packageConfigHaddockForeignLibs, - haddockExecutables = packageConfigHaddockExecutables, - haddockTestSuites = packageConfigHaddockTestSuites, - haddockBenchmarks = packageConfigHaddockBenchmarks, - haddockInternal = packageConfigHaddockInternal, - haddockCss = packageConfigHaddockCss, - haddockLinkedSource = packageConfigHaddockLinkedSource, - haddockQuickJump = packageConfigHaddockQuickJump, - haddockHscolourCss = packageConfigHaddockHscolourCss, - haddockContents = packageConfigHaddockContents, - haddockDistPref = mempty, - haddockKeepTempFiles = mempty, - haddockVerbosity = mempty, - haddockCabalFilePath = mempty, - haddockArgs = mempty - } - - testFlags = TestFlags { - testDistPref = mempty, - testVerbosity = mempty, - testHumanLog = packageConfigTestHumanLog, - testMachineLog = packageConfigTestMachineLog, - testShowDetails = packageConfigTestShowDetails, - testKeepTix = packageConfigTestKeepTix, - testWrapper = packageConfigTestWrapper, - testFailWhenNoTestSuites = packageConfigTestFailWhenNoTestSuites, - testOptions = packageConfigTestTestOptions - } - - benchmarkFlags = BenchmarkFlags { - benchmarkDistPref = mempty, - benchmarkVerbosity = mempty, - benchmarkOptions = packageConfigBenchmarkOptions - } - ------------------------------------------------- --- Parsing and showing the project config file --- - -parseLegacyProjectConfig :: String -> ParseResult LegacyProjectConfig -parseLegacyProjectConfig = - parseConfig legacyProjectConfigFieldDescrs - legacyPackageConfigSectionDescrs - legacyPackageConfigFGSectionDescrs - mempty - -showLegacyProjectConfig :: LegacyProjectConfig -> String -showLegacyProjectConfig config = - Disp.render $ - showConfig legacyProjectConfigFieldDescrs - legacyPackageConfigSectionDescrs - legacyPackageConfigFGSectionDescrs - config - $+$ - Disp.text "" - - -legacyProjectConfigFieldDescrs :: [FieldDescr LegacyProjectConfig] -legacyProjectConfigFieldDescrs = - - [ newLineListField "packages" - (Disp.text . renderPackageLocationToken) parsePackageLocationTokenQ - legacyPackages - (\v flags -> flags { legacyPackages = v }) - , newLineListField "optional-packages" - (Disp.text . renderPackageLocationToken) parsePackageLocationTokenQ - legacyPackagesOptional - (\v flags -> flags { legacyPackagesOptional = v }) - , commaNewLineListFieldParsec "extra-packages" - pretty parsec - legacyPackagesNamed - (\v flags -> flags { legacyPackagesNamed = v }) - ] - - ++ map (liftField - legacySharedConfig - (\flags conf -> conf { legacySharedConfig = flags })) - legacySharedConfigFieldDescrs - - ++ map (liftField - legacyLocalConfig - (\flags conf -> conf { legacyLocalConfig = flags })) - legacyPackageConfigFieldDescrs - --- | This is a bit tricky since it has to cover globs which have embedded @,@ --- chars. But we don't just want to parse strictly as a glob since we want to --- allow http urls which don't parse as globs, and possibly some --- system-dependent file paths. So we parse fairly liberally as a token, but --- we allow @,@ inside matched @{}@ braces. --- -parsePackageLocationTokenQ :: ReadP r String -parsePackageLocationTokenQ = parseHaskellString - Parse.<++ parsePackageLocationToken - where - parsePackageLocationToken :: ReadP r String - parsePackageLocationToken = fmap fst (Parse.gather outerTerm) - where - outerTerm = alternateEither1 outerToken (braces innerTerm) - innerTerm = alternateEither innerToken (braces innerTerm) - outerToken = Parse.munch1 outerChar >> return () - innerToken = Parse.munch1 innerChar >> return () - outerChar c = not (isSpace c || c == '{' || c == '}' || c == ',') - innerChar c = not (isSpace c || c == '{' || c == '}') - braces = Parse.between (Parse.char '{') (Parse.char '}') - - alternateEither, alternateEither1, - alternatePQs, alternate1PQs, alternateQsP, alternate1QsP - :: ReadP r () -> ReadP r () -> ReadP r () - - alternateEither1 p q = alternate1PQs p q +++ alternate1QsP q p - alternateEither p q = alternateEither1 p q +++ return () - alternate1PQs p q = p >> alternateQsP q p - alternatePQs p q = alternate1PQs p q +++ return () - alternate1QsP q p = Parse.many1 q >> alternatePQs p q - alternateQsP q p = alternate1QsP q p +++ return () - -renderPackageLocationToken :: String -> String -renderPackageLocationToken s | needsQuoting = show s - | otherwise = s - where - needsQuoting = not (ok 0 s) - || s == "." -- . on its own on a line has special meaning - || take 2 s == "--" -- on its own line is comment syntax - --TODO: [code cleanup] these "." and "--" escaping issues - -- ought to be dealt with systematically in ParseUtils. - ok :: Int -> String -> Bool - ok n [] = n == 0 - ok _ ('"':_) = False - ok n ('{':cs) = ok (n+1) cs - ok n ('}':cs) = ok (n-1) cs - ok n (',':cs) = (n > 0) && ok n cs - ok _ (c:_) - | isSpace c = False - ok n (_ :cs) = ok n cs - - -legacySharedConfigFieldDescrs :: [FieldDescr LegacySharedConfig] -legacySharedConfigFieldDescrs = concat - [ liftFields - legacyGlobalFlags - (\flags conf -> conf { legacyGlobalFlags = flags }) - . addFields - [ newLineListField "extra-prog-path-shared-only" - showTokenQ parseTokenQ - (fromNubList . globalProgPathExtra) - (\v conf -> conf { globalProgPathExtra = toNubList v }) - ] - . filterFields - [ "remote-repo-cache" - , "logs-dir", "store-dir", "ignore-expiry", "http-transport" - , "active-repositories" - ] - . commandOptionsToFields - $ commandOptions (globalCommand []) ParseArgs - - , liftFields - legacyConfigureShFlags - (\flags conf -> conf { legacyConfigureShFlags = flags }) - . filterFields ["verbose", "builddir" ] - . commandOptionsToFields - $ configureOptions ParseArgs - - , liftFields - legacyConfigureExFlags - (\flags conf -> conf { legacyConfigureExFlags = flags }) - . addFields - [ commaNewLineListFieldParsec "constraints" - (pretty . fst) (fmap (\constraint -> (constraint, constraintSrc)) parsec) - configExConstraints (\v conf -> conf { configExConstraints = v }) - - , commaNewLineListFieldParsec "preferences" - pretty parsec - configPreferences (\v conf -> conf { configPreferences = v }) - - , monoidFieldParsec "allow-older" - (maybe mempty pretty) (fmap Just parsec) - (fmap unAllowOlder . configAllowOlder) - (\v conf -> conf { configAllowOlder = fmap AllowOlder v }) - - , monoidFieldParsec "allow-newer" - (maybe mempty pretty) (fmap Just parsec) - (fmap unAllowNewer . configAllowNewer) - (\v conf -> conf { configAllowNewer = fmap AllowNewer v }) - ] - . filterFields - [ "cabal-lib-version", "solver", "write-ghc-environment-files" - -- not "constraint" or "preference", we use our own plural ones above - ] - . commandOptionsToFields - $ configureExOptions ParseArgs constraintSrc - - , liftFields - legacyInstallFlags - (\flags conf -> conf { legacyInstallFlags = flags }) - . addFields - [ newLineListField "build-summary" - (showTokenQ . fromPathTemplate) (fmap toPathTemplate parseTokenQ) - (fromNubList . installSummaryFile) - (\v conf -> conf { installSummaryFile = toNubList v }) - ] - . filterFields - [ "doc-index-file" - , "root-cmd", "symlink-bindir" - , "build-log" - , "remote-build-reporting", "report-planning-failure" - , "one-shot", "jobs", "keep-going", "offline", "per-component" - -- solver flags: - , "max-backjumps", "reorder-goals", "count-conflicts" - , "fine-grained-conflicts" , "minimize-conflict-set", "independent-goals" - , "strong-flags" , "allow-boot-library-installs" - , "reject-unconstrained-dependencies", "index-state" - ] - . commandOptionsToFields - $ installOptions ParseArgs - - , liftFields - legacyClientInstallFlags - (\flags conf -> conf { legacyClientInstallFlags = flags }) - . commandOptionsToFields - $ clientInstallOptions ParseArgs - - , liftFields - legacyProjectFlags - (\flags conf -> conf { legacyProjectFlags = flags }) - . commandOptionsToFields - $ projectFlagsOptions ParseArgs - - ] - where - constraintSrc = ConstraintSourceProjectConfig "TODO" -- TODO: is a filepath - - -legacyPackageConfigFieldDescrs :: [FieldDescr LegacyPackageConfig] -legacyPackageConfigFieldDescrs = - ( liftFields - legacyConfigureFlags - (\flags conf -> conf { legacyConfigureFlags = flags }) - . addFields - [ newLineListField "extra-include-dirs" - showTokenQ parseTokenQ - configExtraIncludeDirs - (\v conf -> conf { configExtraIncludeDirs = v }) - , newLineListField "extra-lib-dirs" - showTokenQ parseTokenQ - configExtraLibDirs - (\v conf -> conf { configExtraLibDirs = v }) - , newLineListField "extra-framework-dirs" - showTokenQ parseTokenQ - configExtraFrameworkDirs - (\v conf -> conf { configExtraFrameworkDirs = v }) - , newLineListField "extra-prog-path" - showTokenQ parseTokenQ - (fromNubList . configProgramPathExtra) - (\v conf -> conf { configProgramPathExtra = toNubList v }) - , newLineListField "configure-options" - showTokenQ parseTokenQ - configConfigureArgs - (\v conf -> conf { configConfigureArgs = v }) - , simpleFieldParsec "flags" - dispFlagAssignment parsecFlagAssignment - configConfigurationsFlags - (\v conf -> conf { configConfigurationsFlags = v }) - ] - . filterFields - [ "with-compiler", "with-hc-pkg" - , "program-prefix", "program-suffix" - , "library-vanilla", "library-profiling" - , "shared", "static", "executable-dynamic", "executable-static" - , "profiling", "executable-profiling" - , "profiling-detail", "library-profiling-detail" - , "library-for-ghci", "split-objs", "split-sections" - , "executable-stripping", "library-stripping" - , "tests", "benchmarks" - , "coverage", "library-coverage" - , "relocatable" - -- not "extra-include-dirs", "extra-lib-dirs", "extra-framework-dirs" - -- or "extra-prog-path". We use corrected ones above that parse - -- as list fields. - ] - . commandOptionsToFields - ) (configureOptions ParseArgs) - ++ - liftFields - legacyConfigureFlags - (\flags conf -> conf { legacyConfigureFlags = flags }) - [ overrideFieldCompiler - , overrideFieldOptimization - , overrideFieldDebugInfo - ] - ++ - ( liftFields - legacyInstallPkgFlags - (\flags conf -> conf { legacyInstallPkgFlags = flags }) - . filterFields - [ "documentation", "run-tests" - ] - . commandOptionsToFields - ) (installOptions ParseArgs) - ++ - ( liftFields - legacyHaddockFlags - (\flags conf -> conf { legacyHaddockFlags = flags }) - . mapFieldNames - ("haddock-"++) - . addFields - [ simpleFieldParsec "for-hackage" - -- TODO: turn this into a library function - (fromFlagOrDefault Disp.empty . fmap pretty) (toFlag <$> parsec <|> pure mempty) - haddockForHackage (\v conf -> conf { haddockForHackage = v }) - ] - . filterFields - [ "hoogle", "html", "html-location" - , "foreign-libraries" - , "executables", "tests", "benchmarks", "all", "internal", "css" - , "hyperlink-source", "quickjump", "hscolour-css" - , "contents-location", "keep-temp-files" - ] - . commandOptionsToFields - ) (haddockOptions ParseArgs) - ++ - ( liftFields - legacyTestFlags - (\flags conf -> conf { legacyTestFlags = flags }) - . mapFieldNames - prefixTest - . addFields - [ newLineListField "test-options" - (showTokenQ . fromPathTemplate) (fmap toPathTemplate parseTokenQ) - testOptions - (\v conf -> conf { testOptions = v }) - ] - . filterFields - [ "log", "machine-log", "show-details", "keep-tix-files" - , "fail-when-no-test-suites", "test-wrapper" ] - . commandOptionsToFields - ) (testOptions' ParseArgs) - ++ - ( liftFields - legacyBenchmarkFlags - (\flags conf -> conf { legacyBenchmarkFlags = flags }) - . addFields - [ newLineListField "benchmark-options" - (showTokenQ . fromPathTemplate) (fmap toPathTemplate parseTokenQ) - benchmarkOptions - (\v conf -> conf { benchmarkOptions = v }) - ] - . filterFields - [] - . commandOptionsToFields - ) (benchmarkOptions' ParseArgs) - - - where - overrideFieldCompiler = - simpleFieldParsec "compiler" - (fromFlagOrDefault Disp.empty . fmap pretty) - (toFlag <$> parsec <|> pure mempty) - configHcFlavor (\v flags -> flags { configHcFlavor = v }) - - - -- TODO: [code cleanup] The following is a hack. The "optimization" and - -- "debug-info" fields are OptArg, and viewAsFieldDescr fails on that. - -- Instead of a hand-written parser and printer, we should handle this case - -- properly in the library. - - overrideFieldOptimization = - liftField configOptimization - (\v flags -> flags { configOptimization = v }) $ - let name = "optimization" in - FieldDescr name - (\f -> case f of - Flag NoOptimisation -> Disp.text "False" - Flag NormalOptimisation -> Disp.text "True" - Flag MaximumOptimisation -> Disp.text "2" - _ -> Disp.empty) - (\line str _ -> case () of - _ | str == "False" -> ParseOk [] (Flag NoOptimisation) - | str == "True" -> ParseOk [] (Flag NormalOptimisation) - | str == "0" -> ParseOk [] (Flag NoOptimisation) - | str == "1" -> ParseOk [] (Flag NormalOptimisation) - | str == "2" -> ParseOk [] (Flag MaximumOptimisation) - | lstr == "false" -> ParseOk [caseWarning] (Flag NoOptimisation) - | lstr == "true" -> ParseOk [caseWarning] (Flag NormalOptimisation) - | otherwise -> ParseFailed (NoParse name line) - where - lstr = lowercase str - caseWarning = PWarning $ - "The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'.") - - overrideFieldDebugInfo = - liftField configDebugInfo (\v flags -> flags { configDebugInfo = v }) $ - let name = "debug-info" in - FieldDescr name - (\f -> case f of - Flag NoDebugInfo -> Disp.text "False" - Flag MinimalDebugInfo -> Disp.text "1" - Flag NormalDebugInfo -> Disp.text "True" - Flag MaximalDebugInfo -> Disp.text "3" - _ -> Disp.empty) - (\line str _ -> case () of - _ | str == "False" -> ParseOk [] (Flag NoDebugInfo) - | str == "True" -> ParseOk [] (Flag NormalDebugInfo) - | str == "0" -> ParseOk [] (Flag NoDebugInfo) - | str == "1" -> ParseOk [] (Flag MinimalDebugInfo) - | str == "2" -> ParseOk [] (Flag NormalDebugInfo) - | str == "3" -> ParseOk [] (Flag MaximalDebugInfo) - | lstr == "false" -> ParseOk [caseWarning] (Flag NoDebugInfo) - | lstr == "true" -> ParseOk [caseWarning] (Flag NormalDebugInfo) - | otherwise -> ParseFailed (NoParse name line) - where - lstr = lowercase str - caseWarning = PWarning $ - "The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'.") - - prefixTest name | "test-" `isPrefixOf` name = name - | otherwise = "test-" ++ name - - -legacyPackageConfigFGSectionDescrs - :: ( FieldGrammar c g, Applicative (g SourceRepoList) - , c (Identity RepoType), c (List NoCommaFSep FilePathNT String) - ) - => [FGSectionDescr g LegacyProjectConfig] -legacyPackageConfigFGSectionDescrs = - [ packageRepoSectionDescr - ] - -legacyPackageConfigSectionDescrs :: [SectionDescr LegacyProjectConfig] -legacyPackageConfigSectionDescrs = - [ packageSpecificOptionsSectionDescr - , liftSection - legacyLocalConfig - (\flags conf -> conf { legacyLocalConfig = flags }) - programOptionsSectionDescr - , liftSection - legacyLocalConfig - (\flags conf -> conf { legacyLocalConfig = flags }) - programLocationsSectionDescr - , liftSection - legacySharedConfig - (\flags conf -> conf { legacySharedConfig = flags }) $ - liftSection - legacyGlobalFlags - (\flags conf -> conf { legacyGlobalFlags = flags }) - remoteRepoSectionDescr - ] - -packageRepoSectionDescr - :: ( FieldGrammar c g, Applicative (g SourceRepoList) - , c (Identity RepoType), c (List NoCommaFSep FilePathNT String) - ) - => FGSectionDescr g LegacyProjectConfig -packageRepoSectionDescr = FGSectionDescr - { fgSectionName = "source-repository-package" - , fgSectionGrammar = sourceRepositoryPackageGrammar - , fgSectionGet = map (\x->("", x)) . legacyPackagesRepo - , fgSectionSet = - \lineno unused pkgrepo projconf -> do - unless (null unused) $ - syntaxError lineno "the section 'source-repository-package' takes no arguments" - return projconf { - legacyPackagesRepo = legacyPackagesRepo projconf ++ [pkgrepo] - } - } - --- | The definitions of all the fields that can appear in the @package pkgfoo@ --- and @package *@ sections of the @cabal.project@-format files. --- -packageSpecificOptionsFieldDescrs :: [FieldDescr LegacyPackageConfig] -packageSpecificOptionsFieldDescrs = - legacyPackageConfigFieldDescrs - ++ programOptionsFieldDescrs - (configProgramArgs . legacyConfigureFlags) - (\args pkgconf -> pkgconf { - legacyConfigureFlags = (legacyConfigureFlags pkgconf) { - configProgramArgs = args - } - } - ) - ++ liftFields - legacyConfigureFlags - (\flags pkgconf -> pkgconf { - legacyConfigureFlags = flags - } - ) - programLocationsFieldDescrs - --- | The definition of the @package pkgfoo@ sections of the @cabal.project@-format --- files. This section is per-package name. The special package @*@ applies to all --- packages used anywhere by the project, locally or as dependencies. --- -packageSpecificOptionsSectionDescr :: SectionDescr LegacyProjectConfig -packageSpecificOptionsSectionDescr = - SectionDescr { - sectionName = "package", - sectionFields = packageSpecificOptionsFieldDescrs, - sectionSubsections = [], - sectionGet = \projconf -> - [ (prettyShow pkgname, pkgconf) - | (pkgname, pkgconf) <- - Map.toList . getMapMappend - . legacySpecificConfig $ projconf ] - ++ [ ("*", legacyAllConfig projconf) ], - sectionSet = - \lineno pkgnamestr pkgconf projconf -> case pkgnamestr of - "*" -> return projconf { - legacyAllConfig = legacyAllConfig projconf <> pkgconf - } - _ -> do - pkgname <- case simpleParsec pkgnamestr of - Just pkgname -> return pkgname - Nothing -> syntaxError lineno $ - "a 'package' section requires a package name " - ++ "as an argument" - return projconf { - legacySpecificConfig = - MapMappend $ - Map.insertWith mappend pkgname pkgconf - (getMapMappend $ legacySpecificConfig projconf) - }, - sectionEmpty = mempty - } - -programOptionsFieldDescrs :: (a -> [(String, [String])]) - -> ([(String, [String])] -> a -> a) - -> [FieldDescr a] -programOptionsFieldDescrs get' set = - commandOptionsToFields - $ programDbOptions - defaultProgramDb - ParseArgs get' set - -programOptionsSectionDescr :: SectionDescr LegacyPackageConfig -programOptionsSectionDescr = - SectionDescr { - sectionName = "program-options", - sectionFields = programOptionsFieldDescrs - configProgramArgs - (\args conf -> conf { configProgramArgs = args }), - sectionSubsections = [], - sectionGet = (\x->[("", x)]) - . legacyConfigureFlags, - sectionSet = - \lineno unused confflags pkgconf -> do - unless (null unused) $ - syntaxError lineno "the section 'program-options' takes no arguments" - return pkgconf { - legacyConfigureFlags = legacyConfigureFlags pkgconf <> confflags - }, - sectionEmpty = mempty - } - -programLocationsFieldDescrs :: [FieldDescr ConfigFlags] -programLocationsFieldDescrs = - commandOptionsToFields - $ programDbPaths' - (++ "-location") - defaultProgramDb - ParseArgs - configProgramPaths - (\paths conf -> conf { configProgramPaths = paths }) - -programLocationsSectionDescr :: SectionDescr LegacyPackageConfig -programLocationsSectionDescr = - SectionDescr { - sectionName = "program-locations", - sectionFields = programLocationsFieldDescrs, - sectionSubsections = [], - sectionGet = (\x->[("", x)]) - . legacyConfigureFlags, - sectionSet = - \lineno unused confflags pkgconf -> do - unless (null unused) $ - syntaxError lineno "the section 'program-locations' takes no arguments" - return pkgconf { - legacyConfigureFlags = legacyConfigureFlags pkgconf <> confflags - }, - sectionEmpty = mempty - } - - --- | For each known program @PROG@ in 'progDb', produce a @PROG-options@ --- 'OptionField'. -programDbOptions - :: ProgramDb - -> ShowOrParseArgs - -> (flags -> [(String, [String])]) - -> ([(String, [String])] -> (flags -> flags)) - -> [OptionField flags] -programDbOptions progDb showOrParseArgs get' set = - case showOrParseArgs of - -- we don't want a verbose help text list so we just show a generic one: - ShowArgs -> [programOptions "PROG"] - ParseArgs -> map (programOptions . programName . fst) - (knownPrograms progDb) - where - programOptions prog = - option "" [prog ++ "-options"] - ("give extra options to " ++ prog) - get' set - (reqArg' "OPTS" (\args -> [(prog, splitArgs args)]) - (\progArgs -> [ joinsArgs args - | (prog', args) <- progArgs, prog==prog' ])) - - - joinsArgs = unwords . map escape - escape arg | any isSpace arg = "\"" ++ arg ++ "\"" - | otherwise = arg - - --- The implementation is slight hack: we parse all as remote repository --- but if the url schema is file+noindex, we switch to local. -remoteRepoSectionDescr :: SectionDescr GlobalFlags -remoteRepoSectionDescr = SectionDescr - { sectionName = "repository" - , sectionEmpty = emptyRemoteRepo (RepoName "") - , sectionFields = remoteRepoFields - , sectionSubsections = [] - , sectionGet = getS - , sectionSet = setS - } - where - getS :: GlobalFlags -> [(String, RemoteRepo)] - getS gf = - map (\x->(unRepoName $ remoteRepoName x, x)) (fromNubList (globalRemoteRepos gf)) - ++ - map (\x->(unRepoName $ localRepoName x, localToRemote x)) (fromNubList (globalLocalNoIndexRepos gf)) - - setS :: Int -> String -> RemoteRepo -> GlobalFlags -> ParseResult GlobalFlags - setS lineno reponame repo0 conf = do - repo1 <- postProcessRepo lineno reponame repo0 - case repo1 of - Left repo -> return conf - { globalLocalNoIndexRepos = overNubList (++[repo]) (globalLocalNoIndexRepos conf) - } - Right repo -> return conf - { globalRemoteRepos = overNubList (++[repo]) (globalRemoteRepos conf) - } - - localToRemote :: LocalRepo -> RemoteRepo - localToRemote (LocalRepo name path sharedCache) = (emptyRemoteRepo name) - { remoteRepoURI = URI "file+noindex:" Nothing path "" (if sharedCache then "#shared-cache" else "") - } - -------------------------------- --- Local field utils --- - --- | Parser combinator for simple fields which uses the field type's --- 'Monoid' instance for combining multiple occurrences of the field. -monoidFieldParsec - :: Monoid a => String -> (a -> Doc) -> ParsecParser a - -> (b -> a) -> (a -> b -> b) -> FieldDescr b -monoidFieldParsec name showF readF get' set = - liftField get' set' $ ParseUtils.fieldParsec name showF readF - where - set' xs b = set (get' b `mappend` xs) b - - ---TODO: [code cleanup] local redefinition that should replace the version in --- D.ParseUtils called showFilePath. This version escapes "." and "--" which --- otherwise are special syntax. -showTokenQ :: String -> Doc -showTokenQ "" = Disp.empty -showTokenQ x@('-':'-':_) = Disp.text (show x) -showTokenQ x@('.':[]) = Disp.text (show x) -showTokenQ x = showToken x - - --- Handy util -addFields :: [FieldDescr a] - -> ([FieldDescr a] -> [FieldDescr a]) -addFields = (++) diff --git a/cabal/cabal-install/Distribution/Client/ProjectConfig/Types.hs b/cabal/cabal-install/Distribution/Client/ProjectConfig/Types.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/ProjectConfig/Types.hs +++ /dev/null @@ -1,458 +0,0 @@ -{-# LANGUAGE DeriveGeneric, DeriveDataTypeable, GeneralizedNewtypeDeriving #-} - --- | Handling project configuration, types. --- -module Distribution.Client.ProjectConfig.Types ( - - -- * Types for project config - ProjectConfig(..), - ProjectConfigBuildOnly(..), - ProjectConfigShared(..), - ProjectConfigProvenance(..), - PackageConfig(..), - - -- * Resolving configuration - SolverSettings(..), - BuildTimeSettings(..), - - -- * Extra useful Monoids - MapLast(..), - MapMappend(..), - ) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Client.Types.Repo ( RemoteRepo, LocalRepo ) -import Distribution.Client.Types.AllowNewer ( AllowNewer(..), AllowOlder(..) ) -import Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy ( WriteGhcEnvironmentFilesPolicy ) -import Distribution.Client.Dependency.Types - ( PreSolver ) -import Distribution.Client.Targets - ( UserConstraint ) -import Distribution.Client.BuildReports.Types - ( ReportLevel(..) ) -import Distribution.Client.Types.SourceRepo (SourceRepoList) - -import Distribution.Client.IndexUtils.IndexState - ( TotalIndexState ) -import Distribution.Client.IndexUtils.ActiveRepos - ( ActiveRepos ) - -import Distribution.Client.CmdInstall.ClientInstallFlags - ( ClientInstallFlags(..) ) - -import Distribution.Solver.Types.Settings -import Distribution.Solver.Types.ConstraintSource - -import Distribution.Package - ( PackageName, PackageId, UnitId ) -import Distribution.Types.PackageVersionConstraint - ( PackageVersionConstraint ) -import Distribution.Version - ( Version ) -import Distribution.System - ( Platform ) -import Distribution.PackageDescription - ( FlagAssignment ) -import Distribution.Simple.Compiler - ( Compiler, CompilerFlavor - , OptimisationLevel(..), ProfDetailLevel, DebugInfoLevel(..) ) -import Distribution.Simple.Setup - ( Flag, HaddockTarget(..), TestShowDetails(..) ) -import Distribution.Simple.InstallDirs - ( PathTemplate ) -import Distribution.Utils.NubList - ( NubList ) - -import qualified Data.Map as Map - -------------------------------- --- Project config types --- - --- | This type corresponds directly to what can be written in the --- @cabal.project@ file. Other sources of configuration can also be injected --- into this type, such as the user-wide @~/.cabal/config@ file and the --- command line of @cabal configure@ or @cabal build@. --- --- Since it corresponds to the external project file it is an instance of --- 'Monoid' and all the fields can be empty. This also means there has to --- be a step where we resolve configuration. At a minimum resolving means --- applying defaults but it can also mean merging information from multiple --- sources. For example for package-specific configuration the project file --- can specify configuration that applies to all local packages, and then --- additional configuration for a specific package. --- --- Future directions: multiple profiles, conditionals. If we add these --- features then the gap between configuration as written in the config file --- and resolved settings we actually use will become even bigger. --- -data ProjectConfig - = ProjectConfig { - - -- | Packages in this project, including local dirs, local .cabal files - -- local and remote tarballs. When these are file globs, they must - -- match at least one package. - projectPackages :: [String], - - -- | Like 'projectConfigPackageGlobs' but /optional/ in the sense that - -- file globs are allowed to match nothing. The primary use case for - -- this is to be able to say @optional-packages: */@ to automagically - -- pick up deps that we unpack locally without erroring when - -- there aren't any. - projectPackagesOptional :: [String], - - -- | Packages in this project from remote source repositories. - projectPackagesRepo :: [SourceRepoList], - - -- | Packages in this project from hackage repositories. - projectPackagesNamed :: [PackageVersionConstraint], - - -- See respective types for an explanation of what these - -- values are about: - projectConfigBuildOnly :: ProjectConfigBuildOnly, - projectConfigShared :: ProjectConfigShared, - projectConfigProvenance :: Set ProjectConfigProvenance, - - -- | Configuration to be applied to *all* packages, - -- whether named in `cabal.project` or not. - projectConfigAllPackages :: PackageConfig, - - -- | Configuration to be applied to *local* packages; i.e., - -- any packages which are explicitly named in `cabal.project`. - projectConfigLocalPackages :: PackageConfig, - projectConfigSpecificPackage :: MapMappend PackageName PackageConfig - } - deriving (Eq, Show, Generic, Typeable) - --- | That part of the project configuration that only affects /how/ we build --- and not the /value/ of the things we build. This means this information --- does not need to be tracked for changes since it does not affect the --- outcome. --- -data ProjectConfigBuildOnly - = ProjectConfigBuildOnly { - projectConfigVerbosity :: Flag Verbosity, - projectConfigDryRun :: Flag Bool, - projectConfigOnlyDeps :: Flag Bool, - projectConfigSummaryFile :: NubList PathTemplate, - projectConfigLogFile :: Flag PathTemplate, - projectConfigBuildReports :: Flag ReportLevel, - projectConfigReportPlanningFailure :: Flag Bool, - projectConfigSymlinkBinDir :: Flag FilePath, - projectConfigOneShot :: Flag Bool, - projectConfigNumJobs :: Flag (Maybe Int), - projectConfigKeepGoing :: Flag Bool, - projectConfigOfflineMode :: Flag Bool, - projectConfigKeepTempFiles :: Flag Bool, - projectConfigHttpTransport :: Flag String, - projectConfigIgnoreExpiry :: Flag Bool, - projectConfigCacheDir :: Flag FilePath, - projectConfigLogsDir :: Flag FilePath, - projectConfigClientInstallFlags :: ClientInstallFlags - } - deriving (Eq, Show, Generic) - - --- | Project configuration that is shared between all packages in the project. --- In particular this includes configuration that affects the solver. --- -data ProjectConfigShared - = ProjectConfigShared { - projectConfigDistDir :: Flag FilePath, - projectConfigConfigFile :: Flag FilePath, - projectConfigProjectFile :: Flag FilePath, - projectConfigIgnoreProject :: Flag Bool, - projectConfigHcFlavor :: Flag CompilerFlavor, - projectConfigHcPath :: Flag FilePath, - projectConfigHcPkg :: Flag FilePath, - projectConfigHaddockIndex :: Flag PathTemplate, - - -- Things that only make sense for manual mode, not --local mode - -- too much control! - --projectConfigUserInstall :: Flag Bool, - --projectConfigInstallDirs :: InstallDirs (Flag PathTemplate), - --TODO: [required eventually] decide what to do with InstallDirs - -- currently we don't allow it to be specified in the config file - --projectConfigPackageDBs :: [Maybe PackageDB], - - -- configuration used both by the solver and other phases - projectConfigRemoteRepos :: NubList RemoteRepo, -- ^ Available Hackage servers. - projectConfigLocalNoIndexRepos :: NubList LocalRepo, - projectConfigActiveRepos :: Flag ActiveRepos, - projectConfigIndexState :: Flag TotalIndexState, - projectConfigStoreDir :: Flag FilePath, - - -- solver configuration - projectConfigConstraints :: [(UserConstraint, ConstraintSource)], - projectConfigPreferences :: [PackageVersionConstraint], - projectConfigCabalVersion :: Flag Version, --TODO: [required eventually] unused - projectConfigSolver :: Flag PreSolver, - projectConfigAllowOlder :: Maybe AllowOlder, - projectConfigAllowNewer :: Maybe AllowNewer, - projectConfigWriteGhcEnvironmentFilesPolicy - :: Flag WriteGhcEnvironmentFilesPolicy, - projectConfigMaxBackjumps :: Flag Int, - projectConfigReorderGoals :: Flag ReorderGoals, - projectConfigCountConflicts :: Flag CountConflicts, - projectConfigFineGrainedConflicts :: Flag FineGrainedConflicts, - projectConfigMinimizeConflictSet :: Flag MinimizeConflictSet, - projectConfigStrongFlags :: Flag StrongFlags, - projectConfigAllowBootLibInstalls :: Flag AllowBootLibInstalls, - projectConfigOnlyConstrained :: Flag OnlyConstrained, - projectConfigPerComponent :: Flag Bool, - projectConfigIndependentGoals :: Flag IndependentGoals, - - projectConfigProgPathExtra :: NubList FilePath - - -- More things that only make sense for manual mode, not --local mode - -- too much control! - --projectConfigShadowPkgs :: Flag Bool, - --projectConfigReinstall :: Flag Bool, - --projectConfigAvoidReinstalls :: Flag Bool, - --projectConfigOverrideReinstall :: Flag Bool, - --projectConfigUpgradeDeps :: Flag Bool - } - deriving (Eq, Show, Generic) - - --- | Specifies the provenance of project configuration, whether defaults were --- used or if the configuration was read from an explicit file path. -data ProjectConfigProvenance - - -- | The configuration is implicit due to no explicit configuration - -- being found. See 'Distribution.Client.ProjectConfig.readProjectConfig' - -- for how implicit configuration is determined. - = Implicit - - -- | The path the project configuration was explicitly read from. - -- | The configuration was explicitly read from the specified 'FilePath'. - | Explicit FilePath - deriving (Eq, Ord, Show, Generic) - - --- | Project configuration that is specific to each package, that is where we --- can in principle have different values for different packages in the same --- project. --- -data PackageConfig - = PackageConfig { - packageConfigProgramPaths :: MapLast String FilePath, - packageConfigProgramArgs :: MapMappend String [String], - packageConfigProgramPathExtra :: NubList FilePath, - packageConfigFlagAssignment :: FlagAssignment, - packageConfigVanillaLib :: Flag Bool, - packageConfigSharedLib :: Flag Bool, - packageConfigStaticLib :: Flag Bool, - packageConfigDynExe :: Flag Bool, - packageConfigFullyStaticExe :: Flag Bool, - packageConfigProf :: Flag Bool, --TODO: [code cleanup] sort out - packageConfigProfLib :: Flag Bool, -- this duplication - packageConfigProfExe :: Flag Bool, -- and consistency - packageConfigProfDetail :: Flag ProfDetailLevel, - packageConfigProfLibDetail :: Flag ProfDetailLevel, - packageConfigConfigureArgs :: [String], - packageConfigOptimization :: Flag OptimisationLevel, - packageConfigProgPrefix :: Flag PathTemplate, - packageConfigProgSuffix :: Flag PathTemplate, - packageConfigExtraLibDirs :: [FilePath], - packageConfigExtraFrameworkDirs :: [FilePath], - packageConfigExtraIncludeDirs :: [FilePath], - packageConfigGHCiLib :: Flag Bool, - packageConfigSplitSections :: Flag Bool, - packageConfigSplitObjs :: Flag Bool, - packageConfigStripExes :: Flag Bool, - packageConfigStripLibs :: Flag Bool, - packageConfigTests :: Flag Bool, - packageConfigBenchmarks :: Flag Bool, - packageConfigCoverage :: Flag Bool, - packageConfigRelocatable :: Flag Bool, - packageConfigDebugInfo :: Flag DebugInfoLevel, - packageConfigRunTests :: Flag Bool, --TODO: [required eventually] use this - packageConfigDocumentation :: Flag Bool, --TODO: [required eventually] use this - -- Haddock options - packageConfigHaddockHoogle :: Flag Bool, --TODO: [required eventually] use this - packageConfigHaddockHtml :: Flag Bool, --TODO: [required eventually] use this - packageConfigHaddockHtmlLocation :: Flag String, --TODO: [required eventually] use this - packageConfigHaddockForeignLibs :: Flag Bool, --TODO: [required eventually] use this - packageConfigHaddockExecutables :: Flag Bool, --TODO: [required eventually] use this - packageConfigHaddockTestSuites :: Flag Bool, --TODO: [required eventually] use this - packageConfigHaddockBenchmarks :: Flag Bool, --TODO: [required eventually] use this - packageConfigHaddockInternal :: Flag Bool, --TODO: [required eventually] use this - packageConfigHaddockCss :: Flag FilePath, --TODO: [required eventually] use this - packageConfigHaddockLinkedSource :: Flag Bool, --TODO: [required eventually] use this - packageConfigHaddockQuickJump :: Flag Bool, --TODO: [required eventually] use this - packageConfigHaddockHscolourCss :: Flag FilePath, --TODO: [required eventually] use this - packageConfigHaddockContents :: Flag PathTemplate, --TODO: [required eventually] use this - packageConfigHaddockForHackage :: Flag HaddockTarget, - -- Test options - packageConfigTestHumanLog :: Flag PathTemplate, - packageConfigTestMachineLog :: Flag PathTemplate, - packageConfigTestShowDetails :: Flag TestShowDetails, - packageConfigTestKeepTix :: Flag Bool, - packageConfigTestWrapper :: Flag FilePath, - packageConfigTestFailWhenNoTestSuites :: Flag Bool, - packageConfigTestTestOptions :: [PathTemplate], - -- Benchmark options - packageConfigBenchmarkOptions :: [PathTemplate] - } - deriving (Eq, Show, Generic) - -instance Binary ProjectConfig -instance Binary ProjectConfigBuildOnly -instance Binary ProjectConfigShared -instance Binary ProjectConfigProvenance -instance Binary PackageConfig - -instance Structured ProjectConfig -instance Structured ProjectConfigBuildOnly -instance Structured ProjectConfigShared -instance Structured ProjectConfigProvenance -instance Structured PackageConfig - --- | Newtype wrapper for 'Map' that provides a 'Monoid' instance that takes --- the last value rather than the first value for overlapping keys. -newtype MapLast k v = MapLast { getMapLast :: Map k v } - deriving (Eq, Show, Functor, Generic, Binary, Typeable) - -instance (Structured k, Structured v) => Structured (MapLast k v) - -instance Ord k => Monoid (MapLast k v) where - mempty = MapLast Map.empty - mappend = (<>) - -instance Ord k => Semigroup (MapLast k v) where - MapLast a <> MapLast b = MapLast $ Map.union b a - -- rather than Map.union which is the normal Map monoid instance - - --- | Newtype wrapper for 'Map' that provides a 'Monoid' instance that --- 'mappend's values of overlapping keys rather than taking the first. -newtype MapMappend k v = MapMappend { getMapMappend :: Map k v } - deriving (Eq, Show, Functor, Generic, Binary, Typeable) - -instance (Structured k, Structured v) => Structured (MapMappend k v) - -instance (Semigroup v, Ord k) => Monoid (MapMappend k v) where - mempty = MapMappend Map.empty - mappend = (<>) - -instance (Semigroup v, Ord k) => Semigroup (MapMappend k v) where - MapMappend a <> MapMappend b = MapMappend (Map.unionWith (<>) a b) - -- rather than Map.union which is the normal Map monoid instance - - -instance Monoid ProjectConfig where - mempty = gmempty - mappend = (<>) - -instance Semigroup ProjectConfig where - (<>) = gmappend - - -instance Monoid ProjectConfigBuildOnly where - mempty = gmempty - mappend = (<>) - -instance Semigroup ProjectConfigBuildOnly where - (<>) = gmappend - - -instance Monoid ProjectConfigShared where - mempty = gmempty - mappend = (<>) - -instance Semigroup ProjectConfigShared where - (<>) = gmappend - - -instance Monoid PackageConfig where - mempty = gmempty - mappend = (<>) - -instance Semigroup PackageConfig where - (<>) = gmappend - ----------------------------------------- --- Resolving configuration to settings --- - --- | Resolved configuration for the solver. The idea is that this is easier to --- use than the raw configuration because in the raw configuration everything --- is optional (monoidial). In the 'BuildTimeSettings' every field is filled --- in, if only with the defaults. --- --- Use 'resolveSolverSettings' to make one from the project config (by --- applying defaults etc). --- -data SolverSettings - = SolverSettings { - solverSettingRemoteRepos :: [RemoteRepo], -- ^ Available Hackage servers. - solverSettingLocalNoIndexRepos :: [LocalRepo], - solverSettingConstraints :: [(UserConstraint, ConstraintSource)], - solverSettingPreferences :: [PackageVersionConstraint], - solverSettingFlagAssignment :: FlagAssignment, -- ^ For all local packages - solverSettingFlagAssignments :: Map PackageName FlagAssignment, - solverSettingCabalVersion :: Maybe Version, --TODO: [required eventually] unused - solverSettingSolver :: PreSolver, - solverSettingAllowOlder :: AllowOlder, - solverSettingAllowNewer :: AllowNewer, - solverSettingMaxBackjumps :: Maybe Int, - solverSettingReorderGoals :: ReorderGoals, - solverSettingCountConflicts :: CountConflicts, - solverSettingFineGrainedConflicts :: FineGrainedConflicts, - solverSettingMinimizeConflictSet :: MinimizeConflictSet, - solverSettingStrongFlags :: StrongFlags, - solverSettingAllowBootLibInstalls :: AllowBootLibInstalls, - solverSettingOnlyConstrained :: OnlyConstrained, - solverSettingIndexState :: Maybe TotalIndexState, - solverSettingActiveRepos :: Maybe ActiveRepos, - solverSettingIndependentGoals :: IndependentGoals - -- Things that only make sense for manual mode, not --local mode - -- too much control! - --solverSettingShadowPkgs :: Bool, - --solverSettingReinstall :: Bool, - --solverSettingAvoidReinstalls :: Bool, - --solverSettingOverrideReinstall :: Bool, - --solverSettingUpgradeDeps :: Bool - } - deriving (Eq, Show, Generic, Typeable) - -instance Binary SolverSettings -instance Structured SolverSettings - - --- | Resolved configuration for things that affect how we build and not the --- value of the things we build. The idea is that this is easier to use than --- the raw configuration because in the raw configuration everything is --- optional (monoidial). In the 'BuildTimeSettings' every field is filled in, --- if only with the defaults. --- --- Use 'resolveBuildTimeSettings' to make one from the project config (by --- applying defaults etc). --- -data BuildTimeSettings - = BuildTimeSettings { - buildSettingDryRun :: Bool, - buildSettingOnlyDeps :: Bool, - buildSettingSummaryFile :: [PathTemplate], - buildSettingLogFile :: Maybe (Compiler -> Platform - -> PackageId -> UnitId - -> FilePath), - buildSettingLogVerbosity :: Verbosity, - buildSettingBuildReports :: ReportLevel, - buildSettingReportPlanningFailure :: Bool, - buildSettingSymlinkBinDir :: [FilePath], - buildSettingOneShot :: Bool, - buildSettingNumJobs :: Int, - buildSettingKeepGoing :: Bool, - buildSettingOfflineMode :: Bool, - buildSettingKeepTempFiles :: Bool, - buildSettingRemoteRepos :: [RemoteRepo], - buildSettingLocalNoIndexRepos :: [LocalRepo], - buildSettingCacheDir :: FilePath, - buildSettingHttpTransport :: Maybe String, - buildSettingIgnoreExpiry :: Bool, - buildSettingProgPathExtra :: [FilePath] - } diff --git a/cabal/cabal-install/Distribution/Client/ProjectFlags.hs b/cabal/cabal-install/Distribution/Client/ProjectFlags.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/ProjectFlags.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -module Distribution.Client.ProjectFlags ( - ProjectFlags(..), - defaultProjectFlags, - projectFlagsOptions, -) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.ReadE (succeedReadE) -import Distribution.Simple.Command (MkOptDescr, OptionField, ShowOrParseArgs (..), boolOpt', option, reqArg) -import Distribution.Simple.Setup (Flag (..), flagToList, flagToMaybe, toFlag, trueArg) - -data ProjectFlags = ProjectFlags - { flagProjectFileName :: Flag FilePath - -- ^ The cabal project file name; defaults to @cabal.project@. - -- The name itself denotes the cabal project file name, but it also - -- is the base of auxiliary project files, such as - -- @cabal.project.local@ and @cabal.project.freeze@ which are also - -- read and written out in some cases. If the path is not found - -- in the current working directory, we will successively probe - -- relative to parent directories until this name is found. - - , flagIgnoreProject :: Flag Bool - -- ^ Whether to ignore the local project (i.e. don't search for cabal.project) - -- The exact interpretation might be slightly different per command. - } - deriving (Show, Generic) - -defaultProjectFlags :: ProjectFlags -defaultProjectFlags = ProjectFlags - { flagProjectFileName = mempty - , flagIgnoreProject = toFlag False - -- Should we use 'Last' here? - } - -projectFlagsOptions :: ShowOrParseArgs -> [OptionField ProjectFlags] -projectFlagsOptions showOrParseArgs = - [ option [] ["project-file"] - "Set the name of the cabal.project file to search for in parent directories" - flagProjectFileName (\pf flags -> flags { flagProjectFileName = pf }) - (reqArg "FILE" (succeedReadE Flag) flagToList) - , option ['z'] ["ignore-project"] - "Ignore local project configuration" - flagIgnoreProject (\v flags -> flags { flagIgnoreProject = v }) - (yesNoOpt showOrParseArgs) - ] - -instance Monoid ProjectFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup ProjectFlags where - (<>) = gmappend - -yesNoOpt :: ShowOrParseArgs -> MkOptDescr (b -> Flag Bool) (Flag Bool -> b -> b) b -yesNoOpt ShowArgs sf lf = trueArg sf lf -yesNoOpt _ sf lf = boolOpt' flagToMaybe Flag (sf, lf) ([], map ("no-" ++) lf) sf lf diff --git a/cabal/cabal-install/Distribution/Client/ProjectOrchestration.hs b/cabal/cabal-install/Distribution/Client/ProjectOrchestration.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/ProjectOrchestration.hs +++ /dev/null @@ -1,1270 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} -{-# LANGUAGE RankNTypes, ScopedTypeVariables #-} - --- | This module deals with building and incrementally rebuilding a collection --- of packages. It is what backs the @cabal build@ and @configure@ commands, --- as well as being a core part of @run@, @test@, @bench@ and others. --- --- The primary thing is in fact rebuilding (and trying to make that quick by --- not redoing unnecessary work), so building from scratch is just a special --- case. --- --- The build process and the code can be understood by breaking it down into --- three major parts: --- --- * The 'ElaboratedInstallPlan' type --- --- * The \"what to do\" phase, where we look at the all input configuration --- (project files, .cabal files, command line etc) and produce a detailed --- plan of what to do -- the 'ElaboratedInstallPlan'. --- --- * The \"do it\" phase, where we take the 'ElaboratedInstallPlan' and we --- re-execute it. --- --- As far as possible, the \"what to do\" phase embodies all the policy, leaving --- the \"do it\" phase policy free. The first phase contains more of the --- complicated logic, but it is contained in code that is either pure or just --- has read effects (except cache updates). Then the second phase does all the --- actions to build packages, but as far as possible it just follows the --- instructions and avoids any logic for deciding what to do (apart from --- recompilation avoidance in executing the plan). --- --- This division helps us keep the code under control, making it easier to --- understand, test and debug. So when you are extending these modules, please --- think about which parts of your change belong in which part. It is --- perfectly ok to extend the description of what to do (i.e. the --- 'ElaboratedInstallPlan') if that helps keep the policy decisions in the --- first phase. Also, the second phase does not have direct access to any of --- the input configuration anyway; all the information has to flow via the --- 'ElaboratedInstallPlan'. --- -module Distribution.Client.ProjectOrchestration ( - -- * Discovery phase: what is in the project? - CurrentCommand(..), - establishProjectBaseContext, - establishProjectBaseContextWithRoot, - ProjectBaseContext(..), - BuildTimeSettings(..), - commandLineFlagsToProjectConfig, - - -- * Pre-build phase: decide what to do. - withInstallPlan, - runProjectPreBuildPhase, - ProjectBuildContext(..), - - -- ** Selecting what targets we mean - readTargetSelectors, - reportTargetSelectorProblems, - resolveTargets, - TargetsMap, - TargetSelector(..), - TargetImplicitCwd(..), - PackageId, - AvailableTarget(..), - AvailableTargetStatus(..), - TargetRequested(..), - ComponentName(..), - ComponentKind(..), - ComponentTarget(..), - SubComponentTarget(..), - selectComponentTargetBasic, - distinctTargetComponents, - -- ** Utils for selecting targets - filterTargetsKind, - filterTargetsKindWith, - selectBuildableTargets, - selectBuildableTargetsWith, - selectBuildableTargets', - selectBuildableTargetsWith', - forgetTargetsDetail, - - -- ** Adjusting the plan - pruneInstallPlanToTargets, - TargetAction(..), - pruneInstallPlanToDependencies, - CannotPruneDependencies(..), - printPlan, - - -- * Build phase: now do it. - runProjectBuildPhase, - - -- * Post build actions - runProjectPostBuildPhase, - dieOnBuildFailures, - - -- * Shared CLI utils - cmdCommonHelpTextNewBuildBeta, - - -- * Dummy projects - establishDummyProjectBaseContext, - establishDummyDistDirLayout, - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude -import Distribution.Compat.Directory - ( makeAbsolute ) - -import Distribution.Client.ProjectConfig -import Distribution.Client.ProjectPlanning - hiding ( pruneInstallPlanToTargets ) -import qualified Distribution.Client.ProjectPlanning as ProjectPlanning - ( pruneInstallPlanToTargets ) -import Distribution.Client.ProjectPlanning.Types -import Distribution.Client.ProjectBuilding -import Distribution.Client.ProjectPlanOutput -import Distribution.Client.RebuildMonad ( runRebuild ) - -import Distribution.Client.TargetProblem - ( TargetProblem (..) ) -import Distribution.Client.Types - ( GenericReadyPackage(..), UnresolvedSourcePackage - , PackageSpecifier(..) - , SourcePackageDb(..) - , WriteGhcEnvironmentFilesPolicy(..) ) -import Distribution.Solver.Types.PackageIndex - ( lookupPackageName ) -import qualified Distribution.Client.InstallPlan as InstallPlan -import Distribution.Client.TargetSelector - ( TargetSelector(..), TargetImplicitCwd(..) - , ComponentKind(..), componentKind - , readTargetSelectors, reportTargetSelectorProblems ) -import Distribution.Client.DistDirLayout -import Distribution.Client.Config (getCabalDir) -import Distribution.Client.Setup hiding (packageName) -import Distribution.Compiler - ( CompilerFlavor(GHC) ) -import Distribution.Types.ComponentName - ( componentNameString ) -import Distribution.Types.UnqualComponentName - ( UnqualComponentName, packageNameToUnqualComponentName ) - -import Distribution.Solver.Types.OptionalStanza - -import Distribution.Package -import Distribution.Types.Flag - ( FlagAssignment, showFlagAssignment, diffFlagAssignment ) -import Distribution.Simple.LocalBuildInfo - ( ComponentName(..), pkgComponents ) -import Distribution.Simple.Flag - ( fromFlagOrDefault, flagToMaybe ) -import qualified Distribution.Simple.Setup as Setup -import Distribution.Simple.Command (commandShowOptions) -import Distribution.Simple.Configure (computeEffectiveProfiling) - -import Distribution.Simple.Utils - ( die', warn, notice, noticeNoWrap, debugNoWrap, createDirectoryIfMissingVerbose ) -import Distribution.Verbosity -import Distribution.Version - ( mkVersion ) -import Distribution.Simple.Compiler - ( compilerCompatVersion, showCompilerId - , OptimisationLevel(..)) - -import qualified Data.List.NonEmpty as NE -import qualified Data.Set as Set -import qualified Data.Map as Map -import Control.Exception (assert) -#ifdef MIN_VERSION_unix -import System.Posix.Signals (sigKILL, sigSEGV) -#endif - - --- | Tracks what command is being executed, because we need to hide this somewhere --- for cases that need special handling (usually for error reporting). -data CurrentCommand = InstallCommand | HaddockCommand | OtherCommand - deriving (Show, Eq) - --- | This holds the context of a project prior to solving: the content of the --- @cabal.project@ and all the local package @.cabal@ files. --- -data ProjectBaseContext = ProjectBaseContext { - distDirLayout :: DistDirLayout, - cabalDirLayout :: CabalDirLayout, - projectConfig :: ProjectConfig, - localPackages :: [PackageSpecifier UnresolvedSourcePackage], - buildSettings :: BuildTimeSettings, - currentCommand :: CurrentCommand - } - -establishProjectBaseContext - :: Verbosity - -> ProjectConfig - -> CurrentCommand - -> IO ProjectBaseContext -establishProjectBaseContext verbosity cliConfig currentCommand = do - projectRoot <- either throwIO return =<< findProjectRoot Nothing mprojectFile - establishProjectBaseContextWithRoot verbosity cliConfig projectRoot currentCommand - where - mprojectFile = Setup.flagToMaybe projectConfigProjectFile - ProjectConfigShared { projectConfigProjectFile } = projectConfigShared cliConfig - --- | Like 'establishProjectBaseContext' but doesn't search for project root. -establishProjectBaseContextWithRoot - :: Verbosity - -> ProjectConfig - -> ProjectRoot - -> CurrentCommand - -> IO ProjectBaseContext -establishProjectBaseContextWithRoot verbosity cliConfig projectRoot currentCommand = do - cabalDir <- getCabalDir - - let distDirLayout = defaultDistDirLayout projectRoot mdistDirectory - - (projectConfig, localPackages) <- - rebuildProjectConfig verbosity - distDirLayout - cliConfig - - let ProjectConfigBuildOnly { - projectConfigLogsDir - } = projectConfigBuildOnly projectConfig - - ProjectConfigShared { - projectConfigStoreDir - } = projectConfigShared projectConfig - - mlogsDir = Setup.flagToMaybe projectConfigLogsDir - mstoreDir <- sequenceA $ makeAbsolute - <$> Setup.flagToMaybe projectConfigStoreDir - let cabalDirLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir - - buildSettings = resolveBuildTimeSettings - verbosity cabalDirLayout - projectConfig - - -- https://github.com/haskell/cabal/issues/6013 - when (null (projectPackages projectConfig) && null (projectPackagesOptional projectConfig)) $ - warn verbosity "There are no packages or optional-packages in the project" - - return ProjectBaseContext { - distDirLayout, - cabalDirLayout, - projectConfig, - localPackages, - buildSettings, - currentCommand - } - where - mdistDirectory = Setup.flagToMaybe projectConfigDistDir - ProjectConfigShared { projectConfigDistDir } = projectConfigShared cliConfig - - --- | This holds the context between the pre-build, build and post-build phases. --- -data ProjectBuildContext = ProjectBuildContext { - -- | This is the improved plan, before we select a plan subset based on - -- the build targets, and before we do the dry-run. So this contains - -- all packages in the project. - elaboratedPlanOriginal :: ElaboratedInstallPlan, - - -- | This is the 'elaboratedPlanOriginal' after we select a plan subset - -- and do the dry-run phase to find out what is up-to or out-of date. - -- This is the plan that will be executed during the build phase. So - -- this contains only a subset of packages in the project. - elaboratedPlanToExecute:: ElaboratedInstallPlan, - - -- | The part of the install plan that's shared between all packages in - -- the plan. This does not change between the two plan variants above, - -- so there is just the one copy. - elaboratedShared :: ElaboratedSharedConfig, - - -- | The result of the dry-run phase. This tells us about each member of - -- the 'elaboratedPlanToExecute'. - pkgsBuildStatus :: BuildStatusMap, - - -- | The targets selected by @selectPlanSubset@. This is useful eg. in - -- CmdRun, where we need a valid target to execute. - targetsMap :: TargetsMap - } - - --- | Pre-build phase: decide what to do. --- -withInstallPlan - :: Verbosity - -> ProjectBaseContext - -> (ElaboratedInstallPlan -> ElaboratedSharedConfig -> IO a) - -> IO a -withInstallPlan - verbosity - ProjectBaseContext { - distDirLayout, - cabalDirLayout, - projectConfig, - localPackages - } - action = do - -- Take the project configuration and make a plan for how to build - -- everything in the project. This is independent of any specific targets - -- the user has asked for. - -- - (elaboratedPlan, _, elaboratedShared, _, _) <- - rebuildInstallPlan verbosity - distDirLayout cabalDirLayout - projectConfig - localPackages - action elaboratedPlan elaboratedShared - -runProjectPreBuildPhase - :: Verbosity - -> ProjectBaseContext - -> (ElaboratedInstallPlan -> IO (ElaboratedInstallPlan, TargetsMap)) - -> IO ProjectBuildContext -runProjectPreBuildPhase - verbosity - ProjectBaseContext { - distDirLayout, - cabalDirLayout, - projectConfig, - localPackages - } - selectPlanSubset = do - -- Take the project configuration and make a plan for how to build - -- everything in the project. This is independent of any specific targets - -- the user has asked for. - -- - (elaboratedPlan, _, elaboratedShared, _, _) <- - rebuildInstallPlan verbosity - distDirLayout cabalDirLayout - projectConfig - localPackages - - -- The plan for what to do is represented by an 'ElaboratedInstallPlan' - - -- Now given the specific targets the user has asked for, decide - -- which bits of the plan we will want to execute. - -- - (elaboratedPlan', targets) <- selectPlanSubset elaboratedPlan - - -- Check which packages need rebuilding. - -- This also gives us more accurate reasons for the --dry-run output. - -- - pkgsBuildStatus <- rebuildTargetsDryRun distDirLayout elaboratedShared - elaboratedPlan' - - -- Improve the plan by marking up-to-date packages as installed. - -- - let elaboratedPlan'' = improveInstallPlanWithUpToDatePackages - pkgsBuildStatus elaboratedPlan' - debugNoWrap verbosity (InstallPlan.showInstallPlan elaboratedPlan'') - - return ProjectBuildContext { - elaboratedPlanOriginal = elaboratedPlan, - elaboratedPlanToExecute = elaboratedPlan'', - elaboratedShared, - pkgsBuildStatus, - targetsMap = targets - } - - --- | Build phase: now do it. --- --- Execute all or parts of the description of what to do to build or --- rebuild the various packages needed. --- -runProjectBuildPhase :: Verbosity - -> ProjectBaseContext - -> ProjectBuildContext - -> IO BuildOutcomes -runProjectBuildPhase _ ProjectBaseContext{buildSettings} _ - | buildSettingDryRun buildSettings - = return Map.empty - -runProjectBuildPhase verbosity - ProjectBaseContext{..} ProjectBuildContext {..} = - fmap (Map.union (previousBuildOutcomes pkgsBuildStatus)) $ - rebuildTargets verbosity - distDirLayout - (cabalStoreDirLayout cabalDirLayout) - elaboratedPlanToExecute - elaboratedShared - pkgsBuildStatus - buildSettings - where - previousBuildOutcomes :: BuildStatusMap -> BuildOutcomes - previousBuildOutcomes = - Map.mapMaybe $ \status -> case status of - BuildStatusUpToDate buildSuccess -> Just (Right buildSuccess) - --TODO: [nice to have] record build failures persistently - _ -> Nothing - --- | Post-build phase: various administrative tasks --- --- Update bits of state based on the build outcomes and report any failures. --- -runProjectPostBuildPhase :: Verbosity - -> ProjectBaseContext - -> ProjectBuildContext - -> BuildOutcomes - -> IO () -runProjectPostBuildPhase _ ProjectBaseContext{buildSettings} _ _ - | buildSettingDryRun buildSettings - = return () - -runProjectPostBuildPhase verbosity - ProjectBaseContext {..} ProjectBuildContext {..} - buildOutcomes = do - -- Update other build artefacts - -- TODO: currently none, but could include: - -- - bin symlinks/wrappers - -- - haddock/hoogle/ctags indexes - -- - delete stale lib registrations - -- - delete stale package dirs - - postBuildStatus <- updatePostBuildProjectStatus - verbosity - distDirLayout - elaboratedPlanOriginal - pkgsBuildStatus - buildOutcomes - - -- Write the .ghc.environment file (if allowed by the env file write policy). - let writeGhcEnvFilesPolicy = - projectConfigWriteGhcEnvironmentFilesPolicy . projectConfigShared - $ projectConfig - - shouldWriteGhcEnvironment = - case fromFlagOrDefault NeverWriteGhcEnvironmentFiles - writeGhcEnvFilesPolicy - of - AlwaysWriteGhcEnvironmentFiles -> True - NeverWriteGhcEnvironmentFiles -> False - WriteGhcEnvironmentFilesOnlyForGhc844AndNewer -> - let compiler = pkgConfigCompiler elaboratedShared - ghcCompatVersion = compilerCompatVersion GHC compiler - in maybe False (>= mkVersion [8,4,4]) ghcCompatVersion - - when shouldWriteGhcEnvironment $ - void $ writePlanGhcEnvironment (distProjectRootDirectory distDirLayout) - elaboratedPlanOriginal - elaboratedShared - postBuildStatus - - -- Finally if there were any build failures then report them and throw - -- an exception to terminate the program - dieOnBuildFailures verbosity currentCommand elaboratedPlanToExecute buildOutcomes - - -- Note that it is a deliberate design choice that the 'buildTargets' is - -- not passed to phase 1, and the various bits of input config is not - -- passed to phase 2. - -- - -- We make the install plan without looking at the particular targets the - -- user asks us to build. The set of available things we can build is - -- discovered from the env and config and is used to make the install plan. - -- The targets just tell us which parts of the install plan to execute. - -- - -- Conversely, executing the plan does not directly depend on any of the - -- input config. The bits that are needed (or better, the decisions based - -- on it) all go into the install plan. - - -- Notionally, the 'BuildFlags' should be things that do not affect what - -- we build, just how we do it. These ones of course do - - ------------------------------------------------------------------------------- --- Taking targets into account, selecting what to build --- - --- | The set of components to build, represented as a mapping from 'UnitId's --- to the 'ComponentTarget's within the unit that will be selected --- (e.g. selected to build, test or repl). --- --- Associated with each 'ComponentTarget' is the set of 'TargetSelector's that --- matched this target. Typically this is exactly one, but in general it is --- possible to for different selectors to match the same target. This extra --- information is primarily to help make helpful error messages. --- -type TargetsMap = Map UnitId [(ComponentTarget, [TargetSelector])] - --- | Given a set of 'TargetSelector's, resolve which 'UnitId's and --- 'ComponentTarget's they ought to refer to. --- --- The idea is that every user target identifies one or more roots in the --- 'ElaboratedInstallPlan', which we will use to determine the closure --- of what packages need to be built, dropping everything from the plan --- that is unnecessary. This closure and pruning is done by --- 'pruneInstallPlanToTargets' and this needs to be told the roots in terms --- of 'UnitId's and the 'ComponentTarget's within those. --- --- This means we first need to translate the 'TargetSelector's into the --- 'UnitId's and 'ComponentTarget's. This translation has to be different for --- the different command line commands, like @build@, @repl@ etc. For example --- the command @build pkgfoo@ could select a different set of components in --- pkgfoo than @repl pkgfoo@. The @build@ command would select any library and --- all executables, whereas @repl@ would select the library or a single --- executable. Furthermore, both of these examples could fail, and fail in --- different ways and each needs to be able to produce helpful error messages. --- --- So 'resolveTargets' takes two helpers: one to select the targets to be used --- by user targets that refer to a whole package ('TargetPackage'), and --- another to check user targets that refer to a component (or a module or --- file within a component). These helpers can fail, and use their own error --- type. Both helpers get given the 'AvailableTarget' info about the --- component(s). --- --- While commands vary quite a bit in their behaviour about which components to --- select for a whole-package target, most commands have the same behaviour for --- checking a user target that refers to a specific component. To help with --- this commands can use 'selectComponentTargetBasic', either directly or as --- a basis for their own @selectComponentTarget@ implementation. --- -resolveTargets :: forall err. - (forall k. TargetSelector - -> [AvailableTarget k] - -> Either (TargetProblem err) [k]) - -> (forall k. SubComponentTarget - -> AvailableTarget k - -> Either (TargetProblem err) k ) - -> ElaboratedInstallPlan - -> Maybe (SourcePackageDb) - -> [TargetSelector] - -> Either [TargetProblem err] TargetsMap -resolveTargets selectPackageTargets selectComponentTarget - installPlan mPkgDb = - fmap mkTargetsMap - . either (Left . toList) Right - . checkErrors - . map (\ts -> (,) ts <$> checkTarget ts) - where - mkTargetsMap :: [(TargetSelector, [(UnitId, ComponentTarget)])] - -> TargetsMap - mkTargetsMap targets = - Map.map nubComponentTargets - $ Map.fromListWith (++) - [ (uid, [(ct, ts)]) - | (ts, cts) <- targets - , (uid, ct) <- cts ] - - AvailableTargetIndexes{..} = availableTargetIndexes installPlan - - checkTarget :: TargetSelector -> Either (TargetProblem err) [(UnitId, ComponentTarget)] - - -- We can ask to build any whole package, project-local or a dependency - checkTarget bt@(TargetPackage _ [pkgid] mkfilter) - | Just ats <- fmap (maybe id filterTargetsKind mkfilter) - $ Map.lookup pkgid availableTargetsByPackageId - = fmap (componentTargets WholeComponent) - $ selectPackageTargets bt ats - - | otherwise - = Left (TargetProblemNoSuchPackage pkgid) - - checkTarget (TargetPackage _ _ _) - = error "TODO: add support for multiple packages in a directory" - -- For the moment this error cannot happen here, because it gets - -- detected when the package config is being constructed. This case - -- will need handling properly when we do add support. - -- - -- TODO: how should this use case play together with the - -- '--cabal-file' option of 'configure' which allows using multiple - -- .cabal files for a single package? - - checkTarget bt@(TargetAllPackages mkfilter) = - fmap (componentTargets WholeComponent) - . selectPackageTargets bt - . maybe id filterTargetsKind mkfilter - . filter availableTargetLocalToProject - $ concat (Map.elems availableTargetsByPackageId) - - checkTarget (TargetComponent pkgid cname subtarget) - | Just ats <- Map.lookup (pkgid, cname) - availableTargetsByPackageIdAndComponentName - = fmap (componentTargets subtarget) - $ selectComponentTargets subtarget ats - - | Map.member pkgid availableTargetsByPackageId - = Left (TargetProblemNoSuchComponent pkgid cname) - - | otherwise - = Left (TargetProblemNoSuchPackage pkgid) - - checkTarget (TargetComponentUnknown pkgname ecname subtarget) - | Just ats <- case ecname of - Left ucname -> - Map.lookup (pkgname, ucname) - availableTargetsByPackageNameAndUnqualComponentName - Right cname -> - Map.lookup (pkgname, cname) - availableTargetsByPackageNameAndComponentName - = fmap (componentTargets subtarget) - $ selectComponentTargets subtarget ats - - | Map.member pkgname availableTargetsByPackageName - = Left (TargetProblemUnknownComponent pkgname ecname) - - | otherwise - = Left (TargetNotInProject pkgname) - - checkTarget bt@(TargetPackageNamed pkgname mkfilter) - | Just ats <- fmap (maybe id filterTargetsKind mkfilter) - $ Map.lookup pkgname availableTargetsByPackageName - = fmap (componentTargets WholeComponent) - . selectPackageTargets bt - $ ats - - | Just SourcePackageDb{ packageIndex } <- mPkgDb - , let pkg = lookupPackageName packageIndex pkgname - , not (null pkg) - = Left (TargetAvailableInIndex pkgname) - - | otherwise - = Left (TargetNotInProject pkgname) - - componentTargets :: SubComponentTarget - -> [(b, ComponentName)] - -> [(b, ComponentTarget)] - componentTargets subtarget = - map (fmap (\cname -> ComponentTarget cname subtarget)) - - selectComponentTargets :: SubComponentTarget - -> [AvailableTarget k] - -> Either (TargetProblem err) [k] - selectComponentTargets subtarget = - either (Left . NE.head) Right - . checkErrors - . map (selectComponentTarget subtarget) - - checkErrors :: [Either e a] -> Either (NonEmpty e) [a] - checkErrors = (\(es, xs) -> case es of { [] -> Right xs; (e:es') -> Left (e:|es') }) - . partitionEithers - - -data AvailableTargetIndexes = AvailableTargetIndexes { - availableTargetsByPackageIdAndComponentName - :: AvailableTargetsMap (PackageId, ComponentName), - - availableTargetsByPackageId - :: AvailableTargetsMap PackageId, - - availableTargetsByPackageName - :: AvailableTargetsMap PackageName, - - availableTargetsByPackageNameAndComponentName - :: AvailableTargetsMap (PackageName, ComponentName), - - availableTargetsByPackageNameAndUnqualComponentName - :: AvailableTargetsMap (PackageName, UnqualComponentName) - } -type AvailableTargetsMap k = Map k [AvailableTarget (UnitId, ComponentName)] - --- We define a bunch of indexes to help 'resolveTargets' with resolving --- 'TargetSelector's to specific 'UnitId's. --- --- They are all derived from the 'availableTargets' index. --- The 'availableTargetsByPackageIdAndComponentName' is just that main index, --- while the others are derived by re-grouping on the index key. --- --- They are all constructed lazily because they are not necessarily all used. --- -availableTargetIndexes :: ElaboratedInstallPlan -> AvailableTargetIndexes -availableTargetIndexes installPlan = AvailableTargetIndexes{..} - where - availableTargetsByPackageIdAndComponentName = - availableTargets installPlan - - availableTargetsByPackageId = - Map.mapKeysWith - (++) (\(pkgid, _cname) -> pkgid) - availableTargetsByPackageIdAndComponentName - `Map.union` availableTargetsEmptyPackages - - availableTargetsByPackageName = - Map.mapKeysWith - (++) packageName - availableTargetsByPackageId - - availableTargetsByPackageNameAndComponentName = - Map.mapKeysWith - (++) (\(pkgid, cname) -> (packageName pkgid, cname)) - availableTargetsByPackageIdAndComponentName - - availableTargetsByPackageNameAndUnqualComponentName = - Map.mapKeysWith - (++) (\(pkgid, cname) -> let pname = packageName pkgid - cname' = unqualComponentName pname cname - in (pname, cname')) - availableTargetsByPackageIdAndComponentName - where - unqualComponentName :: - PackageName -> ComponentName -> UnqualComponentName - unqualComponentName pkgname = - fromMaybe (packageNameToUnqualComponentName pkgname) - . componentNameString - - -- Add in all the empty packages. These do not appear in the - -- availableTargetsByComponent map, since that only contains - -- components, so packages with no components are invisible from - -- that perspective. The empty packages need to be there for - -- proper error reporting, so users can select the empty package - -- and then we can report that it is empty, otherwise we falsely - -- report there is no such package at all. - availableTargetsEmptyPackages = - Map.fromList - [ (packageId pkg, []) - | InstallPlan.Configured pkg <- InstallPlan.toList installPlan - , case elabPkgOrComp pkg of - ElabComponent _ -> False - ElabPackage _ -> null (pkgComponents (elabPkgDescription pkg)) - ] - - --TODO: [research required] what if the solution has multiple - -- versions of this package? - -- e.g. due to setup deps or due to multiple independent sets - -- of packages being built (e.g. ghc + ghcjs in a project) - -filterTargetsKind :: ComponentKind -> [AvailableTarget k] -> [AvailableTarget k] -filterTargetsKind ckind = filterTargetsKindWith (== ckind) - -filterTargetsKindWith :: (ComponentKind -> Bool) - -> [AvailableTarget k] -> [AvailableTarget k] -filterTargetsKindWith p ts = - [ t | t@(AvailableTarget _ cname _ _) <- ts - , p (componentKind cname) ] - -selectBuildableTargets :: [AvailableTarget k] -> [k] -selectBuildableTargets ts = - [ k | AvailableTarget _ _ (TargetBuildable k _) _ <- ts ] - -selectBuildableTargetsWith :: (TargetRequested -> Bool) - -> [AvailableTarget k] -> [k] -selectBuildableTargetsWith p ts = - [ k | AvailableTarget _ _ (TargetBuildable k req) _ <- ts, p req ] - -selectBuildableTargets' :: [AvailableTarget k] -> ([k], [AvailableTarget ()]) -selectBuildableTargets' ts = - (,) [ k | AvailableTarget _ _ (TargetBuildable k _) _ <- ts ] - [ forgetTargetDetail t - | t@(AvailableTarget _ _ (TargetBuildable _ _) _) <- ts ] - -selectBuildableTargetsWith' :: (TargetRequested -> Bool) - -> [AvailableTarget k] -> ([k], [AvailableTarget ()]) -selectBuildableTargetsWith' p ts = - (,) [ k | AvailableTarget _ _ (TargetBuildable k req) _ <- ts, p req ] - [ forgetTargetDetail t - | t@(AvailableTarget _ _ (TargetBuildable _ req) _) <- ts, p req ] - - -forgetTargetDetail :: AvailableTarget k -> AvailableTarget () -forgetTargetDetail = fmap (const ()) - -forgetTargetsDetail :: [AvailableTarget k] -> [AvailableTarget ()] -forgetTargetsDetail = map forgetTargetDetail - --- | A basic @selectComponentTarget@ implementation to use or pass to --- 'resolveTargets', that does the basic checks that the component is --- buildable and isn't a test suite or benchmark that is disabled. This --- can also be used to do these basic checks as part of a custom impl that --- -selectComponentTargetBasic :: SubComponentTarget - -> AvailableTarget k - -> Either (TargetProblem a) k -selectComponentTargetBasic subtarget - AvailableTarget { - availableTargetPackageId = pkgid, - availableTargetComponentName = cname, - availableTargetStatus - } = - case availableTargetStatus of - TargetDisabledByUser -> - Left (TargetOptionalStanzaDisabledByUser pkgid cname subtarget) - - TargetDisabledBySolver -> - Left (TargetOptionalStanzaDisabledBySolver pkgid cname subtarget) - - TargetNotLocal -> - Left (TargetComponentNotProjectLocal pkgid cname subtarget) - - TargetNotBuildable -> - Left (TargetComponentNotBuildable pkgid cname subtarget) - - TargetBuildable targetKey _ -> - Right targetKey - --- | Wrapper around 'ProjectPlanning.pruneInstallPlanToTargets' that adjusts --- for the extra unneeded info in the 'TargetsMap'. --- -pruneInstallPlanToTargets :: TargetAction -> TargetsMap - -> ElaboratedInstallPlan -> ElaboratedInstallPlan -pruneInstallPlanToTargets targetActionType targetsMap elaboratedPlan = - assert (Map.size targetsMap > 0) $ - ProjectPlanning.pruneInstallPlanToTargets - targetActionType - (Map.map (map fst) 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 targetsMap = - Set.fromList [ (uid, cname) - | (uid, cts) <- Map.toList targetsMap - , (ComponentTarget cname _, _) <- cts ] - - ------------------------------------------------------------------------------- --- Displaying what we plan to do --- - --- | Print a user-oriented presentation of the install plan, indicating what --- will be built. --- -printPlan :: Verbosity - -> ProjectBaseContext - -> ProjectBuildContext - -> IO () -printPlan verbosity - ProjectBaseContext { - buildSettings = BuildTimeSettings{buildSettingDryRun}, - projectConfig = ProjectConfig { - projectConfigLocalPackages = - PackageConfig {packageConfigOptimization} - } - } - ProjectBuildContext { - elaboratedPlanToExecute = elaboratedPlan, - elaboratedShared, - pkgsBuildStatus - } - - | null pkgs - = notice verbosity "Up to date" - - | otherwise - = noticeNoWrap verbosity $ unlines $ - (showBuildProfile ++ "In order, the following " - ++ wouldWill ++ " be built" - ++ ifNormal " (use -v for more details)" ++ ":") - : map showPkgAndReason pkgs - - where - pkgs = InstallPlan.executionOrder elaboratedPlan - - ifVerbose s | verbosity >= verbose = s - | otherwise = "" - - ifNormal s | verbosity >= verbose = "" - | otherwise = s - - wouldWill | buildSettingDryRun = "would" - | otherwise = "will" - - showPkgAndReason :: ElaboratedReadyPackage -> String - showPkgAndReason (ReadyPackage elab) = unwords $ filter (not . null) $ - [ " -" - , if verbosity >= deafening - then prettyShow (installedUnitId elab) - else prettyShow (packageId elab) - , case elabPkgOrComp elab of - ElabPackage pkg -> showTargets elab ++ ifVerbose (showStanzas pkg) - ElabComponent comp -> - "(" ++ showComp elab comp ++ ")" - , showFlagAssignment (nonDefaultFlags elab) - , showConfigureFlags elab - , let buildStatus = pkgsBuildStatus Map.! installedUnitId elab - in "(" ++ showBuildStatus buildStatus ++ ")" - ] - - showComp elab comp = - maybe "custom" prettyShow (compComponentName comp) ++ - if Map.null (elabInstantiatedWith elab) - then "" - else " with " ++ - intercalate ", " - -- TODO: Abbreviate the UnitIds - [ prettyShow k ++ "=" ++ prettyShow v - | (k,v) <- Map.toList (elabInstantiatedWith elab) ] - - nonDefaultFlags :: ElaboratedConfiguredPackage -> FlagAssignment - nonDefaultFlags elab = - elabFlagAssignment elab `diffFlagAssignment` elabFlagDefaults elab - - showStanzas pkg = concat - $ [ " *test" - | TestStanzas `Set.member` pkgStanzasEnabled pkg ] - ++ [ " *bench" - | BenchStanzas `Set.member` pkgStanzasEnabled pkg ] - - showTargets elab - | null (elabBuildTargets elab) = "" - | otherwise - = "(" - ++ intercalate ", " [ showComponentTarget (packageId elab) t - | t <- elabBuildTargets elab ] - ++ ")" - - showConfigureFlags elab = - let fullConfigureFlags - = setupHsConfigureFlags - (ReadyPackage elab) - elaboratedShared - verbosity - "$builddir" - -- | Given a default value @x@ for a flag, nub @Flag x@ - -- into @NoFlag@. This gives us a tidier command line - -- rendering. - nubFlag :: Eq a => a -> Setup.Flag a -> Setup.Flag a - nubFlag x (Setup.Flag x') | x == x' = Setup.NoFlag - nubFlag _ f = f - - (tryLibProfiling, tryExeProfiling) = - computeEffectiveProfiling fullConfigureFlags - - partialConfigureFlags - = mempty { - configProf = - nubFlag False (configProf fullConfigureFlags), - configProfExe = - nubFlag tryExeProfiling (configProfExe fullConfigureFlags), - configProfLib = - nubFlag tryLibProfiling (configProfLib fullConfigureFlags) - -- Maybe there are more we can add - } - -- Not necessary to "escape" it, it's just for user output - in unwords . ("":) $ - commandShowOptions - (Setup.configureCommand (pkgConfigCompilerProgs elaboratedShared)) - partialConfigureFlags - - showBuildStatus status = case status of - BuildStatusPreExisting -> "existing package" - BuildStatusInstalled -> "already installed" - BuildStatusDownload {} -> "requires download & build" - BuildStatusUnpack {} -> "requires build" - BuildStatusRebuild _ rebuild -> case rebuild of - BuildStatusConfigure - (MonitoredValueChanged _) -> "configuration changed" - BuildStatusConfigure mreason -> showMonitorChangedReason mreason - BuildStatusBuild _ buildreason -> case buildreason of - BuildReasonDepsRebuilt -> "dependency rebuilt" - BuildReasonFilesChanged - mreason -> showMonitorChangedReason mreason - BuildReasonExtraTargets _ -> "additional components to build" - BuildReasonEphemeralTargets -> "ephemeral targets" - BuildStatusUpToDate {} -> "up to date" -- doesn't happen - - showMonitorChangedReason (MonitoredFileChanged file) = - "file " ++ file ++ " changed" - showMonitorChangedReason (MonitoredValueChanged _) = "value changed" - showMonitorChangedReason MonitorFirstRun = "first run" - showMonitorChangedReason MonitorCorruptCache = - "cannot read state cache" - - showBuildProfile = "Build profile: " ++ unwords [ - "-w " ++ (showCompilerId . pkgConfigCompiler) elaboratedShared, - "-O" ++ (case packageConfigOptimization of - Setup.Flag NoOptimisation -> "0" - Setup.Flag NormalOptimisation -> "1" - Setup.Flag MaximumOptimisation -> "2" - Setup.NoFlag -> "1")] - ++ "\n" - --- | If there are build failures then report them and throw an exception. --- -dieOnBuildFailures :: Verbosity -> CurrentCommand - -> ElaboratedInstallPlan -> BuildOutcomes -> IO () -dieOnBuildFailures verbosity currentCommand plan buildOutcomes - | null failures = return () - - | isSimpleCase = exitFailure - - | otherwise = do - -- For failures where we have a build log, print the log plus a header - sequence_ - [ do notice verbosity $ - '\n' : renderFailureDetail False pkg reason - ++ "\nBuild log ( " ++ logfile ++ " ):" - readFile logfile >>= noticeNoWrap verbosity - | (pkg, ShowBuildSummaryAndLog reason logfile) - <- failuresClassification - ] - - -- For all failures, print either a short summary (if we showed the - -- build log) or all details - dieIfNotHaddockFailure verbosity $ unlines - [ case failureClassification of - ShowBuildSummaryAndLog reason _ - | verbosity > normal - -> renderFailureDetail mentionDepOf pkg reason - - | otherwise - -> renderFailureSummary mentionDepOf pkg reason - ++ ". See the build log above for details." - - ShowBuildSummaryOnly reason -> - renderFailureDetail mentionDepOf pkg reason - - | let mentionDepOf = verbosity <= normal - , (pkg, failureClassification) <- failuresClassification ] - where - failures = [ (pkgid, failure) - | (pkgid, Left failure) <- Map.toList buildOutcomes ] - - failuresClassification = - [ (pkg, classifyBuildFailure failure) - | (pkgid, failure) <- failures - , case buildFailureReason failure of - DependentFailed {} -> verbosity > normal - _ -> True - , InstallPlan.Configured pkg <- - maybeToList (InstallPlan.lookup plan pkgid) - ] - - dieIfNotHaddockFailure - | currentCommand == HaddockCommand = die' - | all isHaddockFailure failuresClassification = warn - | otherwise = die' - where - isHaddockFailure - (_, ShowBuildSummaryOnly (HaddocksFailed _) ) = True - isHaddockFailure - (_, ShowBuildSummaryAndLog (HaddocksFailed _) _) = True - isHaddockFailure - _ = False - - - classifyBuildFailure :: BuildFailure -> BuildFailurePresentation - classifyBuildFailure BuildFailure { - buildFailureReason = reason, - buildFailureLogFile = mlogfile - } = - maybe (ShowBuildSummaryOnly reason) - (ShowBuildSummaryAndLog reason) $ do - logfile <- mlogfile - e <- buildFailureException reason - ExitFailure 1 <- fromException e - return logfile - - -- Special case: we don't want to report anything complicated in the case - -- of just doing build on the current package, since it's clear from - -- context which package failed. - -- - -- We generalise this rule as follows: - -- - if only one failure occurs, and it is in a single root - -- package (i.e. a package with nothing else depending on it) - -- - and that failure is of a kind that always reports enough - -- detail itself (e.g. ghc reporting errors on stdout) - -- - then we do not report additional error detail or context. - -- - isSimpleCase - | [(pkgid, failure)] <- failures - , [pkg] <- rootpkgs - , installedUnitId pkg == pkgid - , isFailureSelfExplanatory (buildFailureReason failure) - , currentCommand /= InstallCommand - = True - | otherwise - = False - - -- NB: if the Setup script segfaulted or was interrupted, - -- we should give more detailed information. So only - -- assume that exit code 1 is "pedestrian failure." - isFailureSelfExplanatory (BuildFailed e) - | Just (ExitFailure 1) <- fromException e = True - - isFailureSelfExplanatory (ConfigureFailed e) - | Just (ExitFailure 1) <- fromException e = True - - isFailureSelfExplanatory _ = False - - rootpkgs = - [ pkg - | InstallPlan.Configured pkg <- InstallPlan.toList plan - , hasNoDependents pkg ] - - ultimateDeps pkgid = - filter (\pkg -> hasNoDependents pkg && installedUnitId pkg /= pkgid) - (InstallPlan.reverseDependencyClosure plan [pkgid]) - - hasNoDependents :: HasUnitId pkg => pkg -> Bool - hasNoDependents = null . InstallPlan.revDirectDeps plan . installedUnitId - - renderFailureDetail mentionDepOf pkg reason = - renderFailureSummary mentionDepOf pkg reason ++ "." - ++ renderFailureExtraDetail reason - ++ maybe "" showException (buildFailureException reason) - - renderFailureSummary mentionDepOf pkg reason = - case reason of - DownloadFailed _ -> "Failed to download " ++ pkgstr - UnpackFailed _ -> "Failed to unpack " ++ pkgstr - ConfigureFailed _ -> "Failed to build " ++ pkgstr - BuildFailed _ -> "Failed to build " ++ pkgstr - ReplFailed _ -> "repl failed for " ++ pkgstr - HaddocksFailed _ -> "Failed to build documentation for " ++ pkgstr - TestsFailed _ -> "Tests failed for " ++ pkgstr - BenchFailed _ -> "Benchmarks failed for " ++ pkgstr - InstallFailed _ -> "Failed to build " ++ pkgstr - DependentFailed depid - -> "Failed to build " ++ prettyShow (packageId pkg) - ++ " because it depends on " ++ prettyShow depid - ++ " which itself failed to build" - where - pkgstr = elabConfiguredName verbosity pkg - ++ if mentionDepOf - then renderDependencyOf (installedUnitId pkg) - else "" - - renderFailureExtraDetail (ConfigureFailed _) = - " The failure occurred during the configure step." - renderFailureExtraDetail (InstallFailed _) = - " The failure occurred during the final install step." - renderFailureExtraDetail _ = - "" - - renderDependencyOf pkgid = - case ultimateDeps pkgid of - [] -> "" - (p1:[]) -> - " (which is required by " ++ elabPlanPackageName verbosity p1 ++ ")" - (p1:p2:[]) -> - " (which is required by " ++ elabPlanPackageName verbosity p1 - ++ " and " ++ elabPlanPackageName verbosity p2 ++ ")" - (p1:p2:_) -> - " (which is required by " ++ elabPlanPackageName verbosity p1 - ++ ", " ++ elabPlanPackageName verbosity p2 - ++ " and others)" - - showException e = case fromException e of - Just (ExitFailure 1) -> "" - -#ifdef MIN_VERSION_unix - -- Note [Positive "signal" exit code] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- What's the business with the test for negative and positive - -- signal values? The API for process specifies that if the - -- process died due to a signal, it returns a *negative* exit - -- code. So that's the negative test. - -- - -- What about the positive test? Well, when we find out that - -- a process died due to a signal, we ourselves exit with that - -- exit code. However, we don't "kill ourselves" with the - -- signal; we just exit with the same code as the signal: thus - -- the caller sees a *positive* exit code. So that's what - -- happens when we get a positive exit code. - Just (ExitFailure n) - | -n == fromIntegral sigSEGV -> - " The build process segfaulted (i.e. SIGSEGV)." - - | n == fromIntegral sigSEGV -> - " The build process terminated with exit code " ++ show n - ++ " which may be because some part of it segfaulted. (i.e. SIGSEGV)." - - | -n == fromIntegral sigKILL -> - " The build process was killed (i.e. SIGKILL). " ++ explanation - - | n == fromIntegral sigKILL -> - " The build process terminated with exit code " ++ show n - ++ " which may be because some part of it was killed " - ++ "(i.e. SIGKILL). " ++ explanation - where - explanation = - "The typical reason for this is that there is not " - ++ "enough memory available (e.g. the OS killed a process " - ++ "using lots of memory)." -#endif - Just (ExitFailure n) -> - " The build process terminated with exit code " ++ show n - - _ -> " The exception was:\n " -#if MIN_VERSION_base(4,8,0) - ++ displayException e -#else - ++ show e -#endif - - buildFailureException reason = - case reason of - DownloadFailed e -> Just e - UnpackFailed e -> Just e - ConfigureFailed e -> Just e - BuildFailed e -> Just e - ReplFailed e -> Just e - HaddocksFailed e -> Just e - TestsFailed e -> Just e - BenchFailed e -> Just e - InstallFailed e -> Just e - DependentFailed _ -> Nothing - -data BuildFailurePresentation = - ShowBuildSummaryOnly BuildFailureReason - | ShowBuildSummaryAndLog BuildFailureReason FilePath - - -cmdCommonHelpTextNewBuildBeta :: String -cmdCommonHelpTextNewBuildBeta = - "Note: this command is part of the new project-based system (aka " - ++ "nix-style\nlocal builds). These features are currently in beta. " - ++ "Please see\n" - ++ "http://cabal.readthedocs.io/en/latest/nix-local-build-overview.html " - ++ "for\ndetails and advice on what you can expect to work. If you " - ++ "encounter problems\nplease file issues at " - ++ "https://github.com/haskell/cabal/issues and if you\nhave any time " - ++ "to get involved and help with testing, fixing bugs etc then\nthat " - ++ "is very much appreciated.\n" - -------------------------------------------------------------------------------- --- Dummy projects -------------------------------------------------------------------------------- - --- | Create a dummy project context, without a .cabal or a .cabal.project file --- (a place where to put a temporary dist directory is still needed) -establishDummyProjectBaseContext - :: Verbosity - -> ProjectConfig - -> DistDirLayout - -- ^ Where to put the dist directory - -> [PackageSpecifier UnresolvedSourcePackage] - -- ^ The packages to be included in the project - -> CurrentCommand - -> IO ProjectBaseContext -establishDummyProjectBaseContext verbosity cliConfig distDirLayout localPackages currentCommand = do - cabalDir <- getCabalDir - - globalConfig <- runRebuild "" - $ readGlobalConfig verbosity - $ projectConfigConfigFile - $ projectConfigShared cliConfig - let projectConfig = globalConfig <> cliConfig - - let ProjectConfigBuildOnly { - projectConfigLogsDir - } = projectConfigBuildOnly projectConfig - - ProjectConfigShared { - projectConfigStoreDir - } = projectConfigShared projectConfig - - mlogsDir = flagToMaybe projectConfigLogsDir - mstoreDir = flagToMaybe projectConfigStoreDir - cabalDirLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir - - buildSettings = resolveBuildTimeSettings - verbosity cabalDirLayout - projectConfig - - return ProjectBaseContext { - distDirLayout, - cabalDirLayout, - projectConfig, - localPackages, - buildSettings, - currentCommand - } - -establishDummyDistDirLayout :: Verbosity -> ProjectConfig -> FilePath -> IO DistDirLayout -establishDummyDistDirLayout verbosity cliConfig tmpDir = do - let distDirLayout = defaultDistDirLayout projectRoot mdistDirectory - - -- Create the dist directories - createDirectoryIfMissingVerbose verbosity True $ distDirectory distDirLayout - createDirectoryIfMissingVerbose verbosity True $ distProjectCacheDirectory distDirLayout - - return distDirLayout - where - mdistDirectory = flagToMaybe - $ projectConfigDistDir - $ projectConfigShared cliConfig - projectRoot = ProjectRootImplicit tmpDir diff --git a/cabal/cabal-install/Distribution/Client/ProjectPlanOutput.hs b/cabal/cabal-install/Distribution/Client/ProjectPlanOutput.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/ProjectPlanOutput.hs +++ /dev/null @@ -1,939 +0,0 @@ -{-# LANGUAGE BangPatterns, RecordWildCards, NamedFieldPuns, - DeriveGeneric, DeriveDataTypeable, GeneralizedNewtypeDeriving, - ScopedTypeVariables #-} - -module Distribution.Client.ProjectPlanOutput ( - -- * Plan output - writePlanExternalRepresentation, - - -- * Project status - -- | Several outputs rely on having a general overview of - PostBuildProjectStatus(..), - updatePostBuildProjectStatus, - createPackageEnvironment, - writePlanGhcEnvironment, - argsEquivalentOfGhcEnvironmentFile, - ) where - -import Distribution.Client.ProjectPlanning.Types -import Distribution.Client.ProjectBuilding.Types -import Distribution.Client.DistDirLayout -import Distribution.Client.Types.Repo (Repo(..), RemoteRepo(..)) -import Distribution.Client.Types.PackageLocation (PackageLocation(..)) -import Distribution.Client.Types.ConfiguredId (confInstId) -import Distribution.Client.Types.SourceRepo (SourceRepoMaybe, SourceRepositoryPackage (..)) -import Distribution.Client.HashValue (showHashValue, hashValue) -import Distribution.Client.Utils (cabalInstallVersion) - -import qualified Distribution.Client.InstallPlan as InstallPlan -import qualified Distribution.Client.Utils.Json as J -import qualified Distribution.Simple.InstallDirs as InstallDirs - -import qualified Distribution.Solver.Types.ComponentDeps as ComponentDeps - -import Distribution.Package -import Distribution.System -import Distribution.InstalledPackageInfo (InstalledPackageInfo) -import qualified Distribution.PackageDescription as PD -import Distribution.Compiler (CompilerFlavor(GHC, GHCJS)) -import Distribution.Simple.Compiler - ( PackageDBStack, PackageDB(..) - , compilerVersion, compilerFlavor, showCompilerId - , compilerId, CompilerId(..), Compiler ) -import Distribution.Simple.GHC - ( getImplInfo, GhcImplInfo(supportsPkgEnvFiles) - , GhcEnvironmentFileEntry(..), simpleGhcEnvironmentFile - , writeGhcEnvironmentFile ) -import Distribution.Simple.BuildPaths - ( dllExtension, exeExtension ) -import qualified Distribution.Compat.Graph as Graph -import Distribution.Compat.Graph (Graph, Node) -import qualified Distribution.Compat.Binary as Binary -import Distribution.Simple.Utils -import Distribution.Verbosity - -import Prelude () -import Distribution.Client.Compat.Prelude - -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Data.ByteString.Lazy as BS -import qualified Data.ByteString.Builder as BB - -import System.FilePath -import System.IO - -import Distribution.Simple.Program.GHC (packageDbArgsDb) - ------------------------------------------------------------------------------ --- Writing plan.json files --- - --- | Write out a representation of the elaborated install plan. --- --- This is for the benefit of debugging and external tools like editors. --- -writePlanExternalRepresentation :: DistDirLayout - -> ElaboratedInstallPlan - -> ElaboratedSharedConfig - -> IO () -writePlanExternalRepresentation distDirLayout elaboratedInstallPlan - elaboratedSharedConfig = - writeFileAtomic (distProjectCacheFile distDirLayout "plan.json") $ - BB.toLazyByteString - . J.encodeToBuilder - $ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig - --- | Renders a subset of the elaborated install plan in a semi-stable JSON --- format. --- -encodePlanAsJson :: DistDirLayout -> ElaboratedInstallPlan -> ElaboratedSharedConfig -> J.Value -encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = - --TODO: [nice to have] include all of the sharedPackageConfig and all of - -- the parts of the elaboratedInstallPlan - J.object [ "cabal-version" J..= jdisplay cabalInstallVersion - , "cabal-lib-version" J..= jdisplay cabalVersion - , "compiler-id" J..= (J.String . showCompilerId . pkgConfigCompiler) - elaboratedSharedConfig - , "os" J..= jdisplay os - , "arch" J..= jdisplay arch - , "install-plan" J..= installPlanToJ elaboratedInstallPlan - ] - where - plat@(Platform arch os) = pkgConfigPlatform elaboratedSharedConfig - - installPlanToJ :: ElaboratedInstallPlan -> [J.Value] - installPlanToJ = map planPackageToJ . InstallPlan.toList - - planPackageToJ :: ElaboratedPlanPackage -> J.Value - planPackageToJ pkg = - case pkg of - InstallPlan.PreExisting ipi -> installedPackageInfoToJ ipi - InstallPlan.Configured elab -> elaboratedPackageToJ False elab - InstallPlan.Installed elab -> elaboratedPackageToJ True elab - -- Note that the plan.json currently only uses the elaborated plan, - -- not the improved plan. So we will not get the Installed state for - -- 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 ipi = - -- Pre-existing packages lack configuration information such as their flag - -- settings or non-lib components. We only get pre-existing packages for - -- the global/core packages however, so this isn't generally a problem. - -- So these packages are never local to the project. - -- - J.object - [ "type" J..= J.String "pre-existing" - , "id" J..= (jdisplay . installedUnitId) ipi - , "pkg-name" J..= (jdisplay . pkgName . packageId) ipi - , "pkg-version" J..= (jdisplay . pkgVersion . packageId) ipi - , "depends" J..= map jdisplay (installedDepends ipi) - ] - - elaboratedPackageToJ :: Bool -> ElaboratedConfiguredPackage -> J.Value - elaboratedPackageToJ isInstalled elab = - J.object $ - [ "type" J..= J.String (if isInstalled then "installed" - else "configured") - , "id" J..= (jdisplay . installedUnitId) elab - , "pkg-name" J..= (jdisplay . pkgName . packageId) elab - , "pkg-version" J..= (jdisplay . pkgVersion . packageId) elab - , "flags" J..= J.object [ PD.unFlagName fn J..= v - | (fn,v) <- PD.unFlagAssignment (elabFlagAssignment elab) ] - , "style" J..= J.String (style2str (elabLocalToProject elab) (elabBuildStyle elab)) - , "pkg-src" J..= packageLocationToJ (elabPkgSourceLocation elab) - ] ++ - [ "pkg-cabal-sha256" J..= J.String (showHashValue hash) - | Just hash <- [ fmap hashValue (elabPkgDescriptionOverride elab) ] ] ++ - [ "pkg-src-sha256" J..= J.String (showHashValue hash) - | Just hash <- [elabPkgSourceHash elab] ] ++ - (case elabBuildStyle elab of - BuildInplaceOnly -> - ["dist-dir" J..= J.String dist_dir] - BuildAndInstall -> - -- TODO: install dirs? - [] - ) ++ - case elabPkgOrComp elab of - ElabPackage pkg -> - let components = J.object $ - [ comp2str c J..= (J.object $ - [ "depends" J..= map (jdisplay . confInstId) ldeps - , "exe-depends" J..= map (jdisplay . confInstId) edeps - ] ++ - bin_file c) - | (c,(ldeps,edeps)) - <- ComponentDeps.toList $ - ComponentDeps.zip (pkgLibDependencies pkg) - (pkgExeDependencies pkg) ] - in ["components" J..= components] - ElabComponent comp -> - ["depends" J..= map (jdisplay . confInstId) (elabLibDependencies elab) - ,"exe-depends" J..= map jdisplay (elabExeDependencies elab) - ,"component-name" J..= J.String (comp2str (compSolverName comp)) - ] ++ - bin_file (compSolverName comp) - where - packageLocationToJ :: PackageLocation (Maybe FilePath) -> J.Value - packageLocationToJ pkgloc = - case pkgloc of - LocalUnpackedPackage local -> - J.object [ "type" J..= J.String "local" - , "path" J..= J.String local - ] - LocalTarballPackage local -> - J.object [ "type" J..= J.String "local-tar" - , "path" J..= J.String local - ] - RemoteTarballPackage uri _ -> - J.object [ "type" J..= J.String "remote-tar" - , "uri" J..= J.String (show uri) - ] - RepoTarballPackage repo _ _ -> - J.object [ "type" J..= J.String "repo-tar" - , "repo" J..= repoToJ repo - ] - RemoteSourceRepoPackage srcRepo _ -> - J.object [ "type" J..= J.String "source-repo" - , "source-repo" J..= sourceRepoToJ srcRepo - ] - - repoToJ :: Repo -> J.Value - repoToJ repo = - case repo of - RepoLocalNoIndex{..} -> - J.object [ "type" J..= J.String "local-repo-no-index" - , "path" J..= J.String repoLocalDir - ] - RepoRemote{..} -> - J.object [ "type" J..= J.String "remote-repo" - , "uri" J..= J.String (show (remoteRepoURI repoRemote)) - ] - RepoSecure{..} -> - J.object [ "type" J..= J.String "secure-repo" - , "uri" J..= J.String (show (remoteRepoURI repoRemote)) - ] - - sourceRepoToJ :: SourceRepoMaybe -> J.Value - sourceRepoToJ SourceRepositoryPackage{..} = - J.object $ filter ((/= J.Null) . snd) $ - [ "type" J..= jdisplay srpType - , "location" J..= J.String srpLocation - , "branch" J..= fmap J.String srpBranch - , "tag" J..= fmap J.String srpTag - , "subdir" J..= fmap J.String srpSubdir - ] - - dist_dir = distBuildDirectory distDirLayout - (elabDistDirParams elaboratedSharedConfig elab) - - bin_file c = case c of - ComponentDeps.ComponentExe s -> bin_file' s - ComponentDeps.ComponentTest s -> bin_file' s - ComponentDeps.ComponentBench s -> bin_file' s - ComponentDeps.ComponentFLib s -> flib_file' s - _ -> [] - bin_file' s = - ["bin-file" J..= J.String bin] - where - bin = if elabBuildStyle elab == BuildInplaceOnly - then dist_dir "build" prettyShow s prettyShow s <.> exeExtension plat - else InstallDirs.bindir (elabInstallDirs elab) prettyShow s <.> exeExtension plat - - flib_file' s = - ["bin-file" J..= J.String bin] - where - bin = if elabBuildStyle elab == BuildInplaceOnly - then dist_dir "build" prettyShow s ("lib" ++ prettyShow s) <.> dllExtension plat - else InstallDirs.bindir (elabInstallDirs elab) ("lib" ++ prettyShow s) <.> dllExtension plat - - comp2str :: ComponentDeps.Component -> String - comp2str = prettyShow - - style2str :: Bool -> BuildStyle -> String - style2str True _ = "local" - style2str False BuildInplaceOnly = "inplace" - style2str False BuildAndInstall = "global" - - jdisplay :: Pretty a => a -> J.Value - jdisplay = J.String . prettyShow - - ------------------------------------------------------------------------------ --- Project status --- - --- So, what is the status of a project after a build? That is, how do the --- inputs (package source files etc) compare to the output artefacts (build --- libs, exes etc)? Do the outputs reflect the current values of the inputs --- or are outputs out of date or invalid? --- --- First of all, what do we mean by out-of-date and what do we mean by --- invalid? We think of the build system as a morally pure function that --- computes the output artefacts given input values. We say an output artefact --- is out of date when its value is not the value that would be computed by a --- build given the current values of the inputs. An output artefact can be --- out-of-date but still be perfectly usable; it simply correspond to a --- previous state of the inputs. --- --- On the other hand there are cases where output artefacts cannot safely be --- used. For example libraries and dynamically linked executables cannot be --- used when the libs they depend on change without them being recompiled --- themselves. Whether an artefact is still usable depends on what it is, e.g. --- dynamically linked vs statically linked and on how it gets updated (e.g. --- only atomically on success or if failure can leave invalid states). We need --- a definition (or two) that is independent of the kind of artefact and can --- be computed just in terms of changes in package graphs, but are still --- useful for determining when particular kinds of artefacts are invalid. --- --- Note that when we talk about packages in this context we just mean nodes --- in the elaborated install plan, which can be components or packages. --- --- There's obviously a close connection between packages being out of date and --- their output artefacts being unusable: most of the time if a package --- remains out of date at the end of a build then some of its output artefacts --- will be unusable. That is true most of the time because a build will have --- attempted to build one of the out-of-date package's dependencies. If the --- build of the dependency succeeded then it changed output artefacts (like --- libs) and if it failed then it may have failed after already changing --- things (think failure after updating some but not all .hi files). --- --- There are a few reasons we may end up with still-usable output artefacts --- for a package even when it remains out of date at the end of a build. --- Firstly if executing a plan fails then packages can be skipped, and thus we --- may have packages where all their dependencies were skipped. Secondly we --- have artefacts like statically linked executables which are not affected by --- libs they depend on being recompiled. Furthermore, packages can be out of --- date due to changes in build tools or Setup.hs scripts they depend on, but --- again libraries or executables in those out-of-date packages remain usable. --- --- So we have two useful definitions of invalid. Both are useful, for --- different purposes, so we will compute both. The first corresponds to the --- invalid libraries and dynamic executables. We say a package is invalid by --- changed deps if any of the packages it depends on (via library dep edges) --- were rebuilt (successfully or unsuccessfully). The second definition --- corresponds to invalid static executables. We say a package is invalid by --- a failed build simply if the package was built but unsuccessfully. --- --- So how do we find out what packages are out of date or invalid? --- --- Obviously we know something for all the packages that were part of the plan --- that was executed, but that is just a subset since we prune the plan down --- to the targets and their dependencies. --- --- Recall the steps we go though: --- --- + starting with the initial improved plan (this is the full project); --- --- + prune the plan to the user's build targets; --- --- + rebuildTargetsDryRun on the pruned plan giving us a BuildStatusMap --- covering the pruned subset of the original plan; --- --- + execute the plan giving us BuildOutcomes which tell us success/failure --- for each package. --- --- So given that the BuildStatusMap and BuildOutcomes do not cover everything --- in the original plan, what can they tell us about the original plan? --- --- The BuildStatusMap tells us directly that some packages are up to date and --- others out of date (but only for the pruned subset). But we know that --- everything that is a reverse dependency of an out-of-date package is itself --- out-of-date (whether or not it is in the pruned subset). Of course after --- a build the BuildOutcomes may tell us that some of those out-of-date --- packages are now up to date (ie a successful build outcome). --- --- The difference is packages that are reverse dependencies of out-of-date --- packages but are not brought up-to-date by the build (i.e. did not have --- successful outcomes, either because they failed or were not in the pruned --- subset to be built). We also know which packages were rebuilt, so we can --- use this to find the now-invalid packages. --- --- Note that there are still packages for which we cannot discover full status --- information. There may be packages outside of the pruned plan that do not --- depend on packages within the pruned plan that were discovered to be --- out-of-date. For these packages we do not know if their build artefacts --- are out-of-date or not. We do know however that they are not invalid, as --- that's not possible given our definition of invalid. Intuitively it is --- because we have not disturbed anything that these packages depend on, e.g. --- we've not rebuilt any libs they depend on. Recall that our widest --- definition of invalid was only concerned about dependencies on libraries --- (to cover problems like shared libs or GHC seeing inconsistent .hi files). --- --- So our algorithm for out-of-date packages is relatively simple: take the --- reverse dependency closure in the original improved plan (pre-pruning) of --- the out-of-date packages (as determined by the BuildStatusMap from the dry --- run). That gives a set of packages that were definitely out of date after --- the dry run. Now we remove from this set the packages that the --- BuildOutcomes tells us are now up-to-date after the build. The remaining --- set is the out-of-date packages. --- --- As for packages that are invalid by changed deps, we start with the plan --- dependency graph but keep only those edges that point to libraries (so --- ignoring deps on exes and setup scripts). We take the packages for which a --- build was attempted (successfully or unsuccessfully, but not counting --- knock-on failures) and take the reverse dependency closure. We delete from --- this set all the packages that were built successfully. Note that we do not --- need to intersect with the out-of-date packages since this follows --- automatically: all rev deps of packages we attempted to build must have --- been out of date at the start of the build, and if they were not built --- successfully then they're still out of date -- meeting our definition of --- invalid. - - -type PackageIdSet = Set UnitId -type PackagesUpToDate = PackageIdSet - -data PostBuildProjectStatus = PostBuildProjectStatus { - - -- | Packages that are known to be up to date. These were found to be - -- up to date before the build, or they have a successful build outcome - -- afterwards. - -- - -- This does not include any packages outside of the subset of the plan - -- that was executed because we did not check those and so don't know - -- for sure that they're still up to date. - -- - packagesDefinitelyUpToDate :: PackageIdSet, - - -- | Packages that are probably still up to date (and at least not - -- known to be out of date, and certainly not invalid). This includes - -- 'packagesDefinitelyUpToDate' plus packages that were up to date - -- previously and are outside of the subset of the plan that was - -- executed. It excludes 'packagesOutOfDate'. - -- - packagesProbablyUpToDate :: PackageIdSet, - - -- | Packages that are known to be out of date. These are packages - -- that were determined to be out of date before the build, and they - -- do not have a successful build outcome afterwards. - -- - -- Note that this can sometimes include packages outside of the subset - -- of the plan that was executed. For example suppose package A and B - -- depend on C, and A is the target so only A and C are in the subset - -- to be built. Now suppose C is found to have changed, then both A - -- and B are out-of-date before the build and since B is outside the - -- subset to be built then it will remain out of date. - -- - -- Note also that this is /not/ the inverse of - -- 'packagesDefinitelyUpToDate' or 'packagesProbablyUpToDate'. - -- There are packages where we have no information (ones that were not - -- in the subset of the plan that was executed). - -- - packagesOutOfDate :: PackageIdSet, - - -- | Packages that depend on libraries that have changed during the - -- build (either build success or failure). - -- - -- This corresponds to the fact that libraries and dynamic executables - -- are invalid once any of the libs they depend on change. - -- - -- This does include packages that themselves failed (i.e. it is a - -- superset of 'packagesInvalidByFailedBuild'). It does not include - -- changes in dependencies on executables (i.e. build tools). - -- - packagesInvalidByChangedLibDeps :: PackageIdSet, - - -- | Packages that themselves failed during the build (i.e. them - -- directly not a dep). - -- - -- This corresponds to the fact that static executables are invalid - -- in unlucky circumstances such as linking failing half way though, - -- or data file generation failing. - -- - -- This is a subset of 'packagesInvalidByChangedLibDeps'. - -- - packagesInvalidByFailedBuild :: PackageIdSet, - - -- | 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. - -- - -- This is here as a convenience, as strictly speaking it's not status - -- as it's just a function of the original 'ElaboratedInstallPlan'. - -- - packagesLibDepGraph :: Graph (Node UnitId ElaboratedPlanPackage), - - -- | As a convenience for 'Set.intersection' with any of the other - -- 'PackageIdSet's to select only packages that are part of the - -- project locally (i.e. with a local source dir). - -- - packagesBuildLocal :: PackageIdSet, - - -- | As a convenience for 'Set.intersection' with any of the other - -- 'PackageIdSet's to select only packages that are being built - -- in-place within the project (i.e. not destined for the store). - -- - packagesBuildInplace :: PackageIdSet, - - -- | As a convenience for 'Set.intersection' or 'Set.difference' with - -- any of the other 'PackageIdSet's to select only packages that were - -- pre-installed or already in the store prior to the build. - -- - packagesAlreadyInStore :: PackageIdSet - } - --- | Work out which packages are out of date or invalid after a build. --- -postBuildProjectStatus :: ElaboratedInstallPlan - -> PackagesUpToDate - -> BuildStatusMap - -> BuildOutcomes - -> PostBuildProjectStatus -postBuildProjectStatus plan previousPackagesUpToDate - pkgBuildStatus buildOutcomes = - PostBuildProjectStatus { - packagesDefinitelyUpToDate, - packagesProbablyUpToDate, - packagesOutOfDate, - packagesInvalidByChangedLibDeps, - packagesInvalidByFailedBuild, - -- convenience stuff - packagesLibDepGraph, - packagesBuildLocal, - packagesBuildInplace, - packagesAlreadyInStore - } - where - packagesDefinitelyUpToDate = - packagesUpToDatePreBuild - `Set.union` - packagesSuccessfulPostBuild - - packagesProbablyUpToDate = - packagesDefinitelyUpToDate - `Set.union` - (previousPackagesUpToDate' `Set.difference` packagesOutOfDatePreBuild) - - packagesOutOfDate = - packagesOutOfDatePreBuild `Set.difference` packagesSuccessfulPostBuild - - packagesInvalidByChangedLibDeps = - packagesDepOnChangedLib `Set.difference` packagesSuccessfulPostBuild - - packagesInvalidByFailedBuild = - packagesFailurePostBuild - - -- Note: if any of the intermediate values below turn out to be useful in - -- their own right then we can simply promote them to the result record - - -- 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.intersection - previousPackagesUpToDate - (InstallPlan.keysSet plan) - - packagesUpToDatePreBuild = - Set.filter - (\ipkgid -> not (lookupBuildStatusRequiresBuild True 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 /up to date/. - (InstallPlan.keysSet plan) - - packagesOutOfDatePreBuild = - Set.fromList . map installedUnitId $ - InstallPlan.reverseDependencyClosure plan - [ ipkgid - | pkg <- InstallPlan.toList plan - , let ipkgid = installedUnitId 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.fromList - [ ikgid | (ikgid, Right _) <- Map.toList buildOutcomes ] - - -- direct failures, not failures due to deps - packagesFailurePostBuild = - Set.fromList - [ ikgid - | (ikgid, Left failure) <- Map.toList buildOutcomes - , case buildFailureReason failure of - DependentFailed _ -> False - _ -> True - ] - - -- Packages that have a library dependency on a package for which a build - -- was attempted - packagesDepOnChangedLib = - Set.fromList . map Graph.nodeKey $ - fromMaybe (error "packagesBuildStatusAfterBuild: broken dep closure") $ - Graph.revClosure packagesLibDepGraph - ( Map.keys - . Map.filter (uncurry buildAttempted) - $ Map.intersectionWith (,) pkgBuildStatus buildOutcomes - ) - - -- The plan graph but only counting dependency-on-library edges - packagesLibDepGraph :: Graph (Node UnitId ElaboratedPlanPackage) - packagesLibDepGraph = - Graph.fromDistinctList - [ Graph.N pkg (installedUnitId 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 - ] - elabLibDeps = map (newSimpleUnitId . confInstId) . 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. - buildAttempted :: BuildStatus -> BuildOutcome -> Bool - -- And not if it didn't need rebuilding in the first place. - buildAttempted buildStatus _buildOutcome - | not (buildStatusRequiresBuild buildStatus) - = False - - -- And not if it was skipped due to a dep failing first. - buildAttempted _ (Left BuildFailure {buildFailureReason}) - | DependentFailed _ <- buildFailureReason - = False - - -- Otherwise, succeeded or failed, yes the build was tried. - buildAttempted _ (Left BuildFailure {}) = True - buildAttempted _ (Right _) = True - - lookupBuildStatusRequiresBuild def ipkgid = - case Map.lookup ipkgid pkgBuildStatus of - Nothing -> def -- Not in the plan subset we did the dry-run on - Just buildStatus -> buildStatusRequiresBuild buildStatus - - packagesBuildLocal = - selectPlanPackageIdSet $ \pkg -> - case pkg of - InstallPlan.PreExisting _ -> False - InstallPlan.Installed _ -> False - InstallPlan.Configured srcpkg -> elabLocalToProject srcpkg - - packagesBuildInplace = - selectPlanPackageIdSet $ \pkg -> - case pkg of - InstallPlan.PreExisting _ -> False - InstallPlan.Installed _ -> False - InstallPlan.Configured srcpkg -> elabBuildStyle srcpkg - == BuildInplaceOnly - - packagesAlreadyInStore = - selectPlanPackageIdSet $ \pkg -> - case pkg of - InstallPlan.PreExisting _ -> True - InstallPlan.Installed _ -> True - InstallPlan.Configured _ -> False - - selectPlanPackageIdSet p = Map.keysSet - . Map.filter p - $ InstallPlan.toMap plan - - - -updatePostBuildProjectStatus :: Verbosity - -> DistDirLayout - -> ElaboratedInstallPlan - -> BuildStatusMap - -> BuildOutcomes - -> IO PostBuildProjectStatus -updatePostBuildProjectStatus verbosity distDirLayout - elaboratedInstallPlan - pkgsBuildStatus buildOutcomes = do - - -- Read the previous up-to-date set, update it and write it back - previousUpToDate <- readPackagesUpToDateCacheFile distDirLayout - let currentBuildStatus@PostBuildProjectStatus{..} - = postBuildProjectStatus - elaboratedInstallPlan - previousUpToDate - pkgsBuildStatus - buildOutcomes - let currentUpToDate = packagesProbablyUpToDate - writePackagesUpToDateCacheFile distDirLayout currentUpToDate - - -- Report various possibly interesting things - -- We additionally intersect with the packagesBuildInplace so that - -- we don't show huge numbers of boring packages from the store. - debugNoWrap verbosity $ - "packages definitely up to date: " - ++ displayPackageIdSet (packagesDefinitelyUpToDate - `Set.intersection` packagesBuildInplace) - - debugNoWrap verbosity $ - "packages previously probably up to date: " - ++ displayPackageIdSet (previousUpToDate - `Set.intersection` packagesBuildInplace) - - debugNoWrap verbosity $ - "packages now probably up to date: " - ++ displayPackageIdSet (packagesProbablyUpToDate - `Set.intersection` packagesBuildInplace) - - debugNoWrap verbosity $ - "packages newly up to date: " - ++ displayPackageIdSet (packagesDefinitelyUpToDate - `Set.difference` previousUpToDate - `Set.intersection` packagesBuildInplace) - - debugNoWrap verbosity $ - "packages out to date: " - ++ displayPackageIdSet (packagesOutOfDate - `Set.intersection` packagesBuildInplace) - - debugNoWrap verbosity $ - "packages invalid due to dep change: " - ++ displayPackageIdSet packagesInvalidByChangedLibDeps - - debugNoWrap verbosity $ - "packages invalid due to build failure: " - ++ displayPackageIdSet packagesInvalidByFailedBuild - - return currentBuildStatus - where - displayPackageIdSet = intercalate ", " . map prettyShow . Set.toList - --- | Helper for reading the cache file. --- --- This determines the type and format of the binary cache file. --- -readPackagesUpToDateCacheFile :: DistDirLayout -> IO PackagesUpToDate -readPackagesUpToDateCacheFile DistDirLayout{distProjectCacheFile} = - handleDoesNotExist Set.empty $ - handleDecodeFailure $ - withBinaryFile (distProjectCacheFile "up-to-date") ReadMode $ \hnd -> - Binary.decodeOrFailIO =<< BS.hGetContents hnd - where - handleDecodeFailure = fmap (either (const Set.empty) id) - --- | Helper for writing the package up-to-date cache file. --- --- This determines the type and format of the binary cache file. --- -writePackagesUpToDateCacheFile :: DistDirLayout -> PackagesUpToDate -> IO () -writePackagesUpToDateCacheFile DistDirLayout{distProjectCacheFile} upToDate = - writeFileAtomic (distProjectCacheFile "up-to-date") $ - Binary.encode upToDate - --- | Prepare a package environment that includes all the library dependencies --- for a plan. --- --- When running cabal new-exec, we want to set things up so that the compiler --- can find all the right packages (and nothing else). This function is --- intended to do that work. It takes a location where it can write files --- temporarily, in case the compiler wants to learn this information via the --- filesystem, and returns any environment variable overrides the compiler --- needs. -createPackageEnvironment :: Verbosity - -> FilePath - -> ElaboratedInstallPlan - -> ElaboratedSharedConfig - -> PostBuildProjectStatus - -> IO [(String, Maybe String)] -createPackageEnvironment verbosity - path - elaboratedPlan - elaboratedShared - buildStatus - | compilerFlavor (pkgConfigCompiler elaboratedShared) == GHC - = do - envFileM <- writePlanGhcEnvironment - path - elaboratedPlan - elaboratedShared - buildStatus - case envFileM of - Just envFile -> return [("GHC_ENVIRONMENT", Just envFile)] - Nothing -> do - warn verbosity "the configured version of GHC does not support reading package lists from the environment; commands that need the current project's package database are likely to fail" - return [] - | otherwise - = 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 [] - --- Writing .ghc.environment files --- - -writePlanGhcEnvironment :: FilePath - -> ElaboratedInstallPlan - -> ElaboratedSharedConfig - -> PostBuildProjectStatus - -> IO (Maybe FilePath) -writePlanGhcEnvironment path - elaboratedInstallPlan - ElaboratedSharedConfig { - pkgConfigCompiler = compiler, - pkgConfigPlatform = platform - } - postBuildStatus - | compilerFlavor compiler == GHC - , supportsPkgEnvFiles (getImplInfo compiler) - --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/ - -writePlanGhcEnvironment _ _ _ _ = return Nothing - -renderGhcEnvironmentFile :: FilePath - -> ElaboratedInstallPlan - -> PostBuildProjectStatus - -> [GhcEnvironmentFileEntry] -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" - ++ "run ghc or ghci and get the environment of the project as a whole.\n" - ++ "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 - packageDBs = relativePackageDBPaths projectRootDir $ - selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan - - -argsEquivalentOfGhcEnvironmentFile - :: Compiler - -> DistDirLayout - -> ElaboratedInstallPlan - -> PostBuildProjectStatus - -> [String] -argsEquivalentOfGhcEnvironmentFile compiler = - case compilerId compiler - of CompilerId GHC _ -> argsEquivalentOfGhcEnvironmentFileGhc - CompilerId GHCJS _ -> argsEquivalentOfGhcEnvironmentFileGhc - CompilerId _ _ -> error "Only GHC and GHCJS are supported" - --- TODO remove this when we drop support for non-.ghc.env ghc -argsEquivalentOfGhcEnvironmentFileGhc - :: DistDirLayout - -> ElaboratedInstallPlan - -> PostBuildProjectStatus - -> [String] -argsEquivalentOfGhcEnvironmentFileGhc - distDirLayout - elaboratedInstallPlan - postBuildStatus = - clearPackageDbStackFlag - ++ packageDbArgsDb packageDBs - ++ foldMap packageIdFlag packageIds - where - projectRootDir = distProjectRootDirectory distDirLayout - packageIds = selectGhcEnvironmentFileLibraries postBuildStatus - packageDBs = relativePackageDBPaths projectRootDir $ - selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan - -- TODO use proper flags? but packageDbArgsDb is private - clearPackageDbStackFlag = ["-clear-package-db", "-global-package-db"] - packageIdFlag uid = ["-package-id", prettyShow uid] - - --- We're producing an environment for users to use in ghci, so of course --- that means libraries only (can't put exes into the ghc package env!). --- The library environment should be /consistent/ with the environment --- that each of the packages in the project use (ie same lib versions). --- So that means all the normal library dependencies of all the things --- in the project (including deps of exes that are local to the project). --- We do not however want to include the dependencies of Setup.hs scripts, --- since these are generally uninteresting but also they need not in --- general be consistent with the library versions that packages local to --- the project use (recall that Setup.hs script's deps can be picked --- independently of other packages in the project). --- --- So, our strategy is as follows: --- --- produce a dependency graph of all the packages in the install plan, --- but only consider normal library deps as edges in the graph. Thus we --- exclude the dependencies on Setup.hs scripts (in the case of --- per-component granularity) or of Setup.hs scripts (in the case of --- per-package granularity). Then take a dependency closure, using as --- roots all the packages/components local to the project. This will --- exclude Setup scripts and their dependencies. --- --- Note: this algorithm will have to be adapted if/when the install plan --- is extended to cover multiple compilers at once, and may also have to --- change if we start to treat unshared deps of test suites in a similar --- way to how we treat Setup.hs script deps (ie being able to pick them --- independently). --- --- Since we had to use all the local packages, including exes, (as roots --- 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{..} = - case Graph.closure packagesLibDepGraph (Set.toList packagesBuildLocal) of - Nothing -> error "renderGhcEnvironmentFile: broken dep closure" - Just nodes -> [ pkgid | Graph.N pkg pkgid _ <- nodes - , hasUpToDateLib pkg ] - where - hasUpToDateLib planpkg = case planpkg of - -- A pre-existing global lib - InstallPlan.PreExisting _ -> True - - -- A package in the store. Check it's a lib. - InstallPlan.Installed pkg -> elabRequiresRegistration pkg - - -- A package we were installing this time, either destined for the store - -- 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 - - -selectGhcEnvironmentFilePackageDbs :: ElaboratedInstallPlan -> PackageDBStack -selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan = - -- If we have any inplace packages then their package db stack is the - -- one we should use since it'll include the store + the local db but - -- it's certainly possible to have no local inplace packages - -- e.g. just "extra" packages coming from the store. - case (inplacePackages, sourcePackages) of - ([], pkgs) -> checkSamePackageDBs pkgs - (pkgs, _) -> checkSamePackageDBs pkgs - where - checkSamePackageDBs pkgs = - case ordNub (map elabBuildPackageDBStack pkgs) of - [packageDbs] -> packageDbs - [] -> [] - _ -> error $ "renderGhcEnvironmentFile: packages with " - ++ "different package db stacks" - -- This should not happen at the moment but will happen as soon - -- as we support projects where we build packages with different - -- compilers, at which point we have to consider how to adapt - -- this feature, e.g. write out multiple env files, one for each - -- compiler / project profile. - - inplacePackages = - [ srcpkg - | srcpkg <- sourcePackages - , elabBuildStyle srcpkg == BuildInplaceOnly ] - sourcePackages = - [ srcpkg - | pkg <- InstallPlan.toList elaboratedInstallPlan - , srcpkg <- maybeToList $ case pkg of - InstallPlan.Configured srcpkg -> Just srcpkg - InstallPlan.Installed srcpkg -> Just srcpkg - InstallPlan.PreExisting _ -> Nothing - ] - -relativePackageDBPaths :: FilePath -> PackageDBStack -> PackageDBStack -relativePackageDBPaths relroot = map (relativePackageDBPath relroot) - -relativePackageDBPath :: FilePath -> PackageDB -> PackageDB -relativePackageDBPath relroot pkgdb = - case pkgdb of - GlobalPackageDB -> GlobalPackageDB - UserPackageDB -> UserPackageDB - SpecificPackageDB path -> SpecificPackageDB relpath - where relpath = makeRelative relroot path diff --git a/cabal/cabal-install/Distribution/Client/ProjectPlanning.hs b/cabal/cabal-install/Distribution/Client/ProjectPlanning.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/ProjectPlanning.hs +++ /dev/null @@ -1,3798 +0,0 @@ -{-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns, RankNTypes #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE NoMonoLocalBinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} - --- | Planning how to build everything in a project. --- -module Distribution.Client.ProjectPlanning ( - -- * elaborated install plan types - ElaboratedInstallPlan, - ElaboratedConfiguredPackage(..), - ElaboratedPlanPackage, - ElaboratedSharedConfig(..), - ElaboratedReadyPackage, - BuildStyle(..), - CabalFileText, - - -- * Producing the elaborated install plan - rebuildProjectConfig, - rebuildInstallPlan, - - -- * Build targets - availableTargets, - AvailableTarget(..), - AvailableTargetStatus(..), - TargetRequested(..), - ComponentTarget(..), - SubComponentTarget(..), - showComponentTarget, - nubComponentTargets, - - -- * Selecting a plan subset - pruneInstallPlanToTargets, - TargetAction(..), - pruneInstallPlanToDependencies, - CannotPruneDependencies(..), - - -- * Utils required for building - pkgHasEphemeralBuildTargets, - elabBuildTargetWholeComponents, - - -- * Setup.hs CLI flags for building - setupHsScriptOptions, - setupHsConfigureFlags, - setupHsConfigureArgs, - setupHsBuildFlags, - setupHsBuildArgs, - setupHsReplFlags, - setupHsReplArgs, - setupHsTestFlags, - setupHsTestArgs, - setupHsBenchFlags, - setupHsBenchArgs, - setupHsCopyFlags, - setupHsRegisterFlags, - setupHsHaddockFlags, - setupHsHaddockArgs, - - packageHashInputs, - - -- * Path construction - binDirectoryFor, - binDirectories, - storePackageInstallDirs, - storePackageInstallDirs' - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude - -import Distribution.Client.HashValue -import Distribution.Client.ProjectPlanning.Types as Ty -import Distribution.Client.PackageHash -import Distribution.Client.RebuildMonad -import Distribution.Client.Store -import Distribution.Client.ProjectConfig -import Distribution.Client.ProjectPlanOutput - -import Distribution.Client.Types -import qualified Distribution.Client.InstallPlan as InstallPlan -import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan -import Distribution.Client.Dependency -import Distribution.Client.Dependency.Types -import qualified Distribution.Client.IndexUtils as IndexUtils -import Distribution.Client.Init (incVersion) -import Distribution.Client.Targets (userToPackageConstraint) -import Distribution.Client.DistDirLayout -import Distribution.Client.SetupWrapper -import Distribution.Client.JobControl -import Distribution.Client.FetchUtils -import Distribution.Client.Config -import qualified Hackage.Security.Client as Sec -import Distribution.Client.Setup hiding (packageName, cabalVersion) -import Distribution.Utils.NubList -import Distribution.Utils.LogProgress -import Distribution.Utils.MapAccum - -import qualified Distribution.Solver.Types.ComponentDeps as CD -import Distribution.Solver.Types.ComponentDeps (ComponentDeps) -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 -import Distribution.Solver.Types.SolverId -import Distribution.Solver.Types.SolverPackage -import Distribution.Solver.Types.InstSolverPackage -import Distribution.Solver.Types.SourcePackage -import Distribution.Solver.Types.Settings - -import Distribution.CabalSpecVersion -import Distribution.ModuleName -import Distribution.Package -import Distribution.Types.AnnotatedId -import Distribution.Types.ComponentName -import Distribution.Types.LibraryName -import Distribution.Types.GivenComponent - (GivenComponent(..)) -import Distribution.Types.PackageVersionConstraint -import Distribution.Types.PkgconfigDependency -import Distribution.Types.UnqualComponentName -import Distribution.System -import qualified Distribution.PackageDescription as Cabal -import qualified Distribution.PackageDescription as PD -import qualified Distribution.PackageDescription.Configuration as PD -import Distribution.Simple.PackageIndex (InstalledPackageIndex) -import Distribution.Simple.Compiler -import qualified Distribution.Simple.GHC as GHC --TODO: [code cleanup] eliminate -import qualified Distribution.Simple.GHCJS as GHCJS --TODO: [code cleanup] eliminate -import Distribution.Simple.Program -import Distribution.Simple.Program.Db -import Distribution.Simple.Program.Find -import qualified Distribution.Simple.Setup as Cabal -import Distribution.Simple.Setup - (Flag(..), toFlag, flagToMaybe, flagToList, fromFlagOrDefault) -import qualified Distribution.Simple.Configure as Cabal -import qualified Distribution.Simple.LocalBuildInfo as Cabal -import Distribution.Simple.LocalBuildInfo - ( Component(..), pkgComponents, componentBuildInfo - , componentName ) -import qualified Distribution.Simple.InstallDirs as InstallDirs -import qualified Distribution.InstalledPackageInfo as IPI - -import Distribution.Backpack.ConfiguredComponent -import Distribution.Backpack.LinkedComponent -import Distribution.Backpack.ComponentsGraph -import Distribution.Backpack.ModuleShape -import Distribution.Backpack.FullUnitId -import Distribution.Backpack -import Distribution.Types.ComponentInclude - -import Distribution.Simple.Utils -import Distribution.Version - -import qualified Distribution.Compat.Graph as Graph -import Distribution.Compat.Graph(IsNode(..)) - -import Text.PrettyPrint (text, hang, quotes, colon, vcat, ($$), fsep, punctuate, comma) -import qualified Text.PrettyPrint as Disp -import qualified Data.Map as Map -import qualified Data.Set as Set -import Control.Monad.State as State -import Control.Exception (assert) -import Data.List (groupBy) -import qualified Data.List.NonEmpty as NE -import System.FilePath - ------------------------------------------------------------------------------- --- * Elaborated install plan ------------------------------------------------------------------------------- - --- "Elaborated" -- worked out with great care and nicety of detail; --- executed with great minuteness: elaborate preparations; --- elaborate care. --- --- So here's the idea: --- --- Rather than a miscellaneous collection of 'ConfigFlags', 'InstallFlags' etc --- all passed in as separate args and which are then further selected, --- transformed etc during the execution of the build. Instead we construct --- an elaborated install plan that includes everything we will need, and then --- during the execution of the plan we do as little transformation of this --- info as possible. --- --- So we're trying to split the work into two phases: construction of the --- elaborated install plan (which as far as possible should be pure) and --- then simple execution of that plan without any smarts, just doing what the --- plan says to do. --- --- So that means we need a representation of this fully elaborated install --- plan. The representation consists of two parts: --- --- * A 'ElaboratedInstallPlan'. This is a 'GenericInstallPlan' with a --- representation of source packages that includes a lot more detail about --- that package's individual configuration --- --- * A 'ElaboratedSharedConfig'. Some package configuration is the same for --- every package in a plan. Rather than duplicate that info every entry in --- the 'GenericInstallPlan' we keep that separately. --- --- The division between the shared and per-package config is /not set in stone --- for all time/. For example if we wanted to generalise the install plan to --- describe a situation where we want to build some packages with GHC and some --- with GHCJS then the platform and compiler would no longer be shared between --- all packages but would have to be per-package (probably with some sanity --- condition on the graph structure). --- - --- Refer to ProjectPlanning.Types for details of these important types: - --- type ElaboratedInstallPlan = ... --- type ElaboratedPlanPackage = ... --- data ElaboratedSharedConfig = ... --- data ElaboratedConfiguredPackage = ... --- data BuildStyle = - - --- | Check that an 'ElaboratedConfiguredPackage' actually makes --- sense under some 'ElaboratedSharedConfig'. -sanityCheckElaboratedConfiguredPackage - :: ElaboratedSharedConfig - -> ElaboratedConfiguredPackage - -> a - -> a -sanityCheckElaboratedConfiguredPackage sharedConfig - elab@ElaboratedConfiguredPackage{..} = - (case elabPkgOrComp of - ElabPackage pkg -> sanityCheckElaboratedPackage elab pkg - ElabComponent comp -> sanityCheckElaboratedComponent elab comp) - - -- either a package is being built inplace, or the - -- 'installedPackageId' we assigned is consistent with - -- the 'hashedInstalledPackageId' we would compute from - -- the elaborated configured package - . assert (elabBuildStyle == BuildInplaceOnly || - elabComponentId == hashedInstalledPackageId - (packageHashInputs sharedConfig elab)) - - -- the stanzas explicitly disabled should not be available - . assert (Set.null (Map.keysSet (Map.filter not elabStanzasRequested) - `Set.intersection` elabStanzasAvailable)) - - -- either a package is built inplace, or we are not attempting to - -- build any test suites or benchmarks (we never build these - -- for remote packages!) - . assert (elabBuildStyle == BuildInplaceOnly || - Set.null elabStanzasAvailable) - -sanityCheckElaboratedComponent - :: ElaboratedConfiguredPackage - -> ElaboratedComponent - -> a - -> a -sanityCheckElaboratedComponent ElaboratedConfiguredPackage{..} - ElaboratedComponent{..} = - - -- Should not be building bench or test if not inplace. - assert (elabBuildStyle == BuildInplaceOnly || - case compComponentName of - Nothing -> True - Just (CLibName _) -> True - Just (CExeName _) -> True - -- This is interesting: there's no way to declare a dependency - -- on a foreign library at the moment, but you may still want - -- to install these to the store - Just (CFLibName _) -> True - Just (CBenchName _) -> False - Just (CTestName _) -> False) - - -sanityCheckElaboratedPackage - :: ElaboratedConfiguredPackage - -> ElaboratedPackage - -> a - -> a -sanityCheckElaboratedPackage ElaboratedConfiguredPackage{..} - ElaboratedPackage{..} = - -- we should only have enabled stanzas that actually can be built - -- (according to the solver) - assert (pkgStanzasEnabled `Set.isSubsetOf` elabStanzasAvailable) - - -- the stanzas that the user explicitly requested should be - -- enabled (by the previous test, they are also available) - . assert (Map.keysSet (Map.filter id elabStanzasRequested) - `Set.isSubsetOf` pkgStanzasEnabled) - ------------------------------------------------------------------------------- --- * Deciding what to do: making an 'ElaboratedInstallPlan' ------------------------------------------------------------------------------- - --- | Return the up-to-date project config and information about the local --- packages within the project. --- -rebuildProjectConfig :: Verbosity - -> DistDirLayout - -> ProjectConfig - -> IO ( ProjectConfig - , [PackageSpecifier UnresolvedSourcePackage] ) -rebuildProjectConfig verbosity - distDirLayout@DistDirLayout { - distProjectRootDirectory, - distDirectory, - distProjectCacheFile, - distProjectCacheDirectory, - distProjectFile - } - cliConfig = do - - fileMonitorProjectConfigKey <- do - configPath <- getConfigFilePath projectConfigConfigFile - return (configPath, distProjectFile "") - - (projectConfig, localPackages) <- - runRebuild distProjectRootDirectory - $ rerunIfChanged verbosity - fileMonitorProjectConfig - fileMonitorProjectConfigKey - $ do - liftIO $ info verbosity "Project settings changed, reconfiguring..." - projectConfig <- phaseReadProjectConfig - localPackages <- phaseReadLocalPackages projectConfig - return (projectConfig, localPackages) - - info verbosity - $ unlines - $ ("this build was affected by the following (project) config files:" :) - $ [ "- " ++ path - | Explicit path <- Set.toList $ projectConfigProvenance projectConfig - ] - - return (projectConfig <> cliConfig, localPackages) - - where - - ProjectConfigShared { projectConfigConfigFile } = - projectConfigShared cliConfig - - fileMonitorProjectConfig = - newFileMonitor (distProjectCacheFile "config") :: FileMonitor - (FilePath, FilePath) - (ProjectConfig, [PackageSpecifier UnresolvedSourcePackage]) - - -- Read the cabal.project (or implicit config) and combine it with - -- arguments from the command line - -- - phaseReadProjectConfig :: Rebuild ProjectConfig - phaseReadProjectConfig = do - readProjectConfig verbosity projectConfigConfigFile distDirLayout - - -- Look for all the cabal packages in the project - -- some of which may be local src dirs, tarballs etc - -- - phaseReadLocalPackages :: ProjectConfig - -> Rebuild [PackageSpecifier UnresolvedSourcePackage] - phaseReadLocalPackages projectConfig@ProjectConfig { - projectConfigShared, - projectConfigBuildOnly - } = do - pkgLocations <- findProjectPackages distDirLayout projectConfig - - -- Create folder only if findProjectPackages did not throw a - -- BadPackageLocations exception. - liftIO $ do - createDirectoryIfMissingVerbose verbosity True distDirectory - createDirectoryIfMissingVerbose verbosity True distProjectCacheDirectory - - fetchAndReadSourcePackages verbosity distDirLayout - projectConfigShared - projectConfigBuildOnly - pkgLocations - - --- | Return an up-to-date elaborated install plan. --- --- Two variants of the install plan are returned: with and without packages --- from the store. That is, the \"improved\" plan where source packages are --- replaced by pre-existing installed packages from the store (when their ids --- match), and also the original elaborated plan which uses primarily source --- packages. - --- The improved plan is what we use for building, but the original elaborated --- plan is useful for reporting and configuration. For example the @freeze@ --- command needs the source package info to know about flag choices and --- dependencies of executables and setup scripts. --- -rebuildInstallPlan :: Verbosity - -> DistDirLayout -> CabalDirLayout - -> ProjectConfig - -> [PackageSpecifier UnresolvedSourcePackage] - -> IO ( ElaboratedInstallPlan -- with store packages - , ElaboratedInstallPlan -- with source packages - , ElaboratedSharedConfig - , IndexUtils.TotalIndexState - , IndexUtils.ActiveRepos - ) - -- ^ @(improvedPlan, elaboratedPlan, _, _, _)@ -rebuildInstallPlan verbosity - distDirLayout@DistDirLayout { - distProjectRootDirectory, - distProjectCacheFile - } - CabalDirLayout { - cabalStoreDirLayout - } = \projectConfig localPackages -> - runRebuild distProjectRootDirectory $ do - progsearchpath <- liftIO $ getSystemSearchPath - let projectConfigMonitored = projectConfig { projectConfigBuildOnly = mempty } - - -- The overall improved plan is cached - rerunIfChanged verbosity fileMonitorImprovedPlan - -- react to changes in the project config, - -- the package .cabal files and the path - (projectConfigMonitored, localPackages, progsearchpath) $ do - - -- And so is the elaborated plan that the improved plan based on - (elaboratedPlan, elaboratedShared, totalIndexState, activeRepos) <- - rerunIfChanged verbosity fileMonitorElaboratedPlan - (projectConfigMonitored, localPackages, - progsearchpath) $ do - - compilerEtc <- phaseConfigureCompiler projectConfig - _ <- phaseConfigurePrograms projectConfig compilerEtc - (solverPlan, pkgConfigDB, totalIndexState, activeRepos) - <- phaseRunSolver projectConfig - compilerEtc - localPackages - (elaboratedPlan, - elaboratedShared) <- phaseElaboratePlan projectConfig - compilerEtc pkgConfigDB - solverPlan - localPackages - - phaseMaintainPlanOutputs elaboratedPlan elaboratedShared - return (elaboratedPlan, elaboratedShared, totalIndexState, activeRepos) - - -- 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. - improvedPlan <- phaseImprovePlan elaboratedPlan elaboratedShared - - return (improvedPlan, elaboratedPlan, elaboratedShared, totalIndexState, activeRepos) - - where - fileMonitorCompiler = newFileMonitorInCacheDir "compiler" - fileMonitorSolverPlan = newFileMonitorInCacheDir "solver-plan" - fileMonitorSourceHashes = newFileMonitorInCacheDir "source-hashes" - fileMonitorElaboratedPlan = newFileMonitorInCacheDir "elaborated-plan" - fileMonitorImprovedPlan = newFileMonitorInCacheDir "improved-plan" - - newFileMonitorInCacheDir :: Eq a => FilePath -> FileMonitor a b - 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 :: ProjectConfig - -> Rebuild (Compiler, Platform, ProgramDb) - phaseConfigureCompiler ProjectConfig { - projectConfigShared = ProjectConfigShared { - projectConfigHcFlavor, - projectConfigHcPath, - projectConfigHcPkg - }, - projectConfigLocalPackages = PackageConfig { - packageConfigProgramPaths, - packageConfigProgramArgs, - packageConfigProgramPathExtra - } - } = do - progsearchpath <- liftIO $ getSystemSearchPath - rerunIfChanged verbosity fileMonitorCompiler - (hcFlavor, hcPath, hcPkg, progsearchpath, - packageConfigProgramPaths, - packageConfigProgramArgs, - packageConfigProgramPathExtra) $ do - - liftIO $ info verbosity "Compiler settings changed, reconfiguring..." - result@(_, _, progdb') <- liftIO $ - Cabal.configCompilerEx - hcFlavor hcPath hcPkg - 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 - where - hcFlavor = flagToMaybe projectConfigHcFlavor - hcPath = flagToMaybe projectConfigHcPath - hcPkg = flagToMaybe projectConfigHcPkg - progdb = - userSpecifyPaths (Map.toList (getMapLast packageConfigProgramPaths)) - . userSpecifyArgss (Map.toList (getMapMappend packageConfigProgramArgs)) - . modifyProgramSearchPath - (++ [ ProgramSearchPathDir dir - | dir <- fromNubList packageConfigProgramPathExtra ]) - $ defaultProgramDb - - - -- Configuring other programs. - -- - -- Having configred the compiler, now we configure all the remaining - -- programs. This is to check we can find them, and to monitor them for - -- changes. - -- - -- TODO: [required eventually] we don't actually do this yet. - -- - -- We rely on the fact that the previous phase added the program config for - -- all local packages, but that all the programs configured so far are the - -- compiler program or related util programs. - -- - phaseConfigurePrograms :: ProjectConfig - -> (Compiler, Platform, ProgramDb) - -> Rebuild () - phaseConfigurePrograms projectConfig (_, _, compilerprogdb) = 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)) - - --TODO: [required eventually] find/configure other programs that the - -- user specifies. - - --TODO: [required eventually] find/configure all build-tools - -- but note that some of them may be built as part of the plan. - - - -- Run the solver to get the initial install plan. - -- This is expensive so we cache it independently. - -- - phaseRunSolver - :: ProjectConfig - -> (Compiler, Platform, ProgramDb) - -> [PackageSpecifier UnresolvedSourcePackage] - -> Rebuild (SolverInstallPlan, PkgConfigDb, IndexUtils.TotalIndexState, IndexUtils.ActiveRepos) - phaseRunSolver projectConfig@ProjectConfig { - projectConfigShared, - projectConfigBuildOnly - } - (compiler, platform, progdb) - localPackages = - rerunIfChanged verbosity fileMonitorSolverPlan - (solverSettings, - localPackages, localPackagesEnabledStanzas, - compiler, platform, programDbSignature progdb) $ do - - installedPkgIndex <- getInstalledPackages verbosity - compiler progdb platform - corePackageDbs - (sourcePkgDb, tis, ar) <- getSourcePackages verbosity withRepoCtx - (solverSettingIndexState solverSettings) - (solverSettingActiveRepos solverSettings) - pkgConfigDB <- getPkgConfigDb verbosity progdb - - --TODO: [code cleanup] it'd be better if the Compiler contained the - -- ConfiguredPrograms that it needs, rather than relying on the progdb - -- since we don't need to depend on all the programs here, just the - -- ones relevant for the compiler. - - liftIO $ do - solver <- chooseSolver verbosity - (solverSettingSolver solverSettings) - (compilerInfo compiler) - - notice verbosity "Resolving dependencies..." - plan <- foldProgress logMsg (die' verbosity) return $ - planPackages verbosity compiler platform solver solverSettings - installedPkgIndex sourcePkgDb pkgConfigDB - localPackages localPackagesEnabledStanzas - return (plan, pkgConfigDB, tis, ar) - where - corePackageDbs = [GlobalPackageDB] - withRepoCtx = projectConfigWithSolverRepoContext verbosity - projectConfigShared - projectConfigBuildOnly - solverSettings = resolveSolverSettings projectConfig - logMsg message rest = debugNoWrap verbosity message >> rest - - localPackagesEnabledStanzas = - Map.fromList - [ (pkgname, stanzas) - | pkg <- localPackages - -- TODO: misnormer: we should separate - -- builtin/global/inplace/local packages - -- and packages explicitly mentioned in the project - -- - , let pkgname = pkgSpecifierTarget pkg - testsEnabled = lookupLocalPackageConfig - packageConfigTests - projectConfig pkgname - benchmarksEnabled = lookupLocalPackageConfig - packageConfigBenchmarks - projectConfig pkgname - isLocal = isJust (shouldBeLocal pkg) - stanzas - | isLocal = Map.fromList $ - [ (TestStanzas, enabled) - | enabled <- flagToList testsEnabled ] ++ - [ (BenchStanzas , enabled) - | enabled <- flagToList benchmarksEnabled ] - | otherwise = Map.fromList [(TestStanzas, False), (BenchStanzas, False) ] - ] - - -- Elaborate the solver's install plan to get a fully detailed plan. This - -- version of the plan has the final nix-style hashed ids. - -- - phaseElaboratePlan :: ProjectConfig - -> (Compiler, Platform, ProgramDb) - -> PkgConfigDb - -> SolverInstallPlan - -> [PackageSpecifier (SourcePackage (PackageLocation loc))] - -> Rebuild ( ElaboratedInstallPlan - , ElaboratedSharedConfig ) - phaseElaboratePlan ProjectConfig { - projectConfigShared, - projectConfigAllPackages, - projectConfigLocalPackages, - projectConfigSpecificPackage, - projectConfigBuildOnly - } - (compiler, platform, progdb) pkgConfigDB - solverPlan localPackages = do - - liftIO $ debug verbosity "Elaborating the install plan..." - - sourcePackageHashes <- - rerunIfChanged verbosity fileMonitorSourceHashes - (packageLocationsSignature solverPlan) $ - getPackageSourceHashes verbosity withRepoCtx solverPlan - - defaultInstallDirs <- liftIO $ userInstallDirTemplates compiler - (elaboratedPlan, elaboratedShared) - <- liftIO . runLogProgress verbosity $ - elaborateInstallPlan - verbosity - platform compiler progdb pkgConfigDB - distDirLayout - cabalStoreDirLayout - solverPlan - localPackages - sourcePackageHashes - defaultInstallDirs - projectConfigShared - projectConfigAllPackages - projectConfigLocalPackages - (getMapMappend projectConfigSpecificPackage) - let instantiatedPlan - = instantiateInstallPlan - cabalStoreDirLayout - defaultInstallDirs - elaboratedShared - elaboratedPlan - liftIO $ debugNoWrap verbosity (InstallPlan.showInstallPlan instantiatedPlan) - return (instantiatedPlan, elaboratedShared) - where - withRepoCtx = projectConfigWithSolverRepoContext verbosity - projectConfigShared - projectConfigBuildOnly - - -- Update the files we maintain that reflect our current build environment. - -- In particular we maintain a JSON representation of the elaborated - -- install plan (but not the improved plan since that reflects the state - -- of the build rather than just the input environment). - -- - phaseMaintainPlanOutputs :: ElaboratedInstallPlan - -> ElaboratedSharedConfig - -> Rebuild () - phaseMaintainPlanOutputs elaboratedPlan elaboratedShared = liftIO $ do - debug verbosity "Updating plan.json" - writePlanExternalRepresentation - distDirLayout - elaboratedPlan - elaboratedShared - - - -- Improve the elaborated install plan. The elaborated plan consists - -- mostly of source packages (with full nix-style hashed ids). Where - -- corresponding installed packages already exist in the store, replace - -- them in the plan. - -- - -- Note that we do monitor the store's package db here, so we will redo - -- this improvement phase when the db changes -- including as a result of - -- executing a plan and installing things. - -- - phaseImprovePlan :: ElaboratedInstallPlan - -> ElaboratedSharedConfig - -> Rebuild ElaboratedInstallPlan - phaseImprovePlan elaboratedPlan elaboratedShared = do - - liftIO $ debug verbosity "Improving the install plan..." - storePkgIdSet <- getStoreEntries cabalStoreDirLayout compid - let improvedPlan = improveInstallPlanWithInstalledPackages - storePkgIdSet - elaboratedPlan - liftIO $ debugNoWrap verbosity (InstallPlan.showInstallPlan improvedPlan) - -- TODO: [nice to have] having checked which packages from the store - -- we're using, it may be sensible to sanity check those packages - -- by loading up the compiler package db and checking everything - -- matches up as expected, e.g. no dangling deps, files deleted. - return improvedPlan - where - compid = compilerId (pkgConfigCompiler elaboratedShared) - - -programsMonitorFiles :: ProgramDb -> [MonitorFilePath] -programsMonitorFiles progdb = - [ monitor - | prog <- configuredPrograms progdb - , monitor <- monitorFileSearchPath (programMonitorFiles prog) - (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 - -> PackageDBStack - -> Rebuild InstalledPackageIndex -getInstalledPackages verbosity compiler progdb platform packagedbs = do - monitorFiles . map monitorFileOrDirectory - =<< liftIO (IndexUtils.getInstalledPackagesMonitorFiles - verbosity compiler - packagedbs progdb platform) - liftIO $ IndexUtils.getInstalledPackages - verbosity compiler - packagedbs progdb - -{- ---TODO: [nice to have] use this but for sanity / consistency checking -getPackageDBContents :: Verbosity - -> Compiler -> ProgramDb -> Platform - -> PackageDB - -> Rebuild InstalledPackageIndex -getPackageDBContents verbosity compiler progdb platform packagedb = do - monitorFiles . map monitorFileOrDirectory - =<< liftIO (IndexUtils.getInstalledPackagesMonitorFiles - verbosity compiler - [packagedb] progdb platform) - liftIO $ do - createPackageDBIfMissing verbosity compiler progdb packagedb - Cabal.getPackageDBContents verbosity compiler - packagedb progdb --} - -getSourcePackages - :: Verbosity - -> (forall a. (RepoContext -> IO a) -> IO a) - -> Maybe IndexUtils.TotalIndexState - -> Maybe IndexUtils.ActiveRepos - -> Rebuild (SourcePackageDb, IndexUtils.TotalIndexState, IndexUtils.ActiveRepos) -getSourcePackages verbosity withRepoCtx idxState activeRepos = do - (sourcePkgDbWithTIS, repos) <- - liftIO $ - withRepoCtx $ \repoctx -> do - sourcePkgDbWithTIS <- IndexUtils.getSourcePackagesAtIndexState verbosity repoctx idxState activeRepos - return (sourcePkgDbWithTIS, repoContextRepos repoctx) - - traverse_ needIfExists - . IndexUtils.getSourcePackagesMonitorFiles - $ repos - return sourcePkgDbWithTIS - - -getPkgConfigDb :: Verbosity -> ProgramDb -> Rebuild PkgConfigDb -getPkgConfigDb verbosity progdb = do - dirs <- liftIO $ getPkgConfigDbDirs verbosity progdb - -- Just monitor the dirs so we'll notice new .pc files. - -- Alternatively we could monitor all the .pc files too. - traverse_ monitorDirectoryStatus dirs - liftIO $ readPkgConfigDb verbosity progdb - - --- | Select the config values to monitor for changes package source hashes. -packageLocationsSignature :: SolverInstallPlan - -> [(PackageId, PackageLocation (Maybe FilePath))] -packageLocationsSignature solverPlan = - [ (packageId pkg, srcpkgSource pkg) - | SolverInstallPlan.Configured (SolverPackage { solverPkgSource = pkg}) - <- SolverInstallPlan.toList solverPlan - ] - - --- | Get the 'HashValue' for all the source packages where we use hashes, --- and download any packages required to do so. --- --- Note that we don't get hashes for local unpacked packages. --- -getPackageSourceHashes :: Verbosity - -> (forall a. (RepoContext -> IO a) -> IO a) - -> SolverInstallPlan - -> Rebuild (Map PackageId PackageSourceHash) -getPackageSourceHashes verbosity withRepoCtx solverPlan = do - - -- Determine if and where to get the package's source hash from. - -- - let allPkgLocations :: [(PackageId, PackageLocation (Maybe FilePath))] - allPkgLocations = - [ (packageId pkg, srcpkgSource pkg) - | SolverInstallPlan.Configured (SolverPackage { solverPkgSource = pkg}) - <- SolverInstallPlan.toList solverPlan ] - - -- Tarballs that were local in the first place. - -- We'll hash these tarball files directly. - localTarballPkgs :: [(PackageId, FilePath)] - localTarballPkgs = - [ (pkgid, tarball) - | (pkgid, LocalTarballPackage tarball) <- allPkgLocations ] - - -- Tarballs from remote URLs. We must have downloaded these already - -- (since we extracted the .cabal file earlier) - remoteTarballPkgs = - [ (pkgid, tarball) - | (pkgid, RemoteTarballPackage _ (Just tarball)) <- allPkgLocations ] - - -- tarballs from source-repository-package stanzas - sourceRepoTarballPkgs = - [ (pkgid, tarball) - | (pkgid, RemoteSourceRepoPackage _ (Just tarball)) <- allPkgLocations ] - - -- Tarballs from repositories, either where the repository provides - -- hashes as part of the repo metadata, or where we will have to - -- download and hash the tarball. - repoTarballPkgsWithMetadata :: [(PackageId, Repo)] - repoTarballPkgsWithoutMetadata :: [(PackageId, Repo)] - (repoTarballPkgsWithMetadata, - repoTarballPkgsWithoutMetadata) = - partitionEithers - [ case repo of - RepoSecure{} -> Left (pkgid, repo) - _ -> Right (pkgid, repo) - | (pkgid, RepoTarballPackage repo _ _) <- allPkgLocations ] - - -- For tarballs from repos that do not have hashes available we now have - -- to check if the packages were downloaded already. - -- - (repoTarballPkgsToDownload, - repoTarballPkgsDownloaded) - <- fmap partitionEithers $ - liftIO $ sequence - [ do mtarball <- checkRepoTarballFetched repo pkgid - case mtarball of - Nothing -> return (Left (pkgid, repo)) - Just tarball -> return (Right (pkgid, tarball)) - | (pkgid, repo) <- repoTarballPkgsWithoutMetadata ] - - (hashesFromRepoMetadata, - repoTarballPkgsNewlyDownloaded) <- - -- Avoid having to initialise the repository (ie 'withRepoCtx') if we - -- don't have to. (The main cost is configuring the http client.) - if null repoTarballPkgsToDownload && null repoTarballPkgsWithMetadata - then return (Map.empty, []) - else liftIO $ withRepoCtx $ \repoctx -> do - - -- For tarballs from repos that do have hashes available as part of the - -- repo metadata we now load up the index for each repo and retrieve - -- the hashes for the packages - -- - hashesFromRepoMetadata <- - Sec.uncheckClientErrors $ --TODO: [code cleanup] wrap in our own exceptions - fmap (Map.fromList . concat) $ - sequence - -- Reading the repo index is expensive so we group the packages by repo - [ repoContextWithSecureRepo repoctx repo $ \secureRepo -> - Sec.withIndex secureRepo $ \repoIndex -> - sequence - [ do hash <- Sec.trusted <$> -- strip off Trusted tag - Sec.indexLookupHash repoIndex pkgid - -- Note that hackage-security currently uses SHA256 - -- but this API could in principle give us some other - -- choice in future. - return (pkgid, hashFromTUF hash) - | pkgid <- pkgids ] - | (repo, pkgids) <- - map (\grp@((_,repo):|_) -> (repo, map fst (NE.toList grp))) - . NE.groupBy ((==) `on` (remoteRepoName . repoRemote . snd)) - . sortBy (compare `on` (remoteRepoName . repoRemote . snd)) - $ repoTarballPkgsWithMetadata - ] - - -- For tarballs from repos that do not have hashes available, download - -- the ones we previously determined we need. - -- - repoTarballPkgsNewlyDownloaded <- - sequence - [ do tarball <- fetchRepoTarball verbosity repoctx repo pkgid - return (pkgid, tarball) - | (pkgid, repo) <- repoTarballPkgsToDownload ] - - return (hashesFromRepoMetadata, - repoTarballPkgsNewlyDownloaded) - - -- Hash tarball files for packages where we have to do that. This includes - -- tarballs that were local in the first place, plus tarballs from repos, - -- either previously cached or freshly downloaded. - -- - let allTarballFilePkgs :: [(PackageId, FilePath)] - allTarballFilePkgs = localTarballPkgs - ++ remoteTarballPkgs - ++ sourceRepoTarballPkgs - ++ repoTarballPkgsDownloaded - ++ repoTarballPkgsNewlyDownloaded - hashesFromTarballFiles <- liftIO $ - fmap Map.fromList $ - sequence - [ do srchash <- readFileHashValue tarball - return (pkgid, srchash) - | (pkgid, tarball) <- allTarballFilePkgs - ] - monitorFiles [ monitorFile tarball - | (_pkgid, tarball) <- allTarballFilePkgs ] - - -- Return the combination - return $! hashesFromRepoMetadata - <> hashesFromTarballFiles - - --- ------------------------------------------------------------ --- * Installation planning --- ------------------------------------------------------------ - -planPackages :: Verbosity - -> Compiler - -> Platform - -> Solver -> SolverSettings - -> InstalledPackageIndex - -> SourcePackageDb - -> PkgConfigDb - -> [PackageSpecifier UnresolvedSourcePackage] - -> Map PackageName (Map OptionalStanza Bool) - -> Progress String String SolverInstallPlan -planPackages verbosity comp platform solver SolverSettings{..} - installedPkgIndex sourcePkgDb pkgConfigDB - localPackages pkgStanzasEnable = - - resolveDependencies - platform (compilerInfo comp) - pkgConfigDB solver - resolverParams - - where - - --TODO: [nice to have] disable multiple instances restriction in - -- the solver, but then make sure we can cope with that in the - -- output. - resolverParams = - - setMaxBackjumps solverSettingMaxBackjumps - - . setIndependentGoals solverSettingIndependentGoals - - . setReorderGoals solverSettingReorderGoals - - . setCountConflicts solverSettingCountConflicts - - . setFineGrainedConflicts solverSettingFineGrainedConflicts - - . setMinimizeConflictSet solverSettingMinimizeConflictSet - - --TODO: [required eventually] should only be configurable for - --custom installs - -- . setAvoidReinstalls solverSettingAvoidReinstalls - - --TODO: [required eventually] should only be configurable for - --custom installs - -- . setShadowPkgs solverSettingShadowPkgs - - . setStrongFlags solverSettingStrongFlags - - . setAllowBootLibInstalls solverSettingAllowBootLibInstalls - - . setOnlyConstrained solverSettingOnlyConstrained - - . setSolverVerbosity verbosity - - --TODO: [required eventually] decide if we need to prefer - -- installed for global packages, or prefer latest even for - -- global packages. Perhaps should be configurable but with a - -- different name than "upgrade-dependencies". - . setPreferenceDefault PreferLatestForSelected - {-(if solverSettingUpgradeDeps - then PreferAllLatest - else PreferLatestForSelected)-} - - . removeLowerBounds solverSettingAllowOlder - . removeUpperBounds solverSettingAllowNewer - - . addDefaultSetupDependencies (defaultSetupDeps comp platform - . PD.packageDescription - . srcpkgDescription) - - . addSetupCabalMinVersionConstraint setupMinCabalVersionConstraint - . addSetupCabalMaxVersionConstraint setupMaxCabalVersionConstraint - - . addPreferences - -- preferences from the config file or command line - [ PackageVersionPreference name ver - | PackageVersionConstraint name ver <- solverSettingPreferences ] - - . addConstraints - -- version constraints from the config file or command line - [ LabeledPackageConstraint (userToPackageConstraint pc) src - | (pc, src) <- solverSettingConstraints ] - - . addPreferences - -- enable stanza preference where the user did not specify - [ PackageStanzasPreference pkgname stanzas - | pkg <- localPackages - , let pkgname = pkgSpecifierTarget pkg - stanzaM = Map.findWithDefault Map.empty pkgname pkgStanzasEnable - stanzas = [ stanza | stanza <- [minBound..maxBound] - , Map.lookup stanza stanzaM == Nothing ] - , not (null stanzas) - ] - - . addConstraints - -- enable stanza constraints where the user asked to enable - [ LabeledPackageConstraint - (PackageConstraint (scopeToplevel pkgname) - (PackagePropertyStanzas stanzas)) - ConstraintSourceConfigFlagOrTarget - | pkg <- localPackages - , let pkgname = pkgSpecifierTarget pkg - stanzaM = Map.findWithDefault Map.empty pkgname pkgStanzasEnable - stanzas = [ stanza | stanza <- [minBound..maxBound] - , Map.lookup stanza stanzaM == Just True ] - , not (null stanzas) - ] - - . addConstraints - --TODO: [nice to have] should have checked at some point that the - -- package in question actually has these flags. - [ LabeledPackageConstraint - (PackageConstraint (scopeToplevel pkgname) - (PackagePropertyFlags flags)) - ConstraintSourceConfigFlagOrTarget - | (pkgname, flags) <- Map.toList solverSettingFlagAssignments ] - - . addConstraints - --TODO: [nice to have] we have user-supplied flags for unspecified - -- local packages (as well as specific per-package flags). For the - -- former we just apply all these flags to all local targets which - -- is silly. We should check if the flags are appropriate. - [ LabeledPackageConstraint - (PackageConstraint (scopeToplevel pkgname) - (PackagePropertyFlags flags)) - ConstraintSourceConfigFlagOrTarget - | let flags = solverSettingFlagAssignment - , not (PD.nullFlagAssignment flags) - , pkg <- localPackages - , let pkgname = pkgSpecifierTarget pkg ] - - $ stdResolverParams - - stdResolverParams = - -- Note: we don't use the standardInstallPolicy here, since that uses - -- its own addDefaultSetupDependencies that is not appropriate for us. - basicInstallPolicy - installedPkgIndex sourcePkgDb - 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 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 [8,12] = 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 ------------------------------------------------------------------------------- - --- This phase goes from the InstallPlan we get from the solver and has to --- make an elaborated install plan. --- --- We go in two steps: --- --- 1. elaborate all the source packages that the solver has chosen. --- 2. swap source packages for pre-existing installed packages wherever --- possible. --- --- We do it in this order, elaborating and then replacing, because the easiest --- way to calculate the installed package ids used for the replacement step is --- from the elaborated configuration for each package. - - - - ------------------------------------------------------------------------------- --- * Install plan elaboration ------------------------------------------------------------------------------- - --- Note [SolverId to ConfiguredId] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Dependency solving is a per package affair, so after we're done, we --- end up with 'SolverInstallPlan' that records in 'solverPkgLibDeps' --- and 'solverPkgExeDeps' what packages provide the libraries and executables --- needed by each component of the package (phew!) For example, if I have --- --- library --- build-depends: lib --- build-tool-depends: pkg:exe1 --- build-tools: alex --- --- After dependency solving, I find out that this library component has --- library dependencies on lib-0.2, and executable dependencies on pkg-0.1 --- and alex-0.3 (other components of the package may have different --- dependencies). Note that I've "lost" the knowledge that I depend --- *specifically* on the exe1 executable from pkg. --- --- So, we have a this graph of packages, and we need to transform it into --- a graph of components which we are actually going to build. In particular: --- --- NODE changes from PACKAGE (SolverPackage) to COMPONENTS (ElaboratedConfiguredPackage) --- EDGE changes from PACKAGE DEP (SolverId) to COMPONENT DEPS (ConfiguredId) --- --- In both cases, what was previously a single node/edge may turn into multiple --- nodes/edges. Multiple components, because there may be multiple components --- in a package; multiple component deps, because we may depend upon multiple --- executables from the same package (and maybe, some day, multiple libraries --- from the same package.) --- --- Let's talk about how to do this transformation. Naively, we might consider --- just processing each package, converting it into (zero or) one or more --- components. But we also have to update the edges; this leads to --- two complications: --- --- 1. We don't know what the ConfiguredId of a component is until --- we've configured it, but we cannot configure a component unless --- we know the ConfiguredId of all its dependencies. Thus, we must --- process the 'SolverInstallPlan' in topological order. --- --- 2. When we process a package, we know the SolverIds of its --- dependencies, but we have to do some work to turn these into --- ConfiguredIds. For example, in the case of build-tool-depends, the --- SolverId isn't enough to uniquely determine the ConfiguredId we should --- elaborate to: we have to look at the executable name attached to --- the package name in the package description to figure it out. --- At the same time, we NEED to use the SolverId, because there might --- be multiple versions of the same package in the build plan --- (due to setup dependencies); we can't just look up the package name --- from the package description. --- --- We can adopt the following strategy: --- --- * When a package is transformed into components, record --- a mapping from SolverId to ALL of the components --- which were elaborated. --- --- * When we look up an edge, we use our knowledge of the --- component name to *filter* the list of components into --- the ones we actually wanted to refer to. --- --- By the way, we can tell that SolverInstallPlan is not the "right" type --- because a SolverId cannot adequately represent all possible dependency --- solver states: we may need to record foo-0.1 multiple times in --- the solver install plan with different dependencies. This imprecision in the --- type currently doesn't cause any problems because the dependency solver --- continues to enforce the single instance restriction regardless of compiler --- version. The right way to solve this is to come up with something very much --- like a 'ConfiguredId', in that it incorporates the version choices of its --- dependencies, but less fine grained. - - --- | Produce an elaborated install plan using the policy for local builds with --- a nix-style shared store. --- --- In theory should be able to make an elaborated install plan with a policy --- matching that of the classic @cabal install --user@ or @--global@ --- -elaborateInstallPlan - :: Verbosity -> Platform -> Compiler -> ProgramDb -> PkgConfigDb - -> DistDirLayout - -> StoreDirLayout - -> SolverInstallPlan - -> [PackageSpecifier (SourcePackage (PackageLocation loc))] - -> Map PackageId PackageSourceHash - -> InstallDirs.InstallDirTemplates - -> ProjectConfigShared - -> PackageConfig - -> PackageConfig - -> Map PackageName PackageConfig - -> LogProgress (ElaboratedInstallPlan, ElaboratedSharedConfig) -elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB - distDirLayout@DistDirLayout{..} - storeDirLayout@StoreDirLayout{storePackageDBStack} - solverPlan localPackages - sourcePackageHashes - defaultInstallDirs - sharedPackageConfig - allPackagesConfig - localPackagesConfig - perPackageConfig = do - x <- elaboratedInstallPlan - return (x, elaboratedSharedConfig) - where - elaboratedSharedConfig = - ElaboratedSharedConfig { - pkgConfigPlatform = platform, - pkgConfigCompiler = compiler, - pkgConfigCompilerProgs = compilerprogdb, - pkgConfigReplOptions = [] - } - - preexistingInstantiatedPkgs = - Map.fromList (mapMaybe f (SolverInstallPlan.toList solverPlan)) - where - f (SolverInstallPlan.PreExisting inst) - | let ipkg = instSolverPkgIPI inst - , not (IPI.indefinite ipkg) - = Just (IPI.installedUnitId ipkg, - (FullUnitId (IPI.installedComponentId ipkg) - (Map.fromList (IPI.instantiatedWith ipkg)))) - f _ = Nothing - - elaboratedInstallPlan = - flip InstallPlan.fromSolverInstallPlanWithProgress solverPlan $ \mapDep planpkg -> - case planpkg of - SolverInstallPlan.PreExisting pkg -> - return [InstallPlan.PreExisting (instSolverPkgIPI pkg)] - - SolverInstallPlan.Configured pkg -> - let inplace_doc | shouldBuildInplaceOnly pkg = text "inplace" - | otherwise = Disp.empty - in addProgressCtx (text "In the" <+> inplace_doc <+> text "package" <+> - quotes (pretty (packageId pkg))) $ - map InstallPlan.Configured <$> elaborateSolverToComponents mapDep pkg - - -- NB: We don't INSTANTIATE packages at this point. That's - -- a post-pass. This makes it simpler to compute dependencies. - elaborateSolverToComponents - :: (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 not_per_component_reasons = why_not_per_component src_comps - if null not_per_component_reasons - then return comps - else do checkPerPackageOk comps not_per_component_reasons - return [elaborateSolverToPackage spkg g $ - comps ++ maybeToList setupComponent] - Left cns -> - dieProgress $ - hang (text "Dependency cycle between the following components:") 4 - (vcat (map (text . componentNameStanza) cns)) - where - -- 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 ++ cuz_coverage - where - cuz reason = [text reason] - -- We have to disable per-component for now with - -- Configure-type scripts in order to prevent parallel - -- invocation of the same `./configure` script. - -- See https://github.com/haskell/cabal/issues/4548 - -- - -- Moreoever, at this point in time, only non-Custom setup scripts - -- are supported. 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 PD.buildType (elabPkgDescription elab0) of - PD.Configure -> cuz "build-type is Configure" - PD.Custom -> cuz "build-type is Custom" - _ -> [] - -- 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 = cuz "cabal-version is less than 1.8" - -- 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 = cuz "there are no buildable components" - -- For ease of testing, we let per-component builds be toggled - -- at the top level - cuz_flag - | fromFlagOrDefault True (projectConfigPerComponent sharedPackageConfig) - = [] - | otherwise = cuz "you passed --disable-per-component" - -- Enabling program coverage introduces odd runtime dependencies - -- between components. - cuz_coverage - | fromFlagOrDefault False (packageConfigCoverage localPackagesConfig) - = cuz "program coverage is enabled" - | otherwise = [] - - -- | 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 reasons) - -- TODO: Maybe exclude Backpack too - - elab0 = 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 - | PD.buildType (elabPkgDescription elab0) == PD.Custom - = 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 - = map configuredId dep_pkgs - compLinkedLibDependencies = notImpl "compLinkedLibDependencies" - compOrderLibDependencies = notImpl "compOrderLibDependencies" - -- Not supported: - compExeDependencies = [] - compExeDependencyPaths = [] - 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), - ElaboratedConfiguredPackage) - 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 - - - -- 2. Read out the dependencies from the ConfiguredComponent cc0 - let compLibDependencies = - -- Nub because includes can show up multiple times - ordNub (map (annotatedIdToConfiguredId . ci_ann_id) - (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 - } - cid = case elabBuildStyle elab0 of - BuildInplaceOnly -> - mkComponentId $ - prettyShow pkgid ++ "-inplace" ++ - (case Cabal.componentNameString cname of - Nothing -> "" - Just s -> "-" ++ prettyShow s) - BuildAndInstall -> - hashedInstalledPackageId - (packageHashInputs - 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 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 - } - - -- 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 ] - 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)) - (pkgConfigDbPkgVersion pkgConfigDB pn)) - | PkgconfigDependency pn _ <- PD.pkgconfigDepends - (Cabal.componentBuildInfo comp) ] - - 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 - -- returns at most one result. - elaborateLibSolverId :: (SolverId -> [ElaboratedPlanPackage]) - -> SolverId -> [ElaboratedPlanPackage] - elaborateLibSolverId mapDep = filter (matchPlanPkg (== (CLibName LMainLibName))) . mapDep - - -- | Given an 'ElaboratedPlanPackage', return the paths to where the - -- executables that this package represents would be installed. - -- The only case where multiple paths can be returned is the inplace - -- monolithic package one, since there can be multiple exes and each one - -- has its own directory. - planPackageExePaths :: ElaboratedPlanPackage -> [FilePath] - planPackageExePaths = - -- Pre-existing executables are assumed to be in PATH - -- already. In fact, this should be impossible. - InstallPlan.foldPlanPackage (const []) $ \elab -> - let - executables :: [FilePath] - executables = - case elabPkgOrComp elab of - -- Monolithic mode: all exes of the package - ElabPackage _ -> unUnqualComponentName . PD.exeName - <$> PD.executables (elabPkgDescription elab) - -- Per-component mode: just the selected exe - ElabComponent comp -> - case fmap Cabal.componentNameString - (compComponentName comp) of - Just (Just n) -> [prettyShow n] - _ -> [""] - in - binDirectoryFor - distDirLayout - elaboratedSharedConfig - elab - <$> executables - - elaborateSolverToPackage :: SolverPackage UnresolvedPkgLoc - -> ComponentsGraph - -> [ElaboratedConfiguredPackage] - -> ElaboratedConfiguredPackage - elaborateSolverToPackage - pkg@(SolverPackage (SourcePackage pkgid _gpd _srcloc _descOverride) - _flags _stanzas _deps0 _exe_deps0) - compGraph comps = - -- Knot tying: the final elab includes the - -- pkgInstalledId, which is calculated by hashing many - -- of the other fields of the elaboratedPackage. - elab - where - elab0@ElaboratedConfiguredPackage{..} = elaborateSolverToCommon pkg - elab1 = elab0 { - elabUnitId = newSimpleUnitId pkgInstalledId, - elabComponentId = pkgInstalledId, - elabLinkedInstantiatedWith = Map.empty, - elabPkgOrComp = ElabPackage $ ElaboratedPackage {..}, - elabModuleShape = modShape - } - elab = elab1 { - elabInstallDirs = - computeInstallDirs storeDirLayout - defaultInstallDirs - elaboratedSharedConfig - elab1 - } - - modShape = case find (matchElabPkg (== (CLibName LMainLibName))) comps of - Nothing -> emptyModuleShape - Just e -> Ty.elabModuleShape e - - pkgInstalledId - | shouldBuildInplaceOnly pkg - = mkComponentId (prettyShow pkgid ++ "-inplace") - - | otherwise - = assert (isJust elabPkgSourceHash) $ - hashedInstalledPackageId - (packageHashInputs - elaboratedSharedConfig - elab) -- recursive use of elab - - | otherwise - = error $ "elaborateInstallPlan: non-inplace package " - ++ " is missing a source hash: " ++ prettyShow pkgid - - -- Need to filter out internal dependencies, because they don't - -- correspond to anything real anymore. - isExt confid = confSrcId confid /= pkgid - filterExt = filter isExt - 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 - - pkgDependsOnSelfLib - = CD.fromList [ (CD.componentNameToComponent cn, [()]) - | Graph.N _ cn _ <- fromMaybe [] mb_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 - - buildComponentDeps f - = CD.fromList [ (compSolverName comp, f comp) - | 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 = Map.keysSet (Map.filter (id :: Bool -> Bool) elabStanzasRequested) - - elaborateSolverToCommon :: SolverPackage UnresolvedPkgLoc - -> ElaboratedConfiguredPackage - elaborateSolverToCommon - pkg@(SolverPackage (SourcePackage pkgid gdesc srcloc descOverride) - flags stanzas deps0 _exe_deps0) = - elaboratedPackage - where - elaboratedPackage = ElaboratedConfiguredPackage {..} - - -- 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 True) - platform (compilerInfo compiler) - [] gdesc of - Right (desc, _) -> desc - Left _ -> error "Failed to finalizePD in elaborateSolverToCommon" - elabFlagAssignment = flags - elabFlagDefaults = PD.mkFlagAssignment - [ (Cabal.flagName flag, Cabal.flagDefault flag) - | flag <- PD.genPackageFlags gdesc ] - - elabEnabledSpec = enableStanzas stanzas - elabStanzasAvailable = Set.fromList stanzas - elabStanzasRequested = - -- NB: even if a package stanza is requested, if the package - -- doesn't actually have any of that stanza we omit it from - -- the request, to ensure that we don't decide that this - -- package needs to be rebuilt. (It needs to be done here, - -- because the ElaboratedConfiguredPackage is where we test - -- whether or not there have been changes.) - Map.fromList $ [ (TestStanzas, v) | v <- maybeToList tests - , _ <- PD.testSuites elabPkgDescription ] - ++ [ (BenchStanzas, v) | v <- maybeToList benchmarks - , _ <- PD.benchmarks elabPkgDescription ] - where - tests, benchmarks :: Maybe Bool - tests = perPkgOptionMaybe pkgid packageConfigTests - benchmarks = perPkgOptionMaybe pkgid packageConfigBenchmarks - - -- This is a placeholder which will get updated by 'pruneInstallPlanPass1' - -- and 'pruneInstallPlanPass2'. We can't populate it here - -- because whether or not tests/benchmarks should be enabled - -- is heuristically calculated based on whether or not the - -- dependencies of the test suite have already been installed, - -- but this function doesn't know what is installed (since - -- we haven't improved the plan yet), so we do it in another pass. - -- Check the comments of those functions for more details. - elabConfigureTargets = [] - elabBuildTargets = [] - elabTestTargets = [] - elabBenchTargets = [] - elabReplTarget = Nothing - elabHaddockTargets = [] - - elabBuildHaddocks = - perPkgOptionFlag pkgid False packageConfigDocumentation - - elabPkgSourceLocation = srcloc - elabPkgSourceHash = Map.lookup pkgid sourcePackageHashes - elabLocalToProject = isLocalToProject pkg - elabBuildStyle = if shouldBuildInplaceOnly pkg - then BuildInplaceOnly else BuildAndInstall - elabBuildPackageDBStack = buildAndRegisterDbs - elabRegisterPackageDBStack = buildAndRegisterDbs - - elabSetupScriptStyle = packageSetupScriptStyle elabPkgDescription - elabSetupScriptCliVersion = - packageSetupScriptSpecVersion - elabSetupScriptStyle elabPkgDescription libDepGraph deps0 - elabSetupPackageDBStack = buildAndRegisterDbs - - buildAndRegisterDbs - | shouldBuildInplaceOnly pkg = inplacePackageDbs - | otherwise = storePackageDbs - - elabPkgDescriptionOverride = descOverride - - elabVanillaLib = perPkgOptionFlag pkgid True packageConfigVanillaLib --TODO: [required feature]: also needs to be handled recursively - elabSharedLib = pkgid `Set.member` pkgsUseSharedLibrary - elabStaticLib = perPkgOptionFlag pkgid False packageConfigStaticLib - elabDynExe = perPkgOptionFlag pkgid False packageConfigDynExe - elabFullyStaticExe = perPkgOptionFlag pkgid False packageConfigFullyStaticExe - elabGHCiLib = perPkgOptionFlag pkgid False packageConfigGHCiLib --TODO: [required feature] needs to default to enabled on windows still - - elabProfExe = perPkgOptionFlag pkgid False packageConfigProf - elabProfLib = pkgid `Set.member` pkgsUseProfilingLibrary - - (elabProfExeDetail, - elabProfLibDetail) = perPkgOptionLibExeFlag pkgid ProfDetailDefault - packageConfigProfDetail - packageConfigProfLibDetail - elabCoverage = perPkgOptionFlag pkgid False packageConfigCoverage - - elabOptimization = perPkgOptionFlag pkgid NormalOptimisation packageConfigOptimization - elabSplitObjs = perPkgOptionFlag pkgid False packageConfigSplitObjs - elabSplitSections = perPkgOptionFlag pkgid False packageConfigSplitSections - elabStripLibs = perPkgOptionFlag pkgid False packageConfigStripLibs - elabStripExes = perPkgOptionFlag pkgid False packageConfigStripExes - elabDebugInfo = perPkgOptionFlag pkgid NoDebugInfo packageConfigDebugInfo - - -- Combine the configured compiler prog settings with the user-supplied - -- config. For the compiler progs any user-supplied config was taken - -- into account earlier when configuring the compiler so its ok that - -- our configured settings for the compiler override the user-supplied - -- config here. - elabProgramPaths = Map.fromList - [ (programId prog, programPath prog) - | prog <- configuredPrograms compilerprogdb ] - <> perPkgOptionMapLast pkgid packageConfigProgramPaths - elabProgramArgs = Map.fromList - [ (programId prog, args) - | prog <- configuredPrograms compilerprogdb - , let args = programOverrideArgs prog - , not (null args) - ] - <> perPkgOptionMapMappend pkgid packageConfigProgramArgs - elabProgramPathExtra = perPkgOptionNubList pkgid packageConfigProgramPathExtra - elabConfigureScriptArgs = perPkgOptionList pkgid packageConfigConfigureArgs - elabExtraLibDirs = perPkgOptionList pkgid packageConfigExtraLibDirs - 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 - - 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 - - perPkgOptionFlag :: PackageId -> a -> (PackageConfig -> Flag a) -> a - perPkgOptionMaybe :: PackageId -> (PackageConfig -> Flag a) -> Maybe a - perPkgOptionList :: PackageId -> (PackageConfig -> [a]) -> [a] - - perPkgOptionFlag pkgid def f = fromFlagOrDefault def (lookupPerPkgOption pkgid f) - perPkgOptionMaybe pkgid f = flagToMaybe (lookupPerPkgOption pkgid f) - perPkgOptionList pkgid f = lookupPerPkgOption pkgid f - perPkgOptionNubList pkgid f = fromNubList (lookupPerPkgOption pkgid f) - perPkgOptionMapLast pkgid f = getMapLast (lookupPerPkgOption pkgid f) - perPkgOptionMapMappend pkgid f = getMapMappend (lookupPerPkgOption pkgid f) - - perPkgOptionLibExeFlag pkgid def fboth flib = (exe, lib) - where - exe = fromFlagOrDefault def bothflag - lib = fromFlagOrDefault def (bothflag <> libflag) - - bothflag = lookupPerPkgOption pkgid fboth - libflag = lookupPerPkgOption pkgid flib - - lookupPerPkgOption :: (Package pkg, Monoid m) - => pkg -> (PackageConfig -> m) -> m - lookupPerPkgOption pkg f = - -- This is where we merge the options from the project config that - -- apply to all packages, all project local packages, and to specific - -- named packages - global `mappend` local `mappend` perpkg - where - global = f allPackagesConfig - local | isLocalToProject pkg - = f localPackagesConfig - | otherwise - = mempty - perpkg = maybe mempty f (Map.lookup (packageName pkg) perPackageConfig) - - inplacePackageDbs = storePackageDbs - ++ [ distPackageDB (compilerId compiler) ] - - storePackageDbs = storePackageDBStack (compilerId compiler) - - -- 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 - -- source dir packages will also get unpacked locally. - shouldBuildInplaceOnly :: SolverPackage loc -> Bool - shouldBuildInplaceOnly pkg = Set.member (packageId pkg) - pkgsToBuildInplaceOnly - - pkgsToBuildInplaceOnly :: Set PackageId - pkgsToBuildInplaceOnly = - Set.fromList - $ map packageId - $ SolverInstallPlan.reverseDependencyClosure - solverPlan - (map PlannedId (Set.toList pkgsLocalToProject)) - - isLocalToProject :: Package pkg => pkg -> Bool - isLocalToProject pkg = Set.member (packageId pkg) - pkgsLocalToProject - - pkgsLocalToProject :: Set PackageId - pkgsLocalToProject = - Set.fromList (catMaybes (map shouldBeLocal localPackages)) - --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 - where - needsSharedLib pkg = - fromMaybe compilerShouldUseSharedLibByDefault - (liftM2 (||) pkgSharedLib pkgDynExe) - where - pkgid = packageId pkg - pkgSharedLib = perPkgOptionMaybe pkgid packageConfigSharedLib - pkgDynExe = perPkgOptionMaybe pkgid packageConfigDynExe - - --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.isDynamic compiler - GHCJS -> GHCJS.isDynamic compiler - _ -> False - - pkgsUseProfilingLibrary :: Set PackageId - pkgsUseProfilingLibrary = - packagesWithLibDepsDownwardClosedProperty needsProfilingLib - where - needsProfilingLib pkg = - fromFlagOrDefault False (profBothFlag <> profLibFlag) - where - pkgid = packageId pkg - profBothFlag = lookupPerPkgOption pkgid packageConfigProf - profLibFlag = lookupPerPkgOption pkgid packageConfigProfLib - --TODO: [code cleanup] unused: the old deprecated packageConfigProfExe - - libDepGraph = Graph.fromDistinctList $ - map NonSetupLibDepSolverPlanPackage - (SolverInstallPlan.toList solverPlan) - - packagesWithLibDepsDownwardClosedProperty property = - Set.fromList - . map packageId - . fromMaybe [] - $ Graph.closure - libDepGraph - [ Graph.nodeKey pkg - | pkg <- SolverInstallPlan.toList solverPlan - , property pkg ] -- just the packages that satisfy the property - --TODO: [nice to have] this does not check the config consistency, - -- e.g. a package explicitly turning off profiling, but something - -- depending on it that needs profiling. This really needs a separate - -- package config validation/resolution pass. - - --TODO: [nice to have] config consistency checking: - -- + profiling libs & exes, exe needs lib, recursive - -- + shared libs & exes, exe needs lib, recursive - -- + vanilla libs & exes, exe needs lib, recursive - -- + ghci or shared lib needed by TH, recursive, ghc version dependent - --- 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 - --- | Given a 'ElaboratedPlanPackage', report if it matches a 'ComponentName'. -matchPlanPkg :: (ComponentName -> Bool) -> ElaboratedPlanPackage -> Bool -matchPlanPkg p = InstallPlan.foldPlanPackage (p . ipiComponentName) (matchElabPkg p) - --- | Get the appropriate 'ComponentName' which identifies an installed --- component. -ipiComponentName :: IPI.InstalledPackageInfo -> ComponentName -ipiComponentName = CLibName . IPI.sourceLibName - --- | Given a 'ElaboratedConfiguredPackage', report if it matches a --- 'ComponentName'. -matchElabPkg :: (ComponentName -> Bool) -> ElaboratedConfiguredPackage -> Bool -matchElabPkg p elab = - case elabPkgOrComp elab of - ElabComponent comp -> maybe False p (compComponentName comp) - ElabPackage _ -> - -- So, what should we do here? One possibility is to - -- unconditionally return 'True', because whatever it is - -- that we're looking for, it better be in this package. - -- But this is a bit dodgy if the package doesn't actually - -- have, e.g., a library. Fortunately, it's not possible - -- for the build of the library/executables to be toggled - -- by 'pkgStanzasEnabled', so the only thing we have to - -- test is if the component in question is *buildable.* - any (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. -mkCCMapping :: ElaboratedPlanPackage - -> (PackageName, Map ComponentName (AnnotatedId ComponentId)) -mkCCMapping = - InstallPlan.foldPlanPackage - (\ipkg -> (packageName ipkg, - Map.singleton (ipiComponentName ipkg) - -- TODO: libify - (AnnotatedId { - ann_id = IPI.installedComponentId ipkg, - ann_pid = packageId ipkg, - ann_cname = IPI.sourceComponentName ipkg - }))) - $ \elab -> - let mk_aid cn = AnnotatedId { - ann_id = elabComponentId elab, - ann_pid = packageId elab, - ann_cname = cn - } - in (packageName elab, - case elabPkgOrComp elab of - ElabComponent comp -> - case compComponentName comp of - 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)) - (Cabal.pkgBuildableComponents (elabPkgDescription elab))) - --- | Given an 'ElaboratedPlanPackage', generate the mapping from 'ComponentId' --- to the shape of this package, as per mix-in linking. -mkShapeMapping :: ElaboratedPlanPackage - -> (ComponentId, (OpenUnitId, ModuleShape)) -mkShapeMapping dpkg = - (getComponentId dpkg, (indef_uid, shape)) - where - (dcid, shape) = - InstallPlan.foldPlanPackage - -- Uses Monad (->) - (liftM2 (,) IPI.installedComponentId shapeInstalledPackage) - (liftM2 (,) elabComponentId elabModuleShape) - dpkg - indef_uid = - IndefFullUnitId dcid - (Map.fromList [ (req, OpenModuleVar req) - | req <- Set.toList (modShapeRequires shape)]) - --- | Get the bin\/ directories that a package's executables should reside in. --- --- The result may be empty if the package does not build any executables. --- --- The result may have several entries if this is an inplace build of a package --- with multiple executables. -binDirectories - :: DistDirLayout - -> ElaboratedSharedConfig - -> ElaboratedConfiguredPackage - -> [FilePath] -binDirectories layout config package = case elabBuildStyle package of - -- quick sanity check: no sense returning a bin directory if we're not going - -- to put any executables in it, that will just clog up the PATH - _ | noExecutables -> [] - BuildAndInstall -> [installedBinDirectory package] - BuildInplaceOnly -> map (root) $ case elabPkgOrComp package of - ElabComponent comp -> case compSolverName comp of - CD.ComponentExe n -> [prettyShow n] - _ -> [] - ElabPackage _ -> map (prettyShow . PD.exeName) - . PD.executables - . elabPkgDescription - $ package - where - noExecutables = null . PD.executables . elabPkgDescription $ package - root = distBuildDirectory layout (elabDistDirParams config package) - "build" - --- | A newtype for 'SolverInstallPlan.SolverPlanPackage' for which the --- dependency graph considers only dependencies on libraries which are --- NOT from setup dependencies. Used to compute the set --- of packages needed for profiling and dynamic libraries. -newtype NonSetupLibDepSolverPlanPackage - = NonSetupLibDepSolverPlanPackage - { unNonSetupLibDepSolverPlanPackage :: SolverInstallPlan.SolverPlanPackage } - -instance Package NonSetupLibDepSolverPlanPackage where - packageId = packageId . unNonSetupLibDepSolverPlanPackage - -instance IsNode NonSetupLibDepSolverPlanPackage where - type Key NonSetupLibDepSolverPlanPackage = SolverId - nodeKey = nodeKey . unNonSetupLibDepSolverPlanPackage - nodeNeighbors (NonSetupLibDepSolverPlanPackage spkg) - = ordNub $ CD.nonSetupDeps (resolverPackageLibDeps spkg) - -type InstS = Map UnitId ElaboratedPlanPackage -type InstM a = State InstS a - -getComponentId :: ElaboratedPlanPackage - -> ComponentId -getComponentId (InstallPlan.PreExisting dipkg) = IPI.installedComponentId dipkg -getComponentId (InstallPlan.Configured elab) = elabComponentId elab -getComponentId (InstallPlan.Installed elab) = elabComponentId elab - -instantiateInstallPlan :: StoreDirLayout -> InstallDirs.InstallDirTemplates -> ElaboratedSharedConfig -> ElaboratedInstallPlan -> ElaboratedInstallPlan -instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan = - InstallPlan.new (IndependentGoals False) - (Graph.fromDistinctList (Map.elems ready_map)) - where - pkgs = InstallPlan.toList plan - - cmap = Map.fromList [ (getComponentId pkg, pkg) | pkg <- pkgs ] - - instantiateUnitId :: ComponentId -> Map ModuleName Module - -> InstM DefUnitId - instantiateUnitId cid insts = state $ \s -> - case Map.lookup uid s of - Nothing -> - -- Knot tied - let (r, s') = runState (instantiateComponent uid cid insts) - (Map.insert uid r s) - in (def_uid, Map.insert uid r s') - Just _ -> (def_uid, s) - where - def_uid = mkDefUnitId cid insts - uid = unDefUnitId def_uid - - instantiateComponent - :: UnitId -> ComponentId -> Map ModuleName Module - -> InstM ElaboratedPlanPackage - instantiateComponent uid cid insts - | Just planpkg <- Map.lookup cid cmap - = case planpkg of - InstallPlan.Configured (elab0@ElaboratedConfiguredPackage - { elabPkgOrComp = ElabComponent comp }) -> do - deps <- traverse (substUnitId insts) - (compLinkedLibDependencies comp) - let getDep (Module dep_uid _) = [dep_uid] - elab1 = elab0 { - elabUnitId = uid, - elabComponentId = cid, - elabInstantiatedWith = insts, - elabIsCanonical = Map.null insts, - elabPkgOrComp = ElabComponent comp { - compOrderLibDependencies = - (if Map.null insts then [] else [newSimpleUnitId cid]) ++ - ordNub (map unDefUnitId - (deps ++ concatMap getDep (Map.elems insts))) - } - } - elab = elab1 { - elabInstallDirs = computeInstallDirs storeDirLayout - defaultInstallDirs - elaboratedShared - elab1 - } - return $ InstallPlan.Configured elab - _ -> return planpkg - | otherwise = error ("instantiateComponent: " ++ prettyShow cid) - - substUnitId :: Map ModuleName Module -> OpenUnitId -> InstM DefUnitId - substUnitId _ (DefiniteUnitId uid) = - return uid - substUnitId subst (IndefFullUnitId cid insts) = do - insts' <- substSubst subst insts - instantiateUnitId cid insts' - - -- NB: NOT composition - substSubst :: Map ModuleName Module - -> Map ModuleName OpenModule - -> InstM (Map ModuleName Module) - substSubst subst insts = traverse (substModule subst) insts - - substModule :: Map ModuleName Module -> OpenModule -> InstM Module - substModule subst (OpenModuleVar mod_name) - | Just m <- Map.lookup mod_name subst = return m - | otherwise = error "substModule: non-closing substitution" - substModule subst (OpenModule uid mod_name) = do - uid' <- substUnitId subst uid - return (Module uid' mod_name) - - 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 refiying 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 (substUnitId Map.empty uid) - else return uid - 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) - - 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 () - _ -> instantiateUnitId (getComponentId pkg) Map.empty - >> return () - ---------------------------- --- Build targets --- - --- Refer to ProjectPlanning.Types for details of these important types: - --- data ComponentTarget = ... --- data SubComponentTarget = ... - --- One step in the build system is to translate higher level intentions like --- "build this package", "test that package", or "repl that component" into --- a more detailed specification of exactly which components to build (or other --- actions like repl or build docs). This translation is somewhat different for --- different commands. For example "test" for a package will build a different --- set of components than "build". In addition, the translation of these --- intentions can fail. For example "run" for a package is only unambiguous --- when the package has a single executable. --- --- So we need a little bit of infrastructure to make it easy for the command --- implementations to select what component targets are meant when a user asks --- to do something with a package or component. To do this (and to be able to --- produce good error messages for mistakes and when targets are not available) --- we need to gather and summarise accurate information about all the possible --- targets, both available and unavailable. Then a command implementation can --- decide which of the available component targets should be selected. - --- | An available target represents a component within a package that a user --- command could plausibly refer to. In this sense, all the components defined --- within the package are things the user could refer to, whether or not it --- would actually be possible to build that component. --- --- In particular the available target contains an 'AvailableTargetStatus' which --- informs us about whether it's actually possible to select this component to --- be built, and if not why not. This detail makes it possible for command --- implementations (like @build@, @test@ etc) to accurately report why a target --- cannot be used. --- --- Note that the type parameter is used to help enforce that command --- implementations can only select targets that can actually be built (by --- forcing them to return the @k@ value for the selected targets). --- In particular 'resolveTargets' makes use of this (with @k@ as --- @('UnitId', ComponentName')@) to identify the targets thus selected. --- -data AvailableTarget k = AvailableTarget { - availableTargetPackageId :: PackageId, - availableTargetComponentName :: ComponentName, - availableTargetStatus :: AvailableTargetStatus k, - availableTargetLocalToProject :: Bool - } - deriving (Eq, Show, Functor) - --- | The status of a an 'AvailableTarget' component. This tells us whether --- it's actually possible to select this component to be built, and if not --- why not. --- -data AvailableTargetStatus k = - TargetDisabledByUser -- ^ When the user does @tests: False@ - | TargetDisabledBySolver -- ^ When the solver could not enable tests - | TargetNotBuildable -- ^ When the component has @buildable: False@ - | TargetNotLocal -- ^ When the component is non-core in a non-local package - | TargetBuildable k TargetRequested -- ^ The target can or should be built - deriving (Eq, Ord, Show, Functor) - --- | This tells us whether a target ought to be built by default, or only if --- specifically requested. The policy is that components like libraries and --- executables are built by default by @build@, but test suites and benchmarks --- are not, unless this is overridden in the project configuration. --- -data TargetRequested = - TargetRequestedByDefault -- ^ To be built by default - | TargetNotRequestedByDefault -- ^ Not to be built by default - deriving (Eq, Ord, Show) - --- | Given the install plan, produce the set of 'AvailableTarget's for each --- package-component pair. --- --- Typically there will only be one such target for each component, but for --- example if we have a plan with both normal and profiling variants of a --- component then we would get both as available targets, or similarly if we --- had a plan that contained two instances of the same version of a package. --- This approach makes it relatively easy to select all instances\/variants --- of a component. --- -availableTargets :: ElaboratedInstallPlan - -> Map (PackageId, ComponentName) - [AvailableTarget (UnitId, ComponentName)] -availableTargets installPlan = - let rs = [ (pkgid, cname, fake, target) - | pkg <- InstallPlan.toList installPlan - , (pkgid, cname, fake, target) <- case pkg of - InstallPlan.PreExisting ipkg -> availableInstalledTargets ipkg - InstallPlan.Installed elab -> availableSourceTargets elab - InstallPlan.Configured elab -> availableSourceTargets elab - ] - in Map.union - (Map.fromListWith (++) - [ ((pkgid, cname), [target]) - | (pkgid, cname, fake, target) <- rs, not fake]) - (Map.fromList - [ ((pkgid, cname), [target]) - | (pkgid, cname, fake, target) <- rs, fake]) - -- The normal targets mask the fake ones. We get all instances of the - -- normal ones and only one copy of the fake ones (as there are many - -- duplicates of the fake ones). See 'availableSourceTargets' below for - -- more details on this fake stuff is about. - -availableInstalledTargets :: IPI.InstalledPackageInfo - -> [(PackageId, ComponentName, Bool, - AvailableTarget (UnitId, ComponentName))] -availableInstalledTargets ipkg = - let unitid = installedUnitId ipkg - cname = CLibName LMainLibName - status = TargetBuildable (unitid, cname) TargetRequestedByDefault - target = AvailableTarget (packageId ipkg) cname status False - fake = False - in [(packageId ipkg, cname, fake, target)] - -availableSourceTargets :: ElaboratedConfiguredPackage - -> [(PackageId, ComponentName, Bool, - AvailableTarget (UnitId, ComponentName))] -availableSourceTargets elab = - -- We have a somewhat awkward problem here. We need to know /all/ the - -- components from /all/ the packages because these are the things that - -- users could refer to. Unfortunately, at this stage the elaborated install - -- plan does /not/ contain all components: some components have already - -- been deleted because they cannot possibly be built. This is the case - -- for components that are marked @buildable: False@ in their .cabal files. - -- (It's not unreasonable that the unbuildable components have been pruned - -- as the plan invariant is considerably simpler if all nodes can be built) - -- - -- We can recover the missing components but it's not exactly elegant. For - -- a graph node corresponding to a component we still have the information - -- about the package that it came from, and this includes the names of - -- /all/ the other components in the package. So in principle this lets us - -- find the names of all components, plus full details of the buildable - -- components. - -- - -- Consider for example a package with 3 exe components: foo, bar and baz - -- where foo and bar are buildable, but baz is not. So the plan contains - -- nodes for the components foo and bar. Now we look at each of these two - -- nodes and look at the package they come from and the names of the - -- components in this package. This will give us the names foo, bar and - -- baz, twice (once for each of the two buildable components foo and bar). - -- - -- We refer to these reconstructed missing components as fake targets. - -- It is an invariant that they are not available to be built. - -- - -- To produce the final set of targets we put the fake targets in a finite - -- 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) - | component <- pkgComponents (elabPkgDescription elab) - , let cname = componentName component - status = componentAvailableTargetStatus component - target = AvailableTarget { - availableTargetPackageId = packageId elab, - availableTargetComponentName = cname, - availableTargetStatus = status, - availableTargetLocalToProject = elabLocalToProject elab - } - fake = isFakeTarget cname - - -- TODO: The goal of this test is to exclude "instantiated" - -- packages as available targets. This means that you can't - -- ask for a particular instantiated component to be built; - -- it will only get built by a dependency. Perhaps the - -- correct way to implement this is to run selection - -- prior to instantiating packages. If you refactor - -- this, then you can delete this test. - , elabIsCanonical elab - - -- Filter out some bogus parts of the cross product that are never needed - , case status of - TargetBuildable{} | fake -> False - _ -> True - ] - where - isFakeTarget cname = - case elabPkgOrComp elab of - ElabPackage _ -> False - ElabComponent elabComponent -> compComponentName elabComponent - /= Just cname - - componentAvailableTargetStatus - :: Component -> AvailableTargetStatus (UnitId, ComponentName) - componentAvailableTargetStatus component = - case componentOptionalStanza $ CD.componentNameToComponent cname of - -- it is not an optional stanza, so a library, exe or foreign lib - Nothing - | not buildable -> TargetNotBuildable - | otherwise -> TargetBuildable (elabUnitId elab, cname) - TargetRequestedByDefault - - -- it is not an optional stanza, so a testsuite or benchmark - Just stanza -> - case (Map.lookup stanza (elabStanzasRequested elab), - Set.member stanza (elabStanzasAvailable elab)) of - _ | not withinPlan -> TargetNotLocal - (Just False, _) -> TargetDisabledByUser - (Nothing, False) -> TargetDisabledBySolver - _ | not buildable -> TargetNotBuildable - (Just True, True) -> TargetBuildable (elabUnitId elab, cname) - TargetRequestedByDefault - (Nothing, True) -> TargetBuildable (elabUnitId elab, cname) - TargetNotRequestedByDefault - (Just True, False) -> - error "componentAvailableTargetStatus: impossible" - where - cname = componentName component - buildable = PD.buildable (componentBuildInfo component) - withinPlan = elabLocalToProject elab - || case elabPkgOrComp elab of - ElabComponent elabComponent -> - compComponentName elabComponent == Just cname - ElabPackage _ -> - case componentName component of - CLibName (LMainLibName) -> True - CExeName _ -> True - --TODO: what about sub-libs and foreign libs? - _ -> False - --- | Merge component targets that overlap each other. Specially when we have --- multiple targets for the same component and one of them refers to the whole --- component (rather than a module or file within) then all the other targets --- for that component are subsumed. --- --- We also allow for information associated with each component target, and --- whenever we targets subsume each other we aggregate their associated info. --- -nubComponentTargets :: [(ComponentTarget, a)] -> [(ComponentTarget, [a])] -nubComponentTargets = - concatMap (wholeComponentOverrides . map snd) - . groupBy ((==) `on` fst) - . sortBy (compare `on` fst) - . map (\t@((ComponentTarget cname _, _)) -> (cname, t)) - . map 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. - wholeComponentOverrides :: [(ComponentTarget, a )] - -> [(ComponentTarget, [a])] - wholeComponentOverrides ts = - case [ t | (t@(ComponentTarget _ WholeComponent), _) <- ts ] of - (t:_) -> [ (t, map snd ts) ] - [] -> [ (t,[x]) | (t,x) <- ts ] - - -- Not all Cabal Setup.hs versions support sub-component targets, so switch - -- them over to the whole component - compatSubComponentTargets :: (ComponentTarget, a) -> (ComponentTarget, a) - compatSubComponentTargets target@(ComponentTarget cname _subtarget, x) - | not setupHsSupportsSubComponentTargets - = (ComponentTarget cname WholeComponent, x) - | otherwise = target - - -- Actually the reality is that no current version of Cabal's Setup.hs - -- build command actually support building specific files or modules. - setupHsSupportsSubComponentTargets = False - -- TODO: when that changes, adjust this test, e.g. - -- | pkgSetupScriptCliVersion >= Version [x,y] [] - -pkgHasEphemeralBuildTargets :: ElaboratedConfiguredPackage -> Bool -pkgHasEphemeralBuildTargets elab = - isJust (elabReplTarget elab) - || (not . null) (elabTestTargets elab) - || (not . null) (elabBenchTargets elab) - || (not . null) (elabHaddockTargets elab) - || (not . null) [ () | ComponentTarget _ subtarget <- elabBuildTargets elab - , subtarget /= WholeComponent ] - --- | The components that we'll build all of, meaning that after they're built --- we can skip building them again (unlike with building just some modules or --- other files within a component). --- -elabBuildTargetWholeComponents :: ElaboratedConfiguredPackage - -> Set ComponentName -elabBuildTargetWholeComponents elab = - Set.fromList - [ cname | ComponentTarget cname WholeComponent <- elabBuildTargets elab ] - - - ------------------------------------------------------------------------------- --- * Install plan pruning ------------------------------------------------------------------------------- - --- | How 'pruneInstallPlanToTargets' should interpret the per-package --- 'ComponentTarget's: as build, repl or haddock targets. --- -data TargetAction = TargetActionConfigure - | TargetActionBuild - | TargetActionRepl - | TargetActionTest - | TargetActionBench - | TargetActionHaddock - --- | Given a set of per-package\/per-component targets, take the subset of the --- install plan needed to build those targets. Also, update the package config --- to specify which optional stanzas to enable, and which targets within each --- package to build. --- --- NB: Pruning happens after improvement, which is important because we --- will prune differently depending on what is already installed (to --- implement "sticky" test suite enabling behavior). --- -pruneInstallPlanToTargets :: TargetAction - -> Map UnitId [ComponentTarget] - -> ElaboratedInstallPlan -> ElaboratedInstallPlan -pruneInstallPlanToTargets targetActionType perPkgTargetsMap elaboratedPlan = - InstallPlan.new (InstallPlan.planIndepGoals elaboratedPlan) - . Graph.fromDistinctList - -- We have to do the pruning in two passes - . pruneInstallPlanPass2 - . pruneInstallPlanPass1 - -- Set the targets that will be the roots for pruning - . setRootTargets targetActionType perPkgTargetsMap - . InstallPlan.toList - $ elaboratedPlan - --- | This is a temporary data type, where we temporarily --- override the graph dependencies of an 'ElaboratedPackage', --- so we can take a closure over them. We'll throw out the --- overriden dependencies when we're done so it's strictly temporary. --- --- For 'ElaboratedComponent', this the cached unit IDs always --- coincide with the real thing. -data PrunedPackage = PrunedPackage ElaboratedConfiguredPackage [UnitId] - -instance Package PrunedPackage where - packageId (PrunedPackage elab _) = packageId elab - -instance HasUnitId PrunedPackage where - installedUnitId = nodeKey - -instance IsNode PrunedPackage where - type Key PrunedPackage = UnitId - nodeKey (PrunedPackage elab _) = nodeKey elab - nodeNeighbors (PrunedPackage _ deps) = deps - -fromPrunedPackage :: PrunedPackage -> ElaboratedConfiguredPackage -fromPrunedPackage (PrunedPackage elab _) = elab - --- | Set the build targets based on the user targets (but not rev deps yet). --- This is required before we can prune anything. --- -setRootTargets :: TargetAction - -> Map UnitId [ComponentTarget] - -> [ElaboratedPlanPackage] - -> [ElaboratedPlanPackage] -setRootTargets targetAction perPkgTargetsMap = - assert (not (Map.null perPkgTargetsMap)) $ - assert (all (not . null) (Map.elems perPkgTargetsMap)) $ - - map (mapConfiguredPackage setElabBuildTargets) - where - -- Set the targets we'll build for this package/component. This is just - -- based on the root targets from the user, not targets implied by reverse - -- dependencies. Those comes in the second pass once we know the rev deps. - -- - setElabBuildTargets elab = - case (Map.lookup (installedUnitId elab) perPkgTargetsMap, - targetAction) of - (Nothing, _) -> elab - (Just tgts, TargetActionConfigure) -> elab { elabConfigureTargets = tgts } - (Just tgts, TargetActionBuild) -> elab { elabBuildTargets = tgts } - (Just tgts, TargetActionTest) -> elab { elabTestTargets = tgts } - (Just tgts, TargetActionBench) -> elab { elabBenchTargets = tgts } - (Just [tgt], TargetActionRepl) -> elab { elabReplTarget = Just tgt - , elabBuildHaddocks = False } - (Just tgts, TargetActionHaddock) -> - foldr setElabHaddockTargets (elab { elabHaddockTargets = tgts - , elabBuildHaddocks = True }) tgts - (Just _, TargetActionRepl) -> - error "pruneInstallPlanToTargets: multiple repl targets" - - setElabHaddockTargets tgt elab - | isTestComponentTarget tgt = elab { elabHaddockTestSuites = True } - | isBenchComponentTarget tgt = elab { elabHaddockBenchmarks = True } - | isForeignLibComponentTarget tgt = elab { elabHaddockForeignLibs = True } - | isExeComponentTarget tgt = elab { elabHaddockExecutables = True } - | isSubLibComponentTarget tgt = elab { elabHaddockInternal = True } - | otherwise = elab - --- | Assuming we have previously set the root build targets (i.e. the user --- targets but not rev deps yet), the first pruning pass does two things: --- --- * A first go at determining which optional stanzas (testsuites, benchmarks) --- are needed. We have a second go in the next pass. --- * Take the dependency closure using pruned dependencies. We prune deps that --- 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] - -> [ElaboratedPlanPackage] -pruneInstallPlanPass1 pkgs = - map (mapConfiguredPackage fromPrunedPackage) - (fromMaybe [] $ Graph.closure graph roots) - where - pkgs' = map (mapConfiguredPackage prune) pkgs - graph = Graph.fromDistinctList pkgs' - roots = mapMaybe find_root pkgs' - - prune elab = PrunedPackage elab' (pruneOptionalDependencies elab') - where elab' = - setDocumentation - $ addOptionalStanzas elab - - find_root (InstallPlan.Configured (PrunedPackage elab _)) = - if not $ and [ null (elabConfigureTargets elab) - , null (elabBuildTargets elab) - , null (elabTestTargets elab) - , null (elabBenchTargets elab) - , isNothing (elabReplTarget elab) - , null (elabHaddockTargets elab) - ] - then Just (installedUnitId elab) - else Nothing - find_root _ = Nothing - - -- Note [Sticky enabled testsuites] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- The testsuite and benchmark targets are somewhat special in that we need - -- to configure the packages with them enabled, and we need to do that even - -- if we only want to build one of several testsuites. - -- - -- There are two cases in which we will enable the testsuites (or - -- benchmarks): if one of the targets is a testsuite, or if all of the - -- testsuite dependencies are already cached in the store. The rationale - -- for the latter is to minimise how often we have to reconfigure due to - -- the particular targets we choose to build. Otherwise choosing to build - -- a testsuite target, and then later choosing to build an exe target - -- would involve unnecessarily reconfiguring the package with testsuites - -- disabled. Technically this introduces a little bit of stateful - -- behaviour to make this "sticky", but it should be benign. - - -- Decide whether or not to enable testsuites and benchmarks. - -- See [Sticky enabled testsuites] - addOptionalStanzas :: ElaboratedConfiguredPackage -> ElaboratedConfiguredPackage - addOptionalStanzas elab@ElaboratedConfiguredPackage{ elabPkgOrComp = ElabPackage pkg } = - elab { - elabPkgOrComp = ElabPackage (pkg { pkgStanzasEnabled = stanzas }) - } - where - stanzas :: Set OptionalStanza - -- By default, we enabled all stanzas requested by the user, - -- as per elabStanzasRequested, done in - -- 'elaborateSolverToPackage' - stanzas = pkgStanzasEnabled pkg - -- optionalStanzasRequiredByTargets has to be done at - -- prune-time because it depends on 'elabTestTargets' - -- et al, which is done by 'setRootTargets' at the - -- beginning of pruning. - <> optionalStanzasRequiredByTargets elab - -- optionalStanzasWithDepsAvailable has to be done at - -- prune-time because it depends on what packages are - -- installed, which is not known until after improvement - -- (pruning is done after improvement) - <> optionalStanzasWithDepsAvailable availablePkgs elab pkg - addOptionalStanzas elab = elab - - setDocumentation :: ElaboratedConfiguredPackage -> ElaboratedConfiguredPackage - setDocumentation elab@ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent comp } = - elab { - elabBuildHaddocks = - elabBuildHaddocks elab && documentationEnabled (compSolverName comp) elab - } - - where - documentationEnabled c = - case c of - CD.ComponentLib -> const True - CD.ComponentSubLib _ -> elabHaddockInternal - CD.ComponentFLib _ -> elabHaddockForeignLibs - CD.ComponentExe _ -> elabHaddockExecutables - CD.ComponentTest _ -> elabHaddockTestSuites - CD.ComponentBench _ -> elabHaddockBenchmarks - CD.ComponentSetup -> const False - - setDocumentation elab = elab - - -- Calculate package dependencies but cut out those needed only by - -- optional stanzas that we've determined we will not enable. - -- These pruned deps are not persisted in this pass since they're based on - -- the optional stanzas and we'll make further tweaks to the optional - -- stanzas in the next pass. - -- - pruneOptionalDependencies :: ElaboratedConfiguredPackage -> [UnitId] - pruneOptionalDependencies elab@ElaboratedConfiguredPackage{ elabPkgOrComp = ElabComponent _ } - = InstallPlan.depends elab -- no pruning - pruneOptionalDependencies ElaboratedConfiguredPackage{ elabPkgOrComp = ElabPackage pkg } - = (CD.flatDeps . CD.filterDeps keepNeeded) (pkgOrderDependencies pkg) - where - keepNeeded (CD.ComponentTest _) _ = TestStanzas `Set.member` stanzas - keepNeeded (CD.ComponentBench _) _ = BenchStanzas `Set.member` stanzas - keepNeeded _ _ = True - stanzas = pkgStanzasEnabled pkg - - optionalStanzasRequiredByTargets :: ElaboratedConfiguredPackage - -> Set OptionalStanza - optionalStanzasRequiredByTargets pkg = - Set.fromList - [ stanza - | ComponentTarget cname _ <- elabBuildTargets pkg - ++ elabTestTargets pkg - ++ elabBenchTargets pkg - ++ maybeToList (elabReplTarget pkg) - ++ elabHaddockTargets pkg - , stanza <- maybeToList $ - componentOptionalStanza $ - CD.componentNameToComponent cname - ] - - availablePkgs = - Set.fromList - [ installedUnitId pkg - | InstallPlan.PreExisting pkg <- pkgs ] - --- | Given a set of already installed packages @availablePkgs@, --- determine the set of available optional stanzas from @pkg@ --- which have all of their dependencies already installed. This is used --- to implement "sticky" testsuites, where once we have installed --- all of the deps needed for the test suite, we go ahead and --- enable it always. -optionalStanzasWithDepsAvailable :: Set UnitId - -> ElaboratedConfiguredPackage - -> ElaboratedPackage - -> Set OptionalStanza -optionalStanzasWithDepsAvailable availablePkgs elab pkg = - Set.fromList - [ stanza - | stanza <- Set.toList (elabStanzasAvailable elab) - , let deps :: [UnitId] - deps = CD.select (optionalStanzaDeps stanza) - -- TODO: probably need to select other - -- dep types too eventually - (pkgOrderDependencies pkg) - , all (`Set.member` availablePkgs) deps - ] - where - optionalStanzaDeps TestStanzas (CD.ComponentTest _) = True - optionalStanzaDeps BenchStanzas (CD.ComponentBench _) = True - optionalStanzaDeps _ _ = False - - --- The second pass does three things: --- --- * A second go at deciding which optional stanzas to enable. --- * Prune the dependencies based on the final choice of optional stanzas. --- * Extend the targets within each package to build, now we know the reverse --- dependencies, ie we know which libs are needed as deps by other packages. --- --- Achieving sticky behaviour with enabling\/disabling optional stanzas is --- tricky. The first approximation was handled by the first pass above, but --- it's not quite enough. That pass will enable stanzas if all of the deps --- of the optional stanza are already installed /in the store/. That's important --- but it does not account for dependencies that get built inplace as part of --- the project. We cannot take those inplace build deps into account in the --- pruning pass however because we don't yet know which ones we're going to --- build. Once we do know, we can have another go and enable stanzas that have --- all their deps available. Now we can consider all packages in the pruned --- plan to be available, including ones we already decided to build from --- source. --- --- Deciding which targets to build depends on knowing which packages have --- reverse dependencies (ie are needed). This requires the result of first --- pass, which is another reason we have to split it into two passes. --- --- Note that just because we might enable testsuites or benchmarks (in the --- first or second pass) doesn't mean that we build all (or even any) of them. --- That depends on which targets we picked in the first pass. --- -pruneInstallPlanPass2 :: [ElaboratedPlanPackage] - -> [ElaboratedPlanPackage] -pruneInstallPlanPass2 pkgs = - map (mapConfiguredPackage setStanzasDepsAndTargets) pkgs - where - setStanzasDepsAndTargets elab = - elab { - elabBuildTargets = ordNub - $ elabBuildTargets elab - ++ libTargetsRequiredForRevDeps - ++ exeTargetsRequiredForRevDeps, - elabPkgOrComp = - case elabPkgOrComp elab of - ElabPackage pkg -> - let stanzas = pkgStanzasEnabled pkg - <> optionalStanzasWithDepsAvailable availablePkgs elab pkg - keepNeeded (CD.ComponentTest _) _ = TestStanzas `Set.member` stanzas - keepNeeded (CD.ComponentBench _) _ = BenchStanzas `Set.member` stanzas - keepNeeded _ _ = True - in ElabPackage $ pkg { - pkgStanzasEnabled = stanzas, - pkgLibDependencies = CD.filterDeps keepNeeded (pkgLibDependencies pkg), - pkgExeDependencies = CD.filterDeps keepNeeded (pkgExeDependencies pkg), - pkgExeDependencyPaths = CD.filterDeps keepNeeded (pkgExeDependencyPaths pkg) - } - r@(ElabComponent _) -> r - } - where - libTargetsRequiredForRevDeps = - [ ComponentTarget (CLibName Cabal.defaultLibName) WholeComponent - | installedUnitId elab `Set.member` hasReverseLibDeps - ] - exeTargetsRequiredForRevDeps = - -- TODO: allow requesting executable with different name - -- than package name - [ ComponentTarget (Cabal.CExeName - $ packageNameToUnqualComponentName - $ packageName $ elabPkgSourceId elab) - WholeComponent - | installedUnitId elab `Set.member` hasReverseExeDeps - ] - - - availablePkgs :: Set UnitId - availablePkgs = Set.fromList (map installedUnitId pkgs) - - hasReverseLibDeps :: Set UnitId - hasReverseLibDeps = - Set.fromList [ depid - | InstallPlan.Configured pkg <- pkgs - , depid <- elabOrderLibDependencies pkg ] - - hasReverseExeDeps :: Set UnitId - hasReverseExeDeps = - Set.fromList [ depid - | InstallPlan.Configured pkg <- pkgs - , depid <- elabOrderExeDependencies pkg ] - -mapConfiguredPackage :: (srcpkg -> srcpkg') - -> InstallPlan.GenericPlanPackage ipkg srcpkg - -> InstallPlan.GenericPlanPackage ipkg srcpkg' -mapConfiguredPackage f (InstallPlan.Configured pkg) = - InstallPlan.Configured (f pkg) -mapConfiguredPackage f (InstallPlan.Installed pkg) = - InstallPlan.Installed (f pkg) -mapConfiguredPackage _ (InstallPlan.PreExisting pkg) = - InstallPlan.PreExisting pkg - ------------------------------------- --- Support for --only-dependencies --- - --- | Try to remove the given targets from the install plan. --- --- This is not always possible. --- -pruneInstallPlanToDependencies :: Set UnitId - -> ElaboratedInstallPlan - -> Either CannotPruneDependencies - ElaboratedInstallPlan -pruneInstallPlanToDependencies pkgTargets installPlan = - assert (all (isJust . InstallPlan.lookup installPlan) - (Set.toList pkgTargets)) $ - - fmap (InstallPlan.new (InstallPlan.planIndepGoals installPlan)) - . checkBrokenDeps - . Graph.fromDistinctList - . filter (\pkg -> installedUnitId pkg `Set.notMember` pkgTargets) - . InstallPlan.toList - $ installPlan - where - -- Our strategy is to remove the packages we don't want and then check - -- if the remaining graph is broken or not, ie any packages with dangling - -- dependencies. If there are then we cannot prune the given targets. - checkBrokenDeps :: Graph.Graph ElaboratedPlanPackage - -> Either CannotPruneDependencies - (Graph.Graph ElaboratedPlanPackage) - checkBrokenDeps graph = - case Graph.broken graph of - [] -> Right graph - brokenPackages -> - Left $ CannotPruneDependencies - [ (pkg, missingDeps) - | (pkg, missingDepIds) <- brokenPackages - , let missingDeps = mapMaybe lookupDep missingDepIds - ] - where - -- lookup in the original unpruned graph - lookupDep = InstallPlan.lookup installPlan - --- | It is not always possible to prune to only the dependencies of a set of --- targets. It may be the case that removing a package leaves something else --- that still needed the pruned package. --- --- This lists all the packages that would be broken, and their dependencies --- that would be missing if we did prune. --- -newtype CannotPruneDependencies = - CannotPruneDependencies [(ElaboratedPlanPackage, - [ElaboratedPlanPackage])] - deriving (Show) - - ---------------------------- --- Setup.hs script policy --- - --- Handling for Setup.hs scripts is a bit tricky, part of it lives in the --- solver phase, and part in the elaboration phase. We keep the helper --- functions for both phases together here so at least you can see all of it --- in one place. --- --- There are four major cases for Setup.hs handling: --- --- 1. @build-type@ Custom with a @custom-setup@ section --- 2. @build-type@ Custom without a @custom-setup@ section --- 3. @build-type@ not Custom with @cabal-version > $our-cabal-version@ --- 4. @build-type@ not Custom with @cabal-version <= $our-cabal-version@ --- --- It's also worth noting that packages specifying @cabal-version: >= 1.23@ --- or later that have @build-type@ Custom will always have a @custom-setup@ --- section. Therefore in case 2, the specified @cabal-version@ will always be --- less than 1.23. --- --- In cases 1 and 2 we obviously have to build an external Setup.hs script, --- while in case 4 we can use the internal library API. --- --- TODO:In case 3 we should fail. We don't know how to talk to --- newer ./Setup.hs --- --- data SetupScriptStyle = ... -- see ProjectPlanning.Types - --- | Work out the 'SetupScriptStyle' given the package description. --- -packageSetupScriptStyle :: PD.PackageDescription -> SetupScriptStyle -packageSetupScriptStyle pkg - | buildType == PD.Custom - , Just setupbi <- PD.setupBuildInfo pkg -- does have a custom-setup stanza - , not (PD.defaultSetupDepends setupbi) -- but not one we added internally - = SetupCustomExplicitDeps - - | buildType == PD.Custom - , Just setupbi <- PD.setupBuildInfo pkg -- we get this case post-solver as - , PD.defaultSetupDepends setupbi -- the solver fills in the deps - = SetupCustomImplicitDeps - - | buildType == PD.Custom - , Nothing <- PD.setupBuildInfo pkg -- we get this case pre-solver - = SetupCustomImplicitDeps - - -- here we should fail. - | PD.specVersion pkg > cabalSpecLatest -- one cabal-install is built against - = SetupNonCustomExternalLib - - | otherwise - = SetupNonCustomInternalLib - where - buildType = PD.buildType pkg - - --- | Part of our Setup.hs handling policy is implemented by getting the solver --- to work out setup dependencies for packages. The solver already handles --- packages that explicitly specify setup dependencies, but we can also tell --- the solver to treat other packages as if they had setup dependencies. --- That's what this function does, it gets called by the solver for all --- packages that don't already have setup dependencies. --- --- The dependencies we want to add is different for each 'SetupScriptStyle'. --- --- Note that adding default deps means these deps are actually /added/ to the --- packages that we get out of the solver in the 'SolverInstallPlan'. Making --- implicit setup deps explicit is a problem in the post-solver stages because --- we still need to distinguish the case of explicit and implict setup deps. --- See 'rememberImplicitSetupDeps'. --- --- Note in addition to adding default setup deps, we also use --- 'addSetupCabalMinVersionConstraint' (in 'planPackages') to require --- @Cabal >= 1.20@ for Setup scripts. --- -defaultSetupDeps :: Compiler -> Platform - -> PD.PackageDescription - -> Maybe [Dependency] -defaultSetupDeps compiler platform pkg = - case packageSetupScriptStyle pkg of - - -- For packages with build type custom that do not specify explicit - -- setup dependencies, we add a dependency on Cabal and a number - -- of other packages. - SetupCustomImplicitDeps -> - Just $ - [ Dependency depPkgname anyVersion mainLibSet - | depPkgname <- legacyCustomSetupPkgs compiler platform ] ++ - [ Dependency cabalPkgname cabalConstraint mainLibSet - | packageName pkg /= cabalPkgname ] - where - -- The Cabal dep is slightly special: - -- * We omit the dep for the Cabal lib itself, since it bootstraps. - -- * We constrain it to be < 1.25 - -- - -- Note: we also add a global constraint to require Cabal >= 1.20 - -- for Setup scripts (see use addSetupCabalMinVersionConstraint). - -- - cabalConstraint = orLaterVersion (csvToVersion (PD.specVersion pkg)) - `intersectVersionRanges` - earlierVersion cabalCompatMaxVer - -- The idea here is that at some point we will make significant - -- breaking changes to the Cabal API that Setup.hs scripts use. - -- So for old custom Setup scripts that do not specify explicit - -- constraints, we constrain them to use a compatible Cabal version. - cabalCompatMaxVer = mkVersion [1,25] - - -- For other build types (like Simple) if we still need to compile an - -- external Setup.hs, it'll be one of the simple ones that only depends - -- on Cabal and base. - SetupNonCustomExternalLib -> - Just [ Dependency cabalPkgname cabalConstraint mainLibSet - , Dependency basePkgname anyVersion mainLibSet] - where - cabalConstraint = orLaterVersion (csvToVersion (PD.specVersion pkg)) - - -- The internal setup wrapper method has no deps at all. - SetupNonCustomInternalLib -> Just [] - - -- This case gets ruled out by the caller, planPackages, see the note - -- above in the SetupCustomImplicitDeps case. - SetupCustomExplicitDeps -> - error $ "defaultSetupDeps: called for a package with explicit " - ++ "setup deps: " ++ prettyShow (packageId pkg) - where - -- we require one less - -- - -- This maps e.g. CabalSpecV3_0 to mkVersion [2,5] - csvToVersion :: CabalSpecVersion -> Version - csvToVersion = mkVersion . cabalSpecMinimumLibraryVersion - --- | Work out which version of the Cabal we will be using to talk to the --- Setup.hs interface for this package. --- --- This depends somewhat on the 'SetupScriptStyle' but most cases are a result --- of what the solver picked for us, based on the explicit setup deps or the --- ones added implicitly by 'defaultSetupDeps'. --- -packageSetupScriptSpecVersion :: SetupScriptStyle - -> PD.PackageDescription - -> Graph.Graph NonSetupLibDepSolverPlanPackage - -> ComponentDeps [SolverId] - -> Version - --- We're going to be using the internal Cabal library, so the spec version of --- that is simply the version of the Cabal library that cabal-install has been --- built with. -packageSetupScriptSpecVersion SetupNonCustomInternalLib _ _ _ = - cabalVersion - --- If we happen to be building the Cabal lib itself then because that --- bootstraps itself then we use the version of the lib we're building. -packageSetupScriptSpecVersion SetupCustomImplicitDeps pkg _ _ - | packageName pkg == cabalPkgname - = packageVersion pkg - --- In all other cases we have a look at what version of the Cabal lib the --- solver picked. Or if it didn't depend on Cabal at all (which is very rare) --- then we look at the .cabal file to see what spec version it declares. -packageSetupScriptSpecVersion _ pkg libDepGraph deps = - case find ((cabalPkgname ==) . packageName) setupLibDeps of - Just dep -> packageVersion dep - Nothing -> mkVersion (cabalSpecMinimumLibraryVersion (PD.specVersion pkg)) - where - setupLibDeps = map packageId $ fromMaybe [] $ - Graph.closure libDepGraph (CD.setupDeps deps) - - -cabalPkgname, basePkgname :: PackageName -cabalPkgname = mkPackageName "Cabal" -basePkgname = mkPackageName "base" - - -legacyCustomSetupPkgs :: Compiler -> Platform -> [PackageName] -legacyCustomSetupPkgs compiler (Platform _ os) = - map mkPackageName $ - [ "array", "base", "binary", "bytestring", "containers" - , "deepseq", "directory", "filepath", "pretty" - , "process", "time", "transformers" ] - ++ [ "Win32" | os == Windows ] - ++ [ "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] - --- The other aspects of our Setup.hs policy lives here where we decide on --- the 'SetupScriptOptions'. --- --- Our current policy for the 'SetupCustomImplicitDeps' case is that we --- try to make the implicit deps cover everything, and we don't allow the --- compiler to pick up other deps. This may or may not be sustainable, and --- we might have to allow the deps to be non-exclusive, but that itself would --- be tricky since we would have to allow the Setup access to all the packages --- in the store and local dbs. - -setupHsScriptOptions :: ElaboratedReadyPackage - -> ElaboratedInstallPlan - -> ElaboratedSharedConfig - -> DistDirLayout - -> FilePath - -> FilePath - -> Bool - -> Lock - -> SetupScriptOptions --- TODO: Fix this so custom is a separate component. Custom can ALWAYS --- be a separate component!!! -setupHsScriptOptions (ReadyPackage elab@ElaboratedConfiguredPackage{..}) - plan ElaboratedSharedConfig{..} distdir srcdir builddir - isParallelBuild cacheLock = - SetupScriptOptions { - useCabalVersion = thisVersion elabSetupScriptCliVersion, - useCabalSpecVersion = Just elabSetupScriptCliVersion, - useCompiler = Just pkgConfigCompiler, - usePlatform = Just pkgConfigPlatform, - usePackageDB = elabSetupPackageDBStack, - usePackageIndex = Nothing, - useDependencies = [ (uid, srcid) - | ConfiguredId srcid (Just (CLibName LMainLibName)) uid - <- elabSetupDependencies elab ], - useDependenciesExclusive = True, - useVersionMacros = elabSetupScriptStyle == SetupCustomExplicitDeps, - useProgramDb = pkgConfigCompilerProgs, - useDistPref = builddir, - useLoggingHandle = Nothing, -- this gets set later - useWorkingDir = Just srcdir, - useExtraPathEnv = elabExeDependencyPaths elab, - useExtraEnvOverrides = dataDirsEnvironmentForPlan distdir plan, - useWin32CleanHack = False, --TODO: [required eventually] - forceExternalSetupMethod = isParallelBuild, - setupCacheLock = Just cacheLock, - isInteractive = False - } - - --- | To be used for the input for elaborateInstallPlan. --- --- TODO: [code cleanup] make InstallDirs.defaultInstallDirs pure. --- -userInstallDirTemplates :: Compiler - -> IO InstallDirs.InstallDirTemplates -userInstallDirTemplates compiler = do - InstallDirs.defaultInstallDirs - (compilerFlavor compiler) - True -- user install - False -- unused - -storePackageInstallDirs :: StoreDirLayout - -> CompilerId - -> InstalledPackageId - -> InstallDirs.InstallDirs FilePath -storePackageInstallDirs storeDirLayout compid ipkgid = - storePackageInstallDirs' storeDirLayout compid $ newSimpleUnitId ipkgid - -storePackageInstallDirs' :: StoreDirLayout - -> CompilerId - -> UnitId - -> InstallDirs.InstallDirs FilePath -storePackageInstallDirs' StoreDirLayout{ storePackageDirectory - , storeDirectory } - compid unitid = - InstallDirs.InstallDirs {..} - where - store = storeDirectory compid - prefix = storePackageDirectory compid unitid - bindir = prefix "bin" - libdir = prefix "lib" - libsubdir = "" - -- Note: on macOS, we place libraries into - -- @store/lib@ to work around the load - -- command size limit of macOSs mach-o linker. - -- See also @PackageHash.hashedInstalledPackageIdVeryShort@ - dynlibdir | buildOS == OSX = store "lib" - | otherwise = libdir - flibdir = libdir - libexecdir = prefix "libexec" - libexecsubdir= "" - includedir = libdir "include" - datadir = prefix "share" - datasubdir = "" - docdir = datadir "doc" - mandir = datadir "man" - htmldir = docdir "html" - haddockdir = htmldir - sysconfdir = prefix "etc" - - - -computeInstallDirs :: StoreDirLayout - -> InstallDirs.InstallDirTemplates - -> ElaboratedSharedConfig - -> ElaboratedConfiguredPackage - -> InstallDirs.InstallDirs FilePath -computeInstallDirs storeDirLayout defaultInstallDirs elaboratedShared elab - | elabBuildStyle elab == BuildInplaceOnly - -- use the ordinary default install dirs - = (InstallDirs.absoluteInstallDirs - (elabPkgSourceId elab) - (elabUnitId elab) - (compilerInfo (pkgConfigCompiler elaboratedShared)) - InstallDirs.NoCopyDest - (pkgConfigPlatform elaboratedShared) - defaultInstallDirs) { - - -- absoluteInstallDirs sets these as 'undefined' but we have - -- to use them as "Setup.hs configure" args - InstallDirs.libsubdir = "", - InstallDirs.libexecsubdir = "", - InstallDirs.datasubdir = "" - } - - | otherwise - -- use special simplified install dirs - = storePackageInstallDirs' - storeDirLayout - (compilerId (pkgConfigCompiler elaboratedShared)) - (elabUnitId elab) - - ---TODO: [code cleanup] perhaps reorder this code --- based on the ElaboratedInstallPlan + ElaboratedSharedConfig, --- make the various Setup.hs {configure,build,copy} flags - - -setupHsConfigureFlags :: ElaboratedReadyPackage - -> ElaboratedSharedConfig - -> Verbosity - -> FilePath - -> Cabal.ConfigFlags -setupHsConfigureFlags (ReadyPackage elab@ElaboratedConfiguredPackage{..}) - sharedConfig@ElaboratedSharedConfig{..} - verbosity builddir = - sanityCheckElaboratedConfiguredPackage sharedConfig elab - (Cabal.ConfigFlags {..}) - where - configArgs = mempty -- unused, passed via args - configDistPref = toFlag builddir - configCabalFilePath = mempty - configVerbosity = toFlag verbosity - - configInstantiateWith = Map.toList elabInstantiatedWith - - configDeterministic = mempty -- doesn't matter, configIPID/configCID overridese - configIPID = case elabPkgOrComp of - ElabPackage pkg -> toFlag (prettyShow (pkgInstalledId pkg)) - ElabComponent _ -> mempty - configCID = case elabPkgOrComp of - ElabPackage _ -> mempty - 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 - -- conistently well-defined clean slate) until we find a - -- better way. - = Map.toList $ - Map.insertWith (++) "ghc" ["-hide-all-packages"] - elabProgramArgs - | otherwise = Map.toList elabProgramArgs - configProgramPathExtra = toNubList elabProgramPathExtra - configHcFlavor = toFlag (compilerFlavor pkgConfigCompiler) - configHcPath = mempty -- we use configProgramPaths instead - configHcPkg = mempty -- we use configProgramPaths instead - - configVanillaLib = toFlag elabVanillaLib - configSharedLib = toFlag elabSharedLib - configStaticLib = toFlag elabStaticLib - - configDynExe = toFlag elabDynExe - configFullyStaticExe = toFlag elabFullyStaticExe - configGHCiLib = toFlag elabGHCiLib - configProfExe = mempty - configProfLib = toFlag elabProfLib - configProf = toFlag elabProfExe - - -- configProfDetail is for exe+lib, but overridden by configProfLibDetail - -- so we specify both so we can specify independently - configProfDetail = toFlag elabProfExeDetail - configProfLibDetail = toFlag elabProfLibDetail - - configCoverage = toFlag elabCoverage - configLibCoverage = mempty - - configOptimization = toFlag elabOptimization - configSplitSections = toFlag elabSplitSections - configSplitObjs = toFlag elabSplitObjs - configStripExes = toFlag elabStripExes - configStripLibs = toFlag elabStripLibs - configDebugInfo = toFlag elabDebugInfo - - configConfigurationsFlags = elabFlagAssignment - configConfigureArgs = elabConfigureScriptArgs - configExtraLibDirs = elabExtraLibDirs - configExtraFrameworkDirs = elabExtraFrameworkDirs - configExtraIncludeDirs = elabExtraIncludeDirs - configProgPrefix = maybe mempty toFlag elabProgPrefix - configProgSuffix = maybe mempty toFlag elabProgSuffix - - configInstallDirs = fmap (toFlag . InstallDirs.toPathTemplate) - elabInstallDirs - - -- we only use configDependencies, unless we're talking to an old Cabal - -- in which case we use configConstraints - -- NB: This does NOT use InstallPlan.depends, which includes executable - -- dependencies which should NOT be fed in here (also you don't have - -- enough info anyway) - configDependencies = [ GivenComponent - (packageName srcid) - ln - cid - | ConfiguredId srcid mb_cn cid <- elabLibDependencies elab - , let ln = case mb_cn - of Just (CLibName lname) -> lname - Just _ -> error "non-library dependency" - Nothing -> LMainLibName - ] - configConstraints = - case elabPkgOrComp of - ElabPackage _ -> - [ thisPackageVersionConstraint srcid - | ConfiguredId srcid _ _uid <- elabLibDependencies elab ] - ElabComponent _ -> [] - - - -- explicitly clear, then our package db stack - -- TODO: [required eventually] have to do this differently for older Cabal versions - configPackageDBs = Nothing : map Just elabBuildPackageDBStack - - configTests = case elabPkgOrComp of - ElabPackage pkg -> toFlag (TestStanzas `Set.member` pkgStanzasEnabled pkg) - ElabComponent _ -> mempty - configBenchmarks = case elabPkgOrComp of - ElabPackage pkg -> toFlag (BenchStanzas `Set.member` pkgStanzasEnabled pkg) - ElabComponent _ -> mempty - - configExactConfiguration = toFlag True - configFlagError = mempty --TODO: [research required] appears not to be implemented - configRelocatable = mempty --TODO: [research required] ??? - configScratchDir = mempty -- never use - configUserInstall = mempty -- don't rely on defaults - configPrograms_ = mempty -- never use, shouldn't exist - configUseResponseFiles = mempty - configAllowDependingOnPrivateLibs = Flag $ not $ libraryVisibilitySupported pkgConfigCompiler - -setupHsConfigureArgs :: ElaboratedConfiguredPackage - -> [String] -setupHsConfigureArgs (ElaboratedConfiguredPackage { elabPkgOrComp = ElabPackage _ }) = [] -setupHsConfigureArgs elab@(ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent comp }) = - [showComponentTarget (packageId elab) (ComponentTarget cname WholeComponent)] - where - cname = fromMaybe (error "setupHsConfigureArgs: trying to configure setup") - (compComponentName comp) - -setupHsBuildFlags :: ElaboratedConfiguredPackage - -> ElaboratedSharedConfig - -> Verbosity - -> FilePath - -> Cabal.BuildFlags -setupHsBuildFlags _ _ verbosity builddir = - Cabal.BuildFlags { - buildProgramPaths = mempty, --unused, set at configure time - buildProgramArgs = mempty, --unused, set at configure time - buildVerbosity = toFlag verbosity, - buildDistPref = toFlag builddir, - buildNumJobs = mempty, --TODO: [nice to have] sometimes want to use toFlag (Just numBuildJobs), - buildArgs = mempty, -- unused, passed via args not flags - buildCabalFilePath= mempty - } - - -setupHsBuildArgs :: ElaboratedConfiguredPackage -> [String] -setupHsBuildArgs elab@(ElaboratedConfiguredPackage { elabPkgOrComp = ElabPackage _ }) - -- Fix for #3335, don't pass build arguments if it's not supported - | elabSetupScriptCliVersion elab >= mkVersion [1,17] - = map (showComponentTarget (packageId elab)) (elabBuildTargets elab) - | otherwise - = [] -setupHsBuildArgs (ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent _ }) - = [] - - -setupHsTestFlags :: ElaboratedConfiguredPackage - -> ElaboratedSharedConfig - -> Verbosity - -> FilePath - -> Cabal.TestFlags -setupHsTestFlags (ElaboratedConfiguredPackage{..}) _ verbosity builddir = Cabal.TestFlags - { testDistPref = toFlag builddir - , testVerbosity = toFlag verbosity - , testMachineLog = maybe mempty toFlag elabTestMachineLog - , testHumanLog = maybe mempty toFlag elabTestHumanLog - , testShowDetails = maybe (Flag Cabal.Always) toFlag elabTestShowDetails - , testKeepTix = toFlag elabTestKeepTix - , testWrapper = maybe mempty toFlag elabTestWrapper - , testFailWhenNoTestSuites = toFlag elabTestFailWhenNoTestSuites - , testOptions = elabTestTestOptions - } - -setupHsTestArgs :: ElaboratedConfiguredPackage -> [String] --- TODO: Does the issue #3335 affects test as well -setupHsTestArgs elab = - mapMaybe (showTestComponentTarget (packageId elab)) (elabTestTargets elab) - - -setupHsBenchFlags :: ElaboratedConfiguredPackage - -> ElaboratedSharedConfig - -> Verbosity - -> FilePath - -> Cabal.BenchmarkFlags -setupHsBenchFlags (ElaboratedConfiguredPackage{..}) _ verbosity builddir = Cabal.BenchmarkFlags - { benchmarkDistPref = toFlag builddir - , benchmarkVerbosity = toFlag verbosity - , benchmarkOptions = elabBenchmarkOptions - } - -setupHsBenchArgs :: ElaboratedConfiguredPackage -> [String] -setupHsBenchArgs elab = - mapMaybe (showBenchComponentTarget (packageId elab)) (elabBenchTargets elab) - - -setupHsReplFlags :: ElaboratedConfiguredPackage - -> ElaboratedSharedConfig - -> Verbosity - -> FilePath - -> Cabal.ReplFlags -setupHsReplFlags _ sharedConfig verbosity builddir = - Cabal.ReplFlags { - replProgramPaths = mempty, --unused, set at configure time - replProgramArgs = mempty, --unused, set at configure time - replVerbosity = toFlag verbosity, - replDistPref = toFlag builddir, - replReload = mempty, --only used as callback from repl - replReplOptions = pkgConfigReplOptions sharedConfig --runtime override for repl flags - } - - -setupHsReplArgs :: ElaboratedConfiguredPackage -> [String] -setupHsReplArgs elab = - maybe [] (\t -> [showComponentTarget (packageId elab) t]) (elabReplTarget elab) - --TODO: should be able to give multiple modules in one component - - -setupHsCopyFlags :: ElaboratedConfiguredPackage - -> ElaboratedSharedConfig - -> Verbosity - -> FilePath - -> FilePath - -> Cabal.CopyFlags -setupHsCopyFlags _ _ verbosity builddir destdir = - Cabal.CopyFlags { - copyArgs = [], -- TODO: could use this to only copy what we enabled - copyDest = toFlag (InstallDirs.CopyTo destdir), - copyDistPref = toFlag builddir, - copyVerbosity = toFlag verbosity, - copyCabalFilePath = mempty - } - -setupHsRegisterFlags :: ElaboratedConfiguredPackage - -> ElaboratedSharedConfig - -> Verbosity - -> FilePath - -> FilePath - -> Cabal.RegisterFlags -setupHsRegisterFlags ElaboratedConfiguredPackage{..} _ - verbosity builddir pkgConfFile = - Cabal.RegisterFlags { - regPackageDB = mempty, -- misfeature - regGenScript = mempty, -- never use - regGenPkgConf = toFlag (Just pkgConfFile), - regInPlace = case elabBuildStyle of - BuildInplaceOnly -> toFlag True - _ -> toFlag False, - regPrintId = mempty, -- never use - regDistPref = toFlag builddir, - regArgs = [], - regVerbosity = toFlag verbosity, - regCabalFilePath = mempty - } - -setupHsHaddockFlags :: ElaboratedConfiguredPackage - -> ElaboratedSharedConfig - -> Verbosity - -> FilePath - -> Cabal.HaddockFlags -setupHsHaddockFlags (ElaboratedConfiguredPackage{..}) _ verbosity builddir = - Cabal.HaddockFlags { - haddockProgramPaths = mempty, --unused, set at configure time - haddockProgramArgs = mempty, --unused, set at configure time - haddockHoogle = toFlag elabHaddockHoogle, - haddockHtml = toFlag elabHaddockHtml, - haddockHtmlLocation = maybe mempty toFlag elabHaddockHtmlLocation, - haddockForHackage = toFlag elabHaddockForHackage, - haddockForeignLibs = toFlag elabHaddockForeignLibs, - haddockExecutables = toFlag elabHaddockExecutables, - haddockTestSuites = toFlag elabHaddockTestSuites, - haddockBenchmarks = toFlag elabHaddockBenchmarks, - haddockInternal = toFlag elabHaddockInternal, - haddockCss = maybe mempty toFlag elabHaddockCss, - haddockLinkedSource = toFlag elabHaddockLinkedSource, - haddockQuickJump = toFlag elabHaddockQuickJump, - haddockHscolourCss = maybe mempty toFlag elabHaddockHscolourCss, - haddockContents = maybe mempty toFlag elabHaddockContents, - haddockDistPref = toFlag builddir, - haddockKeepTempFiles = mempty, --TODO: from build settings - haddockVerbosity = toFlag verbosity, - haddockCabalFilePath = mempty, - haddockArgs = mempty - } - -setupHsHaddockArgs :: ElaboratedConfiguredPackage -> [String] --- TODO: Does the issue #3335 affects test as well -setupHsHaddockArgs elab = - map (showComponentTarget (packageId elab)) (elabHaddockTargets elab) - -{- -setupHsTestFlags :: ElaboratedConfiguredPackage - -> ElaboratedSharedConfig - -> Verbosity - -> FilePath - -> Cabal.TestFlags -setupHsTestFlags _ _ verbosity builddir = - Cabal.TestFlags { - } --} - ------------------------------------------------------------------------------- --- * Sharing installed packages ------------------------------------------------------------------------------- - --- --- Nix style store management for tarball packages --- --- So here's our strategy: --- --- We use a per-user nix-style hashed store, but /only/ for tarball packages. --- So that includes packages from hackage repos (and other http and local --- tarballs). For packages in local directories we do not register them into --- the shared store by default, we just build them locally inplace. --- --- The reason we do it like this is that it's easy to make stable hashes for --- tarball packages, and these packages benefit most from sharing. By contrast --- unpacked dir packages are harder to hash and they tend to change more --- frequently so there's less benefit to sharing them. --- --- When using the nix store approach we have to run the solver *without* --- looking at the packages installed in the store, just at the source packages --- (plus core\/global installed packages). Then we do a post-processing pass --- to replace configured packages in the plan with pre-existing ones, where --- possible. Where possible of course means where the nix-style package hash --- equals one that's already in the store. --- --- One extra wrinkle is that unless we know package tarball hashes upfront, we --- will have to download the tarballs to find their hashes. So we have two --- options: delay replacing source with pre-existing installed packages until --- the point during the execution of the install plan where we have the --- tarball, or try to do as much up-front as possible and then check again --- during plan execution. The former isn't great because we would end up --- telling users we're going to re-install loads of packages when in fact we --- would just share them. It'd be better to give as accurate a prediction as --- we can. The latter is better for users, but we do still have to check --- during plan execution because it's important that we don't replace existing --- installed packages even if they have the same package hash, because we --- don't guarantee ABI stability. - --- TODO: [required eventually] for safety of concurrent installs, we must make sure we register but --- not replace installed packages with ghc-pkg. - -packageHashInputs :: ElaboratedSharedConfig - -> ElaboratedConfiguredPackage - -> PackageHashInputs -packageHashInputs - pkgshared - elab@(ElaboratedConfiguredPackage { - elabPkgSourceHash = Just srchash - }) = - PackageHashInputs { - pkgHashPkgId = packageId elab, - pkgHashComponent = - case elabPkgOrComp elab of - ElabPackage _ -> Nothing - ElabComponent comp -> Just (compSolverName comp), - 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 (compLibDependencies comp - ++ compExeDependencies comp)), - pkgHashOtherConfig = packageHashConfigInputs pkgshared elab - } - where - -- Obviously the main deps are relevant - relevantDeps CD.ComponentLib = True - relevantDeps (CD.ComponentSubLib _) = True - relevantDeps (CD.ComponentFLib _) = True - relevantDeps (CD.ComponentExe _) = True - -- Setup deps can affect the Setup.hs behaviour and thus what is built - relevantDeps CD.ComponentSetup = True - -- However testsuites and benchmarks do not get installed and should not - -- affect the result, so we do not include them. - relevantDeps (CD.ComponentTest _) = False - relevantDeps (CD.ComponentBench _) = False - -packageHashInputs _ pkg = - error $ "packageHashInputs: only for packages with source hashes. " - ++ prettyShow (packageId pkg) - -packageHashConfigInputs :: ElaboratedSharedConfig - -> ElaboratedConfiguredPackage - -> PackageHashConfigInputs -packageHashConfigInputs shared@ElaboratedSharedConfig{..} pkg = - PackageHashConfigInputs { - pkgHashCompilerId = compilerId pkgConfigCompiler, - pkgHashPlatform = pkgConfigPlatform, - pkgHashFlagAssignment = elabFlagAssignment, - pkgHashConfigureScriptArgs = elabConfigureScriptArgs, - pkgHashVanillaLib = elabVanillaLib, - pkgHashSharedLib = elabSharedLib, - pkgHashDynExe = elabDynExe, - pkgHashFullyStaticExe = elabFullyStaticExe, - pkgHashGHCiLib = elabGHCiLib, - pkgHashProfLib = elabProfLib, - pkgHashProfExe = elabProfExe, - pkgHashProfLibDetail = elabProfLibDetail, - pkgHashProfExeDetail = elabProfExeDetail, - pkgHashCoverage = elabCoverage, - pkgHashOptimization = elabOptimization, - pkgHashSplitSections = elabSplitSections, - pkgHashSplitObjs = elabSplitObjs, - pkgHashStripLibs = elabStripLibs, - pkgHashStripExes = elabStripExes, - pkgHashDebugInfo = elabDebugInfo, - pkgHashProgramArgs = elabProgramArgs, - pkgHashExtraLibDirs = elabExtraLibDirs, - pkgHashExtraFrameworkDirs = elabExtraFrameworkDirs, - pkgHashExtraIncludeDirs = elabExtraIncludeDirs, - pkgHashProgPrefix = elabProgPrefix, - pkgHashProgSuffix = elabProgSuffix, - - pkgHashDocumentation = elabBuildHaddocks, - pkgHashHaddockHoogle = elabHaddockHoogle, - pkgHashHaddockHtml = elabHaddockHtml, - pkgHashHaddockHtmlLocation = elabHaddockHtmlLocation, - pkgHashHaddockForeignLibs = elabHaddockForeignLibs, - pkgHashHaddockExecutables = elabHaddockExecutables, - pkgHashHaddockTestSuites = elabHaddockTestSuites, - pkgHashHaddockBenchmarks = elabHaddockBenchmarks, - pkgHashHaddockInternal = elabHaddockInternal, - pkgHashHaddockCss = elabHaddockCss, - pkgHashHaddockLinkedSource = elabHaddockLinkedSource, - pkgHashHaddockQuickJump = elabHaddockQuickJump, - pkgHashHaddockContents = elabHaddockContents - } - where - ElaboratedConfiguredPackage{..} = normaliseConfiguredPackage shared pkg - --- | 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 - - --TODO: decide what to do if we encounter broken installed packages, - -- since overwriting is never safe. - - --- Path construction ------- - --- | The path to the directory that contains a specific executable. --- NB: For inplace NOT InstallPaths.bindir installDirs; for an --- inplace build those values are utter nonsense. So we --- have to guess where the directory is going to be. --- Fortunately this is "stable" part of Cabal API. --- But the way we get the build directory is A HORRIBLE --- HACK. -binDirectoryFor - :: DistDirLayout - -> ElaboratedSharedConfig - -> ElaboratedConfiguredPackage - -> FilePath - -> FilePath -binDirectoryFor layout config package exe = case elabBuildStyle package of - BuildAndInstall -> installedBinDirectory package - BuildInplaceOnly -> inplaceBinRoot layout config package exe - --- package has been built and installed. -installedBinDirectory :: ElaboratedConfiguredPackage -> FilePath -installedBinDirectory = InstallDirs.bindir . elabInstallDirs - --- | The path to the @build@ directory for an inplace build. -inplaceBinRoot - :: DistDirLayout - -> ElaboratedSharedConfig - -> ElaboratedConfiguredPackage - -> FilePath -inplaceBinRoot layout config package - = distBuildDirectory layout (elabDistDirParams config package) - "build" diff --git a/cabal/cabal-install/Distribution/Client/ProjectPlanning/Types.hs b/cabal/cabal-install/Distribution/Client/ProjectPlanning/Types.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/ProjectPlanning/Types.hs +++ /dev/null @@ -1,840 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE TypeFamilies #-} - --- | Types used while planning how to build everything in a project. --- --- Primarily this is the 'ElaboratedInstallPlan'. --- -module Distribution.Client.ProjectPlanning.Types ( - SolverInstallPlan, - - -- * Elaborated install plan types - ElaboratedInstallPlan, - normaliseConfiguredPackage, - ElaboratedConfiguredPackage(..), - - elabDistDirParams, - elabExeDependencyPaths, - elabLibDependencies, - elabOrderLibDependencies, - elabExeDependencies, - elabOrderExeDependencies, - elabSetupDependencies, - elabPkgConfigDependencies, - elabInplaceDependencyBuildCacheFiles, - elabRequiresRegistration, - dataDirsEnvironmentForPlan, - - elabPlanPackageName, - elabConfiguredName, - elabComponentName, - - ElaboratedPackageOrComponent(..), - ElaboratedComponent(..), - ElaboratedPackage(..), - pkgOrderDependencies, - ElaboratedPlanPackage, - ElaboratedSharedConfig(..), - ElaboratedReadyPackage, - BuildStyle(..), - CabalFileText, - - -- * Build targets - ComponentTarget(..), - showComponentTarget, - showTestComponentTarget, - showBenchComponentTarget, - SubComponentTarget(..), - - isSubLibComponentTarget, - isForeignLibComponentTarget, - isExeComponentTarget, - isTestComponentTarget, - isBenchComponentTarget, - - componentOptionalStanza, - - -- * Setup script - SetupScriptStyle(..), - ) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Client.TargetSelector - ( SubComponentTarget(..) ) -import Distribution.Client.PackageHash - -import Distribution.Client.Types -import qualified Distribution.Client.InstallPlan as InstallPlan -import Distribution.Client.InstallPlan - ( GenericInstallPlan, GenericPlanPackage(..) ) -import Distribution.Client.SolverInstallPlan - ( SolverInstallPlan ) -import Distribution.Client.DistDirLayout - -import Distribution.Backpack -import Distribution.Backpack.ModuleShape - -import Distribution.Verbosity (normal) -import Distribution.Types.ComponentRequestedSpec -import Distribution.Types.PkgconfigVersion -import Distribution.Types.PackageDescription (PackageDescription(..)) -import Distribution.Package -import Distribution.System -import qualified Distribution.PackageDescription as Cabal -import Distribution.InstalledPackageInfo (InstalledPackageInfo) -import Distribution.Simple.Compiler -import Distribution.Simple.Build.PathsModule (pkgPathEnvVar) -import qualified Distribution.Simple.BuildTarget as Cabal -import Distribution.Simple.Program -import Distribution.ModuleName (ModuleName) -import Distribution.Simple.LocalBuildInfo - ( ComponentName(..), LibraryName(..) ) -import qualified Distribution.Simple.InstallDirs as InstallDirs -import Distribution.Simple.InstallDirs (PathTemplate) -import Distribution.Simple.Setup (HaddockTarget, TestShowDetails) -import Distribution.Version - -import qualified Distribution.Solver.Types.ComponentDeps as CD -import Distribution.Solver.Types.ComponentDeps (ComponentDeps) -import Distribution.Solver.Types.OptionalStanza -import Distribution.Compat.Graph (IsNode(..)) -import Distribution.Simple.Utils (ordNub) - -import qualified Data.Map as Map -import qualified Data.ByteString.Lazy as LBS -import qualified Data.Monoid as Mon -import System.FilePath (()) - - --- | The combination of an elaborated install plan plus a --- 'ElaboratedSharedConfig' contains all the details necessary to be able --- to execute the plan without having to make further policy decisions. --- --- It does not include dynamic elements such as resources (such as http --- connections). --- -type ElaboratedInstallPlan - = GenericInstallPlan InstalledPackageInfo - ElaboratedConfiguredPackage - -type ElaboratedPlanPackage - = GenericPlanPackage InstalledPackageInfo - ElaboratedConfiguredPackage - --- | User-friendly display string for an 'ElaboratedPlanPackage'. -elabPlanPackageName :: Verbosity -> ElaboratedPlanPackage -> String -elabPlanPackageName verbosity (PreExisting ipkg) - | verbosity <= normal = prettyShow (packageName ipkg) - | otherwise = prettyShow (installedUnitId ipkg) -elabPlanPackageName verbosity (Configured elab) - = elabConfiguredName verbosity elab -elabPlanPackageName verbosity (Installed elab) - = elabConfiguredName verbosity elab - ---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 - -- | The programs that the compiler configured (e.g. for GHC, the progs - -- ghc & ghc-pkg). Once constructed, only the 'configuredPrograms' are - -- used. - pkgConfigCompilerProgs :: ProgramDb, - pkgConfigReplOptions :: [String] - } - deriving (Show, Generic, Typeable) - --TODO: [code cleanup] no Eq instance - -instance Binary ElaboratedSharedConfig -instance Structured ElaboratedSharedConfig - -data ElaboratedConfiguredPackage - = ElaboratedConfiguredPackage { - -- | The 'UnitId' which uniquely identifies this item in a build plan - elabUnitId :: UnitId, - - elabComponentId :: ComponentId, - elabInstantiatedWith :: Map ModuleName Module, - elabLinkedInstantiatedWith :: Map ModuleName OpenModule, - - -- | This is true if this is an indefinite package, or this is a - -- package with no signatures. (Notably, it's not true for instantiated - -- packages.) The motivation for this is if you ask to build - -- @foo-indef@, this probably means that you want to typecheck - -- it, NOT that you want to rebuild all of the various - -- instantiations of it. - elabIsCanonical :: Bool, - - -- | The 'PackageId' of the originating package - elabPkgSourceId :: PackageId, - - -- | Shape of the package/component, for Backpack. - elabModuleShape :: ModuleShape, - - -- | A total flag assignment for the package. - -- TODO: Actually this can be per-component if we drop - -- all flags that don't affect a component. - elabFlagAssignment :: Cabal.FlagAssignment, - - -- | The original default flag assignment, used only for reporting. - elabFlagDefaults :: Cabal.FlagAssignment, - - elabPkgDescription :: Cabal.PackageDescription, - - -- | 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. - elabPkgSourceLocation :: PackageLocation (Maybe FilePath), - - -- | The hash of the source, e.g. the tarball. We don't have this for - -- local source dir packages. - elabPkgSourceHash :: Maybe PackageSourceHash, - - -- | Is this package one of the ones specified by location in the - -- project file? (As opposed to a dependency, or a named package pulled - -- in) - elabLocalToProject :: Bool, - - -- | Are we going to build and install this package to the store, or are - -- we going to build it and register it locally. - elabBuildStyle :: BuildStyle, - - -- | Another way of phrasing 'pkgStanzasAvailable'. - elabEnabledSpec :: ComponentRequestedSpec, - - -- | Which optional stanzas (ie testsuites, benchmarks) can be built. - -- This means the solver produced a plan that has them available. - -- This doesn't necessary mean we build them by default. - elabStanzasAvailable :: Set OptionalStanza, - - -- | Which optional stanzas the user explicitly asked to enable or - -- 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.) - elabStanzasRequested :: Map OptionalStanza Bool, - - elabSetupPackageDBStack :: PackageDBStack, - elabBuildPackageDBStack :: PackageDBStack, - elabRegisterPackageDBStack :: PackageDBStack, - - elabPkgDescriptionOverride :: Maybe CabalFileText, - - -- TODO: make per-component variants of these flags - elabVanillaLib :: Bool, - elabSharedLib :: Bool, - elabStaticLib :: Bool, - elabDynExe :: Bool, - elabFullyStaticExe :: Bool, - elabGHCiLib :: Bool, - elabProfLib :: Bool, - elabProfExe :: Bool, - elabProfLibDetail :: ProfDetailLevel, - elabProfExeDetail :: ProfDetailLevel, - elabCoverage :: Bool, - elabOptimization :: OptimisationLevel, - elabSplitObjs :: Bool, - elabSplitSections :: Bool, - elabStripLibs :: Bool, - elabStripExes :: Bool, - elabDebugInfo :: DebugInfoLevel, - - elabProgramPaths :: Map String FilePath, - elabProgramArgs :: Map String [String], - elabProgramPathExtra :: [FilePath], - elabConfigureScriptArgs :: [String], - elabExtraLibDirs :: [FilePath], - elabExtraFrameworkDirs :: [FilePath], - elabExtraIncludeDirs :: [FilePath], - elabProgPrefix :: Maybe PathTemplate, - elabProgSuffix :: Maybe PathTemplate, - - elabInstallDirs :: InstallDirs.InstallDirs FilePath, - - elabHaddockHoogle :: Bool, - elabHaddockHtml :: Bool, - elabHaddockHtmlLocation :: Maybe String, - elabHaddockForeignLibs :: Bool, - elabHaddockForHackage :: HaddockTarget, - elabHaddockExecutables :: Bool, - elabHaddockTestSuites :: Bool, - elabHaddockBenchmarks :: Bool, - elabHaddockInternal :: Bool, - elabHaddockCss :: Maybe FilePath, - elabHaddockLinkedSource :: Bool, - elabHaddockQuickJump :: Bool, - elabHaddockHscolourCss :: Maybe FilePath, - elabHaddockContents :: Maybe PathTemplate, - - elabTestMachineLog :: Maybe PathTemplate, - elabTestHumanLog :: Maybe PathTemplate, - elabTestShowDetails :: Maybe TestShowDetails, - elabTestKeepTix :: Bool, - elabTestWrapper :: Maybe FilePath, - elabTestFailWhenNoTestSuites :: Bool, - elabTestTestOptions :: [PathTemplate], - - elabBenchmarkOptions :: [PathTemplate], - - -- Setup.hs related things: - - -- | One of four modes for how we build and interact with the Setup.hs - -- script, based on whether it's a build-type Custom, with or without - -- explicit deps and the cabal spec version the .cabal file needs. - elabSetupScriptStyle :: SetupScriptStyle, - - -- | The version of the Cabal command line interface that we are using - -- for this package. This is typically the version of the Cabal lib - -- that the Setup.hs is built against. - -- - -- TODO: We might want to turn this into a enum, - -- yet different enum than 'CabalSpecVersion'. - elabSetupScriptCliVersion :: Version, - - -- Build time related: - elabConfigureTargets :: [ComponentTarget], - elabBuildTargets :: [ComponentTarget], - elabTestTargets :: [ComponentTarget], - elabBenchTargets :: [ComponentTarget], - elabReplTarget :: Maybe ComponentTarget, - elabHaddockTargets :: [ComponentTarget], - - elabBuildHaddocks :: Bool, - - --pkgSourceDir ? -- currently passed in later because they can use temp locations - --pkgBuildDir ? -- but could in principle still have it here, with optional instr to use temp loc - - -- | Component/package specific information - elabPkgOrComp :: ElaboratedPackageOrComponent - } - deriving (Eq, Show, Generic, Typeable) - -normaliseConfiguredPackage :: ElaboratedSharedConfig - -> ElaboratedConfiguredPackage - -> ElaboratedConfiguredPackage -normaliseConfiguredPackage ElaboratedSharedConfig{pkgConfigCompilerProgs} pkg = - pkg { elabProgramArgs = Map.mapMaybeWithKey lookupFilter (elabProgramArgs pkg) } - where - knownProgramDb = addKnownPrograms builtinPrograms pkgConfigCompilerProgs - - pkgDesc :: PackageDescription - pkgDesc = elabPkgDescription pkg - - removeEmpty :: [String] -> Maybe [String] - removeEmpty [] = Nothing - removeEmpty xs = Just xs - - lookupFilter :: String -> [String] -> Maybe [String] - lookupFilter n args = removeEmpty $ case lookupKnownProgram n knownProgramDb of - Just p -> programNormaliseArgs p (getVersion p) pkgDesc args - Nothing -> args - - getVersion :: Program -> Maybe Version - getVersion p = lookupProgram p knownProgramDb >>= programVersion - --- | The package/component contains/is a library and so must be registered -elabRequiresRegistration :: ElaboratedConfiguredPackage -> Bool -elabRequiresRegistration elab = - case elabPkgOrComp elab of - ElabComponent comp -> - case compComponentName comp of - Just cn -> is_lib cn && build_target - _ -> False - ElabPackage pkg -> - -- Tricky! Not only do we have to test if the user selected - -- a library as a build target, we also have to test if - -- the library was TRANSITIVELY depended upon, since we will - -- also require a register in this case. - -- - -- NB: It would have been far nicer to just unconditionally - -- register in all cases, but some Custom Setups will fall - -- over if you try to do that, ESPECIALLY if there actually is - -- a library but they hadn't built it. - -- - -- However, as the case of `cpphs-1.20.8` has shown in - -- #5379, in cases when a monolithic package gets - -- installed due to its executable components - -- (i.e. exe:cpphs) into the store we *have* to register - -- if there's a buildable public library (i.e. lib:cpphs) - -- that was built and installed into the same store folder - -- as otherwise this will cause build failures once a - -- target actually depends on lib:cpphs. - build_target || (elabBuildStyle elab == BuildAndInstall && - Cabal.hasPublicLib (elabPkgDescription elab)) - -- the next sub-condition below is currently redundant - -- (see discussion in #5604 for more details), but it's - -- being kept intentionally here as a safeguard because if - -- internal libraries ever start working with - -- non-per-component builds this condition won't be - -- redundant anymore. - || any (depends_on_lib pkg) (elabBuildTargets elab) - where - depends_on_lib pkg (ComponentTarget cn _) = - not (null (CD.select (== CD.componentNameToComponent cn) - (pkgDependsOnSelfLib pkg))) - build_target = - if not (null (elabBuildTargets elab)) - then any is_lib_target (elabBuildTargets elab) - -- Empty build targets mean we build /everything/; - -- that means we have to look more carefully to see - -- if there is anything to register - else Cabal.hasLibs (elabPkgDescription elab) - -- NB: this means we DO NOT reregister if you just built a - -- single file - is_lib_target (ComponentTarget cn WholeComponent) = is_lib cn - is_lib_target _ = False - is_lib (CLibName _) = True - is_lib _ = False - --- | Construct the environment needed for the data files to work. --- This consists of a separate @*_datadir@ variable for each --- inplace package in the plan. -dataDirsEnvironmentForPlan :: DistDirLayout - -> ElaboratedInstallPlan - -> [(String, Maybe FilePath)] -dataDirsEnvironmentForPlan distDirLayout = catMaybes - . fmap (InstallPlan.foldPlanPackage - (const Nothing) - (dataDirEnvVarForPackage distDirLayout)) - . InstallPlan.toList - --- | Construct an environment variable that points --- the package's datadir to its correct location. --- This might be: --- * 'Just' the package's source directory plus the data subdirectory --- for inplace packages. --- * 'Nothing' for packages installed in the store (the path was --- already included in the package at install/build time). -dataDirEnvVarForPackage :: DistDirLayout - -> ElaboratedConfiguredPackage - -> Maybe (String, Maybe FilePath) -dataDirEnvVarForPackage distDirLayout pkg = - case elabBuildStyle pkg - of BuildAndInstall -> Nothing - BuildInplaceOnly -> Just - ( pkgPathEnvVar (elabPkgDescription pkg) "datadir" - , Just $ srcPath (elabPkgSourceLocation pkg) - dataDir (elabPkgDescription pkg)) - where - srcPath (LocalUnpackedPackage path) = path - srcPath (LocalTarballPackage _path) = unpackedPath - srcPath (RemoteTarballPackage _uri _localTar) = unpackedPath - srcPath (RepoTarballPackage _repo _packageId _localTar) = unpackedPath - srcPath (RemoteSourceRepoPackage _sourceRepo (Just localCheckout)) = localCheckout - -- TODO: see https://github.com/haskell/cabal/wiki/Potential-Refactors#unresolvedpkgloc - srcPath (RemoteSourceRepoPackage _sourceRepo Nothing) = error - "calling dataDirEnvVarForPackage on a not-downloaded repo is an error" - unpackedPath = - distUnpackedSrcDirectory distDirLayout $ elabPkgSourceId pkg - -instance Package ElaboratedConfiguredPackage where - packageId = elabPkgSourceId - -instance HasConfiguredId ElaboratedConfiguredPackage where - configuredId elab = - ConfiguredId (packageId elab) (elabComponentName elab) (elabComponentId elab) - -instance HasUnitId ElaboratedConfiguredPackage where - installedUnitId = elabUnitId - -instance IsNode ElaboratedConfiguredPackage where - type Key ElaboratedConfiguredPackage = UnitId - nodeKey = elabUnitId - nodeNeighbors = elabOrderDependencies - -instance Binary ElaboratedConfiguredPackage -instance Structured ElaboratedConfiguredPackage - -data ElaboratedPackageOrComponent - = ElabPackage ElaboratedPackage - | ElabComponent ElaboratedComponent - deriving (Eq, Show, Generic) - -instance Binary ElaboratedPackageOrComponent -instance Structured ElaboratedPackageOrComponent - -elabComponentName :: ElaboratedConfiguredPackage -> Maybe ComponentName -elabComponentName elab = - case elabPkgOrComp elab of - ElabPackage _ -> Just $ CLibName LMainLibName -- there could be more, but default this - ElabComponent comp -> compComponentName comp - --- | A user-friendly descriptor for an 'ElaboratedConfiguredPackage'. -elabConfiguredName :: Verbosity -> ElaboratedConfiguredPackage -> String -elabConfiguredName verbosity elab - | verbosity <= normal - = (case elabPkgOrComp elab of - ElabPackage _ -> "" - ElabComponent comp -> - case compComponentName comp of - Nothing -> "setup from " - Just (CLibName LMainLibName) -> "" - Just cname -> prettyShow cname ++ " from ") - ++ prettyShow (packageId elab) - | otherwise - = prettyShow (elabUnitId elab) - -elabDistDirParams :: ElaboratedSharedConfig -> ElaboratedConfiguredPackage -> DistDirParams -elabDistDirParams shared elab = DistDirParams { - 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, - distParamOptimization = elabOptimization elab - } - --- | The full set of dependencies which dictate what order we --- need to build things in the install plan: "order dependencies" --- balls everything together. This is mostly only useful for --- ordering; if you are, for example, trying to compute what --- @--dependency@ flags to pass to a Setup script, you need to --- use 'elabLibDependencies'. This method is the same as --- 'nodeNeighbors'. --- --- NB: this method DOES include setup deps. -elabOrderDependencies :: ElaboratedConfiguredPackage -> [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 = - case elabPkgOrComp elab of - ElabPackage pkg -> map (newSimpleUnitId . confInstId) $ - ordNub $ CD.flatDeps (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@. -elabLibDependencies :: ElaboratedConfiguredPackage -> [ConfiguredId] -elabLibDependencies elab = - case elabPkgOrComp elab of - ElabPackage pkg -> ordNub (CD.nonSetupDeps (pkgLibDependencies pkg)) - ElabComponent comp -> compLibDependencies comp - --- | Like 'elabOrderDependencies', but only returns dependencies on --- executables. (This coincides with 'elabExeDependencies'.) -elabOrderExeDependencies :: ElaboratedConfiguredPackage -> [UnitId] -elabOrderExeDependencies = - map newSimpleUnitId . elabExeDependencies - --- | 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 - --- | This returns the paths of all the executables we depend on; we --- must add these paths to PATH before invoking the setup script. --- (This is usually what you want, not 'elabExeDependencies', if you --- actually want to build something.) -elabExeDependencyPaths :: ElaboratedConfiguredPackage -> [FilePath] -elabExeDependencyPaths elab = - case elabPkgOrComp elab of - ElabPackage pkg -> 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] -elabSetupDependencies 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 - ElabComponent _ -> [] - -elabPkgConfigDependencies :: ElaboratedConfiguredPackage -> [(PkgconfigName, Maybe PkgconfigVersion)] -elabPkgConfigDependencies ElaboratedConfiguredPackage { elabPkgOrComp = ElabPackage pkg } - = pkgPkgConfigDependencies pkg -elabPkgConfigDependencies ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent comp } - = compPkgConfigDependencies comp - --- | The cache files of all our inplace dependencies which, --- when updated, require us to rebuild. See #4202 for --- more details. Essentially, this is a list of filepaths --- that, if our dependencies get rebuilt, will themselves --- get updated. --- --- Note: the hash of these cache files gets built into --- the build cache ourselves, which means that we end --- up tracking transitive dependencies! --- --- Note: This tracks the "build" cache file, but not --- "registration" or "config" cache files. Why not? --- Arguably we should... --- --- Note: This is a bit of a hack, because it is not really --- the hashes of the SOURCES of our (transitive) dependencies --- that we should use to decide whether or not to rebuild, --- but the output BUILD PRODUCTS. The strategy we use --- here will never work if we want to implement unchanging --- rebuilds. -elabInplaceDependencyBuildCacheFiles - :: DistDirLayout - -> ElaboratedSharedConfig - -> ElaboratedInstallPlan - -> ElaboratedConfiguredPackage - -> [FilePath] -elabInplaceDependencyBuildCacheFiles layout sconf plan root_elab = - go =<< InstallPlan.directDeps plan (nodeKey root_elab) - where - go = InstallPlan.foldPlanPackage (const []) $ \elab -> do - guard (elabBuildStyle elab == BuildInplaceOnly) - return $ distPackageCacheFile layout (elabDistDirParams sconf elab) "build" - --- | Some extra metadata associated with an --- 'ElaboratedConfiguredPackage' which indicates that the "package" --- in question is actually a single component to be built. Arguably --- it would be clearer if there were an ADT which branched into --- package work items and component work items, but I've structured --- it this way to minimize change to the existing code (which I --- don't feel qualified to rewrite.) -data ElaboratedComponent - = ElaboratedComponent { - -- | The name of the component to be built according to the solver - compSolverName :: CD.Component, - -- | The name of the component to be built. Nothing if - -- it's a setup dep. - compComponentName :: Maybe ComponentName, - -- | The *external* library dependencies of this component. We - -- pass this to the configure script. - compLibDependencies :: [ConfiguredId], - -- | In a component prior to instantiation, this list specifies - -- the 'OpenUnitId's which, after instantiation, are the - -- actual dependencies of this package. Note that this does - -- NOT include signature packages, which do not turn into real - -- ordering dependencies when we instantiate. This is intended to be - -- a purely temporary field, to carry some information to the - -- instantiation phase. It's more precise than - -- 'compLibDependencies', and also stores information about internal - -- dependencies. - compLinkedLibDependencies :: [OpenUnitId], - -- | The executable dependencies of this component (including - -- internal executables). - compExeDependencies :: [ConfiguredId], - -- | The @pkg-config@ dependencies of the component - compPkgConfigDependencies :: [(PkgconfigName, Maybe PkgconfigVersion)], - -- | The paths all our executable dependencies will be installed - -- to once they are installed. - compExeDependencyPaths :: [(ConfiguredId, FilePath)], - -- | 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 - -- references to definite and indefinite packages; an indefinite - -- UnitId indicates that we must typecheck that indefinite package - -- before we can build this one. - compOrderLibDependencies :: [UnitId] - } - deriving (Eq, Show, Generic) - -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, - - -- | The exact dependencies (on other plan packages) - -- - pkgLibDependencies :: ComponentDeps [ConfiguredId], - - -- | Components which depend (transitively) on an internally - -- defined library. These are used by 'elabRequiresRegistration', - -- to determine if a user-requested build is going to need - -- a library registration - -- - pkgDependsOnSelfLib :: ComponentDeps [()], - - -- | Dependencies on executable packages. - -- - pkgExeDependencies :: ComponentDeps [ConfiguredId], - - -- | Paths where executable dependencies live. - -- - pkgExeDependencyPaths :: ComponentDeps [(ConfiguredId, FilePath)], - - -- | Dependencies on @pkg-config@ packages. - -- NB: this is NOT per-component (although it could be) - -- because Cabal library does not track per-component - -- pkg-config depends; it always does them all at once. - -- - pkgPkgConfigDependencies :: [(PkgconfigName, Maybe PkgconfigVersion)], - - -- | Which optional stanzas (ie testsuites, benchmarks) will actually - -- be enabled during the package configure step. - pkgStanzasEnabled :: Set OptionalStanza - } - deriving (Eq, Show, Generic) - -instance Binary ElaboratedPackage -instance Structured ElaboratedPackage - --- | See 'elabOrderDependencies'. This gives the unflattened version, --- which can be useful in some circumstances. -pkgOrderDependencies :: ElaboratedPackage -> ComponentDeps [UnitId] -pkgOrderDependencies pkg = - fmap (map (newSimpleUnitId . confInstId)) (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 = - -- | The classic approach where the package is built, then the files - -- installed into some location and the result registered in a package db. - -- - -- If the package came from a tarball then it's built in a temp dir and - -- the results discarded. - BuildAndInstall - - -- | The package is built, but the files are not installed anywhere, - -- rather the build dir is kept and the package is registered inplace. - -- - -- Such packages can still subsequently be installed. - -- - -- Typically 'BuildAndInstall' packages will only depend on other - -- 'BuildAndInstall' style packages and not on 'BuildInplaceOnly' ones. - -- - | BuildInplaceOnly - deriving (Eq, Show, Generic) - -instance Binary BuildStyle -instance Structured BuildStyle - -type CabalFileText = LBS.ByteString - -type ElaboratedReadyPackage = GenericReadyPackage ElaboratedConfiguredPackage - - ---------------------------- --- Build targets --- - --- | Specific targets within a package or component to act on e.g. to build, --- haddock or open a repl. --- -data ComponentTarget = ComponentTarget ComponentName SubComponentTarget - deriving (Eq, Ord, Show, Generic) - -instance Binary ComponentTarget -instance Structured ComponentTarget - --- | Unambiguously render a 'ComponentTarget', e.g., to pass --- to a Cabal Setup script. -showComponentTarget :: PackageId -> ComponentTarget -> String -showComponentTarget pkgid = - Cabal.showBuildTarget pkgid . toBuildTarget - where - toBuildTarget :: ComponentTarget -> Cabal.BuildTarget - toBuildTarget (ComponentTarget cname subtarget) = - case subtarget of - WholeComponent -> Cabal.BuildTargetComponent cname - ModuleTarget mname -> Cabal.BuildTargetModule cname mname - FileTarget fname -> Cabal.BuildTargetFile cname fname - -showTestComponentTarget :: PackageId -> ComponentTarget -> Maybe String -showTestComponentTarget _ (ComponentTarget (CTestName n) _) = Just $ prettyShow n -showTestComponentTarget _ _ = Nothing - -isTestComponentTarget :: ComponentTarget -> Bool -isTestComponentTarget (ComponentTarget (CTestName _) _) = True -isTestComponentTarget _ = False - -showBenchComponentTarget :: PackageId -> ComponentTarget -> Maybe String -showBenchComponentTarget _ (ComponentTarget (CBenchName n) _) = Just $ prettyShow n -showBenchComponentTarget _ _ = Nothing - -isBenchComponentTarget :: ComponentTarget -> Bool -isBenchComponentTarget (ComponentTarget (CBenchName _) _) = True -isBenchComponentTarget _ = False - -isForeignLibComponentTarget :: ComponentTarget -> Bool -isForeignLibComponentTarget (ComponentTarget (CFLibName _) _) = True -isForeignLibComponentTarget _ = False - -isExeComponentTarget :: ComponentTarget -> Bool -isExeComponentTarget (ComponentTarget (CExeName _) _ ) = True -isExeComponentTarget _ = False - -isSubLibComponentTarget :: ComponentTarget -> Bool -isSubLibComponentTarget (ComponentTarget (CLibName (LSubLibName _)) _) = True -isSubLibComponentTarget _ = False - -componentOptionalStanza :: CD.Component -> Maybe OptionalStanza -componentOptionalStanza (CD.ComponentTest _) = Just TestStanzas -componentOptionalStanza (CD.ComponentBench _) = Just BenchStanzas -componentOptionalStanza _ = Nothing - ---------------------------- --- Setup.hs script policy --- - --- | There are four major cases for Setup.hs handling: --- --- 1. @build-type@ Custom with a @custom-setup@ section --- 2. @build-type@ Custom without a @custom-setup@ section --- 3. @build-type@ not Custom with @cabal-version > $our-cabal-version@ --- 4. @build-type@ not Custom with @cabal-version <= $our-cabal-version@ --- --- It's also worth noting that packages specifying @cabal-version: >= 1.23@ --- or later that have @build-type@ Custom will always have a @custom-setup@ --- section. Therefore in case 2, the specified @cabal-version@ will always be --- less than 1.23. --- --- In cases 1 and 2 we obviously have to build an external Setup.hs script, --- while in case 4 we can use the internal library API. In case 3 we also have --- to build an external Setup.hs script because the package needs a later --- Cabal lib version than we can support internally. --- -data SetupScriptStyle = SetupCustomExplicitDeps - | SetupCustomImplicitDeps - | SetupNonCustomExternalLib - | SetupNonCustomInternalLib - deriving (Eq, Show, Generic, Typeable) - -instance Binary SetupScriptStyle -instance Structured SetupScriptStyle diff --git a/cabal/cabal-install/Distribution/Client/RebuildMonad.hs b/cabal/cabal-install/Distribution/Client/RebuildMonad.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/RebuildMonad.hs +++ /dev/null @@ -1,310 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, BangPatterns #-} - --- | An abstraction for re-running actions if values or files have changed. --- --- This is not a full-blown make-style incremental build system, it's a bit --- more ad-hoc than that, but it's easier to integrate with existing code. --- --- It's a convenient interface to the "Distribution.Client.FileMonitor" --- functions. --- -module Distribution.Client.RebuildMonad ( - -- * Rebuild monad - Rebuild, - runRebuild, - execRebuild, - askRoot, - - -- * Setting up file monitoring - monitorFiles, - MonitorFilePath, - monitorFile, - monitorFileHashed, - monitorNonExistentFile, - monitorDirectory, - monitorNonExistentDirectory, - monitorDirectoryExistence, - monitorFileOrDirectory, - monitorFileSearchPath, - monitorFileHashedSearchPath, - -- ** Monitoring file globs - monitorFileGlob, - monitorFileGlobExistence, - FilePathGlob(..), - FilePathRoot(..), - FilePathGlobRel(..), - GlobPiece(..), - - -- * Using a file monitor - FileMonitor(..), - newFileMonitor, - rerunIfChanged, - - -- * Utils - delayInitSharedResource, - delayInitSharedResources, - matchFileGlob, - getDirectoryContentsMonitored, - createDirectoryMonitored, - monitorDirectoryStatus, - doesFileExistMonitored, - need, - needIfExists, - findFileWithExtensionMonitored, - findFirstFileMonitored, - findFileMonitored, - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude - -import Distribution.Client.FileMonitor -import Distribution.Client.Glob hiding (matchFileGlob) -import qualified Distribution.Client.Glob as Glob (matchFileGlob) - -import Distribution.Simple.Utils (debug) - -import qualified Data.Map.Strict as Map -import Control.Monad.State as State -import Control.Monad.Reader as Reader -import Control.Concurrent.MVar (MVar, newMVar, modifyMVar) -import System.FilePath -import System.Directory - - --- | A monad layered on top of 'IO' to help with re-running actions when the --- input files and values they depend on change. The crucial operations are --- 'rerunIfChanged' and 'monitorFiles'. --- -newtype Rebuild a = Rebuild (ReaderT FilePath (StateT [MonitorFilePath] IO) a) - deriving (Functor, Applicative, Monad, MonadIO) - --- | Use this wihin the body action of 'rerunIfChanged' to declare that the --- action depends on the given files. This can be based on what the action --- actually did. It is these files that will be checked for changes next --- time 'rerunIfChanged' is called for that 'FileMonitor'. --- --- Relative paths are interpreted as relative to an implicit root, ultimately --- passed in to 'runRebuild'. --- -monitorFiles :: [MonitorFilePath] -> Rebuild () -monitorFiles filespecs = Rebuild (State.modify (filespecs++)) - --- | Run a 'Rebuild' IO action. -unRebuild :: FilePath -> Rebuild a -> IO (a, [MonitorFilePath]) -unRebuild rootDir (Rebuild action) = runStateT (runReaderT action rootDir) [] - --- | Run a 'Rebuild' IO action. -runRebuild :: FilePath -> Rebuild a -> IO a -runRebuild rootDir (Rebuild action) = evalStateT (runReaderT action rootDir) [] - --- | Run a 'Rebuild' IO action. -execRebuild :: FilePath -> Rebuild a -> IO [MonitorFilePath] -execRebuild rootDir (Rebuild action) = execStateT (runReaderT action rootDir) [] - --- | The root that relative paths are interpreted as being relative to. -askRoot :: Rebuild FilePath -askRoot = Rebuild Reader.ask - --- | This captures the standard use pattern for a 'FileMonitor': given a --- monitor, an action and the input value the action depends on, either --- re-run the action to get its output, or if the value and files the action --- depends on have not changed then return a previously cached action result. --- --- The result is still in the 'Rebuild' monad, so these can be nested. --- --- Do not share 'FileMonitor's between different uses of 'rerunIfChanged'. --- -rerunIfChanged :: (Binary a, Structured a, Binary b, Structured b) - => Verbosity - -> FileMonitor a b - -> a - -> Rebuild b - -> Rebuild b -rerunIfChanged verbosity monitor key action = do - rootDir <- askRoot - changed <- liftIO $ checkFileMonitorChanged monitor rootDir key - case changed of - MonitorUnchanged result files -> do - liftIO $ debug verbosity $ "File monitor '" ++ monitorName - ++ "' unchanged." - monitorFiles files - return result - - MonitorChanged reason -> do - liftIO $ debug verbosity $ "File monitor '" ++ monitorName - ++ "' changed: " ++ showReason reason - startTime <- liftIO $ beginUpdateFileMonitor - (result, files) <- liftIO $ unRebuild rootDir action - liftIO $ updateFileMonitor monitor rootDir - (Just startTime) files key result - monitorFiles files - return result - where - monitorName = takeFileName (fileMonitorCacheFile monitor) - - showReason (MonitoredFileChanged file) = "file " ++ file - showReason (MonitoredValueChanged _) = "monitor value changed" - showReason MonitorFirstRun = "first run" - showReason MonitorCorruptCache = "invalid cache file" - - --- | When using 'rerunIfChanged' for each element of a list of actions, it is --- sometimes the case that each action needs to make use of some resource. e.g. --- --- > sequence --- > [ rerunIfChanged verbosity monitor key $ do --- > resource <- mkResource --- > ... -- use the resource --- > | ... ] --- --- For efficiency one would like to share the resource between the actions --- but the straightforward way of doing this means initialising it every time --- even when no actions need re-running. --- --- > resource <- mkResource --- > sequence --- > [ rerunIfChanged verbosity monitor key $ do --- > ... -- use the resource --- > | ... ] --- --- This utility allows one to get the best of both worlds: --- --- > getResource <- delayInitSharedResource mkResource --- > sequence --- > [ rerunIfChanged verbosity monitor key $ do --- > resource <- getResource --- > ... -- use the resource --- > | ... ] --- -delayInitSharedResource :: forall a. IO a -> Rebuild (Rebuild a) -delayInitSharedResource action = do - var <- liftIO (newMVar Nothing) - return (liftIO (getOrInitResource var)) - where - getOrInitResource :: MVar (Maybe a) -> IO a - getOrInitResource var = - modifyMVar var $ \mx -> - case mx of - Just x -> return (Just x, x) - Nothing -> do - x <- action - return (Just x, x) - - --- | Much like 'delayInitSharedResource' but for a keyed set of resources. --- --- > getResource <- delayInitSharedResource mkResource --- > sequence --- > [ rerunIfChanged verbosity monitor key $ do --- > resource <- getResource key --- > ... -- use the resource --- > | ... ] --- -delayInitSharedResources :: forall k v. Ord k - => (k -> IO v) - -> Rebuild (k -> Rebuild v) -delayInitSharedResources action = do - var <- liftIO (newMVar Map.empty) - return (liftIO . getOrInitResource var) - where - getOrInitResource :: MVar (Map k v) -> k -> IO v - getOrInitResource var k = - modifyMVar var $ \m -> - case Map.lookup k m of - Just x -> return (m, x) - Nothing -> do - x <- action k - let !m' = Map.insert k x m - return (m', x) - - --- | Utility to match a file glob against the file system, starting from a --- given root directory. The results are all relative to the given root. --- --- Since this operates in the 'Rebuild' monad, it also monitors the given glob --- for changes. --- -matchFileGlob :: FilePathGlob -> Rebuild [FilePath] -matchFileGlob glob = do - root <- askRoot - monitorFiles [monitorFileGlobExistence glob] - liftIO $ Glob.matchFileGlob root glob - -getDirectoryContentsMonitored :: FilePath -> Rebuild [FilePath] -getDirectoryContentsMonitored dir = do - exists <- monitorDirectoryStatus dir - if exists - then liftIO $ getDirectoryContents dir - else return [] - -createDirectoryMonitored :: Bool -> FilePath -> Rebuild () -createDirectoryMonitored createParents dir = do - monitorFiles [monitorDirectoryExistence dir] - liftIO $ createDirectoryIfMissing createParents dir - --- | Monitor a directory as in 'monitorDirectory' if it currently exists or --- as 'monitorNonExistentDirectory' if it does not. -monitorDirectoryStatus :: FilePath -> Rebuild Bool -monitorDirectoryStatus dir = do - exists <- liftIO $ doesDirectoryExist dir - monitorFiles [if exists - then monitorDirectory dir - else monitorNonExistentDirectory dir] - return exists - --- | Like 'doesFileExist', but in the 'Rebuild' monad. This does --- NOT track the contents of 'FilePath'; use 'need' in that case. -doesFileExistMonitored :: FilePath -> Rebuild Bool -doesFileExistMonitored f = do - root <- askRoot - exists <- liftIO $ doesFileExist (root f) - monitorFiles [if exists - then monitorFileExistence f - else monitorNonExistentFile f] - return exists - --- | Monitor a single file -need :: FilePath -> Rebuild () -need f = monitorFiles [monitorFileHashed f] - --- | Monitor a file if it exists; otherwise check for when it --- gets created. This is a bit better for recompilation avoidance --- because sometimes users give bad package metadata, and we don't --- want to repeatedly rebuild in this case (which we would if we --- need'ed a non-existent file). -needIfExists :: FilePath -> Rebuild () -needIfExists f = do - root <- askRoot - exists <- liftIO $ doesFileExist (root f) - monitorFiles [if exists - then monitorFileHashed f - else monitorNonExistentFile f] - --- | Like 'findFileWithExtension', but in the 'Rebuild' monad. -findFileWithExtensionMonitored - :: [String] - -> [FilePath] - -> FilePath - -> Rebuild (Maybe FilePath) -findFileWithExtensionMonitored extensions searchPath baseName = - findFirstFileMonitored id - [ path baseName <.> ext - | path <- nub searchPath - , ext <- nub extensions ] - --- | Like 'findFirstFile', but in the 'Rebuild' monad. -findFirstFileMonitored :: (a -> FilePath) -> [a] -> Rebuild (Maybe a) -findFirstFileMonitored file = findFirst - where findFirst [] = return Nothing - findFirst (x:xs) = do exists <- doesFileExistMonitored (file x) - if exists - then return (Just x) - else findFirst xs - --- | Like 'findFile', but in the 'Rebuild' monad. -findFileMonitored :: [FilePath] -> FilePath -> Rebuild (Maybe FilePath) -findFileMonitored searchPath fileName = - findFirstFileMonitored id - [ path fileName - | path <- nub searchPath] diff --git a/cabal/cabal-install/Distribution/Client/Reconfigure.hs b/cabal/cabal-install/Distribution/Client/Reconfigure.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Reconfigure.hs +++ /dev/null @@ -1,179 +0,0 @@ -module Distribution.Client.Reconfigure ( Check(..), reconfigure ) where - -import Distribution.Client.Compat.Prelude - -import Data.Monoid ( Any(..) ) -import System.Directory ( doesFileExist ) - -import Distribution.Simple.Configure ( localBuildInfoFile ) -import Distribution.Simple.Setup ( Flag, flagToMaybe, toFlag ) -import Distribution.Simple.Utils - ( existsAndIsMoreRecentThan, defaultPackageDesc, info ) - -import Distribution.Client.Config ( SavedConfig(..) ) -import Distribution.Client.Configure ( readConfigFlags ) -import Distribution.Client.Nix ( findNixExpr, inNixShell, nixInstantiate ) -import Distribution.Client.Sandbox ( findSavedDistPref, updateInstallDirs ) -import Distribution.Client.Sandbox.PackageEnvironment - ( userPackageEnvironmentFile ) -import Distribution.Client.Setup - ( ConfigFlags(..), ConfigExFlags, GlobalFlags(..) ) - --- | @Check@ represents a function to check some condition on type @a@. The --- returned 'Any' is 'True' if any part of the condition failed. -newtype Check a = Check { - runCheck :: Any -- Did any previous check fail? - -> a -- value returned by previous checks - -> IO (Any, a) -- Did this check fail? What value is returned? -} - -instance Semigroup (Check a) where - (<>) c d = Check $ \any0 a0 -> do - (any1, a1) <- runCheck c any0 a0 - (any2, a2) <- runCheck d (any0 <> any1) a1 - return (any0 <> any1 <> any2, a2) - -instance Monoid (Check a) where - mempty = Check $ \_ a -> return (mempty, a) - mappend = (<>) - - --- | Re-configure the package in the current directory if needed. Deciding --- when to reconfigure and with which options is convoluted: --- --- If we are reconfiguring, we must always run @configure@ with the --- verbosity option we are given; however, that a previous configuration --- uses a different verbosity setting is not reason enough to reconfigure. --- --- The package should be configured to use the same \"dist\" prefix as --- given to the @build@ command, otherwise the build will probably --- fail. Not only does this determine the \"dist\" prefix setting if we --- need to reconfigure anyway, but an existing configuration should be --- invalidated if its \"dist\" prefix differs. --- --- If the package has never been configured (i.e., there is no --- LocalBuildInfo), we must configure first, using the default options. --- --- If the package has been configured, there will be a 'LocalBuildInfo'. --- If there no package description file, we assume that the --- 'PackageDescription' is up to date, though the configuration may need --- to be updated for other reasons (see above). If there is a package --- description file, and it has been modified since the 'LocalBuildInfo' --- was generated, then we need to reconfigure. --- --- The caller of this function may also have specific requirements --- regarding the flags the last configuration used. For example, --- 'testAction' requires that the package be configured with test suites --- enabled. The caller may pass the required settings to this function --- along with a function to check the validity of the saved 'ConfigFlags'; --- these required settings will be checked first upon determining that --- a previous configuration exists. -reconfigure - :: ((ConfigFlags, ConfigExFlags) -> [String] -> GlobalFlags -> IO ()) - -- ^ configure action - -> Verbosity - -- ^ Verbosity setting - -> FilePath - -- ^ \"dist\" prefix - -> Flag (Maybe Int) - -- ^ -j flag for reinstalling add-source deps. - -> Check (ConfigFlags, ConfigExFlags) - -- ^ Check that the required flags are set. - -- If they are not set, provide a message explaining the - -- reason for reconfiguration. - -> [String] -- ^ Extra arguments - -> GlobalFlags -- ^ Global flags - -> SavedConfig - -> IO SavedConfig -reconfigure - configureAction - verbosity - dist - _numJobsFlag - check - extraArgs - globalFlags - config - = do - - savedFlags@(_, _) <- readConfigFlags dist - - useNix <- fmap isJust (findNixExpr globalFlags config) - alreadyInNixShell <- inNixShell - - if useNix && not alreadyInNixShell - then do - - -- If we are using Nix, we must reinstantiate the derivation outside - -- the shell. Eventually, the caller will invoke 'nixShell' which will - -- rerun cabal inside the shell. That will bring us back to 'reconfigure', - -- but inside the shell we'll take the second branch, below. - - -- This seems to have a problem: won't 'configureAction' call 'nixShell' - -- yet again, spawning an infinite tree of subprocesses? - -- No, because 'nixShell' doesn't spawn a new process if it is already - -- running in a Nix shell. - - nixInstantiate verbosity dist False globalFlags config - return config - - else do - - let checks = - checkVerb - <> checkDist - <> checkOutdated - <> check - (Any frc, flags@(configFlags, _)) <- runCheck checks mempty savedFlags - - let config' = updateInstallDirs (configUserInstall configFlags) config - - when frc $ configureAction flags extraArgs globalFlags - return config' - - where - - -- Changing the verbosity does not require reconfiguration, but the new - -- verbosity should be used if reconfiguring. - checkVerb = Check $ \_ (configFlags, configExFlags) -> do - let configFlags' = configFlags { configVerbosity = toFlag verbosity} - return (mempty, (configFlags', configExFlags)) - - -- Reconfiguration is required if @--build-dir@ changes. - checkDist = Check $ \_ (configFlags, configExFlags) -> do - -- Always set the chosen @--build-dir@ before saving the flags, - -- or bad things could happen. - savedDist <- findSavedDistPref config (configDistPref configFlags) - let distChanged = dist /= savedDist - when distChanged $ info verbosity "build directory changed" - let configFlags' = configFlags { configDistPref = toFlag dist } - return (Any distChanged, (configFlags', configExFlags)) - - checkOutdated = Check $ \_ flags@(configFlags, _) -> do - let buildConfig = localBuildInfoFile dist - - -- Has the package ever been configured? If not, reconfiguration is - -- required. - configured <- doesFileExist buildConfig - unless configured $ info verbosity "package has never been configured" - - -- Is the @cabal.config@ file newer than @dist/setup.config@? Then we need - -- to force reconfigure. Note that it's possible to use @cabal.config@ - -- even without sandboxes. - userPackageEnvironmentFileModified <- - existsAndIsMoreRecentThan userPackageEnvironmentFile buildConfig - when userPackageEnvironmentFileModified $ - info verbosity ("user package environment file ('" - ++ userPackageEnvironmentFile ++ "') was modified") - - -- Is the configuration older than the package description? - descrFile <- maybe (defaultPackageDesc verbosity) return - (flagToMaybe (configCabalFilePath configFlags)) - outdated <- existsAndIsMoreRecentThan descrFile buildConfig - when outdated $ info verbosity (descrFile ++ " was changed") - - let failed = - Any outdated - <> Any userPackageEnvironmentFileModified - <> Any (not configured) - return (failed, flags) diff --git a/cabal/cabal-install/Distribution/Client/Run.hs b/cabal/cabal-install/Distribution/Client/Run.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Run.hs +++ /dev/null @@ -1,141 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Run --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Implementation of the 'run' command. ------------------------------------------------------------------------------ - -module Distribution.Client.Run ( run, splitRunArgs ) - where - -import Prelude () -import Distribution.Client.Compat.Prelude - -import Distribution.Types.TargetInfo (targetCLBI) -import Distribution.Types.LocalBuildInfo (componentNameTargets') - -import Distribution.Client.Utils (tryCanonicalizePath) - -import Distribution.Types.UnqualComponentName -import Distribution.PackageDescription (Executable (..), - TestSuite(..), - Benchmark(..), - PackageDescription (..), - BuildInfo(buildable)) -import Distribution.Simple.Compiler (compilerFlavor, CompilerFlavor(..)) -import Distribution.Simple.Build.PathsModule (pkgPathEnvVar) -import Distribution.Simple.BuildPaths (exeExtension) -import Distribution.Simple.LocalBuildInfo (ComponentName (..), - LocalBuildInfo (..), - depLibraryPaths) -import Distribution.Simple.Utils (die', notice, warn, - rawSystemExitWithEnv, - addLibraryPath) -import Distribution.System (Platform (..)) - -import qualified Distribution.Simple.GHCJS as GHCJS - -import System.Directory (getCurrentDirectory) -import Distribution.Compat.Environment (getEnvironment) -import System.FilePath ((<.>), ()) - - --- | Return the executable to run and any extra arguments that should be --- forwarded to it. Die in case of error. -splitRunArgs :: Verbosity -> LocalBuildInfo -> [String] - -> IO (Executable, [String]) -splitRunArgs verbosity lbi args = - case whichExecutable of -- Either err (wasManuallyChosen, exe, paramsRest) - Left err -> do - warn verbosity `traverse_` maybeWarning -- If there is a warning, print it. - die' verbosity err - Right (True, exe, xs) -> return (exe, xs) - Right (False, exe, xs) -> do - let addition = " Interpreting all parameters to `run` as a parameter to" - ++ " the default executable." - -- If there is a warning, print it together with the addition. - warn verbosity `traverse_` fmap (++addition) maybeWarning - return (exe, xs) - where - pkg_descr = localPkgDescr lbi - whichExecutable :: Either String -- Error string. - ( Bool -- If it was manually chosen. - , Executable -- The executable. - , [String] -- The remaining parameters. - ) - whichExecutable = case (enabledExes, args) of - ([] , _) -> Left "Couldn't find any enabled executables." - ([exe], []) -> return (False, exe, []) - ([exe], (x:xs)) - | x == unUnqualComponentName (exeName exe) -> return (True, exe, xs) - | otherwise -> return (False, exe, args) - (_ , []) -> Left - $ "This package contains multiple executables. " - ++ "You must pass the executable name as the first argument " - ++ "to 'cabal run'." - (_ , (x:xs)) -> - case find (\exe -> unUnqualComponentName (exeName exe) == x) enabledExes of - Nothing -> Left $ "No executable named '" ++ x ++ "'." - Just exe -> return (True, exe, xs) - where - enabledExes = filter (buildable . buildInfo) (executables pkg_descr) - - maybeWarning :: Maybe String - maybeWarning = case args of - [] -> Nothing - (x:_) -> lookup (mkUnqualComponentName x) components - where - components :: [(UnqualComponentName, String)] -- Component name, message. - components = - [ (name, "The executable '" ++ prettyShow name ++ "' is disabled.") - | e <- executables pkg_descr - , not . buildable . buildInfo $ e, let name = exeName e] - - ++ [ (name, "There is a test-suite '" ++ prettyShow name ++ "'," - ++ " but the `run` command is only for executables.") - | t <- testSuites pkg_descr - , let name = testName t] - - ++ [ (name, "There is a benchmark '" ++ prettyShow name ++ "'," - ++ " but the `run` command is only for executables.") - | b <- benchmarks pkg_descr - , let name = benchmarkName b] - --- | Run a given executable. -run :: Verbosity -> LocalBuildInfo -> Executable -> [String] -> IO () -run verbosity lbi exe exeArgs = do - curDir <- getCurrentDirectory - let buildPref = buildDir lbi - pkg_descr = localPkgDescr lbi - dataDirEnvVar = (pkgPathEnvVar pkg_descr "datadir", - curDir dataDir pkg_descr) - - (path, runArgs) <- - let exeName' = prettyShow $ exeName exe - in case compilerFlavor (compiler lbi) of - GHCJS -> do - let (script, cmd, cmdArgs) = - GHCJS.runCmd (withPrograms lbi) - (buildPref exeName' exeName') - script' <- tryCanonicalizePath script - return (cmd, cmdArgs ++ [script']) - _ -> do - p <- tryCanonicalizePath $ - buildPref exeName' (exeName' <.> exeExtension (hostPlatform lbi)) - return (p, []) - - env <- (dataDirEnvVar:) <$> getEnvironment - -- Add (DY)LD_LIBRARY_PATH if needed - env' <- if withDynExe lbi - then do let (Platform _ os) = hostPlatform lbi - clbi <- case componentNameTargets' pkg_descr lbi (CExeName (exeName exe)) of - [target] -> return (targetCLBI target) - [] -> die' verbosity "run: Could not find executable in LocalBuildInfo" - _ -> die' verbosity "run: Found multiple matching exes in LocalBuildInfo" - paths <- depLibraryPaths True False lbi clbi - return (addLibraryPath os paths env) - else return env - notice verbosity $ "Running " ++ prettyShow (exeName exe) ++ "..." - rawSystemExitWithEnv verbosity path (runArgs++exeArgs) env' diff --git a/cabal/cabal-install/Distribution/Client/Sandbox.hs b/cabal/cabal-install/Distribution/Client/Sandbox.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Sandbox.hs +++ /dev/null @@ -1,122 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Sandbox --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- UI for the sandboxing functionality. ------------------------------------------------------------------------------ - -module Distribution.Client.Sandbox ( - loadConfigOrSandboxConfig, - findSavedDistPref, - - updateInstallDirs, - - getPersistOrConfigCompiler - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude - -import Distribution.Client.Setup - ( ConfigFlags(..), GlobalFlags(..), configCompilerAux' ) -import Distribution.Client.Config - ( SavedConfig(..), defaultUserInstall, loadConfig ) - -import Distribution.Client.Sandbox.PackageEnvironment - ( PackageEnvironmentType(..) - , classifyPackageEnvironment - , loadUserConfig - ) -import Distribution.Client.SetupWrapper - ( SetupScriptOptions(..), defaultSetupScriptOptions ) -import Distribution.Simple.Compiler ( Compiler(..) ) -import Distribution.Simple.Configure ( maybeGetPersistBuildConfig - , findDistPrefOrDefault - , findDistPref ) -import qualified Distribution.Simple.LocalBuildInfo as LocalBuildInfo -import Distribution.Simple.Program ( ProgramDb ) -import Distribution.Simple.Setup ( Flag(..) - , fromFlagOrDefault, flagToMaybe ) -import Distribution.System ( Platform ) - -import System.Directory ( getCurrentDirectory ) - - --- * Basic sandbox functions. --- - -updateInstallDirs :: Flag Bool -> SavedConfig -> SavedConfig -updateInstallDirs userInstallFlag savedConfig = savedConfig - { savedConfigureFlags = configureFlags - { configInstallDirs = installDirs - } - } - where - configureFlags = savedConfigureFlags savedConfig - userInstallDirs = savedUserInstallDirs savedConfig - globalInstallDirs = savedGlobalInstallDirs savedConfig - installDirs | userInstall = userInstallDirs - | otherwise = globalInstallDirs - userInstall = fromFlagOrDefault defaultUserInstall - (configUserInstall configureFlags `mappend` userInstallFlag) - --- | Check which type of package environment we're in and return a --- correctly-initialised @SavedConfig@ and a @UseSandbox@ value that indicates --- whether we're working in a sandbox. -loadConfigOrSandboxConfig :: Verbosity - -> GlobalFlags -- ^ For @--config-file@ and - -- @--sandbox-config-file@. - -> IO SavedConfig -loadConfigOrSandboxConfig verbosity globalFlags = do - let configFileFlag = globalConfigFile globalFlags - - pkgEnvDir <- getCurrentDirectory - pkgEnvType <- classifyPackageEnvironment pkgEnvDir - case pkgEnvType of - -- Only @cabal.config@ is present. - UserPackageEnvironment -> do - config <- loadConfig verbosity configFileFlag - userConfig <- loadUserConfig verbosity pkgEnvDir Nothing - let config' = config `mappend` userConfig - return config' - - -- Neither @cabal.sandbox.config@ nor @cabal.config@ are present. - AmbientPackageEnvironment -> do - config <- loadConfig verbosity configFileFlag - let globalConstraintsOpt = - flagToMaybe . globalConstraintsFile . savedGlobalFlags $ config - globalConstraintConfig <- - loadUserConfig verbosity pkgEnvDir globalConstraintsOpt - let config' = config `mappend` globalConstraintConfig - return config' - --- | Return the saved \"dist/\" prefix, or the default prefix. -findSavedDistPref :: SavedConfig -> Flag FilePath -> IO FilePath -findSavedDistPref config flagDistPref = do - let defDistPref = useDistPref defaultSetupScriptOptions - flagDistPref' = configDistPref (savedConfigureFlags config) - `mappend` flagDistPref - findDistPref defDistPref flagDistPref' - --- Utils (transitionary) --- - --- | Try to read the most recently configured compiler from the --- 'localBuildInfoFile', falling back on 'configCompilerAuxEx' if it --- cannot be read. -getPersistOrConfigCompiler :: ConfigFlags - -> IO (Compiler, Platform, ProgramDb) -getPersistOrConfigCompiler configFlags = do - distPref <- findDistPrefOrDefault (configDistPref configFlags) - mlbi <- maybeGetPersistBuildConfig distPref - case mlbi of - Nothing -> do configCompilerAux' configFlags - Just lbi -> return ( LocalBuildInfo.compiler lbi - , LocalBuildInfo.hostPlatform lbi - , LocalBuildInfo.withPrograms lbi - ) diff --git a/cabal/cabal-install/Distribution/Client/Sandbox/PackageEnvironment.hs b/cabal/cabal-install/Distribution/Client/Sandbox/PackageEnvironment.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Sandbox/PackageEnvironment.hs +++ /dev/null @@ -1,284 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Sandbox.PackageEnvironment --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Utilities for working with the package environment file. Patterned after --- Distribution.Client.Config. ------------------------------------------------------------------------------ - -module Distribution.Client.Sandbox.PackageEnvironment ( - PackageEnvironment(..) - , PackageEnvironmentType(..) - , classifyPackageEnvironment - , readPackageEnvironmentFile - , showPackageEnvironment - , showPackageEnvironmentWithComments - , loadUserConfig - - , userPackageEnvironmentFile - ) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Client.Config ( SavedConfig(..) - , configFieldDescriptions - , haddockFlagsFields - , installDirsFields, withProgramsFields - , withProgramOptionsFields - ) -import Distribution.Client.ParseUtils ( parseFields, ppFields, ppSection ) -import Distribution.Client.Setup ( ConfigExFlags(..) - ) -import Distribution.Client.Targets ( userConstraintPackageName ) -import Distribution.Simple.InstallDirs ( InstallDirs(..), PathTemplate ) -import Distribution.Simple.Setup ( Flag(..) - , ConfigFlags(..), HaddockFlags(..) - ) -import Distribution.Simple.Utils ( warn, debug ) -import Distribution.Solver.Types.ConstraintSource -import Distribution.Deprecated.ParseUtils ( FieldDescr(..), ParseResult(..) - , commaListFieldParsec, commaNewLineListFieldParsec - , liftField, lineNo, locatedErrorMsg - , readFields - , showPWarning - , syntaxError, warning ) -import System.Directory ( doesFileExist ) -import System.FilePath ( () ) -import System.IO.Error ( isDoesNotExistError ) -import Text.PrettyPrint ( ($+$) ) - -import qualified Text.PrettyPrint as Disp -import qualified Distribution.Deprecated.ParseUtils as ParseUtils ( Field(..) ) - --- --- * Configuration saved in the package environment file --- - --- TODO: would be nice to remove duplication between --- D.C.Sandbox.PackageEnvironment and D.C.Config. -data PackageEnvironment = PackageEnvironment { - pkgEnvSavedConfig :: SavedConfig -} deriving Generic - -instance Monoid PackageEnvironment where - mempty = gmempty - mappend = (<>) - -instance Semigroup PackageEnvironment where - (<>) = gmappend - --- | Optional package environment file that can be used to customize the default --- settings. Created by the user. -userPackageEnvironmentFile :: FilePath -userPackageEnvironmentFile = "cabal.config" - --- | Type of the current package environment. -data PackageEnvironmentType - = UserPackageEnvironment -- ^ './cabal.config' - | AmbientPackageEnvironment -- ^ '~/.cabal/config' - --- | Is there a 'cabal.config' in this directory? -classifyPackageEnvironment :: FilePath -> IO PackageEnvironmentType -classifyPackageEnvironment pkgEnvDir = do - isUser <- configExists userPackageEnvironmentFile - return (classify isUser) - where - configExists fname = doesFileExist (pkgEnvDir fname) - - classify :: Bool -> PackageEnvironmentType - classify True = UserPackageEnvironment - classify False = AmbientPackageEnvironment - - --- | Load the user package environment if it exists (the optional "cabal.config" --- file). If it does not exist locally, attempt to load an optional global one. -userPackageEnvironment :: Verbosity -> FilePath -> Maybe FilePath - -> IO PackageEnvironment -userPackageEnvironment verbosity pkgEnvDir globalConfigLocation = do - let path = pkgEnvDir userPackageEnvironmentFile - minp <- readPackageEnvironmentFile (ConstraintSourceUserConfig path) - mempty path - case (minp, globalConfigLocation) of - (Just parseRes, _) -> processConfigParse path parseRes - (_, Just globalLoc) -> do - minp' <- readPackageEnvironmentFile (ConstraintSourceUserConfig globalLoc) - mempty globalLoc - maybe (warn verbosity ("no constraints file found at " ++ globalLoc) - >> return mempty) - (processConfigParse globalLoc) - minp' - _ -> do - debug verbosity ("no user package environment file found at " ++ pkgEnvDir) - return mempty - where - processConfigParse path (ParseOk warns parseResult) = do - unless (null warns) $ warn verbosity $ - unlines (map (showPWarning path) warns) - return parseResult - processConfigParse path (ParseFailed err) = do - let (line, msg) = locatedErrorMsg err - warn verbosity $ "Error parsing package environment file " ++ path - ++ maybe "" (\n -> ":" ++ show n) line ++ ":\n" ++ msg - return mempty - --- | Same as @userPackageEnvironmentFile@, but returns a SavedConfig. -loadUserConfig :: Verbosity -> FilePath -> Maybe FilePath -> IO SavedConfig -loadUserConfig verbosity pkgEnvDir globalConfigLocation = - fmap pkgEnvSavedConfig $ - userPackageEnvironment verbosity pkgEnvDir globalConfigLocation - - - --- | Descriptions of all fields in the package environment file. -pkgEnvFieldDescrs :: ConstraintSource -> [FieldDescr PackageEnvironment] -pkgEnvFieldDescrs src = - [ commaNewLineListFieldParsec "constraints" - (pretty . fst) ((\pc -> (pc, src)) `fmap` parsec) - (sortConstraints . configExConstraints - . savedConfigureExFlags . pkgEnvSavedConfig) - (\v pkgEnv -> updateConfigureExFlags pkgEnv - (\flags -> flags { configExConstraints = v })) - - , commaListFieldParsec "preferences" - pretty parsec - (configPreferences . savedConfigureExFlags . pkgEnvSavedConfig) - (\v pkgEnv -> updateConfigureExFlags pkgEnv - (\flags -> flags { configPreferences = v })) - ] - ++ map toPkgEnv configFieldDescriptions' - where - configFieldDescriptions' :: [FieldDescr SavedConfig] - configFieldDescriptions' = filter - (\(FieldDescr name _ _) -> name /= "preference" && name /= "constraint") - (configFieldDescriptions src) - - toPkgEnv :: FieldDescr SavedConfig -> FieldDescr PackageEnvironment - toPkgEnv fieldDescr = - liftField pkgEnvSavedConfig - (\savedConfig pkgEnv -> pkgEnv { pkgEnvSavedConfig = savedConfig}) - fieldDescr - - updateConfigureExFlags :: PackageEnvironment - -> (ConfigExFlags -> ConfigExFlags) - -> PackageEnvironment - updateConfigureExFlags pkgEnv f = pkgEnv { - pkgEnvSavedConfig = (pkgEnvSavedConfig pkgEnv) { - savedConfigureExFlags = f . savedConfigureExFlags . pkgEnvSavedConfig - $ pkgEnv - } - } - - sortConstraints = sortBy (comparing $ userConstraintPackageName . fst) - --- | Read the package environment file. -readPackageEnvironmentFile :: ConstraintSource -> PackageEnvironment -> FilePath - -> IO (Maybe (ParseResult PackageEnvironment)) -readPackageEnvironmentFile src initial file = - handleNotExists $ - fmap (Just . parsePackageEnvironment src initial) (readFile file) - where - handleNotExists action = catchIO action $ \ioe -> - if isDoesNotExistError ioe - then return Nothing - else ioError ioe - --- | Parse the package environment file. -parsePackageEnvironment :: ConstraintSource -> PackageEnvironment -> String - -> ParseResult PackageEnvironment -parsePackageEnvironment src initial str = do - fields <- readFields str - let (knownSections, others) = partition isKnownSection fields - pkgEnv <- parse others - let config = pkgEnvSavedConfig pkgEnv - installDirs0 = savedUserInstallDirs config - (haddockFlags, installDirs, paths, args) <- - foldM parseSections - (savedHaddockFlags config, installDirs0, [], []) - knownSections - return pkgEnv { - pkgEnvSavedConfig = config { - savedConfigureFlags = (savedConfigureFlags config) { - configProgramPaths = paths, - configProgramArgs = args - }, - savedHaddockFlags = haddockFlags, - savedUserInstallDirs = installDirs, - savedGlobalInstallDirs = installDirs - } - } - - where - isKnownSection :: ParseUtils.Field -> Bool - isKnownSection (ParseUtils.Section _ "haddock" _ _) = True - isKnownSection (ParseUtils.Section _ "install-dirs" _ _) = True - isKnownSection (ParseUtils.Section _ "program-locations" _ _) = True - isKnownSection (ParseUtils.Section _ "program-default-options" _ _) = True - isKnownSection _ = False - - parse :: [ParseUtils.Field] -> ParseResult PackageEnvironment - parse = parseFields (pkgEnvFieldDescrs src) initial - - parseSections :: SectionsAccum -> ParseUtils.Field - -> ParseResult SectionsAccum - parseSections accum@(h,d,p,a) - (ParseUtils.Section _ "haddock" name fs) - | name == "" = do h' <- parseFields haddockFlagsFields h fs - return (h', d, p, a) - | otherwise = do - warning "The 'haddock' section should be unnamed" - return accum - parseSections (h,d,p,a) - (ParseUtils.Section line "install-dirs" name fs) - | name == "" = do d' <- parseFields installDirsFields d fs - return (h, d',p,a) - | otherwise = - syntaxError line $ - "Named 'install-dirs' section: '" ++ name - ++ "'. Note that named 'install-dirs' sections are not allowed in the '" - ++ userPackageEnvironmentFile ++ "' file." - parseSections accum@(h, d,p,a) - (ParseUtils.Section _ "program-locations" name fs) - | name == "" = do p' <- parseFields withProgramsFields p fs - return (h, d, p', a) - | otherwise = do - warning "The 'program-locations' section should be unnamed" - return accum - parseSections accum@(h, d, p, a) - (ParseUtils.Section _ "program-default-options" name fs) - | name == "" = do a' <- parseFields withProgramOptionsFields a fs - return (h, d, p, a') - | otherwise = do - warning "The 'program-default-options' section should be unnamed" - return accum - parseSections accum f = do - warning $ "Unrecognized stanza on line " ++ show (lineNo f) - return accum - --- | Accumulator type for 'parseSections'. -type SectionsAccum = (HaddockFlags, InstallDirs (Flag PathTemplate) - , [(String, FilePath)], [(String, [String])]) - - - --- | Pretty-print the package environment. -showPackageEnvironment :: PackageEnvironment -> String -showPackageEnvironment pkgEnv = showPackageEnvironmentWithComments Nothing pkgEnv - --- | Pretty-print the package environment with default values for empty fields --- commented out (just like the default ~/.cabal/config). -showPackageEnvironmentWithComments :: (Maybe PackageEnvironment) - -> PackageEnvironment - -> String -showPackageEnvironmentWithComments mdefPkgEnv pkgEnv = Disp.render $ - ppFields (pkgEnvFieldDescrs ConstraintSourceUnknown) - mdefPkgEnv pkgEnv - $+$ Disp.text "" - $+$ ppSection "install-dirs" "" installDirsFields - (fmap installDirsSection mdefPkgEnv) (installDirsSection pkgEnv) - where - installDirsSection = savedUserInstallDirs . pkgEnvSavedConfig diff --git a/cabal/cabal-install/Distribution/Client/SavedFlags.hs b/cabal/cabal-install/Distribution/Client/SavedFlags.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/SavedFlags.hs +++ /dev/null @@ -1,81 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} - -module Distribution.Client.SavedFlags - ( readCommandFlags, writeCommandFlags - , readSavedArgs, writeSavedArgs - ) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Simple.Command -import Distribution.Simple.UserHooks ( Args ) -import Distribution.Simple.Utils - ( createDirectoryIfMissingVerbose, unintersperse ) -import Distribution.Verbosity - -import System.Directory ( doesFileExist ) -import System.FilePath ( takeDirectory ) - - -writeSavedArgs :: Verbosity -> FilePath -> [String] -> IO () -writeSavedArgs verbosity path args = do - createDirectoryIfMissingVerbose - (lessVerbose verbosity) True (takeDirectory path) - writeFile path (intercalate "\0" args) - - --- | Write command-line flags to a file, separated by null characters. This --- format is also suitable for the @xargs -0@ command. Using the null --- character also avoids the problem of escaping newlines or spaces, --- because unlike other whitespace characters, the null character is --- not valid in command-line arguments. -writeCommandFlags :: Verbosity -> FilePath -> CommandUI flags -> flags -> IO () -writeCommandFlags verbosity path command flags = - writeSavedArgs verbosity path (commandShowOptions command flags) - - -readSavedArgs :: FilePath -> IO (Maybe [String]) -readSavedArgs path = do - exists <- doesFileExist path - if exists - then fmap (Just . unintersperse '\0') (readFile path) - else return Nothing - - --- | Read command-line arguments, separated by null characters, from a file. --- Returns the default flags if the file does not exist. -readCommandFlags :: FilePath -> CommandUI flags -> IO flags -readCommandFlags path command = do - savedArgs <- fmap (fromMaybe []) (readSavedArgs path) - case (commandParseArgs command True savedArgs) of - CommandHelp _ -> throwIO (SavedArgsErrorHelp savedArgs) - CommandList _ -> throwIO (SavedArgsErrorList savedArgs) - CommandErrors errs -> throwIO (SavedArgsErrorOther savedArgs errs) - CommandReadyToGo (mkFlags, _) -> - return (mkFlags (commandDefaultFlags command)) - --- ----------------------------------------------------------------------------- --- * Exceptions --- ----------------------------------------------------------------------------- - -data SavedArgsError - = SavedArgsErrorHelp Args - | SavedArgsErrorList Args - | SavedArgsErrorOther Args [String] - deriving (Typeable) - -instance Show SavedArgsError where - show (SavedArgsErrorHelp args) = - "unexpected flag '--help', saved command line was:\n" - ++ intercalate " " args - show (SavedArgsErrorList args) = - "unexpected flag '--list-options', saved command line was:\n" - ++ intercalate " " args - show (SavedArgsErrorOther args errs) = - "saved command line was:\n" - ++ intercalate " " args ++ "\n" - ++ "encountered errors:\n" - ++ intercalate "\n" errs - -instance Exception SavedArgsError diff --git a/cabal/cabal-install/Distribution/Client/Security/DNS.hs b/cabal/cabal-install/Distribution/Client/Security/DNS.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Security/DNS.hs +++ /dev/null @@ -1,193 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DoAndIfThenElse #-} - -module Distribution.Client.Security.DNS - ( queryBootstrapMirrors - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude -import Network.URI (URI(..), URIAuth(..), parseURI) -import Control.Exception (try) -import Distribution.Simple.Utils - -#if defined(MIN_VERSION_resolv) || defined(MIN_VERSION_windns) -import Network.DNS (queryTXT, Name(..), CharStr(..)) -import qualified Data.ByteString.Char8 as BS.Char8 -#else -import Distribution.Simple.Program.Db - ( emptyProgramDb, addKnownProgram - , configureAllKnownPrograms, lookupProgram ) -import Distribution.Simple.Program - ( simpleProgram - , programInvocation - , getProgramInvocationOutput ) -#endif - --- | Try to lookup RFC1464-encoded mirror urls for a Hackage --- repository url by performing a DNS TXT lookup on the --- @_mirrors.@-prefixed URL hostname. --- --- Example: for @http://hackage.haskell.org/@ --- perform a DNS TXT query for the hostname --- @_mirrors.hackage.haskell.org@ which may look like e.g. --- --- > _mirrors.hackage.haskell.org. 300 IN TXT --- > "0.urlbase=http://hackage.fpcomplete.com/" --- > "1.urlbase=http://objects-us-west-1.dream.io/hackage-mirror/" --- --- NB: hackage-security doesn't require DNS lookups being trustworthy, --- as the trust is established via the cryptographically signed TUF --- meta-data that is retrieved from the resolved Hackage repository. --- Moreover, we already have to protect against a compromised --- @hackage.haskell.org@ DNS entry, so an the additional --- @_mirrors.hackage.haskell.org@ DNS entry in the same SOA doesn't --- constitute a significant new attack vector anyway. --- -queryBootstrapMirrors :: Verbosity -> URI -> IO [URI] - -#if defined(MIN_VERSION_resolv) || defined(MIN_VERSION_windns) --- use @resolv@ package for performing DNS queries -queryBootstrapMirrors verbosity repoUri - | Just auth <- uriAuthority repoUri = do - let mirrorsDnsName = Name (BS.Char8.pack ("_mirrors." ++ uriRegName auth)) - - mirrors' <- try $ do - txts <- queryTXT mirrorsDnsName - evaluate (force $ extractMirrors (map snd txts)) - - mirrors <- case mirrors' of - Left e -> do - warn verbosity ("Caught exception during _mirrors lookup:"++ - displayException (e :: SomeException)) - return [] - Right v -> return v - - if null mirrors - then warn verbosity ("No mirrors found for " ++ show repoUri) - else do info verbosity ("located " ++ show (length mirrors) ++ - " mirrors for " ++ show repoUri ++ " :") - for_ mirrors $ \url -> info verbosity ("- " ++ show url) - - return mirrors - - | otherwise = return [] - --- | Extract list of mirrors from 'queryTXT' result -extractMirrors :: [[CharStr]] -> [URI] -extractMirrors txtChunks = mapMaybe (parseURI . snd) . sort $ vals - where - vals = [ (kn,v) | CharStr e <- concat txtChunks - , Just (k,v) <- [splitRfc1464 (BS.Char8.unpack e)] - , Just kn <- [isUrlBase k] - ] - ----------------------------------------------------------------------------- -#else /* !defined(MIN_VERSION_resolv) */ --- use external method via @nslookup@ -queryBootstrapMirrors verbosity repoUri - | Just auth <- uriAuthority repoUri = do - progdb <- configureAllKnownPrograms verbosity $ - addKnownProgram nslookupProg emptyProgramDb - - case lookupProgram nslookupProg progdb of - Nothing -> do - warn verbosity "'nslookup' tool missing - can't locate mirrors" - return [] - - Just nslookup -> do - let mirrorsDnsName = "_mirrors." ++ uriRegName auth - - mirrors' <- try $ do - out <- getProgramInvocationOutput verbosity $ - programInvocation nslookup ["-query=TXT", mirrorsDnsName] - evaluate (force $ extractMirrors mirrorsDnsName out) - - mirrors <- case mirrors' of - Left e -> do - warn verbosity ("Caught exception during _mirrors lookup:"++ - displayException (e :: SomeException)) - return [] - Right v -> return v - - if null mirrors - then warn verbosity ("No mirrors found for " ++ show repoUri) - else do info verbosity ("located " ++ show (length mirrors) ++ - " mirrors for " ++ show repoUri ++ " :") - for_ mirrors $ \url -> info verbosity ("- " ++ show url) - - return mirrors - - | otherwise = return [] - where - nslookupProg = simpleProgram "nslookup" - --- | Extract list of mirrors from @nslookup -query=TXT@ output. -extractMirrors :: String -> String -> [URI] -extractMirrors hostname s0 = mapMaybe (parseURI . snd) . sort $ vals - where - vals = [ (kn,v) | (h,ents) <- fromMaybe [] $ parseNsLookupTxt s0 - , h == hostname - , e <- ents - , Just (k,v) <- [splitRfc1464 e] - , Just kn <- [isUrlBase k] - ] - --- | Parse output of @nslookup -query=TXT $HOSTNAME@ tolerantly -parseNsLookupTxt :: String -> Maybe [(String,[String])] -parseNsLookupTxt = go0 [] [] - where - -- approximate grammar: - -- := { } - -- ( starts at begin of line, but may span multiple lines) - -- := ^ TAB "text =" { } - -- := string enclosed by '"'s ('\' and '"' are \-escaped) - - -- scan for ^ "text =" - go0 [] _ [] = Nothing - go0 res _ [] = Just (reverse res) - go0 res _ ('\n':xs) = go0 res [] xs - go0 res lw ('\t':'t':'e':'x':'t':' ':'=':xs) = go1 res (reverse lw) [] (dropWhile isSpace xs) - go0 res lw (x:xs) = go0 res (x:lw) xs - - -- collect at least one - go1 res lw qs ('"':xs) = case qstr "" xs of - Just (s, xs') -> go1 res lw (s:qs) (dropWhile isSpace xs') - Nothing -> Nothing -- bad quoting - go1 _ _ [] _ = Nothing -- missing qstring - go1 res lw qs xs = go0 ((lw,reverse qs):res) [] xs - - qstr _ ('\n':_) = Nothing -- We don't support unquoted LFs - qstr acc ('\\':'\\':cs) = qstr ('\\':acc) cs - qstr acc ('\\':'"':cs) = qstr ('"':acc) cs - qstr acc ('"':cs) = Just (reverse acc, cs) - qstr acc (c:cs) = qstr (c:acc) cs - qstr _ [] = Nothing - -#endif ----------------------------------------------------------------------------- - --- | Helper used by 'extractMirrors' for extracting @urlbase@ keys from Rfc1464-encoded data -isUrlBase :: String -> Maybe Int -isUrlBase s - | ".urlbase" `isSuffixOf` s, not (null ns), all isDigit ns = readMaybe ns - | otherwise = Nothing - where - ns = take (length s - 8) s - --- | Split a TXT string into key and value according to RFC1464. --- Returns 'Nothing' if parsing fails. -splitRfc1464 :: String -> Maybe (String,String) -splitRfc1464 = go "" - where - go _ [] = Nothing - go acc ('`':c:cs) = go (c:acc) cs - go acc ('=':cs) = go2 (reverse acc) "" cs - go acc (c:cs) - | isSpace c = go acc cs - | otherwise = go (c:acc) cs - - go2 k acc [] = Just (k,reverse acc) - go2 _ _ ['`'] = Nothing - go2 k acc ('`':c:cs) = go2 k (c:acc) cs - go2 k acc (c:cs) = go2 k (c:acc) cs diff --git a/cabal/cabal-install/Distribution/Client/Security/HTTP.hs b/cabal/cabal-install/Distribution/Client/Security/HTTP.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Security/HTTP.hs +++ /dev/null @@ -1,179 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} --- | Implementation of 'HttpLib' using cabal-install's own 'HttpTransport' -module Distribution.Client.Security.HTTP (HttpLib, transportAdapter) where - -import Distribution.Solver.Compat.Prelude -import Prelude () - --- stdlibs -import System.Directory - ( getTemporaryDirectory ) -import Network.URI - ( URI ) -import qualified Data.ByteString.Lazy as BS.L -import qualified Network.HTTP as HTTP - --- Cabal/cabal-install -import Distribution.Verbosity - ( Verbosity ) -import Distribution.Client.HttpUtils - ( HttpTransport(..), HttpCode ) -import Distribution.Client.Utils - ( withTempFileName ) - --- hackage-security -import Hackage.Security.Client.Repository.HttpLib (HttpLib (..)) -import qualified Hackage.Security.Client as HC -import qualified Hackage.Security.Client.Repository.HttpLib as HC -import qualified Hackage.Security.Util.Checked as HC -import qualified Hackage.Security.Util.Pretty as HC - -{------------------------------------------------------------------------------- - 'HttpLib' implementation --------------------------------------------------------------------------------} - --- | Translate from hackage-security's 'HttpLib' to cabal-install's 'HttpTransport' --- --- NOTE: The match between these two APIs is currently not perfect: --- --- * We don't get any response headers back from the 'HttpTransport', so we --- don't know if the server supports range requests. For now we optimistically --- assume that it does. --- * The 'HttpTransport' wants to know where to place the resulting file, --- whereas the 'HttpLib' expects an 'IO' action which streams the download; --- the security library then makes sure that the file gets written to a --- location which is suitable (in particular, to a temporary file in the --- directory where the file needs to end up, so that it can "finalize" the --- file simply by doing 'renameFile'). Right now we write the file to a --- temporary file in the system temp directory here and then read it again --- to pass it to the security library; this is a problem for two reasons: it --- is a source of inefficiency; and it means that the security library cannot --- insist on a minimum download rate (potential security attack). --- Fixing it however would require changing the 'HttpTransport'. -transportAdapter :: Verbosity -> IO HttpTransport -> HttpLib -transportAdapter verbosity getTransport = HttpLib{ - httpGet = \headers uri callback -> do - transport <- getTransport - httpGetImpl verbosity transport headers uri callback - , httpGetRange = \headers uri range callback -> do - transport <- getTransport - getRange verbosity transport headers uri range callback - } - -httpGetImpl - :: HC.Throws HC.SomeRemoteError - => Verbosity - -> HttpTransport - -> [HC.HttpRequestHeader] -> URI - -> ([HC.HttpResponseHeader] -> HC.BodyReader -> IO a) - -> IO a -httpGetImpl verbosity transport reqHeaders uri callback = wrapCustomEx $ do - get' verbosity transport reqHeaders uri Nothing $ \code respHeaders br -> - case code of - 200 -> callback respHeaders br - _ -> HC.throwChecked $ UnexpectedResponse uri code - -getRange :: HC.Throws HC.SomeRemoteError - => Verbosity - -> HttpTransport - -> [HC.HttpRequestHeader] -> URI -> (Int, Int) - -> (HC.HttpStatus -> [HC.HttpResponseHeader] -> HC.BodyReader -> IO a) - -> IO a -getRange verbosity transport reqHeaders uri range callback = wrapCustomEx $ do - get' verbosity transport reqHeaders uri (Just range) $ \code respHeaders br -> - case code of - 200 -> callback HC.HttpStatus200OK respHeaders br - 206 -> callback HC.HttpStatus206PartialContent respHeaders br - _ -> HC.throwChecked $ UnexpectedResponse uri code - --- | Internal generalization of 'get' and 'getRange' -get' :: Verbosity - -> HttpTransport - -> [HC.HttpRequestHeader] -> URI -> Maybe (Int, Int) - -> (HttpCode -> [HC.HttpResponseHeader] -> HC.BodyReader -> IO a) - -> IO a -get' verbosity transport reqHeaders uri mRange callback = do - tempDir <- getTemporaryDirectory - withTempFileName tempDir "transportAdapterGet" $ \temp -> do - (code, _etag) <- getHttp transport verbosity uri Nothing temp reqHeaders' - br <- HC.bodyReaderFromBS =<< BS.L.readFile temp - callback code [HC.HttpResponseAcceptRangesBytes] br - where - reqHeaders' = mkReqHeaders reqHeaders mRange - -{------------------------------------------------------------------------------- - Request headers --------------------------------------------------------------------------------} - -mkRangeHeader :: Int -> Int -> HTTP.Header -mkRangeHeader from to = HTTP.Header HTTP.HdrRange rangeHeader - where - -- Content-Range header uses inclusive rather than exclusive bounds - -- See - rangeHeader = "bytes=" ++ show from ++ "-" ++ show (to - 1) - -mkReqHeaders :: [HC.HttpRequestHeader] -> Maybe (Int, Int) -> [HTTP.Header] -mkReqHeaders reqHeaders mRange = concat [ - tr [] reqHeaders - , [mkRangeHeader fr to | Just (fr, to) <- [mRange]] - ] - where - tr :: [(HTTP.HeaderName, [String])] -> [HC.HttpRequestHeader] -> [HTTP.Header] - tr acc [] = - concatMap finalize acc - tr acc (HC.HttpRequestMaxAge0:os) = - tr (insert HTTP.HdrCacheControl ["max-age=0"] acc) os - tr acc (HC.HttpRequestNoTransform:os) = - tr (insert HTTP.HdrCacheControl ["no-transform"] acc) os - - -- Some headers are comma-separated, others need multiple headers for - -- multiple options. - -- - -- TODO: Right we just comma-separate all of them. - finalize :: (HTTP.HeaderName, [String]) -> [HTTP.Header] - finalize (name, strs) = [HTTP.Header name (intercalate ", " (reverse strs))] - - insert :: Eq a => a -> [b] -> [(a, [b])] -> [(a, [b])] - insert x y = modifyAssocList x (++ y) - - -- modify the first matching element - modifyAssocList :: Eq a => a -> (b -> b) -> [(a, b)] -> [(a, b)] - modifyAssocList a f = go where - go [] = [] - go (p@(a', b) : xs) | a == a' = (a', f b) : xs - | otherwise = p : go xs - -{------------------------------------------------------------------------------- - Custom exceptions --------------------------------------------------------------------------------} - -data UnexpectedResponse = UnexpectedResponse URI Int - deriving (Typeable) - -instance HC.Pretty UnexpectedResponse where - pretty (UnexpectedResponse uri code) = "Unexpected response " ++ show code - ++ " for " ++ show uri - -#if MIN_VERSION_base(4,8,0) -deriving instance Show UnexpectedResponse -instance Exception UnexpectedResponse where displayException = HC.pretty -#else -instance Show UnexpectedResponse where show = HC.pretty -instance Exception UnexpectedResponse -#endif - -wrapCustomEx :: ( ( HC.Throws UnexpectedResponse - , HC.Throws IOException - ) => IO a) - -> (HC.Throws HC.SomeRemoteError => IO a) -wrapCustomEx act = HC.handleChecked (\(ex :: UnexpectedResponse) -> go ex) - $ HC.handleChecked (\(ex :: IOException) -> go ex) - $ act - where - go ex = HC.throwChecked (HC.SomeRemoteError ex) diff --git a/cabal/cabal-install/Distribution/Client/Setup.hs b/cabal/cabal-install/Distribution/Client/Setup.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Setup.hs +++ /dev/null @@ -1,2683 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Setup --- Copyright : (c) David Himmelstrup 2005 --- License : BSD-like --- --- Maintainer : lemmih@gmail.com --- Stability : provisional --- Portability : portable --- --- ------------------------------------------------------------------------------ -module Distribution.Client.Setup - ( globalCommand, GlobalFlags(..), defaultGlobalFlags - , RepoContext(..), withRepoContext - , configureCommand, ConfigFlags(..), configureOptions, filterConfigureFlags - , configPackageDB', configCompilerAux' - , configureExCommand, ConfigExFlags(..), defaultConfigExFlags - , buildCommand, BuildFlags(..) - , filterTestFlags - , replCommand, testCommand, benchmarkCommand, testOptions, benchmarkOptions - , configureExOptions, reconfigureCommand - , installCommand, InstallFlags(..), installOptions, defaultInstallFlags - , filterHaddockArgs, filterHaddockFlags, haddockOptions - , defaultSolver, defaultMaxBackjumps - , listCommand, ListFlags(..), listNeedsCompiler - , updateCommand, UpdateFlags(..), defaultUpdateFlags - , infoCommand, InfoFlags(..) - , fetchCommand, FetchFlags(..) - , freezeCommand, FreezeFlags(..) - , genBoundsCommand - , outdatedCommand, OutdatedFlags(..), IgnoreMajorVersionBumps(..) - , getCommand, unpackCommand, GetFlags(..) - , checkCommand - , formatCommand - , uploadCommand, UploadFlags(..), IsCandidate(..) - , reportCommand, ReportFlags(..) - , runCommand - , initCommand, initOptions, IT.InitFlags(..) - , actAsSetupCommand, ActAsSetupFlags(..) - , execCommand, ExecFlags(..), defaultExecFlags - , userConfigCommand, UserConfigFlags(..) - , manpageCommand - , haddockCommand - , cleanCommand - , doctestCommand - , copyCommand - , registerCommand - - , parsePackageArgs - , liftOptions - , yesNoOpt - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude hiding (get) - -import Distribution.Client.Types.Credentials (Username (..), Password (..)) -import Distribution.Client.Types.Repo (RemoteRepo(..), LocalRepo (..)) -import Distribution.Client.Types.AllowNewer (AllowNewer(..), AllowOlder(..), RelaxDeps(..)) -import Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy - -import Distribution.Client.BuildReports.Types - ( ReportLevel(..) ) -import Distribution.Client.Dependency.Types - ( PreSolver(..) ) -import Distribution.Client.IndexUtils.ActiveRepos - ( ActiveRepos ) -import Distribution.Client.IndexUtils.IndexState - ( TotalIndexState, headTotalIndexState ) -import qualified Distribution.Client.Init.Types as IT - ( InitFlags(..), PackageType(..), defaultInitFlags ) -import Distribution.Client.Targets - ( UserConstraint, readUserConstraint ) -import Distribution.Utils.NubList - ( NubList, toNubList, fromNubList) - -import Distribution.Solver.Types.ConstraintSource -import Distribution.Solver.Types.Settings - -import Distribution.Simple.Compiler ( Compiler, PackageDB, PackageDBStack ) -import Distribution.Simple.Program (ProgramDb, defaultProgramDb) -import Distribution.Simple.Command hiding (boolOpt, boolOpt') -import qualified Distribution.Simple.Command as Command -import Distribution.Simple.Configure - ( configCompilerAuxEx, interpretPackageDbFlags, computeEffectiveProfiling ) -import qualified Distribution.Simple.Setup as Cabal -import Distribution.Simple.Flag - ( Flag(..), toFlag, flagToMaybe, flagToList, maybeToFlag - , flagElim, fromFlagOrDefault - ) -import Distribution.Simple.Setup - ( ConfigFlags(..), BuildFlags(..), ReplFlags - , TestFlags, BenchmarkFlags - , HaddockFlags(..) - , CleanFlags(..), DoctestFlags(..) - , CopyFlags(..), RegisterFlags(..) - , readPackageDbList, showPackageDbList - , BooleanFlag(..), optionVerbosity - , boolOpt, boolOpt', trueArg, falseArg - , optionNumJobs ) -import Distribution.Simple.InstallDirs - ( PathTemplate, InstallDirs(..) - , toPathTemplate, fromPathTemplate, combinePathTemplate ) -import Distribution.Version - ( Version, mkVersion ) -import Distribution.Package - ( PackageName ) -import Distribution.Types.GivenComponent - ( GivenComponent(..) ) -import Distribution.Types.PackageVersionConstraint - ( PackageVersionConstraint(..) ) -import Distribution.Types.UnqualComponentName - ( unqualComponentNameToPackageName ) -import Distribution.PackageDescription - ( BuildType(..), RepoKind(..), LibraryName(..) ) -import Distribution.System ( Platform ) -import Distribution.ReadE - ( ReadE(..), succeedReadE, parsecToReadE ) -import qualified Distribution.Compat.CharParsing as P -import Distribution.Verbosity - ( lessVerbose, normal, verboseNoFlags, verboseNoTimestamp ) -import Distribution.Simple.Utils - ( wrapText ) -import Distribution.Client.GlobalFlags - ( GlobalFlags(..), defaultGlobalFlags - , RepoContext(..), withRepoContext - ) -import Distribution.Client.ManpageFlags (ManpageFlags, defaultManpageFlags, manpageOptions) -import Distribution.FieldGrammar.Newtypes (SpecVersion (..)) - -import Data.List - ( deleteFirstsBy ) -import System.FilePath - ( () ) - -globalCommand :: [Command action] -> CommandUI GlobalFlags -globalCommand commands = CommandUI { - commandName = "", - commandSynopsis = - "Command line interface to the Haskell Cabal infrastructure.", - commandUsage = \pname -> - "See http://www.haskell.org/cabal/ for more information.\n" - ++ "\n" - ++ "Usage: " ++ pname ++ " [GLOBAL FLAGS] [COMMAND [FLAGS]]\n", - commandDescription = Just $ \pname -> - let - commands' = commands ++ [commandAddAction helpCommandUI undefined] - cmdDescs = getNormalCommandDescriptions commands' - -- if new commands are added, we want them to appear even if they - -- are not included in the custom listing below. Thus, we calculate - -- the `otherCmds` list and append it under the `other` category. - -- Alternatively, a new testcase could be added that ensures that - -- the set of commands listed here is equal to the set of commands - -- that are actually available. - otherCmds = deleteFirstsBy (==) (map fst cmdDescs) - [ "help" - , "update" - , "install" - , "fetch" - , "list" - , "info" - , "user-config" - , "get" - , "init" - , "configure" - , "build" - , "clean" - , "run" - , "repl" - , "test" - , "bench" - , "check" - , "sdist" - , "upload" - , "report" - , "freeze" - , "gen-bounds" - , "outdated" - , "haddock" - , "hscolour" - , "exec" - , "new-build" - , "new-configure" - , "new-repl" - , "new-freeze" - , "new-run" - , "new-test" - , "new-bench" - , "new-haddock" - , "new-exec" - , "new-update" - , "new-install" - , "new-clean" - , "new-sdist" - , "list-bin" - -- v1 commands, stateful style - , "v1-build" - , "v1-configure" - , "v1-repl" - , "v1-freeze" - , "v1-run" - , "v1-test" - , "v1-bench" - , "v1-haddock" - , "v1-exec" - , "v1-update" - , "v1-install" - , "v1-clean" - , "v1-sdist" - , "v1-doctest" - , "v1-copy" - , "v1-register" - , "v1-reconfigure" - -- v2 commands, nix-style - , "v2-build" - , "v2-configure" - , "v2-repl" - , "v2-freeze" - , "v2-run" - , "v2-test" - , "v2-bench" - , "v2-haddock" - , "v2-exec" - , "v2-update" - , "v2-install" - , "v2-clean" - , "v2-sdist" - ] - maxlen = maximum $ [length name | (name, _) <- cmdDescs] - align str = str ++ replicate (maxlen - length str) ' ' - startGroup n = " ["++n++"]" - par = "" - addCmd n = case lookup n cmdDescs of - Nothing -> "" - Just d -> " " ++ align n ++ " " ++ d - in - "Commands:\n" - ++ unlines ( - [ startGroup "global" - , addCmd "update" - , addCmd "install" - , par - , addCmd "help" - , addCmd "info" - , addCmd "list" - , addCmd "fetch" - , addCmd "user-config" - , par - , startGroup "package" - , addCmd "get" - , addCmd "init" - , par - , addCmd "configure" - , addCmd "build" - , addCmd "clean" - , par - , addCmd "run" - , addCmd "repl" - , addCmd "test" - , addCmd "bench" - , par - , addCmd "check" - , addCmd "sdist" - , addCmd "upload" - , addCmd "report" - , par - , addCmd "freeze" - , addCmd "gen-bounds" - , addCmd "outdated" - , addCmd "haddock" - , addCmd "hscolour" - , addCmd "exec" - , addCmd "list-bin" - , par - , startGroup "new-style projects (forwards-compatible aliases)" - , addCmd "v2-build" - , addCmd "v2-configure" - , addCmd "v2-repl" - , addCmd "v2-run" - , addCmd "v2-test" - , addCmd "v2-bench" - , addCmd "v2-freeze" - , addCmd "v2-haddock" - , addCmd "v2-exec" - , addCmd "v2-update" - , addCmd "v2-install" - , addCmd "v2-clean" - , addCmd "v2-sdist" - , par - , startGroup "legacy command aliases" - , addCmd "v1-build" - , addCmd "v1-configure" - , addCmd "v1-repl" - , addCmd "v1-run" - , addCmd "v1-test" - , addCmd "v1-bench" - , addCmd "v1-freeze" - , addCmd "v1-haddock" - , addCmd "v1-exec" - , addCmd "v1-update" - , addCmd "v1-install" - , addCmd "v1-clean" - , addCmd "v1-sdist" - , addCmd "v1-doctest" - , addCmd "v1-copy" - , addCmd "v1-register" - , addCmd "v1-reconfigure" - ] ++ if null otherCmds then [] else par - :startGroup "other" - :[addCmd n | n <- otherCmds]) - ++ "\n" - ++ "For more information about a command use:\n" - ++ " " ++ pname ++ " COMMAND --help\n" - ++ "or " ++ pname ++ " help COMMAND\n" - ++ "\n" - ++ "To install Cabal packages from hackage use:\n" - ++ " " ++ pname ++ " install foo [--dry-run]\n" - ++ "\n" - ++ "Occasionally you need to update the list of available packages:\n" - ++ " " ++ pname ++ " update\n", - commandNotes = Nothing, - commandDefaultFlags = mempty, - commandOptions = args - } - where - args :: ShowOrParseArgs -> [OptionField GlobalFlags] - args ShowArgs = argsShown - args ParseArgs = argsShown ++ argsNotShown - - -- arguments we want to show in the help - argsShown :: [OptionField GlobalFlags] - argsShown = [ - option ['V'] ["version"] - "Print version information" - globalVersion (\v flags -> flags { globalVersion = v }) - trueArg - - ,option [] ["numeric-version"] - "Print just the version number" - globalNumericVersion (\v flags -> flags { globalNumericVersion = v }) - trueArg - - ,option [] ["config-file"] - "Set an alternate location for the config file" - globalConfigFile (\v flags -> flags { globalConfigFile = v }) - (reqArgFlag "FILE") - - ,option [] ["default-user-config"] - "Set a location for a cabal.config file for projects without their own cabal.config freeze file." - globalConstraintsFile (\v flags -> flags {globalConstraintsFile = v}) - (reqArgFlag "FILE") - - ,option [] ["ignore-expiry"] - "Ignore expiry dates on signed metadata (use only in exceptional circumstances)" - globalIgnoreExpiry (\v flags -> flags { globalIgnoreExpiry = v }) - trueArg - - ,option [] ["http-transport"] - "Set a transport for http(s) requests. Accepts 'curl', 'wget', 'powershell', and 'plain-http'. (default: 'curl')" - globalHttpTransport (\v flags -> flags { globalHttpTransport = v }) - (reqArgFlag "HttpTransport") - ,option [] ["nix"] - "Nix integration: run commands through nix-shell if a 'shell.nix' file exists" - globalNix (\v flags -> flags { globalNix = v }) - (boolOpt [] []) - - ] - - -- arguments we don't want shown in the help - argsNotShown :: [OptionField GlobalFlags] - argsNotShown = [ - option [] ["remote-repo"] - "The name and url for a remote repository" - globalRemoteRepos (\v flags -> flags { globalRemoteRepos = v }) - (reqArg' "NAME:URL" (toNubList . maybeToList . readRemoteRepo) (map showRemoteRepo . fromNubList)) - - ,option [] ["local-no-index-repo"] - "The name and a path for a local no-index repository" - globalLocalNoIndexRepos (\v flags -> flags { globalLocalNoIndexRepos = v }) - (reqArg' "NAME:PATH" (toNubList . maybeToList . readLocalRepo) (map showLocalRepo . fromNubList)) - - ,option [] ["remote-repo-cache"] - "The location where downloads from all remote repos are cached" - globalCacheDir (\v flags -> flags { globalCacheDir = v }) - (reqArgFlag "DIR") - - ,option [] ["logs-dir", "logsdir"] - "The location to put log files" - globalLogsDir (\v flags -> flags { globalLogsDir = v }) - (reqArgFlag "DIR") - - ,option [] ["world-file"] - "The location of the world file" - globalWorldFile (\v flags -> flags { globalWorldFile = v }) - (reqArgFlag "FILE") - - ,option [] ["store-dir", "storedir"] - "The location of the nix-local-build store" - globalStoreDir (\v flags -> flags { globalStoreDir = v }) - (reqArgFlag "DIR") - - , option [] ["active-repositories"] - "The active package repositories" - globalActiveRepos (\v flags -> flags { globalActiveRepos = v }) - (reqArg "REPOS" (parsecToReadE (\err -> "Error parsing active-repositories: " ++ err) - (toFlag `fmap` parsec)) - (map prettyShow . flagToList)) - ] - --- ------------------------------------------------------------ --- * Config flags --- ------------------------------------------------------------ - -configureCommand :: CommandUI ConfigFlags -configureCommand = c - { commandName = "configure" - , commandDefaultFlags = mempty - , commandDescription = Just $ \_ -> wrapText $ - "Configure how the package is built by setting " - ++ "package (and other) flags.\n" - ++ "\n" - ++ "The configuration affects several other commands, " - ++ "including v1-build, v1-test, v1-bench, v1-run, v1-repl.\n" - , commandUsage = \pname -> - "Usage: " ++ pname ++ " v1-configure [FLAGS]\n" - , commandNotes = Just $ \pname -> - (Cabal.programFlagsDescription defaultProgramDb ++ "\n") - ++ "Examples:\n" - ++ " " ++ pname ++ " v1-configure\n" - ++ " Configure with defaults;\n" - ++ " " ++ pname ++ " v1-configure --enable-tests -fcustomflag\n" - ++ " Configure building package including tests,\n" - ++ " with some package-specific flag.\n" - } - where - c = Cabal.configureCommand defaultProgramDb - -configureOptions :: ShowOrParseArgs -> [OptionField ConfigFlags] -configureOptions = commandOptions configureCommand - --- | Given some 'ConfigFlags' for the version of Cabal that --- cabal-install was built with, and a target older 'Version' of --- Cabal that we want to pass these flags to, convert the --- flags into a form that will be accepted by the older --- Setup script. Generally speaking, this just means filtering --- out flags that the old Cabal library doesn't understand, but --- in some cases it may also mean "emulating" a feature using --- some more legacy flags. -filterConfigureFlags :: ConfigFlags -> Version -> ConfigFlags -filterConfigureFlags flags cabalLibVersion - -- NB: we expect the latest version to be the most common case, - -- so test it first. - | cabalLibVersion >= mkVersion [2,5,0] = flags_latest - -- The naming convention is that flags_version gives flags with - -- all flags *introduced* in version eliminated. - -- It is NOT the latest version of Cabal library that - -- these flags work for; version of introduction is a more - -- natural metric. - | cabalLibVersion < mkVersion [1,3,10] = flags_1_3_10 - | cabalLibVersion < mkVersion [1,10,0] = flags_1_10_0 - | cabalLibVersion < mkVersion [1,12,0] = flags_1_12_0 - | cabalLibVersion < mkVersion [1,14,0] = flags_1_14_0 - | cabalLibVersion < mkVersion [1,18,0] = flags_1_18_0 - | cabalLibVersion < mkVersion [1,19,1] = flags_1_19_1 - | cabalLibVersion < mkVersion [1,19,2] = flags_1_19_2 - | cabalLibVersion < mkVersion [1,21,1] = flags_1_21_1 - | cabalLibVersion < mkVersion [1,22,0] = flags_1_22_0 - | cabalLibVersion < mkVersion [1,22,1] = flags_1_22_1 - | cabalLibVersion < mkVersion [1,23,0] = flags_1_23_0 - | cabalLibVersion < mkVersion [1,25,0] = flags_1_25_0 - | cabalLibVersion < mkVersion [2,1,0] = flags_2_1_0 - | cabalLibVersion < mkVersion [2,5,0] = flags_2_5_0 - | otherwise = error "the impossible just happened" -- see first guard - where - flags_latest = flags { - -- Cabal >= 1.19.1 uses '--dependency' and does not need '--constraint'. - -- Note: this is not in the wrong place. configConstraints gets - -- repopulated in flags_1_19_1 but it needs to be set to empty for - -- newer versions first. - configConstraints = [] - } - - flags_2_5_0 = flags_latest { - -- Cabal < 2.5 does not understand --dependency=pkg:component=cid - -- (public sublibraries), so we convert it to the legacy - -- --dependency=pkg_or_internal_compoent=cid - configDependencies = - let convertToLegacyInternalDep (GivenComponent _ (LSubLibName cn) cid) = - Just $ GivenComponent - (unqualComponentNameToPackageName cn) - LMainLibName - cid - convertToLegacyInternalDep (GivenComponent pn LMainLibName cid) = - Just $ GivenComponent pn LMainLibName cid - in catMaybes $ convertToLegacyInternalDep <$> configDependencies flags - -- Cabal < 2.5 doesn't know about '--allow-depending-on-private-libs'. - , configAllowDependingOnPrivateLibs = NoFlag - -- Cabal < 2.5 doesn't know about '--enable/disable-executable-static'. - , configFullyStaticExe = NoFlag - } - - flags_2_1_0 = flags_2_5_0 { - -- Cabal < 2.1 doesn't know about -v +timestamp modifier - configVerbosity = fmap verboseNoTimestamp (configVerbosity flags_latest) - -- Cabal < 2.1 doesn't know about ---static - , configStaticLib = NoFlag - , configSplitSections = NoFlag - } - - flags_1_25_0 = flags_2_1_0 { - -- Cabal < 1.25.0 doesn't know about --dynlibdir. - configInstallDirs = configInstallDirs_1_25_0, - -- Cabal < 1.25 doesn't have extended verbosity syntax - configVerbosity = fmap verboseNoFlags (configVerbosity flags_2_1_0), - -- Cabal < 1.25 doesn't support --deterministic - configDeterministic = mempty - } - configInstallDirs_1_25_0 = let dirs = configInstallDirs flags in - dirs { dynlibdir = NoFlag - , libexecsubdir = NoFlag - , libexecdir = maybeToFlag $ - combinePathTemplate <$> flagToMaybe (libexecdir dirs) - <*> flagToMaybe (libexecsubdir dirs) - } - -- Cabal < 1.23 doesn't know about '--profiling-detail'. - -- Cabal < 1.23 has a hacked up version of 'enable-profiling' - -- which we shouldn't use. - (tryLibProfiling, tryExeProfiling) = computeEffectiveProfiling flags - flags_1_23_0 = flags_1_25_0 { configProfDetail = NoFlag - , configProfLibDetail = NoFlag - , configIPID = NoFlag - , configProf = NoFlag - , configProfExe = Flag tryExeProfiling - , configProfLib = Flag tryLibProfiling - } - - -- Cabal == 1.22.0.* had a discontinuity (see #5946 or e9a8d48a3adce34d) - -- due to temporary amnesia of the --*-executable-profiling flags - flags_1_22_1 = flags_1_23_0 { configDebugInfo = NoFlag - , configProfExe = NoFlag - } - - -- Cabal < 1.22 doesn't know about '--disable-debug-info'. - flags_1_22_0 = flags_1_23_0 { configDebugInfo = NoFlag } - - -- Cabal < 1.21.1 doesn't know about 'disable-relocatable' - -- Cabal < 1.21.1 doesn't know about 'enable-profiling' - -- (but we already dealt with it in flags_1_23_0) - flags_1_21_1 = - flags_1_22_0 { configRelocatable = NoFlag - , configCoverage = NoFlag - , configLibCoverage = configCoverage flags - } - -- Cabal < 1.19.2 doesn't know about '--exact-configuration' and - -- '--enable-library-stripping'. - flags_1_19_2 = flags_1_21_1 { configExactConfiguration = NoFlag - , configStripLibs = NoFlag } - -- Cabal < 1.19.1 uses '--constraint' instead of '--dependency'. - flags_1_19_1 = flags_1_19_2 { configDependencies = [] - , configConstraints = configConstraints flags } - -- Cabal < 1.18.0 doesn't know about --extra-prog-path and --sysconfdir. - flags_1_18_0 = flags_1_19_1 { configProgramPathExtra = toNubList [] - , configInstallDirs = configInstallDirs_1_18_0} - configInstallDirs_1_18_0 = (configInstallDirs flags_1_19_1) { sysconfdir = NoFlag } - -- Cabal < 1.14.0 doesn't know about '--disable-benchmarks'. - flags_1_14_0 = flags_1_18_0 { configBenchmarks = NoFlag } - -- Cabal < 1.12.0 doesn't know about '--enable/disable-executable-dynamic' - -- and '--enable/disable-library-coverage'. - flags_1_12_0 = flags_1_14_0 { configLibCoverage = NoFlag - , configDynExe = NoFlag } - -- Cabal < 1.10.0 doesn't know about '--disable-tests'. - flags_1_10_0 = flags_1_12_0 { configTests = NoFlag } - -- Cabal < 1.3.10 does not grok the '--constraints' flag. - flags_1_3_10 = flags_1_10_0 { configConstraints = [] } - --- | Get the package database settings from 'ConfigFlags', accounting for --- @--package-db@ and @--user@ flags. -configPackageDB' :: ConfigFlags -> PackageDBStack -configPackageDB' cfg = - interpretPackageDbFlags userInstall (configPackageDBs cfg) - where - userInstall = Cabal.fromFlagOrDefault True (configUserInstall cfg) - --- | Configure the compiler, but reduce verbosity during this step. -configCompilerAux' :: ConfigFlags -> IO (Compiler, Platform, ProgramDb) -configCompilerAux' configFlags = - configCompilerAuxEx configFlags - --FIXME: make configCompilerAux use a sensible verbosity - { configVerbosity = fmap lessVerbose (configVerbosity configFlags) } - --- ------------------------------------------------------------ --- * Config extra flags --- ------------------------------------------------------------ - --- | cabal configure takes some extra flags beyond runghc Setup configure --- -data ConfigExFlags = ConfigExFlags { - configCabalVersion :: Flag Version, - configExConstraints :: [(UserConstraint, ConstraintSource)], - configPreferences :: [PackageVersionConstraint], - configSolver :: Flag PreSolver, - configAllowNewer :: Maybe AllowNewer, - configAllowOlder :: Maybe AllowOlder, - configWriteGhcEnvironmentFilesPolicy - :: Flag WriteGhcEnvironmentFilesPolicy - } - deriving (Eq, Show, Generic) - -defaultConfigExFlags :: ConfigExFlags -defaultConfigExFlags = mempty { configSolver = Flag defaultSolver } - -configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags) -configureExCommand = configureCommand { - commandDefaultFlags = (mempty, defaultConfigExFlags), - commandOptions = \showOrParseArgs -> - liftOptions fst setFst - (filter ((`notElem` ["constraint", "dependency", "exact-configuration"]) - . optionName) $ configureOptions showOrParseArgs) - ++ liftOptions snd setSnd - (configureExOptions showOrParseArgs ConstraintSourceCommandlineFlag) - } - where - setFst a (_,b) = (a,b) - setSnd b (a,_) = (a,b) - -configureExOptions :: ShowOrParseArgs - -> ConstraintSource - -> [OptionField ConfigExFlags] -configureExOptions _showOrParseArgs src = - [ option [] ["cabal-lib-version"] - ("Select which version of the Cabal lib to use to build packages " - ++ "(useful for testing).") - configCabalVersion (\v flags -> flags { configCabalVersion = v }) - (reqArg "VERSION" (parsecToReadE ("Cannot parse cabal lib version: "++) - (fmap toFlag parsec)) - (map prettyShow. flagToList)) - , option [] ["constraint"] - "Specify constraints on a package (version, installed/source, flags)" - configExConstraints (\v flags -> flags { configExConstraints = v }) - (reqArg "CONSTRAINT" - ((\x -> [(x, src)]) `fmap` ReadE readUserConstraint) - (map $ prettyShow . fst)) - - , option [] ["preference"] - "Specify preferences (soft constraints) on the version of a package" - configPreferences (\v flags -> flags { configPreferences = v }) - (reqArg "CONSTRAINT" - (parsecToReadE (const "dependency expected") - (fmap (\x -> [x]) parsec)) - (map prettyShow)) - - , optionSolver configSolver (\v flags -> flags { configSolver = v }) - - , option [] ["allow-older"] - ("Ignore lower bounds in all dependencies or DEPS") - (fmap unAllowOlder . configAllowOlder) - (\v flags -> flags { configAllowOlder = fmap AllowOlder v}) - (optArg "DEPS" - (parsecToReadE ("Cannot parse the list of packages: " ++) relaxDepsParser) - (Just RelaxDepsAll) relaxDepsPrinter) - - , option [] ["allow-newer"] - ("Ignore upper bounds in all dependencies or DEPS") - (fmap unAllowNewer . configAllowNewer) - (\v flags -> flags { configAllowNewer = fmap AllowNewer v}) - (optArg "DEPS" - (parsecToReadE ("Cannot parse the list of packages: " ++) relaxDepsParser) - (Just RelaxDepsAll) relaxDepsPrinter) - - , option [] ["write-ghc-environment-files"] - ("Whether to create a .ghc.environment file after a successful build" - ++ " (v2-build only)") - configWriteGhcEnvironmentFilesPolicy - (\v flags -> flags { configWriteGhcEnvironmentFilesPolicy = v}) - (reqArg "always|never|ghc8.4.4+" - writeGhcEnvironmentFilesPolicyParser - writeGhcEnvironmentFilesPolicyPrinter) - ] - - -writeGhcEnvironmentFilesPolicyParser :: ReadE (Flag WriteGhcEnvironmentFilesPolicy) -writeGhcEnvironmentFilesPolicyParser = ReadE $ \case - "always" -> Right $ Flag AlwaysWriteGhcEnvironmentFiles - "never" -> Right $ Flag NeverWriteGhcEnvironmentFiles - "ghc8.4.4+" -> Right $ Flag WriteGhcEnvironmentFilesOnlyForGhc844AndNewer - policy -> Left $ "Cannot parse the GHC environment file write policy '" - <> policy <> "'" - -writeGhcEnvironmentFilesPolicyPrinter - :: Flag WriteGhcEnvironmentFilesPolicy -> [String] -writeGhcEnvironmentFilesPolicyPrinter = \case - (Flag AlwaysWriteGhcEnvironmentFiles) -> ["always"] - (Flag NeverWriteGhcEnvironmentFiles) -> ["never"] - (Flag WriteGhcEnvironmentFilesOnlyForGhc844AndNewer) -> ["ghc8.4.4+"] - NoFlag -> [] - - -relaxDepsParser :: CabalParsing m => m (Maybe RelaxDeps) -relaxDepsParser = - (Just . RelaxDepsSome . toList) `fmap` P.sepByNonEmpty parsec (P.char ',') - -relaxDepsPrinter :: (Maybe RelaxDeps) -> [Maybe String] -relaxDepsPrinter Nothing = [] -relaxDepsPrinter (Just RelaxDepsAll) = [Nothing] -relaxDepsPrinter (Just (RelaxDepsSome pkgs)) = map (Just . prettyShow) $ pkgs - - -instance Monoid ConfigExFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup ConfigExFlags where - (<>) = gmappend - -reconfigureCommand :: CommandUI (ConfigFlags, ConfigExFlags) -reconfigureCommand - = configureExCommand - { commandName = "reconfigure" - , commandSynopsis = "Reconfigure the package if necessary." - , commandDescription = Just $ \pname -> wrapText $ - "Run `configure` with the most recently used flags, or append FLAGS " - ++ "to the most recently used configuration. " - ++ "Accepts the same flags as `" ++ pname ++ " v1-configure'. " - ++ "If the package has never been configured, the default flags are " - ++ "used." - , commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " v1-reconfigure\n" - ++ " Configure with the most recently used flags.\n" - ++ " " ++ pname ++ " v1-reconfigure -w PATH\n" - ++ " Reconfigure with the most recently used flags,\n" - ++ " but use the compiler at PATH.\n\n" - , commandUsage = usageAlternatives "v1-reconfigure" [ "[FLAGS]" ] - , commandDefaultFlags = mempty - } - --- ------------------------------------------------------------ --- * Build flags --- ------------------------------------------------------------ - -buildCommand :: CommandUI BuildFlags -buildCommand = parent { - commandName = "build", - commandDescription = Just $ \_ -> wrapText $ - "Components encompass executables, tests, and benchmarks.\n" - ++ "\n" - ++ "Affected by configuration options, see `v1-configure`.\n", - commandDefaultFlags = commandDefaultFlags parent, - commandUsage = usageAlternatives "v1-build" $ - [ "[FLAGS]", "COMPONENTS [FLAGS]" ], - commandOptions = commandOptions parent - , commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " v1-build " - ++ " All the components in the package\n" - ++ " " ++ pname ++ " v1-build foo " - ++ " A component (i.e. lib, exe, test suite)\n\n" - ++ Cabal.programFlagsDescription defaultProgramDb - } - where - parent = Cabal.buildCommand defaultProgramDb - --- ------------------------------------------------------------ --- * Test flags --- ------------------------------------------------------------ - --- | Given some 'TestFlags' for the version of Cabal that --- cabal-install was built with, and a target older 'Version' of --- Cabal that we want to pass these flags to, convert the --- flags into a form that will be accepted by the older --- Setup script. Generally speaking, this just means filtering --- out flags that the old Cabal library doesn't understand, but --- in some cases it may also mean "emulating" a feature using --- some more legacy flags. -filterTestFlags :: TestFlags -> Version -> TestFlags -filterTestFlags flags cabalLibVersion - -- NB: we expect the latest version to be the most common case, - -- so test it first. - | cabalLibVersion >= mkVersion [3,0,0] = flags_latest - -- The naming convention is that flags_version gives flags with - -- all flags *introduced* in version eliminated. - -- It is NOT the latest version of Cabal library that - -- these flags work for; version of introduction is a more - -- natural metric. - | cabalLibVersion < mkVersion [3,0,0] = flags_3_0_0 - | otherwise = error "the impossible just happened" -- see first guard - where - flags_latest = flags - flags_3_0_0 = flags_latest { - -- Cabal < 3.0 doesn't know about --test-wrapper - Cabal.testWrapper = NoFlag - } - --- ------------------------------------------------------------ --- * Repl command --- ------------------------------------------------------------ - -replCommand :: CommandUI ReplFlags -replCommand = parent { - commandName = "repl", - commandDescription = Just $ \pname -> wrapText $ - "If the current directory contains no package, ignores COMPONENT " - ++ "parameters and opens an interactive interpreter session;\n" - ++ "\n" - ++ "Otherwise, (re)configures with the given or default flags, and " - ++ "loads the interpreter with the relevant modules. For executables, " - ++ "tests and benchmarks, loads the main module (and its " - ++ "dependencies); for libraries all exposed/other modules.\n" - ++ "\n" - ++ "The default component is the library itself, or the executable " - ++ "if that is the only component.\n" - ++ "\n" - ++ "Support for loading specific modules is planned but not " - ++ "implemented yet. For certain scenarios, `" ++ pname - ++ " v1-exec -- ghci :l Foo` may be used instead. Note that `v1-exec` will " - ++ "not (re)configure and you will have to specify the location of " - ++ "other modules, if required.\n", - commandUsage = \pname -> "Usage: " ++ pname ++ " v1-repl [COMPONENT] [FLAGS]\n", - commandDefaultFlags = commandDefaultFlags parent, - commandOptions = commandOptions parent, - commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " v1-repl " - ++ " The first component in the package\n" - ++ " " ++ pname ++ " v1-repl foo " - ++ " A named component (i.e. lib, exe, test suite)\n" - ++ " " ++ pname ++ " v1-repl --ghc-options=\"-lstdc++\"" - ++ " Specifying flags for interpreter\n" - } - where - parent = Cabal.replCommand defaultProgramDb - --- ------------------------------------------------------------ --- * Test command --- ------------------------------------------------------------ - -testCommand :: CommandUI (BuildFlags, TestFlags) -testCommand = parent { - commandName = "test", - commandDescription = Just $ \pname -> wrapText $ - "If necessary (re)configures with `--enable-tests` flag and builds" - ++ " the test suite.\n" - ++ "\n" - ++ "Remember that the tests' dependencies must be installed if there" - ++ " are additional ones; e.g. with `" ++ pname - ++ " v1-install --only-dependencies --enable-tests`.\n" - ++ "\n" - ++ "By defining UserHooks in a custom Setup.hs, the package can" - ++ " define actions to be executed before and after running tests.\n", - commandUsage = usageAlternatives "v1-test" - [ "[FLAGS]", "TESTCOMPONENTS [FLAGS]" ], - commandDefaultFlags = (Cabal.defaultBuildFlags, commandDefaultFlags parent), - commandOptions = - \showOrParseArgs -> liftOptions get1 set1 - (Cabal.buildOptions progDb showOrParseArgs) - ++ - liftOptions get2 set2 - (commandOptions parent showOrParseArgs) - } - where - get1 (a,_) = a; set1 a (_,b) = (a,b) - get2 (_,b) = b; set2 b (a,_) = (a,b) - - parent = Cabal.testCommand - progDb = defaultProgramDb - --- ------------------------------------------------------------ --- * Bench command --- ------------------------------------------------------------ - -benchmarkCommand :: CommandUI (BuildFlags, BenchmarkFlags) -benchmarkCommand = parent { - commandName = "bench", - commandUsage = usageAlternatives "v1-bench" - [ "[FLAGS]", "BENCHCOMPONENTS [FLAGS]" ], - commandDescription = Just $ \pname -> wrapText $ - "If necessary (re)configures with `--enable-benchmarks` flag and" - ++ " builds the benchmarks.\n" - ++ "\n" - ++ "Remember that the benchmarks' dependencies must be installed if" - ++ " there are additional ones; e.g. with `" ++ pname - ++ " v1-install --only-dependencies --enable-benchmarks`.\n" - ++ "\n" - ++ "By defining UserHooks in a custom Setup.hs, the package can" - ++ " define actions to be executed before and after running" - ++ " benchmarks.\n", - commandDefaultFlags = (Cabal.defaultBuildFlags, commandDefaultFlags parent), - commandOptions = - \showOrParseArgs -> liftOptions get1 set1 - (Cabal.buildOptions progDb showOrParseArgs) - ++ - liftOptions get2 set2 - (commandOptions parent showOrParseArgs) - } - where - get1 (a,_) = a; set1 a (_,b) = (a,b) - get2 (_,b) = b; set2 b (a,_) = (a,b) - - parent = Cabal.benchmarkCommand - progDb = defaultProgramDb - --- ------------------------------------------------------------ --- * Fetch command --- ------------------------------------------------------------ - -data FetchFlags = FetchFlags { --- fetchOutput :: Flag FilePath, - fetchDeps :: Flag Bool, - fetchDryRun :: Flag Bool, - fetchSolver :: Flag PreSolver, - fetchMaxBackjumps :: Flag Int, - fetchReorderGoals :: Flag ReorderGoals, - fetchCountConflicts :: Flag CountConflicts, - fetchFineGrainedConflicts :: Flag FineGrainedConflicts, - fetchMinimizeConflictSet :: Flag MinimizeConflictSet, - fetchIndependentGoals :: Flag IndependentGoals, - fetchShadowPkgs :: Flag ShadowPkgs, - fetchStrongFlags :: Flag StrongFlags, - fetchAllowBootLibInstalls :: Flag AllowBootLibInstalls, - fetchOnlyConstrained :: Flag OnlyConstrained, - fetchTests :: Flag Bool, - fetchBenchmarks :: Flag Bool, - fetchVerbosity :: Flag Verbosity - } - -defaultFetchFlags :: FetchFlags -defaultFetchFlags = FetchFlags { --- fetchOutput = mempty, - fetchDeps = toFlag True, - fetchDryRun = toFlag False, - fetchSolver = Flag defaultSolver, - fetchMaxBackjumps = Flag defaultMaxBackjumps, - fetchReorderGoals = Flag (ReorderGoals False), - fetchCountConflicts = Flag (CountConflicts True), - fetchFineGrainedConflicts = Flag (FineGrainedConflicts True), - fetchMinimizeConflictSet = Flag (MinimizeConflictSet False), - fetchIndependentGoals = Flag (IndependentGoals False), - fetchShadowPkgs = Flag (ShadowPkgs False), - fetchStrongFlags = Flag (StrongFlags False), - fetchAllowBootLibInstalls = Flag (AllowBootLibInstalls False), - fetchOnlyConstrained = Flag OnlyConstrainedNone, - fetchTests = toFlag False, - fetchBenchmarks = toFlag False, - fetchVerbosity = toFlag normal - } - -fetchCommand :: CommandUI FetchFlags -fetchCommand = CommandUI { - commandName = "fetch", - commandSynopsis = "Downloads packages for later installation.", - commandUsage = usageAlternatives "fetch" [ "[FLAGS] PACKAGES" - ], - commandDescription = Just $ \_ -> - "Note that it currently is not possible to fetch the dependencies for a\n" - ++ "package in the current directory.\n", - commandNotes = Nothing, - commandDefaultFlags = defaultFetchFlags, - commandOptions = \ showOrParseArgs -> [ - optionVerbosity fetchVerbosity (\v flags -> flags { fetchVerbosity = v }) - --- , option "o" ["output"] --- "Put the package(s) somewhere specific rather than the usual cache." --- fetchOutput (\v flags -> flags { fetchOutput = v }) --- (reqArgFlag "PATH") - - , option [] ["dependencies", "deps"] - "Resolve and fetch dependencies (default)" - fetchDeps (\v flags -> flags { fetchDeps = v }) - trueArg - - , option [] ["no-dependencies", "no-deps"] - "Ignore dependencies" - fetchDeps (\v flags -> flags { fetchDeps = v }) - falseArg - - , option [] ["dry-run"] - "Do not install anything, only print what would be installed." - fetchDryRun (\v flags -> flags { fetchDryRun = v }) - trueArg - - , option "" ["tests"] - "dependency checking and compilation for test suites listed in the package description file." - fetchTests (\v flags -> flags { fetchTests = v }) - (boolOpt [] []) - - , option "" ["benchmarks"] - "dependency checking and compilation for benchmarks listed in the package description file." - fetchBenchmarks (\v flags -> flags { fetchBenchmarks = v }) - (boolOpt [] []) - - ] ++ - - optionSolver fetchSolver (\v flags -> flags { fetchSolver = v }) : - optionSolverFlags showOrParseArgs - fetchMaxBackjumps (\v flags -> flags { fetchMaxBackjumps = v }) - fetchReorderGoals (\v flags -> flags { fetchReorderGoals = v }) - fetchCountConflicts (\v flags -> flags { fetchCountConflicts = v }) - fetchFineGrainedConflicts (\v flags -> flags { fetchFineGrainedConflicts = v }) - fetchMinimizeConflictSet (\v flags -> flags { fetchMinimizeConflictSet = v }) - fetchIndependentGoals (\v flags -> flags { fetchIndependentGoals = v }) - fetchShadowPkgs (\v flags -> flags { fetchShadowPkgs = v }) - fetchStrongFlags (\v flags -> flags { fetchStrongFlags = v }) - fetchAllowBootLibInstalls (\v flags -> flags { fetchAllowBootLibInstalls = v }) - fetchOnlyConstrained (\v flags -> flags { fetchOnlyConstrained = v }) - - } - --- ------------------------------------------------------------ --- * Freeze command --- ------------------------------------------------------------ - -data FreezeFlags = FreezeFlags { - freezeDryRun :: Flag Bool, - freezeTests :: Flag Bool, - freezeBenchmarks :: Flag Bool, - freezeSolver :: Flag PreSolver, - freezeMaxBackjumps :: Flag Int, - freezeReorderGoals :: Flag ReorderGoals, - freezeCountConflicts :: Flag CountConflicts, - freezeFineGrainedConflicts :: Flag FineGrainedConflicts, - freezeMinimizeConflictSet :: Flag MinimizeConflictSet, - freezeIndependentGoals :: Flag IndependentGoals, - freezeShadowPkgs :: Flag ShadowPkgs, - freezeStrongFlags :: Flag StrongFlags, - freezeAllowBootLibInstalls :: Flag AllowBootLibInstalls, - freezeOnlyConstrained :: Flag OnlyConstrained, - freezeVerbosity :: Flag Verbosity - } - -defaultFreezeFlags :: FreezeFlags -defaultFreezeFlags = FreezeFlags { - freezeDryRun = toFlag False, - freezeTests = toFlag False, - freezeBenchmarks = toFlag False, - freezeSolver = Flag defaultSolver, - freezeMaxBackjumps = Flag defaultMaxBackjumps, - freezeReorderGoals = Flag (ReorderGoals False), - freezeCountConflicts = Flag (CountConflicts True), - freezeFineGrainedConflicts = Flag (FineGrainedConflicts True), - freezeMinimizeConflictSet = Flag (MinimizeConflictSet False), - freezeIndependentGoals = Flag (IndependentGoals False), - freezeShadowPkgs = Flag (ShadowPkgs False), - freezeStrongFlags = Flag (StrongFlags False), - freezeAllowBootLibInstalls = Flag (AllowBootLibInstalls False), - freezeOnlyConstrained = Flag OnlyConstrainedNone, - freezeVerbosity = toFlag normal - } - -freezeCommand :: CommandUI FreezeFlags -freezeCommand = CommandUI { - commandName = "freeze", - commandSynopsis = "Freeze dependencies.", - commandDescription = Just $ \_ -> wrapText $ - "Calculates a valid set of dependencies and their exact versions. " - ++ "If successful, saves the result to the file `cabal.config`.\n" - ++ "\n" - ++ "The package versions specified in `cabal.config` will be used for " - ++ "any future installs.\n" - ++ "\n" - ++ "An existing `cabal.config` is ignored and overwritten.\n", - commandNotes = Nothing, - commandUsage = usageFlags "freeze", - commandDefaultFlags = defaultFreezeFlags, - commandOptions = \ showOrParseArgs -> [ - optionVerbosity freezeVerbosity - (\v flags -> flags { freezeVerbosity = v }) - - , option [] ["dry-run"] - "Do not freeze anything, only print what would be frozen" - freezeDryRun (\v flags -> flags { freezeDryRun = v }) - trueArg - - , option [] ["tests"] - ("freezing of the dependencies of any tests suites " - ++ "in the package description file.") - freezeTests (\v flags -> flags { freezeTests = v }) - (boolOpt [] []) - - , option [] ["benchmarks"] - ("freezing of the dependencies of any benchmarks suites " - ++ "in the package description file.") - freezeBenchmarks (\v flags -> flags { freezeBenchmarks = v }) - (boolOpt [] []) - - ] ++ - - optionSolver - freezeSolver (\v flags -> flags { freezeSolver = v }): - optionSolverFlags showOrParseArgs - freezeMaxBackjumps (\v flags -> flags { freezeMaxBackjumps = v }) - freezeReorderGoals (\v flags -> flags { freezeReorderGoals = v }) - freezeCountConflicts (\v flags -> flags { freezeCountConflicts = v }) - freezeFineGrainedConflicts (\v flags -> flags { freezeFineGrainedConflicts = v }) - freezeMinimizeConflictSet (\v flags -> flags { freezeMinimizeConflictSet = v }) - freezeIndependentGoals (\v flags -> flags { freezeIndependentGoals = v }) - freezeShadowPkgs (\v flags -> flags { freezeShadowPkgs = v }) - freezeStrongFlags (\v flags -> flags { freezeStrongFlags = v }) - freezeAllowBootLibInstalls (\v flags -> flags { freezeAllowBootLibInstalls = v }) - freezeOnlyConstrained (\v flags -> flags { freezeOnlyConstrained = v }) - - } - --- ------------------------------------------------------------ --- * 'gen-bounds' command --- ------------------------------------------------------------ - -genBoundsCommand :: CommandUI FreezeFlags -genBoundsCommand = CommandUI { - commandName = "gen-bounds", - commandSynopsis = "Generate dependency bounds.", - commandDescription = Just $ \_ -> wrapText $ - "Generates bounds for all dependencies that do not currently have them. " - ++ "Generated bounds are printed to stdout. " - ++ "You can then paste them into your .cabal file.\n" - ++ "\n", - commandNotes = Nothing, - commandUsage = usageFlags "gen-bounds", - commandDefaultFlags = defaultFreezeFlags, - commandOptions = \ _ -> [ - optionVerbosity freezeVerbosity (\v flags -> flags { freezeVerbosity = v }) - ] - } - --- ------------------------------------------------------------ --- * 'outdated' command --- ------------------------------------------------------------ - -data IgnoreMajorVersionBumps = IgnoreMajorVersionBumpsNone - | IgnoreMajorVersionBumpsAll - | IgnoreMajorVersionBumpsSome [PackageName] - -instance Monoid IgnoreMajorVersionBumps where - mempty = IgnoreMajorVersionBumpsNone - mappend = (<>) - -instance Semigroup IgnoreMajorVersionBumps where - IgnoreMajorVersionBumpsNone <> r = r - l@IgnoreMajorVersionBumpsAll <> _ = l - l@(IgnoreMajorVersionBumpsSome _) <> IgnoreMajorVersionBumpsNone = l - (IgnoreMajorVersionBumpsSome _) <> r@IgnoreMajorVersionBumpsAll = r - (IgnoreMajorVersionBumpsSome a) <> (IgnoreMajorVersionBumpsSome b) = - IgnoreMajorVersionBumpsSome (a ++ b) - -data OutdatedFlags = OutdatedFlags { - outdatedVerbosity :: Flag Verbosity, - outdatedFreezeFile :: Flag Bool, - outdatedNewFreezeFile :: Flag Bool, - outdatedProjectFile :: Flag FilePath, - outdatedSimpleOutput :: Flag Bool, - outdatedExitCode :: Flag Bool, - outdatedQuiet :: Flag Bool, - outdatedIgnore :: [PackageName], - outdatedMinor :: Maybe IgnoreMajorVersionBumps - } - -defaultOutdatedFlags :: OutdatedFlags -defaultOutdatedFlags = OutdatedFlags { - outdatedVerbosity = toFlag normal, - outdatedFreezeFile = mempty, - outdatedNewFreezeFile = mempty, - outdatedProjectFile = mempty, - outdatedSimpleOutput = mempty, - outdatedExitCode = mempty, - outdatedQuiet = mempty, - outdatedIgnore = mempty, - outdatedMinor = mempty - } - -outdatedCommand :: CommandUI OutdatedFlags -outdatedCommand = CommandUI { - commandName = "outdated", - commandSynopsis = "Check for outdated dependencies", - commandDescription = Just $ \_ -> wrapText $ - "Checks for outdated dependencies in the package description file " - ++ "or freeze file", - commandNotes = Nothing, - commandUsage = usageFlags "outdated", - commandDefaultFlags = defaultOutdatedFlags, - commandOptions = \ _ -> [ - optionVerbosity outdatedVerbosity - (\v flags -> flags { outdatedVerbosity = v }) - - ,option [] ["freeze-file", "v1-freeze-file"] - "Act on the freeze file" - outdatedFreezeFile (\v flags -> flags { outdatedFreezeFile = v }) - trueArg - - ,option [] ["v2-freeze-file", "new-freeze-file"] - "Act on the new-style freeze file (default: cabal.project.freeze)" - outdatedNewFreezeFile (\v flags -> flags { outdatedNewFreezeFile = v }) - trueArg - - ,option [] ["project-file"] - "Act on the new-style freeze file named PROJECTFILE.freeze rather than the default cabal.project.freeze" - outdatedProjectFile (\v flags -> flags { outdatedProjectFile = v }) - (reqArgFlag "PROJECTFILE") - - ,option [] ["simple-output"] - "Only print names of outdated dependencies, one per line" - outdatedSimpleOutput (\v flags -> flags { outdatedSimpleOutput = v }) - trueArg - - ,option [] ["exit-code"] - "Exit with non-zero when there are outdated dependencies" - outdatedExitCode (\v flags -> flags { outdatedExitCode = v }) - trueArg - - ,option ['q'] ["quiet"] - "Don't print any output. Implies '--exit-code' and '-v0'" - outdatedQuiet (\v flags -> flags { outdatedQuiet = v }) - trueArg - - ,option [] ["ignore"] - "Packages to ignore" - outdatedIgnore (\v flags -> flags { outdatedIgnore = v }) - (reqArg "PKGS" pkgNameListParser (map prettyShow)) - - ,option [] ["minor"] - "Ignore major version bumps for these packages" - outdatedMinor (\v flags -> flags { outdatedMinor = v }) - (optArg "PKGS" ignoreMajorVersionBumpsParser - (Just IgnoreMajorVersionBumpsAll) ignoreMajorVersionBumpsPrinter) - ] - } - where - ignoreMajorVersionBumpsPrinter :: (Maybe IgnoreMajorVersionBumps) - -> [Maybe String] - ignoreMajorVersionBumpsPrinter Nothing = [] - ignoreMajorVersionBumpsPrinter (Just IgnoreMajorVersionBumpsNone)= [] - ignoreMajorVersionBumpsPrinter (Just IgnoreMajorVersionBumpsAll) = [Nothing] - ignoreMajorVersionBumpsPrinter (Just (IgnoreMajorVersionBumpsSome pkgs)) = - map (Just . prettyShow) $ pkgs - - ignoreMajorVersionBumpsParser = - (Just . IgnoreMajorVersionBumpsSome) `fmap` pkgNameListParser - - pkgNameListParser = parsecToReadE - ("Couldn't parse the list of package names: " ++) - (fmap toList (P.sepByNonEmpty parsec (P.char ','))) - --- ------------------------------------------------------------ --- * Update command --- ------------------------------------------------------------ - -data UpdateFlags - = UpdateFlags { - updateVerbosity :: Flag Verbosity, - updateIndexState :: Flag TotalIndexState - } deriving Generic - -defaultUpdateFlags :: UpdateFlags -defaultUpdateFlags - = UpdateFlags { - updateVerbosity = toFlag normal, - updateIndexState = toFlag headTotalIndexState - } - -updateCommand :: CommandUI UpdateFlags -updateCommand = CommandUI { - commandName = "update", - commandSynopsis = "Updates list of known packages.", - commandDescription = Just $ \_ -> - "For all known remote repositories, download the package list.\n", - commandNotes = Just $ \_ -> - relevantConfigValuesText ["remote-repo" - ,"remote-repo-cache" - ,"local-repo"], - commandUsage = usageFlags "v1-update", - commandDefaultFlags = defaultUpdateFlags, - commandOptions = \_ -> [ - optionVerbosity updateVerbosity (\v flags -> flags { updateVerbosity = v }), - option [] ["index-state"] - ("Update the source package index to its state as it existed at a previous time. " ++ - "Accepts unix-timestamps (e.g. '@1474732068'), ISO8601 UTC timestamps " ++ - "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD' (default: 'HEAD').") - updateIndexState (\v flags -> flags { updateIndexState = v }) - (reqArg "STATE" (parsecToReadE (const $ "index-state must be a " ++ - "unix-timestamps (e.g. '@1474732068'), " ++ - "a ISO8601 UTC timestamp " ++ - "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD'") - (toFlag `fmap` parsec)) - (flagToList . fmap prettyShow)) - ] - } - --- ------------------------------------------------------------ --- * Other commands --- ------------------------------------------------------------ - -cleanCommand :: CommandUI CleanFlags -cleanCommand = Cabal.cleanCommand - { commandUsage = \pname -> - "Usage: " ++ pname ++ " v1-clean [FLAGS]\n" - } - -checkCommand :: CommandUI (Flag Verbosity) -checkCommand = CommandUI { - commandName = "check", - commandSynopsis = "Check the package for common mistakes.", - commandDescription = Just $ \_ -> wrapText $ - "Expects a .cabal package file in the current directory.\n" - ++ "\n" - ++ "The checks correspond to the requirements to packages on Hackage. " - ++ "If no errors and warnings are reported, Hackage will accept this " - ++ "package.\n", - commandNotes = Nothing, - commandUsage = usageFlags "check", - commandDefaultFlags = toFlag normal, - commandOptions = \_ -> [optionVerbosity id const] - } - -formatCommand :: CommandUI (Flag Verbosity) -formatCommand = CommandUI { - commandName = "format", - commandSynopsis = "Reformat the .cabal file using the standard style.", - commandDescription = Nothing, - commandNotes = Nothing, - commandUsage = usageAlternatives "format" ["[FILE]"], - commandDefaultFlags = toFlag normal, - commandOptions = \_ -> [] - } - -manpageCommand :: CommandUI ManpageFlags -manpageCommand = CommandUI { - commandName = "man", - commandSynopsis = "Outputs manpage source.", - commandDescription = Just $ \_ -> - "Output manpage source to STDOUT.\n", - commandNotes = Nothing, - commandUsage = usageFlags "man", - commandDefaultFlags = defaultManpageFlags, - commandOptions = manpageOptions - } - -runCommand :: CommandUI BuildFlags -runCommand = CommandUI { - commandName = "run", - commandSynopsis = "Builds and runs an executable.", - commandDescription = Just $ \pname -> wrapText $ - "Builds and then runs the specified executable. If no executable is " - ++ "specified, but the package contains just one executable, that one " - ++ "is built and executed.\n" - ++ "\n" - ++ "Use `" ++ pname ++ " v1-test --show-details=streaming` to run a " - ++ "test-suite and get its full output.\n", - commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " v1-run\n" - ++ " Run the only executable in the current package;\n" - ++ " " ++ pname ++ " v1-run foo -- --fooflag\n" - ++ " Works similar to `./foo --fooflag`.\n", - commandUsage = usageAlternatives "v1-run" - ["[FLAGS] [EXECUTABLE] [-- EXECUTABLE_FLAGS]"], - commandDefaultFlags = mempty, - commandOptions = commandOptions parent - } - where - parent = Cabal.buildCommand defaultProgramDb - --- ------------------------------------------------------------ --- * Report flags --- ------------------------------------------------------------ - -data ReportFlags = ReportFlags { - reportUsername :: Flag Username, - reportPassword :: Flag Password, - reportVerbosity :: Flag Verbosity - } deriving Generic - -defaultReportFlags :: ReportFlags -defaultReportFlags = ReportFlags { - reportUsername = mempty, - reportPassword = mempty, - reportVerbosity = toFlag normal - } - -reportCommand :: CommandUI ReportFlags -reportCommand = CommandUI { - commandName = "report", - commandSynopsis = "Upload build reports to a remote server.", - commandDescription = Nothing, - commandNotes = Just $ \_ -> - "You can store your Hackage login in the ~/.cabal/config file\n", - commandUsage = usageAlternatives "report" ["[FLAGS]"], - commandDefaultFlags = defaultReportFlags, - commandOptions = \_ -> - [optionVerbosity reportVerbosity (\v flags -> flags { reportVerbosity = v }) - - ,option ['u'] ["username"] - "Hackage username." - reportUsername (\v flags -> flags { reportUsername = v }) - (reqArg' "USERNAME" (toFlag . Username) - (flagToList . fmap unUsername)) - - ,option ['p'] ["password"] - "Hackage password." - reportPassword (\v flags -> flags { reportPassword = v }) - (reqArg' "PASSWORD" (toFlag . Password) - (flagToList . fmap unPassword)) - ] - } - -instance Monoid ReportFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup ReportFlags where - (<>) = gmappend - --- ------------------------------------------------------------ --- * Get flags --- ------------------------------------------------------------ - -data GetFlags = GetFlags { - getDestDir :: Flag FilePath, - getPristine :: Flag Bool, - getIndexState :: Flag TotalIndexState, - getActiveRepos :: Flag ActiveRepos, - getSourceRepository :: Flag (Maybe RepoKind), - getVerbosity :: Flag Verbosity - } deriving Generic - -defaultGetFlags :: GetFlags -defaultGetFlags = GetFlags { - getDestDir = mempty, - getPristine = mempty, - getIndexState = mempty, - getActiveRepos = mempty, - getSourceRepository = mempty, - getVerbosity = toFlag normal - } - -getCommand :: CommandUI GetFlags -getCommand = CommandUI { - commandName = "get", - commandSynopsis = "Download/Extract a package's source code (repository).", - commandDescription = Just $ \_ -> wrapText $ - "Creates a local copy of a package's source code. By default it gets " - ++ "the source\ntarball and unpacks it in a local subdirectory. " - ++ "Alternatively, with -s it will\nget the code from the source " - ++ "repository specified by the package.\n", - commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " get hlint\n" - ++ " Download the latest stable version of hlint;\n" - ++ " " ++ pname ++ " get lens --source-repository=head\n" - ++ " Download the source repository (i.e. git clone from github).\n", - commandUsage = usagePackages "get", - commandDefaultFlags = defaultGetFlags, - commandOptions = \_ -> [ - optionVerbosity getVerbosity (\v flags -> flags { getVerbosity = v }) - - ,option "d" ["destdir"] - "Where to place the package source, defaults to the current directory." - getDestDir (\v flags -> flags { getDestDir = v }) - (reqArgFlag "PATH") - - ,option "s" ["source-repository"] - "Copy the package's source repository (ie git clone, darcs get, etc as appropriate)." - getSourceRepository (\v flags -> flags { getSourceRepository = v }) - (optArg "[head|this|...]" (parsecToReadE (const "invalid source-repository") - (fmap (toFlag . Just) parsec)) - (Flag Nothing) - (map (fmap show) . flagToList)) - - , option [] ["index-state"] - ("Use source package index state as it existed at a previous time. " ++ - "Accepts unix-timestamps (e.g. '@1474732068'), ISO8601 UTC timestamps " ++ - "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD' (default: 'HEAD'). " ++ - "This determines which package versions are available as well as " ++ - ".cabal file revision is selected (unless --pristine is used).") - getIndexState (\v flags -> flags { getIndexState = v }) - (reqArg "STATE" (parsecToReadE (const $ "index-state must be a " ++ - "unix-timestamps (e.g. '@1474732068'), " ++ - "a ISO8601 UTC timestamp " ++ - "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD'") - (toFlag `fmap` parsec)) - (flagToList . fmap prettyShow)) - - , option [] ["pristine"] - ("Unpack the original pristine tarball, rather than updating the " - ++ ".cabal file with the latest revision from the package archive.") - getPristine (\v flags -> flags { getPristine = v }) - trueArg - ] - } - --- 'cabal unpack' is a deprecated alias for 'cabal get'. -unpackCommand :: CommandUI GetFlags -unpackCommand = getCommand { - commandName = "unpack", - commandUsage = usagePackages "unpack" - } - -instance Monoid GetFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup GetFlags where - (<>) = gmappend - --- ------------------------------------------------------------ --- * List flags --- ------------------------------------------------------------ - -data ListFlags = ListFlags - { listInstalled :: Flag Bool - , listSimpleOutput :: Flag Bool - , listCaseInsensitive :: Flag Bool - , listVerbosity :: Flag Verbosity - , listPackageDBs :: [Maybe PackageDB] - , listHcPath :: Flag FilePath - } - deriving Generic - -defaultListFlags :: ListFlags -defaultListFlags = ListFlags - { listInstalled = Flag False - , listSimpleOutput = Flag False - , listCaseInsensitive = Flag True - , listVerbosity = toFlag normal - , listPackageDBs = [] - , listHcPath = mempty - } - -listCommand :: CommandUI ListFlags -listCommand = CommandUI { - commandName = "list", - commandSynopsis = "List packages matching a search string.", - commandDescription = Just $ \_ -> wrapText $ - "List all packages, or all packages matching one of the search" - ++ " strings.\n" - ++ "\n" - ++ "Use the package database specified with --package-db. " - ++ "If not specified, use the user package database.\n", - commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " list pandoc\n" - ++ " Will find pandoc, pandoc-citeproc, pandoc-lens, ...\n", - commandUsage = usageAlternatives "list" [ "[FLAGS]" - , "[FLAGS] STRINGS"], - commandDefaultFlags = defaultListFlags, - commandOptions = const listOptions - } - -listOptions :: [OptionField ListFlags] -listOptions = - [ optionVerbosity listVerbosity (\v flags -> flags { listVerbosity = v }) - - , option [] ["installed"] - "Only print installed packages" - listInstalled (\v flags -> flags { listInstalled = v }) - trueArg - - , option [] ["simple-output"] - "Print in a easy-to-parse format" - listSimpleOutput (\v flags -> flags { listSimpleOutput = v }) - trueArg - , option ['i'] ["ignore-case"] - "Ignore case destictions" - listCaseInsensitive (\v flags -> flags { listCaseInsensitive = v }) - (boolOpt' (['i'], ["ignore-case"]) (['I'], ["strict-case"])) - - , option "" ["package-db"] - ( "Append the given package database to the list of package" - ++ " databases used (to satisfy dependencies and register into)." - ++ " May be a specific file, 'global' or 'user'. The initial list" - ++ " is ['global'], ['global', 'user']," - ++ " depending on context. Use 'clear' to reset the list to empty." - ++ " See the user guide for details.") - listPackageDBs (\v flags -> flags { listPackageDBs = v }) - (reqArg' "DB" readPackageDbList showPackageDbList) - - , option "w" ["with-compiler"] - "give the path to a particular compiler" - listHcPath (\v flags -> flags { listHcPath = v }) - (reqArgFlag "PATH") - ] - -listNeedsCompiler :: ListFlags -> Bool -listNeedsCompiler f = - flagElim False (const True) (listHcPath f) - || fromFlagOrDefault False (listInstalled f) - -instance Monoid ListFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup ListFlags where - (<>) = gmappend - --- ------------------------------------------------------------ --- * Info flags --- ------------------------------------------------------------ - -data InfoFlags = InfoFlags { - infoVerbosity :: Flag Verbosity, - infoPackageDBs :: [Maybe PackageDB] - } deriving Generic - -defaultInfoFlags :: InfoFlags -defaultInfoFlags = InfoFlags { - infoVerbosity = toFlag normal, - infoPackageDBs = [] - } - -infoCommand :: CommandUI InfoFlags -infoCommand = CommandUI { - commandName = "info", - commandSynopsis = "Display detailed information about a particular package.", - commandDescription = Just $ \_ -> wrapText $ - "Use the package database specified with --package-db. " - ++ "If not specified, use the user package database.\n", - commandNotes = Nothing, - commandUsage = usageAlternatives "info" ["[FLAGS] PACKAGES"], - commandDefaultFlags = defaultInfoFlags, - commandOptions = \_ -> [ - optionVerbosity infoVerbosity (\v flags -> flags { infoVerbosity = v }) - - , option "" ["package-db"] - ( "Append the given package database to the list of package" - ++ " databases used (to satisfy dependencies and register into)." - ++ " May be a specific file, 'global' or 'user'. The initial list" - ++ " is ['global'], ['global', 'user']," - ++ " depending on context. Use 'clear' to reset the list to empty." - ++ " See the user guide for details.") - infoPackageDBs (\v flags -> flags { infoPackageDBs = v }) - (reqArg' "DB" readPackageDbList showPackageDbList) - - ] - } - -instance Monoid InfoFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup InfoFlags where - (<>) = gmappend - --- ------------------------------------------------------------ --- * Install flags --- ------------------------------------------------------------ - --- | Install takes the same flags as configure along with a few extras. --- -data InstallFlags = InstallFlags { - installDocumentation :: Flag Bool, - installHaddockIndex :: Flag PathTemplate, - installDest :: Flag Cabal.CopyDest, - installDryRun :: Flag Bool, - installMaxBackjumps :: Flag Int, - installReorderGoals :: Flag ReorderGoals, - installCountConflicts :: Flag CountConflicts, - installFineGrainedConflicts :: Flag FineGrainedConflicts, - installMinimizeConflictSet :: Flag MinimizeConflictSet, - installIndependentGoals :: Flag IndependentGoals, - installShadowPkgs :: Flag ShadowPkgs, - installStrongFlags :: Flag StrongFlags, - installAllowBootLibInstalls :: Flag AllowBootLibInstalls, - installOnlyConstrained :: Flag OnlyConstrained, - installReinstall :: Flag Bool, - installAvoidReinstalls :: Flag AvoidReinstalls, - installOverrideReinstall :: Flag Bool, - installUpgradeDeps :: Flag Bool, - installOnly :: Flag Bool, - installOnlyDeps :: Flag Bool, - installIndexState :: Flag TotalIndexState, - installRootCmd :: Flag String, - installSummaryFile :: NubList PathTemplate, - installLogFile :: Flag PathTemplate, - installBuildReports :: Flag ReportLevel, - installReportPlanningFailure :: Flag Bool, - -- Note: symlink-bindir is no longer used by v2-install and can be removed - -- when removing v1 commands - installSymlinkBinDir :: Flag FilePath, - installPerComponent :: Flag Bool, - installOneShot :: Flag Bool, - installNumJobs :: Flag (Maybe Int), - installKeepGoing :: Flag Bool, - installRunTests :: Flag Bool, - installOfflineMode :: Flag Bool - } - deriving (Eq, Show, Generic) - -instance Binary InstallFlags - -defaultInstallFlags :: InstallFlags -defaultInstallFlags = InstallFlags { - installDocumentation = Flag False, - installHaddockIndex = Flag docIndexFile, - installDest = Flag Cabal.NoCopyDest, - installDryRun = Flag False, - installMaxBackjumps = Flag defaultMaxBackjumps, - installReorderGoals = Flag (ReorderGoals False), - installCountConflicts = Flag (CountConflicts True), - installFineGrainedConflicts = Flag (FineGrainedConflicts True), - installMinimizeConflictSet = Flag (MinimizeConflictSet False), - installIndependentGoals= Flag (IndependentGoals False), - installShadowPkgs = Flag (ShadowPkgs False), - installStrongFlags = Flag (StrongFlags False), - installAllowBootLibInstalls = Flag (AllowBootLibInstalls False), - installOnlyConstrained = Flag OnlyConstrainedNone, - installReinstall = Flag False, - installAvoidReinstalls = Flag (AvoidReinstalls False), - installOverrideReinstall = Flag False, - installUpgradeDeps = Flag False, - installOnly = Flag False, - installOnlyDeps = Flag False, - installIndexState = mempty, - installRootCmd = mempty, - installSummaryFile = mempty, - installLogFile = mempty, - installBuildReports = Flag NoReports, - installReportPlanningFailure = Flag False, - installSymlinkBinDir = mempty, - installPerComponent = Flag True, - installOneShot = Flag False, - installNumJobs = mempty, - installKeepGoing = Flag False, - installRunTests = mempty, - installOfflineMode = Flag False - } - where - docIndexFile = toPathTemplate ("$datadir" "doc" - "$arch-$os-$compiler" "index.html") - -defaultMaxBackjumps :: Int -defaultMaxBackjumps = 4000 - -defaultSolver :: PreSolver -defaultSolver = AlwaysModular - -allSolvers :: String -allSolvers = intercalate ", " (map prettyShow ([minBound .. maxBound] :: [PreSolver])) - -installCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags - , HaddockFlags, TestFlags, BenchmarkFlags - ) -installCommand = CommandUI { - commandName = "install", - commandSynopsis = "Install packages.", - commandUsage = usageAlternatives "v1-install" [ "[FLAGS]" - , "[FLAGS] PACKAGES" - ], - commandDescription = Just $ \_ -> wrapText $ - "Installs one or more packages. By default, the installed package" - ++ " will be registered in the user's package database." - ++ "\n" - ++ "If PACKAGES are specified, downloads and installs those packages." - ++ " Otherwise, install the package in the current directory (and/or its" - ++ " dependencies) (there must be exactly one .cabal file in the current" - ++ " directory).\n" - ++ "\n" - ++ "The flags to `v1-install` are saved and" - ++ " affect future commands such as `v1-build` and `v1-repl`. See the help for" - ++ " `v1-configure` for a list of commands being affected.\n" - ++ "\n" - ++ "Installed executables will by default" - ++ " be put into `~/.cabal/bin/`." - ++ " If you want installed executable to be available globally, make" - ++ " sure that the PATH environment variable contains that directory.\n" - ++ "\n", - commandNotes = Just $ \pname -> - ( case commandNotes - $ Cabal.configureCommand defaultProgramDb - of Just desc -> desc pname ++ "\n" - Nothing -> "" - ) - ++ "Examples:\n" - ++ " " ++ pname ++ " v1-install " - ++ " Package in the current directory\n" - ++ " " ++ pname ++ " v1-install foo " - ++ " Package from the hackage server\n" - ++ " " ++ pname ++ " v1-install foo-1.0 " - ++ " Specific version of a package\n" - ++ " " ++ pname ++ " v1-install 'foo < 2' " - ++ " Constrained package version\n" - ++ " " ++ pname ++ " v1-install haddock --bindir=$HOME/hask-bin/ --datadir=$HOME/hask-data/\n" - ++ " " ++ (map (const ' ') pname) - ++ " " - ++ " Change installation destination\n", - commandDefaultFlags = (mempty, mempty, mempty, mempty, mempty, mempty), - commandOptions = \showOrParseArgs -> - liftOptions get1 set1 - -- Note: [Hidden Flags] - -- hide "constraint", "dependency", and - -- "exact-configuration" from the configure options. - (filter ((`notElem` ["constraint", "dependency" - , "exact-configuration"]) - . optionName) $ - configureOptions showOrParseArgs) - ++ liftOptions get2 set2 (configureExOptions showOrParseArgs ConstraintSourceCommandlineFlag) - ++ liftOptions get3 set3 - -- hide "target-package-db" flag from the - -- install options. - (filter ((`notElem` ["target-package-db"]) - . optionName) $ - installOptions showOrParseArgs) - ++ liftOptions get4 set4 (haddockOptions showOrParseArgs) - ++ liftOptions get5 set5 (testOptions showOrParseArgs) - ++ liftOptions get6 set6 (benchmarkOptions showOrParseArgs) - } - where - get1 (a,_,_,_,_,_) = a; set1 a (_,b,c,d,e,f) = (a,b,c,d,e,f) - get2 (_,b,_,_,_,_) = b; set2 b (a,_,c,d,e,f) = (a,b,c,d,e,f) - get3 (_,_,c,_,_,_) = c; set3 c (a,b,_,d,e,f) = (a,b,c,d,e,f) - get4 (_,_,_,d,_,_) = d; set4 d (a,b,c,_,e,f) = (a,b,c,d,e,f) - get5 (_,_,_,_,e,_) = e; set5 e (a,b,c,d,_,f) = (a,b,c,d,e,f) - get6 (_,_,_,_,_,f) = f; set6 f (a,b,c,d,e,_) = (a,b,c,d,e,f) - -haddockCommand :: CommandUI HaddockFlags -haddockCommand = Cabal.haddockCommand - { commandUsage = usageAlternatives "v1-haddock" $ - [ "[FLAGS]", "COMPONENTS [FLAGS]" ] - } - -filterHaddockArgs :: [String] -> Version -> [String] -filterHaddockArgs args cabalLibVersion - | cabalLibVersion >= mkVersion [2,3,0] = args_latest - | cabalLibVersion < mkVersion [2,3,0] = args_2_3_0 - | otherwise = args_latest - where - args_latest = args - - -- Cabal < 2.3 doesn't know about per-component haddock - args_2_3_0 = [] - -filterHaddockFlags :: HaddockFlags -> Version -> HaddockFlags -filterHaddockFlags flags cabalLibVersion - | cabalLibVersion >= mkVersion [2,3,0] = flags_latest - | cabalLibVersion < mkVersion [2,3,0] = flags_2_3_0 - | otherwise = flags_latest - where - flags_latest = flags - - flags_2_3_0 = flags_latest { - -- Cabal < 2.3 doesn't know about per-component haddock - haddockArgs = [] - } - -haddockOptions :: ShowOrParseArgs -> [OptionField HaddockFlags] -haddockOptions showOrParseArgs - = [ opt { optionName = "haddock-" ++ name, - optionDescr = [ fmapOptFlags (\(_, lflags) -> ([], map ("haddock-" ++) lflags)) descr - | descr <- optionDescr opt] } - | opt <- commandOptions Cabal.haddockCommand showOrParseArgs - , let name = optionName opt - , name `elem` ["hoogle", "html", "html-location" - ,"executables", "tests", "benchmarks", "all", "internal", "css" - ,"hyperlink-source", "quickjump", "hscolour-css" - ,"contents-location", "for-hackage"] - ] - -testOptions :: ShowOrParseArgs -> [OptionField TestFlags] -testOptions showOrParseArgs - = [ opt { optionName = prefixTest name, - optionDescr = [ fmapOptFlags (\(_, lflags) -> ([], map prefixTest lflags)) descr - | descr <- optionDescr opt] } - | opt <- commandOptions Cabal.testCommand showOrParseArgs - , let name = optionName opt - , name `elem` ["log", "machine-log", "show-details", "keep-tix-files" - ,"fail-when-no-test-suites", "test-options", "test-option" - ,"test-wrapper"] - ] - where - prefixTest name | "test-" `isPrefixOf` name = name - | otherwise = "test-" ++ name - -benchmarkOptions :: ShowOrParseArgs -> [OptionField BenchmarkFlags] -benchmarkOptions showOrParseArgs - = [ opt { optionName = prefixBenchmark name, - optionDescr = [ fmapOptFlags (\(_, lflags) -> ([], map prefixBenchmark lflags)) descr - | descr <- optionDescr opt] } - | opt <- commandOptions Cabal.benchmarkCommand showOrParseArgs - , let name = optionName opt - , name `elem` ["benchmark-options", "benchmark-option"] - ] - where - prefixBenchmark name | "benchmark-" `isPrefixOf` name = name - | otherwise = "benchmark-" ++ name - -fmapOptFlags :: (OptFlags -> OptFlags) -> OptDescr a -> OptDescr a -fmapOptFlags modify (ReqArg d f p r w) = ReqArg d (modify f) p r w -fmapOptFlags modify (OptArg d f p r i w) = OptArg d (modify f) p r i w -fmapOptFlags modify (ChoiceOpt xs) = ChoiceOpt [(d, modify f, i, w) | (d, f, i, w) <- xs] -fmapOptFlags modify (BoolOpt d f1 f2 r w) = BoolOpt d (modify f1) (modify f2) r w - -installOptions :: ShowOrParseArgs -> [OptionField InstallFlags] -installOptions showOrParseArgs = - [ option "" ["documentation"] - "building of documentation" - installDocumentation (\v flags -> flags { installDocumentation = v }) - (boolOpt [] []) - - , option [] ["doc-index-file"] - "A central index of haddock API documentation (template cannot use $pkgid)" - installHaddockIndex (\v flags -> flags { installHaddockIndex = v }) - (reqArg' "TEMPLATE" (toFlag.toPathTemplate) - (flagToList . fmap fromPathTemplate)) - - , option [] ["dry-run"] - "Do not install anything, only print what would be installed." - installDryRun (\v flags -> flags { installDryRun = v }) - trueArg - - , option "" ["target-package-db"] - "package database to install into. Required when using ${pkgroot} prefix." - installDest (\v flags -> flags { installDest = v }) - (reqArg "DATABASE" (succeedReadE (Flag . Cabal.CopyToDb)) - (\f -> case f of Flag (Cabal.CopyToDb p) -> [p]; _ -> [])) - ] ++ - - optionSolverFlags showOrParseArgs - installMaxBackjumps (\v flags -> flags { installMaxBackjumps = v }) - installReorderGoals (\v flags -> flags { installReorderGoals = v }) - installCountConflicts (\v flags -> flags { installCountConflicts = v }) - installFineGrainedConflicts (\v flags -> flags { installFineGrainedConflicts = v }) - installMinimizeConflictSet (\v flags -> flags { installMinimizeConflictSet = v }) - installIndependentGoals (\v flags -> flags { installIndependentGoals = v }) - installShadowPkgs (\v flags -> flags { installShadowPkgs = v }) - installStrongFlags (\v flags -> flags { installStrongFlags = v }) - installAllowBootLibInstalls (\v flags -> flags { installAllowBootLibInstalls = v }) - installOnlyConstrained (\v flags -> flags { installOnlyConstrained = v }) ++ - - [ option [] ["reinstall"] - "Install even if it means installing the same version again." - installReinstall (\v flags -> flags { installReinstall = v }) - (yesNoOpt showOrParseArgs) - - , option [] ["avoid-reinstalls"] - "Do not select versions that would destructively overwrite installed packages." - (fmap asBool . installAvoidReinstalls) - (\v flags -> flags { installAvoidReinstalls = fmap AvoidReinstalls v }) - (yesNoOpt showOrParseArgs) - - , option [] ["force-reinstalls"] - "Reinstall packages even if they will most likely break other installed packages." - installOverrideReinstall (\v flags -> flags { installOverrideReinstall = v }) - (yesNoOpt showOrParseArgs) - - , option [] ["upgrade-dependencies"] - "Pick the latest version for all dependencies, rather than trying to pick an installed version." - installUpgradeDeps (\v flags -> flags { installUpgradeDeps = v }) - (yesNoOpt showOrParseArgs) - - , option [] ["only-dependencies"] - "Install only the dependencies necessary to build the given packages" - installOnlyDeps (\v flags -> flags { installOnlyDeps = v }) - (yesNoOpt showOrParseArgs) - - , option [] ["dependencies-only"] - "A synonym for --only-dependencies" - installOnlyDeps (\v flags -> flags { installOnlyDeps = v }) - (yesNoOpt showOrParseArgs) - - , option [] ["index-state"] - ("Use source package index state as it existed at a previous time. " ++ - "Accepts unix-timestamps (e.g. '@1474732068'), ISO8601 UTC timestamps " ++ - "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD' (default: 'HEAD').") - installIndexState (\v flags -> flags { installIndexState = v }) - (reqArg "STATE" (parsecToReadE (const $ "index-state must be a " ++ - "unix-timestamps (e.g. '@1474732068'), " ++ - "a ISO8601 UTC timestamp " ++ - "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD'") - (toFlag `fmap` parsec)) - (flagToList . fmap prettyShow)) - - , option [] ["root-cmd"] - "(No longer supported, do not use.)" - installRootCmd (\v flags -> flags { installRootCmd = v }) - (reqArg' "COMMAND" toFlag flagToList) - - , option [] ["symlink-bindir"] - "Add symlinks to installed executables into this directory." - installSymlinkBinDir (\v flags -> flags { installSymlinkBinDir = v }) - (reqArgFlag "DIR") - - , option [] ["build-summary"] - "Save build summaries to file (name template can use $pkgid, $compiler, $os, $arch)" - installSummaryFile (\v flags -> flags { installSummaryFile = v }) - (reqArg' "TEMPLATE" (\x -> toNubList [toPathTemplate x]) (map fromPathTemplate . fromNubList)) - - , option [] ["build-log"] - "Log all builds to file (name template can use $pkgid, $compiler, $os, $arch)" - installLogFile (\v flags -> flags { installLogFile = v }) - (reqArg' "TEMPLATE" (toFlag.toPathTemplate) - (flagToList . fmap fromPathTemplate)) - - , option [] ["remote-build-reporting"] - "Generate build reports to send to a remote server (none, anonymous or detailed)." - installBuildReports (\v flags -> flags { installBuildReports = v }) - (reqArg "LEVEL" (parsecToReadE (const $ "report level must be 'none', " - ++ "'anonymous' or 'detailed'") - (toFlag `fmap` parsec)) - (flagToList . fmap prettyShow)) - - , option [] ["report-planning-failure"] - "Generate build reports when the dependency solver fails. This is used by the Hackage build bot." - installReportPlanningFailure (\v flags -> flags { installReportPlanningFailure = v }) - trueArg - - , option "" ["per-component"] - "Per-component builds when possible" - installPerComponent (\v flags -> flags { installPerComponent = v }) - (boolOpt [] []) - - , option [] ["one-shot"] - "Do not record the packages in the world file." - installOneShot (\v flags -> flags { installOneShot = v }) - (yesNoOpt showOrParseArgs) - - , option [] ["run-tests"] - "Run package test suites during installation." - installRunTests (\v flags -> flags { installRunTests = v }) - trueArg - - , optionNumJobs - installNumJobs (\v flags -> flags { installNumJobs = v }) - - , option [] ["keep-going"] - "After a build failure, continue to build other unaffected packages." - installKeepGoing (\v flags -> flags { installKeepGoing = v }) - trueArg - - , option [] ["offline"] - "Don't download packages from the Internet." - installOfflineMode (\v flags -> flags { installOfflineMode = v }) - (yesNoOpt showOrParseArgs) - - ] ++ case showOrParseArgs of -- TODO: remove when "cabal install" - -- avoids - ParseArgs -> - [ option [] ["only"] - "Only installs the package in the current directory." - installOnly (\v flags -> flags { installOnly = v }) - trueArg ] - _ -> [] - - -instance Monoid InstallFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup InstallFlags where - (<>) = gmappend - --- ------------------------------------------------------------ --- * Upload flags --- ------------------------------------------------------------ - --- | Is this a candidate package or a package to be published? -data IsCandidate = IsCandidate | IsPublished - deriving Eq - -data UploadFlags = UploadFlags { - uploadCandidate :: Flag IsCandidate, - uploadDoc :: Flag Bool, - uploadUsername :: Flag Username, - uploadPassword :: Flag Password, - uploadPasswordCmd :: Flag [String], - uploadVerbosity :: Flag Verbosity - } deriving Generic - -defaultUploadFlags :: UploadFlags -defaultUploadFlags = UploadFlags { - uploadCandidate = toFlag IsCandidate, - uploadDoc = toFlag False, - uploadUsername = mempty, - uploadPassword = mempty, - uploadPasswordCmd = mempty, - uploadVerbosity = toFlag normal - } - -uploadCommand :: CommandUI UploadFlags -uploadCommand = CommandUI { - commandName = "upload", - commandSynopsis = "Uploads source packages or documentation to Hackage.", - commandDescription = Nothing, - commandNotes = Just $ \_ -> - "You can store your Hackage login in the ~/.cabal/config file\n" - ++ relevantConfigValuesText ["username", "password", "password-command"], - commandUsage = \pname -> - "Usage: " ++ pname ++ " upload [FLAGS] TARFILES\n", - commandDefaultFlags = defaultUploadFlags, - commandOptions = \_ -> - [optionVerbosity uploadVerbosity - (\v flags -> flags { uploadVerbosity = v }) - - ,option [] ["publish"] - "Publish the package instead of uploading it as a candidate." - uploadCandidate (\v flags -> flags { uploadCandidate = v }) - (noArg (Flag IsPublished)) - - ,option ['d'] ["documentation"] - ("Upload documentation instead of a source package. " - ++ "By default, this uploads documentation for a package candidate. " - ++ "To upload documentation for " - ++ "a published package, combine with --publish.") - uploadDoc (\v flags -> flags { uploadDoc = v }) - trueArg - - ,option ['u'] ["username"] - "Hackage username." - uploadUsername (\v flags -> flags { uploadUsername = v }) - (reqArg' "USERNAME" (toFlag . Username) - (flagToList . fmap unUsername)) - - ,option ['p'] ["password"] - "Hackage password." - uploadPassword (\v flags -> flags { uploadPassword = v }) - (reqArg' "PASSWORD" (toFlag . Password) - (flagToList . fmap unPassword)) - - ,option ['P'] ["password-command"] - "Command to get Hackage password." - uploadPasswordCmd (\v flags -> flags { uploadPasswordCmd = v }) - (reqArg' "PASSWORD" (Flag . words) (fromMaybe [] . flagToMaybe)) - ] - } - -instance Monoid UploadFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup UploadFlags where - (<>) = gmappend - --- ------------------------------------------------------------ --- * Init flags --- ------------------------------------------------------------ - -initCommand :: CommandUI IT.InitFlags -initCommand = CommandUI { - commandName = "init", - commandSynopsis = "Create a new .cabal package file.", - commandDescription = Just $ \_ -> wrapText $ - "Create a .cabal, Setup.hs, and optionally a LICENSE file.\n" - ++ "\n" - ++ "Calling init with no arguments creates an executable, " - ++ "guessing as many options as possible. The interactive " - ++ "mode can be invoked by the -i/--interactive flag, which " - ++ "will try to guess as much as possible and prompt you for " - ++ "the rest. You can change init to always be interactive by " - ++ "setting the interactive flag in your configuration file. " - ++ "Command-line arguments are provided for scripting purposes.\n", - commandNotes = Nothing, - commandUsage = \pname -> - "Usage: " ++ pname ++ " init [FLAGS]\n", - commandDefaultFlags = IT.defaultInitFlags, - commandOptions = initOptions - } - -initOptions :: ShowOrParseArgs -> [OptionField IT.InitFlags] -initOptions _ = - [ option ['i'] ["interactive"] - "interactive mode." - IT.interactive (\v flags -> flags { IT.interactive = v }) - (boolOpt' (['i'], ["interactive"]) (['n'], ["non-interactive"])) - - , option ['q'] ["quiet"] - "Do not generate log messages to stdout." - IT.quiet (\v flags -> flags { IT.quiet = v }) - trueArg - - , option [] ["no-comments"] - "Do not generate explanatory comments in the .cabal file." - IT.noComments (\v flags -> flags { IT.noComments = v }) - trueArg - - , option ['m'] ["minimal"] - "Generate a minimal .cabal file, that is, do not include extra empty fields. Also implies --no-comments." - IT.minimal (\v flags -> flags { IT.minimal = v }) - trueArg - - , option [] ["overwrite"] - "Overwrite any existing .cabal, LICENSE, or Setup.hs files without warning." - IT.overwrite (\v flags -> flags { IT.overwrite = v }) - trueArg - - , option [] ["package-dir", "packagedir"] - "Root directory of the package (default = current directory)." - IT.packageDir (\v flags -> flags { IT.packageDir = v }) - (reqArgFlag "DIRECTORY") - - , option ['p'] ["package-name"] - "Name of the Cabal package to create." - IT.packageName (\v flags -> flags { IT.packageName = v }) - (reqArg "PACKAGE" (parsecToReadE ("Cannot parse package name: "++) - (toFlag `fmap` parsec)) - (flagToList . fmap prettyShow)) - - , option [] ["version"] - "Initial version of the package." - IT.version (\v flags -> flags { IT.version = v }) - (reqArg "VERSION" (parsecToReadE ("Cannot parse package version: "++) - (toFlag `fmap` parsec)) - (flagToList . fmap prettyShow)) - - , option [] ["cabal-version"] - "Version of the Cabal specification." - IT.cabalVersion (\v flags -> flags { IT.cabalVersion = v }) - (reqArg "CABALSPECVERSION" (parsecToReadE ("Cannot parse Cabal specification version: "++) - (fmap (toFlag . getSpecVersion) parsec)) - (flagToList . fmap (prettyShow . SpecVersion))) - - , option ['l'] ["license"] - "Project license." - IT.license (\v flags -> flags { IT.license = v }) - (reqArg "LICENSE" (parsecToReadE ("Cannot parse license: "++) - (toFlag `fmap` parsec)) - (flagToList . fmap prettyShow)) - - , option ['a'] ["author"] - "Name of the project's author." - IT.author (\v flags -> flags { IT.author = v }) - (reqArgFlag "NAME") - - , option ['e'] ["email"] - "Email address of the maintainer." - IT.email (\v flags -> flags { IT.email = v }) - (reqArgFlag "EMAIL") - - , option ['u'] ["homepage"] - "Project homepage and/or repository." - IT.homepage (\v flags -> flags { IT.homepage = v }) - (reqArgFlag "URL") - - , option ['s'] ["synopsis"] - "Short project synopsis." - IT.synopsis (\v flags -> flags { IT.synopsis = v }) - (reqArgFlag "TEXT") - - , option ['c'] ["category"] - "Project category." - IT.category (\v flags -> flags { IT.category = v }) - (reqArg' "CATEGORY" (\s -> toFlag $ maybe (Left s) Right (readMaybe s)) - (flagToList . fmap (either id show))) - - , option ['x'] ["extra-source-file"] - "Extra source file to be distributed with tarball." - IT.extraSrc (\v flags -> flags { IT.extraSrc = v }) - (reqArg' "FILE" (Just . (:[])) - (fromMaybe [])) - - , option [] ["lib", "is-library"] - "Build a library." - IT.packageType (\v flags -> flags { IT.packageType = v }) - (noArg (Flag IT.Library)) - - , option [] ["exe", "is-executable"] - "Build an executable." - IT.packageType - (\v flags -> flags { IT.packageType = v }) - (noArg (Flag IT.Executable)) - - , option [] ["libandexe", "is-libandexe"] - "Build a library and an executable." - IT.packageType - (\v flags -> flags { IT.packageType = v }) - (noArg (Flag IT.LibraryAndExecutable)) - - , option [] ["tests"] - "Generate a test suite for the library." - IT.initializeTestSuite - (\v flags -> flags { IT.initializeTestSuite = v }) - trueArg - - , option [] ["test-dir"] - "Directory containing tests." - IT.testDirs (\v flags -> flags { IT.testDirs = v }) - (reqArg' "DIR" (Just . (:[])) - (fromMaybe [])) - - , option [] ["simple"] - "Create a simple project with sensible defaults." - IT.simpleProject - (\v flags -> flags { IT.simpleProject = v }) - trueArg - - , option [] ["main-is"] - "Specify the main module." - IT.mainIs - (\v flags -> flags { IT.mainIs = v }) - (reqArgFlag "FILE") - - , option [] ["language"] - "Specify the default language." - IT.language - (\v flags -> flags { IT.language = v }) - (reqArg "LANGUAGE" (parsecToReadE ("Cannot parse language: "++) - (toFlag `fmap` parsec)) - (flagToList . fmap prettyShow)) - - , option ['o'] ["expose-module"] - "Export a module from the package." - IT.exposedModules - (\v flags -> flags { IT.exposedModules = v }) - (reqArg "MODULE" (parsecToReadE ("Cannot parse module name: "++) - ((Just . (:[])) `fmap` parsec)) - (maybe [] (fmap prettyShow))) - - , option [] ["extension"] - "Use a LANGUAGE extension (in the other-extensions field)." - IT.otherExts - (\v flags -> flags { IT.otherExts = v }) - (reqArg "EXTENSION" (parsecToReadE ("Cannot parse extension: "++) - ((Just . (:[])) `fmap` parsec)) - (maybe [] (fmap prettyShow))) - - , option ['d'] ["dependency"] - "Package dependency." - IT.dependencies (\v flags -> flags { IT.dependencies = v }) - (reqArg "PACKAGE" (parsecToReadE ("Cannot parse dependency: "++) - ((Just . (:[])) `fmap` parsec)) - (maybe [] (fmap prettyShow))) - - , option [] ["application-dir"] - "Directory containing package application executable." - IT.applicationDirs (\v flags -> flags { IT.applicationDirs = v}) - (reqArg' "DIR" (Just . (:[])) - (fromMaybe [])) - - , option [] ["source-dir", "sourcedir"] - "Directory containing package library source." - IT.sourceDirs (\v flags -> flags { IT.sourceDirs = v }) - (reqArg' "DIR" (Just . (:[])) - (fromMaybe [])) - - , option [] ["build-tool"] - "Required external build tool." - IT.buildTools (\v flags -> flags { IT.buildTools = v }) - (reqArg' "TOOL" (Just . (:[])) - (fromMaybe [])) - - -- NB: this is a bit of a transitional hack and will likely be - -- removed again if `cabal init` is migrated to the v2-* command - -- framework - , option "w" ["with-compiler"] - "give the path to a particular compiler" - IT.initHcPath (\v flags -> flags { IT.initHcPath = v }) - (reqArgFlag "PATH") - - , optionVerbosity IT.initVerbosity (\v flags -> flags { IT.initVerbosity = v }) - ] - --- ------------------------------------------------------------ --- * SDist flags --- ------------------------------------------------------------ - -doctestCommand :: CommandUI DoctestFlags -doctestCommand = Cabal.doctestCommand - { commandUsage = \pname -> "Usage: " ++ pname ++ " v1-doctest [FLAGS]\n" } - -copyCommand :: CommandUI CopyFlags -copyCommand = Cabal.copyCommand - { commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " v1-copy " - ++ " All the components in the package\n" - ++ " " ++ pname ++ " v1-copy foo " - ++ " A component (i.e. lib, exe, test suite)" - , commandUsage = usageAlternatives "v1-copy" $ - [ "[FLAGS]" - , "COMPONENTS [FLAGS]" - ] - } - -registerCommand :: CommandUI RegisterFlags -registerCommand = Cabal.registerCommand - { commandUsage = \pname -> "Usage: " ++ pname ++ " v1-register [FLAGS]\n" } - --- ------------------------------------------------------------ --- * ActAsSetup flags --- ------------------------------------------------------------ - -data ActAsSetupFlags = ActAsSetupFlags { - actAsSetupBuildType :: Flag BuildType -} deriving Generic - -defaultActAsSetupFlags :: ActAsSetupFlags -defaultActAsSetupFlags = ActAsSetupFlags { - actAsSetupBuildType = toFlag Simple -} - -actAsSetupCommand :: CommandUI ActAsSetupFlags -actAsSetupCommand = CommandUI { - commandName = "act-as-setup", - commandSynopsis = "Run as-if this was a Setup.hs", - commandDescription = Nothing, - commandNotes = Nothing, - commandUsage = \pname -> - "Usage: " ++ pname ++ " act-as-setup\n", - commandDefaultFlags = defaultActAsSetupFlags, - commandOptions = \_ -> - [option "" ["build-type"] - "Use the given build type." - actAsSetupBuildType (\v flags -> flags { actAsSetupBuildType = v }) - (reqArg "BUILD-TYPE" (parsecToReadE ("Cannot parse build type: "++) - (fmap toFlag parsec)) - (map prettyShow . flagToList)) - ] -} - -instance Monoid ActAsSetupFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup ActAsSetupFlags where - (<>) = gmappend - --- ------------------------------------------------------------ --- * Exec Flags --- ------------------------------------------------------------ - -data ExecFlags = ExecFlags { - execVerbosity :: Flag Verbosity, - execDistPref :: Flag FilePath -} deriving Generic - -defaultExecFlags :: ExecFlags -defaultExecFlags = ExecFlags { - execVerbosity = toFlag normal, - execDistPref = NoFlag - } - -execCommand :: CommandUI ExecFlags -execCommand = CommandUI { - commandName = "exec", - commandSynopsis = "Give a command access to the sandbox package repository.", - commandDescription = Just $ \pname -> wrapText $ - -- TODO: this is too GHC-focused for my liking.. - "A directly invoked GHC will not automatically be aware of any" - ++ " sandboxes: the GHC_PACKAGE_PATH environment variable controls what" - ++ " GHC uses. `" ++ pname ++ " v1-exec` can be used to modify this variable:" - ++ " COMMAND will be executed in a modified environment and thereby uses" - ++ " the sandbox package database.\n" - ++ "\n" - ++ "If there is no sandbox, behaves as identity (executing COMMAND).\n" - ++ "\n" - ++ "Note that other " ++ pname ++ " commands change the environment" - ++ " variable appropriately already, so there is no need to wrap those" - ++ " in `" ++ pname ++ " v1-exec`. But with `" ++ pname ++ " v1-exec`, the user" - ++ " has more control and can, for example, execute custom scripts which" - ++ " indirectly execute GHC.\n" - ++ "\n" - ++ "Note that `" ++ pname ++ " v1-repl` is different from `" ++ pname - ++ " v1-exec -- ghci` as the latter will not forward any additional flags" - ++ " being defined in the local package to ghci.\n" - ++ "\n" - ++ "See `" ++ pname ++ " sandbox`.\n", - commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " v1-exec -- ghci -Wall\n" - ++ " Start a repl session with sandbox packages and all warnings;\n" - ++ " " ++ pname ++ " v1-exec gitit -- -f gitit.cnf\n" - ++ " Give gitit access to the sandbox packages, and pass it a flag;\n" - ++ " " ++ pname ++ " v1-exec runghc Foo.hs\n" - ++ " Execute runghc on Foo.hs with runghc configured to use the\n" - ++ " sandbox package database (if a sandbox is being used).\n", - commandUsage = \pname -> - "Usage: " ++ pname ++ " v1-exec [FLAGS] [--] COMMAND [--] [ARGS]\n", - - commandDefaultFlags = defaultExecFlags, - commandOptions = \showOrParseArgs -> - [ optionVerbosity execVerbosity - (\v flags -> flags { execVerbosity = v }) - , Cabal.optionDistPref - execDistPref (\d flags -> flags { execDistPref = d }) - showOrParseArgs - ] - } - -instance Monoid ExecFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup ExecFlags where - (<>) = gmappend - --- ------------------------------------------------------------ --- * UserConfig flags --- ------------------------------------------------------------ - -data UserConfigFlags = UserConfigFlags { - userConfigVerbosity :: Flag Verbosity, - userConfigForce :: Flag Bool, - userConfigAppendLines :: Flag [String] - } deriving Generic - -instance Monoid UserConfigFlags where - mempty = UserConfigFlags { - userConfigVerbosity = toFlag normal, - userConfigForce = toFlag False, - userConfigAppendLines = toFlag [] - } - mappend = (<>) - -instance Semigroup UserConfigFlags where - (<>) = gmappend - -userConfigCommand :: CommandUI UserConfigFlags -userConfigCommand = CommandUI { - commandName = "user-config", - commandSynopsis = "Display and update the user's global cabal configuration.", - commandDescription = Just $ \_ -> wrapText $ - "When upgrading cabal, the set of configuration keys and their default" - ++ " values may change. This command provides means to merge the existing" - ++ " config in ~/.cabal/config" - ++ " (i.e. all bindings that are actually defined and not commented out)" - ++ " and the default config of the new version.\n" - ++ "\n" - ++ "init: Creates a new config file at either ~/.cabal/config or as" - ++ " specified by --config-file, if given. An existing file won't be " - ++ " overwritten unless -f or --force is given.\n" - ++ "diff: Shows a pseudo-diff of the user's ~/.cabal/config file and" - ++ " the default configuration that would be created by cabal if the" - ++ " config file did not exist.\n" - ++ "update: Applies the pseudo-diff to the configuration that would be" - ++ " created by default, and write the result back to ~/.cabal/config.", - - commandNotes = Nothing, - commandUsage = usageAlternatives "user-config" ["init", "diff", "update"], - commandDefaultFlags = mempty, - commandOptions = \ _ -> [ - optionVerbosity userConfigVerbosity (\v flags -> flags { userConfigVerbosity = v }) - , option ['f'] ["force"] - "Overwrite the config file if it already exists." - userConfigForce (\v flags -> flags { userConfigForce = v }) - trueArg - , option ['a'] ["augment"] - "Additional setting to augment the config file (replacing a previous setting if it existed)." - userConfigAppendLines (\v flags -> flags - {userConfigAppendLines = - Flag $ concat (flagToList (userConfigAppendLines flags) ++ flagToList v)}) - (reqArg' "CONFIGLINE" (Flag . (:[])) (fromMaybe [] . flagToMaybe)) - ] - } - - --- ------------------------------------------------------------ --- * GetOpt Utils --- ------------------------------------------------------------ - -reqArgFlag :: ArgPlaceHolder -> - MkOptDescr (b -> Flag String) (Flag String -> b -> b) b -reqArgFlag ad = reqArg ad (succeedReadE Flag) flagToList - -liftOptions :: (b -> a) -> (a -> b -> b) - -> [OptionField a] -> [OptionField b] -liftOptions get set = map (liftOption get set) - -yesNoOpt :: ShowOrParseArgs -> MkOptDescr (b -> Flag Bool) (Flag Bool -> b -> b) b -yesNoOpt ShowArgs sf lf = trueArg sf lf -yesNoOpt _ sf lf = Command.boolOpt' flagToMaybe Flag (sf, lf) ([], map ("no-" ++) lf) sf lf - -optionSolver :: (flags -> Flag PreSolver) - -> (Flag PreSolver -> flags -> flags) - -> OptionField flags -optionSolver get set = - option [] ["solver"] - ("Select dependency solver to use (default: " ++ prettyShow defaultSolver ++ "). Choices: " ++ allSolvers ++ ".") - get set - (reqArg "SOLVER" (parsecToReadE (const $ "solver must be one of: " ++ allSolvers) - (toFlag `fmap` parsec)) - (flagToList . fmap prettyShow)) - -optionSolverFlags :: ShowOrParseArgs - -> (flags -> Flag Int ) -> (Flag Int -> flags -> flags) - -> (flags -> Flag ReorderGoals) -> (Flag ReorderGoals -> flags -> flags) - -> (flags -> Flag CountConflicts) -> (Flag CountConflicts -> flags -> flags) - -> (flags -> Flag FineGrainedConflicts) -> (Flag FineGrainedConflicts -> flags -> flags) - -> (flags -> Flag MinimizeConflictSet) -> (Flag MinimizeConflictSet -> flags -> flags) - -> (flags -> Flag IndependentGoals) -> (Flag IndependentGoals -> flags -> flags) - -> (flags -> Flag ShadowPkgs) -> (Flag ShadowPkgs -> flags -> flags) - -> (flags -> Flag StrongFlags) -> (Flag StrongFlags -> flags -> flags) - -> (flags -> Flag AllowBootLibInstalls) -> (Flag AllowBootLibInstalls -> flags -> flags) - -> (flags -> Flag OnlyConstrained) -> (Flag OnlyConstrained -> flags -> flags) - -> [OptionField flags] -optionSolverFlags showOrParseArgs getmbj setmbj getrg setrg getcc setcc - getfgc setfgc getmc setmc getig setig getsip setsip - getstrfl setstrfl getib setib getoc setoc = - [ option [] ["max-backjumps"] - ("Maximum number of backjumps allowed while solving (default: " ++ show defaultMaxBackjumps ++ "). Use a negative number to enable unlimited backtracking. Use 0 to disable backtracking completely.") - getmbj setmbj - (reqArg "NUM" (parsecToReadE ("Cannot parse number: "++) (fmap toFlag P.signedIntegral)) - (map show . flagToList)) - , option [] ["reorder-goals"] - "Try to reorder goals according to certain heuristics. Slows things down on average, but may make backtracking faster for some packages." - (fmap asBool . getrg) - (setrg . fmap ReorderGoals) - (yesNoOpt showOrParseArgs) - , option [] ["count-conflicts"] - "Try to speed up solving by preferring goals that are involved in a lot of conflicts (default)." - (fmap asBool . getcc) - (setcc . fmap CountConflicts) - (yesNoOpt showOrParseArgs) - , option [] ["fine-grained-conflicts"] - "Skip a version of a package if it does not resolve the conflicts encountered in the last version, as a solver optimization (default)." - (fmap asBool . getfgc) - (setfgc . fmap FineGrainedConflicts) - (yesNoOpt showOrParseArgs) - , option [] ["minimize-conflict-set"] - ("When there is no solution, try to improve the error message by finding " - ++ "a minimal conflict set (default: false). May increase run time " - ++ "significantly.") - (fmap asBool . getmc) - (setmc . fmap MinimizeConflictSet) - (yesNoOpt showOrParseArgs) - , option [] ["independent-goals"] - "Treat several goals on the command line as independent. If several goals depend on the same package, different versions can be chosen." - (fmap asBool . getig) - (setig . fmap IndependentGoals) - (yesNoOpt showOrParseArgs) - , option [] ["shadow-installed-packages"] - "If multiple package instances of the same version are installed, treat all but one as shadowed." - (fmap asBool . getsip) - (setsip . fmap ShadowPkgs) - (yesNoOpt showOrParseArgs) - , option [] ["strong-flags"] - "Do not defer flag choices (this used to be the default in cabal-install <= 1.20)." - (fmap asBool . getstrfl) - (setstrfl . fmap StrongFlags) - (yesNoOpt showOrParseArgs) - , option [] ["allow-boot-library-installs"] - "Allow cabal to install base, ghc-prim, integer-simple, integer-gmp, and template-haskell." - (fmap asBool . getib) - (setib . fmap AllowBootLibInstalls) - (yesNoOpt showOrParseArgs) - , option [] ["reject-unconstrained-dependencies"] - "Require these packages to have constraints on them if they are to be selected (default: none)." - getoc - setoc - (reqArg "none|all" - (parsecToReadE - (const "reject-unconstrained-dependencies must be 'none' or 'all'") - (toFlag `fmap` parsec)) - (flagToList . fmap prettyShow)) - - ] - -usagePackages :: String -> String -> String -usagePackages name pname = - "Usage: " ++ pname ++ " " ++ name ++ " [PACKAGES]\n" - -usageFlags :: String -> String -> String -usageFlags name pname = - "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n" - ---TODO: do we want to allow per-package flags? -parsePackageArgs :: [String] -> Either String [PackageVersionConstraint] -parsePackageArgs = traverse p where - p arg = case eitherParsec arg of - Right pvc -> Right pvc - Left err -> Left $ - show arg ++ " is not valid syntax for a package name or" - ++ " package dependency. " ++ err - -showRemoteRepo :: RemoteRepo -> String -showRemoteRepo = prettyShow - -readRemoteRepo :: String -> Maybe RemoteRepo -readRemoteRepo = simpleParsec - -showLocalRepo :: LocalRepo -> String -showLocalRepo = prettyShow - -readLocalRepo :: String -> Maybe LocalRepo -readLocalRepo = simpleParsec - --- ------------------------------------------------------------ --- * Helpers for Documentation --- ------------------------------------------------------------ - -relevantConfigValuesText :: [String] -> String -relevantConfigValuesText vs = - "Relevant global configuration keys:\n" - ++ concat [" " ++ v ++ "\n" |v <- vs] diff --git a/cabal/cabal-install/Distribution/Client/SetupWrapper.hs b/cabal/cabal-install/Distribution/Client/SetupWrapper.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/SetupWrapper.hs +++ /dev/null @@ -1,919 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.SetupWrapper --- Copyright : (c) The University of Glasgow 2006, --- Duncan Coutts 2008 --- --- Maintainer : cabal-devel@haskell.org --- Stability : alpha --- Portability : portable --- --- An interface to building and installing Cabal packages. --- If the @Built-Type@ field is specified as something other than --- 'Custom', and the current version of Cabal is acceptable, this performs --- setup actions directly. Otherwise it builds the setup script and --- runs it with the given arguments. - -module Distribution.Client.SetupWrapper ( - getSetup, runSetup, runSetupCommand, setupWrapper, - SetupScriptOptions(..), - defaultSetupScriptOptions, - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude - -import Distribution.CabalSpecVersion (cabalSpecMinimumLibraryVersion) -import qualified Distribution.Make as Make -import qualified Distribution.Simple as Simple -import Distribution.Version - ( Version, mkVersion, versionNumbers, VersionRange, anyVersion - , intersectVersionRanges, orLaterVersion - , withinRange ) -import qualified Distribution.Backpack as Backpack -import Distribution.Package - ( newSimpleUnitId, unsafeMkDefUnitId, ComponentId - , PackageId, mkPackageName - , PackageIdentifier(..), packageVersion, packageName ) -import Distribution.PackageDescription - ( GenericPackageDescription(packageDescription) - , PackageDescription(..), specVersion, buildType - , BuildType(..) ) -import Distribution.Types.ModuleRenaming (defaultRenaming) -import Distribution.PackageDescription.Parsec - ( readGenericPackageDescription ) -import Distribution.Simple.Configure - ( configCompilerEx ) -import Distribution.Compiler - ( buildCompilerId, CompilerFlavor(GHC, GHCJS) ) -import Distribution.Simple.Compiler - ( Compiler(compilerId), compilerFlavor, PackageDB(..), PackageDBStack ) -import Distribution.Simple.PreProcess - ( runSimplePreProcessor, ppUnlit ) -import Distribution.Simple.Build.Macros - ( generatePackageVersionMacros ) -import Distribution.Simple.Program - ( ProgramDb, emptyProgramDb - , getProgramSearchPath, getDbProgramOutput, runDbProgram, ghcProgram - , ghcjsProgram ) -import Distribution.Simple.Program.Find - ( programSearchPathAsPATHVar - , ProgramSearchPathEntry(ProgramSearchPathDir) ) -import Distribution.Simple.Program.Run - ( getEffectiveEnvironment ) -import qualified Distribution.Simple.Program.Strip as Strip -import Distribution.Simple.BuildPaths - ( defaultDistPref, exeExtension ) - -import Distribution.Simple.Command - ( CommandUI(..), commandShowOptions ) -import Distribution.Simple.Program.GHC - ( GhcMode(..), GhcOptions(..), renderGhcOptions ) -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.PackageIndex (InstalledPackageIndex) -import qualified Distribution.InstalledPackageInfo as IPI -import Distribution.Client.Types -import Distribution.Client.Config - ( getCabalDir ) -import Distribution.Client.IndexUtils - ( getInstalledPackages ) -import Distribution.Client.JobControl - ( Lock, criticalSection ) -import Distribution.Simple.Setup - ( Flag(..) ) -import Distribution.Utils.Generic - ( safeHead ) -import Distribution.Simple.Utils - ( die', debug, info, infoNoWrap - , cabalVersion, tryFindPackageDesc - , createDirectoryIfMissingVerbose, installExecutableFile - , copyFileVerbose, rewriteFileEx, rewriteFileLBS ) -import Distribution.Client.Utils - ( inDir, tryCanonicalizePath, withExtraPathEnv - , existsAndIsMoreRecentThan, moreRecentFile, withEnv, withEnvOverrides -#ifdef mingw32_HOST_OS - , canonicalizePathNoThrow -#endif - ) - -import Distribution.ReadE -import Distribution.System ( Platform(..), buildPlatform ) -import Distribution.Utils.NubList - ( toNubListR ) -import Distribution.Verbosity -import Distribution.Compat.Stack - -import System.Directory ( doesFileExist ) -import System.FilePath ( (), (<.>) ) -import System.IO ( Handle, hPutStr ) -import Distribution.Compat.Process (createProcess) -import System.Process ( StdStream(..), proc, waitForProcess - , ProcessHandle ) -import qualified System.Process as Process -import Data.List ( foldl1' ) -import Distribution.Client.Compat.ExecutablePath ( getExecutablePath ) - -import qualified Data.ByteString.Lazy as BS - -#ifdef mingw32_HOST_OS -import Distribution.Simple.Utils - ( withTempDirectory ) - -import Control.Exception ( bracket ) -import System.FilePath ( equalFilePath, takeDirectory ) -import System.Directory ( doesDirectoryExist ) -import qualified System.Win32 as Win32 -#endif - --- | @Setup@ encapsulates the outcome of configuring a setup method to build a --- particular package. -data Setup = Setup { setupMethod :: SetupMethod - , setupScriptOptions :: SetupScriptOptions - , setupVersion :: Version - , setupBuildType :: BuildType - , setupPackage :: PackageDescription - } - --- | @SetupMethod@ represents one of the methods used to run Cabal commands. -data SetupMethod = InternalMethod - -- ^ run Cabal commands through \"cabal\" in the - -- current process - | SelfExecMethod - -- ^ run Cabal commands through \"cabal\" as a - -- child process - | ExternalMethod FilePath - -- ^ run Cabal commands through a custom \"Setup\" executable - --- 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 --- explicit options, and an optional initial part that applies certain --- policies (like if we should add the Cabal lib as a dep, and if so which --- version). This could be structured as an action that returns a fully --- elaborated 'SetupScriptOptions' containing no remaining policy choices. --- --- See also the discussion at https://github.com/haskell/cabal/pull/3094 - --- | @SetupScriptOptions@ are options used to configure and run 'Setup', as --- opposed to options given to the Cabal command at runtime. -data SetupScriptOptions = SetupScriptOptions { - -- | The version of the Cabal library to use (if 'useDependenciesExclusive' - -- is not set). A suitable version of the Cabal library must be installed - -- (or for some build-types be the one cabal-install was built with). - -- - -- The version found also determines the version of the Cabal specification - -- that we us for talking to the Setup.hs, unless overridden by - -- 'useCabalSpecVersion'. - -- - useCabalVersion :: VersionRange, - - -- | This is the version of the Cabal specification that we believe that - -- this package uses. This affects the semantics and in particular the - -- Setup command line interface. - -- - -- 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 - -- library as an additional dependency, so add it to 'useDependencies' - -- if needed. - -- - useCabalSpecVersion :: Maybe Version, - useCompiler :: Maybe Compiler, - usePlatform :: Maybe Platform, - usePackageDB :: PackageDBStack, - usePackageIndex :: Maybe InstalledPackageIndex, - useProgramDb :: ProgramDb, - useDistPref :: FilePath, - useLoggingHandle :: Maybe Handle, - useWorkingDir :: Maybe FilePath, - -- | Extra things to add to PATH when invoking the setup script. - useExtraPathEnv :: [FilePath], - -- | Extra environment variables paired with overrides, where - -- - -- * @'Just' v@ means \"set the environment variable's value to @v@\". - -- * 'Nothing' means \"unset the environment variable\". - useExtraEnvOverrides :: [(String, Maybe FilePath)], - forceExternalSetupMethod :: Bool, - - -- | List of dependencies to use when building Setup.hs. - useDependencies :: [(ComponentId, PackageId)], - - -- | Is the list of setup dependencies exclusive? - -- - -- When this is @False@, if we compile the Setup.hs script we do so with the - -- list in 'useDependencies' but all other packages in the environment are - -- also visible. A suitable version of @Cabal@ library (see - -- 'useCabalVersion') is also added to the list of dependencies, unless - -- 'useDependencies' already contains a Cabal dependency. - -- - -- When @True@, only the 'useDependencies' packages are used, with other - -- packages in the environment hidden. - -- - -- This feature is here to support the setup stanza in .cabal files that - -- specifies explicit (and exclusive) dependencies, as well as the old - -- style with no dependencies. - useDependenciesExclusive :: Bool, - - -- | Should we build the Setup.hs with CPP version macros available? - -- We turn this on when we have a setup stanza in .cabal that declares - -- explicit setup dependencies. - -- - useVersionMacros :: Bool, - - -- Used only by 'cabal clean' on Windows. - -- - -- Note: win32 clean hack - ------------------------- - -- On Windows, running './dist/setup/setup clean' doesn't work because the - -- setup script will try to delete itself (which causes it to fail horribly, - -- unlike on Linux). So we have to move the setup exe out of the way first - -- and then delete it manually. This applies only to the external setup - -- method. - useWin32CleanHack :: Bool, - - -- Used only when calling setupWrapper from parallel code to serialise - -- access to the setup cache; should be Nothing otherwise. - -- - -- Note: setup exe cache - ------------------------ - -- When we are installing in parallel, we always use the external setup - -- method. Since compiling the setup script each time adds noticeable - -- overhead, we use a shared setup script cache - -- ('~/.cabal/setup-exe-cache'). For each (compiler, platform, Cabal - -- version) combination the cache holds a compiled setup script - -- executable. This only affects the Simple build type; for the Custom, - -- Configure and Make build types we always compile the setup script anew. - setupCacheLock :: Maybe Lock, - - -- | Is the task we are going to run an interactive foreground task, - -- or an non-interactive background task? Based on this flag we - -- decide whether or not to delegate ctrl+c to the spawned task - isInteractive :: Bool - } - -defaultSetupScriptOptions :: SetupScriptOptions -defaultSetupScriptOptions = SetupScriptOptions { - useCabalVersion = anyVersion, - useCabalSpecVersion = Nothing, - useCompiler = Nothing, - usePlatform = Nothing, - usePackageDB = [GlobalPackageDB, UserPackageDB], - usePackageIndex = Nothing, - useDependencies = [], - useDependenciesExclusive = False, - useVersionMacros = False, - useProgramDb = emptyProgramDb, - useDistPref = defaultDistPref, - useLoggingHandle = Nothing, - useWorkingDir = Nothing, - useExtraPathEnv = [], - useExtraEnvOverrides = [], - useWin32CleanHack = False, - forceExternalSetupMethod = False, - setupCacheLock = Nothing, - isInteractive = False - } - -workingDir :: SetupScriptOptions -> FilePath -workingDir options = - case fromMaybe "" (useWorkingDir options) of - [] -> "." - dir -> dir - --- | A @SetupRunner@ implements a 'SetupMethod'. -type SetupRunner = Verbosity - -> SetupScriptOptions - -> BuildType - -> [String] - -> IO () - --- | Prepare to build a package by configuring a 'SetupMethod'. The returned --- 'Setup' object identifies the method. The 'SetupScriptOptions' may be changed --- during the configuration process; the final values are given by --- 'setupScriptOptions'. -getSetup :: Verbosity - -> SetupScriptOptions - -> Maybe PackageDescription - -> IO Setup -getSetup verbosity options mpkg = do - pkg <- maybe getPkg return mpkg - let options' = options { - useCabalVersion = intersectVersionRanges - (useCabalVersion options) - (orLaterVersion (mkVersion (cabalSpecMinimumLibraryVersion (specVersion pkg)))) - } - buildType' = buildType pkg - (version, method, options'') <- - getSetupMethod verbosity options' pkg buildType' - return Setup { setupMethod = method - , setupScriptOptions = options'' - , setupVersion = version - , setupBuildType = buildType' - , setupPackage = pkg - } - where - getPkg = tryFindPackageDesc verbosity (fromMaybe "." (useWorkingDir options)) - >>= readGenericPackageDescription verbosity - >>= 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 - :: Verbosity -> SetupScriptOptions -> PackageDescription -> BuildType - -> IO (Version, SetupMethod, SetupScriptOptions) -getSetupMethod verbosity options pkg buildType' - | buildType' == Custom - || maybe False (cabalVersion /=) (useCabalSpecVersion options) - || not (cabalVersion `withinRange` useCabalVersion options) = - getExternalSetupMethod verbosity options pkg buildType' - | isJust (useLoggingHandle options) - -- 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 -runSetupMethod (ExternalMethod path) = externalSetupMethod path -runSetupMethod SelfExecMethod = selfExecSetupMethod - --- | Run a configured 'Setup' with specific arguments. -runSetup :: Verbosity -> Setup - -> [String] -- ^ command-line arguments - -> IO () -runSetup verbosity setup args0 = do - let method = setupMethod setup - options = setupScriptOptions setup - bt = setupBuildType setup - args = verbosityHack (setupVersion setup) args0 - when (verbosity >= deafening {- avoid test if not debug -} && args /= args0) $ - infoNoWrap verbose $ - "Applied verbosity hack:\n" ++ - " Before: " ++ show args0 ++ "\n" ++ - " After: " ++ show args ++ "\n" - runSetupMethod method verbosity options bt args - --- | This is a horrible hack to make sure passing fancy verbosity --- flags (e.g., @-v'info +callstack'@) doesn't break horribly on --- old Setup. We can't do it in 'filterConfigureFlags' because --- verbosity applies to ALL commands. -verbosityHack :: Version -> [String] -> [String] -verbosityHack ver args0 - | ver >= mkVersion [2,1] = args0 - | otherwise = go args0 - where - go (('-':'v':rest) : args) - | Just rest' <- munch rest = ("-v" ++ rest') : go args - go (('-':'-':'v':'e':'r':'b':'o':'s':'e':'=':rest) : args) - | Just rest' <- munch rest = ("--verbose=" ++ rest') : go args - go ("--verbose" : rest : args) - | Just rest' <- munch rest = "--verbose" : rest' : go args - go rest@("--" : _) = rest - go (arg:args) = arg : go args - go [] = [] - - munch rest = - case runReadE flagToVerbosity rest of - Right v - | ver < mkVersion [2,0], verboseHasFlags v - -- We could preserve the prefix, but since we're assuming - -- it's Cabal's verbosity flag, we can assume that - -- any format is OK - -> Just (showForCabal (verboseNoFlags v)) - | ver < mkVersion [2,1], isVerboseTimestamp v - -- +timestamp wasn't yet available in Cabal-2.0.0 - -> Just (showForCabal (verboseNoTimestamp v)) - _ -> Nothing - --- | Run a command through a configured 'Setup'. -runSetupCommand :: Verbosity -> Setup - -> CommandUI flags -- ^ command definition - -> flags -- ^ command flags - -> [String] -- ^ extra command-line arguments - -> IO () -runSetupCommand verbosity setup cmd flags extraArgs = do - let args = commandName cmd : commandShowOptions cmd flags ++ extraArgs - runSetup verbosity setup args - --- | Configure a 'Setup' and run a command in one step. The command flags --- may depend on the Cabal library version in use. -setupWrapper :: Verbosity - -> SetupScriptOptions - -> Maybe PackageDescription - -> CommandUI flags - -> (Version -> flags) - -- ^ produce command flags given the Cabal library version - -> (Version -> [String]) - -> IO () -setupWrapper verbosity options mpkg cmd flags extraArgs = do - setup <- getSetup verbosity options mpkg - runSetupCommand verbosity setup - cmd (flags $ setupVersion setup) - (extraArgs $ setupVersion setup) - --- ------------------------------------------------------------ --- * Internal SetupMethod --- ------------------------------------------------------------ - -internalSetupMethod :: SetupRunner -internalSetupMethod verbosity options bt args = do - info verbosity $ "Using internal setup method with build-type " ++ show bt - ++ " and args:\n " ++ show args - inDir (useWorkingDir options) $ do - withEnv "HASKELL_DIST_DIR" (useDistPref options) $ - withExtraPathEnv (useExtraPathEnv options) $ - withEnvOverrides (useExtraEnvOverrides options) $ - buildTypeAction bt args - -buildTypeAction :: BuildType -> ([String] -> IO ()) -buildTypeAction Simple = Simple.defaultMainArgs -buildTypeAction Configure = Simple.defaultMainWithHooksArgs - Simple.autoconfUserHooks -buildTypeAction Make = Make.defaultMainArgs -buildTypeAction Custom = error "buildTypeAction Custom" - - --- | @runProcess'@ is a version of @runProcess@ where we have --- the additional option to decide whether or not we should --- delegate CTRL+C to the spawned process. -runProcess' :: FilePath -- ^ Filename of the executable - -> [String] -- ^ Arguments to pass to executable - -> Maybe FilePath -- ^ Optional path to working directory - -> Maybe [(String, String)] -- ^ Optional environment - -> Maybe Handle -- ^ Handle for @stdin@ - -> Maybe Handle -- ^ Handle for @stdout@ - -> Maybe Handle -- ^ Handle for @stderr@ - -> Bool -- ^ Delegate Ctrl+C ? - -> IO ProcessHandle -runProcess' cmd args mb_cwd mb_env mb_stdin mb_stdout mb_stderr _delegate = do - (_,_,_,ph) <- - createProcess - (proc cmd args){ Process.cwd = mb_cwd - , Process.env = mb_env - , Process.std_in = mbToStd mb_stdin - , Process.std_out = mbToStd mb_stdout - , Process.std_err = mbToStd mb_stderr - , Process.delegate_ctlc = _delegate - } - return ph - where - mbToStd :: Maybe Handle -> StdStream - mbToStd Nothing = Inherit - mbToStd (Just hdl) = UseHandle hdl - --- ------------------------------------------------------------ --- * Self-Exec SetupMethod --- ------------------------------------------------------------ - -selfExecSetupMethod :: SetupRunner -selfExecSetupMethod verbosity options bt args0 = do - let args = ["act-as-setup", - "--build-type=" ++ prettyShow bt, - "--"] ++ args0 - info verbosity $ "Using self-exec internal setup method with build-type " - ++ show bt ++ " and args:\n " ++ show args - path <- getExecutablePath - info verbosity $ unwords (path : args) - case useLoggingHandle options of - Nothing -> return () - Just logHandle -> info verbosity $ "Redirecting build log to " - ++ show logHandle - - searchpath <- programSearchPathAsPATHVar - (map ProgramSearchPathDir (useExtraPathEnv options) ++ - getProgramSearchPath (useProgramDb options)) - env <- getEffectiveEnvironment $ - [ ("PATH", Just searchpath) - , ("HASKELL_DIST_DIR", Just (useDistPref options)) - ] ++ useExtraEnvOverrides options - process <- runProcess' path args - (useWorkingDir options) env Nothing - (useLoggingHandle options) (useLoggingHandle options) - (isInteractive options) - exitCode <- waitForProcess process - unless (exitCode == ExitSuccess) $ exitWith exitCode - --- ------------------------------------------------------------ --- * External SetupMethod --- ------------------------------------------------------------ - -externalSetupMethod :: WithCallStack (FilePath -> SetupRunner) -externalSetupMethod path verbosity options _ args = do - info verbosity $ unwords (path : args) - case useLoggingHandle options of - Nothing -> return () - Just logHandle -> info verbosity $ "Redirecting build log to " - ++ show logHandle - - -- See 'Note: win32 clean hack' above. -#ifdef mingw32_HOST_OS - if useWin32CleanHack options then doWin32CleanHack path else doInvoke path -#else - doInvoke path -#endif - - where - doInvoke path' = do - searchpath <- programSearchPathAsPATHVar - (map ProgramSearchPathDir (useExtraPathEnv options) ++ - getProgramSearchPath (useProgramDb options)) - env <- getEffectiveEnvironment $ - [ ("PATH", Just searchpath) - , ("HASKELL_DIST_DIR", Just (useDistPref options)) - ] ++ useExtraEnvOverrides options - - debug verbosity $ "Setup arguments: "++unwords args - process <- runProcess' path' args - (useWorkingDir options) env Nothing - (useLoggingHandle options) (useLoggingHandle options) - (isInteractive options) - exitCode <- waitForProcess process - unless (exitCode == ExitSuccess) $ exitWith exitCode - -#ifdef mingw32_HOST_OS - doWin32CleanHack path' = do - info verbosity $ "Using the Win32 clean hack." - -- Recursively removes the temp dir on exit. - withTempDirectory verbosity (workingDir options) "cabal-tmp" $ \tmpDir -> - bracket (moveOutOfTheWay tmpDir path') - (maybeRestore path') - doInvoke - - moveOutOfTheWay tmpDir path' = do - let newPath = tmpDir "setup" <.> exeExtension buildPlatform - Win32.moveFile path' newPath - return newPath - - maybeRestore oldPath path' = do - let oldPathDir = takeDirectory oldPath - oldPathDirExists <- doesDirectoryExist oldPathDir - -- 'setup clean' didn't complete, 'dist/setup' still exists. - when oldPathDirExists $ - Win32.moveFile path' oldPath -#endif - -getExternalSetupMethod - :: 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 setupDir - (cabalLibVersion, mCabalLibInstalledPkgId, options') <- cabalLibVersionToUse - debug verbosity $ "Using Cabal library version " ++ prettyShow cabalLibVersion - path <- if useCachedSetupExecutable - then getCachedSetupExecutable options' - cabalLibVersion mCabalLibInstalledPkgId - else compileSetupExecutable options' - cabalLibVersion mCabalLibInstalledPkgId False - - -- Since useWorkingDir can change the relative path, the path argument must - -- 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 - - -- See 'Note: win32 clean hack' above. -#ifdef mingw32_HOST_OS - -- setupProgFile may not exist if we're using a cached program - setupProgFile' <- canonicalizePathNoThrow setupProgFile - let win32CleanHackNeeded = (useWin32CleanHack options) - -- Skip when a cached setup script is used. - && setupProgFile' `equalFilePath` path' -#else - let win32CleanHackNeeded = False -#endif - let options'' = options' { useWin32CleanHack = win32CleanHackNeeded } - - return (cabalLibVersion, ExternalMethod path', options'') - - where - setupDir = workingDir options useDistPref options "setup" - setupVersionFile = setupDir "setup" <.> "version" - setupHs = setupDir "setup" <.> "hs" - setupProgFile = setupDir "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 - (&&) <$> setupProgFile `existsAndIsMoreRecentThan` setupHs - <*> setupProgFile `existsAndIsMoreRecentThan` setupVersionFile - - writeSetupVersionFile :: Version -> IO () - writeSetupVersionFile version = - writeFile 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 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) $ die' verbosity - "Using 'build-type: Custom' but there is no Setup.hs or Setup.lhs script." - let src = (if useHs then customSetupHs else customSetupLhs) - srcNewer <- src `moreRecentFile` setupHs - when srcNewer $ if useHs - then copyFileVerbose verbosity src setupHs - else runSimplePreProcessor ppUnlit src setupHs verbosity - where - customSetupHs = workingDir options "Setup.hs" - customSetupLhs = workingDir options "Setup.lhs" - - updateSetupScript cabalLibVersion _ = - rewriteFileLBS verbosity setupHs (buildTypeScript cabalLibVersion) - - buildTypeScript :: Version -> BS.ByteString - buildTypeScript cabalLibVersion = case bt of - Simple -> "import Distribution.Simple; main = defaultMain\n" - Configure | 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" - 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 - [] -> die' verbosity $ "The package '" ++ prettyShow (packageName pkg) - ++ "' requires Cabal library version " - ++ prettyShow (useCabalVersion options) - ++ " but no suitable version is installed." - 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 - cabalDir <- getCabalDir - let setupCacheDir = cabalDir "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 - 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') $ - Strip.stripExe verbosity platform (useProgramDb options') - 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 <- setupHs `moreRecentFile` setupProgFile - cabalVersionNewer <- setupVersionFile `moreRecentFile` setupProgFile - let outOfDate = setupHsNewer || cabalVersionNewer - when (outOfDate || forceCompile) $ do - debug verbosity "Setup executable needs to be updated, compiling..." - (compiler, progdb, options'') <- configureCompiler 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' we enforce the deps specified, - -- so only the given ones can be used. Otherwise we allow the use - -- of packages in the ambient environment, and add on a dep on the - -- Cabal library (unless 'useDependencies' already contains one). - -- - -- With 'useVersionMacros' we use a version CPP macros .h file. - -- - -- Both of these options should be enabled for packages that have - -- opted-in and declared a custom-settup stanza. - -- - selectedDeps | useDependenciesExclusive options' - = useDependencies options' - | otherwise = useDependencies options' ++ - if any (isCabalPkgId . snd) - (useDependencies options') - then [] - else cabalDep - addRenaming (ipid, _) = - -- Assert 'DefUnitId' invariant - (Backpack.DefiniteUnitId (unsafeMkDefUnitId (newSimpleUnitId ipid)) - ,defaultRenaming) - cppMacrosFile = setupDir "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 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 [workingDir options'] - _ -> mempty - , ghcOptPackageDBs = usePackageDB options'' - , ghcOptHideAllPackages = Flag (useDependenciesExclusive options') - , ghcOptCabal = Flag (useDependenciesExclusive options') - , ghcOptPackages = toNubListR $ map addRenaming selectedDeps - , ghcOptCppIncludes = toNubListR [ cppMacrosFile - | useVersionMacros options' ] - , ghcOptExtra = extraOpts - } - let ghcCmdLine = renderGhcOptions compiler platform ghcOptions - when (useVersionMacros options') $ - rewriteFileEx verbosity cppMacrosFile - $ generatePackageVersionMacros (pkgVersion $ package pkg) (map snd selectedDeps) - case useLoggingHandle options of - Nothing -> runDbProgram verbosity program progdb ghcCmdLine - - -- If build logging is enabled, redirect compiler output to - -- the log file. - (Just logHandle) -> do output <- getDbProgramOutput verbosity program - progdb ghcCmdLine - hPutStr logHandle output - return setupProgFile - - -isCabalPkgId :: PackageIdentifier -> Bool -isCabalPkgId (PackageIdentifier pname _) = pname == mkPackageName "Cabal" diff --git a/cabal/cabal-install/Distribution/Client/SolverInstallPlan.hs b/cabal/cabal-install/Distribution/Client/SolverInstallPlan.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/SolverInstallPlan.hs +++ /dev/null @@ -1,440 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE TypeFamilies #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.SolverInstallPlan --- Copyright : (c) Duncan Coutts 2008 --- License : BSD-like --- --- Maintainer : duncan@community.haskell.org --- Stability : provisional --- Portability : portable --- --- The 'SolverInstallPlan' is the graph of packages produced by the --- dependency solver, and specifies at the package-granularity what --- things are going to be installed. To put it another way: the --- dependency solver produces a 'SolverInstallPlan', which is then --- consumed by various other parts of Cabal. --- ------------------------------------------------------------------------------ -module Distribution.Client.SolverInstallPlan( - SolverInstallPlan(..), - SolverPlanPackage, - ResolverPackage(..), - - -- * Operations on 'SolverInstallPlan's - new, - toList, - toMap, - - remove, - - showPlanIndex, - showInstallPlan, - - -- * Checking validity of plans - valid, - closed, - consistent, - acyclic, - - -- ** Details on invalid plans - SolverPlanProblem(..), - showPlanProblem, - problems, - - -- ** Querying the install plan - dependencyClosure, - reverseDependencyClosure, - topologicalOrder, - reverseTopologicalOrder, -) where - -import Distribution.Client.Compat.Prelude hiding (toList) -import Prelude () - -import Distribution.Package - ( PackageIdentifier(..), Package(..), PackageName - , HasUnitId(..), PackageId, packageVersion, packageName ) -import Distribution.Types.Flag (nullFlagAssignment) -import qualified Distribution.Solver.Types.ComponentDeps as CD - -import Distribution.Client.Types - ( UnresolvedPkgLoc ) -import Distribution.Version - ( Version ) - -import Distribution.Solver.Types.Settings -import Distribution.Solver.Types.ResolverPackage -import Distribution.Solver.Types.SolverId -import Distribution.Solver.Types.SolverPackage - -import Distribution.Compat.Graph (Graph, IsNode(..)) -import qualified Data.Foldable as Foldable -import qualified Data.Graph as OldGraph -import qualified Distribution.Compat.Graph as Graph -import qualified Data.Map as Map -import Data.Array ((!)) - -type SolverPlanPackage = ResolverPackage UnresolvedPkgLoc - -type SolverPlanIndex = Graph SolverPlanPackage - -data SolverInstallPlan = SolverInstallPlan { - planIndex :: !SolverPlanIndex, - planIndepGoals :: !IndependentGoals - } - deriving (Typeable, 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 - -showPlanIndex :: [SolverPlanPackage] -> String -showPlanIndex = intercalate "\n" . map showPlanPackage - -showInstallPlan :: SolverInstallPlan -> String -showInstallPlan = showPlanIndex . toList - -showPlanPackage :: SolverPlanPackage -> String -showPlanPackage (PreExisting ipkg) = "PreExisting " ++ prettyShow (packageId ipkg) - ++ " (" ++ prettyShow (installedUnitId ipkg) - ++ ")" -showPlanPackage (Configured spkg) = - "Configured " ++ prettyShow (packageId spkg) ++ flags ++ comps - where - flags - | nullFlagAssignment fa = "" - | otherwise = " " ++ prettyShow (solverPkgFlags spkg) - where - fa = solverPkgFlags spkg - - comps | null deps = "" - | otherwise = " " ++ unwords (map prettyShow $ Foldable.toList deps) - where - deps = CD.components (solverPkgLibDeps spkg) - <> CD.components (solverPkgExeDeps spkg) - --- | Build an installation plan from a valid set of resolved packages. --- -new :: IndependentGoals - -> SolverPlanIndex - -> Either [SolverPlanProblem] SolverInstallPlan -new indepGoals index = - case problems indepGoals index of - [] -> Right (SolverInstallPlan index indepGoals) - probs -> Left probs - -toList :: SolverInstallPlan -> [SolverPlanPackage] -toList = Foldable.toList . planIndex - -toMap :: SolverInstallPlan -> Map SolverId SolverPlanPackage -toMap = Graph.toMap . planIndex - --- | Remove packages from the install plan. This will result in an --- error if there are remaining packages that depend on any matching --- package. This is primarily useful for obtaining an install plan for --- the dependencies of a package or set of packages without actually --- installing the package itself, as when doing development. --- -remove :: (SolverPlanPackage -> Bool) - -> SolverInstallPlan - -> Either [SolverPlanProblem] - (SolverInstallPlan) -remove shouldRemove plan = - new (planIndepGoals plan) newIndex - where - newIndex = Graph.fromDistinctList $ - filter (not . shouldRemove) (toList plan) - --- ------------------------------------------------------------ --- * Checking validity of plans --- ------------------------------------------------------------ - --- | A valid installation plan is a set of packages that is 'acyclic', --- 'closed' and 'consistent'. Also, every 'ConfiguredPackage' in the --- plan has to have a valid configuration (see 'configuredPackageValid'). --- --- * if the result is @False@ use 'problems' to get a detailed list. --- -valid :: IndependentGoals - -> SolverPlanIndex - -> Bool -valid indepGoals index = - null $ problems indepGoals index - -data SolverPlanProblem = - PackageMissingDeps SolverPlanPackage - [PackageIdentifier] - | PackageCycle [SolverPlanPackage] - | PackageInconsistency PackageName [(PackageIdentifier, Version)] - | PackageStateInvalid SolverPlanPackage SolverPlanPackage - -showPlanProblem :: SolverPlanProblem -> String -showPlanProblem (PackageMissingDeps pkg missingDeps) = - "Package " ++ prettyShow (packageId 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.packageId) cycleGroup) - -showPlanProblem (PackageInconsistency name inconsistencies) = - "Package " ++ prettyShow name - ++ " is required by several packages," - ++ " but they require inconsistent versions:\n" - ++ unlines [ " package " ++ prettyShow pkg ++ " requires " - ++ prettyShow (PackageIdentifier name ver) - | (pkg, ver) <- inconsistencies ] - -showPlanProblem (PackageStateInvalid pkg pkg') = - "Package " ++ prettyShow (packageId pkg) - ++ " is in the " ++ showPlanState pkg - ++ " state but it depends on package " ++ prettyShow (packageId pkg') - ++ " which is in the " ++ showPlanState pkg' - ++ " state" - where - showPlanState (PreExisting _) = "pre-existing" - showPlanState (Configured _) = "configured" - --- | 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 :: IndependentGoals - -> SolverPlanIndex - -> [SolverPlanProblem] -problems indepGoals index = - - [ PackageMissingDeps pkg - (mapMaybe - (fmap packageId . flip Graph.lookup index) - missingDeps) - | (pkg, missingDeps) <- Graph.broken index ] - - ++ [ PackageCycle cycleGroup - | cycleGroup <- Graph.cycles index ] - - ++ [ PackageInconsistency name inconsistencies - | (name, inconsistencies) <- - dependencyInconsistencies indepGoals index ] - - ++ [ PackageStateInvalid pkg pkg' - | pkg <- Foldable.toList index - , Just pkg' <- map (flip Graph.lookup index) - (nodeNeighbors pkg) - , not (stateDependencyRelation pkg pkg') ] - - --- | Compute all roots of the install plan, and verify that the transitive --- plans from those roots are all consistent. --- --- NOTE: This does not check for dependency cycles. Moreover, dependency cycles --- may be absent from the subplans even if the larger plan contains a dependency --- 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 = - concatMap dependencyInconsistencies' subplans - where - subplans :: [SolverPlanIndex] - subplans = -- Not Graph.closure!! - map (nonSetupClosure index) - (rootSets indepGoals index) - --- NB: When we check for inconsistencies, packages from the setup --- scripts don't count as part of the closure (this way, we --- can build, e.g., Cabal-1.24.1 even if its setup script is --- built with Cabal-1.24.0). --- --- This is a best effort function that swallows any non-existent --- SolverIds. -nonSetupClosure :: SolverPlanIndex - -> [SolverId] - -> SolverPlanIndex -nonSetupClosure index pkgids0 = closure Graph.empty pkgids0 - where - closure completed [] = completed - closure completed (pkgid:pkgids) = - case Graph.lookup pkgid index of - Nothing -> closure completed pkgids - Just pkg -> - case Graph.lookup (nodeKey pkg) completed of - Just _ -> closure completed pkgids - Nothing -> closure completed' pkgids' - where completed' = Graph.insert pkg completed - pkgids' = CD.nonSetupDeps (resolverPackageLibDeps pkg) ++ pkgids - --- | Compute the root sets of a plan --- --- A root set is a set of packages whose dependency closure must be consistent. --- This is the set of all top-level library roots (taken together normally, or --- as singletons sets if we are considering them as independent goals), along --- with all setup dependencies of all packages. -rootSets :: IndependentGoals -> SolverPlanIndex -> [[SolverId]] -rootSets (IndependentGoals indepGoals) index = - if indepGoals then map (:[]) libRoots else [libRoots] - ++ setupRoots index - where - libRoots = libraryRoots index - --- | Compute the library roots of a plan --- --- The library roots are the set of packages with no reverse dependencies --- (no reverse library dependencies but also no reverse setup dependencies). -libraryRoots :: SolverPlanIndex -> [SolverId] -libraryRoots index = - map (nodeKey . toPkgId) roots - where - (graph, toPkgId, _) = Graph.toGraph index - indegree = OldGraph.indegree graph - roots = filter isRoot (OldGraph.vertices graph) - isRoot v = indegree ! v == 0 - --- | The setup dependencies of each package in the plan -setupRoots :: SolverPlanIndex -> [[SolverId]] -setupRoots = filter (not . null) - . map (CD.setupDeps . resolverPackageLibDeps) - . Foldable.toList - --- | Given a package index where we assume we want to use all the packages --- (use 'dependencyClosure' if you need to get such a index subset) find out --- if the dependencies within it use consistent versions of each package. --- Return all cases where multiple packages depend on different versions of --- some other package. --- --- Each element in the result is a package name along with the packages that --- depend on it and the versions they require. These are guaranteed to be --- distinct. --- -dependencyInconsistencies' :: SolverPlanIndex - -> [(PackageName, [(PackageIdentifier, Version)])] -dependencyInconsistencies' index = - [ (name, [ (pid, packageVersion dep) | (dep,pids) <- uses, pid <- pids]) - | (name, ipid_map) <- Map.toList inverseIndex - , let uses = Map.elems ipid_map - , reallyIsInconsistent (map fst uses) - ] - where - -- For each package name (of a dependency, somewhere) - -- 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.fromListWith (Map.unionWith (\(a,b) (_,b') -> (a,b++b'))) - [ (packageName dep, Map.fromList [(sid,(dep,[packageId pkg]))]) - | -- For each package @pkg@ - pkg <- Foldable.toList index - -- Find out which @sid@ @pkg@ depends on - , sid <- CD.nonSetupDeps (resolverPackageLibDeps pkg) - -- And look up those @sid@ (i.e., @sid@ is the ID of @dep@) - , Just dep <- [Graph.lookup sid index] - ] - - -- If, in a single install plan, we depend on more than one version of a - -- package, then this is ONLY okay in the (rather special) case that we - -- depend on precisely two versions of that package, and one of them - -- depends on the other. This is necessary for example for the base where - -- we have base-3 depending on base-4. - reallyIsInconsistent :: [SolverPlanPackage] -> Bool - reallyIsInconsistent [] = False - reallyIsInconsistent [_p] = False - reallyIsInconsistent [p1, p2] = - let pid1 = nodeKey p1 - pid2 = nodeKey p2 - in pid1 `notElem` CD.nonSetupDeps (resolverPackageLibDeps p2) - && pid2 `notElem` CD.nonSetupDeps (resolverPackageLibDeps p1) - reallyIsInconsistent _ = True - - --- | The graph of packages (nodes) and dependencies (edges) must be acyclic. --- --- * if the result is @False@ use 'PackageIndex.dependencyCycles' to find out --- which packages are involved in dependency cycles. --- -acyclic :: SolverPlanIndex -> Bool -acyclic = null . Graph.cycles - --- | An installation plan is closed if for every package in the set, all of --- its dependencies are also in the set. That is, the set is closed under the --- dependency relation. --- --- * if the result is @False@ use 'PackageIndex.brokenPackages' to find out --- which packages depend on packages not in the index. --- -closed :: SolverPlanIndex -> Bool -closed = null . Graph.broken - --- | An installation plan is consistent if all dependencies that target a --- single package name, target the same version. --- --- This is slightly subtle. It is not the same as requiring that there be at --- most one version of any package in the set. It only requires that of --- packages which have more than one other package depending on them. We could --- actually make the condition even more precise and say that different --- versions are OK so long as they are not both in the transitive closure of --- any other package (or equivalently that their inverse closures do not --- intersect). The point is we do not want to have any packages depending --- directly or indirectly on two different versions of the same package. The --- current definition is just a safe approximation of that. --- --- * if the result is @False@ use 'PackageIndex.dependencyInconsistencies' to --- find out which packages are. --- -consistent :: SolverPlanIndex -> Bool -consistent = null . dependencyInconsistencies (IndependentGoals False) - --- | The states of packages have that depend on each other must respect --- this relation. That is for very case where package @a@ depends on --- package @b@ we require that @dependencyStatesOk a b = True@. --- -stateDependencyRelation :: SolverPlanPackage - -> SolverPlanPackage - -> Bool -stateDependencyRelation PreExisting{} PreExisting{} = True - -stateDependencyRelation (Configured _) PreExisting{} = True -stateDependencyRelation (Configured _) (Configured _) = True - -stateDependencyRelation _ _ = False - - --- | Compute the dependency closure of a package in a install plan --- -dependencyClosure :: SolverInstallPlan - -> [SolverId] - -> [SolverPlanPackage] -dependencyClosure plan = fromMaybe [] . Graph.closure (planIndex plan) - - -reverseDependencyClosure :: SolverInstallPlan - -> [SolverId] - -> [SolverPlanPackage] -reverseDependencyClosure plan = fromMaybe [] . Graph.revClosure (planIndex plan) - - -topologicalOrder :: SolverInstallPlan - -> [SolverPlanPackage] -topologicalOrder plan = Graph.topSort (planIndex plan) - - -reverseTopologicalOrder :: SolverInstallPlan - -> [SolverPlanPackage] -reverseTopologicalOrder plan = Graph.revTopSort (planIndex plan) diff --git a/cabal/cabal-install/Distribution/Client/SourceFiles.hs b/cabal/cabal-install/Distribution/Client/SourceFiles.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/SourceFiles.hs +++ /dev/null @@ -1,167 +0,0 @@ --- | Contains an @sdist@ like function which computes the source files --- that we should track to determine if a rebuild is necessary. --- Unlike @sdist@, we can operate directly on the true --- 'PackageDescription' (not flattened). --- --- The naming convention, roughly, is that to declare we need the --- source for some type T, you use the function needT; some functions --- need auxiliary information. --- --- We can only use this code for non-Custom scripts; Custom scripts --- may have arbitrary extra dependencies (esp. new preprocessors) which --- we cannot "see" easily. -module Distribution.Client.SourceFiles (needElaboratedConfiguredPackage) where - -import Distribution.Client.ProjectPlanning.Types -import Distribution.Client.RebuildMonad - -import Distribution.Solver.Types.OptionalStanza - -import Distribution.Simple.PreProcess - -import Distribution.Types.PackageDescription -import Distribution.Types.Component -import Distribution.Types.ComponentRequestedSpec -import Distribution.Types.Library -import Distribution.Types.Executable -import Distribution.Types.Benchmark -import Distribution.Types.BenchmarkInterface -import Distribution.Types.TestSuite -import Distribution.Types.TestSuiteInterface -import Distribution.Types.BuildInfo -import Distribution.Types.ForeignLib - -import Distribution.ModuleName - -import Prelude () -import Distribution.Client.Compat.Prelude - -import System.FilePath -import qualified Data.Set as Set - -needElaboratedConfiguredPackage :: ElaboratedConfiguredPackage -> Rebuild () -needElaboratedConfiguredPackage elab = - case elabPkgOrComp elab of - ElabComponent ecomp -> needElaboratedComponent elab ecomp - ElabPackage epkg -> needElaboratedPackage elab epkg - -needElaboratedPackage :: ElaboratedConfiguredPackage -> ElaboratedPackage -> Rebuild () -needElaboratedPackage elab epkg = - traverse_ (needComponent pkg_descr) (enabledComponents pkg_descr enabled) - where - pkg_descr = elabPkgDescription elab - enabled_stanzas = pkgStanzasEnabled epkg - -- TODO: turn this into a helper function somewhere - enabled = - ComponentRequestedSpec { - testsRequested = TestStanzas `Set.member` enabled_stanzas, - benchmarksRequested = BenchStanzas `Set.member` enabled_stanzas - } - -needElaboratedComponent :: ElaboratedConfiguredPackage -> ElaboratedComponent -> Rebuild () -needElaboratedComponent elab ecomp = - case mb_comp of - Nothing -> needSetup - Just comp -> needComponent pkg_descr comp - where - pkg_descr = elabPkgDescription elab - mb_comp = fmap (getComponent pkg_descr) (compComponentName ecomp) - -needComponent :: PackageDescription -> Component -> Rebuild () -needComponent pkg_descr comp = - case comp of - CLib lib -> needLibrary pkg_descr lib - CFLib flib -> needForeignLib pkg_descr flib - CExe exe -> needExecutable pkg_descr exe - CTest test -> needTestSuite pkg_descr test - CBench bench -> needBenchmark pkg_descr bench - -needSetup :: Rebuild () -needSetup = findFirstFileMonitored id ["Setup.hs", "Setup.lhs"] >> return () - -needLibrary :: PackageDescription -> Library -> Rebuild () -needLibrary pkg_descr (Library { exposedModules = modules - , signatures = sigs - , libBuildInfo = bi }) - = needBuildInfo pkg_descr bi (modules ++ sigs) - -needForeignLib :: PackageDescription -> ForeignLib -> Rebuild () -needForeignLib pkg_descr (ForeignLib { foreignLibModDefFile = fs - , foreignLibBuildInfo = bi }) - = do traverse_ needIfExists fs - needBuildInfo pkg_descr bi [] - -needExecutable :: PackageDescription -> Executable -> Rebuild () -needExecutable pkg_descr (Executable { modulePath = mainPath - , buildInfo = bi }) - = do needBuildInfo pkg_descr bi [] - needMainFile bi mainPath - -needTestSuite :: PackageDescription -> TestSuite -> Rebuild () -needTestSuite pkg_descr t - = case testInterface t of - TestSuiteExeV10 _ mainPath -> do - needBuildInfo pkg_descr bi [] - needMainFile bi mainPath - TestSuiteLibV09 _ m -> - needBuildInfo pkg_descr bi [m] - TestSuiteUnsupported _ -> return () -- soft fail - where - bi = testBuildInfo t - -needMainFile :: BuildInfo -> FilePath -> Rebuild () -needMainFile bi mainPath = do - -- The matter here is subtle. It might *seem* that we - -- should just search for mainPath, but as per - -- b61cb051f63ed5869b8f4a6af996ff7e833e4b39 'main-is' - -- will actually be the source file AFTER preprocessing, - -- whereas we need to get the file *prior* to preprocessing. - ppFile <- findFileWithExtensionMonitored - (ppSuffixes knownSuffixHandlers) - (hsSourceDirs bi) - (dropExtension mainPath) - case ppFile of - -- But check the original path in the end, because - -- maybe it's a non-preprocessed file with a non-traditional - -- extension. - Nothing -> findFileMonitored (hsSourceDirs bi) mainPath - >>= maybe (return ()) need - Just pp -> need pp - -needBenchmark :: PackageDescription -> Benchmark -> Rebuild () -needBenchmark pkg_descr bm - = case benchmarkInterface bm of - BenchmarkExeV10 _ mainPath -> do - needBuildInfo pkg_descr bi [] - needMainFile bi mainPath - BenchmarkUnsupported _ -> return () -- soft fail - where - bi = benchmarkBuildInfo bm - -needBuildInfo :: PackageDescription -> BuildInfo -> [ModuleName] -> Rebuild () -needBuildInfo pkg_descr bi modules = do - -- NB: These are separate because there may be both A.hs and - -- A.hs-boot; need to track both. - findNeededModules ["hs", "lhs", "hsig", "lhsig"] - findNeededModules ["hs-boot", "lhs-boot"] - traverse_ needIfExists $ concat - [ cSources bi - , cxxSources bi - , jsSources bi - , cmmSources bi - , asmSources bi - , extraSrcFiles pkg_descr - ] - for_ (installIncludes bi) $ \f -> - findFileMonitored ("." : includeDirs bi) f - >>= maybe (return ()) need - where - findNeededModules exts = traverse_ - (findNeededModule exts) - (modules ++ otherModules bi) - findNeededModule exts m = - findFileWithExtensionMonitored - (ppSuffixes knownSuffixHandlers ++ exts) - (hsSourceDirs bi) - (toFilePath m) - >>= maybe (return ()) need diff --git a/cabal/cabal-install/Distribution/Client/SrcDist.hs b/cabal/cabal-install/Distribution/Client/SrcDist.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/SrcDist.hs +++ /dev/null @@ -1,93 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} --- | Utilities to implemenet cabal @v2-sdist@. -module Distribution.Client.SrcDist ( - allPackageSourceFiles, - packageDirToSdist, -) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Control.Monad.State.Lazy (StateT, evalStateT, gets, modify) -import Control.Monad.Trans (liftIO) -import Control.Monad.Writer.Lazy (WriterT, execWriterT, tell) -import System.FilePath (normalise, takeDirectory, ()) - -import Distribution.Client.Utils (tryFindAddSourcePackageDesc) -import Distribution.Package (Package (packageId)) -import Distribution.PackageDescription.Configuration (flattenPackageDescription) -import Distribution.PackageDescription.Parsec (readGenericPackageDescription) -import Distribution.Simple.PreProcess (knownSuffixHandlers) -import Distribution.Simple.SrcDist (listPackageSources) -import Distribution.Simple.SrcDist (listPackageSourcesWithDie) -import Distribution.Simple.Utils (die') -import Distribution.Types.GenericPackageDescription (GenericPackageDescription) - -import qualified Codec.Archive.Tar as Tar -import qualified Codec.Archive.Tar.Entry as Tar -import qualified Codec.Compression.GZip as GZip -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BSL -import qualified Data.Set as Set - --- | List all source files of a given add-source dependency. Exits with error if --- something is wrong (e.g. there is no .cabal file in the given directory). --- --- Used in sandbox and projectbuilding. --- TODO: when sandboxes are removed, move to ProjectBuilding. --- -allPackageSourceFiles :: Verbosity -> FilePath -> IO [FilePath] -allPackageSourceFiles verbosity packageDir = do - pd <- do - let err = "Error reading source files of package." - desc <- tryFindAddSourcePackageDesc verbosity packageDir err - flattenPackageDescription `fmap` readGenericPackageDescription verbosity desc - - listPackageSourcesWithDie verbosity (\_ _ -> return []) packageDir pd knownSuffixHandlers - --- | Create a tarball for a package in a directory -packageDirToSdist - :: Verbosity - -> GenericPackageDescription -- ^ read in GPD - -> FilePath -- ^ directory containing that GPD - -> IO BSL.ByteString -- ^ resulting sdist tarball -packageDirToSdist verbosity gpd dir = do - files' <- listPackageSources verbosity dir (flattenPackageDescription gpd) knownSuffixHandlers - let files = nub $ sort $ map normalise files' - - let entriesM :: StateT (Set.Set FilePath) (WriterT [Tar.Entry] IO) () - entriesM = do - let prefix = prettyShow (packageId gpd) - modify (Set.insert prefix) - case Tar.toTarPath True prefix of - Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err) - Right path -> tell [Tar.directoryEntry path] - - for_ files $ \file -> do - let fileDir = takeDirectory (prefix file) - needsEntry <- gets (Set.notMember fileDir) - - when needsEntry $ do - modify (Set.insert fileDir) - case Tar.toTarPath True fileDir of - Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err) - Right path -> tell [Tar.directoryEntry path] - - contents <- liftIO . fmap BSL.fromStrict . BS.readFile $ dir file - case Tar.toTarPath False (prefix file) of - Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err) - Right path -> tell [(Tar.fileEntry path contents) { Tar.entryPermissions = Tar.ordinaryFilePermissions }] - - entries <- execWriterT (evalStateT entriesM mempty) - let -- Pretend our GZip file is made on Unix. - normalize bs = BSL.concat [pfx, "\x03", rest'] - where - (pfx, rest) = BSL.splitAt 9 bs - rest' = BSL.tail rest - -- The Unix epoch, which is the default value, is - -- unsuitable because it causes unpacking problems on - -- Windows; we need a post-1980 date. One gigasecond - -- after the epoch is during 2001-09-09, so that does - -- nicely. See #5596. - setModTime entry = entry { Tar.entryTime = 1000000000 } - return . normalize . GZip.compress . Tar.write $ fmap setModTime entries diff --git a/cabal/cabal-install/Distribution/Client/Store.hs b/cabal/cabal-install/Distribution/Client/Store.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Store.hs +++ /dev/null @@ -1,276 +0,0 @@ -{-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns #-} - - --- | Management for the installed package store. --- -module Distribution.Client.Store ( - - -- * The store layout - StoreDirLayout(..), - defaultStoreDirLayout, - - -- * Reading store entries - getStoreEntries, - doesStoreEntryExist, - - -- * Creating store entries - newStoreEntry, - NewStoreEntryOutcome(..), - - -- * Concurrency strategy - -- $concurrency - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude - -import Distribution.Client.DistDirLayout -import Distribution.Client.RebuildMonad - -import Distribution.Package (UnitId, mkUnitId) -import Distribution.Compiler (CompilerId) - -import Distribution.Simple.Utils - ( withTempDirectory, debug, info ) -import Distribution.Verbosity - ( silent ) - -import qualified Data.Set as Set -import Control.Exception -import System.FilePath -import System.Directory - -#ifdef MIN_VERSION_lukko -import Lukko -#else -import System.IO (openFile, IOMode(ReadWriteMode), hClose) -import GHC.IO.Handle.Lock (hLock, hTryLock, LockMode(ExclusiveLock)) -#if MIN_VERSION_base(4,11,0) -import GHC.IO.Handle.Lock (hUnlock) -#endif -#endif - --- $concurrency --- --- We access and update the store concurrently. Our strategy to do that safely --- is as follows. --- --- The store entries once created are immutable. This alone simplifies matters --- considerably. --- --- Additionally, the way 'UnitId' hashes are constructed means that if a store --- entry exists already then we can assume its content is ok to reuse, rather --- than having to re-recreate. This is the nix-style input hashing concept. --- --- A consequence of this is that with a little care it is /safe/ to race --- updates against each other. Consider two independent concurrent builds that --- both want to build a particular 'UnitId', where that entry does not yet --- exist in the store. It is safe for both to build and try to install this --- entry into the store provided that: --- --- * only one succeeds --- * the looser discovers that they lost, they abandon their own build and --- re-use the store entry installed by the winner. --- --- Note that because builds are not reproducible in general (nor even --- necessarily ABI compatible) then it is essential that the loser abandon --- their build and use the one installed by the winner, so that subsequent --- packages are built against the exact package from the store rather than some --- morally equivalent package that may not be ABI compatible. --- --- Our overriding goal is that store reads be simple, cheap and not require --- locking. We will derive our write-side protocol to make this possible. --- --- The read-side protocol is simply: --- --- * check for the existence of a directory entry named after the 'UnitId' in --- question. That is, if the dir entry @$root/foo-1.0-fe56a...@ exists then --- the store entry can be assumed to be complete and immutable. --- --- Given our read-side protocol, the final step on the write side must be to --- atomically rename a fully-formed store entry directory into its final --- location. While this will indeed be the final step, the preparatory steps --- are more complicated. The tricky aspect is that the store also contains a --- number of shared package databases (one per compiler version). Our read --- strategy means that by the time we install the store dir entry the package --- db must already have been updated. We cannot do the package db update --- as part of atomically renaming the store entry directory however. Furthermore --- it is not safe to allow either package db update because the db entry --- contains the ABI hash and this is not guaranteed to be deterministic. So we --- must register the new package prior to the atomic dir rename. Since this --- combination of steps are not atomic then we need locking. --- --- The write-side protocol is: --- --- * Create a unique temp dir and write all store entry files into it. --- --- * Take a lock named after the 'UnitId' in question. --- --- * Once holding the lock, check again for the existence of the final store --- entry directory. If the entry exists then the process lost the race and it --- must abandon, unlock and re-use the existing store entry. If the entry --- does not exist then the process won the race and it can proceed. --- --- * Register the package into the package db. Note that the files are not in --- their final location at this stage so registration file checks may need --- to be disabled. --- --- * Atomically rename the temp dir to the final store entry location. --- --- * Release the previously-acquired lock. --- --- Obviously this means it is possible to fail after registering but before --- installing the store entry, leaving a dangling package db entry. This is not --- much of a problem because this entry does not determine package existence --- for cabal. It does mean however that the package db update should be insert --- or replace, i.e. not failing if the db entry already exists. - - --- | Check if a particular 'UnitId' exists in the store. --- -doesStoreEntryExist :: StoreDirLayout -> CompilerId -> UnitId -> IO Bool -doesStoreEntryExist StoreDirLayout{storePackageDirectory} compid unitid = - doesDirectoryExist (storePackageDirectory compid unitid) - - --- | Return the 'UnitId's of all packages\/components already installed in the --- store. --- -getStoreEntries :: StoreDirLayout -> CompilerId -> Rebuild (Set UnitId) -getStoreEntries StoreDirLayout{storeDirectory} compid = do - paths <- getDirectoryContentsMonitored (storeDirectory compid) - return $! mkEntries paths - where - mkEntries = Set.delete (mkUnitId "package.db") - . Set.delete (mkUnitId "incoming") - . Set.fromList - . map mkUnitId - . filter valid - valid ('.':_) = False - valid _ = True - - --- | The outcome of 'newStoreEntry': either the store entry was newly created --- or it existed already. The latter case happens if there was a race between --- two builds of the same store entry. --- -data NewStoreEntryOutcome = UseNewStoreEntry - | UseExistingStoreEntry - deriving (Eq, Show) - --- | Place a new entry into the store. See the concurrency strategy description --- for full details. --- --- In particular, it takes two actions: one to place files into a temporary --- location, and a second to perform any necessary registration. The first --- action is executed without any locks held (the temp dir is unique). The --- second action holds a lock that guarantees that only one cabal process is --- able to install this store entry. This means it is safe to register into --- the compiler package DB or do other similar actions. --- --- Note that if you need to use the registration information later then you --- /must/ check the 'NewStoreEntryOutcome' and if it's'UseExistingStoreEntry' --- then you must read the existing registration information (unless your --- registration information is constructed fully deterministically). --- -newStoreEntry :: Verbosity - -> StoreDirLayout - -> CompilerId - -> UnitId - -> (FilePath -> IO (FilePath, [FilePath])) -- ^ Action to place files. - -> IO () -- ^ Register action, if necessary. - -> IO NewStoreEntryOutcome -newStoreEntry verbosity storeDirLayout@StoreDirLayout{..} - compid unitid - copyFiles register = - -- See $concurrency above for an explanation of the concurrency protocol - - withTempIncomingDir storeDirLayout compid $ \incomingTmpDir -> do - - -- Write all store entry files within the temp dir and return the prefix. - (incomingEntryDir, otherFiles) <- copyFiles incomingTmpDir - - -- Take a lock named after the 'UnitId' in question. - withIncomingUnitIdLock verbosity storeDirLayout compid unitid $ do - - -- Check for the existence of the final store entry directory. - exists <- doesStoreEntryExist storeDirLayout compid unitid - - if exists - -- If the entry exists then we lost the race and we must abandon, - -- unlock and re-use the existing store entry. - then do - info verbosity $ - "Concurrent build race: abandoning build in favour of existing " - ++ "store entry " ++ prettyShow compid prettyShow unitid - return UseExistingStoreEntry - - -- If the entry does not exist then we won the race and can proceed. - else do - - -- Register the package into the package db (if appropriate). - register - - -- Atomically rename the temp dir to the final store entry location. - renameDirectory incomingEntryDir finalEntryDir - for_ otherFiles $ \file -> do - let finalStoreFile = storeDirectory compid makeRelative (incomingTmpDir (dropDrive (storeDirectory compid))) file - createDirectoryIfMissing True (takeDirectory finalStoreFile) - renameFile file finalStoreFile - - debug verbosity $ - "Installed store entry " ++ prettyShow compid prettyShow unitid - return UseNewStoreEntry - where - finalEntryDir = storePackageDirectory compid unitid - - -withTempIncomingDir :: StoreDirLayout -> CompilerId - -> (FilePath -> IO a) -> IO a -withTempIncomingDir StoreDirLayout{storeIncomingDirectory} compid action = do - createDirectoryIfMissing True incomingDir - withTempDirectory silent incomingDir "new" action - where - incomingDir = storeIncomingDirectory compid - - -withIncomingUnitIdLock :: Verbosity -> StoreDirLayout - -> CompilerId -> UnitId - -> IO a -> IO a -withIncomingUnitIdLock verbosity StoreDirLayout{storeIncomingLock} - compid unitid action = - bracket takeLock releaseLock (\_hnd -> action) - where -#ifdef MIN_VERSION_lukko - takeLock - | fileLockingSupported = do - fd <- fdOpen (storeIncomingLock compid unitid) - gotLock <- fdTryLock fd ExclusiveLock - unless gotLock $ do - info verbosity $ "Waiting for file lock on store entry " - ++ prettyShow compid prettyShow unitid - fdLock fd ExclusiveLock - return fd - - -- if there's no locking, do nothing. Be careful on AIX. - | otherwise = return undefined -- :( - - releaseLock fd - | fileLockingSupported = do - fdUnlock fd - fdClose fd - | otherwise = return () -#else - takeLock = do - h <- openFile (storeIncomingLock compid unitid) ReadWriteMode - -- First try non-blocking, but if we would have to wait then - -- log an explanation and do it again in blocking mode. - gotlock <- hTryLock h ExclusiveLock - unless gotlock $ do - info verbosity $ "Waiting for file lock on store entry " - ++ prettyShow compid prettyShow unitid - hLock h ExclusiveLock - return h - - releaseLock h = hUnlock h >> hClose h -#endif diff --git a/cabal/cabal-install/Distribution/Client/Tar.hs b/cabal/cabal-install/Distribution/Client/Tar.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Tar.hs +++ /dev/null @@ -1,114 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Tar --- Copyright : (c) 2007 Bjorn Bringert, --- 2008 Andrea Vezzosi, --- 2008-2009 Duncan Coutts --- License : BSD3 --- --- Maintainer : duncan@community.haskell.org --- Portability : portable --- --- Reading, writing and manipulating \"@.tar@\" archive files. --- ------------------------------------------------------------------------------ -module Distribution.Client.Tar ( - -- * @tar.gz@ operations - createTarGzFile, - extractTarGzFile, - - -- * Other local utils - buildTreeRefTypeCode, - buildTreeSnapshotTypeCode, - isBuildTreeRefTypeCode, - filterEntries, - filterEntriesM, - entriesToList, - ) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import qualified Data.ByteString.Lazy as BS -import qualified Codec.Archive.Tar as Tar -import qualified Codec.Archive.Tar.Entry as Tar -import qualified Codec.Archive.Tar.Check as Tar -import qualified Codec.Compression.GZip as GZip -import qualified Distribution.Client.GZipUtils as GZipUtils - --- for foldEntries... -import Control.Exception (throw) - --- --- * High level operations --- - -createTarGzFile :: FilePath -- ^ Full Tarball path - -> FilePath -- ^ Base directory - -> FilePath -- ^ Directory to archive, relative to base dir - -> IO () -createTarGzFile tar base dir = - BS.writeFile tar . GZip.compress . Tar.write =<< Tar.pack base [dir] - -extractTarGzFile :: FilePath -- ^ Destination directory - -> FilePath -- ^ Expected subdir (to check for tarbombs) - -> FilePath -- ^ Tarball - -> IO () -extractTarGzFile dir expected tar = - Tar.unpack dir . Tar.checkTarbomb expected . Tar.read - . GZipUtils.maybeDecompress =<< BS.readFile tar - -instance (Exception a, Exception b) => Exception (Either a b) where - toException (Left e) = toException e - toException (Right e) = toException e - - fromException e = - case fromException e of - Just e' -> Just (Left e') - Nothing -> case fromException e of - Just e' -> Just (Right e') - Nothing -> Nothing - - --- | Type code for the local build tree reference entry type. We don't use the --- symbolic link entry type because it allows only 100 ASCII characters for the --- path. -buildTreeRefTypeCode :: Tar.TypeCode -buildTreeRefTypeCode = 'C' - --- | Type code for the local build tree snapshot entry type. -buildTreeSnapshotTypeCode :: Tar.TypeCode -buildTreeSnapshotTypeCode = 'S' - --- | Is this a type code for a build tree reference? -isBuildTreeRefTypeCode :: Tar.TypeCode -> Bool -isBuildTreeRefTypeCode typeCode - | (typeCode == buildTreeRefTypeCode - || typeCode == buildTreeSnapshotTypeCode) = True - | otherwise = False - -filterEntries :: (Tar.Entry -> Bool) -> Tar.Entries e -> Tar.Entries e -filterEntries p = - Tar.foldEntries - (\e es -> if p e then Tar.Next e es else es) - Tar.Done - Tar.Fail - -filterEntriesM :: Monad m => (Tar.Entry -> m Bool) - -> Tar.Entries e -> m (Tar.Entries e) -filterEntriesM p = - Tar.foldEntries - (\entry rest -> do - keep <- p entry - xs <- rest - if keep - then return (Tar.Next entry xs) - else return xs) - (return Tar.Done) - (return . Tar.Fail) - -entriesToList :: Exception e => Tar.Entries e -> [Tar.Entry] -entriesToList = Tar.foldEntries (:) [] throw - diff --git a/cabal/cabal-install/Distribution/Client/TargetProblem.hs b/cabal/cabal-install/Distribution/Client/TargetProblem.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/TargetProblem.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -module Distribution.Client.TargetProblem ( - TargetProblem(..), - TargetProblem', -) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Client.ProjectPlanning (AvailableTarget) -import Distribution.Client.TargetSelector (SubComponentTarget, TargetSelector) -import Distribution.Package (PackageId, PackageName) -import Distribution.Simple.LocalBuildInfo (ComponentName (..)) -import Distribution.Types.UnqualComponentName (UnqualComponentName) - --- | Target problems that occur during project orchestration. -data TargetProblem a - = TargetNotInProject PackageName - | TargetAvailableInIndex PackageName - - | TargetComponentNotProjectLocal - PackageId ComponentName SubComponentTarget - - | TargetComponentNotBuildable - PackageId ComponentName SubComponentTarget - - | TargetOptionalStanzaDisabledByUser - PackageId ComponentName SubComponentTarget - - | TargetOptionalStanzaDisabledBySolver - PackageId ComponentName SubComponentTarget - - | TargetProblemUnknownComponent - PackageName (Either UnqualComponentName ComponentName) - - | TargetProblemNoneEnabled TargetSelector [AvailableTarget ()] - -- ^ The 'TargetSelector' matches component (test/benchmark/...) but none are buildable - - | TargetProblemNoTargets TargetSelector - -- ^ There are no targets at all - - -- The target matching stuff only returns packages local to the project, - -- so these lookups should never fail, but if 'resolveTargets' is called - -- directly then of course it can. - | TargetProblemNoSuchPackage PackageId - | TargetProblemNoSuchComponent PackageId ComponentName - - -- | A custom target problem - | CustomTargetProblem a - deriving (Eq, Show, Functor) - --- | Type alias for a 'TargetProblem' with no user-defined problems/errors. --- --- Can use the utilities below for reporting/rendering problems. -type TargetProblem' = TargetProblem Void diff --git a/cabal/cabal-install/Distribution/Client/TargetSelector.hs b/cabal/cabal-install/Distribution/Client/TargetSelector.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/TargetSelector.hs +++ /dev/null @@ -1,2490 +0,0 @@ -{-# LANGUAGE CPP, DeriveGeneric, DeriveFunctor, - RecordWildCards, NamedFieldPuns #-} --- TODO -{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.TargetSelector --- Copyright : (c) Duncan Coutts 2012, 2015, 2016 --- License : BSD-like --- --- Maintainer : duncan@community.haskell.org --- --- Handling for user-specified target selectors. --- ------------------------------------------------------------------------------ -module Distribution.Client.TargetSelector ( - - -- * Target selectors - TargetSelector(..), - TargetImplicitCwd(..), - ComponentKind(..), - ComponentKindFilter, - SubComponentTarget(..), - QualLevel(..), - componentKind, - - -- * Reading target selectors - readTargetSelectors, - TargetSelectorProblem(..), - reportTargetSelectorProblems, - showTargetSelector, - TargetString(..), - showTargetString, - parseTargetString, - -- ** non-IO - readTargetSelectorsWith, - DirActions(..), - defaultDirActions, - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude - -import Distribution.Package - ( Package(..), PackageId, PackageName, packageName ) -import Distribution.Types.UnqualComponentName - ( UnqualComponentName, mkUnqualComponentName, unUnqualComponentName - , packageNameToUnqualComponentName ) -import Distribution.Client.Types - ( PackageLocation(..), PackageSpecifier(..) ) - -import Distribution.PackageDescription - ( PackageDescription - , Executable(..) - , TestSuite(..), TestSuiteInterface(..), testModules - , Benchmark(..), BenchmarkInterface(..), benchmarkModules - , BuildInfo(..), explicitLibModules, exeModules ) -import Distribution.PackageDescription.Configuration - ( flattenPackageDescription ) -import Distribution.Solver.Types.SourcePackage - ( SourcePackage(..) ) -import Distribution.ModuleName - ( ModuleName, toFilePath ) -import Distribution.Simple.LocalBuildInfo - ( Component(..), ComponentName(..), LibraryName(..) - , pkgComponents, componentName, componentBuildInfo ) -import Distribution.Types.ForeignLib - -import Distribution.Simple.Utils - ( die', lowercase, ordNub ) -import Distribution.Client.Utils - ( makeRelativeCanonical ) - -import Data.List - ( stripPrefix, groupBy ) -import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Lazy as Map.Lazy -import qualified Data.Map.Strict as Map -import qualified Data.Set as Set -import Control.Arrow ((&&&)) -import Control.Monad - hiding ( mfilter ) -import qualified Distribution.Deprecated.ReadP as Parse -import Distribution.Deprecated.ReadP - ( (+++), (<++) ) -import Distribution.Deprecated.ParseUtils - ( readPToMaybe ) -import System.FilePath as FilePath - ( takeExtension, dropExtension - , splitDirectories, joinPath, splitPath ) -import qualified System.Directory as IO - ( doesFileExist, doesDirectoryExist, canonicalizePath - , getCurrentDirectory ) -import System.FilePath - ( (), (<.>), normalise, dropTrailingPathSeparator ) -import Text.EditDistance - ( defaultEditCosts, restrictedDamerauLevenshteinDistance ) - -import qualified Prelude (foldr1) - --- ------------------------------------------------------------ --- * Target selector terms --- ------------------------------------------------------------ - --- | A target selector is expression selecting a set of components (as targets --- for a 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, --- component names, files etc. Internally we consider a target to be a specific --- component (or module\/file within a component), and all the users' notions --- of targets are just different ways of referring to these component targets. --- --- So target selectors are expressions in the sense that they are interpreted --- to refer to one or more components. For example a 'TargetPackage' gets --- interpreted differently by different commands to refer to all or a subset --- of components within the package. --- --- The syntax has lots of optional parts: --- --- > [ package name | package dir | package .cabal file ] --- > [ [lib:|exe:] component name ] --- > [ module name | source file ] --- -data TargetSelector = - - -- | One (or more) packages as a whole, or all the components of a - -- particular kind within the package(s). - -- - -- These are always packages that are local to the project. In the case - -- that there is more than one, they all share the same directory location. - -- - TargetPackage TargetImplicitCwd [PackageId] (Maybe ComponentKindFilter) - - -- | A package specified by name. This may refer to @extra-packages@ from - -- the @cabal.project@ file, or a dependency of a known project package or - -- could refer to a package from a hackage archive. It needs further - -- context to resolve to a specific package. - -- - | TargetPackageNamed PackageName (Maybe ComponentKindFilter) - - -- | All packages, or all components of a particular kind in all packages. - -- - | TargetAllPackages (Maybe ComponentKindFilter) - - -- | A specific component in a package within the project. - -- - | TargetComponent PackageId ComponentName SubComponentTarget - - -- | A component in a package, but where it cannot be verified that the - -- package has such a component, or because the package is itself not - -- known. - -- - | TargetComponentUnknown PackageName - (Either UnqualComponentName ComponentName) - SubComponentTarget - deriving (Eq, Ord, Show, Generic) - --- | Does this 'TargetPackage' selector arise from syntax referring to a --- package in the current directory (e.g. @tests@ or no giving no explicit --- target at all) or does it come from syntax referring to a package name --- or location. --- -data TargetImplicitCwd = TargetImplicitCwd | TargetExplicitNamed - deriving (Eq, Ord, Show, Generic) - -data ComponentKind = LibKind | FLibKind | ExeKind | TestKind | BenchKind - deriving (Eq, Ord, Enum, Show) - -type ComponentKindFilter = ComponentKind - --- | Either the component as a whole or detail about a file or module target --- within a component. --- -data SubComponentTarget = - - -- | The component as a whole - WholeComponent - - -- | A specific module within a component. - | ModuleTarget ModuleName - - -- | A specific file within a component. Note that this does not carry the - -- file extension. - | FileTarget FilePath - deriving (Eq, Ord, Show, Generic) - -instance Binary SubComponentTarget -instance Structured SubComponentTarget - - --- ------------------------------------------------------------ --- * Top level, do everything --- ------------------------------------------------------------ - - --- | Parse a bunch of command line args as 'TargetSelector's, failing with an --- error if any are unrecognised. The possible target selectors are based on --- the available packages (and their locations). --- -readTargetSelectors :: [PackageSpecifier (SourcePackage (PackageLocation a))] - -> Maybe ComponentKindFilter - -- ^ This parameter is used when there are ambiguous selectors. - -- If it is 'Just', then we attempt to resolve ambiguitiy - -- by applying it, since otherwise there is no way to allow - -- contextually valid yet syntactically ambiguous selectors. - -- (#4676, #5461) - -> [String] - -> IO (Either [TargetSelectorProblem] [TargetSelector]) -readTargetSelectors = readTargetSelectorsWith defaultDirActions - -readTargetSelectorsWith :: (Applicative m, Monad m) => DirActions m - -> [PackageSpecifier (SourcePackage (PackageLocation a))] - -> Maybe ComponentKindFilter - -> [String] - -> m (Either [TargetSelectorProblem] [TargetSelector]) -readTargetSelectorsWith dirActions@DirActions{} pkgs mfilter targetStrs = - case parseTargetStrings targetStrs of - ([], usertargets) -> do - usertargets' <- traverse (getTargetStringFileStatus dirActions) usertargets - knowntargets <- getKnownTargets dirActions pkgs - case resolveTargetSelectors knowntargets usertargets' mfilter of - ([], btargets) -> return (Right btargets) - (problems, _) -> return (Left problems) - (strs, _) -> return (Left (map TargetSelectorUnrecognised strs)) - - -data DirActions m = DirActions { - doesFileExist :: FilePath -> m Bool, - doesDirectoryExist :: FilePath -> m Bool, - canonicalizePath :: FilePath -> m FilePath, - getCurrentDirectory :: m FilePath - } - -defaultDirActions :: DirActions IO -defaultDirActions = - DirActions { - doesFileExist = IO.doesFileExist, - doesDirectoryExist = IO.doesDirectoryExist, - -- Workaround for - canonicalizePath = IO.canonicalizePath . dropTrailingPathSeparator, - getCurrentDirectory = IO.getCurrentDirectory - } - -makeRelativeToCwd :: Applicative m => DirActions m -> FilePath -> m FilePath -makeRelativeToCwd DirActions{..} path = - makeRelativeCanonical <$> canonicalizePath path <*> getCurrentDirectory - - --- ------------------------------------------------------------ --- * Parsing target strings --- ------------------------------------------------------------ - --- | The outline parse of a target selector. It takes one of the forms: --- --- > str1 --- > str1:str2 --- > str1:str2:str3 --- > str1:str2:str3:str4 --- -data TargetString = - TargetString1 String - | TargetString2 String String - | TargetString3 String String String - | TargetString4 String String String String - | TargetString5 String String String String String - | TargetString7 String String String String String String String - deriving (Show, Eq) - --- | Parse a bunch of 'TargetString's (purely without throwing exceptions). --- -parseTargetStrings :: [String] -> ([String], [TargetString]) -parseTargetStrings = - partitionEithers - . map (\str -> maybe (Left str) Right (parseTargetString str)) - -parseTargetString :: String -> Maybe TargetString -parseTargetString = - readPToMaybe parseTargetApprox - where - parseTargetApprox :: Parse.ReadP r TargetString - parseTargetApprox = - (do a <- tokenQ - return (TargetString1 a)) - +++ (do a <- tokenQ0 - _ <- Parse.char ':' - b <- tokenQ - return (TargetString2 a b)) - +++ (do a <- tokenQ0 - _ <- Parse.char ':' - b <- tokenQ - _ <- Parse.char ':' - c <- tokenQ - return (TargetString3 a b c)) - +++ (do a <- tokenQ0 - _ <- Parse.char ':' - b <- token - _ <- Parse.char ':' - c <- tokenQ - _ <- Parse.char ':' - d <- tokenQ - return (TargetString4 a b c d)) - +++ (do a <- tokenQ0 - _ <- Parse.char ':' - b <- token - _ <- Parse.char ':' - c <- tokenQ - _ <- Parse.char ':' - d <- tokenQ - _ <- Parse.char ':' - e <- tokenQ - return (TargetString5 a b c d e)) - +++ (do a <- tokenQ0 - _ <- Parse.char ':' - b <- token - _ <- Parse.char ':' - c <- tokenQ - _ <- Parse.char ':' - d <- tokenQ - _ <- Parse.char ':' - e <- tokenQ - _ <- Parse.char ':' - f <- tokenQ - _ <- Parse.char ':' - g <- tokenQ - return (TargetString7 a b c d e f g)) - - token = Parse.munch1 (\x -> not (isSpace x) && x /= ':') - tokenQ = parseHaskellString <++ token - token0 = Parse.munch (\x -> not (isSpace x) && x /= ':') - tokenQ0= parseHaskellString <++ token0 - parseHaskellString :: Parse.ReadP r String - parseHaskellString = Parse.readS_to_P reads - - --- | Render a 'TargetString' back as the external syntax. This is mainly for --- error messages. --- -showTargetString :: TargetString -> String -showTargetString = intercalate ":" . components - where - components (TargetString1 s1) = [s1] - components (TargetString2 s1 s2) = [s1,s2] - components (TargetString3 s1 s2 s3) = [s1,s2,s3] - components (TargetString4 s1 s2 s3 s4) = [s1,s2,s3,s4] - components (TargetString5 s1 s2 s3 s4 s5) = [s1,s2,s3,s4,s5] - components (TargetString7 s1 s2 s3 s4 s5 s6 s7) = [s1,s2,s3,s4,s5,s6,s7] - -showTargetSelector :: TargetSelector -> String -showTargetSelector ts = - case [ t | ql <- [QL1 .. QLFull] - , t <- renderTargetSelector ql ts ] - of (t':_) -> showTargetString (forgetFileStatus t') - [] -> "" - -showTargetSelectorKind :: TargetSelector -> String -showTargetSelectorKind bt = case bt of - TargetPackage TargetExplicitNamed _ Nothing -> "package" - TargetPackage TargetExplicitNamed _ (Just _) -> "package:filter" - TargetPackage TargetImplicitCwd _ Nothing -> "cwd-package" - TargetPackage TargetImplicitCwd _ (Just _) -> "cwd-package:filter" - TargetPackageNamed _ Nothing -> "named-package" - TargetPackageNamed _ (Just _) -> "named-package:filter" - TargetAllPackages Nothing -> "package *" - TargetAllPackages (Just _) -> "package *:filter" - TargetComponent _ _ WholeComponent -> "component" - TargetComponent _ _ ModuleTarget{} -> "module" - TargetComponent _ _ FileTarget{} -> "file" - TargetComponentUnknown _ _ WholeComponent -> "unknown-component" - TargetComponentUnknown _ _ ModuleTarget{} -> "unknown-module" - TargetComponentUnknown _ _ FileTarget{} -> "unknown-file" - - --- ------------------------------------------------------------ --- * Checking if targets exist as files --- ------------------------------------------------------------ - -data TargetStringFileStatus = - TargetStringFileStatus1 String FileStatus - | TargetStringFileStatus2 String FileStatus String - | TargetStringFileStatus3 String FileStatus String String - | TargetStringFileStatus4 String String String String - | TargetStringFileStatus5 String String String String String - | TargetStringFileStatus7 String String String String String String String - deriving (Eq, Ord, Show) - -data FileStatus = FileStatusExistsFile FilePath -- the canonicalised filepath - | FileStatusExistsDir FilePath -- the canonicalised filepath - | FileStatusNotExists Bool -- does the parent dir exist even? - deriving (Eq, Ord, Show) - -noFileStatus :: FileStatus -noFileStatus = FileStatusNotExists False - -getTargetStringFileStatus :: (Applicative m, Monad m) => DirActions m - -> TargetString -> m TargetStringFileStatus -getTargetStringFileStatus DirActions{..} t = - case t of - TargetString1 s1 -> - (\f1 -> TargetStringFileStatus1 s1 f1) <$> fileStatus s1 - TargetString2 s1 s2 -> - (\f1 -> TargetStringFileStatus2 s1 f1 s2) <$> fileStatus s1 - TargetString3 s1 s2 s3 -> - (\f1 -> TargetStringFileStatus3 s1 f1 s2 s3) <$> fileStatus s1 - TargetString4 s1 s2 s3 s4 -> - return (TargetStringFileStatus4 s1 s2 s3 s4) - TargetString5 s1 s2 s3 s4 s5 -> - return (TargetStringFileStatus5 s1 s2 s3 s4 s5) - TargetString7 s1 s2 s3 s4 s5 s6 s7 -> - return (TargetStringFileStatus7 s1 s2 s3 s4 s5 s6 s7) - where - fileStatus f = do - fexists <- doesFileExist f - dexists <- doesDirectoryExist f - case splitPath f of - _ | fexists -> FileStatusExistsFile <$> canonicalizePath f - | dexists -> FileStatusExistsDir <$> canonicalizePath f - (d:_) -> FileStatusNotExists <$> doesDirectoryExist d - _ -> pure (FileStatusNotExists False) - -forgetFileStatus :: TargetStringFileStatus -> TargetString -forgetFileStatus t = case t of - TargetStringFileStatus1 s1 _ -> TargetString1 s1 - TargetStringFileStatus2 s1 _ s2 -> TargetString2 s1 s2 - TargetStringFileStatus3 s1 _ s2 s3 -> TargetString3 s1 s2 s3 - TargetStringFileStatus4 s1 s2 s3 s4 -> TargetString4 s1 s2 s3 s4 - TargetStringFileStatus5 s1 s2 s3 s4 - s5 -> TargetString5 s1 s2 s3 s4 s5 - TargetStringFileStatus7 s1 s2 s3 s4 - s5 s6 s7 -> TargetString7 s1 s2 s3 s4 s5 s6 s7 - -getFileStatus :: TargetStringFileStatus -> Maybe FileStatus -getFileStatus (TargetStringFileStatus1 _ f) = Just f -getFileStatus (TargetStringFileStatus2 _ f _) = Just f -getFileStatus (TargetStringFileStatus3 _ f _ _) = Just f -getFileStatus _ = Nothing - -setFileStatus :: FileStatus -> TargetStringFileStatus -> TargetStringFileStatus -setFileStatus f (TargetStringFileStatus1 s1 _) = TargetStringFileStatus1 s1 f -setFileStatus f (TargetStringFileStatus2 s1 _ s2) = TargetStringFileStatus2 s1 f s2 -setFileStatus f (TargetStringFileStatus3 s1 _ s2 s3) = TargetStringFileStatus3 s1 f s2 s3 -setFileStatus _ t = t - -copyFileStatus :: TargetStringFileStatus -> TargetStringFileStatus -> TargetStringFileStatus -copyFileStatus src dst = - case getFileStatus src of - Just f -> setFileStatus f dst - Nothing -> dst - --- ------------------------------------------------------------ --- * Resolving target strings to target selectors --- ------------------------------------------------------------ - - --- | Given a bunch of user-specified targets, try to resolve what it is they --- refer to. --- -resolveTargetSelectors :: KnownTargets - -> [TargetStringFileStatus] - -> Maybe ComponentKindFilter - -> ([TargetSelectorProblem], - [TargetSelector]) --- default local dir target if there's no given target: -resolveTargetSelectors (KnownTargets{knownPackagesAll = []}) [] _ = - ([TargetSelectorNoTargetsInProject], []) - -resolveTargetSelectors (KnownTargets{knownPackagesPrimary = []}) [] _ = - ([TargetSelectorNoTargetsInCwd], []) - -resolveTargetSelectors (KnownTargets{knownPackagesPrimary}) [] _ = - ([], [TargetPackage TargetImplicitCwd pkgids Nothing]) - where - pkgids = [ pinfoId | KnownPackage{pinfoId} <- knownPackagesPrimary ] - -resolveTargetSelectors knowntargets targetStrs mfilter = - partitionEithers - . map (resolveTargetSelector knowntargets mfilter) - $ targetStrs - -resolveTargetSelector :: KnownTargets - -> Maybe ComponentKindFilter - -> TargetStringFileStatus - -> Either TargetSelectorProblem TargetSelector -resolveTargetSelector knowntargets@KnownTargets{..} mfilter targetStrStatus = - case findMatch (matcher targetStrStatus) of - - Unambiguous _ - | projectIsEmpty -> Left TargetSelectorNoTargetsInProject - - Unambiguous (TargetPackage TargetImplicitCwd [] _) - -> Left (TargetSelectorNoCurrentPackage targetStr) - - Unambiguous target -> Right target - - None errs - | projectIsEmpty -> Left TargetSelectorNoTargetsInProject - | otherwise -> Left (classifyMatchErrors errs) - - Ambiguous _ targets - | Just kfilter <- mfilter - , [target] <- applyKindFilter kfilter targets -> Right target - - Ambiguous exactMatch targets -> - case disambiguateTargetSelectors - matcher targetStrStatus exactMatch - targets of - Right targets' -> Left (TargetSelectorAmbiguous targetStr targets') - Left ((m, ms):_) -> Left (MatchingInternalError targetStr m ms) - Left [] -> internalError "resolveTargetSelector" - where - matcher = matchTargetSelector knowntargets - - targetStr = forgetFileStatus targetStrStatus - - projectIsEmpty = null knownPackagesAll - - classifyMatchErrors errs - | Just expectedNE <- NE.nonEmpty expected - = let (things, got:|_) = NE.unzip expectedNE in - TargetSelectorExpected targetStr (NE.toList things) got - - | not (null nosuch) - = TargetSelectorNoSuch targetStr nosuch - - | otherwise - = internalError $ "classifyMatchErrors: " ++ show errs - where - expected = [ (thing, got) - | (_, MatchErrorExpected thing got) - <- map (innerErr Nothing) errs ] - -- Trim the list of alternatives by dropping duplicates and - -- retaining only at most three most similar (by edit distance) ones. - nosuch = Map.foldrWithKey genResults [] $ Map.fromListWith Set.union $ - [ ((inside, thing, got), Set.fromList alts) - | (inside, MatchErrorNoSuch thing got alts) - <- map (innerErr Nothing) errs - ] - - genResults (inside, thing, got) alts acc = ( - inside - , thing - , got - , take maxResults - $ map fst - $ takeWhile distanceLow - $ sortBy (comparing snd) - $ map addLevDist - $ Set.toList alts - ) : acc - where - addLevDist = id &&& restrictedDamerauLevenshteinDistance - defaultEditCosts got - - distanceLow (_, dist) = dist < length got `div` 2 - - maxResults = 3 - - innerErr _ (MatchErrorIn kind thing m) - = innerErr (Just (kind,thing)) m - innerErr c m = (c,m) - - applyKindFilter :: ComponentKindFilter -> [TargetSelector] -> [TargetSelector] - applyKindFilter kfilter = filter go - where - go (TargetPackage _ _ (Just filter')) = kfilter == filter' - go (TargetPackageNamed _ (Just filter')) = kfilter == filter' - go (TargetAllPackages (Just filter')) = kfilter == filter' - go (TargetComponent _ cname _) - | CLibName _ <- cname = kfilter == LibKind - | CFLibName _ <- cname = kfilter == FLibKind - | CExeName _ <- cname = kfilter == ExeKind - | CTestName _ <- cname = kfilter == TestKind - | CBenchName _ <- cname = kfilter == BenchKind - go _ = True - --- | The various ways that trying to resolve a 'TargetString' to a --- 'TargetSelector' can fail. --- -data TargetSelectorProblem - = TargetSelectorExpected TargetString [String] String - -- ^ [expected thing] (actually got) - | TargetSelectorNoSuch TargetString - [(Maybe (String, String), String, String, [String])] - -- ^ [([in thing], no such thing, actually got, alternatives)] - | TargetSelectorAmbiguous TargetString - [(TargetString, TargetSelector)] - - | MatchingInternalError TargetString TargetSelector - [(TargetString, [TargetSelector])] - | TargetSelectorUnrecognised String - -- ^ Syntax error when trying to parse a target string. - | TargetSelectorNoCurrentPackage TargetString - | TargetSelectorNoTargetsInCwd - | TargetSelectorNoTargetsInProject - deriving (Show, Eq) - --- | Qualification levels. --- Given the filepath src/F, executable component A, and package foo: -data QualLevel = QL1 -- ^ @src/F@ - | QL2 -- ^ @foo:src/F | A:src/F@ - | QL3 -- ^ @foo:A:src/F | exe:A:src/F@ - | QLFull -- ^ @pkg:foo:exe:A:file:src/F@ - deriving (Eq, Enum, Show) - -disambiguateTargetSelectors - :: (TargetStringFileStatus -> Match TargetSelector) - -> TargetStringFileStatus -> MatchClass - -> [TargetSelector] - -> Either [(TargetSelector, [(TargetString, [TargetSelector])])] - [(TargetString, TargetSelector)] -disambiguateTargetSelectors matcher matchInput exactMatch matchResults = - case partitionEithers results of - (errs@(_:_), _) -> Left errs - ([], ok) -> Right ok - where - -- So, here's the strategy. We take the original match results, and make a - -- table of all their renderings at all qualification levels. - -- Note there can be multiple renderings at each qualification level. - - -- Note that renderTargetSelector won't immediately work on any file syntax - -- When rendering syntax, the FileStatus is always FileStatusNotExists, - -- which will never match on syntaxForm1File! - -- Because matchPackageDirectoryPrefix expects a FileStatusExistsFile. - -- So we need to copy over the file status from the input - -- TargetStringFileStatus, onto the new rendered TargetStringFileStatus - matchResultsRenderings :: [(TargetSelector, [TargetStringFileStatus])] - matchResultsRenderings = - [ (matchResult, matchRenderings) - | matchResult <- matchResults - , let matchRenderings = - [ copyFileStatus matchInput rendering - | ql <- [QL1 .. QLFull] - , rendering <- renderTargetSelector ql matchResult ] - ] - - -- Of course the point is that we're looking for renderings that are - -- unambiguous matches. So we build another memo table of all the matches - -- for all of those renderings. So by looking up in this table we can see - -- if we've got an unambiguous match. - - memoisedMatches :: Map TargetStringFileStatus (Match TargetSelector) - memoisedMatches = - -- avoid recomputing the main one if it was an exact match - (if exactMatch == Exact - then Map.insert matchInput (Match Exact 0 matchResults) - else id) - $ Map.Lazy.fromList - -- (matcher rendering) should *always* be a Match! Otherwise we will hit - -- the internal error later on. - [ (rendering, matcher rendering) - | rendering <- concatMap snd matchResultsRenderings ] - - -- Finally, for each of the match results, we go through all their - -- possible renderings (in order of qualification level, though remember - -- there can be multiple renderings per level), and find the first one - -- that has an unambiguous match. - results :: [Either (TargetSelector, [(TargetString, [TargetSelector])]) - (TargetString, TargetSelector)] - results = - [ case findUnambiguous originalMatch matchRenderings of - Just unambiguousRendering -> - Right ( forgetFileStatus unambiguousRendering - , originalMatch) - - -- This case is an internal error, but we bubble it up and report it - Nothing -> - Left ( originalMatch - , [ (forgetFileStatus rendering, matches) - | rendering <- matchRenderings - , let Match m _ matches = - memoisedMatches Map.! rendering - , m /= Inexact - ] ) - - | (originalMatch, matchRenderings) <- matchResultsRenderings ] - - findUnambiguous :: TargetSelector - -> [TargetStringFileStatus] - -> Maybe TargetStringFileStatus - findUnambiguous _ [] = Nothing - findUnambiguous t (r:rs) = - case memoisedMatches Map.! r of - Match Exact _ [t'] | t == t' - -> Just r - Match Exact _ _ -> findUnambiguous t rs - Match Unknown _ _ -> findUnambiguous t rs - Match Inexact _ _ -> internalError "Match Inexact" - NoMatch _ _ -> internalError "NoMatch" - -internalError :: String -> a -internalError msg = - error $ "TargetSelector: internal error: " ++ msg - - --- | Throw an exception with a formatted message if there are any problems. --- -reportTargetSelectorProblems :: Verbosity -> [TargetSelectorProblem] -> IO a -reportTargetSelectorProblems verbosity problems = do - - case [ str | TargetSelectorUnrecognised str <- problems ] of - [] -> return () - targets -> - die' verbosity $ unlines - [ "Unrecognised target syntax for '" ++ name ++ "'." - | name <- targets ] - - case [ (t, m, ms) | MatchingInternalError t m ms <- problems ] of - [] -> return () - ((target, originalMatch, renderingsAndMatches):_) -> - die' verbosity $ "Internal error in target matching. It should always " - ++ "be possible to find a syntax that's sufficiently qualified to " - ++ "give an unambiguous match. However when matching '" - ++ showTargetString target ++ "' we found " - ++ showTargetSelector originalMatch - ++ " (" ++ showTargetSelectorKind originalMatch ++ ") which does " - ++ "not have an unambiguous syntax. The possible syntax and the " - ++ "targets they match are as follows:\n" - ++ unlines - [ "'" ++ showTargetString rendering ++ "' which matches " - ++ intercalate ", " - [ showTargetSelector match ++ - " (" ++ showTargetSelectorKind match ++ ")" - | match <- matches ] - | (rendering, matches) <- renderingsAndMatches ] - - case [ (t, e, g) | TargetSelectorExpected t e g <- problems ] of - [] -> return () - targets -> - die' verbosity $ unlines - [ "Unrecognised target '" ++ showTargetString target - ++ "'.\n" - ++ "Expected a " ++ intercalate " or " expected - ++ ", rather than '" ++ got ++ "'." - | (target, expected, got) <- targets ] - - case [ (t, e) | TargetSelectorNoSuch t e <- problems ] of - [] -> return () - targets -> - die' verbosity $ unlines - [ "Unknown target '" ++ showTargetString target ++ - "'.\n" ++ unlines - [ (case inside of - Just (kind, "") - -> "The " ++ kind ++ " has no " - Just (kind, thing) - -> "The " ++ kind ++ " " ++ thing ++ " has no " - Nothing -> "There is no ") - ++ intercalate " or " [ mungeThing thing ++ " '" ++ got ++ "'" - | (thing, got, _alts) <- nosuch' ] ++ "." - ++ if null alternatives then "" else - "\nPerhaps you meant " ++ intercalate ";\nor " - [ "the " ++ thing ++ " '" ++ intercalate "' or '" alts ++ "'?" - | (thing, alts) <- alternatives ] - | (inside, nosuch') <- groupByContainer nosuch - , let alternatives = - [ (thing, alts) - | (thing,_got,alts@(_:_)) <- nosuch' ] - ] - | (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 - - case [ (t, ts) | TargetSelectorAmbiguous t ts <- problems ] of - [] -> return () - targets -> - die' verbosity $ unlines - [ "Ambiguous target '" ++ showTargetString target - ++ "'. It could be:\n " - ++ unlines [ " "++ showTargetString ut ++ - " (" ++ showTargetSelectorKind bt ++ ")" - | (ut, bt) <- amb ] - | (target, amb) <- targets ] - - case [ t | TargetSelectorNoCurrentPackage t <- problems ] of - [] -> return () - target:_ -> - die' verbosity $ - "The target '" ++ showTargetString target ++ "' refers to the " - ++ "components in the package in the current directory, but there " - ++ "is no package in the current directory (or at least not listed " - ++ "as part of the project)." - --TODO: report a different error if there is a .cabal file but it's - -- not a member of the project - - case [ () | TargetSelectorNoTargetsInCwd <- problems ] of - [] -> return () - _:_ -> - die' verbosity $ - "No targets given and there is no package in the current " - ++ "directory. Use the target 'all' for all packages in the " - ++ "project or specify packages or components by name or location. " - ++ "See 'cabal build --help' for more details on target options." - - case [ () | TargetSelectorNoTargetsInProject <- problems ] of - [] -> return () - _:_ -> - die' verbosity $ - "There is no .cabal package file or cabal.project file. " - ++ "To build packages locally you need at minimum a .cabal " - ++ "file. You can use 'cabal init' to create one.\n" - ++ "\n" - ++ "For non-trivial projects you will also want a cabal.project " - ++ "file in the root directory of your project. This file lists the " - ++ "packages in your project and all other build configuration. " - ++ "See the Cabal user guide for full details." - - fail "reportTargetSelectorProblems: internal error" - - ----------------------------------- --- Syntax type --- - --- | Syntax for the 'TargetSelector': the matcher and renderer --- -data Syntax = Syntax QualLevel Matcher Renderer - | AmbiguousAlternatives Syntax Syntax - | ShadowingAlternatives Syntax Syntax - -type Matcher = TargetStringFileStatus -> Match TargetSelector -type Renderer = TargetSelector -> [TargetStringFileStatus] - -foldSyntax :: (a -> a -> a) -> (a -> a -> a) - -> (QualLevel -> Matcher -> Renderer -> a) - -> (Syntax -> a) -foldSyntax ambiguous unambiguous syntax = go - where - go (Syntax ql match render) = syntax ql match render - go (AmbiguousAlternatives a b) = ambiguous (go a) (go b) - go (ShadowingAlternatives a b) = unambiguous (go a) (go b) - - ----------------------------------- --- Top level renderer and matcher --- - -renderTargetSelector :: QualLevel -> TargetSelector - -> [TargetStringFileStatus] -renderTargetSelector ql ts = - foldSyntax - (++) (++) - (\ql' _ render -> guard (ql == ql') >> render ts) - syntax - where - syntax = syntaxForms emptyKnownTargets - -- don't need known targets for rendering - -matchTargetSelector :: KnownTargets - -> TargetStringFileStatus - -> Match TargetSelector -matchTargetSelector knowntargets = \usertarget -> - nubMatchesBy (==) $ - - let ql = targetQualLevel usertarget in - foldSyntax - (<|>) () - (\ql' match _ -> guard (ql == ql') >> match usertarget) - syntax - where - syntax = syntaxForms knowntargets - - targetQualLevel TargetStringFileStatus1{} = QL1 - targetQualLevel TargetStringFileStatus2{} = QL2 - targetQualLevel TargetStringFileStatus3{} = QL3 - targetQualLevel TargetStringFileStatus4{} = QLFull - targetQualLevel TargetStringFileStatus5{} = QLFull - targetQualLevel TargetStringFileStatus7{} = QLFull - - ----------------------------------- --- Syntax forms --- - --- | All the forms of syntax for 'TargetSelector'. --- -syntaxForms :: KnownTargets -> Syntax -syntaxForms KnownTargets { - knownPackagesAll = pinfo, - knownPackagesPrimary = ppinfo, - knownComponentsAll = cinfo, - knownComponentsPrimary = pcinfo, - knownComponentsOther = ocinfo - } = - -- The various forms of syntax here are ambiguous in many cases. - -- Our policy is by default we expose that ambiguity and report - -- ambiguous matches. In certain cases we override the ambiguity - -- by having some forms shadow others. - -- - -- We make modules shadow files because module name "Q" clashes - -- with file "Q" with no extension but these refer to the same - -- thing anyway so it's not a useful ambiguity. Other cases are - -- not ambiguous like "Q" vs "Q.hs" or "Data.Q" vs "Data/Q". - - ambiguousAlternatives - -- convenient single-component forms - [ shadowingAlternatives - [ ambiguousAlternatives - [ syntaxForm1All - , syntaxForm1Filter ppinfo - , shadowingAlternatives - [ syntaxForm1Component pcinfo - , syntaxForm1Package pinfo - ] - ] - , syntaxForm1Component ocinfo - , syntaxForm1Module cinfo - , syntaxForm1File pinfo - ] - - -- two-component partially qualified forms - -- fully qualified form for 'all' - , syntaxForm2MetaAll - , syntaxForm2AllFilter - , syntaxForm2NamespacePackage pinfo - , syntaxForm2PackageComponent pinfo - , syntaxForm2PackageFilter pinfo - , syntaxForm2KindComponent cinfo - , shadowingAlternatives - [ syntaxForm2PackageModule pinfo - , syntaxForm2PackageFile pinfo - ] - , shadowingAlternatives - [ syntaxForm2ComponentModule cinfo - , syntaxForm2ComponentFile cinfo - ] - - -- rarely used partially qualified forms - , syntaxForm3PackageKindComponent pinfo - , shadowingAlternatives - [ syntaxForm3PackageComponentModule pinfo - , syntaxForm3PackageComponentFile pinfo - ] - , shadowingAlternatives - [ syntaxForm3KindComponentModule cinfo - , syntaxForm3KindComponentFile cinfo - ] - , syntaxForm3NamespacePackageFilter pinfo - - -- fully-qualified forms for all and cwd with filter - , syntaxForm3MetaAllFilter - , syntaxForm3MetaCwdFilter ppinfo - - -- fully-qualified form for package and package with filter - , syntaxForm3MetaNamespacePackage pinfo - , syntaxForm4MetaNamespacePackageFilter pinfo - - -- fully-qualified forms for component, module and file - , syntaxForm5MetaNamespacePackageKindComponent pinfo - , syntaxForm7MetaNamespacePackageKindComponentNamespaceModule pinfo - , syntaxForm7MetaNamespacePackageKindComponentNamespaceFile pinfo - ] - where - ambiguousAlternatives = Prelude.foldr1 AmbiguousAlternatives - shadowingAlternatives = Prelude.foldr1 ShadowingAlternatives - - --- | Syntax: "all" to select all packages in the project --- --- > cabal build all --- -syntaxForm1All :: Syntax -syntaxForm1All = - syntaxForm1 render $ \str1 _fstatus1 -> do - guardMetaAll str1 - return (TargetAllPackages Nothing) - where - render (TargetAllPackages Nothing) = - [TargetStringFileStatus1 "all" noFileStatus] - render _ = [] - --- | Syntax: filter --- --- > cabal build tests --- -syntaxForm1Filter :: [KnownPackage] -> Syntax -syntaxForm1Filter ps = - syntaxForm1 render $ \str1 _fstatus1 -> do - kfilter <- matchComponentKindFilter str1 - return (TargetPackage TargetImplicitCwd pids (Just kfilter)) - where - pids = [ pinfoId | KnownPackage{pinfoId} <- ps ] - render (TargetPackage TargetImplicitCwd _ (Just kfilter)) = - [TargetStringFileStatus1 (dispF kfilter) noFileStatus] - render _ = [] - - --- | Syntax: package (name, dir or file) --- --- > cabal build foo --- > cabal build ../bar ../bar/bar.cabal --- -syntaxForm1Package :: [KnownPackage] -> Syntax -syntaxForm1Package pinfo = - syntaxForm1 render $ \str1 fstatus1 -> do - guardPackage str1 fstatus1 - p <- matchPackage pinfo str1 fstatus1 - case p of - KnownPackage{pinfoId} -> - return (TargetPackage TargetExplicitNamed [pinfoId] Nothing) - KnownPackageName pn -> - return (TargetPackageNamed pn Nothing) - where - render (TargetPackage TargetExplicitNamed [p] Nothing) = - [TargetStringFileStatus1 (dispP p) noFileStatus] - render (TargetPackageNamed pn Nothing) = - [TargetStringFileStatus1 (dispPN pn) noFileStatus] - render _ = [] - --- | Syntax: component --- --- > cabal build foo --- -syntaxForm1Component :: [KnownComponent] -> Syntax -syntaxForm1Component cs = - syntaxForm1 render $ \str1 _fstatus1 -> do - guardComponentName str1 - c <- matchComponentName cs str1 - return (TargetComponent (cinfoPackageId c) (cinfoName c) WholeComponent) - where - render (TargetComponent p c WholeComponent) = - [TargetStringFileStatus1 (dispC p c) noFileStatus] - render _ = [] - --- | Syntax: module --- --- > cabal build Data.Foo --- -syntaxForm1Module :: [KnownComponent] -> Syntax -syntaxForm1Module cs = - syntaxForm1 render $ \str1 _fstatus1 -> do - guardModuleName str1 - let ms = [ (m,c) | c <- cs, m <- cinfoModules c ] - (m,c) <- matchModuleNameAnd ms str1 - return (TargetComponent (cinfoPackageId c) (cinfoName c) (ModuleTarget m)) - where - render (TargetComponent _p _c (ModuleTarget m)) = - [TargetStringFileStatus1 (dispM m) noFileStatus] - render _ = [] - --- | Syntax: file name --- --- > cabal build Data/Foo.hs bar/Main.hsc --- -syntaxForm1File :: [KnownPackage] -> Syntax -syntaxForm1File ps = - -- Note there's a bit of an inconsistency here vs the other syntax forms - -- for files. For the single-part syntax the target has to point to a file - -- that exists (due to our use of matchPackageDirectoryPrefix), whereas for - -- all the other forms we don't require that. - syntaxForm1 render $ \str1 fstatus1 -> - expecting "file" str1 $ do - (pkgfile, ~KnownPackage{pinfoId, pinfoComponents}) - -- always returns the KnownPackage case - <- matchPackageDirectoryPrefix ps fstatus1 - orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do - (filepath, c) <- matchComponentFile pinfoComponents pkgfile - return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath)) - where - render (TargetComponent _p _c (FileTarget f)) = - [TargetStringFileStatus1 f noFileStatus] - render _ = [] - ---- - --- | Syntax: :all --- --- > cabal build :all --- -syntaxForm2MetaAll :: Syntax -syntaxForm2MetaAll = - syntaxForm2 render $ \str1 _fstatus1 str2 -> do - guardNamespaceMeta str1 - guardMetaAll str2 - return (TargetAllPackages Nothing) - where - render (TargetAllPackages Nothing) = - [TargetStringFileStatus2 "" noFileStatus "all"] - render _ = [] - --- | Syntax: all : filer --- --- > cabal build all:tests --- -syntaxForm2AllFilter :: Syntax -syntaxForm2AllFilter = - syntaxForm2 render $ \str1 _fstatus1 str2 -> do - guardMetaAll str1 - kfilter <- matchComponentKindFilter str2 - return (TargetAllPackages (Just kfilter)) - where - render (TargetAllPackages (Just kfilter)) = - [TargetStringFileStatus2 "all" noFileStatus (dispF kfilter)] - render _ = [] - --- | Syntax: package : filer --- --- > cabal build foo:tests --- -syntaxForm2PackageFilter :: [KnownPackage] -> Syntax -syntaxForm2PackageFilter ps = - syntaxForm2 render $ \str1 fstatus1 str2 -> do - guardPackage str1 fstatus1 - p <- matchPackage ps str1 fstatus1 - kfilter <- matchComponentKindFilter str2 - case p of - KnownPackage{pinfoId} -> - return (TargetPackage TargetExplicitNamed [pinfoId] (Just kfilter)) - KnownPackageName pn -> - return (TargetPackageNamed pn (Just kfilter)) - where - render (TargetPackage TargetExplicitNamed [p] (Just kfilter)) = - [TargetStringFileStatus2 (dispP p) noFileStatus (dispF kfilter)] - render (TargetPackageNamed pn (Just kfilter)) = - [TargetStringFileStatus2 (dispPN pn) noFileStatus (dispF kfilter)] - render _ = [] - --- | Syntax: pkg : package name --- --- > cabal build pkg:foo --- -syntaxForm2NamespacePackage :: [KnownPackage] -> Syntax -syntaxForm2NamespacePackage pinfo = - syntaxForm2 render $ \str1 _fstatus1 str2 -> do - guardNamespacePackage str1 - guardPackageName str2 - p <- matchPackage pinfo str2 noFileStatus - case p of - KnownPackage{pinfoId} -> - return (TargetPackage TargetExplicitNamed [pinfoId] Nothing) - KnownPackageName pn -> - return (TargetPackageNamed pn Nothing) - where - render (TargetPackage TargetExplicitNamed [p] Nothing) = - [TargetStringFileStatus2 "pkg" noFileStatus (dispP p)] - render (TargetPackageNamed pn Nothing) = - [TargetStringFileStatus2 "pkg" noFileStatus (dispPN pn)] - render _ = [] - --- | Syntax: package : component --- --- > cabal build foo:foo --- > cabal build ./foo:foo --- > cabal build ./foo.cabal:foo --- -syntaxForm2PackageComponent :: [KnownPackage] -> Syntax -syntaxForm2PackageComponent ps = - syntaxForm2 render $ \str1 fstatus1 str2 -> do - guardPackage str1 fstatus1 - guardComponentName str2 - p <- matchPackage ps str1 fstatus1 - case p of - KnownPackage{pinfoId, pinfoComponents} -> - orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do - c <- matchComponentName pinfoComponents str2 - return (TargetComponent pinfoId (cinfoName c) WholeComponent) - --TODO: the error here ought to say there's no component by that name in - -- this package, and name the package - KnownPackageName pn -> - let cn = mkUnqualComponentName str2 in - return (TargetComponentUnknown pn (Left cn) WholeComponent) - where - render (TargetComponent p c WholeComponent) = - [TargetStringFileStatus2 (dispP p) noFileStatus (dispC p c)] - render (TargetComponentUnknown pn (Left cn) WholeComponent) = - [TargetStringFileStatus2 (dispPN pn) noFileStatus (prettyShow cn)] - render _ = [] - --- | Syntax: namespace : component --- --- > cabal build lib:foo exe:foo --- -syntaxForm2KindComponent :: [KnownComponent] -> Syntax -syntaxForm2KindComponent cs = - syntaxForm2 render $ \str1 _fstatus1 str2 -> do - ckind <- matchComponentKind str1 - guardComponentName str2 - c <- matchComponentKindAndName cs ckind str2 - return (TargetComponent (cinfoPackageId c) (cinfoName c) WholeComponent) - where - render (TargetComponent p c WholeComponent) = - [TargetStringFileStatus2 (dispCK c) noFileStatus (dispC p c)] - render _ = [] - --- | Syntax: package : module --- --- > cabal build foo:Data.Foo --- > cabal build ./foo:Data.Foo --- > cabal build ./foo.cabal:Data.Foo --- -syntaxForm2PackageModule :: [KnownPackage] -> Syntax -syntaxForm2PackageModule ps = - syntaxForm2 render $ \str1 fstatus1 str2 -> do - guardPackage str1 fstatus1 - guardModuleName str2 - p <- matchPackage ps str1 fstatus1 - case p of - KnownPackage{pinfoId, pinfoComponents} -> - orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do - let ms = [ (m,c) | c <- pinfoComponents, m <- cinfoModules c ] - (m,c) <- matchModuleNameAnd ms str2 - return (TargetComponent pinfoId (cinfoName c) (ModuleTarget m)) - KnownPackageName pn -> do - m <- matchModuleNameUnknown str2 - -- We assume the primary library component of the package: - return (TargetComponentUnknown pn (Right $ CLibName LMainLibName) (ModuleTarget m)) - where - render (TargetComponent p _c (ModuleTarget m)) = - [TargetStringFileStatus2 (dispP p) noFileStatus (dispM m)] - render _ = [] - --- | Syntax: component : module --- --- > cabal build foo:Data.Foo --- -syntaxForm2ComponentModule :: [KnownComponent] -> Syntax -syntaxForm2ComponentModule cs = - syntaxForm2 render $ \str1 _fstatus1 str2 -> do - guardComponentName str1 - guardModuleName str2 - c <- matchComponentName cs str1 - orNoThingIn "component" (cinfoStrName c) $ do - let ms = cinfoModules c - m <- matchModuleName ms str2 - return (TargetComponent (cinfoPackageId c) (cinfoName c) - (ModuleTarget m)) - where - render (TargetComponent p c (ModuleTarget m)) = - [TargetStringFileStatus2 (dispC p c) noFileStatus (dispM m)] - render _ = [] - --- | Syntax: package : filename --- --- > cabal build foo:Data/Foo.hs --- > cabal build ./foo:Data/Foo.hs --- > cabal build ./foo.cabal:Data/Foo.hs --- -syntaxForm2PackageFile :: [KnownPackage] -> Syntax -syntaxForm2PackageFile ps = - syntaxForm2 render $ \str1 fstatus1 str2 -> do - guardPackage str1 fstatus1 - p <- matchPackage ps str1 fstatus1 - case p of - KnownPackage{pinfoId, pinfoComponents} -> - orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do - (filepath, c) <- matchComponentFile pinfoComponents str2 - return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath)) - KnownPackageName pn -> - let filepath = str2 in - -- We assume the primary library component of the package: - return (TargetComponentUnknown pn (Right $ CLibName LMainLibName) (FileTarget filepath)) - where - render (TargetComponent p _c (FileTarget f)) = - [TargetStringFileStatus2 (dispP p) noFileStatus f] - render _ = [] - --- | Syntax: component : filename --- --- > cabal build foo:Data/Foo.hs --- -syntaxForm2ComponentFile :: [KnownComponent] -> Syntax -syntaxForm2ComponentFile cs = - syntaxForm2 render $ \str1 _fstatus1 str2 -> do - guardComponentName str1 - c <- matchComponentName cs str1 - orNoThingIn "component" (cinfoStrName c) $ do - (filepath, _) <- matchComponentFile [c] str2 - return (TargetComponent (cinfoPackageId c) (cinfoName c) - (FileTarget filepath)) - where - render (TargetComponent p c (FileTarget f)) = - [TargetStringFileStatus2 (dispC p c) noFileStatus f] - render _ = [] - ---- - --- | Syntax: :all : filter --- --- > cabal build :all:tests --- -syntaxForm3MetaAllFilter :: Syntax -syntaxForm3MetaAllFilter = - syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do - guardNamespaceMeta str1 - guardMetaAll str2 - kfilter <- matchComponentKindFilter str3 - return (TargetAllPackages (Just kfilter)) - where - render (TargetAllPackages (Just kfilter)) = - [TargetStringFileStatus3 "" noFileStatus "all" (dispF kfilter)] - render _ = [] - -syntaxForm3MetaCwdFilter :: [KnownPackage] -> Syntax -syntaxForm3MetaCwdFilter ps = - syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do - guardNamespaceMeta str1 - guardNamespaceCwd str2 - kfilter <- matchComponentKindFilter str3 - return (TargetPackage TargetImplicitCwd pids (Just kfilter)) - where - pids = [ pinfoId | KnownPackage{pinfoId} <- ps ] - render (TargetPackage TargetImplicitCwd _ (Just kfilter)) = - [TargetStringFileStatus3 "" noFileStatus "cwd" (dispF kfilter)] - render _ = [] - --- | Syntax: :pkg : package name --- --- > cabal build :pkg:foo --- -syntaxForm3MetaNamespacePackage :: [KnownPackage] -> Syntax -syntaxForm3MetaNamespacePackage pinfo = - syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do - guardNamespaceMeta str1 - guardNamespacePackage str2 - guardPackageName str3 - p <- matchPackage pinfo str3 noFileStatus - case p of - KnownPackage{pinfoId} -> - return (TargetPackage TargetExplicitNamed [pinfoId] Nothing) - KnownPackageName pn -> - return (TargetPackageNamed pn Nothing) - where - render (TargetPackage TargetExplicitNamed [p] Nothing) = - [TargetStringFileStatus3 "" noFileStatus "pkg" (dispP p)] - render (TargetPackageNamed pn Nothing) = - [TargetStringFileStatus3 "" noFileStatus "pkg" (dispPN pn)] - render _ = [] - --- | Syntax: package : namespace : component --- --- > cabal build foo:lib:foo --- > cabal build foo/:lib:foo --- > cabal build foo.cabal:lib:foo --- -syntaxForm3PackageKindComponent :: [KnownPackage] -> Syntax -syntaxForm3PackageKindComponent ps = - syntaxForm3 render $ \str1 fstatus1 str2 str3 -> do - guardPackage str1 fstatus1 - ckind <- matchComponentKind str2 - guardComponentName str3 - p <- matchPackage ps str1 fstatus1 - case p of - KnownPackage{pinfoId, pinfoComponents} -> - orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do - c <- matchComponentKindAndName pinfoComponents ckind str3 - return (TargetComponent pinfoId (cinfoName c) WholeComponent) - KnownPackageName pn -> - let cn = mkComponentName pn ckind (mkUnqualComponentName str3) in - return (TargetComponentUnknown pn (Right cn) WholeComponent) - where - render (TargetComponent p c WholeComponent) = - [TargetStringFileStatus3 (dispP p) noFileStatus (dispCK c) (dispC p c)] - render (TargetComponentUnknown pn (Right c) WholeComponent) = - [TargetStringFileStatus3 (dispPN pn) noFileStatus (dispCK c) (dispC' pn c)] - render _ = [] - --- | Syntax: package : component : module --- --- > cabal build foo:foo:Data.Foo --- > cabal build foo/:foo:Data.Foo --- > cabal build foo.cabal:foo:Data.Foo --- -syntaxForm3PackageComponentModule :: [KnownPackage] -> Syntax -syntaxForm3PackageComponentModule ps = - syntaxForm3 render $ \str1 fstatus1 str2 str3 -> do - guardPackage str1 fstatus1 - guardComponentName str2 - guardModuleName str3 - p <- matchPackage ps str1 fstatus1 - case p of - KnownPackage{pinfoId, pinfoComponents} -> - orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do - c <- matchComponentName pinfoComponents str2 - orNoThingIn "component" (cinfoStrName c) $ do - let ms = cinfoModules c - m <- matchModuleName ms str3 - return (TargetComponent pinfoId (cinfoName c) (ModuleTarget m)) - KnownPackageName pn -> do - let cn = mkUnqualComponentName str2 - m <- matchModuleNameUnknown str3 - return (TargetComponentUnknown pn (Left cn) (ModuleTarget m)) - where - render (TargetComponent p c (ModuleTarget m)) = - [TargetStringFileStatus3 (dispP p) noFileStatus (dispC p c) (dispM m)] - render (TargetComponentUnknown pn (Left c) (ModuleTarget m)) = - [TargetStringFileStatus3 (dispPN pn) noFileStatus (dispCN c) (dispM m)] - render _ = [] - --- | Syntax: namespace : component : module --- --- > cabal build lib:foo:Data.Foo --- -syntaxForm3KindComponentModule :: [KnownComponent] -> Syntax -syntaxForm3KindComponentModule cs = - syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do - ckind <- matchComponentKind str1 - guardComponentName str2 - guardModuleName str3 - c <- matchComponentKindAndName cs ckind str2 - orNoThingIn "component" (cinfoStrName c) $ do - let ms = cinfoModules c - m <- matchModuleName ms str3 - return (TargetComponent (cinfoPackageId c) (cinfoName c) - (ModuleTarget m)) - where - render (TargetComponent p c (ModuleTarget m)) = - [TargetStringFileStatus3 (dispCK c) noFileStatus (dispC p c) (dispM m)] - render _ = [] - --- | Syntax: package : component : filename --- --- > cabal build foo:foo:Data/Foo.hs --- > cabal build foo/:foo:Data/Foo.hs --- > cabal build foo.cabal:foo:Data/Foo.hs --- -syntaxForm3PackageComponentFile :: [KnownPackage] -> Syntax -syntaxForm3PackageComponentFile ps = - syntaxForm3 render $ \str1 fstatus1 str2 str3 -> do - guardPackage str1 fstatus1 - guardComponentName str2 - p <- matchPackage ps str1 fstatus1 - case p of - KnownPackage{pinfoId, pinfoComponents} -> - orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do - c <- matchComponentName pinfoComponents str2 - orNoThingIn "component" (cinfoStrName c) $ do - (filepath, _) <- matchComponentFile [c] str3 - return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath)) - KnownPackageName pn -> - let cn = mkUnqualComponentName str2 - filepath = str3 in - return (TargetComponentUnknown pn (Left cn) (FileTarget filepath)) - where - render (TargetComponent p c (FileTarget f)) = - [TargetStringFileStatus3 (dispP p) noFileStatus (dispC p c) f] - render (TargetComponentUnknown pn (Left c) (FileTarget f)) = - [TargetStringFileStatus3 (dispPN pn) noFileStatus (dispCN c) f] - render _ = [] - --- | Syntax: namespace : component : filename --- --- > cabal build lib:foo:Data/Foo.hs --- -syntaxForm3KindComponentFile :: [KnownComponent] -> Syntax -syntaxForm3KindComponentFile cs = - syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do - ckind <- matchComponentKind str1 - guardComponentName str2 - c <- matchComponentKindAndName cs ckind str2 - orNoThingIn "component" (cinfoStrName c) $ do - (filepath, _) <- matchComponentFile [c] str3 - return (TargetComponent (cinfoPackageId c) (cinfoName c) - (FileTarget filepath)) - where - render (TargetComponent p c (FileTarget f)) = - [TargetStringFileStatus3 (dispCK c) noFileStatus (dispC p c) f] - render _ = [] - -syntaxForm3NamespacePackageFilter :: [KnownPackage] -> Syntax -syntaxForm3NamespacePackageFilter ps = - syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do - guardNamespacePackage str1 - guardPackageName str2 - p <- matchPackage ps str2 noFileStatus - kfilter <- matchComponentKindFilter str3 - case p of - KnownPackage{pinfoId} -> - return (TargetPackage TargetExplicitNamed [pinfoId] (Just kfilter)) - KnownPackageName pn -> - return (TargetPackageNamed pn (Just kfilter)) - where - render (TargetPackage TargetExplicitNamed [p] (Just kfilter)) = - [TargetStringFileStatus3 "pkg" noFileStatus (dispP p) (dispF kfilter)] - render (TargetPackageNamed pn (Just kfilter)) = - [TargetStringFileStatus3 "pkg" noFileStatus (dispPN pn) (dispF kfilter)] - render _ = [] - --- - -syntaxForm4MetaNamespacePackageFilter :: [KnownPackage] -> Syntax -syntaxForm4MetaNamespacePackageFilter ps = - syntaxForm4 render $ \str1 str2 str3 str4 -> do - guardNamespaceMeta str1 - guardNamespacePackage str2 - guardPackageName str3 - p <- matchPackage ps str3 noFileStatus - kfilter <- matchComponentKindFilter str4 - case p of - KnownPackage{pinfoId} -> - return (TargetPackage TargetExplicitNamed [pinfoId] (Just kfilter)) - KnownPackageName pn -> - return (TargetPackageNamed pn (Just kfilter)) - where - render (TargetPackage TargetExplicitNamed [p] (Just kfilter)) = - [TargetStringFileStatus4 "" "pkg" (dispP p) (dispF kfilter)] - render (TargetPackageNamed pn (Just kfilter)) = - [TargetStringFileStatus4 "" "pkg" (dispPN pn) (dispF kfilter)] - render _ = [] - --- | Syntax: :pkg : package : namespace : component --- --- > cabal build :pkg:foo:lib:foo --- -syntaxForm5MetaNamespacePackageKindComponent :: [KnownPackage] -> Syntax -syntaxForm5MetaNamespacePackageKindComponent ps = - syntaxForm5 render $ \str1 str2 str3 str4 str5 -> do - guardNamespaceMeta str1 - guardNamespacePackage str2 - guardPackageName str3 - ckind <- matchComponentKind str4 - guardComponentName str5 - p <- matchPackage ps str3 noFileStatus - case p of - KnownPackage{pinfoId, pinfoComponents} -> - orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do - c <- matchComponentKindAndName pinfoComponents ckind str5 - return (TargetComponent pinfoId (cinfoName c) WholeComponent) - KnownPackageName pn -> - let cn = mkComponentName pn ckind (mkUnqualComponentName str5) in - return (TargetComponentUnknown pn (Right cn) WholeComponent) - where - render (TargetComponent p c WholeComponent) = - [TargetStringFileStatus5 "" "pkg" (dispP p) (dispCK c) (dispC p c)] - render (TargetComponentUnknown pn (Right c) WholeComponent) = - [TargetStringFileStatus5 "" "pkg" (dispPN pn) (dispCK c) (dispC' pn c)] - render _ = [] - --- | Syntax: :pkg : package : namespace : component : module : module --- --- > cabal build :pkg:foo:lib:foo:module:Data.Foo --- -syntaxForm7MetaNamespacePackageKindComponentNamespaceModule - :: [KnownPackage] -> Syntax -syntaxForm7MetaNamespacePackageKindComponentNamespaceModule ps = - syntaxForm7 render $ \str1 str2 str3 str4 str5 str6 str7 -> do - guardNamespaceMeta str1 - guardNamespacePackage str2 - guardPackageName str3 - ckind <- matchComponentKind str4 - guardComponentName str5 - guardNamespaceModule str6 - p <- matchPackage ps str3 noFileStatus - case p of - KnownPackage{pinfoId, pinfoComponents} -> - orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do - c <- matchComponentKindAndName pinfoComponents ckind str5 - orNoThingIn "component" (cinfoStrName c) $ do - let ms = cinfoModules c - m <- matchModuleName ms str7 - return (TargetComponent pinfoId (cinfoName c) (ModuleTarget m)) - KnownPackageName pn -> do - let cn = mkComponentName pn ckind (mkUnqualComponentName str2) - m <- matchModuleNameUnknown str7 - return (TargetComponentUnknown pn (Right cn) (ModuleTarget m)) - where - render (TargetComponent p c (ModuleTarget m)) = - [TargetStringFileStatus7 "" "pkg" (dispP p) - (dispCK c) (dispC p c) - "module" (dispM m)] - render (TargetComponentUnknown pn (Right c) (ModuleTarget m)) = - [TargetStringFileStatus7 "" "pkg" (dispPN pn) - (dispCK c) (dispC' pn c) - "module" (dispM m)] - render _ = [] - --- | Syntax: :pkg : package : namespace : component : file : filename --- --- > cabal build :pkg:foo:lib:foo:file:Data/Foo.hs --- -syntaxForm7MetaNamespacePackageKindComponentNamespaceFile - :: [KnownPackage] -> Syntax -syntaxForm7MetaNamespacePackageKindComponentNamespaceFile ps = - syntaxForm7 render $ \str1 str2 str3 str4 str5 str6 str7 -> do - guardNamespaceMeta str1 - guardNamespacePackage str2 - guardPackageName str3 - ckind <- matchComponentKind str4 - guardComponentName str5 - guardNamespaceFile str6 - p <- matchPackage ps str3 noFileStatus - case p of - KnownPackage{pinfoId, pinfoComponents} -> - orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do - c <- matchComponentKindAndName pinfoComponents ckind str5 - orNoThingIn "component" (cinfoStrName c) $ do - (filepath,_) <- matchComponentFile [c] str7 - return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath)) - KnownPackageName pn -> - let cn = mkComponentName pn ckind (mkUnqualComponentName str5) - filepath = str7 in - return (TargetComponentUnknown pn (Right cn) (FileTarget filepath)) - where - render (TargetComponent p c (FileTarget f)) = - [TargetStringFileStatus7 "" "pkg" (dispP p) - (dispCK c) (dispC p c) - "file" f] - render (TargetComponentUnknown pn (Right c) (FileTarget f)) = - [TargetStringFileStatus7 "" "pkg" (dispPN pn) - (dispCK c) (dispC' pn c) - "file" f] - render _ = [] - - ---------------------------------------- --- Syntax utils --- - -type Match1 = String -> FileStatus -> Match TargetSelector -type Match2 = String -> FileStatus -> String - -> Match TargetSelector -type Match3 = String -> FileStatus -> String -> String - -> Match TargetSelector -type Match4 = String -> String -> String -> String - -> Match TargetSelector -type Match5 = String -> String -> String -> String -> String - -> Match TargetSelector -type Match7 = String -> String -> String -> String -> String -> String -> String - -> Match TargetSelector - -syntaxForm1 :: Renderer -> Match1 -> Syntax -syntaxForm2 :: Renderer -> Match2 -> Syntax -syntaxForm3 :: Renderer -> Match3 -> Syntax -syntaxForm4 :: Renderer -> Match4 -> Syntax -syntaxForm5 :: Renderer -> Match5 -> Syntax -syntaxForm7 :: Renderer -> Match7 -> Syntax - -syntaxForm1 render f = - Syntax QL1 match render - where - match = \(TargetStringFileStatus1 str1 fstatus1) -> - f str1 fstatus1 - -syntaxForm2 render f = - Syntax QL2 match render - where - match = \(TargetStringFileStatus2 str1 fstatus1 str2) -> - f str1 fstatus1 str2 - -syntaxForm3 render f = - Syntax QL3 match render - where - match = \(TargetStringFileStatus3 str1 fstatus1 str2 str3) -> - f str1 fstatus1 str2 str3 - -syntaxForm4 render f = - Syntax QLFull match render - where - match (TargetStringFileStatus4 str1 str2 str3 str4) - = f str1 str2 str3 str4 - match _ = mzero - -syntaxForm5 render f = - Syntax QLFull match render - where - match (TargetStringFileStatus5 str1 str2 str3 str4 str5) - = f str1 str2 str3 str4 str5 - match _ = mzero - -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 - -dispP :: Package p => p -> String -dispP = prettyShow . packageName - -dispPN :: PackageName -> String -dispPN = prettyShow - -dispC :: PackageId -> ComponentName -> String -dispC = componentStringName . packageName - -dispC' :: PackageName -> ComponentName -> String -dispC' = componentStringName - -dispCN :: UnqualComponentName -> String -dispCN = prettyShow - -dispK :: ComponentKind -> String -dispK = showComponentKindShort - -dispCK :: ComponentName -> String -dispCK = dispK . componentKind - -dispF :: ComponentKind -> String -dispF = showComponentKindFilterShort - -dispM :: ModuleName -> String -dispM = prettyShow - - -------------------------------- --- Package and component info --- - -data KnownTargets = KnownTargets { - knownPackagesAll :: [KnownPackage], - knownPackagesPrimary :: [KnownPackage], - knownPackagesOther :: [KnownPackage], - knownComponentsAll :: [KnownComponent], - knownComponentsPrimary :: [KnownComponent], - knownComponentsOther :: [KnownComponent] - } - deriving Show - -data KnownPackage = - KnownPackage { - pinfoId :: PackageId, - pinfoDirectory :: Maybe (FilePath, FilePath), - pinfoPackageFile :: Maybe (FilePath, FilePath), - pinfoComponents :: [KnownComponent] - } - | KnownPackageName { - pinfoName :: PackageName - } - deriving Show - -data KnownComponent = KnownComponent { - cinfoName :: ComponentName, - cinfoStrName :: ComponentStringName, - cinfoPackageId :: PackageId, - cinfoSrcDirs :: [FilePath], - cinfoModules :: [ModuleName], - cinfoHsFiles :: [FilePath], -- other hs files (like main.hs) - cinfoCFiles :: [FilePath], - cinfoJsFiles :: [FilePath] - } - deriving Show - -type ComponentStringName = String - -knownPackageName :: KnownPackage -> PackageName -knownPackageName KnownPackage{pinfoId} = packageName pinfoId -knownPackageName KnownPackageName{pinfoName} = pinfoName - -emptyKnownTargets :: KnownTargets -emptyKnownTargets = KnownTargets [] [] [] [] [] [] - -getKnownTargets :: (Applicative m, Monad m) - => DirActions m - -> [PackageSpecifier (SourcePackage (PackageLocation a))] - -> m KnownTargets -getKnownTargets dirActions@DirActions{..} pkgs = do - pinfo <- traverse (collectKnownPackageInfo dirActions) pkgs - cwd <- getCurrentDirectory - let (ppinfo, opinfo) = selectPrimaryPackage cwd pinfo - return KnownTargets { - knownPackagesAll = pinfo, - knownPackagesPrimary = ppinfo, - knownPackagesOther = opinfo, - knownComponentsAll = allComponentsIn pinfo, - knownComponentsPrimary = allComponentsIn ppinfo, - knownComponentsOther = allComponentsIn opinfo - } - where - selectPrimaryPackage :: FilePath - -> [KnownPackage] - -> ([KnownPackage], [KnownPackage]) - selectPrimaryPackage cwd = partition isPkgDirCwd - where - isPkgDirCwd KnownPackage { pinfoDirectory = Just (dir,_) } - | dir == cwd = True - isPkgDirCwd _ = False - allComponentsIn ps = - [ c | KnownPackage{pinfoComponents} <- ps, c <- pinfoComponents ] - - -collectKnownPackageInfo :: (Applicative m, Monad m) => DirActions m - -> PackageSpecifier (SourcePackage (PackageLocation a)) - -> m KnownPackage -collectKnownPackageInfo _ (NamedPackage pkgname _props) = - return (KnownPackageName pkgname) -collectKnownPackageInfo dirActions@DirActions{..} - (SpecificSourcePackage SourcePackage { - srcpkgDescription = pkg, - srcpkgSource = loc - }) = do - (pkgdir, pkgfile) <- - case loc of - --TODO: local tarballs, remote tarballs etc - LocalUnpackedPackage dir -> do - dirabs <- canonicalizePath dir - dirrel <- makeRelativeToCwd dirActions dirabs - --TODO: ought to get this earlier in project reading - let fileabs = dirabs prettyShow (packageName pkg) <.> "cabal" - filerel = dirrel prettyShow (packageName pkg) <.> "cabal" - exists <- doesFileExist fileabs - return ( Just (dirabs, dirrel) - , if exists then Just (fileabs, filerel) else Nothing - ) - _ -> return (Nothing, Nothing) - let pinfo = - KnownPackage { - pinfoId = packageId pkg, - pinfoDirectory = pkgdir, - pinfoPackageFile = pkgfile, - pinfoComponents = collectKnownComponentInfo - (flattenPackageDescription pkg) - } - return pinfo - - -collectKnownComponentInfo :: PackageDescription -> [KnownComponent] -collectKnownComponentInfo pkg = - [ KnownComponent { - cinfoName = componentName c, - cinfoStrName = componentStringName (packageName pkg) (componentName c), - cinfoPackageId = packageId pkg, - cinfoSrcDirs = ordNub (hsSourceDirs bi), - cinfoModules = ordNub (componentModules c), - cinfoHsFiles = ordNub (componentHsFiles c), - cinfoCFiles = ordNub (cSources bi), - cinfoJsFiles = ordNub (jsSources bi) - } - | c <- pkgComponents pkg - , let bi = componentBuildInfo c ] - - -componentStringName :: PackageName -> ComponentName -> ComponentStringName -componentStringName pkgname (CLibName LMainLibName) = prettyShow pkgname -componentStringName _ (CLibName (LSubLibName name)) = unUnqualComponentName name -componentStringName _ (CFLibName name) = unUnqualComponentName name -componentStringName _ (CExeName name) = unUnqualComponentName name -componentStringName _ (CTestName name) = unUnqualComponentName name -componentStringName _ (CBenchName name) = unUnqualComponentName name - -componentModules :: Component -> [ModuleName] --- I think it's unlikely users will ask to build a requirement --- which is not mentioned locally. -componentModules (CLib lib) = explicitLibModules lib -componentModules (CFLib flib) = foreignLibModules flib -componentModules (CExe exe) = exeModules exe -componentModules (CTest test) = testModules test -componentModules (CBench bench) = benchmarkModules bench - -componentHsFiles :: Component -> [FilePath] -componentHsFiles (CExe exe) = [modulePath exe] -componentHsFiles (CTest TestSuite { - testInterface = TestSuiteExeV10 _ mainfile - }) = [mainfile] -componentHsFiles (CBench Benchmark { - benchmarkInterface = BenchmarkExeV10 _ mainfile - }) = [mainfile] -componentHsFiles _ = [] - - ------------------------------- --- Matching meta targets --- - -guardNamespaceMeta :: String -> Match () -guardNamespaceMeta = guardToken [""] "meta namespace" - -guardMetaAll :: String -> Match () -guardMetaAll = guardToken ["all"] "meta-target 'all'" - -guardNamespacePackage :: String -> Match () -guardNamespacePackage = guardToken ["pkg", "package"] "'pkg' namespace" - -guardNamespaceCwd :: String -> Match () -guardNamespaceCwd = guardToken ["cwd"] "'cwd' namespace" - -guardNamespaceModule :: String -> Match () -guardNamespaceModule = guardToken ["mod", "module"] "'module' namespace" - -guardNamespaceFile :: String -> Match () -guardNamespaceFile = guardToken ["file"] "'file' namespace" - -guardToken :: [String] -> String -> String -> Match () -guardToken tokens msg s - | caseFold s `elem` tokens = increaseConfidence - | otherwise = matchErrorExpected msg s - - ------------------------------- --- Matching component kinds --- - -componentKind :: ComponentName -> ComponentKind -componentKind (CLibName _) = LibKind -componentKind (CFLibName _) = FLibKind -componentKind (CExeName _) = ExeKind -componentKind (CTestName _) = TestKind -componentKind (CBenchName _) = BenchKind - -cinfoKind :: KnownComponent -> ComponentKind -cinfoKind = componentKind . cinfoName - -matchComponentKind :: String -> Match ComponentKind -matchComponentKind s - | s' `elem` liblabels = increaseConfidence >> return LibKind - | s' `elem` fliblabels = increaseConfidence >> return FLibKind - | s' `elem` exelabels = increaseConfidence >> return ExeKind - | s' `elem` testlabels = increaseConfidence >> return TestKind - | s' `elem` benchlabels = increaseConfidence >> return BenchKind - | otherwise = matchErrorExpected "component kind" s - where - s' = caseFold s - liblabels = ["lib", "library"] - fliblabels = ["flib", "foreign-library"] - exelabels = ["exe", "executable"] - testlabels = ["tst", "test", "test-suite"] - benchlabels = ["bench", "benchmark"] - -matchComponentKindFilter :: String -> Match ComponentKind -matchComponentKindFilter s - | s' `elem` liblabels = increaseConfidence >> return LibKind - | s' `elem` fliblabels = increaseConfidence >> return FLibKind - | s' `elem` exelabels = increaseConfidence >> return ExeKind - | s' `elem` testlabels = increaseConfidence >> return TestKind - | s' `elem` benchlabels = increaseConfidence >> return BenchKind - | otherwise = matchErrorExpected "component kind filter" s - where - s' = caseFold s - liblabels = ["libs", "libraries"] - fliblabels = ["flibs", "foreign-libraries"] - exelabels = ["exes", "executables"] - testlabels = ["tests", "test-suites"] - benchlabels = ["benches", "benchmarks"] - -showComponentKind :: ComponentKind -> String -showComponentKind LibKind = "library" -showComponentKind FLibKind = "foreign library" -showComponentKind ExeKind = "executable" -showComponentKind TestKind = "test-suite" -showComponentKind BenchKind = "benchmark" - -showComponentKindShort :: ComponentKind -> String -showComponentKindShort LibKind = "lib" -showComponentKindShort FLibKind = "flib" -showComponentKindShort ExeKind = "exe" -showComponentKindShort TestKind = "test" -showComponentKindShort BenchKind = "bench" - -showComponentKindFilterShort :: ComponentKind -> String -showComponentKindFilterShort LibKind = "libs" -showComponentKindFilterShort FLibKind = "flibs" -showComponentKindFilterShort ExeKind = "exes" -showComponentKindFilterShort TestKind = "tests" -showComponentKindFilterShort BenchKind = "benchmarks" - - ------------------------------- --- Matching package targets --- - -guardPackage :: String -> FileStatus -> Match () -guardPackage str fstatus = - guardPackageName str - <|> guardPackageDir str fstatus - <|> guardPackageFile str fstatus - - -guardPackageName :: String -> Match () -guardPackageName s - | validPackageName s = increaseConfidence - | otherwise = matchErrorExpected "package name" s - -validPackageName :: String -> Bool -validPackageName s = - all validPackageNameChar s - && not (null s) - where - validPackageNameChar c = isAlphaNum c || c == '-' - - -guardPackageDir :: String -> FileStatus -> Match () -guardPackageDir _ (FileStatusExistsDir _) = increaseConfidence -guardPackageDir str _ = matchErrorExpected "package directory" str - - -guardPackageFile :: String -> FileStatus -> Match () -guardPackageFile _ (FileStatusExistsFile file) - | takeExtension file == ".cabal" - = increaseConfidence -guardPackageFile str _ = matchErrorExpected "package .cabal file" str - - -matchPackage :: [KnownPackage] -> String -> FileStatus -> Match KnownPackage -matchPackage pinfo = \str fstatus -> - orNoThingIn "project" "" $ - matchPackageName pinfo str - (matchPackageNameUnknown str - <|> matchPackageDir pinfo str fstatus - <|> matchPackageFile pinfo str fstatus) - - -matchPackageName :: [KnownPackage] -> String -> Match KnownPackage -matchPackageName ps = \str -> do - guard (validPackageName str) - orNoSuchThing "package" str - (map (prettyShow . knownPackageName) ps) $ - increaseConfidenceFor $ - matchInexactly caseFold (prettyShow . knownPackageName) ps str - - -matchPackageNameUnknown :: String -> Match KnownPackage -matchPackageNameUnknown str = do - pn <- matchParse str - unknownMatch (KnownPackageName pn) - - -matchPackageDir :: [KnownPackage] - -> String -> FileStatus -> Match KnownPackage -matchPackageDir ps = \str fstatus -> - case fstatus of - FileStatusExistsDir canondir -> - orNoSuchThing "package directory" str (map (snd . fst) dirs) $ - increaseConfidenceFor $ - fmap snd $ matchExactly (fst . fst) dirs canondir - _ -> mzero - where - dirs = [ ((dabs,drel),p) - | p@KnownPackage{ pinfoDirectory = Just (dabs,drel) } <- ps ] - - -matchPackageFile :: [KnownPackage] -> String -> FileStatus -> Match KnownPackage -matchPackageFile ps = \str fstatus -> do - case fstatus of - FileStatusExistsFile canonfile -> - orNoSuchThing "package .cabal file" str (map (snd . fst) files) $ - increaseConfidenceFor $ - fmap snd $ matchExactly (fst . fst) files canonfile - _ -> mzero - where - files = [ ((fabs,frel),p) - | p@KnownPackage{ pinfoPackageFile = Just (fabs,frel) } <- ps ] - ---TODO: test outcome when dir exists but doesn't match any known one - ---TODO: perhaps need another distinction, vs no such thing, point is the --- thing is not known, within the project, but could be outside project - - ------------------------------- --- Matching component targets --- - - -guardComponentName :: String -> Match () -guardComponentName s - | all validComponentChar s - && not (null s) = increaseConfidence - | otherwise = matchErrorExpected "component name" s - where - validComponentChar c = isAlphaNum c || c == '.' - || c == '_' || c == '-' || c == '\'' - - -matchComponentName :: [KnownComponent] -> String -> Match KnownComponent -matchComponentName cs str = - orNoSuchThing "component" str (map cinfoStrName cs) - $ increaseConfidenceFor - $ matchInexactly caseFold cinfoStrName cs str - - -matchComponentKindAndName :: [KnownComponent] -> ComponentKind -> String - -> Match KnownComponent -matchComponentKindAndName cs ckind str = - orNoSuchThing (showComponentKind ckind ++ " component") str - (map render cs) - $ increaseConfidenceFor - $ matchInexactly (\(ck, cn) -> (ck, caseFold cn)) - (\c -> (cinfoKind c, cinfoStrName c)) - cs - (ckind, str) - where - render c = showComponentKindShort (cinfoKind c) ++ ":" ++ cinfoStrName c - - ------------------------------- --- Matching module targets --- - -guardModuleName :: String -> Match () -guardModuleName s = - case simpleParsec s :: Maybe ModuleName of - Just _ -> increaseConfidence - _ | all validModuleChar s - && not (null s) -> return () - | otherwise -> matchErrorExpected "module name" s - where - validModuleChar c = isAlphaNum c || c == '.' || c == '_' || c == '\'' - - -matchModuleName :: [ModuleName] -> String -> Match ModuleName -matchModuleName ms str = - orNoSuchThing "module" str (map prettyShow ms) - $ increaseConfidenceFor - $ matchInexactly caseFold prettyShow ms str - - -matchModuleNameAnd :: [(ModuleName, a)] -> String -> Match (ModuleName, a) -matchModuleNameAnd ms str = - orNoSuchThing "module" str (map (prettyShow . fst) ms) - $ increaseConfidenceFor - $ matchInexactly caseFold (prettyShow . fst) ms str - - -matchModuleNameUnknown :: String -> Match ModuleName -matchModuleNameUnknown str = - expecting "module" str - $ increaseConfidenceFor - $ matchParse str - - ------------------------------- --- Matching file targets --- - -matchPackageDirectoryPrefix :: [KnownPackage] -> FileStatus - -> Match (FilePath, KnownPackage) -matchPackageDirectoryPrefix ps (FileStatusExistsFile filepath) = - increaseConfidenceFor $ - matchDirectoryPrefix pkgdirs filepath - where - pkgdirs = [ (dir, p) - | p@KnownPackage { pinfoDirectory = Just (dir,_) } <- ps ] -matchPackageDirectoryPrefix _ _ = mzero - - -matchComponentFile :: [KnownComponent] -> String - -> Match (FilePath, KnownComponent) -matchComponentFile cs str = - orNoSuchThing "file" str [] $ - matchComponentModuleFile cs str - <|> matchComponentOtherFile cs str - - -matchComponentOtherFile :: [KnownComponent] -> String - -> Match (FilePath, KnownComponent) -matchComponentOtherFile cs = - matchFile - [ (normalise (srcdir file), c) - | c <- cs - , srcdir <- cinfoSrcDirs c - , file <- cinfoHsFiles c - ++ cinfoCFiles c - ++ cinfoJsFiles c - ] - . normalise - - -matchComponentModuleFile :: [KnownComponent] -> String - -> Match (FilePath, KnownComponent) -matchComponentModuleFile cs str = do - matchFile - [ (normalise (d toFilePath m), c) - | c <- cs - , d <- cinfoSrcDirs c - , m <- cinfoModules c - ] - (dropExtension (normalise str)) -- Drop the extension because FileTarget - -- is stored without the extension - --- utils - -matchFile :: [(FilePath, a)] -> FilePath -> Match (FilePath, a) -matchFile fs = - increaseConfidenceFor - . matchInexactly caseFold fst fs - -matchDirectoryPrefix :: [(FilePath, a)] -> FilePath -> Match (FilePath, a) -matchDirectoryPrefix dirs filepath = - tryEach $ - [ (file, x) - | (dir,x) <- dirs - , file <- maybeToList (stripDirectory dir) ] - where - stripDirectory :: FilePath -> Maybe FilePath - stripDirectory dir = - joinPath `fmap` stripPrefix (splitDirectories dir) filepathsplit - - filepathsplit = splitDirectories filepath - - ------------------------------- --- Matching monad --- - --- | A matcher embodies a way to match some input as being some recognised --- value. In particular it deals with multiple and ambiguous matches. --- --- There are various matcher primitives ('matchExactly', 'matchInexactly'), --- ways to combine matchers ('matchPlus', 'matchPlusShadowing') and finally we --- can run a matcher against an input using 'findMatch'. --- -data Match a = NoMatch !Confidence [MatchError] - | Match !MatchClass !Confidence [a] - deriving Show - --- | The kind of match, inexact or exact. We keep track of this so we can --- prefer exact over inexact matches. The 'Ord' here is important: we try --- to maximise this, so 'Exact' is the top value and 'Inexact' the bottom. --- -data MatchClass = Unknown -- ^ Matches an unknown thing e.g. parses as a package - -- name without it being a specific known package - | Inexact -- ^ Matches a known thing inexactly - -- e.g. matches a known package case insensitively - | Exact -- ^ Exactly matches a known thing, - -- e.g. matches a known package case sensitively - deriving (Show, Eq, Ord) - -type Confidence = Int - -data MatchError = MatchErrorExpected String String -- thing got - | MatchErrorNoSuch String String [String] -- thing got alts - | MatchErrorIn String String MatchError -- kind thing - deriving (Show, Eq) - - -instance Functor Match where - fmap _ (NoMatch d ms) = NoMatch d ms - fmap f (Match m d xs) = Match m d (fmap f xs) - -instance Applicative Match where - pure a = Match Exact 0 [a] - (<*>) = ap - -instance Alternative Match where - empty = NoMatch 0 [] - (<|>) = matchPlus - -instance Monad Match where - return = pure - NoMatch d ms >>= _ = NoMatch d ms - Match m d xs >>= f = - -- To understand this, it needs to be read in context with the - -- implementation of 'matchPlus' below - case msum (map f xs) of - Match m' d' xs' -> Match (min m m') (d + d') xs' - -- The minimum match class is the one we keep. The match depth is - -- tracked but not used in the Match case. - - NoMatch d' ms -> NoMatch (d + d') ms - -- Here is where we transfer the depth we were keeping track of in - -- the Match case over to the NoMatch case where it finally gets used. - -instance MonadPlus Match where - mzero = empty - mplus = matchPlus - -() :: Match a -> Match a -> Match a -() = matchPlusShadowing - -infixl 3 - --- | Combine two matchers. Exact matches are used over inexact matches --- but if we have multiple exact, or inexact then the we collect all the --- ambiguous matches. --- --- This operator is associative, has unit 'mzero' and is also commutative. --- -matchPlus :: Match a -> Match a -> Match a -matchPlus a@(Match _ _ _ ) (NoMatch _ _) = a -matchPlus (NoMatch _ _ ) b@(Match _ _ _) = b -matchPlus a@(NoMatch d_a ms_a) b@(NoMatch d_b ms_b) - | d_a > d_b = a -- We only really make use of the depth in the NoMatch case. - | d_a < d_b = b - | otherwise = NoMatch d_a (ms_a ++ ms_b) -matchPlus a@(Match m_a d_a xs_a) b@(Match m_b d_b xs_b) - | m_a > m_b = a -- exact over inexact - | m_a < m_b = b -- exact over inexact - | otherwise = Match m_a (max d_a d_b) (xs_a ++ xs_b) - --- | Combine two matchers. This is similar to 'matchPlus' with the --- difference that an exact match from the left matcher shadows any exact --- match on the right. Inexact matches are still collected however. --- --- This operator is associative, has unit 'mzero' and is not commutative. --- -matchPlusShadowing :: Match a -> Match a -> Match a -matchPlusShadowing a@(Match Exact _ _) _ = a -matchPlusShadowing a b = matchPlus a b - - ------------------------------- --- Various match primitives --- - -matchErrorExpected :: String -> String -> Match a -matchErrorExpected thing got = NoMatch 0 [MatchErrorExpected thing got] - -matchErrorNoSuch :: String -> String -> [String] -> Match a -matchErrorNoSuch thing got alts = NoMatch 0 [MatchErrorNoSuch thing got alts] - -expecting :: String -> String -> Match a -> Match a -expecting thing got (NoMatch 0 _) = matchErrorExpected thing got -expecting _ _ m = m - -orNoSuchThing :: String -> String -> [String] -> Match a -> Match a -orNoSuchThing thing got alts (NoMatch 0 _) = matchErrorNoSuch thing got alts -orNoSuchThing _ _ _ m = m - -orNoThingIn :: String -> String -> Match a -> Match a -orNoThingIn kind name (NoMatch n ms) = - NoMatch n [ MatchErrorIn kind name m | m <- ms ] -orNoThingIn _ _ m = m - -increaseConfidence :: Match () -increaseConfidence = Match Exact 1 [()] - -increaseConfidenceFor :: Match a -> Match a -increaseConfidenceFor m = m >>= \r -> increaseConfidence >> return r - -nubMatchesBy :: (a -> a -> Bool) -> Match a -> Match a -nubMatchesBy _ (NoMatch d msgs) = NoMatch d msgs -nubMatchesBy eq (Match m d xs) = Match m d (nubBy eq xs) - --- | Lift a list of matches to an exact match. --- -exactMatches, inexactMatches :: [a] -> Match a - -exactMatches [] = mzero -exactMatches xs = Match Exact 0 xs - -inexactMatches [] = mzero -inexactMatches xs = Match Inexact 0 xs - -unknownMatch :: a -> Match a -unknownMatch x = Match Unknown 0 [x] - -tryEach :: [a] -> Match a -tryEach = exactMatches - - ------------------------------- --- Top level match runner --- - --- | Given a matcher and a key to look up, use the matcher to find all the --- possible matches. There may be 'None', a single 'Unambiguous' match or --- you may have an 'Ambiguous' match with several possibilities. --- -findMatch :: Match a -> MaybeAmbiguous a -findMatch match = case match of - NoMatch _ msgs -> None msgs - Match _ _ [x] -> Unambiguous x - Match m d [] -> error $ "findMatch: impossible: " ++ show match' - where match' = Match m d [] :: Match () - -- TODO: Maybe use Data.List.NonEmpty inside - -- Match so that this case would be correct - -- by construction? - Match m _ xs -> Ambiguous m xs - -data MaybeAmbiguous a = None [MatchError] - | Unambiguous a - | Ambiguous MatchClass [a] - deriving Show - - ------------------------------- --- Basic matchers --- - --- | A primitive matcher that looks up a value in a finite 'Map'. The --- value must match exactly. --- -matchExactly :: Ord k => (a -> k) -> [a] -> (k -> Match a) -matchExactly key xs = - \k -> case Map.lookup k m of - Nothing -> mzero - Just ys -> exactMatches ys - where - m = Map.fromListWith (++) [ (key x, [x]) | x <- xs ] - --- | A primitive matcher that looks up a value in a finite 'Map'. It checks --- for an exact or inexact match. We get an inexact match if the match --- is not exact, but the canonical forms match. It takes a canonicalisation --- function for this purpose. --- --- So for example if we used string case fold as the canonicalisation --- function, then we would get case insensitive matching (but it will still --- report an exact match when the case matches too). --- -matchInexactly :: (Ord k, Ord k') => (k -> k') -> (a -> k) - -> [a] -> (k -> Match a) -matchInexactly cannonicalise key xs = - \k -> case Map.lookup k m of - Just ys -> exactMatches ys - Nothing -> case Map.lookup (cannonicalise k) m' of - Just ys -> inexactMatches ys - Nothing -> mzero - where - m = Map.fromListWith (++) [ (key x, [x]) | x <- xs ] - - -- the map of canonicalised keys to groups of inexact matches - m' = Map.mapKeysWith (++) cannonicalise m - -matchParse :: Parsec a => String -> Match a -matchParse = maybe mzero return . simpleParsec - - ------------------------------- --- Utils --- - -caseFold :: String -> String -caseFold = lowercase - --- | Make a 'ComponentName' given an 'UnqualComponentName' and knowing the --- 'ComponentKind'. We also need the 'PackageName' to distinguish the package's --- primary library from named private libraries. --- -mkComponentName :: PackageName - -> ComponentKind - -> UnqualComponentName - -> ComponentName -mkComponentName pkgname ckind ucname = - case ckind of - LibKind - | packageNameToUnqualComponentName pkgname == ucname - -> CLibName LMainLibName - | otherwise -> CLibName $ LSubLibName ucname - FLibKind -> CFLibName ucname - ExeKind -> CExeName ucname - TestKind -> CTestName ucname - BenchKind -> CBenchName ucname - - ------------------------------- --- Example inputs --- - -{- -ex1pinfo :: [KnownPackage] -ex1pinfo = - [ addComponent (CExeName (mkUnqualComponentName "foo-exe")) [] ["Data.Foo"] $ - KnownPackage { - pinfoId = PackageIdentifier (mkPackageName "foo") (mkVersion [1]), - pinfoDirectory = Just ("/the/foo", "foo"), - pinfoPackageFile = Just ("/the/foo/foo.cabal", "foo/foo.cabal"), - pinfoComponents = [] - } - , KnownPackage { - pinfoId = PackageIdentifier (mkPackageName "bar") (mkVersion [1]), - pinfoDirectory = Just ("/the/bar", "bar"), - pinfoPackageFile = Just ("/the/bar/bar.cabal", "bar/bar.cabal"), - pinfoComponents = [] - } - ] - where - addComponent n ds ms p = - p { - pinfoComponents = - KnownComponent n (componentStringName (pinfoId p) n) - p ds (map mkMn ms) - [] [] [] - : pinfoComponents p - } - - mkMn :: String -> ModuleName - mkMn = ModuleName.fromString --} -{- -stargets = - [ TargetComponent (CExeName "foo") WholeComponent - , TargetComponent (CExeName "foo") (ModuleTarget (mkMn "Foo")) - , TargetComponent (CExeName "tst") (ModuleTarget (mkMn "Foo")) - ] - where - mkMn :: String -> ModuleName - mkMn = fromJust . simpleParse - -ex_pkgid :: PackageIdentifier -Just ex_pkgid = simpleParse "thelib" --} - -{- -ex_cs :: [KnownComponent] -ex_cs = - [ (mkC (CExeName "foo") ["src1", "src1/src2"] ["Foo", "Src2.Bar", "Bar"]) - , (mkC (CExeName "tst") ["src1", "test"] ["Foo"]) - ] - where - mkC n ds ms = KnownComponent n (componentStringName n) ds (map mkMn ms) - mkMn :: String -> ModuleName - mkMn = fromJust . simpleParse - pkgid :: PackageIdentifier - Just pkgid = simpleParse "thelib" --} diff --git a/cabal/cabal-install/Distribution/Client/Targets.hs b/cabal/cabal-install/Distribution/Client/Targets.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Targets.hs +++ /dev/null @@ -1,746 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Targets --- Copyright : (c) Duncan Coutts 2011 --- License : BSD-like --- --- Maintainer : duncan@community.haskell.org --- --- Handling for user-specified targets ------------------------------------------------------------------------------ -module Distribution.Client.Targets ( - -- * User targets - UserTarget(..), - readUserTargets, - - -- * Resolving user targets to package specifiers - resolveUserTargets, - - -- ** Detailed interface - UserTargetProblem(..), - readUserTarget, - reportUserTargetProblems, - expandUserTarget, - - PackageTarget(..), - fetchPackageTarget, - readPackageTarget, - - PackageTargetProblem(..), - reportPackageTargetProblems, - - disambiguatePackageTargets, - disambiguatePackageName, - - -- * User constraints - UserQualifier(..), - UserConstraintScope(..), - UserConstraint(..), - userConstraintPackageName, - readUserConstraint, - userToPackageConstraint, - - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude - -import Distribution.Package - ( Package(..), PackageName, unPackageName, mkPackageName - , packageName ) -import Distribution.Types.Dependency -import Distribution.Client.Types - ( PackageLocation(..), ResolvedPkgLoc, UnresolvedSourcePackage - , PackageSpecifier(..) ) - -import Distribution.Solver.Types.OptionalStanza -import Distribution.Solver.Types.PackageConstraint -import Distribution.Solver.Types.PackagePath -import Distribution.Solver.Types.PackageIndex (PackageIndex) -import qualified Distribution.Solver.Types.PackageIndex as PackageIndex -import Distribution.Solver.Types.SourcePackage - -import qualified Distribution.Client.World as World -import qualified Codec.Archive.Tar as Tar -import qualified Codec.Archive.Tar.Entry as Tar -import qualified Distribution.Client.Tar as Tar -import Distribution.Client.FetchUtils -import Distribution.Client.Utils ( tryFindPackageDesc ) -import Distribution.Client.GlobalFlags - ( RepoContext(..) ) -import Distribution.Types.PackageVersionConstraint - ( PackageVersionConstraint (..) ) - -import Distribution.PackageDescription - ( GenericPackageDescription ) -import Distribution.Types.Flag - ( nullFlagAssignment, parsecFlagAssignmentNonEmpty ) -import Distribution.Version - ( anyVersion, isAnyVersion ) -import Distribution.Simple.Utils - ( die', warn, lowercase ) - -import Distribution.PackageDescription.Parsec - ( readGenericPackageDescription, parseGenericPackageDescriptionMaybe ) - -import qualified Data.Map as Map -import qualified Data.ByteString.Lazy as BS -import qualified Distribution.Client.GZipUtils as GZipUtils -import qualified Distribution.Compat.CharParsing as P -import System.FilePath - ( takeExtension, dropExtension, takeDirectory, splitPath ) -import System.Directory - ( doesFileExist, doesDirectoryExist ) -import Network.URI - ( URI(..), URIAuth(..), parseAbsoluteURI ) - --- ------------------------------------------------------------ --- * User targets --- ------------------------------------------------------------ - --- | Various ways that a user may specify a package or package collection. --- -data UserTarget = - - -- | A partially specified package, identified by name and possibly with - -- an exact version or a version constraint. - -- - -- > cabal install foo - -- > cabal install foo-1.0 - -- > cabal install 'foo < 2' - -- - UserTargetNamed PackageVersionConstraint - - -- | A special virtual package that refers to the collection of packages - -- recorded in the world file that the user specifically installed. - -- - -- > cabal install world - -- - | UserTargetWorld - - -- | A specific package that is unpacked in a local directory, often the - -- current directory. - -- - -- > cabal install . - -- > cabal install ../lib/other - -- - -- * Note: in future, if multiple @.cabal@ files are allowed in a single - -- directory then this will refer to the collection of packages. - -- - | UserTargetLocalDir FilePath - - -- | A specific local unpacked package, identified by its @.cabal@ file. - -- - -- > cabal install foo.cabal - -- > cabal install ../lib/other/bar.cabal - -- - | UserTargetLocalCabalFile FilePath - - -- | A specific package that is available as a local tarball file - -- - -- > cabal install dist/foo-1.0.tar.gz - -- > cabal install ../build/baz-1.0.tar.gz - -- - | UserTargetLocalTarball FilePath - - -- | A specific package that is available as a remote tarball file - -- - -- > cabal install http://code.haskell.org/~user/foo/foo-0.9.tar.gz - -- - | UserTargetRemoteTarball URI - deriving (Show,Eq) - - --- ------------------------------------------------------------ --- * Parsing and checking user targets --- ------------------------------------------------------------ - -readUserTargets :: Verbosity -> [String] -> IO [UserTarget] -readUserTargets verbosity targetStrs = do - (problems, targets) <- liftM partitionEithers - (traverse readUserTarget targetStrs) - reportUserTargetProblems verbosity problems - return targets - - -data UserTargetProblem - = UserTargetUnexpectedFile String - | UserTargetNonexistantFile String - | UserTargetUnexpectedUriScheme String - | UserTargetUnrecognisedUri String - | UserTargetUnrecognised String - | UserTargetBadWorldPkg - deriving Show - -readUserTarget :: String -> IO (Either UserTargetProblem UserTarget) -readUserTarget targetstr = - case eitherParsec targetstr of - Right (PackageVersionConstraint pkgn verrange) - | pkgn == mkPackageName "world" - -> return $ if verrange == anyVersion - then Right UserTargetWorld - else Left UserTargetBadWorldPkg - Right dep -> return (Right (UserTargetNamed dep)) - Left _err -> do - fileTarget <- testFileTargets targetstr - case fileTarget of - Just target -> return target - Nothing -> - case testUriTargets targetstr of - Just target -> return target - Nothing -> return (Left (UserTargetUnrecognised targetstr)) - where - testFileTargets filename = do - isDir <- doesDirectoryExist filename - isFile <- doesFileExist filename - parentDirExists <- case takeDirectory filename of - [] -> return False - dir -> doesDirectoryExist dir - let result - | isDir - = Just (Right (UserTargetLocalDir filename)) - - | isFile && extensionIsTarGz filename - = Just (Right (UserTargetLocalTarball filename)) - - | isFile && takeExtension filename == ".cabal" - = Just (Right (UserTargetLocalCabalFile filename)) - - | isFile - = Just (Left (UserTargetUnexpectedFile filename)) - - | parentDirExists - = Just (Left (UserTargetNonexistantFile filename)) - - | otherwise - = Nothing - return result - - testUriTargets str = - case parseAbsoluteURI str of - Just uri@URI { - uriScheme = scheme, - uriAuthority = Just URIAuth { uriRegName = host } - } - | scheme /= "http:" && scheme /= "https:" -> - Just (Left (UserTargetUnexpectedUriScheme targetstr)) - - | null host -> - Just (Left (UserTargetUnrecognisedUri targetstr)) - - | otherwise -> - Just (Right (UserTargetRemoteTarball uri)) - _ -> Nothing - - extensionIsTarGz f = takeExtension f == ".gz" - && takeExtension (dropExtension f) == ".tar" - -reportUserTargetProblems :: Verbosity -> [UserTargetProblem] -> IO () -reportUserTargetProblems verbosity problems = do - case [ target | UserTargetUnrecognised target <- problems ] of - [] -> return () - target -> die' verbosity - $ unlines - [ "Unrecognised target '" ++ name ++ "'." - | name <- target ] - ++ "Targets can be:\n" - ++ " - package names, e.g. 'pkgname', 'pkgname-1.0.1', 'pkgname < 2.0'\n" - ++ " - the special 'world' target\n" - ++ " - cabal files 'pkgname.cabal' or package directories 'pkgname/'\n" - ++ " - package tarballs 'pkgname.tar.gz' or 'http://example.com/pkgname.tar.gz'" - - case [ () | UserTargetBadWorldPkg <- problems ] of - [] -> return () - _ -> die' verbosity "The special 'world' target does not take any version." - - case [ target | UserTargetNonexistantFile target <- problems ] of - [] -> return () - target -> die' verbosity - $ unlines - [ "The file does not exist '" ++ name ++ "'." - | name <- target ] - - case [ target | UserTargetUnexpectedFile target <- problems ] of - [] -> return () - target -> die' verbosity - $ unlines - [ "Unrecognised file target '" ++ name ++ "'." - | name <- target ] - ++ "File targets can be either package tarballs 'pkgname.tar.gz' " - ++ "or cabal files 'pkgname.cabal'." - - case [ target | UserTargetUnexpectedUriScheme target <- problems ] of - [] -> return () - target -> die' verbosity - $ unlines - [ "URL target not supported '" ++ name ++ "'." - | name <- target ] - ++ "Only 'http://' and 'https://' URLs are supported." - - case [ target | UserTargetUnrecognisedUri target <- problems ] of - [] -> return () - target -> die' verbosity - $ unlines - [ "Unrecognise URL target '" ++ name ++ "'." - | name <- target ] - - --- ------------------------------------------------------------ --- * Resolving user targets to package specifiers --- ------------------------------------------------------------ - --- | Given a bunch of user-specified targets, try to resolve what it is they --- refer to. They can either be specific packages (local dirs, tarballs etc) --- or they can be named packages (with or without version info). --- -resolveUserTargets :: Package pkg - => Verbosity - -> RepoContext - -> FilePath - -> PackageIndex pkg - -> [UserTarget] - -> IO [PackageSpecifier UnresolvedSourcePackage] -resolveUserTargets verbosity repoCtxt worldFile available userTargets = do - - -- given the user targets, get a list of fully or partially resolved - -- package references - packageTargets <- traverse (readPackageTarget verbosity) - =<< traverse (fetchPackageTarget verbosity repoCtxt) . concat - =<< traverse (expandUserTarget verbosity worldFile) userTargets - - -- users are allowed to give package names case-insensitively, so we must - -- disambiguate named package references - let (problems, packageSpecifiers) = - disambiguatePackageTargets available availableExtra packageTargets - - -- use any extra specific available packages to help us disambiguate - availableExtra = [ packageName pkg - | PackageTargetLocation pkg <- packageTargets ] - - reportPackageTargetProblems verbosity problems - - return packageSpecifiers - - --- ------------------------------------------------------------ --- * Package targets --- ------------------------------------------------------------ - --- | An intermediate between a 'UserTarget' and a resolved 'PackageSpecifier'. --- Unlike a 'UserTarget', a 'PackageTarget' refers only to a single package. --- -data PackageTarget pkg = - PackageTargetNamed PackageName [PackageProperty] UserTarget - - -- | A package identified by name, but case insensitively, so it needs - -- to be resolved to the right case-sensitive name. - | PackageTargetNamedFuzzy PackageName [PackageProperty] UserTarget - | PackageTargetLocation pkg - deriving (Show, Functor, Foldable, Traversable) - - --- ------------------------------------------------------------ --- * Converting user targets to package targets --- ------------------------------------------------------------ - --- | Given a user-specified target, expand it to a bunch of package targets --- (each of which refers to only one package). --- -expandUserTarget :: Verbosity - -> FilePath - -> UserTarget - -> IO [PackageTarget (PackageLocation ())] -expandUserTarget verbosity worldFile userTarget = case userTarget of - - UserTargetNamed (PackageVersionConstraint name vrange) -> - let props = [ PackagePropertyVersion vrange - | not (isAnyVersion vrange) ] - in return [PackageTargetNamedFuzzy name props userTarget] - - UserTargetWorld -> do - worldPkgs <- World.getContents verbosity worldFile - --TODO: should we warn if there are no world targets? - return [ PackageTargetNamed name props userTarget - | World.WorldPkgInfo (Dependency name vrange _) flags <- worldPkgs - , let props = [ PackagePropertyVersion vrange - | not (isAnyVersion vrange) ] - ++ [ PackagePropertyFlags flags - | not (nullFlagAssignment flags) ] ] - - UserTargetLocalDir dir -> - return [ PackageTargetLocation (LocalUnpackedPackage dir) ] - - UserTargetLocalCabalFile file -> do - let dir = takeDirectory file - _ <- tryFindPackageDesc verbosity dir (localPackageError dir) -- just as a check - return [ PackageTargetLocation (LocalUnpackedPackage dir) ] - - UserTargetLocalTarball tarballFile -> - return [ PackageTargetLocation (LocalTarballPackage tarballFile) ] - - UserTargetRemoteTarball tarballURL -> - return [ PackageTargetLocation (RemoteTarballPackage tarballURL ()) ] - -localPackageError :: FilePath -> String -localPackageError dir = - "Error reading local package.\nCouldn't find .cabal file in: " ++ dir - --- ------------------------------------------------------------ --- * Fetching and reading package targets --- ------------------------------------------------------------ - - --- | Fetch any remote targets so that they can be read. --- -fetchPackageTarget :: Verbosity - -> RepoContext - -> PackageTarget (PackageLocation ()) - -> IO (PackageTarget ResolvedPkgLoc) -fetchPackageTarget verbosity repoCtxt = traverse $ - fetchPackage verbosity repoCtxt . fmap (const Nothing) - - --- | Given a package target that has been fetched, read the .cabal file. --- --- This only affects targets given by location, named targets are unaffected. --- -readPackageTarget :: Verbosity - -> PackageTarget ResolvedPkgLoc - -> IO (PackageTarget UnresolvedSourcePackage) -readPackageTarget verbosity = traverse modifyLocation - where - modifyLocation location = case location of - - LocalUnpackedPackage dir -> do - pkg <- tryFindPackageDesc verbosity dir (localPackageError dir) >>= - readGenericPackageDescription verbosity - return SourcePackage - { srcpkgPackageId = packageId pkg - , srcpkgDescription = pkg - , srcpkgSource = fmap Just location - , srcpkgDescrOverride = Nothing - } - - LocalTarballPackage tarballFile -> - readTarballPackageTarget location tarballFile tarballFile - - RemoteTarballPackage tarballURL tarballFile -> - readTarballPackageTarget location tarballFile (show tarballURL) - - RepoTarballPackage _repo _pkgid _ -> - error "TODO: readPackageTarget RepoTarballPackage" - -- For repo tarballs this info should be obtained from the index. - - RemoteSourceRepoPackage _srcRepo _ -> - error "TODO: readPackageTarget RemoteSourceRepoPackage" - -- This can't happen, because it would have errored out already - -- in fetchPackage, via fetchPackageTarget before it gets to this - -- function. - -- - -- When that is corrected, this will also need to be fixed. - - readTarballPackageTarget location tarballFile tarballOriginalLoc = do - (filename, content) <- extractTarballPackageCabalFile - tarballFile tarballOriginalLoc - case parsePackageDescription' content of - Nothing -> die' verbosity $ "Could not parse the cabal file " - ++ filename ++ " in " ++ tarballFile - Just pkg -> - return SourcePackage - { srcpkgPackageId = packageId pkg - , srcpkgDescription = pkg - , srcpkgSource = fmap Just location - , srcpkgDescrOverride = Nothing - } - - extractTarballPackageCabalFile :: FilePath -> String - -> IO (FilePath, BS.ByteString) - extractTarballPackageCabalFile tarballFile tarballOriginalLoc = - either (die' verbosity . formatErr) return - . check - . accumEntryMap - . Tar.filterEntries isCabalFile - . Tar.read - . GZipUtils.maybeDecompress - =<< BS.readFile tarballFile - where - formatErr msg = "Error reading " ++ tarballOriginalLoc ++ ": " ++ msg - - accumEntryMap = Tar.foldlEntries - (\m e -> Map.insert (Tar.entryTarPath e) e m) - Map.empty - - check (Left e) = Left (show e) - check (Right m) = case Map.elems m of - [] -> Left noCabalFile - [file] -> case Tar.entryContent file of - Tar.NormalFile content _ -> Right (Tar.entryPath file, content) - _ -> Left noCabalFile - _files -> Left multipleCabalFiles - where - noCabalFile = "No cabal file found" - multipleCabalFiles = "Multiple cabal files found" - - isCabalFile e = case splitPath (Tar.entryPath e) of - [ _dir, file] -> takeExtension file == ".cabal" - [".", _dir, file] -> takeExtension file == ".cabal" - _ -> False - - parsePackageDescription' :: BS.ByteString -> Maybe GenericPackageDescription - parsePackageDescription' bs = - parseGenericPackageDescriptionMaybe (BS.toStrict bs) - --- ------------------------------------------------------------ --- * Checking package targets --- ------------------------------------------------------------ - -data PackageTargetProblem - = PackageNameUnknown PackageName UserTarget - | PackageNameAmbiguous PackageName [PackageName] UserTarget - deriving Show - - --- | Users are allowed to give package names case-insensitively, so we must --- disambiguate named package references. --- -disambiguatePackageTargets :: Package pkg' - => PackageIndex pkg' - -> [PackageName] - -> [PackageTarget pkg] - -> ( [PackageTargetProblem] - , [PackageSpecifier pkg] ) -disambiguatePackageTargets availablePkgIndex availableExtra targets = - partitionEithers (map disambiguatePackageTarget targets) - where - disambiguatePackageTarget packageTarget = case packageTarget of - PackageTargetLocation pkg -> Right (SpecificSourcePackage pkg) - - PackageTargetNamed pkgname props userTarget - | null (PackageIndex.lookupPackageName availablePkgIndex pkgname) - -> Left (PackageNameUnknown pkgname userTarget) - | otherwise -> Right (NamedPackage pkgname props) - - PackageTargetNamedFuzzy pkgname props userTarget -> - case disambiguatePackageName packageNameEnv pkgname of - None -> Left (PackageNameUnknown - pkgname userTarget) - Ambiguous pkgnames -> Left (PackageNameAmbiguous - pkgname pkgnames userTarget) - Unambiguous pkgname' -> Right (NamedPackage pkgname' props) - - -- use any extra specific available packages to help us disambiguate - packageNameEnv :: PackageNameEnv - packageNameEnv = mappend (indexPackageNameEnv availablePkgIndex) - (extraPackageNameEnv availableExtra) - - --- | Report problems to the user. That is, if there are any problems --- then raise an exception. -reportPackageTargetProblems :: Verbosity - -> [PackageTargetProblem] -> IO () -reportPackageTargetProblems verbosity problems = do - case [ pkg | PackageNameUnknown pkg originalTarget <- problems - , not (isUserTagetWorld originalTarget) ] of - [] -> return () - pkgs -> die' verbosity $ unlines - [ "There is no package named '" ++ prettyShow name ++ "'. " - | name <- pkgs ] - ++ "You may need to run 'hackport update' to get the latest " - ++ "list of available packages." - - case [ (pkg, matches) | PackageNameAmbiguous pkg matches _ <- problems ] of - [] -> return () - ambiguities -> die' verbosity $ unlines - [ "There is no package named '" ++ prettyShow name ++ "'. " - ++ (if length matches > 1 - then "However, the following package names exist: " - else "However, the following package name exists: ") - ++ intercalate ", " [ "'" ++ prettyShow m ++ "'" | m <- matches] - ++ "." - | (name, matches) <- ambiguities ] - - case [ pkg | PackageNameUnknown pkg UserTargetWorld <- problems ] of - [] -> return () - pkgs -> warn verbosity $ - "The following 'world' packages will be ignored because " - ++ "they refer to packages that cannot be found: " - ++ intercalate ", " (map prettyShow pkgs) ++ "\n" - ++ "You can suppress this warning by correcting the world file." - where - isUserTagetWorld UserTargetWorld = True; isUserTagetWorld _ = False - - --- ------------------------------------------------------------ --- * Disambiguating package names --- ------------------------------------------------------------ - -data MaybeAmbiguous a = None | Unambiguous a | Ambiguous [a] - --- | Given a package name and a list of matching names, figure out --- which one it might be referring to. If there is an exact --- case-sensitive match then that's ok (i.e. returned via --- 'Unambiguous'). If it matches just one package case-insensitively --- or if it matches multiple packages case-insensitively, in that case --- the result is 'Ambiguous'. --- --- Note: Before cabal 2.2, when only a single package matched --- case-insensitively it would be considered 'Unambigious'. --- -disambiguatePackageName :: PackageNameEnv - -> PackageName - -> MaybeAmbiguous PackageName -disambiguatePackageName (PackageNameEnv pkgNameLookup) name = - case nub (pkgNameLookup name) of - [] -> None - names -> case find (name==) names of - Just name' -> Unambiguous name' - Nothing -> Ambiguous names - - -newtype PackageNameEnv = PackageNameEnv (PackageName -> [PackageName]) - -instance Monoid PackageNameEnv where - mempty = PackageNameEnv (const []) - mappend = (<>) - -instance Semigroup PackageNameEnv where - PackageNameEnv lookupA <> PackageNameEnv lookupB = - PackageNameEnv (\name -> lookupA name ++ lookupB name) - -indexPackageNameEnv :: PackageIndex pkg -> PackageNameEnv -indexPackageNameEnv pkgIndex = PackageNameEnv pkgNameLookup - where - pkgNameLookup pname = - map fst (PackageIndex.searchByName pkgIndex $ unPackageName pname) - -extraPackageNameEnv :: [PackageName] -> PackageNameEnv -extraPackageNameEnv names = PackageNameEnv pkgNameLookup - where - pkgNameLookup pname = - [ pname' - | let lname = lowercase (unPackageName pname) - , pname' <- names - , lowercase (unPackageName pname') == lname ] - - --- ------------------------------------------------------------ --- * Package constraints --- ------------------------------------------------------------ - --- | Version of 'Qualifier' that a user may specify on the --- command line. -data UserQualifier = - -- | Top-level dependency. - UserQualToplevel - - -- | Setup dependency. - | UserQualSetup PackageName - - -- | Executable dependency. - | UserQualExe PackageName PackageName - deriving (Eq, Show, Generic) - -instance Binary UserQualifier -instance Structured UserQualifier - --- | Version of 'ConstraintScope' that a user may specify on the --- command line. -data UserConstraintScope = - -- | 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 any qualifier. - | UserAnyQualifier PackageName - deriving (Eq, Show, Generic) - -instance Binary UserConstraintScope -instance Structured UserConstraintScope - -fromUserQualifier :: UserQualifier -> Qualifier -fromUserQualifier UserQualToplevel = QualToplevel -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 - --- | Version of 'PackageConstraint' that the user can specify on --- the command line. -data UserConstraint = - UserConstraint UserConstraintScope PackageProperty - deriving (Eq, Show, Generic) - -instance Binary UserConstraint -instance Structured UserConstraint - -userConstraintPackageName :: UserConstraint -> PackageName -userConstraintPackageName (UserConstraint scope _) = scopePN scope - where - scopePN (UserQualified _ pn) = pn - scopePN (UserAnyQualifier pn) = pn - scopePN (UserAnySetupQualifier pn) = pn - -userToPackageConstraint :: UserConstraint -> PackageConstraint -userToPackageConstraint (UserConstraint scope prop) = - PackageConstraint (fromUserConstraintScope scope) prop - -readUserConstraint :: String -> Either String UserConstraint -readUserConstraint str = - case explicitEitherParsec parsec str of - Left err -> Left $ msgCannotParse ++ err - Right c -> Right c - where - msgCannotParse = - "expected a (possibly qualified) package name followed by a " ++ - "constraint, which is either a version range, 'installed', " ++ - "'source', 'test', 'bench', or flags. " - -instance Pretty UserConstraint where - pretty (UserConstraint scope prop) = - dispPackageConstraint $ PackageConstraint (fromUserConstraintScope scope) prop - -instance Parsec UserConstraint where - parsec = do - scope <- parseConstraintScope - P.spaces - prop <- P.choice - [ PackagePropertyFlags <$> parsecFlagAssignmentNonEmpty -- headed by "+-" - , PackagePropertyVersion <$> parsec -- headed by "<=>" (will be) - , PackagePropertyInstalled <$ P.string "installed" - , PackagePropertySource <$ P.string "source" - , PackagePropertyStanzas [TestStanzas] <$ P.string "test" - , PackagePropertyStanzas [BenchStanzas] <$ P.string "bench" - ] - return (UserConstraint scope prop) - - where - parseConstraintScope :: forall m. CabalParsing m => m UserConstraintScope - parseConstraintScope = do - pn <- parsec - P.choice - [ P.char '.' *> withDot pn - , P.char ':' *> withColon pn - , return (UserQualified UserQualToplevel pn) - ] - where - withDot :: PackageName -> m UserConstraintScope - withDot pn - | pn == mkPackageName "any" = UserAnyQualifier <$> parsec - | pn == mkPackageName "setup" = UserAnySetupQualifier <$> parsec - | otherwise = P.unexpected $ "constraint scope: " ++ unPackageName pn - - withColon :: PackageName -> m UserConstraintScope - withColon pn = UserQualified (UserQualSetup pn) - <$ P.string "setup." - <*> parsec diff --git a/cabal/cabal-install/Distribution/Client/Types.hs b/cabal/cabal-install/Distribution/Client/Types.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Types.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Types --- Copyright : (c) David Himmelstrup 2005 --- Duncan Coutts 2011 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- Various common data types for the entire cabal-install system ------------------------------------------------------------------------------ -module Distribution.Client.Types ( - module Distribution.Client.Types.AllowNewer, - module Distribution.Client.Types.ConfiguredId, - module Distribution.Client.Types.ConfiguredPackage, - module Distribution.Client.Types.BuildResults, - module Distribution.Client.Types.PackageLocation, - module Distribution.Client.Types.PackageSpecifier, - module Distribution.Client.Types.ReadyPackage, - module Distribution.Client.Types.Repo, - module Distribution.Client.Types.RepoName, - module Distribution.Client.Types.SourcePackageDb, - module Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy, -) where - - -import Distribution.Client.Types.AllowNewer -import Distribution.Client.Types.BuildResults -import Distribution.Client.Types.ConfiguredId -import Distribution.Client.Types.ConfiguredPackage -import Distribution.Client.Types.PackageLocation -import Distribution.Client.Types.PackageSpecifier -import Distribution.Client.Types.Repo -import Distribution.Client.Types.RepoName -import Distribution.Client.Types.ReadyPackage -import Distribution.Client.Types.SourcePackageDb -import Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy diff --git a/cabal/cabal-install/Distribution/Client/Types/AllowNewer.hs b/cabal/cabal-install/Distribution/Client/Types/AllowNewer.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Types/AllowNewer.hs +++ /dev/null @@ -1,241 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Client.Types.AllowNewer ( - AllowNewer (..), - AllowOlder (..), - RelaxDeps (..), - mkRelaxDepSome, - RelaxDepMod (..), - RelaxDepScope (..), - RelaxDepSubject (..), - RelaxedDep (..), - isRelaxDeps, -) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Parsec (parsecLeadingCommaNonEmpty) -import Distribution.Types.PackageId (PackageId, PackageIdentifier (..)) -import Distribution.Types.PackageName (PackageName, mkPackageName) -import Distribution.Types.Version (nullVersion) - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - --- $setup --- >>> import Distribution.Parsec - --- TODO: When https://github.com/haskell/cabal/issues/4203 gets tackled, --- it may make sense to move these definitions to the Solver.Types --- module - --- | 'RelaxDeps' in the context of upper bounds (i.e. for @--allow-newer@ flag) -newtype AllowNewer = AllowNewer { unAllowNewer :: RelaxDeps } - deriving (Eq, Read, Show, Generic) - --- | 'RelaxDeps' in the context of lower bounds (i.e. for @--allow-older@ flag) -newtype AllowOlder = AllowOlder { unAllowOlder :: RelaxDeps } - deriving (Eq, Read, Show, Generic) - --- | Generic data type for policy when relaxing bounds in dependencies. --- Don't use this directly: use 'AllowOlder' or 'AllowNewer' depending --- on whether or not you are relaxing an lower or upper bound --- (respectively). -data RelaxDeps = - - -- | Ignore upper (resp. lower) bounds in some (or no) dependencies on the given packages. - -- - -- @RelaxDepsSome []@ is the default, i.e. honor the bounds in all - -- dependencies, never choose versions newer (resp. older) than allowed. - RelaxDepsSome [RelaxedDep] - - -- | Ignore upper (resp. lower) bounds in dependencies on all packages. - -- - -- __Note__: This is should be semantically equivalent to - -- - -- > RelaxDepsSome [RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll] - -- - -- (TODO: consider normalising 'RelaxDeps' and/or 'RelaxedDep') - | RelaxDepsAll - deriving (Eq, Read, Show, Generic) - --- | Dependencies can be relaxed either for all packages in the install plan, or --- only for some packages. -data RelaxedDep = RelaxedDep !RelaxDepScope !RelaxDepMod !RelaxDepSubject - deriving (Eq, Read, Show, Generic) - --- | Specify the scope of a relaxation, i.e. limit which depending --- packages are allowed to have their version constraints relaxed. -data RelaxDepScope = RelaxDepScopeAll - -- ^ Apply relaxation in any package - | RelaxDepScopePackage !PackageName - -- ^ Apply relaxation to in all versions of a package - | RelaxDepScopePackageId !PackageId - -- ^ Apply relaxation to a specific version of a package only - deriving (Eq, Read, Show, Generic) - --- | Modifier for dependency relaxation -data RelaxDepMod = RelaxDepModNone -- ^ Default semantics - | RelaxDepModCaret -- ^ Apply relaxation only to @^>=@ constraints - deriving (Eq, Read, Show, Generic) - --- | Express whether to relax bounds /on/ @all@ packages, or a single package -data RelaxDepSubject = RelaxDepSubjectAll - | RelaxDepSubjectPkg !PackageName - deriving (Eq, Ord, Read, Show, Generic) - -instance Pretty RelaxedDep where - pretty (RelaxedDep scope rdmod subj) = case scope of - RelaxDepScopeAll -> Disp.text "*:" Disp.<> modDep - RelaxDepScopePackage p0 -> pretty p0 Disp.<> Disp.colon Disp.<> modDep - RelaxDepScopePackageId p0 -> pretty p0 Disp.<> Disp.colon Disp.<> modDep - where - modDep = case rdmod of - RelaxDepModNone -> pretty subj - RelaxDepModCaret -> Disp.char '^' Disp.<> pretty subj - -instance Parsec RelaxedDep where - parsec = P.char '*' *> relaxedDepStarP <|> (parsec >>= relaxedDepPkgidP) - --- continuation after * -relaxedDepStarP :: CabalParsing m => m RelaxedDep -relaxedDepStarP = - RelaxedDep RelaxDepScopeAll <$ P.char ':' <*> modP <*> parsec - <|> pure (RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll) - --- continuation after package identifier -relaxedDepPkgidP :: CabalParsing m => PackageIdentifier -> m RelaxedDep -relaxedDepPkgidP pid@(PackageIdentifier pn v) - | pn == mkPackageName "all" - , v == nullVersion - = RelaxedDep RelaxDepScopeAll <$ P.char ':' <*> modP <*> parsec - <|> pure (RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll) - - | v == nullVersion - = RelaxedDep (RelaxDepScopePackage pn) <$ P.char ':' <*> modP <*> parsec - <|> pure (RelaxedDep RelaxDepScopeAll RelaxDepModNone (RelaxDepSubjectPkg pn)) - - | otherwise - = RelaxedDep (RelaxDepScopePackageId pid) <$ P.char ':' <*> modP <*> parsec - -modP :: P.CharParsing m => m RelaxDepMod -modP = RelaxDepModCaret <$ P.char '^' <|> pure RelaxDepModNone - -instance Pretty RelaxDepSubject where - pretty RelaxDepSubjectAll = Disp.text "*" - pretty (RelaxDepSubjectPkg pn) = pretty pn - -instance Parsec RelaxDepSubject where - parsec = RelaxDepSubjectAll <$ P.char '*' <|> pkgn - where - pkgn = do - pn <- parsec - pure $ if pn == mkPackageName "all" - then RelaxDepSubjectAll - else RelaxDepSubjectPkg pn - -instance Pretty RelaxDeps where - pretty rd | not (isRelaxDeps rd) = Disp.text "none" - pretty (RelaxDepsSome pkgs) = Disp.fsep . - Disp.punctuate Disp.comma . - map pretty $ pkgs - pretty RelaxDepsAll = Disp.text "all" - --- | --- --- >>> simpleParsec "all" :: Maybe RelaxDeps --- Just RelaxDepsAll --- --- >>> simpleParsec "none" :: Maybe RelaxDeps --- Just (RelaxDepsSome []) --- --- >>> simpleParsec "*, *" :: Maybe RelaxDeps --- Just RelaxDepsAll --- --- >>> simpleParsec "*:*" :: Maybe RelaxDeps --- Just RelaxDepsAll --- --- >>> simpleParsec "foo:bar, quu:puu" :: Maybe RelaxDeps --- Just (RelaxDepsSome [RelaxedDep (RelaxDepScopePackage (PackageName "foo")) RelaxDepModNone (RelaxDepSubjectPkg (PackageName "bar")),RelaxedDep (RelaxDepScopePackage (PackageName "quu")) RelaxDepModNone (RelaxDepSubjectPkg (PackageName "puu"))]) --- --- This is not a glitch, even it looks like: --- --- >>> simpleParsec ", all" :: Maybe RelaxDeps --- Just RelaxDepsAll --- --- >>> simpleParsec "" :: Maybe RelaxDeps --- Nothing --- -instance Parsec RelaxDeps where - parsec = do - xs <- parsecLeadingCommaNonEmpty parsec - pure $ case toList xs of - [RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll] - -> RelaxDepsAll - [RelaxedDep RelaxDepScopeAll RelaxDepModNone (RelaxDepSubjectPkg pn)] - | pn == mkPackageName "none" - -> mempty - xs' -> mkRelaxDepSome xs' - -instance Binary RelaxDeps -instance Binary RelaxDepMod -instance Binary RelaxDepScope -instance Binary RelaxDepSubject -instance Binary RelaxedDep -instance Binary AllowNewer -instance Binary AllowOlder - -instance Structured RelaxDeps -instance Structured RelaxDepMod -instance Structured RelaxDepScope -instance Structured RelaxDepSubject -instance Structured RelaxedDep -instance Structured AllowNewer -instance Structured AllowOlder - --- | Return 'True' if 'RelaxDeps' specifies a non-empty set of relaxations --- --- Equivalent to @isRelaxDeps = (/= 'mempty')@ -isRelaxDeps :: RelaxDeps -> Bool -isRelaxDeps (RelaxDepsSome []) = False -isRelaxDeps (RelaxDepsSome (_:_)) = True -isRelaxDeps RelaxDepsAll = True - --- | A smarter 'RelaxedDepsSome', @*:*@ is the same as @all@. -mkRelaxDepSome :: [RelaxedDep] -> RelaxDeps -mkRelaxDepSome xs - | any (== RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll) xs - = RelaxDepsAll - - | otherwise - = RelaxDepsSome xs - --- | 'RelaxDepsAll' is the /absorbing element/ -instance Semigroup RelaxDeps where - -- identity element - RelaxDepsSome [] <> r = r - l@(RelaxDepsSome _) <> RelaxDepsSome [] = l - -- absorbing element - l@RelaxDepsAll <> _ = l - (RelaxDepsSome _) <> r@RelaxDepsAll = r - -- combining non-{identity,absorbing} elements - (RelaxDepsSome a) <> (RelaxDepsSome b) = RelaxDepsSome (a ++ b) - --- | @'RelaxDepsSome' []@ is the /identity element/ -instance Monoid RelaxDeps where - mempty = RelaxDepsSome [] - mappend = (<>) - -instance Semigroup AllowNewer where - AllowNewer x <> AllowNewer y = AllowNewer (x <> y) - -instance Semigroup AllowOlder where - AllowOlder x <> AllowOlder y = AllowOlder (x <> y) - -instance Monoid AllowNewer where - mempty = AllowNewer mempty - mappend = (<>) - -instance Monoid AllowOlder where - mempty = AllowOlder mempty - mappend = (<>) diff --git a/cabal/cabal-install/Distribution/Client/Types/BuildResults.hs b/cabal/cabal-install/Distribution/Client/Types/BuildResults.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Types/BuildResults.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Client.Types.BuildResults ( - BuildOutcome, - BuildOutcomes, - BuildFailure (..), - BuildResult (..), - TestsResult (..), - DocsResult (..), -) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Types.InstalledPackageInfo (InstalledPackageInfo) -import Distribution.Types.PackageId (PackageId) -import Distribution.Types.UnitId (UnitId) - --- | A summary of the outcome for building a single package. --- -type BuildOutcome = Either BuildFailure BuildResult - --- | A summary of the outcome for building a whole set of packages. --- -type BuildOutcomes = Map UnitId BuildOutcome - -data BuildFailure = PlanningFailed - | DependentFailed PackageId - | DownloadFailed SomeException - | UnpackFailed SomeException - | ConfigureFailed SomeException - | BuildFailed SomeException - | TestsFailed SomeException - | InstallFailed SomeException - deriving (Show, Typeable, Generic) - -instance Exception BuildFailure - --- Note that the @Maybe InstalledPackageInfo@ is a slight hack: we only --- the public library's 'InstalledPackageInfo' is stored here, even if --- there were 'InstalledPackageInfo' from internal libraries. This --- 'InstalledPackageInfo' is not used anyway, so it makes no difference. -data BuildResult = BuildResult DocsResult TestsResult - (Maybe InstalledPackageInfo) - deriving (Show, Generic) - -data DocsResult = DocsNotTried | DocsFailed | DocsOk - deriving (Show, Generic, Typeable) -data TestsResult = TestsNotTried | TestsOk - deriving (Show, Generic, Typeable) - -instance Binary BuildFailure -instance Binary BuildResult -instance Binary DocsResult -instance Binary TestsResult - -instance Structured BuildFailure -instance Structured BuildResult -instance Structured DocsResult -instance Structured TestsResult diff --git a/cabal/cabal-install/Distribution/Client/Types/ConfiguredId.hs b/cabal/cabal-install/Distribution/Client/Types/ConfiguredId.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Types/ConfiguredId.hs +++ /dev/null @@ -1,83 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Client.Types.ConfiguredId ( - InstalledPackageId, - ConfiguredId (..), - annotatedIdToConfiguredId, - HasConfiguredId (..), -) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.InstalledPackageInfo (InstalledPackageInfo, sourceComponentName, installedComponentId) -import Distribution.Package (Package (..)) -import Distribution.Types.AnnotatedId (AnnotatedId (..)) -import Distribution.Types.ComponentId (ComponentId) -import Distribution.Types.ComponentName (ComponentName) -import Distribution.Types.PackageId (PackageId) - -------------------------------------------------------------------------------- --- InstalledPackageId -------------------------------------------------------------------------------- - --- | Within Cabal the library we no longer have a @InstalledPackageId@ type. --- That's because it deals with the compilers' notion of a registered library, --- and those really are libraries not packages. Those are now named units. --- --- The package management layer does however deal with installed packages, as --- whole packages not just as libraries. So we do still need a type for --- installed package ids. At the moment however we track instaled packages via --- their primary library, which is a unit id. In future this may change --- slightly and we may distinguish these two types and have an explicit --- conversion when we register units with the compiler. --- -type InstalledPackageId = ComponentId - -------------------------------------------------------------------------------- --- ConfiguredId -------------------------------------------------------------------------------- - --- | A ConfiguredId is a package ID for a configured package. --- --- Once we configure a source package we know its UnitId. It is still --- however useful in lots of places to also know the source ID for the package. --- We therefore bundle the two. --- --- An already installed package of course is also "configured" (all its --- configuration parameters and dependencies have been specified). -data ConfiguredId = ConfiguredId { - confSrcId :: PackageId - , confCompName :: Maybe ComponentName - , confInstId :: ComponentId - } - deriving (Eq, Ord, Generic) - -annotatedIdToConfiguredId :: AnnotatedId ComponentId -> ConfiguredId -annotatedIdToConfiguredId aid = ConfiguredId { - confSrcId = ann_pid aid, - confCompName = Just (ann_cname aid), - confInstId = ann_id aid - } - -instance Binary ConfiguredId -instance Structured ConfiguredId - -instance Show ConfiguredId where - show cid = show (confInstId cid) - -instance Package ConfiguredId where - packageId = confSrcId - -------------------------------------------------------------------------------- --- HasConfiguredId class -------------------------------------------------------------------------------- - -class HasConfiguredId a where - configuredId :: a -> ConfiguredId - --- NB: This instance is slightly dangerous, in that you'll lose --- information about the specific UnitId you depended on. -instance HasConfiguredId InstalledPackageInfo where - configuredId ipkg = ConfiguredId (packageId ipkg) - (Just (sourceComponentName ipkg)) - (installedComponentId ipkg) diff --git a/cabal/cabal-install/Distribution/Client/Types/ConfiguredPackage.hs b/cabal/cabal-install/Distribution/Client/Types/ConfiguredPackage.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Types/ConfiguredPackage.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TypeFamilies #-} -module Distribution.Client.Types.ConfiguredPackage ( - ConfiguredPackage (..), -) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Compat.Graph (IsNode (..)) -import Distribution.Package (newSimpleUnitId, HasMungedPackageId (..), HasUnitId (..), Package (..), PackageInstalled (..), UnitId) -import Distribution.Types.Flag (FlagAssignment) -import Distribution.Types.ComponentName -import Distribution.Types.LibraryName (LibraryName (..)) -import Distribution.Types.MungedPackageId (computeCompatPackageId) -import Distribution.Simple.Utils (ordNub) - -import Distribution.Client.Types.ConfiguredId -import Distribution.Solver.Types.OptionalStanza (OptionalStanza) -import Distribution.Solver.Types.PackageFixedDeps -import Distribution.Solver.Types.SourcePackage (SourcePackage) - -import qualified Distribution.Solver.Types.ComponentDeps as CD - --- | A 'ConfiguredPackage' is a not-yet-installed package along with the --- total configuration information. The configuration information is total in --- the sense that it provides all the configuration information and so the --- final configure process will be independent of the environment. --- --- 'ConfiguredPackage' is assumed to not support Backpack. Only the --- @v2-build@ codepath supports Backpack. --- -data ConfiguredPackage loc = ConfiguredPackage - { confPkgId :: InstalledPackageId - , confPkgSource :: SourcePackage loc -- ^ package info, including repo - , confPkgFlags :: FlagAssignment -- ^ complete flag assignment for the package - , confPkgStanzas :: [OptionalStanza] -- ^ list of enabled optional stanzas for the package - , confPkgDeps :: CD.ComponentDeps [ConfiguredId] - -- ^ set of exact dependencies (installed or source). - -- - -- These must be consistent with the 'buildDepends' - -- in the 'PackageDescription' that you'd get by - -- applying the flag assignment and optional stanzas. - } - deriving (Eq, Show, Generic) - --- | 'HasConfiguredId' indicates data types which have a 'ConfiguredId'. --- This type class is mostly used to conveniently finesse between --- 'ElaboratedPackage' and 'ElaboratedComponent'. --- -instance HasConfiguredId (ConfiguredPackage loc) where - configuredId pkg = ConfiguredId (packageId pkg) (Just (CLibName LMainLibName)) (confPkgId pkg) - --- 'ConfiguredPackage' is the legacy codepath, we are guaranteed --- to never have a nontrivial 'UnitId' -instance PackageFixedDeps (ConfiguredPackage loc) where - depends = fmap (map (newSimpleUnitId . confInstId)) . confPkgDeps - -instance IsNode (ConfiguredPackage loc) where - type Key (ConfiguredPackage loc) = UnitId - nodeKey = newSimpleUnitId . confPkgId - -- 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 - -instance (Binary loc) => Binary (ConfiguredPackage loc) - - - - -instance Package (ConfiguredPackage loc) where - packageId cpkg = packageId (confPkgSource cpkg) - -instance HasMungedPackageId (ConfiguredPackage loc) where - mungedId cpkg = computeCompatPackageId (packageId cpkg) LMainLibName - --- Never has nontrivial UnitId -instance HasUnitId (ConfiguredPackage loc) where - installedUnitId = newSimpleUnitId . confPkgId - -instance PackageInstalled (ConfiguredPackage loc) where - installedDepends = CD.flatDeps . depends - - - diff --git a/cabal/cabal-install/Distribution/Client/Types/Credentials.hs b/cabal/cabal-install/Distribution/Client/Types/Credentials.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Types/Credentials.hs +++ /dev/null @@ -1,9 +0,0 @@ -module Distribution.Client.Types.Credentials ( - Username (..), - Password (..), -) where - -import Prelude (String) - -newtype Username = Username { unUsername :: String } -newtype Password = Password { unPassword :: String } diff --git a/cabal/cabal-install/Distribution/Client/Types/InstallMethod.hs b/cabal/cabal-install/Distribution/Client/Types/InstallMethod.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Types/InstallMethod.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Client.Types.InstallMethod where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as PP - -data InstallMethod - = InstallMethodCopy - | InstallMethodSymlink - deriving (Eq, Show, Generic, Bounded, Enum) - -instance Binary InstallMethod -instance Structured InstallMethod - --- | Last -instance Semigroup InstallMethod where - _ <> x = x - -instance Parsec InstallMethod where - parsec = do - name <- P.munch1 isAlpha - case name of - "copy" -> pure InstallMethodCopy - "symlink" -> pure InstallMethodSymlink - _ -> P.unexpected $ "InstallMethod: " ++ name - -instance Pretty InstallMethod where - pretty InstallMethodCopy = PP.text "copy" - pretty InstallMethodSymlink = PP.text "symlink" diff --git a/cabal/cabal-install/Distribution/Client/Types/OverwritePolicy.hs b/cabal/cabal-install/Distribution/Client/Types/OverwritePolicy.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Types/OverwritePolicy.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Client.Types.OverwritePolicy where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as PP - -data OverwritePolicy - = NeverOverwrite - | AlwaysOverwrite - deriving (Show, Eq, Generic, Bounded, Enum) - -instance Binary OverwritePolicy -instance Structured OverwritePolicy - -instance Parsec OverwritePolicy where - parsec = do - name <- P.munch1 isAlpha - case name of - "always" -> pure AlwaysOverwrite - "never" -> pure NeverOverwrite - _ -> P.unexpected $ "OverwritePolicy: " ++ name - -instance Pretty OverwritePolicy where - pretty NeverOverwrite = PP.text "never" - pretty AlwaysOverwrite = PP.text "always" diff --git a/cabal/cabal-install/Distribution/Client/Types/PackageLocation.hs b/cabal/cabal-install/Distribution/Client/Types/PackageLocation.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Types/PackageLocation.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Client.Types.PackageLocation ( - PackageLocation (..), - UnresolvedPkgLoc, - ResolvedPkgLoc, - UnresolvedSourcePackage, -) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Network.URI (URI) - -import Distribution.Types.PackageId (PackageId) - -import Distribution.Client.Types.Repo -import Distribution.Client.Types.SourceRepo (SourceRepoMaybe) -import Distribution.Solver.Types.SourcePackage (SourcePackage) - -type UnresolvedPkgLoc = PackageLocation (Maybe FilePath) - -type ResolvedPkgLoc = PackageLocation FilePath - -data PackageLocation local = - - -- | An unpacked package in the given dir, or current dir - LocalUnpackedPackage FilePath - - -- | A package as a tarball that's available as a local tarball - | LocalTarballPackage FilePath - - -- | A package as a tarball from a remote URI - | RemoteTarballPackage URI local - - -- | A package available as a tarball from a repository. - -- - -- It may be from a local repository or from a remote repository, with a - -- locally cached copy. ie a package available from hackage - | RepoTarballPackage Repo PackageId local - - -- | A package available from a version control system source repository - | RemoteSourceRepoPackage SourceRepoMaybe local - deriving (Show, Functor, Eq, Ord, Generic, Typeable) - -instance Binary local => Binary (PackageLocation local) -instance Structured local => Structured (PackageLocation local) - --- | Convenience alias for 'SourcePackage UnresolvedPkgLoc'. -type UnresolvedSourcePackage = SourcePackage UnresolvedPkgLoc diff --git a/cabal/cabal-install/Distribution/Client/Types/PackageSpecifier.hs b/cabal/cabal-install/Distribution/Client/Types/PackageSpecifier.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Types/PackageSpecifier.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Client.Types.PackageSpecifier ( - PackageSpecifier (..), - pkgSpecifierTarget, - pkgSpecifierConstraints, -) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Package (Package (..), packageName, packageVersion) -import Distribution.Types.PackageName (PackageName) -import Distribution.Version (thisVersion) - -import Distribution.Solver.Types.ConstraintSource -import Distribution.Solver.Types.LabeledPackageConstraint -import Distribution.Solver.Types.PackageConstraint - --- | A fully or partially resolved reference to a package. --- -data PackageSpecifier pkg = - - -- | A partially specified reference to a package (either source or - -- installed). It is specified by package name and optionally some - -- required properties. Use a dependency resolver to pick a specific - -- package satisfying these properties. - -- - NamedPackage PackageName [PackageProperty] - - -- | A fully specified source package. - -- - | SpecificSourcePackage pkg - deriving (Eq, Show, Functor, Generic) - -instance Binary pkg => Binary (PackageSpecifier pkg) -instance Structured pkg => Structured (PackageSpecifier pkg) - -pkgSpecifierTarget :: Package pkg => PackageSpecifier pkg -> PackageName -pkgSpecifierTarget (NamedPackage name _) = name -pkgSpecifierTarget (SpecificSourcePackage pkg) = packageName pkg - -pkgSpecifierConstraints :: Package pkg - => PackageSpecifier pkg -> [LabeledPackageConstraint] -pkgSpecifierConstraints (NamedPackage name props) = map toLpc props - where - toLpc prop = LabeledPackageConstraint - (PackageConstraint (scopeToplevel name) prop) - ConstraintSourceUserTarget -pkgSpecifierConstraints (SpecificSourcePackage pkg) = - [LabeledPackageConstraint pc ConstraintSourceUserTarget] - where - pc = PackageConstraint - (ScopeTarget $ packageName pkg) - (PackagePropertyVersion $ thisVersion (packageVersion pkg)) diff --git a/cabal/cabal-install/Distribution/Client/Types/ReadyPackage.hs b/cabal/cabal-install/Distribution/Client/Types/ReadyPackage.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Types/ReadyPackage.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -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.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/cabal-install/Distribution/Client/Types/Repo.hs b/cabal/cabal-install/Distribution/Client/Types/Repo.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Types/Repo.hs +++ /dev/null @@ -1,184 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Client.Types.Repo ( - -- * Remote repository - RemoteRepo (..), - emptyRemoteRepo, - -- * Local repository (no-index) - LocalRepo (..), - emptyLocalRepo, - localRepoCacheKey, - -- * Repository - Repo (..), - isRepoRemote, - maybeRepoRemote, -) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Network.URI (URI (..), nullURI, parseAbsoluteURI, uriToString) - -import Distribution.Simple.Utils (toUTF8BS) - -import Distribution.Client.HashValue (hashValue, showHashValue, truncateHash) - -import qualified Data.ByteString.Lazy.Char8 as LBS -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - -import Distribution.Client.Types.RepoName - -------------------------------------------------------------------------------- --- Remote repository -------------------------------------------------------------------------------- - -data RemoteRepo = - RemoteRepo { - remoteRepoName :: RepoName, - remoteRepoURI :: URI, - - -- | Enable secure access? - -- - -- 'Nothing' here represents "whatever the default is"; this is important - -- to allow for a smooth transition from opt-in to opt-out security - -- (once we switch to opt-out, all access to the central Hackage - -- repository should be secure by default) - remoteRepoSecure :: Maybe Bool, - - -- | Root key IDs (for bootstrapping) - remoteRepoRootKeys :: [String], - - -- | Threshold for verification during bootstrapping - remoteRepoKeyThreshold :: Int, - - -- | Normally a repo just specifies an HTTP or HTTPS URI, but as a - -- special case we may know a repo supports both and want to try HTTPS - -- if we can, but still allow falling back to HTTP. - -- - -- This field is not currently stored in the config file, but is filled - -- in automagically for known repos. - remoteRepoShouldTryHttps :: Bool - } - - deriving (Show, Eq, Ord, Generic) - -instance Binary RemoteRepo -instance Structured RemoteRepo - -instance Pretty RemoteRepo where - pretty r = - pretty (remoteRepoName r) <<>> Disp.colon <<>> - Disp.text (uriToString id (remoteRepoURI r) []) - --- | Note: serialised format represends 'RemoteRepo' only partially. -instance Parsec RemoteRepo where - parsec = do - name <- parsec - _ <- P.char ':' - uriStr <- P.munch1 (\c -> isAlphaNum c || c `elem` ("+-=._/*()@'$:;&!?~" :: String)) - uri <- maybe (fail $ "Cannot parse URI:" ++ uriStr) return (parseAbsoluteURI uriStr) - return RemoteRepo - { remoteRepoName = name - , remoteRepoURI = uri - , remoteRepoSecure = Nothing - , remoteRepoRootKeys = [] - , remoteRepoKeyThreshold = 0 - , remoteRepoShouldTryHttps = False - } - --- | Construct a partial 'RemoteRepo' value to fold the field parser list over. -emptyRemoteRepo :: RepoName -> RemoteRepo -emptyRemoteRepo name = RemoteRepo name nullURI Nothing [] 0 False - -------------------------------------------------------------------------------- --- Local repository -------------------------------------------------------------------------------- - --- | /no-index/ style local repositories. --- --- https://github.com/haskell/cabal/issues/6359 -data LocalRepo = LocalRepo - { localRepoName :: RepoName - , localRepoPath :: FilePath - , localRepoSharedCache :: Bool - } - deriving (Show, Eq, Ord, Generic) - -instance Binary LocalRepo -instance Structured LocalRepo - --- | Note: doesn't parse 'localRepoSharedCache' field. -instance Parsec LocalRepo where - parsec = do - n <- parsec - _ <- P.char ':' - p <- P.munch1 (const True) -- restrict what can be a path? - return (LocalRepo n p False) - -instance Pretty LocalRepo where - pretty (LocalRepo n p _) = pretty n <<>> Disp.colon <<>> Disp.text p - --- | Construct a partial 'LocalRepo' value to fold the field parser list over. -emptyLocalRepo :: RepoName -> LocalRepo -emptyLocalRepo name = LocalRepo name "" False - --- | Calculate a cache key for local-repo. --- --- For remote repositories we just use name, but local repositories may --- all be named "local", so we add a bit of `localRepoPath` into the --- mix. -localRepoCacheKey :: LocalRepo -> String -localRepoCacheKey local = unRepoName (localRepoName local) ++ "-" ++ hashPart where - hashPart - = showHashValue $ truncateHash 8 $ hashValue - $ LBS.fromStrict $ toUTF8BS $ localRepoPath local - -------------------------------------------------------------------------------- --- Any repository -------------------------------------------------------------------------------- - --- | Different kinds of repositories --- --- NOTE: It is important that this type remains serializable. -data Repo - -- | Local repository, without index. - -- - -- https://github.com/haskell/cabal/issues/6359 - = RepoLocalNoIndex - { repoLocal :: LocalRepo - , repoLocalDir :: FilePath - } - - -- | Standard (unsecured) remote repositores - | RepoRemote { - repoRemote :: RemoteRepo - , repoLocalDir :: FilePath - } - - -- | Secure repositories - -- - -- Although this contains the same fields as 'RepoRemote', we use a separate - -- constructor to avoid confusing the two. - -- - -- Not all access to a secure repo goes through the hackage-security - -- library currently; code paths that do not still make use of the - -- 'repoRemote' and 'repoLocalDir' fields directly. - | RepoSecure { - repoRemote :: RemoteRepo - , repoLocalDir :: FilePath - } - deriving (Show, Eq, Ord, Generic) - -instance Binary Repo -instance Structured Repo - --- | Check if this is a remote repo -isRepoRemote :: Repo -> Bool -isRepoRemote RepoLocalNoIndex{} = False -isRepoRemote _ = True - --- | Extract @RemoteRepo@ from @Repo@ if remote. -maybeRepoRemote :: Repo -> Maybe RemoteRepo -maybeRepoRemote (RepoLocalNoIndex _ _localDir) = Nothing -maybeRepoRemote (RepoRemote r _localDir) = Just r -maybeRepoRemote (RepoSecure r _localDir) = Just r diff --git a/cabal/cabal-install/Distribution/Client/Types/RepoName.hs b/cabal/cabal-install/Distribution/Client/Types/RepoName.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Types/RepoName.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Client.Types.RepoName ( - RepoName (..), - unRepoName, -) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - --- $setup --- >>> import Distribution.Parsec - --- | Repository name. --- --- May be used as path segment. --- -newtype RepoName = RepoName String - deriving (Show, Eq, Ord, Generic) - -unRepoName :: RepoName -> String -unRepoName (RepoName n) = n - -instance Binary RepoName -instance Structured RepoName -instance NFData RepoName - -instance Pretty RepoName where - pretty = Disp.text . unRepoName - --- | --- --- >>> simpleParsec "hackage.haskell.org" :: Maybe RepoName --- Just (RepoName "hackage.haskell.org") --- --- >>> simpleParsec "0123" :: Maybe RepoName --- Nothing --- -instance Parsec RepoName where - parsec = RepoName <$> parser where - parser = (:) <$> lead <*> rest - lead = P.satisfy (\c -> isAlpha c || c == '_' || c == '-' || c == '.') - rest = P.munch (\c -> isAlphaNum c || c == '_' || c == '-' || c == '.') diff --git a/cabal/cabal-install/Distribution/Client/Types/SourcePackageDb.hs b/cabal/cabal-install/Distribution/Client/Types/SourcePackageDb.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Types/SourcePackageDb.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Client.Types.SourcePackageDb ( - SourcePackageDb (..), -) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Types.PackageName (PackageName) -import Distribution.Types.VersionRange (VersionRange) - -import Distribution.Client.Types.PackageLocation (UnresolvedSourcePackage) -import Distribution.Solver.Types.PackageIndex (PackageIndex) - --- | This is the information we get from a @00-index.tar.gz@ hackage index. --- -data SourcePackageDb = SourcePackageDb - { packageIndex :: PackageIndex UnresolvedSourcePackage - , packagePreferences :: Map PackageName VersionRange - } - deriving (Eq, Generic) - -instance Binary SourcePackageDb diff --git a/cabal/cabal-install/Distribution/Client/Types/SourceRepo.hs b/cabal/cabal-install/Distribution/Client/Types/SourceRepo.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Types/SourceRepo.hs +++ /dev/null @@ -1,108 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE UndecidableInstances #-} -module Distribution.Client.Types.SourceRepo ( - SourceRepositoryPackage (..), - SourceRepoList, - SourceRepoMaybe, - SourceRepoProxy, - srpHoist, - srpToProxy, - srpFanOut, - sourceRepositoryPackageGrammar, -) where - -import Distribution.Client.Compat.Prelude -import Distribution.Compat.Lens (Lens, Lens') -import Prelude () - -import Distribution.FieldGrammar -import Distribution.Types.SourceRepo (RepoType (..)) - --- | @source-repository-package@ definition --- -data SourceRepositoryPackage f = SourceRepositoryPackage - { srpType :: !RepoType - , srpLocation :: !String - , srpTag :: !(Maybe String) - , srpBranch :: !(Maybe String) - , srpSubdir :: !(f FilePath) - } - deriving (Generic) - -deriving instance (Eq (f FilePath)) => Eq (SourceRepositoryPackage f) -deriving instance (Ord (f FilePath)) => Ord (SourceRepositoryPackage f) -deriving instance (Show (f FilePath)) => Show (SourceRepositoryPackage f) -deriving instance (Binary (f FilePath)) => Binary (SourceRepositoryPackage f) -deriving instance (Typeable f, Structured (f FilePath)) => Structured (SourceRepositoryPackage f) - --- | Read from @cabal.project@ -type SourceRepoList = SourceRepositoryPackage [] - --- | Distilled from 'Distribution.Types.SourceRepo.SourceRepo' -type SourceRepoMaybe = SourceRepositoryPackage Maybe - --- | 'SourceRepositoryPackage' without subdir. Used in clone errors. Cloning doesn't care about subdirectory. -type SourceRepoProxy = SourceRepositoryPackage Proxy - -srpHoist :: (forall x. f x -> g x) -> SourceRepositoryPackage f -> SourceRepositoryPackage g -srpHoist nt s = s { srpSubdir = nt (srpSubdir s) } - -srpToProxy :: SourceRepositoryPackage f -> SourceRepositoryPackage Proxy -srpToProxy s = s { srpSubdir = Proxy } - --- | Split single @source-repository-package@ declaration with multiple subdirs, --- into multiple ones with at most single subdir. -srpFanOut :: SourceRepositoryPackage [] -> NonEmpty (SourceRepositoryPackage Maybe) -srpFanOut s@SourceRepositoryPackage { srpSubdir = [] } = - s { srpSubdir = Nothing } :| [] -srpFanOut s@SourceRepositoryPackage { srpSubdir = d:ds } = f d :| map f ds where - f subdir = s { srpSubdir = Just subdir } - -------------------------------------------------------------------------------- --- Lens -------------------------------------------------------------------------------- - -srpTypeLens :: Lens' (SourceRepositoryPackage f) RepoType -srpTypeLens f s = fmap (\x -> s { srpType = x }) (f (srpType s)) -{-# INLINE srpTypeLens #-} - -srpLocationLens :: Lens' (SourceRepositoryPackage f) String -srpLocationLens f s = fmap (\x -> s { srpLocation = x }) (f (srpLocation s)) -{-# INLINE srpLocationLens #-} - -srpTagLens :: Lens' (SourceRepositoryPackage f) (Maybe String) -srpTagLens f s = fmap (\x -> s { srpTag = x }) (f (srpTag s)) -{-# INLINE srpTagLens #-} - -srpBranchLens :: Lens' (SourceRepositoryPackage f) (Maybe String) -srpBranchLens f s = fmap (\x -> s { srpBranch = x }) (f (srpBranch s)) -{-# INLINE srpBranchLens #-} - -srpSubdirLens :: Lens (SourceRepositoryPackage f) (SourceRepositoryPackage g) (f FilePath) (g FilePath) -srpSubdirLens f s = fmap (\x -> s { srpSubdir = x }) (f (srpSubdir s)) -{-# INLINE srpSubdirLens #-} - -------------------------------------------------------------------------------- --- Parser & PPrinter -------------------------------------------------------------------------------- - -sourceRepositoryPackageGrammar - :: ( FieldGrammar c g, Applicative (g SourceRepoList) - , c (Identity RepoType) - , c (List NoCommaFSep FilePathNT String) - ) - => g SourceRepoList SourceRepoList -sourceRepositoryPackageGrammar = SourceRepositoryPackage - <$> uniqueField "type" srpTypeLens - <*> uniqueFieldAla "location" Token srpLocationLens - <*> optionalFieldAla "tag" Token srpTagLens - <*> optionalFieldAla "branch" Token srpBranchLens - <*> monoidalFieldAla "subdir" (alaList' NoCommaFSep FilePathNT) srpSubdirLens -- note: NoCommaFSep is somewhat important for roundtrip, as "." is there... -{-# SPECIALIZE sourceRepositoryPackageGrammar :: ParsecFieldGrammar' SourceRepoList #-} -{-# SPECIALIZE sourceRepositoryPackageGrammar :: PrettyFieldGrammar' SourceRepoList #-} diff --git a/cabal/cabal-install/Distribution/Client/Types/WriteGhcEnvironmentFilesPolicy.hs b/cabal/cabal-install/Distribution/Client/Types/WriteGhcEnvironmentFilesPolicy.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Types/WriteGhcEnvironmentFilesPolicy.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy ( - WriteGhcEnvironmentFilesPolicy (..), -) where - -import Prelude () -import Distribution.Client.Compat.Prelude - --- | Whether 'v2-build' should write a .ghc.environment file after --- success. Possible values: 'always', 'never' (the default), 'ghc8.4.4+' --- (8.4.4 is the earliest version that supports --- '-package-env -'). -data WriteGhcEnvironmentFilesPolicy - = AlwaysWriteGhcEnvironmentFiles - | NeverWriteGhcEnvironmentFiles - | WriteGhcEnvironmentFilesOnlyForGhc844AndNewer - deriving (Eq, Enum, Bounded, Generic, Show) - -instance Binary WriteGhcEnvironmentFilesPolicy -instance Structured WriteGhcEnvironmentFilesPolicy diff --git a/cabal/cabal-install/Distribution/Client/Update.hs b/cabal/cabal-install/Distribution/Client/Update.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Update.hs +++ /dev/null @@ -1,117 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Update --- Copyright : (c) David Himmelstrup 2005 --- License : BSD-like --- --- Maintainer : lemmih@gmail.com --- Stability : provisional --- Portability : portable --- --- ------------------------------------------------------------------------------ -{-# LANGUAGE RecordWildCards #-} -module Distribution.Client.Update - ( update - ) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Simple.Setup - ( fromFlag ) -import Distribution.Client.Compat.Directory - ( setModificationTime ) -import Distribution.Client.Types - ( Repo(..), RepoName (..), RemoteRepo(..), maybeRepoRemote, unRepoName ) -import Distribution.Client.HttpUtils - ( DownloadResult(..) ) -import Distribution.Client.FetchUtils - ( downloadIndex ) -import Distribution.Client.IndexUtils.Timestamp -import Distribution.Client.IndexUtils.IndexState -import Distribution.Client.IndexUtils - ( updateRepoIndexCache, Index(..), writeIndexTimestamp - , currentIndexTimestamp, indexBaseName ) -import Distribution.Client.JobControl - ( newParallelJobControl, spawnJob, collectJob ) -import Distribution.Client.Setup - ( RepoContext(..), UpdateFlags(..) ) -import Distribution.Verbosity (lessVerbose) - -import Distribution.Simple.Utils - ( writeFileAtomic, warn, notice, noticeNoWrap ) - -import qualified Data.ByteString.Lazy as BS -import Distribution.Client.GZipUtils (maybeDecompress) -import System.FilePath ((<.>), dropExtension) -import Data.Time (getCurrentTime) - -import qualified Hackage.Security.Client as Sec - --- | 'update' downloads the package list from all known servers -update :: Verbosity -> UpdateFlags -> RepoContext -> IO () -update verbosity _ repoCtxt | null (repoContextRepos repoCtxt) = do - warn verbosity $ "No remote package servers have been specified. Usually " - ++ "you would have one specified in the config file." -update verbosity updateFlags repoCtxt = do - let repos = repoContextRepos repoCtxt - remoteRepos = mapMaybe maybeRepoRemote repos - case remoteRepos of - [] -> return () - [remoteRepo] -> - notice verbosity $ "Downloading the latest package list from " - ++ unRepoName (remoteRepoName remoteRepo) - _ -> notice verbosity . unlines - $ "Downloading the latest package lists from: " - : map (("- " ++) . unRepoName . remoteRepoName) remoteRepos - jobCtrl <- newParallelJobControl (length repos) - traverse_ (spawnJob jobCtrl . updateRepo verbosity updateFlags repoCtxt) repos - traverse_ (\_ -> collectJob jobCtrl) repos - -updateRepo :: Verbosity -> UpdateFlags -> RepoContext -> Repo -> IO () -updateRepo verbosity updateFlags repoCtxt repo = do - transport <- repoContextGetTransport repoCtxt - case repo of - RepoLocalNoIndex{} -> return () - RepoRemote{..} -> do - downloadResult <- downloadIndex transport verbosity repoRemote repoLocalDir - case downloadResult of - FileAlreadyInCache -> - setModificationTime (indexBaseName repo <.> "tar") =<< getCurrentTime - FileDownloaded indexPath -> do - writeFileAtomic (dropExtension indexPath) . maybeDecompress - =<< BS.readFile indexPath - updateRepoIndexCache verbosity (RepoIndex repoCtxt repo) - RepoSecure remote _ -> repoContextWithSecureRepo repoCtxt repo $ \repoSecure -> do - let index = RepoIndex repoCtxt repo - -- NB: This may be a nullTimestamp if we've never updated before - current_ts <- currentIndexTimestamp (lessVerbose verbosity) repoCtxt repo - - -- NB: always update the timestamp, even if we didn't actually - -- download anything - let rname :: RepoName - rname = remoteRepoName remote - - let repoIndexState :: RepoIndexState - repoIndexState = lookupIndexState rname (fromFlag (updateIndexState updateFlags)) - writeIndexTimestamp index repoIndexState - - ce <- if repoContextIgnoreExpiry repoCtxt - then Just `fmap` getCurrentTime - else return Nothing - updated <- Sec.uncheckClientErrors $ Sec.checkForUpdates repoSecure ce - -- Update cabal's internal index as well so that it's not out of sync - -- (If all access to the cache goes through hackage-security this can go) - case updated of - Sec.NoUpdates -> - setModificationTime (indexBaseName repo <.> "tar") =<< getCurrentTime - Sec.HasUpdates -> - updateRepoIndexCache verbosity index - -- TODO: This will print multiple times if there are multiple - -- repositories: main problem is we don't have a way of updating - -- a specific repo. Once we implement that, update this. - when (current_ts /= nullTimestamp) $ - noticeNoWrap verbosity $ - "To revert to previous state run:\n" ++ - " cabal update --index-state='" ++ prettyShow current_ts ++ "'\n" diff --git a/cabal/cabal-install/Distribution/Client/Upload.hs b/cabal/cabal-install/Distribution/Client/Upload.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Upload.hs +++ /dev/null @@ -1,225 +0,0 @@ -module Distribution.Client.Upload (upload, uploadDoc, report) where - -import Distribution.Client.Compat.Prelude -import qualified Prelude as Unsafe (tail, head, read) - -import Distribution.Client.Types.Credentials ( Username(..), Password(..) ) -import Distribution.Client.Types.Repo (RemoteRepo(..), maybeRepoRemote) -import Distribution.Client.Types.RepoName (unRepoName) -import Distribution.Client.HttpUtils - ( HttpTransport(..), remoteRepoTryUpgradeToHttps ) -import Distribution.Client.Setup - ( IsCandidate(..), RepoContext(..) ) - -import Distribution.Simple.Utils (notice, warn, info, die', toUTF8BS) -import Distribution.Client.Config - -import qualified Distribution.Client.BuildReports.Anonymous as BuildReport -import Distribution.Client.BuildReports.Anonymous (parseBuildReport) -import qualified Distribution.Client.BuildReports.Upload as BuildReport - -import Network.URI (URI(uriPath, uriAuthority), URIAuth(uriRegName)) -import Network.HTTP (Header(..), HeaderName(..)) - -import System.IO (hFlush, stdout) -import System.IO.Echo (withoutInputEcho) -import System.FilePath ((), takeExtension, takeFileName, dropExtension) -import qualified System.FilePath.Posix as FilePath.Posix (()) -import System.Directory - -type Auth = Maybe (String, String) - --- > stripExtensions ["tar", "gz"] "foo.tar.gz" --- Just "foo" --- > stripExtensions ["tar", "gz"] "foo.gz.tar" --- Nothing -stripExtensions :: [String] -> FilePath -> Maybe String -stripExtensions exts path = foldM f path (reverse exts) - where - f p e - | takeExtension p == '.':e = Just (dropExtension p) - | otherwise = Nothing - -upload :: Verbosity -> RepoContext - -> Maybe Username -> Maybe Password -> IsCandidate -> [FilePath] - -> IO () -upload verbosity repoCtxt mUsername mPassword isCandidate paths = do - let repos = repoContextRepos repoCtxt - transport <- repoContextGetTransport repoCtxt - targetRepo <- - case [ remoteRepo | Just remoteRepo <- map maybeRepoRemote repos ] of - [] -> die' verbosity "Cannot upload. No remote repositories are configured." - (r:rs) -> remoteRepoTryUpgradeToHttps verbosity transport (last (r:|rs)) - let targetRepoURI = remoteRepoURI targetRepo - domain = maybe "Hackage" uriRegName $ uriAuthority targetRepoURI - rootIfEmpty x = if null x then "/" else x - uploadURI = targetRepoURI { - uriPath = rootIfEmpty (uriPath targetRepoURI) FilePath.Posix. - case isCandidate of - IsCandidate -> "packages/candidates" - IsPublished -> "upload" - } - packageURI pkgid = targetRepoURI { - uriPath = rootIfEmpty (uriPath targetRepoURI) - FilePath.Posix. concat - [ "package/", pkgid - , case isCandidate of - IsCandidate -> "/candidate" - IsPublished -> "" - ] - } - Username username <- maybe (promptUsername domain) return mUsername - Password password <- maybe (promptPassword domain) return mPassword - let auth = Just (username,password) - for_ paths $ \path -> do - notice verbosity $ "Uploading " ++ path ++ "... " - case fmap takeFileName (stripExtensions ["tar", "gz"] path) of - Just pkgid -> handlePackage transport verbosity uploadURI - (packageURI pkgid) auth isCandidate path - -- This case shouldn't really happen, since we check in Main that we - -- only pass tar.gz files to upload. - Nothing -> die' verbosity $ "Not a tar.gz file: " ++ path - -uploadDoc :: Verbosity -> RepoContext - -> Maybe Username -> Maybe Password -> IsCandidate -> FilePath - -> IO () -uploadDoc verbosity repoCtxt mUsername mPassword isCandidate path = do - let repos = repoContextRepos repoCtxt - transport <- repoContextGetTransport repoCtxt - targetRepo <- - case [ remoteRepo | Just remoteRepo <- map maybeRepoRemote repos ] of - [] -> die' verbosity $ "Cannot upload. No remote repositories are configured." - (r:rs) -> remoteRepoTryUpgradeToHttps verbosity transport (last (r:|rs)) - let targetRepoURI = remoteRepoURI targetRepo - domain = maybe "Hackage" uriRegName $ uriAuthority targetRepoURI - rootIfEmpty x = if null x then "/" else x - uploadURI = targetRepoURI { - uriPath = rootIfEmpty (uriPath targetRepoURI) - FilePath.Posix. concat - [ "package/", pkgid - , case isCandidate of - IsCandidate -> "/candidate" - IsPublished -> "" - , "/docs" - ] - } - packageUri = targetRepoURI { - uriPath = rootIfEmpty (uriPath targetRepoURI) - FilePath.Posix. concat - [ "package/", pkgid - , case isCandidate of - IsCandidate -> "/candidate" - IsPublished -> "" - ] - } - (reverseSuffix, reversePkgid) = break (== '-') - (reverse (takeFileName path)) - pkgid = reverse $ Unsafe.tail reversePkgid - when (reverse reverseSuffix /= "docs.tar.gz" - || null reversePkgid || Unsafe.head reversePkgid /= '-') $ - die' verbosity "Expected a file name matching the pattern -docs.tar.gz" - Username username <- maybe (promptUsername domain) return mUsername - Password password <- maybe (promptPassword domain) return mPassword - - let auth = Just (username,password) - headers = - [ Header HdrContentType "application/x-tar" - , Header HdrContentEncoding "gzip" - ] - notice verbosity $ "Uploading documentation " ++ path ++ "... " - resp <- putHttpFile transport verbosity uploadURI path auth headers - case resp of - -- Hackage responds with 204 No Content when docs are uploaded - -- successfully. - (code,_) | code `elem` [200,204] -> do - notice verbosity $ okMessage packageUri - (code,err) -> do - notice verbosity $ "Error uploading documentation " - ++ path ++ ": " - ++ "http code " ++ show code ++ "\n" - ++ err - exitFailure - where - okMessage packageUri = case isCandidate of - IsCandidate -> - "Documentation successfully uploaded for package candidate. " - ++ "You can now preview the result at '" ++ show packageUri - ++ "'. To upload non-candidate documentation, use 'cabal upload --publish'." - IsPublished -> - "Package documentation successfully published. You can now view it at '" - ++ show packageUri ++ "'." - - -promptUsername :: String -> IO Username -promptUsername domain = do - putStr $ domain ++ " username: " - hFlush stdout - fmap Username getLine - -promptPassword :: String -> IO Password -promptPassword domain = do - putStr $ domain ++ " password: " - hFlush stdout - -- save/restore the terminal echoing status (no echoing for entering the password) - passwd <- withoutInputEcho $ fmap Password getLine - putStrLn "" - return passwd - -report :: Verbosity -> RepoContext -> Maybe Username -> Maybe Password -> IO () -report verbosity repoCtxt mUsername mPassword = do - let repos = repoContextRepos repoCtxt - remoteRepos = mapMaybe maybeRepoRemote repos - for_ remoteRepos $ \remoteRepo -> do - let domain = maybe "Hackage" uriRegName $ uriAuthority (remoteRepoURI remoteRepo) - Username username <- maybe (promptUsername domain) return mUsername - Password password <- maybe (promptPassword domain) return mPassword - let auth = (username, password) - - dotCabal <- getCabalDir - let srcDir = dotCabal "reports" unRepoName (remoteRepoName remoteRepo) - -- We don't want to bomb out just because we haven't built any packages - -- from this repo yet. - srcExists <- doesDirectoryExist srcDir - when srcExists $ do - contents <- getDirectoryContents srcDir - for_ (filter (\c -> takeExtension c ==".log") contents) $ \logFile -> - do inp <- readFile (srcDir logFile) - let (reportStr, buildLog) = Unsafe.read inp :: (String,String) -- TODO: eradicateNoParse - case parseBuildReport (toUTF8BS reportStr) of - Left errs -> warn verbosity $ "Errors: " ++ errs -- FIXME - Right report' -> - do info verbosity $ "Uploading report for " - ++ prettyShow (BuildReport.package report') - BuildReport.uploadReports verbosity repoCtxt auth - (remoteRepoURI remoteRepo) [(report', Just buildLog)] - return () - -handlePackage :: HttpTransport -> Verbosity -> URI -> URI -> Auth - -> IsCandidate -> FilePath -> IO () -handlePackage transport verbosity uri packageUri auth isCandidate path = - do resp <- postHttpFile transport verbosity uri path auth - case resp of - (code,warnings) | code `elem` [200, 204] -> - notice verbosity $ okMessage isCandidate ++ - if null warnings then "" else "\n" ++ formatWarnings (trim warnings) - (code,err) -> do - notice verbosity $ "Error uploading " ++ path ++ ": " - ++ "http code " ++ show code ++ "\n" - ++ err - exitFailure - where - okMessage IsCandidate = - "Package successfully uploaded as candidate. " - ++ "You can now preview the result at '" ++ show packageUri - ++ "'. To publish the candidate, use 'cabal upload --publish'." - okMessage IsPublished = - "Package successfully published. You can now view it at '" - ++ show packageUri ++ "'." - -formatWarnings :: String -> String -formatWarnings x = "Warnings:\n" ++ (unlines . map ("- " ++) . lines) x - --- Trim -trim :: String -> String -trim = f . f - where f = reverse . dropWhile isSpace diff --git a/cabal/cabal-install/Distribution/Client/Utils.hs b/cabal/cabal-install/Distribution/Client/Utils.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Utils.hs +++ /dev/null @@ -1,369 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface, CPP #-} - -module Distribution.Client.Utils ( MergeResult(..) - , mergeBy, duplicates, duplicatesBy - , readMaybe - , inDir, withEnv, withEnvOverrides - , logDirChange, withExtraPathEnv - , determineNumJobs, numberOfProcessors - , removeExistingFile - , withTempFileName - , makeAbsoluteToCwd - , makeRelativeToCwd, makeRelativeToDir - , makeRelativeCanonical - , filePathToByteString - , byteStringToFilePath, tryCanonicalizePath - , canonicalizePathNoThrow - , moreRecentFile, existsAndIsMoreRecentThan - , tryFindAddSourcePackageDesc - , tryFindPackageDesc - , relaxEncodingErrors - , ProgressPhase (..) - , progressMessage - , cabalInstallVersion) - where - -import Prelude () -import Distribution.Client.Compat.Prelude - -import Distribution.Compat.Environment -import Distribution.Compat.Time ( getModTime ) -import Distribution.Simple.Setup ( Flag(..) ) -import Distribution.Version -import Distribution.Simple.Utils ( die', findPackageDesc, noticeNoWrap ) -import qualified Data.ByteString.Lazy as BS -import Data.Bits - ( (.|.), shiftL, shiftR ) -import System.FilePath -import Control.Monad - ( zipWithM_ ) -import Data.List - ( groupBy ) -import Foreign.C.Types ( CInt(..) ) -import qualified Control.Exception as Exception - ( finally, bracket ) -import System.Directory - ( canonicalizePath, doesFileExist, getCurrentDirectory - , removeFile, setCurrentDirectory ) -import System.IO - ( Handle, hClose, openTempFile - , hGetEncoding, hSetEncoding - ) -import System.IO.Unsafe ( unsafePerformIO ) - -import GHC.IO.Encoding - ( recover, TextEncoding(TextEncoding) ) -import GHC.IO.Encoding.Failure - ( recoverEncode, CodingFailureMode(TransliterateCodingFailure) ) - -#if defined(mingw32_HOST_OS) || MIN_VERSION_directory(1,2,3) -import qualified System.Directory as Dir -import qualified System.IO.Error as IOError -#endif - -#ifndef __DOCTEST__ -import qualified Paths_cabal_install (version) -#endif - --- | Generic merging utility. For sorted input lists this is a full outer join. --- -mergeBy :: (a -> b -> Ordering) -> [a] -> [b] -> [MergeResult a b] -mergeBy cmp = merge - where - merge [] ys = [ OnlyInRight y | y <- ys] - merge xs [] = [ OnlyInLeft x | x <- xs] - merge (x:xs) (y:ys) = - case x `cmp` y of - GT -> OnlyInRight y : merge (x:xs) ys - EQ -> InBoth x y : merge xs ys - LT -> OnlyInLeft x : merge xs (y:ys) - -data MergeResult a b = OnlyInLeft a | InBoth a b | OnlyInRight b - -duplicates :: Ord a => [a] -> [[a]] -duplicates = duplicatesBy compare - -duplicatesBy :: (a -> a -> Ordering) -> [a] -> [[a]] -duplicatesBy cmp = filter moreThanOne . groupBy eq . sortBy cmp - where - eq a b = case cmp a b of - EQ -> True - _ -> False - 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. --- -withTempFileName :: FilePath - -> String - -> (FilePath -> IO a) -> IO a -withTempFileName tmpDir template action = - Exception.bracket - (openTempFile tmpDir template) - (\(name, _) -> removeExistingFile name) - (\(name, h) -> hClose h >> action name) - --- | Executes the action in the specified directory. --- --- Warning: This operation is NOT thread-safe, because current --- working directory is a process-global concept. -inDir :: Maybe FilePath -> IO a -> IO a -inDir Nothing m = m -inDir (Just d) m = do - old <- getCurrentDirectory - setCurrentDirectory d - m `Exception.finally` setCurrentDirectory old - --- | Executes the action with an environment variable set to some --- value. --- --- Warning: This operation is NOT thread-safe, because current --- environment is a process-global concept. -withEnv :: String -> String -> IO a -> IO a -withEnv k v m = do - mb_old <- lookupEnv k - setEnv k v - m `Exception.finally` (case mb_old of - Nothing -> unsetEnv k - Just old -> setEnv k old) - --- | Executes the action with a list of environment variables and --- corresponding overrides, where --- --- * @'Just' v@ means \"set the environment variable's value to @v@\". --- * 'Nothing' means \"unset the environment variable\". --- --- Warning: This operation is NOT thread-safe, because current --- environment is a process-global concept. -withEnvOverrides :: [(String, Maybe FilePath)] -> IO a -> IO a -withEnvOverrides overrides m = do - mb_olds <- traverse lookupEnv envVars - traverse_ (uncurry update) overrides - m `Exception.finally` zipWithM_ update envVars mb_olds - where - envVars :: [String] - envVars = map fst overrides - - update :: String -> Maybe FilePath -> IO () - update var Nothing = unsetEnv var - update var (Just val) = setEnv var val - --- | Executes the action, increasing the PATH environment --- in some way --- --- Warning: This operation is NOT thread-safe, because the --- environment variables are a process-global concept. -withExtraPathEnv :: [FilePath] -> IO a -> IO a -withExtraPathEnv paths m = do - oldPathSplit <- getSearchPath - let newPath = mungePath $ intercalate [searchPathSeparator] (paths ++ oldPathSplit) - oldPath = mungePath $ intercalate [searchPathSeparator] oldPathSplit - -- TODO: This is a horrible hack to work around the fact that - -- setEnv can't take empty values as an argument - mungePath p | p == "" = "/dev/null" - | otherwise = p - setEnv "PATH" newPath - m `Exception.finally` setEnv "PATH" oldPath - --- | Log directory change in 'make' compatible syntax -logDirChange :: (String -> IO ()) -> Maybe FilePath -> IO a -> IO a -logDirChange _ Nothing m = m -logDirChange l (Just d) m = do - l $ "cabal: Entering directory '" ++ d ++ "'\n" - m `Exception.finally` - (l $ "cabal: Leaving directory '" ++ d ++ "'\n") - -foreign import ccall "getNumberOfProcessors" c_getNumberOfProcessors :: IO CInt - --- The number of processors is not going to change during the duration of the --- program, so unsafePerformIO is safe here. -numberOfProcessors :: Int -numberOfProcessors = fromEnum $ unsafePerformIO c_getNumberOfProcessors - --- | Determine the number of jobs to use given the value of the '-j' flag. -determineNumJobs :: Flag (Maybe Int) -> Int -determineNumJobs numJobsFlag = - case numJobsFlag of - NoFlag -> 1 - Flag Nothing -> numberOfProcessors - Flag (Just n) -> n - --- | Given a relative path, make it absolute relative to the current --- directory. Absolute paths are returned unmodified. -makeAbsoluteToCwd :: FilePath -> IO FilePath -makeAbsoluteToCwd path | isAbsolute path = return path - | otherwise = do cwd <- getCurrentDirectory - return $! cwd path - --- | Given a path (relative or absolute), make it relative to the current --- directory, including using @../..@ if necessary. -makeRelativeToCwd :: FilePath -> IO FilePath -makeRelativeToCwd path = - makeRelativeCanonical <$> canonicalizePath path <*> getCurrentDirectory - --- | Given a path (relative or absolute), make it relative to the given --- directory, including using @../..@ if necessary. -makeRelativeToDir :: FilePath -> FilePath -> IO FilePath -makeRelativeToDir path dir = - makeRelativeCanonical <$> canonicalizePath path <*> canonicalizePath dir - --- | Given a canonical absolute path and canonical absolute dir, make the path --- relative to the directory, including using @../..@ if necessary. Returns --- the original absolute path if it is not on the same drive as the given dir. -makeRelativeCanonical :: FilePath -> FilePath -> FilePath -makeRelativeCanonical path dir - | takeDrive path /= takeDrive dir = path - | otherwise = go (splitPath path) (splitPath dir) - where - go (p:ps) (d:ds) | p == d = go ps ds - go [] [] = "./" - go ps ds = joinPath (replicate (length ds) ".." ++ ps) - --- | Convert a 'FilePath' to a lazy 'ByteString'. Each 'Char' is --- encoded as a little-endian 'Word32'. -filePathToByteString :: FilePath -> BS.ByteString -filePathToByteString p = - BS.pack $ foldr conv [] codepts - where - codepts :: [Word32] - codepts = map (fromIntegral . ord) p - - conv :: Word32 -> [Word8] -> [Word8] - conv w32 rest = b0:b1:b2:b3:rest - where - b0 = fromIntegral $ w32 - b1 = fromIntegral $ w32 `shiftR` 8 - b2 = fromIntegral $ w32 `shiftR` 16 - b3 = fromIntegral $ w32 `shiftR` 24 - --- | Reverse operation to 'filePathToByteString'. -byteStringToFilePath :: BS.ByteString -> FilePath -byteStringToFilePath bs | bslen `mod` 4 /= 0 = unexpected - | otherwise = go 0 - where - unexpected = "Distribution.Client.Utils.byteStringToFilePath: unexpected" - bslen = BS.length bs - - go i | i == bslen = [] - | otherwise = (chr . fromIntegral $ w32) : go (i+4) - where - w32 :: Word32 - w32 = b0 .|. (b1 `shiftL` 8) .|. (b2 `shiftL` 16) .|. (b3 `shiftL` 24) - b0 = fromIntegral $ BS.index bs i - b1 = fromIntegral $ BS.index bs (i + 1) - b2 = fromIntegral $ BS.index bs (i + 2) - b3 = fromIntegral $ BS.index bs (i + 3) - --- | Workaround for the inconsistent behaviour of 'canonicalizePath'. Always --- throws an error if the path refers to a non-existent file. -tryCanonicalizePath :: FilePath -> IO FilePath -tryCanonicalizePath path = do - ret <- canonicalizePath path -#if defined(mingw32_HOST_OS) || MIN_VERSION_directory(1,2,3) - exists <- liftM2 (||) (doesFileExist ret) (Dir.doesDirectoryExist ret) - unless exists $ - IOError.ioError $ IOError.mkIOError IOError.doesNotExistErrorType "canonicalizePath" - Nothing (Just ret) -#endif - return ret - --- | A non-throwing wrapper for 'canonicalizePath'. If 'canonicalizePath' throws --- an exception, returns the path argument unmodified. -canonicalizePathNoThrow :: FilePath -> IO FilePath -canonicalizePathNoThrow path = do - canonicalizePath path `catchIO` (\_ -> return path) - --------------------- --- Modification time - --- | Like Distribution.Simple.Utils.moreRecentFile, but uses getModTime instead --- of getModificationTime for higher precision. We can't merge the two because --- Distribution.Client.Time uses MIN_VERSION macros. -moreRecentFile :: FilePath -> FilePath -> IO Bool -moreRecentFile a b = do - exists <- doesFileExist b - if not exists - then return True - else do tb <- getModTime b - ta <- getModTime a - return (ta > tb) - --- | Like 'moreRecentFile', but also checks that the first file exists. -existsAndIsMoreRecentThan :: FilePath -> FilePath -> IO Bool -existsAndIsMoreRecentThan a b = do - exists <- doesFileExist a - if not exists - then return False - else a `moreRecentFile` b - --- | Sets the handler for encoding errors to one that transliterates invalid --- characters into one present in the encoding (i.e., \'?\'). --- This is opposed to the default behavior, which is to throw an exception on --- error. This function will ignore file handles that have a Unicode encoding --- set. It's a no-op for versions of `base` less than 4.4. -relaxEncodingErrors :: Handle -> IO () -relaxEncodingErrors handle = do - maybeEncoding <- hGetEncoding handle - case maybeEncoding of - Just (TextEncoding name decoder encoder) | not ("UTF" `isPrefixOf` name) -> - let relax x = x { recover = recoverEncode TransliterateCodingFailure } - in hSetEncoding handle (TextEncoding name decoder (fmap relax encoder)) - _ -> - return () - --- |Like 'tryFindPackageDesc', but with error specific to add-source deps. -tryFindAddSourcePackageDesc :: Verbosity -> FilePath -> String -> IO FilePath -tryFindAddSourcePackageDesc verbosity depPath err = tryFindPackageDesc verbosity depPath $ - err ++ "\n" ++ "Failed to read cabal file of add-source dependency: " - ++ depPath - --- |Try to find a @.cabal@ file, in directory @depPath@. Fails if one cannot be --- found, with @err@ prefixing the error message. This function simply allows --- us to give a more descriptive error than that provided by @findPackageDesc@. -tryFindPackageDesc :: Verbosity -> FilePath -> String -> IO FilePath -tryFindPackageDesc verbosity depPath err = do - errOrCabalFile <- findPackageDesc depPath - case errOrCabalFile of - Right file -> return file - Left _ -> die' verbosity err - --- | Phase of building a dependency. Represents current status of package --- dependency processing. See #4040 for details. -data ProgressPhase - = ProgressDownloading - | ProgressDownloaded - | ProgressStarting - | ProgressBuilding - | ProgressHaddock - | ProgressInstalling - | ProgressCompleted - -progressMessage :: Verbosity -> ProgressPhase -> String -> IO () -progressMessage verbosity phase subject = do - noticeNoWrap verbosity $ phaseStr ++ subject ++ "\n" - where - phaseStr = case phase of - ProgressDownloading -> "Downloading " - ProgressDownloaded -> "Downloaded " - ProgressStarting -> "Starting " - ProgressBuilding -> "Building " - ProgressHaddock -> "Haddock " - ProgressInstalling -> "Installing " - ProgressCompleted -> "Completed " - -cabalInstallVersion :: Version -#ifdef __DOCTEST__ -cabalInstallVersion = mkVersion [3,3] -#else -cabalInstallVersion = mkVersion' Paths_cabal_install.version -#endif diff --git a/cabal/cabal-install/Distribution/Client/Utils/Assertion.hs b/cabal/cabal-install/Distribution/Client/Utils/Assertion.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Utils/Assertion.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE CPP #-} -module Distribution.Client.Utils.Assertion (expensiveAssert) where - - -#ifdef DEBUG_EXPENSIVE_ASSERTIONS -import Prelude (Bool) -import Control.Exception (assert) -import Distribution.Compat.Stack -#else -import Prelude (Bool, id) -#endif - --- | Like 'assert', but only enabled with -fdebug-expensive-assertions. This --- function can be used for expensive assertions that should only be turned on --- during testing or debugging. -#ifdef DEBUG_EXPENSIVE_ASSERTIONS -expensiveAssert :: WithCallStack (Bool -> a -> a) -expensiveAssert = assert -#else -expensiveAssert :: Bool -> a -> a -expensiveAssert _ = id -#endif diff --git a/cabal/cabal-install/Distribution/Client/Utils/Json.hs b/cabal/cabal-install/Distribution/Client/Utils/Json.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Utils/Json.hs +++ /dev/null @@ -1,222 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | Minimal JSON / RFC 7159 support --- --- The API is heavily inspired by @aeson@'s API but puts emphasis on --- simplicity rather than performance. The 'ToJSON' instances are --- intended to have an encoding compatible with @aeson@'s encoding. --- -module Distribution.Client.Utils.Json - ( Value(..) - , Object, object, Pair, (.=) - , encodeToString - , encodeToBuilder - , ToJSON(toJSON) - ) - where - -import Distribution.Client.Compat.Prelude - -import Data.Char (intToDigit) - -import Data.ByteString.Builder (Builder) -import qualified Data.ByteString.Builder as BB - --- TODO: We may want to replace 'String' with 'Text' or 'ByteString' - --- | A JSON value represented as a Haskell value. -data Value = Object !Object - | Array [Value] - | String String - | Number !Double - | Bool !Bool - | Null - deriving (Eq, Read, Show) - --- | A key\/value pair for an 'Object' -type Pair = (String, Value) - --- | A JSON \"object\" (key/value map). -type Object = [Pair] - -infixr 8 .= - --- | A key-value pair for encoding a JSON object. -(.=) :: ToJSON v => String -> v -> Pair -k .= v = (k, toJSON v) - --- | Create a 'Value' from a list of name\/value 'Pair's. -object :: [Pair] -> Value -object = Object - -instance IsString Value where - fromString = String - - --- | A type that can be converted to JSON. -class ToJSON a where - -- | Convert a Haskell value to a JSON-friendly intermediate type. - toJSON :: a -> Value - -instance ToJSON () where - toJSON () = Array [] - -instance ToJSON Value where - toJSON = id - -instance ToJSON Bool where - toJSON = Bool - -instance ToJSON a => ToJSON [a] where - toJSON = Array . map toJSON - -instance ToJSON a => ToJSON (Maybe a) where - toJSON Nothing = Null - toJSON (Just a) = toJSON a - -instance (ToJSON a,ToJSON b) => ToJSON (a,b) where - toJSON (a,b) = Array [toJSON a, toJSON b] - -instance (ToJSON a,ToJSON b,ToJSON c) => ToJSON (a,b,c) where - toJSON (a,b,c) = Array [toJSON a, toJSON b, toJSON c] - -instance (ToJSON a,ToJSON b,ToJSON c, ToJSON d) => ToJSON (a,b,c,d) where - toJSON (a,b,c,d) = Array [toJSON a, toJSON b, toJSON c, toJSON d] - -instance ToJSON Float where - toJSON = Number . realToFrac - -instance ToJSON Double where - toJSON = Number - -instance ToJSON Int where toJSON = Number . realToFrac -instance ToJSON Int8 where toJSON = Number . realToFrac -instance ToJSON Int16 where toJSON = Number . realToFrac -instance ToJSON Int32 where toJSON = Number . realToFrac - -instance ToJSON Word where toJSON = Number . realToFrac -instance ToJSON Word8 where toJSON = Number . realToFrac -instance ToJSON Word16 where toJSON = Number . realToFrac -instance ToJSON Word32 where toJSON = Number . realToFrac - --- | Possibly lossy due to conversion to 'Double' -instance ToJSON Int64 where toJSON = Number . realToFrac - --- | Possibly lossy due to conversion to 'Double' -instance ToJSON Word64 where toJSON = Number . realToFrac - --- | Possibly lossy due to conversion to 'Double' -instance ToJSON Integer where toJSON = Number . fromInteger - ------------------------------------------------------------------------------- --- 'BB.Builder'-based encoding - --- | Serialise value as JSON/UTF8-encoded 'Builder' -encodeToBuilder :: ToJSON a => a -> Builder -encodeToBuilder = encodeValueBB . toJSON - -encodeValueBB :: Value -> Builder -encodeValueBB jv = case jv of - Bool True -> "true" - Bool False -> "false" - Null -> "null" - Number n - | isNaN n || isInfinite n -> encodeValueBB Null - | Just i <- doubleToInt64 n -> BB.int64Dec i - | otherwise -> BB.doubleDec n - Array a -> encodeArrayBB a - String s -> encodeStringBB s - Object o -> encodeObjectBB o - -encodeArrayBB :: [Value] -> Builder -encodeArrayBB [] = "[]" -encodeArrayBB jvs = BB.char8 '[' <> go jvs <> BB.char8 ']' - where - go = mconcat . intersperse (BB.char8 ',') . map encodeValueBB - -encodeObjectBB :: Object -> Builder -encodeObjectBB [] = "{}" -encodeObjectBB jvs = BB.char8 '{' <> go jvs <> BB.char8 '}' - where - go = mconcat . intersperse (BB.char8 ',') . map encPair - encPair (l,x) = encodeStringBB l <> BB.char8 ':' <> encodeValueBB x - -encodeStringBB :: String -> Builder -encodeStringBB str = BB.char8 '"' <> go str <> BB.char8 '"' - where - go = BB.stringUtf8 . escapeString - ------------------------------------------------------------------------------- --- 'String'-based encoding - --- | Serialise value as JSON-encoded Unicode 'String' -encodeToString :: ToJSON a => a -> String -encodeToString jv = encodeValue (toJSON jv) [] - -encodeValue :: Value -> ShowS -encodeValue jv = case jv of - Bool b -> showString (if b then "true" else "false") - Null -> showString "null" - Number n - | isNaN n || isInfinite n -> encodeValue Null - | Just i <- doubleToInt64 n -> shows i - | otherwise -> shows n - Array a -> encodeArray a - String s -> encodeString s - Object o -> encodeObject o - -encodeArray :: [Value] -> ShowS -encodeArray [] = showString "[]" -encodeArray jvs = ('[':) . go jvs . (']':) - where - go [] = id - go [x] = encodeValue x - go (x:xs) = encodeValue x . (',':) . go xs - -encodeObject :: Object -> ShowS -encodeObject [] = showString "{}" -encodeObject jvs = ('{':) . go jvs . ('}':) - where - go [] = id - go [(l,x)] = encodeString l . (':':) . encodeValue x - go ((l,x):lxs) = encodeString l . (':':) . encodeValue x . (',':) . go lxs - -encodeString :: String -> ShowS -encodeString str = ('"':) . showString (escapeString str) . ('"':) - ------------------------------------------------------------------------------- --- helpers - --- | Try to convert 'Double' into 'Int64', return 'Nothing' if not --- representable loss-free as integral 'Int64' value. -doubleToInt64 :: Double -> Maybe Int64 -doubleToInt64 x - | fromInteger x' == x - , x' <= toInteger (maxBound :: Int64) - , x' >= toInteger (minBound :: Int64) - = Just (fromIntegral x') - | otherwise = Nothing - where - x' = round x - --- | Minimally escape a 'String' in accordance with RFC 7159, "7. Strings" -escapeString :: String -> String -escapeString s - | not (any needsEscape s) = s - | otherwise = escape s - where - escape [] = [] - escape (x:xs) = case x of - '\\' -> '\\':'\\':escape xs - '"' -> '\\':'"':escape xs - '\b' -> '\\':'b':escape xs - '\f' -> '\\':'f':escape xs - '\n' -> '\\':'n':escape xs - '\r' -> '\\':'r':escape xs - '\t' -> '\\':'t':escape xs - c | ord c < 0x10 -> '\\':'u':'0':'0':'0':intToDigit (ord c):escape xs - | ord c < 0x20 -> '\\':'u':'0':'0':'1':intToDigit (ord c - 0x10):escape xs - | otherwise -> c : escape xs - - -- unescaped = %x20-21 / %x23-5B / %x5D-10FFFF - needsEscape c = ord c < 0x20 || c `elem` ['\\','"'] diff --git a/cabal/cabal-install/Distribution/Client/Utils/Parsec.hs b/cabal/cabal-install/Distribution/Client/Utils/Parsec.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Utils/Parsec.hs +++ /dev/null @@ -1,102 +0,0 @@ -module Distribution.Client.Utils.Parsec ( - renderParseError, - ) where - -import Distribution.Client.Compat.Prelude -import Prelude () -import System.FilePath (normalise) - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BS8 - -import Distribution.Parsec (PError (..), PWarning (..), Position (..), showPos, zeroPos) -import Distribution.Simple.Utils (fromUTF8BS) - --- | Render parse error highlighting the part of the input file. -renderParseError - :: FilePath - -> BS.ByteString - -> NonEmpty PError - -> [PWarning] - -> String -renderParseError filepath contents errors warnings = unlines $ - [ "Errors encountered when parsing cabal file " <> filepath <> ":" - ] - ++ renderedErrors - ++ renderedWarnings - where - filepath' = normalise filepath - - -- lines of the input file. 'lines' is taken, so they are called rows - -- contents, line number, whether it's empty line - rows :: [(String, Int, Bool)] - rows = zipWith f (BS8.lines contents) [1..] where - f bs i = let s = fromUTF8BS bs in (s, i, isEmptyOrComment s) - - rowsZipper = listToZipper rows - - isEmptyOrComment :: String -> Bool - isEmptyOrComment s = case dropWhile (== ' ') s of - "" -> True -- empty - ('-':'-':_) -> True -- comment - _ -> False - - renderedErrors = concatMap renderError errors - renderedWarnings = concatMap renderWarning warnings - - renderError :: PError -> [String] - renderError (PError pos@(Position row col) msg) - -- if position is 0:0, then it doesn't make sense to show input - -- looks like, Parsec errors have line-feed in them - | pos == zeroPos = msgs - | otherwise = msgs ++ formatInput row col - where - msgs = [ "", filepath' ++ ":" ++ showPos pos ++ ": error:", trimLF msg, "" ] - - renderWarning :: PWarning -> [String] - renderWarning (PWarning _ pos@(Position row col) msg) - | pos == zeroPos = msgs - | otherwise = msgs ++ formatInput row col - where - msgs = [ "", filepath' ++ ":" ++ showPos pos ++ ": warning:", trimLF msg, "" ] - - -- sometimes there are (especially trailing) newlines. - trimLF :: String -> String - trimLF = dropWhile (== '\n') . reverse . dropWhile (== '\n') . reverse - - -- format line: prepend the given line number - formatInput :: Int -> Int -> [String] - formatInput row col = case advance (row - 1) rowsZipper of - Zipper xs ys -> before ++ after where - before = case span (\(_, _, b) -> b) xs of - (_, []) -> [] - (zs, z : _) -> map formatInputLine $ z : reverse zs - - after = case ys of - [] -> [] - (z : _zs) -> - [ formatInputLine z -- error line - , " | " ++ replicate (col - 1) ' ' ++ "^" -- pointer: ^ - ] - -- do we need rows after? - -- ++ map formatInputLine (take 1 zs) -- one row after - - formatInputLine :: (String, Int, Bool) -> String - formatInputLine (str, row, _) = leftPadShow row ++ " | " ++ str - - -- hopefully we don't need to work with over 99999 lines .cabal files - -- at that point small glitches in error messages are hopefully fine. - leftPadShow :: Int -> String - leftPadShow n = let s = show n in replicate (5 - length s) ' ' ++ s - -data Zipper a = Zipper [a] [a] - -listToZipper :: [a] -> Zipper a -listToZipper = Zipper [] - -advance :: Int -> Zipper a -> Zipper a -advance n z@(Zipper xs ys) - | n <= 0 = z - | otherwise = case ys of - [] -> z - (y:ys') -> advance (n - 1) $ Zipper (y:xs) ys' diff --git a/cabal/cabal-install/Distribution/Client/VCS.hs b/cabal/cabal-install/Distribution/Client/VCS.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/VCS.hs +++ /dev/null @@ -1,641 +0,0 @@ -{-# LANGUAGE NamedFieldPuns, RecordWildCards, RankNTypes #-} -module Distribution.Client.VCS ( - -- * VCS driver type - VCS, - vcsRepoType, - vcsProgram, - -- ** Type re-exports - RepoType, - Program, - ConfiguredProgram, - - -- * Validating 'SourceRepo's and configuring VCS drivers - validatePDSourceRepo, - validateSourceRepo, - validateSourceRepos, - SourceRepoProblem(..), - configureVCS, - configureVCSs, - - -- * Running the VCS driver - cloneSourceRepo, - syncSourceRepos, - - -- * The individual VCS drivers - knownVCSs, - vcsBzr, - vcsDarcs, - vcsGit, - vcsHg, - vcsSvn, - vcsPijul, - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude - -import Distribution.Types.SourceRepo - ( RepoType(..), KnownRepoType (..) ) -import Distribution.Client.Types.SourceRepo (SourceRepoMaybe, SourceRepositoryPackage (..), srpToProxy) -import Distribution.Client.RebuildMonad - ( Rebuild, monitorFiles, MonitorFilePath, monitorDirectoryExistence ) -import Distribution.Verbosity as Verbosity - ( normal ) -import Distribution.Simple.Program - ( Program(programFindVersion) - , ConfiguredProgram(programVersion) - , simpleProgram, findProgramVersion - , ProgramInvocation(..), programInvocation, runProgramInvocation - , emptyProgramDb, requireProgram ) -import Distribution.Version - ( mkVersion ) -import qualified Distribution.PackageDescription as PD - -import Control.Monad.Trans - ( liftIO ) -import qualified Data.Char as Char -import qualified Data.Map as Map -import System.FilePath - ( takeDirectory ) -import System.Directory - ( doesDirectoryExist ) - - --- | A driver for a version control system, e.g. git, darcs etc. --- -data VCS program = VCS { - -- | The type of repository this driver is for. - vcsRepoType :: RepoType, - - -- | The vcs program itself. - -- This is used at type 'Program' and 'ConfiguredProgram'. - vcsProgram :: program, - - -- | The program invocation(s) to get\/clone a repository into a fresh - -- local directory. - vcsCloneRepo :: forall f. Verbosity - -> ConfiguredProgram - -> SourceRepositoryPackage f - -> FilePath -- Source URI - -> FilePath -- Destination directory - -> [ProgramInvocation], - - -- | The program invocation(s) to synchronise a whole set of /related/ - -- repositories with corresponding local directories. Also returns the - -- files that the command depends on, for change monitoring. - vcsSyncRepos :: forall f. Verbosity - -> ConfiguredProgram - -> [(SourceRepositoryPackage f, FilePath)] - -> IO [MonitorFilePath] - } - - --- ------------------------------------------------------------ --- * Selecting repos and drivers --- ------------------------------------------------------------ - -data SourceRepoProblem = SourceRepoRepoTypeUnspecified - | SourceRepoRepoTypeUnsupported (SourceRepositoryPackage Proxy) RepoType - | SourceRepoLocationUnspecified - deriving Show - --- | Validates that the 'SourceRepo' specifies a location URI and a repository --- type that is supported by a VCS driver. --- --- | It also returns the 'VCS' driver we should use to work with it. --- -validateSourceRepo - :: SourceRepositoryPackage f - -> Either SourceRepoProblem (SourceRepositoryPackage f, String, RepoType, VCS Program) -validateSourceRepo = \repo -> do - let rtype = srpType repo - vcs <- Map.lookup rtype knownVCSs ?! SourceRepoRepoTypeUnsupported (srpToProxy repo) rtype - let uri = srpLocation repo - return (repo, uri, rtype, vcs) - where - a ?! e = maybe (Left e) Right a - -validatePDSourceRepo - :: PD.SourceRepo - -> Either SourceRepoProblem (SourceRepoMaybe, String, RepoType, VCS Program) -validatePDSourceRepo repo = do - rtype <- PD.repoType repo ?! SourceRepoRepoTypeUnspecified - uri <- PD.repoLocation repo ?! SourceRepoLocationUnspecified - validateSourceRepo SourceRepositoryPackage - { srpType = rtype - , srpLocation = uri - , srpTag = PD.repoTag repo - , srpBranch = PD.repoBranch repo - , srpSubdir = PD.repoSubdir repo - } - where - a ?! e = maybe (Left e) Right a - - - --- | As 'validateSourceRepo' but for a bunch of 'SourceRepo's, and return --- things in a convenient form to pass to 'configureVCSs', or to report --- problems. --- -validateSourceRepos :: [SourceRepositoryPackage f] - -> Either [(SourceRepositoryPackage f, SourceRepoProblem)] - [(SourceRepositoryPackage f, String, RepoType, VCS Program)] -validateSourceRepos rs = - case partitionEithers (map validateSourceRepo' rs) of - (problems@(_:_), _) -> Left problems - ([], vcss) -> Right vcss - where - validateSourceRepo' r = either (Left . (,) r) Right - (validateSourceRepo r) - - -configureVCS :: Verbosity - -> VCS Program - -> IO (VCS ConfiguredProgram) -configureVCS verbosity vcs@VCS{vcsProgram = prog} = - asVcsConfigured <$> requireProgram verbosity prog emptyProgramDb - where - asVcsConfigured (prog', _) = vcs { vcsProgram = prog' } - -configureVCSs :: Verbosity - -> Map RepoType (VCS Program) - -> IO (Map RepoType (VCS ConfiguredProgram)) -configureVCSs verbosity = traverse (configureVCS verbosity) - - --- ------------------------------------------------------------ --- * Running the driver --- ------------------------------------------------------------ - --- | Clone a single source repo into a fresh directory, using a configured VCS. --- --- This is for making a new copy, not synchronising an existing copy. It will --- fail if the destination directory already exists. --- --- Make sure to validate the 'SourceRepo' using 'validateSourceRepo' first. --- - -cloneSourceRepo - :: Verbosity - -> VCS ConfiguredProgram - -> SourceRepositoryPackage f - -> [Char] - -> IO () -cloneSourceRepo verbosity vcs - repo@SourceRepositoryPackage{ srpLocation = srcuri } destdir = - traverse_ (runProgramInvocation verbosity) invocations - where - invocations = vcsCloneRepo vcs verbosity - (vcsProgram vcs) repo - srcuri destdir - - --- | Syncronise a set of 'SourceRepo's referring to the same repository with --- corresponding local directories. The local directories may or may not --- already exist. --- --- The 'SourceRepo' values used in a single invocation of 'syncSourceRepos', --- or used across a series of invocations with any local directory must refer --- to the /same/ repository. That means it must be the same location but they --- can differ in the branch, or tag or subdir. --- --- The reason to allow multiple related 'SourceRepo's is to allow for the --- network or storage to be shared between different checkouts of the repo. --- For example if a single repo contains multiple packages in different subdirs --- and in some project it may make sense to use a different state of the repo --- for one subdir compared to another. --- -syncSourceRepos :: Verbosity - -> VCS ConfiguredProgram - -> [(SourceRepositoryPackage f, FilePath)] - -> Rebuild () -syncSourceRepos verbosity vcs repos = do - files <- liftIO $ vcsSyncRepos vcs verbosity (vcsProgram vcs) repos - monitorFiles files - - --- ------------------------------------------------------------ --- * The various VCS drivers --- ------------------------------------------------------------ - --- | The set of all supported VCS drivers, organised by 'RepoType'. --- -knownVCSs :: Map RepoType (VCS Program) -knownVCSs = Map.fromList [ (vcsRepoType vcs, vcs) | vcs <- vcss ] - where - vcss = [ vcsBzr, vcsDarcs, vcsGit, vcsHg, vcsSvn ] - - --- | VCS driver for Bazaar. --- -vcsBzr :: VCS Program -vcsBzr = - VCS { - vcsRepoType = KnownRepoType Bazaar, - vcsProgram = bzrProgram, - vcsCloneRepo, - vcsSyncRepos - } - where - vcsCloneRepo :: Verbosity - -> ConfiguredProgram - -> SourceRepositoryPackage f - -> FilePath - -> FilePath - -> [ProgramInvocation] - vcsCloneRepo verbosity prog repo srcuri destdir = - [ programInvocation prog - ([branchCmd, srcuri, destdir] ++ tagArgs ++ verboseArg) ] - where - -- The @get@ command was deprecated in version 2.4 in favour of - -- the alias @branch@ - branchCmd | programVersion prog >= Just (mkVersion [2,4]) - = "branch" - | otherwise = "get" - - tagArgs = case srpTag repo of - Nothing -> [] - Just tag -> ["-r", "tag:" ++ tag] - verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] - - vcsSyncRepos :: Verbosity -> ConfiguredProgram - -> [(SourceRepositoryPackage f, FilePath)] -> IO [MonitorFilePath] - vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for bzr" - -bzrProgram :: Program -bzrProgram = (simpleProgram "bzr") { - programFindVersion = findProgramVersion "--version" $ \str -> - case words str of - -- "Bazaar (bzr) 2.6.0\n ... lots of extra stuff" - (_:_:ver:_) -> ver - _ -> "" - } - - --- | VCS driver for Darcs. --- -vcsDarcs :: VCS Program -vcsDarcs = - VCS { - vcsRepoType = KnownRepoType Darcs, - vcsProgram = darcsProgram, - vcsCloneRepo, - vcsSyncRepos - } - where - vcsCloneRepo :: Verbosity - -> ConfiguredProgram - -> SourceRepositoryPackage f - -> FilePath - -> FilePath - -> [ProgramInvocation] - vcsCloneRepo verbosity prog repo srcuri destdir = - [ programInvocation prog cloneArgs ] - where - cloneArgs = [cloneCmd, srcuri, destdir] ++ tagArgs ++ verboseArg - -- At some point the @clone@ command was introduced as an alias for - -- @get@, and @clone@ seems to be the recommended one now. - cloneCmd | programVersion prog >= Just (mkVersion [2,8]) - = "clone" - | otherwise = "get" - tagArgs = case srpTag repo of - Nothing -> [] - Just tag -> ["-t", tag] - verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] - - vcsSyncRepos :: Verbosity -> ConfiguredProgram - -> [(SourceRepositoryPackage f, FilePath)] -> IO [MonitorFilePath] - vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for darcs" - -darcsProgram :: Program -darcsProgram = (simpleProgram "darcs") { - programFindVersion = findProgramVersion "--version" $ \str -> - case words str of - -- "2.8.5 (release)" - (ver:_) -> ver - _ -> "" - } - - --- | VCS driver for Git. --- -vcsGit :: VCS Program -vcsGit = - VCS { - vcsRepoType = KnownRepoType Git, - vcsProgram = gitProgram, - vcsCloneRepo, - vcsSyncRepos - } - where - vcsCloneRepo :: Verbosity - -> ConfiguredProgram - -> SourceRepositoryPackage f - -> FilePath - -> FilePath - -> [ProgramInvocation] - vcsCloneRepo verbosity prog repo srcuri destdir = - [ programInvocation prog cloneArgs ] - -- And if there's a tag, we have to do that in a second step: - ++ [ (programInvocation prog (checkoutArgs tag)) { - progInvokeCwd = Just destdir - } - | tag <- maybeToList (srpTag repo) ] - where - cloneArgs = ["clone", srcuri, destdir] - ++ branchArgs ++ verboseArg - branchArgs = case srpBranch repo of - Just b -> ["--branch", b] - Nothing -> [] - checkoutArgs tag = "checkout" : verboseArg ++ [tag, "--"] - verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] - - vcsSyncRepos :: Verbosity - -> ConfiguredProgram - -> [(SourceRepositoryPackage f, FilePath)] - -> IO [MonitorFilePath] - vcsSyncRepos _ _ [] = return [] - vcsSyncRepos verbosity gitProg - ((primaryRepo, primaryLocalDir) : secondaryRepos) = do - - vcsSyncRepo verbosity gitProg primaryRepo primaryLocalDir Nothing - sequence_ - [ vcsSyncRepo verbosity gitProg repo localDir (Just primaryLocalDir) - | (repo, localDir) <- secondaryRepos ] - return [ monitorDirectoryExistence dir - | dir <- (primaryLocalDir : map snd secondaryRepos) ] - - vcsSyncRepo verbosity gitProg SourceRepositoryPackage{..} localDir peer = do - exists <- doesDirectoryExist localDir - if exists - then git localDir ["fetch"] - else git (takeDirectory localDir) cloneArgs - git localDir checkoutArgs - where - git :: FilePath -> [String] -> IO () - git cwd args = runProgramInvocation verbosity $ - (programInvocation gitProg args) { - progInvokeCwd = Just cwd - } - - cloneArgs = ["clone", "--no-checkout", loc, localDir] - ++ case peer of - Nothing -> [] - Just peerLocalDir -> ["--reference", peerLocalDir] - ++ verboseArg - where loc = srpLocation - checkoutArgs = "checkout" : verboseArg ++ ["--detach", "--force" - , checkoutTarget, "--" ] - checkoutTarget = fromMaybe "HEAD" (srpBranch `mplus` srpTag) - verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] - -gitProgram :: Program -gitProgram = (simpleProgram "git") { - programFindVersion = findProgramVersion "--version" $ \str -> - case words str of - -- "git version 2.5.5" - (_:_:ver:_) | all isTypical ver -> ver - - -- or annoyingly "git version 2.17.1.windows.2" yes, really - (_:_:ver:_) -> intercalate "." - . takeWhile (all isNum) - . split - $ ver - _ -> "" - } - where - isNum c = c >= '0' && c <= '9' - isTypical c = isNum c || c == '.' - split cs = case break (=='.') cs of - (chunk,[]) -> chunk : [] - (chunk,_:rest) -> chunk : split rest - --- | VCS driver for Mercurial. --- -vcsHg :: VCS Program -vcsHg = - VCS { - vcsRepoType = KnownRepoType Mercurial, - vcsProgram = hgProgram, - vcsCloneRepo, - vcsSyncRepos - } - where - vcsCloneRepo :: Verbosity - -> ConfiguredProgram - -> SourceRepositoryPackage f - -> FilePath - -> FilePath - -> [ProgramInvocation] - vcsCloneRepo verbosity prog repo srcuri destdir = - [ programInvocation prog cloneArgs ] - where - cloneArgs = ["clone", srcuri, destdir] - ++ branchArgs ++ tagArgs ++ verboseArg - branchArgs = case srpBranch repo of - Just b -> ["--branch", b] - Nothing -> [] - tagArgs = case srpTag repo of - Just t -> ["--rev", t] - Nothing -> [] - verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] - - vcsSyncRepos :: Verbosity - -> ConfiguredProgram - -> [(SourceRepositoryPackage f, FilePath)] - -> IO [MonitorFilePath] - vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for hg" - -hgProgram :: Program -hgProgram = (simpleProgram "hg") { - programFindVersion = findProgramVersion "--version" $ \str -> - case words str of - -- Mercurial Distributed SCM (version 3.5.2)\n ... long message - (_:_:_:_:ver:_) -> takeWhile (\c -> Char.isDigit c || c == '.') ver - _ -> "" - } - - --- | VCS driver for Subversion. --- -vcsSvn :: VCS Program -vcsSvn = - VCS { - vcsRepoType = KnownRepoType SVN, - vcsProgram = svnProgram, - vcsCloneRepo, - vcsSyncRepos - } - where - vcsCloneRepo :: Verbosity - -> ConfiguredProgram - -> SourceRepositoryPackage f - -> FilePath - -> FilePath - -> [ProgramInvocation] - vcsCloneRepo verbosity prog _repo srcuri destdir = - [ programInvocation prog checkoutArgs ] - where - checkoutArgs = ["checkout", srcuri, destdir] ++ verboseArg - verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] - --TODO: branch or tag? - - vcsSyncRepos :: Verbosity - -> ConfiguredProgram - -> [(SourceRepositoryPackage f, FilePath)] - -> IO [MonitorFilePath] - vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for svn" - -svnProgram :: Program -svnProgram = (simpleProgram "svn") { - programFindVersion = findProgramVersion "--version" $ \str -> - case words str of - -- svn, version 1.9.4 (r1740329)\n ... long message - (_:_:ver:_) -> ver - _ -> "" - } - - --- | VCS driver for Pijul. --- Documentation for Pijul can be found at --- --- 2020-04-09 Oleg: --- --- As far as I understand pijul, there are branches and "tags" in pijul, --- but there aren't a "commit hash" identifying an arbitrary state. --- --- One can create `a pijul tag`, which will make a patch hash, --- which depends on everything currently in the repository. --- I guess if you try to apply that patch, you'll be forced to apply --- all the dependencies too. In other words, there are no named tags. --- --- It's not clear to me whether there is an option to --- "apply this patch *and* all of its dependencies". --- And relatedly, whether how to make sure that there are no other --- patches applied. --- --- With branches it's easier, as you can `pull` and `checkout` them, --- and they seem to be similar enough. Yet, pijul documentations says --- --- > Note that the purpose of branches in Pijul is quite different from Git, --- since Git's "feature branches" can usually be implemented by just --- patches. --- --- I guess it means that indeed instead of creating a branch and making PR --- in "GitHub" workflow, you'd just create a patch and offer it. --- You can do that with `git` too. Push (a branch with) commit to remote --- and ask other to cherry-pick that commit. Yet, in git identity of commit --- changes when it applied to other trees, where patches in pijul have --- will continue to have the same hash. --- --- Unfortunately pijul doesn't talk about conflict resolution. --- It seems that you get something like: --- --- % pijul status --- On branch merge --- --- Unresolved conflicts: --- (fix conflicts and record the resolution with "pijul record ...") --- --- foo --- --- % cat foo --- first line --- >> >>>>>>>>>>>>>>>>>>>>>>>>>>>>> --- branch BBB --- ================================ --- branch AAA --- <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< --- last line --- --- And then the `pijul dependencies` would draw you a graph like --- --- --- -----> foo on branch B -----> --- resolve confict Initial patch --- -----> foo on branch A -----> --- --- Which is seems reasonable. --- --- So currently, pijul support is very experimental, and most likely --- won't work, even the basics are in place. Tests are also written --- but disabled, as the branching model differs from `git` one, --- for which tests are written. --- -vcsPijul :: VCS Program -vcsPijul = - VCS { - vcsRepoType = KnownRepoType Pijul, - vcsProgram = pijulProgram, - vcsCloneRepo, - vcsSyncRepos - } - where - vcsCloneRepo :: Verbosity -- ^ it seems that pijul does not have verbose flag - -> ConfiguredProgram - -> SourceRepositoryPackage f - -> FilePath - -> FilePath - -> [ProgramInvocation] - vcsCloneRepo _verbosity prog repo srcuri destdir = - [ programInvocation prog cloneArgs ] - -- And if there's a tag, we have to do that in a second step: - ++ [ (programInvocation prog (checkoutArgs tag)) { - progInvokeCwd = Just destdir - } - | tag <- maybeToList (srpTag repo) ] - where - cloneArgs = ["clone", srcuri, destdir] - ++ branchArgs - branchArgs = case srpBranch repo of - Just b -> ["--from-branch", b] - Nothing -> [] - checkoutArgs tag = "checkout" : [tag] -- TODO: this probably doesn't work either - - vcsSyncRepos :: Verbosity - -> ConfiguredProgram - -> [(SourceRepositoryPackage f, FilePath)] - -> IO [MonitorFilePath] - vcsSyncRepos _ _ [] = return [] - vcsSyncRepos verbosity pijulProg - ((primaryRepo, primaryLocalDir) : secondaryRepos) = do - - vcsSyncRepo verbosity pijulProg primaryRepo primaryLocalDir Nothing - sequence_ - [ vcsSyncRepo verbosity pijulProg repo localDir (Just primaryLocalDir) - | (repo, localDir) <- secondaryRepos ] - return [ monitorDirectoryExistence dir - | dir <- (primaryLocalDir : map snd secondaryRepos) ] - - vcsSyncRepo verbosity pijulProg SourceRepositoryPackage{..} localDir peer = do - exists <- doesDirectoryExist localDir - if exists - then pijul localDir ["pull"] -- TODO: this probably doesn't work. - else pijul (takeDirectory localDir) cloneArgs - pijul localDir checkoutArgs - where - pijul :: FilePath -> [String] -> IO () - pijul cwd args = runProgramInvocation verbosity $ - (programInvocation pijulProg args) { - progInvokeCwd = Just cwd - } - - cloneArgs = ["clone", loc, localDir] - ++ case peer of - Nothing -> [] - Just peerLocalDir -> [peerLocalDir] - where loc = srpLocation - checkoutArgs = "checkout" : ["--force", checkoutTarget, "--" ] - checkoutTarget = fromMaybe "HEAD" (srpBranch `mplus` srpTag) -- TODO: this is definitely wrong. - -pijulProgram :: Program -pijulProgram = (simpleProgram "pijul") { - programFindVersion = findProgramVersion "--version" $ \str -> - case words str of - -- "pijul 0.12.2 - (_:ver:_) | all isTypical ver -> ver - _ -> "" - } - where - isNum c = c >= '0' && c <= '9' - isTypical c = isNum c || c == '.' diff --git a/cabal/cabal-install/Distribution/Client/Win32SelfUpgrade.hs b/cabal/cabal-install/Distribution/Client/Win32SelfUpgrade.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Win32SelfUpgrade.hs +++ /dev/null @@ -1,226 +0,0 @@ -{-# LANGUAGE CPP, ForeignFunctionInterface #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Win32SelfUpgrade --- Copyright : (c) Duncan Coutts 2008 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- Support for self-upgrading executables on Windows platforms. ------------------------------------------------------------------------------ -module Distribution.Client.Win32SelfUpgrade ( --- * Explanation --- --- | Windows inherited a design choice from DOS that while initially innocuous --- has rather unfortunate consequences. It maintains the invariant that every --- open file has a corresponding name on disk. One positive consequence of this --- is that an executable can always find its own executable file. The downside --- is that a program cannot be deleted or upgraded while it is running without --- hideous workarounds. This module implements one such hideous workaround. --- --- The basic idea is: --- --- * Move our own exe file to a new name --- * Copy a new exe file to the previous name --- * Run the new exe file, passing our own PID and new path --- * Wait for the new process to start --- * Close the new exe file --- * Exit old process --- --- Then in the new process: --- --- * Inform the old process that we've started --- * Wait for the old process to die --- * Delete the old exe file --- * Exit new process --- - - possibleSelfUpgrade, - deleteOldExeFile, - ) where - -import Distribution.Client.Compat.Prelude hiding (log) -import Prelude () - -#ifdef mingw32_HOST_OS - -import qualified System.Win32 as Win32 -import System.Win32 (DWORD, BOOL, HANDLE, LPCTSTR) -import Foreign.Ptr (Ptr, nullPtr) -import System.Process (runProcess) -import System.Directory (canonicalizePath) -import System.FilePath (takeBaseName, replaceBaseName, equalFilePath) - -import Distribution.Verbosity as Verbosity (showForCabal) -import Distribution.Simple.Utils (debug, info) - - --- | If one of the given files is our own exe file then we arrange things such --- that the nested action can replace our own exe file. --- --- We require that the new process accepts a command line invocation that --- calls 'deleteOldExeFile', passing in the PID and exe file. --- -possibleSelfUpgrade :: Verbosity - -> [FilePath] - -> IO a -> IO a -possibleSelfUpgrade verbosity newPaths action = do - dstPath <- canonicalizePath =<< Win32.getModuleFileName Win32.nullHANDLE - - newPaths' <- traverse canonicalizePath newPaths - let doingSelfUpgrade = any (equalFilePath dstPath) newPaths' - - if not doingSelfUpgrade - then action - else do - info verbosity $ "cabal-install does the replace-own-exe-file dance..." - tmpPath <- moveOurExeOutOfTheWay verbosity - result <- action - scheduleOurDemise verbosity dstPath tmpPath - (\pid path -> ["win32selfupgrade", pid, path - ,"--verbose=" ++ Verbosity.showForCabal verbosity]) - return result - --- | The name of a Win32 Event object that we use to synchronise between the --- old and new processes. We need to synchronise to make sure that the old --- process has not yet terminated by the time the new one starts up and looks --- for the old process. Otherwise the old one might have already terminated --- and we could not wait on it terminating reliably (eg the PID might get --- re-used). --- -syncEventName :: String -syncEventName = "Local\\cabal-install-upgrade" - --- | The first part of allowing our exe file to be replaced is to move the --- existing exe file out of the way. Although we cannot delete our exe file --- while we're still running, fortunately we can rename it, at least within --- the same directory. --- -moveOurExeOutOfTheWay :: Verbosity -> IO FilePath -moveOurExeOutOfTheWay verbosity = do - ourPID <- getCurrentProcessId - dstPath <- Win32.getModuleFileName Win32.nullHANDLE - - let tmpPath = replaceBaseName dstPath (takeBaseName dstPath ++ show ourPID) - - debug verbosity $ "moving " ++ dstPath ++ " to " ++ tmpPath - Win32.moveFile dstPath tmpPath - return tmpPath - --- | Assuming we've now installed the new exe file in the right place, we --- launch it and ask it to delete our exe file when we eventually terminate. --- -scheduleOurDemise :: Verbosity -> FilePath -> FilePath - -> (String -> FilePath -> [String]) -> IO () -scheduleOurDemise verbosity dstPath tmpPath mkArgs = do - ourPID <- getCurrentProcessId - event <- createEvent syncEventName - - let args = mkArgs (show ourPID) tmpPath - log $ "launching child " ++ unwords (dstPath : map show args) - _ <- runProcess dstPath args Nothing Nothing Nothing Nothing Nothing - - log $ "waiting for the child to start up" - waitForSingleObject event (10*1000) -- wait at most 10 sec - log $ "child started ok" - - where - log msg = debug verbosity ("Win32Reinstall.parent: " ++ msg) - --- | Assuming we're now in the new child process, we've been asked by the old --- process to wait for it to terminate and then we can remove the old exe file --- that it renamed itself to. --- -deleteOldExeFile :: Verbosity -> Int -> FilePath -> IO () -deleteOldExeFile verbosity oldPID tmpPath = do - log $ "process started. Will delete exe file of process " - ++ show oldPID ++ " at path " ++ tmpPath - - log $ "getting handle of parent process " ++ show oldPID - oldPHANDLE <- Win32.openProcess Win32.sYNCHORNIZE False (fromIntegral oldPID) - - log $ "synchronising with parent" - event <- openEvent syncEventName - setEvent event - - log $ "waiting for parent process to terminate" - waitForSingleObject oldPHANDLE Win32.iNFINITE - log $ "parent process terminated" - - log $ "deleting parent's old .exe file" - Win32.deleteFile tmpPath - - where - log msg = debug verbosity ("Win32Reinstall.child: " ++ msg) - ------------------------- --- Win32 foreign imports --- - --- A bunch of functions sadly not provided by the Win32 package. - -#ifdef x86_64_HOST_ARCH -#define CALLCONV ccall -#else -#define CALLCONV stdcall -#endif - -foreign import CALLCONV unsafe "windows.h GetCurrentProcessId" - getCurrentProcessId :: IO DWORD - -foreign import CALLCONV unsafe "windows.h WaitForSingleObject" - waitForSingleObject_ :: HANDLE -> DWORD -> IO DWORD - -waitForSingleObject :: HANDLE -> DWORD -> IO () -waitForSingleObject handle timeout = - Win32.failIf_ bad "WaitForSingleObject" $ - waitForSingleObject_ handle timeout - where - bad result = not (result == 0 || result == wAIT_TIMEOUT) - wAIT_TIMEOUT = 0x00000102 - -foreign import CALLCONV unsafe "windows.h CreateEventW" - createEvent_ :: Ptr () -> BOOL -> BOOL -> LPCTSTR -> IO HANDLE - -createEvent :: String -> IO HANDLE -createEvent name = do - Win32.failIfNull "CreateEvent" $ - Win32.withTString name $ - createEvent_ nullPtr False False - -foreign import CALLCONV unsafe "windows.h OpenEventW" - openEvent_ :: DWORD -> BOOL -> LPCTSTR -> IO HANDLE - -openEvent :: String -> IO HANDLE -openEvent name = do - Win32.failIfNull "OpenEvent" $ - Win32.withTString name $ - openEvent_ eVENT_MODIFY_STATE False - where - eVENT_MODIFY_STATE :: DWORD - eVENT_MODIFY_STATE = 0x0002 - -foreign import CALLCONV unsafe "windows.h SetEvent" - setEvent_ :: HANDLE -> IO BOOL - -setEvent :: HANDLE -> IO () -setEvent handle = - Win32.failIfFalse_ "SetEvent" $ - setEvent_ handle - -#else - -import Distribution.Simple.Utils (die') - -possibleSelfUpgrade :: Verbosity - -> [FilePath] - -> IO a -> IO a -possibleSelfUpgrade _ _ action = action - -deleteOldExeFile :: Verbosity -> Int -> FilePath -> IO () -deleteOldExeFile verbosity _ _ = die' verbosity "win32selfupgrade not needed except on win32" - -#endif diff --git a/cabal/cabal-install/Distribution/Client/World.hs b/cabal/cabal-install/Distribution/Client/World.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/World.hs +++ /dev/null @@ -1,144 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.World --- Copyright : (c) Peter Robinson 2009 --- License : BSD-like --- --- Maintainer : thaldyron@gmail.com --- Stability : provisional --- Portability : portable --- --- Interface to the world-file that contains a list of explicitly --- requested packages. Meant to be imported qualified. --- --- A world file entry stores the package-name, package-version, and --- user flags. --- For example, the entry generated by --- # cabal install stm-io-hooks --flags="-debug" --- looks like this: --- # stm-io-hooks -any --flags="-debug" --- To rebuild/upgrade the packages in world (e.g. when updating the compiler) --- use --- # cabal install world --- ------------------------------------------------------------------------------ -module Distribution.Client.World ( - WorldPkgInfo(..), - insert, - delete, - getContents, - ) where - -import Prelude (sequence) -import Distribution.Client.Compat.Prelude hiding (getContents) - -import Distribution.Types.Dependency -import Distribution.Types.Flag - ( FlagAssignment, unFlagAssignment - , unFlagName, parsecFlagAssignmentNonEmpty ) -import Distribution.Simple.Utils - ( die', info, chattyTry, writeFileAtomic ) -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - -import Data.List - ( unionBy, deleteFirstsBy ) -import System.IO.Error - ( isDoesNotExistError ) -import qualified Data.ByteString.Lazy.Char8 as B - - -data WorldPkgInfo = WorldPkgInfo Dependency FlagAssignment - deriving (Show,Eq, Generic) - --- | Adds packages to the world file; creates the file if it doesn't --- exist yet. Version constraints and flag assignments for a package are --- updated if already present. IO errors are non-fatal. -insert :: Verbosity -> FilePath -> [WorldPkgInfo] -> IO () -insert = modifyWorld $ unionBy equalUDep - --- | Removes packages from the world file. --- Note: Currently unused as there is no mechanism in Cabal (yet) to --- handle uninstalls. IO errors are non-fatal. -delete :: Verbosity -> FilePath -> [WorldPkgInfo] -> IO () -delete = modifyWorld $ flip (deleteFirstsBy equalUDep) - --- | WorldPkgInfo values are considered equal if they refer to --- the same package, i.e., we don't care about differing versions or flags. -equalUDep :: WorldPkgInfo -> WorldPkgInfo -> Bool -equalUDep (WorldPkgInfo (Dependency pkg1 _ _) _) - (WorldPkgInfo (Dependency pkg2 _ _) _) = pkg1 == pkg2 - --- | Modifies the world file by applying an update-function ('unionBy' --- for 'insert', 'deleteFirstsBy' for 'delete') to the given list of --- packages. IO errors are considered non-fatal. -modifyWorld :: ([WorldPkgInfo] -> [WorldPkgInfo] - -> [WorldPkgInfo]) - -- ^ Function that defines how - -- the list of user packages are merged with - -- existing world packages. - -> Verbosity - -> FilePath -- ^ Location of the world file - -> [WorldPkgInfo] -- ^ list of user supplied packages - -> IO () -modifyWorld _ _ _ [] = return () -modifyWorld f verbosity world pkgs = - chattyTry "Error while updating world-file. " $ do - pkgsOldWorld <- getContents verbosity world - -- Filter out packages that are not in the world file: - let pkgsNewWorld = nubBy equalUDep $ f pkgs pkgsOldWorld - -- 'Dependency' is not an Ord instance, so we need to check for - -- equivalence the awkward way: - if not (all (`elem` pkgsOldWorld) pkgsNewWorld && - all (`elem` pkgsNewWorld) pkgsOldWorld) - then do - info verbosity "Updating world file..." - writeFileAtomic world . B.pack $ unlines - [ (prettyShow pkg) | pkg <- pkgsNewWorld] - else - info verbosity "World file is already up to date." - - --- | Returns the content of the world file as a list -getContents :: Verbosity -> FilePath -> IO [WorldPkgInfo] -getContents verbosity world = do - content <- safelyReadFile world - let result = map simpleParsec (lines $ B.unpack content) - case sequence result of - Nothing -> die' verbosity "Could not parse world file." - Just xs -> return xs - where - safelyReadFile :: FilePath -> IO B.ByteString - safelyReadFile file = B.readFile file `catchIO` handler - where - handler e | isDoesNotExistError e = return B.empty - | otherwise = ioError e - - -instance Pretty WorldPkgInfo where - pretty (WorldPkgInfo dep flags) = pretty dep Disp.<+> dispFlags (unFlagAssignment flags) - where - dispFlags [] = Disp.empty - dispFlags fs = Disp.text "--flags=" - <<>> Disp.doubleQuotes (flagAssToDoc fs) - flagAssToDoc = foldr (\(fname,val) flagAssDoc -> - (if not val then Disp.char '-' - else Disp.char '+') - <<>> Disp.text (unFlagName fname) - Disp.<+> flagAssDoc) - Disp.empty - -instance Parsec WorldPkgInfo where - parsec = do - dep <- parsec - P.spaces - flagAss <- P.option mempty parseFlagAssignment - return $ WorldPkgInfo dep flagAss - where - parseFlagAssignment :: CabalParsing m => m FlagAssignment - parseFlagAssignment = do - _ <- P.string "--flags=" - inDoubleQuotes parsecFlagAssignmentNonEmpty - where - inDoubleQuotes = P.between (P.char '"') (P.char '"') diff --git a/cabal/cabal-install/Distribution/Deprecated/ParseUtils.hs b/cabal/cabal-install/Distribution/Deprecated/ParseUtils.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Deprecated/ParseUtils.hs +++ /dev/null @@ -1,563 +0,0 @@ -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Deprecated.ParseUtils --- Copyright : (c) The University of Glasgow 2004 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Utilities for parsing 'PackageDescription' and 'InstalledPackageInfo'. --- --- The @.cabal@ file format is not trivial, especially with the introduction --- of configurations and the section syntax that goes with that. This module --- has a bunch of parsing functions that is used by the @.cabal@ parser and a --- couple others. It has the parsing framework code and also little parsers for --- many of the formats we get in various @.cabal@ file fields, like module --- names, comma separated lists etc. - --- This module is meant to be local-only to Distribution... - -{-# OPTIONS_HADDOCK hide #-} -{-# LANGUAGE Rank2Types #-} -module Distribution.Deprecated.ParseUtils ( - LineNo, PError(..), PWarning(..), locatedErrorMsg, syntaxError, warning, - runP, runE, ParseResult(..), parseFail, showPWarning, - Field(..), lineNo, - FieldDescr(..), readFields, readFieldsFlat, - parseHaskellString, parseFilePathQ, parseTokenQ, - parseOptCommaList, - showFilePath, showToken, showFreeText, - field, simpleField, listField, listFieldWithSep, spaceListField, - newLineListField, - liftField, - readPToMaybe, - - fieldParsec, simpleFieldParsec, - listFieldParsec, - commaListFieldParsec, - commaNewLineListFieldParsec, - - UnrecFieldParser, - ) where - -import Distribution.Client.Compat.Prelude hiding (get) -import Prelude () - -import Distribution.Deprecated.ReadP as ReadP hiding (get) - -import Distribution.Pretty -import Distribution.ReadE -import Distribution.Utils.Generic - -import Data.Tree as Tree (Tree (..), flatten) -import System.FilePath (normalise) -import Text.PrettyPrint (Doc, punctuate, comma, fsep, sep) -import qualified Text.Read as Read - -import qualified Control.Monad.Fail as Fail -import Distribution.Parsec (ParsecParser, parsecLeadingCommaList, parsecLeadingOptCommaList) - --- ----------------------------------------------------------------------------- - -type LineNo = Int - -data PError = AmbiguousParse String LineNo - | NoParse String LineNo - | TabsError LineNo - | FromString String (Maybe LineNo) - deriving (Eq, Show) - -data PWarning = PWarning String - | UTFWarning LineNo String - deriving (Eq, Show) - -showPWarning :: FilePath -> PWarning -> String -showPWarning fpath (PWarning msg) = - normalise fpath ++ ": " ++ msg -showPWarning fpath (UTFWarning line fname) = - normalise fpath ++ ":" ++ show line - ++ ": Invalid UTF-8 text in the '" ++ fname ++ "' field." - -data ParseResult a = ParseFailed PError | ParseOk [PWarning] a - deriving Show - -instance Functor ParseResult where - fmap _ (ParseFailed err) = ParseFailed err - fmap f (ParseOk ws x) = ParseOk ws $ f x - -instance Applicative ParseResult where - pure = ParseOk [] - (<*>) = ap - - -instance Monad ParseResult where - return = pure - ParseFailed err >>= _ = ParseFailed err - ParseOk ws x >>= f = case f x of - ParseFailed err -> ParseFailed err - ParseOk ws' x' -> ParseOk (ws'++ws) x' - -#if !(MIN_VERSION_base(4,9,0)) - fail = parseResultFail -#elif !(MIN_VERSION_base(4,13,0)) - fail = Fail.fail -#endif - -instance Fail.MonadFail ParseResult where - fail = parseResultFail - -parseResultFail :: String -> ParseResult a -parseResultFail s = parseFail (FromString s Nothing) - -parseFail :: PError -> ParseResult a -parseFail = ParseFailed - -runP :: LineNo -> String -> ReadP a a -> String -> ParseResult a -runP line fieldname p s = - case [ x | (x,"") <- results ] of - [a] -> ParseOk (utf8Warnings line fieldname s) a - --TODO: what is this double parse thing all about? - -- Can't we just do the all isSpace test the first time? - [] -> case [ x | (x,ys) <- results, all isSpace ys ] of - [a] -> ParseOk (utf8Warnings line fieldname s) a - [] -> ParseFailed (NoParse fieldname line) - _ -> ParseFailed (AmbiguousParse fieldname line) - _ -> ParseFailed (AmbiguousParse fieldname line) - where results = readP_to_S p s - -runE :: LineNo -> String -> ReadE a -> String -> ParseResult a -runE line fieldname p s = - case runReadE p s of - Right a -> ParseOk (utf8Warnings line fieldname s) a - Left e -> syntaxError line $ - "Parse of field '" ++ fieldname ++ "' failed (" ++ e ++ "): " ++ s - -utf8Warnings :: LineNo -> String -> String -> [PWarning] -utf8Warnings line fieldname s = - take 1 [ UTFWarning n fieldname - | (n,l) <- zip [line..] (lines s) - , '\xfffd' `elem` l ] - -locatedErrorMsg :: PError -> (Maybe LineNo, String) -locatedErrorMsg (AmbiguousParse f n) = (Just n, - "Ambiguous parse in field '"++f++"'.") -locatedErrorMsg (NoParse f n) = (Just n, - "Parse of field '"++f++"' failed.") -locatedErrorMsg (TabsError n) = (Just n, "Tab used as indentation.") -locatedErrorMsg (FromString s n) = (n, s) - -syntaxError :: LineNo -> String -> ParseResult a -syntaxError n s = ParseFailed $ FromString s (Just n) - -tabsError :: LineNo -> ParseResult a -tabsError ln = ParseFailed $ TabsError ln - -warning :: String -> ParseResult () -warning s = ParseOk [PWarning s] () - --- | Field descriptor. The parameter @a@ parameterizes over where the field's --- value is stored in. -data FieldDescr a - = FieldDescr - { fieldName :: String - , fieldGet :: a -> Doc - , fieldSet :: LineNo -> String -> a -> ParseResult a - -- ^ @fieldSet n str x@ Parses the field value from the given input - -- string @str@ and stores the result in @x@ if the parse was - -- successful. Otherwise, reports an error on line number @n@. - } - -field :: String -> (a -> Doc) -> ReadP a a -> FieldDescr a -field name showF readF = - FieldDescr name showF (\line val _st -> runP line name readF val) - -fieldParsec :: String -> (a -> Doc) -> ParsecParser a -> FieldDescr a -fieldParsec name showF readF = - FieldDescr name showF $ \line val _st -> case explicitEitherParsec readF val of - Left err -> ParseFailed (FromString err (Just line)) - Right x -> ParseOk [] x - --- Lift a field descriptor storing into an 'a' to a field descriptor storing --- into a 'b'. -liftField :: (b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b -liftField get set (FieldDescr name showF parseF) - = FieldDescr name (showF . get) - (\line str b -> do - a <- parseF line str (get b) - return (set a b)) - --- Parser combinator for simple fields. Takes a field name, a pretty printer, --- a parser function, an accessor, and a setter, returns a FieldDescr over the --- compoid structure. -simpleField :: String -> (a -> Doc) -> ReadP a a - -> (b -> a) -> (a -> b -> b) -> FieldDescr b -simpleField name showF readF get set - = liftField get set $ field name showF readF - -simpleFieldParsec :: String -> (a -> Doc) -> ParsecParser a - -> (b -> a) -> (a -> b -> b) -> FieldDescr b -simpleFieldParsec name showF readF get set - = liftField get set $ fieldParsec name showF readF - -commaListFieldWithSepParsec :: Separator -> String -> (a -> Doc) -> ParsecParser a - -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b -commaListFieldWithSepParsec separator name showF readF get set = - liftField get set' $ - fieldParsec name showF' (parsecLeadingCommaList readF) - where - set' xs b = set (get b ++ xs) b - showF' = separator . punctuate comma . map showF - -commaListFieldParsec :: String -> (a -> Doc) -> ParsecParser a - -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b -commaListFieldParsec = commaListFieldWithSepParsec fsep - -commaNewLineListFieldParsec - :: String -> (a -> Doc) -> ParsecParser a - -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b -commaNewLineListFieldParsec = commaListFieldWithSepParsec sep - -spaceListField :: String -> (a -> Doc) -> ReadP [a] a - -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b -spaceListField name showF readF get set = - liftField get set' $ - field name showF' (parseSpaceList readF) - where - set' xs b = set (get b ++ xs) b - showF' = fsep . map showF - --- this is a different definition from listField, like --- commaNewLineListField it pretty prints on multiple lines -newLineListField :: String -> (a -> Doc) -> ReadP [a] a - -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b -newLineListField = listFieldWithSep sep - -listFieldWithSep :: Separator -> String -> (a -> Doc) -> ReadP [a] a - -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b -listFieldWithSep separator name showF readF get set = - liftField get set' $ - field name showF' (parseOptCommaList readF) - where - set' xs b = set (get b ++ xs) b - showF' = separator . map showF - -listFieldWithSepParsec :: Separator -> String -> (a -> Doc) -> ParsecParser a - -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b -listFieldWithSepParsec separator name showF readF get set = - liftField get set' $ - fieldParsec name showF' (parsecLeadingOptCommaList readF) - where - set' xs b = set (get b ++ xs) b - showF' = separator . map showF - -listField :: String -> (a -> Doc) -> ReadP [a] a - -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b -listField = listFieldWithSep fsep - -listFieldParsec - :: String -> (a -> Doc) -> ParsecParser a - -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b -listFieldParsec = listFieldWithSepParsec fsep - --- | The type of a function which, given a name-value pair of an --- unrecognized field, and the current structure being built, --- decides whether to incorporate the unrecognized field --- (by returning Just x, where x is a possibly modified version --- of the structure being built), or not (by returning Nothing). -type UnrecFieldParser a = (String,String) -> a -> Maybe a - ------------------------------------------------------------------------------- - --- The data type for our three syntactic categories -data Field - = F LineNo String String - -- ^ A regular @: @ field - | Section LineNo String String [Field] - -- ^ A section with a name and possible parameter. The syntactic - -- structure is: - -- - -- @ - -- { - -- * - -- } - -- @ - | IfBlock LineNo String [Field] [Field] - -- ^ A conditional block with an optional else branch: - -- - -- @ - -- if { - -- * - -- } else { - -- * - -- } - -- @ - deriving (Show - ,Eq) -- for testing - -lineNo :: Field -> LineNo -lineNo (F n _ _) = n -lineNo (Section n _ _ _) = n -lineNo (IfBlock n _ _ _) = n - -readFields :: String -> ParseResult [Field] -readFields input = ifelse - =<< traverse (mkField 0) - =<< mkTree tokens - - where ls = (lines . normaliseLineEndings) input - tokens = (concatMap tokeniseLine . trimLines) ls - -readFieldsFlat :: String -> ParseResult [Field] -readFieldsFlat input = traverse (mkField 0) - =<< mkTree tokens - where ls = (lines . normaliseLineEndings) input - tokens = (concatMap tokeniseLineFlat . trimLines) ls - --- attach line number and determine indentation -trimLines :: [String] -> [(LineNo, Indent, HasTabs, String)] -trimLines ls = [ (lineno, indent, hastabs, trimTrailing l') - | (lineno, l) <- zip [1..] ls - , let (sps, l') = span isSpace l - indent = length sps - hastabs = '\t' `elem` sps - , validLine l' ] - where validLine ('-':'-':_) = False -- Comment - validLine [] = False -- blank line - validLine _ = True - --- | We parse generically based on indent level and braces '{' '}'. To do that --- we split into lines and then '{' '}' tokens and other spans within a line. -data Token = - -- | The 'Line' token is for bits that /start/ a line, eg: - -- - -- > "\n blah blah { blah" - -- - -- tokenises to: - -- - -- > [Line n 2 False "blah blah", OpenBracket, Span n "blah"] - -- - -- so lines are the only ones that can have nested layout, since they - -- have a known indentation level. - -- - -- eg: we can't have this: - -- - -- > if ... { - -- > } else - -- > other - -- - -- because other cannot nest under else, since else doesn't start a line - -- so cannot have nested layout. It'd have to be: - -- - -- > if ... { - -- > } - -- > else - -- > other - -- - -- but that's not so common, people would normally use layout or - -- brackets not both in a single @if else@ construct. - -- - -- > if ... { foo : bar } - -- > else - -- > other - -- - -- this is OK - Line LineNo Indent HasTabs String - | Span LineNo String -- ^ span in a line, following brackets - | OpenBracket LineNo | CloseBracket LineNo - -type Indent = Int -type HasTabs = Bool - --- | Tokenise a single line, splitting on '{' '}' and the spans in between. --- Also trims leading & trailing space on those spans within the line. -tokeniseLine :: (LineNo, Indent, HasTabs, String) -> [Token] -tokeniseLine (n0, i, t, l) = case split n0 l of - (Span _ l':ss) -> Line n0 i t l' :ss - cs -> cs - where split _ "" = [] - split n s = case span (\c -> c /='}' && c /= '{') s of - ("", '{' : s') -> OpenBracket n : split n s' - (w , '{' : s') -> mkspan n w (OpenBracket n : split n s') - ("", '}' : s') -> CloseBracket n : split n s' - (w , '}' : s') -> mkspan n w (CloseBracket n : split n s') - (w , _) -> mkspan n w [] - - mkspan n s ss | null s' = ss - | otherwise = Span n s' : ss - where s' = trimTrailing (trimLeading s) - -tokeniseLineFlat :: (LineNo, Indent, HasTabs, String) -> [Token] -tokeniseLineFlat (n0, i, t, l) - | null l' = [] - | otherwise = [Line n0 i t l'] - where - l' = trimTrailing (trimLeading l) - -trimLeading, trimTrailing :: String -> String -trimLeading = dropWhile isSpace -trimTrailing = dropWhileEndLE isSpace - - -type SyntaxTree = Tree (LineNo, HasTabs, String) - --- | Parse the stream of tokens into a tree of them, based on indent \/ layout -mkTree :: [Token] -> ParseResult [SyntaxTree] -mkTree toks = - layout 0 [] toks >>= \(trees, trailing) -> case trailing of - [] -> return trees - OpenBracket n:_ -> syntaxError n "mismatched brackets, unexpected {" - CloseBracket n:_ -> syntaxError n "mismatched brackets, unexpected }" - -- the following two should never happen: - Span n l :_ -> syntaxError n $ "unexpected span: " ++ show l - Line n _ _ l :_ -> syntaxError n $ "unexpected line: " ++ show l - - --- | Parse the stream of tokens into a tree of them, based on indent --- This parse state expect to be in a layout context, though possibly --- nested within a braces context so we may still encounter closing braces. -layout :: Indent -- ^ indent level of the parent\/previous line - -> [SyntaxTree] -- ^ accumulating param, trees in this level - -> [Token] -- ^ remaining tokens - -> ParseResult ([SyntaxTree], [Token]) - -- ^ collected trees on this level and trailing tokens -layout _ a [] = return (reverse a, []) -layout i a (s@(Line _ i' _ _):ss) | i' < i = return (reverse a, s:ss) -layout i a (Line n _ t l:OpenBracket n':ss) = do - (sub, ss') <- braces n' [] ss - layout i (Node (n,t,l) sub:a) ss' - -layout i a (Span n l:OpenBracket n':ss) = do - (sub, ss') <- braces n' [] ss - layout i (Node (n,False,l) sub:a) ss' - --- look ahead to see if following lines are more indented, giving a sub-tree -layout i a (Line n i' t l:ss) = do - lookahead <- layout (i'+1) [] ss - case lookahead of - ([], _) -> layout i (Node (n,t,l) [] :a) ss - (ts, ss') -> layout i (Node (n,t,l) ts :a) ss' - -layout _ _ ( OpenBracket n :_) = syntaxError n "unexpected '{'" -layout _ a (s@(CloseBracket _):ss) = return (reverse a, s:ss) -layout _ _ ( Span n l : _) = syntaxError n $ "unexpected span: " - ++ show l - --- | Parse the stream of tokens into a tree of them, based on explicit braces --- This parse state expects to find a closing bracket. -braces :: LineNo -- ^ line of the '{', used for error messages - -> [SyntaxTree] -- ^ accumulating param, trees in this level - -> [Token] -- ^ remaining tokens - -> ParseResult ([SyntaxTree],[Token]) - -- ^ collected trees on this level and trailing tokens -braces m a (Line n _ t l:OpenBracket n':ss) = do - (sub, ss') <- braces n' [] ss - braces m (Node (n,t,l) sub:a) ss' - -braces m a (Span n l:OpenBracket n':ss) = do - (sub, ss') <- braces n' [] ss - braces m (Node (n,False,l) sub:a) ss' - -braces m a (Line n i t l:ss) = do - lookahead <- layout (i+1) [] ss - case lookahead of - ([], _) -> braces m (Node (n,t,l) [] :a) ss - (ts, ss') -> braces m (Node (n,t,l) ts :a) ss' - -braces m a (Span n l:ss) = braces m (Node (n,False,l) []:a) ss -braces _ a (CloseBracket _:ss) = return (reverse a, ss) -braces n _ [] = syntaxError n $ "opening brace '{'" - ++ "has no matching closing brace '}'" -braces _ _ (OpenBracket n:_) = syntaxError n "unexpected '{'" - --- | Convert the parse tree into the Field AST --- Also check for dodgy uses of tabs in indentation. -mkField :: Int -> SyntaxTree -> ParseResult Field -mkField d (Node (n,t,_) _) | d >= 1 && t = tabsError n -mkField d (Node (n,_,l) ts) = case span (\c -> isAlphaNum c || c == '-') l of - ([], _) -> syntaxError n $ "unrecognised field or section: " ++ show l - (name, rest) -> case trimLeading rest of - (':':rest') -> do let followingLines = concatMap Tree.flatten ts - tabs = not (null [()| (_,True,_) <- followingLines ]) - if tabs && d >= 1 - then tabsError n - else return $ F n (map toLower name) - (fieldValue rest' followingLines) - rest' -> do ts' <- traverse (mkField (d+1)) ts - return (Section n (map toLower name) rest' ts') - where fieldValue firstLine followingLines = - let firstLine' = trimLeading firstLine - followingLines' = map (\(_,_,s) -> stripDot s) followingLines - allLines | null firstLine' = followingLines' - | otherwise = firstLine' : followingLines' - in intercalate "\n" allLines - stripDot "." = "" - stripDot s = s - --- | Convert if/then/else 'Section's to 'IfBlock's -ifelse :: [Field] -> ParseResult [Field] -ifelse [] = return [] -ifelse (Section n "if" cond thenpart - :Section _ "else" as elsepart:fs) - | null cond = syntaxError n "'if' with missing condition" - | null thenpart = syntaxError n "'then' branch of 'if' is empty" - | not (null as) = syntaxError n "'else' takes no arguments" - | null elsepart = syntaxError n "'else' branch of 'if' is empty" - | otherwise = do tp <- ifelse thenpart - ep <- ifelse elsepart - fs' <- ifelse fs - return (IfBlock n cond tp ep:fs') -ifelse (Section n "if" cond thenpart:fs) - | null cond = syntaxError n "'if' with missing condition" - | null thenpart = syntaxError n "'then' branch of 'if' is empty" - | otherwise = do tp <- ifelse thenpart - fs' <- ifelse fs - return (IfBlock n cond tp []:fs') -ifelse (Section n "else" _ _:_) = syntaxError n - "stray 'else' with no preceding 'if'" -ifelse (Section n s a fs':fs) = do fs'' <- ifelse fs' - fs''' <- ifelse fs - return (Section n s a fs'' : fs''') -ifelse (f:fs) = do fs' <- ifelse fs - return (f : fs') - ------------------------------------------------------------------------------- - -parseFilePathQ :: ReadP r FilePath -parseFilePathQ = parseTokenQ - -- removed until normalise is no longer broken, was: - -- liftM normalise parseTokenQ - --- urgh, we can't define optQuotes :: ReadP r a -> ReadP r a --- because the "compat" version of ReadP isn't quite powerful enough. In --- particular, the type of <++ is ReadP r r -> ReadP r a -> ReadP r a --- Hence the trick above to make 'lic' polymorphic. - --- Different than the naive version. it turns out Read instance for String accepts --- the ['a', 'b'] syntax, which we do not want. In particular it messes --- up any token starting with []. -parseHaskellString :: ReadP r String -parseHaskellString = - readS_to_P $ - Read.readPrec_to_S (do Read.String s <- Read.lexP; return s) 0 - -parseTokenQ :: ReadP r String -parseTokenQ = parseHaskellString <++ munch1 (\x -> not (isSpace x) && x /= ',') - -parseSpaceList :: ReadP r a -- ^The parser for the stuff between commas - -> ReadP r [a] -parseSpaceList p = sepBy p skipSpaces - --- This version avoid parse ambiguity for list element parsers --- that have multiple valid parses of prefixes. -parseOptCommaList :: ReadP r a -> ReadP r [a] -parseOptCommaList p = sepBy p localSep - where - -- The separator must not be empty or it introduces ambiguity - localSep = (skipSpaces >> char ',' >> skipSpaces) - +++ (satisfy isSpace >> skipSpaces) - -readPToMaybe :: ReadP a a -> String -> Maybe a -readPToMaybe p str = listToMaybe [ r | (r,s) <- readP_to_S p str - , all isSpace s ] diff --git a/cabal/cabal-install/Distribution/Deprecated/ReadP.hs b/cabal/cabal-install/Distribution/Deprecated/ReadP.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Deprecated/ReadP.hs +++ /dev/null @@ -1,480 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE GADTs #-} ------------------------------------------------------------------------------ --- | --- --- Module : Distribution.Deprecated.ReadP --- Copyright : (c) The University of Glasgow 2002 --- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : libraries@haskell.org --- Portability : portable --- --- This is a library of parser combinators, originally written by Koen Claessen. --- It parses all alternatives in parallel, so it never keeps hold of --- the beginning of the input string, a common source of space leaks with --- other parsers. The '(+++)' choice combinator is genuinely commutative; --- it makes no difference which branch is \"shorter\". --- --- See also Koen's paper /Parallel Parsing Processes/ --- (). --- --- This version of ReadP has been locally hacked to make it H98, by --- Martin Sjögren --- --- The unit tests have been moved to UnitTest.Distribution.Deprecated.ReadP, by --- Mark Lentczner ------------------------------------------------------------------------------ - -module Distribution.Deprecated.ReadP - ( - -- * The 'ReadP' type - ReadP, -- :: * -> *; instance Functor, Monad, MonadPlus - - -- * Primitive operations - get, -- :: ReadP Char - look, -- :: ReadP String - (+++), -- :: ReadP a -> ReadP a -> ReadP a - (<++), -- :: ReadP a -> ReadP a -> ReadP a - gather, -- :: ReadP a -> ReadP (String, a) - - -- * Other operations - pfail, -- :: ReadP a - eof, -- :: ReadP () - satisfy, -- :: (Char -> Bool) -> ReadP Char - char, -- :: Char -> ReadP Char - string, -- :: String -> ReadP String - munch, -- :: (Char -> Bool) -> ReadP String - munch1, -- :: (Char -> Bool) -> ReadP String - skipSpaces, -- :: ReadP () - skipSpaces1,-- :: ReadP () - choice, -- :: [ReadP a] -> ReadP a - count, -- :: Int -> ReadP a -> ReadP [a] - between, -- :: ReadP open -> ReadP close -> ReadP a -> ReadP a - option, -- :: a -> ReadP a -> ReadP a - optional, -- :: ReadP a -> ReadP () - many, -- :: ReadP a -> ReadP [a] - many1, -- :: ReadP a -> ReadP [a] - skipMany, -- :: ReadP a -> ReadP () - skipMany1, -- :: ReadP a -> ReadP () - sepBy, -- :: ReadP a -> ReadP sep -> ReadP [a] - sepBy1, -- :: ReadP a -> ReadP sep -> ReadP [a] - endBy, -- :: ReadP a -> ReadP sep -> ReadP [a] - endBy1, -- :: ReadP a -> ReadP sep -> ReadP [a] - chainr, -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a - chainl, -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a - chainl1, -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a - chainr1, -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a - manyTill, -- :: ReadP a -> ReadP end -> ReadP [a] - - -- * Running a parser - ReadS, -- :: *; = String -> [(a,String)] - readP_to_S, -- :: ReadP a -> ReadS a - readS_to_P, -- :: ReadS a -> ReadP a - readP_to_E, - - -- ** Internal - Parser, - ) - where - -import Prelude () -import Distribution.Client.Compat.Prelude hiding (many, get) - -import Control.Monad( replicateM, (>=>) ) - -import qualified Control.Monad.Fail as Fail - -import Distribution.CabalSpecVersion (cabalSpecLatest) -import qualified Distribution.Compat.CharParsing as P -import qualified Distribution.Parsec as P - -import Distribution.ReadE (ReadE (..)) - -infixr 5 +++, <++ - --- --------------------------------------------------------------------------- --- The P type --- is representation type -- should be kept abstract - -data P s a - = Get (s -> P s a) - | Look ([s] -> P s a) - | Fail - | Result a (P s a) - | Final [(a,[s])] -- invariant: list is non-empty! - --- Monad, MonadPlus - -instance Functor (P s) where - fmap = liftM - -instance Applicative (P s) where - pure x = Result x Fail - (<*>) = ap - -instance Monad (P s) where - return = pure - - (Get f) >>= k = Get (f >=> k) - (Look f) >>= k = Look (f >=> k) - Fail >>= _ = Fail - (Result x p) >>= k = k x `mplus` (p >>= k) - (Final r) >>= k = final [ys' | (x,s) <- r, ys' <- run (k x) s] - -#if !(MIN_VERSION_base(4,9,0)) - fail _ = Fail -#elif !(MIN_VERSION_base(4,13,0)) - fail = Fail.fail -#endif - -instance Fail.MonadFail (P s) where - fail _ = Fail - -instance Alternative (P s) where - empty = mzero - (<|>) = mplus - -instance MonadPlus (P s) where - mzero = Fail - - -- most common case: two gets are combined - Get f1 `mplus` Get f2 = Get (\c -> f1 c `mplus` f2 c) - - -- results are delivered as soon as possible - Result x p `mplus` q = Result x (p `mplus` q) - p `mplus` Result x q = Result x (p `mplus` q) - - -- fail disappears - Fail `mplus` p = p - p `mplus` Fail = p - - -- two finals are combined - -- final + look becomes one look and one final (=optimization) - -- final + sthg else becomes one look and one final - Final r `mplus` Final t = Final (r ++ t) - Final r `mplus` Look f = Look (\s -> Final (r ++ run (f s) s)) - Final r `mplus` p = Look (\s -> Final (r ++ run p s)) - Look f `mplus` Final r = Look (\s -> Final (run (f s) s ++ r)) - p `mplus` Final r = Look (\s -> Final (run p s ++ r)) - - -- two looks are combined (=optimization) - -- look + sthg else floats upwards - Look f `mplus` Look g = Look (\s -> f s `mplus` g s) - Look f `mplus` p = Look (\s -> f s `mplus` p) - p `mplus` Look f = Look (\s -> p `mplus` f s) - --- --------------------------------------------------------------------------- --- The ReadP type - -newtype Parser r s a = R ((a -> P s r) -> P s r) -type ReadP r a = Parser r Char a - --- Functor, Monad, MonadPlus - -instance Functor (Parser r s) where - fmap h (R f) = R (\k -> f (k . h)) - -instance Applicative (Parser r s) where - pure x = R (\k -> k x) - (<*>) = ap - -instance s ~ Char => Alternative (Parser r s) where - empty = pfail - (<|>) = (+++) - -instance Monad (Parser r s) where - return = pure - R m >>= f = R (\k -> m (\a -> let R m' = f a in m' k)) - -#if !(MIN_VERSION_base(4,9,0)) - fail _ = R (const Fail) -#elif !(MIN_VERSION_base(4,13,0)) - fail = Fail.fail -#endif - -instance Fail.MonadFail (Parser r s) where - fail _ = R (const Fail) - -instance s ~ Char => MonadPlus (Parser r s) where - mzero = pfail - mplus = (+++) - --- --------------------------------------------------------------------------- --- Operations over P - -final :: [(a,[s])] -> P s a --- Maintains invariant for Final constructor -final [] = Fail -final r = Final r - -run :: P c a -> ([c] -> [(a, [c])]) -run (Get f) (c:s) = run (f c) s -run (Look f) s = run (f s) s -run (Result x p) s = (x,s) : run p s -run (Final r) _ = r -run _ _ = [] - --- --------------------------------------------------------------------------- --- Operations over ReadP - -get :: ReadP r Char --- ^ Consumes and returns the next character. --- Fails if there is no input left. -get = R Get - -look :: ReadP r String --- ^ Look-ahead: returns the part of the input that is left, without --- consuming it. -look = R Look - -pfail :: ReadP r a --- ^ Always fails. -pfail = R (const Fail) - -eof :: ReadP r () --- ^ Succeeds iff we are at the end of input -eof = do { s <- look - ; if null s then return () - else pfail } - -(+++) :: ReadP r a -> ReadP r a -> ReadP r a --- ^ Symmetric choice. -R f1 +++ R f2 = R (\k -> f1 k `mplus` f2 k) - -(<++) :: ReadP a a -> ReadP r a -> ReadP r a --- ^ Local, exclusive, left-biased choice: If left parser --- locally produces any result at all, then right parser is --- not used. -R f <++ q = - do s <- look - probe (f return) s 0 - where - probe (Get f') (c:s) n = probe (f' c) s (n+1 :: Int) - probe (Look f') s n = probe (f' s) s n - probe p@(Result _ _) _ n = discard n >> R (p >>=) - probe (Final r) _ _ = R (Final r >>=) - probe _ _ _ = q - - discard 0 = return () - discard n = get >> discard (n-1 :: Int) - -gather :: ReadP (String -> P Char r) a -> ReadP r (String, a) --- ^ Transforms a parser into one that does the same, but --- in addition returns the exact characters read. --- IMPORTANT NOTE: 'gather' gives a runtime error if its first argument --- is built using any occurrences of readS_to_P. -gather (R m) = - R (\k -> gath id (m (\a -> return (\s -> k (s,a))))) - where - gath l (Get f) = Get (\c -> gath (l.(c:)) (f c)) - gath _ Fail = Fail - gath l (Look f) = Look (gath l . f) - gath l (Result k p) = k (l []) `mplus` gath l p - gath _ (Final _) = error "do not use readS_to_P in gather!" - --- --------------------------------------------------------------------------- --- Derived operations - -satisfy :: (Char -> Bool) -> ReadP r Char --- ^ Consumes and returns the next character, if it satisfies the --- specified predicate. -satisfy p = do c <- get; if p c then return c else pfail - -char :: Char -> ReadP r Char --- ^ Parses and returns the specified character. -char c = satisfy (c ==) - -string :: String -> ReadP r String --- ^ Parses and returns the specified string. -string this = do s <- look; scan this s - where - scan [] _ = return this - scan (x:xs) (y:ys) | x == y = get >> scan xs ys - scan _ _ = pfail - -munch :: (Char -> Bool) -> ReadP r String --- ^ Parses the first zero or more characters satisfying the predicate. -munch p = - do s <- look - scan s - where - scan (c:cs) | p c = do _ <- get; s <- scan cs; return (c:s) - scan _ = do return "" - -munch1 :: (Char -> Bool) -> ReadP r String --- ^ Parses the first one or more characters satisfying the predicate. -munch1 p = - do c <- get - if p c then do s <- munch p; return (c:s) - else pfail - -choice :: [ReadP r a] -> ReadP r a --- ^ Combines all parsers in the specified list. -choice [] = pfail -choice [p] = p -choice (p:ps) = p +++ choice ps - -skipSpaces :: ReadP r () --- ^ Skips all whitespace. -skipSpaces = - do s <- look - skip s - where - skip (c:s) | isSpace c = do _ <- get; skip s - skip _ = do return () - -skipSpaces1 :: ReadP r () --- ^ Like 'skipSpaces' but succeeds only if there is at least one --- whitespace character to skip. -skipSpaces1 = satisfy isSpace >> skipSpaces - -count :: Int -> ReadP r a -> ReadP r [a] --- ^ @ count n p @ parses @n@ occurrences of @p@ in sequence. A list of --- results is returned. -count n p = replicateM n p - -between :: ReadP r open -> ReadP r close -> ReadP r a -> ReadP r a --- ^ @ between open close p @ parses @open@, followed by @p@ and finally --- @close@. Only the value of @p@ is returned. -between open close p = do _ <- open - x <- p - _ <- close - return x - -option :: a -> ReadP r a -> ReadP r a --- ^ @option x p@ will either parse @p@ or return @x@ without consuming --- any input. -option x p = p +++ return x - -optional :: ReadP r a -> ReadP r () --- ^ @optional p@ optionally parses @p@ and always returns @()@. -optional p = (p >> return ()) +++ return () - -many :: ReadP r a -> ReadP r [a] --- ^ Parses zero or more occurrences of the given parser. -many p = return [] +++ many1 p - -many1 :: ReadP r a -> ReadP r [a] --- ^ Parses one or more occurrences of the given parser. -many1 p = liftM2 (:) p (many p) - -skipMany :: ReadP r a -> ReadP r () --- ^ Like 'many', but discards the result. -skipMany p = many p >> return () - -skipMany1 :: ReadP r a -> ReadP r () --- ^ Like 'many1', but discards the result. -skipMany1 p = p >> skipMany p - -sepBy :: ReadP r a -> ReadP r sep -> ReadP r [a] --- ^ @sepBy p sep@ parses zero or more occurrences of @p@, separated by @sep@. --- Returns a list of values returned by @p@. -sepBy p sep = sepBy1 p sep +++ return [] - -sepBy1 :: ReadP r a -> ReadP r sep -> ReadP r [a] --- ^ @sepBy1 p sep@ parses one or more occurrences of @p@, separated by @sep@. --- Returns a list of values returned by @p@. -sepBy1 p sep = liftM2 (:) p (many (sep >> p)) - -endBy :: ReadP r a -> ReadP r sep -> ReadP r [a] --- ^ @endBy p sep@ parses zero or more occurrences of @p@, separated and ended --- by @sep@. -endBy p sep = many (do x <- p ; _ <- sep ; return x) - -endBy1 :: ReadP r a -> ReadP r sep -> ReadP r [a] --- ^ @endBy p sep@ parses one or more occurrences of @p@, separated and ended --- by @sep@. -endBy1 p sep = many1 (do x <- p ; _ <- sep ; return x) - -chainr :: ReadP r a -> ReadP r (a -> a -> a) -> a -> ReadP r a --- ^ @chainr p op x@ parses zero or more occurrences of @p@, separated by @op@. --- Returns a value produced by a /right/ associative application of all --- functions returned by @op@. If there are no occurrences of @p@, @x@ is --- returned. -chainr p op x = chainr1 p op +++ return x - -chainl :: ReadP r a -> ReadP r (a -> a -> a) -> a -> ReadP r a --- ^ @chainl p op x@ parses zero or more occurrences of @p@, separated by @op@. --- Returns a value produced by a /left/ associative application of all --- functions returned by @op@. If there are no occurrences of @p@, @x@ is --- returned. -chainl p op x = chainl1 p op +++ return x - -chainr1 :: ReadP r a -> ReadP r (a -> a -> a) -> ReadP r a --- ^ Like 'chainr', but parses one or more occurrences of @p@. -chainr1 p op = scan - where scan = p >>= rest - rest x = do f <- op - y <- scan - return (f x y) - +++ return x - -chainl1 :: ReadP r a -> ReadP r (a -> a -> a) -> ReadP r a --- ^ Like 'chainl', but parses one or more occurrences of @p@. -chainl1 p op = p >>= rest - where rest x = do f <- op - y <- p - rest (f x y) - +++ return x - -manyTill :: ReadP r a -> ReadP [a] end -> ReadP r [a] --- ^ @manyTill p end@ parses zero or more occurrences of @p@, until @end@ --- succeeds. Returns a list of values returned by @p@. -manyTill p end = scan - where scan = (end >> return []) <++ (liftM2 (:) p scan) - --- --------------------------------------------------------------------------- --- Converting between ReadP and Read - -readP_to_S :: ReadP a a -> ReadS a --- ^ Converts a parser into a Haskell ReadS-style function. --- This is the main way in which you can \"run\" a 'ReadP' parser: --- the expanded type is --- @ readP_to_S :: ReadP a -> String -> [(a,String)] @ -readP_to_S (R f) = run (f return) - -readS_to_P :: ReadS a -> ReadP r a --- ^ Converts a Haskell ReadS-style function into a parser. --- Warning: This introduces local backtracking in the resulting --- parser, and therefore a possible inefficiency. -readS_to_P r = - R (\k -> Look (\s -> final [bs'' | (a,s') <- r s, bs'' <- run (k a) s'])) - -------------------------------------------------------------------------------- --- Instances -------------------------------------------------------------------------------- - -instance t ~ Char => P.Parsing (Parser r t) where - try = id - () = const - skipMany = skipMany - skipSome = skipMany1 - unexpected = const pfail - eof = eof - - -- TODO: we would like to have <++ here - notFollowedBy p = ((Just <$> p) +++ pure Nothing) - >>= maybe (pure ()) (P.unexpected . show) - -instance t ~ Char => P.CharParsing (Parser r t) where - satisfy = satisfy - char = char - notChar c = satisfy (/= c) - anyChar = get - string = string - -instance t ~ Char => P.CabalParsing (Parser r t) where - parsecWarning _ _ = pure () - askCabalSpecVersion = pure cabalSpecLatest - -------------------------------------------------------------------------------- --- ReadE -------------------------------------------------------------------------------- - -readP_to_E :: (String -> String) -> ReadP a a -> ReadE a -readP_to_E err r = - ReadE $ \txt -> case [ p | (p, s) <- readP_to_S r txt - , all isSpace s ] - of [] -> Left (err txt) - (p:_) -> Right p diff --git a/cabal/cabal-install/Distribution/Deprecated/ViewAsFieldDescr.hs b/cabal/cabal-install/Distribution/Deprecated/ViewAsFieldDescr.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Deprecated/ViewAsFieldDescr.hs +++ /dev/null @@ -1,84 +0,0 @@ -module Distribution.Deprecated.ViewAsFieldDescr ( - viewAsFieldDescr - ) where - -import Distribution.Client.Compat.Prelude hiding (get) -import Prelude () - -import qualified Data.List.NonEmpty as NE -import Distribution.ReadE (parsecToReadE) -import Distribution.Simple.Command -import Text.PrettyPrint (cat, comma, punctuate, text) -import Text.PrettyPrint as PP (empty) - -import Distribution.Deprecated.ParseUtils (FieldDescr (..), runE, syntaxError) - --- | to view as a FieldDescr, we sort the list of interfaces (Req > Bool > --- Choice > Opt) and consider only the first one. -viewAsFieldDescr :: OptionField a -> FieldDescr a -viewAsFieldDescr (OptionField _n []) = - error "Distribution.command.viewAsFieldDescr: unexpected" -viewAsFieldDescr (OptionField n (d:dd)) = FieldDescr n get set - - where - optDescr = head $ NE.sortBy cmp (d:|dd) - - cmp :: OptDescr a -> OptDescr a -> Ordering - ReqArg{} `cmp` ReqArg{} = EQ - ReqArg{} `cmp` _ = GT - BoolOpt{} `cmp` ReqArg{} = LT - BoolOpt{} `cmp` BoolOpt{} = EQ - BoolOpt{} `cmp` _ = GT - ChoiceOpt{} `cmp` ReqArg{} = LT - ChoiceOpt{} `cmp` BoolOpt{} = LT - ChoiceOpt{} `cmp` ChoiceOpt{} = EQ - ChoiceOpt{} `cmp` _ = GT - OptArg{} `cmp` OptArg{} = EQ - OptArg{} `cmp` _ = LT - --- get :: a -> Doc - get t = case optDescr of - ReqArg _ _ _ _ ppr -> - (cat . punctuate comma . map text . ppr) t - - OptArg _ _ _ _ _ ppr -> - case ppr t of [] -> PP.empty - (Nothing : _) -> text "True" - (Just a : _) -> text a - - ChoiceOpt alts -> - fromMaybe PP.empty $ listToMaybe - [ text lf | (_,(_,lf:_), _,enabled) <- alts, enabled t] - - BoolOpt _ _ _ _ enabled -> (maybe PP.empty pretty . enabled) t - --- set :: LineNo -> String -> a -> ParseResult a - set line val a = - case optDescr of - ReqArg _ _ _ readE _ -> ($ a) `liftM` runE line n readE val - -- We parse for a single value instead of a - -- list, as one can't really implement - -- parseList :: ReadE a -> ReadE [a] with - -- the current ReadE definition - ChoiceOpt{} -> - case getChoiceByLongFlag optDescr val of - Just f -> return (f a) - _ -> syntaxError line val - - BoolOpt _ _ _ setV _ -> (`setV` a) `liftM` runE line n (parsecToReadE ("" ++) parsec) val - - OptArg _ _ _ readE _ _ -> ($ a) `liftM` runE line n readE val - -- Optional arguments are parsed just like - -- required arguments here; we don't - -- provide a method to set an OptArg field - -- to the default value. - -getChoiceByLongFlag :: OptDescr a -> String -> Maybe (a -> a) -getChoiceByLongFlag (ChoiceOpt alts) val = listToMaybe - [ set | (_,(_sf,lf:_), set, _) <- alts - , lf == val] - -getChoiceByLongFlag _ _ = - error "Distribution.command.getChoiceByLongFlag: expected a choice option" - - diff --git a/cabal/cabal-install/Distribution/Solver/Compat/Prelude.hs b/cabal/cabal-install/Distribution/Solver/Compat/Prelude.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Solver/Compat/Prelude.hs +++ /dev/null @@ -1,19 +0,0 @@ --- to suppress WARNING in "Distribution.Compat.Prelude.Internal" -{-# OPTIONS_GHC -fno-warn-deprecations #-} - --- | This module does two things: --- --- * Acts as a compatibility layer, like @base-compat@. --- --- * Provides commonly used imports. --- --- This module is a superset of "Distribution.Compat.Prelude" (which --- this module re-exports) --- -module Distribution.Solver.Compat.Prelude - ( module Distribution.Compat.Prelude.Internal - , Prelude.IO - ) where - -import Prelude (IO) -import Distribution.Compat.Prelude.Internal hiding (IO) diff --git a/cabal/cabal-install/Distribution/Solver/Modular.hs b/cabal/cabal-install/Distribution/Solver/Modular.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Solver/Modular.hs +++ /dev/null @@ -1,338 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Distribution.Solver.Modular - ( modularResolver, SolverConfig(..), PruneAfterFirstSuccess(..) ) where - --- Here, we try to map between the external cabal-install solver --- interface and the internal interface that the solver actually --- expects. There are a number of type conversions to perform: we --- have to convert the package indices to the uniform index used --- by the solver; we also have to convert the initial constraints; --- and finally, we have to convert back the resulting install --- plan. - -import Prelude () -import Distribution.Solver.Compat.Prelude - -import qualified Data.Map as M -import Data.Set (isSubsetOf) -import Distribution.Compat.Graph - ( IsNode(..) ) -import Distribution.Compiler - ( CompilerInfo ) -import Distribution.Solver.Modular.Assignment - ( Assignment, toCPs ) -import Distribution.Solver.Modular.ConfiguredConversion - ( convCP ) -import qualified Distribution.Solver.Modular.ConflictSet as CS -import Distribution.Solver.Modular.Dependency -import Distribution.Solver.Modular.Flag -import Distribution.Solver.Modular.Index -import Distribution.Solver.Modular.IndexConversion - ( convPIs ) -import Distribution.Solver.Modular.Log - ( SolverFailure(..), displayLogMessages ) -import Distribution.Solver.Modular.Package - ( PN ) -import Distribution.Solver.Modular.RetryLog -import Distribution.Solver.Modular.Solver - ( SolverConfig(..), PruneAfterFirstSuccess(..), solve ) -import Distribution.Solver.Types.DependencyResolver -import Distribution.Solver.Types.LabeledPackageConstraint -import Distribution.Solver.Types.PackageConstraint -import Distribution.Solver.Types.PackagePath -import Distribution.Solver.Types.PackagePreferences -import Distribution.Solver.Types.PkgConfigDb - ( PkgConfigDb ) -import Distribution.Solver.Types.Progress -import Distribution.Solver.Types.Variable -import Distribution.System - ( Platform(..) ) -import Distribution.Simple.Setup - ( BooleanFlag(..) ) -import Distribution.Simple.Utils - ( ordNubBy ) -import Distribution.Verbosity - - --- | 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 = - fmap (uncurry postprocess) $ -- convert install plan - solve' sc cinfo idx pkgConfigDB pprefs gcs pns - where - -- Indices have to be converted into solver-specific uniform index. - idx = convPIs os arch cinfo 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 - --- | Run 'D.S.Modular.Solver.solve' and then produce a summarized log to display --- in the error case. --- --- When there is no solution, we produce the error message by rerunning the --- solver but making it prefer the goals from the final conflict set from the --- first run (or a subset of the final conflict set with --- --minimize-conflict-set). We also set the backjump limit to 0, so that the --- log stops at the first backjump and is relatively short. Preferring goals --- from the final conflict set increases the probability that the log to the --- first backjump contains package, flag, and stanza choices that are relevant --- to the final failure. The solver shouldn't need to choose any packages that --- aren't in the final conflict set. (For every variable in the final conflict --- set, the final conflict set should also contain the variable that introduced --- that variable. The solver can then follow that chain of variables in reverse --- order from the user target to the conflict.) However, it is possible that the --- conflict set contains unnecessary variables. --- --- Producing an error message when the solver reaches the backjump limit is more --- complicated. There is no final conflict set, so we create one for the minimal --- subtree containing the path that the solver took to the first backjump. This --- conflict set helps explain why the solver reached the backjump limit, because --- the first backjump contributes to reaching the backjump limit. Additionally, --- the solver is much more likely to be able to finish traversing this subtree --- before the backjump limit, since its size is linear (not exponential) in the --- number of goal choices. We create it by pruning all children after the first --- successful child under each node in the original tree, so that there is at --- most one valid choice at each level. Then we use the final conflict set from --- that run to generate an error message, as in the case where the solver found --- that there was no solution. --- --- Using the full log from a rerun of the solver ensures that the log is --- complete, i.e., it shows the whole chain of dependencies from the user --- targets to the conflicting packages. -solve' :: SolverConfig - -> CompilerInfo - -> Index - -> PkgConfigDb - -> (PN -> PackagePreferences) - -> Map PN [LabeledPackageConstraint] - -> Set PN - -> Progress String String (Assignment, RevDepMap) -solve' sc cinfo idx pkgConfigDB pprefs gcs pns = - toProgress $ retry (runSolver printFullLog sc) createErrorMsg - where - runSolver :: Bool -> SolverConfig - -> RetryLog String SolverFailure (Assignment, RevDepMap) - runSolver keepLog sc' = - displayLogMessages keepLog $ - solve sc' cinfo idx pkgConfigDB pprefs gcs pns - - createErrorMsg :: SolverFailure - -> RetryLog String String (Assignment, RevDepMap) - createErrorMsg failure@(ExhaustiveSearch cs cm) = - if asBool $ minimizeConflictSet sc - then continueWith ("Found no solution after exhaustively searching the " - ++ "dependency tree. Rerunning the dependency solver " - ++ "to minimize the conflict set ({" - ++ showConflictSet cs ++ "}).") $ - retry (tryToMinimizeConflictSet (runSolver printFullLog) sc cs cm) $ - \case - ExhaustiveSearch cs' cm' -> - fromProgress $ Fail $ - rerunSolverForErrorMsg cs' - ++ finalErrorMsg sc (ExhaustiveSearch cs' cm') - BackjumpLimitReached -> - fromProgress $ Fail $ - "Reached backjump limit while trying to minimize the " - ++ "conflict set to create a better error message. " - ++ "Original error message:\n" - ++ rerunSolverForErrorMsg cs - ++ finalErrorMsg sc failure - else fromProgress $ Fail $ - rerunSolverForErrorMsg cs ++ finalErrorMsg sc failure - createErrorMsg failure@BackjumpLimitReached = - continueWith - ("Backjump limit reached. Rerunning dependency solver to generate " - ++ "a final conflict set for the search tree containing the " - ++ "first backjump.") $ - retry (runSolver printFullLog sc { pruneAfterFirstSuccess = PruneAfterFirstSuccess True }) $ - \case - ExhaustiveSearch cs _ -> - fromProgress $ Fail $ - rerunSolverForErrorMsg cs ++ finalErrorMsg sc failure - BackjumpLimitReached -> - -- This case is possible when the number of goals involved in - -- conflicts is greater than the backjump limit. - fromProgress $ Fail $ finalErrorMsg sc failure - ++ "Failed to generate a summarized dependency solver " - ++ "log due to low backjump limit." - - rerunSolverForErrorMsg :: ConflictSet -> String - rerunSolverForErrorMsg cs = - let sc' = sc { - goalOrder = Just goalOrder' - , maxBackjumps = Just 0 - } - - -- Preferring goals from the conflict set takes precedence over the - -- original goal order. - goalOrder' = preferGoalsFromConflictSet cs <> fromMaybe mempty (goalOrder sc) - - in unlines ("Could not resolve dependencies:" : messages (toProgress (runSolver True sc'))) - - printFullLog = solverVerbosity sc >= verbose - - messages :: Progress step fail done -> [step] - messages = foldProgress (:) (const []) (const []) - --- | Try to remove variables from the given conflict set to create a minimal --- conflict set. --- --- Minimal means that no proper subset of the conflict set is also a conflict --- set, though there may be other possible conflict sets with fewer variables. --- This function minimizes the input by trying to remove one variable at a time. --- It only makes one pass over the variables, so it runs the solver at most N --- times when given a conflict set of size N. Only one pass is necessary, --- because every superset of a conflict set is also a conflict set, meaning that --- failing to remove variable X from a conflict set in one step means that X --- cannot be removed from any subset of that conflict set in a subsequent step. --- --- Example steps: --- --- Start with {A, B, C}. --- Try to remove A from {A, B, C} and fail. --- Try to remove B from {A, B, C} and succeed. --- Try to remove C from {A, C} and fail. --- Return {A, C} --- --- This function can fail for two reasons: --- --- 1. The solver can reach the backjump limit on any run. In this case the --- returned RetryLog ends with BackjumpLimitReached. --- TODO: Consider applying the backjump limit to all solver runs combined, --- instead of each individual run. For example, 10 runs with 10 backjumps --- each should count as 100 backjumps. --- 2. Since this function works by rerunning the solver, it is possible for the --- solver to add new unnecessary variables to the conflict set. This function --- discards the result from any run that adds new variables to the conflict --- set, but the end result may not be completely minimized. -tryToMinimizeConflictSet :: forall a . (SolverConfig -> RetryLog String SolverFailure a) - -> SolverConfig - -> ConflictSet - -> ConflictMap - -> RetryLog String SolverFailure a -tryToMinimizeConflictSet runSolver sc cs cm = - foldl (\r v -> retryNoSolution r $ tryToRemoveOneVar v) - (fromProgress $ Fail $ ExhaustiveSearch cs cm) - (CS.toList cs) - where - -- This function runs the solver and makes it prefer goals in the following - -- order: - -- - -- 1. variables in 'smallestKnownCS', excluding 'v' - -- 2. 'v' - -- 3. all other variables - -- - -- If 'v' is not necessary, then the solver will find that there is no - -- solution before starting to solve for 'v', and the new final conflict set - -- will be very likely to not contain 'v'. If 'v' is necessary, the solver - -- will most likely need to try solving for 'v' before finding that there is - -- no solution, and the new final conflict set will still contain 'v'. - -- However, this method isn't perfect, because it is possible for the solver - -- to add new unnecessary variables to the conflict set on any run. This - -- function prevents the conflict set from growing by checking that the new - -- conflict set is a subset of the old one and falling back to using the old - -- conflict set when that check fails. - tryToRemoveOneVar :: Var QPN - -> ConflictSet - -> ConflictMap - -> RetryLog String SolverFailure a - tryToRemoveOneVar v smallestKnownCS smallestKnownCM - -- Check whether v is still present, because it may have already been - -- removed in a previous solver rerun. - | not (v `CS.member` smallestKnownCS) = - fromProgress $ Fail $ ExhaustiveSearch smallestKnownCS smallestKnownCM - | otherwise = - continueWith ("Trying to remove variable " ++ varStr ++ " from the " - ++ "conflict set.") $ - retry (runSolver sc') $ \case - err@(ExhaustiveSearch cs' _) - | CS.toSet cs' `isSubsetOf` CS.toSet smallestKnownCS -> - let msg = if not $ CS.member v cs' - then "Successfully removed " ++ varStr ++ " from " - ++ "the conflict set." - else "Failed to remove " ++ varStr ++ " from the " - ++ "conflict set." - in -- Use the new conflict set, even if v wasn't removed, - -- because other variables may have been removed. - failWith (msg ++ " Continuing with " ++ showCS cs' ++ ".") err - | otherwise -> - failWith ("Failed to find a smaller conflict set. The new " - ++ "conflict set is not a subset of the previous " - ++ "conflict set: " ++ showCS cs') $ - ExhaustiveSearch smallestKnownCS smallestKnownCM - BackjumpLimitReached -> - failWith ("Reached backjump limit while minimizing conflict set.") - BackjumpLimitReached - where - varStr = "\"" ++ showVar v ++ "\"" - showCS cs' = "{" ++ showConflictSet cs' ++ "}" - - sc' = sc { goalOrder = Just goalOrder' } - - goalOrder' = - preferGoalsFromConflictSet (v `CS.delete` smallestKnownCS) - <> preferGoal v - <> fromMaybe mempty (goalOrder sc) - - -- Like 'retry', except that it only applies the input function when the - -- backjump limit has not been reached. - retryNoSolution :: RetryLog step SolverFailure done - -> (ConflictSet -> ConflictMap -> RetryLog step SolverFailure done) - -> RetryLog step SolverFailure done - retryNoSolution lg f = retry lg $ \case - ExhaustiveSearch cs' cm' -> f cs' cm' - BackjumpLimitReached -> fromProgress (Fail BackjumpLimitReached) - --- | Goal ordering that chooses goals contained in the conflict set before --- other goals. -preferGoalsFromConflictSet :: ConflictSet - -> Variable QPN -> Variable QPN -> Ordering -preferGoalsFromConflictSet cs = comparing $ \v -> not $ CS.member (toVar v) cs - --- | Goal ordering that chooses the given goal first. -preferGoal :: Var QPN -> Variable QPN -> Variable QPN -> Ordering -preferGoal preferred = comparing $ \v -> toVar v /= preferred - -toVar :: Variable QPN -> Var QPN -toVar (PackageVar qpn) = P qpn -toVar (FlagVar qpn fn) = F (FN qpn fn) -toVar (StanzaVar qpn sn) = S (SN qpn sn) - -finalErrorMsg :: SolverConfig -> SolverFailure -> String -finalErrorMsg sc failure = - case failure of - ExhaustiveSearch cs cm -> - "After searching the rest of the dependency tree exhaustively, " - ++ "these were the goals I've had most trouble fulfilling: " - ++ showCS cm cs - ++ flagSuggestion - where - showCS = if solverVerbosity sc > normal - then CS.showCSWithFrequency - else CS.showCSSortedByFrequency - flagSuggestion = - -- Don't suggest --minimize-conflict-set if the conflict set is - -- already small, because it is unlikely to be reduced further. - if CS.size cs > 3 && not (asBool (minimizeConflictSet sc)) - then "\nTry running with --minimize-conflict-set to improve the " - ++ "error message." - else "" - BackjumpLimitReached -> - "Backjump limit reached (" ++ currlimit (maxBackjumps sc) ++ - "change with --max-backjumps or try to run with --reorder-goals).\n" - where currlimit (Just n) = "currently " ++ show n ++ ", " - currlimit Nothing = "" diff --git a/cabal/cabal-install/Distribution/Solver/Modular/Assignment.hs b/cabal/cabal-install/Distribution/Solver/Modular/Assignment.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Solver/Modular/Assignment.hs +++ /dev/null @@ -1,95 +0,0 @@ -module Distribution.Solver.Modular.Assignment - ( Assignment(..) - , PAssignment - , FAssignment - , SAssignment - , toCPs - ) where - -import Prelude () -import Distribution.Solver.Compat.Prelude hiding (pi) - -import qualified Data.Array as A -import qualified Data.List as L -import qualified Data.Map as M - -import Data.Maybe (fromJust) - -import Distribution.PackageDescription (FlagAssignment, mkFlagAssignment) -- from Cabal - -import Distribution.Solver.Types.ComponentDeps (ComponentDeps, Component) -import qualified Distribution.Solver.Types.ComponentDeps as CD -import Distribution.Solver.Types.OptionalStanza -import Distribution.Solver.Types.PackagePath - -import Distribution.Solver.Modular.Configured -import Distribution.Solver.Modular.Dependency -import Distribution.Solver.Modular.Flag -import Distribution.Solver.Modular.LabeledGraph -import Distribution.Solver.Modular.Package - --- | A (partial) package assignment. Qualified package names --- are associated with instances. -type PAssignment = Map QPN I - -type FAssignment = Map QFN Bool -type SAssignment = Map QSN Bool - --- | A (partial) assignment of variables. -data Assignment = A PAssignment FAssignment SAssignment - deriving (Show, Eq) - --- | Delivers an ordered list of fully configured packages. --- --- TODO: This function is (sort of) ok. However, there's an open bug --- w.r.t. unqualification. There might be several different instances --- of one package version chosen by the solver, which will lead to --- clashes. -toCPs :: Assignment -> RevDepMap -> [CP QPN] -toCPs (A pa fa sa) rdm = - let - -- get hold of the graph - g :: Graph Component - vm :: Vertex -> ((), QPN, [(Component, QPN)]) - cvm :: QPN -> Maybe Vertex - -- Note that the RevDepMap contains duplicate dependencies. Therefore the nub. - (g, vm, cvm) = graphFromEdges (L.map (\ (x, xs) -> ((), x, nub xs)) - (M.toList rdm)) - tg :: Graph Component - tg = transposeG g - -- Topsort the dependency graph, yielding a list of pkgs in the right order. - -- The graph will still contain all the installed packages, and it might - -- contain duplicates, because several variables might actually resolve to - -- the same package in the presence of qualified package names. - ps :: [PI QPN] - ps = L.map ((\ (_, x, _) -> PI x (pa M.! x)) . vm) $ - topSort g - -- Determine the flags per package, by walking over and regrouping the - -- complete flag assignment by package. - fapp :: Map QPN FlagAssignment - fapp = M.fromListWith mappend $ - L.map (\ ((FN qpn fn), b) -> (qpn, mkFlagAssignment [(fn, b)])) $ - M.toList $ - fa - -- Stanzas per package. - sapp :: Map QPN [OptionalStanza] - sapp = M.fromListWith (++) $ - L.map (\ ((SN qpn sn), b) -> (qpn, if b then [sn] else [])) $ - M.toList $ - sa - -- Dependencies per package. - depp :: QPN -> [(Component, PI QPN)] - depp qpn = let v :: Vertex - v = fromJust (cvm qpn) -- TODO: why this is safe? - dvs :: [(Component, Vertex)] - dvs = tg A.! v - in L.map (\ (comp, dv) -> case vm dv of (_, x, _) -> (comp, PI x (pa M.! x))) dvs - -- Translated to PackageDeps - depp' :: QPN -> ComponentDeps [PI QPN] - depp' = CD.fromList . L.map (\(comp, d) -> (comp, [d])) . depp - in - L.map (\ pi@(PI qpn _) -> CP pi - (M.findWithDefault mempty qpn fapp) - (M.findWithDefault mempty qpn sapp) - (depp' qpn)) - ps diff --git a/cabal/cabal-install/Distribution/Solver/Modular/Builder.hs b/cabal/cabal-install/Distribution/Solver/Modular/Builder.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Solver/Modular/Builder.hs +++ /dev/null @@ -1,296 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -module Distribution.Solver.Modular.Builder ( - buildTree - , splits -- for testing - ) where - --- Building the search tree. --- --- In this phase, we build a search tree that is too large, i.e, it contains --- invalid solutions. We keep track of the open goals at each point. We --- nondeterministically pick an open goal (via a goal choice node), create --- subtrees according to the index and the available solutions, and extend the --- set of open goals by superficially looking at the dependencies recorded in --- the index. --- --- For each goal, we keep track of all the *reasons* why it is being --- introduced. These are for debugging and error messages, mainly. A little bit --- of care has to be taken due to the way we treat flags. If a package has --- flag-guarded dependencies, we cannot introduce them immediately. Instead, we --- store the entire dependency. - -import qualified Data.List as L -import qualified Data.Map as M -import qualified Data.Set as S -import Prelude - -import qualified Distribution.Solver.Modular.ConflictSet as CS -import Distribution.Solver.Modular.Dependency -import Distribution.Solver.Modular.Flag -import Distribution.Solver.Modular.Index -import Distribution.Solver.Modular.Package -import qualified Distribution.Solver.Modular.PSQ as P -import Distribution.Solver.Modular.Tree -import qualified Distribution.Solver.Modular.WeightedPSQ as W - -import Distribution.Solver.Types.ComponentDeps -import Distribution.Solver.Types.PackagePath -import Distribution.Solver.Types.Settings - --- | 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 --- the tree. -data Linker a = Linker { - buildState :: a, - linkingState :: LinkingState -} - --- | The state needed to build the search tree without creating any linked nodes. -data BuildState = BS { - index :: Index, -- ^ information about packages and their dependencies - rdeps :: RevDepMap, -- ^ set of all package goals, completed and open, with reverse dependencies - open :: [OpenGoal], -- ^ set of still open goals (flag and package goals) - next :: BuildType, -- ^ kind of node to generate next - qualifyOptions :: QualifyOptions -- ^ qualification options -} - --- | Map of available linking targets. -type LinkingState = M.Map (PN, I) [PackagePath] - --- | Extend the set of open goals with the new goals listed. --- --- 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 - 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. - 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 - - 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) - --- | Given the current scope, qualify all the package names in the given set of --- dependencies and then extend the set of open goals accordingly. -scopedExtendOpen :: QPN -> FlaggedDeps PN -> FlagInfo -> - BuildState -> BuildState -scopedExtendOpen qpn fdeps fdefs s = extendOpen qpn gs s - where - -- Qualify all package names - qfdeps = qualifyDeps (qualifyOptions s) 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 - gs = qfdefs ++ qfdeps - -- NOTE: - -- - -- In the expression @qfdefs ++ qfdeps@ above, flags occur potentially - -- multiple times, both via the flag declaration and via dependencies. - --- | Datatype that encodes what to build next -data BuildType = - Goals -- ^ build a goal choice node - | OneGoal OpenGoal -- ^ build a node for this goal - | Instance QPN PInfo -- ^ build a tree for a concrete instance - -build :: Linker BuildState -> Tree () QGoalReason -build = ana go - where - go :: Linker BuildState -> TreeF () QGoalReason (Linker BuildState) - go s = addLinking (linkingState s) $ addChildren (buildState s) - -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 }) - | L.null gs = DoneF rdm () - | otherwise = GoalChoiceF rdm $ P.fromList - $ L.map (\ (g, gs') -> (close g, bs { next = OneGoal g, open = gs' })) - $ splits gs - --- 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) - --- For a particular instance, we change the state: we update the scope, --- and furthermore we update the set of goals. --- --- TODO: We could inline this above. -addChildren bs@(BS { next = Instance qpn (PInfo fdeps _ fdefs _) }) = - addChildren ((scopedExtendOpen qpn fdeps fdefs bs) - { next = Goals }) - -{------------------------------------------------------------------------------- - Add linking --------------------------------------------------------------------------------} - --- | Introduce link nodes into the tree --- --- Linking is a phase that adapts package choice nodes and adds the option to --- link wherever appropriate: Package goals are called "related" if they are for --- the same instance of the same package (but have different prefixes). A link --- option is available in a package choice node whenever we can choose an --- instance that has already been chosen for a related goal at a higher position --- in the tree. We only create link options for related goals that are not --- themselves linked, because the choice to link to a linked goal is the same as --- the choice to link to the target of that goal's linking. --- --- The code here proceeds by maintaining a finite map recording choices that --- have been made at higher positions in the tree. For each pair of package name --- and instance, it stores the prefixes at which we have made a choice for this --- package instance. Whenever we make an unlinked choice, we extend the map. --- Whenever we find a choice, we look into the map in order to find out what --- link options we have to add. --- --- A separate tree traversal would be simpler. However, 'addLinking' creates --- linked nodes from existing unlinked nodes, which leads to sharing between the --- nodes. If we copied the nodes when they were full trees of type --- 'Tree () QGoalReason', then the sharing would cause a space leak during --- exploration of the tree. Instead, we only copy the 'BuildState', which is --- relatively small, while the tree is being constructed. See --- https://github.com/haskell/cabal/issues/2899 -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) $ - W.fromList $ concatMap (linkChoices ls qpn) (W.toList cs) - unlinkedCs = W.mapWithKey goP cs - allCs = unlinkedCs `W.union` linkedCs - - -- Recurse underneath package choices. Here we just need to make sure - -- that we record the package choice so that it is available below - goP :: POption -> a -> Linker a - 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 - -linkChoices :: forall a w . LinkingState - -> QPN - -> (w, POption, a) - -> [(w, POption, a)] -linkChoices related (Q _pp pn) (weight, POption i Nothing, subtree) = - L.map aux (M.findWithDefault [] (pn, i) related) - where - aux :: PackagePath -> (w, POption, a) - aux pp = (weight, POption i (Just pp), subtree) -linkChoices _ _ (_, POption _ (Just _), _) = - alreadyLinked - -alreadyLinked :: a -alreadyLinked = error "addLinking called on tree that already contains linked nodes" - -------------------------------------------------------------------------------- - --- | Interface to the tree builder. Just takes an index and a list of package names, --- and computes the initial state and then the tree from there. -buildTree :: Index -> IndependentGoals -> [PN] -> Tree () QGoalReason -buildTree idx (IndependentGoals ind) igs = - build Linker { - buildState = BS { - index = idx - , rdeps = M.fromList (L.map (\ qpn -> (qpn, [])) qpns) - , open = L.map topLevelGoal qpns - , next = Goals - , qualifyOptions = defaultQualifyOptions idx - } - , linkingState = M.empty - } - where - topLevelGoal qpn = PkgGoal qpn UserGoal - - qpns | ind = L.map makeIndependent igs - | otherwise = L.map (Q (PackagePath DefaultNamespace QualToplevel)) igs - -{------------------------------------------------------------------------------- - Goals --------------------------------------------------------------------------------} - --- | Information needed about a dependency before it is converted into a Goal. -data OpenGoal = - FlagGoal (FN QPN) FInfo (FlaggedDeps QPN) (FlaggedDeps QPN) QGoalReason - | StanzaGoal (SN QPN) (FlaggedDeps QPN) QGoalReason - | PkgGoal QPN QGoalReason - --- | Closes a goal, i.e., removes all the extraneous information that we --- need only during the build phase. -close :: OpenGoal -> Goal QPN -close (FlagGoal qfn _ _ _ gr) = Goal (F qfn) gr -close (StanzaGoal qsn _ gr) = Goal (S qsn) gr -close (PkgGoal qpn gr) = Goal (P qpn) gr - -{------------------------------------------------------------------------------- - Auxiliary --------------------------------------------------------------------------------} - --- | Pairs each element of a list with the list resulting from removal of that --- element from the original list. -splits :: [a] -> [(a, [a])] -splits = go id - where - go :: ([a] -> [a]) -> [a] -> [(a, [a])] - go _ [] = [] - go f (x : xs) = (x, f xs) : go (f . (x :)) xs diff --git a/cabal/cabal-install/Distribution/Solver/Modular/Configured.hs b/cabal/cabal-install/Distribution/Solver/Modular/Configured.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Solver/Modular/Configured.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Distribution.Solver.Modular.Configured - ( CP(..) - ) where - -import Distribution.PackageDescription (FlagAssignment) - -import Distribution.Solver.Modular.Package -import Distribution.Solver.Types.ComponentDeps (ComponentDeps) -import Distribution.Solver.Types.OptionalStanza - --- | A configured package is a package instance together with --- a flag assignment and complete dependencies. -data CP qpn = CP (PI qpn) FlagAssignment [OptionalStanza] (ComponentDeps [PI qpn]) diff --git a/cabal/cabal-install/Distribution/Solver/Modular/ConfiguredConversion.hs b/cabal/cabal-install/Distribution/Solver/Modular/ConfiguredConversion.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Solver/Modular/ConfiguredConversion.hs +++ /dev/null @@ -1,72 +0,0 @@ -module Distribution.Solver.Modular.ConfiguredConversion - ( convCP - ) where - -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 -import Distribution.Solver.Modular.Package - -import Distribution.Solver.Types.ComponentDeps (ComponentDeps) -import qualified Distribution.Solver.Types.PackageIndex as CI -import Distribution.Solver.Types.PackagePath -import Distribution.Solver.Types.ResolverPackage -import Distribution.Solver.Types.SolverId -import Distribution.Solver.Types.SolverPackage -import Distribution.Solver.Types.InstSolverPackage -import Distribution.Solver.Types.SourcePackage - --- | Converts from the solver specific result @CP QPN@ into --- a 'ResolverPackage', which can then be converted into --- the install plan. -convCP :: 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 $ - InstSolverPackage { - instSolverPkgIPI = fromJust $ SI.lookupUnitId iidx pi, - instSolverPkgLibDeps = fmap fst ds', - instSolverPkgExeDeps = fmap snd ds' - } - Right pi -> Configured $ - SolverPackage { - solverPkgSource = srcpkg, - 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)) = - case loc of - Inst pi -> Left (PreExistingId sourceId pi) - _otherwise - | QualExe _ pn' <- q - -- NB: the dependencies of the executable are also - -- qualified. So the way to tell if this is an executable - -- dependency is to make sure the qualifier is pointing - -- 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) - where - sourceId = PackageIdentifier pn v diff --git a/cabal/cabal-install/Distribution/Solver/Modular/ConflictSet.hs b/cabal/cabal-install/Distribution/Solver/Modular/ConflictSet.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Solver/Modular/ConflictSet.hs +++ /dev/null @@ -1,244 +0,0 @@ -{-# LANGUAGE CPP #-} -#ifdef DEBUG_CONFLICT_SETS -{-# LANGUAGE ImplicitParams #-} -#endif --- | Conflict sets --- --- Intended for double import --- --- > import Distribution.Solver.Modular.ConflictSet (ConflictSet) --- > import qualified Distribution.Solver.Modular.ConflictSet as CS -module Distribution.Solver.Modular.ConflictSet ( - ConflictSet -- opaque - , Conflict(..) - , ConflictMap - , OrderedVersionRange(..) -#ifdef DEBUG_CONFLICT_SETS - , conflictSetOrigin -#endif - , showConflictSet - , showCSSortedByFrequency - , showCSWithFrequency - -- Set-like operations - , toSet - , toList - , union - , unions - , insert - , delete - , empty - , singleton - , singletonWithConflict - , size - , member - , lookup - , filter - , fromList - ) where - -import Prelude hiding (lookup) -import Data.List (intercalate, sortBy) -import Data.Map (Map) -import Data.Set (Set) -import Data.Function (on) -import qualified Data.Map.Strict as M -import qualified Data.Set as S - -#ifdef DEBUG_CONFLICT_SETS -import Data.Tree -import GHC.Stack -#endif - -import Distribution.Solver.Modular.Var -import Distribution.Solver.Modular.Version -import Distribution.Solver.Types.PackagePath - --- | The set of variables involved in a solver conflict, each paired with --- details about the conflict. -data ConflictSet = CS { - -- | The set of variables involved in the conflict - conflictSetToMap :: !(Map (Var QPN) (Set Conflict)) - -#ifdef DEBUG_CONFLICT_SETS - -- | The origin of the conflict set - -- - -- When @DEBUG_CONFLICT_SETS@ is defined @(-f debug-conflict-sets)@, - -- we record the origin of every conflict set. For new conflict sets - -- ('empty', 'fromVars', ..) we just record the 'CallStack'; for operations - -- that construct new conflict sets from existing conflict sets ('union', - -- 'filter', ..) we record the 'CallStack' to the call to the combinator - -- as well as the 'CallStack's of the input conflict sets. - -- - -- Requires @GHC >= 7.10@. - , conflictSetOrigin :: Tree CallStack -#endif - } - deriving (Show) - --- | More detailed information about how a conflict set variable caused a --- conflict. This information can be used to determine whether a second value --- for that variable would lead to the same conflict. --- --- TODO: Handle dependencies under flags or stanzas. -data Conflict = - - -- | The conflict set variable represents a package which depends on the - -- specified problematic package. For example, the conflict set entry - -- '(P x, GoalConflict y)' means that package x introduced package y, and y - -- led to a conflict. - GoalConflict QPN - - -- | The conflict set variable represents a package with a constraint that - -- excluded the specified package and version. For example, the conflict set - -- entry '(P x, VersionConstraintConflict y (mkVersion [2, 0]))' means that - -- package x's constraint on y excluded y-2.0. - | VersionConstraintConflict QPN Ver - - -- | The conflict set variable represents a package that was excluded by a - -- constraint from the specified package. For example, the conflict set - -- entry '(P x, VersionConflict y (orLaterVersion (mkVersion [2, 0])))' - -- means that package y's constraint 'x >= 2.0' excluded some version of x. - | VersionConflict QPN OrderedVersionRange - - -- | Any other conflict. - | OtherConflict - deriving (Eq, Ord, Show) - --- | Version range with an 'Ord' instance. -newtype OrderedVersionRange = OrderedVersionRange VR - deriving (Eq, Show) - --- TODO: Avoid converting the version ranges to strings. -instance Ord OrderedVersionRange where - compare = compare `on` show - -instance Eq ConflictSet where - (==) = (==) `on` conflictSetToMap - -instance Ord ConflictSet where - compare = compare `on` conflictSetToMap - -showConflictSet :: ConflictSet -> String -showConflictSet = intercalate ", " . map showVar . toList - -showCSSortedByFrequency :: ConflictMap -> ConflictSet -> String -showCSSortedByFrequency = showCS False - -showCSWithFrequency :: ConflictMap -> ConflictSet -> String -showCSWithFrequency = showCS True - -showCS :: Bool -> ConflictMap -> ConflictSet -> String -showCS showCount cm = - intercalate ", " . map showWithFrequency . indexByFrequency - where - indexByFrequency = sortBy (flip compare `on` snd) . map (\c -> (c, M.lookup c cm)) . toList - showWithFrequency (conflict, maybeFrequency) = case maybeFrequency of - Just frequency - | showCount -> showVar conflict ++ " (" ++ show frequency ++ ")" - _ -> showVar conflict - -{------------------------------------------------------------------------------- - Set-like operations --------------------------------------------------------------------------------} - -toSet :: ConflictSet -> Set (Var QPN) -toSet = M.keysSet . conflictSetToMap - -toList :: ConflictSet -> [Var QPN] -toList = M.keys . conflictSetToMap - -union :: -#ifdef DEBUG_CONFLICT_SETS - (?loc :: CallStack) => -#endif - ConflictSet -> ConflictSet -> ConflictSet -union cs cs' = CS { - conflictSetToMap = M.unionWith S.union (conflictSetToMap cs) (conflictSetToMap cs') -#ifdef DEBUG_CONFLICT_SETS - , conflictSetOrigin = Node ?loc (map conflictSetOrigin [cs, cs']) -#endif - } - -unions :: -#ifdef DEBUG_CONFLICT_SETS - (?loc :: CallStack) => -#endif - [ConflictSet] -> ConflictSet -unions css = CS { - conflictSetToMap = M.unionsWith S.union (map conflictSetToMap css) -#ifdef DEBUG_CONFLICT_SETS - , conflictSetOrigin = Node ?loc (map conflictSetOrigin css) -#endif - } - -insert :: -#ifdef DEBUG_CONFLICT_SETS - (?loc :: CallStack) => -#endif - Var QPN -> ConflictSet -> ConflictSet -insert var cs = CS { - conflictSetToMap = M.insert var (S.singleton OtherConflict) (conflictSetToMap cs) -#ifdef DEBUG_CONFLICT_SETS - , conflictSetOrigin = Node ?loc [conflictSetOrigin cs] -#endif - } - -delete :: Var QPN -> ConflictSet -> ConflictSet -delete var cs = CS { - conflictSetToMap = M.delete var (conflictSetToMap cs) - } - -empty :: -#ifdef DEBUG_CONFLICT_SETS - (?loc :: CallStack) => -#endif - ConflictSet -empty = CS { - conflictSetToMap = M.empty -#ifdef DEBUG_CONFLICT_SETS - , conflictSetOrigin = Node ?loc [] -#endif - } - -singleton :: -#ifdef DEBUG_CONFLICT_SETS - (?loc :: CallStack) => -#endif - Var QPN -> ConflictSet -singleton var = singletonWithConflict var OtherConflict - -singletonWithConflict :: -#ifdef DEBUG_CONFLICT_SETS - (?loc :: CallStack) => -#endif - Var QPN -> Conflict -> ConflictSet -singletonWithConflict var conflict = CS { - conflictSetToMap = M.singleton var (S.singleton conflict) -#ifdef DEBUG_CONFLICT_SETS - , conflictSetOrigin = Node ?loc [] -#endif - } - -size :: ConflictSet -> Int -size = M.size . conflictSetToMap - -member :: Var QPN -> ConflictSet -> Bool -member var = M.member var . conflictSetToMap - -lookup :: Var QPN -> ConflictSet -> Maybe (Set Conflict) -lookup var = M.lookup var . conflictSetToMap - -fromList :: -#ifdef DEBUG_CONFLICT_SETS - (?loc :: CallStack) => -#endif - [Var QPN] -> ConflictSet -fromList vars = CS { - conflictSetToMap = M.fromList [(var, S.singleton OtherConflict) | var <- vars] -#ifdef DEBUG_CONFLICT_SETS - , conflictSetOrigin = Node ?loc [] -#endif - } - -type ConflictMap = Map (Var QPN) Int - diff --git a/cabal/cabal-install/Distribution/Solver/Modular/Cycles.hs b/cabal/cabal-install/Distribution/Solver/Modular/Cycles.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Solver/Modular/Cycles.hs +++ /dev/null @@ -1,118 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module Distribution.Solver.Modular.Cycles ( - detectCyclesPhase - ) where - -import Prelude hiding (cycle) -import qualified Data.Map as M -import qualified Data.Set as S - -import qualified Distribution.Compat.Graph as G -import Distribution.Simple.Utils (ordNub) -import Distribution.Solver.Modular.Dependency -import Distribution.Solver.Modular.Flag -import Distribution.Solver.Modular.Tree -import qualified Distribution.Solver.Modular.ConflictSet as CS -import Distribution.Solver.Types.ComponentDeps (Component) -import Distribution.Solver.Types.PackagePath - --- | Find and reject any nodes with cyclic dependencies -detectCyclesPhase :: Tree d c -> Tree d c -detectCyclesPhase = cata go - where - -- Only check children of choice nodes. - go :: TreeF d c (Tree d c) -> Tree d c - go (PChoiceF qpn rdm gr cs) = - PChoice qpn rdm gr $ fmap (checkChild qpn) cs - go (FChoiceF qfn@(FN qpn _) rdm gr w m d cs) = - FChoice qfn rdm gr w m d $ fmap (checkChild qpn) cs - go (SChoiceF qsn@(SN qpn _) rdm gr w cs) = - SChoice qsn rdm gr w $ fmap (checkChild qpn) cs - go x = inn x - - checkChild :: QPN -> Tree d c -> Tree d c - checkChild qpn x@(PChoice _ rdm _ _) = failIfCycle qpn rdm x - checkChild qpn x@(FChoice _ rdm _ _ _ _ _) = failIfCycle qpn rdm x - checkChild qpn x@(SChoice _ rdm _ _ _) = failIfCycle qpn rdm x - checkChild qpn x@(GoalChoice rdm _) = failIfCycle qpn rdm x - checkChild _ x@(Fail _ _) = x - checkChild qpn x@(Done rdm _) = failIfCycle qpn rdm x - - failIfCycle :: QPN -> RevDepMap -> Tree d c -> Tree d c - failIfCycle qpn rdm x = - case findCycles qpn rdm of - Nothing -> x - Just relSet -> Fail relSet CyclicDependencies - --- | Given the reverse dependency map from a node in the tree, check --- if the solution is cyclic. If it is, return the conflict set containing --- 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 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. - -- - -- 'hasCycle' checks for cycles incrementally by only looking for cycles - -- containing the current package, 'pkg'. It searches for cycles in the - -- 'RevDepMap', which is the data structure used to store reverse - -- dependencies in the search tree. We store the reverse dependencies in a - -- map, because Data.Map is smaller and/or has better sharing than - -- Distribution.Compat.Graph. - -- - -- If there is a cycle, we call G.cycles to find a strongly connected - -- component. Then we choose one cycle from the component to use for the - -- conflict set. Choosing only one cycle can lead to a smaller conflict set, - -- such as when a choice to enable testing introduces many cycles at once. - -- In that case, all cycles contain the current package and are in one large - -- strongly connected component. - -- - if hasCycle - then let scc :: G.Graph RevDepMapNode - scc = case G.cycles $ revDepMapToGraph rdm of - [] -> findCyclesError "cannot find a strongly connected component" - c : _ -> G.fromDistinctList c - - next :: QPN -> QPN - next p = case G.neighbors scc p of - Just (n : _) -> G.nodeKey n - _ -> findCyclesError "cannot find next node in the cycle" - - -- This function also assumes that all cycles contain 'pkg'. - oneCycle :: [QPN] - oneCycle = case iterate next pkg of - [] -> findCyclesError "empty cycle" - x : xs -> x : takeWhile (/= x) xs - in Just $ CS.fromList $ map P oneCycle - else Nothing - where - hasCycle :: Bool - hasCycle = pkg `S.member` closure (neighbors pkg) - - closure :: [QPN] -> S.Set QPN - closure = foldl go S.empty - where - go :: S.Set QPN -> QPN -> S.Set QPN - go s x = - if x `S.member` s - then s - else foldl go (S.insert x s) $ neighbors x - - neighbors :: QPN -> [QPN] - neighbors x = case x `M.lookup` rdm of - Nothing -> findCyclesError "cannot find node" - Just xs -> map snd xs - - findCyclesError = error . ("Distribution.Solver.Modular.Cycles.findCycles: " ++) - -data RevDepMapNode = RevDepMapNode QPN [(Component, QPN)] - -instance G.IsNode RevDepMapNode where - type Key RevDepMapNode = QPN - nodeKey (RevDepMapNode qpn _) = qpn - nodeNeighbors (RevDepMapNode _ ns) = ordNub $ map snd ns - -revDepMapToGraph :: RevDepMap -> G.Graph RevDepMapNode -revDepMapToGraph rdm = G.fromDistinctList - [RevDepMapNode qpn ns | (qpn, ns) <- M.toList rdm] diff --git a/cabal/cabal-install/Distribution/Solver/Modular/Dependency.hs b/cabal/cabal-install/Distribution/Solver/Modular/Dependency.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Solver/Modular/Dependency.hs +++ /dev/null @@ -1,358 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE RecordWildCards #-} -module Distribution.Solver.Modular.Dependency ( - -- * Variables - Var(..) - , showVar - , varPN - -- * Conflict sets - , ConflictSet - , ConflictMap - , CS.showConflictSet - -- * Constrained instances - , CI(..) - -- * Flagged dependencies - , FlaggedDeps - , FlaggedDep(..) - , LDep(..) - , Dep(..) - , PkgComponent(..) - , ExposedComponent(..) - , DependencyReason(..) - , showDependencyReason - , flattenFlaggedDeps - , QualifyOptions(..) - , qualifyDeps - , unqualifyDeps - -- * Reverse dependency map - , RevDepMap - -- * Goals - , Goal(..) - , GoalReason(..) - , QGoalReason - , goalToVar - , varToConflictSet - , goalReasonToConflictSet - , goalReasonToConflictSetWithConflict - , dependencyReasonToConflictSet - , dependencyReasonToConflictSetWithVersionConstraintConflict - , dependencyReasonToConflictSetWithVersionConflict - ) where - -import Prelude () -import qualified Data.Map as M -import qualified Data.Set as S -import Distribution.Solver.Compat.Prelude hiding (pi) - -import Language.Haskell.Extension (Extension(..), Language(..)) - -import Distribution.Solver.Modular.ConflictSet (ConflictSet, ConflictMap) -import Distribution.Solver.Modular.Flag -import Distribution.Solver.Modular.Package -import Distribution.Solver.Modular.Var -import Distribution.Solver.Modular.Version -import qualified Distribution.Solver.Modular.ConflictSet as CS - -import Distribution.Solver.Types.ComponentDeps (Component(..)) -import Distribution.Solver.Types.PackagePath -import Distribution.Types.LibraryName -import Distribution.Types.PkgconfigVersionRange -import Distribution.Types.UnqualComponentName - -{------------------------------------------------------------------------------- - Constrained instances --------------------------------------------------------------------------------} - --- | Constrained instance. It represents the allowed instances for a package, --- which can be either a fixed instance or a version range. -data CI = Fixed I | Constrained VR - deriving (Eq, Show) - -{------------------------------------------------------------------------------- - Flagged dependencies --------------------------------------------------------------------------------} - --- | Flagged dependencies --- --- 'FlaggedDeps' is the modular solver's view of a packages dependencies: --- rather than having the dependencies indexed by component, each dependency --- defines what component it is in. --- --- Note that each dependency is associated with a Component. We must know what --- component the dependencies belong to, or else we won't be able to construct --- fine-grained reverse dependencies. -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 - -- (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 - --- | Conversatively flatten out flagged dependencies --- --- NOTE: We do not filter out duplicates. -flattenFlaggedDeps :: FlaggedDeps qpn -> [(LDep qpn, Component)] -flattenFlaggedDeps = concatMap aux - where - aux :: FlaggedDep qpn -> [(LDep qpn, Component)] - aux (Flagged _ _ t f) = flattenFlaggedDeps t ++ flattenFlaggedDeps f - 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) - --- | 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 - --- | 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 - deriving (Eq, Ord, Functor, Show) - --- | A component that can be depended upon by another package, i.e., a library --- or an executable. -data ExposedComponent = - ExposedLib LibraryName - | 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) - deriving (Functor, Eq, Show) - --- | Print the reason that a dependency was introduced. -showDependencyReason :: DependencyReason QPN -> String -showDependencyReason (DependencyReason qpn flags stanzas) = - intercalate " " $ - showQPN qpn - : map (uncurry showFlagValue) (M.toList flags) - ++ map (\s -> showSBool s True) (S.toList stanzas) - --- | Options for goal qualification (used in 'qualifyDeps') --- --- See also 'defaultQualifyOptions' -data QualifyOptions = QO { - -- | Do we have a version of base relying on another version of base? - qoBaseShim :: Bool - - -- Should dependencies of the setup script be treated as independent? - , qoSetupIndependent :: Bool - } - deriving Show - --- | Apply built-in rules for package qualifiers --- --- Although the behaviour of 'qualifyDeps' depends on the 'QualifyOptions', --- it is important that these 'QualifyOptions' are _static_. Qualification --- does NOT depend on flag assignment; in other words, it behaves the same no --- matter which choices the solver makes (modulo the global 'QualifyOptions'); --- we rely on this in 'linkDeps' (see comment there). --- --- 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 - where - go :: FlaggedDeps PN -> FlaggedDeps QPN - go = map go1 - - go1 :: FlaggedDep PN -> FlaggedDep QPN - go1 (Flagged fn nfo t f) = Flagged (fmap (Q pp) fn) nfo (go t) (go f) - go1 (Stanza sn t) = Stanza (fmap (Q pp) sn) (go t) - go1 (Simple dep comp) = Simple (goLDep dep comp) comp - - -- Suppose package B has a setup dependency on package A. - -- This will be recorded as something like - -- - -- > LDep (DependencyReason "B") (Dep (PkgComponent "A" (ExposedLib LMainLibName)) (Constrained AnyVersion)) - -- - -- Observe that when we qualify this dependency, we need to turn that - -- @"A"@ into @"B-setup.A"@, but we should not apply that same qualifier - -- to the DependencyReason. - goLDep :: LDep PN -> Component -> LDep QPN - 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 deppendencies 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 - --- | Remove qualifiers from set of dependencies --- --- This is used during link validation: when we link package @Q.A@ to @Q'.A@, --- then all dependencies @Q.B@ need to be linked to @Q'.B@. In order to compute --- what to link these dependencies to, we need to requalify @Q.B@ to become --- @Q'.B@; we do this by first removing all qualifiers and then calling --- 'qualifyDeps' again. -unqualifyDeps :: FlaggedDeps QPN -> FlaggedDeps PN -unqualifyDeps = go - where - go :: FlaggedDeps QPN -> FlaggedDeps PN - go = map go1 - - go1 :: FlaggedDep QPN -> FlaggedDep PN - go1 (Flagged fn nfo t f) = Flagged (fmap unq fn) nfo (go t) (go f) - go1 (Stanza sn t) = Stanza (fmap unq sn) (go t) - go1 (Simple dep comp) = Simple (goLDep dep) comp - - goLDep :: LDep QPN -> LDep PN - goLDep (LDep dr dep) = LDep (fmap unq dr) (fmap unq dep) - - unq :: QPN -> PN - unq (Q _ pn) = pn - -{------------------------------------------------------------------------------- - Reverse dependency map --------------------------------------------------------------------------------} - --- | A map containing reverse dependencies between qualified --- package names. -type RevDepMap = Map QPN [(Component, QPN)] - -{------------------------------------------------------------------------------- - Goals --------------------------------------------------------------------------------} - --- | A goal is just a solver variable paired with a reason. --- The reason is only used for tracing. -data Goal qpn = Goal (Var qpn) (GoalReason qpn) - deriving (Eq, Show, Functor) - --- | Reason why a goal is being added to a goal set. -data GoalReason qpn = - UserGoal -- introduced by a build target - | DependencyGoal (DependencyReason qpn) -- introduced by a package - deriving (Eq, Show, Functor) - -type QGoalReason = GoalReason QPN - -goalToVar :: Goal a -> Var a -goalToVar (Goal v _) = v - --- | Compute a singleton conflict set from a 'Var' -varToConflictSet :: Var QPN -> ConflictSet -varToConflictSet = CS.singleton - --- | Convert a 'GoalReason' to a 'ConflictSet' that can be used when the goal --- leads to a conflict. -goalReasonToConflictSet :: GoalReason QPN -> ConflictSet -goalReasonToConflictSet UserGoal = CS.empty -goalReasonToConflictSet (DependencyGoal dr) = dependencyReasonToConflictSet dr - --- | Convert a 'GoalReason' to a 'ConflictSet' containing the reason that the --- conflict occurred, namely the conflict set variables caused a conflict by --- introducing the given package goal. See the documentation for 'GoalConflict'. --- --- This function currently only specifies the reason for the conflict in the --- simple case where the 'GoalReason' does not involve any flags or stanzas. --- Otherwise, it falls back to calling 'goalReasonToConflictSet'. -goalReasonToConflictSetWithConflict :: QPN -> GoalReason QPN -> ConflictSet -goalReasonToConflictSetWithConflict goal (DependencyGoal (DependencyReason qpn flags stanzas)) - | M.null flags && S.null stanzas = - CS.singletonWithConflict (P qpn) $ CS.GoalConflict goal -goalReasonToConflictSetWithConflict _ gr = goalReasonToConflictSet gr - --- | This function returns the solver variables responsible for the dependency. --- It drops the values chosen for flag and stanza variables, which are only --- needed for log messages. -dependencyReasonToConflictSet :: DependencyReason QPN -> ConflictSet -dependencyReasonToConflictSet (DependencyReason qpn flags stanzas) = - CS.fromList $ P qpn : flagVars ++ map stanzaToVar (S.toList stanzas) - where - -- Filter out any flags that introduced the dependency with both values. - -- They don't need to be included in the conflict set, because changing the - -- flag value can't remove the dependency. - flagVars :: [Var QPN] - flagVars = [F (FN qpn fn) | (fn, fv) <- M.toList flags, fv /= FlagBoth] - - stanzaToVar :: Stanza -> Var QPN - stanzaToVar = S . SN qpn - --- | Convert a 'DependencyReason' to a 'ConflictSet' specifying that the --- conflict occurred because the conflict set variables introduced a problematic --- version constraint. See the documentation for 'VersionConstraintConflict'. --- --- This function currently only specifies the reason for the conflict in the --- simple case where the 'DependencyReason' does not involve any flags or --- stanzas. Otherwise, it falls back to calling 'dependencyReasonToConflictSet'. -dependencyReasonToConflictSetWithVersionConstraintConflict :: QPN - -> Ver - -> DependencyReason QPN - -> ConflictSet -dependencyReasonToConflictSetWithVersionConstraintConflict - dependency excludedVersion dr@(DependencyReason qpn flags stanzas) - | M.null flags && S.null stanzas = - CS.singletonWithConflict (P qpn) $ - CS.VersionConstraintConflict dependency excludedVersion - | otherwise = dependencyReasonToConflictSet dr - --- | Convert a 'DependencyReason' to a 'ConflictSet' specifying that the --- conflict occurred because the conflict set variables introduced a version of --- a package that was excluded by a version constraint. See the documentation --- for 'VersionConflict'. --- --- This function currently only specifies the reason for the conflict in the --- simple case where the 'DependencyReason' does not involve any flags or --- stanzas. Otherwise, it falls back to calling 'dependencyReasonToConflictSet'. -dependencyReasonToConflictSetWithVersionConflict :: QPN - -> CS.OrderedVersionRange - -> DependencyReason QPN - -> ConflictSet -dependencyReasonToConflictSetWithVersionConflict - pkgWithVersionConstraint constraint dr@(DependencyReason qpn flags stanzas) - | M.null flags && S.null stanzas = - CS.singletonWithConflict (P qpn) $ - CS.VersionConflict pkgWithVersionConstraint constraint - | otherwise = dependencyReasonToConflictSet dr diff --git a/cabal/cabal-install/Distribution/Solver/Modular/Explore.hs b/cabal/cabal-install/Distribution/Solver/Modular/Explore.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Solver/Modular/Explore.hs +++ /dev/null @@ -1,367 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Distribution.Solver.Modular.Explore (backjumpAndExplore) where - -import Distribution.Solver.Compat.Prelude -import Prelude () - -import qualified Distribution.Solver.Types.Progress as P - -import qualified Data.List as L (foldl') -import qualified Data.Map.Strict as M -import qualified Data.Set as S - -import Distribution.Simple.Setup (asBool) - -import Distribution.Solver.Modular.Assignment -import Distribution.Solver.Modular.Dependency -import Distribution.Solver.Modular.Index -import Distribution.Solver.Modular.Log -import Distribution.Solver.Modular.Message -import Distribution.Solver.Modular.Package -import qualified Distribution.Solver.Modular.PSQ as P -import qualified Distribution.Solver.Modular.ConflictSet as CS -import Distribution.Solver.Modular.RetryLog -import Distribution.Solver.Modular.Tree -import Distribution.Solver.Modular.Version -import qualified Distribution.Solver.Modular.WeightedPSQ as W -import Distribution.Solver.Types.PackagePath -import Distribution.Solver.Types.Settings - (CountConflicts(..), EnableBackjumping(..), FineGrainedConflicts(..)) -import Distribution.Types.VersionRange (anyVersion) - --- | This function takes the variable we're currently considering, a --- last conflict set and a list of children's logs. Each log yields --- either a solution or a conflict set. The result is a combined log for --- the parent node that has explored a prefix of the children. --- --- We can stop traversing the children's logs if we find an individual --- conflict set that does not contain the current variable. In this --- case, we can just lift the conflict set to the current level, --- because the current level cannot possibly have contributed to this --- conflict, so no other choice at the current level would avoid the --- conflict. --- --- If any of the children might contain a successful solution, we can --- return it immediately. If all children contain conflict sets, we can --- take the union as the combined conflict set. --- --- The last conflict set corresponds to the justification that we --- have to choose this goal at all. There is a reason why we have --- introduced the goal in the first place, and this reason is in conflict --- with the (virtual) option not to choose anything for the current --- variable. See also the comments for 'avoidSet'. --- --- We can also skip a child if it does not resolve any of the conflicts paired --- with the current variable in the previous child's conflict set. 'backjump' --- takes a function to determine whether a child can be skipped. If the child --- can be skipped, the function returns a new conflict set to be merged with the --- previous conflict set. --- -backjump :: forall w k a . Maybe Int - -> EnableBackjumping - -> FineGrainedConflicts - - -> (k -> S.Set CS.Conflict -> Maybe ConflictSet) - -- ^ Function that determines whether the given choice could resolve - -- the given conflict. It indicates false by returning 'Just', - -- with the new conflicts to be added to the conflict set. - - -> (k -> ConflictSet -> ExploreState -> ConflictSetLog a) - -- ^ Function that logs the given choice that was skipped. - - -> Var QPN -- ^ The current variable. - - -> ConflictSet -- ^ Conflict set representing the reason that the goal - -- was introduced. - - -> W.WeightedPSQ w k (ExploreState -> ConflictSetLog a) - -- ^ List of children's logs. - - -> ExploreState -> ConflictSetLog a -backjump mbj enableBj fineGrainedConflicts couldResolveConflicts - logSkippedChoice var lastCS xs = - foldr combine avoidGoal [(k, v) | (_, k, v) <- W.toList xs] CS.empty Nothing - where - combine :: (k, ExploreState -> ConflictSetLog a) - -> (ConflictSet -> Maybe ConflictSet -> ExploreState -> ConflictSetLog a) - -> ConflictSet -> Maybe ConflictSet -> ExploreState -> ConflictSetLog a - combine (k, x) f csAcc mPreviousCS es = - case (asBool fineGrainedConflicts, mPreviousCS) of - (True, Just previousCS) -> - case CS.lookup var previousCS of - Just conflicts -> - case couldResolveConflicts k conflicts of - Nothing -> retryNoSolution (x es) next - Just newConflicts -> skipChoice (previousCS `CS.union` newConflicts) - _ -> skipChoice previousCS - _ -> retryNoSolution (x es) next - where - next :: ConflictSet -> ExploreState -> ConflictSetLog a - next !cs es' = if asBool enableBj && not (var `CS.member` cs) - then skipLoggingBackjump cs es' - else f (csAcc `CS.union` cs) (Just cs) es' - - -- This function is for skipping the choice when it cannot resolve any - -- of the previous conflicts. - skipChoice :: ConflictSet -> ConflictSetLog a - skipChoice newCS = - retryNoSolution (logSkippedChoice k newCS es) $ \cs' es' -> - f (csAcc `CS.union` cs') (Just cs') $ - - -- Update the conflict map with the conflict set, to make up for - -- skipping the whole subtree. - es' { esConflictMap = updateCM cs' (esConflictMap es') } - - -- This function represents the option to not choose a value for this goal. - avoidGoal :: ConflictSet -> Maybe ConflictSet -> ExploreState -> ConflictSetLog a - avoidGoal cs _mPreviousCS !es = - logBackjump mbj (cs `CS.union` lastCS) $ - - -- Use 'lastCS' below instead of 'cs' since we do not want to - -- double-count the additionally accumulated conflicts. - es { esConflictMap = updateCM lastCS (esConflictMap es) } - - -- The solver does not count or log backjumps at levels where the conflict - -- set does not contain the current variable. Otherwise, there would be many - -- consecutive log messages about backjumping with the same conflict set. - skipLoggingBackjump :: ConflictSet -> ExploreState -> ConflictSetLog a - skipLoggingBackjump cs es = fromProgress $ P.Fail (NoSolution cs es) - --- | Creates a failing ConflictSetLog representing a backjump. It inserts a --- "backjumping" message, checks whether the backjump limit has been reached, --- and increments the backjump count. -logBackjump :: Maybe Int -> ConflictSet -> ExploreState -> ConflictSetLog a -logBackjump mbj cs es = - failWith (Failure cs Backjump) $ - if reachedBjLimit (esBackjumps es) - then BackjumpLimit - else NoSolution cs es { esBackjumps = esBackjumps es + 1 } - where - reachedBjLimit = case mbj of - Nothing -> const False - Just limit -> (>= limit) - --- | Like 'retry', except that it only applies the input function when the --- backjump limit has not been reached. -retryNoSolution :: ConflictSetLog a - -> (ConflictSet -> ExploreState -> ConflictSetLog a) - -> ConflictSetLog a -retryNoSolution lg f = retry lg $ \case - BackjumpLimit -> fromProgress (P.Fail BackjumpLimit) - NoSolution cs es -> f cs es - --- | The state that is read and written while exploring the search tree. -data ExploreState = ES { - esConflictMap :: !ConflictMap - , esBackjumps :: !Int - } - -data IntermediateFailure = - NoSolution ConflictSet ExploreState - | BackjumpLimit - -type ConflictSetLog = RetryLog Message IntermediateFailure - -getBestGoal :: ConflictMap -> P.PSQ (Goal QPN) a -> (Goal QPN, a) -getBestGoal cm = - P.maximumBy - ( flip (M.findWithDefault 0) cm - . (\ (Goal v _) -> v) - ) - -getFirstGoal :: P.PSQ (Goal QPN) a -> (Goal QPN, a) -getFirstGoal ts = - P.casePSQ ts - (error "getFirstGoal: empty goal choice") -- empty goal choice is an internal error - (\ k v _xs -> (k, v)) -- commit to the first goal choice - -updateCM :: ConflictSet -> ConflictMap -> ConflictMap -updateCM cs cm = - L.foldl' (\ cmc k -> M.insertWith (+) k 1 cmc) cm (CS.toList cs) - --- | Record complete assignments on 'Done' nodes. -assign :: Tree d c -> Tree Assignment c -assign tree = cata go tree $ A M.empty M.empty M.empty - where - go :: TreeF d c (Assignment -> Tree Assignment c) - -> (Assignment -> Tree Assignment c) - go (FailF c fr) _ = Fail c fr - go (DoneF rdm _) a = Done rdm a - go (PChoiceF qpn rdm y ts) (A pa fa sa) = PChoice qpn rdm y $ W.mapWithKey f ts - where f (POption k _) r = r (A (M.insert qpn k pa) fa sa) - go (FChoiceF qfn rdm y t m d ts) (A pa fa sa) = FChoice qfn rdm y t m d $ W.mapWithKey f ts - where f k r = r (A pa (M.insert qfn k fa) sa) - go (SChoiceF qsn rdm y t ts) (A pa fa sa) = SChoice qsn rdm y t $ W.mapWithKey f ts - where f k r = r (A pa fa (M.insert qsn k sa)) - go (GoalChoiceF rdm ts) a = GoalChoice rdm $ fmap ($ a) ts - --- | A tree traversal that simultaneously propagates conflict sets up --- the tree from the leaves and creates a log. -exploreLog :: Maybe Int - -> EnableBackjumping - -> FineGrainedConflicts - -> CountConflicts - -> Index - -> Tree Assignment QGoalReason - -> ConflictSetLog (Assignment, RevDepMap) -exploreLog mbj enableBj fineGrainedConflicts (CountConflicts countConflicts) idx t = - para go t initES - where - getBestGoal' :: P.PSQ (Goal QPN) a -> ConflictMap -> (Goal QPN, a) - getBestGoal' - | asBool countConflicts = \ ts cm -> getBestGoal cm ts - | otherwise = \ ts _ -> getFirstGoal ts - - go :: TreeF Assignment QGoalReason - (ExploreState -> ConflictSetLog (Assignment, RevDepMap), Tree Assignment QGoalReason) - -> (ExploreState -> ConflictSetLog (Assignment, RevDepMap)) - go (FailF c fr) = \ !es -> - let es' = es { esConflictMap = updateCM c (esConflictMap es) } - in failWith (Failure c fr) (NoSolution c es') - go (DoneF rdm a) = \ _ -> succeedWith Success (a, rdm) - go (PChoiceF qpn _ gr ts) = - backjump mbj enableBj fineGrainedConflicts - (couldResolveConflicts qpn) - (logSkippedPackage qpn) - (P qpn) (avoidSet (P qpn) gr) $ -- try children in order, - W.mapWithKey -- when descending ... - (\ k r es -> tryWith (TryP qpn k) (r es)) - (fmap fst ts) - go (FChoiceF qfn _ gr _ _ _ ts) = - backjump mbj enableBj fineGrainedConflicts - (\_ _ -> Nothing) - (const logSkippedChoiceSimple) - (F qfn) (avoidSet (F qfn) gr) $ -- try children in order, - W.mapWithKey -- when descending ... - (\ k r es -> tryWith (TryF qfn k) (r es)) - (fmap fst ts) - go (SChoiceF qsn _ gr _ ts) = - backjump mbj enableBj fineGrainedConflicts - (\_ _ -> Nothing) - (const logSkippedChoiceSimple) - (S qsn) (avoidSet (S qsn) gr) $ -- try children in order, - W.mapWithKey -- when descending ... - (\ k r es -> tryWith (TryS qsn k) (r es)) - (fmap fst ts) - go (GoalChoiceF _ ts) = \ es -> - let (k, (v, tree)) = getBestGoal' ts (esConflictMap es) - in continueWith (Next k) $ - -- Goal choice nodes are normally not counted as backjumps, since the - -- solver always explores exactly one choice, which means that the - -- backjump from the goal choice would be redundant with the backjump - -- from the PChoice, FChoice, or SChoice below. The one case where the - -- backjump is not redundant is when the chosen goal is a failure node, - -- so we log a backjump in that case. - case tree of - Fail _ _ -> retryNoSolution (v es) $ logBackjump mbj - _ -> v es - - initES = ES { - esConflictMap = M.empty - , esBackjumps = 0 - } - - -- Is it possible for this package instance (QPN and POption) to resolve any - -- of the conflicts that were caused by the previous instance? The default - -- is true, because it is always safe to explore a package instance. - -- 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 = - let (PInfo deps _ _ _) = idx M.! pn M.! i - qdeps = qualifyDeps (defaultQualifyOptions idx) currentQPN deps - - couldBeResolved :: CS.Conflict -> Maybe ConflictSet - couldBeResolved CS.OtherConflict = Nothing - couldBeResolved (CS.GoalConflict conflictingDep) = - -- Check whether this package instance also has 'conflictingDep' - -- as a dependency (ignoring flag and stanza choices). - if null [() | Simple (LDep _ (Dep (PkgComponent qpn _) _)) _ <- qdeps, qpn == conflictingDep] - then Nothing - else Just CS.empty - couldBeResolved (CS.VersionConstraintConflict dep excludedVersion) = - -- Check whether this package instance also excludes version - -- 'excludedVersion' of 'dep' (ignoring flag and stanza choices). - let vrs = [vr | Simple (LDep _ (Dep (PkgComponent qpn _) (Constrained vr))) _ <- qdeps, qpn == dep ] - vrIntersection = L.foldl' (.&&.) anyVersion vrs - in if checkVR vrIntersection excludedVersion - then Nothing - else -- If we skip this package instance, we need to update the - -- conflict set to say that 'dep' was also excluded by - -- this package instance's constraint. - Just $ CS.singletonWithConflict (P dep) $ - CS.VersionConflict currentQPN (CS.OrderedVersionRange vrIntersection) - couldBeResolved (CS.VersionConflict reverseDep (CS.OrderedVersionRange excludingVR)) = - -- Check whether this package instance's version is also excluded - -- by 'excludingVR'. - if checkVR excludingVR v - then Nothing - else -- If we skip this version, we need to update the conflict - -- set to say that the reverse dependency also excluded this - -- version. - Just $ CS.singletonWithConflict (P reverseDep) (CS.VersionConstraintConflict currentQPN v) - in fmap CS.unions $ traverse couldBeResolved (S.toList conflicts) - - logSkippedPackage :: QPN -> POption -> ConflictSet -> ExploreState -> ConflictSetLog a - logSkippedPackage qpn pOption cs es = - tryWith (TryP qpn pOption) $ - failWith (Skip (fromMaybe S.empty $ CS.lookup (P qpn) cs)) $ - NoSolution cs es - - -- This function is used for flag and stanza choices, but it should not be - -- called, because there is currently no way to skip a value for a flag or - -- stanza. - logSkippedChoiceSimple :: ConflictSet -> ExploreState -> ConflictSetLog a - logSkippedChoiceSimple cs es = fromProgress $ P.Fail $ NoSolution cs es - --- | Build a conflict set corresponding to the (virtual) option not to --- choose a solution for a goal at all. --- --- In the solver, the set of goals is not statically determined, but depends --- on the choices we make. Therefore, when dealing with conflict sets, we --- always have to consider that we could perhaps make choices that would --- avoid the existence of the goal completely. --- --- Whenever we actually introduce a choice in the tree, we have already established --- that the goal cannot be avoided. This is tracked in the "goal reason". --- The choice to avoid the goal therefore is a conflict between the goal itself --- and its goal reason. We build this set here, and pass it to the 'backjump' --- function as the last conflict set. --- --- This has two effects: --- --- - In a situation where there are no choices available at all (this happens --- if an unknown package is requested), the last conflict set becomes the --- actual conflict set. --- --- - In a situation where all of the children's conflict sets contain the --- current variable, the goal reason of the current node will be added to the --- conflict set. --- -avoidSet :: Var QPN -> QGoalReason -> ConflictSet -avoidSet var@(P qpn) gr = - CS.union (CS.singleton var) (goalReasonToConflictSetWithConflict qpn gr) -avoidSet var gr = - CS.union (CS.singleton var) (goalReasonToConflictSet gr) - --- | Interface. --- --- Takes as an argument a limit on allowed backjumps. If the limit is 'Nothing', --- then infinitely many backjumps are allowed. If the limit is 'Just 0', --- backtracking is completely disabled. -backjumpAndExplore :: Maybe Int - -> EnableBackjumping - -> FineGrainedConflicts - -> CountConflicts - -> Index - -> Tree d QGoalReason - -> RetryLog Message SolverFailure (Assignment, RevDepMap) -backjumpAndExplore mbj enableBj fineGrainedConflicts countConflicts idx = - mapFailure convertFailure - . exploreLog mbj enableBj fineGrainedConflicts countConflicts idx - . assign - where - convertFailure (NoSolution cs es) = ExhaustiveSearch cs (esConflictMap es) - convertFailure BackjumpLimit = BackjumpLimitReached diff --git a/cabal/cabal-install/Distribution/Solver/Modular/Flag.hs b/cabal/cabal-install/Distribution/Solver/Modular/Flag.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Solver/Modular/Flag.hs +++ /dev/null @@ -1,108 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -module Distribution.Solver.Modular.Flag - ( FInfo(..) - , Flag - , FlagInfo - , FN(..) - , QFN - , QSN - , Stanza - , SN(..) - , WeakOrTrivial(..) - , FlagValue(..) - , mkFlag - , showQFN - , showQFNBool - , showFlagValue - , showQSN - , showQSNBool - , showSBool - ) where - -import Data.Map as M -import Prelude hiding (pi) - -import qualified Distribution.PackageDescription as P -- from Cabal - -import Distribution.Solver.Types.Flag -import Distribution.Solver.Types.OptionalStanza -import Distribution.Solver.Types.PackagePath - --- | Flag name. Consists of a package instance and the flag identifier itself. -data FN qpn = FN qpn Flag - deriving (Eq, Ord, Show, Functor) - --- | Flag identifier. Just a string. -type Flag = P.FlagName - --- | Stanza identifier. -type Stanza = OptionalStanza - -unFlag :: Flag -> String -unFlag = P.unFlagName - -mkFlag :: String -> Flag -mkFlag = P.mkFlagName - --- | Flag info. Default value, whether the flag is manual, and --- whether the flag is weak. Manual flags can only be set explicitly. --- Weak flags are typically deferred by the solver. -data FInfo = FInfo { fdefault :: Bool, fmanual :: FlagType, fweak :: WeakOrTrivial } - deriving (Eq, Show) - --- | Flag defaults. -type FlagInfo = Map Flag FInfo - --- | Qualified flag name. -type QFN = FN QPN - --- | Stanza name. Paired with a package name, much like a flag. -data SN qpn = SN qpn Stanza - deriving (Eq, Ord, Show, Functor) - --- | Qualified stanza name. -type QSN = SN QPN - --- | A property of flag and stanza choices that determines whether the --- choice should be deferred in the solving process. --- --- A choice is called weak if we do want to defer it. This is the --- case for flags that should be implied by what's currently installed on --- the system, as opposed to flags that are used to explicitly enable or --- disable some functionality. --- --- A choice is called trivial if it clearly does not matter. The --- special case of triviality we actually consider is if there are no new --- dependencies introduced by the choice. -newtype WeakOrTrivial = WeakOrTrivial { unWeakOrTrivial :: Bool } - deriving (Eq, Ord, Show) - --- | Value shown for a flag in a solver log message. The message can refer to --- only the true choice, only the false choice, or both choices. -data FlagValue = FlagTrue | FlagFalse | FlagBoth - deriving (Eq, Show) - -showQFNBool :: QFN -> Bool -> String -showQFNBool qfn@(FN qpn _f) b = showQPN qpn ++ ":" ++ showFBool qfn b - -showQSNBool :: QSN -> Bool -> String -showQSNBool (SN qpn s) b = showQPN qpn ++ ":" ++ showSBool s b - -showFBool :: FN qpn -> Bool -> String -showFBool (FN _ f) v = P.showFlagValue (f, v) - --- | String representation of a flag-value pair. -showFlagValue :: P.FlagName -> FlagValue -> String -showFlagValue f FlagTrue = '+' : unFlag f -showFlagValue f FlagFalse = '-' : unFlag f -showFlagValue f FlagBoth = "+/-" ++ unFlag f - -showSBool :: Stanza -> Bool -> String -showSBool s True = "*" ++ showStanza s -showSBool s False = "!" ++ showStanza s - -showQFN :: QFN -> String -showQFN (FN qpn f) = showQPN qpn ++ ":" ++ unFlag f - -showQSN :: QSN -> String -showQSN (SN qpn s) = showQPN qpn ++ ":" ++ showStanza s diff --git a/cabal/cabal-install/Distribution/Solver/Modular/Index.hs b/cabal/cabal-install/Distribution/Solver/Modular/Index.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Solver/Modular/Index.hs +++ /dev/null @@ -1,73 +0,0 @@ -module Distribution.Solver.Modular.Index - ( Index - , PInfo(..) - , ComponentInfo(..) - , IsVisible(..) - , IsBuildable(..) - , defaultQualifyOptions - , mkIndex - ) where - -import Prelude hiding (pi) - -import Data.Map (Map) -import qualified Data.List as L -import qualified Data.Map as M - -import Distribution.Solver.Modular.Dependency -import Distribution.Solver.Modular.Flag -import Distribution.Solver.Modular.Package -import Distribution.Solver.Modular.Tree - --- | An index contains information about package instances. This is a nested --- dictionary. Package names are mapped to instances, which in turn is mapped --- to info. -type Index = Map PN (Map I PInfo) - --- | Info associated with a package instance. --- Currently, dependencies, component names, flags and failure reasons. --- The component map records whether any components are unbuildable in the --- current environment (compiler, os, arch, and global flag constraints). --- Packages that have a failure reason recorded for them are disabled --- 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) - --- | Info associated with each library and executable in a package instance. -data ComponentInfo = ComponentInfo { - compIsVisible :: IsVisible - , compIsBuildable :: IsBuildable - } - --- | Whether a component is visible in the current environment. -newtype IsVisible = IsVisible Bool - deriving Eq - --- | Whether a component is made unbuildable by a "buildable: False" field. -newtype IsBuildable = IsBuildable Bool - deriving Eq - -mkIndex :: [(PN, I, PInfo)] -> Index -mkIndex xs = M.map M.fromList (groupMap (L.map (\ (pn, i, pi) -> (pn, (i, pi))) xs)) - -groupMap :: Ord a => [(a, b)] -> Map a [b] -groupMap xs = M.fromListWith (flip (++)) (L.map (\ (x, y) -> (x, [y])) xs) - -defaultQualifyOptions :: Index -> QualifyOptions -defaultQualifyOptions idx = QO { - qoBaseShim = or [ dep == base - | -- 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 - -- .. and flatten all their dependencies .. - , (LDep _ (Dep (PkgComponent dep _) _ci), _comp) <- flattenFlaggedDeps deps - ] - , qoSetupIndependent = True - } - where - base = mkPackageName "base" diff --git a/cabal/cabal-install/Distribution/Solver/Modular/IndexConversion.hs b/cabal/cabal-install/Distribution/Solver/Modular/IndexConversion.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Solver/Modular/IndexConversion.hs +++ /dev/null @@ -1,562 +0,0 @@ -module Distribution.Solver.Modular.IndexConversion - ( convPIs - ) where - -import Distribution.Solver.Compat.Prelude -import Prelude () - -import qualified Data.List as L -import qualified Data.Map.Strict as M -import qualified Distribution.Compat.NonEmptySet as NonEmptySet -import qualified Data.Set as S - -import qualified Distribution.InstalledPackageInfo as IPI -import Distribution.Compiler -import Distribution.Package -- from Cabal -import Distribution.Simple.BuildToolDepends -- from Cabal -import Distribution.Types.ExeDependency -- from Cabal -import Distribution.Types.PkgconfigDependency -- from Cabal -import Distribution.Types.ComponentName -- from Cabal -import Distribution.Types.CondTree -- from Cabal -import Distribution.Types.MungedPackageId -- from Cabal -import Distribution.Types.MungedPackageName -- from Cabal -import Distribution.PackageDescription -- from Cabal -import Distribution.PackageDescription.Configuration -import qualified Distribution.Simple.PackageIndex as SI -import Distribution.System - -import Distribution.Solver.Types.ComponentDeps - ( Component(..), componentNameToComponent ) -import Distribution.Solver.Types.Flag -import Distribution.Solver.Types.LabeledPackageConstraint -import Distribution.Solver.Types.OptionalStanza -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.Modular.Dependency as D -import Distribution.Solver.Modular.Flag as F -import Distribution.Solver.Modular.Index -import Distribution.Solver.Modular.Package -import Distribution.Solver.Modular.Tree -import Distribution.Solver.Modular.Version - --- | Convert both the installed package index and the source package --- index into one uniform solver index. --- --- We use 'allPackagesBySourcePackageId' for the installed package index --- because that returns us several instances of the same package and version --- in order of preference. This allows us in principle to \"shadow\" --- packages if there are several installed packages of the same version. --- There are currently some shortcomings in both GHC and Cabal in --- 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 = - mkIndex $ - convIPI' sip iidx ++ convSPI' os arch comp 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 = - -- apply shadowing whenever there are multiple installed packages with - -- the same version - [ maybeShadow (convIP idx pkg) - -- IMPORTANT to get internal libraries. See - -- Note [Index conversion with internal libraries] - | (_, pkgs) <- SI.allPackagesBySourcePackageIdAndLibName idx - , (maybeShadow, pkg) <- zip (id : repeat shadow) pkgs ] - where - - -- shadowing is recorded in the package info - shadow (pn, i, PInfo fdeps comps fds _) - | sip = (pn, i, PInfo fdeps comps fds (Just Shadowed)) - 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) - 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 - Nothing -> (pn, i, PInfo [] M.empty M.empty (Just Broken)) - Just fds -> ( pn, i, PInfo fds components M.empty Nothing) - where - -- TODO: Handle sub-libraries and visibility. - components = - M.singleton (ExposedLib LMainLibName) - ComponentInfo { - compIsVisible = IsVisible True - , compIsBuildable = IsBuildable True - } - - (pn, i) = convId ipi - - -- 'sourceLibName' is unreliable, but for now we only really use this for - -- primary libs anyways - comp = componentNameToComponent $ CLibName $ IPI.sourceLibName ipi --- TODO: Installed packages should also store their encapsulations! - --- Note [Index conversion with internal libraries] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Something very interesting happens when we have internal libraries --- in our index. In this case, we maybe have p-0.1, which itself --- depends on the internal library p-internal ALSO from p-0.1. --- Here's the danger: --- --- - If we treat both of these packages as having PN "p", --- then the solver will try to pick one or the other, --- but never both. --- --- - If we drop the internal packages, now p-0.1 has a --- dangling dependency on an "installed" package we know --- nothing about. Oops. --- --- An expedient hack is to put p-internal into cabal-install's --- index as a MUNGED package name, so that it doesn't conflict --- with anyone else (except other instances of itself). But --- yet, we ought NOT to say that PNs in the solver are munged --- package names, because they're not; for source packages, --- we really will never see munged package names. --- --- The tension here is that the installed package index is actually --- per library, but the solver is per package. We need to smooth --- it over, and munging the package names is a pretty good way to --- do it. - --- | Convert dependencies specified by an installed package id into --- flagged dependencies of the solver. --- --- 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 -> Maybe (FlaggedDep PN) -convIPId dr comp idx ipid = - case SI.lookupUnitId idx ipid of - Nothing -> Nothing - Just ipi -> let (pn, i) = convId ipi - name = ExposedLib LMainLibName -- TODO: Handle sub-libraries. - in Just (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 - --- | Convert a single source package into the solver-specific format. -convSP :: 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 - pkgConstraints = fromMaybe [] $ M.lookup pn constraints - in (pn, i, convGPD 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] - -> StrongFlags -> SolveExecutables -> PN -> GenericPackageDescription - -> PInfo -convGPD 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 - conv comp getInfo dr = - convCondTree M.empty dr pkg os arch cinfo pn fds comp getInfo solveExes . - addBuildableCondition getInfo - - initDR = DependencyReason pn M.empty S.empty - - flagged_deps - = concatMap (\ds -> conv ComponentLib libBuildInfo initDR ds) (maybeToList mlib) - ++ concatMap (\(nm, ds) -> conv (ComponentSubLib nm) libBuildInfo initDR ds) sub_libs - ++ concatMap (\(nm, ds) -> conv (ComponentFLib nm) foreignLibBuildInfo initDR ds) flibs - ++ concatMap (\(nm, ds) -> conv (ComponentExe nm) buildInfo initDR ds) exes - ++ prefix (Stanza (SN pn TestStanzas)) - (L.map (\(nm, ds) -> conv (ComponentTest nm) testBuildInfo (addStanza TestStanzas initDR) ds) - tests) - ++ prefix (Stanza (SN pn BenchStanzas)) - (L.map (\(nm, ds) -> conv (ComponentBench nm) benchmarkBuildInfo (addStanza BenchStanzas initDR) ds) - benchs) - ++ maybe [] (convSetupBuildInfo pn) (setupBuildInfo pkg) - - addStanza :: Stanza -> DependencyReason pn -> DependencyReason pn - addStanza s (DependencyReason pn' fs ss) = DependencyReason pn' fs (S.insert s ss) - - -- | A too-new specVersion is turned into a global 'FailReason' - -- which prevents the solver from selecting this release (and if - -- forced to, emit a meaningful solver error message). - fr = case scannedVersion of - Just ver -> Just (UnsupportedSpecVer ver) - Nothing -> Nothing - - components :: Map ExposedComponent ComponentInfo - components = M.fromList $ libComps ++ subLibComps ++ exeComps - where - libComps = [ (ExposedLib LMainLibName, libToComponentInfo lib) - | lib <- maybeToList mlib ] - subLibComps = [ (ExposedLib (LSubLibName name), libToComponentInfo lib) - | (name, lib) <- sub_libs ] - exeComps = [ ( ExposedExe name - , ComponentInfo { - compIsVisible = IsVisible True - , compIsBuildable = IsBuildable $ testCondition (buildable . buildInfo) exe /= Just False - } - ) - | (name, exe) <- exes ] - - libToComponentInfo lib = - ComponentInfo { - compIsVisible = IsVisible $ testCondition (isPrivate . libVisibility) lib /= Just True - , compIsBuildable = IsBuildable $ testCondition (buildable . libBuildInfo) lib /= Just False - } - - testCondition = testConditionForComponent os arch cinfo constraints - - isPrivate LibraryVisibilityPrivate = True - isPrivate LibraryVisibilityPublic = False - - in PInfo flagged_deps components fds fr - --- | Applies the given predicate (for example, testing buildability or --- visibility) to the given component and environment. Values are combined with --- AND. This function returns 'Nothing' when the result cannot be determined --- 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 - -> Arch - -> CompilerInfo - -> [LabeledPackageConstraint] - -> (a -> Bool) - -> CondTree ConfVar [Dependency] a - -> Maybe Bool -testConditionForComponent os arch cinfo constraints p tree = - case go $ extractCondition p tree of - Lit True -> Just True - Lit False -> Just False - _ -> Nothing - where - flagAssignment :: [(FlagName, Bool)] - flagAssignment = - mconcat [ unFlagAssignment fa - | PackageConstraint (ScopeAnyQualifier _) (PackagePropertyFlags fa) - <- L.map unlabelPackageConstraint constraints] - - -- Simplify the condition, using the current environment. Most of this - -- function was copied from convBranch and - -- Distribution.Types.Condition.simplifyCondition. - go :: Condition ConfVar -> Condition ConfVar - go (Var (OS os')) = Lit (os == os') - go (Var (Arch arch')) = Lit (arch == arch') - go (Var (Impl cf cvr)) - | matchImpl (compilerInfoId cinfo) || - -- fixme: Nothing should be treated as unknown, rather than empty - -- list. This code should eventually be changed to either - -- support partial resolution of compiler flags or to - -- complain about incompletely configured compilers. - any matchImpl (fromMaybe [] $ compilerInfoCompat cinfo) = Lit True - | otherwise = Lit False - where - matchImpl (CompilerId cf' cv) = cf == cf' && checkVR cvr cv - go (Var (PackageFlag f)) - | Just b <- L.lookup f flagAssignment = Lit b - go (Var v) = Var v - go (Lit b) = Lit b - go (CNot c) = - case go c of - Lit True -> Lit False - Lit False -> Lit True - c' -> CNot c' - go (COr c d) = - case (go c, go d) of - (Lit False, d') -> d' - (Lit True, _) -> Lit True - (c', Lit False) -> c' - (_, Lit True) -> Lit True - (c', d') -> COr c' d' - go (CAnd c d) = - case (go c, go d) of - (Lit False, _) -> Lit False - (Lit True, d') -> d' - (_, Lit False) -> Lit False - (c', Lit True) -> c' - (c', d') -> CAnd c' d' - --- | Create a flagged dependency tree from a list @fds@ of flagged --- dependencies, using @f@ to form the tree node (@f@ will be --- something like @Stanza sn@). -prefix :: (FlaggedDeps qpn -> FlaggedDep qpn) - -> [FlaggedDeps qpn] -> FlaggedDeps qpn -prefix _ [] = [] -prefix f fds = [f (concat fds)] - --- | Convert flag information. Automatic flags are now considered weak --- unless strong flags have been selected explicitly. -flagInfo :: StrongFlags -> [PackageFlag] -> FlagInfo -flagInfo (StrongFlags strfl) = - M.fromList . L.map (\ (MkPackageFlag fn _ b m) -> (fn, FInfo b (flagType m) (weak m))) - where - weak m = WeakOrTrivial $ not (strfl || m) - flagType m = if m then Manual else Automatic - --- | Convert condition trees to flagged dependencies. Mutually --- recursive with 'convBranch'. See 'convBranch' for an explanation --- of all arguments preceding the input 'CondTree'. -convCondTree :: Map FlagName Bool -> DependencyReason PN -> PackageDescription -> OS -> Arch -> CompilerInfo -> PN -> FlagInfo -> - 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) = - -- 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 - -- duplicates could grow exponentially from the leaves to the root - -- of the tree. - mergeSimpleDeps $ - [ D.Simple singleDep comp - | dep <- ds - , singleDep <- convLibDeps dr dep ] -- unconditional package dependencies - - ++ L.map (\e -> D.Simple (LDep dr (Ext e)) comp) (allExtensions bi) -- unconditional extension dependencies - ++ L.map (\l -> D.Simple (LDep dr (Lang l)) comp) (allLanguages bi) -- unconditional language dependencies - ++ L.map (\(PkgconfigDependency pkn vr) -> D.Simple (LDep dr (Pkg pkn vr)) comp) (pkgconfigDepends bi) -- unconditional pkg-config dependencies - ++ concatMap (convBranch flags dr pkg os arch cinfo pn fds comp getInfo solveExes) branches - -- build-tools dependencies - -- NB: Only include these dependencies if SolveExecutables - -- is True. It might be false in the legacy solver - -- codepath, in which case there won't be any record of - -- an executable we need. - ++ [ D.Simple (convExeDep dr exeDep) comp - | solveExes' - , exeDep <- getAllToolDependencies pkg bi - , not $ isInternal pkg exeDep - ] - where - bi = getInfo info - -data SimpleFlaggedDepKey qpn = - SimpleFlaggedDepKey (PkgComponent qpn) Component - deriving (Eq, Ord) - -data SimpleFlaggedDepValue qpn = SimpleFlaggedDepValue (DependencyReason qpn) VR - --- | Merge 'Simple' dependencies that apply to the same library or build-tool. --- This function should be able to merge any two dependencies that can be merged --- by extractCommon, in order to prevent the exponential growth of dependencies. --- --- Note that this function can merge dependencies that have different --- DependencyReasons, which can make the DependencyReasons less precise. This --- loss of precision only affects performance and log messages, not correctness. --- However, when 'mergeSimpleDeps' is only called on dependencies at a single --- location in the dependency tree, the only difference between --- DependencyReasons should be flags that have value FlagBoth. Adding extra --- flags with value FlagBoth should not affect performance, since they are not --- added to the conflict set. The only downside is the possibility of the log --- incorrectly saying that the flag contributed to excluding a specific version --- of a dependency. For example, if +/-flagA introduces pkg >=2 and +/-flagB --- introduces pkg <5, the merged dependency would mean that --- +/-flagA and +/-flagB introduce pkg >=2 && <5, which would incorrectly imply --- that +/-flagA excludes pkg-6. -mergeSimpleDeps :: Ord qpn => FlaggedDeps qpn -> FlaggedDeps qpn -mergeSimpleDeps deps = L.map (uncurry toFlaggedDep) (M.toList merged) ++ unmerged - where - (merged, unmerged) = L.foldl' f (M.empty, []) deps - where - f :: Ord qpn - => (Map (SimpleFlaggedDepKey qpn) (SimpleFlaggedDepValue qpn), FlaggedDeps qpn) - -> FlaggedDep qpn - -> (Map (SimpleFlaggedDepKey qpn) (SimpleFlaggedDepValue qpn), FlaggedDeps qpn) - f (merged', unmerged') (D.Simple (LDep dr (Dep dep (Constrained vr))) comp) = - ( M.insertWith mergeValues - (SimpleFlaggedDepKey dep comp) - (SimpleFlaggedDepValue dr vr) - merged' - , unmerged') - f (merged', unmerged') unmergeableDep = (merged', unmergeableDep : unmerged') - - mergeValues :: SimpleFlaggedDepValue qpn - -> SimpleFlaggedDepValue qpn - -> SimpleFlaggedDepValue qpn - mergeValues (SimpleFlaggedDepValue dr1 vr1) (SimpleFlaggedDepValue dr2 vr2) = - SimpleFlaggedDepValue (unionDRs dr1 dr2) (vr1 .&&. vr2) - - toFlaggedDep :: SimpleFlaggedDepKey qpn - -> SimpleFlaggedDepValue qpn - -> FlaggedDep qpn - toFlaggedDep (SimpleFlaggedDepKey dep comp) (SimpleFlaggedDepValue dr vr) = - D.Simple (LDep dr (Dep dep (Constrained vr))) comp - --- | Branch interpreter. Mutually recursive with 'convCondTree'. --- --- Here, we try to simplify one of Cabal's condition tree branches into the --- solver's flagged dependency format, which is weaker. Condition trees can --- contain complex logical expression composed from flag choices and special --- flags (such as architecture, or compiler flavour). We try to evaluate the --- special flags and subsequently simplify to a tree that only depends on --- simple flag choices. --- --- This function takes a number of arguments: --- --- 1. A map of flag values that have already been chosen. It allows --- convBranch to avoid creating nested FlaggedDeps that are --- controlled by the same flag and avoid creating DependencyReasons with --- conflicting values for the same flag. --- --- 2. The DependencyReason calculated at this point in the tree of --- conditionals. The flag values in the DependencyReason are similar to --- the values in the map above, except for the use of FlagBoth. --- --- 3. Some pre dependency-solving known information ('OS', 'Arch', --- 'CompilerInfo') for @os()@, @arch()@ and @impl()@ variables, --- --- 4. The package name @'PN'@ which this condition tree --- came from, so that we can correctly associate @flag()@ --- variables with the correct package name qualifier, --- --- 5. The flag defaults 'FlagInfo' so that we can populate --- 'Flagged' dependencies with 'FInfo', --- --- 6. The name of the component 'Component' so we can record where --- the fine-grained information about where the component came --- from (see 'convCondTree'), and --- --- 7. A selector to extract the 'BuildInfo' from the leaves of --- the 'CondTree' (which actually contains the needed --- dependency information.) --- --- 8. The set of package names which should be considered internal --- dependencies, and thus not handled as dependencies. -convBranch :: Map FlagName Bool - -> DependencyReason PN - -> PackageDescription - -> OS - -> Arch - -> CompilerInfo - -> PN - -> FlagInfo - -> Component - -> (a -> BuildInfo) - -> SolveExecutables - -> CondBranch ConfVar [Dependency] a - -> FlaggedDeps PN -convBranch flags dr pkg os arch cinfo pn fds comp getInfo solveExes (CondBranch c' t' mf') = - go c' - (\flags' dr' -> convCondTree flags' dr' pkg os arch cinfo pn fds comp getInfo solveExes t') - (\flags' dr' -> maybe [] (convCondTree flags' dr' pkg os arch cinfo pn fds comp getInfo solveExes) mf') - flags dr - where - go :: Condition ConfVar - -> (Map FlagName Bool -> DependencyReason PN -> FlaggedDeps PN) - -> (Map FlagName Bool -> DependencyReason PN -> FlaggedDeps PN) - -> Map FlagName Bool -> DependencyReason PN -> FlaggedDeps PN - go (Lit True) t _ = t - go (Lit False) _ f = f - go (CNot c) t f = go c f t - go (CAnd c d) t f = go c (go d t f) f - go (COr c d) t f = go c t (go d t f) - go (Var (PackageFlag fn)) t f = \flags' -> - case M.lookup fn flags' of - Just True -> t flags' - Just False -> f flags' - Nothing -> \dr' -> - -- Add each flag to the DependencyReason for all dependencies below, - -- including any extracted dependencies. Extracted dependencies are - -- introduced by both flag values (FlagBoth). Note that we don't - -- actually need to add the flag to the extracted dependencies for - -- correct backjumping; the information only improves log messages - -- by giving the user the full reason for each dependency. - let addFlagValue v = addFlagToDependencyReason fn v dr' - addFlag v = M.insert fn v flags' - in extractCommon (t (addFlag True) (addFlagValue FlagBoth)) - (f (addFlag False) (addFlagValue FlagBoth)) - ++ [ Flagged (FN pn fn) (fds M.! fn) (t (addFlag True) (addFlagValue FlagTrue)) - (f (addFlag False) (addFlagValue FlagFalse)) ] - go (Var (OS os')) t f - | os == os' = t - | otherwise = f - go (Var (Arch arch')) t f - | arch == arch' = t - | otherwise = f - go (Var (Impl cf cvr)) t f - | matchImpl (compilerInfoId cinfo) || - -- fixme: Nothing should be treated as unknown, rather than empty - -- list. This code should eventually be changed to either - -- support partial resolution of compiler flags or to - -- complain about incompletely configured compilers. - any matchImpl (fromMaybe [] $ compilerInfoCompat cinfo) = t - | otherwise = f - where - matchImpl (CompilerId cf' cv) = cf == cf' && checkVR cvr cv - - addFlagToDependencyReason :: FlagName -> FlagValue -> DependencyReason pn -> DependencyReason pn - addFlagToDependencyReason fn v (DependencyReason pn' fs ss) = - DependencyReason pn' (M.insert fn v fs) ss - - -- If both branches contain the same package as a simple dep, we lift it to - -- the next higher-level, but with the union of version ranges. This - -- heuristic together with deferring flag choices will then usually first - -- resolve this package, and try an already installed version before imposing - -- a default flag choice that might not be what we want. - -- - -- Note that we make assumptions here on the form of the dependencies that - -- can occur at this point. In particular, no occurrences of Fixed, as all - -- dependencies below this point have been generated using 'convLibDep'. - -- - -- WARNING: This is quadratic! - extractCommon :: Eq pn => FlaggedDeps pn -> FlaggedDeps pn -> FlaggedDeps pn - extractCommon ps ps' = - -- Union the DependencyReasons, because the extracted dependency can be - -- avoided by removing the dependency from either side of the - -- conditional. - [ D.Simple (LDep (unionDRs vs1 vs2) (Dep dep1 (Constrained $ vr1 .||. vr2))) comp - | D.Simple (LDep vs1 (Dep dep1 (Constrained vr1))) _ <- ps - , D.Simple (LDep vs2 (Dep dep2 (Constrained vr2))) _ <- ps' - , dep1 == dep2 - ] - --- | Merge DependencyReasons by unioning their variables. -unionDRs :: DependencyReason pn -> DependencyReason pn -> DependencyReason pn -unionDRs (DependencyReason pn' fs1 ss1) (DependencyReason _ fs2 ss2) = - DependencyReason pn' (M.union fs1 fs2) (S.union ss1 ss2) - --- | Convert a Cabal dependency on a set of library components (from a single --- package) to solver-specific dependencies. -convLibDeps :: DependencyReason PN -> Dependency -> [LDep PN] -convLibDeps dr (Dependency pn vr libs) = - [ LDep dr $ Dep (PkgComponent pn (ExposedLib lib)) (Constrained vr) - | lib <- NonEmptySet.toList libs ] - --- | Convert a Cabal dependency on an executable (build-tools) to a solver-specific dependency. -convExeDep :: DependencyReason PN -> ExeDependency -> LDep PN -convExeDep dr (ExeDependency pn exe vr) = LDep dr $ Dep (PkgComponent pn (ExposedExe exe)) (Constrained vr) - --- | Convert setup dependencies -convSetupBuildInfo :: PN -> SetupBuildInfo -> FlaggedDeps PN -convSetupBuildInfo pn nfo = - [ D.Simple singleDep ComponentSetup - | dep <- setupDepends nfo - , singleDep <- convLibDeps (DependencyReason pn M.empty S.empty) dep ] diff --git a/cabal/cabal-install/Distribution/Solver/Modular/LabeledGraph.hs b/cabal/cabal-install/Distribution/Solver/Modular/LabeledGraph.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Solver/Modular/LabeledGraph.hs +++ /dev/null @@ -1,117 +0,0 @@ --- | Wrapper around Data.Graph with support for edge labels -{-# LANGUAGE ScopedTypeVariables #-} -module Distribution.Solver.Modular.LabeledGraph ( - -- * Graphs - Graph - , Vertex - -- ** Building graphs - , graphFromEdges - , graphFromEdges' - , buildG - , transposeG - -- ** Graph properties - , vertices - , edges - -- ** Operations on the underlying unlabeled graph - , forgetLabels - , topSort - ) where - -import Distribution.Solver.Compat.Prelude -import Prelude () - -import Data.Array -import Data.Graph (Vertex, Bounds) -import qualified Data.Graph as G - -{------------------------------------------------------------------------------- - Types --------------------------------------------------------------------------------} - -type Graph e = Array Vertex [(e, Vertex)] -type Edge e = (Vertex, e, Vertex) - -{------------------------------------------------------------------------------- - Building graphs --------------------------------------------------------------------------------} - --- | Construct an edge-labeled graph --- --- This is a simple adaptation of the definition in Data.Graph -graphFromEdges :: forall key node edge. Ord key - => [ (node, key, [(edge, key)]) ] - -> ( Graph edge - , Vertex -> (node, key, [(edge, key)]) - , key -> Maybe Vertex - ) -graphFromEdges edges0 = - (graph, \v -> vertex_map ! v, key_vertex) - where - max_v = length edges0 - 1 - bounds0 = (0, max_v) :: (Vertex, Vertex) - sorted_edges = sortBy lt edges0 - edges1 = zip [0..] sorted_edges - - graph = array bounds0 [(v, (mapMaybe mk_edge ks)) - | (v, (_, _, ks)) <- edges1] - key_map = array bounds0 [(v, k ) - | (v, (_, k, _ )) <- edges1] - vertex_map = array bounds0 edges1 - - (_,k1,_) `lt` (_,k2,_) = k1 `compare` k2 - - mk_edge :: (edge, key) -> Maybe (edge, Vertex) - mk_edge (edge, key) = do v <- key_vertex key ; return (edge, v) - - -- returns Nothing for non-interesting vertices - key_vertex :: key -> Maybe Vertex - key_vertex k = findVertex 0 max_v - where - findVertex a b - | a > b = Nothing - | otherwise = case compare k (key_map ! mid) of - LT -> findVertex a (mid-1) - EQ -> Just mid - GT -> findVertex (mid+1) b - where - mid = a + (b - a) `div` 2 - -graphFromEdges' :: Ord key - => [ (node, key, [(edge, key)]) ] - -> ( Graph edge - , Vertex -> (node, key, [(edge, key)]) - ) -graphFromEdges' x = (a,b) - where - (a,b,_) = graphFromEdges x - -transposeG :: Graph e -> Graph e -transposeG g = buildG (bounds g) (reverseE g) - -buildG :: Bounds -> [Edge e] -> Graph e -buildG bounds0 edges0 = accumArray (flip (:)) [] bounds0 (map reassoc edges0) - where - reassoc (v, e, w) = (v, (e, w)) - -reverseE :: Graph e -> [Edge e] -reverseE g = [ (w, e, v) | (v, e, w) <- edges g ] - -{------------------------------------------------------------------------------- - Graph properties --------------------------------------------------------------------------------} - -vertices :: Graph e -> [Vertex] -vertices = indices - -edges :: Graph e -> [Edge e] -edges g = [ (v, e, w) | v <- vertices g, (e, w) <- g!v ] - -{------------------------------------------------------------------------------- - Operations on the underlying unlabelled graph --------------------------------------------------------------------------------} - -forgetLabels :: Graph e -> G.Graph -forgetLabels = fmap (map snd) - -topSort :: Graph e -> [Vertex] -topSort = G.topSort . forgetLabels diff --git a/cabal/cabal-install/Distribution/Solver/Modular/Linking.hs b/cabal/cabal-install/Distribution/Solver/Modular/Linking.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Solver/Modular/Linking.hs +++ /dev/null @@ -1,519 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} - --- TODO: remove this -{-# OPTIONS -fno-warn-incomplete-uni-patterns #-} -module Distribution.Solver.Modular.Linking ( - validateLinking - ) where - -import Prelude () -import Distribution.Solver.Compat.Prelude hiding (get,put) - -import Control.Exception (assert) -import Control.Monad.Reader -import Control.Monad.State -import Data.Map ((!)) -import qualified Data.Map as M -import qualified Data.Set as S -import qualified Data.Traversable as T - -import Distribution.Client.Utils.Assertion -import Distribution.Solver.Modular.Assignment -import Distribution.Solver.Modular.Dependency -import Distribution.Solver.Modular.Flag -import Distribution.Solver.Modular.Index -import Distribution.Solver.Modular.Package -import Distribution.Solver.Modular.Tree -import qualified Distribution.Solver.Modular.ConflictSet as CS -import qualified Distribution.Solver.Modular.WeightedPSQ as W - -import Distribution.Solver.Types.OptionalStanza -import Distribution.Solver.Types.PackagePath -import Distribution.Types.Flag (unFlagName) - -{------------------------------------------------------------------------------- - Validation - - Validation of links is a separate pass that's performed after normal - validation. Validation of links checks that if the tree indicates that a - package is linked, then everything underneath that choice really matches the - package we have linked to. - - This is interesting because it isn't unidirectional. Consider that we've - chosen a.foo to be version 1 and later decide that b.foo should link to a.foo. - Now foo depends on bar. Because a.foo and b.foo are linked, it's required that - a.bar and b.bar are also linked. However, it's not required that we actually - choose a.bar before b.bar. Goal choice order is relatively free. It's possible - that we choose a.bar first, but also possible that we choose b.bar first. In - both cases, we have to recognize that we have freedom of choice for the first - of the two, but no freedom of choice for the second. - - This is what LinkGroups are all about. Using LinkGroup, we can record (in the - situation above) that a.bar and b.bar need to be linked even if we haven't - chosen either of them yet. --------------------------------------------------------------------------------} - -data ValidateState = VS { - vsIndex :: Index - , vsLinks :: Map QPN LinkGroup - , vsFlags :: FAssignment - , vsStanzas :: SAssignment - , vsQualifyOptions :: QualifyOptions - - -- Saved qualified dependencies. Every time 'validateLinking' makes a - -- package choice, it qualifies the package's dependencies and saves them in - -- this map. Then the qualified dependencies are available for subsequent - -- flag and stanza choices for the same package. - , vsSaved :: Map QPN (FlaggedDeps QPN) - } - -type Validate = Reader ValidateState - --- | Validate linked packages --- --- Verify that linked packages have --- --- * Linked dependencies, --- * Equal flag assignments --- * Equal stanza assignments -validateLinking :: Index -> Tree d c -> Tree d c -validateLinking index = (`runReader` initVS) . cata go - where - go :: TreeF d c (Validate (Tree d c)) -> Validate (Tree d c) - - go (PChoiceF qpn rdm gr cs) = - PChoice qpn rdm gr <$> T.sequence (W.mapWithKey (goP qpn) cs) - go (FChoiceF qfn rdm gr t m d cs) = - FChoice qfn rdm gr t m d <$> T.sequence (W.mapWithKey (goF qfn) cs) - go (SChoiceF qsn rdm gr t cs) = - SChoice qsn rdm gr t <$> T.sequence (W.mapWithKey (goS qsn) cs) - - -- For the other nodes we just recurse - go (GoalChoiceF rdm cs) = GoalChoice rdm <$> T.sequence cs - go (DoneF revDepMap s) = return $ Done revDepMap s - go (FailF conflictSet failReason) = return $ Fail conflictSet failReason - - -- Package choices - goP :: QPN -> POption -> Validate (Tree d c) -> Validate (Tree d c) - 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 - newSaved = M.insert qpn qdeps (vsSaved vs) - case execUpdateState (pickPOption qpn opt qdeps) vs of - Left (cs, err) -> return $ Fail cs (DependenciesNotLinked err) - Right vs' -> local (const vs' { vsSaved = newSaved }) r - - -- Flag choices - goF :: QFN -> Bool -> Validate (Tree d c) -> Validate (Tree d c) - goF qfn b r = do - vs <- ask - case execUpdateState (pickFlag qfn b) vs of - Left (cs, err) -> return $ Fail cs (DependenciesNotLinked err) - Right vs' -> local (const vs') r - - -- Stanza choices (much the same as flag choices) - goS :: QSN -> Bool -> Validate (Tree d c) -> Validate (Tree d c) - goS qsn b r = do - vs <- ask - case execUpdateState (pickStanza qsn b) vs of - Left (cs, err) -> return $ Fail cs (DependenciesNotLinked err) - Right vs' -> local (const vs') r - - initVS :: ValidateState - initVS = VS { - vsIndex = index - , vsLinks = M.empty - , vsFlags = M.empty - , vsStanzas = M.empty - , vsQualifyOptions = defaultQualifyOptions index - , vsSaved = M.empty - } - -{------------------------------------------------------------------------------- - Updating the validation state --------------------------------------------------------------------------------} - -type Conflict = (ConflictSet, String) - -newtype UpdateState a = UpdateState { - unUpdateState :: StateT ValidateState (Either Conflict) a - } - deriving (Functor, Applicative, Monad) - -instance MonadState ValidateState UpdateState where - get = UpdateState $ get - put st = UpdateState $ do - expensiveAssert (lgInvariant $ vsLinks st) $ return () - put st - -lift' :: Either Conflict a -> UpdateState a -lift' = UpdateState . lift - -conflict :: Conflict -> UpdateState a -conflict = lift' . Left - -execUpdateState :: UpdateState () -> ValidateState -> Either Conflict ValidateState -execUpdateState = execStateT . unUpdateState - -pickPOption :: QPN -> POption -> FlaggedDeps QPN -> UpdateState () -pickPOption qpn (POption i Nothing) _deps = pickConcrete qpn i -pickPOption qpn (POption i (Just pp')) deps = pickLink qpn i pp' deps - -pickConcrete :: QPN -> I -> UpdateState () -pickConcrete qpn@(Q pp _) i = do - vs <- get - case M.lookup qpn (vsLinks vs) of - -- Package is not yet in a LinkGroup. Create a new singleton link group. - Nothing -> do - let lg = lgSingleton qpn (Just $ PI pp i) - updateLinkGroup lg - - -- Package is already in a link group. Since we are picking a concrete - -- instance here, it must by definition be the canonical package. - Just lg -> - makeCanonical lg qpn i - -pickLink :: QPN -> I -> PackagePath -> FlaggedDeps QPN -> UpdateState () -pickLink qpn@(Q _pp pn) i pp' deps = do - vs <- get - - -- The package might already be in a link group - -- (because one of its reverse dependencies is) - let lgSource = case M.lookup qpn (vsLinks vs) of - Nothing -> lgSingleton qpn Nothing - Just lg -> lg - - -- Find the link group for the package we are linking to - -- - -- Since the builder never links to a package without having first picked a - -- concrete instance for that package, and since we create singleton link - -- groups for concrete instances, this link group must exist (and must - -- in fact already have a canonical member). - let target = Q pp' pn - lgTarget = vsLinks vs ! target - - -- Verify here that the member we add is in fact for the same package and - -- matches the version of the canonical instance. However, violations of - -- these checks would indicate a bug in the linker, not a true conflict. - let sanityCheck :: Maybe (PI PackagePath) -> Bool - sanityCheck Nothing = False - sanityCheck (Just (PI _ canonI)) = pn == lgPackage lgTarget && i == canonI - assert (sanityCheck (lgCanon lgTarget)) $ return () - - -- Merge the two link groups (updateLinkGroup will propagate the change) - lgTarget' <- lift' $ lgMerge CS.empty lgSource lgTarget - updateLinkGroup lgTarget' - - -- Make sure all dependencies are linked as well - linkDeps target deps - -makeCanonical :: LinkGroup -> QPN -> I -> UpdateState () -makeCanonical lg qpn@(Q pp _) i = - case lgCanon lg of - -- There is already a canonical member. Fail. - Just _ -> - conflict ( CS.insert (P qpn) (lgConflictSet lg) - , "cannot make " ++ showQPN qpn - ++ " canonical member of " ++ showLinkGroup lg - ) - Nothing -> do - let lg' = lg { lgCanon = Just (PI pp i) } - updateLinkGroup lg' - --- | Link the dependencies of linked parents. --- --- When we decide to link one package against another we walk through the --- package's direct depedencies and make sure that they're all linked to each --- other by merging their link groups (or creating new singleton link groups if --- they don't have link groups yet). We do not need to do this recursively, --- because having the direct dependencies in a link group means that we must --- have already made or will make sooner or later a link choice for one of these --- as well, and cover their dependencies at that point. -linkDeps :: QPN -> FlaggedDeps QPN -> UpdateState () -linkDeps target = \deps -> do - -- linkDeps is called in two places: when we first link one package to - -- another, and when we discover more dependencies of an already linked - -- package after doing some flag assignment. It is therefore important that - -- flag assignments cannot influence _how_ dependencies are qualified; - -- fortunately this is a documented property of 'qualifyDeps'. - rdeps <- requalify deps - go deps rdeps - where - go :: FlaggedDeps QPN -> FlaggedDeps QPN -> UpdateState () - go = zipWithM_ go1 - - go1 :: FlaggedDep QPN -> FlaggedDep QPN -> UpdateState () - go1 dep rdep = case (dep, rdep) of - (Simple (LDep dr1 (Dep (PkgComponent qpn _) _)) _, ~(Simple (LDep dr2 (Dep (PkgComponent qpn' _) _)) _)) -> do - vs <- get - let lg = M.findWithDefault (lgSingleton qpn Nothing) qpn $ vsLinks vs - lg' = M.findWithDefault (lgSingleton qpn' Nothing) qpn' $ vsLinks vs - lg'' <- lift' $ lgMerge ((CS.union `on` dependencyReasonToConflictSet) dr1 dr2) lg lg' - updateLinkGroup lg'' - (Flagged fn _ t f, ~(Flagged _ _ t' f')) -> do - vs <- get - case M.lookup fn (vsFlags vs) of - Nothing -> return () -- flag assignment not yet known - Just True -> go t t' - Just False -> go f f' - (Stanza sn t, ~(Stanza _ t')) -> do - vs <- get - case M.lookup sn (vsStanzas vs) of - Nothing -> return () -- stanza assignment not yet known - Just True -> go t t' - Just False -> return () -- stanza not enabled; no new deps - -- For extensions and language dependencies, there is nothing to do. - -- No choice is involved, just checking, so there is nothing to link. - -- The same goes for pkg-config constraints. - (Simple (LDep _ (Ext _)) _, _) -> return () - (Simple (LDep _ (Lang _)) _, _) -> return () - (Simple (LDep _ (Pkg _ _)) _, _) -> return () - - requalify :: FlaggedDeps QPN -> UpdateState (FlaggedDeps QPN) - requalify deps = do - vs <- get - return $ qualifyDeps (vsQualifyOptions vs) target (unqualifyDeps deps) - -pickFlag :: QFN -> Bool -> UpdateState () -pickFlag qfn b = do - modify $ \vs -> vs { vsFlags = M.insert qfn b (vsFlags vs) } - verifyFlag qfn - linkNewDeps (F qfn) b - -pickStanza :: QSN -> Bool -> UpdateState () -pickStanza qsn b = do - modify $ \vs -> vs { vsStanzas = M.insert qsn b (vsStanzas vs) } - verifyStanza qsn - linkNewDeps (S qsn) b - --- | Link dependencies that we discover after making a flag or stanza choice. --- --- When we make a flag choice for a package, then new dependencies for that --- package might become available. If the package under consideration is in a --- non-trivial link group, then these new dependencies have to be linked as --- well. In linkNewDeps, we compute such new dependencies and make sure they are --- linked. -linkNewDeps :: Var QPN -> Bool -> UpdateState () -linkNewDeps var b = do - vs <- get - let qpn@(Q pp pn) = varPN var - qdeps = vsSaved vs ! qpn - lg = vsLinks vs ! qpn - newDeps = findNewDeps vs qdeps - linkedTo = S.delete pp (lgMembers lg) - forM_ (S.toList linkedTo) $ \pp' -> linkDeps (Q pp' pn) newDeps - where - findNewDeps :: ValidateState -> FlaggedDeps QPN -> FlaggedDeps QPN - findNewDeps vs = concatMap (findNewDeps' vs) - - findNewDeps' :: ValidateState -> FlaggedDep QPN -> FlaggedDeps QPN - findNewDeps' _ (Simple _ _) = [] - findNewDeps' vs (Flagged qfn _ t f) = - case (F qfn == var, M.lookup qfn (vsFlags vs)) of - (True, _) -> if b then t else f - (_, Nothing) -> [] -- not yet known - (_, Just b') -> findNewDeps vs (if b' then t else f) - findNewDeps' vs (Stanza qsn t) = - case (S qsn == var, M.lookup qsn (vsStanzas vs)) of - (True, _) -> if b then t else [] - (_, Nothing) -> [] -- not yet known - (_, Just b') -> findNewDeps vs (if b' then t else []) - -updateLinkGroup :: LinkGroup -> UpdateState () -updateLinkGroup lg = do - verifyLinkGroup lg - modify $ \vs -> vs { - vsLinks = M.fromList (map aux (S.toList (lgMembers lg))) - `M.union` vsLinks vs - } - where - aux pp = (Q pp (lgPackage lg), lg) - -{------------------------------------------------------------------------------- - Verification --------------------------------------------------------------------------------} - -verifyLinkGroup :: LinkGroup -> UpdateState () -verifyLinkGroup lg = - case lgInstance lg of - -- No instance picked yet. Nothing to verify - Nothing -> - return () - - -- We picked an instance. Verify flags and stanzas - -- TODO: The enumeration of OptionalStanza names is very brittle; - -- if a constructor is added to the datatype we won't notice it here - Just i -> do - vs <- get - let PInfo _deps _exes finfo _ = vsIndex vs ! lgPackage lg ! i - flags = M.keys finfo - stanzas = [TestStanzas, BenchStanzas] - forM_ flags $ \fn -> do - let flag = FN (lgPackage lg) fn - verifyFlag' flag lg - forM_ stanzas $ \sn -> do - let stanza = SN (lgPackage lg) sn - verifyStanza' stanza lg - -verifyFlag :: QFN -> UpdateState () -verifyFlag (FN qpn@(Q _pp pn) fn) = do - vs <- get - -- We can only pick a flag after picking an instance; link group must exist - verifyFlag' (FN pn fn) (vsLinks vs ! qpn) - -verifyStanza :: QSN -> UpdateState () -verifyStanza (SN qpn@(Q _pp pn) sn) = do - vs <- get - -- We can only pick a stanza after picking an instance; link group must exist - verifyStanza' (SN pn sn) (vsLinks vs ! qpn) - --- | Verify that all packages in the link group agree on flag assignments --- --- For the given flag and the link group, obtain all assignments for the flag --- that have already been made for link group members, and check that they are --- equal. -verifyFlag' :: FN PN -> LinkGroup -> UpdateState () -verifyFlag' (FN pn fn) lg = do - vs <- get - let flags = map (\pp' -> FN (Q pp' pn) fn) (S.toList (lgMembers lg)) - vals = map (`M.lookup` vsFlags vs) flags - if allEqual (catMaybes vals) -- We ignore not-yet assigned flags - then return () - else conflict ( CS.fromList (map F flags) `CS.union` lgConflictSet lg - , "flag \"" ++ unFlagName fn ++ "\" incompatible" - ) - --- | Verify that all packages in the link group agree on stanza assignments --- --- For the given stanza and the link group, obtain all assignments for the --- stanza that have already been made for link group members, and check that --- they are equal. --- --- This function closely mirrors 'verifyFlag''. -verifyStanza' :: SN PN -> LinkGroup -> UpdateState () -verifyStanza' (SN pn sn) lg = do - vs <- get - let stanzas = map (\pp' -> SN (Q pp' pn) sn) (S.toList (lgMembers lg)) - vals = map (`M.lookup` vsStanzas vs) stanzas - if allEqual (catMaybes vals) -- We ignore not-yet assigned stanzas - then return () - else conflict ( CS.fromList (map S stanzas) `CS.union` lgConflictSet lg - , "stanza \"" ++ showStanza sn ++ "\" incompatible" - ) - -{------------------------------------------------------------------------------- - Link groups --------------------------------------------------------------------------------} - --- | Set of packages that must be linked together --- --- A LinkGroup is between several qualified package names. In the validation --- state, we maintain a map vsLinks from qualified package names to link groups. --- There is an invariant that for all members of a link group, vsLinks must map --- to the same link group. The function updateLinkGroup can be used to --- re-establish this invariant after creating or expanding a LinkGroup. -data LinkGroup = LinkGroup { - -- | The name of the package of this link group - lgPackage :: PN - - -- | The canonical member of this link group (the one where we picked - -- a concrete instance). Once we have picked a canonical member, all - -- other packages must link to this one. - -- - -- We may not know this yet (if we are constructing link groups - -- for dependencies) - , lgCanon :: Maybe (PI PackagePath) - - -- | The members of the link group - , lgMembers :: Set PackagePath - - -- | The set of variables that should be added to the conflict set if - -- something goes wrong with this link set (in addition to the members - -- of the link group itself) - , lgBlame :: ConflictSet - } - deriving (Show, Eq) - --- | Invariant for the set of link groups: every element in the link group --- must be pointing to the /same/ link group -lgInvariant :: Map QPN LinkGroup -> Bool -lgInvariant links = all invGroup (M.elems links) - where - invGroup :: LinkGroup -> Bool - invGroup lg = allEqual $ map (`M.lookup` links) members - where - members :: [QPN] - members = map (`Q` lgPackage lg) $ S.toList (lgMembers lg) - --- | Package version of this group --- --- This is only known once we have picked a canonical element. -lgInstance :: LinkGroup -> Maybe I -lgInstance = fmap (\(PI _ i) -> i) . lgCanon - -showLinkGroup :: LinkGroup -> String -showLinkGroup lg = - "{" ++ intercalate "," (map showMember (S.toList (lgMembers lg))) ++ "}" - where - showMember :: PackagePath -> String - showMember pp = case lgCanon lg of - Just (PI pp' _i) | pp == pp' -> "*" - _otherwise -> "" - ++ case lgInstance lg of - Nothing -> showQPN (qpn pp) - Just i -> showPI (PI (qpn pp) i) - - qpn :: PackagePath -> QPN - qpn pp = Q pp (lgPackage lg) - --- | Creates a link group that contains a single member. -lgSingleton :: QPN -> Maybe (PI PackagePath) -> LinkGroup -lgSingleton (Q pp pn) canon = LinkGroup { - lgPackage = pn - , lgCanon = canon - , lgMembers = S.singleton pp - , lgBlame = CS.empty - } - -lgMerge :: ConflictSet -> LinkGroup -> LinkGroup -> Either Conflict LinkGroup -lgMerge blame lg lg' = do - canon <- pick (lgCanon lg) (lgCanon lg') - return LinkGroup { - lgPackage = lgPackage lg - , lgCanon = canon - , lgMembers = lgMembers lg `S.union` lgMembers lg' - , lgBlame = CS.unions [blame, lgBlame lg, lgBlame lg'] - } - where - pick :: Eq a => Maybe a -> Maybe a -> Either Conflict (Maybe a) - pick Nothing Nothing = Right Nothing - pick (Just x) Nothing = Right $ Just x - pick Nothing (Just y) = Right $ Just y - pick (Just x) (Just y) = - if x == y then Right $ Just x - else Left ( CS.unions [ - blame - , lgConflictSet lg - , lgConflictSet lg' - ] - , "cannot merge " ++ showLinkGroup lg - ++ " and " ++ showLinkGroup lg' - ) - -lgConflictSet :: LinkGroup -> ConflictSet -lgConflictSet lg = - CS.fromList (map aux (S.toList (lgMembers lg))) - `CS.union` lgBlame lg - where - aux pp = P (Q pp (lgPackage lg)) - -{------------------------------------------------------------------------------- - Auxiliary --------------------------------------------------------------------------------} - -allEqual :: Eq a => [a] -> Bool -allEqual [] = True -allEqual [_] = True -allEqual (x:y:ys) = x == y && allEqual (y:ys) diff --git a/cabal/cabal-install/Distribution/Solver/Modular/Log.hs b/cabal/cabal-install/Distribution/Solver/Modular/Log.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Solver/Modular/Log.hs +++ /dev/null @@ -1,31 +0,0 @@ -module Distribution.Solver.Modular.Log - ( displayLogMessages - , SolverFailure(..) - ) where - -import Prelude () -import Distribution.Solver.Compat.Prelude - -import Distribution.Solver.Types.Progress - -import Distribution.Solver.Modular.Dependency -import Distribution.Solver.Modular.Message -import Distribution.Solver.Modular.RetryLog - --- | Information about a dependency solver failure. -data SolverFailure = - ExhaustiveSearch ConflictSet ConflictMap - | BackjumpLimitReached - --- | Postprocesses a log file. This function discards all log messages and --- avoids calling 'showMessages' if the log isn't needed (specified by --- 'keepLog'), for efficiency. -displayLogMessages :: Bool - -> RetryLog Message SolverFailure a - -> RetryLog String SolverFailure a -displayLogMessages keepLog lg = fromProgress $ - if keepLog - then showMessages progress - else foldProgress (const id) Fail Done progress - where - progress = toProgress lg diff --git a/cabal/cabal-install/Distribution/Solver/Modular/Message.hs b/cabal/cabal-install/Distribution/Solver/Modular/Message.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Solver/Modular/Message.hs +++ /dev/null @@ -1,271 +0,0 @@ -{-# LANGUAGE BangPatterns #-} - -module Distribution.Solver.Modular.Message ( - Message(..), - showMessages - ) where - -import qualified Data.List as L -import Data.Map (Map) -import qualified Data.Map as M -import Data.Set (Set) -import qualified Data.Set as S -import Data.Maybe (catMaybes, mapMaybe) -import Prelude hiding (pi) - -import Distribution.Pretty (prettyShow) -- from Cabal - -import qualified Distribution.Solver.Modular.ConflictSet as CS -import Distribution.Solver.Modular.Dependency -import Distribution.Solver.Modular.Flag -import Distribution.Solver.Modular.Package -import Distribution.Solver.Modular.Tree - ( FailReason(..), POption(..), ConflictingDep(..) ) -import Distribution.Solver.Modular.Version -import Distribution.Solver.Types.ConstraintSource -import Distribution.Solver.Types.PackagePath -import Distribution.Solver.Types.Progress -import Distribution.Types.LibraryName -import Distribution.Types.UnqualComponentName - -data Message = - Enter -- ^ increase indentation level - | Leave -- ^ decrease indentation level - | TryP QPN POption - | TryF QFN Bool - | TryS QSN Bool - | Next (Goal QPN) - | Skip (Set CS.Conflict) - | Success - | Failure ConflictSet FailReason - --- | Transforms the structured message type to actual messages (strings). --- --- The log contains level numbers, which are useful for any trace that involves --- backtracking, because only the level numbers will allow to keep track of --- backjumps. -showMessages :: Progress Message a b -> Progress String a b -showMessages = go 0 - where - -- 'go' increments the level for a recursive call when it encounters - -- 'TryP', 'TryF', or 'TryS' and decrements the level when it encounters 'Leave'. - go :: Int -> Progress Message a b -> Progress String a b - go !_ (Done x) = Done x - go !_ (Fail x) = Fail x - -- complex patterns - go !l (Step (TryP qpn i) (Step Enter (Step (Failure c fr) (Step Leave ms)))) = - goPReject l qpn [i] c fr ms - go !l (Step (TryP qpn i) (Step Enter (Step (Skip conflicts) (Step Leave ms)))) = - goPSkip l qpn [i] conflicts ms - go !l (Step (TryF qfn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) = - (atLevel l $ "rejecting: " ++ showQFNBool qfn b ++ showFR c fr) (go l ms) - go !l (Step (TryS qsn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) = - (atLevel l $ "rejecting: " ++ showQSNBool qsn b ++ showFR c fr) (go l ms) - go !l (Step (Next (Goal (P _ ) gr)) (Step (TryP qpn' i) ms@(Step Enter (Step (Next _) _)))) = - (atLevel l $ "trying: " ++ showQPNPOpt qpn' i ++ showGR gr) (go l ms) - go !l (Step (Next (Goal (P qpn) gr)) (Step (Failure _c UnknownPackage) ms)) = - (atLevel l $ "unknown package: " ++ showQPN qpn ++ showGR gr) $ go l ms - -- standard display - go !l (Step Enter ms) = go (l+1) ms - go !l (Step Leave ms) = go (l-1) ms - go !l (Step (TryP qpn i) ms) = (atLevel l $ "trying: " ++ showQPNPOpt qpn i) (go l ms) - go !l (Step (TryF qfn b) ms) = (atLevel l $ "trying: " ++ showQFNBool qfn b) (go l ms) - go !l (Step (TryS qsn b) ms) = (atLevel l $ "trying: " ++ showQSNBool qsn b) (go l ms) - go !l (Step (Next (Goal (P qpn) gr)) ms) = (atLevel l $ showPackageGoal qpn gr) (go l ms) - go !l (Step (Next _) ms) = go l ms -- ignore flag goals in the log - go !l (Step (Skip conflicts) ms) = - -- 'Skip' should always be handled by 'goPSkip' in the case above. - (atLevel l $ "skipping: " ++ showConflicts conflicts) (go l ms) - go !l (Step (Success) ms) = (atLevel l $ "done") (go l ms) - go !l (Step (Failure c fr) ms) = (atLevel l $ showFailure c fr) (go l ms) - - showPackageGoal :: QPN -> QGoalReason -> String - showPackageGoal qpn gr = "next goal: " ++ showQPN qpn ++ showGR gr - - showFailure :: ConflictSet -> FailReason -> String - showFailure c fr = "fail" ++ showFR c fr - - -- special handler for many subsequent package rejections - goPReject :: Int - -> QPN - -> [POption] - -> ConflictSet - -> FailReason - -> Progress Message a b - -> Progress String a b - goPReject l qpn is c fr (Step (TryP qpn' i) (Step Enter (Step (Failure _ fr') (Step Leave ms)))) - | qpn == qpn' && fr == fr' = goPReject l qpn (i : is) c fr ms - goPReject l qpn is c fr ms = - (atLevel l $ "rejecting: " ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is)) ++ showFR c fr) (go l ms) - - -- Handle many subsequent skipped package instances. - goPSkip :: Int - -> QPN - -> [POption] - -> Set CS.Conflict - -> Progress Message a b - -> Progress String a b - goPSkip l qpn is conflicts (Step (TryP qpn' i) (Step Enter (Step (Skip conflicts') (Step Leave ms)))) - | qpn == qpn' && conflicts == conflicts' = goPSkip l qpn (i : is) conflicts ms - goPSkip l qpn is conflicts ms = - let msg = "skipping: " - ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is)) - ++ showConflicts conflicts - in atLevel l msg (go l ms) - - -- write a message with the current level number - atLevel :: Int -> String -> Progress String a b -> Progress String a b - atLevel l x xs = - let s = show l - in Step ("[" ++ replicate (3 - length s) '_' ++ s ++ "] " ++ x) xs - --- | Display the set of 'Conflicts' for a skipped package version. -showConflicts :: Set CS.Conflict -> String -showConflicts conflicts = - " (has the same characteristics that caused the previous version to fail: " - ++ conflictMsg ++ ")" - where - conflictMsg :: String - conflictMsg = - if S.member CS.OtherConflict conflicts - then - -- This case shouldn't happen, because an unknown conflict should not - -- cause a version to be skipped. - "unknown conflict" - else let mergedConflicts = - [ showConflict qpn conflict - | (qpn, conflict) <- M.toList (mergeConflicts conflicts) ] - in if L.null mergedConflicts - then - -- This case shouldn't happen unless backjumping is turned off. - "none" - else L.intercalate "; " mergedConflicts - - -- Merge conflicts to simplify the log message. - mergeConflicts :: Set CS.Conflict -> Map QPN MergedPackageConflict - mergeConflicts = M.fromListWith mergeConflict . mapMaybe toMergedConflict . S.toList - where - mergeConflict :: MergedPackageConflict - -> MergedPackageConflict - -> MergedPackageConflict - mergeConflict mergedConflict1 mergedConflict2 = MergedPackageConflict { - isGoalConflict = - isGoalConflict mergedConflict1 || isGoalConflict mergedConflict2 - , versionConstraintConflict = - L.nub $ versionConstraintConflict mergedConflict1 - ++ versionConstraintConflict mergedConflict2 - , versionConflict = - mergeVersionConflicts (versionConflict mergedConflict1) - (versionConflict mergedConflict2) - } - where - mergeVersionConflicts (Just vr1) (Just vr2) = Just (vr1 .||. vr2) - mergeVersionConflicts (Just vr1) Nothing = Just vr1 - mergeVersionConflicts Nothing (Just vr2) = Just vr2 - mergeVersionConflicts Nothing Nothing = Nothing - - toMergedConflict :: CS.Conflict -> Maybe (QPN, MergedPackageConflict) - toMergedConflict (CS.GoalConflict qpn) = - Just (qpn, MergedPackageConflict True [] Nothing) - toMergedConflict (CS.VersionConstraintConflict qpn v) = - Just (qpn, MergedPackageConflict False [v] Nothing) - toMergedConflict (CS.VersionConflict qpn (CS.OrderedVersionRange vr)) = - Just (qpn, MergedPackageConflict False [] (Just vr)) - toMergedConflict CS.OtherConflict = Nothing - - showConflict :: QPN -> MergedPackageConflict -> String - showConflict qpn mergedConflict = L.intercalate "; " conflictStrings - where - conflictStrings = catMaybes [ - case () of - () | isGoalConflict mergedConflict -> Just $ - "depends on '" ++ showQPN qpn ++ "'" ++ - (if null (versionConstraintConflict mergedConflict) - then "" - else " but excludes " - ++ showVersions (versionConstraintConflict mergedConflict)) - | not $ L.null (versionConstraintConflict mergedConflict) -> Just $ - "excludes '" ++ showQPN qpn - ++ "' " ++ showVersions (versionConstraintConflict mergedConflict) - | otherwise -> Nothing - , (\vr -> "excluded by constraint '" ++ showVR vr ++ "' from '" ++ showQPN qpn ++ "'") - <$> versionConflict mergedConflict - ] - - showVersions [] = "no versions" - showVersions [v] = "version " ++ showVer v - showVersions vs = "versions " ++ L.intercalate ", " (map showVer vs) - --- | All conflicts related to one package, used for simplifying the display of --- a 'Set CS.Conflict'. -data MergedPackageConflict = MergedPackageConflict { - isGoalConflict :: Bool - , versionConstraintConflict :: [Ver] - , versionConflict :: Maybe VR - } - -showQPNPOpt :: QPN -> POption -> String -showQPNPOpt 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) - -showGR :: QGoalReason -> String -showGR UserGoal = " (user goal)" -showGR (DependencyGoal dr) = " (dependency of " ++ showDependencyReason dr ++ ")" - -showFR :: ConflictSet -> FailReason -> String -showFR _ (UnsupportedExtension ext) = " (conflict: requires " ++ prettyShow ext ++ ")" -showFR _ (UnsupportedLanguage lang) = " (conflict: requires " ++ prettyShow lang ++ ")" -showFR _ (MissingPkgconfigPackage pn vr) = " (conflict: pkg-config package " ++ prettyShow pn ++ prettyShow vr ++ ", not found in the pkg-config database)" -showFR _ (NewPackageDoesNotMatchExistingConstraint d) = " (conflict: " ++ showConflictingDep d ++ ")" -showFR _ (ConflictingConstraints d1 d2) = " (conflict: " ++ L.intercalate ", " (L.map showConflictingDep [d1, d2]) ++ ")" -showFR _ (NewPackageIsMissingRequiredComponent comp dr) = " (does not contain " ++ showExposedComponent comp ++ ", which is required by " ++ showDependencyReason dr ++ ")" -showFR _ (NewPackageHasPrivateRequiredComponent comp dr) = " (" ++ showExposedComponent comp ++ " is private, but it is required by " ++ showDependencyReason dr ++ ")" -showFR _ (NewPackageHasUnbuildableRequiredComponent comp dr) = " (" ++ showExposedComponent comp ++ " is not buildable in the current environment, but it is required by " ++ showDependencyReason dr ++ ")" -showFR _ (PackageRequiresMissingComponent qpn comp) = " (requires " ++ showExposedComponent comp ++ " from " ++ showQPN qpn ++ ", but the component does not exist)" -showFR _ (PackageRequiresPrivateComponent qpn comp) = " (requires " ++ showExposedComponent comp ++ " from " ++ showQPN qpn ++ ", but the component is private)" -showFR _ (PackageRequiresUnbuildableComponent qpn comp) = " (requires " ++ showExposedComponent comp ++ " from " ++ showQPN qpn ++ ", but the component is not buildable in the current environment)" -showFR _ CannotInstall = " (only already installed instances can be used)" -showFR _ CannotReinstall = " (avoiding to reinstall a package with same version but new dependencies)" -showFR _ NotExplicit = " (not a user-provided goal nor mentioned as a constraint, but reject-unconstrained-dependencies was set)" -showFR _ Shadowed = " (shadowed by another installed package with same version)" -showFR _ Broken = " (package is broken)" -showFR _ UnknownPackage = " (unknown package)" -showFR _ (GlobalConstraintVersion vr src) = " (" ++ constraintSource src ++ " requires " ++ prettyShow vr ++ ")" -showFR _ (GlobalConstraintInstalled src) = " (" ++ constraintSource src ++ " requires installed instance)" -showFR _ (GlobalConstraintSource src) = " (" ++ constraintSource src ++ " requires source instance)" -showFR _ (GlobalConstraintFlag src) = " (" ++ constraintSource src ++ " requires opposite flag selection)" -showFR _ ManualFlag = " (manual flag can only be changed explicitly)" -showFR c Backjump = " (backjumping, conflict set: " ++ showConflictSet c ++ ")" -showFR _ MultipleInstances = " (multiple instances)" -showFR c (DependenciesNotLinked msg) = " (dependencies not linked: " ++ msg ++ "; conflict set: " ++ showConflictSet c ++ ")" -showFR c CyclicDependencies = " (cyclic dependencies; conflict set: " ++ showConflictSet c ++ ")" -showFR _ (UnsupportedSpecVer ver) = " (unsupported spec-version " ++ prettyShow ver ++ ")" --- The following are internal failures. They should not occur. In the --- interest of not crashing unnecessarily, we still just print an error --- message though. -showFR _ (MalformedFlagChoice qfn) = " (INTERNAL ERROR: MALFORMED FLAG CHOICE: " ++ showQFN qfn ++ ")" -showFR _ (MalformedStanzaChoice qsn) = " (INTERNAL ERROR: MALFORMED STANZA CHOICE: " ++ showQSN qsn ++ ")" -showFR _ EmptyGoalChoice = " (INTERNAL ERROR: EMPTY GOAL CHOICE)" - -showExposedComponent :: ExposedComponent -> String -showExposedComponent (ExposedLib LMainLibName) = "library" -showExposedComponent (ExposedLib (LSubLibName name)) = "library '" ++ unUnqualComponentName name ++ "'" -showExposedComponent (ExposedExe name) = "executable '" ++ unUnqualComponentName name ++ "'" - -constraintSource :: ConstraintSource -> String -constraintSource src = "constraint from " ++ showConstraintSource src - -showConflictingDep :: ConflictingDep -> String -showConflictingDep (ConflictingDep dr (PkgComponent qpn comp) ci) = - let DependencyReason qpn' _ _ = dr - componentStr = case comp of - ExposedExe exe -> " (exe " ++ unUnqualComponentName exe ++ ")" - ExposedLib LMainLibName -> "" - ExposedLib (LSubLibName lib) -> " (lib " ++ unUnqualComponentName lib ++ ")" - in case ci of - Fixed i -> (if qpn /= qpn' then showDependencyReason dr ++ " => " else "") ++ - showQPN qpn ++ componentStr ++ "==" ++ showI i - Constrained vr -> showDependencyReason dr ++ " => " ++ showQPN qpn ++ - componentStr ++ showVR vr diff --git a/cabal/cabal-install/Distribution/Solver/Modular/PSQ.hs b/cabal/cabal-install/Distribution/Solver/Modular/PSQ.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Solver/Modular/PSQ.hs +++ /dev/null @@ -1,149 +0,0 @@ -{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} -module Distribution.Solver.Modular.PSQ - ( PSQ(..) -- Unit test needs constructor access - , casePSQ - , cons - , length - , lookup - , filter - , filterIfAny - , filterIfAnyByKeys - , filterKeys - , firstOnly - , fromList - , isZeroOrOne - , keys - , map - , mapKeys - , mapWithKey - , maximumBy - , minimumBy - , null - , prefer - , preferByKeys - , snoc - , sortBy - , sortByKeys - , toList - , union - ) where - --- Priority search queues. --- --- I am not yet sure what exactly is needed. But we need a data structure with --- key-based lookup that can be sorted. We're using a sequence right now with --- (inefficiently implemented) lookup, because I think that queue-based --- operations and sorting turn out to be more efficiency-critical in practice. - -import Control.Arrow (first, second) - -import qualified Data.Foldable as F -import Data.Function -import qualified Data.List as S -import Data.Ord (comparing) -import Data.Traversable -import Prelude hiding (foldr, length, lookup, filter, null, map) - -newtype PSQ k v = PSQ [(k, v)] - deriving (Eq, Show, Functor, F.Foldable, Traversable) -- Qualified Foldable to avoid issues with FTP - -keys :: PSQ k v -> [k] -keys (PSQ xs) = fmap fst xs - -lookup :: Eq k => k -> PSQ k v -> Maybe v -lookup k (PSQ xs) = S.lookup k xs - -map :: (v1 -> v2) -> PSQ k v1 -> PSQ k v2 -map f (PSQ xs) = PSQ (fmap (second f) xs) - -mapKeys :: (k1 -> k2) -> PSQ k1 v -> PSQ k2 v -mapKeys f (PSQ xs) = PSQ (fmap (first f) xs) - -mapWithKey :: (k -> a -> b) -> PSQ k a -> PSQ k b -mapWithKey f (PSQ xs) = PSQ (fmap (\ (k, v) -> (k, f k v)) xs) - -fromList :: [(k, a)] -> PSQ k a -fromList = PSQ - -cons :: k -> a -> PSQ k a -> PSQ k a -cons k x (PSQ xs) = PSQ ((k, x) : xs) - -snoc :: PSQ k a -> k -> a -> PSQ k a -snoc (PSQ xs) k x = PSQ (xs ++ [(k, x)]) - -casePSQ :: PSQ k a -> r -> (k -> a -> PSQ k a -> r) -> r -casePSQ (PSQ xs) n c = - case xs of - [] -> n - (k, v) : ys -> c k v (PSQ ys) - -sortBy :: (a -> a -> Ordering) -> PSQ k a -> PSQ k a -sortBy cmp (PSQ xs) = PSQ (S.sortBy (cmp `on` snd) xs) - -sortByKeys :: (k -> k -> Ordering) -> PSQ k a -> PSQ k a -sortByKeys cmp (PSQ xs) = PSQ (S.sortBy (cmp `on` fst) xs) - -maximumBy :: (k -> Int) -> PSQ k a -> (k, a) -maximumBy sel (PSQ xs) = - S.minimumBy (flip (comparing (sel . fst))) xs - -minimumBy :: (a -> Int) -> PSQ k a -> PSQ k a -minimumBy sel (PSQ xs) = - PSQ [snd (S.minimumBy (comparing fst) (S.map (\ x -> (sel (snd x), x)) xs))] - --- | Sort the list so that values satisfying the predicate are first. -prefer :: (a -> Bool) -> PSQ k a -> PSQ k a -prefer p = sortBy $ flip (comparing p) - --- | Sort the list so that keys satisfying the predicate are first. -preferByKeys :: (k -> Bool) -> PSQ k a -> PSQ k a -preferByKeys p = sortByKeys $ flip (comparing p) - --- | Will partition the list according to the predicate. If --- there is any element that satisfies the precidate, then only --- the elements satisfying the predicate are returned. --- Otherwise, the rest is returned. --- -filterIfAny :: (a -> Bool) -> PSQ k a -> PSQ k a -filterIfAny p (PSQ xs) = - let - (pro, con) = S.partition (p . snd) xs - in - if S.null pro then PSQ con else PSQ pro - --- | Variant of 'filterIfAny' that takes a predicate on the keys --- rather than on the values. --- -filterIfAnyByKeys :: (k -> Bool) -> PSQ k a -> PSQ k a -filterIfAnyByKeys p (PSQ xs) = - let - (pro, con) = S.partition (p . fst) xs - in - if S.null pro then PSQ con else PSQ pro - -filterKeys :: (k -> Bool) -> PSQ k a -> PSQ k a -filterKeys p (PSQ xs) = PSQ (S.filter (p . fst) xs) - -filter :: (a -> Bool) -> PSQ k a -> PSQ k a -filter p (PSQ xs) = PSQ (S.filter (p . snd) xs) - -length :: PSQ k a -> Int -length (PSQ xs) = S.length xs - -null :: PSQ k a -> Bool -null (PSQ xs) = S.null xs - -isZeroOrOne :: PSQ k a -> Bool -isZeroOrOne (PSQ []) = True -isZeroOrOne (PSQ [_]) = True -isZeroOrOne _ = False - -firstOnly :: PSQ k a -> PSQ k a -firstOnly (PSQ []) = PSQ [] -firstOnly (PSQ (x : _)) = PSQ [x] - -toList :: PSQ k a -> [(k, a)] -toList (PSQ xs) = xs - -union :: PSQ k a -> PSQ k a -> PSQ k a -union (PSQ xs) (PSQ ys) = PSQ (xs ++ ys) diff --git a/cabal/cabal-install/Distribution/Solver/Modular/Package.hs b/cabal/cabal-install/Distribution/Solver/Modular/Package.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Solver/Modular/Package.hs +++ /dev/null @@ -1,106 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -module Distribution.Solver.Modular.Package - ( I(..) - , Loc(..) - , PackageId - , PackageIdentifier(..) - , PackageName, mkPackageName, unPackageName - , PkgconfigName, mkPkgconfigName, unPkgconfigName - , PI(..) - , PN - , QPV - , instI - , makeIndependent - , primaryPP - , setupPP - , showI - , showPI - , unPN - ) where - -import Prelude () -import Distribution.Solver.Compat.Prelude - -import Distribution.Package -- from Cabal -import Distribution.Pretty (prettyShow) - -import Distribution.Solver.Modular.Version -import Distribution.Solver.Types.PackagePath - --- | A package name. -type PN = PackageName - --- | Unpacking a package name. -unPN :: PN -> String -unPN = unPackageName - --- | Package version. A package name plus a version number. -type PV = PackageId - --- | Qualified package version. -type QPV = Qualified PV - --- | Package id. Currently just a black-box string. -type PId = UnitId - --- | Location. Info about whether a package is installed or not, and where --- exactly it is located. For installed packages, uniquely identifies the --- package instance via its 'PId'. --- --- TODO: More information is needed about the repo. -data Loc = Inst PId | InRepo - deriving (Eq, Ord, Show) - --- | Instance. A version number and a location. -data I = I 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 - --- | Package instance. A package name and an instance. -data PI qpn = PI qpn I - deriving (Eq, Ord, Show, Functor) - --- | String representation of a package instance. -showPI :: PI QPN -> String -showPI (PI qpn i) = showQPN qpn ++ "-" ++ showI i - -instI :: I -> Bool -instI (I _ (Inst _)) = True -instI _ = False - --- | Is the package in the primary group of packages. This is used to --- determine (1) if we should try to establish stanza preferences --- for this goal, and (2) whether or not a user specified @--constraint@ --- should apply to this dependency (grep 'primaryPP' to see the --- use sites). In particular this does not include packages pulled in --- as setup deps. --- -primaryPP :: PackagePath -> Bool -primaryPP (PackagePath _ns q) = go q - where - go QualToplevel = True - go (QualBase _) = True - go (QualSetup _) = False - go (QualExe _ _) = False - --- | Is the package a dependency of a setup script. This is used to --- establish whether or not certain constraints should apply to this --- dependency (grep 'setupPP' to see the use sites). --- -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/cabal-install/Distribution/Solver/Modular/Preference.hs b/cabal/cabal-install/Distribution/Solver/Modular/Preference.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Solver/Modular/Preference.hs +++ /dev/null @@ -1,481 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} --- | Reordering or pruning the tree in order to prefer or make certain choices. -module Distribution.Solver.Modular.Preference - ( avoidReinstalls - , deferSetupChoices - , deferWeakFlagChoices - , enforceManualFlags - , enforcePackageConstraints - , enforceSingleInstanceRestriction - , firstGoal - , preferBaseGoalChoice - , preferLinked - , preferPackagePreferences - , preferReallyEasyGoalChoices - , requireInstalled - , onlyConstrained - , sortGoals - , pruneAfterFirstSuccess - ) where - -import Prelude () -import Distribution.Solver.Compat.Prelude - -import qualified Data.List as L -import qualified Data.Map as M -import Control.Monad.Trans.Reader (Reader, runReader, ask, local) - -import Distribution.PackageDescription (lookupFlagAssignment, unFlagAssignment) -- from Cabal - -import Distribution.Solver.Types.Flag -import Distribution.Solver.Types.InstalledPreference -import Distribution.Solver.Types.LabeledPackageConstraint -import Distribution.Solver.Types.OptionalStanza -import Distribution.Solver.Types.PackageConstraint -import Distribution.Solver.Types.PackagePath -import Distribution.Solver.Types.PackagePreferences -import Distribution.Solver.Types.Variable - -import Distribution.Solver.Modular.Dependency -import Distribution.Solver.Modular.Flag -import Distribution.Solver.Modular.Package -import qualified Distribution.Solver.Modular.PSQ as P -import Distribution.Solver.Modular.Tree -import Distribution.Solver.Modular.Version -import qualified Distribution.Solver.Modular.ConflictSet as CS -import qualified Distribution.Solver.Modular.WeightedPSQ as W - --- | Update the weights of children under 'PChoice' nodes. 'addWeights' takes a --- list of weight-calculating functions in order to avoid sorting the package --- choices multiple times. Each function takes the package name, sorted list of --- children's versions, and package option. 'addWeights' prepends the new --- weights to the existing weights, which gives precedence to preferences that --- are applied later. -addWeights :: [PN -> [Ver] -> POption -> Weight] -> Tree d c -> Tree d c -addWeights fs = trav go - where - go :: TreeF d c (Tree d c) -> TreeF d c (Tree d c) - go (PChoiceF qpn@(Q _ pn) rdm x cs) = - let sortedVersions = L.sortBy (flip compare) $ L.map version (W.keys cs) - weights k = [f pn sortedVersions k | f <- fs] - - elemsToWhnf :: [a] -> () - elemsToWhnf = foldr seq () - in PChoiceF qpn rdm x - -- Evaluate the children's versions before evaluating any of the - -- subtrees, so that 'sortedVersions' doesn't hold onto all of the - -- subtrees (referenced by cs) and cause a space leak. - (elemsToWhnf sortedVersions `seq` - W.mapWeightsWithKey (\k w -> weights k ++ w) cs) - go x = x - -addWeight :: (PN -> [Ver] -> POption -> Weight) -> Tree d c -> Tree d c -addWeight f = addWeights [f] - -version :: POption -> Ver -version (POption (I v _) _) = v - --- | Prefer to link packages whenever possible. -preferLinked :: Tree d c -> Tree d c -preferLinked = addWeight (const (const linked)) - where - linked (POption _ Nothing) = 1 - linked (POption _ (Just _)) = 0 - --- Works by setting weights on choice nodes. Also applies stanza preferences. -preferPackagePreferences :: (PN -> PackagePreferences) -> Tree d c -> Tree d c -preferPackagePreferences pcs = - preferPackageStanzaPreferences pcs . - addWeights [ - \pn _ opt -> preferred pn opt - - -- Note that we always rank installed before uninstalled, and later - -- versions before earlier, but we can change the priority of the - -- two orderings. - , \pn vs opt -> case preference pn of - PreferInstalled -> installed opt - PreferLatest -> latest vs opt - , \pn vs opt -> case preference pn of - PreferInstalled -> latest vs opt - PreferLatest -> installed opt - ] - where - -- Prefer packages with higher version numbers over packages with - -- lower version numbers. - latest :: [Ver] -> POption -> Weight - latest sortedVersions opt = - let l = length sortedVersions - index = fromMaybe l $ L.findIndex (<= version opt) sortedVersions - in fromIntegral index / fromIntegral l - - preference :: PN -> InstalledPreference - preference pn = - let PackagePreferences _ ipref _ = pcs pn - in ipref - - -- | Prefer versions satisfying more preferred version ranges. - preferred :: PN -> POption -> Weight - preferred pn opt = - let PackagePreferences vrs _ _ = pcs pn - in fromIntegral . negate . L.length $ - L.filter (flip checkVR (version opt)) vrs - - -- Prefer installed packages over non-installed packages. - installed :: POption -> Weight - installed (POption (I _ (Inst _)) _) = 0 - installed _ = 1 - --- | Traversal that tries to establish package stanza enable\/disable --- preferences. Works by reordering the branches of stanza choices. -preferPackageStanzaPreferences :: (PN -> PackagePreferences) -> Tree d c -> Tree d c -preferPackageStanzaPreferences pcs = trav go - where - go (SChoiceF qsn@(SN (Q pp pn) s) rdm gr _tr ts) - | primaryPP pp && enableStanzaPref pn s = - -- move True case first to try enabling the stanza - let ts' = W.mapWeightsWithKey (\k w -> weight k : w) ts - weight k = if k then 0 else 1 - -- defer the choice by setting it to weak - in SChoiceF qsn rdm gr (WeakOrTrivial True) ts' - go x = x - - enableStanzaPref :: PN -> OptionalStanza -> Bool - enableStanzaPref pn s = - let PackagePreferences _ _ spref = pcs pn - in s `elem` spref - --- | Helper function that tries to enforce a single package constraint on a --- given instance for a P-node. Translates the constraint into a --- tree-transformer that either leaves the subtree untouched, or replaces it --- with an appropriate failure node. -processPackageConstraintP :: forall d c. QPN - -> ConflictSet - -> I - -> LabeledPackageConstraint - -> Tree d c - -> Tree d c -processPackageConstraintP qpn c i (LabeledPackageConstraint (PackageConstraint scope prop) src) r = - if constraintScopeMatches scope qpn - then go i prop - else r - where - go :: I -> PackageProperty -> Tree d c - go (I v _) (PackagePropertyVersion vr) - | checkVR vr v = r - | otherwise = Fail c (GlobalConstraintVersion vr src) - go _ PackagePropertyInstalled - | instI i = r - | otherwise = Fail c (GlobalConstraintInstalled src) - go _ PackagePropertySource - | not (instI i) = r - | otherwise = Fail c (GlobalConstraintSource src) - go _ _ = r - --- | Helper function that tries to enforce a single package constraint on a --- given flag setting for an F-node. Translates the constraint into a --- tree-transformer that either leaves the subtree untouched, or replaces it --- with an appropriate failure node. -processPackageConstraintF :: forall d c. QPN - -> Flag - -> ConflictSet - -> Bool - -> LabeledPackageConstraint - -> Tree d c - -> Tree d c -processPackageConstraintF qpn f c b' (LabeledPackageConstraint (PackageConstraint scope prop) src) r = - if constraintScopeMatches scope qpn - then go prop - else r - where - go :: PackageProperty -> Tree d c - go (PackagePropertyFlags fa) = - case lookupFlagAssignment f fa of - Nothing -> r - Just b | b == b' -> r - | otherwise -> Fail c (GlobalConstraintFlag src) - go _ = r - --- | Helper function that tries to enforce a single package constraint on a --- given flag setting for an F-node. Translates the constraint into a --- tree-transformer that either leaves the subtree untouched, or replaces it --- with an appropriate failure node. -processPackageConstraintS :: forall d c. QPN - -> OptionalStanza - -> ConflictSet - -> Bool - -> LabeledPackageConstraint - -> Tree d c - -> Tree d c -processPackageConstraintS qpn s c b' (LabeledPackageConstraint (PackageConstraint scope prop) src) r = - if constraintScopeMatches scope qpn - then go prop - else r - where - go :: PackageProperty -> Tree d c - go (PackagePropertyStanzas ss) = - if not b' && s `elem` ss then Fail c (GlobalConstraintFlag src) - else r - go _ = r - --- | Traversal that tries to establish various kinds of user constraints. Works --- by selectively disabling choices that have been ruled out by global user --- constraints. -enforcePackageConstraints :: M.Map PN [LabeledPackageConstraint] - -> Tree d c - -> Tree d c -enforcePackageConstraints pcs = trav go - where - go (PChoiceF qpn@(Q _ pn) rdm gr ts) = - let c = varToConflictSet (P qpn) - -- compose the transformation functions for each of the relevant constraint - g = \ (POption i _) -> foldl (\ h pc -> h . processPackageConstraintP qpn c i pc) - id - (M.findWithDefault [] pn pcs) - in PChoiceF qpn rdm gr (W.mapWithKey g ts) - go (FChoiceF qfn@(FN qpn@(Q _ pn) f) rdm gr tr m d ts) = - let c = varToConflictSet (F qfn) - -- compose the transformation functions for each of the relevant constraint - g = \ b -> foldl (\ h pc -> h . processPackageConstraintF qpn f c b pc) - id - (M.findWithDefault [] pn pcs) - in FChoiceF qfn rdm gr tr m d (W.mapWithKey g ts) - go (SChoiceF qsn@(SN qpn@(Q _ pn) f) rdm gr tr ts) = - let c = varToConflictSet (S qsn) - -- compose the transformation functions for each of the relevant constraint - g = \ b -> foldl (\ h pc -> h . processPackageConstraintS qpn f c b pc) - id - (M.findWithDefault [] pn pcs) - in SChoiceF qsn rdm gr tr (W.mapWithKey g ts) - go x = x - --- | Transformation that tries to enforce the rule that manual flags can only be --- set by the user. --- --- If there are no constraints on a manual flag, this function prunes all but --- the default value. If there are constraints, then the flag is allowed to have --- the values specified by the constraints. Note that the type used for flag --- values doesn't need to be Bool. --- --- This function makes an exception for the case where there are multiple goals --- for a single package (with different qualifiers), and flag constraints for --- manual flag x only apply to some of those goals. In that case, we allow the --- unconstrained goals to use the default value for x OR any of the values in --- the constraints on x (even though the constraints don't apply), in order to --- allow the unconstrained goals to be linked to the constrained goals. See --- https://github.com/haskell/cabal/issues/4299. Removing the single instance --- restriction (SIR) would also fix #4299, so we may want to remove this --- exception and only let the user toggle manual flags if we remove the SIR. --- --- This function does not enforce any of the constraints, since that is done by --- 'enforcePackageConstraints'. -enforceManualFlags :: M.Map PN [LabeledPackageConstraint] -> Tree d c -> Tree d c -enforceManualFlags pcs = trav go - where - go (FChoiceF qfn@(FN (Q _ pn) fn) rdm gr tr Manual d ts) = - FChoiceF qfn rdm gr tr Manual d $ - let -- A list of all values specified by constraints on 'fn'. - -- We ignore the constraint scope in order to handle issue #4299. - flagConstraintValues :: [Bool] - flagConstraintValues = - [ flagVal - | let lpcs = M.findWithDefault [] pn pcs - , (LabeledPackageConstraint (PackageConstraint _ (PackagePropertyFlags fa)) _) <- lpcs - , (fn', flagVal) <- unFlagAssignment fa - , fn' == fn ] - - -- Prune flag values that are not the default and do not match any - -- of the constraints. - restrictToggling :: Eq a => a -> [a] -> a -> Tree d c -> Tree d c - restrictToggling flagDefault constraintVals flagVal r = - if flagVal `elem` constraintVals || flagVal == flagDefault - then r - else Fail (varToConflictSet (F qfn)) ManualFlag - - in W.mapWithKey (restrictToggling d flagConstraintValues) ts - go x = x - --- | Require installed packages. -requireInstalled :: (PN -> Bool) -> Tree d c -> Tree d c -requireInstalled p = trav go - where - go (PChoiceF v@(Q _ pn) rdm gr cs) - | p pn = PChoiceF v rdm gr (W.mapWithKey installed cs) - | otherwise = PChoiceF v rdm gr cs - where - installed (POption (I _ (Inst _)) _) x = x - installed _ _ = Fail (varToConflictSet (P v)) CannotInstall - go x = x - --- | Avoid reinstalls. --- --- This is a tricky strategy. If a package version is installed already and the --- same version is available from a repo, the repo version will never be chosen. --- This would result in a reinstall (either destructively, or potentially, --- shadowing). The old instance won't be visible or even present anymore, but --- other packages might have depended on it. --- --- TODO: It would be better to actually check the reverse dependencies of installed --- packages. If they're not depended on, then reinstalling should be fine. Even if --- they are, perhaps this should just result in trying to reinstall those other --- packages as well. However, doing this all neatly in one pass would require to --- change the builder, or at least to change the goal set after building. -avoidReinstalls :: (PN -> Bool) -> Tree d c -> Tree d c -avoidReinstalls p = trav go - where - go (PChoiceF qpn@(Q _ pn) rdm gr cs) - | p pn = PChoiceF qpn rdm gr disableReinstalls - | otherwise = PChoiceF qpn rdm gr cs - where - disableReinstalls = - 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 = - Fail (varToConflictSet (P qpn)) CannotReinstall - notReinstall _ _ x = - x - go x = x - --- | Require all packages to be mentioned in a constraint or as a goal. -onlyConstrained :: (PN -> Bool) -> Tree d QGoalReason -> Tree d QGoalReason -onlyConstrained p = trav go - where - go (PChoiceF v@(Q _ pn) _ gr _) | not (p pn) - = FailF - (varToConflictSet (P v) `CS.union` goalReasonToConflictSetWithConflict v gr) - NotExplicit - go x - = x - --- | Sort all goals using the provided function. -sortGoals :: (Variable QPN -> Variable QPN -> Ordering) -> Tree d c -> Tree d c -sortGoals variableOrder = trav go - where - go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.sortByKeys goalOrder xs) - go x = x - - goalOrder :: Goal QPN -> Goal QPN -> Ordering - goalOrder = variableOrder `on` (varToVariable . goalToVar) - - varToVariable :: Var QPN -> Variable QPN - varToVariable (P qpn) = PackageVar qpn - varToVariable (F (FN qpn fn)) = FlagVar qpn fn - varToVariable (S (SN qpn stanza)) = StanzaVar qpn stanza - --- | Reduce the branching degree of the search tree by removing all choices --- after the first successful choice at each level. The returned tree is the --- minimal subtree containing the path to the first backjump. -pruneAfterFirstSuccess :: Tree d c -> Tree d c -pruneAfterFirstSuccess = trav go - where - go (PChoiceF qpn rdm gr ts) = PChoiceF qpn rdm gr (W.takeUntil active ts) - go (FChoiceF qfn rdm gr w m d ts) = FChoiceF qfn rdm gr w m d (W.takeUntil active ts) - go (SChoiceF qsn rdm gr w ts) = SChoiceF qsn rdm gr w (W.takeUntil active ts) - go x = x - --- | Always choose the first goal in the list next, abandoning all --- other choices. --- --- This is unnecessary for the default search strategy, because --- it descends only into the first goal choice anyway, --- but may still make sense to just reduce the tree size a bit. -firstGoal :: Tree d c -> Tree d c -firstGoal = trav go - where - go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.firstOnly xs) - go x = x - -- Note that we keep empty choice nodes, because they mean success. - --- | Transformation that tries to make a decision on base as early as --- possible by pruning all other goals when base is available. In nearly --- all cases, there's a single choice for the base package. Also, fixing --- base early should lead to better error messages. -preferBaseGoalChoice :: Tree d c -> Tree d c -preferBaseGoalChoice = trav go - where - go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.filterIfAnyByKeys isBase xs) - go x = x - - isBase :: Goal QPN -> Bool - isBase (Goal (P (Q _pp pn)) _) = unPN pn == "base" - isBase _ = False - --- | Deal with setup dependencies after regular dependencies, so that we can --- will link setup dependencies against package dependencies when possible -deferSetupChoices :: Tree d c -> Tree d c -deferSetupChoices = trav go - where - go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.preferByKeys noSetup xs) - go x = x - - noSetup :: Goal QPN -> Bool - noSetup (Goal (P (Q (PackagePath _ns (QualSetup _)) _)) _) = False - noSetup _ = True - --- | Transformation that tries to avoid making weak flag choices early. --- Weak flags are trivial flags (not influencing dependencies) or such --- flags that are explicitly declared to be weak in the index. -deferWeakFlagChoices :: Tree d c -> Tree d c -deferWeakFlagChoices = trav go - where - go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.prefer noWeakFlag (P.prefer noWeakStanza xs)) - go x = x - - noWeakStanza :: Tree d c -> Bool - noWeakStanza (SChoice _ _ _ (WeakOrTrivial True) _) = False - noWeakStanza _ = True - - noWeakFlag :: Tree d c -> Bool - noWeakFlag (FChoice _ _ _ (WeakOrTrivial True) _ _ _) = False - noWeakFlag _ = True - --- | Transformation that prefers goals with lower branching degrees. --- --- When a goal choice node has at least one goal with zero or one children, this --- function prunes all other goals. This transformation can help the solver find --- a solution in fewer steps by allowing it to backtrack sooner when it is --- exploring a subtree with no solutions. However, each step is more expensive. -preferReallyEasyGoalChoices :: Tree d c -> Tree d c -preferReallyEasyGoalChoices = trav go - where - go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.filterIfAny zeroOrOneChoices xs) - go x = x - --- | Monad used internally in enforceSingleInstanceRestriction --- --- For each package instance we record the goal for which we picked a concrete --- instance. The SIR means that for any package instance there can only be one. -type EnforceSIR = Reader (Map (PI PN) QPN) - --- | Enforce ghc's single instance restriction --- --- From the solver's perspective, this means that for any package instance --- (that is, package name + package version) there can be at most one qualified --- goal resolving to that instance (there may be other goals _linking_ to that --- instance however). -enforceSingleInstanceRestriction :: Tree d c -> Tree d c -enforceSingleInstanceRestriction = (`runReader` M.empty) . cata go - where - go :: TreeF d c (EnforceSIR (Tree d c)) -> EnforceSIR (Tree d c) - - -- We just verify package choices. - go (PChoiceF qpn rdm gr cs) = - PChoice qpn rdm gr <$> sequenceA (W.mapWithKey (goP qpn) cs) - go _otherwise = - innM _otherwise - - -- The check proper - goP :: QPN -> POption -> EnforceSIR (Tree d c) -> EnforceSIR (Tree d c) - goP qpn@(Q _ pn) (POption i linkedTo) r = do - let inst = PI pn i - env <- ask - case (linkedTo, M.lookup inst env) of - (Just _, _) -> - -- For linked nodes we don't check anything - r - (Nothing, Nothing) -> - -- Not linked, not already used - local (M.insert inst qpn) r - (Nothing, Just qpn') -> do - -- Not linked, already used. This is an error - return $ Fail (CS.union (varToConflictSet (P qpn)) (varToConflictSet (P qpn'))) MultipleInstances diff --git a/cabal/cabal-install/Distribution/Solver/Modular/RetryLog.hs b/cabal/cabal-install/Distribution/Solver/Modular/RetryLog.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Solver/Modular/RetryLog.hs +++ /dev/null @@ -1,72 +0,0 @@ -{-# LANGUAGE Rank2Types #-} -module Distribution.Solver.Modular.RetryLog - ( RetryLog - , toProgress - , fromProgress - , mapFailure - , retry - , failWith - , succeedWith - , continueWith - , tryWith - ) where - -import Distribution.Solver.Compat.Prelude -import Prelude () - -import Distribution.Solver.Modular.Message -import Distribution.Solver.Types.Progress - --- | 'Progress' as a difference list that allows efficient appends at failures. -newtype RetryLog step fail done = RetryLog { - unRetryLog :: forall fail2 . (fail -> Progress step fail2 done) - -> Progress step fail2 done - } - --- | /O(1)/. Convert a 'RetryLog' to a 'Progress'. -toProgress :: RetryLog step fail done -> Progress step fail done -toProgress (RetryLog f) = f Fail - --- | /O(N)/. Convert a 'Progress' to a 'RetryLog'. -fromProgress :: Progress step fail done -> RetryLog step fail done -fromProgress l = RetryLog $ \f -> go f l - where - go :: (fail1 -> Progress step fail2 done) - -> Progress step fail1 done - -> Progress step fail2 done - go _ (Done d) = Done d - go f (Fail failure) = f failure - go f (Step m ms) = Step m (go f ms) - --- | /O(1)/. Apply a function to the failure value in a log. -mapFailure :: (fail1 -> fail2) - -> RetryLog step fail1 done - -> RetryLog step fail2 done -mapFailure f l = retry l $ \failure -> RetryLog $ \g -> g (f failure) - --- | /O(1)/. If the first log leads to failure, continue with the second. -retry :: RetryLog step fail1 done - -> (fail1 -> RetryLog step fail2 done) - -> RetryLog step fail2 done -retry (RetryLog f) g = - RetryLog $ \extendLog -> f $ \failure -> unRetryLog (g failure) extendLog - --- | /O(1)/. Create a log with one message before a failure. -failWith :: step -> fail -> RetryLog step fail done -failWith m failure = RetryLog $ \f -> Step m (f failure) - --- | /O(1)/. Create a log with one message before a success. -succeedWith :: step -> done -> RetryLog step fail done -succeedWith m d = RetryLog $ const $ Step m (Done d) - --- | /O(1)/. Prepend a message to a log. -continueWith :: step - -> RetryLog step fail done - -> RetryLog step fail done -continueWith m (RetryLog f) = RetryLog $ Step m . f - --- | /O(1)/. Prepend the given message and 'Enter' to the log, and insert --- 'Leave' before the failure if the log fails. -tryWith :: Message -> RetryLog Message fail done -> RetryLog Message fail done -tryWith m f = - RetryLog $ Step m . Step Enter . unRetryLog (retry f (failWith Leave)) diff --git a/cabal/cabal-install/Distribution/Solver/Modular/Solver.hs b/cabal/cabal-install/Distribution/Solver/Modular/Solver.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Solver/Modular/Solver.hs +++ /dev/null @@ -1,265 +0,0 @@ -{-# LANGUAGE CPP #-} -#ifdef DEBUG_TRACETREE -{-# LANGUAGE FlexibleInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -#endif -module Distribution.Solver.Modular.Solver - ( SolverConfig(..) - , solve - , PruneAfterFirstSuccess(..) - ) where - -import Distribution.Solver.Compat.Prelude -import Prelude () - -import qualified Data.Map as M -import qualified Data.List as L -import qualified Data.Set as S -import Distribution.Verbosity - -import Distribution.Compiler (CompilerInfo) - -import Distribution.Solver.Types.PackagePath -import Distribution.Solver.Types.PackagePreferences -import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb) -import Distribution.Solver.Types.LabeledPackageConstraint -import Distribution.Solver.Types.Settings -import Distribution.Solver.Types.Variable - -import Distribution.Solver.Modular.Assignment -import Distribution.Solver.Modular.Builder -import Distribution.Solver.Modular.Cycles -import Distribution.Solver.Modular.Dependency -import Distribution.Solver.Modular.Explore -import Distribution.Solver.Modular.Index -import Distribution.Solver.Modular.Log -import Distribution.Solver.Modular.Message -import Distribution.Solver.Modular.Package -import qualified Distribution.Solver.Modular.Preference as P -import Distribution.Solver.Modular.Validate -import Distribution.Solver.Modular.Linking -import Distribution.Solver.Modular.PSQ (PSQ) -import Distribution.Solver.Modular.RetryLog -import Distribution.Solver.Modular.Tree -import qualified Distribution.Solver.Modular.PSQ as PSQ - -import Distribution.Simple.Setup (BooleanFlag(..)) - -#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 Debug.Trace.Tree (gtraceJson) -import Debug.Trace.Tree.Simple -import Debug.Trace.Tree.Generic -import Debug.Trace.Tree.Assoc (Assoc(..)) -#endif - --- | Various options for the modular solver. -data SolverConfig = SolverConfig { - reorderGoals :: ReorderGoals, - countConflicts :: CountConflicts, - fineGrainedConflicts :: FineGrainedConflicts, - minimizeConflictSet :: MinimizeConflictSet, - independentGoals :: IndependentGoals, - avoidReinstalls :: AvoidReinstalls, - shadowPkgs :: ShadowPkgs, - strongFlags :: StrongFlags, - allowBootLibInstalls :: AllowBootLibInstalls, - onlyConstrained :: OnlyConstrained, - maxBackjumps :: Maybe Int, - enableBackjumping :: EnableBackjumping, - solveExecutables :: SolveExecutables, - goalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering), - solverVerbosity :: Verbosity, - pruneAfterFirstSuccess :: PruneAfterFirstSuccess -} - --- | Whether to remove all choices after the first successful choice at each --- level in the search tree. -newtype PruneAfterFirstSuccess = PruneAfterFirstSuccess Bool - --- | Run all solver phases. --- --- In principle, we have a valid tree after 'validationPhase', which --- means that every 'Done' node should correspond to valid solution. --- --- There is one exception, though, and that is cycle detection, which --- has been added relatively recently. Cycles are only removed directly --- before exploration. --- -solve :: SolverConfig -- ^ solver parameters - -> CompilerInfo - -> Index -- ^ all available packages as an index - -> 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 = - explorePhase $ - detectCycles $ - heuristicsPhase $ - preferencesPhase $ - validationPhase $ - prunePhase $ - buildPhase - where - explorePhase = backjumpAndExplore (maxBackjumps sc) - (enableBackjumping sc) - (fineGrainedConflicts sc) - (countConflicts sc) - idx - detectCycles = traceTree "cycles.json" id . detectCyclesPhase - heuristicsPhase = - let heuristicsTree = traceTree "heuristics.json" id - sortGoals = case goalOrder sc of - Nothing -> goalChoiceHeuristics . - heuristicsTree . - P.deferSetupChoices . - P.deferWeakFlagChoices . - P.preferBaseGoalChoice - Just order -> P.firstGoal . - heuristicsTree . - P.sortGoals order - PruneAfterFirstSuccess prune = pruneAfterFirstSuccess sc - in sortGoals . - (if prune then P.pruneAfterFirstSuccess else id) - preferencesPhase = P.preferLinked . - P.preferPackagePreferences userPrefs - validationPhase = traceTree "validated.json" id . - P.enforcePackageConstraints userConstraints . - P.enforceManualFlags userConstraints . - P.enforceSingleInstanceRestriction . - validateLinking idx . - validateTree cinfo idx pkgConfigDB - prunePhase = (if asBool (avoidReinstalls sc) then P.avoidReinstalls (const True) else id) . - (if asBool (allowBootLibInstalls sc) - then id - else P.requireInstalled (`elem` nonInstallable)) . - (case onlyConstrained sc of - OnlyConstrainedAll -> - P.onlyConstrained pkgIsExplicit - OnlyConstrainedNone -> - id) - buildPhase = traceTree "build.json" id - $ buildTree idx (independentGoals sc) (S.toList userGoals) - - allExplicit = M.keysSet userConstraints `S.union` userGoals - - pkgIsExplicit :: PN -> Bool - pkgIsExplicit pn = S.member pn allExplicit - - -- packages that can never be installed or upgraded - -- If you change this enumeration, make sure to update the list in - -- "Distribution.Client.Dependency" as well - nonInstallable :: [PackageName] - nonInstallable = - L.map mkPackageName - [ "base" - , "ghc-prim" - , "integer-gmp" - , "integer-simple" - , "template-haskell" - ] - - -- When --reorder-goals is set, we use preferReallyEasyGoalChoices, which - -- prefers (keeps) goals only if the have 0 or 1 enabled choice. - -- - -- In the past, we furthermore used P.firstGoal to trim down the goal choice nodes - -- to just a single option. This was a way to work around a space leak that was - -- unnecessary and is now fixed, so we no longer do it. - -- - -- If --count-conflicts is active, it will then choose among the remaining goals - -- the one that has been responsible for the most conflicts so far. - -- - -- Otherwise, we simply choose the first remaining goal. - -- - goalChoiceHeuristics - | asBool (reorderGoals sc) = P.preferReallyEasyGoalChoices - | otherwise = id {- P.firstGoal -} - --- | Dump solver tree to a file (in debugging mode) --- --- This only does something if the @debug-tracetree@ configure argument was --- given; otherwise this is just the identity function. -traceTree :: -#ifdef DEBUG_TRACETREE - GSimpleTree a => -#endif - FilePath -- ^ Output file - -> (a -> a) -- ^ Function to summarize the tree before dumping - -> a -> a -#ifdef DEBUG_TRACETREE -traceTree = gtraceJson -#else -traceTree _ _ = id -#endif - -#ifdef DEBUG_TRACETREE -instance GSimpleTree (Tree d c) where - fromGeneric = go - where - go :: Tree d c -> SimpleTree - go (PChoice qpn _ _ psq) = Node "P" $ Assoc $ L.map (uncurry (goP qpn)) $ psqToList psq - go (FChoice _ _ _ _ _ _ psq) = Node "F" $ Assoc $ L.map (uncurry goFS) $ psqToList psq - go (SChoice _ _ _ _ psq) = Node "S" $ Assoc $ L.map (uncurry goFS) $ psqToList psq - go (GoalChoice _ psq) = Node "G" $ Assoc $ L.map (uncurry goG) $ PSQ.toList psq - go (Done _rdm _s) = Node "D" $ Assoc [] - go (Fail cs _reason) = Node "X" $ Assoc [("CS", Leaf $ goCS cs)] - - psqToList :: W.WeightedPSQ w k v -> [(k, v)] - psqToList = L.map (\(_, k, v) -> (k, v)) . W.toList - - -- Show package choice - goP :: QPN -> POption -> Tree d c -> (String, SimpleTree) - goP _ (POption (I ver _loc) Nothing) subtree = (T.display ver, go subtree) - goP (Q _ pn) (POption _ (Just pp)) subtree = (showQPN (Q pp pn), go subtree) - - -- Show flag or stanza choice - goFS :: Bool -> Tree d c -> (String, SimpleTree) - goFS val subtree = (show val, go subtree) - - -- Show goal choice - goG :: Goal QPN -> Tree d c -> (String, SimpleTree) - goG (Goal var gr) subtree = (showVar var ++ " (" ++ shortGR gr ++ ")", go subtree) - - -- Variation on 'showGR' that produces shorter strings - -- (Actually, QGoalReason records more info than necessary: we only need - -- to know the variable that introduced the goal, not the value assigned - -- to that variable) - shortGR :: QGoalReason -> String - shortGR UserGoal = "user" - shortGR (DependencyGoal dr) = showDependencyReason dr - - -- Show conflict set - goCS :: ConflictSet -> String - goCS cs = "{" ++ (intercalate "," . L.map showVar . CS.toList $ cs) ++ "}" -#endif - --- | Replace all goal reasons with a dummy goal reason in the tree --- --- This is useful for debugging (when experimenting with the impact of GRs) -_removeGR :: Tree d c -> Tree d QGoalReason -_removeGR = trav go - where - go :: TreeF d c (Tree d QGoalReason) -> TreeF d QGoalReason (Tree d QGoalReason) - go (PChoiceF qpn rdm _ psq) = PChoiceF qpn rdm dummy psq - go (FChoiceF qfn rdm _ a b d psq) = FChoiceF qfn rdm dummy a b d psq - go (SChoiceF qsn rdm _ a psq) = SChoiceF qsn rdm dummy a psq - go (GoalChoiceF rdm psq) = GoalChoiceF rdm (goG psq) - go (DoneF rdm s) = DoneF rdm s - go (FailF cs reason) = FailF cs reason - - goG :: PSQ (Goal QPN) (Tree d QGoalReason) -> PSQ (Goal QPN) (Tree d QGoalReason) - goG = PSQ.fromList - . L.map (\(Goal var _, subtree) -> (Goal var dummy, subtree)) - . PSQ.toList - - dummy :: QGoalReason - dummy = - DependencyGoal $ - DependencyReason - (Q (PackagePath DefaultNamespace QualToplevel) (mkPackageName "$")) - M.empty S.empty diff --git a/cabal/cabal-install/Distribution/Solver/Modular/Tree.hs b/cabal/cabal-install/Distribution/Solver/Modular/Tree.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Solver/Modular/Tree.hs +++ /dev/null @@ -1,198 +0,0 @@ -{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} -module Distribution.Solver.Modular.Tree - ( POption(..) - , Tree(..) - , TreeF(..) - , Weight - , FailReason(..) - , ConflictingDep(..) - , ana - , cata - , inn - , innM - , para - , trav - , zeroOrOneChoices - , active - ) where - -import Control.Monad hiding (mapM, sequence) -import Data.Foldable -import Data.Traversable -import Prelude hiding (foldr, mapM, sequence) - -import Distribution.Solver.Modular.Dependency -import Distribution.Solver.Modular.Flag -import Distribution.Solver.Modular.Package -import Distribution.Solver.Modular.PSQ (PSQ) -import Distribution.Solver.Modular.Version -import Distribution.Solver.Modular.WeightedPSQ (WeightedPSQ) -import qualified Distribution.Solver.Modular.WeightedPSQ as W -import Distribution.Solver.Types.ConstraintSource -import Distribution.Solver.Types.Flag -import Distribution.Solver.Types.PackagePath -import Distribution.Types.PkgconfigVersionRange -import Language.Haskell.Extension (Extension, Language) - -type Weight = Double - --- | Type of the search tree. Inlining the choice nodes for now. Weights on --- package, flag, and stanza choices control the traversal order. --- --- The tree can hold additional data on 'Done' nodes (type 'd') and choice nodes --- (type 'c'). For example, during the final traversal, choice nodes contain the --- variables that introduced the choices, and 'Done' nodes contain the --- assignments for all variables. --- --- 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)) - - -- | 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 whether or not to enable a stanza - | SChoice QSN RevDepMap c WeakOrTrivial (WeightedPSQ [Weight] Bool (Tree d c)) - - -- | Choose which choice to make next - -- - -- Invariants: - -- - -- * PSQ should never be empty - -- * For each choice we additionally record the 'QGoalReason' why we are - -- introducing that goal into tree. Note that most of the time we are - -- working with @Tree QGoalReason@; in that case, we must have the - -- 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)) - - -- | We're done -- we found a solution! - | Done RevDepMap d - - -- | We failed to find a solution in this path through the tree - | Fail ConflictSet FailReason - --- | A package option is a package instance with an optional linking annotation --- --- The modular solver has a number of package goals to solve for, and can only --- pick a single package version for a single goal. In order to allow to --- install multiple versions of the same package as part of a single solution --- the solver uses qualified goals. For example, @0.P@ and @1.P@ might both --- be qualified goals for @P@, allowing to pick a difference version of package --- @P@ for @0.P@ and @1.P@. --- --- Linking is an essential part of this story. In addition to picking a specific --- version for @1.P@, the solver can also decide to link @1.P@ to @0.P@ (or --- vice versa). It means that @1.P@ and @0.P@ really must be the very same package --- (and hence must have the same build time configuration, and their --- dependencies must also be the exact same). --- --- See for details. -data POption = POption I (Maybe PackagePath) - deriving (Eq, Show) - -data FailReason = UnsupportedExtension Extension - | UnsupportedLanguage Language - | MissingPkgconfigPackage PkgconfigName PkgconfigVersionRange - | NewPackageDoesNotMatchExistingConstraint ConflictingDep - | ConflictingConstraints ConflictingDep ConflictingDep - | NewPackageIsMissingRequiredComponent ExposedComponent (DependencyReason QPN) - | NewPackageHasPrivateRequiredComponent ExposedComponent (DependencyReason QPN) - | NewPackageHasUnbuildableRequiredComponent ExposedComponent (DependencyReason QPN) - | PackageRequiresMissingComponent QPN ExposedComponent - | PackageRequiresPrivateComponent QPN ExposedComponent - | PackageRequiresUnbuildableComponent QPN ExposedComponent - | CannotInstall - | CannotReinstall - | NotExplicit - | Shadowed - | Broken - | UnknownPackage - | GlobalConstraintVersion VR ConstraintSource - | GlobalConstraintInstalled ConstraintSource - | GlobalConstraintSource ConstraintSource - | GlobalConstraintFlag ConstraintSource - | ManualFlag - | MalformedFlagChoice QFN - | MalformedStanzaChoice QSN - | EmptyGoalChoice - | Backjump - | MultipleInstances - | DependenciesNotLinked String - | CyclicDependencies - | UnsupportedSpecVer Ver - deriving (Eq, Show) - --- | Information about a dependency involved in a conflict, for error messages. -data ConflictingDep = ConflictingDep (DependencyReason QPN) (PkgComponent QPN) CI - deriving (Eq, Show) - --- | Functor for the tree type. 'a' is the type of nodes' children. 'd' and 'c' --- have the same meaning as in 'Tree'. -data TreeF d c a = - PChoiceF QPN RevDepMap c (WeightedPSQ [Weight] POption a) - | FChoiceF QFN RevDepMap c WeakOrTrivial FlagType Bool (WeightedPSQ [Weight] Bool a) - | SChoiceF QSN RevDepMap c WeakOrTrivial (WeightedPSQ [Weight] Bool a) - | GoalChoiceF RevDepMap (PSQ (Goal QPN) a) - | DoneF RevDepMap d - | FailF ConflictSet FailReason - deriving (Functor, Foldable, Traversable) - -out :: Tree d c -> TreeF d c (Tree d c) -out (PChoice p s i ts) = PChoiceF p s i ts -out (FChoice p s i b m d ts) = FChoiceF p s i b m d ts -out (SChoice p s i b ts) = SChoiceF p s i b ts -out (GoalChoice s ts) = GoalChoiceF s ts -out (Done x s ) = DoneF x s -out (Fail c x ) = FailF c x - -inn :: TreeF d c (Tree d c) -> Tree d c -inn (PChoiceF p s i ts) = PChoice p s i ts -inn (FChoiceF p s i b m d ts) = FChoice p s i b m d ts -inn (SChoiceF p s i b ts) = SChoice p s i b ts -inn (GoalChoiceF s ts) = GoalChoice s ts -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 (DoneF x s ) = return $ Done x s -innM (FailF c x ) = return $ Fail c x - --- | Determines whether a tree is active, i.e., isn't a failure node. -active :: Tree d c -> Bool -active (Fail _ _) = False -active _ = True - --- | Approximates the number of active choices that are available in a node. --- Note that we count goal choices as having one choice, always. -zeroOrOneChoices :: Tree d c -> Bool -zeroOrOneChoices (PChoice _ _ _ ts) = W.isZeroOrOne (W.filter active ts) -zeroOrOneChoices (FChoice _ _ _ _ _ _ ts) = W.isZeroOrOne (W.filter active ts) -zeroOrOneChoices (SChoice _ _ _ _ ts) = W.isZeroOrOne (W.filter active ts) -zeroOrOneChoices (GoalChoice _ _ ) = True -zeroOrOneChoices (Done _ _ ) = True -zeroOrOneChoices (Fail _ _ ) = True - --- | Catamorphism on trees. -cata :: (TreeF d c a -> a) -> Tree d c -> a -cata phi x = (phi . fmap (cata phi) . out) x - -trav :: (TreeF d c (Tree d a) -> TreeF d a (Tree d a)) -> Tree d c -> Tree d a -trav psi x = cata (inn . psi) x - --- | Paramorphism on trees. -para :: (TreeF d c (a, Tree d c) -> a) -> Tree d c -> a -para phi = phi . fmap (\ x -> (para phi x, x)) . out - --- | Anamorphism on trees. -ana :: (a -> TreeF d c a) -> a -> Tree d c -ana psi = inn . fmap (ana psi) . psi diff --git a/cabal/cabal-install/Distribution/Solver/Modular/Validate.hs b/cabal/cabal-install/Distribution/Solver/Modular/Validate.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Solver/Modular/Validate.hs +++ /dev/null @@ -1,590 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE CPP #-} -#ifdef DEBUG_CONFLICT_SETS -{-# LANGUAGE ImplicitParams #-} -#endif -module Distribution.Solver.Modular.Validate (validateTree) where - --- Validation of the tree. --- --- The task here is to make sure all constraints hold. After validation, any --- assignment returned by exploration of the tree should be a complete valid --- assignment, i.e., actually constitute a solution. - -import Control.Applicative -import Control.Monad.Reader hiding (sequence) -import Data.Either (lefts) -import Data.Function (on) -import Data.Traversable -import Prelude hiding (sequence) - -import qualified Data.List as L -import qualified Data.Set as S - -import Language.Haskell.Extension (Extension, Language) - -import Data.Map.Strict as M -import Distribution.Compiler (CompilerInfo(..)) - -import Distribution.Solver.Modular.Assignment -import qualified Distribution.Solver.Modular.ConflictSet as CS -import Distribution.Solver.Modular.Dependency -import Distribution.Solver.Modular.Flag -import Distribution.Solver.Modular.Index -import Distribution.Solver.Modular.Package -import Distribution.Solver.Modular.Tree -import Distribution.Solver.Modular.Version -import qualified Distribution.Solver.Modular.WeightedPSQ as W - -import Distribution.Solver.Types.PackagePath -import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb, pkgConfigPkgIsPresent) -import Distribution.Types.LibraryName -import Distribution.Types.PkgconfigVersionRange - -#ifdef DEBUG_CONFLICT_SETS -import GHC.Stack (CallStack) -#endif - --- 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 --- that for which the preconditions are fulfilled ACTIVE. We maintain a set --- of currently active constraints that we pass down the node. --- --- We aim at detecting inconsistent states as early as possible. --- --- Whenever we make a choice, there are two things that need to happen: --- --- (1) We must check that the choice is consistent with the currently --- active constraints. --- --- (2) The choice increases the set of active constraints. For the new --- active constraints, we must check that they are consistent with --- the current state. --- --- We can actually merge (1) and (2) by saying the current choice is --- a new active constraint, fixing the choice. --- --- If a test fails, we have detected an inconsistent state. We can --- disable the current subtree and do not have to traverse it any further. --- --- We need a good way to represent the current state, i.e., the current --- set of active constraints. Since the main situation where we have to --- search in it is (1), it seems best to store the state by package: for --- every package, we store which versions are still allowed. If for any --- package, we have inconsistent active constraints, we can also stop. --- This is a particular way to read task (2): --- --- (2, weak) We only check if the new constraints are consistent with --- the choices we've already made, and add them to the active set. --- --- (2, strong) We check if the new constraints are consistent with the --- choices we've already made, and the constraints we already have. --- --- It currently seems as if we're implementing the weak variant. However, --- when used together with 'preferEasyGoalChoices', we will find an --- inconsistent state in the very next step. --- --- What do we do about flags? --- --- Like for packages, we store the flag choices we have already made. --- Now, regarding (1), we only have to test whether we've decided the --- current flag before. Regarding (2), the interesting bit is in discovering --- the new active constraints. To this end, we look up the constraints for --- the package the flag belongs to, and traverse its flagged dependencies. --- Wherever we find the flag in question, we start recording dependencies --- underneath as new active dependencies. If we encounter other flags, we --- check if we've chosen them already and either proceed or stop. - --- | The state needed during validation. -data ValidateState = VS { - supportedExt :: Extension -> Bool, - supportedLang :: Language -> Bool, - presentPkgs :: PkgconfigName -> PkgconfigVersionRange -> Bool, - index :: Index, - - -- Saved, scoped, dependencies. Every time 'validate' makes a package choice, - -- it qualifies the package's dependencies and saves them in this map. Then - -- the qualified dependencies are available for subsequent flag and stanza - -- choices for the same package. - saved :: Map QPN (FlaggedDeps QPN), - - pa :: PreAssignment, - - -- Map from package name to the components that are provided by the chosen - -- instance of that package, and whether those components are visible and - -- buildable. - availableComponents :: Map QPN (Map ExposedComponent ComponentInfo), - - -- Map from package name to the components that are required from that - -- package. - requiredComponents :: Map QPN ComponentDependencyReasons, - - qualifyOptions :: QualifyOptions -} - -newtype Validate a = Validate (Reader ValidateState a) - deriving (Functor, Applicative, Monad, MonadReader ValidateState) - -runValidate :: Validate a -> ValidateState -> a -runValidate (Validate r) = runReader r - --- | A preassignment comprises knowledge about variables, but not --- necessarily fixed values. -data PreAssignment = PA PPreAssignment FAssignment SAssignment - --- | A (partial) package preassignment. Qualified package names --- are associated with MergedPkgDeps. -type PPreAssignment = Map QPN MergedPkgDep - --- | A dependency on a component, including its DependencyReason. -data PkgDep = PkgDep (DependencyReason QPN) (PkgComponent QPN) CI - --- | Map from component name to one of the reasons that the component is --- required. -type ComponentDependencyReasons = Map ExposedComponent (DependencyReason QPN) - --- | MergedPkgDep records constraints about the instances that can still be --- chosen, and in the extreme case fixes a concrete instance. Otherwise, it is a --- list of version ranges paired with the goals / variables that introduced --- them. It also records whether a package is a build-tool dependency, for each --- reason that it was introduced. --- --- It is important to store the component name with the version constraint, for --- error messages, because whether something is a build-tool dependency affects --- its qualifier, which affects which constraint is applied. -data MergedPkgDep = - MergedDepFixed ExposedComponent (DependencyReason QPN) I - | MergedDepConstrained [VROrigin] - --- | Version ranges paired with origins. -type VROrigin = (VR, ExposedComponent, DependencyReason QPN) - --- | The information needed to create a 'Fail' node. -type Conflict = (ConflictSet, FailReason) - -validate :: Tree d c -> Validate (Tree d c) -validate = cata go - where - go :: TreeF d c (Validate (Tree d c)) -> Validate (Tree d c) - - go (PChoiceF qpn rdm gr ts) = PChoice qpn rdm gr <$> sequence (W.mapWithKey (goP qpn) ts) - go (FChoiceF qfn rdm gr b m d ts) = - do - -- Flag choices may occur repeatedly (because they can introduce new constraints - -- in various places). However, subsequent choices must be consistent. We thereby - -- collapse repeated flag choice nodes. - PA _ pfa _ <- asks pa -- obtain current flag-preassignment - case M.lookup qfn pfa of - Just rb -> -- flag has already been assigned; collapse choice to the correct branch - case W.lookup rb ts of - Just t -> goF qfn rb t - Nothing -> return $ Fail (varToConflictSet (F qfn)) (MalformedFlagChoice qfn) - Nothing -> -- flag choice is new, follow both branches - FChoice qfn rdm gr b m d <$> sequence (W.mapWithKey (goF qfn) ts) - go (SChoiceF qsn rdm gr b ts) = - do - -- Optional stanza choices are very similar to flag choices. - PA _ _ psa <- asks pa -- obtain current stanza-preassignment - case M.lookup qsn psa of - Just rb -> -- stanza choice has already been made; collapse choice to the correct branch - case W.lookup rb ts of - Just t -> goS qsn rb t - Nothing -> return $ Fail (varToConflictSet (S qsn)) (MalformedStanzaChoice qsn) - Nothing -> -- stanza choice is new, follow both branches - SChoice qsn rdm gr b <$> sequence (W.mapWithKey (goS qsn) ts) - - -- We don't need to do anything for goal choices or failure nodes. - go (GoalChoiceF rdm ts) = GoalChoice rdm <$> sequence ts - go (DoneF rdm s ) = pure (Done rdm s) - go (FailF c fr ) = pure (Fail c fr) - - -- 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 - PA ppa pfa psa <- asks pa -- obtain current preassignment - extSupported <- asks supportedExt -- obtain the supported extensions - langSupported <- asks supportedLang -- obtain the supported languages - pkgPresent <- asks presentPkgs -- obtain the present pkg-config pkgs - idx <- asks index -- obtain the index - svd <- asks saved -- obtain saved dependencies - aComps <- asks availableComponents - rComps <- asks requiredComponents - qo <- asks qualifyOptions - -- obtain dependencies and index-dictated exclusions introduced by the choice - let (PInfo deps comps _ mfr) = idx ! pn ! i - -- qualify the deps in the current scope - let qdeps = qualifyDeps qo 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 - -- In case we continue, we save the scoped dependencies - let nsvd = M.insert qpn qdeps svd - case mfr of - Just fr -> -- The index marks this as an invalid choice. We can stop. - return (Fail (varToConflictSet (P qpn)) fr) - Nothing -> - let newDeps :: Either Conflict (PPreAssignment, Map QPN ComponentDependencyReasons) - newDeps = do - nppa <- mnppa - rComps' <- extendRequiredComponents aComps rComps newactives - checkComponentsInNewPackage (M.findWithDefault M.empty qpn rComps) qpn comps - return (nppa, rComps') - in case newDeps of - Left (c, fr) -> -- We have an inconsistency. We can stop. - return (Fail c fr) - Right (nppa, rComps') -> -- We have an updated partial assignment for the recursive validation. - local (\ s -> s { pa = PA nppa pfa psa - , saved = nsvd - , availableComponents = M.insert qpn comps aComps - , requiredComponents = rComps' - }) r - - -- 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 - PA ppa pfa psa <- asks pa -- obtain current preassignment - extSupported <- asks supportedExt -- obtain the supported extensions - langSupported <- asks supportedLang -- obtain the supported languages - pkgPresent <- asks presentPkgs -- obtain the present pkg-config pkgs - svd <- asks saved -- obtain saved dependencies - aComps <- asks availableComponents - rComps <- asks requiredComponents - -- Note that there should be saved dependencies for the package in question, - -- because while building, we do not choose flags before we see the packages - -- that define them. - let qdeps = svd ! qpn - -- We take the *saved* dependencies, because these have been qualified in the - -- correct scope. - -- - -- Extend the flag assignment - let npfa = M.insert qfn b pfa - -- We now try to get the new active dependencies we might learn about because - -- we have chosen a new flag. - let newactives = extractNewDeps (F qfn) b npfa psa qdeps - mNewRequiredComps = extendRequiredComponents aComps rComps newactives - -- As in the package case, we try to extend the partial assignment. - let mnppa = extend extSupported langSupported pkgPresent newactives ppa - case liftM2 (,) mnppa mNewRequiredComps of - Left (c, fr) -> return (Fail c fr) -- inconsistency found - Right (nppa, rComps') -> - local (\ s -> s { pa = PA nppa npfa psa, requiredComponents = rComps' }) r - - -- 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 - PA ppa pfa psa <- asks pa -- obtain current preassignment - extSupported <- asks supportedExt -- obtain the supported extensions - langSupported <- asks supportedLang -- obtain the supported languages - pkgPresent <- asks presentPkgs -- obtain the present pkg-config pkgs - svd <- asks saved -- obtain saved dependencies - aComps <- asks availableComponents - rComps <- asks requiredComponents - -- Note that there should be saved dependencies for the package in question, - -- because while building, we do not choose flags before we see the packages - -- that define them. - let qdeps = svd ! qpn - -- We take the *saved* dependencies, because these have been qualified in the - -- correct scope. - -- - -- Extend the flag assignment - let npsa = M.insert qsn b psa - -- We now try to get the new active dependencies we might learn about because - -- we have chosen a new flag. - let newactives = extractNewDeps (S qsn) b pfa npsa qdeps - mNewRequiredComps = extendRequiredComponents aComps rComps newactives - -- As in the package case, we try to extend the partial assignment. - let mnppa = extend extSupported langSupported pkgPresent newactives ppa - case liftM2 (,) mnppa mNewRequiredComps of - Left (c, fr) -> return (Fail c fr) -- inconsistency found - Right (nppa, rComps') -> - local (\ s -> s { pa = PA nppa pfa npsa, requiredComponents = rComps' }) r - --- | Check that a newly chosen package instance contains all components that --- are required from that package so far. The components must also be visible --- and buildable. -checkComponentsInNewPackage :: ComponentDependencyReasons - -> QPN - -> Map ExposedComponent ComponentInfo - -> Either Conflict () -checkComponentsInNewPackage required qpn providedComps = - case M.toList $ deleteKeys (M.keys providedComps) required of - (missingComp, dr) : _ -> - Left $ mkConflict missingComp dr NewPackageIsMissingRequiredComponent - [] -> - let failures = lefts - [ case () of - _ | compIsVisible compInfo == IsVisible False -> - Left $ mkConflict comp dr NewPackageHasPrivateRequiredComponent - | compIsBuildable compInfo == IsBuildable False -> - Left $ mkConflict comp dr NewPackageHasUnbuildableRequiredComponent - | otherwise -> Right () - | let merged = M.intersectionWith (,) required providedComps - , (comp, (dr, compInfo)) <- M.toList merged ] - in case failures of - failure : _ -> Left failure - [] -> Right () - where - mkConflict :: ExposedComponent - -> DependencyReason QPN - -> (ExposedComponent -> DependencyReason QPN -> FailReason) - -> Conflict - mkConflict comp dr mkFailure = - (CS.insert (P qpn) (dependencyReasonToConflictSet dr), mkFailure comp dr) - - deleteKeys :: Ord k => [k] -> Map k v -> Map k v - deleteKeys ks m = L.foldr M.delete m ks - --- | 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 fa sa deps = do - d <- deps - case d of - Simple sd _ -> return sd - Flagged qfn _ td fd -> case M.lookup qfn fa of - Nothing -> mzero - Just True -> extractAllDeps fa sa td - Just False -> extractAllDeps fa sa fd - Stanza qsn td -> case M.lookup qsn sa of - Nothing -> mzero - Just True -> extractAllDeps fa sa td - Just False -> [] - --- | 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 v b fa sa = go - where - go :: FlaggedDeps QPN -> [LDep QPN] - go deps = do - d <- deps - case d of - Simple _ _ -> mzero - Flagged qfn' _ td fd - | v == F qfn' -> if b then extractAllDeps fa sa td else extractAllDeps fa sa fd - | otherwise -> case M.lookup qfn' fa of - Nothing -> mzero - Just True -> go td - Just False -> go fd - Stanza qsn' td - | v == S qsn' -> if b then extractAllDeps fa sa td else [] - | otherwise -> case M.lookup qsn' sa of - Nothing -> mzero - Just True -> go td - Just False -> [] - --- | Extend a package preassignment. --- --- Takes the variable that causes the new constraints, a current preassignment --- and a set of new dependency constraints. --- --- We're trying to extend the preassignment with each dependency one by one. --- Each dependency is for a particular variable. We check if we already have --- constraints for that variable in the current preassignment. If so, we're --- trying to merge the constraints. --- --- Either returns a witness of the conflict that would arise during the merge, --- or the successfully extended assignment. -extend :: (Extension -> Bool) -- ^ is a given extension supported - -> (Language -> Bool) -- ^ is a given language supported - -> (PkgconfigName -> PkgconfigVersionRange -> Bool) -- ^ is a given pkg-config requirement satisfiable - -> [LDep QPN] - -> PPreAssignment - -> Either Conflict PPreAssignment -extend extSupported langSupported pkgPresent newactives ppa = foldM extendSingle ppa newactives - where - - extendSingle :: PPreAssignment -> LDep QPN -> Either Conflict PPreAssignment - extendSingle a (LDep dr (Ext ext )) = - if extSupported ext then Right a - else Left (dependencyReasonToConflictSet dr, UnsupportedExtension ext) - extendSingle a (LDep dr (Lang lang)) = - if langSupported lang then Right a - else Left (dependencyReasonToConflictSet dr, UnsupportedLanguage lang) - extendSingle a (LDep dr (Pkg pn vr)) = - if pkgPresent pn vr then Right a - else Left (dependencyReasonToConflictSet dr, MissingPkgconfigPackage pn vr) - extendSingle a (LDep dr (Dep dep@(PkgComponent qpn _) ci)) = - let mergedDep = M.findWithDefault (MergedDepConstrained []) qpn a - in case (\ x -> M.insert qpn x a) <$> merge mergedDep (PkgDep dr dep ci) of - Left (c, (d, d')) -> Left (c, ConflictingConstraints d d') - Right x -> Right x - --- | Extend a package preassignment with a package choice. For example, when --- the solver chooses foo-2.0, it tries to add the constraint foo==2.0. --- --- TODO: The new constraint is implemented as a dependency from foo to foo's --- main library. That isn't correct, because foo might only be needed as a build --- tool dependency. The implemention may need to change when we support --- component-based dependency solving. -extendWithPackageChoice :: PI QPN -> PPreAssignment -> Either Conflict PPreAssignment -extendWithPackageChoice (PI qpn i) ppa = - let mergedDep = M.findWithDefault (MergedDepConstrained []) qpn ppa - newChoice = PkgDep (DependencyReason qpn M.empty S.empty) - (PkgComponent qpn (ExposedLib LMainLibName)) - (Fixed i) - in case (\ x -> M.insert qpn x ppa) <$> merge mergedDep newChoice of - Left (c, (d, _d')) -> -- Don't include the package choice in the - -- FailReason, because it is redundant. - Left (c, NewPackageDoesNotMatchExistingConstraint d) - Right x -> Right x - --- | Merge constrained instances. We currently adopt a lazy strategy for --- merging, i.e., we only perform actual checking if one of the two choices --- is fixed. If the merge fails, we return a conflict set indicating the --- variables responsible for the failure, as well as the two conflicting --- fragments. --- --- Note that while there may be more than one conflicting pair of version --- ranges, we only return the first we find. --- --- The ConflictingDeps are returned in order, i.e., the first describes the --- conflicting part of the MergedPkgDep, and the second describes the PkgDep. --- --- TODO: Different pairs might have different conflict sets. We're --- obviously interested to return a conflict that has a "better" conflict --- set in the sense the it contains variables that allow us to backjump --- further. We might apply some heuristics here, such as to change the --- order in which we check the constraints. -merge :: -#ifdef DEBUG_CONFLICT_SETS - (?loc :: CallStack) => -#endif - MergedPkgDep -> PkgDep -> Either (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep -merge (MergedDepFixed comp1 vs1 i1) (PkgDep vs2 (PkgComponent p comp2) ci@(Fixed i2)) - | i1 == i2 = Right $ MergedDepFixed comp1 vs1 i1 - | otherwise = - Left ( (CS.union `on` dependencyReasonToConflictSet) vs1 vs2 - , ( 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)) - | 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 _))) = - go vrOrigins -- I tried "reverse vrOrigins" here, but it seems to slow things down ... - where - go :: [VROrigin] -> Either (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep - go [] = Right (MergedDepFixed comp2 vs2 i) - go ((vr, comp1, vs1) : vros) - | checkVR vr v = go vros - | otherwise = - Left ( createConflictSetForVersionConflict p v vs2 vr vs1 - , ( ConflictingDep vs1 (PkgComponent p comp1) (Constrained vr) - , ConflictingDep vs2 (PkgComponent p comp2) ci ) ) - -merge (MergedDepConstrained vrOrigins) (PkgDep vs2 (PkgComponent _ comp2) (Constrained vr)) = - Right (MergedDepConstrained $ - - -- TODO: This line appends the new version range, to preserve the order used - -- before a refactoring. Consider prepending the version range, if there is - -- no negative performance impact. - vrOrigins ++ [(vr, comp2, vs2)]) - --- | Creates a conflict set representing a conflict between a version constraint --- and the fixed version chosen for a package. -createConflictSetForVersionConflict :: QPN - -> Ver - -> DependencyReason QPN - -> VR - -> DependencyReason QPN - -> ConflictSet -createConflictSetForVersionConflict pkg - conflictingVersion - versionDR@(DependencyReason p1 _ _) - conflictingVersionRange - versionRangeDR@(DependencyReason p2 _ _) = - let hasFlagsOrStanzas (DependencyReason _ fs ss) = not (M.null fs) || not (S.null ss) - in - -- The solver currently only optimizes the case where there is a conflict - -- between the version chosen for a package and a version constraint that - -- is not under any flags or stanzas. Here is how we check for this case: - -- - -- (1) Choosing a specific version for a package foo is implemented as - -- adding a dependency from foo to that version of foo (See - -- extendWithPackageChoice), so we check that the DependencyReason - -- contains the current package and no flag or stanza choices. - -- - -- (2) We check that the DependencyReason for the version constraint also - -- contains no flag or stanza choices. - -- - -- When these criteria are not met, we fall back to calling - -- dependencyReasonToConflictSet. - if p1 == pkg && not (hasFlagsOrStanzas versionDR) && not (hasFlagsOrStanzas versionRangeDR) - then let cs1 = dependencyReasonToConflictSetWithVersionConflict - p2 - (CS.OrderedVersionRange conflictingVersionRange) - versionDR - cs2 = dependencyReasonToConflictSetWithVersionConstraintConflict - pkg conflictingVersion versionRangeDR - in cs1 `CS.union` cs2 - else dependencyReasonToConflictSet versionRangeDR `CS.union` dependencyReasonToConflictSet versionDR - --- | Takes a list of new dependencies and uses it to try to update the map of --- known component dependencies. It returns a failure when a new dependency --- requires a component that is missing, private, or unbuildable in a previously --- chosen package. -extendRequiredComponents :: Map QPN (Map ExposedComponent ComponentInfo) - -> Map QPN ComponentDependencyReasons - -> [LDep QPN] - -> Either Conflict (Map QPN ComponentDependencyReasons) -extendRequiredComponents available = foldM extendSingle - where - extendSingle :: Map QPN ComponentDependencyReasons - -> LDep QPN - -> Either Conflict (Map QPN ComponentDependencyReasons) - extendSingle required (LDep dr (Dep (PkgComponent qpn comp) _)) = - let compDeps = M.findWithDefault M.empty qpn required - success = Right $ M.insertWith M.union qpn (M.insert comp dr compDeps) required - in -- Only check for the existence of the component if its package has - -- already been chosen. - case M.lookup qpn available of - Just comps -> - case M.lookup comp comps of - Nothing -> - Left $ mkConflict qpn comp dr PackageRequiresMissingComponent - Just compInfo - | compIsVisible compInfo == IsVisible False -> - Left $ mkConflict qpn comp dr PackageRequiresPrivateComponent - | compIsBuildable compInfo == IsBuildable False -> - Left $ mkConflict qpn comp dr PackageRequiresUnbuildableComponent - | otherwise -> success - Nothing -> success - extendSingle required _ = Right required - - mkConflict :: QPN - -> ExposedComponent - -> DependencyReason QPN - -> (QPN -> ExposedComponent -> FailReason) - -> Conflict - mkConflict qpn comp dr mkFailure = - (CS.insert (P qpn) (dependencyReasonToConflictSet dr), mkFailure qpn comp) - - --- | Interface. -validateTree :: CompilerInfo -> Index -> 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 - , index = idx - , saved = M.empty - , pa = PA M.empty M.empty M.empty - , availableComponents = M.empty - , requiredComponents = M.empty - , qualifyOptions = defaultQualifyOptions idx - } diff --git a/cabal/cabal-install/Distribution/Solver/Modular/Var.hs b/cabal/cabal-install/Distribution/Solver/Modular/Var.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Solver/Modular/Var.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -module Distribution.Solver.Modular.Var ( - Var(..) - , showVar - , varPN - ) where - -import Prelude hiding (pi) - -import Distribution.Solver.Modular.Flag -import Distribution.Solver.Types.PackagePath - -{------------------------------------------------------------------------------- - Variables --------------------------------------------------------------------------------} - --- | The type of variables that play a role in the solver. --- Note that the tree currently does not use this type directly, --- and rather has separate tree nodes for the different types of --- variables. This fits better with the fact that in most cases, --- these have to be treated differently. -data Var qpn = P qpn | F (FN qpn) | S (SN qpn) - deriving (Eq, Ord, Show, Functor) - -showVar :: Var QPN -> String -showVar (P qpn) = showQPN qpn -showVar (F qfn) = showQFN qfn -showVar (S qsn) = showQSN qsn - --- | Extract the package name from a Var -varPN :: Var qpn -> qpn -varPN (P qpn) = qpn -varPN (F (FN qpn _)) = qpn -varPN (S (SN qpn _)) = qpn diff --git a/cabal/cabal-install/Distribution/Solver/Modular/Version.hs b/cabal/cabal-install/Distribution/Solver/Modular/Version.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Solver/Modular/Version.hs +++ /dev/null @@ -1,56 +0,0 @@ -module Distribution.Solver.Modular.Version - ( Ver - , VR - , anyVR - , checkVR - , eqVR - , showVer - , showVR - , simplifyVR - , (.&&.) - , (.||.) - ) where - -import Distribution.Solver.Compat.Prelude -import Prelude () - -import qualified Distribution.Version as CV -- from Cabal -import Distribution.Pretty (prettyShow) - --- | Preliminary type for versions. -type Ver = CV.Version - --- | String representation of a version. -showVer :: Ver -> String -showVer = prettyShow - --- | Version range. Consists of a lower and upper bound. -type VR = CV.VersionRange - --- | String representation of a version range. -showVR :: VR -> String -showVR = prettyShow - --- | Unconstrained version range. -anyVR :: VR -anyVR = CV.anyVersion - --- | Version range fixing a single version. -eqVR :: Ver -> VR -eqVR = CV.thisVersion - --- | Intersect two version ranges. -(.&&.) :: VR -> VR -> VR -v1 .&&. v2 = simplifyVR $ CV.intersectVersionRanges v1 v2 - --- | Union of two version ranges. -(.||.) :: VR -> VR -> VR -v1 .||. v2 = simplifyVR $ CV.unionVersionRanges v1 v2 - --- | Simplify a version range. -simplifyVR :: VR -> VR -simplifyVR = CV.simplifyVersionRange - --- | Checking a version against a version range. -checkVR :: VR -> Ver -> Bool -checkVR = flip CV.withinRange diff --git a/cabal/cabal-install/Distribution/Solver/Modular/WeightedPSQ.hs b/cabal/cabal-install/Distribution/Solver/Modular/WeightedPSQ.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Solver/Modular/WeightedPSQ.hs +++ /dev/null @@ -1,97 +0,0 @@ -{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Distribution.Solver.Modular.WeightedPSQ ( - WeightedPSQ - , fromList - , toList - , keys - , weights - , isZeroOrOne - , filter - , lookup - , mapWithKey - , mapWeightsWithKey - , union - , takeUntil - ) where - -import qualified Data.Foldable as F -import qualified Data.List as L -import Data.Ord (comparing) -import qualified Data.Traversable as T -import Prelude hiding (filter, lookup) - --- | An association list that is sorted by weight. --- --- Each element has a key ('k'), value ('v'), and weight ('w'). All operations --- that add elements or modify weights stably sort the elements by weight. -newtype WeightedPSQ w k v = WeightedPSQ [(w, k, v)] - deriving (Eq, Show, Functor, F.Foldable, T.Traversable) - --- | /O(N)/. -filter :: (v -> Bool) -> WeightedPSQ k w v -> WeightedPSQ k w v -filter p (WeightedPSQ xs) = WeightedPSQ (L.filter (p . triple_3) xs) - --- | /O(1)/. Return @True@ if the @WeightedPSQ@ contains zero or one elements. -isZeroOrOne :: WeightedPSQ w k v -> Bool -isZeroOrOne (WeightedPSQ []) = True -isZeroOrOne (WeightedPSQ [_]) = True -isZeroOrOne _ = False - --- | /O(1)/. Return the elements in order. -toList :: WeightedPSQ w k v -> [(w, k, v)] -toList (WeightedPSQ xs) = xs - --- | /O(N log N)/. -fromList :: Ord w => [(w, k, v)] -> WeightedPSQ w k v -fromList = WeightedPSQ . L.sortBy (comparing triple_1) - --- | /O(N)/. Return the weights in order. -weights :: WeightedPSQ w k v -> [w] -weights (WeightedPSQ xs) = L.map triple_1 xs - --- | /O(N)/. Return the keys in order. -keys :: WeightedPSQ w k v -> [k] -keys (WeightedPSQ xs) = L.map triple_2 xs - --- | /O(N)/. Return the value associated with the first occurrence of the give --- key, if it exists. -lookup :: Eq k => k -> WeightedPSQ w k v -> Maybe v -lookup k (WeightedPSQ xs) = triple_3 `fmap` L.find ((k ==) . triple_2) xs - --- | /O(N log N)/. Update the weights. -mapWeightsWithKey :: Ord w2 - => (k -> w1 -> w2) - -> WeightedPSQ w1 k v - -> WeightedPSQ w2 k v -mapWeightsWithKey f (WeightedPSQ xs) = fromList $ - L.map (\ (w, k, v) -> (f k w, k, v)) xs - --- | /O(N)/. Update the values. -mapWithKey :: (k -> v1 -> v2) -> WeightedPSQ w k v1 -> WeightedPSQ w k v2 -mapWithKey f (WeightedPSQ xs) = WeightedPSQ $ - L.map (\ (w, k, v) -> (w, k, f k v)) xs - --- | /O((N + M) log (N + M))/. Combine two @WeightedPSQ@s, preserving all --- elements. Elements from the first @WeightedPSQ@ come before elements in the --- second when they have the same weight. -union :: Ord w => WeightedPSQ w k v -> WeightedPSQ w k v -> WeightedPSQ w k v -union (WeightedPSQ xs) (WeightedPSQ ys) = fromList (xs ++ ys) - --- | /O(N)/. Return the prefix of values ending with the first element that --- satisfies p, or all elements if none satisfy p. -takeUntil :: forall w k v. (v -> Bool) -> WeightedPSQ w k v -> WeightedPSQ w k v -takeUntil p (WeightedPSQ xs) = WeightedPSQ (go xs) - where - go :: [(w, k, v)] -> [(w, k, v)] - go [] = [] - go (y : ys) = y : if p (triple_3 y) then [] else go ys - -triple_1 :: (x, y, z) -> x -triple_1 (x, _, _) = x - -triple_2 :: (x, y, z) -> y -triple_2 (_, y, _) = y - -triple_3 :: (x, y, z) -> z -triple_3 (_, _, z) = z diff --git a/cabal/cabal-install/Distribution/Solver/Types/ComponentDeps.hs b/cabal/cabal-install/Distribution/Solver/Types/ComponentDeps.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Solver/Types/ComponentDeps.hs +++ /dev/null @@ -1,205 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} - --- | Fine-grained package dependencies --- --- Like many others, this module is meant to be "double-imported": --- --- > import Distribution.Solver.Types.ComponentDeps ( --- > Component --- > , ComponentDep --- > , ComponentDeps --- > ) --- > import qualified Distribution.Solver.Types.ComponentDeps as CD -module Distribution.Solver.Types.ComponentDeps ( - -- * Fine-grained package dependencies - Component(..) - , componentNameToComponent - , ComponentDep - , ComponentDeps -- opaque - -- ** Constructing ComponentDeps - , empty - , fromList - , singleton - , insert - , zip - , filterDeps - , fromLibraryDeps - , fromSetupDeps - , fromInstalled - -- ** Deconstructing ComponentDeps - , toList - , flatDeps - , nonSetupDeps - , libraryDeps - , setupDeps - , select - , components - ) where - -import Prelude () -import Distribution.Types.UnqualComponentName -import Distribution.Solver.Compat.Prelude hiding (empty,toList,zip) - -import qualified Data.Map as Map -import Data.Foldable (fold) - -import Distribution.Pretty (Pretty (..)) -import qualified Distribution.Types.ComponentName as CN -import qualified Distribution.Types.LibraryName as LN -import qualified Text.PrettyPrint as PP - - -{------------------------------------------------------------------------------- - Types --------------------------------------------------------------------------------} - --- | Component of a package. -data Component = - ComponentLib - | ComponentSubLib UnqualComponentName - | ComponentFLib UnqualComponentName - | ComponentExe UnqualComponentName - | ComponentTest UnqualComponentName - | ComponentBench UnqualComponentName - | ComponentSetup - deriving (Show, Eq, Ord, Generic) - -instance Binary Component -instance Structured Component - -instance Pretty Component where - pretty ComponentLib = PP.text "lib" - pretty (ComponentSubLib n) = PP.text "lib:" <<>> pretty n - pretty (ComponentFLib n) = PP.text "flib:" <<>> pretty n - pretty (ComponentExe n) = PP.text "exe:" <<>> pretty n - pretty (ComponentTest n) = PP.text "test:" <<>> pretty n - pretty (ComponentBench n) = PP.text "bench:" <<>> pretty n - pretty ComponentSetup = PP.text "setup" - --- | Dependency for a single component. -type ComponentDep a = (Component, a) - --- | Fine-grained dependencies for a package. --- --- Typically used as @ComponentDeps [Dependency]@, to represent the list of --- dependencies for each named component within a package. --- -newtype ComponentDeps a = ComponentDeps { unComponentDeps :: Map Component a } - deriving (Show, Functor, Eq, Ord, Generic) - -instance Semigroup a => Monoid (ComponentDeps a) where - mempty = ComponentDeps Map.empty - mappend = (<>) - -instance Semigroup a => Semigroup (ComponentDeps a) where - ComponentDeps d <> ComponentDeps d' = - ComponentDeps (Map.unionWith (<>) d d') - -instance Foldable ComponentDeps where - foldMap f = foldMap f . unComponentDeps - -instance Traversable ComponentDeps where - traverse f = fmap ComponentDeps . traverse f . unComponentDeps - -instance Binary a => Binary (ComponentDeps a) -instance Structured a => Structured (ComponentDeps a) - -componentNameToComponent :: CN.ComponentName -> Component -componentNameToComponent (CN.CLibName LN.LMainLibName) = ComponentLib -componentNameToComponent (CN.CLibName (LN.LSubLibName s)) = ComponentSubLib s -componentNameToComponent (CN.CFLibName s) = ComponentFLib s -componentNameToComponent (CN.CExeName s) = ComponentExe s -componentNameToComponent (CN.CTestName s) = ComponentTest s -componentNameToComponent (CN.CBenchName s) = ComponentBench s - -{------------------------------------------------------------------------------- - Construction --------------------------------------------------------------------------------} - -empty :: ComponentDeps a -empty = ComponentDeps $ Map.empty - -fromList :: Monoid a => [ComponentDep a] -> ComponentDeps a -fromList = ComponentDeps . Map.fromListWith mappend - -singleton :: Component -> a -> ComponentDeps a -singleton comp = ComponentDeps . Map.singleton comp - -insert :: Monoid a => Component -> a -> ComponentDeps a -> ComponentDeps a -insert comp a = ComponentDeps . Map.alter aux comp . unComponentDeps - where - aux Nothing = Just a - aux (Just a') = Just $ a `mappend` a' - --- | Zip two 'ComponentDeps' together by 'Component', using 'mempty' --- as the neutral element when a 'Component' is present only in one. -zip - :: (Monoid a, Monoid b) - => ComponentDeps a -> ComponentDeps b -> ComponentDeps (a, b) -zip (ComponentDeps d1) (ComponentDeps d2) = - ComponentDeps $ - Map.mergeWithKey - (\_ a b -> Just (a,b)) - (fmap (\a -> (a, mempty))) - (fmap (\b -> (mempty, b))) - d1 d2 - --- | Keep only selected components (and their associated deps info). -filterDeps :: (Component -> a -> Bool) -> ComponentDeps a -> ComponentDeps a -filterDeps p = ComponentDeps . Map.filterWithKey p . unComponentDeps - --- | ComponentDeps containing library dependencies only -fromLibraryDeps :: a -> ComponentDeps a -fromLibraryDeps = singleton ComponentLib - --- | ComponentDeps containing setup dependencies only. -fromSetupDeps :: a -> ComponentDeps a -fromSetupDeps = singleton ComponentSetup - --- | ComponentDeps for installed packages. --- --- We assume that installed packages only record their library dependencies. -fromInstalled :: a -> ComponentDeps a -fromInstalled = fromLibraryDeps - -{------------------------------------------------------------------------------- - Deconstruction --------------------------------------------------------------------------------} - -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 --- would have been _all_ dependencies. -nonSetupDeps :: Monoid a => ComponentDeps a -> a -nonSetupDeps = select (/= ComponentSetup) - --- | Library dependencies proper only. (Includes dependencies --- of internal libraries.) -libraryDeps :: Monoid a => ComponentDeps a -> a -libraryDeps = select (\c -> case c of ComponentSubLib _ -> True - ComponentLib -> True - _ -> False) - --- | List components -components :: ComponentDeps a -> Set Component -components = Map.keysSet . unComponentDeps - --- | Setup dependencies. -setupDeps :: Monoid a => ComponentDeps a -> a -setupDeps = select (== ComponentSetup) - --- | Select dependencies satisfying a given predicate. -select :: Monoid a => (Component -> Bool) -> ComponentDeps a -> a -select p = foldMap snd . filter (p . fst) . toList diff --git a/cabal/cabal-install/Distribution/Solver/Types/ConstraintSource.hs b/cabal/cabal-install/Distribution/Solver/Types/ConstraintSource.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Solver/Types/ConstraintSource.hs +++ /dev/null @@ -1,83 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Solver.Types.ConstraintSource - ( ConstraintSource(..) - , showConstraintSource - ) where - -import Distribution.Solver.Compat.Prelude -import Prelude () - --- | Source of a 'PackageConstraint'. -data ConstraintSource = - - -- | Main config file, which is ~/.cabal/config by default. - ConstraintSourceMainConfig FilePath - - -- | Local cabal.project file - | ConstraintSourceProjectConfig FilePath - - -- | Sandbox config file, which is ./cabal.sandbox.config by default. - | ConstraintSourceSandboxConfig FilePath - - -- | User config file, which is ./cabal.config by default. - | ConstraintSourceUserConfig FilePath - - -- | Flag specified on the command line. - | ConstraintSourceCommandlineFlag - - -- | Target specified by the user, e.g., @cabal install package-0.1.0.0@ - -- implies @package==0.1.0.0@. - | ConstraintSourceUserTarget - - -- | Internal requirement to use installed versions of packages like ghc-prim. - | ConstraintSourceNonUpgradeablePackage - - -- | Internal requirement to use the add-source version of a package when that - -- version is installed and the source is modified. - | ConstraintSourceModifiedAddSourceDep - - -- | Internal constraint used by @cabal freeze@. - | ConstraintSourceFreeze - - -- | Constraint specified by a config file, a command line flag, or a user - -- target, when a more specific source is not known. - | ConstraintSourceConfigFlagOrTarget - - -- | The source of the constraint is not specified. - | ConstraintSourceUnknown - - -- | An internal constraint due to compatibility issues with the Setup.hs - -- command line interface requires a minimum lower bound on Cabal - | ConstraintSetupCabalMinVersion - - -- | An internal constraint due to compatibility issues with the Setup.hs - -- command line interface requires a maximum upper bound on Cabal - | ConstraintSetupCabalMaxVersion - deriving (Eq, Show, Generic) - -instance Binary ConstraintSource -instance Structured ConstraintSource - --- | Description of a 'ConstraintSource'. -showConstraintSource :: ConstraintSource -> String -showConstraintSource (ConstraintSourceMainConfig path) = - "main config " ++ path -showConstraintSource (ConstraintSourceProjectConfig path) = - "project config " ++ path -showConstraintSource (ConstraintSourceSandboxConfig path) = - "sandbox config " ++ path -showConstraintSource (ConstraintSourceUserConfig path)= "user config " ++ path -showConstraintSource ConstraintSourceCommandlineFlag = "command line flag" -showConstraintSource ConstraintSourceUserTarget = "user target" -showConstraintSource ConstraintSourceNonUpgradeablePackage = - "non-upgradeable package" -showConstraintSource ConstraintSourceModifiedAddSourceDep = - "modified add-source dependency" -showConstraintSource ConstraintSourceFreeze = "cabal freeze" -showConstraintSource ConstraintSourceConfigFlagOrTarget = - "config file, command line flag, or user target" -showConstraintSource ConstraintSourceUnknown = "unknown source" -showConstraintSource ConstraintSetupCabalMinVersion = - "minimum version of Cabal used by Setup.hs" -showConstraintSource ConstraintSetupCabalMaxVersion = - "maximum version of Cabal used by Setup.hs" diff --git a/cabal/cabal-install/Distribution/Solver/Types/DependencyResolver.hs b/cabal/cabal-install/Distribution/Solver/Types/DependencyResolver.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Solver/Types/DependencyResolver.hs +++ /dev/null @@ -1,37 +0,0 @@ -module Distribution.Solver.Types.DependencyResolver - ( DependencyResolver - ) where - -import Distribution.Solver.Compat.Prelude -import Prelude () - -import Distribution.Solver.Types.LabeledPackageConstraint -import Distribution.Solver.Types.PkgConfigDb ( PkgConfigDb ) -import Distribution.Solver.Types.PackagePreferences -import Distribution.Solver.Types.PackageIndex ( PackageIndex ) -import Distribution.Solver.Types.Progress -import Distribution.Solver.Types.ResolverPackage -import Distribution.Solver.Types.SourcePackage - -import Distribution.Simple.PackageIndex ( InstalledPackageIndex ) -import Distribution.Package ( PackageName ) -import Distribution.Compiler ( CompilerInfo ) -import Distribution.System ( Platform ) - --- | A dependency resolver is a function that works out an installation plan --- given the set of installed and available packages and a set of deps to --- solve for. --- --- The reason for this interface is because there are dozens of approaches to --- solving the package dependency problem and we want to make it easy to swap --- in alternatives. --- -type DependencyResolver loc = Platform - -> CompilerInfo - -> InstalledPackageIndex - -> PackageIndex (SourcePackage loc) - -> PkgConfigDb - -> (PackageName -> PackagePreferences) - -> [LabeledPackageConstraint] - -> Set PackageName - -> Progress String String [ResolverPackage loc] diff --git a/cabal/cabal-install/Distribution/Solver/Types/Flag.hs b/cabal/cabal-install/Distribution/Solver/Types/Flag.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Solver/Types/Flag.hs +++ /dev/null @@ -1,8 +0,0 @@ -module Distribution.Solver.Types.Flag - ( FlagType(..) - ) where - -import Prelude (Eq, Show) - -data FlagType = Manual | Automatic - deriving (Eq, Show) diff --git a/cabal/cabal-install/Distribution/Solver/Types/InstSolverPackage.hs b/cabal/cabal-install/Distribution/Solver/Types/InstSolverPackage.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Solver/Types/InstSolverPackage.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Solver.Types.InstSolverPackage - ( InstSolverPackage(..) - ) where - -import Distribution.Solver.Compat.Prelude -import Prelude () - -import Distribution.Package ( Package(..), HasMungedPackageId(..), HasUnitId(..) ) -import Distribution.Solver.Types.ComponentDeps ( ComponentDeps ) -import Distribution.Solver.Types.SolverId -import Distribution.Types.MungedPackageId -import Distribution.Types.PackageId -import Distribution.Types.MungedPackageName -import Distribution.InstalledPackageInfo (InstalledPackageInfo) - --- | An 'InstSolverPackage' is a pre-existing installed package --- specified by the dependency solver. -data InstSolverPackage = InstSolverPackage { - instSolverPkgIPI :: InstalledPackageInfo, - instSolverPkgLibDeps :: ComponentDeps [SolverId], - instSolverPkgExeDeps :: ComponentDeps [SolverId] - } - deriving (Eq, Show, Generic) - -instance Binary InstSolverPackage -instance Structured InstSolverPackage - -instance Package InstSolverPackage where - packageId i = - -- HACK! See Note [Index conversion with internal libraries] - let MungedPackageId mpn v = mungedId i - in PackageIdentifier (encodeCompatPackageName mpn) v - -instance HasMungedPackageId InstSolverPackage where - mungedId = mungedId . instSolverPkgIPI - -instance HasUnitId InstSolverPackage where - installedUnitId = installedUnitId . instSolverPkgIPI diff --git a/cabal/cabal-install/Distribution/Solver/Types/InstalledPreference.hs b/cabal/cabal-install/Distribution/Solver/Types/InstalledPreference.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Solver/Types/InstalledPreference.hs +++ /dev/null @@ -1,11 +0,0 @@ -module Distribution.Solver.Types.InstalledPreference - ( InstalledPreference(..), - ) where - -import Prelude (Show) - --- | Whether we prefer an installed version of a package or simply the latest --- version. --- -data InstalledPreference = PreferInstalled | PreferLatest - deriving Show diff --git a/cabal/cabal-install/Distribution/Solver/Types/LabeledPackageConstraint.hs b/cabal/cabal-install/Distribution/Solver/Types/LabeledPackageConstraint.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Solver/Types/LabeledPackageConstraint.hs +++ /dev/null @@ -1,14 +0,0 @@ -module Distribution.Solver.Types.LabeledPackageConstraint - ( LabeledPackageConstraint(..) - , unlabelPackageConstraint - ) where - -import Distribution.Solver.Types.ConstraintSource -import Distribution.Solver.Types.PackageConstraint - --- | 'PackageConstraint' labeled with its source. -data LabeledPackageConstraint - = LabeledPackageConstraint PackageConstraint ConstraintSource - -unlabelPackageConstraint :: LabeledPackageConstraint -> PackageConstraint -unlabelPackageConstraint (LabeledPackageConstraint pc _) = pc diff --git a/cabal/cabal-install/Distribution/Solver/Types/OptionalStanza.hs b/cabal/cabal-install/Distribution/Solver/Types/OptionalStanza.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Solver/Types/OptionalStanza.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveDataTypeable #-} -module Distribution.Solver.Types.OptionalStanza - ( OptionalStanza(..) - , showStanza - , enableStanzas - ) where - -import Distribution.Solver.Compat.Prelude -import Prelude () -import Distribution.Types.ComponentRequestedSpec - (ComponentRequestedSpec(..), defaultComponentRequestedSpec) - -data OptionalStanza - = TestStanzas - | BenchStanzas - deriving (Eq, Ord, Enum, Bounded, Show, Generic, Typeable) - --- | String representation of an OptionalStanza. -showStanza :: OptionalStanza -> String -showStanza TestStanzas = "test" -showStanza BenchStanzas = "bench" - --- | Convert a list of 'OptionalStanza' into the corresponding --- 'ComponentRequestedSpec' which records what components are enabled. -enableStanzas :: [OptionalStanza] -> ComponentRequestedSpec -enableStanzas = foldl' addStanza defaultComponentRequestedSpec - where - addStanza enabled TestStanzas = enabled { testsRequested = True } - addStanza enabled BenchStanzas = enabled { benchmarksRequested = True } - -instance Binary OptionalStanza -instance Structured OptionalStanza diff --git a/cabal/cabal-install/Distribution/Solver/Types/PackageConstraint.hs b/cabal/cabal-install/Distribution/Solver/Types/PackageConstraint.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Solver/Types/PackageConstraint.hs +++ /dev/null @@ -1,148 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - --- | Per-package constraints. Package constraints must be respected by the --- solver. Multiple constraints for each package can be given, though obviously --- it is possible to construct conflicting constraints (eg impossible version --- range or inconsistent flag assignment). --- -module Distribution.Solver.Types.PackageConstraint ( - ConstraintScope(..), - scopeToplevel, - scopeToPackageName, - constraintScopeMatches, - PackageProperty(..), - dispPackageProperty, - PackageConstraint(..), - dispPackageConstraint, - showPackageConstraint, - packageConstraintToDependency - ) where - -import Distribution.Solver.Compat.Prelude -import Prelude () - -import Distribution.Package (PackageName) -import Distribution.PackageDescription (FlagAssignment, dispFlagAssignment) -import Distribution.Pretty (flatStyle, pretty) -import Distribution.Types.PackageVersionConstraint (PackageVersionConstraint (..)) -import Distribution.Version (VersionRange, simplifyVersionRange) - -import Distribution.Solver.Types.OptionalStanza -import Distribution.Solver.Types.PackagePath - -import qualified Text.PrettyPrint as Disp - - --- | Determines to what packages and in what contexts a --- constraint applies. -data ConstraintScope - -- | 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 - -- considered to match a package name when it is either the default - -- namespace (for --no-independent-goals) or it is an independent namespace - -- with the given package name (for --independent-goals). - - -- TODO: Try to generalize the ConstraintScopes once component-based - -- solving is implemented, and remove this special case for targets. - = 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. - | ScopeAnySetupQualifier 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. -scopeToplevel :: PackageName -> ConstraintScope -scopeToplevel = 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 - -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' - --- | Pretty-prints a constraint scope. -dispConstraintScope :: ConstraintScope -> Disp.Doc -dispConstraintScope (ScopeTarget pn) = pretty pn <<>> Disp.text "." <<>> pretty pn -dispConstraintScope (ScopeQualified q pn) = dispQualifier q <<>> pretty pn -dispConstraintScope (ScopeAnySetupQualifier pn) = Disp.text "setup." <<>> pretty pn -dispConstraintScope (ScopeAnyQualifier pn) = Disp.text "any." <<>> pretty pn - --- | A package property is a logical predicate on packages. -data PackageProperty - = PackagePropertyVersion VersionRange - | PackagePropertyInstalled - | PackagePropertySource - | PackagePropertyFlags FlagAssignment - | PackagePropertyStanzas [OptionalStanza] - deriving (Eq, Show, Generic) - -instance Binary PackageProperty -instance Structured PackageProperty - --- | Pretty-prints a package property. -dispPackageProperty :: PackageProperty -> Disp.Doc -dispPackageProperty (PackagePropertyVersion verrange) = pretty verrange -dispPackageProperty PackagePropertyInstalled = Disp.text "installed" -dispPackageProperty PackagePropertySource = Disp.text "source" -dispPackageProperty (PackagePropertyFlags flags) = dispFlagAssignment flags -dispPackageProperty (PackagePropertyStanzas stanzas) = - Disp.hsep $ map (Disp.text . showStanza) stanzas - --- | A package constraint consists of a scope plus a property --- that must hold for all packages within that scope. -data PackageConstraint = PackageConstraint ConstraintScope PackageProperty - deriving (Eq, Show) - --- | Pretty-prints a package constraint. -dispPackageConstraint :: PackageConstraint -> Disp.Doc -dispPackageConstraint (PackageConstraint scope prop) = - dispConstraintScope scope <+> dispPackageProperty prop - --- | Alternative textual representation of a package constraint --- for debugging purposes (slightly more verbose than that --- produced by 'dispPackageConstraint'). --- -showPackageConstraint :: PackageConstraint -> String -showPackageConstraint pc@(PackageConstraint scope prop) = - Disp.renderStyle flatStyle . postprocess $ dispPackageConstraint pc2 - where - pc2 = case prop of - PackagePropertyVersion vr -> - PackageConstraint scope $ PackagePropertyVersion (simplifyVersionRange vr) - _ -> pc - postprocess = case prop of - PackagePropertyFlags _ -> (Disp.text "flags" <+>) - PackagePropertyStanzas _ -> (Disp.text "stanzas" <+>) - _ -> id - --- | Lossily convert a 'PackageConstraint' to a 'Dependency'. -packageConstraintToDependency :: PackageConstraint -> Maybe PackageVersionConstraint -packageConstraintToDependency (PackageConstraint scope prop) = toDep prop - where - toDep (PackagePropertyVersion vr) = Just $ PackageVersionConstraint (scopeToPackageName scope) vr - toDep (PackagePropertyInstalled) = Nothing - toDep (PackagePropertySource) = Nothing - toDep (PackagePropertyFlags _) = Nothing - toDep (PackagePropertyStanzas _) = Nothing diff --git a/cabal/cabal-install/Distribution/Solver/Types/PackageFixedDeps.hs b/cabal/cabal-install/Distribution/Solver/Types/PackageFixedDeps.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Solver/Types/PackageFixedDeps.hs +++ /dev/null @@ -1,23 +0,0 @@ -module Distribution.Solver.Types.PackageFixedDeps - ( PackageFixedDeps(..) - ) where - -import Distribution.InstalledPackageInfo ( InstalledPackageInfo ) -import Distribution.Package - ( Package(..), UnitId, installedDepends) -import Distribution.Solver.Types.ComponentDeps ( ComponentDeps ) -import qualified Distribution.Solver.Types.ComponentDeps as CD - --- | Subclass of packages that have specific versioned dependencies. --- --- So for example a not-yet-configured package has dependencies on version --- ranges, not specific versions. A configured or an already installed package --- depends on exact versions. Some operations or data structures (like --- dependency graphs) only make sense on this subclass of package types. --- -class Package pkg => PackageFixedDeps pkg where - depends :: pkg -> ComponentDeps [UnitId] - -instance PackageFixedDeps InstalledPackageInfo where - depends pkg = CD.fromInstalled (installedDepends pkg) - diff --git a/cabal/cabal-install/Distribution/Solver/Types/PackageIndex.hs b/cabal/cabal-install/Distribution/Solver/Types/PackageIndex.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Solver/Types/PackageIndex.hs +++ /dev/null @@ -1,338 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Solver.Types.PackageIndex --- Copyright : (c) David Himmelstrup 2005, --- Bjorn Bringert 2007, --- Duncan Coutts 2008 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- An index of packages. --- -module Distribution.Solver.Types.PackageIndex ( - -- * Package index data type - PackageIndex, - - -- * Creating an index - fromList, - - -- * Updates - merge, - override, - insert, - deletePackageName, - deletePackageId, - deleteDependency, - - -- * Queries - - -- ** Precise lookups - elemByPackageId, - elemByPackageName, - lookupPackageName, - lookupPackageId, - lookupDependency, - - -- ** Case-insensitive searches - searchByName, - SearchResult(..), - searchByNameSubstring, - searchWithPredicate, - - -- ** Bulk queries - allPackages, - allPackagesByName, - ) where - -import Prelude () -import Distribution.Solver.Compat.Prelude hiding (lookup) - -import Control.Exception (assert) -import qualified Data.Map as Map -import Data.List (isInfixOf) -import qualified Data.List.NonEmpty as NE - -import Distribution.Package - ( PackageName, unPackageName, PackageIdentifier(..) - , Package(..), packageName, packageVersion ) -import Distribution.Version - ( VersionRange, withinRange ) -import Distribution.Simple.Utils - ( lowercase ) - -import qualified Prelude (foldr1) - --- | The collection of information about packages from one or more 'PackageDB's. --- --- It can be searched efficiently by package name and version. --- -newtype PackageIndex pkg = PackageIndex - -- This index package names to all the package records matching that package - -- name case-sensitively. It includes all versions. - -- - -- This allows us to find all versions satisfying a dependency. - -- Most queries are a map lookup followed by a linear scan of the bucket. - -- - (Map PackageName [pkg]) - - deriving (Eq, Show, Read, Functor, Generic) ---FIXME: the Functor instance here relies on no package id changes - -instance Package pkg => Semigroup (PackageIndex pkg) where - (<>) = merge - -instance Package pkg => Monoid (PackageIndex pkg) where - mempty = PackageIndex Map.empty - mappend = (<>) - --save one mappend with empty in the common case: - mconcat [] = mempty - mconcat xs = Prelude.foldr1 mappend xs - -instance Binary pkg => Binary (PackageIndex pkg) - -invariant :: Package pkg => PackageIndex pkg -> Bool -invariant (PackageIndex m) = all (uncurry goodBucket) (Map.toList m) - where - goodBucket _ [] = False - goodBucket name (pkg0:pkgs0) = check (packageId pkg0) pkgs0 - where - check pkgid [] = packageName pkgid == name - check pkgid (pkg':pkgs) = packageName pkgid == name - && pkgid < pkgid' - && check pkgid' pkgs - where pkgid' = packageId pkg' - --- --- * Internal helpers --- - -mkPackageIndex :: Package pkg => Map PackageName [pkg] -> PackageIndex pkg -mkPackageIndex index = assert (invariant (PackageIndex index)) - (PackageIndex index) - -internalError :: String -> a -internalError name = error ("PackageIndex." ++ name ++ ": internal error") - --- | Lookup a name in the index to get all packages that match that name --- case-sensitively. --- -lookup :: PackageIndex pkg -> PackageName -> [pkg] -lookup (PackageIndex m) name = fromMaybe [] $ Map.lookup name m - --- --- * Construction --- - --- | Build an index out of a bunch of packages. --- --- If there are duplicates, later ones mask earlier ones. --- -fromList :: Package pkg => [pkg] -> PackageIndex pkg -fromList pkgs = mkPackageIndex - . Map.map fixBucket - . Map.fromListWith (++) - $ [ (packageName pkg, [pkg]) - | pkg <- pkgs ] - where - fixBucket = -- out of groups of duplicates, later ones mask earlier ones - -- but Map.fromListWith (++) constructs groups in reverse order - map NE.head - -- Eq instance for PackageIdentifier is wrong, so use Ord: - . NE.groupBy (\a b -> EQ == comparing packageId a b) - -- relies on sortBy being a stable sort so we - -- can pick consistently among duplicates - . sortBy (comparing packageId) - --- --- * Updates --- - --- | Merge two indexes. --- --- Packages from the second mask packages of the same exact name --- (case-sensitively) from the first. --- -merge :: Package pkg => PackageIndex pkg -> PackageIndex pkg -> PackageIndex pkg -merge i1@(PackageIndex m1) i2@(PackageIndex m2) = - assert (invariant i1 && invariant i2) $ - mkPackageIndex (Map.unionWith mergeBuckets m1 m2) - - --- | Elements in the second list mask those in the first. -mergeBuckets :: Package pkg => [pkg] -> [pkg] -> [pkg] -mergeBuckets [] ys = ys -mergeBuckets xs [] = xs -mergeBuckets xs@(x:xs') ys@(y:ys') = - case packageId x `compare` packageId y of - GT -> y : mergeBuckets xs ys' - EQ -> y : mergeBuckets xs' ys' - LT -> x : mergeBuckets xs' ys - --- | Override-merge oftwo indexes. --- --- Packages from the second mask packages of the same exact name --- (case-sensitively) from the first. --- -override :: Package pkg => PackageIndex pkg -> PackageIndex pkg -> PackageIndex pkg -override i1@(PackageIndex m1) i2@(PackageIndex m2) = - assert (invariant i1 && invariant i2) $ - mkPackageIndex (Map.unionWith (\_l r -> r) m1 m2) - --- | Inserts a single package into the index. --- --- This is equivalent to (but slightly quicker than) using 'mappend' or --- 'merge' with a singleton index. --- -insert :: Package pkg => pkg -> PackageIndex pkg -> PackageIndex pkg -insert pkg (PackageIndex index) = mkPackageIndex $ - Map.insertWith (\_ -> insertNoDup) (packageName pkg) [pkg] index - where - pkgid = packageId pkg - insertNoDup [] = [pkg] - insertNoDup pkgs@(pkg':pkgs') = case compare pkgid (packageId pkg') of - LT -> pkg : pkgs - EQ -> pkg : pkgs' - GT -> pkg' : insertNoDup pkgs' - --- | Internal delete helper. --- -delete :: Package pkg => PackageName -> (pkg -> Bool) -> PackageIndex pkg - -> PackageIndex pkg -delete name p (PackageIndex index) = mkPackageIndex $ - Map.update filterBucket name index - where - filterBucket = deleteEmptyBucket - . filter (not . p) - deleteEmptyBucket [] = Nothing - deleteEmptyBucket remaining = Just remaining - --- | Removes a single package from the index. --- -deletePackageId :: Package pkg => PackageIdentifier -> PackageIndex pkg - -> PackageIndex pkg -deletePackageId pkgid = - delete (packageName pkgid) (\pkg -> packageId pkg == pkgid) - --- | Removes all packages with this (case-sensitive) name from the index. --- -deletePackageName :: Package pkg => PackageName -> PackageIndex pkg - -> PackageIndex pkg -deletePackageName name = - delete name (\pkg -> packageName pkg == name) - --- | Removes all packages satisfying this dependency from the index. -deleteDependency :: Package pkg - => PackageName -> VersionRange -> PackageIndex pkg - -> PackageIndex pkg -deleteDependency name verstionRange = - delete name (\pkg -> packageVersion pkg `withinRange` verstionRange) - --- --- * Bulk queries --- - --- | Get all the packages from the index. --- -allPackages :: PackageIndex pkg -> [pkg] -allPackages (PackageIndex m) = concat (Map.elems m) - --- | Get all the packages from the index. --- --- They are grouped by package name, case-sensitively. --- -allPackagesByName :: PackageIndex pkg -> [[pkg]] -allPackagesByName (PackageIndex m) = Map.elems m - --- --- * Lookups --- - -elemByPackageId :: Package pkg => PackageIndex pkg -> PackageIdentifier -> Bool -elemByPackageId index = isJust . lookupPackageId index - -elemByPackageName :: Package pkg => PackageIndex pkg -> PackageName -> Bool -elemByPackageName index = not . null . lookupPackageName index - - --- | Does a lookup by package id (name & version). --- --- Since multiple package DBs mask each other case-sensitively by package name, --- then we get back at most one package. --- -lookupPackageId :: Package pkg => PackageIndex pkg -> PackageIdentifier - -> Maybe pkg -lookupPackageId index pkgid = - case [ pkg | pkg <- lookup index (packageName pkgid) - , packageId pkg == pkgid ] of - [] -> Nothing - [pkg] -> Just pkg - _ -> internalError "lookupPackageIdentifier" - --- | Does a case-sensitive search by package name. --- -lookupPackageName :: Package pkg => PackageIndex pkg -> PackageName -> [pkg] -lookupPackageName index name = - [ pkg | pkg <- lookup index name - , packageName pkg == name ] - --- | Does a case-sensitive search by package name and a range of versions. --- --- We get back any number of versions of the specified package name, all --- satisfying the version range constraint. --- -lookupDependency :: Package pkg - => PackageIndex pkg - -> PackageName -> VersionRange - -> [pkg] -lookupDependency index name versionRange = - [ pkg | pkg <- lookup index name - , packageName pkg == name - , packageVersion pkg `withinRange` versionRange ] - --- --- * Case insensitive name lookups --- - --- | Does a case-insensitive search by package name. --- --- If there is only one package that compares case-insensitively to this name --- then the search is unambiguous and we get back all versions of that package. --- If several match case-insensitively but one matches exactly then it is also --- unambiguous. --- --- If however several match case-insensitively and none match exactly then we --- have an ambiguous result, and we get back all the versions of all the --- packages. The list of ambiguous results is split by exact package name. So --- it is a non-empty list of non-empty lists. --- -searchByName :: PackageIndex pkg - -> String -> [(PackageName, [pkg])] -searchByName (PackageIndex m) name = - [ pkgs - | pkgs@(pname,_) <- Map.toList m - , lowercase (unPackageName pname) == lname ] - where - lname = lowercase name - -data SearchResult a = None | Unambiguous a | Ambiguous [a] - --- | Does a case-insensitive substring search by package name. --- --- That is, all packages that contain the given string in their name. --- -searchByNameSubstring :: PackageIndex pkg - -> String -> [(PackageName, [pkg])] -searchByNameSubstring index searchterm = - searchWithPredicate index (\n -> lsearchterm `isInfixOf` lowercase n) - where lsearchterm = lowercase searchterm - -searchWithPredicate :: PackageIndex pkg - -> (String -> Bool) -> [(PackageName, [pkg])] -searchWithPredicate (PackageIndex m) predicate = - [ pkgs - | pkgs@(pname, _) <- Map.toList m - , predicate (unPackageName pname) - ] diff --git a/cabal/cabal-install/Distribution/Solver/Types/PackagePath.hs b/cabal/cabal-install/Distribution/Solver/Types/PackagePath.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Solver/Types/PackagePath.hs +++ /dev/null @@ -1,102 +0,0 @@ -module Distribution.Solver.Types.PackagePath - ( PackagePath(..) - , Namespace(..) - , Qualifier(..) - , dispQualifier - , Qualified(..) - , QPN - , dispQPN - , showQPN - ) where - -import Distribution.Solver.Compat.Prelude -import Prelude () -import Distribution.Package (PackageName) -import Distribution.Pretty (pretty, flatStyle) -import qualified Text.PrettyPrint as Disp - --- | A package path consists of a namespace and a package path inside that --- namespace. -data PackagePath = PackagePath Namespace Qualifier - deriving (Eq, Ord, Show) - --- | 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 "." - --- | Qualifier of a package within a namespace (see 'PackagePath') -data Qualifier = - -- | Top-level dependency in this namespace - QualToplevel - - -- | Any dependency on base is considered independent - -- - -- This makes it possible to have base shims. - | QualBase PackageName - - -- | Setup dependency - -- - -- By rights setup dependencies ought to be nestable; after all, the setup - -- dependencies of a package might themselves have setup dependencies, which - -- are independent from everything else. However, this very quickly leads to - -- infinite search trees in the solver. Therefore we limit ourselves to - -- a single qualifier (within a given namespace). - | QualSetup PackageName - - -- | If we depend on an executable from a package (via - -- @build-tools@), we should solve for the dependencies of that - -- package separately (since we're not going to actually try to - -- link it.) We qualify for EACH package separately; e.g., - -- @'Exe' pn1 pn2@ qualifies the @build-tools@ dependency on - -- @pn2@ from package @pn1@. (If we tracked only @pn1@, that - -- would require a consistent dependency resolution for all - -- of the depended upon executables from a package; if we - -- 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) - --- | Pretty-prints a qualifier. The result is either empty or --- ends in a period, so it can be prepended onto a package name. --- --- NOTE: the base qualifier is for a dependency _on_ base; the qualifier is --- there to make sure different dependencies on base are all independent. --- So we want to print something like @"A.base"@, where the @"A."@ part --- 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 "." - --- | A qualified entity. Pairs a package path with the entity. -data Qualified a = Q PackagePath a - deriving (Eq, Ord, Show) - --- | Qualified package name. -type QPN = Qualified PackageName - --- | Pretty-prints a qualified package name. -dispQPN :: QPN -> Disp.Doc -dispQPN (Q (PackagePath ns qual) pn) = - dispNamespace ns <<>> dispQualifier qual <<>> pretty pn - --- | String representation of a qualified package name. -showQPN :: QPN -> String -showQPN = Disp.renderStyle flatStyle . dispQPN diff --git a/cabal/cabal-install/Distribution/Solver/Types/PackagePreferences.hs b/cabal/cabal-install/Distribution/Solver/Types/PackagePreferences.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Solver/Types/PackagePreferences.hs +++ /dev/null @@ -1,22 +0,0 @@ -module Distribution.Solver.Types.PackagePreferences - ( PackagePreferences(..) - ) where - -import Distribution.Solver.Types.InstalledPreference -import Distribution.Solver.Types.OptionalStanza -import Distribution.Version (VersionRange) - --- | Per-package preferences on the version. It is a soft constraint that the --- 'DependencyResolver' should try to respect where possible. It consists of --- an 'InstalledPreference' which says if we prefer versions of packages --- that are already installed. It also has (possibly multiple) --- 'PackageVersionPreference's which are suggested constraints on the version --- number. The resolver should try to use package versions that satisfy --- the maximum number of the suggested version constraints. --- --- It is not specified if preferences on some packages are more important than --- others. --- -data PackagePreferences = PackagePreferences [VersionRange] - InstalledPreference - [OptionalStanza] diff --git a/cabal/cabal-install/Distribution/Solver/Types/PkgConfigDb.hs b/cabal/cabal-install/Distribution/Solver/Types/PkgConfigDb.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Solver/Types/PkgConfigDb.hs +++ /dev/null @@ -1,155 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Solver.Types.PkgConfigDb --- Copyright : (c) Iñaki García Etxebarria 2016 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Read the list of packages available to pkg-config. ------------------------------------------------------------------------------ -module Distribution.Solver.Types.PkgConfigDb - ( PkgConfigDb - , readPkgConfigDb - , pkgConfigDbFromList - , pkgConfigPkgIsPresent - , pkgConfigDbPkgVersion - , getPkgConfigDbDirs - ) where - -import Distribution.Solver.Compat.Prelude -import Prelude () - -import Control.Exception (handle) -import qualified Data.Map as M -import System.FilePath (splitSearchPath) - -import Distribution.Compat.Environment (lookupEnv) -import Distribution.Package (PkgconfigName, mkPkgconfigName) -import Distribution.Parsec -import Distribution.Simple.Program - (ProgramDb, getProgramOutput, pkgConfigProgram, needProgram) -import Distribution.Simple.Utils (info) -import Distribution.Types.PkgconfigVersion -import Distribution.Types.PkgconfigVersionRange -import Distribution.Verbosity (Verbosity) - --- | The list of packages installed in the system visible to --- @pkg-config@. This is an opaque datatype, to be constructed with --- `readPkgConfigDb` and queried with `pkgConfigPkgPresent`. -data PkgConfigDb = PkgConfigDb (M.Map PkgconfigName (Maybe PkgconfigVersion)) - -- ^ If an entry is `Nothing`, this means that the - -- package seems to be present, but we don't know the - -- exact version (because parsing of the version - -- number failed). - | NoPkgConfigDb - -- ^ For when we could not run pkg-config successfully. - deriving (Show, Generic, Typeable) - -instance Binary PkgConfigDb -instance Structured PkgConfigDb - --- | Query pkg-config for the list of installed packages, together --- with their versions. Return a `PkgConfigDb` encapsulating this --- information. -readPkgConfigDb :: Verbosity -> ProgramDb -> IO PkgConfigDb -readPkgConfigDb verbosity progdb = handle ioErrorHandler $ do - mpkgConfig <- needProgram verbosity pkgConfigProgram progdb - case mpkgConfig of - Nothing -> noPkgConfig "Cannot find pkg-config program" - Just (pkgConfig, _) -> do - pkgList <- lines <$> getProgramOutput verbosity pkgConfig ["--list-all"] - -- The output of @pkg-config --list-all@ also includes a description - -- for each package, which we do not need. - let pkgNames = map (takeWhile (not . isSpace)) pkgList - pkgVersions <- lines <$> getProgramOutput verbosity pkgConfig - ("--modversion" : pkgNames) - (return . pkgConfigDbFromList . zip pkgNames) pkgVersions - where - -- For when pkg-config invocation fails (possibly because of a - -- too long command line). - noPkgConfig extra = do - info verbosity ("Failed to query pkg-config, Cabal will continue" - ++ " without solving for pkg-config constraints: " - ++ extra) - return NoPkgConfigDb - - ioErrorHandler :: IOException -> IO PkgConfigDb - ioErrorHandler e = noPkgConfig (show e) - --- | Create a `PkgConfigDb` from a list of @(packageName, version)@ pairs. -pkgConfigDbFromList :: [(String, String)] -> PkgConfigDb -pkgConfigDbFromList pairs = (PkgConfigDb . M.fromList . map convert) pairs - where - convert :: (String, String) -> (PkgconfigName, Maybe PkgconfigVersion) - convert (n,vs) = (mkPkgconfigName n, simpleParsec vs) - --- | Check whether a given package range is satisfiable in the given --- @pkg-config@ database. -pkgConfigPkgIsPresent :: PkgConfigDb -> PkgconfigName -> PkgconfigVersionRange -> Bool -pkgConfigPkgIsPresent (PkgConfigDb db) pn vr = - case M.lookup pn db of - Nothing -> False -- Package not present in the DB. - Just Nothing -> True -- Package present, but version unknown. - Just (Just v) -> withinPkgconfigVersionRange v vr --- If we could not read the pkg-config database successfully we allow --- the check to succeed. The plan found by the solver may fail to be --- executed later on, but we have no grounds for rejecting the plan at --- this stage. -pkgConfigPkgIsPresent NoPkgConfigDb _ _ = True - - --- | Query the version of a package in the @pkg-config@ database. --- @Nothing@ indicates the package is not in the database, while --- @Just Nothing@ indicates that the package is in the database, --- but its version is not known. -pkgConfigDbPkgVersion :: PkgConfigDb -> PkgconfigName -> Maybe (Maybe PkgconfigVersion) -pkgConfigDbPkgVersion (PkgConfigDb db) pn = M.lookup pn db --- NB: Since the solver allows solving to succeed if there is --- NoPkgConfigDb, we should report that we *guess* that there --- is a matching pkg-config configuration, but that we just --- don't know about it. -pkgConfigDbPkgVersion NoPkgConfigDb _ = Just Nothing - - --- | Query pkg-config for the locations of pkg-config's package files. Use this --- to monitor for changes in the pkg-config DB. --- -getPkgConfigDbDirs :: Verbosity -> ProgramDb -> IO [FilePath] -getPkgConfigDbDirs verbosity progdb = - (++) <$> getEnvPath <*> getDefPath - where - -- According to @man pkg-config@: - -- - -- PKG_CONFIG_PATH - -- A colon-separated (on Windows, semicolon-separated) list of directories - -- to search for .pc files. The default directory will always be searched - -- after searching the path - -- - getEnvPath = maybe [] parseSearchPath - <$> lookupEnv "PKG_CONFIG_PATH" - - -- Again according to @man pkg-config@: - -- - -- pkg-config can be used to query itself for the default search path, - -- version number and other information, for instance using: - -- - -- > pkg-config --variable pc_path pkg-config - -- - getDefPath = handle ioErrorHandler $ do - mpkgConfig <- needProgram verbosity pkgConfigProgram progdb - case mpkgConfig of - Nothing -> return [] - Just (pkgConfig, _) -> parseSearchPath <$> - getProgramOutput verbosity pkgConfig ["--variable", "pc_path", "pkg-config"] - - parseSearchPath str = - case lines str of - [p] | not (null p) -> splitSearchPath p - _ -> [] - - ioErrorHandler :: IOException -> IO [FilePath] - ioErrorHandler _e = return [] diff --git a/cabal/cabal-install/Distribution/Solver/Types/Progress.hs b/cabal/cabal-install/Distribution/Solver/Types/Progress.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Solver/Types/Progress.hs +++ /dev/null @@ -1,49 +0,0 @@ -module Distribution.Solver.Types.Progress - ( Progress(..) - , foldProgress - ) where - -import Prelude () -import Distribution.Solver.Compat.Prelude hiding (fail) - --- | A type to represent the unfolding of an expensive long running --- calculation that may fail. We may get intermediate steps before the final --- result which may be used to indicate progress and\/or logging messages. --- -data Progress step fail done = Step step (Progress step fail done) - | Fail fail - | Done done - --- 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) - --- | Consume a 'Progress' calculation. Much like 'foldr' for lists but with two --- base cases, one for a final result and one for failure. --- --- Eg to convert into a simple 'Either' result use: --- --- > foldProgress (flip const) Left Right --- -foldProgress :: (step -> a -> a) -> (fail -> a) -> (done -> a) - -> Progress step fail done -> a -foldProgress step 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 Applicative (Progress step fail) where - pure a = Done a - p <*> x = foldProgress Step Fail (flip fmap x) p - -instance Monoid fail => Alternative (Progress step fail) where - empty = Fail mempty - p <|> q = foldProgress Step (const q) Done p diff --git a/cabal/cabal-install/Distribution/Solver/Types/ResolverPackage.hs b/cabal/cabal-install/Distribution/Solver/Types/ResolverPackage.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Solver/Types/ResolverPackage.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Solver.Types.ResolverPackage - ( ResolverPackage(..) - , resolverPackageLibDeps - , resolverPackageExeDeps - ) where - -import Distribution.Solver.Compat.Prelude -import Prelude () - -import Distribution.Solver.Types.InstSolverPackage -import Distribution.Solver.Types.SolverId -import Distribution.Solver.Types.SolverPackage -import qualified Distribution.Solver.Types.ComponentDeps as CD - -import Distribution.Compat.Graph (IsNode(..)) -import Distribution.Package (Package(..), HasUnitId(..)) -import Distribution.Simple.Utils (ordNub) - --- | The dependency resolver picks either pre-existing installed packages --- or it picks source packages along with package configuration. --- --- This is like the 'InstallPlan.PlanPackage' but with fewer cases. --- -data ResolverPackage loc = PreExisting InstSolverPackage - | Configured (SolverPackage loc) - deriving (Eq, Show, Generic) - -instance Binary loc => Binary (ResolverPackage loc) -instance Structured loc => Structured (ResolverPackage loc) - -instance Package (ResolverPackage loc) where - packageId (PreExisting ipkg) = packageId ipkg - packageId (Configured spkg) = packageId spkg - -resolverPackageLibDeps :: ResolverPackage loc -> CD.ComponentDeps [SolverId] -resolverPackageLibDeps (PreExisting ipkg) = instSolverPkgLibDeps ipkg -resolverPackageLibDeps (Configured spkg) = solverPkgLibDeps spkg - -resolverPackageExeDeps :: ResolverPackage loc -> CD.ComponentDeps [SolverId] -resolverPackageExeDeps (PreExisting ipkg) = instSolverPkgExeDeps ipkg -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) - -- Use dependencies for ALL components - nodeNeighbors pkg = - ordNub $ CD.flatDeps (resolverPackageLibDeps pkg) ++ - CD.flatDeps (resolverPackageExeDeps pkg) diff --git a/cabal/cabal-install/Distribution/Solver/Types/Settings.hs b/cabal/cabal-install/Distribution/Solver/Types/Settings.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Solver/Types/Settings.hs +++ /dev/null @@ -1,101 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Distribution.Solver.Types.Settings - ( ReorderGoals(..) - , IndependentGoals(..) - , MinimizeConflictSet(..) - , AvoidReinstalls(..) - , ShadowPkgs(..) - , StrongFlags(..) - , AllowBootLibInstalls(..) - , OnlyConstrained(..) - , EnableBackjumping(..) - , CountConflicts(..) - , FineGrainedConflicts(..) - , SolveExecutables(..) - ) where - -import Distribution.Solver.Compat.Prelude -import Prelude () - -import Distribution.Simple.Setup ( BooleanFlag(..) ) -import Distribution.Pretty ( Pretty(pretty) ) -import Distribution.Parsec ( Parsec(parsec) ) - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as PP - -newtype ReorderGoals = ReorderGoals Bool - deriving (BooleanFlag, Eq, Generic, Show) - -newtype CountConflicts = CountConflicts Bool - deriving (BooleanFlag, Eq, Generic, Show) - -newtype FineGrainedConflicts = FineGrainedConflicts Bool - deriving (BooleanFlag, Eq, Generic, Show) - -newtype MinimizeConflictSet = MinimizeConflictSet Bool - deriving (BooleanFlag, Eq, Generic, Show) - -newtype IndependentGoals = IndependentGoals Bool - deriving (BooleanFlag, Eq, Generic, Show) - -newtype AvoidReinstalls = AvoidReinstalls Bool - deriving (BooleanFlag, Eq, Generic, Show) - -newtype ShadowPkgs = ShadowPkgs Bool - deriving (BooleanFlag, Eq, Generic, Show) - -newtype StrongFlags = StrongFlags Bool - deriving (BooleanFlag, Eq, Generic, Show) - -newtype AllowBootLibInstalls = AllowBootLibInstalls Bool - deriving (BooleanFlag, Eq, Generic, Show) - --- | Should we consider all packages we know about, or only those that --- have constraints explicitly placed on them or which are goals? -data OnlyConstrained - = OnlyConstrainedNone - | OnlyConstrainedAll - deriving (Eq, Generic, Show) - -newtype EnableBackjumping = EnableBackjumping Bool - deriving (BooleanFlag, Eq, Generic, Show) - -newtype SolveExecutables = SolveExecutables Bool - deriving (BooleanFlag, Eq, Generic, Show) - -instance Binary ReorderGoals -instance Binary CountConflicts -instance Binary FineGrainedConflicts -instance Binary IndependentGoals -instance Binary MinimizeConflictSet -instance Binary AvoidReinstalls -instance Binary ShadowPkgs -instance Binary StrongFlags -instance Binary AllowBootLibInstalls -instance Binary OnlyConstrained -instance Binary SolveExecutables - -instance Structured ReorderGoals -instance Structured CountConflicts -instance Structured FineGrainedConflicts -instance Structured IndependentGoals -instance Structured MinimizeConflictSet -instance Structured AvoidReinstalls -instance Structured ShadowPkgs -instance Structured StrongFlags -instance Structured AllowBootLibInstalls -instance Structured OnlyConstrained -instance Structured SolveExecutables - -instance Pretty OnlyConstrained where - pretty OnlyConstrainedAll = PP.text "all" - pretty OnlyConstrainedNone = PP.text "none" - -instance Parsec OnlyConstrained where - parsec = P.choice - [ P.string "all" >> return OnlyConstrainedAll - , P.string "none" >> return OnlyConstrainedNone - ] - diff --git a/cabal/cabal-install/Distribution/Solver/Types/SolverId.hs b/cabal/cabal-install/Distribution/Solver/Types/SolverId.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Solver/Types/SolverId.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Solver.Types.SolverId - ( SolverId(..) - ) - -where - -import Distribution.Solver.Compat.Prelude -import Prelude () - -import Distribution.Package (PackageId, Package(..), UnitId) - --- | 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 } - deriving (Eq, Ord, Generic) - -instance Binary SolverId -instance Structured SolverId - -instance Show SolverId where - show = show . solverSrcId - -instance Package SolverId where - packageId = solverSrcId diff --git a/cabal/cabal-install/Distribution/Solver/Types/SolverPackage.hs b/cabal/cabal-install/Distribution/Solver/Types/SolverPackage.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Solver/Types/SolverPackage.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Solver.Types.SolverPackage - ( SolverPackage(..) - ) where - -import Distribution.Solver.Compat.Prelude -import Prelude () - -import Distribution.Package ( Package(..) ) -import Distribution.PackageDescription ( FlagAssignment ) -import Distribution.Solver.Types.ComponentDeps ( ComponentDeps ) -import Distribution.Solver.Types.OptionalStanza -import Distribution.Solver.Types.SolverId -import Distribution.Solver.Types.SourcePackage - --- | A 'SolverPackage' is a package specified by the dependency solver. --- It will get elaborated into a 'ConfiguredPackage' or even an --- 'ElaboratedConfiguredPackage'. --- --- NB: 'SolverPackage's are essentially always with 'UnresolvedPkgLoc', --- but for symmetry we have the parameter. (Maybe it can be removed.) --- -data SolverPackage loc = SolverPackage { - solverPkgSource :: SourcePackage loc, - solverPkgFlags :: FlagAssignment, - solverPkgStanzas :: [OptionalStanza], - solverPkgLibDeps :: ComponentDeps [SolverId], - solverPkgExeDeps :: ComponentDeps [SolverId] - } - deriving (Eq, Show, Generic) - -instance Binary loc => Binary (SolverPackage loc) -instance Structured loc => Structured (SolverPackage loc) - -instance Package (SolverPackage loc) where - packageId = packageId . solverPkgSource diff --git a/cabal/cabal-install/Distribution/Solver/Types/SourcePackage.hs b/cabal/cabal-install/Distribution/Solver/Types/SourcePackage.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Solver/Types/SourcePackage.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveDataTypeable #-} -module Distribution.Solver.Types.SourcePackage - ( PackageDescriptionOverride - , SourcePackage(..) - ) where - -import Distribution.Solver.Compat.Prelude -import Prelude () - -import Distribution.Package - ( PackageId, Package(..) ) -import Distribution.PackageDescription - ( GenericPackageDescription(..) ) - -import Data.ByteString.Lazy (ByteString) - --- | A package description along with the location of the package sources. --- -data SourcePackage loc = SourcePackage - { srcpkgPackageId :: PackageId - , srcpkgDescription :: GenericPackageDescription - -- ^ Note, this field is lazy, e.g. when reading in hackage index - -- we parse only what we need, not whole index. - , srcpkgSource :: loc - , srcpkgDescrOverride :: PackageDescriptionOverride - } - deriving (Eq, Show, Generic, Typeable) - -instance Binary loc => Binary (SourcePackage loc) -instance Structured loc => Structured (SourcePackage loc) - -instance Package (SourcePackage a) where packageId = srcpkgPackageId - --- | We sometimes need to override the .cabal file in the tarball with --- the newer one from the package index. -type PackageDescriptionOverride = Maybe ByteString diff --git a/cabal/cabal-install/Distribution/Solver/Types/Variable.hs b/cabal/cabal-install/Distribution/Solver/Types/Variable.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Solver/Types/Variable.hs +++ /dev/null @@ -1,15 +0,0 @@ -module Distribution.Solver.Types.Variable where - -import Prelude (Eq, Show) - -import Distribution.Solver.Types.OptionalStanza - -import Distribution.PackageDescription (FlagName) - --- | Variables used by the dependency solver. This type is similar to the --- internal 'Var' type. -data Variable qpn = - PackageVar qpn - | FlagVar qpn FlagName - | StanzaVar qpn OptionalStanza - deriving (Eq, Show) diff --git a/cabal/cabal-install/LICENSE b/cabal/cabal-install/LICENSE --- a/cabal/cabal-install/LICENSE +++ b/cabal/cabal-install/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2003-2020, Cabal Development Team. +Copyright (c) 2003-2022, Cabal Development Team. See the AUTHORS file for the full list of copyright holders. See */LICENSE for the copyright holders of the subcomponents. diff --git a/cabal/cabal-install/README.md b/cabal/cabal-install/README.md --- a/cabal/cabal-install/README.md +++ b/cabal/cabal-install/README.md @@ -4,152 +4,9 @@ See the [Cabal web site] for more information. The `cabal-install` package provides a command line tool named `cabal`. -It uses the [Cabal] library and provides a user interface to the -Cabal/[Hackage] build automation and package management system. It can +It uses the Cabal library and provides a user interface to the +Cabal/Hackage build automation and package management system. It can build and install both local and remote packages, including dependencies. [Cabal web site]: http://www.haskell.org/cabal/ -[Cabal]: ../Cabal/README.md - -Installing the `cabal` command-line tool -======================================== - -The `cabal-install` package requires a number of other packages, most of -which come with a standard GHC installation. It requires the [network] -package, which is sometimes packaged separately by Linux distributions; -for example, on Debian or Ubuntu, it is located in the -"libghc6-network-dev" package. - -`cabal` requires a few other Haskell packages that are not always -installed. The exact list is specified in the [.cabal] file or in the -[bootstrap.sh] file. All these packages are available from [Hackage]. - -Note that on some Unix systems you may need to install an additional -zlib development package using your system package manager; for example, -on Debian or Ubuntu, it is located in the "zlib1g-dev" package; on -Fedora, it is located in the "zlib-devel" package. It is required -because the Haskell zlib package uses the system zlib C library and -header files. - -The `cabal-install` package is now part of the [Haskell Platform], so you -do not usually need to install it separately. However, if you are -starting from a minimal GHC installation, you need to install -`cabal-install` manually. Since it is an ordinary Cabal package, -`cabal-install` can be built the standard way; to facilitate this, the -process has been partially automated. It is described below. - -[.cabal]: cabal-install.cabal -[network]: http://hackage.haskell.org/package/network -[Haskell Platform]: http://www.haskell.org/platform/ - -Quick start on Unix-like systems --------------------------------- - -As a convenience for users on Unix-like systems, there is a -[bootstrap.sh] script that will download and install each of -`cabal-install`'s dependencies in turn. - - $ ./bootstrap.sh - -It will download and install the dependencies. The script will install the -library packages (vanilla, profiling and shared) into `$HOME/.cabal/` and the -`cabal` program into `$HOME/.cabal/bin/`. If you don't want to install profiling -and shared versions of the libraries, use - - $ EXTRA_CONFIGURE_OPTS="" ./bootstrap.sh - -You then have the choice either to place `$HOME/.cabal/bin` on your -`$PATH` or move the `cabal` program to somewhere on your `$PATH`. Next, -you can get the latest list of packages by running: - - $ cabal update - -This will also create a default configuration file, if it does not -already exist, at `$HOME/.cabal/config`. - -By default, `cabal` will install programs to `$HOME/.cabal/bin`. If you -do not want to add this directory to your `$PATH`, you can change -the setting in the config file; for example, you could use the -following: - - installdir: $HOME/bin - - -Quick start on Windows systems ------------------------------- - -For Windows users, a precompiled program ([cabal.exe]) is provided. -Download and put it somewhere on your `%PATH%` (for example, -`C:\Program Files\Haskell\bin`.) - -Next, you can get the latest list of packages by running: - - $ cabal update - -This will also create a default configuration file (if it does not -already exist) at -`C:\Documents and Settings\%USERNAME%\Application Data\cabal\config`. - -[cabal.exe]: http://www.haskell.org/cabal/release/cabal-install-latest/ - -Using `cabal` -============= - -There are two sets of commands: commands for working with a local -project build tree and those for working with packages distributed -from [Hackage]. - -For the list of the full set of commands and flags for each command, -run: - - $ cabal help - - -Commands for developers for local build trees ---------------------------------------------- - -The commands for local project build trees are almost the same as the -`runghc Setup` command-line interface you may already be familiar with. -In particular, it has the following commands: - - * `cabal configure` - * `cabal build` - * `cabal haddock` - * `cabal clean` - * `cabal sdist` - -The `install` command is somewhat different; it is an all-in-one -operation. If you run `cabal install` in your build tree, it will -configure, build, and install. It takes all the flags that `configure` -takes such as `--global` and `--prefix`. - -In addition, `cabal` will download and install any dependencies that are -not already installed. It can also rebuild packages to ensure a -consistent set of dependencies. - - -Commands for released Hackage packages --------------------------------------- - - $ cabal update - -This command gets the latest list of packages from the [Hackage] server. -On occasion, this command must be run manually--for instance, if you -want to install a newly released package. - - $ cabal install xmonad - -This command installs one or more named packages, and all their -dependencies, from Hackage. By default, it installs the latest available -version; however, you may specify exact versions or version ranges. For -example, `cabal install alex-2.2` or `cabal install parsec < 3`. - - $ cabal list xml - -This does a search of the installed and available packages. It does a -case-insensitive substring match on the package name. - - -[Hackage]: http://hackage.haskell.org -[bootstrap.sh]: bootstrap.sh diff --git a/cabal/cabal-install/bootstrap.sh b/cabal/cabal-install/bootstrap.sh deleted file mode 100644 --- a/cabal/cabal-install/bootstrap.sh +++ /dev/null @@ -1,558 +0,0 @@ -#!/bin/sh -set -e - -# A script to bootstrap cabal-install. - -# It works by downloading and installing the Cabal, zlib and -# HTTP packages. It then installs cabal-install itself. -# It expects to be run inside the cabal-install directory. - -# Install settings, you can override these by setting environment vars. E.g. if -# you don't want profiling and dynamic versions of libraries to be installed in -# addition to vanilla, run 'EXTRA_CONFIGURE_OPTS="" ./bootstrap.sh' - -echo "DON'T USE THIS SCRIPT IF YOU HAVE other recent cabal-install INSTALLED" -echo "THIS SCRIPT IS MADE FOR BOOTSTRAPPING cabal-install ON NEW ARCHITECTURES" - -#VERBOSE -DEFAULT_CONFIGURE_OPTS="--enable-library-profiling --enable-shared" -EXTRA_CONFIGURE_OPTS=${EXTRA_CONFIGURE_OPTS-$DEFAULT_CONFIGURE_OPTS} -#EXTRA_BUILD_OPTS -#EXTRA_INSTALL_OPTS - -die() { - printf "\nError during cabal-install bootstrap:\n%s\n" "$1" >&2 - exit 2 -} - -# programs, you can override these by setting environment vars -GHC="${GHC:-ghc}" -GHC_PKG="${GHC_PKG:-ghc-pkg}" -GHC_VER="$(${GHC} --numeric-version)" -HADDOCK=${HADDOCK:-haddock} -WGET="${WGET:-wget}" -CURL="${CURL:-curl}" -FETCH="${FETCH:-fetch}" -TAR="${TAR:-tar}" -GZIP_PROGRAM="${GZIP_PROGRAM:-gzip}" - -# The variable SCOPE_OF_INSTALLATION can be set on the command line to -# use/install the libraries needed to build cabal-install to a custom package -# database instead of the user or global package database. -# -# Example: -# -# $ ghc-pkg init /my/package/database -# $ SCOPE_OF_INSTALLATION='--package-db=/my/package/database' ./bootstrap.sh -# -# You can also combine SCOPE_OF_INSTALLATION with PREFIX: -# -# $ ghc-pkg init /my/prefix/packages.conf.d -# $ SCOPE_OF_INSTALLATION='--package-db=/my/prefix/packages.conf.d' \ -# PREFIX=/my/prefix ./bootstrap.sh -# -# If you use the --global,--user or --sandbox arguments, this will -# override the SCOPE_OF_INSTALLATION setting and not use the package -# database you pass in the SCOPE_OF_INSTALLATION variable. - -SCOPE_OF_INSTALLATION="${SCOPE_OF_INSTALLATION:---user}" -DEFAULT_PREFIX="${HOME}/.cabal" - -TMPDIR=$(mktemp -d -p /tmp -t cabal-XXXXXXX || mktemp -d -t cabal-XXXXXXX) -export TMPDIR - -# Check for a C compiler, using user-set $CC, if any, first. -for c in $CC gcc clang cc icc; do - $c --version 1>/dev/null 2>&1 && CC=$c && - echo "Using $c for C compiler. If this is not what you want, set CC." >&2 && - break -done - -# None found. -[ -"$CC"- = -""- ] && die 'C compiler not found (or could not be run). - If a C compiler is installed make sure it is on your PATH, or set $CC.' - -# Find the correct linker/linker-wrapper. -# -# See https://github.com/haskell/cabal/pull/4187#issuecomment-269074153. -LINK="$(for link in collect2 ld; do - if [ $($CC -print-prog-name=$link) = $link ] - then - continue - else - $CC -print-prog-name=$link && break - fi - done)" - -# Fall back to "ld"... might work. -[ -$LINK- = -""- ] && LINK=ld - -# And finally, see if we can compile and link something. - echo 'int main(){}' | $CC -xc - -o /dev/null || - die "C compiler and linker could not compile a simple test program. - Please check your toolchain." - -# Warn that were's overriding $LD if set (if you want). -[ -"$LD"- != -""- ] && [ -"$LD"- != -"$LINK"- ] && - echo "Warning: value set in $LD is not the same as C compiler's $LINK." >&2 - echo "Using $LINK instead." >&2 - -# Set LD, overriding environment if necessary. -export LD=$LINK - -# Check we're in the right directory, etc. -grep "cabal-install" ./cabal-install.cabal > /dev/null 2>&1 || - die "The bootstrap.sh script must be run in the cabal-install directory" - -${GHC} --numeric-version > /dev/null 2>&1 || - die "${GHC} not found (or could not be run). - If ghc is installed, make sure it is on your PATH, - or set the GHC and GHC_PKG vars." - -${GHC_PKG} --version > /dev/null 2>&1 || die "${GHC_PKG} not found." - -GHC_PKG_VER="$(${GHC_PKG} --version | cut -d' ' -f 5)" - -[ ${GHC_VER} = ${GHC_PKG_VER} ] || - die "Version mismatch between ${GHC} and ${GHC_PKG}. - If you set the GHC variable then set GHC_PKG too." - -JOBS="-j1" -while [ "$#" -gt 0 ]; do - case "${1}" in - "--user") - SCOPE_OF_INSTALLATION="${1}" - shift;; - "--global") - SCOPE_OF_INSTALLATION="${1}" - DEFAULT_PREFIX="/usr/local" - shift;; - "--sandbox") - shift - # check if there is another argument which doesn't start with -- - if [ "$#" -le 0 ] || [ ! -z $(echo "${1}" | grep "^--") ] - then - SANDBOX=".cabal-sandbox" - else - SANDBOX="${1}" - shift - fi;; - "--no-doc") - NO_DOCUMENTATION=1 - shift;; - "--no-install") - NO_INSTALL=1 - shift;; - "-j"|"--jobs") - shift - # check if there is another argument which doesn't start with - or -- - if [ "$#" -le 0 ] \ - || [ ! -z $(echo "${1}" | grep "^-") ] \ - || [ ! -z $(echo "${1}" | grep "^--") ] - then - JOBS="-j" - else - JOBS="-j${1}" - shift - fi;; - *) - echo "Unknown argument or option, quitting: ${1}" - echo "usage: bootstrap.sh [OPTION]" - echo - echo "options:" - echo " -j/--jobs Number of concurrent workers to use (Default: 1)" - echo " -j without an argument will use all available cores" - echo " --user Install for the local user (default)" - echo " --global Install systemwide (must be run as root)" - echo " --no-doc Do not generate documentation for installed"\ - "packages" - echo " --sandbox Install to a sandbox in the default location"\ - "(.cabal-sandbox)" - echo " --sandbox path Install to a sandbox located at path" - exit;; - esac -done - -# Do not try to use -j with GHC 7.8 or older -case $GHC_VER in - 7.4*|7.6*|7.8*) - JOBS="" - ;; - *) - ;; -esac - -abspath () { case "$1" in /*)printf "%s\n" "$1";; *)printf "%s\n" "$PWD/$1";; - esac; } - -if [ ! -z "$SANDBOX" ] -then # set up variables for sandbox bootstrap - # Make the sandbox path absolute since it will be used from - # different working directories when the dependency packages are - # installed. - SANDBOX=$(abspath "$SANDBOX") - # Get the name of the package database which cabal sandbox would use. - GHC_ARCH=$(ghc --info | - sed -n 's/.*"Target platform".*"\([^-]\+\)-[^-]\+-\([^"]\+\)".*/\1-\2/p') - PACKAGEDB="$SANDBOX/${GHC_ARCH}-ghc-${GHC_VER}-packages.conf.d" - # Assume that if the directory is already there, it is already a - # package database. We will get an error immediately below if it - # isn't. Uses -r to try to be compatible with Solaris, and allow - # symlinks as well as a normal dir/file. - [ ! -r "$PACKAGEDB" ] && ghc-pkg init "$PACKAGEDB" - PREFIX="$SANDBOX" - SCOPE_OF_INSTALLATION="--package-db=$PACKAGEDB" - echo Bootstrapping in sandbox at \'$SANDBOX\'. -fi - -# Check for haddock unless no documentation should be generated. -if [ ! ${NO_DOCUMENTATION} ] -then - ${HADDOCK} --version > /dev/null 2>&1 || die "${HADDOCK} not found." -fi - -PREFIX=${PREFIX:-${DEFAULT_PREFIX}} - -# Versions of the packages to install. -# The version regex says what existing installed versions are ok. -PARSEC_VER="3.1.13.0"; PARSEC_VER_REGEXP="[3]\.[1]\." - # >= 3.1 && < 3.2 -DEEPSEQ_VER="1.4.3.0"; DEEPSEQ_VER_REGEXP="1\.[1-9]\." - # >= 1.1 && < 2 -BINARY_VER="0.8.5.1"; BINARY_VER_REGEXP="[0]\.[78]\." - # >= 0.7 && < 0.9 -TEXT_VER="1.2.3.0"; TEXT_VER_REGEXP="[1]\.[2]\." - # >= 1.2 && < 1.3 -NETWORK_URI_VER="2.6.1.0"; NETWORK_URI_VER_REGEXP="2\.6\.(0\.[2-9]|[1-9])" - # >= 2.6.0.2 && < 2.7 -NETWORK_VER="2.7.0.0"; NETWORK_VER_REGEXP="2\.[0-7]\." - # >= 2.0 && < 2.7 -CABAL_VER="3.3.0.0"; CABAL_VER_REGEXP="3\.3\.[0-9]" - # >= 3.3 && < 3.4 -TRANS_VER="0.5.5.0"; TRANS_VER_REGEXP="0\.[45]\." - # >= 0.2.* && < 0.6 -MTL_VER="2.2.2"; MTL_VER_REGEXP="[2]\." - # >= 2.0 && < 3 -HTTP_VER="4000.3.14"; HTTP_VER_REGEXP="4000\.(2\.([5-9]|1[0-9]|2[0-9])|3\.?)" - # >= 4000.2.5 < 4000.4 -ZLIB_VER="0.6.2.1"; ZLIB_VER_REGEXP="(0\.5\.([3-9]|1[0-9])|0\.6)" - # >= 0.5.3 && <= 0.7 -TIME_VER="1.9.3" TIME_VER_REGEXP="1\.[1-9]\.?" - # >= 1.1 && < 1.10 -RANDOM_VER="1.1" RANDOM_VER_REGEXP="1\.[01]\.?" - # >= 1 && < 1.2 -STM_VER="2.4.5.0"; STM_VER_REGEXP="2\." - # == 2.* -HASHABLE_VER="1.3.0.0"; HASHABLE_VER_REGEXP="1\." - # 1.* -ASYNC_VER="2.2.2"; ASYNC_VER_REGEXP="2\." - # 2.* -BASE16_BYTESTRING_VER="0.1.1.6"; BASE16_BYTESTRING_VER_REGEXP="0\.1" - # 0.1.* -BASE64_BYTESTRING_VER="1.0.0.1"; BASE64_BYTESTRING_VER_REGEXP="1\." - # >=1.0 -CRYPTOHASH_SHA256_VER="0.11.101.0"; CRYPTOHASH_SHA256_VER_REGEXP="0\.11\.?" - # 0.11.* -RESOLV_VER="0.1.2.0"; RESOLV_VER_REGEXP="0\.1\.[2-9]" - # >= 0.1.2 && < 0.2 -MINTTY_VER="0.1.2"; MINTTY_VER_REGEXP="0\.1\.?" - # 0.1.* -ECHO_VER="0.1.3"; ECHO_VER_REGEXP="0\.1\.[3-9]" - # >= 0.1.3 && < 0.2 -EDIT_DISTANCE_VER="0.2.2.1"; EDIT_DISTANCE_VER_REGEXP="0\.2\.2\.?" - # 0.2.2.* -ED25519_VER="0.0.5.0"; ED25519_VER_REGEXP="0\.0\.?" - # 0.0.* -HACKAGE_SECURITY_VER="0.6.0.1"; HACKAGE_SECURITY_VER_REGEXP="0\.6\." - # >= 0.6.0.0 && < 0.7 -TAR_VER="0.5.1.1"; TAR_VER_REGEXP="0\.5\.([1-9]|1[0-9]|0\.[3-9]|0\.1[0-9])\.?" - # >= 0.5.0.3 && < 0.6 -DIGEST_VER="0.0.1.2"; DIGEST_REGEXP="0\.0\.(1\.[2-9]|[2-9]\.?)" - # >= 0.0.1.2 && < 0.1 -LUKKO_VER="0.1.1"; LUKKO_VER_REGEXP="0\.1\.[1-9]" - # >= 0.1.1 && <0.2 -REGEX_POSIX_VER="0.96.0.0"; REGEX_POSIX_REGEXP="0\.96\.[0-9]" -REGEX_BASE_VER="0.94.0.0"; REGEX_BASE_REGEXP="0\.94\.[0-9]" - -HACKAGE_URL="https://hackage.haskell.org/package" - -# Haddock fails for hackage-security for GHC <8, -# c.f. https://github.com/well-typed/hackage-security/issues/149 -NO_DOCS_PACKAGES_VER_REGEXP="hackage-security-0\.5\.[0-9]+\.[0-9]+" - -# Cache the list of packages: -echo "Checking installed packages for ghc-${GHC_VER}..." -${GHC_PKG} list --global ${SCOPE_OF_INSTALLATION} > ghc-pkg.list || - die "running '${GHC_PKG} list' failed" -trap "rm ghc-pkg.list" EXIT - -# Will we need to install this package, or is a suitable version installed? -need_pkg () { - PKG=$1 - VER_MATCH=$2 - if egrep " ${PKG}-${VER_MATCH}" ghc-pkg.list > /dev/null 2>&1 - then - return 1; - else - return 0; - fi - #Note: we cannot use "! grep" here as Solaris 9 /bin/sh doesn't like it. -} - -info_pkg () { - PKG=$1 - VER=$2 - VER_MATCH=$3 - - if need_pkg ${PKG} ${VER_MATCH} - then - if [ -d "${PKG}-${VER}" ] - then - echo "${PKG}-${VER} will be installed from local directory." - elif [ -r "${PKG}-${VER}.tar.gz" ] - then - echo "${PKG}-${VER} will be installed from local tarball." - else - echo "${PKG}-${VER} will be downloaded and installed." - fi - else - echo "${PKG} is already installed and the version is ok." - fi -} - -fetch_pkg () { - PKG=$1 - VER=$2 - - URL_PKG=${HACKAGE_URL}/${PKG}-${VER}/${PKG}-${VER}.tar.gz - URL_PKGDESC=${HACKAGE_URL}/${PKG}-${VER}/${PKG}.cabal - if which ${CURL} > /dev/null - then - ${CURL} -L --fail -C - -O ${URL_PKG} || die "Failed to download ${PKG}." - ${CURL} -L --fail -C - -O ${URL_PKGDESC} \ - || die "Failed to download '${PKG}.cabal'." - elif which ${WGET} > /dev/null - then - ${WGET} -c ${URL_PKG} || die "Failed to download ${PKG}." - ${WGET} -c ${URL_PKGDESC} || die "Failed to download '${PKG}.cabal'." - elif which ${FETCH} > /dev/null - then - ${FETCH} ${URL_PKG} || die "Failed to download ${PKG}." - ${FETCH} ${URL_PKGDESC} || die "Failed to download '${PKG}.cabal'." - else - die "Failed to find a downloader. 'curl', 'wget' or 'fetch' is required." - fi - [ -f "${PKG}-${VER}.tar.gz" ] || - die "Downloading ${URL_PKG} did not create ${PKG}-${VER}.tar.gz" - [ -f "${PKG}.cabal" ] || - die "Downloading ${URL_PKGDESC} did not create ${PKG}.cabal" - mv "${PKG}.cabal" "${PKG}.cabal.hackage" -} - -unpack_pkg () { - PKG=$1 - VER=$2 - - rm -rf "${PKG}-${VER}.tar" "${PKG}-${VER}" - ${GZIP_PROGRAM} -d < "${PKG}-${VER}.tar.gz" | ${TAR} -xf - - [ -d "${PKG}-${VER}" ] || die "Failed to unpack ${PKG}-${VER}.tar.gz" - cp "${PKG}.cabal.hackage" "${PKG}-${VER}/${PKG}.cabal" -} - -install_pkg () { - [ ${NO_INSTALL} ] && return 0 - - PKG=$1 - VER=$2 - - [ -x Setup ] && ./Setup clean - [ -f Setup ] && rm Setup - - PKG_DBS=$(printf '%s\n' "${SCOPE_OF_INSTALLATION}" \ - | sed -e 's/--package-db/-package-db/' \ - -e 's/--global/-global-package-db/' \ - -e 's/--user/-user-package-db/') - - ${GHC} --make ${JOBS} ${PKG_DBS} Setup -o Setup -XRank2Types -XFlexibleContexts || - die "Compiling the Setup script failed." - - [ -x Setup ] || die "The Setup script does not exist or cannot be run" - - args="${SCOPE_OF_INSTALLATION} --prefix=${PREFIX} --with-compiler=${GHC}" - args="$args --with-hc-pkg=${GHC_PKG} --with-gcc=${CC} --with-ld=${LD}" - args="$args ${EXTRA_CONFIGURE_OPTS} ${VERBOSE}" - - ./Setup configure $args || die "Configuring the ${PKG} package failed." - - ./Setup build ${JOBS} ${EXTRA_BUILD_OPTS} ${VERBOSE} || - die "Building the ${PKG} package failed." - - if [ ! ${NO_DOCUMENTATION} ] - then - if echo "${PKG}-${VER}" | egrep ${NO_DOCS_PACKAGES_VER_REGEXP} \ - > /dev/null 2>&1 - then - echo "Skipping documentation for the ${PKG} package." - else - ./Setup haddock --with-ghc=${GHC} --with-haddock=${HADDOCK} ${VERBOSE} || - die "Documenting the ${PKG} package failed." - fi - fi - - ./Setup install ${EXTRA_INSTALL_OPTS} ${VERBOSE} || - die "Installing the ${PKG} package failed." -} - -do_pkg () { - PKG=$1 - VER=$2 - VER_MATCH=$3 - - if need_pkg ${PKG} ${VER_MATCH} - then - echo - if [ -d "${PKG}-${VER}" ] - then - echo "Using local directory for ${PKG}-${VER}." - else - if [ -r "${PKG}-${VER}.tar.gz" ] - then - echo "Using local tarball for ${PKG}-${VER}." - else - echo "Downloading ${PKG}-${VER}..." - fetch_pkg ${PKG} ${VER} - fi - unpack_pkg "${PKG}" "${VER}" - fi - (cd "${PKG}-${VER}" && install_pkg ${PKG} ${VER}) - fi -} - -# If we're bootstrapping from a Git clone, install the local version of Cabal -# instead of downloading one from Hackage. -do_Cabal_pkg () { - if [ -d "../.git" ] - then - if need_pkg "Cabal" ${CABAL_VER_REGEXP} - then - echo "Cabal-${CABAL_VER} will be installed from the local Git clone." - (cd ../Cabal && install_pkg ${CABAL_VER} ${CABAL_VER_REGEXP}) - else - echo "Cabal is already installed and the version is ok." - fi - else - info_pkg "Cabal" ${CABAL_VER} ${CABAL_VER_REGEXP} - do_pkg "Cabal" ${CABAL_VER} ${CABAL_VER_REGEXP} - fi -} - -# Actually do something! - -info_pkg "deepseq" ${DEEPSEQ_VER} ${DEEPSEQ_VER_REGEXP} -info_pkg "binary" ${BINARY_VER} ${BINARY_VER_REGEXP} -info_pkg "time" ${TIME_VER} ${TIME_VER_REGEXP} -info_pkg "transformers" ${TRANS_VER} ${TRANS_VER_REGEXP} -info_pkg "mtl" ${MTL_VER} ${MTL_VER_REGEXP} -info_pkg "text" ${TEXT_VER} ${TEXT_VER_REGEXP} -info_pkg "parsec" ${PARSEC_VER} ${PARSEC_VER_REGEXP} -info_pkg "network-uri" ${NETWORK_URI_VER} ${NETWORK_URI_VER_REGEXP} -info_pkg "network" ${NETWORK_VER} ${NETWORK_VER_REGEXP} -info_pkg "HTTP" ${HTTP_VER} ${HTTP_VER_REGEXP} -info_pkg "zlib" ${ZLIB_VER} ${ZLIB_VER_REGEXP} -info_pkg "random" ${RANDOM_VER} ${RANDOM_VER_REGEXP} -info_pkg "stm" ${STM_VER} ${STM_VER_REGEXP} -info_pkg "hashable" ${HASHABLE_VER} ${HASHABLE_VER_REGEXP} -info_pkg "async" ${ASYNC_VER} ${ASYNC_VER_REGEXP} -info_pkg "base16-bytestring" ${BASE16_BYTESTRING_VER} \ - ${BASE16_BYTESTRING_VER_REGEXP} -info_pkg "base64-bytestring" ${BASE64_BYTESTRING_VER} \ - ${BASE64_BYTESTRING_VER_REGEXP} -info_pkg "cryptohash-sha256" ${CRYPTOHASH_SHA256_VER} \ - ${CRYPTOHASH_SHA256_VER_REGEXP} -info_pkg "resolv" ${RESOLV_VER} ${RESOLV_VER_REGEXP} -info_pkg "mintty" ${MINTTY_VER} ${MINTTY_VER_REGEXP} -info_pkg "echo" ${ECHO_VER} ${ECHO_VER_REGEXP} -info_pkg "edit-distance" ${EDIT_DISTANCE_VER} ${EDIT_DISTANCE_VER_REGEXP} -info_pkg "ed25519" ${ED25519_VER} ${ED25519_VER_REGEXP} -info_pkg "tar" ${TAR_VER} ${TAR_VER_REGEXP} -info_pkg "digest" ${DIGEST_VER} ${DIGEST_REGEXP} -info_pkg "lukko" ${LUKKO_VER} ${LUKKO_REGEXP} -info_pkg "regex-base" ${REGEX_BASE_VER} ${REGEX_BASE_REGEXP} -info_pkg "regex-posix" ${REGEX_POSIX_VER} ${REGEX_POSIX_REGEXP} -info_pkg "hackage-security" ${HACKAGE_SECURITY_VER} \ - ${HACKAGE_SECURITY_VER_REGEXP} - -do_pkg "deepseq" ${DEEPSEQ_VER} ${DEEPSEQ_VER_REGEXP} -do_pkg "binary" ${BINARY_VER} ${BINARY_VER_REGEXP} -do_pkg "time" ${TIME_VER} ${TIME_VER_REGEXP} - -# Cabal might depend on these -do_pkg "transformers" ${TRANS_VER} ${TRANS_VER_REGEXP} -do_pkg "mtl" ${MTL_VER} ${MTL_VER_REGEXP} -do_pkg "text" ${TEXT_VER} ${TEXT_VER_REGEXP} -do_pkg "parsec" ${PARSEC_VER} ${PARSEC_VER_REGEXP} - -# Install the Cabal library from the local Git clone if possible. -do_Cabal_pkg - -do_pkg "network-uri" ${NETWORK_URI_VER} ${NETWORK_URI_VER_REGEXP} -do_pkg "network" ${NETWORK_VER} ${NETWORK_VER_REGEXP} -do_pkg "HTTP" ${HTTP_VER} ${HTTP_VER_REGEXP} -do_pkg "zlib" ${ZLIB_VER} ${ZLIB_VER_REGEXP} -do_pkg "random" ${RANDOM_VER} ${RANDOM_VER_REGEXP} -do_pkg "stm" ${STM_VER} ${STM_VER_REGEXP} -do_pkg "hashable" ${HASHABLE_VER} ${HASHABLE_VER_REGEXP} -do_pkg "async" ${ASYNC_VER} ${ASYNC_VER_REGEXP} -do_pkg "base16-bytestring" ${BASE16_BYTESTRING_VER} \ - ${BASE16_BYTESTRING_VER_REGEXP} -do_pkg "base64-bytestring" ${BASE64_BYTESTRING_VER} \ - ${BASE64_BYTESTRING_VER_REGEXP} -do_pkg "cryptohash-sha256" ${CRYPTOHASH_SHA256_VER} \ - ${CRYPTOHASH_SHA256_VER_REGEXP} -do_pkg "resolv" ${RESOLV_VER} ${RESOLV_VER_REGEXP} -do_pkg "mintty" ${MINTTY_VER} ${MINTTY_VER_REGEXP} -do_pkg "echo" ${ECHO_VER} ${ECHO_VER_REGEXP} -do_pkg "edit-distance" ${EDIT_DISTANCE_VER} ${EDIT_DISTANCE_VER_REGEXP} -do_pkg "ed25519" ${ED25519_VER} ${ED25519_VER_REGEXP} -do_pkg "tar" ${TAR_VER} ${TAR_VER_REGEXP} -do_pkg "digest" ${DIGEST_VER} ${DIGEST_REGEXP} -do_pkg "lukko" ${LUKKO_VER} ${LUKKO_REGEXP} -do_pkg "regex-base" ${REGEX_BASE_VER} ${REGEX_BASE_REGEXP} -do_pkg "regex-posix" ${REGEX_POSIX_VER} ${REGEX_POSIX_REGEXP} -do_pkg "hackage-security" ${HACKAGE_SECURITY_VER} \ - ${HACKAGE_SECURITY_VER_REGEXP} - - -install_pkg "cabal-install" -[ ${NO_INSTALL} ] && exit 0 - -# Use the newly built cabal to turn the prefix/package database into a -# legit cabal sandbox. This works because 'cabal sandbox init' will -# reuse the already existing package database and other files if they -# are in the expected locations. -[ ! -z "$SANDBOX" ] && $SANDBOX/bin/cabal v1-sandbox init --sandbox $SANDBOX - -echo -echo "===========================================" -CABAL_BIN="$PREFIX/bin" -if [ -x "$CABAL_BIN/cabal" ] -then - echo "The 'cabal' program has been installed in $CABAL_BIN/" - echo "You should either add $CABAL_BIN to your PATH" - echo "or copy the cabal program to a directory that is on your PATH." - echo - echo "The first thing to do is to get the latest list of packages with:" - echo " cabal update" - echo "This will also create a default config file (if it does not already" - echo "exist) at $HOME/.cabal/config" - echo - echo "By default cabal will install programs to $HOME/.cabal/bin" - echo "If you do not want to add this directory to your PATH then you can" - echo "change the setting in the config file, for example you could use:" - echo "installdir: $HOME/bin" -else - echo "Sorry, something went wrong." - echo "The 'cabal' executable was not successfully installed into" - echo "$CABAL_BIN/" -fi -echo diff --git a/cabal/cabal-install/cabal-install.cabal b/cabal/cabal-install/cabal-install.cabal --- a/cabal/cabal-install/cabal-install.cabal +++ b/cabal/cabal-install/cabal-install.cabal @@ -1,10 +1,7 @@ -Cabal-Version: >= 1.10 --- NOTE: This file is autogenerated from 'cabal-install.cabal.pp'. --- DO NOT EDIT MANUALLY. --- To update this file, edit 'cabal-install.cabal.pp' and run --- 'make cabal-install-prod' in the project's root folder. +Cabal-Version: 2.2 + Name: cabal-install -Version: 3.3.0.0 +Version: 3.8.1.0 Synopsis: The command-line interface for Cabal and Hackage. Description: The \'cabal\' command-line program simplifies the process of managing @@ -12,91 +9,17 @@ and installation of Haskell libraries and programs. homepage: http://www.haskell.org/cabal/ bug-reports: https://github.com/haskell/cabal/issues -License: BSD3 +License: BSD-3-Clause License-File: LICENSE Author: Cabal Development Team (see AUTHORS file) Maintainer: Cabal Development Team -Copyright: 2003-2020, Cabal Development Team +Copyright: 2003-2022, Cabal Development Team Category: Distribution Build-type: Simple Extra-Source-Files: - README.md bash-completion/cabal bootstrap.sh changelog - - -- Generated with 'make gen-extra-source-files' - -- Do NOT edit this section manually; instead, run the script. - -- BEGIN gen-extra-source-files - tests/IntegrationTests2/build/keep-going/cabal.project - tests/IntegrationTests2/build/keep-going/p/P.hs - tests/IntegrationTests2/build/keep-going/p/p.cabal - tests/IntegrationTests2/build/keep-going/q/Q.hs - tests/IntegrationTests2/build/keep-going/q/q.cabal - tests/IntegrationTests2/build/local-tarball/cabal.project - tests/IntegrationTests2/build/local-tarball/q/Q.hs - tests/IntegrationTests2/build/local-tarball/q/q.cabal - tests/IntegrationTests2/build/setup-custom1/A.hs - tests/IntegrationTests2/build/setup-custom1/Setup.hs - tests/IntegrationTests2/build/setup-custom1/a.cabal - tests/IntegrationTests2/build/setup-custom2/A.hs - tests/IntegrationTests2/build/setup-custom2/Setup.hs - tests/IntegrationTests2/build/setup-custom2/a.cabal - tests/IntegrationTests2/build/setup-simple/A.hs - tests/IntegrationTests2/build/setup-simple/Setup.hs - tests/IntegrationTests2/build/setup-simple/a.cabal - tests/IntegrationTests2/exception/bad-config/cabal.project - tests/IntegrationTests2/exception/build/Main.hs - tests/IntegrationTests2/exception/build/a.cabal - tests/IntegrationTests2/exception/configure/a.cabal - tests/IntegrationTests2/exception/no-pkg/empty.in - tests/IntegrationTests2/exception/no-pkg2/cabal.project - tests/IntegrationTests2/regression/3324/cabal.project - tests/IntegrationTests2/regression/3324/p/P.hs - tests/IntegrationTests2/regression/3324/p/p.cabal - tests/IntegrationTests2/regression/3324/q/Q.hs - tests/IntegrationTests2/regression/3324/q/q.cabal - tests/IntegrationTests2/targets/all-disabled/cabal.project - tests/IntegrationTests2/targets/all-disabled/p.cabal - tests/IntegrationTests2/targets/benchmarks-disabled/cabal.project - tests/IntegrationTests2/targets/benchmarks-disabled/p.cabal - tests/IntegrationTests2/targets/benchmarks-disabled/q/q.cabal - tests/IntegrationTests2/targets/complex/cabal.project - tests/IntegrationTests2/targets/complex/q/Q.hs - tests/IntegrationTests2/targets/complex/q/q.cabal - tests/IntegrationTests2/targets/empty-pkg/cabal.project - tests/IntegrationTests2/targets/empty-pkg/p.cabal - tests/IntegrationTests2/targets/empty/cabal.project - tests/IntegrationTests2/targets/empty/foo.hs - tests/IntegrationTests2/targets/exes-disabled/cabal.project - tests/IntegrationTests2/targets/exes-disabled/p/p.cabal - tests/IntegrationTests2/targets/exes-disabled/q/q.cabal - tests/IntegrationTests2/targets/lib-only/p.cabal - tests/IntegrationTests2/targets/libs-disabled/cabal.project - tests/IntegrationTests2/targets/libs-disabled/p/p.cabal - tests/IntegrationTests2/targets/libs-disabled/q/q.cabal - tests/IntegrationTests2/targets/multiple-exes/cabal.project - tests/IntegrationTests2/targets/multiple-exes/p.cabal - tests/IntegrationTests2/targets/multiple-libs/cabal.project - tests/IntegrationTests2/targets/multiple-libs/p/p.cabal - tests/IntegrationTests2/targets/multiple-libs/q/q.cabal - tests/IntegrationTests2/targets/multiple-tests/cabal.project - tests/IntegrationTests2/targets/multiple-tests/p.cabal - tests/IntegrationTests2/targets/simple/P.hs - tests/IntegrationTests2/targets/simple/app/Main.hs - tests/IntegrationTests2/targets/simple/cabal.project - tests/IntegrationTests2/targets/simple/p.cabal - tests/IntegrationTests2/targets/simple/q/Q.hs - tests/IntegrationTests2/targets/simple/q/QQ.hs - tests/IntegrationTests2/targets/simple/q/q.cabal - tests/IntegrationTests2/targets/test-only/p.cabal - tests/IntegrationTests2/targets/tests-disabled/cabal.project - tests/IntegrationTests2/targets/tests-disabled/p.cabal - tests/IntegrationTests2/targets/tests-disabled/q/q.cabal - tests/IntegrationTests2/targets/variety/cabal.project - tests/IntegrationTests2/targets/variety/p.cabal - -- END gen-extra-source-files - - -- Additional manual extra-source-files: - tests/IntegrationTests2/build/local-tarball/p-0.1.tar.gz - + README.md + bash-completion/cabal + changelog source-repository head type: git @@ -104,49 +27,42 @@ subdir: cabal-install Flag native-dns - description: Enable use of the [resolv](https://hackage.haskell.org/package/resolv) & [windns](https://hackage.haskell.org/package/windns) packages for performing DNS lookups + description: + Enable use of the [resolv](https://hackage.haskell.org/package/resolv) + & [windns](https://hackage.haskell.org/package/windns) packages for performing DNS lookups default: True manual: True -Flag debug-expensive-assertions - description: Enable expensive assertions for testing or debugging - default: False - manual: True - -Flag debug-conflict-sets - description: Add additional information to ConflictSets - default: False - manual: True - -Flag debug-tracetree - description: Compile in support for tracetree (used to debug the solver) - default: False - manual: True - Flag lukko description: Use @lukko@ for file-locking default: True manual: True -executable cabal - main-is: Main.hs - hs-source-dirs: main - default-language: Haskell2010 - ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns - if impl(ghc >= 8.0) - ghc-options: -Wcompat - -Wnoncanonical-monad-instances - if impl(ghc < 8.8) - ghc-options: -Wnoncanonical-monadfail-instances +common warnings + ghc-options: -Wall -Wcompat -Wnoncanonical-monad-instances -Wincomplete-uni-patterns -Wincomplete-record-updates + if impl(ghc < 8.8) + ghc-options: -Wnoncanonical-monadfail-instances + if impl(ghc >=8.10) + ghc-options: -Wunused-packages +common base-dep + build-depends: base >=4.10 && <4.17 - ghc-options: -rtsopts -threaded +common cabal-dep + build-depends: Cabal ^>=3.8 - -- On AIX, some legacy BSD operations such as flock(2) are provided by libbsd.a - if os(aix) - extra-libraries: bsd - hs-source-dirs: . - other-modules: +common cabal-syntax-dep + build-depends: Cabal-syntax ^>=3.8 + +common cabal-install-solver-dep + build-depends: cabal-install-solver ^>=3.8 + +library + import: warnings, base-dep, cabal-dep, cabal-syntax-dep, cabal-install-solver-dep + default-language: Haskell2010 + + hs-source-dirs: src + exposed-modules: -- this modules are moved from Cabal -- they are needed for as long until cabal-install moves to parsec parser Distribution.Deprecated.ParseUtils @@ -172,6 +88,7 @@ Distribution.Client.CmdInstall.ClientInstallTargetSelector Distribution.Client.CmdLegacy Distribution.Client.CmdListBin + Distribution.Client.CmdOutdated Distribution.Client.CmdRepl Distribution.Client.CmdRun Distribution.Client.CmdSdist @@ -179,7 +96,6 @@ Distribution.Client.CmdUpdate Distribution.Client.Compat.Directory Distribution.Client.Compat.ExecutablePath - Distribution.Client.Compat.FilePerms Distribution.Client.Compat.Orphans Distribution.Client.Compat.Prelude Distribution.Client.Compat.Process @@ -189,7 +105,6 @@ Distribution.Client.Dependency Distribution.Client.Dependency.Types Distribution.Client.DistDirLayout - Distribution.Client.Exec Distribution.Client.Fetch Distribution.Client.FetchUtils Distribution.Client.FileMonitor @@ -207,12 +122,16 @@ Distribution.Client.IndexUtils.IndexState Distribution.Client.IndexUtils.Timestamp Distribution.Client.Init - Distribution.Client.Init.Command Distribution.Client.Init.Defaults Distribution.Client.Init.FileCreators - Distribution.Client.Init.Heuristics + Distribution.Client.Init.FlagExtractors + Distribution.Client.Init.Format + Distribution.Client.Init.Interactive.Command + Distribution.Client.Init.NonInteractive.Command + Distribution.Client.Init.NonInteractive.Heuristics Distribution.Client.Init.Licenses Distribution.Client.Init.Prompt + Distribution.Client.Init.Simple Distribution.Client.Init.Types Distribution.Client.Init.Utils Distribution.Client.Install @@ -224,7 +143,6 @@ Distribution.Client.ManpageFlags Distribution.Client.Nix Distribution.Client.NixStyleOptions - Distribution.Client.Outdated Distribution.Client.PackageHash Distribution.Client.ParseUtils Distribution.Client.ProjectBuilding @@ -243,6 +161,7 @@ Distribution.Client.Sandbox Distribution.Client.Sandbox.PackageEnvironment Distribution.Client.SavedFlags + Distribution.Client.ScriptUtils Distribution.Client.Security.DNS Distribution.Client.Security.HTTP Distribution.Client.Setup @@ -271,102 +190,44 @@ Distribution.Client.Types.SourcePackageDb Distribution.Client.Types.SourceRepo Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy - Distribution.Client.Update Distribution.Client.Upload Distribution.Client.Utils - Distribution.Client.Utils.Assertion Distribution.Client.Utils.Json Distribution.Client.Utils.Parsec Distribution.Client.VCS + Distribution.Client.Version Distribution.Client.Win32SelfUpgrade - Distribution.Client.World - Distribution.Solver.Compat.Prelude - Distribution.Solver.Modular - Distribution.Solver.Modular.Assignment - Distribution.Solver.Modular.Builder - Distribution.Solver.Modular.Configured - Distribution.Solver.Modular.ConfiguredConversion - Distribution.Solver.Modular.ConflictSet - Distribution.Solver.Modular.Cycles - Distribution.Solver.Modular.Dependency - Distribution.Solver.Modular.Explore - Distribution.Solver.Modular.Flag - Distribution.Solver.Modular.Index - Distribution.Solver.Modular.IndexConversion - Distribution.Solver.Modular.LabeledGraph - Distribution.Solver.Modular.Linking - Distribution.Solver.Modular.Log - Distribution.Solver.Modular.Message - Distribution.Solver.Modular.PSQ - Distribution.Solver.Modular.Package - Distribution.Solver.Modular.Preference - Distribution.Solver.Modular.RetryLog - Distribution.Solver.Modular.Solver - Distribution.Solver.Modular.Tree - Distribution.Solver.Modular.Validate - Distribution.Solver.Modular.Var - Distribution.Solver.Modular.Version - Distribution.Solver.Modular.WeightedPSQ - Distribution.Solver.Types.ComponentDeps - Distribution.Solver.Types.ConstraintSource - Distribution.Solver.Types.DependencyResolver - Distribution.Solver.Types.Flag - Distribution.Solver.Types.InstSolverPackage - Distribution.Solver.Types.InstalledPreference - Distribution.Solver.Types.LabeledPackageConstraint - Distribution.Solver.Types.OptionalStanza - Distribution.Solver.Types.PackageConstraint - Distribution.Solver.Types.PackageFixedDeps - Distribution.Solver.Types.PackageIndex - Distribution.Solver.Types.PackagePath - Distribution.Solver.Types.PackagePreferences - Distribution.Solver.Types.PkgConfigDb - Distribution.Solver.Types.Progress - Distribution.Solver.Types.ResolverPackage - Distribution.Solver.Types.Settings - Distribution.Solver.Types.SolverId - Distribution.Solver.Types.SolverPackage - Distribution.Solver.Types.SourcePackage - Distribution.Solver.Types.Variable - Paths_cabal_install build-depends: async >= 2.0 && < 2.3, array >= 0.4 && < 0.6, - base >= 4.8 && < 4.15, - base16-bytestring >= 0.1.1 && < 1.1, + base16-bytestring >= 0.1.1 && < 1.1.0.0, binary >= 0.7.3 && < 0.9, - bytestring >= 0.10.6.0 && < 0.11, - Cabal == 3.3.*, + bytestring >= 0.10.6.0 && < 0.12, containers >= 0.5.6.2 && < 0.7, cryptohash-sha256 >= 0.11 && < 0.12, - deepseq >= 1.4.1.1 && < 1.5, directory >= 1.2.2.0 && < 1.4, echo >= 0.1.3 && < 0.2, edit-distance >= 0.2.2 && < 0.3, + exceptions >= 0.10.4 && < 0.11, filepath >= 1.4.0.0 && < 1.5, - hashable >= 1.0 && < 1.4, - HTTP >= 4000.1.5 && < 4000.4, + hashable >= 1.0 && < 1.5, + HTTP >= 4000.1.5 && < 4000.5, mtl >= 2.0 && < 2.3, network-uri >= 2.6.0.2 && < 2.7, - network >= 2.6 && < 3.2, pretty >= 1.1 && < 1.2, process >= 1.2.3.0 && < 1.7, - random >= 1 && < 1.2, + random >= 1.2 && < 1.3, stm >= 2.0 && < 2.6, tar >= 0.5.0.3 && < 0.6, - time >= 1.5.0.1 && < 1.11, - transformers >= 0.4.2.0 && < 0.6, + time >= 1.5.0.1 && < 1.13, zlib >= 0.5.3 && < 0.7, - hackage-security >= 0.6.0.1 && < 0.7, - text >= 1.2.3 && < 1.3, + hackage-security >= 0.6.2.0 && < 0.7, + text >= 1.2.3 && < 1.3 || >= 2.0 && < 2.1, parsec >= 3.1.13.0 && < 3.2, regex-base >= 0.94.0.0 && <0.95, - regex-posix >= 0.96.0.0 && <0.97 - - if !impl(ghc >= 8.0) - build-depends: fail == 4.9.* - build-depends: semigroups >= 0.18.3 && <0.20 + regex-posix >= 0.96.0.0 && <0.97, + safe-exceptions >= 0.1.7.0 && < 0.2 if flag(native-dns) if os(windows) @@ -376,22 +237,185 @@ if os(windows) -- newer directory for symlinks - build-depends: Win32 >= 2 && < 3, directory >=1.3.1.0 + build-depends: Win32 >= 2.8 && < 3, directory >=1.3.1.0 else build-depends: unix >= 2.5 && < 2.9 if flag(lukko) build-depends: lukko >= 0.1 && <0.2 - else - build-depends: base >= 4.10 - if flag(debug-expensive-assertions) - cpp-options: -DDEBUG_EXPENSIVE_ASSERTIONS + -- pull in process version with fixed waitForProcess error + if impl(ghc >=8.2) + build-depends: process >= 1.6.15.0 - if flag(debug-conflict-sets) - cpp-options: -DDEBUG_CONFLICT_SETS - build-depends: base >= 4.8 - if flag(debug-tracetree) - cpp-options: -DDEBUG_TRACETREE - build-depends: tracetree >= 0.1 && < 0.2 +executable cabal + import: warnings, base-dep, cabal-dep, cabal-syntax-dep + main-is: Main.hs + hs-source-dirs: main + default-language: Haskell2010 + + ghc-options: -rtsopts -threaded + + -- On AIX, some legacy BSD operations such as flock(2) are provided by libbsd.a + if os(aix) + extra-libraries: bsd + + build-depends: + cabal-install, + directory, + filepath + +-- Small, fast running tests. +-- +test-suite unit-tests + import: warnings, base-dep, cabal-dep, cabal-syntax-dep, cabal-install-solver-dep + default-language: Haskell2010 + ghc-options: -rtsopts -threaded + + type: exitcode-stdio-1.0 + main-is: UnitTests.hs + hs-source-dirs: tests + other-modules: + UnitTests.Distribution.Client.ArbitraryInstances + UnitTests.Distribution.Client.BuildReport + UnitTests.Distribution.Client.Configure + UnitTests.Distribution.Client.FetchUtils + UnitTests.Distribution.Client.Get + UnitTests.Distribution.Client.Glob + UnitTests.Distribution.Client.GZipUtils + UnitTests.Distribution.Client.IndexUtils + UnitTests.Distribution.Client.IndexUtils.Timestamp + UnitTests.Distribution.Client.Init + UnitTests.Distribution.Client.Init.Golden + UnitTests.Distribution.Client.Init.Interactive + UnitTests.Distribution.Client.Init.NonInteractive + UnitTests.Distribution.Client.Init.Simple + UnitTests.Distribution.Client.Init.Utils + UnitTests.Distribution.Client.Init.FileCreators + UnitTests.Distribution.Client.InstallPlan + UnitTests.Distribution.Client.JobControl + UnitTests.Distribution.Client.ProjectConfig + UnitTests.Distribution.Client.ProjectPlanning + UnitTests.Distribution.Client.Store + UnitTests.Distribution.Client.Tar + UnitTests.Distribution.Client.Targets + UnitTests.Distribution.Client.TreeDiffInstances + UnitTests.Distribution.Client.UserConfig + UnitTests.Distribution.Solver.Modular.Builder + UnitTests.Distribution.Solver.Modular.RetryLog + UnitTests.Distribution.Solver.Modular.Solver + UnitTests.Distribution.Solver.Modular.DSL + UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils + UnitTests.Distribution.Solver.Modular.WeightedPSQ + UnitTests.Distribution.Solver.Types.OptionalStanza + UnitTests.Options + UnitTests.TempTestDir + + build-depends: + array, + bytestring, + cabal-install, + Cabal-tree-diff, + Cabal-QuickCheck, + containers, + directory, + filepath, + mtl, + network-uri >= 2.6.2.0 && <2.7, + random, + tar, + time, + zlib, + tasty >= 1.2.3 && <1.5, + tasty-golden >=2.3.1.1 && <2.4, + tasty-quickcheck, + tasty-hunit >= 0.10, + tree-diff, + QuickCheck >= 2.14 && <2.15 + + +-- Tests to run with a limited stack and heap size +-- The test suite name must be keep short cause a longer one +-- could make the build generating paths which exceeds the windows +-- max path limit (still a problem for some ghc versions) +test-suite mem-use-tests + import: warnings, base-dep, cabal-dep, cabal-syntax-dep, cabal-install-solver-dep + type: exitcode-stdio-1.0 + main-is: MemoryUsageTests.hs + hs-source-dirs: tests + default-language: Haskell2010 + + ghc-options: -threaded -rtsopts "-with-rtsopts=-M16M -K1K" + + other-modules: + UnitTests.Distribution.Solver.Modular.DSL + UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils + UnitTests.Distribution.Solver.Modular.MemoryUsage + UnitTests.Options + + build-depends: + cabal-install, + containers, + tasty >= 1.2.3 && <1.5, + tasty-hunit >= 0.10 + + +-- Integration tests that use the cabal-install code directly +-- but still build whole projects +test-suite integration-tests2 + import: warnings, base-dep, cabal-dep, cabal-syntax-dep, cabal-install-solver-dep + ghc-options: -rtsopts -threaded + type: exitcode-stdio-1.0 + main-is: IntegrationTests2.hs + hs-source-dirs: tests + default-language: Haskell2010 + + build-depends: + bytestring, + cabal-install, + containers, + directory, + filepath, + tasty >= 1.2.3 && <1.5, + tasty-hunit >= 0.10, + tagged + +test-suite long-tests + import: warnings, base-dep, cabal-dep, cabal-syntax-dep, cabal-install-solver-dep + ghc-options: -rtsopts -threaded + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: LongTests.hs + default-language: Haskell2010 + + other-modules: + UnitTests.Distribution.Client.ArbitraryInstances + UnitTests.Distribution.Client.Described + UnitTests.Distribution.Client.DescribedInstances + UnitTests.Distribution.Client.FileMonitor + UnitTests.Distribution.Client.VCS + UnitTests.Distribution.Solver.Modular.DSL + UnitTests.Distribution.Solver.Modular.QuickCheck + UnitTests.Distribution.Solver.Modular.QuickCheck.Utils + UnitTests.Options + UnitTests.TempTestDir + + build-depends: + Cabal-QuickCheck, + Cabal-described, + cabal-install, + containers, + directory, + filepath, + hashable, + mtl, + network-uri >= 2.6.2.0 && <2.7, + random, + tagged, + tasty >= 1.2.3 && <1.5, + tasty-expected-failure, + tasty-hunit >= 0.10, + tasty-quickcheck, + QuickCheck >= 2.14 && <2.15, + pretty-show >= 1.6.15 diff --git a/cabal/cabal-install/cabal-install.cabal.dev b/cabal/cabal-install/cabal-install.cabal.dev deleted file mode 100644 --- a/cabal/cabal-install/cabal-install.cabal.dev +++ /dev/null @@ -1,587 +0,0 @@ -Cabal-Version: 2.0 --- NOTE: This file is autogenerated from 'cabal-install.cabal.pp'. --- DO NOT EDIT MANUALLY. --- To update this file, edit 'cabal-install.cabal.pp' and run --- 'make cabal-install-prod' in the project's root folder. -Name: cabal-install -Version: 3.3.0.0 -Synopsis: The command-line interface for Cabal and Hackage. -Description: - The \'cabal\' command-line program simplifies the process of managing - Haskell software by automating the fetching, configuration, compilation - and installation of Haskell libraries and programs. -homepage: http://www.haskell.org/cabal/ -bug-reports: https://github.com/haskell/cabal/issues -License: BSD3 -License-File: LICENSE -Author: Cabal Development Team (see AUTHORS file) -Maintainer: Cabal Development Team -Copyright: 2003-2020, Cabal Development Team -Category: Distribution -Build-type: Simple -Extra-Source-Files: - README.md bash-completion/cabal bootstrap.sh changelog - - -- Generated with 'make gen-extra-source-files' - -- Do NOT edit this section manually; instead, run the script. - -- BEGIN gen-extra-source-files - tests/IntegrationTests2/build/keep-going/cabal.project - tests/IntegrationTests2/build/keep-going/p/P.hs - tests/IntegrationTests2/build/keep-going/p/p.cabal - tests/IntegrationTests2/build/keep-going/q/Q.hs - tests/IntegrationTests2/build/keep-going/q/q.cabal - tests/IntegrationTests2/build/local-tarball/cabal.project - tests/IntegrationTests2/build/local-tarball/q/Q.hs - tests/IntegrationTests2/build/local-tarball/q/q.cabal - tests/IntegrationTests2/build/setup-custom1/A.hs - tests/IntegrationTests2/build/setup-custom1/Setup.hs - tests/IntegrationTests2/build/setup-custom1/a.cabal - tests/IntegrationTests2/build/setup-custom2/A.hs - tests/IntegrationTests2/build/setup-custom2/Setup.hs - tests/IntegrationTests2/build/setup-custom2/a.cabal - tests/IntegrationTests2/build/setup-simple/A.hs - tests/IntegrationTests2/build/setup-simple/Setup.hs - tests/IntegrationTests2/build/setup-simple/a.cabal - tests/IntegrationTests2/exception/bad-config/cabal.project - tests/IntegrationTests2/exception/build/Main.hs - tests/IntegrationTests2/exception/build/a.cabal - tests/IntegrationTests2/exception/configure/a.cabal - tests/IntegrationTests2/exception/no-pkg/empty.in - tests/IntegrationTests2/exception/no-pkg2/cabal.project - tests/IntegrationTests2/regression/3324/cabal.project - tests/IntegrationTests2/regression/3324/p/P.hs - tests/IntegrationTests2/regression/3324/p/p.cabal - tests/IntegrationTests2/regression/3324/q/Q.hs - tests/IntegrationTests2/regression/3324/q/q.cabal - tests/IntegrationTests2/targets/all-disabled/cabal.project - tests/IntegrationTests2/targets/all-disabled/p.cabal - tests/IntegrationTests2/targets/benchmarks-disabled/cabal.project - tests/IntegrationTests2/targets/benchmarks-disabled/p.cabal - tests/IntegrationTests2/targets/benchmarks-disabled/q/q.cabal - tests/IntegrationTests2/targets/complex/cabal.project - tests/IntegrationTests2/targets/complex/q/Q.hs - tests/IntegrationTests2/targets/complex/q/q.cabal - tests/IntegrationTests2/targets/empty-pkg/cabal.project - tests/IntegrationTests2/targets/empty-pkg/p.cabal - tests/IntegrationTests2/targets/empty/cabal.project - tests/IntegrationTests2/targets/empty/foo.hs - tests/IntegrationTests2/targets/exes-disabled/cabal.project - tests/IntegrationTests2/targets/exes-disabled/p/p.cabal - tests/IntegrationTests2/targets/exes-disabled/q/q.cabal - tests/IntegrationTests2/targets/lib-only/p.cabal - tests/IntegrationTests2/targets/libs-disabled/cabal.project - tests/IntegrationTests2/targets/libs-disabled/p/p.cabal - tests/IntegrationTests2/targets/libs-disabled/q/q.cabal - tests/IntegrationTests2/targets/multiple-exes/cabal.project - tests/IntegrationTests2/targets/multiple-exes/p.cabal - tests/IntegrationTests2/targets/multiple-libs/cabal.project - tests/IntegrationTests2/targets/multiple-libs/p/p.cabal - tests/IntegrationTests2/targets/multiple-libs/q/q.cabal - tests/IntegrationTests2/targets/multiple-tests/cabal.project - tests/IntegrationTests2/targets/multiple-tests/p.cabal - tests/IntegrationTests2/targets/simple/P.hs - tests/IntegrationTests2/targets/simple/app/Main.hs - tests/IntegrationTests2/targets/simple/cabal.project - tests/IntegrationTests2/targets/simple/p.cabal - tests/IntegrationTests2/targets/simple/q/Q.hs - tests/IntegrationTests2/targets/simple/q/QQ.hs - tests/IntegrationTests2/targets/simple/q/q.cabal - tests/IntegrationTests2/targets/test-only/p.cabal - tests/IntegrationTests2/targets/tests-disabled/cabal.project - tests/IntegrationTests2/targets/tests-disabled/p.cabal - tests/IntegrationTests2/targets/tests-disabled/q/q.cabal - tests/IntegrationTests2/targets/variety/cabal.project - tests/IntegrationTests2/targets/variety/p.cabal - -- END gen-extra-source-files - - -- Additional manual extra-source-files: - tests/IntegrationTests2/build/local-tarball/p-0.1.tar.gz - - -source-repository head - type: git - location: https://github.com/haskell/cabal/ - subdir: cabal-install - -Flag native-dns - description: Enable use of the [resolv](https://hackage.haskell.org/package/resolv) & [windns](https://hackage.haskell.org/package/windns) packages for performing DNS lookups - default: True - manual: True - -Flag debug-expensive-assertions - description: Enable expensive assertions for testing or debugging - default: False - manual: True - -Flag debug-conflict-sets - description: Add additional information to ConflictSets - default: False - manual: True - -Flag debug-tracetree - description: Compile in support for tracetree (used to debug the solver) - default: False - manual: True - -Flag lukko - description: Use @lukko@ for file-locking - default: True - manual: True - -library cabal-lib-client - default-language: Haskell2010 - ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns - if impl(ghc >= 8.0) - ghc-options: -Wcompat - -Wnoncanonical-monad-instances - if impl(ghc < 8.8) - ghc-options: -Wnoncanonical-monadfail-instances - - hs-source-dirs: . - exposed-modules: - -- this modules are moved from Cabal - -- they are needed for as long until cabal-install moves to parsec parser - Distribution.Deprecated.ParseUtils - Distribution.Deprecated.ReadP - Distribution.Deprecated.ViewAsFieldDescr - - Distribution.Client.BuildReports.Anonymous - Distribution.Client.BuildReports.Lens - Distribution.Client.BuildReports.Storage - Distribution.Client.BuildReports.Types - Distribution.Client.BuildReports.Upload - Distribution.Client.Check - Distribution.Client.CmdBench - Distribution.Client.CmdBuild - Distribution.Client.CmdClean - Distribution.Client.CmdConfigure - Distribution.Client.CmdErrorMessages - Distribution.Client.CmdExec - Distribution.Client.CmdFreeze - Distribution.Client.CmdHaddock - Distribution.Client.CmdInstall - Distribution.Client.CmdInstall.ClientInstallFlags - Distribution.Client.CmdInstall.ClientInstallTargetSelector - Distribution.Client.CmdLegacy - Distribution.Client.CmdListBin - Distribution.Client.CmdRepl - Distribution.Client.CmdRun - Distribution.Client.CmdSdist - Distribution.Client.CmdTest - Distribution.Client.CmdUpdate - Distribution.Client.Compat.Directory - Distribution.Client.Compat.ExecutablePath - Distribution.Client.Compat.FilePerms - Distribution.Client.Compat.Orphans - Distribution.Client.Compat.Prelude - Distribution.Client.Compat.Process - Distribution.Client.Compat.Semaphore - Distribution.Client.Config - Distribution.Client.Configure - Distribution.Client.Dependency - Distribution.Client.Dependency.Types - Distribution.Client.DistDirLayout - Distribution.Client.Exec - Distribution.Client.Fetch - Distribution.Client.FetchUtils - Distribution.Client.FileMonitor - Distribution.Client.Freeze - Distribution.Client.GZipUtils - Distribution.Client.GenBounds - Distribution.Client.Get - Distribution.Client.Glob - Distribution.Client.GlobalFlags - Distribution.Client.Haddock - Distribution.Client.HashValue - Distribution.Client.HttpUtils - Distribution.Client.IndexUtils - Distribution.Client.IndexUtils.ActiveRepos - Distribution.Client.IndexUtils.IndexState - Distribution.Client.IndexUtils.Timestamp - Distribution.Client.Init - Distribution.Client.Init.Command - Distribution.Client.Init.Defaults - Distribution.Client.Init.FileCreators - Distribution.Client.Init.Heuristics - Distribution.Client.Init.Licenses - Distribution.Client.Init.Prompt - Distribution.Client.Init.Types - Distribution.Client.Init.Utils - Distribution.Client.Install - Distribution.Client.InstallPlan - Distribution.Client.InstallSymlink - Distribution.Client.JobControl - Distribution.Client.List - Distribution.Client.Manpage - Distribution.Client.ManpageFlags - Distribution.Client.Nix - Distribution.Client.NixStyleOptions - Distribution.Client.Outdated - Distribution.Client.PackageHash - Distribution.Client.ParseUtils - Distribution.Client.ProjectBuilding - Distribution.Client.ProjectBuilding.Types - Distribution.Client.ProjectConfig - Distribution.Client.ProjectConfig.Legacy - Distribution.Client.ProjectConfig.Types - Distribution.Client.ProjectFlags - Distribution.Client.ProjectOrchestration - Distribution.Client.ProjectPlanOutput - Distribution.Client.ProjectPlanning - Distribution.Client.ProjectPlanning.Types - Distribution.Client.RebuildMonad - Distribution.Client.Reconfigure - Distribution.Client.Run - Distribution.Client.Sandbox - Distribution.Client.Sandbox.PackageEnvironment - Distribution.Client.SavedFlags - Distribution.Client.Security.DNS - Distribution.Client.Security.HTTP - Distribution.Client.Setup - Distribution.Client.SetupWrapper - Distribution.Client.SolverInstallPlan - Distribution.Client.SourceFiles - Distribution.Client.SrcDist - Distribution.Client.Store - Distribution.Client.Tar - Distribution.Client.TargetProblem - Distribution.Client.TargetSelector - Distribution.Client.Targets - 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.InstallMethod - Distribution.Client.Types.OverwritePolicy - Distribution.Client.Types.PackageLocation - Distribution.Client.Types.PackageSpecifier - Distribution.Client.Types.ReadyPackage - Distribution.Client.Types.Repo - Distribution.Client.Types.RepoName - Distribution.Client.Types.SourcePackageDb - Distribution.Client.Types.SourceRepo - Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy - Distribution.Client.Update - Distribution.Client.Upload - Distribution.Client.Utils - Distribution.Client.Utils.Assertion - Distribution.Client.Utils.Json - Distribution.Client.Utils.Parsec - Distribution.Client.VCS - Distribution.Client.Win32SelfUpgrade - Distribution.Client.World - Distribution.Solver.Compat.Prelude - Distribution.Solver.Modular - Distribution.Solver.Modular.Assignment - Distribution.Solver.Modular.Builder - Distribution.Solver.Modular.Configured - Distribution.Solver.Modular.ConfiguredConversion - Distribution.Solver.Modular.ConflictSet - Distribution.Solver.Modular.Cycles - Distribution.Solver.Modular.Dependency - Distribution.Solver.Modular.Explore - Distribution.Solver.Modular.Flag - Distribution.Solver.Modular.Index - Distribution.Solver.Modular.IndexConversion - Distribution.Solver.Modular.LabeledGraph - Distribution.Solver.Modular.Linking - Distribution.Solver.Modular.Log - Distribution.Solver.Modular.Message - Distribution.Solver.Modular.PSQ - Distribution.Solver.Modular.Package - Distribution.Solver.Modular.Preference - Distribution.Solver.Modular.RetryLog - Distribution.Solver.Modular.Solver - Distribution.Solver.Modular.Tree - Distribution.Solver.Modular.Validate - Distribution.Solver.Modular.Var - Distribution.Solver.Modular.Version - Distribution.Solver.Modular.WeightedPSQ - Distribution.Solver.Types.ComponentDeps - Distribution.Solver.Types.ConstraintSource - Distribution.Solver.Types.DependencyResolver - Distribution.Solver.Types.Flag - Distribution.Solver.Types.InstSolverPackage - Distribution.Solver.Types.InstalledPreference - Distribution.Solver.Types.LabeledPackageConstraint - Distribution.Solver.Types.OptionalStanza - Distribution.Solver.Types.PackageConstraint - Distribution.Solver.Types.PackageFixedDeps - Distribution.Solver.Types.PackageIndex - Distribution.Solver.Types.PackagePath - Distribution.Solver.Types.PackagePreferences - Distribution.Solver.Types.PkgConfigDb - Distribution.Solver.Types.Progress - Distribution.Solver.Types.ResolverPackage - Distribution.Solver.Types.Settings - Distribution.Solver.Types.SolverId - Distribution.Solver.Types.SolverPackage - Distribution.Solver.Types.SourcePackage - Distribution.Solver.Types.Variable - Paths_cabal_install - - autogen-modules: - Paths_cabal_install - build-depends: - async >= 2.0 && < 2.3, - array >= 0.4 && < 0.6, - base >= 4.8 && < 4.15, - base16-bytestring >= 0.1.1 && < 0.2, - binary >= 0.7.3 && < 0.9, - bytestring >= 0.10.6.0 && < 0.11, - Cabal == 3.3.*, - containers >= 0.5.6.2 && < 0.7, - cryptohash-sha256 >= 0.11 && < 0.12, - deepseq >= 1.4.1.1 && < 1.5, - directory >= 1.2.2.0 && < 1.4, - echo >= 0.1.3 && < 0.2, - edit-distance >= 0.2.2 && < 0.3, - filepath >= 1.4.0.0 && < 1.5, - hashable >= 1.0 && < 1.4, - HTTP >= 4000.1.5 && < 4000.4, - mtl >= 2.0 && < 2.3, - network-uri >= 2.6.0.2 && < 2.7, - network >= 2.6 && < 3.2, - pretty >= 1.1 && < 1.2, - process >= 1.2.3.0 && < 1.7, - random >= 1 && < 1.2, - stm >= 2.0 && < 2.6, - tar >= 0.5.0.3 && < 0.6, - time >= 1.5.0.1 && < 1.11, - transformers >= 0.4.2.0 && < 0.6, - zlib >= 0.5.3 && < 0.7, - hackage-security >= 0.6.0.1 && < 0.7, - text >= 1.2.3 && < 1.3, - parsec >= 3.1.13.0 && < 3.2, - regex-base >= 0.94.0.0 && <0.95, - regex-posix >= 0.96.0.0 && <0.97 - - if !impl(ghc >= 8.0) - build-depends: fail == 4.9.* - build-depends: semigroups >= 0.18.3 && <0.20 - - if flag(native-dns) - if os(windows) - build-depends: windns >= 0.1.0 && < 0.2 - else - build-depends: resolv >= 0.1.1 && < 0.2 - - if os(windows) - -- newer directory for symlinks - build-depends: Win32 >= 2 && < 3, directory >=1.3.1.0 - else - build-depends: unix >= 2.5 && < 2.9 - - if flag(lukko) - build-depends: lukko >= 0.1 && <0.2 - else - build-depends: base >= 4.10 - - if flag(debug-expensive-assertions) - cpp-options: -DDEBUG_EXPENSIVE_ASSERTIONS - - if flag(debug-conflict-sets) - cpp-options: -DDEBUG_CONFLICT_SETS - build-depends: base >= 4.8 - - if flag(debug-tracetree) - cpp-options: -DDEBUG_TRACETREE - build-depends: tracetree >= 0.1 && < 0.2 - -library cabal-install-solver-dsl - default-language: Haskell2010 - ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns - if impl(ghc >= 8.0) - ghc-options: -Wcompat - -Wnoncanonical-monad-instances - if impl(ghc < 8.8) - ghc-options: -Wnoncanonical-monadfail-instances - - hs-source-dirs: solver-dsl - exposed-modules: - UnitTests.Distribution.Solver.Modular.DSL - build-depends: - base, - Cabal, - containers, - -- TODO: depend on cabal-install-solver only - cabal-lib-client -executable cabal - main-is: Main.hs - hs-source-dirs: main - default-language: Haskell2010 - ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns - if impl(ghc >= 8.0) - ghc-options: -Wcompat - -Wnoncanonical-monad-instances - if impl(ghc < 8.8) - ghc-options: -Wnoncanonical-monadfail-instances - - - ghc-options: -rtsopts -threaded - - -- On AIX, some legacy BSD operations such as flock(2) are provided by libbsd.a - if os(aix) - extra-libraries: bsd - build-depends: - cabal-lib-client, - Cabal, - base, - directory, - filepath - - other-modules: Paths_cabal_install --- Small, fast running tests. --- -Test-Suite unit-tests - type: exitcode-stdio-1.0 - main-is: UnitTests.hs - hs-source-dirs: tests - ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -main-is UnitTests - other-modules: - UnitTests.Distribution.Client.ArbitraryInstances - UnitTests.Distribution.Client.BuildReport - UnitTests.Distribution.Client.Described - UnitTests.Distribution.Client.DescribedInstances - UnitTests.Distribution.Client.Targets - UnitTests.Distribution.Client.FileMonitor - UnitTests.Distribution.Client.Get - UnitTests.Distribution.Client.Glob - UnitTests.Distribution.Client.GZipUtils - UnitTests.Distribution.Client.Init.FileCreators - UnitTests.Distribution.Client.Store - UnitTests.Distribution.Client.Tar - UnitTests.Distribution.Client.TreeDiffInstances - UnitTests.Distribution.Client.UserConfig - UnitTests.Distribution.Client.ProjectConfig - UnitTests.Distribution.Client.JobControl - UnitTests.Distribution.Client.IndexUtils.Timestamp - UnitTests.Distribution.Client.InstallPlan - UnitTests.Distribution.Client.VCS - UnitTests.Distribution.Solver.Modular.Builder - UnitTests.Distribution.Solver.Modular.RetryLog - UnitTests.Distribution.Solver.Modular.Solver - UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils - UnitTests.Distribution.Solver.Modular.WeightedPSQ - UnitTests.Options - UnitTests.TempTestDir - build-depends: - array, - base, - async, - bytestring, - cabal-lib-client, - cabal-install-solver-dsl, - Cabal, - Cabal-described, - Cabal-tree-diff, - Cabal-QuickCheck, - containers, - deepseq, - mtl, - random, - directory, - filepath, - tar, - time, - zlib, - network-uri >= 2.6.2.0 && <2.6.4.0, - network, - tasty >= 1.2.3 && <1.4, - tasty-golden >=2.3.1.1 && <2.4, - tasty-hunit >= 0.10, - tasty-quickcheck, - tagged, - tree-diff, - QuickCheck >= 2.14 && <2.15 - - ghc-options: -threaded - - default-language: Haskell2010 - --- Tests to run with a limited stack and heap size --- -Test-Suite memory-usage-tests - type: exitcode-stdio-1.0 - main-is: MemoryUsageTests.hs - hs-source-dirs: tests - ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns "-with-rtsopts=-M4M -K1K" -main-is MemoryUsageTests - other-modules: - UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils - UnitTests.Distribution.Solver.Modular.MemoryUsage - UnitTests.Options - build-depends: - base, - async, - Cabal, - cabal-lib-client, - cabal-install-solver-dsl, - containers, - deepseq, - tagged, - tasty >= 1.2.3 && <1.4, - tasty-hunit >= 0.10 - - ghc-options: -threaded - - default-language: Haskell2010 - --- Slow solver tests --- -Test-Suite solver-quickcheck - type: exitcode-stdio-1.0 - main-is: SolverQuickCheck.hs - hs-source-dirs: tests - ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -main-is SolverQuickCheck - other-modules: - UnitTests.Distribution.Solver.Modular.QuickCheck - UnitTests.Distribution.Solver.Modular.QuickCheck.Utils - build-depends: - base, - async, - Cabal, - Cabal-QuickCheck, - cabal-lib-client, - cabal-install-solver-dsl, - containers, - deepseq >= 1.2, - hashable, - random, - tagged, - tasty >= 1.2.3 && <1.4, - tasty-quickcheck, - QuickCheck >= 2.14 && <2.15, - pretty-show >= 1.6.15 - - ghc-options: -threaded - - default-language: Haskell2010 - - --- Integration tests that use the cabal-install code directly --- but still build whole projects -test-suite integration-tests2 - type: exitcode-stdio-1.0 - main-is: IntegrationTests2.hs - hs-source-dirs: tests - ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -main-is IntegrationTests2 - other-modules: - build-depends: - base, - bytestring, - Cabal, - cabal-lib-client, - containers, - deepseq, - directory, - edit-distance, - filepath, - tasty >= 1.2.3 && <1.4, - tasty-hunit >= 0.10, - tagged - - ghc-options: -threaded - default-language: Haskell2010 - diff --git a/cabal/cabal-install/cabal-install.cabal.prod b/cabal/cabal-install/cabal-install.cabal.prod deleted file mode 100644 --- a/cabal/cabal-install/cabal-install.cabal.prod +++ /dev/null @@ -1,397 +0,0 @@ -Cabal-Version: >= 1.10 --- NOTE: This file is autogenerated from 'cabal-install.cabal.pp'. --- DO NOT EDIT MANUALLY. --- To update this file, edit 'cabal-install.cabal.pp' and run --- 'make cabal-install-prod' in the project's root folder. -Name: cabal-install -Version: 3.3.0.0 -Synopsis: The command-line interface for Cabal and Hackage. -Description: - The \'cabal\' command-line program simplifies the process of managing - Haskell software by automating the fetching, configuration, compilation - and installation of Haskell libraries and programs. -homepage: http://www.haskell.org/cabal/ -bug-reports: https://github.com/haskell/cabal/issues -License: BSD3 -License-File: LICENSE -Author: Cabal Development Team (see AUTHORS file) -Maintainer: Cabal Development Team -Copyright: 2003-2020, Cabal Development Team -Category: Distribution -Build-type: Simple -Extra-Source-Files: - README.md bash-completion/cabal bootstrap.sh changelog - - -- Generated with 'make gen-extra-source-files' - -- Do NOT edit this section manually; instead, run the script. - -- BEGIN gen-extra-source-files - tests/IntegrationTests2/build/keep-going/cabal.project - tests/IntegrationTests2/build/keep-going/p/P.hs - tests/IntegrationTests2/build/keep-going/p/p.cabal - tests/IntegrationTests2/build/keep-going/q/Q.hs - tests/IntegrationTests2/build/keep-going/q/q.cabal - tests/IntegrationTests2/build/local-tarball/cabal.project - tests/IntegrationTests2/build/local-tarball/q/Q.hs - tests/IntegrationTests2/build/local-tarball/q/q.cabal - tests/IntegrationTests2/build/setup-custom1/A.hs - tests/IntegrationTests2/build/setup-custom1/Setup.hs - tests/IntegrationTests2/build/setup-custom1/a.cabal - tests/IntegrationTests2/build/setup-custom2/A.hs - tests/IntegrationTests2/build/setup-custom2/Setup.hs - tests/IntegrationTests2/build/setup-custom2/a.cabal - tests/IntegrationTests2/build/setup-simple/A.hs - tests/IntegrationTests2/build/setup-simple/Setup.hs - tests/IntegrationTests2/build/setup-simple/a.cabal - tests/IntegrationTests2/exception/bad-config/cabal.project - tests/IntegrationTests2/exception/build/Main.hs - tests/IntegrationTests2/exception/build/a.cabal - tests/IntegrationTests2/exception/configure/a.cabal - tests/IntegrationTests2/exception/no-pkg/empty.in - tests/IntegrationTests2/exception/no-pkg2/cabal.project - tests/IntegrationTests2/regression/3324/cabal.project - tests/IntegrationTests2/regression/3324/p/P.hs - tests/IntegrationTests2/regression/3324/p/p.cabal - tests/IntegrationTests2/regression/3324/q/Q.hs - tests/IntegrationTests2/regression/3324/q/q.cabal - tests/IntegrationTests2/targets/all-disabled/cabal.project - tests/IntegrationTests2/targets/all-disabled/p.cabal - tests/IntegrationTests2/targets/benchmarks-disabled/cabal.project - tests/IntegrationTests2/targets/benchmarks-disabled/p.cabal - tests/IntegrationTests2/targets/benchmarks-disabled/q/q.cabal - tests/IntegrationTests2/targets/complex/cabal.project - tests/IntegrationTests2/targets/complex/q/Q.hs - tests/IntegrationTests2/targets/complex/q/q.cabal - tests/IntegrationTests2/targets/empty-pkg/cabal.project - tests/IntegrationTests2/targets/empty-pkg/p.cabal - tests/IntegrationTests2/targets/empty/cabal.project - tests/IntegrationTests2/targets/empty/foo.hs - tests/IntegrationTests2/targets/exes-disabled/cabal.project - tests/IntegrationTests2/targets/exes-disabled/p/p.cabal - tests/IntegrationTests2/targets/exes-disabled/q/q.cabal - tests/IntegrationTests2/targets/lib-only/p.cabal - tests/IntegrationTests2/targets/libs-disabled/cabal.project - tests/IntegrationTests2/targets/libs-disabled/p/p.cabal - tests/IntegrationTests2/targets/libs-disabled/q/q.cabal - tests/IntegrationTests2/targets/multiple-exes/cabal.project - tests/IntegrationTests2/targets/multiple-exes/p.cabal - tests/IntegrationTests2/targets/multiple-libs/cabal.project - tests/IntegrationTests2/targets/multiple-libs/p/p.cabal - tests/IntegrationTests2/targets/multiple-libs/q/q.cabal - tests/IntegrationTests2/targets/multiple-tests/cabal.project - tests/IntegrationTests2/targets/multiple-tests/p.cabal - tests/IntegrationTests2/targets/simple/P.hs - tests/IntegrationTests2/targets/simple/app/Main.hs - tests/IntegrationTests2/targets/simple/cabal.project - tests/IntegrationTests2/targets/simple/p.cabal - tests/IntegrationTests2/targets/simple/q/Q.hs - tests/IntegrationTests2/targets/simple/q/QQ.hs - tests/IntegrationTests2/targets/simple/q/q.cabal - tests/IntegrationTests2/targets/test-only/p.cabal - tests/IntegrationTests2/targets/tests-disabled/cabal.project - tests/IntegrationTests2/targets/tests-disabled/p.cabal - tests/IntegrationTests2/targets/tests-disabled/q/q.cabal - tests/IntegrationTests2/targets/variety/cabal.project - tests/IntegrationTests2/targets/variety/p.cabal - -- END gen-extra-source-files - - -- Additional manual extra-source-files: - tests/IntegrationTests2/build/local-tarball/p-0.1.tar.gz - - -source-repository head - type: git - location: https://github.com/haskell/cabal/ - subdir: cabal-install - -Flag native-dns - description: Enable use of the [resolv](https://hackage.haskell.org/package/resolv) & [windns](https://hackage.haskell.org/package/windns) packages for performing DNS lookups - default: True - manual: True - -Flag debug-expensive-assertions - description: Enable expensive assertions for testing or debugging - default: False - manual: True - -Flag debug-conflict-sets - description: Add additional information to ConflictSets - default: False - manual: True - -Flag debug-tracetree - description: Compile in support for tracetree (used to debug the solver) - default: False - manual: True - -Flag lukko - description: Use @lukko@ for file-locking - default: True - manual: True - -executable cabal - main-is: Main.hs - hs-source-dirs: main - default-language: Haskell2010 - ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns - if impl(ghc >= 8.0) - ghc-options: -Wcompat - -Wnoncanonical-monad-instances - if impl(ghc < 8.8) - ghc-options: -Wnoncanonical-monadfail-instances - - - ghc-options: -rtsopts -threaded - - -- On AIX, some legacy BSD operations such as flock(2) are provided by libbsd.a - if os(aix) - extra-libraries: bsd - hs-source-dirs: . - other-modules: - -- this modules are moved from Cabal - -- they are needed for as long until cabal-install moves to parsec parser - Distribution.Deprecated.ParseUtils - Distribution.Deprecated.ReadP - Distribution.Deprecated.ViewAsFieldDescr - - Distribution.Client.BuildReports.Anonymous - Distribution.Client.BuildReports.Lens - Distribution.Client.BuildReports.Storage - Distribution.Client.BuildReports.Types - Distribution.Client.BuildReports.Upload - Distribution.Client.Check - Distribution.Client.CmdBench - Distribution.Client.CmdBuild - Distribution.Client.CmdClean - Distribution.Client.CmdConfigure - Distribution.Client.CmdErrorMessages - Distribution.Client.CmdExec - Distribution.Client.CmdFreeze - Distribution.Client.CmdHaddock - Distribution.Client.CmdInstall - Distribution.Client.CmdInstall.ClientInstallFlags - Distribution.Client.CmdInstall.ClientInstallTargetSelector - Distribution.Client.CmdLegacy - Distribution.Client.CmdListBin - Distribution.Client.CmdRepl - Distribution.Client.CmdRun - Distribution.Client.CmdSdist - Distribution.Client.CmdTest - Distribution.Client.CmdUpdate - Distribution.Client.Compat.Directory - Distribution.Client.Compat.ExecutablePath - Distribution.Client.Compat.FilePerms - Distribution.Client.Compat.Orphans - Distribution.Client.Compat.Prelude - Distribution.Client.Compat.Process - Distribution.Client.Compat.Semaphore - Distribution.Client.Config - Distribution.Client.Configure - Distribution.Client.Dependency - Distribution.Client.Dependency.Types - Distribution.Client.DistDirLayout - Distribution.Client.Exec - Distribution.Client.Fetch - Distribution.Client.FetchUtils - Distribution.Client.FileMonitor - Distribution.Client.Freeze - Distribution.Client.GZipUtils - Distribution.Client.GenBounds - Distribution.Client.Get - Distribution.Client.Glob - Distribution.Client.GlobalFlags - Distribution.Client.Haddock - Distribution.Client.HashValue - Distribution.Client.HttpUtils - Distribution.Client.IndexUtils - Distribution.Client.IndexUtils.ActiveRepos - Distribution.Client.IndexUtils.IndexState - Distribution.Client.IndexUtils.Timestamp - Distribution.Client.Init - Distribution.Client.Init.Command - Distribution.Client.Init.Defaults - Distribution.Client.Init.FileCreators - Distribution.Client.Init.Heuristics - Distribution.Client.Init.Licenses - Distribution.Client.Init.Prompt - Distribution.Client.Init.Types - Distribution.Client.Init.Utils - Distribution.Client.Install - Distribution.Client.InstallPlan - Distribution.Client.InstallSymlink - Distribution.Client.JobControl - Distribution.Client.List - Distribution.Client.Manpage - Distribution.Client.ManpageFlags - Distribution.Client.Nix - Distribution.Client.NixStyleOptions - Distribution.Client.Outdated - Distribution.Client.PackageHash - Distribution.Client.ParseUtils - Distribution.Client.ProjectBuilding - Distribution.Client.ProjectBuilding.Types - Distribution.Client.ProjectConfig - Distribution.Client.ProjectConfig.Legacy - Distribution.Client.ProjectConfig.Types - Distribution.Client.ProjectFlags - Distribution.Client.ProjectOrchestration - Distribution.Client.ProjectPlanOutput - Distribution.Client.ProjectPlanning - Distribution.Client.ProjectPlanning.Types - Distribution.Client.RebuildMonad - Distribution.Client.Reconfigure - Distribution.Client.Run - Distribution.Client.Sandbox - Distribution.Client.Sandbox.PackageEnvironment - Distribution.Client.SavedFlags - Distribution.Client.Security.DNS - Distribution.Client.Security.HTTP - Distribution.Client.Setup - Distribution.Client.SetupWrapper - Distribution.Client.SolverInstallPlan - Distribution.Client.SourceFiles - Distribution.Client.SrcDist - Distribution.Client.Store - Distribution.Client.Tar - Distribution.Client.TargetProblem - Distribution.Client.TargetSelector - Distribution.Client.Targets - 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.InstallMethod - Distribution.Client.Types.OverwritePolicy - Distribution.Client.Types.PackageLocation - Distribution.Client.Types.PackageSpecifier - Distribution.Client.Types.ReadyPackage - Distribution.Client.Types.Repo - Distribution.Client.Types.RepoName - Distribution.Client.Types.SourcePackageDb - Distribution.Client.Types.SourceRepo - Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy - Distribution.Client.Update - Distribution.Client.Upload - Distribution.Client.Utils - Distribution.Client.Utils.Assertion - Distribution.Client.Utils.Json - Distribution.Client.Utils.Parsec - Distribution.Client.VCS - Distribution.Client.Win32SelfUpgrade - Distribution.Client.World - Distribution.Solver.Compat.Prelude - Distribution.Solver.Modular - Distribution.Solver.Modular.Assignment - Distribution.Solver.Modular.Builder - Distribution.Solver.Modular.Configured - Distribution.Solver.Modular.ConfiguredConversion - Distribution.Solver.Modular.ConflictSet - Distribution.Solver.Modular.Cycles - Distribution.Solver.Modular.Dependency - Distribution.Solver.Modular.Explore - Distribution.Solver.Modular.Flag - Distribution.Solver.Modular.Index - Distribution.Solver.Modular.IndexConversion - Distribution.Solver.Modular.LabeledGraph - Distribution.Solver.Modular.Linking - Distribution.Solver.Modular.Log - Distribution.Solver.Modular.Message - Distribution.Solver.Modular.PSQ - Distribution.Solver.Modular.Package - Distribution.Solver.Modular.Preference - Distribution.Solver.Modular.RetryLog - Distribution.Solver.Modular.Solver - Distribution.Solver.Modular.Tree - Distribution.Solver.Modular.Validate - Distribution.Solver.Modular.Var - Distribution.Solver.Modular.Version - Distribution.Solver.Modular.WeightedPSQ - Distribution.Solver.Types.ComponentDeps - Distribution.Solver.Types.ConstraintSource - Distribution.Solver.Types.DependencyResolver - Distribution.Solver.Types.Flag - Distribution.Solver.Types.InstSolverPackage - Distribution.Solver.Types.InstalledPreference - Distribution.Solver.Types.LabeledPackageConstraint - Distribution.Solver.Types.OptionalStanza - Distribution.Solver.Types.PackageConstraint - Distribution.Solver.Types.PackageFixedDeps - Distribution.Solver.Types.PackageIndex - Distribution.Solver.Types.PackagePath - Distribution.Solver.Types.PackagePreferences - Distribution.Solver.Types.PkgConfigDb - Distribution.Solver.Types.Progress - Distribution.Solver.Types.ResolverPackage - Distribution.Solver.Types.Settings - Distribution.Solver.Types.SolverId - Distribution.Solver.Types.SolverPackage - Distribution.Solver.Types.SourcePackage - Distribution.Solver.Types.Variable - Paths_cabal_install - - build-depends: - async >= 2.0 && < 2.3, - array >= 0.4 && < 0.6, - base >= 4.8 && < 4.15, - base16-bytestring >= 0.1.1 && < 0.2, - binary >= 0.7.3 && < 0.9, - bytestring >= 0.10.6.0 && < 0.11, - Cabal == 3.3.*, - containers >= 0.5.6.2 && < 0.7, - cryptohash-sha256 >= 0.11 && < 0.12, - deepseq >= 1.4.1.1 && < 1.5, - directory >= 1.2.2.0 && < 1.4, - echo >= 0.1.3 && < 0.2, - edit-distance >= 0.2.2 && < 0.3, - filepath >= 1.4.0.0 && < 1.5, - hashable >= 1.0 && < 1.4, - HTTP >= 4000.1.5 && < 4000.4, - mtl >= 2.0 && < 2.3, - network-uri >= 2.6.0.2 && < 2.7, - network >= 2.6 && < 3.2, - pretty >= 1.1 && < 1.2, - process >= 1.2.3.0 && < 1.7, - random >= 1 && < 1.2, - stm >= 2.0 && < 2.6, - tar >= 0.5.0.3 && < 0.6, - time >= 1.5.0.1 && < 1.11, - transformers >= 0.4.2.0 && < 0.6, - zlib >= 0.5.3 && < 0.7, - hackage-security >= 0.6.0.1 && < 0.7, - text >= 1.2.3 && < 1.3, - parsec >= 3.1.13.0 && < 3.2, - regex-base >= 0.94.0.0 && <0.95, - regex-posix >= 0.96.0.0 && <0.97 - - if !impl(ghc >= 8.0) - build-depends: fail == 4.9.* - build-depends: semigroups >= 0.18.3 && <0.20 - - if flag(native-dns) - if os(windows) - build-depends: windns >= 0.1.0 && < 0.2 - else - build-depends: resolv >= 0.1.1 && < 0.2 - - if os(windows) - -- newer directory for symlinks - build-depends: Win32 >= 2 && < 3, directory >=1.3.1.0 - else - build-depends: unix >= 2.5 && < 2.9 - - if flag(lukko) - build-depends: lukko >= 0.1 && <0.2 - else - build-depends: base >= 4.10 - - if flag(debug-expensive-assertions) - cpp-options: -DDEBUG_EXPENSIVE_ASSERTIONS - - if flag(debug-conflict-sets) - cpp-options: -DDEBUG_CONFLICT_SETS - build-depends: base >= 4.8 - - if flag(debug-tracetree) - cpp-options: -DDEBUG_TRACETREE - build-depends: tracetree >= 0.1 && < 0.2 diff --git a/cabal/cabal-install/cabal-install.cabal.zinza b/cabal/cabal-install/cabal-install.cabal.zinza deleted file mode 100644 --- a/cabal/cabal-install/cabal-install.cabal.zinza +++ /dev/null @@ -1,616 +0,0 @@ -{# lib enabled means that we have internal library: cabal-lib-client #} -{% if dev %} -Cabal-Version: 2.0 -{% else %} -Cabal-Version: >= 1.10 -{% endif %} --- NOTE: This file is autogenerated from 'cabal-install.cabal.pp'. --- DO NOT EDIT MANUALLY. --- To update this file, edit 'cabal-install.cabal.pp' and run --- 'make cabal-install-prod' in the project's root folder. -Name: cabal-install -Version: 3.3.0.0 -{# NOTE: when updating build-depends, don't forget to update version regexps in bootstrap.sh. #} -{% defblock buildDepends %} - build-depends: - async >= 2.0 && < 2.3, - array >= 0.4 && < 0.6, - base >= 4.8 && < 4.15, - base16-bytestring >= 0.1.1 && < 0.2, - binary >= 0.7.3 && < 0.9, - bytestring >= 0.10.6.0 && < 0.11, - Cabal == 3.3.*, - containers >= 0.5.6.2 && < 0.7, - cryptohash-sha256 >= 0.11 && < 0.12, - deepseq >= 1.4.1.1 && < 1.5, - directory >= 1.2.2.0 && < 1.4, - echo >= 0.1.3 && < 0.2, - edit-distance >= 0.2.2 && < 0.3, - filepath >= 1.4.0.0 && < 1.5, - hashable >= 1.0 && < 1.4, - HTTP >= 4000.1.5 && < 4000.4, - mtl >= 2.0 && < 2.3, - network-uri >= 2.6.0.2 && < 2.7, - network >= 2.6 && < 3.2, - pretty >= 1.1 && < 1.2, - process >= 1.2.3.0 && < 1.7, - random >= 1 && < 1.2, - stm >= 2.0 && < 2.6, - tar >= 0.5.0.3 && < 0.6, - time >= 1.5.0.1 && < 1.11, - transformers >= 0.4.2.0 && < 0.6, - zlib >= 0.5.3 && < 0.7, - hackage-security >= 0.6.0.1 && < 0.7, - text >= 1.2.3 && < 1.3, - parsec >= 3.1.13.0 && < 3.2, - regex-base >= 0.94.0.0 && <0.95, - regex-posix >= 0.96.0.0 && <0.97 - - if !impl(ghc >= 8.0) - build-depends: fail == 4.9.* - build-depends: semigroups >= 0.18.3 && <0.20 - - if flag(native-dns) - if os(windows) - build-depends: windns >= 0.1.0 && < 0.2 - else - build-depends: resolv >= 0.1.1 && < 0.2 - - if os(windows) - -- newer directory for symlinks - build-depends: Win32 >= 2 && < 3, directory >=1.3.1.0 - else - build-depends: unix >= 2.5 && < 2.9 - - if flag(lukko) - build-depends: lukko >= 0.1 && <0.2 - else - build-depends: base >= 4.10 -{% endblock %} -{% defblock componentCommon %} - default-language: Haskell2010 - ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns - if impl(ghc >= 8.0) - ghc-options: -Wcompat - -Wnoncanonical-monad-instances - if impl(ghc < 8.8) - ghc-options: -Wnoncanonical-monadfail-instances - -{% endblock %} -{% defblock buildInfo %} -{% if dev %} - exposed-modules: -{% else %} - other-modules: -{% endif %} - -- this modules are moved from Cabal - -- they are needed for as long until cabal-install moves to parsec parser - Distribution.Deprecated.ParseUtils - Distribution.Deprecated.ReadP - Distribution.Deprecated.ViewAsFieldDescr - - Distribution.Client.BuildReports.Anonymous - Distribution.Client.BuildReports.Lens - Distribution.Client.BuildReports.Storage - Distribution.Client.BuildReports.Types - Distribution.Client.BuildReports.Upload - Distribution.Client.Check - Distribution.Client.CmdBench - Distribution.Client.CmdBuild - Distribution.Client.CmdClean - Distribution.Client.CmdConfigure - Distribution.Client.CmdErrorMessages - Distribution.Client.CmdExec - Distribution.Client.CmdFreeze - Distribution.Client.CmdHaddock - Distribution.Client.CmdInstall - Distribution.Client.CmdInstall.ClientInstallFlags - Distribution.Client.CmdInstall.ClientInstallTargetSelector - Distribution.Client.CmdLegacy - Distribution.Client.CmdListBin - Distribution.Client.CmdRepl - Distribution.Client.CmdRun - Distribution.Client.CmdSdist - Distribution.Client.CmdTest - Distribution.Client.CmdUpdate - Distribution.Client.Compat.Directory - Distribution.Client.Compat.ExecutablePath - Distribution.Client.Compat.FilePerms - Distribution.Client.Compat.Orphans - Distribution.Client.Compat.Prelude - Distribution.Client.Compat.Process - Distribution.Client.Compat.Semaphore - Distribution.Client.Config - Distribution.Client.Configure - Distribution.Client.Dependency - Distribution.Client.Dependency.Types - Distribution.Client.DistDirLayout - Distribution.Client.Exec - Distribution.Client.Fetch - Distribution.Client.FetchUtils - Distribution.Client.FileMonitor - Distribution.Client.Freeze - Distribution.Client.GZipUtils - Distribution.Client.GenBounds - Distribution.Client.Get - Distribution.Client.Glob - Distribution.Client.GlobalFlags - Distribution.Client.Haddock - Distribution.Client.HashValue - Distribution.Client.HttpUtils - Distribution.Client.IndexUtils - Distribution.Client.IndexUtils.ActiveRepos - Distribution.Client.IndexUtils.IndexState - Distribution.Client.IndexUtils.Timestamp - Distribution.Client.Init - Distribution.Client.Init.Command - Distribution.Client.Init.Defaults - Distribution.Client.Init.FileCreators - Distribution.Client.Init.Heuristics - Distribution.Client.Init.Licenses - Distribution.Client.Init.Prompt - Distribution.Client.Init.Types - Distribution.Client.Init.Utils - Distribution.Client.Install - Distribution.Client.InstallPlan - Distribution.Client.InstallSymlink - Distribution.Client.JobControl - Distribution.Client.List - Distribution.Client.Manpage - Distribution.Client.ManpageFlags - Distribution.Client.Nix - Distribution.Client.NixStyleOptions - Distribution.Client.Outdated - Distribution.Client.PackageHash - Distribution.Client.ParseUtils - Distribution.Client.ProjectBuilding - Distribution.Client.ProjectBuilding.Types - Distribution.Client.ProjectConfig - Distribution.Client.ProjectConfig.Legacy - Distribution.Client.ProjectConfig.Types - Distribution.Client.ProjectFlags - Distribution.Client.ProjectOrchestration - Distribution.Client.ProjectPlanOutput - Distribution.Client.ProjectPlanning - Distribution.Client.ProjectPlanning.Types - Distribution.Client.RebuildMonad - Distribution.Client.Reconfigure - Distribution.Client.Run - Distribution.Client.Sandbox - Distribution.Client.Sandbox.PackageEnvironment - Distribution.Client.SavedFlags - Distribution.Client.Security.DNS - Distribution.Client.Security.HTTP - Distribution.Client.Setup - Distribution.Client.SetupWrapper - Distribution.Client.SolverInstallPlan - Distribution.Client.SourceFiles - Distribution.Client.SrcDist - Distribution.Client.Store - Distribution.Client.Tar - Distribution.Client.TargetProblem - Distribution.Client.TargetSelector - Distribution.Client.Targets - 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.InstallMethod - Distribution.Client.Types.OverwritePolicy - Distribution.Client.Types.PackageLocation - Distribution.Client.Types.PackageSpecifier - Distribution.Client.Types.ReadyPackage - Distribution.Client.Types.Repo - Distribution.Client.Types.RepoName - Distribution.Client.Types.SourcePackageDb - Distribution.Client.Types.SourceRepo - Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy - Distribution.Client.Update - Distribution.Client.Upload - Distribution.Client.Utils - Distribution.Client.Utils.Assertion - Distribution.Client.Utils.Json - Distribution.Client.Utils.Parsec - Distribution.Client.VCS - Distribution.Client.Win32SelfUpgrade - Distribution.Client.World - Distribution.Solver.Compat.Prelude - Distribution.Solver.Modular - Distribution.Solver.Modular.Assignment - Distribution.Solver.Modular.Builder - Distribution.Solver.Modular.Configured - Distribution.Solver.Modular.ConfiguredConversion - Distribution.Solver.Modular.ConflictSet - Distribution.Solver.Modular.Cycles - Distribution.Solver.Modular.Dependency - Distribution.Solver.Modular.Explore - Distribution.Solver.Modular.Flag - Distribution.Solver.Modular.Index - Distribution.Solver.Modular.IndexConversion - Distribution.Solver.Modular.LabeledGraph - Distribution.Solver.Modular.Linking - Distribution.Solver.Modular.Log - Distribution.Solver.Modular.Message - Distribution.Solver.Modular.PSQ - Distribution.Solver.Modular.Package - Distribution.Solver.Modular.Preference - Distribution.Solver.Modular.RetryLog - Distribution.Solver.Modular.Solver - Distribution.Solver.Modular.Tree - Distribution.Solver.Modular.Validate - Distribution.Solver.Modular.Var - Distribution.Solver.Modular.Version - Distribution.Solver.Modular.WeightedPSQ - Distribution.Solver.Types.ComponentDeps - Distribution.Solver.Types.ConstraintSource - Distribution.Solver.Types.DependencyResolver - Distribution.Solver.Types.Flag - Distribution.Solver.Types.InstSolverPackage - Distribution.Solver.Types.InstalledPreference - Distribution.Solver.Types.LabeledPackageConstraint - Distribution.Solver.Types.OptionalStanza - Distribution.Solver.Types.PackageConstraint - Distribution.Solver.Types.PackageFixedDeps - Distribution.Solver.Types.PackageIndex - Distribution.Solver.Types.PackagePath - Distribution.Solver.Types.PackagePreferences - Distribution.Solver.Types.PkgConfigDb - Distribution.Solver.Types.Progress - Distribution.Solver.Types.ResolverPackage - Distribution.Solver.Types.Settings - Distribution.Solver.Types.SolverId - Distribution.Solver.Types.SolverPackage - Distribution.Solver.Types.SourcePackage - Distribution.Solver.Types.Variable - Paths_cabal_install - -{% if dev %} - autogen-modules: - Paths_cabal_install -{% endif %} -{% useblock buildDepends %} - - if flag(debug-expensive-assertions) - cpp-options: -DDEBUG_EXPENSIVE_ASSERTIONS - - if flag(debug-conflict-sets) - cpp-options: -DDEBUG_CONFLICT_SETS - build-depends: base >= 4.8 - - if flag(debug-tracetree) - cpp-options: -DDEBUG_TRACETREE - build-depends: tracetree >= 0.1 && < 0.2 -{% endblock %} -{############################################################################} -{# Package Description #} -{############################################################################} -Synopsis: The command-line interface for Cabal and Hackage. -Description: - The \'cabal\' command-line program simplifies the process of managing - Haskell software by automating the fetching, configuration, compilation - and installation of Haskell libraries and programs. -homepage: http://www.haskell.org/cabal/ -bug-reports: https://github.com/haskell/cabal/issues -License: BSD3 -License-File: LICENSE -Author: Cabal Development Team (see AUTHORS file) -Maintainer: Cabal Development Team -Copyright: 2003-2020, Cabal Development Team -Category: Distribution -Build-type: Simple -Extra-Source-Files: - README.md bash-completion/cabal bootstrap.sh changelog - - -- Generated with 'make gen-extra-source-files' - -- Do NOT edit this section manually; instead, run the script. - -- BEGIN gen-extra-source-files - tests/IntegrationTests2/build/keep-going/cabal.project - tests/IntegrationTests2/build/keep-going/p/P.hs - tests/IntegrationTests2/build/keep-going/p/p.cabal - tests/IntegrationTests2/build/keep-going/q/Q.hs - tests/IntegrationTests2/build/keep-going/q/q.cabal - tests/IntegrationTests2/build/local-tarball/cabal.project - tests/IntegrationTests2/build/local-tarball/q/Q.hs - tests/IntegrationTests2/build/local-tarball/q/q.cabal - tests/IntegrationTests2/build/setup-custom1/A.hs - tests/IntegrationTests2/build/setup-custom1/Setup.hs - tests/IntegrationTests2/build/setup-custom1/a.cabal - tests/IntegrationTests2/build/setup-custom2/A.hs - tests/IntegrationTests2/build/setup-custom2/Setup.hs - tests/IntegrationTests2/build/setup-custom2/a.cabal - tests/IntegrationTests2/build/setup-simple/A.hs - tests/IntegrationTests2/build/setup-simple/Setup.hs - tests/IntegrationTests2/build/setup-simple/a.cabal - tests/IntegrationTests2/exception/bad-config/cabal.project - tests/IntegrationTests2/exception/build/Main.hs - tests/IntegrationTests2/exception/build/a.cabal - tests/IntegrationTests2/exception/configure/a.cabal - tests/IntegrationTests2/exception/no-pkg/empty.in - tests/IntegrationTests2/exception/no-pkg2/cabal.project - tests/IntegrationTests2/regression/3324/cabal.project - tests/IntegrationTests2/regression/3324/p/P.hs - tests/IntegrationTests2/regression/3324/p/p.cabal - tests/IntegrationTests2/regression/3324/q/Q.hs - tests/IntegrationTests2/regression/3324/q/q.cabal - tests/IntegrationTests2/targets/all-disabled/cabal.project - tests/IntegrationTests2/targets/all-disabled/p.cabal - tests/IntegrationTests2/targets/benchmarks-disabled/cabal.project - tests/IntegrationTests2/targets/benchmarks-disabled/p.cabal - tests/IntegrationTests2/targets/benchmarks-disabled/q/q.cabal - tests/IntegrationTests2/targets/complex/cabal.project - tests/IntegrationTests2/targets/complex/q/Q.hs - tests/IntegrationTests2/targets/complex/q/q.cabal - tests/IntegrationTests2/targets/empty-pkg/cabal.project - tests/IntegrationTests2/targets/empty-pkg/p.cabal - tests/IntegrationTests2/targets/empty/cabal.project - tests/IntegrationTests2/targets/empty/foo.hs - tests/IntegrationTests2/targets/exes-disabled/cabal.project - tests/IntegrationTests2/targets/exes-disabled/p/p.cabal - tests/IntegrationTests2/targets/exes-disabled/q/q.cabal - tests/IntegrationTests2/targets/lib-only/p.cabal - tests/IntegrationTests2/targets/libs-disabled/cabal.project - tests/IntegrationTests2/targets/libs-disabled/p/p.cabal - tests/IntegrationTests2/targets/libs-disabled/q/q.cabal - tests/IntegrationTests2/targets/multiple-exes/cabal.project - tests/IntegrationTests2/targets/multiple-exes/p.cabal - tests/IntegrationTests2/targets/multiple-libs/cabal.project - tests/IntegrationTests2/targets/multiple-libs/p/p.cabal - tests/IntegrationTests2/targets/multiple-libs/q/q.cabal - tests/IntegrationTests2/targets/multiple-tests/cabal.project - tests/IntegrationTests2/targets/multiple-tests/p.cabal - tests/IntegrationTests2/targets/simple/P.hs - tests/IntegrationTests2/targets/simple/app/Main.hs - tests/IntegrationTests2/targets/simple/cabal.project - tests/IntegrationTests2/targets/simple/p.cabal - tests/IntegrationTests2/targets/simple/q/Q.hs - tests/IntegrationTests2/targets/simple/q/QQ.hs - tests/IntegrationTests2/targets/simple/q/q.cabal - tests/IntegrationTests2/targets/test-only/p.cabal - tests/IntegrationTests2/targets/tests-disabled/cabal.project - tests/IntegrationTests2/targets/tests-disabled/p.cabal - tests/IntegrationTests2/targets/tests-disabled/q/q.cabal - tests/IntegrationTests2/targets/variety/cabal.project - tests/IntegrationTests2/targets/variety/p.cabal - -- END gen-extra-source-files - - -- Additional manual extra-source-files: - tests/IntegrationTests2/build/local-tarball/p-0.1.tar.gz - - -source-repository head - type: git - location: https://github.com/haskell/cabal/ - subdir: cabal-install - -Flag native-dns - description: Enable use of the [resolv](https://hackage.haskell.org/package/resolv) & [windns](https://hackage.haskell.org/package/windns) packages for performing DNS lookups - default: True - manual: True - -Flag debug-expensive-assertions - description: Enable expensive assertions for testing or debugging - default: False - manual: True - -Flag debug-conflict-sets - description: Add additional information to ConflictSets - default: False - manual: True - -Flag debug-tracetree - description: Compile in support for tracetree (used to debug the solver) - default: False - manual: True - -Flag lukko - description: Use @lukko@ for file-locking - default: True - manual: True - -{############################################################################} -{# Libraries, if dev #} -{############################################################################} -{% if dev %} -library cabal-lib-client -{% useblock componentCommon %} - hs-source-dirs: . -{% useblock buildInfo %} - -library cabal-install-solver-dsl -{% useblock componentCommon %} - hs-source-dirs: solver-dsl - exposed-modules: - UnitTests.Distribution.Solver.Modular.DSL - build-depends: - base, - Cabal, - containers, - -- TODO: depend on cabal-install-solver only - cabal-lib-client -{% endif %} -{############################################################################} -{# Executable #} -{############################################################################} -executable cabal - main-is: Main.hs - hs-source-dirs: main -{% useblock componentCommon %} - - ghc-options: -rtsopts -threaded - - -- On AIX, some legacy BSD operations such as flock(2) are provided by libbsd.a - if os(aix) - extra-libraries: bsd -{% if dev %} - build-depends: - cabal-lib-client, - Cabal, - base, - directory, - filepath - - other-modules: Paths_cabal_install -{% else %} - hs-source-dirs: . -{% useblock buildInfo %} -{% endif %} -{############################################################################} -{# Test-suites #} -{# disable if we don't configure with an (internal) libs #} -{############################################################################} -{% if dev %} --- Small, fast running tests. --- -Test-Suite unit-tests - type: exitcode-stdio-1.0 - main-is: UnitTests.hs - hs-source-dirs: tests - ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -main-is UnitTests - other-modules: - UnitTests.Distribution.Client.ArbitraryInstances - UnitTests.Distribution.Client.BuildReport - UnitTests.Distribution.Client.Described - UnitTests.Distribution.Client.DescribedInstances - UnitTests.Distribution.Client.Targets - UnitTests.Distribution.Client.FileMonitor - UnitTests.Distribution.Client.Get - UnitTests.Distribution.Client.Glob - UnitTests.Distribution.Client.GZipUtils - UnitTests.Distribution.Client.Init.FileCreators - UnitTests.Distribution.Client.Store - UnitTests.Distribution.Client.Tar - UnitTests.Distribution.Client.TreeDiffInstances - UnitTests.Distribution.Client.UserConfig - UnitTests.Distribution.Client.ProjectConfig - UnitTests.Distribution.Client.JobControl - UnitTests.Distribution.Client.IndexUtils.Timestamp - UnitTests.Distribution.Client.InstallPlan - UnitTests.Distribution.Client.VCS - UnitTests.Distribution.Solver.Modular.Builder - UnitTests.Distribution.Solver.Modular.RetryLog - UnitTests.Distribution.Solver.Modular.Solver - UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils - UnitTests.Distribution.Solver.Modular.WeightedPSQ - UnitTests.Options - UnitTests.TempTestDir - build-depends: - array, - base, - async, - bytestring, - cabal-lib-client, - cabal-install-solver-dsl, - Cabal, - Cabal-described, - Cabal-tree-diff, - Cabal-QuickCheck, - containers, - deepseq, - mtl, - random, - directory, - filepath, - tar, - time, - zlib, - network-uri >= 2.6.2.0 && <2.6.4.0, - network, - tasty >= 1.2.3 && <1.4, - tasty-golden >=2.3.1.1 && <2.4, - tasty-hunit >= 0.10, - tasty-quickcheck, - tagged, - tree-diff, - QuickCheck >= 2.14 && <2.15 - - ghc-options: -threaded - - default-language: Haskell2010 - --- Tests to run with a limited stack and heap size --- -Test-Suite memory-usage-tests - type: exitcode-stdio-1.0 - main-is: MemoryUsageTests.hs - hs-source-dirs: tests - ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns "-with-rtsopts=-M4M -K1K" -main-is MemoryUsageTests - other-modules: - UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils - UnitTests.Distribution.Solver.Modular.MemoryUsage - UnitTests.Options - build-depends: - base, - async, - Cabal, - cabal-lib-client, - cabal-install-solver-dsl, - containers, - deepseq, - tagged, - tasty >= 1.2.3 && <1.4, - tasty-hunit >= 0.10 - - ghc-options: -threaded - - default-language: Haskell2010 - --- Slow solver tests --- -Test-Suite solver-quickcheck - type: exitcode-stdio-1.0 - main-is: SolverQuickCheck.hs - hs-source-dirs: tests - ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -main-is SolverQuickCheck - other-modules: - UnitTests.Distribution.Solver.Modular.QuickCheck - UnitTests.Distribution.Solver.Modular.QuickCheck.Utils - build-depends: - base, - async, - Cabal, - Cabal-QuickCheck, - cabal-lib-client, - cabal-install-solver-dsl, - containers, - deepseq >= 1.2, - hashable, - random, - tagged, - tasty >= 1.2.3 && <1.4, - tasty-quickcheck, - QuickCheck >= 2.14 && <2.15, - pretty-show >= 1.6.15 - - ghc-options: -threaded - - default-language: Haskell2010 - - --- Integration tests that use the cabal-install code directly --- but still build whole projects -test-suite integration-tests2 - type: exitcode-stdio-1.0 - main-is: IntegrationTests2.hs - hs-source-dirs: tests - ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -main-is IntegrationTests2 - other-modules: - build-depends: - base, - bytestring, - Cabal, - cabal-lib-client, - containers, - deepseq, - directory, - edit-distance, - filepath, - tasty >= 1.2.3 && <1.4, - tasty-hunit >= 0.10, - tagged - - ghc-options: -threaded - default-language: Haskell2010 - -{% endif %} diff --git a/cabal/cabal-install/changelog b/cabal/cabal-install/changelog --- a/cabal/cabal-install/changelog +++ b/cabal/cabal-install/changelog @@ -1,5 +1,20 @@ -*-change-log-*- +3.8.1.0 Mikolaj Konarski August 2022 + * See https://github.com/haskell/cabal/blob/master/release-notes/cabal-install-3.8.1.0.md + +3.6.2.0 Emily Pillmore October 2021 + * See https://github.com/haskell/cabal/blob/master/release-notes/cabal-install-3.6.2.0.md + +3.6.0.0 Emily Pillmore August 2021 + * See https://github.com/haskell/cabal/blob/master/release-notes/cabal-install-3.6.0.0.md + +3.4.1.0 Emily Pillmore October 2021 + * See https://github.com/haskell/cabal/blob/master/release-notes/cabal-install-3.4.1.0.md + +3.4.0.0 Oleg Grenrus February 2021 + * See https://github.com/haskell/cabal/blob/master/release-notes/cabal-install-3.4.0.0.md + 3.2.0.0 Herbert Valerio Riedel April 2020 * `v2-build` (and other `v2-`prefixed commands) now accept the `--benchmark-option(s)` flags, which pass options to benchmark executables diff --git a/cabal/cabal-install/main/Main.hs b/cabal/cabal-install/main/Main.hs --- a/cabal/cabal-install/main/Main.hs +++ b/cabal/cabal-install/main/Main.hs @@ -28,11 +28,9 @@ , FetchFlags(..), fetchCommand , FreezeFlags(..), freezeCommand , genBoundsCommand - , OutdatedFlags(..), outdatedCommand , GetFlags(..), getCommand, unpackCommand , checkCommand , formatCommand - , UpdateFlags(..), updateCommand , ListFlags(..), listCommand, listNeedsCompiler , InfoFlags(..), infoCommand , UploadFlags(..), uploadCommand @@ -40,19 +38,16 @@ , runCommand , InitFlags(initVerbosity, initHcPath), initCommand , ActAsSetupFlags(..), actAsSetupCommand - , ExecFlags(..), execCommand , UserConfigFlags(..), userConfigCommand , reportCommand , manpageCommand , haddockCommand , cleanCommand - , doctestCommand , copyCommand , registerCommand ) import Distribution.Simple.Setup ( HaddockTarget(..) - , DoctestFlags(..) , HaddockFlags(..), defaultHaddockFlags , HscolourFlags(..), hscolourCommand , ReplFlags(..) @@ -65,7 +60,7 @@ ) import Prelude () -import Distribution.Solver.Compat.Prelude hiding (get) +import Distribution.Client.Compat.Prelude hiding (get) import Distribution.Client.SetupWrapper ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) @@ -91,16 +86,14 @@ import qualified Distribution.Client.CmdClean as CmdClean import qualified Distribution.Client.CmdSdist as CmdSdist import qualified Distribution.Client.CmdListBin as CmdListBin +import qualified Distribution.Client.CmdOutdated as CmdOutdated import Distribution.Client.CmdLegacy import Distribution.Client.Install (install) import Distribution.Client.Configure (configure, writeConfigFlags) -import Distribution.Client.Update (update) -import Distribution.Client.Exec (exec) import Distribution.Client.Fetch (fetch) import Distribution.Client.Freeze (freeze) import Distribution.Client.GenBounds (genBounds) -import Distribution.Client.Outdated (outdated) import Distribution.Client.Check as Check (check) --import Distribution.Client.Clean (clean) import qualified Distribution.Client.Upload as Upload @@ -112,21 +105,20 @@ ) import Distribution.Client.Sandbox (loadConfigOrSandboxConfig ,findSavedDistPref - ,updateInstallDirs - ,getPersistOrConfigCompiler) + ,updateInstallDirs) import Distribution.Client.Tar (createTarGzFile) import Distribution.Client.Types.Credentials (Password (..)) -import Distribution.Client.Init (initCabal) +import Distribution.Client.Init (initCmd) import Distribution.Client.Manpage (manpageCmd) import Distribution.Client.ManpageFlags (ManpageFlags (..)) -import Distribution.Client.Utils (determineNumJobs - ,relaxEncodingErrors - ) +import Distribution.Client.Utils + ( determineNumJobs, relaxEncodingErrors ) +import Distribution.Client.Version + ( cabalInstallVersion ) import Distribution.Package (packageId) import Distribution.PackageDescription ( BuildType(..), Executable(..), buildable ) -import Distribution.PackageDescription.Parsec ( readGenericPackageDescription ) import Distribution.PackageDescription.PrettyPrint ( writeGenericPackageDescription ) @@ -145,6 +137,7 @@ , getPersistBuildConfig, interpretPackageDbFlags , tryGetPersistBuildConfig ) import qualified Distribution.Simple.LocalBuildInfo as LBI +import Distribution.Simple.PackageDescription ( readGenericPackageDescription ) import Distribution.Simple.Program (defaultProgramDb ,configureAllKnownPrograms ,simpleProgramInvocation @@ -153,14 +146,13 @@ import qualified Distribution.Simple.Setup as Cabal import Distribution.Simple.Utils ( cabalVersion, die', dieNoVerbosity, info, notice, topHandler - , findPackageDesc, tryFindPackageDesc ) + , findPackageDesc, tryFindPackageDesc, createDirectoryIfMissingVerbose ) import Distribution.Text ( display ) import Distribution.Verbosity as Verbosity - ( Verbosity, normal ) + ( normal ) import Distribution.Version ( Version, mkVersion, orLaterVersion ) -import qualified Paths_cabal_install (version) import Distribution.Compat.ResponseFile import System.Environment (getArgs, getProgName) @@ -168,11 +160,12 @@ , takeExtension, (), (<.>) ) import System.IO ( BufferMode(LineBuffering), hSetBuffering , stderr, stdout ) -import System.Directory (doesFileExist, getCurrentDirectory) +import System.Directory ( doesFileExist, getCurrentDirectory + , withCurrentDirectory) import Data.Monoid (Any(..)) import Control.Exception (try) -import Data.Version (showVersion) + -- | Entry point -- main :: IO () @@ -227,9 +220,9 @@ ++ "defaults if you run 'cabal update'." printOptionsList = putStr . unlines printErrors errs = dieNoVerbosity $ intercalate "\n" errs - printNumericVersion = putStrLn $ showVersion Paths_cabal_install.version + printNumericVersion = putStrLn $ display cabalInstallVersion printVersion = putStrLn $ "cabal-install version " - ++ showVersion Paths_cabal_install.version + ++ display cabalInstallVersion ++ "\ncompiled using version " ++ display cabalVersion ++ " of the Cabal library " @@ -240,14 +233,14 @@ , regularCmd infoCommand infoAction , regularCmd fetchCommand fetchAction , regularCmd getCommand getAction - , hiddenCmd unpackCommand unpackAction + , regularCmd unpackCommand unpackAction , regularCmd checkCommand checkAction , regularCmd uploadCommand uploadAction , regularCmd reportCommand reportAction , regularCmd initCommand initAction , regularCmd userConfigCommand userConfigAction , regularCmd genBoundsCommand genBoundsAction - , regularCmd outdatedCommand outdatedAction + , regularCmd CmdOutdated.outdatedCommand CmdOutdated.outdatedAction , wrapperCmd hscolourCommand hscolourVerbosity hscolourDistPref , hiddenCmd formatCommand formatAction , hiddenCmd actAsSetupCommand actAsSetupAction @@ -270,7 +263,6 @@ , newCmd CmdSdist.sdistCommand CmdSdist.sdistAction , legacyCmd configureExCommand configureAction - , legacyCmd updateCommand updateAction , legacyCmd buildCommand buildAction , legacyCmd replCommand replAction , legacyCmd freezeCommand freezeAction @@ -279,9 +271,7 @@ , legacyCmd runCommand runAction , legacyCmd testCommand testAction , legacyCmd benchmarkCommand benchmarkAction - , legacyCmd execCommand execAction , legacyCmd cleanCommand cleanAction - , legacyCmd doctestCommand doctestAction , legacyWrapperCmd copyCommand copyVerbosity copyDistPref , legacyWrapperCmd registerCommand regVerbosity regDistPref , legacyCmd reconfigureCommand reconfigureAction @@ -678,13 +668,6 @@ createTarGzFile dest docDir name notice verbosity $ "Documentation tarball created: " ++ dest -doctestAction :: DoctestFlags -> [String] -> Action -doctestAction doctestFlags extraArgs _globalFlags = do - let verbosity = fromFlag (doctestVerbosity doctestFlags) - - setupWrapper verbosity defaultSetupScriptOptions Nothing - doctestCommand (const doctestFlags) (const extraArgs) - cleanAction :: CleanFlags -> [String] -> Action cleanAction cleanFlags extraArgs globalFlags = do load <- try (loadConfigOrSandboxConfig verbosity globalFlags) @@ -711,7 +694,7 @@ , configHcPath = listHcPath listFlags } globalFlags' = savedGlobalFlags config `mappend` globalFlags - compProgdb <- if listNeedsCompiler listFlags + compProgdb <- if listNeedsCompiler listFlags then do (comp, _, progdb) <- configCompilerAux' configFlags return (Just (comp, progdb)) @@ -746,16 +729,6 @@ infoFlags targets -updateAction :: UpdateFlags -> [String] -> Action -updateAction updateFlags extraArgs globalFlags = do - let verbosity = fromFlag (updateVerbosity updateFlags) - unless (null extraArgs) $ - die' verbosity $ "'update' doesn't take any extra arguments: " ++ unwords extraArgs - config <- loadConfigOrSandboxConfig verbosity globalFlags - let globalFlags' = savedGlobalFlags config `mappend` globalFlags - withRepoContext verbosity globalFlags' $ \repoContext -> - update verbosity updateFlags repoContext - fetchAction :: FetchFlags -> [String] -> Action fetchAction fetchFlags extraArgs globalFlags = do let verbosity = fromFlag (fetchVerbosity fetchFlags) @@ -805,17 +778,6 @@ comp platform progdb globalFlags' freezeFlags -outdatedAction :: OutdatedFlags -> [String] -> GlobalFlags -> IO () -outdatedAction outdatedFlags _extraArgs globalFlags = do - let verbosity = fromFlag (outdatedVerbosity outdatedFlags) - config <- loadConfigOrSandboxConfig verbosity globalFlags - let configFlags = savedConfigureFlags config - globalFlags' = savedGlobalFlags config `mappend` globalFlags - (comp, platform, _progdb) <- configCompilerAux' configFlags - withRepoContext verbosity globalFlags' $ \repoContext -> - outdated verbosity outdatedFlags repoContext - comp platform - uploadAction :: UploadFlags -> [String] -> Action uploadAction uploadFlags extraArgs globalFlags = do config <- loadConfig verbosity (globalConfigFile globalFlags) @@ -947,34 +909,33 @@ initAction :: InitFlags -> [String] -> Action initAction initFlags extraArgs globalFlags = do - let verbosity = fromFlag (initVerbosity initFlags) - when (extraArgs /= []) $ - die' verbosity $ "'init' doesn't take any extra arguments: " ++ unwords extraArgs - config <- loadConfigOrSandboxConfig verbosity globalFlags - let configFlags = savedConfigureFlags config `mappend` - -- override with `--with-compiler` from CLI if available - mempty { configHcPath = initHcPath initFlags } - let initFlags' = savedInitFlags config `mappend` initFlags - let globalFlags' = savedGlobalFlags config `mappend` globalFlags - (comp, _, progdb) <- configCompilerAux' configFlags - withRepoContext verbosity globalFlags' $ \repoContext -> - initCabal verbosity - (configPackageDB' configFlags) - repoContext - comp - progdb - initFlags' + -- it takes the first value within extraArgs (if there's one) + -- and uses it as the root directory for the new project + case extraArgs of + [] -> initAction' + [projectDir] -> do + createDirectoryIfMissingVerbose verbosity True projectDir + withCurrentDirectory projectDir initAction' + _ -> die' verbosity $ + "'init' only takes a single, optional, extra " ++ + "argument for the project root directory" + where + initAction' = do + confFlags <- loadConfigOrSandboxConfig verbosity globalFlags + -- override with `--with-compiler` from CLI if available + let confFlags' = savedConfigureFlags confFlags `mappend` compFlags + initFlags' = savedInitFlags confFlags `mappend` initFlags + globalFlags' = savedGlobalFlags confFlags `mappend` globalFlags -execAction :: ExecFlags -> [String] -> Action -execAction execFlags extraArgs globalFlags = do - let verbosity = fromFlag (execVerbosity execFlags) - config <- loadConfigOrSandboxConfig verbosity globalFlags - distPref <- findSavedDistPref config (execDistPref execFlags) - let configFlags = savedConfigureFlags config - configFlags' = configFlags { configDistPref = Flag distPref } - (comp, platform, progdb) <- getPersistOrConfigCompiler configFlags' - exec verbosity comp platform progdb extraArgs + (comp, _, progdb) <- configCompilerAux' confFlags' + withRepoContext verbosity globalFlags' $ \repoContext -> + initCmd verbosity (configPackageDB' confFlags') + repoContext comp progdb initFlags' + + verbosity = fromFlag (initVerbosity initFlags) + compFlags = mempty { configHcPath = initHcPath initFlags } + userConfigAction :: UserConfigFlags -> [String] -> Action userConfigAction ucflags extraArgs globalFlags = do let verbosity = fromFlag (userConfigVerbosity ucflags) @@ -1011,7 +972,7 @@ manpageAction commands flags extraArgs _ = do let verbosity = fromFlag (manpageVerbosity flags) unless (null extraArgs) $ - die' verbosity $ "'manpage' doesn't take any extra arguments: " ++ unwords extraArgs + die' verbosity $ "'man' doesn't take any extra arguments: " ++ unwords extraArgs pname <- getProgName let cabalCmd = if takeExtension pname == ".exe" then dropExtension pname diff --git a/cabal/cabal-install/solver-dsl/UnitTests/Distribution/Solver/Modular/DSL.hs b/cabal/cabal-install/solver-dsl/UnitTests/Distribution/Solver/Modular/DSL.hs deleted file mode 100644 --- a/cabal/cabal-install/solver-dsl/UnitTests/Distribution/Solver/Modular/DSL.hs +++ /dev/null @@ -1,820 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} --- | DSL for testing the modular solver -module UnitTests.Distribution.Solver.Modular.DSL ( - ExampleDependency(..) - , Dependencies(..) - , ExSubLib(..) - , ExTest(..) - , ExExe(..) - , ExConstraint(..) - , ExPreference(..) - , ExampleDb - , ExampleVersionRange - , ExamplePkgVersion - , ExamplePkgName - , ExampleFlagName - , ExFlag(..) - , ExampleAvailable(..) - , ExampleInstalled(..) - , ExampleQualifier(..) - , ExampleVar(..) - , EnableAllTests(..) - , dependencies - , publicDependencies - , unbuildableDependencies - , exAv - , exAvNoLibrary - , exInst - , exSubLib - , exTest - , exExe - , exFlagged - , exResolve - , extractInstallPlan - , declareFlags - , withSubLibrary - , withSubLibraries - , withSetupDeps - , withTest - , withTests - , withExe - , withExes - , runProgress - , mkSimpleVersion - , mkVersionRange - ) where - -import Prelude () -import Distribution.Solver.Compat.Prelude -import Distribution.Utils.Generic - --- base -import Control.Arrow (second) -import qualified Data.Map as Map -import qualified Distribution.Compat.NonEmptySet as NonEmptySet - --- Cabal -import qualified Distribution.CabalSpecVersion as C -import qualified Distribution.Compiler as C -import qualified Distribution.InstalledPackageInfo as IPI -import Distribution.License (License(..)) -import qualified Distribution.ModuleName as Module -import qualified Distribution.Package as C - hiding (HasUnitId(..)) -import qualified Distribution.Types.ExeDependency as C -import qualified Distribution.Types.ForeignLib as C -import qualified Distribution.Types.LegacyExeDependency as C -import qualified Distribution.Types.LibraryVisibility as C -import qualified Distribution.Types.PkgconfigDependency as C -import qualified Distribution.Types.PkgconfigVersion as C -import qualified Distribution.Types.PkgconfigVersionRange as C -import qualified Distribution.Types.UnqualComponentName as C -import qualified Distribution.Types.CondTree as C -import qualified Distribution.PackageDescription as C -import qualified Distribution.PackageDescription.Check as C -import qualified Distribution.Simple.PackageIndex as C.PackageIndex -import Distribution.Simple.Setup (BooleanFlag(..)) -import qualified Distribution.System as C -import Distribution.Text (display) -import qualified Distribution.Verbosity as C -import qualified Distribution.Version as C -import Language.Haskell.Extension (Extension(..), Language(..)) - --- cabal-install -import Distribution.Client.Dependency -import Distribution.Client.Dependency.Types -import Distribution.Client.Types -import qualified Distribution.Client.SolverInstallPlan as CI.SolverInstallPlan - -import Distribution.Solver.Types.ComponentDeps (ComponentDeps) -import qualified Distribution.Solver.Types.ComponentDeps as CD -import Distribution.Solver.Types.ConstraintSource -import Distribution.Solver.Types.Flag -import Distribution.Solver.Types.LabeledPackageConstraint -import Distribution.Solver.Types.OptionalStanza -import qualified Distribution.Solver.Types.PackageIndex as CI.PackageIndex -import Distribution.Solver.Types.PackageConstraint -import qualified Distribution.Solver.Types.PackagePath as P -import qualified Distribution.Solver.Types.PkgConfigDb as PC -import Distribution.Solver.Types.Settings -import Distribution.Solver.Types.SolverPackage -import Distribution.Solver.Types.SourcePackage -import Distribution.Solver.Types.Variable - -{------------------------------------------------------------------------------- - Example package database DSL - - In order to be able to set simple examples up quickly, we define a very - simple version of the package database here explicitly designed for use in - tests. - - The design of `ExampleDb` takes the perspective of the solver, not the - perspective of the package DB. This makes it easier to set up tests for - various parts of the solver, but makes the mapping somewhat awkward, because - it means we first map from "solver perspective" `ExampleDb` to the package - database format, and then the modular solver internally in `IndexConversion` - maps this back to the solver specific data structures. - - IMPLEMENTATION NOTES - -------------------- - - TODO: Perhaps these should be made comments of the corresponding data type - definitions. For now these are just my own conclusions and may be wrong. - - * The difference between `GenericPackageDescription` and `PackageDescription` - is that `PackageDescription` describes a particular _configuration_ of a - package (for instance, see documentation for `checkPackage`). A - `GenericPackageDescription` can be turned into a `PackageDescription` in - two ways: - - a. `finalizePD` does the proper translation, by taking - into account the platform, available dependencies, etc. and picks a - flag assignment (or gives an error if no flag assignment can be found) - b. `flattenPackageDescription` ignores flag assignment and just joins all - components together. - - The slightly odd thing is that a `GenericPackageDescription` contains a - `PackageDescription` as a field; both of the above functions do the same - thing: they take the embedded `PackageDescription` as a basis for the result - value, but override `library`, `executables`, `testSuites`, `benchmarks` - and `buildDepends`. - * The `condTreeComponents` fields of a `CondTree` is a list of triples - `(condition, then-branch, else-branch)`, where the `else-branch` is - optional. --------------------------------------------------------------------------------} - -type ExamplePkgName = String -type ExamplePkgVersion = Int -type ExamplePkgHash = String -- for example "installed" packages -type ExampleFlagName = String -type ExampleSubLibName = String -type ExampleTestName = String -type ExampleExeName = String -type ExampleVersionRange = C.VersionRange - -data Dependencies = Dependencies { - depsVisibility :: C.LibraryVisibility - , depsIsBuildable :: Bool - , depsExampleDependencies :: [ExampleDependency] - } deriving Show - -instance Semigroup Dependencies where - deps1 <> deps2 = Dependencies { - depsVisibility = depsVisibility deps1 <> depsVisibility deps2 - , depsIsBuildable = depsIsBuildable deps1 && depsIsBuildable deps2 - , depsExampleDependencies = depsExampleDependencies deps1 ++ depsExampleDependencies deps2 - } - -instance Monoid Dependencies where - mempty = Dependencies { - depsVisibility = mempty - , depsIsBuildable = True - , depsExampleDependencies = [] - } - mappend = (<>) - -dependencies :: [ExampleDependency] -> Dependencies -dependencies deps = mempty { depsExampleDependencies = deps } - -publicDependencies :: Dependencies -publicDependencies = mempty { depsVisibility = C.LibraryVisibilityPublic } - -unbuildableDependencies :: Dependencies -unbuildableDependencies = mempty { depsIsBuildable = False } - -data ExampleDependency = - -- | Simple dependency on any version - ExAny ExamplePkgName - - -- | Simple dependency on a fixed version - | ExFix ExamplePkgName ExamplePkgVersion - - -- | Simple dependency on a range of versions, with an inclusive lower bound - -- and an exclusive upper bound. - | ExRange ExamplePkgName ExamplePkgVersion ExamplePkgVersion - - -- | Sub-library dependency - | ExSubLibAny ExamplePkgName ExampleSubLibName - - -- | Sub-library dependency on a fixed version - | ExSubLibFix ExamplePkgName ExampleSubLibName ExamplePkgVersion - - -- | Build-tool-depends dependency - | ExBuildToolAny ExamplePkgName ExampleExeName - - -- | Build-tool-depends dependency on a fixed version - | ExBuildToolFix ExamplePkgName ExampleExeName ExamplePkgVersion - - -- | Legacy build-tools dependency - | ExLegacyBuildToolAny ExamplePkgName - - -- | Legacy build-tools dependency on a fixed version - | ExLegacyBuildToolFix ExamplePkgName ExamplePkgVersion - - -- | Dependencies indexed by a flag - | ExFlagged ExampleFlagName Dependencies Dependencies - - -- | Dependency on a language extension - | ExExt Extension - - -- | Dependency on a language version - | ExLang Language - - -- | Dependency on a pkg-config package - | ExPkg (ExamplePkgName, ExamplePkgVersion) - deriving Show - --- | Simplified version of D.Types.GenericPackageDescription.Flag for use in --- example source packages. -data ExFlag = ExFlag { - exFlagName :: ExampleFlagName - , exFlagDefault :: Bool - , exFlagType :: FlagType - } deriving Show - -data ExSubLib = ExSubLib ExampleSubLibName Dependencies - -data ExTest = ExTest ExampleTestName Dependencies - -data ExExe = ExExe ExampleExeName Dependencies - -exSubLib :: ExampleSubLibName -> [ExampleDependency] -> ExSubLib -exSubLib name deps = ExSubLib name (dependencies deps) - -exTest :: ExampleTestName -> [ExampleDependency] -> ExTest -exTest name deps = ExTest name (dependencies deps) - -exExe :: ExampleExeName -> [ExampleDependency] -> ExExe -exExe name deps = ExExe name (dependencies deps) - -exFlagged :: ExampleFlagName -> [ExampleDependency] -> [ExampleDependency] - -> ExampleDependency -exFlagged n t e = ExFlagged n (dependencies t) (dependencies e) - -data ExConstraint = - ExVersionConstraint ConstraintScope ExampleVersionRange - | ExFlagConstraint ConstraintScope ExampleFlagName Bool - | ExStanzaConstraint ConstraintScope [OptionalStanza] - deriving Show - -data ExPreference = - ExPkgPref ExamplePkgName ExampleVersionRange - | ExStanzaPref ExamplePkgName [OptionalStanza] - deriving Show - -data ExampleAvailable = ExAv { - exAvName :: ExamplePkgName - , exAvVersion :: ExamplePkgVersion - , exAvDeps :: ComponentDeps Dependencies - - -- Setting flags here is only necessary to override the default values of - -- the fields in C.Flag. - , exAvFlags :: [ExFlag] - } deriving Show - -data ExampleVar = - P ExampleQualifier ExamplePkgName - | F ExampleQualifier ExamplePkgName ExampleFlagName - | S ExampleQualifier ExamplePkgName OptionalStanza - -data ExampleQualifier = - QualNone - | QualIndep ExamplePkgName - | QualSetup ExamplePkgName - - -- The two package names are the build target and the package containing the - -- setup script. - | QualIndepSetup ExamplePkgName ExamplePkgName - - -- The two package names are the package depending on the exe and the - -- package containing the exe. - | QualExe ExamplePkgName ExamplePkgName - --- | Whether to enable tests in all packages in a test case. -newtype EnableAllTests = EnableAllTests Bool - deriving BooleanFlag - --- | Constructs an 'ExampleAvailable' package for the 'ExampleDb', --- given: --- --- 1. The name 'ExamplePkgName' of the available package, --- 2. The version 'ExamplePkgVersion' available --- 3. The list of dependency constraints ('ExampleDependency') --- for this package's library component. 'ExampleDependency' --- provides a number of pre-canned dependency types to look at. --- -exAv :: ExamplePkgName -> ExamplePkgVersion -> [ExampleDependency] - -> ExampleAvailable -exAv n v ds = (exAvNoLibrary n v) { exAvDeps = CD.fromLibraryDeps (dependencies ds) } - --- | Constructs an 'ExampleAvailable' package without a default library --- component. -exAvNoLibrary :: ExamplePkgName -> ExamplePkgVersion -> ExampleAvailable -exAvNoLibrary n v = ExAv { exAvName = n - , exAvVersion = v - , exAvDeps = CD.empty - , exAvFlags = [] } - --- | Override the default settings (e.g., manual vs. automatic) for a subset of --- a package's flags. -declareFlags :: [ExFlag] -> ExampleAvailable -> ExampleAvailable -declareFlags flags ex = ex { - exAvFlags = flags - } - -withSubLibrary :: ExampleAvailable -> ExSubLib -> ExampleAvailable -withSubLibrary ex lib = withSubLibraries ex [lib] - -withSubLibraries :: ExampleAvailable -> [ExSubLib] -> ExampleAvailable -withSubLibraries ex libs = - let subLibCDs = CD.fromList [(CD.ComponentSubLib $ C.mkUnqualComponentName name, deps) - | ExSubLib name deps <- libs] - in ex { exAvDeps = exAvDeps ex <> subLibCDs } - -withSetupDeps :: ExampleAvailable -> [ExampleDependency] -> ExampleAvailable -withSetupDeps ex setupDeps = ex { - exAvDeps = exAvDeps ex <> CD.fromSetupDeps (dependencies setupDeps) - } - -withTest :: ExampleAvailable -> ExTest -> ExampleAvailable -withTest ex test = withTests ex [test] - -withTests :: ExampleAvailable -> [ExTest] -> ExampleAvailable -withTests ex tests = - let testCDs = CD.fromList [(CD.ComponentTest $ C.mkUnqualComponentName name, deps) - | ExTest name deps <- tests] - in ex { exAvDeps = exAvDeps ex <> testCDs } - -withExe :: ExampleAvailable -> ExExe -> ExampleAvailable -withExe ex exe = withExes ex [exe] - -withExes :: ExampleAvailable -> [ExExe] -> ExampleAvailable -withExes ex exes = - let exeCDs = CD.fromList [(CD.ComponentExe $ C.mkUnqualComponentName name, deps) - | ExExe name deps <- exes] - in ex { exAvDeps = exAvDeps ex <> exeCDs } - --- | An installed package in 'ExampleDb'; construct me with 'exInst'. -data ExampleInstalled = ExInst { - exInstName :: ExamplePkgName - , exInstVersion :: ExamplePkgVersion - , exInstHash :: ExamplePkgHash - , exInstBuildAgainst :: [ExamplePkgHash] - } deriving Show - --- | Constructs an example installed package given: --- --- 1. The name of the package 'ExamplePkgName', i.e., 'String' --- 2. The version of the package 'ExamplePkgVersion', i.e., 'Int' --- 3. The IPID for the package 'ExamplePkgHash', i.e., 'String' --- (just some unique identifier for the package.) --- 4. The 'ExampleInstalled' packages which this package was --- compiled against.) --- -exInst :: ExamplePkgName -> ExamplePkgVersion -> ExamplePkgHash - -> [ExampleInstalled] -> ExampleInstalled -exInst pn v hash deps = ExInst pn v hash (map exInstHash deps) - --- | An example package database is a list of installed packages --- 'ExampleInstalled' and available packages 'ExampleAvailable'. --- Generally, you want to use 'exInst' and 'exAv' to construct --- these packages. -type ExampleDb = [Either ExampleInstalled ExampleAvailable] - -type DependencyTree a = C.CondTree C.ConfVar [C.Dependency] a - -type DependencyComponent a = C.CondBranch C.ConfVar [C.Dependency] a - -exDbPkgs :: ExampleDb -> [ExamplePkgName] -exDbPkgs = map (either exInstName exAvName) - -exAvSrcPkg :: ExampleAvailable -> UnresolvedSourcePackage -exAvSrcPkg ex = - let pkgId = exAvPkgId ex - - flags :: [C.PackageFlag] - flags = - let declaredFlags :: Map ExampleFlagName C.PackageFlag - declaredFlags = - Map.fromListWith - (\f1 f2 -> error $ "duplicate flag declarations: " ++ show [f1, f2]) - [(exFlagName flag, mkFlag flag) | flag <- exAvFlags ex] - - usedFlags :: Map ExampleFlagName C.PackageFlag - usedFlags = Map.fromList [(fn, mkDefaultFlag fn) | fn <- names] - where - names = extractFlags $ CD.flatDeps (exAvDeps ex) - in -- 'declaredFlags' overrides 'usedFlags' to give flags non-default settings: - Map.elems $ declaredFlags `Map.union` usedFlags - - subLibraries = [(name, deps) | (CD.ComponentSubLib name, deps) <- CD.toList (exAvDeps ex)] - foreignLibraries = [(name, deps) | (CD.ComponentFLib name, deps) <- CD.toList (exAvDeps ex)] - testSuites = [(name, deps) | (CD.ComponentTest name, deps) <- CD.toList (exAvDeps ex)] - benchmarks = [(name, deps) | (CD.ComponentBench name, deps) <- CD.toList (exAvDeps ex)] - executables = [(name, deps) | (CD.ComponentExe name, deps) <- CD.toList (exAvDeps ex)] - setup = case depsExampleDependencies $ CD.setupDeps (exAvDeps ex) of - [] -> Nothing - deps -> Just C.SetupBuildInfo { - C.setupDepends = mkSetupDeps deps, - C.defaultSetupDepends = False - } - package = SourcePackage - { srcpkgPackageId = pkgId - , srcpkgSource = LocalTarballPackage "<>" - , srcpkgDescrOverride = Nothing - , srcpkgDescription = C.GenericPackageDescription { - C.packageDescription = C.emptyPackageDescription { - C.package = pkgId - , C.setupBuildInfo = setup - , C.licenseRaw = Right BSD3 - , C.buildTypeRaw = if isNothing setup - then Just C.Simple - else Just C.Custom - , C.category = "category" - , C.maintainer = "maintainer" - , C.description = "description" - , C.synopsis = "synopsis" - , C.licenseFiles = ["LICENSE"] - -- Version 2.0 is required for internal libraries. - , C.specVersion = C.CabalSpecV2_0 - } - , C.gpdScannedVersion = Nothing - , C.genPackageFlags = flags - , C.condLibrary = - let mkLib v bi = mempty { C.libVisibility = v, C.libBuildInfo = bi } - -- Avoid using the Monoid instance for [a] when getting - -- the library dependencies, to allow for the possibility - -- that the package doesn't have a library: - libDeps = lookup CD.ComponentLib (CD.toList (exAvDeps ex)) - in mkTopLevelCondTree defaultLib mkLib <$> libDeps - , C.condSubLibraries = - let mkTree = mkTopLevelCondTree defaultSubLib mkLib - mkLib v bi = mempty { C.libVisibility = v, C.libBuildInfo = bi } - in map (second mkTree) subLibraries - , C.condForeignLibs = - let mkTree = mkTopLevelCondTree (mkLib defaultTopLevelBuildInfo) (const mkLib) - mkLib bi = mempty { C.foreignLibBuildInfo = bi } - in map (second mkTree) foreignLibraries - , C.condExecutables = - let mkTree = mkTopLevelCondTree defaultExe (const mkExe) - mkExe bi = mempty { C.buildInfo = bi } - in map (second mkTree) executables - , C.condTestSuites = - let mkTree = mkTopLevelCondTree defaultTest (const mkTest) - mkTest bi = mempty { C.testBuildInfo = bi } - in map (second mkTree) testSuites - , C.condBenchmarks = - let mkTree = mkTopLevelCondTree defaultBenchmark (const mkBench) - mkBench bi = mempty { C.benchmarkBuildInfo = bi } - in map (second mkTree) benchmarks - } - } - pkgCheckErrors = - -- We ignore these warnings because some unit tests test that the - -- solver allows unknown extensions/languages when the compiler - -- supports them. - let ignore = ["Unknown extensions:", "Unknown languages:"] - in [ err | err <- C.checkPackage (srcpkgDescription package) Nothing - , not $ any (`isPrefixOf` C.explanation err) ignore ] - in if null pkgCheckErrors - then package - else error $ "invalid GenericPackageDescription for package " - ++ display pkgId ++ ": " ++ show pkgCheckErrors - where - defaultTopLevelBuildInfo :: C.BuildInfo - defaultTopLevelBuildInfo = mempty { C.defaultLanguage = Just Haskell98 } - - defaultLib :: C.Library - defaultLib = mempty { - C.libBuildInfo = defaultTopLevelBuildInfo - , C.exposedModules = [Module.fromString "Module"] - , C.libVisibility = C.LibraryVisibilityPublic - } - - defaultSubLib :: C.Library - defaultSubLib = mempty { - C.libBuildInfo = defaultTopLevelBuildInfo - , C.exposedModules = [Module.fromString "Module"] - } - - defaultExe :: C.Executable - defaultExe = mempty { - C.buildInfo = defaultTopLevelBuildInfo - , C.modulePath = "Main.hs" - } - - defaultTest :: C.TestSuite - defaultTest = mempty { - C.testBuildInfo = defaultTopLevelBuildInfo - , C.testInterface = C.TestSuiteExeV10 (C.mkVersion [1,0]) "Test.hs" - } - - defaultBenchmark :: C.Benchmark - defaultBenchmark = mempty { - C.benchmarkBuildInfo = defaultTopLevelBuildInfo - , C.benchmarkInterface = C.BenchmarkExeV10 (C.mkVersion [1,0]) "Benchmark.hs" - } - - -- Split the set of dependencies into the set of dependencies of the library, - -- the dependencies of the test suites and extensions. - splitTopLevel :: [ExampleDependency] - -> ( [ExampleDependency] - , [Extension] - , Maybe Language - , [(ExamplePkgName, ExamplePkgVersion)] -- pkg-config - , [(ExamplePkgName, ExampleExeName, C.VersionRange)] -- build tools - , [(ExamplePkgName, C.VersionRange)] -- legacy build tools - ) - splitTopLevel [] = - ([], [], Nothing, [], [], []) - splitTopLevel (ExBuildToolAny p e:deps) = - let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps - in (other, exts, lang, pcpkgs, (p, e, C.anyVersion):exes, legacyExes) - splitTopLevel (ExBuildToolFix p e v:deps) = - let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps - in (other, exts, lang, pcpkgs, (p, e, C.thisVersion (mkSimpleVersion v)):exes, legacyExes) - splitTopLevel (ExLegacyBuildToolAny p:deps) = - let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps - in (other, exts, lang, pcpkgs, exes, (p, C.anyVersion):legacyExes) - splitTopLevel (ExLegacyBuildToolFix p v:deps) = - let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps - in (other, exts, lang, pcpkgs, exes, (p, C.thisVersion (mkSimpleVersion v)):legacyExes) - splitTopLevel (ExExt ext:deps) = - let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps - in (other, ext:exts, lang, pcpkgs, exes, legacyExes) - splitTopLevel (ExLang lang:deps) = - case splitTopLevel deps of - (other, exts, Nothing, pcpkgs, exes, legacyExes) -> (other, exts, Just lang, pcpkgs, exes, legacyExes) - _ -> error "Only 1 Language dependency is supported" - splitTopLevel (ExPkg pkg:deps) = - let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps - in (other, exts, lang, pkg:pcpkgs, exes, legacyExes) - splitTopLevel (dep:deps) = - let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps - in (dep:other, exts, lang, pcpkgs, exes, legacyExes) - - -- Extract the total set of flags used - extractFlags :: Dependencies -> [ExampleFlagName] - extractFlags deps = concatMap go (depsExampleDependencies deps) - where - go :: ExampleDependency -> [ExampleFlagName] - go (ExAny _) = [] - go (ExFix _ _) = [] - go (ExRange _ _ _) = [] - go (ExSubLibAny _ _) = [] - go (ExSubLibFix _ _ _) = [] - go (ExBuildToolAny _ _) = [] - go (ExBuildToolFix _ _ _) = [] - go (ExLegacyBuildToolAny _) = [] - go (ExLegacyBuildToolFix _ _) = [] - go (ExFlagged f a b) = f : extractFlags a ++ extractFlags b - go (ExExt _) = [] - go (ExLang _) = [] - go (ExPkg _) = [] - - -- Convert 'Dependencies' into a tree of a specific component type, using - -- the given top level component and function for creating a component at - -- any level. - mkTopLevelCondTree :: forall a. Semigroup a => - a - -> (C.LibraryVisibility -> C.BuildInfo -> a) - -> Dependencies - -> DependencyTree a - mkTopLevelCondTree defaultTopLevel mkComponent deps = - let 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 mkComponent deps = - let (libraryDeps, exts, mlang, pcpkgs, buildTools, legacyBuildTools) = splitTopLevel (depsExampleDependencies deps) - (directDeps, flaggedDeps) = splitDeps libraryDeps - component = mkComponent (depsVisibility deps) bi - bi = mempty { - C.otherExtensions = exts - , C.defaultLanguage = mlang - , C.buildToolDepends = [ C.ExeDependency (C.mkPackageName p) (C.mkUnqualComponentName e) vr - | (p, e, vr) <- buildTools] - , C.buildTools = [ C.LegacyExeDependency n vr - | (n,vr) <- legacyBuildTools] - , C.pkgconfigDepends = [ C.PkgconfigDependency n' v' - | (n,v) <- pcpkgs - , let n' = C.mkPkgconfigName n - , let v' = C.PcThisVersion (mkSimplePkgconfigVersion v) ] - , 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.condTreeComponents = map (mkFlagged mkComponent) flaggedDeps - } - - mkDirect :: (ExamplePkgName, C.LibraryName, C.VersionRange) -> C.Dependency - mkDirect (dep, name, vr) = C.Dependency (C.mkPackageName dep) vr (NonEmptySet.singleton name) - - mkFlagged :: (C.LibraryVisibility -> C.BuildInfo -> a) - -> (ExampleFlagName, Dependencies, Dependencies) - -> DependencyComponent a - mkFlagged mkComponent (f, a, b) = - C.CondBranch (C.Var (C.PackageFlag (C.mkFlagName f))) - (mkCondTree mkComponent a) - (Just (mkCondTree mkComponent b)) - - -- Split a set of dependencies into direct dependencies and flagged - -- dependencies. A direct dependency is a tuple of the name of package and - -- its version range meant to be converted to a 'C.Dependency' with - -- 'mkDirect' for example. A flagged dependency is the set of dependencies - -- guarded by a flag. - splitDeps :: [ExampleDependency] - -> ( [(ExamplePkgName, C.LibraryName, C.VersionRange)] - , [(ExampleFlagName, Dependencies, Dependencies)] - ) - splitDeps [] = - ([], []) - splitDeps (ExAny p:deps) = - let (directDeps, flaggedDeps) = splitDeps deps - in ((p, C.LMainLibName, C.anyVersion):directDeps, flaggedDeps) - splitDeps (ExFix p v:deps) = - let (directDeps, flaggedDeps) = splitDeps deps - in ((p, C.LMainLibName, C.thisVersion $ mkSimpleVersion v):directDeps, flaggedDeps) - splitDeps (ExRange p v1 v2:deps) = - let (directDeps, flaggedDeps) = splitDeps deps - in ((p, C.LMainLibName, mkVersionRange v1 v2):directDeps, flaggedDeps) - splitDeps (ExSubLibAny p lib:deps) = - let (directDeps, flaggedDeps) = splitDeps deps - in ((p, C.LSubLibName (C.mkUnqualComponentName lib), C.anyVersion):directDeps, flaggedDeps) - splitDeps (ExSubLibFix p lib v:deps) = - let (directDeps, flaggedDeps) = splitDeps deps - in ((p, C.LSubLibName (C.mkUnqualComponentName lib), C.thisVersion $ mkSimpleVersion v):directDeps, flaggedDeps) - splitDeps (ExFlagged f a b:deps) = - let (directDeps, flaggedDeps) = splitDeps deps - in (directDeps, (f, a, b):flaggedDeps) - splitDeps (dep:_) = error $ "Unexpected dependency: " ++ show dep - - -- custom-setup only supports simple dependencies - mkSetupDeps :: [ExampleDependency] -> [C.Dependency] - mkSetupDeps deps = - case splitDeps deps of - (directDeps, []) -> map mkDirect directDeps - _ -> error "mkSetupDeps: custom setup has non-simple deps" - -mkSimpleVersion :: ExamplePkgVersion -> C.Version -mkSimpleVersion n = C.mkVersion [n, 0, 0] - -mkSimplePkgconfigVersion :: ExamplePkgVersion -> C.PkgconfigVersion -mkSimplePkgconfigVersion = C.versionToPkgconfigVersion . mkSimpleVersion - -mkVersionRange :: ExamplePkgVersion -> ExamplePkgVersion -> C.VersionRange -mkVersionRange v1 v2 = - C.intersectVersionRanges (C.orLaterVersion $ mkSimpleVersion v1) - (C.earlierVersion $ mkSimpleVersion v2) - -mkFlag :: ExFlag -> C.PackageFlag -mkFlag flag = C.MkPackageFlag { - C.flagName = C.mkFlagName $ exFlagName flag - , C.flagDescription = "" - , C.flagDefault = exFlagDefault flag - , C.flagManual = - case exFlagType flag of - Manual -> True - Automatic -> False - } - -mkDefaultFlag :: ExampleFlagName -> C.PackageFlag -mkDefaultFlag flag = C.MkPackageFlag { - C.flagName = C.mkFlagName flag - , C.flagDescription = "" - , C.flagDefault = True - , C.flagManual = False - } - -exAvPkgId :: ExampleAvailable -> C.PackageIdentifier -exAvPkgId ex = C.PackageIdentifier { - pkgName = C.mkPackageName (exAvName ex) - , pkgVersion = C.mkVersion [exAvVersion ex, 0, 0] - } - -exInstInfo :: ExampleInstalled -> IPI.InstalledPackageInfo -exInstInfo ex = IPI.emptyInstalledPackageInfo { - IPI.installedUnitId = C.mkUnitId (exInstHash ex) - , IPI.sourcePackageId = exInstPkgId ex - , IPI.depends = map C.mkUnitId (exInstBuildAgainst ex) - } - -exInstPkgId :: ExampleInstalled -> C.PackageIdentifier -exInstPkgId ex = C.PackageIdentifier { - pkgName = C.mkPackageName (exInstName ex) - , pkgVersion = C.mkVersion [exInstVersion ex, 0, 0] - } - -exAvIdx :: [ExampleAvailable] -> CI.PackageIndex.PackageIndex UnresolvedSourcePackage -exAvIdx = CI.PackageIndex.fromList . map exAvSrcPkg - -exInstIdx :: [ExampleInstalled] -> C.PackageIndex.InstalledPackageIndex -exInstIdx = C.PackageIndex.fromList . map exInstInfo - -exResolve :: ExampleDb - -- List of extensions supported by the compiler, or Nothing if unknown. - -> Maybe [Extension] - -- List of languages supported by the compiler, or Nothing if unknown. - -> Maybe [Language] - -> PC.PkgConfigDb - -> [ExamplePkgName] - -> Maybe Int - -> CountConflicts - -> FineGrainedConflicts - -> MinimizeConflictSet - -> IndependentGoals - -> ReorderGoals - -> AllowBootLibInstalls - -> OnlyConstrained - -> EnableBackjumping - -> SolveExecutables - -> Maybe (Variable P.QPN -> Variable P.QPN -> Ordering) - -> [ExConstraint] - -> [ExPreference] - -> C.Verbosity - -> EnableAllTests - -> Progress String String CI.SolverInstallPlan.SolverInstallPlan -exResolve db exts langs pkgConfigDb targets mbj countConflicts - fineGrainedConflicts minimizeConflictSet indepGoals reorder - allowBootLibInstalls onlyConstrained enableBj solveExes goalOrder - constraints prefs verbosity enableAllTests - = resolveDependencies C.buildPlatform compiler pkgConfigDb Modular params - where - defaultCompiler = C.unknownCompilerInfo C.buildCompilerId C.NoAbiTag - compiler = defaultCompiler { C.compilerInfoExtensions = exts - , C.compilerInfoLanguages = langs - } - (inst, avai) = partitionEithers db - instIdx = exInstIdx inst - avaiIdx = SourcePackageDb { - packageIndex = exAvIdx avai - , packagePreferences = Map.empty - } - enableTests - | asBool enableAllTests = fmap (\p -> PackageConstraint - (scopeToplevel (C.mkPackageName p)) - (PackagePropertyStanzas [TestStanzas])) - (exDbPkgs db) - | otherwise = [] - targets' = fmap (\p -> NamedPackage (C.mkPackageName p) []) targets - params = addConstraints (fmap toConstraint constraints) - $ addConstraints (fmap toLpc enableTests) - $ addPreferences (fmap toPref prefs) - $ setCountConflicts countConflicts - $ setFineGrainedConflicts fineGrainedConflicts - $ setMinimizeConflictSet minimizeConflictSet - $ setIndependentGoals indepGoals - $ setReorderGoals reorder - $ setMaxBackjumps mbj - $ setAllowBootLibInstalls allowBootLibInstalls - $ setOnlyConstrained onlyConstrained - $ setEnableBackjumping enableBj - $ setSolveExecutables solveExes - $ setGoalOrder goalOrder - $ setSolverVerbosity verbosity - $ standardInstallPolicy instIdx avaiIdx targets' - toLpc pc = LabeledPackageConstraint pc ConstraintSourceUnknown - - toConstraint (ExVersionConstraint scope v) = - toLpc $ PackageConstraint scope (PackagePropertyVersion v) - toConstraint (ExFlagConstraint scope fn b) = - toLpc $ PackageConstraint scope (PackagePropertyFlags (C.mkFlagAssignment [(C.mkFlagName fn, b)])) - toConstraint (ExStanzaConstraint scope stanzas) = - toLpc $ PackageConstraint scope (PackagePropertyStanzas stanzas) - - toPref (ExPkgPref n v) = PackageVersionPreference (C.mkPackageName n) v - toPref (ExStanzaPref n stanzas) = PackageStanzasPreference (C.mkPackageName n) stanzas - -extractInstallPlan :: CI.SolverInstallPlan.SolverInstallPlan - -> [(ExamplePkgName, ExamplePkgVersion)] -extractInstallPlan = catMaybes . map confPkg . CI.SolverInstallPlan.toList - where - confPkg :: CI.SolverInstallPlan.SolverPlanPackage -> Maybe (String, Int) - confPkg (CI.SolverInstallPlan.Configured pkg) = srcPkg pkg - confPkg _ = Nothing - - srcPkg :: SolverPackage UnresolvedPkgLoc -> Maybe (String, Int) - srcPkg cpkg = - let C.PackageIdentifier pn ver = C.packageId (solverPkgSource cpkg) - in (\vn -> (C.unPackageName pn, vn)) <$> safeHead (C.versionNumbers ver) - -{------------------------------------------------------------------------------- - Auxiliary --------------------------------------------------------------------------------} - --- | Run Progress computation -runProgress :: Progress step e a -> ([step], Either e a) -runProgress = go - where - go (Step s p) = let (ss, result) = go p in (s:ss, result) - go (Fail e) = ([], Left e) - go (Done a) = ([], Right a) diff --git a/cabal/cabal-install/src/Distribution/Client/BuildReports/Anonymous.hs b/cabal/cabal-install/src/Distribution/Client/BuildReports/Anonymous.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/BuildReports/Anonymous.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE OverloadedStrings #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Reporting +-- Copyright : (c) David Waern 2008 +-- License : BSD-like +-- +-- Maintainer : david.waern@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- Anonymous build report data structure, printing and parsing +-- +----------------------------------------------------------------------------- +module Distribution.Client.BuildReports.Anonymous ( + BuildReport(..), + InstallOutcome(..), + Outcome(..), + + -- * Constructing and writing reports + newBuildReport, + + -- * parsing and pretty printing + parseBuildReport, + parseBuildReportList, + showBuildReport, + cabalInstallID +-- showList, + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.CabalSpecVersion +import Distribution.Client.BuildReports.Types +import Distribution.Client.Version (cabalInstallVersion) +import Distribution.Compiler (CompilerId (..)) +import Distribution.FieldGrammar +import Distribution.Fields +import Distribution.Package (PackageIdentifier (..), mkPackageName) +import Distribution.PackageDescription (FlagAssignment) +import Distribution.Parsec +import Distribution.System (Arch, OS) + +import qualified Distribution.Client.BuildReports.Lens as L +import qualified Distribution.Client.Types as BR (BuildFailure (..), BuildOutcome, BuildResult (..), DocsResult (..), TestsResult (..)) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 + + +------------------------------------------------------------------------------- +-- New +------------------------------------------------------------------------------- + +newBuildReport :: OS -> Arch -> CompilerId -> PackageIdentifier -> FlagAssignment + -> [PackageIdentifier] -> BR.BuildOutcome -> BuildReport +newBuildReport os' arch' comp pkgid flags deps result = + BuildReport { + package = pkgid, + os = os', + arch = arch', + compiler = comp, + client = cabalInstallID, + flagAssignment = flags, + dependencies = deps, + installOutcome = convertInstallOutcome, +-- cabalVersion = undefined + docsOutcome = convertDocsOutcome, + testsOutcome = convertTestsOutcome + } + where + convertInstallOutcome = case result of + Left BR.PlanningFailed -> PlanningFailed + Left (BR.DependentFailed p) -> DependencyFailed p + Left (BR.DownloadFailed _) -> DownloadFailed + Left (BR.UnpackFailed _) -> UnpackFailed + Left (BR.ConfigureFailed _) -> ConfigureFailed + Left (BR.BuildFailed _) -> BuildFailed + Left (BR.TestsFailed _) -> TestsFailed + Left (BR.InstallFailed _) -> InstallFailed + Right (BR.BuildResult _ _ _) -> InstallOk + convertDocsOutcome = case result of + Left _ -> NotTried + Right (BR.BuildResult BR.DocsNotTried _ _) -> NotTried + Right (BR.BuildResult BR.DocsFailed _ _) -> Failed + Right (BR.BuildResult BR.DocsOk _ _) -> Ok + convertTestsOutcome = case result of + Left (BR.TestsFailed _) -> Failed + Left _ -> NotTried + Right (BR.BuildResult _ BR.TestsNotTried _) -> NotTried + Right (BR.BuildResult _ BR.TestsOk _) -> Ok + +cabalInstallID :: PackageIdentifier +cabalInstallID = + PackageIdentifier (mkPackageName "cabal-install") cabalInstallVersion + +------------------------------------------------------------------------------- +-- FieldGrammar +------------------------------------------------------------------------------- + +fieldDescrs + :: ( Applicative (g BuildReport), FieldGrammar c g + , c (Identity Arch) + , c (Identity CompilerId) + , c (Identity FlagAssignment) + , c (Identity InstallOutcome) + , c (Identity OS) + , c (Identity Outcome) + , c (Identity PackageIdentifier) + , c (List VCat (Identity PackageIdentifier) PackageIdentifier) + ) + => g BuildReport BuildReport +fieldDescrs = BuildReport + <$> uniqueField "package" L.package + <*> uniqueField "os" L.os + <*> uniqueField "arch" L.arch + <*> uniqueField "compiler" L.compiler + <*> uniqueField "client" L.client + <*> monoidalField "flags" L.flagAssignment + <*> monoidalFieldAla "dependencies" (alaList VCat) L.dependencies + <*> uniqueField "install-outcome" L.installOutcome + <*> uniqueField "docs-outcome" L.docsOutcome + <*> uniqueField "tests-outcome" L.testsOutcome + +-- ----------------------------------------------------------------------------- +-- Parsing + +parseBuildReport :: BS.ByteString -> Either String BuildReport +parseBuildReport s = case snd $ runParseResult $ parseFields s of + Left (_, perrors) -> Left $ unlines [ err | PError _ err <- toList perrors ] + Right report -> Right report + +parseFields :: BS.ByteString -> ParseResult BuildReport +parseFields input = do + fields <- either (parseFatalFailure zeroPos . show) pure $ readFields input + case partitionFields fields of + (fields', []) -> parseFieldGrammar CabalSpecV2_4 fields' fieldDescrs + _otherwise -> parseFatalFailure zeroPos "found sections in BuildReport" + +parseBuildReportList :: BS.ByteString -> [BuildReport] +parseBuildReportList str = + [ report | Right report <- map parseBuildReport (split str) ] + + where + split :: BS.ByteString -> [BS.ByteString] + split = filter (not . BS.null) . unfoldr chunk . BS8.lines + chunk [] = Nothing + chunk ls = case break BS.null ls of + (r, rs) -> Just (BS8.unlines r, dropWhile BS.null rs) + +-- ----------------------------------------------------------------------------- +-- Pretty-printing + +showBuildReport :: BuildReport -> String +showBuildReport = showFields (const NoComment) . prettyFieldGrammar CabalSpecV2_4 fieldDescrs diff --git a/cabal/cabal-install/src/Distribution/Client/BuildReports/Lens.hs b/cabal/cabal-install/src/Distribution/Client/BuildReports/Lens.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/BuildReports/Lens.hs @@ -0,0 +1,46 @@ +module Distribution.Client.BuildReports.Lens ( + BuildReport, + module Distribution.Client.BuildReports.Lens, +) where + +import Distribution.Client.Compat.Prelude +import Distribution.Compat.Lens +import Prelude () + +import Distribution.Client.BuildReports.Types (BuildReport, InstallOutcome, Outcome) +import Distribution.Compiler (CompilerId) +import Distribution.System (Arch, OS) +import Distribution.Types.Flag (FlagAssignment) +import Distribution.Types.PackageId (PackageIdentifier) + +import qualified Distribution.Client.BuildReports.Types as T + +package :: Lens' BuildReport PackageIdentifier +package f s = fmap (\x -> s { T.package = x }) (f (T.package s)) + +os :: Lens' BuildReport OS +os f s = fmap (\x -> s { T.os = x }) (f (T.os s)) + +arch :: Lens' BuildReport Arch +arch f s = fmap (\x -> s { T.arch = x }) (f (T.arch s)) + +compiler :: Lens' BuildReport CompilerId +compiler f s = fmap (\x -> s { T.compiler = x }) (f (T.compiler s)) + +client :: Lens' BuildReport PackageIdentifier +client f s = fmap (\x -> s { T.client = x }) (f (T.client s)) + +flagAssignment :: Lens' BuildReport FlagAssignment +flagAssignment f s = fmap (\x -> s { T.flagAssignment = x }) (f (T.flagAssignment s)) + +dependencies :: Lens' BuildReport [PackageIdentifier] +dependencies f s = fmap (\x -> s { T.dependencies = x }) (f (T.dependencies s)) + +installOutcome :: Lens' BuildReport InstallOutcome +installOutcome f s = fmap (\x -> s { T.installOutcome = x }) (f (T.installOutcome s)) + +docsOutcome :: Lens' BuildReport Outcome +docsOutcome f s = fmap (\x -> s { T.docsOutcome = x }) (f (T.docsOutcome s)) + +testsOutcome :: Lens' BuildReport Outcome +testsOutcome f s = fmap (\x -> s { T.testsOutcome = x }) (f (T.testsOutcome s)) diff --git a/cabal/cabal-install/src/Distribution/Client/BuildReports/Storage.hs b/cabal/cabal-install/src/Distribution/Client/BuildReports/Storage.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/BuildReports/Storage.hs @@ -0,0 +1,163 @@ +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Reporting +-- Copyright : (c) David Waern 2008 +-- License : BSD-like +-- +-- Maintainer : david.waern@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- Anonymous build report data structure, printing and parsing +-- +----------------------------------------------------------------------------- +module Distribution.Client.BuildReports.Storage ( + + -- * Storing and retrieving build reports + storeAnonymous, + storeLocal, +-- retrieve, + + -- * 'InstallPlan' support + fromInstallPlan, + fromPlanningFailure, + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Client.BuildReports.Anonymous (BuildReport, showBuildReport, newBuildReport) +import qualified Distribution.Client.BuildReports.Anonymous as BuildReport + +import Distribution.Client.Types +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.InstallPlan + ( InstallPlan ) + +import qualified Distribution.Solver.Types.ComponentDeps as CD +import Distribution.Solver.Types.SourcePackage + +import Distribution.Package + ( PackageId, packageId ) +import Distribution.PackageDescription + ( FlagAssignment ) +import Distribution.Simple.InstallDirs + ( PathTemplate, fromPathTemplate + , initialPathTemplateEnv, substPathTemplate ) +import Distribution.System + ( Platform(Platform) ) +import Distribution.Compiler + ( CompilerId(..), CompilerInfo(..) ) +import Distribution.Simple.Utils + ( equating ) + +import Data.List.NonEmpty + ( groupBy ) +import qualified Data.List as L +import System.FilePath + ( (), takeDirectory ) +import System.Directory + ( createDirectoryIfMissing ) + +storeAnonymous :: [(BuildReport, Maybe Repo)] -> IO () +storeAnonymous reports = sequence_ + [ appendFile file (concatMap format reports') + | (repo, reports') <- separate reports + , let file = repoLocalDir repo "build-reports.log" ] + --TODO: make this concurrency safe, either lock the report file or make sure + -- the writes for each report are atomic (under 4k and flush at boundaries) + + where + format r = '\n' : showBuildReport r ++ "\n" + 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 + + repoName' (_,_,rrepo) = remoteRepoName rrepo + + onlyRemote :: [(BuildReport, Maybe Repo)] + -> [(BuildReport, Repo, RemoteRepo)] + onlyRemote rs = + [ (report, repo, remoteRepo) + | (report, Just repo) <- rs + , Just remoteRepo <- [maybeRepoRemote repo] + ] + +storeLocal :: CompilerInfo -> [PathTemplate] -> [(BuildReport, Maybe Repo)] + -> Platform -> IO () +storeLocal cinfo templates reports platform = sequence_ + [ do createDirectoryIfMissing True (takeDirectory file) + appendFile file output + --TODO: make this concurrency safe, either lock the report file or make + -- sure the writes for each report are atomic + | (file, reports') <- groupByFileName + [ (reportFileName template report, report) + | template <- templates + , (report, _repo) <- reports ] + , let output = concatMap format reports' + ] + where + format r = '\n' : showBuildReport r ++ "\n" + + reportFileName template report = + fromPathTemplate (substPathTemplate env template) + where env = initialPathTemplateEnv + (BuildReport.package report) + -- TODO: In principle, we can support $pkgkey, but only + -- if the configure step succeeds. So add a Maybe field + -- to the build report, and either use that or make up + -- a fake identifier if it's not available. + (error "storeLocal: package key not available") + cinfo + platform + + groupByFileName = map (\grp@((filename,_):_) -> (filename, map snd grp)) + . L.groupBy (equating fst) + . sortBy (comparing fst) + +-- ------------------------------------------------------------ +-- * InstallPlan support +-- ------------------------------------------------------------ + +fromInstallPlan :: Platform -> CompilerId + -> InstallPlan + -> BuildOutcomes + -> [(BuildReport, Maybe Repo)] +fromInstallPlan platform comp plan buildOutcomes = + mapMaybe (\pkg -> fromPlanPackage + platform comp pkg + (InstallPlan.lookupBuildOutcome pkg buildOutcomes)) + . InstallPlan.toList + $ plan + +fromPlanPackage :: Platform -> CompilerId + -> InstallPlan.PlanPackage + -> Maybe BuildOutcome + -> Maybe (BuildReport, Maybe Repo) +fromPlanPackage (Platform arch os) comp + (InstallPlan.Configured (ConfiguredPackage _ srcPkg flags _ deps)) + (Just buildResult) = + Just ( newBuildReport os arch comp + (packageId srcPkg) flags + (map packageId (CD.nonSetupDeps deps)) + buildResult + , extractRepo srcPkg) + where + extractRepo (SourcePackage { srcpkgSource = RepoTarballPackage repo _ _ }) + = Just repo + extractRepo _ = Nothing + +fromPlanPackage _ _ _ _ = Nothing + + +fromPlanningFailure :: Platform -> CompilerId + -> [PackageId] -> FlagAssignment -> [(BuildReport, Maybe Repo)] +fromPlanningFailure (Platform arch os) comp pkgids flags = + [ (newBuildReport os arch comp pkgid flags [] (Left PlanningFailed), Nothing) + | pkgid <- pkgids ] diff --git a/cabal/cabal-install/src/Distribution/Client/BuildReports/Types.hs b/cabal/cabal-install/src/Distribution/Client/BuildReports/Types.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/BuildReports/Types.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE DeriveGeneric #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.BuildReports.Types +-- Copyright : (c) Duncan Coutts 2009 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Types related to build reporting +-- +----------------------------------------------------------------------------- +module Distribution.Client.BuildReports.Types ( + ReportLevel(..), + BuildReport (..), + InstallOutcome(..), + Outcome(..), +) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as Disp + +import Distribution.Compiler (CompilerId (..)) +import Distribution.PackageDescription (FlagAssignment) +import Distribution.System (Arch, OS) +import Distribution.Types.PackageId (PackageIdentifier) + +------------------------------------------------------------------------------- +-- ReportLevel +------------------------------------------------------------------------------- + +data ReportLevel = NoReports | AnonymousReports | DetailedReports + deriving (Eq, Ord, Enum, Bounded, Show, Generic) + +instance Binary ReportLevel +instance Structured ReportLevel + +instance Pretty ReportLevel where + pretty NoReports = Disp.text "none" + pretty AnonymousReports = Disp.text "anonymous" + pretty DetailedReports = Disp.text "detailed" + +instance Parsec ReportLevel where + parsec = do + name <- P.munch1 isAlpha + case lowercase name of + "none" -> return NoReports + "anonymous" -> return AnonymousReports + "detailed" -> return DetailedReports + _ -> P.unexpected $ "ReportLevel: " ++ name + +lowercase :: String -> String +lowercase = map toLower + +------------------------------------------------------------------------------- +-- BuildReport +------------------------------------------------------------------------------- + +data BuildReport = BuildReport { + -- | The package this build report is about + package :: PackageIdentifier, + + -- | The OS and Arch the package was built on + os :: OS, + arch :: Arch, + + -- | The Haskell compiler (and hopefully version) used + compiler :: CompilerId, + + -- | The uploading client, ie cabal-install-x.y.z + client :: PackageIdentifier, + + -- | Which configurations flags we used + flagAssignment :: FlagAssignment, + + -- | Which dependent packages we were using exactly + dependencies :: [PackageIdentifier], + + -- | Did installing work ok? + installOutcome :: InstallOutcome, + + -- Which version of the Cabal library was used to compile the Setup.hs +-- cabalVersion :: Version, + + -- Which build tools we were using (with versions) +-- tools :: [PackageIdentifier], + + -- | Configure outcome, did configure work ok? + docsOutcome :: Outcome, + + -- | Configure outcome, did configure work ok? + testsOutcome :: Outcome + } + deriving (Eq, Show, Generic) + + + +------------------------------------------------------------------------------- +-- InstallOutcome +------------------------------------------------------------------------------- + +data InstallOutcome + = PlanningFailed + | DependencyFailed PackageIdentifier + | DownloadFailed + | UnpackFailed + | SetupFailed + | ConfigureFailed + | BuildFailed + | TestsFailed + | InstallFailed + | InstallOk + deriving (Eq, Show, Generic) + +instance Pretty InstallOutcome where + pretty PlanningFailed = Disp.text "PlanningFailed" + pretty (DependencyFailed pkgid) = Disp.text "DependencyFailed" <+> pretty pkgid + pretty DownloadFailed = Disp.text "DownloadFailed" + pretty UnpackFailed = Disp.text "UnpackFailed" + pretty SetupFailed = Disp.text "SetupFailed" + pretty ConfigureFailed = Disp.text "ConfigureFailed" + pretty BuildFailed = Disp.text "BuildFailed" + pretty TestsFailed = Disp.text "TestsFailed" + pretty InstallFailed = Disp.text "InstallFailed" + pretty InstallOk = Disp.text "InstallOk" + +instance Parsec InstallOutcome where + parsec = do + name <- P.munch1 isAlpha + case name of + "PlanningFailed" -> return PlanningFailed + "DependencyFailed" -> DependencyFailed <$ P.spaces <*> parsec + "DownloadFailed" -> return DownloadFailed + "UnpackFailed" -> return UnpackFailed + "SetupFailed" -> return SetupFailed + "ConfigureFailed" -> return ConfigureFailed + "BuildFailed" -> return BuildFailed + "TestsFailed" -> return TestsFailed + "InstallFailed" -> return InstallFailed + "InstallOk" -> return InstallOk + _ -> P.unexpected $ "InstallOutcome: " ++ name + +------------------------------------------------------------------------------- +-- Outcome +------------------------------------------------------------------------------- + +data Outcome = NotTried | Failed | Ok + deriving (Eq, Show, Enum, Bounded, Generic) + +instance Pretty Outcome where + pretty NotTried = Disp.text "NotTried" + pretty Failed = Disp.text "Failed" + pretty Ok = Disp.text "Ok" + +instance Parsec Outcome where + parsec = do + name <- P.munch1 isAlpha + case name of + "NotTried" -> return NotTried + "Failed" -> return Failed + "Ok" -> return Ok + _ -> P.unexpected $ "Outcome: " ++ name diff --git a/cabal/cabal-install/src/Distribution/Client/BuildReports/Upload.hs b/cabal/cabal-install/src/Distribution/Client/BuildReports/Upload.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/BuildReports/Upload.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE CPP, PatternGuards #-} +-- This is a quick hack for uploading build reports to Hackage. + +module Distribution.Client.BuildReports.Upload + ( BuildLog + , BuildReportId + , uploadReports + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +{- +import Network.Browser + ( BrowserAction, request, setAllowRedirects ) +import Network.HTTP + ( Header(..), HeaderName(..) + , Request(..), RequestMethod(..), Response(..) ) +import Network.TCP (HandleStream) +-} +import Network.URI (URI, uriPath) --parseRelativeReference, relativeTo) + +import System.FilePath.Posix + ( () ) +import qualified Distribution.Client.BuildReports.Anonymous as BuildReport +import Distribution.Client.BuildReports.Anonymous (BuildReport, showBuildReport) +import Distribution.Simple.Utils (die') +import Distribution.Client.HttpUtils +import Distribution.Client.Setup + ( RepoContext(..) ) + +type BuildReportId = URI +type BuildLog = String + +uploadReports :: Verbosity -> RepoContext -> (String, String) -> URI -> [(BuildReport, Maybe BuildLog)] -> IO () +uploadReports verbosity repoCtxt auth uri reports = do + for_ reports $ \(report, mbBuildLog) -> do + buildId <- postBuildReport verbosity repoCtxt auth uri report + case mbBuildLog of + Just buildLog -> putBuildLog verbosity repoCtxt auth buildId buildLog + Nothing -> return () + +postBuildReport :: Verbosity -> RepoContext -> (String, String) -> URI -> BuildReport -> IO BuildReportId +postBuildReport verbosity repoCtxt auth uri buildReport = do + let fullURI = uri { uriPath = "/package" prettyShow (BuildReport.package buildReport) "reports" } + transport <- repoContextGetTransport repoCtxt + res <- postHttp transport verbosity fullURI (showBuildReport buildReport) (Just auth) + case res of + (303, redir) -> return $ undefined redir --TODO parse redir + _ -> die' verbosity "unrecognized response" -- give response + +{- + setAllowRedirects False + (_, response) <- request Request { + rqURI = uri { uriPath = "/package" prettyShow (BuildReport.package buildReport) "reports" }, + rqMethod = POST, + rqHeaders = [Header HdrContentType ("text/plain"), + Header HdrContentLength (show (length body)), + Header HdrAccept ("text/plain")], + rqBody = body + } + case rspCode response of + (3,0,3) | [Just buildId] <- [ do rel <- parseRelativeReference location +#if defined(VERSION_network_uri) + return $ relativeTo rel uri +#elif defined(VERSION_network) +#if MIN_VERSION_network(2,4,0) + return $ relativeTo rel uri +#else + relativeTo rel uri +#endif +#endif + | Header HdrLocation location <- rspHeaders response ] + -> return $ buildId + _ -> error "Unrecognised response from server." + where body = BuildReport.show buildReport +-} + + +-- TODO force this to be a PUT? + +putBuildLog :: Verbosity -> RepoContext -> (String, String) + -> BuildReportId -> BuildLog + -> IO () +putBuildLog verbosity repoCtxt auth reportId buildLog = do + let fullURI = reportId {uriPath = uriPath reportId "log"} + transport <- repoContextGetTransport repoCtxt + res <- postHttp transport verbosity fullURI buildLog (Just auth) + case res of + (200, _) -> return () + _ -> die' verbosity "unrecognized response" -- give response diff --git a/cabal/cabal-install/src/Distribution/Client/Check.hs b/cabal/cabal-install/src/Distribution/Client/Check.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Check.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Check +-- Copyright : (c) Lennart Kolmodin 2008 +-- License : BSD-like +-- +-- Maintainer : kolmodin@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Check a package for common mistakes +-- +----------------------------------------------------------------------------- +module Distribution.Client.Check ( + check + ) where + + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Client.Utils.Parsec (renderParseError) +import Distribution.PackageDescription (GenericPackageDescription) +import Distribution.PackageDescription.Check +import Distribution.PackageDescription.Configuration (flattenPackageDescription) +import Distribution.PackageDescription.Parsec + (parseGenericPackageDescription, runParseResult) +import Distribution.Parsec (PWarning (..), showPError, showPWarning) +import Distribution.Simple.Utils (defaultPackageDesc, die', notice, warn) +import System.IO (hPutStr, stderr) + +import qualified Data.ByteString as BS +import qualified System.Directory as Dir + +readGenericPackageDescriptionCheck :: Verbosity -> FilePath -> IO ([PWarning], GenericPackageDescription) +readGenericPackageDescriptionCheck verbosity fpath = do + exists <- Dir.doesFileExist fpath + unless exists $ + die' verbosity $ + "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue." + bs <- BS.readFile fpath + let (warnings, result) = runParseResult (parseGenericPackageDescription bs) + case result of + Left (_, errors) -> do + traverse_ (warn verbosity . showPError fpath) errors + hPutStr stderr $ renderParseError fpath bs errors warnings + die' verbosity "parse error" + Right x -> return (warnings, x) + +-- | Note: must be called with the CWD set to the directory containing +-- the '.cabal' file. +check :: Verbosity -> IO Bool +check verbosity = do + pdfile <- defaultPackageDesc verbosity + (ws, ppd) <- readGenericPackageDescriptionCheck verbosity pdfile + -- convert parse warnings into PackageChecks + -- Note: we /could/ pick different levels, based on warning type. + let ws' = [ PackageDistSuspicious (showPWarning pdfile w) | w <- ws ] + -- flatten the generic package description into a regular package + -- description + -- TODO: this may give more warnings than it should give; + -- consider two branches of a condition, one saying + -- ghc-options: -Wall + -- and the other + -- ghc-options: -Werror + -- joined into + -- ghc-options: -Wall -Werror + -- checkPackages will yield a warning on the last line, but it + -- would not on each individual branch. + -- However, this is the same way hackage does it, so we will yield + -- the exact same errors as it will. + let pkg_desc = flattenPackageDescription ppd + ioChecks <- checkPackageFiles verbosity pkg_desc "." + let packageChecks = ioChecks ++ checkPackage ppd (Just pkg_desc) ++ ws' + buildImpossible = [ x | x@PackageBuildImpossible {} <- packageChecks ] + buildWarning = [ x | x@PackageBuildWarning {} <- packageChecks ] + distSuspicious = [ x | x@PackageDistSuspicious {} <- packageChecks ] + ++ [ x | x@PackageDistSuspiciousWarn {} <- packageChecks ] + distInexusable = [ x | x@PackageDistInexcusable {} <- packageChecks ] + + unless (null buildImpossible) $ do + warn verbosity "The package will not build sanely due to these errors:" + printCheckMessages buildImpossible + + unless (null buildWarning) $ do + warn verbosity "The following warnings are likely to affect your build negatively:" + printCheckMessages buildWarning + + unless (null distSuspicious) $ do + warn verbosity "These warnings may cause trouble when distributing the package:" + printCheckMessages distSuspicious + + unless (null distInexusable) $ do + warn verbosity "The following errors will cause portability problems on other environments:" + printCheckMessages distInexusable + + let isDistError (PackageDistSuspicious {}) = False + isDistError (PackageDistSuspiciousWarn {}) = False + isDistError _ = True + isCheckError (PackageDistSuspiciousWarn {}) = False + isCheckError _ = True + errors = filter isDistError packageChecks + + unless (null errors) $ + warn verbosity "Hackage would reject this package." + + when (null packageChecks) $ + notice verbosity "No errors or warnings could be found in the package." + + return (not . any isCheckError $ packageChecks) + + where + printCheckMessages = traverse_ (warn verbosity . explanation) diff --git a/cabal/cabal-install/src/Distribution/Client/CmdBench.hs b/cabal/cabal-install/src/Distribution/Client/CmdBench.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/CmdBench.hs @@ -0,0 +1,252 @@ +{-# LANGUAGE RecordWildCards #-} + +-- | cabal-install CLI command: bench +-- +module Distribution.Client.CmdBench ( + -- * The @bench@ CLI and action + benchCommand, + benchAction, + + -- * Internals exposed for testing + componentNotBenchmarkProblem, + isSubComponentProblem, + noBenchmarksProblem, + selectPackageTargets, + selectComponentTarget + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Client.ProjectOrchestration +import Distribution.Client.CmdErrorMessages + ( renderTargetSelector, showTargetSelector, renderTargetProblem, + renderTargetProblemNoTargets, plural, targetSelectorPluralPkgs, + targetSelectorFilter ) +import Distribution.Client.TargetProblem + ( TargetProblem (..) ) +import Distribution.Client.NixStyleOptions + ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) +import Distribution.Client.Setup + ( GlobalFlags, ConfigFlags(..) ) +import Distribution.Simple.Flag + ( fromFlagOrDefault ) +import Distribution.Simple.Command + ( CommandUI(..), usageAlternatives ) +import Distribution.Verbosity + ( normal ) +import Distribution.Simple.Utils + ( wrapText, die' ) + +benchCommand :: CommandUI (NixStyleFlags ()) +benchCommand = CommandUI { + commandName = "v2-bench", + commandSynopsis = "Run benchmarks.", + commandUsage = usageAlternatives "v2-bench" [ "[TARGETS] [FLAGS]" ], + commandDescription = Just $ \_ -> wrapText $ + "Runs the specified benchmarks, first ensuring they are up to " + ++ "date.\n\n" + + ++ "Any benchmark in any package in the project can be specified. " + ++ "A package can be specified in which case all the benchmarks in the " + ++ "package are run. The default is to run all the benchmarks in the " + ++ "package in the current directory.\n\n" + + ++ "Dependencies are built or rebuilt as necessary. Additional " + ++ "configuration flags can be specified on the command line and these " + ++ "extend the project configuration from the 'cabal.project', " + ++ "'cabal.project.local' and other files.", + commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " v2-bench\n" + ++ " Run all the benchmarks in the package in the current directory\n" + ++ " " ++ pname ++ " v2-bench pkgname\n" + ++ " Run all the benchmarks in the package named pkgname\n" + ++ " " ++ pname ++ " v2-bench cname\n" + ++ " Run the benchmark named cname\n" + ++ " " ++ pname ++ " v2-bench cname -O2\n" + ++ " Run the benchmark built with '-O2' (including local libs used)\n" + + , commandDefaultFlags = defaultNixStyleFlags () + , commandOptions = nixStyleOptions (const []) + } + + +-- | The @build@ command does a lot. It brings the install plan up to date, +-- selects that part of the plan needed by the given or implicit targets and +-- then executes the plan. +-- +-- For more details on how this works, see the module +-- "Distribution.Client.ProjectOrchestration" +-- +benchAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO () +benchAction flags@NixStyleFlags {..} targetStrings globalFlags = do + + baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand + + targetSelectors <- either (reportTargetSelectorProblems verbosity) return + =<< readTargetSelectors (localPackages baseCtx) (Just BenchKind) targetStrings + + buildCtx <- + runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do + + when (buildSettingOnlyDeps (buildSettings baseCtx)) $ + die' verbosity $ + "The bench command does not support '--only-dependencies'. " + ++ "You may wish to use 'build --only-dependencies' and then " + ++ "use 'bench'." + + -- Interpret the targets on the command line as bench targets + -- (as opposed to say build or haddock targets). + targets <- either (reportTargetProblems verbosity) return + $ resolveTargets + selectPackageTargets + selectComponentTarget + elaboratedPlan + Nothing + targetSelectors + + let elaboratedPlan' = pruneInstallPlanToTargets + TargetActionBench + targets + elaboratedPlan + return (elaboratedPlan', targets) + + printPlan verbosity baseCtx buildCtx + + buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx + runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes + where + verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + cliConfig = commandLineFlagsToProjectConfig globalFlags flags + mempty -- ClientInstallFlags, not needed here + +-- | This defines what a 'TargetSelector' means for the @bench@ command. +-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, +-- or otherwise classifies the problem. +-- +-- For the @bench@ command we select all buildable benchmarks, +-- or fail if there are no benchmarks or no buildable benchmarks. +-- +selectPackageTargets :: TargetSelector + -> [AvailableTarget k] -> Either BenchTargetProblem [k] +selectPackageTargets targetSelector targets + + -- If there are any buildable benchmark targets then we select those + | not (null targetsBenchBuildable) + = Right targetsBenchBuildable + + -- If there are benchmarks but none are buildable then we report those + | not (null targetsBench) + = Left (TargetProblemNoneEnabled targetSelector targetsBench) + + -- If there are no benchmarks but some other targets then we report that + | not (null targets) + = Left (noBenchmarksProblem targetSelector) + + -- If there are no targets at all then we report that + | otherwise + = Left (TargetProblemNoTargets targetSelector) + where + targetsBenchBuildable = selectBuildableTargets + . filterTargetsKind BenchKind + $ targets + + targetsBench = forgetTargetsDetail + . filterTargetsKind BenchKind + $ targets + + +-- | For a 'TargetComponent' 'TargetSelector', check if the component can be +-- selected. +-- +-- For the @bench@ command we just need to check it is a benchmark, in addition +-- to the basic checks on being buildable etc. +-- +selectComponentTarget :: SubComponentTarget + -> AvailableTarget k -> Either BenchTargetProblem k +selectComponentTarget subtarget@WholeComponent t + | CBenchName _ <- availableTargetComponentName t + = selectComponentTargetBasic subtarget t + | otherwise + = Left (componentNotBenchmarkProblem + (availableTargetPackageId t) + (availableTargetComponentName t)) + +selectComponentTarget subtarget t + = Left (isSubComponentProblem + (availableTargetPackageId t) + (availableTargetComponentName t) + subtarget) + +-- | The various error conditions that can occur when matching a +-- 'TargetSelector' against 'AvailableTarget's for the @bench@ command. +-- +data BenchProblem = + -- | The 'TargetSelector' matches targets but no benchmarks + TargetProblemNoBenchmarks TargetSelector + + -- | The 'TargetSelector' refers to a component that is not a benchmark + | TargetProblemComponentNotBenchmark PackageId ComponentName + + -- | Asking to benchmark an individual file or module is not supported + | TargetProblemIsSubComponent PackageId ComponentName SubComponentTarget + deriving (Eq, Show) + + +type BenchTargetProblem = TargetProblem BenchProblem + +noBenchmarksProblem :: TargetSelector -> TargetProblem BenchProblem +noBenchmarksProblem = CustomTargetProblem . TargetProblemNoBenchmarks + +componentNotBenchmarkProblem :: PackageId -> ComponentName -> TargetProblem BenchProblem +componentNotBenchmarkProblem pkgid name = CustomTargetProblem $ + TargetProblemComponentNotBenchmark pkgid name + +isSubComponentProblem + :: PackageId + -> ComponentName + -> SubComponentTarget + -> TargetProblem BenchProblem +isSubComponentProblem pkgid name subcomponent = CustomTargetProblem $ + TargetProblemIsSubComponent pkgid name subcomponent + +reportTargetProblems :: Verbosity -> [BenchTargetProblem] -> IO a +reportTargetProblems verbosity = + die' verbosity . unlines . map renderBenchTargetProblem + +renderBenchTargetProblem :: BenchTargetProblem -> String +renderBenchTargetProblem (TargetProblemNoTargets targetSelector) = + case targetSelectorFilter targetSelector of + Just kind | kind /= BenchKind + -> "The bench command is for running benchmarks, but the target '" + ++ showTargetSelector targetSelector ++ "' refers to " + ++ renderTargetSelector targetSelector ++ "." + + _ -> renderTargetProblemNoTargets "benchmark" targetSelector +renderBenchTargetProblem problem = + renderTargetProblem "benchmark" renderBenchProblem problem + +renderBenchProblem :: BenchProblem -> String +renderBenchProblem (TargetProblemNoBenchmarks targetSelector) = + "Cannot run benchmarks for the target '" ++ showTargetSelector targetSelector + ++ "' which refers to " ++ renderTargetSelector targetSelector + ++ " because " + ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do" + ++ " not contain any benchmarks." + +renderBenchProblem (TargetProblemComponentNotBenchmark pkgid cname) = + "The bench command is for running benchmarks, but the target '" + ++ showTargetSelector targetSelector ++ "' refers to " + ++ renderTargetSelector targetSelector ++ " from the package " + ++ prettyShow pkgid ++ "." + where + targetSelector = TargetComponent pkgid cname WholeComponent + +renderBenchProblem (TargetProblemIsSubComponent pkgid cname subtarget) = + "The bench command can only run benchmarks as a whole, " + ++ "not files or modules within them, but the target '" + ++ showTargetSelector targetSelector ++ "' refers to " + ++ renderTargetSelector targetSelector ++ "." + where + targetSelector = TargetComponent pkgid cname subtarget diff --git a/cabal/cabal-install/src/Distribution/Client/CmdBuild.hs b/cabal/cabal-install/src/Distribution/Client/CmdBuild.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/CmdBuild.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE RecordWildCards #-} +-- | cabal-install CLI command: build +-- +module Distribution.Client.CmdBuild ( + -- * The @build@ CLI and action + buildCommand, + buildAction, + + BuildFlags(..), + defaultBuildFlags, + + -- * Internals exposed for testing + selectPackageTargets, + selectComponentTarget + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Distribution.Client.ProjectFlags + ( removeIgnoreProjectOption ) +import Distribution.Client.ProjectOrchestration +import Distribution.Client.TargetProblem + ( TargetProblem (..), TargetProblem' ) +import Distribution.Client.CmdErrorMessages + +import Distribution.Client.NixStyleOptions + ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) +import Distribution.Client.Setup + ( GlobalFlags, ConfigFlags(..), yesNoOpt ) +import Distribution.Simple.Flag ( Flag(..), toFlag, fromFlag, fromFlagOrDefault ) +import Distribution.Simple.Command + ( CommandUI(..), usageAlternatives, option ) +import Distribution.Verbosity + ( normal ) +import Distribution.Simple.Utils + ( wrapText, die' ) +import Distribution.Client.ScriptUtils + ( AcceptNoTargets(..), withContextAndSelectors, updateContextAndWriteProjectFile, TargetContext(..) ) + +import qualified Data.Map as Map + + +buildCommand :: CommandUI (NixStyleFlags BuildFlags) +buildCommand = CommandUI { + commandName = "v2-build", + commandSynopsis = "Compile targets within the project.", + commandUsage = usageAlternatives "v2-build" [ "[TARGETS] [FLAGS]" ], + commandDescription = Just $ \_ -> wrapText $ + "Build one or more targets from within the project. The available " + ++ "targets are the packages in the project as well as individual " + ++ "components within those packages, including libraries, executables, " + ++ "test-suites or benchmarks. Targets can be specified by name or " + ++ "location. If no target is specified then the default is to build " + ++ "the package in the current directory.\n\n" + + ++ "Dependencies are built or rebuilt as necessary. Additional " + ++ "configuration flags can be specified on the command line and these " + ++ "extend the project configuration from the 'cabal.project', " + ++ "'cabal.project.local' and other files.", + commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " v2-build\n" + ++ " Build the package in the current directory " + ++ "or all packages in the project\n" + ++ " " ++ pname ++ " v2-build pkgname\n" + ++ " Build the package named pkgname in the project\n" + ++ " " ++ pname ++ " v2-build ./pkgfoo\n" + ++ " Build the package in the ./pkgfoo directory\n" + ++ " " ++ pname ++ " v2-build cname\n" + ++ " Build the component named cname in the project\n" + ++ " " ++ pname ++ " v2-build cname --enable-profiling\n" + ++ " Build the component in profiling mode " + ++ "(including dependencies as needed)\n" + + , commandDefaultFlags = defaultNixStyleFlags defaultBuildFlags + , commandOptions = removeIgnoreProjectOption + . nixStyleOptions (\showOrParseArgs -> + [ option [] ["only-configure"] + "Instead of performing a full build just run the configure step" + buildOnlyConfigure (\v flags -> flags { buildOnlyConfigure = v }) + (yesNoOpt showOrParseArgs) + ]) + } + +data BuildFlags = BuildFlags + { buildOnlyConfigure :: Flag Bool + } + +defaultBuildFlags :: BuildFlags +defaultBuildFlags = BuildFlags + { buildOnlyConfigure = toFlag False + } + +-- | The @build@ command does a lot. It brings the install plan up to date, +-- selects that part of the plan needed by the given or implicit targets and +-- then executes the plan. +-- +-- For more details on how this works, see the module +-- "Distribution.Client.ProjectOrchestration" +-- +buildAction :: NixStyleFlags BuildFlags -> [String] -> GlobalFlags -> IO () +buildAction flags@NixStyleFlags { extraFlags = buildFlags, ..} targetStrings globalFlags + = withContextAndSelectors RejectNoTargets Nothing flags targetStrings globalFlags $ \targetCtx ctx targetSelectors -> do + -- TODO: This flags defaults business is ugly + let onlyConfigure = fromFlag (buildOnlyConfigure defaultBuildFlags + <> buildOnlyConfigure buildFlags) + targetAction + | onlyConfigure = TargetActionConfigure + | otherwise = TargetActionBuild + + baseCtx <- case targetCtx of + ProjectContext -> return ctx + GlobalContext -> return ctx + ScriptContext path exemeta -> updateContextAndWriteProjectFile ctx path exemeta + + buildCtx <- + runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do + + -- Interpret the targets on the command line as build targets + -- (as opposed to say repl or haddock targets). + targets <- either (reportBuildTargetProblems verbosity) return + $ resolveTargets + selectPackageTargets + selectComponentTarget + elaboratedPlan + Nothing + targetSelectors + + let elaboratedPlan' = pruneInstallPlanToTargets + targetAction + targets + elaboratedPlan + elaboratedPlan'' <- + if buildSettingOnlyDeps (buildSettings baseCtx) + then either (reportCannotPruneDependencies verbosity) return $ + pruneInstallPlanToDependencies (Map.keysSet targets) + elaboratedPlan' + else return elaboratedPlan' + + return (elaboratedPlan'', targets) + + printPlan verbosity baseCtx buildCtx + + buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx + runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes + where + verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + +-- | This defines what a 'TargetSelector' means for the @bench@ command. +-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, +-- or otherwise classifies the problem. +-- +-- For the @build@ command select all components except non-buildable +-- and disabled tests\/benchmarks, fail if there are no such +-- components +-- +selectPackageTargets :: TargetSelector + -> [AvailableTarget k] -> Either TargetProblem' [k] +selectPackageTargets targetSelector targets + + -- If there are any buildable targets then we select those + | not (null targetsBuildable) + = Right targetsBuildable + + -- If there are targets but none are buildable then we report those + | not (null targets) + = Left (TargetProblemNoneEnabled targetSelector targets') + + -- If there are no targets at all then we report that + | otherwise + = Left (TargetProblemNoTargets targetSelector) + where + targets' = forgetTargetsDetail targets + targetsBuildable = selectBuildableTargetsWith + (buildable targetSelector) + targets + + -- When there's a target filter like "pkg:tests" then we do select tests, + -- but if it's just a target like "pkg" then we don't build tests unless + -- they are requested by default (i.e. by using --enable-tests) + buildable (TargetPackage _ _ Nothing) TargetNotRequestedByDefault = False + buildable (TargetAllPackages Nothing) TargetNotRequestedByDefault = False + buildable _ _ = True + +-- | For a 'TargetComponent' 'TargetSelector', check if the component can be +-- selected. +-- +-- For the @build@ command we just need the basic checks on being buildable etc. +-- +selectComponentTarget :: SubComponentTarget + -> AvailableTarget k -> Either TargetProblem' k +selectComponentTarget = selectComponentTargetBasic + +reportBuildTargetProblems :: Verbosity -> [TargetProblem'] -> IO a +reportBuildTargetProblems verbosity problems = + reportTargetProblems verbosity "build" problems + +reportCannotPruneDependencies :: Verbosity -> CannotPruneDependencies -> IO a +reportCannotPruneDependencies verbosity = + die' verbosity . renderCannotPruneDependencies diff --git a/cabal/cabal-install/src/Distribution/Client/CmdClean.hs b/cabal/cabal-install/src/Distribution/Client/CmdClean.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/CmdClean.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE RecordWildCards #-} +module Distribution.Client.CmdClean (cleanCommand, cleanAction) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Distribution.Client.DistDirLayout + ( DistDirLayout(..), defaultDistDirLayout ) +import Distribution.Client.ProjectConfig + ( findProjectRoot ) +import Distribution.Client.ScriptUtils + ( getScriptCacheDirectoryRoot ) +import Distribution.Client.Setup + ( GlobalFlags ) +import Distribution.ReadE ( succeedReadE ) +import Distribution.Simple.Setup + ( Flag(..), toFlag, fromFlagOrDefault, flagToList, flagToMaybe + , optionDistPref, optionVerbosity, falseArg + ) +import Distribution.Simple.Command + ( CommandUI(..), option, reqArg ) +import Distribution.Simple.Utils + ( info, die', wrapText, handleDoesNotExist ) +import Distribution.Verbosity + ( normal ) + +import Control.Monad + ( forM, forM_, mapM ) +import qualified Data.Set as Set +import System.Directory + ( removeDirectoryRecursive, removeFile + , doesDirectoryExist, doesFileExist + , getDirectoryContents, listDirectory + , canonicalizePath ) +import System.FilePath + ( () ) + +data CleanFlags = CleanFlags + { cleanSaveConfig :: Flag Bool + , cleanVerbosity :: Flag Verbosity + , cleanDistDir :: Flag FilePath + , cleanProjectFile :: Flag FilePath + } deriving (Eq) + +defaultCleanFlags :: CleanFlags +defaultCleanFlags = CleanFlags + { cleanSaveConfig = toFlag False + , cleanVerbosity = toFlag normal + , cleanDistDir = NoFlag + , cleanProjectFile = mempty + } + +cleanCommand :: CommandUI CleanFlags +cleanCommand = CommandUI + { commandName = "v2-clean" + , commandSynopsis = "Clean the package store and remove temporary files." + , commandUsage = \pname -> + "Usage: " ++ pname ++ " new-clean [FLAGS]\n" + , commandDescription = Just $ \_ -> wrapText $ + "Removes all temporary files created during the building process " + ++ "(.hi, .o, preprocessed sources, etc.) and also empties out the " + ++ "local caches (by default).\n\n" + , commandNotes = Nothing + , commandDefaultFlags = defaultCleanFlags + , commandOptions = \showOrParseArgs -> + [ optionVerbosity + cleanVerbosity (\v flags -> flags { cleanVerbosity = v }) + , optionDistPref + cleanDistDir (\dd flags -> flags { cleanDistDir = dd }) + showOrParseArgs + , option [] ["project-file"] + ("Set the name of the cabal.project file" + ++ " to search for in parent directories") + cleanProjectFile (\pf flags -> flags {cleanProjectFile = pf}) + (reqArg "FILE" (succeedReadE Flag) flagToList) + , option ['s'] ["save-config"] + "Save configuration, only remove build artifacts" + cleanSaveConfig (\sc flags -> flags { cleanSaveConfig = sc }) + falseArg + ] + } + +cleanAction :: CleanFlags -> [String] -> GlobalFlags -> IO () +cleanAction CleanFlags{..} extraArgs _ = do + let verbosity = fromFlagOrDefault normal cleanVerbosity + saveConfig = fromFlagOrDefault False cleanSaveConfig + mdistDirectory = flagToMaybe cleanDistDir + mprojectFile = flagToMaybe cleanProjectFile + + -- TODO interpret extraArgs as targets and clean those targets only (issue #7506) + -- + -- For now assume all files passed are the names of scripts + notScripts <- filterM (fmap not . doesFileExist) extraArgs + unless (null notScripts) $ + die' verbosity $ "'clean' extra arguments should be script files: " + ++ unwords notScripts + + projectRoot <- either throwIO return =<< findProjectRoot Nothing mprojectFile + + let distLayout = defaultDistDirLayout projectRoot mdistDirectory + + -- Do not clean a project if just running a script in it's directory + when (null extraArgs || isJust mdistDirectory) $ do + if saveConfig then do + let buildRoot = distBuildRootDirectory distLayout + + buildRootExists <- doesDirectoryExist buildRoot + + when buildRootExists $ do + info verbosity ("Deleting build root (" ++ buildRoot ++ ")") + handleDoesNotExist () $ removeDirectoryRecursive buildRoot + else do + let distRoot = distDirectory distLayout + + info verbosity ("Deleting dist-newstyle (" ++ distRoot ++ ")") + handleDoesNotExist () $ removeDirectoryRecursive distRoot + + removeEnvFiles (distProjectRootDirectory distLayout) + + -- Clean specified script build caches and orphaned caches. + -- There is currently no good way to specify to only clean orphaned caches. + -- It would be better as part of an explicit gc step (see issue #3333) + toClean <- Set.fromList <$> mapM canonicalizePath extraArgs + cacheDir <- getScriptCacheDirectoryRoot + existsCD <- doesDirectoryExist cacheDir + caches <- if existsCD then listDirectory cacheDir else return [] + paths <- fmap concat . forM caches $ \cache -> do + let locFile = cacheDir cache "scriptlocation" + exists <- doesFileExist locFile + if exists then pure . (,) (cacheDir cache) <$> readFile locFile else return [] + forM_ paths $ \(cache, script) -> do + exists <- doesFileExist script + when (not exists || script `Set.member` toClean) $ do + info verbosity ("Deleting cache (" ++ cache ++ ") for script (" ++ script ++ ")") + removeDirectoryRecursive cache + +removeEnvFiles :: FilePath -> IO () +removeEnvFiles dir = + (traverse_ (removeFile . (dir )) . filter ((".ghc.environment" ==) . take 16)) + =<< getDirectoryContents dir diff --git a/cabal/cabal-install/src/Distribution/Client/CmdConfigure.hs b/cabal/cabal-install/src/Distribution/Client/CmdConfigure.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/CmdConfigure.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE RecordWildCards #-} +-- | cabal-install CLI command: configure +-- +module Distribution.Client.CmdConfigure ( + configureCommand, + configureAction, + configureAction', + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import System.Directory +import System.FilePath + +import Distribution.Simple.Flag +import Distribution.Client.ProjectOrchestration +import Distribution.Client.ProjectConfig + ( writeProjectLocalExtraConfig, readProjectLocalExtraConfig ) +import Distribution.Client.ProjectFlags + ( removeIgnoreProjectOption ) + +import Distribution.Client.NixStyleOptions + ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) +import Distribution.Client.Setup + ( GlobalFlags, ConfigFlags(..), ConfigExFlags(..) ) +import Distribution.Verbosity + ( normal ) + +import Distribution.Simple.Command + ( CommandUI(..), usageAlternatives ) +import Distribution.Simple.Utils + ( wrapText, notice, die' ) + +import Distribution.Client.DistDirLayout + ( DistDirLayout(..) ) +import Distribution.Client.RebuildMonad (runRebuild) +import Distribution.Client.ProjectConfig.Types +import Distribution.Client.HttpUtils +import Distribution.Utils.NubList + ( fromNubList ) +import Distribution.Types.CondTree + ( CondTree (..) ) + +configureCommand :: CommandUI (NixStyleFlags ()) +configureCommand = CommandUI { + commandName = "v2-configure", + commandSynopsis = "Add extra project configuration.", + commandUsage = usageAlternatives "v2-configure" [ "[FLAGS]" ], + commandDescription = Just $ \_ -> wrapText $ + "Adjust how the project is built by setting additional package flags " + ++ "and other flags.\n\n" + + ++ "The configuration options are written to the 'cabal.project.local' " + ++ "file (or '$project_file.local', if '--project-file' is specified) " + ++ "which extends the configuration from the 'cabal.project' file " + ++ "(if any). This combination is used as the project configuration for " + ++ "all other commands (such as 'v2-build', 'v2-repl' etc) though it " + ++ "can be extended/overridden on a per-command basis.\n\n" + + ++ "The v2-configure command also checks that the project configuration " + ++ "will work. In particular it checks that there is a consistent set of " + ++ "dependencies for the project as a whole.\n\n" + + ++ "The 'cabal.project.local' file persists across 'v2-clean' but is " + ++ "overwritten on the next use of the 'v2-configure' command. The " + ++ "intention is that the 'cabal.project' file should be kept in source " + ++ "control but the 'cabal.project.local' should not.\n\n" + + ++ "It is never necessary to use the 'v2-configure' command. It is " + ++ "merely a convenience in cases where you do not want to specify flags " + ++ "to 'v2-build' (and other commands) every time and yet do not want " + ++ "to alter the 'cabal.project' persistently.", + commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " v2-configure --with-compiler ghc-7.10.3\n" + ++ " Adjust the project configuration to use the given compiler\n" + ++ " program and check the resulting configuration works.\n" + ++ " " ++ pname ++ " v2-configure\n" + ++ " Reset the local configuration to empty. To check that the\n" + ++ " project configuration works, use 'cabal build'.\n" + + , commandDefaultFlags = defaultNixStyleFlags () + , commandOptions = removeIgnoreProjectOption + . nixStyleOptions (const []) + } + +-- | To a first approximation, the @configure@ just runs the first phase of +-- the @build@ command where we bring the install plan up to date (thus +-- checking that it's possible). +-- +-- The only difference is that @configure@ also allows the user to specify +-- some extra config flags which we save in the file @cabal.project.local@. +-- +-- For more details on how this works, see the module +-- "Distribution.Client.ProjectOrchestration" +-- +configureAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO () +configureAction flags@NixStyleFlags {..} extraArgs globalFlags = do + (baseCtx, projConfig) <- configureAction' flags extraArgs globalFlags + + if shouldNotWriteFile baseCtx + then notice v "Config file not written due to flag(s)." + else writeProjectLocalExtraConfig (distDirLayout baseCtx) projConfig + where + v = fromFlagOrDefault normal (configVerbosity configFlags) + +configureAction' :: NixStyleFlags () -> [String] -> GlobalFlags -> IO (ProjectBaseContext, ProjectConfig) +configureAction' flags@NixStyleFlags {..} _extraArgs globalFlags = do + --TODO: deal with _extraArgs, since flags with wrong syntax end up there + + baseCtx <- establishProjectBaseContext v cliConfig OtherCommand + + let localFile = distProjectFile (distDirLayout baseCtx) "local" + -- If cabal.project.local already exists, and the flags allow, back up to cabal.project.local~ + let backups = fromFlagOrDefault True $ configBackup configExFlags + appends = fromFlagOrDefault False $ configAppend configExFlags + backupFile = localFile <> "~" + + if shouldNotWriteFile baseCtx + then + return (baseCtx, cliConfig) + else do + exists <- doesFileExist localFile + when (exists && backups) $ do + notice v $ + quote (takeFileName localFile) <> " already exists, backing it up to " + <> quote (takeFileName backupFile) <> "." + copyFile localFile backupFile + + -- If the flag @configAppend@ is set to true, append and do not overwrite + if exists && appends + then do + httpTransport <- configureTransport v + (fromNubList . projectConfigProgPathExtra $ projectConfigShared cliConfig) + (flagToMaybe . projectConfigHttpTransport $ projectConfigBuildOnly cliConfig) + (CondNode conf imps bs) <- runRebuild (distProjectRootDirectory . distDirLayout $ baseCtx) $ + readProjectLocalExtraConfig v httpTransport (distDirLayout baseCtx) + when (not (null imps && null bs)) $ die' v "local project file has conditional and/or import logic, unable to perform and automatic in-place update" + return (baseCtx, conf <> cliConfig) + else + return (baseCtx, cliConfig) + where + v = fromFlagOrDefault normal (configVerbosity configFlags) + cliConfig = commandLineFlagsToProjectConfig globalFlags flags + mempty -- ClientInstallFlags, not needed here + quote s = "'" <> s <> "'" + +-- Config file should not be written when certain flags are present +shouldNotWriteFile :: ProjectBaseContext -> Bool +shouldNotWriteFile baseCtx = + buildSettingDryRun (buildSettings baseCtx) + || buildSettingOnlyDownload (buildSettings baseCtx) diff --git a/cabal/cabal-install/src/Distribution/Client/CmdErrorMessages.hs b/cabal/cabal-install/src/Distribution/Client/CmdErrorMessages.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/CmdErrorMessages.hs @@ -0,0 +1,444 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} + + +-- | Utilities to help format error messages for the various CLI commands. +-- +module Distribution.Client.CmdErrorMessages ( + module Distribution.Client.CmdErrorMessages, + module Distribution.Client.TargetSelector, + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Client.ProjectPlanning + ( AvailableTarget(..), AvailableTargetStatus(..), + CannotPruneDependencies(..), TargetRequested(..) ) +import Distribution.Client.TargetSelector + ( SubComponentTarget(..) ) +import Distribution.Client.TargetProblem + ( TargetProblem(..), TargetProblem' ) +import Distribution.Client.TargetSelector + ( ComponentKind(..), ComponentKindFilter, TargetSelector(..), + componentKind, showTargetSelector ) + +import Distribution.Package + ( PackageId, packageId, PackageName, packageName ) +import Distribution.Simple.Utils + ( die' ) +import Distribution.Types.ComponentName + ( ComponentName(..), showComponentName ) +import Distribution.Types.LibraryName + ( LibraryName(..) ) +import Distribution.Solver.Types.OptionalStanza + ( OptionalStanza(..) ) + +import qualified Data.List.NonEmpty as NE + + +----------------------- +-- Singular or plural +-- + +-- | A tag used in rendering messages to distinguish singular or plural. +-- +data Plural = Singular | Plural + +-- | Used to render a singular or plural version of something +-- +-- > plural (listPlural theThings) "it is" "they are" +-- +plural :: Plural -> a -> a -> a +plural Singular si _pl = si +plural Plural _si pl = pl + +-- | Singular for singleton lists and plural otherwise. +-- +listPlural :: [a] -> Plural +listPlural [_] = Singular +listPlural _ = Plural + + +-------------------- +-- Rendering lists +-- + +-- | Render a list of things in the style @foo, bar and baz@ +renderListCommaAnd :: [String] -> String +renderListCommaAnd [] = "" +renderListCommaAnd [x] = x +renderListCommaAnd [x,x'] = x ++ " and " ++ x' +renderListCommaAnd (x:xs) = x ++ ", " ++ renderListCommaAnd xs + +-- | Render a list of things in the style @blah blah; this that; and the other@ +renderListSemiAnd :: [String] -> String +renderListSemiAnd [] = "" +renderListSemiAnd [x] = x +renderListSemiAnd [x,x'] = x ++ "; and " ++ x' +renderListSemiAnd (x:xs) = x ++ "; " ++ renderListSemiAnd xs + +-- | When rendering lists of things it often reads better to group related +-- things, e.g. grouping components by package name +-- +-- > renderListSemiAnd +-- > [ "the package " ++ prettyShow pkgname ++ " components " +-- > ++ renderListCommaAnd showComponentName components +-- > | (pkgname, components) <- sortGroupOn packageName allcomponents ] +-- +sortGroupOn :: Ord b => (a -> b) -> [a] -> [(b, [a])] +sortGroupOn key = map (\(x:|xs) -> (key x, x:xs)) + . NE.groupBy ((==) `on` key) + . sortBy (compare `on` key) + + +---------------------------------------------------- +-- Rendering for a few project and package types +-- + +renderTargetSelector :: TargetSelector -> String +renderTargetSelector (TargetPackage _ pkgids Nothing) = + "the " ++ plural (listPlural pkgids) "package" "packages" ++ " " + ++ renderListCommaAnd (map prettyShow pkgids) + +renderTargetSelector (TargetPackage _ pkgids (Just kfilter)) = + "the " ++ renderComponentKind Plural kfilter + ++ " in the " ++ plural (listPlural pkgids) "package" "packages" ++ " " + ++ renderListCommaAnd (map prettyShow pkgids) + +renderTargetSelector (TargetPackageNamed pkgname Nothing) = + "the package " ++ prettyShow pkgname + +renderTargetSelector (TargetPackageNamed pkgname (Just kfilter)) = + "the " ++ renderComponentKind Plural kfilter + ++ " in the package " ++ prettyShow pkgname + +renderTargetSelector (TargetAllPackages Nothing) = + "all the packages in the project" + +renderTargetSelector (TargetAllPackages (Just kfilter)) = + "all the " ++ renderComponentKind Plural kfilter + ++ " in the project" + +renderTargetSelector (TargetComponent pkgid cname subtarget) = + renderSubComponentTarget subtarget ++ "the " + ++ renderComponentName (packageName pkgid) cname + +renderTargetSelector (TargetComponentUnknown pkgname (Left ucname) subtarget) = + renderSubComponentTarget subtarget ++ "the component " ++ prettyShow ucname + ++ " in the package " ++ prettyShow pkgname + +renderTargetSelector (TargetComponentUnknown pkgname (Right cname) subtarget) = + renderSubComponentTarget subtarget ++ "the " + ++ renderComponentName pkgname cname + +renderSubComponentTarget :: SubComponentTarget -> String +renderSubComponentTarget WholeComponent = "" +renderSubComponentTarget (FileTarget filename) = + "the file " ++ filename ++ " in " +renderSubComponentTarget (ModuleTarget modname) = + "the module " ++ prettyShow modname ++ " in " + + +renderOptionalStanza :: Plural -> OptionalStanza -> String +renderOptionalStanza Singular TestStanzas = "test suite" +renderOptionalStanza Plural TestStanzas = "test suites" +renderOptionalStanza Singular BenchStanzas = "benchmark" +renderOptionalStanza Plural BenchStanzas = "benchmarks" + +-- | The optional stanza type (test suite or benchmark), if it is one. +optionalStanza :: ComponentName -> Maybe OptionalStanza +optionalStanza (CTestName _) = Just TestStanzas +optionalStanza (CBenchName _) = Just BenchStanzas +optionalStanza _ = Nothing + +-- | Does the 'TargetSelector' potentially refer to one package or many? +-- +targetSelectorPluralPkgs :: TargetSelector -> Plural +targetSelectorPluralPkgs (TargetAllPackages _) = Plural +targetSelectorPluralPkgs (TargetPackage _ pids _) = listPlural pids +targetSelectorPluralPkgs (TargetPackageNamed _ _) = Singular +targetSelectorPluralPkgs TargetComponent{} = Singular +targetSelectorPluralPkgs TargetComponentUnknown{} = Singular + +-- | Does the 'TargetSelector' refer to packages or to components? +targetSelectorRefersToPkgs :: TargetSelector -> Bool +targetSelectorRefersToPkgs (TargetAllPackages mkfilter) = isNothing mkfilter +targetSelectorRefersToPkgs (TargetPackage _ _ mkfilter) = isNothing mkfilter +targetSelectorRefersToPkgs (TargetPackageNamed _ mkfilter) = isNothing mkfilter +targetSelectorRefersToPkgs TargetComponent{} = False +targetSelectorRefersToPkgs TargetComponentUnknown{} = False + +targetSelectorFilter :: TargetSelector -> Maybe ComponentKindFilter +targetSelectorFilter (TargetPackage _ _ mkfilter) = mkfilter +targetSelectorFilter (TargetPackageNamed _ mkfilter) = mkfilter +targetSelectorFilter (TargetAllPackages mkfilter) = mkfilter +targetSelectorFilter TargetComponent{} = Nothing +targetSelectorFilter TargetComponentUnknown{} = Nothing + +renderComponentName :: PackageName -> ComponentName -> String +renderComponentName pkgname (CLibName LMainLibName) = "library " ++ prettyShow pkgname +renderComponentName _ (CLibName (LSubLibName name)) = "library " ++ prettyShow name +renderComponentName _ (CFLibName name) = "foreign library " ++ prettyShow name +renderComponentName _ (CExeName name) = "executable " ++ prettyShow name +renderComponentName _ (CTestName name) = "test suite " ++ prettyShow name +renderComponentName _ (CBenchName name) = "benchmark " ++ prettyShow name + +renderComponentKind :: Plural -> ComponentKind -> String +renderComponentKind Singular ckind = case ckind of + LibKind -> "library" -- internal/sub libs? + FLibKind -> "foreign library" + ExeKind -> "executable" + TestKind -> "test suite" + BenchKind -> "benchmark" +renderComponentKind Plural ckind = case ckind of + LibKind -> "libraries" -- internal/sub libs? + FLibKind -> "foreign libraries" + ExeKind -> "executables" + TestKind -> "test suites" + BenchKind -> "benchmarks" + + +------------------------------------------------------- +-- Rendering error messages for TargetProblem +-- + +-- | Default implementation of 'reportTargetProblems' simply renders one problem per line. +reportTargetProblems :: Verbosity -> String -> [TargetProblem'] -> IO a +reportTargetProblems verbosity verb = + die' verbosity . unlines . map (renderTargetProblem verb absurd) + +-- | Default implementation of 'renderTargetProblem'. +renderTargetProblem + :: String -- ^ verb + -> (a -> String) -- ^ how to render custom problems + -> TargetProblem a + -> String +renderTargetProblem _verb f (CustomTargetProblem x) = f x +renderTargetProblem verb _ (TargetProblemNoneEnabled targetSelector targets) = + renderTargetProblemNoneEnabled verb targetSelector targets +renderTargetProblem verb _ (TargetProblemNoTargets targetSelector) = + renderTargetProblemNoTargets verb targetSelector + +renderTargetProblem verb _ (TargetNotInProject pkgname) = + "Cannot " ++ verb ++ " the package " ++ prettyShow pkgname ++ ", it is not " + ++ "in this project (either directly or indirectly). If you want to add it " + ++ "to the project then edit the cabal.project file." + +renderTargetProblem verb _ (TargetAvailableInIndex pkgname) = + "Cannot " ++ verb ++ " the package " ++ prettyShow pkgname ++ ", it is not " + ++ "in this project (either directly or indirectly), but it is in the current " + ++ "package index. If you want to add it to the project then edit the " + ++ "cabal.project file." + +renderTargetProblem verb _ (TargetComponentNotProjectLocal pkgid cname _) = + "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because the " + ++ "package " ++ prettyShow pkgid ++ " is not local to the project, and cabal " + ++ "does not currently support building test suites or benchmarks of " + ++ "non-local dependencies. To run test suites or benchmarks from " + ++ "dependencies you can unpack the package locally and adjust the " + ++ "cabal.project file to include that package directory." + +renderTargetProblem verb _ (TargetComponentNotBuildable pkgid cname _) = + "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because it is " + ++ "marked as 'buildable: False' within the '" ++ prettyShow (packageName pkgid) + ++ ".cabal' file (at least for the current configuration). If you believe it " + ++ "should be buildable then check the .cabal file to see if the buildable " + ++ "property is conditional on flags. Alternatively you may simply have to " + ++ "edit the .cabal file to declare it as buildable and fix any resulting " + ++ "build problems." + +renderTargetProblem verb _ (TargetOptionalStanzaDisabledByUser _ cname _) = + "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because " + ++ "building " ++ compkinds ++ " has been explicitly disabled in the " + ++ "configuration. You can adjust this configuration in the " + ++ "cabal.project{.local} file either for all packages in the project or on " + ++ "a per-package basis. Note that if you do not explicitly disable " + ++ compkinds ++ " then the solver will merely try to make a plan with " + ++ "them available, so you may wish to explicitly enable them which will " + ++ "require the solver to find a plan with them available or to fail with an " + ++ "explanation." + where + compkinds = renderComponentKind Plural (componentKind cname) + +renderTargetProblem verb _ (TargetOptionalStanzaDisabledBySolver pkgid cname _) = + "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because the " + ++ "solver did not find a plan that included the " ++ compkinds + ++ " for " ++ prettyShow pkgid ++ ". It is probably worth trying again with " + ++ compkinds ++ " explicitly enabled in the configuration in the " + ++ "cabal.project{.local} file. This will ask the solver to find a plan with " + ++ "the " ++ compkinds ++ " available. It will either fail with an " + ++ "explanation or find a different plan that uses different versions of some " + ++ "other packages. Use the '--dry-run' flag to see package versions and " + ++ "check that you are happy with the choices." + where + compkinds = renderComponentKind Plural (componentKind cname) + +renderTargetProblem verb _ (TargetProblemUnknownComponent pkgname ecname) = + "Cannot " ++ verb ++ " the " + ++ (case ecname of + Left ucname -> "component " ++ prettyShow ucname + Right cname -> renderComponentName pkgname cname) + ++ " from the package " ++ prettyShow pkgname + ++ ", because the package does not contain a " + ++ (case ecname of + Left _ -> "component" + Right cname -> renderComponentKind Singular (componentKind cname)) + ++ " with that name." + +renderTargetProblem verb _ (TargetProblemNoSuchPackage pkgid) = + "Internal error when trying to " ++ verb ++ " the package " + ++ prettyShow pkgid ++ ". The package is not in the set of available targets " + ++ "for the project plan, which would suggest an inconsistency " + ++ "between readTargetSelectors and resolveTargets." + +renderTargetProblem verb _ (TargetProblemNoSuchComponent pkgid cname) = + "Internal error when trying to " ++ verb ++ " the " + ++ showComponentName cname ++ " from the package " ++ prettyShow pkgid + ++ ". The package,component pair is not in the set of available targets " + ++ "for the project plan, which would suggest an inconsistency " + ++ "between readTargetSelectors and resolveTargets." + + +------------------------------------------------------------ +-- Rendering error messages for TargetProblemNoneEnabled +-- + +-- | Several commands have a @TargetProblemNoneEnabled@ problem constructor. +-- This renders an error message for those cases. +-- +renderTargetProblemNoneEnabled :: String + -> TargetSelector + -> [AvailableTarget ()] + -> String +renderTargetProblemNoneEnabled verb targetSelector targets = + "Cannot " ++ verb ++ " " ++ renderTargetSelector targetSelector + ++ " because none of the components are available to build: " + ++ renderListSemiAnd + [ case (status, mstanza) of + (TargetDisabledByUser, Just stanza) -> + renderListCommaAnd + [ "the " ++ showComponentName availableTargetComponentName + | AvailableTarget {availableTargetComponentName} <- targets' ] + ++ plural (listPlural targets') " is " " are " + ++ " not available because building " + ++ renderOptionalStanza Plural stanza + ++ " has been disabled in the configuration" + (TargetDisabledBySolver, Just stanza) -> + renderListCommaAnd + [ "the " ++ showComponentName availableTargetComponentName + | AvailableTarget {availableTargetComponentName} <- targets' ] + ++ plural (listPlural targets') " is " " are " + ++ "not available because the solver picked a plan that does not " + ++ "include the " ++ renderOptionalStanza Plural stanza + ++ ", perhaps because no such plan exists. To see the error message " + ++ "explaining the problems with such plans, force the solver to " + ++ "include the " ++ renderOptionalStanza Plural stanza ++ " for all " + ++ "packages, by adding the line 'tests: True' to the " + ++ "'cabal.project.local' file." + (TargetNotBuildable, _) -> + renderListCommaAnd + [ "the " ++ showComponentName availableTargetComponentName + | AvailableTarget {availableTargetComponentName} <- targets' ] + ++ plural (listPlural targets') " is " " are all " + ++ "marked as 'buildable: False'" + (TargetNotLocal, _) -> + renderListCommaAnd + [ "the " ++ showComponentName availableTargetComponentName + | AvailableTarget {availableTargetComponentName} <- targets' ] + ++ " cannot be built because cabal does not currently support " + ++ "building test suites or benchmarks of non-local dependencies" + (TargetBuildable () TargetNotRequestedByDefault, Just stanza) -> + renderListCommaAnd + [ "the " ++ showComponentName availableTargetComponentName + | AvailableTarget {availableTargetComponentName} <- targets' ] + ++ " will not be built because " ++ renderOptionalStanza Plural stanza + ++ " are not built by default in the current configuration (but you " + ++ "can still build them specifically)" --TODO: say how + _ -> error $ "renderBuildTargetProblem: unexpected status " + ++ show (status, mstanza) + | ((status, mstanza), targets') <- sortGroupOn groupingKey targets + ] + where + groupingKey t = + ( availableTargetStatus t + , case availableTargetStatus t of + TargetNotBuildable -> Nothing + TargetNotLocal -> Nothing + _ -> optionalStanza (availableTargetComponentName t) + ) + +------------------------------------------------------------ +-- Rendering error messages for TargetProblemNoneEnabled +-- + +-- | Several commands have a @TargetProblemNoTargets@ problem constructor. +-- This renders an error message for those cases. +-- +renderTargetProblemNoTargets :: String -> TargetSelector -> String +renderTargetProblemNoTargets verb targetSelector = + "Cannot " ++ verb ++ " " ++ renderTargetSelector targetSelector + ++ " because " ++ reason targetSelector ++ ". " + ++ "Check the .cabal " + ++ plural (targetSelectorPluralPkgs targetSelector) + "file for the package and make sure that it properly declares " + "files for the packages and make sure that they properly declare " + ++ "the components that you expect." + where + reason (TargetPackage _ _ Nothing) = + "it does not contain any components at all" + reason (TargetPackage _ _ (Just kfilter)) = + "it does not contain any " ++ renderComponentKind Plural kfilter + reason (TargetPackageNamed _ Nothing) = + "it does not contain any components at all" + reason (TargetPackageNamed _ (Just kfilter)) = + "it does not contain any " ++ renderComponentKind Plural kfilter + reason (TargetAllPackages Nothing) = + "none of them contain any components at all" + reason (TargetAllPackages (Just kfilter)) = + "none of the packages contain any " + ++ renderComponentKind Plural kfilter + reason ts@TargetComponent{} = + error $ "renderTargetProblemNoTargets: " ++ show ts + reason ts@TargetComponentUnknown{} = + error $ "renderTargetProblemNoTargets: " ++ show ts + +----------------------------------------------------------- +-- Rendering error messages for CannotPruneDependencies +-- + +renderCannotPruneDependencies :: CannotPruneDependencies -> String +renderCannotPruneDependencies (CannotPruneDependencies brokenPackages) = + "Cannot select only the dependencies (as requested by the " + ++ "'--only-dependencies' flag), " + ++ (case pkgids of + [pkgid] -> "the package " ++ prettyShow pkgid ++ " is " + _ -> "the packages " + ++ renderListCommaAnd (map prettyShow pkgids) ++ " are ") + ++ "required by a dependency of one of the other targets." + where + -- throw away the details and just list the deps that are needed + pkgids :: [PackageId] + pkgids = nub . map packageId . concatMap snd $ brokenPackages + +{- + ++ "Syntax:\n" + ++ " - build [package]\n" + ++ " - build [package:]component\n" + ++ " - build [package:][component:]module\n" + ++ " - build [package:][component:]file\n" + ++ " where\n" + ++ " package is a package name, package dir or .cabal file\n\n" + ++ "Examples:\n" + ++ " - build foo -- package name\n" + ++ " - build tests -- component name\n" + ++ " (name of library, executable, test-suite or benchmark)\n" + ++ " - build Data.Foo -- module name\n" + ++ " - build Data/Foo.hsc -- file name\n\n" + ++ "An ambiguous target can be qualified by package, component\n" + ++ "and/or component kind (lib|exe|test|bench|flib)\n" + ++ " - build foo:tests -- component qualified by package\n" + ++ " - build tests:Data.Foo -- module qualified by component\n" + ++ " - build lib:foo -- component qualified by kind" +-} diff --git a/cabal/cabal-install/src/Distribution/Client/CmdExec.hs b/cabal/cabal-install/src/Distribution/Client/CmdExec.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/CmdExec.hs @@ -0,0 +1,260 @@ +------------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Exec +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Implementation of the 'v2-exec' command for running an arbitrary executable +-- in an environment suited to the part of the store built for a project. +------------------------------------------------------------------------------- + +{-# LANGUAGE RecordWildCards #-} +module Distribution.Client.CmdExec + ( execAction + , execCommand + ) where + +import Distribution.Client.DistDirLayout + ( DistDirLayout(..) + ) +import Distribution.Client.InstallPlan + ( GenericPlanPackage(..) + , toGraph + ) +import Distribution.Client.NixStyleOptions + ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) +import Distribution.Client.Setup + ( ConfigFlags(configVerbosity) + , GlobalFlags + ) +import Distribution.Client.ProjectFlags + ( removeIgnoreProjectOption + ) +import Distribution.Client.ProjectOrchestration + ( ProjectBuildContext(..) + , runProjectPreBuildPhase + , CurrentCommand(..) + , establishProjectBaseContext + , distDirLayout + , commandLineFlagsToProjectConfig + , ProjectBaseContext(..) + , BuildTimeSettings(..) + ) +import Distribution.Client.ProjectPlanOutput + ( updatePostBuildProjectStatus + , createPackageEnvironment + , argsEquivalentOfGhcEnvironmentFile + , PostBuildProjectStatus + ) +import qualified Distribution.Client.ProjectPlanning as Planning +import Distribution.Client.ProjectPlanning + ( ElaboratedInstallPlan + , ElaboratedSharedConfig(..) + ) +import Distribution.Simple.Command + ( CommandUI(..) ) +import Distribution.Simple.Program.Db + ( modifyProgramSearchPath + , requireProgram + , configuredPrograms + ) +import Distribution.Simple.Program.Find + ( ProgramSearchPathEntry(..) + ) +import Distribution.Simple.Program.Run + ( programInvocation + , runProgramInvocation + ) +import Distribution.Simple.Program.Types + ( programOverrideEnv + , programDefaultArgs + , programPath + , simpleProgram + , ConfiguredProgram + ) +import Distribution.Simple.GHC + ( getImplInfo + , GhcImplInfo(supportsPkgEnvFiles) ) +import Distribution.Simple.Flag + ( fromFlagOrDefault + ) +import Distribution.Simple.Utils + ( die' + , info + , createDirectoryIfMissingVerbose + , withTempDirectory + , wrapText + , notice + ) +import Distribution.Verbosity + ( normal + ) + +import Prelude () +import Distribution.Client.Compat.Prelude + +import qualified Data.Set as S +import qualified Data.Map as M + +execCommand :: CommandUI (NixStyleFlags ()) +execCommand = CommandUI + { commandName = "v2-exec" + , commandSynopsis = "Give a command access to the store." + , commandUsage = \pname -> + "Usage: " ++ pname ++ " v2-exec [FLAGS] [--] COMMAND [--] [ARGS]\n" + , commandDescription = Just $ \pname -> wrapText $ + "During development it is often useful to run build tasks and perform" + ++ " one-off program executions to experiment with the behavior of build" + ++ " tools. It is convenient to run these tools in the same way " ++ pname + ++ " itself would. The `" ++ pname ++ " v2-exec` command provides a way to" + ++ " do so.\n" + ++ "\n" + ++ "Compiler tools will be configured to see the same subset of the store" + ++ " that builds would see. The PATH is modified to make all executables in" + ++ " the dependency tree available (provided they have been built already)." + ++ " Commands are also rewritten in the way cabal itself would. For" + ++ " example, `" ++ pname ++ " v2-exec ghc` will consult the configuration" + ++ " to choose an appropriate version of ghc and to include any" + ++ " ghc-specific flags requested." + , commandNotes = Nothing + , commandOptions = removeIgnoreProjectOption + . nixStyleOptions (const []) + , commandDefaultFlags = defaultNixStyleFlags () + } + +execAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO () +execAction flags@NixStyleFlags {..} extraArgs globalFlags = do + + baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand + + -- To set up the environment, we'd like to select the libraries in our + -- dependency tree that we've already built. So first we set up an install + -- plan, but we walk the dependency tree without first executing the plan. + buildCtx <- runProjectPreBuildPhase + verbosity + baseCtx + (\plan -> return (plan, M.empty)) + + -- 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 + -- status. + buildStatus <- updatePostBuildProjectStatus + verbosity + (distDirLayout baseCtx) + (elaboratedPlanOriginal buildCtx) + (pkgsBuildStatus buildCtx) + mempty + + -- Some dependencies may have executables. Let's put those on the PATH. + extraPaths <- pathAdditions verbosity baseCtx buildCtx + let programDb = modifyProgramSearchPath + (map ProgramSearchPathDir extraPaths ++) + . pkgConfigCompilerProgs + . elaboratedShared + $ buildCtx + + -- Now that we have the packages, set up the environment. We accomplish this + -- by creating an environment file that selects the databases and packages we + -- computed in the previous step, and setting an environment variable to + -- 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 + envFilesSupported = supportsPkgEnvFiles (getImplInfo compiler) + case extraArgs of + [] -> die' verbosity "Please specify an executable to run" + exe:args -> do + (program, _) <- requireProgram verbosity (simpleProgram exe) programDb + let argOverrides = + argsEquivalentOfGhcEnvironmentFile + compiler + (distDirLayout baseCtx) + (elaboratedPlanOriginal buildCtx) + buildStatus + programIsConfiguredCompiler = matchCompilerPath + (elaboratedShared buildCtx) + program + argOverrides' = + if envFilesSupported + || not programIsConfiguredCompiler + then [] + else argOverrides + + (if envFilesSupported + then withTempEnvFile verbosity baseCtx buildCtx buildStatus + else \f -> f []) $ \envOverrides -> do + let program' = withOverrides + envOverrides + argOverrides' + program + invocation = programInvocation program' args + dryRun = buildSettingDryRun (buildSettings baseCtx) + || buildSettingOnlyDownload (buildSettings baseCtx) + + if dryRun + then notice verbosity "Running of executable suppressed by flag(s)" + else runProgramInvocation verbosity invocation + where + verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + cliConfig = commandLineFlagsToProjectConfig globalFlags flags + mempty -- ClientInstallFlags, not needed here + withOverrides env args program = program + { programOverrideEnv = programOverrideEnv program ++ env + , programDefaultArgs = programDefaultArgs program ++ args} + +matchCompilerPath :: ElaboratedSharedConfig -> ConfiguredProgram -> Bool +matchCompilerPath elaboratedShared program = + programPath program + `elem` + (programPath <$> configuredCompilers) + where + configuredCompilers = configuredPrograms $ pkgConfigCompilerProgs elaboratedShared + +-- | Execute an action with a temporary .ghc.environment file reflecting the +-- current environment. The action takes an environment containing the env +-- variable which points ghc to the file. +withTempEnvFile :: Verbosity + -> ProjectBaseContext + -> ProjectBuildContext + -> PostBuildProjectStatus + -> ([(String, Maybe String)] -> IO a) + -> IO a +withTempEnvFile verbosity baseCtx buildCtx buildStatus action = do + createDirectoryIfMissingVerbose verbosity True (distTempDirectory (distDirLayout baseCtx)) + withTempDirectory + verbosity + (distTempDirectory (distDirLayout baseCtx)) + "environment." + (\tmpDir -> do + envOverrides <- createPackageEnvironment + verbosity + tmpDir + (elaboratedPlanToExecute buildCtx) + (elaboratedShared buildCtx) + buildStatus + action envOverrides) + +pathAdditions :: Verbosity -> ProjectBaseContext -> ProjectBuildContext -> IO [FilePath] +pathAdditions verbosity ProjectBaseContext{..}ProjectBuildContext{..} = do + info verbosity . unlines $ "Including the following directories in PATH:" + : paths + return paths + where + paths = S.toList + $ binDirectories distDirLayout elaboratedShared elaboratedPlanToExecute + +binDirectories + :: DistDirLayout + -> ElaboratedSharedConfig + -> ElaboratedInstallPlan + -> Set FilePath +binDirectories layout config = fromElaboratedInstallPlan where + fromElaboratedInstallPlan = fromGraph . toGraph + fromGraph = foldMap fromPlan + fromSrcPkg = S.fromList . Planning.binDirectories layout config + + fromPlan (PreExisting _) = mempty + fromPlan (Configured pkg) = fromSrcPkg pkg + fromPlan (Installed pkg) = fromSrcPkg pkg + diff --git a/cabal/cabal-install/src/Distribution/Client/CmdFreeze.hs b/cabal/cabal-install/src/Distribution/Client/CmdFreeze.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/CmdFreeze.hs @@ -0,0 +1,236 @@ +{-# LANGUAGE NamedFieldPuns, RecordWildCards #-} + +-- | cabal-install CLI command: freeze +-- +module Distribution.Client.CmdFreeze ( + freezeCommand, + freezeAction, + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Client.NixStyleOptions + ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) +import Distribution.Client.ProjectOrchestration +import Distribution.Client.ProjectPlanning +import Distribution.Client.ProjectConfig + ( ProjectConfig(..), ProjectConfigShared(..) + , writeProjectLocalFreezeConfig ) +import Distribution.Client.IndexUtils (TotalIndexState, ActiveRepos, filterSkippedActiveRepos) +import Distribution.Client.Targets + ( UserQualifier(..), UserConstraintScope(..), UserConstraint(..) ) +import Distribution.Solver.Types.PackageConstraint + ( PackageProperty(..) ) +import Distribution.Solver.Types.ConstraintSource + ( ConstraintSource(..) ) +import Distribution.Client.DistDirLayout + ( DistDirLayout(distProjectFile) ) +import qualified Distribution.Client.InstallPlan as InstallPlan + + +import Distribution.Package + ( PackageName, packageName, packageVersion ) +import Distribution.Version + ( VersionRange, thisVersion + , unionVersionRanges, simplifyVersionRange ) +import Distribution.PackageDescription + ( FlagAssignment, nullFlagAssignment ) +import Distribution.Client.Setup + ( GlobalFlags, ConfigFlags(..) ) +import Distribution.Simple.Flag + ( fromFlagOrDefault ) +import Distribution.Simple.Flag (Flag (..)) +import Distribution.Simple.Utils + ( die', notice, wrapText ) +import Distribution.Verbosity + ( normal ) + +import qualified Data.Map as Map + +import Distribution.Simple.Command + ( CommandUI(..), usageAlternatives ) + +freezeCommand :: CommandUI (NixStyleFlags ()) +freezeCommand = CommandUI { + commandName = "v2-freeze", + commandSynopsis = "Freeze dependencies.", + commandUsage = usageAlternatives "v2-freeze" [ "[FLAGS]" ], + commandDescription = Just $ \_ -> wrapText $ + "The project configuration is frozen so that it will be reproducible " + ++ "in future.\n\n" + + ++ "The precise dependency configuration for the project is written to " + ++ "the 'cabal.project.freeze' file (or '$project_file.freeze' if " + ++ "'--project-file' is specified). This file extends the configuration " + ++ "from the 'cabal.project' file and thus is used as the project " + ++ "configuration for all other commands (such as 'v2-build', " + ++ "'v2-repl' etc).\n\n" + + ++ "The freeze file can be kept in source control. To make small " + ++ "adjustments it may be edited manually, or to make bigger changes " + ++ "you may wish to delete the file and re-freeze. For more control, " + ++ "one approach is to try variations using 'v2-build --dry-run' with " + ++ "solver flags such as '--constraint=\"pkg < 1.2\"' and once you have " + ++ "a satisfactory solution to freeze it using the 'v2-freeze' command " + ++ "with the same set of flags.", + + commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " v2-freeze\n" + ++ " Freeze the configuration of the current project\n\n" + ++ " " ++ pname ++ " v2-build --dry-run --constraint=\"aeson < 1\"\n" + ++ " Check what a solution with the given constraints would look like\n" + ++ " " ++ pname ++ " v2-freeze --constraint=\"aeson < 1\"\n" + ++ " Freeze a solution using the given constraints\n" + + , commandDefaultFlags = defaultNixStyleFlags () + , commandOptions = nixStyleOptions (const []) + } + +-- | To a first approximation, the @freeze@ command runs the first phase of +-- the @build@ command where we bring the install plan up to date, and then +-- based on the install plan we write out a @cabal.project.freeze@ config file. +-- +-- For more details on how this works, see the module +-- "Distribution.Client.ProjectOrchestration" +-- +freezeAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO () +freezeAction flags@NixStyleFlags {..} extraArgs globalFlags = do + + unless (null extraArgs) $ + die' verbosity $ "'freeze' doesn't take any extra arguments: " + ++ unwords extraArgs + + ProjectBaseContext { + distDirLayout, + cabalDirLayout, + projectConfig, + localPackages, + buildSettings + } <- establishProjectBaseContext verbosity cliConfig OtherCommand + + (_, elaboratedPlan, _, totalIndexState, activeRepos) <- + rebuildInstallPlan verbosity + distDirLayout cabalDirLayout + projectConfig + localPackages + + let freezeConfig = projectFreezeConfig elaboratedPlan totalIndexState activeRepos + dryRun = buildSettingDryRun buildSettings + || buildSettingOnlyDownload buildSettings + + if dryRun + then notice verbosity "Freeze file not written due to flag(s)" + else do + writeProjectLocalFreezeConfig distDirLayout freezeConfig + notice verbosity $ + "Wrote freeze file: " ++ distProjectFile distDirLayout "freeze" + + where + verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + cliConfig = commandLineFlagsToProjectConfig globalFlags flags + mempty -- ClientInstallFlags, not needed here + +-- | Given the install plan, produce a config value with constraints that +-- freezes the versions of packages used in the plan. +-- +projectFreezeConfig + :: ElaboratedInstallPlan + -> TotalIndexState + -> ActiveRepos + -> ProjectConfig +projectFreezeConfig elaboratedPlan totalIndexState activeRepos0 = mempty + { projectConfigShared = mempty + { projectConfigConstraints = + concat (Map.elems (projectFreezeConstraints elaboratedPlan)) + , projectConfigIndexState = Flag totalIndexState + , projectConfigActiveRepos = Flag activeRepos + } + } + where + activeRepos :: ActiveRepos + activeRepos = filterSkippedActiveRepos activeRepos0 + +-- | Given the install plan, produce solver constraints that will ensure the +-- solver picks the same solution again in future in different environments. +-- +projectFreezeConstraints :: ElaboratedInstallPlan + -> Map PackageName [(UserConstraint, ConstraintSource)] +projectFreezeConstraints plan = + -- + -- TODO: [required eventually] this is currently an underapproximation + -- since the constraints language is not expressive enough to specify the + -- precise solution. See https://github.com/haskell/cabal/issues/3502. + -- + -- For the moment we deal with multiple versions in the solution by using + -- constraints that allow either version. Also, we do not include any + -- /version/ constraints for packages that are local to the project (e.g. + -- if the solution has two instances of Cabal, one from the local project + -- and one pulled in as a setup deps then we exclude all constraints on + -- Cabal, not just the constraint for the local instance since any + -- constraint would apply to both instances). We do however keep flag + -- constraints of local packages. + -- + deleteLocalPackagesVersionConstraints + (Map.unionWith (++) versionConstraints flagConstraints) + where + versionConstraints :: Map PackageName [(UserConstraint, ConstraintSource)] + versionConstraints = + Map.mapWithKey + (\p v -> [(UserConstraint (UserAnyQualifier p) (PackagePropertyVersion v), + ConstraintSourceFreeze)]) + versionRanges + + versionRanges :: Map PackageName VersionRange + versionRanges = + Map.map simplifyVersionRange $ + Map.fromListWith unionVersionRanges $ + [ (packageName pkg, thisVersion (packageVersion pkg)) + | InstallPlan.PreExisting pkg <- InstallPlan.toList plan + ] + ++ [ (packageName pkg, thisVersion (packageVersion pkg)) + | InstallPlan.Configured pkg <- InstallPlan.toList plan + ] + + flagConstraints :: Map PackageName [(UserConstraint, ConstraintSource)] + flagConstraints = + Map.mapWithKey + (\p f -> [(UserConstraint (UserQualified UserQualToplevel p) (PackagePropertyFlags f), + ConstraintSourceFreeze)]) + flagAssignments + + flagAssignments :: Map PackageName FlagAssignment + flagAssignments = + Map.fromList + [ (pkgname, flags) + | InstallPlan.Configured elab <- InstallPlan.toList plan + , let flags = elabFlagAssignment elab + pkgname = packageName elab + , not (nullFlagAssignment flags) ] + + -- As described above, remove the version constraints on local packages, + -- but leave any flag constraints. + deleteLocalPackagesVersionConstraints + :: Map PackageName [(UserConstraint, ConstraintSource)] + -> Map PackageName [(UserConstraint, ConstraintSource)] + deleteLocalPackagesVersionConstraints = + Map.mergeWithKey + (\_pkgname () constraints -> + case filter (not . isVersionConstraint . fst) constraints of + [] -> Nothing + constraints' -> Just constraints') + (const Map.empty) id + localPackages + + isVersionConstraint (UserConstraint _ (PackagePropertyVersion _)) = True + isVersionConstraint _ = False + + localPackages :: Map PackageName () + localPackages = + Map.fromList + [ (packageName elab, ()) + | InstallPlan.Configured elab <- InstallPlan.toList plan + , elabLocalToProject elab + ] + diff --git a/cabal/cabal-install/src/Distribution/Client/CmdHaddock.hs b/cabal/cabal-install/src/Distribution/Client/CmdHaddock.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/CmdHaddock.hs @@ -0,0 +1,202 @@ +{-# LANGUAGE RecordWildCards #-} + +-- | cabal-install CLI command: haddock +-- +module Distribution.Client.CmdHaddock ( + -- * The @haddock@ CLI and action + haddockCommand, + haddockAction, + + ClientHaddockFlags(..), + + -- * Internals exposed for testing + selectPackageTargets, + selectComponentTarget + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Client.ProjectOrchestration +import Distribution.Client.CmdErrorMessages +import Distribution.Client.TargetProblem + ( TargetProblem (..), TargetProblem' ) +import Distribution.Client.NixStyleOptions + ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) +import Distribution.Client.Setup + ( GlobalFlags, ConfigFlags(..) ) +import Distribution.Simple.Setup + ( HaddockFlags(..), fromFlagOrDefault, trueArg ) +import Distribution.Simple.Command + ( CommandUI(..), usageAlternatives, ShowOrParseArgs, OptionField, option ) +import Distribution.Verbosity + ( normal ) +import Distribution.Simple.Utils + ( wrapText, die', notice ) +import Distribution.Simple.Flag (Flag(..)) + +import qualified System.Exit (exitSuccess) + +newtype ClientHaddockFlags = ClientHaddockFlags { openInBrowser :: Flag Bool } + +haddockCommand :: CommandUI (NixStyleFlags ClientHaddockFlags) +haddockCommand = CommandUI { + commandName = "v2-haddock", + commandSynopsis = "Build Haddock documentation.", + commandUsage = usageAlternatives "v2-haddock" [ "[FLAGS] TARGET" ], + commandDescription = Just $ \_ -> wrapText $ + "Build Haddock documentation for the specified packages within the " + ++ "project.\n\n" + + ++ "Any package in the project can be specified. If no package is " + ++ "specified, the default is to build the documentation for the package " + ++ "in the current directory. The default behaviour is to build " + ++ "documentation for the exposed modules of the library component (if " + ++ "any). This can be changed with the '--internal', '--executables', " + ++ "'--tests', '--benchmarks' or '--all' flags.\n\n" + + ++ "Currently, documentation for dependencies is NOT built. This " + ++ "behavior may change in future.\n\n" + + ++ "Additional configuration flags can be specified on the command line " + ++ "and these extend the project configuration from the 'cabal.project', " + ++ "'cabal.project.local' and other files.", + commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " v2-haddock pkgname" + ++ " Build documentation for the package named pkgname\n" + , commandOptions = nixStyleOptions haddockOptions + , commandDefaultFlags = defaultNixStyleFlags (ClientHaddockFlags (Flag False)) + } + --TODO: [nice to have] support haddock on specific components, not just + -- whole packages and the silly --executables etc modifiers. + +haddockOptions :: ShowOrParseArgs -> [OptionField ClientHaddockFlags] +haddockOptions _ = + [ option [] ["open"] "Open generated documentation in the browser" + openInBrowser (\v f -> f { openInBrowser = v}) trueArg + ] + +-- | The @haddock@ command is TODO. +-- +-- For more details on how this works, see the module +-- "Distribution.Client.ProjectOrchestration" +-- +haddockAction :: NixStyleFlags ClientHaddockFlags -> [String] -> GlobalFlags -> IO () +haddockAction flags@NixStyleFlags {..} targetStrings globalFlags = do + projCtx <- establishProjectBaseContext verbosity cliConfig HaddockCommand + + let baseCtx + | fromFlagOrDefault False (openInBrowser extraFlags) + = projCtx { buildSettings = (buildSettings projCtx) { buildSettingHaddockOpen = True } } + | otherwise + = projCtx + + targetSelectors <- either (reportTargetSelectorProblems verbosity) return + =<< readTargetSelectors (localPackages baseCtx) Nothing targetStrings + + buildCtx <- + runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do + + when (buildSettingOnlyDeps (buildSettings baseCtx)) $ + die' verbosity + "The haddock command does not support '--only-dependencies'." + + -- When we interpret the targets on the command line, interpret them as + -- haddock targets + targets <- either (reportBuildDocumentationTargetProblems verbosity) return + $ resolveTargets + (selectPackageTargets haddockFlags) + selectComponentTarget + elaboratedPlan + Nothing + targetSelectors + + let elaboratedPlan' = pruneInstallPlanToTargets + TargetActionHaddock + targets + elaboratedPlan + return (elaboratedPlan', targets) + + printPlan verbosity baseCtx buildCtx + + buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx + runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes + where + verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags, not needed here + +-- | This defines what a 'TargetSelector' means for the @haddock@ command. +-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, +-- or otherwise classifies the problem. +-- +-- For the @haddock@ command we select all buildable libraries. Additionally, +-- depending on the @--executables@ flag we also select all the buildable exes. +-- We do similarly for test-suites, benchmarks and foreign libs. +-- +selectPackageTargets :: HaddockFlags -> TargetSelector + -> [AvailableTarget k] -> Either TargetProblem' [k] +selectPackageTargets haddockFlags targetSelector targets + + -- If there are any buildable targets then we select those + | not (null targetsBuildable) + = Right targetsBuildable + + -- If there are targets but none are buildable then we report those + | not (null targets) + = Left (TargetProblemNoneEnabled targetSelector targets') + + -- If there are no targets at all then we report that + | otherwise + = Left (TargetProblemNoTargets targetSelector) + where + targets' = forgetTargetsDetail (map disableNotRequested targets) + targetsBuildable = selectBuildableTargets (map disableNotRequested targets) + + -- When there's a target filter like "pkg:exes" then we do select exes, + -- but if it's just a target like "pkg" then we don't build docs for exes + -- unless they are requested by default (i.e. by using --executables) + disableNotRequested t@(AvailableTarget _ cname (TargetBuildable _ _) _) + | not (isRequested targetSelector (componentKind cname)) + = t { availableTargetStatus = TargetDisabledByUser } + disableNotRequested t = t + + isRequested (TargetPackage _ _ (Just _)) _ = True + isRequested (TargetAllPackages (Just _)) _ = True + isRequested _ LibKind = True +-- isRequested _ SubLibKind = True --TODO: what about sublibs? + + -- TODO/HACK, we encode some defaults here as v2-haddock's logic; + -- make sure this matches the defaults applied in + -- "Distribution.Client.ProjectPlanning"; this may need more work + -- to be done properly + -- + -- See also https://github.com/haskell/cabal/pull/4886 + isRequested _ FLibKind = fromFlagOrDefault False (haddockForeignLibs haddockFlags) + isRequested _ ExeKind = fromFlagOrDefault False (haddockExecutables haddockFlags) + isRequested _ TestKind = fromFlagOrDefault False (haddockTestSuites haddockFlags) + isRequested _ BenchKind = fromFlagOrDefault False (haddockBenchmarks haddockFlags) + + +-- | For a 'TargetComponent' 'TargetSelector', check if the component can be +-- selected. +-- +-- For the @haddock@ command we just need the basic checks on being buildable +-- etc. +-- +selectComponentTarget :: SubComponentTarget + -> AvailableTarget k -> Either TargetProblem' k +selectComponentTarget = selectComponentTargetBasic + +reportBuildDocumentationTargetProblems :: Verbosity -> [TargetProblem'] -> IO a +reportBuildDocumentationTargetProblems verbosity problems = + case problems of + [TargetProblemNoneEnabled _ _] -> do + notice verbosity $ unwords + [ "No documentation was generated as this package does not contain a library." + , "Perhaps you want to use the --haddock-all flag, or one or more of the" + , "--haddock-executables, --haddock-tests, --haddock-benchmarks or" + , "--haddock-internal flags." + ] + System.Exit.exitSuccess + _ -> reportTargetProblems verbosity "build documentation for" problems diff --git a/cabal/cabal-install/src/Distribution/Client/CmdInstall.hs b/cabal/cabal-install/src/Distribution/Client/CmdInstall.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/CmdInstall.hs @@ -0,0 +1,974 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | cabal-install CLI command: build +-- +module Distribution.Client.CmdInstall ( + -- * The @build@ CLI and action + installCommand, + installAction, + + -- * Internals exposed for testing + selectPackageTargets, + selectComponentTarget, + -- * Internals exposed for CmdRepl + CmdRun + establishDummyDistDirLayout, + establishDummyProjectBaseContext + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude +import Distribution.Compat.Directory + ( doesPathExist ) + +import Distribution.Client.ProjectOrchestration +import Distribution.Client.CmdErrorMessages +import Distribution.Client.CmdSdist +import Distribution.Client.TargetProblem + ( TargetProblem', TargetProblem (..) ) + +import Distribution.Client.CmdInstall.ClientInstallFlags +import Distribution.Client.CmdInstall.ClientInstallTargetSelector + +import Distribution.Client.Setup + ( GlobalFlags(..), ConfigFlags(..) ) +import Distribution.Client.Types + ( PackageSpecifier(..), PackageLocation(..), UnresolvedSourcePackage + , SourcePackageDb(..) ) +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Package + ( Package(..), PackageName, mkPackageName, unPackageName ) +import Distribution.Types.PackageId + ( PackageIdentifier(..) ) +import Distribution.Client.ProjectConfig + ( ProjectPackageLocation(..) + , fetchAndReadSourcePackages + , projectConfigWithBuilderRepoContext + , resolveBuildTimeSettings, withProjectOrGlobalConfig ) +import Distribution.Client.NixStyleOptions + ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) +import Distribution.Client.ProjectFlags (ProjectFlags (..)) +import Distribution.Client.ProjectConfig.Types + ( ProjectConfig(..), ProjectConfigShared(..) + , ProjectConfigBuildOnly(..), PackageConfig(..) + , getMapLast, getMapMappend, projectConfigLogsDir + , projectConfigStoreDir, projectConfigBuildOnly + , projectConfigConfigFile ) +import Distribution.Simple.Program.Db + ( userSpecifyPaths, userSpecifyArgss, defaultProgramDb + , modifyProgramSearchPath, ProgramDb ) +import Distribution.Simple.BuildPaths + ( exeExtension ) +import Distribution.Simple.Program.Find + ( ProgramSearchPathEntry(..) ) +import Distribution.Client.Config + ( defaultInstallPath, getCabalDir, loadConfig, SavedConfig(..) ) +import qualified Distribution.Simple.PackageIndex as PI +import Distribution.Solver.Types.PackageIndex + ( lookupPackageName, searchByName ) +import Distribution.Types.InstalledPackageInfo + ( InstalledPackageInfo(..) ) +import Distribution.Types.Version + ( Version, nullVersion ) +import Distribution.Types.VersionRange + ( thisVersion ) +import Distribution.Solver.Types.PackageConstraint + ( PackageProperty(..) ) +import Distribution.Client.IndexUtils + ( getSourcePackages, getInstalledPackages ) +import Distribution.Client.ProjectPlanning + ( storePackageInstallDirs' ) +import Distribution.Client.ProjectPlanning.Types + ( ElaboratedInstallPlan ) +import qualified Distribution.Simple.InstallDirs as InstallDirs +import Distribution.Client.DistDirLayout + ( DistDirLayout(..), mkCabalDirLayout + , cabalStoreDirLayout + , CabalDirLayout(..), StoreDirLayout(..) ) +import Distribution.Client.RebuildMonad + ( runRebuild ) +import Distribution.Client.InstallSymlink + ( symlinkBinary, trySymlink, promptRun ) +import Distribution.Client.Types.OverwritePolicy + ( OverwritePolicy (..) ) +import Distribution.Simple.Flag + ( fromFlagOrDefault, flagToMaybe, flagElim ) +import Distribution.Simple.Setup + ( Flag(..) ) +import Distribution.Solver.Types.SourcePackage + ( SourcePackage(..) ) +import Distribution.Simple.Command + ( CommandUI(..), usageAlternatives ) +import Distribution.Simple.Configure + ( configCompilerEx ) +import Distribution.Simple.Compiler + ( Compiler(..), CompilerId(..), CompilerFlavor(..) + , PackageDBStack ) +import Distribution.Simple.GHC + ( ghcPlatformAndVersionString, getGhcAppDir + , GhcImplInfo(..), getImplInfo + , GhcEnvironmentFileEntry(..) + , renderGhcEnvironmentFile, readGhcEnvironmentFile, ParseErrorExc ) +import Distribution.System + ( Platform , buildOS, OS (Windows) ) +import Distribution.Types.UnitId + ( UnitId ) +import Distribution.Types.UnqualComponentName + ( UnqualComponentName, unUnqualComponentName ) +import Distribution.Verbosity + ( normal, lessVerbose ) +import Distribution.Simple.Utils + ( wrapText, die', notice, warn + , withTempDirectory, createDirectoryIfMissingVerbose + , ordNub ) +import Distribution.Utils.Generic + ( safeHead, writeFileAtomic ) + +import qualified Data.ByteString.Lazy.Char8 as BS +import Data.Ord + ( Down(..) ) +import qualified Data.Map as Map +import qualified Data.List.NonEmpty as NE +import Distribution.Utils.NubList + ( fromNubList ) +import Network.URI (URI) +import System.Directory + ( doesFileExist, createDirectoryIfMissing + , getTemporaryDirectory, makeAbsolute, doesDirectoryExist + , removeFile, removeDirectory, copyFile ) +import System.FilePath + ( (), (<.>), takeDirectory, takeBaseName ) + +installCommand :: CommandUI (NixStyleFlags ClientInstallFlags) +installCommand = CommandUI + { commandName = "v2-install" + , commandSynopsis = "Install packages." + , commandUsage = usageAlternatives + "v2-install" [ "[TARGETS] [FLAGS]" ] + , commandDescription = Just $ \_ -> wrapText $ + "Installs one or more packages. This is done by installing them " + ++ "in the store and symlinking/copying the executables in the directory " + ++ "specified by the --installdir flag (`~/.cabal/bin/` by default). " + ++ "If you want the installed executables to be available globally, " + ++ "make sure that the PATH environment variable contains that directory. " + ++ "\n\n" + ++ "If TARGET is a library and --lib (provisional) is used, " + ++ "it will be added to the global environment. " + ++ "When doing this, cabal will try to build a plan that includes all " + ++ "the previously installed libraries. This is currently not implemented." + , commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " v2-install\n" + ++ " Install the package in the current directory\n" + ++ " " ++ pname ++ " v2-install pkgname\n" + ++ " Install the package named pkgname" + ++ " (fetching it from hackage if necessary)\n" + ++ " " ++ pname ++ " v2-install ./pkgfoo\n" + ++ " Install the package in the ./pkgfoo directory\n" + + , commandOptions = nixStyleOptions clientInstallOptions + , commandDefaultFlags = defaultNixStyleFlags defaultClientInstallFlags + } + +-- | The @install@ command actually serves four different needs. It installs: +-- * exes: +-- For example a program from hackage. The behavior is similar to the old +-- install command, except that now conflicts between separate runs of the +-- command are impossible thanks to the store. +-- Exes are installed in the store like a normal dependency, then they are +-- symlinked/copied in the directory specified by --installdir. +-- To do this we need a dummy projectBaseContext containing the targets as +-- extra packages and using a temporary dist directory. +-- * libraries +-- Libraries install through a similar process, but using GHC environment +-- files instead of symlinks. This means that 'v2-install'ing libraries +-- only works on GHC >= 8.0. +-- +-- For more details on how this works, see the module +-- "Distribution.Client.ProjectOrchestration" +-- +installAction :: NixStyleFlags ClientInstallFlags -> [String] -> GlobalFlags -> IO () +installAction flags@NixStyleFlags { extraFlags = clientInstallFlags', .. } targetStrings globalFlags = do + -- Ensure there were no invalid configuration options specified. + verifyPreconditionsOrDie verbosity configFlags' + + -- We cannot use establishDummyProjectBaseContext to get these flags, since + -- it requires one of them as an argument. Normal establishProjectBaseContext + -- does not, and this is why this is done only for the install command + clientInstallFlags <- getClientInstallFlags verbosity globalFlags clientInstallFlags' + + let + installLibs = fromFlagOrDefault False (cinstInstallLibs clientInstallFlags) + targetFilter = if installLibs then Just LibKind else Just ExeKind + targetStrings' = if null targetStrings then ["."] else targetStrings + + withProject :: IO ([PackageSpecifier UnresolvedSourcePackage], [URI], [TargetSelector], ProjectConfig) + withProject = do + let reducedVerbosity = lessVerbose verbosity + + -- First, we need to learn about what's available to be installed. + localBaseCtx <- + establishProjectBaseContext reducedVerbosity cliConfig InstallCommand + let localDistDirLayout = distDirLayout localBaseCtx + pkgDb <- projectConfigWithBuilderRepoContext reducedVerbosity + (buildSettings localBaseCtx) (getSourcePackages verbosity) + + let + (targetStrings'', packageIds) = + partitionEithers . + flip fmap targetStrings' $ + \str -> case simpleParsec str of + Just (pkgId :: PackageId) + | pkgVersion pkgId /= nullVersion -> Right pkgId + _ -> Left str + packageSpecifiers = + flip fmap packageIds $ \case + PackageIdentifier{..} + | pkgVersion == nullVersion -> NamedPackage pkgName [] + | otherwise -> NamedPackage pkgName + [PackagePropertyVersion + (thisVersion pkgVersion)] + packageTargets = + flip TargetPackageNamed targetFilter . pkgName <$> packageIds + + if null targetStrings' + then return (packageSpecifiers, [], packageTargets, projectConfig localBaseCtx) + else do + targetSelectors <- + either (reportTargetSelectorProblems verbosity) return + =<< readTargetSelectors (localPackages localBaseCtx) + Nothing targetStrings'' + + (specs, selectors) <- + getSpecsAndTargetSelectors + verbosity reducedVerbosity pkgDb targetSelectors localDistDirLayout localBaseCtx targetFilter + + return ( specs ++ packageSpecifiers + , [] + , selectors ++ packageTargets + , projectConfig localBaseCtx ) + + withoutProject :: ProjectConfig -> IO ([PackageSpecifier pkg], [URI], [TargetSelector], ProjectConfig) + withoutProject globalConfig = do + tss <- traverse (parseWithoutProjectTargetSelector verbosity) targetStrings' + + cabalDir <- getCabalDir + let + projectConfig = globalConfig <> cliConfig + + ProjectConfigBuildOnly { + projectConfigLogsDir + } = projectConfigBuildOnly projectConfig + + ProjectConfigShared { + projectConfigStoreDir + } = projectConfigShared projectConfig + + mlogsDir = flagToMaybe projectConfigLogsDir + mstoreDir = flagToMaybe projectConfigStoreDir + cabalDirLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir + + buildSettings = resolveBuildTimeSettings + verbosity cabalDirLayout + projectConfig + + SourcePackageDb { packageIndex } <- projectConfigWithBuilderRepoContext + verbosity buildSettings + (getSourcePackages verbosity) + + for_ (concatMap woPackageNames tss) $ \name -> do + when (null (lookupPackageName packageIndex name)) $ do + let xs = searchByName packageIndex (unPackageName name) + let emptyIf True _ = [] + emptyIf False zs = zs + die' verbosity $ concat $ + [ "Unknown package \"", unPackageName name, "\". " + ] ++ emptyIf (null xs) + [ "Did you mean any of the following?\n" + , unlines (("- " ++) . unPackageName . fst <$> xs) + ] + + let + (uris, packageSpecifiers) = partitionEithers $ map woPackageSpecifiers tss + packageTargets = map woPackageTargets tss + + return (packageSpecifiers, uris, packageTargets, projectConfig) + + (specs, uris, targetSelectors, config) <- + withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag withProject withoutProject + + let + ProjectConfig { + projectConfigBuildOnly = ProjectConfigBuildOnly { + projectConfigLogsDir + }, + projectConfigShared = ProjectConfigShared { + projectConfigHcFlavor, + projectConfigHcPath, + projectConfigHcPkg, + projectConfigStoreDir + }, + projectConfigLocalPackages = PackageConfig { + packageConfigProgramPaths, + packageConfigProgramArgs, + packageConfigProgramPathExtra + } + } = config + + hcFlavor = flagToMaybe projectConfigHcFlavor + hcPath = flagToMaybe projectConfigHcPath + hcPkg = flagToMaybe projectConfigHcPkg + + -- ProgramDb with directly user specified paths + preProgDb = + userSpecifyPaths (Map.toList (getMapLast packageConfigProgramPaths)) + . userSpecifyArgss (Map.toList (getMapMappend packageConfigProgramArgs)) + . modifyProgramSearchPath + (++ [ ProgramSearchPathDir dir + | dir <- fromNubList packageConfigProgramPathExtra ]) + $ defaultProgramDb + + -- progDb is a program database with compiler tools configured properly + (compiler@Compiler { compilerId = + compilerId@(CompilerId compilerFlavor compilerVersion) }, platform, progDb) <- + configCompilerEx hcFlavor hcPath hcPkg preProgDb verbosity + + let + GhcImplInfo{ supportsPkgEnvFiles } = getImplInfo compiler + + envFile <- getEnvFile clientInstallFlags platform compilerVersion + existingEnvEntries <- + getExistingEnvEntries verbosity compilerFlavor supportsPkgEnvFiles envFile + packageDbs <- getPackageDbStack compilerId projectConfigStoreDir projectConfigLogsDir + installedIndex <- getInstalledPackages verbosity compiler packageDbs progDb + + let + (envSpecs, nonGlobalEnvEntries) = + getEnvSpecsAndNonGlobalEntries installedIndex existingEnvEntries installLibs + + -- Second, we need to use a fake project to let Cabal build the + -- installables correctly. For that, we need a place to put a + -- temporary dist directory. + globalTmp <- getTemporaryDirectory + + withTempDirectory verbosity globalTmp "cabal-install." $ \tmpDir -> do + distDirLayout <- establishDummyDistDirLayout verbosity config tmpDir + + uriSpecs <- runRebuild tmpDir $ fetchAndReadSourcePackages + verbosity + distDirLayout + (projectConfigShared config) + (projectConfigBuildOnly config) + [ ProjectPackageRemoteTarball uri | uri <- uris ] + + baseCtx <- establishDummyProjectBaseContext + verbosity + config + distDirLayout + (envSpecs ++ specs ++ uriSpecs) + InstallCommand + + buildCtx <- constructProjectBuildContext verbosity baseCtx targetSelectors + + printPlan verbosity baseCtx buildCtx + + buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx + runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes + + -- Now that we built everything we can do the installation part. + -- First, figure out if / what parts we want to install: + let + dryRun = buildSettingDryRun (buildSettings baseCtx) + || buildSettingOnlyDownload (buildSettings baseCtx) + + -- Then, install! + unless dryRun $ + if installLibs + then installLibraries verbosity + buildCtx compiler packageDbs progDb envFile nonGlobalEnvEntries + else installExes verbosity + baseCtx buildCtx platform compiler configFlags clientInstallFlags + where + configFlags' = disableTestsBenchsByDefault configFlags + verbosity = fromFlagOrDefault normal (configVerbosity configFlags') + ignoreProject = flagIgnoreProject projectFlags + cliConfig = commandLineFlagsToProjectConfig + globalFlags + flags { configFlags = configFlags' } + clientInstallFlags' + globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) + +-- | Verify that invalid config options were not passed to the install command. +-- +-- If an invalid configuration is found the command will @die'@. +verifyPreconditionsOrDie :: Verbosity -> ConfigFlags -> IO () +verifyPreconditionsOrDie verbosity configFlags = do + -- We never try to build tests/benchmarks for remote packages. + -- So we set them as disabled by default and error if they are explicitly + -- enabled. + when (configTests configFlags == Flag True) $ + die' verbosity $ "--enable-tests was specified, but tests can't " + ++ "be enabled in a remote package" + when (configBenchmarks configFlags == Flag True) $ + die' verbosity $ "--enable-benchmarks was specified, but benchmarks can't " + ++ "be enabled in a remote package" + +getClientInstallFlags :: Verbosity -> GlobalFlags -> ClientInstallFlags -> IO ClientInstallFlags +getClientInstallFlags verbosity globalFlags existingClientInstallFlags = do + let configFileFlag = globalConfigFile globalFlags + savedConfig <- loadConfig verbosity configFileFlag + pure $ savedClientInstallFlags savedConfig `mappend` existingClientInstallFlags + + +getSpecsAndTargetSelectors + :: Verbosity + -> Verbosity + -> SourcePackageDb + -> [TargetSelector] + -> DistDirLayout + -> ProjectBaseContext + -> Maybe ComponentKindFilter + -> IO ([PackageSpecifier UnresolvedSourcePackage], [TargetSelector]) +getSpecsAndTargetSelectors verbosity reducedVerbosity pkgDb targetSelectors localDistDirLayout localBaseCtx targetFilter = + withInstallPlan reducedVerbosity localBaseCtx $ \elaboratedPlan _ -> do + -- Split into known targets and hackage packages. + (targets, hackageNames) <- + partitionToKnownTargetsAndHackagePackages + verbosity pkgDb elaboratedPlan targetSelectors + + let + planMap = InstallPlan.toMap elaboratedPlan + targetIds = Map.keys targets + + sdistize (SpecificSourcePackage spkg) = + SpecificSourcePackage spkg' + where + sdistPath = distSdistFile localDistDirLayout (packageId spkg) + spkg' = spkg { srcpkgSource = LocalTarballPackage sdistPath } + sdistize named = named + + local = sdistize <$> localPackages localBaseCtx + + gatherTargets :: UnitId -> TargetSelector + gatherTargets targetId = TargetPackageNamed pkgName targetFilter + where + targetUnit = Map.findWithDefault (error "cannot find target unit") targetId planMap + PackageIdentifier{..} = packageId targetUnit + + targets' = fmap gatherTargets targetIds + + hackagePkgs :: [PackageSpecifier UnresolvedSourcePackage] + hackagePkgs = flip NamedPackage [] <$> hackageNames + + hackageTargets :: [TargetSelector] + hackageTargets = + flip TargetPackageNamed targetFilter <$> hackageNames + + createDirectoryIfMissing True (distSdistDirectory localDistDirLayout) + + unless (Map.null targets) $ for_ (localPackages localBaseCtx) $ \lpkg -> case lpkg of + SpecificSourcePackage pkg -> packageToSdist verbosity + (distProjectRootDirectory localDistDirLayout) TarGzArchive + (distSdistFile localDistDirLayout (packageId pkg)) pkg + NamedPackage pkgName _ -> error $ "Got NamedPackage " ++ prettyShow pkgName + + if null targets + then return (hackagePkgs, hackageTargets) + else return (local ++ hackagePkgs, targets' ++ hackageTargets) + +-- | Partitions the target selectors into known local targets and hackage packages. +partitionToKnownTargetsAndHackagePackages + :: Verbosity + -> SourcePackageDb + -> ElaboratedInstallPlan + -> [TargetSelector] + -> IO (TargetsMap, [PackageName]) +partitionToKnownTargetsAndHackagePackages verbosity pkgDb elaboratedPlan targetSelectors = do + let mTargets = resolveTargets + selectPackageTargets + selectComponentTarget + elaboratedPlan + (Just pkgDb) + targetSelectors + case mTargets of + Right targets -> + -- Everything is a local dependency. + return (targets, []) + Left errs -> do + -- Not everything is local. + let + (errs', hackageNames) = partitionEithers . flip fmap errs $ \case + TargetAvailableInIndex name -> Right name + err -> Left err + + -- report incorrect case for known package. + for_ errs' $ \case + TargetNotInProject hn -> + case searchByName (packageIndex pkgDb) (unPackageName hn) of + [] -> return () + xs -> die' verbosity . concat $ + [ "Unknown package \"", unPackageName hn, "\". " + , "Did you mean any of the following?\n" + , unlines (("- " ++) . unPackageName . fst <$> xs) + ] + _ -> return () + + when (not . null $ errs') $ reportBuildTargetProblems verbosity errs' + + let + targetSelectors' = flip filter targetSelectors $ \case + TargetComponentUnknown name _ _ + | name `elem` hackageNames -> False + TargetPackageNamed name _ + | name `elem` hackageNames -> False + _ -> True + + -- This can't fail, because all of the errors are + -- removed (or we've given up). + targets <- + either (reportBuildTargetProblems verbosity) return $ + resolveTargets + selectPackageTargets + selectComponentTarget + elaboratedPlan + Nothing + targetSelectors' + + return (targets, hackageNames) + + + +constructProjectBuildContext + :: Verbosity + -> ProjectBaseContext + -- ^ The synthetic base context to use to produce the full build context. + -> [TargetSelector] + -> IO ProjectBuildContext +constructProjectBuildContext verbosity baseCtx targetSelectors = do + runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do + -- Interpret the targets on the command line as build targets + targets <- either (reportBuildTargetProblems verbosity) return $ + resolveTargets + selectPackageTargets + selectComponentTarget + elaboratedPlan + Nothing + targetSelectors + + let prunedToTargetsElaboratedPlan = + pruneInstallPlanToTargets TargetActionBuild targets elaboratedPlan + prunedElaboratedPlan <- + if buildSettingOnlyDeps (buildSettings baseCtx) + then either (reportCannotPruneDependencies verbosity) return $ + pruneInstallPlanToDependencies (Map.keysSet targets) + prunedToTargetsElaboratedPlan + else return prunedToTargetsElaboratedPlan + + return (prunedElaboratedPlan, targets) + + +-- | Install any built exe by symlinking/copying it +-- we don't use BuildOutcomes because we also need the component names +installExes + :: Verbosity + -> ProjectBaseContext + -> ProjectBuildContext + -> Platform + -> Compiler + -> ConfigFlags + -> ClientInstallFlags + -> IO () +installExes verbosity baseCtx buildCtx platform compiler + configFlags clientInstallFlags = do + installPath <- defaultInstallPath + let storeDirLayout = cabalStoreDirLayout $ cabalDirLayout baseCtx + + prefix = fromFlagOrDefault "" (fmap InstallDirs.fromPathTemplate (configProgPrefix configFlags)) + suffix = fromFlagOrDefault "" (fmap InstallDirs.fromPathTemplate (configProgSuffix configFlags)) + + mkUnitBinDir :: UnitId -> FilePath + mkUnitBinDir = + InstallDirs.bindir . + storePackageInstallDirs' storeDirLayout (compilerId compiler) + + mkExeName :: UnqualComponentName -> FilePath + mkExeName exe = unUnqualComponentName exe <.> exeExtension platform + + mkFinalExeName :: UnqualComponentName -> FilePath + mkFinalExeName exe = prefix <> unUnqualComponentName exe <> suffix <.> exeExtension platform + installdirUnknown = + "installdir is not defined. Set it in your cabal config file " + ++ "or use --installdir=. Using default installdir: " ++ show installPath + + installdir <- fromFlagOrDefault + (warn verbosity installdirUnknown >> pure installPath) $ + pure <$> cinstInstalldir clientInstallFlags + createDirectoryIfMissingVerbose verbosity False installdir + warnIfNoExes verbosity buildCtx + + installMethod <- flagElim defaultMethod return $ + cinstInstallMethod clientInstallFlags + + let + doInstall = installUnitExes + verbosity + overwritePolicy + mkUnitBinDir mkExeName mkFinalExeName + installdir installMethod + in traverse_ doInstall $ Map.toList $ targetsMap buildCtx + where + overwritePolicy = fromFlagOrDefault NeverOverwrite $ + cinstOverwritePolicy clientInstallFlags + isWindows = buildOS == Windows + + -- This is in IO as we will make environment checks, + -- to decide which method is best + defaultMethod :: IO InstallMethod + defaultMethod + -- Try symlinking in temporary directory, if it works default to + -- symlinking even on windows + | isWindows = do + symlinks <- trySymlink verbosity + return $ if symlinks then InstallMethodSymlink else InstallMethodCopy + | otherwise = return InstallMethodSymlink + +-- | Install any built library by adding it to the default ghc environment +installLibraries + :: Verbosity + -> ProjectBuildContext + -> Compiler + -> PackageDBStack + -> ProgramDb + -> FilePath -- ^ Environment file + -> [GhcEnvironmentFileEntry] + -> IO () +installLibraries verbosity buildCtx compiler + packageDbs programDb envFile envEntries = do + -- Why do we get it again? If we updated a globalPackage then we need + -- the new version. + installedIndex <- getInstalledPackages verbosity compiler packageDbs programDb + if supportsPkgEnvFiles $ getImplInfo compiler + then do + let + getLatest :: PackageName -> [InstalledPackageInfo] + getLatest = (=<<) (maybeToList . safeHead . snd) . take 1 . sortBy (comparing (Down . fst)) + . PI.lookupPackageName installedIndex + globalLatest = concat (getLatest <$> globalPackages) + + baseEntries = + GhcEnvFileClearPackageDbStack : fmap GhcEnvFilePackageDb packageDbs + globalEntries = GhcEnvFilePackageId . installedUnitId <$> globalLatest + pkgEntries = ordNub $ + globalEntries + ++ envEntries + ++ entriesForLibraryComponents (targetsMap buildCtx) + contents' = renderGhcEnvironmentFile (baseEntries ++ pkgEntries) + createDirectoryIfMissing True (takeDirectory envFile) + writeFileAtomic envFile (BS.pack contents') + else + warn verbosity $ + "The current compiler doesn't support safely installing libraries, " + ++ "so only executables will be available. (Library installation is " + ++ "supported on GHC 8.0+ only)" + +warnIfNoExes :: Verbosity -> ProjectBuildContext -> IO () +warnIfNoExes verbosity buildCtx = + when noExes $ + warn verbosity $ + "\n" <> + "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@\n" <> + "@ WARNING: Installation might not be completed as desired! @\n" <> + "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@\n" <> + "The command \"cabal install [TARGETS]\" doesn't expose libraries.\n" <> + "* You might have wanted to add them as dependencies to your package." <> + " In this case add \"" <> + intercalate ", " (showTargetSelector <$> selectors) <> + "\" to the build-depends field(s) of your package's .cabal file.\n" <> + "* You might have wanted to add them to a GHC environment. In this case" <> + " use \"cabal install --lib " <> + unwords (showTargetSelector <$> selectors) <> "\". " <> + " The \"--lib\" flag is provisional: see" <> + " https://github.com/haskell/cabal/issues/6481 for more information." + where + targets = concat $ Map.elems $ targetsMap buildCtx + components = fst <$> targets + selectors = concatMap (NE.toList . snd) targets + noExes = null $ catMaybes $ exeMaybe <$> components + + exeMaybe (ComponentTarget (CExeName exe) _) = Just exe + exeMaybe _ = Nothing + +globalPackages :: [PackageName] +globalPackages = mkPackageName <$> + [ "ghc", "hoopl", "bytestring", "unix", "base", "time", "hpc", "filepath" + , "process", "array", "integer-gmp", "containers", "ghc-boot", "binary" + , "ghc-prim", "ghci", "rts", "terminfo", "transformers", "deepseq" + , "ghc-boot-th", "pretty", "template-haskell", "directory", "text" + , "bin-package-db" + ] + +-- | Return the package specifiers and non-global environment file entries. +getEnvSpecsAndNonGlobalEntries + :: PI.InstalledPackageIndex + -> [GhcEnvironmentFileEntry] + -> Bool + -> ([PackageSpecifier a], [GhcEnvironmentFileEntry]) +getEnvSpecsAndNonGlobalEntries installedIndex entries installLibs = + if installLibs + then (envSpecs, envEntries') + else ([], envEntries') + where + (envSpecs, envEntries') = environmentFileToSpecifiers installedIndex entries + +environmentFileToSpecifiers + :: PI.InstalledPackageIndex -> [GhcEnvironmentFileEntry] + -> ([PackageSpecifier a], [GhcEnvironmentFileEntry]) +environmentFileToSpecifiers ipi = foldMap $ \case + (GhcEnvFilePackageId unitId) + | Just InstalledPackageInfo + { sourcePackageId = PackageIdentifier{..}, installedUnitId } + <- PI.lookupUnitId ipi unitId + , let pkgSpec = NamedPackage pkgName + [PackagePropertyVersion (thisVersion pkgVersion)] + -> if pkgName `elem` globalPackages + then ([pkgSpec], []) + else ([pkgSpec], [GhcEnvFilePackageId installedUnitId]) + _ -> ([], []) + + +-- | Disables tests and benchmarks if they weren't explicitly enabled. +disableTestsBenchsByDefault :: ConfigFlags -> ConfigFlags +disableTestsBenchsByDefault configFlags = + configFlags { configTests = Flag False <> configTests configFlags + , configBenchmarks = Flag False <> configBenchmarks configFlags } + +-- | Symlink/copy every exe from a package from the store to a given location +installUnitExes + :: Verbosity + -> OverwritePolicy -- ^ Whether to overwrite existing files + -> (UnitId -> FilePath) -- ^ A function to get an UnitId's + -- ^ store directory + -> (UnqualComponentName -> FilePath) -- ^ A function to get an + -- ^ exe's filename + -> (UnqualComponentName -> FilePath) -- ^ A function to get an + -- ^ exe's final possibly + -- ^ different to the name in the store. + -> FilePath + -> InstallMethod + -> ( UnitId + , [(ComponentTarget, NonEmpty TargetSelector)] ) + -> IO () +installUnitExes verbosity overwritePolicy + mkSourceBinDir mkExeName mkFinalExeName + installdir installMethod + (unit, components) = + traverse_ installAndWarn exes + where + exes = catMaybes $ (exeMaybe . fst) <$> components + exeMaybe (ComponentTarget (CExeName exe) _) = Just exe + exeMaybe _ = Nothing + installAndWarn exe = do + success <- installBuiltExe + verbosity overwritePolicy + (mkSourceBinDir unit) (mkExeName exe) + (mkFinalExeName exe) + installdir installMethod + let errorMessage = case overwritePolicy of + NeverOverwrite -> + "Path '" <> (installdir prettyShow exe) <> "' already exists. " + <> "Use --overwrite-policy=always to overwrite." + -- This shouldn't even be possible, but we keep it in case + -- symlinking/copying logic changes + _ -> + case installMethod of + InstallMethodSymlink -> "Symlinking" + InstallMethodCopy -> + "Copying" <> " '" <> prettyShow exe <> "' failed." + unless success $ die' verbosity errorMessage + +-- | Install a specific exe. +installBuiltExe + :: Verbosity -> OverwritePolicy + -> FilePath -- ^ The directory where the built exe is located + -> FilePath -- ^ The exe's filename + -> FilePath -- ^ The exe's filename in the public install directory + -> FilePath -- ^ the directory where it should be installed + -> InstallMethod + -> IO Bool -- ^ Whether the installation was successful +installBuiltExe verbosity overwritePolicy + sourceDir exeName finalExeName + installdir InstallMethodSymlink = do + notice verbosity $ "Symlinking '" <> exeName <> "' to '" <> destination <> "'" + symlinkBinary + overwritePolicy + installdir + sourceDir + finalExeName + exeName + where + destination = installdir finalExeName +installBuiltExe verbosity overwritePolicy + sourceDir exeName finalExeName + installdir InstallMethodCopy = do + notice verbosity $ "Copying '" <> exeName <> "' to '" <> destination <> "'" + exists <- doesPathExist destination + case (exists, overwritePolicy) of + (True , NeverOverwrite ) -> pure False + (True , AlwaysOverwrite) -> overwrite + (True , PromptOverwrite) -> maybeOverwrite + (False, _ ) -> copy + where + source = sourceDir exeName + destination = installdir finalExeName + remove = do + isDir <- doesDirectoryExist destination + if isDir + then removeDirectory destination + else removeFile destination + copy = copyFile source destination >> pure True + overwrite :: IO Bool + overwrite = remove >> copy + maybeOverwrite :: IO Bool + maybeOverwrite + = promptRun + "Existing file found while installing executable. Do you want to overwrite that file? (y/n)" + overwrite + +-- | Create 'GhcEnvironmentFileEntry's for packages with exposed libraries. +entriesForLibraryComponents :: TargetsMap -> [GhcEnvironmentFileEntry] +entriesForLibraryComponents = Map.foldrWithKey' (\k v -> mappend (go k v)) [] + where + hasLib :: (ComponentTarget, NonEmpty TargetSelector) -> Bool + hasLib (ComponentTarget (CLibName _) _, _) = True + hasLib _ = False + + go :: UnitId + -> [(ComponentTarget, NonEmpty TargetSelector)] + -> [GhcEnvironmentFileEntry] + go unitId targets + | any hasLib targets = [GhcEnvFilePackageId unitId] + | otherwise = [] + + +-- | Gets the file path to the request environment file. +getEnvFile :: ClientInstallFlags -> Platform -> Version -> IO FilePath +getEnvFile clientInstallFlags platform compilerVersion = do + appDir <- getGhcAppDir + case flagToMaybe (cinstEnvironmentPath clientInstallFlags) of + Just spec + -- Is spec a bare word without any "pathy" content, then it refers to + -- a named global environment. + | takeBaseName spec == spec -> + return (getGlobalEnv appDir platform compilerVersion spec) + | otherwise -> do + spec' <- makeAbsolute spec + isDir <- doesDirectoryExist spec' + if isDir + -- If spec is a directory, then make an ambient environment inside + -- that directory. + then return (getLocalEnv spec' platform compilerVersion) + -- Otherwise, treat it like a literal file path. + else return spec' + Nothing -> + return (getGlobalEnv appDir platform compilerVersion "default") + +-- | Returns the list of @GhcEnvFilePackageIj@ values already existing in the +-- environment being operated on. +getExistingEnvEntries :: Verbosity -> CompilerFlavor -> Bool -> FilePath -> IO [GhcEnvironmentFileEntry] +getExistingEnvEntries verbosity compilerFlavor supportsPkgEnvFiles envFile = do + envFileExists <- doesFileExist envFile + filterEnvEntries <$> if + (compilerFlavor == GHC || compilerFlavor == GHCJS) + && supportsPkgEnvFiles && envFileExists + then catch (readGhcEnvironmentFile envFile) $ \(_ :: ParseErrorExc) -> + warn verbosity ("The environment file " ++ envFile ++ + " is unparsable. Libraries cannot be installed.") >> return [] + else return [] + where + -- Why? We know what the first part will be, we only care about the packages. + filterEnvEntries = filter $ \case + GhcEnvFilePackageId _ -> True + _ -> False + +-- | Constructs the path to the global GHC environment file. +-- +-- TODO(m-renaud): Create PkgEnvName newtype wrapper. +getGlobalEnv :: FilePath -> Platform -> Version -> String -> FilePath +getGlobalEnv appDir platform compilerVersion name = + appDir ghcPlatformAndVersionString platform compilerVersion + "environments" name + +-- | Constructs the path to a local GHC environment file. +getLocalEnv :: FilePath -> Platform -> Version -> FilePath +getLocalEnv dir platform compilerVersion = + dir + ".ghc.environment." <> ghcPlatformAndVersionString platform compilerVersion + +getPackageDbStack + :: CompilerId + -> Flag FilePath + -> Flag FilePath + -> IO PackageDBStack +getPackageDbStack compilerId storeDirFlag logsDirFlag = do + cabalDir <- getCabalDir + mstoreDir <- traverse makeAbsolute $ flagToMaybe storeDirFlag + let + mlogsDir = flagToMaybe logsDirFlag + cabalLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir + pure $ storePackageDBStack (cabalStoreDirLayout cabalLayout) compilerId + +-- | This defines what a 'TargetSelector' means for the @bench@ command. +-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, +-- or otherwise classifies the problem. +-- +-- For the @build@ command select all components except non-buildable +-- and disabled tests\/benchmarks, fail if there are no such +-- components +-- +selectPackageTargets + :: TargetSelector + -> [AvailableTarget k] -> Either TargetProblem' [k] +selectPackageTargets targetSelector targets + + -- If there are any buildable targets then we select those + | not (null targetsBuildable) + = Right targetsBuildable + + -- If there are targets but none are buildable then we report those + | not (null targets) + = Left (TargetProblemNoneEnabled targetSelector targets') + + -- If there are no targets at all then we report that + | otherwise + = Left (TargetProblemNoTargets targetSelector) + where + targets' = forgetTargetsDetail targets + targetsBuildable = selectBuildableTargetsWith + (buildable targetSelector) + targets + + -- When there's a target filter like "pkg:tests" then we do select tests, + -- but if it's just a target like "pkg" then we don't build tests unless + -- they are requested by default (i.e. by using --enable-tests) + buildable (TargetPackage _ _ Nothing) TargetNotRequestedByDefault = False + buildable (TargetAllPackages Nothing) TargetNotRequestedByDefault = False + buildable _ _ = True + +-- | For a 'TargetComponent' 'TargetSelector', check if the component can be +-- selected. +-- +-- For the @build@ command we just need the basic checks on being buildable etc. +-- +selectComponentTarget + :: SubComponentTarget + -> AvailableTarget k -> Either TargetProblem' k +selectComponentTarget = selectComponentTargetBasic + +reportBuildTargetProblems :: Verbosity -> [TargetProblem'] -> IO a +reportBuildTargetProblems verbosity problems = reportTargetProblems verbosity "build" problems + +reportCannotPruneDependencies :: Verbosity -> CannotPruneDependencies -> IO a +reportCannotPruneDependencies verbosity = + die' verbosity . renderCannotPruneDependencies diff --git a/cabal/cabal-install/src/Distribution/Client/CmdInstall/ClientInstallFlags.hs b/cabal/cabal-install/src/Distribution/Client/CmdInstall/ClientInstallFlags.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/CmdInstall/ClientInstallFlags.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +module Distribution.Client.CmdInstall.ClientInstallFlags +( InstallMethod(..) +, ClientInstallFlags(..) +, defaultClientInstallFlags +, clientInstallOptions +) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.ReadE + ( succeedReadE, parsecToReadE ) +import Distribution.Simple.Command + ( ShowOrParseArgs(..), OptionField(..), option, reqArg ) +import Distribution.Simple.Setup + ( Flag(..), trueArg, flagToList, toFlag ) + +import Distribution.Client.Types.InstallMethod + ( InstallMethod (..) ) +import Distribution.Client.Types.OverwritePolicy + ( OverwritePolicy(..) ) + +import qualified Distribution.Compat.CharParsing as P + +data ClientInstallFlags = ClientInstallFlags + { cinstInstallLibs :: Flag Bool + , cinstEnvironmentPath :: Flag FilePath + , cinstOverwritePolicy :: Flag OverwritePolicy + , cinstInstallMethod :: Flag InstallMethod + , cinstInstalldir :: Flag FilePath + } deriving (Eq, Show, Generic) + +instance Monoid ClientInstallFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup ClientInstallFlags where + (<>) = gmappend + +instance Binary ClientInstallFlags +instance Structured ClientInstallFlags + +defaultClientInstallFlags :: ClientInstallFlags +defaultClientInstallFlags = ClientInstallFlags + { cinstInstallLibs = toFlag False + , cinstEnvironmentPath = mempty + , cinstOverwritePolicy = mempty + , cinstInstallMethod = mempty + , cinstInstalldir = mempty + } + +clientInstallOptions :: ShowOrParseArgs -> [OptionField ClientInstallFlags] +clientInstallOptions _ = + [ option [] ["lib"] + ( "Install libraries rather than executables from the target package " <> + "(provisional, see https://github.com/haskell/cabal/issues/6481 for more information)." ) + cinstInstallLibs (\v flags -> flags { cinstInstallLibs = v }) + trueArg + , option [] ["package-env", "env"] + "Set the environment file that may be modified." + cinstEnvironmentPath (\pf flags -> flags { cinstEnvironmentPath = pf }) + (reqArg "ENV" (succeedReadE Flag) flagToList) + , option [] ["overwrite-policy"] + "How to handle already existing symlinks." + cinstOverwritePolicy (\v flags -> flags { cinstOverwritePolicy = v }) + $ reqArg "always|never|prompt" + (parsecToReadE (\err -> "Error parsing overwrite-policy: " ++ err) (toFlag `fmap` parsec)) + (map prettyShow . flagToList) + , option [] ["install-method"] + "How to install the executables." + cinstInstallMethod (\v flags -> flags { cinstInstallMethod = v }) + $ reqArg + "default|copy|symlink" + (parsecToReadE (\err -> "Error parsing install-method: " ++ err) (toFlag `fmap` parsecInstallMethod)) + (map prettyShow . flagToList) + , option [] ["installdir"] + "Where to install (by symlinking or copying) the executables in." + cinstInstalldir (\v flags -> flags { cinstInstalldir = v }) + $ reqArg "DIR" (succeedReadE Flag) flagToList + ] + +parsecInstallMethod :: CabalParsing m => m InstallMethod +parsecInstallMethod = do + name <- P.munch1 isAlpha + case name of + "copy" -> pure InstallMethodCopy + "symlink" -> pure InstallMethodSymlink + _ -> P.unexpected $ "InstallMethod: " ++ name diff --git a/cabal/cabal-install/src/Distribution/Client/CmdInstall/ClientInstallTargetSelector.hs b/cabal/cabal-install/src/Distribution/Client/CmdInstall/ClientInstallTargetSelector.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/CmdInstall/ClientInstallTargetSelector.hs @@ -0,0 +1,68 @@ +module Distribution.Client.CmdInstall.ClientInstallTargetSelector ( + WithoutProjectTargetSelector (..), + parseWithoutProjectTargetSelector, + woPackageNames, + woPackageTargets, + woPackageSpecifiers, + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Network.URI (URI, parseURI) + +import Distribution.Client.TargetSelector +import Distribution.Client.Types +import Distribution.Compat.CharParsing (char, optional) +import Distribution.Package +import Distribution.Simple.LocalBuildInfo (ComponentName (CExeName)) +import Distribution.Simple.Utils (die') +import Distribution.Solver.Types.PackageConstraint (PackageProperty (..)) +import Distribution.Version + +data WithoutProjectTargetSelector + = WoPackageId PackageId + | WoPackageComponent PackageId ComponentName + | WoURI URI + deriving (Show) + +parseWithoutProjectTargetSelector :: Verbosity -> String -> IO WithoutProjectTargetSelector +parseWithoutProjectTargetSelector verbosity input = + case explicitEitherParsec parser input of + Right ts -> return ts + Left err -> case parseURI input of + Just uri -> return (WoURI uri) + Nothing -> die' verbosity $ "Invalid package ID: " ++ input ++ "\n" ++ err + where + parser :: CabalParsing m => m WithoutProjectTargetSelector + parser = do + pid <- parsec + cn <- optional (char ':' *> parsec) + return $ case cn of + Nothing -> WoPackageId pid + Just cn' -> WoPackageComponent pid (CExeName cn') + +woPackageNames :: WithoutProjectTargetSelector -> [PackageName] +woPackageNames (WoPackageId pid) = [pkgName pid] +woPackageNames (WoPackageComponent pid _) = [pkgName pid] +woPackageNames (WoURI _) = [] + +woPackageTargets :: WithoutProjectTargetSelector -> TargetSelector +woPackageTargets (WoPackageId pid) = + TargetPackageNamed (pkgName pid) Nothing +woPackageTargets (WoPackageComponent pid cn) = + TargetComponentUnknown (pkgName pid) (Right cn) WholeComponent +woPackageTargets (WoURI _) = + TargetAllPackages (Just ExeKind) + +woPackageSpecifiers :: WithoutProjectTargetSelector -> Either URI (PackageSpecifier pkg) +woPackageSpecifiers (WoPackageId pid) = Right (pidPackageSpecifiers pid) +woPackageSpecifiers (WoPackageComponent pid _) = Right (pidPackageSpecifiers pid) +woPackageSpecifiers (WoURI uri) = Left uri + +pidPackageSpecifiers :: PackageId -> PackageSpecifier pkg +pidPackageSpecifiers pid + | pkgVersion pid == nullVersion = NamedPackage (pkgName pid) [] + | otherwise = NamedPackage (pkgName pid) + [ PackagePropertyVersion (thisVersion (pkgVersion pid)) + ] diff --git a/cabal/cabal-install/src/Distribution/Client/CmdLegacy.hs b/cabal/cabal-install/src/Distribution/Client/CmdLegacy.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/CmdLegacy.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} +module Distribution.Client.CmdLegacy ( legacyCmd, legacyWrapperCmd, newCmd ) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Distribution.Client.Sandbox + ( loadConfigOrSandboxConfig, findSavedDistPref ) +import qualified Distribution.Client.Setup as Client +import Distribution.Client.SetupWrapper + ( SetupScriptOptions(..), setupWrapper, defaultSetupScriptOptions ) +import qualified Distribution.Simple.Setup as Setup +import Distribution.Simple.Command +import Distribution.Simple.Utils + ( wrapText ) +import Distribution.Verbosity + ( normal ) + +import Control.Exception + ( try ) +import qualified Data.Text as T + +-- Tweaked versions of code from Main. +regularCmd :: (HasVerbosity flags) => CommandUI flags -> (flags -> [String] -> globals -> IO action) -> CommandSpec (globals -> IO action) +regularCmd ui action = + CommandSpec ui ((flip commandAddAction) (\flags extra globals -> action flags extra globals)) NormalCommand + +wrapperCmd :: Monoid flags => CommandUI flags -> (flags -> Setup.Flag Verbosity) -> (flags -> Setup.Flag String) -> CommandSpec (Client.GlobalFlags -> IO ()) +wrapperCmd ui verbosity' distPref = + CommandSpec ui (\ui' -> wrapperAction ui' verbosity' distPref) NormalCommand + +wrapperAction :: Monoid flags => CommandUI flags -> (flags -> Setup.Flag Verbosity) -> (flags -> Setup.Flag String) -> Command (Client.GlobalFlags -> IO ()) +wrapperAction command verbosityFlag distPrefFlag = + commandAddAction command + { commandDefaultFlags = mempty } $ \flags extraArgs globalFlags -> do + let verbosity' = Setup.fromFlagOrDefault normal (verbosityFlag flags) + + load <- try (loadConfigOrSandboxConfig verbosity' globalFlags) + let config = either (\(SomeException _) -> mempty) id load + distPref <- findSavedDistPref config (distPrefFlag flags) + let setupScriptOptions = defaultSetupScriptOptions { useDistPref = distPref } + + let command' = command { commandName = T.unpack . T.replace "v1-" "" . T.pack . commandName $ command } + + setupWrapper verbosity' setupScriptOptions Nothing + command' (const flags) (const extraArgs) + +-- + +class HasVerbosity a where + verbosity :: a -> Verbosity + +instance HasVerbosity (Setup.Flag Verbosity) where + verbosity = Setup.fromFlagOrDefault normal + +instance (HasVerbosity a) => HasVerbosity (a, b) where + verbosity (a, _) = verbosity a + +instance (HasVerbosity a) => HasVerbosity (a, b, c) where + verbosity (a , _, _) = verbosity a + +instance (HasVerbosity a) => HasVerbosity (a, b, c, d) where + verbosity (a, _, _, _) = verbosity a + +instance (HasVerbosity a) => HasVerbosity (a, b, c, d, e) where + verbosity (a, _, _, _, _) = verbosity a + +instance (HasVerbosity a) => HasVerbosity (a, b, c, d, e, f) where + verbosity (a, _, _, _, _, _) = verbosity a + +instance HasVerbosity Setup.BuildFlags where + verbosity = verbosity . Setup.buildVerbosity + +instance HasVerbosity Setup.ConfigFlags where + verbosity = verbosity . Setup.configVerbosity + +instance HasVerbosity Setup.ReplFlags where + verbosity = verbosity . Setup.replVerbosity + +instance HasVerbosity Client.FreezeFlags where + verbosity = verbosity . Client.freezeVerbosity + +instance HasVerbosity Setup.HaddockFlags where + verbosity = verbosity . Setup.haddockVerbosity + +instance HasVerbosity Client.UpdateFlags where + verbosity = verbosity . Client.updateVerbosity + +instance HasVerbosity Setup.CleanFlags where + verbosity = verbosity . Setup.cleanVerbosity + +-- + +legacyNote :: String -> String +legacyNote cmd = wrapText $ + "The v1-" ++ cmd ++ " command is a part of the legacy v1 style of cabal usage.\n\n" ++ + + "It is a legacy feature and will be removed in a future release of cabal-install." ++ + " Please file a bug if you cannot replicate a working v1- use case with the nix-style" ++ + " commands.\n\n" ++ + + "For more information, see: https://cabal.readthedocs.io/en/latest/nix-local-build-overview.html" + +toLegacyCmd :: CommandSpec (globals -> IO action) -> [CommandSpec (globals -> IO action)] +toLegacyCmd mkSpec = [toLegacy mkSpec] + where + toLegacy (CommandSpec origUi@CommandUI{..} action type') = CommandSpec legUi action type' + where + legUi = origUi + { commandName = "v1-" ++ commandName + , commandNotes = Just $ \pname -> case commandNotes of + Just notes -> notes pname ++ "\n" ++ legacyNote commandName + Nothing -> legacyNote commandName + } + +legacyCmd :: (HasVerbosity flags) => CommandUI flags -> (flags -> [String] -> globals -> IO action) -> [CommandSpec (globals -> IO action)] +legacyCmd ui action = toLegacyCmd (regularCmd ui action) + +legacyWrapperCmd :: Monoid flags => CommandUI flags -> (flags -> Setup.Flag Verbosity) -> (flags -> Setup.Flag String) -> [CommandSpec (Client.GlobalFlags -> IO ())] +legacyWrapperCmd ui verbosity' distPref = toLegacyCmd (wrapperCmd ui verbosity' distPref) + +newCmd :: CommandUI flags -> (flags -> [String] -> globals -> IO action) -> [CommandSpec (globals -> IO action)] +newCmd origUi@CommandUI{..} action = [cmd defaultUi, cmd newUi, cmd origUi] + where + cmd ui = CommandSpec ui (flip commandAddAction action) NormalCommand + + newMsg = T.unpack . T.replace "v2-" "new-" . T.pack + newUi = origUi + { commandName = newMsg commandName + , commandUsage = newMsg . commandUsage + , commandDescription = (newMsg .) <$> commandDescription + , commandNotes = (newMsg .) <$> commandNotes + } + + defaultMsg = T.unpack . T.replace "v2-" "" . T.pack + defaultUi = origUi + { commandName = defaultMsg commandName + , commandUsage = defaultMsg . commandUsage + , commandDescription = (defaultMsg .) <$> commandDescription + , commandNotes = (defaultMsg .) <$> commandNotes + } diff --git a/cabal/cabal-install/src/Distribution/Client/CmdListBin.hs b/cabal/cabal-install/src/Distribution/Client/CmdListBin.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/CmdListBin.hs @@ -0,0 +1,374 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +module Distribution.Client.CmdListBin ( + listbinCommand, + listbinAction, + + -- * Internals exposed for testing + selectPackageTargets, + selectComponentTarget, + noComponentsProblem, + matchesMultipleProblem, + multipleTargetsProblem, + componentNotRightKindProblem +) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Client.CmdErrorMessages + (plural, renderListCommaAnd, renderTargetProblem, renderTargetProblemNoTargets, + renderTargetSelector, showTargetSelector, targetSelectorFilter, targetSelectorPluralPkgs) +import Distribution.Client.DistDirLayout (DistDirLayout (..)) +import Distribution.Client.NixStyleOptions + (NixStyleFlags (..), defaultNixStyleFlags, nixStyleOptions) +import Distribution.Client.ProjectOrchestration +import Distribution.Client.ProjectPlanning.Types +import Distribution.Client.ScriptUtils + (AcceptNoTargets(..), TargetContext(..), updateContextAndWriteProjectFile, withContextAndSelectors) +import Distribution.Client.Setup (GlobalFlags (..)) +import Distribution.Client.TargetProblem (TargetProblem (..)) +import Distribution.Simple.BuildPaths (dllExtension, exeExtension) +import Distribution.Simple.Command (CommandUI (..)) +import Distribution.Simple.Setup (configVerbosity, fromFlagOrDefault) +import Distribution.Simple.Utils (die', wrapText) +import Distribution.System (Platform) +import Distribution.Types.ComponentName (showComponentName) +import Distribution.Types.UnitId (UnitId) +import Distribution.Types.UnqualComponentName (UnqualComponentName) +import Distribution.Verbosity (silent, verboseStderr) +import System.FilePath ((<.>), ()) + +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Distribution.Client.InstallPlan as IP +import qualified Distribution.Simple.InstallDirs as InstallDirs +import qualified Distribution.Solver.Types.ComponentDeps as CD + +------------------------------------------------------------------------------- +-- Command +------------------------------------------------------------------------------- + +listbinCommand :: CommandUI (NixStyleFlags ()) +listbinCommand = CommandUI + { commandName = "list-bin" + , commandSynopsis = "List the path to a single executable." + , commandUsage = \pname -> + "Usage: " ++ pname ++ " list-bin [FLAGS] TARGET\n" + , commandDescription = Just $ \_ -> wrapText + "List the path to a build product." + , commandNotes = Nothing + , commandDefaultFlags = defaultNixStyleFlags () + , commandOptions = nixStyleOptions (const []) + } + +------------------------------------------------------------------------------- +-- Action +------------------------------------------------------------------------------- + +listbinAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO () +listbinAction flags@NixStyleFlags{..} args globalFlags = do + -- fail early if multiple target selectors specified + target <- case args of + [] -> die' verbosity "One target is required, none provided" + [x] -> return x + _ -> die' verbosity "One target is required, given multiple" + + -- configure and elaborate target selectors + withContextAndSelectors RejectNoTargets (Just ExeKind) flags [target] globalFlags $ \targetCtx ctx targetSelectors -> do + baseCtx <- case targetCtx of + ProjectContext -> return ctx + GlobalContext -> return ctx + ScriptContext path exemeta -> updateContextAndWriteProjectFile ctx path exemeta + + buildCtx <- + runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do + -- Interpret the targets on the command line as build targets + -- (as opposed to say repl or haddock targets). + targets <- either (reportTargetProblems verbosity) return + $ resolveTargets + selectPackageTargets + selectComponentTarget + elaboratedPlan + Nothing + targetSelectors + + -- 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. + -- + -- Note that we discard the target and return the whole 'TargetsMap', + -- so this check will be repeated (and must succeed) after + -- the 'runProjectPreBuildPhase'. Keep it in mind when modifying this. + _ <- singleComponentOrElse + (reportTargetProblems + verbosity + [multipleTargetsProblem targets]) + targets + + let elaboratedPlan' = pruneInstallPlanToTargets + TargetActionBuild + targets + elaboratedPlan + return (elaboratedPlan', targets) + + (selectedUnitId, selectedComponent) <- + -- Slight duplication with 'runProjectPreBuildPhase'. + singleComponentOrElse + (die' verbosity $ "No or multiple targets given, but the run " + ++ "phase has been reached. This is a bug.") + $ targetsMap buildCtx + + printPlan verbosity baseCtx buildCtx + + binfiles <- case Map.lookup selectedUnitId $ IP.toMap (elaboratedPlanOriginal buildCtx) of + Nothing -> die' verbosity "No or multiple targets given..." + Just gpp -> return $ IP.foldPlanPackage + (const []) -- IPI don't have executables + (elaboratedPackage (distDirLayout baseCtx) (elaboratedShared buildCtx) selectedComponent) + gpp + + case binfiles of + [] -> die' verbosity "No target found" + [exe] -> putStrLn exe + _ -> die' verbosity "Multiple targets found" + where + defaultVerbosity = verboseStderr silent + verbosity = fromFlagOrDefault defaultVerbosity (configVerbosity configFlags) + + -- this is copied from + elaboratedPackage + :: DistDirLayout + -> ElaboratedSharedConfig + -> UnqualComponentName + -> ElaboratedConfiguredPackage + -> [FilePath] + elaboratedPackage distDirLayout elaboratedSharedConfig selectedComponent elab = case elabPkgOrComp elab of + ElabPackage pkg -> + [ bin + | (c, _) <- CD.toList $ CD.zip (pkgLibDependencies pkg) + (pkgExeDependencies pkg) + , bin <- bin_file c + ] + ElabComponent comp -> bin_file (compSolverName comp) + where + dist_dir = distBuildDirectory distDirLayout (elabDistDirParams elaboratedSharedConfig elab) + + bin_file c = case c of + CD.ComponentExe s + | s == selectedComponent -> [bin_file' s] + CD.ComponentTest s + | s == selectedComponent -> [bin_file' s] + CD.ComponentBench s + | s == selectedComponent -> [bin_file' s] + CD.ComponentFLib s + | s == selectedComponent -> [flib_file' s] + _ -> [] + + plat :: Platform + plat = pkgConfigPlatform elaboratedSharedConfig + + -- here and in PlanOutput, + -- use binDirectoryFor? + bin_file' s = + if elabBuildStyle elab == BuildInplaceOnly + then dist_dir "build" prettyShow s prettyShow s <.> exeExtension plat + else InstallDirs.bindir (elabInstallDirs elab) prettyShow s <.> exeExtension plat + + flib_file' s = + if elabBuildStyle elab == BuildInplaceOnly + then dist_dir "build" prettyShow s ("lib" ++ prettyShow s) <.> dllExtension plat + else InstallDirs.bindir (elabInstallDirs elab) ("lib" ++ prettyShow s) <.> dllExtension plat + +------------------------------------------------------------------------------- +-- Target Problem: the very similar to CmdRun +------------------------------------------------------------------------------- + +singleComponentOrElse :: IO (UnitId, UnqualComponentName) -> TargetsMap -> IO (UnitId, UnqualComponentName) +singleComponentOrElse action targetsMap = + case Set.toList . distinctTargetComponents $ targetsMap + of [(unitId, CExeName component)] -> return (unitId, component) + [(unitId, CTestName component)] -> return (unitId, component) + [(unitId, CBenchName component)] -> return (unitId, component) + [(unitId, CFLibName component)] -> return (unitId, component) + _ -> action + +-- | This defines what a 'TargetSelector' means for the @list-bin@ command. +-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, +-- or otherwise classifies the problem. +-- +-- For the @list-bin@ command we select the exe or flib if there is only one +-- and it's buildable. Fail if there are no or multiple buildable exe components. +-- +selectPackageTargets :: TargetSelector + -> [AvailableTarget k] -> Either ListBinTargetProblem [k] +selectPackageTargets targetSelector targets + + -- If there is a single executable component, select that. See #7403 + | [target] <- targetsExesBuildable + = Right [target] + + -- Otherwise, if there is a single executable-like component left, select that. + | [target] <- targetsExeLikesBuildable + = Right [target] + + -- but fail if there are multiple buildable executables. + | not (null targetsExeLikesBuildable) + = Left (matchesMultipleProblem targetSelector targetsExeLikesBuildable') + + -- If there are executables but none are buildable then we report those + | not (null targetsExeLikes') + = Left (TargetProblemNoneEnabled targetSelector targetsExeLikes') + + -- If there are no executables but some other targets then we report that + | not (null targets) + = Left (noComponentsProblem targetSelector) + + -- If there are no targets at all then we report that + | otherwise + = Left (TargetProblemNoTargets targetSelector) + where + -- Targets that are precisely executables + targetsExes = filterTargetsKind ExeKind targets + targetsExesBuildable = selectBuildableTargets targetsExes + + -- Any target that could be executed + targetsExeLikes = targetsExes + ++ filterTargetsKind TestKind targets + ++ filterTargetsKind BenchKind targets + + (targetsExeLikesBuildable, + targetsExeLikesBuildable') = selectBuildableTargets' targetsExeLikes + + targetsExeLikes' = forgetTargetsDetail targetsExeLikes + + +-- | For a 'TargetComponent' 'TargetSelector', check if the component can be +-- selected. +-- +-- For the @run@ command we just need to check it is a executable-like +-- (an executable, a test, or a benchmark), in addition +-- to the basic checks on being buildable etc. +-- +selectComponentTarget :: SubComponentTarget + -> AvailableTarget k -> Either ListBinTargetProblem k +selectComponentTarget subtarget@WholeComponent t + = case availableTargetComponentName t + of CExeName _ -> component + CTestName _ -> component + CBenchName _ -> component + CFLibName _ -> component + _ -> Left (componentNotRightKindProblem pkgid cname) + where pkgid = availableTargetPackageId t + cname = availableTargetComponentName t + component = selectComponentTargetBasic subtarget t + +selectComponentTarget subtarget t + = Left (isSubComponentProblem (availableTargetPackageId t) + (availableTargetComponentName t) + subtarget) + +-- | The various error conditions that can occur when matching a +-- 'TargetSelector' against 'AvailableTarget's for the @run@ command. +-- +data ListBinProblem = + -- | The 'TargetSelector' matches targets but no executables + TargetProblemNoRightComps TargetSelector + + -- | A single 'TargetSelector' matches multiple targets + | TargetProblemMatchesMultiple TargetSelector [AvailableTarget ()] + + -- | Multiple 'TargetSelector's match multiple targets + | TargetProblemMultipleTargets TargetsMap + + -- | 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 + | TargetProblemIsSubComponent PackageId ComponentName SubComponentTarget + deriving (Eq, Show) + +type ListBinTargetProblem = TargetProblem ListBinProblem + +noComponentsProblem :: TargetSelector -> ListBinTargetProblem +noComponentsProblem = CustomTargetProblem . TargetProblemNoRightComps + +matchesMultipleProblem :: TargetSelector -> [AvailableTarget ()] -> ListBinTargetProblem +matchesMultipleProblem selector targets = CustomTargetProblem $ + TargetProblemMatchesMultiple selector targets + +multipleTargetsProblem :: TargetsMap -> TargetProblem ListBinProblem +multipleTargetsProblem = CustomTargetProblem . TargetProblemMultipleTargets + +componentNotRightKindProblem :: PackageId -> ComponentName -> TargetProblem ListBinProblem +componentNotRightKindProblem pkgid name = CustomTargetProblem $ + TargetProblemComponentNotRightKind pkgid name + +isSubComponentProblem + :: PackageId + -> ComponentName + -> SubComponentTarget + -> TargetProblem ListBinProblem +isSubComponentProblem pkgid name subcomponent = CustomTargetProblem $ + TargetProblemIsSubComponent pkgid name subcomponent + +reportTargetProblems :: Verbosity -> [ListBinTargetProblem] -> IO a +reportTargetProblems verbosity = + die' verbosity . unlines . map renderListBinTargetProblem + +renderListBinTargetProblem :: ListBinTargetProblem -> String +renderListBinTargetProblem (TargetProblemNoTargets targetSelector) = + case targetSelectorFilter targetSelector of + Just kind | kind /= ExeKind + -> "The list-bin command is for finding binaries, but the target '" + ++ showTargetSelector targetSelector ++ "' refers to " + ++ renderTargetSelector targetSelector ++ "." + + _ -> renderTargetProblemNoTargets "list-bin" targetSelector +renderListBinTargetProblem problem = + renderTargetProblem "list-bin" renderListBinProblem problem + +renderListBinProblem :: ListBinProblem -> String +renderListBinProblem (TargetProblemMatchesMultiple targetSelector targets) = + "The list-bin command is for finding a single binary at once. The target '" + ++ showTargetSelector targetSelector ++ "' refers to " + ++ renderTargetSelector targetSelector ++ " which includes " + ++ renderListCommaAnd ( ("the "++) <$> + showComponentName <$> + availableTargetComponentName <$> + foldMap + (\kind -> filterTargetsKind kind targets) + [ExeKind, TestKind, BenchKind] ) + ++ "." + +renderListBinProblem (TargetProblemMultipleTargets selectorMap) = + "The list-bin command is for finding a single binary at once. The targets " + ++ renderListCommaAnd [ "'" ++ showTargetSelector ts ++ "'" + | ts <- uniqueTargetSelectors selectorMap ] + ++ " refer to different executables." + +renderListBinProblem (TargetProblemComponentNotRightKind pkgid cname) = + "The list-bin command is for finding binaries, but the target '" + ++ showTargetSelector targetSelector ++ "' refers to " + ++ renderTargetSelector targetSelector ++ " from the package " + ++ prettyShow pkgid ++ "." + where + targetSelector = TargetComponent pkgid cname WholeComponent + +renderListBinProblem (TargetProblemIsSubComponent pkgid cname subtarget) = + "The list-bin command can only find a binary as a whole, " + ++ "not files or modules within them, but the target '" + ++ showTargetSelector targetSelector ++ "' refers to " + ++ renderTargetSelector targetSelector ++ "." + where + targetSelector = TargetComponent pkgid cname subtarget + +renderListBinProblem (TargetProblemNoRightComps targetSelector) = + "Cannot list-bin the target '" ++ showTargetSelector targetSelector + ++ "' which refers to " ++ renderTargetSelector targetSelector + ++ " because " + ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do" + ++ " not contain any executables or foreign libraries." diff --git a/cabal/cabal-install/src/Distribution/Client/CmdOutdated.hs b/cabal/cabal-install/src/Distribution/Client/CmdOutdated.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/CmdOutdated.hs @@ -0,0 +1,392 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.CmdOutdated +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Implementation of the 'outdated' command. Checks for outdated +-- dependencies in the package description file or freeze file. +----------------------------------------------------------------------------- + +module Distribution.Client.CmdOutdated + ( outdatedCommand, outdatedAction + , ListOutdatedSettings(..), listOutdated ) +where + +import Distribution.Client.Compat.Prelude +import Distribution.Compat.Lens + ( _1, _2 ) +import Prelude () + +import Distribution.Client.Config + ( SavedConfig(savedGlobalFlags, savedConfigureFlags + , savedConfigureExFlags) ) +import Distribution.Client.IndexUtils as IndexUtils +import Distribution.Client.DistDirLayout + ( defaultDistDirLayout + , DistDirLayout(distProjectRootDirectory, distProjectFile) ) +import Distribution.Client.ProjectConfig +import Distribution.Client.ProjectConfig.Legacy + ( instantiateProjectConfigSkeleton ) +import Distribution.Client.ProjectFlags + ( projectFlagsOptions, ProjectFlags(..), defaultProjectFlags + , removeIgnoreProjectOption ) +import Distribution.Client.RebuildMonad + ( runRebuild ) +import Distribution.Client.Sandbox + ( loadConfigOrSandboxConfig ) +import Distribution.Client.Setup +import Distribution.Client.Targets + ( userToPackageConstraint, UserConstraint ) +import Distribution.Client.Types.SourcePackageDb as SourcePackageDb +import Distribution.Solver.Types.PackageConstraint + ( packageConstraintToDependency ) +import Distribution.Client.Sandbox.PackageEnvironment + ( loadUserConfig ) +import Distribution.Utils.Generic + ( safeLast, wrapText ) + +import Distribution.Package + ( PackageName, packageVersion ) +import Distribution.PackageDescription + ( allBuildDepends ) +import Distribution.PackageDescription.Configuration + ( finalizePD ) +import Distribution.Simple.Compiler + ( Compiler, compilerInfo ) +import Distribution.Simple.Setup + ( optionVerbosity, trueArg ) +import Distribution.Simple.Utils + ( die', notice, debug, tryFindPackageDesc ) +import Distribution.System + ( Platform (..) ) +import Distribution.Types.ComponentRequestedSpec + ( ComponentRequestedSpec(..) ) +import Distribution.Types.Dependency + ( Dependency(..) ) +import Distribution.Verbosity + ( silent, normal ) +import Distribution.Version + ( Version, VersionInterval (..), VersionRange, LowerBound(..) + , UpperBound(..) , asVersionIntervals, majorBoundVersion ) +import Distribution.Types.PackageVersionConstraint + ( PackageVersionConstraint (..), simplifyPackageVersionConstraint ) +import Distribution.Simple.Flag + ( Flag(..), flagToMaybe, fromFlagOrDefault, toFlag ) +import Distribution.Simple.Command + ( ShowOrParseArgs, OptionField, CommandUI(..), optArg, option, reqArg, liftOptionL ) +import Distribution.Simple.PackageDescription + ( readGenericPackageDescription ) +import qualified Distribution.Compat.CharParsing as P +import Distribution.ReadE + ( parsecToReadE ) +import Distribution.Client.HttpUtils +import Distribution.Utils.NubList + ( fromNubList ) + +import qualified Data.Set as S +import System.Directory + ( getCurrentDirectory, doesFileExist ) + +------------------------------------------------------------------------------- +-- Command +------------------------------------------------------------------------------- + +outdatedCommand :: CommandUI (ProjectFlags, OutdatedFlags) +outdatedCommand = CommandUI + { commandName = "outdated" + , commandSynopsis = "Check for outdated dependencies." + , commandDescription = Just $ \_ -> wrapText $ + "Checks for outdated dependencies in the package description file " + ++ "or freeze file" + , commandNotes = Nothing + , commandUsage = \pname -> + "Usage: " ++ pname ++ " outdated [FLAGS] [PACKAGES]\n" + , commandDefaultFlags = (defaultProjectFlags, defaultOutdatedFlags) + , commandOptions = \showOrParseArgs -> + map (liftOptionL _1) + (removeIgnoreProjectOption (projectFlagsOptions showOrParseArgs)) ++ + map (liftOptionL _2) (outdatedOptions showOrParseArgs) + } + +------------------------------------------------------------------------------- +-- Flags +------------------------------------------------------------------------------- + +data IgnoreMajorVersionBumps = IgnoreMajorVersionBumpsNone + | IgnoreMajorVersionBumpsAll + | IgnoreMajorVersionBumpsSome [PackageName] + +instance Monoid IgnoreMajorVersionBumps where + mempty = IgnoreMajorVersionBumpsNone + mappend = (<>) + +instance Semigroup IgnoreMajorVersionBumps where + IgnoreMajorVersionBumpsNone <> r = r + l@IgnoreMajorVersionBumpsAll <> _ = l + l@(IgnoreMajorVersionBumpsSome _) <> IgnoreMajorVersionBumpsNone = l + (IgnoreMajorVersionBumpsSome _) <> r@IgnoreMajorVersionBumpsAll = r + (IgnoreMajorVersionBumpsSome a) <> (IgnoreMajorVersionBumpsSome b) = + IgnoreMajorVersionBumpsSome (a ++ b) + +data OutdatedFlags = OutdatedFlags + { outdatedVerbosity :: Flag Verbosity + , outdatedFreezeFile :: Flag Bool + , outdatedNewFreezeFile :: Flag Bool + , outdatedSimpleOutput :: Flag Bool + , outdatedExitCode :: Flag Bool + , outdatedQuiet :: Flag Bool + , outdatedIgnore :: [PackageName] + , outdatedMinor :: Maybe IgnoreMajorVersionBumps + } + +defaultOutdatedFlags :: OutdatedFlags +defaultOutdatedFlags = OutdatedFlags + { outdatedVerbosity = toFlag normal + , outdatedFreezeFile = mempty + , outdatedNewFreezeFile = mempty + , outdatedSimpleOutput = mempty + , outdatedExitCode = mempty + , outdatedQuiet = mempty + , outdatedIgnore = mempty + , outdatedMinor = mempty + } + +outdatedOptions :: ShowOrParseArgs -> [OptionField OutdatedFlags] +outdatedOptions _showOrParseArgs = + [ optionVerbosity + outdatedVerbosity + (\v flags -> flags {outdatedVerbosity = v}) + , option [] ["freeze-file", "v1-freeze-file"] + "Act on the freeze file" + outdatedFreezeFile (\v flags -> flags {outdatedFreezeFile = v}) + trueArg + , option [] ["v2-freeze-file", "new-freeze-file"] + "Act on the new-style freeze file (default: cabal.project.freeze)" + outdatedNewFreezeFile (\v flags -> flags {outdatedNewFreezeFile = v}) + trueArg + , option [] ["simple-output"] + "Only print names of outdated dependencies, one per line" + outdatedSimpleOutput (\v flags -> flags {outdatedSimpleOutput = v}) + trueArg + , option [] ["exit-code"] + "Exit with non-zero when there are outdated dependencies" + outdatedExitCode (\v flags -> flags {outdatedExitCode = v}) + trueArg + , option ['q'] ["quiet"] + "Don't print any output. Implies '--exit-code' and '-v0'" + outdatedQuiet (\v flags -> flags {outdatedQuiet = v}) + trueArg + , option [] ["ignore"] + "Packages to ignore" + outdatedIgnore (\v flags -> flags {outdatedIgnore = v}) + (reqArg "PKGS" pkgNameListParser (map prettyShow)) + , option [] ["minor"] + "Ignore major version bumps for these packages" + outdatedMinor (\v flags -> flags {outdatedMinor = v}) + ( optArg + "PKGS" + ignoreMajorVersionBumpsParser + (Just IgnoreMajorVersionBumpsAll) + ignoreMajorVersionBumpsPrinter + ) + ] + where + ignoreMajorVersionBumpsPrinter :: Maybe IgnoreMajorVersionBumps + -> [Maybe String] + ignoreMajorVersionBumpsPrinter Nothing = [] + ignoreMajorVersionBumpsPrinter (Just IgnoreMajorVersionBumpsNone)= [] + ignoreMajorVersionBumpsPrinter (Just IgnoreMajorVersionBumpsAll) = [Nothing] + ignoreMajorVersionBumpsPrinter (Just (IgnoreMajorVersionBumpsSome pkgs)) = + map (Just . prettyShow) pkgs + + ignoreMajorVersionBumpsParser = + (Just . IgnoreMajorVersionBumpsSome) `fmap` pkgNameListParser + + pkgNameListParser = parsecToReadE + ("Couldn't parse the list of package names: " ++) + (fmap toList (P.sepByNonEmpty parsec (P.char ','))) + +------------------------------------------------------------------------------- +-- Action +------------------------------------------------------------------------------- + +-- | Entry point for the 'outdated' command. +outdatedAction :: (ProjectFlags, OutdatedFlags) -> [String] -> GlobalFlags -> IO () +outdatedAction (ProjectFlags{flagProjectFileName}, OutdatedFlags{..}) _targetStrings globalFlags = do + config <- loadConfigOrSandboxConfig verbosity globalFlags + let globalFlags' = savedGlobalFlags config `mappend` globalFlags + configFlags = savedConfigureFlags config + withRepoContext verbosity globalFlags' $ \repoContext -> do + when (not newFreezeFile && isJust mprojectFile) $ + die' verbosity $ + "--project-file must only be used with --v2-freeze-file." + + sourcePkgDb <- IndexUtils.getSourcePackages verbosity repoContext + (comp, platform, _progdb) <- configCompilerAux' configFlags + deps <- if freezeFile + then depsFromFreezeFile verbosity + else if newFreezeFile + then do + httpTransport <- configureTransport verbosity + (fromNubList . globalProgPathExtra $ globalFlags) + (flagToMaybe . globalHttpTransport $ globalFlags) + depsFromNewFreezeFile verbosity httpTransport comp platform mprojectFile + else do + depsFromPkgDesc verbosity comp platform + debug verbosity $ "Dependencies loaded: " + ++ intercalate ", " (map prettyShow deps) + let outdatedDeps = listOutdated deps sourcePkgDb + (ListOutdatedSettings ignorePred minorPred) + when (not quiet) $ + showResult verbosity outdatedDeps simpleOutput + if exitCode && (not . null $ outdatedDeps) + then exitFailure + else return () + where + verbosity = if quiet + then silent + else fromFlagOrDefault normal outdatedVerbosity + freezeFile = fromFlagOrDefault False outdatedFreezeFile + newFreezeFile = fromFlagOrDefault False outdatedNewFreezeFile + mprojectFile = flagToMaybe flagProjectFileName + simpleOutput = fromFlagOrDefault False outdatedSimpleOutput + quiet = fromFlagOrDefault False outdatedQuiet + exitCode = fromFlagOrDefault quiet outdatedExitCode + ignorePred = let ignoreSet = S.fromList outdatedIgnore + in \pkgname -> pkgname `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 + + +-- | Print either the list of all outdated dependencies, or a message +-- that there are none. +showResult :: Verbosity -> [(PackageVersionConstraint,Version)] -> Bool -> IO () +showResult verbosity outdatedDeps simpleOutput = + if not . null $ outdatedDeps + then + do when (not simpleOutput) $ + notice verbosity "Outdated dependencies:" + for_ outdatedDeps $ \(d@(PackageVersionConstraint pn _), v) -> + let outdatedDep = if simpleOutput then prettyShow pn + else prettyShow d ++ " (latest: " ++ prettyShow v ++ ")" + in notice verbosity outdatedDep + else notice verbosity "All dependencies are up to date." + +-- | Convert a list of 'UserConstraint's to a 'Dependency' list. +userConstraintsToDependencies :: [UserConstraint] -> [PackageVersionConstraint] +userConstraintsToDependencies ucnstrs = + mapMaybe (packageConstraintToDependency . userToPackageConstraint) ucnstrs + +-- | Read the list of dependencies from the freeze file. +depsFromFreezeFile :: Verbosity -> IO [PackageVersionConstraint] +depsFromFreezeFile verbosity = do + cwd <- getCurrentDirectory + userConfig <- loadUserConfig verbosity cwd Nothing + let ucnstrs = map fst . configExConstraints . savedConfigureExFlags $ + userConfig + deps = userConstraintsToDependencies ucnstrs + debug verbosity "Reading the list of dependencies from the freeze file" + return deps + +-- | Read the list of dependencies from the new-style freeze file. +depsFromNewFreezeFile :: Verbosity -> HttpTransport -> Compiler -> Platform -> Maybe FilePath -> IO [PackageVersionConstraint] +depsFromNewFreezeFile verbosity httpTransport compiler (Platform arch os) mprojectFile = do + projectRoot <- either throwIO return =<< + findProjectRoot Nothing mprojectFile + let distDirLayout = defaultDistDirLayout projectRoot + {- TODO: Support dist dir override -} Nothing + projectConfig <- runRebuild (distProjectRootDirectory distDirLayout) $ do + pcs <- readProjectLocalFreezeConfig verbosity httpTransport distDirLayout + pure $ instantiateProjectConfigSkeleton os arch (compilerInfo compiler) mempty pcs + let ucnstrs = map fst . projectConfigConstraints . projectConfigShared + $ projectConfig + deps = userConstraintsToDependencies ucnstrs + freezeFile = distProjectFile distDirLayout "freeze" + freezeFileExists <- doesFileExist freezeFile + + unless freezeFileExists $ + die' verbosity $ + "Couldn't find a freeze file expected at: " ++ freezeFile ++ "\n\n" + ++ "We are looking for this file because you supplied '--project-file' or '--v2-freeze-file'. " + ++ "When one of these flags is given, we try to read the dependencies from a freeze file. " + ++ "If it is undesired behaviour, you should not use these flags, otherwise please generate " + ++ "a freeze file via 'cabal freeze'." + debug verbosity $ + "Reading the list of dependencies from the new-style freeze file " ++ freezeFile + return deps + +-- | Read the list of dependencies from the package description. +depsFromPkgDesc :: Verbosity -> Compiler -> Platform -> IO [PackageVersionConstraint] +depsFromPkgDesc verbosity comp platform = do + cwd <- getCurrentDirectory + path <- tryFindPackageDesc verbosity cwd + gpd <- readGenericPackageDescription verbosity path + let cinfo = compilerInfo comp + epd = finalizePD mempty (ComponentRequestedSpec True True) + (const True) platform cinfo [] gpd + case epd of + Left _ -> die' verbosity "finalizePD failed" + Right (pd, _) -> do + let bd = allBuildDepends pd + debug verbosity + "Reading the list of dependencies from the package description" + return $ map toPVC bd + where + toPVC (Dependency pn vr _) = PackageVersionConstraint pn vr + +-- | Various knobs for customising the behaviour of 'listOutdated'. +data ListOutdatedSettings = ListOutdatedSettings + { -- | Should this package be ignored? + listOutdatedIgnorePred :: PackageName -> Bool + , -- | Should major version bumps be ignored for this package? + listOutdatedMinorPred :: PackageName -> Bool + } + +-- | Find all outdated dependencies. +listOutdated :: [PackageVersionConstraint] + -> SourcePackageDb + -> ListOutdatedSettings + -> [(PackageVersionConstraint, Version)] +listOutdated deps sourceDb (ListOutdatedSettings ignorePred minorPred) = + mapMaybe isOutdated $ map simplifyPackageVersionConstraint deps + where + isOutdated :: PackageVersionConstraint -> Maybe (PackageVersionConstraint, Version) + isOutdated dep@(PackageVersionConstraint pname vr) + | ignorePred pname = Nothing + | otherwise = + let this = map packageVersion $ SourcePackageDb.lookupDependency sourceDb pname vr + latest = lookupLatest dep + in (\v -> (dep, v)) `fmap` isOutdated' this latest + + isOutdated' :: [Version] -> [Version] -> Maybe Version + isOutdated' [] _ = Nothing + isOutdated' _ [] = Nothing + isOutdated' this latest = + let this' = maximum this + latest' = maximum latest + in if this' < latest' then Just latest' else Nothing + + lookupLatest :: PackageVersionConstraint -> [Version] + lookupLatest (PackageVersionConstraint pname vr) + | minorPred pname = + map packageVersion $ SourcePackageDb.lookupDependency sourceDb pname (relaxMinor vr) + | otherwise = + map packageVersion $ SourcePackageDb.lookupPackageName sourceDb pname + + relaxMinor :: VersionRange -> VersionRange + relaxMinor vr = + let vis = asVersionIntervals vr + in maybe vr relax (safeLast vis) + where relax (VersionInterval (LowerBound v0 _) upper) = + case upper of + NoUpperBound -> vr + UpperBound _v1 _ -> majorBoundVersion v0 diff --git a/cabal/cabal-install/src/Distribution/Client/CmdRepl.hs b/cabal/cabal-install/src/Distribution/Client/CmdRepl.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/CmdRepl.hs @@ -0,0 +1,545 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +-- | cabal-install CLI command: repl +-- +module Distribution.Client.CmdRepl ( + -- * The @repl@ CLI and action + replCommand, + replAction, + + -- * Internals exposed for testing + matchesMultipleProblem, + selectPackageTargets, + selectComponentTarget + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Distribution.Compat.Lens +import qualified Distribution.Types.Lens as L + +import Distribution.Client.DistDirLayout + ( DistDirLayout(..) ) +import Distribution.Client.NixStyleOptions + ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) +import Distribution.Client.CmdErrorMessages + ( renderTargetSelector, showTargetSelector, + renderTargetProblem, + targetSelectorRefersToPkgs, + renderComponentKind, renderListCommaAnd, renderListSemiAnd, + componentKind, sortGroupOn, Plural(..) ) +import Distribution.Client.TargetProblem + ( TargetProblem(..) ) +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.ProjectBuilding + ( rebuildTargetsDryRun, improveInstallPlanWithUpToDatePackages ) +import Distribution.Client.ProjectOrchestration +import Distribution.Client.ProjectPlanning + ( ElaboratedSharedConfig(..), ElaboratedInstallPlan ) +import Distribution.Client.ProjectPlanning.Types + ( elabOrderExeDependencies ) +import Distribution.Client.ScriptUtils + ( AcceptNoTargets(..), withContextAndSelectors, TargetContext(..) + , updateContextAndWriteProjectFile, updateContextAndWriteProjectFile' + , fakeProjectSourcePackage, lSrcpkgDescription ) +import Distribution.Client.Setup + ( GlobalFlags, ConfigFlags(..) ) +import qualified Distribution.Client.Setup as Client +import Distribution.Client.Types + ( PackageSpecifier(..), UnresolvedSourcePackage ) +import Distribution.Simple.Setup + ( fromFlagOrDefault, ReplOptions(..), replOptions + , Flag(..), toFlag, falseArg ) +import Distribution.Simple.Command + ( CommandUI(..), liftOptionL, usageAlternatives, option + , ShowOrParseArgs, OptionField, reqArg ) +import Distribution.Compiler + ( CompilerFlavor(GHC) ) +import Distribution.Simple.Compiler + ( Compiler, compilerCompatVersion ) +import Distribution.Package + ( Package(..), packageName, UnitId, installedUnitId ) +import Distribution.Parsec + ( parsecCommaList ) +import Distribution.ReadE + ( ReadE, parsecToReadE ) +import Distribution.Solver.Types.SourcePackage + ( SourcePackage(..) ) +import Distribution.Types.BuildInfo + ( BuildInfo(..), emptyBuildInfo ) +import Distribution.Types.ComponentName + ( componentNameString ) +import Distribution.Types.CondTree + ( CondTree(..), traverseCondTreeC ) +import Distribution.Types.Dependency + ( Dependency(..), mainLibSet ) +import Distribution.Types.Library + ( Library(..), emptyLibrary ) +import Distribution.Types.Version + ( Version, mkVersion ) +import Distribution.Types.VersionRange + ( anyVersion ) +import Distribution.Utils.Generic + ( safeHead ) +import Distribution.Verbosity + ( normal, lessVerbose ) +import Distribution.Simple.Utils + ( wrapText, die', debugNoWrap ) +import Language.Haskell.Extension + ( Language(..) ) + +import Data.List + ( (\\) ) +import qualified Data.Map as Map +import qualified Data.Set as Set +import System.Directory + ( doesFileExist, getCurrentDirectory ) +import System.FilePath + ( () ) + +data EnvFlags = EnvFlags + { envPackages :: [Dependency] + , envIncludeTransitive :: Flag Bool + } + +defaultEnvFlags :: EnvFlags +defaultEnvFlags = EnvFlags + { envPackages = [] + , envIncludeTransitive = toFlag True + } + +envOptions :: ShowOrParseArgs -> [OptionField EnvFlags] +envOptions _ = + [ option ['b'] ["build-depends"] + "Include additional packages in the environment presented to GHCi." + envPackages (\p flags -> flags { envPackages = p ++ envPackages flags }) + (reqArg "DEPENDENCIES" dependenciesReadE (fmap prettyShow :: [Dependency] -> [String])) + , option [] ["no-transitive-deps"] + "Don't automatically include transitive dependencies of requested packages." + envIncludeTransitive (\p flags -> flags { envIncludeTransitive = p }) + falseArg + ] + where + dependenciesReadE :: ReadE [Dependency] + dependenciesReadE = + parsecToReadE + ("couldn't parse dependencies: " ++) + (parsecCommaList parsec) + +replCommand :: CommandUI (NixStyleFlags (ReplOptions, EnvFlags)) +replCommand = Client.installCommand { + commandName = "v2-repl", + commandSynopsis = "Open an interactive session for the given component.", + commandUsage = usageAlternatives "v2-repl" [ "[TARGET] [FLAGS]" ], + commandDescription = Just $ \_ -> wrapText $ + "Open an interactive session for a component within the project. The " + ++ "available targets are the same as for the 'v2-build' command: " + ++ "individual components within packages in the project, including " + ++ "libraries, executables, test-suites or benchmarks. Packages can " + ++ "also be specified in which case the library component in the " + ++ "package will be used, or the (first listed) executable in the " + ++ "package if there is no library.\n\n" + + ++ "Dependencies are built or rebuilt as necessary. Additional " + ++ "configuration flags can be specified on the command line and these " + ++ "extend the project configuration from the 'cabal.project', " + ++ "'cabal.project.local' and other files.", + commandNotes = Just $ \pname -> + "Examples, open an interactive session:\n" + ++ " " ++ pname ++ " v2-repl\n" + ++ " for the default component in the package in the current directory\n" + ++ " " ++ pname ++ " v2-repl pkgname\n" + ++ " for the default component in the package named 'pkgname'\n" + ++ " " ++ pname ++ " v2-repl ./pkgfoo\n" + ++ " for the default component in the package in the ./pkgfoo directory\n" + ++ " " ++ pname ++ " v2-repl cname\n" + ++ " for the component named 'cname'\n" + ++ " " ++ pname ++ " v2-repl pkgname:cname\n" + ++ " for the component 'cname' in the package 'pkgname'\n\n" + ++ " " ++ pname ++ " v2-repl --build-depends lens\n" + ++ " add the latest version of the library 'lens' to the default component " + ++ "(or no componentif there is no project present)\n" + ++ " " ++ pname ++ " v2-repl --build-depends \"lens >= 4.15 && < 4.18\"\n" + ++ " add a version (constrained between 4.15 and 4.18) of the library 'lens' " + ++ "to the default component (or no component if there is no project present)\n", + + commandDefaultFlags = defaultNixStyleFlags (mempty, defaultEnvFlags), + commandOptions = nixStyleOptions $ \showOrParseArgs -> + map (liftOptionL _1) (replOptions showOrParseArgs) ++ + map (liftOptionL _2) (envOptions showOrParseArgs) + } + +-- | The @repl@ command is very much like @build@. It brings the install plan +-- up to date, selects that part of the plan needed by the given or implicit +-- repl target and then executes the plan. +-- +-- Compared to @build@ the difference is that only one target is allowed +-- (given or implicit) and the target type is repl rather than build. The +-- general plan execution infrastructure handles both build and repl targets. +-- +-- For more details on how this works, see the module +-- "Distribution.Client.ProjectOrchestration" +-- +replAction :: NixStyleFlags (ReplOptions, EnvFlags) -> [String] -> GlobalFlags -> IO () +replAction flags@NixStyleFlags { extraFlags = (replOpts, envFlags), ..} targetStrings globalFlags + = withContextAndSelectors AcceptNoTargets (Just LibKind) flags targetStrings globalFlags $ \targetCtx ctx targetSelectors -> do + when (buildSettingOnlyDeps (buildSettings ctx)) $ + die' verbosity $ "The repl command does not support '--only-dependencies'. " + ++ "You may wish to use 'build --only-dependencies' and then " + ++ "use 'repl'." + + let projectRoot = distProjectRootDirectory $ distDirLayout ctx + + baseCtx <- case targetCtx of + ProjectContext -> return ctx + GlobalContext -> do + unless (null targetStrings) $ + die' verbosity $ "'repl' takes no arguments or a script argument outside a project: " ++ unwords targetStrings + + let + sourcePackage = fakeProjectSourcePackage projectRoot + & lSrcpkgDescription . L.condLibrary + .~ Just (CondNode library [baseDep] []) + library = emptyLibrary { libBuildInfo = lBuildInfo } + lBuildInfo = emptyBuildInfo + { targetBuildDepends = [baseDep] + , defaultLanguage = Just Haskell2010 + } + baseDep = Dependency "base" anyVersion mainLibSet + + updateContextAndWriteProjectFile' ctx sourcePackage + ScriptContext scriptPath scriptExecutable -> do + unless (length targetStrings == 1) $ + die' verbosity $ "'repl' takes a single argument which should be a script: " ++ unwords targetStrings + existsScriptPath <- doesFileExist scriptPath + unless existsScriptPath $ + die' verbosity $ "'repl' takes a single argument which should be a script: " ++ unwords targetStrings + + updateContextAndWriteProjectFile ctx scriptPath scriptExecutable + + (originalComponent, baseCtx') <- if null (envPackages envFlags) + then return (Nothing, baseCtx) + else + -- Unfortunately, the best way to do this is to let the normal solver + -- help us resolve the targets, but that isn't ideal for performance, + -- especially in the no-project case. + withInstallPlan (lessVerbose verbosity) baseCtx $ \elaboratedPlan _ -> do + -- targets should be non-empty map, but there's no NonEmptyMap yet. + targets <- validatedTargets 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 = fromMaybe (error $ "cannot find " ++ prettyShow unitId) $ packageId <$> InstallPlan.lookup elaboratedPlan unitId + baseCtx' = addDepsToProjectTarget (envPackages envFlags) pkgId baseCtx + + return (Just oci, baseCtx') + + -- Now, we run the solver again with the added packages. While the graph + -- won't actually reflect the addition of transitive dependencies, + -- they're going to be available already and will be offered to the REPL + -- and that's good enough. + -- + -- In addition, to avoid a *third* trip through the solver, we are + -- replicating the second half of 'runProjectPreBuildPhase' by hand + -- here. + (buildCtx, compiler, replOpts') <- withInstallPlan verbosity baseCtx' $ + \elaboratedPlan elaboratedShared' -> do + let ProjectBaseContext{..} = baseCtx' + + -- Recalculate with updated project. + targets <- validatedTargets elaboratedPlan targetSelectors + + let + elaboratedPlan' = pruneInstallPlanToTargets + TargetActionRepl + targets + elaboratedPlan + includeTransitive = fromFlagOrDefault True (envIncludeTransitive envFlags) + + pkgsBuildStatus <- rebuildTargetsDryRun distDirLayout elaboratedShared' + elaboratedPlan' + + let elaboratedPlan'' = improveInstallPlanWithUpToDatePackages + pkgsBuildStatus elaboratedPlan' + debugNoWrap verbosity (InstallPlan.showInstallPlan elaboratedPlan'') + + let + buildCtx = ProjectBuildContext + { elaboratedPlanOriginal = elaboratedPlan + , elaboratedPlanToExecute = elaboratedPlan'' + , elaboratedShared = elaboratedShared' + , pkgsBuildStatus + , targetsMap = targets + } + + ElaboratedSharedConfig { pkgConfigCompiler = compiler } = elaboratedShared' + + replFlags = case originalComponent of + Just oci -> generateReplFlags includeTransitive elaboratedPlan' oci + Nothing -> [] + + return (buildCtx, compiler, replOpts & lReplOptionsFlags %~ (++ replFlags)) + + replOpts'' <- case targetCtx of + ProjectContext -> return replOpts' + _ -> usingGhciScript compiler projectRoot replOpts' + + let buildCtx' = buildCtx & lElaboratedShared . lPkgConfigReplOptions .~ replOpts'' + printPlan verbosity baseCtx' buildCtx' + + buildOutcomes <- runProjectBuildPhase verbosity baseCtx' buildCtx' + runProjectPostBuildPhase verbosity baseCtx' buildCtx' buildOutcomes + where + verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + + validatedTargets elaboratedPlan targetSelectors = do + -- Interpret the targets on the command line as repl targets + -- (as opposed to say build or haddock targets). + targets <- either (reportTargetProblems verbosity) return + $ resolveTargets + selectPackageTargets + selectComponentTarget + elaboratedPlan + Nothing + targetSelectors + + -- 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) $ + reportTargetProblems verbosity + [multipleTargetsProblem targets] + + return targets + +data OriginalComponentInfo = OriginalComponentInfo + { ociUnitId :: UnitId + , ociOriginalDeps :: [UnitId] + } + deriving (Show) + +addDepsToProjectTarget :: [Dependency] + -> PackageId + -> ProjectBaseContext + -> ProjectBaseContext +addDepsToProjectTarget deps pkgId ctx = + (\p -> ctx { localPackages = p }) . fmap addDeps . localPackages $ ctx + where + addDeps :: PackageSpecifier UnresolvedSourcePackage + -> PackageSpecifier UnresolvedSourcePackage + addDeps (SpecificSourcePackage pkg) + | packageId pkg /= pkgId = SpecificSourcePackage pkg + | SourcePackage{..} <- pkg = + SpecificSourcePackage $ pkg { srcpkgDescription = + srcpkgDescription & (\f -> L.allCondTrees $ traverseCondTreeC f) + %~ (deps ++) + } + addDeps spec = spec + +generateReplFlags :: Bool -> ElaboratedInstallPlan -> OriginalComponentInfo -> [String] +generateReplFlags includeTransitive elaboratedPlan OriginalComponentInfo{..} = flags + where + exeDeps :: [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' = deps \\ ociOriginalDeps + trans = installedUnitId <$> InstallPlan.dependencyClosure elaboratedPlan deps' + trans' = trans \\ ociOriginalDeps + flags = fmap (("-package-id " ++) . prettyShow) . (\\ exeDeps) + $ if includeTransitive then trans' else deps' + +-- | Add repl options to ensure the repl actually starts in the current working directory. +-- +-- In a global or script context, when we are using a fake package, @cabal repl@ +-- starts in the fake package directory instead of the directory it was called from, +-- 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] + +-- | This defines what a 'TargetSelector' means for the @repl@ command. +-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, +-- or otherwise classifies the problem. +-- +-- For repl we select: +-- +-- * the library if there is only one and it's buildable; or +-- +-- * the exe if there is only one and it's buildable; or +-- +-- * any other buildable component. +-- +-- Fail if there are no buildable lib\/exe components, or if there are +-- multiple libs or exes. +-- +selectPackageTargets :: TargetSelector + -> [AvailableTarget k] -> Either ReplTargetProblem [k] +selectPackageTargets targetSelector targets + + -- If there is exactly one buildable library then we select that + | [target] <- targetsLibsBuildable + = Right [target] + + -- but fail if there are multiple buildable libraries. + | not (null targetsLibsBuildable) + = Left (matchesMultipleProblem targetSelector targetsLibsBuildable') + + -- If there is exactly one buildable executable then we select that + | [target] <- targetsExesBuildable + = Right [target] + + -- but fail if there are multiple buildable executables. + | not (null targetsExesBuildable) + = Left (matchesMultipleProblem targetSelector targetsExesBuildable') + + -- If there is exactly one other target then we select that + | [target] <- targetsBuildable + = Right [target] + + -- but fail if there are multiple such targets + | not (null targetsBuildable) + = Left (matchesMultipleProblem targetSelector targetsBuildable') + + -- If there are targets but none are buildable then we report those + | not (null targets) + = Left (TargetProblemNoneEnabled targetSelector targets') + + -- If there are no targets at all then we report that + | otherwise + = Left (TargetProblemNoTargets targetSelector) + where + targets' = forgetTargetsDetail targets + (targetsLibsBuildable, + targetsLibsBuildable') = selectBuildableTargets' + . filterTargetsKind LibKind + $ targets + (targetsExesBuildable, + targetsExesBuildable') = selectBuildableTargets' + . filterTargetsKind ExeKind + $ targets + (targetsBuildable, + targetsBuildable') = selectBuildableTargetsWith' + (isRequested targetSelector) targets + + -- When there's a target filter like "pkg:tests" then we do select tests, + -- but if it's just a target like "pkg" then we don't build tests unless + -- they are requested by default (i.e. by using --enable-tests) + isRequested (TargetAllPackages Nothing) TargetNotRequestedByDefault = False + isRequested (TargetPackage _ _ Nothing) TargetNotRequestedByDefault = False + isRequested _ _ = True + + +-- | For a 'TargetComponent' 'TargetSelector', check if the component can be +-- selected. +-- +-- For the @repl@ command we just need the basic checks on being buildable etc. +-- +selectComponentTarget :: SubComponentTarget + -> AvailableTarget k -> Either ReplTargetProblem k +selectComponentTarget = selectComponentTargetBasic + + +data ReplProblem + = TargetProblemMatchesMultiple TargetSelector [AvailableTarget ()] + + -- | Multiple 'TargetSelector's match multiple targets + | TargetProblemMultipleTargets TargetsMap + deriving (Eq, Show) + +-- | The various error conditions that can occur when matching a +-- 'TargetSelector' against 'AvailableTarget's for the @repl@ command. +-- +type ReplTargetProblem = TargetProblem ReplProblem + +matchesMultipleProblem + :: TargetSelector + -> [AvailableTarget ()] + -> ReplTargetProblem +matchesMultipleProblem targetSelector targetsExesBuildable = + CustomTargetProblem $ TargetProblemMatchesMultiple targetSelector targetsExesBuildable + +multipleTargetsProblem + :: TargetsMap + -> ReplTargetProblem +multipleTargetsProblem = CustomTargetProblem . TargetProblemMultipleTargets + +reportTargetProblems :: Verbosity -> [TargetProblem ReplProblem] -> IO a +reportTargetProblems verbosity = + die' verbosity . unlines . map renderReplTargetProblem + +renderReplTargetProblem :: TargetProblem ReplProblem -> String +renderReplTargetProblem = renderTargetProblem "open a repl for" renderReplProblem + +renderReplProblem :: ReplProblem -> String +renderReplProblem (TargetProblemMatchesMultiple targetSelector targets) = + "Cannot open a repl for multiple components at once. The target '" + ++ showTargetSelector targetSelector ++ "' refers to " + ++ renderTargetSelector targetSelector ++ " which " + ++ (if targetSelectorRefersToPkgs targetSelector then "includes " else "are ") + ++ renderListSemiAnd + [ "the " ++ renderComponentKind Plural ckind ++ " " ++ + renderListCommaAnd + [ maybe (prettyShow pkgname) prettyShow (componentNameString cname) + | t <- ts + , let cname = availableTargetComponentName t + pkgname = packageName (availableTargetPackageId t) + ] + | (ckind, ts) <- sortGroupOn availableTargetComponentKind targets + ] + ++ ".\n\n" ++ explanationSingleComponentLimitation + where + availableTargetComponentKind = componentKind + . availableTargetComponentName + +renderReplProblem (TargetProblemMultipleTargets selectorMap) = + "Cannot open a repl for multiple components at once. The targets " + ++ renderListCommaAnd + [ "'" ++ showTargetSelector ts ++ "'" + | ts <- uniqueTargetSelectors selectorMap ] + ++ " refer to different components." + ++ ".\n\n" ++ explanationSingleComponentLimitation + +explanationSingleComponentLimitation :: String +explanationSingleComponentLimitation = + "The reason for this limitation is that current versions of ghci do not " + ++ "support loading multiple components as source. Load just one component " + ++ "and when you make changes to a dependent component then quit and reload." + +-- Lenses +lElaboratedShared :: Lens' ProjectBuildContext ElaboratedSharedConfig +lElaboratedShared f s = fmap (\x -> s { elaboratedShared = x }) (f (elaboratedShared s)) +{-# inline lElaboratedShared #-} + +lPkgConfigReplOptions :: Lens' ElaboratedSharedConfig ReplOptions +lPkgConfigReplOptions f s = fmap (\x -> s { pkgConfigReplOptions = x }) (f (pkgConfigReplOptions s)) +{-# inline lPkgConfigReplOptions #-} + +lReplOptionsFlags :: Lens' ReplOptions [String] +lReplOptionsFlags f s = fmap (\x -> s { replOptionsFlags = x }) (f (replOptionsFlags s)) +{-# inline lReplOptionsFlags #-} diff --git a/cabal/cabal-install/src/Distribution/Client/CmdRun.hs b/cabal/cabal-install/src/Distribution/Client/CmdRun.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/CmdRun.hs @@ -0,0 +1,463 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +-- | cabal-install CLI command: run +-- +module Distribution.Client.CmdRun ( + -- * The @run@ CLI and action + runCommand, + runAction, + handleShebang, validScript, + + -- * Internals exposed for testing + matchesMultipleProblem, + noExesProblem, + selectPackageTargets, + selectComponentTarget + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude hiding (toList) + +import Distribution.Client.ProjectOrchestration +import Distribution.Client.CmdErrorMessages + ( renderTargetSelector, showTargetSelector, + renderTargetProblem, + renderTargetProblemNoTargets, plural, targetSelectorPluralPkgs, + targetSelectorFilter, renderListCommaAnd ) +import Distribution.Client.TargetProblem + ( TargetProblem (..) ) + +import Distribution.Client.NixStyleOptions + ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) +import Distribution.Client.Setup + ( GlobalFlags(..), ConfigFlags(..) ) +import Distribution.Client.GlobalFlags + ( defaultGlobalFlags ) +import Distribution.Simple.Flag + ( fromFlagOrDefault ) +import Distribution.Simple.Command + ( CommandUI(..), usageAlternatives ) +import Distribution.Types.ComponentName + ( showComponentName ) +import Distribution.Verbosity + ( normal, silent ) +import Distribution.Simple.Utils + ( wrapText, die', info, notice ) +import Distribution.Client.ProjectPlanning + ( ElaboratedConfiguredPackage(..) + , ElaboratedInstallPlan, binDirectoryFor ) +import Distribution.Client.ProjectPlanning.Types + ( dataDirsEnvironmentForPlan ) +import Distribution.Client.InstallPlan + ( toList, foldPlanPackage ) +import Distribution.Types.UnqualComponentName + ( UnqualComponentName, unUnqualComponentName ) +import Distribution.Simple.Program.Run + ( runProgramInvocation, ProgramInvocation(..), + emptyProgramInvocation ) +import Distribution.Types.UnitId + ( UnitId ) +import Distribution.Client.ScriptUtils + ( AcceptNoTargets(..), withContextAndSelectors, updateContextAndWriteProjectFile, TargetContext(..) ) + +import qualified Data.Set as Set +import System.Directory + ( doesFileExist ) +import System.FilePath + ( (), isValid, isPathSeparator ) + +runCommand :: CommandUI (NixStyleFlags ()) +runCommand = CommandUI + { commandName = "v2-run" + , commandSynopsis = "Run an executable." + , commandUsage = usageAlternatives "v2-run" + [ "[TARGET] [FLAGS] [-- EXECUTABLE_FLAGS]" ] + , commandDescription = Just $ \pname -> wrapText $ + "Runs the specified executable-like component (an executable, a test, " + ++ "or a benchmark), first ensuring it is up to date.\n\n" + + ++ "Any executable-like component in any package in the project can be " + ++ "specified. A package can be specified if contains just one " + ++ "executable-like, preferring a single executable. The default is to " + ++ "use the package in the current directory if it contains just one " + ++ "executable-like.\n\n" + + ++ "Extra arguments can be passed to the program, but use '--' to " + ++ "separate arguments for the program from arguments for " ++ pname + ++ ". The executable is run in an environment where it can find its " + ++ "data files inplace in the build tree.\n\n" + + ++ "Dependencies are built or rebuilt as necessary. Additional " + ++ "configuration flags can be specified on the command line and these " + ++ "extend the project configuration from the 'cabal.project', " + ++ "'cabal.project.local' and other files." + , commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " v2-run\n" + ++ " Run the executable-like in the package in the current directory\n" + ++ " " ++ pname ++ " v2-run foo-tool\n" + ++ " Run the named executable-like (in any package in the project)\n" + ++ " " ++ pname ++ " v2-run pkgfoo:foo-tool\n" + ++ " Run the executable-like 'foo-tool' in the package 'pkgfoo'\n" + ++ " " ++ pname ++ " v2-run foo -O2 -- dothing --fooflag\n" + ++ " Build with '-O2' and run the program, passing it extra arguments.\n" + + , commandDefaultFlags = defaultNixStyleFlags () + , commandOptions = nixStyleOptions (const []) + } + +-- | The @run@ command runs a specified executable-like component, building it +-- first if necessary. The component can be either an executable, a test, +-- or a benchmark. This is particularly useful for passing arguments to +-- exes/tests/benchs by simply appending them after a @--@. +-- +-- For more details on how this works, see the module +-- "Distribution.Client.ProjectOrchestration" +-- +runAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO () +runAction flags@NixStyleFlags {..} targetAndArgs globalFlags + = withContextAndSelectors RejectNoTargets (Just ExeKind) flags targetStr globalFlags $ \targetCtx ctx targetSelectors -> do + (baseCtx, defaultVerbosity) <- case targetCtx of + ProjectContext -> return (ctx, normal) + GlobalContext -> return (ctx, normal) + ScriptContext path exemeta -> (, silent) <$> updateContextAndWriteProjectFile ctx path exemeta + + let verbosity = fromFlagOrDefault defaultVerbosity (configVerbosity configFlags) + + buildCtx <- + runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do + + when (buildSettingOnlyDeps (buildSettings baseCtx)) $ + die' verbosity $ + "The run command does not support '--only-dependencies'. " + ++ "You may wish to use 'build --only-dependencies' and then " + ++ "use 'run'." + + -- Interpret the targets on the command line as build targets + -- (as opposed to say repl or haddock targets). + targets <- either (reportTargetProblems verbosity) return + $ resolveTargets + selectPackageTargets + selectComponentTarget + elaboratedPlan + Nothing + targetSelectors + + -- 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. + -- + -- Note that we discard the target and return the whole 'TargetsMap', + -- so this check will be repeated (and must succeed) after + -- the 'runProjectPreBuildPhase'. Keep it in mind when modifying this. + _ <- singleExeOrElse + (reportTargetProblems + verbosity + [multipleTargetsProblem targets]) + targets + + let elaboratedPlan' = pruneInstallPlanToTargets + TargetActionBuild + targets + elaboratedPlan + return (elaboratedPlan', targets) + + (selectedUnitId, selectedComponent) <- + -- Slight duplication with 'runProjectPreBuildPhase'. + singleExeOrElse + (die' verbosity $ "No or multiple targets given, but the run " + ++ "phase has been reached. This is a bug.") + $ targetsMap buildCtx + + printPlan verbosity baseCtx buildCtx + + buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx + runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes + + + let elaboratedPlan = elaboratedPlanToExecute buildCtx + matchingElaboratedConfiguredPackages = + matchingPackagesByUnitId + selectedUnitId + elaboratedPlan + + let exeName = unUnqualComponentName selectedComponent + + -- In the common case, we expect @matchingElaboratedConfiguredPackages@ + -- to consist of a single element that provides a single way of building + -- an appropriately-named executable. In that case we take that + -- package and continue. + -- + -- However, multiple packages/components could provide that + -- executable, or it's possible we don't find the executable anywhere + -- in the build plan. I suppose in principle it's also possible that + -- a single package provides an executable in two different ways, + -- though that's probably a bug if. Anyway it's a good lint to report + -- an error in all of these cases, even if some seem like they + -- shouldn't happen. + pkg <- case matchingElaboratedConfiguredPackages of + [] -> die' verbosity $ "Unknown executable " + ++ exeName + ++ " in package " + ++ prettyShow selectedUnitId + [elabPkg] -> do + info verbosity $ "Selecting " + ++ prettyShow selectedUnitId + ++ " to supply " ++ exeName + return elabPkg + elabPkgs -> die' verbosity + $ "Multiple matching executables found matching " + ++ exeName + ++ ":\n" + ++ unlines (fmap (\p -> " - in package " ++ prettyShow (elabUnitId p)) elabPkgs) + let exePath = binDirectoryFor (distDirLayout baseCtx) + (elaboratedShared buildCtx) + pkg + exeName + exeName + let dryRun = buildSettingDryRun (buildSettings baseCtx) + || buildSettingOnlyDownload (buildSettings baseCtx) + + if dryRun + then notice verbosity "Running of executable suppressed by flag(s)" + else + runProgramInvocation + verbosity + emptyProgramInvocation { + progInvokePath = exePath, + progInvokeArgs = args, + progInvokeEnv = dataDirsEnvironmentForPlan + (distDirLayout baseCtx) + elaboratedPlan + } + where + (targetStr, args) = splitAt 1 targetAndArgs + +-- | Used by the main CLI parser as heuristic to decide whether @cabal@ was +-- invoked as a script interpreter, i.e. via +-- +-- > #! /usr/bin/env cabal +-- +-- or +-- +-- > #! /usr/bin/cabal +-- +-- As the first argument passed to `cabal` will be a filepath to the +-- script to be interpreted. +-- +-- See also 'handleShebang' +validScript :: String -> IO Bool +validScript script + | isValid script && any isPathSeparator script = doesFileExist script + | otherwise = return False + +-- | Handle @cabal@ invoked as script interpreter, see also 'validScript' +-- +-- First argument is the 'FilePath' to the script to be executed; second +-- argument is a list of arguments to be passed to the script. +handleShebang :: FilePath -> [String] -> IO () +handleShebang script args = + runAction (commandDefaultFlags runCommand) (script:args) defaultGlobalFlags + +singleExeOrElse :: IO (UnitId, UnqualComponentName) -> TargetsMap -> IO (UnitId, UnqualComponentName) +singleExeOrElse action targetsMap = + case Set.toList . distinctTargetComponents $ targetsMap + of [(unitId, CExeName component)] -> return (unitId, component) + [(unitId, CTestName component)] -> return (unitId, component) + [(unitId, CBenchName component)] -> return (unitId, component) + _ -> action + +-- | Filter the 'ElaboratedInstallPlan' keeping only the +-- 'ElaboratedConfiguredPackage's that match the specified +-- 'UnitId'. +matchingPackagesByUnitId :: UnitId + -> ElaboratedInstallPlan + -> [ElaboratedConfiguredPackage] +matchingPackagesByUnitId uid = + catMaybes + . fmap (foldPlanPackage + (const Nothing) + (\x -> if elabUnitId x == uid + then Just x + else Nothing)) + . toList + +-- | This defines what a 'TargetSelector' means for the @run@ command. +-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, +-- or otherwise classifies the problem. +-- +-- For the @run@ command we select the exe if there is only one and it's +-- buildable. Fail if there are no or multiple buildable exe components. +-- +selectPackageTargets :: TargetSelector + -> [AvailableTarget k] -> Either RunTargetProblem [k] +selectPackageTargets targetSelector targets + + -- If there is a single executable component, select that. See #7403 + | [target] <- targetsExesBuildable + = Right [target] + + -- Otherwise, if there is a single executable-like component left, select that. + | [target] <- targetsExeLikesBuildable + = Right [target] + + -- but fail if there are multiple buildable executables. + | not (null targetsExeLikesBuildable) + = Left (matchesMultipleProblem targetSelector targetsExeLikesBuildable') + + -- If there are executables but none are buildable then we report those + | not (null targetsExeLikes') + = Left (TargetProblemNoneEnabled targetSelector targetsExeLikes') + + -- If there are no executables but some other targets then we report that + | not (null targets) + = Left (noExesProblem targetSelector) + + -- If there are no targets at all then we report that + | otherwise + = Left (TargetProblemNoTargets targetSelector) + where + -- Targets that are precisely executables + targetsExes = filterTargetsKind ExeKind targets + targetsExesBuildable = selectBuildableTargets targetsExes + + -- Any target that could be executed + targetsExeLikes = targetsExes + ++ filterTargetsKind TestKind targets + ++ filterTargetsKind BenchKind targets + + (targetsExeLikesBuildable, + targetsExeLikesBuildable') = selectBuildableTargets' targetsExeLikes + + targetsExeLikes' = forgetTargetsDetail targetsExeLikes + + +-- | For a 'TargetComponent' 'TargetSelector', check if the component can be +-- selected. +-- +-- For the @run@ command we just need to check it is a executable-like +-- (an executable, a test, or a benchmark), in addition +-- to the basic checks on being buildable etc. +-- +selectComponentTarget :: SubComponentTarget + -> AvailableTarget k -> Either RunTargetProblem k +selectComponentTarget subtarget@WholeComponent t + = case availableTargetComponentName t + of CExeName _ -> component + CTestName _ -> component + CBenchName _ -> component + _ -> Left (componentNotExeProblem pkgid cname) + where pkgid = availableTargetPackageId t + cname = availableTargetComponentName t + component = selectComponentTargetBasic subtarget t + +selectComponentTarget subtarget t + = Left (isSubComponentProblem (availableTargetPackageId t) + (availableTargetComponentName t) + subtarget) + +-- | The various error conditions that can occur when matching a +-- 'TargetSelector' against 'AvailableTarget's for the @run@ command. +-- +data RunProblem = + -- | The 'TargetSelector' matches targets but no executables + TargetProblemNoExes TargetSelector + + -- | A single 'TargetSelector' matches multiple targets + | TargetProblemMatchesMultiple TargetSelector [AvailableTarget ()] + + -- | Multiple 'TargetSelector's match multiple targets + | TargetProblemMultipleTargets TargetsMap + + -- | 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 + | TargetProblemIsSubComponent PackageId ComponentName SubComponentTarget + deriving (Eq, Show) + +type RunTargetProblem = TargetProblem RunProblem + +noExesProblem :: TargetSelector -> RunTargetProblem +noExesProblem = CustomTargetProblem . TargetProblemNoExes + +matchesMultipleProblem :: TargetSelector -> [AvailableTarget ()] -> RunTargetProblem +matchesMultipleProblem selector targets = CustomTargetProblem $ + TargetProblemMatchesMultiple selector targets + +multipleTargetsProblem :: TargetsMap -> TargetProblem RunProblem +multipleTargetsProblem = CustomTargetProblem . TargetProblemMultipleTargets + +componentNotExeProblem :: PackageId -> ComponentName -> TargetProblem RunProblem +componentNotExeProblem pkgid name = CustomTargetProblem $ + TargetProblemComponentNotExe pkgid name + +isSubComponentProblem + :: PackageId + -> ComponentName + -> SubComponentTarget + -> TargetProblem RunProblem +isSubComponentProblem pkgid name subcomponent = CustomTargetProblem $ + TargetProblemIsSubComponent pkgid name subcomponent + +reportTargetProblems :: Verbosity -> [RunTargetProblem] -> IO a +reportTargetProblems verbosity = + die' verbosity . unlines . map renderRunTargetProblem + +renderRunTargetProblem :: RunTargetProblem -> String +renderRunTargetProblem (TargetProblemNoTargets targetSelector) = + case targetSelectorFilter targetSelector of + Just kind | kind /= ExeKind + -> "The run command is for running executables, but the target '" + ++ showTargetSelector targetSelector ++ "' refers to " + ++ renderTargetSelector targetSelector ++ "." + + _ -> renderTargetProblemNoTargets "run" targetSelector +renderRunTargetProblem problem = + renderTargetProblem "run" renderRunProblem problem + +renderRunProblem :: RunProblem -> String +renderRunProblem (TargetProblemMatchesMultiple targetSelector targets) = + "The run command is for running a single executable at once. The target '" + ++ showTargetSelector targetSelector ++ "' refers to " + ++ renderTargetSelector targetSelector ++ " which includes " + ++ renderListCommaAnd ( ("the "++) <$> + showComponentName <$> + availableTargetComponentName <$> + foldMap + (\kind -> filterTargetsKind kind targets) + [ExeKind, TestKind, BenchKind] ) + ++ "." + +renderRunProblem (TargetProblemMultipleTargets selectorMap) = + "The run command is for running a single executable at once. The targets " + ++ renderListCommaAnd [ "'" ++ showTargetSelector ts ++ "'" + | ts <- uniqueTargetSelectors selectorMap ] + ++ " refer to different executables." + +renderRunProblem (TargetProblemComponentNotExe pkgid cname) = + "The run command is for running executables, but the target '" + ++ showTargetSelector targetSelector ++ "' refers to " + ++ renderTargetSelector targetSelector ++ " from the package " + ++ prettyShow pkgid ++ "." + where + targetSelector = TargetComponent pkgid cname WholeComponent + +renderRunProblem (TargetProblemIsSubComponent pkgid cname subtarget) = + "The run command can only run an executable as a whole, " + ++ "not files or modules within them, but the target '" + ++ showTargetSelector targetSelector ++ "' refers to " + ++ renderTargetSelector targetSelector ++ "." + where + targetSelector = TargetComponent pkgid cname subtarget + +renderRunProblem (TargetProblemNoExes targetSelector) = + "Cannot run the target '" ++ showTargetSelector targetSelector + ++ "' which refers to " ++ renderTargetSelector targetSelector + ++ " because " + ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do" + ++ " not contain any executables." diff --git a/cabal/cabal-install/src/Distribution/Client/CmdSdist.hs b/cabal/cabal-install/src/Distribution/Client/CmdSdist.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/CmdSdist.hs @@ -0,0 +1,315 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} +module Distribution.Client.CmdSdist + ( sdistCommand, sdistAction, packageToSdist + , OutputFormat(..)) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Distribution.Client.CmdErrorMessages + ( Plural(..), renderComponentKind ) +import Distribution.Client.ProjectOrchestration + ( ProjectBaseContext(..), CurrentCommand(..), establishProjectBaseContext, establishProjectBaseContextWithRoot) +import Distribution.Client.NixStyleOptions + ( NixStyleFlags (..), defaultNixStyleFlags ) +import Distribution.Client.TargetSelector + ( TargetSelector(..), ComponentKind + , readTargetSelectors, reportTargetSelectorProblems ) +import Distribution.Client.Setup + ( GlobalFlags(..) ) +import Distribution.Solver.Types.SourcePackage + ( SourcePackage(..) ) +import Distribution.Client.Types + ( PackageSpecifier(..), PackageLocation(..), UnresolvedSourcePackage ) +import Distribution.Client.DistDirLayout + ( DistDirLayout(..), ProjectRoot (..) ) +import Distribution.Client.ProjectConfig + ( ProjectConfig, withProjectOrGlobalConfig, commandLineFlagsToProjectConfig, projectConfigConfigFile, projectConfigShared ) +import Distribution.Client.ProjectFlags + ( ProjectFlags (..), defaultProjectFlags, projectFlagsOptions ) + +import Distribution.Compat.Lens + ( _1, _2 ) +import Distribution.Package + ( Package(packageId) ) +import Distribution.PackageDescription.Configuration + ( flattenPackageDescription ) +import Distribution.ReadE + ( succeedReadE ) +import Distribution.Simple.Command + ( CommandUI(..), OptionField, option, reqArg, liftOptionL, ShowOrParseArgs ) +import Distribution.Simple.PreProcess + ( knownSuffixHandlers ) +import Distribution.Simple.Setup + ( Flag(..), toFlag, fromFlagOrDefault, flagToList, flagToMaybe + , optionVerbosity, optionDistPref, trueArg, configVerbosity, configDistPref + ) +import Distribution.Simple.SrcDist + ( listPackageSourcesWithDie ) +import Distribution.Client.SrcDist + ( packageDirToSdist ) +import Distribution.Simple.Utils + ( die', notice, withOutputMarker, wrapText ) +import Distribution.Types.ComponentName + ( ComponentName, showComponentName ) +import Distribution.Types.PackageName + ( PackageName, unPackageName ) +import Distribution.Verbosity + ( normal ) +import Distribution.Types.GenericPackageDescription (GenericPackageDescription) + +import qualified Data.ByteString.Lazy.Char8 as BSL +import System.Directory + ( getCurrentDirectory + , createDirectoryIfMissing, makeAbsolute + ) +import System.FilePath + ( (), (<.>), makeRelative, normalise ) + +------------------------------------------------------------------------------- +-- Command +------------------------------------------------------------------------------- + +sdistCommand :: CommandUI (ProjectFlags, SdistFlags) +sdistCommand = CommandUI + { commandName = "v2-sdist" + , commandSynopsis = "Generate a source distribution file (.tar.gz)." + , commandUsage = \pname -> + "Usage: " ++ pname ++ " v2-sdist [FLAGS] [PACKAGES]\n" + , commandDescription = Just $ \_ -> wrapText + "Generates tarballs of project packages suitable for upload to Hackage." + , commandNotes = Nothing + , commandDefaultFlags = (defaultProjectFlags, defaultSdistFlags) + , commandOptions = \showOrParseArgs -> + map (liftOptionL _1) (projectFlagsOptions showOrParseArgs) ++ + map (liftOptionL _2) (sdistOptions showOrParseArgs) + } + +------------------------------------------------------------------------------- +-- Flags +------------------------------------------------------------------------------- + +data SdistFlags = SdistFlags + { sdistVerbosity :: Flag Verbosity + , sdistDistDir :: Flag FilePath + , sdistListSources :: Flag Bool + , sdistNulSeparated :: Flag Bool + , sdistOutputPath :: Flag FilePath + } + +defaultSdistFlags :: SdistFlags +defaultSdistFlags = SdistFlags + { sdistVerbosity = toFlag normal + , sdistDistDir = mempty + , sdistListSources = toFlag False + , sdistNulSeparated = toFlag False + , sdistOutputPath = mempty + } + +sdistOptions :: ShowOrParseArgs -> [OptionField SdistFlags] +sdistOptions showOrParseArgs = + [ optionVerbosity + sdistVerbosity (\v flags -> flags { sdistVerbosity = v }) + , optionDistPref + sdistDistDir (\dd flags -> flags { sdistDistDir = dd }) + showOrParseArgs + , option ['l'] ["list-only"] + "Just list the sources, do not make a tarball" + sdistListSources (\v flags -> flags { sdistListSources = v }) + trueArg + , option [] ["null-sep"] + "Separate the source files with NUL bytes rather than newlines." + sdistNulSeparated (\v flags -> flags { sdistNulSeparated = v }) + trueArg + , option ['o'] ["output-directory", "outputdir"] + "Choose the output directory of this command. '-' sends all output to stdout" + sdistOutputPath (\o flags -> flags { sdistOutputPath = o }) + (reqArg "PATH" (succeedReadE Flag) flagToList) + ] + +------------------------------------------------------------------------------- +-- Action +------------------------------------------------------------------------------- + +sdistAction :: (ProjectFlags, SdistFlags) -> [String] -> GlobalFlags -> IO () +sdistAction (ProjectFlags{..}, SdistFlags{..}) targetStrings globalFlags = do + (baseCtx, distDirLayout) <- withProjectOrGlobalConfig verbosity flagIgnoreProject globalConfigFlag withProject withoutProject + + let localPkgs = localPackages baseCtx + + targetSelectors <- either (reportTargetSelectorProblems verbosity) return + =<< readTargetSelectors localPkgs Nothing targetStrings + + -- elaborate path, create target directory + mOutputPath' <- case mOutputPath of + Just "-" -> return (Just "-") + Just path -> do + abspath <- makeAbsolute path + createDirectoryIfMissing True abspath + return (Just abspath) + Nothing -> do + createDirectoryIfMissing True (distSdistDirectory distDirLayout) + return Nothing + + let format :: OutputFormat + format = + if | listSources, nulSeparated -> SourceList '\0' + | listSources -> SourceList '\n' + | otherwise -> TarGzArchive + + ext = case format of + SourceList _ -> "list" + TarGzArchive -> "tar.gz" + + outputPath pkg = case mOutputPath' of + Just path + | path == "-" -> "-" + | otherwise -> path prettyShow (packageId pkg) <.> ext + Nothing + | listSources -> "-" + | otherwise -> distSdistFile distDirLayout (packageId pkg) + + + case reifyTargetSelectors localPkgs targetSelectors of + Left errs -> die' verbosity . unlines . fmap renderTargetProblem $ errs + Right pkgs + | length pkgs > 1, not listSources, Just "-" <- mOutputPath' -> + die' verbosity "Can't write multiple tarballs to standard output!" + | otherwise -> + traverse_ (\pkg -> packageToSdist verbosity (distProjectRootDirectory distDirLayout) format (outputPath pkg) pkg) pkgs + where + verbosity = fromFlagOrDefault normal sdistVerbosity + listSources = fromFlagOrDefault False sdistListSources + nulSeparated = fromFlagOrDefault False sdistNulSeparated + mOutputPath = flagToMaybe sdistOutputPath + + prjConfig :: ProjectConfig + prjConfig = commandLineFlagsToProjectConfig + globalFlags + (defaultNixStyleFlags ()) + { configFlags = (configFlags $ defaultNixStyleFlags ()) + { configVerbosity = sdistVerbosity + , configDistPref = sdistDistDir + } + } + mempty + + globalConfigFlag = projectConfigConfigFile (projectConfigShared prjConfig) + + withProject :: IO (ProjectBaseContext, DistDirLayout) + withProject = do + baseCtx <- establishProjectBaseContext verbosity prjConfig OtherCommand + return (baseCtx, distDirLayout baseCtx) + + withoutProject :: ProjectConfig -> IO (ProjectBaseContext, DistDirLayout) + withoutProject config = do + cwd <- getCurrentDirectory + baseCtx <- establishProjectBaseContextWithRoot verbosity (config <> prjConfig) (ProjectRootImplicit cwd) OtherCommand + return (baseCtx, distDirLayout baseCtx) + +data OutputFormat = SourceList Char + | TarGzArchive + deriving (Show, Eq) + +packageToSdist :: Verbosity -> FilePath -> OutputFormat -> FilePath -> UnresolvedSourcePackage -> IO () +packageToSdist verbosity projectRootDir format outputFile pkg = do + let death = die' verbosity ("The impossible happened: a local package isn't local" <> (show pkg)) + dir0 <- case srcpkgSource pkg of + LocalUnpackedPackage path -> pure (Right path) + RemoteSourceRepoPackage _ (Just tgz) -> pure (Left tgz) + RemoteSourceRepoPackage {} -> death + LocalTarballPackage tgz -> pure (Left tgz) + RemoteTarballPackage _ (Just tgz) -> pure (Left tgz) + RemoteTarballPackage {} -> death + RepoTarballPackage {} -> death + + let -- Write String to stdout or file, using the default TextEncoding. + write str + | outputFile == "-" = putStr (withOutputMarker verbosity str) + | otherwise = do + writeFile outputFile str + notice verbosity $ "Wrote source list to " ++ outputFile ++ "\n" + -- Write raw ByteString to stdout or file as it is, without encoding. + writeLBS lbs + | outputFile == "-" = BSL.putStr lbs + | otherwise = do + BSL.writeFile outputFile lbs + notice verbosity $ "Wrote tarball sdist to " ++ outputFile ++ "\n" + + case dir0 of + Left tgz -> do + case format of + TarGzArchive -> do + writeLBS =<< BSL.readFile tgz + _ -> die' verbosity ("cannot convert tarball package to " ++ show format) + + Right dir -> case format of + SourceList nulSep -> do + let gpd :: GenericPackageDescription + gpd = srcpkgDescription pkg + + let thisDie :: Verbosity -> String -> IO a + thisDie v s = die' v $ "sdist of " <> prettyShow (packageId gpd) ++ ": " ++ s + + files' <- listPackageSourcesWithDie verbosity thisDie dir (flattenPackageDescription gpd) knownSuffixHandlers + let files = nub $ sort $ map normalise files' + let prefix = makeRelative projectRootDir dir + write $ concat [prefix i ++ [nulSep] | i <- files] + + TarGzArchive -> do + packageDirToSdist verbosity (srcpkgDescription pkg) dir >>= writeLBS + +-- + +reifyTargetSelectors :: [PackageSpecifier UnresolvedSourcePackage] -> [TargetSelector] -> Either [TargetProblem] [UnresolvedSourcePackage] +reifyTargetSelectors pkgs sels = + case partitionEithers (foldMap go sels) of + ([], sels') -> Right sels' + (errs, _) -> Left errs + where + -- there can be pkgs which are in extra-packages: + -- these are not SpecificSourcePackage + -- + -- Why these packages are in localPkgs, it's confusing. + -- Anyhow, better to be lenient here. + -- + flatten (SpecificSourcePackage pkg@SourcePackage{}) = Just pkg + flatten _ = Nothing + + pkgs' = mapMaybe flatten pkgs + + getPkg pid = case find ((== pid) . packageId) pkgs' of + Just pkg -> Right pkg + Nothing -> error "The impossible happened: we have a reference to a local package that isn't in localPackages." + + go :: TargetSelector -> [Either TargetProblem UnresolvedSourcePackage] + go (TargetPackage _ pids Nothing) = fmap getPkg pids + go (TargetAllPackages Nothing) = Right <$> pkgs' + + go (TargetPackage _ _ (Just kind)) = [Left (AllComponentsOnly kind)] + go (TargetAllPackages (Just kind)) = [Left (AllComponentsOnly kind)] + + go (TargetPackageNamed pname _) = [Left (NonlocalPackageNotAllowed pname)] + go (TargetComponentUnknown pname _ _) = [Left (NonlocalPackageNotAllowed pname)] + + go (TargetComponent _ cname _) = [Left (ComponentsNotAllowed cname)] + +data TargetProblem = AllComponentsOnly ComponentKind + | NonlocalPackageNotAllowed PackageName + | ComponentsNotAllowed ComponentName + +renderTargetProblem :: TargetProblem -> String +renderTargetProblem (AllComponentsOnly kind) = + "It is not possible to package only the " ++ renderComponentKind Plural kind ++ " from a package " + ++ "for distribution. Only entire packages may be packaged for distribution." +renderTargetProblem (ComponentsNotAllowed cname) = + "The component " ++ showComponentName cname ++ " cannot be packaged for distribution on its own. " + ++ "Only entire packages may be packaged for distribution." +renderTargetProblem (NonlocalPackageNotAllowed pname) = + "The package " ++ unPackageName pname ++ " cannot be packaged for distribution, because it is not " + ++ "local to this project." diff --git a/cabal/cabal-install/src/Distribution/Client/CmdTest.hs b/cabal/cabal-install/src/Distribution/Client/CmdTest.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/CmdTest.hs @@ -0,0 +1,283 @@ +{-# LANGUAGE RecordWildCards #-} + +-- | cabal-install CLI command: test +-- +module Distribution.Client.CmdTest ( + -- * The @test@ CLI and action + testCommand, + testAction, + + -- * Internals exposed for testing + isSubComponentProblem, + notTestProblem, + noTestsProblem, + selectPackageTargets, + selectComponentTarget + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Client.ProjectOrchestration +import Distribution.Client.CmdErrorMessages + ( renderTargetSelector, showTargetSelector, targetSelectorFilter, plural, + renderTargetProblem, + renderTargetProblemNoTargets, targetSelectorPluralPkgs ) +import Distribution.Client.TargetProblem + ( TargetProblem (..) ) +import Distribution.Client.NixStyleOptions + ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) +import Distribution.Client.Setup + ( GlobalFlags(..), ConfigFlags(..) ) +import Distribution.Simple.Setup + ( TestFlags(..), fromFlagOrDefault ) +import Distribution.Simple.Command + ( CommandUI(..), usageAlternatives ) +import Distribution.Simple.Flag + ( Flag(..) ) +import Distribution.Verbosity + ( normal ) +import Distribution.Simple.Utils + ( notice, wrapText, die' ) + +import qualified System.Exit (exitSuccess) + + +testCommand :: CommandUI (NixStyleFlags ()) +testCommand = CommandUI + { commandName = "v2-test" + , commandSynopsis = "Run test-suites." + , commandUsage = usageAlternatives "v2-test" [ "[TARGETS] [FLAGS]" ] + , commandDescription = Just $ \_ -> wrapText $ + "Runs the specified test-suites, first ensuring they are up to " + ++ "date.\n\n" + + ++ "Any test-suite in any package in the project can be specified. " + ++ "A package can be specified in which case all the test-suites in the " + ++ "package are run. The default is to run all the test-suites in the " + ++ "package in the current directory.\n\n" + + ++ "Dependencies are built or rebuilt as necessary. Additional " + ++ "configuration flags can be specified on the command line and these " + ++ "extend the project configuration from the 'cabal.project', " + ++ "'cabal.project.local' and other files.\n\n" + + ++ "To pass command-line arguments to a test suite, see the " + ++ "v2-run command." + , commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " v2-test\n" + ++ " Run all the test-suites in the package in the current directory\n" + ++ " " ++ pname ++ " v2-test pkgname\n" + ++ " Run all the test-suites in the package named pkgname\n" + ++ " " ++ pname ++ " v2-test cname\n" + ++ " Run the test-suite named cname\n" + ++ " " ++ pname ++ " v2-test cname --enable-coverage\n" + ++ " Run the test-suite built with code coverage (including local libs used)\n" + + , commandDefaultFlags = defaultNixStyleFlags () + , commandOptions = nixStyleOptions (const []) + } + + + +-- | The @test@ command is very much like @build@. It brings the install plan +-- up to date, selects that part of the plan needed by the given or implicit +-- test target(s) and then executes the plan. +-- +-- Compared to @build@ the difference is that there's also test targets +-- which are ephemeral. +-- +-- For more details on how this works, see the module +-- "Distribution.Client.ProjectOrchestration" +-- +testAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO () +testAction flags@NixStyleFlags {..} targetStrings globalFlags = do + + baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand + + targetSelectors <- either (reportTargetSelectorProblems verbosity) return + =<< readTargetSelectors (localPackages baseCtx) (Just TestKind) targetStrings + + buildCtx <- + runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do + + when (buildSettingOnlyDeps (buildSettings baseCtx)) $ + die' verbosity $ + "The test command does not support '--only-dependencies'. " + ++ "You may wish to use 'build --only-dependencies' and then " + ++ "use 'test'." + + -- Interpret the targets on the command line as test targets + -- (as opposed to say build or haddock targets). + targets <- either (reportTargetProblems verbosity failWhenNoTestSuites) return + $ resolveTargets + selectPackageTargets + selectComponentTarget + elaboratedPlan + Nothing + targetSelectors + + let elaboratedPlan' = pruneInstallPlanToTargets + TargetActionTest + targets + elaboratedPlan + return (elaboratedPlan', targets) + + printPlan verbosity baseCtx buildCtx + + buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx + runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes + where + failWhenNoTestSuites = testFailWhenNoTestSuites testFlags + verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags + +-- | This defines what a 'TargetSelector' means for the @test@ command. +-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, +-- or otherwise classifies the problem. +-- +-- For the @test@ command we select all buildable test-suites, +-- or fail if there are no test-suites or no buildable test-suites. +-- +selectPackageTargets :: TargetSelector + -> [AvailableTarget k] -> Either TestTargetProblem [k] +selectPackageTargets targetSelector targets + + -- If there are any buildable test-suite targets then we select those + | not (null targetsTestsBuildable) + = Right targetsTestsBuildable + + -- If there are test-suites but none are buildable then we report those + | not (null targetsTests) + = Left (TargetProblemNoneEnabled targetSelector targetsTests) + + -- If there are no test-suite but some other targets then we report that + | not (null targets) + = Left (noTestsProblem targetSelector) + + -- If there are no targets at all then we report that + | otherwise + = Left (TargetProblemNoTargets targetSelector) + where + targetsTestsBuildable = selectBuildableTargets + . filterTargetsKind TestKind + $ targets + + targetsTests = forgetTargetsDetail + . filterTargetsKind TestKind + $ targets + + +-- | For a 'TargetComponent' 'TargetSelector', check if the component can be +-- selected. +-- +-- For the @test@ command we just need to check it is a test-suite, in addition +-- to the basic checks on being buildable etc. +-- +selectComponentTarget :: SubComponentTarget + -> AvailableTarget k -> Either TestTargetProblem k +selectComponentTarget subtarget@WholeComponent t + | CTestName _ <- availableTargetComponentName t + = either Left return $ + selectComponentTargetBasic subtarget t + | otherwise + = Left (notTestProblem + (availableTargetPackageId t) + (availableTargetComponentName t)) + +selectComponentTarget subtarget t + = Left (isSubComponentProblem + (availableTargetPackageId t) + (availableTargetComponentName t) + subtarget) + +-- | The various error conditions that can occur when matching a +-- 'TargetSelector' against 'AvailableTarget's for the @test@ command. +-- +data TestProblem = + -- | The 'TargetSelector' matches targets but no test-suites + TargetProblemNoTests TargetSelector + + -- | The 'TargetSelector' refers to a component that is not a test-suite + | TargetProblemComponentNotTest PackageId ComponentName + + -- | Asking to test an individual file or module is not supported + | TargetProblemIsSubComponent PackageId ComponentName SubComponentTarget + deriving (Eq, Show) + + +type TestTargetProblem = TargetProblem TestProblem + + +noTestsProblem :: TargetSelector -> TargetProblem TestProblem +noTestsProblem = CustomTargetProblem . TargetProblemNoTests + +notTestProblem :: PackageId -> ComponentName -> TargetProblem TestProblem +notTestProblem pkgid name = CustomTargetProblem $ TargetProblemComponentNotTest pkgid name + +isSubComponentProblem + :: PackageId + -> ComponentName + -> SubComponentTarget + -> TargetProblem TestProblem +isSubComponentProblem pkgid name subcomponent = CustomTargetProblem $ + TargetProblemIsSubComponent pkgid name subcomponent + +reportTargetProblems :: Verbosity -> Flag Bool -> [TestTargetProblem] -> IO a +reportTargetProblems verbosity failWhenNoTestSuites problems = + case (failWhenNoTestSuites, problems) of + (Flag True, [CustomTargetProblem (TargetProblemNoTests _)]) -> + die' verbosity problemsMessage + (_, [CustomTargetProblem (TargetProblemNoTests selector)]) -> do + notice verbosity (renderAllowedNoTestsProblem selector) + System.Exit.exitSuccess + (_, _) -> die' verbosity problemsMessage + where + problemsMessage = unlines . map renderTestTargetProblem $ problems + +-- | Unless @--test-fail-when-no-test-suites@ flag is passed, we don't +-- @die@ when the target problem is 'TargetProblemNoTests'. +-- Instead, we display a notice saying that no tests have run and +-- indicate how this behaviour was enabled. +renderAllowedNoTestsProblem :: TargetSelector -> String +renderAllowedNoTestsProblem selector = + "No tests to run for " ++ renderTargetSelector selector + +renderTestTargetProblem :: TestTargetProblem -> String +renderTestTargetProblem (TargetProblemNoTargets targetSelector) = + case targetSelectorFilter targetSelector of + Just kind | kind /= TestKind + -> "The test command is for running test suites, but the target '" + ++ showTargetSelector targetSelector ++ "' refers to " + ++ renderTargetSelector targetSelector ++ "." + ++ "\n" ++ show targetSelector + + _ -> renderTargetProblemNoTargets "test" targetSelector +renderTestTargetProblem problem = + renderTargetProblem "test" renderTestProblem problem + + +renderTestProblem :: TestProblem -> String +renderTestProblem (TargetProblemNoTests targetSelector) = + "Cannot run tests for the target '" ++ showTargetSelector targetSelector + ++ "' which refers to " ++ renderTargetSelector targetSelector + ++ " because " + ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do" + ++ " not contain any test suites." + +renderTestProblem (TargetProblemComponentNotTest pkgid cname) = + "The test command is for running test suites, but the target '" + ++ showTargetSelector targetSelector ++ "' refers to " + ++ renderTargetSelector targetSelector ++ " from the package " + ++ prettyShow pkgid ++ "." + where + targetSelector = TargetComponent pkgid cname WholeComponent + +renderTestProblem (TargetProblemIsSubComponent pkgid cname subtarget) = + "The test command can only run test suites as a whole, " + ++ "not files or modules within them, but the target '" + ++ showTargetSelector targetSelector ++ "' refers to " + ++ renderTargetSelector targetSelector ++ "." + where + targetSelector = TargetComponent pkgid cname subtarget diff --git a/cabal/cabal-install/src/Distribution/Client/CmdUpdate.hs b/cabal/cabal-install/src/Distribution/Client/CmdUpdate.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/CmdUpdate.hs @@ -0,0 +1,237 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} + +-- | cabal-install CLI command: update +-- +module Distribution.Client.CmdUpdate ( + updateCommand, + updateAction, + ) where + +import Prelude () +import Control.Exception +import Distribution.Client.Compat.Prelude + +import Distribution.Client.NixStyleOptions + ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) +import Distribution.Client.Compat.Directory + ( setModificationTime ) +import Distribution.Client.ProjectOrchestration +import Distribution.Client.ProjectConfig + ( ProjectConfig(..) + , ProjectConfigShared(projectConfigConfigFile) + , projectConfigWithSolverRepoContext + , withProjectOrGlobalConfig ) +import Distribution.Client.ProjectFlags + ( ProjectFlags (..) ) +import Distribution.Client.Types + ( Repo(..), RepoName (..), unRepoName, RemoteRepo(..), repoName ) +import Distribution.Client.HttpUtils + ( DownloadResult(..) ) +import Distribution.Client.FetchUtils + ( downloadIndex ) +import Distribution.Client.JobControl + ( newParallelJobControl, spawnJob, collectJob ) +import Distribution.Client.Setup + ( GlobalFlags, ConfigFlags(..) + , UpdateFlags, defaultUpdateFlags + , RepoContext(..) ) +import Distribution.Simple.Flag + ( fromFlagOrDefault ) +import Distribution.Simple.Utils + ( die', notice, wrapText, writeFileAtomic, noticeNoWrap, warn ) +import Distribution.Verbosity + ( normal, lessVerbose ) +import Distribution.Client.IndexUtils.IndexState +import Distribution.Client.IndexUtils + ( updateRepoIndexCache, Index(..), writeIndexTimestamp + , currentIndexTimestamp, indexBaseName, updatePackageIndexCacheFile ) + +import qualified Data.Maybe as Unsafe (fromJust) +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as Disp + +import qualified Data.ByteString.Lazy as BS +import Distribution.Client.GZipUtils (maybeDecompress) +import System.FilePath ((<.>), dropExtension) +import Data.Time (getCurrentTime) +import Distribution.Simple.Command + ( CommandUI(..), usageAlternatives ) + +import qualified Hackage.Security.Client as Sec +import Distribution.Client.IndexUtils.Timestamp (nullTimestamp) + +updateCommand :: CommandUI (NixStyleFlags ()) +updateCommand = CommandUI + { commandName = "v2-update" + , commandSynopsis = "Updates list of known packages." + , commandUsage = usageAlternatives "v2-update" [ "[FLAGS] [REPOS]" ] + , commandDescription = Just $ \_ -> wrapText $ + "For all known remote repositories, download the package list." + + , commandNotes = Just $ \pname -> + "REPO has the format [,] where index-state follows\n" + ++ "the same format and syntax that is supported by the --index-state flag.\n\n" + ++ "Examples:\n" + ++ " " ++ pname ++ " v2-update\n" + ++ " Download the package list for all known remote repositories.\n\n" + ++ " " ++ pname ++ " v2-update hackage.haskell.org,@1474732068\n" + ++ " " ++ pname ++ " v2-update hackage.haskell.org,2016-09-24T17:47:48Z\n" + ++ " " ++ pname ++ " v2-update hackage.haskell.org,HEAD\n" + ++ " " ++ pname ++ " v2-update hackage.haskell.org\n" + ++ " Download hackage.haskell.org at a specific index state.\n\n" + ++ " " ++ pname ++ " v2-update hackage.haskell.org head.hackage\n" + ++ " Download hackage.haskell.org and head.hackage\n" + ++ " head.hackage must be a known repo-id. E.g. from\n" + ++ " your cabal.project(.local) file.\n" + + , commandOptions = nixStyleOptions $ const [] + , commandDefaultFlags = defaultNixStyleFlags () + } + +data UpdateRequest = UpdateRequest + { _updateRequestRepoName :: RepoName + , _updateRequestRepoState :: RepoIndexState + } deriving (Show) + +instance Pretty UpdateRequest where + pretty (UpdateRequest n s) = pretty n <<>> Disp.comma <<>> pretty s + +instance Parsec UpdateRequest where + parsec = do + name <- parsec + state <- P.char ',' *> parsec <|> pure IndexStateHead + return (UpdateRequest name state) + +updateAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO () +updateAction flags@NixStyleFlags {..} extraArgs globalFlags = do + let ignoreProject = flagIgnoreProject projectFlags + + projectConfig <- withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag + (projectConfig <$> establishProjectBaseContext verbosity cliConfig OtherCommand) + (\globalConfig -> return $ globalConfig <> cliConfig) + + projectConfigWithSolverRepoContext verbosity + (projectConfigShared projectConfig) (projectConfigBuildOnly projectConfig) + $ \repoCtxt -> do + + let repos :: [Repo] + repos = repoContextRepos repoCtxt + + parseArg :: String -> IO UpdateRequest + parseArg s = case simpleParsec s of + Just r -> return r + Nothing -> die' verbosity $ + "'v2-update' unable to parse repo: \"" ++ s ++ "\"" + + updateRepoRequests <- traverse parseArg extraArgs + + unless (null updateRepoRequests) $ do + let remoteRepoNames = map repoName repos + unknownRepos = [r | (UpdateRequest r _) <- updateRepoRequests + , not (r `elem` remoteRepoNames)] + unless (null unknownRepos) $ + die' verbosity $ "'v2-update' repo(s): \"" + ++ intercalate "\", \"" (map unRepoName unknownRepos) + ++ "\" can not be found in known remote repo(s): " + ++ intercalate ", " (map unRepoName remoteRepoNames) + + let reposToUpdate :: [(Repo, RepoIndexState)] + reposToUpdate = case updateRepoRequests of + -- If we are not given any specific repository, update all + -- repositories to HEAD. + [] -> map (,IndexStateHead) repos + updateRequests -> let repoMap = [(repoName r, r) | r <- repos] + lookup' k = Unsafe.fromJust (lookup k repoMap) + in [ (lookup' name, state) + | (UpdateRequest name state) <- updateRequests ] + + case reposToUpdate of + [] -> + notice verbosity "No remote repositories configured" + [(remoteRepo, _)] -> + notice verbosity $ "Downloading the latest package list from " + ++ unRepoName (repoName remoteRepo) + _ -> notice verbosity . unlines + $ "Downloading the latest package lists from: " + : map (("- " ++) . unRepoName . repoName . fst) reposToUpdate + + unless (null reposToUpdate) $ do + jobCtrl <- newParallelJobControl (length reposToUpdate) + traverse_ (spawnJob jobCtrl . updateRepo verbosity defaultUpdateFlags repoCtxt) + reposToUpdate + traverse_ (\_ -> collectJob jobCtrl) reposToUpdate + + where + verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags, not needed here + globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) + +updateRepo :: Verbosity -> UpdateFlags -> RepoContext -> (Repo, RepoIndexState) + -> IO () +updateRepo verbosity _updateFlags repoCtxt (repo, indexState) = do + transport <- repoContextGetTransport repoCtxt + case repo of + RepoLocalNoIndex{} -> do + let index = RepoIndex repoCtxt repo + updatePackageIndexCacheFile verbosity index + + RepoRemote{..} -> do + downloadResult <- downloadIndex transport verbosity + repoRemote repoLocalDir + case downloadResult of + FileAlreadyInCache -> + setModificationTime (indexBaseName repo <.> "tar") + =<< getCurrentTime + FileDownloaded indexPath -> do + writeFileAtomic (dropExtension indexPath) . maybeDecompress + =<< BS.readFile indexPath + updateRepoIndexCache verbosity (RepoIndex repoCtxt repo) + RepoSecure{} -> repoContextWithSecureRepo repoCtxt repo $ \repoSecure -> do + let index = RepoIndex repoCtxt repo + -- NB: This may be a nullTimestamp if we've never updated before + current_ts <- currentIndexTimestamp (lessVerbose verbosity) repoCtxt repo + -- NB: always update the timestamp, even if we didn't actually + -- download anything + writeIndexTimestamp index indexState + ce <- if repoContextIgnoreExpiry repoCtxt + then Just `fmap` getCurrentTime + else return Nothing + updated <- Sec.uncheckClientErrors $ Sec.checkForUpdates repoSecure ce + -- this resolves indexState (which could be HEAD) into a timestamp + new_ts <- currentIndexTimestamp (lessVerbose verbosity) repoCtxt repo + let rname = remoteRepoName (repoRemote repo) + + -- Update cabal's internal index as well so that it's not out of sync + -- (If all access to the cache goes through hackage-security this can go) + case updated of + Sec.NoUpdates -> do + now <- getCurrentTime + setModificationTime (indexBaseName repo <.> "tar") now `catchIO` + (\e -> warn verbosity $ "Could not set modification time of index tarball -- " ++ displayException e) + noticeNoWrap verbosity $ + "Package list of " ++ prettyShow rname ++ " is up to date." + + Sec.HasUpdates -> do + updateRepoIndexCache verbosity index + noticeNoWrap verbosity $ + "Package list of " ++ prettyShow rname ++ " has been updated." + + noticeNoWrap verbosity $ + "The index-state is set to " ++ prettyShow (IndexStateTime new_ts) ++ "." + + -- TODO: This will print multiple times if there are multiple + -- repositories: main problem is we don't have a way of updating + -- a specific repo. Once we implement that, update this. + + -- In case current_ts is a valid timestamp different from new_ts, let + -- the user know how to go back to current_ts + when (current_ts /= nullTimestamp && new_ts /= current_ts) $ + noticeNoWrap verbosity $ + "To revert to previous state run:\n" ++ + " cabal v2-update '" ++ prettyShow (UpdateRequest rname (IndexStateTime current_ts)) ++ "'\n" diff --git a/cabal/cabal-install/src/Distribution/Client/Compat/Directory.hs b/cabal/cabal-install/src/Distribution/Client/Compat/Directory.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Compat/Directory.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE CPP #-} +module Distribution.Client.Compat.Directory ( + setModificationTime, + createFileLink, + pathIsSymbolicLink, + getSymbolicLinkTarget, + ) where + +#if MIN_VERSION_directory(1,2,3) +import System.Directory (setModificationTime) +#else +import Data.Time.Clock (UTCTime) +#endif + +#if MIN_VERSION_directory(1,3,1) +import System.Directory (createFileLink, getSymbolicLinkTarget, pathIsSymbolicLink) +#elif defined(MIN_VERSION_unix) +import System.Posix.Files (createSymbolicLink, getSymbolicLinkStatus, isSymbolicLink, readSymbolicLink) +#endif + +------------------------------------------------------------------------------- +-- setModificationTime +------------------------------------------------------------------------------- + +#if !MIN_VERSION_directory(1,2,3) + +setModificationTime :: FilePath -> UTCTime -> IO () +setModificationTime _fp _t = return () + +#endif + +------------------------------------------------------------------------------- +-- Symlink +------------------------------------------------------------------------------- + +#if MIN_VERSION_directory(1,3,1) +#elif defined(MIN_VERSION_unix) +createFileLink :: FilePath -> FilePath -> IO () +createFileLink = createSymbolicLink + +pathIsSymbolicLink :: FilePath -> IO Bool +pathIsSymbolicLink fp = do + status <- getSymbolicLinkStatus fp + return (isSymbolicLink status) + +getSymbolicLinkTarget :: FilePath -> IO FilePath +getSymbolicLinkTarget = readSymbolicLink + +#else +createFileLink :: FilePath -> FilePath -> IO () +createFileLink _ _ = fail "Symlinking feature not available" + +pathIsSymbolicLink :: FilePath -> IO Bool +pathIsSymbolicLink _ = fail "Symlinking feature not available" + +getSymbolicLinkTarget :: FilePath -> IO FilePath +getSymbolicLinkTarget _ = fail "Symlinking feature not available" +#endif diff --git a/cabal/cabal-install/src/Distribution/Client/Compat/ExecutablePath.hs b/cabal/cabal-install/src/Distribution/Client/Compat/ExecutablePath.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Compat/ExecutablePath.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE CPP #-} + +-- Copied verbatim from base-4.6.0.0. We can't simply import +-- System.Environment.getExecutablePath because we need compatibility with older +-- GHCs. + +module Distribution.Client.Compat.ExecutablePath ( getExecutablePath ) where + +import Prelude + +-- The imports are purposely kept completely disjoint to prevent edits +-- to one OS implementation from breaking another. + +#if defined(darwin_HOST_OS) +import Data.Word +import Foreign.C +import Foreign.Marshal.Alloc +import Foreign.Ptr +import Foreign.Storable +import System.Posix.Internals +#elif defined(linux_HOST_OS) +import Foreign.C +import Foreign.Marshal.Array +import System.Posix.Internals +#elif defined(mingw32_HOST_OS) +import Data.Word +import Foreign.C +import Foreign.Marshal.Array +import Foreign.Ptr +import System.Posix.Internals +#else +import Foreign.C +import Foreign.Marshal.Alloc +import Foreign.Ptr +import Foreign.Storable +import System.Posix.Internals +#endif + +-- The exported function is defined outside any if-guard to make sure +-- every OS implements it with the same type. + +-- | Returns the absolute pathname of the current executable. +-- +-- Note that for scripts and interactive sessions, this is the path to +-- the interpreter (e.g. ghci.) +-- +-- /Since: 4.6.0.0/ +getExecutablePath :: IO FilePath + +-------------------------------------------------------------------------------- +-- Mac OS X + +#if defined(darwin_HOST_OS) + +type UInt32 = Word32 + +foreign import ccall unsafe "mach-o/dyld.h _NSGetExecutablePath" + c__NSGetExecutablePath :: CString -> Ptr UInt32 -> IO CInt + +-- | Returns the path of the main executable. The path may be a +-- symbolic link and not the real file. +-- +-- See dyld(3) +_NSGetExecutablePath :: IO FilePath +_NSGetExecutablePath = + allocaBytes 1024 $ \ buf -> -- PATH_MAX is 1024 on OS X + alloca $ \ bufsize -> do + poke bufsize 1024 + status <- c__NSGetExecutablePath buf bufsize + if status == 0 + then peekFilePath buf + else do reqBufsize <- fromIntegral `fmap` peek bufsize + allocaBytes reqBufsize $ \ newBuf -> do + status2 <- c__NSGetExecutablePath newBuf bufsize + if status2 == 0 + then peekFilePath newBuf + else error "_NSGetExecutablePath: buffer too small" + +foreign import ccall unsafe "stdlib.h realpath" + c_realpath :: CString -> CString -> IO CString + +-- | Resolves all symbolic links, extra \/ characters, and references +-- to \/.\/ and \/..\/. Returns an absolute pathname. +-- +-- See realpath(3) +realpath :: FilePath -> IO FilePath +realpath path = + withFilePath path $ \ fileName -> + allocaBytes 1024 $ \ resolvedName -> do + _ <- throwErrnoIfNull "realpath" $ c_realpath fileName resolvedName + peekFilePath resolvedName + +getExecutablePath = _NSGetExecutablePath >>= realpath + +-------------------------------------------------------------------------------- +-- Linux + +#elif defined(linux_HOST_OS) + +foreign import ccall unsafe "readlink" + c_readlink :: CString -> CString -> CSize -> IO CInt + +-- | Reads the @FilePath@ pointed to by the symbolic link and returns +-- it. +-- +-- See readlink(2) +readSymbolicLink :: FilePath -> IO FilePath +readSymbolicLink file = + allocaArray0 4096 $ \buf -> do + withFilePath file $ \s -> do + len <- throwErrnoPathIfMinus1 "readSymbolicLink" file $ + c_readlink s buf 4096 + peekFilePathLen (buf,fromIntegral len) + +getExecutablePath = readSymbolicLink $ "/proc/self/exe" + +-------------------------------------------------------------------------------- +-- Windows + +#elif defined(mingw32_HOST_OS) + +# if defined(i386_HOST_ARCH) +# define WINDOWS_CCONV stdcall +# elif defined(x86_64_HOST_ARCH) +# define WINDOWS_CCONV ccall +# else +# error Unknown mingw32 arch +# endif + +foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW" + c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32 + +getExecutablePath = go 2048 -- plenty, PATH_MAX is 512 under Win32 + where + go size = allocaArray (fromIntegral size) $ \ buf -> do + ret <- c_GetModuleFileName nullPtr buf size + case ret of + 0 -> error "getExecutablePath: GetModuleFileNameW returned an error" + _ | ret < size -> peekFilePath buf + | otherwise -> go (size * 2) + +-------------------------------------------------------------------------------- +-- Fallback to argv[0] + +#else + +foreign import ccall unsafe "getFullProgArgv" + c_getFullProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO () + +getExecutablePath = + alloca $ \ p_argc -> + alloca $ \ p_argv -> do + c_getFullProgArgv p_argc p_argv + argc <- peek p_argc + if argc > 0 + -- If argc > 0 then argv[0] is guaranteed by the standard + -- to be a pointer to a null-terminated string. + then peek p_argv >>= peek >>= peekFilePath + else error $ "getExecutablePath: " ++ msg + where msg = "no OS specific implementation and program name couldn't be " ++ + "found in argv" + +-------------------------------------------------------------------------------- + +#endif diff --git a/cabal/cabal-install/src/Distribution/Client/Compat/Orphans.hs b/cabal/cabal-install/src/Distribution/Client/Compat/Orphans.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Compat/Orphans.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE BangPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Distribution.Client.Compat.Orphans () where + +import Control.Exception (SomeException) +import Distribution.Compat.Binary (Binary (..)) +import Distribution.Compat.Typeable (typeRep) +import Distribution.Utils.Structured (Structure (Nominal), Structured (..)) +import Network.URI (URI (..), URIAuth (..)) +import Prelude (error, return) + +------------------------------------------------------------------------------- +-- network-uri +------------------------------------------------------------------------------- + +-- note, network-uri-2.6.0.3+ provide a Generic instance but earlier +-- versions do not, so we use manual Binary instances here +instance Binary URI where + put (URI a b c d e) = do put a; put b; put c; put d; put e + get = do !a <- get; !b <- get; !c <- get; !d <- get; !e <- get + return (URI a b c d e) + +instance Structured URI where + structure p = Nominal (typeRep p) 0 "URI" [] + +instance Binary URIAuth where + put (URIAuth a b c) = do put a; put b; put c + get = do !a <- get; !b <- get; !c <- get; return (URIAuth a b c) + +------------------------------------------------------------------------------- +-- base +------------------------------------------------------------------------------- + +--FIXME: Duncan Coutts: this is a total cheat +--Added in 46aa019ec85e313e257d122a3549cce01996c566 +instance Binary SomeException where + put _ = return () + get = error "cannot serialise exceptions" + +instance Structured SomeException where + structure p = Nominal (typeRep p) 0 "SomeException" [] diff --git a/cabal/cabal-install/src/Distribution/Client/Compat/Prelude.hs b/cabal/cabal-install/src/Distribution/Client/Compat/Prelude.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Compat/Prelude.hs @@ -0,0 +1,24 @@ +-- to suppress WARNING in "Distribution.Compat.Prelude.Internal" +{-# OPTIONS_GHC -fno-warn-deprecations #-} + +-- | This module does two things: +-- +-- * Acts as a compatibility layer, like @base-compat@. +-- +-- * Provides commonly used imports. +-- +-- This module is a superset of "Distribution.Compat.Prelude" (which +-- this module re-exports) +-- +module Distribution.Client.Compat.Prelude + ( module Distribution.Compat.Prelude.Internal + , module X + ) where + +import Distribution.Client.Compat.Orphans () +import Distribution.Compat.Prelude.Internal +import Prelude () + +import Distribution.Parsec as X (CabalParsing, Parsec (..), eitherParsec, explicitEitherParsec, simpleParsec) +import Distribution.Pretty as X (Pretty (..), prettyShow) +import Distribution.Verbosity as X (Verbosity) diff --git a/cabal/cabal-install/src/Distribution/Client/Compat/Process.hs b/cabal/cabal-install/src/Distribution/Client/Compat/Process.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Compat/Process.hs @@ -0,0 +1,48 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Compat.Process +-- Copyright : (c) 2013 Liu Hao, Brent Yorgey +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Cross-platform utilities for invoking processes. +-- +----------------------------------------------------------------------------- + +module Distribution.Client.Compat.Process ( + readProcessWithExitCode +) where + +import Prelude (FilePath, IO, String, return, (||)) + +import Control.Exception (catch, throw) +import System.Exit (ExitCode (ExitFailure)) +import System.IO.Error (isDoesNotExistError, isPermissionError) +import qualified System.Process as P + +-- | @readProcessWithExitCode@ creates an external process, reads its +-- standard output and standard error strictly, waits until the +-- process terminates, and then returns the @ExitCode@ of the +-- process, the standard output, and the standard error. +-- +-- See the documentation of the version from @System.Process@ for +-- more information. +-- +-- The version from @System.Process@ behaves inconsistently across +-- platforms when an executable with the given name is not found: in +-- some cases it returns an @ExitFailure@, in others it throws an +-- exception. This variant catches \"does not exist\" and +-- \"permission denied\" exceptions and turns them into +-- @ExitFailure@s. +-- +-- TODO: this doesn't use 'Distrubution.Compat.Process'. +-- +readProcessWithExitCode :: FilePath -> [String] -> String -> IO (ExitCode, String, String) +readProcessWithExitCode cmd args input = + P.readProcessWithExitCode cmd args input + `catch` \e -> if isDoesNotExistError e || isPermissionError e + then return (ExitFailure 127, "", "") + else throw e diff --git a/cabal/cabal-install/src/Distribution/Client/Compat/Semaphore.hs b/cabal/cabal-install/src/Distribution/Client/Compat/Semaphore.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Compat/Semaphore.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} +module Distribution.Client.Compat.Semaphore + ( QSem + , newQSem + , waitQSem + , signalQSem + ) where + +import Prelude (IO, return, Eq (..), Int, Bool (..), ($), ($!), Num (..), flip) + +import Control.Concurrent.STM (TVar, atomically, newTVar, readTVar, retry, + writeTVar) +import Control.Exception (mask_, onException) +import Control.Monad (join, unless) +import Data.Typeable (Typeable) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE + +-- | 'QSem' is a quantity semaphore in which the resource is acquired +-- and released in units of one. It provides guaranteed FIFO ordering +-- for satisfying blocked `waitQSem` calls. +-- +data QSem = QSem !(TVar Int) !(TVar [TVar Bool]) !(TVar [TVar Bool]) + deriving (Eq, Typeable) + +newQSem :: Int -> IO QSem +newQSem i = atomically $ do + q <- newTVar i + b1 <- newTVar [] + b2 <- newTVar [] + return (QSem q b1 b2) + +waitQSem :: QSem -> IO () +waitQSem s@(QSem q _b1 b2) = + mask_ $ join $ atomically $ do + -- join, because if we need to block, we have to add a TVar to + -- the block queue. + -- mask_, because we need a chance to set up an exception handler + -- after the join returns. + v <- readTVar q + if v == 0 + then do b <- newTVar False + ys <- readTVar b2 + writeTVar b2 (b:ys) + return (wait b) + else do writeTVar q $! v - 1 + return (return ()) + where + -- + -- very careful here: if we receive an exception, then we need to + -- (a) write True into the TVar, so that another signalQSem doesn't + -- try to wake up this thread, and + -- (b) if the TVar is *already* True, then we need to do another + -- signalQSem to avoid losing a unit of the resource. + -- + -- The 'wake' function does both (a) and (b), so we can just call + -- it here. + -- + wait t = + flip onException (wake s t) $ + atomically $ do + b <- readTVar t + unless b retry + + +wake :: QSem -> TVar Bool -> IO () +wake s x = join $ atomically $ do + b <- readTVar x + if b then return (signalQSem s) + else do writeTVar x True + return (return ()) + +{- + property we want: + + bracket waitQSem (\_ -> signalQSem) (\_ -> ...) + + never loses a unit of the resource. +-} + +signalQSem :: QSem -> IO () +signalQSem s@(QSem q b1 b2) = + mask_ $ join $ atomically $ do + -- join, so we don't force the reverse inside the txn + -- mask_ is needed so we don't lose a wakeup + v <- readTVar q + if v /= 0 + then do writeTVar q $! v + 1 + return (return ()) + else do xs <- readTVar b1 + checkwake1 xs + where + checkwake1 [] = do + ys <- readTVar b2 + checkwake2 ys + checkwake1 (x:xs) = do + writeTVar b1 xs + return (wake s x) + + checkwake2 [] = do + writeTVar q 1 + return (return ()) + checkwake2 (y:ys) = do + let (z:|zs) = NE.reverse (y:|ys) + writeTVar b1 zs + writeTVar b2 [] + return (wake s z) diff --git a/cabal/cabal-install/src/Distribution/Client/Config.hs b/cabal/cabal-install/src/Distribution/Client/Config.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Config.hs @@ -0,0 +1,1492 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NoMonoLocalBinds #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Config +-- Copyright : (c) David Himmelstrup 2005 +-- License : BSD-like +-- +-- Maintainer : lemmih@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Utilities for handling saved state such as known packages, known servers and +-- downloaded packages. +----------------------------------------------------------------------------- +module Distribution.Client.Config ( + addInfoForKnownRepos, + SavedConfig(..), + loadConfig, + getConfigFilePath, + + showConfig, + showConfigWithComments, + parseConfig, + + getCabalDir, + defaultConfigFile, + defaultCacheDir, + defaultCompiler, + defaultInstallPath, + defaultLogsDir, + defaultUserInstall, + + baseSavedConfig, + commentSavedConfig, + initialSavedConfig, + configFieldDescriptions, + haddockFlagsFields, + installDirsFields, + withProgramsFields, + withProgramOptionsFields, + userConfigDiff, + userConfigUpdate, + createDefaultConfigFile, + + remoteRepoFields, + postProcessRepo, + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Language.Haskell.Extension ( Language(Haskell2010) ) + +import Distribution.Deprecated.ViewAsFieldDescr + ( viewAsFieldDescr ) + +import Distribution.Client.Types + ( RemoteRepo(..), LocalRepo (..), emptyRemoteRepo + , AllowOlder(..), AllowNewer(..), RelaxDeps(..), isRelaxDeps + , RepoName (..), unRepoName + ) +import Distribution.Client.Types.Credentials (Username (..), Password (..)) +import Distribution.Client.BuildReports.Types + ( ReportLevel(..) ) +import qualified Distribution.Client.Init.Types as IT + ( InitFlags(..) ) +import qualified Distribution.Client.Init.Defaults as IT +import Distribution.Client.Setup + ( GlobalFlags(..), globalCommand, defaultGlobalFlags + , ConfigExFlags(..), configureExOptions, defaultConfigExFlags + , initOptions + , InstallFlags(..), installOptions, defaultInstallFlags + , UploadFlags(..), uploadCommand + , ReportFlags(..), reportCommand ) +import Distribution.Client.CmdInstall.ClientInstallFlags + ( ClientInstallFlags(..), defaultClientInstallFlags + , clientInstallOptions ) +import Distribution.Utils.NubList + ( NubList, fromNubList, toNubList, overNubList ) + +import Distribution.Simple.Compiler + ( DebugInfoLevel(..), OptimisationLevel(..) ) +import Distribution.Simple.Setup + ( ConfigFlags(..), configureOptions, defaultConfigFlags + , HaddockFlags(..), haddockOptions, defaultHaddockFlags + , TestFlags(..), defaultTestFlags + , BenchmarkFlags(..), defaultBenchmarkFlags + , installDirsOptions, optionDistPref + , programDbPaths', programDbOptions + , Flag(..), toFlag, flagToMaybe, fromFlagOrDefault ) +import Distribution.Simple.InstallDirs + ( InstallDirs(..), defaultInstallDirs + , PathTemplate, toPathTemplate ) +import Distribution.Deprecated.ParseUtils + ( FieldDescr(..), liftField, runP + , ParseResult(..), PError(..), PWarning(..) + , locatedErrorMsg, showPWarning + , readFields, warning, lineNo + , simpleField, listField, spaceListField + , parseOptCommaList, parseTokenQ, syntaxError + , simpleFieldParsec, listFieldParsec + ) +import Distribution.Client.ParseUtils + ( parseFields, ppFields, ppSection ) +import Distribution.Client.HttpUtils + ( isOldHackageURI ) +import qualified Distribution.Deprecated.ParseUtils as ParseUtils + ( Field(..) ) +import Distribution.Simple.Command + ( CommandUI(commandOptions), commandDefaultFlags, ShowOrParseArgs(..) ) +import Distribution.Simple.Program + ( defaultProgramDb ) +import Distribution.Simple.Utils + ( die', notice, warn, lowercase, cabalVersion, toUTF8BS ) +import Distribution.Client.Version + ( cabalInstallVersion ) +import Distribution.Compiler + ( CompilerFlavor(..), defaultCompilerFlavor ) +import Distribution.Verbosity + ( normal ) +import qualified Distribution.Compat.CharParsing as P +import Distribution.Client.ProjectFlags (ProjectFlags (..)) +import Distribution.Solver.Types.ConstraintSource + +import qualified Text.PrettyPrint as Disp + ( render, text, empty ) +import Distribution.Parsec (parsecOptCommaList, ParsecParser, parsecToken, parsecFilePath) +import Text.PrettyPrint + ( ($+$) ) +import Text.PrettyPrint.HughesPJ + ( text, Doc ) +import System.Directory + ( createDirectoryIfMissing, getAppUserDataDirectory, renameFile ) +import Network.URI + ( URI(..), URIAuth(..), parseURI ) +import System.FilePath + ( (<.>), (), takeDirectory ) +import System.IO.Error + ( isDoesNotExistError ) +import Distribution.Compat.Environment + ( getEnvironment, lookupEnv ) +import qualified Data.Map as M +import qualified Data.ByteString as BS + +-- +-- * Configuration saved in the config file +-- + +data SavedConfig = SavedConfig + { savedGlobalFlags :: GlobalFlags + , savedInitFlags :: IT.InitFlags + , savedInstallFlags :: InstallFlags + , savedClientInstallFlags :: ClientInstallFlags + , savedConfigureFlags :: ConfigFlags + , savedConfigureExFlags :: ConfigExFlags + , savedUserInstallDirs :: InstallDirs (Flag PathTemplate) + , savedGlobalInstallDirs :: InstallDirs (Flag PathTemplate) + , savedUploadFlags :: UploadFlags + , savedReportFlags :: ReportFlags + , savedHaddockFlags :: HaddockFlags + , savedTestFlags :: TestFlags + , savedBenchmarkFlags :: BenchmarkFlags + , savedProjectFlags :: ProjectFlags + } deriving Generic + +instance Monoid SavedConfig where + mempty = gmempty + mappend = (<>) + +instance Semigroup SavedConfig where + a <> b = SavedConfig { + savedGlobalFlags = combinedSavedGlobalFlags, + savedInitFlags = combinedSavedInitFlags, + savedInstallFlags = combinedSavedInstallFlags, + savedClientInstallFlags = combinedSavedClientInstallFlags, + savedConfigureFlags = combinedSavedConfigureFlags, + savedConfigureExFlags = combinedSavedConfigureExFlags, + savedUserInstallDirs = combinedSavedUserInstallDirs, + savedGlobalInstallDirs = combinedSavedGlobalInstallDirs, + savedUploadFlags = combinedSavedUploadFlags, + savedReportFlags = combinedSavedReportFlags, + savedHaddockFlags = combinedSavedHaddockFlags, + savedTestFlags = combinedSavedTestFlags, + savedBenchmarkFlags = combinedSavedBenchmarkFlags, + savedProjectFlags = combinedSavedProjectFlags + } + where + -- This is ugly, but necessary. If we're mappending two config files, we + -- want the values of the *non-empty* list fields from the second one to + -- *override* the corresponding values from the first one. Default + -- behaviour (concatenation) is confusing and makes some use cases (see + -- #1884) impossible. + -- + -- However, we also want to allow specifying multiple values for a list + -- field in a *single* config file. For example, we want the following to + -- continue to work: + -- + -- remote-repo: hackage.haskell.org:http://hackage.haskell.org/ + -- remote-repo: private-collection:http://hackage.local/ + -- + -- So we can't just wrap the list fields inside Flags; we have to do some + -- special-casing just for SavedConfig. + + -- NB: the signature prevents us from using 'combine' on lists. + combine' :: (SavedConfig -> flags) -> (flags -> Flag a) -> Flag a + combine' field subfield = + (subfield . field $ a) `mappend` (subfield . field $ b) + + combineMonoid :: Monoid mon => (SavedConfig -> flags) -> (flags -> mon) + -> mon + combineMonoid field subfield = + (subfield . field $ a) `mappend` (subfield . field $ b) + + lastNonEmpty' :: (SavedConfig -> flags) -> (flags -> [a]) -> [a] + lastNonEmpty' field subfield = + let a' = subfield . field $ a + b' = subfield . field $ b + in case b' of [] -> a' + _ -> b' + + lastNonMempty' + :: (Eq a, Monoid a) => (SavedConfig -> flags) -> (flags -> a) -> a + lastNonMempty' field subfield = + let a' = subfield . field $ a + b' = subfield . field $ b + in if b' == mempty then a' else b' + + lastNonEmptyNL' :: (SavedConfig -> flags) -> (flags -> NubList a) + -> NubList a + lastNonEmptyNL' field subfield = + let a' = subfield . field $ a + b' = subfield . field $ b + in case fromNubList b' of [] -> a' + _ -> b' + + combinedSavedGlobalFlags = GlobalFlags { + globalVersion = combine globalVersion, + globalNumericVersion = combine globalNumericVersion, + globalConfigFile = combine globalConfigFile, + globalConstraintsFile = combine globalConstraintsFile, + globalRemoteRepos = lastNonEmptyNL globalRemoteRepos, + globalCacheDir = combine globalCacheDir, + globalLocalNoIndexRepos = lastNonEmptyNL globalLocalNoIndexRepos, + globalActiveRepos = combine globalActiveRepos, + globalLogsDir = combine globalLogsDir, + globalIgnoreExpiry = combine globalIgnoreExpiry, + globalHttpTransport = combine globalHttpTransport, + globalNix = combine globalNix, + globalStoreDir = combine globalStoreDir, + globalProgPathExtra = lastNonEmptyNL globalProgPathExtra + } + where + combine = combine' savedGlobalFlags + lastNonEmptyNL = lastNonEmptyNL' savedGlobalFlags + + combinedSavedInitFlags = IT.InitFlags { + IT.applicationDirs = combineMonoid savedInitFlags IT.applicationDirs, + IT.author = combine IT.author, + IT.buildTools = combineMonoid savedInitFlags IT.buildTools, + IT.cabalVersion = combine IT.cabalVersion, + IT.category = combine IT.category, + IT.dependencies = combineMonoid savedInitFlags IT.dependencies, + IT.email = combine IT.email, + IT.exposedModules = combineMonoid savedInitFlags IT.exposedModules, + IT.extraSrc = combineMonoid savedInitFlags IT.extraSrc, + IT.extraDoc = combineMonoid savedInitFlags IT.extraDoc, + IT.homepage = combine IT.homepage, + IT.initHcPath = combine IT.initHcPath, + IT.initVerbosity = combine IT.initVerbosity, + IT.initializeTestSuite = combine IT.initializeTestSuite, + IT.interactive = combine IT.interactive, + IT.language = combine IT.language, + IT.license = combine IT.license, + IT.mainIs = combine IT.mainIs, + IT.minimal = combine IT.minimal, + IT.noComments = combine IT.noComments, + IT.otherExts = combineMonoid savedInitFlags IT.otherExts, + IT.otherModules = combineMonoid savedInitFlags IT.otherModules, + IT.overwrite = combine IT.overwrite, + IT.packageDir = combine IT.packageDir, + IT.packageName = combine IT.packageName, + IT.packageType = combine IT.packageType, + IT.quiet = combine IT.quiet, + IT.simpleProject = combine IT.simpleProject, + IT.sourceDirs = combineMonoid savedInitFlags IT.sourceDirs, + IT.synopsis = combine IT.synopsis, + IT.testDirs = combineMonoid savedInitFlags IT.testDirs, + IT.version = combine IT.version + } + where + combine = combine' savedInitFlags + + combinedSavedInstallFlags = InstallFlags { + installDocumentation = combine installDocumentation, + installHaddockIndex = combine installHaddockIndex, + installDryRun = combine installDryRun, + installOnlyDownload = combine installOnlyDownload, + installDest = combine installDest, + installMaxBackjumps = combine installMaxBackjumps, + installReorderGoals = combine installReorderGoals, + installCountConflicts = combine installCountConflicts, + installFineGrainedConflicts = combine installFineGrainedConflicts, + installMinimizeConflictSet = combine installMinimizeConflictSet, + installIndependentGoals = combine installIndependentGoals, + installPreferOldest = combine installPreferOldest, + installShadowPkgs = combine installShadowPkgs, + installStrongFlags = combine installStrongFlags, + installAllowBootLibInstalls = combine installAllowBootLibInstalls, + installOnlyConstrained = combine installOnlyConstrained, + installReinstall = combine installReinstall, + installAvoidReinstalls = combine installAvoidReinstalls, + installOverrideReinstall = combine installOverrideReinstall, + installUpgradeDeps = combine installUpgradeDeps, + installOnly = combine installOnly, + installOnlyDeps = combine installOnlyDeps, + installIndexState = combine installIndexState, + installRootCmd = combine installRootCmd, + installSummaryFile = lastNonEmptyNL installSummaryFile, + installLogFile = combine installLogFile, + installBuildReports = combine installBuildReports, + installReportPlanningFailure = combine installReportPlanningFailure, + installSymlinkBinDir = combine installSymlinkBinDir, + installPerComponent = combine installPerComponent, + installNumJobs = combine installNumJobs, + installKeepGoing = combine installKeepGoing, + installRunTests = combine installRunTests, + installOfflineMode = combine installOfflineMode + } + where + combine = combine' savedInstallFlags + lastNonEmptyNL = lastNonEmptyNL' savedInstallFlags + + combinedSavedClientInstallFlags = ClientInstallFlags + { cinstInstallLibs = combine cinstInstallLibs + , cinstEnvironmentPath = combine cinstEnvironmentPath + , cinstOverwritePolicy = combine cinstOverwritePolicy + , cinstInstallMethod = combine cinstInstallMethod + , cinstInstalldir = combine cinstInstalldir + } + where + combine = combine' savedClientInstallFlags + + combinedSavedConfigureFlags = ConfigFlags { + configArgs = lastNonEmpty configArgs, + configPrograms_ = configPrograms_ . savedConfigureFlags $ b, + -- TODO: NubListify + configProgramPaths = lastNonEmpty configProgramPaths, + -- TODO: NubListify + configProgramArgs = lastNonEmpty configProgramArgs, + configProgramPathExtra = lastNonEmptyNL configProgramPathExtra, + configInstantiateWith = lastNonEmpty configInstantiateWith, + configHcFlavor = combine configHcFlavor, + configHcPath = combine configHcPath, + configHcPkg = combine configHcPkg, + configVanillaLib = combine configVanillaLib, + configProfLib = combine configProfLib, + configProf = combine configProf, + configSharedLib = combine configSharedLib, + configStaticLib = combine configStaticLib, + configDynExe = combine configDynExe, + configFullyStaticExe = combine configFullyStaticExe, + configProfExe = combine configProfExe, + configProfDetail = combine configProfDetail, + configProfLibDetail = combine configProfLibDetail, + -- TODO: NubListify + configConfigureArgs = lastNonEmpty configConfigureArgs, + configOptimization = combine configOptimization, + configDebugInfo = combine configDebugInfo, + configProgPrefix = combine configProgPrefix, + configProgSuffix = combine configProgSuffix, + -- Parametrised by (Flag PathTemplate), so safe to use 'mappend'. + configInstallDirs = + (configInstallDirs . savedConfigureFlags $ a) + `mappend` (configInstallDirs . savedConfigureFlags $ b), + configScratchDir = combine configScratchDir, + -- TODO: NubListify + configExtraLibDirs = lastNonEmpty configExtraLibDirs, + configExtraLibDirsStatic = lastNonEmpty configExtraLibDirsStatic, + -- TODO: NubListify + configExtraFrameworkDirs = lastNonEmpty configExtraFrameworkDirs, + -- TODO: NubListify + configExtraIncludeDirs = lastNonEmpty configExtraIncludeDirs, + configDeterministic = combine configDeterministic, + configIPID = combine configIPID, + configCID = combine configCID, + configDistPref = combine configDistPref, + configCabalFilePath = combine configCabalFilePath, + configVerbosity = combine configVerbosity, + configUserInstall = combine configUserInstall, + -- TODO: NubListify + configPackageDBs = lastNonEmpty configPackageDBs, + configGHCiLib = combine configGHCiLib, + configSplitSections = combine configSplitSections, + configSplitObjs = combine configSplitObjs, + configStripExes = combine configStripExes, + configStripLibs = combine configStripLibs, + -- TODO: NubListify + configConstraints = lastNonEmpty configConstraints, + -- TODO: NubListify + configDependencies = lastNonEmpty configDependencies, + -- TODO: NubListify + configConfigurationsFlags = lastNonMempty configConfigurationsFlags, + configTests = combine configTests, + configBenchmarks = combine configBenchmarks, + configCoverage = combine configCoverage, + configLibCoverage = combine configLibCoverage, + configExactConfiguration = combine configExactConfiguration, + configFlagError = combine configFlagError, + configRelocatable = combine configRelocatable, + configUseResponseFiles = combine configUseResponseFiles, + configDumpBuildInfo = combine configDumpBuildInfo, + configAllowDependingOnPrivateLibs = + combine configAllowDependingOnPrivateLibs + } + where + combine = combine' savedConfigureFlags + lastNonEmpty = lastNonEmpty' savedConfigureFlags + lastNonEmptyNL = lastNonEmptyNL' savedConfigureFlags + lastNonMempty = lastNonMempty' savedConfigureFlags + + combinedSavedConfigureExFlags = ConfigExFlags { + configCabalVersion = combine configCabalVersion, + configAppend = combine configAppend, + configBackup = combine configBackup, + -- TODO: NubListify + configExConstraints = lastNonEmpty configExConstraints, + -- TODO: NubListify + configPreferences = lastNonEmpty configPreferences, + configSolver = combine configSolver, + configAllowNewer = + combineMonoid savedConfigureExFlags configAllowNewer, + configAllowOlder = + combineMonoid savedConfigureExFlags configAllowOlder, + configWriteGhcEnvironmentFilesPolicy + = combine configWriteGhcEnvironmentFilesPolicy + } + where + combine = combine' savedConfigureExFlags + lastNonEmpty = lastNonEmpty' savedConfigureExFlags + + -- Parametrised by (Flag PathTemplate), so safe to use 'mappend'. + combinedSavedUserInstallDirs = savedUserInstallDirs a + `mappend` savedUserInstallDirs b + + -- Parametrised by (Flag PathTemplate), so safe to use 'mappend'. + combinedSavedGlobalInstallDirs = savedGlobalInstallDirs a + `mappend` savedGlobalInstallDirs b + + combinedSavedUploadFlags = UploadFlags { + uploadCandidate = combine uploadCandidate, + uploadDoc = combine uploadDoc, + uploadUsername = combine uploadUsername, + uploadPassword = combine uploadPassword, + uploadPasswordCmd = combine uploadPasswordCmd, + uploadVerbosity = combine uploadVerbosity + } + where + combine = combine' savedUploadFlags + + combinedSavedReportFlags = ReportFlags { + reportUsername = combine reportUsername, + reportPassword = combine reportPassword, + reportVerbosity = combine reportVerbosity + } + where + combine = combine' savedReportFlags + + combinedSavedHaddockFlags = HaddockFlags { + -- TODO: NubListify + haddockProgramPaths = lastNonEmpty haddockProgramPaths, + -- TODO: NubListify + haddockProgramArgs = lastNonEmpty haddockProgramArgs, + haddockHoogle = combine haddockHoogle, + haddockHtml = combine haddockHtml, + haddockHtmlLocation = combine haddockHtmlLocation, + haddockForHackage = combine haddockForHackage, + haddockExecutables = combine haddockExecutables, + haddockTestSuites = combine haddockTestSuites, + haddockBenchmarks = combine haddockBenchmarks, + haddockForeignLibs = combine haddockForeignLibs, + haddockInternal = combine haddockInternal, + haddockCss = combine haddockCss, + haddockLinkedSource = combine haddockLinkedSource, + haddockQuickJump = combine haddockQuickJump, + haddockHscolourCss = combine haddockHscolourCss, + haddockContents = combine haddockContents, + haddockDistPref = combine haddockDistPref, + haddockKeepTempFiles = combine haddockKeepTempFiles, + haddockVerbosity = combine haddockVerbosity, + haddockCabalFilePath = combine haddockCabalFilePath, + haddockArgs = lastNonEmpty haddockArgs + } + where + combine = combine' savedHaddockFlags + lastNonEmpty = lastNonEmpty' savedHaddockFlags + + combinedSavedTestFlags = TestFlags { + testDistPref = combine testDistPref, + testVerbosity = combine testVerbosity, + testHumanLog = combine testHumanLog, + testMachineLog = combine testMachineLog, + testShowDetails = combine testShowDetails, + testKeepTix = combine testKeepTix, + testWrapper = combine testWrapper, + testFailWhenNoTestSuites = combine testFailWhenNoTestSuites, + testOptions = lastNonEmpty testOptions + } + where + combine = combine' savedTestFlags + lastNonEmpty = lastNonEmpty' savedTestFlags + + combinedSavedBenchmarkFlags = BenchmarkFlags { + benchmarkDistPref = combine benchmarkDistPref, + benchmarkVerbosity = combine benchmarkVerbosity, + benchmarkOptions = lastNonEmpty benchmarkOptions + } + where + combine = combine' savedBenchmarkFlags + lastNonEmpty = lastNonEmpty' savedBenchmarkFlags + + combinedSavedProjectFlags = ProjectFlags + { flagProjectFileName = combine flagProjectFileName + , flagIgnoreProject = combine flagIgnoreProject + } + where + combine = combine' savedProjectFlags + +-- +-- * Default config +-- + +-- | These are the absolute basic defaults. The fields that must be +-- initialised. When we load the config from the file we layer the loaded +-- values over these ones, so any missing fields in the file take their values +-- from here. +-- +baseSavedConfig :: IO SavedConfig +baseSavedConfig = do + userPrefix <- getCabalDir + cacheDir <- defaultCacheDir + logsDir <- defaultLogsDir + return mempty { + savedConfigureFlags = mempty { + configHcFlavor = toFlag defaultCompiler, + configUserInstall = toFlag defaultUserInstall, + configVerbosity = toFlag normal + }, + savedUserInstallDirs = mempty { + prefix = toFlag (toPathTemplate userPrefix) + }, + savedGlobalFlags = mempty { + globalCacheDir = toFlag cacheDir, + globalLogsDir = toFlag logsDir + } + } + +-- | This is the initial configuration that we write out to the config file +-- if the file does not exist (or the config we use if the file cannot be read +-- for some other reason). When the config gets loaded it gets layered on top +-- of 'baseSavedConfig' so we do not need to include it into the initial +-- values we save into the config file. +-- +initialSavedConfig :: IO SavedConfig +initialSavedConfig = do + cacheDir <- defaultCacheDir + logsDir <- defaultLogsDir + extraPath <- defaultExtraPath + installPath <- defaultInstallPath + return mempty { + savedGlobalFlags = mempty { + globalCacheDir = toFlag cacheDir, + globalRemoteRepos = toNubList [defaultRemoteRepo] + }, + savedConfigureFlags = mempty { + configProgramPathExtra = toNubList extraPath + }, + savedInstallFlags = mempty { + installSummaryFile = toNubList [toPathTemplate (logsDir "build.log")], + installBuildReports= toFlag NoReports, + installNumJobs = toFlag Nothing + }, + savedClientInstallFlags = mempty { + cinstInstalldir = toFlag installPath + } + } + +defaultCabalDir :: IO FilePath +defaultCabalDir = getAppUserDataDirectory "cabal" + +getCabalDir :: IO FilePath +getCabalDir = do + mDir <- lookupEnv "CABAL_DIR" + case mDir of + Nothing -> defaultCabalDir + Just dir -> return dir + +defaultConfigFile :: IO FilePath +defaultConfigFile = do + dir <- getCabalDir + return $ dir "config" + +defaultCacheDir :: IO FilePath +defaultCacheDir = do + dir <- getCabalDir + return $ dir "packages" + +defaultLogsDir :: IO FilePath +defaultLogsDir = do + dir <- getCabalDir + return $ dir "logs" + +defaultExtraPath :: IO [FilePath] +defaultExtraPath = do + dir <- getCabalDir + return [dir "bin"] + +defaultInstallPath :: IO FilePath +defaultInstallPath = do + dir <- getCabalDir + return (dir "bin") + +defaultCompiler :: CompilerFlavor +defaultCompiler = fromMaybe GHC defaultCompilerFlavor + +defaultUserInstall :: Bool +defaultUserInstall = True +-- We do per-user installs by default on all platforms. We used to default to +-- global installs on Windows but that no longer works on Windows Vista or 7. + +defaultRemoteRepo :: RemoteRepo +defaultRemoteRepo = RemoteRepo name uri Nothing [] 0 False + where + str = "hackage.haskell.org" + name = RepoName str + uri = URI "http:" (Just (URIAuth "" str "")) "/" "" "" + -- Note that lots of old ~/.cabal/config files will have the old url + -- http://hackage.haskell.org/packages/archive + -- but new config files can use the new url (without the /packages/archive) + -- and avoid having to do a http redirect + +-- For the default repo we know extra information, fill this in. +-- +-- We need this because the 'defaultRemoteRepo' above is only used for the +-- first time when a config file is made. So for users with older config files +-- we might have only have older info. This lets us fill that in even for old +-- config files. +-- +addInfoForKnownRepos :: RemoteRepo -> RemoteRepo +addInfoForKnownRepos repo + | remoteRepoName repo == remoteRepoName defaultRemoteRepo + = useSecure . tryHttps . fixOldURI $ repo + where + fixOldURI r + | isOldHackageURI (remoteRepoURI r) + = r { remoteRepoURI = remoteRepoURI defaultRemoteRepo } + | otherwise = r + + tryHttps r = r { remoteRepoShouldTryHttps = True } + + useSecure r@RemoteRepo{ + remoteRepoSecure = secure, + remoteRepoRootKeys = [], + remoteRepoKeyThreshold = 0 + } | secure /= Just False + = r { + -- Use hackage-security by default unless you opt-out with + -- secure: False + remoteRepoSecure = Just True, + remoteRepoRootKeys = defaultHackageRemoteRepoKeys, + remoteRepoKeyThreshold = defaultHackageRemoteRepoKeyThreshold + } + useSecure r = r +addInfoForKnownRepos other = other + +-- | The current hackage.haskell.org repo root keys that we ship with cabal. +--- +-- This lets us bootstrap trust in this repo without user intervention. +-- These keys need to be periodically updated when new root keys are added. +-- See the root key procedures for details. +-- +defaultHackageRemoteRepoKeys :: [String] +defaultHackageRemoteRepoKeys = + [ "fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0", + "1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42", + "2c6c3627bd6c982990239487f1abd02e08a02e6cf16edb105a8012d444d870c3", + "0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d", + "51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921" + ] + +-- | The required threshold of root key signatures for hackage.haskell.org +-- +defaultHackageRemoteRepoKeyThreshold :: Int +defaultHackageRemoteRepoKeyThreshold = 3 + +-- +-- * Config file reading +-- + +-- | Loads the main configuration, and applies additional defaults to give the +-- effective configuration. To loads just what is actually in the config file, +-- use 'loadRawConfig'. +-- +loadConfig :: Verbosity -> Flag FilePath -> IO SavedConfig +loadConfig verbosity configFileFlag = do + config <- loadRawConfig verbosity configFileFlag + extendToEffectiveConfig config + +extendToEffectiveConfig :: SavedConfig -> IO SavedConfig +extendToEffectiveConfig config = do + base <- baseSavedConfig + let effective0 = base `mappend` config + globalFlags0 = savedGlobalFlags effective0 + effective = effective0 { + savedGlobalFlags = globalFlags0 { + globalRemoteRepos = + overNubList (map addInfoForKnownRepos) + (globalRemoteRepos globalFlags0) + } + } + return effective + +-- | Like 'loadConfig' but does not apply any additional defaults, it just +-- loads what is actually in the config file. This is thus suitable for +-- comparing or editing a config file, but not suitable for using as the +-- effective configuration. +-- +loadRawConfig :: Verbosity -> Flag FilePath -> IO SavedConfig +loadRawConfig verbosity configFileFlag = do + (source, configFile) <- getConfigFilePathAndSource configFileFlag + minp <- readConfigFile mempty configFile + case minp of + Nothing -> do + notice verbosity $ + "Config file path source is " ++ sourceMsg source ++ "." + -- 2021-10-07, issue #7705 + -- Only create default config file if name was not given explicitly + -- via option --config-file or environment variable. + case source of + Default -> do + notice verbosity msgNotFound + createDefaultConfigFile verbosity [] configFile + CommandlineOption -> failNoConfigFile + EnvironmentVariable -> failNoConfigFile + where + msgNotFound = unwords [ "Config file not found:", configFile ] + failNoConfigFile = die' verbosity $ unlines + [ msgNotFound + , "(Config files can be created via the cabal-command 'user-config init'.)" + ] + Just (ParseOk ws conf) -> do + unless (null ws) $ warn verbosity $ + unlines (map (showPWarning configFile) ws) + return conf + Just (ParseFailed err) -> do + let (line, msg) = locatedErrorMsg err + die' verbosity $ + "Error parsing config file " ++ configFile + ++ maybe "" (\n -> ':' : show n) line ++ ":\n" ++ msg + + where + sourceMsg CommandlineOption = "commandline option" + sourceMsg EnvironmentVariable = "environment variable CABAL_CONFIG" + sourceMsg Default = "default config file" + +-- | Provenance of the config file. + +data ConfigFileSource = CommandlineOption + | EnvironmentVariable + | Default + +-- | Returns the config file path, without checking that the file exists. +-- The order of precedence is: input flag, CABAL_CONFIG, default location. +getConfigFilePath :: Flag FilePath -> IO FilePath +getConfigFilePath = fmap snd . getConfigFilePathAndSource + +getConfigFilePathAndSource :: Flag FilePath -> IO (ConfigFileSource, FilePath) +getConfigFilePathAndSource configFileFlag = + getSource sources + where + sources = + [ (CommandlineOption, return . flagToMaybe $ configFileFlag) + , (EnvironmentVariable, lookup "CABAL_CONFIG" `liftM` getEnvironment) + , (Default, Just `liftM` defaultConfigFile) ] + + getSource [] = error "no config file path candidate found." + getSource ((source,action): xs) = + action >>= maybe (getSource xs) (return . (,) source) + +readConfigFile + :: SavedConfig -> FilePath -> IO (Maybe (ParseResult SavedConfig)) +readConfigFile initial file = handleNotExists $ + fmap (Just . parseConfig (ConstraintSourceMainConfig file) initial) + (BS.readFile file) + + where + handleNotExists action = catchIO action $ \ioe -> + if isDoesNotExistError ioe + then return Nothing + else ioError ioe + +createDefaultConfigFile :: Verbosity -> [String] -> FilePath -> IO SavedConfig +createDefaultConfigFile verbosity extraLines filePath = do + commentConf <- commentSavedConfig + initialConf <- initialSavedConfig + extraConf <- parseExtraLines verbosity extraLines + notice verbosity $ "Writing default configuration to " ++ filePath + writeConfigFile filePath commentConf (initialConf `mappend` extraConf) + return initialConf + +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 + where + explanation = unlines + ["-- This is the configuration file for the 'cabal' command line tool." + ,"--" + ,"-- The available configuration options are listed below." + ,"-- Some of them have default values listed." + ,"--" + ,"-- Lines (like this one) beginning with '--' are comments." + ,"-- Be careful with spaces and indentation because they are" + ,"-- used to indicate layout for nested sections." + ,"--" + ,"-- This config file was generated using the following versions" + ,"-- of Cabal and cabal-install:" + ,"-- Cabal library version: " ++ prettyShow cabalVersion + ,"-- cabal-install version: " ++ prettyShow cabalInstallVersion + ,"","" + ] + +-- | These are the default values that get used in Cabal if a no value is +-- given. We use these here to include in comments when we write out the +-- initial config file so that the user can see what default value they are +-- overriding. +-- +commentSavedConfig :: IO SavedConfig +commentSavedConfig = do + userInstallDirs <- defaultInstallDirs defaultCompiler True True + globalInstallDirs <- defaultInstallDirs defaultCompiler False True + let conf0 = mempty { + savedGlobalFlags = defaultGlobalFlags { + globalRemoteRepos = toNubList [defaultRemoteRepo] + }, + savedInitFlags = mempty { + IT.interactive = toFlag False, + IT.cabalVersion = toFlag IT.defaultCabalVersion, + IT.language = toFlag Haskell2010, + IT.license = NoFlag, + IT.sourceDirs = Flag [IT.defaultSourceDir], + IT.applicationDirs = Flag [IT.defaultApplicationDir] + }, + savedInstallFlags = defaultInstallFlags, + savedClientInstallFlags= defaultClientInstallFlags, + savedConfigureExFlags = defaultConfigExFlags { + configAllowNewer = Just (AllowNewer mempty), + configAllowOlder = Just (AllowOlder mempty) + }, + savedConfigureFlags = (defaultConfigFlags defaultProgramDb) { + configUserInstall = toFlag defaultUserInstall + }, + savedUserInstallDirs = fmap toFlag userInstallDirs, + savedGlobalInstallDirs = fmap toFlag globalInstallDirs, + savedUploadFlags = commandDefaultFlags uploadCommand, + savedReportFlags = commandDefaultFlags reportCommand, + savedHaddockFlags = defaultHaddockFlags, + savedTestFlags = defaultTestFlags, + savedBenchmarkFlags = defaultBenchmarkFlags + } + conf1 <- extendToEffectiveConfig conf0 + let globalFlagsConf1 = savedGlobalFlags conf1 + conf2 = conf1 { + savedGlobalFlags = globalFlagsConf1 { + globalRemoteRepos = overNubList (map removeRootKeys) + (globalRemoteRepos globalFlagsConf1) + } + } + return conf2 + where + -- Most people don't want to see default root keys, so don't print them. + removeRootKeys :: RemoteRepo -> RemoteRepo + removeRootKeys r = r { remoteRepoRootKeys = [] } + +-- | All config file fields. +-- +configFieldDescriptions :: ConstraintSource -> [FieldDescr SavedConfig] +configFieldDescriptions src = + + toSavedConfig liftGlobalFlag + (commandOptions (globalCommand []) ParseArgs) + ["version", "numeric-version", "config-file"] [] + + ++ toSavedConfig liftConfigFlag + (configureOptions ParseArgs) + (["builddir", "constraint", "dependency", "ipid"] + ++ map fieldName installDirsFields) + + -- This is only here because viewAsFieldDescr gives us a parser + -- that only recognises 'ghc' etc, the case-sensitive flag names, not + -- what the normal case-insensitive parser gives us. + [simpleFieldParsec "compiler" + (fromFlagOrDefault Disp.empty . fmap pretty) (Flag <$> parsec <|> pure NoFlag) + configHcFlavor (\v flags -> flags { configHcFlavor = v }) + + -- TODO: The following is a temporary fix. The "optimization" + -- and "debug-info" fields are OptArg, and viewAsFieldDescr + -- fails on that. Instead of a hand-written hackaged parser + -- and printer, we should handle this case properly in the + -- library. + ,liftField configOptimization (\v flags -> + flags { configOptimization = v }) $ + let name = "optimization" in + FieldDescr name + (\f -> case f of + Flag NoOptimisation -> Disp.text "False" + Flag NormalOptimisation -> Disp.text "True" + Flag MaximumOptimisation -> Disp.text "2" + _ -> Disp.empty) + (\line str _ -> case () of + _ | str == "False" -> ParseOk [] (Flag NoOptimisation) + | str == "True" -> ParseOk [] (Flag NormalOptimisation) + | str == "0" -> ParseOk [] (Flag NoOptimisation) + | str == "1" -> ParseOk [] (Flag NormalOptimisation) + | str == "2" -> ParseOk [] (Flag MaximumOptimisation) + | lstr == "false" -> ParseOk [caseWarning] (Flag NoOptimisation) + | lstr == "true" -> ParseOk [caseWarning] + (Flag NormalOptimisation) + | otherwise -> ParseFailed (NoParse name line) + where + lstr = lowercase str + caseWarning = PWarning $ + "The '" ++ name + ++ "' field is case sensitive, use 'True' or 'False'.") + ,liftField configDebugInfo (\v flags -> flags { configDebugInfo = v }) $ + let name = "debug-info" in + FieldDescr name + (\f -> case f of + Flag NoDebugInfo -> Disp.text "False" + Flag MinimalDebugInfo -> Disp.text "1" + Flag NormalDebugInfo -> Disp.text "True" + Flag MaximalDebugInfo -> Disp.text "3" + _ -> Disp.empty) + (\line str _ -> case () of + _ | str == "False" -> ParseOk [] (Flag NoDebugInfo) + | str == "True" -> ParseOk [] (Flag NormalDebugInfo) + | str == "0" -> ParseOk [] (Flag NoDebugInfo) + | str == "1" -> ParseOk [] (Flag MinimalDebugInfo) + | str == "2" -> ParseOk [] (Flag NormalDebugInfo) + | str == "3" -> ParseOk [] (Flag MaximalDebugInfo) + | lstr == "false" -> ParseOk [caseWarning] (Flag NoDebugInfo) + | lstr == "true" -> ParseOk [caseWarning] (Flag NormalDebugInfo) + | otherwise -> ParseFailed (NoParse name line) + where + lstr = lowercase str + caseWarning = PWarning $ + "The '" ++ name + ++ "' field is case sensitive, use 'True' or 'False'.") + ] + + ++ toSavedConfig liftConfigExFlag + (configureExOptions ParseArgs src) + [] + [let pkgs = (Just . AllowOlder . RelaxDepsSome) + `fmap` parsecOptCommaList parsec + parseAllowOlder = ((Just . AllowOlder . toRelaxDeps) + `fmap` parsec) <|> pkgs + in simpleFieldParsec "allow-older" + (showRelaxDeps . fmap unAllowOlder) parseAllowOlder + configAllowOlder (\v flags -> flags { configAllowOlder = v }) + ,let pkgs = (Just . AllowNewer . RelaxDepsSome) + `fmap` parsecOptCommaList parsec + parseAllowNewer = ((Just . AllowNewer . toRelaxDeps) + `fmap` parsec) <|> pkgs + in simpleFieldParsec "allow-newer" + (showRelaxDeps . fmap unAllowNewer) parseAllowNewer + configAllowNewer (\v flags -> flags { configAllowNewer = v }) + ] + + ++ toSavedConfig liftInstallFlag + (installOptions ParseArgs) + ["dry-run", "only", "only-dependencies", "dependencies-only"] [] + + ++ toSavedConfig liftClientInstallFlag + (clientInstallOptions ParseArgs) + [] [] + + ++ toSavedConfig liftUploadFlag + (commandOptions uploadCommand ParseArgs) + ["verbose", "check", "documentation", "publish"] [] + + ++ toSavedConfig liftReportFlag + (commandOptions reportCommand ParseArgs) + ["verbose", "username", "password"] [] + --FIXME: this is a hack, hiding the user name and password. + -- But otherwise it masks the upload ones. Either need to + -- share the options or make then distinct. In any case + -- they should probably be per-server. + + ++ [ viewAsFieldDescr + $ optionDistPref + (configDistPref . savedConfigureFlags) + (\distPref config -> + config + { savedConfigureFlags = (savedConfigureFlags config) { + configDistPref = distPref } + , savedHaddockFlags = (savedHaddockFlags config) { + haddockDistPref = distPref } + } + ) + ParseArgs + ] + + where + toSavedConfig lift options exclusions replacements = + [ lift (fromMaybe field replacement) + | opt <- options + , let field = viewAsFieldDescr opt + name = fieldName field + replacement = find ((== name) . fieldName) replacements + , name `notElem` exclusions ] + + showRelaxDeps Nothing = mempty + showRelaxDeps (Just rd) | isRelaxDeps rd = Disp.text "True" + | otherwise = Disp.text "False" + + toRelaxDeps True = RelaxDepsAll + toRelaxDeps False = mempty + + +-- TODO: next step, make the deprecated fields elicit a warning. +-- +deprecatedFieldDescriptions :: [FieldDescr SavedConfig] +deprecatedFieldDescriptions = + [ liftGlobalFlag $ + listFieldParsec "repos" + pretty parsec + (fromNubList . globalRemoteRepos) + (\rs cfg -> cfg { globalRemoteRepos = toNubList rs }) + , liftGlobalFlag $ + simpleFieldParsec "cachedir" + (Disp.text . fromFlagOrDefault "") (optionalFlag parsecFilePath) + globalCacheDir (\d cfg -> cfg { globalCacheDir = d }) + , liftUploadFlag $ + simpleFieldParsec "hackage-username" + (Disp.text . fromFlagOrDefault "" . fmap unUsername) + (optionalFlag (fmap Username parsecToken)) + uploadUsername (\d cfg -> cfg { uploadUsername = d }) + , liftUploadFlag $ + simpleFieldParsec "hackage-password" + (Disp.text . fromFlagOrDefault "" . fmap unPassword) + (optionalFlag (fmap Password parsecToken)) + uploadPassword (\d cfg -> cfg { uploadPassword = d }) + , liftUploadFlag $ + spaceListField "hackage-password-command" + Disp.text parseTokenQ + (fromFlagOrDefault [] . uploadPasswordCmd) + (\d cfg -> cfg { uploadPasswordCmd = Flag d }) + ] + ++ map (modifyFieldName ("user-"++) . liftUserInstallDirs) + installDirsFields + ++ map (modifyFieldName ("global-"++) . liftGlobalInstallDirs) + installDirsFields + where + optionalFlag :: ParsecParser a -> ParsecParser (Flag a) + optionalFlag p = toFlag <$> p <|> pure mempty + + modifyFieldName :: (String -> String) -> FieldDescr a -> FieldDescr a + modifyFieldName f d = d { fieldName = f (fieldName d) } + +liftUserInstallDirs :: FieldDescr (InstallDirs (Flag PathTemplate)) + -> FieldDescr SavedConfig +liftUserInstallDirs = liftField + savedUserInstallDirs (\flags conf -> conf { savedUserInstallDirs = flags }) + +liftGlobalInstallDirs :: FieldDescr (InstallDirs (Flag PathTemplate)) + -> FieldDescr SavedConfig +liftGlobalInstallDirs = + liftField savedGlobalInstallDirs + (\flags conf -> conf { savedGlobalInstallDirs = flags }) + +liftGlobalFlag :: FieldDescr GlobalFlags -> FieldDescr SavedConfig +liftGlobalFlag = liftField + savedGlobalFlags (\flags conf -> conf { savedGlobalFlags = flags }) + +liftConfigFlag :: FieldDescr ConfigFlags -> FieldDescr SavedConfig +liftConfigFlag = liftField + savedConfigureFlags (\flags conf -> conf { savedConfigureFlags = flags }) + +liftConfigExFlag :: FieldDescr ConfigExFlags -> FieldDescr SavedConfig +liftConfigExFlag = liftField + savedConfigureExFlags (\flags conf -> conf { savedConfigureExFlags = flags }) + +liftInstallFlag :: FieldDescr InstallFlags -> FieldDescr SavedConfig +liftInstallFlag = liftField + savedInstallFlags (\flags conf -> conf { savedInstallFlags = flags }) + +liftClientInstallFlag :: FieldDescr ClientInstallFlags -> FieldDescr SavedConfig +liftClientInstallFlag = + liftField savedClientInstallFlags + (\flags conf -> conf { savedClientInstallFlags = flags }) + +liftUploadFlag :: FieldDescr UploadFlags -> FieldDescr SavedConfig +liftUploadFlag = liftField + savedUploadFlags (\flags conf -> conf { savedUploadFlags = flags }) + +liftReportFlag :: FieldDescr ReportFlags -> FieldDescr SavedConfig +liftReportFlag = liftField + savedReportFlags (\flags conf -> conf { savedReportFlags = flags }) + +parseConfig :: ConstraintSource + -> SavedConfig + -> BS.ByteString + -> ParseResult SavedConfig +parseConfig src initial = \str -> do + fields <- readFields str + let (knownSections, others) = partition isKnownSection fields + config <- parse others + let init0 = savedInitFlags config + user0 = savedUserInstallDirs config + global0 = savedGlobalInstallDirs config + (remoteRepoSections0, localRepoSections0, haddockFlags, initFlags, user, global, paths, args) <- + foldM parseSections + ([], [], savedHaddockFlags config, init0, user0, global0, [], []) + knownSections + + let remoteRepoSections = + reverse + . nubBy ((==) `on` remoteRepoName) + $ remoteRepoSections0 + + let localRepoSections = + reverse + . nubBy ((==) `on` localRepoName) + $ localRepoSections0 + + return . fixConfigMultilines $ config { + savedGlobalFlags = (savedGlobalFlags config) { + globalRemoteRepos = toNubList remoteRepoSections, + globalLocalNoIndexRepos = toNubList localRepoSections, + -- the global extra prog path comes from the configure flag prog path + globalProgPathExtra = configProgramPathExtra (savedConfigureFlags config) + }, + savedConfigureFlags = (savedConfigureFlags config) { + configProgramPaths = paths, + configProgramArgs = args + }, + savedHaddockFlags = haddockFlags, + savedInitFlags = initFlags, + savedUserInstallDirs = user, + savedGlobalInstallDirs = global + } + + where + isKnownSection (ParseUtils.Section _ "repository" _ _) = True + isKnownSection (ParseUtils.F _ "remote-repo" _) = True + isKnownSection (ParseUtils.Section _ "haddock" _ _) = True + isKnownSection (ParseUtils.Section _ "init" _ _) = True + isKnownSection (ParseUtils.Section _ "install-dirs" _ _) = True + isKnownSection (ParseUtils.Section _ "program-locations" _ _) = True + isKnownSection (ParseUtils.Section _ "program-default-options" _ _) = True + isKnownSection _ = False + + -- Attempt to split fields that can represent lists of paths into + -- actual lists on failure, leave the field untouched. + splitMultiPath :: [String] -> [String] + splitMultiPath [s] = case runP 0 "" (parseOptCommaList parseTokenQ) s of + ParseOk _ res -> res + _ -> [s] + splitMultiPath xs = xs + + -- This is a fixup, pending a full config parser rewrite, to + -- ensure that config fields which can be comma-separated lists + -- actually parse as comma-separated lists. + fixConfigMultilines conf = conf { + savedConfigureFlags = + let scf = savedConfigureFlags conf + in scf { + configProgramPathExtra = + toNubList $ splitMultiPath + (fromNubList $ configProgramPathExtra scf) + , configExtraLibDirs = splitMultiPath + (configExtraLibDirs scf) + , configExtraLibDirsStatic = splitMultiPath + (configExtraLibDirsStatic scf) + , configExtraFrameworkDirs = splitMultiPath + (configExtraFrameworkDirs scf) + , configExtraIncludeDirs = splitMultiPath + (configExtraIncludeDirs scf) + , configConfigureArgs = splitMultiPath + (configConfigureArgs scf) + } + } + + parse = parseFields (configFieldDescriptions src + ++ deprecatedFieldDescriptions) initial + + parseSections (rs, ls, h, i, u, g, p, a) + (ParseUtils.Section lineno "repository" name fs) = do + name' <- maybe (ParseFailed $ NoParse "repository name" lineno) return $ + simpleParsec name + r' <- parseFields remoteRepoFields (emptyRemoteRepo name') fs + r'' <- postProcessRepo lineno name r' + case r'' of + Left local -> return (rs, local:ls, h, i, u, g, p, a) + Right remote -> return (remote:rs, ls, h, i, u, g, p, a) + + parseSections (rs, ls, h, i, u, g, p, a) + (ParseUtils.F lno "remote-repo" raw) = do + let mr' = simpleParsec raw + r' <- maybe (ParseFailed $ NoParse "remote-repo" lno) return mr' + return (r':rs, ls, h, i, u, g, p, a) + + parseSections accum@(rs, ls, h, i, u, g, p, a) + (ParseUtils.Section _ "haddock" name fs) + | name == "" = do h' <- parseFields haddockFlagsFields h fs + return (rs, ls, h', i, u, g, p, a) + | otherwise = do + warning "The 'haddock' section should be unnamed" + return accum + + parseSections accum@(rs, ls, h, i, u, g, p, a) + (ParseUtils.Section _ "init" name fs) + | name == "" = do i' <- parseFields initFlagsFields i fs + return (rs, ls, h, i', u, g, p, a) + | otherwise = do + warning "The 'init' section should be unnamed" + return accum + + parseSections accum@(rs, ls, h, i, u, g, p, a) + (ParseUtils.Section _ "install-dirs" name fs) + | name' == "user" = do u' <- parseFields installDirsFields u fs + return (rs, ls, h, i, u', g, p, a) + | name' == "global" = do g' <- parseFields installDirsFields g fs + return (rs, ls, h, i, u, g', p, a) + | otherwise = do + warning "The 'install-paths' section should be for 'user' or 'global'" + return accum + where name' = lowercase name + parseSections accum@(rs, ls, h, i, u, g, p, a) + (ParseUtils.Section _ "program-locations" name fs) + | name == "" = do p' <- parseFields withProgramsFields p fs + return (rs, ls, h, i, u, g, p', a) + | otherwise = do + warning "The 'program-locations' section should be unnamed" + return accum + parseSections accum@(rs, ls, h, i, u, g, p, a) + (ParseUtils.Section _ "program-default-options" name fs) + | name == "" = do a' <- parseFields withProgramOptionsFields a fs + return (rs, ls, h, i, u, g, p, a') + | otherwise = do + warning "The 'program-default-options' section should be unnamed" + return accum + parseSections accum f = do + warning $ "Unrecognized stanza on line " ++ show (lineNo f) + return accum + +postProcessRepo :: Int -> String -> RemoteRepo -> ParseResult (Either LocalRepo RemoteRepo) +postProcessRepo lineno reponameStr repo0 = do + when (null reponameStr) $ + syntaxError lineno $ "a 'repository' section requires the " + ++ "repository name as an argument" + + reponame <- maybe (fail $ "Invalid repository name " ++ reponameStr) return $ + simpleParsec reponameStr + + case uriScheme (remoteRepoURI repo0) of + -- TODO: check that there are no authority, query or fragment + -- Note: the trailing colon is important + "file+noindex:" -> do + let uri = remoteRepoURI repo0 + return $ Left $ LocalRepo reponame (uriPath uri) (uriFragment uri == "#shared-cache") + + _ -> do + let repo = repo0 { remoteRepoName = reponame } + + when (remoteRepoKeyThreshold repo > length (remoteRepoRootKeys repo)) $ + warning $ "'key-threshold' for repository " + ++ show (remoteRepoName repo) + ++ " higher than number of keys" + + when (not (null (remoteRepoRootKeys repo)) && remoteRepoSecure repo /= Just True) $ + warning $ "'root-keys' for repository " + ++ show (remoteRepoName repo) + ++ " non-empty, but 'secure' not set to True." + + return $ Right repo + +showConfig :: SavedConfig -> String +showConfig = showConfigWithComments mempty + +showConfigWithComments :: SavedConfig -> SavedConfig -> String +showConfigWithComments comment vals = Disp.render $ + case fmap (uncurry ppRemoteRepoSection) + (zip (getRemoteRepos comment) (getRemoteRepos vals)) of + [] -> Disp.text "" + (x:xs) -> foldl' (\ r r' -> r $+$ Disp.text "" $+$ r') x xs + $+$ Disp.text "" + $+$ ppFields + (skipSomeFields (configFieldDescriptions ConstraintSourceUnknown)) + mcomment vals + $+$ Disp.text "" + $+$ ppSection "haddock" "" haddockFlagsFields + (fmap savedHaddockFlags mcomment) (savedHaddockFlags vals) + $+$ Disp.text "" + $+$ ppSection "init" "" initFlagsFields + (fmap savedInitFlags mcomment) (savedInitFlags vals) + $+$ Disp.text "" + $+$ installDirsSection "user" savedUserInstallDirs + $+$ Disp.text "" + $+$ installDirsSection "global" savedGlobalInstallDirs + $+$ Disp.text "" + $+$ configFlagsSection "program-locations" withProgramsFields + configProgramPaths + $+$ Disp.text "" + $+$ configFlagsSection "program-default-options" withProgramOptionsFields + configProgramArgs + where + getRemoteRepos = fromNubList . globalRemoteRepos . savedGlobalFlags + mcomment = Just comment + installDirsSection name field = + ppSection "install-dirs" name installDirsFields + (fmap field mcomment) (field vals) + configFlagsSection name fields field = + ppSection name "" fields + (fmap (field . savedConfigureFlags) mcomment) + ((field . savedConfigureFlags) vals) + + -- skip fields based on field name. currently only skips "remote-repo", + -- because that is rendered as a section. (see 'ppRemoteRepoSection'.) + skipSomeFields = filter ((/= "remote-repo") . fieldName) + +-- | Fields for the 'install-dirs' sections. +installDirsFields :: [FieldDescr (InstallDirs (Flag PathTemplate))] +installDirsFields = map viewAsFieldDescr installDirsOptions + +ppRemoteRepoSection :: RemoteRepo -> RemoteRepo -> Doc +ppRemoteRepoSection def vals = ppSection "repository" (unRepoName (remoteRepoName vals)) + remoteRepoFields (Just def) vals + +remoteRepoFields :: [FieldDescr RemoteRepo] +remoteRepoFields = + [ simpleField "url" + (text . show) (parseTokenQ >>= parseURI') + remoteRepoURI (\x repo -> repo { remoteRepoURI = x }) + , simpleFieldParsec "secure" + showSecure (Just `fmap` parsec) + remoteRepoSecure (\x repo -> repo { remoteRepoSecure = x }) + , listField "root-keys" + text parseTokenQ + remoteRepoRootKeys (\x repo -> repo { remoteRepoRootKeys = x }) + , simpleFieldParsec "key-threshold" + showThreshold P.integral + remoteRepoKeyThreshold (\x repo -> repo { remoteRepoKeyThreshold = x }) + ] + where + parseURI' uriString = + case parseURI uriString of + Nothing -> fail $ "remote-repo: no parse on " ++ show uriString + Just uri -> return uri + + showSecure Nothing = mempty -- default 'secure' setting + showSecure (Just True) = text "True" -- user explicitly enabled it + showSecure (Just False) = text "False" -- user explicitly disabled it + + -- If the key-threshold is set to 0, we omit it as this is the default + -- and it looks odd to have a value for key-threshold but not for 'secure' + -- (note that an empty list of keys is already omitted by default, since + -- that is what we do for all list fields) + showThreshold 0 = mempty + showThreshold t = text (show t) + +-- | Fields for the 'haddock' section. +haddockFlagsFields :: [FieldDescr HaddockFlags] +haddockFlagsFields = [ field + | opt <- haddockOptions ParseArgs + , let field = viewAsFieldDescr opt + name = fieldName field + , name `notElem` exclusions ] + where + exclusions = ["verbose", "builddir", "for-hackage"] + +-- | Fields for the 'init' section. +initFlagsFields :: [FieldDescr IT.InitFlags] +initFlagsFields = [ field + | opt <- initOptions ParseArgs + , let field = viewAsFieldDescr opt + name = fieldName field + , name `notElem` exclusions ] + where + exclusions = + [ "author", "email", "quiet", "no-comments", "minimal", "overwrite" + , "package-dir", "packagedir", "package-name", "version", "homepage" + , "synopsis", "category", "extra-source-file", "lib", "exe", "libandexe" + , "simple", "main-is", "expose-module", "exposed-modules", "extension" + , "dependency", "build-tool", "with-compiler" + , "verbose" + ] + +-- | Fields for the 'program-locations' section. +withProgramsFields :: [FieldDescr [(String, FilePath)]] +withProgramsFields = + map viewAsFieldDescr $ + programDbPaths' (++ "-location") defaultProgramDb + ParseArgs id (++) + +-- | Fields for the 'program-default-options' section. +withProgramOptionsFields :: [FieldDescr [(String, [String])]] +withProgramOptionsFields = + map viewAsFieldDescr $ + programDbOptions defaultProgramDb ParseArgs id (++) + +parseExtraLines :: Verbosity -> [String] -> IO SavedConfig +parseExtraLines verbosity extraLines = + case parseConfig (ConstraintSourceMainConfig "additional lines") + mempty (toUTF8BS (unlines extraLines)) of + ParseFailed err -> + let (line, msg) = locatedErrorMsg err + in die' verbosity $ + "Error parsing additional config lines\n" + ++ maybe "" (\n -> ':' : show n) line ++ ":\n" ++ msg + ParseOk [] r -> return r + ParseOk ws _ -> + die' verbosity $ + unlines (map (showPWarning "Error parsing additional config lines") ws) + +-- | Get the differences (as a pseudo code diff) between the user's +-- '~/.cabal/config' and the one that cabal would generate if it didn't exist. +userConfigDiff :: Verbosity -> GlobalFlags -> [String] -> IO [String] +userConfigDiff verbosity globalFlags extraLines = do + userConfig <- loadRawConfig normal (globalConfigFile globalFlags) + extraConfig <- parseExtraLines verbosity extraLines + testConfig <- initialSavedConfig + return $ + reverse . foldl' createDiff [] . M.toList + $ M.unionWith combine + (M.fromList . map justFst $ filterShow testConfig) + (M.fromList . map justSnd $ filterShow (userConfig `mappend` extraConfig)) + where + justFst (a, b) = (a, (Just b, Nothing)) + justSnd (a, b) = (a, (Nothing, Just b)) + + combine (Nothing, Just b) (Just a, Nothing) = (Just a, Just b) + combine (Just a, Nothing) (Nothing, Just b) = (Just a, Just b) + combine x y = error $ "Can't happen : userConfigDiff " + ++ show x ++ " " ++ show y + + createDiff :: [String] -> (String, (Maybe String, Maybe String)) -> [String] + createDiff acc (key, (Just a, Just b)) + | a == b = acc + | otherwise = ("+ " ++ key ++ ": " ++ b) + : ("- " ++ key ++ ": " ++ a) : acc + createDiff acc (key, (Nothing, Just b)) = ("+ " ++ key ++ ": " ++ b) : acc + createDiff acc (key, (Just a, Nothing)) = ("- " ++ key ++ ": " ++ a) : acc + createDiff acc (_, (Nothing, Nothing)) = acc + + filterShow :: SavedConfig -> [(String, String)] + filterShow cfg = map keyValueSplit + . filter (\s -> not (null s) && ':' `elem` s) + . map nonComment + . lines + $ showConfig cfg + + nonComment [] = [] + nonComment ('-':'-':_) = [] + nonComment (x:xs) = x : nonComment xs + + topAndTail = reverse . dropWhile isSpace . reverse . dropWhile isSpace + + keyValueSplit s = + let (left, right) = break (== ':') s + in (topAndTail left, topAndTail (drop 1 right)) + + +-- | Update the user's ~/.cabal/config' keeping the user's customizations. +userConfigUpdate :: Verbosity -> GlobalFlags -> [String] -> IO () +userConfigUpdate verbosity globalFlags extraLines = do + userConfig <- loadRawConfig normal (globalConfigFile globalFlags) + extraConfig <- parseExtraLines verbosity extraLines + newConfig <- initialSavedConfig + commentConf <- commentSavedConfig + cabalFile <- getConfigFilePath $ globalConfigFile globalFlags + let backup = cabalFile ++ ".backup" + notice verbosity $ "Renaming " ++ cabalFile ++ " to " ++ backup ++ "." + renameFile cabalFile backup + notice verbosity $ "Writing merged config to " ++ cabalFile ++ "." + writeConfigFile cabalFile commentConf + (newConfig `mappend` userConfig `mappend` extraConfig) diff --git a/cabal/cabal-install/src/Distribution/Client/Configure.hs b/cabal/cabal-install/src/Distribution/Client/Configure.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Configure.hs @@ -0,0 +1,470 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Configure +-- Copyright : (c) David Himmelstrup 2005, +-- Duncan Coutts 2005 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- High level interface to configuring a package. +----------------------------------------------------------------------------- +module Distribution.Client.Configure ( + configure, + configureSetupScript, + chooseCabalVersion, + checkConfigExFlags, + -- * Saved configure flags + readConfigFlagsFrom, readConfigFlags, + cabalConfigFlagsFile, + writeConfigFlagsTo, writeConfigFlags, + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude +import Distribution.Utils.Generic (safeHead) + +import Distribution.Client.Dependency +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.SolverInstallPlan (SolverInstallPlan) +import Distribution.Client.IndexUtils as IndexUtils + ( getSourcePackages, getInstalledPackages ) +import Distribution.Client.Setup + ( ConfigExFlags(..), RepoContext(..) + , configureCommand, configureExCommand, filterConfigureFlags ) +import Distribution.Client.Types as Source +import Distribution.Client.SetupWrapper + ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) +import Distribution.Client.Targets + ( userToPackageConstraint, userConstraintPackageName ) +import Distribution.Client.JobControl (Lock) + +import qualified Distribution.Solver.Types.ComponentDeps as CD +import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.LabeledPackageConstraint +import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.PackageIndex + ( PackageIndex, elemByPackageName ) +import Distribution.Solver.Types.PkgConfigDb + (PkgConfigDb, readPkgConfigDb) +import Distribution.Solver.Types.SourcePackage + +import Distribution.Simple.Compiler + ( Compiler, CompilerInfo, compilerInfo, PackageDB(..), PackageDBStack ) +import Distribution.Simple.Program (ProgramDb) +import Distribution.Client.SavedFlags ( readCommandFlags, writeCommandFlags ) +import Distribution.Simple.Setup + ( ConfigFlags(..) + , fromFlag, toFlag, flagToMaybe, fromFlagOrDefault ) +import Distribution.Simple.PackageDescription + ( readGenericPackageDescription ) +import Distribution.Simple.PackageIndex as PackageIndex + ( InstalledPackageIndex, lookupPackageName ) +import Distribution.Package + ( Package(..), packageName, PackageId ) +import Distribution.Types.GivenComponent + ( GivenComponent(..) ) +import Distribution.Types.PackageVersionConstraint + ( PackageVersionConstraint(..), thisPackageVersionConstraint ) +import qualified Distribution.PackageDescription as PkgDesc +import Distribution.PackageDescription.Configuration + ( finalizePD ) +import Distribution.Version + ( Version, mkVersion, anyVersion, thisVersion + , VersionRange, orLaterVersion ) +import Distribution.Simple.Utils as Utils + ( warn, notice, debug, die' + , defaultPackageDesc ) +import Distribution.System + ( Platform ) + +import System.FilePath ( () ) + +-- | Choose the Cabal version such that the setup scripts compiled against this +-- version will support the given command-line flags. +chooseCabalVersion :: ConfigExFlags -> Maybe Version -> VersionRange +chooseCabalVersion configExFlags maybeVersion = + maybe defaultVersionRange thisVersion maybeVersion + where + -- Cabal < 1.19.2 doesn't support '--exact-configuration' which is needed + -- for '--allow-newer' to work. + allowNewer = isRelaxDeps + (maybe mempty unAllowNewer $ configAllowNewer configExFlags) + allowOlder = isRelaxDeps + (maybe mempty unAllowOlder $ configAllowOlder configExFlags) + + defaultVersionRange = if allowOlder || allowNewer + then orLaterVersion (mkVersion [1,19,2]) + else anyVersion + +-- | Configure the package found in the local directory +configure :: Verbosity + -> PackageDBStack + -> RepoContext + -> Compiler + -> Platform + -> ProgramDb + -> ConfigFlags + -> ConfigExFlags + -> [String] + -> IO () +configure verbosity packageDBs repoCtxt comp platform progdb + configFlags configExFlags extraArgs = do + + installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb + sourcePkgDb <- getSourcePackages verbosity repoCtxt + pkgConfigDb <- readPkgConfigDb verbosity progdb + + checkConfigExFlags verbosity installedPkgIndex + (packageIndex sourcePkgDb) configExFlags + + progress <- planLocalPackage verbosity comp platform configFlags configExFlags + installedPkgIndex sourcePkgDb pkgConfigDb + + notice verbosity "Resolving dependencies..." + maybePlan <- foldProgress logMsg (return . Left) (return . Right) + progress + case maybePlan of + Left message -> do + warn verbosity $ + "solver failed to find a solution:\n" + ++ message + ++ "\nTrying configure anyway." + setupWrapper verbosity (setupScriptOptions installedPkgIndex Nothing) + Nothing configureCommand (const configFlags) (const extraArgs) + + Right installPlan0 -> + let installPlan = InstallPlan.configureInstallPlan configFlags installPlan0 + in case fst (InstallPlan.ready installPlan) of + [pkg@(ReadyPackage + (ConfiguredPackage _ (SourcePackage _ _ (LocalUnpackedPackage _) _) + _ _ _))] -> do + configurePackage verbosity + platform (compilerInfo comp) + (setupScriptOptions installedPkgIndex (Just pkg)) + configFlags pkg extraArgs + + _ -> die' verbosity $ "internal error: configure install plan should have exactly " + ++ "one local ready package." + + where + setupScriptOptions :: InstalledPackageIndex + -> Maybe ReadyPackage + -> SetupScriptOptions + setupScriptOptions = + configureSetupScript + packageDBs + comp + platform + progdb + (fromFlagOrDefault + (useDistPref defaultSetupScriptOptions) + (configDistPref configFlags)) + (chooseCabalVersion + configExFlags + (flagToMaybe (configCabalVersion configExFlags))) + Nothing + False + + logMsg message rest = debug verbosity message >> rest + +configureSetupScript :: PackageDBStack + -> Compiler + -> Platform + -> ProgramDb + -> FilePath + -> VersionRange + -> Maybe Lock + -> Bool + -> InstalledPackageIndex + -> Maybe ReadyPackage + -> SetupScriptOptions +configureSetupScript packageDBs + comp + platform + progdb + distPref + cabalVersion + lock + forceExternal + index + mpkg + = SetupScriptOptions { + useCabalVersion = cabalVersion + , useCabalSpecVersion = Nothing + , useCompiler = Just comp + , usePlatform = Just platform + , usePackageDB = packageDBs' + , usePackageIndex = index' + , useProgramDb = progdb + , useDistPref = distPref + , useLoggingHandle = Nothing + , useWorkingDir = Nothing + , useExtraPathEnv = [] + , 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 + -- `compileSetupExecutable` in `externalSetupMethod`, but we don't yet + -- know the version of Cabal at this point, but only find this there. + -- Therefore, for now, we just leave this blank. + , useDependencies = fromMaybe [] explicitSetupDeps + , useDependenciesExclusive = not defaultSetupDeps && isJust explicitSetupDeps + , useVersionMacros = not defaultSetupDeps && isJust explicitSetupDeps + , isInteractive = False + } + where + -- When we are compiling a legacy setup script without an explicit + -- setup stanza, we typically want to allow the UserPackageDB for + -- finding the Cabal lib when compiling any Setup.hs even if we're doing + -- a global install. However we also allow looking in a specific package + -- db. + packageDBs' :: PackageDBStack + index' :: Maybe InstalledPackageIndex + (packageDBs', index') = + case packageDBs of + (GlobalPackageDB:dbs) | UserPackageDB `notElem` dbs + , Nothing <- explicitSetupDeps + -> (GlobalPackageDB:UserPackageDB:dbs, Nothing) + -- but if the user is using an odd db stack, don't touch it + _otherwise -> (packageDBs, Just index) + + maybeSetupBuildInfo :: Maybe PkgDesc.SetupBuildInfo + maybeSetupBuildInfo = do + ReadyPackage cpkg <- mpkg + let gpkg = srcpkgDescription (confPkgSource cpkg) + PkgDesc.setupBuildInfo (PkgDesc.packageDescription gpkg) + + -- Was a default 'custom-setup' stanza added by 'cabal-install' itself? If + -- so, 'setup-depends' must not be exclusive. See #3199. + defaultSetupDeps :: Bool + defaultSetupDeps = maybe False PkgDesc.defaultSetupDepends + maybeSetupBuildInfo + + explicitSetupDeps :: Maybe [(InstalledPackageId, PackageId)] + explicitSetupDeps = do + -- Check if there is an explicit setup stanza. + _buildInfo <- maybeSetupBuildInfo + -- Return the setup dependencies computed by the solver + ReadyPackage cpkg <- mpkg + return [ ( cid, srcid ) + | ConfiguredId srcid + (Just (PkgDesc.CLibName PkgDesc.LMainLibName)) cid + <- CD.setupDeps (confPkgDeps cpkg) + ] + +-- | Warn if any constraints or preferences name packages that are not in the +-- source package index or installed package index. +checkConfigExFlags :: Package pkg + => Verbosity + -> InstalledPackageIndex + -> PackageIndex pkg + -> ConfigExFlags + -> IO () +checkConfigExFlags verbosity installedPkgIndex sourcePkgIndex flags = do + for_ (safeHead unknownConstraints) $ \h -> + warn verbosity $ "Constraint refers to an unknown package: " + ++ showConstraint h + for_ (safeHead unknownPreferences) $ \h -> + warn verbosity $ "Preference refers to an unknown package: " + ++ prettyShow h + where + unknownConstraints = filter (unknown . userConstraintPackageName . fst) $ + configExConstraints flags + unknownPreferences = filter (unknown . \(PackageVersionConstraint name _) -> name) $ + configPreferences flags + unknown pkg = null (PackageIndex.lookupPackageName installedPkgIndex pkg) + && not (elemByPackageName sourcePkgIndex pkg) + showConstraint (uc, src) = + prettyShow uc ++ " (" ++ showConstraintSource src ++ ")" + +-- | Make an 'InstallPlan' for the unpacked package in the current directory, +-- and all its dependencies. +-- +planLocalPackage :: Verbosity -> Compiler + -> Platform + -> ConfigFlags -> ConfigExFlags + -> InstalledPackageIndex + -> SourcePackageDb + -> PkgConfigDb + -> IO (Progress String String SolverInstallPlan) +planLocalPackage verbosity comp platform configFlags configExFlags + installedPkgIndex (SourcePackageDb _ packagePrefs) pkgConfigDb = do + pkg <- readGenericPackageDescription verbosity =<< + case flagToMaybe (configCabalFilePath configFlags) of + Nothing -> defaultPackageDesc verbosity + Just fp -> return fp + solver <- chooseSolver verbosity (fromFlag $ configSolver configExFlags) + (compilerInfo comp) + + let -- We create a local package and ask to resolve a dependency on it + localPkg = SourcePackage { + srcpkgPackageId = packageId pkg, + srcpkgDescription = pkg, + srcpkgSource = LocalUnpackedPackage ".", + srcpkgDescrOverride = Nothing + } + + testsEnabled :: Bool + testsEnabled = fromFlagOrDefault False $ configTests configFlags + benchmarksEnabled :: Bool + benchmarksEnabled = + fromFlagOrDefault False $ configBenchmarks configFlags + + resolverParams :: DepResolverParams + resolverParams = + removeLowerBounds + (fromMaybe (AllowOlder mempty) $ configAllowOlder configExFlags) + . removeUpperBounds + (fromMaybe (AllowNewer mempty) $ configAllowNewer configExFlags) + + . addPreferences + -- preferences from the config file or command line + [ PackageVersionPreference name ver + | PackageVersionConstraint name ver <- configPreferences configExFlags ] + + . addConstraints + -- version constraints from the config file or command line + -- TODO: should warn or error on constraints that are not on direct + -- deps or flag constraints not on the package in question. + [ LabeledPackageConstraint (userToPackageConstraint uc) src + | (uc, src) <- configExConstraints configExFlags ] + + . addConstraints + -- package flags from the config file or command line + [ let pc = PackageConstraint + (scopeToplevel $ packageName pkg) + (PackagePropertyFlags $ configConfigurationsFlags configFlags) + in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget + ] + + . addConstraints + -- '--enable-tests' and '--enable-benchmarks' constraints from + -- the config file or command line + [ let pc = PackageConstraint (scopeToplevel $ packageName pkg) . + PackagePropertyStanzas $ + [ TestStanzas | testsEnabled ] ++ + [ BenchStanzas | benchmarksEnabled ] + in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget + ] + + -- Don't solve for executables, since we use an empty source + -- package database and executables never show up in the + -- installed package index + . setSolveExecutables (SolveExecutables False) + + . setSolverVerbosity 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 solver resolverParams) + + +-- | Call an installer for an 'SourcePackage' but override the configure +-- flags with the ones given by the 'ReadyPackage'. In particular the +-- 'ReadyPackage' specifies an exact 'FlagAssignment' and exactly +-- versioned package dependencies. So we ignore any previous partial flag +-- assignment or dependency constraints and use the new ones. +-- +-- NB: when updating this function, don't forget to also update +-- 'installReadyPackage' in D.C.Install. +configurePackage :: Verbosity + -> Platform -> CompilerInfo + -> SetupScriptOptions + -> ConfigFlags + -> ReadyPackage + -> [String] + -> IO () +configurePackage verbosity platform comp scriptOptions configFlags + (ReadyPackage (ConfiguredPackage ipid spkg flags stanzas deps)) + extraArgs = + + setupWrapper verbosity + scriptOptions (Just pkg) configureCommand configureFlags (const extraArgs) + + where + gpkg :: PkgDesc.GenericPackageDescription + gpkg = srcpkgDescription spkg + configureFlags :: Version -> ConfigFlags + configureFlags = filterConfigureFlags configFlags { + configIPID = if isJust (flagToMaybe (configIPID configFlags)) + -- Make sure cabal configure --ipid works. + then configIPID configFlags + else toFlag (prettyShow ipid), + configConfigurationsFlags = flags, + -- We generate the legacy constraints as well as the new style precise + -- deps. In the end only one set gets passed to Setup.hs configure, + -- depending on the Cabal version we are talking to. + configConstraints = [ thisPackageVersionConstraint srcid + | ConfiguredId srcid (Just (PkgDesc.CLibName PkgDesc.LMainLibName)) _uid + <- CD.nonSetupDeps deps ], + configDependencies = [ GivenComponent (packageName srcid) cname uid + | ConfiguredId srcid (Just (PkgDesc.CLibName cname)) uid + <- CD.nonSetupDeps deps ], + -- Use '--exact-configuration' if supported. + configExactConfiguration = toFlag True, + configVerbosity = toFlag verbosity, + -- NB: if the user explicitly specified + -- --enable-tests/--enable-benchmarks, always respect it. + -- (But if they didn't, let solver decide.) + configBenchmarks = toFlag (BenchStanzas `optStanzaSetMember` stanzas) + `mappend` configBenchmarks configFlags, + configTests = toFlag (TestStanzas `optStanzaSetMember` stanzas) + `mappend` configTests configFlags + } + + pkg :: PkgDesc.PackageDescription + pkg = case finalizePD flags (enableStanzas stanzas) + (const True) + platform comp [] gpkg of + Left _ -> error "finalizePD ReadyPackage failed" + Right (desc, _) -> desc + +-- ----------------------------------------------------------------------------- +-- * Saved configure environments and flags +-- ----------------------------------------------------------------------------- + +-- | Read saved configure flags and restore the saved environment from the +-- specified files. +readConfigFlagsFrom :: FilePath -- ^ path to saved flags file + -> IO (ConfigFlags, ConfigExFlags) +readConfigFlagsFrom flags = do + readCommandFlags flags configureExCommand + +-- | The path (relative to @--build-dir@) where the arguments to @configure@ +-- should be saved. +cabalConfigFlagsFile :: FilePath -> FilePath +cabalConfigFlagsFile dist = dist "cabal-config-flags" + +-- | Read saved configure flags and restore the saved environment from the +-- usual location. +readConfigFlags :: FilePath -- ^ @--build-dir@ + -> IO (ConfigFlags, ConfigExFlags) +readConfigFlags dist = + readConfigFlagsFrom (cabalConfigFlagsFile dist) + +-- | Save the configure flags and environment to the specified files. +writeConfigFlagsTo :: FilePath -- ^ path to saved flags file + -> Verbosity -> (ConfigFlags, ConfigExFlags) + -> IO () +writeConfigFlagsTo file verb flags = do + writeCommandFlags verb file configureExCommand flags + +-- | Save the build flags to the usual location. +writeConfigFlags :: Verbosity + -> FilePath -- ^ @--build-dir@ + -> (ConfigFlags, ConfigExFlags) -> IO () +writeConfigFlags verb dist = + writeConfigFlagsTo (cabalConfigFlagsFile dist) verb diff --git a/cabal/cabal-install/src/Distribution/Client/Dependency.hs b/cabal/cabal-install/src/Distribution/Client/Dependency.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Dependency.hs @@ -0,0 +1,1065 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Dependency +-- Copyright : (c) David Himmelstrup 2005, +-- Bjorn Bringert 2007 +-- Duncan Coutts 2008 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Top level interface to dependency resolution. +----------------------------------------------------------------------------- +module Distribution.Client.Dependency ( + -- * The main package dependency resolver + DepResolverParams, + chooseSolver, + resolveDependencies, + Progress(..), + foldProgress, + + -- * Alternate, simple resolver that does not do dependencies recursively + resolveWithoutDependencies, + + -- * Constructing resolver policies + PackageProperty(..), + PackageConstraint(..), + scopeToplevel, + PackagesPreferenceDefault(..), + PackagePreference(..), + + -- ** Standard policy + basicInstallPolicy, + standardInstallPolicy, + PackageSpecifier(..), + + -- ** Extra policy options + upgradeDependencies, + reinstallTargets, + + -- ** Policy utils + addConstraints, + addPreferences, + setPreferenceDefault, + setReorderGoals, + setCountConflicts, + setFineGrainedConflicts, + setMinimizeConflictSet, + setIndependentGoals, + setAvoidReinstalls, + setShadowPkgs, + setStrongFlags, + setAllowBootLibInstalls, + setOnlyConstrained, + setMaxBackjumps, + setEnableBackjumping, + setSolveExecutables, + setGoalOrder, + setSolverVerbosity, + removeLowerBounds, + removeUpperBounds, + addDefaultSetupDependencies, + addSetupCabalMinVersionConstraint, + addSetupCabalMaxVersionConstraint, + ) where + +import Distribution.Client.Compat.Prelude +import qualified Prelude as Unsafe (head) + +import Distribution.Solver.Modular + ( modularResolver, SolverConfig(..), PruneAfterFirstSuccess(..) ) +import Distribution.Simple.PackageIndex (InstalledPackageIndex) +import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex +import Distribution.Client.SolverInstallPlan (SolverInstallPlan) +import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan +import Distribution.Client.Types + ( SourcePackageDb(SourcePackageDb) + , PackageSpecifier(..), pkgSpecifierTarget, pkgSpecifierConstraints + , UnresolvedPkgLoc, UnresolvedSourcePackage + , AllowNewer(..), AllowOlder(..), RelaxDeps(..), RelaxedDep(..) + , RelaxDepScope(..), RelaxDepMod(..), RelaxDepSubject(..), isRelaxDeps + ) +import Distribution.Client.Dependency.Types + ( PreSolver(..), Solver(..) + , PackagesPreferenceDefault(..) ) +import Distribution.Package + ( PackageName, mkPackageName, PackageIdentifier(PackageIdentifier), PackageId + , Package(..), packageName, packageVersion ) +import Distribution.Types.Dependency +import qualified Distribution.PackageDescription as PD +import qualified Distribution.PackageDescription.Configuration as PD +import Distribution.PackageDescription.Configuration + ( finalizePD ) +import Distribution.Compiler + ( CompilerInfo(..) ) +import Distribution.System + ( Platform ) +import Distribution.Client.Utils + ( duplicatesBy, mergeBy, MergeResult(..) ) +import Distribution.Simple.Setup + ( asBool ) +import Distribution.Verbosity + ( normal ) +import Distribution.Version +import qualified Distribution.Compat.Graph as Graph + +import Distribution.Solver.Types.ComponentDeps (ComponentDeps) +import qualified Distribution.Solver.Types.ComponentDeps as CD +import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.DependencyResolver +import Distribution.Solver.Types.InstalledPreference as Preference +import Distribution.Solver.Types.LabeledPackageConstraint +import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.PackageConstraint +import Distribution.Solver.Types.PackagePath +import Distribution.Solver.Types.PackagePreferences +import qualified Distribution.Solver.Types.PackageIndex as PackageIndex +import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb) +import Distribution.Solver.Types.Progress +import Distribution.Solver.Types.ResolverPackage +import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.SolverId +import Distribution.Solver.Types.SolverPackage +import Distribution.Solver.Types.SourcePackage +import Distribution.Solver.Types.Variable + +import Data.List + ( maximumBy ) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Control.Exception + ( assert ) + + +-- ------------------------------------------------------------ +-- * High level planner policy +-- ------------------------------------------------------------ + +-- | The set of parameters to the dependency resolver. These parameters are +-- relatively low level but many kinds of high level policies can be +-- implemented in terms of adjustments to the parameters. +-- +data DepResolverParams = DepResolverParams { + depResolverTargets :: Set PackageName, + depResolverConstraints :: [LabeledPackageConstraint], + depResolverPreferences :: [PackagePreference], + depResolverPreferenceDefault :: PackagesPreferenceDefault, + depResolverInstalledPkgIndex :: InstalledPackageIndex, + depResolverSourcePkgIndex :: PackageIndex.PackageIndex UnresolvedSourcePackage, + depResolverReorderGoals :: ReorderGoals, + depResolverCountConflicts :: CountConflicts, + depResolverFineGrainedConflicts :: FineGrainedConflicts, + depResolverMinimizeConflictSet :: MinimizeConflictSet, + depResolverIndependentGoals :: IndependentGoals, + depResolverAvoidReinstalls :: AvoidReinstalls, + depResolverShadowPkgs :: ShadowPkgs, + depResolverStrongFlags :: StrongFlags, + + -- | Whether to allow base and its dependencies to be installed. + depResolverAllowBootLibInstalls :: AllowBootLibInstalls, + + -- | Whether to only allow explicitly constrained packages plus + -- goals or to allow any package. + depResolverOnlyConstrained :: OnlyConstrained, + + depResolverMaxBackjumps :: Maybe Int, + depResolverEnableBackjumping :: EnableBackjumping, + -- | Whether or not to solve for dependencies on executables. + -- This should be true, except in the legacy code path where + -- we can't tell if an executable has been installed or not, + -- so we shouldn't solve for them. See #3875. + depResolverSolveExecutables :: SolveExecutables, + + -- | Function to override the solver's goal-ordering heuristics. + depResolverGoalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering), + depResolverVerbosity :: Verbosity + } + +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) + where + showLabeledConstraint :: LabeledPackageConstraint -> String + showLabeledConstraint (LabeledPackageConstraint pc src) = + showPackageConstraint pc ++ " (" ++ showConstraintSource src ++ ")" + +-- | A package selection preference for a particular package. +-- +-- Preferences are soft constraints that the dependency resolver should try to +-- respect where possible. It is not specified if preferences on some packages +-- are more important than others. +-- +data PackagePreference = + + -- | A suggested constraint on the version number. + PackageVersionPreference PackageName VersionRange + + -- | If we prefer versions of packages that are already installed. + | PackageInstalledPreference PackageName InstalledPreference + + -- | If we would prefer to enable these optional stanzas + -- (i.e. test suites and/or benchmarks) + | PackageStanzasPreference PackageName [OptionalStanza] + + +-- | Provide a textual representation of a package preference +-- for debugging purposes. +-- +showPackagePreference :: PackagePreference -> String +showPackagePreference (PackageVersionPreference pn vr) = + prettyShow pn ++ " " ++ prettyShow (simplifyVersionRange vr) +showPackagePreference (PackageInstalledPreference pn ip) = + prettyShow pn ++ " " ++ show ip +showPackagePreference (PackageStanzasPreference pn st) = + prettyShow pn ++ " " ++ show st + +basicDepResolverParams :: InstalledPackageIndex + -> PackageIndex.PackageIndex UnresolvedSourcePackage + -> DepResolverParams +basicDepResolverParams installedPkgIndex sourcePkgIndex = + DepResolverParams { + depResolverTargets = Set.empty, + depResolverConstraints = [], + depResolverPreferences = [], + depResolverPreferenceDefault = PreferLatestForSelected, + depResolverInstalledPkgIndex = installedPkgIndex, + depResolverSourcePkgIndex = sourcePkgIndex, + depResolverReorderGoals = ReorderGoals False, + depResolverCountConflicts = CountConflicts True, + depResolverFineGrainedConflicts = FineGrainedConflicts True, + depResolverMinimizeConflictSet = MinimizeConflictSet False, + depResolverIndependentGoals = IndependentGoals False, + depResolverAvoidReinstalls = AvoidReinstalls False, + depResolverShadowPkgs = ShadowPkgs False, + depResolverStrongFlags = StrongFlags False, + depResolverAllowBootLibInstalls = AllowBootLibInstalls False, + depResolverOnlyConstrained = OnlyConstrainedNone, + depResolverMaxBackjumps = Nothing, + depResolverEnableBackjumping = EnableBackjumping True, + depResolverSolveExecutables = SolveExecutables True, + depResolverGoalOrder = Nothing, + depResolverVerbosity = normal + } + +addTargets :: [PackageName] + -> DepResolverParams -> DepResolverParams +addTargets extraTargets params = + params { + depResolverTargets = Set.fromList extraTargets `Set.union` depResolverTargets params + } + +addConstraints :: [LabeledPackageConstraint] + -> DepResolverParams -> DepResolverParams +addConstraints extraConstraints params = + params { + depResolverConstraints = extraConstraints + ++ depResolverConstraints params + } + +addPreferences :: [PackagePreference] + -> DepResolverParams -> DepResolverParams +addPreferences extraPreferences params = + params { + depResolverPreferences = extraPreferences + ++ depResolverPreferences params + } + +setPreferenceDefault :: PackagesPreferenceDefault + -> DepResolverParams -> DepResolverParams +setPreferenceDefault preferenceDefault params = + params { + depResolverPreferenceDefault = preferenceDefault + } + +setReorderGoals :: ReorderGoals -> DepResolverParams -> DepResolverParams +setReorderGoals reorder params = + params { + depResolverReorderGoals = reorder + } + +setCountConflicts :: CountConflicts -> DepResolverParams -> DepResolverParams +setCountConflicts count params = + params { + depResolverCountConflicts = count + } + +setFineGrainedConflicts :: FineGrainedConflicts -> DepResolverParams -> DepResolverParams +setFineGrainedConflicts fineGrained params = + params { + depResolverFineGrainedConflicts = fineGrained + } + +setMinimizeConflictSet :: MinimizeConflictSet -> DepResolverParams -> DepResolverParams +setMinimizeConflictSet minimize params = + params { + depResolverMinimizeConflictSet = minimize + } + +setIndependentGoals :: IndependentGoals -> DepResolverParams -> DepResolverParams +setIndependentGoals indep params = + params { + depResolverIndependentGoals = indep + } + +setAvoidReinstalls :: AvoidReinstalls -> DepResolverParams -> DepResolverParams +setAvoidReinstalls avoid params = + params { + depResolverAvoidReinstalls = avoid + } + +setShadowPkgs :: ShadowPkgs -> DepResolverParams -> DepResolverParams +setShadowPkgs shadow params = + params { + depResolverShadowPkgs = shadow + } + +setStrongFlags :: StrongFlags -> DepResolverParams -> DepResolverParams +setStrongFlags sf params = + params { + depResolverStrongFlags = sf + } + +setAllowBootLibInstalls :: AllowBootLibInstalls -> DepResolverParams -> DepResolverParams +setAllowBootLibInstalls i params = + params { + depResolverAllowBootLibInstalls = i + } + +setOnlyConstrained :: OnlyConstrained -> DepResolverParams -> DepResolverParams +setOnlyConstrained i params = + params { + depResolverOnlyConstrained = i + } + +setMaxBackjumps :: Maybe Int -> DepResolverParams -> DepResolverParams +setMaxBackjumps n params = + params { + depResolverMaxBackjumps = n + } + +setEnableBackjumping :: EnableBackjumping -> DepResolverParams -> DepResolverParams +setEnableBackjumping b params = + params { + depResolverEnableBackjumping = b + } + +setSolveExecutables :: SolveExecutables -> DepResolverParams -> DepResolverParams +setSolveExecutables b params = + params { + depResolverSolveExecutables = b + } + +setGoalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering) + -> DepResolverParams + -> DepResolverParams +setGoalOrder order params = + params { + depResolverGoalOrder = order + } + +setSolverVerbosity :: Verbosity -> DepResolverParams -> DepResolverParams +setSolverVerbosity verbosity params = + params { + depResolverVerbosity = verbosity + } + +-- | Some packages are specific to a given compiler version and should never be +-- upgraded. +dontUpgradeNonUpgradeablePackages :: DepResolverParams -> DepResolverParams +dontUpgradeNonUpgradeablePackages params = + addConstraints extraConstraints params + where + extraConstraints = + [ LabeledPackageConstraint + (PackageConstraint (ScopeAnyQualifier pkgname) PackagePropertyInstalled) + ConstraintSourceNonUpgradeablePackage + | Set.notMember (mkPackageName "base") (depResolverTargets params) + -- If you change this enumeration, make sure to update the list in + -- "Distribution.Solver.Modular.Solver" as well + , pkgname <- [ mkPackageName "base" + , mkPackageName "ghc-bignum" + , mkPackageName "ghc-prim" + , mkPackageName "integer-gmp" + , mkPackageName "integer-simple" + , mkPackageName "template-haskell" + ] + , isInstalled pkgname ] + + isInstalled = not . null + . InstalledPackageIndex.lookupPackageName + (depResolverInstalledPkgIndex params) + +addSourcePackages :: [UnresolvedSourcePackage] + -> DepResolverParams -> DepResolverParams +addSourcePackages pkgs params = + params { + depResolverSourcePkgIndex = + foldl (flip PackageIndex.insert) + (depResolverSourcePkgIndex params) pkgs + } + +hideInstalledPackagesSpecificBySourcePackageId :: [PackageId] + -> DepResolverParams + -> DepResolverParams +hideInstalledPackagesSpecificBySourcePackageId pkgids params = + --TODO: this should work using exclude constraints instead + params { + depResolverInstalledPkgIndex = + foldl' (flip InstalledPackageIndex.deleteSourcePackageId) + (depResolverInstalledPkgIndex params) pkgids + } + +hideInstalledPackagesAllVersions :: [PackageName] + -> DepResolverParams -> DepResolverParams +hideInstalledPackagesAllVersions pkgnames params = + --TODO: this should work using exclude constraints instead + params { + depResolverInstalledPkgIndex = + foldl' (flip InstalledPackageIndex.deletePackageName) + (depResolverInstalledPkgIndex params) pkgnames + } + + +-- | Remove upper bounds in dependencies using the policy specified by the +-- 'AllowNewer' argument (all/some/none). +-- +-- Note: It's important to apply 'removeUpperBounds' after +-- 'addSourcePackages'. Otherwise, the packages inserted by +-- 'addSourcePackages' won't have upper bounds in dependencies relaxed. +-- +removeUpperBounds :: AllowNewer -> DepResolverParams -> DepResolverParams +removeUpperBounds (AllowNewer relDeps) = removeBounds RelaxUpper relDeps + +-- | Dual of 'removeUpperBounds' +removeLowerBounds :: AllowOlder -> DepResolverParams -> DepResolverParams +removeLowerBounds (AllowOlder relDeps) = removeBounds RelaxLower relDeps + +data RelaxKind = RelaxLower | RelaxUpper + +-- | Common internal implementation of 'removeLowerBounds'/'removeUpperBounds' +removeBounds :: RelaxKind -> RelaxDeps -> DepResolverParams -> DepResolverParams +removeBounds _ rd params | not (isRelaxDeps rd) = params -- no-op optimisation +removeBounds relKind relDeps params = + params { + depResolverSourcePkgIndex = sourcePkgIndex' + } + where + sourcePkgIndex' :: PackageIndex.PackageIndex UnresolvedSourcePackage + sourcePkgIndex' = fmap relaxDeps $ depResolverSourcePkgIndex params + + relaxDeps :: UnresolvedSourcePackage -> UnresolvedSourcePackage + relaxDeps srcPkg = srcPkg + { srcpkgDescription = relaxPackageDeps relKind relDeps (srcpkgDescription srcPkg) + } + +-- | Relax the dependencies of this package if needed. +-- +-- Helper function used by 'removeBounds' +relaxPackageDeps :: RelaxKind + -> RelaxDeps + -> PD.GenericPackageDescription -> PD.GenericPackageDescription +relaxPackageDeps _ rd gpd | not (isRelaxDeps rd) = gpd -- subsumed by no-op case in 'removeBounds' +relaxPackageDeps relKind RelaxDepsAll gpd = PD.transformAllBuildDepends relaxAll gpd + where + relaxAll :: Dependency -> Dependency + relaxAll (Dependency pkgName verRange cs) = + Dependency pkgName (removeBound relKind RelaxDepModNone verRange) cs + +relaxPackageDeps relKind (RelaxDepsSome depsToRelax0) gpd = + PD.transformAllBuildDepends relaxSome gpd + where + thisPkgName = packageName gpd + thisPkgId = packageId gpd + depsToRelax = Map.fromList $ mapMaybe f depsToRelax0 + + f :: RelaxedDep -> Maybe (RelaxDepSubject,RelaxDepMod) + f (RelaxedDep scope rdm p) = case scope of + RelaxDepScopeAll -> Just (p,rdm) + RelaxDepScopePackage p0 + | p0 == thisPkgName -> Just (p,rdm) + | otherwise -> Nothing + RelaxDepScopePackageId p0 + | p0 == thisPkgId -> Just (p,rdm) + | otherwise -> Nothing + + relaxSome :: Dependency -> Dependency + relaxSome d@(Dependency depName verRange cs) + | Just relMod <- Map.lookup RelaxDepSubjectAll depsToRelax = + -- a '*'-subject acts absorbing, for consistency with + -- the 'Semigroup RelaxDeps' instance + Dependency depName (removeBound relKind relMod verRange) cs + | Just relMod <- Map.lookup (RelaxDepSubjectPkg depName) depsToRelax = + Dependency depName (removeBound relKind relMod verRange) cs + | otherwise = d -- no-op + +-- | Internal helper for 'relaxPackageDeps' +removeBound :: RelaxKind -> RelaxDepMod -> VersionRange -> VersionRange +removeBound RelaxLower RelaxDepModNone = removeLowerBound +removeBound RelaxUpper RelaxDepModNone = removeUpperBound +removeBound RelaxLower RelaxDepModCaret = transformCaretLower +removeBound RelaxUpper RelaxDepModCaret = transformCaretUpper + +-- | Supply defaults for packages without explicit Setup dependencies +-- +-- 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]) + -> DepResolverParams -> DepResolverParams +addDefaultSetupDependencies defaultSetupDeps params = + params { + depResolverSourcePkgIndex = + fmap applyDefaultSetupDeps (depResolverSourcePkgIndex params) + } + where + applyDefaultSetupDeps :: UnresolvedSourcePackage -> UnresolvedSourcePackage + applyDefaultSetupDeps 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 + } + } + } + where + isCustom = PD.buildType pkgdesc == PD.Custom + gpkgdesc = srcpkgDescription srcpkg + pkgdesc = PD.packageDescription gpkgdesc + +-- | If a package has a custom setup then we need to add a setup-depends +-- on Cabal. +-- +addSetupCabalMinVersionConstraint :: Version + -> DepResolverParams -> DepResolverParams +addSetupCabalMinVersionConstraint minVersion = + addConstraints + [ LabeledPackageConstraint + (PackageConstraint (ScopeAnySetupQualifier cabalPkgname) + (PackagePropertyVersion $ orLaterVersion minVersion)) + ConstraintSetupCabalMinVersion + ] + where + cabalPkgname = mkPackageName "Cabal" + +-- | Variant of 'addSetupCabalMinVersionConstraint' which sets an +-- upper bound on @setup.Cabal@ labeled with 'ConstraintSetupCabalMaxVersion'. +-- +addSetupCabalMaxVersionConstraint :: Version + -> DepResolverParams -> DepResolverParams +addSetupCabalMaxVersionConstraint maxVersion = + addConstraints + [ LabeledPackageConstraint + (PackageConstraint (ScopeAnySetupQualifier cabalPkgname) + (PackagePropertyVersion $ earlierVersion maxVersion)) + ConstraintSetupCabalMaxVersion + ] + where + cabalPkgname = mkPackageName "Cabal" + + +upgradeDependencies :: DepResolverParams -> DepResolverParams +upgradeDependencies = setPreferenceDefault PreferAllLatest + + +reinstallTargets :: DepResolverParams -> DepResolverParams +reinstallTargets params = + hideInstalledPackagesAllVersions (Set.toList $ depResolverTargets params) params + + +-- | A basic solver policy on which all others are built. +-- +basicInstallPolicy :: InstalledPackageIndex + -> SourcePackageDb + -> [PackageSpecifier UnresolvedSourcePackage] + -> DepResolverParams +basicInstallPolicy + installedPkgIndex (SourcePackageDb sourcePkgIndex sourcePkgPrefs) + pkgSpecifiers + + = addPreferences + [ PackageVersionPreference name ver + | (name, ver) <- Map.toList sourcePkgPrefs ] + + . addConstraints + (concatMap pkgSpecifierConstraints pkgSpecifiers) + + . addTargets + (map pkgSpecifierTarget pkgSpecifiers) + + . hideInstalledPackagesSpecificBySourcePackageId + [ packageId pkg | SpecificSourcePackage pkg <- pkgSpecifiers ] + + . addSourcePackages + [ pkg | SpecificSourcePackage pkg <- pkgSpecifiers ] + + $ basicDepResolverParams + installedPkgIndex sourcePkgIndex + + +-- | The policy used by all the standard commands, install, fetch, freeze etc +-- (but not the v2-build and related commands). +-- +-- It extends the 'basicInstallPolicy' with a policy on setup deps. +-- +standardInstallPolicy :: InstalledPackageIndex + -> SourcePackageDb + -> [PackageSpecifier UnresolvedSourcePackage] + -> DepResolverParams +standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers + + = addDefaultSetupDependencies mkDefaultSetupDeps + + $ basicInstallPolicy + installedPkgIndex sourcePkgDb pkgSpecifiers + + where + -- Force Cabal >= 1.24 dep when the package is affected by #3199. + mkDefaultSetupDeps :: UnresolvedSourcePackage -> Maybe [Dependency] + mkDefaultSetupDeps srcpkg | affected = + Just [Dependency (mkPackageName "Cabal") (orLaterVersion $ mkVersion [1,24]) mainLibSet] + | otherwise = Nothing + where + gpkgdesc = srcpkgDescription srcpkg + pkgdesc = PD.packageDescription gpkgdesc + bt = PD.buildType pkgdesc + affected = bt == PD.Custom && hasBuildableFalse gpkgdesc + + -- Does this package contain any components with non-empty 'build-depends' + -- and a 'buildable' field that could potentially be set to 'False'? False + -- positives are possible. + hasBuildableFalse :: PD.GenericPackageDescription -> Bool + hasBuildableFalse gpkg = + not (all alwaysTrue (zipWith PD.cOr buildableConditions noDepConditions)) + where + buildableConditions = PD.extractConditions PD.buildable gpkg + noDepConditions = PD.extractConditions + (null . PD.targetBuildDepends) gpkg + alwaysTrue (PD.Lit True) = True + alwaysTrue _ = False + +-- ------------------------------------------------------------ +-- * Interface to the standard resolver +-- ------------------------------------------------------------ + +chooseSolver :: Verbosity -> PreSolver -> CompilerInfo -> IO Solver +chooseSolver _verbosity preSolver _cinfo = + case preSolver of + AlwaysModular -> do + return Modular + +runSolver :: Solver -> SolverConfig -> DependencyResolver UnresolvedPkgLoc +runSolver Modular = modularResolver + +-- | Run the dependency solver. +-- +-- Since this is potentially an expensive operation, the result is wrapped in a +-- a 'Progress' structure that can be unfolded to provide progress information, +-- logging messages and the final result or an error. +-- +resolveDependencies :: Platform + -> CompilerInfo + -> PkgConfigDb + -> Solver + -> DepResolverParams + -> Progress String String SolverInstallPlan + + --TODO: is this needed here? see dontUpgradeNonUpgradeablePackages +resolveDependencies platform comp _pkgConfigDB _solver params + | Set.null (depResolverTargets params) + = return (validateSolverResult platform comp indGoals []) + where + indGoals = depResolverIndependentGoals params + +resolveDependencies platform comp pkgConfigDB solver params = + + Step (showDepResolverParams finalparams) + $ fmap (validateSolverResult platform comp indGoals) + $ runSolver solver (SolverConfig reordGoals cntConflicts fineGrained minimize + indGoals noReinstalls + shadowing strFlags allowBootLibs onlyConstrained_ maxBkjumps enableBj + solveExes order verbosity (PruneAfterFirstSuccess False)) + platform comp installedPkgIndex sourcePkgIndex + pkgConfigDB preferences constraints targets + where + + finalparams@(DepResolverParams + targets constraints + prefs defpref + installedPkgIndex + sourcePkgIndex + reordGoals + cntConflicts + fineGrained + minimize + indGoals + noReinstalls + shadowing + strFlags + allowBootLibs + onlyConstrained_ + maxBkjumps + enableBj + solveExes + order + verbosity) = + if asBool (depResolverAllowBootLibInstalls params) + then params + else dontUpgradeNonUpgradeablePackages params + + preferences :: PackageName -> PackagePreferences + preferences = interpretPackagesPreference targets defpref prefs + + +-- | Give an interpretation to the global 'PackagesPreference' as +-- specific per-package 'PackageVersionPreference'. +-- +interpretPackagesPreference :: Set PackageName + -> PackagesPreferenceDefault + -> [PackagePreference] + -> (PackageName -> PackagePreferences) +interpretPackagesPreference selected defaultPref prefs = + \pkgname -> PackagePreferences (versionPref pkgname) + (installPref pkgname) + (stanzasPref pkgname) + where + versionPref :: PackageName -> [VersionRange] + versionPref pkgname = + fromMaybe [anyVersion] (Map.lookup pkgname versionPrefs) + versionPrefs = Map.fromListWith (++) + [(pkgname, [pref]) + | PackageVersionPreference pkgname pref <- prefs] + + installPref :: PackageName -> InstalledPreference + installPref pkgname = + fromMaybe (installPrefDefault pkgname) (Map.lookup pkgname installPrefs) + installPrefs = Map.fromList + [ (pkgname, pref) + | PackageInstalledPreference pkgname pref <- prefs ] + installPrefDefault = case defaultPref of + PreferAllLatest -> const Preference.PreferLatest + PreferAllOldest -> const Preference.PreferOldest + PreferAllInstalled -> const Preference.PreferInstalled + PreferLatestForSelected -> \pkgname -> + -- When you say cabal install foo, what you really mean is, prefer the + -- latest version of foo, but the installed version of everything else + if pkgname `Set.member` selected then Preference.PreferLatest + else Preference.PreferInstalled + + stanzasPref :: PackageName -> [OptionalStanza] + stanzasPref pkgname = + fromMaybe [] (Map.lookup pkgname stanzasPrefs) + stanzasPrefs = Map.fromListWith (\a b -> nub (a ++ b)) + [ (pkgname, pref) + | PackageStanzasPreference pkgname pref <- prefs ] + + +-- ------------------------------------------------------------ +-- * Checking the result of the solver +-- ------------------------------------------------------------ + +-- | 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 + -> [ResolverPackage UnresolvedPkgLoc] + -> SolverInstallPlan +validateSolverResult platform comp indepGoals pkgs = + case planPackagesProblems platform comp pkgs of + [] -> case SolverInstallPlan.new indepGoals graph of + Right plan -> plan + Left problems -> error (formatPlanProblems problems) + problems -> error (formatPkgProblems problems) + + where + graph :: Graph.Graph (ResolverPackage UnresolvedPkgLoc) + graph = Graph.fromDistinctList pkgs + + formatPkgProblems :: [PlanPackageProblem] -> String + formatPkgProblems = formatProblemMessage . map showPlanPackageProblem + formatPlanProblems :: [SolverInstallPlan.SolverPlanProblem] -> String + formatPlanProblems = formatProblemMessage . map SolverInstallPlan.showPlanProblem + + formatProblemMessage problems = + unlines $ + "internal error: could not construct a valid install plan." + : "The proposed (invalid) plan contained the following problems:" + : problems + ++ "Proposed plan:" + : [SolverInstallPlan.showPlanIndex pkgs] + + +data PlanPackageProblem = + InvalidConfiguredPackage (SolverPackage UnresolvedPkgLoc) + [PackageProblem] + | DuplicatePackageSolverId SolverId [ResolverPackage UnresolvedPkgLoc] + +showPlanPackageProblem :: PlanPackageProblem -> String +showPlanPackageProblem (InvalidConfiguredPackage pkg packageProblems) = + "Package " ++ prettyShow (packageId pkg) + ++ " has an invalid configuration, in particular:\n" + ++ unlines [ " " ++ showPackageProblem problem + | problem <- packageProblems ] +showPlanPackageProblem (DuplicatePackageSolverId pid dups) = + "Package " ++ prettyShow (packageId pid) ++ " has " + ++ show (length dups) ++ " duplicate instances." + +planPackagesProblems :: Platform -> CompilerInfo + -> [ResolverPackage UnresolvedPkgLoc] + -> [PlanPackageProblem] +planPackagesProblems platform cinfo pkgs = + [ InvalidConfiguredPackage pkg packageProblems + | Configured pkg <- pkgs + , let packageProblems = configuredPackageProblems platform cinfo pkg + , not (null packageProblems) ] + ++ [ DuplicatePackageSolverId (Graph.nodeKey (Unsafe.head dups)) dups + | dups <- duplicatesBy (comparing Graph.nodeKey) pkgs ] + +data PackageProblem = DuplicateFlag PD.FlagName + | MissingFlag PD.FlagName + | ExtraFlag PD.FlagName + | DuplicateDeps [PackageId] + | MissingDep Dependency + | ExtraDep PackageId + | InvalidDep Dependency PackageId + +showPackageProblem :: PackageProblem -> String +showPackageProblem (DuplicateFlag flag) = + "duplicate flag in the flag assignment: " ++ PD.unFlagName flag + +showPackageProblem (MissingFlag flag) = + "missing an assignment for the flag: " ++ PD.unFlagName flag + +showPackageProblem (ExtraFlag flag) = + "extra flag given that is not used by the package: " ++ PD.unFlagName flag + +showPackageProblem (DuplicateDeps pkgids) = + "duplicate packages specified as selected dependencies: " + ++ intercalate ", " (map prettyShow pkgids) + +showPackageProblem (MissingDep dep) = + "the package has a dependency " ++ prettyShow dep + ++ " but no package has been selected to satisfy it." + +showPackageProblem (ExtraDep pkgid) = + "the package configuration specifies " ++ prettyShow pkgid + ++ " but (with the given flag assignment) the package does not actually" + ++ " depend on any version of that package." + +showPackageProblem (InvalidDep dep pkgid) = + "the package depends on " ++ prettyShow dep + ++ " but the configuration specifies " ++ prettyShow pkgid + ++ " which does not satisfy the dependency." + +-- | A 'ConfiguredPackage' is valid if the flag assignment is total and if +-- in the configuration given by the flag assignment, all the package +-- dependencies are satisfied by the specified packages. +-- +configuredPackageProblems :: Platform -> CompilerInfo + -> SolverPackage UnresolvedPkgLoc -> [PackageProblem] +configuredPackageProblems platform cinfo + (SolverPackage pkg specifiedFlags stanzas specifiedDeps0 _specifiedExeDeps') = + [ DuplicateFlag flag + | flag <- PD.findDuplicateFlagAssignments specifiedFlags ] + ++ [ MissingFlag flag | OnlyInLeft flag <- mergedFlags ] + ++ [ ExtraFlag flag | OnlyInRight flag <- mergedFlags ] + ++ [ DuplicateDeps pkgs + | pkgs <- CD.nonSetupDeps (fmap (duplicatesBy (comparing packageName)) + specifiedDeps1) ] + ++ [ MissingDep dep | OnlyInLeft dep <- mergedDeps ] + ++ [ ExtraDep pkgid | OnlyInRight pkgid <- mergedDeps ] + ++ [ InvalidDep dep pkgid | InBoth dep pkgid <- mergedDeps + , not (packageSatisfiesDependency pkgid dep) ] + -- TODO: sanity tests on executable deps + where + thisPkgName :: PackageName + thisPkgName = packageName (srcpkgDescription pkg) + + specifiedDeps1 :: ComponentDeps [PackageId] + specifiedDeps1 = fmap (map solverSrcId) specifiedDeps0 + + specifiedDeps :: [PackageId] + specifiedDeps = CD.flatDeps specifiedDeps1 + + mergedFlags :: [MergeResult PD.FlagName PD.FlagName] + mergedFlags = mergeBy compare + (sort $ map PD.flagName (PD.genPackageFlags (srcpkgDescription pkg))) + (sort $ map fst (PD.unFlagAssignment specifiedFlags)) -- TODO + + packageSatisfiesDependency :: PackageIdentifier -> Dependency -> Bool + packageSatisfiesDependency + (PackageIdentifier name version) + (Dependency name' versionRange _) = assert (name == name') $ + version `withinRange` versionRange + + dependencyName (Dependency name _ _) = name + + mergedDeps :: [MergeResult Dependency PackageId] + mergedDeps = mergeDeps requiredDeps specifiedDeps + + mergeDeps :: [Dependency] -> [PackageId] + -> [MergeResult Dependency PackageId] + mergeDeps required specified = + let sortNubOn f = nubBy ((==) `on` f) . sortBy (compare `on` f) in + mergeBy + (\dep pkgid -> dependencyName dep `compare` packageName pkgid) + (sortNubOn dependencyName required) + (sortNubOn packageName specified) + + compSpec = enableStanzas stanzas + -- TODO: It would be nicer to use ComponentDeps here so we can be more + -- precise in our checks. In fact, this no longer relies on buildDepends and + -- thus should be easier to fix. As long as we _do_ use a flat list here, we + -- have to allow for duplicates when we fold specifiedDeps; once we have + -- proper ComponentDeps here we should get rid of the `nubOn` in + -- `mergeDeps`. + requiredDeps :: [Dependency] + requiredDeps = + --TODO: use something lower level than finalizePD + case finalizePD specifiedFlags + compSpec + (const True) + platform cinfo + [] + (srcpkgDescription pkg) of + Right (resolvedPkg, _) -> + -- we filter self/internal dependencies. They are still there. + -- This is INCORRECT. + -- + -- If we had per-component solver, it would make this unnecessary, + -- but no finalizePDs picks components we are not building, eg. exes. + -- See #3775 + -- + filter ((/= thisPkgName) . dependencyName) + (PD.enabledBuildDepends resolvedPkg compSpec) + ++ maybe [] PD.setupDepends (PD.setupBuildInfo resolvedPkg) + Left _ -> + error "configuredPackageInvalidDeps internal error" + + +-- ------------------------------------------------------------ +-- * Simple resolver that ignores dependencies +-- ------------------------------------------------------------ + +-- | A simplistic method of resolving a list of target package names to +-- available packages. +-- +-- Specifically, it does not consider package dependencies at all. Unlike +-- 'resolveDependencies', no attempt is made to ensure that the selected +-- packages have dependencies that are satisfiable or consistent with +-- each other. +-- +-- It is suitable for tasks such as selecting packages to download for user +-- inspection. It is not suitable for selecting packages to install. +-- +-- Note: if no installed package index is available, it is OK to pass 'mempty'. +-- It simply means preferences for installed packages will be ignored. +-- +resolveWithoutDependencies :: DepResolverParams + -> Either [ResolveNoDepsError] [UnresolvedSourcePackage] +resolveWithoutDependencies (DepResolverParams targets constraints + prefs defpref installedPkgIndex sourcePkgIndex + _reorderGoals _countConflicts _fineGrained + _minimizeConflictSet _indGoals _avoidReinstalls + _shadowing _strFlags _maxBjumps _enableBj _solveExes + _allowBootLibInstalls _onlyConstrained _order _verbosity) = + collectEithers $ map selectPackage (Set.toList targets) + where + selectPackage :: PackageName -> Either ResolveNoDepsError UnresolvedSourcePackage + selectPackage pkgname + | null choices = Left $! ResolveUnsatisfiable pkgname requiredVersions + | otherwise = Right $! maximumBy bestByPrefs choices + + where + -- Constraints + requiredVersions :: VersionRange + requiredVersions = packageConstraints pkgname + choices :: [UnresolvedSourcePackage] + choices = PackageIndex.lookupDependency sourcePkgIndex + pkgname + requiredVersions + + -- Preferences + PackagePreferences preferredVersions preferInstalled _ + = packagePreferences pkgname + + bestByPrefs :: UnresolvedSourcePackage -> UnresolvedSourcePackage -> Ordering + bestByPrefs = comparing $ \pkg -> + (installPref pkg, versionPref pkg, packageVersion pkg) + installPref :: UnresolvedSourcePackage -> Bool + installPref = case preferInstalled of + Preference.PreferLatest -> const False + Preference.PreferOldest -> const False + Preference.PreferInstalled -> not . null + . InstalledPackageIndex.lookupSourcePackageId + installedPkgIndex + . packageId + versionPref :: Package a => a -> Int + versionPref pkg = length . filter (packageVersion pkg `withinRange`) $ + preferredVersions + + packageConstraints :: PackageName -> VersionRange + packageConstraints pkgname = + Map.findWithDefault anyVersion pkgname packageVersionConstraintMap + packageVersionConstraintMap :: Map PackageName VersionRange + packageVersionConstraintMap = + let pcs = map unlabelPackageConstraint constraints + in Map.fromList [ (scopeToPackageName scope, range) + | PackageConstraint + scope (PackagePropertyVersion range) <- pcs ] + + packagePreferences :: PackageName -> PackagePreferences + packagePreferences = interpretPackagesPreference targets defpref prefs + + +collectEithers :: [Either a b] -> Either [a] [b] +collectEithers = collect . partitionEithers + where + collect ([], xs) = Right xs + collect (errs,_) = Left errs + +-- | Errors for 'resolveWithoutDependencies'. +-- +data ResolveNoDepsError = + + -- | A package name which cannot be resolved to a specific package. + -- Also gives the constraint on the version and whether there was + -- a constraint on the package being installed. + ResolveUnsatisfiable PackageName VersionRange + +instance Show ResolveNoDepsError where + show (ResolveUnsatisfiable name ver) = + "There is no available version of " ++ prettyShow name + ++ " that satisfies " ++ prettyShow (simplifyVersionRange ver) diff --git a/cabal/cabal-install/src/Distribution/Client/Dependency/Types.hs b/cabal/cabal-install/src/Distribution/Client/Dependency/Types.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Dependency/Types.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Client.Dependency.Types ( + PreSolver(..), + Solver(..), + PackagesPreferenceDefault(..), + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Text.PrettyPrint (text) + +import qualified Distribution.Compat.CharParsing as P + + +-- | All the solvers that can be selected. +data PreSolver = AlwaysModular + deriving (Eq, Ord, Show, Bounded, Enum, Generic) + +-- | All the solvers that can be used. +data Solver = Modular + deriving (Eq, Ord, Show, Bounded, Enum, Generic) + +instance Binary PreSolver +instance Binary Solver + +instance Structured PreSolver +instance Structured Solver + +instance Pretty PreSolver where + pretty AlwaysModular = text "modular" + +instance Parsec PreSolver where + parsec = do + name <- P.munch1 isAlpha + case map toLower name of + "modular" -> return AlwaysModular + _ -> P.unexpected $ "PreSolver: " ++ name + +-- | Global policy for all packages to say if we prefer package versions that +-- are already installed locally or if we just prefer the latest available. +-- +data PackagesPreferenceDefault = + + -- | Always prefer the latest version irrespective of any existing + -- installed version. + -- + -- * This is the standard policy for upgrade. + -- + PreferAllLatest + + -- | Always prefer the oldest version irrespective of any existing + -- installed version or packages explicitly requested. + -- + -- * This is enabled by --prefer-oldest. + -- + | PreferAllOldest + + -- | Always prefer the installed versions over ones that would need to be + -- installed. Secondarily, prefer latest versions (eg the latest installed + -- version or if there are none then the latest source version). + | PreferAllInstalled + + -- | Prefer the latest version for packages that are explicitly requested + -- but prefers the installed version for any other packages. + -- + -- * This is the standard policy for install. + -- + | PreferLatestForSelected + deriving Show diff --git a/cabal/cabal-install/src/Distribution/Client/DistDirLayout.hs b/cabal/cabal-install/src/Distribution/Client/DistDirLayout.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/DistDirLayout.hs @@ -0,0 +1,310 @@ +{-# LANGUAGE RecordWildCards #-} + +-- | +-- +-- The layout of the .\/dist\/ directory where cabal keeps all of its state +-- and build artifacts. +-- +module Distribution.Client.DistDirLayout ( + -- * 'DistDirLayout' + DistDirLayout(..), + DistDirParams(..), + defaultDistDirLayout, + ProjectRoot(..), + + -- * 'StoreDirLayout' + StoreDirLayout(..), + defaultStoreDirLayout, + + -- * 'CabalDirLayout' + CabalDirLayout(..), + mkCabalDirLayout, + defaultCabalDirLayout +) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import System.FilePath + +import Distribution.Package + ( PackageId, PackageIdentifier, ComponentId, UnitId ) +import Distribution.Compiler +import Distribution.Simple.Compiler + ( PackageDB(..), PackageDBStack, OptimisationLevel(..) ) +import Distribution.Types.ComponentName +import Distribution.Types.LibraryName +import Distribution.System + + +-- | Information which can be used to construct the path to +-- the build directory of a build. This is LESS fine-grained +-- than what goes into the hashed 'InstalledPackageId', +-- 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, + distParamPackageId :: PackageId, + distParamComponentId :: ComponentId, + distParamComponentName :: Maybe ComponentName, + distParamCompilerId :: CompilerId, + distParamPlatform :: Platform, + distParamOptimization :: OptimisationLevel + -- TODO (see #3343): + -- Flag assignments + -- Optimization + } + + +-- | The layout of the project state directory. Traditionally this has been +-- called the @dist@ directory. +-- +data DistDirLayout = DistDirLayout { + + -- | The root directory of the project. Many other files are relative to + -- this location. In particular, the @cabal.project@ lives here. + -- + distProjectRootDirectory :: FilePath, + + -- | The @cabal.project@ file and related like @cabal.project.freeze@. + -- The parameter is for the extension, like \"freeze\", or \"\" for the + -- main file. + -- + distProjectFile :: String -> FilePath, + + -- | The \"dist\" directory, which is the root of where cabal keeps all + -- its state including the build artifacts from each package we build. + -- + distDirectory :: FilePath, + + -- | The directory under dist where we keep the build artifacts for a + -- package we're building from a local directory. + -- + -- This uses a 'UnitId' not just a 'PackageName' because technically + -- we can have multiple instances of the same package in a solution + -- (e.g. setup deps). + -- + distBuildDirectory :: DistDirParams -> FilePath, + distBuildRootDirectory :: FilePath, + + -- | The directory under dist where we download tarballs and source + -- control repos to. + -- + distDownloadSrcDirectory :: FilePath, + + -- | The directory under dist where we put the unpacked sources of + -- packages, in those cases where it makes sense to keep the build + -- artifacts to reduce rebuild times. + -- + distUnpackedSrcDirectory :: PackageId -> FilePath, + distUnpackedSrcRootDirectory :: FilePath, + + -- | The location for project-wide cache files (e.g. state used in + -- incremental rebuilds). + -- + distProjectCacheFile :: String -> FilePath, + distProjectCacheDirectory :: FilePath, + + -- | The location for package-specific cache files (e.g. state used in + -- incremental rebuilds). + -- + distPackageCacheFile :: DistDirParams -> String -> FilePath, + distPackageCacheDirectory :: DistDirParams -> FilePath, + + -- | The location that sdists are placed by default. + distSdistFile :: PackageId -> FilePath, + distSdistDirectory :: FilePath, + + distTempDirectory :: FilePath, + distBinDirectory :: FilePath, + + distPackageDB :: CompilerId -> PackageDB + } + + +-- | The layout of a cabal nix-style store. +-- +data StoreDirLayout = StoreDirLayout { + storeDirectory :: CompilerId -> FilePath, + storePackageDirectory :: CompilerId -> UnitId -> FilePath, + storePackageDBPath :: CompilerId -> FilePath, + storePackageDB :: CompilerId -> PackageDB, + storePackageDBStack :: CompilerId -> PackageDBStack, + storeIncomingDirectory :: CompilerId -> FilePath, + storeIncomingLock :: CompilerId -> UnitId -> FilePath + } + + +--TODO: move to another module, e.g. CabalDirLayout? +-- or perhaps rename this module to DirLayouts. + +-- | The layout of the user-wide cabal directory, that is the @~/.cabal@ dir +-- on unix, and equivalents on other systems. +-- +-- At the moment this is just a partial specification, but the idea is +-- eventually to cover it all. +-- +data CabalDirLayout = CabalDirLayout { + cabalStoreDirLayout :: StoreDirLayout, + + cabalLogsDirectory :: FilePath + } + + +-- | Information about the root directory of the project. +-- +-- It can either be an implicit project root in the current dir if no +-- @cabal.project@ file is found, or an explicit root if the file is found. +-- +data ProjectRoot = + -- | -- ^ An implicit project root. It contains the absolute project + -- root dir. + ProjectRootImplicit FilePath + + -- | -- ^ An explicit project root. It contains the absolute project + -- root dir and the relative @cabal.project@ file (or explicit override) + | ProjectRootExplicit FilePath FilePath + deriving (Eq, Show) + +-- | Make the default 'DistDirLayout' based on the project root dir and +-- optional overrides for the location of the @dist@ directory and the +-- @cabal.project@ file. +-- +defaultDistDirLayout :: ProjectRoot -- ^ the project root + -> Maybe FilePath -- ^ the @dist@ directory or default + -- (absolute or relative to the root) + -> DistDirLayout +defaultDistDirLayout projectRoot mdistDirectory = + DistDirLayout {..} + where + (projectRootDir, projectFile) = case projectRoot of + ProjectRootImplicit dir -> (dir, dir "cabal.project") + ProjectRootExplicit dir file -> (dir, dir file) + + distProjectRootDirectory :: FilePath + distProjectRootDirectory = projectRootDir + + distProjectFile :: String -> FilePath + distProjectFile ext = projectFile <.> ext + + distDirectory :: FilePath + distDirectory = distProjectRootDirectory + fromMaybe "dist-newstyle" mdistDirectory + --TODO: switch to just dist at some point, or some other new name + + distBuildRootDirectory :: FilePath + distBuildRootDirectory = distDirectory "build" + + distBuildDirectory :: DistDirParams -> FilePath + distBuildDirectory params = + distBuildRootDirectory + 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) + + distUnpackedSrcRootDirectory :: FilePath + distUnpackedSrcRootDirectory = distDirectory "src" + + distUnpackedSrcDirectory :: PackageId -> FilePath + distUnpackedSrcDirectory pkgid = distUnpackedSrcRootDirectory + prettyShow pkgid + -- we shouldn't get name clashes so this should be fine: + distDownloadSrcDirectory :: FilePath + distDownloadSrcDirectory = distUnpackedSrcRootDirectory + + distProjectCacheDirectory :: FilePath + distProjectCacheDirectory = distDirectory "cache" + + distProjectCacheFile :: FilePath -> FilePath + distProjectCacheFile name = distProjectCacheDirectory name + + distPackageCacheDirectory :: DistDirParams -> FilePath + distPackageCacheDirectory params = distBuildDirectory params "cache" + + distPackageCacheFile :: DistDirParams -> String -> FilePath + distPackageCacheFile params name = distPackageCacheDirectory params name + + distSdistFile :: PackageIdentifier -> FilePath + distSdistFile pid = distSdistDirectory prettyShow pid <.> "tar.gz" + + distSdistDirectory :: FilePath + distSdistDirectory = distDirectory "sdist" + + distTempDirectory :: FilePath + distTempDirectory = distDirectory "tmp" + + distBinDirectory :: FilePath + distBinDirectory = distDirectory "bin" + + distPackageDBPath :: CompilerId -> FilePath + distPackageDBPath compid = distDirectory "packagedb" prettyShow compid + + distPackageDB :: CompilerId -> PackageDB + distPackageDB = SpecificPackageDB . distPackageDBPath + + +defaultStoreDirLayout :: FilePath -> StoreDirLayout +defaultStoreDirLayout storeRoot = + StoreDirLayout {..} + where + storeDirectory :: CompilerId -> FilePath + storeDirectory compid = + storeRoot prettyShow compid + + storePackageDirectory :: CompilerId -> UnitId -> FilePath + storePackageDirectory compid ipkgid = + storeDirectory compid prettyShow ipkgid + + storePackageDBPath :: CompilerId -> FilePath + storePackageDBPath compid = + storeDirectory compid "package.db" + + storePackageDB :: CompilerId -> PackageDB + storePackageDB compid = + SpecificPackageDB (storePackageDBPath compid) + + storePackageDBStack :: CompilerId -> PackageDBStack + storePackageDBStack compid = + [GlobalPackageDB, storePackageDB compid] + + storeIncomingDirectory :: CompilerId -> FilePath + storeIncomingDirectory compid = + storeDirectory compid "incoming" + + storeIncomingLock :: CompilerId -> UnitId -> FilePath + storeIncomingLock compid unitid = + storeIncomingDirectory compid prettyShow unitid <.> "lock" + + +defaultCabalDirLayout :: FilePath -> CabalDirLayout +defaultCabalDirLayout cabalDir = + mkCabalDirLayout cabalDir Nothing Nothing + +mkCabalDirLayout :: FilePath -- ^ Cabal directory + -> Maybe FilePath -- ^ Store directory. Must be absolute + -> Maybe FilePath -- ^ Log directory + -> CabalDirLayout +mkCabalDirLayout cabalDir mstoreDir mlogDir = + CabalDirLayout {..} + where + cabalStoreDirLayout :: StoreDirLayout + cabalStoreDirLayout = + defaultStoreDirLayout (fromMaybe (cabalDir "store") mstoreDir) + cabalLogsDirectory :: FilePath + cabalLogsDirectory = fromMaybe (cabalDir "logs") mlogDir diff --git a/cabal/cabal-install/src/Distribution/Client/Fetch.hs b/cabal/cabal-install/src/Distribution/Client/Fetch.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Fetch.hs @@ -0,0 +1,232 @@ +------------------------------------------------------------------------------- | +-- Module : Distribution.Client.Fetch +-- Copyright : (c) David Himmelstrup 2005 +-- Duncan Coutts 2011 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- The cabal fetch command +----------------------------------------------------------------------------- +module Distribution.Client.Fetch ( + fetch, + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Client.Types +import Distribution.Client.Targets +import Distribution.Client.FetchUtils hiding (fetchPackage) +import Distribution.Client.Dependency +import Distribution.Client.IndexUtils as IndexUtils + ( getSourcePackages, getInstalledPackages ) +import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan +import Distribution.Client.Setup + ( GlobalFlags(..), FetchFlags(..), RepoContext(..) ) + +import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.LabeledPackageConstraint +import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.PkgConfigDb ( PkgConfigDb, readPkgConfigDb ) +import Distribution.Solver.Types.SolverPackage +import Distribution.Solver.Types.SourcePackage + +import Distribution.Package + ( packageId ) +import Distribution.Simple.Compiler + ( Compiler, compilerInfo, PackageDBStack ) +import Distribution.Simple.PackageIndex (InstalledPackageIndex) +import Distribution.Simple.Program + ( ProgramDb ) +import Distribution.Simple.Setup + ( fromFlag, fromFlagOrDefault ) +import Distribution.Simple.Utils + ( die', notice, debug ) +import Distribution.System + ( Platform ) + +-- ------------------------------------------------------------ +-- * The fetch command +-- ------------------------------------------------------------ + +--TODO: +-- * add fetch -o support +-- * support tarball URLs via ad-hoc download cache (or in -o mode?) +-- * suggest using --no-deps, unpack or fetch -o if deps cannot be satisfied +-- * Port various flags from install: +-- * --upgrade-dependencies +-- * --constraint and --preference +-- * --only-dependencies, but note it conflicts with --no-deps + + +-- | Fetch a list of packages and their dependencies. +-- +fetch :: Verbosity + -> PackageDBStack + -> RepoContext + -> Compiler + -> Platform + -> ProgramDb + -> GlobalFlags + -> FetchFlags + -> [UserTarget] + -> IO () +fetch verbosity _ _ _ _ _ _ _ [] = + notice verbosity "No packages requested. Nothing to do." + +fetch verbosity packageDBs repoCtxt comp platform progdb + _ fetchFlags userTargets = do + + traverse_ (checkTarget verbosity) userTargets + + installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb + sourcePkgDb <- getSourcePackages verbosity repoCtxt + pkgConfigDb <- readPkgConfigDb verbosity progdb + + pkgSpecifiers <- resolveUserTargets verbosity repoCtxt + (packageIndex sourcePkgDb) + userTargets + + pkgs <- planPackages + verbosity comp platform fetchFlags + installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers + + pkgs' <- filterM (fmap not . isFetched . srcpkgSource) pkgs + if null pkgs' + --TODO: when we add support for remote tarballs then this message + -- will need to be changed because for remote tarballs we fetch them + -- at the earlier phase. + then notice verbosity $ "No packages need to be fetched. " + ++ "All the requested packages are already local " + ++ "or cached locally." + else if dryRun + then notice verbosity $ unlines $ + "The following packages would be fetched:" + : map (prettyShow . packageId) pkgs' + + else traverse_ (fetchPackage verbosity repoCtxt . srcpkgSource) pkgs' + + where + dryRun = fromFlag (fetchDryRun fetchFlags) + +planPackages :: Verbosity + -> Compiler + -> Platform + -> FetchFlags + -> InstalledPackageIndex + -> SourcePackageDb + -> PkgConfigDb + -> [PackageSpecifier UnresolvedSourcePackage] + -> IO [UnresolvedSourcePackage] +planPackages verbosity comp platform fetchFlags + installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers + + | includeDependencies = do + solver <- chooseSolver verbosity + (fromFlag (fetchSolver fetchFlags)) (compilerInfo comp) + notice verbosity "Resolving dependencies..." + installPlan <- foldProgress logMsg (die' verbosity) return $ + resolveDependencies + platform (compilerInfo comp) pkgConfigDb + solver + resolverParams + + -- The packages we want to fetch are those packages the 'InstallPlan' + -- that are in the 'InstallPlan.Configured' state. + return + [ solverPkgSource cpkg + | (SolverInstallPlan.Configured cpkg) + <- SolverInstallPlan.toList installPlan ] + + | otherwise = + either (die' verbosity . unlines . map show) return $ + resolveWithoutDependencies resolverParams + + where + resolverParams :: DepResolverParams + resolverParams = + + setMaxBackjumps (if maxBackjumps < 0 then Nothing + else Just maxBackjumps) + + . setIndependentGoals independentGoals + + . setReorderGoals reorderGoals + + . setCountConflicts countConflicts + + . setFineGrainedConflicts fineGrainedConflicts + + . setMinimizeConflictSet minimizeConflictSet + + . setShadowPkgs shadowPkgs + + . setStrongFlags strongFlags + + . setAllowBootLibInstalls allowBootLibInstalls + + . setOnlyConstrained onlyConstrained + + . setSolverVerbosity verbosity + + . addConstraints + [ let pc = PackageConstraint + (scopeToplevel $ pkgSpecifierTarget pkgSpecifier) + (PackagePropertyStanzas stanzas) + in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget + | pkgSpecifier <- pkgSpecifiers ] + + -- Reinstall the targets given on the command line so that the dep + -- resolver will decide that they need fetching, even if they're + -- 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 + + includeDependencies = fromFlag (fetchDeps fetchFlags) + logMsg message rest = debug verbosity message >> rest + + stanzas = [ TestStanzas | testsEnabled ] + ++ [ BenchStanzas | benchmarksEnabled ] + testsEnabled = fromFlagOrDefault False $ fetchTests fetchFlags + benchmarksEnabled = fromFlagOrDefault False $ fetchBenchmarks fetchFlags + + reorderGoals = fromFlag (fetchReorderGoals fetchFlags) + countConflicts = fromFlag (fetchCountConflicts fetchFlags) + fineGrainedConflicts = fromFlag (fetchFineGrainedConflicts fetchFlags) + minimizeConflictSet = fromFlag (fetchMinimizeConflictSet fetchFlags) + independentGoals = fromFlag (fetchIndependentGoals fetchFlags) + shadowPkgs = fromFlag (fetchShadowPkgs fetchFlags) + strongFlags = fromFlag (fetchStrongFlags fetchFlags) + maxBackjumps = fromFlag (fetchMaxBackjumps fetchFlags) + allowBootLibInstalls = fromFlag (fetchAllowBootLibInstalls fetchFlags) + onlyConstrained = fromFlag (fetchOnlyConstrained fetchFlags) + + +checkTarget :: Verbosity -> UserTarget -> IO () +checkTarget verbosity target = case target of + UserTargetRemoteTarball _uri + -> die' verbosity $ "The 'fetch' command does not yet support remote tarballs. " + ++ "In the meantime you can use the 'unpack' commands." + _ -> return () + +fetchPackage :: Verbosity -> RepoContext -> PackageLocation a -> IO () +fetchPackage verbosity repoCtxt pkgsrc = case pkgsrc of + LocalUnpackedPackage _dir -> return () + LocalTarballPackage _file -> return () + + RemoteTarballPackage _uri _ -> + die' verbosity $ "The 'fetch' command does not yet support remote tarballs. " + ++ "In the meantime you can use the 'unpack' commands." + + RemoteSourceRepoPackage _repo _ -> + die' verbosity $ "The 'fetch' command does not yet support remote " + ++ "source repositories." + + RepoTarballPackage repo pkgid _ -> do + _ <- fetchRepoTarball verbosity repoCtxt repo pkgid + return () diff --git a/cabal/cabal-install/src/Distribution/Client/FetchUtils.hs b/cabal/cabal-install/src/Distribution/Client/FetchUtils.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/FetchUtils.hs @@ -0,0 +1,326 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.FetchUtils +-- Copyright : (c) David Himmelstrup 2005 +-- Duncan Coutts 2011 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Functions for fetching packages +----------------------------------------------------------------------------- +{-# LANGUAGE RecordWildCards #-} +module Distribution.Client.FetchUtils ( + + -- * fetching packages + fetchPackage, + isFetched, + checkFetched, + + -- ** specifically for repo packages + checkRepoTarballFetched, + fetchRepoTarball, + + -- ** fetching packages asynchronously + asyncFetchPackages, + waitAsyncFetchPackage, + AsyncFetchMap, + + -- * fetching other things + downloadIndex, + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Client.Types +import Distribution.Client.HttpUtils + ( downloadURI, isOldHackageURI, DownloadResult(..) + , HttpTransport(..), transportCheckHttps, remoteRepoCheckHttps ) + +import Distribution.Package + ( PackageId, packageName, packageVersion ) +import Distribution.Simple.Utils + ( notice, info, debug, die' ) +import Distribution.Verbosity + ( verboseUnmarkOutput ) +import Distribution.Client.GlobalFlags + ( RepoContext(..) ) +import Distribution.Client.Utils + ( ProgressPhase(..), progressMessage ) + +import qualified Data.Map as Map +import qualified Control.Exception.Safe as Safe +import Control.Concurrent.Async +import Control.Concurrent.MVar +import System.Directory + ( doesFileExist, createDirectoryIfMissing, getTemporaryDirectory ) +import System.IO + ( openTempFile, hClose ) +import System.FilePath + ( (), (<.>) ) +import qualified System.FilePath.Posix as FilePath.Posix + ( combine, joinPath ) +import Network.URI + ( URI(uriPath) ) + +import qualified Hackage.Security.Client as Sec + +-- ------------------------------------------------------------ +-- * Actually fetch things +-- ------------------------------------------------------------ + +-- | Returns @True@ if the package has already been fetched +-- or does not need fetching. +-- +isFetched :: UnresolvedPkgLoc -> IO Bool +isFetched loc = case loc of + LocalUnpackedPackage _dir -> return True + LocalTarballPackage _file -> return True + RemoteTarballPackage _uri local -> return (isJust local) + RepoTarballPackage repo pkgid _ -> doesFileExist (packageFile repo pkgid) + RemoteSourceRepoPackage _ local -> return (isJust local) + + +-- | Checks if the package has already been fetched (or does not need +-- fetching) and if so returns evidence in the form of a 'PackageLocation' +-- with a resolved local file location. +-- +checkFetched :: UnresolvedPkgLoc + -> IO (Maybe ResolvedPkgLoc) +checkFetched loc = case loc of + LocalUnpackedPackage dir -> + return (Just $ LocalUnpackedPackage dir) + LocalTarballPackage file -> + return (Just $ LocalTarballPackage file) + RemoteTarballPackage uri (Just file) -> + return (Just $ RemoteTarballPackage uri file) + RepoTarballPackage repo pkgid (Just file) -> + return (Just $ RepoTarballPackage repo pkgid file) + RemoteSourceRepoPackage repo (Just file) -> + return (Just $ RemoteSourceRepoPackage repo file) + + RemoteTarballPackage _uri Nothing -> return Nothing + RemoteSourceRepoPackage _repo Nothing -> return Nothing + RepoTarballPackage repo pkgid Nothing -> + fmap (fmap (RepoTarballPackage repo pkgid)) + (checkRepoTarballFetched repo pkgid) + +-- | Like 'checkFetched' but for the specific case of a 'RepoTarballPackage'. +-- +checkRepoTarballFetched :: Repo -> PackageId -> IO (Maybe FilePath) +checkRepoTarballFetched repo pkgid = do + let file = packageFile repo pkgid + exists <- doesFileExist file + if exists + then return (Just file) + else return Nothing + + +-- | Fetch a package if we don't have it already. +-- +fetchPackage :: Verbosity + -> RepoContext + -> UnresolvedPkgLoc + -> IO ResolvedPkgLoc +fetchPackage verbosity repoCtxt loc = case loc of + LocalUnpackedPackage dir -> + return (LocalUnpackedPackage dir) + LocalTarballPackage file -> + return (LocalTarballPackage file) + RemoteTarballPackage uri (Just file) -> + return (RemoteTarballPackage uri file) + RepoTarballPackage repo pkgid (Just file) -> + return (RepoTarballPackage repo pkgid file) + RemoteSourceRepoPackage repo (Just dir) -> + return (RemoteSourceRepoPackage repo dir) + + RemoteTarballPackage uri Nothing -> do + path <- downloadTarballPackage uri + return (RemoteTarballPackage uri path) + RepoTarballPackage repo pkgid Nothing -> do + local <- fetchRepoTarball verbosity repoCtxt repo pkgid + return (RepoTarballPackage repo pkgid local) + RemoteSourceRepoPackage _repo Nothing -> + die' verbosity "fetchPackage: source repos not supported" + where + downloadTarballPackage :: URI -> IO FilePath + downloadTarballPackage uri = do + transport <- repoContextGetTransport repoCtxt + transportCheckHttps verbosity transport uri + notice verbosity ("Downloading " ++ show uri) + tmpdir <- getTemporaryDirectory + (path, hnd) <- openTempFile tmpdir "cabal-.tar.gz" + hClose hnd + _ <- downloadURI transport verbosity uri path + return path + + +-- | Fetch a repo package if we don't have it already. +-- +fetchRepoTarball :: Verbosity -> RepoContext -> Repo -> PackageId -> IO FilePath +fetchRepoTarball verbosity' repoCtxt repo pkgid = do + fetched <- doesFileExist (packageFile repo pkgid) + if fetched + then do info verbosity $ prettyShow pkgid ++ " has already been downloaded." + return (packageFile repo pkgid) + else do progressMessage verbosity ProgressDownloading (prettyShow pkgid) + res <- downloadRepoPackage + progressMessage verbosity ProgressDownloaded (prettyShow pkgid) + return res + where + -- whether we download or not is non-deterministic + verbosity = verboseUnmarkOutput verbosity' + + downloadRepoPackage :: IO FilePath + downloadRepoPackage = case repo of + RepoLocalNoIndex{} -> return (packageFile repo pkgid) + + RepoRemote{..} -> do + transport <- repoContextGetTransport repoCtxt + remoteRepoCheckHttps verbosity transport repoRemote + let uri = packageURI repoRemote pkgid + dir = packageDir repo pkgid + path = packageFile repo pkgid + createDirectoryIfMissing True dir + _ <- downloadURI transport verbosity uri path + return path + + RepoSecure{} -> repoContextWithSecureRepo repoCtxt repo $ \rep -> do + let dir = packageDir repo pkgid + path = packageFile repo pkgid + createDirectoryIfMissing True dir + Sec.uncheckClientErrors $ do + info verbosity ("Writing " ++ path) + Sec.downloadPackage' rep pkgid path + return path + +-- | Downloads an index file to [config-dir/packages/serv-id] without +-- hackage-security. You probably don't want to call this directly; +-- use 'updateRepo' instead. +-- +downloadIndex :: HttpTransport -> Verbosity -> RemoteRepo -> FilePath -> IO DownloadResult +downloadIndex transport verbosity remoteRepo cacheDir = do + remoteRepoCheckHttps verbosity transport remoteRepo + let uri = (remoteRepoURI remoteRepo) { + uriPath = uriPath (remoteRepoURI remoteRepo) + `FilePath.Posix.combine` "00-index.tar.gz" + } + path = cacheDir "00-index" <.> "tar.gz" + createDirectoryIfMissing True cacheDir + downloadURI transport verbosity uri path + + +-- ------------------------------------------------------------ +-- * Async fetch wrapper utilities +-- ------------------------------------------------------------ + +type AsyncFetchMap = Map UnresolvedPkgLoc + (MVar (Either SomeException ResolvedPkgLoc)) + +-- | Fork off an async action to download the given packages (by location). +-- +-- The downloads are initiated in order, so you can arrange for packages that +-- will likely be needed sooner to be earlier in the list. +-- +-- The body action is passed a map from those packages (identified by their +-- location) to a completion var for that package. So the body action should +-- lookup the location and use 'waitAsyncFetchPackage' to get the result. +-- +-- Synchronous exceptions raised by the download actions are delivered +-- via 'waitAsyncFetchPackage'. +-- +asyncFetchPackages :: Verbosity + -> RepoContext + -> [UnresolvedPkgLoc] + -> (AsyncFetchMap -> IO a) + -> IO a +asyncFetchPackages verbosity repoCtxt pkglocs body = do + --TODO: [nice to have] use parallel downloads? + + asyncDownloadVars <- sequenceA + [ do v <- newEmptyMVar + return (pkgloc, v) + | pkgloc <- pkglocs + ] + + let fetchPackages :: IO () + fetchPackages = + for_ asyncDownloadVars $ \(pkgloc, var) -> do + -- Suppress marking here, because 'withAsync' means + -- that we get nondeterministic interleaving. + -- It is essential that we don't catch async exceptions here, + -- specifically 'AsyncCancelled' thrown at us from 'concurrently'. + result <- Safe.try $ + fetchPackage (verboseUnmarkOutput verbosity) repoCtxt pkgloc + putMVar var result + + (_, res) <- concurrently + fetchPackages + (body $ Map.fromList asyncDownloadVars) + pure res + + +-- | Expect to find a download in progress in the given 'AsyncFetchMap' +-- and wait on it to finish. +-- +-- If the download failed with an exception then this will be thrown. +-- +-- Note: This function is supposed to be idempotent, as our install plans +-- can now use the same tarball for many builds, e.g. different +-- components and/or qualified goals, and these all go through the +-- download phase so we end up using 'waitAsyncFetchPackage' twice on +-- the same package. C.f. #4461. +waitAsyncFetchPackage :: Verbosity + -> AsyncFetchMap + -> UnresolvedPkgLoc + -> IO ResolvedPkgLoc +waitAsyncFetchPackage verbosity downloadMap srcloc = + case Map.lookup srcloc downloadMap of + Just hnd -> do + debug verbosity $ "Waiting for download of " ++ show srcloc + either throwIO return =<< readMVar hnd + Nothing -> fail "waitAsyncFetchPackage: package not being downloaded" + + +-- ------------------------------------------------------------ +-- * Path utilities +-- ------------------------------------------------------------ + +-- | Generate the full path to the locally cached copy of +-- the tarball for a given @PackageIdentifer@. +-- +packageFile :: Repo -> PackageId -> FilePath +packageFile repo pkgid = packageDir repo pkgid + prettyShow pkgid + <.> "tar.gz" + +-- | Generate the full path to the directory where the local cached copy of +-- the tarball for a given @PackageIdentifer@ is stored. +-- +packageDir :: Repo -> PackageId -> FilePath +packageDir (RepoLocalNoIndex (LocalRepo _ dir _) _) _pkgid = dir +packageDir repo pkgid = repoLocalDir repo + prettyShow (packageName pkgid) + prettyShow (packageVersion pkgid) + +-- | Generate the URI of the tarball for a given package. +-- +packageURI :: RemoteRepo -> PackageId -> URI +packageURI repo pkgid | isOldHackageURI (remoteRepoURI repo) = + (remoteRepoURI repo) { + uriPath = FilePath.Posix.joinPath + [uriPath (remoteRepoURI repo) + ,prettyShow (packageName pkgid) + ,prettyShow (packageVersion pkgid) + ,prettyShow pkgid <.> "tar.gz"] + } +packageURI repo pkgid = + (remoteRepoURI repo) { + uriPath = FilePath.Posix.joinPath + [uriPath (remoteRepoURI repo) + ,"package" + ,prettyShow pkgid <.> "tar.gz"] + } diff --git a/cabal/cabal-install/src/Distribution/Client/FileMonitor.hs b/cabal/cabal-install/src/Distribution/Client/FileMonitor.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/FileMonitor.hs @@ -0,0 +1,1171 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric, DeriveFunctor, GeneralizedNewtypeDeriving, + NamedFieldPuns, BangPatterns, ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | An abstraction to help with re-running actions when files or other +-- input values they depend on have changed. +-- +module Distribution.Client.FileMonitor ( + + -- * Declaring files to monitor + MonitorFilePath(..), + MonitorKindFile(..), + MonitorKindDir(..), + FilePathGlob(..), + monitorFile, + monitorFileHashed, + monitorNonExistentFile, + monitorFileExistence, + monitorDirectory, + monitorNonExistentDirectory, + monitorDirectoryExistence, + monitorFileOrDirectory, + monitorFileGlob, + monitorFileGlobExistence, + monitorFileSearchPath, + monitorFileHashedSearchPath, + + -- * Creating and checking sets of monitored files + FileMonitor(..), + newFileMonitor, + MonitorChanged(..), + MonitorChangedReason(..), + checkFileMonitorChanged, + updateFileMonitor, + MonitorTimestamp, + beginUpdateFileMonitor, + + -- * Internal + MonitorStateFileSet, + MonitorStateFile, + MonitorStateGlob, + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude +import qualified Distribution.Compat.Binary as Binary + +import qualified Data.Map.Strict as Map +import Data.Binary.Get (runGetOrFail) +import qualified Data.ByteString.Lazy as BS +import qualified Data.Hashable as Hashable + +import Control.Monad +import Control.Monad.Trans (MonadIO, liftIO) +import Control.Monad.State (StateT, mapStateT) +import qualified Control.Monad.State as State +import Control.Monad.Except (ExceptT, runExceptT, withExceptT, + throwError) +import Control.Exception + +import Distribution.Compat.Time +import Distribution.Client.Glob +import Distribution.Simple.Utils (handleDoesNotExist, writeFileAtomic) +import Distribution.Client.Utils (mergeBy, MergeResult(..)) +import Distribution.Utils.Structured (structuredEncode, Tag (..)) +import System.FilePath +import System.Directory +import System.IO + +------------------------------------------------------------------------------ +-- Types for specifying files to monitor +-- + + +-- | A description of a file (or set of files) to monitor for changes. +-- +-- Where file paths are relative they are relative to a common directory +-- (e.g. project root), not necessarily the process current directory. +-- +data MonitorFilePath = + MonitorFile { + monitorKindFile :: !MonitorKindFile, + monitorKindDir :: !MonitorKindDir, + monitorPath :: !FilePath + } + | MonitorFileGlob { + monitorKindFile :: !MonitorKindFile, + monitorKindDir :: !MonitorKindDir, + monitorPathGlob :: !FilePathGlob + } + deriving (Eq, Show, Generic) + +data MonitorKindFile = FileExists + | FileModTime + | FileHashed + | FileNotExists + deriving (Eq, Show, Generic) + +data MonitorKindDir = DirExists + | DirModTime + | DirNotExists + deriving (Eq, Show, Generic) + +instance Binary MonitorFilePath +instance Binary MonitorKindFile +instance Binary MonitorKindDir + +instance Structured MonitorFilePath +instance Structured MonitorKindFile +instance Structured MonitorKindDir + +-- | Monitor a single file for changes, based on its modification time. +-- The monitored file is considered to have changed if it no longer +-- exists or if its modification time has changed. +-- +monitorFile :: FilePath -> MonitorFilePath +monitorFile = MonitorFile FileModTime DirNotExists + +-- | Monitor a single file for changes, based on its modification time +-- and content hash. The monitored file is considered to have changed if +-- it no longer exists or if its modification time and content hash have +-- changed. +-- +monitorFileHashed :: FilePath -> MonitorFilePath +monitorFileHashed = MonitorFile FileHashed DirNotExists + +-- | Monitor a single non-existent file for changes. The monitored file +-- is considered to have changed if it exists. +-- +monitorNonExistentFile :: FilePath -> MonitorFilePath +monitorNonExistentFile = MonitorFile FileNotExists DirNotExists + +-- | Monitor a single file for existence only. The monitored file is +-- considered to have changed if it no longer exists. +-- +monitorFileExistence :: FilePath -> MonitorFilePath +monitorFileExistence = MonitorFile FileExists DirNotExists + +-- | Monitor a single directory for changes, based on its modification +-- time. The monitored directory is considered to have changed if it no +-- longer exists or if its modification time has changed. +-- +monitorDirectory :: FilePath -> MonitorFilePath +monitorDirectory = MonitorFile FileNotExists DirModTime + +-- | Monitor a single non-existent directory for changes. The monitored +-- directory is considered to have changed if it exists. +-- +monitorNonExistentDirectory :: FilePath -> MonitorFilePath +-- Just an alias for monitorNonExistentFile, since you can't +-- tell the difference between a non-existent directory and +-- a non-existent file :) +monitorNonExistentDirectory = monitorNonExistentFile + +-- | Monitor a single directory for existence. The monitored directory is +-- considered to have changed only if it no longer exists. +-- +monitorDirectoryExistence :: FilePath -> MonitorFilePath +monitorDirectoryExistence = MonitorFile FileNotExists DirExists + +-- | Monitor a single file or directory for changes, based on its modification +-- time. The monitored file is considered to have changed if it no longer +-- exists or if its modification time has changed. +-- +monitorFileOrDirectory :: FilePath -> MonitorFilePath +monitorFileOrDirectory = MonitorFile FileModTime DirModTime + +-- | Monitor a set of files (or directories) identified by a file glob. +-- The monitored glob is considered to have changed if the set of files +-- matching the glob changes (i.e. creations or deletions), or for files if the +-- modification time and content hash of any matching file has changed. +-- +monitorFileGlob :: FilePathGlob -> MonitorFilePath +monitorFileGlob = MonitorFileGlob FileHashed DirExists + +-- | Monitor a set of files (or directories) identified by a file glob for +-- existence only. The monitored glob is considered to have changed if the set +-- of files matching the glob changes (i.e. creations or deletions). +-- +monitorFileGlobExistence :: FilePathGlob -> MonitorFilePath +monitorFileGlobExistence = MonitorFileGlob FileExists DirExists + +-- | Creates a list of files to monitor when you search for a file which +-- unsuccessfully looked in @notFoundAtPaths@ before finding it at +-- @foundAtPath@. +monitorFileSearchPath :: [FilePath] -> FilePath -> [MonitorFilePath] +monitorFileSearchPath notFoundAtPaths foundAtPath = + monitorFile foundAtPath + : map monitorNonExistentFile notFoundAtPaths + +-- | Similar to 'monitorFileSearchPath', but also instructs us to +-- monitor the hash of the found file. +monitorFileHashedSearchPath :: [FilePath] -> FilePath -> [MonitorFilePath] +monitorFileHashedSearchPath notFoundAtPaths foundAtPath = + monitorFileHashed foundAtPath + : map monitorNonExistentFile notFoundAtPaths + + +------------------------------------------------------------------------------ +-- Implementation types, files status +-- + +-- | The state necessary to determine whether a set of monitored +-- files has changed. It consists of two parts: a set of specific +-- files to be monitored (index by their path), and a list of +-- globs, which monitor may files at once. +data MonitorStateFileSet + = MonitorStateFileSet ![MonitorStateFile] + ![MonitorStateGlob] + -- Morally this is not actually a set but a bag (represented by lists). + -- There is no principled reason to use a bag here rather than a set, but + -- there is also no particular gain either. That said, we do preserve the + -- order of the lists just to reduce confusion (and have predictable I/O + -- patterns). + deriving (Show, Generic) + +instance Binary MonitorStateFileSet +instance Structured MonitorStateFileSet + +type Hash = Int + +-- | The state necessary to determine whether a monitored file has changed. +-- +-- This covers all the cases of 'MonitorFilePath' except for globs which is +-- covered separately by 'MonitorStateGlob'. +-- +-- The @Maybe ModTime@ is to cover the case where we already consider the +-- file to have changed, either because it had already changed by the time we +-- did the snapshot (i.e. too new, changed since start of update process) or it +-- no longer exists at all. +-- +data MonitorStateFile = MonitorStateFile !MonitorKindFile !MonitorKindDir + !FilePath !MonitorStateFileStatus + deriving (Show, Generic) + +data MonitorStateFileStatus + = MonitorStateFileExists + | MonitorStateFileModTime !ModTime -- ^ cached file mtime + | MonitorStateFileHashed !ModTime !Hash -- ^ cached mtime and content hash + | MonitorStateDirExists + | MonitorStateDirModTime !ModTime -- ^ cached dir mtime + | MonitorStateNonExistent + | MonitorStateAlreadyChanged + deriving (Show, Generic) + +instance Binary MonitorStateFile +instance Binary MonitorStateFileStatus +instance Structured MonitorStateFile +instance Structured MonitorStateFileStatus + +-- | The state necessary to determine whether the files matched by a globbing +-- match have changed. +-- +data MonitorStateGlob = MonitorStateGlob !MonitorKindFile !MonitorKindDir + !FilePathRoot !MonitorStateGlobRel + deriving (Show, Generic) + +data MonitorStateGlobRel + = MonitorStateGlobDirs + !Glob !FilePathGlobRel + !ModTime + ![(FilePath, MonitorStateGlobRel)] -- invariant: sorted + + | MonitorStateGlobFiles + !Glob + !ModTime + ![(FilePath, MonitorStateFileStatus)] -- invariant: sorted + + | MonitorStateGlobDirTrailing + deriving (Show, Generic) + +instance Binary MonitorStateGlob +instance Binary MonitorStateGlobRel + +instance Structured MonitorStateGlob +instance Structured MonitorStateGlobRel + +-- | We can build a 'MonitorStateFileSet' from a set of 'MonitorFilePath' by +-- inspecting the state of the file system, and we can go in the reverse +-- direction by just forgetting the extra info. +-- +reconstructMonitorFilePaths :: MonitorStateFileSet -> [MonitorFilePath] +reconstructMonitorFilePaths (MonitorStateFileSet singlePaths globPaths) = + map getSinglePath singlePaths ++ map getGlobPath globPaths + where + getSinglePath :: MonitorStateFile -> MonitorFilePath + getSinglePath (MonitorStateFile kindfile kinddir filepath _) = + MonitorFile kindfile kinddir filepath + + getGlobPath :: MonitorStateGlob -> MonitorFilePath + getGlobPath (MonitorStateGlob kindfile kinddir root gstate) = + MonitorFileGlob kindfile kinddir $ FilePathGlob root $ + case gstate of + MonitorStateGlobDirs glob globs _ _ -> GlobDir glob globs + MonitorStateGlobFiles glob _ _ -> GlobFile glob + MonitorStateGlobDirTrailing -> GlobDirTrailing + +------------------------------------------------------------------------------ +-- Checking the status of monitored files +-- + +-- | A monitor for detecting changes to a set of files. It can be used to +-- efficiently test if any of a set of files (specified individually or by +-- glob patterns) has changed since some snapshot. In addition, it also checks +-- for changes in a value (of type @a@), and when there are no changes in +-- either it returns a saved value (of type @b@). +-- +-- The main use case looks like this: suppose we have some expensive action +-- that depends on certain pure inputs and reads some set of files, and +-- produces some pure result. We want to avoid re-running this action when it +-- would produce the same result. So we need to monitor the files the action +-- looked at, the other pure input values, and we need to cache the result. +-- Then at some later point, if the input value didn't change, and none of the +-- files changed, then we can re-use the cached result rather than re-running +-- the action. +-- +-- This can be achieved using a 'FileMonitor'. Each 'FileMonitor' instance +-- saves state in a disk file, so the file for that has to be specified, +-- making sure it is unique. The pattern is to use 'checkFileMonitorChanged' +-- to see if there's been any change. If there is, re-run the action, keeping +-- track of the files, then use 'updateFileMonitor' to record the current +-- set of files to monitor, the current input value for the action, and the +-- result of the action. +-- +-- The typical occurrence of this pattern is captured by 'rerunIfChanged' +-- and the 'Rebuild' monad. More complicated cases may need to use +-- 'checkFileMonitorChanged' and 'updateFileMonitor' directly. +-- +data FileMonitor a b + = FileMonitor { + + -- | The file where this 'FileMonitor' should store its state. + -- + fileMonitorCacheFile :: FilePath, + + -- | Compares a new cache key with old one to determine if a + -- corresponding cached value is still valid. + -- + -- Typically this is just an equality test, but in some + -- circumstances it can make sense to do things like subset + -- comparisons. + -- + -- The first arg is the new value, the second is the old cached value. + -- + fileMonitorKeyValid :: a -> a -> Bool, + + -- | When this mode is enabled, if 'checkFileMonitorChanged' returns + -- 'MonitoredValueChanged' then we have the guarantee that no files + -- changed, that the value change was the only change. In the default + -- mode no such guarantee is provided which is slightly faster. + -- + fileMonitorCheckIfOnlyValueChanged :: Bool + } + +-- | Define a new file monitor. +-- +-- It's best practice to define file monitor values once, and then use the +-- same value for 'checkFileMonitorChanged' and 'updateFileMonitor' as this +-- ensures you get the same types @a@ and @b@ for reading and writing. +-- +-- The path of the file monitor itself must be unique because it keeps state +-- on disk and these would clash. +-- +newFileMonitor :: Eq a => FilePath -- ^ The file to cache the state of the + -- file monitor. Must be unique. + -> FileMonitor a b +newFileMonitor path = FileMonitor path (==) False + +-- | The result of 'checkFileMonitorChanged': either the monitored files or +-- value changed (and it tells us which it was) or nothing changed and we get +-- the cached result. +-- +data MonitorChanged a b = + -- | The monitored files and value did not change. The cached result is + -- @b@. + -- + -- The set of monitored files is also returned. This is useful + -- for composing or nesting 'FileMonitor's. + MonitorUnchanged b [MonitorFilePath] + + -- | The monitor found that something changed. The reason is given. + -- + | MonitorChanged (MonitorChangedReason a) + deriving Show + +-- | What kind of change 'checkFileMonitorChanged' detected. +-- +data MonitorChangedReason a = + + -- | One of the files changed (existence, file type, mtime or file + -- content, depending on the 'MonitorFilePath' in question) + MonitoredFileChanged FilePath + + -- | The pure input value changed. + -- + -- The previous cached key value is also returned. This is sometimes + -- useful when using a 'fileMonitorKeyValid' function that is not simply + -- '(==)', when invalidation can be partial. In such cases it can make + -- sense to 'updateFileMonitor' with a key value that's a combination of + -- the new and old (e.g. set union). + | MonitoredValueChanged a + + -- | There was no saved monitor state, cached value etc. Ie the file + -- for the 'FileMonitor' does not exist. + | MonitorFirstRun + + -- | There was existing state, but we could not read it. This typically + -- happens when the code has changed compared to an existing 'FileMonitor' + -- cache file and type of the input value or cached value has changed such + -- that we cannot decode the values. This is completely benign as we can + -- treat is just as if there were no cache file and re-run. + | MonitorCorruptCache + deriving (Eq, Show, Functor) + +-- | Test if the input value or files monitored by the 'FileMonitor' have +-- changed. If not, return the cached value. +-- +-- See 'FileMonitor' for a full explanation. +-- +checkFileMonitorChanged + :: forall a b. (Binary a, Structured a, Binary b, Structured b) + => FileMonitor a b -- ^ cache file path + -> FilePath -- ^ root directory + -> a -- ^ guard or key value + -> IO (MonitorChanged a b) -- ^ did the key or any paths change? +checkFileMonitorChanged + monitor@FileMonitor { fileMonitorKeyValid, + fileMonitorCheckIfOnlyValueChanged } + root currentKey = + + -- Consider it a change if the cache file does not exist, + -- or we cannot decode it. Sadly ErrorCall can still happen, despite + -- using decodeFileOrFail, e.g. Data.Char.chr errors + + handleDoesNotExist (MonitorChanged MonitorFirstRun) $ + handleErrorCall (MonitorChanged MonitorCorruptCache) $ + withCacheFile monitor $ + either (\_ -> return (MonitorChanged MonitorCorruptCache)) + checkStatusCache + + where + checkStatusCache :: (MonitorStateFileSet, a, Either String b) -> IO (MonitorChanged a b) + checkStatusCache (cachedFileStatus, cachedKey, cachedResult) = do + change <- checkForChanges + case change of + Just reason -> return (MonitorChanged reason) + Nothing -> case cachedResult of + Left _ -> pure (MonitorChanged MonitorCorruptCache) + Right cr -> return (MonitorUnchanged cr monitorFiles) + where monitorFiles = reconstructMonitorFilePaths cachedFileStatus + where + -- In fileMonitorCheckIfOnlyValueChanged mode we want to guarantee that + -- if we return MonitoredValueChanged that only the value changed. + -- We do that by checking for file changes first. Otherwise it makes + -- more sense to do the cheaper test first. + checkForChanges :: IO (Maybe (MonitorChangedReason a)) + checkForChanges + | fileMonitorCheckIfOnlyValueChanged + = checkFileChange cachedFileStatus cachedKey cachedResult + `mplusMaybeT` + checkValueChange cachedKey + + | otherwise + = checkValueChange cachedKey + `mplusMaybeT` + checkFileChange cachedFileStatus cachedKey cachedResult + + mplusMaybeT :: Monad m => m (Maybe a1) -> m (Maybe a1) -> m (Maybe a1) + mplusMaybeT ma mb = do + mx <- ma + case mx of + Nothing -> mb + Just x -> return (Just x) + + -- Check if the guard value has changed + checkValueChange :: a -> IO (Maybe (MonitorChangedReason a)) + checkValueChange cachedKey + | not (fileMonitorKeyValid currentKey cachedKey) + = return (Just (MonitoredValueChanged cachedKey)) + | otherwise + = return Nothing + + -- Check if any file has changed + checkFileChange :: MonitorStateFileSet -> a -> Either String b -> IO (Maybe (MonitorChangedReason a)) + checkFileChange cachedFileStatus cachedKey cachedResult = do + res <- probeFileSystem root cachedFileStatus + case res of + -- Some monitored file has changed + Left changedPath -> + return (Just (MonitoredFileChanged (normalise changedPath))) + + -- No monitored file has changed + Right (cachedFileStatus', cacheStatus) -> do + + -- But we might still want to update the cache + whenCacheChanged cacheStatus $ + case cachedResult of + Left _ -> pure () + Right cr -> rewriteCacheFile monitor cachedFileStatus' cachedKey cr + + return Nothing + +-- | Lazily decode a triple, parsing the first two fields strictly and +-- returning a lazy value containing either the last one or an error. +-- This is helpful for cabal cache files where the first two components +-- contain header data that lets one test if the cache is still valid, +-- and the last (potentially large) component is the cached value itself. +-- This way we can test for cache validity without needing to pay the +-- cost of the decode of stale cache data. This lives here rather than +-- Distribution.Utils.Structured because it depends on a newer version of +-- binary than supported in the Cabal library proper. +structuredDecodeTriple + :: forall a b c. (Structured a, Structured b, Structured c, Binary.Binary a, Binary.Binary b, Binary.Binary c) + => BS.ByteString -> Either String (a, b, Either String c) +structuredDecodeTriple lbs = + let partialDecode = + (`runGetOrFail` lbs) $ do + (_ :: Tag (a,b,c)) <- Binary.get + (a :: a) <- Binary.get + (b :: b) <- Binary.get + pure (a, b) + cleanEither (Left (_, pos, msg)) = Left ("Data.Binary.Get.runGet at position " ++ show pos ++ ": " ++ msg) + cleanEither (Right (_,_,v)) = Right v + + in case partialDecode of + Left (_, pos, msg) -> Left ("Data.Binary.Get.runGet at position " ++ show pos ++ ": " ++ msg) + Right (lbs', _, (x,y)) -> Right (x, y, cleanEither $ runGetOrFail (Binary.get :: Binary.Get c) lbs') + +-- | Helper for reading the cache file. +-- +-- This determines the type and format of the binary cache file. +-- +withCacheFile :: (Binary a, Structured a, Binary b, Structured b) + => FileMonitor a b + -> (Either String (MonitorStateFileSet, a, Either String b) -> IO r) + -> IO r +withCacheFile (FileMonitor {fileMonitorCacheFile}) k = + withBinaryFile fileMonitorCacheFile ReadMode $ \hnd -> do + contents <- structuredDecodeTriple <$> BS.hGetContents hnd + k contents + +-- | Helper for writing the cache file. +-- +-- This determines the type and format of the binary cache file. +-- +rewriteCacheFile :: (Binary a, Structured a, Binary b, Structured b) + => FileMonitor a b + -> MonitorStateFileSet -> a -> b -> IO () +rewriteCacheFile FileMonitor {fileMonitorCacheFile} fileset key result = + writeFileAtomic fileMonitorCacheFile $ + structuredEncode (fileset, key, result) + +-- | Probe the file system to see if any of the monitored files have changed. +-- +-- It returns Nothing if any file changed, or returns a possibly updated +-- file 'MonitorStateFileSet' plus an indicator of whether it actually changed. +-- +-- We may need to update the cache since there may be changes in the filesystem +-- state which don't change any of our affected files. +-- +-- Consider the glob @{proj1,proj2}\/\*.cabal@. Say we first run and find a +-- @proj1@ directory containing @proj1.cabal@ yet no @proj2@. If we later run +-- and find @proj2@ was created, yet contains no files matching @*.cabal@ then +-- we want to update the cache despite no changes in our relevant file set. +-- Specifically, we should add an mtime for this directory so we can avoid +-- re-traversing the directory in future runs. +-- +probeFileSystem :: FilePath -> MonitorStateFileSet + -> IO (Either FilePath (MonitorStateFileSet, CacheChanged)) +probeFileSystem root (MonitorStateFileSet singlePaths globPaths) = + runChangedM $ do + sequence_ + [ probeMonitorStateFileStatus root file status + | MonitorStateFile _ _ file status <- singlePaths ] + -- The glob monitors can require state changes + globPaths' <- + sequence + [ probeMonitorStateGlob root globPath + | globPath <- globPaths ] + return (MonitorStateFileSet singlePaths globPaths') + + +----------------------------------------------- +-- Monad for checking for file system changes +-- +-- We need to be able to bail out if we detect a change (using ExceptT), +-- but if there's no change we need to be able to rebuild the monitor +-- state. And we want to optimise that rebuilding by keeping track if +-- anything actually changed (using StateT), so that in the typical case +-- we can avoid rewriting the state file. + +newtype ChangedM a = ChangedM (StateT CacheChanged (ExceptT FilePath IO) a) + deriving (Functor, Applicative, Monad, MonadIO) + +runChangedM :: ChangedM a -> IO (Either FilePath (a, CacheChanged)) +runChangedM (ChangedM action) = + runExceptT $ State.runStateT action CacheUnchanged + +somethingChanged :: FilePath -> ChangedM a +somethingChanged path = ChangedM $ throwError path + +cacheChanged :: ChangedM () +cacheChanged = ChangedM $ State.put CacheChanged + +mapChangedFile :: (FilePath -> FilePath) -> ChangedM a -> ChangedM a +mapChangedFile adjust (ChangedM a) = + ChangedM (mapStateT (withExceptT adjust) a) + +data CacheChanged = CacheChanged | CacheUnchanged + +whenCacheChanged :: Monad m => CacheChanged -> m () -> m () +whenCacheChanged CacheChanged action = action +whenCacheChanged CacheUnchanged _ = return () + +---------------------- + +-- | Probe the file system to see if a single monitored file has changed. +-- +probeMonitorStateFileStatus :: FilePath -> FilePath + -> MonitorStateFileStatus + -> ChangedM () +probeMonitorStateFileStatus root file status = + case status of + MonitorStateFileExists -> + probeFileExistence root file + + MonitorStateFileModTime mtime -> + probeFileModificationTime root file mtime + + MonitorStateFileHashed mtime hash -> + probeFileModificationTimeAndHash root file mtime hash + + MonitorStateDirExists -> + probeDirExistence root file + + MonitorStateDirModTime mtime -> + probeFileModificationTime root file mtime + + MonitorStateNonExistent -> + probeFileNonExistence root file + + MonitorStateAlreadyChanged -> + somethingChanged file + + +-- | Probe the file system to see if a monitored file glob has changed. +-- +probeMonitorStateGlob :: FilePath -- ^ root path + -> MonitorStateGlob + -> ChangedM MonitorStateGlob +probeMonitorStateGlob relroot + (MonitorStateGlob kindfile kinddir globroot glob) = do + root <- liftIO $ getFilePathRootDirectory globroot relroot + case globroot of + FilePathRelative -> + MonitorStateGlob kindfile kinddir globroot <$> + probeMonitorStateGlobRel kindfile kinddir root "." glob + + -- for absolute cases, make the changed file we report absolute too + _ -> + mapChangedFile (root ) $ + MonitorStateGlob kindfile kinddir globroot <$> + probeMonitorStateGlobRel kindfile kinddir root "" glob + +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 + change <- liftIO $ checkDirectoryModificationTime (root dirName) mtime + case change of + Nothing -> do + children' <- sequence + [ do fstate' <- probeMonitorStateGlobRel + kindfile kinddir root + (dirName fname) fstate + return (fname, fstate') + | (fname, fstate) <- children ] + return $! MonitorStateGlobDirs glob globPath mtime children' + + Just mtime' -> do + -- directory modification time changed: + -- a matching subdir may have been added or deleted + matches <- filterM (\entry -> let subdir = root dirName entry + in liftIO $ doesDirectoryExist subdir) + . filter (matchGlob glob) + =<< liftIO (getDirectoryContents (root dirName)) + + children' <- traverse probeMergeResult $ + mergeBy (\(path1,_) path2 -> compare path1 path2) + children + (sort matches) + return $! MonitorStateGlobDirs glob globPath mtime' children' + -- Note that just because the directory has changed, we don't force + -- a cache rewrite with 'cacheChanged' since that has some cost, and + -- all we're saving is scanning the directory. But we do rebuild the + -- cache with the new mtime', so that if the cache is rewritten for + -- some other reason, we'll take advantage of that. + + where + probeMergeResult :: MergeResult (FilePath, MonitorStateGlobRel) FilePath + -> ChangedM (FilePath, MonitorStateGlobRel) + + -- Only in cached (directory deleted) + probeMergeResult (OnlyInLeft (path, fstate)) = do + case allMatchingFiles (dirName path) fstate of + [] -> return (path, fstate) + -- Strictly speaking we should be returning 'CacheChanged' above + -- as we should prune the now-missing 'MonitorStateGlobRel'. However + -- we currently just leave these now-redundant entries in the + -- cache as they cost no IO and keeping them allows us to avoid + -- rewriting the cache. + (file:_) -> somethingChanged file + + -- Only in current filesystem state (directory added) + probeMergeResult (OnlyInRight path) = do + fstate <- liftIO $ buildMonitorStateGlobRel Nothing Map.empty + kindfile kinddir root (dirName path) globPath + case allMatchingFiles (dirName path) fstate of + (file:_) -> somethingChanged file + -- This is the only case where we use 'cacheChanged' because we can + -- have a whole new dir subtree (of unbounded size and cost), so we + -- need to save the state of that new subtree in the cache. + [] -> cacheChanged >> return (path, fstate) + + -- Found in path + probeMergeResult (InBoth (path, fstate) _) = do + fstate' <- probeMonitorStateGlobRel kindfile kinddir + root (dirName path) fstate + return (path, fstate') + + -- | Does a 'MonitorStateGlob' have any relevant files within it? + allMatchingFiles :: FilePath -> MonitorStateGlobRel -> [FilePath] + allMatchingFiles dir (MonitorStateGlobFiles _ _ entries) = + [ dir fname | (fname, _) <- entries ] + allMatchingFiles dir (MonitorStateGlobDirs _ _ _ entries) = + [ res + | (subdir, fstate) <- entries + , res <- allMatchingFiles (dir subdir) fstate ] + allMatchingFiles dir MonitorStateGlobDirTrailing = + [dir] + +probeMonitorStateGlobRel _ _ root dirName + (MonitorStateGlobFiles 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 (matchGlob glob) + =<< liftIO (getDirectoryContents (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 (MonitorStateGlobFiles glob mtime' children) + -- Again, we don't force a cache rewrite with 'cacheChanged', but we do use + -- the new mtime' if any. + where + 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) + +probeMonitorStateGlobRel _ _ _ _ MonitorStateGlobDirTrailing = + return MonitorStateGlobDirTrailing + +------------------------------------------------------------------------------ + +-- | Update the input value and the set of files monitored by the +-- 'FileMonitor', plus the cached value that may be returned in future. +-- +-- This takes a snapshot of the state of the monitored files right now, so +-- 'checkFileMonitorChanged' will look for file system changes relative to +-- this snapshot. +-- +-- This is typically done once the action has been completed successfully and +-- we have the action's result and we know what files it looked at. See +-- 'FileMonitor' for a full explanation. +-- +-- If we do take the snapshot after the action has completed then we have a +-- problem. The problem is that files might have changed /while/ the action was +-- running but /after/ the action read them. If we take the snapshot after the +-- action completes then we will miss these changes. The solution is to record +-- a timestamp before beginning execution of the action and then we make the +-- conservative assumption that any file that has changed since then has +-- already changed, ie the file monitor state for these files will be such that +-- 'checkFileMonitorChanged' will report that they have changed. +-- +-- So if you do use 'updateFileMonitor' after the action (so you can discover +-- the files used rather than predicting them in advance) then use +-- 'beginUpdateFileMonitor' to get a timestamp and pass that. Alternatively, +-- if you take the snapshot in advance of the action, or you're not monitoring +-- any files then you can use @Nothing@ for the timestamp parameter. +-- +updateFileMonitor + :: (Binary a, Structured a, Binary b, Structured b) + => FileMonitor a b -- ^ cache file path + -> FilePath -- ^ root directory + -> Maybe MonitorTimestamp -- ^ timestamp when the update action started + -> [MonitorFilePath] -- ^ files of interest relative to root + -> a -- ^ the current key value + -> b -- ^ the current result value + -> IO () +updateFileMonitor monitor root startTime monitorFiles + cachedKey cachedResult = do + hashcache <- readCacheFileHashes monitor + msfs <- buildMonitorStateFileSet startTime hashcache root monitorFiles + rewriteCacheFile monitor msfs cachedKey cachedResult + +-- | A timestamp to help with the problem of file changes during actions. +-- See 'updateFileMonitor' for details. +-- +newtype MonitorTimestamp = MonitorTimestamp ModTime + +-- | Record a timestamp at the beginning of an action, and when the action +-- completes call 'updateFileMonitor' passing it the timestamp. +-- See 'updateFileMonitor' for details. +-- +beginUpdateFileMonitor :: IO MonitorTimestamp +beginUpdateFileMonitor = MonitorTimestamp <$> getCurTime + +-- | Take the snapshot of the monitored files. That is, given the +-- specification of the set of files we need to monitor, inspect the state +-- of the file system now and collect the information we'll need later to +-- determine if anything has changed. +-- +buildMonitorStateFileSet :: Maybe MonitorTimestamp -- ^ optional: timestamp + -- of the start of the action + -> FileHashCache -- ^ existing file hashes + -> FilePath -- ^ root directory + -> [MonitorFilePath] -- ^ patterns of interest + -- relative to root + -> IO MonitorStateFileSet +buildMonitorStateFileSet mstartTime hashcache root = + go [] [] + where + go :: [MonitorStateFile] -> [MonitorStateGlob] + -> [MonitorFilePath] -> IO MonitorStateFileSet + go !singlePaths !globPaths [] = + return (MonitorStateFileSet (reverse singlePaths) (reverse globPaths)) + + go !singlePaths !globPaths + (MonitorFile kindfile kinddir path : monitors) = do + monitorState <- MonitorStateFile kindfile kinddir path + <$> buildMonitorStateFile mstartTime hashcache + kindfile kinddir root path + go (monitorState : singlePaths) globPaths monitors + + go !singlePaths !globPaths + (MonitorFileGlob kindfile kinddir globPath : monitors) = do + monitorState <- buildMonitorStateGlob mstartTime hashcache + kindfile kinddir root globPath + go singlePaths (monitorState : globPaths) monitors + + +buildMonitorStateFile :: Maybe MonitorTimestamp -- ^ start time of update + -> FileHashCache -- ^ existing file hashes + -> MonitorKindFile -> MonitorKindDir + -> FilePath -- ^ the root directory + -> FilePath + -> IO MonitorStateFileStatus +buildMonitorStateFile mstartTime hashcache kindfile kinddir root path = do + let abspath = root path + isFile <- doesFileExist abspath + isDir <- doesDirectoryExist abspath + case (isFile, kindfile, isDir, kinddir) of + (_, FileNotExists, _, DirNotExists) -> + -- we don't need to care if it exists now, since we check at probe time + return MonitorStateNonExistent + + (False, _, False, _) -> + return MonitorStateAlreadyChanged + + (True, FileExists, _, _) -> + return MonitorStateFileExists + + (True, FileModTime, _, _) -> + handleIOException MonitorStateAlreadyChanged $ do + mtime <- getModTime abspath + if changedDuringUpdate mstartTime mtime + then return MonitorStateAlreadyChanged + else return (MonitorStateFileModTime mtime) + + (True, FileHashed, _, _) -> + handleIOException MonitorStateAlreadyChanged $ do + mtime <- getModTime abspath + if changedDuringUpdate mstartTime mtime + then return MonitorStateAlreadyChanged + else do hash <- getFileHash hashcache abspath abspath mtime + return (MonitorStateFileHashed mtime hash) + + (_, _, True, DirExists) -> + return MonitorStateDirExists + + (_, _, True, DirModTime) -> + handleIOException MonitorStateAlreadyChanged $ do + mtime <- getModTime abspath + if changedDuringUpdate mstartTime mtime + then return MonitorStateAlreadyChanged + else return (MonitorStateDirModTime mtime) + + (False, _, True, DirNotExists) -> return MonitorStateAlreadyChanged + (True, FileNotExists, False, _) -> return MonitorStateAlreadyChanged + +-- | If we have a timestamp for the beginning of the update, then any file +-- mtime later than this means that it changed during the update and we ought +-- to consider the file as already changed. +-- +changedDuringUpdate :: Maybe MonitorTimestamp -> ModTime -> Bool +changedDuringUpdate (Just (MonitorTimestamp startTime)) mtime + = mtime > startTime +changedDuringUpdate _ _ = False + +-- | Much like 'buildMonitorStateFileSet' but for the somewhat complicated case +-- of a file glob. +-- +-- This gets used both by 'buildMonitorStateFileSet' when we're taking the +-- file system snapshot, but also by 'probeGlobStatus' as part of checking +-- the monitored (globed) files for changes when we find a whole new subtree. +-- +buildMonitorStateGlob :: Maybe MonitorTimestamp -- ^ start time of update + -> FileHashCache -- ^ existing file hashes + -> MonitorKindFile -> MonitorKindDir + -> FilePath -- ^ the root directory + -> FilePathGlob -- ^ the matching glob + -> IO MonitorStateGlob +buildMonitorStateGlob mstartTime hashcache kindfile kinddir relroot + (FilePathGlob globroot globPath) = do + root <- liftIO $ getFilePathRootDirectory globroot relroot + MonitorStateGlob kindfile kinddir globroot <$> + buildMonitorStateGlobRel + mstartTime hashcache kindfile kinddir root "." globPath + +buildMonitorStateGlobRel :: Maybe MonitorTimestamp -- ^ start time of update + -> FileHashCache -- ^ existing file hashes + -> MonitorKindFile -> MonitorKindDir + -> FilePath -- ^ the root directory + -> FilePath -- ^ directory we are examining + -- relative to the root + -> FilePathGlobRel -- ^ the matching glob + -> IO MonitorStateGlobRel +buildMonitorStateGlobRel mstartTime hashcache kindfile kinddir root + dir globPath = do + let absdir = root dir + dirEntries <- getDirectoryContents absdir + dirMTime <- getModTime absdir + case globPath of + GlobDir glob globPath' -> do + subdirs <- filterM (\subdir -> doesDirectoryExist (absdir subdir)) + $ filter (matchGlob glob) dirEntries + subdirStates <- + for (sort subdirs) $ \subdir -> do + fstate <- buildMonitorStateGlobRel + mstartTime hashcache kindfile kinddir root + (dir subdir) globPath' + return (subdir, fstate) + return $! MonitorStateGlobDirs glob globPath' dirMTime subdirStates + + GlobFile glob -> do + let files = filter (matchGlob glob) dirEntries + filesStates <- + for (sort files) $ \file -> do + fstate <- buildMonitorStateFile + mstartTime hashcache kindfile kinddir root + (dir file) + return (file, fstate) + return $! MonitorStateGlobFiles glob dirMTime filesStates + + GlobDirTrailing -> + return MonitorStateGlobDirTrailing + + +-- | We really want to avoid re-hashing files all the time. We already make +-- the assumption that if a file mtime has not changed then we don't need to +-- bother checking if the content hash has changed. We can apply the same +-- assumption when updating the file monitor state. In the typical case of +-- updating a file monitor the set of files is the same or largely the same so +-- we can grab the previously known content hashes with their corresponding +-- mtimes. +-- +type FileHashCache = Map FilePath (ModTime, Hash) + +-- | We declare it a cache hit if the mtime of a file is the same as before. +-- +lookupFileHashCache :: FileHashCache -> FilePath -> ModTime -> Maybe Hash +lookupFileHashCache hashcache file mtime = do + (mtime', hash) <- Map.lookup file hashcache + guard (mtime' == mtime) + return hash + +-- | Either get it from the cache or go read the file +getFileHash :: FileHashCache -> FilePath -> FilePath -> ModTime -> IO Hash +getFileHash hashcache relfile absfile mtime = + case lookupFileHashCache hashcache relfile mtime of + Just hash -> return hash + Nothing -> readFileHash absfile + +-- | Build a 'FileHashCache' from the previous 'MonitorStateFileSet'. While +-- in principle we could preserve the structure of the previous state, given +-- that the set of files to monitor can change then it's simpler just to throw +-- away the structure and use a finite map. +-- +readCacheFileHashes :: (Binary a, Structured a, Binary b, Structured b) + => FileMonitor a b -> IO FileHashCache +readCacheFileHashes monitor = + handleDoesNotExist Map.empty $ + handleErrorCall Map.empty $ + withCacheFile monitor $ \res -> + case res of + Left _ -> return Map.empty + Right (msfs, _, _) -> return (mkFileHashCache msfs) + where + mkFileHashCache :: MonitorStateFileSet -> FileHashCache + mkFileHashCache (MonitorStateFileSet singlePaths globPaths) = + collectAllFileHashes singlePaths + `Map.union` collectAllGlobHashes globPaths + + collectAllFileHashes :: [MonitorStateFile] -> Map FilePath (ModTime, Hash) + collectAllFileHashes singlePaths = + Map.fromList [ (fpath, (mtime, hash)) + | MonitorStateFile _ _ fpath + (MonitorStateFileHashed mtime hash) <- singlePaths ] + + collectAllGlobHashes :: [MonitorStateGlob] -> Map FilePath (ModTime, Hash) + collectAllGlobHashes globPaths = + Map.fromList [ (fpath, (mtime, hash)) + | MonitorStateGlob _ _ _ gstate <- globPaths + , (fpath, (mtime, hash)) <- collectGlobHashes "" gstate ] + + collectGlobHashes :: FilePath -> MonitorStateGlobRel -> [(FilePath, (ModTime, Hash))] + collectGlobHashes dir (MonitorStateGlobDirs _ _ _ entries) = + [ res + | (subdir, fstate) <- entries + , res <- collectGlobHashes (dir subdir) fstate ] + + collectGlobHashes dir (MonitorStateGlobFiles _ _ entries) = + [ (dir fname, (mtime, hash)) + | (fname, MonitorStateFileHashed mtime hash) <- entries ] + + collectGlobHashes _dir MonitorStateGlobDirTrailing = + [] + + +------------------------------------------------------------------------------ +-- Utils +-- + +-- | Within the @root@ directory, check if @file@ has its 'ModTime' is +-- the same as @mtime@, short-circuiting if it is different. +probeFileModificationTime :: FilePath -> FilePath -> ModTime -> ChangedM () +probeFileModificationTime root file mtime = do + unchanged <- liftIO $ checkModificationTimeUnchanged root file mtime + unless unchanged (somethingChanged file) + +-- | Within the @root@ directory, check if @file@ has its 'ModTime' and +-- 'Hash' is the same as @mtime@ and @hash@, short-circuiting if it is +-- different. +probeFileModificationTimeAndHash :: FilePath -> FilePath -> ModTime -> Hash + -> ChangedM () +probeFileModificationTimeAndHash root file mtime hash = do + unchanged <- liftIO $ + checkFileModificationTimeAndHashUnchanged root file mtime hash + unless unchanged (somethingChanged file) + +-- | Within the @root@ directory, check if @file@ still exists as a file. +-- If it *does not* exist, short-circuit. +probeFileExistence :: FilePath -> FilePath -> ChangedM () +probeFileExistence root file = do + existsFile <- liftIO $ doesFileExist (root file) + unless existsFile (somethingChanged file) + +-- | Within the @root@ directory, check if @dir@ still exists. +-- If it *does not* exist, short-circuit. +probeDirExistence :: FilePath -> FilePath -> ChangedM () +probeDirExistence root dir = do + existsDir <- liftIO $ doesDirectoryExist (root dir) + unless existsDir (somethingChanged dir) + +-- | Within the @root@ directory, check if @file@ still does not exist. +-- If it *does* exist, short-circuit. +probeFileNonExistence :: FilePath -> FilePath -> ChangedM () +probeFileNonExistence root file = do + existsFile <- liftIO $ doesFileExist (root file) + existsDir <- liftIO $ doesDirectoryExist (root file) + when (existsFile || existsDir) (somethingChanged file) + +-- | Returns @True@ if, inside the @root@ directory, @file@ has the same +-- 'ModTime' as @mtime@. +checkModificationTimeUnchanged :: FilePath -> FilePath + -> ModTime -> IO Bool +checkModificationTimeUnchanged root file mtime = + handleIOException False $ do + mtime' <- getModTime (root file) + return (mtime == mtime') + +-- | Returns @True@ if, inside the @root@ directory, @file@ has the +-- same 'ModTime' and 'Hash' as @mtime and @chash@. +checkFileModificationTimeAndHashUnchanged :: FilePath -> FilePath + -> ModTime -> Hash -> IO Bool +checkFileModificationTimeAndHashUnchanged root file mtime chash = + handleIOException False $ do + mtime' <- getModTime (root file) + if mtime == mtime' + then return True + else do + chash' <- readFileHash (root file) + return (chash == chash') + +-- | Read a non-cryptographic hash of a @file@. +readFileHash :: FilePath -> IO Hash +readFileHash file = + withBinaryFile file ReadMode $ \hnd -> + evaluate . Hashable.hash =<< BS.hGetContents hnd + +-- | Given a directory @dir@, return @Nothing@ if its 'ModTime' +-- is the same as @mtime@, and the new 'ModTime' if it is not. +checkDirectoryModificationTime :: FilePath -> ModTime -> IO (Maybe ModTime) +checkDirectoryModificationTime dir mtime = + handleIOException Nothing $ do + mtime' <- getModTime dir + if mtime == mtime' + then return Nothing + else return (Just mtime') + +-- | Run an IO computation, returning the first argument @e@ if there is an 'error' +-- call. ('ErrorCall') +handleErrorCall :: a -> IO a -> IO a +handleErrorCall e = handle handler where +#if MIN_VERSION_base(4,9,0) + handler (ErrorCallWithLocation _ _) = return e +#else + handler (ErrorCall _) = return e +#endif + + +-- | Run an IO computation, returning @e@ if there is any 'IOException'. +-- +-- This policy is OK in the file monitor code because it just causes the +-- monitor to report that something changed, and then code reacting to that +-- will normally encounter the same IO exception when it re-runs the action +-- that uses the file. +-- +handleIOException :: a -> IO a -> IO a +handleIOException e = + handle (anyIOException e) + where + anyIOException :: a -> IOException -> IO a + anyIOException x _ = return x + + +------------------------------------------------------------------------------ +-- Instances +-- diff --git a/cabal/cabal-install/src/Distribution/Client/Freeze.hs b/cabal/cabal-install/src/Distribution/Client/Freeze.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Freeze.hs @@ -0,0 +1,267 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Freeze +-- Copyright : (c) David Himmelstrup 2005 +-- Duncan Coutts 2011 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- The cabal freeze command +----------------------------------------------------------------------------- +module Distribution.Client.Freeze ( + freeze, getFreezePkgs + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Distribution.Client.Config ( SavedConfig(..) ) +import Distribution.Client.Types +import Distribution.Client.Targets +import Distribution.Client.Dependency +import Distribution.Client.IndexUtils as IndexUtils + ( getSourcePackages, getInstalledPackages ) +import Distribution.Client.SolverInstallPlan + ( SolverInstallPlan, SolverPlanPackage ) +import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan +import Distribution.Client.Setup + ( GlobalFlags(..), FreezeFlags(..), ConfigExFlags(..) + , RepoContext(..) ) +import Distribution.Client.Sandbox.PackageEnvironment + ( loadUserConfig, pkgEnvSavedConfig, showPackageEnvironment, + userPackageEnvironmentFile ) + +import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.LabeledPackageConstraint +import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.PkgConfigDb +import Distribution.Solver.Types.SolverId + +import Distribution.Package + ( Package, packageId, packageName, packageVersion ) +import Distribution.Simple.Compiler + ( Compiler, compilerInfo, PackageDBStack ) +import Distribution.Simple.PackageIndex (InstalledPackageIndex) +import Distribution.Simple.Program + ( ProgramDb ) +import Distribution.Simple.Setup + ( fromFlag, fromFlagOrDefault, flagToMaybe ) +import Distribution.Simple.Utils + ( die', notice, debug, writeFileAtomic, toUTF8LBS) +import Distribution.System + ( Platform ) + +import Distribution.Version + ( thisVersion ) + +-- ------------------------------------------------------------ +-- * The freeze command +-- ------------------------------------------------------------ + +-- | Freeze all of the dependencies by writing a constraints section +-- constraining each dependency to an exact version. +-- +freeze :: Verbosity + -> PackageDBStack + -> RepoContext + -> Compiler + -> Platform + -> ProgramDb + -> GlobalFlags + -> FreezeFlags + -> IO () +freeze verbosity packageDBs repoCtxt comp platform progdb + globalFlags freezeFlags = do + + pkgs <- getFreezePkgs + verbosity packageDBs repoCtxt comp platform progdb + globalFlags freezeFlags + + if null pkgs + then notice verbosity $ "No packages to be frozen. " + ++ "As this package has no dependencies." + else if dryRun + then notice verbosity $ unlines $ + "The following packages would be frozen:" + : formatPkgs pkgs + + else freezePackages verbosity globalFlags pkgs + + where + dryRun = fromFlag (freezeDryRun freezeFlags) + +-- | Get the list of packages whose versions would be frozen by the @freeze@ +-- command. +getFreezePkgs :: Verbosity + -> PackageDBStack + -> RepoContext + -> Compiler + -> Platform + -> ProgramDb + -> GlobalFlags + -> FreezeFlags + -> IO [SolverPlanPackage] +getFreezePkgs verbosity packageDBs repoCtxt comp platform progdb + _ freezeFlags = do + + installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb + sourcePkgDb <- getSourcePackages verbosity repoCtxt + pkgConfigDb <- readPkgConfigDb verbosity progdb + + pkgSpecifiers <- resolveUserTargets verbosity repoCtxt + (packageIndex sourcePkgDb) + [UserTargetLocalDir "."] + + sanityCheck pkgSpecifiers + planPackages + verbosity comp platform freezeFlags + installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers + where + sanityCheck :: [PackageSpecifier UnresolvedSourcePackage] -> IO () + sanityCheck pkgSpecifiers = do + when (not . null $ [n | n@(NamedPackage _ _) <- pkgSpecifiers]) $ + die' verbosity $ "internal error: 'resolveUserTargets' returned " + ++ "unexpected named package specifiers!" + when (length pkgSpecifiers /= 1) $ + die' verbosity $ "internal error: 'resolveUserTargets' returned " + ++ "unexpected source package specifiers!" + +planPackages :: Verbosity + -> Compiler + -> Platform + -> FreezeFlags + -> InstalledPackageIndex + -> SourcePackageDb + -> PkgConfigDb + -> [PackageSpecifier UnresolvedSourcePackage] + -> IO [SolverPlanPackage] +planPackages verbosity comp platform freezeFlags + installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers = do + + solver <- chooseSolver verbosity + (fromFlag (freezeSolver freezeFlags)) (compilerInfo comp) + notice verbosity "Resolving dependencies..." + + installPlan <- foldProgress logMsg (die' verbosity) return $ + resolveDependencies + platform (compilerInfo comp) pkgConfigDb + solver + resolverParams + + return $ pruneInstallPlan installPlan pkgSpecifiers + + where + resolverParams :: DepResolverParams + resolverParams = + + setMaxBackjumps (if maxBackjumps < 0 then Nothing + else Just maxBackjumps) + + . setIndependentGoals independentGoals + + . setReorderGoals reorderGoals + + . setCountConflicts countConflicts + + . setFineGrainedConflicts fineGrainedConflicts + + . setMinimizeConflictSet minimizeConflictSet + + . setShadowPkgs shadowPkgs + + . setStrongFlags strongFlags + + . setAllowBootLibInstalls allowBootLibInstalls + + . setOnlyConstrained onlyConstrained + + . setSolverVerbosity verbosity + + . addConstraints + [ let pkg = pkgSpecifierTarget pkgSpecifier + pc = PackageConstraint (scopeToplevel pkg) + (PackagePropertyStanzas stanzas) + in LabeledPackageConstraint pc ConstraintSourceFreeze + | pkgSpecifier <- pkgSpecifiers ] + + $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers + + logMsg message rest = debug verbosity message >> rest + + stanzas = [ TestStanzas | testsEnabled ] + ++ [ BenchStanzas | benchmarksEnabled ] + testsEnabled = fromFlagOrDefault False $ freezeTests freezeFlags + benchmarksEnabled = fromFlagOrDefault False $ freezeBenchmarks freezeFlags + + reorderGoals = fromFlag (freezeReorderGoals freezeFlags) + countConflicts = fromFlag (freezeCountConflicts freezeFlags) + fineGrainedConflicts = fromFlag (freezeFineGrainedConflicts freezeFlags) + minimizeConflictSet = fromFlag (freezeMinimizeConflictSet freezeFlags) + independentGoals = fromFlag (freezeIndependentGoals freezeFlags) + shadowPkgs = fromFlag (freezeShadowPkgs freezeFlags) + strongFlags = fromFlag (freezeStrongFlags freezeFlags) + maxBackjumps = fromFlag (freezeMaxBackjumps freezeFlags) + allowBootLibInstalls = fromFlag (freezeAllowBootLibInstalls freezeFlags) + onlyConstrained = fromFlag (freezeOnlyConstrained freezeFlags) + + +-- | Remove all unneeded packages from an install plan. +-- +-- A package is unneeded if it is either +-- +-- 1) the package that we are freezing, or +-- +-- 2) not a dependency (directly or transitively) of the package we are +-- freezing. This is useful for removing previously installed packages +-- which are no longer required from the install plan. +-- +-- Invariant: @pkgSpecifiers@ must refer to packages which are not +-- 'PreExisting' in the 'SolverInstallPlan'. +pruneInstallPlan :: SolverInstallPlan + -> [PackageSpecifier UnresolvedSourcePackage] + -> [SolverPlanPackage] +pruneInstallPlan installPlan pkgSpecifiers = + removeSelf pkgIds $ + SolverInstallPlan.dependencyClosure installPlan pkgIds + where + pkgIds = [ PlannedId (packageId pkg) + | SpecificSourcePackage pkg <- pkgSpecifiers ] + removeSelf [thisPkg] = filter (\pp -> packageId pp /= packageId thisPkg) + removeSelf _ = error $ "internal error: 'pruneInstallPlan' given " + ++ "unexpected package specifiers!" + + +freezePackages :: Package pkg => Verbosity -> GlobalFlags -> [pkg] -> IO () +freezePackages verbosity globalFlags pkgs = do + + pkgEnv <- fmap (createPkgEnv . addFrozenConstraints) $ + loadUserConfig verbosity "" + (flagToMaybe . globalConstraintsFile $ globalFlags) + writeFileAtomic userPackageEnvironmentFile $ showPkgEnv pkgEnv + where + addFrozenConstraints config = + config { + savedConfigureExFlags = (savedConfigureExFlags config) { + configExConstraints = map constraint pkgs + } + } + constraint pkg = + (pkgIdToConstraint $ packageId pkg + ,ConstraintSourceUserConfig userPackageEnvironmentFile) + where + pkgIdToConstraint pkgId = + UserConstraint (UserQualified UserQualToplevel (packageName pkgId)) + (PackagePropertyVersion $ thisVersion (packageVersion pkgId)) + createPkgEnv config = mempty { pkgEnvSavedConfig = config } + showPkgEnv = toUTF8LBS . showPackageEnvironment + + +formatPkgs :: Package pkg => [pkg] -> [String] +formatPkgs = map $ showPkg . packageId + where + showPkg pid = name pid ++ " == " ++ version pid + name = prettyShow . packageName + version = prettyShow . packageVersion diff --git a/cabal/cabal-install/src/Distribution/Client/GZipUtils.hs b/cabal/cabal-install/src/Distribution/Client/GZipUtils.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/GZipUtils.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.GZipUtils +-- Copyright : (c) Dmitry Astapov 2010 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Provides a convenience functions for working with files that may or may not +-- be zipped. +----------------------------------------------------------------------------- +module Distribution.Client.GZipUtils ( + maybeDecompress, + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Codec.Compression.Zlib.Internal +import Data.ByteString.Lazy.Internal as BS (ByteString(Empty, Chunk)) + +#ifndef MIN_VERSION_zlib +#define MIN_VERSION_zlib(x,y,z) 1 +#endif + +#if MIN_VERSION_zlib(0,6,0) +import Control.Exception (throw) +import Control.Monad.ST.Lazy (ST, runST) +import qualified Data.ByteString as Strict +#endif + +-- | Attempts to decompress the `bytes' under the assumption that +-- "data format" error at the very beginning of the stream means +-- that it is already decompressed. Caller should make sanity checks +-- to verify that it is not, in fact, garbage. +-- +-- This is to deal with http proxies that lie to us and transparently +-- decompress without removing the content-encoding header. See: +-- +-- +maybeDecompress :: ByteString -> ByteString +#if MIN_VERSION_zlib(0,6,0) +maybeDecompress bytes = runST (go bytes decompressor) + where + decompressor :: DecompressStream (ST s) + decompressor = decompressST gzipOrZlibFormat defaultDecompressParams + + -- DataError at the beginning of the stream probably means that stream is + -- not compressed, so we return it as-is. + -- TODO: alternatively, we might consider looking for the two magic bytes + -- 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 _ (DecompressStreamEnd _bs ) = return Empty + go _ (DecompressStreamError _err ) = return bytes + go cs (DecompressInputRequired k) = go cs' =<< k c + where + (c, cs') = uncons cs + + -- Once we have received any output though we regard errors as actual errors + -- 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' _ (DecompressStreamEnd _bs ) = return Empty + go' _ (DecompressStreamError err ) = throw err + go' cs (DecompressInputRequired k) = go' cs' =<< k c + where + (c, cs') = uncons cs + + uncons :: ByteString -> (Strict.ByteString, ByteString) + uncons Empty = (Strict.empty, Empty) + uncons (Chunk c cs) = (c, cs) +#else +maybeDecompress bytes = foldStream $ decompressWithErrors gzipOrZlibFormat defaultDecompressParams bytes + where + -- DataError at the beginning of the stream probably means that stream is not compressed. + -- Returning it as-is. + -- TODO: alternatively, we might consider looking for the two magic bytes + -- at the beginning of the gzip header. + foldStream (StreamError _ _) = bytes + foldStream somethingElse = doFold somethingElse + + doFold StreamEnd = BS.Empty + doFold (StreamChunk bs stream) = BS.Chunk bs (doFold stream) + doFold (StreamError _ msg) = error $ "Codec.Compression.Zlib: " ++ msg +#endif diff --git a/cabal/cabal-install/src/Distribution/Client/GenBounds.hs b/cabal/cabal-install/src/Distribution/Client/GenBounds.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/GenBounds.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.GenBounds +-- Copyright : (c) Doug Beardsley 2015 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- The cabal gen-bounds command for generating PVP-compliant version bounds. +----------------------------------------------------------------------------- +module Distribution.Client.GenBounds ( + genBounds + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Distribution.Client.Utils + ( incVersion ) +import Distribution.Client.Freeze + ( getFreezePkgs ) +import Distribution.Client.Setup + ( GlobalFlags(..), FreezeFlags(..), RepoContext ) +import Distribution.Package + ( Package(..), unPackageName, packageName, packageVersion ) +import Distribution.PackageDescription + ( enabledBuildDepends ) +import Distribution.PackageDescription.Configuration + ( finalizePD ) +import Distribution.Types.ComponentRequestedSpec + ( defaultComponentRequestedSpec ) +import Distribution.Types.Dependency +import Distribution.Simple.Compiler + ( Compiler, PackageDBStack, compilerInfo ) +import Distribution.Simple.PackageDescription + ( readGenericPackageDescription ) +import Distribution.Simple.Program + ( ProgramDb ) +import Distribution.Simple.Utils + ( tryFindPackageDesc ) +import Distribution.System + ( Platform ) +import Distribution.Version + ( Version, alterVersion, VersionInterval (..) + , LowerBound(..), UpperBound(..), VersionRange, asVersionIntervals + , orLaterVersion, earlierVersion, intersectVersionRanges, hasUpperBound) +import System.Directory + ( getCurrentDirectory ) + +-- | Given a version, return an API-compatible (according to PVP) version range. +-- +-- Example: @0.4.1.2@ produces the version range @>= 0.4.1 && < 0.5@. +-- +-- This version is slightly different than the one in +-- 'Distribution.Client.Init'. This one uses a.b.c as the lower bound because +-- the user could be using a new function introduced in a.b.c which would make +-- ">= a.b" incorrect. +pvpize :: Version -> VersionRange +pvpize v = orLaterVersion (vn 3) + `intersectVersionRanges` + earlierVersion (incVersion 1 (vn 2)) + where + vn n = alterVersion (take n) v + +-- | Show the PVP-mandated version range for this package. The @padTo@ parameter +-- specifies the width of the package name column. +showBounds :: Package pkg => Int -> pkg -> String +showBounds padTo p = unwords $ + (padAfter padTo $ unPackageName $ packageName p) : + -- TODO: use normaliseVersionRange + map showInterval (asVersionIntervals $ pvpize $ packageVersion p) + where + padAfter :: Int -> String -> String + padAfter n str = str ++ replicate (n - length str) ' ' + + showInterval :: VersionInterval -> String + showInterval (VersionInterval (LowerBound _ _) NoUpperBound) = + error "Error: expected upper bound...this should never happen!" + showInterval (VersionInterval (LowerBound l _) (UpperBound u _)) = + unwords [">=", prettyShow l, "&& <", prettyShow u] + +-- | Entry point for the @gen-bounds@ command. +genBounds + :: Verbosity + -> PackageDBStack + -> RepoContext + -> Compiler + -> Platform + -> ProgramDb + -> GlobalFlags + -> FreezeFlags + -> IO () +genBounds verbosity packageDBs repoCtxt comp platform progdb globalFlags freezeFlags = do + let cinfo = compilerInfo comp + + cwd <- getCurrentDirectory + path <- tryFindPackageDesc verbosity cwd + gpd <- readGenericPackageDescription verbosity path + -- NB: We don't enable tests or benchmarks, since often they + -- don't really have useful bounds. + let epd = finalizePD mempty defaultComponentRequestedSpec + (const True) platform cinfo [] gpd + case epd of + Left _ -> putStrLn "finalizePD failed" + Right (pd,_) -> do + let needBounds = filter (not . hasUpperBound . depVersion) $ + enabledBuildDepends pd defaultComponentRequestedSpec + + if (null needBounds) + then putStrLn + "Congratulations, all your dependencies have upper bounds!" + else go needBounds + where + go needBounds = do + pkgs <- getFreezePkgs + verbosity packageDBs repoCtxt comp platform progdb + globalFlags freezeFlags + + putStrLn boundsNeededMsg + + let isNeeded pkg = unPackageName (packageName pkg) + `elem` map depName needBounds + let thePkgs = filter isNeeded pkgs + + let padTo = maximum $ map (length . unPackageName . packageName) pkgs + traverse_ (putStrLn . (++",") . showBounds padTo) thePkgs + + depName :: Dependency -> String + depName (Dependency pn _ _) = unPackageName pn + + depVersion :: Dependency -> VersionRange + depVersion (Dependency _ vr _) = vr + +-- | The message printed when some dependencies are found to be lacking proper +-- PVP-mandated bounds. +boundsNeededMsg :: String +boundsNeededMsg = unlines + [ "" + , "The following packages need bounds and here is a suggested starting point." + , "You can copy and paste this into the build-depends section in your .cabal" + , "file and it should work (with the appropriate removal of commas)." + , "" + , "Note that version bounds are a statement that you've successfully built and" + , "tested your package and expect it to work with any of the specified package" + , "versions (PROVIDED that those packages continue to conform with the PVP)." + , "Therefore, the version bounds generated here are the most conservative" + , "based on the versions that you are currently building with. If you know" + , "your package will work with versions outside the ranges generated here," + , "feel free to widen them." + , "" + ] diff --git a/cabal/cabal-install/src/Distribution/Client/Get.hs b/cabal/cabal-install/src/Distribution/Client/Get.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Get.hs @@ -0,0 +1,337 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Get +-- Copyright : (c) Andrea Vezzosi 2008 +-- Duncan Coutts 2011 +-- John Millikin 2012 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- The 'cabal get' command. +----------------------------------------------------------------------------- + +module Distribution.Client.Get ( + get, + + -- * Cloning 'SourceRepo's + -- | Mainly exported for testing purposes + clonePackagesFromSourceRepo, + ClonePackageException(..), + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude hiding (get) +import Distribution.Compat.Directory + ( listDirectory ) +import Distribution.Package + ( PackageId, packageId, packageName ) +import Distribution.Simple.Setup + ( Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe ) +import Distribution.Simple.Utils + ( notice, die', info, writeFileAtomic ) +import qualified Distribution.PackageDescription as PD +import Distribution.Simple.Program + ( programName ) +import Distribution.Types.SourceRepo (RepoKind (..)) +import Distribution.Client.Types.SourceRepo (SourceRepositoryPackage (..), SourceRepoProxy, srpToProxy) + +import Distribution.Client.Setup + ( GlobalFlags(..), GetFlags(..), RepoContext(..) ) +import Distribution.Client.Types +import Distribution.Client.Targets +import Distribution.Client.Dependency +import Distribution.Client.VCS +import Distribution.Client.FetchUtils +import qualified Distribution.Client.Tar as Tar (extractTarGzFile) +import Distribution.Client.IndexUtils + ( getSourcePackagesAtIndexState, TotalIndexState, ActiveRepos ) +import Distribution.Solver.Types.SourcePackage + +import qualified Data.Map as Map +import System.Directory + ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist ) +import System.FilePath + ( (), (<.>), addTrailingPathSeparator ) + + +-- | Entry point for the 'cabal get' command. +get :: Verbosity + -> RepoContext + -> GlobalFlags + -> GetFlags + -> [UserTarget] + -> IO () +get verbosity _ _ _ [] = + notice verbosity "No packages requested. Nothing to do." + +get verbosity repoCtxt _ getFlags userTargets = do + let useSourceRepo = case getSourceRepository getFlags of + NoFlag -> False + _ -> True + + unless useSourceRepo $ + traverse_ (checkTarget verbosity) userTargets + + let idxState :: Maybe TotalIndexState + idxState = flagToMaybe $ getIndexState getFlags + + activeRepos :: Maybe ActiveRepos + activeRepos = flagToMaybe $ getActiveRepos getFlags + + (sourcePkgDb, _, _) <- getSourcePackagesAtIndexState verbosity repoCtxt idxState activeRepos + + pkgSpecifiers <- resolveUserTargets verbosity repoCtxt + (packageIndex sourcePkgDb) + userTargets + + pkgs <- either (die' verbosity . unlines . map show) return $ + resolveWithoutDependencies + (resolverParams sourcePkgDb pkgSpecifiers) + + unless (null prefix) $ + createDirectoryIfMissing True prefix + + if useSourceRepo + then clone pkgs + else unpack pkgs + + where + resolverParams :: SourcePackageDb -> [PackageSpecifier UnresolvedSourcePackage] -> DepResolverParams + resolverParams sourcePkgDb pkgSpecifiers = + --TODO: add command-line constraint and preference args for unpack + standardInstallPolicy mempty sourcePkgDb pkgSpecifiers + + prefix :: String + prefix = fromFlagOrDefault "" (getDestDir getFlags) + + clone :: [UnresolvedSourcePackage] -> IO () + clone = clonePackagesFromSourceRepo verbosity prefix kind + . map (\pkg -> (packageId pkg, packageSourceRepos pkg)) + where + kind :: Maybe RepoKind + kind = fromFlag . getSourceRepository $ getFlags + packageSourceRepos :: SourcePackage loc -> [PD.SourceRepo] + packageSourceRepos = PD.sourceRepos + . PD.packageDescription + . srcpkgDescription + + unpack :: [UnresolvedSourcePackage] -> IO () + unpack pkgs = do + for_ pkgs $ \pkg -> do + location <- fetchPackage verbosity repoCtxt (srcpkgSource pkg) + let pkgid = packageId pkg + descOverride | usePristine = Nothing + | otherwise = srcpkgDescrOverride pkg + case location of + LocalTarballPackage tarballPath -> + unpackPackage verbosity prefix pkgid descOverride tarballPath + + RemoteTarballPackage _tarballURL tarballPath -> + unpackPackage verbosity prefix pkgid descOverride tarballPath + + RepoTarballPackage _repo _pkgid tarballPath -> + unpackPackage verbosity prefix pkgid descOverride tarballPath + + RemoteSourceRepoPackage _repo _ -> + die' verbosity $ "The 'get' command does no yet support targets " + ++ "that are remote source repositories." + + LocalUnpackedPackage _ -> + error "Distribution.Client.Get.unpack: the impossible happened." + where + usePristine :: Bool + usePristine = fromFlagOrDefault False (getPristine getFlags) + +checkTarget :: Verbosity -> UserTarget -> IO () +checkTarget verbosity target = case target of + UserTargetLocalDir dir -> die' verbosity (notTarball dir) + UserTargetLocalCabalFile file -> die' verbosity (notTarball file) + _ -> return () + where + notTarball t = + "The 'get' command is for tarball packages. " + ++ "The target '" ++ t ++ "' is not a tarball." + +-- ------------------------------------------------------------ +-- * Unpacking the source tarball +-- ------------------------------------------------------------ + +unpackPackage :: Verbosity -> FilePath -> PackageId + -> PackageDescriptionOverride + -> FilePath -> IO () +unpackPackage verbosity prefix pkgid descOverride pkgPath = do + let pkgdirname = prettyShow pkgid + pkgdir = prefix pkgdirname + pkgdir' = addTrailingPathSeparator pkgdir + emptyDirectory directory = null <$> listDirectory directory + existsDir <- doesDirectoryExist pkgdir + when existsDir $ do + isEmpty <- emptyDirectory pkgdir + unless isEmpty $ + die' verbosity $ + "The directory \"" ++ pkgdir' ++ "\" already exists and is not empty, not unpacking." + existsFile <- doesFileExist pkgdir + when existsFile $ die' verbosity $ + "A file \"" ++ pkgdir ++ "\" is in the way, not unpacking." + notice verbosity $ "Unpacking to " ++ pkgdir' + Tar.extractTarGzFile prefix pkgdirname pkgPath + + case descOverride of + Nothing -> return () + Just pkgtxt -> do + let descFilePath = pkgdir prettyShow (packageName pkgid) <.> "cabal" + info verbosity $ + "Updating " ++ descFilePath + ++ " with the latest revision from the index." + writeFileAtomic descFilePath pkgtxt + + +-- ------------------------------------------------------------ +-- * Cloning packages from their declared source repositories +-- ------------------------------------------------------------ + + +data ClonePackageException = + ClonePackageNoSourceRepos PackageId + | ClonePackageNoSourceReposOfKind PackageId (Maybe RepoKind) + | ClonePackageNoRepoType PackageId PD.SourceRepo + | ClonePackageUnsupportedRepoType PackageId SourceRepoProxy RepoType + | ClonePackageNoRepoLocation PackageId PD.SourceRepo + | ClonePackageDestinationExists PackageId FilePath Bool + | ClonePackageFailedWithExitCode PackageId SourceRepoProxy String ExitCode + deriving (Show, Eq) + +instance Exception ClonePackageException where + displayException (ClonePackageNoSourceRepos pkgid) = + "Cannot fetch a source repository for package " ++ prettyShow pkgid + ++ ". The package does not specify any source repositories." + + displayException (ClonePackageNoSourceReposOfKind pkgid repoKind) = + "Cannot fetch a source repository for package " ++ prettyShow pkgid + ++ ". The package does not specify a source repository of the requested " + ++ "kind" ++ maybe "." (\k -> " (kind " ++ prettyShow k ++ ").") repoKind + + displayException (ClonePackageNoRepoType pkgid _repo) = + "Cannot fetch the source repository for package " ++ prettyShow pkgid + ++ ". The package's description specifies a source repository but does " + ++ "not specify the repository 'type' field (e.g. git, darcs or hg)." + + displayException (ClonePackageUnsupportedRepoType pkgid _ repoType) = + "Cannot fetch the source repository for package " ++ prettyShow pkgid + ++ ". The repository type '" ++ prettyShow repoType + ++ "' is not yet supported." + + displayException (ClonePackageNoRepoLocation pkgid _repo) = + "Cannot fetch the source repository for package " ++ prettyShow pkgid + ++ ". The package's description specifies a source repository but does " + ++ "not specify the repository 'location' field (i.e. the URL)." + + displayException (ClonePackageDestinationExists pkgid dest isdir) = + "Not fetching the source repository for package " ++ prettyShow pkgid ++ ". " + ++ if isdir then "The destination directory " ++ dest ++ " already exists." + else "A file " ++ dest ++ " is in the way." + + displayException (ClonePackageFailedWithExitCode + pkgid repo vcsprogname exitcode) = + "Failed to fetch the source repository for package " ++ prettyShow pkgid + ++ ", repository location " ++ srpLocation repo ++ " (" + ++ vcsprogname ++ " failed with " ++ show exitcode ++ ")." + + +-- | Given a bunch of package ids and their corresponding available +-- 'SourceRepo's, pick a single 'SourceRepo' for each one and clone into +-- new subdirs of the given directory. +-- +clonePackagesFromSourceRepo :: Verbosity + -> FilePath -- ^ destination dir prefix + -> Maybe RepoKind -- ^ preferred 'RepoKind' + -> [(PackageId, [PD.SourceRepo])] + -- ^ the packages and their + -- available 'SourceRepo's + -> IO () +clonePackagesFromSourceRepo verbosity destDirPrefix + preferredRepoKind pkgrepos = do + + -- Do a bunch of checks and collect the required info + pkgrepos' <- traverse preCloneChecks pkgrepos + + -- Configure the VCS drivers for all the repository types we may need + vcss <- configureVCSs verbosity $ + Map.fromList [ (vcsRepoType vcs, vcs) + | (_, _, vcs, _) <- pkgrepos' ] + + -- Now execute all the required commands for each repo + sequence_ + [ cloneSourceRepo verbosity vcs' repo destDir + `catch` \exitcode -> + throwIO (ClonePackageFailedWithExitCode + pkgid (srpToProxy repo) (programName (vcsProgram vcs)) exitcode) + | (pkgid, repo, vcs, destDir) <- pkgrepos' + , let vcs' = Map.findWithDefault (error $ "Cannot configure " ++ prettyShow (vcsRepoType vcs)) (vcsRepoType vcs) vcss + ] + + where + preCloneChecks :: (PackageId, [PD.SourceRepo]) + -> IO (PackageId, SourceRepositoryPackage Maybe, VCS Program, FilePath) + preCloneChecks (pkgid, repos) = do + repo <- case selectPackageSourceRepo preferredRepoKind repos of + Just repo -> return repo + Nothing | null repos -> throwIO (ClonePackageNoSourceRepos pkgid) + Nothing -> throwIO (ClonePackageNoSourceReposOfKind + pkgid preferredRepoKind) + + (repo', vcs) <- case validatePDSourceRepo repo of + Right (repo', _, _, vcs) -> return (repo', vcs) + Left SourceRepoRepoTypeUnspecified -> + throwIO (ClonePackageNoRepoType pkgid repo) + + Left (SourceRepoRepoTypeUnsupported repo' repoType) -> + throwIO (ClonePackageUnsupportedRepoType pkgid repo' repoType) + + Left SourceRepoLocationUnspecified -> + throwIO (ClonePackageNoRepoLocation pkgid repo) + + let destDir :: FilePath + destDir = destDirPrefix prettyShow (packageName pkgid) + destDirExists <- doesDirectoryExist destDir + destFileExists <- doesFileExist destDir + when (destDirExists || destFileExists) $ + throwIO (ClonePackageDestinationExists pkgid destDir destDirExists) + + return (pkgid, repo', vcs, destDir) + +------------------------------------------------------------------------------- +-- Selecting +------------------------------------------------------------------------------- + +-- | Pick the 'SourceRepo' to use to get the package sources from. +-- +-- Note that this does /not/ depend on what 'VCS' drivers we are able to +-- successfully configure. It is based only on the 'SourceRepo's declared +-- in the package, and optionally on a preferred 'RepoKind'. +-- +selectPackageSourceRepo :: Maybe RepoKind + -> [PD.SourceRepo] + -> Maybe PD.SourceRepo +selectPackageSourceRepo preferredRepoKind = + listToMaybe + -- Sort repositories by kind, from This to Head to Unknown. Repositories + -- with equivalent kinds are selected based on the order they appear in + -- the Cabal description file. + . sortBy (comparing thisFirst) + -- If the user has specified the repo kind, filter out the repositories + -- they're not interested in. + . filter (\repo -> maybe True (PD.repoKind repo ==) preferredRepoKind) + where + thisFirst :: PD.SourceRepo -> Int + thisFirst r = case PD.repoKind r of + RepoThis -> 0 + RepoHead -> case PD.repoTag r of + -- If the type is 'head' but the author specified a tag, they + -- probably meant to create a 'this' repository but screwed up. + Just _ -> 0 + Nothing -> 1 + RepoKindUnknown _ -> 2 diff --git a/cabal/cabal-install/src/Distribution/Client/Glob.hs b/cabal/cabal-install/src/Distribution/Client/Glob.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Glob.hs @@ -0,0 +1,244 @@ +{-# LANGUAGE DeriveGeneric #-} + +--TODO: [code cleanup] plausibly much of this module should be merged with +-- similar functionality in Cabal. +module Distribution.Client.Glob + ( FilePathGlob(..) + , FilePathRoot(..) + , FilePathGlobRel(..) + , Glob + , GlobPiece(..) + , matchFileGlob + , matchFileGlobRel + , matchGlob + , isTrivialFilePathGlob + , getFilePathRootDirectory + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Data.List (stripPrefix) +import System.Directory +import System.FilePath + +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as Disp + + +-- | A file path specified by globbing +-- +data FilePathGlob = FilePathGlob FilePathRoot FilePathGlobRel + deriving (Eq, Show, Generic) + +data FilePathGlobRel + = GlobDir !Glob !FilePathGlobRel + | GlobFile !Glob + | GlobDirTrailing -- ^ trailing dir, a glob ending in @/@ + deriving (Eq, Show, Generic) + +-- | A single directory or file component of a globbed path +type Glob = [GlobPiece] + +-- | A piece of a globbing pattern +data GlobPiece = WildCard + | Literal String + | Union [Glob] + deriving (Eq, Show, Generic) + +data FilePathRoot + = FilePathRelative + | FilePathRoot FilePath -- ^ e.g. @"/"@, @"c:\"@ or result of 'takeDrive' + | FilePathHomeDir + deriving (Eq, Show, Generic) + +instance Binary FilePathGlob +instance Binary FilePathRoot +instance Binary FilePathGlobRel +instance Binary GlobPiece + +instance Structured FilePathGlob +instance Structured FilePathRoot +instance Structured FilePathGlobRel +instance Structured GlobPiece + +-- | Check if a 'FilePathGlob' doesn't actually make use of any globbing and +-- is in fact equivalent to a non-glob 'FilePath'. +-- +-- If it is trivial in this sense then the result is the equivalent constant +-- 'FilePath'. On the other hand if it is not trivial (so could in principle +-- match more than one file) then the result is @Nothing@. +-- +isTrivialFilePathGlob :: FilePathGlob -> Maybe FilePath +isTrivialFilePathGlob (FilePathGlob root pathglob) = + case root of + FilePathRelative -> go [] pathglob + FilePathRoot root' -> go [root'] pathglob + FilePathHomeDir -> Nothing + where + go paths (GlobDir [Literal path] globs) = go (path:paths) globs + go paths (GlobFile [Literal path]) = Just (joinPath (reverse (path:paths))) + go paths GlobDirTrailing = Just (addTrailingPathSeparator + (joinPath (reverse paths))) + go _ _ = Nothing + +-- | Get the 'FilePath' corresponding to a 'FilePathRoot'. +-- +-- The 'FilePath' argument is required to supply the path for the +-- 'FilePathRelative' case. +-- +getFilePathRootDirectory :: FilePathRoot + -> FilePath -- ^ root for relative paths + -> IO FilePath +getFilePathRootDirectory FilePathRelative root = return root +getFilePathRootDirectory (FilePathRoot root) _ = return root +getFilePathRootDirectory FilePathHomeDir _ = getHomeDirectory + + +------------------------------------------------------------------------------ +-- Matching +-- + +-- | Match a 'FilePathGlob' against the file system, starting from a given +-- root directory for relative paths. The results of relative globs are +-- relative to the given root. Matches for absolute globs are absolute. +-- +matchFileGlob :: FilePath -> FilePathGlob -> IO [FilePath] +matchFileGlob relroot (FilePathGlob globroot glob) = do + root <- getFilePathRootDirectory globroot relroot + matches <- matchFileGlobRel root glob + case globroot of + FilePathRelative -> return matches + _ -> return (map (root ) matches) + +-- | Match a 'FilePathGlobRel' against the file system, starting from a +-- given root directory. The results are all relative to the given root. +-- +matchFileGlobRel :: FilePath -> FilePathGlobRel -> IO [FilePath] +matchFileGlobRel root glob0 = go glob0 "" + where + go (GlobFile glob) dir = do + entries <- getDirectoryContents (root dir) + let files = filter (matchGlob glob) entries + return (map (dir ) files) + + go (GlobDir glob globPath) dir = do + entries <- getDirectoryContents (root dir) + subdirs <- filterM (\subdir -> doesDirectoryExist + (root dir subdir)) + $ filter (matchGlob glob) entries + concat <$> traverse (\subdir -> go globPath (dir subdir)) subdirs + + go GlobDirTrailing dir = return [dir] + + +-- | Match a globbing pattern against a file path component +-- +matchGlob :: Glob -> String -> Bool +matchGlob = goStart + where + -- From the man page, glob(7): + -- "If a filename starts with a '.', this character must be + -- matched explicitly." + + go, goStart :: [GlobPiece] -> String -> Bool + + goStart (WildCard:_) ('.':_) = False + goStart (Union globs:rest) cs = any (\glob -> goStart (glob ++ rest) cs) + globs + goStart rest cs = go rest cs + + go [] "" = True + go (Literal lit:rest) cs + | Just cs' <- stripPrefix lit cs + = go rest cs' + | otherwise = False + go [WildCard] "" = True + go (WildCard:rest) (c:cs) = go rest (c:cs) || go (WildCard:rest) cs + go (Union globs:rest) cs = any (\glob -> go (glob ++ rest) cs) globs + go [] (_:_) = False + go (_:_) "" = False + + +------------------------------------------------------------------------------ +-- Parsing & printing +-- + +instance Pretty FilePathGlob where + pretty (FilePathGlob root pathglob) = pretty root Disp.<> pretty pathglob + +instance Parsec FilePathGlob where + parsec = do + root <- parsec + case root of + FilePathRelative -> FilePathGlob root <$> parsec + _ -> FilePathGlob root <$> parsec <|> pure (FilePathGlob root GlobDirTrailing) + +instance Pretty FilePathRoot where + pretty FilePathRelative = Disp.empty + pretty (FilePathRoot root) = Disp.text root + pretty FilePathHomeDir = Disp.char '~' Disp.<> Disp.char '/' + +instance Parsec FilePathRoot where + parsec = root <|> P.try home <|> P.try drive <|> pure FilePathRelative where + root = FilePathRoot "/" <$ P.char '/' + home = FilePathHomeDir <$ P.string "~/" + drive = do + dr <- P.satisfy $ \c -> (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') + _ <- P.char ':' + _ <- P.char '/' <|> P.char '\\' + return (FilePathRoot (toUpper dr : ":\\")) + +instance Pretty FilePathGlobRel where + pretty (GlobDir glob pathglob) = dispGlob glob + Disp.<> Disp.char '/' + Disp.<> pretty pathglob + pretty (GlobFile glob) = dispGlob glob + pretty GlobDirTrailing = Disp.empty + +instance Parsec FilePathGlobRel where + parsec = parsecPath where + parsecPath :: CabalParsing m => m FilePathGlobRel + parsecPath = do + glob <- parsecGlob + dirSep *> (GlobDir glob <$> parsecPath <|> pure (GlobDir glob GlobDirTrailing)) <|> pure (GlobFile glob) + + dirSep :: CabalParsing m => m () + dirSep = () <$ P.char '/' <|> P.try (do + _ <- P.char '\\' + -- check this isn't an escape code + P.notFollowedBy (P.satisfy isGlobEscapedChar)) + +dispGlob :: Glob -> Disp.Doc +dispGlob = Disp.hcat . map dispPiece + where + dispPiece WildCard = Disp.char '*' + dispPiece (Literal str) = Disp.text (escape str) + dispPiece (Union globs) = Disp.braces + (Disp.hcat (Disp.punctuate + (Disp.char ',') + (map dispGlob globs))) + escape [] = [] + escape (c:cs) + | isGlobEscapedChar c = '\\' : c : escape cs + | otherwise = c : escape cs + +parsecGlob :: CabalParsing m => m Glob +parsecGlob = some parsecPiece where + parsecPiece = P.choice [ literal, wildcard, union ] + + wildcard = WildCard <$ P.char '*' + union = Union . toList <$> P.between (P.char '{') (P.char '}') (P.sepByNonEmpty parsecGlob (P.char ',')) + literal = Literal <$> some litchar + + litchar = normal <|> escape + + normal = P.satisfy (\c -> not (isGlobEscapedChar c) && c /= '/' && c /= '\\') + escape = P.try $ P.char '\\' >> P.satisfy isGlobEscapedChar + +isGlobEscapedChar :: Char -> Bool +isGlobEscapedChar '*' = True +isGlobEscapedChar '{' = True +isGlobEscapedChar '}' = True +isGlobEscapedChar ',' = True +isGlobEscapedChar _ = False diff --git a/cabal/cabal-install/src/Distribution/Client/GlobalFlags.hs b/cabal/cabal-install/src/Distribution/Client/GlobalFlags.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/GlobalFlags.hs @@ -0,0 +1,293 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} + +module Distribution.Client.GlobalFlags ( + GlobalFlags(..) + , defaultGlobalFlags + , RepoContext(..) + , withRepoContext + , withRepoContext' + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Distribution.Client.Types + ( Repo(..), unRepoName, RemoteRepo(..), LocalRepo (..), localRepoCacheKey ) +import Distribution.Simple.Setup + ( Flag(..), fromFlag, flagToMaybe ) +import Distribution.Utils.NubList + ( NubList, fromNubList ) +import Distribution.Client.HttpUtils + ( HttpTransport, configureTransport ) +import Distribution.Simple.Utils + ( info, warn ) + +import Distribution.Client.IndexUtils.ActiveRepos + ( ActiveRepos ) + +import Control.Concurrent + ( MVar, newMVar, modifyMVar ) +import System.FilePath + ( () ) +import Network.URI + ( URI, uriScheme, uriPath ) +import qualified Data.Map as Map + +import qualified Hackage.Security.Client as Sec +import qualified Hackage.Security.Util.Path as Sec +import qualified Hackage.Security.Util.Pretty as Sec +import qualified Hackage.Security.Client.Repository.Cache as Sec +import qualified Hackage.Security.Client.Repository.Local as Sec.Local +import qualified Hackage.Security.Client.Repository.Remote as Sec.Remote +import qualified Distribution.Client.Security.HTTP as Sec.HTTP +import qualified Distribution.Client.Security.DNS as Sec.DNS + +import qualified System.FilePath.Posix as FilePath.Posix + +-- ------------------------------------------------------------ +-- * Global flags +-- ------------------------------------------------------------ + +-- | Flags that apply at the top level, not to any sub-command. + +data GlobalFlags = GlobalFlags + { globalVersion :: Flag Bool + , globalNumericVersion :: Flag Bool + , globalConfigFile :: Flag FilePath + , globalConstraintsFile :: Flag FilePath + , globalRemoteRepos :: NubList RemoteRepo -- ^ Available Hackage servers. + , globalCacheDir :: Flag FilePath + , globalLocalNoIndexRepos :: NubList LocalRepo + , globalActiveRepos :: Flag ActiveRepos + , globalLogsDir :: Flag FilePath + , globalIgnoreExpiry :: Flag Bool -- ^ Ignore security expiry dates + , globalHttpTransport :: Flag String + , globalNix :: Flag Bool -- ^ Integrate with Nix + , globalStoreDir :: Flag FilePath + , globalProgPathExtra :: NubList FilePath -- ^ Extra program path used for packagedb lookups in a global context (i.e. for http transports) + } deriving (Show, Generic) + +defaultGlobalFlags :: GlobalFlags +defaultGlobalFlags = GlobalFlags + { globalVersion = Flag False + , globalNumericVersion = Flag False + , globalConfigFile = mempty + , globalConstraintsFile = mempty + , globalRemoteRepos = mempty + , globalCacheDir = mempty + , globalLocalNoIndexRepos = mempty + , globalActiveRepos = mempty + , globalLogsDir = mempty + , globalIgnoreExpiry = Flag False + , globalHttpTransport = mempty + , globalNix = Flag False + , globalStoreDir = mempty + , globalProgPathExtra = mempty + } + +instance Monoid GlobalFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup GlobalFlags where + (<>) = gmappend + +-- ------------------------------------------------------------ +-- * Repo context +-- ------------------------------------------------------------ + +-- | Access to repositories +data RepoContext = RepoContext { + -- | All user-specified repositories + repoContextRepos :: [Repo] + + -- | Get the HTTP transport + -- + -- The transport will be initialized on the first call to this function. + -- + -- NOTE: It is important that we don't eagerly initialize the transport. + -- Initializing the transport is not free, and especially in contexts where + -- we don't know a priori whether or not we need the transport (for instance + -- when using cabal in "nix mode") incurring the overhead of transport + -- initialization on _every_ invocation (eg @cabal build@) is undesirable. + , repoContextGetTransport :: IO HttpTransport + + -- | Get the (initialized) secure repo + -- + -- (the 'Repo' type itself is stateless and must remain so, because it + -- must be serializable) + , repoContextWithSecureRepo :: forall a. + Repo + -> (forall down. Sec.Repository down -> IO a) + -> IO a + + -- | Should we ignore expiry times (when checking security)? + , repoContextIgnoreExpiry :: Bool + } + +-- | Wrapper around 'Repository', hiding the type argument +data SecureRepo = forall down. SecureRepo (Sec.Repository down) + +withRepoContext :: Verbosity -> GlobalFlags -> (RepoContext -> IO a) -> IO a +withRepoContext verbosity globalFlags = + withRepoContext' + verbosity + (fromNubList (globalRemoteRepos globalFlags)) + (fromNubList (globalLocalNoIndexRepos globalFlags)) + (fromFlag (globalCacheDir globalFlags)) + (flagToMaybe (globalHttpTransport globalFlags)) + (flagToMaybe (globalIgnoreExpiry globalFlags)) + (fromNubList (globalProgPathExtra globalFlags)) + +withRepoContext' :: Verbosity -> [RemoteRepo] -> [LocalRepo] + -> FilePath -> Maybe String -> Maybe Bool + -> [FilePath] + -> (RepoContext -> IO a) + -> IO a +withRepoContext' verbosity remoteRepos localNoIndexRepos + sharedCacheDir httpTransport ignoreExpiry extraPaths = \callback -> do + for_ localNoIndexRepos $ \local -> + unless (FilePath.Posix.isAbsolute (localRepoPath local)) $ + warn verbosity $ "file+noindex " ++ unRepoName (localRepoName local) ++ " repository path is not absolute; this is fragile, and not recommended" + + transportRef <- newMVar Nothing + let httpLib = Sec.HTTP.transportAdapter + verbosity + (getTransport transportRef) + initSecureRepos verbosity httpLib secureRemoteRepos $ \secureRepos' -> + callback RepoContext { + repoContextRepos = allRemoteRepos + ++ allLocalNoIndexRepos + , repoContextGetTransport = getTransport transportRef + , repoContextWithSecureRepo = withSecureRepo secureRepos' + , repoContextIgnoreExpiry = fromMaybe False ignoreExpiry + } + where + secureRemoteRepos = + [ (remote, cacheDir) | RepoSecure remote cacheDir <- allRemoteRepos ] + + allRemoteRepos :: [Repo] + allRemoteRepos = + [ (if isSecure then RepoSecure else RepoRemote) remote cacheDir + | remote <- remoteRepos + , let cacheDir = sharedCacheDir unRepoName (remoteRepoName remote) + isSecure = remoteRepoSecure remote == Just True + ] + + allLocalNoIndexRepos :: [Repo] + allLocalNoIndexRepos = + [ RepoLocalNoIndex local cacheDir + | local <- localNoIndexRepos + , let cacheDir | localRepoSharedCache local = sharedCacheDir localRepoCacheKey local + | otherwise = localRepoPath local + ] + + getTransport :: MVar (Maybe HttpTransport) -> IO HttpTransport + getTransport transportRef = + modifyMVar transportRef $ \mTransport -> do + transport <- case mTransport of + Just tr -> return tr + Nothing -> configureTransport verbosity extraPaths httpTransport + return (Just transport, transport) + + withSecureRepo :: Map Repo SecureRepo + -> Repo + -> (forall down. Sec.Repository down -> IO a) + -> IO a + withSecureRepo secureRepos repo callback = + case Map.lookup repo secureRepos of + Just (SecureRepo secureRepo) -> callback secureRepo + Nothing -> throwIO $ userError "repoContextWithSecureRepo: unknown repo" + +-- | Initialize the provided secure repositories +-- +-- Assumed invariant: `remoteRepoSecure` should be set for all these repos. +initSecureRepos :: forall a. Verbosity + -> Sec.HTTP.HttpLib + -> [(RemoteRepo, FilePath)] + -> (Map Repo SecureRepo -> IO a) + -> IO a +initSecureRepos verbosity httpLib repos callback = go Map.empty repos + where + go :: Map Repo SecureRepo -> [(RemoteRepo, FilePath)] -> IO a + go !acc [] = callback acc + go !acc ((r,cacheDir):rs) = do + cachePath <- Sec.makeAbsolute $ Sec.fromFilePath cacheDir + initSecureRepo verbosity httpLib r cachePath $ \r' -> + go (Map.insert (RepoSecure r cacheDir) r' acc) rs + +-- | Initialize the given secure repo +-- +-- The security library has its own concept of a "local" repository, distinct +-- from @cabal-install@'s; these are secure repositories, but live in the local +-- file system. We use the convention that these repositories are identified by +-- URLs of the form @file:/path/to/local/repo@. +initSecureRepo :: Verbosity + -> Sec.HTTP.HttpLib + -> RemoteRepo -- ^ Secure repo ('remoteRepoSecure' assumed) + -> Sec.Path Sec.Absolute -- ^ Cache dir + -> (SecureRepo -> IO a) -- ^ Callback + -> IO a +initSecureRepo verbosity httpLib RemoteRepo{..} cachePath = \callback -> do + requiresBootstrap <- withRepo [] Sec.requiresBootstrap + + mirrors <- if requiresBootstrap + then do + info verbosity $ "Trying to locate mirrors via DNS for " ++ + "initial bootstrap of secure " ++ + "repository '" ++ show remoteRepoURI ++ + "' ..." + + Sec.DNS.queryBootstrapMirrors verbosity remoteRepoURI + else pure [] + + withRepo mirrors $ \r -> do + when requiresBootstrap $ Sec.uncheckClientErrors $ + Sec.bootstrap r + (map Sec.KeyId remoteRepoRootKeys) + (Sec.KeyThreshold (fromIntegral remoteRepoKeyThreshold)) + callback $ SecureRepo r + where + -- Initialize local or remote repo depending on the URI + withRepo :: [URI] -> (forall down. Sec.Repository down -> IO a) -> IO a + withRepo _ callback | uriScheme remoteRepoURI == "file:" = do + dir <- Sec.makeAbsolute $ Sec.fromFilePath (uriPath remoteRepoURI) + Sec.Local.withRepository dir + cache + Sec.hackageRepoLayout + Sec.hackageIndexLayout + logTUF + callback + withRepo mirrors callback = + Sec.Remote.withRepository httpLib + (remoteRepoURI:mirrors) + Sec.Remote.defaultRepoOpts + cache + Sec.hackageRepoLayout + Sec.hackageIndexLayout + logTUF + callback + + cache :: Sec.Cache + cache = Sec.Cache { + cacheRoot = cachePath + , cacheLayout = Sec.cabalCacheLayout { + Sec.cacheLayoutIndexTar = cacheFn "01-index.tar" + , Sec.cacheLayoutIndexIdx = cacheFn "01-index.tar.idx" + , Sec.cacheLayoutIndexTarGz = cacheFn "01-index.tar.gz" + } + } + + cacheFn :: FilePath -> Sec.CachePath + cacheFn = Sec.rootPath . Sec.fragment + + -- We display any TUF progress only in verbose mode, including any transient + -- verification errors. If verification fails, then the final exception that + -- is thrown will of course be shown. + logTUF :: Sec.LogMessage -> IO () + logTUF = info verbosity . Sec.pretty diff --git a/cabal/cabal-install/src/Distribution/Client/Haddock.hs b/cabal/cabal-install/src/Distribution/Client/Haddock.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Haddock.hs @@ -0,0 +1,71 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Haddock +-- Copyright : (c) Andrea Vezzosi 2009 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Interfacing with Haddock +-- +----------------------------------------------------------------------------- +module Distribution.Client.Haddock + ( + regenerateHaddockIndex + ) + where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Data.List (maximumBy) +import System.Directory (createDirectoryIfMissing, renameFile) +import System.FilePath ((), splitFileName) +import Distribution.Package + ( packageVersion ) +import Distribution.Simple.Haddock (haddockPackagePaths) +import Distribution.Simple.Program (haddockProgram, ProgramDb + , runProgram, requireProgramVersion) +import Distribution.Version (mkVersion, orLaterVersion) +import Distribution.Simple.PackageIndex + ( InstalledPackageIndex, allPackagesByName ) +import Distribution.Simple.Utils + ( debug, installDirectoryContents, withTempDirectory ) +import Distribution.InstalledPackageInfo as InstalledPackageInfo + ( InstalledPackageInfo(exposed) ) + +regenerateHaddockIndex :: Verbosity + -> InstalledPackageIndex -> ProgramDb + -> FilePath + -> IO () +regenerateHaddockIndex verbosity pkgs progdb index = do + (paths, warns) <- haddockPackagePaths pkgs' Nothing + let paths' = [ (interface, html) | (interface, Just html, _) <- paths] + for_ warns (debug verbosity) + + (confHaddock, _, _) <- + requireProgramVersion verbosity haddockProgram + (orLaterVersion (mkVersion [0,6])) progdb + + createDirectoryIfMissing True destDir + + withTempDirectory verbosity destDir "tmphaddock" $ \tempDir -> do + + let flags = [ "--gen-contents" + , "--gen-index" + , "--odir=" ++ tempDir + , "--title=Haskell modules on this system" ] + ++ [ "--read-interface=" ++ html ++ "," ++ interface + | (interface, html) <- paths' ] + runProgram verbosity confHaddock flags + renameFile (tempDir "index.html") (tempDir destFile) + installDirectoryContents verbosity tempDir destDir + + where + (destDir,destFile) = splitFileName index + pkgs' :: [InstalledPackageInfo] + pkgs' = [ maximumBy (comparing packageVersion) pkgvers' + | (_pname, pkgvers) <- allPackagesByName pkgs + , let pkgvers' = filter exposed pkgvers + , not (null pkgvers') ] diff --git a/cabal/cabal-install/src/Distribution/Client/HashValue.hs b/cabal/cabal-install/src/Distribution/Client/HashValue.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/HashValue.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Client.HashValue ( + HashValue, + hashValue, + truncateHash, + showHashValue, + readFileHashValue, + hashFromTUF, + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import qualified Hackage.Security.Client as Sec + +import qualified Crypto.Hash.SHA256 as SHA256 +import qualified Data.ByteString.Base16 as Base16 +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy.Char8 as LBS + +import System.IO (IOMode (..), withBinaryFile) + +----------------------------------------------- +-- The specific choice of hash implementation +-- + +-- Is a crypto hash necessary here? One thing to consider is who controls the +-- inputs and what's the result of a hash collision. Obviously we should not +-- install packages we don't trust because they can run all sorts of code, but +-- if I've checked there's no TH, no custom Setup etc, is there still a +-- problem? If someone provided us a tarball that hashed to the same value as +-- some other package and we installed it, we could end up re-using that +-- installed package in place of another one we wanted. So yes, in general +-- there is some value in preventing intentional hash collisions in installed +-- package ids. + +newtype HashValue = HashValue BS.ByteString + deriving (Eq, Generic, Show, Typeable) + +-- Cannot do any sensible validation here. Although we use SHA256 +-- for stuff we hash ourselves, we can also get hashes from TUF +-- and that can in principle use different hash functions in future. +-- +-- Therefore, we simply derive this structurally. +instance Binary HashValue +instance Structured HashValue + +-- | Hash some data. Currently uses SHA256. +-- +hashValue :: LBS.ByteString -> HashValue +hashValue = HashValue . SHA256.hashlazy + +showHashValue :: HashValue -> String +showHashValue (HashValue digest) = BS.unpack (Base16.encode digest) + +-- | Hash the content of a file. Uses SHA256. +-- +readFileHashValue :: FilePath -> IO HashValue +readFileHashValue tarball = + withBinaryFile tarball ReadMode $ \hnd -> + evaluate . hashValue =<< LBS.hGetContents hnd + +-- | Convert a hash from TUF metadata into a 'PackageSourceHash'. +-- +-- Note that TUF hashes don't necessarily have to be SHA256, since it can +-- support new algorithms in future. +-- +hashFromTUF :: Sec.Hash -> HashValue +hashFromTUF (Sec.Hash hashstr) = + --TODO: [code cleanup] either we should get TUF to use raw bytestrings or + -- perhaps we should also just use a base16 string as the internal rep. + case Base16.decode (BS.pack hashstr) of +#if MIN_VERSION_base16_bytestring(1,0,0) + Right hash -> HashValue hash + Left _ -> error "hashFromTUF: cannot decode base16" +#else + (hash, trailing) | not (BS.null hash) && BS.null trailing + -> HashValue hash + _ -> error "hashFromTUF: cannot decode base16 hash" +#endif + +-- | Truncate a 32 byte SHA256 hash to +-- +-- For example 20 bytes render as 40 hex chars, which we use for unit-ids. +-- Or even 4 bytes for 'hashedInstalledPackageIdShort' +-- +truncateHash :: Int -> HashValue -> HashValue +truncateHash n (HashValue h) = HashValue (BS.take n h) diff --git a/cabal/cabal-install/src/Distribution/Client/HttpUtils.hs b/cabal/cabal-install/src/Distribution/Client/HttpUtils.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/HttpUtils.hs @@ -0,0 +1,926 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | Separate module for HTTP actions, using a proxy server if one exists. +----------------------------------------------------------------------------- +module Distribution.Client.HttpUtils ( + DownloadResult(..), + configureTransport, + HttpTransport(..), + HttpCode, + downloadURI, + transportCheckHttps, + remoteRepoCheckHttps, + remoteRepoTryUpgradeToHttps, + isOldHackageURI + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude hiding (Proxy (..)) +import Distribution.Utils.Generic + +import Network.HTTP + ( Request (..), Response (..), RequestMethod (..) + , Header(..), HeaderName(..), lookupHeader ) +import Network.HTTP.Proxy ( Proxy(..), fetchProxy) +import Network.URI + ( URI (..), URIAuth (..), uriToString ) +import Network.Browser + ( browse, setOutHandler, setErrHandler, setProxy + , setAuthorityGen, request, setAllowBasicAuth, setUserAgent ) +import qualified Control.Exception as Exception +import Distribution.Simple.Utils + ( die', info, warn, debug, notice + , copyFileVerbose, withTempFile, IOData (..) ) +import Distribution.Utils.String (trim) +import Distribution.Client.Utils + ( withTempFileName ) +import Distribution.Client.Version + ( cabalInstallVersion ) +import Distribution.Client.Types + ( unRepoName, RemoteRepo(..) ) +import Distribution.System + ( buildOS, buildArch ) +import qualified System.FilePath.Posix as FilePath.Posix + ( splitDirectories ) +import System.FilePath + ( (<.>), takeFileName, takeDirectory ) +import System.Directory + ( doesFileExist, renameFile, canonicalizePath ) +import System.IO + ( withFile, IOMode(ReadMode), hGetContents, hClose ) +import System.IO.Error + ( isDoesNotExistError ) +import Distribution.Simple.Program + ( Program, simpleProgram, ConfiguredProgram, programPath + , ProgramInvocation(..), programInvocation + , ProgramSearchPathEntry(..) + , getProgramInvocationOutput ) +import Distribution.Simple.Program.Db + ( ProgramDb, emptyProgramDb, addKnownPrograms + , configureAllKnownPrograms + , requireProgram, lookupProgram + , modifyProgramSearchPath ) +import Distribution.Simple.Program.Run + ( getProgramInvocationOutputAndErrors ) +import Numeric (showHex) +import System.Random (randomRIO) + +import qualified Crypto.Hash.SHA256 as SHA256 +import qualified Data.ByteString.Base16 as Base16 +import qualified Distribution.Compat.CharParsing as P +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Lazy.Char8 as LBS8 + +------------------------------------------------------------------------------ +-- Downloading a URI, given an HttpTransport +-- + +data DownloadResult = FileAlreadyInCache + | FileDownloaded FilePath + deriving (Eq) + +data DownloadCheck + = Downloaded -- ^ already downloaded and sha256 matches + | CheckETag String -- ^ already downloaded and we have etag + | NeedsDownload (Maybe BS.ByteString) -- ^ needs download with optional hash check + deriving Eq + +downloadURI :: HttpTransport + -> Verbosity + -> URI -- ^ What to download + -> FilePath -- ^ Where to put it + -> IO DownloadResult +downloadURI _transport verbosity uri path | uriScheme uri == "file:" = do + copyFileVerbose verbosity (uriPath uri) path + return (FileDownloaded path) + -- Can we store the hash of the file so we can safely return path when the + -- hash matches to avoid unnecessary computation? + +downloadURI transport verbosity uri path = do + + targetExists <- doesFileExist path + + downloadCheck <- + -- if we have uriFrag, then we expect there to be #sha256=... + if not (null uriFrag) + then case sha256parsed of + -- we know the hash, and target exists + Right expected | targetExists -> do + contents <- LBS.readFile path + let actual = SHA256.hashlazy contents + if expected == actual + then return Downloaded + else return (NeedsDownload (Just expected)) + + -- we known the hash, target doesn't exist + Right expected -> return (NeedsDownload (Just expected)) + + -- we failed to parse uriFragment + Left err -> die' verbosity $ + "Cannot parse URI fragment " ++ uriFrag ++ " " ++ err + + -- if there are no uri fragment, use ETag + else do + etagPathExists <- doesFileExist etagPath + -- In rare cases the target file doesn't exist, but the etag does. + if targetExists && etagPathExists + then return (CheckETag etagPath) + else return (NeedsDownload Nothing) + + -- Only use the external http transports if we actually have to + -- (or have been told to do so) + let transport' + | uriScheme uri == "http:" + , not (transportManuallySelected transport) + = plainHttpTransport + + | otherwise + = transport + + case downloadCheck of + Downloaded -> return FileAlreadyInCache + CheckETag etag -> makeDownload transport' Nothing (Just etag) + NeedsDownload hash -> makeDownload transport' hash Nothing + + where + makeDownload :: HttpTransport -> Maybe BS8.ByteString -> Maybe String -> IO DownloadResult + makeDownload transport' sha256 etag = withTempFileName (takeDirectory path) (takeFileName path) $ \tmpFile -> do + result <- getHttp transport' verbosity uri etag tmpFile [] + + -- Only write the etag if we get a 200 response code. + -- A 304 still sends us an etag header. + case result of + -- if we have hash, we don't care about etag. + (200, _) | Just expected <- sha256 -> do + contents <- LBS.readFile tmpFile + let actual = SHA256.hashlazy contents + unless (actual == expected) $ + die' verbosity $ unwords + [ "Failed to download", show uri + , ": SHA256 don't match; expected:", BS8.unpack (Base16.encode expected) + , "actual:", BS8.unpack (Base16.encode actual) + ] + + (200, Just newEtag) -> writeFile etagPath newEtag + _ -> return () + + case fst result of + 200 -> do + info verbosity ("Downloaded to " ++ path) + renameFile tmpFile path + return (FileDownloaded path) + 304 -> do + notice verbosity "Skipping download: local and remote files match." + return FileAlreadyInCache + errCode -> die' verbosity $ "failed to download " ++ show uri + ++ " : HTTP code " ++ show errCode + + etagPath = path <.> "etag" + uriFrag = uriFragment uri + + sha256parsed :: Either String BS.ByteString + sha256parsed = explicitEitherParsec fragmentParser uriFrag + + fragmentParser = do + _ <- P.string "#sha256=" + str <- some P.hexDigit + let bs = Base16.decode (BS8.pack str) +#if MIN_VERSION_base16_bytestring(1,0,0) + either fail return bs +#else + return (fst bs) +#endif + +------------------------------------------------------------------------------ +-- Utilities for repo url management +-- + +remoteRepoCheckHttps :: Verbosity -> HttpTransport -> RemoteRepo -> IO () +remoteRepoCheckHttps verbosity transport repo + | uriScheme (remoteRepoURI repo) == "https:" + , not (transportSupportsHttps transport) + = die' verbosity $ "The remote repository '" ++ unRepoName (remoteRepoName repo) + ++ "' specifies a URL that " ++ requiresHttpsErrorMessage + | otherwise = return () + +transportCheckHttps :: Verbosity -> HttpTransport -> URI -> IO () +transportCheckHttps verbosity transport uri + | uriScheme uri == "https:" + , not (transportSupportsHttps transport) + = die' verbosity $ "The URL " ++ show uri + ++ " " ++ requiresHttpsErrorMessage + | otherwise = return () + +requiresHttpsErrorMessage :: String +requiresHttpsErrorMessage = + "requires HTTPS however the built-in HTTP implementation " + ++ "does not support HTTPS. The transport implementations with HTTPS " + ++ "support are " ++ intercalate ", " + [ name | (name, _, True, _ ) <- supportedTransports ] + ++ ". One of these will be selected automatically if the corresponding " + ++ "external program is available, or one can be selected specifically " + ++ "with the global flag --http-transport=" + +remoteRepoTryUpgradeToHttps :: Verbosity -> HttpTransport -> RemoteRepo -> IO RemoteRepo +remoteRepoTryUpgradeToHttps verbosity transport repo + | remoteRepoShouldTryHttps repo + , uriScheme (remoteRepoURI repo) == "http:" + , not (transportSupportsHttps transport) + , not (transportManuallySelected transport) + = die' verbosity $ "The builtin HTTP implementation does not support HTTPS, but using " + ++ "HTTPS for authenticated uploads is recommended. " + ++ "The transport implementations with HTTPS support are " + ++ intercalate ", " [ name | (name, _, True, _ ) <- supportedTransports ] + ++ "but they require the corresponding external program to be " + ++ "available. You can either make one available or use plain HTTP by " + ++ "using the global flag --http-transport=plain-http (or putting the " + ++ "equivalent in the config file). With plain HTTP, your password " + ++ "is sent using HTTP digest authentication so it cannot be easily " + ++ "intercepted, but it is not as secure as using HTTPS." + + | remoteRepoShouldTryHttps repo + , uriScheme (remoteRepoURI repo) == "http:" + , transportSupportsHttps transport + = return repo { + remoteRepoURI = (remoteRepoURI repo) { uriScheme = "https:" } + } + + | otherwise + = return repo + +-- | Utility function for legacy support. +isOldHackageURI :: URI -> Bool +isOldHackageURI uri + = case uriAuthority uri of + Just (URIAuth {uriRegName = "hackage.haskell.org"}) -> + FilePath.Posix.splitDirectories (uriPath uri) + == ["/","packages","archive"] + _ -> False + + +------------------------------------------------------------------------------ +-- Setting up a HttpTransport +-- + +data HttpTransport = HttpTransport { + -- | GET a URI, with an optional ETag (to do a conditional fetch), + -- write the resource to the given file and return the HTTP status code, + -- and optional ETag. + getHttp :: Verbosity -> URI -> Maybe ETag -> FilePath -> [Header] + -> IO (HttpCode, Maybe ETag), + + -- | POST a resource to a URI, with optional auth (username, password) + -- and return the HTTP status code and any redirect URL. + postHttp :: Verbosity -> URI -> String -> Maybe Auth + -> IO (HttpCode, String), + + -- | POST a file resource to a URI using multipart\/form-data encoding, + -- with optional auth (username, password) and return the HTTP status + -- code and any error string. + postHttpFile :: Verbosity -> URI -> FilePath -> Maybe Auth + -> IO (HttpCode, String), + + -- | PUT a file resource to a URI, with optional auth + -- (username, password), extra headers and return the HTTP status code + -- and any error string. + putHttpFile :: Verbosity -> URI -> FilePath -> Maybe Auth -> [Header] + -> IO (HttpCode, String), + + -- | Whether this transport supports https or just http. + transportSupportsHttps :: Bool, + + -- | Whether this transport implementation was specifically chosen by + -- the user via configuration, or whether it was automatically selected. + -- Strictly speaking this is not a property of the transport itself but + -- about how it was chosen. Nevertheless it's convenient to keep here. + transportManuallySelected :: Bool + } + --TODO: why does postHttp return a redirect, but postHttpFile return errors? + +type HttpCode = Int +type ETag = String +type Auth = (String, String) + +noPostYet :: Verbosity -> URI -> String -> Maybe (String, String) + -> IO (Int, String) +noPostYet verbosity _ _ _ = die' verbosity "Posting (for report upload) is not implemented yet" + +supportedTransports :: [(String, Maybe Program, Bool, + ProgramDb -> Maybe HttpTransport)] +supportedTransports = + [ let prog = simpleProgram "curl" in + ( "curl", Just prog, True + , \db -> curlTransport <$> lookupProgram prog db ) + + , let prog = simpleProgram "wget" in + ( "wget", Just prog, True + , \db -> wgetTransport <$> lookupProgram prog db ) + + , let prog = simpleProgram "powershell" in + ( "powershell", Just prog, True + , \db -> powershellTransport <$> lookupProgram prog db ) + + , ( "plain-http", Nothing, False + , \_ -> Just plainHttpTransport ) + ] + +configureTransport :: Verbosity -> [FilePath] -> Maybe String -> IO HttpTransport + +configureTransport verbosity extraPath (Just name) = + -- the user specifically selected a transport by name so we'll try and + -- configure that one + + case find (\(name',_,_,_) -> name' == name) supportedTransports of + Just (_, mprog, _tls, mkTrans) -> do + + let baseProgDb = modifyProgramSearchPath (\p -> map ProgramSearchPathDir extraPath ++ p) emptyProgramDb + progdb <- case mprog of + Nothing -> return emptyProgramDb + Just prog -> snd <$> requireProgram verbosity prog baseProgDb + -- ^^ if it fails, it'll fail here + + let transport = fromMaybe (error "configureTransport: failed to make transport") $ mkTrans progdb + return transport { transportManuallySelected = True } + + Nothing -> die' verbosity $ "Unknown HTTP transport specified: " ++ name + ++ ". The supported transports are " + ++ intercalate ", " + [ name' | (name', _, _, _ ) <- supportedTransports ] + +configureTransport verbosity extraPath Nothing = do + -- the user hasn't selected a transport, so we'll pick the first one we + -- can configure successfully, provided that it supports tls + + -- for all the transports except plain-http we need to try and find + -- their external executable + let baseProgDb = modifyProgramSearchPath (\p -> map ProgramSearchPathDir extraPath ++ p) emptyProgramDb + progdb <- configureAllKnownPrograms verbosity $ + addKnownPrograms + [ prog | (_, Just prog, _, _) <- supportedTransports ] + baseProgDb + + let availableTransports = + [ (name, transport) + | (name, _, _, mkTrans) <- supportedTransports + , transport <- maybeToList (mkTrans progdb) ] + let (name, transport) = + fromMaybe ("plain-http", plainHttpTransport) (safeHead availableTransports) + debug verbosity $ "Selected http transport implementation: " ++ name + + return transport { transportManuallySelected = False } + + +------------------------------------------------------------------------------ +-- The HttpTransports based on external programs +-- + +curlTransport :: ConfiguredProgram -> HttpTransport +curlTransport prog = + HttpTransport gethttp posthttp posthttpfile puthttpfile True False + where + gethttp verbosity uri etag destPath reqHeaders = do + withTempFile (takeDirectory destPath) + "curl-headers.txt" $ \tmpFile tmpHandle -> do + hClose tmpHandle + let args = [ show uri + , "--output", destPath + , "--location" + , "--write-out", "%{http_code}" + , "--user-agent", userAgent + , "--silent", "--show-error" + , "--dump-header", tmpFile ] + ++ concat + [ ["--header", "If-None-Match: " ++ t] + | t <- maybeToList etag ] + ++ concat + [ ["--header", show name ++ ": " ++ value] + | Header name value <- reqHeaders ] + + resp <- getProgramInvocationOutput verbosity $ addAuthConfig Nothing uri + (programInvocation prog args) + + withFile tmpFile ReadMode $ \hnd -> do + headers <- hGetContents hnd + (code, _err, etag') <- parseResponse verbosity uri resp headers + evaluate $ force (code, etag') + + posthttp = noPostYet + + addAuthConfig explicitAuth uri progInvocation = do + -- attempt to derive a u/p pair from the uri authority if one exists + -- all `uriUserInfo` values have '@' as a suffix. drop it. + let uriDerivedAuth = case uriAuthority uri of + (Just (URIAuth u _ _)) | not (null u) -> Just $ filter (/= '@') u + _ -> Nothing + -- prefer passed in auth to auth derived from uri. If neither exist, then no auth + let mbAuthString = case (explicitAuth, uriDerivedAuth) of + (Just (uname, passwd), _) -> Just (uname ++ ":" ++ passwd) + (Nothing, Just a) -> Just a + (Nothing, Nothing) -> Nothing + case mbAuthString of + Just up -> progInvocation + { progInvokeInput = Just . IODataText . unlines $ + [ "--digest" + , "--user " ++ up + ] + , progInvokeArgs = ["--config", "-"] ++ progInvokeArgs progInvocation + } + Nothing -> progInvocation + + posthttpfile verbosity uri path auth = do + let args = [ show uri + , "--form", "package=@"++path + , "--write-out", "\n%{http_code}" + , "--user-agent", userAgent + , "--silent", "--show-error" + , "--header", "Accept: text/plain" + , "--location" + ] + resp <- getProgramInvocationOutput verbosity $ addAuthConfig auth uri + (programInvocation prog args) + (code, err, _etag) <- parseResponse verbosity uri resp "" + return (code, err) + + puthttpfile verbosity uri path auth headers = do + let args = [ show uri + , "--request", "PUT", "--data-binary", "@"++path + , "--write-out", "\n%{http_code}" + , "--user-agent", userAgent + , "--silent", "--show-error" + , "--location" + , "--header", "Accept: text/plain" + ] + ++ concat + [ ["--header", show name ++ ": " ++ value] + | Header name value <- headers ] + resp <- getProgramInvocationOutput verbosity $ addAuthConfig auth uri + (programInvocation prog args) + (code, err, _etag) <- parseResponse verbosity uri resp "" + return (code, err) + + -- on success these curl invocations produces an output like "200" + -- and on failure it has the server error response first + parseResponse :: Verbosity -> URI -> String -> String -> IO (Int, String, Maybe ETag) + parseResponse verbosity uri resp headers = + let codeerr = + case reverse (lines resp) of + (codeLine:rerrLines) -> + case readMaybe (trim codeLine) of + Just i -> let errstr = mkErrstr rerrLines + in Just (i, errstr) + Nothing -> Nothing + [] -> Nothing + + mkErrstr = unlines . reverse . dropWhile (all isSpace) + + mb_etag :: Maybe ETag + mb_etag = listToMaybe $ reverse + [ etag + | ["ETag:", etag] <- map words (lines headers) ] + + in case codeerr of + Just (i, err) -> return (i, err, mb_etag) + _ -> statusParseFail verbosity uri resp + + +wgetTransport :: ConfiguredProgram -> HttpTransport +wgetTransport prog = + HttpTransport gethttp posthttp posthttpfile puthttpfile True False + where + gethttp verbosity uri etag destPath reqHeaders = do + resp <- runWGet verbosity uri args + + -- wget doesn't support range requests. + -- so, we not only ignore range request headers, + -- but we also display a warning message when we see them. + let hasRangeHeader = any isRangeHeader reqHeaders + warningMsg = "the 'wget' transport currently doesn't support" + ++ " range requests, which wastes network bandwidth." + ++ " To fix this, set 'http-transport' to 'curl' or" + ++ " 'plain-http' in '~/.cabal/config'." + ++ " Note that the 'plain-http' transport doesn't" + ++ " support HTTPS.\n" + + when (hasRangeHeader) $ warn verbosity warningMsg + (code, etag') <- parseOutput verbosity uri resp + return (code, etag') + where + args = [ "--output-document=" ++ destPath + , "--user-agent=" ++ userAgent + , "--tries=5" + , "--timeout=15" + , "--server-response" ] + ++ concat + [ ["--header", "If-None-Match: " ++ t] + | t <- maybeToList etag ] + ++ [ "--header=" ++ show name ++ ": " ++ value + | hdr@(Header name value) <- reqHeaders + , (not (isRangeHeader hdr)) ] + + -- wget doesn't support range requests. + -- so, we ignore range request headers, lest we get errors. + isRangeHeader :: Header -> Bool + isRangeHeader (Header HdrRange _) = True + isRangeHeader _ = False + + posthttp = noPostYet + + posthttpfile verbosity uri path auth = + withTempFile (takeDirectory path) + (takeFileName path) $ \tmpFile tmpHandle -> + withTempFile (takeDirectory path) "response" $ + \responseFile responseHandle -> do + hClose responseHandle + (body, boundary) <- generateMultipartBody path + LBS.hPut tmpHandle body + hClose tmpHandle + let args = [ "--post-file=" ++ tmpFile + , "--user-agent=" ++ userAgent + , "--server-response" + , "--output-document=" ++ responseFile + , "--header=Accept: text/plain" + , "--header=Content-type: multipart/form-data; " ++ + "boundary=" ++ boundary ] + out <- runWGet verbosity (addUriAuth auth uri) args + (code, _etag) <- parseOutput verbosity uri out + withFile responseFile ReadMode $ \hnd -> do + resp <- hGetContents hnd + evaluate $ force (code, resp) + + puthttpfile verbosity uri path auth headers = + withTempFile (takeDirectory path) "response" $ + \responseFile responseHandle -> do + hClose responseHandle + let args = [ "--method=PUT", "--body-file="++path + , "--user-agent=" ++ userAgent + , "--server-response" + , "--output-document=" ++ responseFile + , "--header=Accept: text/plain" ] + ++ [ "--header=" ++ show name ++ ": " ++ value + | Header name value <- headers ] + + out <- runWGet verbosity (addUriAuth auth uri) args + (code, _etag) <- parseOutput verbosity uri out + withFile responseFile ReadMode $ \hnd -> do + resp <- hGetContents hnd + evaluate $ force (code, resp) + + addUriAuth Nothing uri = uri + addUriAuth (Just (user, pass)) uri = uri + { uriAuthority = Just a { uriUserInfo = user ++ ":" ++ pass ++ "@" } + } + where + a = fromMaybe (URIAuth "" "" "") (uriAuthority uri) + + runWGet verbosity uri args = do + -- We pass the URI via STDIN because it contains the users' credentials + -- and sensitive data should not be passed via command line arguments. + let + invocation = (programInvocation prog ("--input-file=-" : args)) + { progInvokeInput = Just $ IODataText $ uriToString id uri "" + } + + -- wget returns its output on stderr rather than stdout + (_, resp, exitCode) <- getProgramInvocationOutputAndErrors verbosity + invocation + -- wget returns exit code 8 for server "errors" like "304 not modified" + if exitCode == ExitSuccess || exitCode == ExitFailure 8 + then return resp + else die' verbosity $ "'" ++ programPath prog + ++ "' exited with an error:\n" ++ resp + + -- With the --server-response flag, wget produces output with the full + -- http server response with all headers, we want to find a line like + -- "HTTP/1.1 200 OK", but only the last one, since we can have multiple + -- requests due to redirects. + parseOutput verbosity uri resp = + let parsedCode = listToMaybe + [ code + | (protocol:codestr:_err) <- map words (reverse (lines resp)) + , "HTTP/" `isPrefixOf` protocol + , code <- maybeToList (readMaybe codestr) ] + mb_etag :: Maybe ETag + mb_etag = listToMaybe + [ etag + | ["ETag:", etag] <- map words (reverse (lines resp)) ] + in case parsedCode of + Just i -> return (i, mb_etag) + _ -> statusParseFail verbosity uri resp + + +powershellTransport :: ConfiguredProgram -> HttpTransport +powershellTransport prog = + HttpTransport gethttp posthttp posthttpfile puthttpfile True False + where + gethttp verbosity uri etag destPath reqHeaders = do + resp <- runPowershellScript verbosity $ + webclientScript + (escape (show uri)) + (("$targetStream = New-Object -TypeName System.IO.FileStream -ArgumentList " ++ (escape destPath) ++ ", Create") + :(setupHeaders ((useragentHeader : etagHeader) ++ reqHeaders))) + [ "$response = $request.GetResponse()" + , "$responseStream = $response.GetResponseStream()" + , "$buffer = new-object byte[] 10KB" + , "$count = $responseStream.Read($buffer, 0, $buffer.length)" + , "while ($count -gt 0)" + , "{" + , " $targetStream.Write($buffer, 0, $count)" + , " $count = $responseStream.Read($buffer, 0, $buffer.length)" + , "}" + , "Write-Host ($response.StatusCode -as [int]);" + , "Write-Host $response.GetResponseHeader(\"ETag\").Trim('\"')" + ] + [ "$targetStream.Flush()" + , "$targetStream.Close()" + , "$targetStream.Dispose()" + , "$responseStream.Dispose()" + ] + parseResponse resp + where + parseResponse :: String -> IO (HttpCode, Maybe ETag) + parseResponse x = + case lines $ trim x of + (code:etagv:_) -> fmap (\c -> (c, Just etagv)) $ parseCode code x + (code: _) -> fmap (\c -> (c, Nothing )) $ parseCode code x + _ -> statusParseFail verbosity uri x + parseCode :: String -> String -> IO HttpCode + parseCode code x = case readMaybe code of + Just i -> return i + Nothing -> statusParseFail verbosity uri x + etagHeader = [ Header HdrIfNoneMatch t | t <- maybeToList etag ] + + posthttp = noPostYet + + posthttpfile verbosity uri path auth = + withTempFile (takeDirectory path) + (takeFileName path) $ \tmpFile tmpHandle -> do + (body, boundary) <- generateMultipartBody path + LBS.hPut tmpHandle body + hClose tmpHandle + fullPath <- canonicalizePath tmpFile + + let contentHeader = Header HdrContentType + ("multipart/form-data; boundary=" ++ boundary) + resp <- runPowershellScript verbosity $ webclientScript + (escape (show uri)) + (setupHeaders (contentHeader : extraHeaders) ++ setupAuth auth) + (uploadFileAction "POST" uri fullPath) + uploadFileCleanup + parseUploadResponse verbosity uri resp + + puthttpfile verbosity uri path auth headers = do + fullPath <- canonicalizePath path + resp <- runPowershellScript verbosity $ webclientScript + (escape (show uri)) + (setupHeaders (extraHeaders ++ headers) ++ setupAuth auth) + (uploadFileAction "PUT" uri fullPath) + uploadFileCleanup + parseUploadResponse verbosity uri resp + + runPowershellScript verbosity script = do + let args = + [ "-InputFormat", "None" + -- the default execution policy doesn't allow running + -- unsigned scripts, so we need to tell powershell to bypass it + , "-ExecutionPolicy", "bypass" + , "-NoProfile", "-NonInteractive" + , "-Command", "-" + ] + debug verbosity script + getProgramInvocationOutput verbosity (programInvocation prog args) + { progInvokeInput = Just $ IODataText $ script ++ "\nExit(0);" + } + + escape = show + + useragentHeader = Header HdrUserAgent userAgent + extraHeaders = [Header HdrAccept "text/plain", useragentHeader] + + setupHeaders headers = + [ "$request." ++ addHeader name value + | Header name value <- headers + ] + where + addHeader header value + = case header of + HdrAccept -> "Accept = " ++ escape value + HdrUserAgent -> "UserAgent = " ++ escape value + HdrConnection -> "Connection = " ++ escape value + HdrContentLength -> "ContentLength = " ++ escape value + HdrContentType -> "ContentType = " ++ escape value + HdrDate -> "Date = " ++ escape value + HdrExpect -> "Expect = " ++ escape value + HdrHost -> "Host = " ++ escape value + HdrIfModifiedSince -> "IfModifiedSince = " ++ escape value + HdrReferer -> "Referer = " ++ escape value + HdrTransferEncoding -> "TransferEncoding = " ++ escape value + HdrRange -> let (start, end) = + if "bytes=" `isPrefixOf` value + then case break (== '-') value' of + (start', '-':end') -> (start', end') + _ -> error $ "Could not decode range: " ++ value + else error $ "Could not decode range: " ++ value + value' = drop 6 value + in "AddRange(\"bytes\", " ++ escape start ++ ", " ++ escape end ++ ");" + name -> "Headers.Add(" ++ escape (show name) ++ "," ++ escape value ++ ");" + + setupAuth auth = + [ "$request.Credentials = new-object System.Net.NetworkCredential(" + ++ escape uname ++ "," ++ escape passwd ++ ",\"\");" + | (uname,passwd) <- maybeToList auth + ] + + uploadFileAction method _uri fullPath = + [ "$request.Method = " ++ show method + , "$requestStream = $request.GetRequestStream()" + , "$fileStream = [System.IO.File]::OpenRead(" ++ escape fullPath ++ ")" + , "$bufSize=10000" + , "$chunk = New-Object byte[] $bufSize" + , "while( $bytesRead = $fileStream.Read($chunk,0,$bufsize) )" + , "{" + , " $requestStream.write($chunk, 0, $bytesRead)" + , " $requestStream.Flush()" + , "}" + , "" + , "$responseStream = $request.getresponse()" + , "$responseReader = new-object System.IO.StreamReader $responseStream.GetResponseStream()" + , "$code = $response.StatusCode -as [int]" + , "if ($code -eq 0) {" + , " $code = 200;" + , "}" + , "Write-Host $code" + , "Write-Host $responseReader.ReadToEnd()" + ] + + uploadFileCleanup = + [ "$fileStream.Close()" + , "$requestStream.Close()" + , "$responseStream.Close()" + ] + + parseUploadResponse verbosity uri resp = case lines (trim resp) of + (codeStr : message) + | Just code <- readMaybe codeStr -> return (code, unlines message) + _ -> statusParseFail verbosity uri resp + + webclientScript uri setup action cleanup = unlines + [ "[Net.ServicePointManager]::SecurityProtocol = \"tls12, tls11, tls\"" + , "$uri = New-Object \"System.Uri\" " ++ uri + , "$request = [System.Net.HttpWebRequest]::Create($uri)" + , unlines setup + , "Try {" + , unlines (map (" " ++) action) + , "} Catch [System.Net.WebException] {" + , " $exception = $_.Exception;" + , " If ($exception.Status -eq " + ++ "[System.Net.WebExceptionStatus]::ProtocolError) {" + , " $response = $exception.Response -as [System.Net.HttpWebResponse];" + , " $reader = new-object " + ++ "System.IO.StreamReader($response.GetResponseStream());" + , " Write-Host ($response.StatusCode -as [int]);" + , " Write-Host $reader.ReadToEnd();" + , " } Else {" + , " Write-Host $exception.Message;" + , " }" + , "} Catch {" + , " Write-Host $_.Exception.Message;" + , "} finally {" + , unlines (map (" " ++) cleanup) + , "}" + ] + + +------------------------------------------------------------------------------ +-- The builtin plain HttpTransport +-- + +plainHttpTransport :: HttpTransport +plainHttpTransport = + HttpTransport gethttp posthttp posthttpfile puthttpfile False False + where + gethttp verbosity uri etag destPath reqHeaders = do + let req = Request{ + rqURI = uri, + rqMethod = GET, + rqHeaders = [ Header HdrIfNoneMatch t + | t <- maybeToList etag ] + ++ reqHeaders, + rqBody = LBS.empty + } + (_, resp) <- cabalBrowse verbosity Nothing (request req) + let code = convertRspCode (rspCode resp) + etag' = lookupHeader HdrETag (rspHeaders resp) + -- 206 Partial Content is a normal response to a range request; see #3385. + when (code==200 || code==206) $ + writeFileAtomic destPath $ rspBody resp + return (code, etag') + + posthttp = noPostYet + + posthttpfile verbosity uri path auth = do + (body, boundary) <- generateMultipartBody path + let headers = [ Header HdrContentType + ("multipart/form-data; boundary="++boundary) + , Header HdrContentLength (show (LBS8.length body)) + , Header HdrAccept ("text/plain") + ] + req = Request { + rqURI = uri, + rqMethod = POST, + rqHeaders = headers, + rqBody = body + } + (_, resp) <- cabalBrowse verbosity auth (request req) + return (convertRspCode (rspCode resp), rspErrorString resp) + + puthttpfile verbosity uri path auth headers = do + body <- LBS8.readFile path + let req = Request { + rqURI = uri, + rqMethod = PUT, + rqHeaders = Header HdrContentLength (show (LBS8.length body)) + : Header HdrAccept "text/plain" + : headers, + rqBody = body + } + (_, resp) <- cabalBrowse verbosity auth (request req) + return (convertRspCode (rspCode resp), rspErrorString resp) + + convertRspCode (a,b,c) = a*100 + b*10 + c + + rspErrorString resp = + case lookupHeader HdrContentType (rspHeaders resp) of + Just contenttype + | takeWhile (/= ';') contenttype == "text/plain" + -> LBS8.unpack (rspBody resp) + _ -> rspReason resp + + cabalBrowse verbosity auth act = do + p <- fixupEmptyProxy <$> fetchProxy True + Exception.handleJust + (guard . isDoesNotExistError) + (const . die' verbosity $ "Couldn't establish HTTP connection. " + ++ "Possible cause: HTTP proxy server is down.") $ + browse $ do + setProxy p + setErrHandler (warn verbosity . ("http error: "++)) + setOutHandler (debug verbosity) + setUserAgent userAgent + setAllowBasicAuth False + setAuthorityGen (\_ _ -> return auth) + act + + fixupEmptyProxy (Proxy uri _) | null uri = NoProxy + fixupEmptyProxy p = p + + +------------------------------------------------------------------------------ +-- Common stuff used by multiple transport impls +-- + +userAgent :: String +userAgent = concat [ "cabal-install/", prettyShow cabalInstallVersion + , " (", prettyShow buildOS, "; ", prettyShow buildArch, ")" + ] + +statusParseFail :: Verbosity -> URI -> String -> IO a +statusParseFail verbosity uri r = + die' verbosity $ "Failed to download " ++ show uri ++ " : " + ++ "No Status Code could be parsed from response: " ++ r + +------------------------------------------------------------------------------ +-- Multipart stuff partially taken from cgi package. +-- + +generateMultipartBody :: FilePath -> IO (LBS.ByteString, String) +generateMultipartBody path = do + content <- LBS.readFile path + boundary <- genBoundary + let !body = formatBody content (LBS8.pack boundary) + return (body, boundary) + where + formatBody content boundary = + LBS8.concat $ + [ crlf, dd, boundary, crlf ] + ++ [ LBS8.pack (show header) | header <- headers ] + ++ [ crlf + , content + , crlf, dd, boundary, dd, crlf ] + + headers = + [ Header (HdrCustom "Content-disposition") + ("form-data; name=package; " ++ + "filename=\"" ++ takeFileName path ++ "\"") + , Header HdrContentType "application/x-gzip" + ] + + crlf = LBS8.pack "\r\n" + dd = LBS8.pack "--" + +genBoundary :: IO String +genBoundary = do + i <- randomRIO (0x10000000000000,0xFFFFFFFFFFFFFF) :: IO Integer + return $ showHex i "" diff --git a/cabal/cabal-install/src/Distribution/Client/IndexUtils.hs b/cabal/cabal-install/src/Distribution/Client/IndexUtils.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/IndexUtils.hs @@ -0,0 +1,1289 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.IndexUtils +-- Copyright : (c) Duncan Coutts 2008 +-- License : BSD-like +-- +-- Maintainer : duncan@community.haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Extra utils related to the package indexes. +----------------------------------------------------------------------------- +module Distribution.Client.IndexUtils ( + getIndexFileAge, + getInstalledPackages, + indexBaseName, + Configure.getInstalledPackagesMonitorFiles, + getSourcePackages, + getSourcePackagesMonitorFiles, + + TotalIndexState, + getSourcePackagesAtIndexState, + ActiveRepos, + filterSkippedActiveRepos, + + Index(..), + RepoIndexState (..), + PackageEntry(..), + parsePackageIndex, + updateRepoIndexCache, + updatePackageIndexCacheFile, + writeIndexTimestamp, + currentIndexTimestamp, + + BuildTreeRefType(..), refTypeFromTypeCode, typeCodeFromRefType, + -- * preferred-versions utilities + preferredVersions, isPreferredVersions, parsePreferredVersionsWarnings, + PreferredVersionsParseError(..) + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import qualified Codec.Archive.Tar as Tar +import qualified Codec.Archive.Tar.Entry as Tar +import qualified Codec.Archive.Tar.Index as Tar +import qualified Distribution.Client.Tar as Tar +import Distribution.Client.IndexUtils.ActiveRepos +import Distribution.Client.IndexUtils.IndexState +import Distribution.Client.IndexUtils.Timestamp +import Distribution.Client.Types +import Distribution.Verbosity +import Distribution.Parsec (simpleParsecBS) + +import Distribution.Package + ( PackageId, PackageIdentifier(..), mkPackageName + , Package(..), packageVersion, packageName ) +import Distribution.Types.Dependency +import Distribution.Simple.PackageIndex (InstalledPackageIndex) +import Distribution.PackageDescription + ( GenericPackageDescription(..) + , PackageDescription(..), emptyPackageDescription ) +import Distribution.Simple.Compiler + ( Compiler, PackageDBStack ) +import Distribution.Simple.Program + ( ProgramDb ) +import qualified Distribution.Simple.Configure as Configure + ( getInstalledPackages, getInstalledPackagesMonitorFiles ) +import Distribution.Types.PackageName (PackageName) +import Distribution.Version + ( Version, VersionRange, mkVersion, intersectVersionRanges ) +import Distribution.Simple.Utils + ( die', warn, info, createDirectoryIfMissingVerbose, fromUTF8LBS ) +import Distribution.Client.Setup + ( RepoContext(..) ) + +import Distribution.PackageDescription.Parsec + ( parseGenericPackageDescription, parseGenericPackageDescriptionMaybe ) +import qualified Distribution.PackageDescription.Parsec as PackageDesc.Parse +import qualified Distribution.Simple.PackageDescription as PackageDesc.Parse + +import Distribution.Solver.Types.PackageIndex (PackageIndex) +import qualified Distribution.Solver.Types.PackageIndex as PackageIndex +import Distribution.Solver.Types.SourcePackage + +import Data.Either + ( rights ) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Control.Exception +import Data.List (stripPrefix) +import qualified Data.ByteString.Lazy as BS +import qualified Data.ByteString.Char8 as BSS +import Data.ByteString.Lazy (ByteString) +import Distribution.Client.GZipUtils (maybeDecompress) +import Distribution.Client.Utils ( byteStringToFilePath + , tryFindAddSourcePackageDesc ) +import Distribution.Utils.Structured (Structured (..), nominalStructure, structuredEncodeFile, structuredDecodeFileOrFail) +import Distribution.Compat.Time (getFileAge, getModTime) +import System.Directory (doesFileExist, doesDirectoryExist) +import System.FilePath + ( (), (<.>), takeFileName, takeExtension, replaceExtension, splitDirectories, normalise, takeDirectory ) +import qualified System.FilePath.Posix as FilePath.Posix +import System.IO +import System.IO.Unsafe (unsafeInterleaveIO) +import System.IO.Error (isDoesNotExistError) +import Distribution.Compat.Directory (listDirectory) +import Distribution.Utils.Generic (fstOf3) + +import qualified Codec.Compression.GZip as GZip + +import qualified Hackage.Security.Client as Sec +import qualified Hackage.Security.Util.Some as Sec + +-- | Reduced-verbosity version of 'Configure.getInstalledPackages' +getInstalledPackages :: Verbosity -> Compiler + -> PackageDBStack -> ProgramDb + -> IO InstalledPackageIndex +getInstalledPackages verbosity comp packageDbs progdb = + Configure.getInstalledPackages verbosity' comp packageDbs progdb + where + verbosity' = lessVerbose verbosity + + +-- | Get filename base (i.e. without file extension) for index-related files +-- +-- /Secure/ cabal repositories use a new extended & incremental +-- @01-index.tar@. In order to avoid issues resulting from clobbering +-- new/old-style index data, we save them locally to different names. +-- +-- Example: Use @indexBaseName repo <.> "tar.gz"@ to compute the 'FilePath' of the +-- @00-index.tar.gz@/@01-index.tar.gz@ file. +indexBaseName :: Repo -> FilePath +indexBaseName repo = repoLocalDir repo fn + where + fn = case repo of + RepoSecure {} -> "01-index" + RepoRemote {} -> "00-index" + RepoLocalNoIndex {} -> "noindex" + +------------------------------------------------------------------------ +-- Reading the source package index +-- + +-- Note: 'data IndexState' is defined in +-- "Distribution.Client.IndexUtils.Timestamp" to avoid import cycles + +-- | 'IndexStateInfo' contains meta-information about the resulting +-- filtered 'Cache' 'after applying 'filterCache' according to a +-- requested 'IndexState'. +data IndexStateInfo = IndexStateInfo + { isiMaxTime :: !Timestamp + -- ^ 'Timestamp' of maximum/latest 'Timestamp' in the current + -- filtered view of the cache. + -- + -- The following property holds + -- + -- > filterCache (IndexState (isiMaxTime isi)) cache == (cache, isi) + -- + + , isiHeadTime :: !Timestamp + -- ^ 'Timestamp' equivalent to 'IndexStateHead', i.e. the latest + -- known 'Timestamp'; 'isiHeadTime' is always greater or equal to + -- 'isiMaxTime'. + } + +emptyStateInfo :: IndexStateInfo +emptyStateInfo = IndexStateInfo nullTimestamp nullTimestamp + +-- | Filters a 'Cache' according to an 'IndexState' +-- specification. Also returns 'IndexStateInfo' describing the +-- resulting index cache. +-- +-- Note: 'filterCache' is idempotent in the 'Cache' value +filterCache :: RepoIndexState -> Cache -> (Cache, IndexStateInfo) +filterCache IndexStateHead cache = (cache, IndexStateInfo{..}) + where + isiMaxTime = cacheHeadTs cache + isiHeadTime = cacheHeadTs cache +filterCache (IndexStateTime ts0) cache0 = (cache, IndexStateInfo{..}) + where + cache = Cache { cacheEntries = ents, cacheHeadTs = isiMaxTime } + isiHeadTime = cacheHeadTs cache0 + isiMaxTime = maximumTimestamp (map cacheEntryTimestamp ents) + ents = filter ((<= ts0) . cacheEntryTimestamp) (cacheEntries cache0) + +-- | Read a repository index from disk, from the local files specified by +-- a list of 'Repo's. +-- +-- All the 'SourcePackage's are marked as having come from the appropriate +-- 'Repo'. +-- +-- This is a higher level wrapper used internally in cabal-install. +getSourcePackages :: Verbosity -> RepoContext -> IO SourcePackageDb +getSourcePackages verbosity repoCtxt = + fstOf3 <$> getSourcePackagesAtIndexState verbosity repoCtxt Nothing Nothing + +-- | Variant of 'getSourcePackages' which allows getting the source +-- packages at a particular 'IndexState'. +-- +-- Current choices are either the latest (aka HEAD), or the index as +-- it was at a particular time. +-- +-- Returns also the total index where repositories' +-- RepoIndexState's are not HEAD. This is used in v2-freeze. +-- +getSourcePackagesAtIndexState + :: Verbosity + -> RepoContext + -> Maybe TotalIndexState + -> Maybe ActiveRepos + -> IO (SourcePackageDb, TotalIndexState, ActiveRepos) +getSourcePackagesAtIndexState verbosity repoCtxt _ _ + | null (repoContextRepos repoCtxt) = do + -- In the test suite, we routinely don't have any remote package + -- servers, so don't bleat about it + warn (verboseUnmarkOutput verbosity) $ + "No remote package servers have been specified. Usually " ++ + "you would have one specified in the config file." + return (SourcePackageDb { + packageIndex = mempty, + packagePreferences = mempty + }, headTotalIndexState, ActiveRepos []) +getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState mb_activeRepos = do + let describeState IndexStateHead = "most recent state" + describeState (IndexStateTime time) = "historical state as of " ++ prettyShow time + + pkgss <- for (repoContextRepos repoCtxt) $ \r -> do + let rname :: RepoName + rname = repoName r + + info verbosity ("Reading available packages of " ++ unRepoName rname ++ "...") + + idxState <- case mb_idxState of + Just totalIdxState -> do + let idxState = lookupIndexState rname totalIdxState + info verbosity $ "Using " ++ describeState idxState ++ + " as explicitly requested (via command line / project configuration)" + return idxState + Nothing -> do + mb_idxState' <- readIndexTimestamp verbosity (RepoIndex repoCtxt r) + case mb_idxState' of + Nothing -> do + info verbosity "Using most recent state (could not read timestamp file)" + return IndexStateHead + Just idxState -> do + info verbosity $ "Using " ++ describeState idxState ++ + " specified from most recent cabal update" + return idxState + + unless (idxState == IndexStateHead) $ + case r of + RepoLocalNoIndex {} -> warn verbosity "index-state ignored for file+noindex repositories" + RepoRemote {} -> warn verbosity ("index-state ignored for old-format (remote repository '" ++ unRepoName rname ++ "')") + RepoSecure {} -> pure () + + let idxState' = case r of + RepoSecure {} -> idxState + _ -> IndexStateHead + + (pis,deps,isi) <- readRepoIndex verbosity repoCtxt r idxState' + + case idxState' of + IndexStateHead -> do + info verbosity ("index-state("++ unRepoName rname ++") = " ++ prettyShow (isiHeadTime isi)) + return () + IndexStateTime ts0 -> do + when (isiMaxTime isi /= ts0) $ + if ts0 > isiMaxTime isi + then warn verbosity $ + "Requested index-state " ++ prettyShow ts0 + ++ " is newer than '" ++ unRepoName rname ++ "'!" + ++ " Falling back to older state (" + ++ prettyShow (isiMaxTime isi) ++ ")." + else info verbosity $ + "Requested index-state " ++ prettyShow ts0 + ++ " does not exist in '"++ unRepoName rname ++"'!" + ++ " Falling back to older state (" + ++ prettyShow (isiMaxTime isi) ++ ")." + info verbosity ("index-state("++ unRepoName rname ++") = " ++ + prettyShow (isiMaxTime isi) ++ " (HEAD = " ++ + prettyShow (isiHeadTime isi) ++ ")") + + pure RepoData + { rdRepoName = rname + , rdTimeStamp = isiMaxTime isi + , rdIndex = pis + , rdPreferences = deps + } + + let activeRepos :: ActiveRepos + activeRepos = fromMaybe defaultActiveRepos mb_activeRepos + + pkgss' <- case organizeByRepos activeRepos rdRepoName pkgss of + Right x -> return x + Left err -> warn verbosity err >> return (map (\x -> (x, CombineStrategyMerge)) pkgss) + + let activeRepos' :: ActiveRepos + activeRepos' = ActiveRepos + [ ActiveRepo (rdRepoName rd) strategy + | (rd, strategy) <- pkgss' + ] + + let totalIndexState :: TotalIndexState + totalIndexState = makeTotalIndexState IndexStateHead $ Map.fromList + [ (n, IndexStateTime ts) + | (RepoData n ts _idx _prefs, _strategy) <- pkgss' + -- e.g. file+noindex have nullTimestamp as their timestamp + , ts /= nullTimestamp + ] + + 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' + + -- Note: preferences combined without using CombineStrategy + let prefs :: Map PackageName VersionRange + prefs = Map.fromListWith intersectVersionRanges + [ (name, range) + | (RepoData _n _ts _idx prefs', _strategy) <- pkgss' + , Dependency name range _ <- prefs' + ] + + _ <- evaluate pkgs + _ <- evaluate prefs + _ <- evaluate totalIndexState + return (SourcePackageDb { + packageIndex = pkgs, + packagePreferences = prefs + }, totalIndexState, activeRepos') + +-- auxiliary data used in getSourcePackagesAtIndexState +data RepoData = RepoData + { rdRepoName :: RepoName + , rdTimeStamp :: Timestamp + , rdIndex :: PackageIndex UnresolvedSourcePackage + , rdPreferences :: [Dependency] + } + +-- | Read a repository index from disk, from the local file specified by +-- the 'Repo'. +-- +-- All the 'SourcePackage's are marked as having come from the given 'Repo'. +-- +-- This is a higher level wrapper used internally in cabal-install. +-- +readRepoIndex :: Verbosity -> RepoContext -> Repo -> RepoIndexState + -> IO (PackageIndex UnresolvedSourcePackage, [Dependency], IndexStateInfo) +readRepoIndex verbosity repoCtxt repo idxState = + handleNotFound $ do + when (isRepoRemote repo) $ warnIfIndexIsOld =<< getIndexFileAge repo + -- note that if this step fails due to a bad repo cache, the the procedure can still succeed by reading from the existing cache, which is updated regardless. + updateRepoIndexCache verbosity (RepoIndex repoCtxt repo) `catchIO` + (\e -> warn verbosity $ "unable to update the repo index cache -- " ++ displayException e) + readPackageIndexCacheFile verbosity mkAvailablePackage + (RepoIndex repoCtxt repo) + idxState + + where + mkAvailablePackage pkgEntry = SourcePackage + { srcpkgPackageId = pkgid + , srcpkgDescription = pkgdesc + , srcpkgSource = case pkgEntry of + NormalPackage _ _ _ _ -> RepoTarballPackage repo pkgid Nothing + BuildTreeRef _ _ _ path _ -> LocalUnpackedPackage path + , srcpkgDescrOverride = case pkgEntry of + NormalPackage _ _ pkgtxt _ -> Just pkgtxt + _ -> Nothing + } + where + pkgdesc = packageDesc pkgEntry + pkgid = packageId pkgEntry + + handleNotFound action = catchIO action $ \e -> if isDoesNotExistError e + then do + case repo of + RepoRemote{..} -> warn verbosity $ errMissingPackageList repoRemote + RepoSecure{..} -> warn verbosity $ errMissingPackageList repoRemote + RepoLocalNoIndex local _ -> warn verbosity $ + "Error during construction of local+noindex " + ++ unRepoName (localRepoName local) ++ " repository index: " + ++ show e + return (mempty,mempty,emptyStateInfo) + else ioError e + + isOldThreshold = 15 --days + warnIfIndexIsOld dt = do + when (dt >= isOldThreshold) $ case repo of + RepoRemote{..} -> warn verbosity $ errOutdatedPackageList repoRemote dt + RepoSecure{..} -> warn verbosity $ errOutdatedPackageList repoRemote dt + RepoLocalNoIndex {} -> return () + + errMissingPackageList repoRemote = + "The package list for '" ++ (unRepoName (remoteRepoName repoRemote)) + ++ "' does not exist. Run 'hackport update' to download it." + errOutdatedPackageList repoRemote dt = + "The package list for '" ++ unRepoName (remoteRepoName repoRemote) + ++ "' is " ++ shows (floor dt :: Int) " days old.\nRun " + ++ "'cabal update' to get the latest list of available packages." + +-- | Return the age of the index file in days (as a Double). +getIndexFileAge :: Repo -> IO Double +getIndexFileAge repo = getFileAge $ indexBaseName repo <.> "tar" + +-- | A set of files (or directories) that can be monitored to detect when +-- there might have been a change in the source packages. +-- +getSourcePackagesMonitorFiles :: [Repo] -> [FilePath] +getSourcePackagesMonitorFiles repos = + concat [ [ indexBaseName repo <.> "cache" + , indexBaseName repo <.> "timestamp" ] + | repo <- repos ] + +-- | It is not necessary to call this, as the cache will be updated when the +-- index is read normally. However you can do the work earlier if you like. +-- +updateRepoIndexCache :: Verbosity -> Index -> IO () +updateRepoIndexCache verbosity index = + whenCacheOutOfDate index $ updatePackageIndexCacheFile verbosity index + +whenCacheOutOfDate :: Index -> IO () -> IO () +whenCacheOutOfDate index action = do + exists <- doesFileExist $ cacheFile index + if not exists + then action + else if localNoIndex index + then return () -- TODO: don't update cache for local+noindex repositories + else do + indexTime <- getModTime $ indexFile index + cacheTime <- getModTime $ cacheFile index + when (indexTime > cacheTime) action + +localNoIndex :: Index -> Bool +localNoIndex (RepoIndex _ (RepoLocalNoIndex {})) = True +localNoIndex _ = False + +------------------------------------------------------------------------ +-- Reading the index file +-- + +-- | An index entry is either a normal package, or a local build tree reference. +data PackageEntry + = NormalPackage PackageId GenericPackageDescription ByteString BlockNo + | BuildTreeRef BuildTreeRefType + PackageId GenericPackageDescription FilePath BlockNo + +-- | A build tree reference is either a link or a snapshot. +data BuildTreeRefType = SnapshotRef | LinkRef + deriving (Eq,Show,Generic) + +instance Binary BuildTreeRefType +instance Structured BuildTreeRefType + +refTypeFromTypeCode :: Tar.TypeCode -> BuildTreeRefType +refTypeFromTypeCode t + | t == Tar.buildTreeRefTypeCode = LinkRef + | t == Tar.buildTreeSnapshotTypeCode = SnapshotRef + | otherwise = + error "Distribution.Client.IndexUtils.refTypeFromTypeCode: unknown type code" + +typeCodeFromRefType :: BuildTreeRefType -> Tar.TypeCode +typeCodeFromRefType LinkRef = Tar.buildTreeRefTypeCode +typeCodeFromRefType SnapshotRef = Tar.buildTreeSnapshotTypeCode + +instance Package PackageEntry where + packageId (NormalPackage pkgid _ _ _) = pkgid + packageId (BuildTreeRef _ pkgid _ _ _) = pkgid + +packageDesc :: PackageEntry -> GenericPackageDescription +packageDesc (NormalPackage _ descr _ _) = descr +packageDesc (BuildTreeRef _ _ descr _ _) = descr + +-- | Parse an uncompressed \"00-index.tar\" repository index file represented +-- as a 'ByteString'. +-- + +data PackageOrDep = Pkg PackageEntry | Dep Dependency + +-- | Read @00-index.tar.gz@ and extract @.cabal@ and @preferred-versions@ files +-- +-- We read the index using 'Tar.read', which gives us a lazily constructed +-- 'TarEntries'. We translate it to a list of entries using 'tarEntriesList', +-- which preserves the lazy nature of 'TarEntries', and finally 'concatMap' a +-- function over this to translate it to a list of IO actions returning +-- 'PackageOrDep's. We can use 'lazySequence' to turn this into a list of +-- 'PackageOrDep's, still maintaining the lazy nature of the original tar read. +parsePackageIndex :: Verbosity -> ByteString -> [IO (Maybe PackageOrDep)] +parsePackageIndex verbosity = concatMap (uncurry extract) . tarEntriesList . Tar.read + where + extract :: BlockNo -> Tar.Entry -> [IO (Maybe PackageOrDep)] + extract blockNo entry = tryExtractPkg ++ tryExtractPrefs + where + tryExtractPkg = do + mkPkgEntry <- maybeToList $ extractPkg verbosity entry blockNo + return $ fmap (fmap Pkg) mkPkgEntry + + tryExtractPrefs = do + prefs' <- maybeToList $ extractPrefs entry + fmap (return . Just . Dep) prefs' + +-- | Turn the 'Entries' data structure from the @tar@ package into a list, +-- and pair each entry with its block number. +-- +-- NOTE: This preserves the lazy nature of 'Entries': the tar file is only read +-- as far as the list is evaluated. +tarEntriesList :: Show e => Tar.Entries e -> [(BlockNo, Tar.Entry)] +tarEntriesList = go 0 + where + go !_ Tar.Done = [] + go !_ (Tar.Fail e) = error ("tarEntriesList: " ++ show e) + go !n (Tar.Next e es') = (n, e) : go (Tar.nextEntryOffset e n) es' + +extractPkg :: Verbosity -> Tar.Entry -> BlockNo -> Maybe (IO (Maybe PackageEntry)) +extractPkg verbosity entry blockNo = case Tar.entryContent entry of + Tar.NormalFile content _ + | takeExtension fileName == ".cabal" + -> case splitDirectories (normalise fileName) of + [pkgname,vers,_] -> case simpleParsec vers of + Just ver -> Just . return $ Just (NormalPackage pkgid descr content blockNo) + where + pkgid = PackageIdentifier (mkPackageName pkgname) ver + parsed = parseGenericPackageDescriptionMaybe (BS.toStrict content) + descr = case parsed of + Just d -> d + Nothing -> error $ "Couldn't read cabal file " + ++ show fileName + _ -> Nothing + _ -> Nothing + + Tar.OtherEntryType typeCode content _ + | Tar.isBuildTreeRefTypeCode typeCode -> + Just $ do + let path = byteStringToFilePath content + dirExists <- doesDirectoryExist path + result <- if not dirExists then return Nothing + else do + cabalFile <- tryFindAddSourcePackageDesc verbosity path "Error reading package index." + descr <- PackageDesc.Parse.readGenericPackageDescription normal cabalFile + return . Just $ BuildTreeRef (refTypeFromTypeCode typeCode) (packageId descr) + descr path blockNo + return result + + _ -> Nothing + + where + fileName = Tar.entryPath entry + +extractPrefs :: Tar.Entry -> Maybe [Dependency] +extractPrefs entry = case Tar.entryContent entry of +{- + -- get rid of hackage's preferred-versions + -- I'd like to have bleeding-edge packages in system and I don't fear of + -- broken packages with improper depends + Tar.NormalFile content _ + | isPreferredVersions entrypath + -> Just prefs + where + entrypath = Tar.entryPath entry + prefs = parsePreferredVersions content +-} + _ -> Nothing + +------------------------------------------------------------------------ +-- Filename and parsers for 'preferred-versions' file. +-- + +-- | Expected name of the 'preferred-versions' file. +-- +-- Contains special constraints, such as a preferred version of a package +-- or deprecations of certain package versions. +-- +-- Expected format: +-- +-- @ +-- binary > 0.9.0.0 || < 0.9.0.0 +-- text == 1.2.1.0 +-- @ +preferredVersions :: FilePath +preferredVersions = "preferred-versions" + +-- | Does the given filename match with the expected name of 'preferred-versions'? +isPreferredVersions :: FilePath -> Bool +isPreferredVersions = (== preferredVersions) . takeFileName + +-- | Parse `preferred-versions` file, ignoring any parse failures. +-- +-- To obtain parse errors, use 'parsePreferredVersionsWarnings'. +parsePreferredVersions :: ByteString -> [Dependency] +parsePreferredVersions = rights . parsePreferredVersionsWarnings + +-- | Parser error of the `preferred-versions` file. +data PreferredVersionsParseError = PreferredVersionsParseError + { preferredVersionsParsecError :: String + -- ^ Parser error to show to a user. + , preferredVersionsOriginalDependency :: String + -- ^ Original input that produced the parser error. + } + deriving (Generic, Read, Show, Eq, Ord, Typeable) + +-- | Parse `preferred-versions` file, collecting parse errors that can be shown +-- in error messages. +parsePreferredVersionsWarnings :: ByteString + -> [Either PreferredVersionsParseError Dependency] +parsePreferredVersionsWarnings = + map parsePreference + . filter (not . isPrefixOf "--") + . lines + . fromUTF8LBS + where + parsePreference :: String -> Either PreferredVersionsParseError Dependency + parsePreference s = case eitherParsec s of + Left err -> Left $ PreferredVersionsParseError + { preferredVersionsParsecError = err + , preferredVersionsOriginalDependency = s + } + Right dep -> Right dep + +------------------------------------------------------------------------ +-- Reading and updating the index cache +-- + +-- | Variation on 'sequence' which evaluates the actions lazily +-- +-- Pattern matching on the result list will execute just the first action; +-- more generally pattern matching on the first @n@ '(:)' nodes will execute +-- the first @n@ actions. +lazySequence :: [IO a] -> IO [a] +lazySequence = unsafeInterleaveIO . go + where + go [] = return [] + go (x:xs) = do x' <- x + xs' <- lazySequence xs + return (x' : xs') + +-- | A lazy unfolder for lookup operations which return the current +-- value and (possibly) the next key +lazyUnfold :: (k -> IO (v, Maybe k)) -> k -> IO [(k,v)] +lazyUnfold step = goLazy . Just + where + goLazy s = unsafeInterleaveIO (go s) + + go Nothing = return [] + go (Just k) = do + (v, mk') <- step k + vs' <- goLazy mk' + return ((k,v):vs') + +-- | Which index do we mean? +data Index = + -- | The main index for the specified repository + RepoIndex RepoContext Repo + + -- | A sandbox-local repository + -- Argument is the location of the index file + | SandboxIndex FilePath + +indexFile :: Index -> FilePath +indexFile (RepoIndex _ctxt repo) = indexBaseName repo <.> "tar" +indexFile (SandboxIndex index) = index + +cacheFile :: Index -> FilePath +cacheFile (RepoIndex _ctxt repo) = indexBaseName repo <.> "cache" +cacheFile (SandboxIndex index) = index `replaceExtension` "cache" + +timestampFile :: Index -> FilePath +timestampFile (RepoIndex _ctxt repo) = indexBaseName repo <.> "timestamp" +timestampFile (SandboxIndex index) = index `replaceExtension` "timestamp" + +-- | Return 'True' if 'Index' uses 01-index format (aka secure repo) +is01Index :: Index -> Bool +is01Index (RepoIndex _ repo) = case repo of + RepoSecure {} -> True + RepoRemote {} -> False + RepoLocalNoIndex {} -> True +is01Index (SandboxIndex _) = False + + +updatePackageIndexCacheFile :: Verbosity -> Index -> IO () +updatePackageIndexCacheFile verbosity index = do + info verbosity ("Updating index cache file " ++ cacheFile index ++ " ...") + withIndexEntries verbosity index callback callbackNoIndex + where + callback entries = do + let !maxTs = maximumTimestamp (map cacheEntryTimestamp entries) + cache = Cache { cacheHeadTs = maxTs + , cacheEntries = entries + } + writeIndexCache index cache + info verbosity ("Index cache updated to index-state " + ++ prettyShow (cacheHeadTs cache)) + + callbackNoIndex entries = do + writeNoIndexCache verbosity index $ NoIndexCache entries + info verbosity "Index cache updated" + +-- | Read the index (for the purpose of building a cache) +-- +-- The callback is provided with list of cache entries, which is guaranteed to +-- be lazily constructed. This list must ONLY be used in the scope of the +-- callback; when the callback is terminated the file handle to the index will +-- be closed and further attempts to read from the list will result in (pure) +-- I/O exceptions. +-- +-- In the construction of the index for a secure repo we take advantage of the +-- index built by the @hackage-security@ library to avoid reading the @.tar@ +-- file as much as possible (we need to read it only to extract preferred +-- versions). This helps performance, but is also required for correctness: +-- the new @01-index.tar.gz@ may have multiple versions of preferred-versions +-- files, and 'parsePackageIndex' does not correctly deal with that (see #2956); +-- by reading the already-built cache from the security library we will be sure +-- to only read the latest versions of all files. +-- +-- TODO: It would be nicer if we actually incrementally updated @cabal@'s +-- cache, rather than reconstruct it from zero on each update. However, this +-- would require a change in the cache format. +withIndexEntries + :: Verbosity -> Index + -> ([IndexCacheEntry] -> IO a) + -> ([NoIndexCacheEntry] -> IO a) + -> IO a +withIndexEntries _ (RepoIndex repoCtxt repo@RepoSecure{}) callback _ = + repoContextWithSecureRepo repoCtxt repo $ \repoSecure -> + Sec.withIndex repoSecure $ \Sec.IndexCallbacks{..} -> do + -- Incrementally (lazily) read all the entries in the tar file in order, + -- including all revisions, not just the last revision of each file + indexEntries <- lazyUnfold indexLookupEntry (Sec.directoryFirst indexDirectory) + callback [ cacheEntry + | (dirEntry, indexEntry) <- indexEntries + , cacheEntry <- toCacheEntries dirEntry indexEntry ] + where + toCacheEntries :: Sec.DirectoryEntry -> Sec.Some Sec.IndexEntry + -> [IndexCacheEntry] + toCacheEntries dirEntry (Sec.Some sie) = + case Sec.indexEntryPathParsed sie of + Nothing -> [] -- skip unrecognized file + Just (Sec.IndexPkgMetadata _pkgId) -> [] -- skip metadata + Just (Sec.IndexPkgCabal pkgId) -> force + [CachePackageId pkgId blockNo timestamp] + Just (Sec.IndexPkgPrefs _pkgName) -> force + [ CachePreference dep blockNo timestamp + | dep <- parsePreferredVersions (Sec.indexEntryContent sie) + ] + where + blockNo = Sec.directoryEntryBlockNo dirEntry + timestamp = fromMaybe (error "withIndexEntries: invalid timestamp") $ + epochTimeToTimestamp $ Sec.indexEntryTime sie + +withIndexEntries verbosity (RepoIndex _repoCtxt (RepoLocalNoIndex (LocalRepo name localDir _) _cacheDir)) _ callback = do + dirContents <- listDirectory localDir + let contentSet = Set.fromList dirContents + + entries <- handle handler $ fmap catMaybes $ for dirContents $ \file -> do + case isTarGz file of + Nothing + | isPreferredVersions file -> do + contents <- BS.readFile (localDir file) + let versionPreferencesParsed = parsePreferredVersionsWarnings contents + let (warnings, versionPreferences) = partitionEithers versionPreferencesParsed + unless (null warnings) $ do + warn verbosity $ + "withIndexEntries: failed to parse some entries of \"preferred-versions\" found at: " + ++ (localDir file) + for_ warnings $ \err -> do + warn verbosity $ "* \"" ++ preferredVersionsOriginalDependency err + warn verbosity $ "Parser Error: " ++ preferredVersionsParsecError err + return $ Just $ NoIndexCachePreference versionPreferences + | otherwise -> do + unless (takeFileName file == "noindex.cache" || ".cabal" `isSuffixOf` file) $ + info verbosity $ "Skipping " ++ file + return Nothing + Just pkgid | cabalPath `Set.member` contentSet -> do + contents <- BSS.readFile (localDir cabalPath) + for (parseGenericPackageDescriptionMaybe contents) $ \gpd -> + return (CacheGPD gpd contents) + where + cabalPath = prettyShow pkgid ++ ".cabal" + Just pkgId -> do + -- check for the right named .cabal file in the compressed tarball + tarGz <- BS.readFile (localDir file) + let tar = GZip.decompress tarGz + entries = Tar.read tar + + case Tar.foldEntries (readCabalEntry pkgId) Nothing (const Nothing) entries of + Just ce -> return (Just ce) + Nothing -> die' verbosity $ "Cannot read .cabal file inside " ++ file + + let (prefs, gpds) = partitionEithers $ map + (\case + NoIndexCachePreference deps -> Left deps + CacheGPD gpd _ -> Right gpd + ) + entries + + info verbosity $ "Entries in file+noindex repository " ++ unRepoName name + for_ gpds $ \gpd -> + info verbosity $ "- " ++ prettyShow (package $ Distribution.PackageDescription.packageDescription gpd) + unless (null prefs) $ do + info verbosity $ "Preferred versions in file+noindex repository " ++ unRepoName name + for_ (concat prefs) $ \pref -> + info verbosity ("* " ++ prettyShow pref) + + callback entries + where + handler :: IOException -> IO a + handler e = die' verbosity $ "Error while updating index for " ++ unRepoName name ++ " repository " ++ show e + + isTarGz :: FilePath -> Maybe PackageIdentifier + isTarGz fp = do + pfx <- stripSuffix ".tar.gz" fp + simpleParsec pfx + + stripSuffix sfx str = fmap reverse (stripPrefix (reverse sfx) (reverse str)) + + -- look for /.cabal inside the tarball + readCabalEntry :: PackageIdentifier -> Tar.Entry -> Maybe NoIndexCacheEntry -> Maybe NoIndexCacheEntry + readCabalEntry pkgId entry Nothing + | filename == Tar.entryPath entry + , Tar.NormalFile contents _ <- Tar.entryContent entry + = let bs = BS.toStrict contents + in fmap (\gpd -> CacheGPD gpd bs) $ parseGenericPackageDescriptionMaybe bs + where + filename = prettyShow pkgId FilePath.Posix. prettyShow (packageName pkgId) ++ ".cabal" + readCabalEntry _ _ x = x + +withIndexEntries verbosity index callback _ = do -- non-secure repositories + withFile (indexFile index) ReadMode $ \h -> do + bs <- maybeDecompress `fmap` BS.hGetContents h + pkgsOrPrefs <- lazySequence $ parsePackageIndex verbosity bs + callback $ map toCache (catMaybes pkgsOrPrefs) + where + toCache :: PackageOrDep -> IndexCacheEntry + toCache (Pkg (NormalPackage pkgid _ _ blockNo)) = CachePackageId pkgid blockNo nullTimestamp + toCache (Pkg (BuildTreeRef refType _ _ _ blockNo)) = CacheBuildTreeRef refType blockNo + toCache (Dep d) = CachePreference d 0 nullTimestamp + +readPackageIndexCacheFile :: Package pkg + => Verbosity + -> (PackageEntry -> pkg) + -> Index + -> RepoIndexState + -> IO (PackageIndex pkg, [Dependency], IndexStateInfo) +readPackageIndexCacheFile verbosity mkPkg index idxState + | localNoIndex index = do + cache0 <- readNoIndexCache verbosity index + (pkgs, prefs) <- packageNoIndexFromCache verbosity mkPkg cache0 + pure (pkgs, prefs, emptyStateInfo) + + | otherwise = do + cache0 <- readIndexCache verbosity index + indexHnd <- openFile (indexFile index) ReadMode + let (cache,isi) = filterCache idxState cache0 + (pkgs,deps) <- packageIndexFromCache verbosity mkPkg indexHnd cache + pure (pkgs,deps,isi) + +packageIndexFromCache :: Package pkg + => Verbosity + -> (PackageEntry -> pkg) + -> Handle + -> Cache + -> IO (PackageIndex pkg, [Dependency]) +packageIndexFromCache verbosity mkPkg hnd cache = do + (pkgs, prefs) <- packageListFromCache verbosity mkPkg hnd cache + pkgIndex <- evaluate $ PackageIndex.fromList pkgs + return (pkgIndex, prefs) + +packageNoIndexFromCache + :: forall pkg. Package pkg + => Verbosity + -> (PackageEntry -> pkg) + -> NoIndexCache + -> IO (PackageIndex pkg, [Dependency]) +packageNoIndexFromCache _verbosity mkPkg cache = do + let (pkgs, prefs) = packageListFromNoIndexCache + pkgIndex <- evaluate $ PackageIndex.fromList pkgs + pure (pkgIndex, prefs) + where + packageListFromNoIndexCache :: ([pkg], [Dependency]) + packageListFromNoIndexCache = foldr go mempty (noIndexCacheEntries cache) + + go :: NoIndexCacheEntry -> ([pkg], [Dependency]) -> ([pkg], [Dependency]) + go (CacheGPD gpd bs) (pkgs, prefs) = + let pkgId = package $ Distribution.PackageDescription.packageDescription gpd + in (mkPkg (NormalPackage pkgId gpd (BS.fromStrict bs) 0) : pkgs, prefs) + go (NoIndexCachePreference deps) (pkgs, prefs) = + (pkgs, deps ++ prefs) + + +-- | Read package list +-- +-- The result package releases and preference entries are guaranteed +-- to be unique. +-- +-- Note: 01-index.tar is an append-only index and therefore contains +-- all .cabal edits and preference-updates. The masking happens +-- here, i.e. the semantics that later entries in a tar file mask +-- earlier ones is resolved in this function. +packageListFromCache :: Verbosity + -> (PackageEntry -> pkg) + -> Handle + -> Cache + -> IO ([pkg], [Dependency]) +packageListFromCache verbosity mkPkg hnd Cache{..} = accum mempty [] mempty cacheEntries + where + accum !srcpkgs btrs !prefs [] = return (Map.elems srcpkgs ++ btrs, Map.elems prefs) + + accum srcpkgs btrs prefs (CachePackageId pkgid blockno _ : entries) = do + -- Given the cache entry, make a package index entry. + -- The magic here is that we use lazy IO to read the .cabal file + -- from the index tarball if it turns out that we need it. + -- Most of the time we only need the package id. + ~(pkg, pkgtxt) <- unsafeInterleaveIO $ do + pkgtxt <- getEntryContent blockno + pkg <- readPackageDescription pkgid pkgtxt + return (pkg, pkgtxt) + + let srcpkg = mkPkg (NormalPackage pkgid pkg pkgtxt blockno) + accum (Map.insert pkgid srcpkg srcpkgs) btrs prefs entries + + accum srcpkgs btrs prefs (CacheBuildTreeRef refType blockno : entries) = do + -- We have to read the .cabal file eagerly here because we can't cache the + -- package id for build tree references - the user might edit the .cabal + -- file after the reference was added to the index. + path <- liftM byteStringToFilePath . getEntryContent $ blockno + pkg <- do let err = "Error reading package index from cache." + file <- tryFindAddSourcePackageDesc verbosity path err + PackageDesc.Parse.readGenericPackageDescription normal file + let srcpkg = mkPkg (BuildTreeRef refType (packageId pkg) pkg path blockno) + accum srcpkgs (srcpkg:btrs) prefs entries + + accum srcpkgs btrs prefs (CachePreference pref@(Dependency pn _ _) _ _ : entries) = + accum srcpkgs btrs (Map.insert pn pref prefs) entries + + getEntryContent :: BlockNo -> IO ByteString + getEntryContent blockno = do + entry <- Tar.hReadEntry hnd blockno + case Tar.entryContent entry of + Tar.NormalFile content _size -> return content + Tar.OtherEntryType typecode content _size + | Tar.isBuildTreeRefTypeCode typecode + -> return content + _ -> interror "unexpected tar entry type" + + readPackageDescription :: PackageIdentifier -> ByteString -> IO GenericPackageDescription + readPackageDescription pkgid content = + case snd $ PackageDesc.Parse.runParseResult $ parseGenericPackageDescription $ BS.toStrict content of + Right gpd -> return gpd + Left (Just specVer, _) | specVer >= mkVersion [2,2] -> return (dummyPackageDescription specVer) + Left _ -> interror "failed to parse .cabal file" + where + dummyPackageDescription :: Version -> GenericPackageDescription + dummyPackageDescription specVer = GenericPackageDescription + { packageDescription = emptyPackageDescription + { package = pkgid + , synopsis = dummySynopsis + } + , gpdScannedVersion = Just specVer -- tells index scanner to skip this file. + , genPackageFlags = [] + , condLibrary = Nothing + , condSubLibraries = [] + , condForeignLibs = [] + , condExecutables = [] + , condTestSuites = [] + , condBenchmarks = [] + } + + dummySynopsis = "" + + interror :: String -> IO a + interror msg = die' verbosity $ "internal error when reading package index: " ++ msg + ++ "The package index or index cache is probably " + ++ "corrupt. Running 'hackport update' might fix it." + + + +------------------------------------------------------------------------ +-- Index cache data structure -- + +-- | Read the 'Index' cache from the filesystem +-- +-- If a corrupted index cache is detected this function regenerates +-- the index cache and then reattempt to read the index once (and +-- 'die's if it fails again). +readIndexCache :: Verbosity -> Index -> IO Cache +readIndexCache verbosity index = do + cacheOrFail <- readIndexCache' index + case cacheOrFail of + Left msg -> do + warn verbosity $ concat + [ "Parsing the index cache failed (", msg, "). " + , "Trying to regenerate the index cache..." + ] + + updatePackageIndexCacheFile verbosity index + + either (die' verbosity) (return . hashConsCache) =<< readIndexCache' index + + Right res -> return (hashConsCache res) + +readNoIndexCache :: Verbosity -> Index -> IO NoIndexCache +readNoIndexCache verbosity index = do + cacheOrFail <- readNoIndexCache' index + case cacheOrFail of + Left msg -> do + warn verbosity $ concat + [ "Parsing the index cache failed (", msg, "). " + , "Trying to regenerate the index cache..." + ] + + updatePackageIndexCacheFile verbosity index + + either (die' verbosity) return =<< readNoIndexCache' index + + -- we don't hash cons local repository cache, they are hopefully small + Right res -> return res + +-- | Read the 'Index' cache from the filesystem without attempting to +-- regenerate on parsing failures. +readIndexCache' :: Index -> IO (Either String Cache) +readIndexCache' index + | is01Index index = structuredDecodeFileOrFail (cacheFile index) + | otherwise = liftM (Right .read00IndexCache) $ + BSS.readFile (cacheFile index) + +readNoIndexCache' :: Index -> IO (Either String NoIndexCache) +readNoIndexCache' index = structuredDecodeFileOrFail (cacheFile index) + +-- | Write the 'Index' cache to the filesystem +writeIndexCache :: Index -> Cache -> IO () +writeIndexCache index cache + | is01Index index = structuredEncodeFile (cacheFile index) cache + | otherwise = writeFile (cacheFile index) (show00IndexCache cache) + +writeNoIndexCache :: Verbosity -> Index -> NoIndexCache -> IO () +writeNoIndexCache verbosity index cache = do + let path = cacheFile index + createDirectoryIfMissingVerbose verbosity True (takeDirectory path) + structuredEncodeFile path cache + +-- | Write the 'IndexState' to the filesystem +writeIndexTimestamp :: Index -> RepoIndexState -> IO () +writeIndexTimestamp index st + = writeFile (timestampFile index) (prettyShow st) + +-- | Read out the "current" index timestamp, i.e., what +-- timestamp you would use to revert to this version +currentIndexTimestamp :: Verbosity -> RepoContext -> Repo -> IO Timestamp +currentIndexTimestamp verbosity repoCtxt r = do + mb_is <- readIndexTimestamp verbosity (RepoIndex repoCtxt r) + case mb_is of + Just (IndexStateTime ts) -> return ts + _ -> do + (_,_,isi) <- readRepoIndex verbosity repoCtxt r IndexStateHead + return (isiHeadTime isi) + +-- | Read the 'IndexState' from the filesystem +readIndexTimestamp :: Verbosity -> Index -> IO (Maybe RepoIndexState) +readIndexTimestamp verbosity index + = fmap simpleParsec (readFile (timestampFile index)) + `catchIO` \e -> + if isDoesNotExistError e + then return Nothing + else do + warn verbosity $ "Warning: could not read current index timestamp: " ++ displayException e + return Nothing + +-- | Optimise sharing of equal values inside 'Cache' +-- +-- c.f. https://en.wikipedia.org/wiki/Hash_consing +hashConsCache :: Cache -> Cache +hashConsCache cache0 + = cache0 { cacheEntries = go mempty mempty (cacheEntries cache0) } + where + -- TODO/NOTE: + -- + -- If/when we redo the binary serialisation via e.g. CBOR and we + -- are able to use incremental decoding, we may want to move the + -- hash-consing into the incremental deserialisation, or + -- alternatively even do something like + -- http://cbor.schmorp.de/value-sharing + -- + go _ _ [] = [] + -- for now we only optimise only CachePackageIds since those + -- represent the vast majority + go !pns !pvs (CachePackageId pid bno ts : rest) + = CachePackageId pid' bno ts : go pns' pvs' rest + where + !pid' = PackageIdentifier pn' pv' + (!pn',!pns') = mapIntern pn pns + (!pv',!pvs') = mapIntern pv pvs + PackageIdentifier pn pv = pid + + go pns pvs (x:xs) = x : go pns pvs xs + + mapIntern :: Ord k => k -> Map.Map k k -> (k,Map.Map k k) + mapIntern k m = maybe (k,Map.insert k k m) (\k' -> (k',m)) (Map.lookup k m) + +-- | Cabal caches various information about the Hackage index +data Cache = Cache + { cacheHeadTs :: Timestamp + -- ^ maximum/latest 'Timestamp' among 'cacheEntries'; unless the + -- invariant of 'cacheEntries' being in chronological order is + -- violated, this corresponds to the last (seen) 'Timestamp' in + -- 'cacheEntries' + , cacheEntries :: [IndexCacheEntry] + } + deriving (Show, Generic) + +instance NFData Cache where + rnf = rnf . cacheEntries + +-- | Cache format for 'file+noindex' repositories +newtype NoIndexCache = NoIndexCache + { noIndexCacheEntries :: [NoIndexCacheEntry] + } + deriving (Show, Generic) + +instance NFData NoIndexCache where + rnf = rnf . noIndexCacheEntries + +-- | Tar files are block structured with 512 byte blocks. Every header and file +-- content starts on a block boundary. +-- +type BlockNo = Word32 -- Tar.TarEntryOffset + +data IndexCacheEntry + = CachePackageId PackageId !BlockNo !Timestamp + | CachePreference Dependency !BlockNo !Timestamp + | CacheBuildTreeRef !BuildTreeRefType !BlockNo + -- NB: CacheBuildTreeRef is irrelevant for 01-index & v2-build + deriving (Eq,Show,Generic) + +data NoIndexCacheEntry + = CacheGPD GenericPackageDescription !BSS.ByteString + | NoIndexCachePreference [Dependency] + deriving (Eq,Show,Generic) + +instance NFData IndexCacheEntry where + rnf (CachePackageId pkgid _ _) = rnf pkgid + rnf (CachePreference dep _ _) = rnf dep + rnf (CacheBuildTreeRef _ _) = () + +instance NFData NoIndexCacheEntry where + rnf (CacheGPD gpd bs) = rnf gpd `seq` rnf bs + rnf (NoIndexCachePreference dep) = rnf dep + +cacheEntryTimestamp :: IndexCacheEntry -> Timestamp +cacheEntryTimestamp (CacheBuildTreeRef _ _) = nullTimestamp +cacheEntryTimestamp (CachePreference _ _ ts) = ts +cacheEntryTimestamp (CachePackageId _ _ ts) = ts + +---------------------------------------------------------------------------- +-- new binary 01-index.cache format + +instance Binary Cache +instance Binary IndexCacheEntry +instance Binary NoIndexCache + +instance Structured Cache +instance Structured IndexCacheEntry +instance Structured NoIndexCache + +-- | We need to save only .cabal file contents +instance Binary NoIndexCacheEntry where + put (CacheGPD _ bs) = do + put (0 :: Word8) + put bs + put (NoIndexCachePreference dep) = do + put (1 :: Word8) + put dep + + get = do + t :: Word8 <- get + case t of + 0 -> do + bs <- get + case parseGenericPackageDescriptionMaybe bs of + Just gpd -> return (CacheGPD gpd bs) + Nothing -> fail "Failed to parse GPD" + 1 -> do + dep <- get + pure $ NoIndexCachePreference dep + _ -> fail "Failed to parse NoIndexCacheEntry" + +instance Structured NoIndexCacheEntry where + structure = nominalStructure + +---------------------------------------------------------------------------- +-- legacy 00-index.cache format + +packageKey, blocknoKey, buildTreeRefKey, preferredVersionKey :: String +packageKey = "pkg:" +blocknoKey = "b#" +buildTreeRefKey = "build-tree-ref:" +preferredVersionKey = "pref-ver:" + +-- legacy 00-index.cache format +read00IndexCache :: BSS.ByteString -> Cache +read00IndexCache bs = Cache + { cacheHeadTs = nullTimestamp + , cacheEntries = mapMaybe read00IndexCacheEntry $ BSS.lines bs + } + +read00IndexCacheEntry :: BSS.ByteString -> Maybe IndexCacheEntry +read00IndexCacheEntry = \line -> + case BSS.words line of + [key, pkgnamestr, pkgverstr, sep, blocknostr] + | key == BSS.pack packageKey && sep == BSS.pack blocknoKey -> + case (parseName pkgnamestr, parseVer pkgverstr [], + parseBlockNo blocknostr) of + (Just pkgname, Just pkgver, Just blockno) + -> Just (CachePackageId (PackageIdentifier pkgname pkgver) + blockno nullTimestamp) + _ -> Nothing + [key, typecodestr, blocknostr] | key == BSS.pack buildTreeRefKey -> + case (parseRefType typecodestr, parseBlockNo blocknostr) of + (Just refType, Just blockno) + -> Just (CacheBuildTreeRef refType blockno) + _ -> Nothing + + (key: remainder) | key == BSS.pack preferredVersionKey -> do + pref <- simpleParsecBS (BSS.unwords remainder) + return $ CachePreference pref 0 nullTimestamp + + _ -> Nothing + where + parseName str + | BSS.all (\c -> isAlphaNum c || c == '-') str + = Just (mkPackageName (BSS.unpack str)) + | otherwise = Nothing + + parseVer str vs = + case BSS.readInt str of + Nothing -> Nothing + Just (v, str') -> case BSS.uncons str' of + Just ('.', str'') -> parseVer str'' (v:vs) + Just _ -> Nothing + Nothing -> Just (mkVersion (reverse (v:vs))) + + parseBlockNo str = + case BSS.readInt str of + Just (blockno, remainder) + | BSS.null remainder -> Just (fromIntegral blockno) + _ -> Nothing + + parseRefType str = + case BSS.uncons str of + Just (typeCode, remainder) + | BSS.null remainder && Tar.isBuildTreeRefTypeCode typeCode + -> Just (refTypeFromTypeCode typeCode) + _ -> Nothing + +-- legacy 00-index.cache format +show00IndexCache :: Cache -> String +show00IndexCache Cache{..} = unlines $ map show00IndexCacheEntry cacheEntries + +show00IndexCacheEntry :: IndexCacheEntry -> String +show00IndexCacheEntry entry = unwords $ case entry of + CachePackageId pkgid b _ -> + [ packageKey + , prettyShow (packageName pkgid) + , prettyShow (packageVersion pkgid) + , blocknoKey + , show b + ] + CacheBuildTreeRef tr b -> + [ buildTreeRefKey + , [typeCodeFromRefType tr] + , show b + ] + CachePreference dep _ _ -> + [ preferredVersionKey + , prettyShow dep + ] diff --git a/cabal/cabal-install/src/Distribution/Client/IndexUtils/ActiveRepos.hs b/cabal/cabal-install/src/Distribution/Client/IndexUtils/ActiveRepos.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/IndexUtils/ActiveRepos.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Distribution.Client.IndexUtils.ActiveRepos ( + ActiveRepos (..), + defaultActiveRepos, + filterSkippedActiveRepos, + ActiveRepoEntry (..), + CombineStrategy (..), + organizeByRepos, +) where + +import Distribution.Client.Compat.Prelude +import Distribution.Client.Types.RepoName (RepoName (..)) +import Prelude () + +import Distribution.Parsec (parsecLeadingCommaNonEmpty) + +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as Disp + +-- $setup +-- >>> import Distribution.Parsec + +------------------------------------------------------------------------------- +-- Types +------------------------------------------------------------------------------- + +-- | Ordered list of active repositories. +newtype ActiveRepos = ActiveRepos [ActiveRepoEntry] + deriving (Eq, Show, Generic) + +defaultActiveRepos :: ActiveRepos +defaultActiveRepos = ActiveRepos [ ActiveRepoRest CombineStrategyMerge ] + +-- | Note, this does nothing if 'ActiveRepoRest' is present. +filterSkippedActiveRepos :: ActiveRepos -> ActiveRepos +filterSkippedActiveRepos repos@(ActiveRepos entries) + | any isActiveRepoRest entries = repos + | otherwise = ActiveRepos (filter notSkipped entries) + where + isActiveRepoRest (ActiveRepoRest _) = True + isActiveRepoRest _ = False + + notSkipped (ActiveRepo _ CombineStrategySkip) = False + notSkipped _ = True + +instance Binary ActiveRepos +instance Structured ActiveRepos +instance NFData ActiveRepos + +instance Pretty ActiveRepos where + pretty (ActiveRepos []) + = Disp.text ":none" + pretty (ActiveRepos repos) + = Disp.hsep + $ Disp.punctuate Disp.comma + $ map pretty repos + +-- | Note: empty string is not valid 'ActiveRepos'. +-- +-- >>> simpleParsec "" :: Maybe ActiveRepos +-- Nothing +-- +-- >>> simpleParsec ":none" :: Maybe ActiveRepos +-- Just (ActiveRepos []) +-- +-- >>> simpleParsec ":rest" :: Maybe ActiveRepos +-- Just (ActiveRepos [ActiveRepoRest CombineStrategyMerge]) +-- +-- >>> simpleParsec "hackage.haskell.org, :rest, head.hackage:override" :: Maybe ActiveRepos +-- Just (ActiveRepos [ActiveRepo (RepoName "hackage.haskell.org") CombineStrategyMerge,ActiveRepoRest CombineStrategyMerge,ActiveRepo (RepoName "head.hackage") CombineStrategyOverride]) +-- +instance Parsec ActiveRepos where + parsec = ActiveRepos [] <$ P.try (P.string ":none") + <|> do + repos <- parsecLeadingCommaNonEmpty parsec + return (ActiveRepos (toList repos)) + +data ActiveRepoEntry + = ActiveRepoRest CombineStrategy -- ^ rest repositories, i.e. not explicitly listed as 'ActiveRepo' + | ActiveRepo RepoName CombineStrategy -- ^ explicit repository name + deriving (Eq, Show, Generic) + +instance Binary ActiveRepoEntry +instance Structured ActiveRepoEntry +instance NFData ActiveRepoEntry + +instance Pretty ActiveRepoEntry where + pretty (ActiveRepoRest s) = + Disp.text ":rest" <<>> Disp.colon <<>> pretty s + pretty (ActiveRepo r s) = + pretty r <<>> Disp.colon <<>> pretty s + +instance Parsec ActiveRepoEntry where + parsec = leadColon <|> leadRepo where + leadColon = do + _ <- P.char ':' + token <- P.munch1 isAlpha + case token of + "rest" -> ActiveRepoRest <$> strategyP + "repo" -> P.char ':' *> leadRepo + _ -> P.unexpected $ "Unknown active repository entry type: " ++ token + + leadRepo = do + r <- parsec + s <- strategyP + return (ActiveRepo r s) + + strategyP = P.option CombineStrategyMerge (P.char ':' *> parsec) + +data CombineStrategy + = CombineStrategySkip -- ^ skip this repository + | CombineStrategyMerge -- ^ merge existing versions + | CombineStrategyOverride -- ^ if later repository specifies a package, + -- all package versions are replaced + deriving (Eq, Show, Enum, Bounded, Generic) + +instance Binary CombineStrategy +instance Structured CombineStrategy +instance NFData CombineStrategy + +instance Pretty CombineStrategy where + pretty CombineStrategySkip = Disp.text "skip" + pretty CombineStrategyMerge = Disp.text "merge" + pretty CombineStrategyOverride = Disp.text "override" + +instance Parsec CombineStrategy where + parsec = P.choice + [ CombineStrategySkip <$ P.string "skip" + , CombineStrategyMerge <$ P.string "merge" + , CombineStrategyOverride <$ P.string "override" + ] + +------------------------------------------------------------------------------- +-- Organisation +------------------------------------------------------------------------------- + +-- | Sort values 'RepoName' according to 'ActiveRepos' list. +-- +-- >>> let repos = [RepoName "a", RepoName "b", RepoName "c"] +-- >>> organizeByRepos (ActiveRepos [ActiveRepoRest CombineStrategyMerge]) id repos +-- Right [(RepoName "a",CombineStrategyMerge),(RepoName "b",CombineStrategyMerge),(RepoName "c",CombineStrategyMerge)] +-- +-- >>> organizeByRepos (ActiveRepos [ActiveRepo (RepoName "b") CombineStrategyOverride, ActiveRepoRest CombineStrategyMerge]) id repos +-- Right [(RepoName "b",CombineStrategyOverride),(RepoName "a",CombineStrategyMerge),(RepoName "c",CombineStrategyMerge)] +-- +-- >>> organizeByRepos (ActiveRepos [ActiveRepoRest CombineStrategyMerge, ActiveRepo (RepoName "b") CombineStrategyOverride]) id repos +-- Right [(RepoName "a",CombineStrategyMerge),(RepoName "c",CombineStrategyMerge),(RepoName "b",CombineStrategyOverride)] +-- +-- >>> organizeByRepos (ActiveRepos [ActiveRepoRest CombineStrategyMerge, ActiveRepo (RepoName "d") CombineStrategyOverride]) id repos +-- Left "no repository provided d" +-- +-- Note: currently if 'ActiveRepoRest' is provided more than once, +-- rest-repositories will be multiple times in the output. +-- +organizeByRepos + :: forall a. ActiveRepos + -> (a -> RepoName) + -> [a] + -> Either String [(a, CombineStrategy)] +organizeByRepos (ActiveRepos xs0) sel ys0 = + -- here we use lazyness to do only one traversal + let (rest, result) = case go rest xs0 ys0 of + Right (rest', result') -> (rest', Right result') + Left err -> ([], Left err) + in result + where + go :: [a] -> [ActiveRepoEntry] -> [a] -> Either String ([a], [(a, CombineStrategy)]) + go _rest [] ys = Right (ys, []) + go rest (ActiveRepoRest s : xs) ys = + go rest xs ys <&> \(rest', result) -> + (rest', map (\x -> (x, s)) rest ++ result) + go rest (ActiveRepo r s : xs) ys = do + (z, zs) <- extract r ys + go rest xs zs <&> \(rest', result) -> + (rest', (z, s) : result) + + extract :: RepoName -> [a] -> Either String (a, [a]) + extract r = loop id where + loop _acc [] = Left $ "no repository provided " ++ prettyShow r + loop acc (x:xs) + | sel x == r = Right (x, acc xs) + | otherwise = loop (acc . (x :)) xs + + (<&>) + :: Either err ([s], b) + -> (([s], b) -> ([s], c)) + -> Either err ([s], c) + (<&>) = flip fmap diff --git a/cabal/cabal-install/src/Distribution/Client/IndexUtils/IndexState.hs b/cabal/cabal-install/src/Distribution/Client/IndexUtils/IndexState.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/IndexUtils/IndexState.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.IndexUtils.IndexUtils +-- Copyright : (c) 2016 Herbert Valerio Riedel +-- License : BSD3 +-- +-- Package repositories index state. +-- +module Distribution.Client.IndexUtils.IndexState ( + RepoIndexState(..), + TotalIndexState, + headTotalIndexState, + makeTotalIndexState, + lookupIndexState, + insertIndexState, +) where + +import Distribution.Client.Compat.Prelude +import Distribution.Client.IndexUtils.Timestamp (Timestamp) +import Distribution.Client.Types.RepoName (RepoName (..)) + +import Distribution.Parsec (parsecLeadingCommaNonEmpty) + +import qualified Data.Map.Strict as Map +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as Disp + +-- $setup +-- >>> import Distribution.Parsec + +------------------------------------------------------------------------------- +-- Total index state +------------------------------------------------------------------------------- + +-- | Index state of multiple repositories +data TotalIndexState = TIS RepoIndexState (Map RepoName RepoIndexState) + deriving (Eq, Show, Generic) + +instance Binary TotalIndexState +instance Structured TotalIndexState +instance NFData TotalIndexState + +instance Pretty TotalIndexState where + pretty (TIS IndexStateHead m) + | not (Map.null m) + = Disp.hsep $ Disp.punctuate Disp.comma + [ pretty rn Disp.<+> pretty idx + | (rn, idx) <- Map.toList m + ] + pretty (TIS def m) = foldl' go (pretty def) (Map.toList m) where + go doc (rn, idx) = doc <<>> Disp.comma Disp.<+> pretty rn Disp.<+> pretty idx + +-- | +-- +-- >>> simpleParsec "HEAD" :: Maybe TotalIndexState +-- Just (TIS IndexStateHead (fromList [])) +-- +-- >>> simpleParsec "" :: Maybe TotalIndexState +-- Nothing +-- +-- >>> simpleParsec "hackage.haskell.org HEAD" :: Maybe TotalIndexState +-- Just (TIS IndexStateHead (fromList [])) +-- +-- >>> simpleParsec "2020-02-04T12:34:56Z, hackage.haskell.org HEAD" :: Maybe TotalIndexState +-- Just (TIS (IndexStateTime (TS 1580819696)) (fromList [(RepoName "hackage.haskell.org",IndexStateHead)])) +-- +-- >>> simpleParsec "hackage.haskell.org 2020-02-04T12:34:56Z" :: Maybe TotalIndexState +-- Just (TIS IndexStateHead (fromList [(RepoName "hackage.haskell.org",IndexStateTime (TS 1580819696))])) +-- +instance Parsec TotalIndexState where + parsec = normalise . foldl' add headTotalIndexState <$> parsecLeadingCommaNonEmpty single0 where + single0 = startsWithRepoName <|> TokTimestamp <$> parsec + startsWithRepoName = do + reponame <- parsec + -- the "HEAD" is technically a valid reponame... + if reponame == RepoName "HEAD" + then return TokHead + else do + P.spaces + TokRepo reponame <$> parsec + + add :: TotalIndexState -> Tok -> TotalIndexState + add _ TokHead = headTotalIndexState + add _ (TokTimestamp ts) = TIS (IndexStateTime ts) Map.empty + add (TIS def m) (TokRepo rn idx) = TIS def (Map.insert rn idx m) + +-- used in Parsec TotalIndexState implementation +data Tok + = TokRepo RepoName RepoIndexState + | TokTimestamp Timestamp + | TokHead + +-- | Remove non-default values from 'TotalIndexState'. +normalise :: TotalIndexState -> TotalIndexState +normalise (TIS def m) = TIS def (Map.filter (/= def) m) + +-- | 'TotalIndexState' where all repositories are at @HEAD@ index state. +headTotalIndexState :: TotalIndexState +headTotalIndexState = TIS IndexStateHead Map.empty + +-- | Create 'TotalIndexState'. +makeTotalIndexState :: RepoIndexState -> Map RepoName RepoIndexState -> TotalIndexState +makeTotalIndexState def m = normalise (TIS def m) + +-- | Lookup a 'RepoIndexState' for an individual repository from 'TotalIndexState'. +lookupIndexState :: RepoName -> TotalIndexState -> RepoIndexState +lookupIndexState rn (TIS def m) = Map.findWithDefault def rn m + +-- | Insert a 'RepoIndexState' to 'TotalIndexState'. +insertIndexState :: RepoName -> RepoIndexState -> TotalIndexState -> TotalIndexState +insertIndexState rn idx (TIS def m) + | idx == def = TIS def (Map.delete rn m) + | otherwise = TIS def (Map.insert rn idx m) + +------------------------------------------------------------------------------- +-- Repository index state +------------------------------------------------------------------------------- + +-- | Specification of the state of a specific repo package index +data RepoIndexState + = IndexStateHead -- ^ Use all available entries + | IndexStateTime !Timestamp -- ^ Use all entries that existed at the specified time + deriving (Eq,Generic,Show) + +instance Binary RepoIndexState +instance Structured RepoIndexState +instance NFData RepoIndexState + +instance Pretty RepoIndexState where + pretty IndexStateHead = Disp.text "HEAD" + pretty (IndexStateTime ts) = pretty ts + +instance Parsec RepoIndexState where + parsec = parseHead <|> parseTime where + parseHead = IndexStateHead <$ P.string "HEAD" + parseTime = IndexStateTime <$> parsec diff --git a/cabal/cabal-install/src/Distribution/Client/IndexUtils/Timestamp.hs b/cabal/cabal-install/src/Distribution/Client/IndexUtils/Timestamp.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/IndexUtils/Timestamp.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.IndexUtils.Timestamp +-- Copyright : (c) 2016 Herbert Valerio Riedel +-- License : BSD3 +-- +-- Timestamp type used in package indexes + +module Distribution.Client.IndexUtils.Timestamp + ( Timestamp + , nullTimestamp + , epochTimeToTimestamp + , timestampToUTCTime + , utcTimeToTimestamp + , maximumTimestamp + ) where + +import Distribution.Client.Compat.Prelude + +-- read is needed for Text instance +import Prelude (read) + +import Data.Time (UTCTime (..), fromGregorianValid, makeTimeOfDayValid, showGregorian, timeOfDayToTime, timeToTimeOfDay) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds) + +import qualified Codec.Archive.Tar.Entry as Tar +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as Disp + +-- | UNIX timestamp (expressed in seconds since unix epoch, i.e. 1970). +newtype Timestamp = TS Int64 -- Tar.EpochTime + deriving (Eq,Ord,Enum,NFData,Show,Generic) + +epochTimeToTimestamp :: Tar.EpochTime -> Maybe Timestamp +epochTimeToTimestamp et + | ts == nullTimestamp = Nothing + | otherwise = Just ts + where + ts = TS et + +timestampToUTCTime :: Timestamp -> Maybe UTCTime +timestampToUTCTime (TS t) + | t == minBound = Nothing + | otherwise = Just $ posixSecondsToUTCTime (fromIntegral t) + +utcTimeToTimestamp :: UTCTime -> Maybe Timestamp +utcTimeToTimestamp utct + | minTime <= t, t <= maxTime = Just (TS (fromIntegral t)) + | otherwise = Nothing + where + maxTime = toInteger (maxBound :: Int64) + minTime = toInteger (succ minBound :: Int64) + t :: Integer + t = round . utcTimeToPOSIXSeconds $ utct + +-- | Compute the maximum 'Timestamp' value +-- +-- Returns 'nullTimestamp' for the empty list. Also note that +-- 'nullTimestamp' compares as smaller to all non-'nullTimestamp' +-- values. +maximumTimestamp :: [Timestamp] -> Timestamp +maximumTimestamp [] = nullTimestamp +maximumTimestamp xs@(_:_) = maximum xs + +-- returns 'Nothing' if not representable as 'Timestamp' +posixSecondsToTimestamp :: Integer -> Maybe Timestamp +posixSecondsToTimestamp pt + | minTs <= pt, pt <= maxTs = Just (TS (fromInteger pt)) + | otherwise = Nothing + where + maxTs = toInteger (maxBound :: Int64) + minTs = toInteger (succ minBound :: Int64) + +-- | Pretty-prints 'Timestamp' in ISO8601/RFC3339 format +-- (e.g. @"2017-12-31T23:59:59Z"@) +-- +-- Returns empty string for 'nullTimestamp' in order for +-- +-- > null (display nullTimestamp) == True +-- +-- to hold. +showTimestamp :: Timestamp -> String +showTimestamp ts = case timestampToUTCTime ts of + Nothing -> "" + -- Note: we don't use 'formatTime' here to avoid incurring a + -- dependency on 'old-locale' for older `time` libs + Just UTCTime{..} -> showGregorian utctDay ++ ('T':showTOD utctDayTime) ++ "Z" + where + showTOD = show . timeToTimeOfDay + +instance Binary Timestamp +instance Structured Timestamp + +instance Pretty Timestamp where + pretty = Disp.text . showTimestamp + +instance Parsec Timestamp where + parsec = parsePosix <|> parseUTC + where + -- | Parses unix timestamps, e.g. @"\@1474626019"@ + parsePosix = do + _ <- P.char '@' + t <- P.integral -- note, no negative timestamps + maybe (fail (show t ++ " is not representable as timestamp")) return $ + posixSecondsToTimestamp t + + -- | Parses ISO8601/RFC3339-style UTC timestamps, + -- e.g. @"2017-12-31T23:59:59Z"@ + -- + -- TODO: support numeric tz offsets; allow to leave off seconds + parseUTC = do + -- Note: we don't use 'Data.Time.Format.parseTime' here since + -- we want more control over the accepted formats. + + ye <- parseYear + _ <- P.char '-' + mo <- parseTwoDigits + _ <- P.char '-' + da <- parseTwoDigits + _ <- P.char 'T' + + utctDay <- maybe (fail (show (ye,mo,da) ++ " is not valid gregorian date")) return $ + fromGregorianValid ye mo da + + ho <- parseTwoDigits + _ <- P.char ':' + mi <- parseTwoDigits + _ <- P.char ':' + se <- parseTwoDigits + _ <- P.char 'Z' + + utctDayTime <- maybe (fail (show (ho,mi,se) ++ " is not valid time of day")) (return . timeOfDayToTime) $ + makeTimeOfDayValid ho mi (realToFrac (se::Int)) + + let utc = UTCTime {..} + + maybe (fail (show utc ++ " is not representable as timestamp")) return $ utcTimeToTimestamp utc + + parseTwoDigits = do + d1 <- P.satisfy isDigit + d2 <- P.satisfy isDigit + return (read [d1,d2]) + + -- A year must have at least 4 digits; e.g. "0097" is fine, + -- while "97" is not c.f. RFC3339 which + -- deprecates 2-digit years + parseYear = do + sign <- P.option ' ' (P.char '-') + ds <- P.munch1 isDigit + when (length ds < 4) $ fail "Year should have at least 4 digits" + return (read (sign:ds)) + +-- | Special timestamp value to be used when 'timestamp' is +-- missing/unknown/invalid +nullTimestamp :: Timestamp +nullTimestamp = TS minBound diff --git a/cabal/cabal-install/src/Distribution/Client/Init.hs b/cabal/cabal-install/src/Distribution/Client/Init.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Init.hs @@ -0,0 +1,64 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Init +-- Copyright : (c) Brent Yorgey 2009 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Implementation of the 'cabal init' command, which creates an initial .cabal +-- file for a project. +-- +----------------------------------------------------------------------------- + +module Distribution.Client.Init +( -- * Commands + initCmd +) where + +import qualified Distribution.Client.Init.Interactive.Command as Interactive +import qualified Distribution.Client.Init.NonInteractive.Command as NonInteractive +import qualified Distribution.Client.Init.Simple as Simple +import Distribution.Verbosity +import Distribution.Client.Setup (RepoContext) +import Distribution.Simple.Compiler +import Distribution.Simple.Program (ProgramDb) +import Distribution.Client.Init.Types +import Distribution.Simple.Setup +import Distribution.Client.IndexUtils +import System.IO (hSetBuffering, stdout, BufferMode (NoBuffering)) +import Distribution.Client.Init.FileCreators + +-- | This is the main driver for the init script. +-- +initCmd + :: Verbosity + -> PackageDBStack + -> RepoContext + -> Compiler + -> ProgramDb + -> InitFlags + -> IO () +initCmd v packageDBs repoCtxt comp progdb initFlags = do + installedPkgIndex <- getInstalledPackages v comp packageDBs progdb + sourcePkgDb <- getSourcePackages v repoCtxt + hSetBuffering stdout NoBuffering + settings <- createProject v installedPkgIndex sourcePkgDb initFlags + writeProject settings + where + -- When no flag is set, default to interactive. + -- + -- When `--interactive` is set, if we also set `--simple`, + -- then we interactive generate a simple project with sensible defaults. + -- + -- If `--simple` is not set, default to interactive. When the flag + -- is explicitly set to `--non-interactive`, then we choose non-interactive. + -- + createProject + | fromFlagOrDefault False (simpleProject initFlags) = + Simple.createProject + | otherwise = case interactive initFlags of + Flag False -> NonInteractive.createProject comp + _ -> Interactive.createProject diff --git a/cabal/cabal-install/src/Distribution/Client/Init/Defaults.hs b/cabal/cabal-install/src/Distribution/Client/Init/Defaults.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Init/Defaults.hs @@ -0,0 +1,192 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Init.Defaults +-- Copyright : (c) Brent Yorgey 2009 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Default values to use in cabal init (if not specified in config/flags). +-- +----------------------------------------------------------------------------- +module Distribution.Client.Init.Defaults + +( -- * default init values + defaultApplicationDir +, defaultSourceDir +, defaultCabalVersion +, defaultCabalVersions +, defaultPackageType +, defaultLicense +, defaultLicenseIds +, defaultMainIs +, defaultChangelog +, defaultCategories +, defaultInitFlags +, defaultLanguage +, defaultVersion +, defaultTestDir + -- * MyLib defaults +, myLibModule +, myLibTestFile +, myLibFile +, myLibHs +, myExeHs +, myLibExeHs +, myTestHs +) where + + +import Distribution.ModuleName (ModuleName) +import qualified Distribution.ModuleName as ModuleName(fromString) +import Distribution.CabalSpecVersion (CabalSpecVersion (..)) +import Distribution.Client.Init.Types (PackageType(..), InitFlags(..), HsFilePath, toHsFilePath) +import qualified Distribution.SPDX.License as SPDX +import qualified Distribution.SPDX.LicenseId as SPDX +import Distribution.Simple.Flag (toFlag) +import Distribution.Verbosity (normal) +import Distribution.Types.Version +import Distribution.FieldGrammar.Newtypes +import Distribution.Simple (Language(..), License(..)) + + +-- -------------------------------------------------------------------- -- +-- Default flag and init values + +defaultVersion :: Version +defaultVersion = mkVersion [0,1,0,0] + +defaultApplicationDir :: String +defaultApplicationDir = "app" + +defaultSourceDir :: String +defaultSourceDir = "src" + +defaultTestDir :: String +defaultTestDir = "test" + +defaultCabalVersion :: CabalSpecVersion +defaultCabalVersion = CabalSpecV3_0 + +defaultPackageType :: PackageType +defaultPackageType = Executable + +defaultChangelog :: FilePath +defaultChangelog = "CHANGELOG.md" + +defaultLicense :: CabalSpecVersion -> SpecLicense +defaultLicense csv + | csv < CabalSpecV2_2 = SpecLicense $ Right AllRightsReserved + | otherwise = SpecLicense $ Left SPDX.NONE + +defaultMainIs :: HsFilePath +defaultMainIs = toHsFilePath "Main.hs" + +defaultLanguage :: Language +defaultLanguage = Haskell2010 + +defaultLicenseIds :: [SPDX.LicenseId] +defaultLicenseIds = + [ SPDX.BSD_2_Clause + , SPDX.BSD_3_Clause + , SPDX.Apache_2_0 + , SPDX.MIT + , SPDX.MPL_2_0 + , SPDX.ISC + , SPDX.GPL_2_0_only + , SPDX.GPL_3_0_only + , SPDX.LGPL_2_1_only + , SPDX.LGPL_3_0_only + , SPDX.AGPL_3_0_only + , SPDX.GPL_2_0_or_later + , SPDX.GPL_3_0_or_later + , SPDX.LGPL_2_1_or_later + , SPDX.LGPL_3_0_or_later + , SPDX.AGPL_3_0_or_later + ] + +defaultCategories :: [String] +defaultCategories = + [ "Codec" + , "Concurrency" + , "Control" + , "Data" + , "Database" + , "Development" + , "Distribution" + , "Game" + , "Graphics" + , "Language" + , "Math" + , "Network" + , "Sound" + , "System" + , "Testing" + , "Text" + , "Web" + ] + +defaultCabalVersions :: [CabalSpecVersion] +defaultCabalVersions = + [ CabalSpecV1_24 + , CabalSpecV2_0 + , CabalSpecV2_2 + , CabalSpecV2_4 + , CabalSpecV3_0 + , CabalSpecV3_4 + ] + +defaultInitFlags :: InitFlags +defaultInitFlags = mempty { initVerbosity = toFlag normal } + +-- -------------------------------------------------------------------- -- +-- MyLib defaults + +myLibModule :: ModuleName +myLibModule = ModuleName.fromString "MyLib" + +myLibTestFile :: HsFilePath +myLibTestFile = toHsFilePath "MyLibTest.hs" + +myLibFile :: HsFilePath +myLibFile = toHsFilePath "MyLib.hs" + +-- | Default MyLib.hs file. Used when no Lib.hs exists. +myLibHs :: String +myLibHs = unlines + [ "module MyLib (someFunc) where" + , "" + , "someFunc :: IO ()" + , "someFunc = putStrLn \"someFunc\"" + ] + +myExeHs :: [String] +myExeHs = + [ "module Main where" + , "" + , "main :: IO ()" + , "main = putStrLn \"Hello, Haskell!\"" + ] + +myLibExeHs :: [String] +myLibExeHs = + [ "module Main where" + , "" + , "import qualified MyLib (someFunc)" + , "" + , "main :: IO ()" + , "main = do" + , " putStrLn \"Hello, Haskell!\"" + , " MyLib.someFunc" + ] + +-- | Default MyLibTest.hs file. +myTestHs :: String +myTestHs = unlines + [ "module Main (main) where" + , "" + , "main :: IO ()" + , "main = putStrLn \"Test suite not yet implemented.\"" + ] diff --git a/cabal/cabal-install/src/Distribution/Client/Init/FileCreators.hs b/cabal/cabal-install/src/Distribution/Client/Init/FileCreators.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Init/FileCreators.hs @@ -0,0 +1,315 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Init.FileCreators +-- Copyright : (c) Brent Yorgey 2009 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Functions to create files during 'cabal init'. +-- +----------------------------------------------------------------------------- +module Distribution.Client.Init.FileCreators +( -- * Commands + writeProject +, writeLicense +, writeChangeLog +, prepareLibTarget +, prepareExeTarget +, prepareTestTarget +) where + +import Prelude hiding (writeFile, readFile) +import Distribution.Client.Compat.Prelude hiding (head, empty, writeFile, readFile) + +import qualified Data.Set as Set (member) + +import Distribution.Client.Init.Defaults +import Distribution.Client.Init.Licenses + ( bsd2, bsd3, gplv2, gplv3, lgpl21, lgpl3, agplv3, apache20, mit, mpl20, isc ) +import Distribution.Client.Init.Types hiding (putStrLn, putStr, message) +import qualified Distribution.Client.Init.Types as T +import Distribution.Fields.Pretty (PrettyField(..), showFields') +import qualified Distribution.SPDX as SPDX +import Distribution.Types.PackageName +import Distribution.Client.Init.Format +import Distribution.CabalSpecVersion (showCabalSpecVersion) + +import System.FilePath ((), (<.>)) +import Distribution.FieldGrammar.Newtypes +import Distribution.License (licenseToSPDX) + +-- -------------------------------------------------------------------- -- +-- File generation + +writeProject :: Interactive m => ProjectSettings -> m () +writeProject (ProjectSettings opts pkgDesc libTarget exeTarget testTarget) + | null pkgName = do + message opts T.Error "no package name given, so no .cabal file can be generated\n" + | otherwise = do + + -- clear prompt history a bit" + message opts T.Log + $ "Using cabal specification: " + ++ showCabalSpecVersion (_optCabalSpec opts) + + writeLicense opts pkgDesc + writeChangeLog opts pkgDesc + + let pkgFields = mkPkgDescription opts pkgDesc + commonStanza = mkCommonStanza opts + + libStanza <- prepareLibTarget opts libTarget + exeStanza <- prepareExeTarget opts exeTarget + testStanza <- prepareTestTarget opts testTarget + + (reusedCabal, cabalContents) <- writeCabalFile opts $ + pkgFields ++ [commonStanza, libStanza, exeStanza, testStanza] + + when (null $ _pkgSynopsis pkgDesc) $ + message opts T.Warning "No synopsis given. You should edit the .cabal file and add one." + + message opts T.Info "You may want to edit the .cabal file and add a Description field." + + when reusedCabal $ do + existingCabal <- readFile $ unPackageName (_optPkgName opts) ++ ".cabal" + when (existingCabal /= cabalContents) $ + message opts T.Warning "A .cabal file was found and not updated, if updating is desired please use the '--overwrite' option." + + -- clear out last line for presentation. + T.putStrLn "" + where + pkgName = unPackageName $ _optPkgName opts + + +prepareLibTarget + :: Interactive m + => WriteOpts + -> Maybe LibTarget + -> m (PrettyField FieldAnnotation) +prepareLibTarget _ Nothing = return PrettyEmpty +prepareLibTarget opts (Just libTarget) = do + void $ writeDirectoriesSafe opts $ filter (/= ".") srcDirs + -- avoid writing when conflicting exposed paths may + -- exist. + when (expMods == (myLibModule :| [])) . void $ + writeFileSafe opts libPath myLibHs + + return $ mkLibStanza opts libTarget + where + expMods = _libExposedModules libTarget + srcDirs = _libSourceDirs libTarget + libPath = case srcDirs of + path:_ -> path _hsFilePath myLibFile + _ -> _hsFilePath myLibFile + +prepareExeTarget + :: Interactive m + => WriteOpts + -> Maybe ExeTarget + -> m (PrettyField FieldAnnotation) +prepareExeTarget _ Nothing = return PrettyEmpty +prepareExeTarget opts (Just exeTarget) = do + void $ writeDirectoriesSafe opts appDirs + void $ writeFileSafe opts mainPath mainHs + return $ mkExeStanza opts exeTarget + where + exeMainIs = _exeMainIs exeTarget + pkgType = _optPkgType opts + appDirs = _exeApplicationDirs exeTarget + mainFile = _hsFilePath exeMainIs + mainPath = case appDirs of + appPath:_ -> appPath mainFile + _ -> mainFile + + mainHs = unlines . mkLiterate exeMainIs $ + if pkgType == LibraryAndExecutable + then myLibExeHs + else myExeHs + +prepareTestTarget + :: Interactive m + => WriteOpts + -> Maybe TestTarget + -> m (PrettyField FieldAnnotation) +prepareTestTarget _ Nothing = return PrettyEmpty +prepareTestTarget opts (Just testTarget) = do + void $ writeDirectoriesSafe opts testDirs' + void $ writeFileSafe opts testPath myTestHs + return $ mkTestStanza opts testTarget + where + testDirs' = _testDirs testTarget + testMainIs = _hsFilePath $ _testMainIs testTarget + testPath = case testDirs' of + p:_ -> p testMainIs + _ -> testMainIs + +writeCabalFile + :: Interactive m + => WriteOpts + -> [PrettyField FieldAnnotation] + -- ^ .cabal fields + -> m (Bool, String) +writeCabalFile opts fields = do + let cabalContents = showFields' + annCommentLines + postProcessFieldLines + 4 fields + + reusedCabal <- writeFileSafe opts cabalFileName cabalContents + return (reusedCabal, cabalContents) + where + cabalFileName = pkgName ++ ".cabal" + pkgName = unPackageName $ _optPkgName opts + +-- | Write the LICENSE file. +-- +-- For licenses that contain the author's name(s), the values are taken +-- from the 'authors' field of 'InitFlags', and if not specified will +-- be the string "???". +-- +-- If the license type is unknown no license file will be prepared and +-- a warning will be raised. +-- +writeLicense :: Interactive m => WriteOpts -> PkgDescription -> m () +writeLicense writeOpts pkgDesc = do + year <- show <$> getCurrentYear + case licenseFile year (_pkgAuthor pkgDesc) of + Just licenseText -> + void $ writeFileSafe writeOpts "LICENSE" licenseText + Nothing -> message writeOpts T.Warning "unknown license type, you must put a copy in LICENSE yourself." + where + getLid (Left (SPDX.License (SPDX.ELicense (SPDX.ELicenseId lid) Nothing))) = Just lid + getLid (Right l) = getLid . Left $ licenseToSPDX l + getLid _ = Nothing + + licenseFile year auth = case getLid . getSpecLicense $ _pkgLicense pkgDesc of + Just SPDX.BSD_2_Clause -> Just $ bsd2 auth year + Just SPDX.BSD_3_Clause -> Just $ bsd3 auth year + Just SPDX.Apache_2_0 -> Just apache20 + Just SPDX.MIT -> Just $ mit auth year + Just SPDX.MPL_2_0 -> Just mpl20 + Just SPDX.ISC -> Just $ isc auth year + Just SPDX.GPL_2_0_only -> Just gplv2 + Just SPDX.GPL_3_0_only -> Just gplv3 + Just SPDX.LGPL_2_1_only -> Just lgpl21 + Just SPDX.LGPL_3_0_only -> Just lgpl3 + Just SPDX.AGPL_3_0_only -> Just agplv3 + Just SPDX.GPL_2_0_or_later -> Just gplv2 + Just SPDX.GPL_3_0_or_later -> Just gplv3 + Just SPDX.LGPL_2_1_or_later -> Just lgpl21 + Just SPDX.LGPL_3_0_or_later -> Just lgpl3 + Just SPDX.AGPL_3_0_or_later -> Just agplv3 + _ -> Nothing + +-- | Writes the changelog to the current directory. +-- +writeChangeLog :: Interactive m => WriteOpts -> PkgDescription -> m () +writeChangeLog opts pkgDesc + | Just docs <- _pkgExtraDocFiles pkgDesc + , defaultChangelog `Set.member` docs = go + | defaultChangelog `elem` _pkgExtraSrcFiles pkgDesc = go + | otherwise = return () + where + changeLog = unlines + [ "# Revision history for " ++ prettyShow (_pkgName pkgDesc) + , "" + , "## " ++ prettyShow (_pkgVersion pkgDesc) ++ " -- YYYY-mm-dd" + , "" + , "* First version. Released on an unsuspecting world." + ] + + go = + void $ writeFileSafe opts defaultChangelog changeLog + +-- -------------------------------------------------------------------- -- +-- Utilities + +data WriteAction = Overwrite | Fresh | Existing deriving Eq + +instance Show WriteAction where + show Overwrite = "Overwriting" + show Fresh = "Creating fresh" + show Existing = "Using existing" + +-- | Possibly generate a message to stdout, taking into account the +-- --quiet flag. +message :: Interactive m => WriteOpts -> T.Severity -> String -> m () +message opts = T.message (_optVerbosity opts) + +-- | Write a file \"safely\" if it doesn't exist, backing up any existing version when +-- the overwrite flag is set. +writeFileSafe :: Interactive m => WriteOpts -> FilePath -> String -> m Bool +writeFileSafe opts fileName content = do + exists <- doesFileExist fileName + + let action + | exists && doOverwrite = Overwrite + | not exists = Fresh + | otherwise = Existing + + go exists + + message opts T.Log $ show action ++ " file " ++ fileName ++ "..." + return $ action == Existing + where + doOverwrite = _optOverwrite opts + + go exists + | not exists = do + writeFile fileName content + | exists && doOverwrite = do + newName <- findNewPath fileName + message opts T.Log $ concat + [ fileName + , " already exists. Backing up old version in " + , newName + ] + + copyFile fileName newName -- backups the old file + removeExistingFile fileName -- removes the original old file + writeFile fileName content -- writes the new file + | otherwise = return () + +writeDirectoriesSafe :: Interactive m => WriteOpts -> [String] -> m Bool +writeDirectoriesSafe opts dirs = fmap or $ for dirs $ \dir -> do + exists <- doesDirectoryExist dir + + let action + | exists && doOverwrite = Overwrite + | not exists = Fresh + | otherwise = Existing + + go dir exists + + message opts T.Log $ show action ++ " directory ./" ++ dir ++ "..." + return $ action == Existing + where + doOverwrite = _optOverwrite opts + + go dir exists + | not exists = do + createDirectory dir + | exists && doOverwrite = do + newDir <- findNewPath dir + message opts T.Log $ concat + [ dir + , " already exists. Backing up old version in " + , newDir + ] + + renameDirectory dir newDir -- backups the old directory + createDirectory dir -- creates the new directory + | otherwise = return () + +findNewPath :: Interactive m => FilePath -> m FilePath +findNewPath dir = go (0 :: Int) + where + go n = do + let newDir = dir <.> ("save" ++ show n) + e <- doesDirectoryExist newDir + if e then go (succ n) else return newDir diff --git a/cabal/cabal-install/src/Distribution/Client/Init/FlagExtractors.hs b/cabal/cabal-install/src/Distribution/Client/Init/FlagExtractors.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Init/FlagExtractors.hs @@ -0,0 +1,302 @@ +{-# LANGUAGE LambdaCase #-} +module Distribution.Client.Init.FlagExtractors +( -- * Flag extractors + getPackageDir +, getSimpleProject +, getMinimal +, getCabalVersion +, getCabalVersionNoPrompt +, getPackageName +, getVersion +, getLicense +, getAuthor +, getEmail +, getHomepage +, getSynopsis +, getCategory +, getExtraSrcFiles +, getExtraDocFiles +, getPackageType +, getMainFile +, getInitializeTestSuite +, getTestDirs +, getLanguage +, getNoComments +, getAppDirs +, getSrcDirs +, getExposedModules +, getBuildTools +, getDependencies +, getOtherExts +, getOverwrite +, getOtherModules + -- * Shared prompts +, simpleProjectPrompt +, initializeTestSuitePrompt +, packageTypePrompt +, testMainPrompt +, dependenciesPrompt +) where + + +import Prelude () +import Distribution.Client.Compat.Prelude hiding (putStr, putStrLn, getLine, last) + +import qualified Data.List.NonEmpty as NEL + +import Distribution.CabalSpecVersion (CabalSpecVersion(..)) +import Distribution.Version (Version) +import Distribution.ModuleName (ModuleName) +import Distribution.Types.Dependency (Dependency(..)) +import Distribution.Types.PackageName (PackageName) +import Distribution.Client.Init.Defaults +import Distribution.FieldGrammar.Newtypes (SpecLicense) +import Distribution.Client.Init.Types +import Distribution.Simple.Setup (Flag(..), fromFlagOrDefault, flagToMaybe) +import Distribution.Simple.Flag (flagElim) + +import Language.Haskell.Extension (Language(..), Extension(..)) +import Distribution.Client.Init.Prompt +import qualified Data.Set as Set +import Distribution.Simple.PackageIndex +import Distribution.Client.Init.Utils + + + +-- -------------------------------------------------------------------- -- +-- Flag extraction + +getPackageDir :: Interactive m => InitFlags -> m FilePath +getPackageDir = flagElim getCurrentDirectory return . packageDir + +-- | Ask if a simple project with sensible defaults should be created. +getSimpleProject :: Interactive m => InitFlags -> m Bool -> m Bool +getSimpleProject flags = fromFlagOrPrompt (simpleProject flags) + +-- | Extract minimal cabal file flag (implies nocomments) +getMinimal :: Interactive m => InitFlags -> m Bool +getMinimal = return . fromFlagOrDefault False . minimal + +-- | Get the version of the cabal spec to use. +-- +-- The spec version can be specified by the InitFlags cabalVersion field. If +-- none is specified then the user is prompted to pick from a list of +-- supported versions (see code below). +getCabalVersion :: Interactive m => InitFlags -> m CabalSpecVersion -> m CabalSpecVersion +getCabalVersion flags = fromFlagOrPrompt (cabalVersion flags) + +getCabalVersionNoPrompt :: InitFlags -> CabalSpecVersion +getCabalVersionNoPrompt = fromFlagOrDefault defaultCabalVersion . cabalVersion + +-- | Get the package name: use the package directory (supplied, or the current +-- directory by default) as a guess. It looks at the SourcePackageDb to avoid +-- using an existing package name. +getPackageName :: Interactive m => InitFlags -> m PackageName -> m PackageName +getPackageName flags = fromFlagOrPrompt (packageName flags) + +-- | Package version: use 0.1.0.0 as a last resort, but try prompting the user +-- if possible. +getVersion :: Interactive m => InitFlags -> m Version -> m Version +getVersion flags = fromFlagOrPrompt (version flags) + +-- | Choose a license for the package. +-- The license can come from Initflags (license field), if it is not present +-- then prompt the user from a predefined list of licenses. +getLicense :: Interactive m => InitFlags -> m SpecLicense -> m SpecLicense +getLicense flags = fromFlagOrPrompt (license flags) + +-- | The author's name. Prompt, or try to guess from an existing +-- darcs repo. +getAuthor :: Interactive m => InitFlags -> m String -> m String +getAuthor flags = fromFlagOrPrompt (author flags) + +-- | The author's email. Prompt, or try to guess from an existing +-- darcs repo. +getEmail :: Interactive m => InitFlags -> m String -> m String +getEmail flags = fromFlagOrPrompt (email flags) + +-- | Prompt for a homepage URL for the package. +getHomepage :: Interactive m => InitFlags -> m String -> m String +getHomepage flags = fromFlagOrPrompt (homepage flags) + +-- | Prompt for a project synopsis. +getSynopsis :: Interactive m => InitFlags -> m String -> m String +getSynopsis flags = fromFlagOrPrompt (synopsis flags) + +-- | Prompt for a package category. +-- Note that it should be possible to do some smarter guessing here too, i.e. +-- look at the name of the top level source directory. +getCategory :: Interactive m => InitFlags -> m String -> m String +getCategory flags = fromFlagOrPrompt (category flags) + +-- | Try to guess extra source files (don't prompt the user). +getExtraSrcFiles :: Interactive m => InitFlags -> m (Set String) +getExtraSrcFiles = pure . flagElim mempty Set.fromList . extraSrc + +-- | Try to guess extra source files (don't prompt the user). +getExtraDocFiles :: Interactive m => InitFlags -> m (Maybe (Set String)) +getExtraDocFiles = pure + . Just + . flagElim (Set.singleton defaultChangelog) Set.fromList + . extraDoc + +-- | Ask whether the project builds a library or executable. +getPackageType :: Interactive m => InitFlags -> m PackageType -> m PackageType +getPackageType InitFlags + { initializeTestSuite = Flag True + , packageType = NoFlag + } _ = return TestSuite +getPackageType flags act = fromFlagOrPrompt (packageType flags) act + +getMainFile :: Interactive m => InitFlags -> m HsFilePath -> m HsFilePath +getMainFile flags act = case mainIs flags of + Flag a + | isHsFilePath a -> return $ toHsFilePath a + | otherwise -> act + NoFlag -> act + +getInitializeTestSuite :: Interactive m => InitFlags -> m Bool -> m Bool +getInitializeTestSuite flags = fromFlagOrPrompt (initializeTestSuite flags) + +getTestDirs :: Interactive m => InitFlags -> m [String] -> m [String] +getTestDirs flags = fromFlagOrPrompt (testDirs flags) + +-- | Ask for the Haskell base language of the package. +getLanguage :: Interactive m => InitFlags -> m Language -> m Language +getLanguage flags = fromFlagOrPrompt (language flags) + +-- | Ask whether to generate explanatory comments. +getNoComments :: Interactive m => InitFlags -> m Bool -> m Bool +getNoComments flags = fromFlagOrPrompt (noComments flags) + +-- | Ask for the application root directory. +getAppDirs :: Interactive m => InitFlags -> m [String] -> m [String] +getAppDirs flags = fromFlagOrPrompt (applicationDirs flags) + +-- | Ask for the source (library) root directory. +getSrcDirs :: Interactive m => InitFlags -> m [String] -> m [String] +getSrcDirs flags = fromFlagOrPrompt (sourceDirs flags) + +-- | Retrieve the list of exposed modules +getExposedModules :: Interactive m => InitFlags -> m (NonEmpty ModuleName) +getExposedModules = return + . fromMaybe (myLibModule NEL.:| []) + . join + . flagToMaybe + . fmap NEL.nonEmpty + . exposedModules + +-- | Retrieve the list of other modules +getOtherModules :: Interactive m => InitFlags -> m [ModuleName] +getOtherModules = return . fromFlagOrDefault [] . otherModules + +-- | Retrieve the list of build tools +getBuildTools :: Interactive m => InitFlags -> m [Dependency] +getBuildTools = flagElim (return []) (foldM go []) . buildTools + where + go acc dep = case eitherParsec dep of + Left e -> do + putStrLn $ "Failed to parse dependency: " ++ e + putStrLn "Skipping..." + + return acc + Right d -> return $ acc ++ [d] + +-- | Retrieve the list of dependencies +getDependencies + :: Interactive m + => InitFlags + -> m [Dependency] + -> m [Dependency] +getDependencies flags = fromFlagOrPrompt (dependencies flags) + + +-- | Retrieve the list of extensions +getOtherExts :: Interactive m => InitFlags -> m [Extension] +getOtherExts = return . fromFlagOrDefault [] . otherExts + +-- | Tell whether to overwrite files on write +-- +getOverwrite :: Interactive m => InitFlags -> m Bool +getOverwrite = return . fromFlagOrDefault False . overwrite + +-- -------------------------------------------------------------------- -- +-- Shared prompts + +simpleProjectPrompt :: Interactive m => InitFlags -> m Bool +simpleProjectPrompt flags = getSimpleProject flags $ + promptYesNo + "Should I generate a simple project with sensible defaults" + (DefaultPrompt True) + +initializeTestSuitePrompt :: Interactive m => InitFlags -> m Bool +initializeTestSuitePrompt flags = getInitializeTestSuite flags $ + promptYesNo + "Should I generate a test suite for the library" + (DefaultPrompt True) + +packageTypePrompt :: Interactive m => InitFlags -> m PackageType +packageTypePrompt flags = getPackageType flags $ do + pt <- promptList "What does the package build" + packageTypes + (DefaultPrompt "Executable") + Nothing + False + + return $ fromMaybe Executable (parsePackageType pt) + where + packageTypes = + [ "Library" + , "Executable" + , "Library and Executable" + , "Test suite" + ] + + parsePackageType = \case + "Library" -> Just Library + "Executable" -> Just Executable + "Library and Executable" -> Just LibraryAndExecutable + "Test suite" -> Just TestSuite + _ -> Nothing + +testMainPrompt :: Interactive m => m HsFilePath +testMainPrompt = do + fp <- promptList "What is the main module of the test suite?" + [defaultMainIs', "Main.lhs"] + (DefaultPrompt defaultMainIs') + Nothing + True + + let hs = toHsFilePath fp + + case _hsFileType hs of + InvalidHsPath -> do + putStrLn $ concat + [ "Main file " + , show hs + , " is not a valid haskell file. Source files must end in .hs or .lhs." + ] + testMainPrompt + _ -> return hs + where + defaultMainIs' = show defaultMainIs + +dependenciesPrompt + :: Interactive m + => InstalledPackageIndex + -> InitFlags + -> m [Dependency] +dependenciesPrompt pkgIx flags = getDependencies flags (getBaseDep pkgIx flags) + +-- -------------------------------------------------------------------- -- +-- utilities + +-- | If a flag is defined, return its value or else execute +-- an interactive action. +-- +fromFlagOrPrompt + :: Interactive m + => Flag a + -> m a + -> m a +fromFlagOrPrompt flag action = flagElim action return flag diff --git a/cabal/cabal-install/src/Distribution/Client/Init/Format.hs b/cabal/cabal-install/src/Distribution/Client/Init/Format.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Init/Format.hs @@ -0,0 +1,402 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : Distribution.Client.Init.Format +-- Copyright : (c) Brent Yorgey 2009 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Pretty printing and field formatting utilities used for file creation. +-- +module Distribution.Client.Init.Format +( -- * cabal file formatters + listFieldS +, field +, fieldD +, commentedOutWithComments +, withComments +, annNoComments +, postProcessFieldLines + -- * stanza generation +, mkCommonStanza +, mkLibStanza +, mkExeStanza +, mkTestStanza +, mkPkgDescription +) where + + +import Distribution.Pretty +import Distribution.Fields +import Distribution.Client.Init.Types +import Distribution.License +import Text.PrettyPrint +import Distribution.Solver.Compat.Prelude hiding (empty) +import Distribution.PackageDescription.FieldGrammar +import Distribution.Simple.Utils hiding (cabalVersion) +import Distribution.Utils.Path +import Distribution.Package (unPackageName) +import qualified Distribution.SPDX.License as SPDX +import Distribution.CabalSpecVersion +import Distribution.FieldGrammar.Newtypes (SpecLicense(SpecLicense)) + + +-- | Construct a 'PrettyField' from a field that can be automatically +-- converted to a 'Doc' via 'display'. +field + :: Pretty b + => FieldName + -> (a -> b) + -> a + -> [String] + -> Bool + -> WriteOpts + -> PrettyField FieldAnnotation +field fieldName modifier fieldContents = + fieldD fieldName (pretty $ modifier fieldContents) + +-- | Construct a 'PrettyField' from a 'Doc' Flag. +fieldD + :: FieldName -- ^ Name of the field + -> Doc -- ^ Field contents + -> [String] -- ^ Comment to explain the field + -> Bool -- ^ Should the field be included (commented out) even if blank? + -> WriteOpts + -> PrettyField FieldAnnotation +fieldD fieldName fieldContents fieldComments includeField opts + -- If the "--no-comments" or "--minimal" flag is set, strip comments. + | hasNoComments || isMinimal = contents NoComment + | otherwise = contents $ commentPositionFor fieldName fieldComments + where + commentPositionFor fn + | fn == "cabal-version" = CommentAfter + | otherwise = CommentBefore + + isMinimal = _optMinimal opts + hasNoComments = _optNoComments opts + + contents + -- If there is no content, optionally produce a commented out field. + | fieldContents == empty = fieldSEmptyContents + | otherwise = fieldSWithContents + + fieldSEmptyContents cs + | not includeField || isMinimal = PrettyEmpty + | otherwise = PrettyField + (commentedOutWithComments cs) + fieldName + empty + + fieldSWithContents cs = + PrettyField (withComments cs) fieldName fieldContents + + +-- | A field annotation instructing the pretty printer to comment out the field +-- and any contents, with no comments. +commentedOutWithComments :: CommentPosition -> FieldAnnotation +commentedOutWithComments (CommentBefore cs) = FieldAnnotation True . CommentBefore $ map commentNoTrailing cs +commentedOutWithComments (CommentAfter cs) = FieldAnnotation True . CommentAfter $ map commentNoTrailing cs +commentedOutWithComments NoComment = FieldAnnotation True NoComment + +-- | A field annotation with the specified comment lines. +withComments :: CommentPosition -> FieldAnnotation +withComments (CommentBefore cs) = FieldAnnotation False . CommentBefore $ map commentNoTrailing cs +withComments (CommentAfter cs) = FieldAnnotation False . CommentAfter $ map commentNoTrailing cs +withComments NoComment = FieldAnnotation False NoComment + +-- | A field annotation with no comments. +annNoComments :: FieldAnnotation +annNoComments = FieldAnnotation False NoComment + +postProcessFieldLines :: FieldAnnotation -> [String] -> [String] +postProcessFieldLines ann + | annCommentedOut ann = fmap commentNoTrailing + | otherwise = id + +-- -------------------------------------------------------------------- -- +-- Stanzas + +-- The common stanzas are hardcoded for simplicity purposes, +-- see https://github.com/haskell/cabal/pull/7558#discussion_r693173846 +mkCommonStanza :: WriteOpts -> PrettyField FieldAnnotation +mkCommonStanza opts = case specHasCommonStanzas $ _optCabalSpec opts of + NoCommonStanzas -> PrettyEmpty + _ -> PrettySection + annNoComments + "common" + [text "warnings"] + [field "ghc-options" text "-Wall" [] False opts] + +mkLibStanza :: WriteOpts -> LibTarget -> PrettyField FieldAnnotation +mkLibStanza opts (LibTarget srcDirs lang expMods otherMods exts deps tools) = + PrettySection annNoComments (toUTF8BS "library") [] + [ case specHasCommonStanzas $ _optCabalSpec opts of + NoCommonStanzas -> PrettyEmpty + _ -> field "import" (hsep . map text) ["warnings"] + ["Import common warning flags."] + False + opts + + , field "exposed-modules" formatExposedModules (toList expMods) + ["Modules exported by the library."] + True + opts + + , field "other-modules" formatOtherModules otherMods + ["Modules included in this library but not exported."] + True + opts + + , field "other-extensions" formatOtherExtensions exts + ["LANGUAGE extensions used by modules in this package."] + True + opts + + , field "build-depends" formatDependencyList deps + ["Other library packages from which modules are imported."] + True + opts + + , field "hs-source-dirs" formatHsSourceDirs (unsafeMakeSymbolicPath <$> srcDirs) + ["Directories containing source files."] + True + opts + + , field (buildToolTag opts) formatDependencyList tools + ["Extra tools (e.g. alex, hsc2hs, ...) needed to build the source."] + False + opts + + , field "default-language" id lang + ["Base language which the package is written in."] + True + opts + ] + +mkExeStanza :: WriteOpts -> ExeTarget -> PrettyField FieldAnnotation +mkExeStanza opts (ExeTarget exeMain appDirs lang otherMods exts deps tools) = + PrettySection annNoComments (toUTF8BS "executable") [exeName] + [ case specHasCommonStanzas $ _optCabalSpec opts of + NoCommonStanzas -> PrettyEmpty + _ -> field "import" (hsep . map text) ["warnings"] + ["Import common warning flags."] + False + opts + + , field "main-is" unsafeFromHs exeMain + [".hs or .lhs file containing the Main module."] + True + opts + + , field "other-modules" formatOtherModules otherMods + [ "Modules included in this executable, other than Main." ] + True + opts + + , field "other-extensions" formatOtherExtensions exts + ["LANGUAGE extensions used by modules in this package."] + True + opts + , field "build-depends" formatDependencyList deps + ["Other library packages from which modules are imported."] + True + opts + + , field "hs-source-dirs" formatHsSourceDirs + (unsafeMakeSymbolicPath <$> appDirs) + ["Directories containing source files."] + True + opts + + , field (buildToolTag opts) formatDependencyList tools + ["Extra tools (e.g. alex, hsc2hs, ...) needed to build the source."] + False + opts + + , field "default-language" id lang + ["Base language which the package is written in."] + True + opts + ] + where + exeName = pretty $ _optPkgName opts + +mkTestStanza :: WriteOpts -> TestTarget -> PrettyField FieldAnnotation +mkTestStanza opts (TestTarget testMain dirs lang otherMods exts deps tools) = + PrettySection annNoComments (toUTF8BS "test-suite") [suiteName] + [ case specHasCommonStanzas $ _optCabalSpec opts of + NoCommonStanzas -> PrettyEmpty + _ -> field "import" (hsep . map text) ["warnings"] + ["Import common warning flags."] + False + opts + + , field "default-language" id lang + ["Base language which the package is written in."] + True + opts + , field "other-modules" formatOtherModules otherMods + [ "Modules included in this executable, other than Main." ] + True + opts + + , field "other-extensions" formatOtherExtensions exts + ["LANGUAGE extensions used by modules in this package."] + True + opts + + , field "type" text "exitcode-stdio-1.0" + ["The interface type and version of the test suite."] + True + opts + + , field "hs-source-dirs" formatHsSourceDirs + (unsafeMakeSymbolicPath <$> dirs) + ["Directories containing source files."] + True + opts + + , field "main-is" unsafeFromHs testMain + ["The entrypoint to the test suite."] + True + opts + + , field "build-depends" formatDependencyList deps + ["Test dependencies."] + True + opts + + , field (buildToolTag opts) formatDependencyList tools + ["Extra tools (e.g. alex, hsc2hs, ...) needed to build the source."] + False + opts + ] + where + suiteName = text $ unPackageName (_optPkgName opts) ++ "-test" + +mkPkgDescription :: WriteOpts -> PkgDescription -> [PrettyField FieldAnnotation] +mkPkgDescription opts pkgDesc = + [ field "cabal-version" text (showCabalSpecVersion cabalSpec) + [ "The cabal-version field refers to the version of the .cabal specification," + , "and can be different from the cabal-install (the tool) version and the" + , "Cabal (the library) version you are using. As such, the Cabal (the library)" + , "version used must be equal or greater than the version stated in this field." + , "Starting from the specification version 2.2, the cabal-version field must be" + , "the first thing in the cabal file." + ] + False + opts + + , field "name" pretty (_pkgName pkgDesc) + ["Initial package description '" ++ prettyShow (_optPkgName opts) ++ "' generated by" + , "'cabal init'. For further documentation, see:" + , " http://haskell.org/cabal/users-guide/" + , "" + , "The name of the package." + ] + True + opts + + , field "version" pretty (_pkgVersion pkgDesc) + ["The package version.", + "See the Haskell package versioning policy (PVP) for standards", + "guiding when and how versions should be incremented.", + "https://pvp.haskell.org", + "PVP summary: +-+------- breaking API changes", + " | | +----- non-breaking API additions", + " | | | +--- code changes with no API change"] + True + opts + + , field "synopsis" text (_pkgSynopsis pkgDesc) + ["A short (one-line) description of the package."] + True + opts + + , field "description" text "" + ["A longer description of the package."] + True + opts + + , field "homepage" text (_pkgHomePage pkgDesc) + ["URL for the project homepage or repository."] + False + opts + + , field "bug-reports" text "" + ["A URL where users can report bugs."] + False + opts + + , field "license" pretty (_pkgLicense pkgDesc) + ["The license under which the package is released."] + True + opts + + , case _pkgLicense pkgDesc of + SpecLicense (Left SPDX.NONE) -> PrettyEmpty + SpecLicense (Right AllRightsReserved) -> PrettyEmpty + SpecLicense (Right UnspecifiedLicense) -> PrettyEmpty + _ -> field "license-file" text "LICENSE" + ["The file containing the license text."] + False + opts + + , field "author" text (_pkgAuthor pkgDesc) + ["The package author(s)."] + True + opts + + , field "maintainer" text (_pkgEmail pkgDesc) + ["An email address to which users can send suggestions, bug reports, and patches."] + True + opts + + , field "copyright" text "" + ["A copyright notice."] + True + opts + + , field "category" text (_pkgCategory pkgDesc) + [] + False + opts + , field "build-type" text "Simple" + [] + False + opts + , case _pkgExtraDocFiles pkgDesc of + Nothing -> PrettyEmpty + Just fs -> + field "extra-doc-files" formatExtraSourceFiles (toList fs) + ["Extra doc files to be distributed with the package, such as a CHANGELOG or a README."] + True + opts + + , field "extra-source-files" formatExtraSourceFiles (toList $ _pkgExtraSrcFiles pkgDesc) + ["Extra source files to be distributed with the package, such as examples, or a tutorial module."] + True + opts + ] + where + cabalSpec = _pkgCabalVersion pkgDesc + +-- -------------------------------------------------------------------- -- +-- Utils + +listFieldS :: [String] -> Doc +listFieldS = text . intercalate ", " + +unsafeFromHs :: HsFilePath -> Doc +unsafeFromHs = text . _hsFilePath + +buildToolTag :: WriteOpts -> FieldName +buildToolTag opts + | _optCabalSpec opts < CabalSpecV3_0 = "build-tools" + | otherwise = "build-tool-depends" + +commentNoTrailing :: String -> String +commentNoTrailing "" = "--" +commentNoTrailing c = "-- " ++ c diff --git a/cabal/cabal-install/src/Distribution/Client/Init/Interactive/Command.hs b/cabal/cabal-install/src/Distribution/Client/Init/Interactive/Command.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Init/Interactive/Command.hs @@ -0,0 +1,476 @@ +{-# LANGUAGE LambdaCase, MultiWayIf #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Init.Command +-- Copyright : (c) Brent Yorgey 2009 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Implementation of the 'cabal init' command, which creates an initial .cabal +-- file for a project. +-- +----------------------------------------------------------------------------- +module Distribution.Client.Init.Interactive.Command +( -- * Commands + createProject + -- ** Target generation +, genPkgDescription +, genLibTarget +, genExeTarget +, genTestTarget + -- ** Prompts +, cabalVersionPrompt +, packageNamePrompt +, versionPrompt +, licensePrompt +, authorPrompt +, emailPrompt +, homepagePrompt +, synopsisPrompt +, categoryPrompt +, mainFilePrompt +, testDirsPrompt +, languagePrompt +, noCommentsPrompt +, appDirsPrompt +, dependenciesPrompt +, srcDirsPrompt +) where + + +import Prelude () +import Distribution.Client.Compat.Prelude hiding (putStr, putStrLn, getLine, last) + +import Distribution.CabalSpecVersion (CabalSpecVersion(..), showCabalSpecVersion) +import Distribution.Version (Version) +import Distribution.Types.PackageName (PackageName, unPackageName) +import qualified Distribution.SPDX as SPDX +import Distribution.Client.Init.Defaults +import Distribution.Client.Init.FlagExtractors +import Distribution.Client.Init.Prompt +import Distribution.Client.Init.Types +import Distribution.Client.Init.Utils +import Distribution.Client.Init.NonInteractive.Heuristics (guessAuthorName, guessAuthorEmail) +import Distribution.FieldGrammar.Newtypes (SpecLicense(..)) +import Distribution.Simple.Setup (Flag(..), fromFlagOrDefault) +import Distribution.Simple.PackageIndex (InstalledPackageIndex) +import Distribution.Client.Types (SourcePackageDb(..)) +import Distribution.Solver.Types.PackageIndex (elemByPackageName) + +import Language.Haskell.Extension (Language(..)) +import Distribution.License (knownLicenses) +import Distribution.Parsec (simpleParsec') + + +-- | Main driver for interactive prompt code. +-- +createProject + :: Interactive m + => Verbosity + -> InstalledPackageIndex + -> SourcePackageDb + -> InitFlags + -> m ProjectSettings +createProject v pkgIx srcDb initFlags = do + + -- The workflow is as follows: + -- + -- 1. Get the package type, supplied as either a program input or + -- via user prompt. This determines what targets will be built + -- in later steps. + -- + -- 2. Generate package description and the targets specified by + -- the package type. Once this is done, a prompt for building + -- test suites is initiated, and this determines if we build + -- test targets as well. Then we ask if the user wants to + -- comment their .cabal file with pretty comments. + -- + -- 3. The targets are passed to the file creator script, and associated + -- directories/files/modules are created, with the a .cabal file + -- being generated as a final result. + -- + + pkgType <- packageTypePrompt initFlags + isMinimal <- getMinimal initFlags + doOverwrite <- overwritePrompt initFlags + pkgDir <- getPackageDir initFlags + pkgDesc <- fixupDocFiles v =<< genPkgDescription initFlags srcDb + + let pkgName = _pkgName pkgDesc + cabalSpec = _pkgCabalVersion pkgDesc + mkOpts cs = WriteOpts + doOverwrite isMinimal cs + v pkgDir pkgType pkgName + initFlags' = initFlags { cabalVersion = Flag cabalSpec } + + case pkgType of + Library -> do + libTarget <- genLibTarget initFlags' pkgIx + testTarget <- addLibDepToTest pkgName <$> + genTestTarget initFlags' pkgIx + + comments <- noCommentsPrompt initFlags' + + return $ ProjectSettings + (mkOpts comments cabalSpec) pkgDesc + (Just libTarget) Nothing testTarget + + Executable -> do + exeTarget <- genExeTarget initFlags' pkgIx + comments <- noCommentsPrompt initFlags' + + return $ ProjectSettings + (mkOpts comments cabalSpec) pkgDesc Nothing + (Just exeTarget) Nothing + + LibraryAndExecutable -> do + libTarget <- genLibTarget initFlags' pkgIx + + exeTarget <- addLibDepToExe pkgName <$> + genExeTarget initFlags' pkgIx + + testTarget <- addLibDepToTest pkgName <$> + genTestTarget initFlags' pkgIx + + comments <- noCommentsPrompt initFlags' + + return $ ProjectSettings + (mkOpts comments cabalSpec) pkgDesc (Just libTarget) + (Just exeTarget) testTarget + + TestSuite -> do + -- the line below is necessary because if both package type and test flags + -- are *not* passed, the user will be prompted for a package type (which + -- includes TestSuite in the list). It prevents that the user end up with a + -- TestSuite target with initializeTestSuite set to NoFlag, thus avoiding the prompt. + let initFlags'' = initFlags' { initializeTestSuite = Flag True } + testTarget <- genTestTarget initFlags'' pkgIx + + comments <- noCommentsPrompt initFlags'' + + return $ ProjectSettings + (mkOpts comments cabalSpec) pkgDesc + Nothing Nothing testTarget + +-- -------------------------------------------------------------------- -- +-- Target and pkg description generation + +-- | Extract flags relevant to a package description and interactively +-- generate a 'PkgDescription' object for creation. If the user specifies +-- the generation of a simple package, then a simple target with defaults +-- is generated. +-- +genPkgDescription + :: Interactive m + => InitFlags + -> SourcePackageDb + -> m PkgDescription +genPkgDescription flags' srcDb = do + csv <- cabalVersionPrompt flags' + let flags = flags' { cabalVersion = Flag csv } + PkgDescription csv + <$> packageNamePrompt srcDb flags + <*> versionPrompt flags + <*> licensePrompt flags + <*> authorPrompt flags + <*> emailPrompt flags + <*> homepagePrompt flags + <*> synopsisPrompt flags + <*> categoryPrompt flags + <*> getExtraSrcFiles flags + <*> getExtraDocFiles flags + +-- | Extract flags relevant to a library target and interactively +-- generate a 'LibTarget' object for creation. If the user specifies +-- the generation of a simple package, then a simple target with defaults +-- is generated. +-- +genLibTarget + :: Interactive m + => InitFlags + -> InstalledPackageIndex + -> m LibTarget +genLibTarget flags pkgs = LibTarget + <$> srcDirsPrompt flags + <*> languagePrompt flags "library" + <*> getExposedModules flags + <*> getOtherModules flags + <*> getOtherExts flags + <*> dependenciesPrompt pkgs flags + <*> getBuildTools flags + +-- | Extract flags relevant to a executable target and interactively +-- generate a 'ExeTarget' object for creation. If the user specifies +-- the generation of a simple package, then a simple target with defaults +-- is generated. +-- +genExeTarget + :: Interactive m + => InitFlags + -> InstalledPackageIndex + -> m ExeTarget +genExeTarget flags pkgs = ExeTarget + <$> mainFilePrompt flags + <*> appDirsPrompt flags + <*> languagePrompt flags "executable" + <*> getOtherModules flags + <*> getOtherExts flags + <*> dependenciesPrompt pkgs flags + <*> getBuildTools flags + +-- | Extract flags relevant to a test target and interactively +-- generate a 'TestTarget' object for creation. If the user specifies +-- the generation of a simple package, then a simple target with defaults +-- is generated. +-- +-- Note: this workflow is only enabled if the user answers affirmatively +-- when prompted, or if the user passes in the flag to enable +-- test suites at command line. +-- +genTestTarget + :: Interactive m + => InitFlags + -> InstalledPackageIndex + -> m (Maybe TestTarget) +genTestTarget flags pkgs = initializeTestSuitePrompt flags >>= go + where + go initialized + | not initialized = return Nothing + | otherwise = fmap Just $ TestTarget + <$> testMainPrompt + <*> testDirsPrompt flags + <*> languagePrompt flags "test suite" + <*> getOtherModules flags + <*> getOtherExts flags + <*> dependenciesPrompt pkgs flags + <*> getBuildTools flags + + +-- -------------------------------------------------------------------- -- +-- Prompts + +overwritePrompt :: Interactive m => InitFlags -> m Bool +overwritePrompt flags = do + isOverwrite <- getOverwrite flags + promptYesNo + "Do you wish to overwrite existing files (backups will be created) (y/n)" + (DefaultPrompt isOverwrite) + +cabalVersionPrompt :: Interactive m => InitFlags -> m CabalSpecVersion +cabalVersionPrompt flags = getCabalVersion flags $ do + v <- promptList "Please choose version of the Cabal specification to use" + ppVersions + (DefaultPrompt ppDefault) + (Just takeVersion) + False + -- take just the version numbers for convenience + return $ parseCabalVersion (takeVersion v) + where + -- only used when presenting the default in prompt + takeVersion = takeWhile (/= ' ') + + ppDefault = displayCabalVersion defaultCabalVersion + ppVersions = displayCabalVersion <$> defaultCabalVersions + + parseCabalVersion :: String -> CabalSpecVersion + parseCabalVersion "1.24" = CabalSpecV1_24 + parseCabalVersion "2.0" = CabalSpecV2_0 + parseCabalVersion "2.2" = CabalSpecV2_2 + parseCabalVersion "2.4" = CabalSpecV2_4 + parseCabalVersion "3.0" = CabalSpecV3_0 + parseCabalVersion "3.4" = CabalSpecV3_4 + parseCabalVersion _ = defaultCabalVersion -- 2.4 + + displayCabalVersion :: CabalSpecVersion -> String + displayCabalVersion v = case v of + CabalSpecV1_24 -> "1.24 (legacy)" + CabalSpecV2_0 -> "2.0 (+ support for Backpack, internal sub-libs, '^>=' operator)" + CabalSpecV2_2 -> "2.2 (+ support for 'common', 'elif', redundant commas, SPDX)" + CabalSpecV2_4 -> "2.4 (+ support for '**' globbing)" + CabalSpecV3_0 -> "3.0 (+ set notation for ==, common stanzas in ifs, more redundant commas, better pkgconfig-depends)" + CabalSpecV3_4 -> "3.4 (+ sublibraries in 'mixins', optional 'default-language')" + _ -> showCabalSpecVersion v + +packageNamePrompt :: Interactive m => SourcePackageDb -> InitFlags -> m PackageName +packageNamePrompt srcDb flags = getPackageName flags $ do + defName <- case packageDir flags of + Flag b -> filePathToPkgName b + NoFlag -> currentDirPkgName + + go $ DefaultPrompt defName + where + go defName = prompt "Package name" defName >>= \n -> + if isPkgRegistered n + then do + don'tUseName <- promptYesNo (promptOtherNameMsg n) (DefaultPrompt True) + if don'tUseName + then go defName + else return n + else return n + + isPkgRegistered = elemByPackageName (packageIndex srcDb) + + inUseMsg pn = "The name " + ++ unPackageName pn + ++ " is already in use by another package on Hackage." + + promptOtherNameMsg pn = inUseMsg pn ++ " Do you want to choose a different name (y/n)" + +versionPrompt :: Interactive m => InitFlags -> m Version +versionPrompt flags = getVersion flags go + where + go = do + vv <- promptStr "Package version" (DefaultPrompt $ prettyShow defaultVersion) + case simpleParsec vv of + Nothing -> do + putStrLn + $ "Version must be a valid PVP format (e.g. 0.1.0.0): " + ++ vv + go + Just v -> return v + +licensePrompt :: Interactive m => InitFlags -> m SpecLicense +licensePrompt flags = getLicense flags $ do + let csv = fromFlagOrDefault defaultCabalVersion (cabalVersion flags) + l <- promptList "Please choose a license" + (licenses csv) + MandatoryPrompt + Nothing + True + + case simpleParsec' csv l of + Nothing -> do + putStrLn ( "The license must be a valid SPDX expression:" + ++ "\n - On the SPDX License List: https://spdx.org/licenses/" + ++ "\n - NONE, if you do not want to grant any license" + ++ "\n - LicenseRef-( alphanumeric | - | . )+" + ) + licensePrompt flags + Just l' -> return l' + where + licenses csv = if csv >= CabalSpecV2_2 + then SPDX.licenseId <$> defaultLicenseIds + else fmap prettyShow knownLicenses + +authorPrompt :: Interactive m => InitFlags -> m String +authorPrompt flags = getAuthor flags $ do + name <- guessAuthorName + promptStr "Author name" (DefaultPrompt name) + +emailPrompt :: Interactive m => InitFlags -> m String +emailPrompt flags = getEmail flags $ do + email' <- guessAuthorEmail + promptStr "Maintainer email" (DefaultPrompt email') + +homepagePrompt :: Interactive m => InitFlags -> m String +homepagePrompt flags = getHomepage flags $ + promptStr "Project homepage URL" OptionalPrompt + +synopsisPrompt :: Interactive m => InitFlags -> m String +synopsisPrompt flags = getSynopsis flags $ + promptStr "Project synopsis" OptionalPrompt + +categoryPrompt :: Interactive m => InitFlags -> m String +categoryPrompt flags = getCategory flags $ promptList + "Project category" defaultCategories + (DefaultPrompt "") (Just matchNone) True + where + matchNone s + | null s = "(none)" + | otherwise = s + +mainFilePrompt :: Interactive m => InitFlags -> m HsFilePath +mainFilePrompt flags = getMainFile flags go + where + defaultMainIs' = show defaultMainIs + go = do + fp <- promptList "What is the main module of the executable" + [defaultMainIs', "Main.lhs"] + (DefaultPrompt defaultMainIs') + Nothing + True + + let hs = toHsFilePath fp + + case _hsFileType hs of + InvalidHsPath -> do + putStrLn $ concat + [ "Main file " + , show hs + , " is not a valid haskell file. Source files must end in .hs or .lhs." + ] + go + + _ -> return hs + +testDirsPrompt :: Interactive m => InitFlags -> m [String] +testDirsPrompt flags = getTestDirs flags $ do + dir <- promptStr "Test directory" (DefaultPrompt defaultTestDir) + return [dir] + +languagePrompt :: Interactive m => InitFlags -> String -> m Language +languagePrompt flags pkgType = getLanguage flags $ do + let h2010 = "Haskell2010" + h98 = "Haskell98" + ghc2021 = "GHC2021 (requires at least GHC 9.2)" + + l <- promptList ("Choose a language for your " ++ pkgType) + [h2010, h98, ghc2021] + (DefaultPrompt h2010) + Nothing + True + + if + | l == h2010 -> return Haskell2010 + | l == h98 -> return Haskell98 + | l == ghc2021 -> return GHC2021 + | all isAlphaNum l -> return $ UnknownLanguage l + | otherwise -> do + putStrLn + $ "\nThe language must be alphanumeric. " + ++ "Please enter a different language." + + languagePrompt flags pkgType + +noCommentsPrompt :: Interactive m => InitFlags -> m Bool +noCommentsPrompt flags = getNoComments flags $ do + doComments <- promptYesNo + "Add informative comments to each field in the cabal file. (y/n)" + (DefaultPrompt True) + + -- + -- if --no-comments is flagged, then we choose not to generate comments + -- for fields in the cabal file, but it's a nicer UX to present the + -- affirmative question which must be negated. + -- + + return (not doComments) + +-- | Ask for the application root directory. +appDirsPrompt :: Interactive m => InitFlags -> m [String] +appDirsPrompt flags = getAppDirs flags $ do + dir <- promptList promptMsg + [defaultApplicationDir, "exe", "src-exe"] + (DefaultPrompt defaultApplicationDir) + Nothing + True + + return [dir] + where + promptMsg = case mainIs flags of + Flag p -> "Application (" ++ p ++ ") directory" + NoFlag -> "Application directory" + +-- | Ask for the source (library) root directory. +srcDirsPrompt :: Interactive m => InitFlags -> m [String] +srcDirsPrompt flags = getSrcDirs flags $ do + dir <- promptList "Library source directory" + [defaultSourceDir, "lib", "src-lib"] + (DefaultPrompt defaultSourceDir) + Nothing + True + + return [dir] diff --git a/cabal/cabal-install/src/Distribution/Client/Init/Licenses.hs b/cabal/cabal-install/src/Distribution/Client/Init/Licenses.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Init/Licenses.hs @@ -0,0 +1,3077 @@ +{-| +Module : Distribution.Client.Init.Licenses + +Description : Factory functions for producing known license types. + +License : BSD-like +Maintainer : cabal-devel@haskell.org +Stability : provisional +Portability : portable +-} +module Distribution.Client.Init.Licenses + ( License + , bsd2 + , bsd3 + , gplv2 + , gplv3 + , lgpl21 + , lgpl3 + , agplv3 + , apache20 + , mit + , mpl20 + , isc + ) where + +import Prelude (String, unlines, (++)) + +type License = String + +bsd2 :: String -> String -> License +bsd2 authors year = unlines + [ "Copyright (c) " ++ year ++ ", " ++ authors + , "All rights reserved." + , "" + , "Redistribution and use in source and binary forms, with or without" + , "modification, are permitted provided that the following conditions are" + , "met:" + , "" + , "1. Redistributions of source code must retain the above copyright" + , " notice, this list of conditions and the following disclaimer." + , "" + , "2. Redistributions in binary form must reproduce the above copyright" + , " notice, this list of conditions and the following disclaimer in the" + , " documentation and/or other materials provided with the" + , " distribution." + , "" + , "THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS" + , "\"AS IS\" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT" + , "LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR" + , "A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT" + , "OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL," + , "SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT" + , "LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE," + , "DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY" + , "THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT" + , "(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE" + , "OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE." + ] + +bsd3 :: String -> String -> License +bsd3 authors year = unlines + [ "Copyright (c) " ++ year ++ ", " ++ authors + , "" + , "All rights reserved." + , "" + , "Redistribution and use in source and binary forms, with or without" + , "modification, are permitted provided that the following conditions are met:" + , "" + , " * Redistributions of source code must retain the above copyright" + , " notice, this list of conditions and the following disclaimer." + , "" + , " * Redistributions in binary form must reproduce the above" + , " copyright notice, this list of conditions and the following" + , " disclaimer in the documentation and/or other materials provided" + , " with the distribution." + , "" + , " * Neither the name of " ++ authors ++ " nor the names of other" + , " contributors may be used to endorse or promote products derived" + , " from this software without specific prior written permission." + , "" + , "THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS" + , "\"AS IS\" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT" + , "LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR" + , "A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT" + , "OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL," + , "SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT" + , "LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE," + , "DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY" + , "THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT" + , "(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE" + , "OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE." + ] + +gplv2 :: License +gplv2 = unlines + [ " GNU GENERAL PUBLIC LICENSE" + , " Version 2, June 1991" + , "" + , " Copyright (C) 1989, 1991 Free Software Foundation, Inc.," + , " 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA" + , " Everyone is permitted to copy and distribute verbatim copies" + , " of this license document, but changing it is not allowed." + , "" + , " Preamble" + , "" + , " The licenses for most software are designed to take away your" + , "freedom to share and change it. By contrast, the GNU General Public" + , "License is intended to guarantee your freedom to share and change free" + , "software--to make sure the software is free for all its users. This" + , "General Public License applies to most of the Free Software" + , "Foundation's software and to any other program whose authors commit to" + , "using it. (Some other Free Software Foundation software is covered by" + , "the GNU Lesser General Public License instead.) You can apply it to" + , "your programs, too." + , "" + , " When we speak of free software, we are referring to freedom, not" + , "price. Our General Public Licenses are designed to make sure that you" + , "have the freedom to distribute copies of free software (and charge for" + , "this service if you wish), that you receive source code or can get it" + , "if you want it, that you can change the software or use pieces of it" + , "in new free programs; and that you know you can do these things." + , "" + , " To protect your rights, we need to make restrictions that forbid" + , "anyone to deny you these rights or to ask you to surrender the rights." + , "These restrictions translate to certain responsibilities for you if you" + , "distribute copies of the software, or if you modify it." + , "" + , " For example, if you distribute copies of such a program, whether" + , "gratis or for a fee, you must give the recipients all the rights that" + , "you have. You must make sure that they, too, receive or can get the" + , "source code. And you must show them these terms so they know their" + , "rights." + , "" + , " We protect your rights with two steps: (1) copyright the software, and" + , "(2) offer you this license which gives you legal permission to copy," + , "distribute and/or modify the software." + , "" + , " Also, for each author's protection and ours, we want to make certain" + , "that everyone understands that there is no warranty for this free" + , "software. If the software is modified by someone else and passed on, we" + , "want its recipients to know that what they have is not the original, so" + , "that any problems introduced by others will not reflect on the original" + , "authors' reputations." + , "" + , " Finally, any free program is threatened constantly by software" + , "patents. We wish to avoid the danger that redistributors of a free" + , "program will individually obtain patent licenses, in effect making the" + , "program proprietary. To prevent this, we have made it clear that any" + , "patent must be licensed for everyone's free use or not licensed at all." + , "" + , " The precise terms and conditions for copying, distribution and" + , "modification follow." + , "" + , " GNU GENERAL PUBLIC LICENSE" + , " TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION" + , "" + , " 0. This License applies to any program or other work which contains" + , "a notice placed by the copyright holder saying it may be distributed" + , "under the terms of this General Public License. The \"Program\", below," + , "refers to any such program or work, and a \"work based on the Program\"" + , "means either the Program or any derivative work under copyright law:" + , "that is to say, a work containing the Program or a portion of it," + , "either verbatim or with modifications and/or translated into another" + , "language. (Hereinafter, translation is included without limitation in" + , "the term \"modification\".) Each licensee is addressed as \"you\"." + , "" + , "Activities other than copying, distribution and modification are not" + , "covered by this License; they are outside its scope. The act of" + , "running the Program is not restricted, and the output from the Program" + , "is covered only if its contents constitute a work based on the" + , "Program (independent of having been made by running the Program)." + , "Whether that is true depends on what the Program does." + , "" + , " 1. You may copy and distribute verbatim copies of the Program's" + , "source code as you receive it, in any medium, provided that you" + , "conspicuously and appropriately publish on each copy an appropriate" + , "copyright notice and disclaimer of warranty; keep intact all the" + , "notices that refer to this License and to the absence of any warranty;" + , "and give any other recipients of the Program a copy of this License" + , "along with the Program." + , "" + , "You may charge a fee for the physical act of transferring a copy, and" + , "you may at your option offer warranty protection in exchange for a fee." + , "" + , " 2. You may modify your copy or copies of the Program or any portion" + , "of it, thus forming a work based on the Program, and copy and" + , "distribute such modifications or work under the terms of Section 1" + , "above, provided that you also meet all of these conditions:" + , "" + , " a) You must cause the modified files to carry prominent notices" + , " stating that you changed the files and the date of any change." + , "" + , " b) You must cause any work that you distribute or publish, that in" + , " whole or in part contains or is derived from the Program or any" + , " part thereof, to be licensed as a whole at no charge to all third" + , " parties under the terms of this License." + , "" + , " c) If the modified program normally reads commands interactively" + , " when run, you must cause it, when started running for such" + , " interactive use in the most ordinary way, to print or display an" + , " announcement including an appropriate copyright notice and a" + , " notice that there is no warranty (or else, saying that you provide" + , " a warranty) and that users may redistribute the program under" + , " these conditions, and telling the user how to view a copy of this" + , " License. (Exception: if the Program itself is interactive but" + , " does not normally print such an announcement, your work based on" + , " the Program is not required to print an announcement.)" + , "" + , "These requirements apply to the modified work as a whole. If" + , "identifiable sections of that work are not derived from the Program," + , "and can be reasonably considered independent and separate works in" + , "themselves, then this License, and its terms, do not apply to those" + , "sections when you distribute them as separate works. But when you" + , "distribute the same sections as part of a whole which is a work based" + , "on the Program, the distribution of the whole must be on the terms of" + , "this License, whose permissions for other licensees extend to the" + , "entire whole, and thus to each and every part regardless of who wrote it." + , "" + , "Thus, it is not the intent of this section to claim rights or contest" + , "your rights to work written entirely by you; rather, the intent is to" + , "exercise the right to control the distribution of derivative or" + , "collective works based on the Program." + , "" + , "In addition, mere aggregation of another work not based on the Program" + , "with the Program (or with a work based on the Program) on a volume of" + , "a storage or distribution medium does not bring the other work under" + , "the scope of this License." + , "" + , " 3. You may copy and distribute the Program (or a work based on it," + , "under Section 2) in object code or executable form under the terms of" + , "Sections 1 and 2 above provided that you also do one of the following:" + , "" + , " a) Accompany it with the complete corresponding machine-readable" + , " source code, which must be distributed under the terms of Sections" + , " 1 and 2 above on a medium customarily used for software interchange; or," + , "" + , " b) Accompany it with a written offer, valid for at least three" + , " years, to give any third party, for a charge no more than your" + , " cost of physically performing source distribution, a complete" + , " machine-readable copy of the corresponding source code, to be" + , " distributed under the terms of Sections 1 and 2 above on a medium" + , " customarily used for software interchange; or," + , "" + , " c) Accompany it with the information you received as to the offer" + , " to distribute corresponding source code. (This alternative is" + , " allowed only for noncommercial distribution and only if you" + , " received the program in object code or executable form with such" + , " an offer, in accord with Subsection b above.)" + , "" + , "The source code for a work means the preferred form of the work for" + , "making modifications to it. For an executable work, complete source" + , "code means all the source code for all modules it contains, plus any" + , "associated interface definition files, plus the scripts used to" + , "control compilation and installation of the executable. However, as a" + , "special exception, the source code distributed need not include" + , "anything that is normally distributed (in either source or binary" + , "form) with the major components (compiler, kernel, and so on) of the" + , "operating system on which the executable runs, unless that component" + , "itself accompanies the executable." + , "" + , "If distribution of executable or object code is made by offering" + , "access to copy from a designated place, then offering equivalent" + , "access to copy the source code from the same place counts as" + , "distribution of the source code, even though third parties are not" + , "compelled to copy the source along with the object code." + , "" + , " 4. You may not copy, modify, sublicense, or distribute the Program" + , "except as expressly provided under this License. Any attempt" + , "otherwise to copy, modify, sublicense or distribute the Program is" + , "void, and will automatically terminate your rights under this License." + , "However, parties who have received copies, or rights, from you under" + , "this License will not have their licenses terminated so long as such" + , "parties remain in full compliance." + , "" + , " 5. You are not required to accept this License, since you have not" + , "signed it. However, nothing else grants you permission to modify or" + , "distribute the Program or its derivative works. These actions are" + , "prohibited by law if you do not accept this License. Therefore, by" + , "modifying or distributing the Program (or any work based on the" + , "Program), you indicate your acceptance of this License to do so, and" + , "all its terms and conditions for copying, distributing or modifying" + , "the Program or works based on it." + , "" + , " 6. Each time you redistribute the Program (or any work based on the" + , "Program), the recipient automatically receives a license from the" + , "original licensor to copy, distribute or modify the Program subject to" + , "these terms and conditions. You may not impose any further" + , "restrictions on the recipients' exercise of the rights granted herein." + , "You are not responsible for enforcing compliance by third parties to" + , "this License." + , "" + , " 7. If, as a consequence of a court judgment or allegation of patent" + , "infringement or for any other reason (not limited to patent issues)," + , "conditions are imposed on you (whether by court order, agreement or" + , "otherwise) that contradict the conditions of this License, they do not" + , "excuse you from the conditions of this License. If you cannot" + , "distribute so as to satisfy simultaneously your obligations under this" + , "License and any other pertinent obligations, then as a consequence you" + , "may not distribute the Program at all. For example, if a patent" + , "license would not permit royalty-free redistribution of the Program by" + , "all those who receive copies directly or indirectly through you, then" + , "the only way you could satisfy both it and this License would be to" + , "refrain entirely from distribution of the Program." + , "" + , "If any portion of this section is held invalid or unenforceable under" + , "any particular circumstance, the balance of the section is intended to" + , "apply and the section as a whole is intended to apply in other" + , "circumstances." + , "" + , "It is not the purpose of this section to induce you to infringe any" + , "patents or other property right claims or to contest validity of any" + , "such claims; this section has the sole purpose of protecting the" + , "integrity of the free software distribution system, which is" + , "implemented by public license practices. Many people have made" + , "generous contributions to the wide range of software distributed" + , "through that system in reliance on consistent application of that" + , "system; it is up to the author/donor to decide if he or she is willing" + , "to distribute software through any other system and a licensee cannot" + , "impose that choice." + , "" + , "This section is intended to make thoroughly clear what is believed to" + , "be a consequence of the rest of this License." + , "" + , " 8. If the distribution and/or use of the Program is restricted in" + , "certain countries either by patents or by copyrighted interfaces, the" + , "original copyright holder who places the Program under this License" + , "may add an explicit geographical distribution limitation excluding" + , "those countries, so that distribution is permitted only in or among" + , "countries not thus excluded. In such case, this License incorporates" + , "the limitation as if written in the body of this License." + , "" + , " 9. The Free Software Foundation may publish revised and/or new versions" + , "of the General Public License from time to time. Such new versions will" + , "be similar in spirit to the present version, but may differ in detail to" + , "address new problems or concerns." + , "" + , "Each version is given a distinguishing version number. If the Program" + , "specifies a version number of this License which applies to it and \"any" + , "later version\", you have the option of following the terms and conditions" + , "either of that version or of any later version published by the Free" + , "Software Foundation. If the Program does not specify a version number of" + , "this License, you may choose any version ever published by the Free Software" + , "Foundation." + , "" + , " 10. If you wish to incorporate parts of the Program into other free" + , "programs whose distribution conditions are different, write to the author" + , "to ask for permission. For software which is copyrighted by the Free" + , "Software Foundation, write to the Free Software Foundation; we sometimes" + , "make exceptions for this. Our decision will be guided by the two goals" + , "of preserving the free status of all derivatives of our free software and" + , "of promoting the sharing and reuse of software generally." + , "" + , " NO WARRANTY" + , "" + , " 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY" + , "FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN" + , "OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES" + , "PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED" + , "OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF" + , "MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS" + , "TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE" + , "PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING," + , "REPAIR OR CORRECTION." + , "" + , " 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING" + , "WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR" + , "REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES," + , "INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING" + , "OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED" + , "TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY" + , "YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER" + , "PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE" + , "POSSIBILITY OF SUCH DAMAGES." + , "" + , " END OF TERMS AND CONDITIONS" + , "" + , " How to Apply These Terms to Your New Programs" + , "" + , " If you develop a new program, and you want it to be of the greatest" + , "possible use to the public, the best way to achieve this is to make it" + , "free software which everyone can redistribute and change under these terms." + , "" + , " To do so, attach the following notices to the program. It is safest" + , "to attach them to the start of each source file to most effectively" + , "convey the exclusion of warranty; and each file should have at least" + , "the \"copyright\" line and a pointer to where the full notice is found." + , "" + , " " + , " Copyright (C) " + , "" + , " This program is free software; you can redistribute it and/or modify" + , " it under the terms of the GNU General Public License as published by" + , " the Free Software Foundation; either version 2 of the License, or" + , " (at your option) any later version." + , "" + , " This program is distributed in the hope that it will be useful," + , " but WITHOUT ANY WARRANTY; without even the implied warranty of" + , " MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the" + , " GNU General Public License for more details." + , "" + , " You should have received a copy of the GNU General Public License along" + , " with this program; if not, write to the Free Software Foundation, Inc.," + , " 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA." + , "" + , "Also add information on how to contact you by electronic and paper mail." + , "" + , "If the program is interactive, make it output a short notice like this" + , "when it starts in an interactive mode:" + , "" + , " Gnomovision version 69, Copyright (C) year name of author" + , " Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'." + , " This is free software, and you are welcome to redistribute it" + , " under certain conditions; type `show c' for details." + , "" + , "The hypothetical commands `show w' and `show c' should show the appropriate" + , "parts of the General Public License. Of course, the commands you use may" + , "be called something other than `show w' and `show c'; they could even be" + , "mouse-clicks or menu items--whatever suits your program." + , "" + , "You should also get your employer (if you work as a programmer) or your" + , "school, if any, to sign a \"copyright disclaimer\" for the program, if" + , "necessary. Here is a sample; alter the names:" + , "" + , " Yoyodyne, Inc., hereby disclaims all copyright interest in the program" + , " `Gnomovision' (which makes passes at compilers) written by James Hacker." + , "" + , " , 1 April 1989" + , " Ty Coon, President of Vice" + , "" + , "This General Public License does not permit incorporating your program into" + , "proprietary programs. If your program is a subroutine library, you may" + , "consider it more useful to permit linking proprietary applications with the" + , "library. If this is what you want to do, use the GNU Lesser General" + , "Public License instead of this License." + ] + +gplv3 :: License +gplv3 = unlines + [ " GNU GENERAL PUBLIC LICENSE" + , " Version 3, 29 June 2007" + , "" + , " Copyright (C) 2007 Free Software Foundation, Inc. " + , " Everyone is permitted to copy and distribute verbatim copies" + , " of this license document, but changing it is not allowed." + , "" + , " Preamble" + , "" + , " The GNU General Public License is a free, copyleft license for" + , "software and other kinds of works." + , "" + , " The licenses for most software and other practical works are designed" + , "to take away your freedom to share and change the works. By contrast," + , "the GNU General Public License is intended to guarantee your freedom to" + , "share and change all versions of a program--to make sure it remains free" + , "software for all its users. We, the Free Software Foundation, use the" + , "GNU General Public License for most of our software; it applies also to" + , "any other work released this way by its authors. You can apply it to" + , "your programs, too." + , "" + , " When we speak of free software, we are referring to freedom, not" + , "price. Our General Public Licenses are designed to make sure that you" + , "have the freedom to distribute copies of free software (and charge for" + , "them if you wish), that you receive source code or can get it if you" + , "want it, that you can change the software or use pieces of it in new" + , "free programs, and that you know you can do these things." + , "" + , " To protect your rights, we need to prevent others from denying you" + , "these rights or asking you to surrender the rights. Therefore, you have" + , "certain responsibilities if you distribute copies of the software, or if" + , "you modify it: responsibilities to respect the freedom of others." + , "" + , " For example, if you distribute copies of such a program, whether" + , "gratis or for a fee, you must pass on to the recipients the same" + , "freedoms that you received. You must make sure that they, too, receive" + , "or can get the source code. And you must show them these terms so they" + , "know their rights." + , "" + , " Developers that use the GNU GPL protect your rights with two steps:" + , "(1) assert copyright on the software, and (2) offer you this License" + , "giving you legal permission to copy, distribute and/or modify it." + , "" + , " For the developers' and authors' protection, the GPL clearly explains" + , "that there is no warranty for this free software. For both users' and" + , "authors' sake, the GPL requires that modified versions be marked as" + , "changed, so that their problems will not be attributed erroneously to" + , "authors of previous versions." + , "" + , " Some devices are designed to deny users access to install or run" + , "modified versions of the software inside them, although the manufacturer" + , "can do so. This is fundamentally incompatible with the aim of" + , "protecting users' freedom to change the software. The systematic" + , "pattern of such abuse occurs in the area of products for individuals to" + , "use, which is precisely where it is most unacceptable. Therefore, we" + , "have designed this version of the GPL to prohibit the practice for those" + , "products. If such problems arise substantially in other domains, we" + , "stand ready to extend this provision to those domains in future versions" + , "of the GPL, as needed to protect the freedom of users." + , "" + , " Finally, every program is threatened constantly by software patents." + , "States should not allow patents to restrict development and use of" + , "software on general-purpose computers, but in those that do, we wish to" + , "avoid the special danger that patents applied to a free program could" + , "make it effectively proprietary. To prevent this, the GPL assures that" + , "patents cannot be used to render the program non-free." + , "" + , " The precise terms and conditions for copying, distribution and" + , "modification follow." + , "" + , " TERMS AND CONDITIONS" + , "" + , " 0. Definitions." + , "" + , " \"This License\" refers to version 3 of the GNU General Public License." + , "" + , " \"Copyright\" also means copyright-like laws that apply to other kinds of" + , "works, such as semiconductor masks." + , "" + , " \"The Program\" refers to any copyrightable work licensed under this" + , "License. Each licensee is addressed as \"you\". \"Licensees\" and" + , "\"recipients\" may be individuals or organizations." + , "" + , " To \"modify\" a work means to copy from or adapt all or part of the work" + , "in a fashion requiring copyright permission, other than the making of an" + , "exact copy. The resulting work is called a \"modified version\" of the" + , "earlier work or a work \"based on\" the earlier work." + , "" + , " A \"covered work\" means either the unmodified Program or a work based" + , "on the Program." + , "" + , " To \"propagate\" a work means to do anything with it that, without" + , "permission, would make you directly or secondarily liable for" + , "infringement under applicable copyright law, except executing it on a" + , "computer or modifying a private copy. Propagation includes copying," + , "distribution (with or without modification), making available to the" + , "public, and in some countries other activities as well." + , "" + , " To \"convey\" a work means any kind of propagation that enables other" + , "parties to make or receive copies. Mere interaction with a user through" + , "a computer network, with no transfer of a copy, is not conveying." + , "" + , " An interactive user interface displays \"Appropriate Legal Notices\"" + , "to the extent that it includes a convenient and prominently visible" + , "feature that (1) displays an appropriate copyright notice, and (2)" + , "tells the user that there is no warranty for the work (except to the" + , "extent that warranties are provided), that licensees may convey the" + , "work under this License, and how to view a copy of this License. If" + , "the interface presents a list of user commands or options, such as a" + , "menu, a prominent item in the list meets this criterion." + , "" + , " 1. Source Code." + , "" + , " The \"source code\" for a work means the preferred form of the work" + , "for making modifications to it. \"Object code\" means any non-source" + , "form of a work." + , "" + , " A \"Standard Interface\" means an interface that either is an official" + , "standard defined by a recognized standards body, or, in the case of" + , "interfaces specified for a particular programming language, one that" + , "is widely used among developers working in that language." + , "" + , " The \"System Libraries\" of an executable work include anything, other" + , "than the work as a whole, that (a) is included in the normal form of" + , "packaging a Major Component, but which is not part of that Major" + , "Component, and (b) serves only to enable use of the work with that" + , "Major Component, or to implement a Standard Interface for which an" + , "implementation is available to the public in source code form. A" + , "\"Major Component\", in this context, means a major essential component" + , "(kernel, window system, and so on) of the specific operating system" + , "(if any) on which the executable work runs, or a compiler used to" + , "produce the work, or an object code interpreter used to run it." + , "" + , " The \"Corresponding Source\" for a work in object code form means all" + , "the source code needed to generate, install, and (for an executable" + , "work) run the object code and to modify the work, including scripts to" + , "control those activities. However, it does not include the work's" + , "System Libraries, or general-purpose tools or generally available free" + , "programs which are used unmodified in performing those activities but" + , "which are not part of the work. For example, Corresponding Source" + , "includes interface definition files associated with source files for" + , "the work, and the source code for shared libraries and dynamically" + , "linked subprograms that the work is specifically designed to require," + , "such as by intimate data communication or control flow between those" + , "subprograms and other parts of the work." + , "" + , " The Corresponding Source need not include anything that users" + , "can regenerate automatically from other parts of the Corresponding" + , "Source." + , "" + , " The Corresponding Source for a work in source code form is that" + , "same work." + , "" + , " 2. Basic Permissions." + , "" + , " All rights granted under this License are granted for the term of" + , "copyright on the Program, and are irrevocable provided the stated" + , "conditions are met. This License explicitly affirms your unlimited" + , "permission to run the unmodified Program. The output from running a" + , "covered work is covered by this License only if the output, given its" + , "content, constitutes a covered work. This License acknowledges your" + , "rights of fair use or other equivalent, as provided by copyright law." + , "" + , " You may make, run and propagate covered works that you do not" + , "convey, without conditions so long as your license otherwise remains" + , "in force. You may convey covered works to others for the sole purpose" + , "of having them make modifications exclusively for you, or provide you" + , "with facilities for running those works, provided that you comply with" + , "the terms of this License in conveying all material for which you do" + , "not control copyright. Those thus making or running the covered works" + , "for you must do so exclusively on your behalf, under your direction" + , "and control, on terms that prohibit them from making any copies of" + , "your copyrighted material outside their relationship with you." + , "" + , " Conveying under any other circumstances is permitted solely under" + , "the conditions stated below. Sublicensing is not allowed; section 10" + , "makes it unnecessary." + , "" + , " 3. Protecting Users' Legal Rights From Anti-Circumvention Law." + , "" + , " No covered work shall be deemed part of an effective technological" + , "measure under any applicable law fulfilling obligations under article" + , "11 of the WIPO copyright treaty adopted on 20 December 1996, or" + , "similar laws prohibiting or restricting circumvention of such" + , "measures." + , "" + , " When you convey a covered work, you waive any legal power to forbid" + , "circumvention of technological measures to the extent such circumvention" + , "is effected by exercising rights under this License with respect to" + , "the covered work, and you disclaim any intention to limit operation or" + , "modification of the work as a means of enforcing, against the work's" + , "users, your or third parties' legal rights to forbid circumvention of" + , "technological measures." + , "" + , " 4. Conveying Verbatim Copies." + , "" + , " You may convey verbatim copies of the Program's source code as you" + , "receive it, in any medium, provided that you conspicuously and" + , "appropriately publish on each copy an appropriate copyright notice;" + , "keep intact all notices stating that this License and any" + , "non-permissive terms added in accord with section 7 apply to the code;" + , "keep intact all notices of the absence of any warranty; and give all" + , "recipients a copy of this License along with the Program." + , "" + , " You may charge any price or no price for each copy that you convey," + , "and you may offer support or warranty protection for a fee." + , "" + , " 5. Conveying Modified Source Versions." + , "" + , " You may convey a work based on the Program, or the modifications to" + , "produce it from the Program, in the form of source code under the" + , "terms of section 4, provided that you also meet all of these conditions:" + , "" + , " a) The work must carry prominent notices stating that you modified" + , " it, and giving a relevant date." + , "" + , " b) The work must carry prominent notices stating that it is" + , " released under this License and any conditions added under section" + , " 7. This requirement modifies the requirement in section 4 to" + , " \"keep intact all notices\"." + , "" + , " c) You must license the entire work, as a whole, under this" + , " License to anyone who comes into possession of a copy. This" + , " License will therefore apply, along with any applicable section 7" + , " additional terms, to the whole of the work, and all its parts," + , " regardless of how they are packaged. This License gives no" + , " permission to license the work in any other way, but it does not" + , " invalidate such permission if you have separately received it." + , "" + , " d) If the work has interactive user interfaces, each must display" + , " Appropriate Legal Notices; however, if the Program has interactive" + , " interfaces that do not display Appropriate Legal Notices, your" + , " work need not make them do so." + , "" + , " A compilation of a covered work with other separate and independent" + , "works, which are not by their nature extensions of the covered work," + , "and which are not combined with it such as to form a larger program," + , "in or on a volume of a storage or distribution medium, is called an" + , "\"aggregate\" if the compilation and its resulting copyright are not" + , "used to limit the access or legal rights of the compilation's users" + , "beyond what the individual works permit. Inclusion of a covered work" + , "in an aggregate does not cause this License to apply to the other" + , "parts of the aggregate." + , "" + , " 6. Conveying Non-Source Forms." + , "" + , " You may convey a covered work in object code form under the terms" + , "of sections 4 and 5, provided that you also convey the" + , "machine-readable Corresponding Source under the terms of this License," + , "in one of these ways:" + , "" + , " a) Convey the object code in, or embodied in, a physical product" + , " (including a physical distribution medium), accompanied by the" + , " Corresponding Source fixed on a durable physical medium" + , " customarily used for software interchange." + , "" + , " b) Convey the object code in, or embodied in, a physical product" + , " (including a physical distribution medium), accompanied by a" + , " written offer, valid for at least three years and valid for as" + , " long as you offer spare parts or customer support for that product" + , " model, to give anyone who possesses the object code either (1) a" + , " copy of the Corresponding Source for all the software in the" + , " product that is covered by this License, on a durable physical" + , " medium customarily used for software interchange, for a price no" + , " more than your reasonable cost of physically performing this" + , " conveying of source, or (2) access to copy the" + , " Corresponding Source from a network server at no charge." + , "" + , " c) Convey individual copies of the object code with a copy of the" + , " written offer to provide the Corresponding Source. This" + , " alternative is allowed only occasionally and noncommercially, and" + , " only if you received the object code with such an offer, in accord" + , " with subsection 6b." + , "" + , " d) Convey the object code by offering access from a designated" + , " place (gratis or for a charge), and offer equivalent access to the" + , " Corresponding Source in the same way through the same place at no" + , " further charge. You need not require recipients to copy the" + , " Corresponding Source along with the object code. If the place to" + , " copy the object code is a network server, the Corresponding Source" + , " may be on a different server (operated by you or a third party)" + , " that supports equivalent copying facilities, provided you maintain" + , " clear directions next to the object code saying where to find the" + , " Corresponding Source. Regardless of what server hosts the" + , " Corresponding Source, you remain obligated to ensure that it is" + , " available for as long as needed to satisfy these requirements." + , "" + , " e) Convey the object code using peer-to-peer transmission, provided" + , " you inform other peers where the object code and Corresponding" + , " Source of the work are being offered to the general public at no" + , " charge under subsection 6d." + , "" + , " A separable portion of the object code, whose source code is excluded" + , "from the Corresponding Source as a System Library, need not be" + , "included in conveying the object code work." + , "" + , " A \"User Product\" is either (1) a \"consumer product\", which means any" + , "tangible personal property which is normally used for personal, family," + , "or household purposes, or (2) anything designed or sold for incorporation" + , "into a dwelling. In determining whether a product is a consumer product," + , "doubtful cases shall be resolved in favor of coverage. For a particular" + , "product received by a particular user, \"normally used\" refers to a" + , "typical or common use of that class of product, regardless of the status" + , "of the particular user or of the way in which the particular user" + , "actually uses, or expects or is expected to use, the product. A product" + , "is a consumer product regardless of whether the product has substantial" + , "commercial, industrial or non-consumer uses, unless such uses represent" + , "the only significant mode of use of the product." + , "" + , " \"Installation Information\" for a User Product means any methods," + , "procedures, authorization keys, or other information required to install" + , "and execute modified versions of a covered work in that User Product from" + , "a modified version of its Corresponding Source. The information must" + , "suffice to ensure that the continued functioning of the modified object" + , "code is in no case prevented or interfered with solely because" + , "modification has been made." + , "" + , " If you convey an object code work under this section in, or with, or" + , "specifically for use in, a User Product, and the conveying occurs as" + , "part of a transaction in which the right of possession and use of the" + , "User Product is transferred to the recipient in perpetuity or for a" + , "fixed term (regardless of how the transaction is characterized), the" + , "Corresponding Source conveyed under this section must be accompanied" + , "by the Installation Information. But this requirement does not apply" + , "if neither you nor any third party retains the ability to install" + , "modified object code on the User Product (for example, the work has" + , "been installed in ROM)." + , "" + , " The requirement to provide Installation Information does not include a" + , "requirement to continue to provide support service, warranty, or updates" + , "for a work that has been modified or installed by the recipient, or for" + , "the User Product in which it has been modified or installed. Access to a" + , "network may be denied when the modification itself materially and" + , "adversely affects the operation of the network or violates the rules and" + , "protocols for communication across the network." + , "" + , " Corresponding Source conveyed, and Installation Information provided," + , "in accord with this section must be in a format that is publicly" + , "documented (and with an implementation available to the public in" + , "source code form), and must require no special password or key for" + , "unpacking, reading or copying." + , "" + , " 7. Additional Terms." + , "" + , " \"Additional permissions\" are terms that supplement the terms of this" + , "License by making exceptions from one or more of its conditions." + , "Additional permissions that are applicable to the entire Program shall" + , "be treated as though they were included in this License, to the extent" + , "that they are valid under applicable law. If additional permissions" + , "apply only to part of the Program, that part may be used separately" + , "under those permissions, but the entire Program remains governed by" + , "this License without regard to the additional permissions." + , "" + , " When you convey a copy of a covered work, you may at your option" + , "remove any additional permissions from that copy, or from any part of" + , "it. (Additional permissions may be written to require their own" + , "removal in certain cases when you modify the work.) You may place" + , "additional permissions on material, added by you to a covered work," + , "for which you have or can give appropriate copyright permission." + , "" + , " Notwithstanding any other provision of this License, for material you" + , "add to a covered work, you may (if authorized by the copyright holders of" + , "that material) supplement the terms of this License with terms:" + , "" + , " a) Disclaiming warranty or limiting liability differently from the" + , " terms of sections 15 and 16 of this License; or" + , "" + , " b) Requiring preservation of specified reasonable legal notices or" + , " author attributions in that material or in the Appropriate Legal" + , " Notices displayed by works containing it; or" + , "" + , " c) Prohibiting misrepresentation of the origin of that material, or" + , " requiring that modified versions of such material be marked in" + , " reasonable ways as different from the original version; or" + , "" + , " d) Limiting the use for publicity purposes of names of licensors or" + , " authors of the material; or" + , "" + , " e) Declining to grant rights under trademark law for use of some" + , " trade names, trademarks, or service marks; or" + , "" + , " f) Requiring indemnification of licensors and authors of that" + , " material by anyone who conveys the material (or modified versions of" + , " it) with contractual assumptions of liability to the recipient, for" + , " any liability that these contractual assumptions directly impose on" + , " those licensors and authors." + , "" + , " All other non-permissive additional terms are considered \"further" + , "restrictions\" within the meaning of section 10. If the Program as you" + , "received it, or any part of it, contains a notice stating that it is" + , "governed by this License along with a term that is a further" + , "restriction, you may remove that term. If a license document contains" + , "a further restriction but permits relicensing or conveying under this" + , "License, you may add to a covered work material governed by the terms" + , "of that license document, provided that the further restriction does" + , "not survive such relicensing or conveying." + , "" + , " If you add terms to a covered work in accord with this section, you" + , "must place, in the relevant source files, a statement of the" + , "additional terms that apply to those files, or a notice indicating" + , "where to find the applicable terms." + , "" + , " Additional terms, permissive or non-permissive, may be stated in the" + , "form of a separately written license, or stated as exceptions;" + , "the above requirements apply either way." + , "" + , " 8. Termination." + , "" + , " You may not propagate or modify a covered work except as expressly" + , "provided under this License. Any attempt otherwise to propagate or" + , "modify it is void, and will automatically terminate your rights under" + , "this License (including any patent licenses granted under the third" + , "paragraph of section 11)." + , "" + , " However, if you cease all violation of this License, then your" + , "license from a particular copyright holder is reinstated (a)" + , "provisionally, unless and until the copyright holder explicitly and" + , "finally terminates your license, and (b) permanently, if the copyright" + , "holder fails to notify you of the violation by some reasonable means" + , "prior to 60 days after the cessation." + , "" + , " Moreover, your license from a particular copyright holder is" + , "reinstated permanently if the copyright holder notifies you of the" + , "violation by some reasonable means, this is the first time you have" + , "received notice of violation of this License (for any work) from that" + , "copyright holder, and you cure the violation prior to 30 days after" + , "your receipt of the notice." + , "" + , " Termination of your rights under this section does not terminate the" + , "licenses of parties who have received copies or rights from you under" + , "this License. If your rights have been terminated and not permanently" + , "reinstated, you do not qualify to receive new licenses for the same" + , "material under section 10." + , "" + , " 9. Acceptance Not Required for Having Copies." + , "" + , " You are not required to accept this License in order to receive or" + , "run a copy of the Program. Ancillary propagation of a covered work" + , "occurring solely as a consequence of using peer-to-peer transmission" + , "to receive a copy likewise does not require acceptance. However," + , "nothing other than this License grants you permission to propagate or" + , "modify any covered work. These actions infringe copyright if you do" + , "not accept this License. Therefore, by modifying or propagating a" + , "covered work, you indicate your acceptance of this License to do so." + , "" + , " 10. Automatic Licensing of Downstream Recipients." + , "" + , " Each time you convey a covered work, the recipient automatically" + , "receives a license from the original licensors, to run, modify and" + , "propagate that work, subject to this License. You are not responsible" + , "for enforcing compliance by third parties with this License." + , "" + , " An \"entity transaction\" is a transaction transferring control of an" + , "organization, or substantially all assets of one, or subdividing an" + , "organization, or merging organizations. If propagation of a covered" + , "work results from an entity transaction, each party to that" + , "transaction who receives a copy of the work also receives whatever" + , "licenses to the work the party's predecessor in interest had or could" + , "give under the previous paragraph, plus a right to possession of the" + , "Corresponding Source of the work from the predecessor in interest, if" + , "the predecessor has it or can get it with reasonable efforts." + , "" + , " You may not impose any further restrictions on the exercise of the" + , "rights granted or affirmed under this License. For example, you may" + , "not impose a license fee, royalty, or other charge for exercise of" + , "rights granted under this License, and you may not initiate litigation" + , "(including a cross-claim or counterclaim in a lawsuit) alleging that" + , "any patent claim is infringed by making, using, selling, offering for" + , "sale, or importing the Program or any portion of it." + , "" + , " 11. Patents." + , "" + , " A \"contributor\" is a copyright holder who authorizes use under this" + , "License of the Program or a work on which the Program is based. The" + , "work thus licensed is called the contributor's \"contributor version\"." + , "" + , " A contributor's \"essential patent claims\" are all patent claims" + , "owned or controlled by the contributor, whether already acquired or" + , "hereafter acquired, that would be infringed by some manner, permitted" + , "by this License, of making, using, or selling its contributor version," + , "but do not include claims that would be infringed only as a" + , "consequence of further modification of the contributor version. For" + , "purposes of this definition, \"control\" includes the right to grant" + , "patent sublicenses in a manner consistent with the requirements of" + , "this License." + , "" + , " Each contributor grants you a non-exclusive, worldwide, royalty-free" + , "patent license under the contributor's essential patent claims, to" + , "make, use, sell, offer for sale, import and otherwise run, modify and" + , "propagate the contents of its contributor version." + , "" + , " In the following three paragraphs, a \"patent license\" is any express" + , "agreement or commitment, however denominated, not to enforce a patent" + , "(such as an express permission to practice a patent or covenant not to" + , "sue for patent infringement). To \"grant\" such a patent license to a" + , "party means to make such an agreement or commitment not to enforce a" + , "patent against the party." + , "" + , " If you convey a covered work, knowingly relying on a patent license," + , "and the Corresponding Source of the work is not available for anyone" + , "to copy, free of charge and under the terms of this License, through a" + , "publicly available network server or other readily accessible means," + , "then you must either (1) cause the Corresponding Source to be so" + , "available, or (2) arrange to deprive yourself of the benefit of the" + , "patent license for this particular work, or (3) arrange, in a manner" + , "consistent with the requirements of this License, to extend the patent" + , "license to downstream recipients. \"Knowingly relying\" means you have" + , "actual knowledge that, but for the patent license, your conveying the" + , "covered work in a country, or your recipient's use of the covered work" + , "in a country, would infringe one or more identifiable patents in that" + , "country that you have reason to believe are valid." + , "" + , " If, pursuant to or in connection with a single transaction or" + , "arrangement, you convey, or propagate by procuring conveyance of, a" + , "covered work, and grant a patent license to some of the parties" + , "receiving the covered work authorizing them to use, propagate, modify" + , "or convey a specific copy of the covered work, then the patent license" + , "you grant is automatically extended to all recipients of the covered" + , "work and works based on it." + , "" + , " A patent license is \"discriminatory\" if it does not include within" + , "the scope of its coverage, prohibits the exercise of, or is" + , "conditioned on the non-exercise of one or more of the rights that are" + , "specifically granted under this License. You may not convey a covered" + , "work if you are a party to an arrangement with a third party that is" + , "in the business of distributing software, under which you make payment" + , "to the third party based on the extent of your activity of conveying" + , "the work, and under which the third party grants, to any of the" + , "parties who would receive the covered work from you, a discriminatory" + , "patent license (a) in connection with copies of the covered work" + , "conveyed by you (or copies made from those copies), or (b) primarily" + , "for and in connection with specific products or compilations that" + , "contain the covered work, unless you entered into that arrangement," + , "or that patent license was granted, prior to 28 March 2007." + , "" + , " Nothing in this License shall be construed as excluding or limiting" + , "any implied license or other defenses to infringement that may" + , "otherwise be available to you under applicable patent law." + , "" + , " 12. No Surrender of Others' Freedom." + , "" + , " If conditions are imposed on you (whether by court order, agreement or" + , "otherwise) that contradict the conditions of this License, they do not" + , "excuse you from the conditions of this License. If you cannot convey a" + , "covered work so as to satisfy simultaneously your obligations under this" + , "License and any other pertinent obligations, then as a consequence you may" + , "not convey it at all. For example, if you agree to terms that obligate you" + , "to collect a royalty for further conveying from those to whom you convey" + , "the Program, the only way you could satisfy both those terms and this" + , "License would be to refrain entirely from conveying the Program." + , "" + , " 13. Use with the GNU Affero General Public License." + , "" + , " Notwithstanding any other provision of this License, you have" + , "permission to link or combine any covered work with a work licensed" + , "under version 3 of the GNU Affero General Public License into a single" + , "combined work, and to convey the resulting work. The terms of this" + , "License will continue to apply to the part which is the covered work," + , "but the special requirements of the GNU Affero General Public License," + , "section 13, concerning interaction through a network will apply to the" + , "combination as such." + , "" + , " 14. Revised Versions of this License." + , "" + , " The Free Software Foundation may publish revised and/or new versions of" + , "the GNU General Public License from time to time. Such new versions will" + , "be similar in spirit to the present version, but may differ in detail to" + , "address new problems or concerns." + , "" + , " Each version is given a distinguishing version number. If the" + , "Program specifies that a certain numbered version of the GNU General" + , "Public License \"or any later version\" applies to it, you have the" + , "option of following the terms and conditions either of that numbered" + , "version or of any later version published by the Free Software" + , "Foundation. If the Program does not specify a version number of the" + , "GNU General Public License, you may choose any version ever published" + , "by the Free Software Foundation." + , "" + , " If the Program specifies that a proxy can decide which future" + , "versions of the GNU General Public License can be used, that proxy's" + , "public statement of acceptance of a version permanently authorizes you" + , "to choose that version for the Program." + , "" + , " Later license versions may give you additional or different" + , "permissions. However, no additional obligations are imposed on any" + , "author or copyright holder as a result of your choosing to follow a" + , "later version." + , "" + , " 15. Disclaimer of Warranty." + , "" + , " THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY" + , "APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT" + , "HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY" + , "OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO," + , "THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR" + , "PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM" + , "IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF" + , "ALL NECESSARY SERVICING, REPAIR OR CORRECTION." + , "" + , " 16. Limitation of Liability." + , "" + , " IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING" + , "WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS" + , "THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY" + , "GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE" + , "USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF" + , "DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD" + , "PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS)," + , "EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF" + , "SUCH DAMAGES." + , "" + , " 17. Interpretation of Sections 15 and 16." + , "" + , " If the disclaimer of warranty and limitation of liability provided" + , "above cannot be given local legal effect according to their terms," + , "reviewing courts shall apply local law that most closely approximates" + , "an absolute waiver of all civil liability in connection with the" + , "Program, unless a warranty or assumption of liability accompanies a" + , "copy of the Program in return for a fee." + , "" + , " END OF TERMS AND CONDITIONS" + , "" + , " How to Apply These Terms to Your New Programs" + , "" + , " If you develop a new program, and you want it to be of the greatest" + , "possible use to the public, the best way to achieve this is to make it" + , "free software which everyone can redistribute and change under these terms." + , "" + , " To do so, attach the following notices to the program. It is safest" + , "to attach them to the start of each source file to most effectively" + , "state the exclusion of warranty; and each file should have at least" + , "the \"copyright\" line and a pointer to where the full notice is found." + , "" + , " " + , " Copyright (C) " + , "" + , " This program is free software: you can redistribute it and/or modify" + , " it under the terms of the GNU General Public License as published by" + , " the Free Software Foundation, either version 3 of the License, or" + , " (at your option) any later version." + , "" + , " This program is distributed in the hope that it will be useful," + , " but WITHOUT ANY WARRANTY; without even the implied warranty of" + , " MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the" + , " GNU General Public License for more details." + , "" + , " You should have received a copy of the GNU General Public License" + , " along with this program. If not, see ." + , "" + , "Also add information on how to contact you by electronic and paper mail." + , "" + , " If the program does terminal interaction, make it output a short" + , "notice like this when it starts in an interactive mode:" + , "" + , " Copyright (C) " + , " This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'." + , " This is free software, and you are welcome to redistribute it" + , " under certain conditions; type `show c' for details." + , "" + , "The hypothetical commands `show w' and `show c' should show the appropriate" + , "parts of the General Public License. Of course, your program's commands" + , "might be different; for a GUI interface, you would use an \"about box\"." + , "" + , " You should also get your employer (if you work as a programmer) or school," + , "if any, to sign a \"copyright disclaimer\" for the program, if necessary." + , "For more information on this, and how to apply and follow the GNU GPL, see" + , "." + , "" + , " The GNU General Public License does not permit incorporating your program" + , "into proprietary programs. If your program is a subroutine library, you" + , "may consider it more useful to permit linking proprietary applications with" + , "the library. If this is what you want to do, use the GNU Lesser General" + , "Public License instead of this License. But first, please read" + , "." + ] + +agplv3 :: License +agplv3 = unlines + [ " GNU AFFERO GENERAL PUBLIC LICENSE" + , " Version 3, 19 November 2007" + , "" + , " Copyright (C) 2007 Free Software Foundation, Inc. " + , " Everyone is permitted to copy and distribute verbatim copies" + , " of this license document, but changing it is not allowed." + , "" + , " Preamble" + , "" + , " The GNU Affero General Public License is a free, copyleft license for" + , "software and other kinds of works, specifically designed to ensure" + , "cooperation with the community in the case of network server software." + , "" + , " The licenses for most software and other practical works are designed" + , "to take away your freedom to share and change the works. By contrast," + , "our General Public Licenses are intended to guarantee your freedom to" + , "share and change all versions of a program--to make sure it remains free" + , "software for all its users." + , "" + , " When we speak of free software, we are referring to freedom, not" + , "price. Our General Public Licenses are designed to make sure that you" + , "have the freedom to distribute copies of free software (and charge for" + , "them if you wish), that you receive source code or can get it if you" + , "want it, that you can change the software or use pieces of it in new" + , "free programs, and that you know you can do these things." + , "" + , " Developers that use our General Public Licenses protect your rights" + , "with two steps: (1) assert copyright on the software, and (2) offer" + , "you this License which gives you legal permission to copy, distribute" + , "and/or modify the software." + , "" + , " A secondary benefit of defending all users' freedom is that" + , "improvements made in alternate versions of the program, if they" + , "receive widespread use, become available for other developers to" + , "incorporate. Many developers of free software are heartened and" + , "encouraged by the resulting cooperation. However, in the case of" + , "software used on network servers, this result may fail to come about." + , "The GNU General Public License permits making a modified version and" + , "letting the public access it on a server without ever releasing its" + , "source code to the public." + , "" + , " The GNU Affero General Public License is designed specifically to" + , "ensure that, in such cases, the modified source code becomes available" + , "to the community. It requires the operator of a network server to" + , "provide the source code of the modified version running there to the" + , "users of that server. Therefore, public use of a modified version, on" + , "a publicly accessible server, gives the public access to the source" + , "code of the modified version." + , "" + , " An older license, called the Affero General Public License and" + , "published by Affero, was designed to accomplish similar goals. This is" + , "a different license, not a version of the Affero GPL, but Affero has" + , "released a new version of the Affero GPL which permits relicensing under" + , "this license." + , "" + , " The precise terms and conditions for copying, distribution and" + , "modification follow." + , "" + , " TERMS AND CONDITIONS" + , "" + , " 0. Definitions." + , "" + , " \"This License\" refers to version 3 of the GNU Affero General Public License." + , "" + , " \"Copyright\" also means copyright-like laws that apply to other kinds of" + , "works, such as semiconductor masks." + , "" + , " \"The Program\" refers to any copyrightable work licensed under this" + , "License. Each licensee is addressed as \"you\". \"Licensees\" and" + , "\"recipients\" may be individuals or organizations." + , "" + , " To \"modify\" a work means to copy from or adapt all or part of the work" + , "in a fashion requiring copyright permission, other than the making of an" + , "exact copy. The resulting work is called a \"modified version\" of the" + , "earlier work or a work \"based on\" the earlier work." + , "" + , " A \"covered work\" means either the unmodified Program or a work based" + , "on the Program." + , "" + , " To \"propagate\" a work means to do anything with it that, without" + , "permission, would make you directly or secondarily liable for" + , "infringement under applicable copyright law, except executing it on a" + , "computer or modifying a private copy. Propagation includes copying," + , "distribution (with or without modification), making available to the" + , "public, and in some countries other activities as well." + , "" + , " To \"convey\" a work means any kind of propagation that enables other" + , "parties to make or receive copies. Mere interaction with a user through" + , "a computer network, with no transfer of a copy, is not conveying." + , "" + , " An interactive user interface displays \"Appropriate Legal Notices\"" + , "to the extent that it includes a convenient and prominently visible" + , "feature that (1) displays an appropriate copyright notice, and (2)" + , "tells the user that there is no warranty for the work (except to the" + , "extent that warranties are provided), that licensees may convey the" + , "work under this License, and how to view a copy of this License. If" + , "the interface presents a list of user commands or options, such as a" + , "menu, a prominent item in the list meets this criterion." + , "" + , " 1. Source Code." + , "" + , " The \"source code\" for a work means the preferred form of the work" + , "for making modifications to it. \"Object code\" means any non-source" + , "form of a work." + , "" + , " A \"Standard Interface\" means an interface that either is an official" + , "standard defined by a recognized standards body, or, in the case of" + , "interfaces specified for a particular programming language, one that" + , "is widely used among developers working in that language." + , "" + , " The \"System Libraries\" of an executable work include anything, other" + , "than the work as a whole, that (a) is included in the normal form of" + , "packaging a Major Component, but which is not part of that Major" + , "Component, and (b) serves only to enable use of the work with that" + , "Major Component, or to implement a Standard Interface for which an" + , "implementation is available to the public in source code form. A" + , "\"Major Component\", in this context, means a major essential component" + , "(kernel, window system, and so on) of the specific operating system" + , "(if any) on which the executable work runs, or a compiler used to" + , "produce the work, or an object code interpreter used to run it." + , "" + , " The \"Corresponding Source\" for a work in object code form means all" + , "the source code needed to generate, install, and (for an executable" + , "work) run the object code and to modify the work, including scripts to" + , "control those activities. However, it does not include the work's" + , "System Libraries, or general-purpose tools or generally available free" + , "programs which are used unmodified in performing those activities but" + , "which are not part of the work. For example, Corresponding Source" + , "includes interface definition files associated with source files for" + , "the work, and the source code for shared libraries and dynamically" + , "linked subprograms that the work is specifically designed to require," + , "such as by intimate data communication or control flow between those" + , "subprograms and other parts of the work." + , "" + , " The Corresponding Source need not include anything that users" + , "can regenerate automatically from other parts of the Corresponding" + , "Source." + , "" + , " The Corresponding Source for a work in source code form is that" + , "same work." + , "" + , " 2. Basic Permissions." + , "" + , " All rights granted under this License are granted for the term of" + , "copyright on the Program, and are irrevocable provided the stated" + , "conditions are met. This License explicitly affirms your unlimited" + , "permission to run the unmodified Program. The output from running a" + , "covered work is covered by this License only if the output, given its" + , "content, constitutes a covered work. This License acknowledges your" + , "rights of fair use or other equivalent, as provided by copyright law." + , "" + , " You may make, run and propagate covered works that you do not" + , "convey, without conditions so long as your license otherwise remains" + , "in force. You may convey covered works to others for the sole purpose" + , "of having them make modifications exclusively for you, or provide you" + , "with facilities for running those works, provided that you comply with" + , "the terms of this License in conveying all material for which you do" + , "not control copyright. Those thus making or running the covered works" + , "for you must do so exclusively on your behalf, under your direction" + , "and control, on terms that prohibit them from making any copies of" + , "your copyrighted material outside their relationship with you." + , "" + , " Conveying under any other circumstances is permitted solely under" + , "the conditions stated below. Sublicensing is not allowed; section 10" + , "makes it unnecessary." + , "" + , " 3. Protecting Users' Legal Rights From Anti-Circumvention Law." + , "" + , " No covered work shall be deemed part of an effective technological" + , "measure under any applicable law fulfilling obligations under article" + , "11 of the WIPO copyright treaty adopted on 20 December 1996, or" + , "similar laws prohibiting or restricting circumvention of such" + , "measures." + , "" + , " When you convey a covered work, you waive any legal power to forbid" + , "circumvention of technological measures to the extent such circumvention" + , "is effected by exercising rights under this License with respect to" + , "the covered work, and you disclaim any intention to limit operation or" + , "modification of the work as a means of enforcing, against the work's" + , "users, your or third parties' legal rights to forbid circumvention of" + , "technological measures." + , "" + , " 4. Conveying Verbatim Copies." + , "" + , " You may convey verbatim copies of the Program's source code as you" + , "receive it, in any medium, provided that you conspicuously and" + , "appropriately publish on each copy an appropriate copyright notice;" + , "keep intact all notices stating that this License and any" + , "non-permissive terms added in accord with section 7 apply to the code;" + , "keep intact all notices of the absence of any warranty; and give all" + , "recipients a copy of this License along with the Program." + , "" + , " You may charge any price or no price for each copy that you convey," + , "and you may offer support or warranty protection for a fee." + , "" + , " 5. Conveying Modified Source Versions." + , "" + , " You may convey a work based on the Program, or the modifications to" + , "produce it from the Program, in the form of source code under the" + , "terms of section 4, provided that you also meet all of these conditions:" + , "" + , " a) The work must carry prominent notices stating that you modified" + , " it, and giving a relevant date." + , "" + , " b) The work must carry prominent notices stating that it is" + , " released under this License and any conditions added under section" + , " 7. This requirement modifies the requirement in section 4 to" + , " \"keep intact all notices\"." + , "" + , " c) You must license the entire work, as a whole, under this" + , " License to anyone who comes into possession of a copy. This" + , " License will therefore apply, along with any applicable section 7" + , " additional terms, to the whole of the work, and all its parts," + , " regardless of how they are packaged. This License gives no" + , " permission to license the work in any other way, but it does not" + , " invalidate such permission if you have separately received it." + , "" + , " d) If the work has interactive user interfaces, each must display" + , " Appropriate Legal Notices; however, if the Program has interactive" + , " interfaces that do not display Appropriate Legal Notices, your" + , " work need not make them do so." + , "" + , " A compilation of a covered work with other separate and independent" + , "works, which are not by their nature extensions of the covered work," + , "and which are not combined with it such as to form a larger program," + , "in or on a volume of a storage or distribution medium, is called an" + , "\"aggregate\" if the compilation and its resulting copyright are not" + , "used to limit the access or legal rights of the compilation's users" + , "beyond what the individual works permit. Inclusion of a covered work" + , "in an aggregate does not cause this License to apply to the other" + , "parts of the aggregate." + , "" + , " 6. Conveying Non-Source Forms." + , "" + , " You may convey a covered work in object code form under the terms" + , "of sections 4 and 5, provided that you also convey the" + , "machine-readable Corresponding Source under the terms of this License," + , "in one of these ways:" + , "" + , " a) Convey the object code in, or embodied in, a physical product" + , " (including a physical distribution medium), accompanied by the" + , " Corresponding Source fixed on a durable physical medium" + , " customarily used for software interchange." + , "" + , " b) Convey the object code in, or embodied in, a physical product" + , " (including a physical distribution medium), accompanied by a" + , " written offer, valid for at least three years and valid for as" + , " long as you offer spare parts or customer support for that product" + , " model, to give anyone who possesses the object code either (1) a" + , " copy of the Corresponding Source for all the software in the" + , " product that is covered by this License, on a durable physical" + , " medium customarily used for software interchange, for a price no" + , " more than your reasonable cost of physically performing this" + , " conveying of source, or (2) access to copy the" + , " Corresponding Source from a network server at no charge." + , "" + , " c) Convey individual copies of the object code with a copy of the" + , " written offer to provide the Corresponding Source. This" + , " alternative is allowed only occasionally and noncommercially, and" + , " only if you received the object code with such an offer, in accord" + , " with subsection 6b." + , "" + , " d) Convey the object code by offering access from a designated" + , " place (gratis or for a charge), and offer equivalent access to the" + , " Corresponding Source in the same way through the same place at no" + , " further charge. You need not require recipients to copy the" + , " Corresponding Source along with the object code. If the place to" + , " copy the object code is a network server, the Corresponding Source" + , " may be on a different server (operated by you or a third party)" + , " that supports equivalent copying facilities, provided you maintain" + , " clear directions next to the object code saying where to find the" + , " Corresponding Source. Regardless of what server hosts the" + , " Corresponding Source, you remain obligated to ensure that it is" + , " available for as long as needed to satisfy these requirements." + , "" + , " e) Convey the object code using peer-to-peer transmission, provided" + , " you inform other peers where the object code and Corresponding" + , " Source of the work are being offered to the general public at no" + , " charge under subsection 6d." + , "" + , " A separable portion of the object code, whose source code is excluded" + , "from the Corresponding Source as a System Library, need not be" + , "included in conveying the object code work." + , "" + , " A \"User Product\" is either (1) a \"consumer product\", which means any" + , "tangible personal property which is normally used for personal, family," + , "or household purposes, or (2) anything designed or sold for incorporation" + , "into a dwelling. In determining whether a product is a consumer product," + , "doubtful cases shall be resolved in favor of coverage. For a particular" + , "product received by a particular user, \"normally used\" refers to a" + , "typical or common use of that class of product, regardless of the status" + , "of the particular user or of the way in which the particular user" + , "actually uses, or expects or is expected to use, the product. A product" + , "is a consumer product regardless of whether the product has substantial" + , "commercial, industrial or non-consumer uses, unless such uses represent" + , "the only significant mode of use of the product." + , "" + , " \"Installation Information\" for a User Product means any methods," + , "procedures, authorization keys, or other information required to install" + , "and execute modified versions of a covered work in that User Product from" + , "a modified version of its Corresponding Source. The information must" + , "suffice to ensure that the continued functioning of the modified object" + , "code is in no case prevented or interfered with solely because" + , "modification has been made." + , "" + , " If you convey an object code work under this section in, or with, or" + , "specifically for use in, a User Product, and the conveying occurs as" + , "part of a transaction in which the right of possession and use of the" + , "User Product is transferred to the recipient in perpetuity or for a" + , "fixed term (regardless of how the transaction is characterized), the" + , "Corresponding Source conveyed under this section must be accompanied" + , "by the Installation Information. But this requirement does not apply" + , "if neither you nor any third party retains the ability to install" + , "modified object code on the User Product (for example, the work has" + , "been installed in ROM)." + , "" + , " The requirement to provide Installation Information does not include a" + , "requirement to continue to provide support service, warranty, or updates" + , "for a work that has been modified or installed by the recipient, or for" + , "the User Product in which it has been modified or installed. Access to a" + , "network may be denied when the modification itself materially and" + , "adversely affects the operation of the network or violates the rules and" + , "protocols for communication across the network." + , "" + , " Corresponding Source conveyed, and Installation Information provided," + , "in accord with this section must be in a format that is publicly" + , "documented (and with an implementation available to the public in" + , "source code form), and must require no special password or key for" + , "unpacking, reading or copying." + , "" + , " 7. Additional Terms." + , "" + , " \"Additional permissions\" are terms that supplement the terms of this" + , "License by making exceptions from one or more of its conditions." + , "Additional permissions that are applicable to the entire Program shall" + , "be treated as though they were included in this License, to the extent" + , "that they are valid under applicable law. If additional permissions" + , "apply only to part of the Program, that part may be used separately" + , "under those permissions, but the entire Program remains governed by" + , "this License without regard to the additional permissions." + , "" + , " When you convey a copy of a covered work, you may at your option" + , "remove any additional permissions from that copy, or from any part of" + , "it. (Additional permissions may be written to require their own" + , "removal in certain cases when you modify the work.) You may place" + , "additional permissions on material, added by you to a covered work," + , "for which you have or can give appropriate copyright permission." + , "" + , " Notwithstanding any other provision of this License, for material you" + , "add to a covered work, you may (if authorized by the copyright holders of" + , "that material) supplement the terms of this License with terms:" + , "" + , " a) Disclaiming warranty or limiting liability differently from the" + , " terms of sections 15 and 16 of this License; or" + , "" + , " b) Requiring preservation of specified reasonable legal notices or" + , " author attributions in that material or in the Appropriate Legal" + , " Notices displayed by works containing it; or" + , "" + , " c) Prohibiting misrepresentation of the origin of that material, or" + , " requiring that modified versions of such material be marked in" + , " reasonable ways as different from the original version; or" + , "" + , " d) Limiting the use for publicity purposes of names of licensors or" + , " authors of the material; or" + , "" + , " e) Declining to grant rights under trademark law for use of some" + , " trade names, trademarks, or service marks; or" + , "" + , " f) Requiring indemnification of licensors and authors of that" + , " material by anyone who conveys the material (or modified versions of" + , " it) with contractual assumptions of liability to the recipient, for" + , " any liability that these contractual assumptions directly impose on" + , " those licensors and authors." + , "" + , " All other non-permissive additional terms are considered \"further" + , "restrictions\" within the meaning of section 10. If the Program as you" + , "received it, or any part of it, contains a notice stating that it is" + , "governed by this License along with a term that is a further" + , "restriction, you may remove that term. If a license document contains" + , "a further restriction but permits relicensing or conveying under this" + , "License, you may add to a covered work material governed by the terms" + , "of that license document, provided that the further restriction does" + , "not survive such relicensing or conveying." + , "" + , " If you add terms to a covered work in accord with this section, you" + , "must place, in the relevant source files, a statement of the" + , "additional terms that apply to those files, or a notice indicating" + , "where to find the applicable terms." + , "" + , " Additional terms, permissive or non-permissive, may be stated in the" + , "form of a separately written license, or stated as exceptions;" + , "the above requirements apply either way." + , "" + , " 8. Termination." + , "" + , " You may not propagate or modify a covered work except as expressly" + , "provided under this License. Any attempt otherwise to propagate or" + , "modify it is void, and will automatically terminate your rights under" + , "this License (including any patent licenses granted under the third" + , "paragraph of section 11)." + , "" + , " However, if you cease all violation of this License, then your" + , "license from a particular copyright holder is reinstated (a)" + , "provisionally, unless and until the copyright holder explicitly and" + , "finally terminates your license, and (b) permanently, if the copyright" + , "holder fails to notify you of the violation by some reasonable means" + , "prior to 60 days after the cessation." + , "" + , " Moreover, your license from a particular copyright holder is" + , "reinstated permanently if the copyright holder notifies you of the" + , "violation by some reasonable means, this is the first time you have" + , "received notice of violation of this License (for any work) from that" + , "copyright holder, and you cure the violation prior to 30 days after" + , "your receipt of the notice." + , "" + , " Termination of your rights under this section does not terminate the" + , "licenses of parties who have received copies or rights from you under" + , "this License. If your rights have been terminated and not permanently" + , "reinstated, you do not qualify to receive new licenses for the same" + , "material under section 10." + , "" + , " 9. Acceptance Not Required for Having Copies." + , "" + , " You are not required to accept this License in order to receive or" + , "run a copy of the Program. Ancillary propagation of a covered work" + , "occurring solely as a consequence of using peer-to-peer transmission" + , "to receive a copy likewise does not require acceptance. However," + , "nothing other than this License grants you permission to propagate or" + , "modify any covered work. These actions infringe copyright if you do" + , "not accept this License. Therefore, by modifying or propagating a" + , "covered work, you indicate your acceptance of this License to do so." + , "" + , " 10. Automatic Licensing of Downstream Recipients." + , "" + , " Each time you convey a covered work, the recipient automatically" + , "receives a license from the original licensors, to run, modify and" + , "propagate that work, subject to this License. You are not responsible" + , "for enforcing compliance by third parties with this License." + , "" + , " An \"entity transaction\" is a transaction transferring control of an" + , "organization, or substantially all assets of one, or subdividing an" + , "organization, or merging organizations. If propagation of a covered" + , "work results from an entity transaction, each party to that" + , "transaction who receives a copy of the work also receives whatever" + , "licenses to the work the party's predecessor in interest had or could" + , "give under the previous paragraph, plus a right to possession of the" + , "Corresponding Source of the work from the predecessor in interest, if" + , "the predecessor has it or can get it with reasonable efforts." + , "" + , " You may not impose any further restrictions on the exercise of the" + , "rights granted or affirmed under this License. For example, you may" + , "not impose a license fee, royalty, or other charge for exercise of" + , "rights granted under this License, and you may not initiate litigation" + , "(including a cross-claim or counterclaim in a lawsuit) alleging that" + , "any patent claim is infringed by making, using, selling, offering for" + , "sale, or importing the Program or any portion of it." + , "" + , " 11. Patents." + , "" + , " A \"contributor\" is a copyright holder who authorizes use under this" + , "License of the Program or a work on which the Program is based. The" + , "work thus licensed is called the contributor's \"contributor version\"." + , "" + , " A contributor's \"essential patent claims\" are all patent claims" + , "owned or controlled by the contributor, whether already acquired or" + , "hereafter acquired, that would be infringed by some manner, permitted" + , "by this License, of making, using, or selling its contributor version," + , "but do not include claims that would be infringed only as a" + , "consequence of further modification of the contributor version. For" + , "purposes of this definition, \"control\" includes the right to grant" + , "patent sublicenses in a manner consistent with the requirements of" + , "this License." + , "" + , " Each contributor grants you a non-exclusive, worldwide, royalty-free" + , "patent license under the contributor's essential patent claims, to" + , "make, use, sell, offer for sale, import and otherwise run, modify and" + , "propagate the contents of its contributor version." + , "" + , " In the following three paragraphs, a \"patent license\" is any express" + , "agreement or commitment, however denominated, not to enforce a patent" + , "(such as an express permission to practice a patent or covenant not to" + , "sue for patent infringement). To \"grant\" such a patent license to a" + , "party means to make such an agreement or commitment not to enforce a" + , "patent against the party." + , "" + , " If you convey a covered work, knowingly relying on a patent license," + , "and the Corresponding Source of the work is not available for anyone" + , "to copy, free of charge and under the terms of this License, through a" + , "publicly available network server or other readily accessible means," + , "then you must either (1) cause the Corresponding Source to be so" + , "available, or (2) arrange to deprive yourself of the benefit of the" + , "patent license for this particular work, or (3) arrange, in a manner" + , "consistent with the requirements of this License, to extend the patent" + , "license to downstream recipients. \"Knowingly relying\" means you have" + , "actual knowledge that, but for the patent license, your conveying the" + , "covered work in a country, or your recipient's use of the covered work" + , "in a country, would infringe one or more identifiable patents in that" + , "country that you have reason to believe are valid." + , "" + , " If, pursuant to or in connection with a single transaction or" + , "arrangement, you convey, or propagate by procuring conveyance of, a" + , "covered work, and grant a patent license to some of the parties" + , "receiving the covered work authorizing them to use, propagate, modify" + , "or convey a specific copy of the covered work, then the patent license" + , "you grant is automatically extended to all recipients of the covered" + , "work and works based on it." + , "" + , " A patent license is \"discriminatory\" if it does not include within" + , "the scope of its coverage, prohibits the exercise of, or is" + , "conditioned on the non-exercise of one or more of the rights that are" + , "specifically granted under this License. You may not convey a covered" + , "work if you are a party to an arrangement with a third party that is" + , "in the business of distributing software, under which you make payment" + , "to the third party based on the extent of your activity of conveying" + , "the work, and under which the third party grants, to any of the" + , "parties who would receive the covered work from you, a discriminatory" + , "patent license (a) in connection with copies of the covered work" + , "conveyed by you (or copies made from those copies), or (b) primarily" + , "for and in connection with specific products or compilations that" + , "contain the covered work, unless you entered into that arrangement," + , "or that patent license was granted, prior to 28 March 2007." + , "" + , " Nothing in this License shall be construed as excluding or limiting" + , "any implied license or other defenses to infringement that may" + , "otherwise be available to you under applicable patent law." + , "" + , " 12. No Surrender of Others' Freedom." + , "" + , " If conditions are imposed on you (whether by court order, agreement or" + , "otherwise) that contradict the conditions of this License, they do not" + , "excuse you from the conditions of this License. If you cannot convey a" + , "covered work so as to satisfy simultaneously your obligations under this" + , "License and any other pertinent obligations, then as a consequence you may" + , "not convey it at all. For example, if you agree to terms that obligate you" + , "to collect a royalty for further conveying from those to whom you convey" + , "the Program, the only way you could satisfy both those terms and this" + , "License would be to refrain entirely from conveying the Program." + , "" + , " 13. Remote Network Interaction; Use with the GNU General Public License." + , "" + , " Notwithstanding any other provision of this License, if you modify the" + , "Program, your modified version must prominently offer all users" + , "interacting with it remotely through a computer network (if your version" + , "supports such interaction) an opportunity to receive the Corresponding" + , "Source of your version by providing access to the Corresponding Source" + , "from a network server at no charge, through some standard or customary" + , "means of facilitating copying of software. This Corresponding Source" + , "shall include the Corresponding Source for any work covered by version 3" + , "of the GNU General Public License that is incorporated pursuant to the" + , "following paragraph." + , "" + , " Notwithstanding any other provision of this License, you have" + , "permission to link or combine any covered work with a work licensed" + , "under version 3 of the GNU General Public License into a single" + , "combined work, and to convey the resulting work. The terms of this" + , "License will continue to apply to the part which is the covered work," + , "but the work with which it is combined will remain governed by version" + , "3 of the GNU General Public License." + , "" + , " 14. Revised Versions of this License." + , "" + , " The Free Software Foundation may publish revised and/or new versions of" + , "the GNU Affero General Public License from time to time. Such new versions" + , "will be similar in spirit to the present version, but may differ in detail to" + , "address new problems or concerns." + , "" + , " Each version is given a distinguishing version number. If the" + , "Program specifies that a certain numbered version of the GNU Affero General" + , "Public License \"or any later version\" applies to it, you have the" + , "option of following the terms and conditions either of that numbered" + , "version or of any later version published by the Free Software" + , "Foundation. If the Program does not specify a version number of the" + , "GNU Affero General Public License, you may choose any version ever published" + , "by the Free Software Foundation." + , "" + , " If the Program specifies that a proxy can decide which future" + , "versions of the GNU Affero General Public License can be used, that proxy's" + , "public statement of acceptance of a version permanently authorizes you" + , "to choose that version for the Program." + , "" + , " Later license versions may give you additional or different" + , "permissions. However, no additional obligations are imposed on any" + , "author or copyright holder as a result of your choosing to follow a" + , "later version." + , "" + , " 15. Disclaimer of Warranty." + , "" + , " THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY" + , "APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT" + , "HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY" + , "OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO," + , "THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR" + , "PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM" + , "IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF" + , "ALL NECESSARY SERVICING, REPAIR OR CORRECTION." + , "" + , " 16. Limitation of Liability." + , "" + , " IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING" + , "WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS" + , "THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY" + , "GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE" + , "USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF" + , "DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD" + , "PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS)," + , "EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF" + , "SUCH DAMAGES." + , "" + , " 17. Interpretation of Sections 15 and 16." + , "" + , " If the disclaimer of warranty and limitation of liability provided" + , "above cannot be given local legal effect according to their terms," + , "reviewing courts shall apply local law that most closely approximates" + , "an absolute waiver of all civil liability in connection with the" + , "Program, unless a warranty or assumption of liability accompanies a" + , "copy of the Program in return for a fee." + , "" + , " END OF TERMS AND CONDITIONS" + , "" + , " How to Apply These Terms to Your New Programs" + , "" + , " If you develop a new program, and you want it to be of the greatest" + , "possible use to the public, the best way to achieve this is to make it" + , "free software which everyone can redistribute and change under these terms." + , "" + , " To do so, attach the following notices to the program. It is safest" + , "to attach them to the start of each source file to most effectively" + , "state the exclusion of warranty; and each file should have at least" + , "the \"copyright\" line and a pointer to where the full notice is found." + , "" + , " " + , " Copyright (C) " + , "" + , " This program is free software: you can redistribute it and/or modify" + , " it under the terms of the GNU Affero General Public License as published by" + , " the Free Software Foundation, either version 3 of the License, or" + , " (at your option) any later version." + , "" + , " This program is distributed in the hope that it will be useful," + , " but WITHOUT ANY WARRANTY; without even the implied warranty of" + , " MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the" + , " GNU Affero General Public License for more details." + , "" + , " You should have received a copy of the GNU Affero General Public License" + , " along with this program. If not, see ." + , "" + , "Also add information on how to contact you by electronic and paper mail." + , "" + , " If your software can interact with users remotely through a computer" + , "network, you should also make sure that it provides a way for users to" + , "get its source. For example, if your program is a web application, its" + , "interface could display a \"Source\" link that leads users to an archive" + , "of the code. There are many ways you could offer source, and different" + , "solutions will be better for different programs; see section 13 for the" + , "specific requirements." + , "" + , " You should also get your employer (if you work as a programmer) or school," + , "if any, to sign a \"copyright disclaimer\" for the program, if necessary." + , "For more information on this, and how to apply and follow the GNU AGPL, see" + , "." + ] + +lgpl21 :: License +lgpl21 = unlines + [ " GNU LESSER GENERAL PUBLIC LICENSE" + , " Version 2.1, February 1999" + , "" + , " Copyright (C) 1991, 1999 Free Software Foundation, Inc." + , " 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA" + , " Everyone is permitted to copy and distribute verbatim copies" + , " of this license document, but changing it is not allowed." + , "" + , "[This is the first released version of the Lesser GPL. It also counts" + , " as the successor of the GNU Library Public License, version 2, hence" + , " the version number 2.1.]" + , "" + , " Preamble" + , "" + , " The licenses for most software are designed to take away your" + , "freedom to share and change it. By contrast, the GNU General Public" + , "Licenses are intended to guarantee your freedom to share and change" + , "free software--to make sure the software is free for all its users." + , "" + , " This license, the Lesser General Public License, applies to some" + , "specially designated software packages--typically libraries--of the" + , "Free Software Foundation and other authors who decide to use it. You" + , "can use it too, but we suggest you first think carefully about whether" + , "this license or the ordinary General Public License is the better" + , "strategy to use in any particular case, based on the explanations below." + , "" + , " When we speak of free software, we are referring to freedom of use," + , "not price. Our General Public Licenses are designed to make sure that" + , "you have the freedom to distribute copies of free software (and charge" + , "for this service if you wish); that you receive source code or can get" + , "it if you want it; that you can change the software and use pieces of" + , "it in new free programs; and that you are informed that you can do" + , "these things." + , "" + , " To protect your rights, we need to make restrictions that forbid" + , "distributors to deny you these rights or to ask you to surrender these" + , "rights. These restrictions translate to certain responsibilities for" + , "you if you distribute copies of the library or if you modify it." + , "" + , " For example, if you distribute copies of the library, whether gratis" + , "or for a fee, you must give the recipients all the rights that we gave" + , "you. You must make sure that they, too, receive or can get the source" + , "code. If you link other code with the library, you must provide" + , "complete object files to the recipients, so that they can relink them" + , "with the library after making changes to the library and recompiling" + , "it. And you must show them these terms so they know their rights." + , "" + , " We protect your rights with a two-step method: (1) we copyright the" + , "library, and (2) we offer you this license, which gives you legal" + , "permission to copy, distribute and/or modify the library." + , "" + , " To protect each distributor, we want to make it very clear that" + , "there is no warranty for the free library. Also, if the library is" + , "modified by someone else and passed on, the recipients should know" + , "that what they have is not the original version, so that the original" + , "author's reputation will not be affected by problems that might be" + , "introduced by others." + , "" + , " Finally, software patents pose a constant threat to the existence of" + , "any free program. We wish to make sure that a company cannot" + , "effectively restrict the users of a free program by obtaining a" + , "restrictive license from a patent holder. Therefore, we insist that" + , "any patent license obtained for a version of the library must be" + , "consistent with the full freedom of use specified in this license." + , "" + , " Most GNU software, including some libraries, is covered by the" + , "ordinary GNU General Public License. This license, the GNU Lesser" + , "General Public License, applies to certain designated libraries, and" + , "is quite different from the ordinary General Public License. We use" + , "this license for certain libraries in order to permit linking those" + , "libraries into non-free programs." + , "" + , " When a program is linked with a library, whether statically or using" + , "a shared library, the combination of the two is legally speaking a" + , "combined work, a derivative of the original library. The ordinary" + , "General Public License therefore permits such linking only if the" + , "entire combination fits its criteria of freedom. The Lesser General" + , "Public License permits more lax criteria for linking other code with" + , "the library." + , "" + , " We call this license the \"Lesser\" General Public License because it" + , "does Less to protect the user's freedom than the ordinary General" + , "Public License. It also provides other free software developers Less" + , "of an advantage over competing non-free programs. These disadvantages" + , "are the reason we use the ordinary General Public License for many" + , "libraries. However, the Lesser license provides advantages in certain" + , "special circumstances." + , "" + , " For example, on rare occasions, there may be a special need to" + , "encourage the widest possible use of a certain library, so that it becomes" + , "a de-facto standard. To achieve this, non-free programs must be" + , "allowed to use the library. A more frequent case is that a free" + , "library does the same job as widely used non-free libraries. In this" + , "case, there is little to gain by limiting the free library to free" + , "software only, so we use the Lesser General Public License." + , "" + , " In other cases, permission to use a particular library in non-free" + , "programs enables a greater number of people to use a large body of" + , "free software. For example, permission to use the GNU C Library in" + , "non-free programs enables many more people to use the whole GNU" + , "operating system, as well as its variant, the GNU/Linux operating" + , "system." + , "" + , " Although the Lesser General Public License is Less protective of the" + , "users' freedom, it does ensure that the user of a program that is" + , "linked with the Library has the freedom and the wherewithal to run" + , "that program using a modified version of the Library." + , "" + , " The precise terms and conditions for copying, distribution and" + , "modification follow. Pay close attention to the difference between a" + , "\"work based on the library\" and a \"work that uses the library\". The" + , "former contains code derived from the library, whereas the latter must" + , "be combined with the library in order to run." + , "" + , " GNU LESSER GENERAL PUBLIC LICENSE" + , " TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION" + , "" + , " 0. This License Agreement applies to any software library or other" + , "program which contains a notice placed by the copyright holder or" + , "other authorized party saying it may be distributed under the terms of" + , "this Lesser General Public License (also called \"this License\")." + , "Each licensee is addressed as \"you\"." + , "" + , " A \"library\" means a collection of software functions and/or data" + , "prepared so as to be conveniently linked with application programs" + , "(which use some of those functions and data) to form executables." + , "" + , " The \"Library\", below, refers to any such software library or work" + , "which has been distributed under these terms. A \"work based on the" + , "Library\" means either the Library or any derivative work under" + , "copyright law: that is to say, a work containing the Library or a" + , "portion of it, either verbatim or with modifications and/or translated" + , "straightforwardly into another language. (Hereinafter, translation is" + , "included without limitation in the term \"modification\".)" + , "" + , " \"Source code\" for a work means the preferred form of the work for" + , "making modifications to it. For a library, complete source code means" + , "all the source code for all modules it contains, plus any associated" + , "interface definition files, plus the scripts used to control compilation" + , "and installation of the library." + , "" + , " Activities other than copying, distribution and modification are not" + , "covered by this License; they are outside its scope. The act of" + , "running a program using the Library is not restricted, and output from" + , "such a program is covered only if its contents constitute a work based" + , "on the Library (independent of the use of the Library in a tool for" + , "writing it). Whether that is true depends on what the Library does" + , "and what the program that uses the Library does." + , "" + , " 1. You may copy and distribute verbatim copies of the Library's" + , "complete source code as you receive it, in any medium, provided that" + , "you conspicuously and appropriately publish on each copy an" + , "appropriate copyright notice and disclaimer of warranty; keep intact" + , "all the notices that refer to this License and to the absence of any" + , "warranty; and distribute a copy of this License along with the" + , "Library." + , "" + , " You may charge a fee for the physical act of transferring a copy," + , "and you may at your option offer warranty protection in exchange for a" + , "fee." + , "" + , " 2. You may modify your copy or copies of the Library or any portion" + , "of it, thus forming a work based on the Library, and copy and" + , "distribute such modifications or work under the terms of Section 1" + , "above, provided that you also meet all of these conditions:" + , "" + , " a) The modified work must itself be a software library." + , "" + , " b) You must cause the files modified to carry prominent notices" + , " stating that you changed the files and the date of any change." + , "" + , " c) You must cause the whole of the work to be licensed at no" + , " charge to all third parties under the terms of this License." + , "" + , " d) If a facility in the modified Library refers to a function or a" + , " table of data to be supplied by an application program that uses" + , " the facility, other than as an argument passed when the facility" + , " is invoked, then you must make a good faith effort to ensure that," + , " in the event an application does not supply such function or" + , " table, the facility still operates, and performs whatever part of" + , " its purpose remains meaningful." + , "" + , " (For example, a function in a library to compute square roots has" + , " a purpose that is entirely well-defined independent of the" + , " application. Therefore, Subsection 2d requires that any" + , " application-supplied function or table used by this function must" + , " be optional: if the application does not supply it, the square" + , " root function must still compute square roots.)" + , "" + , "These requirements apply to the modified work as a whole. If" + , "identifiable sections of that work are not derived from the Library," + , "and can be reasonably considered independent and separate works in" + , "themselves, then this License, and its terms, do not apply to those" + , "sections when you distribute them as separate works. But when you" + , "distribute the same sections as part of a whole which is a work based" + , "on the Library, the distribution of the whole must be on the terms of" + , "this License, whose permissions for other licensees extend to the" + , "entire whole, and thus to each and every part regardless of who wrote" + , "it." + , "" + , "Thus, it is not the intent of this section to claim rights or contest" + , "your rights to work written entirely by you; rather, the intent is to" + , "exercise the right to control the distribution of derivative or" + , "collective works based on the Library." + , "" + , "In addition, mere aggregation of another work not based on the Library" + , "with the Library (or with a work based on the Library) on a volume of" + , "a storage or distribution medium does not bring the other work under" + , "the scope of this License." + , "" + , " 3. You may opt to apply the terms of the ordinary GNU General Public" + , "License instead of this License to a given copy of the Library. To do" + , "this, you must alter all the notices that refer to this License, so" + , "that they refer to the ordinary GNU General Public License, version 2," + , "instead of to this License. (If a newer version than version 2 of the" + , "ordinary GNU General Public License has appeared, then you can specify" + , "that version instead if you wish.) Do not make any other change in" + , "these notices." + , "" + , " Once this change is made in a given copy, it is irreversible for" + , "that copy, so the ordinary GNU General Public License applies to all" + , "subsequent copies and derivative works made from that copy." + , "" + , " This option is useful when you wish to copy part of the code of" + , "the Library into a program that is not a library." + , "" + , " 4. You may copy and distribute the Library (or a portion or" + , "derivative of it, under Section 2) in object code or executable form" + , "under the terms of Sections 1 and 2 above provided that you accompany" + , "it with the complete corresponding machine-readable source code, which" + , "must be distributed under the terms of Sections 1 and 2 above on a" + , "medium customarily used for software interchange." + , "" + , " If distribution of object code is made by offering access to copy" + , "from a designated place, then offering equivalent access to copy the" + , "source code from the same place satisfies the requirement to" + , "distribute the source code, even though third parties are not" + , "compelled to copy the source along with the object code." + , "" + , " 5. A program that contains no derivative of any portion of the" + , "Library, but is designed to work with the Library by being compiled or" + , "linked with it, is called a \"work that uses the Library\". Such a" + , "work, in isolation, is not a derivative work of the Library, and" + , "therefore falls outside the scope of this License." + , "" + , " However, linking a \"work that uses the Library\" with the Library" + , "creates an executable that is a derivative of the Library (because it" + , "contains portions of the Library), rather than a \"work that uses the" + , "library\". The executable is therefore covered by this License." + , "Section 6 states terms for distribution of such executables." + , "" + , " When a \"work that uses the Library\" uses material from a header file" + , "that is part of the Library, the object code for the work may be a" + , "derivative work of the Library even though the source code is not." + , "Whether this is true is especially significant if the work can be" + , "linked without the Library, or if the work is itself a library. The" + , "threshold for this to be true is not precisely defined by law." + , "" + , " If such an object file uses only numerical parameters, data" + , "structure layouts and accessors, and small macros and small inline" + , "functions (ten lines or less in length), then the use of the object" + , "file is unrestricted, regardless of whether it is legally a derivative" + , "work. (Executables containing this object code plus portions of the" + , "Library will still fall under Section 6.)" + , "" + , " Otherwise, if the work is a derivative of the Library, you may" + , "distribute the object code for the work under the terms of Section 6." + , "Any executables containing that work also fall under Section 6," + , "whether or not they are linked directly with the Library itself." + , "" + , " 6. As an exception to the Sections above, you may also combine or" + , "link a \"work that uses the Library\" with the Library to produce a" + , "work containing portions of the Library, and distribute that work" + , "under terms of your choice, provided that the terms permit" + , "modification of the work for the customer's own use and reverse" + , "engineering for debugging such modifications." + , "" + , " You must give prominent notice with each copy of the work that the" + , "Library is used in it and that the Library and its use are covered by" + , "this License. You must supply a copy of this License. If the work" + , "during execution displays copyright notices, you must include the" + , "copyright notice for the Library among them, as well as a reference" + , "directing the user to the copy of this License. Also, you must do one" + , "of these things:" + , "" + , " a) Accompany the work with the complete corresponding" + , " machine-readable source code for the Library including whatever" + , " changes were used in the work (which must be distributed under" + , " Sections 1 and 2 above); and, if the work is an executable linked" + , " with the Library, with the complete machine-readable \"work that" + , " uses the Library\", as object code and/or source code, so that the" + , " user can modify the Library and then relink to produce a modified" + , " executable containing the modified Library. (It is understood" + , " that the user who changes the contents of definitions files in the" + , " Library will not necessarily be able to recompile the application" + , " to use the modified definitions.)" + , "" + , " b) Use a suitable shared library mechanism for linking with the" + , " Library. A suitable mechanism is one that (1) uses at run time a" + , " copy of the library already present on the user's computer system," + , " rather than copying library functions into the executable, and (2)" + , " will operate properly with a modified version of the library, if" + , " the user installs one, as long as the modified version is" + , " interface-compatible with the version that the work was made with." + , "" + , " c) Accompany the work with a written offer, valid for at" + , " least three years, to give the same user the materials" + , " specified in Subsection 6a, above, for a charge no more" + , " than the cost of performing this distribution." + , "" + , " d) If distribution of the work is made by offering access to copy" + , " from a designated place, offer equivalent access to copy the above" + , " specified materials from the same place." + , "" + , " e) Verify that the user has already received a copy of these" + , " materials or that you have already sent this user a copy." + , "" + , " For an executable, the required form of the \"work that uses the" + , "Library\" must include any data and utility programs needed for" + , "reproducing the executable from it. However, as a special exception," + , "the materials to be distributed need not include anything that is" + , "normally distributed (in either source or binary form) with the major" + , "components (compiler, kernel, and so on) of the operating system on" + , "which the executable runs, unless that component itself accompanies" + , "the executable." + , "" + , " It may happen that this requirement contradicts the license" + , "restrictions of other proprietary libraries that do not normally" + , "accompany the operating system. Such a contradiction means you cannot" + , "use both them and the Library together in an executable that you" + , "distribute." + , "" + , " 7. You may place library facilities that are a work based on the" + , "Library side-by-side in a single library together with other library" + , "facilities not covered by this License, and distribute such a combined" + , "library, provided that the separate distribution of the work based on" + , "the Library and of the other library facilities is otherwise" + , "permitted, and provided that you do these two things:" + , "" + , " a) Accompany the combined library with a copy of the same work" + , " based on the Library, uncombined with any other library" + , " facilities. This must be distributed under the terms of the" + , " Sections above." + , "" + , " b) Give prominent notice with the combined library of the fact" + , " that part of it is a work based on the Library, and explaining" + , " where to find the accompanying uncombined form of the same work." + , "" + , " 8. You may not copy, modify, sublicense, link with, or distribute" + , "the Library except as expressly provided under this License. Any" + , "attempt otherwise to copy, modify, sublicense, link with, or" + , "distribute the Library is void, and will automatically terminate your" + , "rights under this License. However, parties who have received copies," + , "or rights, from you under this License will not have their licenses" + , "terminated so long as such parties remain in full compliance." + , "" + , " 9. You are not required to accept this License, since you have not" + , "signed it. However, nothing else grants you permission to modify or" + , "distribute the Library or its derivative works. These actions are" + , "prohibited by law if you do not accept this License. Therefore, by" + , "modifying or distributing the Library (or any work based on the" + , "Library), you indicate your acceptance of this License to do so, and" + , "all its terms and conditions for copying, distributing or modifying" + , "the Library or works based on it." + , "" + , " 10. Each time you redistribute the Library (or any work based on the" + , "Library), the recipient automatically receives a license from the" + , "original licensor to copy, distribute, link with or modify the Library" + , "subject to these terms and conditions. You may not impose any further" + , "restrictions on the recipients' exercise of the rights granted herein." + , "You are not responsible for enforcing compliance by third parties with" + , "this License." + , "" + , " 11. If, as a consequence of a court judgment or allegation of patent" + , "infringement or for any other reason (not limited to patent issues)," + , "conditions are imposed on you (whether by court order, agreement or" + , "otherwise) that contradict the conditions of this License, they do not" + , "excuse you from the conditions of this License. If you cannot" + , "distribute so as to satisfy simultaneously your obligations under this" + , "License and any other pertinent obligations, then as a consequence you" + , "may not distribute the Library at all. For example, if a patent" + , "license would not permit royalty-free redistribution of the Library by" + , "all those who receive copies directly or indirectly through you, then" + , "the only way you could satisfy both it and this License would be to" + , "refrain entirely from distribution of the Library." + , "" + , "If any portion of this section is held invalid or unenforceable under any" + , "particular circumstance, the balance of the section is intended to apply," + , "and the section as a whole is intended to apply in other circumstances." + , "" + , "It is not the purpose of this section to induce you to infringe any" + , "patents or other property right claims or to contest validity of any" + , "such claims; this section has the sole purpose of protecting the" + , "integrity of the free software distribution system which is" + , "implemented by public license practices. Many people have made" + , "generous contributions to the wide range of software distributed" + , "through that system in reliance on consistent application of that" + , "system; it is up to the author/donor to decide if he or she is willing" + , "to distribute software through any other system and a licensee cannot" + , "impose that choice." + , "" + , "This section is intended to make thoroughly clear what is believed to" + , "be a consequence of the rest of this License." + , "" + , " 12. If the distribution and/or use of the Library is restricted in" + , "certain countries either by patents or by copyrighted interfaces, the" + , "original copyright holder who places the Library under this License may add" + , "an explicit geographical distribution limitation excluding those countries," + , "so that distribution is permitted only in or among countries not thus" + , "excluded. In such case, this License incorporates the limitation as if" + , "written in the body of this License." + , "" + , " 13. The Free Software Foundation may publish revised and/or new" + , "versions of the Lesser General Public License from time to time." + , "Such new versions will be similar in spirit to the present version," + , "but may differ in detail to address new problems or concerns." + , "" + , "Each version is given a distinguishing version number. If the Library" + , "specifies a version number of this License which applies to it and" + , "\"any later version\", you have the option of following the terms and" + , "conditions either of that version or of any later version published by" + , "the Free Software Foundation. If the Library does not specify a" + , "license version number, you may choose any version ever published by" + , "the Free Software Foundation." + , "" + , " 14. If you wish to incorporate parts of the Library into other free" + , "programs whose distribution conditions are incompatible with these," + , "write to the author to ask for permission. For software which is" + , "copyrighted by the Free Software Foundation, write to the Free" + , "Software Foundation; we sometimes make exceptions for this. Our" + , "decision will be guided by the two goals of preserving the free status" + , "of all derivatives of our free software and of promoting the sharing" + , "and reuse of software generally." + , "" + , " NO WARRANTY" + , "" + , " 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO" + , "WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW." + , "EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR" + , "OTHER PARTIES PROVIDE THE LIBRARY \"AS IS\" WITHOUT WARRANTY OF ANY" + , "KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE" + , "IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR" + , "PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE" + , "LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME" + , "THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION." + , "" + , " 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN" + , "WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY" + , "AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU" + , "FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR" + , "CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE" + , "LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING" + , "RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A" + , "FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF" + , "SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH" + , "DAMAGES." + , "" + , " END OF TERMS AND CONDITIONS" + , "" + , " How to Apply These Terms to Your New Libraries" + , "" + , " If you develop a new library, and you want it to be of the greatest" + , "possible use to the public, we recommend making it free software that" + , "everyone can redistribute and change. You can do so by permitting" + , "redistribution under these terms (or, alternatively, under the terms of the" + , "ordinary General Public License)." + , "" + , " To apply these terms, attach the following notices to the library. It is" + , "safest to attach them to the start of each source file to most effectively" + , "convey the exclusion of warranty; and each file should have at least the" + , "\"copyright\" line and a pointer to where the full notice is found." + , "" + , " " + , " Copyright (C) " + , "" + , " This library is free software; you can redistribute it and/or" + , " modify it under the terms of the GNU Lesser General Public" + , " License as published by the Free Software Foundation; either" + , " version 2.1 of the License, or (at your option) any later version." + , "" + , " This library is distributed in the hope that it will be useful," + , " but WITHOUT ANY WARRANTY; without even the implied warranty of" + , " MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU" + , " Lesser General Public License for more details." + , "" + , " You should have received a copy of the GNU Lesser General Public" + , " License along with this library; if not, write to the Free Software" + , " Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA" + , "" + , "Also add information on how to contact you by electronic and paper mail." + , "" + , "You should also get your employer (if you work as a programmer) or your" + , "school, if any, to sign a \"copyright disclaimer\" for the library, if" + , "necessary. Here is a sample; alter the names:" + , "" + , " Yoyodyne, Inc., hereby disclaims all copyright interest in the" + , " library `Frob' (a library for tweaking knobs) written by James Random Hacker." + , "" + , " , 1 April 1990" + , " Ty Coon, President of Vice" + , "" + , "That's all there is to it!" + ] + +lgpl3 :: License +lgpl3 = unlines + [ " GNU LESSER GENERAL PUBLIC LICENSE" + , " Version 3, 29 June 2007" + , "" + , " Copyright (C) 2007 Free Software Foundation, Inc. " + , " Everyone is permitted to copy and distribute verbatim copies" + , " of this license document, but changing it is not allowed." + , "" + , "" + , " This version of the GNU Lesser General Public License incorporates" + , "the terms and conditions of version 3 of the GNU General Public" + , "License, supplemented by the additional permissions listed below." + , "" + , " 0. Additional Definitions." + , "" + , " As used herein, \"this License\" refers to version 3 of the GNU Lesser" + , "General Public License, and the \"GNU GPL\" refers to version 3 of the GNU" + , "General Public License." + , "" + , " \"The Library\" refers to a covered work governed by this License," + , "other than an Application or a Combined Work as defined below." + , "" + , " An \"Application\" is any work that makes use of an interface provided" + , "by the Library, but which is not otherwise based on the Library." + , "Defining a subclass of a class defined by the Library is deemed a mode" + , "of using an interface provided by the Library." + , "" + , " A \"Combined Work\" is a work produced by combining or linking an" + , "Application with the Library. The particular version of the Library" + , "with which the Combined Work was made is also called the \"Linked" + , "Version\"." + , "" + , " The \"Minimal Corresponding Source\" for a Combined Work means the" + , "Corresponding Source for the Combined Work, excluding any source code" + , "for portions of the Combined Work that, considered in isolation, are" + , "based on the Application, and not on the Linked Version." + , "" + , " The \"Corresponding Application Code\" for a Combined Work means the" + , "object code and/or source code for the Application, including any data" + , "and utility programs needed for reproducing the Combined Work from the" + , "Application, but excluding the System Libraries of the Combined Work." + , "" + , " 1. Exception to Section 3 of the GNU GPL." + , "" + , " You may convey a covered work under sections 3 and 4 of this License" + , "without being bound by section 3 of the GNU GPL." + , "" + , " 2. Conveying Modified Versions." + , "" + , " If you modify a copy of the Library, and, in your modifications, a" + , "facility refers to a function or data to be supplied by an Application" + , "that uses the facility (other than as an argument passed when the" + , "facility is invoked), then you may convey a copy of the modified" + , "version:" + , "" + , " a) under this License, provided that you make a good faith effort to" + , " ensure that, in the event an Application does not supply the" + , " function or data, the facility still operates, and performs" + , " whatever part of its purpose remains meaningful, or" + , "" + , " b) under the GNU GPL, with none of the additional permissions of" + , " this License applicable to that copy." + , "" + , " 3. Object Code Incorporating Material from Library Header Files." + , "" + , " The object code form of an Application may incorporate material from" + , "a header file that is part of the Library. You may convey such object" + , "code under terms of your choice, provided that, if the incorporated" + , "material is not limited to numerical parameters, data structure" + , "layouts and accessors, or small macros, inline functions and templates" + , "(ten or fewer lines in length), you do both of the following:" + , "" + , " a) Give prominent notice with each copy of the object code that the" + , " Library is used in it and that the Library and its use are" + , " covered by this License." + , "" + , " b) Accompany the object code with a copy of the GNU GPL and this license" + , " document." + , "" + , " 4. Combined Works." + , "" + , " You may convey a Combined Work under terms of your choice that," + , "taken together, effectively do not restrict modification of the" + , "portions of the Library contained in the Combined Work and reverse" + , "engineering for debugging such modifications, if you also do each of" + , "the following:" + , "" + , " a) Give prominent notice with each copy of the Combined Work that" + , " the Library is used in it and that the Library and its use are" + , " covered by this License." + , "" + , " b) Accompany the Combined Work with a copy of the GNU GPL and this license" + , " document." + , "" + , " c) For a Combined Work that displays copyright notices during" + , " execution, include the copyright notice for the Library among" + , " these notices, as well as a reference directing the user to the" + , " copies of the GNU GPL and this license document." + , "" + , " d) Do one of the following:" + , "" + , " 0) Convey the Minimal Corresponding Source under the terms of this" + , " License, and the Corresponding Application Code in a form" + , " suitable for, and under terms that permit, the user to" + , " recombine or relink the Application with a modified version of" + , " the Linked Version to produce a modified Combined Work, in the" + , " manner specified by section 6 of the GNU GPL for conveying" + , " Corresponding Source." + , "" + , " 1) Use a suitable shared library mechanism for linking with the" + , " Library. A suitable mechanism is one that (a) uses at run time" + , " a copy of the Library already present on the user's computer" + , " system, and (b) will operate properly with a modified version" + , " of the Library that is interface-compatible with the Linked" + , " Version." + , "" + , " e) Provide Installation Information, but only if you would otherwise" + , " be required to provide such information under section 6 of the" + , " GNU GPL, and only to the extent that such information is" + , " necessary to install and execute a modified version of the" + , " Combined Work produced by recombining or relinking the" + , " Application with a modified version of the Linked Version. (If" + , " you use option 4d0, the Installation Information must accompany" + , " the Minimal Corresponding Source and Corresponding Application" + , " Code. If you use option 4d1, you must provide the Installation" + , " Information in the manner specified by section 6 of the GNU GPL" + , " for conveying Corresponding Source.)" + , "" + , " 5. Combined Libraries." + , "" + , " You may place library facilities that are a work based on the" + , "Library side by side in a single library together with other library" + , "facilities that are not Applications and are not covered by this" + , "License, and convey such a combined library under terms of your" + , "choice, if you do both of the following:" + , "" + , " a) Accompany the combined library with a copy of the same work based" + , " on the Library, uncombined with any other library facilities," + , " conveyed under the terms of this License." + , "" + , " b) Give prominent notice with the combined library that part of it" + , " is a work based on the Library, and explaining where to find the" + , " accompanying uncombined form of the same work." + , "" + , " 6. Revised Versions of the GNU Lesser General Public License." + , "" + , " The Free Software Foundation may publish revised and/or new versions" + , "of the GNU Lesser General Public License from time to time. Such new" + , "versions will be similar in spirit to the present version, but may" + , "differ in detail to address new problems or concerns." + , "" + , " Each version is given a distinguishing version number. If the" + , "Library as you received it specifies that a certain numbered version" + , "of the GNU Lesser General Public License \"or any later version\"" + , "applies to it, you have the option of following the terms and" + , "conditions either of that published version or of any later version" + , "published by the Free Software Foundation. If the Library as you" + , "received it does not specify a version number of the GNU Lesser" + , "General Public License, you may choose any version of the GNU Lesser" + , "General Public License ever published by the Free Software Foundation." + , "" + , " If the Library as you received it specifies that a proxy can decide" + , "whether future versions of the GNU Lesser General Public License shall" + , "apply, that proxy's public statement of acceptance of any version is" + , "permanent authorization for you to choose that version for the" + , "Library." + ] + +apache20 :: License +apache20 = unlines + [ "" + , " Apache License" + , " Version 2.0, January 2004" + , " http://www.apache.org/licenses/" + , "" + , " TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION" + , "" + , " 1. Definitions." + , "" + , " \"License\" shall mean the terms and conditions for use, reproduction," + , " and distribution as defined by Sections 1 through 9 of this document." + , "" + , " \"Licensor\" shall mean the copyright owner or entity authorized by" + , " the copyright owner that is granting the License." + , "" + , " \"Legal Entity\" shall mean the union of the acting entity and all" + , " other entities that control, are controlled by, or are under common" + , " control with that entity. For the purposes of this definition," + , " \"control\" means (i) the power, direct or indirect, to cause the" + , " direction or management of such entity, whether by contract or" + , " otherwise, or (ii) ownership of fifty percent (50%) or more of the" + , " outstanding shares, or (iii) beneficial ownership of such entity." + , "" + , " \"You\" (or \"Your\") shall mean an individual or Legal Entity" + , " exercising permissions granted by this License." + , "" + , " \"Source\" form shall mean the preferred form for making modifications," + , " including but not limited to software source code, documentation" + , " source, and configuration files." + , "" + , " \"Object\" form shall mean any form resulting from mechanical" + , " transformation or translation of a Source form, including but" + , " not limited to compiled object code, generated documentation," + , " and conversions to other media types." + , "" + , " \"Work\" shall mean the work of authorship, whether in Source or" + , " Object form, made available under the License, as indicated by a" + , " copyright notice that is included in or attached to the work" + , " (an example is provided in the Appendix below)." + , "" + , " \"Derivative Works\" shall mean any work, whether in Source or Object" + , " form, that is based on (or derived from) the Work and for which the" + , " editorial revisions, annotations, elaborations, or other modifications" + , " represent, as a whole, an original work of authorship. For the purposes" + , " of this License, Derivative Works shall not include works that remain" + , " separable from, or merely link (or bind by name) to the interfaces of," + , " the Work and Derivative Works thereof." + , "" + , " \"Contribution\" shall mean any work of authorship, including" + , " the original version of the Work and any modifications or additions" + , " to that Work or Derivative Works thereof, that is intentionally" + , " submitted to Licensor for inclusion in the Work by the copyright owner" + , " or by an individual or Legal Entity authorized to submit on behalf of" + , " the copyright owner. For the purposes of this definition, \"submitted\"" + , " means any form of electronic, verbal, or written communication sent" + , " to the Licensor or its representatives, including but not limited to" + , " communication on electronic mailing lists, source code control systems," + , " and issue tracking systems that are managed by, or on behalf of, the" + , " Licensor for the purpose of discussing and improving the Work, but" + , " excluding communication that is conspicuously marked or otherwise" + , " designated in writing by the copyright owner as \"Not a Contribution.\"" + , "" + , " \"Contributor\" shall mean Licensor and any individual or Legal Entity" + , " on behalf of whom a Contribution has been received by Licensor and" + , " subsequently incorporated within the Work." + , "" + , " 2. Grant of Copyright License. Subject to the terms and conditions of" + , " this License, each Contributor hereby grants to You a perpetual," + , " worldwide, non-exclusive, no-charge, royalty-free, irrevocable" + , " copyright license to reproduce, prepare Derivative Works of," + , " publicly display, publicly perform, sublicense, and distribute the" + , " Work and such Derivative Works in Source or Object form." + , "" + , " 3. Grant of Patent License. Subject to the terms and conditions of" + , " this License, each Contributor hereby grants to You a perpetual," + , " worldwide, non-exclusive, no-charge, royalty-free, irrevocable" + , " (except as stated in this section) patent license to make, have made," + , " use, offer to sell, sell, import, and otherwise transfer the Work," + , " where such license applies only to those patent claims licensable" + , " by such Contributor that are necessarily infringed by their" + , " Contribution(s) alone or by combination of their Contribution(s)" + , " with the Work to which such Contribution(s) was submitted. If You" + , " institute patent litigation against any entity (including a" + , " cross-claim or counterclaim in a lawsuit) alleging that the Work" + , " or a Contribution incorporated within the Work constitutes direct" + , " or contributory patent infringement, then any patent licenses" + , " granted to You under this License for that Work shall terminate" + , " as of the date such litigation is filed." + , "" + , " 4. Redistribution. You may reproduce and distribute copies of the" + , " Work or Derivative Works thereof in any medium, with or without" + , " modifications, and in Source or Object form, provided that You" + , " meet the following conditions:" + , "" + , " (a) You must give any other recipients of the Work or" + , " Derivative Works a copy of this License; and" + , "" + , " (b) You must cause any modified files to carry prominent notices" + , " stating that You changed the files; and" + , "" + , " (c) You must retain, in the Source form of any Derivative Works" + , " that You distribute, all copyright, patent, trademark, and" + , " attribution notices from the Source form of the Work," + , " excluding those notices that do not pertain to any part of" + , " the Derivative Works; and" + , "" + , " (d) If the Work includes a \"NOTICE\" text file as part of its" + , " distribution, then any Derivative Works that You distribute must" + , " include a readable copy of the attribution notices contained" + , " within such NOTICE file, excluding those notices that do not" + , " pertain to any part of the Derivative Works, in at least one" + , " of the following places: within a NOTICE text file distributed" + , " as part of the Derivative Works; within the Source form or" + , " documentation, if provided along with the Derivative Works; or," + , " within a display generated by the Derivative Works, if and" + , " wherever such third-party notices normally appear. The contents" + , " of the NOTICE file are for informational purposes only and" + , " do not modify the License. You may add Your own attribution" + , " notices within Derivative Works that You distribute, alongside" + , " or as an addendum to the NOTICE text from the Work, provided" + , " that such additional attribution notices cannot be construed" + , " as modifying the License." + , "" + , " You may add Your own copyright statement to Your modifications and" + , " may provide additional or different license terms and conditions" + , " for use, reproduction, or distribution of Your modifications, or" + , " for any such Derivative Works as a whole, provided Your use," + , " reproduction, and distribution of the Work otherwise complies with" + , " the conditions stated in this License." + , "" + , " 5. Submission of Contributions. Unless You explicitly state otherwise," + , " any Contribution intentionally submitted for inclusion in the Work" + , " by You to the Licensor shall be under the terms and conditions of" + , " this License, without any additional terms or conditions." + , " Notwithstanding the above, nothing herein shall supersede or modify" + , " the terms of any separate license agreement you may have executed" + , " with Licensor regarding such Contributions." + , "" + , " 6. Trademarks. This License does not grant permission to use the trade" + , " names, trademarks, service marks, or product names of the Licensor," + , " except as required for reasonable and customary use in describing the" + , " origin of the Work and reproducing the content of the NOTICE file." + , "" + , " 7. Disclaimer of Warranty. Unless required by applicable law or" + , " agreed to in writing, Licensor provides the Work (and each" + , " Contributor provides its Contributions) on an \"AS IS\" BASIS," + , " WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or" + , " implied, including, without limitation, any warranties or conditions" + , " of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A" + , " PARTICULAR PURPOSE. You are solely responsible for determining the" + , " appropriateness of using or redistributing the Work and assume any" + , " risks associated with Your exercise of permissions under this License." + , "" + , " 8. Limitation of Liability. In no event and under no legal theory," + , " whether in tort (including negligence), contract, or otherwise," + , " unless required by applicable law (such as deliberate and grossly" + , " negligent acts) or agreed to in writing, shall any Contributor be" + , " liable to You for damages, including any direct, indirect, special," + , " incidental, or consequential damages of any character arising as a" + , " result of this License or out of the use or inability to use the" + , " Work (including but not limited to damages for loss of goodwill," + , " work stoppage, computer failure or malfunction, or any and all" + , " other commercial damages or losses), even if such Contributor" + , " has been advised of the possibility of such damages." + , "" + , " 9. Accepting Warranty or Additional Liability. While redistributing" + , " the Work or Derivative Works thereof, You may choose to offer," + , " and charge a fee for, acceptance of support, warranty, indemnity," + , " or other liability obligations and/or rights consistent with this" + , " License. However, in accepting such obligations, You may act only" + , " on Your own behalf and on Your sole responsibility, not on behalf" + , " of any other Contributor, and only if You agree to indemnify," + , " defend, and hold each Contributor harmless for any liability" + , " incurred by, or claims asserted against, such Contributor by reason" + , " of your accepting any such warranty or additional liability." + , "" + , " END OF TERMS AND CONDITIONS" + , "" + , " APPENDIX: How to apply the Apache License to your work." + , "" + , " To apply the Apache License to your work, attach the following" + , " boilerplate notice, with the fields enclosed by brackets \"[]\"" + , " replaced with your own identifying information. (Don't include" + , " the brackets!) The text should be enclosed in the appropriate" + , " comment syntax for the file format. We also recommend that a" + , " file or class name and description of purpose be included on the" + , " same \"printed page\" as the copyright notice for easier" + , " identification within third-party archives." + , "" + , " Copyright [yyyy] [name of copyright owner]" + , "" + , " Licensed under the Apache License, Version 2.0 (the \"License\");" + , " you may not use this file except in compliance with the License." + , " You may obtain a copy of the License at" + , "" + , " http://www.apache.org/licenses/LICENSE-2.0" + , "" + , " Unless required by applicable law or agreed to in writing, software" + , " distributed under the License is distributed on an \"AS IS\" BASIS," + , " WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied." + , " See the License for the specific language governing permissions and" + , " limitations under the License." + ] + +mit :: String -> String -> License +mit authors year = unlines + [ "Copyright (c) " ++ year ++ " " ++ authors + , "" + , "Permission is hereby granted, free of charge, to any person obtaining" + , "a copy of this software and associated documentation files (the" + , "\"Software\"), to deal in the Software without restriction, including" + , "without limitation the rights to use, copy, modify, merge, publish," + , "distribute, sublicense, and/or sell copies of the Software, and to" + , "permit persons to whom the Software is furnished to do so, subject to" + , "the following conditions:" + , "" + , "The above copyright notice and this permission notice shall be included" + , "in all copies or substantial portions of the Software." + , "" + , "THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND," + , "EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF" + , "MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT." + , "IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY" + , "CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT," + , "TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE" + , "SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE." + ] + +mpl20 :: License +mpl20 = unlines + [ "Mozilla Public License Version 2.0" + , "==================================" + , "" + , "1. Definitions" + , "--------------" + , "" + , "1.1. \"Contributor\"" + , " means each individual or legal entity that creates, contributes to" + , " the creation of, or owns Covered Software." + , "" + , "1.2. \"Contributor Version\"" + , " means the combination of the Contributions of others (if any) used" + , " by a Contributor and that particular Contributor's Contribution." + , "" + , "1.3. \"Contribution\"" + , " means Covered Software of a particular Contributor." + , "" + , "1.4. \"Covered Software\"" + , " means Source Code Form to which the initial Contributor has attached" + , " the notice in Exhibit A, the Executable Form of such Source Code" + , " Form, and Modifications of such Source Code Form, in each case" + , " including portions thereof." + , "" + , "1.5. \"Incompatible With Secondary Licenses\"" + , " means" + , "" + , " (a) that the initial Contributor has attached the notice described" + , " in Exhibit B to the Covered Software; or" + , "" + , " (b) that the Covered Software was made available under the terms of" + , " version 1.1 or earlier of the License, but not also under the" + , " terms of a Secondary License." + , "" + , "1.6. \"Executable Form\"" + , " means any form of the work other than Source Code Form." + , "" + , "1.7. \"Larger Work\"" + , " means a work that combines Covered Software with other material, in" + , " a separate file or files, that is not Covered Software." + , "" + , "1.8. \"License\"" + , " means this document." + , "" + , "1.9. \"Licensable\"" + , " means having the right to grant, to the maximum extent possible," + , " whether at the time of the initial grant or subsequently, any and" + , " all of the rights conveyed by this License." + , "" + , "1.10. \"Modifications\"" + , " means any of the following:" + , "" + , " (a) any file in Source Code Form that results from an addition to," + , " deletion from, or modification of the contents of Covered" + , " Software; or" + , "" + , " (b) any new file in Source Code Form that contains any Covered" + , " Software." + , "" + , "1.11. \"Patent Claims\" of a Contributor" + , " means any patent claim(s), including without limitation, method," + , " process, and apparatus claims, in any patent Licensable by such" + , " Contributor that would be infringed, but for the grant of the" + , " License, by the making, using, selling, offering for sale, having" + , " made, import, or transfer of either its Contributions or its" + , " Contributor Version." + , "" + , "1.12. \"Secondary License\"" + , " means either the GNU General Public License, Version 2.0, the GNU" + , " Lesser General Public License, Version 2.1, the GNU Affero General" + , " Public License, Version 3.0, or any later versions of those" + , " licenses." + , "" + , "1.13. \"Source Code Form\"" + , " means the form of the work preferred for making modifications." + , "" + , "1.14. \"You\" (or \"Your\")" + , " means an individual or a legal entity exercising rights under this" + , " License. For legal entities, \"You\" includes any entity that" + , " controls, is controlled by, or is under common control with You. For" + , " purposes of this definition, \"control\" means (a) the power, direct" + , " or indirect, to cause the direction or management of such entity," + , " whether by contract or otherwise, or (b) ownership of more than" + , " fifty percent (50%) of the outstanding shares or beneficial" + , " ownership of such entity." + , "" + , "2. License Grants and Conditions" + , "--------------------------------" + , "" + , "2.1. Grants" + , "" + , "Each Contributor hereby grants You a world-wide, royalty-free," + , "non-exclusive license:" + , "" + , "(a) under intellectual property rights (other than patent or trademark)" + , " Licensable by such Contributor to use, reproduce, make available," + , " modify, display, perform, distribute, and otherwise exploit its" + , " Contributions, either on an unmodified basis, with Modifications, or" + , " as part of a Larger Work; and" + , "" + , "(b) under Patent Claims of such Contributor to make, use, sell, offer" + , " for sale, have made, import, and otherwise transfer either its" + , " Contributions or its Contributor Version." + , "" + , "2.2. Effective Date" + , "" + , "The licenses granted in Section 2.1 with respect to any Contribution" + , "become effective for each Contribution on the date the Contributor first" + , "distributes such Contribution." + , "" + , "2.3. Limitations on Grant Scope" + , "" + , "The licenses granted in this Section 2 are the only rights granted under" + , "this License. No additional rights or licenses will be implied from the" + , "distribution or licensing of Covered Software under this License." + , "Notwithstanding Section 2.1(b) above, no patent license is granted by a" + , "Contributor:" + , "" + , "(a) for any code that a Contributor has removed from Covered Software;" + , " or" + , "" + , "(b) for infringements caused by: (i) Your and any other third party's" + , " modifications of Covered Software, or (ii) the combination of its" + , " Contributions with other software (except as part of its Contributor" + , " Version); or" + , "" + , "(c) under Patent Claims infringed by Covered Software in the absence of" + , " its Contributions." + , "" + , "This License does not grant any rights in the trademarks, service marks," + , "or logos of any Contributor (except as may be necessary to comply with" + , "the notice requirements in Section 3.4)." + , "" + , "2.4. Subsequent Licenses" + , "" + , "No Contributor makes additional grants as a result of Your choice to" + , "distribute the Covered Software under a subsequent version of this" + , "License (see Section 10.2) or under the terms of a Secondary License (if" + , "permitted under the terms of Section 3.3)." + , "" + , "2.5. Representation" + , "" + , "Each Contributor represents that the Contributor believes its" + , "Contributions are its original creation(s) or it has sufficient rights" + , "to grant the rights to its Contributions conveyed by this License." + , "" + , "2.6. Fair Use" + , "" + , "This License is not intended to limit any rights You have under" + , "applicable copyright doctrines of fair use, fair dealing, or other" + , "equivalents." + , "" + , "2.7. Conditions" + , "" + , "Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted" + , "in Section 2.1." + , "" + , "3. Responsibilities" + , "-------------------" + , "" + , "3.1. Distribution of Source Form" + , "" + , "All distribution of Covered Software in Source Code Form, including any" + , "Modifications that You create or to which You contribute, must be under" + , "the terms of this License. You must inform recipients that the Source" + , "Code Form of the Covered Software is governed by the terms of this" + , "License, and how they can obtain a copy of this License. You may not" + , "attempt to alter or restrict the recipients' rights in the Source Code" + , "Form." + , "" + , "3.2. Distribution of Executable Form" + , "" + , "If You distribute Covered Software in Executable Form then:" + , "" + , "(a) such Covered Software must also be made available in Source Code" + , " Form, as described in Section 3.1, and You must inform recipients of" + , " the Executable Form how they can obtain a copy of such Source Code" + , " Form by reasonable means in a timely manner, at a charge no more" + , " than the cost of distribution to the recipient; and" + , "" + , "(b) You may distribute such Executable Form under the terms of this" + , " License, or sublicense it under different terms, provided that the" + , " license for the Executable Form does not attempt to limit or alter" + , " the recipients' rights in the Source Code Form under this License." + , "" + , "3.3. Distribution of a Larger Work" + , "" + , "You may create and distribute a Larger Work under terms of Your choice," + , "provided that You also comply with the requirements of this License for" + , "the Covered Software. If the Larger Work is a combination of Covered" + , "Software with a work governed by one or more Secondary Licenses, and the" + , "Covered Software is not Incompatible With Secondary Licenses, this" + , "License permits You to additionally distribute such Covered Software" + , "under the terms of such Secondary License(s), so that the recipient of" + , "the Larger Work may, at their option, further distribute the Covered" + , "Software under the terms of either this License or such Secondary" + , "License(s)." + , "" + , "3.4. Notices" + , "" + , "You may not remove or alter the substance of any license notices" + , "(including copyright notices, patent notices, disclaimers of warranty," + , "or limitations of liability) contained within the Source Code Form of" + , "the Covered Software, except that You may alter any license notices to" + , "the extent required to remedy known factual inaccuracies." + , "" + , "3.5. Application of Additional Terms" + , "" + , "You may choose to offer, and to charge a fee for, warranty, support," + , "indemnity or liability obligations to one or more recipients of Covered" + , "Software. However, You may do so only on Your own behalf, and not on" + , "behalf of any Contributor. You must make it absolutely clear that any" + , "such warranty, support, indemnity, or liability obligation is offered by" + , "You alone, and You hereby agree to indemnify every Contributor for any" + , "liability incurred by such Contributor as a result of warranty, support," + , "indemnity or liability terms You offer. You may include additional" + , "disclaimers of warranty and limitations of liability specific to any" + , "jurisdiction." + , "" + , "4. Inability to Comply Due to Statute or Regulation" + , "---------------------------------------------------" + , "" + , "If it is impossible for You to comply with any of the terms of this" + , "License with respect to some or all of the Covered Software due to" + , "statute, judicial order, or regulation then You must: (a) comply with" + , "the terms of this License to the maximum extent possible; and (b)" + , "describe the limitations and the code they affect. Such description must" + , "be placed in a text file included with all distributions of the Covered" + , "Software under this License. Except to the extent prohibited by statute" + , "or regulation, such description must be sufficiently detailed for a" + , "recipient of ordinary skill to be able to understand it." + , "" + , "5. Termination" + , "--------------" + , "" + , "5.1. The rights granted under this License will terminate automatically" + , "if You fail to comply with any of its terms. However, if You become" + , "compliant, then the rights granted under this License from a particular" + , "Contributor are reinstated (a) provisionally, unless and until such" + , "Contributor explicitly and finally terminates Your grants, and (b) on an" + , "ongoing basis, if such Contributor fails to notify You of the" + , "non-compliance by some reasonable means prior to 60 days after You have" + , "come back into compliance. Moreover, Your grants from a particular" + , "Contributor are reinstated on an ongoing basis if such Contributor" + , "notifies You of the non-compliance by some reasonable means, this is the" + , "first time You have received notice of non-compliance with this License" + , "from such Contributor, and You become compliant prior to 30 days after" + , "Your receipt of the notice." + , "" + , "5.2. If You initiate litigation against any entity by asserting a patent" + , "infringement claim (excluding declaratory judgment actions," + , "counter-claims, and cross-claims) alleging that a Contributor Version" + , "directly or indirectly infringes any patent, then the rights granted to" + , "You by any and all Contributors for the Covered Software under Section" + , "2.1 of this License shall terminate." + , "" + , "5.3. In the event of termination under Sections 5.1 or 5.2 above, all" + , "end user license agreements (excluding distributors and resellers) which" + , "have been validly granted by You or Your distributors under this License" + , "prior to termination shall survive termination." + , "" + , "************************************************************************" + , "* *" + , "* 6. Disclaimer of Warranty *" + , "* ------------------------- *" + , "* *" + , "* Covered Software is provided under this License on an \"as is\" *" + , "* basis, without warranty of any kind, either expressed, implied, or *" + , "* statutory, including, without limitation, warranties that the *" + , "* Covered Software is free of defects, merchantable, fit for a *" + , "* particular purpose or non-infringing. The entire risk as to the *" + , "* quality and performance of the Covered Software is with You. *" + , "* Should any Covered Software prove defective in any respect, You *" + , "* (not any Contributor) assume the cost of any necessary servicing, *" + , "* repair, or correction. This disclaimer of warranty constitutes an *" + , "* essential part of this License. No use of any Covered Software is *" + , "* authorized under this License except under this disclaimer. *" + , "* *" + , "************************************************************************" + , "" + , "************************************************************************" + , "* *" + , "* 7. Limitation of Liability *" + , "* -------------------------- *" + , "* *" + , "* Under no circumstances and under no legal theory, whether tort *" + , "* (including negligence), contract, or otherwise, shall any *" + , "* Contributor, or anyone who distributes Covered Software as *" + , "* permitted above, be liable to You for any direct, indirect, *" + , "* special, incidental, or consequential damages of any character *" + , "* including, without limitation, damages for lost profits, loss of *" + , "* goodwill, work stoppage, computer failure or malfunction, or any *" + , "* and all other commercial damages or losses, even if such party *" + , "* shall have been informed of the possibility of such damages. This *" + , "* limitation of liability shall not apply to liability for death or *" + , "* personal injury resulting from such party's negligence to the *" + , "* extent applicable law prohibits such limitation. Some *" + , "* jurisdictions do not allow the exclusion or limitation of *" + , "* incidental or consequential damages, so this exclusion and *" + , "* limitation may not apply to You. *" + , "* *" + , "************************************************************************" + , "" + , "8. Litigation" + , "-------------" + , "" + , "Any litigation relating to this License may be brought only in the" + , "courts of a jurisdiction where the defendant maintains its principal" + , "place of business and such litigation shall be governed by laws of that" + , "jurisdiction, without reference to its conflict-of-law provisions." + , "Nothing in this Section shall prevent a party's ability to bring" + , "cross-claims or counter-claims." + , "" + , "9. Miscellaneous" + , "----------------" + , "" + , "This License represents the complete agreement concerning the subject" + , "matter hereof. If any provision of this License is held to be" + , "unenforceable, such provision shall be reformed only to the extent" + , "necessary to make it enforceable. Any law or regulation which provides" + , "that the language of a contract shall be construed against the drafter" + , "shall not be used to construe this License against a Contributor." + , "" + , "10. Versions of the License" + , "---------------------------" + , "" + , "10.1. New Versions" + , "" + , "Mozilla Foundation is the license steward. Except as provided in Section" + , "10.3, no one other than the license steward has the right to modify or" + , "publish new versions of this License. Each version will be given a" + , "distinguishing version number." + , "" + , "10.2. Effect of New Versions" + , "" + , "You may distribute the Covered Software under the terms of the version" + , "of the License under which You originally received the Covered Software," + , "or under the terms of any subsequent version published by the license" + , "steward." + , "" + , "10.3. Modified Versions" + , "" + , "If you create software not governed by this License, and you want to" + , "create a new license for such software, you may create and use a" + , "modified version of this License if you rename the license and remove" + , "any references to the name of the license steward (except to note that" + , "such modified license differs from this License)." + , "" + , "10.4. Distributing Source Code Form that is Incompatible With Secondary" + , "Licenses" + , "" + , "If You choose to distribute Source Code Form that is Incompatible With" + , "Secondary Licenses under the terms of this version of the License, the" + , "notice described in Exhibit B of this License must be attached." + , "" + , "Exhibit A - Source Code Form License Notice" + , "-------------------------------------------" + , "" + , " This Source Code Form is subject to the terms of the Mozilla Public" + , " License, v. 2.0. If a copy of the MPL was not distributed with this" + , " file, You can obtain one at http://mozilla.org/MPL/2.0/." + , "" + , "If it is not possible or desirable to put the notice in a particular" + , "file, then You may include the notice in a location (such as a LICENSE" + , "file in a relevant directory) where a recipient would be likely to look" + , "for such a notice." + , "" + , "You may add additional accurate notices of copyright ownership." + , "" + , "Exhibit B - \"Incompatible With Secondary Licenses\" Notice" + , "---------------------------------------------------------" + , "" + , " This Source Code Form is \"Incompatible With Secondary Licenses\", as" + , " defined by the Mozilla Public License, v. 2.0." + ] + +isc :: String -> String -> License +isc authors year = unlines + [ "Copyright (c) " ++ year ++ " " ++ authors + , "" + , "Permission to use, copy, modify, and/or distribute this software for any purpose" + , "with or without fee is hereby granted, provided that the above copyright notice" + , "and this permission notice appear in all copies." + , "" + , "THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH" + , "REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND" + , "FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT," + , "INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS" + , "OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER" + , "TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF" + , "THIS SOFTWARE." + ] diff --git a/cabal/cabal-install/src/Distribution/Client/Init/NonInteractive/Command.hs b/cabal/cabal-install/src/Distribution/Client/Init/NonInteractive/Command.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Init/NonInteractive/Command.hs @@ -0,0 +1,475 @@ +{-# LANGUAGE LambdaCase #-} +module Distribution.Client.Init.NonInteractive.Command +( genPkgDescription +, genLibTarget +, genExeTarget +, genTestTarget +, createProject +, packageTypeHeuristics +, authorHeuristics +, emailHeuristics +, cabalVersionHeuristics +, packageNameHeuristics +, versionHeuristics +, mainFileHeuristics +, testDirsHeuristics +, initializeTestSuiteHeuristics +, exposedModulesHeuristics +, libOtherModulesHeuristics +, exeOtherModulesHeuristics +, testOtherModulesHeuristics +, buildToolsHeuristics +, dependenciesHeuristics +, otherExtsHeuristics +, licenseHeuristics +, homepageHeuristics +, synopsisHeuristics +, categoryHeuristics +, extraDocFileHeuristics +, appDirsHeuristics +, srcDirsHeuristics +, languageHeuristics +, noCommentsHeuristics +, minimalHeuristics +, overwriteHeuristics +) where +import Distribution.Client.Init.Types + +import Prelude () +import Distribution.Client.Compat.Prelude hiding (putStr, putStrLn, getLine, last, head) + +import Data.List (last, head) +import qualified Data.List.NonEmpty as NEL + +import Distribution.CabalSpecVersion (CabalSpecVersion(..)) +import Distribution.Version (Version) +import Distribution.ModuleName (ModuleName, components) +import Distribution.Types.Dependency (Dependency(..)) +import Distribution.Types.PackageName (PackageName, unPackageName) +import Distribution.Client.Init.Defaults +import Distribution.Client.Init.NonInteractive.Heuristics +import Distribution.Client.Init.Utils +import Distribution.Client.Init.FlagExtractors +import Distribution.Simple.Setup (Flag(..), fromFlagOrDefault) +import Distribution.Simple.PackageIndex (InstalledPackageIndex) +import Distribution.Client.Types (SourcePackageDb(..)) +import Distribution.Solver.Types.PackageIndex (elemByPackageName) +import Distribution.Utils.Generic (safeHead) +import Distribution.Verbosity + +import Language.Haskell.Extension (Language(..), Extension(..)) + +import System.FilePath (splitDirectories, ()) +import Distribution.Simple.Compiler +import qualified Data.Set as Set +import Distribution.FieldGrammar.Newtypes + + +-- | Main driver for interactive prompt code. +-- +createProject + :: Interactive m + => Compiler + -> Verbosity + -> InstalledPackageIndex + -> SourcePackageDb + -> InitFlags + -> m ProjectSettings +createProject comp v pkgIx srcDb initFlags = do + + -- The workflow is as follows: + -- + -- 1. Get the package type, supplied as either a program input or + -- via user prompt. This determines what targets will be built + -- in later steps. + -- + -- 2. Determine whether we generate simple targets or prompt the + -- user for inputs when not supplied as a flag. In general, + -- flag inputs are preferred, and "simple" here means + -- reasonable defaults defined in @Defaults.hs@. + -- + -- 3. Generate package description and the targets specified by + -- the package type. Once this is done, a prompt for building + -- test suites is initiated, and this determines if we build + -- test targets as well. Then we ask if the user wants to + -- comment their .cabal file with pretty comments. + -- + -- 4. The targets are passed to the file creator script, and associated + -- directories/files/modules are created, with the a .cabal file + -- being generated as a final result. + -- + + pkgType <- packageTypeHeuristics initFlags + isMinimal <- getMinimal initFlags + doOverwrite <- getOverwrite initFlags + pkgDir <- packageDirHeuristics initFlags + pkgDesc <- fixupDocFiles v =<< genPkgDescription initFlags srcDb + comments <- noCommentsHeuristics initFlags + + let pkgName = _pkgName pkgDesc + cabalSpec = _pkgCabalVersion pkgDesc + mkOpts cs = WriteOpts + doOverwrite isMinimal cs + v pkgDir pkgType pkgName + + case pkgType of + Library -> do + libTarget <- genLibTarget initFlags comp pkgIx cabalSpec + testTarget <- addLibDepToTest pkgName <$> + genTestTarget initFlags comp pkgIx cabalSpec + + return $ ProjectSettings + (mkOpts comments cabalSpec) pkgDesc + (Just libTarget) Nothing testTarget + + Executable -> do + exeTarget <- genExeTarget initFlags comp pkgIx cabalSpec + + return $ ProjectSettings + (mkOpts comments cabalSpec) pkgDesc Nothing + (Just exeTarget) Nothing + + LibraryAndExecutable -> do + libTarget <- genLibTarget initFlags comp pkgIx cabalSpec + exeTarget <- addLibDepToExe pkgName <$> + genExeTarget initFlags comp pkgIx cabalSpec + testTarget <- addLibDepToTest pkgName <$> + genTestTarget initFlags comp pkgIx cabalSpec + + return $ ProjectSettings + (mkOpts comments cabalSpec) pkgDesc (Just libTarget) + (Just exeTarget) testTarget + + TestSuite -> do + testTarget <- genTestTarget initFlags comp pkgIx cabalSpec + + return $ ProjectSettings + (mkOpts comments cabalSpec) pkgDesc + Nothing Nothing testTarget + +genPkgDescription + :: Interactive m + => InitFlags + -> SourcePackageDb + -> m PkgDescription +genPkgDescription flags srcDb = PkgDescription + <$> cabalVersionHeuristics flags + <*> packageNameHeuristics srcDb flags + <*> versionHeuristics flags + <*> licenseHeuristics flags + <*> authorHeuristics flags + <*> emailHeuristics flags + <*> homepageHeuristics flags + <*> synopsisHeuristics flags + <*> categoryHeuristics flags + <*> getExtraSrcFiles flags + <*> extraDocFileHeuristics flags + +genLibTarget + :: Interactive m + => InitFlags + -> Compiler + -> InstalledPackageIndex + -> CabalSpecVersion + -> m LibTarget +genLibTarget flags comp pkgs v = do + srcDirs <- srcDirsHeuristics flags + let srcDir = fromMaybe defaultSourceDir $ safeHead srcDirs + LibTarget srcDirs + <$> languageHeuristics flags comp + <*> exposedModulesHeuristics flags + <*> libOtherModulesHeuristics flags + <*> otherExtsHeuristics flags srcDir + <*> dependenciesHeuristics flags srcDir pkgs + <*> buildToolsHeuristics flags srcDir v + +genExeTarget + :: Interactive m + => InitFlags + -> Compiler + -> InstalledPackageIndex + -> CabalSpecVersion + -> m ExeTarget +genExeTarget flags comp pkgs v = do + appDirs <- appDirsHeuristics flags + let appDir = fromMaybe defaultApplicationDir $ safeHead appDirs + ExeTarget + <$> mainFileHeuristics flags + <*> pure appDirs + <*> languageHeuristics flags comp + <*> exeOtherModulesHeuristics flags + <*> otherExtsHeuristics flags appDir + <*> dependenciesHeuristics flags appDir pkgs + <*> buildToolsHeuristics flags appDir v + +genTestTarget + :: Interactive m + => InitFlags + -> Compiler + -> InstalledPackageIndex + -> CabalSpecVersion + -> m (Maybe TestTarget) +genTestTarget flags comp pkgs v = do + initialized <- initializeTestSuiteHeuristics flags + testDirs' <- testDirsHeuristics flags + let testDir = fromMaybe defaultTestDir $ safeHead testDirs' + if not initialized + then return Nothing + else fmap Just $ TestTarget + <$> testMainHeuristics flags + <*> pure testDirs' + <*> languageHeuristics flags comp + <*> testOtherModulesHeuristics flags + <*> otherExtsHeuristics flags testDir + <*> dependenciesHeuristics flags testDir pkgs + <*> buildToolsHeuristics flags testDir v + +-- -------------------------------------------------------------------- -- +-- Get flags from init config + +minimalHeuristics :: Interactive m => InitFlags -> m Bool +minimalHeuristics = getMinimal + +overwriteHeuristics :: Interactive m => InitFlags -> m Bool +overwriteHeuristics = getOverwrite + +packageDirHeuristics :: Interactive m => InitFlags -> m FilePath +packageDirHeuristics = getPackageDir + +-- | Get the version of the cabal spec to use. +-- The spec version can be specified by the InitFlags cabalVersion field. If +-- none is specified then the default version is used. +cabalVersionHeuristics :: Interactive m => InitFlags -> m CabalSpecVersion +cabalVersionHeuristics flags = getCabalVersion flags guessCabalSpecVersion + +-- | Get the package name: use the package directory (supplied, or the current +-- directory by default) as a guess. It looks at the SourcePackageDb to avoid +-- using an existing package name. +packageNameHeuristics :: Interactive m => SourcePackageDb -> InitFlags -> m PackageName +packageNameHeuristics sourcePkgDb flags = getPackageName flags $ do + defName <- guessPackageName =<< case packageDir flags of + Flag a -> return a + NoFlag -> last . splitDirectories <$> getCurrentDirectory + + when (isPkgRegistered defName) + $ putStrLn (inUseMsg defName) + + return defName + + where + isPkgRegistered = elemByPackageName (packageIndex sourcePkgDb) + + inUseMsg pn = "The name " + ++ unPackageName pn + ++ " is already in use by another package on Hackage." + +-- | Package version: use 0.1.0.0 as a last resort +versionHeuristics :: Interactive m => InitFlags -> m Version +versionHeuristics flags = getVersion flags $ return defaultVersion + +-- | Choose a license for the package. +-- The license can come from Initflags (license field), if it is not present +-- then prompt the user from a predefined list of licenses. +licenseHeuristics :: Interactive m => InitFlags -> m SpecLicense +licenseHeuristics flags = getLicense flags $ guessLicense flags + +-- | The author's name. Prompt, or try to guess from an existing +-- darcs repo. +authorHeuristics :: Interactive m => InitFlags -> m String +authorHeuristics flags = getAuthor flags guessAuthorEmail + +-- | The author's email. Prompt, or try to guess from an existing +-- darcs repo. +emailHeuristics :: Interactive m => InitFlags -> m String +emailHeuristics flags = getEmail flags guessAuthorName + +-- | Prompt for a homepage URL for the package. +homepageHeuristics :: Interactive m => InitFlags -> m String +homepageHeuristics flags = getHomepage flags $ return "" + +-- | Prompt for a project synopsis. +synopsisHeuristics :: Interactive m => InitFlags -> m String +synopsisHeuristics flags = getSynopsis flags $ return "" + +-- | Prompt for a package category. +-- Note that it should be possible to do some smarter guessing here too, i.e. +-- look at the name of the top level source directory. +categoryHeuristics :: Interactive m => InitFlags -> m String +categoryHeuristics flags = getCategory flags $ return "" + +-- | Try to guess extra source files. +extraDocFileHeuristics :: Interactive m => InitFlags -> m (Maybe (Set FilePath)) +extraDocFileHeuristics flags = case extraDoc flags of + Flag x -> return $ Just $ Set.fromList x + _ -> guessExtraDocFiles flags + +-- | Try to guess if the project builds a library, an executable, or both. +packageTypeHeuristics :: Interactive m => InitFlags -> m PackageType +packageTypeHeuristics flags = getPackageType flags $ guessPackageType flags + +-- | Try to guess the main file, if nothing is found, fallback +-- to a default value. +mainFileHeuristics :: Interactive m => InitFlags -> m HsFilePath +mainFileHeuristics flags = do + appDir <- head <$> appDirsHeuristics flags + getMainFile flags . guessMainFile $ appDir + +testMainHeuristics :: Interactive m => InitFlags -> m HsFilePath +testMainHeuristics flags = do + testDir <- head <$> testDirsHeuristics flags + guessMainFile testDir + +initializeTestSuiteHeuristics :: Interactive m => InitFlags -> m Bool +initializeTestSuiteHeuristics flags = getInitializeTestSuite flags $ return False + +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 + +-- | Ask whether to generate explanatory comments. +noCommentsHeuristics :: Interactive m => InitFlags -> m Bool +noCommentsHeuristics flags = getNoComments flags $ return False + +-- | Ask for the application root directory. +appDirsHeuristics :: Interactive m => InitFlags -> m [String] +appDirsHeuristics flags = getAppDirs flags $ guessApplicationDirectories flags + +-- | Ask for the source (library) root directory. +srcDirsHeuristics :: Interactive m => InitFlags -> m [String] +srcDirsHeuristics flags = getSrcDirs flags $ guessSourceDirectories flags + +-- | Retrieve the list of exposed modules +exposedModulesHeuristics :: Interactive m => InitFlags -> m (NonEmpty ModuleName) +exposedModulesHeuristics flags = do + mods <- case exposedModules flags of + Flag x -> return x + NoFlag -> do + srcDir <- fromMaybe defaultSourceDir . safeHead <$> srcDirsHeuristics flags + + exists <- doesDirectoryExist srcDir + + if exists + then do + modules <- filter isHaskell <$> listFilesRecursive srcDir + modulesNames <- catMaybes <$> traverse retrieveModuleName modules + + otherModules' <- libOtherModulesHeuristics flags + return $ filter (`notElem` otherModules') modulesNames + + else + return [] + + return $ if null mods + then myLibModule NEL.:| [] + else NEL.fromList mods + +-- | Retrieve the list of other modules for Libraries, filtering them +-- based on the last component of the module name +libOtherModulesHeuristics :: Interactive m => InitFlags -> m [ModuleName] +libOtherModulesHeuristics flags = case otherModules flags of + Flag x -> return x + NoFlag -> do + let otherCandidates = ["Internal", "Utils"] + srcDir = case sourceDirs flags of + Flag x -> fromMaybe defaultSourceDir $ safeHead x + NoFlag -> defaultSourceDir + + libDir <- ( srcDir) <$> case packageDir flags of + Flag x -> return x + NoFlag -> getCurrentDirectory + + exists <- doesDirectoryExist libDir + if exists + then do + otherModules' <- filter isHaskell <$> listFilesRecursive libDir + filter ((`elem` otherCandidates) . last . components) + . catMaybes <$> traverse retrieveModuleName otherModules' + else return [] + +-- | Retrieve the list of other modules for Executables, it lists everything +-- that is a Haskell file within the application directory, excluding the main file +exeOtherModulesHeuristics :: Interactive m => InitFlags -> m [ModuleName] +exeOtherModulesHeuristics flags = case otherModules flags of + Flag x -> return x + NoFlag -> do + let appDir = case applicationDirs flags of + Flag x -> fromMaybe defaultApplicationDir $ safeHead x + NoFlag -> defaultApplicationDir + + exeDir <- ( appDir) <$> case packageDir flags of + Flag x -> return x + NoFlag -> getCurrentDirectory + + exists <- doesDirectoryExist exeDir + if exists + then do + otherModules' <- filter (\f -> not (isMain f) && isHaskell f) + <$> listFilesRecursive exeDir + catMaybes <$> traverse retrieveModuleName otherModules' + else return [] + +-- | Retrieve the list of other modules for Tests, it lists everything +-- that is a Haskell file within the tests directory, excluding the main file +testOtherModulesHeuristics :: Interactive m => InitFlags -> m [ModuleName] +testOtherModulesHeuristics flags = case otherModules flags of + Flag x -> return x + NoFlag -> do + let testDir = case testDirs flags of + Flag x -> fromMaybe defaultTestDir $ safeHead x + NoFlag -> defaultTestDir + + testDir' <- ( testDir) <$> case packageDir flags of + Flag x -> return x + NoFlag -> getCurrentDirectory + + exists <- doesDirectoryExist testDir' + if exists + then do + otherModules' <- filter (\f -> not (isMain f) && isHaskell f) + <$> listFilesRecursive testDir' + catMaybes <$> traverse retrieveModuleName otherModules' + else return [] + +-- | Retrieve the list of build tools +buildToolsHeuristics + :: Interactive m + => InitFlags + -> FilePath + -> CabalSpecVersion + -> m [Dependency] +buildToolsHeuristics flags fp v = case buildTools flags of + Flag{} -> getBuildTools flags + NoFlag -> retrieveBuildTools v fp + +-- | Retrieve the list of dependencies +dependenciesHeuristics :: Interactive m => InitFlags -> FilePath -> InstalledPackageIndex -> m [Dependency] +dependenciesHeuristics flags fp pkgIx = getDependencies flags $ do + sources <- retrieveSourceFiles fp + + let mods = case exposedModules flags of + Flag x -> x + NoFlag -> map moduleName sources + + groupedDeps = concatMap (\s -> map (\i -> (moduleName s, i)) (imports s)) sources + filteredDeps = filter ((`notElem` mods) . snd) groupedDeps + preludeNub = nubBy (\a b -> snd a == snd b) $ (fromString "Prelude", fromString "Prelude") : filteredDeps + + retrieveDependencies (fromFlagOrDefault normal $ initVerbosity flags) flags preludeNub pkgIx + +-- | Retrieve the list of extensions +otherExtsHeuristics :: Interactive m => InitFlags -> FilePath -> m [Extension] +otherExtsHeuristics flags fp = case otherExts flags of + Flag x -> return x + NoFlag -> do + exists <- doesDirectoryExist fp + if exists + then do + sources <- listFilesRecursive fp + extensions' <- traverse retrieveModuleExtensions . filter isHaskell $ sources + + return $ nub . join $ extensions' + else + return [] diff --git a/cabal/cabal-install/src/Distribution/Client/Init/NonInteractive/Heuristics.hs b/cabal/cabal-install/src/Distribution/Client/Init/NonInteractive/Heuristics.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Init/NonInteractive/Heuristics.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE LambdaCase #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Init.NonInteractive.Heuristics +-- Copyright : (c) Benedikt Huber 2009 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Heuristics for creating initial cabal files. +-- +----------------------------------------------------------------------------- +module Distribution.Client.Init.NonInteractive.Heuristics + ( guessPackageName + , guessMainFile + , guessLicense + , guessExtraDocFiles + , guessAuthorName + , guessAuthorEmail + , guessCabalSpecVersion + , guessLanguage + , guessPackageType + , guessSourceDirectories + , guessApplicationDirectories + ) where + +import Distribution.Client.Compat.Prelude hiding (readFile, (<|>), many) + +import Distribution.Simple.Setup (fromFlagOrDefault) + +import qualified Data.List as L +import Distribution.Client.Init.Defaults +import Distribution.Client.Init.FlagExtractors (getCabalVersionNoPrompt) +import Distribution.Client.Init.Types +import Distribution.Client.Init.Utils +import System.FilePath +import Distribution.CabalSpecVersion +import Language.Haskell.Extension +import Distribution.Version +import Distribution.Types.PackageName (PackageName) +import Distribution.Simple.Compiler +import qualified Data.Set as Set +import Distribution.FieldGrammar.Newtypes + + + +-- | Guess the main file, returns a default value if none is found. +guessMainFile :: Interactive m => FilePath -> m HsFilePath +guessMainFile pkgDir = do + exists <- doesDirectoryExist pkgDir + if exists + then do + files <- filter isMain <$> listFilesRecursive pkgDir + return $ if null files + then defaultMainIs + else toHsFilePath $ L.head files + else + return defaultMainIs + +-- | Juggling characters around to guess the desired cabal version based on +-- the system's cabal version. +guessCabalSpecVersion :: Interactive m => m CabalSpecVersion +guessCabalSpecVersion = do + (_, verString, _) <- readProcessWithExitCode "cabal" ["--version"] "" + case simpleParsec $ takeWhile (not . isSpace) $ dropWhile (not . isDigit) verString of + Just v -> pure $ fromMaybe defaultCabalVersion $ case versionNumbers v of + [x,y,_,_] -> cabalSpecFromVersionDigits [x,y] + [x,y,_] -> cabalSpecFromVersionDigits [x,y] + _ -> 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 + +-- | Try to guess the license from an already existing @LICENSE@ file in +-- the package directory, comparing the file contents with the ones +-- listed in @Licenses.hs@, for now it only returns a default value. +guessLicense :: Interactive m => InitFlags -> m SpecLicense +guessLicense flags = return . defaultLicense $ getCabalVersionNoPrompt flags + +guessExtraDocFiles :: Interactive m => InitFlags -> m (Maybe (Set FilePath)) +guessExtraDocFiles flags = do + pkgDir <- fromFlagOrDefault getCurrentDirectory $ return <$> packageDir flags + files <- getDirectoryContents pkgDir + + let extraDocCandidates = ["CHANGES", "CHANGELOG", "README"] + extraDocs = [y | x <- extraDocCandidates, y <- files, x == map toUpper (takeBaseName y)] + + return $ Just $ if null extraDocs + then Set.singleton defaultChangelog + else Set.fromList extraDocs + +-- | Try to guess the package type from the files in the package directory, +-- looking for unique characteristics from each type, defaults to Executable. +guessPackageType :: Interactive m => InitFlags -> m PackageType +guessPackageType flags = do + if fromFlagOrDefault False (initializeTestSuite flags) + then + return TestSuite + else do + let lastDir dirs = L.last . splitDirectories $ dirs + srcCandidates = [defaultSourceDir, "src", "source"] + testCandidates = [defaultTestDir, "test", "tests"] + + pkgDir <- fromFlagOrDefault getCurrentDirectory $ return <$> packageDir flags + files <- listFilesInside (\x -> return $ lastDir x `notElem` testCandidates) pkgDir + files' <- filter (not . null . map (`elem` testCandidates) . splitDirectories) <$> + listFilesRecursive pkgDir + + let hasExe = not $ null [f | f <- files, isMain $ takeFileName f] + hasLib = not $ null [f | f <- files, lastDir f `elem` srcCandidates] + hasTest = not $ null [f | f <- files', isMain $ takeFileName f] + + return $ case (hasLib, hasExe, hasTest) of + (True , True , _ ) -> LibraryAndExecutable + (True , False, _ ) -> Library + (False, False, True) -> TestSuite + _ -> Executable + +-- | Try to guess the application directories from the package directory, +-- using a default value as fallback. +guessApplicationDirectories :: Interactive m => InitFlags -> m [FilePath] +guessApplicationDirectories flags = do + pkgDirs <- fromFlagOrDefault getCurrentDirectory + (return <$> packageDir flags) + pkgDirsContents <- listDirectory pkgDirs + + let candidates = [defaultApplicationDir, "app", "src-exe"] in + return $ case [y | x <- candidates, y <- pkgDirsContents, x == y] of + [] -> [defaultApplicationDir] + x -> map ( pkgDirs) . nub $ x + +-- | Try to guess the source directories, using a default value as fallback. +guessSourceDirectories :: Interactive m => InitFlags -> m [FilePath] +guessSourceDirectories flags = do + pkgDir <- fromFlagOrDefault getCurrentDirectory $ return <$> packageDir flags + + doesDirectoryExist (pkgDir "src") >>= return . \case + False -> [defaultSourceDir] + True -> ["src"] + +-- | Guess author and email using git configuration options. +guessAuthorName :: Interactive m => m String +guessAuthorName = guessGitInfo "user.name" + +guessAuthorEmail :: Interactive m => m String +guessAuthorEmail = guessGitInfo "user.email" + +guessGitInfo :: Interactive m => String -> m String +guessGitInfo target = do + info <- readProcessWithExitCode "git" ["config", "--local", target] "" + if null $ snd' info + then trim . snd' <$> readProcessWithExitCode "git" ["config", "--global", target] "" + else return . trim $ snd' info + + where + snd' (_, x, _) = x diff --git a/cabal/cabal-install/src/Distribution/Client/Init/Prompt.hs b/cabal/cabal-install/src/Distribution/Client/Init/Prompt.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Init/Prompt.hs @@ -0,0 +1,171 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Init.Prompt +-- Copyright : (c) Brent Yorgey 2009 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- User prompt utility functions for use by the 'cabal init' command. +-- +----------------------------------------------------------------------------- + +module Distribution.Client.Init.Prompt +( prompt +, promptYesNo +, promptStr +, promptList +) where + +import Prelude hiding (break, putStrLn, getLine, putStr) + +import Distribution.Client.Compat.Prelude hiding (break, empty, getLine, putStr, putStrLn) +import Distribution.Client.Init.Types +import qualified System.IO + + +-- | Create a prompt with optional default value that returns a +-- String. +promptStr :: Interactive m => String -> DefaultPrompt String -> m String +promptStr = promptDefault Right id + +-- | Create a yes/no prompt with optional default value. +promptYesNo + :: Interactive m + => String + -- ^ prompt message + -> DefaultPrompt Bool + -- ^ optional default value + -> m Bool +promptYesNo = + promptDefault recogniseYesNo showYesNo + where + recogniseYesNo s + | (toLower <$> s) == "y" = Right True + | (toLower <$> s) == "n" || s == "N" = Right False + | otherwise = Left $ "Cannot parse input: " ++ s + + showYesNo True = "y" + showYesNo False = "n" + +-- | Create a prompt with optional default value that returns a value +-- of some Text instance. +prompt :: (Interactive m, Parsec t, Pretty t) => String -> DefaultPrompt t -> m t +prompt = promptDefault eitherParsec prettyShow + +-- | Create a prompt from a prompt string and a String representation +-- of an optional default value. +mkDefPrompt :: String -> DefaultPrompt String -> String +mkDefPrompt msg def = msg ++ "?" ++ format def + where + format MandatoryPrompt = " " + format OptionalPrompt = " [optional] " + format (DefaultPrompt s) = " [default: " ++ s ++ "] " + +-- | Create a prompt from a list of strings +promptList + :: Interactive m + => String + -- ^ prompt + -> [String] + -- ^ choices + -> DefaultPrompt String + -- ^ optional default value + -> Maybe (String -> String) + -- ^ modify the default value to present in-prompt + -- e.g. empty string maps to "(none)", but only in the + -- prompt. + -> Bool + -- ^ whether to allow an 'other' option + -> m String +promptList msg choices def modDef hasOther = do + putStrLn $ msg ++ ":" + + -- Output nicely formatted list of options + for_ prettyChoices $ \(i,c) -> do + let star = if DefaultPrompt c == def + then "*" + else " " + + let output = concat $ if i < 10 + then [" ", star, " ", show i, ") ", c] + else [" ", star, show i, ") ", c] + + putStrLn output + + go + where + prettyChoices = + let cs = if hasOther + then choices ++ ["Other (specify)"] + else choices + in zip [1::Int .. length choices + 1] cs + + numChoices = length choices + + invalidChoice input = do + let msg' = if null input + then "Empty input is not a valid choice." + else concat + [ input + , " is not a valid choice. Please choose a number from 1 to " + , show (length prettyChoices) + , "." + ] + + putStrLn msg' + breakOrContinue ("promptList: " ++ input) go + + go = do + putStr + $ mkDefPrompt "Your choice" + $ maybe def (<$> def) modDef + + input <- getLine + case def of + DefaultPrompt d | null input -> return d + _ -> case readMaybe input of + Nothing -> invalidChoice input + Just n + | n > 0, n <= numChoices -> return $ choices !! (n-1) + | n == numChoices + 1, hasOther -> + promptStr "Please specify" OptionalPrompt + | otherwise -> invalidChoice (show n) + +-- | Create a prompt with an optional default value. +promptDefault + :: Interactive m + => (String -> Either String t) + -- ^ parser + -> (t -> String) + -- ^ pretty-printer + -> String + -- ^ prompt message + -> (DefaultPrompt t) + -- ^ optional default value + -> m t +promptDefault parse pprint msg def = do + putStr $ mkDefPrompt msg (pprint <$> def) + hFlush System.IO.stdout + input <- getLine + case def of + DefaultPrompt d | null input -> return d + _ -> case parse input of + Right t -> return t + Left err -> do + putStrLn $ "Couldn't parse " ++ input ++ ", please try again!" + breakOrContinue + ("promptDefault: " ++ err ++ " on input: " ++ input) + (promptDefault parse pprint msg def) + +-- | Prompt utility for breaking out of an interactive loop +-- in the pure case +-- +breakOrContinue :: Interactive m => String -> m a -> m a +breakOrContinue msg act = break >>= \case + True -> throwPrompt $ BreakException msg + False -> act diff --git a/cabal/cabal-install/src/Distribution/Client/Init/Simple.hs b/cabal/cabal-install/src/Distribution/Client/Init/Simple.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Init/Simple.hs @@ -0,0 +1,175 @@ +module Distribution.Client.Init.Simple +( -- * Project creation + createProject + -- * Gen targets +, genSimplePkgDesc +, genSimpleLibTarget +, genSimpleExeTarget +, genSimpleTestTarget +) where + + +import Distribution.Client.Init.Types +import Distribution.Verbosity +import Distribution.Simple.PackageIndex +import Distribution.Client.Types.SourcePackageDb (SourcePackageDb(..)) +import qualified Data.List.NonEmpty as NEL +import Distribution.Client.Init.Utils (currentDirPkgName, mkPackageNameDep, fixupDocFiles) +import Distribution.Client.Init.Defaults +import Distribution.Simple.Flag (fromFlagOrDefault, flagElim, Flag(..)) +import Distribution.Client.Init.FlagExtractors +import qualified Data.Set as Set +import Distribution.Types.Dependency +import Distribution.Types.PackageName (unPackageName) + + +createProject + :: Interactive m + => Verbosity + -> InstalledPackageIndex + -> SourcePackageDb + -> InitFlags + -> m ProjectSettings +createProject v pkgIx _srcDb initFlags = do + pkgType <- packageTypePrompt initFlags + isMinimal <- getMinimal initFlags + doOverwrite <- getOverwrite initFlags + pkgDir <- getPackageDir initFlags + pkgDesc <- fixupDocFiles v =<< genSimplePkgDesc initFlags + + let pkgName = _pkgName pkgDesc + cabalSpec = _pkgCabalVersion pkgDesc + mkOpts cs = WriteOpts + doOverwrite isMinimal cs + v pkgDir pkgType pkgName + + basedFlags <- addBaseDepToFlags pkgIx initFlags + + case pkgType of + Library -> do + libTarget <- genSimpleLibTarget basedFlags + testTarget <- addLibDepToTest pkgName <$> genSimpleTestTarget basedFlags + return $ ProjectSettings + (mkOpts False cabalSpec) pkgDesc + (Just libTarget) Nothing testTarget + + Executable -> do + exeTarget <- genSimpleExeTarget basedFlags + return $ ProjectSettings + (mkOpts False cabalSpec) pkgDesc + Nothing (Just exeTarget) Nothing + + LibraryAndExecutable -> do + libTarget <- genSimpleLibTarget basedFlags + testTarget <- addLibDepToTest pkgName <$> genSimpleTestTarget basedFlags + exeTarget <- addLibDepToExe pkgName <$> genSimpleExeTarget basedFlags + return $ ProjectSettings + (mkOpts False cabalSpec) pkgDesc + (Just libTarget) (Just exeTarget) testTarget + + TestSuite -> do + testTarget <- genSimpleTestTarget basedFlags + return $ ProjectSettings + (mkOpts False cabalSpec) pkgDesc + Nothing Nothing testTarget + where + -- Add package name as dependency of test suite + -- + addLibDepToTest _ Nothing = Nothing + addLibDepToTest n (Just t) = Just $ t + { _testDependencies = _testDependencies t ++ [mkPackageNameDep n] + } + + -- Add package name as dependency of executable + -- + addLibDepToExe n exe = exe + { _exeDependencies = _exeDependencies exe ++ [mkPackageNameDep n] + } + +genSimplePkgDesc :: Interactive m => InitFlags -> m PkgDescription +genSimplePkgDesc flags = mkPkgDesc <$> currentDirPkgName + where + defaultExtraDoc = Just $ Set.singleton defaultChangelog + + extractExtraDoc [] = defaultExtraDoc + extractExtraDoc fs = Just $ Set.fromList fs + + mkPkgDesc pkgName = PkgDescription + (fromFlagOrDefault defaultCabalVersion (cabalVersion flags)) + pkgName + (fromFlagOrDefault defaultVersion (version flags)) + (fromFlagOrDefault (defaultLicense $ getCabalVersionNoPrompt flags) (license flags)) + (fromFlagOrDefault "" (author flags)) + (fromFlagOrDefault "" (email flags)) + (fromFlagOrDefault "" (homepage flags)) + (fromFlagOrDefault "" (synopsis flags)) + (fromFlagOrDefault "" (category flags)) + (flagElim mempty Set.fromList (extraSrc flags)) + (flagElim defaultExtraDoc extractExtraDoc (extraDoc flags)) + +genSimpleLibTarget :: Interactive m => InitFlags -> m LibTarget +genSimpleLibTarget flags = do + buildToolDeps <- getBuildTools flags + return $ LibTarget + { _libSourceDirs = fromFlagOrDefault [defaultSourceDir] $ sourceDirs flags + , _libLanguage = fromFlagOrDefault defaultLanguage $ language flags + , _libExposedModules = + flagElim (myLibModule NEL.:| []) extractMods $ exposedModules flags + , _libOtherModules = fromFlagOrDefault [] $ otherModules flags + , _libOtherExts = fromFlagOrDefault [] $ otherExts flags + , _libDependencies = fromFlagOrDefault [] $ dependencies flags + , _libBuildTools = buildToolDeps + } + + where + extractMods [] = myLibModule NEL.:| [] + extractMods as = NEL.fromList as + +genSimpleExeTarget :: Interactive m => InitFlags -> m ExeTarget +genSimpleExeTarget flags = do + buildToolDeps <- getBuildTools flags + return $ ExeTarget + { _exeMainIs = flagElim defaultMainIs toHsFilePath $ mainIs flags + , _exeApplicationDirs = + fromFlagOrDefault [defaultApplicationDir] $ applicationDirs flags + , _exeLanguage = fromFlagOrDefault defaultLanguage $ language flags + , _exeOtherModules = fromFlagOrDefault [] $ otherModules flags + , _exeOtherExts = fromFlagOrDefault [] $ otherExts flags + , _exeDependencies = fromFlagOrDefault [] $ dependencies flags + , _exeBuildTools = buildToolDeps + } + +genSimpleTestTarget :: Interactive m => InitFlags -> m (Maybe TestTarget) +genSimpleTestTarget flags = go =<< initializeTestSuitePrompt flags + where + go initialized + | not initialized = return Nothing + | otherwise = do + buildToolDeps <- getBuildTools flags + return $ Just $ TestTarget + { _testMainIs = flagElim defaultMainIs toHsFilePath $ mainIs flags + , _testDirs = fromFlagOrDefault [defaultTestDir] $ testDirs flags + , _testLanguage = fromFlagOrDefault defaultLanguage $ language flags + , _testOtherModules = fromFlagOrDefault [] $ otherModules flags + , _testOtherExts = fromFlagOrDefault [] $ otherExts flags + , _testDependencies = fromFlagOrDefault [] $ dependencies flags + , _testBuildTools = buildToolDeps + } + +-- -------------------------------------------------------------------- -- +-- Utils + +-- | If deps are defined, and base is present, we skip the search for base. +-- otherwise, we look up @base@ and add it to the list. +addBaseDepToFlags :: Interactive m => InstalledPackageIndex -> InitFlags -> m InitFlags +addBaseDepToFlags pkgIx initFlags = case dependencies initFlags of + Flag as + | any ((==) "base" . unPackageName . depPkgName) as -> return initFlags + | otherwise -> do + based <- dependenciesPrompt pkgIx initFlags + return $ initFlags + { dependencies = Flag $ based ++ as + } + _ -> do + based <- dependenciesPrompt pkgIx initFlags + return initFlags { dependencies = Flag based } diff --git a/cabal/cabal-install/src/Distribution/Client/Init/Types.hs b/cabal/cabal-install/src/Distribution/Client/Init/Types.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Init/Types.hs @@ -0,0 +1,472 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE BangPatterns #-} +-- | +-- Module : Distribution.Client.Init.Types +-- Copyright : (c) Brent Yorgey, Benedikt Huber 2009 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Some types used by the 'cabal init' command. +-- +module Distribution.Client.Init.Types +( -- * Data + InitFlags(..) + -- ** Targets and descriptions +, PkgDescription(..) +, LibTarget(..) +, ExeTarget(..) +, TestTarget(..) + -- ** package types +, PackageType(..) + -- ** Main file +, HsFilePath(..) +, HsFileType(..) +, fromHsFilePath +, toHsFilePath +, toLiterateHs +, toStandardHs +, mkLiterate +, isHsFilePath + -- * Typeclasses +, Interactive(..) +, BreakException(..) +, PurePrompt(..) +, evalPrompt +, Severity(..) + -- * Aliases +, IsLiterate +, IsSimple + -- * File creator opts +, WriteOpts(..) +, ProjectSettings(..) + -- * Formatters +, FieldAnnotation(..) + -- * Other conveniences +, DefaultPrompt(..) +) where + + +import qualified Distribution.Client.Compat.Prelude as P +import Distribution.Client.Compat.Prelude as P hiding (getLine, putStr, putStrLn) +import Prelude (read) + +import Control.Monad.Catch + +import Data.List.NonEmpty (fromList) + +import Distribution.Simple.Setup (Flag(..)) +import Distribution.Types.Dependency as P +import Distribution.Verbosity (silent) +import Distribution.Version +import qualified Distribution.Package as P +import Distribution.ModuleName +import Distribution.CabalSpecVersion +import Distribution.Client.Utils as P +import Distribution.Fields.Pretty +import Language.Haskell.Extension ( Language(..), Extension ) +import qualified System.IO + +import qualified System.Directory as P +import qualified System.Process as P +import qualified Distribution.Compat.Environment as P +import System.FilePath +import Distribution.FieldGrammar.Newtypes (SpecLicense) + + +-- -------------------------------------------------------------------- -- +-- Flags + +-- | InitFlags is a subset of flags available in the +-- @.cabal@ file that represent options that are relevant to the +-- init command process. +-- +data InitFlags = + InitFlags + { interactive :: Flag Bool + , quiet :: Flag Bool + , packageDir :: Flag FilePath + , noComments :: Flag Bool + , minimal :: Flag Bool + , simpleProject :: Flag Bool + , packageName :: Flag P.PackageName + , version :: Flag Version + , cabalVersion :: Flag CabalSpecVersion + , license :: Flag SpecLicense + , author :: Flag String + , email :: Flag String + , homepage :: Flag String + , synopsis :: Flag String + , category :: Flag String + , extraSrc :: Flag [String] + , extraDoc :: Flag [String] + , packageType :: Flag PackageType + , mainIs :: Flag FilePath + , language :: Flag Language + , exposedModules :: Flag [ModuleName] + , otherModules :: Flag [ModuleName] + , otherExts :: Flag [Extension] + , dependencies :: Flag [P.Dependency] + , applicationDirs :: Flag [String] + , sourceDirs :: Flag [String] + , buildTools :: Flag [String] + , initializeTestSuite :: Flag Bool + , testDirs :: Flag [String] + , initHcPath :: Flag FilePath + , initVerbosity :: Flag Verbosity + , overwrite :: Flag Bool + } deriving (Eq, Show, Generic) + +instance Monoid InitFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup InitFlags where + (<>) = gmappend + +-- -------------------------------------------------------------------- -- +-- Targets + +-- | 'PkgDescription' represents the relevant options set by the +-- user when building a package description during the init command +-- process. +-- +data PkgDescription = PkgDescription + { _pkgCabalVersion :: CabalSpecVersion + , _pkgName :: P.PackageName + , _pkgVersion :: Version + , _pkgLicense :: SpecLicense + , _pkgAuthor :: String + , _pkgEmail :: String + , _pkgHomePage :: String + , _pkgSynopsis :: String + , _pkgCategory :: String + , _pkgExtraSrcFiles :: Set String + , _pkgExtraDocFiles :: Maybe (Set String) + } deriving (Show, Eq) + +-- | 'LibTarget' represents the relevant options set by the +-- user when building a library package during the init command +-- process. +-- +data LibTarget = LibTarget + { _libSourceDirs :: [String] + , _libLanguage :: Language + , _libExposedModules :: NonEmpty ModuleName + , _libOtherModules :: [ModuleName] + , _libOtherExts :: [Extension] + , _libDependencies :: [P.Dependency] + , _libBuildTools :: [P.Dependency] + } deriving (Show, Eq) + +-- | 'ExeTarget' represents the relevant options set by the +-- user when building an executable package. +-- +data ExeTarget = ExeTarget + { _exeMainIs :: HsFilePath + , _exeApplicationDirs :: [String] + , _exeLanguage :: Language + , _exeOtherModules :: [ModuleName] + , _exeOtherExts :: [Extension] + , _exeDependencies :: [P.Dependency] + , _exeBuildTools :: [P.Dependency] + } deriving (Show, Eq) + +-- | 'TestTarget' represents the relevant options set by the +-- user when building a library package. +-- +data TestTarget = TestTarget + { _testMainIs :: HsFilePath + , _testDirs :: [String] + , _testLanguage :: Language + , _testOtherModules :: [ModuleName] + , _testOtherExts :: [Extension] + , _testDependencies :: [P.Dependency] + , _testBuildTools :: [P.Dependency] + } deriving (Show, Eq) + +-- -------------------------------------------------------------------- -- +-- File creator options + +data WriteOpts = WriteOpts + { _optOverwrite :: Bool + , _optMinimal :: Bool + , _optNoComments :: Bool + , _optVerbosity :: Verbosity + , _optPkgDir :: FilePath + , _optPkgType :: PackageType + , _optPkgName :: P.PackageName + , _optCabalSpec :: CabalSpecVersion + } deriving (Eq, Show) + +data ProjectSettings = ProjectSettings + { _pkgOpts :: WriteOpts + , _pkgDesc :: PkgDescription + , _pkgLibTarget :: Maybe LibTarget + , _pkgExeTarget :: Maybe ExeTarget + , _pkgTestTarget :: Maybe TestTarget + } deriving (Eq, Show) + +-- -------------------------------------------------------------------- -- +-- Other types + +-- | Enum to denote whether the user wants to build a library target, +-- executable target, library and executable targets, or a standalone test suite. +-- +data PackageType = Library | Executable | LibraryAndExecutable | TestSuite + deriving (Eq, Show, Generic) + +data HsFileType + = Literate + | Standard + | InvalidHsPath + deriving (Eq, Show) + +data HsFilePath = HsFilePath + { _hsFilePath :: FilePath + , _hsFileType :: HsFileType + } deriving Eq + +instance Show HsFilePath where + show (HsFilePath fp ty) = case ty of + Literate -> fp + Standard -> fp + InvalidHsPath -> "Invalid haskell source file: " ++ fp + +fromHsFilePath :: HsFilePath -> Maybe FilePath +fromHsFilePath (HsFilePath fp ty) = case ty of + Literate -> Just fp + Standard -> Just fp + InvalidHsPath -> Nothing + +isHsFilePath :: FilePath -> Bool +isHsFilePath fp = case _hsFileType $ toHsFilePath fp of + InvalidHsPath -> False + _ -> True + +toHsFilePath :: FilePath -> HsFilePath +toHsFilePath fp + | takeExtension fp == ".lhs" = HsFilePath fp Literate + | takeExtension fp == ".hs" = HsFilePath fp Standard + | otherwise = HsFilePath fp InvalidHsPath + +toLiterateHs :: HsFilePath -> HsFilePath +toLiterateHs (HsFilePath fp Standard) = HsFilePath + (dropExtension fp ++ ".lhs") + Literate +toLiterateHs a = a + +toStandardHs :: HsFilePath -> HsFilePath +toStandardHs (HsFilePath fp Literate) = HsFilePath + (dropExtension fp ++ ".hs") + Standard +toStandardHs a = a + +mkLiterate :: HsFilePath -> [String] -> [String] +mkLiterate (HsFilePath _ Literate) hs = + (\line -> if null line then line else "> " ++ line) <$> hs +mkLiterate _ hs = hs + +-- -------------------------------------------------------------------- -- +-- Interactive prompt monad + +newtype PurePrompt a = PurePrompt + { _runPrompt + :: NonEmpty String + -> Either BreakException (a, NonEmpty String) + } deriving (Functor) + +evalPrompt :: PurePrompt a -> NonEmpty String -> a +evalPrompt act s = case _runPrompt act s of + Left e -> error $ show e + Right (a,_) -> a + +instance Applicative PurePrompt where + pure a = PurePrompt $ \s -> Right (a, s) + PurePrompt ff <*> PurePrompt aa = PurePrompt $ \s -> case ff s of + Left e -> Left e + Right (f, s') -> case aa s' of + Left e -> Left e + Right (a, s'') -> Right (f a, s'') + +instance Monad PurePrompt where + return = pure + PurePrompt a >>= k = PurePrompt $ \s -> case a s of + Left e -> Left e + Right (a', s') -> _runPrompt (k a') s' + +class Monad m => Interactive m where + -- input functions + getLine :: m String + readFile :: FilePath -> m String + getCurrentDirectory :: m FilePath + getHomeDirectory :: m FilePath + getDirectoryContents :: FilePath -> m [FilePath] + listDirectory :: FilePath -> m [FilePath] + doesDirectoryExist :: FilePath -> m Bool + doesFileExist :: FilePath -> m Bool + canonicalizePathNoThrow :: FilePath -> m FilePath + readProcessWithExitCode :: FilePath -> [String] -> String -> m (ExitCode, String, String) + getEnvironment :: m [(String, String)] + getCurrentYear :: m Integer + listFilesInside :: (FilePath -> m Bool) -> FilePath -> m [FilePath] + listFilesRecursive :: FilePath -> m [FilePath] + + -- output functions + putStr :: String -> m () + putStrLn :: String -> m () + createDirectory :: FilePath -> m () + removeDirectory :: FilePath -> m () + writeFile :: FilePath -> String -> m () + removeExistingFile :: FilePath -> m () + copyFile :: FilePath -> FilePath -> m () + renameDirectory :: FilePath -> FilePath -> m () + hFlush :: System.IO.Handle -> m () + message :: Verbosity -> Severity -> String -> m () + + -- misc functions + break :: m Bool + throwPrompt :: BreakException -> m a + +instance Interactive IO where + getLine = P.getLine + readFile = P.readFile + getCurrentDirectory = P.getCurrentDirectory + getHomeDirectory = P.getHomeDirectory + getDirectoryContents = P.getDirectoryContents + listDirectory = P.listDirectory + doesDirectoryExist = P.doesDirectoryExist + doesFileExist = P.doesFileExist + canonicalizePathNoThrow = P.canonicalizePathNoThrow + readProcessWithExitCode = P.readProcessWithExitCode + getEnvironment = P.getEnvironment + getCurrentYear = P.getCurrentYear + listFilesInside = P.listFilesInside + listFilesRecursive = P.listFilesRecursive + + putStr = P.putStr + putStrLn = P.putStrLn + createDirectory = P.createDirectory + removeDirectory = P.removeDirectoryRecursive + writeFile = P.writeFile + removeExistingFile = P.removeExistingFile + copyFile = P.copyFile + renameDirectory = P.renameDirectory + hFlush = System.IO.hFlush + message q severity msg + | q == silent = pure () + | otherwise = putStrLn $ "[" ++ show severity ++ "] " ++ msg + break = return False + throwPrompt = throwM + +instance Interactive PurePrompt where + getLine = pop + readFile !_ = pop + getCurrentDirectory = popAbsolute + getHomeDirectory = popAbsolute + -- expects stack input of form "[\"foo\", \"bar\", \"baz\"]" + getDirectoryContents !_ = popList + listDirectory !_ = popList + doesDirectoryExist !_ = popBool + doesFileExist !_ = popBool + canonicalizePathNoThrow !_ = popAbsolute + readProcessWithExitCode !_ !_ !_ = do + input <- pop + return (ExitSuccess, input, "") + getEnvironment = fmap (map read) popList + getCurrentYear = fmap read pop + listFilesInside pred' !_ = do + input <- map splitDirectories <$> popList + map joinPath <$> filterM (fmap and . traverse pred') input + listFilesRecursive !_ = popList + + putStr !_ = return () + putStrLn !_ = return () + createDirectory !d = checkInvalidPath d () + removeDirectory !d = checkInvalidPath d () + writeFile !f !_ = checkInvalidPath f () + removeExistingFile !f = checkInvalidPath f () + copyFile !f !_ = checkInvalidPath f () + renameDirectory !d !_ = checkInvalidPath d () + hFlush _ = return () + message !_ !severity !msg = case severity of + Error -> PurePrompt $ \_ -> Left $ BreakException + (show severity ++ ": " ++ msg) + _ -> return () + + break = return True + throwPrompt (BreakException e) = PurePrompt $ \s -> Left $ BreakException + ("Error: " ++ e ++ "\nStacktrace: " ++ show s) + +pop :: PurePrompt String +pop = PurePrompt $ \ (p:|ps) -> Right (p,fromList ps) + +popAbsolute :: PurePrompt String +popAbsolute = do + input <- pop + return $ "/home/test/" ++ input + +popBool :: PurePrompt Bool +popBool = pop >>= \case + "True" -> pure True + "False" -> pure False + s -> throwPrompt $ BreakException $ "popBool: " ++ s + +popList :: PurePrompt [String] +popList = pop >>= \a -> case P.safeRead a of + Nothing -> throwPrompt $ BreakException ("popList: " ++ show a) + Just as -> return as + +checkInvalidPath :: String -> a -> PurePrompt a +checkInvalidPath path act = + -- The check below is done this way so it's easier to append + -- more invalid paths in the future, if necessary + if path `elem` ["."] then + throwPrompt $ BreakException $ "Invalid path: " ++ path + else + return act + +-- | A pure exception thrown exclusively by the pure prompter +-- to cancel infinite loops in the prompting process. +-- +-- For example, in order to break on parse errors, or user-driven +-- continuations that do not make sense to test. +-- +newtype BreakException = BreakException String deriving (Eq, Show) + +instance Exception BreakException + +-- | Used to inform the intent of prompted messages. +-- +data Severity = Log | Info | Warning | Error deriving (Eq, Show) + +-- | Convenience alias for the literate haskell flag +-- +type IsLiterate = Bool + +-- | Convenience alias for generating simple projects +-- +type IsSimple = Bool + +-- | Defines whether or not a prompt will have a default value, +-- is optional, or is mandatory. +data DefaultPrompt t + = DefaultPrompt t + | OptionalPrompt + | MandatoryPrompt + deriving (Eq, Functor) + +-- -------------------------------------------------------------------- -- +-- Field annotation for pretty formatters + +-- | Annotations for cabal file PrettyField. +data FieldAnnotation = FieldAnnotation + { annCommentedOut :: Bool + -- ^ True iif the field and its contents should be commented out. + , annCommentLines :: CommentPosition + -- ^ Comment lines to place before the field or section. + } diff --git a/cabal/cabal-install/src/Distribution/Client/Init/Utils.hs b/cabal/cabal-install/src/Distribution/Client/Init/Utils.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Init/Utils.hs @@ -0,0 +1,345 @@ +{-# LANGUAGE RecordWildCards #-} + +module Distribution.Client.Init.Utils +( SourceFileEntry(..) +, retrieveSourceFiles +, retrieveModuleName +, retrieveModuleImports +, retrieveModuleExtensions +, retrieveBuildTools +, retrieveDependencies +, isMain +, isHaskell +, isSourceFile +, trim +, currentDirPkgName +, filePathToPkgName +, mkPackageNameDep +, fixupDocFiles +, mkStringyDep +, getBaseDep +, addLibDepToExe +, addLibDepToTest +) where + + +import qualified Prelude () +import Distribution.Client.Compat.Prelude hiding (putStrLn, empty, readFile, Parsec, many) +import Distribution.Utils.Generic (isInfixOf, safeLast) + +import Control.Monad (forM) + +import qualified Data.List.NonEmpty as NE +import qualified Data.Map as M +import Language.Haskell.Extension (Extension(..)) +import System.FilePath + +import Distribution.CabalSpecVersion (CabalSpecVersion(..)) +import Distribution.ModuleName (ModuleName) +import Distribution.InstalledPackageInfo (InstalledPackageInfo, exposed) +import qualified Distribution.Package as P +import Distribution.Simple.PackageIndex (InstalledPackageIndex, moduleNameIndex) +import Distribution.Simple.Setup (Flag(..)) +import Distribution.Utils.String (trim) +import Distribution.Version +import Distribution.Client.Init.Defaults +import Distribution.Client.Init.Types +import Distribution.Client.Utils (pvpize) +import Distribution.Types.PackageName +import Distribution.Types.Dependency (Dependency, mkDependency) +import qualified Distribution.Compat.NonEmptySet as NES +import Distribution.Types.LibraryName +import Distribution.Verbosity (silent) + + +-- |Data type of source files found in the working directory +data SourceFileEntry = SourceFileEntry + { relativeSourcePath :: FilePath + , moduleName :: ModuleName + , fileExtension :: String + , imports :: [ModuleName] + , extensions :: [Extension] + } deriving Show + +-- Unfortunately we cannot use the version exported by Distribution.Simple.Program +knownSuffixHandlers :: CabalSpecVersion -> String -> String +knownSuffixHandlers v s + | v < CabalSpecV3_0 = case s of + ".gc" -> "greencard" + ".chs" -> "chs" + ".hsc" -> "hsc2hs" + ".x" -> "alex" + ".y" -> "happy" + ".ly" -> "happy" + ".cpphs" -> "cpp" + _ -> "" + | otherwise = case s of + ".gc" -> "greencard:greencard" + ".chs" -> "chs:chs" + ".hsc" -> "hsc2hs:hsc2hs" + ".x" -> "alex:alex" + ".y" -> "happy:happy" + ".ly" -> "happy:happy" + ".cpphs" -> "cpp:cpp" + _ -> "" + + +-- | Check if a given file has main file characteristics +isMain :: String -> Bool +isMain f = (isInfixOf "Main" f || isInfixOf "main" f) + && isSuffixOf ".hs" f || isSuffixOf ".lhs" f + +-- | Check if a given file has a Haskell extension +isHaskell :: String -> Bool +isHaskell f = isSuffixOf ".hs" f || isSuffixOf ".lhs" f + +isBuildTool :: CabalSpecVersion -> String -> Bool +isBuildTool v = not . null . knownSuffixHandlers v . takeExtension + +retrieveBuildTools :: Interactive m => CabalSpecVersion -> FilePath -> m [Dependency] +retrieveBuildTools v fp = do + exists <- doesDirectoryExist fp + if exists + then do + files <- fmap takeExtension <$> listFilesRecursive fp + + let tools = + [ mkStringyDep (knownSuffixHandlers v f) + | f <- files, isBuildTool v f + ] + + return tools + + else + return [] + +retrieveSourceFiles :: Interactive m => FilePath -> m [SourceFileEntry] +retrieveSourceFiles fp = do + exists <- doesDirectoryExist fp + if exists + then do + files <- filter isHaskell <$> listFilesRecursive fp + + entries <- forM files $ \f -> do + exists' <- doesFileExist f + if exists' + then do + maybeModuleName <- retrieveModuleName f + case maybeModuleName of + Nothing -> return Nothing + Just moduleName -> do + + let fileExtension = takeExtension f + relativeSourcePath <- makeRelative f <$> getCurrentDirectory + imports <- retrieveModuleImports f + extensions <- retrieveModuleExtensions f + + return . Just $ SourceFileEntry {..} + else + return Nothing + + return . catMaybes $ entries + + else + return [] + +-- | Given a module, retrieve its name +retrieveModuleName :: Interactive m => FilePath -> m (Maybe ModuleName) +retrieveModuleName m = do + rawModule <- trim . grabModuleName <$> readFile m + + if isInfixOf rawModule (dirToModuleName m) + then + return $ Just $ fromString rawModule + else do + putStrLn + $ "Warning: found module that doesn't match directory structure: " + ++ rawModule + return Nothing + where + dirToModuleName = map (\x -> if x == '/' || x == '\\' then '.' else x) + + stop c = (c /= '\n') && (c /= ' ') + + grabModuleName [] = [] + grabModuleName ('-':'-':xs) = grabModuleName $ dropWhile' (/= '\n') xs + grabModuleName ('m':'o':'d':'u':'l':'e':' ':xs) = takeWhile' stop xs + grabModuleName (_:xs) = grabModuleName xs + +-- | Given a module, retrieve all of its imports +retrieveModuleImports :: Interactive m => FilePath -> m [ModuleName] +retrieveModuleImports m = do + map (fromString . trim) . grabModuleImports <$> readFile m + + where + stop c = (c /= '\n') && (c /= ' ') && (c /= '(') + + grabModuleImports [] = [] + grabModuleImports ('-':'-':xs) = grabModuleImports $ dropWhile' (/= '\n') xs + grabModuleImports ('i':'m':'p':'o':'r':'t':' ':xs) = case trim xs of -- in case someone uses a weird formatting + ('q':'u':'a':'l':'i':'f':'i':'e':'d':' ':ys) -> takeWhile' stop ys : grabModuleImports (dropWhile' stop ys) + _ -> takeWhile' stop xs : grabModuleImports (dropWhile' stop xs) + grabModuleImports (_:xs) = grabModuleImports xs + +-- | 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 + + where + stop c = (c /= '\n') && (c /= ' ') && (c /= ',') && (c /= '#') + + grabModuleExtensions [] = [] + grabModuleExtensions ('-':'-':xs) = grabModuleExtensions $ dropWhile' (/= '\n') xs + grabModuleExtensions ('L':'A':'N':'G':'U':'A':'G':'E':xs) = takeWhile' stop xs : grabModuleExtensions' (dropWhile' stop xs) + grabModuleExtensions (_:xs) = grabModuleExtensions xs + + grabModuleExtensions' [] = [] + grabModuleExtensions' ('#':xs) = grabModuleExtensions xs + grabModuleExtensions' (',':xs) = takeWhile' stop xs : grabModuleExtensions' (dropWhile' stop xs) + grabModuleExtensions' (_:xs) = grabModuleExtensions xs + +takeWhile' :: (Char -> Bool) -> String -> String +takeWhile' p = takeWhile p . trim + +dropWhile' :: (Char -> Bool) -> String -> String +dropWhile' p = dropWhile p . trim + +-- | Check whether a potential source file is located in one of the +-- source directories. +isSourceFile :: Maybe [FilePath] -> SourceFileEntry -> Bool +isSourceFile Nothing sf = isSourceFile (Just ["."]) sf +isSourceFile (Just srcDirs) sf = any (equalFilePath (relativeSourcePath sf)) srcDirs + +retrieveDependencies :: Interactive m => Verbosity -> InitFlags -> [(ModuleName, ModuleName)] -> InstalledPackageIndex -> m [P.Dependency] +retrieveDependencies v flags mods' pkgIx = do + let mods = mods' + + modMap :: M.Map ModuleName [InstalledPackageInfo] + modMap = M.map (filter exposed) $ moduleNameIndex pkgIx + + modDeps :: [(ModuleName, ModuleName, Maybe [InstalledPackageInfo])] + modDeps = map (\(mn, ds) -> (mn, ds, M.lookup ds modMap)) mods + -- modDeps = map (id &&& flip M.lookup modMap) mods + + message v Log "Guessing dependencies..." + nub . catMaybes <$> traverse (chooseDep v flags) modDeps + +-- Given a module and a list of installed packages providing it, +-- choose a dependency (i.e. package + version range) to use for that +-- module. +chooseDep + :: Interactive m + => Verbosity + -> InitFlags + -> (ModuleName, ModuleName, Maybe [InstalledPackageInfo]) + -> m (Maybe P.Dependency) +chooseDep v flags (importer, m, mipi) = case mipi of + -- We found some packages: group them by name. + Just ps@(_:_) -> + case NE.groupBy (\x y -> P.pkgName x == P.pkgName y) $ map P.packageId ps of + -- if there's only one group, i.e. multiple versions of a single package, + -- we make it into a dependency, choosing the latest-ish version. + + -- Given a list of available versions of the same package, pick a dependency. + [grp] -> fmap Just $ case grp of + + -- If only one version, easy. We change e.g. 0.4.2 into 0.4.* + (pid:|[]) -> + return $ P.Dependency + (P.pkgName pid) + (pvpize desugar . P.pkgVersion $ pid) + P.mainLibSet --TODO sublibraries + + -- Otherwise, choose the latest version and issue a warning. + pids -> do + message v Warning ("multiple versions of " ++ prettyShow (P.pkgName . NE.head $ pids) ++ " provide " ++ prettyShow m ++ ", choosing the latest.") + return $ P.Dependency + (P.pkgName . NE.head $ pids) + (pvpize desugar . maximum . fmap P.pkgVersion $ pids) + P.mainLibSet --TODO take into account sublibraries + + -- if multiple packages are found, we refuse to choose between + -- different packages and make the user do it + grps -> do + message v Warning ("multiple packages found providing " ++ prettyShow m ++ ": " ++ intercalate ", " (fmap (prettyShow . P.pkgName . NE.head) grps)) + message v Warning "You will need to pick one and manually add it to the build-depends field." + return Nothing + + _ -> do + message v Warning ("no package found providing " ++ prettyShow m ++ " in " ++ prettyShow importer ++ ".") + return Nothing + + where + -- desugar if cabal version lower than 2.0 + desugar = case cabalVersion flags of + Flag x -> x < CabalSpecV2_0 + NoFlag -> defaultCabalVersion < CabalSpecV2_0 + +filePathToPkgName :: Interactive m => FilePath -> m P.PackageName +filePathToPkgName = fmap (mkPackageName . repair . fromMaybe "" . safeLast . splitDirectories) + . canonicalizePathNoThrow + where + -- Treat each span of non-alphanumeric characters as a hyphen. Each + -- hyphenated component of a package name must contain at least one + -- alphabetic character. An arbitrary character ('x') will be prepended if + -- this is not the case for the first component, and subsequent components + -- will simply be run together. For example, "1+2_foo-3" will become + -- "x12-foo3". + repair = repair' ('x' :) id + repair' invalid valid x = case dropWhile (not . isAlphaNum) x of + "" -> repairComponent "" + x' -> let (c, r) = first repairComponent $ span isAlphaNum x' + in c ++ repairRest r + where + repairComponent c | all isDigit c = invalid c + | otherwise = valid c + repairRest = repair' id ('-' :) + +currentDirPkgName :: Interactive m => m P.PackageName +currentDirPkgName = filePathToPkgName =<< getCurrentDirectory + +mkPackageNameDep :: PackageName -> Dependency +mkPackageNameDep pkg = mkDependency pkg anyVersion (NES.singleton LMainLibName) + +-- when cabal-version < 1.18, extra-doc-files is not supported +-- so whatever the user wants as doc files should be dumped into +-- extra-src-files. +-- +fixupDocFiles :: Interactive m => Verbosity -> PkgDescription -> m PkgDescription +fixupDocFiles v pkgDesc + | _pkgCabalVersion pkgDesc < CabalSpecV1_18 = do + message v Warning $ concat + [ "Cabal spec versions < 1.18 do not support extra-doc-files. " + , "Doc files will be treated as extra-src-files." + ] + + return $ pkgDesc + { _pkgExtraSrcFiles =_pkgExtraSrcFiles pkgDesc + <> fromMaybe mempty (_pkgExtraDocFiles pkgDesc) + , _pkgExtraDocFiles = Nothing + } + | otherwise = return pkgDesc + +mkStringyDep :: String -> Dependency +mkStringyDep = mkPackageNameDep . mkPackageName + + +getBaseDep :: Interactive m => InstalledPackageIndex -> InitFlags -> m [Dependency] +getBaseDep pkgIx flags = retrieveDependencies silent flags + [(fromString "Prelude", fromString "Prelude")] pkgIx + +-- Add package name as dependency of test suite +-- +addLibDepToTest :: PackageName -> Maybe TestTarget -> Maybe TestTarget +addLibDepToTest _ Nothing = Nothing +addLibDepToTest n (Just t) = Just $ t + { _testDependencies = _testDependencies t ++ [mkPackageNameDep n] + } + +-- Add package name as dependency of executable +-- +addLibDepToExe :: PackageName -> ExeTarget -> ExeTarget +addLibDepToExe n exe = exe + { _exeDependencies = _exeDependencies exe ++ [mkPackageNameDep n] + } diff --git a/cabal/cabal-install/src/Distribution/Client/Install.hs b/cabal/cabal-install/src/Distribution/Client/Install.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Install.hs @@ -0,0 +1,1569 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Install +-- Copyright : (c) 2005 David Himmelstrup +-- 2007 Bjorn Bringert +-- 2007-2010 Duncan Coutts +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- High level interface to package installation. +----------------------------------------------------------------------------- +module Distribution.Client.Install ( + -- * High-level interface + install, + + -- * Lower-level interface that allows to manipulate the install plan + makeInstallContext, + makeInstallPlan, + processInstallPlan, + InstallArgs, + InstallContext, + + -- * Prune certain packages from the install plan + pruneInstallPlan + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude +import Distribution.Utils.Generic(safeLast) + +import qualified Data.List.NonEmpty as NE +import qualified Data.Map as Map +import Control.Exception as Exception + ( bracket, catches, Handler(Handler), handleJust ) +import System.Directory + ( getTemporaryDirectory, doesDirectoryExist, doesFileExist, + createDirectoryIfMissing, removeFile, renameDirectory, + getDirectoryContents ) +import System.FilePath + ( (), (<.>), equalFilePath, takeDirectory ) +import System.IO + ( openFile, IOMode(AppendMode), hClose ) +import System.IO.Error + ( isDoesNotExistError, ioeGetFileName ) + +import Distribution.Client.Targets +import Distribution.Client.Configure + ( chooseCabalVersion, configureSetupScript, checkConfigExFlags ) +import Distribution.Client.Dependency +import Distribution.Client.Dependency.Types + ( Solver(..) ) +import Distribution.Client.FetchUtils +import Distribution.Client.HttpUtils + ( HttpTransport (..) ) +import Distribution.Solver.Types.PackageFixedDeps +import qualified Distribution.Client.Haddock as Haddock (regenerateHaddockIndex) +import Distribution.Client.IndexUtils as IndexUtils + ( getSourcePackagesAtIndexState, getInstalledPackages ) +import qualified Distribution.Client.InstallPlan as InstallPlan +import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan +import Distribution.Client.InstallPlan (InstallPlan) +import Distribution.Client.SolverInstallPlan (SolverInstallPlan) +import Distribution.Client.Setup + ( GlobalFlags(..), RepoContext(..) + , ConfigFlags(..), configureCommand, filterConfigureFlags + , ConfigExFlags(..), InstallFlags(..) + , filterTestFlags ) +import Distribution.Client.Config + ( getCabalDir, defaultUserInstall ) +import Distribution.Client.Tar (extractTarGzFile) +import Distribution.Client.Types as Source +import Distribution.Client.BuildReports.Types + ( ReportLevel(..) ) +import Distribution.Client.SetupWrapper + ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) +import Distribution.Client.BuildReports.Anonymous (showBuildReport) +import qualified Distribution.Client.BuildReports.Anonymous as BuildReports +import qualified Distribution.Client.BuildReports.Storage as BuildReports + ( storeAnonymous, storeLocal, fromInstallPlan, fromPlanningFailure ) +import qualified Distribution.Client.InstallSymlink as InstallSymlink + ( symlinkBinaries ) +import Distribution.Client.Types.OverwritePolicy (OverwritePolicy (..)) +import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade +import qualified Distribution.InstalledPackageInfo as Installed +import Distribution.Client.JobControl + +import qualified Distribution.Solver.Types.ComponentDeps as CD +import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.LabeledPackageConstraint +import Distribution.Solver.Types.OptionalStanza +import qualified Distribution.Solver.Types.PackageIndex as SourcePackageIndex +import Distribution.Solver.Types.PkgConfigDb + ( PkgConfigDb, readPkgConfigDb ) +import Distribution.Solver.Types.SourcePackage as SourcePackage + +import Distribution.Utils.NubList +import Distribution.Simple.Compiler + ( CompilerId(..), Compiler(compilerId), compilerFlavor + , CompilerInfo(..), compilerInfo, PackageDB(..), PackageDBStack ) +import Distribution.Simple.Program (ProgramDb) +import qualified Distribution.Simple.InstallDirs as InstallDirs +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.PackageIndex (InstalledPackageIndex) +import Distribution.Simple.Setup + ( haddockCommand, HaddockFlags(..) + , buildCommand, BuildFlags(..), emptyBuildFlags + , TestFlags, BenchmarkFlags + , toFlag, fromFlag, fromFlagOrDefault, flagToMaybe, defaultDistPref ) +import qualified Distribution.Simple.Setup as Cabal + ( Flag(..) + , copyCommand, CopyFlags(..), emptyCopyFlags + , registerCommand, RegisterFlags(..), emptyRegisterFlags + , testCommand, TestFlags(..) ) +import Distribution.Simple.Utils + ( createDirectoryIfMissingVerbose, writeFileAtomic ) +import Distribution.Simple.InstallDirs as InstallDirs + ( PathTemplate, fromPathTemplate, toPathTemplate, substPathTemplate + , initialPathTemplateEnv, installDirsTemplateEnv ) +import Distribution.Simple.Configure (interpretPackageDbFlags) +import Distribution.Simple.Register (registerPackage, defaultRegisterOptions) +import Distribution.Package + ( PackageIdentifier(..), PackageId, packageName, packageVersion + , Package(..), HasMungedPackageId(..), HasUnitId(..) + , UnitId ) +import Distribution.Types.GivenComponent + ( GivenComponent(..) ) +import Distribution.Types.PackageVersionConstraint + ( PackageVersionConstraint(..), thisPackageVersionConstraint ) +import Distribution.Types.MungedPackageId +import qualified Distribution.PackageDescription as PackageDescription +import Distribution.PackageDescription + ( PackageDescription, GenericPackageDescription(..) ) +import Distribution.Types.Flag + ( PackageFlag(..), FlagAssignment, mkFlagAssignment + , showFlagAssignment, diffFlagAssignment, nullFlagAssignment ) +import Distribution.PackageDescription.Configuration + ( finalizePD ) +import Distribution.Version + ( Version, VersionRange, foldVersionRange ) +import Distribution.Simple.Utils as Utils + ( notice, info, warn, debug, debugNoWrap, die' + , withTempDirectory ) +import Distribution.Client.Utils + ( determineNumJobs, logDirChange, mergeBy, MergeResult(..) + , ProgressPhase(..), progressMessage ) +import Distribution.System + ( Platform, OS(Windows), buildOS, buildPlatform ) +import Distribution.Verbosity as Verbosity + ( modifyVerbosity, normal, verbose ) +import Distribution.Simple.BuildPaths ( exeExtension ) + +import qualified Data.ByteString as BS + +--TODO: +-- * assign flags to packages individually +-- * complain about flags that do not apply to any package given as target +-- so flags do not apply to dependencies, only listed, can use flag +-- constraints for dependencies +-- * allow flag constraints +-- * allow installed constraints +-- * allow flag and installed preferences +-- * allow persistent configure flags for each package individually + +-- ------------------------------------------------------------ +-- * Top level user actions +-- ------------------------------------------------------------ + +-- | Installs the packages needed to satisfy a list of dependencies. +-- +install + :: Verbosity + -> PackageDBStack + -> RepoContext + -> Compiler + -> Platform + -> ProgramDb + -> GlobalFlags + -> ConfigFlags + -> ConfigExFlags + -> InstallFlags + -> HaddockFlags + -> TestFlags + -> BenchmarkFlags + -> [UserTarget] + -> IO () +install verbosity packageDBs repos comp platform progdb + globalFlags configFlags configExFlags installFlags + haddockFlags testFlags benchmarkFlags userTargets0 = do + + unless (installRootCmd installFlags == Cabal.NoFlag) $ + warn verbosity $ "--root-cmd is no longer supported, " + ++ "see https://github.com/haskell/cabal/issues/3353" + ++ " (if you didn't type --root-cmd, comment out root-cmd" + ++ " in your ~/.cabal/config file)" + let userOrSandbox = fromFlag (configUserInstall configFlags) + unless userOrSandbox $ + warn verbosity $ "the --global flag is deprecated -- " + ++ "it is generally considered a bad idea to install packages " + ++ "into the global store" + + installContext <- makeInstallContext verbosity args (Just userTargets0) + planResult <- foldProgress logMsg (return . Left) (return . Right) =<< + makeInstallPlan verbosity args installContext + + case planResult of + Left message -> do + reportPlanningFailure verbosity args installContext message + die'' message + Right installPlan -> + processInstallPlan verbosity args installContext installPlan + where + args :: InstallArgs + args = (packageDBs, repos, comp, platform, progdb, + globalFlags, configFlags, configExFlags, + installFlags, haddockFlags, testFlags, benchmarkFlags) + + die'' = die' verbosity + + logMsg message rest = debugNoWrap verbosity message >> rest + +-- TODO: Make InstallContext a proper data type with documented fields. +-- | Common context for makeInstallPlan and processInstallPlan. +type InstallContext = ( InstalledPackageIndex, SourcePackageDb + , PkgConfigDb + , [UserTarget], [PackageSpecifier UnresolvedSourcePackage] + , HttpTransport ) + +-- TODO: Make InstallArgs a proper data type with documented fields or just get +-- rid of it completely. +-- | Initial arguments given to 'install' or 'makeInstallContext'. +type InstallArgs = ( PackageDBStack + , RepoContext + , Compiler + , Platform + , ProgramDb + , GlobalFlags + , ConfigFlags + , ConfigExFlags + , InstallFlags + , HaddockFlags + , TestFlags + , BenchmarkFlags ) + +-- | Make an install context given install arguments. +makeInstallContext :: Verbosity -> InstallArgs -> Maybe [UserTarget] + -> IO InstallContext +makeInstallContext verbosity + (packageDBs, repoCtxt, comp, _, progdb, + _, _, configExFlags, installFlags, _, _, _) mUserTargets = do + + let idxState = flagToMaybe (installIndexState installFlags) + + installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb + (sourcePkgDb, _, _) <- getSourcePackagesAtIndexState verbosity repoCtxt idxState Nothing + pkgConfigDb <- readPkgConfigDb verbosity progdb + + checkConfigExFlags verbosity installedPkgIndex + (packageIndex sourcePkgDb) configExFlags + transport <- repoContextGetTransport repoCtxt + + (userTargets, pkgSpecifiers) <- case mUserTargets of + Nothing -> + -- We want to distinguish between the case where the user has given an + -- empty list of targets on the command-line and the case where we + -- specifically want to have an empty list of targets. + return ([], []) + Just userTargets0 -> do + -- For install, if no target is given it means we use the current + -- directory as the single target. + let userTargets | null userTargets0 = [UserTargetLocalDir "."] + | otherwise = userTargets0 + + pkgSpecifiers <- resolveUserTargets verbosity repoCtxt + (packageIndex sourcePkgDb) + userTargets + return (userTargets, pkgSpecifiers) + + return (installedPkgIndex, sourcePkgDb, pkgConfigDb, userTargets + ,pkgSpecifiers, transport) + +-- | Make an install plan given install context and install arguments. +makeInstallPlan :: Verbosity -> InstallArgs -> InstallContext + -> IO (Progress String String SolverInstallPlan) +makeInstallPlan verbosity + (_, _, comp, platform,_, + _, configFlags, configExFlags, installFlags, + _, _, _) + (installedPkgIndex, sourcePkgDb, pkgConfigDb, + _, pkgSpecifiers, _) = do + + solver <- chooseSolver verbosity (fromFlag (configSolver configExFlags)) + (compilerInfo comp) + notice verbosity "Resolving dependencies..." + return $ planPackages verbosity comp platform solver + configFlags configExFlags installFlags + installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers + +-- | Given an install plan, perform the actual installations. +processInstallPlan :: Verbosity -> InstallArgs -> InstallContext + -> SolverInstallPlan + -> IO () +processInstallPlan verbosity + args@(_,_, _, _, _, _, configFlags, _, installFlags, _, _, _) + (installedPkgIndex, sourcePkgDb, _, + userTargets, pkgSpecifiers, _) installPlan0 = do + + checkPrintPlan verbosity installedPkgIndex installPlan sourcePkgDb + installFlags pkgSpecifiers + + unless (dryRun || nothingToInstall) $ do + buildOutcomes <- performInstallations verbosity + args installedPkgIndex installPlan + postInstallActions verbosity args userTargets installPlan buildOutcomes + where + installPlan = InstallPlan.configureInstallPlan configFlags installPlan0 + dryRun = fromFlag (installDryRun installFlags) + nothingToInstall = null (fst (InstallPlan.ready installPlan)) + +-- ------------------------------------------------------------ +-- * Installation planning +-- ------------------------------------------------------------ + +planPackages :: Verbosity + -> Compiler + -> Platform + -> Solver + -> ConfigFlags + -> ConfigExFlags + -> InstallFlags + -> InstalledPackageIndex + -> SourcePackageDb + -> PkgConfigDb + -> [PackageSpecifier UnresolvedSourcePackage] + -> Progress String String SolverInstallPlan +planPackages verbosity comp platform solver + configFlags configExFlags installFlags + installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers = + + resolveDependencies + platform (compilerInfo comp) pkgConfigDb + solver + resolverParams + + >>= if onlyDeps then pruneInstallPlan pkgSpecifiers else return + + where + resolverParams = + + setMaxBackjumps (if maxBackjumps < 0 then Nothing + else Just maxBackjumps) + + . setIndependentGoals independentGoals + + . setReorderGoals reorderGoals + + . setCountConflicts countConflicts + + . setFineGrainedConflicts fineGrainedConflicts + + . setMinimizeConflictSet minimizeConflictSet + + . setAvoidReinstalls avoidReinstalls + + . setShadowPkgs shadowPkgs + + . setStrongFlags strongFlags + + . setAllowBootLibInstalls allowBootLibInstalls + + . setOnlyConstrained onlyConstrained + + . setSolverVerbosity verbosity + + . setPreferenceDefault (if upgradeDeps then PreferAllLatest + else PreferLatestForSelected) + + . removeLowerBounds allowOlder + . removeUpperBounds allowNewer + + . addPreferences + -- preferences from the config file or command line + [ PackageVersionPreference name ver + | PackageVersionConstraint name ver <- configPreferences configExFlags ] + + . addConstraints + -- version constraints from the config file or command line + [ LabeledPackageConstraint (userToPackageConstraint pc) src + | (pc, src) <- configExConstraints configExFlags ] + + . addConstraints + --FIXME: this just applies all flags to all targets which + -- is silly. We should check if the flags are appropriate + [ let pc = PackageConstraint + (scopeToplevel $ pkgSpecifierTarget pkgSpecifier) + (PackagePropertyFlags flags) + in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget + | let flags = configConfigurationsFlags configFlags + , not (nullFlagAssignment flags) + , pkgSpecifier <- pkgSpecifiers ] + + . addConstraints + [ let pc = PackageConstraint + (scopeToplevel $ pkgSpecifierTarget pkgSpecifier) + (PackagePropertyStanzas stanzas) + in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget + | pkgSpecifier <- pkgSpecifiers ] + + . (if reinstall then reinstallTargets else id) + + -- Don't solve for executables, the legacy install codepath + -- doesn't understand how to install them + . setSolveExecutables (SolveExecutables False) + + $ standardInstallPolicy + installedPkgIndex sourcePkgDb pkgSpecifiers + + stanzas = [ TestStanzas | testsEnabled ] + ++ [ BenchStanzas | benchmarksEnabled ] + testsEnabled = fromFlagOrDefault False $ configTests configFlags + benchmarksEnabled = fromFlagOrDefault False $ configBenchmarks configFlags + + reinstall = fromFlag (installOverrideReinstall installFlags) || + fromFlag (installReinstall installFlags) + reorderGoals = fromFlag (installReorderGoals installFlags) + countConflicts = fromFlag (installCountConflicts installFlags) + fineGrainedConflicts = fromFlag (installFineGrainedConflicts installFlags) + minimizeConflictSet = fromFlag (installMinimizeConflictSet installFlags) + independentGoals = fromFlag (installIndependentGoals installFlags) + avoidReinstalls = fromFlag (installAvoidReinstalls installFlags) + shadowPkgs = fromFlag (installShadowPkgs installFlags) + strongFlags = fromFlag (installStrongFlags installFlags) + maxBackjumps = fromFlag (installMaxBackjumps installFlags) + allowBootLibInstalls = fromFlag (installAllowBootLibInstalls installFlags) + onlyConstrained = fromFlag (installOnlyConstrained installFlags) + upgradeDeps = fromFlag (installUpgradeDeps installFlags) + onlyDeps = fromFlag (installOnlyDeps installFlags) + + allowOlder = fromMaybe (AllowOlder mempty) + (configAllowOlder configExFlags) + allowNewer = fromMaybe (AllowNewer mempty) + (configAllowNewer configExFlags) + +-- | Remove the provided targets from the install plan. +pruneInstallPlan :: Package targetpkg + => [PackageSpecifier targetpkg] + -> SolverInstallPlan + -> Progress String String SolverInstallPlan +pruneInstallPlan pkgSpecifiers = + -- TODO: this is a general feature and should be moved to D.C.Dependency + -- Also, the InstallPlan.remove should return info more precise to the + -- problem, rather than the very general PlanProblem type. + either (Fail . explain) Done + . SolverInstallPlan.remove (\pkg -> packageName pkg `elem` targetnames) + where + explain :: [SolverInstallPlan.SolverPlanProblem] -> String + explain problems = + "Cannot select only the dependencies (as requested by the " + ++ "'--only-dependencies' flag), " + ++ (case pkgids of + [pkgid] -> "the package " ++ prettyShow pkgid ++ " is " + _ -> "the packages " + ++ intercalate ", " (map prettyShow pkgids) ++ " are ") + ++ "required by a dependency of one of the other targets." + where + pkgids = + nub [ depid + | SolverInstallPlan.PackageMissingDeps _ depids <- problems + , depid <- depids + , packageName depid `elem` targetnames ] + + targetnames = map pkgSpecifierTarget pkgSpecifiers + +-- ------------------------------------------------------------ +-- * Informational messages +-- ------------------------------------------------------------ + +-- | Perform post-solver checks of the install plan and print it if +-- either requested or needed. +checkPrintPlan :: Verbosity + -> InstalledPackageIndex + -> InstallPlan + -> SourcePackageDb + -> InstallFlags + -> [PackageSpecifier UnresolvedSourcePackage] + -> IO () +checkPrintPlan verbosity installed installPlan sourcePkgDb + installFlags pkgSpecifiers = do + + -- User targets that are already installed. + let preExistingTargets = + [ p | let tgts = map pkgSpecifierTarget pkgSpecifiers, + InstallPlan.PreExisting p <- InstallPlan.toList installPlan, + packageName p `elem` tgts ] + + -- If there's nothing to install, we print the already existing + -- target packages as an explanation. + when nothingToInstall $ + notice verbosity $ unlines $ + "All the requested packages are already installed:" + : map (prettyShow . packageId) preExistingTargets + ++ ["Use --reinstall if you want to reinstall anyway."] + + let lPlan = + [ (pkg, status) + | pkg <- InstallPlan.executionOrder installPlan + , let status = packageStatus installed pkg ] + -- Are any packages classified as reinstalls? + let reinstalledPkgs = + [ ipkg + | (_pkg, status) <- lPlan + , ipkg <- extractReinstalls status ] + -- Packages that are already broken. + let oldBrokenPkgs = + map Installed.installedUnitId + . PackageIndex.reverseDependencyClosure installed + . map (Installed.installedUnitId . fst) + . PackageIndex.brokenPackages + $ installed + let excluded = reinstalledPkgs ++ oldBrokenPkgs + -- Packages that are reverse dependencies of replaced packages are very + -- likely to be broken. We exclude packages that are already broken. + let newBrokenPkgs = + filter (\ p -> not (Installed.installedUnitId p `elem` excluded)) + (PackageIndex.reverseDependencyClosure installed reinstalledPkgs) + let containsReinstalls = not (null reinstalledPkgs) + let breaksPkgs = not (null newBrokenPkgs) + + let adaptedVerbosity + | containsReinstalls + , not overrideReinstall = modifyVerbosity (max verbose) verbosity + | otherwise = verbosity + + -- We print the install plan if we are in a dry-run or if we are confronted + -- with a dangerous install plan. + when (dryRun || containsReinstalls && not overrideReinstall) $ + printPlan (dryRun || breaksPkgs && not overrideReinstall) + adaptedVerbosity lPlan sourcePkgDb + + -- If the install plan is dangerous, we print various warning messages. In + -- particular, if we can see that packages are likely to be broken, we even + -- bail out (unless installation has been forced with --force-reinstalls). + when containsReinstalls $ do + if breaksPkgs + then do + (if dryRun || overrideReinstall then warn else die') verbosity $ unlines $ + "The following packages are likely to be broken by the reinstalls:" + : map (prettyShow . mungedId) newBrokenPkgs + ++ if overrideReinstall + then if dryRun then [] else + ["Continuing even though " ++ + "the plan contains dangerous reinstalls."] + else + ["Use --force-reinstalls if you want to install anyway."] + else unless dryRun $ warn verbosity + "Note that reinstalls are always dangerous. Continuing anyway..." + + -- If we are explicitly told to not download anything, check that all packages + -- are already fetched. + let offline = fromFlagOrDefault False (installOfflineMode installFlags) + when offline $ do + let pkgs = [ confPkgSource cpkg + | InstallPlan.Configured cpkg <- InstallPlan.toList installPlan ] + notFetched <- fmap (map packageId) + . filterM (fmap isNothing . checkFetched . srcpkgSource) + $ pkgs + unless (null notFetched) $ + die' verbosity $ "Can't download packages in offline mode. " + ++ "Must download the following packages to proceed:\n" + ++ intercalate ", " (map prettyShow notFetched) + ++ "\nTry using 'cabal fetch'." + + where + nothingToInstall = null (fst (InstallPlan.ready installPlan)) + + dryRun = fromFlag (installDryRun installFlags) + overrideReinstall = fromFlag (installOverrideReinstall installFlags) + +data PackageStatus = NewPackage + | NewVersion [Version] + | Reinstall [UnitId] [PackageChange] + +type PackageChange = MergeResult MungedPackageId MungedPackageId + +extractReinstalls :: PackageStatus -> [UnitId] +extractReinstalls (Reinstall ipids _) = ipids +extractReinstalls _ = [] + +packageStatus :: InstalledPackageIndex + -> ReadyPackage + -> PackageStatus +packageStatus installedPkgIndex cpkg = + case PackageIndex.lookupPackageName installedPkgIndex + (packageName cpkg) of + [] -> NewPackage + ps -> case filter ((== mungedId cpkg) + . mungedId) (concatMap snd ps) of + [] -> NewVersion (map fst ps) + pkgs@(pkg:_) -> Reinstall (map Installed.installedUnitId pkgs) + (changes pkg cpkg) + + where + + changes :: Installed.InstalledPackageInfo + -> ReadyPackage + -> [PackageChange] + changes pkg (ReadyPackage pkg') = filter changed $ + mergeBy (comparing mungedName) + -- deps of installed pkg + (resolveInstalledIds $ Installed.depends pkg) + -- deps of configured pkg + (resolveInstalledIds $ CD.nonSetupDeps (depends pkg')) + + -- convert to source pkg ids via index + resolveInstalledIds :: [UnitId] -> [MungedPackageId] + resolveInstalledIds = + nub + . sort + . map mungedId + . mapMaybe (PackageIndex.lookupUnitId installedPkgIndex) + + changed (InBoth pkgid pkgid') = pkgid /= pkgid' + changed _ = True + +printPlan :: Bool -- is dry run + -> Verbosity + -> [(ReadyPackage, PackageStatus)] + -> SourcePackageDb + -> IO () +printPlan dryRun verbosity plan sourcePkgDb = case plan of + [] -> return () + pkgs + | verbosity >= Verbosity.verbose -> notice verbosity $ unlines $ + ("In order, the following " ++ wouldWill ++ " be installed:") + : map showPkgAndReason pkgs + | otherwise -> notice verbosity $ unlines $ + ("In order, the following " ++ wouldWill + ++ " be installed (use -v for more details):") + : map showPkg pkgs + where + wouldWill | dryRun = "would" + | otherwise = "will" + + showPkg (pkg, _) = prettyShow (packageId pkg) ++ + showLatest (pkg) + + showPkgAndReason (ReadyPackage pkg', pr) = unwords + [ prettyShow (packageId pkg') + , showLatest pkg' + , showFlagAssignment (nonDefaultFlags pkg') + , showStanzas (confPkgStanzas pkg') + , showDep pkg' + , case pr of + NewPackage -> "(new package)" + NewVersion _ -> "(new version)" + Reinstall _ cs -> "(reinstall)" ++ case cs of + [] -> "" + diff -> "(changes: " ++ intercalate ", " (map change diff) + ++ ")" + ] + + showLatest :: Package srcpkg => srcpkg -> String + showLatest pkg = case mLatestVersion of + Just latestVersion -> + if packageVersion pkg < latestVersion + then ("(latest: " ++ prettyShow latestVersion ++ ")") + else "" + Nothing -> "" + where + mLatestVersion :: Maybe Version + mLatestVersion = fmap packageVersion $ + safeLast $ + SourcePackageIndex.lookupPackageName + (packageIndex sourcePkgDb) + (packageName pkg) + + toFlagAssignment :: [PackageFlag] -> FlagAssignment + toFlagAssignment = mkFlagAssignment . map (\ f -> (flagName f, flagDefault f)) + + nonDefaultFlags :: ConfiguredPackage loc -> FlagAssignment + nonDefaultFlags cpkg = + let defaultAssignment = + toFlagAssignment + (genPackageFlags (SourcePackage.srcpkgDescription $ + confPkgSource cpkg)) + in confPkgFlags cpkg `diffFlagAssignment` defaultAssignment + + change (OnlyInLeft pkgid) = prettyShow pkgid ++ " removed" + change (InBoth pkgid pkgid') = prettyShow pkgid ++ " -> " + ++ prettyShow (mungedVersion pkgid') + change (OnlyInRight pkgid') = prettyShow pkgid' ++ " added" + + showDep pkg | Just rdeps <- Map.lookup (packageId pkg) revDeps + = " (via: " ++ unwords (map prettyShow rdeps) ++ ")" + | otherwise = "" + + revDepGraphEdges :: [(PackageId, PackageId)] + revDepGraphEdges = [ (rpid, packageId cpkg) + | (ReadyPackage cpkg, _) <- plan + , ConfiguredId + rpid + (Just + (PackageDescription.CLibName + PackageDescription.LMainLibName)) + _ + <- CD.flatDeps (confPkgDeps cpkg) ] + + revDeps :: Map.Map PackageId [PackageId] + revDeps = Map.fromListWith (++) (map (fmap (:[])) revDepGraphEdges) + +-- ------------------------------------------------------------ +-- * Post installation stuff +-- ------------------------------------------------------------ + +-- | Report a solver failure. This works slightly differently to +-- 'postInstallActions', as (by definition) we don't have an install plan. +reportPlanningFailure :: Verbosity -> InstallArgs -> InstallContext -> String + -> IO () +reportPlanningFailure verbosity + (_, _, comp, platform, _ + ,_, configFlags, _, installFlags, _, _, _) + (_, sourcePkgDb, _, _, pkgSpecifiers, _) + message = do + + when reportFailure $ do + + -- Only create reports for explicitly named packages + let pkgids = filter + (SourcePackageIndex.elemByPackageId (packageIndex sourcePkgDb)) $ + mapMaybe theSpecifiedPackage pkgSpecifiers + + buildReports = BuildReports.fromPlanningFailure platform + (compilerId comp) pkgids + (configConfigurationsFlags configFlags) + + unless (null buildReports) $ + info verbosity $ + "Solver failure will be reported for " + ++ intercalate "," (map prettyShow pkgids) + + -- Save reports + BuildReports.storeLocal (compilerInfo comp) + (fromNubList $ installSummaryFile installFlags) + buildReports platform + + -- Save solver log + case logFile of + Nothing -> return () + Just template -> for_ pkgids $ \pkgid -> + let env = initialPathTemplateEnv pkgid dummyIpid + (compilerInfo comp) platform + path = fromPathTemplate $ substPathTemplate env template + in writeFile path message + + where + reportFailure = fromFlag (installReportPlanningFailure installFlags) + logFile = flagToMaybe (installLogFile installFlags) + + -- A IPID is calculated from the transitive closure of + -- dependencies, but when the solver fails we don't have that. + -- So we fail. + dummyIpid = error "reportPlanningFailure: installed package ID not available" + +-- | If a 'PackageSpecifier' refers to a single package, return Just that +-- package. +theSpecifiedPackage :: Package pkg => PackageSpecifier pkg -> Maybe PackageId +theSpecifiedPackage pkgSpec = + case pkgSpec of + NamedPackage name [PackagePropertyVersion version] + -> PackageIdentifier name <$> trivialRange version + NamedPackage _ _ -> Nothing + SpecificSourcePackage pkg -> Just $ packageId pkg + where + -- | If a range includes only a single version, return Just that version. + trivialRange :: VersionRange -> Maybe Version + trivialRange = foldVersionRange + Nothing + Just -- "== v" + (\_ -> Nothing) + (\_ -> Nothing) + (\_ _ -> Nothing) + (\_ _ -> Nothing) + +-- | Various stuff we do after successful or unsuccessfully installing a bunch +-- of packages. This includes: +-- +-- * build reporting, local and remote +-- * symlinking binaries +-- * updating indexes +-- * error reporting +-- +postInstallActions :: Verbosity + -> InstallArgs + -> [UserTarget] + -> InstallPlan + -> BuildOutcomes + -> IO () +postInstallActions verbosity + (packageDBs, _, comp, platform, progdb + ,globalFlags, configFlags, _, installFlags, _, _, _) + _ installPlan buildOutcomes = do + + let buildReports = BuildReports.fromInstallPlan platform (compilerId comp) + installPlan buildOutcomes + BuildReports.storeLocal (compilerInfo comp) + (fromNubList $ installSummaryFile installFlags) + buildReports + platform + when (reportingLevel >= AnonymousReports) $ + BuildReports.storeAnonymous buildReports + when (reportingLevel == DetailedReports) $ + storeDetailedBuildReports verbosity logsDir buildReports + + regenerateHaddockIndex verbosity packageDBs comp platform progdb + configFlags installFlags buildOutcomes + + symlinkBinaries verbosity platform comp configFlags installFlags + installPlan buildOutcomes + + printBuildFailures verbosity buildOutcomes + + where + reportingLevel = fromFlag (installBuildReports installFlags) + logsDir = fromFlag (globalLogsDir globalFlags) + +storeDetailedBuildReports :: Verbosity -> FilePath + -> [(BuildReports.BuildReport, Maybe Repo)] -> IO () +storeDetailedBuildReports verbosity logsDir reports = sequence_ + [ do dotCabal <- getCabalDir + let logFileName = prettyShow (BuildReports.package report) <.> "log" + logFile = logsDir logFileName + reportsDir = dotCabal "reports" unRepoName (remoteRepoName remoteRepo) + reportFile = reportsDir logFileName + + handleMissingLogFile $ do + buildLog <- readFile logFile + createDirectoryIfMissing True reportsDir -- FIXME + writeFile reportFile (show (showBuildReport report, buildLog)) + + | (report, Just repo) <- reports + , Just remoteRepo <- [maybeRepoRemote repo] + , isLikelyToHaveLogFile (BuildReports.installOutcome report) ] + + where + isLikelyToHaveLogFile BuildReports.ConfigureFailed {} = True + isLikelyToHaveLogFile BuildReports.BuildFailed {} = True + isLikelyToHaveLogFile BuildReports.InstallFailed {} = True + isLikelyToHaveLogFile BuildReports.InstallOk {} = True + isLikelyToHaveLogFile _ = False + + handleMissingLogFile = Exception.handleJust missingFile $ \ioe -> + warn verbosity $ "Missing log file for build report: " + ++ fromMaybe "" (ioeGetFileName ioe) + + missingFile ioe + | isDoesNotExistError ioe = Just ioe + missingFile _ = Nothing + + +regenerateHaddockIndex :: Verbosity + -> [PackageDB] + -> Compiler + -> Platform + -> ProgramDb + -> ConfigFlags + -> InstallFlags + -> BuildOutcomes + -> IO () +regenerateHaddockIndex verbosity packageDBs comp platform progdb + configFlags installFlags buildOutcomes + | haddockIndexFileIsRequested && shouldRegenerateHaddockIndex = do + + defaultDirs <- InstallDirs.defaultInstallDirs + (compilerFlavor comp) + (fromFlag (configUserInstall configFlags)) + True + let indexFileTemplate = fromFlag (installHaddockIndex installFlags) + indexFile = substHaddockIndexFileName defaultDirs indexFileTemplate + + notice verbosity $ + "Updating documentation index " ++ indexFile + + --TODO: might be nice if the install plan gave us the new InstalledPackageInfo + installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb + Haddock.regenerateHaddockIndex verbosity installedPkgIndex progdb indexFile + + | otherwise = return () + where + haddockIndexFileIsRequested = + fromFlag (installDocumentation installFlags) + && isJust (flagToMaybe (installHaddockIndex installFlags)) + + -- We want to regenerate the index if some new documentation was actually + -- installed. Since the index can be only per-user or per-sandbox (see + -- #1337), we don't do it for global installs or special cases where we're + -- installing into a specific db. + shouldRegenerateHaddockIndex = normalUserInstall && someDocsWereInstalled buildOutcomes + where + someDocsWereInstalled = any installedDocs . Map.elems + installedDocs (Right (BuildResult DocsOk _ _)) = True + installedDocs _ = False + + normalUserInstall = (UserPackageDB `elem` packageDBs) + && all (not . isSpecificPackageDB) packageDBs + isSpecificPackageDB (SpecificPackageDB _) = True + isSpecificPackageDB _ = False + + substHaddockIndexFileName defaultDirs = fromPathTemplate + . substPathTemplate env + where + env = env0 ++ installDirsTemplateEnv absoluteDirs + env0 = InstallDirs.compilerTemplateEnv (compilerInfo comp) + ++ InstallDirs.platformTemplateEnv platform + ++ InstallDirs.abiTemplateEnv (compilerInfo comp) platform + absoluteDirs = InstallDirs.substituteInstallDirTemplates + env0 templateDirs + templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault + defaultDirs (configInstallDirs configFlags) + + +symlinkBinaries :: Verbosity + -> Platform -> Compiler + -> ConfigFlags + -> InstallFlags + -> InstallPlan + -> BuildOutcomes + -> IO () +symlinkBinaries verbosity platform comp configFlags installFlags + plan buildOutcomes = do + failed <- InstallSymlink.symlinkBinaries platform comp + NeverOverwrite + configFlags installFlags + plan buildOutcomes + case failed of + [] -> return () + [(_, exe, path)] -> + warn verbosity $ + "could not create a symlink in " ++ bindir ++ " for " + ++ prettyShow exe ++ " because the file exists there already but is not " + ++ "managed by cabal. You can create a symlink for this executable " + ++ "manually if you wish. The executable file has been installed at " + ++ path + exes -> + warn verbosity $ + "could not create symlinks in " ++ bindir ++ " for " + ++ intercalate ", " [ prettyShow exe | (_, exe, _) <- exes ] + ++ " because the files exist there already and are not " + ++ "managed by cabal. You can create symlinks for these executables " + ++ "manually if you wish. The executable files have been installed at " + ++ intercalate ", " [ path | (_, _, path) <- exes ] + where + bindir = fromFlag (installSymlinkBinDir installFlags) + + +printBuildFailures :: Verbosity -> BuildOutcomes -> IO () +printBuildFailures verbosity buildOutcomes = + case [ (pkgid, failure) + | (pkgid, Left failure) <- Map.toList buildOutcomes ] of + [] -> return () + failed -> die' verbosity . unlines + $ "Some packages failed to install:" + : [ prettyShow pkgid ++ printFailureReason reason + | (pkgid, reason) <- failed ] + where + printFailureReason reason = case reason of + DependentFailed pkgid -> " depends on " ++ prettyShow pkgid + ++ " which failed to install." + DownloadFailed e -> " failed while downloading the package." + ++ showException e + UnpackFailed e -> " failed while unpacking the package." + ++ showException e + ConfigureFailed e -> " failed during the configure step." + ++ showException e + BuildFailed e -> " failed during the building phase." + ++ showException e + TestsFailed e -> " failed during the tests phase." + ++ showException e + InstallFailed e -> " failed during the final install step." + ++ showException e + + -- This will never happen, but we include it for completeness + PlanningFailed -> " failed during the planning phase." + + showException e = " The exception was:\n " ++ show e ++ maybeOOM e +#ifdef mingw32_HOST_OS + maybeOOM _ = "" +#else + maybeOOM e = maybe "" onExitFailure (fromException e) + onExitFailure (ExitFailure n) + | n == 9 || n == -9 = + "\nThis may be due to an out-of-memory condition." + onExitFailure _ = "" +#endif + +-- ------------------------------------------------------------ +-- * Actually do the installations +-- ------------------------------------------------------------ + +data InstallMisc = InstallMisc { + libVersion :: Maybe Version + } + +-- | If logging is enabled, contains location of the log file and the verbosity +-- level for logging. +type UseLogFile = Maybe (PackageIdentifier -> UnitId -> FilePath, Verbosity) + +performInstallations :: Verbosity + -> InstallArgs + -> InstalledPackageIndex + -> InstallPlan + -> IO BuildOutcomes +performInstallations verbosity + (packageDBs, repoCtxt, comp, platform, progdb, + globalFlags, configFlags, configExFlags, installFlags, + haddockFlags, testFlags, _) + installedPkgIndex installPlan = do + + info verbosity $ "Number of threads used: " ++ (show numJobs) ++ "." + + jobControl <- if parallelInstall then newParallelJobControl numJobs + else newSerialJobControl + fetchLimit <- newJobLimit (min numJobs numFetchJobs) + installLock <- newLock -- serialise installation + cacheLock <- newLock -- serialise access to setup exe cache + + executeInstallPlan verbosity jobControl keepGoing useLogFile + installPlan $ \rpkg -> + installReadyPackage platform cinfo configFlags + rpkg $ \configFlags' src pkg pkgoverride -> + fetchSourcePackage verbosity repoCtxt fetchLimit src $ \src' -> + installLocalPackage verbosity (packageId pkg) src' distPref $ \mpath -> + installUnpackedPackage verbosity installLock numJobs + (setupScriptOptions installedPkgIndex + cacheLock rpkg) + configFlags' + installFlags haddockFlags testFlags + comp progdb + platform pkg rpkg pkgoverride mpath useLogFile + + where + cinfo = compilerInfo comp + + numJobs = determineNumJobs (installNumJobs installFlags) + numFetchJobs = 2 + parallelInstall = numJobs >= 2 + keepGoing = fromFlag (installKeepGoing installFlags) + distPref = fromFlagOrDefault (useDistPref defaultSetupScriptOptions) + (configDistPref configFlags) + + setupScriptOptions index lock rpkg = + configureSetupScript + packageDBs + comp + platform + progdb + distPref + (chooseCabalVersion configExFlags (libVersion miscOptions)) + (Just lock) + parallelInstall + index + (Just rpkg) + + reportingLevel = fromFlag (installBuildReports installFlags) + logsDir = fromFlag (globalLogsDir globalFlags) + + -- Should the build output be written to a log file instead of stdout? + useLogFile :: UseLogFile + useLogFile = fmap ((\f -> (f, loggingVerbosity)) . substLogFileName) + logFileTemplate + where + installLogFile' = flagToMaybe $ installLogFile installFlags + defaultTemplate = toPathTemplate $ + logsDir "$compiler" "$libname" <.> "log" + + -- If the user has specified --remote-build-reporting=detailed, use the + -- default log file location. If the --build-log option is set, use the + -- provided location. Otherwise don't use logging, unless building in + -- parallel (in which case the default location is used). + logFileTemplate :: Maybe PathTemplate + logFileTemplate + | useDefaultTemplate = Just defaultTemplate + | otherwise = installLogFile' + + -- If the user has specified --remote-build-reporting=detailed or + -- --build-log, use more verbose logging. + loggingVerbosity :: Verbosity + loggingVerbosity | overrideVerbosity = modifyVerbosity (max verbose) verbosity + | otherwise = verbosity + + useDefaultTemplate :: Bool + useDefaultTemplate + | reportingLevel == DetailedReports = True + | isJust installLogFile' = False + | parallelInstall = True + | otherwise = False + + overrideVerbosity :: Bool + overrideVerbosity + | reportingLevel == DetailedReports = True + | isJust installLogFile' = True + | parallelInstall = False + | otherwise = False + + substLogFileName :: PathTemplate -> PackageIdentifier -> UnitId -> FilePath + substLogFileName template pkg uid = fromPathTemplate + . substPathTemplate env + $ template + where env = initialPathTemplateEnv (packageId pkg) uid + (compilerInfo comp) platform + + miscOptions = InstallMisc { + libVersion = flagToMaybe (configCabalVersion configExFlags) + } + + +executeInstallPlan :: Verbosity + -> JobControl IO (UnitId, BuildOutcome) + -> Bool + -> UseLogFile + -> InstallPlan + -> (ReadyPackage -> IO BuildOutcome) + -> IO BuildOutcomes +executeInstallPlan verbosity jobCtl keepGoing useLogFile plan0 installPkg = + InstallPlan.execute + jobCtl keepGoing depsFailure plan0 $ \pkg -> do + buildOutcome <- installPkg pkg + printBuildResult (packageId pkg) (installedUnitId pkg) buildOutcome + return buildOutcome + + where + depsFailure = DependentFailed . packageId + + -- Print build log if something went wrong, and 'Installed $PKGID' + -- otherwise. + printBuildResult :: PackageId -> UnitId -> BuildOutcome -> IO () + printBuildResult pkgid uid buildOutcome = case buildOutcome of + (Right _) -> progressMessage verbosity ProgressCompleted (prettyShow pkgid) + (Left _) -> do + notice verbosity $ "Failed to install " ++ prettyShow pkgid + when (verbosity >= normal) $ + case useLogFile of + Nothing -> return () + Just (mkLogFileName, _) -> do + let logName = mkLogFileName pkgid uid + putStr $ "Build log ( " ++ logName ++ " ):\n" + printFile logName + + printFile :: FilePath -> IO () + printFile path = readFile path >>= putStr + +-- | Call an installer for an 'SourcePackage' but override the configure +-- flags with the ones given by the 'ReadyPackage'. In particular the +-- 'ReadyPackage' specifies an exact 'FlagAssignment' and exactly +-- versioned package dependencies. So we ignore any previous partial flag +-- assignment or dependency constraints and use the new ones. +-- +-- NB: when updating this function, don't forget to also update +-- 'configurePackage' in D.C.Configure. +installReadyPackage :: Platform -> CompilerInfo + -> ConfigFlags + -> ReadyPackage + -> (ConfigFlags -> UnresolvedPkgLoc + -> PackageDescription + -> PackageDescriptionOverride + -> a) + -> a +installReadyPackage platform cinfo configFlags + (ReadyPackage (ConfiguredPackage ipid + (SourcePackage _ gpkg source pkgoverride) + flags stanzas deps)) + installPkg = + installPkg configFlags { + configIPID = toFlag (prettyShow ipid), + configConfigurationsFlags = flags, + -- We generate the legacy constraints as well as the new style precise deps. + -- In the end only one set gets passed to Setup.hs configure, depending on + -- the Cabal version we are talking to. + configConstraints = [ thisPackageVersionConstraint srcid + | ConfiguredId + srcid + (Just + (PackageDescription.CLibName + PackageDescription.LMainLibName)) + _ipid + <- CD.nonSetupDeps deps ], + configDependencies = [ GivenComponent (packageName srcid) cname dep_ipid + | ConfiguredId srcid (Just (PackageDescription.CLibName cname)) dep_ipid + <- CD.nonSetupDeps deps ], + -- Use '--exact-configuration' if supported. + configExactConfiguration = toFlag True, + configBenchmarks = toFlag False, + configTests = toFlag (TestStanzas `optStanzaSetMember` stanzas) + } source pkg pkgoverride + where + pkg = case finalizePD flags (enableStanzas stanzas) + (const True) + platform cinfo [] gpkg of + Left _ -> error "finalizePD ReadyPackage failed" + Right (desc, _) -> desc + +fetchSourcePackage + :: Verbosity + -> RepoContext + -> JobLimit + -> UnresolvedPkgLoc + -> (ResolvedPkgLoc -> IO BuildOutcome) + -> IO BuildOutcome +fetchSourcePackage verbosity repoCtxt fetchLimit src installPkg = do + fetched <- checkFetched src + case fetched of + Just src' -> installPkg src' + Nothing -> onFailure DownloadFailed $ do + loc <- withJobLimit fetchLimit $ + fetchPackage verbosity repoCtxt src + installPkg loc + + +installLocalPackage + :: Verbosity + -> PackageIdentifier -> ResolvedPkgLoc -> FilePath + -> (Maybe FilePath -> IO BuildOutcome) + -> IO BuildOutcome +installLocalPackage verbosity pkgid location distPref installPkg = + + case location of + + LocalUnpackedPackage dir -> + installPkg (Just dir) + + RemoteSourceRepoPackage _repo dir -> + installPkg (Just dir) + + LocalTarballPackage tarballPath -> + installLocalTarballPackage verbosity + pkgid tarballPath distPref installPkg + + RemoteTarballPackage _ tarballPath -> + installLocalTarballPackage verbosity + pkgid tarballPath distPref installPkg + + RepoTarballPackage _ _ tarballPath -> + installLocalTarballPackage verbosity + pkgid tarballPath distPref installPkg + +installLocalTarballPackage + :: Verbosity + -> PackageIdentifier -> FilePath -> FilePath + -> (Maybe FilePath -> IO BuildOutcome) + -> IO BuildOutcome +installLocalTarballPackage verbosity pkgid + tarballPath distPref installPkg = do + tmp <- getTemporaryDirectory + withTempDirectory verbosity tmp "cabal-tmp" $ \tmpDirPath -> + onFailure UnpackFailed $ do + let relUnpackedPath = prettyShow pkgid + absUnpackedPath = tmpDirPath relUnpackedPath + descFilePath = absUnpackedPath + prettyShow (packageName pkgid) <.> "cabal" + info verbosity $ "Extracting " ++ tarballPath + ++ " to " ++ tmpDirPath ++ "..." + extractTarGzFile tmpDirPath relUnpackedPath tarballPath + exists <- doesFileExist descFilePath + unless exists $ + die' verbosity $ "Package .cabal file not found: " ++ show descFilePath + maybeRenameDistDir absUnpackedPath + installPkg (Just absUnpackedPath) + + where + -- 'cabal sdist' puts pre-generated files in the 'dist' + -- directory. This fails when a nonstandard build directory name + -- is used (as is the case with sandboxes), so we need to rename + -- the 'dist' dir here. + -- + -- TODO: 'cabal get happy && cd sandbox && cabal install ../happy' still + -- fails even with this workaround. We probably can live with that. + maybeRenameDistDir :: FilePath -> IO () + maybeRenameDistDir absUnpackedPath = do + let distDirPath = absUnpackedPath defaultDistPref + distDirPathTmp = absUnpackedPath (defaultDistPref ++ "-tmp") + distDirPathNew = absUnpackedPath distPref + distDirExists <- doesDirectoryExist distDirPath + when (distDirExists + && (not $ distDirPath `equalFilePath` distDirPathNew)) $ do + -- NB: we need to handle the case when 'distDirPathNew' is a + -- subdirectory of 'distDirPath' (e.g. the former is + -- 'dist/dist-sandbox-3688fbc2' and the latter is 'dist'). + debug verbosity $ "Renaming '" ++ distDirPath ++ "' to '" + ++ distDirPathTmp ++ "'." + renameDirectory distDirPath distDirPathTmp + when (distDirPath `isPrefixOf` distDirPathNew) $ + createDirectoryIfMissingVerbose verbosity False distDirPath + debug verbosity $ "Renaming '" ++ distDirPathTmp ++ "' to '" + ++ distDirPathNew ++ "'." + renameDirectory distDirPathTmp distDirPathNew + +installUnpackedPackage + :: Verbosity + -> Lock + -> Int + -> SetupScriptOptions + -> ConfigFlags + -> InstallFlags + -> HaddockFlags + -> TestFlags + -> Compiler + -> ProgramDb + -> Platform + -> PackageDescription + -> ReadyPackage + -> PackageDescriptionOverride + -> Maybe FilePath -- ^ Directory to change to before starting the installation. + -> UseLogFile -- ^ File to log output to (if any) + -> IO BuildOutcome +installUnpackedPackage verbosity installLock numJobs + scriptOptions + configFlags installFlags haddockFlags testFlags comp progdb + platform pkg rpkg pkgoverride workingDir useLogFile = do + -- Override the .cabal file if necessary + case pkgoverride of + Nothing -> return () + Just pkgtxt -> do + let descFilePath = fromMaybe "." workingDir + prettyShow (packageName pkgid) <.> "cabal" + info verbosity $ + "Updating " ++ prettyShow (packageName pkgid) <.> "cabal" + ++ " with the latest revision from the index." + writeFileAtomic descFilePath pkgtxt + + -- Make sure that we pass --libsubdir etc to 'setup configure' (necessary if + -- the setup script was compiled against an old version of the Cabal lib). + configFlags' <- addDefaultInstallDirs configFlags + -- Filter out flags not supported by the old versions of the Cabal lib. + let configureFlags :: Version -> ConfigFlags + configureFlags = filterConfigureFlags configFlags' { + configVerbosity = toFlag verbosity' + } + + -- Path to the optional log file. + mLogPath <- maybeLogPath + + logDirChange (maybe (const (return ())) appendFile mLogPath) workingDir $ do + -- Configure phase + onFailure ConfigureFailed $ do + noticeProgress ProgressStarting + setup configureCommand configureFlags mLogPath + + -- Build phase + onFailure BuildFailed $ do + noticeProgress ProgressBuilding + setup buildCommand' buildFlags mLogPath + + -- Doc generation phase + docsResult <- if shouldHaddock + then (do setup haddockCommand haddockFlags' mLogPath + return DocsOk) + `catchIO` (\_ -> return DocsFailed) + `catchExit` (\_ -> return DocsFailed) + else return DocsNotTried + + -- Tests phase + onFailure TestsFailed $ do + when (testsEnabled && PackageDescription.hasTests pkg) $ + setup Cabal.testCommand testFlags' mLogPath + + let testsResult | testsEnabled = TestsOk + | otherwise = TestsNotTried + + -- Install phase + onFailure InstallFailed $ criticalSection installLock $ do + -- Actual installation + withWin32SelfUpgrade verbosity uid configFlags + cinfo platform pkg $ do + setup Cabal.copyCommand copyFlags mLogPath + + -- Capture installed package configuration file, so that + -- it can be incorporated into the final InstallPlan + ipkgs <- genPkgConfs mLogPath + let ipkgs' = case ipkgs of + [ipkg] -> [ipkg { Installed.installedUnitId = uid }] + _ -> ipkgs + let packageDBs = interpretPackageDbFlags + (fromFlag (configUserInstall configFlags)) + (configPackageDBs configFlags) + for_ ipkgs' $ \ipkg' -> + registerPackage verbosity comp progdb + packageDBs ipkg' + defaultRegisterOptions + + return (Right (BuildResult docsResult testsResult (find ((==uid).installedUnitId) ipkgs'))) + + where + pkgid = packageId pkg + uid = installedUnitId rpkg + cinfo = compilerInfo comp + buildCommand' = buildCommand progdb + dispname = prettyShow pkgid + isParallelBuild = numJobs >= 2 + + noticeProgress phase = when isParallelBuild $ + progressMessage verbosity phase dispname + + buildFlags _ = emptyBuildFlags { + buildDistPref = configDistPref configFlags, + buildVerbosity = toFlag verbosity' + } + shouldHaddock = fromFlag (installDocumentation installFlags) + haddockFlags' _ = haddockFlags { + haddockVerbosity = toFlag verbosity', + haddockDistPref = configDistPref configFlags + } + testsEnabled = fromFlag (configTests configFlags) + && fromFlagOrDefault False (installRunTests installFlags) + testFlags' = filterTestFlags testFlags { + Cabal.testDistPref = configDistPref configFlags + } + copyFlags _ = Cabal.emptyCopyFlags { + Cabal.copyDistPref = configDistPref configFlags, + Cabal.copyDest = toFlag InstallDirs.NoCopyDest, + Cabal.copyVerbosity = toFlag verbosity' + } + shouldRegister = PackageDescription.hasLibs pkg + registerFlags _ = Cabal.emptyRegisterFlags { + Cabal.regDistPref = configDistPref configFlags, + Cabal.regVerbosity = toFlag verbosity' + } + verbosity' = maybe verbosity snd useLogFile + tempTemplate name = name ++ "-" ++ prettyShow pkgid + + addDefaultInstallDirs :: ConfigFlags -> IO ConfigFlags + addDefaultInstallDirs configFlags' = do + defInstallDirs <- InstallDirs.defaultInstallDirs flavor userInstall False + return $ configFlags' { + configInstallDirs = fmap Cabal.Flag . + InstallDirs.substituteInstallDirTemplates env $ + InstallDirs.combineInstallDirs fromFlagOrDefault + defInstallDirs (configInstallDirs configFlags) + } + where + CompilerId flavor _ = compilerInfoId cinfo + env = initialPathTemplateEnv pkgid uid cinfo platform + userInstall = fromFlagOrDefault defaultUserInstall + (configUserInstall configFlags') + + genPkgConfs :: Maybe FilePath + -> IO [Installed.InstalledPackageInfo] + genPkgConfs mLogPath = + if shouldRegister then do + tmp <- getTemporaryDirectory + withTempDirectory verbosity tmp (tempTemplate "pkgConf") $ \dir -> do + let pkgConfDest = dir "pkgConf" + registerFlags' version = (registerFlags version) { + Cabal.regGenPkgConf = toFlag (Just pkgConfDest) + } + setup Cabal.registerCommand registerFlags' mLogPath + is_dir <- doesDirectoryExist pkgConfDest + let notHidden = not . isHidden + isHidden name = "." `isPrefixOf` name + if is_dir + -- Sort so that each prefix of the package + -- configurations is well formed + then traverse (readPkgConf pkgConfDest) . sort . filter notHidden + =<< getDirectoryContents pkgConfDest + else fmap (:[]) $ readPkgConf "." pkgConfDest + else return [] + + readPkgConf :: FilePath -> FilePath + -> IO Installed.InstalledPackageInfo + readPkgConf pkgConfDir pkgConfFile = do + pkgConfText <- BS.readFile (pkgConfDir pkgConfFile) + case Installed.parseInstalledPackageInfo pkgConfText of + Left perrors -> pkgConfParseFailed $ unlines $ NE.toList perrors + Right (warns, pkgConf) -> do + unless (null warns) $ + warn verbosity $ unlines warns + return pkgConf + + pkgConfParseFailed :: String -> IO a + pkgConfParseFailed perror = + die' verbosity $ "Couldn't parse the output of 'setup register --gen-pkg-config':" + ++ show perror + + maybeLogPath :: IO (Maybe FilePath) + maybeLogPath = + case useLogFile of + Nothing -> return Nothing + Just (mkLogFileName, _) -> do + let logFileName = mkLogFileName (packageId pkg) uid + logDir = takeDirectory logFileName + unless (null logDir) $ createDirectoryIfMissing True logDir + logFileExists <- doesFileExist logFileName + when logFileExists $ removeFile logFileName + return (Just logFileName) + + setup cmd flags mLogPath = + Exception.bracket + (traverse (\path -> openFile path AppendMode) mLogPath) + (traverse_ hClose) + (\logFileHandle -> + setupWrapper verbosity + scriptOptions { useLoggingHandle = logFileHandle + , useWorkingDir = workingDir } + (Just pkg) + cmd flags (const [])) + + +-- helper +onFailure :: (SomeException -> BuildFailure) -> IO BuildOutcome -> IO BuildOutcome +onFailure result action = + action `catches` + [ Handler $ \ioe -> handler (ioe :: IOException) + , Handler $ \exit -> handler (exit :: ExitCode) + ] + where + handler :: Exception e => e -> IO BuildOutcome + handler = return . Left . result . toException + + +-- ------------------------------------------------------------ +-- * Weird windows hacks +-- ------------------------------------------------------------ + +withWin32SelfUpgrade :: Verbosity + -> UnitId + -> ConfigFlags + -> CompilerInfo + -> Platform + -> PackageDescription + -> IO a -> IO a +withWin32SelfUpgrade _ _ _ _ _ _ action | buildOS /= Windows = action +withWin32SelfUpgrade verbosity uid configFlags cinfo platform pkg action = do + + defaultDirs <- InstallDirs.defaultInstallDirs + compFlavor + (fromFlag (configUserInstall configFlags)) + (PackageDescription.hasLibs pkg) + + Win32SelfUpgrade.possibleSelfUpgrade verbosity + (exeInstallPaths defaultDirs) action + + where + pkgid = packageId pkg + (CompilerId compFlavor _) = compilerInfoId cinfo + + exeInstallPaths defaultDirs = + [ InstallDirs.bindir absoluteDirs exeName <.> exeExtension buildPlatform + | exe <- PackageDescription.executables pkg + , PackageDescription.buildable (PackageDescription.buildInfo exe) + , let exeName = prefix ++ prettyShow (PackageDescription.exeName exe) ++ suffix + prefix = substTemplate prefixTemplate + suffix = substTemplate suffixTemplate ] + where + fromFlagTemplate = fromFlagOrDefault (InstallDirs.toPathTemplate "") + prefixTemplate = fromFlagTemplate (configProgPrefix configFlags) + suffixTemplate = fromFlagTemplate (configProgSuffix configFlags) + templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault + defaultDirs (configInstallDirs configFlags) + absoluteDirs = InstallDirs.absoluteInstallDirs + pkgid uid + cinfo InstallDirs.NoCopyDest + platform templateDirs + substTemplate = InstallDirs.fromPathTemplate + . InstallDirs.substPathTemplate env + where env = InstallDirs.initialPathTemplateEnv pkgid uid + cinfo platform diff --git a/cabal/cabal-install/src/Distribution/Client/InstallPlan.hs b/cabal/cabal-install/src/Distribution/Client/InstallPlan.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/InstallPlan.hs @@ -0,0 +1,957 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.InstallPlan +-- Copyright : (c) Duncan Coutts 2008 +-- License : BSD-like +-- +-- Maintainer : duncan@community.haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Package installation plan +-- +----------------------------------------------------------------------------- +module Distribution.Client.InstallPlan ( + InstallPlan, + GenericInstallPlan, + PlanPackage, + GenericPlanPackage(..), + foldPlanPackage, + IsUnit, + + -- * Operations on 'InstallPlan's + new, + toGraph, + toList, + toMap, + keys, + keysSet, + planIndepGoals, + depends, + + fromSolverInstallPlan, + fromSolverInstallPlanWithProgress, + configureInstallPlan, + remove, + installed, + lookup, + directDeps, + revDirectDeps, + + -- * Traversal + executionOrder, + execute, + BuildOutcomes, + lookupBuildOutcome, + -- ** Traversal helpers + -- $traversal + Processing, + ready, + completed, + failed, + + -- * Display + showPlanGraph, + showInstallPlan, + + -- * Graph-like operations + dependencyClosure, + reverseTopologicalOrder, + reverseDependencyClosure, + ) where + +import Distribution.Client.Compat.Prelude hiding (toList, lookup, tail) +import Prelude (tail) +import Distribution.Compat.Stack (WithCallStack) + +import Distribution.Client.Types hiding (BuildOutcomes) +import qualified Distribution.PackageDescription as PD +import qualified Distribution.Simple.Configure as Configure +import qualified Distribution.Simple.Setup as Cabal + +import Distribution.InstalledPackageInfo + ( InstalledPackageInfo ) +import Distribution.Package + ( Package(..), HasMungedPackageId(..) + , HasUnitId(..), UnitId ) +import Distribution.Solver.Types.SolverPackage +import Distribution.Client.JobControl +import Distribution.Pretty (defaultStyle) +import Text.PrettyPrint +import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan +import Distribution.Client.SolverInstallPlan (SolverInstallPlan) + +import qualified Distribution.Solver.Types.ComponentDeps as CD +import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.SolverId +import Distribution.Solver.Types.InstSolverPackage + +import Distribution.Utils.LogProgress +import Distribution.Utils.Structured (Structured (..), Structure(Nominal)) + +-- TODO: Need this when we compute final UnitIds +-- import qualified Distribution.Simple.Configure as Configure + +import qualified Data.Foldable as Foldable (all, toList) +import qualified Distribution.Compat.Graph as Graph +import Distribution.Compat.Graph (Graph, IsNode(..)) +import Control.Exception + ( assert ) +import qualified Data.Map as Map +import qualified Data.Set as Set + +-- When cabal tries to install a number of packages, including all their +-- dependencies it has a non-trivial problem to solve. +-- +-- The Problem: +-- +-- In general we start with a set of installed packages and a set of source +-- packages. +-- +-- Installed packages have fixed dependencies. They have already been built and +-- we know exactly what packages they were built against, including their exact +-- versions. +-- +-- Source package have somewhat flexible dependencies. They are specified as +-- version ranges, though really they're predicates. To make matters worse they +-- have conditional flexible dependencies. Configuration flags can affect which +-- packages are required and can place additional constraints on their +-- versions. +-- +-- These two sets of package can and usually do overlap. There can be installed +-- packages that are also available as source packages which means they could +-- be re-installed if required, though there will also be packages which are +-- not available as source and cannot be re-installed. Very often there will be +-- extra versions available than are installed. Sometimes we may like to prefer +-- installed packages over source ones or perhaps always prefer the latest +-- available version whether installed or not. +-- +-- The goal is to calculate an installation plan that is closed, acyclic and +-- consistent and where every configured package is valid. +-- +-- An installation plan is a set of packages that are going to be used +-- together. It will consist of a mixture of installed packages and source +-- packages along with their exact version dependencies. An installation plan +-- is closed if for every package in the set, all of its dependencies are +-- also in the set. It is consistent if for every package in the set, all +-- dependencies which target that package have the same version. + +-- Note that plans do not necessarily compose. You might have a valid plan for +-- package A and a valid plan for package B. That does not mean the composition +-- is simultaneously valid for A and B. In particular you're most likely to +-- have problems with inconsistent dependencies. +-- On the other hand it is true that every closed sub plan is valid. + +-- | Packages in an install plan +-- +-- NOTE: 'ConfiguredPackage', 'GenericReadyPackage' and 'GenericPlanPackage' +-- intentionally have no 'PackageInstalled' instance. `This is important: +-- PackageInstalled returns only library dependencies, but for package that +-- aren't yet installed we know many more kinds of dependencies (setup +-- dependencies, exe, test-suite, benchmark, ..). Any functions that operate on +-- dependencies in cabal-install should consider what to do with these +-- dependencies; if we give a 'PackageInstalled' instance it would be too easy +-- to get this wrong (and, for instance, call graph traversal functions from +-- Cabal rather than from cabal-install). Instead, see 'PackageInstalled'. +data GenericPlanPackage ipkg srcpkg + = PreExisting ipkg + | Configured srcpkg + | Installed srcpkg + deriving (Eq, Show, Generic) + +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) + +-- | 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 + +type IsUnit a = (IsNode a, Key a ~ UnitId) + +depends :: IsUnit a => a -> [UnitId] +depends = nodeNeighbors + +-- 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 + nodeKey (PreExisting ipkg) = nodeKey ipkg + nodeKey (Configured spkg) = nodeKey spkg + nodeKey (Installed spkg) = nodeKey spkg + nodeNeighbors (PreExisting ipkg) = nodeNeighbors ipkg + nodeNeighbors (Configured spkg) = nodeNeighbors spkg + nodeNeighbors (Installed spkg) = nodeNeighbors spkg + +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) where + packageId (PreExisting ipkg) = packageId ipkg + packageId (Configured spkg) = packageId spkg + packageId (Installed spkg) = packageId spkg + +instance (HasMungedPackageId ipkg, HasMungedPackageId srcpkg) => + HasMungedPackageId (GenericPlanPackage ipkg srcpkg) where + mungedId (PreExisting ipkg) = mungedId ipkg + mungedId (Configured spkg) = mungedId spkg + mungedId (Installed spkg) = mungedId spkg + +instance (HasUnitId ipkg, HasUnitId srcpkg) => + HasUnitId + (GenericPlanPackage ipkg srcpkg) where + installedUnitId (PreExisting ipkg) = installedUnitId ipkg + installedUnitId (Configured spkg) = installedUnitId spkg + installedUnitId (Installed spkg) = installedUnitId spkg + +instance (HasConfiguredId ipkg, HasConfiguredId srcpkg) => + HasConfiguredId (GenericPlanPackage ipkg srcpkg) where + configuredId (PreExisting ipkg) = configuredId ipkg + configuredId (Configured spkg) = configuredId spkg + configuredId (Installed spkg) = configuredId spkg + +data GenericInstallPlan ipkg srcpkg = GenericInstallPlan { + planGraph :: !(Graph (GenericPlanPackage ipkg srcpkg)), + planIndepGoals :: !IndependentGoals + } + deriving (Typeable) + +-- | '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 $ "internal error in InstallPlan." ++ loc + ++ if null msg then "" else ": " ++ msg + +instance (Structured ipkg, Structured srcpkg) => Structured (GenericInstallPlan ipkg srcpkg) where + structure p = Nominal (typeRep p) 0 "GenericInstallPlan" + [ structure (Proxy :: Proxy ipkg) + , structure (Proxy :: Proxy srcpkg) + ] + +instance (IsNode ipkg, Key ipkg ~ UnitId, IsNode srcpkg, Key srcpkg ~ UnitId, + Binary ipkg, Binary srcpkg) + => Binary (GenericInstallPlan ipkg srcpkg) where + put GenericInstallPlan { + planGraph = graph, + planIndepGoals = indepGoals + } = put graph >> put indepGoals + + get = do + graph <- get + indepGoals <- get + return $! mkInstallPlan "(instance Binary)" graph indepGoals + +showPlanGraph :: (Package ipkg, Package srcpkg, + IsUnit ipkg, IsUnit srcpkg) + => Graph (GenericPlanPackage ipkg srcpkg) -> String +showPlanGraph graph = renderStyle defaultStyle $ + vcat (map dispPlanPackage (Foldable.toList graph)) + where dispPlanPackage p = + hang (hsep [ text (showPlanPackageTag p) + , pretty (packageId p) + , parens (pretty (nodeKey p))]) 2 + (vcat (map pretty (nodeNeighbors p))) + +showInstallPlan :: (Package ipkg, Package srcpkg, + IsUnit ipkg, IsUnit srcpkg) + => GenericInstallPlan ipkg srcpkg -> String +showInstallPlan = showPlanGraph . planGraph + +showPlanPackageTag :: GenericPlanPackage ipkg srcpkg -> String +showPlanPackageTag (PreExisting _) = "PreExisting" +showPlanPackageTag (Configured _) = "Configured" +showPlanPackageTag (Installed _) = "Installed" + +-- | Build an installation plan from a valid set of resolved packages. +-- +new :: (IsUnit ipkg, IsUnit srcpkg) + => IndependentGoals + -> Graph (GenericPlanPackage ipkg srcpkg) + -> GenericInstallPlan ipkg srcpkg +new indepGoals graph = mkInstallPlan "new" graph indepGoals + +toGraph :: GenericInstallPlan ipkg srcpkg + -> Graph (GenericPlanPackage ipkg srcpkg) +toGraph = planGraph + +toList :: GenericInstallPlan ipkg srcpkg + -> [GenericPlanPackage ipkg srcpkg] +toList = Foldable.toList . planGraph + +toMap :: GenericInstallPlan ipkg srcpkg + -> Map UnitId (GenericPlanPackage ipkg srcpkg) +toMap = Graph.toMap . planGraph + +keys :: GenericInstallPlan ipkg srcpkg -> [UnitId] +keys = Graph.keys . planGraph + +keysSet :: GenericInstallPlan ipkg srcpkg -> Set UnitId +keysSet = Graph.keysSet . planGraph + +-- | Remove packages from the install plan. This will result in an +-- error if there are remaining packages that depend on any matching +-- package. This is primarily useful for obtaining an install plan for +-- the dependencies of a package or set of packages without actually +-- installing the package itself, as when doing development. +-- +remove :: (IsUnit ipkg, IsUnit srcpkg) + => (GenericPlanPackage ipkg srcpkg -> Bool) + -> GenericInstallPlan ipkg srcpkg + -> GenericInstallPlan ipkg srcpkg +remove shouldRemove plan = + mkInstallPlan "remove" newGraph (planIndepGoals plan) + where + newGraph = Graph.fromDistinctList $ + filter (not . shouldRemove) (toList 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'). +-- +installed :: (IsUnit ipkg, IsUnit srcpkg) + => (srcpkg -> Bool) + -> GenericInstallPlan ipkg srcpkg + -> GenericInstallPlan ipkg srcpkg +installed shouldBeInstalled installPlan = + foldl' markInstalled installPlan + [ pkg + | Configured pkg <- reverseTopologicalOrder installPlan + , shouldBeInstalled pkg ] + 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) + => GenericInstallPlan ipkg srcpkg + -> UnitId + -> Maybe (GenericPlanPackage ipkg srcpkg) +lookup plan pkgid = Graph.lookup pkgid (planGraph plan) + +-- | Find all the direct dependencies of the given package. +-- +-- Note that the package must exist in the plan or it is an error. +-- +directDeps :: GenericInstallPlan ipkg srcpkg + -> UnitId + -> [GenericPlanPackage ipkg srcpkg] +directDeps plan pkgid = + case Graph.neighbors (planGraph plan) pkgid of + Just deps -> deps + Nothing -> internalError "directDeps" "package not in graph" + +-- | Find all the direct reverse dependencies of the given package. +-- +-- Note that the package must exist in the plan or it is an error. +-- +revDirectDeps :: GenericInstallPlan ipkg srcpkg + -> UnitId + -> [GenericPlanPackage ipkg srcpkg] +revDirectDeps plan pkgid = + case Graph.revNeighbors (planGraph plan) pkgid of + Just deps -> deps + Nothing -> internalError "revDirectDeps" "package not in graph" + +-- | Return all the packages in the 'InstallPlan' in reverse topological order. +-- That is, for each package, all dependencies of the package appear first. +-- +-- Compared to 'executionOrder', this function returns all the installed and +-- source packages rather than just the source ones. Also, while both this +-- and 'executionOrder' produce reverse topological orderings of the package +-- dependency graph, it is not necessarily exactly the same order. +-- +reverseTopologicalOrder :: GenericInstallPlan ipkg srcpkg + -> [GenericPlanPackage ipkg srcpkg] +reverseTopologicalOrder plan = Graph.revTopSort (planGraph plan) + + +-- | Return the packages in the plan that are direct or indirect dependencies of +-- the given packages. +-- +dependencyClosure :: GenericInstallPlan ipkg srcpkg + -> [UnitId] + -> [GenericPlanPackage ipkg srcpkg] +dependencyClosure plan = fromMaybe [] + . Graph.closure (planGraph plan) + +-- | Return the packages in the plan that depend directly or indirectly on the +-- given packages. +-- +reverseDependencyClosure :: GenericInstallPlan ipkg srcpkg + -> [UnitId] + -> [GenericPlanPackage ipkg srcpkg] +reverseDependencyClosure plan = fromMaybe [] + . Graph.revClosure (planGraph plan) + + +-- Alert alert! Why does SolverId map to a LIST of plan packages? +-- The sordid story has to do with 'build-depends' on a package +-- with libraries and executables. In an ideal world, we would +-- ONLY depend on the library in this situation. But c.f. #3661 +-- some people rely on the build-depends to ALSO implicitly +-- depend on an executable. +-- +-- I don't want to commit to a strategy yet, so the only possible +-- thing you can do in this case is return EVERYTHING and let +-- the client filter out what they want (executables? libraries? +-- etc). This similarly implies we can't return a 'ConfiguredId' +-- because that's not enough information. + +fromSolverInstallPlan :: + (IsUnit ipkg, IsUnit srcpkg) + => ( (SolverId -> [GenericPlanPackage ipkg srcpkg]) + -> SolverInstallPlan.SolverPlanPackage + -> [GenericPlanPackage ipkg srcpkg] ) + -> 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). + + +fromSolverInstallPlanWithProgress :: + (IsUnit ipkg, IsUnit srcpkg) + => ( (SolverId -> [GenericPlanPackage ipkg srcpkg]) + -> SolverInstallPlan.SolverPlanPackage + -> LogProgress [GenericPlanPackage ipkg srcpkg] ) + -> SolverInstallPlan + -> LogProgress (GenericInstallPlan ipkg srcpkg) +fromSolverInstallPlanWithProgress f plan = do + (_, _, pkgs'') <- foldM f' (Map.empty, Map.empty, []) + (SolverInstallPlan.reverseTopologicalOrder plan) + return $ mkInstallPlan "fromSolverInstallPlanWithProgress" + (Graph.fromDistinctList pkgs'') + (SolverInstallPlan.planIndepGoals plan) + 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). + +-- | Conversion of 'SolverInstallPlan' to 'InstallPlan'. +-- Similar to 'elaboratedInstallPlan' +configureInstallPlan :: Cabal.ConfigFlags -> SolverInstallPlan -> InstallPlan +configureInstallPlan configFlags solverPlan = + flip fromSolverInstallPlan solverPlan $ \mapDep planpkg -> + [case planpkg of + SolverInstallPlan.PreExisting pkg -> + PreExisting (instSolverPkgIPI pkg) + + SolverInstallPlan.Configured pkg -> + Configured (configureSolverPackage mapDep pkg) + ] + where + configureSolverPackage :: (SolverId -> [PlanPackage]) + -> SolverPackage UnresolvedPkgLoc + -> ConfiguredPackage UnresolvedPkgLoc + configureSolverPackage mapDep spkg = + ConfiguredPackage { + confPkgId = Configure.computeComponentId + (Cabal.fromFlagOrDefault False + (Cabal.configDeterministic configFlags)) + Cabal.NoFlag + Cabal.NoFlag + (packageId spkg) + (PD.CLibName PD.LMainLibName) + (Just (map confInstId (CD.libraryDeps deps), + solverPkgFlags spkg)), + confPkgSource = solverPkgSource spkg, + confPkgFlags = solverPkgFlags spkg, + confPkgStanzas = solverPkgStanzas spkg, + confPkgDeps = deps + -- NB: no support for executable dependencies + } + where + deps = fmap (concatMap (map configuredId . mapDep)) (solverPkgLibDeps spkg) + + +-- ------------------------------------------------------------ +-- * Primitives for traversing plans +-- ------------------------------------------------------------ + +-- $traversal +-- +-- Algorithms to traverse or execute an 'InstallPlan', especially in parallel, +-- may make use of the 'Processing' type and the associated operations +-- 'ready', 'completed' and 'failed'. +-- +-- The 'Processing' type is used to keep track of the state of a traversal 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. +-- +-- Traversal algorithms start with an 'InstallPlan': +-- +-- * Initially there will be certain packages that can be processed immediately +-- (since they are configured source packages and have all their dependencies +-- installed already). The function 'ready' returns these packages plus a +-- 'Processing' state that marks these same packages as being in the +-- processing state. +-- +-- * The algorithm must now arrange for these packages to be processed +-- (possibly in parallel). When a package has completed processing, the +-- algorithm needs to know which other packages (if any) are now ready to +-- process as a result. The 'completed' function marks a package as completed +-- and returns any packages that are newly in the processing state (ie ready +-- to process), along with the updated 'Processing' state. +-- +-- * If failure is possible then when processing a package fails, the algorithm +-- needs to know which other packages have also failed as a result. The +-- 'failed' function marks the given package as failed as well as all the +-- other packages that depend on the failed package. In addition it returns +-- the other failed packages. + + +-- | The 'Processing' type is used to keep track of the state of a traversal +-- 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) + -- processing, completed, failed + +-- | The packages in the plan that are initially ready to be installed. +-- That is they are in the configured state and have all their dependencies +-- installed already. +-- +-- The result is both the packages that are now ready to be installed and also +-- a 'Processing' state containing those same packages. The assumption is that +-- 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) + => GenericInstallPlan ipkg srcpkg + -> ([GenericReadyPackage srcpkg], Processing) +ready plan = + assert (processingInvariant plan processing) $ + (readyPackages, processing) + where + !processing = + Processing + (Set.fromList [ nodeKey pkg | pkg <- readyPackages ]) + (Set.fromList [ nodeKey pkg | pkg <- toList plan, isInstalled pkg ]) + Set.empty + readyPackages = + [ ReadyPackage pkg + | Configured pkg <- toList plan + , all isInstalled (directDeps plan (nodeKey pkg)) + ] + +isInstalled :: GenericPlanPackage a b -> Bool +isInstalled (PreExisting {}) = True +isInstalled (Installed {}) = True +isInstalled _ = False + +-- | Given a package in the processing state, mark the package as completed +-- and return any packages that are newly in the processing state (ie ready to +-- process), along with the updated 'Processing' state. +-- +completed :: forall ipkg srcpkg. (IsUnit ipkg, IsUnit srcpkg) + => GenericInstallPlan ipkg srcpkg + -> Processing -> UnitId + -> ([GenericReadyPackage srcpkg], Processing) +completed plan (Processing processingSet completedSet failedSet) pkgid = + assert (pkgid `Set.member` processingSet) $ + assert (processingInvariant plan processing') $ + + ( map asReadyPackage newlyReady + , processing' ) + where + completedSet' = Set.insert pkgid completedSet + + -- each direct reverse dep where all direct deps are completed + newlyReady = [ dep + | dep <- revDirectDeps plan pkgid + , all ((`Set.member` completedSet') . nodeKey) + (directDeps plan (nodeKey dep)) + ] + + processingSet' = foldl' (flip Set.insert) + (Set.delete pkgid processingSet) + (map nodeKey newlyReady) + processing' = Processing processingSet' completedSet' failedSet + + asReadyPackage :: GenericPlanPackage ipkg srcpkg -> GenericReadyPackage srcpkg + asReadyPackage (Configured pkg) = ReadyPackage pkg + asReadyPackage pkg = internalError "completed" $ "not in configured state: " ++ displayGenericPlanPackage pkg + +failed :: (IsUnit ipkg, IsUnit srcpkg) + => GenericInstallPlan ipkg srcpkg + -> Processing -> UnitId + -> ([srcpkg], Processing) +failed plan (Processing processingSet completedSet failedSet) pkgid = + assert (pkgid `Set.member` processingSet) $ + assert (all (`Set.notMember` processingSet) (tail newlyFailedIds)) $ + assert (all (`Set.notMember` completedSet) (tail newlyFailedIds)) $ + -- but note that some newlyFailed may already be in the failed set + -- since one package can depend on two packages that both fail and + -- so would be in the rev-dep closure for both. + assert (processingInvariant plan processing') $ + + ( map asConfiguredPackage (tail newlyFailed) + , processing' ) + where + processingSet' = Set.delete pkgid processingSet + failedSet' = failedSet `Set.union` Set.fromList newlyFailedIds + newlyFailedIds = map nodeKey newlyFailed + newlyFailed = fromMaybe (internalError "failed" "package not in graph") + $ Graph.revClosure (planGraph plan) [pkgid] + processing' = Processing processingSet' completedSet failedSet' + + asConfiguredPackage (Configured pkg) = pkg + asConfiguredPackage pkg = internalError "failed" $ "not in configured state: " ++ displayGenericPlanPackage pkg + +processingInvariant :: (IsUnit ipkg, IsUnit srcpkg) + => GenericInstallPlan ipkg srcpkg + -> Processing -> Bool +processingInvariant plan (Processing processingSet completedSet failedSet) = + + -- All the packages in the three sets are actually in the graph + assert (Foldable.all (flip Graph.member (planGraph plan)) processingSet) $ + assert (Foldable.all (flip Graph.member (planGraph plan)) completedSet) $ + assert (Foldable.all (flip Graph.member (planGraph plan)) failedSet) $ + + -- The processing, completed and failed sets are disjoint from each other + assert (noIntersection processingSet completedSet) $ + assert (noIntersection processingSet failedSet) $ + assert (noIntersection failedSet completedSet) $ + + -- Packages that depend on a package that's still processing cannot be + -- completed + assert (noIntersection (reverseClosure processingSet) completedSet) $ + + -- On the other hand, packages that depend on a package that's still + -- processing /can/ have failed (since they may have depended on multiple + -- packages that were processing, but it only takes one to fail to cause + -- knock-on failures) so it is quite possible to have an + -- intersection (reverseClosure processingSet) failedSet + + -- The failed set is upwards closed, i.e. equal to its own rev dep closure + assert (failedSet == reverseClosure failedSet) $ + + -- All immediate reverse deps of packages that are currently processing + -- are not currently being processed (ie not in the processing set). + assert (and [ rdeppkgid `Set.notMember` processingSet + | pkgid <- Set.toList processingSet + , rdeppkgid <- maybe (internalError "processingInvariant" "") + (map nodeKey) + (Graph.revNeighbors (planGraph plan) pkgid) + ]) $ + + -- Packages from the processing or failed sets are only ever in the + -- configured state. + assert (and [ case Graph.lookup pkgid (planGraph plan) of + Just (Configured _) -> True + Just (PreExisting _) -> False + Just (Installed _) -> False + Nothing -> False + | pkgid <- Set.toList processingSet ++ Set.toList failedSet ]) + + -- We use asserts rather than returning False so that on failure we get + -- better details on which bit of the invariant was violated. + True + where + reverseClosure = Set.fromList + . map nodeKey + . fromMaybe (internalError "processingInvariant" "") + . Graph.revClosure (planGraph plan) + . Set.toList + noIntersection a b = Set.null (Set.intersection a b) + + +-- ------------------------------------------------------------ +-- * Traversing plans +-- ------------------------------------------------------------ + +-- | Flatten an 'InstallPlan', producing the sequence of source packages in +-- the order in which they would be processed when the plan is executed. This +-- can be used for simulations or presenting execution dry-runs. +-- +-- It is guaranteed to give the same order as using 'execute' (with a serial +-- in-order 'JobControl'), which is a reverse topological orderings of the +-- source packages in the dependency graph, albeit not necessarily exactly the +-- same ordering as that produced by 'reverseTopologicalOrder'. +-- +executionOrder :: (IsUnit ipkg, IsUnit srcpkg) + => GenericInstallPlan ipkg srcpkg + -> [GenericReadyPackage srcpkg] +executionOrder plan = + let (newpkgs, processing) = ready plan + in tryNewTasks processing newpkgs + where + tryNewTasks _processing [] = [] + tryNewTasks processing (p:todo) = waitForTasks processing p todo + + waitForTasks processing p todo = + p : tryNewTasks processing' (todo++nextpkgs) + where + (nextpkgs, processing') = completed plan processing (nodeKey p) + + +-- ------------------------------------------------------------ +-- * Executing plans +-- ------------------------------------------------------------ + +-- | The set of results we get from executing an install plan. +-- +type BuildOutcomes failure result = Map UnitId (Either failure result) + +-- | Lookup the build result for a single package. +-- +lookupBuildOutcome :: HasUnitId pkg + => pkg -> BuildOutcomes failure result + -> Maybe (Either failure result) +lookupBuildOutcome = Map.lookup . installedUnitId + +-- | Execute an install plan. This traverses the plan in dependency order. +-- +-- Executing each individual package can fail and if so all dependents fail +-- too. The result for each package is collected as a 'BuildOutcomes' map. +-- +-- Visiting each package happens with optional parallelism, as determined by +-- the 'JobControl'. By default, after any failure we stop as soon as possible +-- (using the 'JobControl' to try to cancel in-progress tasks). This behaviour +-- can be reversed to keep going and build as many packages as possible. +-- +-- Note that the 'BuildOutcomes' is /not/ guaranteed to cover all the packages +-- in the plan. In particular in the default mode where we stop as soon as +-- possible after a failure then there may be packages which are skipped and +-- these will have no 'BuildOutcome'. +-- +execute :: forall m ipkg srcpkg result failure. + (IsUnit ipkg, IsUnit srcpkg, + Monad m) + => JobControl m (UnitId, 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) +execute jobCtl keepGoing depFailure plan installPkg = + let (newpkgs, processing) = ready plan + in tryNewTasks Map.empty False False processing newpkgs + where + tryNewTasks :: BuildOutcomes failure result + -> Bool -> Bool -> Processing + -> [GenericReadyPackage srcpkg] + -> m (BuildOutcomes failure result) + + tryNewTasks !results tasksFailed tasksRemaining !processing newpkgs + -- we were in the process of cancelling and now we're finished + | tasksFailed && not keepGoing && not tasksRemaining + = return results + + -- we are still in the process of cancelling, wait for remaining tasks + | tasksFailed && not keepGoing && tasksRemaining + = waitForTasks results tasksFailed processing + + -- no new tasks to do and all tasks are done so we're finished + | null newpkgs && not tasksRemaining + = return results + + -- no new tasks to do, remaining tasks to wait for + | null newpkgs + = waitForTasks results tasksFailed processing + + -- new tasks to do, spawn them, then wait for tasks to complete + | otherwise + = do sequence_ [ spawnJob jobCtl $ do + result <- installPkg pkg + return (nodeKey pkg, result) + | pkg <- newpkgs ] + waitForTasks results tasksFailed processing + + waitForTasks :: BuildOutcomes failure result + -> Bool -> Processing + -> m (BuildOutcomes failure result) + waitForTasks !results tasksFailed !processing = do + (pkgid, result) <- collectJob jobCtl + + case result of + + Right _success -> do + tasksRemaining <- remainingJobs jobCtl + tryNewTasks results' tasksFailed tasksRemaining + processing' nextpkgs + where + results' = Map.insert pkgid result results + (nextpkgs, processing') = completed plan processing pkgid + + Left _failure -> do + -- if this is the first failure and we're not trying to keep going + -- then try to cancel as many of the remaining jobs as possible + when (not tasksFailed && not keepGoing) $ + cancelJobs jobCtl + + tasksRemaining <- remainingJobs jobCtl + tryNewTasks results' True tasksRemaining processing' [] + where + (depsfailed, processing') = failed plan processing pkgid + results' = Map.insert pkgid result results `Map.union` depResults + depResults = Map.fromList + [ (nodeKey deppkg, Left (depFailure deppkg)) + | deppkg <- depsfailed ] + +-- ------------------------------------------------------------ +-- * Checking validity of plans +-- ------------------------------------------------------------ + +-- | 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] + | PackageStateInvalid (GenericPlanPackage ipkg srcpkg) + (GenericPlanPackage ipkg srcpkg) + +showPlanProblem :: (IsUnit ipkg, IsUnit 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" + +-- | 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) + => Graph (GenericPlanPackage ipkg srcpkg) + -> [PlanProblem ipkg srcpkg] +problems graph = + + [ PackageMissingDeps pkg + (mapMaybe + (fmap nodeKey . flip Graph.lookup graph) + 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 (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 +-- package @b@ we require that @stateDependencyRelation a b = True@. +-- +stateDependencyRelation :: GenericPlanPackage ipkg srcpkg + -> GenericPlanPackage ipkg srcpkg -> Bool +stateDependencyRelation PreExisting{} PreExisting{} = True + +stateDependencyRelation Installed{} PreExisting{} = True +stateDependencyRelation Installed{} Installed{} = True + +stateDependencyRelation Configured{} PreExisting{} = True +stateDependencyRelation Configured{} Installed{} = True +stateDependencyRelation Configured{} Configured{} = True + +stateDependencyRelation _ _ = False diff --git a/cabal/cabal-install/src/Distribution/Client/InstallSymlink.hs b/cabal/cabal-install/src/Distribution/Client/InstallSymlink.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/InstallSymlink.hs @@ -0,0 +1,292 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.InstallSymlink +-- Copyright : (c) Duncan Coutts 2008 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Managing installing binaries with symlinks. +----------------------------------------------------------------------------- +module Distribution.Client.InstallSymlink ( + symlinkBinaries, + symlinkBinary, + trySymlink, + promptRun + ) where + +import Distribution.Client.Compat.Prelude hiding (ioError) +import Prelude () + +import Distribution.Client.Types + ( ConfiguredPackage(..), BuildOutcomes ) +import Distribution.Client.Setup + ( InstallFlags(installSymlinkBinDir) ) +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.InstallPlan (InstallPlan) + +import Distribution.Solver.Types.SourcePackage +import Distribution.Solver.Types.OptionalStanza + +import Distribution.Package + ( PackageIdentifier, Package(packageId), UnitId, installedUnitId ) +import Distribution.Types.UnqualComponentName +import Distribution.Compiler + ( CompilerId(..) ) +import qualified Distribution.PackageDescription as PackageDescription +import Distribution.PackageDescription + ( PackageDescription ) +import Distribution.PackageDescription.Configuration + ( finalizePD ) +import Distribution.Simple.Setup + ( ConfigFlags(..), fromFlag, fromFlagOrDefault, flagToMaybe ) +import qualified Distribution.Simple.InstallDirs as InstallDirs +import Distribution.Simple.Compiler + ( Compiler, compilerInfo, CompilerInfo(..) ) +import Distribution.System + ( Platform ) +import Distribution.Simple.Utils ( info, withTempDirectory ) + +import System.Directory + ( canonicalizePath, getTemporaryDirectory, removeFile ) +import System.FilePath + ( (), splitPath, joinPath, isAbsolute ) + +import System.IO.Error + ( isDoesNotExistError, ioError ) +import Control.Exception + ( assert ) + +import Distribution.Client.Compat.Directory ( createFileLink, getSymbolicLinkTarget, pathIsSymbolicLink ) +import Distribution.Client.Types.OverwritePolicy +import Distribution.Client.Init.Types ( DefaultPrompt(MandatoryPrompt) ) +import Distribution.Client.Init.Prompt ( promptYesNo ) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 + +-- | We would like by default to install binaries into some location that is on +-- the user's PATH. For per-user installations on Unix systems that basically +-- means the @~/bin/@ directory. On the majority of platforms the @~/bin/@ +-- directory will be on the user's PATH. However some people are a bit nervous +-- about letting a package manager install programs into @~/bin/@. +-- +-- A compromise solution is that instead of installing binaries directly into +-- @~/bin/@, we could install them in a private location under @~/.cabal/bin@ +-- and then create symlinks in @~/bin/@. We can be careful when setting up the +-- symlinks that we do not overwrite any binary that the user installed. We can +-- check if it was a symlink we made because it would point to the private dir +-- where we install our binaries. This means we can install normally without +-- worrying and in a later phase set up symlinks, and if that fails then we +-- report it to the user, but even in this case the package is still in an OK +-- installed state. +-- +-- This is an optional feature that users can choose to use or not. It is +-- controlled from the config file. Of course it only works on POSIX systems +-- with symlinks so is not available to Windows users. +-- +symlinkBinaries :: Platform -> Compiler + -> OverwritePolicy + -> ConfigFlags + -> InstallFlags + -> InstallPlan + -> BuildOutcomes + -> IO [(PackageIdentifier, UnqualComponentName, FilePath)] +symlinkBinaries platform comp overwritePolicy + configFlags installFlags + plan buildOutcomes = + case flagToMaybe (installSymlinkBinDir installFlags) of + Nothing -> return [] + Just symlinkBinDir + | null exes -> return [] + | otherwise -> do + publicBinDir <- canonicalizePath symlinkBinDir +-- TODO: do we want to do this here? : +-- createDirectoryIfMissing True publicBinDir + fmap catMaybes $ sequenceA + [ do privateBinDir <- pkgBinDir pkg ipid + ok <- symlinkBinary + overwritePolicy + publicBinDir privateBinDir + (prettyShow publicExeName) privateExeName + if ok + then return Nothing + else return (Just (pkgid, publicExeName, + privateBinDir privateExeName)) + | (rpkg, pkg, exe) <- exes + , let pkgid = packageId pkg + -- This is a bit dodgy; probably won't work for Backpack packages + ipid = installedUnitId rpkg + publicExeName = PackageDescription.exeName exe + privateExeName = prefix ++ unUnqualComponentName publicExeName ++ suffix + prefix = substTemplate pkgid ipid prefixTemplate + suffix = substTemplate pkgid ipid suffixTemplate ] + where + exes = + [ (cpkg, pkg, exe) + | InstallPlan.Configured cpkg <- InstallPlan.toList plan + , case InstallPlan.lookupBuildOutcome cpkg buildOutcomes of + Just (Right _success) -> True + _ -> False + , let pkg :: PackageDescription + pkg = pkgDescription cpkg + , exe <- PackageDescription.executables pkg + , PackageDescription.buildable (PackageDescription.buildInfo exe) ] + + pkgDescription (ConfiguredPackage _ (SourcePackage _ gpd _ _) + flags stanzas _) = + case finalizePD flags (enableStanzas stanzas) + (const True) + platform cinfo [] gpd of + Left _ -> error "finalizePD ReadyPackage failed" + Right (desc, _) -> desc + + -- This is sadly rather complicated. We're kind of re-doing part of the + -- configuration for the package. :-( + pkgBinDir :: PackageDescription -> UnitId -> IO FilePath + pkgBinDir pkg ipid = do + defaultDirs <- InstallDirs.defaultInstallDirs + compilerFlavor + (fromFlag (configUserInstall configFlags)) + (PackageDescription.hasLibs pkg) + let templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault + defaultDirs (configInstallDirs configFlags) + absoluteDirs = InstallDirs.absoluteInstallDirs + (packageId pkg) ipid + cinfo InstallDirs.NoCopyDest + platform templateDirs + canonicalizePath (InstallDirs.bindir absoluteDirs) + + substTemplate pkgid ipid = InstallDirs.fromPathTemplate + . InstallDirs.substPathTemplate env + where env = InstallDirs.initialPathTemplateEnv pkgid ipid + cinfo platform + + fromFlagTemplate = fromFlagOrDefault (InstallDirs.toPathTemplate "") + prefixTemplate = fromFlagTemplate (configProgPrefix configFlags) + suffixTemplate = fromFlagTemplate (configProgSuffix configFlags) + cinfo = compilerInfo comp + (CompilerId compilerFlavor _) = compilerInfoId cinfo + +-- | Symlink binary. +-- +-- The paths are take in pieces, so we can make relative link when possible. +-- +symlinkBinary :: + OverwritePolicy -- ^ Whether to force overwrite an existing file + -> FilePath -- ^ The canonical path of the public bin dir eg + -- @/home/user/bin@ + -> FilePath -- ^ The canonical path of the private bin dir eg + -- @/home/user/.cabal/bin@ + -> FilePath -- ^ The name of the executable to go in the public bin + -- dir, eg @foo@ + -> String -- ^ The name of the executable to in the private bin + -- dir, eg @foo-1.0@ + -> IO Bool -- ^ If creating the symlink was successful. @False@ if + -- there was another file there already that we did + -- not own. Other errors like permission errors just + -- propagate as exceptions. +symlinkBinary overwritePolicy publicBindir privateBindir publicName privateName = do + ok <- targetOkToOverwrite (publicBindir publicName) + (privateBindir privateName) + case ok of + NotExists -> mkLink + OkToOverwrite -> overwrite + NotOurFile -> + case overwritePolicy of + NeverOverwrite -> return False + AlwaysOverwrite -> overwrite + PromptOverwrite -> maybeOverwrite + where + relativeBindir = makeRelative publicBindir privateBindir + mkLink :: IO Bool + mkLink = True <$ createFileLink (relativeBindir privateName) (publicBindir publicName) + rmLink :: IO Bool + rmLink = True <$ removeFile (publicBindir publicName) + overwrite :: IO Bool + overwrite = rmLink *> mkLink + maybeOverwrite :: IO Bool + maybeOverwrite + = promptRun + "Existing file found while installing symlink. Do you want to overwrite that file? (y/n)" + overwrite + +promptRun :: String -> IO Bool -> IO Bool +promptRun s m = do + a <- promptYesNo s MandatoryPrompt + if a then m else pure a + +-- | Check a file path of a symlink that we would like to create to see if it +-- is OK. For it to be OK to overwrite it must either not already exist yet or +-- be a symlink to our target (in which case we can assume ownership). +-- +targetOkToOverwrite :: FilePath -- ^ The file path of the symlink to the private + -- binary that we would like to create + -> FilePath -- ^ The canonical path of the private binary. + -- Use 'canonicalizePath' to make this. + -> IO SymlinkStatus +targetOkToOverwrite symlink target = handleNotExist $ do + isLink <- pathIsSymbolicLink symlink + if not isLink + then return NotOurFile + else do target' <- canonicalizePath =<< getSymbolicLinkTarget symlink + -- This partially relies on canonicalizePath handling symlinks + if target == target' + then return OkToOverwrite + else return NotOurFile + + where + handleNotExist action = catchIO action $ \ioexception -> + -- If the target doesn't exist then there's no problem overwriting it! + if isDoesNotExistError ioexception + then return NotExists + else ioError ioexception + +data SymlinkStatus + = NotExists -- ^ The file doesn't exist so we can make a symlink. + | OkToOverwrite -- ^ A symlink already exists, though it is ours. We'll + -- have to delete it first before we make a new symlink. + | NotOurFile -- ^ A file already exists and it is not one of our existing + -- symlinks (either because it is not a symlink or because + -- it points somewhere other than our managed space). + deriving Show + +-- | Take two canonical paths and produce a relative path to get from the first +-- to the second, even if it means adding @..@ path components. +-- +makeRelative :: FilePath -> FilePath -> FilePath +makeRelative a b = assert (isAbsolute a && isAbsolute b) $ + let as = splitPath a + bs = splitPath b + commonLen = length $ takeWhile id $ zipWith (==) as bs + in joinPath $ [ ".." | _ <- drop commonLen as ] + ++ drop commonLen bs + +-- | Try to make a symlink in a temporary directory. +-- +-- If this works, we can try to symlink: even on Windows. +-- +trySymlink :: Verbosity -> IO Bool +trySymlink verbosity = do + tmp <- getTemporaryDirectory + withTempDirectory verbosity tmp "cabal-symlink-test" $ \tmpDirPath -> do + let from = tmpDirPath "file.txt" + let to = tmpDirPath "file2.txt" + + -- create a file + BS.writeFile from (BS8.pack "TEST") + + -- create a symbolic link + let create :: IO Bool + create = do + createFileLink from to + info verbosity $ "Symlinking seems to work" + return True + + create `catchIO` \exc -> do + info verbosity $ "Symlinking doesn't seem to be working: " ++ show exc + return False diff --git a/cabal/cabal-install/src/Distribution/Client/JobControl.hs b/cabal/cabal-install/src/Distribution/Client/JobControl.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/JobControl.hs @@ -0,0 +1,179 @@ +{-# LANGUAGE FlexibleContexts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.JobControl +-- Copyright : (c) Duncan Coutts 2012 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- A job control concurrency abstraction +----------------------------------------------------------------------------- +module Distribution.Client.JobControl ( + JobControl, + newSerialJobControl, + newParallelJobControl, + spawnJob, + collectJob, + remainingJobs, + cancelJobs, + + JobLimit, + newJobLimit, + withJobLimit, + + Lock, + newLock, + criticalSection + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Control.Monad (forever, replicateM_) +import Control.Concurrent (forkIO) +import Control.Concurrent.MVar +import Control.Concurrent.STM (STM, atomically) +import Control.Concurrent.STM.TVar +import Control.Concurrent.STM.TChan +import Control.Exception (bracket_, try) +import Distribution.Compat.Stack +import Distribution.Client.Compat.Semaphore + + +-- | A simple concurrency abstraction. Jobs can be spawned and can complete +-- in any order. This allows both serial and parallel implementations. +-- +data JobControl m a = JobControl { + -- | Add a new job to the pool of jobs + spawnJob :: m a -> m (), + + -- | Wait until one job is complete + collectJob :: m a, + + -- | Returns True if there are any outstanding jobs + -- (ie spawned but yet to be collected) + remainingJobs :: m Bool, + + -- | Try to cancel any outstanding but not-yet-started jobs. + -- Call 'remainingJobs' after this to find out if any jobs are left + -- (ie could not be cancelled). + cancelJobs :: m () + } + + +-- | Make a 'JobControl' that executes all jobs serially and in order. +-- It only executes jobs on demand when they are collected, not eagerly. +-- +-- Cancelling will cancel /all/ jobs that have not been collected yet. +-- +newSerialJobControl :: IO (JobControl IO a) +newSerialJobControl = do + qVar <- newTChanIO + return JobControl { + spawnJob = spawn qVar, + collectJob = collect qVar, + remainingJobs = remaining qVar, + cancelJobs = cancel qVar + } + where + spawn :: TChan (IO a) -> IO a -> IO () + spawn qVar job = atomically $ writeTChan qVar job + + collect :: TChan (IO a) -> IO a + collect qVar = + join $ atomically $ readTChan qVar + + remaining :: TChan (IO a) -> IO Bool + remaining qVar = fmap not $ atomically $ isEmptyTChan qVar + + cancel :: TChan (IO a) -> IO () + cancel qVar = do + _ <- atomically $ readAllTChan qVar + return () + +-- | Make a 'JobControl' that eagerly executes jobs in parallel, with a given +-- maximum degree of parallelism. +-- +-- Cancelling will cancel jobs that have not yet begun executing, but jobs +-- that have already been executed or are currently executing cannot be +-- cancelled. +-- +newParallelJobControl :: WithCallStack (Int -> IO (JobControl IO a)) +newParallelJobControl n | n < 1 || n > 1000 = + error $ "newParallelJobControl: not a sensible number of jobs: " ++ show n +newParallelJobControl maxJobLimit = do + inqVar <- newTChanIO + outqVar <- newTChanIO + countVar <- newTVarIO 0 + replicateM_ maxJobLimit $ + forkIO $ + worker inqVar outqVar + return JobControl { + spawnJob = spawn inqVar countVar, + collectJob = collect outqVar countVar, + remainingJobs = remaining countVar, + cancelJobs = cancel inqVar countVar + } + where + worker :: TChan (IO a) -> TChan (Either SomeException a) -> IO () + worker inqVar outqVar = + forever $ do + job <- atomically $ readTChan inqVar + res <- try job + atomically $ writeTChan outqVar res + + spawn :: TChan (IO a) -> TVar Int -> IO a -> IO () + spawn inqVar countVar job = + atomically $ do + modifyTVar' countVar (+1) + writeTChan inqVar job + + collect :: TChan (Either SomeException a) -> TVar Int -> IO a + collect outqVar countVar = do + res <- atomically $ do + modifyTVar' countVar (subtract 1) + readTChan outqVar + either throwIO return res + + remaining :: TVar Int -> IO Bool + remaining countVar = fmap (/=0) $ atomically $ readTVar countVar + + cancel :: TChan (IO a) -> TVar Int -> IO () + cancel inqVar countVar = + atomically $ do + xs <- readAllTChan inqVar + modifyTVar' countVar (subtract (length xs)) + +readAllTChan :: TChan a -> STM [a] +readAllTChan qvar = go [] + where + go xs = do + mx <- tryReadTChan qvar + case mx of + Nothing -> return (reverse xs) + Just x -> go (x:xs) + +------------------------- +-- Job limits and locks +-- + +data JobLimit = JobLimit QSem + +newJobLimit :: Int -> IO JobLimit +newJobLimit n = + fmap JobLimit (newQSem n) + +withJobLimit :: JobLimit -> IO a -> IO a +withJobLimit (JobLimit sem) = + bracket_ (waitQSem sem) (signalQSem sem) + +newtype Lock = Lock (MVar ()) + +newLock :: IO Lock +newLock = fmap Lock $ newMVar () + +criticalSection :: Lock -> IO a -> IO a +criticalSection (Lock lck) act = bracket_ (takeMVar lck) (putMVar lck ()) act diff --git a/cabal/cabal-install/src/Distribution/Client/List.hs b/cabal/cabal-install/src/Distribution/Client/List.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/List.hs @@ -0,0 +1,627 @@ +{-# LANGUAGE ScopedTypeVariables #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.List +-- Copyright : (c) David Himmelstrup 2005 +-- Duncan Coutts 2008-2011 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- +-- Search for and print information about packages +----------------------------------------------------------------------------- +module Distribution.Client.List ( + list, info + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Distribution.Package + ( PackageName, Package(..), packageName + , packageVersion, UnitId ) +import Distribution.Types.Dependency +import Distribution.Types.UnqualComponentName +import Distribution.ModuleName (ModuleName) +import Distribution.License (License) +import qualified Distribution.InstalledPackageInfo as Installed +import qualified Distribution.PackageDescription as Source +import Distribution.PackageDescription + ( PackageFlag(..), unFlagName ) +import Distribution.PackageDescription.Configuration + ( flattenPackageDescription ) + +import Distribution.Simple.Compiler + ( Compiler, PackageDBStack ) +import Distribution.Simple.Program (ProgramDb) +import Distribution.Simple.Utils + ( equating, die', notice ) +import Distribution.Simple.Setup (fromFlag, fromFlagOrDefault) +import Distribution.Simple.PackageIndex (InstalledPackageIndex) +import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex +import Distribution.Version + ( Version, mkVersion, versionNumbers, VersionRange, withinRange, anyVersion + , intersectVersionRanges, simplifyVersionRange ) + +import qualified Distribution.SPDX as SPDX + +import Distribution.Solver.Types.PackageConstraint +import qualified Distribution.Solver.Types.PackageIndex as PackageIndex +import Distribution.Solver.Types.SourcePackage + +import Distribution.Client.Types + ( SourcePackageDb(..), PackageSpecifier(..), UnresolvedSourcePackage ) +import Distribution.Client.Targets + ( UserTarget, resolveUserTargets ) +import Distribution.Client.Setup + ( GlobalFlags(..), ListFlags(..), InfoFlags(..) + , RepoContext(..) ) +import Distribution.Client.Utils + ( mergeBy, MergeResult(..) ) +import Distribution.Client.IndexUtils as IndexUtils + ( getSourcePackages, getInstalledPackages ) +import Distribution.Client.FetchUtils + ( isFetched ) + +import Data.Bits ((.|.)) +import Data.List + ( maximumBy ) +import Data.List.NonEmpty (groupBy) +import qualified Data.List as L +import Data.Maybe + ( fromJust ) +import qualified Data.Map as Map +import Data.Tree as Tree +import Control.Exception + ( assert ) +import qualified Text.PrettyPrint as Disp +import Text.PrettyPrint + ( lineLength, ribbonsPerLine, Doc, renderStyle, char + , nest, ($+$), text, vcat, style, parens, fsep) +import System.Directory + ( doesDirectoryExist ) + +import Distribution.Utils.ShortText (ShortText) +import qualified Distribution.Utils.ShortText as ShortText +import qualified Text.Regex.Base as Regex +import qualified Text.Regex.Posix.String as Regex + + +-- | Return a list of packages matching given search strings. +getPkgList :: Verbosity + -> PackageDBStack + -> RepoContext + -> Maybe (Compiler, ProgramDb) + -> ListFlags + -> [String] + -> IO [PackageDisplayInfo] +getPkgList verbosity packageDBs repoCtxt mcompprogdb listFlags pats = do + installedPkgIndex <- for mcompprogdb $ \(comp, progdb) -> + getInstalledPackages verbosity comp packageDBs progdb + sourcePkgDb <- getSourcePackages verbosity repoCtxt + + regexps <- for pats $ \pat -> do + e <- Regex.compile compOption Regex.execBlank pat + case e of + Right r -> return r + Left err -> die' verbosity $ "Failed to compile regex " ++ pat ++ ": " ++ snd err + + let sourcePkgIndex = packageIndex sourcePkgDb + prefs name = fromMaybe anyVersion + (Map.lookup name (packagePreferences sourcePkgDb)) + + pkgsInfoMatching :: + [(PackageName, [Installed.InstalledPackageInfo], [UnresolvedSourcePackage])] + pkgsInfoMatching = + let matchingInstalled = maybe [] (matchingPackages InstalledPackageIndex.searchWithPredicate regexps) installedPkgIndex + matchingSource = matchingPackages (\ idx n -> concatMap snd (PackageIndex.searchWithPredicate idx n)) regexps sourcePkgIndex + in mergePackages matchingInstalled matchingSource + + pkgsInfo :: + [(PackageName, [Installed.InstalledPackageInfo], [UnresolvedSourcePackage])] + pkgsInfo + -- gather info for all packages + | null regexps = mergePackages + (maybe [] InstalledPackageIndex.allPackages installedPkgIndex) + ( PackageIndex.allPackages sourcePkgIndex) + + -- gather info for packages matching search term + | otherwise = pkgsInfoMatching + + matches :: [PackageDisplayInfo] + matches = [ mergePackageInfo pref + installedPkgs sourcePkgs selectedPkg False + | (pkgname, installedPkgs, sourcePkgs) <- pkgsInfo + , not onlyInstalled || not (null installedPkgs) + , let pref = prefs pkgname + selectedPkg = latestWithPref pref sourcePkgs ] + return matches + where + onlyInstalled = fromFlagOrDefault False (listInstalled listFlags) + caseInsensitive = fromFlagOrDefault True (listCaseInsensitive listFlags) + + compOption | caseInsensitive = Regex.compExtended .|. Regex.compIgnoreCase + | otherwise = Regex.compExtended + + matchingPackages search regexps index = + [ pkg + | re <- regexps + , pkg <- search index (Regex.matchTest re) ] + + +-- | Show information about packages. +list :: Verbosity + -> PackageDBStack + -> RepoContext + -> Maybe (Compiler, ProgramDb) + -> ListFlags + -> [String] + -> IO () +list verbosity packageDBs repos mcompProgdb listFlags pats = do + matches <- getPkgList verbosity packageDBs repos mcompProgdb listFlags pats + + if simpleOutput + then putStr $ unlines + [ prettyShow (pkgName pkg) ++ " " ++ prettyShow version + | pkg <- matches + , version <- if onlyInstalled + then installedVersions pkg + else nub . sort $ installedVersions pkg + ++ sourceVersions pkg ] + -- Note: this only works because for 'list', one cannot currently + -- specify any version constraints, so listing all installed + -- and source ones works. + else + if null matches + then notice verbosity "No matches found." + else putStr $ unlines (map showPackageSummaryInfo matches) + where + onlyInstalled = fromFlag (listInstalled listFlags) + simpleOutput = fromFlag (listSimpleOutput listFlags) + +info :: Verbosity + -> PackageDBStack + -> RepoContext + -> Compiler + -> ProgramDb + -> GlobalFlags + -> InfoFlags + -> [UserTarget] + -> IO () +info verbosity _ _ _ _ _ _ [] = + notice verbosity "No packages requested. Nothing to do." + +info verbosity packageDBs repoCtxt comp progdb + _ _listFlags userTargets = do + + installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb + sourcePkgDb <- getSourcePackages verbosity repoCtxt + let sourcePkgIndex = packageIndex sourcePkgDb + prefs name = fromMaybe anyVersion + (Map.lookup name (packagePreferences sourcePkgDb)) + + -- Users may specify names of packages that are only installed, not + -- just available source packages, so we must resolve targets using + -- the combination of installed and source packages. + let sourcePkgs' = PackageIndex.fromList + $ map packageId + (InstalledPackageIndex.allPackages installedPkgIndex) + ++ map packageId + (PackageIndex.allPackages sourcePkgIndex) + pkgSpecifiers <- resolveUserTargets verbosity repoCtxt + sourcePkgs' userTargets + + pkgsinfo <- sequenceA + [ do pkginfo <- either (die' verbosity) return $ + gatherPkgInfo prefs + installedPkgIndex sourcePkgIndex + pkgSpecifier + updateFileSystemPackageDetails pkginfo + | pkgSpecifier <- pkgSpecifiers ] + + putStr $ unlines (map showPackageDetailedInfo pkgsinfo) + + where + gatherPkgInfo :: (PackageName -> VersionRange) -> + InstalledPackageIndex -> + PackageIndex.PackageIndex UnresolvedSourcePackage -> + PackageSpecifier UnresolvedSourcePackage -> + Either String PackageDisplayInfo + gatherPkgInfo prefs installedPkgIndex sourcePkgIndex + (NamedPackage name props) + | null (selectedInstalledPkgs) && null (selectedSourcePkgs) + = Left $ "There is no available version of " ++ prettyShow name + ++ " that satisfies " + ++ prettyShow (simplifyVersionRange verConstraint) + + | otherwise + = Right $ mergePackageInfo pref installedPkgs + sourcePkgs selectedSourcePkg' + showPkgVersion + where + (pref, installedPkgs, sourcePkgs) = + sourcePkgsInfo prefs name installedPkgIndex sourcePkgIndex + + selectedInstalledPkgs = InstalledPackageIndex.lookupDependency + installedPkgIndex + name verConstraint + selectedSourcePkgs = PackageIndex.lookupDependency sourcePkgIndex + name verConstraint + selectedSourcePkg' = latestWithPref pref selectedSourcePkgs + + -- display a specific package version if the user + -- supplied a non-trivial version constraint + showPkgVersion = not (null verConstraints) + verConstraint = foldr intersectVersionRanges anyVersion verConstraints + verConstraints = [ vr | PackagePropertyVersion vr <- props ] + + gatherPkgInfo prefs installedPkgIndex sourcePkgIndex + (SpecificSourcePackage pkg) = + Right $ mergePackageInfo pref installedPkgs sourcePkgs + selectedPkg True + where + name = packageName pkg + selectedPkg = Just pkg + (pref, installedPkgs, sourcePkgs) = + sourcePkgsInfo prefs name installedPkgIndex sourcePkgIndex + +sourcePkgsInfo :: + (PackageName -> VersionRange) + -> PackageName + -> InstalledPackageIndex + -> PackageIndex.PackageIndex UnresolvedSourcePackage + -> (VersionRange, [Installed.InstalledPackageInfo], [UnresolvedSourcePackage]) +sourcePkgsInfo prefs name installedPkgIndex sourcePkgIndex = + (pref, installedPkgs, sourcePkgs) + where + pref = prefs name + installedPkgs = concatMap snd (InstalledPackageIndex.lookupPackageName + installedPkgIndex name) + sourcePkgs = PackageIndex.lookupPackageName sourcePkgIndex name + + +-- | The info that we can display for each package. It is information per +-- package name and covers all installed and available versions. +-- +data PackageDisplayInfo = PackageDisplayInfo { + pkgName :: PackageName, + selectedVersion :: Maybe Version, + selectedSourcePkg :: Maybe UnresolvedSourcePackage, + installedVersions :: [Version], + sourceVersions :: [Version], + preferredVersions :: VersionRange, + homepage :: ShortText, + bugReports :: ShortText, + sourceRepo :: String, -- TODO + synopsis :: ShortText, + description :: ShortText, + category :: ShortText, + license :: Either SPDX.License License, + author :: ShortText, + maintainer :: ShortText, + dependencies :: [ExtDependency], + flags :: [PackageFlag], + hasLib :: Bool, + hasExe :: Bool, + executables :: [UnqualComponentName], + modules :: [ModuleName], + haddockHtml :: FilePath, + haveTarball :: Bool + } + +-- | Covers source dependencies and installed dependencies in +-- one type. +data ExtDependency = SourceDependency Dependency + | InstalledDependency UnitId + +showPackageSummaryInfo :: PackageDisplayInfo -> String +showPackageSummaryInfo pkginfo = + renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $ + char '*' <+> pretty (pkgName pkginfo) + $+$ + (nest 4 $ vcat [ + maybeShowST (synopsis pkginfo) "Synopsis:" reflowParagraphs + , text "Default available version:" <+> + case selectedSourcePkg pkginfo of + Nothing -> text "[ Not available from any configured repository ]" + Just pkg -> pretty (packageVersion pkg) + , text "Installed versions:" <+> + case installedVersions pkginfo of + [] | hasLib pkginfo -> text "[ Not installed ]" + | otherwise -> text "[ Unknown ]" + versions -> dispTopVersions 4 + (preferredVersions pkginfo) versions + , maybeShowST (homepage pkginfo) "Homepage:" text + , text "License: " <+> either pretty pretty (license pkginfo) + ]) + $+$ text "" + where + maybeShowST l s f + | ShortText.null l = Disp.empty + | otherwise = text s <+> f (ShortText.fromShortText l) + +showPackageDetailedInfo :: PackageDisplayInfo -> String +showPackageDetailedInfo pkginfo = + renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $ + char '*' <+> pretty (pkgName pkginfo) + <<>> maybe Disp.empty (\v -> char '-' Disp.<> pretty v) (selectedVersion pkginfo) + <+> text (replicate (16 - length (prettyShow (pkgName pkginfo))) ' ') + <<>> parens pkgkind + $+$ + (nest 4 $ vcat [ + entryST "Synopsis" synopsis hideIfNull reflowParagraphs + , entry "Versions available" sourceVersions + (altText null "[ Not available from server ]") + (dispTopVersions 9 (preferredVersions pkginfo)) + , entry "Versions installed" installedVersions + (altText null (if hasLib pkginfo then "[ Not installed ]" + else "[ Unknown ]")) + (dispTopVersions 4 (preferredVersions pkginfo)) + , entryST "Homepage" homepage orNotSpecified text + , entryST "Bug reports" bugReports orNotSpecified text + , entryST "Description" description hideIfNull reflowParagraphs + , entryST "Category" category hideIfNull text + , entry "License" license alwaysShow (either pretty pretty) + , entryST "Author" author hideIfNull reflowLines + , entryST "Maintainer" maintainer hideIfNull reflowLines + , entry "Source repo" sourceRepo orNotSpecified text + , entry "Executables" executables hideIfNull (commaSep pretty) + , entry "Flags" flags hideIfNull (commaSep dispFlag) + , entry "Dependencies" dependencies hideIfNull (commaSep dispExtDep) + , entry "Documentation" haddockHtml showIfInstalled text + , entry "Cached" haveTarball alwaysShow dispYesNo + , if not (hasLib pkginfo) then mempty else + text "Modules:" $+$ nest 4 (vcat (map pretty . sort . modules $ pkginfo)) + ]) + $+$ text "" + where + entry fname field cond format = case cond (field pkginfo) of + Nothing -> label <+> format (field pkginfo) + Just Nothing -> mempty + Just (Just other) -> label <+> text other + where + label = text fname Disp.<> char ':' Disp.<> padding + padding = text (replicate (13 - length fname ) ' ') + + entryST fname field = entry fname (ShortText.fromShortText . field) + + normal = Nothing + hide = Just Nothing + replace msg = Just (Just msg) + + alwaysShow = const normal + hideIfNull v = if null v then hide else normal + showIfInstalled v + | not isInstalled = hide + | null v = replace "[ Not installed ]" + | otherwise = normal + altText nul msg v = if nul v then replace msg else normal + orNotSpecified = altText null "[ Not specified ]" + + commaSep f = Disp.fsep . Disp.punctuate (Disp.char ',') . map f + dispFlag = text . unFlagName . flagName + dispYesNo True = text "Yes" + dispYesNo False = text "No" + + dispExtDep (SourceDependency dep) = pretty dep + dispExtDep (InstalledDependency dep) = pretty dep + + isInstalled = not (null (installedVersions pkginfo)) + hasExes = length (executables pkginfo) >= 2 + --TODO: exclude non-buildable exes + pkgkind | hasLib pkginfo && hasExes = text "programs and library" + | hasLib pkginfo && hasExe pkginfo = text "program and library" + | hasLib pkginfo = text "library" + | hasExes = text "programs" + | hasExe pkginfo = text "program" + | otherwise = mempty + + +reflowParagraphs :: String -> Doc +reflowParagraphs = + vcat + . intersperse (text "") -- re-insert blank lines + . map (fsep . map text . concatMap words) -- reflow paragraphs + . filter (/= [""]) + . L.groupBy (\x y -> "" `notElem` [x,y]) -- break on blank lines + . lines + +reflowLines :: String -> Doc +reflowLines = vcat . map text . lines + +-- | We get the 'PackageDisplayInfo' by combining the info for the installed +-- and available versions of a package. +-- +-- * We're building info about a various versions of a single named package so +-- the input package info records are all supposed to refer to the same +-- package name. +-- +mergePackageInfo :: VersionRange + -> [Installed.InstalledPackageInfo] + -> [UnresolvedSourcePackage] + -> Maybe UnresolvedSourcePackage + -> Bool + -> PackageDisplayInfo +mergePackageInfo versionPref installedPkgs sourcePkgs selectedPkg showVer = + assert (length installedPkgs + length sourcePkgs > 0) $ + PackageDisplayInfo { + pkgName = combine packageName source + packageName installed, + selectedVersion = if showVer then fmap packageVersion selectedPkg + else Nothing, + selectedSourcePkg = sourceSelected, + installedVersions = map packageVersion installedPkgs, + sourceVersions = map packageVersion sourcePkgs, + preferredVersions = versionPref, + + license = combine Source.licenseRaw source + Installed.license installed, + maintainer = combine Source.maintainer source + Installed.maintainer installed, + author = combine Source.author source + Installed.author installed, + homepage = combine Source.homepage source + Installed.homepage installed, + bugReports = maybe mempty Source.bugReports source, + sourceRepo = fromMaybe mempty . join + . fmap (uncons Nothing Source.repoLocation + . sortBy (comparing Source.repoKind) + . Source.sourceRepos) + $ source, + --TODO: installed package info is missing synopsis + synopsis = maybe mempty Source.synopsis source, + description = combine Source.description source + Installed.description installed, + category = combine Source.category source + Installed.category installed, + flags = maybe [] Source.genPackageFlags sourceGeneric, + hasLib = isJust installed + || maybe False (isJust . Source.condLibrary) sourceGeneric, + hasExe = maybe False (not . null . Source.condExecutables) sourceGeneric, + executables = map fst (maybe [] Source.condExecutables sourceGeneric), + modules = combine (map Installed.exposedName . Installed.exposedModules) + installed + -- NB: only for the PUBLIC library + (concatMap getListOfExposedModules . maybeToList . Source.library) + source, + dependencies = + combine (map (SourceDependency . simplifyDependency) + . Source.allBuildDepends) source + (map InstalledDependency . Installed.depends) installed, + haddockHtml = fromMaybe "" . join + . fmap (listToMaybe . Installed.haddockHTMLs) + $ installed, + haveTarball = False + } + where + combine f x g y = fromJust (fmap f x `mplus` fmap g y) + installed :: Maybe Installed.InstalledPackageInfo + installed = latestWithPref versionPref installedPkgs + + getListOfExposedModules lib = Source.exposedModules lib + ++ map Source.moduleReexportName + (Source.reexportedModules lib) + + sourceSelected + | isJust selectedPkg = selectedPkg + | otherwise = latestWithPref versionPref sourcePkgs + sourceGeneric = fmap srcpkgDescription sourceSelected + source = fmap flattenPackageDescription sourceGeneric + + uncons :: b -> (a -> b) -> [a] -> b + uncons z _ [] = z + uncons _ f (x:_) = f x + + +-- | Not all the info is pure. We have to check if the docs really are +-- installed, because the registered package info lies. Similarly we have to +-- check if the tarball has indeed been fetched. +-- +updateFileSystemPackageDetails :: PackageDisplayInfo -> IO PackageDisplayInfo +updateFileSystemPackageDetails pkginfo = do + fetched <- maybe (return False) (isFetched . srcpkgSource) + (selectedSourcePkg pkginfo) + docsExist <- doesDirectoryExist (haddockHtml pkginfo) + return pkginfo { + haveTarball = fetched, + haddockHtml = if docsExist then haddockHtml pkginfo else "" + } + +latestWithPref :: Package pkg => VersionRange -> [pkg] -> Maybe pkg +latestWithPref _ [] = Nothing +latestWithPref pref pkgs = Just (maximumBy (comparing prefThenVersion) pkgs) + where + prefThenVersion pkg = let ver = packageVersion pkg + in (withinRange ver pref, ver) + + +-- | Rearrange installed and source packages into groups referring to the +-- same package by name. In the result pairs, the lists are guaranteed to not +-- both be empty. +-- +mergePackages :: [Installed.InstalledPackageInfo] + -> [UnresolvedSourcePackage] + -> [( PackageName + , [Installed.InstalledPackageInfo] + , [UnresolvedSourcePackage] )] +mergePackages installedPkgs sourcePkgs = + map collect + $ mergeBy (\i a -> fst i `compare` fst a) + (groupOn packageName installedPkgs) + (groupOn packageName sourcePkgs) + where + collect (OnlyInLeft (name,is) ) = (name, is, []) + collect ( InBoth (_,is) (name,as)) = (name, is, as) + collect (OnlyInRight (name,as)) = (name, [], as) + +groupOn :: Ord key => (a -> key) -> [a] -> [(key,[a])] +groupOn key = map (\xs -> (key (head xs), toList xs)) + . groupBy (equating key) + . sortBy (comparing key) + +dispTopVersions :: Int -> VersionRange -> [Version] -> Doc +dispTopVersions n pref vs = + (Disp.fsep . Disp.punctuate (Disp.char ',') + . map (\ver -> if ispref ver then pretty ver else parens (pretty ver)) + . sort . take n . interestingVersions ispref + $ vs) + <+> trailingMessage + + where + ispref ver = withinRange ver pref + extra = length vs - n + trailingMessage + | extra <= 0 = Disp.empty + | otherwise = Disp.parens $ Disp.text "and" + <+> Disp.int (length vs - n) + <+> if extra == 1 then Disp.text "other" + else Disp.text "others" + +-- | Reorder a bunch of versions to put the most interesting / significant +-- versions first. A preferred version range is taken into account. +-- +-- This may be used in a user interface to select a small number of versions +-- to present to the user, e.g. +-- +-- > let selectVersions = sort . take 5 . interestingVersions pref +-- +interestingVersions :: (Version -> Bool) -> [Version] -> [Version] +interestingVersions pref = + map (mkVersion . fst) . filter snd + . concat . Tree.levels + . swizzleTree + . reorderTree (\(Node (v,_) _) -> pref (mkVersion v)) + . reverseTree + . mkTree + . map (or0 . versionNumbers) + + where + or0 [] = 0 :| [] + or0 (x:xs) = x :| xs + + swizzleTree = unfoldTree (spine []) + where + spine ts' (Node x []) = (x, ts') + spine ts' (Node x (t:ts)) = spine (Node x ts:ts') t + + reorderTree _ (Node x []) = Node x [] + reorderTree p (Node x ts) = Node x (ts' ++ ts'') + where + (ts',ts'') = partition p (map (reorderTree p) ts) + + reverseTree (Node x cs) = Node x (reverse (map reverseTree cs)) + + mkTree :: forall a. Eq a => [NonEmpty a] -> Tree ([a], Bool) + mkTree xs = unfoldTree step (False, [], xs) + where + step :: (Bool, [a], [NonEmpty a]) -> (([a], Bool), [(Bool, [a], [NonEmpty a])]) + step (node,ns,vs) = + ( (reverse ns, node) + , [ (any null vs', n:ns, mapMaybe nonEmpty (toList vs')) + | (n, vs') <- groups vs + ] + ) + + groups :: [NonEmpty a] -> [(a, NonEmpty [a])] + groups = map (\g -> (head (head g), fmap tail g)) + . groupBy (equating head) diff --git a/cabal/cabal-install/src/Distribution/Client/Manpage.hs b/cabal/cabal-install/src/Distribution/Client/Manpage.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Manpage.hs @@ -0,0 +1,256 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Manpage +-- Copyright : (c) Maciek Makowski 2015 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Functions for building the manual page. + +module Distribution.Client.Manpage + ( -- * Manual page generation + manpage + , manpageCmd + , ManpageFlags + , defaultManpageFlags + , manpageOptions + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () +import qualified Data.List.NonEmpty as List1 + +import Distribution.Client.Init.Utils (trim) +import Distribution.Client.ManpageFlags +import Distribution.Client.Setup (globalCommand) +import Distribution.Simple.Command +import Distribution.Simple.Flag (fromFlagOrDefault) +import Distribution.Simple.Utils + ( IOData(..), IODataMode(..), createProcessWithEnv, ignoreSigPipe, rawSystemStdInOut ) +import qualified Distribution.Verbosity as Verbosity +import System.IO (hClose, hPutStr) +import System.Environment (lookupEnv) +import System.FilePath (takeFileName) + +import qualified System.Process as Process + +data FileInfo = FileInfo String String -- ^ path, description + +------------------------------------------------------------------------------- +-- +------------------------------------------------------------------------------- + +-- | A list of files that should be documented in the manual page. +files :: [FileInfo] +files = + [ (FileInfo "~/.cabal/config" "The defaults that can be overridden with command-line options.") + ] + +manpageCmd :: String -> [CommandSpec a] -> ManpageFlags -> IO () +manpageCmd pname commands flags + | fromFlagOrDefault False (manpageRaw flags) + = putStrLn contents + | otherwise + = ignoreSigPipe $ do + -- 2021-10-08, issue #7714 + -- @cabal man --raw | man -l -@ does not work on macOS/BSD, + -- because BSD-man does not support option @-l@, rather would + -- accept directly a file argument, e.g. @man /dev/stdin@. + -- The following works both on macOS and Linux + -- (but not on Windows out-of-the-box): + -- + -- cabal man --raw | nroff -man /dev/stdin | less + -- + -- So let us simulate this! + + -- Feed contents into @nroff -man /dev/stdin@ + (formatted, _errors, ec1) <- rawSystemStdInOut + Verbosity.normal + "nroff" + [ "-man", "/dev/stdin" ] + Nothing -- Inherit working directory + Nothing -- Inherit environment + (Just $ IODataText contents) + IODataModeText + + unless (ec1 == ExitSuccess) $ exitWith ec1 + + pager <- fromMaybe "less" <$> lookupEnv "PAGER" + -- 'less' is borked with color sequences otherwise + let pagerArgs = if takeFileName pager == "less" then ["-R"] else [] + -- Pipe output of @nroff@ into @less@ + (Just inLess, _, _, procLess) <- createProcessWithEnv + Verbosity.normal + pager + pagerArgs + Nothing -- Inherit working directory + Nothing -- Inherit environment + Process.CreatePipe -- in + Process.Inherit -- out + Process.Inherit -- err + + hPutStr inLess formatted + hClose inLess + exitWith =<< Process.waitForProcess procLess + where + contents :: String + contents = manpage pname commands + +-- | Produces a manual page with @troff@ markup. +manpage :: String -> [CommandSpec a] -> String +manpage pname commands = unlines $ + [ ".TH " ++ map toUpper pname ++ " 1" + , ".SH NAME" + , pname ++ " \\- a system for building and packaging Haskell libraries and programs" + , ".SH SYNOPSIS" + , ".B " ++ pname + , ".I command" + , ".RI < arguments |[ options ]>..." + , "" + , "Where the" + , ".I commands" + , "are" + , "" + ] ++ + concatMap (commandSynopsisLines pname) commands ++ + [ ".SH DESCRIPTION" + , "Cabal is the standard package system for Haskell software. It helps people to configure, " + , "build and install Haskell software and to distribute it easily to other users and developers." + , "" + , "The command line " ++ pname ++ " tool (also referred to as cabal-install) helps with " + , "installing existing packages and developing new packages. " + , "It can be used to work with local packages or to install packages from online package archives, " + , "including automatically installing dependencies. By default it is configured to use Hackage, " + , "which is Haskell's central package archive that contains thousands of libraries and applications " + , "in the Cabal package format." + , ".SH OPTIONS" + , "Global options:" + , "" + ] ++ + optionsLines (globalCommand []) ++ + [ ".SH COMMANDS" + ] ++ + concatMap (commandDetailsLines pname) commands ++ + [ ".SH FILES" + ] ++ + concatMap fileLines files ++ + [ ".SH BUGS" + , "To browse the list of known issues or report a new one please see " + , "https://github.com/haskell/cabal/labels/cabal-install." + ] + +commandSynopsisLines :: String -> CommandSpec action -> [String] +commandSynopsisLines pname (CommandSpec ui _ NormalCommand) = + [ ".B " ++ pname ++ " " ++ (commandName ui) + , "- " ++ commandSynopsis ui + , ".br" + ] +commandSynopsisLines _ (CommandSpec _ _ HiddenCommand) = [] + +commandDetailsLines :: String -> CommandSpec action -> [String] +commandDetailsLines pname (CommandSpec ui _ NormalCommand) = + [ ".B " ++ pname ++ " " ++ (commandName ui) + , "" + , commandUsage ui pname + , "" + ] ++ + optional removeLineBreaks commandDescription ++ + optional id commandNotes ++ + [ "Flags:" + , ".RS" + ] ++ + optionsLines ui ++ + [ ".RE" + , "" + ] + where + optional f field = + case field ui of + Just text -> [ f $ text pname, "" ] + Nothing -> [] + -- 2021-10-12, https://github.com/haskell/cabal/issues/7714#issuecomment-940842905 + -- Line breaks just before e.g. 'new-build' cause weird @nroff@ warnings. + -- Thus: + -- Remove line breaks but preserve paragraph breaks. + -- We group lines by empty/non-empty and then 'unwords' + -- blocks consisting of non-empty lines. + removeLineBreaks + = unlines + . concatMap unwordsNonEmpty + . List1.groupWith null + . map trim + . lines + unwordsNonEmpty :: List1.NonEmpty String -> [String] + unwordsNonEmpty ls1 = if null (List1.head ls1) then ls else [unwords ls] + where ls = List1.toList ls1 + +commandDetailsLines _ (CommandSpec _ _ HiddenCommand) = [] + +optionsLines :: CommandUI flags -> [String] +optionsLines command = concatMap optionLines (concatMap optionDescr (commandOptions command ParseArgs)) + +data ArgumentRequired = Optional | Required +type OptionArg = (ArgumentRequired, ArgPlaceHolder) + +optionLines :: OptDescr flags -> [String] +optionLines (ReqArg description (optionChars, optionStrings) placeHolder _ _) = + argOptionLines description optionChars optionStrings (Required, placeHolder) +optionLines (OptArg description (optionChars, optionStrings) placeHolder _ _ _) = + argOptionLines description optionChars optionStrings (Optional, placeHolder) +optionLines (BoolOpt description (trueChars, trueStrings) (falseChars, falseStrings) _ _) = + optionLinesIfPresent trueChars trueStrings ++ + optionLinesIfPresent falseChars falseStrings ++ + optionDescriptionLines description +optionLines (ChoiceOpt options) = + concatMap choiceLines options + where + choiceLines (description, (optionChars, optionStrings), _, _) = + [ optionsLine optionChars optionStrings ] ++ + optionDescriptionLines description + +argOptionLines :: String -> [Char] -> [String] -> OptionArg -> [String] +argOptionLines description optionChars optionStrings arg = + [ optionsLine optionChars optionStrings + , optionArgLine arg + ] ++ + optionDescriptionLines description + +optionLinesIfPresent :: [Char] -> [String] -> [String] +optionLinesIfPresent optionChars optionStrings = + if null optionChars && null optionStrings then [] + else [ optionsLine optionChars optionStrings, ".br" ] + +optionDescriptionLines :: String -> [String] +optionDescriptionLines description = + [ ".RS" + , description + , ".RE" + , "" + ] + +optionsLine :: [Char] -> [String] -> String +optionsLine optionChars optionStrings = + intercalate ", " (shortOptions optionChars ++ longOptions optionStrings) + +shortOptions :: [Char] -> [String] +shortOptions = map (\c -> "\\-" ++ [c]) + +longOptions :: [String] -> [String] +longOptions = map (\s -> "\\-\\-" ++ s) + +optionArgLine :: OptionArg -> String +optionArgLine (Required, placeHolder) = ".I " ++ placeHolder +optionArgLine (Optional, placeHolder) = ".RI [ " ++ placeHolder ++ " ]" + +fileLines :: FileInfo -> [String] +fileLines (FileInfo path description) = + [ path + , ".RS" + , description + , ".RE" + , "" + ] diff --git a/cabal/cabal-install/src/Distribution/Client/ManpageFlags.hs b/cabal/cabal-install/src/Distribution/Client/ManpageFlags.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/ManpageFlags.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +module Distribution.Client.ManpageFlags +( ManpageFlags (..) +, defaultManpageFlags +, manpageOptions, +) where + +import Distribution.Client.Compat.Prelude + +import Distribution.Simple.Command (OptionField (..), ShowOrParseArgs (..), option) +import Distribution.Simple.Setup (Flag (..), toFlag, trueArg, optionVerbosity) +import Distribution.Verbosity (normal) + +data ManpageFlags = ManpageFlags + { manpageVerbosity :: Flag Verbosity + , manpageRaw :: Flag Bool + } deriving (Eq, Show, Generic) + +instance Monoid ManpageFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup ManpageFlags where + (<>) = gmappend + +defaultManpageFlags :: ManpageFlags +defaultManpageFlags = ManpageFlags + { manpageVerbosity = toFlag normal + , manpageRaw = toFlag False + } + +manpageOptions :: ShowOrParseArgs -> [OptionField ManpageFlags] +manpageOptions _ = + [ optionVerbosity manpageVerbosity (\v flags -> flags { manpageVerbosity = v }) + , option "" ["raw"] + "Output raw troff content" + manpageRaw (\v flags -> flags { manpageRaw = v }) + trueArg + ] diff --git a/cabal/cabal-install/src/Distribution/Client/Nix.hs b/cabal/cabal-install/src/Distribution/Client/Nix.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Nix.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ViewPatterns #-} + +module Distribution.Client.Nix + ( findNixExpr + , inNixShell + , nixInstantiate + , nixShell + ) where + +import Distribution.Client.Compat.Prelude + +import Control.Exception (bracket) +import System.Directory + ( canonicalizePath, createDirectoryIfMissing, doesDirectoryExist + , doesFileExist, removeDirectoryRecursive, removeFile ) +import System.Environment (getArgs, getExecutablePath) +import System.FilePath + ( (), replaceExtension, takeDirectory, takeFileName ) +import System.IO (IOMode(..), hClose, openFile) +import System.IO.Error (isDoesNotExistError) +import System.Process (showCommandForUser) + +import Distribution.Compat.Environment + ( lookupEnv, setEnv, unsetEnv ) + +import Distribution.Simple.Program + ( Program(..), ProgramDb + , addKnownProgram, configureProgram, emptyProgramDb, getDbProgramOutput + , runDbProgram, simpleProgram ) +import Distribution.Simple.Setup (fromFlagOrDefault) +import Distribution.Simple.Utils (debug, existsAndIsMoreRecentThan) + +import Distribution.Client.Config (SavedConfig(..)) +import Distribution.Client.GlobalFlags (GlobalFlags(..)) + + +configureOneProgram :: Verbosity -> Program -> IO ProgramDb +configureOneProgram verb prog = + configureProgram verb prog (addKnownProgram prog emptyProgramDb) + + +touchFile :: FilePath -> IO () +touchFile path = do + catch (removeFile path) (\e -> when (isDoesNotExistError e) (return ())) + createDirectoryIfMissing True (takeDirectory path) + openFile path WriteMode >>= hClose + + +findNixExpr :: GlobalFlags -> SavedConfig -> IO (Maybe FilePath) +findNixExpr globalFlags config = do + -- criteria for deciding to run nix-shell + let nixEnabled = + fromFlagOrDefault False + (globalNix (savedGlobalFlags config) <> globalNix globalFlags) + + if nixEnabled + then do + let exprPaths = [ "shell.nix", "default.nix" ] + filterM doesFileExist exprPaths >>= \case + [] -> return Nothing + (path : _) -> return (Just path) + else return Nothing + + +-- set IN_NIX_SHELL so that builtins.getEnv in Nix works as in nix-shell +inFakeNixShell :: IO a -> IO a +inFakeNixShell f = + bracket (fakeEnv "IN_NIX_SHELL" "1") (resetEnv "IN_NIX_SHELL") (\_ -> f) + where + fakeEnv var new = do + old <- lookupEnv var + setEnv var new + return old + resetEnv var = maybe (unsetEnv var) (setEnv var) + + +nixInstantiate + :: Verbosity + -> FilePath + -> Bool + -> GlobalFlags + -> SavedConfig + -> IO () +nixInstantiate verb dist force' globalFlags config = + findNixExpr globalFlags config >>= \case + Nothing -> return () + Just shellNix -> do + alreadyInShell <- inNixShell + shellDrv <- drvPath dist shellNix + instantiated <- doesFileExist shellDrv + -- an extra timestamp file is necessary because the derivation lives in + -- the store so its mtime is always 1. + let timestamp = timestampPath dist shellNix + upToDate <- existsAndIsMoreRecentThan timestamp shellNix + + let ready = alreadyInShell || (instantiated && upToDate && not force') + unless ready $ do + + let prog = simpleProgram "nix-instantiate" + progdb <- configureOneProgram verb prog + + removeGCRoots verb dist + touchFile timestamp + + _ <- inFakeNixShell + (getDbProgramOutput verb prog progdb + [ "--add-root", shellDrv, "--indirect", shellNix ]) + return () + + +nixShell + :: Verbosity + -> FilePath + -> GlobalFlags + -> SavedConfig + -> IO () + -- ^ The action to perform inside a nix-shell. This is also the action + -- that will be performed immediately if Nix is disabled. + -> IO () +nixShell verb dist globalFlags config go = do + + alreadyInShell <- inNixShell + + if alreadyInShell + then go + else do + findNixExpr globalFlags config >>= \case + Nothing -> go + Just shellNix -> do + + let prog = simpleProgram "nix-shell" + progdb <- configureOneProgram verb prog + + cabal <- getExecutablePath + + -- alreadyInShell == True in child process + setEnv "CABAL_IN_NIX_SHELL" "1" + + -- Run cabal with the same arguments inside nix-shell. + -- When the child process reaches the top of nixShell, it will + -- detect that it is running inside the shell and fall back + -- automatically. + shellDrv <- drvPath dist shellNix + args <- getArgs + runDbProgram verb prog progdb + [ "--add-root", gcrootPath dist "result", "--indirect", shellDrv + , "--run", showCommandForUser cabal args + ] + + +drvPath :: FilePath -> FilePath -> IO FilePath +drvPath dist path = do + -- We do not actually care about canonicity, but makeAbsolute is only + -- available in newer versions of directory. + -- We expect the path to be a symlink if it exists, so we do not canonicalize + -- the entire path because that would dereference the symlink. + distNix <- canonicalizePath (dist "nix") + -- Nix garbage collector roots must be absolute paths + return (distNix replaceExtension (takeFileName path) "drv") + + +timestampPath :: FilePath -> FilePath -> FilePath +timestampPath dist path = + dist "nix" replaceExtension (takeFileName path) "drv.timestamp" + + +gcrootPath :: FilePath -> FilePath +gcrootPath dist = dist "nix" "gcroots" + + +inNixShell :: IO Bool +inNixShell = isJust <$> lookupEnv "CABAL_IN_NIX_SHELL" + + +removeGCRoots :: Verbosity -> FilePath -> IO () +removeGCRoots verb dist = do + let tgt = gcrootPath dist + exists <- doesDirectoryExist tgt + when exists $ do + debug verb ("removing Nix gcroots from " ++ tgt) + removeDirectoryRecursive tgt diff --git a/cabal/cabal-install/src/Distribution/Client/NixStyleOptions.hs b/cabal/cabal-install/src/Distribution/Client/NixStyleOptions.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/NixStyleOptions.hs @@ -0,0 +1,85 @@ +-- | Command line options for nix-style / v2 commands. +-- +-- The commands take a lot of the same options, which affect how install plan +-- is constructed. +module Distribution.Client.NixStyleOptions ( + NixStyleFlags (..), + nixStyleOptions, + defaultNixStyleFlags, +) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Simple.Command (OptionField (..), ShowOrParseArgs) +import Distribution.Simple.Setup (BenchmarkFlags, HaddockFlags, TestFlags) +import Distribution.Solver.Types.ConstraintSource (ConstraintSource (..)) + +import Distribution.Client.ProjectFlags + (ProjectFlags (..), defaultProjectFlags, projectFlagsOptions) +import Distribution.Client.Setup + (ConfigExFlags, ConfigFlags (..), InstallFlags (..), benchmarkOptions, configureExOptions, + configureOptions, haddockOptions, installOptions, liftOptions, testOptions) + +data NixStyleFlags a = NixStyleFlags + { configFlags :: ConfigFlags + , configExFlags :: ConfigExFlags + , installFlags :: InstallFlags + , haddockFlags :: HaddockFlags + , testFlags :: TestFlags + , benchmarkFlags :: BenchmarkFlags + , projectFlags :: ProjectFlags + , extraFlags :: a + } + +nixStyleOptions + :: (ShowOrParseArgs -> [OptionField a]) + -> ShowOrParseArgs -> [OptionField (NixStyleFlags a)] +nixStyleOptions commandOptions showOrParseArgs = + liftOptions configFlags set1 + -- Note: [Hidden Flags] + -- hide "constraint", "dependency", and + -- "exact-configuration" from the configure options. + (filter ((`notElem` ["constraint", "dependency" + , "exact-configuration"]) + . optionName) $ configureOptions showOrParseArgs) + ++ liftOptions configExFlags set2 (configureExOptions showOrParseArgs + ConstraintSourceCommandlineFlag) + ++ liftOptions installFlags set3 + -- hide "target-package-db" and "symlink-bindir" flags from the + -- install options. + -- "symlink-bindir" is obsoleted by "installdir" in ClientInstallFlags + (filter ((`notElem` ["target-package-db", "symlink-bindir"]) + . optionName) $ + installOptions showOrParseArgs) + ++ liftOptions haddockFlags set4 + -- hide "verbose" and "builddir" flags from the + -- haddock options. + (filter ((`notElem` ["v", "verbose", "builddir"]) + . optionName) $ + haddockOptions showOrParseArgs) + ++ liftOptions testFlags set5 (testOptions showOrParseArgs) + ++ liftOptions benchmarkFlags set6 (benchmarkOptions showOrParseArgs) + ++ liftOptions projectFlags set7 (projectFlagsOptions showOrParseArgs) + ++ liftOptions extraFlags set8 (commandOptions showOrParseArgs) + where + set1 x flags = flags { configFlags = x } + set2 x flags = flags { configExFlags = x } + set3 x flags = flags { installFlags = x } + set4 x flags = flags { haddockFlags = x } + set5 x flags = flags { testFlags = x } + set6 x flags = flags { benchmarkFlags = x } + set7 x flags = flags { projectFlags = x } + set8 x flags = flags { extraFlags = x } + +defaultNixStyleFlags :: a -> NixStyleFlags a +defaultNixStyleFlags x = NixStyleFlags + { configFlags = mempty + , configExFlags = mempty + , installFlags = mempty + , haddockFlags = mempty + , testFlags = mempty + , benchmarkFlags = mempty + , projectFlags = defaultProjectFlags + , extraFlags = x + } diff --git a/cabal/cabal-install/src/Distribution/Client/PackageHash.hs b/cabal/cabal-install/src/Distribution/Client/PackageHash.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/PackageHash.hs @@ -0,0 +1,319 @@ +{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} +{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} + +-- | Functions to calculate nix-style hashes for package ids. +-- +-- The basic idea is simple, hash the combination of: +-- +-- * the package tarball +-- * the ids of all the direct dependencies +-- * other local configuration (flags, profiling, etc) +-- +module Distribution.Client.PackageHash ( + -- * Calculating package hashes + PackageHashInputs(..), + PackageHashConfigInputs(..), + PackageSourceHash, + hashedInstalledPackageId, + hashPackageHashInputs, + renderPackageHashInputs, + -- ** Platform-specific variations + hashedInstalledPackageIdLong, + hashedInstalledPackageIdShort, + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Distribution.Package + ( PackageId, PackageIdentifier(..), mkComponentId + , PkgconfigName ) +import Distribution.System + ( Platform, OS(Windows, OSX), buildOS ) +import Distribution.Types.Flag + ( FlagAssignment, showFlagAssignment ) +import Distribution.Simple.Compiler + ( CompilerId, OptimisationLevel(..), DebugInfoLevel(..) + , ProfDetailLevel(..), PackageDB, showProfDetailLevel ) +import Distribution.Simple.InstallDirs + ( PathTemplate, fromPathTemplate ) +import Distribution.Types.PkgconfigVersion (PkgconfigVersion) +import Distribution.Client.HashValue +import Distribution.Client.Types + ( InstalledPackageId ) +import qualified Distribution.Solver.Types.ComponentDeps as CD + +import qualified Data.ByteString.Lazy.Char8 as LBS +import qualified Data.Map as Map +import qualified Data.Set as Set + +------------------------------- +-- Calculating package hashes +-- + +-- | Calculate a 'InstalledPackageId' for a package using our nix-style +-- inputs hashing method. +-- +-- Note that due to path length limitations on Windows, this function uses +-- a different method on Windows that produces shorted package ids. +-- See 'hashedInstalledPackageIdLong' vs 'hashedInstalledPackageIdShort'. +-- +hashedInstalledPackageId :: PackageHashInputs -> InstalledPackageId +hashedInstalledPackageId + | buildOS == Windows = hashedInstalledPackageIdShort + | buildOS == OSX = hashedInstalledPackageIdVeryShort + | otherwise = hashedInstalledPackageIdLong + +-- | Calculate a 'InstalledPackageId' for a package using our nix-style +-- inputs hashing method. +-- +-- This produces large ids with big hashes. It is only suitable for systems +-- without significant path length limitations (ie not Windows). +-- +hashedInstalledPackageIdLong :: PackageHashInputs -> InstalledPackageId +hashedInstalledPackageIdLong + pkghashinputs@PackageHashInputs{pkgHashPkgId,pkgHashComponent} + = mkComponentId $ + prettyShow pkgHashPkgId -- to be a bit user friendly + ++ maybe "" displayComponent pkgHashComponent + ++ "-" + ++ showHashValue (hashPackageHashInputs pkghashinputs) + where + displayComponent :: CD.Component -> String + displayComponent CD.ComponentLib = "" + displayComponent (CD.ComponentSubLib s) = "-l-" ++ prettyShow s + displayComponent (CD.ComponentFLib s) = "-f-" ++ prettyShow s + displayComponent (CD.ComponentExe s) = "-e-" ++ prettyShow s + displayComponent (CD.ComponentTest s) = "-t-" ++ prettyShow s + displayComponent (CD.ComponentBench s) = "-b-" ++ prettyShow s + displayComponent CD.ComponentSetup = "-setup" + +-- | On Windows we have serious problems with path lengths. Windows imposes a +-- maximum path length of 260 chars, and even if we can use the windows long +-- path APIs ourselves, we cannot guarantee that ghc, gcc, ld, ar, etc etc all +-- do so too. +-- +-- So our only choice is to limit the lengths of the paths, and the only real +-- way to do that is to limit the size of the 'InstalledPackageId's that we +-- generate. We do this by truncating the package names and versions and also +-- by truncating the hash sizes. +-- +-- Truncating the package names and versions is technically ok because they are +-- just included for human convenience, the full source package id is included +-- in the hash. +-- +-- Truncating the hash size is disappointing but also technically ok. We +-- rely on the hash primarily for collision avoidance not for any security +-- properties (at least for now). +-- +hashedInstalledPackageIdShort :: PackageHashInputs -> InstalledPackageId +hashedInstalledPackageIdShort pkghashinputs@PackageHashInputs{pkgHashPkgId} = + mkComponentId $ + intercalate "-" + -- max length now 64 + [ truncateStr 14 (prettyShow name) + , truncateStr 8 (prettyShow version) + , showHashValue (truncateHash 20 (hashPackageHashInputs pkghashinputs)) + ] + where + PackageIdentifier name version = pkgHashPkgId + + -- Truncate a string, with a visual indication that it is truncated. + truncateStr n s | length s <= n = s + | otherwise = take (n-1) s ++ "_" + +-- | On macOS we shorten the name very aggressively. The mach-o linker on +-- macOS has a limited load command size, to which the name of the library +-- as well as its relative path (\@rpath) entry count. To circumvent this, +-- on macOS the libraries are not stored as +-- @store//libHS.dylib@ +-- where libraryname contains the libraries name, version and abi hash, but in +-- @store/lib/libHS.dylib@ +-- where the very short library name drops all vowels from the package name, +-- and truncates the hash to 4 bytes. +-- +-- We therefore we only need one \@rpath entry to @store/lib@ instead of one +-- \@rpath entry for each library. And the reduced library name saves some +-- additional space. +-- +-- This however has two major drawbacks: +-- 1) Packages can collide more easily due to the shortened hash. +-- 2) The libraries are *not* prefix relocatable anymore as they all end up +-- in the same @store/lib@ folder. +-- +-- The ultimate solution would have to include generating proxy dynamic +-- libraries on macOS, such that the proxy libraries and the linked libraries +-- stay under the load command limit, and the recursive linker is still able +-- to link all of them. +hashedInstalledPackageIdVeryShort :: PackageHashInputs -> InstalledPackageId +hashedInstalledPackageIdVeryShort pkghashinputs@PackageHashInputs{pkgHashPkgId} = + mkComponentId $ + intercalate "-" + [ filter (not . flip elem "aeiou") (prettyShow name) + , prettyShow version + , showHashValue (truncateHash 4 (hashPackageHashInputs pkghashinputs)) + ] + where + PackageIdentifier name version = pkgHashPkgId + +-- | All the information that contributes to a package's hash, and thus its +-- 'InstalledPackageId'. +-- +data PackageHashInputs = PackageHashInputs { + pkgHashPkgId :: PackageId, + pkgHashComponent :: Maybe CD.Component, + pkgHashSourceHash :: PackageSourceHash, + pkgHashPkgConfigDeps :: Set (PkgconfigName, Maybe PkgconfigVersion), + pkgHashDirectDeps :: Set InstalledPackageId, + pkgHashOtherConfig :: PackageHashConfigInputs + } + +type PackageSourceHash = HashValue + +-- | Those parts of the package configuration that contribute to the +-- package hash. +-- +data PackageHashConfigInputs = PackageHashConfigInputs { + pkgHashCompilerId :: CompilerId, + pkgHashPlatform :: Platform, + pkgHashFlagAssignment :: FlagAssignment, -- complete not partial + pkgHashConfigureScriptArgs :: [String], -- just ./configure for build-type Configure + pkgHashVanillaLib :: Bool, + pkgHashSharedLib :: Bool, + pkgHashDynExe :: Bool, + pkgHashFullyStaticExe :: Bool, + pkgHashGHCiLib :: Bool, + pkgHashProfLib :: Bool, + pkgHashProfExe :: Bool, + pkgHashProfLibDetail :: ProfDetailLevel, + pkgHashProfExeDetail :: ProfDetailLevel, + pkgHashCoverage :: Bool, + pkgHashOptimization :: OptimisationLevel, + pkgHashSplitObjs :: Bool, + pkgHashSplitSections :: Bool, + pkgHashStripLibs :: Bool, + pkgHashStripExes :: Bool, + pkgHashDebugInfo :: DebugInfoLevel, + pkgHashProgramArgs :: Map String [String], + pkgHashExtraLibDirs :: [FilePath], + pkgHashExtraFrameworkDirs :: [FilePath], + pkgHashExtraIncludeDirs :: [FilePath], + pkgHashProgPrefix :: Maybe PathTemplate, + pkgHashProgSuffix :: Maybe PathTemplate, + pkgHashPackageDbs :: [Maybe PackageDB], + + -- Haddock options + pkgHashDocumentation :: Bool, + pkgHashHaddockHoogle :: Bool, + pkgHashHaddockHtml :: Bool, + pkgHashHaddockHtmlLocation :: Maybe String, + pkgHashHaddockForeignLibs :: Bool, + pkgHashHaddockExecutables :: Bool, + pkgHashHaddockTestSuites :: Bool, + pkgHashHaddockBenchmarks :: Bool, + pkgHashHaddockInternal :: Bool, + pkgHashHaddockCss :: Maybe FilePath, + pkgHashHaddockLinkedSource :: Bool, + pkgHashHaddockQuickJump :: Bool, + pkgHashHaddockContents :: Maybe PathTemplate + +-- TODO: [required eventually] pkgHashToolsVersions ? +-- TODO: [required eventually] pkgHashToolsExtraOptions ? + } + deriving Show + + +-- | Calculate the overall hash to be used for an 'InstalledPackageId'. +-- +hashPackageHashInputs :: PackageHashInputs -> HashValue +hashPackageHashInputs = hashValue . renderPackageHashInputs + +-- | Render a textual representation of the 'PackageHashInputs'. +-- +-- The 'hashValue' of this text is the overall package hash. +-- +renderPackageHashInputs :: PackageHashInputs -> LBS.ByteString +renderPackageHashInputs PackageHashInputs{ + pkgHashPkgId, + pkgHashComponent, + pkgHashSourceHash, + pkgHashDirectDeps, + pkgHashPkgConfigDeps, + pkgHashOtherConfig = + PackageHashConfigInputs{..} + } = + -- The purpose of this somewhat laboured rendering (e.g. why not just + -- use show?) is so that existing package hashes do not change + -- unnecessarily when new configuration inputs are added into the hash. + + -- In particular, the assumption is that when a new configuration input + -- is included into the hash, that existing packages will typically get + -- the default value for that feature. So if we avoid adding entries with + -- the default value then most of the time adding new features will not + -- change the hashes of existing packages and so fewer packages will need + -- to be rebuilt. + + --TODO: [nice to have] ultimately we probably want to put this config info + -- into the ghc-pkg db. At that point this should probably be changed to + -- use the config file infrastructure so it can be read back in again. + LBS.pack $ unlines $ catMaybes $ + [ entry "pkgid" prettyShow pkgHashPkgId + , mentry "component" show pkgHashComponent + , entry "src" showHashValue pkgHashSourceHash + , entry "pkg-config-deps" + (intercalate ", " . map (\(pn, mb_v) -> prettyShow pn ++ + case mb_v of + Nothing -> "" + Just v -> " " ++ prettyShow v) + . Set.toList) pkgHashPkgConfigDeps + , entry "deps" (intercalate ", " . map prettyShow + . Set.toList) pkgHashDirectDeps + -- and then all the config + , entry "compilerid" prettyShow pkgHashCompilerId + , entry "platform" prettyShow pkgHashPlatform + , opt "flags" mempty showFlagAssignment pkgHashFlagAssignment + , opt "configure-script" [] unwords pkgHashConfigureScriptArgs + , opt "vanilla-lib" True prettyShow pkgHashVanillaLib + , opt "shared-lib" False prettyShow pkgHashSharedLib + , opt "dynamic-exe" False prettyShow pkgHashDynExe + , opt "fully-static-exe" False prettyShow pkgHashFullyStaticExe + , opt "ghci-lib" False prettyShow pkgHashGHCiLib + , opt "prof-lib" False prettyShow pkgHashProfLib + , opt "prof-exe" False prettyShow pkgHashProfExe + , opt "prof-lib-detail" ProfDetailDefault showProfDetailLevel pkgHashProfLibDetail + , opt "prof-exe-detail" ProfDetailDefault showProfDetailLevel pkgHashProfExeDetail + , opt "hpc" False prettyShow pkgHashCoverage + , opt "optimisation" NormalOptimisation (show . fromEnum) pkgHashOptimization + , opt "split-objs" False prettyShow pkgHashSplitObjs + , opt "split-sections" False prettyShow pkgHashSplitSections + , opt "stripped-lib" False prettyShow pkgHashStripLibs + , opt "stripped-exe" True prettyShow pkgHashStripExes + , opt "debug-info" NormalDebugInfo (show . fromEnum) pkgHashDebugInfo + , opt "extra-lib-dirs" [] unwords pkgHashExtraLibDirs + , opt "extra-framework-dirs" [] unwords pkgHashExtraFrameworkDirs + , opt "extra-include-dirs" [] unwords pkgHashExtraIncludeDirs + , opt "prog-prefix" Nothing (maybe "" fromPathTemplate) pkgHashProgPrefix + , opt "prog-suffix" Nothing (maybe "" fromPathTemplate) pkgHashProgSuffix + , opt "package-dbs" [] (unwords . map show) pkgHashPackageDbs + + , opt "documentation" False prettyShow pkgHashDocumentation + , opt "haddock-hoogle" False prettyShow pkgHashHaddockHoogle + , opt "haddock-html" False prettyShow pkgHashHaddockHtml + , opt "haddock-html-location" Nothing (fromMaybe "") pkgHashHaddockHtmlLocation + , opt "haddock-foreign-libraries" False prettyShow pkgHashHaddockForeignLibs + , opt "haddock-executables" False prettyShow pkgHashHaddockExecutables + , opt "haddock-tests" False prettyShow pkgHashHaddockTestSuites + , opt "haddock-benchmarks" False prettyShow pkgHashHaddockBenchmarks + , opt "haddock-internal" False prettyShow pkgHashHaddockInternal + , opt "haddock-css" Nothing (fromMaybe "") pkgHashHaddockCss + , opt "haddock-hyperlink-source" False prettyShow pkgHashHaddockLinkedSource + , opt "haddock-quickjump" False prettyShow pkgHashHaddockQuickJump + , opt "haddock-contents-location" Nothing (maybe "" fromPathTemplate) pkgHashHaddockContents + + ] ++ Map.foldrWithKey (\prog args acc -> opt (prog ++ "-options") [] unwords args : acc) [] pkgHashProgramArgs + where + entry key format value = Just (key ++ ": " ++ format value) + mentry key format value = fmap (\v -> key ++ ": " ++ format v) value + opt key def format value + | value == def = Nothing + | otherwise = entry key format value diff --git a/cabal/cabal-install/src/Distribution/Client/ParseUtils.hs b/cabal/cabal-install/src/Distribution/Client/ParseUtils.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/ParseUtils.hs @@ -0,0 +1,371 @@ +{-# LANGUAGE ExistentialQuantification, NamedFieldPuns, RankNTypes #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.ParseUtils +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Parsing utilities. +----------------------------------------------------------------------------- + +module Distribution.Client.ParseUtils ( + + -- * Fields and field utilities + FieldDescr(..), + liftField, + liftFields, + filterFields, + mapFieldNames, + commandOptionToField, + commandOptionsToFields, + + -- * Sections and utilities + SectionDescr(..), + liftSection, + + -- * FieldGrammar sections + FGSectionDescr(..), + + -- * Parsing and printing flat config + parseFields, + ppFields, + ppSection, + + -- * Parsing and printing config with sections and subsections + parseFieldsAndSections, + ppFieldsAndSections, + + -- ** Top level of config files + parseConfig, + showConfig, + ) + where + +import Distribution.Client.Compat.Prelude hiding (empty, get) +import Prelude () + +import Distribution.Deprecated.ParseUtils + ( FieldDescr(..), ParseResult(..), warning, LineNo, lineNo + , Field(..), liftField, readFields ) +import Distribution.Deprecated.ViewAsFieldDescr + ( viewAsFieldDescr ) + +import Distribution.Simple.Command + ( OptionField ) + +import Text.PrettyPrint ( ($+$) ) +import qualified Data.ByteString as BS +import qualified Data.Map as Map +import qualified Text.PrettyPrint as Disp + ( (<>), Doc, text, colon, vcat, empty, isEmpty, nest ) + +-- For new parser stuff +import Distribution.CabalSpecVersion (cabalSpecLatest) +import Distribution.FieldGrammar (partitionFields, parseFieldGrammar) +import Distribution.Fields.ParseResult (runParseResult) +import Distribution.Parsec.Error (showPError) +import Distribution.Parsec.Position (Position (..)) +import Distribution.Parsec.Warning (showPWarning) +import Distribution.Simple.Utils (fromUTF8BS, toUTF8BS) +import qualified Distribution.Fields as F +import qualified Distribution.FieldGrammar as FG + + +------------------------- +-- FieldDescr utilities +-- + +liftFields :: (b -> a) + -> (a -> b -> b) + -> [FieldDescr a] + -> [FieldDescr b] +liftFields get set = map (liftField get set) + + +-- | Given a collection of field descriptions, keep only a given list of them, +-- identified by name. +-- +filterFields :: [String] -> [FieldDescr a] -> [FieldDescr a] +filterFields includeFields = filter ((`elem` includeFields) . fieldName) + +-- | Apply a name mangling function to the field names of all the field +-- descriptions. The typical use case is to apply some prefix. +-- +mapFieldNames :: (String -> String) -> [FieldDescr a] -> [FieldDescr a] +mapFieldNames mangleName = + map (\descr -> descr { fieldName = mangleName (fieldName descr) }) + + +-- | Reuse a command line 'OptionField' as a config file 'FieldDescr'. +-- +commandOptionToField :: OptionField a -> FieldDescr a +commandOptionToField = viewAsFieldDescr + +-- | Reuse a bunch of command line 'OptionField's as config file 'FieldDescr's. +-- +commandOptionsToFields :: [OptionField a] -> [FieldDescr a] +commandOptionsToFields = map viewAsFieldDescr + + +------------------------------------------ +-- SectionDescr definition and utilities +-- + +-- | The description of a section in a config file. It can contain both +-- fields and optionally further subsections. See also 'FieldDescr'. +-- +data SectionDescr a = forall b. SectionDescr { + sectionName :: String, + sectionFields :: [FieldDescr b], + sectionSubsections :: [SectionDescr b], + sectionGet :: a -> [(String, b)], + sectionSet :: LineNo -> String -> b -> a -> ParseResult a, + sectionEmpty :: b + } + +-- | 'FieldGrammar' section description +data FGSectionDescr g a = forall s. FGSectionDescr + { fgSectionName :: String + , fgSectionGrammar :: g s s + -- todo: add subsections? + , fgSectionGet :: a -> [(String, s)] + , fgSectionSet :: LineNo -> String -> s -> a -> ParseResult a + } + +-- | To help construction of config file descriptions in a modular way it is +-- useful to define fields and sections on local types and then hoist them +-- into the parent types when combining them in bigger descriptions. +-- +-- This is essentially a lens operation for 'SectionDescr' to help embedding +-- one inside another. +-- +liftSection :: (b -> a) + -> (a -> b -> b) + -> SectionDescr a + -> SectionDescr b +liftSection get' set' (SectionDescr name fields sections get set empty) = + let sectionGet' = get . get' + sectionSet' lineno param x y = do + x' <- set lineno param x (get' y) + return (set' x' y) + in SectionDescr name fields sections sectionGet' sectionSet' empty + + +------------------------------------- +-- Parsing and printing flat config +-- + +-- | Parse a bunch of semi-parsed 'Field's according to a set of field +-- descriptions. It accumulates the result on top of a given initial value. +-- +-- This only covers the case of flat configuration without subsections. See +-- also 'parseFieldsAndSections'. +-- +parseFields :: [FieldDescr a] -> a -> [Field] -> ParseResult a +parseFields fieldDescrs = + foldM setField + where + fieldMap = Map.fromList [ (fieldName f, f) | f <- fieldDescrs ] + + setField accum (F line name value) = + case Map.lookup name fieldMap of + Just (FieldDescr _ _ set) -> set line value accum + Nothing -> do + -- the 'world-file' field was removed in 3.8, however + -- it was automatically added to many config files + -- before that, so its warning is silently ignored + unless (name == "world-file") $ + warning $ "Unrecognized field " ++ name ++ " on line " ++ show line + return accum + + setField accum f = do + warning $ "Unrecognized stanza on line " ++ show (lineNo f) + return accum + +-- | This is a customised version of the functions from Distribution.Deprecated.ParseUtils +-- that also optionally print default values for empty fields as comments. +-- +ppFields :: [FieldDescr a] -> (Maybe a) -> a -> Disp.Doc +ppFields fields def cur = + Disp.vcat [ ppField name (fmap getter def) (getter cur) + | FieldDescr name getter _ <- fields] + +ppField :: String -> (Maybe Disp.Doc) -> Disp.Doc -> Disp.Doc +ppField name mdef cur + | Disp.isEmpty cur = maybe Disp.empty + (\def -> Disp.text "--" <+> Disp.text name + Disp.<> Disp.colon <+> def) mdef + | otherwise = Disp.text name Disp.<> Disp.colon <+> cur + +-- | Pretty print a section. +-- +-- Since 'ppFields' does not cover subsections you can use this to add them. +-- Or alternatively use a 'SectionDescr' and use 'ppFieldsAndSections'. +-- +ppSection :: String -> String -> [FieldDescr a] -> (Maybe a) -> a -> Disp.Doc +ppSection name arg fields def cur + | Disp.isEmpty fieldsDoc = Disp.empty + | otherwise = Disp.text name <+> argDoc + $+$ (Disp.nest 2 fieldsDoc) + where + fieldsDoc = ppFields fields def cur + argDoc | arg == "" = Disp.empty + | otherwise = Disp.text arg + + +----------------------------------------- +-- Parsing and printing non-flat config +-- + +-- | Much like 'parseFields' but it also allows subsections. The permitted +-- subsections are given by a list of 'SectionDescr's. +-- +parseFieldsAndSections + :: [FieldDescr a] -- ^ field + -> [SectionDescr a] -- ^ legacy sections + -> [FGSectionDescr FG.ParsecFieldGrammar a] -- ^ FieldGrammar sections + -> a + -> [Field] -> ParseResult a +parseFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs = + foldM setField + where + fieldMap = Map.fromList [ (fieldName f, f) | f <- fieldDescrs ] + sectionMap = Map.fromList [ (sectionName s, s) | s <- sectionDescrs ] + fgSectionMap = Map.fromList [ (fgSectionName s, s) | s <- fgSectionDescrs ] + + setField a (F line name value) = + case Map.lookup name fieldMap of + Just (FieldDescr _ _ set) -> set line value a + Nothing -> do + warning $ "Unrecognized field '" ++ name + ++ "' on line " ++ show line + return a + + setField a (Section line name param fields) = + case Left <$> Map.lookup name sectionMap <|> Right <$> Map.lookup name fgSectionMap of + Just (Left (SectionDescr _ fieldDescrs' sectionDescrs' _ set sectionEmpty)) -> do + b <- parseFieldsAndSections fieldDescrs' sectionDescrs' [] sectionEmpty fields + set line param b a + Just (Right (FGSectionDescr _ grammar _getter setter)) -> do + let fields1 = map convertField fields + (fields2, sections) = partitionFields fields1 + -- TODO: recurse into sections + for_ (concat sections) $ \(FG.MkSection (F.Name (Position line' _) name') _ _) -> + warning $ "Unrecognized section '" ++ fromUTF8BS name' + ++ "' on line " ++ show line' + case runParseResult $ parseFieldGrammar cabalSpecLatest fields2 grammar of + (warnings, Right b) -> do + for_ warnings $ \w -> warning $ showPWarning "???" w + setter line param b a + (warnings, Left (_, errs)) -> do + for_ warnings $ \w -> warning $ showPWarning "???" w + case errs of + err :| _errs -> fail $ showPError "???" err + Nothing -> do + warning $ "Unrecognized section '" ++ name + ++ "' on line " ++ show line + return a + +convertField :: Field -> F.Field Position +convertField (F line name str) = + F.Field (F.Name pos (toUTF8BS name)) [ F.FieldLine pos $ toUTF8BS str ] + where + pos = Position line 0 +-- arguments omitted +convertField (Section line name _arg fields) = + F.Section (F.Name pos (toUTF8BS name)) [] (map convertField fields) + where + pos = Position line 0 + +-- | Much like 'ppFields' but also pretty prints any subsections. Subsection +-- are only shown if they are non-empty. +-- +-- Note that unlike 'ppFields', at present it does not support printing +-- default values. If needed, adding such support would be quite reasonable. +-- +ppFieldsAndSections :: [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr FG.PrettyFieldGrammar a] -> a -> Disp.Doc +ppFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs val = + ppFields fieldDescrs Nothing val + $+$ + Disp.vcat ( + [ Disp.text "" $+$ sectionDoc + | SectionDescr { + sectionName, sectionGet, + sectionFields, sectionSubsections + } <- sectionDescrs + , (param, x) <- sectionGet val + , let sectionDoc = ppSectionAndSubsections + sectionName param + sectionFields sectionSubsections [] x + , not (Disp.isEmpty sectionDoc) + ] ++ + [ Disp.text "" $+$ sectionDoc + | FGSectionDescr { fgSectionName, fgSectionGrammar, fgSectionGet } <- fgSectionDescrs + , (param, x) <- fgSectionGet val + , let sectionDoc = ppFgSection fgSectionName param fgSectionGrammar x + , not (Disp.isEmpty sectionDoc) + ]) + +-- | Unlike 'ppSection' which has to be called directly, this gets used via +-- 'ppFieldsAndSections' and so does not need to be exported. +-- +ppSectionAndSubsections :: String -> String + -> [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr FG.PrettyFieldGrammar a] -> a -> Disp.Doc +ppSectionAndSubsections name arg fields sections fgSections cur + | Disp.isEmpty fieldsDoc = Disp.empty + | otherwise = Disp.text name <+> argDoc + $+$ (Disp.nest 2 fieldsDoc) + where + fieldsDoc = showConfig fields sections fgSections cur + argDoc | arg == "" = Disp.empty + | otherwise = Disp.text arg + +-- | +-- +-- TODO: subsections +-- TODO: this should simply build 'PrettyField' +ppFgSection + :: String -- ^ section name + -> String -- ^ parameter + -> FG.PrettyFieldGrammar a a + -> a + -> Disp.Doc +ppFgSection secName arg grammar x + | null prettyFields = Disp.empty + | otherwise = + Disp.text secName <+> argDoc + $+$ (Disp.nest 2 fieldsDoc) + where + prettyFields = FG.prettyFieldGrammar cabalSpecLatest grammar x + + argDoc | arg == "" = Disp.empty + | otherwise = Disp.text arg + + fieldsDoc = Disp.vcat + [ Disp.text fname' <<>> Disp.colon <<>> doc + | F.PrettyField _ fname doc <- prettyFields -- TODO: this skips sections + , let fname' = fromUTF8BS fname + ] + + +----------------------------------------------- +-- Top level config file parsing and printing +-- + +-- | Parse a string in the config file syntax into a value, based on a +-- description of the configuration file in terms of its fields and sections. +-- +-- It accumulates the result on top of a given initial (typically empty) value. +-- +parseConfig :: [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr FG.ParsecFieldGrammar a] -> a + -> BS.ByteString -> ParseResult a +parseConfig fieldDescrs sectionDescrs fgSectionDescrs empty str = + parseFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs empty + =<< readFields str + +-- | Render a value in the config file syntax, based on a description of the +-- configuration file in terms of its fields and sections. +-- +showConfig :: [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr FG.PrettyFieldGrammar a] -> a -> Disp.Doc +showConfig = ppFieldsAndSections diff --git a/cabal/cabal-install/src/Distribution/Client/ProjectBuilding.hs b/cabal/cabal-install/src/Distribution/Client/ProjectBuilding.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/ProjectBuilding.hs @@ -0,0 +1,1543 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NoMonoLocalBinds #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- +module Distribution.Client.ProjectBuilding ( + -- * Dry run phase + -- | What bits of the plan will we execute? The dry run does not change + -- anything but tells us what will need to be built. + rebuildTargetsDryRun, + improveInstallPlanWithUpToDatePackages, + + -- ** Build status + -- | This is the detailed status information we get from the dry run. + BuildStatusMap, + BuildStatus(..), + BuildStatusRebuild(..), + BuildReason(..), + MonitorChangedReason(..), + buildStatusToString, + + -- * Build phase + -- | Now we actually execute the plan. + rebuildTargets, + -- ** Build outcomes + -- | This is the outcome for each package of executing the plan. + -- For each package, did the build succeed or fail? + BuildOutcomes, + BuildOutcome, + BuildResult(..), + BuildFailure(..), + BuildFailureReason(..), + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Client.PackageHash (renderPackageHashInputs) +import Distribution.Client.RebuildMonad +import Distribution.Client.ProjectConfig +import Distribution.Client.ProjectPlanning +import Distribution.Client.ProjectPlanning.Types +import Distribution.Client.ProjectBuilding.Types +import Distribution.Client.Store + +import Distribution.Client.Types + hiding (BuildOutcomes, BuildOutcome, + BuildResult(..), BuildFailure(..)) +import Distribution.Client.InstallPlan + ( GenericInstallPlan, GenericPlanPackage, IsUnit ) +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.DistDirLayout +import Distribution.Client.FileMonitor +import Distribution.Client.SetupWrapper +import Distribution.Client.JobControl +import Distribution.Client.FetchUtils +import Distribution.Client.GlobalFlags (RepoContext) +import qualified Distribution.Client.Tar as Tar +import Distribution.Client.Setup + ( filterConfigureFlags, filterHaddockArgs + , filterHaddockFlags, filterTestFlags ) +import Distribution.Client.SourceFiles +import Distribution.Client.SrcDist (allPackageSourceFiles) +import Distribution.Client.Utils + ( ProgressPhase(..), findOpenProgramLocation, progressMessage, removeExistingFile ) + +import Distribution.Compat.Lens +import Distribution.Package +import qualified Distribution.PackageDescription as PD +import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import qualified Distribution.InstalledPackageInfo as Installed +import Distribution.Simple.BuildPaths (haddockDirName) +import qualified Distribution.Simple.InstallDirs as InstallDirs +import Distribution.Types.BuildType +import Distribution.Types.PackageDescription.Lens (componentModules) +import Distribution.Simple.Program +import qualified Distribution.Simple.Setup as Cabal +import Distribution.Simple.Command (CommandUI) +import qualified Distribution.Simple.Register as Cabal +import Distribution.Simple.LocalBuildInfo + ( ComponentName(..), LibraryName(..) ) +import Distribution.Simple.Compiler + ( Compiler, compilerId, PackageDB(..) ) + +import Distribution.Simple.Utils +import Distribution.Version +import Distribution.Compat.Graph (IsNode(..)) + +import qualified Data.List.NonEmpty as NE +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Lazy.Char8 as LBS.Char8 + +import Control.Exception (Handler (..), SomeAsyncException, assert, catches, handle) +import System.Directory (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, removeFile, renameDirectory) +import System.FilePath (dropDrive, makeRelative, normalise, takeDirectory, (<.>), ()) +import System.IO (IOMode (AppendMode), Handle, withFile) + +import Distribution.Compat.Directory (listDirectory) + + +------------------------------------------------------------------------------ +-- * Overall building strategy. +------------------------------------------------------------------------------ +-- +-- We start with an 'ElaboratedInstallPlan' that has already been improved by +-- reusing packages from the store, and pruned to include only the targets of +-- interest and their dependencies. So the remaining packages in the +-- 'InstallPlan.Configured' state are ones we either need to build or rebuild. +-- +-- First, we do a preliminary dry run phase where we work out which packages +-- we really need to (re)build, and for the ones we do need to build which +-- build phase to start at. +-- +-- We use this to improve the 'ElaboratedInstallPlan' again by changing +-- up-to-date 'InstallPlan.Configured' packages to 'InstallPlan.Installed' +-- so that the build phase will skip them. +-- +-- Then we execute the plan, that is actually build packages. The outcomes of +-- trying to build all the packages are collected and returned. +-- +-- We split things like this (dry run and execute) for a couple reasons. +-- Firstly we need to be able to do dry runs anyway, and these need to be +-- reasonably accurate in terms of letting users know what (and why) things +-- are going to be (re)built. +-- +-- Given that we need to be able to do dry runs, it would not be great if +-- we had to repeat all the same work when we do it for real. Not only is +-- it duplicate work, but it's duplicate code which is likely to get out of +-- sync. So we do things only once. We preserve info we discover in the dry +-- run phase and rely on it later when we build things for real. This also +-- somewhat simplifies the build phase. So this way the dry run can't so +-- easily drift out of sync with the real thing since we're relying on the +-- info it produces. +-- +-- An additional advantage is that it makes it easier to debug rebuild +-- errors (ie rebuilding too much or too little), since all the rebuild +-- decisions are made without making any state changes at the same time +-- (that would make it harder to reproduce the problem situation). +-- +-- Finally, we can use the dry run build status and the build outcomes to +-- give us some information on the overall status of packages in the project. +-- This includes limited information about the status of things that were +-- not actually in the subset of the plan that was used for the dry run or +-- execution phases. In particular we may know that some packages are now +-- definitely out of date. See "Distribution.Client.ProjectPlanOutput" for +-- details. + + +------------------------------------------------------------------------------ +-- * Dry run: what bits of the 'ElaboratedInstallPlan' will we execute? +------------------------------------------------------------------------------ + +-- Refer to ProjectBuilding.Types for details of these important types: + +-- type BuildStatusMap = ... +-- data BuildStatus = ... +-- data BuildStatusRebuild = ... +-- data BuildReason = ... + +-- | Do the dry run pass. This is a prerequisite of 'rebuildTargets'. +-- +-- It gives us the 'BuildStatusMap'. This should be used with +-- 'improveInstallPlanWithUpToDatePackages' to give an improved version of +-- the 'ElaboratedInstallPlan' with packages switched to the +-- 'InstallPlan.Installed' state when we find that they're already up to date. +-- +rebuildTargetsDryRun :: DistDirLayout + -> ElaboratedSharedConfig + -> ElaboratedInstallPlan + -> IO BuildStatusMap +rebuildTargetsDryRun distDirLayout@DistDirLayout{..} shared = + -- Do the various checks to work out the 'BuildStatus' of each package + foldMInstallPlanDepOrder dryRunPkg + where + dryRunPkg :: ElaboratedPlanPackage + -> [BuildStatus] + -> IO BuildStatus + dryRunPkg (InstallPlan.PreExisting _pkg) _depsBuildStatus = + return BuildStatusPreExisting + + dryRunPkg (InstallPlan.Installed _pkg) _depsBuildStatus = + return BuildStatusInstalled + + dryRunPkg (InstallPlan.Configured pkg) depsBuildStatus = do + mloc <- checkFetched (elabPkgSourceLocation pkg) + case mloc of + Nothing -> return BuildStatusDownload + + Just (LocalUnpackedPackage srcdir) -> + -- For the case of a user-managed local dir, irrespective of the + -- build style, we build from that directory and put build + -- artifacts under the shared dist directory. + dryRunLocalPkg pkg depsBuildStatus srcdir + + -- The rest cases are all tarball cases are, + -- and handled the same as each other though depending on the build style. + Just (LocalTarballPackage tarball) -> + dryRunTarballPkg pkg depsBuildStatus tarball + + Just (RemoteTarballPackage _ tarball) -> + dryRunTarballPkg pkg depsBuildStatus tarball + + Just (RepoTarballPackage _ _ tarball) -> + dryRunTarballPkg pkg depsBuildStatus tarball + + Just (RemoteSourceRepoPackage _repo tarball) -> + dryRunTarballPkg pkg depsBuildStatus tarball + + + dryRunTarballPkg :: ElaboratedConfiguredPackage + -> [BuildStatus] + -> FilePath + -> IO BuildStatus + dryRunTarballPkg pkg depsBuildStatus tarball = + case elabBuildStyle pkg of + BuildAndInstall -> return (BuildStatusUnpack tarball) + BuildInplaceOnly -> do + -- TODO: [nice to have] use a proper file monitor rather + -- than this dir exists test + exists <- doesDirectoryExist srcdir + if exists + then dryRunLocalPkg pkg depsBuildStatus srcdir + else return (BuildStatusUnpack tarball) + where + srcdir :: FilePath + srcdir = distUnpackedSrcDirectory (packageId pkg) + + dryRunLocalPkg :: ElaboratedConfiguredPackage + -> [BuildStatus] + -> FilePath + -> IO BuildStatus + dryRunLocalPkg pkg depsBuildStatus srcdir = do + -- Go and do lots of I/O, reading caches and probing files to work out + -- if anything has changed + change <- checkPackageFileMonitorChanged + packageFileMonitor pkg srcdir depsBuildStatus + case change of + -- It did change, giving us 'BuildStatusRebuild' info on why + Left rebuild -> + return (BuildStatusRebuild srcdir rebuild) + + -- No changes, the package is up to date. Use the saved build results. + Right buildResult -> + return (BuildStatusUpToDate buildResult) + where + packageFileMonitor :: PackageFileMonitor + packageFileMonitor = + newPackageFileMonitor shared distDirLayout + (elabDistDirParams shared pkg) + + +-- | A specialised traversal over the packages in an install plan. +-- +-- The packages are visited in dependency order, starting with packages with no +-- dependencies. The result for each package is accumulated into a 'Map' and +-- returned as the final result. In addition, when visiting a package, the +-- 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) + => (GenericPlanPackage ipkg srcpkg -> + [b] -> m b) + -> GenericInstallPlan ipkg srcpkg + -> m (Map UnitId b) +foldMInstallPlanDepOrder visit = + go Map.empty . InstallPlan.reverseTopologicalOrder + where + go :: Map UnitId b + -> [GenericPlanPackage ipkg srcpkg] + -> m (Map UnitId 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 + let depresults :: [b] + depresults = + map (\ipkgid -> let result = Map.findWithDefault (error "foldMInstallPlanDepOrder") ipkgid results + in result) + (InstallPlan.depends pkg) + result <- visit pkg depresults + let results' = Map.insert (nodeKey pkg) result results + go results' pkgs + +improveInstallPlanWithUpToDatePackages :: BuildStatusMap + -> ElaboratedInstallPlan + -> ElaboratedInstallPlan +improveInstallPlanWithUpToDatePackages pkgsBuildStatus = + InstallPlan.installed canPackageBeImproved + where + canPackageBeImproved :: ElaboratedConfiguredPackage -> Bool + canPackageBeImproved pkg = + case Map.lookup (installedUnitId pkg) pkgsBuildStatus of + Just BuildStatusUpToDate {} -> True + Just _ -> False + Nothing -> error $ "improveInstallPlanWithUpToDatePackages: " + ++ prettyShow (packageId pkg) ++ " not in status map" + + +----------------------------- +-- Package change detection +-- + +-- | As part of the dry run for local unpacked packages we have to check if the +-- package config or files have changed. That is the purpose of +-- 'PackageFileMonitor' and 'checkPackageFileMonitorChanged'. +-- +-- When a package is (re)built, the monitor must be updated to reflect the new +-- state of the package. Because we sometimes build without reconfiguring the +-- state updates are split into two, one for package config changes and one +-- for other changes. This is the purpose of 'updatePackageConfigFileMonitor' +-- and 'updatePackageBuildFileMonitor'. +-- +data PackageFileMonitor = PackageFileMonitor { + pkgFileMonitorConfig :: FileMonitor ElaboratedConfiguredPackage (), + pkgFileMonitorBuild :: FileMonitor (Set ComponentName) BuildResultMisc, + pkgFileMonitorReg :: FileMonitor () (Maybe InstalledPackageInfo) + } + +-- | This is all the components of the 'BuildResult' other than the +-- @['InstalledPackageInfo']@. +-- +-- We have to split up the 'BuildResult' components since they get produced +-- at different times (or rather, when different things change). +-- +type BuildResultMisc = (DocsResult, TestsResult) + +newPackageFileMonitor :: ElaboratedSharedConfig + -> DistDirLayout + -> DistDirParams + -> PackageFileMonitor +newPackageFileMonitor shared + DistDirLayout{distPackageCacheFile} + dparams = + PackageFileMonitor { + pkgFileMonitorConfig = + FileMonitor { + fileMonitorCacheFile = distPackageCacheFile dparams "config", + fileMonitorKeyValid = (==) `on` normaliseConfiguredPackage shared, + fileMonitorCheckIfOnlyValueChanged = False + }, + + pkgFileMonitorBuild = + FileMonitor { + fileMonitorCacheFile = distPackageCacheFile dparams "build", + fileMonitorKeyValid = \componentsToBuild componentsAlreadyBuilt -> + componentsToBuild `Set.isSubsetOf` componentsAlreadyBuilt, + fileMonitorCheckIfOnlyValueChanged = True + }, + + pkgFileMonitorReg = + newFileMonitor (distPackageCacheFile dparams "registration") + } + +-- | Helper function for 'checkPackageFileMonitorChanged', +-- 'updatePackageConfigFileMonitor' and 'updatePackageBuildFileMonitor'. +-- +-- It selects the info from a 'ElaboratedConfiguredPackage' that are used by +-- the 'FileMonitor's (in the 'PackageFileMonitor') to detect value changes. +-- +packageFileMonitorKeyValues :: ElaboratedConfiguredPackage + -> (ElaboratedConfiguredPackage, Set ComponentName) +packageFileMonitorKeyValues elab = + (elab_config, buildComponents) + where + -- The first part is the value used to guard (re)configuring the package. + -- That is, if this value changes then we will reconfigure. + -- The ElaboratedConfiguredPackage consists mostly (but not entirely) of + -- information that affects the (re)configure step. But those parts that + -- do not affect the configure step need to be nulled out. Those parts are + -- the specific targets that we're going to build. + -- + + -- Additionally we null out the parts that don't affect the configure step because they're simply + -- about how tests or benchmarks are run + + -- TODO there may be more things to null here too, in the future. + + elab_config :: ElaboratedConfiguredPackage + elab_config = + elab { + elabBuildTargets = [], + elabTestTargets = [], + elabBenchTargets = [], + elabReplTarget = Nothing, + elabHaddockTargets = [], + elabBuildHaddocks = False, + + elabTestMachineLog = Nothing, + elabTestHumanLog = Nothing, + elabTestShowDetails = Nothing, + elabTestKeepTix = False, + elabTestTestOptions = [], + elabBenchmarkOptions = [] + } + + -- The second part is the value used to guard the build step. So this is + -- more or less the opposite of the first part, as it's just the info about + -- what targets we're going to build. + -- + buildComponents :: Set ComponentName + buildComponents = elabBuildTargetWholeComponents elab + +-- | Do all the checks on whether a package has changed and thus needs either +-- rebuilding or reconfiguring and rebuilding. +-- +checkPackageFileMonitorChanged :: PackageFileMonitor + -> ElaboratedConfiguredPackage + -> FilePath + -> [BuildStatus] + -> IO (Either BuildStatusRebuild BuildResult) +checkPackageFileMonitorChanged PackageFileMonitor{..} + pkg srcdir depsBuildStatus = do + --TODO: [nice to have] some debug-level message about file + --changes, like rerunIfChanged + configChanged <- checkFileMonitorChanged + pkgFileMonitorConfig srcdir pkgconfig + case configChanged of + MonitorChanged monitorReason -> + return (Left (BuildStatusConfigure monitorReason')) + where + monitorReason' = fmap (const ()) monitorReason + + MonitorUnchanged () _ + -- The configChanged here includes the identity of the dependencies, + -- so depsBuildStatus is just needed for the changes in the content + -- of dependencies. + | any buildStatusRequiresBuild depsBuildStatus -> do + regChanged <- checkFileMonitorChanged pkgFileMonitorReg srcdir () + let mreg = changedToMaybe regChanged + return (Left (BuildStatusBuild mreg BuildReasonDepsRebuilt)) + + | otherwise -> do + buildChanged <- checkFileMonitorChanged + pkgFileMonitorBuild srcdir buildComponents + regChanged <- checkFileMonitorChanged + pkgFileMonitorReg srcdir () + let mreg = changedToMaybe regChanged + case (buildChanged, regChanged) of + (MonitorChanged (MonitoredValueChanged prevBuildComponents), _) -> + return (Left (BuildStatusBuild mreg buildReason)) + where + buildReason = BuildReasonExtraTargets prevBuildComponents + + (MonitorChanged monitorReason, _) -> + return (Left (BuildStatusBuild mreg buildReason)) + where + buildReason = BuildReasonFilesChanged monitorReason' + monitorReason' = fmap (const ()) monitorReason + + (MonitorUnchanged _ _, MonitorChanged monitorReason) -> + -- this should only happen if the file is corrupt or been + -- manually deleted. We don't want to bother with another + -- phase just for this, so we'll reregister by doing a build. + return (Left (BuildStatusBuild Nothing buildReason)) + where + buildReason = BuildReasonFilesChanged monitorReason' + monitorReason' = fmap (const ()) monitorReason + + (MonitorUnchanged _ _, MonitorUnchanged _ _) + | pkgHasEphemeralBuildTargets pkg -> + return (Left (BuildStatusBuild mreg buildReason)) + where + buildReason = BuildReasonEphemeralTargets + + (MonitorUnchanged buildResult _, MonitorUnchanged _ _) -> + return $ Right BuildResult { + buildResultDocs = docsResult, + buildResultTests = testsResult, + buildResultLogFile = Nothing + } + where + (docsResult, testsResult) = buildResult + where + (pkgconfig, buildComponents) = packageFileMonitorKeyValues pkg + changedToMaybe :: MonitorChanged a b -> Maybe b + changedToMaybe (MonitorChanged _) = Nothing + changedToMaybe (MonitorUnchanged x _) = Just x + + +updatePackageConfigFileMonitor :: PackageFileMonitor + -> FilePath + -> ElaboratedConfiguredPackage + -> IO () +updatePackageConfigFileMonitor PackageFileMonitor{pkgFileMonitorConfig} + srcdir pkg = + updateFileMonitor pkgFileMonitorConfig srcdir Nothing + [] pkgconfig () + where + (pkgconfig, _buildComponents) = packageFileMonitorKeyValues pkg + +updatePackageBuildFileMonitor :: PackageFileMonitor + -> FilePath + -> MonitorTimestamp + -> ElaboratedConfiguredPackage + -> BuildStatusRebuild + -> [MonitorFilePath] + -> BuildResultMisc + -> IO () +updatePackageBuildFileMonitor PackageFileMonitor{pkgFileMonitorBuild} + srcdir timestamp pkg pkgBuildStatus + monitors buildResult = + updateFileMonitor pkgFileMonitorBuild srcdir (Just timestamp) + monitors buildComponents' buildResult + where + (_pkgconfig, buildComponents) = packageFileMonitorKeyValues pkg + + -- If the only thing that's changed is that we're now building extra + -- components, then we can avoid later unnecessary rebuilds by saving the + -- total set of components that have been built, namely the union of the + -- existing ones plus the new ones. If files also changed this would be + -- the wrong thing to do. Note that we rely on the + -- fileMonitorCheckIfOnlyValueChanged = True mode to get this guarantee + -- that it's /only/ the value that changed not any files that changed. + buildComponents' = + case pkgBuildStatus of + BuildStatusBuild _ (BuildReasonExtraTargets prevBuildComponents) + -> buildComponents `Set.union` prevBuildComponents + _ -> buildComponents + +updatePackageRegFileMonitor :: PackageFileMonitor + -> FilePath + -> Maybe InstalledPackageInfo + -> IO () +updatePackageRegFileMonitor PackageFileMonitor{pkgFileMonitorReg} + srcdir mipkg = + updateFileMonitor pkgFileMonitorReg srcdir Nothing + [] () mipkg + +invalidatePackageRegFileMonitor :: PackageFileMonitor -> IO () +invalidatePackageRegFileMonitor PackageFileMonitor{pkgFileMonitorReg} = + removeExistingFile (fileMonitorCacheFile pkgFileMonitorReg) + + +------------------------------------------------------------------------------ +-- * Doing it: executing an 'ElaboratedInstallPlan' +------------------------------------------------------------------------------ + +-- Refer to ProjectBuilding.Types for details of these important types: + +-- type BuildOutcomes = ... +-- type BuildOutcome = ... +-- data BuildResult = ... +-- data BuildFailure = ... +-- data BuildFailureReason = ... + +-- | Build things for real. +-- +-- It requires the 'BuildStatusMap' gathered by 'rebuildTargetsDryRun'. +-- +rebuildTargets :: Verbosity + -> DistDirLayout + -> StoreDirLayout + -> ElaboratedInstallPlan + -> ElaboratedSharedConfig + -> BuildStatusMap + -> BuildTimeSettings + -> IO BuildOutcomes +rebuildTargets verbosity + distDirLayout@DistDirLayout{..} + storeDirLayout + installPlan + sharedPackageConfig@ElaboratedSharedConfig { + pkgConfigCompiler = compiler, + pkgConfigCompilerProgs = progdb + } + pkgsBuildStatus + buildSettings@BuildTimeSettings{ + buildSettingNumJobs, + buildSettingKeepGoing + } = do + + -- Concurrency control: create the job controller and concurrency limits + -- for downloading, building and installing. + jobControl <- if isParallelBuild + then newParallelJobControl buildSettingNumJobs + else newSerialJobControl + registerLock <- newLock -- serialise registration + cacheLock <- newLock -- serialise access to setup exe cache + --TODO: [code cleanup] eliminate setup exe cache + + debug verbosity $ + "Executing install plan " + ++ if isParallelBuild + then " in parallel using " ++ show buildSettingNumJobs ++ " threads." + else " serially." + + createDirectoryIfMissingVerbose verbosity True distBuildRootDirectory + createDirectoryIfMissingVerbose verbosity True distTempDirectory + traverse_ (createPackageDBIfMissing verbosity compiler progdb) packageDBsToUse + + -- Before traversing the install plan, preemptively find all packages that + -- will need to be downloaded and start downloading them. + asyncDownloadPackages verbosity withRepoCtx + installPlan pkgsBuildStatus $ \downloadMap -> + + -- For each package in the plan, in dependency order, but in parallel... + InstallPlan.execute jobControl keepGoing + (BuildFailure Nothing . DependentFailed . packageId) + installPlan $ \pkg -> + --TODO: review exception handling + handle (\(e :: BuildFailure) -> return (Left e)) $ fmap Right $ + + let uid = installedUnitId pkg + pkgBuildStatus = Map.findWithDefault (error "rebuildTargets") uid pkgsBuildStatus in + + rebuildTarget + verbosity + distDirLayout + storeDirLayout + buildSettings downloadMap + registerLock cacheLock + sharedPackageConfig + installPlan pkg + pkgBuildStatus + where + isParallelBuild = buildSettingNumJobs >= 2 + 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 ] + ] + + +-- | Create a package DB if it does not currently exist. Note that this action +-- is /not/ safe to run concurrently. +-- +createPackageDBIfMissing :: Verbosity -> Compiler -> ProgramDb + -> PackageDB -> 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 + -> DistDirLayout + -> StoreDirLayout + -> BuildTimeSettings + -> AsyncFetchMap + -> Lock -> Lock + -> ElaboratedSharedConfig + -> ElaboratedInstallPlan + -> ElaboratedReadyPackage + -> BuildStatus + -> IO BuildResult +rebuildTarget verbosity + distDirLayout@DistDirLayout{distBuildDirectory} + storeDirLayout + buildSettings downloadMap + registerLock cacheLock + sharedPackageConfig + plan rpkg@(ReadyPackage pkg) + pkgBuildStatus + -- Technically, doing the --only-download filtering only in this function is + -- not perfect. We could also prune the plan at an earlier stage, like it's + -- done with --only-dependencies. But... + -- * the benefit would be minimal (practically just avoiding to print the + -- "requires build" parts of the plan) + -- * we currently don't have easy access to the BuildStatus of packages + -- in the pruning phase + -- * we still have to check it here to avoid performing successive phases + | buildSettingOnlyDownload buildSettings = do + case pkgBuildStatus of + BuildStatusDownload -> + void $ waitAsyncPackageDownload verbosity downloadMap pkg + _ -> return () + return $ BuildResult DocsNotTried TestsNotTried Nothing + | otherwise = + -- We rely on the 'BuildStatus' to decide which phase to start from: + case pkgBuildStatus of + BuildStatusDownload -> downloadPhase + BuildStatusUnpack tarball -> unpackTarballPhase tarball + BuildStatusRebuild srcdir status -> rebuildPhase status srcdir + + -- TODO: perhaps re-nest the types to make these impossible + BuildStatusPreExisting {} -> unexpectedState + BuildStatusInstalled {} -> unexpectedState + BuildStatusUpToDate {} -> unexpectedState + where + unexpectedState = error "rebuildTarget: unexpected package status" + + downloadPhase :: IO BuildResult + downloadPhase = do + downsrcloc <- annotateFailureNoLog DownloadFailed $ + waitAsyncPackageDownload verbosity downloadMap pkg + case downsrcloc of + DownloadedTarball tarball -> unpackTarballPhase tarball + --TODO: [nice to have] git/darcs repos etc + + + unpackTarballPhase :: FilePath -> IO BuildResult + unpackTarballPhase tarball = + withTarballLocalDirectory + verbosity distDirLayout tarball + (packageId pkg) (elabDistDirParams sharedPackageConfig pkg) + (elabBuildStyle pkg) + (elabPkgDescriptionOverride pkg) $ + + case elabBuildStyle pkg of + BuildAndInstall -> buildAndInstall + BuildInplaceOnly -> buildInplace buildStatus + where + buildStatus = BuildStatusConfigure MonitorFirstRun + + -- Note that this really is rebuild, not build. It can only happen for + -- 'BuildInplaceOnly' style packages. 'BuildAndInstall' style packages + -- would only start from download or unpack phases. + -- + rebuildPhase :: BuildStatusRebuild -> FilePath -> IO BuildResult + rebuildPhase buildStatus srcdir = + assert (elabBuildStyle pkg == BuildInplaceOnly) $ + + buildInplace buildStatus srcdir builddir + where + builddir = distBuildDirectory + (elabDistDirParams sharedPackageConfig pkg) + + buildAndInstall :: FilePath -> FilePath -> IO BuildResult + buildAndInstall srcdir builddir = + buildAndInstallUnpackedPackage + verbosity distDirLayout storeDirLayout + buildSettings registerLock cacheLock + sharedPackageConfig + plan rpkg + srcdir builddir' + where + builddir' = makeRelative srcdir builddir + --TODO: [nice to have] ^^ do this relative stuff better + + buildInplace :: BuildStatusRebuild -> FilePath -> FilePath -> IO BuildResult + buildInplace buildStatus srcdir builddir = + --TODO: [nice to have] use a relative build dir rather than absolute + buildInplaceUnpackedPackage + verbosity distDirLayout + buildSettings registerLock cacheLock + sharedPackageConfig + plan rpkg + buildStatus + srcdir builddir + +-- 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? + +-- | Given the current 'InstallPlan' and 'BuildStatusMap', select all the +-- packages we have to download and fork off an async action to download them. +-- We download them in dependency order so that the one's we'll need +-- first are the ones we will start downloading first. +-- +-- The body action is passed a map from those packages (identified by their +-- location) to a completion var for that package. So the body action should +-- lookup the location and use 'waitAsyncPackageDownload' to get the result. +-- +asyncDownloadPackages :: Verbosity + -> ((RepoContext -> IO a) -> IO a) + -> ElaboratedInstallPlan + -> BuildStatusMap + -> (AsyncFetchMap -> IO a) + -> IO a +asyncDownloadPackages verbosity withRepoCtx installPlan pkgsBuildStatus body + | null pkgsToDownload = body Map.empty + | otherwise = withRepoCtx $ \repoctx -> + asyncFetchPackages verbosity repoctx + pkgsToDownload body + where + pkgsToDownload :: [PackageLocation (Maybe FilePath)] + pkgsToDownload = + ordNub $ + [ elabPkgSourceLocation elab + | InstallPlan.Configured elab + <- InstallPlan.reverseTopologicalOrder installPlan + , let uid = installedUnitId elab + pkgBuildStatus = Map.findWithDefault (error "asyncDownloadPackages") uid pkgsBuildStatus + , BuildStatusDownload <- [pkgBuildStatus] + ] + + +-- | Check if a package needs downloading, and if so expect to find a download +-- in progress in the given 'AsyncFetchMap' and wait on it to finish. +-- +waitAsyncPackageDownload :: Verbosity + -> AsyncFetchMap + -> ElaboratedConfiguredPackage + -> IO DownloadedSourceLocation +waitAsyncPackageDownload verbosity downloadMap elab = do + pkgloc <- waitAsyncFetchPackage verbosity downloadMap + (elabPkgSourceLocation elab) + case downloadedSourceLocation pkgloc of + Just loc -> return loc + Nothing -> fail "waitAsyncPackageDownload: unexpected source location" + +data DownloadedSourceLocation = DownloadedTarball FilePath + --TODO: [nice to have] git/darcs repos etc + +downloadedSourceLocation :: PackageLocation FilePath + -> Maybe DownloadedSourceLocation +downloadedSourceLocation pkgloc = + case pkgloc of + RemoteTarballPackage _ tarball -> Just (DownloadedTarball tarball) + RepoTarballPackage _ _ tarball -> Just (DownloadedTarball tarball) + _ -> Nothing + + + + +-- | Ensure that the package is unpacked in an appropriate directory, either +-- a temporary one or a persistent one under the shared dist directory. +-- +withTarballLocalDirectory + :: Verbosity + -> DistDirLayout + -> FilePath + -> PackageId + -> DistDirParams + -> BuildStyle + -> Maybe CabalFileText + -> (FilePath -> -- Source directory + FilePath -> -- Build directory + IO a) + -> IO a +withTarballLocalDirectory verbosity distDirLayout@DistDirLayout{..} + tarball pkgid dparams buildstyle pkgTextOverride + buildPkg = + case buildstyle of + -- In this case we make a temp dir (e.g. tmp/src2345/), unpack + -- the tarball to it (e.g. tmp/src2345/foo-1.0/), and for + -- compatibility we put the dist dir within it + -- (i.e. tmp/src2345/foo-1.0/dist/). + -- + -- Unfortunately, a few custom Setup.hs scripts do not respect + -- the --builddir flag and always look for it at ./dist/ so + -- this way we avoid breaking those packages + BuildAndInstall -> + let tmpdir = distTempDirectory in + withTempDirectory verbosity tmpdir "src" $ \unpackdir -> do + unpackPackageTarball verbosity tarball unpackdir + pkgid pkgTextOverride + let srcdir = unpackdir prettyShow pkgid + builddir = srcdir "dist" + buildPkg srcdir builddir + + -- In this case we make sure the tarball has been unpacked to the + -- appropriate location under the shared dist dir, and then build it + -- inplace there + BuildInplaceOnly -> do + let srcrootdir = distUnpackedSrcRootDirectory + srcdir = distUnpackedSrcDirectory pkgid + builddir = distBuildDirectory dparams + -- TODO: [nice to have] use a proper file monitor rather + -- than this dir exists test + exists <- doesDirectoryExist srcdir + unless exists $ do + createDirectoryIfMissingVerbose verbosity True srcrootdir + unpackPackageTarball verbosity tarball srcrootdir + pkgid pkgTextOverride + moveTarballShippedDistDirectory verbosity distDirLayout + srcrootdir pkgid dparams + buildPkg srcdir builddir + + +unpackPackageTarball :: Verbosity -> FilePath -> FilePath + -> PackageId -> Maybe CabalFileText + -> IO () +unpackPackageTarball verbosity tarball parentdir pkgid pkgTextOverride = + --TODO: [nice to have] switch to tar package and catch tar exceptions + annotateFailureNoLog UnpackFailed $ do + + -- Unpack the tarball + -- + info verbosity $ "Extracting " ++ tarball ++ " to " ++ parentdir ++ "..." + Tar.extractTarGzFile parentdir pkgsubdir tarball + + -- Sanity check + -- + exists <- doesFileExist cabalFile + unless exists $ + die' verbosity $ + "Package .cabal file not found in the tarball: " ++ cabalFile + + -- Overwrite the .cabal with the one from the index, when appropriate + -- + case pkgTextOverride of + Nothing -> return () + Just pkgtxt -> do + info verbosity $ "Updating " ++ prettyShow pkgname <.> "cabal" + ++ " with the latest revision from the index." + writeFileAtomic cabalFile pkgtxt + + where + cabalFile :: FilePath + cabalFile = parentdir pkgsubdir + prettyShow pkgname <.> "cabal" + pkgsubdir = prettyShow pkgid + pkgname = packageName pkgid + + +-- | This is a bit of a hacky workaround. A number of packages ship +-- pre-processed .hs files in a dist directory inside the tarball. We don't +-- use the standard 'dist' location so unless we move this dist dir to the +-- right place then we'll miss the shipped pre-processed files. This hacky +-- approach to shipped pre-processed files ought to be replaced by a proper +-- system, though we'll still need to keep this hack for older packages. +-- +moveTarballShippedDistDirectory :: Verbosity -> DistDirLayout + -> FilePath -> PackageId -> DistDirParams + -> IO () +moveTarballShippedDistDirectory verbosity DistDirLayout{distBuildDirectory} + parentdir pkgid dparams = do + distDirExists <- doesDirectoryExist tarballDistDir + when distDirExists $ do + debug verbosity $ "Moving '" ++ tarballDistDir ++ "' to '" + ++ targetDistDir ++ "'" + --TODO: [nice to have] or perhaps better to copy, and use a file monitor + renameDirectory tarballDistDir targetDistDir + where + tarballDistDir = parentdir prettyShow pkgid "dist" + targetDistDir = distBuildDirectory dparams + + +buildAndInstallUnpackedPackage :: Verbosity + -> DistDirLayout + -> StoreDirLayout + -> BuildTimeSettings -> Lock -> Lock + -> ElaboratedSharedConfig + -> ElaboratedInstallPlan + -> ElaboratedReadyPackage + -> FilePath -> FilePath + -> IO BuildResult +buildAndInstallUnpackedPackage verbosity + distDirLayout@DistDirLayout{distTempDirectory} + storeDirLayout@StoreDirLayout { + storePackageDBStack + } + BuildTimeSettings { + buildSettingNumJobs, + buildSettingLogFile + } + registerLock cacheLock + pkgshared@ElaboratedSharedConfig { + pkgConfigPlatform = platform, + pkgConfigCompiler = compiler, + pkgConfigCompilerProgs = progdb + } + plan rpkg@(ReadyPackage pkg) + srcdir builddir = do + + createDirectoryIfMissingVerbose verbosity True (srcdir builddir) + initLogFile + + --TODO: [code cleanup] deal consistently with talking to older + -- Setup.hs versions, much like we do for ghc, with a proper + -- options type and rendering step which will also let us + -- call directly into the lib, rather than always going via + -- the lib's command line interface, which would also allow + -- passing data like installed packages, compiler, and + -- program db for a quicker configure. + + --TODO: [required feature] docs and tests + --TODO: [required feature] sudo re-exec + + -- Configure phase + noticeProgress ProgressStarting + + annotateFailure mlogFile ConfigureFailed $ + setup' configureCommand configureFlags configureArgs + + -- Build phase + noticeProgress ProgressBuilding + + annotateFailure mlogFile BuildFailed $ + setup buildCommand buildFlags + + -- Haddock phase + whenHaddock $ do + noticeProgress ProgressHaddock + annotateFailureNoLog HaddocksFailed $ + setup haddockCommand haddockFlags + + -- Install phase + noticeProgress ProgressInstalling + annotateFailure mlogFile InstallFailed $ do + + let copyPkgFiles tmpDir = do + let tmpDirNormalised = normalise tmpDir + setup Cabal.copyCommand (copyFlags tmpDirNormalised) + -- Note that the copy command has put the files into + -- @$tmpDir/$prefix@ so we need to return this dir so + -- the store knows which dir will be the final store entry. + let prefix = normalise $ + dropDrive (InstallDirs.prefix (elabInstallDirs pkg)) + entryDir = tmpDirNormalised prefix + + -- if there weren't anything to build, it might be that directory is not created + -- the @setup Cabal.copyCommand@ above might do nothing. + -- https://github.com/haskell/cabal/issues/4130 + createDirectoryIfMissingVerbose verbosity True entryDir + + let hashFileName = entryDir "cabal-hash.txt" + outPkgHashInputs = renderPackageHashInputs (packageHashInputs pkgshared pkg) + + info verbosity $ + "creating file with the inputs used to compute the package hash: " ++ hashFileName + + LBS.writeFile hashFileName outPkgHashInputs + + debug verbosity "Package hash inputs:" + traverse_ + (debug verbosity . ("> " ++)) + (lines $ LBS.Char8.unpack outPkgHashInputs) + + -- Ensure that there are no files in `tmpDir`, that are + -- not in `entryDir`. While this breaks the + -- prefix-relocatable property of the libraries, it is + -- necessary on macOS to stay under the load command limit + -- of the macOS mach-o linker. See also + -- @PackageHash.hashedInstalledPackageIdVeryShort@. + -- + -- We also normalise paths to ensure that there are no + -- different representations for the same path. Like / and + -- \\ on windows under msys. + otherFiles <- filter (not . isPrefixOf entryDir) <$> + listFilesRecursive tmpDirNormalised + -- Here's where we could keep track of the installed files + -- ourselves if we wanted to by making a manifest of the + -- files in the tmp dir. + return (entryDir, otherFiles) + where + listFilesRecursive :: FilePath -> IO [FilePath] + listFilesRecursive path = do + files <- fmap (path ) <$> (listDirectory path) + allFiles <- for files $ \file -> do + isDir <- doesDirectoryExist file + if isDir + then listFilesRecursive file + else return [file] + return (concat allFiles) + + registerPkg + | not (elabRequiresRegistration pkg) = + debug verbosity $ + "registerPkg: elab does NOT require registration for " + ++ prettyShow uid + | otherwise = do + -- 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 + let ipkg = ipkg0 { Installed.installedUnitId = uid } + assert ( elabRegisterPackageDBStack pkg + == storePackageDBStack compid) (return ()) + criticalSection registerLock $ + Cabal.registerPackage + verbosity compiler progdb + (storePackageDBStack compid) ipkg + Cabal.defaultRegisterOptions { + Cabal.registerMultiInstance = True, + Cabal.registerSuppressFilesCheck = True + } + + + -- Actual installation + void $ newStoreEntry verbosity storeDirLayout + compid uid + copyPkgFiles registerPkg + + --TODO: [nice to have] we currently rely on Setup.hs copy to do the right + -- thing. Although we do copy into an image dir and do the move into the + -- final location ourselves, perhaps we ought to do some sanity checks on + -- the image dir first. + + -- TODO: [required eventually] note that for nix-style + -- installations it is not necessary to do the + -- 'withWin32SelfUpgrade' dance, but it would be necessary for a + -- shared bin dir. + + --TODO: [required feature] docs and test phases + let docsResult = DocsNotTried + testsResult = TestsNotTried + + noticeProgress ProgressCompleted + + return BuildResult { + buildResultDocs = docsResult, + buildResultTests = testsResult, + buildResultLogFile = mlogFile + } + + where + pkgid = packageId rpkg + uid = installedUnitId rpkg + compid = compilerId compiler + + dispname :: String + dispname = case elabPkgOrComp pkg of + ElabPackage _ -> prettyShow pkgid + ++ " (all, legacy fallback)" + ElabComponent comp -> prettyShow pkgid + ++ " (" ++ maybe "custom" prettyShow (compComponentName comp) ++ ")" + + noticeProgress :: ProgressPhase -> IO () + noticeProgress phase = when isParallelBuild $ + progressMessage verbosity phase dispname + + isParallelBuild = buildSettingNumJobs >= 2 + + whenHaddock action + | hasValidHaddockTargets pkg = action + | otherwise = return () + + configureCommand = Cabal.configureCommand defaultProgramDb + configureFlags v = flip filterConfigureFlags v $ + setupHsConfigureFlags rpkg pkgshared + verbosity builddir + configureArgs _ = setupHsConfigureArgs pkg + + buildCommand = Cabal.buildCommand defaultProgramDb + buildFlags _ = setupHsBuildFlags pkg pkgshared verbosity builddir + + haddockCommand = Cabal.haddockCommand + haddockFlags _ = setupHsHaddockFlags pkg pkgshared + verbosity builddir + + generateInstalledPackageInfo :: IO InstalledPackageInfo + generateInstalledPackageInfo = + withTempInstalledPackageInfoFile + verbosity distTempDirectory $ \pkgConfDest -> do + let registerFlags _ = setupHsRegisterFlags + pkg pkgshared + verbosity builddir + pkgConfDest + setup Cabal.registerCommand registerFlags + + copyFlags destdir _ = setupHsCopyFlags pkg pkgshared verbosity + builddir destdir + + scriptOptions = setupHsScriptOptions rpkg plan pkgshared + distDirLayout srcdir builddir + isParallelBuild cacheLock + + setup :: CommandUI flags -> (Version -> flags) -> IO () + setup cmd flags = setup' cmd flags (const []) + + setup' :: CommandUI flags -> (Version -> flags) -> (Version -> [String]) + -> IO () + setup' cmd flags args = + withLogging $ \mLogFileHandle -> + setupWrapper + verbosity + scriptOptions + { useLoggingHandle = mLogFileHandle + , useExtraEnvOverrides = dataDirsEnvironmentForPlan + distDirLayout plan } + (Just (elabPkgDescription pkg)) + cmd flags args + + mlogFile :: Maybe FilePath + mlogFile = + case buildSettingLogFile of + Nothing -> Nothing + Just mkLogFile -> Just (mkLogFile compiler platform pkgid uid) + + initLogFile :: IO () + initLogFile = + case mlogFile of + Nothing -> return () + Just logFile -> do + createDirectoryIfMissing True (takeDirectory logFile) + exists <- doesFileExist logFile + when exists $ removeFile logFile + + withLogging :: (Maybe Handle -> IO r) -> IO r + withLogging action = + case mlogFile of + Nothing -> action Nothing + Just logFile -> withFile logFile AppendMode (action . Just) + + +hasValidHaddockTargets :: ElaboratedConfiguredPackage -> Bool +hasValidHaddockTargets ElaboratedConfiguredPackage{..} + | not elabBuildHaddocks = False + | otherwise = any componentHasHaddocks components + where + components :: [ComponentTarget] + components = elabBuildTargets ++ elabTestTargets ++ elabBenchTargets + ++ maybeToList elabReplTarget ++ elabHaddockTargets + + componentHasHaddocks :: ComponentTarget -> Bool + componentHasHaddocks (ComponentTarget name _) = + case name of + CLibName LMainLibName -> hasHaddocks + CLibName (LSubLibName _) -> elabHaddockInternal && hasHaddocks + CFLibName _ -> elabHaddockForeignLibs && hasHaddocks + CExeName _ -> elabHaddockExecutables && hasHaddocks + CTestName _ -> elabHaddockTestSuites && hasHaddocks + CBenchName _ -> elabHaddockBenchmarks && hasHaddocks + where + hasHaddocks = not (null (elabPkgDescription ^. componentModules name)) + + +buildInplaceUnpackedPackage :: Verbosity + -> DistDirLayout + -> BuildTimeSettings -> Lock -> Lock + -> ElaboratedSharedConfig + -> ElaboratedInstallPlan + -> ElaboratedReadyPackage + -> BuildStatusRebuild + -> FilePath -> FilePath + -> IO BuildResult +buildInplaceUnpackedPackage verbosity + distDirLayout@DistDirLayout { + distTempDirectory, + distPackageCacheDirectory, + distDirectory + } + BuildTimeSettings{buildSettingNumJobs, buildSettingHaddockOpen} + registerLock cacheLock + pkgshared@ElaboratedSharedConfig { + pkgConfigCompiler = compiler, + pkgConfigCompilerProgs = progdb, + pkgConfigPlatform = platform + } + plan + rpkg@(ReadyPackage pkg) + buildStatus + srcdir builddir = do + + --TODO: [code cleanup] there is duplication between the + -- distdirlayout and the builddir here builddir is not + -- enough, we also need the per-package cachedir + createDirectoryIfMissingVerbose verbosity True builddir + createDirectoryIfMissingVerbose verbosity True + (distPackageCacheDirectory dparams) + + -- Configure phase + -- + whenReConfigure $ do + annotateFailureNoLog ConfigureFailed $ + setup configureCommand configureFlags configureArgs + invalidatePackageRegFileMonitor packageFileMonitor + updatePackageConfigFileMonitor packageFileMonitor srcdir pkg + + -- Build phase + -- + let docsResult = DocsNotTried + testsResult = TestsNotTried + + buildResult :: BuildResultMisc + buildResult = (docsResult, testsResult) + + whenRebuild $ do + timestamp <- beginUpdateFileMonitor + annotateFailureNoLog BuildFailed $ + setup buildCommand buildFlags buildArgs + + let listSimple = + execRebuild srcdir (needElaboratedConfiguredPackage pkg) + listSdist = + fmap (map monitorFileHashed) $ + allPackageSourceFiles verbosity 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 srcdir timestamp + pkg buildStatus + (monitors ++ dep_monitors) buildResult + + -- PURPOSELY omitted: no copy! + + whenReRegister $ annotateFailureNoLog InstallFailed $ do + -- Register locally + mipkg <- if elabRequiresRegistration pkg + then do + ipkg0 <- generateInstalledPackageInfo + -- 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. + let ipkg = ipkg0 { Installed.installedUnitId = ipkgid } + criticalSection registerLock $ + Cabal.registerPackage verbosity compiler progdb + (elabRegisterPackageDBStack pkg) + ipkg Cabal.defaultRegisterOptions + return (Just ipkg) + + else return Nothing + + updatePackageRegFileMonitor packageFileMonitor srcdir mipkg + + whenTest $ do + annotateFailureNoLog TestsFailed $ + setup testCommand testFlags testArgs + + whenBench $ + annotateFailureNoLog BenchFailed $ + setup benchCommand benchFlags benchArgs + + -- Repl phase + -- + whenRepl $ + annotateFailureNoLog ReplFailed $ + setupInteractive replCommand replFlags replArgs + + -- Haddock phase + whenHaddock $ + annotateFailureNoLog HaddocksFailed $ do + setup haddockCommand haddockFlags haddockArgs + let haddockTarget = elabHaddockForHackage pkg + when (haddockTarget == Cabal.ForHackage) $ do + let dest = distDirectory name <.> "tar.gz" + name = haddockDirName haddockTarget (elabPkgDescription pkg) + docDir = distBuildDirectory distDirLayout dparams + "doc" "html" + Tar.createTarGzFile dest docDir name + notice verbosity $ "Documentation tarball created: " ++ dest + + when (buildSettingHaddockOpen && haddockTarget /= Cabal.ForHackage) $ do + let dest = docDir name "index.html" + name = haddockDirName haddockTarget (elabPkgDescription pkg) + docDir = distBuildDirectory distDirLayout dparams + "doc" "html" + exe <- findOpenProgramLocation platform + case exe of + Right open -> runProgramInvocation verbosity (simpleProgramInvocation open [dest]) + Left err -> die' verbosity err + + + return BuildResult { + buildResultDocs = docsResult, + buildResultTests = testsResult, + buildResultLogFile = Nothing + } + + where + ipkgid = installedUnitId pkg + dparams = elabDistDirParams pkgshared pkg + + isParallelBuild = buildSettingNumJobs >= 2 + + packageFileMonitor = newPackageFileMonitor pkgshared distDirLayout dparams + + whenReConfigure action = case buildStatus of + BuildStatusConfigure _ -> action + _ -> return () + + whenRebuild action + | null (elabBuildTargets pkg) + -- NB: we have to build the test/bench suite! + , null (elabTestTargets pkg) + , null (elabBenchTargets pkg) = return () + | otherwise = action + + whenTest action + | null (elabTestTargets pkg) = return () + | otherwise = action + + whenBench action + | null (elabBenchTargets pkg) = return () + | otherwise = action + + whenRepl action + | isNothing (elabReplTarget pkg) = return () + | otherwise = action + + whenHaddock action + | hasValidHaddockTargets pkg = action + | otherwise = return () + + whenReRegister action + = case buildStatus of + -- We registered the package already + BuildStatusBuild (Just _) _ -> + info verbosity "whenReRegister: previously registered" + -- There is nothing to register + _ | null (elabBuildTargets pkg) -> + info verbosity "whenReRegister: nothing to register" + | otherwise -> action + + configureCommand = Cabal.configureCommand defaultProgramDb + configureFlags v = flip filterConfigureFlags v $ + setupHsConfigureFlags rpkg pkgshared + verbosity builddir + configureArgs _ = setupHsConfigureArgs pkg + + buildCommand = Cabal.buildCommand defaultProgramDb + buildFlags _ = setupHsBuildFlags pkg pkgshared + verbosity builddir + buildArgs _ = setupHsBuildArgs pkg + + testCommand = Cabal.testCommand -- defaultProgramDb + testFlags v = flip filterTestFlags v $ + setupHsTestFlags pkg pkgshared + verbosity builddir + testArgs _ = setupHsTestArgs pkg + + benchCommand = Cabal.benchmarkCommand + benchFlags _ = setupHsBenchFlags pkg pkgshared + verbosity builddir + benchArgs _ = setupHsBenchArgs pkg + + replCommand = Cabal.replCommand defaultProgramDb + replFlags _ = setupHsReplFlags pkg pkgshared + verbosity builddir + replArgs _ = setupHsReplArgs pkg + + haddockCommand = Cabal.haddockCommand + haddockFlags v = flip filterHaddockFlags v $ + setupHsHaddockFlags pkg pkgshared + verbosity builddir + haddockArgs v = flip filterHaddockArgs v $ + setupHsHaddockArgs pkg + + scriptOptions = setupHsScriptOptions rpkg plan pkgshared + distDirLayout srcdir builddir + isParallelBuild cacheLock + + setupInteractive :: CommandUI flags + -> (Version -> flags) -> (Version -> [String]) -> IO () + setupInteractive cmd flags args = + setupWrapper verbosity + scriptOptions { isInteractive = True } + (Just (elabPkgDescription pkg)) + cmd flags args + + setup :: CommandUI flags -> (Version -> flags) -> (Version -> [String]) + -> IO () + setup cmd flags args = + setupWrapper verbosity + scriptOptions + (Just (elabPkgDescription pkg)) + cmd flags args + + generateInstalledPackageInfo :: IO InstalledPackageInfo + generateInstalledPackageInfo = + withTempInstalledPackageInfoFile + verbosity distTempDirectory $ \pkgConfDest -> do + let registerFlags _ = setupHsRegisterFlags + pkg pkgshared + verbosity builddir + pkgConfDest + setup Cabal.registerCommand registerFlags (const []) + +withTempInstalledPackageInfoFile :: Verbosity -> FilePath + -> (FilePath -> IO ()) + -> IO InstalledPackageInfo +withTempInstalledPackageInfoFile verbosity tempdir action = + withTempDirectory verbosity tempdir "package-registration-" $ \dir -> do + -- make absolute since @action@ will often change directory + abs_dir <- canonicalizePath dir + + let pkgConfDest = abs_dir "pkgConf" + action pkgConfDest + + readPkgConf "." pkgConfDest + where + pkgConfParseFailed :: String -> IO a + pkgConfParseFailed perror = + die' verbosity $ + "Couldn't parse the output of 'setup register --gen-pkg-config':" + ++ show perror + + readPkgConf :: FilePath -> FilePath -> IO InstalledPackageInfo + readPkgConf pkgConfDir pkgConfFile = do + pkgConfStr <- BS.readFile (pkgConfDir pkgConfFile) + (warns, ipkg) <- case Installed.parseInstalledPackageInfo pkgConfStr of + Left perrors -> pkgConfParseFailed $ unlines $ NE.toList perrors + Right (warns, ipkg) -> return (warns, ipkg) + + unless (null warns) $ + warn verbosity $ unlines warns + + return ipkg + + +------------------------------------------------------------------------------ +-- * Utilities +------------------------------------------------------------------------------ + +annotateFailureNoLog :: (SomeException -> BuildFailureReason) + -> IO a -> IO a +annotateFailureNoLog annotate action = + annotateFailure Nothing annotate action + +annotateFailure :: Maybe FilePath + -> (SomeException -> BuildFailureReason) + -> IO a -> IO a +annotateFailure mlogFile annotate action = + action `catches` + -- It's not just IOException and ExitCode we have to deal with, there's + -- lots, including exceptions from the hackage-security and tar packages. + -- So we take the strategy of catching everything except async exceptions. + [ +#if MIN_VERSION_base(4,7,0) + Handler $ \async -> throwIO (async :: SomeAsyncException) +#else + Handler $ \async -> throwIO (async :: AsyncException) +#endif + , Handler $ \other -> handler (other :: SomeException) + ] + where + handler :: Exception e => e -> IO a + handler = throwIO . BuildFailure mlogFile . annotate . toException diff --git a/cabal/cabal-install/src/Distribution/Client/ProjectBuilding/Types.hs b/cabal/cabal-install/src/Distribution/Client/ProjectBuilding/Types.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/ProjectBuilding/Types.hs @@ -0,0 +1,204 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +-- | Types for the "Distribution.Client.ProjectBuilding" +-- +-- Moved out to avoid module cycles. +-- +module Distribution.Client.ProjectBuilding.Types ( + -- * Pre-build status + BuildStatusMap, + BuildStatus(..), + buildStatusRequiresBuild, + buildStatusToString, + BuildStatusRebuild(..), + BuildReason(..), + MonitorChangedReason(..), + + -- * Build outcomes + BuildOutcomes, + BuildOutcome, + BuildResult(..), + BuildFailure(..), + BuildFailureReason(..), + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Client.Types (DocsResult, TestsResult) +import Distribution.Client.FileMonitor (MonitorChangedReason(..)) + +import Distribution.Package (UnitId, PackageId) +import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import Distribution.Simple.LocalBuildInfo (ComponentName) + + +------------------------------------------------------------------------------ +-- Pre-build status: result of the dry run +-- + +-- | 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 + +-- | The build status for an individual package is the state that the +-- package is in /prior/ to initiating a (re)build. +-- +-- This should not be confused with a 'BuildResult' which is the result +-- /after/ successfully building a package. +-- +-- It serves two purposes: +-- +-- * For dry-run output, it lets us explain to the user if and why a package +-- is going to be (re)built. +-- +-- * It tell us what step to start or resume building from, and carries +-- enough information for us to be able to do so. +-- +data BuildStatus = + + -- | The package is in the 'InstallPlan.PreExisting' state, so does not + -- need building. + BuildStatusPreExisting + + -- | The package is in the 'InstallPlan.Installed' state, so does not + -- need building. + | BuildStatusInstalled + + -- | The package has not been downloaded yet, so it will have to be + -- downloaded, unpacked and built. + | BuildStatusDownload + + -- | The package has not been unpacked yet, so it will have to be + -- unpacked and built. + | BuildStatusUnpack FilePath + + -- | The package exists in a local dir already, and just needs building + -- or rebuilding. So this can only happen for 'BuildInplaceOnly' style + -- packages. + | BuildStatusRebuild FilePath BuildStatusRebuild + + -- | The package exists in a local dir already, and is fully up to date. + -- So this package can be put into the 'InstallPlan.Installed' state + -- and it does not need to be built. + | BuildStatusUpToDate BuildResult + + +-- | Which 'BuildStatus' values indicate we'll have to do some build work of +-- some sort. In particular we use this as part of checking if any of a +-- package's deps have changed. +-- +buildStatusRequiresBuild :: BuildStatus -> Bool +buildStatusRequiresBuild BuildStatusPreExisting = False +buildStatusRequiresBuild BuildStatusInstalled = False +buildStatusRequiresBuild BuildStatusUpToDate {} = False +buildStatusRequiresBuild _ = True + +-- | This is primarily here for debugging. It's not actually used anywhere. +-- +buildStatusToString :: BuildStatus -> String +buildStatusToString BuildStatusPreExisting = "BuildStatusPreExisting" +buildStatusToString BuildStatusInstalled = "BuildStatusInstalled" +buildStatusToString BuildStatusDownload = "BuildStatusDownload" +buildStatusToString (BuildStatusUnpack fp) = "BuildStatusUnpack " ++ show fp +buildStatusToString (BuildStatusRebuild fp _) = "BuildStatusRebuild " ++ show fp +buildStatusToString (BuildStatusUpToDate _) = "BuildStatusUpToDate" + + +-- | For a package that is going to be built or rebuilt, the state it's in now. +-- +-- So again, this tells us why a package needs to be rebuilt and what build +-- phases need to be run. The 'MonitorChangedReason' gives us details like +-- which file changed, which is mainly for high verbosity debug output. +-- +data BuildStatusRebuild = + + -- | The package configuration changed, so the configure and build phases + -- needs to be (re)run. + BuildStatusConfigure (MonitorChangedReason ()) + + -- | The configuration has not changed but the build phase needs to be + -- rerun. We record the reason the (re)build is needed. + -- + -- The optional registration info here tells us if we've registered the + -- package already, or if we still need to do that after building. + -- @Just Nothing@ indicates that we know that no registration is + -- necessary (e.g., executable.) + -- + | BuildStatusBuild (Maybe (Maybe InstalledPackageInfo)) BuildReason + +data BuildReason = + -- | The dependencies of this package have been (re)built so the build + -- phase needs to be rerun. + -- + BuildReasonDepsRebuilt + + -- | Changes in files within the package (or first run or corrupt cache) + | BuildReasonFilesChanged (MonitorChangedReason ()) + + -- | An important special case is that no files have changed but the + -- set of components the /user asked to build/ has changed. We track the + -- set of components /we have built/, which of course only grows (until + -- some other change resets it). + -- + -- The @Set 'ComponentName'@ is the set of components we have built + -- previously. When we update the monitor we take the union of the ones + -- we have built previously with the ones the user has asked for this + -- time and save those. See 'updatePackageBuildFileMonitor'. + -- + | BuildReasonExtraTargets (Set ComponentName) + + -- | Although we're not going to build any additional targets as a whole, + -- we're going to build some part of a component or run a repl or any + -- other action that does not result in additional persistent artifacts. + -- + | BuildReasonEphemeralTargets + + +------------------------------------------------------------------------------ +-- Build outcomes: result of the build +-- + +-- | A summary of the outcome for building a whole set of packages. +-- +type BuildOutcomes = Map UnitId BuildOutcome + +-- | A summary of the outcome for building a single package: either success +-- or failure. +-- +type BuildOutcome = Either BuildFailure BuildResult + +-- | Information arising from successfully building a single package. +-- +data BuildResult = BuildResult { + buildResultDocs :: DocsResult, + buildResultTests :: TestsResult, + buildResultLogFile :: Maybe FilePath + } + deriving Show + +-- | Information arising from the failure to build a single package. +-- +data BuildFailure = BuildFailure { + buildFailureLogFile :: Maybe FilePath, + buildFailureReason :: BuildFailureReason + } + deriving (Show, Typeable) + +instance Exception BuildFailure + +-- | Detail on the reason that a package failed to build. +-- +data BuildFailureReason = DependentFailed PackageId + | DownloadFailed SomeException + | UnpackFailed SomeException + | ConfigureFailed SomeException + | BuildFailed SomeException + | ReplFailed SomeException + | HaddocksFailed SomeException + | TestsFailed SomeException + | BenchFailed SomeException + | InstallFailed SomeException + deriving Show diff --git a/cabal/cabal-install/src/Distribution/Client/ProjectConfig.hs b/cabal/cabal-install/src/Distribution/Client/ProjectConfig.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/ProjectConfig.hs @@ -0,0 +1,1470 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} + +-- | Handling project configuration. +-- +module Distribution.Client.ProjectConfig ( + + -- * Types for project config + ProjectConfig(..), + ProjectConfigBuildOnly(..), + ProjectConfigShared(..), + ProjectConfigProvenance(..), + PackageConfig(..), + MapLast(..), + MapMappend(..), + + -- * Project root + findProjectRoot, + ProjectRoot(..), + BadProjectRoot(..), + + -- * Project config files + readProjectConfig, + readGlobalConfig, + readProjectLocalExtraConfig, + readProjectLocalFreezeConfig, + reportParseResult, + showProjectConfig, + withProjectOrGlobalConfig, + writeProjectLocalExtraConfig, + writeProjectLocalFreezeConfig, + writeProjectConfigFile, + commandLineFlagsToProjectConfig, + + -- * Packages within projects + ProjectPackageLocation(..), + BadPackageLocations(..), + BadPackageLocation(..), + BadPackageLocationMatch(..), + findProjectPackages, + fetchAndReadSourcePackages, + + -- * Resolving configuration + lookupLocalPackageConfig, + projectConfigWithBuilderRepoContext, + projectConfigWithSolverRepoContext, + SolverSettings(..), + resolveSolverSettings, + BuildTimeSettings(..), + resolveBuildTimeSettings, + + -- * Checking configuration + checkBadPerPackageCompilerPaths, + BadPerPackageCompilerPaths(..) + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Distribution.Client.ProjectConfig.Types +import Distribution.Client.ProjectConfig.Legacy +import Distribution.Client.RebuildMonad +import Distribution.Client.Glob + ( isTrivialFilePathGlob ) +import Distribution.Client.VCS + ( validateSourceRepos, SourceRepoProblem(..) + , VCS(..), knownVCSs, configureVCS, syncSourceRepos ) + +import Distribution.Client.Types +import Distribution.Client.DistDirLayout + ( DistDirLayout(..), CabalDirLayout(..), ProjectRoot(..) ) +import Distribution.Client.GlobalFlags + ( RepoContext(..), withRepoContext' ) +import Distribution.Client.BuildReports.Types + ( ReportLevel(..) ) +import Distribution.Client.Config + ( loadConfig, getConfigFilePath ) +import Distribution.Client.HttpUtils + ( HttpTransport, configureTransport, transportCheckHttps + , downloadURI ) +import Distribution.Client.Utils.Parsec (renderParseError) + +import Distribution.Solver.Types.SourcePackage +import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.PackageConstraint + ( PackageProperty(..) ) + +import Distribution.Package + ( PackageName, PackageId, UnitId, packageId ) +import Distribution.Types.PackageVersionConstraint + ( PackageVersionConstraint(..) ) +import Distribution.System + ( Platform ) +import Distribution.Types.GenericPackageDescription + ( GenericPackageDescription ) +import Distribution.PackageDescription.Parsec + ( parseGenericPackageDescription ) +import Distribution.Fields + ( runParseResult, PError, PWarning, showPWarning) +import Distribution.Types.SourceRepo + ( RepoType(..) ) +import Distribution.Client.Types.SourceRepo + ( SourceRepoList, SourceRepositoryPackage (..), srpFanOut ) +import Distribution.Simple.Compiler + ( Compiler, compilerInfo ) +import Distribution.Simple.Program + ( ConfiguredProgram(..) ) +import Distribution.Simple.Setup + ( Flag(Flag), toFlag, flagToMaybe, flagToList + , fromFlag, fromFlagOrDefault ) +import Distribution.Client.Setup + ( defaultSolver, defaultMaxBackjumps ) +import Distribution.Simple.InstallDirs + ( PathTemplate, fromPathTemplate + , toPathTemplate, substPathTemplate, initialPathTemplateEnv ) +import Distribution.Simple.Utils + ( die', warn, notice, info, createDirectoryIfMissingVerbose, rawSystemIOWithEnv ) +import Distribution.Client.Utils + ( determineNumJobs ) +import Distribution.Utils.NubList + ( fromNubList ) +import Distribution.Verbosity + ( modifyVerbosity, verbose ) +import Distribution.Version + ( Version ) +import qualified Distribution.Deprecated.ParseUtils as OldParser + ( ParseResult(..), locatedErrorMsg, showPWarning ) +import Distribution.Client.SrcDist + ( packageDirToSdist ) + +import qualified Codec.Archive.Tar as Tar +import qualified Codec.Archive.Tar.Entry as Tar +import qualified Distribution.Client.Tar as Tar +import qualified Distribution.Client.GZipUtils as GZipUtils + +import Control.Monad.Trans (liftIO) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Map as Map +import qualified Data.List.NonEmpty as NE +import qualified Data.Set as Set +import qualified Data.Hashable as Hashable +import Numeric (showHex) + +import System.FilePath hiding (combine) +import System.IO + ( withBinaryFile, IOMode(ReadMode) ) +import System.Directory +import Network.URI + ( URI(..), URIAuth(..), parseAbsoluteURI, uriToString ) + + +---------------------------------------- +-- Resolving configuration to settings +-- + +-- | Look up a 'PackageConfig' field in the 'ProjectConfig' for a specific +-- 'PackageName'. This returns the configuration that applies to all local +-- packages plus any package-specific configuration for this package. +-- +lookupLocalPackageConfig + :: (Semigroup a, Monoid a) + => (PackageConfig -> a) -> ProjectConfig -> PackageName + -> a +lookupLocalPackageConfig field ProjectConfig { + projectConfigLocalPackages, + projectConfigSpecificPackage + } pkgname = + field projectConfigLocalPackages + <> maybe mempty field + (Map.lookup pkgname (getMapMappend projectConfigSpecificPackage)) + + +-- | Use a 'RepoContext' based on the 'BuildTimeSettings'. +-- +projectConfigWithBuilderRepoContext :: Verbosity + -> BuildTimeSettings + -> (RepoContext -> IO a) -> IO a +projectConfigWithBuilderRepoContext verbosity BuildTimeSettings{..} = + withRepoContext' + verbosity + buildSettingRemoteRepos + buildSettingLocalNoIndexRepos + buildSettingCacheDir + buildSettingHttpTransport + (Just buildSettingIgnoreExpiry) + buildSettingProgPathExtra + + +-- | Use a 'RepoContext', but only for the solver. The solver does not use the +-- full facilities of the 'RepoContext' so we can get away with making one +-- that doesn't have an http transport. And that avoids having to have access +-- to the 'BuildTimeSettings' +-- +projectConfigWithSolverRepoContext + :: Verbosity -> ProjectConfigShared -> ProjectConfigBuildOnly + -> (RepoContext -> IO a) + -> IO a +projectConfigWithSolverRepoContext verbosity + ProjectConfigShared{..} + ProjectConfigBuildOnly{..} = + withRepoContext' + verbosity + (fromNubList projectConfigRemoteRepos) + (fromNubList projectConfigLocalNoIndexRepos) + (fromFlagOrDefault + (error + "projectConfigWithSolverRepoContext: projectConfigCacheDir") + projectConfigCacheDir) + (flagToMaybe projectConfigHttpTransport) + (flagToMaybe projectConfigIgnoreExpiry) + (fromNubList projectConfigProgPathExtra) + + +-- | Resolve the project configuration, with all its optional fields, into +-- 'SolverSettings' with no optional fields (by applying defaults). +-- +resolveSolverSettings :: ProjectConfig -> SolverSettings +resolveSolverSettings ProjectConfig{ + projectConfigShared, + projectConfigLocalPackages, + projectConfigSpecificPackage + } = + SolverSettings {..} + where + --TODO: [required eventually] some of these settings need validation, e.g. + -- the flag assignments need checking. + solverSettingRemoteRepos = fromNubList projectConfigRemoteRepos + solverSettingLocalNoIndexRepos = fromNubList projectConfigLocalNoIndexRepos + solverSettingConstraints = projectConfigConstraints + solverSettingPreferences = projectConfigPreferences + solverSettingFlagAssignment = packageConfigFlagAssignment projectConfigLocalPackages + solverSettingFlagAssignments = fmap packageConfigFlagAssignment + (getMapMappend projectConfigSpecificPackage) + solverSettingCabalVersion = flagToMaybe projectConfigCabalVersion + solverSettingSolver = fromFlag projectConfigSolver + solverSettingAllowOlder = fromMaybe mempty projectConfigAllowOlder + solverSettingAllowNewer = fromMaybe mempty projectConfigAllowNewer + solverSettingMaxBackjumps = case fromFlag projectConfigMaxBackjumps of + n | n < 0 -> Nothing + | otherwise -> Just n + solverSettingReorderGoals = fromFlag projectConfigReorderGoals + solverSettingCountConflicts = fromFlag projectConfigCountConflicts + solverSettingFineGrainedConflicts = fromFlag projectConfigFineGrainedConflicts + solverSettingMinimizeConflictSet = fromFlag projectConfigMinimizeConflictSet + solverSettingStrongFlags = fromFlag projectConfigStrongFlags + solverSettingAllowBootLibInstalls = fromFlag projectConfigAllowBootLibInstalls + solverSettingOnlyConstrained = fromFlag projectConfigOnlyConstrained + solverSettingIndexState = flagToMaybe projectConfigIndexState + solverSettingActiveRepos = flagToMaybe projectConfigActiveRepos + solverSettingIndependentGoals = fromFlag projectConfigIndependentGoals + solverSettingPreferOldest = fromFlag projectConfigPreferOldest + --solverSettingShadowPkgs = fromFlag projectConfigShadowPkgs + --solverSettingReinstall = fromFlag projectConfigReinstall + --solverSettingAvoidReinstalls = fromFlag projectConfigAvoidReinstalls + --solverSettingOverrideReinstall = fromFlag projectConfigOverrideReinstall + --solverSettingUpgradeDeps = fromFlag projectConfigUpgradeDeps + + ProjectConfigShared {..} = defaults <> projectConfigShared + + defaults = mempty { + projectConfigSolver = Flag defaultSolver, + projectConfigAllowOlder = Just (AllowOlder mempty), + projectConfigAllowNewer = Just (AllowNewer mempty), + projectConfigMaxBackjumps = Flag defaultMaxBackjumps, + projectConfigReorderGoals = Flag (ReorderGoals False), + projectConfigCountConflicts = Flag (CountConflicts True), + projectConfigFineGrainedConflicts = Flag (FineGrainedConflicts True), + projectConfigMinimizeConflictSet = Flag (MinimizeConflictSet False), + projectConfigStrongFlags = Flag (StrongFlags False), + projectConfigAllowBootLibInstalls = Flag (AllowBootLibInstalls False), + projectConfigOnlyConstrained = Flag OnlyConstrainedNone, + projectConfigIndependentGoals = Flag (IndependentGoals False), + projectConfigPreferOldest = Flag (PreferOldest False) + --projectConfigShadowPkgs = Flag False, + --projectConfigReinstall = Flag False, + --projectConfigAvoidReinstalls = Flag False, + --projectConfigOverrideReinstall = Flag False, + --projectConfigUpgradeDeps = Flag False + } + + +-- | Resolve the project configuration, with all its optional fields, into +-- 'BuildTimeSettings' with no optional fields (by applying defaults). +-- +resolveBuildTimeSettings :: Verbosity + -> CabalDirLayout + -> ProjectConfig + -> BuildTimeSettings +resolveBuildTimeSettings verbosity + CabalDirLayout { + cabalLogsDirectory + } + ProjectConfig { + projectConfigShared = ProjectConfigShared { + projectConfigRemoteRepos, + projectConfigLocalNoIndexRepos, + projectConfigProgPathExtra + }, + projectConfigBuildOnly + } = + BuildTimeSettings {..} + where + buildSettingDryRun = fromFlag projectConfigDryRun + buildSettingOnlyDeps = fromFlag projectConfigOnlyDeps + buildSettingOnlyDownload = fromFlag projectConfigOnlyDownload + buildSettingSummaryFile = fromNubList projectConfigSummaryFile + --buildSettingLogFile -- defined below, more complicated + --buildSettingLogVerbosity -- defined below, more complicated + buildSettingBuildReports = fromFlag projectConfigBuildReports + buildSettingSymlinkBinDir = flagToList projectConfigSymlinkBinDir + buildSettingNumJobs = determineNumJobs projectConfigNumJobs + buildSettingKeepGoing = fromFlag projectConfigKeepGoing + buildSettingOfflineMode = fromFlag projectConfigOfflineMode + buildSettingKeepTempFiles = fromFlag projectConfigKeepTempFiles + buildSettingRemoteRepos = fromNubList projectConfigRemoteRepos + buildSettingLocalNoIndexRepos = fromNubList projectConfigLocalNoIndexRepos + buildSettingCacheDir = fromFlag projectConfigCacheDir + buildSettingHttpTransport = flagToMaybe projectConfigHttpTransport + buildSettingIgnoreExpiry = fromFlag projectConfigIgnoreExpiry + buildSettingReportPlanningFailure + = fromFlag projectConfigReportPlanningFailure + buildSettingProgPathExtra = fromNubList projectConfigProgPathExtra + buildSettingHaddockOpen = False + + ProjectConfigBuildOnly{..} = defaults + <> projectConfigBuildOnly + + defaults = mempty { + projectConfigDryRun = toFlag False, + projectConfigOnlyDeps = toFlag False, + projectConfigOnlyDownload = toFlag False, + projectConfigBuildReports = toFlag NoReports, + projectConfigReportPlanningFailure = toFlag False, + projectConfigKeepGoing = toFlag False, + projectConfigOfflineMode = toFlag False, + projectConfigKeepTempFiles = toFlag False, + projectConfigIgnoreExpiry = toFlag False + } + + -- The logging logic: what log file to use and what verbosity. + -- + -- If the user has specified --remote-build-reporting=detailed, use the + -- default log file location. If the --build-log option is set, use the + -- provided location. Otherwise don't use logging, unless building in + -- parallel (in which case the default location is used). + -- + buildSettingLogFile :: Maybe (Compiler -> Platform + -> PackageId -> UnitId -> FilePath) + buildSettingLogFile + | useDefaultTemplate = Just (substLogFileName defaultTemplate) + | otherwise = fmap substLogFileName givenTemplate + + defaultTemplate = toPathTemplate $ + cabalLogsDirectory + "$compiler" "$libname" <.> "log" + givenTemplate = flagToMaybe projectConfigLogFile + + useDefaultTemplate + | buildSettingBuildReports == DetailedReports = True + | isJust givenTemplate = False + | isParallelBuild = True + | otherwise = False + + isParallelBuild = buildSettingNumJobs >= 2 + + substLogFileName :: PathTemplate + -> Compiler -> Platform + -> PackageId -> UnitId -> FilePath + substLogFileName template compiler platform pkgid uid = + fromPathTemplate (substPathTemplate env template) + where + env = initialPathTemplateEnv + pkgid uid (compilerInfo compiler) platform + + -- If the user has specified --remote-build-reporting=detailed or + -- --build-log, use more verbose logging. + -- + buildSettingLogVerbosity :: Verbosity + buildSettingLogVerbosity + | overrideVerbosity = modifyVerbosity (max verbose) verbosity + | otherwise = verbosity + + overrideVerbosity :: Bool + overrideVerbosity + | buildSettingBuildReports == DetailedReports = True + | isJust givenTemplate = True + | isParallelBuild = False + | otherwise = False + + +--------------------------------------------- +-- Reading and writing project config files +-- + +-- | Find the root of this project. +-- +-- Searches for an explicit @cabal.project@ file, in the current directory or +-- parent directories. If no project file is found then the current dir is the +-- project root (and the project will use an implicit config). +-- +findProjectRoot :: Maybe FilePath -- ^ starting directory, or current directory + -> Maybe FilePath -- ^ @cabal.project@ file name override + -> IO (Either BadProjectRoot ProjectRoot) +findProjectRoot _ (Just projectFile) + | isAbsolute projectFile = do + exists <- doesFileExist projectFile + if exists + then do projectFile' <- canonicalizePath projectFile + let projectRoot = ProjectRootExplicit (takeDirectory projectFile') + (takeFileName projectFile') + return (Right projectRoot) + else return (Left (BadProjectRootExplicitFile projectFile)) + +findProjectRoot mstartdir mprojectFile = do + startdir <- maybe getCurrentDirectory canonicalizePath mstartdir + homedir <- getHomeDirectory + probe startdir homedir + where + projectFileName :: String + projectFileName = fromMaybe "cabal.project" mprojectFile + + -- Search upwards. If we get to the users home dir or the filesystem root, + -- then use the current dir + probe :: FilePath -> String -> IO (Either BadProjectRoot ProjectRoot) + probe startdir homedir = go startdir + where + go :: FilePath -> IO (Either BadProjectRoot ProjectRoot) + go dir | isDrive dir || dir == homedir = + case mprojectFile of + Nothing -> return (Right (ProjectRootImplicit startdir)) + Just file -> return (Left (BadProjectRootExplicitFile file)) + go dir = do + exists <- doesFileExist (dir projectFileName) + if exists + then return (Right (ProjectRootExplicit dir projectFileName)) + else go (takeDirectory dir) + +-- | Errors returned by 'findProjectRoot'. +-- +data BadProjectRoot = BadProjectRootExplicitFile FilePath +#if MIN_VERSION_base(4,8,0) + deriving (Show, Typeable) +#else + deriving (Typeable) + +instance Show BadProjectRoot where + show = renderBadProjectRoot +#endif + +instance Exception BadProjectRoot where +#if MIN_VERSION_base(4,8,0) + displayException = renderBadProjectRoot +#endif + +renderBadProjectRoot :: BadProjectRoot -> String +renderBadProjectRoot (BadProjectRootExplicitFile projectFile) = + "The given project file '" ++ projectFile ++ "' does not exist." + +withProjectOrGlobalConfig + :: Verbosity -- ^ verbosity + -> Flag Bool -- ^ whether to ignore local project (--ignore-project flag) + -> Flag FilePath -- ^ @--cabal-config@ + -> IO a -- ^ with project + -> (ProjectConfig -> IO a) -- ^ without projet + -> IO a +withProjectOrGlobalConfig verbosity (Flag True) gcf _with without = do + globalConfig <- runRebuild "" $ readGlobalConfig verbosity gcf + without globalConfig +withProjectOrGlobalConfig verbosity _ignorePrj gcf with without = + withProjectOrGlobalConfig' verbosity gcf with without + +withProjectOrGlobalConfig' + :: Verbosity + -> Flag FilePath + -> IO a + -> (ProjectConfig -> IO a) + -> IO a +withProjectOrGlobalConfig' verbosity globalConfigFlag with without = do + globalConfig <- runRebuild "" $ readGlobalConfig verbosity globalConfigFlag + + let + res' = catch with + $ \case + (BadPackageLocations prov locs) + | prov == Set.singleton Implicit + , let + isGlobErr (BadLocGlobEmptyMatch _) = True + isGlobErr _ = False + , any isGlobErr locs -> + without globalConfig + err -> throwIO err + + catch res' + $ \case + (BadProjectRootExplicitFile "") -> without globalConfig + err -> throwIO err + +-- | Read all the config relevant for a project. This includes the project +-- file if any, plus other global config. +-- +readProjectConfig :: Verbosity + -> HttpTransport + -> Flag Bool -- ^ @--ignore-project@ + -> Flag FilePath + -> DistDirLayout + -> Rebuild ProjectConfigSkeleton +readProjectConfig verbosity httpTransport ignoreProjectFlag configFileFlag distDirLayout = do + global <- singletonProjectConfigSkeleton <$> readGlobalConfig verbosity configFileFlag + local <- readProjectLocalConfigOrDefault verbosity httpTransport distDirLayout + freeze <- readProjectLocalFreezeConfig verbosity httpTransport distDirLayout + extra <- readProjectLocalExtraConfig verbosity httpTransport distDirLayout + if ignoreProjectFlag == Flag True then return (global <> (singletonProjectConfigSkeleton defaultProject)) + else return (global <> local <> freeze <> extra) + where + defaultProject :: ProjectConfig + defaultProject = mempty { + projectPackages = ["./"] + } + +-- | Reads an explicit @cabal.project@ file in the given project root dir, +-- or returns the default project config for an implicitly defined project. +-- +readProjectLocalConfigOrDefault :: Verbosity + -> HttpTransport + -> DistDirLayout + -> Rebuild ProjectConfigSkeleton +readProjectLocalConfigOrDefault verbosity httpTransport distDirLayout = do + usesExplicitProjectRoot <- liftIO $ doesFileExist projectFile + if usesExplicitProjectRoot + then do + readProjectFileSkeleton verbosity httpTransport distDirLayout "" "project file" + else do + monitorFiles [monitorNonExistentFile projectFile] + return (singletonProjectConfigSkeleton defaultImplicitProjectConfig) + + where + projectFile :: FilePath + projectFile = distProjectFile distDirLayout "" + defaultImplicitProjectConfig :: ProjectConfig + defaultImplicitProjectConfig = mempty { + -- We expect a package in the current directory. + projectPackages = [ "./*.cabal" ], + + projectConfigProvenance = Set.singleton Implicit + } + +-- | Reads a @cabal.project.local@ file in the given project root dir, +-- or returns empty. This file gets written by @cabal configure@, or in +-- principle can be edited manually or by other tools. +-- +readProjectLocalExtraConfig :: Verbosity -> HttpTransport -> DistDirLayout + -> Rebuild ProjectConfigSkeleton +readProjectLocalExtraConfig verbosity httpTransport distDirLayout = + readProjectFileSkeleton verbosity httpTransport distDirLayout "local" + "project local configuration file" + +-- | Reads a @cabal.project.freeze@ file in the given project root dir, +-- or returns empty. This file gets written by @cabal freeze@, or in +-- principle can be edited manually or by other tools. +-- +readProjectLocalFreezeConfig :: Verbosity -> HttpTransport ->DistDirLayout + -> Rebuild ProjectConfigSkeleton +readProjectLocalFreezeConfig verbosity httpTransport distDirLayout = + readProjectFileSkeleton verbosity httpTransport distDirLayout "freeze" + "project freeze file" + +-- | Reads a named extended (with imports and conditionals) config file in the given project root dir, or returns empty. +-- +readProjectFileSkeleton :: Verbosity -> HttpTransport -> DistDirLayout -> String -> String -> Rebuild ProjectConfigSkeleton +readProjectFileSkeleton verbosity httpTransport DistDirLayout{distProjectFile, distDownloadSrcDirectory} + extensionName extensionDescription = do + exists <- liftIO $ doesFileExist extensionFile + if exists + then do monitorFiles [monitorFileHashed extensionFile] + pcs <- liftIO readExtensionFile + monitorFiles $ map monitorFileHashed (projectSkeletonImports pcs) + pure pcs + else do monitorFiles [monitorNonExistentFile extensionFile] + return mempty + where + extensionFile = distProjectFile extensionName + + readExtensionFile = + reportParseResult verbosity extensionDescription extensionFile + =<< parseProjectSkeleton distDownloadSrcDirectory httpTransport verbosity [] extensionFile + =<< BS.readFile extensionFile + +-- | Render the 'ProjectConfig' format. +-- +-- For the moment this is implemented in terms of a pretty printer for the +-- legacy configuration types, plus a conversion. +-- +showProjectConfig :: ProjectConfig -> String +showProjectConfig = + showLegacyProjectConfig . convertToLegacyProjectConfig + + +-- | Write a @cabal.project.local@ file in the given project root dir. +-- +writeProjectLocalExtraConfig :: DistDirLayout -> ProjectConfig -> IO () +writeProjectLocalExtraConfig DistDirLayout{distProjectFile} = + writeProjectConfigFile (distProjectFile "local") + + +-- | Write a @cabal.project.freeze@ file in the given project root dir. +-- +writeProjectLocalFreezeConfig :: DistDirLayout -> ProjectConfig -> IO () +writeProjectLocalFreezeConfig DistDirLayout{distProjectFile} = + writeProjectConfigFile (distProjectFile "freeze") + + +-- | Write in the @cabal.project@ format to the given file. +-- +writeProjectConfigFile :: FilePath -> ProjectConfig -> IO () +writeProjectConfigFile file = + writeFile file . showProjectConfig + + +-- | Read the user's @~/.cabal/config@ file. +-- +readGlobalConfig :: Verbosity -> Flag FilePath -> Rebuild ProjectConfig +readGlobalConfig verbosity configFileFlag = do + config <- liftIO (loadConfig verbosity configFileFlag) + configFile <- liftIO (getConfigFilePath configFileFlag) + monitorFiles [monitorFileHashed configFile] + return (convertLegacyGlobalConfig config) + +reportParseResult :: Verbosity -> String -> FilePath -> OldParser.ParseResult ProjectConfigSkeleton -> IO ProjectConfigSkeleton +reportParseResult verbosity _filetype filename (OldParser.ParseOk warnings x) = do + unless (null warnings) $ + let msg = unlines (map (OldParser.showPWarning (intercalate ", " $ filename : projectSkeletonImports x)) warnings) + in warn verbosity msg + return x +reportParseResult verbosity filetype filename (OldParser.ParseFailed err) = + let (line, msg) = OldParser.locatedErrorMsg err + in die' verbosity $ "Error parsing " ++ filetype ++ " " ++ filename + ++ maybe "" (\n -> ':' : show n) line ++ ":\n" ++ msg + + +--------------------------------------------- +-- Finding packages in the project +-- + +-- | The location of a package as part of a project. Local file paths are +-- either absolute (if the user specified it as such) or they are relative +-- to the project root. +-- +data ProjectPackageLocation = + ProjectPackageLocalCabalFile FilePath + | ProjectPackageLocalDirectory FilePath FilePath -- dir and .cabal file + | ProjectPackageLocalTarball FilePath + | ProjectPackageRemoteTarball URI + | ProjectPackageRemoteRepo SourceRepoList + | ProjectPackageNamed PackageVersionConstraint + deriving Show + + +-- | Exception thrown by 'findProjectPackages'. +-- +data BadPackageLocations + = BadPackageLocations (Set ProjectConfigProvenance) [BadPackageLocation] +#if MIN_VERSION_base(4,8,0) + deriving (Show, Typeable) +#else + deriving (Typeable) + +instance Show BadPackageLocations where + show = renderBadPackageLocations +#endif + +instance Exception BadPackageLocations where +#if MIN_VERSION_base(4,8,0) + displayException = renderBadPackageLocations +#endif +--TODO: [nice to have] custom exception subclass for Doc rendering, colour etc + +data BadPackageLocation + = BadPackageLocationFile BadPackageLocationMatch + | BadLocGlobEmptyMatch String + | BadLocGlobBadMatches String [BadPackageLocationMatch] + | BadLocUnexpectedUriScheme String + | BadLocUnrecognisedUri String + | BadLocUnrecognised String + deriving Show + +data BadPackageLocationMatch + = BadLocUnexpectedFile String + | BadLocNonexistantFile String + | BadLocDirNoCabalFile String + | BadLocDirManyCabalFiles String + deriving Show + +renderBadPackageLocations :: BadPackageLocations -> String +renderBadPackageLocations (BadPackageLocations provenance bpls) + -- There is no provenance information, + -- render standard bad package error information. + | Set.null provenance = renderErrors renderBadPackageLocation + + -- The configuration is implicit, render bad package locations + -- using possibly specialized error messages. + | Set.singleton Implicit == provenance = + renderErrors renderImplicitBadPackageLocation + + -- The configuration contains both implicit and explicit provenance. + -- This should not occur, and a message is output to assist debugging. + | Implicit `Set.member` provenance = + "Warning: both implicit and explicit configuration is present." + ++ renderExplicit + + -- The configuration was read from one or more explicit path(s), + -- list the locations and render the bad package error information. + -- The intent is to supersede this with the relevant location information + -- per package error. + | otherwise = renderExplicit + where + renderErrors f = unlines (map f bpls) + + renderExplicit = + "When using configuration(s) from " + ++ intercalate ", " (mapMaybe getExplicit (Set.toList provenance)) + ++ ", the following errors occurred:\n" + ++ renderErrors renderBadPackageLocation + + getExplicit (Explicit path) = Just path + getExplicit Implicit = Nothing + +--TODO: [nice to have] keep track of the config file (and src loc) packages +-- were listed, to use in error messages + +-- | Render bad package location error information for the implicit +-- @cabal.project@ configuration. +-- +-- TODO: This is currently not fully realized, with only one of the implicit +-- cases handled. More cases should be added with informative help text +-- about the issues related specifically when having no project configuration +-- is present. +renderImplicitBadPackageLocation :: BadPackageLocation -> String +renderImplicitBadPackageLocation bpl = case bpl of + BadLocGlobEmptyMatch pkglocstr -> + "No cabal.project file or cabal file matching the default glob '" + ++ pkglocstr ++ "' was found.\n" + ++ "Please create a package description file .cabal " + ++ "or a cabal.project file referencing the packages you " + ++ "want to build." + _ -> renderBadPackageLocation bpl + +renderBadPackageLocation :: BadPackageLocation -> String +renderBadPackageLocation bpl = case bpl of + BadPackageLocationFile badmatch -> + renderBadPackageLocationMatch badmatch + BadLocGlobEmptyMatch pkglocstr -> + "The package location glob '" ++ pkglocstr + ++ "' does not match any files or directories." + BadLocGlobBadMatches pkglocstr failures -> + "The package location glob '" ++ pkglocstr ++ "' does not match any " + ++ "recognised forms of package. " + ++ concatMap ((' ':) . renderBadPackageLocationMatch) failures + BadLocUnexpectedUriScheme pkglocstr -> + "The package location URI '" ++ pkglocstr ++ "' does not use a " + ++ "supported URI scheme. The supported URI schemes are http, https and " + ++ "file." + BadLocUnrecognisedUri pkglocstr -> + "The package location URI '" ++ pkglocstr ++ "' does not appear to " + ++ "be a valid absolute URI." + BadLocUnrecognised pkglocstr -> + "The package location syntax '" ++ pkglocstr ++ "' is not recognised." + +renderBadPackageLocationMatch :: BadPackageLocationMatch -> String +renderBadPackageLocationMatch bplm = case bplm of + BadLocUnexpectedFile pkglocstr -> + "The package location '" ++ pkglocstr ++ "' is not recognised. The " + ++ "supported file targets are .cabal files, .tar.gz tarballs or package " + ++ "directories (i.e. directories containing a .cabal file)." + BadLocNonexistantFile pkglocstr -> + "The package location '" ++ pkglocstr ++ "' does not exist." + BadLocDirNoCabalFile pkglocstr -> + "The package directory '" ++ pkglocstr ++ "' does not contain any " + ++ ".cabal file." + BadLocDirManyCabalFiles pkglocstr -> + "The package directory '" ++ pkglocstr ++ "' contains multiple " + ++ ".cabal files (which is not currently supported)." + +-- | Given the project config, +-- +-- Throws 'BadPackageLocations'. +-- +findProjectPackages :: DistDirLayout -> ProjectConfig + -> Rebuild [ProjectPackageLocation] +findProjectPackages DistDirLayout{distProjectRootDirectory} + ProjectConfig{..} = do + + requiredPkgs <- findPackageLocations True projectPackages + optionalPkgs <- findPackageLocations False projectPackagesOptional + let repoPkgs = map ProjectPackageRemoteRepo projectPackagesRepo + namedPkgs = map ProjectPackageNamed projectPackagesNamed + + return (concat [requiredPkgs, optionalPkgs, repoPkgs, namedPkgs]) + where + findPackageLocations :: Bool -> [String] -> Rebuild [ProjectPackageLocation] + findPackageLocations required pkglocstr = do + (problems, pkglocs) <- + partitionEithers <$> traverse (findPackageLocation required) pkglocstr + unless (null problems) $ + liftIO $ throwIO $ BadPackageLocations projectConfigProvenance problems + return (concat pkglocs) + + + findPackageLocation :: Bool -> String + -> Rebuild (Either BadPackageLocation + [ProjectPackageLocation]) + findPackageLocation _required@True pkglocstr = + -- strategy: try first as a file:// or http(s):// URL. + -- then as a file glob (usually encompassing single file) + -- finally as a single file, for files that fail to parse as globs + checkIsUriPackage pkglocstr + `mplusMaybeT` checkIsFileGlobPackage pkglocstr + `mplusMaybeT` checkIsSingleFilePackage pkglocstr + >>= maybe (return (Left (BadLocUnrecognised pkglocstr))) return + + + findPackageLocation _required@False pkglocstr = do + -- just globs for optional case + res <- checkIsFileGlobPackage pkglocstr + case res of + Nothing -> return (Left (BadLocUnrecognised pkglocstr)) + Just (Left _) -> return (Right []) -- it's optional + Just (Right pkglocs) -> return (Right pkglocs) + + + checkIsUriPackage, checkIsFileGlobPackage, checkIsSingleFilePackage + :: String -> Rebuild (Maybe (Either BadPackageLocation + [ProjectPackageLocation])) + checkIsUriPackage pkglocstr = + case parseAbsoluteURI pkglocstr of + Just uri@URI { + uriScheme = scheme, + uriAuthority = Just URIAuth { uriRegName = host }, + uriPath = path, + uriQuery = query, + uriFragment = frag + } + | recognisedScheme && not (null host) -> + return (Just (Right [ProjectPackageRemoteTarball uri])) + + | scheme == "file:" && null host && null query && null frag -> + checkIsSingleFilePackage path + + | not recognisedScheme && not (null host) -> + return (Just (Left (BadLocUnexpectedUriScheme pkglocstr))) + + | recognisedScheme && null host -> + return (Just (Left (BadLocUnrecognisedUri pkglocstr))) + where + recognisedScheme = scheme == "http:" || scheme == "https:" + || scheme == "file:" + + _ -> return Nothing + + + checkIsFileGlobPackage pkglocstr = + case simpleParsec pkglocstr of + Nothing -> return Nothing + Just glob -> liftM Just $ do + matches <- matchFileGlob glob + case matches of + [] | isJust (isTrivialFilePathGlob glob) + -> return (Left (BadPackageLocationFile + (BadLocNonexistantFile pkglocstr))) + + [] -> return (Left (BadLocGlobEmptyMatch pkglocstr)) + + _ -> do + (failures, pkglocs) <- partitionEithers <$> + traverse checkFilePackageMatch matches + return $! case (failures, pkglocs) of + ([failure], []) | isJust (isTrivialFilePathGlob glob) + -> Left (BadPackageLocationFile failure) + (_, []) -> Left (BadLocGlobBadMatches pkglocstr failures) + _ -> Right pkglocs + + + checkIsSingleFilePackage pkglocstr = do + let filename = distProjectRootDirectory pkglocstr + isFile <- liftIO $ doesFileExist filename + isDir <- liftIO $ doesDirectoryExist filename + if isFile || isDir + then checkFilePackageMatch pkglocstr + >>= either (return . Just . Left . BadPackageLocationFile) + (return . Just . Right . (\x->[x])) + else return Nothing + + + checkFilePackageMatch :: String -> Rebuild (Either BadPackageLocationMatch + ProjectPackageLocation) + checkFilePackageMatch pkglocstr = do + -- The pkglocstr may be absolute or may be relative to the project root. + -- Either way, does the right thing here. We return relative paths if + -- they were relative in the first place. + let abspath = distProjectRootDirectory pkglocstr + isFile <- liftIO $ doesFileExist abspath + isDir <- liftIO $ doesDirectoryExist abspath + parentDirExists <- case takeDirectory abspath of + [] -> return False + dir -> liftIO $ doesDirectoryExist dir + case () of + _ | isDir + -> do matches <- matchFileGlob (globStarDotCabal pkglocstr) + case matches of + [cabalFile] + -> return (Right (ProjectPackageLocalDirectory + pkglocstr cabalFile)) + [] -> return (Left (BadLocDirNoCabalFile pkglocstr)) + _ -> return (Left (BadLocDirManyCabalFiles pkglocstr)) + + | extensionIsTarGz pkglocstr + -> return (Right (ProjectPackageLocalTarball pkglocstr)) + + | takeExtension pkglocstr == ".cabal" + -> return (Right (ProjectPackageLocalCabalFile pkglocstr)) + + | isFile + -> return (Left (BadLocUnexpectedFile pkglocstr)) + + | parentDirExists + -> return (Left (BadLocNonexistantFile pkglocstr)) + + | otherwise + -> return (Left (BadLocUnexpectedFile pkglocstr)) + + + extensionIsTarGz f = takeExtension f == ".gz" + && takeExtension (dropExtension f) == ".tar" + + +-- | A glob to find all the cabal files in a directory. +-- +-- For a directory @some/dir/@, this is a glob of the form @some/dir/\*.cabal@. +-- The directory part can be either absolute or relative. +-- +globStarDotCabal :: FilePath -> FilePathGlob +globStarDotCabal dir = + FilePathGlob + (if isAbsolute dir then FilePathRoot root else FilePathRelative) + (foldr (\d -> GlobDir [Literal d]) + (GlobFile [WildCard, Literal ".cabal"]) dirComponents) + where + (root, dirComponents) = fmap splitDirectories (splitDrive dir) + + +--TODO: [code cleanup] use sufficiently recent transformers package +mplusMaybeT :: Monad m => m (Maybe a) -> m (Maybe a) -> m (Maybe a) +mplusMaybeT ma mb = do + mx <- ma + case mx of + Nothing -> mb + Just x -> return (Just x) + + +------------------------------------------------- +-- Fetching and reading packages in the project +-- + +-- | Read the @.cabal@ files for a set of packages. For remote tarballs and +-- VCS source repos this also fetches them if needed. +-- +-- Note here is where we convert from project-root relative paths to absolute +-- paths. +-- +fetchAndReadSourcePackages + :: Verbosity + -> DistDirLayout + -> ProjectConfigShared + -> ProjectConfigBuildOnly + -> [ProjectPackageLocation] + -> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)] +fetchAndReadSourcePackages verbosity distDirLayout + projectConfigShared + projectConfigBuildOnly + pkgLocations = do + + pkgsLocalDirectory <- + sequenceA + [ readSourcePackageLocalDirectory verbosity dir cabalFile + | location <- pkgLocations + , (dir, cabalFile) <- projectPackageLocal location ] + + pkgsLocalTarball <- + sequenceA + [ readSourcePackageLocalTarball verbosity path + | ProjectPackageLocalTarball path <- pkgLocations ] + + pkgsRemoteTarball <- do + getTransport <- delayInitSharedResource $ + configureTransport verbosity progPathExtra + preferredHttpTransport + sequenceA + [ fetchAndReadSourcePackageRemoteTarball verbosity distDirLayout + getTransport uri + | ProjectPackageRemoteTarball uri <- pkgLocations ] + + pkgsRemoteRepo <- + syncAndReadSourcePackagesRemoteRepos + verbosity distDirLayout + projectConfigShared + [ repo | ProjectPackageRemoteRepo repo <- pkgLocations ] + + let pkgsNamed = + [ NamedPackage pkgname [PackagePropertyVersion verrange] + | ProjectPackageNamed (PackageVersionConstraint pkgname verrange) <- pkgLocations ] + + return $ concat + [ pkgsLocalDirectory + , pkgsLocalTarball + , pkgsRemoteTarball + , pkgsRemoteRepo + , pkgsNamed + ] + where + projectPackageLocal (ProjectPackageLocalDirectory dir file) = [(dir, file)] + projectPackageLocal (ProjectPackageLocalCabalFile file) = [(dir, file)] + where dir = takeDirectory file + projectPackageLocal _ = [] + + progPathExtra = fromNubList (projectConfigProgPathExtra projectConfigShared) + preferredHttpTransport = + flagToMaybe (projectConfigHttpTransport projectConfigBuildOnly) + +-- | A helper for 'fetchAndReadSourcePackages' to handle the case of +-- 'ProjectPackageLocalDirectory' and 'ProjectPackageLocalCabalFile'. +-- We simply read the @.cabal@ file. +-- +readSourcePackageLocalDirectory + :: Verbosity + -> FilePath -- ^ The package directory + -> FilePath -- ^ The package @.cabal@ file + -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc)) +readSourcePackageLocalDirectory verbosity dir cabalFile = do + monitorFiles [monitorFileHashed cabalFile] + root <- askRoot + let location = LocalUnpackedPackage (root dir) + liftIO $ fmap (mkSpecificSourcePackage location) + . readSourcePackageCabalFile verbosity cabalFile + =<< BS.readFile (root cabalFile) + + +-- | A helper for 'fetchAndReadSourcePackages' to handle the case of +-- 'ProjectPackageLocalTarball'. We scan through the @.tar.gz@ file to find +-- the @.cabal@ file and read that. +-- +readSourcePackageLocalTarball + :: Verbosity + -> FilePath + -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc)) +readSourcePackageLocalTarball verbosity tarballFile = do + monitorFiles [monitorFile tarballFile] + root <- askRoot + let location = LocalTarballPackage (root tarballFile) + liftIO $ fmap (mkSpecificSourcePackage location) + . uncurry (readSourcePackageCabalFile verbosity) + =<< extractTarballPackageCabalFile (root tarballFile) + +-- | A helper for 'fetchAndReadSourcePackages' to handle the case of +-- 'ProjectPackageRemoteTarball'. We download the tarball to the dist src dir +-- and after that handle it like the local tarball case. +-- +fetchAndReadSourcePackageRemoteTarball + :: Verbosity + -> DistDirLayout + -> Rebuild HttpTransport + -> URI + -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc)) +fetchAndReadSourcePackageRemoteTarball verbosity + DistDirLayout { + distDownloadSrcDirectory + } + getTransport + tarballUri = + -- The tarball download is expensive so we use another layer of file + -- monitor to avoid it whenever possible. + rerunIfChanged verbosity monitor tarballUri $ do + + -- Download + transport <- getTransport + liftIO $ do + transportCheckHttps verbosity transport tarballUri + notice verbosity ("Downloading " ++ show tarballUri) + createDirectoryIfMissingVerbose verbosity True + distDownloadSrcDirectory + _ <- downloadURI transport verbosity tarballUri tarballFile + return () + + -- Read + monitorFiles [monitorFile tarballFile] + let location = RemoteTarballPackage tarballUri tarballFile + liftIO $ fmap (mkSpecificSourcePackage location) + . uncurry (readSourcePackageCabalFile verbosity) + =<< extractTarballPackageCabalFile tarballFile + where + tarballStem :: FilePath + tarballStem = distDownloadSrcDirectory + localFileNameForRemoteTarball tarballUri + tarballFile :: FilePath + tarballFile = tarballStem <.> "tar.gz" + + monitor :: FileMonitor URI (PackageSpecifier (SourcePackage UnresolvedPkgLoc)) + monitor = newFileMonitor (tarballStem <.> "cache") + + +-- | A helper for 'fetchAndReadSourcePackages' to handle all the cases of +-- 'ProjectPackageRemoteRepo'. +-- +syncAndReadSourcePackagesRemoteRepos + :: Verbosity + -> DistDirLayout + -> ProjectConfigShared + -> [SourceRepoList] + -> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)] +syncAndReadSourcePackagesRemoteRepos verbosity + DistDirLayout{distDownloadSrcDirectory} + ProjectConfigShared { + projectConfigProgPathExtra + } + repos = do + + repos' <- either reportSourceRepoProblems return $ + validateSourceRepos repos + + -- All 'SourceRepo's grouped by referring to the "same" remote repo + -- instance. So same location but can differ in commit/tag/branch/subdir. + let reposByLocation :: Map (RepoType, String) + [(SourceRepoList, RepoType)] + reposByLocation = Map.fromListWith (++) + [ ((rtype, rloc), [(repo, vcsRepoType vcs)]) + | (repo, rloc, rtype, vcs) <- repos' ] + + --TODO: pass progPathExtra on to 'configureVCS' + let _progPathExtra = fromNubList projectConfigProgPathExtra + getConfiguredVCS <- delayInitSharedResources $ \repoType -> + let vcs = Map.findWithDefault (error $ "Unknown VCS: " ++ prettyShow repoType) repoType knownVCSs in + configureVCS verbosity {-progPathExtra-} vcs + + concat <$> sequenceA + [ rerunIfChanged verbosity monitor repoGroup' $ do + vcs' <- getConfiguredVCS repoType + syncRepoGroupAndReadSourcePackages vcs' pathStem repoGroup' + | repoGroup@((primaryRepo, repoType):_) <- Map.elems reposByLocation + , let repoGroup' = map fst repoGroup + pathStem = distDownloadSrcDirectory + localFileNameForRemoteRepo primaryRepo + monitor :: FileMonitor + [SourceRepoList] + [PackageSpecifier (SourcePackage UnresolvedPkgLoc)] + monitor = newFileMonitor (pathStem <.> "cache") + ] + where + syncRepoGroupAndReadSourcePackages + :: VCS ConfiguredProgram + -> FilePath + -> [SourceRepoList] + -> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)] + syncRepoGroupAndReadSourcePackages vcs pathStem repoGroup = do + liftIO $ createDirectoryIfMissingVerbose verbosity False + distDownloadSrcDirectory + + -- For syncing we don't care about different 'SourceRepo' values that + -- are just different subdirs in the same repo. + syncSourceRepos verbosity vcs + [ (repo, repoPath) + | (repo, _, repoPath) <- repoGroupWithPaths ] + + -- Run post-checkout-command if it is specified + for_ repoGroupWithPaths $ \(repo, _, repoPath) -> + for_ (nonEmpty (srpCommand repo)) $ \(cmd :| args) -> liftIO $ do + exitCode <- rawSystemIOWithEnv verbosity cmd args (Just repoPath) Nothing Nothing Nothing Nothing + unless (exitCode == ExitSuccess) $ exitWith exitCode + + -- But for reading we go through each 'SourceRepo' including its subdir + -- value and have to know which path each one ended up in. + sequenceA + [ readPackageFromSourceRepo repoWithSubdir repoPath + | (_, reposWithSubdir, repoPath) <- repoGroupWithPaths + , repoWithSubdir <- NE.toList reposWithSubdir ] + where + -- So to do both things above, we pair them up here. + repoGroupWithPaths + :: [(SourceRepositoryPackage Proxy, NonEmpty (SourceRepositoryPackage Maybe), FilePath)] + repoGroupWithPaths = + zipWith (\(x, y) z -> (x,y,z)) + (mapGroup + [ (repo { srpSubdir = Proxy }, repo) + | repo <- foldMap (NE.toList . srpFanOut) repoGroup + ]) + repoPaths + + mapGroup :: Ord k => [(k, v)] -> [(k, NonEmpty v)] + mapGroup = Map.toList . Map.fromListWith (<>) . map (\(k, v) -> (k, pure v)) + + -- The repos in a group are given distinct names by simple enumeration + -- foo, foo-2, foo-3 etc + repoPaths :: [FilePath] + repoPaths = pathStem + : [ pathStem ++ "-" ++ show (i :: Int) | i <- [2..] ] + + readPackageFromSourceRepo + :: SourceRepositoryPackage Maybe + -> FilePath + -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc)) + readPackageFromSourceRepo repo repoPath = do + let packageDir :: FilePath + packageDir = maybe repoPath (repoPath ) (srpSubdir repo) + + entries <- liftIO $ getDirectoryContents packageDir + --TODO: dcoutts 2018-06-23: wrap exceptions + case filter (\e -> takeExtension e == ".cabal") entries of + [] -> liftIO $ throwIO $ NoCabalFileFound packageDir + (_:_:_) -> liftIO $ throwIO $ MultipleCabalFilesFound packageDir + [cabalFileName] -> do + let cabalFilePath = packageDir cabalFileName + monitorFiles [monitorFileHashed cabalFilePath] + gpd <- liftIO $ readSourcePackageCabalFile verbosity cabalFilePath =<< BS.readFile cabalFilePath + + -- write sdist tarball, to repoPath-pgkid + tarball <- liftIO $ packageDirToSdist verbosity gpd packageDir + let tarballPath = repoPath ++ "-" ++ prettyShow (packageId gpd) ++ ".tar.gz" + liftIO $ LBS.writeFile tarballPath tarball + + let location = RemoteSourceRepoPackage repo tarballPath + return $ mkSpecificSourcePackage location gpd + + reportSourceRepoProblems :: [(SourceRepoList, SourceRepoProblem)] -> Rebuild a + reportSourceRepoProblems = liftIO . die' verbosity . renderSourceRepoProblems + + renderSourceRepoProblems :: [(SourceRepoList, SourceRepoProblem)] -> String + renderSourceRepoProblems = unlines . map show -- "TODO: the repo problems" + + +-- | Utility used by all the helpers of 'fetchAndReadSourcePackages' to make an +-- appropriate @'PackageSpecifier' ('SourcePackage' (..))@ for a given package +-- from a given location. +-- +mkSpecificSourcePackage :: PackageLocation FilePath + -> GenericPackageDescription + -> PackageSpecifier (SourcePackage UnresolvedPkgLoc) +mkSpecificSourcePackage location pkg = + SpecificSourcePackage SourcePackage + { srcpkgPackageId = packageId pkg + , srcpkgDescription = pkg + , srcpkgSource = fmap Just location + , srcpkgDescrOverride = Nothing + } + + +-- | Errors reported upon failing to parse a @.cabal@ file. +-- +data CabalFileParseError = CabalFileParseError + FilePath -- ^ @.cabal@ file path + BS.ByteString -- ^ @.cabal@ file contents + (NonEmpty PError) -- ^ errors + (Maybe Version) -- ^ We might discover the spec version the package needs + [PWarning] -- ^ warnings + deriving (Typeable) + +-- | Manual instance which skips file contents +instance Show CabalFileParseError where + showsPrec d (CabalFileParseError fp _ es mv ws) = showParen (d > 10) + $ showString "CabalFileParseError" + . showChar ' ' . showsPrec 11 fp + . showChar ' ' . showsPrec 11 ("" :: String) + . showChar ' ' . showsPrec 11 es + . showChar ' ' . showsPrec 11 mv + . showChar ' ' . showsPrec 11 ws + +instance Exception CabalFileParseError +#if MIN_VERSION_base(4,8,0) + where + displayException = renderCabalFileParseError +#endif + +renderCabalFileParseError :: CabalFileParseError -> String +renderCabalFileParseError (CabalFileParseError filePath contents errors _ warnings) = + renderParseError filePath contents errors warnings + +-- | Wrapper for the @.cabal@ file parser. It reports warnings on higher +-- verbosity levels and throws 'CabalFileParseError' on failure. +-- +readSourcePackageCabalFile :: Verbosity + -> FilePath + -> BS.ByteString + -> IO GenericPackageDescription +readSourcePackageCabalFile verbosity pkgfilename content = + case runParseResult (parseGenericPackageDescription content) of + (warnings, Right pkg) -> do + unless (null warnings) $ + info verbosity (formatWarnings warnings) + return pkg + + (warnings, Left (mspecVersion, errors)) -> + throwIO $ CabalFileParseError pkgfilename content errors mspecVersion warnings + where + formatWarnings warnings = + "The package description file " ++ pkgfilename + ++ " has warnings: " + ++ unlines (map (showPWarning pkgfilename) warnings) + + +-- | When looking for a package's @.cabal@ file we can find none, or several, +-- both of which are failures. +-- +data CabalFileSearchFailure + = NoCabalFileFound FilePath + | MultipleCabalFilesFound FilePath + deriving (Show, Typeable) + +instance Exception CabalFileSearchFailure + + +-- | Find the @.cabal@ file within a tarball file and return it by value. +-- +-- Can fail with a 'Tar.FormatError' or 'CabalFileSearchFailure' exception. +-- +extractTarballPackageCabalFile :: FilePath -> IO (FilePath, BS.ByteString) +extractTarballPackageCabalFile tarballFile = + withBinaryFile tarballFile ReadMode $ \hnd -> do + content <- LBS.hGetContents hnd + case extractTarballPackageCabalFilePure tarballFile content of + Left (Left e) -> throwIO e + Left (Right e) -> throwIO e + Right (fileName, fileContent) -> + (,) fileName <$> evaluate (LBS.toStrict fileContent) + + +-- | Scan through a tar file stream and collect the @.cabal@ file, or fail. +-- +extractTarballPackageCabalFilePure :: FilePath + -> LBS.ByteString + -> Either (Either Tar.FormatError + CabalFileSearchFailure) + (FilePath, LBS.ByteString) +extractTarballPackageCabalFilePure tarballFile = + check + . accumEntryMap + . Tar.filterEntries isCabalFile + . Tar.read + . GZipUtils.maybeDecompress + where + accumEntryMap = Tar.foldlEntries + (\m e -> Map.insert (Tar.entryTarPath e) e m) + Map.empty + + check (Left (e, _m)) = Left (Left e) + check (Right m) = case Map.elems m of + [] -> Left (Right $ NoCabalFileFound tarballFile) + [file] -> case Tar.entryContent file of + Tar.NormalFile content _ -> Right (Tar.entryPath file, content) + _ -> Left (Right $ NoCabalFileFound tarballFile) + _files -> Left (Right $ MultipleCabalFilesFound tarballFile) + + isCabalFile e = case splitPath (Tar.entryPath e) of + [ _dir, file] -> takeExtension file == ".cabal" + [".", _dir, file] -> takeExtension file == ".cabal" + _ -> False + + +-- | The name to use for a local file for a remote tarball 'SourceRepo'. +-- This is deterministic based on the remote tarball URI, and is intended +-- to produce non-clashing file names for different tarballs. +-- +localFileNameForRemoteTarball :: URI -> FilePath +localFileNameForRemoteTarball uri = + mangleName uri + ++ "-" ++ showHex locationHash "" + where + mangleName = truncateString 10 . dropExtension . dropExtension + . takeFileName . dropTrailingPathSeparator . uriPath + + locationHash :: Word + locationHash = fromIntegral (Hashable.hash (uriToString id uri "")) + + +-- | The name to use for a local file or dir for a remote 'SourceRepo'. +-- This is deterministic based on the source repo identity details, and +-- intended to produce non-clashing file names for different repos. +-- +localFileNameForRemoteRepo :: SourceRepoList -> FilePath +localFileNameForRemoteRepo SourceRepositoryPackage {srpType, srpLocation} = + mangleName srpLocation ++ "-" ++ showHex locationHash "" + where + mangleName = truncateString 10 . dropExtension + . takeFileName . dropTrailingPathSeparator + + -- just the parts that make up the "identity" of the repo + locationHash :: Word + locationHash = + fromIntegral (Hashable.hash (show srpType, srpLocation)) + + +-- | Truncate a string, with a visual indication that it is truncated. +truncateString :: Int -> String -> String +truncateString n s | length s <= n = s + | otherwise = take (n-1) s ++ "_" + + +-- TODO: add something like this, here or in the project planning +-- Based on the package location, which packages will be built inplace in the +-- build tree vs placed in the store. This has various implications on what we +-- can do with the package, e.g. can we run tests, ghci etc. +-- +-- packageIsLocalToProject :: ProjectPackageLocation -> Bool + + +--------------------------------------------- +-- Checking configuration sanity +-- + +data BadPerPackageCompilerPaths + = BadPerPackageCompilerPaths [(PackageName, String)] +#if MIN_VERSION_base(4,8,0) + deriving (Show, Typeable) +#else + deriving (Typeable) + +instance Show BadPerPackageCompilerPaths where + show = renderBadPerPackageCompilerPaths +#endif + +instance Exception BadPerPackageCompilerPaths where +#if MIN_VERSION_base(4,8,0) + displayException = renderBadPerPackageCompilerPaths +#endif +--TODO: [nice to have] custom exception subclass for Doc rendering, colour etc + +renderBadPerPackageCompilerPaths :: BadPerPackageCompilerPaths -> String +renderBadPerPackageCompilerPaths + (BadPerPackageCompilerPaths ((pkgname, progname) : _)) = + "The path to the compiler program (or programs used by the compiler) " + ++ "cannot be specified on a per-package basis in the cabal.project file " + ++ "(i.e. setting the '" ++ progname ++ "-location' for package '" + ++ prettyShow pkgname ++ "'). All packages have to use the same compiler, so " + ++ "specify the path in a global 'program-locations' section." + --TODO: [nice to have] better format control so we can pretty-print the + -- offending part of the project file. Currently the line wrapping breaks any + -- formatting. +renderBadPerPackageCompilerPaths _ = error "renderBadPerPackageCompilerPaths" + +-- | The project configuration is not allowed to specify program locations for +-- programs used by the compiler as these have to be the same for each set of +-- packages. +-- +-- We cannot check this until we know which programs the compiler uses, which +-- in principle is not until we've configured the compiler. +-- +-- Throws 'BadPerPackageCompilerPaths' +-- +checkBadPerPackageCompilerPaths :: [ConfiguredProgram] + -> Map PackageName PackageConfig + -> IO () +checkBadPerPackageCompilerPaths compilerPrograms packagesConfig = + case [ (pkgname, progname) + | let compProgNames = Set.fromList (map programId compilerPrograms) + , (pkgname, pkgconf) <- Map.toList packagesConfig + , progname <- Map.keys (getMapLast (packageConfigProgramPaths pkgconf)) + , progname `Set.member` compProgNames ] of + [] -> return () + ps -> throwIO (BadPerPackageCompilerPaths ps) diff --git a/cabal/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs b/cabal/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs @@ -0,0 +1,1665 @@ +{-# LANGUAGE RecordWildCards, NamedFieldPuns, DeriveGeneric, ConstraintKinds, FlexibleInstances #-} + +-- | Project configuration, implementation in terms of legacy types. +-- +module Distribution.Client.ProjectConfig.Legacy ( + + -- Project config skeletons + ProjectConfigSkeleton, + parseProjectSkeleton, + instantiateProjectConfigSkeleton, + singletonProjectConfigSkeleton, + projectSkeletonImports, + + -- * Project config in terms of legacy types + LegacyProjectConfig, + parseLegacyProjectConfig, + showLegacyProjectConfig, + + -- * Conversion to and from legacy config types + commandLineFlagsToProjectConfig, + convertLegacyProjectConfig, + convertLegacyGlobalConfig, + convertToLegacyProjectConfig, + + -- * Internals, just for tests + parsePackageLocationTokenQ, + renderPackageLocationToken + ) where + +import Distribution.Client.Compat.Prelude + +import Distribution.Types.Flag (parsecFlagAssignment, FlagName) + +import Distribution.Client.ProjectConfig.Types +import Distribution.Client.Types.RepoName (RepoName (..), unRepoName) +import Distribution.Client.Types.Repo (RemoteRepo(..), LocalRepo (..), emptyRemoteRepo) +import Distribution.Client.Types.AllowNewer (AllowNewer(..), AllowOlder(..)) +import Distribution.Client.Types.SourceRepo (sourceRepositoryPackageGrammar, SourceRepoList) + +import Distribution.Client.Config + ( SavedConfig(..), remoteRepoFields, postProcessRepo ) + +import Distribution.Client.CmdInstall.ClientInstallFlags + ( ClientInstallFlags(..), defaultClientInstallFlags + , clientInstallOptions ) + +import Distribution.Compat.Lens (view) + +import Distribution.Solver.Types.ConstraintSource + +import Distribution.FieldGrammar +import Distribution.Package +import Distribution.Types.SourceRepo (RepoType) +import Distribution.Types.CondTree + ( CondTree (..), CondBranch (..), mapTreeConds, traverseCondTreeC ) +import Distribution.PackageDescription + ( dispFlagAssignment, Condition (..), ConfVar (..), FlagAssignment ) +import Distribution.PackageDescription.Configuration (simplifyWithSysParams) +import Distribution.Simple.Compiler + ( OptimisationLevel(..), DebugInfoLevel(..), CompilerInfo(..) ) +import Distribution.Simple.InstallDirs ( CopyDest (NoCopyDest) ) +import Distribution.Simple.Setup + ( Flag(..), toFlag, fromFlagOrDefault + , ConfigFlags(..), configureOptions + , HaddockFlags(..), haddockOptions, defaultHaddockFlags + , TestFlags(..), testOptions', defaultTestFlags + , BenchmarkFlags(..), benchmarkOptions', defaultBenchmarkFlags + , programDbPaths', splitArgs, DumpBuildInfo (NoDumpBuildInfo, DumpBuildInfo) + , readPackageDb, showPackageDb + ) +import Distribution.Client.NixStyleOptions (NixStyleFlags (..)) +import Distribution.Client.ProjectFlags (ProjectFlags (..), projectFlagsOptions, defaultProjectFlags) +import Distribution.Client.Setup + ( GlobalFlags(..), globalCommand + , ConfigExFlags(..), configureExOptions, defaultConfigExFlags + , InstallFlags(..), installOptions, defaultInstallFlags ) +import Distribution.Simple.Program + ( programName, knownPrograms ) +import Distribution.Simple.Program.Db + ( ProgramDb, defaultProgramDb ) +import Distribution.Simple.Utils + ( lowercase ) +import Distribution.Utils.NubList + ( toNubList, fromNubList, overNubList ) +import Distribution.Simple.LocalBuildInfo + ( toPathTemplate, fromPathTemplate ) + +import qualified Distribution.Deprecated.ReadP as Parse +import Distribution.Deprecated.ReadP + ( ReadP, (+++) ) +import qualified Text.PrettyPrint as Disp +import Text.PrettyPrint + ( Doc, ($+$) ) +import qualified Distribution.Deprecated.ParseUtils as ParseUtils +import Distribution.Deprecated.ParseUtils + ( ParseResult(..), PError(..), syntaxError, PWarning(..) + , commaNewLineListFieldParsec, newLineListField, parseTokenQ + , parseHaskellString, showToken + , simpleFieldParsec, parseFail + ) +import Distribution.Client.ParseUtils +import Distribution.Simple.Command + ( CommandUI(commandOptions), ShowOrParseArgs(..) + , OptionField, option, reqArg' ) +import Distribution.Types.PackageVersionConstraint + ( PackageVersionConstraint ) +import Distribution.Parsec (ParsecParser, parsecToken) +import Distribution.System (OS, Arch) + +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.ByteString.Char8 as BS + +import Network.URI (URI (..), parseURI) + +import Distribution.Fields.ConfVar (parseConditionConfVarFromClause) + +import Distribution.Client.HttpUtils +import System.FilePath ((), isPathSeparator, makeValid) +import System.Directory (createDirectoryIfMissing) + + + + +------------------------------------------------------------------ +-- Handle extended project config files with conditionals and imports. +-- + +-- | 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 [ProjectConfigImport] ProjectConfig +type ProjectConfigImport = String + + +singletonProjectConfigSkeleton :: ProjectConfig -> ProjectConfigSkeleton +singletonProjectConfigSkeleton x = CondNode x mempty mempty + +instantiateProjectConfigSkeleton :: OS -> Arch -> CompilerInfo -> FlagAssignment -> ProjectConfigSkeleton -> ProjectConfig +instantiateProjectConfigSkeleton os arch impl _flags skel = go $ mapTreeConds (fst . simplifyWithSysParams os arch impl) skel + where + go :: CondTree + FlagName + [ProjectConfigImport] + ProjectConfig + -> ProjectConfig + go (CondNode l _imps ts) = + let branches = concatMap processBranch ts + in l <> mconcat branches + processBranch (CondBranch cnd t mf) = case cnd of + (Lit True) -> [go t] + (Lit False) -> maybe ([]) ((:[]) . go) mf + _ -> error $ "unable to process condition: " ++ show cnd -- TODO it would be nice if there were a pretty printer + +projectSkeletonImports :: ProjectConfigSkeleton -> [ProjectConfigImport] +projectSkeletonImports = view traverseCondTreeC + +parseProjectSkeleton :: FilePath -> HttpTransport -> Verbosity -> [ProjectConfigImport] -> FilePath -> BS.ByteString -> IO (ParseResult ProjectConfigSkeleton) +parseProjectSkeleton cacheDir httpTransport verbosity seenImports source bs = (sanityWalkPCS False =<<) <$> liftPR (go []) (ParseUtils.readFields bs) + where + go :: [ParseUtils.Field] -> [ParseUtils.Field] -> IO (ParseResult ProjectConfigSkeleton) + go acc (x:xs) = case x of + (ParseUtils.F l "import" importLoc) -> + if importLoc `elem` seenImports + then pure . parseFail $ ParseUtils.FromString ("cyclical import of " ++ importLoc) (Just l) + else do + let fs = fmap (\z -> CondNode z [importLoc] mempty) $ fieldsToConfig (reverse acc) + res <- parseProjectSkeleton cacheDir httpTransport verbosity (importLoc : seenImports) importLoc =<< fetchImportConfig importLoc + rest <- go [] xs + pure . fmap mconcat . sequence $ [fs, res, rest] + (ParseUtils.Section l "if" p xs') -> do + subpcs <- go [] xs' + let fs = fmap singletonProjectConfigSkeleton $ fieldsToConfig (reverse acc) + (elseClauses, rest) <- parseElseClauses xs + let condNode = (\c pcs e -> CondNode mempty mempty [CondBranch c pcs e]) <$> + -- we rewrap as as a section so the readFields lexer of the conditional parser doesn't get confused + adaptParseError l (parseConditionConfVarFromClause . BS.pack $ "if(" <> p <> ")") <*> + subpcs <*> + elseClauses + pure . fmap mconcat . sequence $ [fs, condNode, rest] + _ -> go (x:acc) xs + go acc [] = pure . fmap singletonProjectConfigSkeleton . fieldsToConfig $ reverse acc + + parseElseClauses :: [ParseUtils.Field] -> IO (ParseResult (Maybe ProjectConfigSkeleton), ParseResult ProjectConfigSkeleton) + parseElseClauses x = case x of + (ParseUtils.Section _l "else" _p xs':xs) -> do + subpcs <- go [] xs' + rest <- go [] xs + pure (Just <$> subpcs, rest) + (ParseUtils.Section l "elif" p xs':xs) -> do + subpcs <- go [] xs' + (elseClauses, rest) <- parseElseClauses xs + let condNode = (\c pcs e -> CondNode mempty mempty [CondBranch c pcs e]) <$> + adaptParseError l (parseConditionConfVarFromClause . BS.pack $ "else("<> p <> ")") <*> + subpcs <*> + elseClauses + pure (Just <$> condNode, rest) + _ -> (\r -> (pure Nothing,r)) <$> go [] x + + fieldsToConfig xs = fmap (addProvenance . convertLegacyProjectConfig) $ parseLegacyProjectConfigFields source xs + addProvenance x = x {projectConfigProvenance = Set.singleton (Explicit source)} + + adaptParseError _ (Right x) = pure x + adaptParseError l (Left e) = parseFail $ ParseUtils.FromString (show e) (Just l) + + liftPR :: (a -> IO (ParseResult b)) -> ParseResult a -> IO (ParseResult b) + liftPR f (ParseOk ws x) = addWarnings <$> f x + where addWarnings (ParseOk ws' x') = ParseOk (ws' ++ ws) x' + addWarnings x' = x' + liftPR _ (ParseFailed e) = pure $ ParseFailed e + + fetchImportConfig :: ProjectConfigImport -> IO BS.ByteString + fetchImportConfig pci = case parseURI pci of + Just uri -> do + let fp = cacheDir map (\x -> if isPathSeparator x then '_' else x) (makeValid $ show uri) + createDirectoryIfMissing True cacheDir + _ <- downloadURI httpTransport verbosity uri fp + BS.readFile fp + Nothing -> BS.readFile pci + + modifiesCompiler :: ProjectConfig -> Bool + modifiesCompiler pc = isSet projectConfigHcFlavor || isSet projectConfigHcPath || isSet projectConfigHcPkg + where + isSet f = f (projectConfigShared pc) /= NoFlag + + sanityWalkPCS :: Bool -> ProjectConfigSkeleton -> ParseResult ProjectConfigSkeleton + sanityWalkPCS underConditional t@(CondNode d _c comps) + | underConditional && modifiesCompiler d = parseFail $ ParseUtils.FromString "Cannot set compiler in a conditional clause of a cabal project file" Nothing + | otherwise = mapM_ sanityWalkBranch comps >> pure t + + sanityWalkBranch:: CondBranch ConfVar [ProjectConfigImport] ProjectConfig -> ParseResult () + sanityWalkBranch (CondBranch _c t f) = traverse (sanityWalkPCS True) f >> sanityWalkPCS True t >> pure () + +------------------------------------------------------------------ +-- Representing the project config file in terms of legacy types +-- + +-- | We already have parsers\/pretty-printers for almost all the fields in the +-- project config file, but they're in terms of the types used for the command +-- line flags for Setup.hs or cabal commands. We don't want to redefine them +-- all, at least not yet so for the moment we use the parsers at the old types +-- and use conversion functions. +-- +-- Ultimately if\/when this project-based approach becomes the default then we +-- can redefine the parsers directly for the new types. +-- +data LegacyProjectConfig = LegacyProjectConfig { + legacyPackages :: [String], + legacyPackagesOptional :: [String], + legacyPackagesRepo :: [SourceRepoList], + legacyPackagesNamed :: [PackageVersionConstraint], + + legacySharedConfig :: LegacySharedConfig, + legacyAllConfig :: LegacyPackageConfig, + legacyLocalConfig :: LegacyPackageConfig, + legacySpecificConfig :: MapMappend PackageName LegacyPackageConfig + } deriving (Show, Generic) + +instance Monoid LegacyProjectConfig where + mempty = gmempty + mappend = (<>) + +instance Semigroup LegacyProjectConfig where + (<>) = gmappend + +data LegacyPackageConfig = LegacyPackageConfig { + legacyConfigureFlags :: ConfigFlags, + legacyInstallPkgFlags :: InstallFlags, + legacyHaddockFlags :: HaddockFlags, + legacyTestFlags :: TestFlags, + legacyBenchmarkFlags :: BenchmarkFlags + } deriving (Show, Generic) + +instance Monoid LegacyPackageConfig where + mempty = gmempty + mappend = (<>) + +instance Semigroup LegacyPackageConfig where + (<>) = gmappend + +data LegacySharedConfig = LegacySharedConfig { + legacyGlobalFlags :: GlobalFlags, + legacyConfigureShFlags :: ConfigFlags, + legacyConfigureExFlags :: ConfigExFlags, + legacyInstallFlags :: InstallFlags, + legacyClientInstallFlags:: ClientInstallFlags, + legacyProjectFlags :: ProjectFlags + } deriving (Show, Generic) + +instance Monoid LegacySharedConfig where + mempty = gmempty + mappend = (<>) + +instance Semigroup LegacySharedConfig where + (<>) = gmappend + + +------------------------------------------------------------------ +-- Converting from and to the legacy types +-- + +-- | Convert configuration from the @cabal configure@ or @cabal build@ command +-- line into a 'ProjectConfig' value that can combined with configuration from +-- other sources. +-- +-- At the moment this uses the legacy command line flag types. See +-- 'LegacyProjectConfig' for an explanation. +-- +commandLineFlagsToProjectConfig :: GlobalFlags + -> NixStyleFlags a + -> ClientInstallFlags + -> ProjectConfig +commandLineFlagsToProjectConfig globalFlags NixStyleFlags {..} clientInstallFlags = + mempty { + projectConfigBuildOnly = convertLegacyBuildOnlyFlags + globalFlags configFlags + installFlags clientInstallFlags + haddockFlags testFlags benchmarkFlags, + projectConfigShared = convertLegacyAllPackageFlags + globalFlags configFlags + configExFlags installFlags projectFlags, + projectConfigLocalPackages = localConfig, + projectConfigAllPackages = allConfig + } + where (localConfig, allConfig) = splitConfig + (convertLegacyPerPackageFlags + configFlags installFlags + haddockFlags testFlags benchmarkFlags) + -- split the package config (from command line arguments) into + -- those applied to all packages and those to local only. + -- + -- for now we will just copy over the ProgramPaths/Extra into + -- the AllPackages. The LocalPackages do not inherit them from + -- AllPackages, and as such need to retain them. + -- + -- The general decision rule for what to put into allConfig + -- into localConfig is the following: + -- + -- - anything that is host/toolchain/env specific should be applied + -- to all packages, as packagesets have to be host/toolchain/env + -- consistent. + -- - anything else should be in the local config and could potentially + -- be lifted into all-packages vial the `package *` cabal.project + -- section. + -- + splitConfig :: PackageConfig -> (PackageConfig, PackageConfig) + splitConfig pc = (pc + , mempty { packageConfigProgramPaths = packageConfigProgramPaths pc + , packageConfigProgramPathExtra = packageConfigProgramPathExtra pc + + -- Some flags to haddock should be passed to dependencies + , packageConfigDocumentation = packageConfigDocumentation pc + , packageConfigHaddockHoogle = packageConfigHaddockHoogle pc + , packageConfigHaddockHtml = packageConfigHaddockHtml pc + , packageConfigHaddockInternal = packageConfigHaddockInternal pc + , packageConfigHaddockQuickJump = packageConfigHaddockQuickJump pc + , packageConfigHaddockLinkedSource = packageConfigHaddockLinkedSource pc + }) + +-- | Convert from the types currently used for the user-wide @~/.cabal/config@ +-- file into the 'ProjectConfig' type. +-- +-- Only a subset of the 'ProjectConfig' can be represented in the user-wide +-- config. In particular it does not include packages that are in the project, +-- and it also doesn't support package-specific configuration (only +-- configuration that applies to all packages). +-- +convertLegacyGlobalConfig :: SavedConfig -> ProjectConfig +convertLegacyGlobalConfig + SavedConfig { + savedGlobalFlags = globalFlags, + savedInstallFlags = installFlags, + savedClientInstallFlags= clientInstallFlags, + savedConfigureFlags = configFlags, + savedConfigureExFlags = configExFlags, + savedUserInstallDirs = _, + savedGlobalInstallDirs = _, + savedUploadFlags = _, + savedReportFlags = _, + savedHaddockFlags = haddockFlags, + savedTestFlags = testFlags, + savedBenchmarkFlags = benchmarkFlags, + savedProjectFlags = projectFlags + } = + mempty { + projectConfigBuildOnly = configBuildOnly, + projectConfigShared = configShared, + projectConfigAllPackages = configAllPackages + } + where + --TODO: [code cleanup] eliminate use of default*Flags here and specify the + -- defaults in the various resolve functions in terms of the new types. + configExFlags' = defaultConfigExFlags <> configExFlags + installFlags' = defaultInstallFlags <> installFlags + clientInstallFlags' = defaultClientInstallFlags <> clientInstallFlags + haddockFlags' = defaultHaddockFlags <> haddockFlags + testFlags' = defaultTestFlags <> testFlags + benchmarkFlags' = defaultBenchmarkFlags <> benchmarkFlags + projectFlags' = defaultProjectFlags <> projectFlags + + configAllPackages = convertLegacyPerPackageFlags + configFlags installFlags' + haddockFlags' testFlags' benchmarkFlags' + configShared = convertLegacyAllPackageFlags + globalFlags configFlags + configExFlags' installFlags' projectFlags' + configBuildOnly = convertLegacyBuildOnlyFlags + globalFlags configFlags + installFlags' clientInstallFlags' + haddockFlags' testFlags' benchmarkFlags' + + +-- | Convert the project config from the legacy types to the 'ProjectConfig' +-- and associated types. See 'LegacyProjectConfig' for an explanation of the +-- approach. +-- +convertLegacyProjectConfig :: LegacyProjectConfig -> ProjectConfig +convertLegacyProjectConfig + LegacyProjectConfig { + legacyPackages, + legacyPackagesOptional, + legacyPackagesRepo, + legacyPackagesNamed, + legacySharedConfig = LegacySharedConfig globalFlags configShFlags + configExFlags installSharedFlags + clientInstallFlags projectFlags, + legacyAllConfig, + legacyLocalConfig = LegacyPackageConfig configFlags installPerPkgFlags + haddockFlags testFlags benchmarkFlags, + legacySpecificConfig + } = + + ProjectConfig { + projectPackages = legacyPackages, + projectPackagesOptional = legacyPackagesOptional, + projectPackagesRepo = legacyPackagesRepo, + projectPackagesNamed = legacyPackagesNamed, + + projectConfigBuildOnly = configBuildOnly, + projectConfigShared = configPackagesShared, + projectConfigProvenance = mempty, + projectConfigAllPackages = configAllPackages, + projectConfigLocalPackages = configLocalPackages, + projectConfigSpecificPackage = fmap perPackage legacySpecificConfig + } + where + configAllPackages = convertLegacyPerPackageFlags g i h t b + where LegacyPackageConfig g i h t b = legacyAllConfig + configLocalPackages = convertLegacyPerPackageFlags + configFlags installPerPkgFlags haddockFlags + testFlags benchmarkFlags + configPackagesShared= convertLegacyAllPackageFlags + globalFlags (configFlags <> configShFlags) + configExFlags installSharedFlags projectFlags + configBuildOnly = convertLegacyBuildOnlyFlags + globalFlags configShFlags + installSharedFlags clientInstallFlags + haddockFlags testFlags benchmarkFlags + + perPackage (LegacyPackageConfig perPkgConfigFlags perPkgInstallFlags + perPkgHaddockFlags perPkgTestFlags + perPkgBenchmarkFlags) = + convertLegacyPerPackageFlags + perPkgConfigFlags perPkgInstallFlags perPkgHaddockFlags + perPkgTestFlags perPkgBenchmarkFlags + + +-- | Helper used by other conversion functions that returns the +-- 'ProjectConfigShared' subset of the 'ProjectConfig'. +-- +convertLegacyAllPackageFlags + :: GlobalFlags + -> ConfigFlags + -> ConfigExFlags + -> InstallFlags + -> ProjectFlags + -> ProjectConfigShared +convertLegacyAllPackageFlags globalFlags configFlags configExFlags installFlags projectFlags = + ProjectConfigShared{..} + where + GlobalFlags { + globalConfigFile = projectConfigConfigFile, + globalRemoteRepos = projectConfigRemoteRepos, + globalLocalNoIndexRepos = projectConfigLocalNoIndexRepos, + globalActiveRepos = projectConfigActiveRepos, + globalProgPathExtra = projectConfigProgPathExtra, + globalStoreDir = projectConfigStoreDir + } = globalFlags + + ConfigFlags { + configDistPref = projectConfigDistDir, + configHcFlavor = projectConfigHcFlavor, + configHcPath = projectConfigHcPath, + configHcPkg = projectConfigHcPkg, + --configProgramPathExtra = projectConfigProgPathExtra DELETE ME + --configInstallDirs = projectConfigInstallDirs, + --configUserInstall = projectConfigUserInstall, + configPackageDBs = projectConfigPackageDBs + } = configFlags + + ConfigExFlags { + configCabalVersion = projectConfigCabalVersion, + configExConstraints = projectConfigConstraints, + configPreferences = projectConfigPreferences, + configSolver = projectConfigSolver, + configAllowOlder = projectConfigAllowOlder, + configAllowNewer = projectConfigAllowNewer, + configWriteGhcEnvironmentFilesPolicy + = projectConfigWriteGhcEnvironmentFilesPolicy + } = configExFlags + + InstallFlags { + installHaddockIndex = projectConfigHaddockIndex, + --installReinstall = projectConfigReinstall, + --installAvoidReinstalls = projectConfigAvoidReinstalls, + --installOverrideReinstall = projectConfigOverrideReinstall, + installIndexState = projectConfigIndexState, + installMaxBackjumps = projectConfigMaxBackjumps, + --installUpgradeDeps = projectConfigUpgradeDeps, + installReorderGoals = projectConfigReorderGoals, + installCountConflicts = projectConfigCountConflicts, + installFineGrainedConflicts = projectConfigFineGrainedConflicts, + installMinimizeConflictSet = projectConfigMinimizeConflictSet, + installPerComponent = projectConfigPerComponent, + installIndependentGoals = projectConfigIndependentGoals, + installPreferOldest = projectConfigPreferOldest, + --installShadowPkgs = projectConfigShadowPkgs, + installStrongFlags = projectConfigStrongFlags, + installAllowBootLibInstalls = projectConfigAllowBootLibInstalls, + installOnlyConstrained = projectConfigOnlyConstrained + } = installFlags + + ProjectFlags + { flagProjectFileName = projectConfigProjectFile + , flagIgnoreProject = projectConfigIgnoreProject + } = projectFlags + +-- | Helper used by other conversion functions that returns the +-- 'PackageConfig' subset of the 'ProjectConfig'. +-- +convertLegacyPerPackageFlags :: ConfigFlags -> InstallFlags -> HaddockFlags + -> TestFlags -> BenchmarkFlags -> PackageConfig +convertLegacyPerPackageFlags configFlags installFlags + haddockFlags testFlags benchmarkFlags = + PackageConfig{..} + where + ConfigFlags { + configProgramPaths, + configProgramArgs, + configProgramPathExtra = packageConfigProgramPathExtra, + configVanillaLib = packageConfigVanillaLib, + configProfLib = packageConfigProfLib, + configSharedLib = packageConfigSharedLib, + configStaticLib = packageConfigStaticLib, + configDynExe = packageConfigDynExe, + configFullyStaticExe = packageConfigFullyStaticExe, + configProfExe = packageConfigProfExe, + configProf = packageConfigProf, + configProfDetail = packageConfigProfDetail, + configProfLibDetail = packageConfigProfLibDetail, + configConfigureArgs = packageConfigConfigureArgs, + configOptimization = packageConfigOptimization, + configProgPrefix = packageConfigProgPrefix, + configProgSuffix = packageConfigProgSuffix, + configGHCiLib = packageConfigGHCiLib, + configSplitSections = packageConfigSplitSections, + configSplitObjs = packageConfigSplitObjs, + configStripExes = packageConfigStripExes, + configStripLibs = packageConfigStripLibs, + configExtraLibDirs = packageConfigExtraLibDirs, + configExtraLibDirsStatic = packageConfigExtraLibDirsStatic, + configExtraFrameworkDirs = packageConfigExtraFrameworkDirs, + configExtraIncludeDirs = packageConfigExtraIncludeDirs, + configConfigurationsFlags = packageConfigFlagAssignment, + configTests = packageConfigTests, + configBenchmarks = packageConfigBenchmarks, + configCoverage = coverage, + configLibCoverage = libcoverage, --deprecated + configDebugInfo = packageConfigDebugInfo, + configDumpBuildInfo = packageConfigDumpBuildInfo, + configRelocatable = packageConfigRelocatable + } = configFlags + packageConfigProgramPaths = MapLast (Map.fromList configProgramPaths) + packageConfigProgramArgs = MapMappend (Map.fromListWith (++) configProgramArgs) + + packageConfigCoverage = coverage <> libcoverage + --TODO: defer this merging to the resolve phase + + InstallFlags { + installDocumentation = packageConfigDocumentation, + installRunTests = packageConfigRunTests + } = installFlags + + HaddockFlags { + haddockHoogle = packageConfigHaddockHoogle, + haddockHtml = packageConfigHaddockHtml, + haddockHtmlLocation = packageConfigHaddockHtmlLocation, + haddockForeignLibs = packageConfigHaddockForeignLibs, + haddockForHackage = packageConfigHaddockForHackage, + haddockExecutables = packageConfigHaddockExecutables, + haddockTestSuites = packageConfigHaddockTestSuites, + haddockBenchmarks = packageConfigHaddockBenchmarks, + haddockInternal = packageConfigHaddockInternal, + haddockCss = packageConfigHaddockCss, + haddockLinkedSource = packageConfigHaddockLinkedSource, + haddockQuickJump = packageConfigHaddockQuickJump, + haddockHscolourCss = packageConfigHaddockHscolourCss, + haddockContents = packageConfigHaddockContents + } = haddockFlags + + TestFlags { + testHumanLog = packageConfigTestHumanLog, + testMachineLog = packageConfigTestMachineLog, + testShowDetails = packageConfigTestShowDetails, + testKeepTix = packageConfigTestKeepTix, + testWrapper = packageConfigTestWrapper, + testFailWhenNoTestSuites = packageConfigTestFailWhenNoTestSuites, + testOptions = packageConfigTestTestOptions + } = testFlags + + BenchmarkFlags { + benchmarkOptions = packageConfigBenchmarkOptions + } = benchmarkFlags + + +-- | Helper used by other conversion functions that returns the +-- 'ProjectConfigBuildOnly' subset of the 'ProjectConfig'. +-- +convertLegacyBuildOnlyFlags :: GlobalFlags -> ConfigFlags + -> InstallFlags -> ClientInstallFlags + -> HaddockFlags -> TestFlags + -> BenchmarkFlags + -> ProjectConfigBuildOnly +convertLegacyBuildOnlyFlags globalFlags configFlags + installFlags clientInstallFlags + haddockFlags _ _ = + ProjectConfigBuildOnly{..} + where + projectConfigClientInstallFlags = clientInstallFlags + GlobalFlags { + globalCacheDir = projectConfigCacheDir, + globalLogsDir = projectConfigLogsDir, + globalHttpTransport = projectConfigHttpTransport, + globalIgnoreExpiry = projectConfigIgnoreExpiry + } = globalFlags + + ConfigFlags { + configVerbosity = projectConfigVerbosity + } = configFlags + + InstallFlags { + installDryRun = projectConfigDryRun, + installOnlyDownload = projectConfigOnlyDownload, + installOnly = _, + installOnlyDeps = projectConfigOnlyDeps, + installRootCmd = _, + installSummaryFile = projectConfigSummaryFile, + installLogFile = projectConfigLogFile, + installBuildReports = projectConfigBuildReports, + installReportPlanningFailure = projectConfigReportPlanningFailure, + installSymlinkBinDir = projectConfigSymlinkBinDir, + installNumJobs = projectConfigNumJobs, + installKeepGoing = projectConfigKeepGoing, + installOfflineMode = projectConfigOfflineMode + } = installFlags + + HaddockFlags { + haddockKeepTempFiles = projectConfigKeepTempFiles --TODO: this ought to live elsewhere + } = haddockFlags + + +convertToLegacyProjectConfig :: ProjectConfig -> LegacyProjectConfig +convertToLegacyProjectConfig + projectConfig@ProjectConfig { + projectPackages, + projectPackagesOptional, + projectPackagesRepo, + projectPackagesNamed, + projectConfigAllPackages, + projectConfigLocalPackages, + projectConfigSpecificPackage + } = + LegacyProjectConfig { + legacyPackages = projectPackages, + legacyPackagesOptional = projectPackagesOptional, + legacyPackagesRepo = projectPackagesRepo, + legacyPackagesNamed = projectPackagesNamed, + legacySharedConfig = convertToLegacySharedConfig projectConfig, + legacyAllConfig = convertToLegacyPerPackageConfig + projectConfigAllPackages, + legacyLocalConfig = convertToLegacyAllPackageConfig projectConfig + <> convertToLegacyPerPackageConfig + projectConfigLocalPackages, + legacySpecificConfig = fmap convertToLegacyPerPackageConfig + projectConfigSpecificPackage + } + +convertToLegacySharedConfig :: ProjectConfig -> LegacySharedConfig +convertToLegacySharedConfig + ProjectConfig { + projectConfigBuildOnly = ProjectConfigBuildOnly {..}, + projectConfigShared = ProjectConfigShared {..}, + projectConfigAllPackages = PackageConfig { + packageConfigDocumentation + } + } = + + LegacySharedConfig + { legacyGlobalFlags = globalFlags + , legacyConfigureShFlags = configFlags + , legacyConfigureExFlags = configExFlags + , legacyInstallFlags = installFlags + , legacyClientInstallFlags = projectConfigClientInstallFlags + , legacyProjectFlags = projectFlags + } + where + globalFlags = GlobalFlags { + globalVersion = mempty, + globalNumericVersion = mempty, + globalConfigFile = projectConfigConfigFile, + globalConstraintsFile = mempty, + globalRemoteRepos = projectConfigRemoteRepos, + globalCacheDir = projectConfigCacheDir, + globalLocalNoIndexRepos = projectConfigLocalNoIndexRepos, + globalActiveRepos = projectConfigActiveRepos, + globalLogsDir = projectConfigLogsDir, + globalIgnoreExpiry = projectConfigIgnoreExpiry, + globalHttpTransport = projectConfigHttpTransport, + globalNix = mempty, + globalStoreDir = projectConfigStoreDir, + globalProgPathExtra = projectConfigProgPathExtra + } + + configFlags = mempty { + configVerbosity = projectConfigVerbosity, + configDistPref = projectConfigDistDir, + configPackageDBs = projectConfigPackageDBs + } + + configExFlags = ConfigExFlags { + configCabalVersion = projectConfigCabalVersion, + configAppend = mempty, + configBackup = mempty, + configExConstraints = projectConfigConstraints, + configPreferences = projectConfigPreferences, + configSolver = projectConfigSolver, + configAllowOlder = projectConfigAllowOlder, + configAllowNewer = projectConfigAllowNewer, + configWriteGhcEnvironmentFilesPolicy + = projectConfigWriteGhcEnvironmentFilesPolicy + } + + installFlags = InstallFlags { + installDocumentation = packageConfigDocumentation, + installHaddockIndex = projectConfigHaddockIndex, + installDest = Flag NoCopyDest, + installDryRun = projectConfigDryRun, + installOnlyDownload = projectConfigOnlyDownload, + installReinstall = mempty, --projectConfigReinstall, + installAvoidReinstalls = mempty, --projectConfigAvoidReinstalls, + installOverrideReinstall = mempty, --projectConfigOverrideReinstall, + installMaxBackjumps = projectConfigMaxBackjumps, + installUpgradeDeps = mempty, --projectConfigUpgradeDeps, + installReorderGoals = projectConfigReorderGoals, + installCountConflicts = projectConfigCountConflicts, + installFineGrainedConflicts = projectConfigFineGrainedConflicts, + installMinimizeConflictSet = projectConfigMinimizeConflictSet, + installIndependentGoals = projectConfigIndependentGoals, + installPreferOldest = projectConfigPreferOldest, + installShadowPkgs = mempty, --projectConfigShadowPkgs, + installStrongFlags = projectConfigStrongFlags, + installAllowBootLibInstalls = projectConfigAllowBootLibInstalls, + installOnlyConstrained = projectConfigOnlyConstrained, + installOnly = mempty, + installOnlyDeps = projectConfigOnlyDeps, + installIndexState = projectConfigIndexState, + installRootCmd = mempty, --no longer supported + installSummaryFile = projectConfigSummaryFile, + installLogFile = projectConfigLogFile, + installBuildReports = projectConfigBuildReports, + installReportPlanningFailure = projectConfigReportPlanningFailure, + installSymlinkBinDir = projectConfigSymlinkBinDir, + installPerComponent = projectConfigPerComponent, + installNumJobs = projectConfigNumJobs, + installKeepGoing = projectConfigKeepGoing, + installRunTests = mempty, + installOfflineMode = projectConfigOfflineMode + } + + projectFlags = ProjectFlags + { flagProjectFileName = projectConfigProjectFile + , flagIgnoreProject = projectConfigIgnoreProject + } + + +convertToLegacyAllPackageConfig :: ProjectConfig -> LegacyPackageConfig +convertToLegacyAllPackageConfig + ProjectConfig { + projectConfigBuildOnly = ProjectConfigBuildOnly {..}, + projectConfigShared = ProjectConfigShared {..} + } = + + LegacyPackageConfig { + legacyConfigureFlags = configFlags, + legacyInstallPkgFlags= mempty, + legacyHaddockFlags = haddockFlags, + legacyTestFlags = mempty, + legacyBenchmarkFlags = mempty + } + where + configFlags = ConfigFlags { + configArgs = mempty, + configPrograms_ = mempty, + configProgramPaths = mempty, + configProgramArgs = mempty, + configProgramPathExtra = mempty, + configHcFlavor = projectConfigHcFlavor, + configHcPath = projectConfigHcPath, + configHcPkg = projectConfigHcPkg, + configInstantiateWith = mempty, + configVanillaLib = mempty, + configProfLib = mempty, + configSharedLib = mempty, + configStaticLib = mempty, + configDynExe = mempty, + configFullyStaticExe = mempty, + configProfExe = mempty, + configProf = mempty, + configProfDetail = mempty, + configProfLibDetail = mempty, + configConfigureArgs = mempty, + configOptimization = mempty, + configProgPrefix = mempty, + configProgSuffix = mempty, + configInstallDirs = mempty, + configScratchDir = mempty, + configDistPref = mempty, + configCabalFilePath = mempty, + configVerbosity = mempty, + configUserInstall = mempty, --projectConfigUserInstall, + configPackageDBs = mempty, + configGHCiLib = mempty, + configSplitSections = mempty, + configSplitObjs = mempty, + configStripExes = mempty, + configStripLibs = mempty, + configExtraLibDirs = mempty, + configExtraLibDirsStatic = mempty, + configExtraFrameworkDirs = mempty, + configConstraints = mempty, + configDependencies = mempty, + configExtraIncludeDirs = mempty, + configDeterministic = mempty, + configIPID = mempty, + configCID = mempty, + configConfigurationsFlags = mempty, + configTests = mempty, + configCoverage = mempty, --TODO: don't merge + configLibCoverage = mempty, --TODO: don't merge + configExactConfiguration = mempty, + configBenchmarks = mempty, + configFlagError = mempty, --TODO: ??? + configRelocatable = mempty, + configDebugInfo = mempty, + configUseResponseFiles = mempty, + configDumpBuildInfo = mempty, + configAllowDependingOnPrivateLibs = mempty + } + + haddockFlags = mempty { + haddockKeepTempFiles = projectConfigKeepTempFiles + } + + +convertToLegacyPerPackageConfig :: PackageConfig -> LegacyPackageConfig +convertToLegacyPerPackageConfig PackageConfig {..} = + LegacyPackageConfig { + legacyConfigureFlags = configFlags, + legacyInstallPkgFlags = installFlags, + legacyHaddockFlags = haddockFlags, + legacyTestFlags = testFlags, + legacyBenchmarkFlags = benchmarkFlags + } + where + configFlags = ConfigFlags { + configArgs = mempty, + configPrograms_ = configPrograms_ mempty, + configProgramPaths = Map.toList (getMapLast packageConfigProgramPaths), + configProgramArgs = Map.toList (getMapMappend packageConfigProgramArgs), + configProgramPathExtra = packageConfigProgramPathExtra, + configHcFlavor = mempty, + configHcPath = mempty, + configHcPkg = mempty, + configInstantiateWith = mempty, + configVanillaLib = packageConfigVanillaLib, + configProfLib = packageConfigProfLib, + configSharedLib = packageConfigSharedLib, + configStaticLib = packageConfigStaticLib, + configDynExe = packageConfigDynExe, + configFullyStaticExe = packageConfigFullyStaticExe, + configProfExe = packageConfigProfExe, + configProf = packageConfigProf, + configProfDetail = packageConfigProfDetail, + configProfLibDetail = packageConfigProfLibDetail, + configConfigureArgs = packageConfigConfigureArgs, + configOptimization = packageConfigOptimization, + configProgPrefix = packageConfigProgPrefix, + configProgSuffix = packageConfigProgSuffix, + configInstallDirs = mempty, + configScratchDir = mempty, + configDistPref = mempty, + configCabalFilePath = mempty, + configVerbosity = mempty, + configUserInstall = mempty, + configPackageDBs = mempty, + configGHCiLib = packageConfigGHCiLib, + configSplitSections = packageConfigSplitSections, + configSplitObjs = packageConfigSplitObjs, + configStripExes = packageConfigStripExes, + configStripLibs = packageConfigStripLibs, + configExtraLibDirs = packageConfigExtraLibDirs, + configExtraLibDirsStatic = packageConfigExtraLibDirsStatic, + configExtraFrameworkDirs = packageConfigExtraFrameworkDirs, + configConstraints = mempty, + configDependencies = mempty, + configExtraIncludeDirs = packageConfigExtraIncludeDirs, + configIPID = mempty, + configCID = mempty, + configDeterministic = mempty, + configConfigurationsFlags = packageConfigFlagAssignment, + configTests = packageConfigTests, + configCoverage = packageConfigCoverage, --TODO: don't merge + configLibCoverage = packageConfigCoverage, --TODO: don't merge + configExactConfiguration = mempty, + configBenchmarks = packageConfigBenchmarks, + configFlagError = mempty, --TODO: ??? + configRelocatable = packageConfigRelocatable, + configDebugInfo = packageConfigDebugInfo, + configUseResponseFiles = mempty, + configDumpBuildInfo = packageConfigDumpBuildInfo, + configAllowDependingOnPrivateLibs = mempty + } + + installFlags = mempty { + installDocumentation = packageConfigDocumentation, + installRunTests = packageConfigRunTests + } + + haddockFlags = HaddockFlags { + haddockProgramPaths = mempty, + haddockProgramArgs = mempty, + haddockHoogle = packageConfigHaddockHoogle, + haddockHtml = packageConfigHaddockHtml, + haddockHtmlLocation = packageConfigHaddockHtmlLocation, + haddockForHackage = packageConfigHaddockForHackage, + haddockForeignLibs = packageConfigHaddockForeignLibs, + haddockExecutables = packageConfigHaddockExecutables, + haddockTestSuites = packageConfigHaddockTestSuites, + haddockBenchmarks = packageConfigHaddockBenchmarks, + haddockInternal = packageConfigHaddockInternal, + haddockCss = packageConfigHaddockCss, + haddockLinkedSource = packageConfigHaddockLinkedSource, + haddockQuickJump = packageConfigHaddockQuickJump, + haddockHscolourCss = packageConfigHaddockHscolourCss, + haddockContents = packageConfigHaddockContents, + haddockDistPref = mempty, + haddockKeepTempFiles = mempty, + haddockVerbosity = mempty, + haddockCabalFilePath = mempty, + haddockArgs = mempty + } + + testFlags = TestFlags { + testDistPref = mempty, + testVerbosity = mempty, + testHumanLog = packageConfigTestHumanLog, + testMachineLog = packageConfigTestMachineLog, + testShowDetails = packageConfigTestShowDetails, + testKeepTix = packageConfigTestKeepTix, + testWrapper = packageConfigTestWrapper, + testFailWhenNoTestSuites = packageConfigTestFailWhenNoTestSuites, + testOptions = packageConfigTestTestOptions + } + + benchmarkFlags = BenchmarkFlags { + benchmarkDistPref = mempty, + benchmarkVerbosity = mempty, + benchmarkOptions = packageConfigBenchmarkOptions + } + +------------------------------------------------ +-- Parsing and showing the project config file +-- + +parseLegacyProjectConfigFields :: FilePath -> [ParseUtils.Field] -> ParseResult LegacyProjectConfig +parseLegacyProjectConfigFields source = + parseFieldsAndSections (legacyProjectConfigFieldDescrs constraintSrc) + legacyPackageConfigSectionDescrs + legacyPackageConfigFGSectionDescrs + mempty + where + constraintSrc = ConstraintSourceProjectConfig source + +parseLegacyProjectConfig :: FilePath -> BS.ByteString -> ParseResult LegacyProjectConfig +parseLegacyProjectConfig source bs = parseLegacyProjectConfigFields source =<< ParseUtils.readFields bs + +showLegacyProjectConfig :: LegacyProjectConfig -> String +showLegacyProjectConfig config = + Disp.render $ + showConfig (legacyProjectConfigFieldDescrs constraintSrc) + legacyPackageConfigSectionDescrs + legacyPackageConfigFGSectionDescrs + config + $+$ + Disp.text "" + where + -- Note: ConstraintSource is unused when pretty-printing. We fake + -- it here to avoid having to pass it on call-sites. It's not great + -- but requires re-work of how we annotate provenance. + constraintSrc = ConstraintSourceProjectConfig "unused" + + +legacyProjectConfigFieldDescrs :: ConstraintSource -> [FieldDescr LegacyProjectConfig] +legacyProjectConfigFieldDescrs constraintSrc = + + [ newLineListField "packages" + (Disp.text . renderPackageLocationToken) parsePackageLocationTokenQ + legacyPackages + (\v flags -> flags { legacyPackages = v }) + , newLineListField "optional-packages" + (Disp.text . renderPackageLocationToken) parsePackageLocationTokenQ + legacyPackagesOptional + (\v flags -> flags { legacyPackagesOptional = v }) + , commaNewLineListFieldParsec "extra-packages" + pretty parsec + legacyPackagesNamed + (\v flags -> flags { legacyPackagesNamed = v }) + ] + + ++ map (liftField + legacySharedConfig + (\flags conf -> conf { legacySharedConfig = flags })) + (legacySharedConfigFieldDescrs constraintSrc) + + ++ map (liftField + legacyLocalConfig + (\flags conf -> conf { legacyLocalConfig = flags })) + legacyPackageConfigFieldDescrs + +-- | This is a bit tricky since it has to cover globs which have embedded @,@ +-- chars. But we don't just want to parse strictly as a glob since we want to +-- allow http urls which don't parse as globs, and possibly some +-- system-dependent file paths. So we parse fairly liberally as a token, but +-- we allow @,@ inside matched @{}@ braces. +-- +parsePackageLocationTokenQ :: ReadP r String +parsePackageLocationTokenQ = parseHaskellString + Parse.<++ parsePackageLocationToken + where + parsePackageLocationToken :: ReadP r String + parsePackageLocationToken = fmap fst (Parse.gather outerTerm) + where + outerTerm = alternateEither1 outerToken (braces innerTerm) + innerTerm = alternateEither innerToken (braces innerTerm) + outerToken = Parse.munch1 outerChar >> return () + innerToken = Parse.munch1 innerChar >> return () + outerChar c = not (isSpace c || c == '{' || c == '}' || c == ',') + innerChar c = not (isSpace c || c == '{' || c == '}') + braces = Parse.between (Parse.char '{') (Parse.char '}') + + alternateEither, alternateEither1, + alternatePQs, alternate1PQs, alternateQsP, alternate1QsP + :: ReadP r () -> ReadP r () -> ReadP r () + + alternateEither1 p q = alternate1PQs p q +++ alternate1QsP q p + alternateEither p q = alternateEither1 p q +++ return () + alternate1PQs p q = p >> alternateQsP q p + alternatePQs p q = alternate1PQs p q +++ return () + alternate1QsP q p = Parse.many1 q >> alternatePQs p q + alternateQsP q p = alternate1QsP q p +++ return () + +renderPackageLocationToken :: String -> String +renderPackageLocationToken s | needsQuoting = show s + | otherwise = s + where + needsQuoting = not (ok 0 s) + || s == "." -- . on its own on a line has special meaning + || take 2 s == "--" -- on its own line is comment syntax + --TODO: [code cleanup] these "." and "--" escaping issues + -- ought to be dealt with systematically in ParseUtils. + ok :: Int -> String -> Bool + ok n [] = n == 0 + ok _ ('"':_) = False + ok n ('{':cs) = ok (n+1) cs + ok n ('}':cs) = ok (n-1) cs + ok n (',':cs) = (n > 0) && ok n cs + ok _ (c:_) + | isSpace c = False + ok n (_ :cs) = ok n cs + + +legacySharedConfigFieldDescrs :: ConstraintSource -> [FieldDescr LegacySharedConfig] +legacySharedConfigFieldDescrs constraintSrc = concat + [ liftFields + legacyGlobalFlags + (\flags conf -> conf { legacyGlobalFlags = flags }) + . addFields + [ newLineListField "extra-prog-path-shared-only" + showTokenQ parseTokenQ + (fromNubList . globalProgPathExtra) + (\v conf -> conf { globalProgPathExtra = toNubList v }) + ] + . filterFields + [ "remote-repo-cache" + , "logs-dir", "store-dir", "ignore-expiry", "http-transport" + , "active-repositories" + ] + . commandOptionsToFields + $ commandOptions (globalCommand []) ParseArgs + + , liftFields + legacyConfigureShFlags + (\flags conf -> conf { legacyConfigureShFlags = flags }) + . addFields + [ commaNewLineListFieldParsec "package-dbs" + (Disp.text . showPackageDb) (fmap readPackageDb parsecToken) + configPackageDBs (\v conf -> conf { configPackageDBs = v }) + ] + . filterFields ["verbose", "builddir" ] + . commandOptionsToFields + $ configureOptions ParseArgs + + , liftFields + legacyConfigureExFlags + (\flags conf -> conf { legacyConfigureExFlags = flags }) + . addFields + [ commaNewLineListFieldParsec "constraints" + (pretty . fst) (fmap (\constraint -> (constraint, constraintSrc)) parsec) + configExConstraints (\v conf -> conf { configExConstraints = v }) + + , commaNewLineListFieldParsec "preferences" + pretty parsec + configPreferences (\v conf -> conf { configPreferences = v }) + + , monoidFieldParsec "allow-older" + (maybe mempty pretty) (fmap Just parsec) + (fmap unAllowOlder . configAllowOlder) + (\v conf -> conf { configAllowOlder = fmap AllowOlder v }) + + , monoidFieldParsec "allow-newer" + (maybe mempty pretty) (fmap Just parsec) + (fmap unAllowNewer . configAllowNewer) + (\v conf -> conf { configAllowNewer = fmap AllowNewer v }) + ] + . filterFields + [ "cabal-lib-version", "solver", "write-ghc-environment-files" + -- not "constraint" or "preference", we use our own plural ones above + ] + . commandOptionsToFields + $ configureExOptions ParseArgs constraintSrc + + , liftFields + legacyInstallFlags + (\flags conf -> conf { legacyInstallFlags = flags }) + . addFields + [ newLineListField "build-summary" + (showTokenQ . fromPathTemplate) (fmap toPathTemplate parseTokenQ) + (fromNubList . installSummaryFile) + (\v conf -> conf { installSummaryFile = toNubList v }) + ] + . filterFields + [ "doc-index-file" + , "root-cmd", "symlink-bindir" + , "build-log" + , "remote-build-reporting", "report-planning-failure" + , "jobs", "keep-going", "offline", "per-component" + -- solver flags: + , "max-backjumps", "reorder-goals", "count-conflicts" + , "fine-grained-conflicts" , "minimize-conflict-set", "independent-goals", "prefer-oldest" + , "strong-flags" , "allow-boot-library-installs" + , "reject-unconstrained-dependencies", "index-state" + ] + . commandOptionsToFields + $ installOptions ParseArgs + + , liftFields + legacyClientInstallFlags + (\flags conf -> conf { legacyClientInstallFlags = flags }) + . commandOptionsToFields + $ clientInstallOptions ParseArgs + + , liftFields + legacyProjectFlags + (\flags conf -> conf { legacyProjectFlags = flags }) + . commandOptionsToFields + $ projectFlagsOptions ParseArgs + + ] + + +legacyPackageConfigFieldDescrs :: [FieldDescr LegacyPackageConfig] +legacyPackageConfigFieldDescrs = + ( liftFields + legacyConfigureFlags + (\flags conf -> conf { legacyConfigureFlags = flags }) + . addFields + [ newLineListField "extra-include-dirs" + showTokenQ parseTokenQ + configExtraIncludeDirs + (\v conf -> conf { configExtraIncludeDirs = v }) + , newLineListField "extra-lib-dirs" + showTokenQ parseTokenQ + configExtraLibDirs + (\v conf -> conf { configExtraLibDirs = v }) + , newLineListField "extra-lib-dirs-static" + showTokenQ parseTokenQ + configExtraLibDirsStatic + (\v conf -> conf { configExtraLibDirsStatic = v }) + , newLineListField "extra-framework-dirs" + showTokenQ parseTokenQ + configExtraFrameworkDirs + (\v conf -> conf { configExtraFrameworkDirs = v }) + , newLineListField "extra-prog-path" + showTokenQ parseTokenQ + (fromNubList . configProgramPathExtra) + (\v conf -> conf { configProgramPathExtra = toNubList v }) + , newLineListField "configure-options" + showTokenQ parseTokenQ + configConfigureArgs + (\v conf -> conf { configConfigureArgs = v }) + , simpleFieldParsec "flags" + dispFlagAssignment parsecFlagAssignment + configConfigurationsFlags + (\v conf -> conf { configConfigurationsFlags = v }) + , overrideDumpBuildInfo + ] + . filterFields + [ "with-compiler", "with-hc-pkg" + , "program-prefix", "program-suffix" + , "library-vanilla", "library-profiling" + , "shared", "static", "executable-dynamic", "executable-static" + , "profiling", "executable-profiling" + , "profiling-detail", "library-profiling-detail" + , "library-for-ghci", "split-objs", "split-sections" + , "executable-stripping", "library-stripping" + , "tests", "benchmarks" + , "coverage", "library-coverage" + , "relocatable" + -- not "extra-include-dirs", "extra-lib-dirs", "extra-framework-dirs" + -- or "extra-prog-path". We use corrected ones above that parse + -- as list fields. + ] + . commandOptionsToFields + ) (configureOptions ParseArgs) + ++ + liftFields + legacyConfigureFlags + (\flags conf -> conf { legacyConfigureFlags = flags }) + [ overrideFieldCompiler + , overrideFieldOptimization + , overrideFieldDebugInfo + ] + ++ + ( liftFields + legacyInstallPkgFlags + (\flags conf -> conf { legacyInstallPkgFlags = flags }) + . filterFields + [ "documentation", "run-tests" + ] + . commandOptionsToFields + ) (installOptions ParseArgs) + ++ + ( liftFields + legacyHaddockFlags + (\flags conf -> conf { legacyHaddockFlags = flags }) + . mapFieldNames + ("haddock-"++) + . addFields + [ simpleFieldParsec "for-hackage" + -- TODO: turn this into a library function + (fromFlagOrDefault Disp.empty . fmap pretty) (toFlag <$> parsec <|> pure mempty) + haddockForHackage (\v conf -> conf { haddockForHackage = v }) + ] + . filterFields + [ "hoogle", "html", "html-location" + , "foreign-libraries" + , "executables", "tests", "benchmarks", "all", "internal", "css" + , "hyperlink-source", "quickjump", "hscolour-css" + , "contents-location", "keep-temp-files" + ] + . commandOptionsToFields + ) (haddockOptions ParseArgs) + ++ + ( liftFields + legacyTestFlags + (\flags conf -> conf { legacyTestFlags = flags }) + . mapFieldNames + prefixTest + . addFields + [ newLineListField "test-options" + (showTokenQ . fromPathTemplate) (fmap toPathTemplate parseTokenQ) + testOptions + (\v conf -> conf { testOptions = v }) + ] + . filterFields + [ "log", "machine-log", "show-details", "keep-tix-files" + , "fail-when-no-test-suites", "test-wrapper" ] + . commandOptionsToFields + ) (testOptions' ParseArgs) + ++ + ( liftFields + legacyBenchmarkFlags + (\flags conf -> conf { legacyBenchmarkFlags = flags }) + . addFields + [ newLineListField "benchmark-options" + (showTokenQ . fromPathTemplate) (fmap toPathTemplate parseTokenQ) + benchmarkOptions + (\v conf -> conf { benchmarkOptions = v }) + ] + . filterFields + [] + . commandOptionsToFields + ) (benchmarkOptions' ParseArgs) + + + where + overrideFieldCompiler = + simpleFieldParsec "compiler" + (fromFlagOrDefault Disp.empty . fmap pretty) + (toFlag <$> parsec <|> pure mempty) + configHcFlavor (\v flags -> flags { configHcFlavor = v }) + + overrideDumpBuildInfo = + liftField configDumpBuildInfo + (\v flags -> flags { configDumpBuildInfo = v }) $ + let name = "build-info" in + FieldDescr name + (\f -> case f of + Flag NoDumpBuildInfo -> Disp.text "False" + Flag DumpBuildInfo -> Disp.text "True" + _ -> Disp.empty) + (\line str _ -> case () of + _ | str == "False" -> ParseOk [] (Flag NoDumpBuildInfo) + | str == "True" -> ParseOk [] (Flag DumpBuildInfo) + | lstr == "false" -> ParseOk [caseWarning name] (Flag NoDumpBuildInfo) + | lstr == "true" -> ParseOk [caseWarning name] (Flag DumpBuildInfo) + | otherwise -> ParseFailed (NoParse name line) + where + lstr = lowercase str) + + -- TODO: [code cleanup] The following is a hack. The "optimization" and + -- "debug-info" fields are OptArg, and viewAsFieldDescr fails on that. + -- Instead of a hand-written parser and printer, we should handle this case + -- properly in the library. + + overrideFieldOptimization = + liftField configOptimization + (\v flags -> flags { configOptimization = v }) $ + let name = "optimization" in + FieldDescr name + (\f -> case f of + Flag NoOptimisation -> Disp.text "False" + Flag NormalOptimisation -> Disp.text "True" + Flag MaximumOptimisation -> Disp.text "2" + _ -> Disp.empty) + (\line str _ -> case () of + _ | str == "False" -> ParseOk [] (Flag NoOptimisation) + | str == "True" -> ParseOk [] (Flag NormalOptimisation) + | str == "0" -> ParseOk [] (Flag NoOptimisation) + | str == "1" -> ParseOk [] (Flag NormalOptimisation) + | str == "2" -> ParseOk [] (Flag MaximumOptimisation) + | lstr == "false" -> ParseOk [caseWarning name] (Flag NoOptimisation) + | lstr == "true" -> ParseOk [caseWarning name] (Flag NormalOptimisation) + | otherwise -> ParseFailed (NoParse name line) + where + lstr = lowercase str) + + overrideFieldDebugInfo = + liftField configDebugInfo (\v flags -> flags { configDebugInfo = v }) $ + let name = "debug-info" in + FieldDescr name + (\f -> case f of + Flag NoDebugInfo -> Disp.text "False" + Flag MinimalDebugInfo -> Disp.text "1" + Flag NormalDebugInfo -> Disp.text "True" + Flag MaximalDebugInfo -> Disp.text "3" + _ -> Disp.empty) + (\line str _ -> case () of + _ | str == "False" -> ParseOk [] (Flag NoDebugInfo) + | str == "True" -> ParseOk [] (Flag NormalDebugInfo) + | str == "0" -> ParseOk [] (Flag NoDebugInfo) + | str == "1" -> ParseOk [] (Flag MinimalDebugInfo) + | str == "2" -> ParseOk [] (Flag NormalDebugInfo) + | str == "3" -> ParseOk [] (Flag MaximalDebugInfo) + | lstr == "false" -> ParseOk [caseWarning name] (Flag NoDebugInfo) + | lstr == "true" -> ParseOk [caseWarning name] (Flag NormalDebugInfo) + | otherwise -> ParseFailed (NoParse name line) + where + lstr = lowercase str) + + caseWarning name = PWarning $ + "The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'." + + prefixTest name | "test-" `isPrefixOf` name = name + | otherwise = "test-" ++ name + + +legacyPackageConfigFGSectionDescrs + :: ( FieldGrammar c g, Applicative (g SourceRepoList) + , c (Identity RepoType) + , c (List NoCommaFSep FilePathNT String) + , c (NonEmpty' NoCommaFSep Token String) + ) + => [FGSectionDescr g LegacyProjectConfig] +legacyPackageConfigFGSectionDescrs = + [ packageRepoSectionDescr + ] + +legacyPackageConfigSectionDescrs :: [SectionDescr LegacyProjectConfig] +legacyPackageConfigSectionDescrs = + [ packageSpecificOptionsSectionDescr + , liftSection + legacyLocalConfig + (\flags conf -> conf { legacyLocalConfig = flags }) + programOptionsSectionDescr + , liftSection + legacyLocalConfig + (\flags conf -> conf { legacyLocalConfig = flags }) + programLocationsSectionDescr + , liftSection + legacySharedConfig + (\flags conf -> conf { legacySharedConfig = flags }) $ + liftSection + legacyGlobalFlags + (\flags conf -> conf { legacyGlobalFlags = flags }) + remoteRepoSectionDescr + ] + +packageRepoSectionDescr + :: ( FieldGrammar c g, Applicative (g SourceRepoList) + , c (Identity RepoType) + , c (List NoCommaFSep FilePathNT String) + , c (NonEmpty' NoCommaFSep Token String) + ) + => FGSectionDescr g LegacyProjectConfig +packageRepoSectionDescr = FGSectionDescr + { fgSectionName = "source-repository-package" + , fgSectionGrammar = sourceRepositoryPackageGrammar + , fgSectionGet = map (\x->("", x)) . legacyPackagesRepo + , fgSectionSet = + \lineno unused pkgrepo projconf -> do + unless (null unused) $ + syntaxError lineno "the section 'source-repository-package' takes no arguments" + return projconf { + legacyPackagesRepo = legacyPackagesRepo projconf ++ [pkgrepo] + } + } + +-- | The definitions of all the fields that can appear in the @package pkgfoo@ +-- and @package *@ sections of the @cabal.project@-format files. +-- +packageSpecificOptionsFieldDescrs :: [FieldDescr LegacyPackageConfig] +packageSpecificOptionsFieldDescrs = + legacyPackageConfigFieldDescrs + ++ programOptionsFieldDescrs + (configProgramArgs . legacyConfigureFlags) + (\args pkgconf -> pkgconf { + legacyConfigureFlags = (legacyConfigureFlags pkgconf) { + configProgramArgs = args + } + } + ) + ++ liftFields + legacyConfigureFlags + (\flags pkgconf -> pkgconf { + legacyConfigureFlags = flags + } + ) + programLocationsFieldDescrs + +-- | The definition of the @package pkgfoo@ sections of the @cabal.project@-format +-- files. This section is per-package name. The special package @*@ applies to all +-- packages used anywhere by the project, locally or as dependencies. +-- +packageSpecificOptionsSectionDescr :: SectionDescr LegacyProjectConfig +packageSpecificOptionsSectionDescr = + SectionDescr { + sectionName = "package", + sectionFields = packageSpecificOptionsFieldDescrs, + sectionSubsections = [], + sectionGet = \projconf -> + [ (prettyShow pkgname, pkgconf) + | (pkgname, pkgconf) <- + Map.toList . getMapMappend + . legacySpecificConfig $ projconf ] + ++ [ ("*", legacyAllConfig projconf) ], + sectionSet = + \lineno pkgnamestr pkgconf projconf -> case pkgnamestr of + "*" -> return projconf { + legacyAllConfig = legacyAllConfig projconf <> pkgconf + } + _ -> do + pkgname <- case simpleParsec pkgnamestr of + Just pkgname -> return pkgname + Nothing -> syntaxError lineno $ + "a 'package' section requires a package name " + ++ "as an argument" + return projconf { + legacySpecificConfig = + MapMappend $ + Map.insertWith mappend pkgname pkgconf + (getMapMappend $ legacySpecificConfig projconf) + }, + sectionEmpty = mempty + } + +programOptionsFieldDescrs :: (a -> [(String, [String])]) + -> ([(String, [String])] -> a -> a) + -> [FieldDescr a] +programOptionsFieldDescrs get' set = + commandOptionsToFields + $ programDbOptions + defaultProgramDb + ParseArgs get' set + +programOptionsSectionDescr :: SectionDescr LegacyPackageConfig +programOptionsSectionDescr = + SectionDescr { + sectionName = "program-options", + sectionFields = programOptionsFieldDescrs + configProgramArgs + (\args conf -> conf { configProgramArgs = args }), + sectionSubsections = [], + sectionGet = (\x->[("", x)]) + . legacyConfigureFlags, + sectionSet = + \lineno unused confflags pkgconf -> do + unless (null unused) $ + syntaxError lineno "the section 'program-options' takes no arguments" + return pkgconf { + legacyConfigureFlags = legacyConfigureFlags pkgconf <> confflags + }, + sectionEmpty = mempty + } + +programLocationsFieldDescrs :: [FieldDescr ConfigFlags] +programLocationsFieldDescrs = + commandOptionsToFields + $ programDbPaths' + (++ "-location") + defaultProgramDb + ParseArgs + configProgramPaths + (\paths conf -> conf { configProgramPaths = paths }) + +programLocationsSectionDescr :: SectionDescr LegacyPackageConfig +programLocationsSectionDescr = + SectionDescr { + sectionName = "program-locations", + sectionFields = programLocationsFieldDescrs, + sectionSubsections = [], + sectionGet = (\x->[("", x)]) + . legacyConfigureFlags, + sectionSet = + \lineno unused confflags pkgconf -> do + unless (null unused) $ + syntaxError lineno "the section 'program-locations' takes no arguments" + return pkgconf { + legacyConfigureFlags = legacyConfigureFlags pkgconf <> confflags + }, + sectionEmpty = mempty + } + + +-- | For each known program @PROG@ in 'progDb', produce a @PROG-options@ +-- 'OptionField'. +programDbOptions + :: ProgramDb + -> ShowOrParseArgs + -> (flags -> [(String, [String])]) + -> ([(String, [String])] -> (flags -> flags)) + -> [OptionField flags] +programDbOptions progDb showOrParseArgs get' set = + case showOrParseArgs of + -- we don't want a verbose help text list so we just show a generic one: + ShowArgs -> [programOptions "PROG"] + ParseArgs -> map (programOptions . programName . fst) + (knownPrograms progDb) + where + programOptions prog = + option "" [prog ++ "-options"] + ("give extra options to " ++ prog) + get' set + (reqArg' "OPTS" (\args -> [(prog, splitArgs args)]) + (\progArgs -> [ joinsArgs args + | (prog', args) <- progArgs, prog==prog' ])) + + + joinsArgs = unwords . map escape + escape arg | any isSpace arg = "\"" ++ arg ++ "\"" + | otherwise = arg + + +-- The implementation is slight hack: we parse all as remote repository +-- but if the url schema is file+noindex, we switch to local. +remoteRepoSectionDescr :: SectionDescr GlobalFlags +remoteRepoSectionDescr = SectionDescr + { sectionName = "repository" + , sectionEmpty = emptyRemoteRepo (RepoName "") + , sectionFields = remoteRepoFields + , sectionSubsections = [] + , sectionGet = getS + , sectionSet = setS + } + where + getS :: GlobalFlags -> [(String, RemoteRepo)] + getS gf = + map (\x->(unRepoName $ remoteRepoName x, x)) (fromNubList (globalRemoteRepos gf)) + ++ + map (\x->(unRepoName $ localRepoName x, localToRemote x)) (fromNubList (globalLocalNoIndexRepos gf)) + + setS :: Int -> String -> RemoteRepo -> GlobalFlags -> ParseResult GlobalFlags + setS lineno reponame repo0 conf = do + repo1 <- postProcessRepo lineno reponame repo0 + case repo1 of + Left repo -> return conf + { globalLocalNoIndexRepos = overNubList (++[repo]) (globalLocalNoIndexRepos conf) + } + Right repo -> return conf + { globalRemoteRepos = overNubList (++[repo]) (globalRemoteRepos conf) + } + + localToRemote :: LocalRepo -> RemoteRepo + localToRemote (LocalRepo name path sharedCache) = (emptyRemoteRepo name) + { remoteRepoURI = URI "file+noindex:" Nothing path "" (if sharedCache then "#shared-cache" else "") + } + +------------------------------- +-- Local field utils +-- + +-- | Parser combinator for simple fields which uses the field type's +-- 'Monoid' instance for combining multiple occurrences of the field. +monoidFieldParsec + :: Monoid a => String -> (a -> Doc) -> ParsecParser a + -> (b -> a) -> (a -> b -> b) -> FieldDescr b +monoidFieldParsec name showF readF get' set = + liftField get' set' $ ParseUtils.fieldParsec name showF readF + where + set' xs b = set (get' b `mappend` xs) b + + +--TODO: [code cleanup] local redefinition that should replace the version in +-- D.ParseUtils called showFilePath. This version escapes "." and "--" which +-- otherwise are special syntax. +showTokenQ :: String -> Doc +showTokenQ "" = Disp.empty +showTokenQ x@('-':'-':_) = Disp.text (show x) +showTokenQ x@('.':[]) = Disp.text (show x) +showTokenQ x = showToken x + + +-- Handy util +addFields :: [FieldDescr a] + -> ([FieldDescr a] -> [FieldDescr a]) +addFields = (++) diff --git a/cabal/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs b/cabal/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs @@ -0,0 +1,463 @@ +{-# LANGUAGE DeriveGeneric, DeriveDataTypeable, GeneralizedNewtypeDeriving #-} + +-- | Handling project configuration, types. +-- +module Distribution.Client.ProjectConfig.Types ( + + -- * Types for project config + ProjectConfig(..), + ProjectConfigBuildOnly(..), + ProjectConfigShared(..), + ProjectConfigProvenance(..), + PackageConfig(..), + + -- * Resolving configuration + SolverSettings(..), + BuildTimeSettings(..), + + -- * Extra useful Monoids + MapLast(..), + MapMappend(..), + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Client.Types.Repo ( RemoteRepo, LocalRepo ) +import Distribution.Client.Types.AllowNewer ( AllowNewer(..), AllowOlder(..) ) +import Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy ( WriteGhcEnvironmentFilesPolicy ) +import Distribution.Client.Dependency.Types + ( PreSolver ) +import Distribution.Client.Targets + ( UserConstraint ) +import Distribution.Client.BuildReports.Types + ( ReportLevel(..) ) +import Distribution.Client.Types.SourceRepo (SourceRepoList) + +import Distribution.Client.IndexUtils.IndexState + ( TotalIndexState ) +import Distribution.Client.IndexUtils.ActiveRepos + ( ActiveRepos ) + +import Distribution.Client.CmdInstall.ClientInstallFlags + ( ClientInstallFlags(..) ) + +import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.ConstraintSource + +import Distribution.Package + ( PackageName, PackageId, UnitId ) +import Distribution.Types.PackageVersionConstraint + ( PackageVersionConstraint ) +import Distribution.Version + ( Version ) +import Distribution.System + ( Platform ) +import Distribution.PackageDescription + ( FlagAssignment ) +import Distribution.Simple.Compiler + ( Compiler, CompilerFlavor, PackageDB + , OptimisationLevel(..), ProfDetailLevel, DebugInfoLevel(..) ) +import Distribution.Simple.Setup + ( Flag, HaddockTarget(..), TestShowDetails(..), DumpBuildInfo (..) ) +import Distribution.Simple.InstallDirs + ( PathTemplate ) +import Distribution.Utils.NubList + ( NubList ) + +import qualified Data.Map as Map + +------------------------------- +-- Project config types +-- + +-- | This type corresponds directly to what can be written in the +-- @cabal.project@ file. Other sources of configuration can also be injected +-- into this type, such as the user-wide @~/.cabal/config@ file and the +-- command line of @cabal configure@ or @cabal build@. +-- +-- Since it corresponds to the external project file it is an instance of +-- 'Monoid' and all the fields can be empty. This also means there has to +-- be a step where we resolve configuration. At a minimum resolving means +-- applying defaults but it can also mean merging information from multiple +-- sources. For example for package-specific configuration the project file +-- can specify configuration that applies to all local packages, and then +-- additional configuration for a specific package. +-- +-- Future directions: multiple profiles, conditionals. If we add these +-- features then the gap between configuration as written in the config file +-- and resolved settings we actually use will become even bigger. +-- +data ProjectConfig + = ProjectConfig { + + -- | Packages in this project, including local dirs, local .cabal files + -- local and remote tarballs. When these are file globs, they must + -- match at least one package. + projectPackages :: [String], + + -- | Like 'projectConfigPackageGlobs' but /optional/ in the sense that + -- file globs are allowed to match nothing. The primary use case for + -- this is to be able to say @optional-packages: */@ to automagically + -- pick up deps that we unpack locally without erroring when + -- there aren't any. + projectPackagesOptional :: [String], + + -- | Packages in this project from remote source repositories. + projectPackagesRepo :: [SourceRepoList], + + -- | Packages in this project from hackage repositories. + projectPackagesNamed :: [PackageVersionConstraint], + + -- See respective types for an explanation of what these + -- values are about: + projectConfigBuildOnly :: ProjectConfigBuildOnly, + projectConfigShared :: ProjectConfigShared, + projectConfigProvenance :: Set ProjectConfigProvenance, + + -- | Configuration to be applied to *all* packages, + -- whether named in `cabal.project` or not. + projectConfigAllPackages :: PackageConfig, + + -- | Configuration to be applied to *local* packages; i.e., + -- any packages which are explicitly named in `cabal.project`. + projectConfigLocalPackages :: PackageConfig, + projectConfigSpecificPackage :: MapMappend PackageName PackageConfig + } + deriving (Eq, Show, Generic, Typeable) + +-- | That part of the project configuration that only affects /how/ we build +-- and not the /value/ of the things we build. This means this information +-- does not need to be tracked for changes since it does not affect the +-- outcome. +-- +data ProjectConfigBuildOnly + = ProjectConfigBuildOnly { + projectConfigVerbosity :: Flag Verbosity, + projectConfigDryRun :: Flag Bool, + projectConfigOnlyDeps :: Flag Bool, + projectConfigOnlyDownload :: Flag Bool, + projectConfigSummaryFile :: NubList PathTemplate, + projectConfigLogFile :: Flag PathTemplate, + projectConfigBuildReports :: Flag ReportLevel, + projectConfigReportPlanningFailure :: Flag Bool, + projectConfigSymlinkBinDir :: Flag FilePath, + projectConfigNumJobs :: Flag (Maybe Int), + projectConfigKeepGoing :: Flag Bool, + projectConfigOfflineMode :: Flag Bool, + projectConfigKeepTempFiles :: Flag Bool, + projectConfigHttpTransport :: Flag String, + projectConfigIgnoreExpiry :: Flag Bool, + projectConfigCacheDir :: Flag FilePath, + projectConfigLogsDir :: Flag FilePath, + projectConfigClientInstallFlags :: ClientInstallFlags + } + deriving (Eq, Show, Generic) + + +-- | Project configuration that is shared between all packages in the project. +-- In particular this includes configuration that affects the solver. +-- +data ProjectConfigShared + = ProjectConfigShared { + projectConfigDistDir :: Flag FilePath, + projectConfigConfigFile :: Flag FilePath, + projectConfigProjectFile :: Flag FilePath, + projectConfigIgnoreProject :: Flag Bool, + projectConfigHcFlavor :: Flag CompilerFlavor, + projectConfigHcPath :: Flag FilePath, + projectConfigHcPkg :: Flag FilePath, + projectConfigHaddockIndex :: Flag PathTemplate, + + -- Things that only make sense for manual mode, not --local mode + -- too much control! + --projectConfigUserInstall :: Flag Bool, + --projectConfigInstallDirs :: InstallDirs (Flag PathTemplate), + --TODO: [required eventually] decide what to do with InstallDirs + -- currently we don't allow it to be specified in the config file + projectConfigPackageDBs :: [Maybe PackageDB], + + -- configuration used both by the solver and other phases + projectConfigRemoteRepos :: NubList RemoteRepo, -- ^ Available Hackage servers. + projectConfigLocalNoIndexRepos :: NubList LocalRepo, + projectConfigActiveRepos :: Flag ActiveRepos, + projectConfigIndexState :: Flag TotalIndexState, + projectConfigStoreDir :: Flag FilePath, + + -- solver configuration + projectConfigConstraints :: [(UserConstraint, ConstraintSource)], + projectConfigPreferences :: [PackageVersionConstraint], + projectConfigCabalVersion :: Flag Version, --TODO: [required eventually] unused + projectConfigSolver :: Flag PreSolver, + projectConfigAllowOlder :: Maybe AllowOlder, + projectConfigAllowNewer :: Maybe AllowNewer, + projectConfigWriteGhcEnvironmentFilesPolicy + :: Flag WriteGhcEnvironmentFilesPolicy, + projectConfigMaxBackjumps :: Flag Int, + projectConfigReorderGoals :: Flag ReorderGoals, + projectConfigCountConflicts :: Flag CountConflicts, + projectConfigFineGrainedConflicts :: Flag FineGrainedConflicts, + projectConfigMinimizeConflictSet :: Flag MinimizeConflictSet, + projectConfigStrongFlags :: Flag StrongFlags, + projectConfigAllowBootLibInstalls :: Flag AllowBootLibInstalls, + projectConfigOnlyConstrained :: Flag OnlyConstrained, + projectConfigPerComponent :: Flag Bool, + projectConfigIndependentGoals :: Flag IndependentGoals, + projectConfigPreferOldest :: Flag PreferOldest, + + projectConfigProgPathExtra :: NubList FilePath + + -- More things that only make sense for manual mode, not --local mode + -- too much control! + --projectConfigShadowPkgs :: Flag Bool, + --projectConfigReinstall :: Flag Bool, + --projectConfigAvoidReinstalls :: Flag Bool, + --projectConfigOverrideReinstall :: Flag Bool, + --projectConfigUpgradeDeps :: Flag Bool + } + deriving (Eq, Show, Generic) + + +-- | Specifies the provenance of project configuration, whether defaults were +-- used or if the configuration was read from an explicit file path. +data ProjectConfigProvenance + + -- | The configuration is implicit due to no explicit configuration + -- being found. See 'Distribution.Client.ProjectConfig.readProjectConfig' + -- for how implicit configuration is determined. + = Implicit + + -- | The path the project configuration was explicitly read from. + -- | The configuration was explicitly read from the specified 'FilePath'. + | Explicit FilePath + deriving (Eq, Ord, Show, Generic) + + +-- | Project configuration that is specific to each package, that is where we +-- can in principle have different values for different packages in the same +-- project. +-- +data PackageConfig + = PackageConfig { + packageConfigProgramPaths :: MapLast String FilePath, + packageConfigProgramArgs :: MapMappend String [String], + packageConfigProgramPathExtra :: NubList FilePath, + packageConfigFlagAssignment :: FlagAssignment, + packageConfigVanillaLib :: Flag Bool, + packageConfigSharedLib :: Flag Bool, + packageConfigStaticLib :: Flag Bool, + packageConfigDynExe :: Flag Bool, + packageConfigFullyStaticExe :: Flag Bool, + packageConfigProf :: Flag Bool, --TODO: [code cleanup] sort out + packageConfigProfLib :: Flag Bool, -- this duplication + packageConfigProfExe :: Flag Bool, -- and consistency + packageConfigProfDetail :: Flag ProfDetailLevel, + packageConfigProfLibDetail :: Flag ProfDetailLevel, + packageConfigConfigureArgs :: [String], + packageConfigOptimization :: Flag OptimisationLevel, + packageConfigProgPrefix :: Flag PathTemplate, + packageConfigProgSuffix :: Flag PathTemplate, + packageConfigExtraLibDirs :: [FilePath], + packageConfigExtraLibDirsStatic :: [FilePath], + packageConfigExtraFrameworkDirs :: [FilePath], + packageConfigExtraIncludeDirs :: [FilePath], + packageConfigGHCiLib :: Flag Bool, + packageConfigSplitSections :: Flag Bool, + packageConfigSplitObjs :: Flag Bool, + packageConfigStripExes :: Flag Bool, + packageConfigStripLibs :: Flag Bool, + packageConfigTests :: Flag Bool, + packageConfigBenchmarks :: Flag Bool, + packageConfigCoverage :: Flag Bool, + packageConfigRelocatable :: Flag Bool, + packageConfigDebugInfo :: Flag DebugInfoLevel, + packageConfigDumpBuildInfo :: Flag DumpBuildInfo, + packageConfigRunTests :: Flag Bool, --TODO: [required eventually] use this + packageConfigDocumentation :: Flag Bool, --TODO: [required eventually] use this + -- Haddock options + packageConfigHaddockHoogle :: Flag Bool, --TODO: [required eventually] use this + packageConfigHaddockHtml :: Flag Bool, --TODO: [required eventually] use this + packageConfigHaddockHtmlLocation :: Flag String, --TODO: [required eventually] use this + packageConfigHaddockForeignLibs :: Flag Bool, --TODO: [required eventually] use this + packageConfigHaddockExecutables :: Flag Bool, --TODO: [required eventually] use this + packageConfigHaddockTestSuites :: Flag Bool, --TODO: [required eventually] use this + packageConfigHaddockBenchmarks :: Flag Bool, --TODO: [required eventually] use this + packageConfigHaddockInternal :: Flag Bool, --TODO: [required eventually] use this + packageConfigHaddockCss :: Flag FilePath, --TODO: [required eventually] use this + packageConfigHaddockLinkedSource :: Flag Bool, --TODO: [required eventually] use this + packageConfigHaddockQuickJump :: Flag Bool, --TODO: [required eventually] use this + packageConfigHaddockHscolourCss :: Flag FilePath, --TODO: [required eventually] use this + packageConfigHaddockContents :: Flag PathTemplate, --TODO: [required eventually] use this + packageConfigHaddockForHackage :: Flag HaddockTarget, + -- Test options + packageConfigTestHumanLog :: Flag PathTemplate, + packageConfigTestMachineLog :: Flag PathTemplate, + packageConfigTestShowDetails :: Flag TestShowDetails, + packageConfigTestKeepTix :: Flag Bool, + packageConfigTestWrapper :: Flag FilePath, + packageConfigTestFailWhenNoTestSuites :: Flag Bool, + packageConfigTestTestOptions :: [PathTemplate], + -- Benchmark options + packageConfigBenchmarkOptions :: [PathTemplate] + } + deriving (Eq, Show, Generic) + +instance Binary ProjectConfig +instance Binary ProjectConfigBuildOnly +instance Binary ProjectConfigShared +instance Binary ProjectConfigProvenance +instance Binary PackageConfig + +instance Structured ProjectConfig +instance Structured ProjectConfigBuildOnly +instance Structured ProjectConfigShared +instance Structured ProjectConfigProvenance +instance Structured PackageConfig + +-- | Newtype wrapper for 'Map' that provides a 'Monoid' instance that takes +-- the last value rather than the first value for overlapping keys. +newtype MapLast k v = MapLast { getMapLast :: Map k v } + deriving (Eq, Show, Functor, Generic, Binary, Typeable) + +instance (Structured k, Structured v) => Structured (MapLast k v) + +instance Ord k => Monoid (MapLast k v) where + mempty = MapLast Map.empty + mappend = (<>) + +instance Ord k => Semigroup (MapLast k v) where + MapLast a <> MapLast b = MapLast $ Map.union b a + -- rather than Map.union which is the normal Map monoid instance + + +-- | Newtype wrapper for 'Map' that provides a 'Monoid' instance that +-- 'mappend's values of overlapping keys rather than taking the first. +newtype MapMappend k v = MapMappend { getMapMappend :: Map k v } + deriving (Eq, Show, Functor, Generic, Binary, Typeable) + +instance (Structured k, Structured v) => Structured (MapMappend k v) + +instance (Semigroup v, Ord k) => Monoid (MapMappend k v) where + mempty = MapMappend Map.empty + mappend = (<>) + +instance (Semigroup v, Ord k) => Semigroup (MapMappend k v) where + MapMappend a <> MapMappend b = MapMappend (Map.unionWith (<>) a b) + -- rather than Map.union which is the normal Map monoid instance + + +instance Monoid ProjectConfig where + mempty = gmempty + mappend = (<>) + +instance Semigroup ProjectConfig where + (<>) = gmappend + + +instance Monoid ProjectConfigBuildOnly where + mempty = gmempty + mappend = (<>) + +instance Semigroup ProjectConfigBuildOnly where + (<>) = gmappend + + +instance Monoid ProjectConfigShared where + mempty = gmempty + mappend = (<>) + +instance Semigroup ProjectConfigShared where + (<>) = gmappend + + +instance Monoid PackageConfig where + mempty = gmempty + mappend = (<>) + +instance Semigroup PackageConfig where + (<>) = gmappend + +---------------------------------------- +-- Resolving configuration to settings +-- + +-- | Resolved configuration for the solver. The idea is that this is easier to +-- use than the raw configuration because in the raw configuration everything +-- is optional (monoidial). In the 'BuildTimeSettings' every field is filled +-- in, if only with the defaults. +-- +-- Use 'resolveSolverSettings' to make one from the project config (by +-- applying defaults etc). +-- +data SolverSettings + = SolverSettings { + solverSettingRemoteRepos :: [RemoteRepo], -- ^ Available Hackage servers. + solverSettingLocalNoIndexRepos :: [LocalRepo], + solverSettingConstraints :: [(UserConstraint, ConstraintSource)], + solverSettingPreferences :: [PackageVersionConstraint], + solverSettingFlagAssignment :: FlagAssignment, -- ^ For all local packages + solverSettingFlagAssignments :: Map PackageName FlagAssignment, + solverSettingCabalVersion :: Maybe Version, --TODO: [required eventually] unused + solverSettingSolver :: PreSolver, + solverSettingAllowOlder :: AllowOlder, + solverSettingAllowNewer :: AllowNewer, + solverSettingMaxBackjumps :: Maybe Int, + solverSettingReorderGoals :: ReorderGoals, + solverSettingCountConflicts :: CountConflicts, + solverSettingFineGrainedConflicts :: FineGrainedConflicts, + solverSettingMinimizeConflictSet :: MinimizeConflictSet, + solverSettingStrongFlags :: StrongFlags, + solverSettingAllowBootLibInstalls :: AllowBootLibInstalls, + solverSettingOnlyConstrained :: OnlyConstrained, + solverSettingIndexState :: Maybe TotalIndexState, + solverSettingActiveRepos :: Maybe ActiveRepos, + solverSettingIndependentGoals :: IndependentGoals, + solverSettingPreferOldest :: PreferOldest + -- Things that only make sense for manual mode, not --local mode + -- too much control! + --solverSettingShadowPkgs :: Bool, + --solverSettingReinstall :: Bool, + --solverSettingAvoidReinstalls :: Bool, + --solverSettingOverrideReinstall :: Bool, + --solverSettingUpgradeDeps :: Bool + } + deriving (Eq, Show, Generic, Typeable) + +instance Binary SolverSettings +instance Structured SolverSettings + + +-- | Resolved configuration for things that affect how we build and not the +-- value of the things we build. The idea is that this is easier to use than +-- the raw configuration because in the raw configuration everything is +-- optional (monoidial). In the 'BuildTimeSettings' every field is filled in, +-- if only with the defaults. +-- +-- Use 'resolveBuildTimeSettings' to make one from the project config (by +-- applying defaults etc). +-- +data BuildTimeSettings + = BuildTimeSettings { + buildSettingDryRun :: Bool, + buildSettingOnlyDeps :: Bool, + buildSettingOnlyDownload :: Bool, + buildSettingSummaryFile :: [PathTemplate], + buildSettingLogFile :: Maybe (Compiler -> Platform + -> PackageId -> UnitId + -> FilePath), + buildSettingLogVerbosity :: Verbosity, + buildSettingBuildReports :: ReportLevel, + buildSettingReportPlanningFailure :: Bool, + buildSettingSymlinkBinDir :: [FilePath], + buildSettingNumJobs :: Int, + buildSettingKeepGoing :: Bool, + buildSettingOfflineMode :: Bool, + buildSettingKeepTempFiles :: Bool, + buildSettingRemoteRepos :: [RemoteRepo], + buildSettingLocalNoIndexRepos :: [LocalRepo], + buildSettingCacheDir :: FilePath, + buildSettingHttpTransport :: Maybe String, + buildSettingIgnoreExpiry :: Bool, + buildSettingProgPathExtra :: [FilePath], + buildSettingHaddockOpen :: Bool + } diff --git a/cabal/cabal-install/src/Distribution/Client/ProjectFlags.hs b/cabal/cabal-install/src/Distribution/Client/ProjectFlags.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/ProjectFlags.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +module Distribution.Client.ProjectFlags ( + ProjectFlags(..), + defaultProjectFlags, + projectFlagsOptions, + removeIgnoreProjectOption, +) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.ReadE (succeedReadE) +import Distribution.Simple.Command + ( MkOptDescr, OptionField(optionName), ShowOrParseArgs (..), boolOpt', option + , reqArg ) +import Distribution.Simple.Setup (Flag (..), flagToList, flagToMaybe, toFlag, trueArg) + +data ProjectFlags = ProjectFlags + { flagProjectFileName :: Flag FilePath + -- ^ The cabal project file name; defaults to @cabal.project@. + -- The name itself denotes the cabal project file name, but it also + -- is the base of auxiliary project files, such as + -- @cabal.project.local@ and @cabal.project.freeze@ which are also + -- read and written out in some cases. If the path is not found + -- in the current working directory, we will successively probe + -- relative to parent directories until this name is found. + + , flagIgnoreProject :: Flag Bool + -- ^ Whether to ignore the local project (i.e. don't search for cabal.project) + -- The exact interpretation might be slightly different per command. + } + deriving (Show, Generic) + +defaultProjectFlags :: ProjectFlags +defaultProjectFlags = ProjectFlags + { flagProjectFileName = mempty + , flagIgnoreProject = toFlag False + -- Should we use 'Last' here? + } + +projectFlagsOptions :: ShowOrParseArgs -> [OptionField ProjectFlags] +projectFlagsOptions showOrParseArgs = + [ option [] ["project-file"] + "Set the name of the cabal.project file to search for in parent directories" + flagProjectFileName (\pf flags -> flags { flagProjectFileName = pf }) + (reqArg "FILE" (succeedReadE Flag) flagToList) + , option ['z'] ["ignore-project"] + "Ignore local project configuration" + -- Flag True: --ignore-project is given and --project-file is not given + -- Flag False: --ignore-project and --project-file is given + -- NoFlag: neither --ignore-project or --project-file is given + flagIgnoreProject (\v flags -> flags { flagIgnoreProject = if v == NoFlag then NoFlag else toFlag ((flagProjectFileName flags) == NoFlag && v == Flag True) }) + (yesNoOpt showOrParseArgs) + ] + +-- | As almost all commands use 'ProjectFlags' but not all can honour +-- "ignore-project" flag, provide this utility to remove the flag +-- parsing from the help message. +removeIgnoreProjectOption :: [OptionField a] -> [OptionField a] +removeIgnoreProjectOption = filter (\o -> optionName o /= "ignore-project") + +instance Monoid ProjectFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup ProjectFlags where + (<>) = gmappend + +yesNoOpt :: ShowOrParseArgs -> MkOptDescr (b -> Flag Bool) (Flag Bool -> b -> b) b +yesNoOpt ShowArgs sf lf = trueArg sf lf +yesNoOpt _ sf lf = boolOpt' flagToMaybe Flag (sf, lf) ([], map ("no-" ++) lf) sf lf diff --git a/cabal/cabal-install/src/Distribution/Client/ProjectOrchestration.hs b/cabal/cabal-install/src/Distribution/Client/ProjectOrchestration.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/ProjectOrchestration.hs @@ -0,0 +1,1363 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} +{-# LANGUAGE RankNTypes, ScopedTypeVariables #-} + +-- | This module deals with building and incrementally rebuilding a collection +-- of packages. It is what backs the @cabal build@ and @configure@ commands, +-- as well as being a core part of @run@, @test@, @bench@ and others. +-- +-- The primary thing is in fact rebuilding (and trying to make that quick by +-- not redoing unnecessary work), so building from scratch is just a special +-- case. +-- +-- The build process and the code can be understood by breaking it down into +-- three major parts: +-- +-- * The 'ElaboratedInstallPlan' type +-- +-- * The \"what to do\" phase, where we look at the all input configuration +-- (project files, .cabal files, command line etc) and produce a detailed +-- plan of what to do -- the 'ElaboratedInstallPlan'. +-- +-- * The \"do it\" phase, where we take the 'ElaboratedInstallPlan' and we +-- re-execute it. +-- +-- As far as possible, the \"what to do\" phase embodies all the policy, leaving +-- the \"do it\" phase policy free. The first phase contains more of the +-- complicated logic, but it is contained in code that is either pure or just +-- has read effects (except cache updates). Then the second phase does all the +-- actions to build packages, but as far as possible it just follows the +-- instructions and avoids any logic for deciding what to do (apart from +-- recompilation avoidance in executing the plan). +-- +-- This division helps us keep the code under control, making it easier to +-- understand, test and debug. So when you are extending these modules, please +-- think about which parts of your change belong in which part. It is +-- perfectly ok to extend the description of what to do (i.e. the +-- 'ElaboratedInstallPlan') if that helps keep the policy decisions in the +-- first phase. Also, the second phase does not have direct access to any of +-- the input configuration anyway; all the information has to flow via the +-- 'ElaboratedInstallPlan'. +-- +module Distribution.Client.ProjectOrchestration ( + -- * Discovery phase: what is in the project? + CurrentCommand(..), + establishProjectBaseContext, + establishProjectBaseContextWithRoot, + ProjectBaseContext(..), + BuildTimeSettings(..), + commandLineFlagsToProjectConfig, + + -- * Pre-build phase: decide what to do. + withInstallPlan, + runProjectPreBuildPhase, + ProjectBuildContext(..), + + -- ** Selecting what targets we mean + readTargetSelectors, + reportTargetSelectorProblems, + resolveTargets, + TargetsMap, + allTargetSelectors, + uniqueTargetSelectors, + TargetSelector(..), + TargetImplicitCwd(..), + PackageId, + AvailableTarget(..), + AvailableTargetStatus(..), + TargetRequested(..), + ComponentName(..), + ComponentKind(..), + ComponentTarget(..), + SubComponentTarget(..), + selectComponentTargetBasic, + distinctTargetComponents, + -- ** Utils for selecting targets + filterTargetsKind, + filterTargetsKindWith, + selectBuildableTargets, + selectBuildableTargetsWith, + selectBuildableTargets', + selectBuildableTargetsWith', + forgetTargetsDetail, + + -- ** Adjusting the plan + pruneInstallPlanToTargets, + TargetAction(..), + pruneInstallPlanToDependencies, + CannotPruneDependencies(..), + printPlan, + + -- * Build phase: now do it. + runProjectBuildPhase, + + -- * Post build actions + runProjectPostBuildPhase, + dieOnBuildFailures, + + -- * Dummy projects + establishDummyProjectBaseContext, + establishDummyDistDirLayout, + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude +import Distribution.Compat.Directory + ( makeAbsolute ) + +import Distribution.Client.ProjectConfig +import Distribution.Client.ProjectPlanning + hiding ( pruneInstallPlanToTargets ) +import qualified Distribution.Client.ProjectPlanning as ProjectPlanning + ( pruneInstallPlanToTargets ) +import Distribution.Client.ProjectPlanning.Types +import Distribution.Client.ProjectBuilding +import Distribution.Client.ProjectPlanOutput + +import Distribution.Client.TargetProblem + ( TargetProblem (..) ) +import Distribution.Client.Types + ( GenericReadyPackage(..), UnresolvedSourcePackage + , PackageSpecifier(..) + , SourcePackageDb(..) + , WriteGhcEnvironmentFilesPolicy(..) + , PackageLocation(..) + , DocsResult(..) + , TestsResult(..) ) +import Distribution.Solver.Types.PackageIndex + ( lookupPackageName ) +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.TargetSelector + ( TargetSelector(..), TargetImplicitCwd(..) + , ComponentKind(..), componentKind + , readTargetSelectors, reportTargetSelectorProblems ) +import Distribution.Client.DistDirLayout + +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.Config (getCabalDir) +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 ) + +import Distribution.Solver.Types.OptionalStanza + +import Distribution.Package +import Distribution.Types.Flag + ( FlagAssignment, showFlagAssignment, diffFlagAssignment ) +import Distribution.Simple.LocalBuildInfo + ( ComponentName(..), pkgComponents ) +import Distribution.Simple.Flag + ( fromFlagOrDefault, flagToMaybe ) +import qualified Distribution.Simple.Setup as Setup +import Distribution.Simple.Command (commandShowOptions) +import Distribution.Simple.Configure (computeEffectiveProfiling) + +import Distribution.Simple.Utils + ( die', warn, notice, noticeNoWrap, debugNoWrap, createDirectoryIfMissingVerbose, ordNub ) +import Distribution.Verbosity +import Distribution.Version + ( mkVersion ) +import Distribution.Simple.Compiler + ( compilerCompatVersion, showCompilerId, compilerId, compilerInfo + , OptimisationLevel(..)) +import Distribution.Utils.NubList + ( fromNubList ) +import Distribution.System + ( Platform(Platform) ) + +import qualified Data.List.NonEmpty as NE +import qualified Data.Set as Set +import qualified Data.Map as Map +import Control.Exception ( assert ) +#ifdef MIN_VERSION_unix +import System.Posix.Signals (sigKILL, sigSEGV) +#endif + + +-- | Tracks what command is being executed, because we need to hide this somewhere +-- for cases that need special handling (usually for error reporting). +data CurrentCommand = InstallCommand | HaddockCommand | OtherCommand + deriving (Show, Eq) + +-- | This holds the context of a project prior to solving: the content of the +-- @cabal.project@ and all the local package @.cabal@ files. +-- +data ProjectBaseContext = ProjectBaseContext { + distDirLayout :: DistDirLayout, + cabalDirLayout :: CabalDirLayout, + projectConfig :: ProjectConfig, + localPackages :: [PackageSpecifier UnresolvedSourcePackage], + buildSettings :: BuildTimeSettings, + currentCommand :: CurrentCommand + } + +establishProjectBaseContext + :: Verbosity + -> ProjectConfig + -> CurrentCommand + -> IO ProjectBaseContext +establishProjectBaseContext verbosity cliConfig currentCommand = do + projectRoot <- either throwIO return =<< findProjectRoot Nothing mprojectFile + establishProjectBaseContextWithRoot verbosity cliConfig projectRoot currentCommand + where + mprojectFile = Setup.flagToMaybe projectConfigProjectFile + ProjectConfigShared { projectConfigProjectFile} = projectConfigShared cliConfig + +-- | Like 'establishProjectBaseContext' but doesn't search for project root. +establishProjectBaseContextWithRoot + :: Verbosity + -> ProjectConfig + -> ProjectRoot + -> CurrentCommand + -> IO ProjectBaseContext +establishProjectBaseContextWithRoot verbosity cliConfig projectRoot currentCommand = do + cabalDir <- getCabalDir + + let distDirLayout = defaultDistDirLayout projectRoot mdistDirectory + + httpTransport <- configureTransport verbosity + (fromNubList . projectConfigProgPathExtra $ projectConfigShared cliConfig) + (flagToMaybe . projectConfigHttpTransport $ projectConfigBuildOnly cliConfig) + + (projectConfig, localPackages) <- + rebuildProjectConfig verbosity + httpTransport + distDirLayout + cliConfig + + let ProjectConfigBuildOnly { + projectConfigLogsDir + } = projectConfigBuildOnly projectConfig + + ProjectConfigShared { + projectConfigStoreDir + } = projectConfigShared projectConfig + + mlogsDir = Setup.flagToMaybe projectConfigLogsDir + mstoreDir <- sequenceA $ makeAbsolute + <$> Setup.flagToMaybe projectConfigStoreDir + let cabalDirLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir + + buildSettings = resolveBuildTimeSettings + verbosity cabalDirLayout + projectConfig + + -- https://github.com/haskell/cabal/issues/6013 + when (null (projectPackages projectConfig) && null (projectPackagesOptional projectConfig)) $ + warn verbosity "There are no packages or optional-packages in the project" + + return ProjectBaseContext { + distDirLayout, + cabalDirLayout, + projectConfig, + localPackages, + buildSettings, + currentCommand + } + where + mdistDirectory = Setup.flagToMaybe projectConfigDistDir + ProjectConfigShared { projectConfigDistDir } = projectConfigShared cliConfig + + +-- | This holds the context between the pre-build, build and post-build phases. +-- +data ProjectBuildContext = ProjectBuildContext { + -- | This is the improved plan, before we select a plan subset based on + -- the build targets, and before we do the dry-run. So this contains + -- all packages in the project. + elaboratedPlanOriginal :: ElaboratedInstallPlan, + + -- | This is the 'elaboratedPlanOriginal' after we select a plan subset + -- and do the dry-run phase to find out what is up-to or out-of date. + -- This is the plan that will be executed during the build phase. So + -- this contains only a subset of packages in the project. + elaboratedPlanToExecute:: ElaboratedInstallPlan, + + -- | The part of the install plan that's shared between all packages in + -- the plan. This does not change between the two plan variants above, + -- so there is just the one copy. + elaboratedShared :: ElaboratedSharedConfig, + + -- | The result of the dry-run phase. This tells us about each member of + -- the 'elaboratedPlanToExecute'. + pkgsBuildStatus :: BuildStatusMap, + + -- | The targets selected by @selectPlanSubset@. This is useful eg. in + -- CmdRun, where we need a valid target to execute. + targetsMap :: TargetsMap + } + + +-- | Pre-build phase: decide what to do. +-- +withInstallPlan + :: Verbosity + -> ProjectBaseContext + -> (ElaboratedInstallPlan -> ElaboratedSharedConfig -> IO a) + -> IO a +withInstallPlan + verbosity + ProjectBaseContext { + distDirLayout, + cabalDirLayout, + projectConfig, + localPackages + } + action = do + -- Take the project configuration and make a plan for how to build + -- everything in the project. This is independent of any specific targets + -- the user has asked for. + -- + (elaboratedPlan, _, elaboratedShared, _, _) <- + rebuildInstallPlan verbosity + distDirLayout cabalDirLayout + projectConfig + localPackages + action elaboratedPlan elaboratedShared + +runProjectPreBuildPhase + :: Verbosity + -> ProjectBaseContext + -> (ElaboratedInstallPlan -> IO (ElaboratedInstallPlan, TargetsMap)) + -> IO ProjectBuildContext +runProjectPreBuildPhase + verbosity + ProjectBaseContext { + distDirLayout, + cabalDirLayout, + projectConfig, + localPackages + } + selectPlanSubset = do + -- Take the project configuration and make a plan for how to build + -- everything in the project. This is independent of any specific targets + -- the user has asked for. + -- + (elaboratedPlan, _, elaboratedShared, _, _) <- + rebuildInstallPlan verbosity + distDirLayout cabalDirLayout + projectConfig + localPackages + + -- The plan for what to do is represented by an 'ElaboratedInstallPlan' + + -- Now given the specific targets the user has asked for, decide + -- which bits of the plan we will want to execute. + -- + (elaboratedPlan', targets) <- selectPlanSubset elaboratedPlan + + -- Check which packages need rebuilding. + -- This also gives us more accurate reasons for the --dry-run output. + -- + pkgsBuildStatus <- rebuildTargetsDryRun distDirLayout elaboratedShared + elaboratedPlan' + + -- Improve the plan by marking up-to-date packages as installed. + -- + let elaboratedPlan'' = improveInstallPlanWithUpToDatePackages + pkgsBuildStatus elaboratedPlan' + debugNoWrap verbosity (InstallPlan.showInstallPlan elaboratedPlan'') + + return ProjectBuildContext { + elaboratedPlanOriginal = elaboratedPlan, + elaboratedPlanToExecute = elaboratedPlan'', + elaboratedShared, + pkgsBuildStatus, + targetsMap = targets + } + + +-- | Build phase: now do it. +-- +-- Execute all or parts of the description of what to do to build or +-- rebuild the various packages needed. +-- +runProjectBuildPhase :: Verbosity + -> ProjectBaseContext + -> ProjectBuildContext + -> IO BuildOutcomes +runProjectBuildPhase _ ProjectBaseContext{buildSettings} _ + | buildSettingDryRun buildSettings + = return Map.empty + +runProjectBuildPhase verbosity + ProjectBaseContext{..} ProjectBuildContext {..} = + fmap (Map.union (previousBuildOutcomes pkgsBuildStatus)) $ + rebuildTargets verbosity + distDirLayout + (cabalStoreDirLayout cabalDirLayout) + elaboratedPlanToExecute + elaboratedShared + pkgsBuildStatus + buildSettings + where + previousBuildOutcomes :: BuildStatusMap -> BuildOutcomes + previousBuildOutcomes = + Map.mapMaybe $ \status -> case status of + BuildStatusUpToDate buildSuccess -> Just (Right buildSuccess) + --TODO: [nice to have] record build failures persistently + _ -> Nothing + +-- | Post-build phase: various administrative tasks +-- +-- Update bits of state based on the build outcomes and report any failures. +-- +runProjectPostBuildPhase :: Verbosity + -> ProjectBaseContext + -> ProjectBuildContext + -> BuildOutcomes + -> IO () +runProjectPostBuildPhase _ ProjectBaseContext{buildSettings} _ _ + | buildSettingDryRun buildSettings + = return () + +runProjectPostBuildPhase verbosity + ProjectBaseContext {..} bc@ProjectBuildContext {..} + buildOutcomes = do + -- Update other build artefacts + -- TODO: currently none, but could include: + -- - bin symlinks/wrappers + -- - haddock/hoogle/ctags indexes + -- - delete stale lib registrations + -- - delete stale package dirs + + postBuildStatus <- updatePostBuildProjectStatus + verbosity + distDirLayout + elaboratedPlanOriginal + pkgsBuildStatus + buildOutcomes + + -- Write the .ghc.environment file (if allowed by the env file write policy). + let writeGhcEnvFilesPolicy = + projectConfigWriteGhcEnvironmentFilesPolicy . projectConfigShared + $ projectConfig + + shouldWriteGhcEnvironment :: Bool + shouldWriteGhcEnvironment = + case fromFlagOrDefault NeverWriteGhcEnvironmentFiles + writeGhcEnvFilesPolicy + of + AlwaysWriteGhcEnvironmentFiles -> True + NeverWriteGhcEnvironmentFiles -> False + WriteGhcEnvironmentFilesOnlyForGhc844AndNewer -> + let compiler = pkgConfigCompiler elaboratedShared + ghcCompatVersion = compilerCompatVersion GHC compiler + in maybe False (>= mkVersion [8,4,4]) ghcCompatVersion + + when shouldWriteGhcEnvironment $ + void $ writePlanGhcEnvironment (distProjectRootDirectory distDirLayout) + elaboratedPlanOriginal + elaboratedShared + postBuildStatus + + -- Write the build reports + writeBuildReports buildSettings bc elaboratedPlanToExecute buildOutcomes + + -- Finally if there were any build failures then report them and throw + -- an exception to terminate the program + dieOnBuildFailures verbosity currentCommand elaboratedPlanToExecute buildOutcomes + + -- Note that it is a deliberate design choice that the 'buildTargets' is + -- not passed to phase 1, and the various bits of input config is not + -- passed to phase 2. + -- + -- We make the install plan without looking at the particular targets the + -- user asks us to build. The set of available things we can build is + -- discovered from the env and config and is used to make the install plan. + -- The targets just tell us which parts of the install plan to execute. + -- + -- Conversely, executing the plan does not directly depend on any of the + -- input config. The bits that are needed (or better, the decisions based + -- on it) all go into the install plan. + + -- Notionally, the 'BuildFlags' should be things that do not affect what + -- we build, just how we do it. These ones of course do + + +------------------------------------------------------------------------------ +-- Taking targets into account, selecting what to build +-- + +-- | The set of components to build, represented as a mapping from 'UnitId's +-- to the 'ComponentTarget's within the unit that will be selected +-- (e.g. selected to build, test or repl). +-- +-- Associated with each 'ComponentTarget' is the set of 'TargetSelector's that +-- matched this target. Typically this is exactly one, but in general it is +-- possible to for different selectors to match the same target. This extra +-- information is primarily to help make helpful error messages. +-- +type TargetsMap = Map UnitId [(ComponentTarget, NonEmpty TargetSelector)] + +-- | Get all target selectors. +allTargetSelectors :: TargetsMap -> [TargetSelector] +allTargetSelectors = concatMap (NE.toList . snd) . concat . Map.elems + +-- | Get all unique target selectors. +uniqueTargetSelectors :: TargetsMap -> [TargetSelector] +uniqueTargetSelectors = ordNub . allTargetSelectors + +-- | Given a set of 'TargetSelector's, resolve which 'UnitId's and +-- 'ComponentTarget's they ought to refer to. +-- +-- The idea is that every user target identifies one or more roots in the +-- 'ElaboratedInstallPlan', which we will use to determine the closure +-- of what packages need to be built, dropping everything from the plan +-- that is unnecessary. This closure and pruning is done by +-- 'pruneInstallPlanToTargets' and this needs to be told the roots in terms +-- of 'UnitId's and the 'ComponentTarget's within those. +-- +-- This means we first need to translate the 'TargetSelector's into the +-- 'UnitId's and 'ComponentTarget's. This translation has to be different for +-- the different command line commands, like @build@, @repl@ etc. For example +-- the command @build pkgfoo@ could select a different set of components in +-- pkgfoo than @repl pkgfoo@. The @build@ command would select any library and +-- all executables, whereas @repl@ would select the library or a single +-- executable. Furthermore, both of these examples could fail, and fail in +-- different ways and each needs to be able to produce helpful error messages. +-- +-- So 'resolveTargets' takes two helpers: one to select the targets to be used +-- by user targets that refer to a whole package ('TargetPackage'), and +-- another to check user targets that refer to a component (or a module or +-- file within a component). These helpers can fail, and use their own error +-- type. Both helpers get given the 'AvailableTarget' info about the +-- component(s). +-- +-- While commands vary quite a bit in their behaviour about which components to +-- select for a whole-package target, most commands have the same behaviour for +-- checking a user target that refers to a specific component. To help with +-- this commands can use 'selectComponentTargetBasic', either directly or as +-- a basis for their own @selectComponentTarget@ implementation. +-- +resolveTargets :: forall err. + (forall k. TargetSelector + -> [AvailableTarget k] + -> Either (TargetProblem err) [k]) + -> (forall k. SubComponentTarget + -> AvailableTarget k + -> Either (TargetProblem err) k ) + -> ElaboratedInstallPlan + -> Maybe (SourcePackageDb) + -> [TargetSelector] + -> Either [TargetProblem err] TargetsMap +resolveTargets selectPackageTargets selectComponentTarget + installPlan mPkgDb = + fmap mkTargetsMap + . either (Left . toList) Right + . checkErrors + . map (\ts -> (,) ts <$> checkTarget ts) + where + mkTargetsMap :: [(TargetSelector, [(UnitId, ComponentTarget)])] + -> TargetsMap + mkTargetsMap targets = + Map.map nubComponentTargets + $ Map.fromListWith (<>) + [ (uid, [(ct, ts)]) + | (ts, cts) <- targets + , (uid, ct) <- cts ] + + AvailableTargetIndexes{..} = availableTargetIndexes installPlan + + checkTarget :: TargetSelector -> Either (TargetProblem err) [(UnitId, ComponentTarget)] + + -- We can ask to build any whole package, project-local or a dependency + checkTarget bt@(TargetPackage _ [pkgid] mkfilter) + | Just ats <- fmap (maybe id filterTargetsKind mkfilter) + $ Map.lookup pkgid availableTargetsByPackageId + = fmap (componentTargets WholeComponent) + $ selectPackageTargets bt ats + + | otherwise + = Left (TargetProblemNoSuchPackage pkgid) + + checkTarget (TargetPackage _ pkgids _) + = error ("TODO: add support for multiple packages in a directory. Got\n" + ++ unlines (map prettyShow pkgids)) + -- For the moment this error cannot happen here, because it gets + -- detected when the package config is being constructed. This case + -- will need handling properly when we do add support. + -- + -- TODO: how should this use case play together with the + -- '--cabal-file' option of 'configure' which allows using multiple + -- .cabal files for a single package? + + checkTarget bt@(TargetAllPackages mkfilter) = + fmap (componentTargets WholeComponent) + . selectPackageTargets bt + . maybe id filterTargetsKind mkfilter + . filter availableTargetLocalToProject + $ concat (Map.elems availableTargetsByPackageId) + + checkTarget (TargetComponent pkgid cname subtarget) + | Just ats <- Map.lookup (pkgid, cname) + availableTargetsByPackageIdAndComponentName + = fmap (componentTargets subtarget) + $ selectComponentTargets subtarget ats + + | Map.member pkgid availableTargetsByPackageId + = Left (TargetProblemNoSuchComponent pkgid cname) + + | otherwise + = Left (TargetProblemNoSuchPackage pkgid) + + checkTarget (TargetComponentUnknown pkgname ecname subtarget) + | Just ats <- case ecname of + Left ucname -> + Map.lookup (pkgname, ucname) + availableTargetsByPackageNameAndUnqualComponentName + Right cname -> + Map.lookup (pkgname, cname) + availableTargetsByPackageNameAndComponentName + = fmap (componentTargets subtarget) + $ selectComponentTargets subtarget ats + + | Map.member pkgname availableTargetsByPackageName + = Left (TargetProblemUnknownComponent pkgname ecname) + + | otherwise + = Left (TargetNotInProject pkgname) + + checkTarget bt@(TargetPackageNamed pkgname mkfilter) + | Just ats <- fmap (maybe id filterTargetsKind mkfilter) + $ Map.lookup pkgname availableTargetsByPackageName + = fmap (componentTargets WholeComponent) + . selectPackageTargets bt + $ ats + + | Just SourcePackageDb{ packageIndex } <- mPkgDb + , let pkg = lookupPackageName packageIndex pkgname + , not (null pkg) + = Left (TargetAvailableInIndex pkgname) + + | otherwise + = Left (TargetNotInProject pkgname) + + componentTargets :: SubComponentTarget + -> [(b, ComponentName)] + -> [(b, ComponentTarget)] + componentTargets subtarget = + map (fmap (\cname -> ComponentTarget cname subtarget)) + + selectComponentTargets :: SubComponentTarget + -> [AvailableTarget k] + -> Either (TargetProblem err) [k] + selectComponentTargets subtarget = + either (Left . NE.head) Right + . checkErrors + . map (selectComponentTarget subtarget) + + checkErrors :: [Either e a] -> Either (NonEmpty e) [a] + checkErrors = (\(es, xs) -> case es of { [] -> Right xs; (e:es') -> Left (e:|es') }) + . partitionEithers + + +data AvailableTargetIndexes = AvailableTargetIndexes { + availableTargetsByPackageIdAndComponentName + :: AvailableTargetsMap (PackageId, ComponentName), + + availableTargetsByPackageId + :: AvailableTargetsMap PackageId, + + availableTargetsByPackageName + :: AvailableTargetsMap PackageName, + + availableTargetsByPackageNameAndComponentName + :: AvailableTargetsMap (PackageName, ComponentName), + + availableTargetsByPackageNameAndUnqualComponentName + :: AvailableTargetsMap (PackageName, UnqualComponentName) + } +type AvailableTargetsMap k = Map k [AvailableTarget (UnitId, ComponentName)] + +-- We define a bunch of indexes to help 'resolveTargets' with resolving +-- 'TargetSelector's to specific 'UnitId's. +-- +-- They are all derived from the 'availableTargets' index. +-- The 'availableTargetsByPackageIdAndComponentName' is just that main index, +-- while the others are derived by re-grouping on the index key. +-- +-- They are all constructed lazily because they are not necessarily all used. +-- +availableTargetIndexes :: ElaboratedInstallPlan -> AvailableTargetIndexes +availableTargetIndexes installPlan = AvailableTargetIndexes{..} + where + availableTargetsByPackageIdAndComponentName :: + Map (PackageId, ComponentName) + [AvailableTarget (UnitId, ComponentName)] + availableTargetsByPackageIdAndComponentName = + availableTargets installPlan + + availableTargetsByPackageId :: + Map PackageId [AvailableTarget (UnitId, ComponentName)] + availableTargetsByPackageId = + Map.mapKeysWith + (++) (\(pkgid, _cname) -> pkgid) + availableTargetsByPackageIdAndComponentName + `Map.union` availableTargetsEmptyPackages + + availableTargetsByPackageName :: + Map PackageName [AvailableTarget (UnitId, ComponentName)] + availableTargetsByPackageName = + Map.mapKeysWith + (++) packageName + availableTargetsByPackageId + + availableTargetsByPackageNameAndComponentName :: + Map (PackageName, ComponentName) + [AvailableTarget (UnitId, ComponentName)] + availableTargetsByPackageNameAndComponentName = + Map.mapKeysWith + (++) (\(pkgid, cname) -> (packageName pkgid, cname)) + availableTargetsByPackageIdAndComponentName + + availableTargetsByPackageNameAndUnqualComponentName :: + Map (PackageName, UnqualComponentName) + [AvailableTarget (UnitId, ComponentName)] + availableTargetsByPackageNameAndUnqualComponentName = + Map.mapKeysWith + (++) (\(pkgid, cname) -> let pname = packageName pkgid + cname' = unqualComponentName pname cname + in (pname, cname')) + availableTargetsByPackageIdAndComponentName + where + unqualComponentName :: + PackageName -> ComponentName -> UnqualComponentName + unqualComponentName pkgname = + fromMaybe (packageNameToUnqualComponentName pkgname) + . componentNameString + + -- Add in all the empty packages. These do not appear in the + -- availableTargetsByComponent map, since that only contains + -- components, so packages with no components are invisible from + -- that perspective. The empty packages need to be there for + -- proper error reporting, so users can select the empty package + -- and then we can report that it is empty, otherwise we falsely + -- report there is no such package at all. + availableTargetsEmptyPackages = + Map.fromList + [ (packageId pkg, []) + | InstallPlan.Configured pkg <- InstallPlan.toList installPlan + , case elabPkgOrComp pkg of + ElabComponent _ -> False + ElabPackage _ -> null (pkgComponents (elabPkgDescription pkg)) + ] + + --TODO: [research required] what if the solution has multiple + -- versions of this package? + -- e.g. due to setup deps or due to multiple independent sets + -- of packages being built (e.g. ghc + ghcjs in a project) + +filterTargetsKind :: ComponentKind -> [AvailableTarget k] -> [AvailableTarget k] +filterTargetsKind ckind = filterTargetsKindWith (== ckind) + +filterTargetsKindWith :: (ComponentKind -> Bool) + -> [AvailableTarget k] -> [AvailableTarget k] +filterTargetsKindWith p ts = + [ t | t@(AvailableTarget _ cname _ _) <- ts + , p (componentKind cname) ] + +selectBuildableTargets :: [AvailableTarget k] -> [k] +selectBuildableTargets = selectBuildableTargetsWith (const True) + +zipBuildableTargetsWith :: (TargetRequested -> Bool) + -> [AvailableTarget k] -> [(k, AvailableTarget k)] +zipBuildableTargetsWith p ts = + [ (k, t) | t@(AvailableTarget _ _ (TargetBuildable k req) _) <- ts, p req ] + +selectBuildableTargetsWith :: (TargetRequested -> Bool) + -> [AvailableTarget k] -> [k] +selectBuildableTargetsWith p = map fst . zipBuildableTargetsWith p + +selectBuildableTargets' :: [AvailableTarget k] -> ([k], [AvailableTarget ()]) +selectBuildableTargets' = selectBuildableTargetsWith' (const True) + +selectBuildableTargetsWith' :: (TargetRequested -> Bool) + -> [AvailableTarget k] -> ([k], [AvailableTarget ()]) +selectBuildableTargetsWith' p = + (fmap . map) forgetTargetDetail . unzip . zipBuildableTargetsWith p + + +forgetTargetDetail :: AvailableTarget k -> AvailableTarget () +forgetTargetDetail = fmap (const ()) + +forgetTargetsDetail :: [AvailableTarget k] -> [AvailableTarget ()] +forgetTargetsDetail = map forgetTargetDetail + +-- | A basic @selectComponentTarget@ implementation to use or pass to +-- 'resolveTargets', that does the basic checks that the component is +-- buildable and isn't a test suite or benchmark that is disabled. This +-- can also be used to do these basic checks as part of a custom impl that +-- +selectComponentTargetBasic :: SubComponentTarget + -> AvailableTarget k + -> Either (TargetProblem a) k +selectComponentTargetBasic subtarget + AvailableTarget { + availableTargetPackageId = pkgid, + availableTargetComponentName = cname, + availableTargetStatus + } = + case availableTargetStatus of + TargetDisabledByUser -> + Left (TargetOptionalStanzaDisabledByUser pkgid cname subtarget) + + TargetDisabledBySolver -> + Left (TargetOptionalStanzaDisabledBySolver pkgid cname subtarget) + + TargetNotLocal -> + Left (TargetComponentNotProjectLocal pkgid cname subtarget) + + TargetNotBuildable -> + Left (TargetComponentNotBuildable pkgid cname subtarget) + + TargetBuildable targetKey _ -> + Right targetKey + +-- | Wrapper around 'ProjectPlanning.pruneInstallPlanToTargets' that adjusts +-- for the extra unneeded info in the 'TargetsMap'. +-- +pruneInstallPlanToTargets :: TargetAction -> TargetsMap + -> ElaboratedInstallPlan -> ElaboratedInstallPlan +pruneInstallPlanToTargets targetActionType targetsMap elaboratedPlan = + assert (Map.size targetsMap > 0) $ + ProjectPlanning.pruneInstallPlanToTargets + targetActionType + (Map.map (map fst) 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 targetsMap = + Set.fromList [ (uid, cname) + | (uid, cts) <- Map.toList targetsMap + , (ComponentTarget cname _, _) <- cts ] + + +------------------------------------------------------------------------------ +-- Displaying what we plan to do +-- + +-- | Print a user-oriented presentation of the install plan, indicating what +-- will be built. +-- +printPlan :: Verbosity + -> ProjectBaseContext + -> ProjectBuildContext + -> IO () +printPlan verbosity + ProjectBaseContext { + buildSettings = BuildTimeSettings{buildSettingDryRun}, + projectConfig = ProjectConfig { + projectConfigLocalPackages = + PackageConfig {packageConfigOptimization} + } + } + ProjectBuildContext { + elaboratedPlanToExecute = elaboratedPlan, + elaboratedShared, + pkgsBuildStatus + } + + | null pkgs + = notice verbosity "Up to date" + + | otherwise + = noticeNoWrap verbosity $ unlines $ + (showBuildProfile ++ "In order, the following " + ++ wouldWill ++ " be built" + ++ ifNormal " (use -v for more details)" ++ ":") + : map showPkgAndReason pkgs + + where + pkgs = InstallPlan.executionOrder elaboratedPlan + + ifVerbose s | verbosity >= verbose = s + | otherwise = "" + + ifNormal s | verbosity >= verbose = "" + | otherwise = s + + wouldWill | buildSettingDryRun = "would" + | otherwise = "will" + + showPkgAndReason :: ElaboratedReadyPackage -> String + showPkgAndReason (ReadyPackage elab) = unwords $ filter (not . null) $ + [ " -" + , if verbosity >= deafening + then prettyShow (installedUnitId elab) + else prettyShow (packageId elab) + , case elabPkgOrComp elab of + ElabPackage pkg -> showTargets elab ++ ifVerbose (showStanzas (pkgStanzasEnabled pkg)) + ElabComponent comp -> + "(" ++ showComp elab comp ++ ")" + , showFlagAssignment (nonDefaultFlags elab) + , showConfigureFlags elab + , let buildStatus = pkgsBuildStatus Map.! installedUnitId elab + in "(" ++ showBuildStatus buildStatus ++ ")" + ] + + showComp :: ElaboratedConfiguredPackage -> ElaboratedComponent -> String + showComp elab comp = + maybe "custom" prettyShow (compComponentName comp) ++ + if Map.null (elabInstantiatedWith elab) + then "" + else " with " ++ + intercalate ", " + -- TODO: Abbreviate the UnitIds + [ prettyShow k ++ "=" ++ prettyShow v + | (k,v) <- Map.toList (elabInstantiatedWith elab) ] + + nonDefaultFlags :: ElaboratedConfiguredPackage -> FlagAssignment + nonDefaultFlags elab = + elabFlagAssignment elab `diffFlagAssignment` elabFlagDefaults elab + + showTargets :: ElaboratedConfiguredPackage -> String + showTargets elab + | null (elabBuildTargets elab) = "" + | otherwise + = "(" + ++ intercalate ", " [ showComponentTarget (packageId elab) t + | t <- elabBuildTargets elab ] + ++ ")" + + showConfigureFlags :: ElaboratedConfiguredPackage -> String + showConfigureFlags elab = + let fullConfigureFlags + = setupHsConfigureFlags + (ReadyPackage elab) + elaboratedShared + verbosity + "$builddir" + -- | Given a default value @x@ for a flag, nub @Flag x@ + -- into @NoFlag@. This gives us a tidier command line + -- rendering. + nubFlag :: Eq a => a -> Setup.Flag a -> Setup.Flag a + nubFlag x (Setup.Flag x') | x == x' = Setup.NoFlag + nubFlag _ f = f + + (tryLibProfiling, tryExeProfiling) = + computeEffectiveProfiling fullConfigureFlags + + partialConfigureFlags + = mempty { + configProf = + nubFlag False (configProf fullConfigureFlags), + configProfExe = + nubFlag tryExeProfiling (configProfExe fullConfigureFlags), + configProfLib = + nubFlag tryLibProfiling (configProfLib fullConfigureFlags) + -- Maybe there are more we can add + } + -- Not necessary to "escape" it, it's just for user output + in unwords . ("":) $ + commandShowOptions + (Setup.configureCommand (pkgConfigCompilerProgs elaboratedShared)) + partialConfigureFlags + + showBuildStatus :: BuildStatus -> String + showBuildStatus status = case status of + BuildStatusPreExisting -> "existing package" + BuildStatusInstalled -> "already installed" + BuildStatusDownload {} -> "requires download & build" + BuildStatusUnpack {} -> "requires build" + BuildStatusRebuild _ rebuild -> case rebuild of + BuildStatusConfigure + (MonitoredValueChanged _) -> "configuration changed" + BuildStatusConfigure mreason -> showMonitorChangedReason mreason + BuildStatusBuild _ buildreason -> case buildreason of + BuildReasonDepsRebuilt -> "dependency rebuilt" + BuildReasonFilesChanged + mreason -> showMonitorChangedReason mreason + BuildReasonExtraTargets _ -> "additional components to build" + BuildReasonEphemeralTargets -> "ephemeral targets" + BuildStatusUpToDate {} -> "up to date" -- doesn't happen + + showMonitorChangedReason :: MonitorChangedReason a -> String + showMonitorChangedReason (MonitoredFileChanged file) = + "file " ++ file ++ " changed" + showMonitorChangedReason (MonitoredValueChanged _) = "value changed" + showMonitorChangedReason MonitorFirstRun = "first run" + showMonitorChangedReason MonitorCorruptCache = + "cannot read state cache" + + showBuildProfile :: String + showBuildProfile = "Build profile: " ++ unwords [ + "-w " ++ (showCompilerId . pkgConfigCompiler) elaboratedShared, + "-O" ++ (case packageConfigOptimization of + Setup.Flag NoOptimisation -> "0" + Setup.Flag NormalOptimisation -> "1" + Setup.Flag MaximumOptimisation -> "2" + Setup.NoFlag -> "1")] + ++ "\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 + 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 $ 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. + +-- | If there are build failures then report them and throw an exception. +-- +dieOnBuildFailures :: Verbosity -> CurrentCommand + -> ElaboratedInstallPlan -> BuildOutcomes -> IO () +dieOnBuildFailures verbosity currentCommand plan buildOutcomes + | null failures = return () + + | isSimpleCase = exitFailure + + | otherwise = do + -- For failures where we have a build log, print the log plus a header + sequence_ + [ do notice verbosity $ + '\n' : renderFailureDetail False pkg reason + ++ "\nBuild log ( " ++ logfile ++ " ):" + readFile logfile >>= noticeNoWrap verbosity + | (pkg, ShowBuildSummaryAndLog reason logfile) + <- failuresClassification + ] + + -- For all failures, print either a short summary (if we showed the + -- build log) or all details + dieIfNotHaddockFailure verbosity $ unlines + [ case failureClassification of + ShowBuildSummaryAndLog reason _ + | verbosity > normal + -> renderFailureDetail mentionDepOf pkg reason + + | otherwise + -> renderFailureSummary mentionDepOf pkg reason + ++ ". See the build log above for details." + + ShowBuildSummaryOnly reason -> + renderFailureDetail mentionDepOf pkg reason + + | let mentionDepOf = verbosity <= normal + , (pkg, failureClassification) <- failuresClassification ] + where + failures :: [(UnitId, BuildFailure)] + failures = [ (pkgid, failure) + | (pkgid, Left failure) <- Map.toList buildOutcomes ] + + failuresClassification :: [(ElaboratedConfiguredPackage, BuildFailurePresentation)] + failuresClassification = + [ (pkg, classifyBuildFailure failure) + | (pkgid, failure) <- failures + , case buildFailureReason failure of + DependentFailed {} -> verbosity > normal + _ -> True + , InstallPlan.Configured pkg <- + maybeToList (InstallPlan.lookup plan pkgid) + ] + + dieIfNotHaddockFailure :: Verbosity -> String -> IO () + dieIfNotHaddockFailure + | currentCommand == HaddockCommand = die' + | all isHaddockFailure failuresClassification = warn + | otherwise = die' + where + isHaddockFailure + (_, ShowBuildSummaryOnly (HaddocksFailed _) ) = True + isHaddockFailure + (_, ShowBuildSummaryAndLog (HaddocksFailed _) _) = True + isHaddockFailure + _ = False + + + classifyBuildFailure :: BuildFailure -> BuildFailurePresentation + classifyBuildFailure BuildFailure { + buildFailureReason = reason, + buildFailureLogFile = mlogfile + } = + maybe (ShowBuildSummaryOnly reason) + (ShowBuildSummaryAndLog reason) $ do + logfile <- mlogfile + e <- buildFailureException reason + ExitFailure 1 <- fromException e + return logfile + + -- Special case: we don't want to report anything complicated in the case + -- of just doing build on the current package, since it's clear from + -- context which package failed. + -- + -- We generalise this rule as follows: + -- - if only one failure occurs, and it is in a single root + -- package (i.e. a package with nothing else depending on it) + -- - and that failure is of a kind that always reports enough + -- detail itself (e.g. ghc reporting errors on stdout) + -- - then we do not report additional error detail or context. + -- + isSimpleCase :: Bool + isSimpleCase + | [(pkgid, failure)] <- failures + , [pkg] <- rootpkgs + , installedUnitId pkg == pkgid + , isFailureSelfExplanatory (buildFailureReason failure) + , currentCommand /= InstallCommand + = True + | otherwise + = False + + -- NB: if the Setup script segfaulted or was interrupted, + -- we should give more detailed information. So only + -- assume that exit code 1 is "pedestrian failure." + isFailureSelfExplanatory :: BuildFailureReason -> Bool + isFailureSelfExplanatory (BuildFailed e) + | Just (ExitFailure 1) <- fromException e = True + + isFailureSelfExplanatory (ConfigureFailed e) + | Just (ExitFailure 1) <- fromException e = True + + isFailureSelfExplanatory _ = False + + rootpkgs :: [ElaboratedConfiguredPackage] + rootpkgs = + [ pkg + | InstallPlan.Configured pkg <- InstallPlan.toList plan + , hasNoDependents pkg ] + + ultimateDeps + :: UnitId + -> [InstallPlan.GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage] + ultimateDeps pkgid = + filter (\pkg -> hasNoDependents pkg && installedUnitId pkg /= pkgid) + (InstallPlan.reverseDependencyClosure plan [pkgid]) + + hasNoDependents :: HasUnitId pkg => pkg -> Bool + hasNoDependents = null . InstallPlan.revDirectDeps plan . installedUnitId + + renderFailureDetail :: Bool -> ElaboratedConfiguredPackage -> BuildFailureReason -> String + renderFailureDetail mentionDepOf pkg reason = + renderFailureSummary mentionDepOf pkg reason ++ "." + ++ renderFailureExtraDetail reason + ++ maybe "" showException (buildFailureException reason) + + renderFailureSummary :: Bool -> ElaboratedConfiguredPackage -> BuildFailureReason -> String + renderFailureSummary mentionDepOf pkg reason = + case reason of + DownloadFailed _ -> "Failed to download " ++ pkgstr + UnpackFailed _ -> "Failed to unpack " ++ pkgstr + ConfigureFailed _ -> "Failed to build " ++ pkgstr + BuildFailed _ -> "Failed to build " ++ pkgstr + ReplFailed _ -> "repl failed for " ++ pkgstr + HaddocksFailed _ -> "Failed to build documentation for " ++ pkgstr + TestsFailed _ -> "Tests failed for " ++ pkgstr + BenchFailed _ -> "Benchmarks failed for " ++ pkgstr + InstallFailed _ -> "Failed to build " ++ pkgstr + DependentFailed depid + -> "Failed to build " ++ prettyShow (packageId pkg) + ++ " because it depends on " ++ prettyShow depid + ++ " which itself failed to build" + where + pkgstr = elabConfiguredName verbosity pkg + ++ if mentionDepOf + then renderDependencyOf (installedUnitId pkg) + else "" + + renderFailureExtraDetail :: BuildFailureReason -> String + renderFailureExtraDetail (ConfigureFailed _) = + " The failure occurred during the configure step." + renderFailureExtraDetail (InstallFailed _) = + " The failure occurred during the final install step." + renderFailureExtraDetail _ = + "" + + renderDependencyOf :: UnitId -> String + renderDependencyOf pkgid = + case ultimateDeps pkgid of + [] -> "" + (p1:[]) -> + " (which is required by " ++ elabPlanPackageName verbosity p1 ++ ")" + (p1:p2:[]) -> + " (which is required by " ++ elabPlanPackageName verbosity p1 + ++ " and " ++ elabPlanPackageName verbosity p2 ++ ")" + (p1:p2:_) -> + " (which is required by " ++ elabPlanPackageName verbosity p1 + ++ ", " ++ elabPlanPackageName verbosity p2 + ++ " and others)" + + showException e = case fromException e of + Just (ExitFailure 1) -> "" + +#ifdef MIN_VERSION_unix + -- Note [Positive "signal" exit code] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- What's the business with the test for negative and positive + -- signal values? The API for process specifies that if the + -- process died due to a signal, it returns a *negative* exit + -- code. So that's the negative test. + -- + -- What about the positive test? Well, when we find out that + -- a process died due to a signal, we ourselves exit with that + -- exit code. However, we don't "kill ourselves" with the + -- signal; we just exit with the same code as the signal: thus + -- the caller sees a *positive* exit code. So that's what + -- happens when we get a positive exit code. + Just (ExitFailure n) + | -n == fromIntegral sigSEGV -> + " The build process segfaulted (i.e. SIGSEGV)." + + | n == fromIntegral sigSEGV -> + " The build process terminated with exit code " ++ show n + ++ " which may be because some part of it segfaulted. (i.e. SIGSEGV)." + + | -n == fromIntegral sigKILL -> + " The build process was killed (i.e. SIGKILL). " ++ explanation + + | n == fromIntegral sigKILL -> + " The build process terminated with exit code " ++ show n + ++ " which may be because some part of it was killed " + ++ "(i.e. SIGKILL). " ++ explanation + where + explanation = + "The typical reason for this is that there is not " + ++ "enough memory available (e.g. the OS killed a process " + ++ "using lots of memory)." +#endif + Just (ExitFailure n) -> + " The build process terminated with exit code " ++ show n + + _ -> " The exception was:\n " +#if MIN_VERSION_base(4,8,0) + ++ displayException e +#else + ++ show e +#endif + + buildFailureException :: BuildFailureReason -> Maybe SomeException + buildFailureException reason = + case reason of + DownloadFailed e -> Just e + UnpackFailed e -> Just e + ConfigureFailed e -> Just e + BuildFailed e -> Just e + ReplFailed e -> Just e + HaddocksFailed e -> Just e + TestsFailed e -> Just e + BenchFailed e -> Just e + InstallFailed e -> Just e + DependentFailed _ -> Nothing + +data BuildFailurePresentation = + ShowBuildSummaryOnly BuildFailureReason + | ShowBuildSummaryAndLog BuildFailureReason FilePath + +------------------------------------------------------------------------------- +-- Dummy projects +------------------------------------------------------------------------------- + +-- | Create a dummy project context, without a .cabal or a .cabal.project file +-- (a place where to put a temporary dist directory is still needed) +establishDummyProjectBaseContext + :: Verbosity + -> ProjectConfig + -- ^ Project configuration including the global config if needed + -> DistDirLayout + -- ^ Where to put the dist directory + -> [PackageSpecifier UnresolvedSourcePackage] + -- ^ The packages to be included in the project + -> CurrentCommand + -> IO ProjectBaseContext +establishDummyProjectBaseContext verbosity projectConfig distDirLayout localPackages currentCommand = do + cabalDir <- getCabalDir + + let ProjectConfigBuildOnly { + projectConfigLogsDir + } = projectConfigBuildOnly projectConfig + + ProjectConfigShared { + projectConfigStoreDir + } = projectConfigShared projectConfig + + mlogsDir = flagToMaybe projectConfigLogsDir + mstoreDir = flagToMaybe projectConfigStoreDir + cabalDirLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir + + buildSettings :: BuildTimeSettings + buildSettings = resolveBuildTimeSettings + verbosity cabalDirLayout + projectConfig + + return ProjectBaseContext { + distDirLayout, + cabalDirLayout, + projectConfig, + localPackages, + buildSettings, + currentCommand + } + +establishDummyDistDirLayout :: Verbosity -> ProjectConfig -> FilePath -> IO DistDirLayout +establishDummyDistDirLayout verbosity cliConfig tmpDir = do + let distDirLayout = defaultDistDirLayout projectRoot mdistDirectory + + -- Create the dist directories + createDirectoryIfMissingVerbose verbosity True $ distDirectory distDirLayout + createDirectoryIfMissingVerbose verbosity True $ distProjectCacheDirectory distDirLayout + + return distDirLayout + where + mdistDirectory = flagToMaybe + $ projectConfigDistDir + $ projectConfigShared cliConfig + projectRoot = ProjectRootImplicit tmpDir diff --git a/cabal/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs b/cabal/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs @@ -0,0 +1,971 @@ +{-# LANGUAGE BangPatterns, RecordWildCards, NamedFieldPuns, + DeriveGeneric, DeriveDataTypeable, GeneralizedNewtypeDeriving, + ScopedTypeVariables #-} + +module Distribution.Client.ProjectPlanOutput ( + -- * Plan output + writePlanExternalRepresentation, + + -- * Project status + -- | Several outputs rely on having a general overview of + PostBuildProjectStatus(..), + updatePostBuildProjectStatus, + createPackageEnvironment, + writePlanGhcEnvironment, + argsEquivalentOfGhcEnvironmentFile, + ) where + +import Distribution.Client.ProjectPlanning.Types +import Distribution.Client.ProjectBuilding.Types +import Distribution.Client.DistDirLayout +import Distribution.Client.Types.Repo (Repo(..), RemoteRepo(..)) +import Distribution.Client.Types.PackageLocation (PackageLocation(..)) +import Distribution.Client.Types.ConfiguredId (confInstId) +import Distribution.Client.Types.SourceRepo (SourceRepoMaybe, SourceRepositoryPackage (..)) +import Distribution.Client.HashValue (showHashValue, hashValue) +import Distribution.Client.Version (cabalInstallVersion) + +import qualified Distribution.Client.InstallPlan as InstallPlan +import qualified Distribution.Client.Utils.Json as J +import qualified Distribution.Simple.InstallDirs as InstallDirs + +import qualified Distribution.Solver.Types.ComponentDeps as ComponentDeps + +import Distribution.Package +import Distribution.System +import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import qualified Distribution.PackageDescription as PD +import Distribution.Compiler (CompilerFlavor(GHC, GHCJS)) +import Distribution.Simple.Compiler + ( PackageDBStack, PackageDB(..) + , compilerVersion, compilerFlavor, showCompilerId + , compilerId, CompilerId(..), Compiler ) +import Distribution.Simple.GHC + ( getImplInfo, GhcImplInfo(supportsPkgEnvFiles) + , GhcEnvironmentFileEntry(..), simpleGhcEnvironmentFile + , writeGhcEnvironmentFile ) +import Distribution.Simple.BuildPaths + ( dllExtension, exeExtension, buildInfoPref ) +import qualified Distribution.Compat.Graph as Graph +import Distribution.Compat.Graph (Graph, Node) +import qualified Distribution.Compat.Binary as Binary +import Distribution.Simple.Utils +import Distribution.Types.Version + ( mkVersion ) +import Distribution.Verbosity + +import Prelude () +import Distribution.Client.Compat.Prelude + +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.ByteString.Lazy as BS +import qualified Data.ByteString.Builder as BB + +import System.FilePath +import System.IO + +import Distribution.Simple.Program.GHC (packageDbArgsDb) + +----------------------------------------------------------------------------- +-- Writing plan.json files +-- + +-- | Write out a representation of the elaborated install plan. +-- +-- This is for the benefit of debugging and external tools like editors. +-- +writePlanExternalRepresentation :: DistDirLayout + -> ElaboratedInstallPlan + -> ElaboratedSharedConfig + -> IO () +writePlanExternalRepresentation distDirLayout elaboratedInstallPlan + elaboratedSharedConfig = + writeFileAtomic (distProjectCacheFile distDirLayout "plan.json") $ + BB.toLazyByteString + . J.encodeToBuilder + $ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig + +-- | Renders a subset of the elaborated install plan in a semi-stable JSON +-- format. +-- +encodePlanAsJson :: DistDirLayout -> ElaboratedInstallPlan -> ElaboratedSharedConfig -> J.Value +encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = + --TODO: [nice to have] include all of the sharedPackageConfig and all of + -- the parts of the elaboratedInstallPlan + J.object [ "cabal-version" J..= jdisplay cabalInstallVersion + , "cabal-lib-version" J..= jdisplay cabalVersion + , "compiler-id" J..= (J.String . showCompilerId . pkgConfigCompiler) + elaboratedSharedConfig + , "os" J..= jdisplay os + , "arch" J..= jdisplay arch + , "install-plan" J..= installPlanToJ elaboratedInstallPlan + ] + where + plat :: Platform + plat@(Platform arch os) = pkgConfigPlatform elaboratedSharedConfig + + installPlanToJ :: ElaboratedInstallPlan -> [J.Value] + installPlanToJ = map planPackageToJ . InstallPlan.toList + + planPackageToJ :: ElaboratedPlanPackage -> J.Value + planPackageToJ pkg = + case pkg of + InstallPlan.PreExisting ipi -> installedPackageInfoToJ ipi + InstallPlan.Configured elab -> elaboratedPackageToJ False elab + InstallPlan.Installed elab -> elaboratedPackageToJ True elab + -- Note that the plan.json currently only uses the elaborated plan, + -- not the improved plan. So we will not get the Installed state for + -- 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 ipi = + -- Pre-existing packages lack configuration information such as their flag + -- settings or non-lib components. We only get pre-existing packages for + -- the global/core packages however, so this isn't generally a problem. + -- So these packages are never local to the project. + -- + J.object + [ "type" J..= J.String "pre-existing" + , "id" J..= (jdisplay . installedUnitId) ipi + , "pkg-name" J..= (jdisplay . pkgName . packageId) ipi + , "pkg-version" J..= (jdisplay . pkgVersion . packageId) ipi + , "depends" J..= map jdisplay (installedDepends ipi) + ] + + elaboratedPackageToJ :: Bool -> ElaboratedConfiguredPackage -> J.Value + elaboratedPackageToJ isInstalled elab = + J.object $ + [ "type" J..= J.String (if isInstalled then "installed" + else "configured") + , "id" J..= (jdisplay . installedUnitId) elab + , "pkg-name" J..= (jdisplay . pkgName . packageId) elab + , "pkg-version" J..= (jdisplay . pkgVersion . packageId) elab + , "flags" J..= J.object [ PD.unFlagName fn J..= v + | (fn,v) <- PD.unFlagAssignment (elabFlagAssignment elab) ] + , "style" J..= J.String (style2str (elabLocalToProject elab) (elabBuildStyle elab)) + , "pkg-src" J..= packageLocationToJ (elabPkgSourceLocation elab) + ] ++ + [ "pkg-cabal-sha256" J..= J.String (showHashValue hash) + | Just hash <- [ fmap hashValue (elabPkgDescriptionOverride elab) ] ] ++ + [ "pkg-src-sha256" J..= J.String (showHashValue hash) + | Just hash <- [elabPkgSourceHash elab] ] ++ + (case elabBuildStyle elab of + BuildInplaceOnly -> + ["dist-dir" J..= J.String dist_dir] ++ [buildInfoFileLocation] + BuildAndInstall -> + -- TODO: install dirs? + [] + ) ++ + case elabPkgOrComp elab of + ElabPackage pkg -> + let components = J.object $ + [ comp2str c J..= (J.object $ + [ "depends" J..= map (jdisplay . confInstId) ldeps + , "exe-depends" J..= map (jdisplay . confInstId) edeps + ] ++ + bin_file c) + | (c,(ldeps,edeps)) + <- ComponentDeps.toList $ + ComponentDeps.zip (pkgLibDependencies pkg) + (pkgExeDependencies pkg) ] + in ["components" J..= components] + ElabComponent comp -> + ["depends" J..= map (jdisplay . confInstId) (elabLibDependencies elab) + ,"exe-depends" J..= map jdisplay (elabExeDependencies elab) + ,"component-name" J..= J.String (comp2str (compSolverName comp)) + ] ++ + bin_file (compSolverName comp) + where + -- | 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'. + -- + -- Consumers of `plan.json` can use the nullability of this file location + -- to indicate that the given component uses `build-type: Custom` + -- with an old lib:Cabal version. + buildInfoFileLocation :: J.Pair + buildInfoFileLocation + | elabSetupScriptCliVersion elab < mkVersion [3, 7, 0, 0] + = "build-info" J..= J.Null + | otherwise + = "build-info" J..= J.String (buildInfoPref dist_dir) + + packageLocationToJ :: PackageLocation (Maybe FilePath) -> J.Value + packageLocationToJ pkgloc = + case pkgloc of + LocalUnpackedPackage local -> + J.object [ "type" J..= J.String "local" + , "path" J..= J.String local + ] + LocalTarballPackage local -> + J.object [ "type" J..= J.String "local-tar" + , "path" J..= J.String local + ] + RemoteTarballPackage uri _ -> + J.object [ "type" J..= J.String "remote-tar" + , "uri" J..= J.String (show uri) + ] + RepoTarballPackage repo _ _ -> + J.object [ "type" J..= J.String "repo-tar" + , "repo" J..= repoToJ repo + ] + RemoteSourceRepoPackage srcRepo _ -> + J.object [ "type" J..= J.String "source-repo" + , "source-repo" J..= sourceRepoToJ srcRepo + ] + + repoToJ :: Repo -> J.Value + repoToJ repo = + case repo of + RepoLocalNoIndex{..} -> + J.object [ "type" J..= J.String "local-repo-no-index" + , "path" J..= J.String repoLocalDir + ] + RepoRemote{..} -> + J.object [ "type" J..= J.String "remote-repo" + , "uri" J..= J.String (show (remoteRepoURI repoRemote)) + ] + RepoSecure{..} -> + J.object [ "type" J..= J.String "secure-repo" + , "uri" J..= J.String (show (remoteRepoURI repoRemote)) + ] + + sourceRepoToJ :: SourceRepoMaybe -> J.Value + sourceRepoToJ SourceRepositoryPackage{..} = + J.object $ filter ((/= J.Null) . snd) $ + [ "type" J..= jdisplay srpType + , "location" J..= J.String srpLocation + , "branch" J..= fmap J.String srpBranch + , "tag" J..= fmap J.String srpTag + , "subdir" J..= fmap J.String srpSubdir + ] + + dist_dir :: FilePath + dist_dir = distBuildDirectory distDirLayout + (elabDistDirParams elaboratedSharedConfig elab) + + bin_file :: ComponentDeps.Component -> [J.Pair] + bin_file c = case c of + ComponentDeps.ComponentExe s -> bin_file' s + ComponentDeps.ComponentTest s -> bin_file' s + ComponentDeps.ComponentBench s -> bin_file' s + ComponentDeps.ComponentFLib s -> flib_file' s + _ -> [] + bin_file' s = + ["bin-file" J..= J.String bin] + where + bin = if elabBuildStyle elab == BuildInplaceOnly + then dist_dir "build" prettyShow s prettyShow s <.> exeExtension plat + else InstallDirs.bindir (elabInstallDirs elab) prettyShow s <.> exeExtension plat + + flib_file' :: (Pretty a, Show a) => a -> [J.Pair] + flib_file' s = + ["bin-file" J..= J.String bin] + where + bin = if elabBuildStyle elab == BuildInplaceOnly + then dist_dir "build" prettyShow s ("lib" ++ prettyShow s) <.> dllExtension plat + else InstallDirs.bindir (elabInstallDirs elab) ("lib" ++ prettyShow s) <.> dllExtension plat + + comp2str :: ComponentDeps.Component -> String + comp2str = prettyShow + + style2str :: Bool -> BuildStyle -> String + style2str True _ = "local" + style2str False BuildInplaceOnly = "inplace" + style2str False BuildAndInstall = "global" + + jdisplay :: Pretty a => a -> J.Value + jdisplay = J.String . prettyShow + +----------------------------------------------------------------------------- +-- Project status +-- + +-- So, what is the status of a project after a build? That is, how do the +-- inputs (package source files etc) compare to the output artefacts (build +-- libs, exes etc)? Do the outputs reflect the current values of the inputs +-- or are outputs out of date or invalid? +-- +-- First of all, what do we mean by out-of-date and what do we mean by +-- invalid? We think of the build system as a morally pure function that +-- computes the output artefacts given input values. We say an output artefact +-- is out of date when its value is not the value that would be computed by a +-- build given the current values of the inputs. An output artefact can be +-- out-of-date but still be perfectly usable; it simply correspond to a +-- previous state of the inputs. +-- +-- On the other hand there are cases where output artefacts cannot safely be +-- used. For example libraries and dynamically linked executables cannot be +-- used when the libs they depend on change without them being recompiled +-- themselves. Whether an artefact is still usable depends on what it is, e.g. +-- dynamically linked vs statically linked and on how it gets updated (e.g. +-- only atomically on success or if failure can leave invalid states). We need +-- a definition (or two) that is independent of the kind of artefact and can +-- be computed just in terms of changes in package graphs, but are still +-- useful for determining when particular kinds of artefacts are invalid. +-- +-- Note that when we talk about packages in this context we just mean nodes +-- in the elaborated install plan, which can be components or packages. +-- +-- There's obviously a close connection between packages being out of date and +-- their output artefacts being unusable: most of the time if a package +-- remains out of date at the end of a build then some of its output artefacts +-- will be unusable. That is true most of the time because a build will have +-- attempted to build one of the out-of-date package's dependencies. If the +-- build of the dependency succeeded then it changed output artefacts (like +-- libs) and if it failed then it may have failed after already changing +-- things (think failure after updating some but not all .hi files). +-- +-- There are a few reasons we may end up with still-usable output artefacts +-- for a package even when it remains out of date at the end of a build. +-- Firstly if executing a plan fails then packages can be skipped, and thus we +-- may have packages where all their dependencies were skipped. Secondly we +-- have artefacts like statically linked executables which are not affected by +-- libs they depend on being recompiled. Furthermore, packages can be out of +-- date due to changes in build tools or Setup.hs scripts they depend on, but +-- again libraries or executables in those out-of-date packages remain usable. +-- +-- So we have two useful definitions of invalid. Both are useful, for +-- different purposes, so we will compute both. The first corresponds to the +-- invalid libraries and dynamic executables. We say a package is invalid by +-- changed deps if any of the packages it depends on (via library dep edges) +-- were rebuilt (successfully or unsuccessfully). The second definition +-- corresponds to invalid static executables. We say a package is invalid by +-- a failed build simply if the package was built but unsuccessfully. +-- +-- So how do we find out what packages are out of date or invalid? +-- +-- Obviously we know something for all the packages that were part of the plan +-- that was executed, but that is just a subset since we prune the plan down +-- to the targets and their dependencies. +-- +-- Recall the steps we go though: +-- +-- + starting with the initial improved plan (this is the full project); +-- +-- + prune the plan to the user's build targets; +-- +-- + rebuildTargetsDryRun on the pruned plan giving us a BuildStatusMap +-- covering the pruned subset of the original plan; +-- +-- + execute the plan giving us BuildOutcomes which tell us success/failure +-- for each package. +-- +-- So given that the BuildStatusMap and BuildOutcomes do not cover everything +-- in the original plan, what can they tell us about the original plan? +-- +-- The BuildStatusMap tells us directly that some packages are up to date and +-- others out of date (but only for the pruned subset). But we know that +-- everything that is a reverse dependency of an out-of-date package is itself +-- out-of-date (whether or not it is in the pruned subset). Of course after +-- a build the BuildOutcomes may tell us that some of those out-of-date +-- packages are now up to date (ie a successful build outcome). +-- +-- The difference is packages that are reverse dependencies of out-of-date +-- packages but are not brought up-to-date by the build (i.e. did not have +-- successful outcomes, either because they failed or were not in the pruned +-- subset to be built). We also know which packages were rebuilt, so we can +-- use this to find the now-invalid packages. +-- +-- Note that there are still packages for which we cannot discover full status +-- information. There may be packages outside of the pruned plan that do not +-- depend on packages within the pruned plan that were discovered to be +-- out-of-date. For these packages we do not know if their build artefacts +-- are out-of-date or not. We do know however that they are not invalid, as +-- that's not possible given our definition of invalid. Intuitively it is +-- because we have not disturbed anything that these packages depend on, e.g. +-- we've not rebuilt any libs they depend on. Recall that our widest +-- definition of invalid was only concerned about dependencies on libraries +-- (to cover problems like shared libs or GHC seeing inconsistent .hi files). +-- +-- So our algorithm for out-of-date packages is relatively simple: take the +-- reverse dependency closure in the original improved plan (pre-pruning) of +-- the out-of-date packages (as determined by the BuildStatusMap from the dry +-- run). That gives a set of packages that were definitely out of date after +-- the dry run. Now we remove from this set the packages that the +-- BuildOutcomes tells us are now up-to-date after the build. The remaining +-- set is the out-of-date packages. +-- +-- As for packages that are invalid by changed deps, we start with the plan +-- dependency graph but keep only those edges that point to libraries (so +-- ignoring deps on exes and setup scripts). We take the packages for which a +-- build was attempted (successfully or unsuccessfully, but not counting +-- knock-on failures) and take the reverse dependency closure. We delete from +-- this set all the packages that were built successfully. Note that we do not +-- need to intersect with the out-of-date packages since this follows +-- automatically: all rev deps of packages we attempted to build must have +-- been out of date at the start of the build, and if they were not built +-- successfully then they're still out of date -- meeting our definition of +-- invalid. + + +type PackageIdSet = Set UnitId +type PackagesUpToDate = PackageIdSet + +data PostBuildProjectStatus = PostBuildProjectStatus { + + -- | Packages that are known to be up to date. These were found to be + -- up to date before the build, or they have a successful build outcome + -- afterwards. + -- + -- This does not include any packages outside of the subset of the plan + -- that was executed because we did not check those and so don't know + -- for sure that they're still up to date. + -- + packagesDefinitelyUpToDate :: PackageIdSet, + + -- | Packages that are probably still up to date (and at least not + -- known to be out of date, and certainly not invalid). This includes + -- 'packagesDefinitelyUpToDate' plus packages that were up to date + -- previously and are outside of the subset of the plan that was + -- executed. It excludes 'packagesOutOfDate'. + -- + packagesProbablyUpToDate :: PackageIdSet, + + -- | Packages that are known to be out of date. These are packages + -- that were determined to be out of date before the build, and they + -- do not have a successful build outcome afterwards. + -- + -- Note that this can sometimes include packages outside of the subset + -- of the plan that was executed. For example suppose package A and B + -- depend on C, and A is the target so only A and C are in the subset + -- to be built. Now suppose C is found to have changed, then both A + -- and B are out-of-date before the build and since B is outside the + -- subset to be built then it will remain out of date. + -- + -- Note also that this is /not/ the inverse of + -- 'packagesDefinitelyUpToDate' or 'packagesProbablyUpToDate'. + -- There are packages where we have no information (ones that were not + -- in the subset of the plan that was executed). + -- + packagesOutOfDate :: PackageIdSet, + + -- | Packages that depend on libraries that have changed during the + -- build (either build success or failure). + -- + -- This corresponds to the fact that libraries and dynamic executables + -- are invalid once any of the libs they depend on change. + -- + -- This does include packages that themselves failed (i.e. it is a + -- superset of 'packagesInvalidByFailedBuild'). It does not include + -- changes in dependencies on executables (i.e. build tools). + -- + packagesInvalidByChangedLibDeps :: PackageIdSet, + + -- | Packages that themselves failed during the build (i.e. them + -- directly not a dep). + -- + -- This corresponds to the fact that static executables are invalid + -- in unlucky circumstances such as linking failing half way though, + -- or data file generation failing. + -- + -- This is a subset of 'packagesInvalidByChangedLibDeps'. + -- + packagesInvalidByFailedBuild :: PackageIdSet, + + -- | 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. + -- + -- This is here as a convenience, as strictly speaking it's not status + -- as it's just a function of the original 'ElaboratedInstallPlan'. + -- + packagesLibDepGraph :: Graph (Node UnitId ElaboratedPlanPackage), + + -- | As a convenience for 'Set.intersection' with any of the other + -- 'PackageIdSet's to select only packages that are part of the + -- project locally (i.e. with a local source dir). + -- + packagesBuildLocal :: PackageIdSet, + + -- | As a convenience for 'Set.intersection' with any of the other + -- 'PackageIdSet's to select only packages that are being built + -- in-place within the project (i.e. not destined for the store). + -- + packagesBuildInplace :: PackageIdSet, + + -- | As a convenience for 'Set.intersection' or 'Set.difference' with + -- any of the other 'PackageIdSet's to select only packages that were + -- pre-installed or already in the store prior to the build. + -- + packagesAlreadyInStore :: PackageIdSet + } + +-- | Work out which packages are out of date or invalid after a build. +-- +postBuildProjectStatus :: ElaboratedInstallPlan + -> PackagesUpToDate + -> BuildStatusMap + -> BuildOutcomes + -> PostBuildProjectStatus +postBuildProjectStatus plan previousPackagesUpToDate + pkgBuildStatus buildOutcomes = + PostBuildProjectStatus { + packagesDefinitelyUpToDate, + packagesProbablyUpToDate, + packagesOutOfDate, + packagesInvalidByChangedLibDeps, + packagesInvalidByFailedBuild, + -- convenience stuff + packagesLibDepGraph, + packagesBuildLocal, + packagesBuildInplace, + packagesAlreadyInStore + } + where + packagesDefinitelyUpToDate = + packagesUpToDatePreBuild + `Set.union` + packagesSuccessfulPostBuild + + packagesProbablyUpToDate = + packagesDefinitelyUpToDate + `Set.union` + (previousPackagesUpToDate' `Set.difference` packagesOutOfDatePreBuild) + + packagesOutOfDate = + packagesOutOfDatePreBuild `Set.difference` packagesSuccessfulPostBuild + + packagesInvalidByChangedLibDeps = + packagesDepOnChangedLib `Set.difference` packagesSuccessfulPostBuild + + packagesInvalidByFailedBuild = + packagesFailurePostBuild + + -- Note: if any of the intermediate values below turn out to be useful in + -- their own right then we can simply promote them to the result record + + -- 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.intersection + previousPackagesUpToDate + (InstallPlan.keysSet plan) + + packagesUpToDatePreBuild = + Set.filter + (\ipkgid -> not (lookupBuildStatusRequiresBuild True 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 /up to date/. + (InstallPlan.keysSet plan) + + packagesOutOfDatePreBuild = + Set.fromList . map installedUnitId $ + InstallPlan.reverseDependencyClosure plan + [ ipkgid + | pkg <- InstallPlan.toList plan + , let ipkgid = installedUnitId 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.fromList + [ ikgid | (ikgid, Right _) <- Map.toList buildOutcomes ] + + -- direct failures, not failures due to deps + packagesFailurePostBuild = + Set.fromList + [ ikgid + | (ikgid, Left failure) <- Map.toList buildOutcomes + , case buildFailureReason failure of + DependentFailed _ -> False + _ -> True + ] + + -- Packages that have a library dependency on a package for which a build + -- was attempted + packagesDepOnChangedLib = + Set.fromList . map Graph.nodeKey $ + fromMaybe (error "packagesBuildStatusAfterBuild: broken dep closure") $ + Graph.revClosure packagesLibDepGraph + ( Map.keys + . Map.filter (uncurry buildAttempted) + $ Map.intersectionWith (,) pkgBuildStatus buildOutcomes + ) + + -- The plan graph but only counting dependency-on-library edges + packagesLibDepGraph :: Graph (Node UnitId ElaboratedPlanPackage) + packagesLibDepGraph = + Graph.fromDistinctList + [ Graph.N pkg (installedUnitId 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 + ] + + elabLibDeps :: ElaboratedConfiguredPackage -> [UnitId] + elabLibDeps = map (newSimpleUnitId . confInstId) . 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. + buildAttempted :: BuildStatus -> BuildOutcome -> Bool + -- And not if it didn't need rebuilding in the first place. + buildAttempted buildStatus _buildOutcome + | not (buildStatusRequiresBuild buildStatus) + = False + + -- And not if it was skipped due to a dep failing first. + buildAttempted _ (Left BuildFailure {buildFailureReason}) + | DependentFailed _ <- buildFailureReason + = False + + -- Otherwise, succeeded or failed, yes the build was tried. + buildAttempted _ (Left BuildFailure {}) = True + buildAttempted _ (Right _) = True + + lookupBuildStatusRequiresBuild :: Bool -> UnitId -> Bool + lookupBuildStatusRequiresBuild def ipkgid = + case Map.lookup ipkgid pkgBuildStatus of + Nothing -> def -- Not in the plan subset we did the dry-run on + Just buildStatus -> buildStatusRequiresBuild buildStatus + + packagesBuildLocal :: Set UnitId + packagesBuildLocal = + selectPlanPackageIdSet $ \pkg -> + case pkg of + InstallPlan.PreExisting _ -> False + InstallPlan.Installed _ -> False + InstallPlan.Configured srcpkg -> elabLocalToProject srcpkg + + packagesBuildInplace :: Set UnitId + packagesBuildInplace = + selectPlanPackageIdSet $ \pkg -> + case pkg of + InstallPlan.PreExisting _ -> False + InstallPlan.Installed _ -> False + InstallPlan.Configured srcpkg -> elabBuildStyle srcpkg + == BuildInplaceOnly + packagesAlreadyInStore :: Set UnitId + packagesAlreadyInStore = + selectPlanPackageIdSet $ \pkg -> + case pkg of + InstallPlan.PreExisting _ -> True + InstallPlan.Installed _ -> True + InstallPlan.Configured _ -> False + + selectPlanPackageIdSet + :: (InstallPlan.GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage + -> Bool) + -> Set UnitId + selectPlanPackageIdSet p = Map.keysSet + . Map.filter p + $ InstallPlan.toMap plan + + + +updatePostBuildProjectStatus :: Verbosity + -> DistDirLayout + -> ElaboratedInstallPlan + -> BuildStatusMap + -> BuildOutcomes + -> IO PostBuildProjectStatus +updatePostBuildProjectStatus verbosity distDirLayout + elaboratedInstallPlan + pkgsBuildStatus buildOutcomes = do + + -- Read the previous up-to-date set, update it and write it back + previousUpToDate <- readPackagesUpToDateCacheFile distDirLayout + let currentBuildStatus@PostBuildProjectStatus{..} + = postBuildProjectStatus + elaboratedInstallPlan + previousUpToDate + pkgsBuildStatus + buildOutcomes + let currentUpToDate = packagesProbablyUpToDate + writePackagesUpToDateCacheFile distDirLayout currentUpToDate + + -- Report various possibly interesting things + -- We additionally intersect with the packagesBuildInplace so that + -- we don't show huge numbers of boring packages from the store. + debugNoWrap verbosity $ + "packages definitely up to date: " + ++ displayPackageIdSet (packagesDefinitelyUpToDate + `Set.intersection` packagesBuildInplace) + + debugNoWrap verbosity $ + "packages previously probably up to date: " + ++ displayPackageIdSet (previousUpToDate + `Set.intersection` packagesBuildInplace) + + debugNoWrap verbosity $ + "packages now probably up to date: " + ++ displayPackageIdSet (packagesProbablyUpToDate + `Set.intersection` packagesBuildInplace) + + debugNoWrap verbosity $ + "packages newly up to date: " + ++ displayPackageIdSet (packagesDefinitelyUpToDate + `Set.difference` previousUpToDate + `Set.intersection` packagesBuildInplace) + + debugNoWrap verbosity $ + "packages out to date: " + ++ displayPackageIdSet (packagesOutOfDate + `Set.intersection` packagesBuildInplace) + + debugNoWrap verbosity $ + "packages invalid due to dep change: " + ++ displayPackageIdSet packagesInvalidByChangedLibDeps + + debugNoWrap verbosity $ + "packages invalid due to build failure: " + ++ displayPackageIdSet packagesInvalidByFailedBuild + + return currentBuildStatus + where + displayPackageIdSet = intercalate ", " . map prettyShow . Set.toList + +-- | Helper for reading the cache file. +-- +-- This determines the type and format of the binary cache file. +-- +readPackagesUpToDateCacheFile :: DistDirLayout -> IO PackagesUpToDate +readPackagesUpToDateCacheFile DistDirLayout{distProjectCacheFile} = + handleDoesNotExist Set.empty $ + handleDecodeFailure $ + withBinaryFile (distProjectCacheFile "up-to-date") ReadMode $ \hnd -> + Binary.decodeOrFailIO =<< BS.hGetContents hnd + where + handleDecodeFailure = fmap (either (const Set.empty) id) + +-- | Helper for writing the package up-to-date cache file. +-- +-- This determines the type and format of the binary cache file. +-- +writePackagesUpToDateCacheFile :: DistDirLayout -> PackagesUpToDate -> IO () +writePackagesUpToDateCacheFile DistDirLayout{distProjectCacheFile} upToDate = + writeFileAtomic (distProjectCacheFile "up-to-date") $ + Binary.encode upToDate + +-- | Prepare a package environment that includes all the library dependencies +-- for a plan. +-- +-- When running cabal new-exec, we want to set things up so that the compiler +-- can find all the right packages (and nothing else). This function is +-- intended to do that work. It takes a location where it can write files +-- temporarily, in case the compiler wants to learn this information via the +-- filesystem, and returns any environment variable overrides the compiler +-- needs. +createPackageEnvironment :: Verbosity + -> FilePath + -> ElaboratedInstallPlan + -> ElaboratedSharedConfig + -> PostBuildProjectStatus + -> IO [(String, Maybe String)] +createPackageEnvironment verbosity + path + elaboratedPlan + elaboratedShared + buildStatus + | compilerFlavor (pkgConfigCompiler elaboratedShared) == GHC + = do + envFileM <- writePlanGhcEnvironment + path + elaboratedPlan + elaboratedShared + buildStatus + case envFileM of + Just envFile -> return [("GHC_ENVIRONMENT", Just envFile)] + Nothing -> do + warn verbosity "the configured version of GHC does not support reading package lists from the environment; commands that need the current project's package database are likely to fail" + return [] + | otherwise + = 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 [] + +-- Writing .ghc.environment files +-- + +writePlanGhcEnvironment :: FilePath + -> ElaboratedInstallPlan + -> ElaboratedSharedConfig + -> PostBuildProjectStatus + -> IO (Maybe FilePath) +writePlanGhcEnvironment path + elaboratedInstallPlan + ElaboratedSharedConfig { + pkgConfigCompiler = compiler, + pkgConfigPlatform = platform + } + postBuildStatus + | compilerFlavor compiler == GHC + , supportsPkgEnvFiles (getImplInfo compiler) + --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/ + +writePlanGhcEnvironment _ _ _ _ = return Nothing + +renderGhcEnvironmentFile :: FilePath + -> ElaboratedInstallPlan + -> PostBuildProjectStatus + -> [GhcEnvironmentFileEntry] +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" + ++ "run ghc or ghci and get the environment of the project as a whole.\n" + ++ "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 + packageDBs = relativePackageDBPaths projectRootDir $ + selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan + + +argsEquivalentOfGhcEnvironmentFile + :: Compiler + -> DistDirLayout + -> ElaboratedInstallPlan + -> PostBuildProjectStatus + -> [String] +argsEquivalentOfGhcEnvironmentFile compiler = + case compilerId compiler + of CompilerId GHC _ -> argsEquivalentOfGhcEnvironmentFileGhc + CompilerId GHCJS _ -> argsEquivalentOfGhcEnvironmentFileGhc + CompilerId _ _ -> error "Only GHC and GHCJS are supported" + +-- TODO remove this when we drop support for non-.ghc.env ghc +argsEquivalentOfGhcEnvironmentFileGhc + :: DistDirLayout + -> ElaboratedInstallPlan + -> PostBuildProjectStatus + -> [String] +argsEquivalentOfGhcEnvironmentFileGhc + distDirLayout + elaboratedInstallPlan + postBuildStatus = + clearPackageDbStackFlag + ++ packageDbArgsDb packageDBs + ++ foldMap packageIdFlag packageIds + where + projectRootDir = distProjectRootDirectory distDirLayout + packageIds = selectGhcEnvironmentFileLibraries postBuildStatus + packageDBs = relativePackageDBPaths projectRootDir $ + selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan + -- TODO use proper flags? but packageDbArgsDb is private + clearPackageDbStackFlag = ["-clear-package-db", "-global-package-db"] + packageIdFlag uid = ["-package-id", prettyShow uid] + + +-- We're producing an environment for users to use in ghci, so of course +-- that means libraries only (can't put exes into the ghc package env!). +-- The library environment should be /consistent/ with the environment +-- that each of the packages in the project use (ie same lib versions). +-- So that means all the normal library dependencies of all the things +-- in the project (including deps of exes that are local to the project). +-- We do not however want to include the dependencies of Setup.hs scripts, +-- since these are generally uninteresting but also they need not in +-- general be consistent with the library versions that packages local to +-- the project use (recall that Setup.hs script's deps can be picked +-- independently of other packages in the project). +-- +-- So, our strategy is as follows: +-- +-- produce a dependency graph of all the packages in the install plan, +-- but only consider normal library deps as edges in the graph. Thus we +-- exclude the dependencies on Setup.hs scripts (in the case of +-- per-component granularity) or of Setup.hs scripts (in the case of +-- per-package granularity). Then take a dependency closure, using as +-- roots all the packages/components local to the project. This will +-- exclude Setup scripts and their dependencies. +-- +-- Note: this algorithm will have to be adapted if/when the install plan +-- is extended to cover multiple compilers at once, and may also have to +-- change if we start to treat unshared deps of test suites in a similar +-- way to how we treat Setup.hs script deps (ie being able to pick them +-- independently). +-- +-- Since we had to use all the local packages, including exes, (as roots +-- 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{..} = + case Graph.closure packagesLibDepGraph (Set.toList packagesBuildLocal) of + Nothing -> error "renderGhcEnvironmentFile: broken dep closure" + Just nodes -> [ pkgid | Graph.N pkg pkgid _ <- nodes + , hasUpToDateLib pkg ] + where + hasUpToDateLib planpkg = case planpkg of + -- A pre-existing global lib + InstallPlan.PreExisting _ -> True + + -- A package in the store. Check it's a lib. + InstallPlan.Installed pkg -> elabRequiresRegistration pkg + + -- A package we were installing this time, either destined for the store + -- 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 + + +selectGhcEnvironmentFilePackageDbs :: ElaboratedInstallPlan -> PackageDBStack +selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan = + -- If we have any inplace packages then their package db stack is the + -- one we should use since it'll include the store + the local db but + -- it's certainly possible to have no local inplace packages + -- e.g. just "extra" packages coming from the store. + case (inplacePackages, sourcePackages) of + ([], pkgs) -> checkSamePackageDBs pkgs + (pkgs, _) -> checkSamePackageDBs pkgs + where + checkSamePackageDBs :: [ElaboratedConfiguredPackage] -> PackageDBStack + checkSamePackageDBs pkgs = + case ordNub (map elabBuildPackageDBStack pkgs) of + [packageDbs] -> packageDbs + [] -> [] + _ -> error $ "renderGhcEnvironmentFile: packages with " + ++ "different package db stacks" + -- This should not happen at the moment but will happen as soon + -- as we support projects where we build packages with different + -- compilers, at which point we have to consider how to adapt + -- this feature, e.g. write out multiple env files, one for each + -- compiler / project profile. + + inplacePackages :: [ElaboratedConfiguredPackage] + inplacePackages = + [ srcpkg + | srcpkg <- sourcePackages + , elabBuildStyle srcpkg == BuildInplaceOnly ] + + sourcePackages :: [ElaboratedConfiguredPackage] + sourcePackages = + [ srcpkg + | pkg <- InstallPlan.toList elaboratedInstallPlan + , srcpkg <- maybeToList $ case pkg of + InstallPlan.Configured srcpkg -> Just srcpkg + InstallPlan.Installed srcpkg -> Just srcpkg + InstallPlan.PreExisting _ -> Nothing + ] + +relativePackageDBPaths :: FilePath -> PackageDBStack -> PackageDBStack +relativePackageDBPaths relroot = map (relativePackageDBPath relroot) + +relativePackageDBPath :: FilePath -> PackageDB -> PackageDB +relativePackageDBPath relroot pkgdb = + case pkgdb of + GlobalPackageDB -> GlobalPackageDB + UserPackageDB -> UserPackageDB + SpecificPackageDB path -> SpecificPackageDB relpath + where relpath = makeRelative relroot path diff --git a/cabal/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal/cabal-install/src/Distribution/Client/ProjectPlanning.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -0,0 +1,3978 @@ +{-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns, RankNTypes #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NoMonoLocalBinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} + +-- | Planning how to build everything in a project. +-- +module Distribution.Client.ProjectPlanning ( + -- * elaborated install plan types + ElaboratedInstallPlan, + ElaboratedConfiguredPackage(..), + ElaboratedPlanPackage, + ElaboratedSharedConfig(..), + ElaboratedReadyPackage, + BuildStyle(..), + CabalFileText, + + -- * Producing the elaborated install plan + rebuildProjectConfig, + rebuildInstallPlan, + + -- * Build targets + availableTargets, + AvailableTarget(..), + AvailableTargetStatus(..), + TargetRequested(..), + ComponentTarget(..), + SubComponentTarget(..), + showComponentTarget, + nubComponentTargets, + + -- * Selecting a plan subset + pruneInstallPlanToTargets, + TargetAction(..), + pruneInstallPlanToDependencies, + CannotPruneDependencies(..), + + -- * Utils required for building + pkgHasEphemeralBuildTargets, + elabBuildTargetWholeComponents, + configureCompiler, + + -- * Setup.hs CLI flags for building + setupHsScriptOptions, + setupHsConfigureFlags, + setupHsConfigureArgs, + setupHsBuildFlags, + setupHsBuildArgs, + setupHsReplFlags, + setupHsReplArgs, + setupHsTestFlags, + setupHsTestArgs, + setupHsBenchFlags, + setupHsBenchArgs, + setupHsCopyFlags, + setupHsRegisterFlags, + setupHsHaddockFlags, + setupHsHaddockArgs, + + packageHashInputs, + + -- * Path construction + binDirectoryFor, + binDirectories, + storePackageInstallDirs, + storePackageInstallDirs' + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Distribution.Client.HashValue +import Distribution.Client.HttpUtils +import Distribution.Client.ProjectPlanning.Types as Ty +import Distribution.Client.PackageHash +import Distribution.Client.RebuildMonad +import Distribution.Client.Store +import Distribution.Client.ProjectConfig +import Distribution.Client.ProjectConfig.Legacy +import Distribution.Client.ProjectPlanOutput + +import Distribution.Client.Types +import qualified Distribution.Client.InstallPlan as InstallPlan +import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan +import Distribution.Client.Dependency +import Distribution.Client.Dependency.Types +import qualified Distribution.Client.IndexUtils as IndexUtils +import Distribution.Client.Utils (incVersion) +import Distribution.Client.Targets (userToPackageConstraint) +import Distribution.Client.DistDirLayout +import Distribution.Client.SetupWrapper +import Distribution.Client.JobControl +import Distribution.Client.FetchUtils +import Distribution.Client.Config +import qualified Hackage.Security.Client as Sec +import Distribution.Client.Setup hiding (packageName, cabalVersion) +import Distribution.Utils.NubList +import Distribution.Utils.LogProgress +import Distribution.Utils.MapAccum + +import qualified Distribution.Client.BuildReports.Storage as BuildReports + ( storeLocal, fromPlanningFailure ) + +import qualified Distribution.Solver.Types.ComponentDeps as CD +import Distribution.Solver.Types.ComponentDeps (ComponentDeps) +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 +import Distribution.Solver.Types.SolverId +import Distribution.Solver.Types.SolverPackage +import Distribution.Solver.Types.InstSolverPackage +import Distribution.Solver.Types.SourcePackage +import Distribution.Solver.Types.Settings + +import Distribution.CabalSpecVersion +import Distribution.ModuleName +import Distribution.Package +import Distribution.Types.AnnotatedId +import Distribution.Types.ComponentName +import Distribution.Types.DumpBuildInfo + ( DumpBuildInfo (..) ) +import Distribution.Types.LibraryName +import Distribution.Types.GivenComponent + (GivenComponent(..)) +import Distribution.Types.PackageVersionConstraint +import Distribution.Types.PkgconfigDependency +import Distribution.Types.UnqualComponentName +import Distribution.System +import qualified Distribution.PackageDescription as Cabal +import qualified Distribution.PackageDescription as PD +import qualified Distribution.PackageDescription.Configuration as PD +import Distribution.Simple.PackageIndex (InstalledPackageIndex) +import Distribution.Simple.Compiler +import qualified Distribution.Simple.GHC as GHC --TODO: [code cleanup] eliminate +import qualified Distribution.Simple.GHCJS as GHCJS --TODO: [code cleanup] eliminate +import Distribution.Simple.Program +import Distribution.Simple.Program.Db +import Distribution.Simple.Program.Find +import qualified Distribution.Simple.Setup as Cabal +import Distribution.Simple.Setup + (Flag(..), toFlag, flagToMaybe, flagToList, fromFlagOrDefault) +import qualified Distribution.Simple.Configure as Cabal +import qualified Distribution.Simple.LocalBuildInfo as Cabal +import Distribution.Simple.LocalBuildInfo + ( Component(..), pkgComponents, componentBuildInfo + , componentName ) +import qualified Distribution.Simple.InstallDirs as InstallDirs +import qualified Distribution.InstalledPackageInfo as IPI + +import Distribution.Backpack.ConfiguredComponent +import Distribution.Backpack.LinkedComponent +import Distribution.Backpack.ComponentsGraph +import Distribution.Backpack.ModuleShape +import Distribution.Backpack.FullUnitId +import Distribution.Backpack +import Distribution.Types.ComponentInclude + +import Distribution.Simple.Utils +import Distribution.Version + +import qualified Distribution.Compat.Graph as Graph +import Distribution.Compat.Graph(IsNode(..)) + +import Data.Foldable (fold) +import Text.PrettyPrint (text, hang, quotes, colon, vcat, ($$), fsep, punctuate, comma) +import qualified Text.PrettyPrint as Disp +import qualified Data.Map as Map +import qualified Data.Set as Set +import Control.Monad.State as State +import Control.Exception (assert) +import Data.List (groupBy, deleteBy) +import qualified Data.List.NonEmpty as NE +import System.FilePath + +------------------------------------------------------------------------------ +-- * Elaborated install plan +------------------------------------------------------------------------------ + +-- "Elaborated" -- worked out with great care and nicety of detail; +-- executed with great minuteness: elaborate preparations; +-- elaborate care. +-- +-- So here's the idea: +-- +-- Rather than a miscellaneous collection of 'ConfigFlags', 'InstallFlags' etc +-- all passed in as separate args and which are then further selected, +-- transformed etc during the execution of the build. Instead we construct +-- an elaborated install plan that includes everything we will need, and then +-- during the execution of the plan we do as little transformation of this +-- info as possible. +-- +-- So we're trying to split the work into two phases: construction of the +-- elaborated install plan (which as far as possible should be pure) and +-- then simple execution of that plan without any smarts, just doing what the +-- plan says to do. +-- +-- So that means we need a representation of this fully elaborated install +-- plan. The representation consists of two parts: +-- +-- * A 'ElaboratedInstallPlan'. This is a 'GenericInstallPlan' with a +-- representation of source packages that includes a lot more detail about +-- that package's individual configuration +-- +-- * A 'ElaboratedSharedConfig'. Some package configuration is the same for +-- every package in a plan. Rather than duplicate that info every entry in +-- the 'GenericInstallPlan' we keep that separately. +-- +-- The division between the shared and per-package config is /not set in stone +-- for all time/. For example if we wanted to generalise the install plan to +-- describe a situation where we want to build some packages with GHC and some +-- with GHCJS then the platform and compiler would no longer be shared between +-- all packages but would have to be per-package (probably with some sanity +-- condition on the graph structure). +-- + +-- Refer to ProjectPlanning.Types for details of these important types: + +-- type ElaboratedInstallPlan = ... +-- type ElaboratedPlanPackage = ... +-- data ElaboratedSharedConfig = ... +-- data ElaboratedConfiguredPackage = ... +-- data BuildStyle = + + +-- | Check that an 'ElaboratedConfiguredPackage' actually makes +-- sense under some 'ElaboratedSharedConfig'. +sanityCheckElaboratedConfiguredPackage + :: ElaboratedSharedConfig + -> ElaboratedConfiguredPackage + -> a + -> a +sanityCheckElaboratedConfiguredPackage sharedConfig + elab@ElaboratedConfiguredPackage{..} = + (case elabPkgOrComp of + ElabPackage pkg -> sanityCheckElaboratedPackage elab pkg + ElabComponent comp -> sanityCheckElaboratedComponent elab comp) + + -- either a package is being built inplace, or the + -- 'installedPackageId' we assigned is consistent with + -- the 'hashedInstalledPackageId' we would compute from + -- the elaborated configured package + . assert (elabBuildStyle == BuildInplaceOnly || + elabComponentId == hashedInstalledPackageId + (packageHashInputs sharedConfig elab)) + + -- the stanzas explicitly disabled should not be available + . assert (optStanzaSetNull $ + optStanzaKeysFilteredByValue (maybe False not) elabStanzasRequested `optStanzaSetIntersection` elabStanzasAvailable) + + -- either a package is built inplace, or we are not attempting to + -- build any test suites or benchmarks (we never build these + -- for remote packages!) + . assert (elabBuildStyle == BuildInplaceOnly || + optStanzaSetNull elabStanzasAvailable) + +sanityCheckElaboratedComponent + :: ElaboratedConfiguredPackage + -> ElaboratedComponent + -> a + -> a +sanityCheckElaboratedComponent ElaboratedConfiguredPackage{..} + ElaboratedComponent{..} = + + -- Should not be building bench or test if not inplace. + assert (elabBuildStyle == BuildInplaceOnly || + case compComponentName of + Nothing -> True + Just (CLibName _) -> True + Just (CExeName _) -> True + -- This is interesting: there's no way to declare a dependency + -- on a foreign library at the moment, but you may still want + -- to install these to the store + Just (CFLibName _) -> True + Just (CBenchName _) -> False + Just (CTestName _) -> False) + + +sanityCheckElaboratedPackage + :: ElaboratedConfiguredPackage + -> ElaboratedPackage + -> a + -> a +sanityCheckElaboratedPackage ElaboratedConfiguredPackage{..} + ElaboratedPackage{..} = + -- we should only have enabled stanzas that actually can be built + -- (according to the solver) + assert (pkgStanzasEnabled `optStanzaSetIsSubset` elabStanzasAvailable) + + -- the stanzas that the user explicitly requested should be + -- enabled (by the previous test, they are also available) + . assert (optStanzaKeysFilteredByValue (fromMaybe False) elabStanzasRequested + `optStanzaSetIsSubset` pkgStanzasEnabled) + +------------------------------------------------------------------------------ +-- * Deciding what to do: making an 'ElaboratedInstallPlan' +------------------------------------------------------------------------------ + +-- | Return the up-to-date project config and information about the local +-- packages within the project. +-- +rebuildProjectConfig :: Verbosity + -> HttpTransport + -> DistDirLayout + -> ProjectConfig + -> IO ( ProjectConfig + , [PackageSpecifier UnresolvedSourcePackage] ) +rebuildProjectConfig verbosity + httpTransport + distDirLayout@DistDirLayout { + distProjectRootDirectory, + distDirectory, + distProjectCacheFile, + distProjectCacheDirectory, + distProjectFile + } + cliConfig = do + + fileMonitorProjectConfigKey <- do + configPath <- getConfigFilePath projectConfigConfigFile + return (configPath, distProjectFile "") + + (projectConfig, localPackages) <- + runRebuild distProjectRootDirectory + $ rerunIfChanged verbosity + fileMonitorProjectConfig + fileMonitorProjectConfigKey -- todo check deps too? + $ do + liftIO $ info verbosity "Project settings changed, reconfiguring..." + liftIO $ createDirectoryIfMissingVerbose verbosity True distProjectCacheDirectory + projectConfigSkeleton <- phaseReadProjectConfig + -- have to create the cache directory before configuring the compiler + (compiler, Platform arch os, _) <- configureCompiler verbosity distDirLayout ((fst $ PD.ignoreConditions projectConfigSkeleton) <> cliConfig) + let projectConfig = instantiateProjectConfigSkeleton os arch (compilerInfo compiler) mempty projectConfigSkeleton + localPackages <- phaseReadLocalPackages (projectConfig <> cliConfig) + return (projectConfig, localPackages) + + info verbosity + $ unlines + $ ("this build was affected by the following (project) config files:" :) + $ [ "- " ++ path + | Explicit path <- Set.toList $ projectConfigProvenance projectConfig + ] + + return (projectConfig <> cliConfig, localPackages) + + where + + ProjectConfigShared { projectConfigConfigFile } = + projectConfigShared cliConfig + + ProjectConfigShared { projectConfigIgnoreProject } = + projectConfigShared cliConfig + + fileMonitorProjectConfig :: + FileMonitor + (FilePath, FilePath) + (ProjectConfig, [PackageSpecifier UnresolvedSourcePackage]) + fileMonitorProjectConfig = + newFileMonitor (distProjectCacheFile "config") + + -- Read the cabal.project (or implicit config) and combine it with + -- arguments from the command line + -- + phaseReadProjectConfig :: Rebuild ProjectConfigSkeleton + phaseReadProjectConfig = do + readProjectConfig verbosity httpTransport projectConfigIgnoreProject projectConfigConfigFile distDirLayout + + -- Look for all the cabal packages in the project + -- some of which may be local src dirs, tarballs etc + -- + phaseReadLocalPackages :: ProjectConfig + -> Rebuild [PackageSpecifier UnresolvedSourcePackage] + phaseReadLocalPackages projectConfig@ProjectConfig { + projectConfigShared, + projectConfigBuildOnly + } = do + + pkgLocations <- findProjectPackages distDirLayout projectConfig + -- Create folder only if findProjectPackages did not throw a + -- BadPackageLocations exception. + liftIO $ do + createDirectoryIfMissingVerbose verbosity True distDirectory + createDirectoryIfMissingVerbose verbosity True distProjectCacheDirectory + + fetchAndReadSourcePackages verbosity distDirLayout + projectConfigShared + projectConfigBuildOnly + pkgLocations + + +configureCompiler :: Verbosity -> + DistDirLayout -> + ProjectConfig -> + Rebuild (Compiler, Platform, ProgramDb) +configureCompiler verbosity + DistDirLayout { + distProjectCacheFile + } + ProjectConfig { + projectConfigShared = ProjectConfigShared { + projectConfigHcFlavor, + projectConfigHcPath, + projectConfigHcPkg + }, + projectConfigLocalPackages = PackageConfig { + packageConfigProgramPaths, + packageConfigProgramPathExtra + } + } = do + let fileMonitorCompiler = newFileMonitor . distProjectCacheFile $ "compiler" + + progsearchpath <- liftIO $ getSystemSearchPath + rerunIfChanged verbosity fileMonitorCompiler + (hcFlavor, hcPath, hcPkg, progsearchpath, + packageConfigProgramPaths, + packageConfigProgramPathExtra) $ do + + liftIO $ info verbosity "Compiler settings changed, reconfiguring..." + result@(_, _, progdb') <- liftIO $ + Cabal.configCompilerEx + hcFlavor hcPath hcPkg + 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 + where + hcFlavor = flagToMaybe projectConfigHcFlavor + hcPath = flagToMaybe projectConfigHcPath + hcPkg = flagToMaybe projectConfigHcPkg + progdb = + userSpecifyPaths (Map.toList (getMapLast packageConfigProgramPaths)) + . modifyProgramSearchPath + (++ [ ProgramSearchPathDir dir + | dir <- fromNubList packageConfigProgramPathExtra ]) + $ defaultProgramDb + + +-- | Return an up-to-date elaborated install plan. +-- +-- Two variants of the install plan are returned: with and without packages +-- from the store. That is, the \"improved\" plan where source packages are +-- replaced by pre-existing installed packages from the store (when their ids +-- match), and also the original elaborated plan which uses primarily source +-- packages. + +-- The improved plan is what we use for building, but the original elaborated +-- plan is useful for reporting and configuration. For example the @freeze@ +-- command needs the source package info to know about flag choices and +-- dependencies of executables and setup scripts. +-- +rebuildInstallPlan :: Verbosity + -> DistDirLayout -> CabalDirLayout + -> ProjectConfig + -> [PackageSpecifier UnresolvedSourcePackage] + -> IO ( ElaboratedInstallPlan -- with store packages + , ElaboratedInstallPlan -- with source packages + , ElaboratedSharedConfig + , IndexUtils.TotalIndexState + , IndexUtils.ActiveRepos + ) + -- ^ @(improvedPlan, elaboratedPlan, _, _, _)@ +rebuildInstallPlan verbosity + distDirLayout@DistDirLayout { + distProjectRootDirectory, + distProjectCacheFile + } + CabalDirLayout { + cabalStoreDirLayout + } = \projectConfig localPackages -> + runRebuild distProjectRootDirectory $ do + progsearchpath <- liftIO $ getSystemSearchPath + let projectConfigMonitored = projectConfig { projectConfigBuildOnly = mempty } + + -- The overall improved plan is cached + rerunIfChanged verbosity fileMonitorImprovedPlan + -- react to changes in the project config, + -- the package .cabal files and the path + (projectConfigMonitored, localPackages, progsearchpath) $ do + + -- And so is the elaborated plan that the improved plan based on + (elaboratedPlan, elaboratedShared, totalIndexState, activeRepos) <- + rerunIfChanged verbosity fileMonitorElaboratedPlan + (projectConfigMonitored, localPackages, + progsearchpath) $ do + + compilerEtc <- phaseConfigureCompiler projectConfig + _ <- phaseConfigurePrograms projectConfig compilerEtc + (solverPlan, pkgConfigDB, totalIndexState, activeRepos) + <- phaseRunSolver projectConfig + compilerEtc + localPackages + (elaboratedPlan, + elaboratedShared) <- phaseElaboratePlan projectConfig + compilerEtc pkgConfigDB + solverPlan + localPackages + + phaseMaintainPlanOutputs elaboratedPlan elaboratedShared + return (elaboratedPlan, elaboratedShared, totalIndexState, activeRepos) + + -- 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. + improvedPlan <- phaseImprovePlan elaboratedPlan elaboratedShared + + return (improvedPlan, elaboratedPlan, elaboratedShared, totalIndexState, activeRepos) + + where + fileMonitorSolverPlan = newFileMonitorInCacheDir "solver-plan" + fileMonitorSourceHashes = newFileMonitorInCacheDir "source-hashes" + fileMonitorElaboratedPlan = newFileMonitorInCacheDir "elaborated-plan" + fileMonitorImprovedPlan = newFileMonitorInCacheDir "improved-plan" + + newFileMonitorInCacheDir :: Eq a => FilePath -> FileMonitor a b + 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 :: ProjectConfig + -> Rebuild (Compiler, Platform, ProgramDb) + phaseConfigureCompiler = configureCompiler verbosity distDirLayout + + -- Configuring other programs. + -- + -- Having configred the compiler, now we configure all the remaining + -- programs. This is to check we can find them, and to monitor them for + -- changes. + -- + -- TODO: [required eventually] we don't actually do this yet. + -- + -- We rely on the fact that the previous phase added the program config for + -- all local packages, but that all the programs configured so far are the + -- compiler program or related util programs. + -- + phaseConfigurePrograms :: ProjectConfig + -> (Compiler, Platform, ProgramDb) + -> Rebuild () + phaseConfigurePrograms projectConfig (_, _, compilerprogdb) = 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)) + + --TODO: [required eventually] find/configure other programs that the + -- user specifies. + + --TODO: [required eventually] find/configure all build-tools + -- but note that some of them may be built as part of the plan. + + + -- Run the solver to get the initial install plan. + -- This is expensive so we cache it independently. + -- + phaseRunSolver + :: ProjectConfig + -> (Compiler, Platform, ProgramDb) + -> [PackageSpecifier UnresolvedSourcePackage] + -> Rebuild (SolverInstallPlan, PkgConfigDb, IndexUtils.TotalIndexState, IndexUtils.ActiveRepos) + phaseRunSolver projectConfig@ProjectConfig { + projectConfigShared, + projectConfigBuildOnly + } + (compiler, platform, progdb) + localPackages = + rerunIfChanged verbosity fileMonitorSolverPlan + (solverSettings, + localPackages, localPackagesEnabledStanzas, + compiler, platform, programDbSignature progdb) $ do + + installedPkgIndex <- getInstalledPackages verbosity + compiler progdb platform + corePackageDbs + (sourcePkgDb, tis, ar) <- getSourcePackages verbosity withRepoCtx + (solverSettingIndexState solverSettings) + (solverSettingActiveRepos solverSettings) + pkgConfigDB <- getPkgConfigDb verbosity progdb + + --TODO: [code cleanup] it'd be better if the Compiler contained the + -- ConfiguredPrograms that it needs, rather than relying on the progdb + -- since we don't need to depend on all the programs here, just the + -- ones relevant for the compiler. + + liftIO $ do + solver <- chooseSolver verbosity + (solverSettingSolver solverSettings) + (compilerInfo compiler) + + notice verbosity "Resolving dependencies..." + planOrError <- foldProgress logMsg (pure . Left) (pure . Right) $ + planPackages verbosity compiler platform solver solverSettings + installedPkgIndex sourcePkgDb pkgConfigDB + localPackages localPackagesEnabledStanzas + case planOrError of + Left msg -> do reportPlanningFailure projectConfig compiler platform localPackages + die' verbosity msg + Right plan -> return (plan, pkgConfigDB, tis, ar) + where + corePackageDbs :: [PackageDB] + corePackageDbs = applyPackageDbFlags [GlobalPackageDB] + (projectConfigPackageDBs projectConfigShared) + + withRepoCtx = projectConfigWithSolverRepoContext verbosity + projectConfigShared + projectConfigBuildOnly + solverSettings = resolveSolverSettings projectConfig + logMsg message rest = debugNoWrap verbosity message >> rest + + localPackagesEnabledStanzas = + Map.fromList + [ (pkgname, stanzas) + | pkg <- localPackages + -- TODO: misnomer: we should separate + -- builtin/global/inplace/local packages + -- and packages explicitly mentioned in the project + -- + , let pkgname = pkgSpecifierTarget pkg + testsEnabled = lookupLocalPackageConfig + packageConfigTests + projectConfig pkgname + benchmarksEnabled = lookupLocalPackageConfig + packageConfigBenchmarks + projectConfig pkgname + isLocal = isJust (shouldBeLocal pkg) + stanzas + | isLocal = Map.fromList $ + [ (TestStanzas, enabled) + | enabled <- flagToList testsEnabled ] ++ + [ (BenchStanzas , enabled) + | enabled <- flagToList benchmarksEnabled ] + | otherwise = Map.fromList [(TestStanzas, False), (BenchStanzas, False) ] + ] + + -- Elaborate the solver's install plan to get a fully detailed plan. This + -- version of the plan has the final nix-style hashed ids. + -- + phaseElaboratePlan :: ProjectConfig + -> (Compiler, Platform, ProgramDb) + -> PkgConfigDb + -> SolverInstallPlan + -> [PackageSpecifier (SourcePackage (PackageLocation loc))] + -> Rebuild ( ElaboratedInstallPlan + , ElaboratedSharedConfig ) + phaseElaboratePlan ProjectConfig { + projectConfigShared, + projectConfigAllPackages, + projectConfigLocalPackages, + projectConfigSpecificPackage, + projectConfigBuildOnly + } + (compiler, platform, progdb) pkgConfigDB + solverPlan localPackages = do + + liftIO $ debug verbosity "Elaborating the install plan..." + + sourcePackageHashes <- + rerunIfChanged verbosity fileMonitorSourceHashes + (packageLocationsSignature solverPlan) $ + getPackageSourceHashes verbosity withRepoCtx solverPlan + + defaultInstallDirs <- liftIO $ userInstallDirTemplates compiler + (elaboratedPlan, elaboratedShared) + <- liftIO . runLogProgress verbosity $ + elaborateInstallPlan + verbosity + platform compiler progdb pkgConfigDB + distDirLayout + cabalStoreDirLayout + solverPlan + localPackages + sourcePackageHashes + defaultInstallDirs + projectConfigShared + projectConfigAllPackages + projectConfigLocalPackages + (getMapMappend projectConfigSpecificPackage) + let instantiatedPlan + = instantiateInstallPlan + cabalStoreDirLayout + defaultInstallDirs + elaboratedShared + elaboratedPlan + liftIO $ debugNoWrap verbosity (InstallPlan.showInstallPlan instantiatedPlan) + return (instantiatedPlan, elaboratedShared) + where + withRepoCtx = projectConfigWithSolverRepoContext verbosity + projectConfigShared + projectConfigBuildOnly + + -- Update the files we maintain that reflect our current build environment. + -- In particular we maintain a JSON representation of the elaborated + -- install plan (but not the improved plan since that reflects the state + -- of the build rather than just the input environment). + -- + phaseMaintainPlanOutputs :: ElaboratedInstallPlan + -> ElaboratedSharedConfig + -> Rebuild () + phaseMaintainPlanOutputs elaboratedPlan elaboratedShared = liftIO $ do + debug verbosity "Updating plan.json" + writePlanExternalRepresentation + distDirLayout + elaboratedPlan + elaboratedShared + + + -- Improve the elaborated install plan. The elaborated plan consists + -- mostly of source packages (with full nix-style hashed ids). Where + -- corresponding installed packages already exist in the store, replace + -- them in the plan. + -- + -- Note that we do monitor the store's package db here, so we will redo + -- this improvement phase when the db changes -- including as a result of + -- executing a plan and installing things. + -- + phaseImprovePlan :: ElaboratedInstallPlan + -> ElaboratedSharedConfig + -> Rebuild ElaboratedInstallPlan + phaseImprovePlan elaboratedPlan elaboratedShared = do + + liftIO $ debug verbosity "Improving the install plan..." + storePkgIdSet <- getStoreEntries cabalStoreDirLayout compid + let improvedPlan = improveInstallPlanWithInstalledPackages + storePkgIdSet + elaboratedPlan + liftIO $ debugNoWrap verbosity (InstallPlan.showInstallPlan improvedPlan) + -- TODO: [nice to have] having checked which packages from the store + -- we're using, it may be sensible to sanity check those packages + -- by loading up the compiler package db and checking everything + -- matches up as expected, e.g. no dangling deps, files deleted. + return improvedPlan + where + compid = compilerId (pkgConfigCompiler elaboratedShared) + + +-- | If a 'PackageSpecifier' refers to a single package, return Just that +-- package. + + +reportPlanningFailure :: ProjectConfig -> Compiler -> Platform -> [PackageSpecifier UnresolvedSourcePackage] -> IO () +reportPlanningFailure projectConfig comp platform pkgSpecifiers = when reportFailure $ + + BuildReports.storeLocal (compilerInfo comp) + (fromNubList $ projectConfigSummaryFile . projectConfigBuildOnly $ projectConfig) + buildReports platform + + -- TODO may want to handle the projectConfigLogFile paramenter here, or just remove it entirely? + where + reportFailure = Cabal.fromFlag . projectConfigReportPlanningFailure . projectConfigBuildOnly $ projectConfig + pkgids = mapMaybe theSpecifiedPackage pkgSpecifiers + buildReports = BuildReports.fromPlanningFailure platform + (compilerId comp) pkgids + -- TODO we may want to get more flag assignments and merge them here? + (packageConfigFlagAssignment . projectConfigAllPackages $ projectConfig) + + theSpecifiedPackage :: Package pkg => PackageSpecifier pkg -> Maybe PackageId + theSpecifiedPackage pkgSpec = + case pkgSpec of + NamedPackage name [PackagePropertyVersion version] + -> PackageIdentifier name <$> trivialRange version + NamedPackage _ _ -> Nothing + SpecificSourcePackage pkg -> Just $ packageId pkg + -- | If a range includes only a single version, return Just that version. + trivialRange :: VersionRange -> Maybe Version + trivialRange = foldVersionRange + Nothing + Just -- "== v" + (\_ -> Nothing) + (\_ -> Nothing) + (\_ _ -> Nothing) + (\_ _ -> Nothing) + + +programsMonitorFiles :: ProgramDb -> [MonitorFilePath] +programsMonitorFiles progdb = + [ monitor + | prog <- configuredPrograms progdb + , monitor <- monitorFileSearchPath (programMonitorFiles prog) + (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 + -> PackageDBStack + -> Rebuild InstalledPackageIndex +getInstalledPackages verbosity compiler progdb platform packagedbs = do + monitorFiles . map monitorFileOrDirectory + =<< liftIO (IndexUtils.getInstalledPackagesMonitorFiles + verbosity compiler + packagedbs progdb platform) + liftIO $ IndexUtils.getInstalledPackages + verbosity compiler + packagedbs progdb + +{- +--TODO: [nice to have] use this but for sanity / consistency checking +getPackageDBContents :: Verbosity + -> Compiler -> ProgramDb -> Platform + -> PackageDB + -> Rebuild InstalledPackageIndex +getPackageDBContents verbosity compiler progdb platform packagedb = do + monitorFiles . map monitorFileOrDirectory + =<< liftIO (IndexUtils.getInstalledPackagesMonitorFiles + verbosity compiler + [packagedb] progdb platform) + liftIO $ do + createPackageDBIfMissing verbosity compiler progdb packagedb + Cabal.getPackageDBContents verbosity compiler + packagedb progdb +-} + +getSourcePackages + :: Verbosity + -> (forall a. (RepoContext -> IO a) -> IO a) + -> Maybe IndexUtils.TotalIndexState + -> Maybe IndexUtils.ActiveRepos + -> Rebuild (SourcePackageDb, IndexUtils.TotalIndexState, IndexUtils.ActiveRepos) +getSourcePackages verbosity withRepoCtx idxState activeRepos = do + (sourcePkgDbWithTIS, repos) <- + liftIO $ + withRepoCtx $ \repoctx -> do + sourcePkgDbWithTIS <- IndexUtils.getSourcePackagesAtIndexState verbosity repoctx idxState activeRepos + return (sourcePkgDbWithTIS, repoContextRepos repoctx) + + traverse_ needIfExists + . IndexUtils.getSourcePackagesMonitorFiles + $ repos + return sourcePkgDbWithTIS + + +getPkgConfigDb :: Verbosity -> ProgramDb -> Rebuild PkgConfigDb +getPkgConfigDb verbosity progdb = do + dirs <- liftIO $ getPkgConfigDbDirs verbosity progdb + -- Just monitor the dirs so we'll notice new .pc files. + -- Alternatively we could monitor all the .pc files too. + traverse_ monitorDirectoryStatus dirs + liftIO $ readPkgConfigDb verbosity progdb + + +-- | Select the config values to monitor for changes package source hashes. +packageLocationsSignature :: SolverInstallPlan + -> [(PackageId, PackageLocation (Maybe FilePath))] +packageLocationsSignature solverPlan = + [ (packageId pkg, srcpkgSource pkg) + | SolverInstallPlan.Configured (SolverPackage { solverPkgSource = pkg}) + <- SolverInstallPlan.toList solverPlan + ] + + +-- | Get the 'HashValue' for all the source packages where we use hashes, +-- and download any packages required to do so. +-- +-- Note that we don't get hashes for local unpacked packages. +-- +getPackageSourceHashes :: Verbosity + -> (forall a. (RepoContext -> IO a) -> IO a) + -> SolverInstallPlan + -> Rebuild (Map PackageId PackageSourceHash) +getPackageSourceHashes verbosity withRepoCtx solverPlan = do + + -- Determine if and where to get the package's source hash from. + -- + let allPkgLocations :: [(PackageId, PackageLocation (Maybe FilePath))] + allPkgLocations = + [ (packageId pkg, srcpkgSource pkg) + | SolverInstallPlan.Configured (SolverPackage { solverPkgSource = pkg}) + <- SolverInstallPlan.toList solverPlan ] + + -- Tarballs that were local in the first place. + -- We'll hash these tarball files directly. + localTarballPkgs :: [(PackageId, FilePath)] + localTarballPkgs = + [ (pkgid, tarball) + | (pkgid, LocalTarballPackage tarball) <- allPkgLocations ] + + -- Tarballs from remote URLs. We must have downloaded these already + -- (since we extracted the .cabal file earlier) + remoteTarballPkgs = + [ (pkgid, tarball) + | (pkgid, RemoteTarballPackage _ (Just tarball)) <- allPkgLocations ] + + -- tarballs from source-repository-package stanzas + sourceRepoTarballPkgs = + [ (pkgid, tarball) + | (pkgid, RemoteSourceRepoPackage _ (Just tarball)) <- allPkgLocations ] + + -- Tarballs from repositories, either where the repository provides + -- hashes as part of the repo metadata, or where we will have to + -- download and hash the tarball. + repoTarballPkgsWithMetadata :: [(PackageId, Repo)] + repoTarballPkgsWithoutMetadata :: [(PackageId, Repo)] + (repoTarballPkgsWithMetadata, + repoTarballPkgsWithoutMetadata) = + partitionEithers + [ case repo of + RepoSecure{} -> Left (pkgid, repo) + _ -> Right (pkgid, repo) + | (pkgid, RepoTarballPackage repo _ _) <- allPkgLocations ] + + -- For tarballs from repos that do not have hashes available we now have + -- to check if the packages were downloaded already. + -- + (repoTarballPkgsToDownload, + repoTarballPkgsDownloaded) + <- fmap partitionEithers $ + liftIO $ sequence + [ do mtarball <- checkRepoTarballFetched repo pkgid + case mtarball of + Nothing -> return (Left (pkgid, repo)) + Just tarball -> return (Right (pkgid, tarball)) + | (pkgid, repo) <- repoTarballPkgsWithoutMetadata ] + + (hashesFromRepoMetadata, + repoTarballPkgsNewlyDownloaded) <- + -- Avoid having to initialise the repository (ie 'withRepoCtx') if we + -- don't have to. (The main cost is configuring the http client.) + if null repoTarballPkgsToDownload && null repoTarballPkgsWithMetadata + then return (Map.empty, []) + else liftIO $ withRepoCtx $ \repoctx -> do + + -- For tarballs from repos that do have hashes available as part of the + -- repo metadata we now load up the index for each repo and retrieve + -- the hashes for the packages + -- + hashesFromRepoMetadata <- + Sec.uncheckClientErrors $ --TODO: [code cleanup] wrap in our own exceptions + fmap (Map.fromList . concat) $ + sequence + -- Reading the repo index is expensive so we group the packages by repo + [ repoContextWithSecureRepo repoctx repo $ \secureRepo -> + Sec.withIndex secureRepo $ \repoIndex -> + sequence + [ do hash <- Sec.trusted <$> -- strip off Trusted tag + Sec.indexLookupHash repoIndex pkgid + -- Note that hackage-security currently uses SHA256 + -- but this API could in principle give us some other + -- choice in future. + return (pkgid, hashFromTUF hash) + | pkgid <- pkgids ] + | (repo, pkgids) <- + map (\grp@((_,repo):|_) -> (repo, map fst (NE.toList grp))) + . NE.groupBy ((==) `on` (remoteRepoName . repoRemote . snd)) + . sortBy (compare `on` (remoteRepoName . repoRemote . snd)) + $ repoTarballPkgsWithMetadata + ] + + -- For tarballs from repos that do not have hashes available, download + -- the ones we previously determined we need. + -- + repoTarballPkgsNewlyDownloaded <- + sequence + [ do tarball <- fetchRepoTarball verbosity repoctx repo pkgid + return (pkgid, tarball) + | (pkgid, repo) <- repoTarballPkgsToDownload ] + + return (hashesFromRepoMetadata, + repoTarballPkgsNewlyDownloaded) + + -- Hash tarball files for packages where we have to do that. This includes + -- tarballs that were local in the first place, plus tarballs from repos, + -- either previously cached or freshly downloaded. + -- + let allTarballFilePkgs :: [(PackageId, FilePath)] + allTarballFilePkgs = localTarballPkgs + ++ remoteTarballPkgs + ++ sourceRepoTarballPkgs + ++ repoTarballPkgsDownloaded + ++ repoTarballPkgsNewlyDownloaded + hashesFromTarballFiles <- liftIO $ + fmap Map.fromList $ + sequence + [ do srchash <- readFileHashValue tarball + return (pkgid, srchash) + | (pkgid, tarball) <- allTarballFilePkgs + ] + monitorFiles [ monitorFile tarball + | (_pkgid, tarball) <- allTarballFilePkgs ] + + -- Return the combination + return $! hashesFromRepoMetadata + <> hashesFromTarballFiles + +-- | Append the given package databases to an existing PackageDBStack. +-- A @Nothing@ entry will clear everything before it. +applyPackageDbFlags :: PackageDBStack -> [Maybe PackageDB] -> PackageDBStack +applyPackageDbFlags dbs' [] = dbs' +applyPackageDbFlags _ (Nothing:dbs) = applyPackageDbFlags [] dbs +applyPackageDbFlags dbs' (Just db:dbs) = applyPackageDbFlags (dbs' ++ [db]) dbs + +-- ------------------------------------------------------------ +-- * Installation planning +-- ------------------------------------------------------------ + +planPackages :: Verbosity + -> Compiler + -> Platform + -> Solver -> SolverSettings + -> InstalledPackageIndex + -> SourcePackageDb + -> PkgConfigDb + -> [PackageSpecifier UnresolvedSourcePackage] + -> Map PackageName (Map OptionalStanza Bool) + -> Progress String String SolverInstallPlan +planPackages verbosity comp platform solver SolverSettings{..} + installedPkgIndex sourcePkgDb pkgConfigDB + localPackages pkgStanzasEnable = + + resolveDependencies + platform (compilerInfo comp) + pkgConfigDB solver + resolverParams + + where + + --TODO: [nice to have] disable multiple instances restriction in + -- the solver, but then make sure we can cope with that in the + -- output. + resolverParams :: DepResolverParams + resolverParams = + + setMaxBackjumps solverSettingMaxBackjumps + + . setIndependentGoals solverSettingIndependentGoals + + . setReorderGoals solverSettingReorderGoals + + . setCountConflicts solverSettingCountConflicts + + . setFineGrainedConflicts solverSettingFineGrainedConflicts + + . setMinimizeConflictSet solverSettingMinimizeConflictSet + + --TODO: [required eventually] should only be configurable for + --custom installs + -- . setAvoidReinstalls solverSettingAvoidReinstalls + + --TODO: [required eventually] should only be configurable for + --custom installs + -- . setShadowPkgs solverSettingShadowPkgs + + . setStrongFlags solverSettingStrongFlags + + . setAllowBootLibInstalls solverSettingAllowBootLibInstalls + + . setOnlyConstrained solverSettingOnlyConstrained + + . setSolverVerbosity verbosity + + --TODO: [required eventually] decide if we need to prefer + -- installed for global packages, or prefer latest even for + -- global packages. Perhaps should be configurable but with a + -- different name than "upgrade-dependencies". + . setPreferenceDefault + (if Cabal.asBool solverSettingPreferOldest + then PreferAllOldest + else PreferLatestForSelected) + {-(if solverSettingUpgradeDeps + then PreferAllLatest + else PreferLatestForSelected)-} + + . removeLowerBounds solverSettingAllowOlder + . removeUpperBounds solverSettingAllowNewer + + . addDefaultSetupDependencies (defaultSetupDeps comp platform + . PD.packageDescription + . srcpkgDescription) + + . addSetupCabalMinVersionConstraint setupMinCabalVersionConstraint + . addSetupCabalMaxVersionConstraint setupMaxCabalVersionConstraint + + . addPreferences + -- preferences from the config file or command line + [ PackageVersionPreference name ver + | PackageVersionConstraint name ver <- solverSettingPreferences ] + + . addConstraints + -- version constraints from the config file or command line + [ LabeledPackageConstraint (userToPackageConstraint pc) src + | (pc, src) <- solverSettingConstraints ] + + . addPreferences + -- enable stanza preference unilaterally, regardless if the user asked + -- accordingly or expressed no preference, to help hint the solver + [ PackageStanzasPreference pkgname stanzas + | pkg <- localPackages + , let pkgname = pkgSpecifierTarget pkg + stanzaM = Map.findWithDefault Map.empty pkgname pkgStanzasEnable + stanzas = [ stanza | stanza <- [minBound..maxBound] + , Map.lookup stanza stanzaM /= Just False ] + , not (null stanzas) + ] + + . addConstraints + -- enable stanza constraints where the user asked to enable + [ LabeledPackageConstraint + (PackageConstraint (scopeToplevel pkgname) + (PackagePropertyStanzas stanzas)) + ConstraintSourceConfigFlagOrTarget + | pkg <- localPackages + , let pkgname = pkgSpecifierTarget pkg + stanzaM = Map.findWithDefault Map.empty pkgname pkgStanzasEnable + stanzas = [ stanza | stanza <- [minBound..maxBound] + , Map.lookup stanza stanzaM == Just True ] + , not (null stanzas) + ] + + . addConstraints + --TODO: [nice to have] should have checked at some point that the + -- package in question actually has these flags. + [ LabeledPackageConstraint + (PackageConstraint (scopeToplevel pkgname) + (PackagePropertyFlags flags)) + ConstraintSourceConfigFlagOrTarget + | (pkgname, flags) <- Map.toList solverSettingFlagAssignments ] + + . addConstraints + --TODO: [nice to have] we have user-supplied flags for unspecified + -- local packages (as well as specific per-package flags). For the + -- former we just apply all these flags to all local targets which + -- is silly. We should check if the flags are appropriate. + [ LabeledPackageConstraint + (PackageConstraint (scopeToplevel pkgname) + (PackagePropertyFlags flags)) + ConstraintSourceConfigFlagOrTarget + | let flags = solverSettingFlagAssignment + , not (PD.nullFlagAssignment flags) + , pkg <- localPackages + , let pkgname = pkgSpecifierTarget pkg ] + + $ stdResolverParams + + stdResolverParams :: DepResolverParams + stdResolverParams = + -- Note: we don't use the standardInstallPolicy here, since that uses + -- its own addDefaultSetupDependencies that is not appropriate for us. + basicInstallPolicy + installedPkgIndex sourcePkgDb + 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,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 +------------------------------------------------------------------------------ + +-- This phase goes from the InstallPlan we get from the solver and has to +-- make an elaborated install plan. +-- +-- We go in two steps: +-- +-- 1. elaborate all the source packages that the solver has chosen. +-- 2. swap source packages for pre-existing installed packages wherever +-- possible. +-- +-- We do it in this order, elaborating and then replacing, because the easiest +-- way to calculate the installed package ids used for the replacement step is +-- from the elaborated configuration for each package. + + + + +------------------------------------------------------------------------------ +-- * Install plan elaboration +------------------------------------------------------------------------------ + +-- Note [SolverId to ConfiguredId] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Dependency solving is a per package affair, so after we're done, we +-- end up with 'SolverInstallPlan' that records in 'solverPkgLibDeps' +-- and 'solverPkgExeDeps' what packages provide the libraries and executables +-- needed by each component of the package (phew!) For example, if I have +-- +-- library +-- build-depends: lib +-- build-tool-depends: pkg:exe1 +-- build-tools: alex +-- +-- After dependency solving, I find out that this library component has +-- library dependencies on lib-0.2, and executable dependencies on pkg-0.1 +-- and alex-0.3 (other components of the package may have different +-- dependencies). Note that I've "lost" the knowledge that I depend +-- *specifically* on the exe1 executable from pkg. +-- +-- So, we have a this graph of packages, and we need to transform it into +-- a graph of components which we are actually going to build. In particular: +-- +-- NODE changes from PACKAGE (SolverPackage) to COMPONENTS (ElaboratedConfiguredPackage) +-- EDGE changes from PACKAGE DEP (SolverId) to COMPONENT DEPS (ConfiguredId) +-- +-- In both cases, what was previously a single node/edge may turn into multiple +-- nodes/edges. Multiple components, because there may be multiple components +-- in a package; multiple component deps, because we may depend upon multiple +-- executables from the same package (and maybe, some day, multiple libraries +-- from the same package.) +-- +-- Let's talk about how to do this transformation. Naively, we might consider +-- just processing each package, converting it into (zero or) one or more +-- components. But we also have to update the edges; this leads to +-- two complications: +-- +-- 1. We don't know what the ConfiguredId of a component is until +-- we've configured it, but we cannot configure a component unless +-- we know the ConfiguredId of all its dependencies. Thus, we must +-- process the 'SolverInstallPlan' in topological order. +-- +-- 2. When we process a package, we know the SolverIds of its +-- dependencies, but we have to do some work to turn these into +-- ConfiguredIds. For example, in the case of build-tool-depends, the +-- SolverId isn't enough to uniquely determine the ConfiguredId we should +-- elaborate to: we have to look at the executable name attached to +-- the package name in the package description to figure it out. +-- At the same time, we NEED to use the SolverId, because there might +-- be multiple versions of the same package in the build plan +-- (due to setup dependencies); we can't just look up the package name +-- from the package description. +-- +-- We can adopt the following strategy: +-- +-- * When a package is transformed into components, record +-- a mapping from SolverId to ALL of the components +-- which were elaborated. +-- +-- * When we look up an edge, we use our knowledge of the +-- component name to *filter* the list of components into +-- the ones we actually wanted to refer to. +-- +-- By the way, we can tell that SolverInstallPlan is not the "right" type +-- because a SolverId cannot adequately represent all possible dependency +-- solver states: we may need to record foo-0.1 multiple times in +-- the solver install plan with different dependencies. This imprecision in the +-- type currently doesn't cause any problems because the dependency solver +-- continues to enforce the single instance restriction regardless of compiler +-- version. The right way to solve this is to come up with something very much +-- like a 'ConfiguredId', in that it incorporates the version choices of its +-- dependencies, but less fine grained. + + +-- | Produce an elaborated install plan using the policy for local builds with +-- a nix-style shared store. +-- +-- In theory should be able to make an elaborated install plan with a policy +-- matching that of the classic @cabal install --user@ or @--global@ +-- +elaborateInstallPlan + :: Verbosity -> Platform -> Compiler -> ProgramDb -> PkgConfigDb + -> DistDirLayout + -> StoreDirLayout + -> SolverInstallPlan + -> [PackageSpecifier (SourcePackage (PackageLocation loc))] + -> Map PackageId PackageSourceHash + -> InstallDirs.InstallDirTemplates + -> ProjectConfigShared + -> PackageConfig + -> PackageConfig + -> Map PackageName PackageConfig + -> LogProgress (ElaboratedInstallPlan, ElaboratedSharedConfig) +elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB + distDirLayout@DistDirLayout{..} + storeDirLayout@StoreDirLayout{storePackageDBStack} + solverPlan localPackages + sourcePackageHashes + defaultInstallDirs + sharedPackageConfig + allPackagesConfig + localPackagesConfig + perPackageConfig = do + x <- elaboratedInstallPlan + return (x, elaboratedSharedConfig) + where + elaboratedSharedConfig = + ElaboratedSharedConfig { + pkgConfigPlatform = platform, + pkgConfigCompiler = compiler, + pkgConfigCompilerProgs = compilerprogdb, + pkgConfigReplOptions = mempty + } + + preexistingInstantiatedPkgs :: Map UnitId FullUnitId + preexistingInstantiatedPkgs = + Map.fromList (mapMaybe f (SolverInstallPlan.toList solverPlan)) + where + f (SolverInstallPlan.PreExisting inst) + | let ipkg = instSolverPkgIPI inst + , not (IPI.indefinite ipkg) + = Just (IPI.installedUnitId ipkg, + (FullUnitId (IPI.installedComponentId ipkg) + (Map.fromList (IPI.instantiatedWith ipkg)))) + f _ = Nothing + + elaboratedInstallPlan :: + LogProgress (InstallPlan.GenericInstallPlan IPI.InstalledPackageInfo ElaboratedConfiguredPackage) + elaboratedInstallPlan = + flip InstallPlan.fromSolverInstallPlanWithProgress solverPlan $ \mapDep planpkg -> + case planpkg of + SolverInstallPlan.PreExisting pkg -> + return [InstallPlan.PreExisting (instSolverPkgIPI pkg)] + + SolverInstallPlan.Configured pkg -> + let inplace_doc | shouldBuildInplaceOnly pkg = text "inplace" + | otherwise = Disp.empty + in addProgressCtx (text "In the" <+> inplace_doc <+> text "package" <+> + quotes (pretty (packageId pkg))) $ + map InstallPlan.Configured <$> elaborateSolverToComponents mapDep pkg + + -- NB: We don't INSTANTIATE packages at this point. That's + -- a post-pass. This makes it simpler to compute dependencies. + elaborateSolverToComponents + :: (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 not_per_component_reasons = why_not_per_component src_comps + if null not_per_component_reasons + then return comps + else do checkPerPackageOk comps not_per_component_reasons + return [elaborateSolverToPackage spkg g $ + comps ++ maybeToList setupComponent] + Left cns -> + dieProgress $ + hang (text "Dependency cycle between the following components:") 4 + (vcat (map (text . componentNameStanza) cns)) + where + -- 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 ++ cuz_coverage + where + cuz reason = [text reason] + -- We have to disable per-component for now with + -- Configure-type scripts in order to prevent parallel + -- invocation of the same `./configure` script. + -- See https://github.com/haskell/cabal/issues/4548 + -- + -- Moreover, at this point in time, only non-Custom setup scripts + -- are supported. 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 PD.buildType (elabPkgDescription elab0) of + PD.Configure -> cuz "build-type is Configure" + PD.Custom -> cuz "build-type is Custom" + _ -> [] + -- 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 = cuz "cabal-version is less than 1.8" + -- 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 = cuz "there are no buildable components" + -- For ease of testing, we let per-component builds be toggled + -- at the top level + cuz_flag + | fromFlagOrDefault True (projectConfigPerComponent sharedPackageConfig) + = [] + | otherwise = cuz "you passed --disable-per-component" + -- Enabling program coverage introduces odd runtime dependencies + -- between components. + cuz_coverage + | fromFlagOrDefault False (packageConfigCoverage localPackagesConfig) + = cuz "program coverage is enabled" + | otherwise = [] + + -- | 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 reasons) + -- TODO: Maybe exclude Backpack too + + elab0 = 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 + | PD.buildType (elabPkgDescription elab0) == PD.Custom + = 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 + = map configuredId dep_pkgs + compLinkedLibDependencies = notImpl "compLinkedLibDependencies" + compOrderLibDependencies = notImpl "compOrderLibDependencies" + -- Not supported: + compExeDependencies = [] + compExeDependencyPaths = [] + 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), + ElaboratedConfiguredPackage) + 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 + + + -- 2. Read out the dependencies from the ConfiguredComponent cc0 + let compLibDependencies = + -- Nub because includes can show up multiple times + ordNub (map (annotatedIdToConfiguredId . ci_ann_id) + (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 + } + cid = case elabBuildStyle elab0 of + BuildInplaceOnly -> + mkComponentId $ + prettyShow pkgid ++ "-inplace" ++ + (case Cabal.componentNameString cname of + Nothing -> "" + Just s -> "-" ++ prettyShow s) + BuildAndInstall -> + hashedInstalledPackageId + (packageHashInputs + 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 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 + } + + -- 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 ] + 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)) + (pkgConfigDbPkgVersion pkgConfigDB pn)) + | PkgconfigDependency pn _ <- PD.pkgconfigDepends + (Cabal.componentBuildInfo comp) ] + + 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 + -- returns at most one result. + elaborateLibSolverId :: (SolverId -> [ElaboratedPlanPackage]) + -> SolverId -> [ElaboratedPlanPackage] + elaborateLibSolverId mapDep = filter (matchPlanPkg (== (CLibName LMainLibName))) . mapDep + + -- | Given an 'ElaboratedPlanPackage', return the paths to where the + -- executables that this package represents would be installed. + -- The only case where multiple paths can be returned is the inplace + -- monolithic package one, since there can be multiple exes and each one + -- has its own directory. + planPackageExePaths :: ElaboratedPlanPackage -> [FilePath] + planPackageExePaths = + -- Pre-existing executables are assumed to be in PATH + -- already. In fact, this should be impossible. + InstallPlan.foldPlanPackage (const []) $ \elab -> + let + executables :: [FilePath] + executables = + case elabPkgOrComp elab of + -- Monolithic mode: all exes of the package + ElabPackage _ -> unUnqualComponentName . PD.exeName + <$> PD.executables (elabPkgDescription elab) + -- Per-component mode: just the selected exe + ElabComponent comp -> + case fmap Cabal.componentNameString + (compComponentName comp) of + Just (Just n) -> [prettyShow n] + _ -> [""] + in + binDirectoryFor + distDirLayout + elaboratedSharedConfig + elab + <$> executables + + elaborateSolverToPackage :: SolverPackage UnresolvedPkgLoc + -> ComponentsGraph + -> [ElaboratedConfiguredPackage] + -> ElaboratedConfiguredPackage + elaborateSolverToPackage + pkg@(SolverPackage (SourcePackage pkgid _gpd _srcloc _descOverride) + _flags _stanzas _deps0 _exe_deps0) + compGraph comps = + -- Knot tying: the final elab includes the + -- pkgInstalledId, which is calculated by hashing many + -- of the other fields of the elaboratedPackage. + elab + where + elab0@ElaboratedConfiguredPackage{..} = elaborateSolverToCommon pkg + elab1 = elab0 { + elabUnitId = newSimpleUnitId pkgInstalledId, + elabComponentId = pkgInstalledId, + elabLinkedInstantiatedWith = Map.empty, + elabPkgOrComp = ElabPackage $ ElaboratedPackage {..}, + elabModuleShape = modShape + } + elab = elab1 { + elabInstallDirs = + computeInstallDirs storeDirLayout + defaultInstallDirs + elaboratedSharedConfig + elab1 + } + + modShape = case find (matchElabPkg (== (CLibName LMainLibName))) comps of + Nothing -> emptyModuleShape + Just e -> Ty.elabModuleShape e + + pkgInstalledId + | shouldBuildInplaceOnly pkg + = mkComponentId (prettyShow pkgid ++ "-inplace") + + | otherwise + = assert (isJust elabPkgSourceHash) $ + hashedInstalledPackageId + (packageHashInputs + elaboratedSharedConfig + elab) -- recursive use of elab + + -- Need to filter out internal dependencies, because they don't + -- correspond to anything real anymore. + isExt confid = confSrcId confid /= pkgid + filterExt = filter isExt + 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 + + pkgDependsOnSelfLib + = CD.fromList [ (CD.componentNameToComponent cn, [()]) + | Graph.N _ cn _ <- fromMaybe [] mb_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 + + buildComponentDeps f + = CD.fromList [ (compSolverName comp, f comp) + | 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 + elaborateSolverToCommon + pkg@(SolverPackage (SourcePackage pkgid gdesc srcloc descOverride) + flags stanzas deps0 _exe_deps0) = + elaboratedPackage + where + elaboratedPackage = ElaboratedConfiguredPackage {..} + + -- 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 True) + platform (compilerInfo compiler) + [] gdesc of + Right (desc, _) -> desc + Left _ -> error "Failed to finalizePD in elaborateSolverToCommon" + elabFlagAssignment = flags + elabFlagDefaults = PD.mkFlagAssignment + [ (Cabal.flagName flag, Cabal.flagDefault flag) + | flag <- PD.genPackageFlags gdesc ] + + elabEnabledSpec = enableStanzas stanzas + elabStanzasAvailable = stanzas + + elabStanzasRequested :: OptionalStanzaMap (Maybe Bool) + elabStanzasRequested = optStanzaTabulate $ \o -> case o of + -- NB: even if a package stanza is requested, if the package + -- doesn't actually have any of that stanza we omit it from + -- the request, to ensure that we don't decide that this + -- package needs to be rebuilt. (It needs to be done here, + -- because the ElaboratedConfiguredPackage is where we test + -- whether or not there have been changes.) + TestStanzas -> listToMaybe [ v | v <- maybeToList tests, _ <- PD.testSuites elabPkgDescription ] + BenchStanzas -> listToMaybe [ v | v <- maybeToList benchmarks, _ <- PD.benchmarks elabPkgDescription ] + where + tests, benchmarks :: Maybe Bool + tests = perPkgOptionMaybe pkgid packageConfigTests + benchmarks = perPkgOptionMaybe pkgid packageConfigBenchmarks + + -- This is a placeholder which will get updated by 'pruneInstallPlanPass1' + -- and 'pruneInstallPlanPass2'. We can't populate it here + -- because whether or not tests/benchmarks should be enabled + -- is heuristically calculated based on whether or not the + -- dependencies of the test suite have already been installed, + -- but this function doesn't know what is installed (since + -- we haven't improved the plan yet), so we do it in another pass. + -- Check the comments of those functions for more details. + elabConfigureTargets = [] + elabBuildTargets = [] + elabTestTargets = [] + elabBenchTargets = [] + elabReplTarget = Nothing + elabHaddockTargets = [] + + elabBuildHaddocks = + perPkgOptionFlag pkgid False packageConfigDocumentation + + elabPkgSourceLocation = srcloc + elabPkgSourceHash = Map.lookup pkgid sourcePackageHashes + elabLocalToProject = isLocalToProject pkg + elabBuildStyle = if shouldBuildInplaceOnly pkg + then BuildInplaceOnly else BuildAndInstall + elabPackageDbs = projectConfigPackageDBs sharedPackageConfig + elabBuildPackageDBStack = buildAndRegisterDbs + elabRegisterPackageDBStack = buildAndRegisterDbs + + elabSetupScriptStyle = packageSetupScriptStyle elabPkgDescription + elabSetupScriptCliVersion = + packageSetupScriptSpecVersion + elabSetupScriptStyle elabPkgDescription libDepGraph deps0 + elabSetupPackageDBStack = buildAndRegisterDbs + + elabInplaceBuildPackageDBStack = inplacePackageDbs + elabInplaceRegisterPackageDBStack = inplacePackageDbs + elabInplaceSetupPackageDBStack = inplacePackageDbs + + buildAndRegisterDbs + | shouldBuildInplaceOnly pkg = inplacePackageDbs + | otherwise = corePackageDbs + + elabPkgDescriptionOverride = descOverride + + elabVanillaLib = perPkgOptionFlag pkgid True packageConfigVanillaLib --TODO: [required feature]: also needs to be handled recursively + elabSharedLib = pkgid `Set.member` pkgsUseSharedLibrary + elabStaticLib = perPkgOptionFlag pkgid False packageConfigStaticLib + elabDynExe = perPkgOptionFlag pkgid False packageConfigDynExe + elabFullyStaticExe = perPkgOptionFlag pkgid False packageConfigFullyStaticExe + elabGHCiLib = perPkgOptionFlag pkgid False packageConfigGHCiLib --TODO: [required feature] needs to default to enabled on windows still + + elabProfExe = perPkgOptionFlag pkgid False packageConfigProf + elabProfLib = pkgid `Set.member` pkgsUseProfilingLibrary + + (elabProfExeDetail, + elabProfLibDetail) = perPkgOptionLibExeFlag pkgid ProfDetailDefault + packageConfigProfDetail + packageConfigProfLibDetail + elabCoverage = perPkgOptionFlag pkgid False packageConfigCoverage + + elabOptimization = perPkgOptionFlag pkgid NormalOptimisation packageConfigOptimization + elabSplitObjs = perPkgOptionFlag pkgid False packageConfigSplitObjs + elabSplitSections = perPkgOptionFlag pkgid False packageConfigSplitSections + elabStripLibs = perPkgOptionFlag pkgid False packageConfigStripLibs + elabStripExes = perPkgOptionFlag pkgid False packageConfigStripExes + elabDebugInfo = perPkgOptionFlag pkgid NoDebugInfo packageConfigDebugInfo + elabDumpBuildInfo = perPkgOptionFlag pkgid NoDumpBuildInfo packageConfigDumpBuildInfo + + -- Combine the configured compiler prog settings with the user-supplied + -- config. For the compiler progs any user-supplied config was taken + -- into account earlier when configuring the compiler so its ok that + -- our configured settings for the compiler override the user-supplied + -- config here. + elabProgramPaths = Map.fromList + [ (programId prog, programPath prog) + | prog <- configuredPrograms compilerprogdb ] + <> perPkgOptionMapLast pkgid packageConfigProgramPaths + elabProgramArgs = Map.fromList + [ (programId prog, args) + | prog <- configuredPrograms compilerprogdb + , let args = programOverrideArgs prog + , not (null args) + ] + <> perPkgOptionMapMappend pkgid packageConfigProgramArgs + elabProgramPathExtra = perPkgOptionNubList pkgid packageConfigProgramPathExtra + 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 + + 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 + + perPkgOptionFlag :: PackageId -> a -> (PackageConfig -> Flag a) -> a + perPkgOptionMaybe :: PackageId -> (PackageConfig -> Flag a) -> Maybe a + perPkgOptionList :: PackageId -> (PackageConfig -> [a]) -> [a] + + perPkgOptionFlag pkgid def f = fromFlagOrDefault def (lookupPerPkgOption pkgid f) + perPkgOptionMaybe pkgid f = flagToMaybe (lookupPerPkgOption pkgid f) + perPkgOptionList pkgid f = lookupPerPkgOption pkgid f + perPkgOptionNubList pkgid f = fromNubList (lookupPerPkgOption pkgid f) + perPkgOptionMapLast pkgid f = getMapLast (lookupPerPkgOption pkgid f) + perPkgOptionMapMappend pkgid f = getMapMappend (lookupPerPkgOption pkgid f) + + perPkgOptionLibExeFlag pkgid def fboth flib = (exe, lib) + where + exe = fromFlagOrDefault def bothflag + lib = fromFlagOrDefault def (bothflag <> libflag) + + bothflag = lookupPerPkgOption pkgid fboth + libflag = lookupPerPkgOption pkgid flib + + lookupPerPkgOption :: (Package pkg, Monoid m) + => pkg -> (PackageConfig -> m) -> m + lookupPerPkgOption pkg f = + -- This is where we merge the options from the project config that + -- apply to all packages, all project local packages, and to specific + -- named packages + global `mappend` local `mappend` perpkg + where + global = f allPackagesConfig + local | isLocalToProject pkg + = f localPackagesConfig + | otherwise + = mempty + perpkg = maybe mempty f (Map.lookup (packageName pkg) perPackageConfig) + + inplacePackageDbs = corePackageDbs + ++ [ distPackageDB (compilerId compiler) ] + + corePackageDbs = applyPackageDbFlags (storePackageDBStack (compilerId 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 + -- source dir packages will also get unpacked locally. + shouldBuildInplaceOnly :: SolverPackage loc -> Bool + shouldBuildInplaceOnly pkg = Set.member (packageId pkg) + pkgsToBuildInplaceOnly + + pkgsToBuildInplaceOnly :: Set PackageId + pkgsToBuildInplaceOnly = + Set.fromList + $ map packageId + $ SolverInstallPlan.reverseDependencyClosure + solverPlan + (map PlannedId (Set.toList pkgsLocalToProject)) + + isLocalToProject :: Package pkg => pkg -> Bool + isLocalToProject pkg = Set.member (packageId pkg) + pkgsLocalToProject + + pkgsLocalToProject :: Set PackageId + pkgsLocalToProject = + Set.fromList (catMaybes (map shouldBeLocal localPackages)) + --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 + where + needsSharedLib pkg = + fromMaybe compilerShouldUseSharedLibByDefault + (liftM2 (||) pkgSharedLib pkgDynExe) + where + pkgid = packageId pkg + pkgSharedLib = perPkgOptionMaybe pkgid packageConfigSharedLib + pkgDynExe = perPkgOptionMaybe pkgid packageConfigDynExe + + --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.isDynamic compiler + GHCJS -> GHCJS.isDynamic compiler + _ -> False + + pkgsUseProfilingLibrary :: Set PackageId + pkgsUseProfilingLibrary = + packagesWithLibDepsDownwardClosedProperty needsProfilingLib + where + needsProfilingLib pkg = + fromFlagOrDefault False (profBothFlag <> profLibFlag) + where + pkgid = packageId pkg + profBothFlag = lookupPerPkgOption pkgid packageConfigProf + profLibFlag = lookupPerPkgOption pkgid packageConfigProfLib + --TODO: [code cleanup] unused: the old deprecated packageConfigProfExe + + libDepGraph = Graph.fromDistinctList $ + map NonSetupLibDepSolverPlanPackage + (SolverInstallPlan.toList solverPlan) + + packagesWithLibDepsDownwardClosedProperty property = + Set.fromList + . map packageId + . fromMaybe [] + $ Graph.closure + libDepGraph + [ Graph.nodeKey pkg + | pkg <- SolverInstallPlan.toList solverPlan + , property pkg ] -- just the packages that satisfy the property + --TODO: [nice to have] this does not check the config consistency, + -- e.g. a package explicitly turning off profiling, but something + -- depending on it that needs profiling. This really needs a separate + -- package config validation/resolution pass. + + --TODO: [nice to have] config consistency checking: + -- + profiling libs & exes, exe needs lib, recursive + -- + shared libs & exes, exe needs lib, recursive + -- + vanilla libs & exes, exe needs lib, recursive + -- + ghci or shared lib needed by TH, recursive, ghc version dependent + +-- 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 + +-- | Given a 'ElaboratedPlanPackage', report if it matches a 'ComponentName'. +matchPlanPkg :: (ComponentName -> Bool) -> ElaboratedPlanPackage -> Bool +matchPlanPkg p = InstallPlan.foldPlanPackage (p . ipiComponentName) (matchElabPkg p) + +-- | Get the appropriate 'ComponentName' which identifies an installed +-- component. +ipiComponentName :: IPI.InstalledPackageInfo -> ComponentName +ipiComponentName = CLibName . IPI.sourceLibName + +-- | Given a 'ElaboratedConfiguredPackage', report if it matches a +-- 'ComponentName'. +matchElabPkg :: (ComponentName -> Bool) -> ElaboratedConfiguredPackage -> Bool +matchElabPkg p elab = + case elabPkgOrComp elab of + ElabComponent comp -> maybe False p (compComponentName comp) + ElabPackage _ -> + -- So, what should we do here? One possibility is to + -- unconditionally return 'True', because whatever it is + -- that we're looking for, it better be in this package. + -- But this is a bit dodgy if the package doesn't actually + -- have, e.g., a library. Fortunately, it's not possible + -- for the build of the library/executables to be toggled + -- by 'pkgStanzasEnabled', so the only thing we have to + -- test is if the component in question is *buildable.* + any (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. +mkCCMapping :: ElaboratedPlanPackage + -> (PackageName, Map ComponentName (AnnotatedId ComponentId)) +mkCCMapping = + InstallPlan.foldPlanPackage + (\ipkg -> (packageName ipkg, + Map.singleton (ipiComponentName ipkg) + -- TODO: libify + (AnnotatedId { + ann_id = IPI.installedComponentId ipkg, + ann_pid = packageId ipkg, + ann_cname = IPI.sourceComponentName ipkg + }))) + $ \elab -> + let mk_aid cn = AnnotatedId { + ann_id = elabComponentId elab, + ann_pid = packageId elab, + ann_cname = cn + } + in (packageName elab, + case elabPkgOrComp elab of + ElabComponent comp -> + case compComponentName comp of + 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)) + (Cabal.pkgBuildableComponents (elabPkgDescription elab))) + +-- | Given an 'ElaboratedPlanPackage', generate the mapping from 'ComponentId' +-- to the shape of this package, as per mix-in linking. +mkShapeMapping :: ElaboratedPlanPackage + -> (ComponentId, (OpenUnitId, ModuleShape)) +mkShapeMapping dpkg = + (getComponentId dpkg, (indef_uid, shape)) + where + (dcid, shape) = + InstallPlan.foldPlanPackage + -- Uses Monad (->) + (liftM2 (,) IPI.installedComponentId shapeInstalledPackage) + (liftM2 (,) elabComponentId elabModuleShape) + dpkg + indef_uid = + IndefFullUnitId dcid + (Map.fromList [ (req, OpenModuleVar req) + | req <- Set.toList (modShapeRequires shape)]) + +-- | Get the bin\/ directories that a package's executables should reside in. +-- +-- The result may be empty if the package does not build any executables. +-- +-- The result may have several entries if this is an inplace build of a package +-- with multiple executables. +binDirectories + :: DistDirLayout + -> ElaboratedSharedConfig + -> ElaboratedConfiguredPackage + -> [FilePath] +binDirectories layout config package = case elabBuildStyle package of + -- quick sanity check: no sense returning a bin directory if we're not going + -- to put any executables in it, that will just clog up the PATH + _ | noExecutables -> [] + BuildAndInstall -> [installedBinDirectory package] + BuildInplaceOnly -> map (root) $ case elabPkgOrComp package of + ElabComponent comp -> case compSolverName comp of + CD.ComponentExe n -> [prettyShow n] + _ -> [] + ElabPackage _ -> map (prettyShow . PD.exeName) + . PD.executables + . elabPkgDescription + $ package + where + noExecutables = null . PD.executables . elabPkgDescription $ package + root = distBuildDirectory layout (elabDistDirParams config package) + "build" + +-- | A newtype for 'SolverInstallPlan.SolverPlanPackage' for which the +-- dependency graph considers only dependencies on libraries which are +-- NOT from setup dependencies. Used to compute the set +-- of packages needed for profiling and dynamic libraries. +newtype NonSetupLibDepSolverPlanPackage + = NonSetupLibDepSolverPlanPackage + { unNonSetupLibDepSolverPlanPackage :: SolverInstallPlan.SolverPlanPackage } + +instance Package NonSetupLibDepSolverPlanPackage where + packageId = packageId . unNonSetupLibDepSolverPlanPackage + +instance IsNode NonSetupLibDepSolverPlanPackage where + type Key NonSetupLibDepSolverPlanPackage = SolverId + nodeKey = nodeKey . unNonSetupLibDepSolverPlanPackage + nodeNeighbors (NonSetupLibDepSolverPlanPackage spkg) + = ordNub $ CD.nonSetupDeps (resolverPackageLibDeps spkg) + +type InstS = Map UnitId ElaboratedPlanPackage +type InstM a = State InstS a + +getComponentId :: ElaboratedPlanPackage + -> ComponentId +getComponentId (InstallPlan.PreExisting dipkg) = IPI.installedComponentId dipkg +getComponentId (InstallPlan.Configured elab) = elabComponentId elab +getComponentId (InstallPlan.Installed elab) = elabComponentId elab + +extractElabBuildStyle :: InstallPlan.GenericPlanPackage ipkg ElaboratedConfiguredPackage + -> BuildStyle +extractElabBuildStyle (InstallPlan.Configured elab) = elabBuildStyle elab +extractElabBuildStyle _ = BuildAndInstall + +-- 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. +-- +-- Suppose we are compiling the following packages: +-- +-- unit f where +-- signature H +-- +-- unit g where +-- dependency f[H=containers:Data.Map] +-- +-- At entry, we have an InstallPlan with a single plan package per +-- actual source package, e.g., only (indefinite!) f and g. The job of +-- instantiation is to turn this into three plan packages: each of the +-- packages as before, but also a new, definite package f[H=containers:Data.Map] +-- +-- How do we do this? The general strategy is to iterate over every +-- package in the existing plan and recursively create new entries for +-- each of its dependencies which is an instantiated package (e.g., +-- f[H=p:G]). This process must be recursive, as f itself may depend on +-- OTHER packages which it instantiated using its hole H. +-- +-- Some subtleties: +-- +-- * We have to keep track of whether or not we are instantiating with +-- inplace packages, because instantiating a non-inplace package with +-- an inplace packages makes it inplace (since it depends on +-- something in the inplace store)! The rule is that if any of the +-- modules in an instantiation are inplace, then the instantiated +-- unit itself must be inplace. There is then a bunch of faffing +-- about to keep track of BuildStyle. +-- +-- * ElaboratedConfiguredPackage was never really designed for post +-- facto instantiation, so some of the steps for generating new +-- instantiations are a little fraught. For example, the act of +-- flipping a package to be inplace involves faffing about with four +-- fields, because these fields are precomputed. A good refactor +-- would be to reduce the amount of precomputation to simplify the +-- algorithm here. +-- +-- * 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)) + where + pkgs = InstallPlan.toList plan + + cmap = Map.fromList [ (getComponentId pkg, pkg) | pkg <- pkgs ] + + instantiateUnitId :: ComponentId -> Map ModuleName (Module, BuildStyle) + -> 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) + where + def_uid = mkDefUnitId cid (fmap fst insts) + uid = unDefUnitId def_uid + + -- No need to InplaceT; the inplace-ness is properly computed for + -- the ElaboratedPlanPackage, so that will implicitly pass it on + instantiateComponent + :: UnitId -> ComponentId -> Map ModuleName (Module, BuildStyle) + -> InstM ElaboratedPlanPackage + instantiateComponent uid cid insts + | Just planpkg <- Map.lookup cid cmap + = 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 = + (if Map.null insts then [] else [newSimpleUnitId cid]) ++ + ordNub (map unDefUnitId + (deps ++ concatMap (getDep . fst) (Map.elems insts))) + } + } + elab = elab1 { + elabInstallDirs = computeInstallDirs storeDirLayout + defaultInstallDirs + 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) = + -- 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) + | 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 + 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) + + fixupBuildStyle BuildAndInstall elab = elab + fixupBuildStyle _ (elab@ElaboratedConfiguredPackage { elabBuildStyle = BuildInplaceOnly }) = elab + fixupBuildStyle BuildInplaceOnly elab = elab { + elabBuildStyle = BuildInplaceOnly, + 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 () + _ -> instantiateUnitId (getComponentId pkg) Map.empty + >> return () + +--------------------------- +-- Build targets +-- + +-- Refer to ProjectPlanning.Types for details of these important types: + +-- data ComponentTarget = ... +-- data SubComponentTarget = ... + +-- One step in the build system is to translate higher level intentions like +-- "build this package", "test that package", or "repl that component" into +-- a more detailed specification of exactly which components to build (or other +-- actions like repl or build docs). This translation is somewhat different for +-- different commands. For example "test" for a package will build a different +-- set of components than "build". In addition, the translation of these +-- intentions can fail. For example "run" for a package is only unambiguous +-- when the package has a single executable. +-- +-- So we need a little bit of infrastructure to make it easy for the command +-- implementations to select what component targets are meant when a user asks +-- to do something with a package or component. To do this (and to be able to +-- produce good error messages for mistakes and when targets are not available) +-- we need to gather and summarise accurate information about all the possible +-- targets, both available and unavailable. Then a command implementation can +-- decide which of the available component targets should be selected. + +-- | An available target represents a component within a package that a user +-- command could plausibly refer to. In this sense, all the components defined +-- within the package are things the user could refer to, whether or not it +-- would actually be possible to build that component. +-- +-- In particular the available target contains an 'AvailableTargetStatus' which +-- informs us about whether it's actually possible to select this component to +-- be built, and if not why not. This detail makes it possible for command +-- implementations (like @build@, @test@ etc) to accurately report why a target +-- cannot be used. +-- +-- Note that the type parameter is used to help enforce that command +-- implementations can only select targets that can actually be built (by +-- forcing them to return the @k@ value for the selected targets). +-- In particular 'resolveTargets' makes use of this (with @k@ as +-- @('UnitId', ComponentName')@) to identify the targets thus selected. +-- +data AvailableTarget k = AvailableTarget { + availableTargetPackageId :: PackageId, + availableTargetComponentName :: ComponentName, + availableTargetStatus :: AvailableTargetStatus k, + availableTargetLocalToProject :: Bool + } + deriving (Eq, Show, Functor) + +-- | The status of a an 'AvailableTarget' component. This tells us whether +-- it's actually possible to select this component to be built, and if not +-- why not. +-- +data AvailableTargetStatus k = + TargetDisabledByUser -- ^ When the user does @tests: False@ + | TargetDisabledBySolver -- ^ When the solver could not enable tests + | TargetNotBuildable -- ^ When the component has @buildable: False@ + | TargetNotLocal -- ^ When the component is non-core in a non-local package + | TargetBuildable k TargetRequested -- ^ The target can or should be built + deriving (Eq, Ord, Show, Functor) + +-- | This tells us whether a target ought to be built by default, or only if +-- specifically requested. The policy is that components like libraries and +-- executables are built by default by @build@, but test suites and benchmarks +-- are not, unless this is overridden in the project configuration. +-- +data TargetRequested = + TargetRequestedByDefault -- ^ To be built by default + | TargetNotRequestedByDefault -- ^ Not to be built by default + deriving (Eq, Ord, Show) + +-- | Given the install plan, produce the set of 'AvailableTarget's for each +-- package-component pair. +-- +-- Typically there will only be one such target for each component, but for +-- example if we have a plan with both normal and profiling variants of a +-- component then we would get both as available targets, or similarly if we +-- had a plan that contained two instances of the same version of a package. +-- This approach makes it relatively easy to select all instances\/variants +-- of a component. +-- +availableTargets :: ElaboratedInstallPlan + -> Map (PackageId, ComponentName) + [AvailableTarget (UnitId, ComponentName)] +availableTargets installPlan = + let rs = [ (pkgid, cname, fake, target) + | pkg <- InstallPlan.toList installPlan + , (pkgid, cname, fake, target) <- case pkg of + InstallPlan.PreExisting ipkg -> availableInstalledTargets ipkg + InstallPlan.Installed elab -> availableSourceTargets elab + InstallPlan.Configured elab -> availableSourceTargets elab + ] + in Map.union + (Map.fromListWith (++) + [ ((pkgid, cname), [target]) + | (pkgid, cname, fake, target) <- rs, not fake]) + (Map.fromList + [ ((pkgid, cname), [target]) + | (pkgid, cname, fake, target) <- rs, fake]) + -- The normal targets mask the fake ones. We get all instances of the + -- normal ones and only one copy of the fake ones (as there are many + -- duplicates of the fake ones). See 'availableSourceTargets' below for + -- more details on this fake stuff is about. + +availableInstalledTargets :: IPI.InstalledPackageInfo + -> [(PackageId, ComponentName, Bool, + AvailableTarget (UnitId, ComponentName))] +availableInstalledTargets ipkg = + let unitid = installedUnitId ipkg + cname = CLibName LMainLibName + status = TargetBuildable (unitid, cname) TargetRequestedByDefault + target = AvailableTarget (packageId ipkg) cname status False + fake = False + in [(packageId ipkg, cname, fake, target)] + +availableSourceTargets :: ElaboratedConfiguredPackage + -> [(PackageId, ComponentName, Bool, + AvailableTarget (UnitId, ComponentName))] +availableSourceTargets elab = + -- We have a somewhat awkward problem here. We need to know /all/ the + -- components from /all/ the packages because these are the things that + -- users could refer to. Unfortunately, at this stage the elaborated install + -- plan does /not/ contain all components: some components have already + -- been deleted because they cannot possibly be built. This is the case + -- for components that are marked @buildable: False@ in their .cabal files. + -- (It's not unreasonable that the unbuildable components have been pruned + -- as the plan invariant is considerably simpler if all nodes can be built) + -- + -- We can recover the missing components but it's not exactly elegant. For + -- a graph node corresponding to a component we still have the information + -- about the package that it came from, and this includes the names of + -- /all/ the other components in the package. So in principle this lets us + -- find the names of all components, plus full details of the buildable + -- components. + -- + -- Consider for example a package with 3 exe components: foo, bar and baz + -- where foo and bar are buildable, but baz is not. So the plan contains + -- nodes for the components foo and bar. Now we look at each of these two + -- nodes and look at the package they come from and the names of the + -- components in this package. This will give us the names foo, bar and + -- baz, twice (once for each of the two buildable components foo and bar). + -- + -- We refer to these reconstructed missing components as fake targets. + -- It is an invariant that they are not available to be built. + -- + -- To produce the final set of targets we put the fake targets in a finite + -- 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) + | component <- pkgComponents (elabPkgDescription elab) + , let cname = componentName component + status = componentAvailableTargetStatus component + target = AvailableTarget { + availableTargetPackageId = packageId elab, + availableTargetComponentName = cname, + availableTargetStatus = status, + availableTargetLocalToProject = elabLocalToProject elab + } + fake = isFakeTarget cname + + -- TODO: The goal of this test is to exclude "instantiated" + -- packages as available targets. This means that you can't + -- ask for a particular instantiated component to be built; + -- it will only get built by a dependency. Perhaps the + -- correct way to implement this is to run selection + -- prior to instantiating packages. If you refactor + -- this, then you can delete this test. + , elabIsCanonical elab + + -- Filter out some bogus parts of the cross product that are never needed + , case status of + TargetBuildable{} | fake -> False + _ -> True + ] + where + isFakeTarget cname = + case elabPkgOrComp elab of + ElabPackage _ -> False + ElabComponent elabComponent -> compComponentName elabComponent + /= Just cname + + componentAvailableTargetStatus + :: Component -> AvailableTargetStatus (UnitId, ComponentName) + componentAvailableTargetStatus component = + case componentOptionalStanza $ CD.componentNameToComponent cname of + -- it is not an optional stanza, so a library, exe or foreign lib + Nothing + | not buildable -> TargetNotBuildable + | otherwise -> TargetBuildable (elabUnitId elab, cname) + TargetRequestedByDefault + + -- it is not an optional stanza, so a testsuite or benchmark + Just stanza -> + case (optStanzaLookup stanza (elabStanzasRequested elab), -- TODO + optStanzaSetMember stanza (elabStanzasAvailable elab)) of + _ | not withinPlan -> TargetNotLocal + (Just False, _) -> TargetDisabledByUser + (Nothing, False) -> TargetDisabledBySolver + _ | not buildable -> TargetNotBuildable + (Just True, True) -> TargetBuildable (elabUnitId elab, cname) + TargetRequestedByDefault + (Nothing, True) -> TargetBuildable (elabUnitId elab, cname) + TargetNotRequestedByDefault + (Just True, False) -> + error $ "componentAvailableTargetStatus: impossible; cname=" ++ prettyShow cname + where + cname = componentName component + buildable = PD.buildable (componentBuildInfo component) + withinPlan = elabLocalToProject elab + || case elabPkgOrComp elab of + ElabComponent elabComponent -> + compComponentName elabComponent == Just cname + ElabPackage _ -> + case componentName component of + CLibName (LMainLibName) -> True + CExeName _ -> True + --TODO: what about sub-libs and foreign libs? + _ -> False + +-- | Merge component targets that overlap each other. Specially when we have +-- multiple targets for the same component and one of them refers to the whole +-- component (rather than a module or file within) then all the other targets +-- for that component are subsumed. +-- +-- We also allow for information associated with each component target, and +-- whenever we targets subsume each other we aggregate their associated info. +-- +nubComponentTargets :: [(ComponentTarget, a)] -> [(ComponentTarget, NonEmpty a)] +nubComponentTargets = + concatMap (wholeComponentOverrides . map snd) + . groupBy ((==) `on` fst) + . sortBy (compare `on` fst) + . map (\t@((ComponentTarget cname _, _)) -> (cname, t)) + . map 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. + wholeComponentOverrides :: [(ComponentTarget, a )] + -> [(ComponentTarget, NonEmpty a)] + wholeComponentOverrides ts = + case [ ta | ta@(ComponentTarget _ WholeComponent, _) <- ts ] of + ((t, x):_) -> + let + -- Delete tuple (t, x) from original list to avoid duplicates. + -- Use 'deleteBy', to avoid additional Class constraint on 'nubComponentTargets'. + ts' = deleteBy (\(t1, _) (t2, _) -> t1 == t2) (t, x) ts + in + [ (t, x :| map snd ts') ] + [] -> [ (t, x :| []) | (t,x) <- ts ] + + -- Not all Cabal Setup.hs versions support sub-component targets, so switch + -- them over to the whole component + compatSubComponentTargets :: (ComponentTarget, a) -> (ComponentTarget, a) + compatSubComponentTargets target@(ComponentTarget cname _subtarget, x) + | not setupHsSupportsSubComponentTargets + = (ComponentTarget cname WholeComponent, x) + | otherwise = target + + -- Actually the reality is that no current version of Cabal's Setup.hs + -- build command actually support building specific files or modules. + setupHsSupportsSubComponentTargets = False + -- TODO: when that changes, adjust this test, e.g. + -- | pkgSetupScriptCliVersion >= Version [x,y] [] + +pkgHasEphemeralBuildTargets :: ElaboratedConfiguredPackage -> Bool +pkgHasEphemeralBuildTargets elab = + isJust (elabReplTarget elab) + || (not . null) (elabTestTargets elab) + || (not . null) (elabBenchTargets elab) + || (not . null) (elabHaddockTargets elab) + || (not . null) [ () | ComponentTarget _ subtarget <- elabBuildTargets elab + , subtarget /= WholeComponent ] + +-- | The components that we'll build all of, meaning that after they're built +-- we can skip building them again (unlike with building just some modules or +-- other files within a component). +-- +elabBuildTargetWholeComponents :: ElaboratedConfiguredPackage + -> Set ComponentName +elabBuildTargetWholeComponents elab = + Set.fromList + [ cname | ComponentTarget cname WholeComponent <- elabBuildTargets elab ] + + + +------------------------------------------------------------------------------ +-- * Install plan pruning +------------------------------------------------------------------------------ + +-- | How 'pruneInstallPlanToTargets' should interpret the per-package +-- 'ComponentTarget's: as build, repl or haddock targets. +-- +data TargetAction = TargetActionConfigure + | TargetActionBuild + | TargetActionRepl + | TargetActionTest + | TargetActionBench + | TargetActionHaddock + +-- | Given a set of per-package\/per-component targets, take the subset of the +-- install plan needed to build those targets. Also, update the package config +-- to specify which optional stanzas to enable, and which targets within each +-- package to build. +-- +-- NB: Pruning happens after improvement, which is important because we +-- will prune differently depending on what is already installed (to +-- implement "sticky" test suite enabling behavior). +-- +pruneInstallPlanToTargets :: TargetAction + -> Map UnitId [ComponentTarget] + -> ElaboratedInstallPlan -> ElaboratedInstallPlan +pruneInstallPlanToTargets targetActionType perPkgTargetsMap elaboratedPlan = + InstallPlan.new (InstallPlan.planIndepGoals elaboratedPlan) + . Graph.fromDistinctList + -- We have to do the pruning in two passes + . pruneInstallPlanPass2 + . pruneInstallPlanPass1 + -- Set the targets that will be the roots for pruning + . setRootTargets targetActionType perPkgTargetsMap + . InstallPlan.toList + $ elaboratedPlan + +-- | This is a temporary data type, where we temporarily +-- override the graph dependencies of an 'ElaboratedPackage', +-- so we can take a closure over them. We'll throw out the +-- overridden dependencies when we're done so it's strictly temporary. +-- +-- For 'ElaboratedComponent', this the cached unit IDs always +-- coincide with the real thing. +data PrunedPackage = PrunedPackage ElaboratedConfiguredPackage [UnitId] + +instance Package PrunedPackage where + packageId (PrunedPackage elab _) = packageId elab + +instance HasUnitId PrunedPackage where + installedUnitId = nodeKey + +instance IsNode PrunedPackage where + type Key PrunedPackage = UnitId + nodeKey (PrunedPackage elab _) = nodeKey elab + nodeNeighbors (PrunedPackage _ deps) = deps + +fromPrunedPackage :: PrunedPackage -> ElaboratedConfiguredPackage +fromPrunedPackage (PrunedPackage elab _) = elab + +-- | Set the build targets based on the user targets (but not rev deps yet). +-- This is required before we can prune anything. +-- +setRootTargets :: TargetAction + -> Map UnitId [ComponentTarget] + -> [ElaboratedPlanPackage] + -> [ElaboratedPlanPackage] +setRootTargets targetAction perPkgTargetsMap = + assert (not (Map.null perPkgTargetsMap)) $ + assert (all (not . null) (Map.elems perPkgTargetsMap)) $ + + map (mapConfiguredPackage setElabBuildTargets) + where + -- Set the targets we'll build for this package/component. This is just + -- based on the root targets from the user, not targets implied by reverse + -- dependencies. Those comes in the second pass once we know the rev deps. + -- + setElabBuildTargets elab = + case (Map.lookup (installedUnitId elab) perPkgTargetsMap, + targetAction) of + (Nothing, _) -> elab + (Just tgts, TargetActionConfigure) -> elab { elabConfigureTargets = tgts } + (Just tgts, TargetActionBuild) -> elab { elabBuildTargets = tgts } + (Just tgts, TargetActionTest) -> elab { elabTestTargets = tgts } + (Just tgts, TargetActionBench) -> elab { elabBenchTargets = tgts } + (Just [tgt], TargetActionRepl) -> elab { elabReplTarget = Just tgt + , elabBuildHaddocks = False } + (Just tgts, TargetActionHaddock) -> + foldr setElabHaddockTargets (elab { elabHaddockTargets = tgts + , elabBuildHaddocks = True }) tgts + (Just _, TargetActionRepl) -> + error "pruneInstallPlanToTargets: multiple repl targets" + + setElabHaddockTargets tgt elab + | isTestComponentTarget tgt = elab { elabHaddockTestSuites = True } + | isBenchComponentTarget tgt = elab { elabHaddockBenchmarks = True } + | isForeignLibComponentTarget tgt = elab { elabHaddockForeignLibs = True } + | isExeComponentTarget tgt = elab { elabHaddockExecutables = True } + | isSubLibComponentTarget tgt = elab { elabHaddockInternal = True } + | otherwise = elab + +-- | Assuming we have previously set the root build targets (i.e. the user +-- targets but not rev deps yet), the first pruning pass does two things: +-- +-- * A first go at determining which optional stanzas (testsuites, benchmarks) +-- are needed. We have a second go in the next pass. +-- * Take the dependency closure using pruned dependencies. We prune deps that +-- 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] + -> [ElaboratedPlanPackage] +pruneInstallPlanPass1 pkgs = + map (mapConfiguredPackage fromPrunedPackage) + (fromMaybe [] $ Graph.closure graph roots) + where + pkgs' = map (mapConfiguredPackage prune) pkgs + graph = Graph.fromDistinctList pkgs' + roots = mapMaybe find_root pkgs' + + prune elab = PrunedPackage elab' (pruneOptionalDependencies elab') + where elab' = + setDocumentation + $ addOptionalStanzas elab + + is_root :: PrunedPackage -> Maybe UnitId + is_root (PrunedPackage elab _) = + if not $ and [ null (elabConfigureTargets elab) + , null (elabBuildTargets elab) + , null (elabTestTargets elab) + , null (elabBenchTargets elab) + , isNothing (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 + + -- Note [Sticky enabled testsuites] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- The testsuite and benchmark targets are somewhat special in that we need + -- to configure the packages with them enabled, and we need to do that even + -- if we only want to build one of several testsuites. + -- + -- There are two cases in which we will enable the testsuites (or + -- benchmarks): if one of the targets is a testsuite, or if all of the + -- testsuite dependencies are already cached in the store. The rationale + -- for the latter is to minimise how often we have to reconfigure due to + -- the particular targets we choose to build. Otherwise choosing to build + -- a testsuite target, and then later choosing to build an exe target + -- would involve unnecessarily reconfiguring the package with testsuites + -- disabled. Technically this introduces a little bit of stateful + -- behaviour to make this "sticky", but it should be benign. + + -- Decide whether or not to enable testsuites and benchmarks. + -- See [Sticky enabled testsuites] + addOptionalStanzas :: ElaboratedConfiguredPackage -> ElaboratedConfiguredPackage + addOptionalStanzas elab@ElaboratedConfiguredPackage{ elabPkgOrComp = ElabPackage pkg } = + elab { + elabPkgOrComp = ElabPackage (pkg { pkgStanzasEnabled = stanzas }) + } + where + stanzas :: OptionalStanzaSet + -- By default, we enabled all stanzas requested by the user, + -- as per elabStanzasRequested, done in + -- 'elaborateSolverToPackage' + stanzas = pkgStanzasEnabled pkg + -- optionalStanzasRequiredByTargets has to be done at + -- prune-time because it depends on 'elabTestTargets' + -- et al, which is done by 'setRootTargets' at the + -- beginning of pruning. + <> optionalStanzasRequiredByTargets elab + -- optionalStanzasWithDepsAvailable has to be done at + -- prune-time because it depends on what packages are + -- installed, which is not known until after improvement + -- (pruning is done after improvement) + <> optionalStanzasWithDepsAvailable availablePkgs elab pkg + addOptionalStanzas elab = elab + + setDocumentation :: ElaboratedConfiguredPackage -> ElaboratedConfiguredPackage + setDocumentation elab@ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent comp } = + elab { + elabBuildHaddocks = + elabBuildHaddocks elab && documentationEnabled (compSolverName comp) elab + } + + where + documentationEnabled c = + case c of + CD.ComponentLib -> const True + CD.ComponentSubLib _ -> elabHaddockInternal + CD.ComponentFLib _ -> elabHaddockForeignLibs + CD.ComponentExe _ -> elabHaddockExecutables + CD.ComponentTest _ -> elabHaddockTestSuites + CD.ComponentBench _ -> elabHaddockBenchmarks + CD.ComponentSetup -> const False + + setDocumentation elab = elab + + -- Calculate package dependencies but cut out those needed only by + -- optional stanzas that we've determined we will not enable. + -- These pruned deps are not persisted in this pass since they're based on + -- the optional stanzas and we'll make further tweaks to the optional + -- stanzas in the next pass. + -- + pruneOptionalDependencies :: ElaboratedConfiguredPackage -> [UnitId] + pruneOptionalDependencies elab@ElaboratedConfiguredPackage{ elabPkgOrComp = ElabComponent _ } + = InstallPlan.depends elab -- no pruning + pruneOptionalDependencies ElaboratedConfiguredPackage{ elabPkgOrComp = ElabPackage pkg } + = (CD.flatDeps . CD.filterDeps keepNeeded) (pkgOrderDependencies pkg) + where + keepNeeded (CD.ComponentTest _) _ = TestStanzas `optStanzaSetMember` stanzas + keepNeeded (CD.ComponentBench _) _ = BenchStanzas `optStanzaSetMember` stanzas + keepNeeded _ _ = True + stanzas = pkgStanzasEnabled pkg + + optionalStanzasRequiredByTargets :: ElaboratedConfiguredPackage + -> OptionalStanzaSet + optionalStanzasRequiredByTargets pkg = + optStanzaSetFromList + [ stanza + | ComponentTarget cname _ <- elabBuildTargets pkg + ++ elabTestTargets pkg + ++ elabBenchTargets pkg + ++ maybeToList (elabReplTarget pkg) + ++ elabHaddockTargets pkg + , stanza <- maybeToList $ + componentOptionalStanza $ + CD.componentNameToComponent cname + ] + + availablePkgs = + Set.fromList + [ installedUnitId pkg + | InstallPlan.PreExisting pkg <- pkgs ] + +-- | Given a set of already installed packages @availablePkgs@, +-- determine the set of available optional stanzas from @pkg@ +-- which have all of their dependencies already installed. This is used +-- to implement "sticky" testsuites, where once we have installed +-- all of the deps needed for the test suite, we go ahead and +-- enable it always. +optionalStanzasWithDepsAvailable :: Set UnitId + -> ElaboratedConfiguredPackage + -> ElaboratedPackage + -> OptionalStanzaSet +optionalStanzasWithDepsAvailable availablePkgs elab pkg = + optStanzaSetFromList + [ stanza + | stanza <- optStanzaSetToList (elabStanzasAvailable elab) + , let deps :: [UnitId] + deps = CD.select (optionalStanzaDeps stanza) + -- TODO: probably need to select other + -- dep types too eventually + (pkgOrderDependencies pkg) + , all (`Set.member` availablePkgs) deps + ] + where + optionalStanzaDeps TestStanzas (CD.ComponentTest _) = True + optionalStanzaDeps BenchStanzas (CD.ComponentBench _) = True + optionalStanzaDeps _ _ = False + + +-- The second pass does three things: +-- +-- * A second go at deciding which optional stanzas to enable. +-- * Prune the dependencies based on the final choice of optional stanzas. +-- * Extend the targets within each package to build, now we know the reverse +-- dependencies, ie we know which libs are needed as deps by other packages. +-- +-- Achieving sticky behaviour with enabling\/disabling optional stanzas is +-- tricky. The first approximation was handled by the first pass above, but +-- it's not quite enough. That pass will enable stanzas if all of the deps +-- of the optional stanza are already installed /in the store/. That's important +-- but it does not account for dependencies that get built inplace as part of +-- the project. We cannot take those inplace build deps into account in the +-- pruning pass however because we don't yet know which ones we're going to +-- build. Once we do know, we can have another go and enable stanzas that have +-- all their deps available. Now we can consider all packages in the pruned +-- plan to be available, including ones we already decided to build from +-- source. +-- +-- Deciding which targets to build depends on knowing which packages have +-- reverse dependencies (ie are needed). This requires the result of first +-- pass, which is another reason we have to split it into two passes. +-- +-- Note that just because we might enable testsuites or benchmarks (in the +-- first or second pass) doesn't mean that we build all (or even any) of them. +-- That depends on which targets we picked in the first pass. +-- +pruneInstallPlanPass2 :: [ElaboratedPlanPackage] + -> [ElaboratedPlanPackage] +pruneInstallPlanPass2 pkgs = + map (mapConfiguredPackage setStanzasDepsAndTargets) pkgs + where + setStanzasDepsAndTargets elab = + elab { + elabBuildTargets = ordNub + $ elabBuildTargets elab + ++ libTargetsRequiredForRevDeps + ++ exeTargetsRequiredForRevDeps, + elabPkgOrComp = + case elabPkgOrComp elab of + ElabPackage pkg -> + let stanzas = pkgStanzasEnabled pkg + <> optionalStanzasWithDepsAvailable availablePkgs elab pkg + keepNeeded (CD.ComponentTest _) _ = TestStanzas `optStanzaSetMember` stanzas + keepNeeded (CD.ComponentBench _) _ = BenchStanzas `optStanzaSetMember` stanzas + keepNeeded _ _ = True + in ElabPackage $ pkg { + pkgStanzasEnabled = stanzas, + pkgLibDependencies = CD.filterDeps keepNeeded (pkgLibDependencies pkg), + pkgExeDependencies = CD.filterDeps keepNeeded (pkgExeDependencies pkg), + pkgExeDependencyPaths = CD.filterDeps keepNeeded (pkgExeDependencyPaths pkg) + } + r@(ElabComponent _) -> r + } + where + libTargetsRequiredForRevDeps = + [ ComponentTarget (CLibName Cabal.defaultLibName) WholeComponent + | installedUnitId elab `Set.member` hasReverseLibDeps + ] + exeTargetsRequiredForRevDeps = + -- TODO: allow requesting executable with different name + -- than package name + [ ComponentTarget (Cabal.CExeName + $ packageNameToUnqualComponentName + $ packageName $ elabPkgSourceId elab) + WholeComponent + | installedUnitId elab `Set.member` hasReverseExeDeps + ] + + + availablePkgs :: Set UnitId + availablePkgs = Set.fromList (map installedUnitId pkgs) + + hasReverseLibDeps :: Set UnitId + hasReverseLibDeps = + Set.fromList [ depid + | InstallPlan.Configured pkg <- pkgs + , depid <- elabOrderLibDependencies pkg ] + + hasReverseExeDeps :: Set UnitId + hasReverseExeDeps = + Set.fromList [ depid + | InstallPlan.Configured pkg <- pkgs + , depid <- elabOrderExeDependencies pkg ] + +mapConfiguredPackage :: (srcpkg -> srcpkg') + -> InstallPlan.GenericPlanPackage ipkg srcpkg + -> InstallPlan.GenericPlanPackage ipkg srcpkg' +mapConfiguredPackage f (InstallPlan.Configured pkg) = + InstallPlan.Configured (f pkg) +mapConfiguredPackage f (InstallPlan.Installed pkg) = + InstallPlan.Installed (f pkg) +mapConfiguredPackage _ (InstallPlan.PreExisting pkg) = + InstallPlan.PreExisting pkg + +------------------------------------ +-- Support for --only-dependencies +-- + +-- | Try to remove the given targets from the install plan. +-- +-- This is not always possible. +-- +pruneInstallPlanToDependencies :: Set UnitId + -> ElaboratedInstallPlan + -> Either CannotPruneDependencies + ElaboratedInstallPlan +pruneInstallPlanToDependencies pkgTargets installPlan = + assert (all (isJust . InstallPlan.lookup installPlan) + (Set.toList pkgTargets)) $ + + fmap (InstallPlan.new (InstallPlan.planIndepGoals installPlan)) + . checkBrokenDeps + . Graph.fromDistinctList + . filter (\pkg -> installedUnitId pkg `Set.notMember` pkgTargets) + . InstallPlan.toList + $ installPlan + where + -- Our strategy is to remove the packages we don't want and then check + -- if the remaining graph is broken or not, ie any packages with dangling + -- dependencies. If there are then we cannot prune the given targets. + checkBrokenDeps :: Graph.Graph ElaboratedPlanPackage + -> Either CannotPruneDependencies + (Graph.Graph ElaboratedPlanPackage) + checkBrokenDeps graph = + case Graph.broken graph of + [] -> Right graph + brokenPackages -> + Left $ CannotPruneDependencies + [ (pkg, missingDeps) + | (pkg, missingDepIds) <- brokenPackages + , let missingDeps = mapMaybe lookupDep missingDepIds + ] + where + -- lookup in the original unpruned graph + lookupDep = InstallPlan.lookup installPlan + +-- | It is not always possible to prune to only the dependencies of a set of +-- targets. It may be the case that removing a package leaves something else +-- that still needed the pruned package. +-- +-- This lists all the packages that would be broken, and their dependencies +-- that would be missing if we did prune. +-- +newtype CannotPruneDependencies = + CannotPruneDependencies [(ElaboratedPlanPackage, + [ElaboratedPlanPackage])] + deriving (Show) + + +--------------------------- +-- Setup.hs script policy +-- + +-- Handling for Setup.hs scripts is a bit tricky, part of it lives in the +-- solver phase, and part in the elaboration phase. We keep the helper +-- functions for both phases together here so at least you can see all of it +-- in one place. +-- +-- There are four major cases for Setup.hs handling: +-- +-- 1. @build-type@ Custom with a @custom-setup@ section +-- 2. @build-type@ Custom without a @custom-setup@ section +-- 3. @build-type@ not Custom with @cabal-version > $our-cabal-version@ +-- 4. @build-type@ not Custom with @cabal-version <= $our-cabal-version@ +-- +-- It's also worth noting that packages specifying @cabal-version: >= 1.23@ +-- or later that have @build-type@ Custom will always have a @custom-setup@ +-- section. Therefore in case 2, the specified @cabal-version@ will always be +-- less than 1.23. +-- +-- In cases 1 and 2 we obviously have to build an external Setup.hs script, +-- while in case 4 we can use the internal library API. +-- +-- TODO:In case 3 we should fail. We don't know how to talk to +-- newer ./Setup.hs +-- +-- data SetupScriptStyle = ... -- see ProjectPlanning.Types + +-- | Work out the 'SetupScriptStyle' given the package description. +-- +packageSetupScriptStyle :: PD.PackageDescription -> SetupScriptStyle +packageSetupScriptStyle pkg + | buildType == PD.Custom + , Just setupbi <- PD.setupBuildInfo pkg -- does have a custom-setup stanza + , not (PD.defaultSetupDepends setupbi) -- but not one we added internally + = SetupCustomExplicitDeps + + | buildType == PD.Custom + , Just setupbi <- PD.setupBuildInfo pkg -- we get this case post-solver as + , PD.defaultSetupDepends setupbi -- the solver fills in the deps + = SetupCustomImplicitDeps + + | buildType == PD.Custom + , Nothing <- PD.setupBuildInfo pkg -- we get this case pre-solver + = SetupCustomImplicitDeps + + -- here we should fail. + | PD.specVersion pkg > cabalSpecLatest -- one cabal-install is built against + = SetupNonCustomExternalLib + + | otherwise + = SetupNonCustomInternalLib + where + buildType = PD.buildType pkg + + +-- | Part of our Setup.hs handling policy is implemented by getting the solver +-- to work out setup dependencies for packages. The solver already handles +-- packages that explicitly specify setup dependencies, but we can also tell +-- the solver to treat other packages as if they had setup dependencies. +-- That's what this function does, it gets called by the solver for all +-- packages that don't already have setup dependencies. +-- +-- The dependencies we want to add is different for each 'SetupScriptStyle'. +-- +-- Note that adding default deps means these deps are actually /added/ to the +-- packages that we get out of the solver in the 'SolverInstallPlan'. Making +-- implicit setup deps explicit is a problem in the post-solver stages because +-- we still need to distinguish the case of explicit and implicit setup deps. +-- See 'rememberImplicitSetupDeps'. +-- +-- Note in addition to adding default setup deps, we also use +-- 'addSetupCabalMinVersionConstraint' (in 'planPackages') to require +-- @Cabal >= 1.20@ for Setup scripts. +-- +defaultSetupDeps :: Compiler -> Platform + -> PD.PackageDescription + -> Maybe [Dependency] +defaultSetupDeps compiler platform pkg = + case packageSetupScriptStyle pkg of + + -- For packages with build type custom that do not specify explicit + -- setup dependencies, we add a dependency on Cabal and a number + -- of other packages. + SetupCustomImplicitDeps -> + Just $ + [ Dependency depPkgname anyVersion mainLibSet + | depPkgname <- legacyCustomSetupPkgs compiler platform ] ++ + [ Dependency cabalPkgname cabalConstraint mainLibSet + | packageName pkg /= cabalPkgname ] + where + -- The Cabal dep is slightly special: + -- * We omit the dep for the Cabal lib itself, since it bootstraps. + -- * We constrain it to be < 1.25 + -- + -- Note: we also add a global constraint to require Cabal >= 1.20 + -- for Setup scripts (see use addSetupCabalMinVersionConstraint). + -- + cabalConstraint = orLaterVersion (csvToVersion (PD.specVersion pkg)) + `intersectVersionRanges` + earlierVersion cabalCompatMaxVer + -- The idea here is that at some point we will make significant + -- breaking changes to the Cabal API that Setup.hs scripts use. + -- So for old custom Setup scripts that do not specify explicit + -- constraints, we constrain them to use a compatible Cabal version. + cabalCompatMaxVer = mkVersion [1,25] + + -- For other build types (like Simple) if we still need to compile an + -- external Setup.hs, it'll be one of the simple ones that only depends + -- on Cabal and base. + SetupNonCustomExternalLib -> + Just [ Dependency cabalPkgname cabalConstraint mainLibSet + , Dependency basePkgname anyVersion mainLibSet] + where + cabalConstraint = orLaterVersion (csvToVersion (PD.specVersion pkg)) + + -- The internal setup wrapper method has no deps at all. + SetupNonCustomInternalLib -> Just [] + + -- This case gets ruled out by the caller, planPackages, see the note + -- above in the SetupCustomImplicitDeps case. + SetupCustomExplicitDeps -> + error $ "defaultSetupDeps: called for a package with explicit " + ++ "setup deps: " ++ prettyShow (packageId pkg) + where + -- we require one less + -- + -- This maps e.g. CabalSpecV3_0 to mkVersion [2,5] + csvToVersion :: CabalSpecVersion -> Version + csvToVersion = mkVersion . cabalSpecMinimumLibraryVersion + +-- | Work out which version of the Cabal we will be using to talk to the +-- Setup.hs interface for this package. +-- +-- This depends somewhat on the 'SetupScriptStyle' but most cases are a result +-- of what the solver picked for us, based on the explicit setup deps or the +-- ones added implicitly by 'defaultSetupDeps'. +-- +packageSetupScriptSpecVersion :: SetupScriptStyle + -> PD.PackageDescription + -> Graph.Graph NonSetupLibDepSolverPlanPackage + -> ComponentDeps [SolverId] + -> Version + +-- We're going to be using the internal Cabal library, so the spec version of +-- that is simply the version of the Cabal library that cabal-install has been +-- built with. +packageSetupScriptSpecVersion SetupNonCustomInternalLib _ _ _ = + cabalVersion + +-- If we happen to be building the Cabal lib itself then because that +-- bootstraps itself then we use the version of the lib we're building. +packageSetupScriptSpecVersion SetupCustomImplicitDeps pkg _ _ + | packageName pkg == cabalPkgname + = packageVersion pkg + +-- In all other cases we have a look at what version of the Cabal lib the +-- solver picked. Or if it didn't depend on Cabal at all (which is very rare) +-- then we look at the .cabal file to see what spec version it declares. +packageSetupScriptSpecVersion _ pkg libDepGraph deps = + case find ((cabalPkgname ==) . packageName) setupLibDeps of + Just dep -> packageVersion dep + Nothing -> mkVersion (cabalSpecMinimumLibraryVersion (PD.specVersion pkg)) + where + setupLibDeps = map packageId $ fromMaybe [] $ + Graph.closure libDepGraph (CD.setupDeps deps) + + +cabalPkgname, basePkgname :: PackageName +cabalPkgname = mkPackageName "Cabal" +basePkgname = mkPackageName "base" + + +legacyCustomSetupPkgs :: Compiler -> Platform -> [PackageName] +legacyCustomSetupPkgs compiler (Platform _ os) = + map mkPackageName $ + [ "array", "base", "binary", "bytestring", "containers" + , "deepseq", "directory", "filepath", "pretty" + , "process", "time", "transformers" ] + ++ [ "Win32" | os == Windows ] + ++ [ "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] + +-- The other aspects of our Setup.hs policy lives here where we decide on +-- the 'SetupScriptOptions'. +-- +-- Our current policy for the 'SetupCustomImplicitDeps' case is that we +-- try to make the implicit deps cover everything, and we don't allow the +-- compiler to pick up other deps. This may or may not be sustainable, and +-- we might have to allow the deps to be non-exclusive, but that itself would +-- be tricky since we would have to allow the Setup access to all the packages +-- in the store and local dbs. + +setupHsScriptOptions :: ElaboratedReadyPackage + -> ElaboratedInstallPlan + -> ElaboratedSharedConfig + -> DistDirLayout + -> FilePath + -> FilePath + -> Bool + -> Lock + -> SetupScriptOptions +-- TODO: Fix this so custom is a separate component. Custom can ALWAYS +-- be a separate component!!! +setupHsScriptOptions (ReadyPackage elab@ElaboratedConfiguredPackage{..}) + plan ElaboratedSharedConfig{..} distdir srcdir builddir + isParallelBuild cacheLock = + SetupScriptOptions { + useCabalVersion = thisVersion elabSetupScriptCliVersion, + useCabalSpecVersion = Just elabSetupScriptCliVersion, + useCompiler = Just pkgConfigCompiler, + usePlatform = Just pkgConfigPlatform, + usePackageDB = elabSetupPackageDBStack, + usePackageIndex = Nothing, + useDependencies = [ (uid, srcid) + | ConfiguredId srcid (Just (CLibName LMainLibName)) uid + <- elabSetupDependencies elab ], + useDependenciesExclusive = True, + useVersionMacros = elabSetupScriptStyle == SetupCustomExplicitDeps, + useProgramDb = pkgConfigCompilerProgs, + useDistPref = builddir, + useLoggingHandle = Nothing, -- this gets set later + useWorkingDir = Just srcdir, + useExtraPathEnv = elabExeDependencyPaths elab, + useExtraEnvOverrides = dataDirsEnvironmentForPlan distdir plan, + useWin32CleanHack = False, --TODO: [required eventually] + forceExternalSetupMethod = isParallelBuild, + setupCacheLock = Just cacheLock, + isInteractive = False + } + + +-- | To be used for the input for elaborateInstallPlan. +-- +-- TODO: [code cleanup] make InstallDirs.defaultInstallDirs pure. +-- +userInstallDirTemplates :: Compiler + -> IO InstallDirs.InstallDirTemplates +userInstallDirTemplates compiler = do + InstallDirs.defaultInstallDirs + (compilerFlavor compiler) + True -- user install + False -- unused + +storePackageInstallDirs :: StoreDirLayout + -> CompilerId + -> InstalledPackageId + -> InstallDirs.InstallDirs FilePath +storePackageInstallDirs storeDirLayout compid ipkgid = + storePackageInstallDirs' storeDirLayout compid $ newSimpleUnitId ipkgid + +storePackageInstallDirs' :: StoreDirLayout + -> CompilerId + -> UnitId + -> InstallDirs.InstallDirs FilePath +storePackageInstallDirs' StoreDirLayout{ storePackageDirectory + , storeDirectory } + compid unitid = + InstallDirs.InstallDirs {..} + where + store = storeDirectory compid + prefix = storePackageDirectory compid unitid + bindir = prefix "bin" + libdir = prefix "lib" + libsubdir = "" + -- Note: on macOS, we place libraries into + -- @store/lib@ to work around the load + -- command size limit of macOSs mach-o linker. + -- See also @PackageHash.hashedInstalledPackageIdVeryShort@ + dynlibdir | buildOS == OSX = store "lib" + | otherwise = libdir + flibdir = libdir + libexecdir = prefix "libexec" + libexecsubdir= "" + includedir = libdir "include" + datadir = prefix "share" + datasubdir = "" + docdir = datadir "doc" + mandir = datadir "man" + htmldir = docdir "html" + haddockdir = htmldir + sysconfdir = prefix "etc" + + + +computeInstallDirs :: StoreDirLayout + -> InstallDirs.InstallDirTemplates + -> ElaboratedSharedConfig + -> ElaboratedConfiguredPackage + -> InstallDirs.InstallDirs FilePath +computeInstallDirs storeDirLayout defaultInstallDirs elaboratedShared elab + | elabBuildStyle elab == BuildInplaceOnly + -- use the ordinary default install dirs + = (InstallDirs.absoluteInstallDirs + (elabPkgSourceId elab) + (elabUnitId elab) + (compilerInfo (pkgConfigCompiler elaboratedShared)) + InstallDirs.NoCopyDest + (pkgConfigPlatform elaboratedShared) + defaultInstallDirs) { + + -- absoluteInstallDirs sets these as 'undefined' but we have + -- to use them as "Setup.hs configure" args + InstallDirs.libsubdir = "", + InstallDirs.libexecsubdir = "", + InstallDirs.datasubdir = "" + } + + | otherwise + -- use special simplified install dirs + = storePackageInstallDirs' + storeDirLayout + (compilerId (pkgConfigCompiler elaboratedShared)) + (elabUnitId elab) + + +--TODO: [code cleanup] perhaps reorder this code +-- based on the ElaboratedInstallPlan + ElaboratedSharedConfig, +-- make the various Setup.hs {configure,build,copy} flags + + +setupHsConfigureFlags :: ElaboratedReadyPackage + -> ElaboratedSharedConfig + -> Verbosity + -> FilePath + -> Cabal.ConfigFlags +setupHsConfigureFlags (ReadyPackage elab@ElaboratedConfiguredPackage{..}) + sharedConfig@ElaboratedSharedConfig{..} + verbosity builddir = + sanityCheckElaboratedConfiguredPackage sharedConfig elab + (Cabal.ConfigFlags {..}) + where + configArgs = mempty -- unused, passed via args + configDistPref = toFlag builddir + configCabalFilePath = mempty + configVerbosity = toFlag verbosity + + configInstantiateWith = Map.toList elabInstantiatedWith + + configDeterministic = mempty -- doesn't matter, configIPID/configCID overridese + configIPID = case elabPkgOrComp of + ElabPackage pkg -> toFlag (prettyShow (pkgInstalledId pkg)) + ElabComponent _ -> mempty + configCID = case elabPkgOrComp of + ElabPackage _ -> mempty + 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 + configProgramPathExtra = toNubList elabProgramPathExtra + configHcFlavor = toFlag (compilerFlavor pkgConfigCompiler) + configHcPath = mempty -- we use configProgramPaths instead + configHcPkg = mempty -- we use configProgramPaths instead + + configVanillaLib = toFlag elabVanillaLib + configSharedLib = toFlag elabSharedLib + configStaticLib = toFlag elabStaticLib + + configDynExe = toFlag elabDynExe + configFullyStaticExe = toFlag elabFullyStaticExe + configGHCiLib = toFlag elabGHCiLib + configProfExe = mempty + configProfLib = toFlag elabProfLib + configProf = toFlag elabProfExe + + -- configProfDetail is for exe+lib, but overridden by configProfLibDetail + -- so we specify both so we can specify independently + configProfDetail = toFlag elabProfExeDetail + configProfLibDetail = toFlag elabProfLibDetail + + configCoverage = toFlag elabCoverage + configLibCoverage = mempty + + configOptimization = toFlag elabOptimization + configSplitSections = toFlag elabSplitSections + configSplitObjs = toFlag elabSplitObjs + configStripExes = toFlag elabStripExes + configStripLibs = toFlag elabStripLibs + configDebugInfo = toFlag elabDebugInfo + configDumpBuildInfo = toFlag elabDumpBuildInfo + + configConfigurationsFlags = elabFlagAssignment + configConfigureArgs = elabConfigureScriptArgs + configExtraLibDirs = elabExtraLibDirs + configExtraLibDirsStatic = elabExtraLibDirsStatic + configExtraFrameworkDirs = elabExtraFrameworkDirs + configExtraIncludeDirs = elabExtraIncludeDirs + configProgPrefix = maybe mempty toFlag elabProgPrefix + configProgSuffix = maybe mempty toFlag elabProgSuffix + + configInstallDirs = fmap (toFlag . InstallDirs.toPathTemplate) + elabInstallDirs + + -- we only use configDependencies, unless we're talking to an old Cabal + -- in which case we use configConstraints + -- NB: This does NOT use InstallPlan.depends, which includes executable + -- dependencies which should NOT be fed in here (also you don't have + -- enough info anyway) + configDependencies = [ GivenComponent + (packageName srcid) + ln + cid + | ConfiguredId srcid mb_cn cid <- elabLibDependencies elab + , let ln = case mb_cn + of Just (CLibName lname) -> lname + Just _ -> error "non-library dependency" + Nothing -> LMainLibName + ] + configConstraints = + case elabPkgOrComp of + ElabPackage _ -> + [ thisPackageVersionConstraint srcid + | ConfiguredId srcid _ _uid <- elabLibDependencies elab ] + ElabComponent _ -> [] + + + -- explicitly clear, then our package db stack + -- TODO: [required eventually] have to do this differently for older Cabal versions + configPackageDBs = Nothing : map Just elabBuildPackageDBStack + + 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 + + configExactConfiguration = toFlag True + configFlagError = mempty --TODO: [research required] appears not to be implemented + configRelocatable = mempty --TODO: [research required] ??? + configScratchDir = mempty -- never use + configUserInstall = mempty -- don't rely on defaults + configPrograms_ = mempty -- never use, shouldn't exist + configUseResponseFiles = mempty + configAllowDependingOnPrivateLibs = Flag $ not $ libraryVisibilitySupported pkgConfigCompiler + +setupHsConfigureArgs :: ElaboratedConfiguredPackage + -> [String] +setupHsConfigureArgs (ElaboratedConfiguredPackage { elabPkgOrComp = ElabPackage _ }) = [] +setupHsConfigureArgs elab@(ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent comp }) = + [showComponentTarget (packageId elab) (ComponentTarget cname WholeComponent)] + where + cname = fromMaybe (error "setupHsConfigureArgs: trying to configure setup") + (compComponentName comp) + +setupHsBuildFlags :: ElaboratedConfiguredPackage + -> ElaboratedSharedConfig + -> Verbosity + -> FilePath + -> Cabal.BuildFlags +setupHsBuildFlags _ _ verbosity builddir = + Cabal.BuildFlags { + buildProgramPaths = mempty, --unused, set at configure time + buildProgramArgs = mempty, --unused, set at configure time + buildVerbosity = toFlag verbosity, + buildDistPref = toFlag builddir, + buildNumJobs = mempty, --TODO: [nice to have] sometimes want to use toFlag (Just numBuildJobs), + buildArgs = mempty, -- unused, passed via args not flags + buildCabalFilePath= mempty + } + + +setupHsBuildArgs :: ElaboratedConfiguredPackage -> [String] +setupHsBuildArgs elab@(ElaboratedConfiguredPackage { elabPkgOrComp = ElabPackage _ }) + -- Fix for #3335, don't pass build arguments if it's not supported + | elabSetupScriptCliVersion elab >= mkVersion [1,17] + = map (showComponentTarget (packageId elab)) (elabBuildTargets elab) + | otherwise + = [] +setupHsBuildArgs (ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent _ }) + = [] + + +setupHsTestFlags :: ElaboratedConfiguredPackage + -> ElaboratedSharedConfig + -> Verbosity + -> FilePath + -> Cabal.TestFlags +setupHsTestFlags (ElaboratedConfiguredPackage{..}) _ verbosity builddir = Cabal.TestFlags + { testDistPref = toFlag builddir + , testVerbosity = toFlag verbosity + , testMachineLog = maybe mempty toFlag elabTestMachineLog + , testHumanLog = maybe mempty toFlag elabTestHumanLog + , testShowDetails = maybe (Flag Cabal.Always) toFlag elabTestShowDetails + , testKeepTix = toFlag elabTestKeepTix + , testWrapper = maybe mempty toFlag elabTestWrapper + , testFailWhenNoTestSuites = toFlag elabTestFailWhenNoTestSuites + , testOptions = elabTestTestOptions + } + +setupHsTestArgs :: ElaboratedConfiguredPackage -> [String] +-- TODO: Does the issue #3335 affects test as well +setupHsTestArgs elab = + mapMaybe (showTestComponentTarget (packageId elab)) (elabTestTargets elab) + + +setupHsBenchFlags :: ElaboratedConfiguredPackage + -> ElaboratedSharedConfig + -> Verbosity + -> FilePath + -> Cabal.BenchmarkFlags +setupHsBenchFlags (ElaboratedConfiguredPackage{..}) _ verbosity builddir = Cabal.BenchmarkFlags + { benchmarkDistPref = toFlag builddir + , benchmarkVerbosity = toFlag verbosity + , benchmarkOptions = elabBenchmarkOptions + } + +setupHsBenchArgs :: ElaboratedConfiguredPackage -> [String] +setupHsBenchArgs elab = + mapMaybe (showBenchComponentTarget (packageId elab)) (elabBenchTargets elab) + + +setupHsReplFlags :: ElaboratedConfiguredPackage + -> ElaboratedSharedConfig + -> Verbosity + -> FilePath + -> Cabal.ReplFlags +setupHsReplFlags _ sharedConfig verbosity builddir = + Cabal.ReplFlags { + replProgramPaths = mempty, --unused, set at configure time + replProgramArgs = mempty, --unused, set at configure time + replVerbosity = toFlag verbosity, + replDistPref = toFlag builddir, + replReload = mempty, --only used as callback from repl + replReplOptions = pkgConfigReplOptions sharedConfig --runtime override for repl flags + } + + +setupHsReplArgs :: ElaboratedConfiguredPackage -> [String] +setupHsReplArgs elab = + maybe [] (\t -> [showComponentTarget (packageId elab) t]) (elabReplTarget elab) + --TODO: should be able to give multiple modules in one component + + +setupHsCopyFlags :: ElaboratedConfiguredPackage + -> ElaboratedSharedConfig + -> Verbosity + -> FilePath + -> FilePath + -> Cabal.CopyFlags +setupHsCopyFlags _ _ verbosity builddir destdir = + Cabal.CopyFlags { + copyArgs = [], -- TODO: could use this to only copy what we enabled + copyDest = toFlag (InstallDirs.CopyTo destdir), + copyDistPref = toFlag builddir, + copyVerbosity = toFlag verbosity, + copyCabalFilePath = mempty + } + +setupHsRegisterFlags :: ElaboratedConfiguredPackage + -> ElaboratedSharedConfig + -> Verbosity + -> FilePath + -> FilePath + -> Cabal.RegisterFlags +setupHsRegisterFlags ElaboratedConfiguredPackage{..} _ + verbosity builddir pkgConfFile = + Cabal.RegisterFlags { + regPackageDB = mempty, -- misfeature + regGenScript = mempty, -- never use + regGenPkgConf = toFlag (Just pkgConfFile), + regInPlace = case elabBuildStyle of + BuildInplaceOnly -> toFlag True + _ -> toFlag False, + regPrintId = mempty, -- never use + regDistPref = toFlag builddir, + regArgs = [], + regVerbosity = toFlag verbosity, + regCabalFilePath = mempty + } + +setupHsHaddockFlags :: ElaboratedConfiguredPackage + -> ElaboratedSharedConfig + -> Verbosity + -> FilePath + -> Cabal.HaddockFlags +setupHsHaddockFlags (ElaboratedConfiguredPackage{..}) _ verbosity builddir = + Cabal.HaddockFlags { + haddockProgramPaths = mempty, --unused, set at configure time + haddockProgramArgs = mempty, --unused, set at configure time + haddockHoogle = toFlag elabHaddockHoogle, + haddockHtml = toFlag elabHaddockHtml, + haddockHtmlLocation = maybe mempty toFlag elabHaddockHtmlLocation, + haddockForHackage = toFlag elabHaddockForHackage, + haddockForeignLibs = toFlag elabHaddockForeignLibs, + haddockExecutables = toFlag elabHaddockExecutables, + haddockTestSuites = toFlag elabHaddockTestSuites, + haddockBenchmarks = toFlag elabHaddockBenchmarks, + haddockInternal = toFlag elabHaddockInternal, + haddockCss = maybe mempty toFlag elabHaddockCss, + haddockLinkedSource = toFlag elabHaddockLinkedSource, + haddockQuickJump = toFlag elabHaddockQuickJump, + haddockHscolourCss = maybe mempty toFlag elabHaddockHscolourCss, + haddockContents = maybe mempty toFlag elabHaddockContents, + haddockDistPref = toFlag builddir, + haddockKeepTempFiles = mempty, --TODO: from build settings + haddockVerbosity = toFlag verbosity, + haddockCabalFilePath = mempty, + haddockArgs = mempty + } + +setupHsHaddockArgs :: ElaboratedConfiguredPackage -> [String] +-- TODO: Does the issue #3335 affects test as well +setupHsHaddockArgs elab = + map (showComponentTarget (packageId elab)) (elabHaddockTargets elab) + +{- +setupHsTestFlags :: ElaboratedConfiguredPackage + -> ElaboratedSharedConfig + -> Verbosity + -> FilePath + -> Cabal.TestFlags +setupHsTestFlags _ _ verbosity builddir = + Cabal.TestFlags { + } +-} + +------------------------------------------------------------------------------ +-- * Sharing installed packages +------------------------------------------------------------------------------ + +-- +-- Nix style store management for tarball packages +-- +-- So here's our strategy: +-- +-- We use a per-user nix-style hashed store, but /only/ for tarball packages. +-- So that includes packages from hackage repos (and other http and local +-- tarballs). For packages in local directories we do not register them into +-- the shared store by default, we just build them locally inplace. +-- +-- The reason we do it like this is that it's easy to make stable hashes for +-- tarball packages, and these packages benefit most from sharing. By contrast +-- unpacked dir packages are harder to hash and they tend to change more +-- frequently so there's less benefit to sharing them. +-- +-- When using the nix store approach we have to run the solver *without* +-- looking at the packages installed in the store, just at the source packages +-- (plus core\/global installed packages). Then we do a post-processing pass +-- to replace configured packages in the plan with pre-existing ones, where +-- possible. Where possible of course means where the nix-style package hash +-- equals one that's already in the store. +-- +-- One extra wrinkle is that unless we know package tarball hashes upfront, we +-- will have to download the tarballs to find their hashes. So we have two +-- options: delay replacing source with pre-existing installed packages until +-- the point during the execution of the install plan where we have the +-- tarball, or try to do as much up-front as possible and then check again +-- during plan execution. The former isn't great because we would end up +-- telling users we're going to re-install loads of packages when in fact we +-- would just share them. It'd be better to give as accurate a prediction as +-- we can. The latter is better for users, but we do still have to check +-- during plan execution because it's important that we don't replace existing +-- installed packages even if they have the same package hash, because we +-- don't guarantee ABI stability. + +-- TODO: [required eventually] for safety of concurrent installs, we must make sure we register but +-- not replace installed packages with ghc-pkg. + +packageHashInputs :: ElaboratedSharedConfig + -> ElaboratedConfiguredPackage + -> PackageHashInputs +packageHashInputs + pkgshared + elab@(ElaboratedConfiguredPackage { + elabPkgSourceHash = Just srchash + }) = + PackageHashInputs { + pkgHashPkgId = packageId elab, + pkgHashComponent = + case elabPkgOrComp elab of + ElabPackage _ -> Nothing + ElabComponent comp -> Just (compSolverName comp), + 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 (compLibDependencies comp + ++ compExeDependencies comp)), + pkgHashOtherConfig = packageHashConfigInputs pkgshared elab + } + where + -- Obviously the main deps are relevant + relevantDeps CD.ComponentLib = True + relevantDeps (CD.ComponentSubLib _) = True + relevantDeps (CD.ComponentFLib _) = True + relevantDeps (CD.ComponentExe _) = True + -- Setup deps can affect the Setup.hs behaviour and thus what is built + relevantDeps CD.ComponentSetup = True + -- However testsuites and benchmarks do not get installed and should not + -- affect the result, so we do not include them. + relevantDeps (CD.ComponentTest _) = False + relevantDeps (CD.ComponentBench _) = False + +packageHashInputs _ pkg = + error $ "packageHashInputs: only for packages with source hashes. " + ++ prettyShow (packageId pkg) + +packageHashConfigInputs :: ElaboratedSharedConfig + -> ElaboratedConfiguredPackage + -> PackageHashConfigInputs +packageHashConfigInputs shared@ElaboratedSharedConfig{..} pkg = + PackageHashConfigInputs { + pkgHashCompilerId = compilerId pkgConfigCompiler, + pkgHashPlatform = pkgConfigPlatform, + pkgHashFlagAssignment = elabFlagAssignment, + pkgHashConfigureScriptArgs = elabConfigureScriptArgs, + pkgHashVanillaLib = elabVanillaLib, + pkgHashSharedLib = elabSharedLib, + pkgHashDynExe = elabDynExe, + pkgHashFullyStaticExe = elabFullyStaticExe, + pkgHashGHCiLib = elabGHCiLib, + pkgHashProfLib = elabProfLib, + pkgHashProfExe = elabProfExe, + pkgHashProfLibDetail = elabProfLibDetail, + pkgHashProfExeDetail = elabProfExeDetail, + pkgHashCoverage = elabCoverage, + pkgHashOptimization = elabOptimization, + pkgHashSplitSections = elabSplitSections, + pkgHashSplitObjs = elabSplitObjs, + pkgHashStripLibs = elabStripLibs, + pkgHashStripExes = elabStripExes, + pkgHashDebugInfo = elabDebugInfo, + pkgHashProgramArgs = elabProgramArgs, + pkgHashExtraLibDirs = elabExtraLibDirs, + pkgHashExtraFrameworkDirs = elabExtraFrameworkDirs, + pkgHashExtraIncludeDirs = elabExtraIncludeDirs, + pkgHashProgPrefix = elabProgPrefix, + pkgHashProgSuffix = elabProgSuffix, + pkgHashPackageDbs = elabPackageDbs, + + pkgHashDocumentation = elabBuildHaddocks, + pkgHashHaddockHoogle = elabHaddockHoogle, + pkgHashHaddockHtml = elabHaddockHtml, + pkgHashHaddockHtmlLocation = elabHaddockHtmlLocation, + pkgHashHaddockForeignLibs = elabHaddockForeignLibs, + pkgHashHaddockExecutables = elabHaddockExecutables, + pkgHashHaddockTestSuites = elabHaddockTestSuites, + pkgHashHaddockBenchmarks = elabHaddockBenchmarks, + pkgHashHaddockInternal = elabHaddockInternal, + pkgHashHaddockCss = elabHaddockCss, + pkgHashHaddockLinkedSource = elabHaddockLinkedSource, + pkgHashHaddockQuickJump = elabHaddockQuickJump, + pkgHashHaddockContents = elabHaddockContents + } + where + ElaboratedConfiguredPackage{..} = normaliseConfiguredPackage shared pkg + +-- | 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 + + --TODO: decide what to do if we encounter broken installed packages, + -- since overwriting is never safe. + + +-- Path construction +------ + +-- | The path to the directory that contains a specific executable. +-- NB: For inplace NOT InstallPaths.bindir installDirs; for an +-- inplace build those values are utter nonsense. So we +-- have to guess where the directory is going to be. +-- Fortunately this is "stable" part of Cabal API. +-- But the way we get the build directory is A HORRIBLE +-- HACK. +binDirectoryFor + :: DistDirLayout + -> ElaboratedSharedConfig + -> ElaboratedConfiguredPackage + -> FilePath + -> FilePath +binDirectoryFor layout config package exe = case elabBuildStyle package of + BuildAndInstall -> installedBinDirectory package + BuildInplaceOnly -> inplaceBinRoot layout config package exe + +-- package has been built and installed. +installedBinDirectory :: ElaboratedConfiguredPackage -> FilePath +installedBinDirectory = InstallDirs.bindir . elabInstallDirs + +-- | The path to the @build@ directory for an inplace build. +inplaceBinRoot + :: DistDirLayout + -> ElaboratedSharedConfig + -> ElaboratedConfiguredPackage + -> FilePath +inplaceBinRoot layout config package + = distBuildDirectory layout (elabDistDirParams config package) + "build" diff --git a/cabal/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs b/cabal/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs @@ -0,0 +1,855 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Types used while planning how to build everything in a project. +-- +-- Primarily this is the 'ElaboratedInstallPlan'. +-- +module Distribution.Client.ProjectPlanning.Types ( + SolverInstallPlan, + + -- * Elaborated install plan types + ElaboratedInstallPlan, + normaliseConfiguredPackage, + ElaboratedConfiguredPackage(..), + + elabDistDirParams, + elabExeDependencyPaths, + elabLibDependencies, + elabOrderLibDependencies, + elabExeDependencies, + elabOrderExeDependencies, + elabSetupDependencies, + elabPkgConfigDependencies, + elabInplaceDependencyBuildCacheFiles, + elabRequiresRegistration, + dataDirsEnvironmentForPlan, + + elabPlanPackageName, + elabConfiguredName, + elabComponentName, + + ElaboratedPackageOrComponent(..), + ElaboratedComponent(..), + ElaboratedPackage(..), + pkgOrderDependencies, + ElaboratedPlanPackage, + ElaboratedSharedConfig(..), + ElaboratedReadyPackage, + BuildStyle(..), + CabalFileText, + + -- * Build targets + ComponentTarget(..), + showComponentTarget, + showTestComponentTarget, + showBenchComponentTarget, + SubComponentTarget(..), + + isSubLibComponentTarget, + isForeignLibComponentTarget, + isExeComponentTarget, + isTestComponentTarget, + isBenchComponentTarget, + + componentOptionalStanza, + + -- * Setup script + SetupScriptStyle(..), + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Client.TargetSelector + ( SubComponentTarget(..) ) +import Distribution.Client.PackageHash + +import Distribution.Client.Types +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.InstallPlan + ( GenericInstallPlan, GenericPlanPackage(..) ) +import Distribution.Client.SolverInstallPlan + ( SolverInstallPlan ) +import Distribution.Client.DistDirLayout + +import Distribution.Backpack +import Distribution.Backpack.ModuleShape + +import Distribution.Verbosity (normal) +import Distribution.Types.ComponentRequestedSpec +import Distribution.Types.PkgconfigVersion +import Distribution.Types.PackageDescription (PackageDescription(..)) +import Distribution.Package +import Distribution.System +import qualified Distribution.PackageDescription as Cabal +import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import Distribution.Simple.Compiler +import Distribution.Simple.Build.PathsModule (pkgPathEnvVar) +import qualified Distribution.Simple.BuildTarget as Cabal +import Distribution.Simple.Program +import Distribution.ModuleName (ModuleName) +import Distribution.Simple.LocalBuildInfo + ( ComponentName(..), LibraryName(..) ) +import qualified Distribution.Simple.InstallDirs as InstallDirs +import Distribution.Simple.InstallDirs (PathTemplate) +import Distribution.Simple.Setup + ( HaddockTarget, TestShowDetails, DumpBuildInfo (..), ReplOptions ) +import Distribution.Version + +import qualified Distribution.Solver.Types.ComponentDeps as CD +import Distribution.Solver.Types.ComponentDeps (ComponentDeps) +import Distribution.Solver.Types.OptionalStanza +import Distribution.Compat.Graph (IsNode(..)) +import Distribution.Simple.Utils (ordNub) + +import qualified Data.Map as Map +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Monoid as Mon +import System.FilePath (()) + + +-- | The combination of an elaborated install plan plus a +-- 'ElaboratedSharedConfig' contains all the details necessary to be able +-- to execute the plan without having to make further policy decisions. +-- +-- It does not include dynamic elements such as resources (such as http +-- connections). +-- +type ElaboratedInstallPlan + = GenericInstallPlan InstalledPackageInfo + ElaboratedConfiguredPackage + +type ElaboratedPlanPackage + = GenericPlanPackage InstalledPackageInfo + ElaboratedConfiguredPackage + +-- | User-friendly display string for an 'ElaboratedPlanPackage'. +elabPlanPackageName :: Verbosity -> ElaboratedPlanPackage -> String +elabPlanPackageName verbosity (PreExisting ipkg) + | verbosity <= normal = prettyShow (packageName ipkg) + | otherwise = prettyShow (installedUnitId ipkg) +elabPlanPackageName verbosity (Configured elab) + = elabConfiguredName verbosity elab +elabPlanPackageName verbosity (Installed elab) + = elabConfiguredName verbosity elab + +--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 + -- | The programs that the compiler configured (e.g. for GHC, the progs + -- ghc & ghc-pkg). Once constructed, only the 'configuredPrograms' are + -- used. + pkgConfigCompilerProgs :: ProgramDb, + pkgConfigReplOptions :: ReplOptions + } + deriving (Show, Generic, Typeable) + --TODO: [code cleanup] no Eq instance + +instance Binary ElaboratedSharedConfig +instance Structured ElaboratedSharedConfig + +data ElaboratedConfiguredPackage + = ElaboratedConfiguredPackage { + -- | The 'UnitId' which uniquely identifies this item in a build plan + elabUnitId :: UnitId, + + elabComponentId :: ComponentId, + elabInstantiatedWith :: Map ModuleName Module, + elabLinkedInstantiatedWith :: Map ModuleName OpenModule, + + -- | This is true if this is an indefinite package, or this is a + -- package with no signatures. (Notably, it's not true for instantiated + -- packages.) The motivation for this is if you ask to build + -- @foo-indef@, this probably means that you want to typecheck + -- it, NOT that you want to rebuild all of the various + -- instantiations of it. + elabIsCanonical :: Bool, + + -- | The 'PackageId' of the originating package + elabPkgSourceId :: PackageId, + + -- | Shape of the package/component, for Backpack. + elabModuleShape :: ModuleShape, + + -- | A total flag assignment for the package. + -- TODO: Actually this can be per-component if we drop + -- all flags that don't affect a component. + elabFlagAssignment :: Cabal.FlagAssignment, + + -- | The original default flag assignment, used only for reporting. + elabFlagDefaults :: Cabal.FlagAssignment, + + elabPkgDescription :: Cabal.PackageDescription, + + -- | 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. + elabPkgSourceLocation :: PackageLocation (Maybe FilePath), + + -- | The hash of the source, e.g. the tarball. We don't have this for + -- local source dir packages. + elabPkgSourceHash :: Maybe PackageSourceHash, + + -- | Is this package one of the ones specified by location in the + -- project file? (As opposed to a dependency, or a named package pulled + -- in) + elabLocalToProject :: Bool, + + -- | Are we going to build and install this package to the store, or are + -- we going to build it and register it locally. + elabBuildStyle :: BuildStyle, + + -- | Another way of phrasing 'pkgStanzasAvailable'. + elabEnabledSpec :: ComponentRequestedSpec, + + -- | Which optional stanzas (ie testsuites, benchmarks) can be built. + -- This means the solver produced a plan that has them available. + -- This doesn't necessary mean we build them by default. + elabStanzasAvailable :: OptionalStanzaSet, + + -- | Which optional stanzas the user explicitly asked to enable or + -- 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.) + elabStanzasRequested :: OptionalStanzaMap (Maybe Bool), + + elabPackageDbs :: [Maybe PackageDB], + elabSetupPackageDBStack :: PackageDBStack, + elabBuildPackageDBStack :: PackageDBStack, + elabRegisterPackageDBStack :: PackageDBStack, + + elabInplaceSetupPackageDBStack :: PackageDBStack, + elabInplaceBuildPackageDBStack :: PackageDBStack, + elabInplaceRegisterPackageDBStack :: PackageDBStack, + + elabPkgDescriptionOverride :: Maybe CabalFileText, + + -- TODO: make per-component variants of these flags + elabVanillaLib :: Bool, + elabSharedLib :: Bool, + elabStaticLib :: Bool, + elabDynExe :: Bool, + elabFullyStaticExe :: Bool, + elabGHCiLib :: Bool, + elabProfLib :: Bool, + elabProfExe :: Bool, + elabProfLibDetail :: ProfDetailLevel, + elabProfExeDetail :: ProfDetailLevel, + elabCoverage :: Bool, + elabOptimization :: OptimisationLevel, + elabSplitObjs :: Bool, + elabSplitSections :: Bool, + elabStripLibs :: Bool, + elabStripExes :: Bool, + elabDebugInfo :: DebugInfoLevel, + elabDumpBuildInfo :: DumpBuildInfo, + + elabProgramPaths :: Map String FilePath, + elabProgramArgs :: Map String [String], + elabProgramPathExtra :: [FilePath], + elabConfigureScriptArgs :: [String], + elabExtraLibDirs :: [FilePath], + elabExtraLibDirsStatic :: [FilePath], + elabExtraFrameworkDirs :: [FilePath], + elabExtraIncludeDirs :: [FilePath], + elabProgPrefix :: Maybe PathTemplate, + elabProgSuffix :: Maybe PathTemplate, + + elabInstallDirs :: InstallDirs.InstallDirs FilePath, + + elabHaddockHoogle :: Bool, + elabHaddockHtml :: Bool, + elabHaddockHtmlLocation :: Maybe String, + elabHaddockForeignLibs :: Bool, + elabHaddockForHackage :: HaddockTarget, + elabHaddockExecutables :: Bool, + elabHaddockTestSuites :: Bool, + elabHaddockBenchmarks :: Bool, + elabHaddockInternal :: Bool, + elabHaddockCss :: Maybe FilePath, + elabHaddockLinkedSource :: Bool, + elabHaddockQuickJump :: Bool, + elabHaddockHscolourCss :: Maybe FilePath, + elabHaddockContents :: Maybe PathTemplate, + + elabTestMachineLog :: Maybe PathTemplate, + elabTestHumanLog :: Maybe PathTemplate, + elabTestShowDetails :: Maybe TestShowDetails, + elabTestKeepTix :: Bool, + elabTestWrapper :: Maybe FilePath, + elabTestFailWhenNoTestSuites :: Bool, + elabTestTestOptions :: [PathTemplate], + + elabBenchmarkOptions :: [PathTemplate], + + -- Setup.hs related things: + + -- | One of four modes for how we build and interact with the Setup.hs + -- script, based on whether it's a build-type Custom, with or without + -- explicit deps and the cabal spec version the .cabal file needs. + elabSetupScriptStyle :: SetupScriptStyle, + + -- | The version of the Cabal command line interface that we are using + -- for this package. This is typically the version of the Cabal lib + -- that the Setup.hs is built against. + -- + -- TODO: We might want to turn this into a enum, + -- yet different enum than 'CabalSpecVersion'. + elabSetupScriptCliVersion :: Version, + + -- Build time related: + elabConfigureTargets :: [ComponentTarget], + elabBuildTargets :: [ComponentTarget], + elabTestTargets :: [ComponentTarget], + elabBenchTargets :: [ComponentTarget], + elabReplTarget :: Maybe ComponentTarget, + elabHaddockTargets :: [ComponentTarget], + + elabBuildHaddocks :: Bool, + + --pkgSourceDir ? -- currently passed in later because they can use temp locations + --pkgBuildDir ? -- but could in principle still have it here, with optional instr to use temp loc + + -- | Component/package specific information + elabPkgOrComp :: ElaboratedPackageOrComponent + } + deriving (Eq, Show, Generic, Typeable) + +normaliseConfiguredPackage :: ElaboratedSharedConfig + -> ElaboratedConfiguredPackage + -> ElaboratedConfiguredPackage +normaliseConfiguredPackage ElaboratedSharedConfig{pkgConfigCompilerProgs} pkg = + pkg { elabProgramArgs = Map.mapMaybeWithKey lookupFilter (elabProgramArgs pkg) } + where + knownProgramDb = addKnownPrograms builtinPrograms pkgConfigCompilerProgs + + pkgDesc :: PackageDescription + pkgDesc = elabPkgDescription pkg + + removeEmpty :: [String] -> Maybe [String] + removeEmpty [] = Nothing + removeEmpty xs = Just xs + + lookupFilter :: String -> [String] -> Maybe [String] + lookupFilter n args = removeEmpty $ case lookupKnownProgram n knownProgramDb of + Just p -> programNormaliseArgs p (getVersion p) pkgDesc args + Nothing -> args + + getVersion :: Program -> Maybe Version + getVersion p = lookupProgram p knownProgramDb >>= programVersion + +-- | The package/component contains/is a library and so must be registered +elabRequiresRegistration :: ElaboratedConfiguredPackage -> Bool +elabRequiresRegistration elab = + case elabPkgOrComp elab of + ElabComponent comp -> + case compComponentName comp of + Just cn -> is_lib cn && build_target + _ -> False + ElabPackage pkg -> + -- Tricky! Not only do we have to test if the user selected + -- a library as a build target, we also have to test if + -- the library was TRANSITIVELY depended upon, since we will + -- also require a register in this case. + -- + -- NB: It would have been far nicer to just unconditionally + -- register in all cases, but some Custom Setups will fall + -- over if you try to do that, ESPECIALLY if there actually is + -- a library but they hadn't built it. + -- + -- However, as the case of `cpphs-1.20.8` has shown in + -- #5379, in cases when a monolithic package gets + -- installed due to its executable components + -- (i.e. exe:cpphs) into the store we *have* to register + -- if there's a buildable public library (i.e. lib:cpphs) + -- that was built and installed into the same store folder + -- as otherwise this will cause build failures once a + -- target actually depends on lib:cpphs. + build_target || (elabBuildStyle elab == BuildAndInstall && + Cabal.hasPublicLib (elabPkgDescription elab)) + -- the next sub-condition below is currently redundant + -- (see discussion in #5604 for more details), but it's + -- being kept intentionally here as a safeguard because if + -- internal libraries ever start working with + -- non-per-component builds this condition won't be + -- redundant anymore. + || any (depends_on_lib pkg) (elabBuildTargets elab) + where + depends_on_lib pkg (ComponentTarget cn _) = + not (null (CD.select (== CD.componentNameToComponent cn) + (pkgDependsOnSelfLib pkg))) + build_target = + if not (null (elabBuildTargets elab)) + then any is_lib_target (elabBuildTargets elab) + -- Empty build targets mean we build /everything/; + -- that means we have to look more carefully to see + -- if there is anything to register + else Cabal.hasLibs (elabPkgDescription elab) + -- NB: this means we DO NOT reregister if you just built a + -- single file + is_lib_target (ComponentTarget cn WholeComponent) = is_lib cn + is_lib_target _ = False + is_lib (CLibName _) = True + is_lib _ = False + +-- | Construct the environment needed for the data files to work. +-- This consists of a separate @*_datadir@ variable for each +-- inplace package in the plan. +dataDirsEnvironmentForPlan :: DistDirLayout + -> ElaboratedInstallPlan + -> [(String, Maybe FilePath)] +dataDirsEnvironmentForPlan distDirLayout = catMaybes + . fmap (InstallPlan.foldPlanPackage + (const Nothing) + (dataDirEnvVarForPackage distDirLayout)) + . InstallPlan.toList + +-- | Construct an environment variable that points +-- the package's datadir to its correct location. +-- This might be: +-- * 'Just' the package's source directory plus the data subdirectory +-- for inplace packages. +-- * 'Nothing' for packages installed in the store (the path was +-- already included in the package at install/build time). +dataDirEnvVarForPackage :: DistDirLayout + -> ElaboratedConfiguredPackage + -> Maybe (String, Maybe FilePath) +dataDirEnvVarForPackage distDirLayout pkg = + case elabBuildStyle pkg + of BuildAndInstall -> Nothing + BuildInplaceOnly -> Just + ( pkgPathEnvVar (elabPkgDescription pkg) "datadir" + , Just $ srcPath (elabPkgSourceLocation pkg) + dataDir (elabPkgDescription pkg)) + where + srcPath (LocalUnpackedPackage path) = path + srcPath (LocalTarballPackage _path) = unpackedPath + srcPath (RemoteTarballPackage _uri _localTar) = unpackedPath + srcPath (RepoTarballPackage _repo _packageId _localTar) = unpackedPath + srcPath (RemoteSourceRepoPackage _sourceRepo (Just localCheckout)) = localCheckout + -- TODO: see https://github.com/haskell/cabal/wiki/Potential-Refactors#unresolvedpkgloc + srcPath (RemoteSourceRepoPackage _sourceRepo Nothing) = error + "calling dataDirEnvVarForPackage on a not-downloaded repo is an error" + unpackedPath = + distUnpackedSrcDirectory distDirLayout $ elabPkgSourceId pkg + +instance Package ElaboratedConfiguredPackage where + packageId = elabPkgSourceId + +instance HasConfiguredId ElaboratedConfiguredPackage where + configuredId elab = + ConfiguredId (packageId elab) (elabComponentName elab) (elabComponentId elab) + +instance HasUnitId ElaboratedConfiguredPackage where + installedUnitId = elabUnitId + +instance IsNode ElaboratedConfiguredPackage where + type Key ElaboratedConfiguredPackage = UnitId + nodeKey = elabUnitId + nodeNeighbors = elabOrderDependencies + +instance Binary ElaboratedConfiguredPackage +instance Structured ElaboratedConfiguredPackage + +data ElaboratedPackageOrComponent + = ElabPackage ElaboratedPackage + | ElabComponent ElaboratedComponent + deriving (Eq, Show, Generic) + +instance Binary ElaboratedPackageOrComponent +instance Structured ElaboratedPackageOrComponent + +elabComponentName :: ElaboratedConfiguredPackage -> Maybe ComponentName +elabComponentName elab = + case elabPkgOrComp elab of + ElabPackage _ -> Just $ CLibName LMainLibName -- there could be more, but default this + ElabComponent comp -> compComponentName comp + +-- | A user-friendly descriptor for an 'ElaboratedConfiguredPackage'. +elabConfiguredName :: Verbosity -> ElaboratedConfiguredPackage -> String +elabConfiguredName verbosity elab + | verbosity <= normal + = (case elabPkgOrComp elab of + ElabPackage _ -> "" + ElabComponent comp -> + case compComponentName comp of + Nothing -> "setup from " + Just (CLibName LMainLibName) -> "" + Just cname -> prettyShow cname ++ " from ") + ++ prettyShow (packageId elab) + | otherwise + = prettyShow (elabUnitId elab) + +elabDistDirParams :: ElaboratedSharedConfig -> ElaboratedConfiguredPackage -> DistDirParams +elabDistDirParams shared elab = DistDirParams { + 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, + distParamOptimization = elabOptimization elab + } + +-- | The full set of dependencies which dictate what order we +-- need to build things in the install plan: "order dependencies" +-- balls everything together. This is mostly only useful for +-- ordering; if you are, for example, trying to compute what +-- @--dependency@ flags to pass to a Setup script, you need to +-- use 'elabLibDependencies'. This method is the same as +-- 'nodeNeighbors'. +-- +-- NB: this method DOES include setup deps. +elabOrderDependencies :: ElaboratedConfiguredPackage -> [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 = + case elabPkgOrComp elab of + ElabPackage pkg -> map (newSimpleUnitId . confInstId) $ + ordNub $ CD.flatDeps (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@. +elabLibDependencies :: ElaboratedConfiguredPackage -> [ConfiguredId] +elabLibDependencies elab = + case elabPkgOrComp elab of + ElabPackage pkg -> ordNub (CD.nonSetupDeps (pkgLibDependencies pkg)) + ElabComponent comp -> compLibDependencies comp + +-- | Like 'elabOrderDependencies', but only returns dependencies on +-- executables. (This coincides with 'elabExeDependencies'.) +elabOrderExeDependencies :: ElaboratedConfiguredPackage -> [UnitId] +elabOrderExeDependencies = + map newSimpleUnitId . elabExeDependencies + +-- | 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 + +-- | This returns the paths of all the executables we depend on; we +-- must add these paths to PATH before invoking the setup script. +-- (This is usually what you want, not 'elabExeDependencies', if you +-- actually want to build something.) +elabExeDependencyPaths :: ElaboratedConfiguredPackage -> [FilePath] +elabExeDependencyPaths elab = + case elabPkgOrComp elab of + ElabPackage pkg -> 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] +elabSetupDependencies 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 + ElabComponent _ -> [] + +elabPkgConfigDependencies :: ElaboratedConfiguredPackage -> [(PkgconfigName, Maybe PkgconfigVersion)] +elabPkgConfigDependencies ElaboratedConfiguredPackage { elabPkgOrComp = ElabPackage pkg } + = pkgPkgConfigDependencies pkg +elabPkgConfigDependencies ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent comp } + = compPkgConfigDependencies comp + +-- | The cache files of all our inplace dependencies which, +-- when updated, require us to rebuild. See #4202 for +-- more details. Essentially, this is a list of filepaths +-- that, if our dependencies get rebuilt, will themselves +-- get updated. +-- +-- Note: the hash of these cache files gets built into +-- the build cache ourselves, which means that we end +-- up tracking transitive dependencies! +-- +-- Note: This tracks the "build" cache file, but not +-- "registration" or "config" cache files. Why not? +-- Arguably we should... +-- +-- Note: This is a bit of a hack, because it is not really +-- the hashes of the SOURCES of our (transitive) dependencies +-- that we should use to decide whether or not to rebuild, +-- but the output BUILD PRODUCTS. The strategy we use +-- here will never work if we want to implement unchanging +-- rebuilds. +elabInplaceDependencyBuildCacheFiles + :: DistDirLayout + -> ElaboratedSharedConfig + -> ElaboratedInstallPlan + -> ElaboratedConfiguredPackage + -> [FilePath] +elabInplaceDependencyBuildCacheFiles layout sconf plan root_elab = + go =<< InstallPlan.directDeps plan (nodeKey root_elab) + where + go = InstallPlan.foldPlanPackage (const []) $ \elab -> do + guard (elabBuildStyle elab == BuildInplaceOnly) + return $ distPackageCacheFile layout (elabDistDirParams sconf elab) "build" + +-- | Some extra metadata associated with an +-- 'ElaboratedConfiguredPackage' which indicates that the "package" +-- in question is actually a single component to be built. Arguably +-- it would be clearer if there were an ADT which branched into +-- package work items and component work items, but I've structured +-- it this way to minimize change to the existing code (which I +-- don't feel qualified to rewrite.) +data ElaboratedComponent + = ElaboratedComponent { + -- | The name of the component to be built according to the solver + compSolverName :: CD.Component, + -- | The name of the component to be built. Nothing if + -- it's a setup dep. + compComponentName :: Maybe ComponentName, + -- | The *external* library dependencies of this component. We + -- pass this to the configure script. + compLibDependencies :: [ConfiguredId], + -- | In a component prior to instantiation, this list specifies + -- the 'OpenUnitId's which, after instantiation, are the + -- actual dependencies of this package. Note that this does + -- NOT include signature packages, which do not turn into real + -- ordering dependencies when we instantiate. This is intended to be + -- a purely temporary field, to carry some information to the + -- instantiation phase. It's more precise than + -- 'compLibDependencies', and also stores information about internal + -- dependencies. + compLinkedLibDependencies :: [OpenUnitId], + -- | The executable dependencies of this component (including + -- internal executables). + compExeDependencies :: [ConfiguredId], + -- | The @pkg-config@ dependencies of the component + compPkgConfigDependencies :: [(PkgconfigName, Maybe PkgconfigVersion)], + -- | The paths all our executable dependencies will be installed + -- to once they are installed. + compExeDependencyPaths :: [(ConfiguredId, FilePath)], + -- | 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 + -- references to definite and indefinite packages; an indefinite + -- UnitId indicates that we must typecheck that indefinite package + -- before we can build this one. + compOrderLibDependencies :: [UnitId] + } + deriving (Eq, Show, Generic) + +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, + + -- | The exact dependencies (on other plan packages) + -- + pkgLibDependencies :: ComponentDeps [ConfiguredId], + + -- | Components which depend (transitively) on an internally + -- defined library. These are used by 'elabRequiresRegistration', + -- to determine if a user-requested build is going to need + -- a library registration + -- + pkgDependsOnSelfLib :: ComponentDeps [()], + + -- | Dependencies on executable packages. + -- + pkgExeDependencies :: ComponentDeps [ConfiguredId], + + -- | Paths where executable dependencies live. + -- + pkgExeDependencyPaths :: ComponentDeps [(ConfiguredId, FilePath)], + + -- | Dependencies on @pkg-config@ packages. + -- NB: this is NOT per-component (although it could be) + -- because Cabal library does not track per-component + -- pkg-config depends; it always does them all at once. + -- + pkgPkgConfigDependencies :: [(PkgconfigName, Maybe PkgconfigVersion)], + + -- | Which optional stanzas (ie testsuites, benchmarks) will actually + -- be enabled during the package configure step. + pkgStanzasEnabled :: OptionalStanzaSet + } + deriving (Eq, Show, Generic) + +instance Binary ElaboratedPackage +instance Structured ElaboratedPackage + +-- | See 'elabOrderDependencies'. This gives the unflattened version, +-- which can be useful in some circumstances. +pkgOrderDependencies :: ElaboratedPackage -> ComponentDeps [UnitId] +pkgOrderDependencies pkg = + fmap (map (newSimpleUnitId . confInstId)) (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 = + -- | The classic approach where the package is built, then the files + -- installed into some location and the result registered in a package db. + -- + -- If the package came from a tarball then it's built in a temp dir and + -- the results discarded. + BuildAndInstall + + -- | The package is built, but the files are not installed anywhere, + -- rather the build dir is kept and the package is registered inplace. + -- + -- Such packages can still subsequently be installed. + -- + -- Typically 'BuildAndInstall' packages will only depend on other + -- 'BuildAndInstall' style packages and not on 'BuildInplaceOnly' ones. + -- + | BuildInplaceOnly + deriving (Eq, Show, Generic) + +instance Binary BuildStyle +instance Structured BuildStyle +instance Semigroup BuildStyle where + BuildInplaceOnly <> _ = BuildInplaceOnly + _ <> BuildInplaceOnly = BuildInplaceOnly + _ <> _ = BuildAndInstall +instance Monoid BuildStyle where + mempty = BuildAndInstall + mappend = (<>) + +type CabalFileText = LBS.ByteString + +type ElaboratedReadyPackage = GenericReadyPackage ElaboratedConfiguredPackage + + +--------------------------- +-- Build targets +-- + +-- | Specific targets within a package or component to act on e.g. to build, +-- haddock or open a repl. +-- +data ComponentTarget = ComponentTarget ComponentName SubComponentTarget + deriving (Eq, Ord, Show, Generic) + +instance Binary ComponentTarget +instance Structured ComponentTarget + +-- | Unambiguously render a 'ComponentTarget', e.g., to pass +-- to a Cabal Setup script. +showComponentTarget :: PackageId -> ComponentTarget -> String +showComponentTarget pkgid = + Cabal.showBuildTarget pkgid . toBuildTarget + where + toBuildTarget :: ComponentTarget -> Cabal.BuildTarget + toBuildTarget (ComponentTarget cname subtarget) = + case subtarget of + WholeComponent -> Cabal.BuildTargetComponent cname + ModuleTarget mname -> Cabal.BuildTargetModule cname mname + FileTarget fname -> Cabal.BuildTargetFile cname fname + +showTestComponentTarget :: PackageId -> ComponentTarget -> Maybe String +showTestComponentTarget _ (ComponentTarget (CTestName n) _) = Just $ prettyShow n +showTestComponentTarget _ _ = Nothing + +isTestComponentTarget :: ComponentTarget -> Bool +isTestComponentTarget (ComponentTarget (CTestName _) _) = True +isTestComponentTarget _ = False + +showBenchComponentTarget :: PackageId -> ComponentTarget -> Maybe String +showBenchComponentTarget _ (ComponentTarget (CBenchName n) _) = Just $ prettyShow n +showBenchComponentTarget _ _ = Nothing + +isBenchComponentTarget :: ComponentTarget -> Bool +isBenchComponentTarget (ComponentTarget (CBenchName _) _) = True +isBenchComponentTarget _ = False + +isForeignLibComponentTarget :: ComponentTarget -> Bool +isForeignLibComponentTarget (ComponentTarget (CFLibName _) _) = True +isForeignLibComponentTarget _ = False + +isExeComponentTarget :: ComponentTarget -> Bool +isExeComponentTarget (ComponentTarget (CExeName _) _ ) = True +isExeComponentTarget _ = False + +isSubLibComponentTarget :: ComponentTarget -> Bool +isSubLibComponentTarget (ComponentTarget (CLibName (LSubLibName _)) _) = True +isSubLibComponentTarget _ = False + +componentOptionalStanza :: CD.Component -> Maybe OptionalStanza +componentOptionalStanza (CD.ComponentTest _) = Just TestStanzas +componentOptionalStanza (CD.ComponentBench _) = Just BenchStanzas +componentOptionalStanza _ = Nothing + +--------------------------- +-- Setup.hs script policy +-- + +-- | There are four major cases for Setup.hs handling: +-- +-- 1. @build-type@ Custom with a @custom-setup@ section +-- 2. @build-type@ Custom without a @custom-setup@ section +-- 3. @build-type@ not Custom with @cabal-version > $our-cabal-version@ +-- 4. @build-type@ not Custom with @cabal-version <= $our-cabal-version@ +-- +-- It's also worth noting that packages specifying @cabal-version: >= 1.23@ +-- or later that have @build-type@ Custom will always have a @custom-setup@ +-- section. Therefore in case 2, the specified @cabal-version@ will always be +-- less than 1.23. +-- +-- In cases 1 and 2 we obviously have to build an external Setup.hs script, +-- while in case 4 we can use the internal library API. In case 3 we also have +-- to build an external Setup.hs script because the package needs a later +-- Cabal lib version than we can support internally. +-- +data SetupScriptStyle = SetupCustomExplicitDeps + | SetupCustomImplicitDeps + | SetupNonCustomExternalLib + | SetupNonCustomInternalLib + deriving (Eq, Show, Generic, Typeable) + +instance Binary SetupScriptStyle +instance Structured SetupScriptStyle diff --git a/cabal/cabal-install/src/Distribution/Client/RebuildMonad.hs b/cabal/cabal-install/src/Distribution/Client/RebuildMonad.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/RebuildMonad.hs @@ -0,0 +1,311 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, BangPatterns #-} + +-- | An abstraction for re-running actions if values or files have changed. +-- +-- This is not a full-blown make-style incremental build system, it's a bit +-- more ad-hoc than that, but it's easier to integrate with existing code. +-- +-- It's a convenient interface to the "Distribution.Client.FileMonitor" +-- functions. +-- +module Distribution.Client.RebuildMonad ( + -- * Rebuild monad + Rebuild, + runRebuild, + execRebuild, + askRoot, + + -- * Setting up file monitoring + monitorFiles, + MonitorFilePath, + monitorFile, + monitorFileHashed, + monitorNonExistentFile, + monitorDirectory, + monitorNonExistentDirectory, + monitorDirectoryExistence, + monitorFileOrDirectory, + monitorFileSearchPath, + monitorFileHashedSearchPath, + -- ** Monitoring file globs + monitorFileGlob, + monitorFileGlobExistence, + FilePathGlob(..), + FilePathRoot(..), + FilePathGlobRel(..), + GlobPiece(..), + + -- * Using a file monitor + FileMonitor(..), + newFileMonitor, + rerunIfChanged, + + -- * Utils + delayInitSharedResource, + delayInitSharedResources, + matchFileGlob, + getDirectoryContentsMonitored, + createDirectoryMonitored, + monitorDirectoryStatus, + doesFileExistMonitored, + need, + needIfExists, + findFileWithExtensionMonitored, + findFirstFileMonitored, + findFileMonitored, + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Distribution.Client.FileMonitor +import Distribution.Client.Glob hiding (matchFileGlob) +import qualified Distribution.Client.Glob as Glob (matchFileGlob) + +import Distribution.Simple.Utils (debug) + +import qualified Data.Map.Strict as Map +import Control.Monad.State as State +import Control.Monad.Reader as Reader +import Control.Concurrent.MVar (MVar, newMVar, modifyMVar) +import System.FilePath +import System.Directory + + +-- | A monad layered on top of 'IO' to help with re-running actions when the +-- input files and values they depend on change. The crucial operations are +-- 'rerunIfChanged' and 'monitorFiles'. +-- +newtype Rebuild a = Rebuild (ReaderT FilePath (StateT [MonitorFilePath] IO) a) + deriving (Functor, Applicative, Monad, MonadIO) + +-- | Use this within the body action of 'rerunIfChanged' to declare that the +-- action depends on the given files. This can be based on what the action +-- actually did. It is these files that will be checked for changes next +-- time 'rerunIfChanged' is called for that 'FileMonitor'. +-- +-- Relative paths are interpreted as relative to an implicit root, ultimately +-- passed in to 'runRebuild'. +-- +monitorFiles :: [MonitorFilePath] -> Rebuild () +monitorFiles filespecs = Rebuild (State.modify (filespecs++)) + +-- | Run a 'Rebuild' IO action. +unRebuild :: FilePath -> Rebuild a -> IO (a, [MonitorFilePath]) +unRebuild rootDir (Rebuild action) = runStateT (runReaderT action rootDir) [] + +-- | Run a 'Rebuild' IO action. +runRebuild :: FilePath -> Rebuild a -> IO a +runRebuild rootDir (Rebuild action) = evalStateT (runReaderT action rootDir) [] + +-- | Run a 'Rebuild' IO action. +execRebuild :: FilePath -> Rebuild a -> IO [MonitorFilePath] +execRebuild rootDir (Rebuild action) = execStateT (runReaderT action rootDir) [] + +-- | The root that relative paths are interpreted as being relative to. +askRoot :: Rebuild FilePath +askRoot = Rebuild Reader.ask + +-- | This captures the standard use pattern for a 'FileMonitor': given a +-- monitor, an action and the input value the action depends on, either +-- re-run the action to get its output, or if the value and files the action +-- depends on have not changed then return a previously cached action result. +-- +-- The result is still in the 'Rebuild' monad, so these can be nested. +-- +-- Do not share 'FileMonitor's between different uses of 'rerunIfChanged'. +-- +rerunIfChanged :: (Binary a, Structured a, Binary b, Structured b) + => Verbosity + -> FileMonitor a b + -> a + -> Rebuild b + -> Rebuild b +rerunIfChanged verbosity monitor key action = do + rootDir <- askRoot + changed <- liftIO $ checkFileMonitorChanged monitor rootDir key + case changed of + MonitorUnchanged result files -> do + liftIO $ debug verbosity $ "File monitor '" ++ monitorName + ++ "' unchanged." + monitorFiles files + return result + + MonitorChanged reason -> do + liftIO $ debug verbosity $ "File monitor '" ++ monitorName + ++ "' changed: " ++ showReason reason + startTime <- liftIO $ beginUpdateFileMonitor + (result, files) <- liftIO $ unRebuild rootDir action + liftIO $ updateFileMonitor monitor rootDir + (Just startTime) files key result + monitorFiles files + return result + where + monitorName = takeFileName (fileMonitorCacheFile monitor) + + showReason (MonitoredFileChanged file) = "file " ++ file + showReason (MonitoredValueChanged _) = "monitor value changed" + showReason MonitorFirstRun = "first run" + showReason MonitorCorruptCache = "invalid cache file" + + +-- | When using 'rerunIfChanged' for each element of a list of actions, it is +-- sometimes the case that each action needs to make use of some resource. e.g. +-- +-- > sequence +-- > [ rerunIfChanged verbosity monitor key $ do +-- > resource <- mkResource +-- > ... -- use the resource +-- > | ... ] +-- +-- For efficiency one would like to share the resource between the actions +-- but the straightforward way of doing this means initialising it every time +-- even when no actions need re-running. +-- +-- > resource <- mkResource +-- > sequence +-- > [ rerunIfChanged verbosity monitor key $ do +-- > ... -- use the resource +-- > | ... ] +-- +-- This utility allows one to get the best of both worlds: +-- +-- > getResource <- delayInitSharedResource mkResource +-- > sequence +-- > [ rerunIfChanged verbosity monitor key $ do +-- > resource <- getResource +-- > ... -- use the resource +-- > | ... ] +-- +delayInitSharedResource :: forall a. IO a -> Rebuild (Rebuild a) +delayInitSharedResource action = do + var <- liftIO (newMVar Nothing) + return (liftIO (getOrInitResource var)) + where + getOrInitResource :: MVar (Maybe a) -> IO a + getOrInitResource var = + modifyMVar var $ \mx -> + case mx of + Just x -> return (Just x, x) + Nothing -> do + x <- action + return (Just x, x) + + +-- | Much like 'delayInitSharedResource' but for a keyed set of resources. +-- +-- > getResource <- delayInitSharedResource mkResource +-- > sequence +-- > [ rerunIfChanged verbosity monitor key $ do +-- > resource <- getResource key +-- > ... -- use the resource +-- > | ... ] +-- +delayInitSharedResources :: forall k v. Ord k + => (k -> IO v) + -> Rebuild (k -> Rebuild v) +delayInitSharedResources action = do + var <- liftIO (newMVar Map.empty) + return (liftIO . getOrInitResource var) + where + getOrInitResource :: MVar (Map k v) -> k -> IO v + getOrInitResource var k = + modifyMVar var $ \m -> + case Map.lookup k m of + Just x -> return (m, x) + Nothing -> do + x <- action k + let !m' = Map.insert k x m + return (m', x) + + +-- | Utility to match a file glob against the file system, starting from a +-- given root directory. The results are all relative to the given root. +-- +-- Since this operates in the 'Rebuild' monad, it also monitors the given glob +-- for changes. +-- +matchFileGlob :: FilePathGlob -> Rebuild [FilePath] +matchFileGlob glob = do + root <- askRoot + monitorFiles [monitorFileGlobExistence glob] + liftIO $ Glob.matchFileGlob root glob + +getDirectoryContentsMonitored :: FilePath -> Rebuild [FilePath] +getDirectoryContentsMonitored dir = do + exists <- monitorDirectoryStatus dir + if exists + then liftIO $ getDirectoryContents dir + else return [] + +createDirectoryMonitored :: Bool -> FilePath -> Rebuild () +createDirectoryMonitored createParents dir = do + monitorFiles [monitorDirectoryExistence dir] + liftIO $ createDirectoryIfMissing createParents dir + +-- | Monitor a directory as in 'monitorDirectory' if it currently exists or +-- as 'monitorNonExistentDirectory' if it does not. +monitorDirectoryStatus :: FilePath -> Rebuild Bool +monitorDirectoryStatus dir = do + exists <- liftIO $ doesDirectoryExist dir + monitorFiles [if exists + then monitorDirectory dir + else monitorNonExistentDirectory dir] + return exists + +-- | Like 'doesFileExist', but in the 'Rebuild' monad. This does +-- NOT track the contents of 'FilePath'; use 'need' in that case. +doesFileExistMonitored :: FilePath -> Rebuild Bool +doesFileExistMonitored f = do + root <- askRoot + exists <- liftIO $ doesFileExist (root f) + monitorFiles [if exists + then monitorFileExistence f + else monitorNonExistentFile f] + return exists + +-- | Monitor a single file +need :: FilePath -> Rebuild () +need f = monitorFiles [monitorFileHashed f] + +-- | Monitor a file if it exists; otherwise check for when it +-- gets created. This is a bit better for recompilation avoidance +-- because sometimes users give bad package metadata, and we don't +-- want to repeatedly rebuild in this case (which we would if we +-- need'ed a non-existent file). +needIfExists :: FilePath -> Rebuild () +needIfExists f = do + root <- askRoot + exists <- liftIO $ doesFileExist (root f) + monitorFiles [if exists + then monitorFileHashed f + else monitorNonExistentFile f] + +-- | Like 'findFileWithExtension', but in the 'Rebuild' monad. +findFileWithExtensionMonitored + :: [String] + -> [FilePath] + -> FilePath + -> Rebuild (Maybe FilePath) +findFileWithExtensionMonitored extensions searchPath baseName = + findFirstFileMonitored id + [ path baseName <.> ext + | path <- nub searchPath + , ext <- nub extensions ] + +-- | Like 'findFirstFile', but in the 'Rebuild' monad. +findFirstFileMonitored :: forall a. (a -> FilePath) -> [a] -> Rebuild (Maybe a) +findFirstFileMonitored file = findFirst + where findFirst :: [a] -> Rebuild (Maybe a) + findFirst [] = return Nothing + findFirst (x:xs) = do exists <- doesFileExistMonitored (file x) + if exists + then return (Just x) + else findFirst xs + +-- | Like 'findFile', but in the 'Rebuild' monad. +findFileMonitored :: [FilePath] -> FilePath -> Rebuild (Maybe FilePath) +findFileMonitored searchPath fileName = + findFirstFileMonitored id + [ path fileName + | path <- nub searchPath] diff --git a/cabal/cabal-install/src/Distribution/Client/Reconfigure.hs b/cabal/cabal-install/src/Distribution/Client/Reconfigure.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Reconfigure.hs @@ -0,0 +1,189 @@ +module Distribution.Client.Reconfigure ( Check(..), reconfigure ) where + +import Distribution.Client.Compat.Prelude + +import Data.Monoid ( Any(..) ) +import System.Directory ( doesFileExist ) + +import Distribution.Simple.Configure ( localBuildInfoFile ) +import Distribution.Simple.Setup ( Flag, flagToMaybe, toFlag ) +import Distribution.Simple.Utils + ( existsAndIsMoreRecentThan, defaultPackageDesc, info ) + +import Distribution.Client.Config ( SavedConfig(..) ) +import Distribution.Client.Configure ( readConfigFlags ) +import Distribution.Client.Nix ( findNixExpr, inNixShell, nixInstantiate ) +import Distribution.Client.Sandbox ( findSavedDistPref, updateInstallDirs ) +import Distribution.Client.Sandbox.PackageEnvironment + ( userPackageEnvironmentFile ) +import Distribution.Client.Setup + ( ConfigFlags(..), ConfigExFlags, GlobalFlags(..) ) + +-- | @Check@ represents a function to check some condition on type @a@. The +-- returned 'Any' is 'True' if any part of the condition failed. +newtype Check a = Check { + runCheck :: Any -- Did any previous check fail? + -> a -- value returned by previous checks + -> IO (Any, a) -- Did this check fail? What value is returned? +} + +instance Semigroup (Check a) where + (<>) c d = Check $ \any0 a0 -> do + (any1, a1) <- runCheck c any0 a0 + (any2, a2) <- runCheck d (any0 <> any1) a1 + return (any0 <> any1 <> any2, a2) + +instance Monoid (Check a) where + mempty = Check $ \_ a -> return (mempty, a) + mappend = (<>) + + +-- | Re-configure the package in the current directory if needed. Deciding +-- when to reconfigure and with which options is convoluted: +-- +-- If we are reconfiguring, we must always run @configure@ with the +-- verbosity option we are given; however, that a previous configuration +-- uses a different verbosity setting is not reason enough to reconfigure. +-- +-- The package should be configured to use the same \"dist\" prefix as +-- given to the @build@ command, otherwise the build will probably +-- fail. Not only does this determine the \"dist\" prefix setting if we +-- need to reconfigure anyway, but an existing configuration should be +-- invalidated if its \"dist\" prefix differs. +-- +-- If the package has never been configured (i.e., there is no +-- LocalBuildInfo), we must configure first, using the default options. +-- +-- If the package has been configured, there will be a 'LocalBuildInfo'. +-- If there no package description file, we assume that the +-- 'PackageDescription' is up to date, though the configuration may need +-- to be updated for other reasons (see above). If there is a package +-- description file, and it has been modified since the 'LocalBuildInfo' +-- was generated, then we need to reconfigure. +-- +-- The caller of this function may also have specific requirements +-- regarding the flags the last configuration used. For example, +-- 'testAction' requires that the package be configured with test suites +-- enabled. The caller may pass the required settings to this function +-- along with a function to check the validity of the saved 'ConfigFlags'; +-- these required settings will be checked first upon determining that +-- a previous configuration exists. +reconfigure + :: ((ConfigFlags, ConfigExFlags) -> [String] -> GlobalFlags -> IO ()) + -- ^ configure action + -> Verbosity + -- ^ Verbosity setting + -> FilePath + -- ^ \"dist\" prefix + -> Flag (Maybe Int) + -- ^ -j flag for reinstalling add-source deps. + -> Check (ConfigFlags, ConfigExFlags) + -- ^ Check that the required flags are set. + -- If they are not set, provide a message explaining the + -- reason for reconfiguration. + -> [String] -- ^ Extra arguments + -> GlobalFlags -- ^ Global flags + -> SavedConfig + -> IO SavedConfig +reconfigure + configureAction + verbosity + dist + _numJobsFlag + check + extraArgs + globalFlags + config + = do + + savedFlags@(_, _) <- readConfigFlags dist + + useNix <- fmap isJust (findNixExpr globalFlags config) + alreadyInNixShell <- inNixShell + + if useNix && not alreadyInNixShell + then do + + -- If we are using Nix, we must reinstantiate the derivation outside + -- the shell. Eventually, the caller will invoke 'nixShell' which will + -- rerun cabal inside the shell. That will bring us back to 'reconfigure', + -- but inside the shell we'll take the second branch, below. + + -- This seems to have a problem: won't 'configureAction' call 'nixShell' + -- yet again, spawning an infinite tree of subprocesses? + -- No, because 'nixShell' doesn't spawn a new process if it is already + -- running in a Nix shell. + + nixInstantiate verbosity dist False globalFlags config + return config + + else do + + let checks :: Check (ConfigFlags, ConfigExFlags) + checks = + checkVerb + <> checkDist + <> checkOutdated + <> check + (Any frc, flags@(configFlags, _)) <- runCheck checks mempty savedFlags + + let config' :: SavedConfig + config' = updateInstallDirs (configUserInstall configFlags) config + + when frc $ configureAction flags extraArgs globalFlags + return config' + + where + + -- Changing the verbosity does not require reconfiguration, but the new + -- verbosity should be used if reconfiguring. + checkVerb :: Check (ConfigFlags, b) + checkVerb = Check $ \_ (configFlags, configExFlags) -> do + let configFlags' :: ConfigFlags + configFlags' = configFlags { configVerbosity = toFlag verbosity} + return (mempty, (configFlags', configExFlags)) + + -- Reconfiguration is required if @--build-dir@ changes. + checkDist :: Check (ConfigFlags, b) + checkDist = Check $ \_ (configFlags, configExFlags) -> do + -- Always set the chosen @--build-dir@ before saving the flags, + -- or bad things could happen. + savedDist <- findSavedDistPref config (configDistPref configFlags) + let distChanged :: Bool + distChanged = dist /= savedDist + when distChanged $ info verbosity "build directory changed" + let configFlags' :: ConfigFlags + configFlags' = configFlags { configDistPref = toFlag dist } + return (Any distChanged, (configFlags', configExFlags)) + + checkOutdated :: Check (ConfigFlags, b) + checkOutdated = Check $ \_ flags@(configFlags, _) -> do + let buildConfig :: FilePath + buildConfig = localBuildInfoFile dist + + -- Has the package ever been configured? If not, reconfiguration is + -- required. + configured <- doesFileExist buildConfig + unless configured $ info verbosity "package has never been configured" + + -- Is the @cabal.config@ file newer than @dist/setup.config@? Then we need + -- to force reconfigure. Note that it's possible to use @cabal.config@ + -- even without sandboxes. + userPackageEnvironmentFileModified <- + existsAndIsMoreRecentThan userPackageEnvironmentFile buildConfig + when userPackageEnvironmentFileModified $ + info verbosity ("user package environment file ('" + ++ userPackageEnvironmentFile ++ "') was modified") + + -- Is the configuration older than the package description? + descrFile <- maybe (defaultPackageDesc verbosity) return + (flagToMaybe (configCabalFilePath configFlags)) + outdated <- existsAndIsMoreRecentThan descrFile buildConfig + when outdated $ info verbosity (descrFile ++ " was changed") + + let failed :: Any + failed = + Any outdated + <> Any userPackageEnvironmentFileModified + <> Any (not configured) + return (failed, flags) diff --git a/cabal/cabal-install/src/Distribution/Client/Run.hs b/cabal/cabal-install/src/Distribution/Client/Run.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Run.hs @@ -0,0 +1,141 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Run +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Implementation of the 'run' command. +----------------------------------------------------------------------------- + +module Distribution.Client.Run ( run, splitRunArgs ) + where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Distribution.Types.TargetInfo (targetCLBI) +import Distribution.Types.LocalBuildInfo (componentNameTargets') + +import Distribution.Client.Utils (tryCanonicalizePath) + +import Distribution.Types.UnqualComponentName +import Distribution.PackageDescription (Executable (..), + TestSuite(..), + Benchmark(..), + PackageDescription (..), + BuildInfo(buildable)) +import Distribution.Simple.Compiler (compilerFlavor, CompilerFlavor(..)) +import Distribution.Simple.Build.PathsModule (pkgPathEnvVar) +import Distribution.Simple.BuildPaths (exeExtension) +import Distribution.Simple.LocalBuildInfo (ComponentName (..), + LocalBuildInfo (..), + depLibraryPaths) +import Distribution.Simple.Utils (die', notice, warn, + rawSystemExitWithEnv, + addLibraryPath) +import Distribution.System (Platform (..)) + +import qualified Distribution.Simple.GHCJS as GHCJS + +import System.Directory (getCurrentDirectory) +import Distribution.Compat.Environment (getEnvironment) +import System.FilePath ((<.>), ()) + + +-- | Return the executable to run and any extra arguments that should be +-- forwarded to it. Die in case of error. +splitRunArgs :: Verbosity -> LocalBuildInfo -> [String] + -> IO (Executable, [String]) +splitRunArgs verbosity lbi args = + case whichExecutable of -- Either err (wasManuallyChosen, exe, paramsRest) + Left err -> do + warn verbosity `traverse_` maybeWarning -- If there is a warning, print it. + die' verbosity err + Right (True, exe, xs) -> return (exe, xs) + Right (False, exe, xs) -> do + let addition = " Interpreting all parameters to `run` as a parameter to" + ++ " the default executable." + -- If there is a warning, print it together with the addition. + warn verbosity `traverse_` fmap (++addition) maybeWarning + return (exe, xs) + where + pkg_descr = localPkgDescr lbi + whichExecutable :: Either String -- Error string. + ( Bool -- If it was manually chosen. + , Executable -- The executable. + , [String] -- The remaining parameters. + ) + whichExecutable = case (enabledExes, args) of + ([] , _) -> Left "Couldn't find any enabled executables." + ([exe], []) -> return (False, exe, []) + ([exe], (x:xs)) + | x == unUnqualComponentName (exeName exe) -> return (True, exe, xs) + | otherwise -> return (False, exe, args) + (_ , []) -> Left + $ "This package contains multiple executables. " + ++ "You must pass the executable name as the first argument " + ++ "to 'cabal run'." + (_ , (x:xs)) -> + case find (\exe -> unUnqualComponentName (exeName exe) == x) enabledExes of + Nothing -> Left $ "No executable named '" ++ x ++ "'." + Just exe -> return (True, exe, xs) + where + enabledExes = filter (buildable . buildInfo) (executables pkg_descr) + + maybeWarning :: Maybe String + maybeWarning = case args of + [] -> Nothing + (x:_) -> lookup (mkUnqualComponentName x) components + where + components :: [(UnqualComponentName, String)] -- Component name, message. + components = + [ (name, "The executable '" ++ prettyShow name ++ "' is disabled.") + | e <- executables pkg_descr + , not . buildable . buildInfo $ e, let name = exeName e] + + ++ [ (name, "There is a test-suite '" ++ prettyShow name ++ "'," + ++ " but the `run` command is only for executables.") + | t <- testSuites pkg_descr + , let name = testName t] + + ++ [ (name, "There is a benchmark '" ++ prettyShow name ++ "'," + ++ " but the `run` command is only for executables.") + | b <- benchmarks pkg_descr + , let name = benchmarkName b] + +-- | Run a given executable. +run :: Verbosity -> LocalBuildInfo -> Executable -> [String] -> IO () +run verbosity lbi exe exeArgs = do + curDir <- getCurrentDirectory + let buildPref = buildDir lbi + pkg_descr = localPkgDescr lbi + dataDirEnvVar = (pkgPathEnvVar pkg_descr "datadir", + curDir dataDir pkg_descr) + + (path, runArgs) <- + let exeName' = prettyShow $ exeName exe + in case compilerFlavor (compiler lbi) of + GHCJS -> do + let (script, cmd, cmdArgs) = + GHCJS.runCmd (withPrograms lbi) + (buildPref exeName' exeName') + script' <- tryCanonicalizePath script + return (cmd, cmdArgs ++ [script']) + _ -> do + p <- tryCanonicalizePath $ + buildPref exeName' (exeName' <.> exeExtension (hostPlatform lbi)) + return (p, []) + + env <- (dataDirEnvVar:) <$> getEnvironment + -- Add (DY)LD_LIBRARY_PATH if needed + env' <- if withDynExe lbi + then do let (Platform _ os) = hostPlatform lbi + clbi <- case componentNameTargets' pkg_descr lbi (CExeName (exeName exe)) of + [target] -> return (targetCLBI target) + [] -> die' verbosity "run: Could not find executable in LocalBuildInfo" + _ -> die' verbosity "run: Found multiple matching exes in LocalBuildInfo" + paths <- depLibraryPaths True False lbi clbi + return (addLibraryPath os paths env) + else return env + notice verbosity $ "Running " ++ prettyShow (exeName exe) ++ "..." + rawSystemExitWithEnv verbosity path (runArgs++exeArgs) env' diff --git a/cabal/cabal-install/src/Distribution/Client/Sandbox.hs b/cabal/cabal-install/src/Distribution/Client/Sandbox.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Sandbox.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Sandbox +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- UI for the sandboxing functionality. +----------------------------------------------------------------------------- + +module Distribution.Client.Sandbox ( + loadConfigOrSandboxConfig, + findSavedDistPref, + + updateInstallDirs, + + getPersistOrConfigCompiler + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Distribution.Client.Setup + ( ConfigFlags(..), GlobalFlags(..), configCompilerAux' ) +import Distribution.Client.Config + ( SavedConfig(..), defaultUserInstall, loadConfig ) + +import Distribution.Client.Sandbox.PackageEnvironment + ( PackageEnvironmentType(..) + , classifyPackageEnvironment + , loadUserConfig + ) +import Distribution.Client.SetupWrapper + ( SetupScriptOptions(..), defaultSetupScriptOptions ) +import Distribution.Simple.Compiler ( Compiler(..) ) +import Distribution.Simple.Configure ( maybeGetPersistBuildConfig + , findDistPrefOrDefault + , findDistPref ) +import qualified Distribution.Simple.LocalBuildInfo as LocalBuildInfo +import Distribution.Simple.Program ( ProgramDb ) +import Distribution.Simple.Setup ( Flag(..) + , fromFlagOrDefault, flagToMaybe ) +import Distribution.System ( Platform ) + +import System.Directory ( getCurrentDirectory ) + + +-- * Basic sandbox functions. +-- + +updateInstallDirs :: Flag Bool -> SavedConfig -> SavedConfig +updateInstallDirs userInstallFlag savedConfig = savedConfig + { savedConfigureFlags = configureFlags + { configInstallDirs = installDirs + } + } + where + configureFlags = savedConfigureFlags savedConfig + userInstallDirs = savedUserInstallDirs savedConfig + globalInstallDirs = savedGlobalInstallDirs savedConfig + installDirs | userInstall = userInstallDirs + | otherwise = globalInstallDirs + userInstall = fromFlagOrDefault defaultUserInstall + (configUserInstall configureFlags `mappend` userInstallFlag) + +-- | Check which type of package environment we're in and return a +-- correctly-initialised @SavedConfig@ and a @UseSandbox@ value that indicates +-- whether we're working in a sandbox. +loadConfigOrSandboxConfig :: Verbosity + -> GlobalFlags -- ^ For @--config-file@ and + -- @--sandbox-config-file@. + -> IO SavedConfig +loadConfigOrSandboxConfig verbosity globalFlags = do + let configFileFlag = globalConfigFile globalFlags + + pkgEnvDir <- getCurrentDirectory + pkgEnvType <- classifyPackageEnvironment pkgEnvDir + case pkgEnvType of + -- Only @cabal.config@ is present. + UserPackageEnvironment -> do + config <- loadConfig verbosity configFileFlag + userConfig <- loadUserConfig verbosity pkgEnvDir Nothing + let config' = config `mappend` userConfig + return config' + + -- Neither @cabal.sandbox.config@ nor @cabal.config@ are present. + AmbientPackageEnvironment -> do + config <- loadConfig verbosity configFileFlag + let globalConstraintsOpt = + flagToMaybe . globalConstraintsFile . savedGlobalFlags $ config + globalConstraintConfig <- + loadUserConfig verbosity pkgEnvDir globalConstraintsOpt + let config' = config `mappend` globalConstraintConfig + return config' + +-- | Return the saved \"dist/\" prefix, or the default prefix. +findSavedDistPref :: SavedConfig -> Flag FilePath -> IO FilePath +findSavedDistPref config flagDistPref = do + let defDistPref = useDistPref defaultSetupScriptOptions + flagDistPref' = configDistPref (savedConfigureFlags config) + `mappend` flagDistPref + findDistPref defDistPref flagDistPref' + +-- Utils (transitionary) +-- + +-- | Try to read the most recently configured compiler from the +-- 'localBuildInfoFile', falling back on 'configCompilerAuxEx' if it +-- cannot be read. +getPersistOrConfigCompiler :: ConfigFlags + -> IO (Compiler, Platform, ProgramDb) +getPersistOrConfigCompiler configFlags = do + distPref <- findDistPrefOrDefault (configDistPref configFlags) + mlbi <- maybeGetPersistBuildConfig distPref + case mlbi of + Nothing -> do configCompilerAux' configFlags + Just lbi -> return ( LocalBuildInfo.compiler lbi + , LocalBuildInfo.hostPlatform lbi + , LocalBuildInfo.withPrograms lbi + ) diff --git a/cabal/cabal-install/src/Distribution/Client/Sandbox/PackageEnvironment.hs b/cabal/cabal-install/src/Distribution/Client/Sandbox/PackageEnvironment.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Sandbox/PackageEnvironment.hs @@ -0,0 +1,285 @@ +{-# LANGUAGE DeriveGeneric #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Sandbox.PackageEnvironment +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Utilities for working with the package environment file. Patterned after +-- Distribution.Client.Config. +----------------------------------------------------------------------------- + +module Distribution.Client.Sandbox.PackageEnvironment ( + PackageEnvironment(..) + , PackageEnvironmentType(..) + , classifyPackageEnvironment + , readPackageEnvironmentFile + , showPackageEnvironment + , showPackageEnvironmentWithComments + , loadUserConfig + + , userPackageEnvironmentFile + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Client.Config ( SavedConfig(..) + , configFieldDescriptions + , haddockFlagsFields + , installDirsFields, withProgramsFields + , withProgramOptionsFields + ) +import Distribution.Client.ParseUtils ( parseFields, ppFields, ppSection ) +import Distribution.Client.Setup ( ConfigExFlags(..) + ) +import Distribution.Client.Targets ( userConstraintPackageName ) +import Distribution.Simple.InstallDirs ( InstallDirs(..), PathTemplate ) +import Distribution.Simple.Setup ( Flag(..) + , ConfigFlags(..), HaddockFlags(..) + ) +import Distribution.Simple.Utils ( warn, debug ) +import Distribution.Solver.Types.ConstraintSource +import Distribution.Deprecated.ParseUtils ( FieldDescr(..), ParseResult(..) + , commaListFieldParsec, commaNewLineListFieldParsec + , liftField, lineNo, locatedErrorMsg + , readFields + , showPWarning + , syntaxError, warning ) +import System.Directory ( doesFileExist ) +import System.FilePath ( () ) +import System.IO.Error ( isDoesNotExistError ) +import Text.PrettyPrint ( ($+$) ) + +import qualified Data.ByteString as BS +import qualified Text.PrettyPrint as Disp +import qualified Distribution.Deprecated.ParseUtils as ParseUtils ( Field(..) ) + +-- +-- * Configuration saved in the package environment file +-- + +-- TODO: would be nice to remove duplication between +-- D.C.Sandbox.PackageEnvironment and D.C.Config. +data PackageEnvironment = PackageEnvironment { + pkgEnvSavedConfig :: SavedConfig +} deriving Generic + +instance Monoid PackageEnvironment where + mempty = gmempty + mappend = (<>) + +instance Semigroup PackageEnvironment where + (<>) = gmappend + +-- | Optional package environment file that can be used to customize the default +-- settings. Created by the user. +userPackageEnvironmentFile :: FilePath +userPackageEnvironmentFile = "cabal.config" + +-- | Type of the current package environment. +data PackageEnvironmentType + = UserPackageEnvironment -- ^ './cabal.config' + | AmbientPackageEnvironment -- ^ '~/.cabal/config' + +-- | Is there a 'cabal.config' in this directory? +classifyPackageEnvironment :: FilePath -> IO PackageEnvironmentType +classifyPackageEnvironment pkgEnvDir = do + isUser <- configExists userPackageEnvironmentFile + return (classify isUser) + where + configExists fname = doesFileExist (pkgEnvDir fname) + + classify :: Bool -> PackageEnvironmentType + classify True = UserPackageEnvironment + classify False = AmbientPackageEnvironment + + +-- | Load the user package environment if it exists (the optional "cabal.config" +-- file). If it does not exist locally, attempt to load an optional global one. +userPackageEnvironment :: Verbosity -> FilePath -> Maybe FilePath + -> IO PackageEnvironment +userPackageEnvironment verbosity pkgEnvDir globalConfigLocation = do + let path = pkgEnvDir userPackageEnvironmentFile + minp <- readPackageEnvironmentFile (ConstraintSourceUserConfig path) + mempty path + case (minp, globalConfigLocation) of + (Just parseRes, _) -> processConfigParse path parseRes + (_, Just globalLoc) -> do + minp' <- readPackageEnvironmentFile (ConstraintSourceUserConfig globalLoc) + mempty globalLoc + maybe (warn verbosity ("no constraints file found at " ++ globalLoc) + >> return mempty) + (processConfigParse globalLoc) + minp' + _ -> do + debug verbosity ("no user package environment file found at " ++ pkgEnvDir) + return mempty + where + processConfigParse path (ParseOk warns parseResult) = do + unless (null warns) $ warn verbosity $ + unlines (map (showPWarning path) warns) + return parseResult + processConfigParse path (ParseFailed err) = do + let (line, msg) = locatedErrorMsg err + warn verbosity $ "Error parsing package environment file " ++ path + ++ maybe "" (\n -> ":" ++ show n) line ++ ":\n" ++ msg + return mempty + +-- | Same as @userPackageEnvironmentFile@, but returns a SavedConfig. +loadUserConfig :: Verbosity -> FilePath -> Maybe FilePath -> IO SavedConfig +loadUserConfig verbosity pkgEnvDir globalConfigLocation = + fmap pkgEnvSavedConfig $ + userPackageEnvironment verbosity pkgEnvDir globalConfigLocation + + + +-- | Descriptions of all fields in the package environment file. +pkgEnvFieldDescrs :: ConstraintSource -> [FieldDescr PackageEnvironment] +pkgEnvFieldDescrs src = + [ commaNewLineListFieldParsec "constraints" + (pretty . fst) ((\pc -> (pc, src)) `fmap` parsec) + (sortConstraints . configExConstraints + . savedConfigureExFlags . pkgEnvSavedConfig) + (\v pkgEnv -> updateConfigureExFlags pkgEnv + (\flags -> flags { configExConstraints = v })) + + , commaListFieldParsec "preferences" + pretty parsec + (configPreferences . savedConfigureExFlags . pkgEnvSavedConfig) + (\v pkgEnv -> updateConfigureExFlags pkgEnv + (\flags -> flags { configPreferences = v })) + ] + ++ map toPkgEnv configFieldDescriptions' + where + configFieldDescriptions' :: [FieldDescr SavedConfig] + configFieldDescriptions' = filter + (\(FieldDescr name _ _) -> name /= "preference" && name /= "constraint") + (configFieldDescriptions src) + + toPkgEnv :: FieldDescr SavedConfig -> FieldDescr PackageEnvironment + toPkgEnv fieldDescr = + liftField pkgEnvSavedConfig + (\savedConfig pkgEnv -> pkgEnv { pkgEnvSavedConfig = savedConfig}) + fieldDescr + + updateConfigureExFlags :: PackageEnvironment + -> (ConfigExFlags -> ConfigExFlags) + -> PackageEnvironment + updateConfigureExFlags pkgEnv f = pkgEnv { + pkgEnvSavedConfig = (pkgEnvSavedConfig pkgEnv) { + savedConfigureExFlags = f . savedConfigureExFlags . pkgEnvSavedConfig + $ pkgEnv + } + } + + sortConstraints = sortBy (comparing $ userConstraintPackageName . fst) + +-- | Read the package environment file. +readPackageEnvironmentFile :: ConstraintSource -> PackageEnvironment -> FilePath + -> IO (Maybe (ParseResult PackageEnvironment)) +readPackageEnvironmentFile src initial file = + handleNotExists $ + fmap (Just . parsePackageEnvironment src initial) (BS.readFile file) + where + handleNotExists action = catchIO action $ \ioe -> + if isDoesNotExistError ioe + then return Nothing + else ioError ioe + +-- | Parse the package environment file. +parsePackageEnvironment :: ConstraintSource -> PackageEnvironment -> BS.ByteString + -> ParseResult PackageEnvironment +parsePackageEnvironment src initial str = do + fields <- readFields str + let (knownSections, others) = partition isKnownSection fields + pkgEnv <- parse others + let config = pkgEnvSavedConfig pkgEnv + installDirs0 = savedUserInstallDirs config + (haddockFlags, installDirs, paths, args) <- + foldM parseSections + (savedHaddockFlags config, installDirs0, [], []) + knownSections + return pkgEnv { + pkgEnvSavedConfig = config { + savedConfigureFlags = (savedConfigureFlags config) { + configProgramPaths = paths, + configProgramArgs = args + }, + savedHaddockFlags = haddockFlags, + savedUserInstallDirs = installDirs, + savedGlobalInstallDirs = installDirs + } + } + + where + isKnownSection :: ParseUtils.Field -> Bool + isKnownSection (ParseUtils.Section _ "haddock" _ _) = True + isKnownSection (ParseUtils.Section _ "install-dirs" _ _) = True + isKnownSection (ParseUtils.Section _ "program-locations" _ _) = True + isKnownSection (ParseUtils.Section _ "program-default-options" _ _) = True + isKnownSection _ = False + + parse :: [ParseUtils.Field] -> ParseResult PackageEnvironment + parse = parseFields (pkgEnvFieldDescrs src) initial + + parseSections :: SectionsAccum -> ParseUtils.Field + -> ParseResult SectionsAccum + parseSections accum@(h,d,p,a) + (ParseUtils.Section _ "haddock" name fs) + | name == "" = do h' <- parseFields haddockFlagsFields h fs + return (h', d, p, a) + | otherwise = do + warning "The 'haddock' section should be unnamed" + return accum + parseSections (h,d,p,a) + (ParseUtils.Section line "install-dirs" name fs) + | name == "" = do d' <- parseFields installDirsFields d fs + return (h, d',p,a) + | otherwise = + syntaxError line $ + "Named 'install-dirs' section: '" ++ name + ++ "'. Note that named 'install-dirs' sections are not allowed in the '" + ++ userPackageEnvironmentFile ++ "' file." + parseSections accum@(h, d,p,a) + (ParseUtils.Section _ "program-locations" name fs) + | name == "" = do p' <- parseFields withProgramsFields p fs + return (h, d, p', a) + | otherwise = do + warning "The 'program-locations' section should be unnamed" + return accum + parseSections accum@(h, d, p, a) + (ParseUtils.Section _ "program-default-options" name fs) + | name == "" = do a' <- parseFields withProgramOptionsFields a fs + return (h, d, p, a') + | otherwise = do + warning "The 'program-default-options' section should be unnamed" + return accum + parseSections accum f = do + warning $ "Unrecognized stanza on line " ++ show (lineNo f) + return accum + +-- | Accumulator type for 'parseSections'. +type SectionsAccum = (HaddockFlags, InstallDirs (Flag PathTemplate) + , [(String, FilePath)], [(String, [String])]) + + + +-- | Pretty-print the package environment. +showPackageEnvironment :: PackageEnvironment -> String +showPackageEnvironment pkgEnv = showPackageEnvironmentWithComments Nothing pkgEnv + +-- | Pretty-print the package environment with default values for empty fields +-- commented out (just like the default ~/.cabal/config). +showPackageEnvironmentWithComments :: (Maybe PackageEnvironment) + -> PackageEnvironment + -> String +showPackageEnvironmentWithComments mdefPkgEnv pkgEnv = Disp.render $ + ppFields (pkgEnvFieldDescrs ConstraintSourceUnknown) + mdefPkgEnv pkgEnv + $+$ Disp.text "" + $+$ ppSection "install-dirs" "" installDirsFields + (fmap installDirsSection mdefPkgEnv) (installDirsSection pkgEnv) + where + installDirsSection = savedUserInstallDirs . pkgEnvSavedConfig diff --git a/cabal/cabal-install/src/Distribution/Client/SavedFlags.hs b/cabal/cabal-install/src/Distribution/Client/SavedFlags.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/SavedFlags.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +module Distribution.Client.SavedFlags + ( readCommandFlags, writeCommandFlags + , readSavedArgs, writeSavedArgs + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Simple.Command +import Distribution.Simple.UserHooks ( Args ) +import Distribution.Simple.Utils + ( createDirectoryIfMissingVerbose, unintersperse ) +import Distribution.Verbosity + +import System.Directory ( doesFileExist ) +import System.FilePath ( takeDirectory ) + + +writeSavedArgs :: Verbosity -> FilePath -> [String] -> IO () +writeSavedArgs verbosity path args = do + createDirectoryIfMissingVerbose + (lessVerbose verbosity) True (takeDirectory path) + writeFile path (intercalate "\0" args) + + +-- | Write command-line flags to a file, separated by null characters. This +-- format is also suitable for the @xargs -0@ command. Using the null +-- character also avoids the problem of escaping newlines or spaces, +-- because unlike other whitespace characters, the null character is +-- not valid in command-line arguments. +writeCommandFlags :: Verbosity -> FilePath -> CommandUI flags -> flags -> IO () +writeCommandFlags verbosity path command flags = + writeSavedArgs verbosity path (commandShowOptions command flags) + + +readSavedArgs :: FilePath -> IO (Maybe [String]) +readSavedArgs path = do + exists <- doesFileExist path + if exists + then fmap (Just . unintersperse '\0') (readFile path) + else return Nothing + + +-- | Read command-line arguments, separated by null characters, from a file. +-- Returns the default flags if the file does not exist. +readCommandFlags :: FilePath -> CommandUI flags -> IO flags +readCommandFlags path command = do + savedArgs <- fmap (fromMaybe []) (readSavedArgs path) + case (commandParseArgs command True savedArgs) of + CommandHelp _ -> throwIO (SavedArgsErrorHelp savedArgs) + CommandList _ -> throwIO (SavedArgsErrorList savedArgs) + CommandErrors errs -> throwIO (SavedArgsErrorOther savedArgs errs) + CommandReadyToGo (mkFlags, _) -> + return (mkFlags (commandDefaultFlags command)) + +-- ----------------------------------------------------------------------------- +-- * Exceptions +-- ----------------------------------------------------------------------------- + +data SavedArgsError + = SavedArgsErrorHelp Args + | SavedArgsErrorList Args + | SavedArgsErrorOther Args [String] + deriving (Typeable) + +instance Show SavedArgsError where + show (SavedArgsErrorHelp args) = + "unexpected flag '--help', saved command line was:\n" + ++ intercalate " " args + show (SavedArgsErrorList args) = + "unexpected flag '--list-options', saved command line was:\n" + ++ intercalate " " args + show (SavedArgsErrorOther args errs) = + "saved command line was:\n" + ++ intercalate " " args ++ "\n" + ++ "encountered errors:\n" + ++ intercalate "\n" errs + +instance Exception SavedArgsError diff --git a/cabal/cabal-install/src/Distribution/Client/ScriptUtils.hs b/cabal/cabal-install/src/Distribution/Client/ScriptUtils.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/ScriptUtils.hs @@ -0,0 +1,425 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | Utilities to help commands with scripts +-- +module Distribution.Client.ScriptUtils ( + getScriptCacheDirectoryRoot, getScriptHash, getScriptCacheDirectory, ensureScriptCacheDirectory, + withContextAndSelectors, AcceptNoTargets(..), TargetContext(..), + updateContextAndWriteProjectFile, updateContextAndWriteProjectFile', + fakeProjectSourcePackage, lSrcpkgDescription + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude hiding (toList) + +import Distribution.Compat.Lens +import qualified Distribution.Types.Lens as L + +import Distribution.CabalSpecVersion + ( CabalSpecVersion (..), cabalSpecLatest) +import Distribution.Client.ProjectOrchestration +import Distribution.Client.Config + ( getCabalDir ) +import Distribution.Client.DistDirLayout + ( DistDirLayout(..) ) +import Distribution.Client.HashValue + ( hashValue, showHashValue ) +import Distribution.Client.HttpUtils + ( HttpTransport, configureTransport ) +import Distribution.Client.NixStyleOptions + ( NixStyleFlags (..) ) +import Distribution.Client.ProjectConfig + ( ProjectConfig(..), ProjectConfigShared(..) + , reportParseResult, withProjectOrGlobalConfig + , projectConfigHttpTransport ) +import Distribution.Client.ProjectConfig.Legacy + ( ProjectConfigSkeleton + , parseProjectSkeleton, instantiateProjectConfigSkeleton ) +import Distribution.Client.ProjectFlags + ( flagIgnoreProject ) +import Distribution.Client.RebuildMonad + ( runRebuild ) +import Distribution.Client.Setup + ( ConfigFlags(..), GlobalFlags(..) ) +import Distribution.Client.TargetSelector + ( TargetSelectorProblem(..), TargetString(..) ) +import Distribution.Client.Types + ( PackageLocation(..), PackageSpecifier(..), UnresolvedSourcePackage ) +import Distribution.FieldGrammar + ( parseFieldGrammar, takeFields ) +import Distribution.Fields + ( ParseResult, parseFatalFailure, readFields ) +import Distribution.PackageDescription + ( ignoreConditions ) +import Distribution.PackageDescription.FieldGrammar + ( executableFieldGrammar ) +import Distribution.PackageDescription.PrettyPrint + ( showGenericPackageDescription ) +import Distribution.Parsec + ( Position(..) ) +import Distribution.Simple.Flag + ( fromFlagOrDefault, flagToMaybe ) +import Distribution.Simple.PackageDescription + ( parseString ) +import Distribution.Simple.Setup + ( Flag(..) ) +import Distribution.Simple.Compiler + ( compilerInfo ) +import Distribution.Simple.Utils + ( createDirectoryIfMissingVerbose, createTempDirectory, die', handleDoesNotExist, readUTF8File, warn, writeUTF8File ) +import qualified Distribution.SPDX.License as SPDX +import Distribution.Solver.Types.SourcePackage as SP + ( SourcePackage(..) ) +import Distribution.System + ( Platform(..) ) +import Distribution.Types.BuildInfo + ( BuildInfo(..) ) +import Distribution.Types.CondTree + ( CondTree(..) ) +import Distribution.Types.Executable + ( Executable(..) ) +import Distribution.Types.GenericPackageDescription as GPD + ( GenericPackageDescription(..), emptyGenericPackageDescription ) +import Distribution.Types.PackageDescription + ( PackageDescription(..), emptyPackageDescription ) +import Distribution.Types.PackageName.Magic + ( fakePackageCabalFileName, fakePackageId ) +import Distribution.Utils.NubList + ( fromNubList ) +import Distribution.Client.ProjectPlanning + ( configureCompiler ) +import Distribution.Verbosity + ( normal ) +import Language.Haskell.Extension + ( Language(..) ) + +import Control.Concurrent.MVar + ( newEmptyMVar, putMVar, tryTakeMVar ) +import Control.Exception + ( bracket ) +import qualified Data.ByteString.Char8 as BS +import Data.ByteString.Lazy () +import qualified Data.Set as S +import System.Directory + ( canonicalizePath, doesFileExist, getTemporaryDirectory, removeDirectoryRecursive ) +import System.FilePath + ( (), takeFileName ) +import qualified Text.Parsec as P + +-- A note on multi-module script support #6787: +-- Multi-module scripts are not supported and support is non-trivial. +-- What you want to do is pass the absolute path to the script's directory in hs-source-dirs, +-- but hs-source-dirs only accepts relative paths. This leaves you with several options none +-- of which are particularly appealing. +-- 1) Loosen the requirement that hs-source-dirs take relative paths +-- 2) Add a field to BuildInfo that acts like an hs-source-dir, but accepts an absolute path +-- 3) Use a path relative to the project root in hs-source-dirs, and pass extra flags to the +-- repl to deal with the fact that the repl is relative to the working directory and not +-- the project root. + +-- | Get the directory where script builds are cached. +-- +-- @CABAL_DIR\/script-builds\/@ +getScriptCacheDirectoryRoot :: IO FilePath +getScriptCacheDirectoryRoot = do + cabalDir <- getCabalDir + return $ cabalDir "script-builds" + +-- | Get the hash of a script's absolute path) +-- +-- Two hashes will be the same as long as the absolute paths +-- are the same. +getScriptHash :: FilePath -> IO String +getScriptHash script = showHashValue . hashValue . fromString <$> canonicalizePath script + +-- | Get the directory for caching a script build. +-- +-- The only identity of a script is it's absolute path, so append the +-- hashed path to @CABAL_DIR\/script-builds\/@ to get the cache directory. +getScriptCacheDirectory :: FilePath -> IO FilePath +getScriptCacheDirectory script = () <$> getScriptCacheDirectoryRoot <*> getScriptHash script + +-- | Get the directory for caching a script build and ensure it exists. +-- +-- The only identity of a script is it's absolute path, so append the +-- hashed path to @CABAL_DIR\/script-builds\/@ to get the cache directory. +ensureScriptCacheDirectory :: Verbosity -> FilePath -> IO FilePath +ensureScriptCacheDirectory verbosity script = do + cacheDir <- getScriptCacheDirectory script + createDirectoryIfMissingVerbose verbosity True cacheDir + return cacheDir + +-- | What your command should do when no targets are found. +data AcceptNoTargets + = RejectNoTargets -- ^ die on 'TargetSelectorNoTargetsInProject' + | AcceptNoTargets -- ^ return a default 'TargetSelector' + deriving (Eq, Show) + +-- | Information about the context in which we found the 'TargetSelector's. +data TargetContext + = ProjectContext -- ^ The target selectors are part of a project. + | GlobalContext -- ^ The target selectors are from the global context. + | ScriptContext FilePath Executable + -- ^ The target selectors refer to a script. Contains the path to the script and + -- the executable metadata parsed from the script + deriving (Eq, Show) + +-- | Determine whether the targets represent regular targets or a script +-- and return the proper context and target selectors. +-- Die with an error message if selectors are valid as neither regular targets or as a script. +-- +-- In the case that the context refers to a temporary directory, +-- delete it after the action finishes. +withContextAndSelectors + :: AcceptNoTargets -- ^ What your command should do when no targets are found. + -> Maybe ComponentKind -- ^ A target filter + -> NixStyleFlags a -- ^ Command line flags + -> [String] -- ^ Target strings or a script and args. + -> GlobalFlags -- ^ Global flags. + -> (TargetContext -> ProjectBaseContext -> [TargetSelector] -> IO b) + -- ^ The body of your command action. + -> IO b +withContextAndSelectors noTargets kind flags@NixStyleFlags {..} targetStrings globalFlags act + = withTemporaryTempDirectory $ \mkTmpDir -> do + (tc, ctx) <- withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag with (without mkTmpDir) + + (tc', ctx', sels) <- case targetStrings of + -- Only script targets may contain spaces and or end with ':'. + -- Trying to readTargetSelectors such a target leads to a parse error. + [target] | any (\c -> isSpace c) target || ":" `isSuffixOf` target -> do + scriptOrError target [TargetSelectorNoScript $ TargetString1 target] + _ -> do + -- In the case where a selector is both a valid target and script, assume it is a target, + -- because you can disambiguate the script with "./script" + readTargetSelectors (localPackages ctx) kind targetStrings >>= \case + Left err@(TargetSelectorNoTargetsInProject:_) + | [] <- targetStrings + , AcceptNoTargets <- noTargets -> return (tc, ctx, defaultTarget) + | (script:_) <- targetStrings -> scriptOrError script err + Left err@(TargetSelectorNoSuch t _:_) + | TargetString1 script <- t -> scriptOrError script err + Left err@(TargetSelectorExpected t _ _:_) + | TargetString1 script <- t -> scriptOrError script err + Left err@(MatchingInternalError _ _ _:_) -- Handle ':' in middle of script name. + | [script] <- targetStrings -> scriptOrError script err + Left err -> reportTargetSelectorProblems verbosity err + Right sels -> return (tc, ctx, sels) + + act tc' ctx' sels + where + verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + ignoreProject = flagIgnoreProject projectFlags + cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty + globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) + defaultTarget = [TargetPackage TargetExplicitNamed [fakePackageId] Nothing] + + with = do + ctx <- establishProjectBaseContext verbosity cliConfig OtherCommand + return (ProjectContext, ctx) + without mkDir globalConfig = do + distDirLayout <- establishDummyDistDirLayout verbosity (globalConfig <> cliConfig) =<< mkDir + ctx <- establishDummyProjectBaseContext verbosity (globalConfig <> cliConfig) distDirLayout [] OtherCommand + return (GlobalContext, ctx) + scriptOrError script err = do + exists <- doesFileExist script + if exists then do + -- In the script case we always want a dummy context even when ignoreProject is False + let mkCacheDir = ensureScriptCacheDirectory verbosity script + (_, ctx) <- withProjectOrGlobalConfig verbosity (Flag True) globalConfigFlag with (without mkCacheDir) + + let projectRoot = distProjectRootDirectory $ distDirLayout ctx + writeFile (projectRoot "scriptlocation") =<< canonicalizePath script + + scriptContents <- BS.readFile script + executable <- readExecutableBlockFromScript verbosity scriptContents + + + httpTransport <- configureTransport verbosity + (fromNubList . projectConfigProgPathExtra $ projectConfigShared cliConfig) + (flagToMaybe . projectConfigHttpTransport $ projectConfigBuildOnly cliConfig) + + projectCfgSkeleton <- readProjectBlockFromScript verbosity httpTransport (distDirLayout ctx) (takeFileName script) scriptContents + + (compiler, Platform arch os, _) <- runRebuild (distProjectRootDirectory . distDirLayout $ ctx) $ configureCompiler verbosity (distDirLayout ctx) ((fst $ ignoreConditions projectCfgSkeleton) <> projectConfig ctx) + + let projectCfg = instantiateProjectConfigSkeleton os arch (compilerInfo compiler) mempty projectCfgSkeleton :: ProjectConfig + + let executable' = executable & L.buildInfo . L.defaultLanguage %~ maybe (Just Haskell2010) Just + ctx' = ctx & lProjectConfig %~ (<> projectCfg) + return (ScriptContext script executable', ctx', defaultTarget) + else reportTargetSelectorProblems verbosity err + +withTemporaryTempDirectory :: (IO FilePath -> IO a) -> IO a +withTemporaryTempDirectory act = newEmptyMVar >>= \m -> bracket (getMkTmp m) (rmTmp m) act + where + -- We return an (IO Filepath) instead of a FilePath for two reasons: + -- 1) To give the consumer the discretion to not create the tmpDir, + -- but still grantee that it's deleted if they do create it + -- 2) Because the path returned by createTempDirectory is not predicable + getMkTmp m = return $ do + tmpDir <- getTemporaryDirectory >>= flip createTempDirectory "cabal-repl." + putMVar m tmpDir + return tmpDir + rmTmp m _ = tryTakeMVar m >>= maybe (return ()) (handleDoesNotExist () . removeDirectoryRecursive) + +-- | Add the 'SourcePackage' to the context and use it to write a .cabal file. +updateContextAndWriteProjectFile' :: ProjectBaseContext -> SourcePackage (PackageLocation (Maybe FilePath)) -> IO ProjectBaseContext +updateContextAndWriteProjectFile' ctx srcPkg = do + let projectRoot = distProjectRootDirectory $ distDirLayout ctx + packageFile = projectRoot fakePackageCabalFileName + contents = showGenericPackageDescription (srcpkgDescription srcPkg) + writePackageFile = writeUTF8File packageFile contents + -- TODO This is here to prevent reconfiguration of cached repl packages. + -- It's worth investigating why it's needed in the first place. + packageFileExists <- doesFileExist packageFile + if packageFileExists then do + cached <- force <$> readUTF8File packageFile + when (cached /= contents) + writePackageFile + else writePackageFile + return (ctx & lLocalPackages %~ (++ [SpecificSourcePackage srcPkg])) + +-- | Add add the executable metadata to the context and write a .cabal file. +updateContextAndWriteProjectFile :: ProjectBaseContext -> FilePath -> Executable -> IO ProjectBaseContext +updateContextAndWriteProjectFile ctx scriptPath scriptExecutable = do + let projectRoot = distProjectRootDirectory $ distDirLayout ctx + + absScript <- canonicalizePath scriptPath + let + -- Replace characters which aren't allowed in the executable component name with '_' + -- Prefix with "cabal-script-" to make it clear to end users that the name may be mangled + scriptExeName = "cabal-script-" ++ map censor (takeFileName scriptPath) + censor c | c `S.member` ccNamecore = c + | otherwise = '_' + + sourcePackage = fakeProjectSourcePackage projectRoot + & lSrcpkgDescription . L.condExecutables + .~ [(fromString scriptExeName, CondNode executable (targetBuildDepends $ buildInfo executable) [])] + executable = scriptExecutable + & L.modulePath .~ absScript + + updateContextAndWriteProjectFile' ctx sourcePackage + +parseScriptBlock :: BS.ByteString -> ParseResult Executable +parseScriptBlock str = + case readFields str of + Right fs -> do + let (fields, _) = takeFields fs + parseFieldGrammar cabalSpecLatest fields (executableFieldGrammar "script") + Left perr -> parseFatalFailure pos (show perr) where + ppos = P.errorPos perr + pos = Position (P.sourceLine ppos) (P.sourceColumn ppos) + +readScriptBlock :: Verbosity -> BS.ByteString -> IO Executable +readScriptBlock verbosity = parseString parseScriptBlock verbosity "script block" + +-- | Extract the first encountered executable metadata block started and +-- terminated by the below tokens or die. +-- +-- * @{- cabal:@ +-- +-- * @-}@ +-- +-- Return the metadata. +readExecutableBlockFromScript :: Verbosity -> BS.ByteString -> IO Executable +readExecutableBlockFromScript verbosity str = do + str' <- case extractScriptBlock "cabal" str of + Left e -> die' verbosity $ "Failed extracting script block: " ++ e + Right x -> return x + when (BS.all isSpace str') $ warn verbosity "Empty script block" + readScriptBlock verbosity str' + +-- | Extract the first encountered project metadata block started and +-- terminated by the below tokens. +-- +-- * @{- project:@ +-- +-- * @-}@ +-- +-- Return the metadata. +readProjectBlockFromScript :: Verbosity -> HttpTransport -> DistDirLayout -> String -> BS.ByteString -> IO ProjectConfigSkeleton +readProjectBlockFromScript verbosity httpTransport DistDirLayout{distDownloadSrcDirectory} scriptName str = do + case extractScriptBlock "project" str of + Left _ -> return mempty + Right x -> reportParseResult verbosity "script" scriptName + =<< parseProjectSkeleton distDownloadSrcDirectory httpTransport verbosity [] scriptName x + +-- | Extract the first encountered script metadata block started end +-- terminated by the tokens +-- +-- * @{-
:@ +-- +-- * @-}@ +-- +-- appearing alone on lines (while tolerating trailing whitespace). +-- These tokens are not part of the 'Right' result. +-- +-- In case of missing or unterminated blocks a 'Left'-error is +-- returned. +extractScriptBlock :: BS.ByteString -> BS.ByteString -> Either String BS.ByteString +extractScriptBlock header str = goPre (BS.lines str) + where + isStartMarker = (== startMarker) . stripTrailSpace + isEndMarker = (== endMarker) . stripTrailSpace + + stripTrailSpace = fst . BS.spanEnd isSpace + + -- before start marker + goPre ls = case dropWhile (not . isStartMarker) ls of + [] -> Left $ "`" ++ BS.unpack startMarker ++ "` start marker not found" + (_:ls') -> goBody [] ls' + + goBody _ [] = Left $ "`" ++ BS.unpack endMarker ++ "` end marker not found" + goBody acc (l:ls) + | isEndMarker l = Right $! BS.unlines $ reverse acc + | otherwise = goBody (l:acc) ls + + startMarker, endMarker :: BS.ByteString + startMarker = "{- " <> header <> ":" + endMarker = "-}" + +-- | The base for making a 'SourcePackage' for a fake project. +-- It needs a 'Distribution.Types.Library.Library' or 'Executable' depending on the command. +fakeProjectSourcePackage :: FilePath -> SourcePackage (PackageLocation loc) +fakeProjectSourcePackage projectRoot = sourcePackage + where + sourcePackage = SourcePackage + { srcpkgPackageId = fakePackageId + , srcpkgDescription = genericPackageDescription + , srcpkgSource = LocalUnpackedPackage projectRoot + , srcpkgDescrOverride = Nothing + } + genericPackageDescription = emptyGenericPackageDescription + { GPD.packageDescription = packageDescription } + packageDescription = emptyPackageDescription + { package = fakePackageId + , specVersion = CabalSpecV2_2 + , licenseRaw = Left SPDX.NONE + } + +-- Lenses +-- | A lens for the 'srcpkgDescription' field of 'SourcePackage' +lSrcpkgDescription :: Lens' (SourcePackage loc) GenericPackageDescription +lSrcpkgDescription f s = fmap (\x -> s { srcpkgDescription = x }) (f (srcpkgDescription s)) +{-# inline lSrcpkgDescription #-} + +lLocalPackages :: Lens' ProjectBaseContext [PackageSpecifier UnresolvedSourcePackage] +lLocalPackages f s = fmap (\x -> s { localPackages = x }) (f (localPackages s)) +{-# inline lLocalPackages #-} + +lProjectConfig :: Lens' ProjectBaseContext ProjectConfig +lProjectConfig f s = fmap (\x -> s { projectConfig = x }) (f (projectConfig s)) +{-# inline lProjectConfig #-} + +-- Character classes +-- Transcribed from "templates/Lexer.x" +ccSpace, ccCtrlchar, ccPrintable, ccSymbol', ccParen, ccNamecore :: Set Char +ccSpace = S.fromList " " +ccCtrlchar = S.fromList $ [chr 0x0 .. chr 0x1f] ++ [chr 0x7f] +ccPrintable = S.fromList [chr 0x0 .. chr 0xff] S.\\ ccCtrlchar +ccSymbol' = S.fromList ",=<>+*&|!$%^@#?/\\~" +ccParen = S.fromList "()[]" +ccNamecore = ccPrintable S.\\ S.unions [ccSpace, S.fromList ":\"{}", ccParen, ccSymbol'] diff --git a/cabal/cabal-install/src/Distribution/Client/Security/DNS.hs b/cabal/cabal-install/src/Distribution/Client/Security/DNS.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Security/DNS.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DoAndIfThenElse #-} + +module Distribution.Client.Security.DNS + ( queryBootstrapMirrors + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude +import Network.URI (URI(..), URIAuth(..), parseURI) +import Control.Exception (try) +import Distribution.Simple.Utils + +#if defined(MIN_VERSION_resolv) || defined(MIN_VERSION_windns) +import Network.DNS (queryTXT, Name(..), CharStr(..)) +import qualified Data.ByteString.Char8 as BS.Char8 +#else +import Distribution.Simple.Program.Db + ( emptyProgramDb, addKnownProgram + , configureAllKnownPrograms, lookupProgram ) +import Distribution.Simple.Program + ( simpleProgram + , programInvocation + , getProgramInvocationOutput ) +#endif + +-- | Try to lookup RFC1464-encoded mirror urls for a Hackage +-- repository url by performing a DNS TXT lookup on the +-- @_mirrors.@-prefixed URL hostname. +-- +-- Example: for @http://hackage.haskell.org/@ +-- perform a DNS TXT query for the hostname +-- @_mirrors.hackage.haskell.org@ which may look like e.g. +-- +-- > _mirrors.hackage.haskell.org. 300 IN TXT +-- > "0.urlbase=http://hackage.fpcomplete.com/" +-- > "1.urlbase=http://objects-us-west-1.dream.io/hackage-mirror/" +-- +-- NB: hackage-security doesn't require DNS lookups being trustworthy, +-- as the trust is established via the cryptographically signed TUF +-- meta-data that is retrieved from the resolved Hackage repository. +-- Moreover, we already have to protect against a compromised +-- @hackage.haskell.org@ DNS entry, so an the additional +-- @_mirrors.hackage.haskell.org@ DNS entry in the same SOA doesn't +-- constitute a significant new attack vector anyway. +-- +queryBootstrapMirrors :: Verbosity -> URI -> IO [URI] + +#if defined(MIN_VERSION_resolv) || defined(MIN_VERSION_windns) +-- use @resolv@ package for performing DNS queries +queryBootstrapMirrors verbosity repoUri + | Just auth <- uriAuthority repoUri = do + let mirrorsDnsName = Name (BS.Char8.pack ("_mirrors." ++ uriRegName auth)) + + mirrors' <- try $ do + txts <- queryTXT mirrorsDnsName + evaluate (force $ extractMirrors (map snd txts)) + + mirrors <- case mirrors' of + Left e -> do + warn verbosity ("Caught exception during _mirrors lookup:"++ + displayException (e :: SomeException)) + return [] + Right v -> return v + + if null mirrors + then warn verbosity ("No mirrors found for " ++ show repoUri) + else do info verbosity ("located " ++ show (length mirrors) ++ + " mirrors for " ++ show repoUri ++ " :") + for_ mirrors $ \url -> info verbosity ("- " ++ show url) + + return mirrors + + | otherwise = return [] + +-- | Extract list of mirrors from 'queryTXT' result +extractMirrors :: [[CharStr]] -> [URI] +extractMirrors txtChunks = mapMaybe (parseURI . snd) . sort $ vals + where + vals = [ (kn,v) | CharStr e <- concat txtChunks + , Just (k,v) <- [splitRfc1464 (BS.Char8.unpack e)] + , Just kn <- [isUrlBase k] + ] + +---------------------------------------------------------------------------- +#else /* !defined(MIN_VERSION_resolv) */ +-- use external method via @nslookup@ +queryBootstrapMirrors verbosity repoUri + | Just auth <- uriAuthority repoUri = do + progdb <- configureAllKnownPrograms verbosity $ + addKnownProgram nslookupProg emptyProgramDb + + case lookupProgram nslookupProg progdb of + Nothing -> do + warn verbosity "'nslookup' tool missing - can't locate mirrors" + return [] + + Just nslookup -> do + let mirrorsDnsName = "_mirrors." ++ uriRegName auth + + mirrors' <- try $ do + out <- getProgramInvocationOutput verbosity $ + programInvocation nslookup ["-query=TXT", mirrorsDnsName] + evaluate (force $ extractMirrors mirrorsDnsName out) + + mirrors <- case mirrors' of + Left e -> do + warn verbosity ("Caught exception during _mirrors lookup:"++ + displayException (e :: SomeException)) + return [] + Right v -> return v + + if null mirrors + then warn verbosity ("No mirrors found for " ++ show repoUri) + else do info verbosity ("located " ++ show (length mirrors) ++ + " mirrors for " ++ show repoUri ++ " :") + for_ mirrors $ \url -> info verbosity ("- " ++ show url) + + return mirrors + + | otherwise = return [] + where + nslookupProg = simpleProgram "nslookup" + +-- | Extract list of mirrors from @nslookup -query=TXT@ output. +extractMirrors :: String -> String -> [URI] +extractMirrors hostname s0 = mapMaybe (parseURI . snd) . sort $ vals + where + vals = [ (kn,v) | (h,ents) <- fromMaybe [] $ parseNsLookupTxt s0 + , h == hostname + , e <- ents + , Just (k,v) <- [splitRfc1464 e] + , Just kn <- [isUrlBase k] + ] + +-- | Parse output of @nslookup -query=TXT $HOSTNAME@ tolerantly +parseNsLookupTxt :: String -> Maybe [(String,[String])] +parseNsLookupTxt = go0 [] [] + where + -- approximate grammar: + -- := { } + -- ( starts at begin of line, but may span multiple lines) + -- := ^ TAB "text =" { } + -- := string enclosed by '"'s ('\' and '"' are \-escaped) + + -- scan for ^ "text =" + go0 [] _ [] = Nothing + go0 res _ [] = Just (reverse res) + go0 res _ ('\n':xs) = go0 res [] xs + go0 res lw ('\t':'t':'e':'x':'t':' ':'=':xs) = go1 res (reverse lw) [] (dropWhile isSpace xs) + go0 res lw (x:xs) = go0 res (x:lw) xs + + -- collect at least one + go1 res lw qs ('"':xs) = case qstr "" xs of + Just (s, xs') -> go1 res lw (s:qs) (dropWhile isSpace xs') + Nothing -> Nothing -- bad quoting + go1 _ _ [] _ = Nothing -- missing qstring + go1 res lw qs xs = go0 ((lw,reverse qs):res) [] xs + + qstr _ ('\n':_) = Nothing -- We don't support unquoted LFs + qstr acc ('\\':'\\':cs) = qstr ('\\':acc) cs + qstr acc ('\\':'"':cs) = qstr ('"':acc) cs + qstr acc ('"':cs) = Just (reverse acc, cs) + qstr acc (c:cs) = qstr (c:acc) cs + qstr _ [] = Nothing + +#endif +---------------------------------------------------------------------------- + +-- | Helper used by 'extractMirrors' for extracting @urlbase@ keys from Rfc1464-encoded data +isUrlBase :: String -> Maybe Int +isUrlBase s + | ".urlbase" `isSuffixOf` s, not (null ns), all isDigit ns = readMaybe ns + | otherwise = Nothing + where + ns = take (length s - 8) s + +-- | Split a TXT string into key and value according to RFC1464. +-- Returns 'Nothing' if parsing fails. +splitRfc1464 :: String -> Maybe (String,String) +splitRfc1464 = go "" + where + go _ [] = Nothing + go acc ('`':c:cs) = go (c:acc) cs + go acc ('=':cs) = go2 (reverse acc) "" cs + go acc (c:cs) + | isSpace c = go acc cs + | otherwise = go (c:acc) cs + + go2 k acc [] = Just (k,reverse acc) + go2 _ _ ['`'] = Nothing + go2 k acc ('`':c:cs) = go2 k (c:acc) cs + go2 k acc (c:cs) = go2 k (c:acc) cs diff --git a/cabal/cabal-install/src/Distribution/Client/Security/HTTP.hs b/cabal/cabal-install/src/Distribution/Client/Security/HTTP.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Security/HTTP.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +-- | Implementation of 'HttpLib' using cabal-install's own 'HttpTransport' +module Distribution.Client.Security.HTTP (HttpLib, transportAdapter) where + +import Distribution.Solver.Compat.Prelude +import Prelude () + +-- stdlibs +import System.Directory + ( getTemporaryDirectory ) +import Network.URI + ( URI ) +import qualified Data.ByteString.Lazy as BS.L +import qualified Network.HTTP as HTTP + +-- Cabal/cabal-install +import Distribution.Verbosity + ( Verbosity ) +import Distribution.Client.HttpUtils + ( HttpTransport(..), HttpCode ) +import Distribution.Client.Utils + ( withTempFileName ) + +-- hackage-security +import Hackage.Security.Client.Repository.HttpLib (HttpLib (..)) +import qualified Hackage.Security.Client as HC +import qualified Hackage.Security.Client.Repository.HttpLib as HC +import qualified Hackage.Security.Util.Checked as HC +import qualified Hackage.Security.Util.Pretty as HC + +{------------------------------------------------------------------------------- + 'HttpLib' implementation +-------------------------------------------------------------------------------} + +-- | Translate from hackage-security's 'HttpLib' to cabal-install's 'HttpTransport' +-- +-- NOTE: The match between these two APIs is currently not perfect: +-- +-- * We don't get any response headers back from the 'HttpTransport', so we +-- don't know if the server supports range requests. For now we optimistically +-- assume that it does. +-- * The 'HttpTransport' wants to know where to place the resulting file, +-- whereas the 'HttpLib' expects an 'IO' action which streams the download; +-- the security library then makes sure that the file gets written to a +-- location which is suitable (in particular, to a temporary file in the +-- directory where the file needs to end up, so that it can "finalize" the +-- file simply by doing 'renameFile'). Right now we write the file to a +-- temporary file in the system temp directory here and then read it again +-- to pass it to the security library; this is a problem for two reasons: it +-- is a source of inefficiency; and it means that the security library cannot +-- insist on a minimum download rate (potential security attack). +-- Fixing it however would require changing the 'HttpTransport'. +transportAdapter :: Verbosity -> IO HttpTransport -> HttpLib +transportAdapter verbosity getTransport = HttpLib{ + httpGet = \headers uri callback -> do + transport <- getTransport + httpGetImpl verbosity transport headers uri callback + , httpGetRange = \headers uri range callback -> do + transport <- getTransport + getRange verbosity transport headers uri range callback + } + +httpGetImpl + :: HC.Throws HC.SomeRemoteError + => Verbosity + -> HttpTransport + -> [HC.HttpRequestHeader] -> URI + -> ([HC.HttpResponseHeader] -> HC.BodyReader -> IO a) + -> IO a +httpGetImpl verbosity transport reqHeaders uri callback = wrapCustomEx $ do + get' verbosity transport reqHeaders uri Nothing $ \code respHeaders br -> + case code of + 200 -> callback respHeaders br + _ -> HC.throwChecked $ UnexpectedResponse uri code + +getRange :: HC.Throws HC.SomeRemoteError + => Verbosity + -> HttpTransport + -> [HC.HttpRequestHeader] -> URI -> (Int, Int) + -> (HC.HttpStatus -> [HC.HttpResponseHeader] -> HC.BodyReader -> IO a) + -> IO a +getRange verbosity transport reqHeaders uri range callback = wrapCustomEx $ do + get' verbosity transport reqHeaders uri (Just range) $ \code respHeaders br -> + case code of + 200 -> callback HC.HttpStatus200OK respHeaders br + 206 -> callback HC.HttpStatus206PartialContent respHeaders br + _ -> HC.throwChecked $ UnexpectedResponse uri code + +-- | Internal generalization of 'get' and 'getRange' +get' :: Verbosity + -> HttpTransport + -> [HC.HttpRequestHeader] -> URI -> Maybe (Int, Int) + -> (HttpCode -> [HC.HttpResponseHeader] -> HC.BodyReader -> IO a) + -> IO a +get' verbosity transport reqHeaders uri mRange callback = do + tempDir <- getTemporaryDirectory + withTempFileName tempDir "transportAdapterGet" $ \temp -> do + (code, _etag) <- getHttp transport verbosity uri Nothing temp reqHeaders' + br <- HC.bodyReaderFromBS =<< BS.L.readFile temp + callback code [HC.HttpResponseAcceptRangesBytes] br + where + reqHeaders' = mkReqHeaders reqHeaders mRange + +{------------------------------------------------------------------------------- + Request headers +-------------------------------------------------------------------------------} + +mkRangeHeader :: Int -> Int -> HTTP.Header +mkRangeHeader from to = HTTP.Header HTTP.HdrRange rangeHeader + where + -- Content-Range header uses inclusive rather than exclusive bounds + -- See + rangeHeader = "bytes=" ++ show from ++ "-" ++ show (to - 1) + +mkReqHeaders :: [HC.HttpRequestHeader] -> Maybe (Int, Int) -> [HTTP.Header] +mkReqHeaders reqHeaders mRange' = concat [ + tr [] reqHeaders + , [mkRangeHeader fr to | Just (fr, to) <- [mRange]] + ] + where + -- guard against malformed range headers. + mRange = case mRange' of + Just (fr, to) | fr >= to -> Nothing + _ -> mRange' + + tr :: [(HTTP.HeaderName, [String])] -> [HC.HttpRequestHeader] -> [HTTP.Header] + tr acc [] = + concatMap finalize acc + tr acc (HC.HttpRequestMaxAge0:os) = + tr (insert HTTP.HdrCacheControl ["max-age=0"] acc) os + tr acc (HC.HttpRequestNoTransform:os) = + tr (insert HTTP.HdrCacheControl ["no-transform"] acc) os + + -- Some headers are comma-separated, others need multiple headers for + -- multiple options. + -- + -- TODO: Right we just comma-separate all of them. + finalize :: (HTTP.HeaderName, [String]) -> [HTTP.Header] + finalize (name, strs) = [HTTP.Header name (intercalate ", " (reverse strs))] + + insert :: Eq a => a -> [b] -> [(a, [b])] -> [(a, [b])] + insert x y = modifyAssocList x (++ y) + + -- modify the first matching element + modifyAssocList :: Eq a => a -> (b -> b) -> [(a, b)] -> [(a, b)] + modifyAssocList a f = go where + go [] = [] + go (p@(a', b) : xs) | a == a' = (a', f b) : xs + | otherwise = p : go xs + +{------------------------------------------------------------------------------- + Custom exceptions +-------------------------------------------------------------------------------} + +data UnexpectedResponse = UnexpectedResponse URI Int + deriving (Typeable) + +instance HC.Pretty UnexpectedResponse where + pretty (UnexpectedResponse uri code) = "Unexpected response " ++ show code + ++ " for " ++ show uri + +#if MIN_VERSION_base(4,8,0) +deriving instance Show UnexpectedResponse +instance Exception UnexpectedResponse where displayException = HC.pretty +#else +instance Show UnexpectedResponse where show = HC.pretty +instance Exception UnexpectedResponse +#endif + +wrapCustomEx :: ( ( HC.Throws UnexpectedResponse + , HC.Throws IOException + ) => IO a) + -> (HC.Throws HC.SomeRemoteError => IO a) +wrapCustomEx act = HC.handleChecked (\(ex :: UnexpectedResponse) -> go ex) + $ HC.handleChecked (\(ex :: IOException) -> go ex) + $ act + where + go ex = HC.throwChecked (HC.SomeRemoteError ex) diff --git a/cabal/cabal-install/src/Distribution/Client/Setup.hs b/cabal/cabal-install/src/Distribution/Client/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Setup.hs @@ -0,0 +1,2515 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Setup +-- Copyright : (c) David Himmelstrup 2005 +-- License : BSD-like +-- +-- Maintainer : lemmih@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- +----------------------------------------------------------------------------- +module Distribution.Client.Setup + ( globalCommand, GlobalFlags(..), defaultGlobalFlags + , RepoContext(..), withRepoContext + , configureCommand, ConfigFlags(..), configureOptions, filterConfigureFlags + , configPackageDB', configCompilerAux' + , configureExCommand, ConfigExFlags(..), defaultConfigExFlags + , buildCommand, BuildFlags(..) + , filterTestFlags + , replCommand, testCommand, benchmarkCommand, testOptions, benchmarkOptions + , configureExOptions, reconfigureCommand + , installCommand, InstallFlags(..), installOptions, defaultInstallFlags + , filterHaddockArgs, filterHaddockFlags, haddockOptions + , defaultSolver, defaultMaxBackjumps + , listCommand, ListFlags(..), listNeedsCompiler + ,UpdateFlags(..), defaultUpdateFlags + , infoCommand, InfoFlags(..) + , fetchCommand, FetchFlags(..) + , freezeCommand, FreezeFlags(..) + , genBoundsCommand + , getCommand, unpackCommand, GetFlags(..) + , checkCommand + , formatCommand + , uploadCommand, UploadFlags(..), IsCandidate(..) + , reportCommand, ReportFlags(..) + , runCommand + , initCommand, initOptions, IT.InitFlags(..) + , actAsSetupCommand, ActAsSetupFlags(..) + , userConfigCommand, UserConfigFlags(..) + , manpageCommand + , haddockCommand + , cleanCommand + , copyCommand + , registerCommand + + , liftOptions + , yesNoOpt + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude hiding (get) + +import Distribution.Client.Types.Credentials (Username (..), Password (..)) +import Distribution.Client.Types.Repo (RemoteRepo(..), LocalRepo (..)) +import Distribution.Client.Types.AllowNewer (AllowNewer(..), AllowOlder(..), RelaxDeps(..)) +import Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy + +import Distribution.Client.BuildReports.Types + ( ReportLevel(..) ) +import Distribution.Client.Dependency.Types + ( PreSolver(..) ) +import Distribution.Client.IndexUtils.ActiveRepos + ( ActiveRepos ) +import Distribution.Client.IndexUtils.IndexState + ( TotalIndexState, headTotalIndexState ) +import qualified Distribution.Client.Init.Types as IT +import qualified Distribution.Client.Init.Defaults as IT +import Distribution.Client.Targets + ( UserConstraint, readUserConstraint ) +import Distribution.Utils.NubList + ( NubList, toNubList, fromNubList) + +import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.Settings + +import Distribution.Simple.Compiler ( Compiler, PackageDB, PackageDBStack ) +import Distribution.Simple.Program (ProgramDb, defaultProgramDb) +import Distribution.Simple.Command hiding (boolOpt, boolOpt') +import qualified Distribution.Simple.Command as Command +import Distribution.Simple.Configure + ( configCompilerAuxEx, interpretPackageDbFlags, computeEffectiveProfiling ) +import qualified Distribution.Simple.Setup as Cabal +import Distribution.Simple.Flag + ( Flag(..), toFlag, flagToMaybe, flagToList, maybeToFlag + , flagElim, fromFlagOrDefault + ) +import Distribution.Simple.Setup + ( ConfigFlags(..), BuildFlags(..), ReplFlags + , TestFlags, BenchmarkFlags + , HaddockFlags(..) + , CleanFlags(..) + , CopyFlags(..), RegisterFlags(..) + , readPackageDbList, showPackageDbList + , BooleanFlag(..), optionVerbosity + , boolOpt, boolOpt', trueArg, falseArg + , optionNumJobs ) +import Distribution.Simple.InstallDirs + ( PathTemplate, InstallDirs(..) + , toPathTemplate, fromPathTemplate, combinePathTemplate ) +import Distribution.Version + ( Version, mkVersion ) +import Distribution.Types.GivenComponent + ( GivenComponent(..) ) +import Distribution.Types.PackageVersionConstraint + ( PackageVersionConstraint(..) ) +import Distribution.Types.UnqualComponentName + ( unqualComponentNameToPackageName ) +import Distribution.PackageDescription + ( BuildType(..), RepoKind(..), LibraryName(..) ) +import Distribution.System ( Platform ) +import Distribution.ReadE + ( ReadE(..), succeedReadE, parsecToReadE, parsecToReadEErr, unexpectMsgString ) +import qualified Distribution.Compat.CharParsing as P +import Distribution.Verbosity + ( lessVerbose, normal, verboseNoFlags, verboseNoTimestamp ) +import Distribution.Simple.Utils + ( wrapText ) +import Distribution.Client.GlobalFlags + ( GlobalFlags(..), defaultGlobalFlags + , RepoContext(..), withRepoContext + ) +import Distribution.Client.ManpageFlags (ManpageFlags, defaultManpageFlags, manpageOptions) +import Distribution.FieldGrammar.Newtypes (SpecVersion (..)) + +import Data.List + ( deleteFirstsBy ) +import System.FilePath + ( () ) + +globalCommand :: [Command action] -> CommandUI GlobalFlags +globalCommand commands = CommandUI { + commandName = "", + commandSynopsis = + "Command line interface to the Haskell Cabal infrastructure.", + commandUsage = \pname -> + "See http://www.haskell.org/cabal/ for more information.\n" + ++ "\n" + ++ "Usage: " ++ pname ++ " [GLOBAL FLAGS] [COMMAND [FLAGS]]\n", + commandDescription = Just $ \pname -> + let + commands' = commands ++ [commandAddAction helpCommandUI undefined] + cmdDescs = getNormalCommandDescriptions commands' + -- if new commands are added, we want them to appear even if they + -- are not included in the custom listing below. Thus, we calculate + -- the `otherCmds` list and append it under the `other` category. + -- Alternatively, a new testcase could be added that ensures that + -- the set of commands listed here is equal to the set of commands + -- that are actually available. + otherCmds = deleteFirstsBy (==) (map fst cmdDescs) + [ "help" + , "update" + , "install" + , "fetch" + , "list" + , "info" + , "user-config" + , "get" + , "unpack" + , "init" + , "configure" + , "build" + , "clean" + , "run" + , "repl" + , "test" + , "bench" + , "check" + , "sdist" + , "upload" + , "report" + , "freeze" + , "gen-bounds" + , "outdated" + , "haddock" + , "hscolour" + , "exec" + , "new-build" + , "new-configure" + , "new-repl" + , "new-freeze" + , "new-run" + , "new-test" + , "new-bench" + , "new-haddock" + , "new-exec" + , "new-update" + , "new-install" + , "new-clean" + , "new-sdist" + , "list-bin" + -- v1 commands, stateful style + , "v1-build" + , "v1-configure" + , "v1-repl" + , "v1-freeze" + , "v1-run" + , "v1-test" + , "v1-bench" + , "v1-haddock" + , "v1-exec" + , "v1-update" + , "v1-install" + , "v1-clean" + , "v1-sdist" + , "v1-doctest" + , "v1-copy" + , "v1-register" + , "v1-reconfigure" + -- v2 commands, nix-style + , "v2-build" + , "v2-configure" + , "v2-repl" + , "v2-freeze" + , "v2-run" + , "v2-test" + , "v2-bench" + , "v2-haddock" + , "v2-exec" + , "v2-update" + , "v2-install" + , "v2-clean" + , "v2-sdist" + ] + maxlen = maximum $ [length name | (name, _) <- cmdDescs] + align str = str ++ replicate (maxlen - length str) ' ' + startGroup n = " ["++n++"]" + par = "" + addCmd n = case lookup n cmdDescs of + Nothing -> "" + Just d -> " " ++ align n ++ " " ++ d + in + "Commands:\n" + ++ unlines ( + [ startGroup "global" + , addCmd "update" + , addCmd "install" + , par + , addCmd "help" + , addCmd "info" + , addCmd "list" + , addCmd "fetch" + , addCmd "user-config" + , par + , startGroup "package" + , addCmd "get" + , addCmd "unpack" + , addCmd "init" + , par + , addCmd "configure" + , addCmd "build" + , addCmd "clean" + , par + , addCmd "run" + , addCmd "repl" + , addCmd "test" + , addCmd "bench" + , par + , addCmd "check" + , addCmd "sdist" + , addCmd "upload" + , addCmd "report" + , par + , addCmd "freeze" + , addCmd "gen-bounds" + , addCmd "outdated" + , addCmd "haddock" + , addCmd "hscolour" + , addCmd "exec" + , addCmd "list-bin" + , par + , startGroup "new-style projects (forwards-compatible aliases)" + , addCmd "v2-build" + , addCmd "v2-configure" + , addCmd "v2-repl" + , addCmd "v2-run" + , addCmd "v2-test" + , addCmd "v2-bench" + , addCmd "v2-freeze" + , addCmd "v2-haddock" + , addCmd "v2-exec" + , addCmd "v2-update" + , addCmd "v2-install" + , addCmd "v2-clean" + , addCmd "v2-sdist" + , par + , startGroup "legacy command aliases" + , addCmd "v1-build" + , addCmd "v1-configure" + , addCmd "v1-repl" + , addCmd "v1-run" + , addCmd "v1-test" + , addCmd "v1-bench" + , addCmd "v1-freeze" + , addCmd "v1-haddock" + , addCmd "v1-exec" + , addCmd "v1-update" + , addCmd "v1-install" + , addCmd "v1-clean" + , addCmd "v1-sdist" + , addCmd "v1-doctest" + , addCmd "v1-copy" + , addCmd "v1-register" + , addCmd "v1-reconfigure" + ] ++ if null otherCmds then [] else par + :startGroup "other" + :[addCmd n | n <- otherCmds]) + ++ "\n" + ++ "For more information about a command use:\n" + ++ " " ++ pname ++ " COMMAND --help\n" + ++ "or " ++ pname ++ " help COMMAND\n" + ++ "\n" + ++ "To install Cabal packages from hackage use:\n" + ++ " " ++ pname ++ " install foo [--dry-run]\n" + ++ "\n" + ++ "Occasionally you need to update the list of available packages:\n" + ++ " " ++ pname ++ " update\n", + commandNotes = Nothing, + commandDefaultFlags = mempty, + commandOptions = args + } + where + args :: ShowOrParseArgs -> [OptionField GlobalFlags] + args ShowArgs = argsShown + args ParseArgs = argsShown ++ argsNotShown + + -- arguments we want to show in the help + argsShown :: [OptionField GlobalFlags] + argsShown = [ + option ['V'] ["version"] + "Print version information" + globalVersion (\v flags -> flags { globalVersion = v }) + trueArg + + ,option [] ["numeric-version"] + "Print just the version number" + globalNumericVersion (\v flags -> flags { globalNumericVersion = v }) + trueArg + + ,option [] ["config-file"] + "Set an alternate location for the config file" + globalConfigFile (\v flags -> flags { globalConfigFile = v }) + (reqArgFlag "FILE") + + ,option [] ["ignore-expiry"] + "Ignore expiry dates on signed metadata (use only in exceptional circumstances)" + globalIgnoreExpiry (\v flags -> flags { globalIgnoreExpiry = v }) + trueArg + + ,option [] ["http-transport"] + "Set a transport for http(s) requests. Accepts 'curl', 'wget', 'powershell', and 'plain-http'. (default: 'curl')" + globalHttpTransport (\v flags -> flags { globalHttpTransport = v }) + (reqArgFlag "HttpTransport") + + ,multiOption "nix" + globalNix (\v flags -> flags { globalNix = v }) + [ + noArg (Flag True) [] ["enable-nix"] + "Enable Nix integration: run commands through nix-shell if a 'shell.nix' file exists", + noArg (Flag False) [] ["disable-nix"] + "Disable Nix integration" + ] + + ,option [] ["store-dir", "storedir"] + "The location of the build store" + globalStoreDir (\v flags -> flags { globalStoreDir = v }) + (reqArgFlag "DIR") + + , option [] ["active-repositories"] + "The active package repositories (set to ':none' to disable all repositories)" + globalActiveRepos (\v flags -> flags { globalActiveRepos = v }) + (reqArg "REPOS" (parsecToReadE (\err -> "Error parsing active-repositories: " ++ err) + (toFlag `fmap` parsec)) + (map prettyShow . flagToList)) + ] + + -- arguments we don't want shown in the help + -- the remote repo flags are not useful compared to the more general "active-repositories" flag. + -- the global logs directory was only used in v1, while in v2 we have specific project config logs dirs + -- default-user-config is support for a relatively obscure workflow for v1-freeze. + argsNotShown :: [OptionField GlobalFlags] + argsNotShown = [ + option [] ["remote-repo"] + "The name and url for a remote repository" + globalRemoteRepos (\v flags -> flags { globalRemoteRepos = v }) + (reqArg' "NAME:URL" (toNubList . maybeToList . readRemoteRepo) (map showRemoteRepo . fromNubList)) + + ,option [] ["local-no-index-repo"] + "The name and a path for a local no-index repository" + globalLocalNoIndexRepos (\v flags -> flags { globalLocalNoIndexRepos = v }) + (reqArg' "NAME:PATH" (toNubList . maybeToList . readLocalRepo) (map showLocalRepo . fromNubList)) + + ,option [] ["remote-repo-cache"] + "The location where downloads from all remote repos are cached" + globalCacheDir (\v flags -> flags { globalCacheDir = v }) + (reqArgFlag "DIR") + + ,option [] ["logs-dir", "logsdir"] + "The location to put log files" + globalLogsDir (\v flags -> flags { globalLogsDir = v }) + (reqArgFlag "DIR") + + ,option [] ["default-user-config"] + "Set a location for a cabal.config file for projects without their own cabal.config freeze file." + globalConstraintsFile (\v flags -> flags {globalConstraintsFile = v}) + (reqArgFlag "FILE") + + ] + +-- ------------------------------------------------------------ +-- * Config flags +-- ------------------------------------------------------------ + +configureCommand :: CommandUI ConfigFlags +configureCommand = c + { commandName = "configure" + , commandDefaultFlags = mempty + , commandDescription = Just $ \_ -> wrapText $ + "Configure how the package is built by setting " + ++ "package (and other) flags.\n" + ++ "\n" + ++ "The configuration affects several other commands, " + ++ "including v1-build, v1-test, v1-bench, v1-run, v1-repl.\n" + , commandUsage = \pname -> + "Usage: " ++ pname ++ " v1-configure [FLAGS]\n" + , commandNotes = Just $ \pname -> + (Cabal.programFlagsDescription defaultProgramDb ++ "\n") + ++ "Examples:\n" + ++ " " ++ pname ++ " v1-configure\n" + ++ " Configure with defaults;\n" + ++ " " ++ pname ++ " v1-configure --enable-tests -fcustomflag\n" + ++ " Configure building package including tests,\n" + ++ " with some package-specific flag.\n" + } + where + c = Cabal.configureCommand defaultProgramDb + +configureOptions :: ShowOrParseArgs -> [OptionField ConfigFlags] +configureOptions = commandOptions configureCommand + +-- | Given some 'ConfigFlags' for the version of Cabal that +-- cabal-install was built with, and a target older 'Version' of +-- Cabal that we want to pass these flags to, convert the +-- flags into a form that will be accepted by the older +-- Setup script. Generally speaking, this just means filtering +-- out flags that the old Cabal library doesn't understand, but +-- in some cases it may also mean "emulating" a feature using +-- some more legacy flags. +filterConfigureFlags :: ConfigFlags -> Version -> ConfigFlags +filterConfigureFlags flags cabalLibVersion + -- NB: we expect the latest version to be the most common case, + -- so test it first. + | cabalLibVersion >= mkVersion [3,7,0] = flags_latest + -- The naming convention is that flags_version gives flags with + -- all flags *introduced* in version eliminated. + -- It is NOT the latest version of Cabal library that + -- these flags work for; version of introduction is a more + -- natural metric. + | cabalLibVersion < mkVersion [1,3,10] = flags_1_3_10 + | cabalLibVersion < mkVersion [1,10,0] = flags_1_10_0 + | cabalLibVersion < mkVersion [1,12,0] = flags_1_12_0 + | cabalLibVersion < mkVersion [1,14,0] = flags_1_14_0 + | cabalLibVersion < mkVersion [1,18,0] = flags_1_18_0 + | cabalLibVersion < mkVersion [1,19,1] = flags_1_19_1 + | cabalLibVersion < mkVersion [1,19,2] = flags_1_19_2 + | cabalLibVersion < mkVersion [1,21,1] = flags_1_21_1 + | cabalLibVersion < mkVersion [1,22,0] = flags_1_22_0 + | cabalLibVersion < mkVersion [1,22,1] = flags_1_22_1 + | cabalLibVersion < mkVersion [1,23,0] = flags_1_23_0 + | cabalLibVersion < mkVersion [1,25,0] = flags_1_25_0 + | cabalLibVersion < mkVersion [2,1,0] = flags_2_1_0 + | cabalLibVersion < mkVersion [2,5,0] = flags_2_5_0 + | cabalLibVersion < mkVersion [3,7,0] = flags_3_7_0 + | otherwise = error "the impossible just happened" -- see first guard + where + flags_latest = flags { + -- Cabal >= 1.19.1 uses '--dependency' and does not need '--constraint'. + -- Note: this is not in the wrong place. configConstraints gets + -- repopulated in flags_1_19_1 but it needs to be set to empty for + -- newer versions first. + configConstraints = [] + } + + flags_3_7_0 = flags_latest { + -- Cabal < 3.7 does not know about --extra-lib-dirs-static + configExtraLibDirsStatic = [], + + -- Cabal < 3.7 does not understand '--enable-build-info' or '--disable-build-info' + configDumpBuildInfo = NoFlag + } + + flags_2_5_0 = flags_3_7_0 { + -- Cabal < 2.5 does not understand --dependency=pkg:component=cid + -- (public sublibraries), so we convert it to the legacy + -- --dependency=pkg_or_internal_compoent=cid + configDependencies = + let convertToLegacyInternalDep (GivenComponent _ (LSubLibName cn) cid) = + Just $ GivenComponent + (unqualComponentNameToPackageName cn) + LMainLibName + cid + convertToLegacyInternalDep (GivenComponent pn LMainLibName cid) = + Just $ GivenComponent pn LMainLibName cid + in catMaybes $ convertToLegacyInternalDep <$> configDependencies flags + -- Cabal < 2.5 doesn't know about '--allow-depending-on-private-libs'. + , configAllowDependingOnPrivateLibs = NoFlag + -- Cabal < 2.5 doesn't know about '--enable/disable-executable-static'. + , configFullyStaticExe = NoFlag + } + + flags_2_1_0 = flags_2_5_0 { + -- Cabal < 2.1 doesn't know about -v +timestamp modifier + configVerbosity = fmap verboseNoTimestamp (configVerbosity flags_latest) + -- Cabal < 2.1 doesn't know about ---static + , configStaticLib = NoFlag + , configSplitSections = NoFlag + } + + flags_1_25_0 = flags_2_1_0 { + -- Cabal < 1.25.0 doesn't know about --dynlibdir. + configInstallDirs = configInstallDirs_1_25_0, + -- Cabal < 1.25 doesn't have extended verbosity syntax + configVerbosity = fmap verboseNoFlags (configVerbosity flags_2_1_0), + -- Cabal < 1.25 doesn't support --deterministic + configDeterministic = mempty + } + configInstallDirs_1_25_0 = let dirs = configInstallDirs flags in + dirs { dynlibdir = NoFlag + , libexecsubdir = NoFlag + , libexecdir = maybeToFlag $ + combinePathTemplate <$> flagToMaybe (libexecdir dirs) + <*> flagToMaybe (libexecsubdir dirs) + } + -- Cabal < 1.23 doesn't know about '--profiling-detail'. + -- Cabal < 1.23 has a hacked up version of 'enable-profiling' + -- which we shouldn't use. + (tryLibProfiling, tryExeProfiling) = computeEffectiveProfiling flags + flags_1_23_0 = flags_1_25_0 { configProfDetail = NoFlag + , configProfLibDetail = NoFlag + , configIPID = NoFlag + , configProf = NoFlag + , configProfExe = Flag tryExeProfiling + , configProfLib = Flag tryLibProfiling + } + + -- Cabal == 1.22.0.* had a discontinuity (see #5946 or e9a8d48a3adce34d) + -- due to temporary amnesia of the --*-executable-profiling flags + flags_1_22_1 = flags_1_23_0 { configDebugInfo = NoFlag + , configProfExe = NoFlag + } + + -- Cabal < 1.22 doesn't know about '--disable-debug-info'. + flags_1_22_0 = flags_1_23_0 { configDebugInfo = NoFlag } + + -- Cabal < 1.21.1 doesn't know about 'disable-relocatable' + -- Cabal < 1.21.1 doesn't know about 'enable-profiling' + -- (but we already dealt with it in flags_1_23_0) + flags_1_21_1 = + flags_1_22_0 { configRelocatable = NoFlag + , configCoverage = NoFlag + , configLibCoverage = configCoverage flags + } + -- Cabal < 1.19.2 doesn't know about '--exact-configuration' and + -- '--enable-library-stripping'. + flags_1_19_2 = flags_1_21_1 { configExactConfiguration = NoFlag + , configStripLibs = NoFlag } + -- Cabal < 1.19.1 uses '--constraint' instead of '--dependency'. + flags_1_19_1 = flags_1_19_2 { configDependencies = [] + , configConstraints = configConstraints flags } + -- Cabal < 1.18.0 doesn't know about --extra-prog-path and --sysconfdir. + flags_1_18_0 = flags_1_19_1 { configProgramPathExtra = toNubList [] + , configInstallDirs = configInstallDirs_1_18_0} + configInstallDirs_1_18_0 = (configInstallDirs flags_1_19_1) { sysconfdir = NoFlag } + -- Cabal < 1.14.0 doesn't know about '--disable-benchmarks'. + flags_1_14_0 = flags_1_18_0 { configBenchmarks = NoFlag } + -- Cabal < 1.12.0 doesn't know about '--enable/disable-executable-dynamic' + -- and '--enable/disable-library-coverage'. + flags_1_12_0 = flags_1_14_0 { configLibCoverage = NoFlag + , configDynExe = NoFlag } + -- Cabal < 1.10.0 doesn't know about '--disable-tests'. + flags_1_10_0 = flags_1_12_0 { configTests = NoFlag } + -- Cabal < 1.3.10 does not grok the '--constraints' flag. + flags_1_3_10 = flags_1_10_0 { configConstraints = [] } + +-- | Get the package database settings from 'ConfigFlags', accounting for +-- @--package-db@ and @--user@ flags. +configPackageDB' :: ConfigFlags -> PackageDBStack +configPackageDB' cfg = + interpretPackageDbFlags userInstall (configPackageDBs cfg) + where + userInstall = Cabal.fromFlagOrDefault True (configUserInstall cfg) + +-- | Configure the compiler, but reduce verbosity during this step. +configCompilerAux' :: ConfigFlags -> IO (Compiler, Platform, ProgramDb) +configCompilerAux' configFlags = + configCompilerAuxEx configFlags + --FIXME: make configCompilerAux use a sensible verbosity + { configVerbosity = fmap lessVerbose (configVerbosity configFlags) } + +-- ------------------------------------------------------------ +-- * Config extra flags +-- ------------------------------------------------------------ + +-- | cabal configure takes some extra flags beyond runghc Setup configure +-- +data ConfigExFlags = ConfigExFlags { + configCabalVersion :: Flag Version, + configAppend :: Flag Bool, + configBackup :: Flag Bool, + configExConstraints :: [(UserConstraint, ConstraintSource)], + configPreferences :: [PackageVersionConstraint], + configSolver :: Flag PreSolver, + configAllowNewer :: Maybe AllowNewer, + configAllowOlder :: Maybe AllowOlder, + configWriteGhcEnvironmentFilesPolicy + :: Flag WriteGhcEnvironmentFilesPolicy + } + deriving (Eq, Show, Generic) + +defaultConfigExFlags :: ConfigExFlags +defaultConfigExFlags = mempty { configSolver = Flag defaultSolver } + +configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags) +configureExCommand = configureCommand { + commandDefaultFlags = (mempty, defaultConfigExFlags), + commandOptions = \showOrParseArgs -> + liftOptions fst setFst + (filter ((`notElem` ["constraint", "dependency", "exact-configuration"]) + . optionName) $ configureOptions showOrParseArgs) + ++ liftOptions snd setSnd + (configureExOptions showOrParseArgs ConstraintSourceCommandlineFlag) + } + where + setFst a (_,b) = (a,b) + setSnd b (a,_) = (a,b) + +configureExOptions :: ShowOrParseArgs + -> ConstraintSource + -> [OptionField ConfigExFlags] +configureExOptions _showOrParseArgs src = + [ option [] ["cabal-lib-version"] + ("Select which version of the Cabal lib to use to build packages " + ++ "(useful for testing).") + configCabalVersion (\v flags -> flags { configCabalVersion = v }) + (reqArg "VERSION" (parsecToReadE ("Cannot parse cabal lib version: "++) + (fmap toFlag parsec)) + (map prettyShow. flagToList)) + , option "" ["append"] + "appending the new config to the old config file" + configAppend (\v flags -> flags { configAppend = v }) + (boolOpt [] []) + , option "" ["backup"] + "the backup of the config file before any alterations" + configBackup (\v flags -> flags { configBackup = v }) + (boolOpt [] []) + , option "c" ["constraint"] + "Specify constraints on a package (version, installed/source, flags)" + configExConstraints (\v flags -> flags { configExConstraints = v }) + (reqArg "CONSTRAINT" + ((\x -> [(x, src)]) `fmap` ReadE readUserConstraint) + (map $ prettyShow . fst)) + + , option [] ["preference"] + "Specify preferences (soft constraints) on the version of a package" + configPreferences (\v flags -> flags { configPreferences = v }) + (reqArg "CONSTRAINT" + (parsecToReadE (const "dependency expected") + (fmap (\x -> [x]) parsec)) + (map prettyShow)) + + , optionSolver configSolver (\v flags -> flags { configSolver = v }) + + , option [] ["allow-older"] + ("Ignore lower bounds in all dependencies or DEPS") + (fmap unAllowOlder . configAllowOlder) + (\v flags -> flags { configAllowOlder = fmap AllowOlder v}) + (optArg "DEPS" + (parsecToReadEErr unexpectMsgString relaxDepsParser) + (Just RelaxDepsAll) relaxDepsPrinter) + + , option [] ["allow-newer"] + ("Ignore upper bounds in all dependencies or DEPS") + (fmap unAllowNewer . configAllowNewer) + (\v flags -> flags { configAllowNewer = fmap AllowNewer v}) + (optArg "DEPS" + (parsecToReadEErr unexpectMsgString relaxDepsParser) + (Just RelaxDepsAll) relaxDepsPrinter) + + , option [] ["write-ghc-environment-files"] + ("Whether to create a .ghc.environment file after a successful build" + ++ " (v2-build only)") + configWriteGhcEnvironmentFilesPolicy + (\v flags -> flags { configWriteGhcEnvironmentFilesPolicy = v}) + (reqArg "always|never|ghc8.4.4+" + writeGhcEnvironmentFilesPolicyParser + writeGhcEnvironmentFilesPolicyPrinter) + ] + + +writeGhcEnvironmentFilesPolicyParser :: ReadE (Flag WriteGhcEnvironmentFilesPolicy) +writeGhcEnvironmentFilesPolicyParser = ReadE $ \case + "always" -> Right $ Flag AlwaysWriteGhcEnvironmentFiles + "never" -> Right $ Flag NeverWriteGhcEnvironmentFiles + "ghc8.4.4+" -> Right $ Flag WriteGhcEnvironmentFilesOnlyForGhc844AndNewer + policy -> Left $ "Cannot parse the GHC environment file write policy '" + <> policy <> "'" + +writeGhcEnvironmentFilesPolicyPrinter + :: Flag WriteGhcEnvironmentFilesPolicy -> [String] +writeGhcEnvironmentFilesPolicyPrinter = \case + (Flag AlwaysWriteGhcEnvironmentFiles) -> ["always"] + (Flag NeverWriteGhcEnvironmentFiles) -> ["never"] + (Flag WriteGhcEnvironmentFilesOnlyForGhc844AndNewer) -> ["ghc8.4.4+"] + NoFlag -> [] + + +relaxDepsParser :: CabalParsing m => m (Maybe RelaxDeps) +relaxDepsParser = do + rs <- P.sepBy parsec (P.char ',') + if null rs + then fail $ "empty argument list is not allowed. " + ++ "Note: use --allow-newer without the equals sign to permit all " + ++ "packages to use newer versions." + else return . Just . RelaxDepsSome . toList $ rs + +relaxDepsPrinter :: (Maybe RelaxDeps) -> [Maybe String] +relaxDepsPrinter Nothing = [] +relaxDepsPrinter (Just RelaxDepsAll) = [Nothing] +relaxDepsPrinter (Just (RelaxDepsSome pkgs)) = map (Just . prettyShow) $ pkgs + + +instance Monoid ConfigExFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup ConfigExFlags where + (<>) = gmappend + +reconfigureCommand :: CommandUI (ConfigFlags, ConfigExFlags) +reconfigureCommand + = configureExCommand + { commandName = "reconfigure" + , commandSynopsis = "Reconfigure the package if necessary." + , commandDescription = Just $ \pname -> wrapText $ + "Run `configure` with the most recently used flags, or append FLAGS " + ++ "to the most recently used configuration. " + ++ "Accepts the same flags as `" ++ pname ++ " v1-configure'. " + ++ "If the package has never been configured, the default flags are " + ++ "used." + , commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " v1-reconfigure\n" + ++ " Configure with the most recently used flags.\n" + ++ " " ++ pname ++ " v1-reconfigure -w PATH\n" + ++ " Reconfigure with the most recently used flags,\n" + ++ " but use the compiler at PATH.\n\n" + , commandUsage = usageAlternatives "v1-reconfigure" [ "[FLAGS]" ] + , commandDefaultFlags = mempty + } + +-- ------------------------------------------------------------ +-- * Build flags +-- ------------------------------------------------------------ + +buildCommand :: CommandUI BuildFlags +buildCommand = parent { + commandName = "build", + commandDescription = Just $ \_ -> wrapText $ + "Components encompass executables, tests, and benchmarks.\n" + ++ "\n" + ++ "Affected by configuration options, see `v1-configure`.\n", + commandDefaultFlags = commandDefaultFlags parent, + commandUsage = usageAlternatives "v1-build" $ + [ "[FLAGS]", "COMPONENTS [FLAGS]" ], + commandOptions = commandOptions parent + , commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " v1-build " + ++ " All the components in the package\n" + ++ " " ++ pname ++ " v1-build foo " + ++ " A component (i.e. lib, exe, test suite)\n\n" + ++ Cabal.programFlagsDescription defaultProgramDb + } + where + parent = Cabal.buildCommand defaultProgramDb + +-- ------------------------------------------------------------ +-- * Test flags +-- ------------------------------------------------------------ + +-- | Given some 'TestFlags' for the version of Cabal that +-- cabal-install was built with, and a target older 'Version' of +-- Cabal that we want to pass these flags to, convert the +-- flags into a form that will be accepted by the older +-- Setup script. Generally speaking, this just means filtering +-- out flags that the old Cabal library doesn't understand, but +-- in some cases it may also mean "emulating" a feature using +-- some more legacy flags. +filterTestFlags :: TestFlags -> Version -> TestFlags +filterTestFlags flags cabalLibVersion + -- NB: we expect the latest version to be the most common case, + -- so test it first. + | cabalLibVersion >= mkVersion [3,0,0] = flags_latest + -- The naming convention is that flags_version gives flags with + -- all flags *introduced* in version eliminated. + -- It is NOT the latest version of Cabal library that + -- these flags work for; version of introduction is a more + -- natural metric. + | cabalLibVersion < mkVersion [3,0,0] = flags_3_0_0 + | otherwise = error "the impossible just happened" -- see first guard + where + flags_latest = flags + flags_3_0_0 = flags_latest { + -- Cabal < 3.0 doesn't know about --test-wrapper + Cabal.testWrapper = NoFlag + } + +-- ------------------------------------------------------------ +-- * Repl command +-- ------------------------------------------------------------ + +replCommand :: CommandUI ReplFlags +replCommand = parent { + commandName = "repl", + commandDescription = Just $ \pname -> wrapText $ + "If the current directory contains no package, ignores COMPONENT " + ++ "parameters and opens an interactive interpreter session;\n" + ++ "\n" + ++ "Otherwise, (re)configures with the given or default flags, and " + ++ "loads the interpreter with the relevant modules. For executables, " + ++ "tests and benchmarks, loads the main module (and its " + ++ "dependencies); for libraries all exposed/other modules.\n" + ++ "\n" + ++ "The default component is the library itself, or the executable " + ++ "if that is the only component.\n" + ++ "\n" + ++ "Support for loading specific modules is planned but not " + ++ "implemented yet. For certain scenarios, `" ++ pname + ++ " v1-exec -- ghci :l Foo` may be used instead. Note that `v1-exec` will " + ++ "not (re)configure and you will have to specify the location of " + ++ "other modules, if required.\n", + commandUsage = \pname -> "Usage: " ++ pname ++ " v1-repl [COMPONENT] [FLAGS]\n", + commandDefaultFlags = commandDefaultFlags parent, + commandOptions = commandOptions parent, + commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " v1-repl " + ++ " The first component in the package\n" + ++ " " ++ pname ++ " v1-repl foo " + ++ " A named component (i.e. lib, exe, test suite)\n" + ++ " " ++ pname ++ " v1-repl --ghc-options=\"-lstdc++\"" + ++ " Specifying flags for interpreter\n" + } + where + parent = Cabal.replCommand defaultProgramDb + +-- ------------------------------------------------------------ +-- * Test command +-- ------------------------------------------------------------ + +testCommand :: CommandUI (BuildFlags, TestFlags) +testCommand = parent { + commandName = "test", + commandDescription = Just $ \pname -> wrapText $ + "If necessary (re)configures with `--enable-tests` flag and builds" + ++ " the test suite.\n" + ++ "\n" + ++ "Remember that the tests' dependencies must be installed if there" + ++ " are additional ones; e.g. with `" ++ pname + ++ " v1-install --only-dependencies --enable-tests`.\n" + ++ "\n" + ++ "By defining UserHooks in a custom Setup.hs, the package can" + ++ " define actions to be executed before and after running tests.\n", + commandUsage = usageAlternatives "v1-test" + [ "[FLAGS]", "TESTCOMPONENTS [FLAGS]" ], + commandDefaultFlags = (Cabal.defaultBuildFlags, commandDefaultFlags parent), + commandOptions = + \showOrParseArgs -> liftOptions get1 set1 + (Cabal.buildOptions progDb showOrParseArgs) + ++ + liftOptions get2 set2 + (commandOptions parent showOrParseArgs) + } + where + get1 (a,_) = a; set1 a (_,b) = (a,b) + get2 (_,b) = b; set2 b (a,_) = (a,b) + + parent = Cabal.testCommand + progDb = defaultProgramDb + +-- ------------------------------------------------------------ +-- * Bench command +-- ------------------------------------------------------------ + +benchmarkCommand :: CommandUI (BuildFlags, BenchmarkFlags) +benchmarkCommand = parent { + commandName = "bench", + commandUsage = usageAlternatives "v1-bench" + [ "[FLAGS]", "BENCHCOMPONENTS [FLAGS]" ], + commandDescription = Just $ \pname -> wrapText $ + "If necessary (re)configures with `--enable-benchmarks` flag and" + ++ " builds the benchmarks.\n" + ++ "\n" + ++ "Remember that the benchmarks' dependencies must be installed if" + ++ " there are additional ones; e.g. with `" ++ pname + ++ " v1-install --only-dependencies --enable-benchmarks`.\n" + ++ "\n" + ++ "By defining UserHooks in a custom Setup.hs, the package can" + ++ " define actions to be executed before and after running" + ++ " benchmarks.\n", + commandDefaultFlags = (Cabal.defaultBuildFlags, commandDefaultFlags parent), + commandOptions = + \showOrParseArgs -> liftOptions get1 set1 + (Cabal.buildOptions progDb showOrParseArgs) + ++ + liftOptions get2 set2 + (commandOptions parent showOrParseArgs) + } + where + get1 (a,_) = a; set1 a (_,b) = (a,b) + get2 (_,b) = b; set2 b (a,_) = (a,b) + + parent = Cabal.benchmarkCommand + progDb = defaultProgramDb + +-- ------------------------------------------------------------ +-- * Fetch command +-- ------------------------------------------------------------ + +data FetchFlags = FetchFlags { +-- fetchOutput :: Flag FilePath, + fetchDeps :: Flag Bool, + fetchDryRun :: Flag Bool, + fetchSolver :: Flag PreSolver, + fetchMaxBackjumps :: Flag Int, + fetchReorderGoals :: Flag ReorderGoals, + fetchCountConflicts :: Flag CountConflicts, + fetchFineGrainedConflicts :: Flag FineGrainedConflicts, + fetchMinimizeConflictSet :: Flag MinimizeConflictSet, + fetchIndependentGoals :: Flag IndependentGoals, + fetchPreferOldest :: Flag PreferOldest, + fetchShadowPkgs :: Flag ShadowPkgs, + fetchStrongFlags :: Flag StrongFlags, + fetchAllowBootLibInstalls :: Flag AllowBootLibInstalls, + fetchOnlyConstrained :: Flag OnlyConstrained, + fetchTests :: Flag Bool, + fetchBenchmarks :: Flag Bool, + fetchVerbosity :: Flag Verbosity + } + +defaultFetchFlags :: FetchFlags +defaultFetchFlags = FetchFlags { +-- fetchOutput = mempty, + fetchDeps = toFlag True, + fetchDryRun = toFlag False, + fetchSolver = Flag defaultSolver, + fetchMaxBackjumps = Flag defaultMaxBackjumps, + fetchReorderGoals = Flag (ReorderGoals False), + fetchCountConflicts = Flag (CountConflicts True), + fetchFineGrainedConflicts = Flag (FineGrainedConflicts True), + fetchMinimizeConflictSet = Flag (MinimizeConflictSet False), + fetchIndependentGoals = Flag (IndependentGoals False), + fetchPreferOldest = Flag (PreferOldest False), + fetchShadowPkgs = Flag (ShadowPkgs False), + fetchStrongFlags = Flag (StrongFlags False), + fetchAllowBootLibInstalls = Flag (AllowBootLibInstalls False), + fetchOnlyConstrained = Flag OnlyConstrainedNone, + fetchTests = toFlag False, + fetchBenchmarks = toFlag False, + fetchVerbosity = toFlag normal + } + +fetchCommand :: CommandUI FetchFlags +fetchCommand = CommandUI { + commandName = "fetch", + commandSynopsis = "Downloads packages for later installation.", + commandUsage = usageAlternatives "fetch" [ "[FLAGS] PACKAGES" + ], + commandDescription = Just $ \_ -> + "Note that it currently is not possible to fetch the dependencies for a\n" + ++ "package in the current directory.\n", + commandNotes = Nothing, + commandDefaultFlags = defaultFetchFlags, + commandOptions = \ showOrParseArgs -> [ + optionVerbosity fetchVerbosity (\v flags -> flags { fetchVerbosity = v }) + +-- , option "o" ["output"] +-- "Put the package(s) somewhere specific rather than the usual cache." +-- fetchOutput (\v flags -> flags { fetchOutput = v }) +-- (reqArgFlag "PATH") + + , option [] ["dependencies", "deps"] + "Resolve and fetch dependencies (default)" + fetchDeps (\v flags -> flags { fetchDeps = v }) + trueArg + + , option [] ["no-dependencies", "no-deps"] + "Ignore dependencies" + fetchDeps (\v flags -> flags { fetchDeps = v }) + falseArg + + , option [] ["dry-run"] + "Do not install anything, only print what would be installed." + fetchDryRun (\v flags -> flags { fetchDryRun = v }) + trueArg + + , option "" ["tests"] + "dependency checking and compilation for test suites listed in the package description file." + fetchTests (\v flags -> flags { fetchTests = v }) + (boolOpt [] []) + + , option "" ["benchmarks"] + "dependency checking and compilation for benchmarks listed in the package description file." + fetchBenchmarks (\v flags -> flags { fetchBenchmarks = v }) + (boolOpt [] []) + + ] ++ + + optionSolver fetchSolver (\v flags -> flags { fetchSolver = v }) : + optionSolverFlags showOrParseArgs + fetchMaxBackjumps (\v flags -> flags { fetchMaxBackjumps = v }) + fetchReorderGoals (\v flags -> flags { fetchReorderGoals = v }) + fetchCountConflicts (\v flags -> flags { fetchCountConflicts = v }) + fetchFineGrainedConflicts (\v flags -> flags { fetchFineGrainedConflicts = v }) + fetchMinimizeConflictSet (\v flags -> flags { fetchMinimizeConflictSet = v }) + fetchIndependentGoals (\v flags -> flags { fetchIndependentGoals = v }) + fetchPreferOldest (\v flags -> flags { fetchPreferOldest = v }) + fetchShadowPkgs (\v flags -> flags { fetchShadowPkgs = v }) + fetchStrongFlags (\v flags -> flags { fetchStrongFlags = v }) + fetchAllowBootLibInstalls (\v flags -> flags { fetchAllowBootLibInstalls = v }) + fetchOnlyConstrained (\v flags -> flags { fetchOnlyConstrained = v }) + + } + +-- ------------------------------------------------------------ +-- * Freeze command +-- ------------------------------------------------------------ + +data FreezeFlags = FreezeFlags { + freezeDryRun :: Flag Bool, + freezeTests :: Flag Bool, + freezeBenchmarks :: Flag Bool, + freezeSolver :: Flag PreSolver, + freezeMaxBackjumps :: Flag Int, + freezeReorderGoals :: Flag ReorderGoals, + freezeCountConflicts :: Flag CountConflicts, + freezeFineGrainedConflicts :: Flag FineGrainedConflicts, + freezeMinimizeConflictSet :: Flag MinimizeConflictSet, + freezeIndependentGoals :: Flag IndependentGoals, + freezePreferOldest :: Flag PreferOldest, + freezeShadowPkgs :: Flag ShadowPkgs, + freezeStrongFlags :: Flag StrongFlags, + freezeAllowBootLibInstalls :: Flag AllowBootLibInstalls, + freezeOnlyConstrained :: Flag OnlyConstrained, + freezeVerbosity :: Flag Verbosity + } + +defaultFreezeFlags :: FreezeFlags +defaultFreezeFlags = FreezeFlags { + freezeDryRun = toFlag False, + freezeTests = toFlag False, + freezeBenchmarks = toFlag False, + freezeSolver = Flag defaultSolver, + freezeMaxBackjumps = Flag defaultMaxBackjumps, + freezeReorderGoals = Flag (ReorderGoals False), + freezeCountConflicts = Flag (CountConflicts True), + freezeFineGrainedConflicts = Flag (FineGrainedConflicts True), + freezeMinimizeConflictSet = Flag (MinimizeConflictSet False), + freezeIndependentGoals = Flag (IndependentGoals False), + freezePreferOldest = Flag (PreferOldest False), + freezeShadowPkgs = Flag (ShadowPkgs False), + freezeStrongFlags = Flag (StrongFlags False), + freezeAllowBootLibInstalls = Flag (AllowBootLibInstalls False), + freezeOnlyConstrained = Flag OnlyConstrainedNone, + freezeVerbosity = toFlag normal + } + +freezeCommand :: CommandUI FreezeFlags +freezeCommand = CommandUI { + commandName = "freeze", + commandSynopsis = "Freeze dependencies.", + commandDescription = Just $ \_ -> wrapText $ + "Calculates a valid set of dependencies and their exact versions. " + ++ "If successful, saves the result to the file `cabal.config`.\n" + ++ "\n" + ++ "The package versions specified in `cabal.config` will be used for " + ++ "any future installs.\n" + ++ "\n" + ++ "An existing `cabal.config` is ignored and overwritten.\n", + commandNotes = Nothing, + commandUsage = usageFlags "freeze", + commandDefaultFlags = defaultFreezeFlags, + commandOptions = \ showOrParseArgs -> [ + optionVerbosity freezeVerbosity + (\v flags -> flags { freezeVerbosity = v }) + + , option [] ["dry-run"] + "Do not freeze anything, only print what would be frozen" + freezeDryRun (\v flags -> flags { freezeDryRun = v }) + trueArg + + , option [] ["tests"] + ("freezing of the dependencies of any tests suites " + ++ "in the package description file.") + freezeTests (\v flags -> flags { freezeTests = v }) + (boolOpt [] []) + + , option [] ["benchmarks"] + ("freezing of the dependencies of any benchmarks suites " + ++ "in the package description file.") + freezeBenchmarks (\v flags -> flags { freezeBenchmarks = v }) + (boolOpt [] []) + + ] ++ + + optionSolver + freezeSolver (\v flags -> flags { freezeSolver = v }): + optionSolverFlags showOrParseArgs + freezeMaxBackjumps (\v flags -> flags { freezeMaxBackjumps = v }) + freezeReorderGoals (\v flags -> flags { freezeReorderGoals = v }) + freezeCountConflicts (\v flags -> flags { freezeCountConflicts = v }) + freezeFineGrainedConflicts (\v flags -> flags { freezeFineGrainedConflicts = v }) + freezeMinimizeConflictSet (\v flags -> flags { freezeMinimizeConflictSet = v }) + freezeIndependentGoals (\v flags -> flags { freezeIndependentGoals = v }) + freezePreferOldest (\v flags -> flags { freezePreferOldest = v }) + freezeShadowPkgs (\v flags -> flags { freezeShadowPkgs = v }) + freezeStrongFlags (\v flags -> flags { freezeStrongFlags = v }) + freezeAllowBootLibInstalls (\v flags -> flags { freezeAllowBootLibInstalls = v }) + freezeOnlyConstrained (\v flags -> flags { freezeOnlyConstrained = v }) + + } + +-- ------------------------------------------------------------ +-- * 'gen-bounds' command +-- ------------------------------------------------------------ + +genBoundsCommand :: CommandUI FreezeFlags +genBoundsCommand = CommandUI { + commandName = "gen-bounds", + commandSynopsis = "Generate dependency bounds.", + commandDescription = Just $ \_ -> wrapText $ + "Generates bounds for all dependencies that do not currently have them. " + ++ "Generated bounds are printed to stdout. " + ++ "You can then paste them into your .cabal file.\n" + ++ "\n", + commandNotes = Nothing, + commandUsage = usageFlags "gen-bounds", + commandDefaultFlags = defaultFreezeFlags, + commandOptions = \ _ -> [ + optionVerbosity freezeVerbosity (\v flags -> flags { freezeVerbosity = v }) + ] + } + +-- ------------------------------------------------------------ +-- * Update command +-- ------------------------------------------------------------ + +data UpdateFlags + = UpdateFlags { + updateVerbosity :: Flag Verbosity, + updateIndexState :: Flag TotalIndexState + } deriving Generic + +defaultUpdateFlags :: UpdateFlags +defaultUpdateFlags + = UpdateFlags { + updateVerbosity = toFlag normal, + updateIndexState = toFlag headTotalIndexState + } + +-- ------------------------------------------------------------ +-- * Other commands +-- ------------------------------------------------------------ + +cleanCommand :: CommandUI CleanFlags +cleanCommand = Cabal.cleanCommand + { commandUsage = \pname -> + "Usage: " ++ pname ++ " v1-clean [FLAGS]\n" + } + +checkCommand :: CommandUI (Flag Verbosity) +checkCommand = CommandUI { + commandName = "check", + commandSynopsis = "Check the package for common mistakes.", + commandDescription = Just $ \_ -> wrapText $ + "Expects a .cabal package file in the current directory.\n" + ++ "\n" + ++ "The checks correspond to the requirements to packages on Hackage. " + ++ "If no errors and warnings are reported, Hackage will accept this " + ++ "package.\n", + commandNotes = Nothing, + commandUsage = usageFlags "check", + commandDefaultFlags = toFlag normal, + commandOptions = \_ -> [optionVerbosity id const] + } + +formatCommand :: CommandUI (Flag Verbosity) +formatCommand = CommandUI { + commandName = "format", + commandSynopsis = "Reformat the .cabal file using the standard style.", + commandDescription = Nothing, + commandNotes = Nothing, + commandUsage = usageAlternatives "format" ["[FILE]"], + commandDefaultFlags = toFlag normal, + commandOptions = \_ -> [] + } + +manpageCommand :: CommandUI ManpageFlags +manpageCommand = CommandUI { + commandName = "man", + commandSynopsis = "Outputs manpage source.", + commandDescription = Just $ \_ -> + "Output manpage source to STDOUT.\n", + commandNotes = Nothing, + commandUsage = usageFlags "man", + commandDefaultFlags = defaultManpageFlags, + commandOptions = manpageOptions + } + +runCommand :: CommandUI BuildFlags +runCommand = CommandUI { + commandName = "run", + commandSynopsis = "Builds and runs an executable.", + commandDescription = Just $ \pname -> wrapText $ + "Builds and then runs the specified executable. If no executable is " + ++ "specified, but the package contains just one executable, that one " + ++ "is built and executed.\n" + ++ "\n" + ++ "Use `" ++ pname ++ " v1-test --show-details=streaming` to run a " + ++ "test-suite and get its full output.\n", + commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " v1-run\n" + ++ " Run the only executable in the current package;\n" + ++ " " ++ pname ++ " v1-run foo -- --fooflag\n" + ++ " Works similar to `./foo --fooflag`.\n", + commandUsage = usageAlternatives "v1-run" + ["[FLAGS] [EXECUTABLE] [-- EXECUTABLE_FLAGS]"], + commandDefaultFlags = mempty, + commandOptions = commandOptions parent + } + where + parent = Cabal.buildCommand defaultProgramDb + +-- ------------------------------------------------------------ +-- * Report flags +-- ------------------------------------------------------------ + +data ReportFlags = ReportFlags { + reportUsername :: Flag Username, + reportPassword :: Flag Password, + reportVerbosity :: Flag Verbosity + } deriving Generic + +defaultReportFlags :: ReportFlags +defaultReportFlags = ReportFlags { + reportUsername = mempty, + reportPassword = mempty, + reportVerbosity = toFlag normal + } + +reportCommand :: CommandUI ReportFlags +reportCommand = CommandUI { + commandName = "report", + commandSynopsis = "Upload build reports to a remote server.", + commandDescription = Nothing, + commandNotes = Just $ \_ -> + "You can store your Hackage login in the ~/.cabal/config file\n", + commandUsage = usageAlternatives "report" ["[FLAGS]"], + commandDefaultFlags = defaultReportFlags, + commandOptions = \_ -> + [optionVerbosity reportVerbosity (\v flags -> flags { reportVerbosity = v }) + + ,option ['u'] ["username"] + "Hackage username." + reportUsername (\v flags -> flags { reportUsername = v }) + (reqArg' "USERNAME" (toFlag . Username) + (flagToList . fmap unUsername)) + + ,option ['p'] ["password"] + "Hackage password." + reportPassword (\v flags -> flags { reportPassword = v }) + (reqArg' "PASSWORD" (toFlag . Password) + (flagToList . fmap unPassword)) + ] + } + +instance Monoid ReportFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup ReportFlags where + (<>) = gmappend + +-- ------------------------------------------------------------ +-- * Get flags +-- ------------------------------------------------------------ + +data GetFlags = GetFlags { + getDestDir :: Flag FilePath, + getPristine :: Flag Bool, + getIndexState :: Flag TotalIndexState, + getActiveRepos :: Flag ActiveRepos, + getSourceRepository :: Flag (Maybe RepoKind), + getVerbosity :: Flag Verbosity + } deriving Generic + +defaultGetFlags :: GetFlags +defaultGetFlags = GetFlags { + getDestDir = mempty, + getPristine = mempty, + getIndexState = mempty, + getActiveRepos = mempty, + getSourceRepository = mempty, + getVerbosity = toFlag normal + } + +getCommand :: CommandUI GetFlags +getCommand = CommandUI { + commandName = "get", + commandSynopsis = "Download/Extract a package's source code (repository).", + commandDescription = Just $ \_ -> wrapText $ unlines descriptionOfGetCommand, + commandNotes = Just $ \pname -> unlines $ notesOfGetCommand "get" pname, + commandUsage = usagePackages "get", + commandDefaultFlags = defaultGetFlags, + commandOptions = \_ -> [ + optionVerbosity getVerbosity (\v flags -> flags { getVerbosity = v }) + + ,option "d" ["destdir"] + "Where to place the package source, defaults to the current directory." + getDestDir (\v flags -> flags { getDestDir = v }) + (reqArgFlag "PATH") + + ,option "s" ["source-repository"] + "Copy the package's source repository (ie git clone, darcs get, etc as appropriate)." + getSourceRepository (\v flags -> flags { getSourceRepository = v }) + (optArg "[head|this|...]" (parsecToReadE (const "invalid source-repository") + (fmap (toFlag . Just) parsec)) + (Flag Nothing) + (map (fmap show) . flagToList)) + + , option [] ["index-state"] + ("Use source package index state as it existed at a previous time. " ++ + "Accepts unix-timestamps (e.g. '@1474732068'), ISO8601 UTC timestamps " ++ + "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD' (default: 'HEAD'). " ++ + "This determines which package versions are available as well as " ++ + ".cabal file revision is selected (unless --pristine is used).") + getIndexState (\v flags -> flags { getIndexState = v }) + (reqArg "STATE" (parsecToReadE (const $ "index-state must be a " ++ + "unix-timestamps (e.g. '@1474732068'), " ++ + "a ISO8601 UTC timestamp " ++ + "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD'") + (toFlag `fmap` parsec)) + (flagToList . fmap prettyShow)) + + , option [] ["pristine"] + ("Unpack the original pristine tarball, rather than updating the " + ++ ".cabal file with the latest revision from the package archive.") + getPristine (\v flags -> flags { getPristine = v }) + trueArg + ] + } + +-- | List of lines describing command @get@. +descriptionOfGetCommand :: [String] +descriptionOfGetCommand = + [ "Creates a local copy of a package's source code. By default it gets the source" + , "tarball and unpacks it in a local subdirectory. Alternatively, with -s it will" + , "get the code from the source repository specified by the package." + ] + +-- | Notes for the command @get@. +notesOfGetCommand + :: String -- ^ Either @"get"@ or @"unpack"@. + -> String -- ^ E.g. @"cabal"@. + -> [String] -- ^ List of lines. +notesOfGetCommand cmd pname = + [ "Examples:" + , " " ++ unwords [ pname, cmd, "hlint" ] + , " Download the latest stable version of hlint;" + , " " ++ unwords [ pname, cmd, "lens --source-repository=head" ] + , " Download the source repository of lens (i.e. git clone from github)." + ] + +-- 'cabal unpack' is a deprecated alias for 'cabal get'. +unpackCommand :: CommandUI GetFlags +unpackCommand = getCommand + { commandName = "unpack" + , commandSynopsis = synopsis + , commandNotes = Just $ \ pname -> unlines $ + notesOfGetCommand "unpack" pname + , commandUsage = usagePackages "unpack" + } + where + synopsis = "Deprecated alias for 'get'." + +instance Monoid GetFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup GetFlags where + (<>) = gmappend + +-- ------------------------------------------------------------ +-- * List flags +-- ------------------------------------------------------------ + +data ListFlags = ListFlags + { listInstalled :: Flag Bool + , listSimpleOutput :: Flag Bool + , listCaseInsensitive :: Flag Bool + , listVerbosity :: Flag Verbosity + , listPackageDBs :: [Maybe PackageDB] + , listHcPath :: Flag FilePath + } + deriving Generic + +defaultListFlags :: ListFlags +defaultListFlags = ListFlags + { listInstalled = Flag False + , listSimpleOutput = Flag False + , listCaseInsensitive = Flag True + , listVerbosity = toFlag normal + , listPackageDBs = [] + , listHcPath = mempty + } + +listCommand :: CommandUI ListFlags +listCommand = CommandUI { + commandName = "list", + commandSynopsis = "List packages matching a search string.", + commandDescription = Just $ \_ -> wrapText $ + "List all packages, or all packages matching one of the search" + ++ " strings.\n" + ++ "\n" + ++ "Use the package database specified with --package-db. " + ++ "If not specified, use the user package database.\n", + commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " list pandoc\n" + ++ " Will find pandoc, pandoc-citeproc, pandoc-lens, ...\n", + commandUsage = usageAlternatives "list" [ "[FLAGS]" + , "[FLAGS] STRINGS"], + commandDefaultFlags = defaultListFlags, + commandOptions = const listOptions + } + +listOptions :: [OptionField ListFlags] +listOptions = + [ optionVerbosity listVerbosity (\v flags -> flags { listVerbosity = v }) + + , option [] ["installed"] + "Only print installed packages" + listInstalled (\v flags -> flags { listInstalled = v }) + trueArg + + , option [] ["simple-output"] + "Print in a easy-to-parse format" + listSimpleOutput (\v flags -> flags { listSimpleOutput = v }) + trueArg + , option ['i'] ["ignore-case"] + "Ignore case distinctions" + listCaseInsensitive (\v flags -> flags { listCaseInsensitive = v }) + (boolOpt' (['i'], ["ignore-case"]) (['I'], ["strict-case"])) + + , option "" ["package-db"] + ( "Append the given package database to the list of package" + ++ " databases used (to satisfy dependencies and register into)." + ++ " May be a specific file, 'global' or 'user'. The initial list" + ++ " is ['global'], ['global', 'user']," + ++ " depending on context. Use 'clear' to reset the list to empty." + ++ " See the user guide for details.") + listPackageDBs (\v flags -> flags { listPackageDBs = v }) + (reqArg' "DB" readPackageDbList showPackageDbList) + + , option "w" ["with-compiler"] + "give the path to a particular compiler" + listHcPath (\v flags -> flags { listHcPath = v }) + (reqArgFlag "PATH") + ] + +listNeedsCompiler :: ListFlags -> Bool +listNeedsCompiler f = + flagElim False (const True) (listHcPath f) + || fromFlagOrDefault False (listInstalled f) + +instance Monoid ListFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup ListFlags where + (<>) = gmappend + +-- ------------------------------------------------------------ +-- * Info flags +-- ------------------------------------------------------------ + +data InfoFlags = InfoFlags { + infoVerbosity :: Flag Verbosity, + infoPackageDBs :: [Maybe PackageDB] + } deriving Generic + +defaultInfoFlags :: InfoFlags +defaultInfoFlags = InfoFlags { + infoVerbosity = toFlag normal, + infoPackageDBs = [] + } + +infoCommand :: CommandUI InfoFlags +infoCommand = CommandUI { + commandName = "info", + commandSynopsis = "Display detailed information about a particular package.", + commandDescription = Just $ \_ -> wrapText $ + "Use the package database specified with --package-db. " + ++ "If not specified, use the user package database.\n", + commandNotes = Nothing, + commandUsage = usageAlternatives "info" ["[FLAGS] PACKAGES"], + commandDefaultFlags = defaultInfoFlags, + commandOptions = \_ -> [ + optionVerbosity infoVerbosity (\v flags -> flags { infoVerbosity = v }) + + , option "" ["package-db"] + ( "Append the given package database to the list of package" + ++ " databases used (to satisfy dependencies and register into)." + ++ " May be a specific file, 'global' or 'user'. The initial list" + ++ " is ['global'], ['global', 'user']," + ++ " depending on context. Use 'clear' to reset the list to empty." + ++ " See the user guide for details.") + infoPackageDBs (\v flags -> flags { infoPackageDBs = v }) + (reqArg' "DB" readPackageDbList showPackageDbList) + + ] + } + +instance Monoid InfoFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup InfoFlags where + (<>) = gmappend + +-- ------------------------------------------------------------ +-- * Install flags +-- ------------------------------------------------------------ + +-- | Install takes the same flags as configure along with a few extras. +-- +data InstallFlags = InstallFlags { + installDocumentation :: Flag Bool, + installHaddockIndex :: Flag PathTemplate, + installDest :: Flag Cabal.CopyDest, + installDryRun :: Flag Bool, + installOnlyDownload :: Flag Bool, + installMaxBackjumps :: Flag Int, + installReorderGoals :: Flag ReorderGoals, + installCountConflicts :: Flag CountConflicts, + installFineGrainedConflicts :: Flag FineGrainedConflicts, + installMinimizeConflictSet :: Flag MinimizeConflictSet, + installIndependentGoals :: Flag IndependentGoals, + installPreferOldest :: Flag PreferOldest, + installShadowPkgs :: Flag ShadowPkgs, + installStrongFlags :: Flag StrongFlags, + installAllowBootLibInstalls :: Flag AllowBootLibInstalls, + installOnlyConstrained :: Flag OnlyConstrained, + installReinstall :: Flag Bool, + installAvoidReinstalls :: Flag AvoidReinstalls, + installOverrideReinstall :: Flag Bool, + installUpgradeDeps :: Flag Bool, + installOnly :: Flag Bool, + installOnlyDeps :: Flag Bool, + installIndexState :: Flag TotalIndexState, + installRootCmd :: Flag String, + installSummaryFile :: NubList PathTemplate, + installLogFile :: Flag PathTemplate, + installBuildReports :: Flag ReportLevel, + installReportPlanningFailure :: Flag Bool, + -- Note: symlink-bindir is no longer used by v2-install and can be removed + -- when removing v1 commands + installSymlinkBinDir :: Flag FilePath, + installPerComponent :: Flag Bool, + installNumJobs :: Flag (Maybe Int), + installKeepGoing :: Flag Bool, + installRunTests :: Flag Bool, + installOfflineMode :: Flag Bool + } + deriving (Eq, Show, Generic) + +instance Binary InstallFlags + +defaultInstallFlags :: InstallFlags +defaultInstallFlags = InstallFlags { + installDocumentation = Flag False, + installHaddockIndex = Flag docIndexFile, + installDest = Flag Cabal.NoCopyDest, + installDryRun = Flag False, + installOnlyDownload = Flag False, + installMaxBackjumps = Flag defaultMaxBackjumps, + installReorderGoals = Flag (ReorderGoals False), + installCountConflicts = Flag (CountConflicts True), + installFineGrainedConflicts = Flag (FineGrainedConflicts True), + installMinimizeConflictSet = Flag (MinimizeConflictSet False), + installIndependentGoals= Flag (IndependentGoals False), + installPreferOldest = Flag (PreferOldest False), + installShadowPkgs = Flag (ShadowPkgs False), + installStrongFlags = Flag (StrongFlags False), + installAllowBootLibInstalls = Flag (AllowBootLibInstalls False), + installOnlyConstrained = Flag OnlyConstrainedNone, + installReinstall = Flag False, + installAvoidReinstalls = Flag (AvoidReinstalls False), + installOverrideReinstall = Flag False, + installUpgradeDeps = Flag False, + installOnly = Flag False, + installOnlyDeps = Flag False, + installIndexState = mempty, + installRootCmd = mempty, + installSummaryFile = mempty, + installLogFile = mempty, + installBuildReports = Flag NoReports, + installReportPlanningFailure = Flag False, + installSymlinkBinDir = mempty, + installPerComponent = Flag True, + installNumJobs = mempty, + installKeepGoing = Flag False, + installRunTests = mempty, + installOfflineMode = Flag False + } + where + docIndexFile = toPathTemplate ("$datadir" "doc" + "$arch-$os-$compiler" "index.html") + +defaultMaxBackjumps :: Int +defaultMaxBackjumps = 4000 + +defaultSolver :: PreSolver +defaultSolver = AlwaysModular + +allSolvers :: String +allSolvers = intercalate ", " (map prettyShow ([minBound .. maxBound] :: [PreSolver])) + +installCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags + , HaddockFlags, TestFlags, BenchmarkFlags + ) +installCommand = CommandUI { + commandName = "install", + commandSynopsis = "Install packages.", + commandUsage = usageAlternatives "v1-install" [ "[FLAGS]" + , "[FLAGS] PACKAGES" + ], + commandDescription = Just $ \_ -> wrapText $ + "Installs one or more packages. By default, the installed package" + ++ " will be registered in the user's package database." + ++ "\n" + ++ "If PACKAGES are specified, downloads and installs those packages." + ++ " Otherwise, install the package in the current directory (and/or its" + ++ " dependencies) (there must be exactly one .cabal file in the current" + ++ " directory).\n" + ++ "\n" + ++ "The flags to `v1-install` are saved and" + ++ " affect future commands such as `v1-build` and `v1-repl`. See the help for" + ++ " `v1-configure` for a list of commands being affected.\n" + ++ "\n" + ++ "Installed executables will by default" + ++ " be put into `~/.cabal/bin/`." + ++ " If you want installed executable to be available globally, make" + ++ " sure that the PATH environment variable contains that directory.\n" + ++ "\n", + commandNotes = Just $ \pname -> + ( case commandNotes + $ Cabal.configureCommand defaultProgramDb + of Just desc -> desc pname ++ "\n" + Nothing -> "" + ) + ++ "Examples:\n" + ++ " " ++ pname ++ " v1-install " + ++ " Package in the current directory\n" + ++ " " ++ pname ++ " v1-install foo " + ++ " Package from the hackage server\n" + ++ " " ++ pname ++ " v1-install foo-1.0 " + ++ " Specific version of a package\n" + ++ " " ++ pname ++ " v1-install 'foo < 2' " + ++ " Constrained package version\n" + ++ " " ++ pname ++ " v1-install haddock --bindir=$HOME/hask-bin/ --datadir=$HOME/hask-data/\n" + ++ " " ++ (map (const ' ') pname) + ++ " " + ++ " Change installation destination\n", + commandDefaultFlags = (mempty, mempty, mempty, mempty, mempty, mempty), + commandOptions = \showOrParseArgs -> + liftOptions get1 set1 + -- Note: [Hidden Flags] + -- hide "constraint", "dependency", and + -- "exact-configuration" from the configure options. + (filter ((`notElem` ["constraint", "dependency" + , "exact-configuration"]) + . optionName) $ + configureOptions showOrParseArgs) + ++ liftOptions get2 set2 (configureExOptions showOrParseArgs ConstraintSourceCommandlineFlag) + ++ liftOptions get3 set3 + -- hide "target-package-db" flag from the + -- install options. + (filter ((`notElem` ["target-package-db"]) + . optionName) $ + installOptions showOrParseArgs) + ++ liftOptions get4 set4 (haddockOptions showOrParseArgs) + ++ liftOptions get5 set5 (testOptions showOrParseArgs) + ++ liftOptions get6 set6 (benchmarkOptions showOrParseArgs) + } + where + get1 (a,_,_,_,_,_) = a; set1 a (_,b,c,d,e,f) = (a,b,c,d,e,f) + get2 (_,b,_,_,_,_) = b; set2 b (a,_,c,d,e,f) = (a,b,c,d,e,f) + get3 (_,_,c,_,_,_) = c; set3 c (a,b,_,d,e,f) = (a,b,c,d,e,f) + get4 (_,_,_,d,_,_) = d; set4 d (a,b,c,_,e,f) = (a,b,c,d,e,f) + get5 (_,_,_,_,e,_) = e; set5 e (a,b,c,d,_,f) = (a,b,c,d,e,f) + get6 (_,_,_,_,_,f) = f; set6 f (a,b,c,d,e,_) = (a,b,c,d,e,f) + +haddockCommand :: CommandUI HaddockFlags +haddockCommand = Cabal.haddockCommand + { commandUsage = usageAlternatives "v1-haddock" $ + [ "[FLAGS]", "COMPONENTS [FLAGS]" ] + } + +filterHaddockArgs :: [String] -> Version -> [String] +filterHaddockArgs args cabalLibVersion + | cabalLibVersion >= mkVersion [2,3,0] = args_latest + | cabalLibVersion < mkVersion [2,3,0] = args_2_3_0 + | otherwise = args_latest + where + args_latest = args + + -- Cabal < 2.3 doesn't know about per-component haddock + args_2_3_0 = [] + +filterHaddockFlags :: HaddockFlags -> Version -> HaddockFlags +filterHaddockFlags flags cabalLibVersion + | cabalLibVersion >= mkVersion [2,3,0] = flags_latest + | cabalLibVersion < mkVersion [2,3,0] = flags_2_3_0 + | otherwise = flags_latest + where + flags_latest = flags + + flags_2_3_0 = flags_latest { + -- Cabal < 2.3 doesn't know about per-component haddock + haddockArgs = [] + } + +haddockOptions :: ShowOrParseArgs -> [OptionField HaddockFlags] +haddockOptions showOrParseArgs + = [ opt { optionName = "haddock-" ++ name, + optionDescr = [ fmapOptFlags (\(_, lflags) -> ([], map ("haddock-" ++) lflags)) descr + | descr <- optionDescr opt] } + | opt <- commandOptions Cabal.haddockCommand showOrParseArgs + , let name = optionName opt + , name `elem` ["hoogle", "html", "html-location" + ,"executables", "tests", "benchmarks", "all", "internal", "css" + ,"hyperlink-source", "quickjump", "hscolour-css" + ,"contents-location", "for-hackage"] + ] + +testOptions :: ShowOrParseArgs -> [OptionField TestFlags] +testOptions showOrParseArgs + = [ opt { optionName = prefixTest name, + optionDescr = [ fmapOptFlags (\(_, lflags) -> ([], map prefixTest lflags)) descr + | descr <- optionDescr opt] } + | opt <- commandOptions Cabal.testCommand showOrParseArgs + , let name = optionName opt + , name `elem` ["log", "machine-log", "show-details", "keep-tix-files" + ,"fail-when-no-test-suites", "test-options", "test-option" + ,"test-wrapper"] + ] + where + prefixTest name | "test-" `isPrefixOf` name = name + | otherwise = "test-" ++ name + +benchmarkOptions :: ShowOrParseArgs -> [OptionField BenchmarkFlags] +benchmarkOptions showOrParseArgs + = [ opt { optionName = prefixBenchmark name, + optionDescr = [ fmapOptFlags (\(_, lflags) -> ([], map prefixBenchmark lflags)) descr + | descr <- optionDescr opt] } + | opt <- commandOptions Cabal.benchmarkCommand showOrParseArgs + , let name = optionName opt + , name `elem` ["benchmark-options", "benchmark-option"] + ] + where + prefixBenchmark name | "benchmark-" `isPrefixOf` name = name + | otherwise = "benchmark-" ++ name + +fmapOptFlags :: (OptFlags -> OptFlags) -> OptDescr a -> OptDescr a +fmapOptFlags modify (ReqArg d f p r w) = ReqArg d (modify f) p r w +fmapOptFlags modify (OptArg d f p r i w) = OptArg d (modify f) p r i w +fmapOptFlags modify (ChoiceOpt xs) = ChoiceOpt [(d, modify f, i, w) | (d, f, i, w) <- xs] +fmapOptFlags modify (BoolOpt d f1 f2 r w) = BoolOpt d (modify f1) (modify f2) r w + +installOptions :: ShowOrParseArgs -> [OptionField InstallFlags] +installOptions showOrParseArgs = + [ option "" ["documentation"] + "building of documentation" + installDocumentation (\v flags -> flags { installDocumentation = v }) + (boolOpt [] []) + + , option [] ["doc-index-file"] + "A central index of haddock API documentation (template cannot use $pkgid)" + installHaddockIndex (\v flags -> flags { installHaddockIndex = v }) + (reqArg' "TEMPLATE" (toFlag.toPathTemplate) + (flagToList . fmap fromPathTemplate)) + + , option [] ["dry-run"] + "Do not install anything, only print what would be installed." + installDryRun (\v flags -> flags { installDryRun = v }) + trueArg + + , option [] ["only-download"] + "Do not build anything, only fetch the packages." + installOnlyDownload (\v flags -> flags { installOnlyDownload = v }) + trueArg + + , option "" ["target-package-db"] + "package database to install into. Required when using ${pkgroot} prefix." + installDest (\v flags -> flags { installDest = v }) + (reqArg "DATABASE" (succeedReadE (Flag . Cabal.CopyToDb)) + (\f -> case f of Flag (Cabal.CopyToDb p) -> [p]; _ -> [])) + ] ++ + + optionSolverFlags showOrParseArgs + installMaxBackjumps (\v flags -> flags { installMaxBackjumps = v }) + installReorderGoals (\v flags -> flags { installReorderGoals = v }) + installCountConflicts (\v flags -> flags { installCountConflicts = v }) + installFineGrainedConflicts (\v flags -> flags { installFineGrainedConflicts = v }) + installMinimizeConflictSet (\v flags -> flags { installMinimizeConflictSet = v }) + installIndependentGoals (\v flags -> flags { installIndependentGoals = v }) + installPreferOldest (\v flags -> flags { installPreferOldest = v }) + installShadowPkgs (\v flags -> flags { installShadowPkgs = v }) + installStrongFlags (\v flags -> flags { installStrongFlags = v }) + installAllowBootLibInstalls (\v flags -> flags { installAllowBootLibInstalls = v }) + installOnlyConstrained (\v flags -> flags { installOnlyConstrained = v }) ++ + + [ option [] ["reinstall"] + "Install even if it means installing the same version again." + installReinstall (\v flags -> flags { installReinstall = v }) + (yesNoOpt showOrParseArgs) + + , option [] ["avoid-reinstalls"] + "Do not select versions that would destructively overwrite installed packages." + (fmap asBool . installAvoidReinstalls) + (\v flags -> flags { installAvoidReinstalls = fmap AvoidReinstalls v }) + (yesNoOpt showOrParseArgs) + + , option [] ["force-reinstalls"] + "Reinstall packages even if they will most likely break other installed packages." + installOverrideReinstall (\v flags -> flags { installOverrideReinstall = v }) + (yesNoOpt showOrParseArgs) + + , option [] ["upgrade-dependencies"] + "Pick the latest version for all dependencies, rather than trying to pick an installed version." + installUpgradeDeps (\v flags -> flags { installUpgradeDeps = v }) + (yesNoOpt showOrParseArgs) + + , option [] ["only-dependencies"] + "Install only the dependencies necessary to build the given packages" + installOnlyDeps (\v flags -> flags { installOnlyDeps = v }) + (yesNoOpt showOrParseArgs) + + , option [] ["dependencies-only"] + "A synonym for --only-dependencies" + installOnlyDeps (\v flags -> flags { installOnlyDeps = v }) + (yesNoOpt showOrParseArgs) + + , option [] ["index-state"] + ("Use source package index state as it existed at a previous time. " ++ + "Accepts unix-timestamps (e.g. '@1474732068'), ISO8601 UTC timestamps " ++ + "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD' (default: 'HEAD').") + installIndexState (\v flags -> flags { installIndexState = v }) + (reqArg "STATE" (parsecToReadE (const $ "index-state must be a " ++ + "unix-timestamps (e.g. '@1474732068'), " ++ + "a ISO8601 UTC timestamp " ++ + "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD'") + (toFlag `fmap` parsec)) + (flagToList . fmap prettyShow)) + + , option [] ["root-cmd"] + "(No longer supported, do not use.)" + installRootCmd (\v flags -> flags { installRootCmd = v }) + (reqArg' "COMMAND" toFlag flagToList) + + , option [] ["symlink-bindir"] + "Add symlinks to installed executables into this directory." + installSymlinkBinDir (\v flags -> flags { installSymlinkBinDir = v }) + (reqArgFlag "DIR") + + , option [] ["build-summary"] + "Save build summaries to file (name template can use $pkgid, $compiler, $os, $arch)" + installSummaryFile (\v flags -> flags { installSummaryFile = v }) + (reqArg' "TEMPLATE" (\x -> toNubList [toPathTemplate x]) (map fromPathTemplate . fromNubList)) + + , option [] ["build-log"] + "Log all builds to file (name template can use $pkgid, $compiler, $os, $arch)" + installLogFile (\v flags -> flags { installLogFile = v }) + (reqArg' "TEMPLATE" (toFlag.toPathTemplate) + (flagToList . fmap fromPathTemplate)) + + , option [] ["remote-build-reporting"] + "Generate build reports to send to a remote server (none, anonymous or detailed)." + installBuildReports (\v flags -> flags { installBuildReports = v }) + (reqArg "LEVEL" (parsecToReadE (const $ "report level must be 'none', " + ++ "'anonymous' or 'detailed'") + (toFlag `fmap` parsec)) + (flagToList . fmap prettyShow)) + + , option [] ["report-planning-failure"] + "Generate build reports when the dependency solver fails. This is used by the Hackage build bot." + installReportPlanningFailure (\v flags -> flags { installReportPlanningFailure = v }) + trueArg + + , option "" ["per-component"] + "Per-component builds when possible" + installPerComponent (\v flags -> flags { installPerComponent = v }) + (boolOpt [] []) + + , option [] ["run-tests"] + "Run package test suites during installation." + installRunTests (\v flags -> flags { installRunTests = v }) + trueArg + + , optionNumJobs + installNumJobs (\v flags -> flags { installNumJobs = v }) + + , option [] ["keep-going"] + "After a build failure, continue to build other unaffected packages." + installKeepGoing (\v flags -> flags { installKeepGoing = v }) + trueArg + + , option [] ["offline"] + "Don't download packages from the Internet." + installOfflineMode (\v flags -> flags { installOfflineMode = v }) + (yesNoOpt showOrParseArgs) + + ] ++ case showOrParseArgs of -- TODO: remove when "cabal install" + -- avoids + ParseArgs -> + [ option [] ["only"] + "Only installs the package in the current directory." + installOnly (\v flags -> flags { installOnly = v }) + trueArg ] + _ -> [] + + +instance Monoid InstallFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup InstallFlags where + (<>) = gmappend + +-- ------------------------------------------------------------ +-- * Upload flags +-- ------------------------------------------------------------ + +-- | Is this a candidate package or a package to be published? +data IsCandidate = IsCandidate | IsPublished + deriving Eq + +data UploadFlags = UploadFlags { + uploadCandidate :: Flag IsCandidate, + uploadDoc :: Flag Bool, + uploadUsername :: Flag Username, + uploadPassword :: Flag Password, + uploadPasswordCmd :: Flag [String], + uploadVerbosity :: Flag Verbosity + } deriving Generic + +defaultUploadFlags :: UploadFlags +defaultUploadFlags = UploadFlags { + uploadCandidate = toFlag IsCandidate, + uploadDoc = toFlag False, + uploadUsername = mempty, + uploadPassword = mempty, + uploadPasswordCmd = mempty, + uploadVerbosity = toFlag normal + } + +uploadCommand :: CommandUI UploadFlags +uploadCommand = CommandUI { + commandName = "upload", + commandSynopsis = "Uploads source packages or documentation to Hackage.", + commandDescription = Nothing, + commandNotes = Just $ \_ -> + "You can store your Hackage login in the ~/.cabal/config file\n" + ++ relevantConfigValuesText ["username", "password", "password-command"], + commandUsage = \pname -> + "Usage: " ++ pname ++ " upload [FLAGS] TARFILES\n", + commandDefaultFlags = defaultUploadFlags, + commandOptions = \_ -> + [optionVerbosity uploadVerbosity + (\v flags -> flags { uploadVerbosity = v }) + + ,option [] ["publish"] + "Publish the package instead of uploading it as a candidate." + uploadCandidate (\v flags -> flags { uploadCandidate = v }) + (noArg (Flag IsPublished)) + + ,option ['d'] ["documentation"] + ("Upload documentation instead of a source package. " + ++ "By default, this uploads documentation for a package candidate. " + ++ "To upload documentation for " + ++ "a published package, combine with --publish.") + uploadDoc (\v flags -> flags { uploadDoc = v }) + trueArg + + ,option ['u'] ["username"] + "Hackage username." + uploadUsername (\v flags -> flags { uploadUsername = v }) + (reqArg' "USERNAME" (toFlag . Username) + (flagToList . fmap unUsername)) + + ,option ['p'] ["password"] + "Hackage password." + uploadPassword (\v flags -> flags { uploadPassword = v }) + (reqArg' "PASSWORD" (toFlag . Password) + (flagToList . fmap unPassword)) + + ,option ['P'] ["password-command"] + "Command to get Hackage password." + uploadPasswordCmd (\v flags -> flags { uploadPasswordCmd = v }) + (reqArg' "PASSWORD" (Flag . words) (fromMaybe [] . flagToMaybe)) + ] + } + +instance Monoid UploadFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup UploadFlags where + (<>) = gmappend + +-- ------------------------------------------------------------ +-- * Init flags +-- ------------------------------------------------------------ + +initCommand :: CommandUI IT.InitFlags +initCommand = CommandUI { + commandName = "init", + commandSynopsis = "Create a new cabal package.", + commandDescription = Just $ \_ -> wrapText $ + "Create a .cabal, CHANGELOG.md, minimal initial Haskell code and optionally a LICENSE file.\n" + ++ "\n" + ++ "Calling init with no arguments runs interactive mode, " + ++ "which will try to guess as much as possible and prompt you for the rest.\n" + ++ "Non-interactive mode can be invoked by the -n/--non-interactive flag, " + ++ "which will let you specify the options via flags and will use the defaults for the rest.\n" + ++ "It is also possible to call init with a single argument, which denotes the project's desired " + ++ "root directory.\n", + commandNotes = Nothing, + commandUsage = \pname -> + "Usage: " ++ pname ++ " init [PROJECT ROOT] [FLAGS]\n", + commandDefaultFlags = IT.defaultInitFlags, + commandOptions = initOptions + } + +initOptions :: ShowOrParseArgs -> [OptionField IT.InitFlags] +initOptions _ = + [ option ['i'] ["interactive"] + "interactive mode." + IT.interactive (\v flags -> flags { IT.interactive = v }) + (boolOpt' (['i'], ["interactive"]) (['n'], ["non-interactive"])) + + , option ['q'] ["quiet"] + "Do not generate log messages to stdout." + IT.quiet (\v flags -> flags { IT.quiet = v }) + trueArg + + , option [] ["no-comments"] + "Do not generate explanatory comments in the .cabal file." + IT.noComments (\v flags -> flags { IT.noComments = v }) + trueArg + + , option ['m'] ["minimal"] + "Generate a minimal .cabal file, that is, do not include extra empty fields. Also implies --no-comments." + IT.minimal (\v flags -> flags { IT.minimal = v }) + trueArg + + , option [] ["overwrite"] + "Overwrite any existing .cabal, LICENSE, or Setup.hs files without warning." + IT.overwrite (\v flags -> flags { IT.overwrite = v }) + trueArg + + , option [] ["package-dir", "packagedir"] + "Root directory of the package (default = current directory)." + IT.packageDir (\v flags -> flags { IT.packageDir = v }) + (reqArgFlag "DIRECTORY") + + , option ['p'] ["package-name"] + "Name of the Cabal package to create." + IT.packageName (\v flags -> flags { IT.packageName = v }) + (reqArg "PACKAGE" (parsecToReadE ("Cannot parse package name: "++) + (toFlag `fmap` parsec)) + (flagToList . fmap prettyShow)) + + , option [] ["version"] + "Initial version of the package." + IT.version (\v flags -> flags { IT.version = v }) + (reqArg "VERSION" (parsecToReadE ("Cannot parse package version: "++) + (toFlag `fmap` parsec)) + (flagToList . fmap prettyShow)) + + , option [] ["cabal-version"] + "Version of the Cabal specification." + IT.cabalVersion (\v flags -> flags { IT.cabalVersion = v }) + (reqArg "CABALSPECVERSION" (parsecToReadE ("Cannot parse Cabal specification version: "++) + (fmap (toFlag . getSpecVersion) parsec)) + (flagToList . fmap (prettyShow . SpecVersion))) + + , option ['l'] ["license"] + "Project license." + IT.license (\v flags -> flags { IT.license = v }) + (reqArg "LICENSE" (parsecToReadE ("Cannot parse license: "++) + (toFlag `fmap` parsec)) + (flagToList . fmap prettyShow)) + + , option ['a'] ["author"] + "Name of the project's author." + IT.author (\v flags -> flags { IT.author = v }) + (reqArgFlag "NAME") + + , option ['e'] ["email"] + "Email address of the maintainer." + IT.email (\v flags -> flags { IT.email = v }) + (reqArgFlag "EMAIL") + + , option ['u'] ["homepage"] + "Project homepage and/or repository." + IT.homepage (\v flags -> flags { IT.homepage = v }) + (reqArgFlag "URL") + + , option ['s'] ["synopsis"] + "Short project synopsis." + IT.synopsis (\v flags -> flags { IT.synopsis = v }) + (reqArgFlag "TEXT") + + , option ['c'] ["category"] + "Project category." + IT.category (\v flags -> flags { IT.category = v }) + (reqArgFlag "CATEGORY") + + , option ['x'] ["extra-source-file"] + "Extra source file to be distributed with tarball." + IT.extraSrc (\v flags -> flags { IT.extraSrc = v }) + (reqArg' "FILE" (Flag . (:[])) + (fromFlagOrDefault [])) + , option [] ["extra-doc-file"] + "Extra doc file to be distributed with tarball." + IT.extraDoc (\v flags -> flags { IT.extraDoc = v }) + (reqArg' "FILE" (Flag . (:[])) (fromFlagOrDefault [])) + + , option [] ["lib", "is-library"] + "Build a library." + IT.packageType (\v flags -> flags { IT.packageType = v }) + (noArg (Flag IT.Library)) + + , option [] ["exe", "is-executable"] + "Build an executable." + IT.packageType + (\v flags -> flags { IT.packageType = v }) + (noArg (Flag IT.Executable)) + + , option [] ["libandexe", "is-libandexe"] + "Build a library and an executable." + IT.packageType + (\v flags -> flags { IT.packageType = v }) + (noArg (Flag IT.LibraryAndExecutable)) + + , option [] ["tests"] + "Generate a test suite, standalone or for a library." + IT.initializeTestSuite + (\v flags -> flags { IT.initializeTestSuite = v }) + trueArg + + , option [] ["test-dir"] + "Directory containing tests." + IT.testDirs (\v flags -> flags { IT.testDirs = v }) + (reqArg' "DIR" (Flag . (:[])) + (fromFlagOrDefault [])) + + , option [] ["simple"] + "Create a simple project with sensible defaults." + IT.simpleProject + (\v flags -> flags { IT.simpleProject = v }) + trueArg + + , option [] ["main-is"] + "Specify the main module." + IT.mainIs + (\v flags -> flags { IT.mainIs = v }) + (reqArgFlag "FILE") + + , option [] ["language"] + "Specify the default language." + IT.language + (\v flags -> flags { IT.language = v }) + (reqArg "LANGUAGE" (parsecToReadE ("Cannot parse language: "++) + (toFlag `fmap` parsec)) + (flagToList . fmap prettyShow)) + + , option ['o'] ["expose-module"] + "Export a module from the package." + IT.exposedModules + (\v flags -> flags { IT.exposedModules = v }) + (reqArg "MODULE" (parsecToReadE ("Cannot parse module name: "++) + (Flag . (:[]) <$> parsec)) + (flagElim [] (fmap prettyShow))) + + , option [] ["extension"] + "Use a LANGUAGE extension (in the other-extensions field)." + IT.otherExts + (\v flags -> flags { IT.otherExts = v }) + (reqArg "EXTENSION" (parsecToReadE ("Cannot parse extension: "++) + (Flag . (:[]) <$> parsec)) + (flagElim [] (fmap prettyShow))) + + , option ['d'] ["dependency"] + "Package dependency." + IT.dependencies (\v flags -> flags { IT.dependencies = v }) + (reqArg "PACKAGE" (parsecToReadE ("Cannot parse dependency: "++) + (Flag . (:[]) <$> parsec)) + (flagElim [] (fmap prettyShow))) + + , option [] ["application-dir"] + "Directory containing package application executable." + IT.applicationDirs (\v flags -> flags { IT.applicationDirs = v}) + (reqArg' "DIR" (Flag . (:[])) + (fromFlagOrDefault [])) + + , option [] ["source-dir", "sourcedir"] + "Directory containing package library source." + IT.sourceDirs (\v flags -> flags { IT.sourceDirs = v }) + (reqArg' "DIR" (Flag. (:[])) + (fromFlagOrDefault [])) + + , option [] ["build-tool"] + "Required external build tool." + IT.buildTools (\v flags -> flags { IT.buildTools = v }) + (reqArg' "TOOL" (Flag . (:[])) + (fromFlagOrDefault [])) + + , option "w" ["with-compiler"] + "give the path to a particular compiler. For 'init', this flag is used \ + \to set the bounds inferred for the 'base' package." + IT.initHcPath (\v flags -> flags { IT.initHcPath = v }) + (reqArgFlag "PATH") + + , optionVerbosity IT.initVerbosity (\v flags -> flags { IT.initVerbosity = v }) + ] + +-- ------------------------------------------------------------ +-- * Copy and Register +-- ------------------------------------------------------------ + +copyCommand :: CommandUI CopyFlags +copyCommand = Cabal.copyCommand + { commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " v1-copy " + ++ " All the components in the package\n" + ++ " " ++ pname ++ " v1-copy foo " + ++ " A component (i.e. lib, exe, test suite)" + , commandUsage = usageAlternatives "v1-copy" $ + [ "[FLAGS]" + , "COMPONENTS [FLAGS]" + ] + } + +registerCommand :: CommandUI RegisterFlags +registerCommand = Cabal.registerCommand + { commandUsage = \pname -> "Usage: " ++ pname ++ " v1-register [FLAGS]\n" } + +-- ------------------------------------------------------------ +-- * ActAsSetup flags +-- ------------------------------------------------------------ + +data ActAsSetupFlags = ActAsSetupFlags { + actAsSetupBuildType :: Flag BuildType +} deriving Generic + +defaultActAsSetupFlags :: ActAsSetupFlags +defaultActAsSetupFlags = ActAsSetupFlags { + actAsSetupBuildType = toFlag Simple +} + +actAsSetupCommand :: CommandUI ActAsSetupFlags +actAsSetupCommand = CommandUI { + commandName = "act-as-setup", + commandSynopsis = "Run as-if this was a Setup.hs", + commandDescription = Nothing, + commandNotes = Nothing, + commandUsage = \pname -> + "Usage: " ++ pname ++ " act-as-setup\n", + commandDefaultFlags = defaultActAsSetupFlags, + commandOptions = \_ -> + [option "" ["build-type"] + "Use the given build type." + actAsSetupBuildType (\v flags -> flags { actAsSetupBuildType = v }) + (reqArg "BUILD-TYPE" (parsecToReadE ("Cannot parse build type: "++) + (fmap toFlag parsec)) + (map prettyShow . flagToList)) + ] +} + +instance Monoid ActAsSetupFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup ActAsSetupFlags where + (<>) = gmappend + +-- ------------------------------------------------------------ +-- * UserConfig flags +-- ------------------------------------------------------------ + +data UserConfigFlags = UserConfigFlags { + userConfigVerbosity :: Flag Verbosity, + userConfigForce :: Flag Bool, + userConfigAppendLines :: Flag [String] + } deriving Generic + +instance Monoid UserConfigFlags where + mempty = UserConfigFlags { + userConfigVerbosity = toFlag normal, + userConfigForce = toFlag False, + userConfigAppendLines = toFlag [] + } + mappend = (<>) + +instance Semigroup UserConfigFlags where + (<>) = gmappend + +userConfigCommand :: CommandUI UserConfigFlags +userConfigCommand = CommandUI { + commandName = "user-config", + commandSynopsis = "Display and update the user's global cabal configuration.", + commandDescription = Just $ \_ -> wrapText $ + "When upgrading cabal, the set of configuration keys and their default" + ++ " values may change. This command provides means to merge the existing" + ++ " config in ~/.cabal/config" + ++ " (i.e. all bindings that are actually defined and not commented out)" + ++ " and the default config of the new version.\n" + ++ "\n" + ++ "init: Creates a new config file at either ~/.cabal/config or as" + ++ " specified by --config-file, if given. An existing file won't be " + ++ " overwritten unless -f or --force is given.\n" + ++ "diff: Shows a pseudo-diff of the user's ~/.cabal/config file and" + ++ " the default configuration that would be created by cabal if the" + ++ " config file did not exist.\n" + ++ "update: Applies the pseudo-diff to the configuration that would be" + ++ " created by default, and write the result back to ~/.cabal/config.", + + commandNotes = Nothing, + commandUsage = usageAlternatives "user-config" ["init", "diff", "update"], + commandDefaultFlags = mempty, + commandOptions = \ _ -> [ + optionVerbosity userConfigVerbosity (\v flags -> flags { userConfigVerbosity = v }) + , option ['f'] ["force"] + "Overwrite the config file if it already exists." + userConfigForce (\v flags -> flags { userConfigForce = v }) + trueArg + , option ['a'] ["augment"] + "Additional setting to augment the config file (replacing a previous setting if it existed)." + userConfigAppendLines (\v flags -> flags + {userConfigAppendLines = + Flag $ concat (flagToList (userConfigAppendLines flags) ++ flagToList v)}) + (reqArg' "CONFIGLINE" (Flag . (:[])) (fromMaybe [] . flagToMaybe)) + ] + } + + +-- ------------------------------------------------------------ +-- * GetOpt Utils +-- ------------------------------------------------------------ + +reqArgFlag :: ArgPlaceHolder -> + MkOptDescr (b -> Flag String) (Flag String -> b -> b) b +reqArgFlag ad = reqArg ad (succeedReadE Flag) flagToList + +liftOptions :: (b -> a) -> (a -> b -> b) + -> [OptionField a] -> [OptionField b] +liftOptions get set = map (liftOption get set) + +yesNoOpt :: ShowOrParseArgs -> MkOptDescr (b -> Flag Bool) (Flag Bool -> b -> b) b +yesNoOpt ShowArgs sf lf = trueArg sf lf +yesNoOpt _ sf lf = Command.boolOpt' flagToMaybe Flag (sf, lf) ([], map ("no-" ++) lf) sf lf + +optionSolver :: (flags -> Flag PreSolver) + -> (Flag PreSolver -> flags -> flags) + -> OptionField flags +optionSolver get set = + option [] ["solver"] + ("Select dependency solver to use (default: " ++ prettyShow defaultSolver ++ "). Choices: " ++ allSolvers ++ ".") + get set + (reqArg "SOLVER" (parsecToReadE (const $ "solver must be one of: " ++ allSolvers) + (toFlag `fmap` parsec)) + (flagToList . fmap prettyShow)) + +optionSolverFlags :: ShowOrParseArgs + -> (flags -> Flag Int ) -> (Flag Int -> flags -> flags) + -> (flags -> Flag ReorderGoals) -> (Flag ReorderGoals -> flags -> flags) + -> (flags -> Flag CountConflicts) -> (Flag CountConflicts -> flags -> flags) + -> (flags -> Flag FineGrainedConflicts) -> (Flag FineGrainedConflicts -> flags -> flags) + -> (flags -> Flag MinimizeConflictSet) -> (Flag MinimizeConflictSet -> flags -> flags) + -> (flags -> Flag IndependentGoals) -> (Flag IndependentGoals -> flags -> flags) + -> (flags -> Flag PreferOldest) -> (Flag PreferOldest -> flags -> flags) + -> (flags -> Flag ShadowPkgs) -> (Flag ShadowPkgs -> flags -> flags) + -> (flags -> Flag StrongFlags) -> (Flag StrongFlags -> flags -> flags) + -> (flags -> Flag AllowBootLibInstalls) -> (Flag AllowBootLibInstalls -> flags -> flags) + -> (flags -> Flag OnlyConstrained) -> (Flag OnlyConstrained -> flags -> flags) + -> [OptionField flags] +optionSolverFlags showOrParseArgs getmbj setmbj getrg setrg getcc setcc + getfgc setfgc getmc setmc getig setig getpo setpo getsip setsip + getstrfl setstrfl getib setib getoc setoc = + [ option [] ["max-backjumps"] + ("Maximum number of backjumps allowed while solving (default: " ++ show defaultMaxBackjumps ++ "). Use a negative number to enable unlimited backtracking. Use 0 to disable backtracking completely.") + getmbj setmbj + (reqArg "NUM" (parsecToReadE ("Cannot parse number: "++) (fmap toFlag P.signedIntegral)) + (map show . flagToList)) + , option [] ["reorder-goals"] + "Try to reorder goals according to certain heuristics. Slows things down on average, but may make backtracking faster for some packages." + (fmap asBool . getrg) + (setrg . fmap ReorderGoals) + (yesNoOpt showOrParseArgs) + , option [] ["count-conflicts"] + "Try to speed up solving by preferring goals that are involved in a lot of conflicts (default)." + (fmap asBool . getcc) + (setcc . fmap CountConflicts) + (yesNoOpt showOrParseArgs) + , option [] ["fine-grained-conflicts"] + "Skip a version of a package if it does not resolve the conflicts encountered in the last version, as a solver optimization (default)." + (fmap asBool . getfgc) + (setfgc . fmap FineGrainedConflicts) + (yesNoOpt showOrParseArgs) + , option [] ["minimize-conflict-set"] + ("When there is no solution, try to improve the error message by finding " + ++ "a minimal conflict set (default: false). May increase run time " + ++ "significantly.") + (fmap asBool . getmc) + (setmc . fmap MinimizeConflictSet) + (yesNoOpt showOrParseArgs) + , option [] ["independent-goals"] + "Treat several goals on the command line as independent. If several goals depend on the same package, different versions can be chosen." + (fmap asBool . getig) + (setig . fmap IndependentGoals) + (yesNoOpt showOrParseArgs) + , option [] ["prefer-oldest"] + "Prefer the oldest (instead of the latest) versions of packages available. Useful to determine lower bounds in the build-depends section." + (fmap asBool . getpo) + (setpo . fmap PreferOldest) + (yesNoOpt showOrParseArgs) + , option [] ["shadow-installed-packages"] + "If multiple package instances of the same version are installed, treat all but one as shadowed." + (fmap asBool . getsip) + (setsip . fmap ShadowPkgs) + (yesNoOpt showOrParseArgs) + , option [] ["strong-flags"] + "Do not defer flag choices (this used to be the default in cabal-install <= 1.20)." + (fmap asBool . getstrfl) + (setstrfl . fmap StrongFlags) + (yesNoOpt showOrParseArgs) + , option [] ["allow-boot-library-installs"] + "Allow cabal to install base, ghc-prim, integer-simple, integer-gmp, and template-haskell." + (fmap asBool . getib) + (setib . fmap AllowBootLibInstalls) + (yesNoOpt showOrParseArgs) + , option [] ["reject-unconstrained-dependencies"] + "Require these packages to have constraints on them if they are to be selected (default: none)." + getoc + setoc + (reqArg "none|all" + (parsecToReadE + (const "reject-unconstrained-dependencies must be 'none' or 'all'") + (toFlag `fmap` parsec)) + (flagToList . fmap prettyShow)) + + ] + +usagePackages :: String -> String -> String +usagePackages name pname = + "Usage: " ++ pname ++ " " ++ name ++ " [PACKAGES]\n" + +usageFlags :: String -> String -> String +usageFlags name pname = + "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n" + +-- ------------------------------------------------------------ +-- * Repo helpers +-- ------------------------------------------------------------ + +showRemoteRepo :: RemoteRepo -> String +showRemoteRepo = prettyShow + +readRemoteRepo :: String -> Maybe RemoteRepo +readRemoteRepo = simpleParsec + +showLocalRepo :: LocalRepo -> String +showLocalRepo = prettyShow + +readLocalRepo :: String -> Maybe LocalRepo +readLocalRepo = simpleParsec + +-- ------------------------------------------------------------ +-- * Helpers for Documentation +-- ------------------------------------------------------------ + +relevantConfigValuesText :: [String] -> String +relevantConfigValuesText vs = + "Relevant global configuration keys:\n" + ++ concat [" " ++ v ++ "\n" |v <- vs] diff --git a/cabal/cabal-install/src/Distribution/Client/SetupWrapper.hs b/cabal/cabal-install/src/Distribution/Client/SetupWrapper.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/SetupWrapper.hs @@ -0,0 +1,919 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.SetupWrapper +-- Copyright : (c) The University of Glasgow 2006, +-- Duncan Coutts 2008 +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : alpha +-- Portability : portable +-- +-- An interface to building and installing Cabal packages. +-- If the @Built-Type@ field is specified as something other than +-- 'Custom', and the current version of Cabal is acceptable, this performs +-- setup actions directly. Otherwise it builds the setup script and +-- runs it with the given arguments. + +module Distribution.Client.SetupWrapper ( + getSetup, runSetup, runSetupCommand, setupWrapper, + SetupScriptOptions(..), + defaultSetupScriptOptions, + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Distribution.CabalSpecVersion (cabalSpecMinimumLibraryVersion) +import qualified Distribution.Make as Make +import qualified Distribution.Simple as Simple +import Distribution.Version + ( Version, mkVersion, versionNumbers, VersionRange, anyVersion + , intersectVersionRanges, orLaterVersion + , withinRange ) +import qualified Distribution.Backpack as Backpack +import Distribution.Package + ( newSimpleUnitId, unsafeMkDefUnitId, ComponentId + , PackageId, mkPackageName + , PackageIdentifier(..), packageVersion, packageName ) +import Distribution.PackageDescription + ( GenericPackageDescription(packageDescription) + , PackageDescription(..), specVersion, buildType + , BuildType(..) ) +import Distribution.Types.ModuleRenaming (defaultRenaming) +import Distribution.Simple.Configure + ( configCompilerEx ) +import Distribution.Compiler + ( buildCompilerId, CompilerFlavor(GHC, GHCJS) ) +import Distribution.Simple.Compiler + ( Compiler(compilerId), compilerFlavor, PackageDB(..), PackageDBStack ) +import Distribution.Simple.PackageDescription + ( readGenericPackageDescription ) +import Distribution.Simple.PreProcess + ( runSimplePreProcessor, ppUnlit ) +import Distribution.Simple.Build.Macros + ( generatePackageVersionMacros ) +import Distribution.Simple.Program + ( ProgramDb, emptyProgramDb + , getProgramSearchPath, getDbProgramOutput, runDbProgram, ghcProgram + , ghcjsProgram ) +import Distribution.Simple.Program.Find + ( programSearchPathAsPATHVar + , ProgramSearchPathEntry(ProgramSearchPathDir) ) +import Distribution.Simple.Program.Run + ( getEffectiveEnvironment ) +import qualified Distribution.Simple.Program.Strip as Strip +import Distribution.Simple.BuildPaths + ( defaultDistPref, exeExtension ) + +import Distribution.Simple.Command + ( CommandUI(..), commandShowOptions ) +import Distribution.Simple.Program.GHC + ( GhcMode(..), GhcOptions(..), renderGhcOptions ) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.PackageIndex (InstalledPackageIndex) +import qualified Distribution.InstalledPackageInfo as IPI +import Distribution.Client.Types +import Distribution.Client.Config + ( getCabalDir ) +import Distribution.Client.IndexUtils + ( getInstalledPackages ) +import Distribution.Client.JobControl + ( Lock, criticalSection ) +import Distribution.Simple.Setup + ( Flag(..) ) +import Distribution.Utils.Generic + ( safeHead ) +import Distribution.Simple.Utils + ( die', debug, info, infoNoWrap + , cabalVersion, tryFindPackageDesc + , createDirectoryIfMissingVerbose, installExecutableFile + , copyFileVerbose, rewriteFileEx, rewriteFileLBS ) +import Distribution.Client.Utils + ( inDir, tryCanonicalizePath, withExtraPathEnv + , existsAndIsMoreRecentThan, moreRecentFile, withEnv, withEnvOverrides +#ifdef mingw32_HOST_OS + , canonicalizePathNoThrow +#endif + ) + +import Distribution.ReadE +import Distribution.System ( Platform(..), buildPlatform ) +import Distribution.Utils.NubList + ( toNubListR ) +import Distribution.Verbosity +import Distribution.Compat.Stack + +import System.Directory ( doesFileExist ) +import System.FilePath ( (), (<.>) ) +import System.IO ( Handle, hPutStr ) +import Distribution.Compat.Process (createProcess) +import System.Process ( StdStream(..), proc, waitForProcess + , ProcessHandle ) +import qualified System.Process as Process +import Data.List ( foldl1' ) +import Distribution.Client.Compat.ExecutablePath ( getExecutablePath ) + +import qualified Data.ByteString.Lazy as BS + +#ifdef mingw32_HOST_OS +import Distribution.Simple.Utils + ( withTempDirectory ) + +import Control.Exception ( bracket ) +import System.FilePath ( equalFilePath, takeDirectory ) +import System.Directory ( doesDirectoryExist ) +import qualified System.Win32 as Win32 +#endif + +-- | @Setup@ encapsulates the outcome of configuring a setup method to build a +-- particular package. +data Setup = Setup { setupMethod :: SetupMethod + , setupScriptOptions :: SetupScriptOptions + , setupVersion :: Version + , setupBuildType :: BuildType + , setupPackage :: PackageDescription + } + +-- | @SetupMethod@ represents one of the methods used to run Cabal commands. +data SetupMethod = InternalMethod + -- ^ run Cabal commands through \"cabal\" in the + -- current process + | SelfExecMethod + -- ^ run Cabal commands through \"cabal\" as a + -- child process + | ExternalMethod FilePath + -- ^ run Cabal commands through a custom \"Setup\" executable + +-- 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 +-- explicit options, and an optional initial part that applies certain +-- policies (like if we should add the Cabal lib as a dep, and if so which +-- version). This could be structured as an action that returns a fully +-- elaborated 'SetupScriptOptions' containing no remaining policy choices. +-- +-- See also the discussion at https://github.com/haskell/cabal/pull/3094 + +-- | @SetupScriptOptions@ are options used to configure and run 'Setup', as +-- opposed to options given to the Cabal command at runtime. +data SetupScriptOptions = SetupScriptOptions { + -- | The version of the Cabal library to use (if 'useDependenciesExclusive' + -- is not set). A suitable version of the Cabal library must be installed + -- (or for some build-types be the one cabal-install was built with). + -- + -- The version found also determines the version of the Cabal specification + -- that we us for talking to the Setup.hs, unless overridden by + -- 'useCabalSpecVersion'. + -- + useCabalVersion :: VersionRange, + + -- | This is the version of the Cabal specification that we believe that + -- this package uses. This affects the semantics and in particular the + -- Setup command line interface. + -- + -- 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 + -- library as an additional dependency, so add it to 'useDependencies' + -- if needed. + -- + useCabalSpecVersion :: Maybe Version, + useCompiler :: Maybe Compiler, + usePlatform :: Maybe Platform, + usePackageDB :: PackageDBStack, + usePackageIndex :: Maybe InstalledPackageIndex, + useProgramDb :: ProgramDb, + useDistPref :: FilePath, + useLoggingHandle :: Maybe Handle, + useWorkingDir :: Maybe FilePath, + -- | Extra things to add to PATH when invoking the setup script. + useExtraPathEnv :: [FilePath], + -- | Extra environment variables paired with overrides, where + -- + -- * @'Just' v@ means \"set the environment variable's value to @v@\". + -- * 'Nothing' means \"unset the environment variable\". + useExtraEnvOverrides :: [(String, Maybe FilePath)], + forceExternalSetupMethod :: Bool, + + -- | List of dependencies to use when building Setup.hs. + useDependencies :: [(ComponentId, PackageId)], + + -- | Is the list of setup dependencies exclusive? + -- + -- When this is @False@, if we compile the Setup.hs script we do so with the + -- list in 'useDependencies' but all other packages in the environment are + -- also visible. A suitable version of @Cabal@ library (see + -- 'useCabalVersion') is also added to the list of dependencies, unless + -- 'useDependencies' already contains a Cabal dependency. + -- + -- When @True@, only the 'useDependencies' packages are used, with other + -- packages in the environment hidden. + -- + -- This feature is here to support the setup stanza in .cabal files that + -- specifies explicit (and exclusive) dependencies, as well as the old + -- style with no dependencies. + useDependenciesExclusive :: Bool, + + -- | Should we build the Setup.hs with CPP version macros available? + -- We turn this on when we have a setup stanza in .cabal that declares + -- explicit setup dependencies. + -- + useVersionMacros :: Bool, + + -- Used only by 'cabal clean' on Windows. + -- + -- Note: win32 clean hack + ------------------------- + -- On Windows, running './dist/setup/setup clean' doesn't work because the + -- setup script will try to delete itself (which causes it to fail horribly, + -- unlike on Linux). So we have to move the setup exe out of the way first + -- and then delete it manually. This applies only to the external setup + -- method. + useWin32CleanHack :: Bool, + + -- Used only when calling setupWrapper from parallel code to serialise + -- access to the setup cache; should be Nothing otherwise. + -- + -- Note: setup exe cache + ------------------------ + -- When we are installing in parallel, we always use the external setup + -- method. Since compiling the setup script each time adds noticeable + -- overhead, we use a shared setup script cache + -- ('~/.cabal/setup-exe-cache'). For each (compiler, platform, Cabal + -- version) combination the cache holds a compiled setup script + -- executable. This only affects the Simple build type; for the Custom, + -- Configure and Make build types we always compile the setup script anew. + setupCacheLock :: Maybe Lock, + + -- | Is the task we are going to run an interactive foreground task, + -- or an non-interactive background task? Based on this flag we + -- decide whether or not to delegate ctrl+c to the spawned task + isInteractive :: Bool + } + +defaultSetupScriptOptions :: SetupScriptOptions +defaultSetupScriptOptions = SetupScriptOptions { + useCabalVersion = anyVersion, + useCabalSpecVersion = Nothing, + useCompiler = Nothing, + usePlatform = Nothing, + usePackageDB = [GlobalPackageDB, UserPackageDB], + usePackageIndex = Nothing, + useDependencies = [], + useDependenciesExclusive = False, + useVersionMacros = False, + useProgramDb = emptyProgramDb, + useDistPref = defaultDistPref, + useLoggingHandle = Nothing, + useWorkingDir = Nothing, + useExtraPathEnv = [], + useExtraEnvOverrides = [], + useWin32CleanHack = False, + forceExternalSetupMethod = False, + setupCacheLock = Nothing, + isInteractive = False + } + +workingDir :: SetupScriptOptions -> FilePath +workingDir options = + case fromMaybe "" (useWorkingDir options) of + [] -> "." + dir -> dir + +-- | A @SetupRunner@ implements a 'SetupMethod'. +type SetupRunner = Verbosity + -> SetupScriptOptions + -> BuildType + -> [String] + -> IO () + +-- | Prepare to build a package by configuring a 'SetupMethod'. The returned +-- 'Setup' object identifies the method. The 'SetupScriptOptions' may be changed +-- during the configuration process; the final values are given by +-- 'setupScriptOptions'. +getSetup :: Verbosity + -> SetupScriptOptions + -> Maybe PackageDescription + -> IO Setup +getSetup verbosity options mpkg = do + pkg <- maybe getPkg return mpkg + let options' = options { + useCabalVersion = intersectVersionRanges + (useCabalVersion options) + (orLaterVersion (mkVersion (cabalSpecMinimumLibraryVersion (specVersion pkg)))) + } + buildType' = buildType pkg + (version, method, options'') <- + getSetupMethod verbosity options' pkg buildType' + return Setup { setupMethod = method + , setupScriptOptions = options'' + , setupVersion = version + , setupBuildType = buildType' + , setupPackage = pkg + } + where + getPkg = tryFindPackageDesc verbosity (fromMaybe "." (useWorkingDir options)) + >>= readGenericPackageDescription verbosity + >>= 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 + :: Verbosity -> SetupScriptOptions -> PackageDescription -> BuildType + -> IO (Version, SetupMethod, SetupScriptOptions) +getSetupMethod verbosity options pkg buildType' + | buildType' == Custom + || maybe False (cabalVersion /=) (useCabalSpecVersion options) + || not (cabalVersion `withinRange` useCabalVersion options) = + getExternalSetupMethod verbosity options pkg buildType' + | isJust (useLoggingHandle options) + -- 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 +runSetupMethod (ExternalMethod path) = externalSetupMethod path +runSetupMethod SelfExecMethod = selfExecSetupMethod + +-- | Run a configured 'Setup' with specific arguments. +runSetup :: Verbosity -> Setup + -> [String] -- ^ command-line arguments + -> IO () +runSetup verbosity setup args0 = do + let method = setupMethod setup + options = setupScriptOptions setup + bt = setupBuildType setup + args = verbosityHack (setupVersion setup) args0 + when (verbosity >= deafening {- avoid test if not debug -} && args /= args0) $ + infoNoWrap verbose $ + "Applied verbosity hack:\n" ++ + " Before: " ++ show args0 ++ "\n" ++ + " After: " ++ show args ++ "\n" + runSetupMethod method verbosity options bt args + +-- | This is a horrible hack to make sure passing fancy verbosity +-- flags (e.g., @-v'info +callstack'@) doesn't break horribly on +-- old Setup. We can't do it in 'filterConfigureFlags' because +-- verbosity applies to ALL commands. +verbosityHack :: Version -> [String] -> [String] +verbosityHack ver args0 + | ver >= mkVersion [2,1] = args0 + | otherwise = go args0 + where + go (('-':'v':rest) : args) + | Just rest' <- munch rest = ("-v" ++ rest') : go args + go (('-':'-':'v':'e':'r':'b':'o':'s':'e':'=':rest) : args) + | Just rest' <- munch rest = ("--verbose=" ++ rest') : go args + go ("--verbose" : rest : args) + | Just rest' <- munch rest = "--verbose" : rest' : go args + go rest@("--" : _) = rest + go (arg:args) = arg : go args + go [] = [] + + munch rest = + case runReadE flagToVerbosity rest of + Right v + | ver < mkVersion [2,0], verboseHasFlags v + -- We could preserve the prefix, but since we're assuming + -- it's Cabal's verbosity flag, we can assume that + -- any format is OK + -> Just (showForCabal (verboseNoFlags v)) + | ver < mkVersion [2,1], isVerboseTimestamp v + -- +timestamp wasn't yet available in Cabal-2.0.0 + -> Just (showForCabal (verboseNoTimestamp v)) + _ -> Nothing + +-- | Run a command through a configured 'Setup'. +runSetupCommand :: Verbosity -> Setup + -> CommandUI flags -- ^ command definition + -> flags -- ^ command flags + -> [String] -- ^ extra command-line arguments + -> IO () +runSetupCommand verbosity setup cmd flags extraArgs = do + let args = commandName cmd : commandShowOptions cmd flags ++ extraArgs + runSetup verbosity setup args + +-- | Configure a 'Setup' and run a command in one step. The command flags +-- may depend on the Cabal library version in use. +setupWrapper :: Verbosity + -> SetupScriptOptions + -> Maybe PackageDescription + -> CommandUI flags + -> (Version -> flags) + -- ^ produce command flags given the Cabal library version + -> (Version -> [String]) + -> IO () +setupWrapper verbosity options mpkg cmd flags extraArgs = do + setup <- getSetup verbosity options mpkg + runSetupCommand verbosity setup + cmd (flags $ setupVersion setup) + (extraArgs $ setupVersion setup) + +-- ------------------------------------------------------------ +-- * Internal SetupMethod +-- ------------------------------------------------------------ + +internalSetupMethod :: SetupRunner +internalSetupMethod verbosity options bt args = do + info verbosity $ "Using internal setup method with build-type " ++ show bt + ++ " and args:\n " ++ show args + inDir (useWorkingDir options) $ do + withEnv "HASKELL_DIST_DIR" (useDistPref options) $ + withExtraPathEnv (useExtraPathEnv options) $ + withEnvOverrides (useExtraEnvOverrides options) $ + buildTypeAction bt args + +buildTypeAction :: BuildType -> ([String] -> IO ()) +buildTypeAction Simple = Simple.defaultMainArgs +buildTypeAction Configure = Simple.defaultMainWithHooksArgs + Simple.autoconfUserHooks +buildTypeAction Make = Make.defaultMainArgs +buildTypeAction Custom = error "buildTypeAction Custom" + + +-- | @runProcess'@ is a version of @runProcess@ where we have +-- the additional option to decide whether or not we should +-- delegate CTRL+C to the spawned process. +runProcess' :: FilePath -- ^ Filename of the executable + -> [String] -- ^ Arguments to pass to executable + -> Maybe FilePath -- ^ Optional path to working directory + -> Maybe [(String, String)] -- ^ Optional environment + -> Maybe Handle -- ^ Handle for @stdin@ + -> Maybe Handle -- ^ Handle for @stdout@ + -> Maybe Handle -- ^ Handle for @stderr@ + -> Bool -- ^ Delegate Ctrl+C ? + -> IO ProcessHandle +runProcess' cmd args mb_cwd mb_env mb_stdin mb_stdout mb_stderr _delegate = do + (_,_,_,ph) <- + createProcess + (proc cmd args){ Process.cwd = mb_cwd + , Process.env = mb_env + , Process.std_in = mbToStd mb_stdin + , Process.std_out = mbToStd mb_stdout + , Process.std_err = mbToStd mb_stderr + , Process.delegate_ctlc = _delegate + } + return ph + where + mbToStd :: Maybe Handle -> StdStream + mbToStd Nothing = Inherit + mbToStd (Just hdl) = UseHandle hdl + +-- ------------------------------------------------------------ +-- * Self-Exec SetupMethod +-- ------------------------------------------------------------ + +selfExecSetupMethod :: SetupRunner +selfExecSetupMethod verbosity options bt args0 = do + let args = ["act-as-setup", + "--build-type=" ++ prettyShow bt, + "--"] ++ args0 + info verbosity $ "Using self-exec internal setup method with build-type " + ++ show bt ++ " and args:\n " ++ show args + path <- getExecutablePath + info verbosity $ unwords (path : args) + case useLoggingHandle options of + Nothing -> return () + Just logHandle -> info verbosity $ "Redirecting build log to " + ++ show logHandle + + searchpath <- programSearchPathAsPATHVar + (map ProgramSearchPathDir (useExtraPathEnv options) ++ + getProgramSearchPath (useProgramDb options)) + env <- getEffectiveEnvironment $ + [ ("PATH", Just searchpath) + , ("HASKELL_DIST_DIR", Just (useDistPref options)) + ] ++ useExtraEnvOverrides options + process <- runProcess' path args + (useWorkingDir options) env Nothing + (useLoggingHandle options) (useLoggingHandle options) + (isInteractive options) + exitCode <- waitForProcess process + unless (exitCode == ExitSuccess) $ exitWith exitCode + +-- ------------------------------------------------------------ +-- * External SetupMethod +-- ------------------------------------------------------------ + +externalSetupMethod :: WithCallStack (FilePath -> SetupRunner) +externalSetupMethod path verbosity options _ args = do + info verbosity $ unwords (path : args) + case useLoggingHandle options of + Nothing -> return () + Just logHandle -> info verbosity $ "Redirecting build log to " + ++ show logHandle + + -- See 'Note: win32 clean hack' above. +#ifdef mingw32_HOST_OS + if useWin32CleanHack options then doWin32CleanHack path else doInvoke path +#else + doInvoke path +#endif + + where + doInvoke path' = do + searchpath <- programSearchPathAsPATHVar + (map ProgramSearchPathDir (useExtraPathEnv options) ++ + getProgramSearchPath (useProgramDb options)) + env <- getEffectiveEnvironment $ + [ ("PATH", Just searchpath) + , ("HASKELL_DIST_DIR", Just (useDistPref options)) + ] ++ useExtraEnvOverrides options + + debug verbosity $ "Setup arguments: "++unwords args + process <- runProcess' path' args + (useWorkingDir options) env Nothing + (useLoggingHandle options) (useLoggingHandle options) + (isInteractive options) + exitCode <- waitForProcess process + unless (exitCode == ExitSuccess) $ exitWith exitCode + +#ifdef mingw32_HOST_OS + doWin32CleanHack path' = do + info verbosity $ "Using the Win32 clean hack." + -- Recursively removes the temp dir on exit. + withTempDirectory verbosity (workingDir options) "cabal-tmp" $ \tmpDir -> + bracket (moveOutOfTheWay tmpDir path') + (maybeRestore path') + doInvoke + + moveOutOfTheWay tmpDir path' = do + let newPath = tmpDir "setup" <.> exeExtension buildPlatform + Win32.moveFile path' newPath + return newPath + + maybeRestore oldPath path' = do + let oldPathDir = takeDirectory oldPath + oldPathDirExists <- doesDirectoryExist oldPathDir + -- 'setup clean' didn't complete, 'dist/setup' still exists. + when oldPathDirExists $ + Win32.moveFile path' oldPath +#endif + +getExternalSetupMethod + :: 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 setupDir + (cabalLibVersion, mCabalLibInstalledPkgId, options') <- cabalLibVersionToUse + debug verbosity $ "Using Cabal library version " ++ prettyShow cabalLibVersion + path <- if useCachedSetupExecutable + then getCachedSetupExecutable options' + cabalLibVersion mCabalLibInstalledPkgId + else compileSetupExecutable options' + cabalLibVersion mCabalLibInstalledPkgId False + + -- Since useWorkingDir can change the relative path, the path argument must + -- 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 + + -- See 'Note: win32 clean hack' above. +#ifdef mingw32_HOST_OS + -- setupProgFile may not exist if we're using a cached program + setupProgFile' <- canonicalizePathNoThrow setupProgFile + let win32CleanHackNeeded = (useWin32CleanHack options) + -- Skip when a cached setup script is used. + && setupProgFile' `equalFilePath` path' +#else + let win32CleanHackNeeded = False +#endif + let options'' = options' { useWin32CleanHack = win32CleanHackNeeded } + + return (cabalLibVersion, ExternalMethod path', options'') + + where + setupDir = workingDir options useDistPref options "setup" + setupVersionFile = setupDir "setup" <.> "version" + setupHs = setupDir "setup" <.> "hs" + setupProgFile = setupDir "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 + (&&) <$> setupProgFile `existsAndIsMoreRecentThan` setupHs + <*> setupProgFile `existsAndIsMoreRecentThan` setupVersionFile + + writeSetupVersionFile :: Version -> IO () + writeSetupVersionFile version = + writeFile 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 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) $ die' verbosity + "Using 'build-type: Custom' but there is no Setup.hs or Setup.lhs script." + let src = (if useHs then customSetupHs else customSetupLhs) + srcNewer <- src `moreRecentFile` setupHs + when srcNewer $ if useHs + then copyFileVerbose verbosity src setupHs + else runSimplePreProcessor ppUnlit src setupHs verbosity + where + customSetupHs = workingDir options "Setup.hs" + customSetupLhs = workingDir options "Setup.lhs" + + updateSetupScript cabalLibVersion _ = + rewriteFileLBS verbosity setupHs (buildTypeScript cabalLibVersion) + + buildTypeScript :: Version -> BS.ByteString + buildTypeScript cabalLibVersion = case bt of + Simple -> "import Distribution.Simple; main = defaultMain\n" + Configure | 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" + 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 + [] -> die' verbosity $ "The package '" ++ prettyShow (packageName pkg) + ++ "' requires Cabal library version " + ++ prettyShow (useCabalVersion options) + ++ " but no suitable version is installed." + 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 + cabalDir <- getCabalDir + let setupCacheDir = cabalDir "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 + 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') $ + Strip.stripExe verbosity platform (useProgramDb options') + 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 <- setupHs `moreRecentFile` setupProgFile + cabalVersionNewer <- setupVersionFile `moreRecentFile` setupProgFile + let outOfDate = setupHsNewer || cabalVersionNewer + when (outOfDate || forceCompile) $ do + debug verbosity "Setup executable needs to be updated, compiling..." + (compiler, progdb, options'') <- configureCompiler 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' we enforce the deps specified, + -- so only the given ones can be used. Otherwise we allow the use + -- of packages in the ambient environment, and add on a dep on the + -- Cabal library (unless 'useDependencies' already contains one). + -- + -- With 'useVersionMacros' we use a version CPP macros .h file. + -- + -- Both of these options should be enabled for packages that have + -- opted-in and declared a custom-settup stanza. + -- + selectedDeps | useDependenciesExclusive options' + = useDependencies options' + | otherwise = useDependencies options' ++ + if any (isCabalPkgId . snd) + (useDependencies options') + then [] + else cabalDep + addRenaming (ipid, _) = + -- Assert 'DefUnitId' invariant + (Backpack.DefiniteUnitId (unsafeMkDefUnitId (newSimpleUnitId ipid)) + ,defaultRenaming) + cppMacrosFile = setupDir "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 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 [workingDir options'] + _ -> mempty + , ghcOptPackageDBs = usePackageDB options'' + , ghcOptHideAllPackages = Flag (useDependenciesExclusive options') + , ghcOptCabal = Flag (useDependenciesExclusive options') + , ghcOptPackages = toNubListR $ map addRenaming selectedDeps + , ghcOptCppIncludes = toNubListR [ cppMacrosFile + | useVersionMacros options' ] + , ghcOptExtra = extraOpts + } + let ghcCmdLine = renderGhcOptions compiler platform ghcOptions + when (useVersionMacros options') $ + rewriteFileEx verbosity cppMacrosFile + $ generatePackageVersionMacros (pkgVersion $ package pkg) (map snd selectedDeps) + case useLoggingHandle options of + Nothing -> runDbProgram verbosity program progdb ghcCmdLine + + -- If build logging is enabled, redirect compiler output to + -- the log file. + (Just logHandle) -> do output <- getDbProgramOutput verbosity program + progdb ghcCmdLine + hPutStr logHandle output + return setupProgFile + + +isCabalPkgId :: PackageIdentifier -> Bool +isCabalPkgId (PackageIdentifier pname _) = pname == mkPackageName "Cabal" diff --git a/cabal/cabal-install/src/Distribution/Client/SolverInstallPlan.hs b/cabal/cabal-install/src/Distribution/Client/SolverInstallPlan.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/SolverInstallPlan.hs @@ -0,0 +1,443 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.SolverInstallPlan +-- Copyright : (c) Duncan Coutts 2008 +-- License : BSD-like +-- +-- Maintainer : duncan@community.haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- The 'SolverInstallPlan' is the graph of packages produced by the +-- dependency solver, and specifies at the package-granularity what +-- things are going to be installed. To put it another way: the +-- dependency solver produces a 'SolverInstallPlan', which is then +-- consumed by various other parts of Cabal. +-- +----------------------------------------------------------------------------- +module Distribution.Client.SolverInstallPlan( + SolverInstallPlan(..), + SolverPlanPackage, + ResolverPackage(..), + + -- * Operations on 'SolverInstallPlan's + new, + toList, + toMap, + + remove, + + showPlanIndex, + showInstallPlan, + + -- * Checking validity of plans + valid, + closed, + consistent, + acyclic, + + -- ** Details on invalid plans + SolverPlanProblem(..), + showPlanProblem, + problems, + + -- ** Querying the install plan + dependencyClosure, + reverseDependencyClosure, + topologicalOrder, + reverseTopologicalOrder, +) where + +import Distribution.Client.Compat.Prelude hiding (toList) +import Prelude () + +import Distribution.Package + ( PackageIdentifier(..), Package(..), PackageName + , HasUnitId(..), PackageId, packageVersion, packageName ) +import Distribution.Types.Flag (nullFlagAssignment) +import qualified Distribution.Solver.Types.ComponentDeps as CD + +import Distribution.Client.Types + ( UnresolvedPkgLoc ) +import Distribution.Version + ( Version ) + +import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.ResolverPackage +import Distribution.Solver.Types.SolverId +import Distribution.Solver.Types.SolverPackage + +import Distribution.Compat.Graph (Graph, IsNode(..)) +import qualified Data.Foldable as Foldable +import qualified Data.Graph as OldGraph +import qualified Distribution.Compat.Graph as Graph +import qualified Data.Map as Map +import Data.Array ((!)) + +type SolverPlanPackage = ResolverPackage UnresolvedPkgLoc + +type SolverPlanIndex = Graph SolverPlanPackage + +data SolverInstallPlan = SolverInstallPlan { + planIndex :: !SolverPlanIndex, + planIndepGoals :: !IndependentGoals + } + deriving (Typeable, 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 + +showPlanIndex :: [SolverPlanPackage] -> String +showPlanIndex = intercalate "\n" . map showPlanPackage + +showInstallPlan :: SolverInstallPlan -> String +showInstallPlan = showPlanIndex . toList + +showPlanPackage :: SolverPlanPackage -> String +showPlanPackage (PreExisting ipkg) = "PreExisting " ++ prettyShow (packageId ipkg) + ++ " (" ++ prettyShow (installedUnitId ipkg) + ++ ")" +showPlanPackage (Configured spkg) = + "Configured " ++ prettyShow (packageId spkg) ++ flags ++ comps + where + flags + | nullFlagAssignment fa = "" + | otherwise = " " ++ prettyShow (solverPkgFlags spkg) + where + fa = solverPkgFlags spkg + + comps | null deps = "" + | otherwise = " " ++ unwords (map prettyShow $ Foldable.toList deps) + where + deps :: Set CD.Component + deps = CD.components (solverPkgLibDeps spkg) + <> CD.components (solverPkgExeDeps spkg) + +-- | Build an installation plan from a valid set of resolved packages. +-- +new :: IndependentGoals + -> SolverPlanIndex + -> Either [SolverPlanProblem] SolverInstallPlan +new indepGoals index = + case problems indepGoals index of + [] -> Right (SolverInstallPlan index indepGoals) + probs -> Left probs + +toList :: SolverInstallPlan -> [SolverPlanPackage] +toList = Foldable.toList . planIndex + +toMap :: SolverInstallPlan -> Map SolverId SolverPlanPackage +toMap = Graph.toMap . planIndex + +-- | Remove packages from the install plan. This will result in an +-- error if there are remaining packages that depend on any matching +-- package. This is primarily useful for obtaining an install plan for +-- the dependencies of a package or set of packages without actually +-- installing the package itself, as when doing development. +-- +remove :: (SolverPlanPackage -> Bool) + -> SolverInstallPlan + -> Either [SolverPlanProblem] + (SolverInstallPlan) +remove shouldRemove plan = + new (planIndepGoals plan) newIndex + where + newIndex = Graph.fromDistinctList $ + filter (not . shouldRemove) (toList plan) + +-- ------------------------------------------------------------ +-- * Checking validity of plans +-- ------------------------------------------------------------ + +-- | A valid installation plan is a set of packages that is 'acyclic', +-- 'closed' and 'consistent'. Also, every 'ConfiguredPackage' in the +-- plan has to have a valid configuration (see 'configuredPackageValid'). +-- +-- * if the result is @False@ use 'problems' to get a detailed list. +-- +valid :: IndependentGoals + -> SolverPlanIndex + -> Bool +valid indepGoals index = + null $ problems indepGoals index + +data SolverPlanProblem = + PackageMissingDeps SolverPlanPackage + [PackageIdentifier] + | PackageCycle [SolverPlanPackage] + | PackageInconsistency PackageName [(PackageIdentifier, Version)] + | PackageStateInvalid SolverPlanPackage SolverPlanPackage + +showPlanProblem :: SolverPlanProblem -> String +showPlanProblem (PackageMissingDeps pkg missingDeps) = + "Package " ++ prettyShow (packageId 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.packageId) cycleGroup) + +showPlanProblem (PackageInconsistency name inconsistencies) = + "Package " ++ prettyShow name + ++ " is required by several packages," + ++ " but they require inconsistent versions:\n" + ++ unlines [ " package " ++ prettyShow pkg ++ " requires " + ++ prettyShow (PackageIdentifier name ver) + | (pkg, ver) <- inconsistencies ] + +showPlanProblem (PackageStateInvalid pkg pkg') = + "Package " ++ prettyShow (packageId pkg) + ++ " is in the " ++ showPlanState pkg + ++ " state but it depends on package " ++ prettyShow (packageId pkg') + ++ " which is in the " ++ showPlanState pkg' + ++ " state" + where + showPlanState (PreExisting _) = "pre-existing" + showPlanState (Configured _) = "configured" + +-- | 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 :: IndependentGoals + -> SolverPlanIndex + -> [SolverPlanProblem] +problems indepGoals index = + + [ PackageMissingDeps pkg + (mapMaybe + (fmap packageId . flip Graph.lookup index) + missingDeps) + | (pkg, missingDeps) <- Graph.broken index ] + + ++ [ PackageCycle cycleGroup + | cycleGroup <- Graph.cycles index ] + + ++ [ PackageInconsistency name inconsistencies + | (name, inconsistencies) <- + dependencyInconsistencies indepGoals index ] + + ++ [ PackageStateInvalid pkg pkg' + | pkg <- Foldable.toList index + , Just pkg' <- map (flip Graph.lookup index) + (nodeNeighbors pkg) + , not (stateDependencyRelation pkg pkg') ] + + +-- | Compute all roots of the install plan, and verify that the transitive +-- plans from those roots are all consistent. +-- +-- NOTE: This does not check for dependency cycles. Moreover, dependency cycles +-- may be absent from the subplans even if the larger plan contains a dependency +-- 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 = + concatMap dependencyInconsistencies' subplans + where + subplans :: [SolverPlanIndex] + subplans = -- Not Graph.closure!! + map (nonSetupClosure index) + (rootSets indepGoals index) + +-- NB: When we check for inconsistencies, packages from the setup +-- scripts don't count as part of the closure (this way, we +-- can build, e.g., Cabal-1.24.1 even if its setup script is +-- built with Cabal-1.24.0). +-- +-- This is a best effort function that swallows any non-existent +-- SolverIds. +nonSetupClosure :: SolverPlanIndex + -> [SolverId] + -> SolverPlanIndex +nonSetupClosure index pkgids0 = closure Graph.empty pkgids0 + where + closure :: Graph SolverPlanPackage -> [SolverId] -> SolverPlanIndex + closure completed [] = completed + closure completed (pkgid:pkgids) = + case Graph.lookup pkgid index of + Nothing -> closure completed pkgids + Just pkg -> + case Graph.lookup (nodeKey pkg) completed of + Just _ -> closure completed pkgids + Nothing -> closure completed' pkgids' + where completed' = Graph.insert pkg completed + pkgids' = CD.nonSetupDeps (resolverPackageLibDeps pkg) ++ pkgids + +-- | Compute the root sets of a plan +-- +-- A root set is a set of packages whose dependency closure must be consistent. +-- This is the set of all top-level library roots (taken together normally, or +-- as singletons sets if we are considering them as independent goals), along +-- with all setup dependencies of all packages. +rootSets :: IndependentGoals -> SolverPlanIndex -> [[SolverId]] +rootSets (IndependentGoals indepGoals) index = + if indepGoals then map (:[]) libRoots else [libRoots] + ++ setupRoots index + where + libRoots :: [SolverId] + libRoots = libraryRoots index + +-- | Compute the library roots of a plan +-- +-- The library roots are the set of packages with no reverse dependencies +-- (no reverse library dependencies but also no reverse setup dependencies). +libraryRoots :: SolverPlanIndex -> [SolverId] +libraryRoots index = + map (nodeKey . toPkgId) roots + where + (graph, toPkgId, _) = Graph.toGraph index + indegree = OldGraph.indegree graph + roots = filter isRoot (OldGraph.vertices graph) + isRoot v = indegree ! v == 0 + +-- | The setup dependencies of each package in the plan +setupRoots :: SolverPlanIndex -> [[SolverId]] +setupRoots = filter (not . null) + . map (CD.setupDeps . resolverPackageLibDeps) + . Foldable.toList + +-- | Given a package index where we assume we want to use all the packages +-- (use 'dependencyClosure' if you need to get such a index subset) find out +-- if the dependencies within it use consistent versions of each package. +-- Return all cases where multiple packages depend on different versions of +-- some other package. +-- +-- Each element in the result is a package name along with the packages that +-- depend on it and the versions they require. These are guaranteed to be +-- distinct. +-- +dependencyInconsistencies' :: SolverPlanIndex + -> [(PackageName, [(PackageIdentifier, Version)])] +dependencyInconsistencies' index = + [ (name, [ (pid, packageVersion dep) | (dep,pids) <- uses, pid <- pids]) + | (name, ipid_map) <- Map.toList inverseIndex + , let uses = Map.elems ipid_map + , reallyIsInconsistent (map fst uses) + ] + where + -- For each package name (of a dependency, somewhere) + -- 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.fromListWith (Map.unionWith (\(a,b) (_,b') -> (a,b++b'))) + [ (packageName dep, Map.fromList [(sid,(dep,[packageId pkg]))]) + | -- For each package @pkg@ + pkg <- Foldable.toList index + -- Find out which @sid@ @pkg@ depends on + , sid <- CD.nonSetupDeps (resolverPackageLibDeps pkg) + -- And look up those @sid@ (i.e., @sid@ is the ID of @dep@) + , Just dep <- [Graph.lookup sid index] + ] + + -- If, in a single install plan, we depend on more than one version of a + -- package, then this is ONLY okay in the (rather special) case that we + -- depend on precisely two versions of that package, and one of them + -- depends on the other. This is necessary for example for the base where + -- we have base-3 depending on base-4. + reallyIsInconsistent :: [SolverPlanPackage] -> Bool + reallyIsInconsistent [] = False + reallyIsInconsistent [_p] = False + reallyIsInconsistent [p1, p2] = + let pid1 = nodeKey p1 + pid2 = nodeKey p2 + in pid1 `notElem` CD.nonSetupDeps (resolverPackageLibDeps p2) + && pid2 `notElem` CD.nonSetupDeps (resolverPackageLibDeps p1) + reallyIsInconsistent _ = True + + +-- | The graph of packages (nodes) and dependencies (edges) must be acyclic. +-- +-- * if the result is @False@ use 'PackageIndex.dependencyCycles' to find out +-- which packages are involved in dependency cycles. +-- +acyclic :: SolverPlanIndex -> Bool +acyclic = null . Graph.cycles + +-- | An installation plan is closed if for every package in the set, all of +-- its dependencies are also in the set. That is, the set is closed under the +-- dependency relation. +-- +-- * if the result is @False@ use 'PackageIndex.brokenPackages' to find out +-- which packages depend on packages not in the index. +-- +closed :: SolverPlanIndex -> Bool +closed = null . Graph.broken + +-- | An installation plan is consistent if all dependencies that target a +-- single package name, target the same version. +-- +-- This is slightly subtle. It is not the same as requiring that there be at +-- most one version of any package in the set. It only requires that of +-- packages which have more than one other package depending on them. We could +-- actually make the condition even more precise and say that different +-- versions are OK so long as they are not both in the transitive closure of +-- any other package (or equivalently that their inverse closures do not +-- intersect). The point is we do not want to have any packages depending +-- directly or indirectly on two different versions of the same package. The +-- current definition is just a safe approximation of that. +-- +-- * if the result is @False@ use 'PackageIndex.dependencyInconsistencies' to +-- find out which packages are. +-- +consistent :: SolverPlanIndex -> Bool +consistent = null . dependencyInconsistencies (IndependentGoals False) + +-- | The states of packages have that depend on each other must respect +-- this relation. That is for very case where package @a@ depends on +-- package @b@ we require that @dependencyStatesOk a b = True@. +-- +stateDependencyRelation :: SolverPlanPackage + -> SolverPlanPackage + -> Bool +stateDependencyRelation PreExisting{} PreExisting{} = True + +stateDependencyRelation (Configured _) PreExisting{} = True +stateDependencyRelation (Configured _) (Configured _) = True + +stateDependencyRelation _ _ = False + + +-- | Compute the dependency closure of a package in a install plan +-- +dependencyClosure :: SolverInstallPlan + -> [SolverId] + -> [SolverPlanPackage] +dependencyClosure plan = fromMaybe [] . Graph.closure (planIndex plan) + + +reverseDependencyClosure :: SolverInstallPlan + -> [SolverId] + -> [SolverPlanPackage] +reverseDependencyClosure plan = fromMaybe [] . Graph.revClosure (planIndex plan) + + +topologicalOrder :: SolverInstallPlan + -> [SolverPlanPackage] +topologicalOrder plan = Graph.topSort (planIndex plan) + + +reverseTopologicalOrder :: SolverInstallPlan + -> [SolverPlanPackage] +reverseTopologicalOrder plan = Graph.revTopSort (planIndex plan) diff --git a/cabal/cabal-install/src/Distribution/Client/SourceFiles.hs b/cabal/cabal-install/src/Distribution/Client/SourceFiles.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/SourceFiles.hs @@ -0,0 +1,176 @@ +-- | Contains an @sdist@ like function which computes the source files +-- that we should track to determine if a rebuild is necessary. +-- Unlike @sdist@, we can operate directly on the true +-- 'PackageDescription' (not flattened). +-- +-- The naming convention, roughly, is that to declare we need the +-- source for some type T, you use the function needT; some functions +-- need auxiliary information. +-- +-- We can only use this code for non-Custom scripts; Custom scripts +-- may have arbitrary extra dependencies (esp. new preprocessors) which +-- we cannot "see" easily. +module Distribution.Client.SourceFiles (needElaboratedConfiguredPackage) where + +import Control.Monad.IO.Class + +import Distribution.Client.ProjectPlanning.Types +import Distribution.Client.RebuildMonad + +import Distribution.Solver.Types.OptionalStanza + +import Distribution.Simple.Glob (matchDirFileGlobWithDie) +import Distribution.Simple.PreProcess + +import Distribution.Types.PackageDescription +import Distribution.Types.Component +import Distribution.Types.ComponentRequestedSpec (ComponentRequestedSpec) +import Distribution.Types.Library +import Distribution.Types.Executable +import Distribution.Types.Benchmark +import Distribution.Types.BenchmarkInterface +import Distribution.Types.TestSuite +import Distribution.Types.TestSuiteInterface +import Distribution.Types.BuildInfo +import Distribution.Types.ForeignLib +import Distribution.Utils.Path + +import Distribution.ModuleName + +import Prelude () +import Distribution.Client.Compat.Prelude +import Distribution.Verbosity (silent) + +import System.FilePath + +needElaboratedConfiguredPackage :: ElaboratedConfiguredPackage -> Rebuild () +needElaboratedConfiguredPackage elab = + case elabPkgOrComp elab of + ElabComponent ecomp -> needElaboratedComponent elab ecomp + ElabPackage epkg -> needElaboratedPackage elab epkg + +needElaboratedPackage :: ElaboratedConfiguredPackage -> ElaboratedPackage -> Rebuild () +needElaboratedPackage elab epkg = + traverse_ (needComponent pkg_descr) (enabledComponents pkg_descr enabled) + where + pkg_descr :: PackageDescription + pkg_descr = elabPkgDescription elab + enabled_stanzas :: OptionalStanzaSet + enabled_stanzas = pkgStanzasEnabled epkg + enabled :: ComponentRequestedSpec + enabled = enableStanzas enabled_stanzas + +needElaboratedComponent :: ElaboratedConfiguredPackage -> ElaboratedComponent -> Rebuild () +needElaboratedComponent elab ecomp = + case mb_comp of + Nothing -> needSetup + Just comp -> needComponent pkg_descr comp + where + pkg_descr :: PackageDescription + pkg_descr = elabPkgDescription elab + mb_comp :: Maybe Component + mb_comp = fmap (getComponent pkg_descr) (compComponentName ecomp) + +needComponent :: PackageDescription -> Component -> Rebuild () +needComponent pkg_descr comp = + case comp of + CLib lib -> needLibrary pkg_descr lib + CFLib flib -> needForeignLib pkg_descr flib + CExe exe -> needExecutable pkg_descr exe + CTest test -> needTestSuite pkg_descr test + CBench bench -> needBenchmark pkg_descr bench + +needSetup :: Rebuild () +needSetup = findFirstFileMonitored id ["Setup.hs", "Setup.lhs"] >> return () + +needLibrary :: PackageDescription -> Library -> Rebuild () +needLibrary pkg_descr (Library { exposedModules = modules + , signatures = sigs + , libBuildInfo = bi }) + = needBuildInfo pkg_descr bi (modules ++ sigs) + +needForeignLib :: PackageDescription -> ForeignLib -> Rebuild () +needForeignLib pkg_descr (ForeignLib { foreignLibModDefFile = fs + , foreignLibBuildInfo = bi }) + = do traverse_ needIfExists fs + needBuildInfo pkg_descr bi [] + +needExecutable :: PackageDescription -> Executable -> Rebuild () +needExecutable pkg_descr (Executable { modulePath = mainPath + , buildInfo = bi }) + = do needBuildInfo pkg_descr bi [] + needMainFile bi mainPath + +needTestSuite :: PackageDescription -> TestSuite -> Rebuild () +needTestSuite pkg_descr t + = case testInterface t of + TestSuiteExeV10 _ mainPath -> do + needBuildInfo pkg_descr bi [] + needMainFile bi mainPath + TestSuiteLibV09 _ m -> + needBuildInfo pkg_descr bi [m] + TestSuiteUnsupported _ -> return () -- soft fail + where + bi :: BuildInfo + bi = testBuildInfo t + +needMainFile :: BuildInfo -> FilePath -> Rebuild () +needMainFile bi mainPath = do + -- The matter here is subtle. It might *seem* that we + -- should just search for mainPath, but as per + -- b61cb051f63ed5869b8f4a6af996ff7e833e4b39 'main-is' + -- will actually be the source file AFTER preprocessing, + -- whereas we need to get the file *prior* to preprocessing. + ppFile <- findFileWithExtensionMonitored + (ppSuffixes knownSuffixHandlers) + (map getSymbolicPath (hsSourceDirs bi)) + (dropExtension mainPath) + case ppFile of + -- But check the original path in the end, because + -- maybe it's a non-preprocessed file with a non-traditional + -- extension. + Nothing -> findFileMonitored (map getSymbolicPath (hsSourceDirs bi)) mainPath + >>= maybe (return ()) need + Just pp -> need pp + +needBenchmark :: PackageDescription -> Benchmark -> Rebuild () +needBenchmark pkg_descr bm + = case benchmarkInterface bm of + BenchmarkExeV10 _ mainPath -> do + needBuildInfo pkg_descr bi [] + needMainFile bi mainPath + BenchmarkUnsupported _ -> return () -- soft fail + where + bi :: BuildInfo + bi = benchmarkBuildInfo bm + +needBuildInfo :: PackageDescription -> BuildInfo -> [ModuleName] -> Rebuild () +needBuildInfo pkg_descr bi modules = do + -- NB: These are separate because there may be both A.hs and + -- A.hs-boot; need to track both. + findNeededModules ["hs", "lhs", "hsig", "lhsig"] + findNeededModules ["hs-boot", "lhs-boot"] + expandedExtraSrcFiles <- liftIO $ fmap concat . for (extraSrcFiles pkg_descr) $ \fpath -> matchDirFileGlobWithDie silent (\ _ _ -> return []) (specVersion pkg_descr) "." fpath + traverse_ needIfExists $ concat + [ cSources bi + , cxxSources bi + , jsSources bi + , cmmSources bi + , asmSources bi + , expandedExtraSrcFiles + ] + for_ (installIncludes bi) $ \f -> + findFileMonitored ("." : includeDirs bi) f + >>= maybe (return ()) need + where + findNeededModules :: [String] -> Rebuild () + findNeededModules exts = traverse_ + (findNeededModule exts) + (modules ++ otherModules bi) + findNeededModule :: [String] -> ModuleName -> Rebuild () + findNeededModule exts m = + findFileWithExtensionMonitored + (ppSuffixes knownSuffixHandlers ++ exts) + (map getSymbolicPath (hsSourceDirs bi)) + (toFilePath m) + >>= maybe (return ()) need diff --git a/cabal/cabal-install/src/Distribution/Client/SrcDist.hs b/cabal/cabal-install/src/Distribution/Client/SrcDist.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/SrcDist.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | Utilities to implement cabal @v2-sdist@. +module Distribution.Client.SrcDist ( + allPackageSourceFiles, + packageDirToSdist, +) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Control.Monad.State.Lazy (StateT, evalStateT, gets, modify) +import Control.Monad.Trans (liftIO) +import Control.Monad.Writer.Lazy (WriterT, execWriterT, tell) +import System.FilePath (normalise, takeDirectory, ()) + +import Distribution.Client.Utils (tryFindAddSourcePackageDesc) +import Distribution.Package (Package (packageId)) +import Distribution.PackageDescription.Configuration (flattenPackageDescription) +import Distribution.Simple.PackageDescription (readGenericPackageDescription) +import Distribution.Simple.PreProcess (knownSuffixHandlers) +import Distribution.Simple.SrcDist (listPackageSourcesWithDie) +import Distribution.Simple.Utils (die') +import Distribution.Types.GenericPackageDescription (GenericPackageDescription) + +import qualified Codec.Archive.Tar as Tar +import qualified Codec.Archive.Tar.Entry as Tar +import qualified Codec.Compression.GZip as GZip +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import qualified Data.Set as Set + +-- | List all source files of a given add-source dependency. Exits with error if +-- something is wrong (e.g. there is no .cabal file in the given directory). +-- +-- Used in sandbox and projectbuilding. +-- TODO: when sandboxes are removed, move to ProjectBuilding. +-- +allPackageSourceFiles :: Verbosity -> FilePath -> IO [FilePath] +allPackageSourceFiles verbosity packageDir = do + pd <- do + let err = "Error reading source files of package." + desc <- tryFindAddSourcePackageDesc verbosity packageDir err + flattenPackageDescription `fmap` readGenericPackageDescription verbosity desc + + listPackageSourcesWithDie verbosity (\_ _ -> return []) packageDir pd knownSuffixHandlers + +-- | Create a tarball for a package in a directory +packageDirToSdist + :: Verbosity + -> GenericPackageDescription -- ^ read in GPD + -> FilePath -- ^ directory containing that GPD + -> IO BSL.ByteString -- ^ resulting sdist tarball +packageDirToSdist verbosity gpd dir = do + let thisDie :: Verbosity -> String -> IO a + thisDie v s = die' v $ "sdist of " <> prettyShow (packageId gpd) ++ ": " ++ s + + files' <- listPackageSourcesWithDie verbosity thisDie dir (flattenPackageDescription gpd) knownSuffixHandlers + let files :: [FilePath] + files = nub $ sort $ map normalise files' + + let entriesM :: StateT (Set.Set FilePath) (WriterT [Tar.Entry] IO) () + entriesM = do + let prefix = prettyShow (packageId gpd) + modify (Set.insert prefix) + case Tar.toTarPath True prefix of + Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err) + Right path -> tell [Tar.directoryEntry path] + + for_ files $ \file -> do + let fileDir = takeDirectory (prefix file) + needsEntry <- gets (Set.notMember fileDir) + + when needsEntry $ do + modify (Set.insert fileDir) + case Tar.toTarPath True fileDir of + Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err) + Right path -> tell [Tar.directoryEntry path] + + contents <- liftIO . fmap BSL.fromStrict . BS.readFile $ dir file + case Tar.toTarPath False (prefix file) of + Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err) + Right path -> tell [(Tar.fileEntry path contents) { Tar.entryPermissions = Tar.ordinaryFilePermissions }] + + entries <- execWriterT (evalStateT entriesM mempty) + let -- Pretend our GZip file is made on Unix. + normalize bs = BSL.concat [pfx, "\x03", rest'] + where + (pfx, rest) = BSL.splitAt 9 bs + rest' = BSL.tail rest + -- The Unix epoch, which is the default value, is + -- unsuitable because it causes unpacking problems on + -- Windows; we need a post-1980 date. One gigasecond + -- after the epoch is during 2001-09-09, so that does + -- nicely. See #5596. + setModTime :: Tar.Entry -> Tar.Entry + setModTime entry = entry { Tar.entryTime = 1000000000 } + return . normalize . GZip.compress . Tar.write $ fmap setModTime entries diff --git a/cabal/cabal-install/src/Distribution/Client/Store.hs b/cabal/cabal-install/src/Distribution/Client/Store.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Store.hs @@ -0,0 +1,276 @@ +{-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns #-} + + +-- | Management for the installed package store. +-- +module Distribution.Client.Store ( + + -- * The store layout + StoreDirLayout(..), + defaultStoreDirLayout, + + -- * Reading store entries + getStoreEntries, + doesStoreEntryExist, + + -- * Creating store entries + newStoreEntry, + NewStoreEntryOutcome(..), + + -- * Concurrency strategy + -- $concurrency + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Distribution.Client.DistDirLayout +import Distribution.Client.RebuildMonad + +import Distribution.Package (UnitId, mkUnitId) +import Distribution.Compiler (CompilerId) + +import Distribution.Simple.Utils + ( withTempDirectory, debug, info ) +import Distribution.Verbosity + ( silent ) + +import qualified Data.Set as Set +import Control.Exception +import System.FilePath +import System.Directory + +#ifdef MIN_VERSION_lukko +import Lukko +#else +import System.IO (openFile, IOMode(ReadWriteMode), hClose) +import GHC.IO.Handle.Lock (hLock, hTryLock, LockMode(ExclusiveLock)) +#if MIN_VERSION_base(4,11,0) +import GHC.IO.Handle.Lock (hUnlock) +#endif +#endif + +-- $concurrency +-- +-- We access and update the store concurrently. Our strategy to do that safely +-- is as follows. +-- +-- The store entries once created are immutable. This alone simplifies matters +-- considerably. +-- +-- Additionally, the way 'UnitId' hashes are constructed means that if a store +-- entry exists already then we can assume its content is ok to reuse, rather +-- than having to re-recreate. This is the nix-style input hashing concept. +-- +-- A consequence of this is that with a little care it is /safe/ to race +-- updates against each other. Consider two independent concurrent builds that +-- both want to build a particular 'UnitId', where that entry does not yet +-- exist in the store. It is safe for both to build and try to install this +-- entry into the store provided that: +-- +-- * only one succeeds +-- * the looser discovers that they lost, they abandon their own build and +-- re-use the store entry installed by the winner. +-- +-- Note that because builds are not reproducible in general (nor even +-- necessarily ABI compatible) then it is essential that the loser abandon +-- their build and use the one installed by the winner, so that subsequent +-- packages are built against the exact package from the store rather than some +-- morally equivalent package that may not be ABI compatible. +-- +-- Our overriding goal is that store reads be simple, cheap and not require +-- locking. We will derive our write-side protocol to make this possible. +-- +-- The read-side protocol is simply: +-- +-- * check for the existence of a directory entry named after the 'UnitId' in +-- question. That is, if the dir entry @$root/foo-1.0-fe56a...@ exists then +-- the store entry can be assumed to be complete and immutable. +-- +-- Given our read-side protocol, the final step on the write side must be to +-- atomically rename a fully-formed store entry directory into its final +-- location. While this will indeed be the final step, the preparatory steps +-- are more complicated. The tricky aspect is that the store also contains a +-- number of shared package databases (one per compiler version). Our read +-- strategy means that by the time we install the store dir entry the package +-- db must already have been updated. We cannot do the package db update +-- as part of atomically renaming the store entry directory however. Furthermore +-- it is not safe to allow either package db update because the db entry +-- contains the ABI hash and this is not guaranteed to be deterministic. So we +-- must register the new package prior to the atomic dir rename. Since this +-- combination of steps are not atomic then we need locking. +-- +-- The write-side protocol is: +-- +-- * Create a unique temp dir and write all store entry files into it. +-- +-- * Take a lock named after the 'UnitId' in question. +-- +-- * Once holding the lock, check again for the existence of the final store +-- entry directory. If the entry exists then the process lost the race and it +-- must abandon, unlock and re-use the existing store entry. If the entry +-- does not exist then the process won the race and it can proceed. +-- +-- * Register the package into the package db. Note that the files are not in +-- their final location at this stage so registration file checks may need +-- to be disabled. +-- +-- * Atomically rename the temp dir to the final store entry location. +-- +-- * Release the previously-acquired lock. +-- +-- Obviously this means it is possible to fail after registering but before +-- installing the store entry, leaving a dangling package db entry. This is not +-- much of a problem because this entry does not determine package existence +-- for cabal. It does mean however that the package db update should be insert +-- or replace, i.e. not failing if the db entry already exists. + + +-- | Check if a particular 'UnitId' exists in the store. +-- +doesStoreEntryExist :: StoreDirLayout -> CompilerId -> UnitId -> IO Bool +doesStoreEntryExist StoreDirLayout{storePackageDirectory} compid unitid = + doesDirectoryExist (storePackageDirectory compid unitid) + + +-- | Return the 'UnitId's of all packages\/components already installed in the +-- store. +-- +getStoreEntries :: StoreDirLayout -> CompilerId -> Rebuild (Set UnitId) +getStoreEntries StoreDirLayout{storeDirectory} compid = do + paths <- getDirectoryContentsMonitored (storeDirectory compid) + return $! mkEntries paths + where + mkEntries = Set.delete (mkUnitId "package.db") + . Set.delete (mkUnitId "incoming") + . Set.fromList + . map mkUnitId + . filter valid + valid ('.':_) = False + valid _ = True + + +-- | The outcome of 'newStoreEntry': either the store entry was newly created +-- or it existed already. The latter case happens if there was a race between +-- two builds of the same store entry. +-- +data NewStoreEntryOutcome = UseNewStoreEntry + | UseExistingStoreEntry + deriving (Eq, Show) + +-- | Place a new entry into the store. See the concurrency strategy description +-- for full details. +-- +-- In particular, it takes two actions: one to place files into a temporary +-- location, and a second to perform any necessary registration. The first +-- action is executed without any locks held (the temp dir is unique). The +-- second action holds a lock that guarantees that only one cabal process is +-- able to install this store entry. This means it is safe to register into +-- the compiler package DB or do other similar actions. +-- +-- Note that if you need to use the registration information later then you +-- /must/ check the 'NewStoreEntryOutcome' and if it's'UseExistingStoreEntry' +-- then you must read the existing registration information (unless your +-- registration information is constructed fully deterministically). +-- +newStoreEntry :: Verbosity + -> StoreDirLayout + -> CompilerId + -> UnitId + -> (FilePath -> IO (FilePath, [FilePath])) -- ^ Action to place files. + -> IO () -- ^ Register action, if necessary. + -> IO NewStoreEntryOutcome +newStoreEntry verbosity storeDirLayout@StoreDirLayout{..} + compid unitid + copyFiles register = + -- See $concurrency above for an explanation of the concurrency protocol + + withTempIncomingDir storeDirLayout compid $ \incomingTmpDir -> do + + -- Write all store entry files within the temp dir and return the prefix. + (incomingEntryDir, otherFiles) <- copyFiles incomingTmpDir + + -- Take a lock named after the 'UnitId' in question. + withIncomingUnitIdLock verbosity storeDirLayout compid unitid $ do + + -- Check for the existence of the final store entry directory. + exists <- doesStoreEntryExist storeDirLayout compid unitid + + if exists + -- If the entry exists then we lost the race and we must abandon, + -- unlock and re-use the existing store entry. + then do + info verbosity $ + "Concurrent build race: abandoning build in favour of existing " + ++ "store entry " ++ prettyShow compid prettyShow unitid + return UseExistingStoreEntry + + -- If the entry does not exist then we won the race and can proceed. + else do + + -- Register the package into the package db (if appropriate). + register + + -- Atomically rename the temp dir to the final store entry location. + renameDirectory incomingEntryDir finalEntryDir + for_ otherFiles $ \file -> do + let finalStoreFile = storeDirectory compid makeRelative (incomingTmpDir (dropDrive (storeDirectory compid))) file + createDirectoryIfMissing True (takeDirectory finalStoreFile) + renameFile file finalStoreFile + + debug verbosity $ + "Installed store entry " ++ prettyShow compid prettyShow unitid + return UseNewStoreEntry + where + finalEntryDir = storePackageDirectory compid unitid + + +withTempIncomingDir :: StoreDirLayout -> CompilerId + -> (FilePath -> IO a) -> IO a +withTempIncomingDir StoreDirLayout{storeIncomingDirectory} compid action = do + createDirectoryIfMissing True incomingDir + withTempDirectory silent incomingDir "new" action + where + incomingDir = storeIncomingDirectory compid + + +withIncomingUnitIdLock :: Verbosity -> StoreDirLayout + -> CompilerId -> UnitId + -> IO a -> IO a +withIncomingUnitIdLock verbosity StoreDirLayout{storeIncomingLock} + compid unitid action = + bracket takeLock releaseLock (\_hnd -> action) + where +#ifdef MIN_VERSION_lukko + takeLock + | fileLockingSupported = do + fd <- fdOpen (storeIncomingLock compid unitid) + gotLock <- fdTryLock fd ExclusiveLock + unless gotLock $ do + info verbosity $ "Waiting for file lock on store entry " + ++ prettyShow compid prettyShow unitid + fdLock fd ExclusiveLock + return fd + + -- if there's no locking, do nothing. Be careful on AIX. + | otherwise = return undefined -- :( + + releaseLock fd + | fileLockingSupported = do + fdUnlock fd + fdClose fd + | otherwise = return () +#else + takeLock = do + h <- openFile (storeIncomingLock compid unitid) ReadWriteMode + -- First try non-blocking, but if we would have to wait then + -- log an explanation and do it again in blocking mode. + gotlock <- hTryLock h ExclusiveLock + unless gotlock $ do + info verbosity $ "Waiting for file lock on store entry " + ++ prettyShow compid prettyShow unitid + hLock h ExclusiveLock + return h + + releaseLock h = hUnlock h >> hClose h +#endif diff --git a/cabal/cabal-install/src/Distribution/Client/Tar.hs b/cabal/cabal-install/src/Distribution/Client/Tar.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Tar.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Tar +-- Copyright : (c) 2007 Bjorn Bringert, +-- 2008 Andrea Vezzosi, +-- 2008-2009 Duncan Coutts +-- License : BSD3 +-- +-- Maintainer : duncan@community.haskell.org +-- Portability : portable +-- +-- Reading, writing and manipulating \"@.tar@\" archive files. +-- +----------------------------------------------------------------------------- +module Distribution.Client.Tar ( + -- * @tar.gz@ operations + createTarGzFile, + extractTarGzFile, + + -- * Other local utils + buildTreeRefTypeCode, + buildTreeSnapshotTypeCode, + isBuildTreeRefTypeCode, + filterEntries, + filterEntriesM, + entriesToList, + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import qualified Data.ByteString.Lazy as BS +import qualified Codec.Archive.Tar as Tar +import qualified Codec.Archive.Tar.Entry as Tar +import qualified Codec.Archive.Tar.Check as Tar +import qualified Codec.Compression.GZip as GZip +import qualified Distribution.Client.GZipUtils as GZipUtils + +-- for foldEntries... +import Control.Exception (throw) + +-- +-- * High level operations +-- + +createTarGzFile :: FilePath -- ^ Full Tarball path + -> FilePath -- ^ Base directory + -> FilePath -- ^ Directory to archive, relative to base dir + -> IO () +createTarGzFile tar base dir = + BS.writeFile tar . GZip.compress . Tar.write =<< Tar.pack base [dir] + +extractTarGzFile :: FilePath -- ^ Destination directory + -> FilePath -- ^ Expected subdir (to check for tarbombs) + -> FilePath -- ^ Tarball + -> IO () +extractTarGzFile dir expected tar = + Tar.unpack dir . Tar.checkTarbomb expected . Tar.read + . GZipUtils.maybeDecompress =<< BS.readFile tar + +instance (Exception a, Exception b) => Exception (Either a b) where + toException (Left e) = toException e + toException (Right e) = toException e + + fromException e = + case fromException e of + Just e' -> Just (Left e') + Nothing -> case fromException e of + Just e' -> Just (Right e') + Nothing -> Nothing + + +-- | Type code for the local build tree reference entry type. We don't use the +-- symbolic link entry type because it allows only 100 ASCII characters for the +-- path. +buildTreeRefTypeCode :: Tar.TypeCode +buildTreeRefTypeCode = 'C' + +-- | Type code for the local build tree snapshot entry type. +buildTreeSnapshotTypeCode :: Tar.TypeCode +buildTreeSnapshotTypeCode = 'S' + +-- | Is this a type code for a build tree reference? +isBuildTreeRefTypeCode :: Tar.TypeCode -> Bool +isBuildTreeRefTypeCode typeCode + | (typeCode == buildTreeRefTypeCode + || typeCode == buildTreeSnapshotTypeCode) = True + | otherwise = False + +filterEntries :: (Tar.Entry -> Bool) -> Tar.Entries e -> Tar.Entries e +filterEntries p = + Tar.foldEntries + (\e es -> if p e then Tar.Next e es else es) + Tar.Done + Tar.Fail + +filterEntriesM :: Monad m => (Tar.Entry -> m Bool) + -> Tar.Entries e -> m (Tar.Entries e) +filterEntriesM p = + Tar.foldEntries + (\entry rest -> do + keep <- p entry + xs <- rest + if keep + then return (Tar.Next entry xs) + else return xs) + (return Tar.Done) + (return . Tar.Fail) + +entriesToList :: Exception e => Tar.Entries e -> [Tar.Entry] +entriesToList = Tar.foldEntries (:) [] throw + diff --git a/cabal/cabal-install/src/Distribution/Client/TargetProblem.hs b/cabal/cabal-install/src/Distribution/Client/TargetProblem.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/TargetProblem.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE DeriveFunctor #-} +module Distribution.Client.TargetProblem ( + TargetProblem(..), + TargetProblem', +) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Client.ProjectPlanning (AvailableTarget) +import Distribution.Client.TargetSelector (SubComponentTarget, TargetSelector) +import Distribution.Package (PackageId, PackageName) +import Distribution.Simple.LocalBuildInfo (ComponentName (..)) +import Distribution.Types.UnqualComponentName (UnqualComponentName) + +-- | Target problems that occur during project orchestration. +data TargetProblem a + = TargetNotInProject PackageName + | TargetAvailableInIndex PackageName + + | TargetComponentNotProjectLocal + PackageId ComponentName SubComponentTarget + + | TargetComponentNotBuildable + PackageId ComponentName SubComponentTarget + + | TargetOptionalStanzaDisabledByUser + PackageId ComponentName SubComponentTarget + + | TargetOptionalStanzaDisabledBySolver + PackageId ComponentName SubComponentTarget + + | TargetProblemUnknownComponent + PackageName (Either UnqualComponentName ComponentName) + + | TargetProblemNoneEnabled TargetSelector [AvailableTarget ()] + -- ^ The 'TargetSelector' matches component (test/benchmark/...) but none are buildable + + | TargetProblemNoTargets TargetSelector + -- ^ There are no targets at all + + -- The target matching stuff only returns packages local to the project, + -- so these lookups should never fail, but if 'resolveTargets' is called + -- directly then of course it can. + | TargetProblemNoSuchPackage PackageId + | TargetProblemNoSuchComponent PackageId ComponentName + + -- | A custom target problem + | CustomTargetProblem a + deriving (Eq, Show, Functor) + +-- | Type alias for a 'TargetProblem' with no user-defined problems/errors. +-- +-- Can use the utilities below for reporting/rendering problems. +type TargetProblem' = TargetProblem Void diff --git a/cabal/cabal-install/src/Distribution/Client/TargetSelector.hs b/cabal/cabal-install/src/Distribution/Client/TargetSelector.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/TargetSelector.hs @@ -0,0 +1,2529 @@ +{-# LANGUAGE CPP, DeriveGeneric, DeriveFunctor, + RecordWildCards, NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- TODO +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.TargetSelector +-- Copyright : (c) Duncan Coutts 2012, 2015, 2016 +-- License : BSD-like +-- +-- Maintainer : duncan@community.haskell.org +-- +-- Handling for user-specified target selectors. +-- +----------------------------------------------------------------------------- +module Distribution.Client.TargetSelector ( + + -- * Target selectors + TargetSelector(..), + TargetImplicitCwd(..), + ComponentKind(..), + ComponentKindFilter, + SubComponentTarget(..), + QualLevel(..), + componentKind, + + -- * Reading target selectors + readTargetSelectors, + TargetSelectorProblem(..), + reportTargetSelectorProblems, + showTargetSelector, + TargetString(..), + showTargetString, + parseTargetString, + -- ** non-IO + readTargetSelectorsWith, + DirActions(..), + defaultDirActions, + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Distribution.Package + ( Package(..), PackageId, PackageName, packageName ) +import Distribution.Types.UnqualComponentName + ( UnqualComponentName, mkUnqualComponentName, unUnqualComponentName + , packageNameToUnqualComponentName ) +import Distribution.Client.Types + ( PackageLocation(..), PackageSpecifier(..) ) + +import Distribution.PackageDescription + ( PackageDescription + , Executable(..) + , TestSuite(..), TestSuiteInterface(..), testModules + , Benchmark(..), BenchmarkInterface(..), benchmarkModules + , BuildInfo(..), explicitLibModules, exeModules ) +import Distribution.PackageDescription.Configuration + ( flattenPackageDescription ) +import Distribution.Solver.Types.SourcePackage + ( SourcePackage(..) ) +import Distribution.ModuleName + ( ModuleName, toFilePath ) +import Distribution.Simple.LocalBuildInfo + ( Component(..), ComponentName(..), LibraryName(..) + , pkgComponents, componentName, componentBuildInfo ) +import Distribution.Types.ForeignLib + +import Distribution.Simple.Utils + ( die', lowercase, ordNub ) +import Distribution.Client.Utils + ( makeRelativeCanonical ) + +import Data.List + ( stripPrefix, groupBy ) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Lazy as Map.Lazy +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import Control.Arrow ((&&&)) +import Control.Monad + hiding ( mfilter ) +import qualified Distribution.Deprecated.ReadP as Parse +import Distribution.Deprecated.ReadP + ( (+++), (<++) ) +import Distribution.Deprecated.ParseUtils + ( readPToMaybe ) +import System.FilePath as FilePath + ( takeExtension, dropExtension + , splitDirectories, joinPath, splitPath ) +import qualified System.Directory as IO + ( doesFileExist, doesDirectoryExist, canonicalizePath + , getCurrentDirectory ) +import System.FilePath + ( (), (<.>), normalise, dropTrailingPathSeparator, equalFilePath ) +import Text.EditDistance + ( defaultEditCosts, restrictedDamerauLevenshteinDistance ) +import Distribution.Utils.Path + +import qualified Prelude (foldr1) + +-- ------------------------------------------------------------ +-- * Target selector terms +-- ------------------------------------------------------------ + +-- | A target selector is expression selecting a set of components (as targets +-- for a 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, +-- component names, files etc. Internally we consider a target to be a specific +-- component (or module\/file within a component), and all the users' notions +-- of targets are just different ways of referring to these component targets. +-- +-- So target selectors are expressions in the sense that they are interpreted +-- to refer to one or more components. For example a 'TargetPackage' gets +-- interpreted differently by different commands to refer to all or a subset +-- of components within the package. +-- +-- The syntax has lots of optional parts: +-- +-- > [ package name | package dir | package .cabal file ] +-- > [ [lib:|exe:] component name ] +-- > [ module name | source file ] +-- +data TargetSelector = + + -- | One (or more) packages as a whole, or all the components of a + -- particular kind within the package(s). + -- + -- These are always packages that are local to the project. In the case + -- that there is more than one, they all share the same directory location. + -- + TargetPackage TargetImplicitCwd [PackageId] (Maybe ComponentKindFilter) + + -- | A package specified by name. This may refer to @extra-packages@ from + -- the @cabal.project@ file, or a dependency of a known project package or + -- could refer to a package from a hackage archive. It needs further + -- context to resolve to a specific package. + -- + | TargetPackageNamed PackageName (Maybe ComponentKindFilter) + + -- | All packages, or all components of a particular kind in all packages. + -- + | TargetAllPackages (Maybe ComponentKindFilter) + + -- | A specific component in a package within the project. + -- + | TargetComponent PackageId ComponentName SubComponentTarget + + -- | A component in a package, but where it cannot be verified that the + -- package has such a component, or because the package is itself not + -- known. + -- + | TargetComponentUnknown PackageName + (Either UnqualComponentName ComponentName) + SubComponentTarget + deriving (Eq, Ord, Show, Generic) + +-- | Does this 'TargetPackage' selector arise from syntax referring to a +-- package in the current directory (e.g. @tests@ or no giving no explicit +-- target at all) or does it come from syntax referring to a package name +-- or location. +-- +data TargetImplicitCwd = TargetImplicitCwd | TargetExplicitNamed + deriving (Eq, Ord, Show, Generic) + +data ComponentKind = LibKind | FLibKind | ExeKind | TestKind | BenchKind + deriving (Eq, Ord, Enum, Show) + +type ComponentKindFilter = ComponentKind + +-- | Either the component as a whole or detail about a file or module target +-- within a component. +-- +data SubComponentTarget = + + -- | The component as a whole + WholeComponent + + -- | A specific module within a component. + | ModuleTarget ModuleName + + -- | A specific file within a component. Note that this does not carry the + -- file extension. + | FileTarget FilePath + deriving (Eq, Ord, Show, Generic) + +instance Binary SubComponentTarget +instance Structured SubComponentTarget + + +-- ------------------------------------------------------------ +-- * Top level, do everything +-- ------------------------------------------------------------ + + +-- | Parse a bunch of command line args as 'TargetSelector's, failing with an +-- error if any are unrecognised. The possible target selectors are based on +-- the available packages (and their locations). +-- +readTargetSelectors :: [PackageSpecifier (SourcePackage (PackageLocation a))] + -> Maybe ComponentKindFilter + -- ^ This parameter is used when there are ambiguous selectors. + -- If it is 'Just', then we attempt to resolve ambiguity + -- by applying it, since otherwise there is no way to allow + -- contextually valid yet syntactically ambiguous selectors. + -- (#4676, #5461) + -> [String] + -> IO (Either [TargetSelectorProblem] [TargetSelector]) +readTargetSelectors = readTargetSelectorsWith defaultDirActions + +readTargetSelectorsWith :: (Applicative m, Monad m) => DirActions m + -> [PackageSpecifier (SourcePackage (PackageLocation a))] + -> Maybe ComponentKindFilter + -> [String] + -> m (Either [TargetSelectorProblem] [TargetSelector]) +readTargetSelectorsWith dirActions@DirActions{} pkgs mfilter targetStrs = + case parseTargetStrings targetStrs of + ([], usertargets) -> do + usertargets' <- traverse (getTargetStringFileStatus dirActions) usertargets + knowntargets <- getKnownTargets dirActions pkgs + case resolveTargetSelectors knowntargets usertargets' mfilter of + ([], btargets) -> return (Right btargets) + (problems, _) -> return (Left problems) + (strs, _) -> return (Left (map TargetSelectorUnrecognised strs)) + + +data DirActions m = DirActions { + doesFileExist :: FilePath -> m Bool, + doesDirectoryExist :: FilePath -> m Bool, + canonicalizePath :: FilePath -> m FilePath, + getCurrentDirectory :: m FilePath + } + +defaultDirActions :: DirActions IO +defaultDirActions = + DirActions { + doesFileExist = IO.doesFileExist, + doesDirectoryExist = IO.doesDirectoryExist, + -- Workaround for + canonicalizePath = IO.canonicalizePath . dropTrailingPathSeparator, + getCurrentDirectory = IO.getCurrentDirectory + } + +makeRelativeToCwd :: Applicative m => DirActions m -> FilePath -> m FilePath +makeRelativeToCwd DirActions{..} path = + makeRelativeCanonical <$> canonicalizePath path <*> getCurrentDirectory + + +-- ------------------------------------------------------------ +-- * Parsing target strings +-- ------------------------------------------------------------ + +-- | The outline parse of a target selector. It takes one of the forms: +-- +-- > str1 +-- > str1:str2 +-- > str1:str2:str3 +-- > str1:str2:str3:str4 +-- +data TargetString = + TargetString1 String + | TargetString2 String String + | TargetString3 String String String + | TargetString4 String String String String + | TargetString5 String String String String String + | TargetString7 String String String String String String String + deriving (Show, Eq) + +-- | Parse a bunch of 'TargetString's (purely without throwing exceptions). +-- +parseTargetStrings :: [String] -> ([String], [TargetString]) +parseTargetStrings = + partitionEithers + . map (\str -> maybe (Left str) Right (parseTargetString str)) + +parseTargetString :: String -> Maybe TargetString +parseTargetString = + readPToMaybe parseTargetApprox + where + parseTargetApprox :: Parse.ReadP r TargetString + parseTargetApprox = + (do a <- tokenQ + return (TargetString1 a)) + +++ (do a <- tokenQ0 + _ <- Parse.char ':' + b <- tokenQ + return (TargetString2 a b)) + +++ (do a <- tokenQ0 + _ <- Parse.char ':' + b <- tokenQ + _ <- Parse.char ':' + c <- tokenQ + return (TargetString3 a b c)) + +++ (do a <- tokenQ0 + _ <- Parse.char ':' + b <- token + _ <- Parse.char ':' + c <- tokenQ + _ <- Parse.char ':' + d <- tokenQ + return (TargetString4 a b c d)) + +++ (do a <- tokenQ0 + _ <- Parse.char ':' + b <- token + _ <- Parse.char ':' + c <- tokenQ + _ <- Parse.char ':' + d <- tokenQ + _ <- Parse.char ':' + e <- tokenQ + return (TargetString5 a b c d e)) + +++ (do a <- tokenQ0 + _ <- Parse.char ':' + b <- token + _ <- Parse.char ':' + c <- tokenQ + _ <- Parse.char ':' + d <- tokenQ + _ <- Parse.char ':' + e <- tokenQ + _ <- Parse.char ':' + f <- tokenQ + _ <- Parse.char ':' + g <- tokenQ + return (TargetString7 a b c d e f g)) + + token = Parse.munch1 (\x -> not (isSpace x) && x /= ':') + tokenQ = parseHaskellString <++ token + token0 = Parse.munch (\x -> not (isSpace x) && x /= ':') + tokenQ0= parseHaskellString <++ token0 + parseHaskellString :: Parse.ReadP r String + parseHaskellString = Parse.readS_to_P reads + + +-- | Render a 'TargetString' back as the external syntax. This is mainly for +-- error messages. +-- +showTargetString :: TargetString -> String +showTargetString = intercalate ":" . components + where + components (TargetString1 s1) = [s1] + components (TargetString2 s1 s2) = [s1,s2] + components (TargetString3 s1 s2 s3) = [s1,s2,s3] + components (TargetString4 s1 s2 s3 s4) = [s1,s2,s3,s4] + components (TargetString5 s1 s2 s3 s4 s5) = [s1,s2,s3,s4,s5] + components (TargetString7 s1 s2 s3 s4 s5 s6 s7) = [s1,s2,s3,s4,s5,s6,s7] + +showTargetSelector :: TargetSelector -> String +showTargetSelector ts = + case [ t | ql <- [QL1 .. QLFull] + , t <- renderTargetSelector ql ts ] + of (t':_) -> showTargetString (forgetFileStatus t') + [] -> "" + +showTargetSelectorKind :: TargetSelector -> String +showTargetSelectorKind bt = case bt of + TargetPackage TargetExplicitNamed _ Nothing -> "package" + TargetPackage TargetExplicitNamed _ (Just _) -> "package:filter" + TargetPackage TargetImplicitCwd _ Nothing -> "cwd-package" + TargetPackage TargetImplicitCwd _ (Just _) -> "cwd-package:filter" + TargetPackageNamed _ Nothing -> "named-package" + TargetPackageNamed _ (Just _) -> "named-package:filter" + TargetAllPackages Nothing -> "package *" + TargetAllPackages (Just _) -> "package *:filter" + TargetComponent _ _ WholeComponent -> "component" + TargetComponent _ _ ModuleTarget{} -> "module" + TargetComponent _ _ FileTarget{} -> "file" + TargetComponentUnknown _ _ WholeComponent -> "unknown-component" + TargetComponentUnknown _ _ ModuleTarget{} -> "unknown-module" + TargetComponentUnknown _ _ FileTarget{} -> "unknown-file" + + +-- ------------------------------------------------------------ +-- * Checking if targets exist as files +-- ------------------------------------------------------------ + +data TargetStringFileStatus = + TargetStringFileStatus1 String FileStatus + | TargetStringFileStatus2 String FileStatus String + | TargetStringFileStatus3 String FileStatus String String + | TargetStringFileStatus4 String String String String + | TargetStringFileStatus5 String String String String String + | TargetStringFileStatus7 String String String String String String String + deriving (Eq, Ord, Show) + +data FileStatus = FileStatusExistsFile FilePath -- the canonicalised filepath + | FileStatusExistsDir FilePath -- the canonicalised filepath + | FileStatusNotExists Bool -- does the parent dir exist even? + deriving (Eq, Ord, Show) + +noFileStatus :: FileStatus +noFileStatus = FileStatusNotExists False + +getTargetStringFileStatus :: (Applicative m, Monad m) => DirActions m + -> TargetString -> m TargetStringFileStatus +getTargetStringFileStatus DirActions{..} t = + case t of + TargetString1 s1 -> + (\f1 -> TargetStringFileStatus1 s1 f1) <$> fileStatus s1 + TargetString2 s1 s2 -> + (\f1 -> TargetStringFileStatus2 s1 f1 s2) <$> fileStatus s1 + TargetString3 s1 s2 s3 -> + (\f1 -> TargetStringFileStatus3 s1 f1 s2 s3) <$> fileStatus s1 + TargetString4 s1 s2 s3 s4 -> + return (TargetStringFileStatus4 s1 s2 s3 s4) + TargetString5 s1 s2 s3 s4 s5 -> + return (TargetStringFileStatus5 s1 s2 s3 s4 s5) + TargetString7 s1 s2 s3 s4 s5 s6 s7 -> + return (TargetStringFileStatus7 s1 s2 s3 s4 s5 s6 s7) + where + fileStatus f = do + fexists <- doesFileExist f + dexists <- doesDirectoryExist f + case splitPath f of + _ | fexists -> FileStatusExistsFile <$> canonicalizePath f + | dexists -> FileStatusExistsDir <$> canonicalizePath f + (d:_) -> FileStatusNotExists <$> doesDirectoryExist d + _ -> pure (FileStatusNotExists False) + +forgetFileStatus :: TargetStringFileStatus -> TargetString +forgetFileStatus t = case t of + TargetStringFileStatus1 s1 _ -> TargetString1 s1 + TargetStringFileStatus2 s1 _ s2 -> TargetString2 s1 s2 + TargetStringFileStatus3 s1 _ s2 s3 -> TargetString3 s1 s2 s3 + TargetStringFileStatus4 s1 s2 s3 s4 -> TargetString4 s1 s2 s3 s4 + TargetStringFileStatus5 s1 s2 s3 s4 + s5 -> TargetString5 s1 s2 s3 s4 s5 + TargetStringFileStatus7 s1 s2 s3 s4 + s5 s6 s7 -> TargetString7 s1 s2 s3 s4 s5 s6 s7 + +getFileStatus :: TargetStringFileStatus -> Maybe FileStatus +getFileStatus (TargetStringFileStatus1 _ f) = Just f +getFileStatus (TargetStringFileStatus2 _ f _) = Just f +getFileStatus (TargetStringFileStatus3 _ f _ _) = Just f +getFileStatus _ = Nothing + +setFileStatus :: FileStatus -> TargetStringFileStatus -> TargetStringFileStatus +setFileStatus f (TargetStringFileStatus1 s1 _) = TargetStringFileStatus1 s1 f +setFileStatus f (TargetStringFileStatus2 s1 _ s2) = TargetStringFileStatus2 s1 f s2 +setFileStatus f (TargetStringFileStatus3 s1 _ s2 s3) = TargetStringFileStatus3 s1 f s2 s3 +setFileStatus _ t = t + +copyFileStatus :: TargetStringFileStatus -> TargetStringFileStatus -> TargetStringFileStatus +copyFileStatus src dst = + case getFileStatus src of + Just f -> setFileStatus f dst + Nothing -> dst + +-- ------------------------------------------------------------ +-- * Resolving target strings to target selectors +-- ------------------------------------------------------------ + + +-- | Given a bunch of user-specified targets, try to resolve what it is they +-- refer to. +-- +resolveTargetSelectors :: KnownTargets + -> [TargetStringFileStatus] + -> Maybe ComponentKindFilter + -> ([TargetSelectorProblem], + [TargetSelector]) +-- default local dir target if there's no given target: +resolveTargetSelectors (KnownTargets{knownPackagesAll = []}) [] _ = + ([TargetSelectorNoTargetsInProject], []) + +-- if the component kind filter is just exes, we don't want to suggest "all" as a target. +resolveTargetSelectors (KnownTargets{knownPackagesPrimary = []}) [] ckf = + ([TargetSelectorNoTargetsInCwd (ckf /= Just ExeKind) ], []) + +resolveTargetSelectors (KnownTargets{knownPackagesPrimary}) [] _ = + ([], [TargetPackage TargetImplicitCwd pkgids Nothing]) + where + pkgids = [ pinfoId | KnownPackage{pinfoId} <- knownPackagesPrimary ] + +resolveTargetSelectors knowntargets targetStrs mfilter = + partitionEithers + . map (resolveTargetSelector knowntargets mfilter) + $ targetStrs + +resolveTargetSelector :: KnownTargets + -> Maybe ComponentKindFilter + -> TargetStringFileStatus + -> Either TargetSelectorProblem TargetSelector +resolveTargetSelector knowntargets@KnownTargets{..} mfilter targetStrStatus = + case findMatch (matcher targetStrStatus) of + + Unambiguous _ + | projectIsEmpty -> Left TargetSelectorNoTargetsInProject + + Unambiguous (TargetPackage TargetImplicitCwd [] _) + -> Left (TargetSelectorNoCurrentPackage targetStr) + + Unambiguous target -> Right target + + None errs + | projectIsEmpty -> Left TargetSelectorNoTargetsInProject + | otherwise -> Left (classifyMatchErrors errs) + + Ambiguous _ targets + | Just kfilter <- mfilter + , [target] <- applyKindFilter kfilter targets -> Right target + + Ambiguous exactMatch targets -> + case disambiguateTargetSelectors + matcher targetStrStatus exactMatch + targets of + Right targets' -> Left (TargetSelectorAmbiguous targetStr targets') + Left ((m, ms):_) -> Left (MatchingInternalError targetStr m ms) + Left [] -> internalError "resolveTargetSelector" + where + matcher = matchTargetSelector knowntargets + + targetStr = forgetFileStatus targetStrStatus + + projectIsEmpty = null knownPackagesAll + + classifyMatchErrors errs + | Just expectedNE <- NE.nonEmpty expected + = let (things, got:|_) = NE.unzip expectedNE in + TargetSelectorExpected targetStr (NE.toList things) got + + | not (null nosuch) + = TargetSelectorNoSuch targetStr nosuch + + | otherwise + = internalError $ "classifyMatchErrors: " ++ show errs + where + expected = [ (thing, got) + | (_, MatchErrorExpected thing got) + <- map (innerErr Nothing) errs ] + -- Trim the list of alternatives by dropping duplicates and + -- retaining only at most three most similar (by edit distance) ones. + nosuch = Map.foldrWithKey genResults [] $ Map.fromListWith Set.union $ + [ ((inside, thing, got), Set.fromList alts) + | (inside, MatchErrorNoSuch thing got alts) + <- map (innerErr Nothing) errs + ] + + genResults (inside, thing, got) alts acc = ( + inside + , thing + , got + , take maxResults + $ map fst + $ takeWhile distanceLow + $ sortBy (comparing snd) + $ map addLevDist + $ Set.toList alts + ) : acc + where + addLevDist = id &&& restrictedDamerauLevenshteinDistance + defaultEditCosts got + + distanceLow (_, dist) = dist < length got `div` 2 + + maxResults = 3 + + innerErr _ (MatchErrorIn kind thing m) + = innerErr (Just (kind,thing)) m + innerErr c m = (c,m) + + applyKindFilter :: ComponentKindFilter -> [TargetSelector] -> [TargetSelector] + applyKindFilter kfilter = filter go + where + go (TargetPackage _ _ (Just filter')) = kfilter == filter' + go (TargetPackageNamed _ (Just filter')) = kfilter == filter' + go (TargetAllPackages (Just filter')) = kfilter == filter' + go (TargetComponent _ cname _) + | CLibName _ <- cname = kfilter == LibKind + | CFLibName _ <- cname = kfilter == FLibKind + | CExeName _ <- cname = kfilter == ExeKind + | CTestName _ <- cname = kfilter == TestKind + | CBenchName _ <- cname = kfilter == BenchKind + go _ = True + +-- | The various ways that trying to resolve a 'TargetString' to a +-- 'TargetSelector' can fail. +-- +data TargetSelectorProblem + = TargetSelectorExpected TargetString [String] String + -- ^ [expected thing] (actually got) + | TargetSelectorNoSuch TargetString + [(Maybe (String, String), String, String, [String])] + -- ^ [([in thing], no such thing, actually got, alternatives)] + | TargetSelectorAmbiguous TargetString + [(TargetString, TargetSelector)] + + | MatchingInternalError TargetString TargetSelector + [(TargetString, [TargetSelector])] + | TargetSelectorUnrecognised String + -- ^ Syntax error when trying to parse a target string. + | TargetSelectorNoCurrentPackage TargetString + | TargetSelectorNoTargetsInCwd Bool + -- ^ bool that flags when it is acceptable to suggest "all" as a target + | TargetSelectorNoTargetsInProject + | TargetSelectorNoScript TargetString + deriving (Show, Eq) + +-- | Qualification levels. +-- Given the filepath src/F, executable component A, and package foo: +data QualLevel = QL1 -- ^ @src/F@ + | QL2 -- ^ @foo:src/F | A:src/F@ + | QL3 -- ^ @foo:A:src/F | exe:A:src/F@ + | QLFull -- ^ @pkg:foo:exe:A:file:src/F@ + deriving (Eq, Enum, Show) + +disambiguateTargetSelectors + :: (TargetStringFileStatus -> Match TargetSelector) + -> TargetStringFileStatus -> MatchClass + -> [TargetSelector] + -> Either [(TargetSelector, [(TargetString, [TargetSelector])])] + [(TargetString, TargetSelector)] +disambiguateTargetSelectors matcher matchInput exactMatch matchResults = + case partitionEithers results of + (errs@(_:_), _) -> Left errs + ([], ok) -> Right ok + where + -- So, here's the strategy. We take the original match results, and make a + -- table of all their renderings at all qualification levels. + -- Note there can be multiple renderings at each qualification level. + + -- Note that renderTargetSelector won't immediately work on any file syntax + -- When rendering syntax, the FileStatus is always FileStatusNotExists, + -- which will never match on syntaxForm1File! + -- Because matchPackageDirectoryPrefix expects a FileStatusExistsFile. + -- So we need to copy over the file status from the input + -- TargetStringFileStatus, onto the new rendered TargetStringFileStatus + matchResultsRenderings :: [(TargetSelector, [TargetStringFileStatus])] + matchResultsRenderings = + [ (matchResult, matchRenderings) + | matchResult <- matchResults + , let matchRenderings = + [ copyFileStatus matchInput rendering + | ql <- [QL1 .. QLFull] + , rendering <- renderTargetSelector ql matchResult ] + ] + + -- Of course the point is that we're looking for renderings that are + -- unambiguous matches. So we build another memo table of all the matches + -- for all of those renderings. So by looking up in this table we can see + -- if we've got an unambiguous match. + + memoisedMatches :: Map TargetStringFileStatus (Match TargetSelector) + memoisedMatches = + -- avoid recomputing the main one if it was an exact match + (if exactMatch == Exact + then Map.insert matchInput (Match Exact 0 matchResults) + else id) + $ Map.Lazy.fromList + -- (matcher rendering) should *always* be a Match! Otherwise we will hit + -- the internal error later on. + [ (rendering, matcher rendering) + | rendering <- concatMap snd matchResultsRenderings ] + + -- Finally, for each of the match results, we go through all their + -- possible renderings (in order of qualification level, though remember + -- there can be multiple renderings per level), and find the first one + -- that has an unambiguous match. + results :: [Either (TargetSelector, [(TargetString, [TargetSelector])]) + (TargetString, TargetSelector)] + results = + [ case findUnambiguous originalMatch matchRenderings of + Just unambiguousRendering -> + Right ( forgetFileStatus unambiguousRendering + , originalMatch) + + -- This case is an internal error, but we bubble it up and report it + Nothing -> + Left ( originalMatch + , [ (forgetFileStatus rendering, matches) + | rendering <- matchRenderings + , let Match m _ matches = + memoisedMatches Map.! rendering + , m /= Inexact + ] ) + + | (originalMatch, matchRenderings) <- matchResultsRenderings ] + + findUnambiguous :: TargetSelector + -> [TargetStringFileStatus] + -> Maybe TargetStringFileStatus + findUnambiguous _ [] = Nothing + findUnambiguous t (r:rs) = + case memoisedMatches Map.! r of + Match Exact _ [t'] | t == t' + -> Just r + Match Exact _ _ -> findUnambiguous t rs + Match Unknown _ _ -> findUnambiguous t rs + Match Inexact _ _ -> internalError "Match Inexact" + NoMatch _ _ -> internalError "NoMatch" + +internalError :: String -> a +internalError msg = + error $ "TargetSelector: internal error: " ++ msg + + +-- | Throw an exception with a formatted message if there are any problems. +-- +reportTargetSelectorProblems :: Verbosity -> [TargetSelectorProblem] -> IO a +reportTargetSelectorProblems verbosity problems = do + + case [ str | TargetSelectorUnrecognised str <- problems ] of + [] -> return () + targets -> + die' verbosity $ unlines + [ "Unrecognised target syntax for '" ++ name ++ "'." + | name <- targets ] + + case [ (t, m, ms) | MatchingInternalError t m ms <- problems ] of + [] -> return () + ((target, originalMatch, renderingsAndMatches):_) -> + die' verbosity $ "Internal error in target matching. It should always " + ++ "be possible to find a syntax that's sufficiently qualified to " + ++ "give an unambiguous match. However when matching '" + ++ showTargetString target ++ "' we found " + ++ showTargetSelector originalMatch + ++ " (" ++ showTargetSelectorKind originalMatch ++ ") which does " + ++ "not have an unambiguous syntax. The possible syntax and the " + ++ "targets they match are as follows:\n" + ++ unlines + [ "'" ++ showTargetString rendering ++ "' which matches " + ++ intercalate ", " + [ showTargetSelector match ++ + " (" ++ showTargetSelectorKind match ++ ")" + | match <- matches ] + | (rendering, matches) <- renderingsAndMatches ] + + case [ (t, e, g) | TargetSelectorExpected t e g <- problems ] of + [] -> return () + targets -> + die' verbosity $ unlines + [ "Unrecognised target '" ++ showTargetString target + ++ "'.\n" + ++ "Expected a " ++ intercalate " or " expected + ++ ", rather than '" ++ got ++ "'." + | (target, expected, got) <- targets ] + + case [ (t, e) | TargetSelectorNoSuch t e <- problems ] of + [] -> return () + targets -> + die' verbosity $ unlines + [ "Unknown target '" ++ showTargetString target ++ + "'.\n" ++ unlines + [ (case inside of + Just (kind, "") + -> "The " ++ kind ++ " has no " + Just (kind, thing) + -> "The " ++ kind ++ " " ++ thing ++ " has no " + Nothing -> "There is no ") + ++ intercalate " or " [ mungeThing thing ++ " '" ++ got ++ "'" + | (thing, got, _alts) <- nosuch' ] ++ "." + ++ if null alternatives then "" else + "\nPerhaps you meant " ++ intercalate ";\nor " + [ "the " ++ thing ++ " '" ++ intercalate "' or '" alts ++ "'?" + | (thing, alts) <- alternatives ] + | (inside, nosuch') <- groupByContainer nosuch + , let alternatives = + [ (thing, alts) + | (thing,_got,alts@(_:_)) <- nosuch' ] + ] + | (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 + + case [ (t, ts) | TargetSelectorAmbiguous t ts <- problems ] of + [] -> return () + targets -> + die' verbosity $ unlines + [ "Ambiguous target '" ++ showTargetString target + ++ "'. It could be:\n " + ++ unlines [ " "++ showTargetString ut ++ + " (" ++ showTargetSelectorKind bt ++ ")" + | (ut, bt) <- amb ] + | (target, amb) <- targets ] + + case [ t | TargetSelectorNoCurrentPackage t <- problems ] of + [] -> return () + target:_ -> + die' verbosity $ + "The target '" ++ showTargetString target ++ "' refers to the " + ++ "components in the package in the current directory, but there " + ++ "is no package in the current directory (or at least not listed " + ++ "as part of the project)." + --TODO: report a different error if there is a .cabal file but it's + -- not a member of the project + + case [ () | TargetSelectorNoTargetsInCwd True <- problems ] of + [] -> return () + _:_ -> + die' verbosity $ + "No targets given and there is no package in the current " + ++ "directory. Use the target 'all' for all packages in the " + ++ "project or specify packages or components by name or location. " + ++ "See 'cabal build --help' for more details on target options." + + case [ () | TargetSelectorNoTargetsInCwd False <- problems ] of + [] -> return () + _:_ -> + die' verbosity $ + "No targets given and there is no package in the current " + ++ "directory. Specify packages or components by name or location. " + ++ "See 'cabal build --help' for more details on target options." + + case [ () | TargetSelectorNoTargetsInProject <- problems ] of + [] -> return () + _:_ -> + die' verbosity $ + "There is no .cabal package file or cabal.project file. " + ++ "To build packages locally you need at minimum a .cabal " + ++ "file. You can use 'cabal init' to create one.\n" + ++ "\n" + ++ "For non-trivial projects you will also want a cabal.project " + ++ "file in the root directory of your project. This file lists the " + ++ "packages in your project and all other build configuration. " + ++ "See the Cabal user guide for full details." + + case [ t | TargetSelectorNoScript t <- problems ] of + [] -> return () + target:_ -> + die' verbosity $ + "The script '" ++ showTargetString target ++ "' does not exist, " + ++ "and only script targets may contain whitespace characters or end " + ++ "with ':'" + + fail "reportTargetSelectorProblems: internal error" + + +---------------------------------- +-- Syntax type +-- + +-- | Syntax for the 'TargetSelector': the matcher and renderer +-- +data Syntax = Syntax QualLevel Matcher Renderer + | AmbiguousAlternatives Syntax Syntax + | ShadowingAlternatives Syntax Syntax + +type Matcher = TargetStringFileStatus -> Match TargetSelector +type Renderer = TargetSelector -> [TargetStringFileStatus] + +foldSyntax :: (a -> a -> a) -> (a -> a -> a) + -> (QualLevel -> Matcher -> Renderer -> a) + -> (Syntax -> a) +foldSyntax ambiguous unambiguous syntax = go + where + go (Syntax ql match render) = syntax ql match render + go (AmbiguousAlternatives a b) = ambiguous (go a) (go b) + go (ShadowingAlternatives a b) = unambiguous (go a) (go b) + + +---------------------------------- +-- Top level renderer and matcher +-- + +renderTargetSelector :: QualLevel -> TargetSelector + -> [TargetStringFileStatus] +renderTargetSelector ql ts = + foldSyntax + (++) (++) + (\ql' _ render -> guard (ql == ql') >> render ts) + syntax + where + syntax = syntaxForms emptyKnownTargets + -- don't need known targets for rendering + +matchTargetSelector :: KnownTargets + -> TargetStringFileStatus + -> Match TargetSelector +matchTargetSelector knowntargets = \usertarget -> + nubMatchesBy (==) $ + + let ql = targetQualLevel usertarget in + foldSyntax + (<|>) () + (\ql' match _ -> guard (ql == ql') >> match usertarget) + syntax + where + syntax = syntaxForms knowntargets + + targetQualLevel TargetStringFileStatus1{} = QL1 + targetQualLevel TargetStringFileStatus2{} = QL2 + targetQualLevel TargetStringFileStatus3{} = QL3 + targetQualLevel TargetStringFileStatus4{} = QLFull + targetQualLevel TargetStringFileStatus5{} = QLFull + targetQualLevel TargetStringFileStatus7{} = QLFull + + +---------------------------------- +-- Syntax forms +-- + +-- | All the forms of syntax for 'TargetSelector'. +-- +syntaxForms :: KnownTargets -> Syntax +syntaxForms KnownTargets { + knownPackagesAll = pinfo, + knownPackagesPrimary = ppinfo, + knownComponentsAll = cinfo, + knownComponentsPrimary = pcinfo, + knownComponentsOther = ocinfo + } = + -- The various forms of syntax here are ambiguous in many cases. + -- Our policy is by default we expose that ambiguity and report + -- ambiguous matches. In certain cases we override the ambiguity + -- by having some forms shadow others. + -- + -- We make modules shadow files because module name "Q" clashes + -- with file "Q" with no extension but these refer to the same + -- thing anyway so it's not a useful ambiguity. Other cases are + -- not ambiguous like "Q" vs "Q.hs" or "Data.Q" vs "Data/Q". + + ambiguousAlternatives + -- convenient single-component forms + [ shadowingAlternatives + [ ambiguousAlternatives + [ syntaxForm1All + , syntaxForm1Filter ppinfo + , shadowingAlternatives + [ syntaxForm1Component pcinfo + , syntaxForm1Package pinfo + ] + ] + , syntaxForm1Component ocinfo + , syntaxForm1Module cinfo + , syntaxForm1File pinfo + ] + + -- two-component partially qualified forms + -- fully qualified form for 'all' + , syntaxForm2MetaAll + , syntaxForm2AllFilter + , syntaxForm2NamespacePackage pinfo + , syntaxForm2PackageComponent pinfo + , syntaxForm2PackageFilter pinfo + , syntaxForm2KindComponent cinfo + , shadowingAlternatives + [ syntaxForm2PackageModule pinfo + , syntaxForm2PackageFile pinfo + ] + , shadowingAlternatives + [ syntaxForm2ComponentModule cinfo + , syntaxForm2ComponentFile cinfo + ] + + -- rarely used partially qualified forms + , syntaxForm3PackageKindComponent pinfo + , shadowingAlternatives + [ syntaxForm3PackageComponentModule pinfo + , syntaxForm3PackageComponentFile pinfo + ] + , shadowingAlternatives + [ syntaxForm3KindComponentModule cinfo + , syntaxForm3KindComponentFile cinfo + ] + , syntaxForm3NamespacePackageFilter pinfo + + -- fully-qualified forms for all and cwd with filter + , syntaxForm3MetaAllFilter + , syntaxForm3MetaCwdFilter ppinfo + + -- fully-qualified form for package and package with filter + , syntaxForm3MetaNamespacePackage pinfo + , syntaxForm4MetaNamespacePackageFilter pinfo + + -- fully-qualified forms for component, module and file + , syntaxForm5MetaNamespacePackageKindComponent pinfo + , syntaxForm7MetaNamespacePackageKindComponentNamespaceModule pinfo + , syntaxForm7MetaNamespacePackageKindComponentNamespaceFile pinfo + ] + where + ambiguousAlternatives = Prelude.foldr1 AmbiguousAlternatives + shadowingAlternatives = Prelude.foldr1 ShadowingAlternatives + + +-- | Syntax: "all" to select all packages in the project +-- +-- > cabal build all +-- +syntaxForm1All :: Syntax +syntaxForm1All = + syntaxForm1 render $ \str1 _fstatus1 -> do + guardMetaAll str1 + return (TargetAllPackages Nothing) + where + render (TargetAllPackages Nothing) = + [TargetStringFileStatus1 "all" noFileStatus] + render _ = [] + +-- | Syntax: filter +-- +-- > cabal build tests +-- +syntaxForm1Filter :: [KnownPackage] -> Syntax +syntaxForm1Filter ps = + syntaxForm1 render $ \str1 _fstatus1 -> do + kfilter <- matchComponentKindFilter str1 + return (TargetPackage TargetImplicitCwd pids (Just kfilter)) + where + pids = [ pinfoId | KnownPackage{pinfoId} <- ps ] + render (TargetPackage TargetImplicitCwd _ (Just kfilter)) = + [TargetStringFileStatus1 (dispF kfilter) noFileStatus] + render _ = [] + + +-- | Syntax: package (name, dir or file) +-- +-- > cabal build foo +-- > cabal build ../bar ../bar/bar.cabal +-- +syntaxForm1Package :: [KnownPackage] -> Syntax +syntaxForm1Package pinfo = + syntaxForm1 render $ \str1 fstatus1 -> do + guardPackage str1 fstatus1 + p <- matchPackage pinfo str1 fstatus1 + case p of + KnownPackage{pinfoId} -> + return (TargetPackage TargetExplicitNamed [pinfoId] Nothing) + KnownPackageName pn -> + return (TargetPackageNamed pn Nothing) + where + render (TargetPackage TargetExplicitNamed [p] Nothing) = + [TargetStringFileStatus1 (dispP p) noFileStatus] + render (TargetPackageNamed pn Nothing) = + [TargetStringFileStatus1 (dispPN pn) noFileStatus] + render _ = [] + +-- | Syntax: component +-- +-- > cabal build foo +-- +syntaxForm1Component :: [KnownComponent] -> Syntax +syntaxForm1Component cs = + syntaxForm1 render $ \str1 _fstatus1 -> do + guardComponentName str1 + c <- matchComponentName cs str1 + return (TargetComponent (cinfoPackageId c) (cinfoName c) WholeComponent) + where + render (TargetComponent p c WholeComponent) = + [TargetStringFileStatus1 (dispC p c) noFileStatus] + render _ = [] + +-- | Syntax: module +-- +-- > cabal build Data.Foo +-- +syntaxForm1Module :: [KnownComponent] -> Syntax +syntaxForm1Module cs = + syntaxForm1 render $ \str1 _fstatus1 -> do + guardModuleName str1 + let ms = [ (m,c) | c <- cs, m <- cinfoModules c ] + (m,c) <- matchModuleNameAnd ms str1 + return (TargetComponent (cinfoPackageId c) (cinfoName c) (ModuleTarget m)) + where + render (TargetComponent _p _c (ModuleTarget m)) = + [TargetStringFileStatus1 (dispM m) noFileStatus] + render _ = [] + +-- | Syntax: file name +-- +-- > cabal build Data/Foo.hs bar/Main.hsc +-- +syntaxForm1File :: [KnownPackage] -> Syntax +syntaxForm1File ps = + -- Note there's a bit of an inconsistency here vs the other syntax forms + -- for files. For the single-part syntax the target has to point to a file + -- that exists (due to our use of matchPackageDirectoryPrefix), whereas for + -- all the other forms we don't require that. + syntaxForm1 render $ \str1 fstatus1 -> + expecting "file" str1 $ do + (pkgfile, ~KnownPackage{pinfoId, pinfoComponents}) + -- always returns the KnownPackage case + <- matchPackageDirectoryPrefix ps fstatus1 + orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do + (filepath, c) <- matchComponentFile pinfoComponents pkgfile + return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath)) + where + render (TargetComponent _p _c (FileTarget f)) = + [TargetStringFileStatus1 f noFileStatus] + render _ = [] + +--- + +-- | Syntax: :all +-- +-- > cabal build :all +-- +syntaxForm2MetaAll :: Syntax +syntaxForm2MetaAll = + syntaxForm2 render $ \str1 _fstatus1 str2 -> do + guardNamespaceMeta str1 + guardMetaAll str2 + return (TargetAllPackages Nothing) + where + render (TargetAllPackages Nothing) = + [TargetStringFileStatus2 "" noFileStatus "all"] + render _ = [] + +-- | Syntax: all : filer +-- +-- > cabal build all:tests +-- +syntaxForm2AllFilter :: Syntax +syntaxForm2AllFilter = + syntaxForm2 render $ \str1 _fstatus1 str2 -> do + guardMetaAll str1 + kfilter <- matchComponentKindFilter str2 + return (TargetAllPackages (Just kfilter)) + where + render (TargetAllPackages (Just kfilter)) = + [TargetStringFileStatus2 "all" noFileStatus (dispF kfilter)] + render _ = [] + +-- | Syntax: package : filer +-- +-- > cabal build foo:tests +-- +syntaxForm2PackageFilter :: [KnownPackage] -> Syntax +syntaxForm2PackageFilter ps = + syntaxForm2 render $ \str1 fstatus1 str2 -> do + guardPackage str1 fstatus1 + p <- matchPackage ps str1 fstatus1 + kfilter <- matchComponentKindFilter str2 + case p of + KnownPackage{pinfoId} -> + return (TargetPackage TargetExplicitNamed [pinfoId] (Just kfilter)) + KnownPackageName pn -> + return (TargetPackageNamed pn (Just kfilter)) + where + render (TargetPackage TargetExplicitNamed [p] (Just kfilter)) = + [TargetStringFileStatus2 (dispP p) noFileStatus (dispF kfilter)] + render (TargetPackageNamed pn (Just kfilter)) = + [TargetStringFileStatus2 (dispPN pn) noFileStatus (dispF kfilter)] + render _ = [] + +-- | Syntax: pkg : package name +-- +-- > cabal build pkg:foo +-- +syntaxForm2NamespacePackage :: [KnownPackage] -> Syntax +syntaxForm2NamespacePackage pinfo = + syntaxForm2 render $ \str1 _fstatus1 str2 -> do + guardNamespacePackage str1 + guardPackageName str2 + p <- matchPackage pinfo str2 noFileStatus + case p of + KnownPackage{pinfoId} -> + return (TargetPackage TargetExplicitNamed [pinfoId] Nothing) + KnownPackageName pn -> + return (TargetPackageNamed pn Nothing) + where + render (TargetPackage TargetExplicitNamed [p] Nothing) = + [TargetStringFileStatus2 "pkg" noFileStatus (dispP p)] + render (TargetPackageNamed pn Nothing) = + [TargetStringFileStatus2 "pkg" noFileStatus (dispPN pn)] + render _ = [] + +-- | Syntax: package : component +-- +-- > cabal build foo:foo +-- > cabal build ./foo:foo +-- > cabal build ./foo.cabal:foo +-- +syntaxForm2PackageComponent :: [KnownPackage] -> Syntax +syntaxForm2PackageComponent ps = + syntaxForm2 render $ \str1 fstatus1 str2 -> do + guardPackage str1 fstatus1 + guardComponentName str2 + p <- matchPackage ps str1 fstatus1 + case p of + KnownPackage{pinfoId, pinfoComponents} -> + orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do + c <- matchComponentName pinfoComponents str2 + return (TargetComponent pinfoId (cinfoName c) WholeComponent) + --TODO: the error here ought to say there's no component by that name in + -- this package, and name the package + KnownPackageName pn -> + let cn = mkUnqualComponentName str2 in + return (TargetComponentUnknown pn (Left cn) WholeComponent) + where + render (TargetComponent p c WholeComponent) = + [TargetStringFileStatus2 (dispP p) noFileStatus (dispC p c)] + render (TargetComponentUnknown pn (Left cn) WholeComponent) = + [TargetStringFileStatus2 (dispPN pn) noFileStatus (prettyShow cn)] + render _ = [] + +-- | Syntax: namespace : component +-- +-- > cabal build lib:foo exe:foo +-- +syntaxForm2KindComponent :: [KnownComponent] -> Syntax +syntaxForm2KindComponent cs = + syntaxForm2 render $ \str1 _fstatus1 str2 -> do + ckind <- matchComponentKind str1 + guardComponentName str2 + c <- matchComponentKindAndName cs ckind str2 + return (TargetComponent (cinfoPackageId c) (cinfoName c) WholeComponent) + where + render (TargetComponent p c WholeComponent) = + [TargetStringFileStatus2 (dispCK c) noFileStatus (dispC p c)] + render _ = [] + +-- | Syntax: package : module +-- +-- > cabal build foo:Data.Foo +-- > cabal build ./foo:Data.Foo +-- > cabal build ./foo.cabal:Data.Foo +-- +syntaxForm2PackageModule :: [KnownPackage] -> Syntax +syntaxForm2PackageModule ps = + syntaxForm2 render $ \str1 fstatus1 str2 -> do + guardPackage str1 fstatus1 + guardModuleName str2 + p <- matchPackage ps str1 fstatus1 + case p of + KnownPackage{pinfoId, pinfoComponents} -> + orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do + let ms = [ (m,c) | c <- pinfoComponents, m <- cinfoModules c ] + (m,c) <- matchModuleNameAnd ms str2 + return (TargetComponent pinfoId (cinfoName c) (ModuleTarget m)) + KnownPackageName pn -> do + m <- matchModuleNameUnknown str2 + -- We assume the primary library component of the package: + return (TargetComponentUnknown pn (Right $ CLibName LMainLibName) (ModuleTarget m)) + where + render (TargetComponent p _c (ModuleTarget m)) = + [TargetStringFileStatus2 (dispP p) noFileStatus (dispM m)] + render _ = [] + +-- | Syntax: component : module +-- +-- > cabal build foo:Data.Foo +-- +syntaxForm2ComponentModule :: [KnownComponent] -> Syntax +syntaxForm2ComponentModule cs = + syntaxForm2 render $ \str1 _fstatus1 str2 -> do + guardComponentName str1 + guardModuleName str2 + c <- matchComponentName cs str1 + orNoThingIn "component" (cinfoStrName c) $ do + let ms = cinfoModules c + m <- matchModuleName ms str2 + return (TargetComponent (cinfoPackageId c) (cinfoName c) + (ModuleTarget m)) + where + render (TargetComponent p c (ModuleTarget m)) = + [TargetStringFileStatus2 (dispC p c) noFileStatus (dispM m)] + render _ = [] + +-- | Syntax: package : filename +-- +-- > cabal build foo:Data/Foo.hs +-- > cabal build ./foo:Data/Foo.hs +-- > cabal build ./foo.cabal:Data/Foo.hs +-- +syntaxForm2PackageFile :: [KnownPackage] -> Syntax +syntaxForm2PackageFile ps = + syntaxForm2 render $ \str1 fstatus1 str2 -> do + guardPackage str1 fstatus1 + p <- matchPackage ps str1 fstatus1 + case p of + KnownPackage{pinfoId, pinfoComponents} -> + orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do + (filepath, c) <- matchComponentFile pinfoComponents str2 + return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath)) + KnownPackageName pn -> + let filepath = str2 in + -- We assume the primary library component of the package: + return (TargetComponentUnknown pn (Right $ CLibName LMainLibName) (FileTarget filepath)) + where + render (TargetComponent p _c (FileTarget f)) = + [TargetStringFileStatus2 (dispP p) noFileStatus f] + render _ = [] + +-- | Syntax: component : filename +-- +-- > cabal build foo:Data/Foo.hs +-- +syntaxForm2ComponentFile :: [KnownComponent] -> Syntax +syntaxForm2ComponentFile cs = + syntaxForm2 render $ \str1 _fstatus1 str2 -> do + guardComponentName str1 + c <- matchComponentName cs str1 + orNoThingIn "component" (cinfoStrName c) $ do + (filepath, _) <- matchComponentFile [c] str2 + return (TargetComponent (cinfoPackageId c) (cinfoName c) + (FileTarget filepath)) + where + render (TargetComponent p c (FileTarget f)) = + [TargetStringFileStatus2 (dispC p c) noFileStatus f] + render _ = [] + +--- + +-- | Syntax: :all : filter +-- +-- > cabal build :all:tests +-- +syntaxForm3MetaAllFilter :: Syntax +syntaxForm3MetaAllFilter = + syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do + guardNamespaceMeta str1 + guardMetaAll str2 + kfilter <- matchComponentKindFilter str3 + return (TargetAllPackages (Just kfilter)) + where + render (TargetAllPackages (Just kfilter)) = + [TargetStringFileStatus3 "" noFileStatus "all" (dispF kfilter)] + render _ = [] + +syntaxForm3MetaCwdFilter :: [KnownPackage] -> Syntax +syntaxForm3MetaCwdFilter ps = + syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do + guardNamespaceMeta str1 + guardNamespaceCwd str2 + kfilter <- matchComponentKindFilter str3 + return (TargetPackage TargetImplicitCwd pids (Just kfilter)) + where + pids = [ pinfoId | KnownPackage{pinfoId} <- ps ] + render (TargetPackage TargetImplicitCwd _ (Just kfilter)) = + [TargetStringFileStatus3 "" noFileStatus "cwd" (dispF kfilter)] + render _ = [] + +-- | Syntax: :pkg : package name +-- +-- > cabal build :pkg:foo +-- +syntaxForm3MetaNamespacePackage :: [KnownPackage] -> Syntax +syntaxForm3MetaNamespacePackage pinfo = + syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do + guardNamespaceMeta str1 + guardNamespacePackage str2 + guardPackageName str3 + p <- matchPackage pinfo str3 noFileStatus + case p of + KnownPackage{pinfoId} -> + return (TargetPackage TargetExplicitNamed [pinfoId] Nothing) + KnownPackageName pn -> + return (TargetPackageNamed pn Nothing) + where + render (TargetPackage TargetExplicitNamed [p] Nothing) = + [TargetStringFileStatus3 "" noFileStatus "pkg" (dispP p)] + render (TargetPackageNamed pn Nothing) = + [TargetStringFileStatus3 "" noFileStatus "pkg" (dispPN pn)] + render _ = [] + +-- | Syntax: package : namespace : component +-- +-- > cabal build foo:lib:foo +-- > cabal build foo/:lib:foo +-- > cabal build foo.cabal:lib:foo +-- +syntaxForm3PackageKindComponent :: [KnownPackage] -> Syntax +syntaxForm3PackageKindComponent ps = + syntaxForm3 render $ \str1 fstatus1 str2 str3 -> do + guardPackage str1 fstatus1 + ckind <- matchComponentKind str2 + guardComponentName str3 + p <- matchPackage ps str1 fstatus1 + case p of + KnownPackage{pinfoId, pinfoComponents} -> + orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do + c <- matchComponentKindAndName pinfoComponents ckind str3 + return (TargetComponent pinfoId (cinfoName c) WholeComponent) + KnownPackageName pn -> + let cn = mkComponentName pn ckind (mkUnqualComponentName str3) in + return (TargetComponentUnknown pn (Right cn) WholeComponent) + where + render (TargetComponent p c WholeComponent) = + [TargetStringFileStatus3 (dispP p) noFileStatus (dispCK c) (dispC p c)] + render (TargetComponentUnknown pn (Right c) WholeComponent) = + [TargetStringFileStatus3 (dispPN pn) noFileStatus (dispCK c) (dispC' pn c)] + render _ = [] + +-- | Syntax: package : component : module +-- +-- > cabal build foo:foo:Data.Foo +-- > cabal build foo/:foo:Data.Foo +-- > cabal build foo.cabal:foo:Data.Foo +-- +syntaxForm3PackageComponentModule :: [KnownPackage] -> Syntax +syntaxForm3PackageComponentModule ps = + syntaxForm3 render $ \str1 fstatus1 str2 str3 -> do + guardPackage str1 fstatus1 + guardComponentName str2 + guardModuleName str3 + p <- matchPackage ps str1 fstatus1 + case p of + KnownPackage{pinfoId, pinfoComponents} -> + orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do + c <- matchComponentName pinfoComponents str2 + orNoThingIn "component" (cinfoStrName c) $ do + let ms = cinfoModules c + m <- matchModuleName ms str3 + return (TargetComponent pinfoId (cinfoName c) (ModuleTarget m)) + KnownPackageName pn -> do + let cn = mkUnqualComponentName str2 + m <- matchModuleNameUnknown str3 + return (TargetComponentUnknown pn (Left cn) (ModuleTarget m)) + where + render (TargetComponent p c (ModuleTarget m)) = + [TargetStringFileStatus3 (dispP p) noFileStatus (dispC p c) (dispM m)] + render (TargetComponentUnknown pn (Left c) (ModuleTarget m)) = + [TargetStringFileStatus3 (dispPN pn) noFileStatus (dispCN c) (dispM m)] + render _ = [] + +-- | Syntax: namespace : component : module +-- +-- > cabal build lib:foo:Data.Foo +-- +syntaxForm3KindComponentModule :: [KnownComponent] -> Syntax +syntaxForm3KindComponentModule cs = + syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do + ckind <- matchComponentKind str1 + guardComponentName str2 + guardModuleName str3 + c <- matchComponentKindAndName cs ckind str2 + orNoThingIn "component" (cinfoStrName c) $ do + let ms = cinfoModules c + m <- matchModuleName ms str3 + return (TargetComponent (cinfoPackageId c) (cinfoName c) + (ModuleTarget m)) + where + render (TargetComponent p c (ModuleTarget m)) = + [TargetStringFileStatus3 (dispCK c) noFileStatus (dispC p c) (dispM m)] + render _ = [] + +-- | Syntax: package : component : filename +-- +-- > cabal build foo:foo:Data/Foo.hs +-- > cabal build foo/:foo:Data/Foo.hs +-- > cabal build foo.cabal:foo:Data/Foo.hs +-- +syntaxForm3PackageComponentFile :: [KnownPackage] -> Syntax +syntaxForm3PackageComponentFile ps = + syntaxForm3 render $ \str1 fstatus1 str2 str3 -> do + guardPackage str1 fstatus1 + guardComponentName str2 + p <- matchPackage ps str1 fstatus1 + case p of + KnownPackage{pinfoId, pinfoComponents} -> + orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do + c <- matchComponentName pinfoComponents str2 + orNoThingIn "component" (cinfoStrName c) $ do + (filepath, _) <- matchComponentFile [c] str3 + return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath)) + KnownPackageName pn -> + let cn = mkUnqualComponentName str2 + filepath = str3 in + return (TargetComponentUnknown pn (Left cn) (FileTarget filepath)) + where + render (TargetComponent p c (FileTarget f)) = + [TargetStringFileStatus3 (dispP p) noFileStatus (dispC p c) f] + render (TargetComponentUnknown pn (Left c) (FileTarget f)) = + [TargetStringFileStatus3 (dispPN pn) noFileStatus (dispCN c) f] + render _ = [] + +-- | Syntax: namespace : component : filename +-- +-- > cabal build lib:foo:Data/Foo.hs +-- +syntaxForm3KindComponentFile :: [KnownComponent] -> Syntax +syntaxForm3KindComponentFile cs = + syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do + ckind <- matchComponentKind str1 + guardComponentName str2 + c <- matchComponentKindAndName cs ckind str2 + orNoThingIn "component" (cinfoStrName c) $ do + (filepath, _) <- matchComponentFile [c] str3 + return (TargetComponent (cinfoPackageId c) (cinfoName c) + (FileTarget filepath)) + where + render (TargetComponent p c (FileTarget f)) = + [TargetStringFileStatus3 (dispCK c) noFileStatus (dispC p c) f] + render _ = [] + +syntaxForm3NamespacePackageFilter :: [KnownPackage] -> Syntax +syntaxForm3NamespacePackageFilter ps = + syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do + guardNamespacePackage str1 + guardPackageName str2 + p <- matchPackage ps str2 noFileStatus + kfilter <- matchComponentKindFilter str3 + case p of + KnownPackage{pinfoId} -> + return (TargetPackage TargetExplicitNamed [pinfoId] (Just kfilter)) + KnownPackageName pn -> + return (TargetPackageNamed pn (Just kfilter)) + where + render (TargetPackage TargetExplicitNamed [p] (Just kfilter)) = + [TargetStringFileStatus3 "pkg" noFileStatus (dispP p) (dispF kfilter)] + render (TargetPackageNamed pn (Just kfilter)) = + [TargetStringFileStatus3 "pkg" noFileStatus (dispPN pn) (dispF kfilter)] + render _ = [] + +-- + +syntaxForm4MetaNamespacePackageFilter :: [KnownPackage] -> Syntax +syntaxForm4MetaNamespacePackageFilter ps = + syntaxForm4 render $ \str1 str2 str3 str4 -> do + guardNamespaceMeta str1 + guardNamespacePackage str2 + guardPackageName str3 + p <- matchPackage ps str3 noFileStatus + kfilter <- matchComponentKindFilter str4 + case p of + KnownPackage{pinfoId} -> + return (TargetPackage TargetExplicitNamed [pinfoId] (Just kfilter)) + KnownPackageName pn -> + return (TargetPackageNamed pn (Just kfilter)) + where + render (TargetPackage TargetExplicitNamed [p] (Just kfilter)) = + [TargetStringFileStatus4 "" "pkg" (dispP p) (dispF kfilter)] + render (TargetPackageNamed pn (Just kfilter)) = + [TargetStringFileStatus4 "" "pkg" (dispPN pn) (dispF kfilter)] + render _ = [] + +-- | Syntax: :pkg : package : namespace : component +-- +-- > cabal build :pkg:foo:lib:foo +-- +syntaxForm5MetaNamespacePackageKindComponent :: [KnownPackage] -> Syntax +syntaxForm5MetaNamespacePackageKindComponent ps = + syntaxForm5 render $ \str1 str2 str3 str4 str5 -> do + guardNamespaceMeta str1 + guardNamespacePackage str2 + guardPackageName str3 + ckind <- matchComponentKind str4 + guardComponentName str5 + p <- matchPackage ps str3 noFileStatus + case p of + KnownPackage{pinfoId, pinfoComponents} -> + orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do + c <- matchComponentKindAndName pinfoComponents ckind str5 + return (TargetComponent pinfoId (cinfoName c) WholeComponent) + KnownPackageName pn -> + let cn = mkComponentName pn ckind (mkUnqualComponentName str5) in + return (TargetComponentUnknown pn (Right cn) WholeComponent) + where + render (TargetComponent p c WholeComponent) = + [TargetStringFileStatus5 "" "pkg" (dispP p) (dispCK c) (dispC p c)] + render (TargetComponentUnknown pn (Right c) WholeComponent) = + [TargetStringFileStatus5 "" "pkg" (dispPN pn) (dispCK c) (dispC' pn c)] + render _ = [] + +-- | Syntax: :pkg : package : namespace : component : module : module +-- +-- > cabal build :pkg:foo:lib:foo:module:Data.Foo +-- +syntaxForm7MetaNamespacePackageKindComponentNamespaceModule + :: [KnownPackage] -> Syntax +syntaxForm7MetaNamespacePackageKindComponentNamespaceModule ps = + syntaxForm7 render $ \str1 str2 str3 str4 str5 str6 str7 -> do + guardNamespaceMeta str1 + guardNamespacePackage str2 + guardPackageName str3 + ckind <- matchComponentKind str4 + guardComponentName str5 + guardNamespaceModule str6 + p <- matchPackage ps str3 noFileStatus + case p of + KnownPackage{pinfoId, pinfoComponents} -> + orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do + c <- matchComponentKindAndName pinfoComponents ckind str5 + orNoThingIn "component" (cinfoStrName c) $ do + let ms = cinfoModules c + m <- matchModuleName ms str7 + return (TargetComponent pinfoId (cinfoName c) (ModuleTarget m)) + KnownPackageName pn -> do + let cn = mkComponentName pn ckind (mkUnqualComponentName str2) + m <- matchModuleNameUnknown str7 + return (TargetComponentUnknown pn (Right cn) (ModuleTarget m)) + where + render (TargetComponent p c (ModuleTarget m)) = + [TargetStringFileStatus7 "" "pkg" (dispP p) + (dispCK c) (dispC p c) + "module" (dispM m)] + render (TargetComponentUnknown pn (Right c) (ModuleTarget m)) = + [TargetStringFileStatus7 "" "pkg" (dispPN pn) + (dispCK c) (dispC' pn c) + "module" (dispM m)] + render _ = [] + +-- | Syntax: :pkg : package : namespace : component : file : filename +-- +-- > cabal build :pkg:foo:lib:foo:file:Data/Foo.hs +-- +syntaxForm7MetaNamespacePackageKindComponentNamespaceFile + :: [KnownPackage] -> Syntax +syntaxForm7MetaNamespacePackageKindComponentNamespaceFile ps = + syntaxForm7 render $ \str1 str2 str3 str4 str5 str6 str7 -> do + guardNamespaceMeta str1 + guardNamespacePackage str2 + guardPackageName str3 + ckind <- matchComponentKind str4 + guardComponentName str5 + guardNamespaceFile str6 + p <- matchPackage ps str3 noFileStatus + case p of + KnownPackage{pinfoId, pinfoComponents} -> + orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do + c <- matchComponentKindAndName pinfoComponents ckind str5 + orNoThingIn "component" (cinfoStrName c) $ do + (filepath,_) <- matchComponentFile [c] str7 + return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath)) + KnownPackageName pn -> + let cn = mkComponentName pn ckind (mkUnqualComponentName str5) + filepath = str7 in + return (TargetComponentUnknown pn (Right cn) (FileTarget filepath)) + where + render (TargetComponent p c (FileTarget f)) = + [TargetStringFileStatus7 "" "pkg" (dispP p) + (dispCK c) (dispC p c) + "file" f] + render (TargetComponentUnknown pn (Right c) (FileTarget f)) = + [TargetStringFileStatus7 "" "pkg" (dispPN pn) + (dispCK c) (dispC' pn c) + "file" f] + render _ = [] + + +--------------------------------------- +-- Syntax utils +-- + +type Match1 = String -> FileStatus -> Match TargetSelector +type Match2 = String -> FileStatus -> String + -> Match TargetSelector +type Match3 = String -> FileStatus -> String -> String + -> Match TargetSelector +type Match4 = String -> String -> String -> String + -> Match TargetSelector +type Match5 = String -> String -> String -> String -> String + -> Match TargetSelector +type Match7 = String -> String -> String -> String -> String -> String -> String + -> Match TargetSelector + +syntaxForm1 :: Renderer -> Match1 -> Syntax +syntaxForm2 :: Renderer -> Match2 -> Syntax +syntaxForm3 :: Renderer -> Match3 -> Syntax +syntaxForm4 :: Renderer -> Match4 -> Syntax +syntaxForm5 :: Renderer -> Match5 -> Syntax +syntaxForm7 :: Renderer -> Match7 -> Syntax + +syntaxForm1 render f = + Syntax QL1 match render + where + match = \(TargetStringFileStatus1 str1 fstatus1) -> + f str1 fstatus1 + +syntaxForm2 render f = + Syntax QL2 match render + where + match = \(TargetStringFileStatus2 str1 fstatus1 str2) -> + f str1 fstatus1 str2 + +syntaxForm3 render f = + Syntax QL3 match render + where + match = \(TargetStringFileStatus3 str1 fstatus1 str2 str3) -> + f str1 fstatus1 str2 str3 + +syntaxForm4 render f = + Syntax QLFull match render + where + match (TargetStringFileStatus4 str1 str2 str3 str4) + = f str1 str2 str3 str4 + match _ = mzero + +syntaxForm5 render f = + Syntax QLFull match render + where + match (TargetStringFileStatus5 str1 str2 str3 str4 str5) + = f str1 str2 str3 str4 str5 + match _ = mzero + +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 + +dispP :: Package p => p -> String +dispP = prettyShow . packageName + +dispPN :: PackageName -> String +dispPN = prettyShow + +dispC :: PackageId -> ComponentName -> String +dispC = componentStringName . packageName + +dispC' :: PackageName -> ComponentName -> String +dispC' = componentStringName + +dispCN :: UnqualComponentName -> String +dispCN = prettyShow + +dispK :: ComponentKind -> String +dispK = showComponentKindShort + +dispCK :: ComponentName -> String +dispCK = dispK . componentKind + +dispF :: ComponentKind -> String +dispF = showComponentKindFilterShort + +dispM :: ModuleName -> String +dispM = prettyShow + + +------------------------------- +-- Package and component info +-- + +data KnownTargets = KnownTargets { + knownPackagesAll :: [KnownPackage], + knownPackagesPrimary :: [KnownPackage], + knownPackagesOther :: [KnownPackage], + knownComponentsAll :: [KnownComponent], + knownComponentsPrimary :: [KnownComponent], + knownComponentsOther :: [KnownComponent] + } + deriving Show + +data KnownPackage = + KnownPackage { + pinfoId :: PackageId, + pinfoDirectory :: Maybe (FilePath, FilePath), + pinfoPackageFile :: Maybe (FilePath, FilePath), + pinfoComponents :: [KnownComponent] + } + | KnownPackageName { + pinfoName :: PackageName + } + deriving Show + +data KnownComponent = KnownComponent { + cinfoName :: ComponentName, + cinfoStrName :: ComponentStringName, + cinfoPackageId :: PackageId, + cinfoSrcDirs :: [FilePath], + cinfoModules :: [ModuleName], + cinfoHsFiles :: [FilePath], -- other hs files (like main.hs) + cinfoCFiles :: [FilePath], + cinfoJsFiles :: [FilePath] + } + deriving Show + +type ComponentStringName = String + +knownPackageName :: KnownPackage -> PackageName +knownPackageName KnownPackage{pinfoId} = packageName pinfoId +knownPackageName KnownPackageName{pinfoName} = pinfoName + +emptyKnownTargets :: KnownTargets +emptyKnownTargets = KnownTargets [] [] [] [] [] [] + +getKnownTargets :: forall m a. (Applicative m, Monad m) + => DirActions m + -> [PackageSpecifier (SourcePackage (PackageLocation a))] + -> m KnownTargets +getKnownTargets dirActions@DirActions{..} pkgs = do + pinfo <- traverse (collectKnownPackageInfo dirActions) pkgs + cwd <- getCurrentDirectory + (ppinfo, opinfo) <- selectPrimaryPackage cwd pinfo + return KnownTargets { + knownPackagesAll = pinfo, + knownPackagesPrimary = ppinfo, + knownPackagesOther = opinfo, + knownComponentsAll = allComponentsIn pinfo, + knownComponentsPrimary = allComponentsIn ppinfo, + knownComponentsOther = allComponentsIn opinfo + } + where + mPkgDir :: KnownPackage -> Maybe FilePath + mPkgDir KnownPackage { pinfoDirectory = Just (dir,_) } = Just dir + mPkgDir _ = Nothing + + selectPrimaryPackage :: FilePath + -> [KnownPackage] + -> m ([KnownPackage], [KnownPackage]) + selectPrimaryPackage _ [] = return ([] , []) + selectPrimaryPackage cwd (pkg : packages) = do + (ppinfo, opinfo) <- selectPrimaryPackage cwd packages + isPkgDirCwd <- maybe (pure False) (compareFilePath dirActions cwd) (mPkgDir pkg) + return (if isPkgDirCwd then (pkg : ppinfo, opinfo) else (ppinfo, pkg : opinfo)) + + allComponentsIn ps = + [ c | KnownPackage{pinfoComponents} <- ps, c <- pinfoComponents ] + + +collectKnownPackageInfo :: (Applicative m, Monad m) => DirActions m + -> PackageSpecifier (SourcePackage (PackageLocation a)) + -> m KnownPackage +collectKnownPackageInfo _ (NamedPackage pkgname _props) = + return (KnownPackageName pkgname) +collectKnownPackageInfo dirActions@DirActions{..} + (SpecificSourcePackage SourcePackage { + srcpkgDescription = pkg, + srcpkgSource = loc + }) = do + (pkgdir, pkgfile) <- + case loc of + --TODO: local tarballs, remote tarballs etc + LocalUnpackedPackage dir -> do + dirabs <- canonicalizePath dir + dirrel <- makeRelativeToCwd dirActions dirabs + --TODO: ought to get this earlier in project reading + let fileabs = dirabs prettyShow (packageName pkg) <.> "cabal" + filerel = dirrel prettyShow (packageName pkg) <.> "cabal" + exists <- doesFileExist fileabs + return ( Just (dirabs, dirrel) + , if exists then Just (fileabs, filerel) else Nothing + ) + _ -> return (Nothing, Nothing) + let pinfo = + KnownPackage { + pinfoId = packageId pkg, + pinfoDirectory = pkgdir, + pinfoPackageFile = pkgfile, + pinfoComponents = collectKnownComponentInfo + (flattenPackageDescription pkg) + } + return pinfo + + +collectKnownComponentInfo :: PackageDescription -> [KnownComponent] +collectKnownComponentInfo pkg = + [ KnownComponent { + cinfoName = componentName c, + cinfoStrName = componentStringName (packageName pkg) (componentName c), + cinfoPackageId = packageId pkg, + cinfoSrcDirs = ordNub (map getSymbolicPath (hsSourceDirs bi)), + cinfoModules = ordNub (componentModules c), + cinfoHsFiles = ordNub (componentHsFiles c), + cinfoCFiles = ordNub (cSources bi), + cinfoJsFiles = ordNub (jsSources bi) + } + | c <- pkgComponents pkg + , let bi = componentBuildInfo c ] + + +componentStringName :: PackageName -> ComponentName -> ComponentStringName +componentStringName pkgname (CLibName LMainLibName) = prettyShow pkgname +componentStringName _ (CLibName (LSubLibName name)) = unUnqualComponentName name +componentStringName _ (CFLibName name) = unUnqualComponentName name +componentStringName _ (CExeName name) = unUnqualComponentName name +componentStringName _ (CTestName name) = unUnqualComponentName name +componentStringName _ (CBenchName name) = unUnqualComponentName name + +componentModules :: Component -> [ModuleName] +-- I think it's unlikely users will ask to build a requirement +-- which is not mentioned locally. +componentModules (CLib lib) = explicitLibModules lib +componentModules (CFLib flib) = foreignLibModules flib +componentModules (CExe exe) = exeModules exe +componentModules (CTest test) = testModules test +componentModules (CBench bench) = benchmarkModules bench + +componentHsFiles :: Component -> [FilePath] +componentHsFiles (CExe exe) = [modulePath exe] +componentHsFiles (CTest TestSuite { + testInterface = TestSuiteExeV10 _ mainfile + }) = [mainfile] +componentHsFiles (CBench Benchmark { + benchmarkInterface = BenchmarkExeV10 _ mainfile + }) = [mainfile] +componentHsFiles _ = [] + + +------------------------------ +-- Matching meta targets +-- + +guardNamespaceMeta :: String -> Match () +guardNamespaceMeta = guardToken [""] "meta namespace" + +guardMetaAll :: String -> Match () +guardMetaAll = guardToken ["all"] "meta-target 'all'" + +guardNamespacePackage :: String -> Match () +guardNamespacePackage = guardToken ["pkg", "package"] "'pkg' namespace" + +guardNamespaceCwd :: String -> Match () +guardNamespaceCwd = guardToken ["cwd"] "'cwd' namespace" + +guardNamespaceModule :: String -> Match () +guardNamespaceModule = guardToken ["mod", "module"] "'module' namespace" + +guardNamespaceFile :: String -> Match () +guardNamespaceFile = guardToken ["file"] "'file' namespace" + +guardToken :: [String] -> String -> String -> Match () +guardToken tokens msg s + | caseFold s `elem` tokens = increaseConfidence + | otherwise = matchErrorExpected msg s + + +------------------------------ +-- Matching component kinds +-- + +componentKind :: ComponentName -> ComponentKind +componentKind (CLibName _) = LibKind +componentKind (CFLibName _) = FLibKind +componentKind (CExeName _) = ExeKind +componentKind (CTestName _) = TestKind +componentKind (CBenchName _) = BenchKind + +cinfoKind :: KnownComponent -> ComponentKind +cinfoKind = componentKind . cinfoName + +matchComponentKind :: String -> Match ComponentKind +matchComponentKind s + | s' `elem` liblabels = increaseConfidence >> return LibKind + | s' `elem` fliblabels = increaseConfidence >> return FLibKind + | s' `elem` exelabels = increaseConfidence >> return ExeKind + | s' `elem` testlabels = increaseConfidence >> return TestKind + | s' `elem` benchlabels = increaseConfidence >> return BenchKind + | otherwise = matchErrorExpected "component kind" s + where + s' = caseFold s + liblabels = ["lib", "library"] + fliblabels = ["flib", "foreign-library"] + exelabels = ["exe", "executable"] + testlabels = ["tst", "test", "test-suite"] + benchlabels = ["bench", "benchmark"] + +matchComponentKindFilter :: String -> Match ComponentKind +matchComponentKindFilter s + | s' `elem` liblabels = increaseConfidence >> return LibKind + | s' `elem` fliblabels = increaseConfidence >> return FLibKind + | s' `elem` exelabels = increaseConfidence >> return ExeKind + | s' `elem` testlabels = increaseConfidence >> return TestKind + | s' `elem` benchlabels = increaseConfidence >> return BenchKind + | otherwise = matchErrorExpected "component kind filter" s + where + s' = caseFold s + liblabels = ["libs", "libraries"] + fliblabels = ["flibs", "foreign-libraries"] + exelabels = ["exes", "executables"] + testlabels = ["tests", "test-suites"] + benchlabels = ["benches", "benchmarks"] + +showComponentKind :: ComponentKind -> String +showComponentKind LibKind = "library" +showComponentKind FLibKind = "foreign library" +showComponentKind ExeKind = "executable" +showComponentKind TestKind = "test-suite" +showComponentKind BenchKind = "benchmark" + +showComponentKindShort :: ComponentKind -> String +showComponentKindShort LibKind = "lib" +showComponentKindShort FLibKind = "flib" +showComponentKindShort ExeKind = "exe" +showComponentKindShort TestKind = "test" +showComponentKindShort BenchKind = "bench" + +showComponentKindFilterShort :: ComponentKind -> String +showComponentKindFilterShort LibKind = "libs" +showComponentKindFilterShort FLibKind = "flibs" +showComponentKindFilterShort ExeKind = "exes" +showComponentKindFilterShort TestKind = "tests" +showComponentKindFilterShort BenchKind = "benchmarks" + + +------------------------------ +-- Matching package targets +-- + +guardPackage :: String -> FileStatus -> Match () +guardPackage str fstatus = + guardPackageName str + <|> guardPackageDir str fstatus + <|> guardPackageFile str fstatus + + +guardPackageName :: String -> Match () +guardPackageName s + | validPackageName s = increaseConfidence + | otherwise = matchErrorExpected "package name" s + +validPackageName :: String -> Bool +validPackageName s = + all validPackageNameChar s + && not (null s) + where + validPackageNameChar c = isAlphaNum c || c == '-' + + +guardPackageDir :: String -> FileStatus -> Match () +guardPackageDir _ (FileStatusExistsDir _) = increaseConfidence +guardPackageDir str _ = matchErrorExpected "package directory" str + + +guardPackageFile :: String -> FileStatus -> Match () +guardPackageFile _ (FileStatusExistsFile file) + | takeExtension file == ".cabal" + = increaseConfidence +guardPackageFile str _ = matchErrorExpected "package .cabal file" str + + +matchPackage :: [KnownPackage] -> String -> FileStatus -> Match KnownPackage +matchPackage pinfo = \str fstatus -> + orNoThingIn "project" "" $ + matchPackageName pinfo str + (matchPackageNameUnknown str + <|> matchPackageDir pinfo str fstatus + <|> matchPackageFile pinfo str fstatus) + + +matchPackageName :: [KnownPackage] -> String -> Match KnownPackage +matchPackageName ps = \str -> do + guard (validPackageName str) + orNoSuchThing "package" str + (map (prettyShow . knownPackageName) ps) $ + increaseConfidenceFor $ + matchInexactly caseFold (prettyShow . knownPackageName) ps str + + +matchPackageNameUnknown :: String -> Match KnownPackage +matchPackageNameUnknown str = do + pn <- matchParse str + unknownMatch (KnownPackageName pn) + + +matchPackageDir :: [KnownPackage] + -> String -> FileStatus -> Match KnownPackage +matchPackageDir ps = \str fstatus -> + case fstatus of + FileStatusExistsDir canondir -> + orNoSuchThing "package directory" str (map (snd . fst) dirs) $ + increaseConfidenceFor $ + fmap snd $ matchExactly (fst . fst) dirs canondir + _ -> mzero + where + dirs = [ ((dabs,drel),p) + | p@KnownPackage{ pinfoDirectory = Just (dabs,drel) } <- ps ] + + +matchPackageFile :: [KnownPackage] -> String -> FileStatus -> Match KnownPackage +matchPackageFile ps = \str fstatus -> do + case fstatus of + FileStatusExistsFile canonfile -> + orNoSuchThing "package .cabal file" str (map (snd . fst) files) $ + increaseConfidenceFor $ + fmap snd $ matchExactly (fst . fst) files canonfile + _ -> mzero + where + files = [ ((fabs,frel),p) + | p@KnownPackage{ pinfoPackageFile = Just (fabs,frel) } <- ps ] + +--TODO: test outcome when dir exists but doesn't match any known one + +--TODO: perhaps need another distinction, vs no such thing, point is the +-- thing is not known, within the project, but could be outside project + + +------------------------------ +-- Matching component targets +-- + + +guardComponentName :: String -> Match () +guardComponentName s + | all validComponentChar s + && not (null s) = increaseConfidence + | otherwise = matchErrorExpected "component name" s + where + validComponentChar c = isAlphaNum c || c == '.' + || c == '_' || c == '-' || c == '\'' + + +matchComponentName :: [KnownComponent] -> String -> Match KnownComponent +matchComponentName cs str = + orNoSuchThing "component" str (map cinfoStrName cs) + $ increaseConfidenceFor + $ matchInexactly caseFold cinfoStrName cs str + + +matchComponentKindAndName :: [KnownComponent] -> ComponentKind -> String + -> Match KnownComponent +matchComponentKindAndName cs ckind str = + orNoSuchThing (showComponentKind ckind ++ " component") str + (map render cs) + $ increaseConfidenceFor + $ matchInexactly (\(ck, cn) -> (ck, caseFold cn)) + (\c -> (cinfoKind c, cinfoStrName c)) + cs + (ckind, str) + where + render c = showComponentKindShort (cinfoKind c) ++ ":" ++ cinfoStrName c + + +------------------------------ +-- Matching module targets +-- + +guardModuleName :: String -> Match () +guardModuleName s = + case simpleParsec s :: Maybe ModuleName of + Just _ -> increaseConfidence + _ | all validModuleChar s + && not (null s) -> return () + | otherwise -> matchErrorExpected "module name" s + where + validModuleChar c = isAlphaNum c || c == '.' || c == '_' || c == '\'' + + +matchModuleName :: [ModuleName] -> String -> Match ModuleName +matchModuleName ms str = + orNoSuchThing "module" str (map prettyShow ms) + $ increaseConfidenceFor + $ matchInexactly caseFold prettyShow ms str + + +matchModuleNameAnd :: [(ModuleName, a)] -> String -> Match (ModuleName, a) +matchModuleNameAnd ms str = + orNoSuchThing "module" str (map (prettyShow . fst) ms) + $ increaseConfidenceFor + $ matchInexactly caseFold (prettyShow . fst) ms str + + +matchModuleNameUnknown :: String -> Match ModuleName +matchModuleNameUnknown str = + expecting "module" str + $ increaseConfidenceFor + $ matchParse str + + +------------------------------ +-- Matching file targets +-- + +matchPackageDirectoryPrefix :: [KnownPackage] -> FileStatus + -> Match (FilePath, KnownPackage) +matchPackageDirectoryPrefix ps (FileStatusExistsFile filepath) = + increaseConfidenceFor $ + matchDirectoryPrefix pkgdirs filepath + where + pkgdirs = [ (dir, p) + | p@KnownPackage { pinfoDirectory = Just (dir,_) } <- ps ] +matchPackageDirectoryPrefix _ _ = mzero + + +matchComponentFile :: [KnownComponent] -> String + -> Match (FilePath, KnownComponent) +matchComponentFile cs str = + orNoSuchThing "file" str [] $ + matchComponentModuleFile cs str + <|> matchComponentOtherFile cs str + + +matchComponentOtherFile :: [KnownComponent] -> String + -> Match (FilePath, KnownComponent) +matchComponentOtherFile cs = + matchFile + [ (normalise (srcdir file), c) + | c <- cs + , srcdir <- cinfoSrcDirs c + , file <- cinfoHsFiles c + ++ cinfoCFiles c + ++ cinfoJsFiles c + ] + . normalise + + +matchComponentModuleFile :: [KnownComponent] -> String + -> Match (FilePath, KnownComponent) +matchComponentModuleFile cs str = do + matchFile + [ (normalise (d toFilePath m), c) + | c <- cs + , d <- cinfoSrcDirs c + , m <- cinfoModules c + ] + (dropExtension (normalise str)) -- Drop the extension because FileTarget + -- is stored without the extension + +-- utils + +-- | Compare two filepaths for equality using DirActions' canonicalizePath +-- to normalize AND canonicalize filepaths before comparison. +compareFilePath :: (Applicative m, Monad m) => DirActions m + -> FilePath -> FilePath -> m Bool +compareFilePath DirActions{..} fp1 fp2 + | equalFilePath fp1 fp2 = pure True -- avoid unnecessary IO if we can match earlier + | otherwise = do + c1 <- canonicalizePath fp1 + c2 <- canonicalizePath fp2 + pure $ equalFilePath c1 c2 + + +matchFile :: [(FilePath, a)] -> FilePath -> Match (FilePath, a) +matchFile fs = + increaseConfidenceFor + . matchInexactly caseFold fst fs + +matchDirectoryPrefix :: [(FilePath, a)] -> FilePath -> Match (FilePath, a) +matchDirectoryPrefix dirs filepath = + tryEach $ + [ (file, x) + | (dir,x) <- dirs + , file <- maybeToList (stripDirectory dir) ] + where + stripDirectory :: FilePath -> Maybe FilePath + stripDirectory dir = + joinPath `fmap` stripPrefix (splitDirectories dir) filepathsplit + + filepathsplit = splitDirectories filepath + + +------------------------------ +-- Matching monad +-- + +-- | A matcher embodies a way to match some input as being some recognised +-- value. In particular it deals with multiple and ambiguous matches. +-- +-- There are various matcher primitives ('matchExactly', 'matchInexactly'), +-- ways to combine matchers ('matchPlus', 'matchPlusShadowing') and finally we +-- can run a matcher against an input using 'findMatch'. +-- +data Match a = NoMatch !Confidence [MatchError] + | Match !MatchClass !Confidence [a] + deriving Show + +-- | The kind of match, inexact or exact. We keep track of this so we can +-- prefer exact over inexact matches. The 'Ord' here is important: we try +-- to maximise this, so 'Exact' is the top value and 'Inexact' the bottom. +-- +data MatchClass = Unknown -- ^ Matches an unknown thing e.g. parses as a package + -- name without it being a specific known package + | Inexact -- ^ Matches a known thing inexactly + -- e.g. matches a known package case insensitively + | Exact -- ^ Exactly matches a known thing, + -- e.g. matches a known package case sensitively + deriving (Show, Eq, Ord) + +type Confidence = Int + +data MatchError = MatchErrorExpected String String -- thing got + | MatchErrorNoSuch String String [String] -- thing got alts + | MatchErrorIn String String MatchError -- kind thing + deriving (Show, Eq) + + +instance Functor Match where + fmap _ (NoMatch d ms) = NoMatch d ms + fmap f (Match m d xs) = Match m d (fmap f xs) + +instance Applicative Match where + pure a = Match Exact 0 [a] + (<*>) = ap + +instance Alternative Match where + empty = NoMatch 0 [] + (<|>) = matchPlus + +instance Monad Match where + return = pure + NoMatch d ms >>= _ = NoMatch d ms + Match m d xs >>= f = + -- To understand this, it needs to be read in context with the + -- implementation of 'matchPlus' below + case msum (map f xs) of + Match m' d' xs' -> Match (min m m') (d + d') xs' + -- The minimum match class is the one we keep. The match depth is + -- tracked but not used in the Match case. + + NoMatch d' ms -> NoMatch (d + d') ms + -- Here is where we transfer the depth we were keeping track of in + -- the Match case over to the NoMatch case where it finally gets used. + +instance MonadPlus Match where + mzero = empty + mplus = matchPlus + +() :: Match a -> Match a -> Match a +() = matchPlusShadowing + +infixl 3 + +-- | Combine two matchers. Exact matches are used over inexact matches +-- but if we have multiple exact, or inexact then the we collect all the +-- ambiguous matches. +-- +-- This operator is associative, has unit 'mzero' and is also commutative. +-- +matchPlus :: Match a -> Match a -> Match a +matchPlus a@(Match _ _ _ ) (NoMatch _ _) = a +matchPlus (NoMatch _ _ ) b@(Match _ _ _) = b +matchPlus a@(NoMatch d_a ms_a) b@(NoMatch d_b ms_b) + | d_a > d_b = a -- We only really make use of the depth in the NoMatch case. + | d_a < d_b = b + | otherwise = NoMatch d_a (ms_a ++ ms_b) +matchPlus a@(Match m_a d_a xs_a) b@(Match m_b d_b xs_b) + | m_a > m_b = a -- exact over inexact + | m_a < m_b = b -- exact over inexact + | otherwise = Match m_a (max d_a d_b) (xs_a ++ xs_b) + +-- | Combine two matchers. This is similar to 'matchPlus' with the +-- difference that an exact match from the left matcher shadows any exact +-- match on the right. Inexact matches are still collected however. +-- +-- This operator is associative, has unit 'mzero' and is not commutative. +-- +matchPlusShadowing :: Match a -> Match a -> Match a +matchPlusShadowing a@(Match Exact _ _) _ = a +matchPlusShadowing a b = matchPlus a b + + +------------------------------ +-- Various match primitives +-- + +matchErrorExpected :: String -> String -> Match a +matchErrorExpected thing got = NoMatch 0 [MatchErrorExpected thing got] + +matchErrorNoSuch :: String -> String -> [String] -> Match a +matchErrorNoSuch thing got alts = NoMatch 0 [MatchErrorNoSuch thing got alts] + +expecting :: String -> String -> Match a -> Match a +expecting thing got (NoMatch 0 _) = matchErrorExpected thing got +expecting _ _ m = m + +orNoSuchThing :: String -> String -> [String] -> Match a -> Match a +orNoSuchThing thing got alts (NoMatch 0 _) = matchErrorNoSuch thing got alts +orNoSuchThing _ _ _ m = m + +orNoThingIn :: String -> String -> Match a -> Match a +orNoThingIn kind name (NoMatch n ms) = + NoMatch n [ MatchErrorIn kind name m | m <- ms ] +orNoThingIn _ _ m = m + +increaseConfidence :: Match () +increaseConfidence = Match Exact 1 [()] + +increaseConfidenceFor :: Match a -> Match a +increaseConfidenceFor m = m >>= \r -> increaseConfidence >> return r + +nubMatchesBy :: (a -> a -> Bool) -> Match a -> Match a +nubMatchesBy _ (NoMatch d msgs) = NoMatch d msgs +nubMatchesBy eq (Match m d xs) = Match m d (nubBy eq xs) + +-- | Lift a list of matches to an exact match. +-- +exactMatches, inexactMatches :: [a] -> Match a + +exactMatches [] = mzero +exactMatches xs = Match Exact 0 xs + +inexactMatches [] = mzero +inexactMatches xs = Match Inexact 0 xs + +unknownMatch :: a -> Match a +unknownMatch x = Match Unknown 0 [x] + +tryEach :: [a] -> Match a +tryEach = exactMatches + + +------------------------------ +-- Top level match runner +-- + +-- | Given a matcher and a key to look up, use the matcher to find all the +-- possible matches. There may be 'None', a single 'Unambiguous' match or +-- you may have an 'Ambiguous' match with several possibilities. +-- +findMatch :: Match a -> MaybeAmbiguous a +findMatch match = case match of + NoMatch _ msgs -> None msgs + Match _ _ [x] -> Unambiguous x + Match m d [] -> error $ "findMatch: impossible: " ++ show match' + where match' = Match m d [] :: Match () + -- TODO: Maybe use Data.List.NonEmpty inside + -- Match so that this case would be correct + -- by construction? + Match m _ xs -> Ambiguous m xs + +data MaybeAmbiguous a = None [MatchError] + | Unambiguous a + | Ambiguous MatchClass [a] + deriving Show + + +------------------------------ +-- Basic matchers +-- + +-- | A primitive matcher that looks up a value in a finite 'Map'. The +-- value must match exactly. +-- +matchExactly :: Ord k => (a -> k) -> [a] -> (k -> Match a) +matchExactly key xs = + \k -> case Map.lookup k m of + Nothing -> mzero + Just ys -> exactMatches ys + where + m = Map.fromListWith (++) [ (key x, [x]) | x <- xs ] + +-- | A primitive matcher that looks up a value in a finite 'Map'. It checks +-- for an exact or inexact match. We get an inexact match if the match +-- is not exact, but the canonical forms match. It takes a canonicalisation +-- function for this purpose. +-- +-- So for example if we used string case fold as the canonicalisation +-- function, then we would get case insensitive matching (but it will still +-- report an exact match when the case matches too). +-- +matchInexactly :: (Ord k, Ord k') => (k -> k') -> (a -> k) + -> [a] -> (k -> Match a) +matchInexactly cannonicalise key xs = + \k -> case Map.lookup k m of + Just ys -> exactMatches ys + Nothing -> case Map.lookup (cannonicalise k) m' of + Just ys -> inexactMatches ys + Nothing -> mzero + where + m = Map.fromListWith (++) [ (key x, [x]) | x <- xs ] + + -- the map of canonicalised keys to groups of inexact matches + m' = Map.mapKeysWith (++) cannonicalise m + +matchParse :: Parsec a => String -> Match a +matchParse = maybe mzero return . simpleParsec + + +------------------------------ +-- Utils +-- + +caseFold :: String -> String +caseFold = lowercase + +-- | Make a 'ComponentName' given an 'UnqualComponentName' and knowing the +-- 'ComponentKind'. We also need the 'PackageName' to distinguish the package's +-- primary library from named private libraries. +-- +mkComponentName :: PackageName + -> ComponentKind + -> UnqualComponentName + -> ComponentName +mkComponentName pkgname ckind ucname = + case ckind of + LibKind + | packageNameToUnqualComponentName pkgname == ucname + -> CLibName LMainLibName + | otherwise -> CLibName $ LSubLibName ucname + FLibKind -> CFLibName ucname + ExeKind -> CExeName ucname + TestKind -> CTestName ucname + BenchKind -> CBenchName ucname + + +------------------------------ +-- Example inputs +-- + +{- +ex1pinfo :: [KnownPackage] +ex1pinfo = + [ addComponent (CExeName (mkUnqualComponentName "foo-exe")) [] ["Data.Foo"] $ + KnownPackage { + pinfoId = PackageIdentifier (mkPackageName "foo") (mkVersion [1]), + pinfoDirectory = Just ("/the/foo", "foo"), + pinfoPackageFile = Just ("/the/foo/foo.cabal", "foo/foo.cabal"), + pinfoComponents = [] + } + , KnownPackage { + pinfoId = PackageIdentifier (mkPackageName "bar") (mkVersion [1]), + pinfoDirectory = Just ("/the/bar", "bar"), + pinfoPackageFile = Just ("/the/bar/bar.cabal", "bar/bar.cabal"), + pinfoComponents = [] + } + ] + where + addComponent n ds ms p = + p { + pinfoComponents = + KnownComponent n (componentStringName (pinfoId p) n) + p ds (map mkMn ms) + [] [] [] + : pinfoComponents p + } + + mkMn :: String -> ModuleName + mkMn = ModuleName.fromString +-} +{- +stargets = + [ TargetComponent (CExeName "foo") WholeComponent + , TargetComponent (CExeName "foo") (ModuleTarget (mkMn "Foo")) + , TargetComponent (CExeName "tst") (ModuleTarget (mkMn "Foo")) + ] + where + mkMn :: String -> ModuleName + mkMn = fromJust . simpleParse + +ex_pkgid :: PackageIdentifier +Just ex_pkgid = simpleParse "thelib" +-} + +{- +ex_cs :: [KnownComponent] +ex_cs = + [ (mkC (CExeName "foo") ["src1", "src1/src2"] ["Foo", "Src2.Bar", "Bar"]) + , (mkC (CExeName "tst") ["src1", "test"] ["Foo"]) + ] + where + mkC n ds ms = KnownComponent n (componentStringName n) ds (map mkMn ms) + mkMn :: String -> ModuleName + mkMn = fromJust . simpleParse + pkgid :: PackageIdentifier + Just pkgid = simpleParse "thelib" +-} diff --git a/cabal/cabal-install/src/Distribution/Client/Targets.hs b/cabal/cabal-install/src/Distribution/Client/Targets.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Targets.hs @@ -0,0 +1,715 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Targets +-- Copyright : (c) Duncan Coutts 2011 +-- License : BSD-like +-- +-- Maintainer : duncan@community.haskell.org +-- +-- Handling for user-specified targets +----------------------------------------------------------------------------- +module Distribution.Client.Targets ( + -- * User targets + UserTarget(..), + readUserTargets, + + -- * Resolving user targets to package specifiers + resolveUserTargets, + + -- ** Detailed interface + UserTargetProblem(..), + readUserTarget, + reportUserTargetProblems, + expandUserTarget, + + PackageTarget(..), + fetchPackageTarget, + readPackageTarget, + + PackageTargetProblem(..), + reportPackageTargetProblems, + + disambiguatePackageTargets, + disambiguatePackageName, + + -- * User constraints + UserQualifier(..), + UserConstraintScope(..), + UserConstraint(..), + userConstraintPackageName, + readUserConstraint, + userToPackageConstraint, + + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Distribution.Package + ( Package(..), PackageName, unPackageName, mkPackageName + , packageName ) +import Distribution.Client.Types + ( PackageLocation(..), ResolvedPkgLoc, UnresolvedSourcePackage + , PackageSpecifier(..) ) + +import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.PackageConstraint +import Distribution.Solver.Types.PackagePath +import Distribution.Solver.Types.PackageIndex (PackageIndex) +import qualified Distribution.Solver.Types.PackageIndex as PackageIndex +import Distribution.Solver.Types.SourcePackage + +import qualified Codec.Archive.Tar as Tar +import qualified Codec.Archive.Tar.Entry as Tar +import qualified Distribution.Client.Tar as Tar +import Distribution.Client.FetchUtils +import Distribution.Client.Utils ( tryFindPackageDesc ) +import Distribution.Client.GlobalFlags + ( RepoContext(..) ) +import Distribution.Types.PackageVersionConstraint + ( PackageVersionConstraint (..) ) + +import Distribution.PackageDescription + ( GenericPackageDescription ) +import Distribution.Types.Flag + ( parsecFlagAssignmentNonEmpty ) +import Distribution.Version + ( isAnyVersion ) +import Distribution.Simple.Utils + ( die', lowercase ) + +import Distribution.PackageDescription.Parsec + ( parseGenericPackageDescriptionMaybe ) +import Distribution.Simple.PackageDescription + ( readGenericPackageDescription ) + +import qualified Data.Map as Map +import qualified Data.ByteString.Lazy as BS +import qualified Distribution.Client.GZipUtils as GZipUtils +import qualified Distribution.Compat.CharParsing as P +import System.FilePath + ( takeExtension, dropExtension, takeDirectory, splitPath ) +import System.Directory + ( doesFileExist, doesDirectoryExist ) +import Network.URI + ( URI(..), URIAuth(..), parseAbsoluteURI ) + +-- ------------------------------------------------------------ +-- * User targets +-- ------------------------------------------------------------ + +-- | Various ways that a user may specify a package or package collection. +-- +data UserTarget = + + -- | A partially specified package, identified by name and possibly with + -- an exact version or a version constraint. + -- + -- > cabal install foo + -- > cabal install foo-1.0 + -- > cabal install 'foo < 2' + -- + UserTargetNamed PackageVersionConstraint + + -- | A specific package that is unpacked in a local directory, often the + -- current directory. + -- + -- > cabal install . + -- > cabal install ../lib/other + -- + -- * Note: in future, if multiple @.cabal@ files are allowed in a single + -- directory then this will refer to the collection of packages. + -- + | UserTargetLocalDir FilePath + + -- | A specific local unpacked package, identified by its @.cabal@ file. + -- + -- > cabal install foo.cabal + -- > cabal install ../lib/other/bar.cabal + -- + | UserTargetLocalCabalFile FilePath + + -- | A specific package that is available as a local tarball file + -- + -- > cabal install dist/foo-1.0.tar.gz + -- > cabal install ../build/baz-1.0.tar.gz + -- + | UserTargetLocalTarball FilePath + + -- | A specific package that is available as a remote tarball file + -- + -- > cabal install http://code.haskell.org/~user/foo/foo-0.9.tar.gz + -- + | UserTargetRemoteTarball URI + deriving (Show,Eq) + + +-- ------------------------------------------------------------ +-- * Parsing and checking user targets +-- ------------------------------------------------------------ + +readUserTargets :: Verbosity -> [String] -> IO [UserTarget] +readUserTargets verbosity targetStrs = do + (problems, targets) <- liftM partitionEithers + (traverse readUserTarget targetStrs) + reportUserTargetProblems verbosity problems + return targets + + +data UserTargetProblem + = UserTargetUnexpectedFile String + | UserTargetNonexistantFile String + | UserTargetUnexpectedUriScheme String + | UserTargetUnrecognisedUri String + | UserTargetUnrecognised String + deriving Show + +readUserTarget :: String -> IO (Either UserTargetProblem UserTarget) +readUserTarget targetstr = + case eitherParsec targetstr of + Right dep -> return (Right (UserTargetNamed dep)) + Left _err -> do + fileTarget <- testFileTargets targetstr + case fileTarget of + Just target -> return target + Nothing -> + case testUriTargets targetstr of + Just target -> return target + Nothing -> return (Left (UserTargetUnrecognised targetstr)) + where + testFileTargets :: FilePath -> IO (Maybe (Either UserTargetProblem UserTarget)) + testFileTargets filename = do + isDir <- doesDirectoryExist filename + isFile <- doesFileExist filename + parentDirExists <- case takeDirectory filename of + [] -> return False + dir -> doesDirectoryExist dir + let result :: Maybe (Either UserTargetProblem UserTarget) + result + | isDir + = Just (Right (UserTargetLocalDir filename)) + + | isFile && extensionIsTarGz filename + = Just (Right (UserTargetLocalTarball filename)) + + | isFile && takeExtension filename == ".cabal" + = Just (Right (UserTargetLocalCabalFile filename)) + + | isFile + = Just (Left (UserTargetUnexpectedFile filename)) + + | parentDirExists + = Just (Left (UserTargetNonexistantFile filename)) + + | otherwise + = Nothing + return result + + testUriTargets :: String -> Maybe (Either UserTargetProblem UserTarget) + testUriTargets str = + case parseAbsoluteURI str of + Just uri@URI { + uriScheme = scheme, + uriAuthority = Just URIAuth { uriRegName = host } + } + | scheme /= "http:" && scheme /= "https:" -> + Just (Left (UserTargetUnexpectedUriScheme targetstr)) + + | null host -> + Just (Left (UserTargetUnrecognisedUri targetstr)) + + | otherwise -> + Just (Right (UserTargetRemoteTarball uri)) + _ -> Nothing + + extensionIsTarGz :: FilePath -> Bool + extensionIsTarGz f = takeExtension f == ".gz" + && takeExtension (dropExtension f) == ".tar" + +reportUserTargetProblems :: Verbosity -> [UserTargetProblem] -> IO () +reportUserTargetProblems verbosity problems = do + case [ target | UserTargetUnrecognised target <- problems ] of + [] -> return () + target -> die' verbosity + $ unlines + [ "Unrecognised target '" ++ name ++ "'." + | name <- target ] + ++ "Targets can be:\n" + ++ " - package names, e.g. 'pkgname', 'pkgname-1.0.1', 'pkgname < 2.0'\n" + ++ " - cabal files 'pkgname.cabal' or package directories 'pkgname/'\n" + ++ " - package tarballs 'pkgname.tar.gz' or 'http://example.com/pkgname.tar.gz'" + + case [ target | UserTargetNonexistantFile target <- problems ] of + [] -> return () + target -> die' verbosity + $ unlines + [ "The file does not exist '" ++ name ++ "'." + | name <- target ] + + case [ target | UserTargetUnexpectedFile target <- problems ] of + [] -> return () + target -> die' verbosity + $ unlines + [ "Unrecognised file target '" ++ name ++ "'." + | name <- target ] + ++ "File targets can be either package tarballs 'pkgname.tar.gz' " + ++ "or cabal files 'pkgname.cabal'." + + case [ target | UserTargetUnexpectedUriScheme target <- problems ] of + [] -> return () + target -> die' verbosity + $ unlines + [ "URL target not supported '" ++ name ++ "'." + | name <- target ] + ++ "Only 'http://' and 'https://' URLs are supported." + + case [ target | UserTargetUnrecognisedUri target <- problems ] of + [] -> return () + target -> die' verbosity + $ unlines + [ "Unrecognise URL target '" ++ name ++ "'." + | name <- target ] + + +-- ------------------------------------------------------------ +-- * Resolving user targets to package specifiers +-- ------------------------------------------------------------ + +-- | Given a bunch of user-specified targets, try to resolve what it is they +-- refer to. They can either be specific packages (local dirs, tarballs etc) +-- or they can be named packages (with or without version info). +-- +resolveUserTargets :: Package pkg + => Verbosity + -> RepoContext + -> PackageIndex pkg + -> [UserTarget] + -> IO [PackageSpecifier UnresolvedSourcePackage] +resolveUserTargets verbosity repoCtxt available userTargets = do + + -- given the user targets, get a list of fully or partially resolved + -- package references + packageTargets <- traverse (readPackageTarget verbosity) + =<< traverse (fetchPackageTarget verbosity repoCtxt) . concat + =<< traverse (expandUserTarget verbosity) userTargets + + -- users are allowed to give package names case-insensitively, so we must + -- disambiguate named package references + let (problems, packageSpecifiers) :: ([PackageTargetProblem], [PackageSpecifier UnresolvedSourcePackage]) = + disambiguatePackageTargets available availableExtra packageTargets + + -- use any extra specific available packages to help us disambiguate + availableExtra :: [PackageName] + availableExtra = [ packageName pkg + | PackageTargetLocation pkg <- packageTargets ] + + reportPackageTargetProblems verbosity problems + + return packageSpecifiers + + +-- ------------------------------------------------------------ +-- * Package targets +-- ------------------------------------------------------------ + +-- | An intermediate between a 'UserTarget' and a resolved 'PackageSpecifier'. +-- Unlike a 'UserTarget', a 'PackageTarget' refers only to a single package. +-- +data PackageTarget pkg = + PackageTargetNamed PackageName [PackageProperty] UserTarget + + -- | A package identified by name, but case insensitively, so it needs + -- to be resolved to the right case-sensitive name. + | PackageTargetNamedFuzzy PackageName [PackageProperty] UserTarget + | PackageTargetLocation pkg + deriving (Show, Functor, Foldable, Traversable) + + +-- ------------------------------------------------------------ +-- * Converting user targets to package targets +-- ------------------------------------------------------------ + +-- | Given a user-specified target, expand it to a bunch of package targets +-- (each of which refers to only one package). +-- +expandUserTarget :: Verbosity + -> UserTarget + -> IO [PackageTarget (PackageLocation ())] +expandUserTarget verbosity userTarget = case userTarget of + + UserTargetNamed (PackageVersionConstraint name vrange) -> + let props = [ PackagePropertyVersion vrange + | not (isAnyVersion vrange) ] + in return [PackageTargetNamedFuzzy name props userTarget] + + UserTargetLocalDir dir -> + return [ PackageTargetLocation (LocalUnpackedPackage dir) ] + + UserTargetLocalCabalFile file -> do + let dir = takeDirectory file + _ <- tryFindPackageDesc verbosity dir (localPackageError dir) -- just as a check + return [ PackageTargetLocation (LocalUnpackedPackage dir) ] + + UserTargetLocalTarball tarballFile -> + return [ PackageTargetLocation (LocalTarballPackage tarballFile) ] + + UserTargetRemoteTarball tarballURL -> + return [ PackageTargetLocation (RemoteTarballPackage tarballURL ()) ] + +localPackageError :: FilePath -> String +localPackageError dir = + "Error reading local package.\nCouldn't find .cabal file in: " ++ dir + +-- ------------------------------------------------------------ +-- * Fetching and reading package targets +-- ------------------------------------------------------------ + + +-- | Fetch any remote targets so that they can be read. +-- +fetchPackageTarget :: Verbosity + -> RepoContext + -> PackageTarget (PackageLocation ()) + -> IO (PackageTarget ResolvedPkgLoc) +fetchPackageTarget verbosity repoCtxt = traverse $ + fetchPackage verbosity repoCtxt . fmap (const Nothing) + + +-- | Given a package target that has been fetched, read the .cabal file. +-- +-- This only affects targets given by location, named targets are unaffected. +-- +readPackageTarget :: Verbosity + -> PackageTarget ResolvedPkgLoc + -> IO (PackageTarget UnresolvedSourcePackage) +readPackageTarget verbosity = traverse modifyLocation + where + modifyLocation :: ResolvedPkgLoc -> IO UnresolvedSourcePackage + modifyLocation location = case location of + + LocalUnpackedPackage dir -> do + pkg <- tryFindPackageDesc verbosity dir (localPackageError dir) >>= + readGenericPackageDescription verbosity + return SourcePackage + { srcpkgPackageId = packageId pkg + , srcpkgDescription = pkg + , srcpkgSource = fmap Just location + , srcpkgDescrOverride = Nothing + } + + LocalTarballPackage tarballFile -> + readTarballPackageTarget location tarballFile tarballFile + + RemoteTarballPackage tarballURL tarballFile -> + readTarballPackageTarget location tarballFile (show tarballURL) + + RepoTarballPackage _repo _pkgid _ -> + error "TODO: readPackageTarget RepoTarballPackage" + -- For repo tarballs this info should be obtained from the index. + + RemoteSourceRepoPackage _srcRepo _ -> + error "TODO: readPackageTarget RemoteSourceRepoPackage" + -- This can't happen, because it would have errored out already + -- in fetchPackage, via fetchPackageTarget before it gets to this + -- function. + -- + -- When that is corrected, this will also need to be fixed. + + readTarballPackageTarget :: ResolvedPkgLoc -> FilePath -> FilePath -> IO UnresolvedSourcePackage + readTarballPackageTarget location tarballFile tarballOriginalLoc = do + (filename, content) <- extractTarballPackageCabalFile + tarballFile tarballOriginalLoc + case parsePackageDescription' content of + Nothing -> die' verbosity $ "Could not parse the cabal file " + ++ filename ++ " in " ++ tarballFile + Just pkg -> + return SourcePackage + { srcpkgPackageId = packageId pkg + , srcpkgDescription = pkg + , srcpkgSource = fmap Just location + , srcpkgDescrOverride = Nothing + } + + extractTarballPackageCabalFile :: FilePath -> String + -> IO (FilePath, BS.ByteString) + extractTarballPackageCabalFile tarballFile tarballOriginalLoc = + either (die' verbosity . formatErr) return + . check + . accumEntryMap + . Tar.filterEntries isCabalFile + . Tar.read + . GZipUtils.maybeDecompress + =<< BS.readFile tarballFile + where + formatErr msg = "Error reading " ++ tarballOriginalLoc ++ ": " ++ msg + + accumEntryMap :: Tar.Entries Tar.FormatError + -> Either (Tar.FormatError, Map Tar.TarPath Tar.Entry) (Map Tar.TarPath Tar.Entry) + accumEntryMap = Tar.foldlEntries + (\m e -> Map.insert (Tar.entryTarPath e) e m) + Map.empty + + check (Left e) = Left (show e) + check (Right m) = case Map.elems m of + [] -> Left noCabalFile + [file] -> case Tar.entryContent file of + Tar.NormalFile content _ -> Right (Tar.entryPath file, content) + _ -> Left noCabalFile + _files -> Left multipleCabalFiles + where + noCabalFile = "No cabal file found" + multipleCabalFiles = "Multiple cabal files found" + + isCabalFile :: Tar.Entry -> Bool + isCabalFile e = case splitPath (Tar.entryPath e) of + [ _dir, file] -> takeExtension file == ".cabal" + [".", _dir, file] -> takeExtension file == ".cabal" + _ -> False + + parsePackageDescription' :: BS.ByteString -> Maybe GenericPackageDescription + parsePackageDescription' bs = + parseGenericPackageDescriptionMaybe (BS.toStrict bs) + +-- ------------------------------------------------------------ +-- * Checking package targets +-- ------------------------------------------------------------ + +data PackageTargetProblem + = PackageNameUnknown PackageName UserTarget + | PackageNameAmbiguous PackageName [PackageName] UserTarget + deriving Show + + +-- | Users are allowed to give package names case-insensitively, so we must +-- disambiguate named package references. +-- +disambiguatePackageTargets :: Package pkg' + => PackageIndex pkg' + -> [PackageName] + -> [PackageTarget pkg] + -> ( [PackageTargetProblem] + , [PackageSpecifier pkg] ) +disambiguatePackageTargets availablePkgIndex availableExtra targets = + partitionEithers (map disambiguatePackageTarget targets) + where + disambiguatePackageTarget packageTarget = case packageTarget of + PackageTargetLocation pkg -> Right (SpecificSourcePackage pkg) + + PackageTargetNamed pkgname props userTarget + | null (PackageIndex.lookupPackageName availablePkgIndex pkgname) + -> Left (PackageNameUnknown pkgname userTarget) + | otherwise -> Right (NamedPackage pkgname props) + + PackageTargetNamedFuzzy pkgname props userTarget -> + case disambiguatePackageName packageNameEnv pkgname of + None -> Left (PackageNameUnknown + pkgname userTarget) + Ambiguous pkgnames -> Left (PackageNameAmbiguous + pkgname pkgnames userTarget) + Unambiguous pkgname' -> Right (NamedPackage pkgname' props) + + -- use any extra specific available packages to help us disambiguate + packageNameEnv :: PackageNameEnv + packageNameEnv = mappend (indexPackageNameEnv availablePkgIndex) + (extraPackageNameEnv availableExtra) + + +-- | Report problems to the user. That is, if there are any problems +-- then raise an exception. +reportPackageTargetProblems :: Verbosity + -> [PackageTargetProblem] -> IO () +reportPackageTargetProblems verbosity problems = do + case [ pkg | PackageNameUnknown pkg _ <- problems ] of + [] -> return () + pkgs -> die' verbosity $ unlines + [ "There is no package named '" ++ prettyShow name ++ "'. " + | name <- pkgs ] + ++ "You may need to run 'hackport update' to get the latest " + ++ "list of available packages." + + case [ (pkg, matches) | PackageNameAmbiguous pkg matches _ <- problems ] of + [] -> return () + ambiguities -> die' verbosity $ unlines + [ "There is no package named '" ++ prettyShow name ++ "'. " + ++ (if length matches > 1 + then "However, the following package names exist: " + else "However, the following package name exists: ") + ++ intercalate ", " [ "'" ++ prettyShow m ++ "'" | m <- matches] + ++ "." + | (name, matches) <- ambiguities ] + + +-- ------------------------------------------------------------ +-- * Disambiguating package names +-- ------------------------------------------------------------ + +data MaybeAmbiguous a = None | Unambiguous a | Ambiguous [a] + +-- | Given a package name and a list of matching names, figure out +-- which one it might be referring to. If there is an exact +-- case-sensitive match then that's ok (i.e. returned via +-- 'Unambiguous'). If it matches just one package case-insensitively +-- or if it matches multiple packages case-insensitively, in that case +-- the result is 'Ambiguous'. +-- +-- Note: Before cabal 2.2, when only a single package matched +-- case-insensitively it would be considered 'Unambiguous'. +-- +disambiguatePackageName :: PackageNameEnv + -> PackageName + -> MaybeAmbiguous PackageName +disambiguatePackageName (PackageNameEnv pkgNameLookup) name = + case nub (pkgNameLookup name) of + [] -> None + names -> case find (name==) names of + Just name' -> Unambiguous name' + Nothing -> Ambiguous names + + +newtype PackageNameEnv = PackageNameEnv (PackageName -> [PackageName]) + +instance Monoid PackageNameEnv where + mempty = PackageNameEnv (const []) + mappend = (<>) + +instance Semigroup PackageNameEnv where + PackageNameEnv lookupA <> PackageNameEnv lookupB = + PackageNameEnv (\name -> lookupA name ++ lookupB name) + +indexPackageNameEnv :: PackageIndex pkg -> PackageNameEnv +indexPackageNameEnv pkgIndex = PackageNameEnv pkgNameLookup + where + pkgNameLookup pname = + map fst (PackageIndex.searchByName pkgIndex $ unPackageName pname) + +extraPackageNameEnv :: [PackageName] -> PackageNameEnv +extraPackageNameEnv names = PackageNameEnv pkgNameLookup + where + pkgNameLookup pname = + [ pname' + | let lname = lowercase (unPackageName pname) + , pname' <- names + , lowercase (unPackageName pname') == lname ] + + +-- ------------------------------------------------------------ +-- * Package constraints +-- ------------------------------------------------------------ + +-- | Version of 'Qualifier' that a user may specify on the +-- command line. +data UserQualifier = + -- | Top-level dependency. + UserQualToplevel + + -- | Setup dependency. + | UserQualSetup PackageName + + -- | Executable dependency. + | UserQualExe PackageName PackageName + deriving (Eq, Show, Generic) + +instance Binary UserQualifier +instance Structured UserQualifier + +-- | Version of 'ConstraintScope' that a user may specify on the +-- command line. +data UserConstraintScope = + -- | 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 any qualifier. + | UserAnyQualifier PackageName + deriving (Eq, Show, Generic) + +instance Binary UserConstraintScope +instance Structured UserConstraintScope + +fromUserQualifier :: UserQualifier -> Qualifier +fromUserQualifier UserQualToplevel = QualToplevel +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 + +-- | Version of 'PackageConstraint' that the user can specify on +-- the command line. +data UserConstraint = + UserConstraint UserConstraintScope PackageProperty + deriving (Eq, Show, Generic) + +instance Binary UserConstraint +instance Structured UserConstraint + +userConstraintPackageName :: UserConstraint -> PackageName +userConstraintPackageName (UserConstraint scope _) = scopePN scope + where + scopePN (UserQualified _ pn) = pn + scopePN (UserAnyQualifier pn) = pn + scopePN (UserAnySetupQualifier pn) = pn + +userToPackageConstraint :: UserConstraint -> PackageConstraint +userToPackageConstraint (UserConstraint scope prop) = + PackageConstraint (fromUserConstraintScope scope) prop + +readUserConstraint :: String -> Either String UserConstraint +readUserConstraint str = + case explicitEitherParsec parsec str of + Left err -> Left $ msgCannotParse ++ err + Right c -> Right c + where + msgCannotParse = + "expected a (possibly qualified) package name followed by a " ++ + "constraint, which is either a version range, 'installed', " ++ + "'source', 'test', 'bench', or flags. " + +instance Pretty UserConstraint where + pretty (UserConstraint scope prop) = + dispPackageConstraint $ PackageConstraint (fromUserConstraintScope scope) prop + +instance Parsec UserConstraint where + parsec = do + scope <- parseConstraintScope + P.spaces + prop <- P.choice + [ PackagePropertyFlags <$> parsecFlagAssignmentNonEmpty -- headed by "+-" + , PackagePropertyVersion <$> parsec -- headed by "<=>" (will be) + , PackagePropertyInstalled <$ P.string "installed" + , PackagePropertySource <$ P.string "source" + , PackagePropertyStanzas [TestStanzas] <$ P.string "test" + , PackagePropertyStanzas [BenchStanzas] <$ P.string "bench" + ] + return (UserConstraint scope prop) + + where + parseConstraintScope :: forall m. CabalParsing m => m UserConstraintScope + parseConstraintScope = do + pn <- parsec + P.choice + [ P.char '.' *> withDot pn + , P.char ':' *> withColon pn + , return (UserQualified UserQualToplevel pn) + ] + where + withDot :: PackageName -> m UserConstraintScope + withDot pn + | pn == mkPackageName "any" = UserAnyQualifier <$> parsec + | pn == mkPackageName "setup" = UserAnySetupQualifier <$> parsec + | otherwise = P.unexpected $ "constraint scope: " ++ unPackageName pn + + withColon :: PackageName -> m UserConstraintScope + withColon pn = UserQualified (UserQualSetup pn) + <$ P.string "setup." + <*> parsec diff --git a/cabal/cabal-install/src/Distribution/Client/Types.hs b/cabal/cabal-install/src/Distribution/Client/Types.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Types.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Types +-- Copyright : (c) David Himmelstrup 2005 +-- Duncan Coutts 2011 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Various common data types for the entire cabal-install system +----------------------------------------------------------------------------- +module Distribution.Client.Types ( + module Distribution.Client.Types.AllowNewer, + module Distribution.Client.Types.ConfiguredId, + module Distribution.Client.Types.ConfiguredPackage, + module Distribution.Client.Types.BuildResults, + module Distribution.Client.Types.PackageLocation, + module Distribution.Client.Types.PackageSpecifier, + module Distribution.Client.Types.ReadyPackage, + module Distribution.Client.Types.Repo, + module Distribution.Client.Types.RepoName, + module Distribution.Client.Types.SourcePackageDb, + module Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy, +) where + + +import Distribution.Client.Types.AllowNewer +import Distribution.Client.Types.BuildResults +import Distribution.Client.Types.ConfiguredId +import Distribution.Client.Types.ConfiguredPackage +import Distribution.Client.Types.PackageLocation +import Distribution.Client.Types.PackageSpecifier +import Distribution.Client.Types.Repo +import Distribution.Client.Types.RepoName +import Distribution.Client.Types.ReadyPackage +import Distribution.Client.Types.SourcePackageDb +import Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy diff --git a/cabal/cabal-install/src/Distribution/Client/Types/AllowNewer.hs b/cabal/cabal-install/src/Distribution/Client/Types/AllowNewer.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Types/AllowNewer.hs @@ -0,0 +1,241 @@ +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Client.Types.AllowNewer ( + AllowNewer (..), + AllowOlder (..), + RelaxDeps (..), + mkRelaxDepSome, + RelaxDepMod (..), + RelaxDepScope (..), + RelaxDepSubject (..), + RelaxedDep (..), + isRelaxDeps, +) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Parsec (parsecLeadingCommaNonEmpty) +import Distribution.Types.PackageId (PackageId, PackageIdentifier (..)) +import Distribution.Types.PackageName (PackageName, mkPackageName) +import Distribution.Types.Version (nullVersion) + +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as Disp + +-- $setup +-- >>> import Distribution.Parsec + +-- TODO: When https://github.com/haskell/cabal/issues/4203 gets tackled, +-- it may make sense to move these definitions to the Solver.Types +-- module + +-- | 'RelaxDeps' in the context of upper bounds (i.e. for @--allow-newer@ flag) +newtype AllowNewer = AllowNewer { unAllowNewer :: RelaxDeps } + deriving (Eq, Read, Show, Generic) + +-- | 'RelaxDeps' in the context of lower bounds (i.e. for @--allow-older@ flag) +newtype AllowOlder = AllowOlder { unAllowOlder :: RelaxDeps } + deriving (Eq, Read, Show, Generic) + +-- | Generic data type for policy when relaxing bounds in dependencies. +-- Don't use this directly: use 'AllowOlder' or 'AllowNewer' depending +-- on whether or not you are relaxing an lower or upper bound +-- (respectively). +data RelaxDeps = + + -- | Ignore upper (resp. lower) bounds in some (or no) dependencies on the given packages. + -- + -- @RelaxDepsSome []@ is the default, i.e. honor the bounds in all + -- dependencies, never choose versions newer (resp. older) than allowed. + RelaxDepsSome [RelaxedDep] + + -- | Ignore upper (resp. lower) bounds in dependencies on all packages. + -- + -- __Note__: This is should be semantically equivalent to + -- + -- > RelaxDepsSome [RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll] + -- + -- (TODO: consider normalising 'RelaxDeps' and/or 'RelaxedDep') + | RelaxDepsAll + deriving (Eq, Read, Show, Generic) + +-- | Dependencies can be relaxed either for all packages in the install plan, or +-- only for some packages. +data RelaxedDep = RelaxedDep !RelaxDepScope !RelaxDepMod !RelaxDepSubject + deriving (Eq, Read, Show, Generic) + +-- | Specify the scope of a relaxation, i.e. limit which depending +-- packages are allowed to have their version constraints relaxed. +data RelaxDepScope = RelaxDepScopeAll + -- ^ Apply relaxation in any package + | RelaxDepScopePackage !PackageName + -- ^ Apply relaxation to in all versions of a package + | RelaxDepScopePackageId !PackageId + -- ^ Apply relaxation to a specific version of a package only + deriving (Eq, Read, Show, Generic) + +-- | Modifier for dependency relaxation +data RelaxDepMod = RelaxDepModNone -- ^ Default semantics + | RelaxDepModCaret -- ^ Apply relaxation only to @^>=@ constraints + deriving (Eq, Read, Show, Generic) + +-- | Express whether to relax bounds /on/ @all@ packages, or a single package +data RelaxDepSubject = RelaxDepSubjectAll + | RelaxDepSubjectPkg !PackageName + deriving (Eq, Ord, Read, Show, Generic) + +instance Pretty RelaxedDep where + pretty (RelaxedDep scope rdmod subj) = case scope of + RelaxDepScopeAll -> Disp.text "*:" Disp.<> modDep + RelaxDepScopePackage p0 -> pretty p0 Disp.<> Disp.colon Disp.<> modDep + RelaxDepScopePackageId p0 -> pretty p0 Disp.<> Disp.colon Disp.<> modDep + where + modDep = case rdmod of + RelaxDepModNone -> pretty subj + RelaxDepModCaret -> Disp.char '^' Disp.<> pretty subj + +instance Parsec RelaxedDep where + parsec = P.char '*' *> relaxedDepStarP <|> (parsec >>= relaxedDepPkgidP) + +-- continuation after * +relaxedDepStarP :: CabalParsing m => m RelaxedDep +relaxedDepStarP = + RelaxedDep RelaxDepScopeAll <$ P.char ':' <*> modP <*> parsec + <|> pure (RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll) + +-- continuation after package identifier +relaxedDepPkgidP :: CabalParsing m => PackageIdentifier -> m RelaxedDep +relaxedDepPkgidP pid@(PackageIdentifier pn v) + | pn == mkPackageName "all" + , v == nullVersion + = RelaxedDep RelaxDepScopeAll <$ P.char ':' <*> modP <*> parsec + <|> pure (RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll) + + | v == nullVersion + = RelaxedDep (RelaxDepScopePackage pn) <$ P.char ':' <*> modP <*> parsec + <|> pure (RelaxedDep RelaxDepScopeAll RelaxDepModNone (RelaxDepSubjectPkg pn)) + + | otherwise + = RelaxedDep (RelaxDepScopePackageId pid) <$ P.char ':' <*> modP <*> parsec + +modP :: P.CharParsing m => m RelaxDepMod +modP = RelaxDepModCaret <$ P.char '^' <|> pure RelaxDepModNone + +instance Pretty RelaxDepSubject where + pretty RelaxDepSubjectAll = Disp.text "*" + pretty (RelaxDepSubjectPkg pn) = pretty pn + +instance Parsec RelaxDepSubject where + parsec = RelaxDepSubjectAll <$ P.char '*' <|> pkgn + where + pkgn = do + pn <- parsec + pure $ if pn == mkPackageName "all" + then RelaxDepSubjectAll + else RelaxDepSubjectPkg pn + +instance Pretty RelaxDeps where + pretty rd | not (isRelaxDeps rd) = Disp.text "none" + pretty (RelaxDepsSome pkgs) = Disp.fsep . + Disp.punctuate Disp.comma . + map pretty $ pkgs + pretty RelaxDepsAll = Disp.text "all" + +-- | +-- +-- >>> simpleParsec "all" :: Maybe RelaxDeps +-- Just RelaxDepsAll +-- +-- >>> simpleParsec "none" :: Maybe RelaxDeps +-- Just (RelaxDepsSome []) +-- +-- >>> simpleParsec "*, *" :: Maybe RelaxDeps +-- Just RelaxDepsAll +-- +-- >>> simpleParsec "*:*" :: Maybe RelaxDeps +-- Just RelaxDepsAll +-- +-- >>> simpleParsec "foo:bar, quu:puu" :: Maybe RelaxDeps +-- Just (RelaxDepsSome [RelaxedDep (RelaxDepScopePackage (PackageName "foo")) RelaxDepModNone (RelaxDepSubjectPkg (PackageName "bar")),RelaxedDep (RelaxDepScopePackage (PackageName "quu")) RelaxDepModNone (RelaxDepSubjectPkg (PackageName "puu"))]) +-- +-- This is not a glitch, even it looks like: +-- +-- >>> simpleParsec ", all" :: Maybe RelaxDeps +-- Just RelaxDepsAll +-- +-- >>> simpleParsec "" :: Maybe RelaxDeps +-- Nothing +-- +instance Parsec RelaxDeps where + parsec = do + xs <- parsecLeadingCommaNonEmpty parsec + pure $ case toList xs of + [RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll] + -> RelaxDepsAll + [RelaxedDep RelaxDepScopeAll RelaxDepModNone (RelaxDepSubjectPkg pn)] + | pn == mkPackageName "none" + -> mempty + xs' -> mkRelaxDepSome xs' + +instance Binary RelaxDeps +instance Binary RelaxDepMod +instance Binary RelaxDepScope +instance Binary RelaxDepSubject +instance Binary RelaxedDep +instance Binary AllowNewer +instance Binary AllowOlder + +instance Structured RelaxDeps +instance Structured RelaxDepMod +instance Structured RelaxDepScope +instance Structured RelaxDepSubject +instance Structured RelaxedDep +instance Structured AllowNewer +instance Structured AllowOlder + +-- | Return 'True' if 'RelaxDeps' specifies a non-empty set of relaxations +-- +-- Equivalent to @isRelaxDeps = (/= 'mempty')@ +isRelaxDeps :: RelaxDeps -> Bool +isRelaxDeps (RelaxDepsSome []) = False +isRelaxDeps (RelaxDepsSome (_:_)) = True +isRelaxDeps RelaxDepsAll = True + +-- | A smarter 'RelaxedDepsSome', @*:*@ is the same as @all@. +mkRelaxDepSome :: [RelaxedDep] -> RelaxDeps +mkRelaxDepSome xs + | any (== RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll) xs + = RelaxDepsAll + + | otherwise + = RelaxDepsSome xs + +-- | 'RelaxDepsAll' is the /absorbing element/ +instance Semigroup RelaxDeps where + -- identity element + RelaxDepsSome [] <> r = r + l@(RelaxDepsSome _) <> RelaxDepsSome [] = l + -- absorbing element + l@RelaxDepsAll <> _ = l + (RelaxDepsSome _) <> r@RelaxDepsAll = r + -- combining non-{identity,absorbing} elements + (RelaxDepsSome a) <> (RelaxDepsSome b) = RelaxDepsSome (a ++ b) + +-- | @'RelaxDepsSome' []@ is the /identity element/ +instance Monoid RelaxDeps where + mempty = RelaxDepsSome [] + mappend = (<>) + +instance Semigroup AllowNewer where + AllowNewer x <> AllowNewer y = AllowNewer (x <> y) + +instance Semigroup AllowOlder where + AllowOlder x <> AllowOlder y = AllowOlder (x <> y) + +instance Monoid AllowNewer where + mempty = AllowNewer mempty + mappend = (<>) + +instance Monoid AllowOlder where + mempty = AllowOlder mempty + mappend = (<>) diff --git a/cabal/cabal-install/src/Distribution/Client/Types/BuildResults.hs b/cabal/cabal-install/src/Distribution/Client/Types/BuildResults.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Types/BuildResults.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Client.Types.BuildResults ( + BuildOutcome, + BuildOutcomes, + BuildFailure (..), + BuildResult (..), + TestsResult (..), + DocsResult (..), +) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Types.InstalledPackageInfo (InstalledPackageInfo) +import Distribution.Types.PackageId (PackageId) +import Distribution.Types.UnitId (UnitId) + +-- | A summary of the outcome for building a single package. +-- +type BuildOutcome = Either BuildFailure BuildResult + +-- | A summary of the outcome for building a whole set of packages. +-- +type BuildOutcomes = Map UnitId BuildOutcome + +data BuildFailure = PlanningFailed + | DependentFailed PackageId + | DownloadFailed SomeException + | UnpackFailed SomeException + | ConfigureFailed SomeException + | BuildFailed SomeException + | TestsFailed SomeException + | InstallFailed SomeException + deriving (Show, Typeable, Generic) + +instance Exception BuildFailure + +-- Note that the @Maybe InstalledPackageInfo@ is a slight hack: we only +-- the public library's 'InstalledPackageInfo' is stored here, even if +-- there were 'InstalledPackageInfo' from internal libraries. This +-- 'InstalledPackageInfo' is not used anyway, so it makes no difference. +data BuildResult = BuildResult DocsResult TestsResult + (Maybe InstalledPackageInfo) + deriving (Show, Generic) + +data DocsResult = DocsNotTried | DocsFailed | DocsOk + deriving (Show, Generic, Typeable) +data TestsResult = TestsNotTried | TestsOk + deriving (Show, Generic, Typeable) + +instance Binary BuildFailure +instance Binary BuildResult +instance Binary DocsResult +instance Binary TestsResult + +instance Structured BuildFailure +instance Structured BuildResult +instance Structured DocsResult +instance Structured TestsResult diff --git a/cabal/cabal-install/src/Distribution/Client/Types/ConfiguredId.hs b/cabal/cabal-install/src/Distribution/Client/Types/ConfiguredId.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Types/ConfiguredId.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Client.Types.ConfiguredId ( + InstalledPackageId, + ConfiguredId (..), + annotatedIdToConfiguredId, + HasConfiguredId (..), +) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.InstalledPackageInfo (InstalledPackageInfo, sourceComponentName, installedComponentId) +import Distribution.Package (Package (..)) +import Distribution.Types.AnnotatedId (AnnotatedId (..)) +import Distribution.Types.ComponentId (ComponentId) +import Distribution.Types.ComponentName (ComponentName) +import Distribution.Types.PackageId (PackageId) + +------------------------------------------------------------------------------- +-- InstalledPackageId +------------------------------------------------------------------------------- + +-- | Within Cabal the library we no longer have a @InstalledPackageId@ type. +-- That's because it deals with the compilers' notion of a registered library, +-- and those really are libraries not packages. Those are now named units. +-- +-- The package management layer does however deal with installed packages, as +-- whole packages not just as libraries. So we do still need a type for +-- installed package ids. At the moment however we track installed packages via +-- their primary library, which is a unit id. In future this may change +-- slightly and we may distinguish these two types and have an explicit +-- conversion when we register units with the compiler. +-- +type InstalledPackageId = ComponentId + +------------------------------------------------------------------------------- +-- ConfiguredId +------------------------------------------------------------------------------- + +-- | A ConfiguredId is a package ID for a configured package. +-- +-- Once we configure a source package we know its UnitId. It is still +-- however useful in lots of places to also know the source ID for the package. +-- We therefore bundle the two. +-- +-- An already installed package of course is also "configured" (all its +-- configuration parameters and dependencies have been specified). +data ConfiguredId = ConfiguredId { + confSrcId :: PackageId + , confCompName :: Maybe ComponentName + , confInstId :: ComponentId + } + deriving (Eq, Ord, Generic) + +annotatedIdToConfiguredId :: AnnotatedId ComponentId -> ConfiguredId +annotatedIdToConfiguredId aid = ConfiguredId { + confSrcId = ann_pid aid, + confCompName = Just (ann_cname aid), + confInstId = ann_id aid + } + +instance Binary ConfiguredId +instance Structured ConfiguredId + +instance Show ConfiguredId where + show cid = show (confInstId cid) + +instance Package ConfiguredId where + packageId = confSrcId + +------------------------------------------------------------------------------- +-- HasConfiguredId class +------------------------------------------------------------------------------- + +class HasConfiguredId a where + configuredId :: a -> ConfiguredId + +-- NB: This instance is slightly dangerous, in that you'll lose +-- information about the specific UnitId you depended on. +instance HasConfiguredId InstalledPackageInfo where + configuredId ipkg = ConfiguredId (packageId ipkg) + (Just (sourceComponentName ipkg)) + (installedComponentId ipkg) diff --git a/cabal/cabal-install/src/Distribution/Client/Types/ConfiguredPackage.hs b/cabal/cabal-install/src/Distribution/Client/Types/ConfiguredPackage.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Types/ConfiguredPackage.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeFamilies #-} +module Distribution.Client.Types.ConfiguredPackage ( + ConfiguredPackage (..), +) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Compat.Graph (IsNode (..)) +import Distribution.Package (newSimpleUnitId, HasMungedPackageId (..), HasUnitId (..), Package (..), PackageInstalled (..), UnitId) +import Distribution.Types.Flag (FlagAssignment) +import Distribution.Types.ComponentName +import Distribution.Types.LibraryName (LibraryName (..)) +import Distribution.Types.MungedPackageId (computeCompatPackageId) +import Distribution.Simple.Utils (ordNub) + +import Distribution.Client.Types.ConfiguredId +import Distribution.Solver.Types.OptionalStanza (OptionalStanzaSet) +import Distribution.Solver.Types.PackageFixedDeps +import Distribution.Solver.Types.SourcePackage (SourcePackage) + +import qualified Distribution.Solver.Types.ComponentDeps as CD + +-- | A 'ConfiguredPackage' is a not-yet-installed package along with the +-- total configuration information. The configuration information is total in +-- the sense that it provides all the configuration information and so the +-- final configure process will be independent of the environment. +-- +-- 'ConfiguredPackage' is assumed to not support Backpack. Only the +-- @v2-build@ codepath supports Backpack. +-- +data ConfiguredPackage loc = ConfiguredPackage + { confPkgId :: InstalledPackageId + , confPkgSource :: SourcePackage loc -- ^ package info, including repo + , confPkgFlags :: FlagAssignment -- ^ complete flag assignment for the package + , confPkgStanzas :: OptionalStanzaSet -- ^ list of enabled optional stanzas for the package + , confPkgDeps :: CD.ComponentDeps [ConfiguredId] + -- ^ set of exact dependencies (installed or source). + -- + -- These must be consistent with the 'buildDepends' + -- in the 'PackageDescription' that you'd get by + -- applying the flag assignment and optional stanzas. + } + deriving (Eq, Show, Generic) + +-- | 'HasConfiguredId' indicates data types which have a 'ConfiguredId'. +-- This type class is mostly used to conveniently finesse between +-- 'ElaboratedPackage' and 'ElaboratedComponent'. +-- +instance HasConfiguredId (ConfiguredPackage loc) where + configuredId pkg = ConfiguredId (packageId pkg) (Just (CLibName LMainLibName)) (confPkgId pkg) + +-- 'ConfiguredPackage' is the legacy codepath, we are guaranteed +-- to never have a nontrivial 'UnitId' +instance PackageFixedDeps (ConfiguredPackage loc) where + depends = fmap (map (newSimpleUnitId . confInstId)) . confPkgDeps + +instance IsNode (ConfiguredPackage loc) where + type Key (ConfiguredPackage loc) = UnitId + nodeKey = newSimpleUnitId . confPkgId + -- 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 + +instance (Binary loc) => Binary (ConfiguredPackage loc) + + + + +instance Package (ConfiguredPackage loc) where + packageId cpkg = packageId (confPkgSource cpkg) + +instance HasMungedPackageId (ConfiguredPackage loc) where + mungedId cpkg = computeCompatPackageId (packageId cpkg) LMainLibName + +-- Never has nontrivial UnitId +instance HasUnitId (ConfiguredPackage loc) where + installedUnitId = newSimpleUnitId . confPkgId + +instance PackageInstalled (ConfiguredPackage loc) where + installedDepends = CD.flatDeps . depends + + + diff --git a/cabal/cabal-install/src/Distribution/Client/Types/Credentials.hs b/cabal/cabal-install/src/Distribution/Client/Types/Credentials.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Types/Credentials.hs @@ -0,0 +1,9 @@ +module Distribution.Client.Types.Credentials ( + Username (..), + Password (..), +) where + +import Prelude (String) + +newtype Username = Username { unUsername :: String } +newtype Password = Password { unPassword :: String } diff --git a/cabal/cabal-install/src/Distribution/Client/Types/InstallMethod.hs b/cabal/cabal-install/src/Distribution/Client/Types/InstallMethod.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Types/InstallMethod.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Client.Types.InstallMethod where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as PP + +data InstallMethod + = InstallMethodCopy + | InstallMethodSymlink + deriving (Eq, Show, Generic, Bounded, Enum) + +instance Binary InstallMethod +instance Structured InstallMethod + +-- | Last +instance Semigroup InstallMethod where + _ <> x = x + +instance Parsec InstallMethod where + parsec = do + name <- P.munch1 isAlpha + case name of + "copy" -> pure InstallMethodCopy + "symlink" -> pure InstallMethodSymlink + _ -> P.unexpected $ "InstallMethod: " ++ name + +instance Pretty InstallMethod where + pretty InstallMethodCopy = PP.text "copy" + pretty InstallMethodSymlink = PP.text "symlink" diff --git a/cabal/cabal-install/src/Distribution/Client/Types/OverwritePolicy.hs b/cabal/cabal-install/src/Distribution/Client/Types/OverwritePolicy.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Types/OverwritePolicy.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Client.Types.OverwritePolicy where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as PP + +data OverwritePolicy + = NeverOverwrite + | AlwaysOverwrite + | PromptOverwrite + deriving (Show, Eq, Generic, Bounded, Enum) + +instance Binary OverwritePolicy +instance Structured OverwritePolicy + +instance Parsec OverwritePolicy where + parsec = do + name <- P.munch1 isAlpha + case name of + "always" -> pure AlwaysOverwrite + "never" -> pure NeverOverwrite + "prompt" -> pure PromptOverwrite + _ -> P.unexpected $ "OverwritePolicy: " ++ name + +instance Pretty OverwritePolicy where + pretty NeverOverwrite = PP.text "never" + pretty AlwaysOverwrite = PP.text "always" + pretty PromptOverwrite = PP.text "prompt" diff --git a/cabal/cabal-install/src/Distribution/Client/Types/PackageLocation.hs b/cabal/cabal-install/src/Distribution/Client/Types/PackageLocation.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Types/PackageLocation.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Client.Types.PackageLocation ( + PackageLocation (..), + UnresolvedPkgLoc, + ResolvedPkgLoc, + UnresolvedSourcePackage, +) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Network.URI (URI) + +import Distribution.Types.PackageId (PackageId) + +import Distribution.Client.Types.Repo +import Distribution.Client.Types.SourceRepo (SourceRepoMaybe) +import Distribution.Solver.Types.SourcePackage (SourcePackage) + +type UnresolvedPkgLoc = PackageLocation (Maybe FilePath) + +type ResolvedPkgLoc = PackageLocation FilePath + +data PackageLocation local = + + -- | An unpacked package in the given dir, or current dir + LocalUnpackedPackage FilePath + + -- | A package as a tarball that's available as a local tarball + | LocalTarballPackage FilePath + + -- | A package as a tarball from a remote URI + | RemoteTarballPackage URI local + + -- | A package available as a tarball from a repository. + -- + -- It may be from a local repository or from a remote repository, with a + -- locally cached copy. ie a package available from hackage + | RepoTarballPackage Repo PackageId local + + -- | A package available from a version control system source repository + | RemoteSourceRepoPackage SourceRepoMaybe local + deriving (Show, Functor, Eq, Ord, Generic, Typeable) + +instance Binary local => Binary (PackageLocation local) +instance Structured local => Structured (PackageLocation local) + +-- | Convenience alias for 'SourcePackage UnresolvedPkgLoc'. +type UnresolvedSourcePackage = SourcePackage UnresolvedPkgLoc diff --git a/cabal/cabal-install/src/Distribution/Client/Types/PackageSpecifier.hs b/cabal/cabal-install/src/Distribution/Client/Types/PackageSpecifier.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Types/PackageSpecifier.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Client.Types.PackageSpecifier ( + PackageSpecifier (..), + pkgSpecifierTarget, + pkgSpecifierConstraints, +) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Package (Package (..), packageName, packageVersion) +import Distribution.Types.PackageName (PackageName) +import Distribution.Version (thisVersion) + +import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.LabeledPackageConstraint +import Distribution.Solver.Types.PackageConstraint + +-- | A fully or partially resolved reference to a package. +-- +data PackageSpecifier pkg = + + -- | A partially specified reference to a package (either source or + -- installed). It is specified by package name and optionally some + -- required properties. Use a dependency resolver to pick a specific + -- package satisfying these properties. + -- + NamedPackage PackageName [PackageProperty] + + -- | A fully specified source package. + -- + | SpecificSourcePackage pkg + deriving (Eq, Show, Functor, Generic) + +instance Binary pkg => Binary (PackageSpecifier pkg) +instance Structured pkg => Structured (PackageSpecifier pkg) + +pkgSpecifierTarget :: Package pkg => PackageSpecifier pkg -> PackageName +pkgSpecifierTarget (NamedPackage name _) = name +pkgSpecifierTarget (SpecificSourcePackage pkg) = packageName pkg + +pkgSpecifierConstraints :: Package pkg + => PackageSpecifier pkg -> [LabeledPackageConstraint] +pkgSpecifierConstraints (NamedPackage name props) = map toLpc props + where + toLpc prop = LabeledPackageConstraint + (PackageConstraint (scopeToplevel name) prop) + ConstraintSourceUserTarget +pkgSpecifierConstraints (SpecificSourcePackage pkg) = + [LabeledPackageConstraint pc ConstraintSourceUserTarget] + where + pc = PackageConstraint + (ScopeTarget $ packageName pkg) + (PackagePropertyVersion $ thisVersion (packageVersion pkg)) diff --git a/cabal/cabal-install/src/Distribution/Client/Types/ReadyPackage.hs b/cabal/cabal-install/src/Distribution/Client/Types/ReadyPackage.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Types/ReadyPackage.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +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.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/cabal-install/src/Distribution/Client/Types/Repo.hs b/cabal/cabal-install/src/Distribution/Client/Types/Repo.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Types/Repo.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Client.Types.Repo ( + -- * Remote repository + RemoteRepo (..), + emptyRemoteRepo, + -- * Local repository (no-index) + LocalRepo (..), + emptyLocalRepo, + localRepoCacheKey, + -- * Repository + Repo (..), + repoName, + isRepoRemote, + maybeRepoRemote, +) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Network.URI (URI (..), nullURI, parseAbsoluteURI, uriToString) + +import Distribution.Simple.Utils (toUTF8BS) + +import Distribution.Client.HashValue (hashValue, showHashValue, truncateHash) + +import qualified Data.ByteString.Lazy.Char8 as LBS +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as Disp + +import Distribution.Client.Types.RepoName + +------------------------------------------------------------------------------- +-- Remote repository +------------------------------------------------------------------------------- + +data RemoteRepo = + RemoteRepo { + remoteRepoName :: RepoName, + remoteRepoURI :: URI, + + -- | Enable secure access? + -- + -- 'Nothing' here represents "whatever the default is"; this is important + -- to allow for a smooth transition from opt-in to opt-out security + -- (once we switch to opt-out, all access to the central Hackage + -- repository should be secure by default) + remoteRepoSecure :: Maybe Bool, + + -- | Root key IDs (for bootstrapping) + remoteRepoRootKeys :: [String], + + -- | Threshold for verification during bootstrapping + remoteRepoKeyThreshold :: Int, + + -- | Normally a repo just specifies an HTTP or HTTPS URI, but as a + -- special case we may know a repo supports both and want to try HTTPS + -- if we can, but still allow falling back to HTTP. + -- + -- This field is not currently stored in the config file, but is filled + -- in automagically for known repos. + remoteRepoShouldTryHttps :: Bool + } + + deriving (Show, Eq, Ord, Generic) + +instance Binary RemoteRepo +instance Structured RemoteRepo + +instance Pretty RemoteRepo where + pretty r = + pretty (remoteRepoName r) <<>> Disp.colon <<>> + Disp.text (uriToString id (remoteRepoURI r) []) + +-- | Note: serialised format represents 'RemoteRepo' only partially. +instance Parsec RemoteRepo where + parsec = do + name <- parsec + _ <- P.char ':' + uriStr <- P.munch1 (\c -> isAlphaNum c || c `elem` ("+-=._/*()@'$:;&!?~" :: String)) + uri <- maybe (fail $ "Cannot parse URI:" ++ uriStr) return (parseAbsoluteURI uriStr) + return RemoteRepo + { remoteRepoName = name + , remoteRepoURI = uri + , remoteRepoSecure = Nothing + , remoteRepoRootKeys = [] + , remoteRepoKeyThreshold = 0 + , remoteRepoShouldTryHttps = False + } + +-- | Construct a partial 'RemoteRepo' value to fold the field parser list over. +emptyRemoteRepo :: RepoName -> RemoteRepo +emptyRemoteRepo name = RemoteRepo name nullURI Nothing [] 0 False + +------------------------------------------------------------------------------- +-- Local repository +------------------------------------------------------------------------------- + +-- | /no-index/ style local repositories. +-- +-- https://github.com/haskell/cabal/issues/6359 +data LocalRepo = LocalRepo + { localRepoName :: RepoName + , localRepoPath :: FilePath + , localRepoSharedCache :: Bool + } + deriving (Show, Eq, Ord, Generic) + +instance Binary LocalRepo +instance Structured LocalRepo + +-- | Note: doesn't parse 'localRepoSharedCache' field. +instance Parsec LocalRepo where + parsec = do + n <- parsec + _ <- P.char ':' + p <- P.munch1 (const True) -- restrict what can be a path? + return (LocalRepo n p False) + +instance Pretty LocalRepo where + pretty (LocalRepo n p _) = pretty n <<>> Disp.colon <<>> Disp.text p + +-- | Construct a partial 'LocalRepo' value to fold the field parser list over. +emptyLocalRepo :: RepoName -> LocalRepo +emptyLocalRepo name = LocalRepo name "" False + +-- | Calculate a cache key for local-repo. +-- +-- For remote repositories we just use name, but local repositories may +-- all be named "local", so we add a bit of `localRepoPath` into the +-- mix. +localRepoCacheKey :: LocalRepo -> String +localRepoCacheKey local = unRepoName (localRepoName local) ++ "-" ++ hashPart where + hashPart + = showHashValue $ truncateHash 8 $ hashValue + $ LBS.fromStrict $ toUTF8BS $ localRepoPath local + +------------------------------------------------------------------------------- +-- Any repository +------------------------------------------------------------------------------- + +-- | Different kinds of repositories +-- +-- NOTE: It is important that this type remains serializable. +data Repo + -- | Local repository, without index. + -- + -- https://github.com/haskell/cabal/issues/6359 + = RepoLocalNoIndex + { repoLocal :: LocalRepo + , repoLocalDir :: FilePath + } + + -- | Standard (unsecured) remote repositories + | RepoRemote { + repoRemote :: RemoteRepo + , repoLocalDir :: FilePath + } + + -- | Secure repositories + -- + -- Although this contains the same fields as 'RepoRemote', we use a separate + -- constructor to avoid confusing the two. + -- + -- Not all access to a secure repo goes through the hackage-security + -- library currently; code paths that do not still make use of the + -- 'repoRemote' and 'repoLocalDir' fields directly. + | RepoSecure { + repoRemote :: RemoteRepo + , repoLocalDir :: FilePath + } + deriving (Show, Eq, Ord, Generic) + +instance Binary Repo +instance Structured Repo + +-- | Check if this is a remote repo +isRepoRemote :: Repo -> Bool +isRepoRemote RepoLocalNoIndex{} = False +isRepoRemote _ = True + +-- | Extract @RemoteRepo@ from @Repo@ if remote. +maybeRepoRemote :: Repo -> Maybe RemoteRepo +maybeRepoRemote (RepoLocalNoIndex _ _localDir) = Nothing +maybeRepoRemote (RepoRemote r _localDir) = Just r +maybeRepoRemote (RepoSecure r _localDir) = Just r + +repoName :: Repo -> RepoName +repoName (RepoLocalNoIndex r _) = localRepoName r +repoName (RepoRemote r _) = remoteRepoName r +repoName (RepoSecure r _) = remoteRepoName r diff --git a/cabal/cabal-install/src/Distribution/Client/Types/RepoName.hs b/cabal/cabal-install/src/Distribution/Client/Types/RepoName.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Types/RepoName.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Client.Types.RepoName ( + RepoName (..), +) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as Disp + +-- $setup +-- >>> import Distribution.Parsec + +-- | Repository name. +-- +-- May be used as path segment. +-- +newtype RepoName = RepoName { unRepoName :: String } + deriving (Show, Eq, Ord, Generic) + +instance Binary RepoName +instance Structured RepoName +instance NFData RepoName + +instance Pretty RepoName where + pretty = Disp.text . unRepoName + +-- | +-- +-- >>> simpleParsec "hackage.haskell.org" :: Maybe RepoName +-- Just (RepoName "hackage.haskell.org") +-- +-- >>> simpleParsec "0123" :: Maybe RepoName +-- Nothing +-- +instance Parsec RepoName where + parsec = RepoName <$> parser where + parser = (:) <$> lead <*> rest + lead = P.satisfy (\c -> isAlpha c || c == '_' || c == '-' || c == '.') + rest = P.munch (\c -> isAlphaNum c || c == '_' || c == '-' || c == '.') diff --git a/cabal/cabal-install/src/Distribution/Client/Types/SourcePackageDb.hs b/cabal/cabal-install/src/Distribution/Client/Types/SourcePackageDb.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Types/SourcePackageDb.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Client.Types.SourcePackageDb ( + SourcePackageDb (..), + lookupDependency, + lookupPackageName, +) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Types.PackageName (PackageName) +import Distribution.Types.VersionRange (VersionRange, withinRange) +import Distribution.Package (packageVersion) + +import Distribution.Client.Types.PackageLocation (UnresolvedSourcePackage) +import qualified Distribution.Solver.Types.PackageIndex as PackageIndex +import Distribution.Solver.Types.PackageIndex (PackageIndex) + +import qualified Data.Map as Map + +-- | This is the information we get from a @00-index.tar.gz@ hackage index. +-- +data SourcePackageDb = SourcePackageDb + { packageIndex :: PackageIndex UnresolvedSourcePackage + , packagePreferences :: Map PackageName VersionRange + } + deriving (Eq, Generic) + +instance Binary SourcePackageDb + +-- | Does a case-sensitive search by package name and a range of versions. +-- +-- We get back any number of versions of the specified package name, all +-- satisfying the version range constraint. +-- +-- Additionally, `preferred-versions` (such as version deprecation) are +-- honoured in this lookup, which is the only difference to +-- 'PackageIndex.lookupDependency' +lookupDependency :: SourcePackageDb -> PackageName -> VersionRange -> [UnresolvedSourcePackage] +lookupDependency sourceDb pname version = + filterPreferredVersions pref $ PackageIndex.lookupDependency (packageIndex sourceDb) pname version + where + pref = Map.lookup pname (packagePreferences sourceDb) + + +-- | Does a case-sensitive search by package name. +-- +-- Additionally, `preferred-versions` (such as version deprecation) are +-- honoured in this lookup, which is the only difference to +-- 'PackageIndex.lookupPackageName' +lookupPackageName :: SourcePackageDb -> PackageName -> [UnresolvedSourcePackage] +lookupPackageName sourceDb pname = + filterPreferredVersions pref $ PackageIndex.lookupPackageName (packageIndex sourceDb) pname + where + pref = Map.lookup pname (packagePreferences sourceDb) + +-- | @filterPreferredVersions 'range' 'versions'@. +-- If a 'range' is given, only keep versions that satisfy the range. +-- If 'range' is 'Nothing', all versions are kept. +-- +-- The 'range' is expected to be obtained from the 'SourcePackageDb.packagePreferences'. +filterPreferredVersions :: Maybe VersionRange -> [UnresolvedSourcePackage] -> [UnresolvedSourcePackage] +filterPreferredVersions Nothing versions = versions +filterPreferredVersions (Just range) versions = filter ((`withinRange` range) . packageVersion) versions diff --git a/cabal/cabal-install/src/Distribution/Client/Types/SourceRepo.hs b/cabal/cabal-install/src/Distribution/Client/Types/SourceRepo.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Types/SourceRepo.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} +module Distribution.Client.Types.SourceRepo ( + SourceRepositoryPackage (..), + SourceRepoList, + SourceRepoMaybe, + SourceRepoProxy, + srpHoist, + srpToProxy, + srpFanOut, + sourceRepositoryPackageGrammar, +) where + +import Distribution.Client.Compat.Prelude +import Distribution.Compat.Lens (Lens, Lens') +import Prelude () + +import Distribution.FieldGrammar +import Distribution.Types.SourceRepo (RepoType (..)) + +-- | @source-repository-package@ definition +-- +data SourceRepositoryPackage f = SourceRepositoryPackage + { srpType :: !RepoType + , srpLocation :: !String + , srpTag :: !(Maybe String) + , srpBranch :: !(Maybe String) + , srpSubdir :: !(f FilePath) + , srpCommand :: ![String] + } + deriving (Generic) + +deriving instance (Eq (f FilePath)) => Eq (SourceRepositoryPackage f) +deriving instance (Ord (f FilePath)) => Ord (SourceRepositoryPackage f) +deriving instance (Show (f FilePath)) => Show (SourceRepositoryPackage f) +deriving instance (Binary (f FilePath)) => Binary (SourceRepositoryPackage f) +deriving instance (Typeable f, Structured (f FilePath)) => Structured (SourceRepositoryPackage f) + +-- | Read from @cabal.project@ +type SourceRepoList = SourceRepositoryPackage [] + +-- | Distilled from 'Distribution.Types.SourceRepo.SourceRepo' +type SourceRepoMaybe = SourceRepositoryPackage Maybe + +-- | 'SourceRepositoryPackage' without subdir. Used in clone errors. Cloning doesn't care about subdirectory. +type SourceRepoProxy = SourceRepositoryPackage Proxy + +srpHoist :: (forall x. f x -> g x) -> SourceRepositoryPackage f -> SourceRepositoryPackage g +srpHoist nt s = s { srpSubdir = nt (srpSubdir s) } + +srpToProxy :: SourceRepositoryPackage f -> SourceRepositoryPackage Proxy +srpToProxy s = s { srpSubdir = Proxy } + +-- | Split single @source-repository-package@ declaration with multiple subdirs, +-- into multiple ones with at most single subdir. +srpFanOut :: SourceRepositoryPackage [] -> NonEmpty (SourceRepositoryPackage Maybe) +srpFanOut s@SourceRepositoryPackage { srpSubdir = [] } = + s { srpSubdir = Nothing } :| [] +srpFanOut s@SourceRepositoryPackage { srpSubdir = d:ds } = f d :| map f ds where + f subdir = s { srpSubdir = Just subdir } + +------------------------------------------------------------------------------- +-- Lens +------------------------------------------------------------------------------- + +srpTypeLens :: Lens' (SourceRepositoryPackage f) RepoType +srpTypeLens f s = fmap (\x -> s { srpType = x }) (f (srpType s)) +{-# INLINE srpTypeLens #-} + +srpLocationLens :: Lens' (SourceRepositoryPackage f) String +srpLocationLens f s = fmap (\x -> s { srpLocation = x }) (f (srpLocation s)) +{-# INLINE srpLocationLens #-} + +srpTagLens :: Lens' (SourceRepositoryPackage f) (Maybe String) +srpTagLens f s = fmap (\x -> s { srpTag = x }) (f (srpTag s)) +{-# INLINE srpTagLens #-} + +srpBranchLens :: Lens' (SourceRepositoryPackage f) (Maybe String) +srpBranchLens f s = fmap (\x -> s { srpBranch = x }) (f (srpBranch s)) +{-# INLINE srpBranchLens #-} + +srpSubdirLens :: Lens (SourceRepositoryPackage f) (SourceRepositoryPackage g) (f FilePath) (g FilePath) +srpSubdirLens f s = fmap (\x -> s { srpSubdir = x }) (f (srpSubdir s)) +{-# INLINE srpSubdirLens #-} + +srpCommandLensNE :: Lens' (SourceRepositoryPackage f) (Maybe (NonEmpty String)) +srpCommandLensNE f s = fmap (\x -> s { srpCommand = maybe [] toList x }) (f (nonEmpty (srpCommand s))) +{-# INLINE srpCommandLensNE #-} + +------------------------------------------------------------------------------- +-- Parser & PPrinter +------------------------------------------------------------------------------- + +sourceRepositoryPackageGrammar + :: ( FieldGrammar c g, Applicative (g SourceRepoList) + , c (Identity RepoType) + , c (List NoCommaFSep FilePathNT String) + , c (NonEmpty' NoCommaFSep Token String) + ) + => g SourceRepoList SourceRepoList +sourceRepositoryPackageGrammar = SourceRepositoryPackage + <$> uniqueField "type" srpTypeLens + <*> uniqueFieldAla "location" Token srpLocationLens + <*> optionalFieldAla "tag" Token srpTagLens + <*> optionalFieldAla "branch" Token srpBranchLens + <*> monoidalFieldAla "subdir" (alaList' NoCommaFSep FilePathNT) srpSubdirLens -- note: NoCommaFSep is somewhat important for roundtrip, as "." is there... + <*> fmap (maybe [] toList) pcc + where + pcc = optionalFieldAla "post-checkout-command" (alaNonEmpty' NoCommaFSep Token) srpCommandLensNE +{-# SPECIALIZE sourceRepositoryPackageGrammar :: ParsecFieldGrammar' SourceRepoList #-} +{-# SPECIALIZE sourceRepositoryPackageGrammar :: PrettyFieldGrammar' SourceRepoList #-} diff --git a/cabal/cabal-install/src/Distribution/Client/Types/WriteGhcEnvironmentFilesPolicy.hs b/cabal/cabal-install/src/Distribution/Client/Types/WriteGhcEnvironmentFilesPolicy.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Types/WriteGhcEnvironmentFilesPolicy.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy ( + WriteGhcEnvironmentFilesPolicy (..), +) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +-- | Whether 'v2-build' should write a .ghc.environment file after +-- success. Possible values: 'always', 'never' (the default), 'ghc8.4.4+' +-- (8.4.4 is the earliest version that supports +-- '-package-env -'). +data WriteGhcEnvironmentFilesPolicy + = AlwaysWriteGhcEnvironmentFiles + | NeverWriteGhcEnvironmentFiles + | WriteGhcEnvironmentFilesOnlyForGhc844AndNewer + deriving (Eq, Enum, Bounded, Generic, Show) + +instance Binary WriteGhcEnvironmentFilesPolicy +instance Structured WriteGhcEnvironmentFilesPolicy diff --git a/cabal/cabal-install/src/Distribution/Client/Upload.hs b/cabal/cabal-install/src/Distribution/Client/Upload.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Upload.hs @@ -0,0 +1,231 @@ +module Distribution.Client.Upload (upload, uploadDoc, report) where + +import Distribution.Client.Compat.Prelude +import qualified Prelude as Unsafe (tail, head, read) + +import Distribution.Client.Types.Credentials ( Username(..), Password(..) ) +import Distribution.Client.Types.Repo (Repo, RemoteRepo(..), maybeRepoRemote) +import Distribution.Client.Types.RepoName (unRepoName) +import Distribution.Client.HttpUtils + ( HttpTransport(..), remoteRepoTryUpgradeToHttps ) +import Distribution.Client.Setup + ( IsCandidate(..), RepoContext(..) ) + +import Distribution.Simple.Utils (notice, warn, info, die', toUTF8BS) +import Distribution.Utils.String (trim) +import Distribution.Client.Config + +import qualified Distribution.Client.BuildReports.Anonymous as BuildReport +import Distribution.Client.BuildReports.Anonymous (parseBuildReport) +import qualified Distribution.Client.BuildReports.Upload as BuildReport + +import Network.URI (URI(uriPath, uriAuthority), URIAuth(uriRegName)) +import Network.HTTP (Header(..), HeaderName(..)) + +import System.IO (hFlush, stdout) +import System.IO.Echo (withoutInputEcho) +import System.FilePath ((), takeExtension, takeFileName, dropExtension) +import qualified System.FilePath.Posix as FilePath.Posix (()) +import System.Directory + +type Auth = Maybe (String, String) + +-- > stripExtensions ["tar", "gz"] "foo.tar.gz" +-- Just "foo" +-- > stripExtensions ["tar", "gz"] "foo.gz.tar" +-- Nothing +stripExtensions :: [String] -> FilePath -> Maybe String +stripExtensions exts path = foldM f path (reverse exts) + where + f p e + | takeExtension p == '.':e = Just (dropExtension p) + | otherwise = Nothing + +upload :: Verbosity -> RepoContext + -> Maybe Username -> Maybe Password -> IsCandidate -> [FilePath] + -> IO () +upload verbosity repoCtxt mUsername mPassword isCandidate paths = do + let repos :: [Repo] + repos = repoContextRepos repoCtxt + transport <- repoContextGetTransport repoCtxt + targetRepo <- + case [ remoteRepo | Just remoteRepo <- map maybeRepoRemote repos ] of + [] -> die' verbosity "Cannot upload. No remote repositories are configured." + (r:rs) -> remoteRepoTryUpgradeToHttps verbosity transport (last (r:|rs)) + let targetRepoURI :: URI + targetRepoURI = remoteRepoURI targetRepo + domain :: String + domain = maybe "Hackage" uriRegName $ uriAuthority targetRepoURI + rootIfEmpty x = if null x then "/" else x + uploadURI :: URI + uploadURI = targetRepoURI { + uriPath = rootIfEmpty (uriPath targetRepoURI) FilePath.Posix. + case isCandidate of + IsCandidate -> "packages/candidates" + IsPublished -> "upload" + } + packageURI pkgid = targetRepoURI { + uriPath = rootIfEmpty (uriPath targetRepoURI) + FilePath.Posix. concat + [ "package/", pkgid + , case isCandidate of + IsCandidate -> "/candidate" + IsPublished -> "" + ] + } + Username username <- maybe (promptUsername domain) return mUsername + Password password <- maybe (promptPassword domain) return mPassword + let auth = Just (username,password) + for_ paths $ \path -> do + notice verbosity $ "Uploading " ++ path ++ "... " + case fmap takeFileName (stripExtensions ["tar", "gz"] path) of + Just pkgid -> handlePackage transport verbosity uploadURI + (packageURI pkgid) auth isCandidate path + -- This case shouldn't really happen, since we check in Main that we + -- only pass tar.gz files to upload. + Nothing -> die' verbosity $ "Not a tar.gz file: " ++ path + +uploadDoc :: Verbosity -> RepoContext + -> Maybe Username -> Maybe Password -> IsCandidate -> FilePath + -> IO () +uploadDoc verbosity repoCtxt mUsername mPassword isCandidate path = do + let repos = repoContextRepos repoCtxt + transport <- repoContextGetTransport repoCtxt + targetRepo <- + case [ remoteRepo | Just remoteRepo <- map maybeRepoRemote repos ] of + [] -> die' verbosity $ "Cannot upload. No remote repositories are configured." + (r:rs) -> remoteRepoTryUpgradeToHttps verbosity transport (last (r:|rs)) + let targetRepoURI = remoteRepoURI targetRepo + domain = maybe "Hackage" uriRegName $ uriAuthority targetRepoURI + rootIfEmpty x = if null x then "/" else x + uploadURI = targetRepoURI { + uriPath = rootIfEmpty (uriPath targetRepoURI) + FilePath.Posix. concat + [ "package/", pkgid + , case isCandidate of + IsCandidate -> "/candidate" + IsPublished -> "" + , "/docs" + ] + } + packageUri = targetRepoURI { + uriPath = rootIfEmpty (uriPath targetRepoURI) + FilePath.Posix. concat + [ "package/", pkgid + , case isCandidate of + IsCandidate -> "/candidate" + IsPublished -> "" + ] + } + (reverseSuffix, reversePkgid) = break (== '-') + (reverse (takeFileName path)) + pkgid = reverse $ Unsafe.tail reversePkgid + when (reverse reverseSuffix /= "docs.tar.gz" + || null reversePkgid || Unsafe.head reversePkgid /= '-') $ + die' verbosity "Expected a file name matching the pattern -docs.tar.gz" + Username username <- maybe (promptUsername domain) return mUsername + Password password <- maybe (promptPassword domain) return mPassword + + let auth = Just (username,password) + headers = + [ Header HdrContentType "application/x-tar" + , Header HdrContentEncoding "gzip" + ] + notice verbosity $ "Uploading documentation " ++ path ++ "... " + resp <- putHttpFile transport verbosity uploadURI path auth headers + case resp of + -- Hackage responds with 204 No Content when docs are uploaded + -- successfully. + (code,_) | code `elem` [200,204] -> do + notice verbosity $ okMessage packageUri + (code,err) -> do + notice verbosity $ "Error uploading documentation " + ++ path ++ ": " + ++ "http code " ++ show code ++ "\n" + ++ err + exitFailure + where + okMessage packageUri = case isCandidate of + IsCandidate -> + "Documentation successfully uploaded for package candidate. " + ++ "You can now preview the result at '" ++ show packageUri + ++ "'. To upload non-candidate documentation, use 'cabal upload --publish'." + IsPublished -> + "Package documentation successfully published. You can now view it at '" + ++ show packageUri ++ "'." + + +promptUsername :: String -> IO Username +promptUsername domain = do + putStr $ domain ++ " username: " + hFlush stdout + fmap Username getLine + +promptPassword :: String -> IO Password +promptPassword domain = do + putStr $ domain ++ " password: " + hFlush stdout + -- save/restore the terminal echoing status (no echoing for entering the password) + passwd <- withoutInputEcho $ fmap Password getLine + putStrLn "" + return passwd + +report :: Verbosity -> RepoContext -> Maybe Username -> Maybe Password -> IO () +report verbosity repoCtxt mUsername mPassword = do + let repos :: [Repo] + repos = repoContextRepos repoCtxt + remoteRepos :: [RemoteRepo] + remoteRepos = mapMaybe maybeRepoRemote repos + for_ remoteRepos $ \remoteRepo -> do + let domain = maybe "Hackage" uriRegName $ uriAuthority (remoteRepoURI remoteRepo) + Username username <- maybe (promptUsername domain) return mUsername + Password password <- maybe (promptPassword domain) return mPassword + let auth :: (String, String) + auth = (username, password) + + dotCabal <- getCabalDir + let srcDir :: FilePath + srcDir = dotCabal "reports" unRepoName (remoteRepoName remoteRepo) + -- We don't want to bomb out just because we haven't built any packages + -- from this repo yet. + srcExists <- doesDirectoryExist srcDir + when srcExists $ do + contents <- getDirectoryContents srcDir + for_ (filter (\c -> takeExtension c ==".log") contents) $ \logFile -> + do inp <- readFile (srcDir logFile) + let (reportStr, buildLog) = Unsafe.read inp :: (String,String) -- TODO: eradicateNoParse + case parseBuildReport (toUTF8BS reportStr) of + Left errs -> warn verbosity $ "Errors: " ++ errs -- FIXME + Right report' -> + do info verbosity $ "Uploading report for " + ++ prettyShow (BuildReport.package report') + BuildReport.uploadReports verbosity repoCtxt auth + (remoteRepoURI remoteRepo) [(report', Just buildLog)] + return () + +handlePackage :: HttpTransport -> Verbosity -> URI -> URI -> Auth + -> IsCandidate -> FilePath -> IO () +handlePackage transport verbosity uri packageUri auth isCandidate path = + do resp <- postHttpFile transport verbosity uri path auth + case resp of + (code,warnings) | code `elem` [200, 204] -> + notice verbosity $ okMessage isCandidate ++ + if null warnings then "" else "\n" ++ formatWarnings (trim warnings) + (code,err) -> do + notice verbosity $ "Error uploading " ++ path ++ ": " + ++ "http code " ++ show code ++ "\n" + ++ err + exitFailure + where + okMessage :: IsCandidate -> String + okMessage IsCandidate = + "Package successfully uploaded as candidate. " + ++ "You can now preview the result at '" ++ show packageUri + ++ "'. To publish the candidate, use 'cabal upload --publish'." + okMessage IsPublished = + "Package successfully published. You can now view it at '" + ++ show packageUri ++ "'." + +formatWarnings :: String -> String +formatWarnings x = "Warnings:\n" ++ (unlines . map ("- " ++) . lines) x + diff --git a/cabal/cabal-install/src/Distribution/Client/Utils.hs b/cabal/cabal-install/src/Distribution/Client/Utils.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Utils.hs @@ -0,0 +1,482 @@ +{-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables, CPP #-} + +module Distribution.Client.Utils + ( MergeResult(..) + , mergeBy, duplicates, duplicatesBy + , readMaybe + , inDir, withEnv, withEnvOverrides + , logDirChange, withExtraPathEnv + , determineNumJobs, numberOfProcessors + , removeExistingFile + , withTempFileName + , makeAbsoluteToCwd + , makeRelativeToCwd, makeRelativeToDir + , makeRelativeCanonical + , filePathToByteString + , byteStringToFilePath, tryCanonicalizePath + , canonicalizePathNoThrow + , moreRecentFile, existsAndIsMoreRecentThan + , tryFindAddSourcePackageDesc + , tryFindPackageDesc + , findOpenProgramLocation + , relaxEncodingErrors + , ProgressPhase (..) + , progressMessage + , pvpize + , incVersion + , getCurrentYear + , listFilesRecursive + , listFilesInside + , safeRead + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Distribution.Compat.Environment +import Distribution.Compat.Time ( getModTime ) +import Distribution.Simple.Setup ( Flag(..) ) +import Distribution.Version +import Distribution.Simple.Utils ( die', findPackageDesc, noticeNoWrap ) +import Distribution.System ( Platform (..), OS(..)) +import qualified Data.ByteString.Lazy as BS +import Data.Bits + ( (.|.), shiftL, shiftR ) +import System.FilePath +import Control.Monad + ( zipWithM_ ) +import Data.List + ( groupBy ) +import Foreign.C.Types ( CInt(..) ) +import qualified Control.Exception as Exception + ( finally ) +import qualified Control.Exception.Safe as Safe + ( bracket ) +import System.Directory + ( canonicalizePath, doesFileExist, findExecutable, getCurrentDirectory + , removeFile, setCurrentDirectory, getDirectoryContents, doesDirectoryExist ) +import System.IO + ( Handle, hClose, openTempFile + , hGetEncoding, hSetEncoding + ) +import System.IO.Unsafe ( unsafePerformIO ) + +import GHC.IO.Encoding + ( recover, TextEncoding(TextEncoding) ) +import GHC.IO.Encoding.Failure + ( recoverEncode, CodingFailureMode(TransliterateCodingFailure) ) +import Data.Time.Clock.POSIX (getCurrentTime) +import Data.Time.LocalTime (getCurrentTimeZone, localDay) +import Data.Time (utcToLocalTime) +import Data.Time.Calendar (toGregorian) +#if defined(mingw32_HOST_OS) || MIN_VERSION_directory(1,2,3) +import qualified System.Directory as Dir +import qualified System.IO.Error as IOError +#endif + + +-- | Generic merging utility. For sorted input lists this is a full outer join. +-- +mergeBy :: forall a b. (a -> b -> Ordering) -> [a] -> [b] -> [MergeResult a b] +mergeBy cmp = merge + where + merge :: [a] -> [b] -> [MergeResult a b] + merge [] ys = [ OnlyInRight y | y <- ys] + merge xs [] = [ OnlyInLeft x | x <- xs] + merge (x:xs) (y:ys) = + case x `cmp` y of + GT -> OnlyInRight y : merge (x:xs) ys + EQ -> InBoth x y : merge xs ys + LT -> OnlyInLeft x : merge xs (y:ys) + +data MergeResult a b = OnlyInLeft a | InBoth a b | OnlyInRight b + +duplicates :: Ord a => [a] -> [[a]] +duplicates = duplicatesBy compare + +duplicatesBy :: forall a. (a -> a -> Ordering) -> [a] -> [[a]] +duplicatesBy cmp = filter moreThanOne . groupBy eq . sortBy cmp + where + eq :: a -> a -> Bool + eq a b = case cmp a b of + EQ -> True + _ -> False + 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. +-- +withTempFileName :: FilePath + -> String + -> (FilePath -> IO a) -> IO a +withTempFileName tmpDir template action = + Safe.bracket + (openTempFile tmpDir template) + (\(name, _) -> removeExistingFile name) + (\(name, h) -> hClose h >> action name) + +-- | Executes the action in the specified directory. +-- +-- Warning: This operation is NOT thread-safe, because current +-- working directory is a process-global concept. +inDir :: Maybe FilePath -> IO a -> IO a +inDir Nothing m = m +inDir (Just d) m = do + old <- getCurrentDirectory + setCurrentDirectory d + m `Exception.finally` setCurrentDirectory old + +-- | Executes the action with an environment variable set to some +-- value. +-- +-- Warning: This operation is NOT thread-safe, because current +-- environment is a process-global concept. +withEnv :: String -> String -> IO a -> IO a +withEnv k v m = do + mb_old <- lookupEnv k + setEnv k v + m `Exception.finally` (case mb_old of + Nothing -> unsetEnv k + Just old -> setEnv k old) + +-- | Executes the action with a list of environment variables and +-- corresponding overrides, where +-- +-- * @'Just' v@ means \"set the environment variable's value to @v@\". +-- * 'Nothing' means \"unset the environment variable\". +-- +-- Warning: This operation is NOT thread-safe, because current +-- environment is a process-global concept. +withEnvOverrides :: [(String, Maybe FilePath)] -> IO a -> IO a +withEnvOverrides overrides m = do + mb_olds <- traverse lookupEnv envVars + traverse_ (uncurry update) overrides + m `Exception.finally` zipWithM_ update envVars mb_olds + where + envVars :: [String] + envVars = map fst overrides + + update :: String -> Maybe FilePath -> IO () + update var Nothing = unsetEnv var + update var (Just val) = setEnv var val + +-- | Executes the action, increasing the PATH environment +-- in some way +-- +-- Warning: This operation is NOT thread-safe, because the +-- environment variables are a process-global concept. +withExtraPathEnv :: [FilePath] -> IO a -> IO a +withExtraPathEnv paths m = do + oldPathSplit <- getSearchPath + let newPath :: String + newPath = mungePath $ intercalate [searchPathSeparator] (paths ++ oldPathSplit) + oldPath :: String + oldPath = mungePath $ intercalate [searchPathSeparator] oldPathSplit + -- TODO: This is a horrible hack to work around the fact that + -- setEnv can't take empty values as an argument + mungePath p | p == "" = "/dev/null" + | otherwise = p + setEnv "PATH" newPath + m `Exception.finally` setEnv "PATH" oldPath + +-- | Log directory change in 'make' compatible syntax +logDirChange :: (String -> IO ()) -> Maybe FilePath -> IO a -> IO a +logDirChange _ Nothing m = m +logDirChange l (Just d) m = do + l $ "cabal: Entering directory '" ++ d ++ "'\n" + m `Exception.finally` + (l $ "cabal: Leaving directory '" ++ d ++ "'\n") + +foreign import ccall "getNumberOfProcessors" c_getNumberOfProcessors :: IO CInt + +-- The number of processors is not going to change during the duration of the +-- program, so unsafePerformIO is safe here. +numberOfProcessors :: Int +numberOfProcessors = fromEnum $ unsafePerformIO c_getNumberOfProcessors + +-- | Determine the number of jobs to use given the value of the '-j' flag. +determineNumJobs :: Flag (Maybe Int) -> Int +determineNumJobs numJobsFlag = + case numJobsFlag of + NoFlag -> 1 + Flag Nothing -> numberOfProcessors + Flag (Just n) -> n + +-- | Given a relative path, make it absolute relative to the current +-- directory. Absolute paths are returned unmodified. +makeAbsoluteToCwd :: FilePath -> IO FilePath +makeAbsoluteToCwd path | isAbsolute path = return path + | otherwise = do cwd <- getCurrentDirectory + return $! cwd path + +-- | Given a path (relative or absolute), make it relative to the current +-- directory, including using @../..@ if necessary. +makeRelativeToCwd :: FilePath -> IO FilePath +makeRelativeToCwd path = + makeRelativeCanonical <$> canonicalizePath path <*> getCurrentDirectory + +-- | Given a path (relative or absolute), make it relative to the given +-- directory, including using @../..@ if necessary. +makeRelativeToDir :: FilePath -> FilePath -> IO FilePath +makeRelativeToDir path dir = + makeRelativeCanonical <$> canonicalizePath path <*> canonicalizePath dir + +-- | Given a canonical absolute path and canonical absolute dir, make the path +-- relative to the directory, including using @../..@ if necessary. Returns +-- the original absolute path if it is not on the same drive as the given dir. +makeRelativeCanonical :: FilePath -> FilePath -> FilePath +makeRelativeCanonical path dir + | takeDrive path /= takeDrive dir = path + | otherwise = go (splitPath path) (splitPath dir) + where + go (p:ps) (d:ds) | p' == d' = go ps ds + where (p', d') = (dropTrailingPathSeparator p, dropTrailingPathSeparator d) + go [] [] = "./" + go ps ds = joinPath (replicate (length ds) ".." ++ ps) + +-- | Convert a 'FilePath' to a lazy 'ByteString'. Each 'Char' is +-- encoded as a little-endian 'Word32'. +filePathToByteString :: FilePath -> BS.ByteString +filePathToByteString p = + BS.pack $ foldr conv [] codepts + where + codepts :: [Word32] + codepts = map (fromIntegral . ord) p + + conv :: Word32 -> [Word8] -> [Word8] + conv w32 rest = b0:b1:b2:b3:rest + where + b0 = fromIntegral $ w32 + b1 = fromIntegral $ w32 `shiftR` 8 + b2 = fromIntegral $ w32 `shiftR` 16 + b3 = fromIntegral $ w32 `shiftR` 24 + +-- | Reverse operation to 'filePathToByteString'. +byteStringToFilePath :: BS.ByteString -> FilePath +byteStringToFilePath bs | bslen `mod` 4 /= 0 = unexpected + | otherwise = go 0 + where + unexpected = "Distribution.Client.Utils.byteStringToFilePath: unexpected" + bslen = BS.length bs + + go i | i == bslen = [] + | otherwise = (chr . fromIntegral $ w32) : go (i+4) + where + w32 :: Word32 + w32 = b0 .|. (b1 `shiftL` 8) .|. (b2 `shiftL` 16) .|. (b3 `shiftL` 24) + b0 = fromIntegral $ BS.index bs i + b1 = fromIntegral $ BS.index bs (i + 1) + b2 = fromIntegral $ BS.index bs (i + 2) + b3 = fromIntegral $ BS.index bs (i + 3) + +-- | Workaround for the inconsistent behaviour of 'canonicalizePath'. Always +-- throws an error if the path refers to a non-existent file. +tryCanonicalizePath :: FilePath -> IO FilePath +tryCanonicalizePath path = do + ret <- canonicalizePath path +#if defined(mingw32_HOST_OS) || MIN_VERSION_directory(1,2,3) + exists <- liftM2 (||) (doesFileExist ret) (Dir.doesDirectoryExist ret) + unless exists $ + IOError.ioError $ IOError.mkIOError IOError.doesNotExistErrorType "canonicalizePath" + Nothing (Just ret) +#endif + return ret + +-- | A non-throwing wrapper for 'canonicalizePath'. If 'canonicalizePath' throws +-- an exception, returns the path argument unmodified. +canonicalizePathNoThrow :: FilePath -> IO FilePath +canonicalizePathNoThrow path = do + canonicalizePath path `catchIO` (\_ -> return path) + +-------------------- +-- Modification time + +-- | Like Distribution.Simple.Utils.moreRecentFile, but uses getModTime instead +-- of getModificationTime for higher precision. We can't merge the two because +-- Distribution.Client.Time uses MIN_VERSION macros. +moreRecentFile :: FilePath -> FilePath -> IO Bool +moreRecentFile a b = do + exists <- doesFileExist b + if not exists + then return True + else do tb <- getModTime b + ta <- getModTime a + return (ta > tb) + +-- | Like 'moreRecentFile', but also checks that the first file exists. +existsAndIsMoreRecentThan :: FilePath -> FilePath -> IO Bool +existsAndIsMoreRecentThan a b = do + exists <- doesFileExist a + if not exists + then return False + else a `moreRecentFile` b + +-- | Sets the handler for encoding errors to one that transliterates invalid +-- characters into one present in the encoding (i.e., \'?\'). +-- This is opposed to the default behavior, which is to throw an exception on +-- error. This function will ignore file handles that have a Unicode encoding +-- set. It's a no-op for versions of `base` less than 4.4. +relaxEncodingErrors :: Handle -> IO () +relaxEncodingErrors handle = do + maybeEncoding <- hGetEncoding handle + case maybeEncoding of + Just (TextEncoding name decoder encoder) | not ("UTF" `isPrefixOf` name) -> + let relax x = x { recover = recoverEncode TransliterateCodingFailure } + in hSetEncoding handle (TextEncoding name decoder (fmap relax encoder)) + _ -> + return () + +-- |Like 'tryFindPackageDesc', but with error specific to add-source deps. +tryFindAddSourcePackageDesc :: Verbosity -> FilePath -> String -> IO FilePath +tryFindAddSourcePackageDesc verbosity depPath err = tryFindPackageDesc verbosity depPath $ + err ++ "\n" ++ "Failed to read cabal file of add-source dependency: " + ++ depPath + +-- |Try to find a @.cabal@ file, in directory @depPath@. Fails if one cannot be +-- found, with @err@ prefixing the error message. This function simply allows +-- us to give a more descriptive error than that provided by @findPackageDesc@. +tryFindPackageDesc :: Verbosity -> FilePath -> String -> IO FilePath +tryFindPackageDesc verbosity depPath err = do + errOrCabalFile <- findPackageDesc depPath + case errOrCabalFile of + Right file -> return file + Left _ -> die' verbosity err + +findOpenProgramLocation :: Platform -> IO (Either String FilePath) +findOpenProgramLocation (Platform _ os) = + let + locate name = do + exe <- findExecutable name + case exe of + Just s -> pure (Right s) + Nothing -> pure (Left ("Couldn't find file-opener program `" <> name <> "`")) + xdg = locate "xdg-open" + in case os of + Windows -> pure (Right "start") + OSX -> locate "open" + Linux -> xdg + FreeBSD -> xdg + OpenBSD -> xdg + NetBSD -> xdg + DragonFly -> xdg + _ -> pure (Left ("Couldn't determine file-opener program for " <> show os)) + + +-- | Phase of building a dependency. Represents current status of package +-- dependency processing. See #4040 for details. +data ProgressPhase + = ProgressDownloading + | ProgressDownloaded + | ProgressStarting + | ProgressBuilding + | ProgressHaddock + | ProgressInstalling + | ProgressCompleted + +progressMessage :: Verbosity -> ProgressPhase -> String -> IO () +progressMessage verbosity phase subject = do + noticeNoWrap verbosity $ phaseStr ++ subject ++ "\n" + where + phaseStr = case phase of + ProgressDownloading -> "Downloading " + ProgressDownloaded -> "Downloaded " + ProgressStarting -> "Starting " + ProgressBuilding -> "Building " + ProgressHaddock -> "Haddock " + ProgressInstalling -> "Installing " + ProgressCompleted -> "Completed " + + +-- | Given a version, return an API-compatible (according to PVP) version range. +-- +-- If the boolean argument denotes whether to use a desugared +-- representation (if 'True') or the new-style @^>=@-form (if +-- 'False'). +-- +-- Example: @pvpize True (mkVersion [0,4,1])@ produces the version range @>= 0.4 && < 0.5@ (which is the +-- same as @0.4.*@). +pvpize :: Bool -> Version -> VersionRange +pvpize False v = majorBoundVersion v +pvpize True v = orLaterVersion v' + `intersectVersionRanges` + earlierVersion (incVersion 1 v') + where v' = alterVersion (take 2) v + +-- | Increment the nth version component (counting from 0). +incVersion :: Int -> Version -> Version +incVersion n = alterVersion (incVersion' n) + where + incVersion' 0 [] = [1] + incVersion' 0 (v:_) = [v+1] + incVersion' m [] = replicate m 0 ++ [1] + incVersion' m (v:vs) = v : incVersion' (m-1) vs + +-- | Returns the current calendar year. +getCurrentYear :: IO Integer +getCurrentYear = do + u <- getCurrentTime + z <- getCurrentTimeZone + let l = utcToLocalTime z u + (y, _, _) = toGregorian $ localDay l + return y + +-- | From System.Directory.Extra +-- https://hackage.haskell.org/package/extra-1.7.9 +listFilesInside :: (FilePath -> IO Bool) -> FilePath -> IO [FilePath] +listFilesInside test dir = ifM (notM $ test $ dropTrailingPathSeparator dir) (pure []) $ do + (dirs,files) <- partitionM doesDirectoryExist =<< listContents dir + rest <- concatMapM (listFilesInside test) dirs + pure $ files ++ rest + +-- | From System.Directory.Extra +-- https://hackage.haskell.org/package/extra-1.7.9 +listFilesRecursive :: FilePath -> IO [FilePath] +listFilesRecursive = listFilesInside (const $ pure True) + +-- | From System.Directory.Extra +-- https://hackage.haskell.org/package/extra-1.7.9 +listContents :: FilePath -> IO [FilePath] +listContents dir = do + xs <- getDirectoryContents dir + pure $ sort [dir x | x <- xs, not $ all (== '.') x] + +-- | From Control.Monad.Extra +-- https://hackage.haskell.org/package/extra-1.7.9 +ifM :: Monad m => m Bool -> m a -> m a -> m a +ifM b t f = do b' <- b; if b' then t else f + +-- | From Control.Monad.Extra +-- https://hackage.haskell.org/package/extra-1.7.9 +concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] +{-# INLINE concatMapM #-} +concatMapM op = foldr f (pure []) + where f x xs = do x' <- op x; if null x' then xs else do xs' <- xs; pure $ x' ++ xs' + +-- | From Control.Monad.Extra +-- https://hackage.haskell.org/package/extra-1.7.9 +partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a]) +partitionM _ [] = pure ([], []) +partitionM f (x:xs) = do + res <- f x + (as,bs) <- partitionM f xs + pure ([x | res]++as, [x | not res]++bs) + +-- | From Control.Monad.Extra +-- https://hackage.haskell.org/package/extra-1.7.9 +notM :: Functor m => m Bool -> m Bool +notM = fmap not + +safeRead :: Read a => String -> Maybe a +safeRead s + | [(x, "")] <- reads s = Just x + | otherwise = Nothing diff --git a/cabal/cabal-install/src/Distribution/Client/Utils/Json.hs b/cabal/cabal-install/src/Distribution/Client/Utils/Json.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Utils/Json.hs @@ -0,0 +1,222 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Minimal JSON / RFC 7159 support +-- +-- The API is heavily inspired by @aeson@'s API but puts emphasis on +-- simplicity rather than performance. The 'ToJSON' instances are +-- intended to have an encoding compatible with @aeson@'s encoding. +-- +module Distribution.Client.Utils.Json + ( Value(..) + , Object, object, Pair, (.=) + , encodeToString + , encodeToBuilder + , ToJSON(toJSON) + ) + where + +import Distribution.Client.Compat.Prelude + +import Data.Char (intToDigit) + +import Data.ByteString.Builder (Builder) +import qualified Data.ByteString.Builder as BB + +-- TODO: We may want to replace 'String' with 'Text' or 'ByteString' + +-- | A JSON value represented as a Haskell value. +data Value = Object !Object + | Array [Value] + | String String + | Number !Double + | Bool !Bool + | Null + deriving (Eq, Read, Show) + +-- | A key\/value pair for an 'Object' +type Pair = (String, Value) + +-- | A JSON \"object\" (key/value map). +type Object = [Pair] + +infixr 8 .= + +-- | A key-value pair for encoding a JSON object. +(.=) :: ToJSON v => String -> v -> Pair +k .= v = (k, toJSON v) + +-- | Create a 'Value' from a list of name\/value 'Pair's. +object :: [Pair] -> Value +object = Object + +instance IsString Value where + fromString = String + + +-- | A type that can be converted to JSON. +class ToJSON a where + -- | Convert a Haskell value to a JSON-friendly intermediate type. + toJSON :: a -> Value + +instance ToJSON () where + toJSON () = Array [] + +instance ToJSON Value where + toJSON = id + +instance ToJSON Bool where + toJSON = Bool + +instance ToJSON a => ToJSON [a] where + toJSON = Array . map toJSON + +instance ToJSON a => ToJSON (Maybe a) where + toJSON Nothing = Null + toJSON (Just a) = toJSON a + +instance (ToJSON a,ToJSON b) => ToJSON (a,b) where + toJSON (a,b) = Array [toJSON a, toJSON b] + +instance (ToJSON a,ToJSON b,ToJSON c) => ToJSON (a,b,c) where + toJSON (a,b,c) = Array [toJSON a, toJSON b, toJSON c] + +instance (ToJSON a,ToJSON b,ToJSON c, ToJSON d) => ToJSON (a,b,c,d) where + toJSON (a,b,c,d) = Array [toJSON a, toJSON b, toJSON c, toJSON d] + +instance ToJSON Float where + toJSON = Number . realToFrac + +instance ToJSON Double where + toJSON = Number + +instance ToJSON Int where toJSON = Number . realToFrac +instance ToJSON Int8 where toJSON = Number . realToFrac +instance ToJSON Int16 where toJSON = Number . realToFrac +instance ToJSON Int32 where toJSON = Number . realToFrac + +instance ToJSON Word where toJSON = Number . realToFrac +instance ToJSON Word8 where toJSON = Number . realToFrac +instance ToJSON Word16 where toJSON = Number . realToFrac +instance ToJSON Word32 where toJSON = Number . realToFrac + +-- | Possibly lossy due to conversion to 'Double' +instance ToJSON Int64 where toJSON = Number . realToFrac + +-- | Possibly lossy due to conversion to 'Double' +instance ToJSON Word64 where toJSON = Number . realToFrac + +-- | Possibly lossy due to conversion to 'Double' +instance ToJSON Integer where toJSON = Number . fromInteger + +------------------------------------------------------------------------------ +-- 'BB.Builder'-based encoding + +-- | Serialise value as JSON/UTF8-encoded 'Builder' +encodeToBuilder :: ToJSON a => a -> Builder +encodeToBuilder = encodeValueBB . toJSON + +encodeValueBB :: Value -> Builder +encodeValueBB jv = case jv of + Bool True -> "true" + Bool False -> "false" + Null -> "null" + Number n + | isNaN n || isInfinite n -> encodeValueBB Null + | Just i <- doubleToInt64 n -> BB.int64Dec i + | otherwise -> BB.doubleDec n + Array a -> encodeArrayBB a + String s -> encodeStringBB s + Object o -> encodeObjectBB o + +encodeArrayBB :: [Value] -> Builder +encodeArrayBB [] = "[]" +encodeArrayBB jvs = BB.char8 '[' <> go jvs <> BB.char8 ']' + where + go = mconcat . intersperse (BB.char8 ',') . map encodeValueBB + +encodeObjectBB :: Object -> Builder +encodeObjectBB [] = "{}" +encodeObjectBB jvs = BB.char8 '{' <> go jvs <> BB.char8 '}' + where + go = mconcat . intersperse (BB.char8 ',') . map encPair + encPair (l,x) = encodeStringBB l <> BB.char8 ':' <> encodeValueBB x + +encodeStringBB :: String -> Builder +encodeStringBB str = BB.char8 '"' <> go str <> BB.char8 '"' + where + go = BB.stringUtf8 . escapeString + +------------------------------------------------------------------------------ +-- 'String'-based encoding + +-- | Serialise value as JSON-encoded Unicode 'String' +encodeToString :: ToJSON a => a -> String +encodeToString jv = encodeValue (toJSON jv) [] + +encodeValue :: Value -> ShowS +encodeValue jv = case jv of + Bool b -> showString (if b then "true" else "false") + Null -> showString "null" + Number n + | isNaN n || isInfinite n -> encodeValue Null + | Just i <- doubleToInt64 n -> shows i + | otherwise -> shows n + Array a -> encodeArray a + String s -> encodeString s + Object o -> encodeObject o + +encodeArray :: [Value] -> ShowS +encodeArray [] = showString "[]" +encodeArray jvs = ('[':) . go jvs . (']':) + where + go [] = id + go [x] = encodeValue x + go (x:xs) = encodeValue x . (',':) . go xs + +encodeObject :: Object -> ShowS +encodeObject [] = showString "{}" +encodeObject jvs = ('{':) . go jvs . ('}':) + where + go [] = id + go [(l,x)] = encodeString l . (':':) . encodeValue x + go ((l,x):lxs) = encodeString l . (':':) . encodeValue x . (',':) . go lxs + +encodeString :: String -> ShowS +encodeString str = ('"':) . showString (escapeString str) . ('"':) + +------------------------------------------------------------------------------ +-- helpers + +-- | Try to convert 'Double' into 'Int64', return 'Nothing' if not +-- representable loss-free as integral 'Int64' value. +doubleToInt64 :: Double -> Maybe Int64 +doubleToInt64 x + | fromInteger x' == x + , x' <= toInteger (maxBound :: Int64) + , x' >= toInteger (minBound :: Int64) + = Just (fromIntegral x') + | otherwise = Nothing + where + x' = round x + +-- | Minimally escape a 'String' in accordance with RFC 7159, "7. Strings" +escapeString :: String -> String +escapeString s + | not (any needsEscape s) = s + | otherwise = escape s + where + escape [] = [] + escape (x:xs) = case x of + '\\' -> '\\':'\\':escape xs + '"' -> '\\':'"':escape xs + '\b' -> '\\':'b':escape xs + '\f' -> '\\':'f':escape xs + '\n' -> '\\':'n':escape xs + '\r' -> '\\':'r':escape xs + '\t' -> '\\':'t':escape xs + c | ord c < 0x10 -> '\\':'u':'0':'0':'0':intToDigit (ord c):escape xs + | ord c < 0x20 -> '\\':'u':'0':'0':'1':intToDigit (ord c - 0x10):escape xs + | otherwise -> c : escape xs + + -- unescaped = %x20-21 / %x23-5B / %x5D-10FFFF + needsEscape c = ord c < 0x20 || c `elem` ['\\','"'] diff --git a/cabal/cabal-install/src/Distribution/Client/Utils/Parsec.hs b/cabal/cabal-install/src/Distribution/Client/Utils/Parsec.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Utils/Parsec.hs @@ -0,0 +1,102 @@ +module Distribution.Client.Utils.Parsec ( + renderParseError, + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () +import System.FilePath (normalise) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 + +import Distribution.Parsec (PError (..), PWarning (..), Position (..), showPos, zeroPos) +import Distribution.Simple.Utils (fromUTF8BS) + +-- | Render parse error highlighting the part of the input file. +renderParseError + :: FilePath + -> BS.ByteString + -> NonEmpty PError + -> [PWarning] + -> String +renderParseError filepath contents errors warnings = unlines $ + [ "Errors encountered when parsing cabal file " <> filepath <> ":" + ] + ++ renderedErrors + ++ renderedWarnings + where + filepath' = normalise filepath + + -- lines of the input file. 'lines' is taken, so they are called rows + -- contents, line number, whether it's empty line + rows :: [(String, Int, Bool)] + rows = zipWith f (BS8.lines contents) [1..] where + f bs i = let s = fromUTF8BS bs in (s, i, isEmptyOrComment s) + + rowsZipper = listToZipper rows + + isEmptyOrComment :: String -> Bool + isEmptyOrComment s = case dropWhile (== ' ') s of + "" -> True -- empty + ('-':'-':_) -> True -- comment + _ -> False + + renderedErrors = concatMap renderError errors + renderedWarnings = concatMap renderWarning warnings + + renderError :: PError -> [String] + renderError (PError pos@(Position row col) msg) + -- if position is 0:0, then it doesn't make sense to show input + -- looks like, Parsec errors have line-feed in them + | pos == zeroPos = msgs + | otherwise = msgs ++ formatInput row col + where + msgs = [ "", filepath' ++ ":" ++ showPos pos ++ ": error:", trimLF msg, "" ] + + renderWarning :: PWarning -> [String] + renderWarning (PWarning _ pos@(Position row col) msg) + | pos == zeroPos = msgs + | otherwise = msgs ++ formatInput row col + where + msgs = [ "", filepath' ++ ":" ++ showPos pos ++ ": warning:", trimLF msg, "" ] + + -- sometimes there are (especially trailing) newlines. + trimLF :: String -> String + trimLF = dropWhile (== '\n') . reverse . dropWhile (== '\n') . reverse + + -- format line: prepend the given line number + formatInput :: Int -> Int -> [String] + formatInput row col = case advance (row - 1) rowsZipper of + Zipper xs ys -> before ++ after where + before = case span (\(_, _, b) -> b) xs of + (_, []) -> [] + (zs, z : _) -> map formatInputLine $ z : reverse zs + + after = case ys of + [] -> [] + (z : _zs) -> + [ formatInputLine z -- error line + , " | " ++ replicate (col - 1) ' ' ++ "^" -- pointer: ^ + ] + -- do we need rows after? + -- ++ map formatInputLine (take 1 zs) -- one row after + + formatInputLine :: (String, Int, Bool) -> String + formatInputLine (str, row, _) = leftPadShow row ++ " | " ++ str + + -- hopefully we don't need to work with over 99999 lines .cabal files + -- at that point small glitches in error messages are hopefully fine. + leftPadShow :: Int -> String + leftPadShow n = let s = show n in replicate (5 - length s) ' ' ++ s + +data Zipper a = Zipper [a] [a] + +listToZipper :: [a] -> Zipper a +listToZipper = Zipper [] + +advance :: Int -> Zipper a -> Zipper a +advance n z@(Zipper xs ys) + | n <= 0 = z + | otherwise = case ys of + [] -> z + (y:ys') -> advance (n - 1) $ Zipper (y:xs) ys' diff --git a/cabal/cabal-install/src/Distribution/Client/VCS.hs b/cabal/cabal-install/src/Distribution/Client/VCS.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/VCS.hs @@ -0,0 +1,747 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NamedFieldPuns, RecordWildCards, RankNTypes #-} +module Distribution.Client.VCS ( + -- * VCS driver type + VCS, + vcsRepoType, + vcsProgram, + -- ** Type re-exports + RepoType, + Program, + ConfiguredProgram, + + -- * Validating 'SourceRepo's and configuring VCS drivers + validatePDSourceRepo, + validateSourceRepo, + validateSourceRepos, + SourceRepoProblem(..), + configureVCS, + configureVCSs, + + -- * Running the VCS driver + cloneSourceRepo, + syncSourceRepos, + + -- * The individual VCS drivers + knownVCSs, + vcsBzr, + vcsDarcs, + vcsGit, + vcsHg, + vcsSvn, + vcsPijul, + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Distribution.Types.SourceRepo + ( RepoType(..), KnownRepoType (..) ) +import Distribution.Client.Types.SourceRepo (SourceRepoMaybe, SourceRepositoryPackage (..), srpToProxy) +import Distribution.Client.RebuildMonad + ( Rebuild, monitorFiles, MonitorFilePath, monitorDirectoryExistence ) +import Distribution.Verbosity as Verbosity + ( normal ) +import Distribution.Simple.Program + ( Program(programFindVersion) + , ConfiguredProgram(programVersion) + , simpleProgram, findProgramVersion + , ProgramInvocation(..), programInvocation, runProgramInvocation, getProgramInvocationOutput + , emptyProgramDb, requireProgram ) +import Distribution.Version + ( mkVersion ) +import qualified Distribution.PackageDescription as PD + +import Control.Applicative + ( liftA2 ) +import Control.Exception + ( throw, try ) +import Control.Monad.Trans + ( liftIO ) +import qualified Data.Char as Char +import qualified Data.List as List +import qualified Data.Map as Map +import System.FilePath + ( takeDirectory, () ) +import System.Directory + ( doesDirectoryExist + , removeDirectoryRecursive + ) +import System.IO.Error + ( isDoesNotExistError ) + + +-- | A driver for a version control system, e.g. git, darcs etc. +-- +data VCS program = VCS { + -- | The type of repository this driver is for. + vcsRepoType :: RepoType, + + -- | The vcs program itself. + -- This is used at type 'Program' and 'ConfiguredProgram'. + vcsProgram :: program, + + -- | The program invocation(s) to get\/clone a repository into a fresh + -- local directory. + vcsCloneRepo :: forall f. Verbosity + -> ConfiguredProgram + -> SourceRepositoryPackage f + -> FilePath -- Source URI + -> FilePath -- Destination directory + -> [ProgramInvocation], + + -- | The program invocation(s) to synchronise a whole set of /related/ + -- repositories with corresponding local directories. Also returns the + -- files that the command depends on, for change monitoring. + vcsSyncRepos :: forall f. Verbosity + -> ConfiguredProgram + -> [(SourceRepositoryPackage f, FilePath)] + -> IO [MonitorFilePath] + } + + +-- ------------------------------------------------------------ +-- * Selecting repos and drivers +-- ------------------------------------------------------------ + +data SourceRepoProblem = SourceRepoRepoTypeUnspecified + | SourceRepoRepoTypeUnsupported (SourceRepositoryPackage Proxy) RepoType + | SourceRepoLocationUnspecified + deriving Show + +-- | Validates that the 'SourceRepo' specifies a location URI and a repository +-- type that is supported by a VCS driver. +-- +-- | It also returns the 'VCS' driver we should use to work with it. +-- +validateSourceRepo + :: SourceRepositoryPackage f + -> Either SourceRepoProblem (SourceRepositoryPackage f, String, RepoType, VCS Program) +validateSourceRepo = \repo -> do + let rtype = srpType repo + vcs <- Map.lookup rtype knownVCSs ?! SourceRepoRepoTypeUnsupported (srpToProxy repo) rtype + let uri = srpLocation repo + return (repo, uri, rtype, vcs) + where + a ?! e = maybe (Left e) Right a + +validatePDSourceRepo + :: PD.SourceRepo + -> Either SourceRepoProblem (SourceRepoMaybe, String, RepoType, VCS Program) +validatePDSourceRepo repo = do + rtype <- PD.repoType repo ?! SourceRepoRepoTypeUnspecified + uri <- PD.repoLocation repo ?! SourceRepoLocationUnspecified + validateSourceRepo SourceRepositoryPackage + { srpType = rtype + , srpLocation = uri + , srpTag = PD.repoTag repo + , srpBranch = PD.repoBranch repo + , srpSubdir = PD.repoSubdir repo + , srpCommand = mempty + } + where + a ?! e = maybe (Left e) Right a + + + +-- | As 'validateSourceRepo' but for a bunch of 'SourceRepo's, and return +-- things in a convenient form to pass to 'configureVCSs', or to report +-- problems. +-- +validateSourceRepos :: [SourceRepositoryPackage f] + -> Either [(SourceRepositoryPackage f, SourceRepoProblem)] + [(SourceRepositoryPackage f, String, RepoType, VCS Program)] +validateSourceRepos rs = + case partitionEithers (map validateSourceRepo' rs) of + (problems@(_:_), _) -> Left problems + ([], vcss) -> Right vcss + where + validateSourceRepo' :: SourceRepositoryPackage f + -> Either (SourceRepositoryPackage f, SourceRepoProblem) + (SourceRepositoryPackage f, String, RepoType, VCS Program) + validateSourceRepo' r = either (Left . (,) r) Right + (validateSourceRepo r) + + +configureVCS :: Verbosity + -> VCS Program + -> IO (VCS ConfiguredProgram) +configureVCS verbosity vcs@VCS{vcsProgram = prog} = + asVcsConfigured <$> requireProgram verbosity prog emptyProgramDb + where + asVcsConfigured (prog', _) = vcs { vcsProgram = prog' } + +configureVCSs :: Verbosity + -> Map RepoType (VCS Program) + -> IO (Map RepoType (VCS ConfiguredProgram)) +configureVCSs verbosity = traverse (configureVCS verbosity) + + +-- ------------------------------------------------------------ +-- * Running the driver +-- ------------------------------------------------------------ + +-- | Clone a single source repo into a fresh directory, using a configured VCS. +-- +-- This is for making a new copy, not synchronising an existing copy. It will +-- fail if the destination directory already exists. +-- +-- Make sure to validate the 'SourceRepo' using 'validateSourceRepo' first. +-- + +cloneSourceRepo + :: Verbosity + -> VCS ConfiguredProgram + -> SourceRepositoryPackage f + -> [Char] + -> IO () +cloneSourceRepo verbosity vcs + repo@SourceRepositoryPackage{ srpLocation = srcuri } destdir = + traverse_ (runProgramInvocation verbosity) invocations + where + invocations = vcsCloneRepo vcs verbosity + (vcsProgram vcs) repo + srcuri destdir + + +-- | Syncronise a set of 'SourceRepo's referring to the same repository with +-- corresponding local directories. The local directories may or may not +-- already exist. +-- +-- The 'SourceRepo' values used in a single invocation of 'syncSourceRepos', +-- or used across a series of invocations with any local directory must refer +-- to the /same/ repository. That means it must be the same location but they +-- can differ in the branch, or tag or subdir. +-- +-- The reason to allow multiple related 'SourceRepo's is to allow for the +-- network or storage to be shared between different checkouts of the repo. +-- For example if a single repo contains multiple packages in different subdirs +-- and in some project it may make sense to use a different state of the repo +-- for one subdir compared to another. +-- +syncSourceRepos :: Verbosity + -> VCS ConfiguredProgram + -> [(SourceRepositoryPackage f, FilePath)] + -> Rebuild () +syncSourceRepos verbosity vcs repos = do + files <- liftIO $ vcsSyncRepos vcs verbosity (vcsProgram vcs) repos + monitorFiles files + + +-- ------------------------------------------------------------ +-- * The various VCS drivers +-- ------------------------------------------------------------ + +-- | The set of all supported VCS drivers, organised by 'RepoType'. +-- +knownVCSs :: Map RepoType (VCS Program) +knownVCSs = Map.fromList [ (vcsRepoType vcs, vcs) | vcs <- vcss ] + where + vcss = [ vcsBzr, vcsDarcs, vcsGit, vcsHg, vcsSvn ] + + +-- | VCS driver for Bazaar. +-- +vcsBzr :: VCS Program +vcsBzr = + VCS { + vcsRepoType = KnownRepoType Bazaar, + vcsProgram = bzrProgram, + vcsCloneRepo, + vcsSyncRepos + } + where + vcsCloneRepo :: Verbosity + -> ConfiguredProgram + -> SourceRepositoryPackage f + -> FilePath + -> FilePath + -> [ProgramInvocation] + vcsCloneRepo verbosity prog repo srcuri destdir = + [ programInvocation prog + ([branchCmd, srcuri, destdir] ++ tagArgs ++ verboseArg) ] + where + -- The @get@ command was deprecated in version 2.4 in favour of + -- the alias @branch@ + branchCmd | programVersion prog >= Just (mkVersion [2,4]) + = "branch" + | otherwise = "get" + + tagArgs :: [String] + tagArgs = case srpTag repo of + Nothing -> [] + Just tag -> ["-r", "tag:" ++ tag] + verboseArg :: [String] + verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] + + vcsSyncRepos :: Verbosity -> ConfiguredProgram + -> [(SourceRepositoryPackage f, FilePath)] -> IO [MonitorFilePath] + vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for bzr" + +bzrProgram :: Program +bzrProgram = (simpleProgram "bzr") { + programFindVersion = findProgramVersion "--version" $ \str -> + case words str of + -- "Bazaar (bzr) 2.6.0\n ... lots of extra stuff" + (_:_:ver:_) -> ver + _ -> "" + } + + +-- | VCS driver for Darcs. +-- +vcsDarcs :: VCS Program +vcsDarcs = + VCS { + vcsRepoType = KnownRepoType Darcs, + vcsProgram = darcsProgram, + vcsCloneRepo, + vcsSyncRepos + } + where + vcsCloneRepo :: Verbosity + -> ConfiguredProgram + -> SourceRepositoryPackage f + -> FilePath + -> FilePath + -> [ProgramInvocation] + vcsCloneRepo verbosity prog repo srcuri destdir = + [ programInvocation prog cloneArgs ] + where + cloneArgs :: [String] + cloneArgs = [cloneCmd, srcuri, destdir] ++ tagArgs ++ verboseArg + -- At some point the @clone@ command was introduced as an alias for + -- @get@, and @clone@ seems to be the recommended one now. + cloneCmd :: String + cloneCmd | programVersion prog >= Just (mkVersion [2,8]) + = "clone" + | otherwise = "get" + tagArgs :: [String] + tagArgs = case srpTag repo of + Nothing -> [] + Just tag -> ["-t", tag] + verboseArg :: [String] + verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] + + vcsSyncRepos :: Verbosity -> ConfiguredProgram + -> [(SourceRepositoryPackage f, FilePath)] -> IO [MonitorFilePath] + vcsSyncRepos _ _ [] = return [] + vcsSyncRepos verbosity prog ((primaryRepo, primaryLocalDir) : secondaryRepos) = + monitors <$ do + vcsSyncRepo verbosity prog primaryRepo primaryLocalDir Nothing + for_ secondaryRepos $ \ (repo, localDir) -> + vcsSyncRepo verbosity prog repo localDir $ Just primaryLocalDir + where + dirs :: [FilePath] + dirs = primaryLocalDir : (snd <$> secondaryRepos) + monitors :: [MonitorFilePath] + monitors = monitorDirectoryExistence <$> dirs + + vcsSyncRepo verbosity prog SourceRepositoryPackage{..} localDir _peer = + try (lines <$> darcsWithOutput localDir ["log", "--last", "1"]) >>= \ case + Right (_:_:_:x:_) + | Just tag <- (List.stripPrefix "tagged " . List.dropWhile Char.isSpace) x + , Just tag' <- srpTag + , tag == tag' -> pure () + Left e | not (isDoesNotExistError e) -> throw e + _ -> do + removeDirectoryRecursive localDir `catch` liftA2 unless isDoesNotExistError throw + darcs (takeDirectory localDir) cloneArgs + where + darcs :: FilePath -> [String] -> IO () + darcs = darcs' runProgramInvocation + + darcsWithOutput :: FilePath -> [String] -> IO String + darcsWithOutput = darcs' getProgramInvocationOutput + + darcs' :: (Verbosity -> ProgramInvocation -> t) -> FilePath -> [String] -> t + darcs' f cwd args = f verbosity (programInvocation prog args) + { progInvokeCwd = Just cwd } + + cloneArgs :: [String] + cloneArgs = ["clone"] ++ tagArgs ++ [srpLocation, localDir] ++ verboseArg + tagArgs :: [String] + tagArgs = case srpTag of + Nothing -> [] + Just tag -> ["-t" ++ tag] + verboseArg :: [String] + verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] + +darcsProgram :: Program +darcsProgram = (simpleProgram "darcs") { + programFindVersion = findProgramVersion "--version" $ \str -> + case words str of + -- "2.8.5 (release)" + (ver:_) -> ver + _ -> "" + } + + +-- | VCS driver for Git. +-- +vcsGit :: VCS Program +vcsGit = + VCS { + vcsRepoType = KnownRepoType Git, + vcsProgram = gitProgram, + vcsCloneRepo, + vcsSyncRepos + } + where + vcsCloneRepo :: Verbosity + -> ConfiguredProgram + -> SourceRepositoryPackage f + -> FilePath + -> FilePath + -> [ProgramInvocation] + vcsCloneRepo verbosity prog repo srcuri destdir = + [ programInvocation prog cloneArgs ] + -- And if there's a tag, we have to do that in a second step: + ++ [ git (resetArgs tag) | tag <- maybeToList (srpTag repo) ] + ++ [ git (["submodule", "sync", "--recursive"] ++ verboseArg) + , git (["submodule", "update", "--init", "--force", "--recursive"] ++ verboseArg) + ] + where + git args = (programInvocation prog args) {progInvokeCwd = Just destdir} + cloneArgs = ["clone", srcuri, destdir] + ++ branchArgs ++ verboseArg + branchArgs = case srpBranch repo of + Just b -> ["--branch", b] + Nothing -> [] + resetArgs tag = "reset" : verboseArg ++ ["--hard", tag, "--"] + verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] + + vcsSyncRepos :: Verbosity + -> ConfiguredProgram + -> [(SourceRepositoryPackage f, FilePath)] + -> IO [MonitorFilePath] + vcsSyncRepos _ _ [] = return [] + vcsSyncRepos verbosity gitProg + ((primaryRepo, primaryLocalDir) : secondaryRepos) = do + + vcsSyncRepo verbosity gitProg primaryRepo primaryLocalDir Nothing + sequence_ + [ vcsSyncRepo verbosity gitProg repo localDir (Just primaryLocalDir) + | (repo, localDir) <- secondaryRepos ] + return [ monitorDirectoryExistence dir + | dir <- (primaryLocalDir : map snd secondaryRepos) ] + + vcsSyncRepo verbosity gitProg SourceRepositoryPackage{..} localDir peer = do + exists <- doesDirectoryExist localDir + if exists + then git localDir ["fetch"] + else git (takeDirectory localDir) cloneArgs + -- Before trying to checkout other commits, all submodules must be + -- de-initialised and the .git/modules directory must be deleted. This + -- is needed because sometimes `git submodule sync` does not actually + -- update the submodule source URL. Detailed description here: + -- https://git.coop/-/snippets/85 + git localDir ["submodule", "deinit", "--force", "--all"] + let gitModulesDir = localDir ".git" "modules" + gitModulesExists <- doesDirectoryExist gitModulesDir + when gitModulesExists $ removeDirectoryRecursive gitModulesDir + git localDir resetArgs + git localDir $ ["submodule", "sync", "--recursive"] ++ verboseArg + git localDir $ ["submodule", "update", "--force", "--init", "--recursive"] ++ verboseArg + git localDir $ ["submodule", "foreach", "--recursive"] ++ verboseArg ++ ["git clean -ffxdq"] + git localDir $ ["clean", "-ffxdq"] + where + git :: FilePath -> [String] -> IO () + git cwd args = runProgramInvocation verbosity $ + (programInvocation gitProg args) { + progInvokeCwd = Just cwd + } + + cloneArgs = ["clone", "--no-checkout", loc, localDir] + ++ case peer of + Nothing -> [] + Just peerLocalDir -> ["--reference", peerLocalDir] + ++ verboseArg + where loc = srpLocation + resetArgs = "reset" : verboseArg ++ ["--hard", resetTarget, "--" ] + resetTarget = fromMaybe "HEAD" (srpBranch `mplus` srpTag) + verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] + +gitProgram :: Program +gitProgram = (simpleProgram "git") { + programFindVersion = findProgramVersion "--version" $ \str -> + case words str of + -- "git version 2.5.5" + (_:_:ver:_) | all isTypical ver -> ver + + -- or annoyingly "git version 2.17.1.windows.2" yes, really + (_:_:ver:_) -> intercalate "." + . takeWhile (all isNum) + . split + $ ver + _ -> "" + } + where + isNum c = c >= '0' && c <= '9' + isTypical c = isNum c || c == '.' + split cs = case break (=='.') cs of + (chunk,[]) -> chunk : [] + (chunk,_:rest) -> chunk : split rest + +-- | VCS driver for Mercurial. +-- +vcsHg :: VCS Program +vcsHg = + VCS { + vcsRepoType = KnownRepoType Mercurial, + vcsProgram = hgProgram, + vcsCloneRepo, + vcsSyncRepos + } + where + vcsCloneRepo :: Verbosity + -> ConfiguredProgram + -> SourceRepositoryPackage f + -> FilePath + -> FilePath + -> [ProgramInvocation] + vcsCloneRepo verbosity prog repo srcuri destdir = + [ programInvocation prog cloneArgs ] + where + cloneArgs = ["clone", srcuri, destdir] + ++ branchArgs ++ tagArgs ++ verboseArg + branchArgs = case srpBranch repo of + Just b -> ["--branch", b] + Nothing -> [] + tagArgs = case srpTag repo of + Just t -> ["--rev", t] + Nothing -> [] + verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] + + vcsSyncRepos :: Verbosity + -> ConfiguredProgram + -> [(SourceRepositoryPackage f, FilePath)] + -> IO [MonitorFilePath] + vcsSyncRepos _ _ [] = return [] + vcsSyncRepos verbosity hgProg + ((primaryRepo, primaryLocalDir) : secondaryRepos) = do + vcsSyncRepo verbosity hgProg primaryRepo primaryLocalDir + sequence_ + [ vcsSyncRepo verbosity hgProg repo localDir + | (repo, localDir) <- secondaryRepos ] + return [ monitorDirectoryExistence dir + | dir <- (primaryLocalDir : map snd secondaryRepos) ] + vcsSyncRepo verbosity hgProg repo localDir = do + exists <- doesDirectoryExist localDir + if exists + then hg localDir ["pull"] + else hg (takeDirectory localDir) cloneArgs + hg localDir checkoutArgs + where + hg :: FilePath -> [String] -> IO () + hg cwd args = runProgramInvocation verbosity $ + (programInvocation hgProg args) { + progInvokeCwd = Just cwd + } + cloneArgs = ["clone", "--noupdate", (srpLocation repo), localDir] + ++ verboseArg + verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] + checkoutArgs = [ "checkout", "--clean" ] + ++ tagArgs + tagArgs = case srpTag repo of + Just t -> ["--rev", t] + Nothing -> [] + +hgProgram :: Program +hgProgram = (simpleProgram "hg") { + programFindVersion = findProgramVersion "--version" $ \str -> + case words str of + -- Mercurial Distributed SCM (version 3.5.2)\n ... long message + (_:_:_:_:ver:_) -> takeWhile (\c -> Char.isDigit c || c == '.') ver + _ -> "" + } + + +-- | VCS driver for Subversion. +-- +vcsSvn :: VCS Program +vcsSvn = + VCS { + vcsRepoType = KnownRepoType SVN, + vcsProgram = svnProgram, + vcsCloneRepo, + vcsSyncRepos + } + where + vcsCloneRepo :: Verbosity + -> ConfiguredProgram + -> SourceRepositoryPackage f + -> FilePath + -> FilePath + -> [ProgramInvocation] + vcsCloneRepo verbosity prog _repo srcuri destdir = + [ programInvocation prog checkoutArgs ] + where + checkoutArgs = ["checkout", srcuri, destdir] ++ verboseArg + verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] + --TODO: branch or tag? + + vcsSyncRepos :: Verbosity + -> ConfiguredProgram + -> [(SourceRepositoryPackage f, FilePath)] + -> IO [MonitorFilePath] + vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for svn" + +svnProgram :: Program +svnProgram = (simpleProgram "svn") { + programFindVersion = findProgramVersion "--version" $ \str -> + case words str of + -- svn, version 1.9.4 (r1740329)\n ... long message + (_:_:ver:_) -> ver + _ -> "" + } + + +-- | VCS driver for Pijul. +-- Documentation for Pijul can be found at +-- +-- 2020-04-09 Oleg: +-- +-- As far as I understand pijul, there are branches and "tags" in pijul, +-- but there aren't a "commit hash" identifying an arbitrary state. +-- +-- One can create `a pijul tag`, which will make a patch hash, +-- which depends on everything currently in the repository. +-- I guess if you try to apply that patch, you'll be forced to apply +-- all the dependencies too. In other words, there are no named tags. +-- +-- It's not clear to me whether there is an option to +-- "apply this patch *and* all of its dependencies". +-- And relatedly, whether how to make sure that there are no other +-- patches applied. +-- +-- With branches it's easier, as you can `pull` and `checkout` them, +-- and they seem to be similar enough. Yet, pijul documentations says +-- +-- > Note that the purpose of branches in Pijul is quite different from Git, +-- since Git's "feature branches" can usually be implemented by just +-- patches. +-- +-- I guess it means that indeed instead of creating a branch and making PR +-- in "GitHub" workflow, you'd just create a patch and offer it. +-- You can do that with `git` too. Push (a branch with) commit to remote +-- and ask other to cherry-pick that commit. Yet, in git identity of commit +-- changes when it applied to other trees, where patches in pijul have +-- will continue to have the same hash. +-- +-- Unfortunately pijul doesn't talk about conflict resolution. +-- It seems that you get something like: +-- +-- % pijul status +-- On branch merge +-- +-- Unresolved conflicts: +-- (fix conflicts and record the resolution with "pijul record ...") +-- +-- foo +-- +-- % cat foo +-- first line +-- >> >>>>>>>>>>>>>>>>>>>>>>>>>>>>> +-- branch BBB +-- ================================ +-- branch AAA +-- <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< +-- last line +-- +-- And then the `pijul dependencies` would draw you a graph like +-- +-- +-- -----> foo on branch B -----> +-- resolve confict Initial patch +-- -----> foo on branch A -----> +-- +-- Which is seems reasonable. +-- +-- So currently, pijul support is very experimental, and most likely +-- won't work, even the basics are in place. Tests are also written +-- but disabled, as the branching model differs from `git` one, +-- for which tests are written. +-- +vcsPijul :: VCS Program +vcsPijul = + VCS { + vcsRepoType = KnownRepoType Pijul, + vcsProgram = pijulProgram, + vcsCloneRepo, + vcsSyncRepos + } + where + vcsCloneRepo :: Verbosity -- ^ it seems that pijul does not have verbose flag + -> ConfiguredProgram + -> SourceRepositoryPackage f + -> FilePath + -> FilePath + -> [ProgramInvocation] + vcsCloneRepo _verbosity prog repo srcuri destdir = + [ programInvocation prog cloneArgs ] + -- And if there's a tag, we have to do that in a second step: + ++ [ (programInvocation prog (checkoutArgs tag)) { + progInvokeCwd = Just destdir + } + | tag <- maybeToList (srpTag repo) ] + where + cloneArgs :: [String] + cloneArgs = ["clone", srcuri, destdir] + ++ branchArgs + branchArgs :: [String] + branchArgs = case srpBranch repo of + Just b -> ["--from-branch", b] + Nothing -> [] + checkoutArgs tag = "checkout" : [tag] -- TODO: this probably doesn't work either + + vcsSyncRepos :: Verbosity + -> ConfiguredProgram + -> [(SourceRepositoryPackage f, FilePath)] + -> IO [MonitorFilePath] + vcsSyncRepos _ _ [] = return [] + vcsSyncRepos verbosity pijulProg + ((primaryRepo, primaryLocalDir) : secondaryRepos) = do + + vcsSyncRepo verbosity pijulProg primaryRepo primaryLocalDir Nothing + sequence_ + [ vcsSyncRepo verbosity pijulProg repo localDir (Just primaryLocalDir) + | (repo, localDir) <- secondaryRepos ] + return [ monitorDirectoryExistence dir + | dir <- (primaryLocalDir : map snd secondaryRepos) ] + + vcsSyncRepo verbosity pijulProg SourceRepositoryPackage{..} localDir peer = do + exists <- doesDirectoryExist localDir + if exists + then pijul localDir ["pull"] -- TODO: this probably doesn't work. + else pijul (takeDirectory localDir) cloneArgs + pijul localDir checkoutArgs + where + pijul :: FilePath -> [String] -> IO () + pijul cwd args = runProgramInvocation verbosity $ + (programInvocation pijulProg args) { + progInvokeCwd = Just cwd + } + + cloneArgs :: [String] + cloneArgs = ["clone", loc, localDir] + ++ case peer of + Nothing -> [] + Just peerLocalDir -> [peerLocalDir] + where loc = srpLocation + checkoutArgs :: [String] + checkoutArgs = "checkout" : ["--force", checkoutTarget, "--" ] + checkoutTarget = fromMaybe "HEAD" (srpBranch `mplus` srpTag) -- TODO: this is definitely wrong. + +pijulProgram :: Program +pijulProgram = (simpleProgram "pijul") { + programFindVersion = findProgramVersion "--version" $ \str -> + case words str of + -- "pijul 0.12.2 + (_:ver:_) | all isTypical ver -> ver + _ -> "" + } + where + isNum c = c >= '0' && c <= '9' + isTypical c = isNum c || c == '.' diff --git a/cabal/cabal-install/src/Distribution/Client/Version.hs b/cabal/cabal-install/src/Distribution/Client/Version.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Version.hs @@ -0,0 +1,16 @@ +-- | Provides the version number of @cabal-install@. + +module Distribution.Client.Version + ( cabalInstallVersion + ) where + +import Distribution.Version + +-- This value determines the `cabal-install --version` output. +-- +-- It is used in several places throughout the project, including anonymous build reports, client configuration, +-- and project planning output. Historically, this was a @Paths_*@ module, however, this conflicted with +-- program coverage information generated by HPC, and hence was moved to be a standalone value. +-- +cabalInstallVersion :: Version +cabalInstallVersion = mkVersion [3,8,1,0] diff --git a/cabal/cabal-install/src/Distribution/Client/Win32SelfUpgrade.hs b/cabal/cabal-install/src/Distribution/Client/Win32SelfUpgrade.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Client/Win32SelfUpgrade.hs @@ -0,0 +1,226 @@ +{-# LANGUAGE CPP, ForeignFunctionInterface #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Win32SelfUpgrade +-- Copyright : (c) Duncan Coutts 2008 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Support for self-upgrading executables on Windows platforms. +----------------------------------------------------------------------------- +module Distribution.Client.Win32SelfUpgrade ( +-- * Explanation +-- +-- | Windows inherited a design choice from DOS that while initially innocuous +-- has rather unfortunate consequences. It maintains the invariant that every +-- open file has a corresponding name on disk. One positive consequence of this +-- is that an executable can always find its own executable file. The downside +-- is that a program cannot be deleted or upgraded while it is running without +-- hideous workarounds. This module implements one such hideous workaround. +-- +-- The basic idea is: +-- +-- * Move our own exe file to a new name +-- * Copy a new exe file to the previous name +-- * Run the new exe file, passing our own PID and new path +-- * Wait for the new process to start +-- * Close the new exe file +-- * Exit old process +-- +-- Then in the new process: +-- +-- * Inform the old process that we've started +-- * Wait for the old process to die +-- * Delete the old exe file +-- * Exit new process +-- + + possibleSelfUpgrade, + deleteOldExeFile, + ) where + +import Distribution.Client.Compat.Prelude hiding (log) +import Prelude () + +#ifdef mingw32_HOST_OS + +import qualified System.Win32 as Win32 +import System.Win32 (DWORD, BOOL, HANDLE, LPCTSTR) +import Foreign.Ptr (Ptr, nullPtr) +import System.Process (runProcess) +import System.Directory (canonicalizePath) +import System.FilePath (takeBaseName, replaceBaseName, equalFilePath) + +import Distribution.Verbosity as Verbosity (showForCabal) +import Distribution.Simple.Utils (debug, info) + + +-- | If one of the given files is our own exe file then we arrange things such +-- that the nested action can replace our own exe file. +-- +-- We require that the new process accepts a command line invocation that +-- calls 'deleteOldExeFile', passing in the PID and exe file. +-- +possibleSelfUpgrade :: Verbosity + -> [FilePath] + -> IO a -> IO a +possibleSelfUpgrade verbosity newPaths action = do + dstPath <- canonicalizePath =<< Win32.getModuleFileName Win32.nullHANDLE + + newPaths' <- traverse canonicalizePath newPaths + let doingSelfUpgrade = any (equalFilePath dstPath) newPaths' + + if not doingSelfUpgrade + then action + else do + info verbosity $ "cabal-install does the replace-own-exe-file dance..." + tmpPath <- moveOurExeOutOfTheWay verbosity + result <- action + scheduleOurDemise verbosity dstPath tmpPath + (\pid path -> ["win32selfupgrade", pid, path + ,"--verbose=" ++ Verbosity.showForCabal verbosity]) + return result + +-- | The name of a Win32 Event object that we use to synchronise between the +-- old and new processes. We need to synchronise to make sure that the old +-- process has not yet terminated by the time the new one starts up and looks +-- for the old process. Otherwise the old one might have already terminated +-- and we could not wait on it terminating reliably (eg the PID might get +-- re-used). +-- +syncEventName :: String +syncEventName = "Local\\cabal-install-upgrade" + +-- | The first part of allowing our exe file to be replaced is to move the +-- existing exe file out of the way. Although we cannot delete our exe file +-- while we're still running, fortunately we can rename it, at least within +-- the same directory. +-- +moveOurExeOutOfTheWay :: Verbosity -> IO FilePath +moveOurExeOutOfTheWay verbosity = do + ourPID <- getCurrentProcessId + dstPath <- Win32.getModuleFileName Win32.nullHANDLE + + let tmpPath = replaceBaseName dstPath (takeBaseName dstPath ++ show ourPID) + + debug verbosity $ "moving " ++ dstPath ++ " to " ++ tmpPath + Win32.moveFile dstPath tmpPath + return tmpPath + +-- | Assuming we've now installed the new exe file in the right place, we +-- launch it and ask it to delete our exe file when we eventually terminate. +-- +scheduleOurDemise :: Verbosity -> FilePath -> FilePath + -> (String -> FilePath -> [String]) -> IO () +scheduleOurDemise verbosity dstPath tmpPath mkArgs = do + ourPID <- getCurrentProcessId + event <- createEvent syncEventName + + let args = mkArgs (show ourPID) tmpPath + log $ "launching child " ++ unwords (dstPath : map show args) + _ <- runProcess dstPath args Nothing Nothing Nothing Nothing Nothing + + log $ "waiting for the child to start up" + waitForSingleObject event (10*1000) -- wait at most 10 sec + log $ "child started ok" + + where + log msg = debug verbosity ("Win32Reinstall.parent: " ++ msg) + +-- | Assuming we're now in the new child process, we've been asked by the old +-- process to wait for it to terminate and then we can remove the old exe file +-- that it renamed itself to. +-- +deleteOldExeFile :: Verbosity -> Int -> FilePath -> IO () +deleteOldExeFile verbosity oldPID tmpPath = do + log $ "process started. Will delete exe file of process " + ++ show oldPID ++ " at path " ++ tmpPath + + log $ "getting handle of parent process " ++ show oldPID + oldPHANDLE <- Win32.openProcess Win32.sYNCHRONIZE False (fromIntegral oldPID) + + log $ "synchronising with parent" + event <- openEvent syncEventName + setEvent event + + log $ "waiting for parent process to terminate" + waitForSingleObject oldPHANDLE Win32.iNFINITE + log $ "parent process terminated" + + log $ "deleting parent's old .exe file" + Win32.deleteFile tmpPath + + where + log msg = debug verbosity ("Win32Reinstall.child: " ++ msg) + +------------------------ +-- Win32 foreign imports +-- + +-- A bunch of functions sadly not provided by the Win32 package. + +#ifdef x86_64_HOST_ARCH +#define CALLCONV ccall +#else +#define CALLCONV stdcall +#endif + +foreign import CALLCONV unsafe "windows.h GetCurrentProcessId" + getCurrentProcessId :: IO DWORD + +foreign import CALLCONV unsafe "windows.h WaitForSingleObject" + waitForSingleObject_ :: HANDLE -> DWORD -> IO DWORD + +waitForSingleObject :: HANDLE -> DWORD -> IO () +waitForSingleObject handle timeout = + Win32.failIf_ bad "WaitForSingleObject" $ + waitForSingleObject_ handle timeout + where + bad result = not (result == 0 || result == wAIT_TIMEOUT) + wAIT_TIMEOUT = 0x00000102 + +foreign import CALLCONV unsafe "windows.h CreateEventW" + createEvent_ :: Ptr () -> BOOL -> BOOL -> LPCTSTR -> IO HANDLE + +createEvent :: String -> IO HANDLE +createEvent name = do + Win32.failIfNull "CreateEvent" $ + Win32.withTString name $ + createEvent_ nullPtr False False + +foreign import CALLCONV unsafe "windows.h OpenEventW" + openEvent_ :: DWORD -> BOOL -> LPCTSTR -> IO HANDLE + +openEvent :: String -> IO HANDLE +openEvent name = do + Win32.failIfNull "OpenEvent" $ + Win32.withTString name $ + openEvent_ eVENT_MODIFY_STATE False + where + eVENT_MODIFY_STATE :: DWORD + eVENT_MODIFY_STATE = 0x0002 + +foreign import CALLCONV unsafe "windows.h SetEvent" + setEvent_ :: HANDLE -> IO BOOL + +setEvent :: HANDLE -> IO () +setEvent handle = + Win32.failIfFalse_ "SetEvent" $ + setEvent_ handle + +#else + +import Distribution.Simple.Utils (die') + +possibleSelfUpgrade :: Verbosity + -> [FilePath] + -> IO a -> IO a +possibleSelfUpgrade _ _ action = action + +deleteOldExeFile :: Verbosity -> Int -> FilePath -> IO () +deleteOldExeFile verbosity _ _ = die' verbosity "win32selfupgrade not needed except on win32" + +#endif diff --git a/cabal/cabal-install/src/Distribution/Deprecated/ParseUtils.hs b/cabal/cabal-install/src/Distribution/Deprecated/ParseUtils.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Deprecated/ParseUtils.hs @@ -0,0 +1,364 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Deprecated.ParseUtils +-- Copyright : (c) The University of Glasgow 2004 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Utilities for parsing 'PackageDescription' and 'InstalledPackageInfo'. +-- +-- The @.cabal@ file format is not trivial, especially with the introduction +-- of configurations and the section syntax that goes with that. This module +-- has a bunch of parsing functions that is used by the @.cabal@ parser and a +-- couple others. It has the parsing framework code and also little parsers for +-- many of the formats we get in various @.cabal@ file fields, like module +-- names, comma separated lists etc. + +-- This module is meant to be local-only to Distribution... + +{-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE Rank2Types #-} +module Distribution.Deprecated.ParseUtils ( + LineNo, PError(..), PWarning(..), locatedErrorMsg, syntaxError, warning, + runP, runE, ParseResult(..), parseFail, showPWarning, + Field(..), lineNo, + FieldDescr(..), readFields, + parseHaskellString, parseTokenQ, + parseOptCommaList, + showFilePath, showToken, showFreeText, + field, simpleField, listField, listFieldWithSep, spaceListField, + newLineListField, + liftField, + readPToMaybe, + + fieldParsec, simpleFieldParsec, + listFieldParsec, + commaListFieldParsec, + commaNewLineListFieldParsec, + + UnrecFieldParser, + ) where + +import Distribution.Client.Compat.Prelude hiding (get) +import Prelude () + +import Distribution.Deprecated.ReadP as ReadP hiding (get) + +import Distribution.Pretty +import Distribution.ReadE +import Distribution.Utils.Generic + +import System.FilePath (normalise) +import Text.PrettyPrint (Doc, punctuate, comma, fsep, sep) +import qualified Text.Read as Read + +import qualified Control.Monad.Fail as Fail +import Distribution.Parsec (ParsecParser, parsecLeadingCommaList, parsecLeadingOptCommaList) + +import qualified Data.ByteString as BS +import qualified Distribution.Fields as Fields +import qualified Distribution.Fields.Field as Fields +import qualified Distribution.Parsec as Parsec +import qualified Distribution.Fields.LexerMonad as Fields +import qualified Text.Parsec.Error as PE +import qualified Text.Parsec.Pos as PP + +-- ----------------------------------------------------------------------------- + +type LineNo = Int + +data PError = AmbiguousParse String LineNo + | NoParse String LineNo + | TabsError LineNo + | FromString String (Maybe LineNo) + deriving (Eq, Show) + +data PWarning = PWarning String + | UTFWarning LineNo String + deriving (Eq, Show) + +showPWarning :: FilePath -> PWarning -> String +showPWarning fpath (PWarning msg) = + normalise fpath ++ ": " ++ msg +showPWarning fpath (UTFWarning line fname) = + normalise fpath ++ ":" ++ show line + ++ ": Invalid UTF-8 text in the '" ++ fname ++ "' field." + +data ParseResult a = ParseFailed PError | ParseOk [PWarning] a + deriving Show + +instance Functor ParseResult where + fmap _ (ParseFailed err) = ParseFailed err + fmap f (ParseOk ws x) = ParseOk ws $ f x + +instance Applicative ParseResult where + pure = ParseOk [] + (<*>) = ap + + +instance Monad ParseResult where + return = pure + ParseFailed err >>= _ = ParseFailed err + ParseOk ws x >>= f = case f x of + ParseFailed err -> ParseFailed err + ParseOk ws' x' -> ParseOk (ws'++ws) x' +#if !(MIN_VERSION_base(4,9,0)) + fail = parseResultFail +#elif !(MIN_VERSION_base(4,13,0)) + fail = Fail.fail +#endif + +instance Foldable ParseResult where + foldMap _ (ParseFailed _ ) = mempty + foldMap f (ParseOk _ x) = f x + +instance Traversable ParseResult where + traverse _ (ParseFailed err) = pure (ParseFailed err) + traverse f (ParseOk ws x) = ParseOk ws <$> f x + + +instance Fail.MonadFail ParseResult where + fail = parseResultFail + +parseResultFail :: String -> ParseResult a +parseResultFail s = parseFail (FromString s Nothing) + +parseFail :: PError -> ParseResult a +parseFail = ParseFailed + +runP :: LineNo -> String -> ReadP a a -> String -> ParseResult a +runP line fieldname p s = + case [ x | (x,"") <- results ] of + [a] -> ParseOk (utf8Warnings line fieldname s) a + --TODO: what is this double parse thing all about? + -- Can't we just do the all isSpace test the first time? + [] -> case [ x | (x,ys) <- results, all isSpace ys ] of + [a] -> ParseOk (utf8Warnings line fieldname s) a + [] -> ParseFailed (NoParse fieldname line) + _ -> ParseFailed (AmbiguousParse fieldname line) + _ -> ParseFailed (AmbiguousParse fieldname line) + where results = readP_to_S p s + +runE :: LineNo -> String -> ReadE a -> String -> ParseResult a +runE line fieldname p s = + case runReadE p s of + Right a -> ParseOk (utf8Warnings line fieldname s) a + Left e -> syntaxError line $ + "Parse of field '" ++ fieldname ++ "' failed (" ++ e ++ "): " ++ s + +utf8Warnings :: LineNo -> String -> String -> [PWarning] +utf8Warnings line fieldname s = + take 1 [ UTFWarning n fieldname + | (n,l) <- zip [line..] (lines s) + , '\xfffd' `elem` l ] + +locatedErrorMsg :: PError -> (Maybe LineNo, String) +locatedErrorMsg (AmbiguousParse f n) = (Just n, + "Ambiguous parse in field '"++f++"'.") +locatedErrorMsg (NoParse f n) = (Just n, + "Parse of field '"++f++"' failed.") +locatedErrorMsg (TabsError n) = (Just n, "Tab used as indentation.") +locatedErrorMsg (FromString s n) = (n, s) + +syntaxError :: LineNo -> String -> ParseResult a +syntaxError n s = ParseFailed $ FromString s (Just n) + + +warning :: String -> ParseResult () +warning s = ParseOk [PWarning s] () + +-- | Field descriptor. The parameter @a@ parameterizes over where the field's +-- value is stored in. +data FieldDescr a + = FieldDescr + { fieldName :: String + , fieldGet :: a -> Doc + , fieldSet :: LineNo -> String -> a -> ParseResult a + -- ^ @fieldSet n str x@ Parses the field value from the given input + -- string @str@ and stores the result in @x@ if the parse was + -- successful. Otherwise, reports an error on line number @n@. + } + +field :: String -> (a -> Doc) -> ReadP a a -> FieldDescr a +field name showF readF = + FieldDescr name showF (\line val _st -> runP line name readF val) + +fieldParsec :: String -> (a -> Doc) -> ParsecParser a -> FieldDescr a +fieldParsec name showF readF = + FieldDescr name showF $ \line val _st -> case explicitEitherParsec readF val of + Left err -> ParseFailed (FromString err (Just line)) + Right x -> ParseOk [] x + +-- Lift a field descriptor storing into an 'a' to a field descriptor storing +-- into a 'b'. +liftField :: (b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b +liftField get set (FieldDescr name showF parseF) + = FieldDescr name (showF . get) + (\line str b -> do + a <- parseF line str (get b) + return (set a b)) + +-- Parser combinator for simple fields. Takes a field name, a pretty printer, +-- a parser function, an accessor, and a setter, returns a FieldDescr over the +-- compoid structure. +simpleField :: String -> (a -> Doc) -> ReadP a a + -> (b -> a) -> (a -> b -> b) -> FieldDescr b +simpleField name showF readF get set + = liftField get set $ field name showF readF + +simpleFieldParsec :: String -> (a -> Doc) -> ParsecParser a + -> (b -> a) -> (a -> b -> b) -> FieldDescr b +simpleFieldParsec name showF readF get set + = liftField get set $ fieldParsec name showF readF + +commaListFieldWithSepParsec :: Separator -> String -> (a -> Doc) -> ParsecParser a + -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b +commaListFieldWithSepParsec separator name showF readF get set = + liftField get set' $ + fieldParsec name showF' (parsecLeadingCommaList readF) + where + set' xs b = set (get b ++ xs) b + showF' = separator . punctuate comma . map showF + +commaListFieldParsec :: String -> (a -> Doc) -> ParsecParser a + -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b +commaListFieldParsec = commaListFieldWithSepParsec fsep + +commaNewLineListFieldParsec + :: String -> (a -> Doc) -> ParsecParser a + -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b +commaNewLineListFieldParsec = commaListFieldWithSepParsec sep + +spaceListField :: String -> (a -> Doc) -> ReadP [a] a + -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b +spaceListField name showF readF get set = + liftField get set' $ + field name showF' (parseSpaceList readF) + where + set' xs b = set (get b ++ xs) b + showF' = fsep . map showF + +-- this is a different definition from listField, like +-- commaNewLineListField it pretty prints on multiple lines +newLineListField :: String -> (a -> Doc) -> ReadP [a] a + -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b +newLineListField = listFieldWithSep sep + +listFieldWithSep :: Separator -> String -> (a -> Doc) -> ReadP [a] a + -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b +listFieldWithSep separator name showF readF get set = + liftField get set' $ + field name showF' (parseOptCommaList readF) + where + set' xs b = set (get b ++ xs) b + showF' = separator . map showF + +listFieldWithSepParsec :: Separator -> String -> (a -> Doc) -> ParsecParser a + -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b +listFieldWithSepParsec separator name showF readF get set = + liftField get set' $ + fieldParsec name showF' (parsecLeadingOptCommaList readF) + where + set' xs b = set (get b ++ xs) b + showF' = separator . map showF + +listField :: String -> (a -> Doc) -> ReadP [a] a + -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b +listField = listFieldWithSep fsep + +listFieldParsec + :: String -> (a -> Doc) -> ParsecParser a + -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b +listFieldParsec = listFieldWithSepParsec fsep + +-- | The type of a function which, given a name-value pair of an +-- unrecognized field, and the current structure being built, +-- decides whether to incorporate the unrecognized field +-- (by returning Just x, where x is a possibly modified version +-- of the structure being built), or not (by returning Nothing). +type UnrecFieldParser a = (String,String) -> a -> Maybe a + +------------------------------------------------------------------------------ + +-- The data type for our three syntactic categories +data Field + = F LineNo String String + -- ^ A regular @: @ field + | Section LineNo String String [Field] + -- ^ A section with a name and possible parameter. The syntactic + -- structure is: + -- + -- @ + -- { + -- * + -- } + -- @ + deriving (Show + ,Eq) -- for testing + +lineNo :: Field -> LineNo +lineNo (F n _ _) = n +lineNo (Section n _ _ _) = n + +readFields :: BS.ByteString -> ParseResult [Field] +readFields input = case Fields.readFields' input of + Right (fs, ws) -> ParseOk + [ PWarning msg | Fields.PWarning _ _ msg <- Fields.toPWarnings ws ] + (legacyFields fs) + Left perr -> ParseFailed $ NoParse + (PE.showErrorMessages + "or" "unknown parse error" "expecting" "unexpected" "end of file" + (PE.errorMessages perr)) + (PP.sourceLine pos) + where + pos = PE.errorPos perr + +legacyFields :: [Fields.Field Parsec.Position] -> [Field] +legacyFields = map legacyField + +legacyField :: Fields.Field Parsec.Position -> Field +legacyField (Fields.Field (Fields.Name pos name) fls) = + F (posToLineNo pos) (fromUTF8BS name) (Fields.fieldLinesToString fls) +legacyField (Fields.Section (Fields.Name pos name) args fs) = + Section (posToLineNo pos) (fromUTF8BS name) (Fields.sectionArgsToString args) (legacyFields fs) + +posToLineNo :: Parsec.Position -> LineNo +posToLineNo (Parsec.Position row _) = row + +------------------------------------------------------------------------------ + +-- urgh, we can't define optQuotes :: ReadP r a -> ReadP r a +-- because the "compat" version of ReadP isn't quite powerful enough. In +-- particular, the type of <++ is ReadP r r -> ReadP r a -> ReadP r a +-- Hence the trick above to make 'lic' polymorphic. + +-- Different than the naive version. it turns out Read instance for String accepts +-- the ['a', 'b'] syntax, which we do not want. In particular it messes +-- up any token starting with []. +parseHaskellString :: ReadP r String +parseHaskellString = + readS_to_P $ + Read.readPrec_to_S (do Read.String s <- Read.lexP; return s) 0 + +parseTokenQ :: ReadP r String +parseTokenQ = parseHaskellString <++ munch1 (\x -> not (isSpace x) && x /= ',') + +parseSpaceList :: ReadP r a -- ^The parser for the stuff between commas + -> ReadP r [a] +parseSpaceList p = sepBy p skipSpaces + +-- This version avoid parse ambiguity for list element parsers +-- that have multiple valid parses of prefixes. +parseOptCommaList :: ReadP r a -> ReadP r [a] +parseOptCommaList p = sepBy p localSep + where + -- The separator must not be empty or it introduces ambiguity + localSep = (skipSpaces >> char ',' >> skipSpaces) + +++ (satisfy isSpace >> skipSpaces) + +readPToMaybe :: ReadP a a -> String -> Maybe a +readPToMaybe p str = listToMaybe [ r | (r,s) <- readP_to_S p str + , all isSpace s ] diff --git a/cabal/cabal-install/src/Distribution/Deprecated/ReadP.hs b/cabal/cabal-install/src/Distribution/Deprecated/ReadP.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Deprecated/ReadP.hs @@ -0,0 +1,449 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +----------------------------------------------------------------------------- +-- | +-- +-- Module : Distribution.Deprecated.ReadP +-- Copyright : (c) The University of Glasgow 2002 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Portability : portable +-- +-- This is a library of parser combinators, originally written by Koen Claessen. +-- It parses all alternatives in parallel, so it never keeps hold of +-- the beginning of the input string, a common source of space leaks with +-- other parsers. The '(+++)' choice combinator is genuinely commutative; +-- it makes no difference which branch is \"shorter\". +-- +-- See also Koen's paper /Parallel Parsing Processes/ +-- (). +-- +-- This version of ReadP has been locally hacked to make it H98, by +-- Martin Sjögren +-- +-- The unit tests have been moved to UnitTest.Distribution.Deprecated.ReadP, by +-- Mark Lentczner +----------------------------------------------------------------------------- + +module Distribution.Deprecated.ReadP + ( + -- * The 'ReadP' type + ReadP, -- :: * -> *; instance Functor, Monad, MonadPlus + + -- * Primitive operations + get, -- :: ReadP Char + look, -- :: ReadP String + (+++), -- :: ReadP a -> ReadP a -> ReadP a + (<++), -- :: ReadP a -> ReadP a -> ReadP a + gather, -- :: ReadP a -> ReadP (String, a) + + -- * Other operations + pfail, -- :: ReadP a + eof, -- :: ReadP () + satisfy, -- :: (Char -> Bool) -> ReadP Char + char, -- :: Char -> ReadP Char + string, -- :: String -> ReadP String + munch, -- :: (Char -> Bool) -> ReadP String + munch1, -- :: (Char -> Bool) -> ReadP String + skipSpaces, -- :: ReadP () + skipSpaces1,-- :: ReadP () + choice, -- :: [ReadP a] -> ReadP a + count, -- :: Int -> ReadP a -> ReadP [a] + between, -- :: ReadP open -> ReadP close -> ReadP a -> ReadP a + option, -- :: a -> ReadP a -> ReadP a + optional, -- :: ReadP a -> ReadP () + many, -- :: ReadP a -> ReadP [a] + many1, -- :: ReadP a -> ReadP [a] + skipMany, -- :: ReadP a -> ReadP () + skipMany1, -- :: ReadP a -> ReadP () + sepBy, -- :: ReadP a -> ReadP sep -> ReadP [a] + sepBy1, -- :: ReadP a -> ReadP sep -> ReadP [a] + endBy, -- :: ReadP a -> ReadP sep -> ReadP [a] + endBy1, -- :: ReadP a -> ReadP sep -> ReadP [a] + chainr, -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a + chainl, -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a + chainl1, -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a + chainr1, -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a + manyTill, -- :: ReadP a -> ReadP end -> ReadP [a] + + -- * Running a parser + ReadS, -- :: *; = String -> [(a,String)] + readP_to_S, -- :: ReadP a -> ReadS a + readS_to_P, -- :: ReadS a -> ReadP a + readP_to_E, + + -- ** Internal + Parser, + ) + where + +import Prelude () +import Distribution.Client.Compat.Prelude hiding (many, get) + +import Control.Monad( replicateM, (>=>) ) + +import qualified Control.Monad.Fail as Fail + +import Distribution.ReadE (ReadE (..)) + +infixr 5 +++, <++ + +-- --------------------------------------------------------------------------- +-- The P type +-- is representation type -- should be kept abstract + +data P s a + = Get (s -> P s a) + | Look ([s] -> P s a) + | Fail + | Result a (P s a) + | Final [(a,[s])] -- invariant: list is non-empty! + +-- Monad, MonadPlus + +instance Functor (P s) where + fmap = liftM + +instance Applicative (P s) where + pure x = Result x Fail + (<*>) = ap + +instance Monad (P s) where + return = pure + + (Get f) >>= k = Get (f >=> k) + (Look f) >>= k = Look (f >=> k) + Fail >>= _ = Fail + (Result x p) >>= k = k x `mplus` (p >>= k) + (Final r) >>= k = final [ys' | (x,s) <- r, ys' <- run (k x) s] + +#if !(MIN_VERSION_base(4,9,0)) + fail _ = Fail +#elif !(MIN_VERSION_base(4,13,0)) + fail = Fail.fail +#endif + +instance Fail.MonadFail (P s) where + fail _ = Fail + +instance Alternative (P s) where + empty = mzero + (<|>) = mplus + +instance MonadPlus (P s) where + mzero = Fail + + -- most common case: two gets are combined + Get f1 `mplus` Get f2 = Get (\c -> f1 c `mplus` f2 c) + + -- results are delivered as soon as possible + Result x p `mplus` q = Result x (p `mplus` q) + p `mplus` Result x q = Result x (p `mplus` q) + + -- fail disappears + Fail `mplus` p = p + p `mplus` Fail = p + + -- two finals are combined + -- final + look becomes one look and one final (=optimization) + -- final + sthg else becomes one look and one final + Final r `mplus` Final t = Final (r ++ t) + Final r `mplus` Look f = Look (\s -> Final (r ++ run (f s) s)) + Final r `mplus` p = Look (\s -> Final (r ++ run p s)) + Look f `mplus` Final r = Look (\s -> Final (run (f s) s ++ r)) + p `mplus` Final r = Look (\s -> Final (run p s ++ r)) + + -- two looks are combined (=optimization) + -- look + sthg else floats upwards + Look f `mplus` Look g = Look (\s -> f s `mplus` g s) + Look f `mplus` p = Look (\s -> f s `mplus` p) + p `mplus` Look f = Look (\s -> p `mplus` f s) + +-- --------------------------------------------------------------------------- +-- The ReadP type + +newtype Parser r s a = R ((a -> P s r) -> P s r) +type ReadP r a = Parser r Char a + +-- Functor, Monad, MonadPlus + +instance Functor (Parser r s) where + fmap h (R f) = R (\k -> f (k . h)) + +instance Applicative (Parser r s) where + pure x = R (\k -> k x) + (<*>) = ap + +instance s ~ Char => Alternative (Parser r s) where + empty = pfail + (<|>) = (+++) + +instance Monad (Parser r s) where + return = pure + R m >>= f = R (\k -> m (\a -> let R m' = f a in m' k)) + +#if !(MIN_VERSION_base(4,9,0)) + fail _ = R (const Fail) +#elif !(MIN_VERSION_base(4,13,0)) + fail = Fail.fail +#endif + +instance Fail.MonadFail (Parser r s) where + fail _ = R (const Fail) + +instance s ~ Char => MonadPlus (Parser r s) where + mzero = pfail + mplus = (+++) + +-- --------------------------------------------------------------------------- +-- Operations over P + +final :: [(a,[s])] -> P s a +-- Maintains invariant for Final constructor +final [] = Fail +final r = Final r + +run :: P c a -> ([c] -> [(a, [c])]) +run (Get f) (c:s) = run (f c) s +run (Look f) s = run (f s) s +run (Result x p) s = (x,s) : run p s +run (Final r) _ = r +run _ _ = [] + +-- --------------------------------------------------------------------------- +-- Operations over ReadP + +get :: ReadP r Char +-- ^ Consumes and returns the next character. +-- Fails if there is no input left. +get = R Get + +look :: ReadP r String +-- ^ Look-ahead: returns the part of the input that is left, without +-- consuming it. +look = R Look + +pfail :: ReadP r a +-- ^ Always fails. +pfail = R (const Fail) + +eof :: ReadP r () +-- ^ Succeeds iff we are at the end of input +eof = do { s <- look + ; if null s then return () + else pfail } + +(+++) :: ReadP r a -> ReadP r a -> ReadP r a +-- ^ Symmetric choice. +R f1 +++ R f2 = R (\k -> f1 k `mplus` f2 k) + +(<++) :: ReadP a a -> ReadP r a -> ReadP r a +-- ^ Local, exclusive, left-biased choice: If left parser +-- locally produces any result at all, then right parser is +-- not used. +R f <++ q = + do s <- look + probe (f return) s 0 + where + probe (Get f') (c:s) n = probe (f' c) s (n+1 :: Int) + probe (Look f') s n = probe (f' s) s n + probe p@(Result _ _) _ n = discard n >> R (p >>=) + probe (Final r) _ _ = R (Final r >>=) + probe _ _ _ = q + + discard 0 = return () + discard n = get >> discard (n-1 :: Int) + +gather :: ReadP (String -> P Char r) a -> ReadP r (String, a) +-- ^ Transforms a parser into one that does the same, but +-- in addition returns the exact characters read. +-- IMPORTANT NOTE: 'gather' gives a runtime error if its first argument +-- is built using any occurrences of readS_to_P. +gather (R m) = + R (\k -> gath id (m (\a -> return (\s -> k (s,a))))) + where + gath l (Get f) = Get (\c -> gath (l.(c:)) (f c)) + gath _ Fail = Fail + gath l (Look f) = Look (gath l . f) + gath l (Result k p) = k (l []) `mplus` gath l p + gath _ (Final _) = error "do not use readS_to_P in gather!" + +-- --------------------------------------------------------------------------- +-- Derived operations + +satisfy :: (Char -> Bool) -> ReadP r Char +-- ^ Consumes and returns the next character, if it satisfies the +-- specified predicate. +satisfy p = do c <- get; if p c then return c else pfail + +char :: Char -> ReadP r Char +-- ^ Parses and returns the specified character. +char c = satisfy (c ==) + +string :: String -> ReadP r String +-- ^ Parses and returns the specified string. +string this = do s <- look; scan this s + where + scan [] _ = return this + scan (x:xs) (y:ys) | x == y = get >> scan xs ys + scan _ _ = pfail + +munch :: (Char -> Bool) -> ReadP r String +-- ^ Parses the first zero or more characters satisfying the predicate. +munch p = + do s <- look + scan s + where + scan (c:cs) | p c = do _ <- get; s <- scan cs; return (c:s) + scan _ = do return "" + +munch1 :: (Char -> Bool) -> ReadP r String +-- ^ Parses the first one or more characters satisfying the predicate. +munch1 p = + do c <- get + if p c then do s <- munch p; return (c:s) + else pfail + +choice :: [ReadP r a] -> ReadP r a +-- ^ Combines all parsers in the specified list. +choice [] = pfail +choice [p] = p +choice (p:ps) = p +++ choice ps + +skipSpaces :: ReadP r () +-- ^ Skips all whitespace. +skipSpaces = + do s <- look + skip s + where + skip (c:s) | isSpace c = do _ <- get; skip s + skip _ = do return () + +skipSpaces1 :: ReadP r () +-- ^ Like 'skipSpaces' but succeeds only if there is at least one +-- whitespace character to skip. +skipSpaces1 = satisfy isSpace >> skipSpaces + +count :: Int -> ReadP r a -> ReadP r [a] +-- ^ @ count n p @ parses @n@ occurrences of @p@ in sequence. A list of +-- results is returned. +count n p = replicateM n p + +between :: ReadP r open -> ReadP r close -> ReadP r a -> ReadP r a +-- ^ @ between open close p @ parses @open@, followed by @p@ and finally +-- @close@. Only the value of @p@ is returned. +between open close p = do _ <- open + x <- p + _ <- close + return x + +option :: a -> ReadP r a -> ReadP r a +-- ^ @option x p@ will either parse @p@ or return @x@ without consuming +-- any input. +option x p = p +++ return x + +optional :: ReadP r a -> ReadP r () +-- ^ @optional p@ optionally parses @p@ and always returns @()@. +optional p = (p >> return ()) +++ return () + +many :: ReadP r a -> ReadP r [a] +-- ^ Parses zero or more occurrences of the given parser. +many p = return [] +++ many1 p + +many1 :: ReadP r a -> ReadP r [a] +-- ^ Parses one or more occurrences of the given parser. +many1 p = liftM2 (:) p (many p) + +skipMany :: ReadP r a -> ReadP r () +-- ^ Like 'many', but discards the result. +skipMany p = many p >> return () + +skipMany1 :: ReadP r a -> ReadP r () +-- ^ Like 'many1', but discards the result. +skipMany1 p = p >> skipMany p + +sepBy :: ReadP r a -> ReadP r sep -> ReadP r [a] +-- ^ @sepBy p sep@ parses zero or more occurrences of @p@, separated by @sep@. +-- Returns a list of values returned by @p@. +sepBy p sep = sepBy1 p sep +++ return [] + +sepBy1 :: ReadP r a -> ReadP r sep -> ReadP r [a] +-- ^ @sepBy1 p sep@ parses one or more occurrences of @p@, separated by @sep@. +-- Returns a list of values returned by @p@. +sepBy1 p sep = liftM2 (:) p (many (sep >> p)) + +endBy :: ReadP r a -> ReadP r sep -> ReadP r [a] +-- ^ @endBy p sep@ parses zero or more occurrences of @p@, separated and ended +-- by @sep@. +endBy p sep = many (do x <- p ; _ <- sep ; return x) + +endBy1 :: ReadP r a -> ReadP r sep -> ReadP r [a] +-- ^ @endBy p sep@ parses one or more occurrences of @p@, separated and ended +-- by @sep@. +endBy1 p sep = many1 (do x <- p ; _ <- sep ; return x) + +chainr :: ReadP r a -> ReadP r (a -> a -> a) -> a -> ReadP r a +-- ^ @chainr p op x@ parses zero or more occurrences of @p@, separated by @op@. +-- Returns a value produced by a /right/ associative application of all +-- functions returned by @op@. If there are no occurrences of @p@, @x@ is +-- returned. +chainr p op x = chainr1 p op +++ return x + +chainl :: ReadP r a -> ReadP r (a -> a -> a) -> a -> ReadP r a +-- ^ @chainl p op x@ parses zero or more occurrences of @p@, separated by @op@. +-- Returns a value produced by a /left/ associative application of all +-- functions returned by @op@. If there are no occurrences of @p@, @x@ is +-- returned. +chainl p op x = chainl1 p op +++ return x + +chainr1 :: ReadP r a -> ReadP r (a -> a -> a) -> ReadP r a +-- ^ Like 'chainr', but parses one or more occurrences of @p@. +chainr1 p op = scan + where scan = p >>= rest + rest x = do f <- op + y <- scan + return (f x y) + +++ return x + +chainl1 :: ReadP r a -> ReadP r (a -> a -> a) -> ReadP r a +-- ^ Like 'chainl', but parses one or more occurrences of @p@. +chainl1 p op = p >>= rest + where rest x = do f <- op + y <- p + rest (f x y) + +++ return x + +manyTill :: ReadP r a -> ReadP [a] end -> ReadP r [a] +-- ^ @manyTill p end@ parses zero or more occurrences of @p@, until @end@ +-- succeeds. Returns a list of values returned by @p@. +manyTill p end = scan + where scan = (end >> return []) <++ (liftM2 (:) p scan) + +-- --------------------------------------------------------------------------- +-- Converting between ReadP and Read + +readP_to_S :: ReadP a a -> ReadS a +-- ^ Converts a parser into a Haskell ReadS-style function. +-- This is the main way in which you can \"run\" a 'ReadP' parser: +-- the expanded type is +-- @ readP_to_S :: ReadP a -> String -> [(a,String)] @ +readP_to_S (R f) = run (f return) + +readS_to_P :: ReadS a -> ReadP r a +-- ^ Converts a Haskell ReadS-style function into a parser. +-- Warning: This introduces local backtracking in the resulting +-- parser, and therefore a possible inefficiency. +readS_to_P r = + R (\k -> Look (\s -> final [bs'' | (a,s') <- r s, bs'' <- run (k a) s'])) + +------------------------------------------------------------------------------- +-- ReadE +------------------------------------------------------------------------------- + +readP_to_E :: (String -> String) -> ReadP a a -> ReadE a +readP_to_E err r = + ReadE $ \txt -> case [ p | (p, s) <- readP_to_S r txt + , all isSpace s ] + of [] -> Left (err txt) + (p:_) -> Right p diff --git a/cabal/cabal-install/src/Distribution/Deprecated/ViewAsFieldDescr.hs b/cabal/cabal-install/src/Distribution/Deprecated/ViewAsFieldDescr.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/src/Distribution/Deprecated/ViewAsFieldDescr.hs @@ -0,0 +1,84 @@ +module Distribution.Deprecated.ViewAsFieldDescr ( + viewAsFieldDescr + ) where + +import Distribution.Client.Compat.Prelude hiding (get) +import Prelude () + +import qualified Data.List.NonEmpty as NE +import Distribution.ReadE (parsecToReadE) +import Distribution.Simple.Command +import Text.PrettyPrint (cat, comma, punctuate, text) +import Text.PrettyPrint as PP (empty) + +import Distribution.Deprecated.ParseUtils (FieldDescr (..), runE, syntaxError) + +-- | to view as a FieldDescr, we sort the list of interfaces (Req > Bool > +-- Choice > Opt) and consider only the first one. +viewAsFieldDescr :: OptionField a -> FieldDescr a +viewAsFieldDescr (OptionField _n []) = + error "Distribution.command.viewAsFieldDescr: unexpected" +viewAsFieldDescr (OptionField n (d:dd)) = FieldDescr n get set + + where + optDescr = head $ NE.sortBy cmp (d:|dd) + + cmp :: OptDescr a -> OptDescr a -> Ordering + ReqArg{} `cmp` ReqArg{} = EQ + ReqArg{} `cmp` _ = GT + BoolOpt{} `cmp` ReqArg{} = LT + BoolOpt{} `cmp` BoolOpt{} = EQ + BoolOpt{} `cmp` _ = GT + ChoiceOpt{} `cmp` ReqArg{} = LT + ChoiceOpt{} `cmp` BoolOpt{} = LT + ChoiceOpt{} `cmp` ChoiceOpt{} = EQ + ChoiceOpt{} `cmp` _ = GT + OptArg{} `cmp` OptArg{} = EQ + OptArg{} `cmp` _ = LT + +-- get :: a -> Doc + get t = case optDescr of + ReqArg _ _ _ _ ppr -> + (cat . punctuate comma . map text . ppr) t + + OptArg _ _ _ _ _ ppr -> + case ppr t of [] -> PP.empty + (Nothing : _) -> text "True" + (Just a : _) -> text a + + ChoiceOpt alts -> + fromMaybe PP.empty $ listToMaybe + [ text lf | (_,(_,lf:_), _,enabled) <- alts, enabled t] + + BoolOpt _ _ _ _ enabled -> (maybe PP.empty pretty . enabled) t + +-- set :: LineNo -> String -> a -> ParseResult a + set line val a = + case optDescr of + ReqArg _ _ _ readE _ -> ($ a) `liftM` runE line n readE val + -- We parse for a single value instead of a + -- list, as one can't really implement + -- parseList :: ReadE a -> ReadE [a] with + -- the current ReadE definition + ChoiceOpt{} -> + case getChoiceByLongFlag optDescr val of + Just f -> return (f a) + _ -> syntaxError line val + + BoolOpt _ _ _ setV _ -> (`setV` a) `liftM` runE line n (parsecToReadE ("" ++) parsec) val + + OptArg _ _ _ readE _ _ -> ($ a) `liftM` runE line n readE val + -- Optional arguments are parsed just like + -- required arguments here; we don't + -- provide a method to set an OptArg field + -- to the default value. + +getChoiceByLongFlag :: OptDescr a -> String -> Maybe (a -> a) +getChoiceByLongFlag (ChoiceOpt alts) val = listToMaybe + [ set | (_,(_sf,lf:_), set, _) <- alts + , lf == val] + +getChoiceByLongFlag _ _ = + error "Distribution.command.getChoiceByLongFlag: expected a choice option" + + diff --git a/cabal/cabal-install/tests/IntegrationTests2.hs b/cabal/cabal-install/tests/IntegrationTests2.hs --- a/cabal/cabal-install/tests/IntegrationTests2.hs +++ b/cabal/cabal-install/tests/IntegrationTests2.hs @@ -8,7 +8,7 @@ -- For the handy instance IsString PackageIdentifier {-# OPTIONS_GHC -fno-warn-orphans #-} -module IntegrationTests2 where +module Main where import Distribution.Client.Compat.Prelude import Prelude () @@ -16,6 +16,7 @@ import Distribution.Client.DistDirLayout import Distribution.Client.ProjectConfig import Distribution.Client.Config (getCabalDir) +import Distribution.Client.HttpUtils import Distribution.Client.TargetSelector hiding (DirActions(..)) import qualified Distribution.Client.TargetSelector as TS (DirActions(..)) import Distribution.Client.ProjectPlanning @@ -43,16 +44,21 @@ import qualified Distribution.Client.CmdTest as CmdTest import qualified Distribution.Client.CmdBench as CmdBench import qualified Distribution.Client.CmdHaddock as CmdHaddock +import qualified Distribution.Client.CmdListBin as CmdListBin import Distribution.Package import Distribution.PackageDescription import Distribution.InstalledPackageInfo (InstalledPackageInfo) import Distribution.Simple.Setup (toFlag, HaddockFlags(..), defaultHaddockFlags) +import Distribution.Client.Setup (globalCommand) import Distribution.Simple.Compiler +import Distribution.Simple.Command +import qualified Distribution.Simple.Flag as Flag import Distribution.System import Distribution.Version import Distribution.ModuleName (ModuleName) import Distribution.Text +import Distribution.Utils.Path import qualified Data.Map as Map import qualified Data.Set as Set @@ -69,6 +75,9 @@ import Data.Tagged (Tagged(..)) import qualified Data.ByteString as BS +import Distribution.Client.GlobalFlags (GlobalFlags, globalNix) +import Distribution.Simple.Flag (Flag (Flag, NoFlag)) +import Data.Maybe (fromJust) #if !MIN_VERSION_directory(1,2,7) removePathForcibly :: FilePath -> IO () @@ -97,16 +106,18 @@ , testCase "proj conf1" (testExceptionInProjectConfig config) ] , testGroup "Target selectors" $ - [ testCaseSteps "valid" testTargetSelectors - , testCase "bad syntax" testTargetSelectorBadSyntax - , testCaseSteps "ambiguous syntax" testTargetSelectorAmbiguous - , testCase "no current pkg" testTargetSelectorNoCurrentPackage - , testCase "no targets" testTargetSelectorNoTargets - , testCase "project empty" testTargetSelectorProjectEmpty + [ testCaseSteps "valid" testTargetSelectors + , testCase "bad syntax" testTargetSelectorBadSyntax + , testCaseSteps "ambiguous syntax" testTargetSelectorAmbiguous + , testCase "no current pkg" testTargetSelectorNoCurrentPackage + , testCase "no targets" testTargetSelectorNoTargets + , testCase "project empty" testTargetSelectorProjectEmpty + , testCase "canonicalized path" testTargetSelectorCanonicalizedPath , testCase "problems (common)" (testTargetProblemsCommon config) , testCaseSteps "problems (build)" (testTargetProblemsBuild config) , testCaseSteps "problems (repl)" (testTargetProblemsRepl config) , testCaseSteps "problems (run)" (testTargetProblemsRun config) + , testCaseSteps "problems (list-bin)" (testTargetProblemsListBin config) , testCaseSteps "problems (test)" (testTargetProblemsTest config) , testCaseSteps "problems (bench)" (testTargetProblemsBench config) , testCaseSteps "problems (haddock)" (testTargetProblemsHaddock config) @@ -131,10 +142,17 @@ , testGroup "Regression tests" $ [ testCase "issue #3324" (testRegressionIssue3324 config) + , testCase "program options scope all" (testProgramOptionsAll config) + , testCase "program options scope local" (testProgramOptionsLocal config) + , testCase "program options scope specific" (testProgramOptionsSpecific config) ] + , testGroup "Flag tests" $ + [ + testCase "Test Nix Flag" testNixFlags, + testCase "Test Ignore Project Flag" testIgnoreProjectFlag + ] ] - testFindProjectRoot :: Assertion testFindProjectRoot = do Left (BadProjectRootExplicitFile file) <- findProjectRoot (Just testdir) @@ -481,7 +499,7 @@ withHsSrcDirs :: Executable -> [FilePath] -> Executable withHsSrcDirs exe srcDirs = - exe { buildInfo = (buildInfo exe) { hsSourceDirs = srcDirs }} + exe { buildInfo = (buildInfo exe) { hsSourceDirs = map unsafeMakeSymbolicPath srcDirs }} mkTargetPackage :: PackageId -> TargetSelector @@ -505,7 +523,7 @@ instance IsString PackageIdentifier where fromString pkgidstr = pkgid - where pkgid = fromMaybe (error $"fromString @PackageIdentifier " ++ show pkgidstr) $ simpleParse pkgidstr + where pkgid = fromMaybe (error $ "fromString @PackageIdentifier " ++ show pkgidstr) $ simpleParse pkgidstr testTargetSelectorNoCurrentPackage :: Assertion @@ -535,7 +553,7 @@ testTargetSelectorNoTargets = do (_, _, _, localPackages, _) <- configureProject testdir config Left errs <- readTargetSelectors localPackages Nothing [] - errs @?= [TargetSelectorNoTargetsInCwd] + errs @?= [TargetSelectorNoTargetsInCwd True] cleanProject testdir where testdir = "targets/complex" @@ -553,6 +571,28 @@ config = mempty +-- | Ensure we don't miss primary package and produce +-- TargetSelectorNoTargetsInCwd error due to symlink or +-- drive capitalisation mismatch when no targets are given +testTargetSelectorCanonicalizedPath :: Assertion +testTargetSelectorCanonicalizedPath = do + (_, _, _, localPackages, _) <- configureProject testdir config + cwd <- getCurrentDirectory + let virtcwd = cwd basedir symlink + -- Check that the symlink is there before running test as on Windows + -- some versions/configurations of git won't pull down/create the symlink + canRunTest <- doesDirectoryExist virtcwd + when canRunTest (do + let dirActions' = (dirActions symlink) { TS.getCurrentDirectory = return virtcwd } + Right ts <- readTargetSelectorsWith dirActions' localPackages Nothing [] + ts @?= [TargetPackage TargetImplicitCwd ["p-0.1"] Nothing]) + cleanProject testdir + where + testdir = "targets/simple" + symlink = "targets/symbolic-link-to-simple" + config = mempty + + testTargetProblemsCommon :: ProjectConfig -> Assertion testTargetProblemsCommon config0 = do (_,elaboratedPlan,_) <- planProject testdir config @@ -837,9 +877,85 @@ [ TargetPackage TargetExplicitNamed ["p-0.1"] (Just BenchKind) ] [ ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark") ] +testTargetProblemsListBin :: ProjectConfig -> (String -> IO ()) -> Assertion +testTargetProblemsListBin config reportSubCase = do + reportSubCase "one-of-each" + do (_,elaboratedPlan,_) <- planProject "targets/one-of-each" config + assertProjectDistinctTargets + elaboratedPlan + CmdListBin.selectPackageTargets + CmdListBin.selectComponentTarget + [ TargetPackage TargetExplicitNamed ["p-0.1"] Nothing + ] + [ ("p-0.1-inplace-p1", CExeName "p1") + ] + reportSubCase "multiple-exes" + assertProjectTargetProblems + "targets/multiple-exes" config + CmdListBin.selectPackageTargets + CmdListBin.selectComponentTarget + [ ( flip CmdListBin.matchesMultipleProblem + [ AvailableTarget "p-0.1" (CExeName "p2") + (TargetBuildable () TargetRequestedByDefault) True + , AvailableTarget "p-0.1" (CExeName "p1") + (TargetBuildable () TargetRequestedByDefault) True + ] + , mkTargetPackage "p-0.1" ) + ] + + reportSubCase "multiple targets" + do (_,elaboratedPlan,_) <- planProject "targets/multiple-exes" config + assertProjectDistinctTargets + elaboratedPlan + CmdListBin.selectPackageTargets + CmdListBin.selectComponentTarget + [ 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") + ] + + reportSubCase "exes-disabled" + assertProjectTargetProblems + "targets/exes-disabled" config + CmdListBin.selectPackageTargets + CmdListBin.selectComponentTarget + [ ( flip TargetProblemNoneEnabled + [ AvailableTarget "p-0.1" (CExeName "p") TargetNotBuildable True + ] + , mkTargetPackage "p-0.1" ) + ] + + reportSubCase "empty-pkg" + assertProjectTargetProblems + "targets/empty-pkg" config + CmdListBin.selectPackageTargets + CmdListBin.selectComponentTarget + [ ( TargetProblemNoTargets, mkTargetPackage "p-0.1" ) + ] + + reportSubCase "lib-only" + assertProjectTargetProblems + "targets/lib-only" config + CmdListBin.selectPackageTargets + CmdListBin.selectComponentTarget + [ (CmdListBin.noComponentsProblem, mkTargetPackage "p-0.1" ) + ] + testTargetProblemsRun :: ProjectConfig -> (String -> IO ()) -> Assertion testTargetProblemsRun config reportSubCase = do + reportSubCase "one-of-each" + do (_,elaboratedPlan,_) <- planProject "targets/one-of-each" config + assertProjectDistinctTargets + elaboratedPlan + CmdRun.selectPackageTargets + CmdRun.selectComponentTarget + [ TargetPackage TargetExplicitNamed ["p-0.1"] Nothing + ] + [ ("p-0.1-inplace-p1", CExeName "p1") + ] reportSubCase "multiple-exes" assertProjectTargetProblems @@ -1438,7 +1554,97 @@ where testdir = "regression/3324" +-- | Test global program options are propagated correctly +-- from ProjectConfig to ElaboratedInstallPlan +testProgramOptionsAll :: ProjectConfig -> Assertion +testProgramOptionsAll config0 = do + -- P is a tarball package, Q is a local dir package that depends on it. + (_, elaboratedPlan, _) <- planProject testdir config + let packages = filterConfiguredPackages $ InstallPlan.toList elaboratedPlan + assertEqual "q" + (Just [ghcFlag]) + (getProgArgs packages "q") + assertEqual "p" + (Just [ghcFlag]) + (getProgArgs packages "p") + where + testdir = "regression/program-options" + programArgs = MapMappend (Map.fromList [("ghc", [ghcFlag])]) + ghcFlag = "-fno-full-laziness" + + -- Insert flag into global config + config = config0 { + projectConfigAllPackages = (projectConfigAllPackages config0) { + packageConfigProgramArgs = programArgs + } + } + +-- | Test local program options are propagated correctly +-- from ProjectConfig to ElaboratedInstallPlan +testProgramOptionsLocal :: ProjectConfig -> Assertion +testProgramOptionsLocal config0 = do + (_, elaboratedPlan, _) <- planProject testdir config + let localPackages = filterConfiguredPackages $ InstallPlan.toList elaboratedPlan + + assertEqual "q" + (Just [ghcFlag]) + (getProgArgs localPackages "q") + assertEqual "p" + Nothing + (getProgArgs localPackages "p") + where + testdir = "regression/program-options" + programArgs = MapMappend (Map.fromList [("ghc", [ghcFlag])]) + ghcFlag = "-fno-full-laziness" + + -- Insert flag into local config + config = config0 { + projectConfigLocalPackages = (projectConfigLocalPackages config0) { + packageConfigProgramArgs = programArgs + } + } + +-- | Test package specific program options are propagated correctly +-- from ProjectConfig to ElaboratedInstallPlan +testProgramOptionsSpecific :: ProjectConfig -> Assertion +testProgramOptionsSpecific config0 = do + (_, elaboratedPlan, _) <- planProject testdir config + let packages = filterConfiguredPackages $ InstallPlan.toList elaboratedPlan + + assertEqual "q" + (Nothing) + (getProgArgs packages "q") + assertEqual "p" + (Just [ghcFlag]) + (getProgArgs packages "p") + where + testdir = "regression/program-options" + programArgs = MapMappend (Map.fromList [("ghc", [ghcFlag])]) + ghcFlag = "-fno-full-laziness" + + -- Insert flag into package "p" config + config = config0 { + projectConfigSpecificPackage = MapMappend (Map.fromList [(mkPackageName "p", configArgs)]) + } + configArgs = mempty { + packageConfigProgramArgs = programArgs + } + +filterConfiguredPackages :: [ElaboratedPlanPackage] -> [ElaboratedConfiguredPackage] +filterConfiguredPackages [] = [] +filterConfiguredPackages (InstallPlan.PreExisting _ : pkgs) = filterConfiguredPackages pkgs +filterConfiguredPackages (InstallPlan.Installed elab : pkgs) = elab : filterConfiguredPackages pkgs +filterConfiguredPackages (InstallPlan.Configured elab : pkgs) = elab : filterConfiguredPackages pkgs + +getProgArgs :: [ElaboratedConfiguredPackage] -> String -> Maybe [String] +getProgArgs [] _ = Nothing +getProgArgs (elab : pkgs) name + | pkgName (elabPkgSourceId elab) == mkPackageName name + = Map.lookup "ghc" (elabProgramArgs elab) + | otherwise + = getProgArgs pkgs name + --------------------------------- -- Test utils to plan and build -- @@ -1487,8 +1693,11 @@ -- ended in an exception (as we leave the files to help with debugging). cleanProject testdir + httpTransport <- configureTransport verbosity [] Nothing + (projectConfig, localPackages) <- rebuildProjectConfig verbosity + httpTransport distDirLayout cliConfig @@ -1509,8 +1718,8 @@ planProject :: FilePath -> ProjectConfig -> IO PlanDetails planProject testdir cliConfig = do - projDetails@ - (distDirLayout, + projDetails@( + distDirLayout, cabalDirLayout, projectConfig, localPackages, @@ -1732,3 +1941,41 @@ hPutStrLn stderr $ "Trying " ++ show n ++ " after " ++ show e threadDelay 10000 go (n - 1) + +testNixFlags :: Assertion +testNixFlags = do + let gc = globalCommand [] + -- changing from the v1 to v2 build command does not change whether the "--enable-nix" flag + -- sets the globalNix param of the GlobalFlags type to True even though the v2 command doesn't use it + let nixEnabledFlags = getFlags gc . commandParseArgs gc True $ ["--enable-nix", "build"] + let nixDisabledFlags = getFlags gc . commandParseArgs gc True $ ["--disable-nix", "build"] + let nixDefaultFlags = getFlags gc . commandParseArgs gc True $ ["build"] + True @=? isJust nixDefaultFlags + True @=? isJust nixEnabledFlags + True @=? isJust nixDisabledFlags + Just True @=? (fromFlag . globalNix . fromJust $ nixEnabledFlags) + Just False @=? (fromFlag . globalNix . fromJust $ nixDisabledFlags) + Nothing @=? (fromFlag . globalNix . fromJust $ nixDefaultFlags) + where + fromFlag :: Flag Bool -> Maybe Bool + fromFlag (Flag x) = Just x + fromFlag NoFlag = Nothing + getFlags :: CommandUI GlobalFlags -> CommandParse (GlobalFlags -> GlobalFlags, [String]) -> Maybe GlobalFlags + getFlags cui (CommandReadyToGo (mkflags, _)) = Just . mkflags . commandDefaultFlags $ cui + getFlags _ _ = Nothing + +testIgnoreProjectFlag :: Assertion +testIgnoreProjectFlag = do + -- Coverage flag should be false globally by default (~/.cabal folder) + (_, _, prjConfigGlobal, _, _) <- configureProject testdir ignoreSetConfig + let globalCoverageFlag = packageConfigCoverage . projectConfigLocalPackages $ prjConfigGlobal + False @=? Flag.fromFlagOrDefault False globalCoverageFlag + -- It is set to true in the cabal.project file + (_, _, prjConfigLocal, _, _) <- configureProject testdir emptyConfig + let localCoverageFlag = packageConfigCoverage . projectConfigLocalPackages $ prjConfigLocal + True @=? Flag.fromFlagOrDefault False localCoverageFlag + where + testdir = "build/ignore-project" + emptyConfig = mempty + ignoreSetConfig :: ProjectConfig + ignoreSetConfig = mempty { projectConfigShared = mempty { projectConfigIgnoreProject = Flag True } } diff --git a/cabal/cabal-install/tests/IntegrationTests2/build/ignore-project/A.hs b/cabal/cabal-install/tests/IntegrationTests2/build/ignore-project/A.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/IntegrationTests2/build/ignore-project/A.hs @@ -0,0 +1,4 @@ +module A where + +a :: Int +a = 42 diff --git a/cabal/cabal-install/tests/IntegrationTests2/build/ignore-project/Setup.hs b/cabal/cabal-install/tests/IntegrationTests2/build/ignore-project/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/IntegrationTests2/build/ignore-project/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cabal/cabal-install/tests/IntegrationTests2/build/ignore-project/a.cabal b/cabal/cabal-install/tests/IntegrationTests2/build/ignore-project/a.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/IntegrationTests2/build/ignore-project/a.cabal @@ -0,0 +1,10 @@ +name: a +version: 0.1 +build-type: Simple +cabal-version: >= 1.10 + +library + exposed-modules: A + build-depends: base + default-language: Haskell2010 + profiling: true diff --git a/cabal/cabal-install/tests/IntegrationTests2/build/ignore-project/cabal.project b/cabal/cabal-install/tests/IntegrationTests2/build/ignore-project/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/IntegrationTests2/build/ignore-project/cabal.project @@ -0,0 +1,3 @@ +packages: . + +coverage: true diff --git a/cabal/cabal-install/tests/IntegrationTests2/regression/program-options/cabal.project b/cabal/cabal-install/tests/IntegrationTests2/regression/program-options/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/IntegrationTests2/regression/program-options/cabal.project @@ -0,0 +1,2 @@ +packages: p-0.1.tar.gz + q/ diff --git a/cabal/cabal-install/tests/IntegrationTests2/regression/program-options/p-0.1.tar.gz b/cabal/cabal-install/tests/IntegrationTests2/regression/program-options/p-0.1.tar.gz new file mode 100644 Binary files /dev/null and b/cabal/cabal-install/tests/IntegrationTests2/regression/program-options/p-0.1.tar.gz differ diff --git a/cabal/cabal-install/tests/IntegrationTests2/regression/program-options/q/Q.hs b/cabal/cabal-install/tests/IntegrationTests2/regression/program-options/q/Q.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/IntegrationTests2/regression/program-options/q/Q.hs @@ -0,0 +1,5 @@ +module Q where + +import P + +q = p ++ " world" diff --git a/cabal/cabal-install/tests/IntegrationTests2/regression/program-options/q/q.cabal b/cabal/cabal-install/tests/IntegrationTests2/regression/program-options/q/q.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/IntegrationTests2/regression/program-options/q/q.cabal @@ -0,0 +1,8 @@ +name: q +version: 0.1 +build-type: Simple +cabal-version: >= 1.2 + +library + exposed-modules: Q + build-depends: base, p diff --git a/cabal/cabal-install/tests/IntegrationTests2/targets/benchmarks-disabled/p.cabal b/cabal/cabal-install/tests/IntegrationTests2/targets/benchmarks-disabled/p.cabal --- a/cabal/cabal-install/tests/IntegrationTests2/targets/benchmarks-disabled/p.cabal +++ b/cabal/cabal-install/tests/IntegrationTests2/targets/benchmarks-disabled/p.cabal @@ -1,7 +1,7 @@ +cabal-version: 3.8 name: p version: 0.1 build-type: Simple -cabal-version: >= 1.10 benchmark solver-disabled type: exitcode-stdio-1.0 @@ -9,7 +9,6 @@ build-depends: a-package-that-does-not-exist benchmark user-disabled - type: exitcode-stdio-1.0 main-is: Test.hs build-depends: base diff --git a/cabal/cabal-install/tests/IntegrationTests2/targets/multiple-tests/p.cabal b/cabal/cabal-install/tests/IntegrationTests2/targets/multiple-tests/p.cabal --- a/cabal/cabal-install/tests/IntegrationTests2/targets/multiple-tests/p.cabal +++ b/cabal/cabal-install/tests/IntegrationTests2/targets/multiple-tests/p.cabal @@ -1,10 +1,9 @@ +cabal-version: 3.8 name: p version: 0.1 build-type: Simple -cabal-version: >= 1.10 test-suite p1 - type: exitcode-stdio-1.0 main-is: P1.hs build-depends: base diff --git a/cabal/cabal-install/tests/IntegrationTests2/targets/one-of-each/cabal.project b/cabal/cabal-install/tests/IntegrationTests2/targets/one-of-each/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/IntegrationTests2/targets/one-of-each/cabal.project @@ -0,0 +1,1 @@ +packages: ./ diff --git a/cabal/cabal-install/tests/IntegrationTests2/targets/one-of-each/p.cabal b/cabal/cabal-install/tests/IntegrationTests2/targets/one-of-each/p.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/IntegrationTests2/targets/one-of-each/p.cabal @@ -0,0 +1,26 @@ +name: p +version: 0.1 +build-type: Simple +cabal-version: >= 1.10 + +executable p1 + main-is: P1.hs + build-depends: base + +benchmark p2 + type: exitcode-stdio-1.0 + main-is: P2.hs + build-depends: base + +test-suite p3 + type: exitcode-stdio-1.0 + main-is: P3.hs + build-depends: base + +library p4 + exposed-modules: P4 + build-depends: base + +foreign-library libp + type: native-shared + other-modules: FLib diff --git a/cabal/cabal-install/tests/IntegrationTests2/targets/variety/p.cabal b/cabal/cabal-install/tests/IntegrationTests2/targets/variety/p.cabal --- a/cabal/cabal-install/tests/IntegrationTests2/targets/variety/p.cabal +++ b/cabal/cabal-install/tests/IntegrationTests2/targets/variety/p.cabal @@ -1,7 +1,7 @@ +cabal-version: 3.8 name: p version: 0.1 build-type: Simple -cabal-version: >= 1.10 library exposed-modules: P @@ -16,7 +16,6 @@ other-modules: AModule test-suite a-testsuite - type: exitcode-stdio-1.0 main-is: Test.hs other-modules: AModule diff --git a/cabal/cabal-install/tests/LongTests.hs b/cabal/cabal-install/tests/LongTests.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/LongTests.hs @@ -0,0 +1,46 @@ +module Main (main) where + + +import Test.Tasty + +import Distribution.Simple.Utils +import Distribution.Verbosity +import Distribution.Compat.Time + +import qualified UnitTests.Distribution.Client.FileMonitor +import qualified UnitTests.Distribution.Client.VCS +import qualified UnitTests.Distribution.Solver.Modular.QuickCheck +import qualified UnitTests.Distribution.Client.Described +import UnitTests.Options + + +main :: IO () +main = do + (mtimeChange, mtimeChange') <- calibrateMtimeChangeDelay + let toMillis :: Int -> Double + toMillis x = fromIntegral x / 1000.0 + notice normal $ "File modification time resolution calibration completed, " + ++ "maximum delay observed: " + ++ (show . toMillis $ mtimeChange ) ++ " ms. " + ++ "Will be using delay of " ++ (show . toMillis $ mtimeChange') + ++ " for test runs." + defaultMainWithIngredients + (includingOptions extraOptions : defaultIngredients) + (tests mtimeChange') + + +tests :: Int -> TestTree +tests mtimeChangeCalibrated = + askOption $ \(OptionMtimeChangeDelay mtimeChangeProvided) -> + let mtimeChange = if mtimeChangeProvided /= 0 + then mtimeChangeProvided + else mtimeChangeCalibrated + in testGroup "Long-running tests" + [ testGroup "Solver QuickCheck" + UnitTests.Distribution.Solver.Modular.QuickCheck.tests + , testGroup "UnitTests.Distribution.Client.VCS" $ + UnitTests.Distribution.Client.VCS.tests mtimeChange + , testGroup "UnitTests.Distribution.Client.FileMonitor" $ + UnitTests.Distribution.Client.FileMonitor.tests mtimeChange + , UnitTests.Distribution.Client.Described.tests + ] diff --git a/cabal/cabal-install/tests/MemoryUsageTests.hs b/cabal/cabal-install/tests/MemoryUsageTests.hs --- a/cabal/cabal-install/tests/MemoryUsageTests.hs +++ b/cabal/cabal-install/tests/MemoryUsageTests.hs @@ -1,4 +1,4 @@ -module MemoryUsageTests where +module Main where import Test.Tasty diff --git a/cabal/cabal-install/tests/SolverQuickCheck.hs b/cabal/cabal-install/tests/SolverQuickCheck.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/SolverQuickCheck.hs +++ /dev/null @@ -1,16 +0,0 @@ -module SolverQuickCheck where - -import Test.Tasty - -import qualified UnitTests.Distribution.Solver.Modular.QuickCheck - - -tests :: TestTree -tests = - testGroup "Solver QuickCheck" - [ testGroup "UnitTests.Distribution.Solver.Modular.QuickCheck" - UnitTests.Distribution.Solver.Modular.QuickCheck.tests - ] - -main :: IO () -main = defaultMain tests diff --git a/cabal/cabal-install/tests/UnitTests.hs b/cabal/cabal-install/tests/UnitTests.hs --- a/cabal/cabal-install/tests/UnitTests.hs +++ b/cabal/cabal-install/tests/UnitTests.hs @@ -1,96 +1,77 @@ -{-# LANGUAGE ScopedTypeVariables #-} +module Main (main) where -module UnitTests where import Test.Tasty -import Distribution.Simple.Utils -import Distribution.Verbosity - -import Distribution.Compat.Time - -import qualified UnitTests.Distribution.Solver.Modular.Builder -import qualified UnitTests.Distribution.Solver.Modular.WeightedPSQ -import qualified UnitTests.Distribution.Solver.Modular.Solver -import qualified UnitTests.Distribution.Solver.Modular.RetryLog import qualified UnitTests.Distribution.Client.BuildReport -import qualified UnitTests.Distribution.Client.Described -import qualified UnitTests.Distribution.Client.FileMonitor +import qualified UnitTests.Distribution.Client.Configure +import qualified UnitTests.Distribution.Client.FetchUtils +import qualified UnitTests.Distribution.Client.Get import qualified UnitTests.Distribution.Client.Glob import qualified UnitTests.Distribution.Client.GZipUtils -import qualified UnitTests.Distribution.Client.Init.FileCreators +import qualified UnitTests.Distribution.Client.IndexUtils +import qualified UnitTests.Distribution.Client.IndexUtils.Timestamp +import qualified UnitTests.Distribution.Client.Init +import qualified UnitTests.Distribution.Client.InstallPlan +import qualified UnitTests.Distribution.Client.JobControl +import qualified UnitTests.Distribution.Client.ProjectConfig +import qualified UnitTests.Distribution.Client.ProjectPlanning import qualified UnitTests.Distribution.Client.Store import qualified UnitTests.Distribution.Client.Tar import qualified UnitTests.Distribution.Client.Targets import qualified UnitTests.Distribution.Client.UserConfig -import qualified UnitTests.Distribution.Client.ProjectConfig -import qualified UnitTests.Distribution.Client.JobControl -import qualified UnitTests.Distribution.Client.IndexUtils.Timestamp -import qualified UnitTests.Distribution.Client.InstallPlan -import qualified UnitTests.Distribution.Client.VCS -import qualified UnitTests.Distribution.Client.Get - -import UnitTests.Options - - -tests :: Int -> TestTree -tests mtimeChangeCalibrated = - askOption $ \(OptionMtimeChangeDelay mtimeChangeProvided) -> - let mtimeChange = if mtimeChangeProvided /= 0 - then mtimeChangeProvided - else mtimeChangeCalibrated - in - testGroup "Unit Tests" - [ testGroup "UnitTests.Distribution.Solver.Modular.Builder" - UnitTests.Distribution.Solver.Modular.Builder.tests - , testGroup "UnitTests.Distribution.Solver.Modular.WeightedPSQ" - UnitTests.Distribution.Solver.Modular.WeightedPSQ.tests - , testGroup "UnitTests.Distribution.Solver.Modular.Solver" - UnitTests.Distribution.Solver.Modular.Solver.tests - , testGroup "UnitTests.Distribution.Solver.Modular.RetryLog" - UnitTests.Distribution.Solver.Modular.RetryLog.tests - , testGroup "UnitTests.Distribution.Client.FileMonitor" $ - UnitTests.Distribution.Client.FileMonitor.tests mtimeChange - , testGroup "UnitTests.Distribution.Client.Glob" - UnitTests.Distribution.Client.Glob.tests - , testGroup "Distribution.Client.GZipUtils" - UnitTests.Distribution.Client.GZipUtils.tests - , testGroup "Distribution.Client.Init.FileCreators" - UnitTests.Distribution.Client.Init.FileCreators.tests - , testGroup "Distribution.Client.Store" - UnitTests.Distribution.Client.Store.tests - , testGroup "Distribution.Client.Tar" - UnitTests.Distribution.Client.Tar.tests - , testGroup "Distribution.Client.Targets" - UnitTests.Distribution.Client.Targets.tests - , testGroup "UnitTests.Distribution.Client.UserConfig" - UnitTests.Distribution.Client.UserConfig.tests - , testGroup "UnitTests.Distribution.Client.ProjectConfig" - UnitTests.Distribution.Client.ProjectConfig.tests - , testGroup "UnitTests.Distribution.Client.JobControl" - UnitTests.Distribution.Client.JobControl.tests - , testGroup "UnitTests.Distribution.Client.IndexUtils.Timestamp" - UnitTests.Distribution.Client.IndexUtils.Timestamp.tests - , testGroup "UnitTests.Distribution.Client.InstallPlan" - UnitTests.Distribution.Client.InstallPlan.tests - , testGroup "UnitTests.Distribution.Client.VCS" $ - UnitTests.Distribution.Client.VCS.tests mtimeChange - , testGroup "UnitTests.Distribution.Client.Get" - UnitTests.Distribution.Client.Get.tests - , UnitTests.Distribution.Client.Described.tests - , UnitTests.Distribution.Client.BuildReport.tests - ] +import qualified UnitTests.Distribution.Solver.Modular.Builder +import qualified UnitTests.Distribution.Solver.Modular.RetryLog +import qualified UnitTests.Distribution.Solver.Modular.Solver +import qualified UnitTests.Distribution.Solver.Modular.WeightedPSQ +import qualified UnitTests.Distribution.Solver.Types.OptionalStanza main :: IO () main = do - (mtimeChange, mtimeChange') <- calibrateMtimeChangeDelay - let toMillis :: Int -> Double - toMillis x = fromIntegral x / 1000.0 - notice normal $ "File modification time resolution calibration completed, " - ++ "maximum delay observed: " - ++ (show . toMillis $ mtimeChange ) ++ " ms. " - ++ "Will be using delay of " ++ (show . toMillis $ mtimeChange') - ++ " for test runs." - defaultMainWithIngredients - (includingOptions extraOptions : defaultIngredients) - (tests mtimeChange') + initTests <- UnitTests.Distribution.Client.Init.tests + defaultMain $ testGroup "Unit Tests" + [ testGroup "UnitTests.Distribution.Client.BuildReport" + UnitTests.Distribution.Client.BuildReport.tests + , testGroup "UnitTests.Distribution.Client.Configure" + UnitTests.Distribution.Client.Configure.tests + , testGroup "UnitTests.Distribution.Client.FetchUtils" + UnitTests.Distribution.Client.FetchUtils.tests + , testGroup "UnitTests.Distribution.Client.Get" + UnitTests.Distribution.Client.Get.tests + , testGroup "UnitTests.Distribution.Client.Glob" + UnitTests.Distribution.Client.Glob.tests + , testGroup "Distribution.Client.GZipUtils" + UnitTests.Distribution.Client.GZipUtils.tests + , testGroup "UnitTests.Distribution.Client.IndexUtils" + UnitTests.Distribution.Client.IndexUtils.tests + , testGroup "UnitTests.Distribution.Client.IndexUtils.Timestamp" + UnitTests.Distribution.Client.IndexUtils.Timestamp.tests + , testGroup "Distribution.Client.Init" + initTests + , testGroup "UnitTests.Distribution.Client.InstallPlan" + UnitTests.Distribution.Client.InstallPlan.tests + , testGroup "UnitTests.Distribution.Client.JobControl" + UnitTests.Distribution.Client.JobControl.tests + , testGroup "UnitTests.Distribution.Client.ProjectConfig" + UnitTests.Distribution.Client.ProjectConfig.tests + , testGroup "UnitTests.Distribution.Client.ProjectPlanning" + UnitTests.Distribution.Client.ProjectPlanning.tests + , testGroup "Distribution.Client.Store" + UnitTests.Distribution.Client.Store.tests + , testGroup "Distribution.Client.Tar" + UnitTests.Distribution.Client.Tar.tests + , testGroup "Distribution.Client.Targets" + UnitTests.Distribution.Client.Targets.tests + , testGroup "UnitTests.Distribution.Client.UserConfig" + UnitTests.Distribution.Client.UserConfig.tests + , testGroup "UnitTests.Distribution.Solver.Modular.Builder" + UnitTests.Distribution.Solver.Modular.Builder.tests + , testGroup "UnitTests.Distribution.Solver.Modular.RetryLog" + UnitTests.Distribution.Solver.Modular.RetryLog.tests + , testGroup "UnitTests.Distribution.Solver.Modular.Solver" + UnitTests.Distribution.Solver.Modular.Solver.tests + , testGroup "UnitTests.Distribution.Solver.Modular.WeightedPSQ" + UnitTests.Distribution.Solver.Modular.WeightedPSQ.tests + , testGroup "UnitTests.Distribution.Solver.Types.OptionalStanza" + UnitTests.Distribution.Solver.Types.OptionalStanza.tests + ] diff --git a/cabal/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs b/cabal/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs --- a/cabal/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs +++ b/cabal/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs @@ -26,7 +26,7 @@ import Data.List ((\\)) import Distribution.Simple.Setup -import Distribution.Types.Flag (mkFlagAssignment) +import Distribution.Types.Flag (mkFlagAssignment) import Distribution.Client.BuildReports.Types (BuildReport, InstallOutcome, Outcome, ReportLevel (..)) import Distribution.Client.CmdInstall.ClientInstallFlags (InstallMethod) @@ -34,12 +34,11 @@ import Distribution.Client.IndexUtils.ActiveRepos (ActiveRepoEntry (..), ActiveRepos (..), CombineStrategy (..)) import Distribution.Client.IndexUtils.IndexState (RepoIndexState (..), TotalIndexState, makeTotalIndexState) import Distribution.Client.IndexUtils.Timestamp (Timestamp, epochTimeToTimestamp) -import Distribution.Client.Types.OverwritePolicy (OverwritePolicy) import Distribution.Client.Targets import Distribution.Client.Types (RepoName (..), WriteGhcEnvironmentFilesPolicy) import Distribution.Client.Types.AllowNewer -import Distribution.Client.World (WorldPkgInfo (..)) -import Distribution.Solver.Types.OptionalStanza (OptionalStanza (..)) +import Distribution.Client.Types.OverwritePolicy (OverwritePolicy) +import Distribution.Solver.Types.OptionalStanza (OptionalStanza (..), OptionalStanzaMap, OptionalStanzaSet, optStanzaSetFromList, optStanzaTabulate) import Distribution.Solver.Types.PackageConstraint (PackageProperty (..)) import Data.Coerce (Coercible, coerce) @@ -135,6 +134,7 @@ arbitrary = ShortToken <$> (shortListOf1 5 (choose ('#', '~')) + `suchThat` (all (`notElem` "{}")) `suchThat` (not . ("[]" `isPrefixOf`))) --TODO: [code cleanup] need to replace parseHaskellString impl to stop -- accepting Haskell list syntax [], ['a'] etc, just allow String syntax. @@ -183,7 +183,8 @@ arbitraryFlag = liftArbitrary instance Arbitrary RepoName where - arbitrary = RepoName <$> mk where + -- TODO: rename refinement? + arbitrary = RepoName <$> (mk `suchThat` \x -> not $ "--" `isPrefixOf` x) where mk = (:) <$> lead <*> rest lead = elements [ c | c <- [ '\NUL' .. '\255' ], isAlpha c || c `elem` "_-."] @@ -251,14 +252,6 @@ shrink = genericShrink ------------------------------------------------------------------------------- --- WorldPkgInfo -------------------------------------------------------------------------------- - -instance Arbitrary WorldPkgInfo where - arbitrary = WorldPkgInfo <$> arbitrary <*> arbitrary - shrink = genericShrink - -------------------------------------------------------------------------------- -- UserConstraint ------------------------------------------------------------------------------- @@ -289,6 +282,17 @@ instance Arbitrary OptionalStanza where arbitrary = elements [minBound..maxBound] + +instance Arbitrary OptionalStanzaSet where + arbitrary = fmap optStanzaSetFromList arbitrary + +instance Arbitrary a => Arbitrary (OptionalStanzaMap a) where + arbitrary = do + x1 <- arbitrary + x2 <- arbitrary + return $ optStanzaTabulate $ \x -> case x of + TestStanzas -> x1 + BenchStanzas -> x2 ------------------------------------------------------------------------------- -- BuildReport diff --git a/cabal/cabal-install/tests/UnitTests/Distribution/Client/BuildReport.hs b/cabal/cabal-install/tests/UnitTests/Distribution/Client/BuildReport.hs --- a/cabal/cabal-install/tests/UnitTests/Distribution/Client/BuildReport.hs +++ b/cabal/cabal-install/tests/UnitTests/Distribution/Client/BuildReport.hs @@ -9,7 +9,7 @@ import Data.TreeDiff.QuickCheck (ediffEq) import Test.QuickCheck (Property, counterexample) -import Test.Tasty (TestTree, testGroup) +import Test.Tasty (TestTree) import Test.Tasty.QuickCheck (testProperty) import Distribution.Client.BuildReports.Anonymous (BuildReport, parseBuildReport, showBuildReport) @@ -18,8 +18,8 @@ -- instances import Test.QuickCheck.Instances.Cabal () -tests :: TestTree -tests = testGroup "BuildReport" +tests :: [TestTree] +tests = [ testProperty "test" roundtrip ] diff --git a/cabal/cabal-install/tests/UnitTests/Distribution/Client/Configure.hs b/cabal/cabal-install/tests/UnitTests/Distribution/Client/Configure.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/UnitTests/Distribution/Client/Configure.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE RecordWildCards #-} +module UnitTests.Distribution.Client.Configure (tests) where + +import Distribution.Client.CmdConfigure + +import Test.Tasty +import Test.Tasty.HUnit +import Control.Monad +import qualified Data.Map as Map +import System.Directory +import System.FilePath +import Distribution.Verbosity +import Distribution.Client.Setup +import Distribution.Client.NixStyleOptions +import Distribution.Client.ProjectConfig.Types +import Distribution.Client.ProjectFlags +import Distribution.Simple +import Distribution.Simple.Flag + +tests :: [TestTree] +tests = + [ configureTests + ] + +configureTests :: TestTree +configureTests = testGroup "Configure tests" + [ testCase "New config" $ do + let flags = (defaultNixStyleFlags ()) + { configFlags = mempty + { configOptimization = Flag MaximumOptimisation + , configVerbosity = Flag silent + } + } + projConfig <- configureAction' flags [] defaultGlobalFlags + + Flag MaximumOptimisation @=? + (packageConfigOptimization . projectConfigLocalPackages $ snd projConfig) + + , testCase "Replacement + new config" $ do + let flags = (defaultNixStyleFlags ()) + { configExFlags = mempty + { configAppend = Flag True } + , configFlags = mempty + { configOptimization = Flag NoOptimisation + , configVerbosity = Flag silent + } + , projectFlags = mempty + { flagProjectFileName = Flag projectFile } + } + (_, ProjectConfig {..}) <- configureAction' flags [] defaultGlobalFlags + + Flag NoOptimisation @=? packageConfigOptimization projectConfigLocalPackages + Flag silent @=? projectConfigVerbosity projectConfigBuildOnly + + , testCase "Old + new config" $ do + let flags = (defaultNixStyleFlags ()) + { configExFlags = mempty + { configAppend = Flag True } + , configFlags = mempty + { configVerbosity = Flag silent } + , projectFlags = mempty + { flagProjectFileName = Flag projectFile } + } + (_, ProjectConfig {..}) <- configureAction' flags [] defaultGlobalFlags + + Flag MaximumOptimisation @=? packageConfigOptimization projectConfigLocalPackages + Flag silent @=? projectConfigVerbosity projectConfigBuildOnly + + , testCase "Old + new config, no appending" $ do + let flags = (defaultNixStyleFlags ()) + { configFlags = mempty + { configVerbosity = Flag silent } + , projectFlags = mempty + { flagProjectFileName = Flag projectFile } + } + (_, ProjectConfig {..}) <- configureAction' flags [] defaultGlobalFlags + + NoFlag @=? packageConfigOptimization projectConfigLocalPackages + Flag silent @=? projectConfigVerbosity projectConfigBuildOnly + + , testCase "Old + new config, backup check" $ do + let flags = (defaultNixStyleFlags ()) + { configFlags = mempty + { configVerbosity = Flag silent } + , projectFlags = mempty + { flagProjectFileName = Flag projectFile } + } + backup = projectFile <.> "local~" + + exists <- doesFileExist backup + when exists $ + removeFile backup + + _ <- configureAction' flags [] defaultGlobalFlags + + doesFileExist backup >>= + assertBool ("No file found, expected: " ++ backup) + + , testCase "Local program options" $ do + let ghcFlags = ["-fno-full-laziness"] + flags = (defaultNixStyleFlags ()) + { configFlags = mempty + { configVerbosity = Flag silent + , configProgramArgs = [("ghc", ghcFlags)] + } + , projectFlags = mempty + { flagProjectFileName = Flag projectFile } + } + (_, ProjectConfig {..}) <- configureAction' flags [] defaultGlobalFlags + + + assertEqual "global" + Nothing + (Map.lookup "ghc" (getMapMappend (packageConfigProgramArgs projectConfigAllPackages))) + + assertEqual "local" + (Just ghcFlags) + (Map.lookup "ghc" (getMapMappend (packageConfigProgramArgs projectConfigLocalPackages))) + ] + +projectFile :: FilePath +projectFile = "tests" "fixtures" "configure" "cabal.project" diff --git a/cabal/cabal-install/tests/UnitTests/Distribution/Client/Described.hs b/cabal/cabal-install/tests/UnitTests/Distribution/Client/Described.hs --- a/cabal/cabal-install/tests/UnitTests/Distribution/Client/Described.hs +++ b/cabal/cabal-install/tests/UnitTests/Distribution/Client/Described.hs @@ -18,7 +18,6 @@ import Distribution.Client.Targets (UserConstraint) import Distribution.Client.Types (RepoName) import Distribution.Client.Types.AllowNewer (RelaxDepSubject, RelaxDeps, RelaxedDep) -import Distribution.Client.World (WorldPkgInfo) tests :: TestTree tests = testGroup "Described" @@ -31,7 +30,6 @@ , testDescribed (Proxy :: Proxy RelaxedDep) , testDescribed (Proxy :: Proxy RelaxDeps) , testDescribed (Proxy :: Proxy UserConstraint) - , testDescribed (Proxy :: Proxy WorldPkgInfo) , testDescribed (Proxy :: Proxy InstallOutcome) , testDescribed (Proxy :: Proxy Outcome) ] diff --git a/cabal/cabal-install/tests/UnitTests/Distribution/Client/DescribedInstances.hs b/cabal/cabal-install/tests/UnitTests/Distribution/Client/DescribedInstances.hs --- a/cabal/cabal-install/tests/UnitTests/Distribution/Client/DescribedInstances.hs +++ b/cabal/cabal-install/tests/UnitTests/Distribution/Client/DescribedInstances.hs @@ -7,7 +7,6 @@ import Distribution.Described import Data.List ((\\)) -import Distribution.Types.Dependency (Dependency) import Distribution.Types.PackageId (PackageIdentifier) import Distribution.Types.PackageName (PackageName) import Distribution.Types.VersionRange (VersionRange) @@ -19,7 +18,6 @@ import Distribution.Client.Targets (UserConstraint) import Distribution.Client.Types (RepoName) import Distribution.Client.Types.AllowNewer (RelaxDepSubject, RelaxDeps, RelaxedDep) -import Distribution.Client.World (WorldPkgInfo) import Distribution.Client.Glob (FilePathGlob) ------------------------------------------------------------------------------- @@ -80,15 +78,6 @@ escape = fromString "\\" <> reChars "*{}," ------------------------------------------------------------------------------- --- WorldPkgInfo -------------------------------------------------------------------------------- - -instance Described WorldPkgInfo where - describe _ = - describe (Proxy :: Proxy Dependency) - <> REOpt (RESpaces1 <> "--flags=\"" <> describeFlagAssignmentNonEmpty <> "\"") - -------------------------------------------------------------------------------- -- AllowNewer ------------------------------------------------------------------------------- @@ -139,7 +128,8 @@ instance Described CombineStrategy where describe _ = REUnion - [ "merge" + [ "skip" + , "merge" , "override" ] diff --git a/cabal/cabal-install/tests/UnitTests/Distribution/Client/FetchUtils.hs b/cabal/cabal-install/tests/UnitTests/Distribution/Client/FetchUtils.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/UnitTests/Distribution/Client/FetchUtils.hs @@ -0,0 +1,209 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module UnitTests.Distribution.Client.FetchUtils + ( tests, + ) +where + +import Control.Concurrent (threadDelay) +import Control.Exception +import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime) +import Distribution.Client.FetchUtils +import Distribution.Client.GlobalFlags (RepoContext (..)) +import Distribution.Client.HttpUtils (HttpCode, HttpTransport (..)) +import Distribution.Client.Types.PackageLocation (PackageLocation (..), ResolvedPkgLoc) +import Distribution.Client.Types.Repo (Repo (..), emptyRemoteRepo) +import Distribution.Client.Types.RepoName (RepoName (..)) +import Distribution.Types.PackageId (PackageIdentifier (..)) +import Distribution.Types.PackageName (mkPackageName) +import qualified Distribution.Verbosity as Verbosity +import Distribution.Version (mkVersion) +import Network.URI (URI, uriPath) +import Test.Tasty +import Test.Tasty.HUnit +import UnitTests.TempTestDir (withTestDir) + +tests :: [TestTree] +tests = + [ testGroup + "asyncFetchPackages" + [ testCase "handles an empty package list" testEmpty, + testCase "passes an unpacked local package through" testPassLocalPackage, + testCase "handles http" testHttp, + testCase "aborts on interrupt in GET" $ testGetInterrupt, + testCase "aborts on other exception in GET" $ testGetException, + testCase "aborts on interrupt in GET (uncollected download)" $ testUncollectedInterrupt, + testCase "continues on other exception in GET (uncollected download)" $ testUncollectedException + ] + ] + +verbosity :: Verbosity.Verbosity +verbosity = Verbosity.silent + +-- | An interval that we use to assert that something happens "immediately". +-- Must be shorter than 'longSleep' to ensure those are interrupted. +-- 1s would be a reasonable value, but failed tempfile cleanup on Windows CI +-- takes ~1s. +shortDelta :: NominalDiffTime +shortDelta = 5 -- 5s + +longSleep :: IO () +longSleep = threadDelay 10000000 -- 10s + +testEmpty :: Assertion +testEmpty = do + let repoCtxt = undefined + pkgLocs = [] + res <- asyncFetchPackages verbosity repoCtxt pkgLocs $ \_ -> + return () + res @?= () + +testPassLocalPackage :: Assertion +testPassLocalPackage = do + let repoCtxt = error "repoCtxt undefined" + loc = LocalUnpackedPackage "a" + res <- asyncFetchPackages verbosity repoCtxt [loc] $ \downloadMap -> + waitAsyncFetchPackage verbosity downloadMap loc + res @?= LocalUnpackedPackage "a" + +testHttp :: Assertion +testHttp = withFakeRepoCtxt get200 $ \repoCtxt repo -> do + let pkgId = mkPkgId "foo" + loc = RepoTarballPackage repo pkgId Nothing + res <- asyncFetchPackages verbosity repoCtxt [loc] $ \downloadMap -> + waitAsyncFetchPackage verbosity downloadMap loc + case res of + RepoTarballPackage repo' pkgId' _ -> do + repo' @?= repo + pkgId' @?= pkgId + _ -> assertFailure $ "expected RepoTarballPackage, got " ++ show res + where + get200 = \_uri -> return 200 + +testGetInterrupt :: Assertion +testGetInterrupt = testGetAny UserInterrupt + +testGetException :: Assertion +testGetException = testGetAny $ userError "some error" + +-- | Test that if a GET request fails with the given exception, +-- we exit promptly. We queue two slow downloads after the failing +-- download to cover a buggy scenario where +-- 1. first download throws +-- 2. second download is cancelled, but swallows AsyncCancelled +-- 3. third download keeps running +testGetAny :: Exception e => e -> Assertion +testGetAny exc = withFakeRepoCtxt get $ \repoCtxt repo -> do + let loc pkgId = RepoTarballPackage repo pkgId Nothing + pkgLocs = [loc throws, loc slowA, loc slowB] + + start <- getCurrentTime + res :: Either SomeException ResolvedPkgLoc <- + try $ + asyncFetchPackages verbosity repoCtxt pkgLocs $ \downloadMap -> do + waitAsyncFetchPackage verbosity downloadMap (loc throws) + assertFaster start shortDelta + case res of + Left _ -> pure () + Right _ -> assertFailure $ "expected an exception, got " ++ show res + where + throws = mkPkgId "throws" + slowA = mkPkgId "slowA" + slowB = mkPkgId "slowB" + get uri = case uriPath uri of + "package/throws-1.0.tar.gz" -> throwIO exc + "package/slowA-1.0.tar.gz" -> longSleep >> return 200 + "package/slowB-1.0.tar.gz" -> longSleep >> return 200 + _ -> assertFailure $ "unexpected URI: " ++ show uri + +-- | Test that when an undemanded download is interrupted (Ctrl-C), +-- we still abort directly. +testUncollectedInterrupt :: Assertion +testUncollectedInterrupt = withFakeRepoCtxt get $ \repoCtxt repo -> do + let loc pkgId = RepoTarballPackage repo pkgId Nothing + pkgLocs = [loc throws, loc slowA, loc slowB] + + start <- getCurrentTime + res :: Either SomeException ResolvedPkgLoc <- + try $ + asyncFetchPackages verbosity repoCtxt pkgLocs $ \downloadMap -> do + waitAsyncFetchPackage verbosity downloadMap (loc slowA) + assertFaster start shortDelta + case res of + Left _ -> pure () + Right _ -> assertFailure $ "expected an exception, got " ++ show res + where + throws = mkPkgId "throws" + slowA = mkPkgId "slowA" + slowB = mkPkgId "slowB" + get uri = case uriPath uri of + "package/throws-1.0.tar.gz" -> throwIO UserInterrupt + "package/slowA-1.0.tar.gz" -> longSleep >> return 200 + "package/slowB-1.0.tar.gz" -> longSleep >> return 200 + _ -> assertFailure $ "unexpected URI: " ++ show uri + +-- | Test that a download failure doesn't automatically abort things, +-- e.g. if we don't collect the download. (In practice, we might collect +-- the download and handle its exception.) +testUncollectedException :: Assertion +testUncollectedException = withFakeRepoCtxt get $ \repoCtxt repo -> do + let loc pkgId = RepoTarballPackage repo pkgId Nothing + pkgLocs = [loc throws, loc foo] + + start <- getCurrentTime + res <- asyncFetchPackages verbosity repoCtxt pkgLocs $ \downloadMap -> do + waitAsyncFetchPackage verbosity downloadMap (loc foo) + assertFaster start shortDelta + case res of + RepoTarballPackage repo' pkgId' _ -> do + repo' @?= repo + pkgId' @?= foo + _ -> assertFailure $ "expected RepoTarballPackage, got " ++ show res + where + throws = mkPkgId "throws" + foo = mkPkgId "foo" + get uri = case uriPath uri of + "package/throws-1.0.tar.gz" -> throwIO $ userError "failed download" + "package/foo-1.0.tar.gz" -> return 200 + _ -> assertFailure $ "unexpected URI: " ++ show uri + +assertFaster :: UTCTime -> NominalDiffTime -> Assertion +assertFaster start delta = do + t <- getCurrentTime + assertBool ("took longer than " ++ show delta) (diffUTCTime t start < delta) + +mkPkgId :: String -> PackageIdentifier +mkPkgId name = PackageIdentifier (mkPackageName name) (mkVersion [1, 0]) + +-- | Provide a repo and a repo context with the given GET handler. +withFakeRepoCtxt :: + (URI -> IO HttpCode) -> + (RepoContext -> Repo -> IO a) -> + IO a +withFakeRepoCtxt handleGet action = + withTestDir verbosity "fake repo" $ \tmpDir -> + let repo = + RepoRemote + { repoRemote = emptyRemoteRepo $ RepoName "fake", + repoLocalDir = tmpDir + } + repoCtxt = + RepoContext + { repoContextRepos = [repo], + repoContextGetTransport = return httpTransport, + repoContextWithSecureRepo = \_ _ -> + error "fake repo ctxt: repoContextWithSecureRepo not implemented", + repoContextIgnoreExpiry = error "fake repo ctxt: repoContextIgnoreExpiry not implemented" + } + in action repoCtxt repo + where + httpTransport = + HttpTransport + { getHttp = \_verbosity uri _etag _filepath _headers -> do + code <- handleGet uri + return (code, Nothing), + postHttp = error "fake transport: postHttp not implemented", + postHttpFile = error "fake transport: postHttpFile not implemented", + putHttpFile = error "fake transport: putHttp not implemented", + transportSupportsHttps = error "fake transport: transportSupportsHttps not implemented", + transportManuallySelected = True + } diff --git a/cabal/cabal-install/tests/UnitTests/Distribution/Client/FileMonitor.hs b/cabal/cabal-install/tests/UnitTests/Distribution/Client/FileMonitor.hs --- a/cabal/cabal-install/tests/UnitTests/Distribution/Client/FileMonitor.hs +++ b/cabal/cabal-install/tests/UnitTests/Distribution/Client/FileMonitor.hs @@ -14,6 +14,7 @@ import Distribution.Compat.Binary import Distribution.Simple.Utils (withTempDirectory) +import Distribution.System (buildOS, OS (Windows)) import Distribution.Verbosity (silent) import Distribution.Client.FileMonitor @@ -22,6 +23,7 @@ import GHC.Fingerprint (Fingerprint (..)) import Test.Tasty +import Test.Tasty.ExpectedFailure import Test.Tasty.HUnit @@ -60,8 +62,9 @@ , testCase "add non-match" $ testGlobAddNonMatch mtimeChange , testCase "remove non-match" $ testGlobRemoveNonMatch mtimeChange - , testCase "add non-match" $ testGlobAddNonMatchSubdir mtimeChange - , testCase "remove non-match" $ testGlobRemoveNonMatchSubdir mtimeChange + , knownBrokenInWindows "See issue #3126" $ + testCase "add non-match subdir" $ testGlobAddNonMatchSubdir mtimeChange + , testCase "remove non-match subdir" $ testGlobRemoveNonMatchSubdir mtimeChange , testCase "invariant sorted 1" $ testInvariantMonitorStateGlobFiles mtimeChange @@ -69,7 +72,8 @@ mtimeChange , testCase "match dirs" $ testGlobMatchDir mtimeChange - , testCase "match dirs only" $ testGlobMatchDirOnly mtimeChange + , knownBrokenInWindows "See issue #3126" $ + testCase "match dirs only" $ testGlobMatchDirOnly mtimeChange , testCase "change file type" $ testGlobChangeFileType mtimeChange , testCase "absolute paths" $ testGlobAbsolutePath mtimeChange ] @@ -80,6 +84,10 @@ , testCase "value updated" testValueUpdated ] + where knownBrokenInWindows msg = case buildOS of + Windows -> expectFailBecause msg + _ -> id + -- Check the file system behaves the way we expect it to -- we rely on file mtimes having a reasonable resolution @@ -697,19 +705,19 @@ threadDelay mtimeChange removeFile root "dir/good-a" reason <- expectMonitorChanged root monitor () - reason @?= MonitoredFileChanged (root' "dir/good-a") + reason @?= MonitoredFileChanged (root' "dir" "good-a") -- absolute glob, adding a file updateMonitor root monitor [monitorFileGlobStr (root' "dir/good-*")] () () threadDelay mtimeChange touchFile root ("dir/good-a") reason2 <- expectMonitorChanged root monitor () - reason2 @?= MonitoredFileChanged (root' "dir/good-a") + reason2 @?= MonitoredFileChanged (root' "dir" "good-a") -- absolute glob, changing a file updateMonitor root monitor [monitorFileGlobStr (root' "dir/good-*")] () () threadDelay mtimeChange touchFileContent root "dir/good-b" reason3 <- expectMonitorChanged root monitor () - reason3 @?= MonitoredFileChanged (root' "dir/good-b") + reason3 @?= MonitoredFileChanged (root' "dir" "good-b") ------------------ diff --git a/cabal/cabal-install/tests/UnitTests/Distribution/Client/Get.hs b/cabal/cabal-install/tests/UnitTests/Distribution/Client/Get.hs --- a/cabal/cabal-install/tests/UnitTests/Distribution/Client/Get.hs +++ b/cabal/cabal-install/tests/UnitTests/Distribution/Client/Get.hs @@ -106,6 +106,7 @@ , srpTag = Nothing , srpBranch = Nothing , srpSubdir = Proxy + , srpCommand = [] } repotype = OtherRepoType "baz" @@ -184,6 +185,7 @@ , srpTag = Nothing , srpBranch = Nothing , srpSubdir = Proxy + , srpCommand = [] } pkgrepos = [(pkgidfoo, [repo])] e1 <- assertException $ diff --git a/cabal/cabal-install/tests/UnitTests/Distribution/Client/IndexUtils.hs b/cabal/cabal-install/tests/UnitTests/Distribution/Client/IndexUtils.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/UnitTests/Distribution/Client/IndexUtils.hs @@ -0,0 +1,79 @@ +module UnitTests.Distribution.Client.IndexUtils where + +import Distribution.Client.IndexUtils +import qualified Distribution.Compat.NonEmptySet as NES +import Distribution.Simple.Utils (toUTF8LBS) +import Distribution.Version +import Distribution.Types.Dependency +import Distribution.Types.PackageName +import Distribution.Types.LibraryName + + +import Test.Tasty +import Test.Tasty.HUnit + +tests :: [TestTree] +tests = + [ simpleVersionsParserTests + ] + +simpleVersionsParserTests :: TestTree +simpleVersionsParserTests = testGroup "Simple preferred-versions Parser Tests" + [ testCase "simple deprecation dependency" $ do + let prefs = parsePreferredVersionsWarnings (toUTF8LBS "binary < 0.9.0.0 || > 0.9.0.0") + prefs @?= + [ Right + (Dependency + (mkPackageName "binary") + (unionVersionRanges + (earlierVersion $ mkVersion [0,9,0,0]) + (laterVersion $ mkVersion [0,9,0,0]) + ) + (NES.singleton LMainLibName) + ) + ] + , testCase "multiple deprecation dependency" $ do + let prefs = parsePreferredVersionsWarnings (toUTF8LBS "binary < 0.9.0.0 || > 0.9.0.0\ncontainers == 0.6.4.1") + prefs @?= + [ Right + (Dependency + (mkPackageName "binary") + (unionVersionRanges + (earlierVersion $ mkVersion [0,9,0,0]) + (laterVersion $ mkVersion [0,9,0,0]) + ) + (NES.singleton LMainLibName) + ) + , Right + (Dependency + (mkPackageName "containers") + (thisVersion $ mkVersion [0,6,4,1]) + (NES.singleton LMainLibName) + ) + ] + , testCase "unparsable dependency" $ do + let prefs = parsePreferredVersionsWarnings (toUTF8LBS "binary 0.9.0.0 || > 0.9.0.0") + prefs @?= + [ Left binaryDepParseError + ] + , testCase "partial parse" $ do + let prefs = parsePreferredVersionsWarnings (toUTF8LBS "binary 0.9.0.0 || > 0.9.0.0\ncontainers == 0.6.4.1") + prefs @?= + [ Left binaryDepParseError + , Right + (Dependency + (mkPackageName "containers") + (thisVersion $ mkVersion [0,6,4,1]) + (NES.singleton LMainLibName) + ) + ] + ] + where + binaryDepParseError = PreferredVersionsParseError + { preferredVersionsParsecError = mconcat + [ "\"\" (line 1, column 8):\n" + , "unexpected '0'\n" + , "expecting space, white space, opening paren, operator or end of input" + ] + , preferredVersionsOriginalDependency = "binary 0.9.0.0 || > 0.9.0.0" + } diff --git a/cabal/cabal-install/tests/UnitTests/Distribution/Client/Init.hs b/cabal/cabal-install/tests/UnitTests/Distribution/Client/Init.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/UnitTests/Distribution/Client/Init.hs @@ -0,0 +1,51 @@ +module UnitTests.Distribution.Client.Init +( tests +) where + +import Test.Tasty + +import qualified UnitTests.Distribution.Client.Init.Interactive as Interactive +import qualified UnitTests.Distribution.Client.Init.NonInteractive as NonInteractive +import qualified UnitTests.Distribution.Client.Init.Golden as Golden +import qualified UnitTests.Distribution.Client.Init.Simple as Simple +import qualified UnitTests.Distribution.Client.Init.FileCreators as FileCreators + +import UnitTests.Distribution.Client.Init.Utils + +import Distribution.Client.Config +import Distribution.Client.IndexUtils +import Distribution.Client.Init.Types +import Distribution.Client.Sandbox +import Distribution.Client.Setup +import Distribution.Verbosity + + +tests :: IO [TestTree] +tests = do + confFlags <- loadConfigOrSandboxConfig v defaultGlobalFlags + + let confFlags' = savedConfigureFlags confFlags `mappend` compFlags + initFlags' = savedInitFlags confFlags `mappend` emptyFlags + globalFlags' = savedGlobalFlags confFlags `mappend` defaultGlobalFlags + + (comp, _, progdb) <- configCompilerAux' confFlags' + + withRepoContext v globalFlags' $ \repoCtx -> do + let pkgDb = configPackageDB' confFlags' + + pkgIx <- getInstalledPackages v comp pkgDb progdb + srcDb <- getSourcePackages v repoCtx + + return + [ Interactive.tests v initFlags' pkgIx srcDb + , 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 + ] + where + v :: Verbosity + v = normal + + compFlags :: ConfigFlags + compFlags = mempty { configHcPath = initHcPath emptyFlags } diff --git a/cabal/cabal-install/tests/UnitTests/Distribution/Client/Init/FileCreators.hs b/cabal/cabal-install/tests/UnitTests/Distribution/Client/Init/FileCreators.hs --- a/cabal/cabal-install/tests/UnitTests/Distribution/Client/Init/FileCreators.hs +++ b/cabal/cabal-install/tests/UnitTests/Distribution/Client/Init/FileCreators.hs @@ -1,184 +1,87 @@ -module UnitTests.Distribution.Client.Init.FileCreators ( - tests +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedLists #-} +module UnitTests.Distribution.Client.Init.FileCreators + ( tests ) where -import Distribution.Client.Init.FileCreators - ( generateCabalFile ) - import Test.Tasty -import Test.Tasty.Golden (goldenVsString) +import Test.Tasty.HUnit -import System.FilePath - ( () ) -import qualified Data.ByteString.Lazy as BS -import qualified Data.ByteString.Lazy.Char8 as BS8 +import UnitTests.Distribution.Client.Init.Utils +import Distribution.Client.Init.FileCreators +import Distribution.Client.Init.NonInteractive.Command import Distribution.Client.Init.Types - ( InitFlags(..), PackageType(..), defaultInitFlags ) -import Distribution.Simple.Setup - ( Flag(..) ) - -import Distribution.CabalSpecVersion - ( CabalSpecVersion(CabalSpecV2_4) ) -import Distribution.Types.Dependency - ( Dependency, mkDependency, mainLibSet ) -import Distribution.Types.PackageName - ( mkPackageName ) -import Distribution.Types.VersionRange - ( majorBoundVersion ) -import Distribution.Types.Version - ( mkVersion ) -import qualified Distribution.ModuleName as ModuleName - ( fromString ) -import qualified Distribution.SPDX as SPDX -import Language.Haskell.Extension ( Language(..) ) - -tests :: [TestTree] -tests = [ testGroup "cabal init goldens" - [ checkCabalFileGolden exeFlags "exe-only-golden.cabal" - , checkCabalFileGolden libAndExeFlags "lib-and-exe-golden.cabal" - , checkCabalFileGolden libExeAndTestFlags "lib-exe-and-test-golden.cabal" - , checkCabalFileGolden libExeAndTestWithCommentsFlags "lib-exe-and-test-with-comments-golden.cabal" - ] - ] - -checkCabalFileGolden :: InitFlags -> FilePath -> TestTree -checkCabalFileGolden flags goldenFileName = - goldenVsString goldenFileName goldenFilePath generatedCabalFile - where - goldenFilePath :: FilePath - goldenFilePath = "tests" "fixtures" "init" goldenFileName - - generatedCabalFile :: IO BS.ByteString - generatedCabalFile = pure . BS8.pack $ generateCabalFile goldenFileName flags - --- ================================================== --- Base flags to set common InitFlags values. - -baseFlags :: InitFlags -baseFlags = defaultInitFlags { - -- Values common to all (or most) test flags. - packageName = Flag (mkPackageName "foo") - , noComments = Flag False - , minimal = Flag True - , version = Flag (mkVersion [3,2,1]) - , synopsis = Flag "The foo package" - , homepage = Flag "https://github.com/foo/foo" - , license = Flag SPDX.NONE - , author = Flag "me" - , email = Flag "me@me.me" - , category = Flag (Left "SomeCat") - , cabalVersion = Flag CabalSpecV2_4 - , extraSrc = Just ["CHANGELOG.md"] - , interactive = Flag False - , otherModules = Nothing - , otherExts = Nothing - , language = Flag Haskell2010 - , buildTools = Nothing - , dependencies = Just testDependencies - , quiet = Flag True - , packageDir = NoFlag - , simpleProject = Flag False - , initHcPath = NoFlag - , overwrite = NoFlag - - -- Commonly overridden values in test InitFlags. - -- It is fine to provide the same value in an overridden InitFlags - -- to make it clear what that particular test case is differentiating - -- from others. - , packageType = Flag Executable - , mainIs = Flag "Main.hs" - , applicationDirs = Just ["app"] - , sourceDirs = Nothing - , exposedModules = Nothing - , initializeTestSuite = Flag False - , testDirs = Nothing - } - - --- ================================================== --- Simple exe. - -exeFlags :: InitFlags -exeFlags = baseFlags { - -- Create an executable only, with main living in app/Main.hs. - packageType = Flag Executable - , mainIs = Flag "Main.hs" - , applicationDirs = Just ["app"] - } - - --- ================================================== --- Simple lib and exe (as created by `cabal init --libandexe`). --- --- Specifically, having 'exposedModules = Just ["MyLib"]' is a special --- case which results in the executable depending on the library from --- the same package, i.e. 'build-depends = foo' with no version --- constraints. - -libAndExeFlags :: InitFlags -libAndExeFlags = baseFlags { - -- Create a library and executable - packageType = Flag LibraryAndExecutable - - -- Main living in app/Main.hs. - , mainIs = Flag "Main.hs" - , applicationDirs = Just ["app"] - - -- Library sources live in src/ and expose the module MyLib. - , sourceDirs = Just ["src"] - , exposedModules = Just (map ModuleName.fromString ["MyLib"]) - } - - --- ================================================== --- Lib, exe, and test suite - -libExeAndTestFlags :: InitFlags -libExeAndTestFlags = baseFlags { - -- Create a library and executable - packageType = Flag LibraryAndExecutable - - -- Main living in app/Main.hs. - , mainIs = Flag "Main.hs" - , applicationDirs = Just ["app"] - - -- Library sources live in src/ and expose the modules A and B. - , sourceDirs = Just ["src"] - , exposedModules = Just (map ModuleName.fromString ["A", "B"]) - - -- Create a test suite living in tests/ - , initializeTestSuite = Flag True - , testDirs = Just ["tests"] - } - --- ================================================== --- Lib, exe, and test suite with comments. - -libExeAndTestWithCommentsFlags :: InitFlags -libExeAndTestWithCommentsFlags = libExeAndTestFlags { - minimal = Flag False - , noComments = Flag False - , quiet = Flag False - } +import Distribution.Client.Types +import Distribution.Simple +import Distribution.Simple.Flag +import Distribution.Simple.PackageIndex +import Distribution.Verbosity +tests + :: Verbosity + -> InitFlags + -> Compiler + -> InstalledPackageIndex + -> SourcePackageDb + -> TestTree +tests _v _initFlags comp pkgIx srcDb = + testGroup "Distribution.Client.Init.FileCreators" + [ testCase "Check . as source directory" $ do + let dummyFlags' = dummyFlags + { packageType = Flag LibraryAndExecutable + , minimal = Flag False + , overwrite = Flag False + , packageDir = Flag "/home/test/test-package" + , extraDoc = Flag ["CHANGELOG.md"] + , exposedModules = Flag [] + , otherModules = Flag [] + , otherExts = Flag [] + , buildTools = Flag [] + , mainIs = Flag "quxApp/Main.hs" + , dependencies = Flag [] + , sourceDirs = Flag ["."] + } + inputs = + -- createProject stuff + [ "True" + , "[\"quxTest/Main.hs\"]" + -- writeProject stuff + -- writeLicense + , "2021" + -- writeFileSafe + , "True" + -- findNewPath + , "False" + -- writeChangeLog + -- writeFileSafe + , "False" + -- prepareLibTarget + -- writeDirectoriesSafe + , "True" + -- findNewPath + , "False" + -- prepareExeTarget + -- writeDirectoriesSafe + , "False" + -- writeFileSafe + , "False" + -- prepareTestTarget + -- writeDirectoriesSafe + , "False" + -- writeFileSafe + , "False" + -- writeCabalFile + -- writeFileSafe + , "False" + ] + case flip _runPrompt inputs $ do + projSettings <- createProject comp silent pkgIx srcDb dummyFlags' + writeProject projSettings of --- ================================================== --- Test dependency. + Left (BreakException ex) -> assertFailure $ show ex + Right _ -> return () + -testDependencies :: [Dependency] -testDependencies = - [ mkDependency - (mkPackageName "base") - (majorBoundVersion (mkVersion [4,13,0,0])) - mainLibSet - , mkDependency - (mkPackageName "containers") - (majorBoundVersion (mkVersion [5,7,0,0])) - mainLibSet - , mkDependency - (mkPackageName "unordered-containers") - (majorBoundVersion (mkVersion [2,7,0,0])) - mainLibSet - ] + ] diff --git a/cabal/cabal-install/tests/UnitTests/Distribution/Client/Init/Golden.hs b/cabal/cabal-install/tests/UnitTests/Distribution/Client/Init/Golden.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/UnitTests/Distribution/Client/Init/Golden.hs @@ -0,0 +1,372 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +module UnitTests.Distribution.Client.Init.Golden +( tests +) where + + +import Test.Tasty +import Test.Tasty.Golden +import Test.Tasty.HUnit + +import qualified Data.ByteString.Lazy.Char8 as BS8 +import Data.List.NonEmpty (fromList) +import Data.List.NonEmpty as NEL (NonEmpty, drop) +#if __GLASGOW_HASKELL__ < 804 +import Data.Semigroup ((<>)) +#endif + +import Distribution.Client.Init.Types +import Distribution.Simple.PackageIndex hiding (fromList) +import Distribution.Verbosity +import Distribution.Client.Types.SourcePackageDb +import Distribution.Client.Init.Interactive.Command +import Distribution.Client.Init.Format +import Distribution.Fields.Pretty +import Distribution.Types.PackageName (PackageName) +import Distribution.Client.Init.FlagExtractors +import Distribution.Simple.Flag +import Distribution.CabalSpecVersion + +import System.FilePath + +import UnitTests.Distribution.Client.Init.Utils +import Distribution.Client.Init.Defaults + +-- -------------------------------------------------------------------- -- +-- golden test suite + +-- | Golden executable tests. +-- +-- We test target generation against a golden file in @tests/fixtures/init/@ for +-- executables, libraries, and test targets with the following: +-- +-- * Empty flags, non-simple target gen, no special options +-- * Empty flags, simple target gen, no special options +-- * Empty flags, non-simple target gen, with generated comments (no minimal setting) +-- * Empty flags, non-simple target gen, with minimal setting (no generated comments) +-- * Empty flags, non-simple target gen, minimal and generated comments set. +-- +-- Additionally, we test whole @.cabal@ file generation for every combination +-- of library, lib + tests, exe, exe + tests, exe + lib, exe + lib + tests +-- and so on against the same options. +-- +tests + :: Verbosity + -> InitFlags + -> InstalledPackageIndex + -> SourcePackageDb + -> TestTree +tests v initFlags pkgIx srcDb = testGroup "golden" + [ goldenLibTests v pkgIx pkgDir pkgName + , goldenExeTests v pkgIx pkgDir pkgName + , goldenTestTests v pkgIx pkgDir pkgName + , goldenPkgDescTests v srcDb pkgDir pkgName + , goldenCabalTests v pkgIx srcDb + ] + where + pkgDir = evalPrompt (getPackageDir initFlags) + $ fromList ["."] + pkgName = evalPrompt (packageNamePrompt srcDb initFlags) + $ fromList ["test-package", "test-package", "y"] + +goldenPkgDescTests + :: Verbosity + -> SourcePackageDb + -> FilePath + -> PackageName + -> TestTree +goldenPkgDescTests v srcDb pkgDir pkgName = testGroup "package description golden tests" + [ goldenVsString "Empty flags, non-simple, no comments" + (goldenPkgDesc "pkg.golden") $ + let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion + in runPkgDesc opts emptyFlags pkgArgs + + , goldenVsString "Empty flags, non-simple, with comments" + (goldenPkgDesc "pkg-with-comments.golden") $ + let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion + in runPkgDesc opts emptyFlags pkgArgs + + , goldenVsString "Dummy flags, with comments" + (goldenPkgDesc "pkg-with-flags.golden") $ + let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion + in runPkgDesc opts dummyFlags pkgArgs + + , goldenVsString "Dummy flags, old cabal version, with comments" + (goldenPkgDesc "pkg-old-cabal-with-flags.golden") $ + let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion + in runPkgDesc opts (dummyFlags {cabalVersion = Flag CabalSpecV2_0}) pkgArgs + ] + where + runPkgDesc opts flags args = do + case _runPrompt (genPkgDescription flags srcDb) args of + Left e -> assertFailure $ show e + Right (pkg, _) -> mkStanza $ mkPkgDescription opts pkg + +goldenExeTests + :: Verbosity + -> InstalledPackageIndex + -> FilePath + -> PackageName + -> TestTree +goldenExeTests v pkgIx pkgDir pkgName = testGroup "exe golden tests" + [ goldenVsString "Empty flags, not simple, no options, no comments" + (goldenExe "exe-no-comments.golden") $ + let opts = WriteOpts False False True v pkgDir Executable pkgName defaultCabalVersion + in runGoldenExe opts exeArgs emptyFlags + + , goldenVsString "Empty flags, not simple, with comments + no minimal" + (goldenExe "exe-with-comments.golden") $ + let opts = WriteOpts False False False v pkgDir Executable pkgName defaultCabalVersion + in runGoldenExe opts exeArgs emptyFlags + + , goldenVsString "Empty flags, not simple, with minimal + no comments" + (goldenExe "exe-minimal-no-comments.golden") $ + let opts = WriteOpts False True True v pkgDir Executable pkgName defaultCabalVersion + in runGoldenExe opts exeArgs emptyFlags + + , goldenVsString "Empty flags, not simple, with minimal + comments" + (goldenExe "exe-simple-minimal-with-comments.golden") $ + let opts = WriteOpts False True False v pkgDir Executable pkgName defaultCabalVersion + in runGoldenExe opts exeArgs emptyFlags + + , goldenVsString "Build tools flag, not simple, with comments + no minimal" + (goldenExe "exe-build-tools-with-comments.golden") $ + let opts = WriteOpts False False False v pkgDir Executable pkgName defaultCabalVersion + in runGoldenExe opts exeArgs (emptyFlags {buildTools = Flag ["happy"]}) + ] + where + runGoldenExe opts args flags = + case _runPrompt (genExeTarget flags pkgIx) args of + Right (t, _) -> mkStanza [mkExeStanza opts $ t {_exeDependencies = mangleBaseDep t _exeDependencies}] + Left e -> assertFailure $ show e + +goldenLibTests + :: Verbosity + -> InstalledPackageIndex + -> FilePath + -> PackageName + -> TestTree +goldenLibTests v pkgIx pkgDir pkgName = testGroup "lib golden tests" + [ goldenVsString "Empty flags, not simple, no options, no comments" + (goldenLib "lib-no-comments.golden") $ + let opts = WriteOpts False False True v pkgDir Library pkgName defaultCabalVersion + in runGoldenLib opts libArgs emptyFlags + + , goldenVsString "Empty flags, simple, no options, no comments" + (goldenLib "lib-simple-no-comments.golden") $ + let opts = WriteOpts False False True v pkgDir Library pkgName defaultCabalVersion + in runGoldenLib opts libArgs emptyFlags + + , goldenVsString "Empty flags, not simple, with comments + no minimal" + (goldenLib "lib-with-comments.golden") $ + let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion + in runGoldenLib opts libArgs emptyFlags + + , goldenVsString "Empty flags, not simple, with minimal + no comments" + (goldenLib "lib-minimal-no-comments.golden") $ + let opts = WriteOpts False True True v pkgDir Library pkgName defaultCabalVersion + in runGoldenLib opts libArgs emptyFlags + + , goldenVsString "Empty flags, not simple, with minimal + comments" + (goldenLib "lib-simple-minimal-with-comments.golden") $ + let opts = WriteOpts False True False v pkgDir Library pkgName defaultCabalVersion + in runGoldenLib opts libArgs emptyFlags + + , goldenVsString "Build tools flag, not simple, with comments + no minimal" + (goldenLib "lib-build-tools-with-comments.golden") $ + let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion + in runGoldenLib opts libArgs (emptyFlags {buildTools = Flag ["happy"]}) + ] + where + runGoldenLib opts args flags = + case _runPrompt (genLibTarget flags pkgIx) args of + Right (t, _) -> mkStanza [mkLibStanza opts $ t {_libDependencies = mangleBaseDep t _libDependencies}] + Left e -> assertFailure $ show e + +goldenTestTests + :: Verbosity + -> InstalledPackageIndex + -> FilePath + -> PackageName + -> TestTree +goldenTestTests v pkgIx pkgDir pkgName = testGroup "test golden tests" + [ goldenVsString "Empty flags, not simple, no options, no comments" + (goldenTest "test-no-comments.golden") $ + let opts = WriteOpts False False True v pkgDir Library pkgName defaultCabalVersion + in runGoldenTest opts testArgs emptyFlags + + , goldenVsString "Empty flags, not simple, with comments + no minimal" + (goldenTest "test-with-comments.golden") $ + let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion + in runGoldenTest opts testArgs emptyFlags + + , goldenVsString "Empty flags, not simple, with minimal + no comments" + (goldenTest "test-minimal-no-comments.golden") $ + let opts = WriteOpts False True True v pkgDir Library pkgName defaultCabalVersion + in runGoldenTest opts testArgs emptyFlags + + , goldenVsString "Empty flags, not simple, with minimal + comments" + (goldenTest "test-simple-minimal-with-comments.golden") $ + let opts = WriteOpts False True False v pkgDir Library pkgName defaultCabalVersion + in runGoldenTest opts testArgs emptyFlags + + , goldenVsString "Build tools flag, not simple, with comments + no minimal" + (goldenTest "test-build-tools-with-comments.golden") $ + let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion + in runGoldenTest opts testArgs (emptyFlags {buildTools = Flag ["happy"]}) + + , goldenVsString "Standalone tests, empty flags, not simple, no options, no comments" + (goldenTest "standalone-test-no-comments.golden") $ + let opts = WriteOpts False False True v pkgDir TestSuite pkgName defaultCabalVersion + in runGoldenTest opts testArgs emptyFlags + + , goldenVsString "Standalone tests, empty flags, not simple, with comments + no minimal" + (goldenTest "standalone-test-with-comments.golden") $ + let opts = WriteOpts False False False v pkgDir TestSuite pkgName defaultCabalVersion + in runGoldenTest opts testArgs emptyFlags + ] + where + runGoldenTest opts args flags = + case _runPrompt (genTestTarget flags pkgIx) args of + Left e -> assertFailure $ show e + Right (Nothing, _) -> assertFailure + "goldenTestTests: Tests not enabled." + Right (Just t, _) -> mkStanza [mkTestStanza opts $ t {_testDependencies = mangleBaseDep t _testDependencies}] + +-- | Full cabal file golden tests +goldenCabalTests + :: Verbosity + -> InstalledPackageIndex + -> SourcePackageDb + -> TestTree +goldenCabalTests v pkgIx srcDb = testGroup ".cabal file golden tests" + [ goldenVsString "Library and executable, empty flags, not simple, with comments + no minimal" + (goldenCabal "cabal-lib-and-exe-with-comments.golden") $ + runGoldenTest (fullProjArgs "Y") emptyFlags + + , goldenVsString "Library and executable, empty flags, not simple, no comments + no minimal" + (goldenCabal "cabal-lib-and-exe-no-comments.golden") $ + runGoldenTest (fullProjArgs "N") emptyFlags + + , goldenVsString "Library, empty flags, not simple, with comments + no minimal" + (goldenCabal "cabal-lib-with-comments.golden") $ + runGoldenTest (libProjArgs "Y") emptyFlags + + , goldenVsString "Library, empty flags, not simple, no comments + no minimal" + (goldenCabal "cabal-lib-no-comments.golden") $ + runGoldenTest (libProjArgs "N") emptyFlags + + , goldenVsString "Test suite, empty flags, not simple, with comments + no minimal" + (goldenCabal "cabal-test-suite-with-comments.golden") $ + runGoldenTest (testProjArgs "Y") emptyFlags + + , goldenVsString "Test suite, empty flags, not simple, no comments + no minimal" + (goldenCabal "cabal-test-suite-no-comments.golden") $ + runGoldenTest (testProjArgs "N") emptyFlags + ] + where + runGoldenTest args flags = + case _runPrompt (createProject v pkgIx srcDb flags) args of + Left e -> assertFailure $ show e + + (Right (ProjectSettings opts pkgDesc (Just libTarget) (Just exeTarget) (Just testTarget), _)) -> do + let pkgFields = mkPkgDescription opts pkgDesc + commonStanza = mkCommonStanza opts + libStanza = mkLibStanza opts $ libTarget {_libDependencies = mangleBaseDep libTarget _libDependencies} + exeStanza = mkExeStanza opts $ exeTarget {_exeDependencies = mangleBaseDep exeTarget _exeDependencies} + testStanza = mkTestStanza opts $ testTarget {_testDependencies = mangleBaseDep testTarget _testDependencies} + + mkStanza $ pkgFields ++ [commonStanza, libStanza, exeStanza, testStanza] + + (Right (ProjectSettings opts pkgDesc (Just libTarget) Nothing (Just testTarget), _)) -> do + let pkgFields = mkPkgDescription opts pkgDesc + commonStanza = mkCommonStanza opts + libStanza = mkLibStanza opts $ libTarget {_libDependencies = mangleBaseDep libTarget _libDependencies} + testStanza = mkTestStanza opts $ testTarget {_testDependencies = mangleBaseDep testTarget _testDependencies} + + mkStanza $ pkgFields ++ [commonStanza, libStanza, testStanza] + + (Right (ProjectSettings opts pkgDesc Nothing Nothing (Just testTarget), _)) -> do + let pkgFields = mkPkgDescription opts pkgDesc + commonStanza = mkCommonStanza opts + testStanza = mkTestStanza opts $ testTarget {_testDependencies = mangleBaseDep testTarget _testDependencies} + + mkStanza $ pkgFields ++ [commonStanza, testStanza] + + (Right (ProjectSettings _ _ l e t, _)) -> assertFailure $ + show l ++ "\n" ++ show e ++ "\n" ++ show t + + +-- -------------------------------------------------------------------- -- +-- utils + +mkStanza :: [PrettyField FieldAnnotation] -> IO BS8.ByteString +mkStanza fields = return . BS8.pack $ showFields' + annCommentLines postProcessFieldLines + 4 fields + +golden :: FilePath +golden = "tests" "fixtures" "init" "golden" + +goldenExe :: FilePath -> FilePath +goldenExe file = golden "exe" file + +goldenTest :: FilePath -> FilePath +goldenTest file = golden "test" file + +goldenLib :: FilePath -> FilePath +goldenLib file = golden "lib" file + +goldenCabal :: FilePath -> FilePath +goldenCabal file = golden "cabal" file + +goldenPkgDesc :: FilePath -> FilePath +goldenPkgDesc file = golden "pkg-desc" file + +libArgs :: NonEmpty String +libArgs = fromList ["1", "2"] + +exeArgs :: NonEmpty String +exeArgs = fromList ["1", "2", "1"] + +testArgs :: NonEmpty String +testArgs = fromList ["y", "1", "test", "1"] + +pkgArgs :: NonEmpty String +pkgArgs = fromList + [ "5" + , "foo-package" + , "foo-package" + , "y" + , "0.1.0.0" + , "2" + , "git username" + , "foo-kmett" + , "git email" + , "foo-kmett@kmett.kmett" + , "home" + , "synopsis" + , "4" + ] + +testProjArgs :: String -> NonEmpty String +testProjArgs comments = fromList ["4", "n", "foo-package"] + <> pkgArgs + <> fromList (NEL.drop 1 testArgs) + <> fromList [comments] + +libProjArgs :: String -> NonEmpty String +libProjArgs comments = fromList ["1", "n", "foo-package"] + <> pkgArgs + <> libArgs + <> testArgs + <> fromList [comments] + +fullProjArgs :: String -> NonEmpty String +fullProjArgs comments = fromList ["3", "n", "foo-package"] + <> pkgArgs + <> libArgs + <> exeArgs + <> testArgs + <> fromList [comments] diff --git a/cabal/cabal-install/tests/UnitTests/Distribution/Client/Init/Interactive.hs b/cabal/cabal-install/tests/UnitTests/Distribution/Client/Init/Interactive.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/UnitTests/Distribution/Client/Init/Interactive.hs @@ -0,0 +1,1038 @@ +module UnitTests.Distribution.Client.Init.Interactive +( tests +) where + + +import Prelude as P +import Test.Tasty +import Test.Tasty.HUnit + +import Distribution.Client.Init.Defaults +import Distribution.Client.Init.Interactive.Command +import Distribution.Client.Init.Types + +import qualified Distribution.SPDX as SPDX + +import Data.List.NonEmpty hiding (zip) +import Distribution.Client.Types +import Distribution.Simple.PackageIndex hiding (fromList) +import Distribution.Types.PackageName +import Distribution.Types.Version +import Distribution.Verbosity + +import Language.Haskell.Extension + +import UnitTests.Distribution.Client.Init.Utils +import Distribution.Client.Init.FlagExtractors +import Distribution.Simple.Setup +import Distribution.CabalSpecVersion +import qualified Data.Set as Set +import Distribution.FieldGrammar.Newtypes + + +-- -------------------------------------------------------------------- -- +-- Init Test main + +tests + :: Verbosity + -> InitFlags + -> InstalledPackageIndex + -> SourcePackageDb + -> TestTree +tests _v initFlags pkgIx srcDb = + testGroup "Distribution.Client.Init.Interactive.Command.hs" + [ createProjectTest pkgIx srcDb + , fileCreatorTests pkgIx srcDb pkgName + , interactiveTests srcDb + ] + where + pkgName = evalPrompt (packageNamePrompt srcDb initFlags) $ + fromList ["test-package", "y"] + + -- pkgNm = evalPrompt (getPackageName srcDb initFlags) $ fromList ["test-package", "y"] + +createProjectTest + :: InstalledPackageIndex + -> SourcePackageDb + -> TestTree +createProjectTest pkgIx srcDb = testGroup "createProject tests" + [ testGroup "with flags" + [ testCase "Check the interactive workflow" $ do + let dummyFlags' = dummyFlags + { packageType = Flag LibraryAndExecutable + , minimal = Flag False + , overwrite = Flag False + , packageDir = Flag "/home/test/test-package" + , extraSrc = NoFlag + , exposedModules = Flag [] + , otherModules = Flag [] + , otherExts = Flag [] + , buildTools = Flag [] + , mainIs = Flag "quxApp/Main.hs" + , dependencies = Flag [] + } + + case (_runPrompt $ createProject silent pkgIx srcDb dummyFlags') (fromList ["n", "3", "quxTest/Main.hs"]) of + Right (ProjectSettings opts desc (Just lib) (Just exe) (Just test), _) -> do + _optOverwrite opts @?= False + _optMinimal opts @?= False + _optNoComments opts @?= True + _optVerbosity opts @?= silent + _optPkgDir opts @?= "/home/test/test-package" + _optPkgType opts @?= LibraryAndExecutable + _optPkgName opts @?= mkPackageName "QuxPackage" + + _pkgCabalVersion desc @?= CabalSpecV2_2 + _pkgName desc @?= mkPackageName "QuxPackage" + _pkgVersion desc @?= mkVersion [4,2,6] + _pkgLicense desc @?! (SpecLicense . Left $ SPDX.NONE) + _pkgAuthor desc @?= "Foobar" + _pkgEmail desc @?= "foobar@qux.com" + _pkgHomePage desc @?= "qux.com" + _pkgSynopsis desc @?= "We are Qux, and this is our package" + _pkgCategory desc @?= "Control" + _pkgExtraSrcFiles desc @?= mempty + _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md") + + _libSourceDirs lib @?= ["quxSrc"] + _libLanguage lib @?= Haskell98 + _libExposedModules lib @?= myLibModule :| [] + _libOtherModules lib @?= [] + _libOtherExts lib @?= [] + _libDependencies lib @?= [] + _libBuildTools lib @?= [] + + _exeMainIs exe @?= HsFilePath "quxApp/Main.hs" Standard + _exeApplicationDirs exe @?= ["quxApp"] + _exeLanguage exe @?= Haskell98 + _exeOtherModules exe @?= [] + _exeOtherExts exe @?= [] + _exeDependencies exe @?! [] + _exeBuildTools exe @?= [] + + _testMainIs test @?= HsFilePath "quxTest/Main.hs" Standard + _testDirs test @?= ["quxTest"] + _testLanguage test @?= Haskell98 + _testOtherModules test @?= [] + _testOtherExts test @?= [] + _testDependencies test @?! [] + _testBuildTools test @?= [] + + Right (ProjectSettings _ _ lib exe test, _) -> do + lib @?! Nothing + exe @?! Nothing + test @?! Nothing + Left e -> assertFailure $ show e + ] + + , testGroup "with tests" + [ testCase "Check the interactive library and executable workflow" $ do + let inputs = fromList + -- package type + [ "3" + -- overwrite + , "n" + -- package dir + , "test-package" + -- package description + -- cabal version + , "4" + -- package name + , "test-package" + , "test-package" + , "test-package" + -- version + , "3.1.2.3" + -- license + , "3" + -- author + , "git username" + , "Foobar" + -- email + , "git email" + , "foobar@qux.com" + -- homepage + , "qux.com" + -- synopsis + , "Qux's package" + -- category + , "3" + -- library target + -- source dir + , "1" + -- language + , "2" + -- executable target + -- main file + , "1" + -- application dir + , "2" + -- language + , "2" + -- test target + , "y" + -- main file + , "1" + -- test dir + , "test" + -- language + , "1" + -- comments + , "y" + ] + + case (_runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of + Right (ProjectSettings opts desc (Just lib) (Just exe) (Just test), _) -> do + _optOverwrite opts @?= False + _optMinimal opts @?= False + _optNoComments opts @?= False + _optVerbosity opts @?= silent + _optPkgDir opts @?= "/home/test/test-package" + _optPkgType opts @?= LibraryAndExecutable + _optPkgName opts @?= mkPackageName "test-package" + + _pkgCabalVersion desc @?= CabalSpecV2_4 + _pkgName desc @?= mkPackageName "test-package" + _pkgVersion desc @?= mkVersion [3,1,2,3] + _pkgLicense desc @?! (SpecLicense . Left $ SPDX.NONE) + _pkgAuthor desc @?= "Foobar" + _pkgEmail desc @?= "foobar@qux.com" + _pkgHomePage desc @?= "qux.com" + _pkgSynopsis desc @?= "Qux's package" + _pkgCategory desc @?= "Control" + _pkgExtraSrcFiles desc @?= mempty + _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md") + + _libSourceDirs lib @?= ["src"] + _libLanguage lib @?= Haskell98 + _libExposedModules lib @?= myLibModule :| [] + _libOtherModules lib @?= [] + _libOtherExts lib @?= [] + _libDependencies lib @?! [] + _libBuildTools lib @?= [] + + _exeMainIs exe @?= HsFilePath "Main.hs" Standard + _exeApplicationDirs exe @?= ["exe"] + _exeLanguage exe @?= Haskell98 + _exeOtherModules exe @?= [] + _exeOtherExts exe @?= [] + _exeDependencies exe @?! [] + _exeBuildTools exe @?= [] + + _testMainIs test @?= HsFilePath "Main.hs" Standard + _testDirs test @?= ["test"] + _testLanguage test @?= Haskell2010 + _testOtherModules test @?= [] + _testOtherExts test @?= [] + _testDependencies test @?! [] + _testBuildTools test @?= [] + + Right (ProjectSettings _ _ lib exe test, _) -> do + lib @?! Nothing + exe @?! Nothing + test @?! Nothing + Left e -> assertFailure $ show e + + , testCase "Check the interactive library workflow" $ do + let inputs = fromList + -- package type + [ "1" + -- overwrite + , "n" + -- package dir + , "test-package" + -- package description + -- cabal version + , "4" + -- package name + , "test-package" + , "test-package" + , "test-package" + -- version + , "3.1.2.3" + -- license + , "3" + -- author + , "git username" + , "Foobar" + -- email + , "git email" + , "foobar@qux.com" + -- homepage + , "qux.com" + -- synopsis + , "Qux's package" + -- category + , "3" + -- library target + -- source dir + , "1" + -- language + , "2" + -- test target + , "y" + -- main file + , "1" + -- test dir + , "test" + -- language + , "1" + -- comments + , "y" + ] + + case (_runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of + Right (ProjectSettings opts desc (Just lib) Nothing (Just test), _) -> do + _optOverwrite opts @?= False + _optMinimal opts @?= False + _optNoComments opts @?= False + _optVerbosity opts @?= silent + _optPkgDir opts @?= "/home/test/test-package" + _optPkgType opts @?= Library + _optPkgName opts @?= mkPackageName "test-package" + + _pkgCabalVersion desc @?= CabalSpecV2_4 + _pkgName desc @?= mkPackageName "test-package" + _pkgVersion desc @?= mkVersion [3,1,2,3] + _pkgLicense desc @?! (SpecLicense . Left $ SPDX.NONE) + _pkgAuthor desc @?= "Foobar" + _pkgEmail desc @?= "foobar@qux.com" + _pkgHomePage desc @?= "qux.com" + _pkgSynopsis desc @?= "Qux's package" + _pkgCategory desc @?= "Control" + _pkgExtraSrcFiles desc @?= mempty + _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md") + + _libSourceDirs lib @?= ["src"] + _libLanguage lib @?= Haskell98 + _libExposedModules lib @?= myLibModule :| [] + _libOtherModules lib @?= [] + _libOtherExts lib @?= [] + _libDependencies lib @?! [] + _libBuildTools lib @?= [] + + _testMainIs test @?= HsFilePath "Main.hs" Standard + _testDirs test @?= ["test"] + _testLanguage test @?= Haskell2010 + _testOtherModules test @?= [] + _testOtherExts test @?= [] + _testDependencies test @?! [] + _testBuildTools test @?= [] + + Right (ProjectSettings _ _ lib exe test, _) -> do + lib @?! Nothing + exe @?= Nothing + test @?! Nothing + Left e -> assertFailure $ show e + + , testCase "Check the interactive library workflow" $ do + let inputs = fromList + -- package type + [ "4" + -- overwrite + , "n" + -- package dir + , "test-package" + -- package description + -- cabal version + , "4" + -- package name + , "test-package" + , "test-package" + , "test-package" + -- version + , "3.1.2.3" + -- license + , "3" + -- author + , "git username" + , "Foobar" + -- email + , "git email" + , "foobar@qux.com" + -- homepage + , "qux.com" + -- synopsis + , "Qux's package" + -- category + , "3" + -- test target + -- main file + , "1" + -- test dir + , "test" + -- language + , "1" + -- comments + , "y" + ] + + case (_runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of + Right (ProjectSettings opts desc Nothing Nothing (Just test), _) -> do + _optOverwrite opts @?= False + _optMinimal opts @?= False + _optNoComments opts @?= False + _optVerbosity opts @?= silent + _optPkgDir opts @?= "/home/test/test-package" + _optPkgType opts @?= TestSuite + _optPkgName opts @?= mkPackageName "test-package" + + _pkgCabalVersion desc @?= CabalSpecV2_4 + _pkgName desc @?= mkPackageName "test-package" + _pkgVersion desc @?= mkVersion [3,1,2,3] + _pkgLicense desc @?! (SpecLicense . Left $ SPDX.NONE) + _pkgAuthor desc @?= "Foobar" + _pkgEmail desc @?= "foobar@qux.com" + _pkgHomePage desc @?= "qux.com" + _pkgSynopsis desc @?= "Qux's package" + _pkgCategory desc @?= "Control" + _pkgExtraSrcFiles desc @?= mempty + _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md") + + _testMainIs test @?= HsFilePath "Main.hs" Standard + _testDirs test @?= ["test"] + _testLanguage test @?= Haskell2010 + _testOtherModules test @?= [] + _testOtherExts test @?= [] + _testDependencies test @?! [] + _testBuildTools test @?= [] + + Right (ProjectSettings _ _ lib exe test, _) -> do + lib @?= Nothing + exe @?= Nothing + test @?! Nothing + Left e -> assertFailure $ show e + ] + , testGroup "without tests" + [ testCase "Check the interactive library and executable workflow" $ do + let inputs = fromList + -- package type + [ "3" + -- overwrite + , "n" + -- package dir + , "test-package" + -- package description + -- cabal version + , "4" + -- package name + , "test-package" + , "test-package" + , "test-package" + -- version + , "3.1.2.3" + -- license + , "3" + -- author + , "git username" + , "Foobar" + -- email + , "git email" + , "foobar@qux.com" + -- homepage + , "qux.com" + -- synopsis + , "Qux's package" + -- category + , "3" + -- library target + -- source dir + , "1" + -- language + , "2" + -- executable target + -- main file + , "1" + -- application dir + , "2" + -- language + , "2" + -- test suite + , "n" + -- comments + , "y" + ] + + case (_runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of + Right (ProjectSettings opts desc (Just lib) (Just exe) Nothing, _) -> do + _optOverwrite opts @?= False + _optMinimal opts @?= False + _optNoComments opts @?= False + _optVerbosity opts @?= silent + _optPkgDir opts @?= "/home/test/test-package" + _optPkgType opts @?= LibraryAndExecutable + _optPkgName opts @?= mkPackageName "test-package" + + _pkgCabalVersion desc @?= CabalSpecV2_4 + _pkgName desc @?= mkPackageName "test-package" + _pkgVersion desc @?= mkVersion [3,1,2,3] + _pkgLicense desc @?! (SpecLicense . Left $ SPDX.NONE) + _pkgAuthor desc @?= "Foobar" + _pkgEmail desc @?= "foobar@qux.com" + _pkgHomePage desc @?= "qux.com" + _pkgSynopsis desc @?= "Qux's package" + _pkgCategory desc @?= "Control" + _pkgExtraSrcFiles desc @?= mempty + _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md") + + _libSourceDirs lib @?= ["src"] + _libLanguage lib @?= Haskell98 + _libExposedModules lib @?= myLibModule :| [] + _libOtherModules lib @?= [] + _libOtherExts lib @?= [] + _libDependencies lib @?! [] + _libBuildTools lib @?= [] + + _exeMainIs exe @?= HsFilePath "Main.hs" Standard + _exeApplicationDirs exe @?= ["exe"] + _exeLanguage exe @?= Haskell98 + _exeOtherModules exe @?= [] + _exeOtherExts exe @?= [] + _exeDependencies exe @?! [] + _exeBuildTools exe @?= [] + + Right (ProjectSettings _ _ lib exe test, _) -> do + lib @?! Nothing + exe @?! Nothing + test @?= Nothing + Left e -> assertFailure $ show e + + , testCase "Check the interactive library workflow" $ do + let inputs = fromList + -- package type + [ "1" + -- overwrite + , "n" + -- package dir + , "test-package" + -- package description + -- cabal version + , "4" + -- package name + , "test-package" + , "test-package" + , "test-package" + -- version + , "3.1.2.3" + -- license + , "3" + -- author + , "git username" + , "Foobar" + -- email + , "git email" + , "foobar@qux.com" + -- homepage + , "qux.com" + -- synopsis + , "Qux's package" + -- category + , "3" + -- library target + -- source dir + , "1" + -- language + , "2" + -- test suite + , "n" + -- comments + , "y" + ] + + case (_runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of + Right (ProjectSettings opts desc (Just lib) Nothing Nothing, _) -> do + _optOverwrite opts @?= False + _optMinimal opts @?= False + _optNoComments opts @?= False + _optVerbosity opts @?= silent + _optPkgDir opts @?= "/home/test/test-package" + _optPkgType opts @?= Library + _optPkgName opts @?= mkPackageName "test-package" + + _pkgCabalVersion desc @?= CabalSpecV2_4 + _pkgName desc @?= mkPackageName "test-package" + _pkgVersion desc @?= mkVersion [3,1,2,3] + _pkgLicense desc @?! (SpecLicense . Left $ SPDX.NONE) + _pkgAuthor desc @?= "Foobar" + _pkgEmail desc @?= "foobar@qux.com" + _pkgHomePage desc @?= "qux.com" + _pkgSynopsis desc @?= "Qux's package" + _pkgCategory desc @?= "Control" + _pkgExtraSrcFiles desc @?= mempty + _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md") + + _libSourceDirs lib @?= ["src"] + _libLanguage lib @?= Haskell98 + _libExposedModules lib @?= myLibModule :| [] + _libOtherModules lib @?= [] + _libOtherExts lib @?= [] + _libDependencies lib @?! [] + _libBuildTools lib @?= [] + + Right (ProjectSettings _ _ lib exe test, _) -> do + lib @?! Nothing + exe @?= Nothing + test @?= Nothing + Left e -> assertFailure $ show e + + , testCase "Check the interactive library workflow - cabal < 1.18" $ do + let inputs = fromList + -- package type + [ "1" + -- overwrite + , "n" + -- package dir + , "test-package" + -- package description + -- cabal version + , "4" + -- package name + , "test-package" + , "test-package" + , "test-package" + -- version + , "3.1.2.3" + -- license + , "3" + -- author + , "git username" + , "Foobar" + -- email + , "git email" + , "foobar@qux.com" + -- homepage + , "qux.com" + -- synopsis + , "Qux's package" + -- category + , "3" + -- library target + -- source dir + , "1" + -- language + , "2" + -- test suite + , "n" + -- comments + , "y" + ] + + flags = emptyFlags + { cabalVersion = Flag CabalSpecV1_10 + , extraDoc = Flag [defaultChangelog] + , extraSrc = Flag ["README.md"] + } + + case (_runPrompt $ createProject silent pkgIx srcDb flags) inputs of + Right (ProjectSettings opts desc (Just lib) Nothing Nothing, _) -> do + _optOverwrite opts @?= False + _optMinimal opts @?= False + _optNoComments opts @?= False + _optVerbosity opts @?= silent + _optPkgDir opts @?= "/home/test/test-package" + _optPkgType opts @?= Library + _optPkgName opts @?= mkPackageName "test-package" + + _pkgCabalVersion desc @?= CabalSpecV1_10 + _pkgName desc @?= mkPackageName "test-package" + _pkgVersion desc @?= mkVersion [3,1,2,3] + _pkgLicense desc @?! (SpecLicense . Left $ SPDX.NONE) + _pkgAuthor desc @?= "Foobar" + _pkgEmail desc @?= "foobar@qux.com" + _pkgHomePage desc @?= "qux.com" + _pkgSynopsis desc @?= "Qux's package" + _pkgCategory desc @?= "Control" + _pkgExtraSrcFiles desc @?= Set.fromList [defaultChangelog, "README.md"] + _pkgExtraDocFiles desc @?= Nothing + + _libSourceDirs lib @?= ["src"] + _libLanguage lib @?= Haskell98 + _libExposedModules lib @?= myLibModule :| [] + _libOtherModules lib @?= [] + _libOtherExts lib @?= [] + _libDependencies lib @?! [] + _libBuildTools lib @?= [] + + Right (ProjectSettings _ _ lib exe test, _) -> do + lib @?! Nothing + exe @?= Nothing + test @?= Nothing + Left e -> assertFailure $ show e + + , testCase "Check the interactive executable workflow" $ do + let inputs = fromList + -- package type + [ "2" + -- overwrite + , "n" + -- package dir + , "test-package" + -- package description + -- cabal version + , "4" + -- package name + , "test-package" + , "test-package" + , "test-package" + -- version + , "3.1.2.3" + -- license + , "3" + -- author + , "git username" + , "Foobar" + -- email + , "git email" + , "foobar@qux.com" + -- homepage + , "qux.com" + -- synopsis + , "Qux's package" + -- category + , "3" + -- executable target + -- main file + , "1" + -- application dir + , "2" + -- language + , "2" + -- comments + , "y" + ] + + case (_runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of + Right (ProjectSettings opts desc Nothing (Just exe) Nothing, _) -> do + _optOverwrite opts @?= False + _optMinimal opts @?= False + _optNoComments opts @?= False + _optVerbosity opts @?= silent + _optPkgDir opts @?= "/home/test/test-package" + _optPkgType opts @?= Executable + _optPkgName opts @?= mkPackageName "test-package" + + _pkgCabalVersion desc @?= CabalSpecV2_4 + _pkgName desc @?= mkPackageName "test-package" + _pkgVersion desc @?= mkVersion [3,1,2,3] + _pkgLicense desc @?! (SpecLicense . Left $ SPDX.NONE) + _pkgAuthor desc @?= "Foobar" + _pkgEmail desc @?= "foobar@qux.com" + _pkgHomePage desc @?= "qux.com" + _pkgSynopsis desc @?= "Qux's package" + _pkgCategory desc @?= "Control" + _pkgExtraSrcFiles desc @?= mempty + _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md") + + _exeMainIs exe @?= HsFilePath "Main.hs" Standard + _exeApplicationDirs exe @?= ["exe"] + _exeLanguage exe @?= Haskell98 + _exeOtherModules exe @?= [] + _exeOtherExts exe @?= [] + _exeDependencies exe @?! [] + _exeBuildTools exe @?= [] + + Right (ProjectSettings _ _ lib exe test, _) -> do + lib @?= Nothing + exe @?! Nothing + test @?= Nothing + Left e -> assertFailure $ show e + ] + ] + +fileCreatorTests :: InstalledPackageIndex -> SourcePackageDb -> PackageName -> TestTree +fileCreatorTests pkgIx srcDb _pkgName = testGroup "generators" + [ testGroup "genPkgDescription" + [ testCase "Check common package flags workflow" $ do + let inputs = fromList + [ "1" -- pick the first cabal version in the list + , "my-test-package" -- package name + , "my-test-package" -- current dir for the purpose of guessing the package name + , "y" -- "yes to prompt internal to package name" + , "0.2.0.1" -- package version + , "2" -- pick the second license in the list + , "git username" -- name guessed by calling "git config user.name" + , "Foobar" -- author name + , "git email" -- email guessed by calling "git config user.email" + , "foobar@qux.com" -- maintainer email + , "qux.com" -- package homepage + , "Qux's package" -- package synopsis + , "3" -- pick the third category in the list + ] + runGenTest inputs $ genPkgDescription emptyFlags srcDb + ] + , testGroup "genLibTarget" + [ testCase "Check library package flags workflow" $ do + let inputs = fromList + [ "1" -- pick the first source directory in the list + , "2" -- pick the second language in the list + ] + + runGenTest inputs $ genLibTarget emptyFlags pkgIx + ] + , testGroup "genExeTarget" + [ testCase "Check executable package flags workflow" $ do + let inputs = fromList + [ "1" -- pick the first main file option in the list + , "2" -- pick the second application directory in the list + , "1" -- pick the first language in the list + ] + + runGenTest inputs $ genExeTarget emptyFlags pkgIx + ] + , testGroup "genTestTarget" + [ testCase "Check test package flags workflow" $ do + let inputs = fromList + [ "y" -- say yes to tests + , "1" -- pick the first main file option in the list + , "test" -- package test dir + , "1" -- pick the first language in the list + ] + + runGenTest inputs $ genTestTarget emptyFlags pkgIx + ] + ] + where + runGenTest inputs go = case _runPrompt go inputs of + Left e -> assertFailure $ show e + Right{} -> return () + +interactiveTests :: SourcePackageDb -> TestTree +interactiveTests srcDb = testGroup "Check top level getter functions" + [ testGroup "Simple prompt tests" + [ testGroup "Check packageNamePrompt output" + [ testSimplePrompt "New package name 1" + (packageNamePrompt srcDb) (mkPackageName "test-package") + [ "test-package" + , "test-package" + , "test-package" + ] + , testSimplePrompt "New package name 2" + (packageNamePrompt srcDb) (mkPackageName "test-package") + [ "test-package" + , "test-package" + , "" + ] + , testSimplePrompt "Existing package name 1" + (packageNamePrompt srcDb) (mkPackageName "test-package") + [ "test-package" + , "test-package" + , "cabal-install" + , "y" + , "test-package" + ] + , testSimplePrompt "Existing package name 2" + (packageNamePrompt srcDb) (mkPackageName "cabal-install") + [ "test-package" + , "test-package" + , "cabal-install" + , "n" + ] + ] + , testGroup "Check mainFilePrompt output" + [ testSimplePrompt "New valid main file" + mainFilePrompt defaultMainIs + [ "1" + ] + , testSimplePrompt "New valid other main file" + mainFilePrompt (HsFilePath "Main.hs" Standard) + [ "3" + , "Main.hs" + ] + , testSimplePrompt "Invalid other main file" + mainFilePrompt (HsFilePath "Main.lhs" Literate) + [ "3" + , "Yoink.jl" + , "2" + ] + ] + , testGroup "Check versionPrompt output" + [ testSimplePrompt "Proper PVP" + versionPrompt (mkVersion [0,3,1,0]) + [ "0.3.1.0" + ] + , testSimplePrompt "No PVP" + versionPrompt (mkVersion [0,3,1,0]) + [ "yee-haw" + , "0.3.1.0" + ] + ] + , testGroup "Check synopsisPrompt output" + [ testSimplePrompt "1" synopsisPrompt + "We are Qux, and this is our package" ["We are Qux, and this is our package"] + , testSimplePrompt "2" synopsisPrompt + "Resistance is futile, you will be assimilated" ["Resistance is futile, you will be assimilated"] + ] + , testSimplePrompt "Check authorPrompt output (name supplied by the user)" authorPrompt + "Foobar" ["git username", "Foobar"] + , testSimplePrompt "Check authorPrompt output (name guessed from git config)" authorPrompt + "git username" ["git username", ""] + , testSimplePrompt "Check emailPrompt output (email supplied by the user)" emailPrompt + "foobar@qux.com" ["git email", "foobar@qux.com"] + , testSimplePrompt "Check emailPrompt output (email guessed from git config)" emailPrompt + "git@email" ["git@email", ""] + , testSimplePrompt "Check homepagePrompt output" homepagePrompt + "qux.com" ["qux.com"] + , testSimplePrompt "Check testDirsPrompt output" testDirsPrompt + ["quxTest"] ["quxTest"] + -- this tests 4) other, and can be used to model more inputs in case of failure + , testSimplePrompt "Check srcDirsPrompt output" srcDirsPrompt + ["app"] ["4", "app"] + ] + , testGroup "Numbered prompt tests" + [ testGroup "Check categoryPrompt output" + [ testNumberedPrompt "Category indices" categoryPrompt + defaultCategories + , testSimplePrompt "Other category" + categoryPrompt "Unlisted" + [ show $ P.length defaultCategories + 1 + , "Unlisted" + ] + , testSimplePrompt "No category" + categoryPrompt "" + [ "" + ] + ] + , testGroup "Check licensePrompt output" $ let other = show (1 + P.length defaultLicenseIds) in + [ testNumberedPrompt "License indices" licensePrompt $ + fmap (\l -> SpecLicense . Left . SPDX.License $ SPDX.ELicense (SPDX.ELicenseId l) Nothing) defaultLicenseIds + , testSimplePrompt "Other license 1" + licensePrompt (SpecLicense . Left $ mkLicense SPDX.CC_BY_NC_ND_4_0) + [ other + , "CC-BY-NC-ND-4.0" + ] + , testSimplePrompt "Other license 2" + licensePrompt (SpecLicense . Left $ mkLicense SPDX.D_FSL_1_0) + [ other + , "D-FSL-1.0" + ] + , testSimplePrompt "Other license 3" + licensePrompt (SpecLicense . Left $ mkLicense SPDX.NPOSL_3_0) + [ other + , "NPOSL-3.0" + ] + , testSimplePrompt "Invalid license" + licensePrompt (SpecLicense $ Left SPDX.NONE) + [ other + , "yay" + , other + , "NONE" + ] + , testPromptBreak "Invalid index" + licensePrompt + [ "42" + ] + ] + , testGroup "Check languagePrompt output" + [ testNumberedPrompt "Language indices" (`languagePrompt` "test") + [Haskell2010, Haskell98, GHC2021] + , testSimplePrompt "Other language" + (`languagePrompt` "test") (UnknownLanguage "Haskell2022") + [ "4" + , "Haskell2022" + ] + , testSimplePrompt "Invalid language" + (`languagePrompt` "test") Haskell2010 + [ "4" + , "Lang_TS!" + , "1" + ] + ] + , testGroup "Check srcDirsPrompt output" + [ testNumberedPrompt "Soruce dirs indices" srcDirsPrompt + [[defaultSourceDir], ["lib"], ["src-lib"]] + , testSimplePrompt "Other source dir" + srcDirsPrompt ["src"] + [ "4" + , "src" + ] + ] + , testGroup "Check appDirsPrompt output" + [ testNumberedPrompt "App dirs indices" appDirsPrompt + [[defaultApplicationDir], ["exe"], ["src-exe"]] + , testSimplePrompt "Other app dir" + appDirsPrompt ["app"] + [ "4" + , "app" + ] + ] + , testNumberedPrompt "Check packageTypePrompt output" packageTypePrompt + [Library, Executable, LibraryAndExecutable] + , testNumberedPrompt "Check cabalVersionPrompt output" cabalVersionPrompt + defaultCabalVersions + ] + , testGroup "Bool prompt tests" + [ testBoolPrompt "Check noCommentsPrompt output - y" noCommentsPrompt False "y" + , testBoolPrompt "Check noCommentsPrompt output - Y" noCommentsPrompt False "Y" + , testBoolPrompt "Check noCommentsPrompt output - n" noCommentsPrompt True "n" + , testBoolPrompt "Check noCommentsPrompt output - N" noCommentsPrompt True "N" + ] + ] + + + +-- -------------------------------------------------------------------- -- +-- Prompt test utils + + +testSimplePrompt + :: Eq a + => Show a + => String + -> (InitFlags -> PurePrompt a) + -> a + -> [String] + -> TestTree +testSimplePrompt label f target = + testPrompt label f (assertFailure . show) (\(a,_) -> target @=? a) + +testPromptBreak + :: Eq a + => Show a + => String + -> (InitFlags -> PurePrompt a) + -> [String] + -> TestTree +testPromptBreak label f = + testPrompt label f go (assertFailure . show) + where + go BreakException{} = + return () + +testPrompt + :: Eq a + => Show a + => String + -> (InitFlags -> PurePrompt a) + -> (BreakException -> Assertion) + -> ((a, NonEmpty String) -> Assertion) + -> [String] + -> TestTree +testPrompt label f g h input = testCase label $ + case (_runPrompt $ f emptyFlags) (fromList input) of + Left x -> g x -- :: BreakException + Right x -> h x -- :: (a, other inputs) + +testNumberedPrompt :: (Eq a, Show a) => String -> (InitFlags -> PurePrompt a) -> [a] -> TestTree +testNumberedPrompt label act = testGroup label . (++ goBreak) . fmap go . indexed1 + where + indexed1 = zip [1 :: Int ..] + mkLabel a n = "testing index " + ++ show n + ++ ") with: " + ++ show a + + go (n, a) = + testSimplePrompt (mkLabel a n) act a [show n] + goBreak = + [ testPromptBreak "testing index -1" act ["-1"] + , testPromptBreak "testing index 1000" act ["1000"] + ] + +testBoolPrompt + :: String + -> (InitFlags -> PurePrompt Bool) + -> Bool + -> String + -> TestTree +testBoolPrompt label act target b = + testSimplePrompt label act target [b] diff --git a/cabal/cabal-install/tests/UnitTests/Distribution/Client/Init/NonInteractive.hs b/cabal/cabal-install/tests/UnitTests/Distribution/Client/Init/NonInteractive.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/UnitTests/Distribution/Client/Init/NonInteractive.hs @@ -0,0 +1,1267 @@ +module UnitTests.Distribution.Client.Init.NonInteractive + ( tests + ) where + +import Test.Tasty +import Test.Tasty.HUnit + +import UnitTests.Distribution.Client.Init.Utils + +import qualified Data.List.NonEmpty as NEL +import qualified Distribution.SPDX as SPDX + +import Distribution.Client.Init.Defaults +import Distribution.Client.Init.NonInteractive.Command +import Distribution.Client.Init.Types +import Distribution.Client.Types +import Distribution.Simple +import Distribution.Simple.PackageIndex +import Distribution.Verbosity +import Distribution.CabalSpecVersion +import Distribution.ModuleName (fromString) +import Distribution.Simple.Flag +import Data.List (foldl') +import qualified Data.Set as Set +import Distribution.Client.Init.Utils (mkPackageNameDep, mkStringyDep) +import Distribution.FieldGrammar.Newtypes + +tests + :: Verbosity + -> InitFlags + -> Compiler + -> InstalledPackageIndex + -> SourcePackageDb + -> TestTree +tests _v _initFlags comp pkgIx srcDb = + testGroup "Distribution.Client.Init.NonInteractive.Command" + [ testGroup "driver function test" + [ driverFunctionTest pkgIx srcDb comp + ] + , testGroup "target creator tests" + [ fileCreatorTests pkgIx srcDb comp + ] + , testGroup "non-interactive tests" + [ nonInteractiveTests pkgIx srcDb comp + ] + ] + +driverFunctionTest + :: InstalledPackageIndex + -> SourcePackageDb + -> Compiler + -> TestTree +driverFunctionTest pkgIx srcDb comp = testGroup "createProject" + [ testGroup "with flags" + [ testCase "Check the non-interactive workflow 1" $ do + let dummyFlags' = dummyFlags + { packageType = Flag LibraryAndExecutable + , minimal = Flag False + , overwrite = Flag False + , packageDir = Flag "/home/test/test-package" + , extraDoc = Flag ["CHANGELOG.md"] + , exposedModules = Flag [] + , otherModules = Flag [] + , otherExts = Flag [] + , buildTools = Flag [] + , mainIs = Flag "quxApp/Main.hs" + , dependencies = Flag [] + } + inputs = NEL.fromList + [ "True" + , "[\"quxTest/Main.hs\"]" + ] + + case (_runPrompt $ createProject comp silent pkgIx srcDb dummyFlags') inputs of + Right (ProjectSettings opts desc (Just lib) (Just exe) (Just test), _) -> do + _optOverwrite opts @?= False + _optMinimal opts @?= False + _optNoComments opts @?= True + _optVerbosity opts @?= silent + _optPkgDir opts @?= "/home/test/test-package" + _optPkgType opts @?= LibraryAndExecutable + _optPkgName opts @?= mkPackageName "QuxPackage" + + _pkgCabalVersion desc @?= CabalSpecV2_2 + _pkgName desc @?= mkPackageName "QuxPackage" + _pkgVersion desc @?= mkVersion [4,2,6] + _pkgLicense desc @?! (SpecLicense . Left $ SPDX.NONE) + _pkgAuthor desc @?= "Foobar" + _pkgEmail desc @?= "foobar@qux.com" + _pkgHomePage desc @?= "qux.com" + _pkgSynopsis desc @?= "We are Qux, and this is our package" + _pkgCategory desc @?= "Control" + _pkgExtraSrcFiles desc @?= mempty + _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md") + + _libSourceDirs lib @?= ["quxSrc"] + _libLanguage lib @?= Haskell98 + _libExposedModules lib @?= myLibModule NEL.:| [] + _libOtherModules lib @?= [] + _libOtherExts lib @?= [] + _libDependencies lib @?= [] + _libBuildTools lib @?= [] + + _exeMainIs exe @?= HsFilePath "quxApp/Main.hs" Standard + _exeApplicationDirs exe @?= ["quxApp"] + _exeLanguage exe @?= Haskell98 + _exeOtherModules exe @?= [] + _exeOtherExts exe @?= [] + _exeDependencies exe @?! [] + _exeBuildTools exe @?= [] + + _testMainIs test @?= HsFilePath "quxTest/Main.hs" Standard + _testDirs test @?= ["quxTest"] + _testLanguage test @?= Haskell98 + _testOtherModules test @?= [] + _testOtherExts test @?= [] + _testDependencies test @?! [] + _testBuildTools test @?= [] + + assertBool "The library should be a dependency of the executable" $ + mkPackageNameDep (_optPkgName opts) `elem` _exeDependencies exe + assertBool "The library should be a dependency of the test executable" $ + mkPackageNameDep (_optPkgName opts) `elem` _testDependencies test + + Right (ProjectSettings _ _ lib exe test, _) -> do + lib @?! Nothing + exe @?! Nothing + test @?! Nothing + Left e -> assertFailure $ show e + + , testCase "Check the non-interactive workflow 2" $ do + let dummyFlags' = dummyFlags + { packageType = Flag LibraryAndExecutable + , minimal = Flag False + , overwrite = Flag False + , packageDir = Flag "/home/test/test-package" + , extraSrc = Flag [] + , exposedModules = Flag [] + , otherModules = NoFlag + , otherExts = Flag [] + , buildTools = Flag [] + , mainIs = Flag "quxApp/Main.hs" + , dependencies = Flag [] + } + inputs = NEL.fromList + -- extra sources + [ "[\"CHANGELOG.md\"]" + -- lib other modules + , "False" + -- exe other modules + , "False" + -- test main file + , "True" + , "[\"quxTest/Main.hs\"]" + -- test other modules + , "False" + ] + + case (_runPrompt $ createProject comp silent pkgIx srcDb dummyFlags') inputs of + Right (ProjectSettings opts desc (Just lib) (Just exe) (Just test), _) -> do + _optOverwrite opts @?= False + _optMinimal opts @?= False + _optNoComments opts @?= True + _optVerbosity opts @?= silent + _optPkgDir opts @?= "/home/test/test-package" + _optPkgType opts @?= LibraryAndExecutable + _optPkgName opts @?= mkPackageName "QuxPackage" + + _pkgCabalVersion desc @?= CabalSpecV2_2 + _pkgName desc @?= mkPackageName "QuxPackage" + _pkgVersion desc @?= mkVersion [4,2,6] + _pkgLicense desc @?! (SpecLicense . Left $ SPDX.NONE) + _pkgAuthor desc @?= "Foobar" + _pkgEmail desc @?= "foobar@qux.com" + _pkgHomePage desc @?= "qux.com" + _pkgSynopsis desc @?= "We are Qux, and this is our package" + _pkgCategory desc @?= "Control" + _pkgExtraSrcFiles desc @?= mempty + _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md") + + _libSourceDirs lib @?= ["quxSrc"] + _libLanguage lib @?= Haskell98 + _libExposedModules lib @?= myLibModule NEL.:| [] + _libOtherModules lib @?= [] + _libOtherExts lib @?= [] + _libDependencies lib @?= [] + _libBuildTools lib @?= [] + + _exeMainIs exe @?= HsFilePath "quxApp/Main.hs" Standard + _exeApplicationDirs exe @?= ["quxApp"] + _exeLanguage exe @?= Haskell98 + _exeOtherModules exe @?= [] + _exeOtherExts exe @?= [] + _exeDependencies exe @?! [] + _exeBuildTools exe @?= [] + + _testMainIs test @?= HsFilePath "quxTest/Main.hs" Standard + _testDirs test @?= ["quxTest"] + _testLanguage test @?= Haskell98 + _testOtherModules test @?= [] + _testOtherExts test @?= [] + _testDependencies test @?! [] + _testBuildTools test @?= [] + + assertBool "The library should be a dependency of the executable" $ + mkPackageNameDep (_optPkgName opts) `elem` _exeDependencies exe + assertBool "The library should be a dependency of the test executable" $ + mkPackageNameDep (_optPkgName opts) `elem` _testDependencies test + + Right (ProjectSettings _ _ lib exe test, _) -> do + lib @?! Nothing + exe @?! Nothing + test @?! Nothing + Left e -> assertFailure $ show e + ] + , testGroup "with tests" + [ testCase "Check the non-interactive library and executable workflow" $ do + let inputs = NEL.fromList + -- package dir + [ "test-package" + -- package description + -- cabal version + , "cabal-install version 3.4.0.0\ncompiled using version 3.4.0.0 of the Cabal library \n" + -- package name + , "test-package" + , "test-package" + -- author name + , "" + , "Foobar" + -- author email + , "" + , "foobar@qux.com" + -- extra source files + , "test-package" + , "[]" + -- library target + -- source dirs + , "src" + , "True" + -- exposed modules + , "src" + , "True" + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + , "test-package" + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + -- other modules + , "test-package" + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\", \"src/Baz/Internal.hs\"]" + , "module Foo where" + , "module Bar where" + , "module Baz.Internal where" + -- other extensions + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\"]" + , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\"" + , "\"{-# LANGUAGE RecordWildCards #-}\"" + -- dependencies + , "True" + , "[\"src/Foo.hs\"]" + , "True" + , "test-package" + , "module Main where" + , "import Control.Monad.Extra" + , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}" + -- build tools + , "True" + , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]" + -- executable target + -- application dirs + , "app" + , "[]" + -- main file + , "test-package" + , "[\"test-package/app/\"]" + , "True" + , "[]" + -- other modules + , "test-package" + , "True" + , "[\"app/Main.hs\", \"app/Foo.hs\", \"app/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + -- other extensions + , "True" + , "[\"app/Foo.hs\", \"app/Bar.hs\"]" + , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\"" + , "\"{-# LANGUAGE RecordWildCards #-}\"" + -- dependencies + , "True" + , "[\"app/Main.hs\"]" + , "True" + , "test-package" + , "module Main where" + , "import Control.Monad.Extra" + , "{-# LANGUAGE OverloadedStrings, DataKinds #-}" + -- build tools + , "True" + , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]" + -- test target + -- main file + , "True" + , "[\"test-package/test/\"]" + -- other modules + , "test-package" + , "True" + , "[\"test/Main.hs\", \"test/Foo.hs\", \"test/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + -- other extensions + , "True" + , "[\"test/Foo.hs\", \"test/Bar.hs\"]" + , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\"" + , "\"{-# LANGUAGE RecordWildCards #-}\"" + -- dependencies + , "True" + , "[\"test/Main.hs\"]" + , "True" + , "test-package" + , "module Main where" + , "import Test.Tasty\nimport Test.Tasty.HUnit" + , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}" + -- build tools + , "True" + , "[\"test/Main.hs\", \"test/Foo.hs\", \"test/bar.y\"]" + ] + + case (_runPrompt $ createProject comp silent pkgIx srcDb (emptyFlags + { initializeTestSuite = Flag True + , packageType = Flag LibraryAndExecutable + })) inputs of + Right (ProjectSettings opts desc (Just lib) (Just exe) (Just test), _) -> do + _optOverwrite opts @?= False + _optMinimal opts @?= False + _optNoComments opts @?= False + _optVerbosity opts @?= silent + _optPkgDir opts @?= "/home/test/test-package" + _optPkgType opts @?= LibraryAndExecutable + _optPkgName opts @?= mkPackageName "test-package" + + _pkgCabalVersion desc @?= CabalSpecV3_4 + _pkgName desc @?= mkPackageName "test-package" + _pkgVersion desc @?= mkVersion [0,1,0,0] + _pkgLicense desc @?= (SpecLicense . Left $ SPDX.NONE) + _pkgAuthor desc @?= "Foobar" + _pkgEmail desc @?= "foobar@qux.com" + _pkgHomePage desc @?= "" + _pkgSynopsis desc @?= "" + _pkgCategory desc @?= "" + _pkgExtraSrcFiles desc @?= mempty + _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md") + + _libSourceDirs lib @?= ["src"] + _libLanguage lib @?= Haskell2010 + _libExposedModules lib @?= NEL.fromList (map fromString ["Foo", "Bar"]) + _libOtherModules lib @?= map fromString ["Baz.Internal"] + _libOtherExts lib @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards] + _libDependencies lib @?! [] + _libBuildTools lib @?= [mkStringyDep "happy:happy"] + + _exeMainIs exe @?= HsFilePath "Main.hs" Standard + _exeApplicationDirs exe @?= ["app"] + _exeLanguage exe @?= Haskell2010 + _exeOtherModules exe @?= map fromString ["Foo", "Bar"] + _exeOtherExts exe @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards] + _exeDependencies exe @?! [] + _exeBuildTools exe @?= [mkStringyDep "happy:happy"] + + _testMainIs test @?= HsFilePath "Main.hs" Standard + _testDirs test @?= ["test"] + _testLanguage test @?= Haskell2010 + _testOtherModules test @?= map fromString ["Foo", "Bar"] + _testOtherExts test @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards] + _testDependencies test @?! [] + _testBuildTools test @?= [mkStringyDep "happy:happy"] + + assertBool "The library should be a dependency of the executable" $ + mkPackageNameDep (_optPkgName opts) `elem` _exeDependencies exe + assertBool "The library should be a dependency of the test executable" $ + mkPackageNameDep (_optPkgName opts) `elem` _testDependencies test + + Right (ProjectSettings _ _ lib exe test, _) -> do + lib @?! Nothing + exe @?! Nothing + test @?! Nothing + Left e -> assertFailure $ show e + + , testCase "Check the non-interactive library workflow" $ do + let inputs = NEL.fromList + -- package dir + [ "test-package" + -- package description + -- cabal version + , "cabal-install version 3.4.0.0\ncompiled using version 3.4.0.0 of the Cabal library \n" + -- package name + , "test-package" + , "test-package" + -- author name + , "Foobar" + -- author email + , "foobar@qux.com" + -- extra source files + , "test-package" + , "[]" + -- library target + -- source dirs + , "src" + , "True" + -- exposed modules + , "src" + , "True" + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + , "test-package" + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + -- other modules + , "test-package" + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\", \"src/Baz/Internal.hs\"]" + , "module Foo where" + , "module Bar where" + , "module Baz.Internal where" + -- other extensions + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\"]" + , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\"" + , "\"{-# LANGUAGE RecordWildCards #-}\"" + -- dependencies + , "True" + , "[\"src/Foo.hs\"]" + , "True" + , "test-package" + , "module Main where" + , "import Control.Monad.Extra" + , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}" + -- build tools + , "True" + , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]" + -- test target + -- main file + , "True" + , "[\"test-package/test/\"]" + -- other modules + , "test-package" + , "True" + , "[\"test/Main.hs\", \"test/Foo.hs\", \"test/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + -- other extensions + , "True" + , "[\"test/Foo.hs\", \"test/Bar.hs\"]" + , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\"" + , "\"{-# LANGUAGE RecordWildCards #-}\"" + -- dependencies + , "True" + , "[\"test/Main.hs\"]" + , "True" + , "test-package" + , "module Main where" + , "import Test.Tasty\nimport Test.Tasty.HUnit" + , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}" + -- build tools + , "True" + , "[\"test/Main.hs\", \"test/Foo.hs\", \"test/bar.y\"]" + ] + + case (_runPrompt $ createProject comp silent pkgIx srcDb (emptyFlags + { initializeTestSuite = Flag True + , packageType = Flag Library + })) inputs of + Right (ProjectSettings opts desc (Just lib) Nothing (Just test), _) -> do + _optOverwrite opts @?= False + _optMinimal opts @?= False + _optNoComments opts @?= False + _optVerbosity opts @?= silent + _optPkgDir opts @?= "/home/test/test-package" + _optPkgType opts @?= Library + _optPkgName opts @?= mkPackageName "test-package" + + _pkgCabalVersion desc @?= CabalSpecV3_4 + _pkgName desc @?= mkPackageName "test-package" + _pkgVersion desc @?= mkVersion [0,1,0,0] + _pkgLicense desc @?= (SpecLicense . Left $ SPDX.NONE) + _pkgAuthor desc @?= "Foobar" + _pkgEmail desc @?= "foobar@qux.com" + _pkgHomePage desc @?= "" + _pkgSynopsis desc @?= "" + _pkgCategory desc @?= "" + _pkgExtraSrcFiles desc @?= mempty + _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md") + + _libSourceDirs lib @?= ["src"] + _libLanguage lib @?= Haskell2010 + _libExposedModules lib @?= NEL.fromList (map fromString ["Foo", "Bar"]) + _libOtherModules lib @?= map fromString ["Baz.Internal"] + _libOtherExts lib @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards] + _libDependencies lib @?! [] + _libBuildTools lib @?= [mkStringyDep "happy:happy"] + + _testMainIs test @?= HsFilePath "Main.hs" Standard + _testDirs test @?= ["test"] + _testLanguage test @?= Haskell2010 + _testOtherModules test @?= map fromString ["Foo", "Bar"] + _testOtherExts test @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards] + _testDependencies test @?! [] + _testBuildTools test @?= [mkStringyDep "happy:happy"] + + assertBool "The library should be a dependency of the test executable" $ + mkPackageNameDep (_optPkgName opts) `elem` _testDependencies test + + Right (ProjectSettings _ _ lib exe test, _) -> do + lib @?! Nothing + exe @?= Nothing + test @?! Nothing + Left e -> assertFailure $ show e + ] + , testGroup "without tests" + [ testCase "Check the non-interactive library and executable workflow" $ do + let inputs = NEL.fromList + -- package type + [ "test-package" + , "[\".\", \"..\", \"src/\", \"app/Main.hs\"]" + , "[\".\", \"..\", \"src/\", \"app/Main.hs\"]" + -- package dir + , "test-package" + -- package description + -- cabal version + , "cabal-install version 3.4.0.0\ncompiled using version 3.4.0.0 of the Cabal library \n" + -- package name + , "test-package" + , "test-package" + -- author name + , "" + , "Foobar" + -- author email + , "" + , "foobar@qux.com" + -- extra source files + , "test-package" + , "[]" + -- library target + -- source dirs + , "src" + , "True" + -- exposed modules + , "src" + , "True" + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + , "test-package" + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + -- other modules + , "test-package" + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\", \"src/Baz/Internal.hs\"]" + , "module Foo where" + , "module Bar where" + , "module Baz.Internal where" + -- other extensions + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\"]" + , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\"" + , "\"{-# LANGUAGE RecordWildCards #-}\"" + -- dependencies + , "True" + , "[\"src/Foo.hs\"]" + , "True" + , "test-package" + , "module Main where" + , "import Control.Monad.Extra" + , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}" + -- build tools + , "True" + , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]" + -- executable target + -- application dirs + , "app" + , "[]" + -- main file + , "test-package" + , "[\"test-package/app/\"]" + , "True" + , "[]" + -- other modules + , "test-package" + , "True" + , "[\"app/Main.hs\", \"app/Foo.hs\", \"app/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + -- other extensions + , "True" + , "[\"app/Foo.hs\", \"app/Bar.hs\"]" + , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\"" + , "\"{-# LANGUAGE RecordWildCards #-}\"" + -- dependencies + , "True" + , "[\"app/Main.hs\"]" + , "True" + , "test-package" + , "module Main where" + , "import Control.Monad.Extra" + , "{-# LANGUAGE OverloadedStrings, DataKinds #-}" + -- build tools + , "True" + , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]" + ] + + case (_runPrompt $ createProject comp silent pkgIx srcDb emptyFlags) inputs of + Right (ProjectSettings opts desc (Just lib) (Just exe) Nothing, _) -> do + _optOverwrite opts @?= False + _optMinimal opts @?= False + _optNoComments opts @?= False + _optVerbosity opts @?= silent + _optPkgDir opts @?= "/home/test/test-package" + _optPkgType opts @?= LibraryAndExecutable + _optPkgName opts @?= mkPackageName "test-package" + + _pkgCabalVersion desc @?= CabalSpecV3_4 + _pkgName desc @?= mkPackageName "test-package" + _pkgVersion desc @?= mkVersion [0,1,0,0] + _pkgLicense desc @?= (SpecLicense . Left $ SPDX.NONE) + _pkgAuthor desc @?= "Foobar" + _pkgEmail desc @?= "foobar@qux.com" + _pkgHomePage desc @?= "" + _pkgSynopsis desc @?= "" + _pkgCategory desc @?= "" + _pkgExtraSrcFiles desc @?= mempty + _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md") + + _libSourceDirs lib @?= ["src"] + _libLanguage lib @?= Haskell2010 + _libExposedModules lib @?= NEL.fromList (map fromString ["Foo", "Bar"]) + _libOtherModules lib @?= map fromString ["Baz.Internal"] + _libOtherExts lib @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards] + _libDependencies lib @?! [] + _libBuildTools lib @?= [mkStringyDep "happy:happy"] + + _exeMainIs exe @?= HsFilePath "Main.hs" Standard + _exeApplicationDirs exe @?= ["app"] + _exeLanguage exe @?= Haskell2010 + _exeOtherModules exe @?= map fromString ["Foo", "Bar"] + _exeOtherExts exe @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards] + _exeDependencies exe @?! [] + _exeBuildTools exe @?= [mkStringyDep "happy:happy"] + + assertBool "The library should be a dependency of the executable" $ + mkPackageNameDep (_optPkgName opts) `elem` _exeDependencies exe + + Right (ProjectSettings _ _ lib exe test, _) -> do + lib @?! Nothing + exe @?! Nothing + test @?= Nothing + Left e -> assertFailure $ show e + + , testCase "Check the non-interactive library workflow" $ do + let inputs = NEL.fromList + -- package type + [ "test-package" + , "[\".\", \"..\", \"src/\"]" + , "[\".\", \"..\", \"src/\"]" + -- package dir + , "test-package" + -- package description + -- cabal version + , "cabal-install version 3.4.0.0\ncompiled using version 3.4.0.0 of the Cabal library \n" + -- package name + , "test-package" + , "test-package" + -- author name + , "" + , "Foobar" + -- author email + , "" + , "foobar@qux.com" + -- extra source files + , "test-package" + , "[]" + -- library target + -- source dirs + , "src" + , "True" + -- exposed modules + , "src" + , "True" + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + , "test-package" + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + -- other modules + , "test-package" + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\", \"src/Baz/Internal.hs\"]" + , "module Foo where" + , "module Bar where" + , "module Baz.Internal where" + -- other extensions + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\"]" + , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\"" + , "\"{-# LANGUAGE RecordWildCards #-}\"" + -- dependencies + , "True" + , "[\"src/Foo.hs\"]" + , "True" + , "test-package" + , "module Main where" + , "import Control.Monad.Extra" + , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}" + -- build tools + , "True" + , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]" + ] + + case (_runPrompt $ createProject comp silent pkgIx srcDb emptyFlags) inputs of + Right (ProjectSettings opts desc (Just lib) Nothing Nothing, _) -> do + _optOverwrite opts @?= False + _optMinimal opts @?= False + _optNoComments opts @?= False + _optVerbosity opts @?= silent + _optPkgDir opts @?= "/home/test/test-package" + _optPkgType opts @?= Library + _optPkgName opts @?= mkPackageName "test-package" + + _pkgCabalVersion desc @?= CabalSpecV3_4 + _pkgName desc @?= mkPackageName "test-package" + _pkgVersion desc @?= mkVersion [0,1,0,0] + _pkgLicense desc @?= (SpecLicense . Left $ SPDX.NONE) + _pkgAuthor desc @?= "Foobar" + _pkgEmail desc @?= "foobar@qux.com" + _pkgHomePage desc @?= "" + _pkgSynopsis desc @?= "" + _pkgCategory desc @?= "" + _pkgExtraSrcFiles desc @?= mempty + _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md") + + _libSourceDirs lib @?= ["src"] + _libLanguage lib @?= Haskell2010 + _libExposedModules lib @?= NEL.fromList (map fromString ["Foo", "Bar"]) + _libOtherModules lib @?= map fromString ["Baz.Internal"] + _libOtherExts lib @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards] + _libDependencies lib @?! [] + _libBuildTools lib @?= [mkStringyDep "happy:happy"] + + Right (ProjectSettings _ _ lib exe test, _) -> do + lib @?! Nothing + exe @?= Nothing + test @?= Nothing + Left e -> assertFailure $ show e + + , testCase "Check the non-interactive executable workflow" $ do + let inputs = NEL.fromList + -- package type + [ "test-package" + , "[\".\", \"..\", \"app/Main.hs\"]" + , "[\".\", \"..\", \"app/Main.hs\"]" + -- package dir + , "test-package" + -- package description + -- cabal version + , "cabal-install version 3.4.0.0\ncompiled using version 3.4.0.0 of the Cabal library \n" + -- package name + , "test-package" + , "test-package" + -- author name + , "" + , "Foobar" + -- author email + , "" + , "foobar@qux.com" + -- extra source files + , "test-package" + , "[]" + -- executable target + -- application dirs + , "app" + , "[]" + -- main file + , "test-package" + , "[\"test-package/app/\"]" + , "True" + , "[]" + -- other modules + , "test-package" + , "True" + , "[\"app/Main.hs\", \"app/Foo.hs\", \"app/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + -- other extensions + , "True" + , "[\"app/Foo.hs\", \"app/Bar.hs\"]" + , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\"" + , "\"{-# LANGUAGE RecordWildCards #-}\"" + -- dependencies + , "True" + , "[\"app/Main.hs\"]" + , "True" + , "test-package" + , "module Main where" + , "import Control.Monad.Extra" + , "{-# LANGUAGE OverloadedStrings, DataKinds #-}" + -- build tools + , "True" + , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]" + ] + + case (_runPrompt $ createProject comp silent pkgIx srcDb emptyFlags) inputs of + Right (ProjectSettings opts desc Nothing (Just exe) Nothing, _) -> do + _optOverwrite opts @?= False + _optMinimal opts @?= False + _optNoComments opts @?= False + _optVerbosity opts @?= silent + _optPkgDir opts @?= "/home/test/test-package" + _optPkgType opts @?= Executable + _optPkgName opts @?= mkPackageName "test-package" + + _pkgCabalVersion desc @?= CabalSpecV3_4 + _pkgName desc @?= mkPackageName "test-package" + _pkgVersion desc @?= mkVersion [0,1,0,0] + _pkgLicense desc @?= (SpecLicense . Left $ SPDX.NONE) + _pkgAuthor desc @?= "Foobar" + _pkgEmail desc @?= "foobar@qux.com" + _pkgHomePage desc @?= "" + _pkgSynopsis desc @?= "" + _pkgCategory desc @?= "" + _pkgExtraSrcFiles desc @?= mempty + _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md") + + _exeMainIs exe @?= HsFilePath "Main.hs" Standard + _exeApplicationDirs exe @?= ["app"] + _exeLanguage exe @?= Haskell2010 + _exeOtherModules exe @?= map fromString ["Foo", "Bar"] + _exeOtherExts exe @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards] + _exeDependencies exe @?! [] + _exeBuildTools exe @?= [mkStringyDep "happy:happy"] + + Right (ProjectSettings _ _ lib exe test, _) -> do + lib @?= Nothing + exe @?! Nothing + test @?= Nothing + Left e -> assertFailure $ show e + ] + ] + +fileCreatorTests + :: InstalledPackageIndex + -> SourcePackageDb + -> Compiler + -> TestTree +fileCreatorTests pkgIx srcDb comp = testGroup "generators" + [ testGroup "genPkgDescription" + [ testCase "Check common package flags workflow" $ do + let inputs = NEL.fromList + -- cabal version + [ "cabal-install version 2.4.0.0\ncompiled using version 2.4.0.0 of the Cabal library \n" + -- package name + , "test-package" + , "test-package" + -- author name + , "" + , "Foobar" + -- author email + , "" + , "foobar@qux.com" + -- extra source files + , "test-package" + , "[]" + ] + + case (_runPrompt $ genPkgDescription emptyFlags srcDb) inputs of + Left e -> assertFailure $ show e + Right{} -> return () + ] + , testGroup "genLibTarget" + [ testCase "Check library package flags workflow" $ do + let inputs = NEL.fromList + -- source dirs + [ "src" + , "True" + -- exposed modules + , "src" + , "True" + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + , "test-package" + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + -- other modules + , "test-package" + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\", \"src/Baz/Internal.hs\"]" + , "module Foo where" + , "module Bar where" + , "module Baz.Internal where" + -- other extensions + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\"]" + , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\"" + , "\"{-# LANGUAGE RecordWildCards #-}\"" + -- dependencies + , "True" + , "[\"src/Foo.hs\"]" + , "True" + , "test-package" + , "module Main where" + , "import Control.Monad.Extra" + , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}" + -- build tools + , "True" + , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]" + ] + + case (_runPrompt $ genLibTarget emptyFlags comp pkgIx defaultCabalVersion) inputs of + Left e -> assertFailure $ show e + Right{} -> return () + ] + , testGroup "genExeTarget" + [ testCase "Check executable package flags workflow" $ do + let inputs = NEL.fromList + -- application dirs + [ "app" + , "[]" + -- main file + , "test-package" + , "[\"test-package/app/\"]" + , "True" + , "[]" + -- other modules + , "test-package" + , "True" + , "[\"app/Main.hs\", \"app/Foo.hs\", \"app/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + -- other extensions + , "True" + , "[\"app/Foo.hs\", \"app/Bar.hs\"]" + , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\"" + , "\"{-# LANGUAGE RecordWildCards #-}\"" + -- dependencies + , "True" + , "[\"app/Main.hs\"]" + , "True" + , "test-package" + , "module Main where" + , "import Control.Monad.Extra" + , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}" + -- build tools + , "True" + , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]" + ] + + case (_runPrompt $ genExeTarget emptyFlags comp pkgIx defaultCabalVersion) inputs of + Left e -> assertFailure $ show e + Right{} -> return () + ] + , testGroup "genTestTarget" + [ testCase "Check test package flags workflow" $ do + let inputs = NEL.fromList + -- main file + [ "True" + , "[]" + -- other modules + , "test-package" + , "True" + , "[\"test/Main.hs\", \"test/Foo.hs\", \"test/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + -- other extensions + , "True" + , "[\"test/Foo.hs\", \"test/Bar.hs\"]" + , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\"" + , "\"{-# LANGUAGE RecordWildCards #-}\"" + -- dependencies + , "True" + , "[\"test/Main.hs\"]" + , "True" + , "test-package" + , "module Main where" + , "import Test.Tasty\nimport Test.Tasty.HUnit" + , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}" + -- build tools + , "True" + , "[\"test/Main.hs\", \"test/Foo.hs\", \"test/bar.y\"]" + ] + flags = emptyFlags {initializeTestSuite = Flag True} + + case (_runPrompt $ genTestTarget flags comp pkgIx defaultCabalVersion) inputs of + Left e -> assertFailure $ show e + Right{} -> return () + ] + ] + +nonInteractiveTests + :: InstalledPackageIndex + -> SourcePackageDb + -> Compiler + -> TestTree +nonInteractiveTests pkgIx srcDb comp = testGroup "Check top level getter functions" + [ testGroup "Simple heuristics tests" + [ testGroup "Check packageNameHeuristics output" + [ testSimple "New package name" (packageNameHeuristics srcDb) + (mkPackageName "test-package") + [ "test-package" + , "test-package" + ] + , testSimple "Existing package name" (packageNameHeuristics srcDb) + (mkPackageName "cabal-install") + [ "test-package" + , "cabal-install" + ] + ] + , testSimple "Check authorHeuristics output" authorHeuristics "Foobar" + [ "" + , "Foobar" + ] + , testSimple "Check emailHeuristics output" emailHeuristics "foobar@qux.com" + [ "" + , "foobar@qux.com" + ] + , testSimple "Check srcDirsHeuristics output" srcDirsHeuristics ["src"] + [ "src" + , "True" + ] + , testSimple "Check appDirsHeuristics output" appDirsHeuristics ["app"] + [ "test-package" + , "[\"test-package/app/\"]" + ] + , testGroup "Check packageTypeHeuristics output" + [ testSimple "Library" packageTypeHeuristics Library + [ "test-package" + , "[\".\", \"..\", \"test/Main.hs\", \"src/\"]" + , "[\".\", \"..\", \"test/Main.hs\", \"src/\"]" + ] + , testSimple "Executable" packageTypeHeuristics Executable + [ "test-package" + , "[\".\", \"..\", \"app/Main.hs\"]" + , "[\".\", \"..\", \"app/Main.hs\"]" + ] + , testSimple "Library and Executable" packageTypeHeuristics LibraryAndExecutable + [ "test-package" + , "[\".\", \"..\", \"src/\", \"app/Main.hs\"]" + , "[\".\", \"..\", \"src/\", \"app/Main.hs\"]" + ] + , testSimple "TestSuite" packageTypeHeuristics TestSuite + [ "test-package" + , "[\".\", \"..\", \"test/Main.hs\"]" + , "[\".\", \"..\", \"test/Main.hs\"]" + ] + ] + , testGroup "Check cabalVersionHeuristics output" + [ testSimple "Broken command" cabalVersionHeuristics defaultCabalVersion + [""] + , testSimple "Proper answer" cabalVersionHeuristics 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 "No extra sources" extraDocFileHeuristics + (pure (Set.singleton "CHANGELOG.md")) + [ "test-package" + , "[]" + ] + , testSimple "Extra doc files present" extraDocFileHeuristics + (pure $ Set.singleton "README.md") + [ "test-package" + , "[\"README.md\"]" + ] + ] + , testGroup "Check mainFileHeuristics output" + [ testSimple "No main file defined" mainFileHeuristics + (toHsFilePath "Main.hs") + [ "test-package" + , "[\"test-package/app/\"]" + , "True" + , "[]" + ] + , testSimple "Main file already defined" mainFileHeuristics + (toHsFilePath "app/Main.hs") + [ "test-package" + , "[\"test-package/app/\"]" + , "True" + , "[\"app/Main.hs\"]" + ] + , testSimple "Main lhs file already defined" mainFileHeuristics + (toHsFilePath "app/Main.lhs") + [ "test-package" + , "[\"test-package/app/\"]" + , "True" + , "[\"app/Main.lhs\"]" + ] + ] + , testGroup "Check exposedModulesHeuristics output" + [ testSimple "Default exposed modules" exposedModulesHeuristics + (myLibModule NEL.:| []) + [ "src" + , "True" + , "True" + , "[]" + , "test-package" + , "True" + , "[]" + ] + , testSimple "Contains exposed modules" exposedModulesHeuristics + (NEL.fromList $ map fromString ["Foo", "Bar"]) + [ "src" + , "True" + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + , "test-package" + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + ] + ] + , testGroup "Check libOtherModulesHeuristics output" + [ testSimple "Library directory exists" libOtherModulesHeuristics + (map fromString ["Baz.Internal"]) + [ "test-package" + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\", \"src/Baz/Internal.hs\"]" + , "module Foo where" + , "module Bar where" + , "module Baz.Internal where" + ] + , testSimple "Library directory doesn't exist" libOtherModulesHeuristics [] + [ "test-package" + , "False" + ] + ] + , testGroup "Check exeOtherModulesHeuristics output" + [ testSimple "Executable directory exists" exeOtherModulesHeuristics + (map fromString ["Foo", "Bar"]) + [ "test-package" + , "True" + , "[\"app/Main.hs\", \"app/Foo.hs\", \"app/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + ] + , testSimple "Executable directory doesn't exist" exeOtherModulesHeuristics [] + [ "test-package" + , "False" + ] + ] + , testGroup "Check testOtherModulesHeuristics output" + [ testSimple "Test directory exists" testOtherModulesHeuristics + (map fromString ["Foo", "Bar"]) + [ "test-package" + , "True" + , "[\"test/Main.hs\", \"test/Foo.hs\", \"test/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + ] + , testSimple "Test directory doesn't exist" testOtherModulesHeuristics [] + [ "test-package" + , "False" + ] + ] + , testGroup "Check dependenciesHeuristics output" + [ testSimple "base version bounds is correct" + (fmap + (flip foldl' anyVersion $ \a (Dependency n v _) -> + if unPackageName n == "base" && baseVersion comp /= anyVersion + then v else a) + . (\x -> dependenciesHeuristics x "" pkgIx)) + (baseVersion comp) + [ "True" + , "[]" + ] + ] + , testSimple "Check buildToolsHeuristics output" (\a -> buildToolsHeuristics a "" defaultCabalVersion) + [mkStringyDep "happy:happy"] + [ "True" + , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]" + ] + , testSimple "Check otherExtsHeuristics output" (`otherExtsHeuristics` "") + (map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards]) + [ "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\"]" + , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\"" + , "\"{-# LANGUAGE RecordWildCards #-}\"" + ] + + , testSimple "Check versionHeuristics output" versionHeuristics (mkVersion [0,1,0,0]) [""] + , testSimple "Check homepageHeuristics output" homepageHeuristics "" [""] + , testSimple "Check synopsisHeuristics output" synopsisHeuristics "" [""] + , testSimple "Check testDirsHeuristics output" testDirsHeuristics ["test"] [""] + , testSimple "Check categoryHeuristics output" categoryHeuristics "" [""] + , testSimple "Check minimalHeuristics output" minimalHeuristics False [""] + , testSimple "Check overwriteHeuristics output" overwriteHeuristics False [""] + , testSimple "Check initializeTestSuiteHeuristics output" initializeTestSuiteHeuristics False [""] + , testSimple "Check licenseHeuristics output" licenseHeuristics (SpecLicense $ Left SPDX.NONE) [""] + ] + , testGroup "Bool heuristics tests" + [ testBool "Check noCommentsHeuristics output" noCommentsHeuristics False "" + ] + ] + +testSimple + :: Eq a + => Show a + => String + -> (InitFlags -> PurePrompt a) + -> a + -> [String] + -> TestTree +testSimple label f target = + testGo label f (assertFailure . show) (\(a, _) -> target @=? a) + +testBool + :: String + -> (InitFlags -> PurePrompt Bool) + -> Bool + -> String + -> TestTree +testBool label f target input = + testSimple label f target [input] + +testGo + :: Eq a + => Show a + => String + -> (InitFlags -> PurePrompt a) + -> (BreakException -> Assertion) + -> ((a, NEL.NonEmpty String) -> Assertion) + -> [String] + -> TestTree +testGo label f g h inputs = testCase label $ + case (_runPrompt $ f emptyFlags) (NEL.fromList inputs) of + Left x -> g x + Right x -> h x diff --git a/cabal/cabal-install/tests/UnitTests/Distribution/Client/Init/Simple.hs b/cabal/cabal-install/tests/UnitTests/Distribution/Client/Init/Simple.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/UnitTests/Distribution/Client/Init/Simple.hs @@ -0,0 +1,173 @@ +module UnitTests.Distribution.Client.Init.Simple +( tests +) where + + +import Prelude as P +import Test.Tasty +import Test.Tasty.HUnit + +import Distribution.Client.Init.Defaults +import Distribution.Client.Init.Simple +import Distribution.Client.Init.Types + + +import Data.List.NonEmpty hiding (zip) +import Distribution.Client.Types +import Distribution.Simple.PackageIndex hiding (fromList) +import Distribution.Types.PackageName +import Distribution.Verbosity + + +import UnitTests.Distribution.Client.Init.Utils +import Distribution.Simple.Setup +import qualified Data.List.NonEmpty as NEL +import Distribution.Types.Dependency +import Distribution.Client.Init.Utils (mkPackageNameDep, getBaseDep) +import qualified Data.Set as Set +import Distribution.Client.Init.FlagExtractors (getCabalVersionNoPrompt) + +tests + :: Verbosity + -> InitFlags + -> InstalledPackageIndex + -> SourcePackageDb + -> TestTree +tests v _initFlags pkgIx srcDb = testGroup "Distribution.Client.Init.Simple.hs" + [ simpleCreateProjectTests v pkgIx srcDb pkgName + ] + where + pkgName = mkPackageName "simple-test" + +simpleCreateProjectTests + :: Verbosity + -> InstalledPackageIndex + -> SourcePackageDb + -> PackageName + -> TestTree +simpleCreateProjectTests v pkgIx srcDb pkgName = + testGroup "Simple createProject tests" + [ testCase "Simple lib createProject - no tests" $ do + let inputs = fromList + [ "1" -- package type: Library + , "simple.test" -- package dir: used for determining package name; + -- note that . will be replaced with - in a sanitization step, + -- and we get the expected "simple-test" -- regression test for #8404 + , "simple.test" -- package dir again: the prompt monad needs extra parameter for every + -- IO call, and this one will be used for canonicalizePath, + -- which is called as a part of sanitization + , "n" -- no tests + ] + + flags = emptyFlags { packageType = Flag Library } + settings = ProjectSettings + (WriteOpts False False False v "/home/test/1" Library pkgName defaultCabalVersion) + (simplePkgDesc pkgName) (Just $ simpleLibTarget baseDep) + Nothing Nothing + + case _runPrompt (createProject v pkgIx srcDb flags) inputs of + Left e -> assertFailure $ "Failed to create simple lib project: " ++ show e + Right (settings', _) -> settings @=? settings' + + , testCase "Simple lib createProject - with tests" $ do + let inputs = fromList ["1", "simple-test", "simple-test", "y", "1"] + flags = emptyFlags { packageType = Flag Library } + settings = ProjectSettings + (WriteOpts False False False v "/home/test/1" Library pkgName defaultCabalVersion) + (simplePkgDesc pkgName) (Just $ simpleLibTarget baseDep) + Nothing (Just $ simpleTestTarget (Just pkgName) baseDep) + + case _runPrompt (createProject v pkgIx srcDb flags) inputs of + Left e -> assertFailure $ "Failed to create simple lib (with tests)project: " ++ show e + Right (settings', _) -> settings @=? settings' + + , testCase "Simple exe createProject" $ do + let inputs = fromList ["2", "simple-test", "simple-test"] + flags = emptyFlags { packageType = Flag Executable } + settings = ProjectSettings + (WriteOpts False False False v "/home/test/2" Executable pkgName defaultCabalVersion) + (simplePkgDesc pkgName) Nothing + (Just $ simpleExeTarget Nothing baseDep) Nothing + + case _runPrompt (createProject v pkgIx srcDb flags) inputs of + Left e -> assertFailure $ "Failed to create simple exe project: " ++ show e + Right (settings', _) -> settings @=? settings' + + , testCase "Simple lib+exe createProject - no tests" $ do + let inputs = fromList ["2", "simple-test", "simple-test", "n"] + flags = emptyFlags { packageType = Flag LibraryAndExecutable } + settings = ProjectSettings + (WriteOpts False False False v "/home/test/2" LibraryAndExecutable pkgName defaultCabalVersion) + (simplePkgDesc pkgName) (Just $ simpleLibTarget baseDep) + (Just $ simpleExeTarget (Just pkgName) baseDep) Nothing + + case _runPrompt (createProject v pkgIx srcDb flags) inputs of + Left e -> assertFailure $ "Failed to create simple lib+exe project: " ++ show e + Right (settings', _) -> settings @=? settings' + , testCase "Simple lib+exe createProject - with tests" $ do + let inputs = fromList ["2", "simple-test", "simple-test", "y", "1"] + flags = emptyFlags { packageType = Flag LibraryAndExecutable } + settings = ProjectSettings + (WriteOpts False False False v "/home/test/2" LibraryAndExecutable pkgName defaultCabalVersion) + (simplePkgDesc pkgName) (Just $ simpleLibTarget baseDep) + (Just $ simpleExeTarget (Just pkgName) baseDep) + (Just $ simpleTestTarget (Just pkgName) baseDep) + + case _runPrompt (createProject v pkgIx srcDb flags) inputs of + Left e -> assertFailure $ "Failed to create simple lib+exe (with tests) project: " ++ show e + Right (settings', _) -> settings @=? settings' + + , testCase "Simple standalone tests" $ do + let inputs = fromList ["2", "simple-test", "simple-test", "y", "1"] + flags = emptyFlags { packageType = Flag TestSuite } + settings = ProjectSettings + (WriteOpts False False False v "/home/test/2" TestSuite pkgName defaultCabalVersion) + (simplePkgDesc pkgName) Nothing Nothing + (Just $ simpleTestTarget Nothing baseDep) + + case _runPrompt (createProject v pkgIx srcDb flags) inputs of + Left e -> assertFailure $ "Failed to create simple standalone test project: " ++ show e + Right (settings', _) -> settings @=? settings' + ] + where + baseDep = case _runPrompt (getBaseDep pkgIx emptyFlags) $ fromList [] of + Left e -> error $ show e + Right a -> fst a + +-- -------------------------------------------------------------------- -- +-- Utils + +mkPkgDep :: Maybe PackageName -> [Dependency] +mkPkgDep Nothing = [] +mkPkgDep (Just pn) = [mkPackageNameDep pn] + +simplePkgDesc :: PackageName -> PkgDescription +simplePkgDesc pkgName = PkgDescription + defaultCabalVersion + pkgName + defaultVersion + (defaultLicense $ getCabalVersionNoPrompt dummyFlags) + "" "" "" "" "" + mempty + (Just $ Set.singleton defaultChangelog) + +simpleLibTarget :: [Dependency] -> LibTarget +simpleLibTarget baseDep = LibTarget + [defaultSourceDir] + defaultLanguage + (myLibModule NEL.:| []) + [] [] baseDep [] + +simpleExeTarget :: Maybe PackageName -> [Dependency] -> ExeTarget +simpleExeTarget pn baseDep = ExeTarget + defaultMainIs + [defaultApplicationDir] + defaultLanguage + [] [] (baseDep ++ mkPkgDep pn) [] + +simpleTestTarget :: Maybe PackageName -> [Dependency] -> TestTarget +simpleTestTarget pn baseDep = TestTarget + defaultMainIs + [defaultTestDir] + defaultLanguage + [] [] (baseDep ++ mkPkgDep pn) [] diff --git a/cabal/cabal-install/tests/UnitTests/Distribution/Client/Init/Utils.hs b/cabal/cabal-install/tests/UnitTests/Distribution/Client/Init/Utils.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/UnitTests/Distribution/Client/Init/Utils.hs @@ -0,0 +1,107 @@ +module UnitTests.Distribution.Client.Init.Utils +( dummyFlags +, emptyFlags +, mkLicense +, baseVersion +, mangleBaseDep +, (@?!) +, (@!?) +) where + + +import Distribution.Client.Init.Types + +import qualified Distribution.SPDX as SPDX + +import Distribution.CabalSpecVersion +import Distribution.Simple.Setup +import Distribution.Types.PackageName +import Distribution.Types.Version +import Language.Haskell.Extension +import Test.Tasty.HUnit +import Distribution.Types.Dependency +import Distribution.Types.VersionRange +import Distribution.Simple.Compiler +import Distribution.Pretty +import Distribution.FieldGrammar.Newtypes + + +-- -------------------------------------------------------------------- -- +-- Test flags + +dummyFlags :: InitFlags +dummyFlags = emptyFlags + { noComments = Flag True + , packageName = Flag (mkPackageName "QuxPackage") + , version = Flag (mkVersion [4,2,6]) + , cabalVersion = Flag CabalSpecV2_2 + , license = Flag $ SpecLicense $ Left $ SPDX.License $ SPDX.ELicense (SPDX.ELicenseId SPDX.MIT) Nothing + , author = Flag "Foobar" + , email = Flag "foobar@qux.com" + , homepage = Flag "qux.com" + , synopsis = Flag "We are Qux, and this is our package" + , category = Flag "Control" + , language = Flag Haskell98 + , initializeTestSuite = Flag True + , sourceDirs = Flag ["quxSrc"] + , testDirs = Flag ["quxTest"] + , applicationDirs = Flag ["quxApp"] + } + +emptyFlags :: InitFlags +emptyFlags = mempty + +-- | Retireves the proper base version based on the GHC version +baseVersion :: Compiler -> VersionRange +baseVersion Compiler {compilerId = CompilerId GHC ver} = + let ghcToBase = baseVersion' . prettyShow $ ver in + if null ghcToBase + then anyVersion + else majorBoundVersion $ mkVersion ghcToBase +baseVersion _ = anyVersion + +baseVersion' :: String -> [Int] +baseVersion' "9.0.1" = [4,15,0,0] +baseVersion' "8.10.4" = [4,14,1,0] +baseVersion' "8.8.4" = [4,13,0,0] +baseVersion' "8.6.5" = [4,12,0,0] +baseVersion' "8.4.4" = [4,11,1,0] +baseVersion' "8.2.2" = [4,10,1,0] +baseVersion' "7.10.3" = [4,9,0,0] +baseVersion' "7.8.4" = [4,8,0,0] +baseVersion' "7.6.3" = [4,7,0,0] +baseVersion' _ = [] + +-- -------------------------------------------------------------------- -- +-- Test utils + +mkLicense :: SPDX.LicenseId -> SPDX.License +mkLicense lid = SPDX.License (SPDX.ELicense (SPDX.ELicenseId lid) Nothing) + +mangleBaseDep :: a -> (a -> [Dependency]) -> [Dependency] +mangleBaseDep target f = + [ if unPackageName x == "base" + then Dependency x anyVersion z + else dep + | dep@(Dependency x _ z) <- f target + ] + +infix 1 @?!, @!? + +-- | Just like @'@?='@, except it checks for difference rather than equality. +(@?!) + :: (Eq a, Show a, HasCallStack) + => a + -> a + -> Assertion +actual @?! unexpected = assertBool + ("unexpected: " ++ show unexpected) + (actual /= unexpected) + +-- | Just like @'@=?'@, except it checks for difference rather than equality. +(@!?) + :: (Eq a, Show a, HasCallStack) + => a + -> a + -> Assertion +(@!?) = flip (@?!) diff --git a/cabal/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs b/cabal/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs --- a/cabal/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs +++ b/cabal/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs @@ -16,7 +16,7 @@ #endif import Data.Map (Map) import qualified Data.Map as Map -import Data.List +import Data.List (isPrefixOf, intercalate, (\\)) import Network.URI (URI) import Distribution.Deprecated.ParseUtils @@ -28,6 +28,7 @@ import Distribution.Version import Distribution.Simple.Program.Types import Distribution.Simple.Program.Db +import Distribution.Simple.Utils (toUTF8BS) import Distribution.Types.PackageVersionConstraint import Distribution.Parsec @@ -99,10 +100,12 @@ -- Round trip: conversion to/from legacy types -- -roundtrip :: (Eq a, ToExpr a) => (a -> b) -> (b -> a) -> a -> Property +roundtrip :: (Eq a, ToExpr a, Show b) => (a -> b) -> (b -> a) -> a -> Property roundtrip f f_inv x = - let y = f x - in x `ediffEq` f_inv y -- no counterexample with y, as they not have ToExpr + counterexample (show y) $ + x `ediffEq` f_inv y -- no counterexample with y, as they not have ToExpr + where + y = f x roundtrip_legacytypes :: ProjectConfig -> Property roundtrip_legacytypes = @@ -155,10 +158,10 @@ roundtrip_printparse :: ProjectConfig -> Property roundtrip_printparse config = - case fmap convertLegacyProjectConfig (parseLegacyProjectConfig str) of - ParseOk _ x -> counterexample ("shown: " ++ str) $ + case fmap convertLegacyProjectConfig (parseLegacyProjectConfig "unused" (toUTF8BS str)) of + ParseOk _ x -> counterexample ("shown:\n" ++ str) $ x `ediffEq` config { projectConfigProvenance = mempty } - ParseFailed err -> counterexample (show err) False + ParseFailed err -> counterexample ("shown:\n" ++ str ++ "\nERROR: " ++ show err) False where str :: String str = showLegacyProjectConfig (convertToLegacyProjectConfig config) @@ -198,10 +201,11 @@ hackProjectConfigBuildOnly :: ProjectConfigBuildOnly -> ProjectConfigBuildOnly hackProjectConfigBuildOnly config = config { - -- These two fields are only command line transitory things, not + -- These fields are only command line transitory things, not -- something to be recorded persistently in a config file - projectConfigOnlyDeps = mempty, - projectConfigDryRun = mempty + projectConfigOnlyDeps = mempty, + projectConfigOnlyDownload = mempty, + projectConfigDryRun = mempty } prop_roundtrip_printparse_shared :: ProjectConfigShared -> Property @@ -272,7 +276,7 @@ prop_roundtrip_printparse_RelaxDeps' :: RelaxDeps -> Property prop_roundtrip_printparse_RelaxDeps' rdep = counterexample rdep' $ - Right rdep `ediffEq` eitherParsec rdep' + Right rdep `ediffEq` eitherParsec rdep' where rdep' = go (prettyShow rdep) @@ -344,6 +348,7 @@ , arbitraryGlobLikeStr , show <$> (arbitrary :: Gen URI) ] + `suchThat` (\xs -> not ("{" `isPrefixOf` xs)) arbitraryGlobLikeStr :: Gen String arbitraryGlobLikeStr = outerTerm @@ -373,12 +378,12 @@ <$> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary <*> (toNubList <$> shortListOf 2 arbitrary) <*> arbitrary <*> arbitrary <*> arbitrary <*> (fmap getShortToken <$> arbitrary) - <*> arbitrary <*> arbitraryNumJobs <*> arbitrary <*> arbitrary @@ -394,12 +399,12 @@ shrink ProjectConfigBuildOnly { projectConfigVerbosity = x00 , projectConfigDryRun = x01 , projectConfigOnlyDeps = x02 + , projectConfigOnlyDownload = x18 , projectConfigSummaryFile = x03 , projectConfigLogFile = x04 , projectConfigBuildReports = x05 , projectConfigReportPlanningFailure = x06 , projectConfigSymlinkBinDir = x07 - , projectConfigOneShot = x08 , projectConfigNumJobs = x09 , projectConfigKeepGoing = x10 , projectConfigOfflineMode = x11 @@ -412,12 +417,12 @@ [ ProjectConfigBuildOnly { projectConfigVerbosity = x00' , projectConfigDryRun = x01' , projectConfigOnlyDeps = x02' + , projectConfigOnlyDownload = x18' , projectConfigSummaryFile = x03' , projectConfigLogFile = x04' , projectConfigBuildReports = x05' , projectConfigReportPlanningFailure = x06' , projectConfigSymlinkBinDir = x07' - , projectConfigOneShot = x08' , projectConfigNumJobs = postShrink_NumJobs x09' , projectConfigKeepGoing = x10' , projectConfigOfflineMode = x11' @@ -428,14 +433,14 @@ , projectConfigLogsDir = x16 , projectConfigClientInstallFlags = x17' } | ((x00', x01', x02', x03', x04'), - (x05', x06', x07', x08', x09'), + (x05', x06', x07', x09'), (x10', x11', x12', x14'), - ( x17' )) + ( x17', x18' )) <- shrink ((x00, x01, x02, x03, x04), - (x05, x06, x07, x08, preShrink_NumJobs x09), + (x05, x06, x07, preShrink_NumJobs x09), (x10, x11, x12, x14), - ( x17 )) + ( x17, x18 )) ] where preShrink_NumJobs = fmap (fmap Positive) @@ -451,6 +456,7 @@ projectConfigHcPath <- arbitraryFlag arbitraryShortToken projectConfigHcPkg <- arbitraryFlag arbitraryShortToken projectConfigHaddockIndex <- arbitrary + projectConfigPackageDBs <- shortListOf 2 arbitrary projectConfigRemoteRepos <- arbitrary projectConfigLocalNoIndexRepos <- arbitrary projectConfigActiveRepos <- arbitrary @@ -473,6 +479,7 @@ projectConfigOnlyConstrained <- arbitrary projectConfigPerComponent <- arbitrary projectConfigIndependentGoals <- arbitrary + projectConfigPreferOldest <- arbitrary projectConfigProgPathExtra <- toNubList <$> listOf arbitraryShortToken return ProjectConfigShared {..} where @@ -489,6 +496,7 @@ <*> shrinkerAla (fmap NonEmpty) projectConfigHcPath <*> shrinkerAla (fmap NonEmpty) projectConfigHcPkg <*> shrinker projectConfigHaddockIndex + <*> shrinker projectConfigPackageDBs <*> shrinker projectConfigRemoteRepos <*> shrinker projectConfigLocalNoIndexRepos <*> shrinker projectConfigActiveRepos @@ -511,6 +519,7 @@ <*> shrinker projectConfigOnlyConstrained <*> shrinker projectConfigPerComponent <*> shrinker projectConfigIndependentGoals + <*> shrinker projectConfigPreferOldest <*> shrinker projectConfigProgPathExtra where preShrink_Constraints = map fst @@ -518,7 +527,7 @@ projectConfigConstraintSource :: ConstraintSource projectConfigConstraintSource = - ConstraintSourceProjectConfig "TODO" + ConstraintSourceProjectConfig "unused" instance Arbitrary ProjectConfigProvenance where arbitrary = elements [Implicit, Explicit "cabal.project"] @@ -545,12 +554,13 @@ <*> shortListOf 5 arbitraryShortToken <*> shortListOf 5 arbitraryShortToken <*> shortListOf 5 arbitraryShortToken - <*> arbitrary <*> arbitrary + <*> shortListOf 5 arbitraryShortToken <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitraryFlag arbitraryShortToken <*> arbitrary @@ -596,6 +606,7 @@ , packageConfigProgPrefix = x14 , packageConfigProgSuffix = x15 , packageConfigExtraLibDirs = x16 + , packageConfigExtraLibDirsStatic = x53 , packageConfigExtraFrameworkDirs = x17 , packageConfigExtraIncludeDirs = x18 , packageConfigGHCiLib = x19 @@ -608,6 +619,7 @@ , packageConfigCoverage = x25 , packageConfigRelocatable = x26 , packageConfigDebugInfo = x27 + , packageConfigDumpBuildInfo = x27_1 , packageConfigRunTests = x28 , packageConfigDocumentation = x29 , packageConfigHaddockHoogle = x30 @@ -651,6 +663,7 @@ , packageConfigProgPrefix = x14' , packageConfigProgSuffix = x15' , packageConfigExtraLibDirs = map getNonEmpty x16' + , packageConfigExtraLibDirsStatic = map getNonEmpty x53' , packageConfigExtraFrameworkDirs = map getNonEmpty x17' , packageConfigExtraIncludeDirs = map getNonEmpty x18' , packageConfigGHCiLib = x19' @@ -663,6 +676,7 @@ , packageConfigCoverage = x25' , packageConfigRelocatable = x26' , packageConfigDebugInfo = x27' + , packageConfigDumpBuildInfo = x27_1' , packageConfigRunTests = x28' , packageConfigDocumentation = x29' , packageConfigHaddockHoogle = x30' @@ -690,9 +704,9 @@ | (((x00', x01', x02', x03', x04'), (x05', x42', x06', x50', x07', x08', x09'), (x10', x11', x12', x13', x14'), - (x15', x16', x17', x18', x19')), + (x15', x16', x53', x17', x18', x19')), ((x20', x20_1', x21', x22', x23', x24'), - (x25', x26', x27', x28', x29'), + (x25', x26', x27', x27_1', x28', x29'), (x30', x31', x32', (x33', x33_1'), x34'), (x35', x36', x37', x38', x43', x39'), (x40', x41'), @@ -701,12 +715,12 @@ (((preShrink_Paths x00, preShrink_Args x01, x02, x03, x04), (x05, x42, x06, x50, x07, x08, x09), (x10, x11, map NonEmpty x12, x13, x14), - (x15, map NonEmpty x16, + (x15, map NonEmpty x16, map NonEmpty x53, map NonEmpty x17, map NonEmpty x18, x19)), ((x20, x20_1, x21, x22, x23, x24), - (x25, x26, x27, x28, x29), + (x25, x26, x27, x27_1, x28, x29), (x30, x31, x32, (x33, x33_1), x34), (x35, x36, fmap NonEmpty x37, x38, x43, fmap NonEmpty x39), (x40, x41), @@ -735,17 +749,15 @@ <*> (fmap getShortToken <$> arbitrary) <*> (fmap getShortToken <$> arbitrary) <*> (fmap getShortToken <$> shortListOf 3 arbitrary) + <*> (fmap getShortToken <$> shortListOf 3 arbitrary) - shrink (SourceRepositoryPackage x1 x2 x3 x4 x5) = - [ SourceRepositoryPackage - x1' - (getShortToken x2') - (fmap getShortToken x3') - (fmap getShortToken x4') - (fmap getShortToken x5') - | (x1', x2', x3', x4', x5') <- shrink - (x1, ShortToken x2, fmap ShortToken x3, fmap ShortToken x4, fmap ShortToken x5) - ] + shrink SourceRepositoryPackage {..} = runShrinker $ pure SourceRepositoryPackage + <*> shrinker srpType + <*> shrinkerAla ShortToken srpLocation + <*> shrinkerAla (fmap ShortToken) srpTag + <*> shrinkerAla (fmap ShortToken) srpBranch + <*> shrinkerAla (fmap ShortToken) srpSubdir + <*> shrinkerAla (fmap ShortToken) srpCommand instance Arbitrary RemoteRepo where arbitrary = @@ -784,6 +796,9 @@ instance Arbitrary IndependentGoals where arbitrary = IndependentGoals <$> arbitrary + +instance Arbitrary PreferOldest where + arbitrary = PreferOldest <$> arbitrary instance Arbitrary StrongFlags where arbitrary = StrongFlags <$> arbitrary diff --git a/cabal/cabal-install/tests/UnitTests/Distribution/Client/ProjectPlanning.hs b/cabal/cabal-install/tests/UnitTests/Distribution/Client/ProjectPlanning.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/UnitTests/Distribution/Client/ProjectPlanning.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE OverloadedStrings #-} + +module UnitTests.Distribution.Client.ProjectPlanning (tests) where + +import Data.List.NonEmpty +import Distribution.Client.ProjectPlanning (ComponentTarget (..), SubComponentTarget (..), nubComponentTargets) +import Distribution.Types.ComponentName +import Distribution.Types.LibraryName +import Test.Tasty +import Test.Tasty.HUnit + +tests :: [TestTree] +tests = + [ testGroup "Build Target Tests" buildTargetTests + ] + +-- ---------------------------------------------------------------------------- +-- Build Target Tests +-- ---------------------------------------------------------------------------- + +buildTargetTests :: [TestTree] +buildTargetTests = + [ testGroup "nubComponentTargets" nubComponentTargetsTests + ] + +nubComponentTargetsTests :: [TestTree] +nubComponentTargetsTests = + [ testCase "Works on empty list" $ + nubComponentTargets [] @?= ([] :: [(ComponentTarget, NonEmpty Int)]) + , testCase "Merges targets to same component" $ + nubComponentTargets + [ (mainLibModuleTarget, 1 :: Int) + , (mainLibFileTarget, 2) + ] + @?= [(mainLibWholeCompTarget, 1 :| [2])] + , testCase "Merges whole component targets" $ + nubComponentTargets [(mainLibFileTarget, 2), (mainLibWholeCompTarget, 1 :: Int)] + @?= [(mainLibWholeCompTarget, 2 :| [1])], + testCase "Don't merge unrelated targets" $ + nubComponentTargets + [ (mainLibWholeCompTarget, 1 :: Int) + , (exeWholeCompTarget, 2) + ] + @?= [(mainLibWholeCompTarget, pure 1), (exeWholeCompTarget, pure 2)] + , testCase "Merge multiple related targets" $ + nubComponentTargets + [ (mainLibWholeCompTarget, 1 :: Int) + , (mainLibModuleTarget, 4) + , (exeWholeCompTarget, 2) + , (exeFileTarget, 3) + ] + @?= [(mainLibWholeCompTarget, 1 :| [4]), (exeWholeCompTarget, 2 :| [3])] + , testCase "Merge related targets, don't merge unrelated ones" $ + nubComponentTargets + [ (mainLibFileTarget, 1 :: Int) + , (mainLibModuleTarget, 4) + , (exeWholeCompTarget, 2) + , (exeFileTarget, 3) + , (exe2FileTarget, 5) + ] + @?= + [ (mainLibWholeCompTarget, 1 :| [4]) + , (exeWholeCompTarget, 2 :| [3]) + , (exe2WholeCompTarget, 5 :| []) + ] + ] + +-- ---------------------------------------------------------------------------- +-- Utils +-- ---------------------------------------------------------------------------- + +mainLibWholeCompTarget :: ComponentTarget +mainLibWholeCompTarget = ComponentTarget (CLibName LMainLibName) WholeComponent + +mainLibModuleTarget :: ComponentTarget +mainLibModuleTarget = ComponentTarget (CLibName LMainLibName) (ModuleTarget "Lib") + +mainLibFileTarget :: ComponentTarget +mainLibFileTarget = ComponentTarget (CLibName LMainLibName) (FileTarget "./Lib.hs") + +exeWholeCompTarget :: ComponentTarget +exeWholeCompTarget = ComponentTarget (CExeName "exe") WholeComponent + +exeFileTarget :: ComponentTarget +exeFileTarget = ComponentTarget (CExeName "exe") (FileTarget "./Main.hs") + +exe2WholeCompTarget :: ComponentTarget +exe2WholeCompTarget = ComponentTarget (CExeName "exe2") WholeComponent + +exe2FileTarget :: ComponentTarget +exe2FileTarget = ComponentTarget (CExeName "exe2") (FileTarget "./Main2.hs") diff --git a/cabal/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs b/cabal/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs --- a/cabal/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs +++ b/cabal/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs @@ -20,6 +20,8 @@ import Distribution.Client.Types.OverwritePolicy (OverwritePolicy) import Distribution.Client.Types.SourceRepo (SourceRepositoryPackage) +import Distribution.Simple.Compiler (PackageDB) + import Data.TreeDiff.Class import Data.TreeDiff.Instances.Cabal () import Network.URI @@ -50,7 +52,9 @@ instance ToExpr Outcome instance ToExpr OverwritePolicy instance ToExpr PackageConfig +instance ToExpr PackageDB instance ToExpr PackageProperty +instance ToExpr PreferOldest instance ToExpr PreSolver instance ToExpr ProjectConfig instance ToExpr ProjectConfigBuildOnly diff --git a/cabal/cabal-install/tests/UnitTests/Distribution/Client/UserConfig.hs b/cabal/cabal-install/tests/UnitTests/Distribution/Client/UserConfig.hs --- a/cabal/cabal-install/tests/UnitTests/Distribution/Client/UserConfig.hs +++ b/cabal/cabal-install/tests/UnitTests/Distribution/Client/UserConfig.hs @@ -35,7 +35,7 @@ nullDiffOnCreateTest :: Assertion nullDiffOnCreateTest = bracketTest $ \configFile -> do -- Create a new default config file in our test directory. - _ <- loadConfig silent (Flag configFile) + _ <- createDefaultConfigFile silent [] configFile -- Now we read it in and compare it against the default. diff <- userConfigDiff silent (globalFlags configFile) [] assertBool (unlines $ "Following diff should be empty:" : diff) $ null diff @@ -44,7 +44,7 @@ canDetectDifference :: Assertion canDetectDifference = bracketTest $ \configFile -> do -- Create a new default config file in our test directory. - _ <- loadConfig silent (Flag configFile) + _ <- createDefaultConfigFile silent [] configFile appendFile configFile "verbose: 0\n" diff <- userConfigDiff silent (globalFlags configFile) [] assertBool (unlines $ "Should detect a difference:" : diff) $ @@ -66,7 +66,7 @@ doubleUpdateConfig :: Assertion doubleUpdateConfig = bracketTest $ \configFile -> do -- Create a new default config file in our test directory. - _ <- loadConfig silent (Flag configFile) + _ <- createDefaultConfigFile silent [] configFile -- Update it twice. replicateM_ 2 $ userConfigUpdate silent (globalFlags configFile) [] -- Load it again. diff --git a/cabal/cabal-install/tests/UnitTests/Distribution/Client/VCS.hs b/cabal/cabal-install/tests/UnitTests/Distribution/Client/VCS.hs --- a/cabal/cabal-install/tests/UnitTests/Distribution/Client/VCS.hs +++ b/cabal/cabal-install/tests/UnitTests/Distribution/Client/VCS.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards, NamedFieldPuns, KindSignatures, DataKinds #-} +{-# LANGUAGE AllowAmbiguousTypes, TypeApplications, ScopedTypeVariables #-} module UnitTests.Distribution.Client.VCS (tests) where import Distribution.Client.Compat.Prelude @@ -6,10 +7,11 @@ import Distribution.Client.RebuildMonad ( execRebuild ) import Distribution.Simple.Program +import Distribution.System ( buildOS, OS (Windows) ) import Distribution.Verbosity as Verbosity import Distribution.Client.Types.SourceRepo (SourceRepositoryPackage (..), SourceRepoProxy) -import Data.List +import Data.List (mapAccumL) import Data.Tuple import qualified Data.Map as Map import qualified Data.Set as Set @@ -26,6 +28,7 @@ import Test.Tasty import Test.Tasty.QuickCheck +import Test.Tasty.ExpectedFailure import UnitTests.Distribution.Client.ArbitraryInstances import UnitTests.TempTestDir (withTestDir, removeDirectoryRecursiveHack) @@ -36,7 +39,7 @@ -- working state. -- -- The first test simply checks that the test infrastructure works. It --- constructs a repository on disk and then checks out every tag or commmit +-- constructs a repository on disk and then checks out every tag or commit -- and checks that the working state is the same as the pure representation. -- -- The second test works in a similar way but tests 'syncSourceRepos'. It @@ -46,67 +49,93 @@ -- checks that the working state is as expected (given the pure representation). -- tests :: MTimeChange -> [TestTree] -tests mtimeChange = - [ testGroup "git" +tests mtimeChange = map (localOption $ QuickCheckTests 10) + [ ignoreInWindows "See issue #8048" $ + testGroup "git" [ testProperty "check VCS test framework" prop_framework_git , testProperty "cloneSourceRepo" prop_cloneRepo_git , testProperty "syncSourceRepos" prop_syncRepos_git ] - -- for the moment they're not yet working - , testGroup "darcs" $ const [] + -- + , ignoreTestBecause "for the moment they're not yet working" $ + testGroup "darcs" [ testProperty "check VCS test framework" $ prop_framework_darcs mtimeChange , testProperty "cloneSourceRepo" $ prop_cloneRepo_darcs mtimeChange , testProperty "syncSourceRepos" $ prop_syncRepos_darcs mtimeChange ] - , testGroup "pijul" $ const [] + , ignoreTestBecause "for the moment they're not yet working" $ + testGroup "pijul" [ testProperty "check VCS test framework" prop_framework_pijul , testProperty "cloneSourceRepo" prop_cloneRepo_pijul , testProperty "syncSourceRepos" prop_syncRepos_pijul ] + , ignoreTestBecause "for the moment they're not yet working" $ + testGroup "mercurial" + [ testProperty "check VCS test framework" prop_framework_hg + , testProperty "cloneSourceRepo" prop_cloneRepo_hg + , testProperty "syncSourceRepos" prop_syncRepos_hg + ] + ] -prop_framework_git :: BranchingRepoRecipe -> Property + where ignoreInWindows msg = case buildOS of + Windows -> ignoreTestBecause msg + _ -> id + +prop_framework_git :: BranchingRepoRecipe 'SubmodulesSupported -> Property prop_framework_git = ioProperty . prop_framework vcsGit vcsTestDriverGit . WithBranchingSupport -prop_framework_darcs :: MTimeChange -> NonBranchingRepoRecipe -> Property +prop_framework_darcs :: MTimeChange -> NonBranchingRepoRecipe 'SubmodulesNotSupported -> Property prop_framework_darcs mtimeChange = ioProperty . prop_framework vcsDarcs (vcsTestDriverDarcs mtimeChange) . WithoutBranchingSupport -prop_framework_pijul :: BranchingRepoRecipe -> Property +prop_framework_pijul :: BranchingRepoRecipe 'SubmodulesNotSupported -> Property prop_framework_pijul = ioProperty . prop_framework vcsPijul vcsTestDriverPijul . WithBranchingSupport -prop_cloneRepo_git :: BranchingRepoRecipe -> Property +prop_framework_hg :: BranchingRepoRecipe 'SubmodulesNotSupported -> Property +prop_framework_hg = + ioProperty + . prop_framework vcsHg vcsTestDriverHg + . WithBranchingSupport + +prop_cloneRepo_git :: BranchingRepoRecipe 'SubmodulesSupported -> Property prop_cloneRepo_git = ioProperty . prop_cloneRepo vcsGit vcsTestDriverGit . WithBranchingSupport prop_cloneRepo_darcs :: MTimeChange - -> NonBranchingRepoRecipe -> Property + -> NonBranchingRepoRecipe 'SubmodulesNotSupported -> Property prop_cloneRepo_darcs mtimeChange = ioProperty . prop_cloneRepo vcsDarcs (vcsTestDriverDarcs mtimeChange) . WithoutBranchingSupport -prop_cloneRepo_pijul :: BranchingRepoRecipe -> Property +prop_cloneRepo_pijul :: BranchingRepoRecipe 'SubmodulesNotSupported -> Property prop_cloneRepo_pijul = ioProperty . prop_cloneRepo vcsPijul vcsTestDriverPijul . WithBranchingSupport +prop_cloneRepo_hg :: BranchingRepoRecipe 'SubmodulesNotSupported -> Property +prop_cloneRepo_hg = + ioProperty + . prop_cloneRepo vcsHg vcsTestDriverHg + . WithBranchingSupport + prop_syncRepos_git :: RepoDirSet -> SyncTargetIterations -> PrngSeed - -> BranchingRepoRecipe -> Property + -> BranchingRepoRecipe 'SubmodulesSupported -> Property prop_syncRepos_git destRepoDirs syncTargetSetIterations seed = ioProperty . prop_syncRepos vcsGit vcsTestDriverGit @@ -115,7 +144,7 @@ prop_syncRepos_darcs :: MTimeChange -> RepoDirSet -> SyncTargetIterations -> PrngSeed - -> NonBranchingRepoRecipe -> Property + -> NonBranchingRepoRecipe 'SubmodulesNotSupported -> Property prop_syncRepos_darcs mtimeChange destRepoDirs syncTargetSetIterations seed = ioProperty . prop_syncRepos vcsDarcs (vcsTestDriverDarcs mtimeChange) @@ -123,21 +152,29 @@ . WithoutBranchingSupport prop_syncRepos_pijul :: RepoDirSet -> SyncTargetIterations -> PrngSeed - -> BranchingRepoRecipe -> Property + -> BranchingRepoRecipe 'SubmodulesNotSupported -> Property prop_syncRepos_pijul destRepoDirs syncTargetSetIterations seed = ioProperty . prop_syncRepos vcsPijul vcsTestDriverPijul destRepoDirs syncTargetSetIterations seed . WithBranchingSupport +prop_syncRepos_hg :: RepoDirSet -> SyncTargetIterations -> PrngSeed + -> BranchingRepoRecipe 'SubmodulesNotSupported -> Property +prop_syncRepos_hg destRepoDirs syncTargetSetIterations seed = + ioProperty + . prop_syncRepos vcsHg vcsTestDriverHg + destRepoDirs syncTargetSetIterations seed + . WithBranchingSupport + -- ------------------------------------------------------------ -- * General test setup -- ------------------------------------------------------------ testSetup :: VCS Program -> (Verbosity -> VCS ConfiguredProgram - -> FilePath -> VCSTestDriver) - -> RepoRecipe + -> FilePath -> FilePath -> VCSTestDriver) + -> RepoRecipe submodules -> (VCSTestDriver -> FilePath -> RepoState -> IO a) -> IO a testSetup vcs mkVCSTestDriver repoRecipe theTest = do @@ -145,7 +182,8 @@ vcs' <- configureVCS verbosity vcs withTestDir verbosity "vcstest" $ \tmpdir -> do let srcRepoPath = tmpdir "src" - vcsDriver = mkVCSTestDriver verbosity vcs' srcRepoPath + submodulesPath = tmpdir "submodules" + vcsDriver = mkVCSTestDriver verbosity vcs' submodulesPath srcRepoPath repoState <- createRepo vcsDriver repoRecipe -- actual test @@ -165,8 +203,8 @@ -- prop_framework :: VCS Program -> (Verbosity -> VCS ConfiguredProgram - -> FilePath -> VCSTestDriver) - -> RepoRecipe + -> FilePath -> FilePath -> VCSTestDriver) + -> RepoRecipe submodules -> IO () prop_framework vcs mkVCSTestDriver repoRecipe = testSetup vcs mkVCSTestDriver repoRecipe $ \vcsDriver tmpdir repoState -> @@ -196,8 +234,8 @@ prop_cloneRepo :: VCS Program -> (Verbosity -> VCS ConfiguredProgram - -> FilePath -> VCSTestDriver) - -> RepoRecipe + -> FilePath -> FilePath -> VCSTestDriver) + -> RepoRecipe submodules -> IO () prop_cloneRepo vcs mkVCSTestDriver repoRecipe = testSetup vcs mkVCSTestDriver repoRecipe $ \vcsDriver tmpdir repoState -> @@ -215,6 +253,7 @@ , srpTag = Just tagname , srpBranch = Nothing , srpSubdir = [] + , srpCommand = [] } verbosity = silent @@ -229,11 +268,11 @@ prop_syncRepos :: VCS Program -> (Verbosity -> VCS ConfiguredProgram - -> FilePath -> VCSTestDriver) + -> FilePath -> FilePath -> VCSTestDriver) -> RepoDirSet -> SyncTargetIterations -> PrngSeed - -> RepoRecipe + -> RepoRecipe submodules -> IO () prop_syncRepos vcs mkVCSTestDriver repoDirs syncTargetSetIterations seed repoRecipe = @@ -315,6 +354,7 @@ , srpTag = Just tag , srpBranch = Nothing , srpSubdir = Proxy + , srpCommand = [] } (tag, workingState) = Map.elemAt tagIdx (allTags repoState) (tagIdx, prng') = randomR (0, Map.size (allTags repoState) - 1) prng @@ -346,49 +386,91 @@ -- ways: to make a pure representation of repository state, and to execute -- VCS commands to make a repository on-disk. -data FileUpdate = FileUpdate FilePath String deriving Show -data Commit = Commit [FileUpdate] deriving Show -data TaggedCommits = TaggedCommits TagName [Commit] deriving Show -data BranchCommits = BranchCommits BranchName [Commit] deriving Show +data SubmodulesSupport = SubmodulesSupported | SubmodulesNotSupported -type BranchName = String -type TagName = String +class KnownSubmodulesSupport (a :: SubmodulesSupport) where + submoduleSupport :: SubmodulesSupport +instance KnownSubmodulesSupport 'SubmodulesSupported where + submoduleSupport = SubmodulesSupported + +instance KnownSubmodulesSupport 'SubmodulesNotSupported where + submoduleSupport = SubmodulesNotSupported + +data FileUpdate = FileUpdate FilePath String + deriving Show +data SubmoduleAdd = SubmoduleAdd FilePath FilePath (Commit 'SubmodulesSupported) + deriving Show + +newtype Commit (submodules :: SubmodulesSupport) + = Commit [Either FileUpdate SubmoduleAdd] + deriving Show + +data TaggedCommits (submodules :: SubmodulesSupport) + = TaggedCommits TagName [Commit submodules] + deriving Show + +data BranchCommits (submodules :: SubmodulesSupport) + = BranchCommits BranchName [Commit submodules] + deriving Show + +type BranchName = String +type TagName = String + -- | Instructions to make a repository without branches, for VCSs that do not -- support branches (e.g. darcs). -newtype NonBranchingRepoRecipe = NonBranchingRepoRecipe [TaggedCommits] - deriving Show +newtype NonBranchingRepoRecipe submodules + = NonBranchingRepoRecipe [TaggedCommits submodules] + deriving Show -- | Instructions to make a repository with branches, for VCSs that do -- support branches (e.g. git). -newtype BranchingRepoRecipe = BranchingRepoRecipe - [Either TaggedCommits BranchCommits] +newtype BranchingRepoRecipe submodules + = BranchingRepoRecipe [Either (TaggedCommits submodules) (BranchCommits submodules)] deriving Show -data RepoRecipe = WithBranchingSupport BranchingRepoRecipe - | WithoutBranchingSupport NonBranchingRepoRecipe +data RepoRecipe submodules + = WithBranchingSupport (BranchingRepoRecipe submodules) + | WithoutBranchingSupport (NonBranchingRepoRecipe submodules) + deriving Show -- --------------------------------------------------------------------------- -- Arbitrary instances for them +genFileName :: Gen FilePath +genFileName = (\c -> "file" [c]) <$> choose ('A', 'E') + instance Arbitrary FileUpdate where - arbitrary = FileUpdate <$> genFileName <*> genFileContent + arbitrary = genOnlyFileUpdate where - genFileName = (\c -> "file" [c]) <$> choose ('A', 'E') - genFileContent = vectorOf 10 (choose ('#', '~')) + genOnlyFileUpdate = FileUpdate <$> genFileName <*> genFileContent + genFileContent = vectorOf 10 (choose ('#', '~')) -instance Arbitrary Commit where - arbitrary = Commit <$> shortListOf1 5 arbitrary +instance Arbitrary SubmoduleAdd where + arbitrary = genOnlySubmoduleAdd + where + genOnlySubmoduleAdd = SubmoduleAdd <$> genFileName <*> genSubmoduleSrc <*> arbitrary + genSubmoduleSrc = vectorOf 20 (choose ('a', 'z')) + +instance forall submodules.KnownSubmodulesSupport submodules => Arbitrary (Commit submodules) where + arbitrary = Commit <$> shortListOf1 5 fileUpdateOrSubmoduleAdd + where + fileUpdateOrSubmoduleAdd = + case submoduleSupport @submodules of + SubmodulesSupported -> frequency [ (10, Left <$> arbitrary) + , (1, Right <$> arbitrary) + ] + SubmodulesNotSupported -> Left <$> arbitrary shrink (Commit writes) = Commit <$> filter (not . null) (shrink writes) -instance Arbitrary TaggedCommits where +instance KnownSubmodulesSupport submodules => Arbitrary (TaggedCommits submodules) where arbitrary = TaggedCommits <$> genTagName <*> shortListOf1 5 arbitrary where genTagName = ("tag_" ++) <$> shortListOf1 5 (choose ('A', 'Z')) shrink (TaggedCommits tag commits) = TaggedCommits tag <$> filter (not . null) (shrink commits) -instance Arbitrary BranchCommits where +instance KnownSubmodulesSupport submodules => Arbitrary (BranchCommits submodules) where arbitrary = BranchCommits <$> genBranchName <*> shortListOf1 5 arbitrary where genBranchName = @@ -398,12 +480,12 @@ shrink (BranchCommits branch commits) = BranchCommits branch <$> filter (not . null) (shrink commits) -instance Arbitrary NonBranchingRepoRecipe where +instance KnownSubmodulesSupport submodules => Arbitrary (NonBranchingRepoRecipe submodules) where arbitrary = NonBranchingRepoRecipe <$> shortListOf1 15 arbitrary shrink (NonBranchingRepoRecipe xs) = NonBranchingRepoRecipe <$> filter (not . null) (shrink xs) -instance Arbitrary BranchingRepoRecipe where +instance KnownSubmodulesSupport submodules => Arbitrary (BranchingRepoRecipe submodules) where arbitrary = BranchingRepoRecipe <$> shortListOf1 15 taggedOrBranch where taggedOrBranch = frequency [ (3, Left <$> arbitrary) @@ -453,8 +535,16 @@ updateFile :: FilePath -> String -> RepoState -> RepoState updateFile filename content state@RepoState{currentWorking} = - state { currentWorking = Map.insert filename content currentWorking } + let removeSubmodule = Map.filterWithKey (\path _ -> not $ filename `isPrefixOf` path) currentWorking + in state { currentWorking = Map.insert filename content removeSubmodule } +addSubmodule :: FilePath -> RepoState -> RepoState -> RepoState +addSubmodule submodulePath submoduleState mainState = + let newFiles = Map.mapKeys (submodulePath ) (currentWorking submoduleState) + removeSubmodule = Map.filterWithKey (\path _ -> not $ submodulePath `isPrefixOf` path ) (currentWorking mainState) + newWorking = Map.union removeSubmodule newFiles + in mainState { currentWorking = newWorking} + addTagOrCommit :: TagOrCommitId -> RepoState -> RepoState addTagOrCommit commit state@RepoState{currentWorking, allTags} = state { allTags = Map.insert commit currentWorking allTags } @@ -534,10 +624,10 @@ -- support VCSs like git that have commit ids, so that those commit ids can be -- included in the 'RepoState's 'allTags' set. -- -createRepo :: VCSTestDriver -> RepoRecipe -> IO RepoState +createRepo :: VCSTestDriver -> RepoRecipe submodules -> IO RepoState createRepo vcsDriver@VCSTestDriver{vcsRepoRoot, vcsInit} recipe = do - createDirectory vcsRepoRoot - createDirectory (vcsRepoRoot "file") + createDirectoryIfMissing True vcsRepoRoot + createDirectoryIfMissing True (vcsRepoRoot "file") vcsInit execStateT createRepoAction initialRepoState where @@ -548,17 +638,17 @@ type CreateRepoAction a = VCSTestDriver -> a -> StateT RepoState IO () -execNonBranchingRepoRecipe :: CreateRepoAction NonBranchingRepoRecipe +execNonBranchingRepoRecipe :: CreateRepoAction (NonBranchingRepoRecipe submodules) execNonBranchingRepoRecipe vcsDriver (NonBranchingRepoRecipe taggedCommits) = mapM_ (execTaggdCommits vcsDriver) taggedCommits -execBranchingRepoRecipe :: CreateRepoAction BranchingRepoRecipe +execBranchingRepoRecipe :: CreateRepoAction (BranchingRepoRecipe submodules) execBranchingRepoRecipe vcsDriver (BranchingRepoRecipe taggedCommits) = mapM_ (either (execTaggdCommits vcsDriver) (execBranchCommits vcsDriver)) taggedCommits -execBranchCommits :: CreateRepoAction BranchCommits +execBranchCommits :: CreateRepoAction (BranchCommits submodules) execBranchCommits vcsDriver@VCSTestDriver{vcsSwitchBranch} (BranchCommits branch commits) = do mapM_ (execCommit vcsDriver) commits @@ -571,7 +661,7 @@ -- switch branch. In part this is because git cannot branch from an empty -- repo state, it complains that the master branch doesn't exist yet. -execTaggdCommits :: CreateRepoAction TaggedCommits +execTaggdCommits :: CreateRepoAction (TaggedCommits submodules) execTaggdCommits vcsDriver@VCSTestDriver{vcsTagState} (TaggedCommits tagname commits) = do mapM_ (execCommit vcsDriver) commits @@ -580,20 +670,30 @@ liftIO $ vcsTagState state tagname State.modify (addTagOrCommit tagname) -execCommit :: CreateRepoAction Commit +execCommit :: CreateRepoAction (Commit submodules) execCommit vcsDriver@VCSTestDriver{..} (Commit fileUpdates) = do - mapM_ (execFileUpdate vcsDriver) fileUpdates + mapM_ (either (execFileUpdate vcsDriver) (execSubmoduleAdd vcsDriver)) fileUpdates state <- State.get -- existing state, not updated mcommit <- liftIO $ vcsCommitChanges state State.modify (maybe id addTagOrCommit mcommit) execFileUpdate :: CreateRepoAction FileUpdate execFileUpdate VCSTestDriver{..} (FileUpdate filename content) = do + isDir <- liftIO $ doesDirectoryExist (vcsRepoRoot filename) + liftIO . when isDir $ removeDirectoryRecursive (vcsRepoRoot filename) liftIO $ writeFile (vcsRepoRoot filename) content state <- State.get -- existing state, not updated liftIO $ vcsAddFile state filename State.modify (updateFile filename content) +execSubmoduleAdd :: CreateRepoAction SubmoduleAdd +execSubmoduleAdd vcsDriver (SubmoduleAdd submodulePath source submoduleCommit) = do + submoduleVcsDriver <- liftIO $ vcsSubmoduleDriver vcsDriver source + let submoduleRecipe = WithoutBranchingSupport $ NonBranchingRepoRecipe [TaggedCommits "submodule-tag" [submoduleCommit]] + submoduleState <- liftIO $ createRepo submoduleVcsDriver submoduleRecipe + mainState <- State.get -- existing state, not updated + liftIO $ vcsAddSubmodule vcsDriver mainState (vcsRepoRoot submoduleVcsDriver) submodulePath + State.modify $ addSubmodule submodulePath submoduleState -- ------------------------------------------------------------ -- * VCSTestDriver for various VCSs @@ -609,22 +709,24 @@ -- The driver instance knows the particular repo directory. -- data VCSTestDriver = VCSTestDriver { - vcsVCS :: VCS ConfiguredProgram, - vcsRepoRoot :: FilePath, - vcsIgnoreFiles :: Set FilePath, - vcsInit :: IO (), - vcsAddFile :: RepoState -> FilePath -> IO (), - vcsCommitChanges :: RepoState -> IO (Maybe CommitId), - vcsTagState :: RepoState -> TagName -> IO (), - vcsSwitchBranch :: RepoState -> BranchName -> IO (), - vcsCheckoutTag :: Either (TagName -> IO ()) - (TagName -> FilePath -> IO ()) + vcsVCS :: VCS ConfiguredProgram, + vcsRepoRoot :: FilePath, + vcsIgnoreFiles :: Set FilePath, + vcsInit :: IO (), + vcsAddFile :: RepoState -> FilePath -> IO (), + vcsSubmoduleDriver :: FilePath -> IO VCSTestDriver, + vcsAddSubmodule :: RepoState -> FilePath -> FilePath -> IO (), + vcsCommitChanges :: RepoState -> IO (Maybe CommitId), + vcsTagState :: RepoState -> TagName -> IO (), + vcsSwitchBranch :: RepoState -> BranchName -> IO (), + vcsCheckoutTag :: Either (TagName -> IO ()) + (TagName -> FilePath -> IO ()) } vcsTestDriverGit :: Verbosity -> VCS ConfiguredProgram - -> FilePath -> VCSTestDriver -vcsTestDriverGit verbosity vcs repoRoot = + -> FilePath -> FilePath -> VCSTestDriver +vcsTestDriverGit verbosity vcs submoduleDir repoRoot = VCSTestDriver { vcsVCS = vcs @@ -650,13 +752,31 @@ , vcsTagState = \_ tagname -> git ["tag", "--force", "--no-sign", tagname] + , vcsSubmoduleDriver = + pure . vcsTestDriverGit verbosity vcs submoduleDir . (submoduleDir ) + + , vcsAddSubmodule = \_ source dest -> do + destExists <- (||) <$> doesFileExist (repoRoot dest) + <*> doesDirectoryExist (repoRoot dest) + when destExists $ git ["rm", "-f", dest] + -- If there is an old submodule git dir with the same name, remove it. + -- It most likely has a different URL and `git submodule add` will fai. + submoduleGitDirExists <- doesDirectoryExist $ submoduleGitDir dest + when submoduleGitDirExists $ removeDirectoryRecursive (submoduleGitDir dest) + git ["submodule", "add", source, dest] + git ["submodule", "update", "--init", "--recursive", "--force"] + , vcsSwitchBranch = \RepoState{allBranches} branchname -> do + deinitAndRemoveCachedSubmodules unless (branchname `Map.member` allBranches) $ git ["branch", branchname] git $ ["checkout", branchname] ++ verboseArg + updateSubmodulesAndCleanup - , vcsCheckoutTag = Left $ \tagname -> + , vcsCheckoutTag = Left $ \tagname -> do + deinitAndRemoveCachedSubmodules git $ ["checkout", "--detach", "--force", tagname] ++ verboseArg + updateSubmodulesAndCleanup } where gitInvocation args = (programInvocation (vcsProgram vcs) args) { @@ -665,13 +785,24 @@ git = runProgramInvocation verbosity . gitInvocation git' = getProgramInvocationOutput verbosity . gitInvocation verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] + submoduleGitDir path = repoRoot ".git" "modules" path + deinitAndRemoveCachedSubmodules = do + git $ ["submodule", "deinit", "--force", "--all"] ++ verboseArg + let gitModulesDir = repoRoot ".git" "modules" + gitModulesExists <- doesDirectoryExist gitModulesDir + when gitModulesExists $ removeDirectoryRecursive gitModulesDir + updateSubmodulesAndCleanup = do + git $ ["submodule", "sync", "--recursive"] ++ verboseArg + git $ ["submodule", "update", "--init", "--recursive", "--force"] ++ verboseArg + git $ ["submodule", "foreach", "--recursive"] ++ verboseArg ++ ["git clean -ffxdq"] + git $ ["clean", "-ffxdq"] ++ verboseArg type MTimeChange = Int vcsTestDriverDarcs :: MTimeChange -> Verbosity -> VCS ConfiguredProgram - -> FilePath -> VCSTestDriver -vcsTestDriverDarcs mtimeChange verbosity vcs repoRoot = + -> FilePath -> FilePath -> VCSTestDriver +vcsTestDriverDarcs mtimeChange verbosity vcs _ repoRoot = VCSTestDriver { vcsVCS = vcs @@ -689,6 +820,12 @@ -- Darcs's file change tracking relies on mtime changes, -- so we have to be careful with doing stuff too quickly: + , vcsSubmoduleDriver = \_-> + fail "vcsSubmoduleDriver: darcs does not support submodules" + + , vcsAddSubmodule = \_ _ _ -> + fail "vcsAddSubmodule: darcs does not support submodules" + , vcsCommitChanges = \_state -> do threadDelay mtimeChange darcs ["record", "--all", "--author=author", "--name=a patch"] @@ -711,8 +848,8 @@ vcsTestDriverPijul :: Verbosity -> VCS ConfiguredProgram - -> FilePath -> VCSTestDriver -vcsTestDriverPijul verbosity vcs repoRoot = + -> FilePath -> FilePath -> VCSTestDriver +vcsTestDriverPijul verbosity vcs _ repoRoot = VCSTestDriver { vcsVCS = vcs @@ -726,6 +863,12 @@ , vcsAddFile = \_ filename -> pijul ["add", filename] + , vcsSubmoduleDriver = \_ -> + fail "vcsSubmoduleDriver: pijul does not support submodules" + + , vcsAddSubmodule = \_ _ _ -> + fail "vcsAddSubmodule: pijul does not support submodules" + , vcsCommitChanges = \_state -> do pijul $ ["record", "-a", "-m 'a patch'" , "-A 'A '" @@ -753,3 +896,52 @@ } pijul = runProgramInvocation verbosity . gitInvocation pijul' = getProgramInvocationOutput verbosity . gitInvocation + +vcsTestDriverHg :: Verbosity -> VCS ConfiguredProgram + -> FilePath -> FilePath -> VCSTestDriver +vcsTestDriverHg verbosity vcs _ repoRoot = + VCSTestDriver { + vcsVCS = vcs + + , vcsRepoRoot = repoRoot + + , vcsIgnoreFiles = Set.empty + + , vcsInit = + hg $ ["init"] ++ verboseArg + + , vcsAddFile = \_ filename -> + hg ["add", filename] + + , vcsSubmoduleDriver = \_ -> + fail "vcsSubmoduleDriver: hg submodules not supported" + + , vcsAddSubmodule = \_ _ _ -> + fail "vcsAddSubmodule: hg submodules not supported" + + , vcsCommitChanges = \_state -> do + hg $ [ "--user='A '" + , "commit", "--message=a patch" + ] ++ verboseArg + commit <- hg' ["log", "--template='{node}\\n' -l1"] + let commit' = takeWhile (not . isSpace) commit + return (Just commit') + + , vcsTagState = \_ tagname -> + hg ["tag", "--force", tagname] + + , vcsSwitchBranch = \RepoState{allBranches} branchname -> do + unless (branchname `Map.member` allBranches) $ + hg ["branch", branchname] + hg $ ["checkout", branchname] ++ verboseArg + + , vcsCheckoutTag = Left $ \tagname -> + hg $ ["checkout", "--rev", tagname] ++ verboseArg + } + where + hgInvocation args = (programInvocation (vcsProgram vcs) args) { + progInvokeCwd = Just repoRoot + } + hg = runProgramInvocation verbosity . hgInvocation + hg' = getProgramInvocationOutput verbosity . hgInvocation + verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] diff --git a/cabal/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs b/cabal/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs @@ -0,0 +1,823 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +-- | DSL for testing the modular solver +module UnitTests.Distribution.Solver.Modular.DSL ( + ExampleDependency(..) + , Dependencies(..) + , ExSubLib(..) + , ExTest(..) + , ExExe(..) + , ExConstraint(..) + , ExPreference(..) + , ExampleDb + , ExampleVersionRange + , ExamplePkgVersion + , ExamplePkgName + , ExampleFlagName + , ExFlag(..) + , ExampleAvailable(..) + , ExampleInstalled(..) + , ExampleQualifier(..) + , ExampleVar(..) + , EnableAllTests(..) + , dependencies + , publicDependencies + , unbuildableDependencies + , exAv + , exAvNoLibrary + , exInst + , exSubLib + , exTest + , exExe + , exFlagged + , exResolve + , extractInstallPlan + , declareFlags + , withSubLibrary + , withSubLibraries + , withSetupDeps + , withTest + , withTests + , withExe + , withExes + , runProgress + , mkSimpleVersion + , mkVersionRange + ) where + +import Prelude () +import Distribution.Solver.Compat.Prelude +import Distribution.Utils.Generic + +-- base +import Control.Arrow (second) +import qualified Data.Map as Map +import qualified Distribution.Compat.NonEmptySet as NonEmptySet + +-- Cabal +import qualified Distribution.CabalSpecVersion as C +import qualified Distribution.Compiler as C +import qualified Distribution.InstalledPackageInfo as IPI +import Distribution.License (License(..)) +import qualified Distribution.ModuleName as Module +import qualified Distribution.Package as C + hiding (HasUnitId(..)) +import qualified Distribution.Types.ExeDependency as C +import qualified Distribution.Types.ForeignLib as C +import qualified Distribution.Types.LegacyExeDependency as C +import qualified Distribution.Types.LibraryVisibility as C +import qualified Distribution.Types.PkgconfigDependency as C +import qualified Distribution.Types.PkgconfigVersion as C +import qualified Distribution.Types.PkgconfigVersionRange as C +import qualified Distribution.Types.UnqualComponentName as C +import qualified Distribution.Types.CondTree as C +import qualified Distribution.PackageDescription as C +import qualified Distribution.PackageDescription.Check as C +import qualified Distribution.Simple.PackageIndex as C.PackageIndex +import Distribution.Simple.Setup (BooleanFlag(..)) +import qualified Distribution.System as C +import Distribution.Text (display) +import qualified Distribution.Verbosity as C +import qualified Distribution.Version as C +import qualified Distribution.Utils.Path as C +import Language.Haskell.Extension (Extension(..), Language(..)) + +-- cabal-install +import Distribution.Client.Dependency +import Distribution.Client.Dependency.Types +import Distribution.Client.Types +import qualified Distribution.Client.SolverInstallPlan as CI.SolverInstallPlan + +import Distribution.Solver.Types.ComponentDeps (ComponentDeps) +import qualified Distribution.Solver.Types.ComponentDeps as CD +import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.Flag +import Distribution.Solver.Types.LabeledPackageConstraint +import Distribution.Solver.Types.OptionalStanza +import qualified Distribution.Solver.Types.PackageIndex as CI.PackageIndex +import Distribution.Solver.Types.PackageConstraint +import qualified Distribution.Solver.Types.PackagePath as P +import qualified Distribution.Solver.Types.PkgConfigDb as PC +import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.SolverPackage +import Distribution.Solver.Types.SourcePackage +import Distribution.Solver.Types.Variable + +{------------------------------------------------------------------------------- + Example package database DSL + + In order to be able to set simple examples up quickly, we define a very + simple version of the package database here explicitly designed for use in + tests. + + The design of `ExampleDb` takes the perspective of the solver, not the + perspective of the package DB. This makes it easier to set up tests for + various parts of the solver, but makes the mapping somewhat awkward, because + it means we first map from "solver perspective" `ExampleDb` to the package + database format, and then the modular solver internally in `IndexConversion` + maps this back to the solver specific data structures. + + IMPLEMENTATION NOTES + -------------------- + + TODO: Perhaps these should be made comments of the corresponding data type + definitions. For now these are just my own conclusions and may be wrong. + + * The difference between `GenericPackageDescription` and `PackageDescription` + is that `PackageDescription` describes a particular _configuration_ of a + package (for instance, see documentation for `checkPackage`). A + `GenericPackageDescription` can be turned into a `PackageDescription` in + two ways: + + a. `finalizePD` does the proper translation, by taking + into account the platform, available dependencies, etc. and picks a + flag assignment (or gives an error if no flag assignment can be found) + b. `flattenPackageDescription` ignores flag assignment and just joins all + components together. + + The slightly odd thing is that a `GenericPackageDescription` contains a + `PackageDescription` as a field; both of the above functions do the same + thing: they take the embedded `PackageDescription` as a basis for the result + value, but override `library`, `executables`, `testSuites`, `benchmarks` + and `buildDepends`. + * The `condTreeComponents` fields of a `CondTree` is a list of triples + `(condition, then-branch, else-branch)`, where the `else-branch` is + optional. +-------------------------------------------------------------------------------} + +type ExamplePkgName = String +type ExamplePkgVersion = Int +type ExamplePkgHash = String -- for example "installed" packages +type ExampleFlagName = String +type ExampleSubLibName = String +type ExampleTestName = String +type ExampleExeName = String +type ExampleVersionRange = C.VersionRange + +data Dependencies = Dependencies { + depsVisibility :: C.LibraryVisibility + , depsIsBuildable :: Bool + , depsExampleDependencies :: [ExampleDependency] + } deriving Show + +instance Semigroup Dependencies where + deps1 <> deps2 = Dependencies { + depsVisibility = depsVisibility deps1 <> depsVisibility deps2 + , depsIsBuildable = depsIsBuildable deps1 && depsIsBuildable deps2 + , depsExampleDependencies = depsExampleDependencies deps1 ++ depsExampleDependencies deps2 + } + +instance Monoid Dependencies where + mempty = Dependencies { + depsVisibility = mempty + , depsIsBuildable = True + , depsExampleDependencies = [] + } + mappend = (<>) + +dependencies :: [ExampleDependency] -> Dependencies +dependencies deps = mempty { depsExampleDependencies = deps } + +publicDependencies :: Dependencies +publicDependencies = mempty { depsVisibility = C.LibraryVisibilityPublic } + +unbuildableDependencies :: Dependencies +unbuildableDependencies = mempty { depsIsBuildable = False } + +data ExampleDependency = + -- | Simple dependency on any version + ExAny ExamplePkgName + + -- | Simple dependency on a fixed version + | ExFix ExamplePkgName ExamplePkgVersion + + -- | Simple dependency on a range of versions, with an inclusive lower bound + -- and an exclusive upper bound. + | ExRange ExamplePkgName ExamplePkgVersion ExamplePkgVersion + + -- | Sub-library dependency + | ExSubLibAny ExamplePkgName ExampleSubLibName + + -- | Sub-library dependency on a fixed version + | ExSubLibFix ExamplePkgName ExampleSubLibName ExamplePkgVersion + + -- | Build-tool-depends dependency + | ExBuildToolAny ExamplePkgName ExampleExeName + + -- | Build-tool-depends dependency on a fixed version + | ExBuildToolFix ExamplePkgName ExampleExeName ExamplePkgVersion + + -- | Legacy build-tools dependency + | ExLegacyBuildToolAny ExamplePkgName + + -- | Legacy build-tools dependency on a fixed version + | ExLegacyBuildToolFix ExamplePkgName ExamplePkgVersion + + -- | Dependencies indexed by a flag + | ExFlagged ExampleFlagName Dependencies Dependencies + + -- | Dependency on a language extension + | ExExt Extension + + -- | Dependency on a language version + | ExLang Language + + -- | Dependency on a pkg-config package + | ExPkg (ExamplePkgName, ExamplePkgVersion) + deriving Show + +-- | Simplified version of D.Types.GenericPackageDescription.Flag for use in +-- example source packages. +data ExFlag = ExFlag { + exFlagName :: ExampleFlagName + , exFlagDefault :: Bool + , exFlagType :: FlagType + } deriving Show + +data ExSubLib = ExSubLib ExampleSubLibName Dependencies + +data ExTest = ExTest ExampleTestName Dependencies + +data ExExe = ExExe ExampleExeName Dependencies + +exSubLib :: ExampleSubLibName -> [ExampleDependency] -> ExSubLib +exSubLib name deps = ExSubLib name (dependencies deps) + +exTest :: ExampleTestName -> [ExampleDependency] -> ExTest +exTest name deps = ExTest name (dependencies deps) + +exExe :: ExampleExeName -> [ExampleDependency] -> ExExe +exExe name deps = ExExe name (dependencies deps) + +exFlagged :: ExampleFlagName -> [ExampleDependency] -> [ExampleDependency] + -> ExampleDependency +exFlagged n t e = ExFlagged n (dependencies t) (dependencies e) + +data ExConstraint = + ExVersionConstraint ConstraintScope ExampleVersionRange + | ExFlagConstraint ConstraintScope ExampleFlagName Bool + | ExStanzaConstraint ConstraintScope [OptionalStanza] + deriving Show + +data ExPreference = + ExPkgPref ExamplePkgName ExampleVersionRange + | ExStanzaPref ExamplePkgName [OptionalStanza] + deriving Show + +data ExampleAvailable = ExAv { + exAvName :: ExamplePkgName + , exAvVersion :: ExamplePkgVersion + , exAvDeps :: ComponentDeps Dependencies + + -- Setting flags here is only necessary to override the default values of + -- the fields in C.Flag. + , exAvFlags :: [ExFlag] + } deriving Show + +data ExampleVar = + P ExampleQualifier ExamplePkgName + | F ExampleQualifier ExamplePkgName ExampleFlagName + | S ExampleQualifier ExamplePkgName OptionalStanza + +data ExampleQualifier = + QualNone + | QualIndep ExamplePkgName + | QualSetup ExamplePkgName + + -- The two package names are the build target and the package containing the + -- setup script. + | QualIndepSetup ExamplePkgName ExamplePkgName + + -- The two package names are the package depending on the exe and the + -- package containing the exe. + | QualExe ExamplePkgName ExamplePkgName + +-- | Whether to enable tests in all packages in a test case. +newtype EnableAllTests = EnableAllTests Bool + deriving BooleanFlag + +-- | Constructs an 'ExampleAvailable' package for the 'ExampleDb', +-- given: +-- +-- 1. The name 'ExamplePkgName' of the available package, +-- 2. The version 'ExamplePkgVersion' available +-- 3. The list of dependency constraints ('ExampleDependency') +-- for this package's library component. 'ExampleDependency' +-- provides a number of pre-canned dependency types to look at. +-- +exAv :: ExamplePkgName -> ExamplePkgVersion -> [ExampleDependency] + -> ExampleAvailable +exAv n v ds = (exAvNoLibrary n v) { exAvDeps = CD.fromLibraryDeps (dependencies ds) } + +-- | Constructs an 'ExampleAvailable' package without a default library +-- component. +exAvNoLibrary :: ExamplePkgName -> ExamplePkgVersion -> ExampleAvailable +exAvNoLibrary n v = ExAv { exAvName = n + , exAvVersion = v + , exAvDeps = CD.empty + , exAvFlags = [] } + +-- | Override the default settings (e.g., manual vs. automatic) for a subset of +-- a package's flags. +declareFlags :: [ExFlag] -> ExampleAvailable -> ExampleAvailable +declareFlags flags ex = ex { + exAvFlags = flags + } + +withSubLibrary :: ExampleAvailable -> ExSubLib -> ExampleAvailable +withSubLibrary ex lib = withSubLibraries ex [lib] + +withSubLibraries :: ExampleAvailable -> [ExSubLib] -> ExampleAvailable +withSubLibraries ex libs = + let subLibCDs = CD.fromList [(CD.ComponentSubLib $ C.mkUnqualComponentName name, deps) + | ExSubLib name deps <- libs] + in ex { exAvDeps = exAvDeps ex <> subLibCDs } + +withSetupDeps :: ExampleAvailable -> [ExampleDependency] -> ExampleAvailable +withSetupDeps ex setupDeps = ex { + exAvDeps = exAvDeps ex <> CD.fromSetupDeps (dependencies setupDeps) + } + +withTest :: ExampleAvailable -> ExTest -> ExampleAvailable +withTest ex test = withTests ex [test] + +withTests :: ExampleAvailable -> [ExTest] -> ExampleAvailable +withTests ex tests = + let testCDs = CD.fromList [(CD.ComponentTest $ C.mkUnqualComponentName name, deps) + | ExTest name deps <- tests] + in ex { exAvDeps = exAvDeps ex <> testCDs } + +withExe :: ExampleAvailable -> ExExe -> ExampleAvailable +withExe ex exe = withExes ex [exe] + +withExes :: ExampleAvailable -> [ExExe] -> ExampleAvailable +withExes ex exes = + let exeCDs = CD.fromList [(CD.ComponentExe $ C.mkUnqualComponentName name, deps) + | ExExe name deps <- exes] + in ex { exAvDeps = exAvDeps ex <> exeCDs } + +-- | An installed package in 'ExampleDb'; construct me with 'exInst'. +data ExampleInstalled = ExInst { + exInstName :: ExamplePkgName + , exInstVersion :: ExamplePkgVersion + , exInstHash :: ExamplePkgHash + , exInstBuildAgainst :: [ExamplePkgHash] + } deriving Show + +-- | Constructs an example installed package given: +-- +-- 1. The name of the package 'ExamplePkgName', i.e., 'String' +-- 2. The version of the package 'ExamplePkgVersion', i.e., 'Int' +-- 3. The IPID for the package 'ExamplePkgHash', i.e., 'String' +-- (just some unique identifier for the package.) +-- 4. The 'ExampleInstalled' packages which this package was +-- compiled against.) +-- +exInst :: ExamplePkgName -> ExamplePkgVersion -> ExamplePkgHash + -> [ExampleInstalled] -> ExampleInstalled +exInst pn v hash deps = ExInst pn v hash (map exInstHash deps) + +-- | An example package database is a list of installed packages +-- 'ExampleInstalled' and available packages 'ExampleAvailable'. +-- Generally, you want to use 'exInst' and 'exAv' to construct +-- these packages. +type ExampleDb = [Either ExampleInstalled ExampleAvailable] + +type DependencyTree a = C.CondTree C.ConfVar [C.Dependency] a + +type DependencyComponent a = C.CondBranch C.ConfVar [C.Dependency] a + +exDbPkgs :: ExampleDb -> [ExamplePkgName] +exDbPkgs = map (either exInstName exAvName) + +exAvSrcPkg :: ExampleAvailable -> UnresolvedSourcePackage +exAvSrcPkg ex = + let pkgId = exAvPkgId ex + + flags :: [C.PackageFlag] + flags = + let declaredFlags :: Map ExampleFlagName C.PackageFlag + declaredFlags = + Map.fromListWith + (\f1 f2 -> error $ "duplicate flag declarations: " ++ show [f1, f2]) + [(exFlagName flag, mkFlag flag) | flag <- exAvFlags ex] + + usedFlags :: Map ExampleFlagName C.PackageFlag + usedFlags = Map.fromList [(fn, mkDefaultFlag fn) | fn <- names] + where + names = extractFlags $ CD.flatDeps (exAvDeps ex) + in -- 'declaredFlags' overrides 'usedFlags' to give flags non-default settings: + Map.elems $ declaredFlags `Map.union` usedFlags + + subLibraries = [(name, deps) | (CD.ComponentSubLib name, deps) <- CD.toList (exAvDeps ex)] + foreignLibraries = [(name, deps) | (CD.ComponentFLib name, deps) <- CD.toList (exAvDeps ex)] + testSuites = [(name, deps) | (CD.ComponentTest name, deps) <- CD.toList (exAvDeps ex)] + benchmarks = [(name, deps) | (CD.ComponentBench name, deps) <- CD.toList (exAvDeps ex)] + executables = [(name, deps) | (CD.ComponentExe name, deps) <- CD.toList (exAvDeps ex)] + setup = case depsExampleDependencies $ CD.setupDeps (exAvDeps ex) of + [] -> Nothing + deps -> Just C.SetupBuildInfo { + C.setupDepends = mkSetupDeps deps, + C.defaultSetupDepends = False + } + package = SourcePackage + { srcpkgPackageId = pkgId + , srcpkgSource = LocalTarballPackage "<>" + , srcpkgDescrOverride = Nothing + , srcpkgDescription = C.GenericPackageDescription { + C.packageDescription = C.emptyPackageDescription { + C.package = pkgId + , C.setupBuildInfo = setup + , C.licenseRaw = Right BSD3 + , C.buildTypeRaw = if isNothing setup + then Just C.Simple + else Just C.Custom + , C.category = "category" + , C.maintainer = "maintainer" + , C.description = "description" + , C.synopsis = "synopsis" + , C.licenseFiles = [C.unsafeMakeSymbolicPath "LICENSE"] + -- Version 2.0 is required for internal libraries. + , C.specVersion = C.CabalSpecV2_0 + } + , C.gpdScannedVersion = Nothing + , C.genPackageFlags = flags + , C.condLibrary = + let mkLib v bi = mempty { C.libVisibility = v, C.libBuildInfo = bi } + -- Avoid using the Monoid instance for [a] when getting + -- the library dependencies, to allow for the possibility + -- that the package doesn't have a library: + libDeps = lookup CD.ComponentLib (CD.toList (exAvDeps ex)) + in mkTopLevelCondTree defaultLib mkLib <$> libDeps + , C.condSubLibraries = + let mkTree = mkTopLevelCondTree defaultSubLib mkLib + mkLib v bi = mempty { C.libVisibility = v, C.libBuildInfo = bi } + in map (second mkTree) subLibraries + , C.condForeignLibs = + let mkTree = mkTopLevelCondTree (mkLib defaultTopLevelBuildInfo) (const mkLib) + mkLib bi = mempty { C.foreignLibBuildInfo = bi } + in map (second mkTree) foreignLibraries + , C.condExecutables = + let mkTree = mkTopLevelCondTree defaultExe (const mkExe) + mkExe bi = mempty { C.buildInfo = bi } + in map (second mkTree) executables + , C.condTestSuites = + let mkTree = mkTopLevelCondTree defaultTest (const mkTest) + mkTest bi = mempty { C.testBuildInfo = bi } + in map (second mkTree) testSuites + , C.condBenchmarks = + let mkTree = mkTopLevelCondTree defaultBenchmark (const mkBench) + mkBench bi = mempty { C.benchmarkBuildInfo = bi } + in map (second mkTree) benchmarks + } + } + pkgCheckErrors = + -- We ignore these warnings because some unit tests test that the + -- solver allows unknown extensions/languages when the compiler + -- supports them. + let ignore = ["Unknown extensions:", "Unknown languages:"] + in [ err | err <- C.checkPackage (srcpkgDescription package) Nothing + , not $ any (`isPrefixOf` C.explanation err) ignore ] + in if null pkgCheckErrors + then package + else error $ "invalid GenericPackageDescription for package " + ++ display pkgId ++ ": " ++ show pkgCheckErrors + where + defaultTopLevelBuildInfo :: C.BuildInfo + defaultTopLevelBuildInfo = mempty { C.defaultLanguage = Just Haskell98 } + + defaultLib :: C.Library + defaultLib = mempty { + C.libBuildInfo = defaultTopLevelBuildInfo + , C.exposedModules = [Module.fromString "Module"] + , C.libVisibility = C.LibraryVisibilityPublic + } + + defaultSubLib :: C.Library + defaultSubLib = mempty { + C.libBuildInfo = defaultTopLevelBuildInfo + , C.exposedModules = [Module.fromString "Module"] + } + + defaultExe :: C.Executable + defaultExe = mempty { + C.buildInfo = defaultTopLevelBuildInfo + , C.modulePath = "Main.hs" + } + + defaultTest :: C.TestSuite + defaultTest = mempty { + C.testBuildInfo = defaultTopLevelBuildInfo + , C.testInterface = C.TestSuiteExeV10 (C.mkVersion [1,0]) "Test.hs" + } + + defaultBenchmark :: C.Benchmark + defaultBenchmark = mempty { + C.benchmarkBuildInfo = defaultTopLevelBuildInfo + , C.benchmarkInterface = C.BenchmarkExeV10 (C.mkVersion [1,0]) "Benchmark.hs" + } + + -- Split the set of dependencies into the set of dependencies of the library, + -- the dependencies of the test suites and extensions. + splitTopLevel :: [ExampleDependency] + -> ( [ExampleDependency] + , [Extension] + , Maybe Language + , [(ExamplePkgName, ExamplePkgVersion)] -- pkg-config + , [(ExamplePkgName, ExampleExeName, C.VersionRange)] -- build tools + , [(ExamplePkgName, C.VersionRange)] -- legacy build tools + ) + splitTopLevel [] = + ([], [], Nothing, [], [], []) + splitTopLevel (ExBuildToolAny p e:deps) = + let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps + in (other, exts, lang, pcpkgs, (p, e, C.anyVersion):exes, legacyExes) + splitTopLevel (ExBuildToolFix p e v:deps) = + let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps + in (other, exts, lang, pcpkgs, (p, e, C.thisVersion (mkSimpleVersion v)):exes, legacyExes) + splitTopLevel (ExLegacyBuildToolAny p:deps) = + let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps + in (other, exts, lang, pcpkgs, exes, (p, C.anyVersion):legacyExes) + splitTopLevel (ExLegacyBuildToolFix p v:deps) = + let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps + in (other, exts, lang, pcpkgs, exes, (p, C.thisVersion (mkSimpleVersion v)):legacyExes) + splitTopLevel (ExExt ext:deps) = + let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps + in (other, ext:exts, lang, pcpkgs, exes, legacyExes) + splitTopLevel (ExLang lang:deps) = + case splitTopLevel deps of + (other, exts, Nothing, pcpkgs, exes, legacyExes) -> (other, exts, Just lang, pcpkgs, exes, legacyExes) + _ -> error "Only 1 Language dependency is supported" + splitTopLevel (ExPkg pkg:deps) = + let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps + in (other, exts, lang, pkg:pcpkgs, exes, legacyExes) + splitTopLevel (dep:deps) = + let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps + in (dep:other, exts, lang, pcpkgs, exes, legacyExes) + + -- Extract the total set of flags used + extractFlags :: Dependencies -> [ExampleFlagName] + extractFlags deps = concatMap go (depsExampleDependencies deps) + where + go :: ExampleDependency -> [ExampleFlagName] + go (ExAny _) = [] + go (ExFix _ _) = [] + go (ExRange _ _ _) = [] + go (ExSubLibAny _ _) = [] + go (ExSubLibFix _ _ _) = [] + go (ExBuildToolAny _ _) = [] + go (ExBuildToolFix _ _ _) = [] + go (ExLegacyBuildToolAny _) = [] + go (ExLegacyBuildToolFix _ _) = [] + go (ExFlagged f a b) = f : extractFlags a ++ extractFlags b + go (ExExt _) = [] + go (ExLang _) = [] + go (ExPkg _) = [] + + -- Convert 'Dependencies' into a tree of a specific component type, using + -- the given top level component and function for creating a component at + -- any level. + mkTopLevelCondTree :: forall a. Semigroup a => + a + -> (C.LibraryVisibility -> C.BuildInfo -> a) + -> Dependencies + -> DependencyTree a + mkTopLevelCondTree defaultTopLevel mkComponent deps = + let 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 mkComponent deps = + let (libraryDeps, exts, mlang, pcpkgs, buildTools, legacyBuildTools) = splitTopLevel (depsExampleDependencies deps) + (directDeps, flaggedDeps) = splitDeps libraryDeps + component = mkComponent (depsVisibility deps) bi + bi = mempty { + C.otherExtensions = exts + , C.defaultLanguage = mlang + , C.buildToolDepends = [ C.ExeDependency (C.mkPackageName p) (C.mkUnqualComponentName e) vr + | (p, e, vr) <- buildTools] + , C.buildTools = [ C.LegacyExeDependency n vr + | (n,vr) <- legacyBuildTools] + , C.pkgconfigDepends = [ C.PkgconfigDependency n' v' + | (n,v) <- pcpkgs + , let n' = C.mkPkgconfigName n + , let v' = C.PcThisVersion (mkSimplePkgconfigVersion v) ] + , 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.condTreeComponents = map (mkFlagged mkComponent) flaggedDeps + } + + mkDirect :: (ExamplePkgName, C.LibraryName, C.VersionRange) -> C.Dependency + mkDirect (dep, name, vr) = C.Dependency (C.mkPackageName dep) vr (NonEmptySet.singleton name) + + mkFlagged :: (C.LibraryVisibility -> C.BuildInfo -> a) + -> (ExampleFlagName, Dependencies, Dependencies) + -> DependencyComponent a + mkFlagged mkComponent (f, a, b) = + C.CondBranch (C.Var (C.PackageFlag (C.mkFlagName f))) + (mkCondTree mkComponent a) + (Just (mkCondTree mkComponent b)) + + -- Split a set of dependencies into direct dependencies and flagged + -- dependencies. A direct dependency is a tuple of the name of package and + -- its version range meant to be converted to a 'C.Dependency' with + -- 'mkDirect' for example. A flagged dependency is the set of dependencies + -- guarded by a flag. + splitDeps :: [ExampleDependency] + -> ( [(ExamplePkgName, C.LibraryName, C.VersionRange)] + , [(ExampleFlagName, Dependencies, Dependencies)] + ) + splitDeps [] = + ([], []) + splitDeps (ExAny p:deps) = + let (directDeps, flaggedDeps) = splitDeps deps + in ((p, C.LMainLibName, C.anyVersion):directDeps, flaggedDeps) + splitDeps (ExFix p v:deps) = + let (directDeps, flaggedDeps) = splitDeps deps + in ((p, C.LMainLibName, C.thisVersion $ mkSimpleVersion v):directDeps, flaggedDeps) + splitDeps (ExRange p v1 v2:deps) = + let (directDeps, flaggedDeps) = splitDeps deps + in ((p, C.LMainLibName, mkVersionRange v1 v2):directDeps, flaggedDeps) + splitDeps (ExSubLibAny p lib:deps) = + let (directDeps, flaggedDeps) = splitDeps deps + in ((p, C.LSubLibName (C.mkUnqualComponentName lib), C.anyVersion):directDeps, flaggedDeps) + splitDeps (ExSubLibFix p lib v:deps) = + let (directDeps, flaggedDeps) = splitDeps deps + in ((p, C.LSubLibName (C.mkUnqualComponentName lib), C.thisVersion $ mkSimpleVersion v):directDeps, flaggedDeps) + splitDeps (ExFlagged f a b:deps) = + let (directDeps, flaggedDeps) = splitDeps deps + in (directDeps, (f, a, b):flaggedDeps) + splitDeps (dep:_) = error $ "Unexpected dependency: " ++ show dep + + -- custom-setup only supports simple dependencies + mkSetupDeps :: [ExampleDependency] -> [C.Dependency] + mkSetupDeps deps = + case splitDeps deps of + (directDeps, []) -> map mkDirect directDeps + _ -> error "mkSetupDeps: custom setup has non-simple deps" + +mkSimpleVersion :: ExamplePkgVersion -> C.Version +mkSimpleVersion n = C.mkVersion [n, 0, 0] + +mkSimplePkgconfigVersion :: ExamplePkgVersion -> C.PkgconfigVersion +mkSimplePkgconfigVersion = C.versionToPkgconfigVersion . mkSimpleVersion + +mkVersionRange :: ExamplePkgVersion -> ExamplePkgVersion -> C.VersionRange +mkVersionRange v1 v2 = + C.intersectVersionRanges (C.orLaterVersion $ mkSimpleVersion v1) + (C.earlierVersion $ mkSimpleVersion v2) + +mkFlag :: ExFlag -> C.PackageFlag +mkFlag flag = C.MkPackageFlag { + C.flagName = C.mkFlagName $ exFlagName flag + , C.flagDescription = "" + , C.flagDefault = exFlagDefault flag + , C.flagManual = + case exFlagType flag of + Manual -> True + Automatic -> False + } + +mkDefaultFlag :: ExampleFlagName -> C.PackageFlag +mkDefaultFlag flag = C.MkPackageFlag { + C.flagName = C.mkFlagName flag + , C.flagDescription = "" + , C.flagDefault = True + , C.flagManual = False + } + +exAvPkgId :: ExampleAvailable -> C.PackageIdentifier +exAvPkgId ex = C.PackageIdentifier { + pkgName = C.mkPackageName (exAvName ex) + , pkgVersion = C.mkVersion [exAvVersion ex, 0, 0] + } + +exInstInfo :: ExampleInstalled -> IPI.InstalledPackageInfo +exInstInfo ex = IPI.emptyInstalledPackageInfo { + IPI.installedUnitId = C.mkUnitId (exInstHash ex) + , IPI.sourcePackageId = exInstPkgId ex + , IPI.depends = map C.mkUnitId (exInstBuildAgainst ex) + } + +exInstPkgId :: ExampleInstalled -> C.PackageIdentifier +exInstPkgId ex = C.PackageIdentifier { + pkgName = C.mkPackageName (exInstName ex) + , pkgVersion = C.mkVersion [exInstVersion ex, 0, 0] + } + +exAvIdx :: [ExampleAvailable] -> CI.PackageIndex.PackageIndex UnresolvedSourcePackage +exAvIdx = CI.PackageIndex.fromList . map exAvSrcPkg + +exInstIdx :: [ExampleInstalled] -> C.PackageIndex.InstalledPackageIndex +exInstIdx = C.PackageIndex.fromList . map exInstInfo + +exResolve :: ExampleDb + -- List of extensions supported by the compiler, or Nothing if unknown. + -> Maybe [Extension] + -- List of languages supported by the compiler, or Nothing if unknown. + -> Maybe [Language] + -> PC.PkgConfigDb + -> [ExamplePkgName] + -> Maybe Int + -> CountConflicts + -> FineGrainedConflicts + -> MinimizeConflictSet + -> IndependentGoals + -> PreferOldest + -> ReorderGoals + -> AllowBootLibInstalls + -> OnlyConstrained + -> EnableBackjumping + -> SolveExecutables + -> Maybe (Variable P.QPN -> Variable P.QPN -> Ordering) + -> [ExConstraint] + -> [ExPreference] + -> C.Verbosity + -> EnableAllTests + -> Progress String String CI.SolverInstallPlan.SolverInstallPlan +exResolve db exts langs pkgConfigDb targets mbj countConflicts + fineGrainedConflicts minimizeConflictSet indepGoals prefOldest reorder + allowBootLibInstalls onlyConstrained enableBj solveExes goalOrder + constraints prefs verbosity enableAllTests + = resolveDependencies C.buildPlatform compiler pkgConfigDb Modular params + where + defaultCompiler = C.unknownCompilerInfo C.buildCompilerId C.NoAbiTag + compiler = defaultCompiler { C.compilerInfoExtensions = exts + , C.compilerInfoLanguages = langs + } + (inst, avai) = partitionEithers db + instIdx = exInstIdx inst + avaiIdx = SourcePackageDb { + packageIndex = exAvIdx avai + , packagePreferences = Map.empty + } + enableTests + | asBool enableAllTests = fmap (\p -> PackageConstraint + (scopeToplevel (C.mkPackageName p)) + (PackagePropertyStanzas [TestStanzas])) + (exDbPkgs db) + | otherwise = [] + targets' = fmap (\p -> NamedPackage (C.mkPackageName p) []) targets + params = addConstraints (fmap toConstraint constraints) + $ addConstraints (fmap toLpc enableTests) + $ addPreferences (fmap toPref prefs) + $ 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 verbosity + $ standardInstallPolicy instIdx avaiIdx targets' + toLpc pc = LabeledPackageConstraint pc ConstraintSourceUnknown + + toConstraint (ExVersionConstraint scope v) = + toLpc $ PackageConstraint scope (PackagePropertyVersion v) + toConstraint (ExFlagConstraint scope fn b) = + toLpc $ PackageConstraint scope (PackagePropertyFlags (C.mkFlagAssignment [(C.mkFlagName fn, b)])) + toConstraint (ExStanzaConstraint scope stanzas) = + toLpc $ PackageConstraint scope (PackagePropertyStanzas stanzas) + + toPref (ExPkgPref n v) = PackageVersionPreference (C.mkPackageName n) v + toPref (ExStanzaPref n stanzas) = PackageStanzasPreference (C.mkPackageName n) stanzas + +extractInstallPlan :: CI.SolverInstallPlan.SolverInstallPlan + -> [(ExamplePkgName, ExamplePkgVersion)] +extractInstallPlan = catMaybes . map confPkg . CI.SolverInstallPlan.toList + where + confPkg :: CI.SolverInstallPlan.SolverPlanPackage -> Maybe (String, Int) + confPkg (CI.SolverInstallPlan.Configured pkg) = srcPkg pkg + confPkg _ = Nothing + + srcPkg :: SolverPackage UnresolvedPkgLoc -> Maybe (String, Int) + srcPkg cpkg = + let C.PackageIdentifier pn ver = C.packageId (solverPkgSource cpkg) + in (\vn -> (C.unPackageName pn, vn)) <$> safeHead (C.versionNumbers ver) + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +-- | Run Progress computation +runProgress :: Progress step e a -> ([step], Either e a) +runProgress = go + where + go (Step s p) = let (ss, result) = go p in (s:ss, result) + go (Fail e) = ([], Left e) + go (Done a) = ([], Right a) diff --git a/cabal/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs b/cabal/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs --- a/cabal/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs +++ b/cabal/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs @@ -7,6 +7,7 @@ , disableFineGrainedConflicts , minimizeConflictSet , independentGoals + , preferOldest , allowBootLibInstalls , onlyConstrained , disableBackjumping @@ -43,7 +44,7 @@ -- cabal-install import qualified Distribution.Solver.Types.PackagePath as P -import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb, pkgConfigDbFromList) +import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb (..), pkgConfigDbFromList) import Distribution.Solver.Types.Settings import Distribution.Solver.Types.Variable import Distribution.Client.Dependency (foldProgress) @@ -66,6 +67,10 @@ independentGoals :: SolverTest -> SolverTest independentGoals test = test { testIndepGoals = IndependentGoals True } +-- | Combinator to turn on --prefer-oldest +preferOldest :: SolverTest -> SolverTest +preferOldest test = test { testPreferOldest = PreferOldest True } + allowBootLibInstalls :: SolverTest -> SolverTest allowBootLibInstalls test = test { testAllowBootLibInstalls = AllowBootLibInstalls True } @@ -111,6 +116,7 @@ , testFineGrainedConflicts :: FineGrainedConflicts , testMinimizeConflictSet :: MinimizeConflictSet , testIndepGoals :: IndependentGoals + , testPreferOldest :: PreferOldest , testAllowBootLibInstalls :: AllowBootLibInstalls , testOnlyConstrained :: OnlyConstrained , testEnableBackjumping :: EnableBackjumping @@ -166,7 +172,7 @@ -> [String] -> SolverResult -> SolverTest -mkTest = mkTestExtLangPC Nothing Nothing [] +mkTest = mkTestExtLangPC Nothing Nothing (Just []) mkTestExts :: [Extension] -> ExampleDb @@ -174,7 +180,7 @@ -> [String] -> SolverResult -> SolverTest -mkTestExts exts = mkTestExtLangPC (Just exts) Nothing [] +mkTestExts exts = mkTestExtLangPC (Just exts) Nothing (Just []) mkTestLangs :: [Language] -> ExampleDb @@ -182,25 +188,25 @@ -> [String] -> SolverResult -> SolverTest -mkTestLangs langs = mkTestExtLangPC Nothing (Just langs) [] +mkTestLangs langs = mkTestExtLangPC Nothing (Just langs) (Just []) -mkTestPCDepends :: [(String, String)] +mkTestPCDepends :: Maybe [(String, String)] -> ExampleDb -> String -> [String] -> SolverResult -> SolverTest -mkTestPCDepends pkgConfigDb = mkTestExtLangPC Nothing Nothing pkgConfigDb +mkTestPCDepends mPkgConfigDb = mkTestExtLangPC Nothing Nothing mPkgConfigDb mkTestExtLangPC :: Maybe [Extension] -> Maybe [Language] - -> [(String, String)] + -> Maybe [(String, String)] -> ExampleDb -> String -> [String] -> SolverResult -> SolverTest -mkTestExtLangPC exts langs pkgConfigDb db label targets result = SolverTest { +mkTestExtLangPC exts langs mPkgConfigDb db label targets result = SolverTest { testLabel = label , testTargets = targets , testResult = result @@ -208,6 +214,7 @@ , testFineGrainedConflicts = FineGrainedConflicts True , testMinimizeConflictSet = MinimizeConflictSet False , testIndepGoals = IndependentGoals False + , testPreferOldest = PreferOldest False , testAllowBootLibInstalls = AllowBootLibInstalls False , testOnlyConstrained = OnlyConstrainedNone , testEnableBackjumping = EnableBackjumping True @@ -219,7 +226,7 @@ , testDb = db , testSupportedExts = exts , testSupportedLangs = langs - , testPkgConfigDb = pkgConfigDbFromList pkgConfigDb + , testPkgConfigDb = maybe NoPkgConfigDb pkgConfigDbFromList mPkgConfigDb , testEnableAllTests = EnableAllTests False } @@ -230,7 +237,7 @@ testSupportedLangs testPkgConfigDb testTargets testMaxBackjumps (CountConflicts True) testFineGrainedConflicts testMinimizeConflictSet - testIndepGoals (ReorderGoals False) testAllowBootLibInstalls + testIndepGoals testPreferOldest (ReorderGoals False) testAllowBootLibInstalls testOnlyConstrained testEnableBackjumping testSolveExecutables (sortGoals <$> testGoalOrder) testConstraints testSoftConstraints testVerbosity testEnableAllTests diff --git a/cabal/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs b/cabal/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs --- a/cabal/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs +++ b/cabal/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs @@ -57,7 +57,7 @@ r2 = solve' mGoalOrder2 test { testTargets = targets2 } solve' goalOrder = solve (EnableBackjumping True) (FineGrainedConflicts True) - (ReorderGoals False) (CountConflicts True) indepGoals + (ReorderGoals False) (CountConflicts True) indepGoals (PreferOldest False) (getBlind <$> goalOrder) targets = testTargets test targets2 = case targetOrder of @@ -74,7 +74,7 @@ r2 = solve' (IndependentGoals True) test solve' indep = solve (EnableBackjumping True) (FineGrainedConflicts True) - reorderGoals (CountConflicts True) indep Nothing + reorderGoals (CountConflicts True) indep (PreferOldest False)Nothing in counterexample (showResults r1 r2) $ noneReachedBackjumpLimit [r1, r2] ==> isRight (resultPlan r1) `implies` isRight (resultPlan r2) @@ -85,7 +85,7 @@ r2 = solve' (EnableBackjumping False) test solve' enableBj = solve enableBj (FineGrainedConflicts False) reorderGoals - (CountConflicts True) indepGoals Nothing + (CountConflicts True) indepGoals (PreferOldest False) Nothing in counterexample (showResults r1 r2) $ noneReachedBackjumpLimit [r1, r2] ==> isRight (resultPlan r1) === isRight (resultPlan r2) @@ -96,11 +96,22 @@ r2 = solve' (FineGrainedConflicts False) test solve' fineGrainedConflicts = solve (EnableBackjumping True) fineGrainedConflicts - reorderGoals (CountConflicts True) indepGoals Nothing + reorderGoals (CountConflicts True) indepGoals (PreferOldest False) Nothing in counterexample (showResults r1 r2) $ noneReachedBackjumpLimit [r1, r2] ==> isRight (resultPlan r1) === isRight (resultPlan r2) + , testPropertyWithSeed "prefer oldest does not affect solvability" $ + \test reorderGoals indepGoals -> + let r1 = solve' (PreferOldest True) test + r2 = solve' (PreferOldest False) test + solve' prefOldest = + solve (EnableBackjumping True) (FineGrainedConflicts True) + reorderGoals (CountConflicts True) indepGoals prefOldest Nothing + in counterexample (showResults r1 r2) $ + noneReachedBackjumpLimit [r1, r2] ==> + isRight (resultPlan r1) === isRight (resultPlan r2) + -- The next two tests use --no-count-conflicts, because the goal order used -- with --count-conflicts depends on the total set of conflicts seen by the -- solver. The solver explores more of the tree and encounters more @@ -116,7 +127,7 @@ r2 = solve' (EnableBackjumping False) test solve' enableBj = solve enableBj (FineGrainedConflicts False) reorderGoals - (CountConflicts False) indepGoals Nothing + (CountConflicts False) indepGoals (PreferOldest False) Nothing in counterexample (showResults r1 r2) $ noneReachedBackjumpLimit [r1, r2] ==> resultPlan r1 === resultPlan r2 @@ -128,7 +139,7 @@ r2 = solve' (FineGrainedConflicts False) test solve' fineGrainedConflicts = solve (EnableBackjumping True) fineGrainedConflicts - reorderGoals (CountConflicts False) indepGoals Nothing + reorderGoals (CountConflicts False) indepGoals (PreferOldest False) Nothing in counterexample (showResults r1 r2) $ noneReachedBackjumpLimit [r1, r2] ==> resultPlan r1 === resultPlan r2 @@ -163,10 +174,11 @@ -> ReorderGoals -> CountConflicts -> IndependentGoals + -> PreferOldest -> Maybe VarOrdering -> SolverTest -> Result -solve enableBj fineGrainedConflicts reorder countConflicts indep goalOrder test = +solve enableBj fineGrainedConflicts reorder countConflicts indep prefOldest goalOrder test = let (lg, result) = runProgress $ exResolve (unTestDb (testDb test)) Nothing Nothing (pkgConfigDbFromList []) @@ -175,7 +187,7 @@ -- too much time and memory. (Just defaultMaxBackjumps) countConflicts fineGrainedConflicts - (MinimizeConflictSet False) indep reorder + (MinimizeConflictSet False) indep prefOldest reorder (AllowBootLibInstalls False) OnlyConstrainedNone enableBj (SolveExecutables True) (unVarOrdering <$> goalOrder) (testConstraints test) (testPreferences test) normal diff --git a/cabal/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs b/cabal/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs --- a/cabal/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs +++ b/cabal/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs @@ -30,6 +30,8 @@ testGroup "Simple dependencies" [ runTest $ mkTest db1 "alreadyInstalled" ["A"] (solverSuccess []) , runTest $ mkTest db1 "installLatest" ["B"] (solverSuccess [("B", 2)]) + , runTest $ preferOldest + $ mkTest db1 "installOldest" ["B"] (solverSuccess [("B", 1)]) , runTest $ mkTest db1 "simpleDep1" ["C"] (solverSuccess [("B", 1), ("C", 1)]) , runTest $ mkTest db1 "simpleDep2" ["D"] (solverSuccess [("B", 2), ("D", 1)]) , runTest $ mkTest db1 "failTwoVersions" ["C", "D"] anySolverFailure @@ -253,10 +255,12 @@ , runTest $ mkTest dbBuildable2 "choose version that sets buildable to false" ["A"] (solverSuccess [("A", 1), ("B", 2)]) ] , testGroup "Pkg-config dependencies" [ - runTest $ mkTestPCDepends [] dbPC1 "noPkgs" ["A"] anySolverFailure - , runTest $ mkTestPCDepends [("pkgA", "0")] dbPC1 "tooOld" ["A"] anySolverFailure - , runTest $ mkTestPCDepends [("pkgA", "1.0.0"), ("pkgB", "1.0.0")] dbPC1 "pruneNotFound" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)]) - , runTest $ mkTestPCDepends [("pkgA", "1.0.0"), ("pkgB", "2.0.0")] dbPC1 "chooseNewest" ["C"] (solverSuccess [("A", 1), ("B", 2), ("C", 1)]) + 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 Nothing dbPC1 "noPkgConfigFailure" ["A"] anySolverFailure + , runTest $ mkTestPCDepends Nothing dbPC1 "noPkgConfigSuccess" ["D"] (solverSuccess [("D",1)]) ] , testGroup "Independent goals" [ runTest $ indep $ mkTest db16 "indepGoals1" ["A", "B"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1), ("D", 2), ("E", 1)]) @@ -1570,7 +1574,7 @@ -- or also its link target. -- -- It turns out that as long as the Single Instance Restriction is in place, --- it does not matter, because there will aways be an option that is failing +-- it does not matter, because there will always be an option that is failing -- due to the SIR, which contains the link target in its conflict set. -- -- Even if the SIR is not in place, if there is a solution, one will always @@ -1665,7 +1669,7 @@ testBuildable :: String -> ExampleDependency -> TestTree testBuildable testName unavailableDep = runTest $ - mkTestExtLangPC (Just []) (Just [Haskell98]) [] db testName ["pkg"] expected + mkTestExtLangPC (Just []) (Just [Haskell98]) (Just []) db testName ["pkg"] expected where expected = solverSuccess [("false-dep", 1), ("pkg", 1)] db = [ @@ -1718,12 +1722,14 @@ ] -- | Package databases for testing @pkg-config@ dependencies. +-- when no pkgconfig db is present, cabal must pick flag1 false and flag2 true to avoid the pkg dependency. dbPC1 :: ExampleDb dbPC1 = [ Right $ exAv "A" 1 [ExPkg ("pkgA", 1)] , Right $ exAv "B" 1 [ExPkg ("pkgB", 1), ExAny "A"] , Right $ exAv "B" 2 [ExPkg ("pkgB", 2), ExAny "A"] , Right $ exAv "C" 1 [ExAny "B"] + , Right $ exAv "D" 1 [exFlagged "flag1" [ExAny "A"] [], exFlagged "flag2" [] [ExAny "A"]] ] -- | Test for the solver's summarized log. The final conflict set is {A, F}, diff --git a/cabal/cabal-install/tests/UnitTests/Distribution/Solver/Types/OptionalStanza.hs b/cabal/cabal-install/tests/UnitTests/Distribution/Solver/Types/OptionalStanza.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/UnitTests/Distribution/Solver/Types/OptionalStanza.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE CPP #-} +module UnitTests.Distribution.Solver.Types.OptionalStanza ( + tests, +) where + +import Distribution.Solver.Types.OptionalStanza +import UnitTests.Distribution.Client.ArbitraryInstances () + +import Test.Tasty +import Test.Tasty.QuickCheck + +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid +#endif + +tests :: [TestTree] +tests = + [ testProperty "fromList . toList = id" $ \xs -> + optStanzaSetFromList (optStanzaSetToList xs) === xs + , testProperty "member x (insert x xs) = True" $ \x xs -> + optStanzaSetMember x (optStanzaSetInsert x xs) === True + , testProperty "member x (singleton y) = (x == y)" $ \x y -> + optStanzaSetMember x (optStanzaSetSingleton y) === (x == y) + , testProperty "(subset xs ys, member x xs) ==> member x ys" $ \x xs ys -> + optStanzaSetIsSubset xs ys && optStanzaSetMember x xs ==> + optStanzaSetMember x ys + + , testProperty "tabulate index = id" $ \xs -> + optStanzaTabulate (optStanzaIndex xs) === (xs :: OptionalStanzaMap Int) + , testProperty "keysFilteredByValue" $ \xs -> + let set i = if optStanzaIndex xs i then optStanzaSetSingleton i else mempty + in optStanzaKeysFilteredByValue id xs === set TestStanzas `mappend` set BenchStanzas + ] diff --git a/cabal/cabal-install/tests/fixtures/configure/cabal.project b/cabal/cabal-install/tests/fixtures/configure/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/fixtures/configure/cabal.project @@ -0,0 +1,2 @@ +ignore-project: False +optimization: 2 diff --git a/cabal/cabal-install/tests/fixtures/configure/cabal.project.local b/cabal/cabal-install/tests/fixtures/configure/cabal.project.local new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/fixtures/configure/cabal.project.local @@ -0,0 +1,2 @@ +ignore-project: False +optimization: 2 diff --git a/cabal/cabal-install/tests/fixtures/init/golden/cabal/cabal-lib-and-exe-no-comments.golden b/cabal/cabal-install/tests/fixtures/init/golden/cabal/cabal-lib-and-exe-no-comments.golden new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/fixtures/init/golden/cabal/cabal-lib-and-exe-no-comments.golden @@ -0,0 +1,51 @@ +cabal-version: 3.0 +name: y +version: 0.1.0.0 +synopsis: synopsis +-- description: +homepage: home +license: BSD-3-Clause +license-file: LICENSE +author: foo-kmett +maintainer: foo-kmett@kmett.kmett +-- copyright: +category: Data +build-type: Simple +extra-doc-files: CHANGELOG.md +-- extra-source-files: + +common warnings + ghc-options: -Wall + +library + import: warnings + exposed-modules: MyLib + -- other-modules: + -- other-extensions: + build-depends: base + hs-source-dirs: src + default-language: Haskell98 + +executable y + import: warnings + main-is: Main.hs + -- other-modules: + -- other-extensions: + build-depends: + base, + y + + hs-source-dirs: exe + default-language: Haskell2010 + +test-suite y-test + import: warnings + default-language: Haskell2010 + -- other-modules: + -- other-extensions: + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: + base, + y diff --git a/cabal/cabal-install/tests/fixtures/init/golden/cabal/cabal-lib-and-exe-with-comments.golden b/cabal/cabal-install/tests/fixtures/init/golden/cabal/cabal-lib-and-exe-with-comments.golden new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/fixtures/init/golden/cabal/cabal-lib-and-exe-with-comments.golden @@ -0,0 +1,131 @@ +cabal-version: 3.0 +-- The cabal-version field refers to the version of the .cabal specification, +-- and can be different from the cabal-install (the tool) version and the +-- Cabal (the library) version you are using. As such, the Cabal (the library) +-- version used must be equal or greater than the version stated in this field. +-- Starting from the specification version 2.2, the cabal-version field must be +-- the first thing in the cabal file. + +-- Initial package description 'y' generated by +-- 'cabal init'. For further documentation, see: +-- http://haskell.org/cabal/users-guide/ +-- +-- The name of the package. +name: y + +-- The package version. +-- See the Haskell package versioning policy (PVP) for standards +-- guiding when and how versions should be incremented. +-- https://pvp.haskell.org +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.1.0.0 + +-- A short (one-line) description of the package. +synopsis: synopsis + +-- A longer description of the package. +-- description: + +-- URL for the project homepage or repository. +homepage: home + +-- The license under which the package is released. +license: BSD-3-Clause + +-- The file containing the license text. +license-file: LICENSE + +-- The package author(s). +author: foo-kmett + +-- An email address to which users can send suggestions, bug reports, and patches. +maintainer: foo-kmett@kmett.kmett + +-- A copyright notice. +-- copyright: +category: Data +build-type: Simple + +-- Extra doc files to be distributed with the package, such as a CHANGELOG or a README. +extra-doc-files: CHANGELOG.md + +-- Extra source files to be distributed with the package, such as examples, or a tutorial module. +-- extra-source-files: + +common warnings + ghc-options: -Wall + +library + -- Import common warning flags. + import: warnings + + -- Modules exported by the library. + exposed-modules: MyLib + + -- Modules included in this library but not exported. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- Other library packages from which modules are imported. + build-depends: base + + -- Directories containing source files. + hs-source-dirs: src + + -- Base language which the package is written in. + default-language: Haskell98 + +executable y + -- Import common warning flags. + import: warnings + + -- .hs or .lhs file containing the Main module. + main-is: Main.hs + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- Other library packages from which modules are imported. + build-depends: + base, + y + + -- Directories containing source files. + hs-source-dirs: exe + + -- Base language which the package is written in. + default-language: Haskell2010 + +test-suite y-test + -- Import common warning flags. + import: warnings + + -- Base language which the package is written in. + default-language: Haskell2010 + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- The interface type and version of the test suite. + type: exitcode-stdio-1.0 + + -- Directories containing source files. + hs-source-dirs: test + + -- The entrypoint to the test suite. + main-is: Main.hs + + -- Test dependencies. + build-depends: + base, + y diff --git a/cabal/cabal-install/tests/fixtures/init/golden/cabal/cabal-lib-no-comments.golden b/cabal/cabal-install/tests/fixtures/init/golden/cabal/cabal-lib-no-comments.golden new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/fixtures/init/golden/cabal/cabal-lib-no-comments.golden @@ -0,0 +1,39 @@ +cabal-version: 3.0 +name: y +version: 0.1.0.0 +synopsis: synopsis +-- description: +homepage: home +license: BSD-3-Clause +license-file: LICENSE +author: foo-kmett +maintainer: foo-kmett@kmett.kmett +-- copyright: +category: Data +build-type: Simple +extra-doc-files: CHANGELOG.md +-- extra-source-files: + +common warnings + ghc-options: -Wall + +library + import: warnings + exposed-modules: MyLib + -- other-modules: + -- other-extensions: + build-depends: base + hs-source-dirs: src + default-language: Haskell98 + +test-suite y-test + import: warnings + default-language: Haskell2010 + -- other-modules: + -- other-extensions: + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: + base, + y diff --git a/cabal/cabal-install/tests/fixtures/init/golden/cabal/cabal-lib-with-comments.golden b/cabal/cabal-install/tests/fixtures/init/golden/cabal/cabal-lib-with-comments.golden new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/fixtures/init/golden/cabal/cabal-lib-with-comments.golden @@ -0,0 +1,107 @@ +cabal-version: 3.0 +-- The cabal-version field refers to the version of the .cabal specification, +-- and can be different from the cabal-install (the tool) version and the +-- Cabal (the library) version you are using. As such, the Cabal (the library) +-- version used must be equal or greater than the version stated in this field. +-- Starting from the specification version 2.2, the cabal-version field must be +-- the first thing in the cabal file. + +-- Initial package description 'y' generated by +-- 'cabal init'. For further documentation, see: +-- http://haskell.org/cabal/users-guide/ +-- +-- The name of the package. +name: y + +-- The package version. +-- See the Haskell package versioning policy (PVP) for standards +-- guiding when and how versions should be incremented. +-- https://pvp.haskell.org +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.1.0.0 + +-- A short (one-line) description of the package. +synopsis: synopsis + +-- A longer description of the package. +-- description: + +-- URL for the project homepage or repository. +homepage: home + +-- The license under which the package is released. +license: BSD-3-Clause + +-- The file containing the license text. +license-file: LICENSE + +-- The package author(s). +author: foo-kmett + +-- An email address to which users can send suggestions, bug reports, and patches. +maintainer: foo-kmett@kmett.kmett + +-- A copyright notice. +-- copyright: +category: Data +build-type: Simple + +-- Extra doc files to be distributed with the package, such as a CHANGELOG or a README. +extra-doc-files: CHANGELOG.md + +-- Extra source files to be distributed with the package, such as examples, or a tutorial module. +-- extra-source-files: + +common warnings + ghc-options: -Wall + +library + -- Import common warning flags. + import: warnings + + -- Modules exported by the library. + exposed-modules: MyLib + + -- Modules included in this library but not exported. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- Other library packages from which modules are imported. + build-depends: base + + -- Directories containing source files. + hs-source-dirs: src + + -- Base language which the package is written in. + default-language: Haskell98 + +test-suite y-test + -- Import common warning flags. + import: warnings + + -- Base language which the package is written in. + default-language: Haskell2010 + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- The interface type and version of the test suite. + type: exitcode-stdio-1.0 + + -- Directories containing source files. + hs-source-dirs: test + + -- The entrypoint to the test suite. + main-is: Main.hs + + -- Test dependencies. + build-depends: + base, + y diff --git a/cabal/cabal-install/tests/fixtures/init/golden/cabal/cabal-test-suite-no-comments.golden b/cabal/cabal-install/tests/fixtures/init/golden/cabal/cabal-test-suite-no-comments.golden new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/fixtures/init/golden/cabal/cabal-test-suite-no-comments.golden @@ -0,0 +1,28 @@ +cabal-version: 3.0 +name: y +version: 0.1.0.0 +synopsis: synopsis +-- description: +homepage: home +license: BSD-3-Clause +license-file: LICENSE +author: foo-kmett +maintainer: foo-kmett@kmett.kmett +-- copyright: +category: Data +build-type: Simple +extra-doc-files: CHANGELOG.md +-- extra-source-files: + +common warnings + ghc-options: -Wall + +test-suite y-test + import: warnings + default-language: Haskell2010 + -- other-modules: + -- other-extensions: + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: base diff --git a/cabal/cabal-install/tests/fixtures/init/golden/cabal/cabal-test-suite-with-comments.golden b/cabal/cabal-install/tests/fixtures/init/golden/cabal/cabal-test-suite-with-comments.golden new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/fixtures/init/golden/cabal/cabal-test-suite-with-comments.golden @@ -0,0 +1,83 @@ +cabal-version: 3.0 +-- The cabal-version field refers to the version of the .cabal specification, +-- and can be different from the cabal-install (the tool) version and the +-- Cabal (the library) version you are using. As such, the Cabal (the library) +-- version used must be equal or greater than the version stated in this field. +-- Starting from the specification version 2.2, the cabal-version field must be +-- the first thing in the cabal file. + +-- Initial package description 'y' generated by +-- 'cabal init'. For further documentation, see: +-- http://haskell.org/cabal/users-guide/ +-- +-- The name of the package. +name: y + +-- The package version. +-- See the Haskell package versioning policy (PVP) for standards +-- guiding when and how versions should be incremented. +-- https://pvp.haskell.org +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.1.0.0 + +-- A short (one-line) description of the package. +synopsis: synopsis + +-- A longer description of the package. +-- description: + +-- URL for the project homepage or repository. +homepage: home + +-- The license under which the package is released. +license: BSD-3-Clause + +-- The file containing the license text. +license-file: LICENSE + +-- The package author(s). +author: foo-kmett + +-- An email address to which users can send suggestions, bug reports, and patches. +maintainer: foo-kmett@kmett.kmett + +-- A copyright notice. +-- copyright: +category: Data +build-type: Simple + +-- Extra doc files to be distributed with the package, such as a CHANGELOG or a README. +extra-doc-files: CHANGELOG.md + +-- Extra source files to be distributed with the package, such as examples, or a tutorial module. +-- extra-source-files: + +common warnings + ghc-options: -Wall + +test-suite y-test + -- Import common warning flags. + import: warnings + + -- Base language which the package is written in. + default-language: Haskell2010 + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- The interface type and version of the test suite. + type: exitcode-stdio-1.0 + + -- Directories containing source files. + hs-source-dirs: test + + -- The entrypoint to the test suite. + main-is: Main.hs + + -- Test dependencies. + build-depends: base diff --git a/cabal/cabal-install/tests/fixtures/init/golden/exe/exe-build-tools-with-comments.golden b/cabal/cabal-install/tests/fixtures/init/golden/exe/exe-build-tools-with-comments.golden new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/fixtures/init/golden/exe/exe-build-tools-with-comments.golden @@ -0,0 +1,24 @@ +executable y + -- Import common warning flags. + import: warnings + + -- .hs or .lhs file containing the Main module. + main-is: Main.hs + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- Other library packages from which modules are imported. + build-depends: base + + -- Directories containing source files. + hs-source-dirs: exe + + -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. + build-tool-depends: happy + + -- Base language which the package is written in. + default-language: Haskell2010 diff --git a/cabal/cabal-install/tests/fixtures/init/golden/exe/exe-minimal-no-comments.golden b/cabal/cabal-install/tests/fixtures/init/golden/exe/exe-minimal-no-comments.golden new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/fixtures/init/golden/exe/exe-minimal-no-comments.golden @@ -0,0 +1,6 @@ +executable y + import: warnings + main-is: Main.hs + build-depends: base + hs-source-dirs: exe + default-language: Haskell2010 diff --git a/cabal/cabal-install/tests/fixtures/init/golden/exe/exe-no-comments.golden b/cabal/cabal-install/tests/fixtures/init/golden/exe/exe-no-comments.golden new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/fixtures/init/golden/exe/exe-no-comments.golden @@ -0,0 +1,8 @@ +executable y + import: warnings + main-is: Main.hs + -- other-modules: + -- other-extensions: + build-depends: base + hs-source-dirs: exe + default-language: Haskell2010 diff --git a/cabal/cabal-install/tests/fixtures/init/golden/exe/exe-simple-minimal-with-comments.golden b/cabal/cabal-install/tests/fixtures/init/golden/exe/exe-simple-minimal-with-comments.golden new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/fixtures/init/golden/exe/exe-simple-minimal-with-comments.golden @@ -0,0 +1,6 @@ +executable y + import: warnings + main-is: Main.hs + build-depends: base + hs-source-dirs: exe + default-language: Haskell2010 diff --git a/cabal/cabal-install/tests/fixtures/init/golden/exe/exe-with-comments.golden b/cabal/cabal-install/tests/fixtures/init/golden/exe/exe-with-comments.golden new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/fixtures/init/golden/exe/exe-with-comments.golden @@ -0,0 +1,21 @@ +executable y + -- Import common warning flags. + import: warnings + + -- .hs or .lhs file containing the Main module. + main-is: Main.hs + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- Other library packages from which modules are imported. + build-depends: base + + -- Directories containing source files. + hs-source-dirs: exe + + -- Base language which the package is written in. + default-language: Haskell2010 diff --git a/cabal/cabal-install/tests/fixtures/init/golden/lib/lib-build-tools-with-comments.golden b/cabal/cabal-install/tests/fixtures/init/golden/lib/lib-build-tools-with-comments.golden new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/fixtures/init/golden/lib/lib-build-tools-with-comments.golden @@ -0,0 +1,24 @@ +library + -- Import common warning flags. + import: warnings + + -- Modules exported by the library. + exposed-modules: MyLib + + -- Modules included in this library but not exported. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- Other library packages from which modules are imported. + build-depends: base + + -- Directories containing source files. + hs-source-dirs: src + + -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. + build-tool-depends: happy + + -- Base language which the package is written in. + default-language: Haskell98 diff --git a/cabal/cabal-install/tests/fixtures/init/golden/lib/lib-minimal-no-comments.golden b/cabal/cabal-install/tests/fixtures/init/golden/lib/lib-minimal-no-comments.golden new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/fixtures/init/golden/lib/lib-minimal-no-comments.golden @@ -0,0 +1,6 @@ +library + import: warnings + exposed-modules: MyLib + build-depends: base + hs-source-dirs: src + default-language: Haskell98 diff --git a/cabal/cabal-install/tests/fixtures/init/golden/lib/lib-no-comments.golden b/cabal/cabal-install/tests/fixtures/init/golden/lib/lib-no-comments.golden new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/fixtures/init/golden/lib/lib-no-comments.golden @@ -0,0 +1,8 @@ +library + import: warnings + exposed-modules: MyLib + -- other-modules: + -- other-extensions: + build-depends: base + hs-source-dirs: src + default-language: Haskell98 diff --git a/cabal/cabal-install/tests/fixtures/init/golden/lib/lib-simple-minimal-with-comments.golden b/cabal/cabal-install/tests/fixtures/init/golden/lib/lib-simple-minimal-with-comments.golden new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/fixtures/init/golden/lib/lib-simple-minimal-with-comments.golden @@ -0,0 +1,6 @@ +library + import: warnings + exposed-modules: MyLib + build-depends: base + hs-source-dirs: src + default-language: Haskell98 diff --git a/cabal/cabal-install/tests/fixtures/init/golden/lib/lib-simple-no-comments.golden b/cabal/cabal-install/tests/fixtures/init/golden/lib/lib-simple-no-comments.golden new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/fixtures/init/golden/lib/lib-simple-no-comments.golden @@ -0,0 +1,8 @@ +library + import: warnings + exposed-modules: MyLib + -- other-modules: + -- other-extensions: + build-depends: base + hs-source-dirs: src + default-language: Haskell98 diff --git a/cabal/cabal-install/tests/fixtures/init/golden/lib/lib-with-comments.golden b/cabal/cabal-install/tests/fixtures/init/golden/lib/lib-with-comments.golden new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/fixtures/init/golden/lib/lib-with-comments.golden @@ -0,0 +1,21 @@ +library + -- Import common warning flags. + import: warnings + + -- Modules exported by the library. + exposed-modules: MyLib + + -- Modules included in this library but not exported. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- Other library packages from which modules are imported. + build-depends: base + + -- Directories containing source files. + hs-source-dirs: src + + -- Base language which the package is written in. + default-language: Haskell98 diff --git a/cabal/cabal-install/tests/fixtures/init/golden/pkg-desc/pkg-old-cabal-with-flags.golden b/cabal/cabal-install/tests/fixtures/init/golden/pkg-desc/pkg-old-cabal-with-flags.golden new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/fixtures/init/golden/pkg-desc/pkg-old-cabal-with-flags.golden @@ -0,0 +1,55 @@ +cabal-version: 2.0 +-- The cabal-version field refers to the version of the .cabal specification, +-- and can be different from the cabal-install (the tool) version and the +-- Cabal (the library) version you are using. As such, the Cabal (the library) +-- version used must be equal or greater than the version stated in this field. +-- Starting from the specification version 2.2, the cabal-version field must be +-- the first thing in the cabal file. + +-- Initial package description 'y' generated by +-- 'cabal init'. For further documentation, see: +-- http://haskell.org/cabal/users-guide/ +-- +-- The name of the package. +name: QuxPackage + +-- The package version. +-- See the Haskell package versioning policy (PVP) for standards +-- guiding when and how versions should be incremented. +-- https://pvp.haskell.org +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 4.2.6 + +-- A short (one-line) description of the package. +synopsis: We are Qux, and this is our package + +-- A longer description of the package. +-- description: + +-- URL for the project homepage or repository. +homepage: qux.com + +-- The license under which the package is released. +license: MIT + +-- The file containing the license text. +license-file: LICENSE + +-- The package author(s). +author: Foobar + +-- An email address to which users can send suggestions, bug reports, and patches. +maintainer: foobar@qux.com + +-- A copyright notice. +-- copyright: +category: Control +build-type: Simple + +-- Extra doc files to be distributed with the package, such as a CHANGELOG or a README. +extra-doc-files: CHANGELOG.md + +-- Extra source files to be distributed with the package, such as examples, or a tutorial module. +-- extra-source-files: diff --git a/cabal/cabal-install/tests/fixtures/init/golden/pkg-desc/pkg-with-comments.golden b/cabal/cabal-install/tests/fixtures/init/golden/pkg-desc/pkg-with-comments.golden new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/fixtures/init/golden/pkg-desc/pkg-with-comments.golden @@ -0,0 +1,55 @@ +cabal-version: 3.0 +-- The cabal-version field refers to the version of the .cabal specification, +-- and can be different from the cabal-install (the tool) version and the +-- Cabal (the library) version you are using. As such, the Cabal (the library) +-- version used must be equal or greater than the version stated in this field. +-- Starting from the specification version 2.2, the cabal-version field must be +-- the first thing in the cabal file. + +-- Initial package description 'y' generated by +-- 'cabal init'. For further documentation, see: +-- http://haskell.org/cabal/users-guide/ +-- +-- The name of the package. +name: y + +-- The package version. +-- See the Haskell package versioning policy (PVP) for standards +-- guiding when and how versions should be incremented. +-- https://pvp.haskell.org +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.1.0.0 + +-- A short (one-line) description of the package. +synopsis: synopsis + +-- A longer description of the package. +-- description: + +-- URL for the project homepage or repository. +homepage: home + +-- The license under which the package is released. +license: BSD-3-Clause + +-- The file containing the license text. +license-file: LICENSE + +-- The package author(s). +author: foo-kmett + +-- An email address to which users can send suggestions, bug reports, and patches. +maintainer: foo-kmett@kmett.kmett + +-- A copyright notice. +-- copyright: +category: Data +build-type: Simple + +-- Extra doc files to be distributed with the package, such as a CHANGELOG or a README. +extra-doc-files: CHANGELOG.md + +-- Extra source files to be distributed with the package, such as examples, or a tutorial module. +-- extra-source-files: diff --git a/cabal/cabal-install/tests/fixtures/init/golden/pkg-desc/pkg-with-flags.golden b/cabal/cabal-install/tests/fixtures/init/golden/pkg-desc/pkg-with-flags.golden new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/fixtures/init/golden/pkg-desc/pkg-with-flags.golden @@ -0,0 +1,55 @@ +cabal-version: 2.2 +-- The cabal-version field refers to the version of the .cabal specification, +-- and can be different from the cabal-install (the tool) version and the +-- Cabal (the library) version you are using. As such, the Cabal (the library) +-- version used must be equal or greater than the version stated in this field. +-- Starting from the specification version 2.2, the cabal-version field must be +-- the first thing in the cabal file. + +-- Initial package description 'y' generated by +-- 'cabal init'. For further documentation, see: +-- http://haskell.org/cabal/users-guide/ +-- +-- The name of the package. +name: QuxPackage + +-- The package version. +-- See the Haskell package versioning policy (PVP) for standards +-- guiding when and how versions should be incremented. +-- https://pvp.haskell.org +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 4.2.6 + +-- A short (one-line) description of the package. +synopsis: We are Qux, and this is our package + +-- A longer description of the package. +-- description: + +-- URL for the project homepage or repository. +homepage: qux.com + +-- The license under which the package is released. +license: MIT + +-- The file containing the license text. +license-file: LICENSE + +-- The package author(s). +author: Foobar + +-- An email address to which users can send suggestions, bug reports, and patches. +maintainer: foobar@qux.com + +-- A copyright notice. +-- copyright: +category: Control +build-type: Simple + +-- Extra doc files to be distributed with the package, such as a CHANGELOG or a README. +extra-doc-files: CHANGELOG.md + +-- Extra source files to be distributed with the package, such as examples, or a tutorial module. +-- extra-source-files: diff --git a/cabal/cabal-install/tests/fixtures/init/golden/pkg-desc/pkg.golden b/cabal/cabal-install/tests/fixtures/init/golden/pkg-desc/pkg.golden new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/fixtures/init/golden/pkg-desc/pkg.golden @@ -0,0 +1,55 @@ +cabal-version: 3.0 +-- The cabal-version field refers to the version of the .cabal specification, +-- and can be different from the cabal-install (the tool) version and the +-- Cabal (the library) version you are using. As such, the Cabal (the library) +-- version used must be equal or greater than the version stated in this field. +-- Starting from the specification version 2.2, the cabal-version field must be +-- the first thing in the cabal file. + +-- Initial package description 'y' generated by +-- 'cabal init'. For further documentation, see: +-- http://haskell.org/cabal/users-guide/ +-- +-- The name of the package. +name: y + +-- The package version. +-- See the Haskell package versioning policy (PVP) for standards +-- guiding when and how versions should be incremented. +-- https://pvp.haskell.org +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.1.0.0 + +-- A short (one-line) description of the package. +synopsis: synopsis + +-- A longer description of the package. +-- description: + +-- URL for the project homepage or repository. +homepage: home + +-- The license under which the package is released. +license: BSD-3-Clause + +-- The file containing the license text. +license-file: LICENSE + +-- The package author(s). +author: foo-kmett + +-- An email address to which users can send suggestions, bug reports, and patches. +maintainer: foo-kmett@kmett.kmett + +-- A copyright notice. +-- copyright: +category: Data +build-type: Simple + +-- Extra doc files to be distributed with the package, such as a CHANGELOG or a README. +extra-doc-files: CHANGELOG.md + +-- Extra source files to be distributed with the package, such as examples, or a tutorial module. +-- extra-source-files: diff --git a/cabal/cabal-install/tests/fixtures/init/golden/test/standalone-test-no-comments.golden b/cabal/cabal-install/tests/fixtures/init/golden/test/standalone-test-no-comments.golden new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/fixtures/init/golden/test/standalone-test-no-comments.golden @@ -0,0 +1,9 @@ +test-suite y-test + import: warnings + default-language: Haskell2010 + -- other-modules: + -- other-extensions: + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: base diff --git a/cabal/cabal-install/tests/fixtures/init/golden/test/standalone-test-with-comments.golden b/cabal/cabal-install/tests/fixtures/init/golden/test/standalone-test-with-comments.golden new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/fixtures/init/golden/test/standalone-test-with-comments.golden @@ -0,0 +1,24 @@ +test-suite y-test + -- Import common warning flags. + import: warnings + + -- Base language which the package is written in. + default-language: Haskell2010 + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- The interface type and version of the test suite. + type: exitcode-stdio-1.0 + + -- Directories containing source files. + hs-source-dirs: test + + -- The entrypoint to the test suite. + main-is: Main.hs + + -- Test dependencies. + build-depends: base diff --git a/cabal/cabal-install/tests/fixtures/init/golden/test/test-build-tools-with-comments.golden b/cabal/cabal-install/tests/fixtures/init/golden/test/test-build-tools-with-comments.golden new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/fixtures/init/golden/test/test-build-tools-with-comments.golden @@ -0,0 +1,27 @@ +test-suite y-test + -- Import common warning flags. + import: warnings + + -- Base language which the package is written in. + default-language: Haskell2010 + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- The interface type and version of the test suite. + type: exitcode-stdio-1.0 + + -- Directories containing source files. + hs-source-dirs: test + + -- The entrypoint to the test suite. + main-is: Main.hs + + -- Test dependencies. + build-depends: base + + -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. + build-tool-depends: happy diff --git a/cabal/cabal-install/tests/fixtures/init/golden/test/test-minimal-no-comments.golden b/cabal/cabal-install/tests/fixtures/init/golden/test/test-minimal-no-comments.golden new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/fixtures/init/golden/test/test-minimal-no-comments.golden @@ -0,0 +1,7 @@ +test-suite y-test + import: warnings + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: base diff --git a/cabal/cabal-install/tests/fixtures/init/golden/test/test-no-comments.golden b/cabal/cabal-install/tests/fixtures/init/golden/test/test-no-comments.golden new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/fixtures/init/golden/test/test-no-comments.golden @@ -0,0 +1,9 @@ +test-suite y-test + import: warnings + default-language: Haskell2010 + -- other-modules: + -- other-extensions: + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: base diff --git a/cabal/cabal-install/tests/fixtures/init/golden/test/test-simple-minimal-with-comments.golden b/cabal/cabal-install/tests/fixtures/init/golden/test/test-simple-minimal-with-comments.golden new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/fixtures/init/golden/test/test-simple-minimal-with-comments.golden @@ -0,0 +1,7 @@ +test-suite y-test + import: warnings + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: base diff --git a/cabal/cabal-install/tests/fixtures/init/golden/test/test-with-comments.golden b/cabal/cabal-install/tests/fixtures/init/golden/test/test-with-comments.golden new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/fixtures/init/golden/test/test-with-comments.golden @@ -0,0 +1,24 @@ +test-suite y-test + -- Import common warning flags. + import: warnings + + -- Base language which the package is written in. + default-language: Haskell2010 + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- The interface type and version of the test suite. + type: exitcode-stdio-1.0 + + -- Directories containing source files. + hs-source-dirs: test + + -- The entrypoint to the test suite. + main-is: Main.hs + + -- Test dependencies. + build-depends: base diff --git a/cabal/cabal-testsuite/LICENSE b/cabal/cabal-testsuite/LICENSE --- a/cabal/cabal-testsuite/LICENSE +++ b/cabal/cabal-testsuite/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2003-2020, Cabal Development Team. +Copyright (c) 2003-2022, Cabal Development Team. See the AUTHORS file for the full list of copyright holders. See */LICENSE for the copyright holders of the subcomponents. diff --git a/cabal/cabal-testsuite/PackageTests/Ambiguity/setup-reexport.test.hs b/cabal/cabal-testsuite/PackageTests/Ambiguity/setup-reexport.test.hs --- a/cabal/cabal-testsuite/PackageTests/Ambiguity/setup-reexport.test.hs +++ b/cabal/cabal-testsuite/PackageTests/Ambiguity/setup-reexport.test.hs @@ -2,7 +2,7 @@ -- Test that we can resolve a module name ambiguity when reexporting -- by explicitly specifying what package we want. main = setupAndCabalTest $ do - skipUnless =<< ghcVersionIs (>= mkVersion [7,9]) + skipUnlessGhcVersion ">= 7.9" withPackageDb $ do withDirectory "p" $ setup_install [] withDirectory "q" $ setup_install [] diff --git a/cabal/cabal-testsuite/PackageTests/AutoconfBadPaths/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/AutoconfBadPaths/cabal.test.hs --- a/cabal/cabal-testsuite/PackageTests/AutoconfBadPaths/cabal.test.hs +++ b/cabal/cabal-testsuite/PackageTests/AutoconfBadPaths/cabal.test.hs @@ -7,7 +7,7 @@ -- -- Note: we bundle the configure script so no need to autoreconf -- while building - skipIf =<< isWindows + skipIfWindows traverse_ check [ "foo bar" , "foo\tbar" diff --git a/cabal/cabal-testsuite/PackageTests/AutogenModules/Package/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/AutogenModules/Package/setup.cabal.out --- a/cabal/cabal-testsuite/PackageTests/AutogenModules/Package/setup.cabal.out +++ b/cabal/cabal-testsuite/PackageTests/AutogenModules/Package/setup.cabal.out @@ -1,6 +1,6 @@ # Setup configure Configuring AutogenModules-0.1... -cabal: An 'autogen-module' is neither on 'exposed-modules' or 'other-modules'. +Error: cabal: An 'autogen-module' is neither on 'exposed-modules' or 'other-modules'. On executable 'Exe' an 'autogen-module' is not on 'other-modules' @@ -14,7 +14,7 @@ On test suite 'Test' an 'autogen-module' is not on 'other-modules' On benchmark 'Bench' an 'autogen-module' is not on 'other-modules' Packages using 'cabal-version: 2.0' and the autogenerated module Paths_* must include it also on the 'autogen-modules' field besides 'exposed-modules' and 'other-modules'. This specifies that the module does not come with the package and is generated on setup. Modules built with a custom Setup.hs script also go here to ensure that commands like sdist don't fail. -The filename ./my.cabal does not match package name (expected: AutogenModules.cabal) +The filename './my.cabal' does not match package name (expected: 'AutogenModules.cabal') Note: the public hackage server would reject this package. Building source dist for AutogenModules-0.1... -cabal: Error: Could not find module: MyLibHelperModule with any suffix: ["gc","chs","hsc","x","y","ly","cpphs","hs","lhs","hsig","lhsig"]. If the module is autogenerated it should be added to 'autogen-modules'. +Error: cabal: Could not find module: MyLibHelperModule with any suffix: ["gc","chs","hsc","x","y","ly","cpphs","hs","lhs","hsig","lhsig"]. If the module is autogenerated it should be added to 'autogen-modules'. diff --git a/cabal/cabal-testsuite/PackageTests/AutogenModules/Package/setup.out b/cabal/cabal-testsuite/PackageTests/AutogenModules/Package/setup.out --- a/cabal/cabal-testsuite/PackageTests/AutogenModules/Package/setup.out +++ b/cabal/cabal-testsuite/PackageTests/AutogenModules/Package/setup.out @@ -1,6 +1,6 @@ # Setup configure Configuring AutogenModules-0.1... -setup: An 'autogen-module' is neither on 'exposed-modules' or 'other-modules'. +Error: setup: An 'autogen-module' is neither on 'exposed-modules' or 'other-modules'. On executable 'Exe' an 'autogen-module' is not on 'other-modules' @@ -14,7 +14,7 @@ On test suite 'Test' an 'autogen-module' is not on 'other-modules' On benchmark 'Bench' an 'autogen-module' is not on 'other-modules' Packages using 'cabal-version: 2.0' and the autogenerated module Paths_* must include it also on the 'autogen-modules' field besides 'exposed-modules' and 'other-modules'. This specifies that the module does not come with the package and is generated on setup. Modules built with a custom Setup.hs script also go here to ensure that commands like sdist don't fail. -The filename ./my.cabal does not match package name (expected: AutogenModules.cabal) +The filename './my.cabal' does not match package name (expected: 'AutogenModules.cabal') Note: the public hackage server would reject this package. Building source dist for AutogenModules-0.1... -setup: Error: Could not find module: MyLibHelperModule with any suffix: ["gc","chs","hsc","x","y","ly","cpphs","hs","lhs","hsig","lhsig"]. If the module is autogenerated it should be added to 'autogen-modules'. +Error: setup: Could not find module: MyLibHelperModule with any suffix: ["gc","chs","hsc","x","y","ly","cpphs","hs","lhs","hsig","lhsig"]. If the module is autogenerated it should be added to 'autogen-modules'. diff --git a/cabal/cabal-testsuite/PackageTests/AutogenModules/Package/setup.test.hs b/cabal/cabal-testsuite/PackageTests/AutogenModules/Package/setup.test.hs --- a/cabal/cabal-testsuite/PackageTests/AutogenModules/Package/setup.test.hs +++ b/cabal/cabal-testsuite/PackageTests/AutogenModules/Package/setup.test.hs @@ -40,7 +40,7 @@ -- Asserts for the error messages of the modules not found. assertOutputContains - "Error: Could not find module: MyLibHelperModule with any suffix" + "Could not find module: MyLibHelperModule with any suffix" sdistResult assertOutputContains "module is autogenerated it should be added to 'autogen-modules'" diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Fail1/setup.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Fail1/setup.test.hs --- a/cabal/cabal-testsuite/PackageTests/Backpack/Fail1/setup.test.hs +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Fail1/setup.test.hs @@ -1,6 +1,6 @@ import Test.Cabal.Prelude main = setupAndCabalTest $ do - skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) + skipUnlessGhcVersion ">= 8.1" r <- fails $ setup' "configure" [] assertOutputContains "MissingReq" r return () diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Fail2/setup.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Fail2/setup.test.hs --- a/cabal/cabal-testsuite/PackageTests/Backpack/Fail2/setup.test.hs +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Fail2/setup.test.hs @@ -1,6 +1,6 @@ import Test.Cabal.Prelude main = setupAndCabalTest $ do - skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) + skipUnlessGhcVersion ">= 8.1" r <- fails $ setup' "configure" [] assertOutputContains "non-existent" r return () diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Fail3/setup.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Fail3/setup.test.hs --- a/cabal/cabal-testsuite/PackageTests/Backpack/Fail3/setup.test.hs +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Fail3/setup.test.hs @@ -1,6 +1,6 @@ import Test.Cabal.Prelude main = setupAndCabalTest $ do - skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) + skipUnlessGhcVersion ">= 8.1" r <- fails $ setup' "configure" [] assertOutputContains "UnfilledSig" r return () diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes1/setup.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Includes1/setup.test.hs --- a/cabal/cabal-testsuite/PackageTests/Backpack/Includes1/setup.test.hs +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes1/setup.test.hs @@ -1,6 +1,6 @@ import Test.Cabal.Prelude main = setupAndCabalTest $ do - skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) + skipUnlessGhcVersion ">= 8.1" setup "configure" [] r <- fails $ setup' "build" [] assertRegex "error should be in B.hs" "^B.hs:" r diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-external-target.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-external-target.test.hs --- a/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-external-target.test.hs +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-external-target.test.hs @@ -1,6 +1,6 @@ import Test.Cabal.Prelude main = cabalTest $ do - skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) + skipUnlessGhcVersion ">= 8.1" withProjectFile "cabal.external.project" $ do cabal "v2-build" ["mylib"] diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-external.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-external.test.hs --- a/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-external.test.hs +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-external.test.hs @@ -1,8 +1,8 @@ import Test.Cabal.Prelude main = cabalTest $ do - skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) - skipIf =<< isWindows -- TODO: https://github.com/haskell/cabal/issues/6271 + skipUnlessGhcVersion ">= 8.1" + skipIfWindows -- TODO: https://github.com/haskell/cabal/issues/6271 withProjectFile "cabal.external.project" $ do cabal "v2-build" ["exe"] withPlan $ do diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal-target.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal-target.test.hs --- a/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal-target.test.hs +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal-target.test.hs @@ -1,6 +1,6 @@ import Test.Cabal.Prelude main = cabalTest $ do - skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) + skipUnlessGhcVersion ">= 8.1" withProjectFile "cabal.internal.project" $ do cabal "v2-build" ["mylib"] diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal.out b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal.out --- a/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal.out +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal.out @@ -34,11 +34,9 @@ Database = Includes2-0.1.0.0-inplace-postgresql:Database.PostgreSQL for Includes2-0.1.0.0.. Configuring library for Includes2-0.1.0.0.. -Warning: The package has an extraneous version range for a dependency on an internal library: Includes2:{mylib, mysql, postgresql} (((>=0 && >=0 && >=0) && ==0.1.0.0) && ==0.1.0.0) && ==0.1.0.0, Includes2 ((>=0 && ==0.1.0.0) && ==0.1.0.0) && ==0.1.0.0. This version range includes the current package but isn't needed as the current package's library will always be used. Preprocessing library for Includes2-0.1.0.0.. Building library for Includes2-0.1.0.0.. Configuring executable 'exe' for Includes2-0.1.0.0.. -Warning: The package has an extraneous version range for a dependency on an internal library: Includes2:{mylib, mysql, postgresql} (>=0 && >=0 && >=0) && ==0.1.0.0, Includes2 >=0 && ==0.1.0.0. This version range includes the current package but isn't needed as the current package's library will always be used. Preprocessing executable 'exe' for Includes2-0.1.0.0.. Building executable 'exe' for Includes2-0.1.0.0.. # Includes2 exe diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal.test.hs --- a/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal.test.hs +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal.test.hs @@ -1,8 +1,8 @@ import Test.Cabal.Prelude main = cabalTest $ do - skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) - skipIf =<< isWindows -- TODO: https://github.com/haskell/cabal/issues/6271 + skipUnlessGhcVersion ">= 8.1" + skipIfWindows -- TODO: https://github.com/haskell/cabal/issues/6271 withProjectFile "cabal.internal.project" $ do cabal "v2-build" ["exe"] withPlan $ do diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/setup-external.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/setup-external.test.hs --- a/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/setup-external.test.hs +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/setup-external.test.hs @@ -1,6 +1,8 @@ import Test.Cabal.Prelude main = setupAndCabalTest $ do - skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) + skipUnlessGhcVersion ">= 8.1" + ghc <- isGhcVersion "== 9.0.2 || == 9.2.*" + expectBrokenIf ghc 7987 $ do withPackageDb $ do withDirectory "mylib" $ setup_install_with_docs ["--ipid", "mylib-0.1.0.0"] withDirectory "mysql" $ setup_install_with_docs ["--ipid", "mysql-0.1.0.0"] diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/setup-internal-fail.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/setup-internal-fail.test.hs --- a/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/setup-internal-fail.test.hs +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/setup-internal-fail.test.hs @@ -1,5 +1,5 @@ import Test.Cabal.Prelude main = setupAndCabalTest $ do - skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) + skipUnlessGhcVersion ">= 8.1" r <- fails $ setup' "configure" ["--cabal-file", "Includes2.cabal.fail"] assertOutputContains "mysql" r diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/setup-internal.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/setup-internal.test.hs --- a/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/setup-internal.test.hs +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/setup-internal.test.hs @@ -1,6 +1,6 @@ import Test.Cabal.Prelude main = setupAndCabalTest $ do - skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) + skipUnlessGhcVersion ">= 8.1" withPackageDb $ do setup_install ["--cabal-file", "Includes2.cabal"] -- TODO: haddock for internal method doesn't work diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/setup-per-component.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/setup-per-component.test.hs --- a/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/setup-per-component.test.hs +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/setup-per-component.test.hs @@ -1,7 +1,9 @@ import Test.Cabal.Prelude main = setupTest $ do - -- No cabal test because per-component is broken with it - skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) + -- No cabal test because per-component is broken with it + skipUnlessGhcVersion ">= 8.1" + ghc <- isGhcVersion "== 9.0.2 || == 9.2.*" + expectBrokenIf ghc 7987 $ withPackageDb $ do let setup_install' args = setup_install_with_docs (["--cabal-file", "Includes2.cabal"] ++ args) setup_install' ["mylib", "--cid", "mylib-0.1.0.0"] diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-external.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-external.test.hs --- a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-external.test.hs +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-external.test.hs @@ -1,8 +1,8 @@ import Test.Cabal.Prelude main = cabalTest $ do - skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) - skipIf =<< isWindows -- TODO: https://github.com/haskell/cabal/issues/6271 + skipUnlessGhcVersion ">= 8.1" + skipIfWindows -- TODO: https://github.com/haskell/cabal/issues/6271 withProjectFile "cabal.external.project" $ do cabal "v2-build" ["exe"] withPlan $ do diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-internal.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-internal.test.hs --- a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-internal.test.hs +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-internal.test.hs @@ -1,8 +1,8 @@ import Test.Cabal.Prelude main = cabalTest $ do - skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) - skipIf =<< isWindows -- TODO: https://github.com/haskell/cabal/issues/6271 + skipUnlessGhcVersion ">= 8.1" + skipIfWindows -- TODO: https://github.com/haskell/cabal/issues/6271 withProjectFile "cabal.internal.project" $ do cabal "v2-build" ["exe"] withPlan $ do diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-repo.out b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-repo.out --- a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-repo.out +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-repo.out @@ -1,12 +1,12 @@ -# cabal v1-update +# cabal v2-update Downloading the latest package list from test-local-repo # cabal v2-build Resolving dependencies... Build profile: -w ghc- -O1 In order, the following will be built: - - sigs-0.1.0.0 (lib) (requires download & build) - - indef-0.1.0.0 (lib) (requires download & build) - - indef-0.1.0.0 (lib with Data.Map=containers-:Data.Map) (requires download & build) + - sigs-0.1.0.0 (lib) (requires build) + - indef-0.1.0.0 (lib) (requires build) + - indef-0.1.0.0 (lib with Data.Map=containers-:Data.Map) (requires build) - exe-0.1.0.0 (exe:exe) (first run) Configuring library for sigs-0.1.0.0.. Preprocessing library for sigs-0.1.0.0.. diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-repo.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-repo.test.hs --- a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-repo.test.hs +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-repo.test.hs @@ -1,8 +1,8 @@ import Test.Cabal.Prelude main = withShorterPathForNewBuildStore $ \storeDir -> cabalTest $ do - skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) - skipIf =<< isWindows -- TODO: https://github.com/haskell/cabal/issues/6271 + skipUnlessGhcVersion ">= 8.1" + skipIfWindows -- TODO: https://github.com/haskell/cabal/issues/6271 withProjectFile "cabal.repo.project" $ do withRepo "repo" $ do cabalG ["--store-dir=" ++ storeDir] "v2-build" ["exe"] diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-explicit.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-explicit.test.hs --- a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-explicit.test.hs +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-explicit.test.hs @@ -1,7 +1,7 @@ import Test.Cabal.Prelude -- NB: cabal-install doesn't understand --dependency main = setupTest $ do - skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) + skipUnlessGhcVersion ">= 8.1" withPackageDb $ do withDirectory "repo/sigs-0.1.0.0" $ setup_install_with_docs ["--cid", "sigs-0.1.0.0", "lib:sigs"] withDirectory "repo/indef-0.1.0.0" $ setup_install_with_docs ["--cid", "indef-0.1.0.0", "--dependency=sigs=sigs-0.1.0.0", "lib:indef"] diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-fail.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-fail.test.hs --- a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-fail.test.hs +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-fail.test.hs @@ -1,6 +1,6 @@ import Test.Cabal.Prelude main = setupAndCabalTest $ do - skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) + skipUnlessGhcVersion ">= 8.1" withPackageDb $ do withDirectory "repo/sigs-0.1.0.0" $ setup_install [] withDirectory "repo/indef-0.1.0.0" $ setup_install [] diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-ok.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-ok.test.hs --- a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-ok.test.hs +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-ok.test.hs @@ -2,7 +2,9 @@ import Data.List import qualified Data.Char as Char main = setupAndCabalTest $ do - skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) + skipUnlessGhcVersion ">= 8.1" + ghc <- isGhcVersion "== 9.0.2 || == 9.2.*" + expectBrokenIf ghc 7987 $ withPackageDb $ do containers_id <- getIPID "containers" withDirectory "repo/sigs-0.1.0.0" $ setup_install_with_docs ["--ipid", "sigs-0.1.0.0"] diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-internal.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-internal.test.hs --- a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-internal.test.hs +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-internal.test.hs @@ -1,6 +1,6 @@ import Test.Cabal.Prelude main = setupAndCabalTest $ do - skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) + skipUnlessGhcVersion ">= 8.1" withPackageDb $ do setup_install [] _ <- runM "touch" ["repo/indef-0.1.0.0/Foo.hs"] Nothing diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes4/setup.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Includes4/setup.test.hs --- a/cabal/cabal-testsuite/PackageTests/Backpack/Includes4/setup.test.hs +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes4/setup.test.hs @@ -1,6 +1,6 @@ import Test.Cabal.Prelude main = setupAndCabalTest $ do - skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) + skipUnlessGhcVersion ">= 8.1" withPackageDb $ do setup_install [] runExe' "exe" [] >>= assertOutputContains "A (B (A (B" diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes5/setup.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Includes5/setup.test.hs --- a/cabal/cabal-testsuite/PackageTests/Backpack/Includes5/setup.test.hs +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes5/setup.test.hs @@ -1,6 +1,6 @@ import Test.Cabal.Prelude main = setupAndCabalTest $ do - skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) + skipUnlessGhcVersion ">= 8.1" setup "configure" [] r <- fails $ setup' "build" [] assertOutputContains "Foobar" r diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Indef2/setup.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Indef2/setup.test.hs --- a/cabal/cabal-testsuite/PackageTests/Backpack/Indef2/setup.test.hs +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Indef2/setup.test.hs @@ -1,6 +1,6 @@ import Test.Cabal.Prelude main = setupAndCabalTest $ do - skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) + skipUnlessGhcVersion ">= 8.1" setup "configure" [] setup "build" [] return () diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Reexport1/setup.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Reexport1/setup.test.hs --- a/cabal/cabal-testsuite/PackageTests/Backpack/Reexport1/setup.test.hs +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Reexport1/setup.test.hs @@ -1,6 +1,6 @@ import Test.Cabal.Prelude main = setupAndCabalTest $ do - skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) + skipUnlessGhcVersion ">= 8.1" withPackageDb $ do withDirectory "p" $ setup_install_with_docs [] withDirectory "q" $ do diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Reexport2/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/Backpack/Reexport2/setup.cabal.out --- a/cabal/cabal-testsuite/PackageTests/Backpack/Reexport2/setup.cabal.out +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Reexport2/setup.cabal.out @@ -1,3 +1,3 @@ # Setup configure Configuring Reexport2-1.0... -cabal: Duplicate modules in library: Asdf +Error: cabal: Duplicate modules in library: Asdf diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Reexport2/setup.out b/cabal/cabal-testsuite/PackageTests/Backpack/Reexport2/setup.out --- a/cabal/cabal-testsuite/PackageTests/Backpack/Reexport2/setup.out +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Reexport2/setup.out @@ -1,3 +1,3 @@ # Setup configure Configuring Reexport2-1.0... -setup: Duplicate modules in library: Asdf +Error: setup: Duplicate modules in library: Asdf diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Reexport2/setup.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Reexport2/setup.test.hs --- a/cabal/cabal-testsuite/PackageTests/Backpack/Reexport2/setup.test.hs +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Reexport2/setup.test.hs @@ -1,5 +1,5 @@ import Test.Cabal.Prelude main = setupAndCabalTest $ do - skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) + skipUnlessGhcVersion ">= 8.1" fails (setup' "configure" []) >>= assertRegex "Expect problem with Asdf" "Asdf" diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/T4447/setup.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/T4447/setup.test.hs --- a/cabal/cabal-testsuite/PackageTests/Backpack/T4447/setup.test.hs +++ b/cabal/cabal-testsuite/PackageTests/Backpack/T4447/setup.test.hs @@ -1,4 +1,4 @@ import Test.Cabal.Prelude main = setupAndCabalTest $ do - skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) + skipUnlessGhcVersion ">= 8.1" fails $ setup "configure" [] diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/T4754/setup.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/T4754/setup.test.hs --- a/cabal/cabal-testsuite/PackageTests/Backpack/T4754/setup.test.hs +++ b/cabal/cabal-testsuite/PackageTests/Backpack/T4754/setup.test.hs @@ -1,6 +1,6 @@ import Test.Cabal.Prelude main = setupAndCabalTest $ do - skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) - skipUnless =<< hasProfiledLibraries + skipUnlessGhcVersion ">= 8.1" + skipUnless "no profiling libs" =<< hasProfiledLibraries setup "configure" ["--enable-profiling"] setup "build" [] diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/T5634/setup.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/T5634/setup.test.hs --- a/cabal/cabal-testsuite/PackageTests/Backpack/T5634/setup.test.hs +++ b/cabal/cabal-testsuite/PackageTests/Backpack/T5634/setup.test.hs @@ -1,5 +1,5 @@ import Test.Cabal.Prelude main = setupAndCabalTest $ do - skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) + skipUnlessGhcVersion ">= 8.1" setup "configure" [] setup "build" [] diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/T6385/Go.hs b/cabal/cabal-testsuite/PackageTests/Backpack/T6385/Go.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/T6385/Go.hs @@ -0,0 +1,1 @@ +module Go where diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/T6385/Go2.hs b/cabal/cabal-testsuite/PackageTests/Backpack/T6385/Go2.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/T6385/Go2.hs @@ -0,0 +1,1 @@ +module Go2 where diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/T6385/Hole.hsig b/cabal/cabal-testsuite/PackageTests/Backpack/T6385/Hole.hsig new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/T6385/Hole.hsig @@ -0,0 +1,1 @@ +signature Hole where diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/T6385/T6385.cabal b/cabal/cabal-testsuite/PackageTests/Backpack/T6385/T6385.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/T6385/T6385.cabal @@ -0,0 +1,17 @@ +name: T6385 +version: 1.0 +build-type: Simple +cabal-version: 2.0 + +library top-def + default-language: Haskell2010 + build-depends: base, indef, alt-containers + hs-source-dirs: . + exposed-modules: Go + +library top-indef + default-language: Haskell2010 + build-depends: base, indef, alt-containers + hs-source-dirs: . + signatures: Hole + exposed-modules: Go2 diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/T6385/alt-containers/Data/Map.hs b/cabal/cabal-testsuite/PackageTests/Backpack/T6385/alt-containers/Data/Map.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/T6385/alt-containers/Data/Map.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE RoleAnnotations #-} +module Data.Map where +type role Map nominal representational +data Map k a = Map +instance Functor (Map k) where + fmap _ Map = Map diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/T6385/alt-containers/alt-containers.cabal b/cabal/cabal-testsuite/PackageTests/Backpack/T6385/alt-containers/alt-containers.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/T6385/alt-containers/alt-containers.cabal @@ -0,0 +1,10 @@ +name: alt-containers +version: 1.0 +build-type: Simple +cabal-version: 2.0 + +library + default-language: Haskell2010 + build-depends: base + hs-source-dirs: . + exposed-modules: Data.Map diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/T6385/cabal.out b/cabal/cabal-testsuite/PackageTests/Backpack/T6385/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/T6385/cabal.out @@ -0,0 +1,33 @@ +# cabal v2-update +Downloading the latest package list from test-local-repo +# cabal v2-build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - alt-containers-1.0 (lib) (first run) + - indef-0.1.0.0 (lib) (requires build) + - indef-0.1.0.0 (lib with Data.Map=alt-containers-1.0-inplace:Data.Map) (requires build) + - T6385-1.0 (lib:top-indef) (first run) + - T6385-1.0 (lib:top-def) (first run) +Configuring library for alt-containers-1.0.. +Preprocessing library for alt-containers-1.0.. +Building library for alt-containers-1.0.. +Configuring library for indef-0.1.0.0.. +Preprocessing library for indef-0.1.0.0.. +Building library instantiated with Data.Map = +for indef-0.1.0.0.. +Installing library in +Configuring library instantiated with + Data.Map = alt-containers-1.0-inplace:Data.Map +for indef-0.1.0.0.. +Preprocessing library for indef-0.1.0.0.. +Building library instantiated with + Data.Map = alt-containers-1.0-inplace:Data.Map +for indef-0.1.0.0.. +Configuring library 'top-indef' for T6385-1.0.. +Preprocessing library 'top-indef' for T6385-1.0.. +Building library 'top-indef' instantiated with Hole = +for T6385-1.0.. +Configuring library 'top-def' for T6385-1.0.. +Preprocessing library 'top-def' for T6385-1.0.. +Building library 'top-def' for T6385-1.0.. diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/T6385/cabal.project b/cabal/cabal-testsuite/PackageTests/Backpack/T6385/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/T6385/cabal.project @@ -0,0 +1,1 @@ +packages: . alt-containers diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/T6385/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/T6385/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/T6385/cabal.test.hs @@ -0,0 +1,7 @@ +import Test.Cabal.Prelude +main = withShorterPathForNewBuildStore $ \storeDir -> + cabalTest $ do + skipUnlessGhcVersion ">= 8.1" + skipIfWindows -- TODO: https://github.com/haskell/cabal/issues/6271 + withRepo "repo" $ do + cabalG ["--store-dir=" ++ storeDir] "v2-build" ["T6385"] diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/T6385/repo/indef-0.1.0.0/Data/Map.hsig b/cabal/cabal-testsuite/PackageTests/Backpack/T6385/repo/indef-0.1.0.0/Data/Map.hsig new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/T6385/repo/indef-0.1.0.0/Data/Map.hsig @@ -0,0 +1,5 @@ +{-# LANGUAGE RoleAnnotations #-} +signature Data.Map where +type role Map nominal representational +data Map k a +instance Functor (Map k) diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/T6385/repo/indef-0.1.0.0/Foo.hs b/cabal/cabal-testsuite/PackageTests/Backpack/T6385/repo/indef-0.1.0.0/Foo.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/T6385/repo/indef-0.1.0.0/Foo.hs @@ -0,0 +1,6 @@ +module Foo where + +import Data.Map + +f :: (a -> b) -> Map k a -> Map k b +f = fmap diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/T6385/repo/indef-0.1.0.0/indef.cabal b/cabal/cabal-testsuite/PackageTests/Backpack/T6385/repo/indef-0.1.0.0/indef.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/T6385/repo/indef-0.1.0.0/indef.cabal @@ -0,0 +1,13 @@ +name: indef +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: 2.0 + +library + build-depends: base + signatures: Data.Map + exposed-modules: Foo + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/TemplateHaskell/setup.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/TemplateHaskell/setup.test.hs --- a/cabal/cabal-testsuite/PackageTests/Backpack/TemplateHaskell/setup.test.hs +++ b/cabal/cabal-testsuite/PackageTests/Backpack/TemplateHaskell/setup.test.hs @@ -1,5 +1,5 @@ import Test.Cabal.Prelude main = setupAndCabalTest $ do - skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) + skipUnlessGhcVersion ">= 8.1" setup "configure" [] setup "build" [] diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/bkpcabal01/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/bkpcabal01/cabal.test.hs --- a/cabal/cabal-testsuite/PackageTests/Backpack/bkpcabal01/cabal.test.hs +++ b/cabal/cabal-testsuite/PackageTests/Backpack/bkpcabal01/cabal.test.hs @@ -1,6 +1,6 @@ import Test.Cabal.Prelude main = cabalTest $ do -- GHC 8.2.2 had a regression ("unknown package: hole"), see also #4908 - skipUnless =<< ghcVersionIs (\v -> v >= mkVersion [8,2] && v /= mkVersion [8,2,2]) - skipIf =<< isWindows -- TODO: https://github.com/haskell/cabal/issues/6271 + skipUnlessGhcVersion ">= 8.2 && <8.2.2 || >8.2.2" + skipIfWindows -- TODO: https://github.com/haskell/cabal/issues/6271 cabal "v2-build" ["all"] diff --git a/cabal/cabal-testsuite/PackageTests/BenchmarkStanza/setup.test.hs b/cabal/cabal-testsuite/PackageTests/BenchmarkStanza/setup.test.hs --- a/cabal/cabal-testsuite/PackageTests/BenchmarkStanza/setup.test.hs +++ b/cabal/cabal-testsuite/PackageTests/BenchmarkStanza/setup.test.hs @@ -7,6 +7,7 @@ import Distribution.Types.UnqualComponentName import Control.Monad.IO.Class import Distribution.Simple.Configure +import Distribution.Utils.Path main = setupAndCabalTest $ do assertOutputDoesNotContain "unknown section type" @@ -21,7 +22,8 @@ (benchmarkInterface gotBenchmark) -- NB: Not testing targetBuildDepends (benchmarkBuildInfo gotBenchmark), -- as the dependency varies with cabal-install - assertEqual "benchmarkBuildInfo/hsSourceDirs" - ["."] - (hsSourceDirs (benchmarkBuildInfo gotBenchmark)) + assertEqual + "benchmarkBuildInfo/hsSourceDirs" + [sameDirectory] + (hsSourceDirs (benchmarkBuildInfo gotBenchmark)) return () diff --git a/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary0/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary0/setup.cabal.out --- a/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary0/setup.cabal.out +++ b/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary0/setup.cabal.out @@ -1,3 +1,3 @@ # Setup configure Configuring InternalLibrary0-0.1... -cabal: The field 'build-depends: InternalLibrary0' refers to a library which is defined within the same package. To use this feature the package must specify at least 'cabal-version: >= 1.8'. +Error: cabal: The field 'build-depends: InternalLibrary0' refers to a library which is defined within the same package. To use this feature the package must specify at least 'cabal-version: >= 1.8'. diff --git a/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary0/setup.out b/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary0/setup.out --- a/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary0/setup.out +++ b/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary0/setup.out @@ -1,3 +1,3 @@ # Setup configure Configuring InternalLibrary0-0.1... -setup: The field 'build-depends: InternalLibrary0' refers to a library which is defined within the same package. To use this feature the package must specify at least 'cabal-version: >= 1.8'. +Error: setup: The field 'build-depends: InternalLibrary0' refers to a library which is defined within the same package. To use this feature the package must specify at least 'cabal-version: >= 1.8'. diff --git a/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary1/cabal.out b/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary1/cabal.out --- a/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary1/cabal.out +++ b/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary1/cabal.out @@ -8,6 +8,5 @@ Preprocessing library for InternalLibrary1-0.1.. Building library for InternalLibrary1-0.1.. Configuring executable 'lemon' for InternalLibrary1-0.1.. -Warning: The package has an extraneous version range for a dependency on an internal library: InternalLibrary1 >=0 && ==0.1. This version range includes the current package but isn't needed as the current package's library will always be used. Preprocessing executable 'lemon' for InternalLibrary1-0.1.. Building executable 'lemon' for InternalLibrary1-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/BuildTargetErrors/setup.out b/cabal/cabal-testsuite/PackageTests/BuildTargetErrors/setup.out --- a/cabal/cabal-testsuite/PackageTests/BuildTargetErrors/setup.out +++ b/cabal/cabal-testsuite/PackageTests/BuildTargetErrors/setup.out @@ -1,4 +1,4 @@ # Setup configure Configuring BuildTargetErrors-1.0... # Setup build -setup: Cannot process the executable 'not-buildable-exe' because the component is marked as disabled in the .cabal file. +Error: setup: Cannot process the executable 'not-buildable-exe' because the component is marked as disabled in the .cabal file. diff --git a/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackage/use-local-version-of-package.out b/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackage/use-local-version-of-package.out --- a/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackage/use-local-version-of-package.out +++ b/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackage/use-local-version-of-package.out @@ -1,4 +1,4 @@ -# cabal v1-update +# cabal v2-update Downloading the latest package list from test-local-repo # cabal v2-build Resolving dependencies... @@ -12,7 +12,7 @@ local pkg-1.0 # cabal v2-build Resolving dependencies... -cabal: Could not resolve dependencies: +Error: cabal: Could not resolve dependencies: [__0] next goal: pkg (user goal) [__0] rejecting: pkg-2.0 (constraint from user target requires ==1.0) [__0] rejecting: pkg-1.0 (constraint from command line flag requires ==2.0) diff --git a/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackage/use-local-version-of-package.test.hs b/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackage/use-local-version-of-package.test.hs --- a/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackage/use-local-version-of-package.test.hs +++ b/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackage/use-local-version-of-package.test.hs @@ -11,5 +11,5 @@ -- cabal shouldn't build a package from the repo, even when given a constraint -- that only matches a non-local package. - r <- fails $ cabal' "v2-build" ["pkg", "--constraint=pkg==2.0"] + r <- fails $ cabal' "v2-build" ["pkg", "-c", "pkg==2.0"] assertOutputContains "rejecting: pkg-2.0" r diff --git a/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackageForSetup/use-local-package-as-setup-dep.out b/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackageForSetup/use-local-package-as-setup-dep.out --- a/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackageForSetup/use-local-package-as-setup-dep.out +++ b/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackageForSetup/use-local-package-as-setup-dep.out @@ -1,11 +1,11 @@ -# cabal v1-update +# cabal v2-update Downloading the latest package list from test-local-repo # cabal v2-build Resolving dependencies... -cabal: Could not resolve dependencies: +Error: cabal: Could not resolve dependencies: [__0] trying: pkg-1.0 (user goal) [__1] next goal: setup-dep (user goal) -[__1] rejecting: setup-dep-2.0 (conflict: pkg => setup-dep==1.*) +[__1] rejecting: setup-dep-2.0 (conflict: pkg => setup-dep>=1 && <2) [__1] rejecting: setup-dep-1.0 (constraint from user target requires ==2.0) [__1] fail (backjumping, conflict set: pkg, setup-dep) After searching the rest of the dependency tree exhaustively, these were the goals I've had most trouble fulfilling: setup-dep (3), pkg (2) diff --git a/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackageForSetup/use-local-package-as-setup-dep.test.hs b/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackageForSetup/use-local-package-as-setup-dep.test.hs --- a/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackageForSetup/use-local-package-as-setup-dep.test.hs +++ b/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackageForSetup/use-local-package-as-setup-dep.test.hs @@ -12,7 +12,7 @@ -- qualifiers. main = withShorterPathForNewBuildStore $ \storeDir -> cabalTest $ do - skipUnless =<< hasNewBuildCompatBootCabal + skipUnless "no v2-build compatible boot-Cabal" =<< hasNewBuildCompatBootCabal withRepo "repo" $ do fails $ cabalG ["--store-dir=" ++ storeDir] "v2-build" ["pkg:my-exe", "--dry-run"] -- Disabled recording because whether or not we get diff --git a/cabal/cabal-testsuite/PackageTests/BuildToolDependsInternalMissing/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/BuildToolDependsInternalMissing/setup.cabal.out --- a/cabal/cabal-testsuite/PackageTests/BuildToolDependsInternalMissing/setup.cabal.out +++ b/cabal/cabal-testsuite/PackageTests/BuildToolDependsInternalMissing/setup.cabal.out @@ -1,3 +1,3 @@ # Setup configure Configuring build-tool-depends-missing-0.1.0.0... -cabal: The package depends on a missing internal executable: +Error: cabal: The package depends on a missing internal executable: diff --git a/cabal/cabal-testsuite/PackageTests/BuildToolDependsInternalMissing/setup.out b/cabal/cabal-testsuite/PackageTests/BuildToolDependsInternalMissing/setup.out --- a/cabal/cabal-testsuite/PackageTests/BuildToolDependsInternalMissing/setup.out +++ b/cabal/cabal-testsuite/PackageTests/BuildToolDependsInternalMissing/setup.out @@ -1,3 +1,3 @@ # Setup configure Configuring build-tool-depends-missing-0.1.0.0... -setup: The package depends on a missing internal executable: +Error: setup: The package depends on a missing internal executable: diff --git a/cabal/cabal-testsuite/PackageTests/BuildTools/Foreign/setup.test.hs b/cabal/cabal-testsuite/PackageTests/BuildTools/Foreign/setup.test.hs --- a/cabal/cabal-testsuite/PackageTests/BuildTools/Foreign/setup.test.hs +++ b/cabal/cabal-testsuite/PackageTests/BuildTools/Foreign/setup.test.hs @@ -7,7 +7,7 @@ -- Test PATH-munging -- TODO: Enable this test on Windows main = setupAndCabalTest $ do - skipIf =<< isWindows + skipIfWindows path <- liftIO $ getEnv "PATH" cwd <- testCurrentDir <$> getTestEnv r <- withEnv [("PATH", Just $ cwd ++ ":" ++ path)] $ setup_build [] diff --git a/cabal/cabal-testsuite/PackageTests/BuildTools/Internal/cabal.out b/cabal/cabal-testsuite/PackageTests/BuildTools/Internal/cabal.out --- a/cabal/cabal-testsuite/PackageTests/BuildTools/Internal/cabal.out +++ b/cabal/cabal-testsuite/PackageTests/BuildTools/Internal/cabal.out @@ -12,6 +12,5 @@ Preprocessing library for foo-0.1.0.0.. Building library for foo-0.1.0.0.. Configuring executable 'hello-world' for foo-0.1.0.0.. -Warning: The package has an extraneous version range for a dependency on an internal library: foo >=0 && ==0.1.0.0. This version range includes the current package but isn't needed as the current package's library will always be used. Preprocessing executable 'hello-world' for foo-0.1.0.0.. Building executable 'hello-world' for foo-0.1.0.0.. diff --git a/cabal/cabal-testsuite/PackageTests/CCompilerOverride/Main.hs b/cabal/cabal-testsuite/PackageTests/CCompilerOverride/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CCompilerOverride/Main.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +module Main (main) where + +foreign import ccall "foo" foo :: Int -> Int + +main :: IO () +main = do + let x = foo 0 + y = x + let x = y + print x + pure () diff --git a/cabal/cabal-testsuite/PackageTests/CCompilerOverride/custom-cc b/cabal/cabal-testsuite/PackageTests/CCompilerOverride/custom-cc new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CCompilerOverride/custom-cc @@ -0,0 +1,13 @@ +#!/bin/bash + +if which cc >/dev/null 2>&1; then + cc -DNOERROR6 "${@}" +elif which gcc >/dev/null 2>&1; then + gcc -DNOERROR6 "${@}" +elif which clang >/dev/null 2>&1; then + clang -DNOERROR6 "${@}" +else + echo "Cannot find C compiler" >&2 + exit 1 +fi + diff --git a/cabal/cabal-testsuite/PackageTests/CCompilerOverride/custom-cc.bat b/cabal/cabal-testsuite/PackageTests/CCompilerOverride/custom-cc.bat new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CCompilerOverride/custom-cc.bat @@ -0,0 +1,11 @@ +@echo OFF + +where /q gcc.exe + +IF %ERRORLEVEL% EQU 0 ( + call gcc.exe -DNOERROR6 %* + EXIT /B %ERRORLEVEL% +) + +ECHO "Cannot find C compiler" +EXIT /B 1 diff --git a/cabal/cabal-testsuite/PackageTests/CCompilerOverride/foo.c b/cabal/cabal-testsuite/PackageTests/CCompilerOverride/foo.c new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CCompilerOverride/foo.c @@ -0,0 +1,28 @@ + +#ifndef NOERROR1 +#error "NOERROR1 was not passed" +#endif + +#ifndef NOERROR2 +#error "NOERROR2 was not passed" +#endif + +#ifndef NOERROR3 +#error "NOERROR3 was not passed" +#endif + +#ifndef NOERROR4 +#error "NOERROR4 was not passed" +#endif + +#ifndef NOERROR5 +#error "NOERROR5 was not passed" +#endif + +#ifndef NOERROR6 +#error "NOERROR6 was not passed" +#endif + +int foo(int x) { + return x + 42; +} diff --git a/cabal/cabal-testsuite/PackageTests/CCompilerOverride/my.cabal b/cabal/cabal-testsuite/PackageTests/CCompilerOverride/my.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CCompilerOverride/my.cabal @@ -0,0 +1,13 @@ +name: my +version: 0.1 +license: BSD3 +cabal-version: >= 1.10 +build-type: Simple + +executable foo + default-language: Haskell2010 + main-is: Main.hs + c-sources: foo.c + build-depends: base + ghc-options: -DNOERROR4 + cc-options: -DNOERROR5 -march=native diff --git a/cabal/cabal-testsuite/PackageTests/CCompilerOverride/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/CCompilerOverride/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CCompilerOverride/setup.cabal.out @@ -0,0 +1,4 @@ +# Setup configure +Configuring my-0.1... +Warning: Instead of 'ghc-options: -DNOERROR4' use 'cpp-options: -DNOERROR4' +# Setup build diff --git a/cabal/cabal-testsuite/PackageTests/CCompilerOverride/setup.out b/cabal/cabal-testsuite/PackageTests/CCompilerOverride/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CCompilerOverride/setup.out @@ -0,0 +1,4 @@ +# Setup configure +Configuring my-0.1... +Warning: Instead of 'ghc-options: -DNOERROR4' use 'cpp-options: -DNOERROR4' +# Setup build diff --git a/cabal/cabal-testsuite/PackageTests/CCompilerOverride/setup.test.hs b/cabal/cabal-testsuite/PackageTests/CCompilerOverride/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CCompilerOverride/setup.test.hs @@ -0,0 +1,19 @@ +import Test.Cabal.Prelude + +-- Test that all the respective defines -DNOERROR... specified in various ways +-- all end up routed to the C compiler. Otherwise the C file we depend on will +-- not compile. +main = setupAndCabalTest $ do + skipUnlessGhcVersion ">= 8.8" + isWin <- isWindows + env <- getTestEnv + let pwd = testCurrentDir env + customCC = pwd ++ "/custom-cc" ++ if isWin then ".bat" else "" + + setup "configure" + [ "--ghc-option=-DNOERROR1" + , "--ghc-option=-optc=-DNOERROR2" + , "--ghc-option=-optP=-DNOERROR3" + , "--with-gcc=" ++ customCC + ] + setup "build" ["-v2"] diff --git a/cabal/cabal-testsuite/PackageTests/CaretOperator/setup.test.hs b/cabal/cabal-testsuite/PackageTests/CaretOperator/setup.test.hs --- a/cabal/cabal-testsuite/PackageTests/CaretOperator/setup.test.hs +++ b/cabal/cabal-testsuite/PackageTests/CaretOperator/setup.test.hs @@ -7,6 +7,7 @@ import Distribution.Types.Dependency import Distribution.PackageDescription import Language.Haskell.Extension (Language(..)) +import Distribution.Utils.Path -- Test that setup parses '^>=' operator correctly. -- Don't bother with the cabal-install test as the build-depends @@ -14,7 +15,7 @@ main = setupTest $ do -- Don't run this for GHC 7.0/7.2, which doesn't have a recent -- enough version of pretty. (But this is pretty dumb.) - skipUnless =<< ghcVersionIs (>= mkVersion [7,3]) + skipUnlessGhcVersion ">= 7.3" assertOutputDoesNotContain "Parse of field 'build-depends' failed" =<< setup' "configure" [] lbi <- getLocalBuildInfoM @@ -26,5 +27,5 @@ when (pn == mkPackageName "pretty") $ assertEqual "targetBuildDepends/pretty" vr (majorBoundVersion (mkVersion [1,1,1,0])) - assertEqual "hsSourceDirs" ["."] (hsSourceDirs bi) + assertEqual "hsSourceDirs" [sameDirectory] (hsSourceDirs bi) return () diff --git a/cabal/cabal-testsuite/PackageTests/Check/SynopsisLength/cabal.out b/cabal/cabal-testsuite/PackageTests/Check/SynopsisLength/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Check/SynopsisLength/cabal.out @@ -0,0 +1,2 @@ +# cabal check +No errors or warnings could be found in the package. diff --git a/cabal/cabal-testsuite/PackageTests/Check/SynopsisLength/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/Check/SynopsisLength/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Check/SynopsisLength/cabal.test.hs @@ -0,0 +1,3 @@ +import Test.Cabal.Prelude + +main = cabalTest $ cabal "check" [] diff --git a/cabal/cabal-testsuite/PackageTests/Check/SynopsisLength/pkg.cabal b/cabal/cabal-testsuite/PackageTests/Check/SynopsisLength/pkg.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Check/SynopsisLength/pkg.cabal @@ -0,0 +1,12 @@ +cabal-version: 2.2 +name: pkg +version: 0 +category: example +maintainer: none@example.com +synopsis: this is a preposterously big synopsis but don't worry because it is this big on +description: this is a preposterously filler description so warnings are not triggered but don +license: BSD-3-Clause + +library + exposed-modules: Foo + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/CheckSetup/LICENSE b/cabal/cabal-testsuite/PackageTests/CheckSetup/LICENSE new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CheckSetup/LICENSE @@ -0,0 +1,1 @@ +LICENSE diff --git a/cabal/cabal-testsuite/PackageTests/CheckSetup/MyLibrary.hs b/cabal/cabal-testsuite/PackageTests/CheckSetup/MyLibrary.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CheckSetup/MyLibrary.hs @@ -0,0 +1,1 @@ +module MyLibrary () where diff --git a/cabal/cabal-testsuite/PackageTests/CheckSetup/Setup.hs b/cabal/cabal-testsuite/PackageTests/CheckSetup/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CheckSetup/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cabal/cabal-testsuite/PackageTests/CheckSetup/my.cabal b/cabal/cabal-testsuite/PackageTests/CheckSetup/my.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CheckSetup/my.cabal @@ -0,0 +1,25 @@ +name: CheckSetup +version: 0.1 +license: BSD3 +license-file: LICENSE +author: Alexander Vershilov +maintainer: Alexander Vershilov +synopsis: Check setup +category: PackageTests +build-type: Custom +cabal-version: 2.0 + +description: + Check that Cabal recognizes problems with setup module. + +custom-setup + setup-depends: + base, + Cabal, + bytestring + +Library + default-language: Haskell2010 + build-depends: base <5.0 + exposed-modules: + MyLibrary diff --git a/cabal/cabal-testsuite/PackageTests/CheckSetup/setup.test.hs b/cabal/cabal-testsuite/PackageTests/CheckSetup/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CheckSetup/setup.test.hs @@ -0,0 +1,20 @@ +import Test.Cabal.Prelude + +-- Test that setup shows all the 'autogen-modules' warnings. +main = cabalTest $ do + + checkResult <- fails $ cabal_raw' ["check"] Nothing + + -- Package check messages. + let libError1 = + "The dependency 'setup-depends: 'Cabal' does not specify " + ++ "an upper bound on the version number" + libError2 = + "The dependency 'setup-depends: 'base' does not specify " + ++ "an upper bound on the version number" + + -- Asserts for the desired check messages after configure. + assertOutputContains libError1 checkResult + assertOutputContains libError2 checkResult + + return () diff --git a/cabal/cabal-testsuite/PackageTests/CmmSources/cabal.out b/cabal/cabal-testsuite/PackageTests/CmmSources/cabal.out --- a/cabal/cabal-testsuite/PackageTests/CmmSources/cabal.out +++ b/cabal/cabal-testsuite/PackageTests/CmmSources/cabal.out @@ -8,6 +8,5 @@ Preprocessing library for cmmexperiment-0.. Building library for cmmexperiment-0.. Configuring executable 'demo' for cmmexperiment-0.. -Warning: The package has an extraneous version range for a dependency on an internal library: cmmexperiment >=0 && ==0. This version range includes the current package but isn't needed as the current package's library will always be used. Preprocessing executable 'demo' for cmmexperiment-0.. Building executable 'demo' for cmmexperiment-0.. diff --git a/cabal/cabal-testsuite/PackageTests/CmmSources/demo/Main.hs b/cabal/cabal-testsuite/PackageTests/CmmSources/demo/Main.hs --- a/cabal/cabal-testsuite/PackageTests/CmmSources/demo/Main.hs +++ b/cabal/cabal-testsuite/PackageTests/CmmSources/demo/Main.hs @@ -1,2 +1,2 @@ -module Main (main) where +module Main (module Demo) where import Demo (main) diff --git a/cabal/cabal-testsuite/PackageTests/CmmSources/setup.test.hs b/cabal/cabal-testsuite/PackageTests/CmmSources/setup.test.hs --- a/cabal/cabal-testsuite/PackageTests/CmmSources/setup.test.hs +++ b/cabal/cabal-testsuite/PackageTests/CmmSources/setup.test.hs @@ -1,7 +1,7 @@ import Test.Cabal.Prelude main = setupTest $ do - skipIf =<< ghcVersionIs (< mkVersion [7,8]) + skipUnlessGhcVersion ">= 7.8" setup "configure" [] res <- setup' "build" [] assertOutputContains "= Post common block elimination =" res diff --git a/cabal/cabal-testsuite/PackageTests/CmmSourcesDyn/cabal.out b/cabal/cabal-testsuite/PackageTests/CmmSourcesDyn/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CmmSourcesDyn/cabal.out @@ -0,0 +1,12 @@ +# cabal v2-run +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - cmmexperiment-0 (lib) (first run) + - cmmexperiment-0 (exe:demo) (first run) +Configuring library for cmmexperiment-0.. +Preprocessing library for cmmexperiment-0.. +Building library for cmmexperiment-0.. +Configuring executable 'demo' for cmmexperiment-0.. +Preprocessing executable 'demo' for cmmexperiment-0.. +Building executable 'demo' for cmmexperiment-0.. diff --git a/cabal/cabal-testsuite/PackageTests/CmmSourcesDyn/cabal.project b/cabal/cabal-testsuite/PackageTests/CmmSourcesDyn/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CmmSourcesDyn/cabal.project @@ -0,0 +1,2 @@ +packages: . +executable-dynamic: True diff --git a/cabal/cabal-testsuite/PackageTests/CmmSourcesDyn/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/CmmSourcesDyn/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CmmSourcesDyn/cabal.test.hs @@ -0,0 +1,7 @@ +import Test.Cabal.Prelude + +main = cabalTest $ do + skipIfWindows + res <- cabal' "v2-run" ["demo"] + assertOutputContains "= Post common block elimination =" res + assertOutputContains "In Box we have 0x" res diff --git a/cabal/cabal-testsuite/PackageTests/CmmSourcesDyn/cbits/HeapPrim.cmm b/cabal/cabal-testsuite/PackageTests/CmmSourcesDyn/cbits/HeapPrim.cmm new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CmmSourcesDyn/cbits/HeapPrim.cmm @@ -0,0 +1,6 @@ +#include "Cmm.h" + +aToMyWordzh (P_ clos) +{ + return (clos); +} diff --git a/cabal/cabal-testsuite/PackageTests/CmmSourcesDyn/cmmexperiment.cabal b/cabal/cabal-testsuite/PackageTests/CmmSourcesDyn/cmmexperiment.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CmmSourcesDyn/cmmexperiment.cabal @@ -0,0 +1,27 @@ +cabal-version: 3.0 +name: cmmexperiment +version: 0 +build-type: Simple + +-- This code is extracted form ghc-heap +-- Copyright (c) 2012-2013, Joachim Breitner +-- (and probably -2020 GHC Team) +-- Under BSD-3-Clause + +library + default-language: Haskell2010 + hs-source-dirs: src + build-depends: base + exposed-modules: Demo + + cmm-sources: cbits/HeapPrim.cmm + if impl(ghc >=8.2) + cmm-options: -ddump-cmm-verbose + else + cmm-options: -ddump-cmm + +executable demo + default-language: Haskell2010 + main-is: Main.hs + hs-source-dirs: demo + build-depends: base, cmmexperiment diff --git a/cabal/cabal-testsuite/PackageTests/CmmSourcesDyn/demo/Main.hs b/cabal/cabal-testsuite/PackageTests/CmmSourcesDyn/demo/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CmmSourcesDyn/demo/Main.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE CPP #-} +module Main (main) where + +-- Qualified due to https://gitlab.haskell.org/ghc/ghc/-/issues/19397 +-- +import qualified Demo (main) + +main :: IO () +main = Demo.main diff --git a/cabal/cabal-testsuite/PackageTests/CmmSourcesDyn/setup.out b/cabal/cabal-testsuite/PackageTests/CmmSourcesDyn/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CmmSourcesDyn/setup.out @@ -0,0 +1,7 @@ +# Setup configure +Configuring cmmexperiment-0... +# Setup build +Preprocessing library for cmmexperiment-0.. +Building library for cmmexperiment-0.. +Preprocessing executable 'demo' for cmmexperiment-0.. +Building executable 'demo' for cmmexperiment-0.. diff --git a/cabal/cabal-testsuite/PackageTests/CmmSourcesDyn/setup.test.hs b/cabal/cabal-testsuite/PackageTests/CmmSourcesDyn/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CmmSourcesDyn/setup.test.hs @@ -0,0 +1,7 @@ +import Test.Cabal.Prelude + +main = setupTest $ do + skipIf "ghc < 7.8" =<< isGhcVersion "< 7.8" + setup "configure" [] + res <- setup' "build" [] + assertOutputContains "= Post common block elimination =" res diff --git a/cabal/cabal-testsuite/PackageTests/CmmSourcesDyn/src/Demo.hs b/cabal/cabal-testsuite/PackageTests/CmmSourcesDyn/src/Demo.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CmmSourcesDyn/src/Demo.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE GHCForeignImportPrim #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnliftedFFITypes #-} +module Demo (main) where + +#include "MachDeps.h" + +import Data.Bits +import GHC.Exts +import Numeric (showHex) + +foreign import prim "aToMyWordzh" aToWord# :: Any -> Word# + +tAG_MASK :: Int +tAG_MASK = (1 `shift` TAG_BITS) - 1 + +data Box = Box Any + +instance Show Box where + showsPrec _ (Box a) rs = + -- unsafePerformIO (print "↓" >> pClosure a) `seq` + pad_out (showHex addr "") ++ (if tag>0 then "/" ++ show tag else "") ++ rs + where + ptr = W# (aToWord# a) + tag = ptr .&. fromIntegral tAG_MASK -- ((1 `shiftL` TAG_BITS) -1) + addr = ptr - tag + pad_out ls = '0':'x':ls + +asBox :: a -> Box +asBox x = Box (unsafeCoerce# x) + +main :: IO () +main = do + let box = asBox "foobar" + putStrLn $ "In Box we have " ++ show box diff --git a/cabal/cabal-testsuite/PackageTests/ConditionalAndImport/Foo.hs b/cabal/cabal-testsuite/PackageTests/ConditionalAndImport/Foo.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ConditionalAndImport/Foo.hs @@ -0,0 +1,1 @@ +module Foo where diff --git a/cabal/cabal-testsuite/PackageTests/ConditionalAndImport/cabal-bad-conditional.project b/cabal/cabal-testsuite/PackageTests/ConditionalAndImport/cabal-bad-conditional.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ConditionalAndImport/cabal-bad-conditional.project @@ -0,0 +1,4 @@ +packages: . + +if(True) + compiler: ghc diff --git a/cabal/cabal-testsuite/PackageTests/ConditionalAndImport/cabal-cyclical.project b/cabal/cabal-testsuite/PackageTests/ConditionalAndImport/cabal-cyclical.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ConditionalAndImport/cabal-cyclical.project @@ -0,0 +1,3 @@ +packages: . + +import: cabal-cyclical.project diff --git a/cabal/cabal-testsuite/PackageTests/ConditionalAndImport/cabal.out b/cabal/cabal-testsuite/PackageTests/ConditionalAndImport/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ConditionalAndImport/cabal.out @@ -0,0 +1,18 @@ +# cabal v2-update +Downloading the latest package list from test-local-repo +# cabal v2-run +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - some-exe-0.0.1.0 (exe:some-exe) (requires build) +Configuring some-exe-0.0.1.0... +Preprocessing executable 'some-exe' for some-exe-0.0.1.0.. +Building executable 'some-exe' for some-exe-0.0.1.0.. +Installing executable some-exe in +Warning: The directory /cabal.dist/home/.cabal/store/ghc-/incoming/new-/cabal.dist/home/.cabal/store/ghc-/-/bin is not in the system search path. +# cabal v2-build +Error: cabal: Error parsing project file /cabal-cyclical.project:3: +cyclical import of cabal-cyclical.project +# cabal v2-build +Error: cabal: Error parsing project file /cabal-bad-conditional.project: +Cannot set compiler in a conditional clause of a cabal project file diff --git a/cabal/cabal-testsuite/PackageTests/ConditionalAndImport/cabal.project b/cabal/cabal-testsuite/PackageTests/ConditionalAndImport/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ConditionalAndImport/cabal.project @@ -0,0 +1,3 @@ +packages: . + +import: extra.project diff --git a/cabal/cabal-testsuite/PackageTests/ConditionalAndImport/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/ConditionalAndImport/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ConditionalAndImport/cabal.test.hs @@ -0,0 +1,6 @@ +import Test.Cabal.Prelude +main = cabalTest $ + withRepo "repo" $ do + cabal "v2-run" [ "some-exe" ] + fails $ cabal "v2-build" [ "--project=cabal-cyclical.project" ] + fails $ cabal "v2-build" [ "--project=cabal-bad-conditional.project" ] diff --git a/cabal/cabal-testsuite/PackageTests/ConditionalAndImport/extra.project b/cabal/cabal-testsuite/PackageTests/ConditionalAndImport/extra.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ConditionalAndImport/extra.project @@ -0,0 +1,8 @@ +if(os(NoSuchOs) || False) + extra-packages: no-such-package +elif(os(Whoops)) + extra-packages: no-can-do +elif(True) + extra-packages: some-exe +else + extra-packages: nope diff --git a/cabal/cabal-testsuite/PackageTests/ConditionalAndImport/my.cabal b/cabal/cabal-testsuite/PackageTests/ConditionalAndImport/my.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ConditionalAndImport/my.cabal @@ -0,0 +1,9 @@ +name: my +version: 0.1 +license: BSD3 +cabal-version: >= 1.2 +build-type: Simple + +library + exposed-modules: Foo + build-depends: base diff --git a/cabal/cabal-testsuite/PackageTests/ConditionalAndImport/repo/some-exe-0.0.1.0/Main.hs b/cabal/cabal-testsuite/PackageTests/ConditionalAndImport/repo/some-exe-0.0.1.0/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ConditionalAndImport/repo/some-exe-0.0.1.0/Main.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = putStrLn "hello world" diff --git a/cabal/cabal-testsuite/PackageTests/ConditionalAndImport/repo/some-exe-0.0.1.0/some-exe.cabal b/cabal/cabal-testsuite/PackageTests/ConditionalAndImport/repo/some-exe-0.0.1.0/some-exe.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ConditionalAndImport/repo/some-exe-0.0.1.0/some-exe.cabal @@ -0,0 +1,9 @@ +name: some-exe +version: 0.0.1.0 +license: BSD3 +cabal-version: >= 1.2 +build-type: Simple + +Executable some-exe + main-is: Main.hs + build-depends: base diff --git a/cabal/cabal-testsuite/PackageTests/ConfigFile/T7705/cabal.out b/cabal/cabal-testsuite/PackageTests/ConfigFile/T7705/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ConfigFile/T7705/cabal.out @@ -0,0 +1,8 @@ +# cabal info +Config file path source is commandline option. +Error: cabal: Config file not found: does.not.exist +(Config files can be created via the cabal-command 'user-config init'.) +# cabal info +Config file path source is environment variable CABAL_CONFIG. +Error: cabal: Config file not found: absent.file +(Config files can be created via the cabal-command 'user-config init'.) diff --git a/cabal/cabal-testsuite/PackageTests/ConfigFile/T7705/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/ConfigFile/T7705/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ConfigFile/T7705/cabal.test.hs @@ -0,0 +1,23 @@ +-- 2021-10-07, issue #7705 +-- +-- Non-existent config file given explicitly (via option or environment variable) +-- should not be filled with default content. +-- Rather, an error should be raised. +-- +-- See also @PackageTests/UserConfig/cabal.test.hs@ for testing of command +-- @user-config@. +-- +-- We use the @info@ command as it does not have side-effects. +-- Does not really matter which command we use for this test, +-- except that it should accept option @--config-file@. +-- +-- This is a golden value test that reports the produced error message. +-- Needs to be checked manually whether it meets expectations. + +import Test.Cabal.Prelude + +main = cabalTest $ do + fails $ + cabalG [ "--config-file", "does.not.exist" ] "info" [ "happy" ] + fails $ withEnv [("CABAL_CONFIG", Just "absent.file")] $ + cabal "info" [ "alex" ] diff --git a/cabal/cabal-testsuite/PackageTests/Configure/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/Configure/cabal.test.hs --- a/cabal/cabal-testsuite/PackageTests/Configure/cabal.test.hs +++ b/cabal/cabal-testsuite/PackageTests/Configure/cabal.test.hs @@ -5,6 +5,6 @@ -- Test for 'build-type: Configure' example from the setup manual. main = cabalTest $ do hasAutoreconf <- liftIO $ fmap isJust $ findExecutable "autoreconf" - skipUnless hasAutoreconf + skipUnless "no autoreconf" hasAutoreconf _ <- shell "autoreconf" ["-i"] cabal "v2-build" [] diff --git a/cabal/cabal-testsuite/PackageTests/Configure/setup.test.hs b/cabal/cabal-testsuite/PackageTests/Configure/setup.test.hs --- a/cabal/cabal-testsuite/PackageTests/Configure/setup.test.hs +++ b/cabal/cabal-testsuite/PackageTests/Configure/setup.test.hs @@ -5,6 +5,6 @@ -- Test for 'build-type: Configure' example from the setup manual. main = setupTest $ do hasAutoreconf <- liftIO $ fmap isJust $ findExecutable "autoreconf" - skipUnless hasAutoreconf + skipUnless "no autoreconf" hasAutoreconf _ <- shell "autoreconf" ["-i"] setup_build [] diff --git a/cabal/cabal-testsuite/PackageTests/ConfigureComponent/SubLib/setup-explicit-fail.out b/cabal/cabal-testsuite/PackageTests/ConfigureComponent/SubLib/setup-explicit-fail.out --- a/cabal/cabal-testsuite/PackageTests/ConfigureComponent/SubLib/setup-explicit-fail.out +++ b/cabal/cabal-testsuite/PackageTests/ConfigureComponent/SubLib/setup-explicit-fail.out @@ -9,5 +9,5 @@ Registering library 'sublib' for Lib-0.1.0.0.. # Setup configure Configuring executable 'exe' for Lib-0.1.0.0.. -setup: Encountered missing or private dependencies: +Error: setup: Encountered missing or private dependencies: Lib:sublib diff --git a/cabal/cabal-testsuite/PackageTests/CustomDep/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/CustomDep/cabal.test.hs --- a/cabal/cabal-testsuite/PackageTests/CustomDep/cabal.test.hs +++ b/cabal/cabal-testsuite/PackageTests/CustomDep/cabal.test.hs @@ -1,9 +1,9 @@ import Test.Cabal.Prelude main = cabalTest $ do -- NB: This variant seems to use the bootstrapped Cabal? - skipUnless =<< hasCabalForGhc + skipUnless "no Cabal for GHC" =<< hasCabalForGhc -- implicit setup-depends conflict with GHC >= 8.2; c.f. #415 - skipIf =<< (ghcVersionIs (>= mkVersion [8,2])) + skipUnlessGhcVersion "< 8.2" -- This test depends heavily on what packages are in the global -- database, don't record the output recordMode DoNotRecord $ do diff --git a/cabal/cabal-testsuite/PackageTests/CustomPlain/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/CustomPlain/cabal.test.hs --- a/cabal/cabal-testsuite/PackageTests/CustomPlain/cabal.test.hs +++ b/cabal/cabal-testsuite/PackageTests/CustomPlain/cabal.test.hs @@ -1,7 +1,7 @@ import Test.Cabal.Prelude main = cabalTest $ do -- implicit setup-depends conflict with GHC >= 8.2; c.f. #415 - skipIf =<< (ghcVersionIs (>= mkVersion [8,2])) + skipUnlessGhcVersion "< 8.2" -- Regression test for #4393 recordMode DoNotRecord $ do -- TODO: Hack; see also CustomDep/cabal.test.hs diff --git a/cabal/cabal-testsuite/PackageTests/CustomPlain/setup.test.hs b/cabal/cabal-testsuite/PackageTests/CustomPlain/setup.test.hs --- a/cabal/cabal-testsuite/PackageTests/CustomPlain/setup.test.hs +++ b/cabal/cabal-testsuite/PackageTests/CustomPlain/setup.test.hs @@ -1,10 +1,5 @@ import Test.Cabal.Prelude main = setupTest $ do - skipUnless =<< hasCabalForGhc - -- On Travis OSX, Cabal shipped with GHC 7.8 does not work - -- with error "setup: /usr/bin/ar: permission denied"; see - -- also https://github.com/haskell/cabal/issues/3938 - -- This is a hack to make the test not run in this case. - skipIf =<< liftM2 (&&) isOSX (ghcVersionIs (< mkVersion [7,10])) + skipUnless "no Cabal for GHC" =<< hasCabalForGhc setup' "configure" [] >>= assertOutputContains "ThisIsCustomYeah" setup' "build" [] >>= assertOutputContains "ThisIsCustomYeah" diff --git a/cabal/cabal-testsuite/PackageTests/CustomPreProcess/Setup.hs b/cabal/cabal-testsuite/PackageTests/CustomPreProcess/Setup.hs --- a/cabal/cabal-testsuite/PackageTests/CustomPreProcess/Setup.hs +++ b/cabal/cabal-testsuite/PackageTests/CustomPreProcess/Setup.hs @@ -33,7 +33,12 @@ platformIndependent = True, runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do info verbosity ("Preprocessing " ++ inFile ++ " to " ++ outFile) +#if MIN_VERSION_Cabal(3,7,0) + callProcess progPath [inFile, outFile], + ppOrdering = unsorted +#else callProcess progPath [inFile, outFile] +#endif } where builddir = buildDir lbi diff --git a/cabal/cabal-testsuite/PackageTests/CustomPreProcess/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/CustomPreProcess/cabal.test.hs --- a/cabal/cabal-testsuite/PackageTests/CustomPreProcess/cabal.test.hs +++ b/cabal/cabal-testsuite/PackageTests/CustomPreProcess/cabal.test.hs @@ -1,7 +1,7 @@ import Test.Cabal.Prelude -- Test internal custom preprocessor main = cabalTest $ do - skipUnless =<< hasCabalForGhc + skipUnless "no Cabal for GHC" =<< hasCabalForGhc -- old Cabal's ./Setup.hs output is difficult to normalise recordMode DoNotRecord $ diff --git a/cabal/cabal-testsuite/PackageTests/CustomPreProcess/setup.test.hs b/cabal/cabal-testsuite/PackageTests/CustomPreProcess/setup.test.hs --- a/cabal/cabal-testsuite/PackageTests/CustomPreProcess/setup.test.hs +++ b/cabal/cabal-testsuite/PackageTests/CustomPreProcess/setup.test.hs @@ -1,7 +1,7 @@ import Test.Cabal.Prelude -- Test internal custom preprocessor main = setupTest $ do - skipUnless =<< hasCabalForGhc + skipUnless "no Cabal for GHC" =<< hasCabalForGhc setup_build [] runExe' "hello-world" [] >>= assertOutputContains "hello from A" diff --git a/cabal/cabal-testsuite/PackageTests/CustomSegfault/cabal.out b/cabal/cabal-testsuite/PackageTests/CustomSegfault/cabal.out --- a/cabal/cabal-testsuite/PackageTests/CustomSegfault/cabal.out +++ b/cabal/cabal-testsuite/PackageTests/CustomSegfault/cabal.out @@ -3,4 +3,4 @@ Build profile: -w ghc- -O1 In order, the following will be built: - plain-0.1.0.0 (lib:plain) (first run) -cabal: Failed to build plain-0.1.0.0-inplace. The failure occurred during the configure step. The build process segfaulted (i.e. SIGSEGV). +Error: cabal: Failed to build plain-0.1.0.0-inplace. The failure occurred during the configure step. The build process segfaulted (i.e. SIGSEGV). diff --git a/cabal/cabal-testsuite/PackageTests/CustomSegfault/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/CustomSegfault/cabal.test.hs --- a/cabal/cabal-testsuite/PackageTests/CustomSegfault/cabal.test.hs +++ b/cabal/cabal-testsuite/PackageTests/CustomSegfault/cabal.test.hs @@ -1,6 +1,6 @@ import Test.Cabal.Prelude main = cabalTest $ do -- TODO: this test ought to work on Windows too - skipUnless =<< isLinux - skipUnless =<< ghcVersionIs (>= mkVersion [7,8]) + skipUnless "not Linux" =<< isLinux + skipUnlessGhcVersion ">= 7.8" fails $ cabal' "v2-build" [] >>= assertOutputContains "SIGSEGV" diff --git a/cabal/cabal-testsuite/PackageTests/DeterministicAr/setup-default-ar.test.hs b/cabal/cabal-testsuite/PackageTests/DeterministicAr/setup-default-ar.test.hs --- a/cabal/cabal-testsuite/PackageTests/DeterministicAr/setup-default-ar.test.hs +++ b/cabal/cabal-testsuite/PackageTests/DeterministicAr/setup-default-ar.test.hs @@ -5,7 +5,7 @@ import Test.Cabal.CheckArMetadata --- Test that setup determinstically generates object archives +-- Test that setup deterministically generates object archives main = setupAndCabalTest $ do setup_build [] dist_dir <- fmap testDistDir getTestEnv diff --git a/cabal/cabal-testsuite/PackageTests/DeterministicAr/setup-old-ar-without-at-args.test.hs b/cabal/cabal-testsuite/PackageTests/DeterministicAr/setup-old-ar-without-at-args.test.hs --- a/cabal/cabal-testsuite/PackageTests/DeterministicAr/setup-old-ar-without-at-args.test.hs +++ b/cabal/cabal-testsuite/PackageTests/DeterministicAr/setup-old-ar-without-at-args.test.hs @@ -5,7 +5,7 @@ import Test.Cabal.CheckArMetadata --- Test that setup determinstically generates object archives +-- Test that setup deterministically generates object archives main = setupAndCabalTest $ do setup_build ["--disable-response-files"] dist_dir <- fmap testDistDir getTestEnv diff --git a/cabal/cabal-testsuite/PackageTests/DuplicateModuleName/DuplicateModuleName.cabal b/cabal/cabal-testsuite/PackageTests/DuplicateModuleName/DuplicateModuleName.cabal --- a/cabal/cabal-testsuite/PackageTests/DuplicateModuleName/DuplicateModuleName.cabal +++ b/cabal/cabal-testsuite/PackageTests/DuplicateModuleName/DuplicateModuleName.cabal @@ -1,10 +1,10 @@ +cabal-version: 3.8 name: DuplicateModuleName version: 0.1.0.0 -license: BSD3 +license: BSD-3-Clause author: Edward Z. Yang maintainer: ezyang@cs.stanford.edu build-type: Simple -cabal-version: >=1.10 library exposed-modules: Foo @@ -13,7 +13,6 @@ default-language: Haskell2010 test-suite foo - type: detailed-0.9 test-module: Foo hs-source-dirs: tests build-depends: base, Cabal, DuplicateModuleName diff --git a/cabal/cabal-testsuite/PackageTests/DuplicateModuleName/setup.test.hs b/cabal/cabal-testsuite/PackageTests/DuplicateModuleName/setup.test.hs --- a/cabal/cabal-testsuite/PackageTests/DuplicateModuleName/setup.test.hs +++ b/cabal/cabal-testsuite/PackageTests/DuplicateModuleName/setup.test.hs @@ -2,7 +2,7 @@ -- Test that if two components have the same module name, they do not -- clobber each other. main = setupAndCabalTest $ do - skipUnless =<< hasCabalForGhc -- use of library test suite + skipUnless "no Cabal for GHC" =<< hasCabalForGhc -- use of library test suite setup_build ["--enable-tests"] r1 <- fails $ setup' "test" ["foo"] assertOutputContains "test B" r1 diff --git a/cabal/cabal-testsuite/PackageTests/Exec/legacy-autoconfigure.out b/cabal/cabal-testsuite/PackageTests/Exec/legacy-autoconfigure.out deleted file mode 100644 --- a/cabal/cabal-testsuite/PackageTests/Exec/legacy-autoconfigure.out +++ /dev/null @@ -1,1 +0,0 @@ -# cabal v1-exec diff --git a/cabal/cabal-testsuite/PackageTests/Exec/legacy-autoconfigure.test.hs b/cabal/cabal-testsuite/PackageTests/Exec/legacy-autoconfigure.test.hs deleted file mode 100644 --- a/cabal/cabal-testsuite/PackageTests/Exec/legacy-autoconfigure.test.hs +++ /dev/null @@ -1,4 +0,0 @@ -import Test.Cabal.Prelude -main = cabalTest $ do - cabal' "v1-exec" ["echo", "find_me_in_output"] - >>= assertOutputContains "find_me_in_output" diff --git a/cabal/cabal-testsuite/PackageTests/Exec/legacy-no-args.out b/cabal/cabal-testsuite/PackageTests/Exec/legacy-no-args.out deleted file mode 100644 --- a/cabal/cabal-testsuite/PackageTests/Exec/legacy-no-args.out +++ /dev/null @@ -1,2 +0,0 @@ -# cabal v1-exec -cabal: Please specify an executable to run diff --git a/cabal/cabal-testsuite/PackageTests/Exec/legacy-no-args.test.hs b/cabal/cabal-testsuite/PackageTests/Exec/legacy-no-args.test.hs deleted file mode 100644 --- a/cabal/cabal-testsuite/PackageTests/Exec/legacy-no-args.test.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Test.Cabal.Prelude -main = cabalTest $ fails (cabal' "v1-exec" []) >>= assertOutputContains "Please specify an executable to run" diff --git a/cabal/cabal-testsuite/PackageTests/Exec/legacy.out b/cabal/cabal-testsuite/PackageTests/Exec/legacy.out deleted file mode 100644 --- a/cabal/cabal-testsuite/PackageTests/Exec/legacy.out +++ /dev/null @@ -1,4 +0,0 @@ -# cabal v1-configure -Resolving dependencies... -Configuring my-0.1... -# cabal v1-exec diff --git a/cabal/cabal-testsuite/PackageTests/Exec/legacy.test.hs b/cabal/cabal-testsuite/PackageTests/Exec/legacy.test.hs deleted file mode 100644 --- a/cabal/cabal-testsuite/PackageTests/Exec/legacy.test.hs +++ /dev/null @@ -1,5 +0,0 @@ -import Test.Cabal.Prelude -main = cabalTest $ do - cabal "v1-configure" [] - cabal' "v1-exec" ["echo", "find_me_in_output"] - >>= assertOutputContains "find_me_in_output" diff --git a/cabal/cabal-testsuite/PackageTests/ExtraPackages/Foo.hs b/cabal/cabal-testsuite/PackageTests/ExtraPackages/Foo.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ExtraPackages/Foo.hs @@ -0,0 +1,1 @@ +module Foo where diff --git a/cabal/cabal-testsuite/PackageTests/ExtraPackages/cabal.out b/cabal/cabal-testsuite/PackageTests/ExtraPackages/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ExtraPackages/cabal.out @@ -0,0 +1,12 @@ +# cabal v2-update +Downloading the latest package list from test-local-repo +# cabal v2-run +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - some-exe-0.0.1.0 (exe:some-exe) (requires build) +Configuring some-exe-0.0.1.0... +Preprocessing executable 'some-exe' for some-exe-0.0.1.0.. +Building executable 'some-exe' for some-exe-0.0.1.0.. +Installing executable some-exe in +Warning: The directory /cabal.dist/home/.cabal/store/ghc-/incoming/new-/cabal.dist/home/.cabal/store/ghc-/-/bin is not in the system search path. diff --git a/cabal/cabal-testsuite/PackageTests/ExtraPackages/cabal.project b/cabal/cabal-testsuite/PackageTests/ExtraPackages/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ExtraPackages/cabal.project @@ -0,0 +1,2 @@ +packages: . +extra-packages: some-exe diff --git a/cabal/cabal-testsuite/PackageTests/ExtraPackages/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/ExtraPackages/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ExtraPackages/cabal.test.hs @@ -0,0 +1,3 @@ +import Test.Cabal.Prelude +main = cabalTest $ withRepo "repo" $ do + cabal "v2-run" [ "some-exe" ] diff --git a/cabal/cabal-testsuite/PackageTests/ExtraPackages/my.cabal b/cabal/cabal-testsuite/PackageTests/ExtraPackages/my.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ExtraPackages/my.cabal @@ -0,0 +1,9 @@ +name: my +version: 0.1 +license: BSD3 +cabal-version: >= 1.2 +build-type: Simple + +library + exposed-modules: Foo + build-depends: base diff --git a/cabal/cabal-testsuite/PackageTests/ExtraPackages/repo/some-exe-0.0.1.0/Main.hs b/cabal/cabal-testsuite/PackageTests/ExtraPackages/repo/some-exe-0.0.1.0/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ExtraPackages/repo/some-exe-0.0.1.0/Main.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = putStrLn "hello world" diff --git a/cabal/cabal-testsuite/PackageTests/ExtraPackages/repo/some-exe-0.0.1.0/some-exe.cabal b/cabal/cabal-testsuite/PackageTests/ExtraPackages/repo/some-exe-0.0.1.0/some-exe.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ExtraPackages/repo/some-exe-0.0.1.0/some-exe.cabal @@ -0,0 +1,9 @@ +name: some-exe +version: 0.0.1.0 +license: BSD3 +cabal-version: >= 1.2 +build-type: Simple + +Executable some-exe + main-is: Main.hs + build-depends: base diff --git a/cabal/cabal-testsuite/PackageTests/FFI/ForeignOptsC/Main.hs b/cabal/cabal-testsuite/PackageTests/FFI/ForeignOptsC/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/FFI/ForeignOptsC/Main.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +module Main where + +import Foreign.C (CInt (..)) + +foreign import ccall "clib.h meaning_of_life_c" + meaning_of_life_c :: IO CInt + +main :: IO () +main = do + secret <- meaning_of_life_c + -- The value 11 comes from __TESTOPT_C__ - see the cabal file. + if (secret == 11) + then putStrLn ("The secret is " ++ show secret) + else error ("Expected value 11, got " ++ show secret) diff --git a/cabal/cabal-testsuite/PackageTests/FFI/ForeignOptsC/README.md b/cabal/cabal-testsuite/PackageTests/FFI/ForeignOptsC/README.md new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/FFI/ForeignOptsC/README.md @@ -0,0 +1,5 @@ +# ForeignOptsC + +This test case asserts that cabal passes `cc-options` to the C compiler (and NOT `cxx-options`). + +See the additional case `ForeignOptsCxx`. diff --git a/cabal/cabal-testsuite/PackageTests/FFI/ForeignOptsC/cabal.out b/cabal/cabal-testsuite/PackageTests/FFI/ForeignOptsC/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/FFI/ForeignOptsC/cabal.out @@ -0,0 +1,10 @@ +# cabal v2-build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - foreign-opts-c-0.1 (exe:foreign-opts-c-exe) (first run) +Configuring executable 'foreign-opts-c-exe' for foreign-opts-c-0.1.. +Preprocessing executable 'foreign-opts-c-exe' for foreign-opts-c-0.1.. +Building executable 'foreign-opts-c-exe' for foreign-opts-c-0.1.. +# foreign-opts-c foreign-opts-c-exe +The secret is 11 diff --git a/cabal/cabal-testsuite/PackageTests/FFI/ForeignOptsC/cabal.project b/cabal/cabal-testsuite/PackageTests/FFI/ForeignOptsC/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/FFI/ForeignOptsC/cabal.project @@ -0,0 +1,1 @@ +packages: . diff --git a/cabal/cabal-testsuite/PackageTests/FFI/ForeignOptsC/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/FFI/ForeignOptsC/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/FFI/ForeignOptsC/cabal.test.hs @@ -0,0 +1,4 @@ +import Test.Cabal.Prelude +main = cabalTest $ do + cabal "v2-build" ["foreign-opts-c-exe"] + withPlan $ runPlanExe "foreign-opts-c" "foreign-opts-c-exe" [] diff --git a/cabal/cabal-testsuite/PackageTests/FFI/ForeignOptsC/cbits/clib.c b/cabal/cabal-testsuite/PackageTests/FFI/ForeignOptsC/cbits/clib.c new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/FFI/ForeignOptsC/cbits/clib.c @@ -0,0 +1,13 @@ +#include "clib.h" + +#ifndef __TESTOPT_C__ +#error "Did not get required __TESTOPT_C__ from cc-options" +#endif + +#ifdef __TESTOPT_CXX__ +#error "Got unexpected __TESTOPT_CXX__ from cxx-options" +#endif + +int meaning_of_life_c() { + return __TESTOPT_C__; +} diff --git a/cabal/cabal-testsuite/PackageTests/FFI/ForeignOptsC/cbits/clib.h b/cabal/cabal-testsuite/PackageTests/FFI/ForeignOptsC/cbits/clib.h new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/FFI/ForeignOptsC/cbits/clib.h @@ -0,0 +1,6 @@ +#ifndef CLIB_H +#define CLIB_H + +int meaning_of_life_c(); + +#endif diff --git a/cabal/cabal-testsuite/PackageTests/FFI/ForeignOptsC/foreign-opts-c.cabal b/cabal/cabal-testsuite/PackageTests/FFI/ForeignOptsC/foreign-opts-c.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/FFI/ForeignOptsC/foreign-opts-c.cabal @@ -0,0 +1,14 @@ +cabal-version: 2.2 +name: foreign-opts-c +version: 0.1 +build-type: Simple + +executable foreign-opts-c-exe + main-is: Main.hs + build-depends: base + default-language: Haskell2010 + include-dirs: cbits + c-sources: cbits/clib.c + -- The following options are shared in all ForeignOpts cases: + cc-options: -D__TESTOPT_C__=11 + cxx-options: -D__TESTOPT_CXX__=22 diff --git a/cabal/cabal-testsuite/PackageTests/FFI/ForeignOptsCxx/Main.hs b/cabal/cabal-testsuite/PackageTests/FFI/ForeignOptsCxx/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/FFI/ForeignOptsCxx/Main.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +module Main where + +import Foreign.C (CInt (..)) + +foreign import ccall "cxxlib.h meaning_of_life_cxx" + meaning_of_life_cxx :: IO CInt + +main :: IO () +main = do + secret <- meaning_of_life_cxx + -- The value 22 comes from __TESTOPT_CXX__ - see the cabal file. + if (secret == 22) + then putStrLn ("The secret is " ++ show secret) + else error ("Expected value 22, got " ++ show secret) diff --git a/cabal/cabal-testsuite/PackageTests/FFI/ForeignOptsCxx/README.md b/cabal/cabal-testsuite/PackageTests/FFI/ForeignOptsCxx/README.md new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/FFI/ForeignOptsCxx/README.md @@ -0,0 +1,7 @@ +# ForeignOptsCxx + +This asserts that cabal passes `cxx-options` to the C++ compiler (and NOT `cc-options`). + +Since GHC 8.10, they are passed through GHC with `-optcxx`. Before that, they were passed with `-optc`. + +See the additional case `ForeignOptsC`. diff --git a/cabal/cabal-testsuite/PackageTests/FFI/ForeignOptsCxx/cabal.out b/cabal/cabal-testsuite/PackageTests/FFI/ForeignOptsCxx/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/FFI/ForeignOptsCxx/cabal.out @@ -0,0 +1,10 @@ +# cabal v2-build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - foreign-opts-cxx-0.1 (exe:foreign-opts-cxx-exe) (first run) +Configuring executable 'foreign-opts-cxx-exe' for foreign-opts-cxx-0.1.. +Preprocessing executable 'foreign-opts-cxx-exe' for foreign-opts-cxx-0.1.. +Building executable 'foreign-opts-cxx-exe' for foreign-opts-cxx-0.1.. +# foreign-opts-cxx foreign-opts-cxx-exe +The secret is 22 diff --git a/cabal/cabal-testsuite/PackageTests/FFI/ForeignOptsCxx/cabal.project b/cabal/cabal-testsuite/PackageTests/FFI/ForeignOptsCxx/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/FFI/ForeignOptsCxx/cabal.project @@ -0,0 +1,1 @@ +packages: . diff --git a/cabal/cabal-testsuite/PackageTests/FFI/ForeignOptsCxx/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/FFI/ForeignOptsCxx/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/FFI/ForeignOptsCxx/cabal.test.hs @@ -0,0 +1,4 @@ +import Test.Cabal.Prelude +main = cabalTest $ do + cabal "v2-build" ["foreign-opts-cxx-exe"] + withPlan $ runPlanExe "foreign-opts-cxx" "foreign-opts-cxx-exe" [] diff --git a/cabal/cabal-testsuite/PackageTests/FFI/ForeignOptsCxx/cxxbits/cxxlib.cpp b/cabal/cabal-testsuite/PackageTests/FFI/ForeignOptsCxx/cxxbits/cxxlib.cpp new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/FFI/ForeignOptsCxx/cxxbits/cxxlib.cpp @@ -0,0 +1,13 @@ +#include "cxxlib.h" + +#ifdef __TESTOPT_C__ +#error "Got unexpected __TESTOPT_C__ from cc-options" +#endif + +#ifndef __TESTOPT_CXX__ +#error "Did not get required __TESTOPT_CXX__ from cxx-options" +#endif + +int meaning_of_life_cxx() { + return __TESTOPT_CXX__; +} diff --git a/cabal/cabal-testsuite/PackageTests/FFI/ForeignOptsCxx/cxxbits/cxxlib.h b/cabal/cabal-testsuite/PackageTests/FFI/ForeignOptsCxx/cxxbits/cxxlib.h new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/FFI/ForeignOptsCxx/cxxbits/cxxlib.h @@ -0,0 +1,12 @@ +#ifndef CXXLIB_H +#define CXXLIB_H +#ifdef __cplusplus +extern "C" { +#endif + +int meaning_of_life_cxx(); + +#ifdef __cplusplus +} +#endif +#endif diff --git a/cabal/cabal-testsuite/PackageTests/FFI/ForeignOptsCxx/foreign-opts-cxx.cabal b/cabal/cabal-testsuite/PackageTests/FFI/ForeignOptsCxx/foreign-opts-cxx.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/FFI/ForeignOptsCxx/foreign-opts-cxx.cabal @@ -0,0 +1,15 @@ +cabal-version: 2.2 +name: foreign-opts-cxx +version: 0.1 +build-type: Simple + +executable foreign-opts-cxx-exe + main-is: Main.hs + build-depends: base + default-language: Haskell2010 + include-dirs: cxxbits + extra-libraries: stdc++ + cxx-sources: cxxbits/cxxlib.cpp + -- The following options are shared in all ForeignOpts cases: + cc-options: -D__TESTOPT_C__=11 + cxx-options: -D__TESTOPT_CXX__=22 diff --git a/cabal/cabal-testsuite/PackageTests/ForeignLibs/UseLib.c b/cabal/cabal-testsuite/PackageTests/ForeignLibs/UseLib.c --- a/cabal/cabal-testsuite/PackageTests/ForeignLibs/UseLib.c +++ b/cabal/cabal-testsuite/PackageTests/ForeignLibs/UseLib.c @@ -1,4 +1,10 @@ #include +#include + +/* Forward declarations */ +bool myForeignLibInit(); +void myForeignLibExit(); +void sayHi(); int main() { diff --git a/cabal/cabal-testsuite/PackageTests/ForeignLibs/csrc/MyForeignLibWrapper.c b/cabal/cabal-testsuite/PackageTests/ForeignLibs/csrc/MyForeignLibWrapper.c --- a/cabal/cabal-testsuite/PackageTests/ForeignLibs/csrc/MyForeignLibWrapper.c +++ b/cabal/cabal-testsuite/PackageTests/ForeignLibs/csrc/MyForeignLibWrapper.c @@ -1,7 +1,8 @@ #include +#include #include "HsFFI.h" -HsBool myForeignLibInit(void){ +bool myForeignLibInit(void){ int argc = 2; char *argv[] = { "+RTS", "-A32m", NULL }; char **pargv = argv; @@ -11,7 +12,7 @@ // do any other initialization here and // return false if there was a problem - return HS_BOOL_TRUE; + return true; } void myForeignLibExit(void){ diff --git a/cabal/cabal-testsuite/PackageTests/ForeignLibs/my-foreign-lib.cabal b/cabal/cabal-testsuite/PackageTests/ForeignLibs/my-foreign-lib.cabal --- a/cabal/cabal-testsuite/PackageTests/ForeignLibs/my-foreign-lib.cabal +++ b/cabal/cabal-testsuite/PackageTests/ForeignLibs/my-foreign-lib.cabal @@ -20,6 +20,7 @@ other-modules: MyForeignLib.Hello MyForeignLib.SomeBindings + MyForeignLib.AnotherVal build-depends: base, my-foreign-lib hs-source-dirs: src c-sources: csrc/MyForeignLibWrapper.c @@ -34,6 +35,7 @@ other-modules: MyForeignLib.Hello MyForeignLib.SomeBindings + MyForeignLib.AnotherVal build-depends: base, my-foreign-lib hs-source-dirs: src c-sources: csrc/MyForeignLibWrapper.c diff --git a/cabal/cabal-testsuite/PackageTests/ForeignLibs/setup.test.hs b/cabal/cabal-testsuite/PackageTests/ForeignLibs/setup.test.hs --- a/cabal/cabal-testsuite/PackageTests/ForeignLibs/setup.test.hs +++ b/cabal/cabal-testsuite/PackageTests/ForeignLibs/setup.test.hs @@ -24,8 +24,11 @@ -- Recording is turned off because versionedlib will or will not -- be installed depending on if we're on Linux or not. main = setupAndCabalTest . recordMode DoNotRecord $ do - -- Foreign libraries don't work with GHC 7.6 and earlier - skipUnless =<< ghcVersionIs (>= mkVersion [7,8]) + -- Foreign libraries don't work with GHC 7.6 and earlier + skipUnlessGhcVersion ">= 7.8" + osx <- isOSX + ghc80 <- isGhcVersion "== 8.0.2" + expectBrokenIf (osx && ghc80) 7989 $ withPackageDb $ do setup_install [] setup "copy" [] -- regression test #4156 @@ -35,7 +38,8 @@ -- Link a C program against the library _ <- runProgramM gccProgram - [ "-o", "uselib" + [ "-std=c11", "-Wall" + , "-o", "uselib" , "UseLib.c" , "-l", "myforeignlib" , "-L", flibdir installDirs ] diff --git a/cabal/cabal-testsuite/PackageTests/Freeze/disable-benchmarks.out b/cabal/cabal-testsuite/PackageTests/Freeze/disable-benchmarks.out --- a/cabal/cabal-testsuite/PackageTests/Freeze/disable-benchmarks.out +++ b/cabal/cabal-testsuite/PackageTests/Freeze/disable-benchmarks.out @@ -1,4 +1,4 @@ -# cabal v1-update +# cabal v2-update Downloading the latest package list from test-local-repo # cabal v1-freeze Resolving dependencies... diff --git a/cabal/cabal-testsuite/PackageTests/Freeze/disable-tests.out b/cabal/cabal-testsuite/PackageTests/Freeze/disable-tests.out --- a/cabal/cabal-testsuite/PackageTests/Freeze/disable-tests.out +++ b/cabal/cabal-testsuite/PackageTests/Freeze/disable-tests.out @@ -1,4 +1,4 @@ -# cabal v1-update +# cabal v2-update Downloading the latest package list from test-local-repo # cabal v1-freeze Resolving dependencies... diff --git a/cabal/cabal-testsuite/PackageTests/Freeze/dry-run.out b/cabal/cabal-testsuite/PackageTests/Freeze/dry-run.out --- a/cabal/cabal-testsuite/PackageTests/Freeze/dry-run.out +++ b/cabal/cabal-testsuite/PackageTests/Freeze/dry-run.out @@ -1,2 +1,2 @@ -# cabal v1-update +# cabal v2-update Downloading the latest package list from test-local-repo diff --git a/cabal/cabal-testsuite/PackageTests/Freeze/enable-benchmarks.out b/cabal/cabal-testsuite/PackageTests/Freeze/enable-benchmarks.out --- a/cabal/cabal-testsuite/PackageTests/Freeze/enable-benchmarks.out +++ b/cabal/cabal-testsuite/PackageTests/Freeze/enable-benchmarks.out @@ -1,4 +1,4 @@ -# cabal v1-update +# cabal v2-update Downloading the latest package list from test-local-repo # cabal v1-freeze Resolving dependencies... diff --git a/cabal/cabal-testsuite/PackageTests/Freeze/enable-tests.out b/cabal/cabal-testsuite/PackageTests/Freeze/enable-tests.out --- a/cabal/cabal-testsuite/PackageTests/Freeze/enable-tests.out +++ b/cabal/cabal-testsuite/PackageTests/Freeze/enable-tests.out @@ -1,4 +1,4 @@ -# cabal v1-update +# cabal v2-update Downloading the latest package list from test-local-repo # cabal v1-freeze Resolving dependencies... diff --git a/cabal/cabal-testsuite/PackageTests/Freeze/freeze.out b/cabal/cabal-testsuite/PackageTests/Freeze/freeze.out --- a/cabal/cabal-testsuite/PackageTests/Freeze/freeze.out +++ b/cabal/cabal-testsuite/PackageTests/Freeze/freeze.out @@ -1,4 +1,4 @@ -# cabal v1-update +# cabal v2-update Downloading the latest package list from test-local-repo # cabal v1-freeze Resolving dependencies... diff --git a/cabal/cabal-testsuite/PackageTests/GHCJS/BuildRunner/BuildRunner.cabal b/cabal/cabal-testsuite/PackageTests/GHCJS/BuildRunner/BuildRunner.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/GHCJS/BuildRunner/BuildRunner.cabal @@ -0,0 +1,21 @@ +name: BuildRunner +version: 1.0 +build-type: Simple +cabal-version: >= 1.10 + +test-suite ghcjs-test + type: exitcode-stdio-1.0 + main-is: BuildRunner.hs + build-depends: base + default-language: Haskell2010 + +executable ghcjs-exe + main-is: BuildRunner.hs + build-depends: base + default-language: Haskell2010 + +benchmark ghcjs-bench + type: exitcode-stdio-1.0 + main-is: BuildRunner.hs + build-depends: base + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/GHCJS/BuildRunner/BuildRunner.hs b/cabal/cabal-testsuite/PackageTests/GHCJS/BuildRunner/BuildRunner.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/GHCJS/BuildRunner/BuildRunner.hs @@ -0,0 +1,7 @@ +module Main where + +import System.Exit (exitSuccess) + +main :: IO () +main = do + exitSuccess diff --git a/cabal/cabal-testsuite/PackageTests/GHCJS/BuildRunner/README.md b/cabal/cabal-testsuite/PackageTests/GHCJS/BuildRunner/README.md new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/GHCJS/BuildRunner/README.md @@ -0,0 +1,6 @@ +This test verifies that the `-build-runner` option is passed to GHCJS when the cabal commands `test`/`run`/`bench` are run with the `--ghcjs` option. + +This test was created in order to avoid regressions in running GHCJS executables, e.g.: + +* https://github.com/haskell/cabal/issues/6175 +* https://github.com/haskell/cabal/issues/6361 diff --git a/cabal/cabal-testsuite/PackageTests/GHCJS/BuildRunner/cabal.project b/cabal/cabal-testsuite/PackageTests/GHCJS/BuildRunner/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/GHCJS/BuildRunner/cabal.project @@ -0,0 +1,1 @@ +packages: . diff --git a/cabal/cabal-testsuite/PackageTests/GHCJS/BuildRunner/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/GHCJS/BuildRunner/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/GHCJS/BuildRunner/cabal.test.hs @@ -0,0 +1,19 @@ +import Test.Cabal.Prelude + +main = cabalTest . recordMode DoNotRecord $ do + skipIfWindows -- disabled because (I presume) Windows doesn't have BASH + cwd <- fmap testCurrentDir getTestEnv + testInvokedWithBuildRunner cwd "test" [] + testInvokedWithBuildRunner cwd "run" ["ghcjs-exe"] + testInvokedWithBuildRunner cwd "bench" [] + +magicString = "SUCCESS! GHCJS was invoked with '-build-runner' option" + +testInvokedWithBuildRunner cwd cabalCmd extraArgs = do + output <- fails $ cabal' cabalCmd $ extraArgs ++ + [ "--ghcjs" + , "--with-compiler", cwd fakeGhcjsPath + ] + assertOutputContains magicString output + where + fakeGhcjsPath = "scripts/fake-ghcjs.sh" diff --git a/cabal/cabal-testsuite/PackageTests/GHCJS/BuildRunner/scripts/fake-ghcjs.sh b/cabal/cabal-testsuite/PackageTests/GHCJS/BuildRunner/scripts/fake-ghcjs.sh new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/GHCJS/BuildRunner/scripts/fake-ghcjs.sh @@ -0,0 +1,20 @@ +#!/usr/bin/env bash + +# A script that will print out $MAGIC_STRING when invoked with the +# '-build-runner' option. +# +# When cabal is invoked with the '--ghcjs' option and the '--with-compiler' +# option set to the path of this script, cabal will successfully get to the linking +# stage (where it *should* call this script with the '-build-runner' option). + +MAGIC_STRING="SUCCESS! GHCJS was invoked with '-build-runner' option" + +if [ "$1" == "--numeric-ghcjs-version" ]; then + ghc --numeric-version +elif [ "$1" == "--numeric-ghc-version" ]; then + ghc --numeric-version +elif [[ "$*" == *-build-runner* ]]; then + echo "$MAGIC_STRING" +else + ghc "$@" +fi diff --git a/cabal/cabal-testsuite/PackageTests/GHCJS/BuildRunner/scripts/ghcjs-pkg b/cabal/cabal-testsuite/PackageTests/GHCJS/BuildRunner/scripts/ghcjs-pkg new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/GHCJS/BuildRunner/scripts/ghcjs-pkg @@ -0,0 +1,9 @@ +#!/usr/bin/env bash + +if [ "$1" == "--numeric-ghcjs-version" ]; then + ghc --numeric-version +elif [ "$1" == "--numeric-ghc-version" ]; then + ghc --numeric-version +else + ghc-pkg "$@" +fi diff --git a/cabal/cabal-testsuite/PackageTests/Get/T7248/cabal.config b/cabal/cabal-testsuite/PackageTests/Get/T7248/cabal.config new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Get/T7248/cabal.config @@ -0,0 +1,4 @@ +-- This config file contains a bogus repository by intention. + +repository repo.invalid + url: http://repo.invalid/ diff --git a/cabal/cabal-testsuite/PackageTests/Get/T7248/cabal.out b/cabal/cabal-testsuite/PackageTests/Get/T7248/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Get/T7248/cabal.out @@ -0,0 +1,5 @@ +# cabal get +Warning: /cabal.config: Unrecognized stanza on line 3 +Warning: The package list for 'repo.invalid' does not exist. Run 'cabal update' to download it. +Error: cabal: There is no package named 'a-b-s-e-n-t'. +You may need to run 'cabal update' to get the latest list of available packages. diff --git a/cabal/cabal-testsuite/PackageTests/Get/T7248/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/Get/T7248/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Get/T7248/cabal.test.hs @@ -0,0 +1,15 @@ +-- 2021-10-06, issue #7248 +-- +-- Purpose of this test: +-- Make sure that ordinary user communication does not contain 'Show'ed internal structures. +-- +-- This is a golden value test that reports the produced error message. +-- Needs to be checked manually whether it meets expectations. + +import Test.Cabal.Prelude +main = cabalTest $ + fails $ + cabalG + [ "--config-file", "cabal.config" ] + "get" + [ "a-b-s-e-n-t" ] diff --git a/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectory/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectory/setup.cabal.out --- a/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectory/setup.cabal.out +++ b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectory/setup.cabal.out @@ -1,3 +1,3 @@ # Setup configure Configuring SameDirectory-0.1.0.0... -cabal: Version mismatch between ghc and ghc-pkg: /./ghc is version /./ghc-pkg is version 9999999 +Error: cabal: Version mismatch between ghc and ghc-pkg: /./ghc is version /ghc-pkg is version 9999999 diff --git a/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectory/setup.out b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectory/setup.out --- a/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectory/setup.out +++ b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectory/setup.out @@ -1,3 +1,3 @@ # Setup configure Configuring SameDirectory-0.1.0.0... -setup: Version mismatch between ghc and ghc-pkg: /./ghc is version /./ghc-pkg is version 9999999 +Error: setup: Version mismatch between ghc and ghc-pkg: /./ghc is version /ghc-pkg is version 9999999 diff --git a/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectory/setup.test.hs b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectory/setup.test.hs --- a/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectory/setup.test.hs +++ b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectory/setup.test.hs @@ -1,7 +1,7 @@ import Test.Cabal.Prelude -- TODO: Enable this test on Windows main = setupAndCabalTest $ do - skipIf =<< isWindows + skipIfWindows env <- getTestEnv let cwd = testCurrentDir env ghc_path <- programPathM ghcProgram diff --git a/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryGhcVersion/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryGhcVersion/setup.cabal.out --- a/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryGhcVersion/setup.cabal.out +++ b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryGhcVersion/setup.cabal.out @@ -1,3 +1,3 @@ # Setup configure Configuring SameDirectory-0.1.0.0... -cabal: Version mismatch between ghc and ghc-pkg: /./ghc-7.10 is version /./ghc-pkg-ghc-7.10 is version 9999999 +Error: cabal: Version mismatch between ghc and ghc-pkg: /./ghc-7.10 is version /ghc-pkg-ghc-7.10 is version 9999999 diff --git a/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryGhcVersion/setup.out b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryGhcVersion/setup.out --- a/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryGhcVersion/setup.out +++ b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryGhcVersion/setup.out @@ -1,3 +1,3 @@ # Setup configure Configuring SameDirectory-0.1.0.0... -setup: Version mismatch between ghc and ghc-pkg: /./ghc-7.10 is version /./ghc-pkg-ghc-7.10 is version 9999999 +Error: setup: Version mismatch between ghc and ghc-pkg: /./ghc-7.10 is version /ghc-pkg-ghc-7.10 is version 9999999 diff --git a/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryGhcVersion/setup.test.hs b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryGhcVersion/setup.test.hs --- a/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryGhcVersion/setup.test.hs +++ b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryGhcVersion/setup.test.hs @@ -1,7 +1,7 @@ import Test.Cabal.Prelude -- TODO: Enable this test on Windows main = setupAndCabalTest $ do - skipIf =<< isWindows + skipIfWindows env <- getTestEnv let cwd = testCurrentDir env ghc_path <- programPathM ghcProgram diff --git a/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryVersion/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryVersion/setup.cabal.out --- a/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryVersion/setup.cabal.out +++ b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryVersion/setup.cabal.out @@ -1,3 +1,3 @@ # Setup configure Configuring SameDirectory-0.1.0.0... -cabal: Version mismatch between ghc and ghc-pkg: /./ghc-7.10 is version /./ghc-pkg-7.10 is version 9999999 +Error: cabal: Version mismatch between ghc and ghc-pkg: /./ghc-7.10 is version /ghc-pkg-7.10 is version 9999999 diff --git a/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryVersion/setup.out b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryVersion/setup.out --- a/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryVersion/setup.out +++ b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryVersion/setup.out @@ -1,3 +1,3 @@ # Setup configure Configuring SameDirectory-0.1.0.0... -setup: Version mismatch between ghc and ghc-pkg: /./ghc-7.10 is version /./ghc-pkg-7.10 is version 9999999 +Error: setup: Version mismatch between ghc and ghc-pkg: /./ghc-7.10 is version /ghc-pkg-7.10 is version 9999999 diff --git a/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryVersion/setup.test.hs b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryVersion/setup.test.hs --- a/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryVersion/setup.test.hs +++ b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryVersion/setup.test.hs @@ -1,7 +1,7 @@ import Test.Cabal.Prelude -- TODO: Enable this test on Windows main = setupAndCabalTest $ do - skipIf =<< isWindows + skipIfWindows env <- getTestEnv let cwd = testCurrentDir env ghc_path <- programPathM ghcProgram diff --git a/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/Symlink/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/Symlink/setup.cabal.out --- a/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/Symlink/setup.cabal.out +++ b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/Symlink/setup.cabal.out @@ -1,3 +1,3 @@ # Setup configure Configuring SameDirectory-0.1.0.0... -cabal: Version mismatch between ghc and ghc-pkg: /./ghc is version /bin/ghc-pkg is version 9999999 +Error: cabal: Version mismatch between ghc and ghc-pkg: /./ghc is version /bin/ghc-pkg is version 9999999 diff --git a/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/Symlink/setup.out b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/Symlink/setup.out --- a/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/Symlink/setup.out +++ b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/Symlink/setup.out @@ -1,3 +1,3 @@ # Setup configure Configuring SameDirectory-0.1.0.0... -setup: Version mismatch between ghc and ghc-pkg: /./ghc is version /bin/ghc-pkg is version 9999999 +Error: setup: Version mismatch between ghc and ghc-pkg: /./ghc is version /bin/ghc-pkg is version 9999999 diff --git a/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/Symlink/setup.test.hs b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/Symlink/setup.test.hs --- a/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/Symlink/setup.test.hs +++ b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/Symlink/setup.test.hs @@ -1,7 +1,7 @@ import Test.Cabal.Prelude -- TODO: Enable this test on Windows main = setupAndCabalTest $ do - skipIf =<< isWindows + skipIfWindows withSymlink "bin/ghc" "ghc" $ do env <- getTestEnv let cwd = testCurrentDir env diff --git a/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkGhcVersion/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkGhcVersion/setup.cabal.out --- a/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkGhcVersion/setup.cabal.out +++ b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkGhcVersion/setup.cabal.out @@ -1,3 +1,3 @@ # Setup configure Configuring SameDirectory-0.1.0.0... -cabal: Version mismatch between ghc and ghc-pkg: /./ghc is version /bin/ghc-pkg-7.10 is version 9999999 +Error: cabal: Version mismatch between ghc and ghc-pkg: /./ghc is version /bin/ghc-pkg-7.10 is version 9999999 diff --git a/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkGhcVersion/setup.out b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkGhcVersion/setup.out --- a/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkGhcVersion/setup.out +++ b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkGhcVersion/setup.out @@ -1,3 +1,3 @@ # Setup configure Configuring SameDirectory-0.1.0.0... -setup: Version mismatch between ghc and ghc-pkg: /./ghc is version /bin/ghc-pkg-7.10 is version 9999999 +Error: setup: Version mismatch between ghc and ghc-pkg: /./ghc is version /bin/ghc-pkg-7.10 is version 9999999 diff --git a/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkGhcVersion/setup.test.hs b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkGhcVersion/setup.test.hs --- a/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkGhcVersion/setup.test.hs +++ b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkGhcVersion/setup.test.hs @@ -1,7 +1,7 @@ import Test.Cabal.Prelude -- TODO: Enable this test on Windows main = setupAndCabalTest $ do - skipIf =<< isWindows + skipIfWindows withSymlink "bin/ghc-7.10" "ghc" $ do env <- getTestEnv let cwd = testCurrentDir env diff --git a/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkVersion/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkVersion/setup.cabal.out --- a/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkVersion/setup.cabal.out +++ b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkVersion/setup.cabal.out @@ -1,3 +1,3 @@ # Setup configure Configuring SameDirectory-0.1.0.0... -cabal: Version mismatch between ghc and ghc-pkg: /./ghc is version /bin/ghc-pkg-ghc-7.10 is version 9999999 +Error: cabal: Version mismatch between ghc and ghc-pkg: /./ghc is version /bin/ghc-pkg-ghc-7.10 is version 9999999 diff --git a/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkVersion/setup.out b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkVersion/setup.out --- a/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkVersion/setup.out +++ b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkVersion/setup.out @@ -1,3 +1,3 @@ # Setup configure Configuring SameDirectory-0.1.0.0... -setup: Version mismatch between ghc and ghc-pkg: /./ghc is version /bin/ghc-pkg-ghc-7.10 is version 9999999 +Error: setup: Version mismatch between ghc and ghc-pkg: /./ghc is version /bin/ghc-pkg-ghc-7.10 is version 9999999 diff --git a/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkVersion/setup.test.hs b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkVersion/setup.test.hs --- a/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkVersion/setup.test.hs +++ b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkVersion/setup.test.hs @@ -1,7 +1,7 @@ import Test.Cabal.Prelude -- TODO: Enable this test on Windows main = setupAndCabalTest $ do - skipIf =<< isWindows + skipIfWindows withSymlink "bin/ghc-7.10" "ghc" $ do env <- getTestEnv let cwd = testCurrentDir env diff --git a/cabal/cabal-testsuite/PackageTests/HaddockArgs/cabal.project b/cabal/cabal-testsuite/PackageTests/HaddockArgs/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/HaddockArgs/cabal.project @@ -0,0 +1,1 @@ +packages: . diff --git a/cabal/cabal-testsuite/PackageTests/HaddockArgs/example.cabal b/cabal/cabal-testsuite/PackageTests/HaddockArgs/example.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/HaddockArgs/example.cabal @@ -0,0 +1,12 @@ +name: example +version: 1.0 +build-type: Simple +cabal-version: >= 1.10 + + +library + hs-source-dirs: src + exposed-modules: Lib + build-depends: base, indef + default-language: Haskell2010 + diff --git a/cabal/cabal-testsuite/PackageTests/HaddockArgs/hoogle.out b/cabal/cabal-testsuite/PackageTests/HaddockArgs/hoogle.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/HaddockArgs/hoogle.out @@ -0,0 +1,35 @@ +# cabal v2-update +Downloading the latest package list from test-local-repo +# cabal v2-build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - sigs-0.1.0.0 (lib) (requires build) + - indef-0.1.0.0 (lib) (requires build) + - example-1.0 (lib) (first run) +Configuring library for sigs-0.1.0.0.. +Preprocessing library for sigs-0.1.0.0.. +Building library instantiated with Data.Map = +for sigs-0.1.0.0.. +Preprocessing library for sigs-0.1.0.0.. +Running Haddock on library instantiated with Data.Map = +for sigs-0.1.0.0.. +Documentation created: dist/doc/html/sigs/sigs.txt +Installing library in +Configuring library for indef-0.1.0.0.. +Preprocessing library for indef-0.1.0.0.. +Building library instantiated with Data.Map = +for indef-0.1.0.0.. +Preprocessing library for indef-0.1.0.0.. +Running Haddock on library instantiated with Data.Map = +for indef-0.1.0.0.. +Documentation created: dist/doc/html/indef/indef.txt +Installing library in +Configuring library for example-1.0.. +Preprocessing library for example-1.0.. +Building library instantiated with Data.Map = +for example-1.0.. +Preprocessing library for example-1.0.. +Running Haddock on library instantiated with Data.Map = +for example-1.0.. +Documentation created: /hoogle.dist/work/dist/build//ghc-/example-1.0/doc/html/example/example.txt diff --git a/cabal/cabal-testsuite/PackageTests/HaddockArgs/hoogle.test.hs b/cabal/cabal-testsuite/PackageTests/HaddockArgs/hoogle.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/HaddockArgs/hoogle.test.hs @@ -0,0 +1,11 @@ +import Test.Cabal.Prelude + +main = withShorterPathForNewBuildStore $ \storeDir -> cabalTest $ withRepo "repo" $ do + -- Checks if hoogle txt files are generated. + -- Logs contain something like "Documentation created: dist/doc/html/indef/indef.txt", so we don't need + -- to do extra check + cabalG ["--store-dir=" ++ storeDir] "v2-build" + [ "example" + , "--enable-documentation" + , "--haddock-hoogle" + ] diff --git a/cabal/cabal-testsuite/PackageTests/HaddockArgs/quickjump.out b/cabal/cabal-testsuite/PackageTests/HaddockArgs/quickjump.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/HaddockArgs/quickjump.out @@ -0,0 +1,35 @@ +# cabal v2-update +Downloading the latest package list from test-local-repo +# cabal v2-build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - sigs-0.1.0.0 (lib) (requires build) + - indef-0.1.0.0 (lib) (requires build) + - example-1.0 (lib) (first run) +Configuring library for sigs-0.1.0.0.. +Preprocessing library for sigs-0.1.0.0.. +Building library instantiated with Data.Map = +for sigs-0.1.0.0.. +Preprocessing library for sigs-0.1.0.0.. +Running Haddock on library instantiated with Data.Map = +for sigs-0.1.0.0.. +Documentation created: dist/doc/html/sigs/index.html +Installing library in +Configuring library for indef-0.1.0.0.. +Preprocessing library for indef-0.1.0.0.. +Building library instantiated with Data.Map = +for indef-0.1.0.0.. +Preprocessing library for indef-0.1.0.0.. +Running Haddock on library instantiated with Data.Map = +for indef-0.1.0.0.. +Documentation created: dist/doc/html/indef/index.html +Installing library in +Configuring library for example-1.0.. +Preprocessing library for example-1.0.. +Building library instantiated with Data.Map = +for example-1.0.. +Preprocessing library for example-1.0.. +Running Haddock on library instantiated with Data.Map = +for example-1.0.. +Documentation created: /quickjump.dist/work/dist/build//ghc-/example-1.0/doc/html/example/index.html diff --git a/cabal/cabal-testsuite/PackageTests/HaddockArgs/quickjump.test.hs b/cabal/cabal-testsuite/PackageTests/HaddockArgs/quickjump.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/HaddockArgs/quickjump.test.hs @@ -0,0 +1,16 @@ +import Test.Cabal.Prelude + +import System.Directory +import System.FilePath + +main = withShorterPathForNewBuildStore $ \storeDir -> cabalTest $ withRepo "repo" $ do + cabalG ["--store-dir=" ++ storeDir] "v2-build" + [ "example" + , "--enable-documentation" + , "--haddock-quickjump" + ] + liftIO $ do + libDir <- findDependencyInStore storeDir "indef" + assertFileDoesContain (libDir "cabal-hash.txt") "haddock-quickjump: True" + docIndexJsonExists <- doesFileExist (libDir "share" "doc" "html" "doc-index.json") + assertBool "doc-index.json doesn't exist, --quickjump is probably not passed to haddock" docIndexJsonExists diff --git a/cabal/cabal-testsuite/PackageTests/HaddockArgs/repo/exe-0.1.0.0/Main.hs b/cabal/cabal-testsuite/PackageTests/HaddockArgs/repo/exe-0.1.0.0/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/HaddockArgs/repo/exe-0.1.0.0/Main.hs @@ -0,0 +1,4 @@ +import qualified Data.Map as Map +import Data.Map (Map) +import Foo +main = print $ f (+1) (Map.fromList [(0,1),(2,3)] :: Map Int Int) diff --git a/cabal/cabal-testsuite/PackageTests/HaddockArgs/repo/exe-0.1.0.0/exe.cabal b/cabal/cabal-testsuite/PackageTests/HaddockArgs/repo/exe-0.1.0.0/exe.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/HaddockArgs/repo/exe-0.1.0.0/exe.cabal @@ -0,0 +1,12 @@ +name: exe +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: 2.0 + +executable exe + build-depends: base, containers, indef + main-is: Main.hs + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/HaddockArgs/repo/indef-0.1.0.0/Foo.hs b/cabal/cabal-testsuite/PackageTests/HaddockArgs/repo/indef-0.1.0.0/Foo.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/HaddockArgs/repo/indef-0.1.0.0/Foo.hs @@ -0,0 +1,7 @@ +module Foo where + +import Data.Map + +-- | A dummy function using 'Map' +f :: (a -> b) -> Map k a -> Map k b +f = fmap diff --git a/cabal/cabal-testsuite/PackageTests/HaddockArgs/repo/indef-0.1.0.0/indef.cabal b/cabal/cabal-testsuite/PackageTests/HaddockArgs/repo/indef-0.1.0.0/indef.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/HaddockArgs/repo/indef-0.1.0.0/indef.cabal @@ -0,0 +1,12 @@ +name: indef +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: 2.0 + +library + build-depends: base, sigs + exposed-modules: Foo + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/HaddockArgs/repo/sigs-0.1.0.0/Data/Map.hsig b/cabal/cabal-testsuite/PackageTests/HaddockArgs/repo/sigs-0.1.0.0/Data/Map.hsig new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/HaddockArgs/repo/sigs-0.1.0.0/Data/Map.hsig @@ -0,0 +1,5 @@ +{-# LANGUAGE RoleAnnotations #-} +signature Data.Map where +type role Map nominal representational +data Map k a +instance Functor (Map k) diff --git a/cabal/cabal-testsuite/PackageTests/HaddockArgs/repo/sigs-0.1.0.0/sigs.cabal b/cabal/cabal-testsuite/PackageTests/HaddockArgs/repo/sigs-0.1.0.0/sigs.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/HaddockArgs/repo/sigs-0.1.0.0/sigs.cabal @@ -0,0 +1,12 @@ +name: sigs +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: 2.0 + +library + build-depends: base + signatures: Data.Map + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/HaddockArgs/src/Lib.hs b/cabal/cabal-testsuite/PackageTests/HaddockArgs/src/Lib.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/HaddockArgs/src/Lib.hs @@ -0,0 +1,7 @@ +module Lib where + +import Foo + +-- | See 'f' +main :: IO () +main = putStrLn "Hello, Haskell!" diff --git a/cabal/cabal-testsuite/PackageTests/HaddockWarn/Main.hs b/cabal/cabal-testsuite/PackageTests/HaddockWarn/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/HaddockWarn/Main.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = putStrLn "Hello, Haskell!" diff --git a/cabal/cabal-testsuite/PackageTests/HaddockWarn/cabal.out b/cabal/cabal-testsuite/PackageTests/HaddockWarn/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/HaddockWarn/cabal.out @@ -0,0 +1,3 @@ +# cabal v2-haddock +Resolving dependencies... +No documentation was generated as this package does not contain a library. Perhaps you want to use the --haddock-all flag, or one or more of the --haddock-executables, --haddock-tests, --haddock-benchmarks or --haddock-internal flags. diff --git a/cabal/cabal-testsuite/PackageTests/HaddockWarn/cabal.project b/cabal/cabal-testsuite/PackageTests/HaddockWarn/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/HaddockWarn/cabal.project @@ -0,0 +1,1 @@ +packages: . diff --git a/cabal/cabal-testsuite/PackageTests/HaddockWarn/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/HaddockWarn/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/HaddockWarn/cabal.test.hs @@ -0,0 +1,4 @@ +import Test.Cabal.Prelude +import System.Exit (ExitCode (..)) + +main = cabalTest $ cabal "v2-haddock" [] diff --git a/cabal/cabal-testsuite/PackageTests/HaddockWarn/example.cabal b/cabal/cabal-testsuite/PackageTests/HaddockWarn/example.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/HaddockWarn/example.cabal @@ -0,0 +1,11 @@ +name: example +version: 1.0 +build-type: Simple +cabal-version: >= 1.10 + + +executable example + main-is: Main.hs + build-depends: base + default-language: Haskell2010 + diff --git a/cabal/cabal-testsuite/PackageTests/Init/app/Main.hs b/cabal/cabal-testsuite/PackageTests/Init/app/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Init/app/Main.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = putStrLn "This should remain as is!" diff --git a/cabal/cabal-testsuite/PackageTests/Init/init-backup.out b/cabal/cabal-testsuite/PackageTests/Init/init-backup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Init/init-backup.out @@ -0,0 +1,6 @@ +# cabal init +# Setup configure +Configuring app-0.1.0.0... +# Setup build +Preprocessing executable 'app' for app-0.1.0.0.. +Building executable 'app' for app-0.1.0.0.. diff --git a/cabal/cabal-testsuite/PackageTests/Init/init-backup.test.hs b/cabal/cabal-testsuite/PackageTests/Init/init-backup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Init/init-backup.test.hs @@ -0,0 +1,20 @@ +import Test.Cabal.Prelude + +main = cabalTest $ + withSourceCopyDir "app" $ do + cwd <- fmap testSourceCopyDir getTestEnv + + (initOut, buildOut) <- withDirectory cwd $ do + initOut <- cabalWithStdin "init" ["-i"] + "2\ny\n5\n\n\n2\n\n\n\n\n\n\n\n\n\n" + setup "configure" [] + buildOut <- setup' "build" ["app"] + return (initOut, buildOut) + + assertFileDoesContain (cwd "app.cabal") "3.0" + assertFileDoesContain (cwd "app.cabal") "BSD-3-Clause" + assertFileDoesContain (cwd "app.cabal") "Simple" + shouldDirectoryExist (cwd "app.save0") + assertOutputContains "Backing up old version in app.save0" initOut + assertOutputContains "Overwriting directory ./app" initOut + assertOutputContains "Linking" buildOut diff --git a/cabal/cabal-testsuite/PackageTests/Init/init-interactive-ghc2021.out b/cabal/cabal-testsuite/PackageTests/Init/init-interactive-ghc2021.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Init/init-interactive-ghc2021.out @@ -0,0 +1,1 @@ +# cabal init diff --git a/cabal/cabal-testsuite/PackageTests/Init/init-interactive-ghc2021.test.hs b/cabal/cabal-testsuite/PackageTests/Init/init-interactive-ghc2021.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Init/init-interactive-ghc2021.test.hs @@ -0,0 +1,11 @@ +import Test.Cabal.Prelude + +main = cabalTest $ + withSourceCopyDir "app" $ do + cwd <- fmap testSourceCopyDir getTestEnv + + buildOut <- withDirectory cwd $ do + cabalWithStdin "init" ["-i"] + "2\n\n5\n\n\n2\n\n\n\n\n\n\n\n3\n\n" + + assertFileDoesContain (cwd "app.cabal") "GHC2021" diff --git a/cabal/cabal-testsuite/PackageTests/Init/init-interactive-legacy.out b/cabal/cabal-testsuite/PackageTests/Init/init-interactive-legacy.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Init/init-interactive-legacy.out @@ -0,0 +1,6 @@ +# cabal init +# Setup configure +Configuring app-0.1.0.0... +# Setup build +Preprocessing executable 'app' for app-0.1.0.0.. +Building executable 'app' for app-0.1.0.0.. diff --git a/cabal/cabal-testsuite/PackageTests/Init/init-interactive-legacy.test.hs b/cabal/cabal-testsuite/PackageTests/Init/init-interactive-legacy.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Init/init-interactive-legacy.test.hs @@ -0,0 +1,18 @@ +import Test.Cabal.Prelude + +main = cabalTest $ + withSourceCopyDir "app" $ do + cwd <- fmap testSourceCopyDir getTestEnv + + buildOut <- withDirectory cwd $ do + cabalWithStdin "init" ["-i"] + "2\n\n1\n\n\n10\n\n\n\n\n\n\n\n\n\n" + setup "configure" [] + setup' "build" ["app"] + + assertFileDoesContain (cwd "app.cabal") "1.24" + assertFileDoesContain (cwd "app.cabal") "BSD3" + assertFileDoesContain (cwd "app.cabal") "Simple" + assertFileDoesNotContain (cwd "app.cabal") "^>=" + assertFileDoesContain (cwd "app/Main.hs") "This should remain as is!" + assertOutputContains "Linking" buildOut diff --git a/cabal/cabal-testsuite/PackageTests/Init/init-interactive.out b/cabal/cabal-testsuite/PackageTests/Init/init-interactive.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Init/init-interactive.out @@ -0,0 +1,6 @@ +# cabal init +# Setup configure +Configuring app-0.1.0.0... +# Setup build +Preprocessing executable 'app' for app-0.1.0.0.. +Building executable 'app' for app-0.1.0.0.. diff --git a/cabal/cabal-testsuite/PackageTests/Init/init-interactive.test.hs b/cabal/cabal-testsuite/PackageTests/Init/init-interactive.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Init/init-interactive.test.hs @@ -0,0 +1,17 @@ +import Test.Cabal.Prelude + +main = cabalTest $ + withSourceCopyDir "app" $ do + cwd <- fmap testSourceCopyDir getTestEnv + + buildOut <- withDirectory cwd $ do + cabalWithStdin "init" ["-i"] + "2\n\n5\n\n\n2\n\n\n\n\n\n\n\n\n\n" + setup "configure" [] + setup' "build" ["app"] + + assertFileDoesContain (cwd "app.cabal") "3.0" + assertFileDoesContain (cwd "app.cabal") "BSD-3-Clause" + assertFileDoesContain (cwd "app.cabal") "Simple" + assertFileDoesContain (cwd "app/Main.hs") "This should remain as is!" + assertOutputContains "Linking" buildOut diff --git a/cabal/cabal-testsuite/PackageTests/Init/init-legacy.out b/cabal/cabal-testsuite/PackageTests/Init/init-legacy.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Init/init-legacy.out @@ -0,0 +1,6 @@ +# cabal init +# Setup configure +Configuring app-0.1.0.0... +# Setup build +Preprocessing executable 'app' for app-0.1.0.0.. +Building executable 'app' for app-0.1.0.0.. diff --git a/cabal/cabal-testsuite/PackageTests/Init/init-legacy.test.hs b/cabal/cabal-testsuite/PackageTests/Init/init-legacy.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Init/init-legacy.test.hs @@ -0,0 +1,16 @@ +import Test.Cabal.Prelude + +main = cabalTest $ + withSourceCopyDir "app" $ do + cwd <- fmap testSourceCopyDir getTestEnv + + buildOut <- withDirectory cwd $ do + cabal "init" ["-n", "--exe", "--application-dir=app", "--main-is=Main.hs", "--cabal-version=1.24"] + setup "configure" [] + setup' "build" ["app"] + + assertFileDoesContain (cwd "app.cabal") "1.24" + assertFileDoesContain (cwd "app.cabal") "Simple" + assertFileDoesNotContain (cwd "app.cabal") "^>=" + assertFileDoesContain (cwd "app/Main.hs") "This should remain as is!" + assertOutputContains "Linking" buildOut diff --git a/cabal/cabal-testsuite/PackageTests/Init/init.out b/cabal/cabal-testsuite/PackageTests/Init/init.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Init/init.out @@ -0,0 +1,6 @@ +# cabal init +# Setup configure +Configuring app-0.1.0.0... +# Setup build +Preprocessing executable 'app' for app-0.1.0.0.. +Building executable 'app' for app-0.1.0.0.. diff --git a/cabal/cabal-testsuite/PackageTests/Init/init.test.hs b/cabal/cabal-testsuite/PackageTests/Init/init.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Init/init.test.hs @@ -0,0 +1,15 @@ +import Test.Cabal.Prelude + +main = cabalTest $ + withSourceCopyDir "app" $ do + cwd <- fmap testSourceCopyDir getTestEnv + + buildOut <- withDirectory cwd $ do + cabal "init" ["-n", "--exe", "--application-dir=app", "--main-is=Main.hs"] + setup "configure" [] + setup' "build" ["app"] + + assertFileDoesContain (cwd "app.cabal") "Simple" + assertFileDoesContain (cwd "app.cabal") "base ^>=" + assertFileDoesContain (cwd "app/Main.hs") "This should remain as is!" + assertOutputContains "Linking" buildOut diff --git a/cabal/cabal-testsuite/PackageTests/InternalLibraries/Executable/setup-static.test.hs b/cabal/cabal-testsuite/PackageTests/InternalLibraries/Executable/setup-static.test.hs --- a/cabal/cabal-testsuite/PackageTests/InternalLibraries/Executable/setup-static.test.hs +++ b/cabal/cabal-testsuite/PackageTests/InternalLibraries/Executable/setup-static.test.hs @@ -18,7 +18,7 @@ -- this does build shared libraries just to make sure they -- don't get installed, so this test doesn't work on Windows.) main = setupAndCabalTest $ do - skipUnless =<< hasSharedLibraries + skipUnless "no shared libs" =<< hasSharedLibraries withPackageDb $ do -- MULTI forM_ [False, True] $ \is_dynamic -> do diff --git a/cabal/cabal-testsuite/PackageTests/InternalLibraries/Haddock/Foo.hs b/cabal/cabal-testsuite/PackageTests/InternalLibraries/Haddock/Foo.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalLibraries/Haddock/Foo.hs @@ -0,0 +1,6 @@ +module Foo where + +import InternalBefore + +foo :: Int +foo = internalBefore diff --git a/cabal/cabal-testsuite/PackageTests/InternalLibraries/Haddock/InternalAfter.hs b/cabal/cabal-testsuite/PackageTests/InternalLibraries/Haddock/InternalAfter.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalLibraries/Haddock/InternalAfter.hs @@ -0,0 +1,6 @@ +module InternalAfter where + +import Foo + +internalAfter :: Int +internalAfter = foo diff --git a/cabal/cabal-testsuite/PackageTests/InternalLibraries/Haddock/InternalBefore.hs b/cabal/cabal-testsuite/PackageTests/InternalLibraries/Haddock/InternalBefore.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalLibraries/Haddock/InternalBefore.hs @@ -0,0 +1,4 @@ +module InternalBefore where + +internalBefore :: Int +internalBefore = 42 diff --git a/cabal/cabal-testsuite/PackageTests/InternalLibraries/Haddock/foo.cabal b/cabal/cabal-testsuite/PackageTests/InternalLibraries/Haddock/foo.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalLibraries/Haddock/foo.cabal @@ -0,0 +1,19 @@ +name: foo +version: 0.1.0.0 +build-type: Simple +cabal-version: 1.24 + +library foo-internal-before + build-depends: base + exposed-modules: InternalBefore + default-language: Haskell2010 + +library + build-depends: base, foo-internal-before + exposed-modules: Foo + default-language: Haskell2010 + +library foo-internal-after + build-depends: base, foo + exposed-modules: InternalAfter + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/InternalLibraries/Haddock/haddock.cabal.out b/cabal/cabal-testsuite/PackageTests/InternalLibraries/Haddock/haddock.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalLibraries/Haddock/haddock.cabal.out @@ -0,0 +1,27 @@ +# Setup configure +Configuring foo-0.1.0.0... +# Setup build +Preprocessing library 'foo-internal-before' for foo-0.1.0.0.. +Building library 'foo-internal-before' for foo-0.1.0.0.. +Preprocessing library for foo-0.1.0.0.. +Building library for foo-0.1.0.0.. +Preprocessing library 'foo-internal-after' for foo-0.1.0.0.. +Building library 'foo-internal-after' for foo-0.1.0.0.. +# Setup copy +Installing internal library foo-internal-before in +Installing library in +Installing internal library foo-internal-after in +# Setup register +Registering library 'foo-internal-before' for foo-0.1.0.0.. +Registering library for foo-0.1.0.0.. +Registering library 'foo-internal-after' for foo-0.1.0.0.. +# Setup haddock +Preprocessing library 'foo-internal-before' for foo-0.1.0.0.. +Running Haddock on library 'foo-internal-before' for foo-0.1.0.0.. +Documentation created: haddock.cabal.dist/work/dist/doc/html/foo/index.html +Preprocessing library for foo-0.1.0.0.. +Running Haddock on library for foo-0.1.0.0.. +Documentation created: haddock.cabal.dist/work/dist/doc/html/foo/index.html +Preprocessing library 'foo-internal-after' for foo-0.1.0.0.. +Running Haddock on library 'foo-internal-after' for foo-0.1.0.0.. +Documentation created: haddock.cabal.dist/work/dist/doc/html/foo/index.html diff --git a/cabal/cabal-testsuite/PackageTests/InternalLibraries/Haddock/haddock.out b/cabal/cabal-testsuite/PackageTests/InternalLibraries/Haddock/haddock.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalLibraries/Haddock/haddock.out @@ -0,0 +1,27 @@ +# Setup configure +Configuring foo-0.1.0.0... +# Setup build +Preprocessing library 'foo-internal-before' for foo-0.1.0.0.. +Building library 'foo-internal-before' for foo-0.1.0.0.. +Preprocessing library for foo-0.1.0.0.. +Building library for foo-0.1.0.0.. +Preprocessing library 'foo-internal-after' for foo-0.1.0.0.. +Building library 'foo-internal-after' for foo-0.1.0.0.. +# Setup copy +Installing internal library foo-internal-before in +Installing library in +Installing internal library foo-internal-after in +# Setup register +Registering library 'foo-internal-before' for foo-0.1.0.0.. +Registering library for foo-0.1.0.0.. +Registering library 'foo-internal-after' for foo-0.1.0.0.. +# Setup haddock +Preprocessing library 'foo-internal-before' for foo-0.1.0.0.. +Running Haddock on library 'foo-internal-before' for foo-0.1.0.0.. +Documentation created: haddock.dist/work/dist/doc/html/foo/index.html +Preprocessing library for foo-0.1.0.0.. +Running Haddock on library for foo-0.1.0.0.. +Documentation created: haddock.dist/work/dist/doc/html/foo/index.html +Preprocessing library 'foo-internal-after' for foo-0.1.0.0.. +Running Haddock on library 'foo-internal-after' for foo-0.1.0.0.. +Documentation created: haddock.dist/work/dist/doc/html/foo/index.html diff --git a/cabal/cabal-testsuite/PackageTests/InternalLibraries/Haddock/haddock.test.hs b/cabal/cabal-testsuite/PackageTests/InternalLibraries/Haddock/haddock.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalLibraries/Haddock/haddock.test.hs @@ -0,0 +1,6 @@ +import Test.Cabal.Prelude +-- https://github.com/haskell/cabal/issues/1919 +main = setupAndCabalTest $ + withPackageDb $ do + setup_install [] + setup "haddock" [] diff --git a/cabal/cabal-testsuite/PackageTests/InternalLibraries/cabal.out b/cabal/cabal-testsuite/PackageTests/InternalLibraries/cabal.out --- a/cabal/cabal-testsuite/PackageTests/InternalLibraries/cabal.out +++ b/cabal/cabal-testsuite/PackageTests/InternalLibraries/cabal.out @@ -9,10 +9,8 @@ Preprocessing library 'q' for p-0.1.0.0.. Building library 'q' for p-0.1.0.0.. Configuring executable 'foo' for p-0.1.0.0.. -Warning: The package has an extraneous version range for a dependency on an internal library: p:q >=0 && ==0.1.0.0, p:q >=0 && ==0.1.0.0. This version range includes the current package but isn't needed as the current package's library will always be used. Preprocessing executable 'foo' for p-0.1.0.0.. Building executable 'foo' for p-0.1.0.0.. Configuring library for p-0.1.0.0.. -Warning: The package has an extraneous version range for a dependency on an internal library: p:q >=0 && ==0.1.0.0, p:q >=0 && ==0.1.0.0. This version range includes the current package but isn't needed as the current package's library will always be used. Preprocessing library for p-0.1.0.0.. Building library for p-0.1.0.0.. diff --git a/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildDependsBad/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildDependsBad/setup.cabal.out --- a/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildDependsBad/setup.cabal.out +++ b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildDependsBad/setup.cabal.out @@ -1,3 +1,3 @@ # Setup configure Configuring build-depends-bad-version-0.1.0.0... -cabal: The package has an impossible version range for a dependency on an internal library: build-depends-bad-version >=2. This version range does not include the current package, and must be removed as the current package's library will always be used. +Error: cabal: The package has an impossible version range for a dependency on an internal library: build-depends-bad-version >=2. This version range does not include the current package, and must be removed as the current package's library will always be used. diff --git a/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildDependsBad/setup.out b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildDependsBad/setup.out --- a/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildDependsBad/setup.out +++ b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildDependsBad/setup.out @@ -1,3 +1,3 @@ # Setup configure Configuring build-depends-bad-version-0.1.0.0... -setup: The package has an impossible version range for a dependency on an internal library: build-depends-bad-version >=2. This version range does not include the current package, and must be removed as the current package's library will always be used. +Error: setup: The package has an impossible version range for a dependency on an internal library: build-depends-bad-version >=2. This version range does not include the current package, and must be removed as the current package's library will always be used. diff --git a/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildDependsExtra/setup.test.hs b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildDependsExtra/setup.test.hs --- a/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildDependsExtra/setup.test.hs +++ b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildDependsExtra/setup.test.hs @@ -1,6 +1,6 @@ import Test.Cabal.Prelude -- Test unneed version bound on internal build-tools deps -main = setupAndCabalTest $ do +main = setupAndCabalTest . expectBroken 7470 $ do setup' "configure" [] assertOutputContains "extraneous version range" =<< setup' "sdist" [] diff --git a/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsBad/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsBad/setup.cabal.out --- a/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsBad/setup.cabal.out +++ b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsBad/setup.cabal.out @@ -1,3 +1,3 @@ # Setup configure Configuring build-tool-depends-bad-version-0.1.0.0... -cabal: The package has an impossible version range for a dependency on an internal executable: build-tool-depends-bad-version:hello-world >=2. This version range does not include the current package, and must be removed as the current package's executable will always be used. +Error: cabal: The package has an impossible version range for a dependency on an internal executable: build-tool-depends-bad-version:hello-world >=2. This version range does not include the current package, and must be removed as the current package's executable will always be used. diff --git a/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsBad/setup.out b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsBad/setup.out --- a/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsBad/setup.out +++ b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsBad/setup.out @@ -1,3 +1,3 @@ # Setup configure Configuring build-tool-depends-bad-version-0.1.0.0... -setup: The package has an impossible version range for a dependency on an internal executable: build-tool-depends-bad-version:hello-world >=2. This version range does not include the current package, and must be removed as the current package's executable will always be used. +Error: setup: The package has an impossible version range for a dependency on an internal executable: build-tool-depends-bad-version:hello-world >=2. This version range does not include the current package, and must be removed as the current package's executable will always be used. diff --git a/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsExtra/setup.test.hs b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsExtra/setup.test.hs --- a/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsExtra/setup.test.hs +++ b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsExtra/setup.test.hs @@ -1,6 +1,6 @@ import Test.Cabal.Prelude -- Test unneed version bound on internal build-tools deps -main = setupAndCabalTest $ do +main = setupAndCabalTest . expectBroken 7470 $ do setup' "configure" [] assertOutputContains "extraneous version range" =<< setup' "sdist" [] diff --git a/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolsBad/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolsBad/setup.cabal.out --- a/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolsBad/setup.cabal.out +++ b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolsBad/setup.cabal.out @@ -1,3 +1,3 @@ # Setup configure Configuring build-tools-bad-version-0.1.0.0... -cabal: The package has an impossible version range for a dependency on an internal executable: build-tools-bad-version:hello-world >=2. This version range does not include the current package, and must be removed as the current package's executable will always be used. +Error: cabal: The package has an impossible version range for a dependency on an internal executable: build-tools-bad-version:hello-world >=2. This version range does not include the current package, and must be removed as the current package's executable will always be used. diff --git a/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolsBad/setup.out b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolsBad/setup.out --- a/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolsBad/setup.out +++ b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolsBad/setup.out @@ -1,3 +1,3 @@ # Setup configure Configuring build-tools-bad-version-0.1.0.0... -setup: The package has an impossible version range for a dependency on an internal executable: build-tools-bad-version:hello-world >=2. This version range does not include the current package, and must be removed as the current package's executable will always be used. +Error: setup: The package has an impossible version range for a dependency on an internal executable: build-tools-bad-version:hello-world >=2. This version range does not include the current package, and must be removed as the current package's executable will always be used. diff --git a/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolsExtra/setup.test.hs b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolsExtra/setup.test.hs --- a/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolsExtra/setup.test.hs +++ b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolsExtra/setup.test.hs @@ -1,6 +1,6 @@ import Test.Cabal.Prelude -- Test unneed version bound on internal build-tools deps -main = setupAndCabalTest $ do +main = setupAndCabalTest . expectBroken 7470 $ do setup' "configure" [] assertOutputContains "extraneous version range" =<< setup' "sdist" [] diff --git a/cabal/cabal-testsuite/PackageTests/ListBin/Script/cabal.out b/cabal/cabal-testsuite/PackageTests/ListBin/Script/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ListBin/Script/cabal.out @@ -0,0 +1,5 @@ +# cabal list-bin +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - fake-package-0 (exe:cabal-script-script.hs) (first run) diff --git a/cabal/cabal-testsuite/PackageTests/ListBin/Script/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/ListBin/Script/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ListBin/Script/cabal.test.hs @@ -0,0 +1,8 @@ +import Test.Cabal.Prelude + +main = cabalTest . void $ do + res <- cabal' "list-bin" ["script.hs"] + + env <- getTestEnv + cacheDir <- getScriptCacheDirectory $ testCurrentDir env "script.hs" + assertOutputContains cacheDir res diff --git a/cabal/cabal-testsuite/PackageTests/ListBin/Script/script.hs b/cabal/cabal-testsuite/PackageTests/ListBin/Script/script.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ListBin/Script/script.hs @@ -0,0 +1,6 @@ +{- cabal: +build-depends: base +-} + +main :: IO () +main = putStrLn "Hello World" diff --git a/cabal/cabal-testsuite/PackageTests/ListBin/SelectedComponent/SelectedComponent.cabal b/cabal/cabal-testsuite/PackageTests/ListBin/SelectedComponent/SelectedComponent.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ListBin/SelectedComponent/SelectedComponent.cabal @@ -0,0 +1,9 @@ +cabal-version: 2.2 +name: SelectedComponent +version: 1.0.0 + +executable testexe + +executable setup + +custom-setup diff --git a/cabal/cabal-testsuite/PackageTests/ListBin/SelectedComponent/cabal.out b/cabal/cabal-testsuite/PackageTests/ListBin/SelectedComponent/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ListBin/SelectedComponent/cabal.out @@ -0,0 +1,5 @@ +# cabal list-bin +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - SelectedComponent-1.0.0 (exe:testexe) (first run) diff --git a/cabal/cabal-testsuite/PackageTests/ListBin/SelectedComponent/cabal.project b/cabal/cabal-testsuite/PackageTests/ListBin/SelectedComponent/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ListBin/SelectedComponent/cabal.project @@ -0,0 +1,1 @@ +packages: . diff --git a/cabal/cabal-testsuite/PackageTests/ListBin/SelectedComponent/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/ListBin/SelectedComponent/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ListBin/SelectedComponent/cabal.test.hs @@ -0,0 +1,8 @@ +import Test.Cabal.Prelude + +-- https://github.com/haskell/cabal/issues/7679 +main = cabalTest . void $ do + res <- cabal' "list-bin" ["exe:testexe"] + + assertOutputContains "SelectedComponent-1.0.0" res + assertOutputContains "testexe" res diff --git a/cabal/cabal-testsuite/PackageTests/Manpage/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/Manpage/cabal.test.hs --- a/cabal/cabal-testsuite/PackageTests/Manpage/cabal.test.hs +++ b/cabal/cabal-testsuite/PackageTests/Manpage/cabal.test.hs @@ -1,5 +1,24 @@ +import System.Process +import Distribution.System (OS(Windows,Linux,OSX), buildOS) import Test.Cabal.Prelude + main = cabalTest $ do r <- cabal' "man" ["--raw"] assertOutputContains ".B cabal install" r assertOutputDoesNotContain ".B cabal manpage" r + + -- The following test of `cabal man` needs `nroff` which is not available under Windows. + unless (buildOS == Windows) $ do + + -- Check that output of `cabal man --raw` can be passed through `nroff -man` + -- without producing any warnings (which are printed to stderr). + -- + -- NB: runM is not suitable as it mixes stdout and stderr + -- r2 <- runM "nroff" ["-man", "/dev/stdin"] $ Just $ resultOutput r + (ec, _output, errors) <- liftIO $ + readProcessWithExitCode "nroff" ["-man", "/dev/stdin"] $ resultOutput r + unless (null errors) $ + assertFailure $ unlines + [ "Error: unexpected warnings produced by `nroff -man`:" + , errors + ] diff --git a/cabal/cabal-testsuite/PackageTests/MultipleLibraries/Failing/cabal.out b/cabal/cabal-testsuite/PackageTests/MultipleLibraries/Failing/cabal.out --- a/cabal/cabal-testsuite/PackageTests/MultipleLibraries/Failing/cabal.out +++ b/cabal/cabal-testsuite/PackageTests/MultipleLibraries/Failing/cabal.out @@ -1,6 +1,6 @@ # cabal v2-build Resolving dependencies... -cabal: Could not resolve dependencies: +Error: cabal: Could not resolve dependencies: [__0] trying: d-0.1.0.0 (user goal) [__1] next goal: p (user goal) [__1] rejecting: p-0.1.0.0 (requires library 'privatelib' from d, but the component is private) diff --git a/cabal/cabal-testsuite/PackageTests/MultipleLibraries/Successful/cabal.out b/cabal/cabal-testsuite/PackageTests/MultipleLibraries/Successful/cabal.out --- a/cabal/cabal-testsuite/PackageTests/MultipleLibraries/Successful/cabal.out +++ b/cabal/cabal-testsuite/PackageTests/MultipleLibraries/Successful/cabal.out @@ -4,11 +4,9 @@ In order, the following will be built: - pkg-def-0.1.0.0 (lib:publib) (first run) - pkg-abc-0.1.0.0 (exe:program) (first run) -Warning: pkg-def.cabal:10:27: visibility is experimental feature (issue #5660) Configuring library 'publib' for pkg-def-0.1.0.0.. Preprocessing library 'publib' for pkg-def-0.1.0.0.. Building library 'publib' for pkg-def-0.1.0.0.. -Warning: pkg-abc.cabal:10:15: colon specifier is experimental feature (issue #5660) Configuring executable 'program' for pkg-abc-0.1.0.0.. Preprocessing executable 'program' for pkg-abc-0.1.0.0.. Building executable 'program' for pkg-abc-0.1.0.0.. diff --git a/cabal/cabal-testsuite/PackageTests/MultipleLibraries/T6083Post/cabal.out b/cabal/cabal-testsuite/PackageTests/MultipleLibraries/T6083Post/cabal.out --- a/cabal/cabal-testsuite/PackageTests/MultipleLibraries/T6083Post/cabal.out +++ b/cabal/cabal-testsuite/PackageTests/MultipleLibraries/T6083Post/cabal.out @@ -4,12 +4,9 @@ In order, the following will be built: - pkg-def-0.1.0.0 (lib) (first run) - pkg-abc-0.1.0.0 (exe:program) (first run) -Warning: pkg-def.cabal:13:27: visibility is experimental feature (issue #5660) Configuring library for pkg-def-0.1.0.0.. Preprocessing library for pkg-def-0.1.0.0.. Building library for pkg-def-0.1.0.0.. -Warning: pkg-abc.cabal:19:15: colon specifier is experimental feature (issue #5660) Configuring executable 'program' for pkg-abc-0.1.0.0.. -Warning: The package has an extraneous version range for a dependency on an internal library: pkg-def >=0 && ==0.1.0.0. This version range includes the current package but isn't needed as the current package's library will always be used. Preprocessing executable 'program' for pkg-abc-0.1.0.0.. Building executable 'program' for pkg-abc-0.1.0.0.. diff --git a/cabal/cabal-testsuite/PackageTests/MultipleLibraries/T6083PostMixin/cabal.out b/cabal/cabal-testsuite/PackageTests/MultipleLibraries/T6083PostMixin/cabal.out --- a/cabal/cabal-testsuite/PackageTests/MultipleLibraries/T6083PostMixin/cabal.out +++ b/cabal/cabal-testsuite/PackageTests/MultipleLibraries/T6083PostMixin/cabal.out @@ -4,13 +4,9 @@ In order, the following will be built: - pkg-def-0.1.0.0 (lib) (first run) - pkg-abc-0.1.0.0 (exe:program) (first run) -Warning: pkg-def.cabal:13:27: visibility is experimental feature (issue #5660) Configuring library for pkg-def-0.1.0.0.. Preprocessing library for pkg-def-0.1.0.0.. Building library for pkg-def-0.1.0.0.. -Warning: pkg-abc.cabal:15:29: colon specifier is experimental feature (issue #5660) -Warning: pkg-abc.cabal:20:15: colon specifier is experimental feature (issue #5660) Configuring executable 'program' for pkg-abc-0.1.0.0.. -Warning: The package has an extraneous version range for a dependency on an internal library: pkg-def >=0 && ==0.1.0.0. This version range includes the current package but isn't needed as the current package's library will always be used. Preprocessing executable 'program' for pkg-abc-0.1.0.0.. Building executable 'program' for pkg-abc-0.1.0.0.. diff --git a/cabal/cabal-testsuite/PackageTests/MultipleLibraries/T6083Pre/cabal.out b/cabal/cabal-testsuite/PackageTests/MultipleLibraries/T6083Pre/cabal.out --- a/cabal/cabal-testsuite/PackageTests/MultipleLibraries/T6083Pre/cabal.out +++ b/cabal/cabal-testsuite/PackageTests/MultipleLibraries/T6083Pre/cabal.out @@ -4,11 +4,9 @@ In order, the following will be built: - pkg-abc-0.1.0.0 (lib:pkg-def) (first run) - pkg-abc-0.1.0.0 (exe:program) (first run) -Warning: pkg-abc.cabal:19:15: colon specifier is experimental feature (issue #5660) Configuring library 'pkg-def' for pkg-abc-0.1.0.0.. Preprocessing library 'pkg-def' for pkg-abc-0.1.0.0.. Building library 'pkg-def' for pkg-abc-0.1.0.0.. -Warning: pkg-abc.cabal:19:15: colon specifier is experimental feature (issue #5660) Configuring executable 'program' for pkg-abc-0.1.0.0.. Preprocessing executable 'program' for pkg-abc-0.1.0.0.. Building executable 'program' for pkg-abc-0.1.0.0.. diff --git a/cabal/cabal-testsuite/PackageTests/MultipleLibraries/T6083PreMixin/cabal.out b/cabal/cabal-testsuite/PackageTests/MultipleLibraries/T6083PreMixin/cabal.out --- a/cabal/cabal-testsuite/PackageTests/MultipleLibraries/T6083PreMixin/cabal.out +++ b/cabal/cabal-testsuite/PackageTests/MultipleLibraries/T6083PreMixin/cabal.out @@ -4,11 +4,9 @@ In order, the following will be built: - pkg-abc-0.1.0.0 (lib:pkg-def) (first run) - pkg-abc-0.1.0.0 (exe:program) (first run) -Warning: pkg-abc.cabal:20:15: colon specifier is experimental feature (issue #5660) Configuring library 'pkg-def' for pkg-abc-0.1.0.0.. Preprocessing library 'pkg-def' for pkg-abc-0.1.0.0.. Building library 'pkg-def' for pkg-abc-0.1.0.0.. -Warning: pkg-abc.cabal:20:15: colon specifier is experimental feature (issue #5660) Configuring executable 'program' for pkg-abc-0.1.0.0.. Preprocessing executable 'program' for pkg-abc-0.1.0.0.. Building executable 'program' for pkg-abc-0.1.0.0.. diff --git a/cabal/cabal-testsuite/PackageTests/MultipleLibraries/T6894/cabal.out b/cabal/cabal-testsuite/PackageTests/MultipleLibraries/T6894/cabal.out --- a/cabal/cabal-testsuite/PackageTests/MultipleLibraries/T6894/cabal.out +++ b/cabal/cabal-testsuite/PackageTests/MultipleLibraries/T6894/cabal.out @@ -4,12 +4,9 @@ In order, the following will be built: - issue-6894 (lib:sublib) (first run) - issue-6894 (lib) (first run) -Warning: issue.cabal:7:30: colon specifier is experimental feature (issue #5660) Configuring library 'sublib' for issue-6894.. Preprocessing library 'sublib' for issue-6894.. Building library 'sublib' for issue-6894.. -Warning: issue.cabal:7:30: colon specifier is experimental feature (issue #5660) Configuring library for issue-6894.. -Warning: The package has an extraneous version range for a dependency on an internal library: issue:sublib >=0 && ==6894. This version range includes the current package but isn't needed as the current package's library will always be used. Preprocessing library for issue-6894.. Building library for issue-6894.. diff --git a/cabal/cabal-testsuite/PackageTests/MultipleLibraries/T6894/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/MultipleLibraries/T6894/setup.cabal.out --- a/cabal/cabal-testsuite/PackageTests/MultipleLibraries/T6894/setup.cabal.out +++ b/cabal/cabal-testsuite/PackageTests/MultipleLibraries/T6894/setup.cabal.out @@ -1,5 +1,4 @@ # Setup configure -Warning: issue.cabal:7:30: colon specifier is experimental feature (issue #5660) Configuring issue-6894... # Setup build Preprocessing library 'sublib' for issue-6894.. diff --git a/cabal/cabal-testsuite/PackageTests/MultipleLibraries/T6894/setup.out b/cabal/cabal-testsuite/PackageTests/MultipleLibraries/T6894/setup.out --- a/cabal/cabal-testsuite/PackageTests/MultipleLibraries/T6894/setup.out +++ b/cabal/cabal-testsuite/PackageTests/MultipleLibraries/T6894/setup.out @@ -1,5 +1,4 @@ # Setup configure -Warning: issue.cabal:7:30: colon specifier is experimental feature (issue #5660) Configuring issue-6894... # Setup build Preprocessing library 'sublib' for issue-6894.. diff --git a/cabal/cabal-testsuite/PackageTests/MultipleLibraries/T7270/cabal.cabal.out b/cabal/cabal-testsuite/PackageTests/MultipleLibraries/T7270/cabal.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/MultipleLibraries/T7270/cabal.cabal.out @@ -0,0 +1,18 @@ +# Setup configure +Configuring dep-0.1.0.0... +# Setup build +Preprocessing library 'sublib' for dep-0.1.0.0.. +Building library 'sublib' for dep-0.1.0.0.. +Preprocessing library for dep-0.1.0.0.. +Building library for dep-0.1.0.0.. +# Setup copy +Installing internal library sublib in +Installing library in +# Setup register +Registering library 'sublib' for dep-0.1.0.0.. +Registering library for dep-0.1.0.0.. +# Setup configure +Configuring p-0.1.0.0... +# Setup build +Preprocessing library for p-0.1.0.0.. +Building library for p-0.1.0.0.. diff --git a/cabal/cabal-testsuite/PackageTests/MultipleLibraries/T7270/cabal.out b/cabal/cabal-testsuite/PackageTests/MultipleLibraries/T7270/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/MultipleLibraries/T7270/cabal.out @@ -0,0 +1,18 @@ +# Setup configure +Configuring dep-0.1.0.0... +# Setup build +Preprocessing library 'sublib' for dep-0.1.0.0.. +Building library 'sublib' for dep-0.1.0.0.. +Preprocessing library for dep-0.1.0.0.. +Building library for dep-0.1.0.0.. +# Setup copy +Installing internal library sublib in +Installing library in +# Setup register +Registering library 'sublib' for dep-0.1.0.0.. +Registering library for dep-0.1.0.0.. +# Setup configure +Configuring p-0.1.0.0... +# Setup build +Preprocessing library for p-0.1.0.0.. +Building library for p-0.1.0.0.. diff --git a/cabal/cabal-testsuite/PackageTests/MultipleLibraries/T7270/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/MultipleLibraries/T7270/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/MultipleLibraries/T7270/cabal.test.hs @@ -0,0 +1,5 @@ +import Test.Cabal.Prelude +main = setupAndCabalTest $ + withPackageDb $ do + withDirectory "dep" $ setup_install [] + withDirectory "p" $ setup_build [] diff --git a/cabal/cabal-testsuite/PackageTests/MultipleLibraries/T7270/dep/Sublib.hs b/cabal/cabal-testsuite/PackageTests/MultipleLibraries/T7270/dep/Sublib.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/MultipleLibraries/T7270/dep/Sublib.hs @@ -0,0 +1,4 @@ +module Sublib where + +s :: String +s = "Hello World" diff --git a/cabal/cabal-testsuite/PackageTests/MultipleLibraries/T7270/dep/dep.cabal b/cabal/cabal-testsuite/PackageTests/MultipleLibraries/T7270/dep/dep.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/MultipleLibraries/T7270/dep/dep.cabal @@ -0,0 +1,14 @@ +cabal-version: 3.0 +name: dep +version: 0.1.0.0 +build-type: Simple + +-- needed because of https://github.com/haskell/cabal/issues/8095 +library + default-language: Haskell2010 + +library sublib + visibility: public + exposed-modules: Sublib + build-depends: base >=4 && <5 + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/MultipleLibraries/T7270/p/Main.hs b/cabal/cabal-testsuite/PackageTests/MultipleLibraries/T7270/p/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/MultipleLibraries/T7270/p/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import Sublib (s) + +main :: IO () +main = putStrLn s diff --git a/cabal/cabal-testsuite/PackageTests/MultipleLibraries/T7270/p/p.cabal b/cabal/cabal-testsuite/PackageTests/MultipleLibraries/T7270/p/p.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/MultipleLibraries/T7270/p/p.cabal @@ -0,0 +1,10 @@ +cabal-version: 3.0 +name: p +version: 0.1.0.0 +build-type: Simple + +library + exposed-modules: Main + build-depends: base >=4 && <5 + , dep:sublib + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBench/MultipleBenchmarks/MultipleBenchmarks.cabal b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBench/MultipleBenchmarks/MultipleBenchmarks.cabal --- a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBench/MultipleBenchmarks/MultipleBenchmarks.cabal +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBench/MultipleBenchmarks/MultipleBenchmarks.cabal @@ -1,10 +1,9 @@ +cabal-version: 3.8 name: MultipleBenchmarks version: 1.0 build-type: Simple -cabal-version: >= 1.10 benchmark foo - type: exitcode-stdio-1.0 main-is: Foo.hs build-depends: base default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBuild/Script/cabal.out b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBuild/Script/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBuild/Script/cabal.out @@ -0,0 +1,7 @@ +# cabal v2-build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - fake-package-0 (exe:cabal-script-script.hs) (first run) +Configuring executable 'cabal-script-script.hs' for fake-package-0.. +Building executable 'cabal-script-script.hs' for fake-package-0.. diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBuild/Script/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBuild/Script/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBuild/Script/cabal.test.hs @@ -0,0 +1,10 @@ +import Test.Cabal.Prelude + +main = cabalTest . void $ do + cabal' "v2-build" ["script.hs"] + + env <- getTestEnv + cacheDir <- getScriptCacheDirectory $ testCurrentDir env "script.hs" + + shouldExist $ cacheDir "fake-package.cabal" + shouldExist $ cacheDir "scriptlocation" diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBuild/Script/script.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBuild/Script/script.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBuild/Script/script.hs @@ -0,0 +1,6 @@ +{- cabal: +build-depends: base +-} + +main :: IO () +main = putStrLn "Hello World" diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBuild/ScriptBuildRepl/cabal.out b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBuild/ScriptBuildRepl/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBuild/ScriptBuildRepl/cabal.out @@ -0,0 +1,11 @@ +# cabal v2-build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - fake-package-0 (exe:cabal-script-script.hs) (first run) +Configuring executable 'cabal-script-script.hs' for fake-package-0.. +Building executable 'cabal-script-script.hs' for fake-package-0.. +# cabal v2-repl +Build profile: -w ghc- -O1 +In order, the following will be built: + - fake-package-0 (exe:cabal-script-script.hs) (ephemeral targets) diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBuild/ScriptBuildRepl/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBuild/ScriptBuildRepl/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBuild/ScriptBuildRepl/cabal.test.hs @@ -0,0 +1,5 @@ +import Test.Cabal.Prelude + +main = cabalTest . void $ do + cabal' "v2-build" ["script.hs"] + cabalWithStdin "v2-repl" ["script.hs"] "" diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBuild/ScriptBuildRepl/script.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBuild/ScriptBuildRepl/script.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBuild/ScriptBuildRepl/script.hs @@ -0,0 +1,6 @@ +{- cabal: +build-depends: base +-} + +main :: IO () +main = putStrLn "Hello World" diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBuild/ScriptBuildRun/cabal.out b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBuild/ScriptBuildRun/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBuild/ScriptBuildRun/cabal.out @@ -0,0 +1,9 @@ +# cabal v2-build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - fake-package-0 (exe:cabal-script-script.hs) (first run) +Configuring executable 'cabal-script-script.hs' for fake-package-0.. +Building executable 'cabal-script-script.hs' for fake-package-0.. +# cabal v2-run +Up to date diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBuild/ScriptBuildRun/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBuild/ScriptBuildRun/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBuild/ScriptBuildRun/cabal.test.hs @@ -0,0 +1,5 @@ +import Test.Cabal.Prelude + +main = cabalTest . void $ do + cabal' "v2-build" ["script.hs"] + cabal' "v2-run" ["script.hs"] diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBuild/ScriptBuildRun/script.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBuild/ScriptBuildRun/script.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBuild/ScriptBuildRun/script.hs @@ -0,0 +1,6 @@ +{- cabal: +build-depends: base +-} + +main :: IO () +main = putStrLn "Hello World" diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBuild/ScriptRerun/cabal.out b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBuild/ScriptRerun/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBuild/ScriptRerun/cabal.out @@ -0,0 +1,9 @@ +# cabal v2-build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - fake-package-0 (exe:cabal-script-script.hs) (first run) +Configuring executable 'cabal-script-script.hs' for fake-package-0.. +Building executable 'cabal-script-script.hs' for fake-package-0.. +# cabal v2-build +Up to date diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBuild/ScriptRerun/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBuild/ScriptRerun/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBuild/ScriptRerun/cabal.test.hs @@ -0,0 +1,5 @@ +import Test.Cabal.Prelude + +main = cabalTest . void $ do + cabal' "v2-build" ["script.hs"] + cabal' "v2-build" ["script.hs"] diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBuild/ScriptRerun/script.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBuild/ScriptRerun/script.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBuild/ScriptRerun/script.hs @@ -0,0 +1,6 @@ +{- cabal: +build-depends: base +-} + +main :: IO () +main = putStrLn "Hello World" diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdClean/CleanScriptWithNoScriptsBuilt/cabal.out b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdClean/CleanScriptWithNoScriptsBuilt/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdClean/CleanScriptWithNoScriptsBuilt/cabal.out @@ -0,0 +1,2 @@ +# cabal v2-clean +# cabal v2-clean diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdClean/CleanScriptWithNoScriptsBuilt/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdClean/CleanScriptWithNoScriptsBuilt/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdClean/CleanScriptWithNoScriptsBuilt/cabal.test.hs @@ -0,0 +1,5 @@ +import Test.Cabal.Prelude + +main = cabalTest . void $ do + cabal' "v2-clean" [] + cabal' "v2-clean" ["script.hs"] diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdClean/CleanScriptWithNoScriptsBuilt/script.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdClean/CleanScriptWithNoScriptsBuilt/script.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdClean/CleanScriptWithNoScriptsBuilt/script.hs @@ -0,0 +1,6 @@ +{- cabal: +build-depends: base +-} + +main :: IO () +main = putStrLn "Hello World" diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdClean/Keep/cabal.out b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdClean/Keep/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdClean/Keep/cabal.out @@ -0,0 +1,15 @@ +# cabal v2-build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - fake-package-0 (exe:cabal-script-script.hs) (first run) +Configuring executable 'cabal-script-script.hs' for fake-package-0.. +Building executable 'cabal-script-script.hs' for fake-package-0.. +# cabal v2-build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - fake-package-0 (exe:cabal-script-script2.hs) (first run) +Configuring executable 'cabal-script-script2.hs' for fake-package-0.. +Building executable 'cabal-script-script2.hs' for fake-package-0.. +# cabal v2-clean diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdClean/Keep/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdClean/Keep/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdClean/Keep/cabal.test.hs @@ -0,0 +1,18 @@ +import Test.Cabal.Prelude +import System.Directory (copyFile, removeFile) + +main = cabalTest . void $ do + env <- getTestEnv + let td = testCurrentDir env + + cabal' "v2-build" ["script.hs"] + liftIO $ copyFile (td "script.hs") (td "script2.hs") + cabal' "v2-build" ["script2.hs"] + liftIO $ removeFile (td "script2.hs") + cabal' "v2-clean" [] + + cacheDir <- getScriptCacheDirectory (td "script.hs") + cacheDir2 <- getScriptCacheDirectory (td "script2.hs") + + shouldDirectoryExist cacheDir + shouldDirectoryNotExist cacheDir2 diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdClean/Keep/script.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdClean/Keep/script.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdClean/Keep/script.hs @@ -0,0 +1,6 @@ +{- cabal: +build-depends: base +-} + +main :: IO () +main = putStrLn "Hello World" diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdClean/Orphan/cabal.out b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdClean/Orphan/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdClean/Orphan/cabal.out @@ -0,0 +1,15 @@ +# cabal v2-build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - fake-package-0 (exe:cabal-script-script.hs) (first run) +Configuring executable 'cabal-script-script.hs' for fake-package-0.. +Building executable 'cabal-script-script.hs' for fake-package-0.. +# cabal v2-build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - fake-package-0 (exe:cabal-script-script2.hs) (first run) +Configuring executable 'cabal-script-script2.hs' for fake-package-0.. +Building executable 'cabal-script-script2.hs' for fake-package-0.. +# cabal v2-clean diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdClean/Orphan/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdClean/Orphan/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdClean/Orphan/cabal.test.hs @@ -0,0 +1,18 @@ +import Test.Cabal.Prelude +import System.Directory (copyFile, removeFile) + +main = cabalTest . void $ do + env <- getTestEnv + let td = testCurrentDir env + + cabal' "v2-build" ["script.hs"] + liftIO $ copyFile (td "script.hs") (td "script2.hs") + cabal' "v2-build" ["script2.hs"] + liftIO $ removeFile (td "script2.hs") + cabal' "v2-clean" ["script.hs"] + + cacheDir <- getScriptCacheDirectory (td "script.hs") + cacheDir2 <- getScriptCacheDirectory (td "script2.hs") + + shouldDirectoryNotExist cacheDir + shouldDirectoryNotExist cacheDir2 diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdClean/Orphan/script.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdClean/Orphan/script.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdClean/Orphan/script.hs @@ -0,0 +1,6 @@ +{- cabal: +build-depends: base +-} + +main :: IO () +main = putStrLn "Hello World" diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdClean/Script/cabal.out b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdClean/Script/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdClean/Script/cabal.out @@ -0,0 +1,8 @@ +# cabal v2-build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - fake-package-0 (exe:cabal-script-script.hs) (first run) +Configuring executable 'cabal-script-script.hs' for fake-package-0.. +Building executable 'cabal-script-script.hs' for fake-package-0.. +# cabal v2-clean diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdClean/Script/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdClean/Script/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdClean/Script/cabal.test.hs @@ -0,0 +1,11 @@ +import Test.Cabal.Prelude + +main = cabalTest . void $ do + cabal' "v2-build" ["script.hs"] + cabal' "v2-clean" ["script.hs"] + + env <- getTestEnv + cacheDir <- getScriptCacheDirectory (testCurrentDir env "script.hs") + + shouldDirectoryNotExist cacheDir + shouldDirectoryNotExist (testDistDir env) diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdClean/Script/script.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdClean/Script/script.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdClean/Script/script.hs @@ -0,0 +1,6 @@ +{- cabal: +build-depends: base +-} + +main :: IO () +main = putStrLn "Hello World" diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRepl/Script/cabal.out b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRepl/Script/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRepl/Script/cabal.out @@ -0,0 +1,6 @@ +# cabal v2-repl +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - fake-package-0 (exe:cabal-script-script.hs) (first run) +Configuring executable 'cabal-script-script.hs' for fake-package-0.. diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRepl/Script/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRepl/Script/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRepl/Script/cabal.test.hs @@ -0,0 +1,11 @@ +import Test.Cabal.Prelude + +main = cabalTest . void $ do + res <- cabalWithStdin "v2-repl" ["script.hs"] ":main" + assertOutputContains "Hello World" res + + env <- getTestEnv + cacheDir <- getScriptCacheDirectory $ testCurrentDir env "script.hs" + + shouldExist $ cacheDir "fake-package.cabal" + shouldExist $ cacheDir "scriptlocation" diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRepl/Script/script.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRepl/Script/script.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRepl/Script/script.hs @@ -0,0 +1,6 @@ +{- cabal: +build-depends: base +-} + +main :: IO () +main = putStrLn "Hello World" diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRepl/ScriptRerun/cabal.out b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRepl/ScriptRerun/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRepl/ScriptRerun/cabal.out @@ -0,0 +1,10 @@ +# cabal v2-repl +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - fake-package-0 (exe:cabal-script-script.hs) (first run) +Configuring executable 'cabal-script-script.hs' for fake-package-0.. +# cabal v2-repl +Build profile: -w ghc- -O1 +In order, the following will be built: + - fake-package-0 (exe:cabal-script-script.hs) (first run) diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRepl/ScriptRerun/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRepl/ScriptRerun/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRepl/ScriptRerun/cabal.test.hs @@ -0,0 +1,5 @@ +import Test.Cabal.Prelude + +main = cabalTest . void $ do + cabalWithStdin "v2-repl" ["script.hs"] "" + cabalWithStdin "v2-repl" ["script.hs"] "" diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRepl/ScriptRerun/script.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRepl/ScriptRerun/script.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRepl/ScriptRerun/script.hs @@ -0,0 +1,6 @@ +{- cabal: +build-depends: base +-} + +main :: IO () +main = putStrLn "Hello World" diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ExeAndLib/cabal.out b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ExeAndLib/cabal.out --- a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ExeAndLib/cabal.out +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ExeAndLib/cabal.out @@ -7,4 +7,4 @@ Preprocessing executable 'foo' for ExeAndLib-1.0.. Building executable 'foo' for ExeAndLib-1.0.. # cabal v2-run -cabal: The run command is for running executables, but the target 'ExeAndLib' refers to the library ExeAndLib from the package ExeAndLib-1.0. +Error: cabal: The run command is for running executables, but the target 'ExeAndLib' refers to the library ExeAndLib from the package ExeAndLib-1.0. diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultipleExes/cabal.out b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultipleExes/cabal.out --- a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultipleExes/cabal.out +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultipleExes/cabal.out @@ -16,6 +16,6 @@ # cabal v2-run Up to date # cabal v2-run -cabal: The run command is for running a single executable at once. The target '' refers to the package MultipleExes-1.0 which includes the executable 'foo' and the executable 'bar'. +Error: cabal: The run command is for running a single executable at once. The target '' refers to the package MultipleExes-1.0 which includes the executable 'foo' and the executable 'bar'. # cabal v2-run -cabal: The run command is for running a single executable at once. The target 'MultipleExes' refers to the package MultipleExes-1.0 which includes the executable 'foo' and the executable 'bar'. +Error: cabal: The run command is for running a single executable at once. The target 'MultipleExes' refers to the package MultipleExes-1.0 which includes the executable 'foo' and the executable 'bar'. diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultiplePackages/cabal.out b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultiplePackages/cabal.out --- a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultiplePackages/cabal.out +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultiplePackages/cabal.out @@ -23,15 +23,15 @@ Preprocessing executable 'foo-exe' for bar-1.0.. Building executable 'foo-exe' for bar-1.0.. # cabal v2-run -cabal: No targets given and there is no package in the current directory. Use the target 'all' for all packages in the project or specify packages or components by name or location. See 'cabal build --help' for more details on target options. +Error: cabal: No targets given and there is no package in the current directory. Specify packages or components by name or location. See 'cabal build --help' for more details on target options. # cabal v2-run -cabal: The run command is for running a single executable at once. The target 'bar' refers to the package bar-1.0 which includes the executable 'foo-exe' and the executable 'bar-exe'. +Error: cabal: The run command is for running a single executable at once. The target 'bar' refers to the package bar-1.0 which includes the executable 'foo-exe' and the executable 'bar-exe'. # cabal v2-run -cabal: Ambiguous target 'foo-exe'. It could be: +Error: cabal: Ambiguous target 'foo-exe'. It could be: bar:foo-exe (component) foo:foo-exe (component) # cabal v2-run -cabal: Unknown target 'foo:bar-exe'. +Error: cabal: Unknown target 'foo:bar-exe'. The package foo has no component 'bar-exe'. diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/RunMainBad/Main.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/RunMainBad/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/RunMainBad/Main.hs @@ -0,0 +1,1 @@ +main = putStrLn "Hello World" diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/RunMainBad/RunMainBad.cabal b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/RunMainBad/RunMainBad.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/RunMainBad/RunMainBad.cabal @@ -0,0 +1,9 @@ +name: RunMainBad +version: 1.0 +build-type: Simple +cabal-version: >= 1.10 + +executable foo + main-is: Main.hs + build-depends: base + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/RunMainBad/cabal.out b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/RunMainBad/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/RunMainBad/cabal.out @@ -0,0 +1,3 @@ +# cabal v2-run +Resolving dependencies... +Error: cabal: The run command can only run an executable as a whole, not files or modules within them, but the target 'Main.hs' refers to the file Main.hs in the executable foo. diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/RunMainBad/cabal.project b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/RunMainBad/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/RunMainBad/cabal.project @@ -0,0 +1,1 @@ +packages: . diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/RunMainBad/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/RunMainBad/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/RunMainBad/cabal.test.hs @@ -0,0 +1,4 @@ +import Test.Cabal.Prelude + +main = cabalTest $ do + void . fails $ cabal' "v2-run" ["./Main.hs"] diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/Script/cabal.out b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/Script/cabal.out --- a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/Script/cabal.out +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/Script/cabal.out @@ -2,7 +2,6 @@ Resolving dependencies... Build profile: -w ghc- -O1 In order, the following will be built: - - fake-package-0 (exe:script) (first run) -Configuring executable 'script' for fake-package-0.. -Preprocessing executable 'script' for fake-package-0.. -Building executable 'script' for fake-package-0.. + - fake-package-0 (exe:cabal-script-script.hs) (first run) +Configuring executable 'cabal-script-script.hs' for fake-package-0.. +Building executable 'cabal-script-script.hs' for fake-package-0.. diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/Script/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/Script/cabal.test.hs --- a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/Script/cabal.test.hs +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/Script/cabal.test.hs @@ -3,3 +3,9 @@ main = cabalTest $ do res <- cabal' "v2-run" ["script.hs"] assertOutputContains "Hello World" res + + env <- getTestEnv + cacheDir <- getScriptCacheDirectory (testCurrentDir env "script.hs") + + shouldExist $ cacheDir "fake-package.cabal" + shouldExist $ cacheDir "scriptlocation" diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptBad/cabal.out b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptBad/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptBad/cabal.out @@ -0,0 +1,2 @@ +# cabal v2-run +Error: cabal: Failed extracting script block: `{- cabal:` start marker not found diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptBad/cabal.project b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptBad/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptBad/cabal.project @@ -0,0 +1,1 @@ +packages: . diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptBad/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptBad/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptBad/cabal.test.hs @@ -0,0 +1,4 @@ +import Test.Cabal.Prelude + +main = cabalTest $ do + void . fails $ cabal' "v2-run" ["script.hs"] diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptBad/script.cabal b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptBad/script.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptBad/script.cabal @@ -0,0 +1,4 @@ +name: script +version: 1.0 +build-type: Simple +cabal-version: >= 1.10 diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptBad/script.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptBad/script.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptBad/script.hs @@ -0,0 +1,9 @@ +#! /usr/bin/env cabal +{- +build-depends: base >= 4.3 && <5 +-} + +import Prelude + +main :: IO () +main = putStrLn "Hello World" diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptLiterate/cabal.out b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptLiterate/cabal.out --- a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptLiterate/cabal.out +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptLiterate/cabal.out @@ -2,7 +2,6 @@ Resolving dependencies... Build profile: -w ghc- -O1 In order, the following will be built: - - fake-package-0 (exe:script) (first run) -Configuring executable 'script' for fake-package-0.. -Preprocessing executable 'script' for fake-package-0.. -Building executable 'script' for fake-package-0.. + - fake-package-0 (exe:cabal-script-script.lhs) (first run) +Configuring executable 'cabal-script-script.lhs' for fake-package-0.. +Building executable 'cabal-script-script.lhs' for fake-package-0.. diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptNoExtension/cabal.out b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptNoExtension/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptNoExtension/cabal.out @@ -0,0 +1,7 @@ +# cabal v2-run +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - fake-package-0 (exe:cabal-script-with_sp) (first run) +Configuring executable 'cabal-script-with_sp' for fake-package-0.. +Building executable 'cabal-script-with_sp' for fake-package-0.. diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptNoExtension/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptNoExtension/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptNoExtension/cabal.test.hs @@ -0,0 +1,4 @@ +import Test.Cabal.Prelude + +main = cabalTest . void $ do + cabal' "v2-run" ["with sp"] >>= assertOutputContains "Hello World" diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptNoExtension/with sp b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptNoExtension/with sp new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptNoExtension/with sp @@ -0,0 +1,6 @@ +{- cabal: +build-depends: base +-} + +main :: IO () +main = putStrLn "Hello World" diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptRerun/cabal.out b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptRerun/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptRerun/cabal.out @@ -0,0 +1,9 @@ +# cabal v2-run +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - fake-package-0 (exe:cabal-script-script.hs) (first run) +Configuring executable 'cabal-script-script.hs' for fake-package-0.. +Building executable 'cabal-script-script.hs' for fake-package-0.. +# cabal v2-run +Up to date diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptRerun/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptRerun/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptRerun/cabal.test.hs @@ -0,0 +1,5 @@ +import Test.Cabal.Prelude + +main = cabalTest . void $ do + cabal' "v2-run" ["script.hs"] + cabal' "v2-run" ["script.hs"] diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptRerun/script.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptRerun/script.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptRerun/script.hs @@ -0,0 +1,6 @@ +{- cabal: +build-depends: base +-} + +main :: IO () +main = putStrLn "Hello World" diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptWithProjectBlock/cabal.out b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptWithProjectBlock/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptWithProjectBlock/cabal.out @@ -0,0 +1,7 @@ +# cabal v2-run +Resolving dependencies... +Build profile: -w ghc- -O2 +In order, the following will be built: + - fake-package-0 (exe:cabal-script-s.hs) (first run) +Configuring executable 'cabal-script-s.hs' for fake-package-0.. +Building executable 'cabal-script-s.hs' for fake-package-0.. diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptWithProjectBlock/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptWithProjectBlock/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptWithProjectBlock/cabal.test.hs @@ -0,0 +1,6 @@ +import Test.Cabal.Prelude + +main = cabalTest $ do + -- script is called "s.hs" to avoid Windows long path issue in CI + res <- cabal' "v2-run" ["s.hs"] + assertOutputContains "Hello World" res diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptWithProjectBlock/s.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptWithProjectBlock/s.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptWithProjectBlock/s.hs @@ -0,0 +1,10 @@ +#!/usr/bin/env cabal +{- cabal: +build-depends: base +-} +{- project: +optimization: 2 +-} + +main :: IO () +main = putStrLn "Hello World" diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/Single/cabal.out b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/Single/cabal.out --- a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/Single/cabal.out +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/Single/cabal.out @@ -15,5 +15,4 @@ # cabal v2-run Up to date # cabal v2-run -cabal: Cannot run the package bar, it is not in this project (either directly or indirectly). If you want to add it to the project then edit the cabal.project file. - +Error: cabal: Cannot run the package bar, it is not in this project (either directly or indirectly). If you want to add it to the project then edit the cabal.project file. diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/LocalPackageWithCustomSetup/build-local-package-with-custom-setup.out b/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/LocalPackageWithCustomSetup/build-local-package-with-custom-setup.out --- a/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/LocalPackageWithCustomSetup/build-local-package-with-custom-setup.out +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/LocalPackageWithCustomSetup/build-local-package-with-custom-setup.out @@ -1,2 +1,2 @@ -# cabal v1-update +# cabal v2-update Downloading the latest package list from test-local-repo diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/LocalPackageWithCustomSetup/build-local-package-with-custom-setup.test.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/LocalPackageWithCustomSetup/build-local-package-with-custom-setup.test.hs --- a/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/LocalPackageWithCustomSetup/build-local-package-with-custom-setup.test.hs +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/LocalPackageWithCustomSetup/build-local-package-with-custom-setup.test.hs @@ -4,7 +4,7 @@ -- in the repository. main = withShorterPathForNewBuildStore $ \storeDir -> cabalTest $ do - skipUnless =<< hasNewBuildCompatBootCabal + skipUnless "no v2-build compatible boot-Cabal" =<< hasNewBuildCompatBootCabal withRepo "repo" $ do r <- recordMode DoNotRecord $ cabalG' ["--store-dir=" ++ storeDir] "v2-build" ["pkg"] -- pkg's setup script should print out a message that it imported from diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/RemotePackageWithCustomSetup/build-package-from-repo-with-custom-setup.out b/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/RemotePackageWithCustomSetup/build-package-from-repo-with-custom-setup.out --- a/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/RemotePackageWithCustomSetup/build-package-from-repo-with-custom-setup.out +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/RemotePackageWithCustomSetup/build-package-from-repo-with-custom-setup.out @@ -1,4 +1,4 @@ -# cabal v1-update +# cabal v2-update Downloading the latest package list from test-local-repo # pkg my-exe pkg Main.hs: remote-pkg-2.0 diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/RemotePackageWithCustomSetup/build-package-from-repo-with-custom-setup.test.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/RemotePackageWithCustomSetup/build-package-from-repo-with-custom-setup.test.hs --- a/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/RemotePackageWithCustomSetup/build-package-from-repo-with-custom-setup.test.hs +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/RemotePackageWithCustomSetup/build-package-from-repo-with-custom-setup.test.hs @@ -6,9 +6,9 @@ cabalTest $ do -- TODO: Debug this failure on Windows. - skipIf =<< isWindows + skipIfWindows - skipUnless =<< hasNewBuildCompatBootCabal + skipUnless "no v2-build compatible boot-Cabal" =<< hasNewBuildCompatBootCabal withRepo "repo" $ do r1 <- recordMode DoNotRecord $ cabalG' ["--store-dir=" ++ storeDir] "v2-build" ["pkg:my-exe"] -- remote-pkg's setup script should print out a message that it imported from diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T3827/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/T3827/cabal.test.hs --- a/cabal/cabal-testsuite/PackageTests/NewBuild/T3827/cabal.test.hs +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T3827/cabal.test.hs @@ -1,3 +1,6 @@ import Test.Cabal.Prelude main = cabalTest $ do - cabal "v2-build" ["exe:q"] + linux <- isLinux + osx <- isOSX + skipIf "8032 heisenbug profiling" (linux || osx) + cabal "v2-build" ["exe:q"] diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T3978/cabal.out b/cabal/cabal-testsuite/PackageTests/NewBuild/T3978/cabal.out --- a/cabal/cabal-testsuite/PackageTests/NewBuild/T3978/cabal.out +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T3978/cabal.out @@ -1,6 +1,6 @@ # cabal v2-build Resolving dependencies... -cabal: Could not resolve dependencies: +Error: cabal: Could not resolve dependencies: [__0] trying: p-1.0 (user goal) [__1] next goal: q (user goal) [__1] rejecting: q-1.0 (requires library from p, but the component is not buildable in the current environment) diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T4288/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/T4288/cabal.test.hs --- a/cabal/cabal-testsuite/PackageTests/NewBuild/T4288/cabal.test.hs +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T4288/cabal.test.hs @@ -7,7 +7,7 @@ -- to the setup script are compatible with the version of Cabal that it depends -- on, even though Cabal is only a transitive dependency. main = cabalTest $ do - skipUnless =<< hasNewBuildCompatBootCabal + skipUnless "no v2-build compatible boot-Cabal" =<< hasNewBuildCompatBootCabal r <- recordMode DoNotRecord $ cabal' "v2-build" ["T4288"] assertOutputContains "This is setup-helper-1.0." r assertOutputContains diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T4375/cabal.out b/cabal/cabal-testsuite/PackageTests/NewBuild/T4375/cabal.out --- a/cabal/cabal-testsuite/PackageTests/NewBuild/T4375/cabal.out +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T4375/cabal.out @@ -1,17 +1,7 @@ -# cabal v1-update +# cabal v2-update Downloading the latest package list from test-local-repo # cabal v2-build Resolving dependencies... Build profile: -w ghc- -O1 In order, the following will be built: - - old-locale-1.0.0.7 (lib) (requires download & build) - - old-time-1.1.0.3 (lib) (requires download & build) - a-0.1 (lib:a) (first run) -Configuring library for old-locale-1.0.0.7.. -Preprocessing library for old-locale-1.0.0.7.. -Building library for old-locale-1.0.0.7.. -Installing library in -Configuring library for old-time-1.1.0.3.. -Preprocessing library for old-time-1.1.0.3.. -Building library for old-time-1.1.0.3.. -Installing library in diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T4375/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/T4375/cabal.test.hs --- a/cabal/cabal-testsuite/PackageTests/NewBuild/T4375/cabal.test.hs +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T4375/cabal.test.hs @@ -1,12 +1,13 @@ import Test.Cabal.Prelude main = withShorterPathForNewBuildStore $ \storeDir -> + -- TODO: is this test ever run? cabalTest $ do -- Don't run this test unless the GHC is sufficiently recent -- to not ship boot old-time/old-locale - skipUnless =<< ghcVersionIs (>= mkVersion [7,11]) + skipUnlessGhcVersion ">= 7.11" -- Don't run this test on GHC 8.2, which ships with Cabal 2.0, -- which is not eligible for old-style Custom setup (if -- we had the full Hackage index, we'd try it.) - skipUnless =<< ghcVersionIs (< mkVersion [8,1]) + skipUnlessGhcVersion "< 8.1" withRepo "repo" $ do cabalG ["--store-dir=" ++ storeDir] "v2-build" ["a"] diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T4450/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/T4450/cabal.test.hs --- a/cabal/cabal-testsuite/PackageTests/NewBuild/T4450/cabal.test.hs +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T4450/cabal.test.hs @@ -1,6 +1,6 @@ import Test.Cabal.Prelude main = cabalTest $ do - skipUnless =<< hasNewBuildCompatBootCabal + skipUnless "no v2-build compatible boot-Cabal" =<< hasNewBuildCompatBootCabal -- Custom Setups inconsistently report output depending -- on your boot GHC. recordMode DoNotRecord $ cabal "v2-build" ["foo"] diff --git a/cabal/cabal-testsuite/PackageTests/NewConfigure/ConfigFile/ConfigFile.cabal b/cabal/cabal-testsuite/PackageTests/NewConfigure/ConfigFile/ConfigFile.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewConfigure/ConfigFile/ConfigFile.cabal @@ -0,0 +1,7 @@ +name: ConfigFile +version: 0.1.0.0 +author: Foo Bar +maintainer: cabal-dev@haskell.org +build-type: Simple +cabal-version: >=1.10 + diff --git a/cabal/cabal-testsuite/PackageTests/NewConfigure/ConfigFile/Setup.hs b/cabal/cabal-testsuite/PackageTests/NewConfigure/ConfigFile/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewConfigure/ConfigFile/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cabal/cabal-testsuite/PackageTests/NewConfigure/ConfigFile/cabal.out b/cabal/cabal-testsuite/PackageTests/NewConfigure/ConfigFile/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewConfigure/ConfigFile/cabal.out @@ -0,0 +1,5 @@ +# cabal v2-configure +Config file not written due to flag(s). +# cabal v2-configure +Config file not written due to flag(s). +# cabal v2-configure diff --git a/cabal/cabal-testsuite/PackageTests/NewConfigure/ConfigFile/cabal.project b/cabal/cabal-testsuite/PackageTests/NewConfigure/ConfigFile/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewConfigure/ConfigFile/cabal.project @@ -0,0 +1,1 @@ +packages: . diff --git a/cabal/cabal-testsuite/PackageTests/NewConfigure/ConfigFile/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/NewConfigure/ConfigFile/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewConfigure/ConfigFile/cabal.test.hs @@ -0,0 +1,18 @@ +import Test.Cabal.Prelude + +-- Test that 'cabal v2-configure' generates the config file appropriately +main = withShorterPathForNewBuildStore $ \storeDir -> + cabalTest . withSourceCopy $ do + cwd <- fmap testCurrentDir getTestEnv + let configFile = cwd "cabal.project.local" + + shouldNotExist configFile + + -- should not create config file with --dry-run or --only-download + cabalG ["--store-dir=" ++ storeDir] "v2-configure" ["--dry-run"] + cabalG ["--store-dir=" ++ storeDir] "v2-configure" ["--only-download"] + shouldNotExist configFile + + -- should create the config file + cabalG ["--store-dir=" ++ storeDir] "v2-configure" [] + shouldExist configFile diff --git a/cabal/cabal-testsuite/PackageTests/NewConfigure/LocalConfigOverwrite/cabal.out b/cabal/cabal-testsuite/PackageTests/NewConfigure/LocalConfigOverwrite/cabal.out --- a/cabal/cabal-testsuite/PackageTests/NewConfigure/LocalConfigOverwrite/cabal.out +++ b/cabal/cabal-testsuite/PackageTests/NewConfigure/LocalConfigOverwrite/cabal.out @@ -1,31 +1,4 @@ # cabal v2-configure 'cabal.project.local' already exists, backing it up to 'cabal.project.local~'. -Resolving dependencies... -Build profile: -w ghc- -O1 -In order, the following would be built: - - NewConfigure-0.1.0.0 (lib) (first run) # cabal v2-configure -'cabal.project.local' already exists, backing it up to 'cabal.project.local~0'. -Build profile: -w ghc- -O1 -In order, the following would be built: - - NewConfigure-0.1.0.0 (lib) (first run) -# cabal v2-configure -'cabal.project.local' already exists, backing it up to 'cabal.project.local~1'. -Build profile: -w ghc- -O1 -In order, the following would be built: - - NewConfigure-0.1.0.0 (lib) (first run) -# cabal v2-configure 'foo.project.local' already exists, backing it up to 'foo.project.local~'. -Build profile: -w ghc- -O1 -In order, the following would be built: - - NewConfigure-0.1.0.0 (lib) (first run) -# cabal v2-configure -'foo.project.local' already exists, backing it up to 'foo.project.local~0'. -Build profile: -w ghc- -O1 -In order, the following would be built: - - NewConfigure-0.1.0.0 (lib) (first run) -# cabal v2-configure -'foo.project.local' already exists, backing it up to 'foo.project.local~1'. -Build profile: -w ghc- -O1 -In order, the following would be built: - - NewConfigure-0.1.0.0 (lib) (first run) diff --git a/cabal/cabal-testsuite/PackageTests/NewConfigure/LocalConfigOverwrite/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/NewConfigure/LocalConfigOverwrite/cabal.test.hs --- a/cabal/cabal-testsuite/PackageTests/NewConfigure/LocalConfigOverwrite/cabal.test.hs +++ b/cabal/cabal-testsuite/PackageTests/NewConfigure/LocalConfigOverwrite/cabal.test.hs @@ -4,18 +4,8 @@ withSourceCopy $ do cabal' "v2-configure" [] >>= assertOutputContains "backing it up to 'cabal.project.local~'" - cabal' "v2-configure" [] >>= - assertOutputContains "backing it up to 'cabal.project.local~0'" - cabal' "v2-configure" [] >>= - assertOutputContains "backing it up to 'cabal.project.local~1'" -- With --project-file cabal' "v2-configure" ["--project-file", "foo.project"] >>= assertOutputContains "'foo.project.local' already exists, backing it up to 'foo.project.local~'" - cabal' "v2-configure" ["--project-file", "foo.project"] >>= - assertOutputContains - "'foo.project.local' already exists, backing it up to 'foo.project.local~0'" - cabal' "v2-configure" ["--project-file", "foo.project"] >>= - assertOutputContains - "'foo.project.local' already exists, backing it up to 'foo.project.local~1'" diff --git a/cabal/cabal-testsuite/PackageTests/NewFreeze/BuildTools/new_freeze.out b/cabal/cabal-testsuite/PackageTests/NewFreeze/BuildTools/new_freeze.out --- a/cabal/cabal-testsuite/PackageTests/NewFreeze/BuildTools/new_freeze.out +++ b/cabal/cabal-testsuite/PackageTests/NewFreeze/BuildTools/new_freeze.out @@ -1,12 +1,12 @@ -# cabal v1-update +# cabal v2-update Downloading the latest package list from test-local-repo # cabal v2-build Resolving dependencies... Build profile: -w ghc- -O1 In order, the following would be built: - - my-build-tool-dep-1.0 (exe:my-build-tool) (requires download & build) - - my-build-tool-dep-3.0 (exe:my-build-tool) (requires download & build) - - my-library-dep-1.0 (lib) (requires download & build) + - my-build-tool-dep-1.0 (exe:my-build-tool) (requires build) + - my-build-tool-dep-3.0 (exe:my-build-tool) (requires build) + - my-library-dep-1.0 (lib) (requires build) - my-local-package-1.0 (lib) (first run) # cabal v2-freeze Resolving dependencies... @@ -15,7 +15,7 @@ Resolving dependencies... Build profile: -w ghc- -O1 In order, the following would be built: - - my-build-tool-dep-1.0 (exe:my-build-tool) (requires download & build) - - my-build-tool-dep-2.0 (exe:my-build-tool) (requires download & build) - - my-library-dep-1.0 (lib) (requires download & build) + - my-build-tool-dep-1.0 (exe:my-build-tool) (requires build) + - my-build-tool-dep-2.0 (exe:my-build-tool) (requires build) + - my-library-dep-1.0 (lib) (requires build) - my-local-package-1.0 (lib) (first run) diff --git a/cabal/cabal-testsuite/PackageTests/NewFreeze/Flags/new_freeze.out b/cabal/cabal-testsuite/PackageTests/NewFreeze/Flags/new_freeze.out --- a/cabal/cabal-testsuite/PackageTests/NewFreeze/Flags/new_freeze.out +++ b/cabal/cabal-testsuite/PackageTests/NewFreeze/Flags/new_freeze.out @@ -1,11 +1,11 @@ -# cabal v1-update +# cabal v2-update Downloading the latest package list from test-local-repo # cabal v2-build Resolving dependencies... Build profile: -w ghc- -O1 In order, the following would be built: - - true-dep-1.0 (lib) (requires download & build) - - my-library-dep-1.0 (lib) (requires download & build) + - true-dep-1.0 (lib) (requires build) + - my-library-dep-1.0 (lib) (requires build) - my-local-package-1.0 (lib) (first run) # cabal v2-freeze Resolving dependencies... @@ -14,6 +14,6 @@ Resolving dependencies... Build profile: -w ghc- -O1 In order, the following would be built: - - false-dep-1.0 (lib) (requires download & build) - - my-library-dep-1.0 (lib) (requires download & build) + - false-dep-1.0 (lib) (requires build) + - my-library-dep-1.0 (lib) (requires build) - my-local-package-1.0 (lib) (first run) diff --git a/cabal/cabal-testsuite/PackageTests/NewFreeze/FreezeFile/new_freeze.out b/cabal/cabal-testsuite/PackageTests/NewFreeze/FreezeFile/new_freeze.out --- a/cabal/cabal-testsuite/PackageTests/NewFreeze/FreezeFile/new_freeze.out +++ b/cabal/cabal-testsuite/PackageTests/NewFreeze/FreezeFile/new_freeze.out @@ -1,19 +1,23 @@ -# cabal v1-update +# cabal v2-update Downloading the latest package list from test-local-repo # cabal v2-build Resolving dependencies... Build profile: -w ghc- -O1 In order, the following would be built: - - my-library-dep-2.0 (lib) (requires download & build) + - my-library-dep-2.0 (lib) (requires build) - my-local-package-1.0 (exe:my-exe) (first run) # cabal v2-freeze +Freeze file not written due to flag(s) +# cabal v2-freeze +Freeze file not written due to flag(s) +# cabal v2-freeze Resolving dependencies... Wrote freeze file: /new_freeze.dist/source/cabal.project.freeze # cabal v2-build Resolving dependencies... Build profile: -w ghc- -O1 In order, the following will be built: - - my-library-dep-1.0 (lib) (requires download & build) + - my-library-dep-1.0 (lib) (requires build) - my-local-package-1.0 (exe:my-exe) (first run) Configuring library for my-library-dep-1.0.. Preprocessing library for my-library-dep-1.0.. @@ -28,7 +32,7 @@ Resolving dependencies... Build profile: -w ghc- -O1 In order, the following would be built: - - my-library-dep-2.0 (lib) (requires download & build) + - my-library-dep-2.0 (lib) (requires build) - my-local-package-1.0 (exe:my-exe) (configuration changed) # cabal v2-freeze Wrote freeze file: /new_freeze.dist/source/cabal.project.freeze diff --git a/cabal/cabal-testsuite/PackageTests/NewFreeze/FreezeFile/new_freeze.test.hs b/cabal/cabal-testsuite/PackageTests/NewFreeze/FreezeFile/new_freeze.test.hs --- a/cabal/cabal-testsuite/PackageTests/NewFreeze/FreezeFile/new_freeze.test.hs +++ b/cabal/cabal-testsuite/PackageTests/NewFreeze/FreezeFile/new_freeze.test.hs @@ -16,6 +16,11 @@ -- v2-build should choose the latest version for the dependency. cabalG' ["--store-dir=" ++ storeDir] "v2-build" ["--dry-run"] >>= assertUsesLatestDependency + -- should not create freeze file with --dry-run or --only-download flags + cabalG' ["--store-dir=" ++ storeDir] "v2-freeze" ["--dry-run"] + cabalG' ["--store-dir=" ++ storeDir] "v2-freeze" ["--only-download"] + shouldNotExist freezeFile + -- Freeze a dependency on the older version. cabalG ["--store-dir=" ++ storeDir] "v2-freeze" ["--constraint=my-library-dep==1.0"] diff --git a/cabal/cabal-testsuite/PackageTests/NewHaddock/Fails/cabal.out b/cabal/cabal-testsuite/PackageTests/NewHaddock/Fails/cabal.out --- a/cabal/cabal-testsuite/PackageTests/NewHaddock/Fails/cabal.out +++ b/cabal/cabal-testsuite/PackageTests/NewHaddock/Fails/cabal.out @@ -12,4 +12,4 @@ - example-1.0 (lib) (first run) Preprocessing library for example-1.0.. Running Haddock on library for example-1.0.. -cabal: Failed to build documentation for example-1.0-inplace. +Error: cabal: Failed to build documentation for example-1.0-inplace. diff --git a/cabal/cabal-testsuite/PackageTests/NewSdist/DeterministicTrivial/deterministic.test.hs b/cabal/cabal-testsuite/PackageTests/NewSdist/DeterministicTrivial/deterministic.test.hs --- a/cabal/cabal-testsuite/PackageTests/NewSdist/DeterministicTrivial/deterministic.test.hs +++ b/cabal/cabal-testsuite/PackageTests/NewSdist/DeterministicTrivial/deterministic.test.hs @@ -1,10 +1,13 @@ import Test.Cabal.Prelude import qualified Data.ByteString as BS -import qualified Data.ByteString.Base16 as BS16 -import qualified Crypto.Hash.SHA256 as SHA256 +-- import qualified Data.ByteString.Base16 as BS16 +-- import qualified Crypto.Hash.SHA256 as SHA256 import System.FilePath ( () ) + -- Note: we cannot simply use `expectBroken` or `skip` or similar + -- becuase this test fails on imports (see #8357). + main = cabalTest $ do cabal "v2-sdist" ["deterministic"] env <- getTestEnv @@ -21,4 +24,6 @@ known <- liftIO (BS.readFile knownSdist) unknown <- liftIO (BS.readFile mySdist) - assertEqual "hashes didn't match for sdist" (BS16.encode $ SHA256.hash known) (BS16.encode $ SHA256.hash unknown) + skipIf "#8356" True -- bogus, just to indicate that the test is skipped + assertEqual "hashes didn't match for sdist" True True + -- assertEqual "hashes didn't match for sdist" (BS16.encode $ SHA256.hash known) (BS16.encode $ SHA256.hash unknown) diff --git a/cabal/cabal-testsuite/PackageTests/NewSdist/ManyDataFiles/many-data-files.test.hs b/cabal/cabal-testsuite/PackageTests/NewSdist/ManyDataFiles/many-data-files.test.hs --- a/cabal/cabal-testsuite/PackageTests/NewSdist/ManyDataFiles/many-data-files.test.hs +++ b/cabal/cabal-testsuite/PackageTests/NewSdist/ManyDataFiles/many-data-files.test.hs @@ -14,4 +14,4 @@ forM_ [1 .. n + 100] $ \i -> liftIO $ BS.writeFile (cwd "data" ("data-file-" ++ show i) <.> "txt") (BS.pack "a data file\n") cabal "v2-sdist" ["many-data-files"] - Nothing -> skip + Nothing -> skip "no open file limit" diff --git a/cabal/cabal-testsuite/PackageTests/NewSdist/MultiTarget/all-test-sute.out b/cabal/cabal-testsuite/PackageTests/NewSdist/MultiTarget/all-test-sute.out --- a/cabal/cabal-testsuite/PackageTests/NewSdist/MultiTarget/all-test-sute.out +++ b/cabal/cabal-testsuite/PackageTests/NewSdist/MultiTarget/all-test-sute.out @@ -1,2 +1,2 @@ # cabal v2-sdist -cabal: It is not possible to package only the test suites from a package for distribution. Only entire packages may be packaged for distribution. +Error: cabal: It is not possible to package only the test suites from a package for distribution. Only entire packages may be packaged for distribution. diff --git a/cabal/cabal-testsuite/PackageTests/NewSdist/MultiTarget/multi-archive-to-stdout.out b/cabal/cabal-testsuite/PackageTests/NewSdist/MultiTarget/multi-archive-to-stdout.out --- a/cabal/cabal-testsuite/PackageTests/NewSdist/MultiTarget/multi-archive-to-stdout.out +++ b/cabal/cabal-testsuite/PackageTests/NewSdist/MultiTarget/multi-archive-to-stdout.out @@ -1,2 +1,2 @@ # cabal v2-sdist -cabal: Can't write multiple tarballs to standard output! +Error: cabal: Can't write multiple tarballs to standard output! diff --git a/cabal/cabal-testsuite/PackageTests/NewSdist/MultiTarget/target-remote-package.out b/cabal/cabal-testsuite/PackageTests/NewSdist/MultiTarget/target-remote-package.out --- a/cabal/cabal-testsuite/PackageTests/NewSdist/MultiTarget/target-remote-package.out +++ b/cabal/cabal-testsuite/PackageTests/NewSdist/MultiTarget/target-remote-package.out @@ -1,2 +1,2 @@ # cabal v2-sdist -cabal: The package base cannot be packaged for distribution, because it is not local to this project. +Error: cabal: The package base cannot be packaged for distribution, because it is not local to this project. diff --git a/cabal/cabal-testsuite/PackageTests/NewSdist/MultiTarget/valid-and-test-suite.out b/cabal/cabal-testsuite/PackageTests/NewSdist/MultiTarget/valid-and-test-suite.out --- a/cabal/cabal-testsuite/PackageTests/NewSdist/MultiTarget/valid-and-test-suite.out +++ b/cabal/cabal-testsuite/PackageTests/NewSdist/MultiTarget/valid-and-test-suite.out @@ -1,2 +1,2 @@ # cabal v2-sdist -cabal: The component test suite 'a-tests' cannot be packaged for distribution on its own. Only entire packages may be packaged for distribution. +Error: cabal: The component test suite 'a-tests' cannot be packaged for distribution on its own. Only entire packages may be packaged for distribution. diff --git a/cabal/cabal-testsuite/PackageTests/NewUpdate/UpdateIndexState/repo/pkg-1.0/pkg.cabal b/cabal/cabal-testsuite/PackageTests/NewUpdate/UpdateIndexState/repo/pkg-1.0/pkg.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewUpdate/UpdateIndexState/repo/pkg-1.0/pkg.cabal @@ -0,0 +1,8 @@ +name: pkg +version: 1.0 +build-type: Simple +cabal-version: >= 1.2 + +executable my-exe + main-is: Main.hs + build-depends: base diff --git a/cabal/cabal-testsuite/PackageTests/NewUpdate/UpdateIndexState/update-index-state.out b/cabal/cabal-testsuite/PackageTests/NewUpdate/UpdateIndexState/update-index-state.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewUpdate/UpdateIndexState/update-index-state.out @@ -0,0 +1,18 @@ +# cabal update +Warning: Caught exception during _mirrors lookup:user error (res_query(3) failed) +Warning: No mirrors found for http://localhost:8000/ +Downloading the latest package list from repository.localhost +Package list of repository.localhost has been updated. +The index-state is set to 2022-01-28T02:36:41Z. +# cabal update +Downloading the latest package list from repository.localhost +Package list of repository.localhost is up to date. +The index-state is set to 2016-09-24T17:47:48Z. +To revert to previous state run: + cabal v2-update 'repository.localhost,2022-01-28T02:36:41Z' +# cabal update +Downloading the latest package list from repository.localhost +Package list of repository.localhost is up to date. +The index-state is set to 2022-01-28T02:36:41Z. +To revert to previous state run: + cabal v2-update 'repository.localhost,2016-09-24T17:47:48Z' diff --git a/cabal/cabal-testsuite/PackageTests/NewUpdate/UpdateIndexState/update-index-state.test.hs b/cabal/cabal-testsuite/PackageTests/NewUpdate/UpdateIndexState/update-index-state.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewUpdate/UpdateIndexState/update-index-state.test.hs @@ -0,0 +1,9 @@ +import Test.Cabal.Prelude + +main = cabalTest $ withRemoteRepo "repo" $ do + -- This test causes a warning about missing mirrors, the warning is + -- included in the expected output to make the test pass but it's not + -- part of the test expectations. + cabal "update" ["repository.localhost,2022-01-28T02:36:41Z"] + cabal "update" ["repository.localhost,2016-09-24T17:47:48Z"] + cabal "update" ["repository.localhost,2022-01-28T02:36:41Z"] diff --git a/cabal/cabal-testsuite/PackageTests/Outdated/cabal.config b/cabal/cabal-testsuite/PackageTests/Outdated/cabal.config --- a/cabal/cabal-testsuite/PackageTests/Outdated/cabal.config +++ b/cabal/cabal-testsuite/PackageTests/Outdated/cabal.config @@ -1,1 +1,1 @@ -constraints: base == 3.0.3.2, template-haskell ==2.3.0.0 +constraints: base == 3.0.3.2, template-haskell ==2.3.0.0, binary ==0.8.5.0 diff --git a/cabal/cabal-testsuite/PackageTests/Outdated/cabal.project.freeze b/cabal/cabal-testsuite/PackageTests/Outdated/cabal.project.freeze --- a/cabal/cabal-testsuite/PackageTests/Outdated/cabal.project.freeze +++ b/cabal/cabal-testsuite/PackageTests/Outdated/cabal.project.freeze @@ -1,1 +1,1 @@ -constraints: base == 3.0.3.2, template-haskell ==2.3.0.0 +constraints: base == 3.0.3.2, template-haskell ==2.3.0.0, binary ==0.8.5.0 diff --git a/cabal/cabal-testsuite/PackageTests/Outdated/cabal.project.missing.freeze b/cabal/cabal-testsuite/PackageTests/Outdated/cabal.project.missing.freeze new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Outdated/cabal.project.missing.freeze @@ -0,0 +1,1 @@ +packages: ./ diff --git a/cabal/cabal-testsuite/PackageTests/Outdated/my.cabal b/cabal/cabal-testsuite/PackageTests/Outdated/my.cabal --- a/cabal/cabal-testsuite/PackageTests/Outdated/my.cabal +++ b/cabal/cabal-testsuite/PackageTests/Outdated/my.cabal @@ -7,7 +7,7 @@ library default-language: Haskell2010 exposed-modules: Foo - build-depends: base >= 3 && < 4 + build-depends: base >= 3 && < 4, binary == 0.8.6.* test-suite tests-Foo default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/Outdated/outdated-project-file.out b/cabal/cabal-testsuite/PackageTests/Outdated/outdated-project-file.out --- a/cabal/cabal-testsuite/PackageTests/Outdated/outdated-project-file.out +++ b/cabal/cabal-testsuite/PackageTests/Outdated/outdated-project-file.out @@ -1,4 +1,4 @@ -# cabal v1-update +# cabal v2-update Downloading the latest package list from test-local-repo # cabal outdated Outdated dependencies: @@ -7,4 +7,4 @@ Outdated dependencies: base ==3.0.3.2 (latest: 4.0.0.0) # cabal outdated -cabal: --project-file must only be used with --v2-freeze-file. +Error: cabal: --project-file must only be used with --v2-freeze-file. diff --git a/cabal/cabal-testsuite/PackageTests/Outdated/outdated-project-file.test.hs b/cabal/cabal-testsuite/PackageTests/Outdated/outdated-project-file.test.hs --- a/cabal/cabal-testsuite/PackageTests/Outdated/outdated-project-file.test.hs +++ b/cabal/cabal-testsuite/PackageTests/Outdated/outdated-project-file.test.hs @@ -3,11 +3,13 @@ res <- cabal' "outdated" ["--v2-freeze-file", "--project-file", "variant.project"] assertOutputContains "base" res assertOutputDoesNotContain "template-haskell" res + assertOutputDoesNotContain "binary" res -- Test last-one-wins behaviour. res <- cabal' "outdated" ["--v2-freeze-file", "--project-file", "cabal.project", "--project-file", "variant.project"] assertOutputContains "base" res assertOutputDoesNotContain "template-haskell" res + assertOutputDoesNotContain "binary" res -- Test for erroring on --project-file without --v2-freeze-file fails $ cabal "outdated" ["--project-file", "variant.project"] diff --git a/cabal/cabal-testsuite/PackageTests/Outdated/outdated.out b/cabal/cabal-testsuite/PackageTests/Outdated/outdated.out --- a/cabal/cabal-testsuite/PackageTests/Outdated/outdated.out +++ b/cabal/cabal-testsuite/PackageTests/Outdated/outdated.out @@ -1,8 +1,8 @@ -# cabal v1-update +# cabal v2-update Downloading the latest package list from test-local-repo # cabal outdated Outdated dependencies: -base ==3.* (latest: 4.0.0.0) +base >=3 && <4 (latest: 4.0.0.0) template-haskell >=2.3.0.0 && <2.4 (latest: 2.4.0.0) # cabal outdated Outdated dependencies: diff --git a/cabal/cabal-testsuite/PackageTests/Outdated/outdated.test.hs b/cabal/cabal-testsuite/PackageTests/Outdated/outdated.test.hs --- a/cabal/cabal-testsuite/PackageTests/Outdated/outdated.test.hs +++ b/cabal/cabal-testsuite/PackageTests/Outdated/outdated.test.hs @@ -3,24 +3,29 @@ cabal' "outdated" [] >>= (\out -> do assertOutputContains "base" out - assertOutputContains "template-haskell" out) + assertOutputContains "template-haskell" out + assertOutputDoesNotContain "binary" out) cabal' "outdated" ["--ignore=base"] >>= (\out -> do assertOutputDoesNotContain "base" out - assertOutputContains "template-haskell" out) + assertOutputContains "template-haskell" out + assertOutputDoesNotContain "binary" out) cabal' "outdated" ["--ignore=base,template-haskell"] >>= (\out -> do assertOutputDoesNotContain "base" out - assertOutputDoesNotContain "template-haskell" out) + assertOutputDoesNotContain "template-haskell" out + assertOutputDoesNotContain "binary" out) cabal' "outdated" ["--minor=base"] >>= (\out -> do assertOutputDoesNotContain "base" out - assertOutputContains "template-haskell" out) + assertOutputContains "template-haskell" out + assertOutputDoesNotContain "binary" out) cabal' "outdated" ["--minor=base,template-haskell"] >>= (\out -> do assertOutputDoesNotContain "base" out - assertOutputDoesNotContain "template-haskell" out) + assertOutputDoesNotContain "template-haskell" out + assertOutputDoesNotContain "binary" out) diff --git a/cabal/cabal-testsuite/PackageTests/Outdated/outdated_freeze.out b/cabal/cabal-testsuite/PackageTests/Outdated/outdated_freeze.out --- a/cabal/cabal-testsuite/PackageTests/Outdated/outdated_freeze.out +++ b/cabal/cabal-testsuite/PackageTests/Outdated/outdated_freeze.out @@ -1,20 +1,28 @@ -# cabal v1-update +# cabal v2-update Downloading the latest package list from test-local-repo # cabal outdated Outdated dependencies: base ==3.0.3.2 (latest: 4.0.0.0) template-haskell ==2.3.0.0 (latest: 2.4.0.0) +binary ==0.8.5.0 (latest: 0.8.6.0) # cabal outdated All dependencies are up to date. # cabal outdated Outdated dependencies: template-haskell ==2.3.0.0 (latest: 2.3.0.1) +binary ==0.8.5.0 (latest: 0.8.6.0) # cabal outdated Outdated dependencies: base ==3.0.3.2 (latest: 4.0.0.0) template-haskell ==2.3.0.0 (latest: 2.4.0.0) +binary ==0.8.5.0 (latest: 0.8.6.0) # cabal outdated All dependencies are up to date. # cabal outdated Outdated dependencies: template-haskell ==2.3.0.0 (latest: 2.3.0.1) +binary ==0.8.5.0 (latest: 0.8.6.0) +# cabal outdated +Error: cabal: Couldn't find a freeze file expected at: /cabal.project.missing.freeze.freeze + +We are looking for this file because you supplied '--project-file' or '--v2-freeze-file'. When one of these flags is given, we try to read the dependencies from a freeze file. If it is undesired behaviour, you should not use these flags, otherwise please generate a freeze file via 'cabal freeze'. diff --git a/cabal/cabal-testsuite/PackageTests/Outdated/outdated_freeze.test.hs b/cabal/cabal-testsuite/PackageTests/Outdated/outdated_freeze.test.hs --- a/cabal/cabal-testsuite/PackageTests/Outdated/outdated_freeze.test.hs +++ b/cabal/cabal-testsuite/PackageTests/Outdated/outdated_freeze.test.hs @@ -1,18 +1,23 @@ import Test.Cabal.Prelude -main = cabalTest $ withRepo "repo" - $ forM_ ["--v2-freeze-file", "--freeze-file"] $ \arg -> do +main = cabalTest $ withRepo "repo" $ do + forM_ ["--v2-freeze-file", "--freeze-file"] $ \arg -> do + cabal' "outdated" [arg] >>= + (\out -> do + assertOutputContains "base" out + assertOutputContains "template-haskell" out + assertOutputContains "binary" out) - cabal' "outdated" [arg] >>= - (\out -> do - assertOutputContains "base" out - assertOutputContains "template-haskell" out) + cabal' "outdated" [arg, "--ignore=base,template-haskell,binary"] >>= + (\out -> do + assertOutputDoesNotContain "base" out + assertOutputDoesNotContain "template-haskell" out + assertOutputDoesNotContain "binary" out) - cabal' "outdated" [arg, "--ignore=base,template-haskell"] >>= - (\out -> do - assertOutputDoesNotContain "base" out - assertOutputDoesNotContain "template-haskell" out) + cabal' "outdated" [arg, "--minor=base,template-haskell,binary"] >>= + (\out -> do + assertOutputDoesNotContain "base" out + assertOutputContains "template-haskell" out + assertOutputContains "binary" out) - cabal' "outdated" [arg, "--minor=base,template-haskell"] >>= - (\out -> do - assertOutputDoesNotContain "base" out - assertOutputContains "template-haskell" out) + fails $ cabal' "outdated" ["--project-file=cabal.project.missing.freeze", "--v2-freeze-file"] + return () diff --git a/cabal/cabal-testsuite/PackageTests/Outdated/repo/binary-0.8.5.0/binary.cabal b/cabal/cabal-testsuite/PackageTests/Outdated/repo/binary-0.8.5.0/binary.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Outdated/repo/binary-0.8.5.0/binary.cabal @@ -0,0 +1,35 @@ +name: binary +version: 0.8.5.0 +license: BSD3 +license-file: LICENSE +author: Lennart Kolmodin +maintainer: Lennart Kolmodin, Don Stewart +homepage: https://github.com/kolmodin/binary +description: Efficient, pure binary serialisation using lazy ByteStrings. + Haskell values may be encoded to and from binary formats, + written to disk as binary, or sent over the network. + The format used can be automatically generated, or + you can choose to implement a custom format if needed. + Serialisation speeds of over 1 G\/sec have been observed, + so this library should be suitable for high performance + scenarios. +synopsis: Binary serialisation for Haskell values using lazy ByteStrings +category: Data, Parsing +stability: provisional +build-type: Simple +cabal-version: >= 1.8 + +library + build-depends: base >= 3 && < 5, bytestring >= 0.8.4, containers, array + hs-source-dirs: src + exposed-modules: Data.Binary, + Data.Binary.Put, + Data.Binary.Get, + Data.Binary.Get.Internal, + Data.Binary.Builder + + other-modules: Data.Binary.Class, + Data.Binary.Internal, + Data.Binary.Generic, + Data.Binary.FloatCast + ghc-options: -O2 -Wall -fliberate-case-threshold=1000 diff --git a/cabal/cabal-testsuite/PackageTests/Outdated/repo/binary-0.8.6.0/binary.cabal b/cabal/cabal-testsuite/PackageTests/Outdated/repo/binary-0.8.6.0/binary.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Outdated/repo/binary-0.8.6.0/binary.cabal @@ -0,0 +1,35 @@ +name: binary +version: 0.8.6.0 +license: BSD3 +license-file: LICENSE +author: Lennart Kolmodin +maintainer: Lennart Kolmodin, Don Stewart +homepage: https://github.com/kolmodin/binary +description: Efficient, pure binary serialisation using lazy ByteStrings. + Haskell values may be encoded to and from binary formats, + written to disk as binary, or sent over the network. + The format used can be automatically generated, or + you can choose to implement a custom format if needed. + Serialisation speeds of over 1 G\/sec have been observed, + so this library should be suitable for high performance + scenarios. +synopsis: Binary serialisation for Haskell values using lazy ByteStrings +category: Data, Parsing +stability: provisional +build-type: Simple +cabal-version: >= 1.8 + +library + build-depends: base >= 3 && < 5, bytestring >= 0.8.4, containers, array + hs-source-dirs: src + exposed-modules: Data.Binary, + Data.Binary.Put, + Data.Binary.Get, + Data.Binary.Get.Internal, + Data.Binary.Builder + + other-modules: Data.Binary.Class, + Data.Binary.Internal, + Data.Binary.Generic, + Data.Binary.FloatCast + ghc-options: -O2 -Wall -fliberate-case-threshold=1000 diff --git a/cabal/cabal-testsuite/PackageTests/Outdated/repo/binary-0.9.0.0/binary.cabal b/cabal/cabal-testsuite/PackageTests/Outdated/repo/binary-0.9.0.0/binary.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Outdated/repo/binary-0.9.0.0/binary.cabal @@ -0,0 +1,35 @@ +name: binary +version: 0.9.0.0 +license: BSD3 +license-file: LICENSE +author: Lennart Kolmodin +maintainer: Lennart Kolmodin, Don Stewart +homepage: https://github.com/kolmodin/binary +description: Efficient, pure binary serialisation using lazy ByteStrings. + Haskell values may be encoded to and from binary formats, + written to disk as binary, or sent over the network. + The format used can be automatically generated, or + you can choose to implement a custom format if needed. + Serialisation speeds of over 1 G\/sec have been observed, + so this library should be suitable for high performance + scenarios. +synopsis: Binary serialisation for Haskell values using lazy ByteStrings +category: Data, Parsing +stability: provisional +build-type: Simple +cabal-version: >= 1.8 + +library + build-depends: base >= 3 && < 5, bytestring >= 0.8.4, containers, array + hs-source-dirs: src + exposed-modules: Data.Binary, + Data.Binary.Put, + Data.Binary.Get, + Data.Binary.Get.Internal, + Data.Binary.Builder + + other-modules: Data.Binary.Class, + Data.Binary.Internal, + Data.Binary.Generic, + Data.Binary.FloatCast + ghc-options: -O2 -Wall -fliberate-case-threshold=1000 diff --git a/cabal/cabal-testsuite/PackageTests/Outdated/repo/preferred-versions b/cabal/cabal-testsuite/PackageTests/Outdated/repo/preferred-versions new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Outdated/repo/preferred-versions @@ -0,0 +1,1 @@ +binary <0.9.0.0 || >0.9.0.0 diff --git a/cabal/cabal-testsuite/PackageTests/PackageDB/cabal-fail-no-base.out b/cabal/cabal-testsuite/PackageTests/PackageDB/cabal-fail-no-base.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/PackageDB/cabal-fail-no-base.out @@ -0,0 +1,16 @@ +# Setup configure +Configuring p-1.0... +# Setup build +Preprocessing library for p-1.0.. +Building library for p-1.0.. +# Setup copy +Installing library in +# Setup register +Registering library for p-1.0.. +# cabal v2-build +Resolving dependencies... +Error: cabal: Could not resolve dependencies: +[__0] trying: q-1.0 (user goal) +[__1] unknown package: base (dependency of q) +[__1] fail (backjumping, conflict set: base, q) +After searching the rest of the dependency tree exhaustively, these were the goals I've had most trouble fulfilling: q (2), base (1) diff --git a/cabal/cabal-testsuite/PackageTests/PackageDB/cabal-fail-no-base.test.hs b/cabal/cabal-testsuite/PackageTests/PackageDB/cabal-fail-no-base.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/PackageDB/cabal-fail-no-base.test.hs @@ -0,0 +1,12 @@ +import Test.Cabal.Prelude +main = cabalTest $ do + withPackageDb $ do + withDirectory "p" $ + setup_install [] + + env <- getTestEnv + let pkgDbPath = testPackageDbDir env + + withDirectory "q" $ do + res <- fails $ cabal' "v2-build" ["--package-db=clear", "--package-db=" ++ pkgDbPath] + assertOutputContains "unknown package: base" res diff --git a/cabal/cabal-testsuite/PackageTests/PackageDB/cabal-fail-no-p.out b/cabal/cabal-testsuite/PackageTests/PackageDB/cabal-fail-no-p.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/PackageDB/cabal-fail-no-p.out @@ -0,0 +1,16 @@ +# Setup configure +Configuring p-1.0... +# Setup build +Preprocessing library for p-1.0.. +Building library for p-1.0.. +# Setup copy +Installing library in +# Setup register +Registering library for p-1.0.. +# cabal v2-build +Resolving dependencies... +Error: cabal: Could not resolve dependencies: +[__0] trying: q-1.0 (user goal) +[__1] unknown package: p (dependency of q) +[__1] fail (backjumping, conflict set: p, q) +After searching the rest of the dependency tree exhaustively, these were the goals I've had most trouble fulfilling: q (2), p (1) diff --git a/cabal/cabal-testsuite/PackageTests/PackageDB/cabal-fail-no-p.test.hs b/cabal/cabal-testsuite/PackageTests/PackageDB/cabal-fail-no-p.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/PackageDB/cabal-fail-no-p.test.hs @@ -0,0 +1,9 @@ +import Test.Cabal.Prelude +main = cabalTest $ do + withPackageDb $ do + withDirectory "p" $ + setup_install [] + + withDirectory "q" $ do + res <- fails $ cabal' "v2-build" [] + assertOutputContains "unknown package: p" res diff --git a/cabal/cabal-testsuite/PackageTests/PackageDB/cabal-fail-no-packagedbs.out b/cabal/cabal-testsuite/PackageTests/PackageDB/cabal-fail-no-packagedbs.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/PackageDB/cabal-fail-no-packagedbs.out @@ -0,0 +1,2 @@ +# cabal v2-build +Error: cabal: No package databases have been specified. If you use --package-db=clear, you must follow it with --package-db= with 'global', 'user' or a specific file. diff --git a/cabal/cabal-testsuite/PackageTests/PackageDB/cabal-fail-no-packagedbs.test.hs b/cabal/cabal-testsuite/PackageTests/PackageDB/cabal-fail-no-packagedbs.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/PackageDB/cabal-fail-no-packagedbs.test.hs @@ -0,0 +1,6 @@ +import Test.Cabal.Prelude +main = cabalTest $ do + withPackageDb $ do + withDirectory "p-no-package-dbs" $ do + res <- fails $ cabal' "v2-build" [] + assertOutputContains "No package databases have been specified." res diff --git a/cabal/cabal-testsuite/PackageTests/PackageDB/cabal-manual-packagedb.out b/cabal/cabal-testsuite/PackageTests/PackageDB/cabal-manual-packagedb.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/PackageDB/cabal-manual-packagedb.out @@ -0,0 +1,17 @@ +# Setup configure +Configuring p-1.0... +# Setup build +Preprocessing library for p-1.0.. +Building library for p-1.0.. +# Setup copy +Installing library in +# Setup register +Registering library for p-1.0.. +# cabal v2-build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - q-1.0 (exe:q) (first run) +Configuring executable 'q' for q-1.0.. +Preprocessing executable 'q' for q-1.0.. +Building executable 'q' for q-1.0.. diff --git a/cabal/cabal-testsuite/PackageTests/PackageDB/cabal-manual-packagedb.test.hs b/cabal/cabal-testsuite/PackageTests/PackageDB/cabal-manual-packagedb.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/PackageDB/cabal-manual-packagedb.test.hs @@ -0,0 +1,12 @@ +import Test.Cabal.Prelude +main = cabalTest $ do + withPackageDb $ do + withDirectory "p" $ + setup_install [] + + env <- getTestEnv + let pkgDbPath = testPackageDbDir env + withDirectory "q" $ + cabal "v2-build" [ "--package-db=clear" + , "--package-db=global" + , "--package-db=" ++ pkgDbPath] diff --git a/cabal/cabal-testsuite/PackageTests/PackageDB/cabal-packagedb.out b/cabal/cabal-testsuite/PackageTests/PackageDB/cabal-packagedb.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/PackageDB/cabal-packagedb.out @@ -0,0 +1,17 @@ +# Setup configure +Configuring p-1.0... +# Setup build +Preprocessing library for p-1.0.. +Building library for p-1.0.. +# Setup copy +Installing library in +# Setup register +Registering library for p-1.0.. +# cabal v2-build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - q-1.0 (exe:q) (first run) +Configuring executable 'q' for q-1.0.. +Preprocessing executable 'q' for q-1.0.. +Building executable 'q' for q-1.0.. diff --git a/cabal/cabal-testsuite/PackageTests/PackageDB/cabal-packagedb.test.hs b/cabal/cabal-testsuite/PackageTests/PackageDB/cabal-packagedb.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/PackageDB/cabal-packagedb.test.hs @@ -0,0 +1,10 @@ +import Test.Cabal.Prelude +main = cabalTest $ do + withPackageDb $ do + withDirectory "p" $ + setup_install [] + + env <- getTestEnv + let pkgDbPath = testPackageDbDir env + withDirectory "q" $ + cabal "v2-build" ["--package-db=" ++ pkgDbPath] diff --git a/cabal/cabal-testsuite/PackageTests/PackageDB/p-no-package-dbs/P.hs b/cabal/cabal-testsuite/PackageTests/PackageDB/p-no-package-dbs/P.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/PackageDB/p-no-package-dbs/P.hs @@ -0,0 +1,2 @@ +module P where +p = True diff --git a/cabal/cabal-testsuite/PackageTests/PackageDB/p-no-package-dbs/cabal.project b/cabal/cabal-testsuite/PackageTests/PackageDB/p-no-package-dbs/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/PackageDB/p-no-package-dbs/cabal.project @@ -0,0 +1,2 @@ +packages: . +package-dbs: clear diff --git a/cabal/cabal-testsuite/PackageTests/PackageDB/p-no-package-dbs/p-no-package-dbs.cabal b/cabal/cabal-testsuite/PackageTests/PackageDB/p-no-package-dbs/p-no-package-dbs.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/PackageDB/p-no-package-dbs/p-no-package-dbs.cabal @@ -0,0 +1,9 @@ +name: p-no-package-dbs +version: 1.0 +build-type: Simple +cabal-version: >= 1.10 + +library + build-depends: base + exposed-modules: P + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/PackageDB/p/P.hs b/cabal/cabal-testsuite/PackageTests/PackageDB/p/P.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/PackageDB/p/P.hs @@ -0,0 +1,2 @@ +module P where +p = True diff --git a/cabal/cabal-testsuite/PackageTests/PackageDB/p/cabal.project b/cabal/cabal-testsuite/PackageTests/PackageDB/p/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/PackageDB/p/cabal.project @@ -0,0 +1,1 @@ +packages: . diff --git a/cabal/cabal-testsuite/PackageTests/PackageDB/p/p.cabal b/cabal/cabal-testsuite/PackageTests/PackageDB/p/p.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/PackageDB/p/p.cabal @@ -0,0 +1,9 @@ +name: p +version: 1.0 +build-type: Simple +cabal-version: >= 1.10 + +library + build-depends: base + exposed-modules: P + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/PackageDB/q/Main.hs b/cabal/cabal-testsuite/PackageTests/PackageDB/q/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/PackageDB/q/Main.hs @@ -0,0 +1,3 @@ +module Main where +import P +main = print p diff --git a/cabal/cabal-testsuite/PackageTests/PackageDB/q/cabal.project b/cabal/cabal-testsuite/PackageTests/PackageDB/q/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/PackageDB/q/cabal.project @@ -0,0 +1,1 @@ +packages: . diff --git a/cabal/cabal-testsuite/PackageTests/PackageDB/q/q.cabal b/cabal/cabal-testsuite/PackageTests/PackageDB/q/q.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/PackageDB/q/q.cabal @@ -0,0 +1,9 @@ +name: q +version: 1.0 +build-type: Simple +cabal-version: >= 1.10 + +executable q + build-depends: base, p + main-is: Main.hs + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/PathsModule/MissingSafeHaskellMode/my.cabal b/cabal/cabal-testsuite/PackageTests/PathsModule/MissingSafeHaskellMode/my.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/PathsModule/MissingSafeHaskellMode/my.cabal @@ -0,0 +1,19 @@ +cabal-version: 2.2 +name: PathsModule +version: 0.1 +license: BSD-3-Clause +author: Oleg Grenrus +stability: stable +category: PackageTests +build-type: Simple + +description: + Check that the generated paths module compiles. + +Library + exposed-modules: Paths_PathsModule + build-depends: base + default-language: Haskell2010 + + if impl(ghc >= 8.10) + ghc-options: -Winferred-safe-imports -Wmissing-safe-haskell-mode -Werror diff --git a/cabal/cabal-testsuite/PackageTests/PathsModule/MissingSafeHaskellMode/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/PathsModule/MissingSafeHaskellMode/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/PathsModule/MissingSafeHaskellMode/setup.cabal.out @@ -0,0 +1,5 @@ +# Setup configure +Configuring PathsModule-0.1... +# Setup build +Preprocessing library for PathsModule-0.1.. +Building library for PathsModule-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/PathsModule/MissingSafeHaskellMode/setup.out b/cabal/cabal-testsuite/PackageTests/PathsModule/MissingSafeHaskellMode/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/PathsModule/MissingSafeHaskellMode/setup.out @@ -0,0 +1,5 @@ +# Setup configure +Configuring PathsModule-0.1... +# Setup build +Preprocessing library for PathsModule-0.1.. +Building library for PathsModule-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/PathsModule/MissingSafeHaskellMode/setup.test.hs b/cabal/cabal-testsuite/PackageTests/PathsModule/MissingSafeHaskellMode/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/PathsModule/MissingSafeHaskellMode/setup.test.hs @@ -0,0 +1,3 @@ +import Test.Cabal.Prelude +-- Test that Paths module is generated and available for libraries. +main = setupAndCabalTest $ setup_build [] diff --git a/cabal/cabal-testsuite/PackageTests/PreProcess/Basic/Foo.hsc b/cabal/cabal-testsuite/PackageTests/PreProcess/Basic/Foo.hsc new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/PreProcess/Basic/Foo.hsc @@ -0,0 +1,1 @@ +module Foo where diff --git a/cabal/cabal-testsuite/PackageTests/PreProcess/Basic/Main.hs b/cabal/cabal-testsuite/PackageTests/PreProcess/Basic/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/PreProcess/Basic/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import Foo + +main :: IO () +main = return () diff --git a/cabal/cabal-testsuite/PackageTests/PreProcess/Basic/my.cabal b/cabal/cabal-testsuite/PackageTests/PreProcess/Basic/my.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/PreProcess/Basic/my.cabal @@ -0,0 +1,32 @@ +name: PreProcess +version: 0.1 +license: BSD3 +author: Johan Tibell +stability: stable +category: PackageTests +build-type: Simple +Cabal-version: >= 1.2 + +description: + Check that preprocessors are run. + +Library + exposed-modules: Foo + build-depends: base + +Executable my-executable + main-is: Main.hs + other-modules: Foo + build-depends: base + +Test-Suite my-test-suite + main-is: Main.hs + type: exitcode-stdio-1.0 + other-modules: Foo + build-depends: base + +Benchmark my-benchmark + main-is: Main.hs + type: exitcode-stdio-1.0 + other-modules: Foo + build-depends: base diff --git a/cabal/cabal-testsuite/PackageTests/PreProcess/Basic/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/PreProcess/Basic/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/PreProcess/Basic/setup.cabal.out @@ -0,0 +1,11 @@ +# Setup configure +Configuring PreProcess-0.1... +# Setup build +Preprocessing test suite 'my-test-suite' for PreProcess-0.1.. +Building test suite 'my-test-suite' for PreProcess-0.1.. +Preprocessing executable 'my-executable' for PreProcess-0.1.. +Building executable 'my-executable' for PreProcess-0.1.. +Preprocessing benchmark 'my-benchmark' for PreProcess-0.1.. +Building benchmark 'my-benchmark' for PreProcess-0.1.. +Preprocessing library for PreProcess-0.1.. +Building library for PreProcess-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/PreProcess/Basic/setup.out b/cabal/cabal-testsuite/PackageTests/PreProcess/Basic/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/PreProcess/Basic/setup.out @@ -0,0 +1,11 @@ +# Setup configure +Configuring PreProcess-0.1... +# Setup build +Preprocessing test suite 'my-test-suite' for PreProcess-0.1.. +Building test suite 'my-test-suite' for PreProcess-0.1.. +Preprocessing executable 'my-executable' for PreProcess-0.1.. +Building executable 'my-executable' for PreProcess-0.1.. +Preprocessing benchmark 'my-benchmark' for PreProcess-0.1.. +Building benchmark 'my-benchmark' for PreProcess-0.1.. +Preprocessing library for PreProcess-0.1.. +Building library for PreProcess-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/PreProcess/Basic/setup.test.hs b/cabal/cabal-testsuite/PackageTests/PreProcess/Basic/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/PreProcess/Basic/setup.test.hs @@ -0,0 +1,3 @@ +import Test.Cabal.Prelude +-- Check that preprocessors (hsc2hs) are run +main = setupAndCabalTest $ setup_build ["--enable-tests", "--enable-benchmarks"] diff --git a/cabal/cabal-testsuite/PackageTests/PreProcess/Foo.hsc b/cabal/cabal-testsuite/PackageTests/PreProcess/Foo.hsc deleted file mode 100644 --- a/cabal/cabal-testsuite/PackageTests/PreProcess/Foo.hsc +++ /dev/null @@ -1,1 +0,0 @@ -module Foo where diff --git a/cabal/cabal-testsuite/PackageTests/PreProcess/Hsc2HsOptions/Foo.hsc b/cabal/cabal-testsuite/PackageTests/PreProcess/Hsc2HsOptions/Foo.hsc new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/PreProcess/Hsc2HsOptions/Foo.hsc @@ -0,0 +1,8 @@ +module Foo where + +foo :: Int +#ifdef TEST_OPTION +foo = #{const TEST_OPTION} +#else +foo = -1 +#endif diff --git a/cabal/cabal-testsuite/PackageTests/PreProcess/Hsc2HsOptions/Main.hs b/cabal/cabal-testsuite/PackageTests/PreProcess/Hsc2HsOptions/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/PreProcess/Hsc2HsOptions/Main.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE CPP #-} +module Main where + +import Foo + +bar :: Int +#ifdef TEST_OPTION +bar = TEST_OPTION +#else +bar = 0 +#endif + +main :: IO () +main = do + putStrLn $ "hsc2hs value: " ++ show foo + putStrLn $ "ghc value: " ++ show bar diff --git a/cabal/cabal-testsuite/PackageTests/PreProcess/Hsc2HsOptions/my.cabal b/cabal/cabal-testsuite/PackageTests/PreProcess/Hsc2HsOptions/my.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/PreProcess/Hsc2HsOptions/my.cabal @@ -0,0 +1,14 @@ +cabal-version: 3.6 +name: Hsc2HsOptions +version: 0.1 +license: BSD-3-Clause +stability: stable +category: PackageTests +build-type: Simple +description: Check that preprocessors are run. + +executable my-executable + main-is: Main.hs + other-modules: Foo + build-depends: base + hsc2hs-options: -DTEST_OPTION=42 diff --git a/cabal/cabal-testsuite/PackageTests/PreProcess/Hsc2HsOptions/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/PreProcess/Hsc2HsOptions/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/PreProcess/Hsc2HsOptions/setup.cabal.out @@ -0,0 +1,8 @@ +# Setup configure +Configuring Hsc2HsOptions-0.1... +# Setup build +Preprocessing executable 'my-executable' for Hsc2HsOptions-0.1.. +Building executable 'my-executable' for Hsc2HsOptions-0.1.. +# my-executable +hsc2hs value: 42 +ghc value: 0 diff --git a/cabal/cabal-testsuite/PackageTests/PreProcess/Hsc2HsOptions/setup.out b/cabal/cabal-testsuite/PackageTests/PreProcess/Hsc2HsOptions/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/PreProcess/Hsc2HsOptions/setup.out @@ -0,0 +1,8 @@ +# Setup configure +Configuring Hsc2HsOptions-0.1... +# Setup build +Preprocessing executable 'my-executable' for Hsc2HsOptions-0.1.. +Building executable 'my-executable' for Hsc2HsOptions-0.1.. +# my-executable +hsc2hs value: 42 +ghc value: 0 diff --git a/cabal/cabal-testsuite/PackageTests/PreProcess/Hsc2HsOptions/setup.test.hs b/cabal/cabal-testsuite/PackageTests/PreProcess/Hsc2HsOptions/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/PreProcess/Hsc2HsOptions/setup.test.hs @@ -0,0 +1,7 @@ +import Test.Cabal.Prelude +-- Check that preprocessors (hsc2hs) are run +main = setupAndCabalTest $ do + setup_build [] + r <- runExe' "my-executable" [] + assertOutputContains "hsc2hs value: 42" r + assertOutputContains "ghc value: 0" r diff --git a/cabal/cabal-testsuite/PackageTests/PreProcess/Hsc2HsOptionsCC/Foo.hsc b/cabal/cabal-testsuite/PackageTests/PreProcess/Hsc2HsOptionsCC/Foo.hsc new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/PreProcess/Hsc2HsOptionsCC/Foo.hsc @@ -0,0 +1,9 @@ +module Foo where + +-- https://isocpp.org/wiki/faq/mixing-c-and-cpp +compiler :: String +#ifdef __cplusplus +compiler = "Is not C, is C++" +#else +compiler = "Is C, is not C++" +#endif diff --git a/cabal/cabal-testsuite/PackageTests/PreProcess/Hsc2HsOptionsCC/Main.hs b/cabal/cabal-testsuite/PackageTests/PreProcess/Hsc2HsOptionsCC/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/PreProcess/Hsc2HsOptionsCC/Main.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE CPP #-} +module Main where + +import Foo + +main :: IO () +main = putStrLn compiler diff --git a/cabal/cabal-testsuite/PackageTests/PreProcess/Hsc2HsOptionsCC/my.cabal b/cabal/cabal-testsuite/PackageTests/PreProcess/Hsc2HsOptionsCC/my.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/PreProcess/Hsc2HsOptionsCC/my.cabal @@ -0,0 +1,14 @@ +cabal-version: 3.6 +name: Hsc2HsOptions +version: 0.1 +license: BSD-3-Clause +stability: stable +category: PackageTests +build-type: Simple +description: Check that preprocessors are run. + +executable my-executable + main-is: Main.hs + build-depends: base + other-modules: Foo + hsc2hs-options: "--cc=g++" diff --git a/cabal/cabal-testsuite/PackageTests/PreProcess/Hsc2HsOptionsCC/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/PreProcess/Hsc2HsOptionsCC/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/PreProcess/Hsc2HsOptionsCC/setup.cabal.out @@ -0,0 +1,7 @@ +# Setup configure +Configuring Hsc2HsOptions-0.1... +# Setup build +Preprocessing executable 'my-executable' for Hsc2HsOptions-0.1.. +Building executable 'my-executable' for Hsc2HsOptions-0.1.. +# my-executable +Is not C, is C++ diff --git a/cabal/cabal-testsuite/PackageTests/PreProcess/Hsc2HsOptionsCC/setup.out b/cabal/cabal-testsuite/PackageTests/PreProcess/Hsc2HsOptionsCC/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/PreProcess/Hsc2HsOptionsCC/setup.out @@ -0,0 +1,7 @@ +# Setup configure +Configuring Hsc2HsOptions-0.1... +# Setup build +Preprocessing executable 'my-executable' for Hsc2HsOptions-0.1.. +Building executable 'my-executable' for Hsc2HsOptions-0.1.. +# my-executable +Is not C, is C++ diff --git a/cabal/cabal-testsuite/PackageTests/PreProcess/Hsc2HsOptionsCC/setup.test.hs b/cabal/cabal-testsuite/PackageTests/PreProcess/Hsc2HsOptionsCC/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/PreProcess/Hsc2HsOptionsCC/setup.test.hs @@ -0,0 +1,28 @@ +import Test.Cabal.Prelude +import Distribution.Pretty (prettyShow) +import Data.Maybe (isJust) +import System.Directory (findExecutable) + +-- Check that preprocessors (hsc2hs) are run +main = setupAndCabalTest $ do + -- we need "g++" + hasGxx <- liftIO $ fmap isJust $ findExecutable "g++" + skipUnless "g++" hasGxx + + -- Figure out how recent GHC we need + -- https://github.com/msys2/MINGW-packages/issues/3531 + skipIfWindows + + -- we need recent enough hsc2hs + -- hsc2hs commit 9671202c11f7fe98e5b96d379532b6f691dc46dd + -- Fix when using g++ as C compiler. Patch from elaforge. Fixes ghc #7232 + p <- requireProgramM hsc2hsProgram + case programVersion p of + Nothing -> skip "Unknown hsc2hs version" + Just v | v < mkVersion [0,68] -> skip $ "hsc2hs version: " ++ prettyShow v ++ " < 0.68" + _ -> return () + + -- Actual test + setup_build [] + r <- runExe' "my-executable" [] + assertOutputContains "Is not C, is C++" r diff --git a/cabal/cabal-testsuite/PackageTests/PreProcess/Main.hs b/cabal/cabal-testsuite/PackageTests/PreProcess/Main.hs deleted file mode 100644 --- a/cabal/cabal-testsuite/PackageTests/PreProcess/Main.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Main where - -import Foo - -main :: IO () -main = return () diff --git a/cabal/cabal-testsuite/PackageTests/PreProcess/my.cabal b/cabal/cabal-testsuite/PackageTests/PreProcess/my.cabal deleted file mode 100644 --- a/cabal/cabal-testsuite/PackageTests/PreProcess/my.cabal +++ /dev/null @@ -1,32 +0,0 @@ -name: PreProcess -version: 0.1 -license: BSD3 -author: Johan Tibell -stability: stable -category: PackageTests -build-type: Simple -Cabal-version: >= 1.2 - -description: - Check that preprocessors are run. - -Library - exposed-modules: Foo - build-depends: base - -Executable my-executable - main-is: Main.hs - other-modules: Foo - build-depends: base - -Test-Suite my-test-suite - main-is: Main.hs - type: exitcode-stdio-1.0 - other-modules: Foo - build-depends: base - -Benchmark my-benchmark - main-is: Main.hs - type: exitcode-stdio-1.0 - other-modules: Foo - build-depends: base diff --git a/cabal/cabal-testsuite/PackageTests/PreProcess/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/PreProcess/setup.cabal.out deleted file mode 100644 --- a/cabal/cabal-testsuite/PackageTests/PreProcess/setup.cabal.out +++ /dev/null @@ -1,11 +0,0 @@ -# Setup configure -Configuring PreProcess-0.1... -# Setup build -Preprocessing test suite 'my-test-suite' for PreProcess-0.1.. -Building test suite 'my-test-suite' for PreProcess-0.1.. -Preprocessing executable 'my-executable' for PreProcess-0.1.. -Building executable 'my-executable' for PreProcess-0.1.. -Preprocessing benchmark 'my-benchmark' for PreProcess-0.1.. -Building benchmark 'my-benchmark' for PreProcess-0.1.. -Preprocessing library for PreProcess-0.1.. -Building library for PreProcess-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/PreProcess/setup.out b/cabal/cabal-testsuite/PackageTests/PreProcess/setup.out deleted file mode 100644 --- a/cabal/cabal-testsuite/PackageTests/PreProcess/setup.out +++ /dev/null @@ -1,11 +0,0 @@ -# Setup configure -Configuring PreProcess-0.1... -# Setup build -Preprocessing test suite 'my-test-suite' for PreProcess-0.1.. -Building test suite 'my-test-suite' for PreProcess-0.1.. -Preprocessing executable 'my-executable' for PreProcess-0.1.. -Building executable 'my-executable' for PreProcess-0.1.. -Preprocessing benchmark 'my-benchmark' for PreProcess-0.1.. -Building benchmark 'my-benchmark' for PreProcess-0.1.. -Preprocessing library for PreProcess-0.1.. -Building library for PreProcess-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/PreProcess/setup.test.hs b/cabal/cabal-testsuite/PackageTests/PreProcess/setup.test.hs deleted file mode 100644 --- a/cabal/cabal-testsuite/PackageTests/PreProcess/setup.test.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Test.Cabal.Prelude --- Check that preprocessors (hsc2hs) are run -main = setupAndCabalTest $ setup_build ["--enable-tests", "--enable-benchmarks"] diff --git a/cabal/cabal-testsuite/PackageTests/QuasiQuotes/dynamic/setup.test.hs b/cabal/cabal-testsuite/PackageTests/QuasiQuotes/dynamic/setup.test.hs --- a/cabal/cabal-testsuite/PackageTests/QuasiQuotes/dynamic/setup.test.hs +++ b/cabal/cabal-testsuite/PackageTests/QuasiQuotes/dynamic/setup.test.hs @@ -1,5 +1,5 @@ import Test.Cabal.Prelude -- Test building a dynamic library/executable which uses QuasiQuotes main = setupAndCabalTest $ do - skipUnless =<< hasSharedLibraries + skipUnless "no shared libs" =<< hasSharedLibraries setup_build ["--enable-shared", "--enable-executable-dynamic"] diff --git a/cabal/cabal-testsuite/PackageTests/QuasiQuotes/profiling/setup.test.hs b/cabal/cabal-testsuite/PackageTests/QuasiQuotes/profiling/setup.test.hs --- a/cabal/cabal-testsuite/PackageTests/QuasiQuotes/profiling/setup.test.hs +++ b/cabal/cabal-testsuite/PackageTests/QuasiQuotes/profiling/setup.test.hs @@ -2,6 +2,6 @@ -- Test building a profiled library/executable which uses QuasiQuotes -- (setup has to build the non-profiled version first) main = setupAndCabalTest $ do - skipUnless =<< hasProfiledLibraries + skipUnless "no profiling libs" =<< hasProfiledLibraries setup_build ["--enable-library-profiling", "--enable-profiling"] diff --git a/cabal/cabal-testsuite/PackageTests/ReexportedModules/setup-fail-ambiguous.test.hs b/cabal/cabal-testsuite/PackageTests/ReexportedModules/setup-fail-ambiguous.test.hs --- a/cabal/cabal-testsuite/PackageTests/ReexportedModules/setup-fail-ambiguous.test.hs +++ b/cabal/cabal-testsuite/PackageTests/ReexportedModules/setup-fail-ambiguous.test.hs @@ -1,6 +1,6 @@ import Test.Cabal.Prelude main = setupAndCabalTest $ do - skipUnless =<< ghcVersionIs (>= mkVersion [7,9]) + skipUnlessGhcVersion ">= 7.9" withPackageDb $ do withDirectory "containers-dupe" $ setup_install [] diff --git a/cabal/cabal-testsuite/PackageTests/ReexportedModules/setup-fail-missing.test.hs b/cabal/cabal-testsuite/PackageTests/ReexportedModules/setup-fail-missing.test.hs --- a/cabal/cabal-testsuite/PackageTests/ReexportedModules/setup-fail-missing.test.hs +++ b/cabal/cabal-testsuite/PackageTests/ReexportedModules/setup-fail-missing.test.hs @@ -1,6 +1,6 @@ import Test.Cabal.Prelude main = setupAndCabalTest $ do - skipUnless =<< ghcVersionIs (>= mkVersion [7,9]) + skipUnlessGhcVersion ">= 7.9" withDirectory "p" $ do r <- fails $ setup' "configure" ["--cabal-file", "p.cabal.fail-missing"] assertOutputContains "Missing" r diff --git a/cabal/cabal-testsuite/PackageTests/ReexportedModules/setup-fail-other.test.hs b/cabal/cabal-testsuite/PackageTests/ReexportedModules/setup-fail-other.test.hs --- a/cabal/cabal-testsuite/PackageTests/ReexportedModules/setup-fail-other.test.hs +++ b/cabal/cabal-testsuite/PackageTests/ReexportedModules/setup-fail-other.test.hs @@ -1,6 +1,6 @@ import Test.Cabal.Prelude main = setupAndCabalTest $ do - skipUnless =<< ghcVersionIs (>= mkVersion [7,9]) + skipUnlessGhcVersion ">= 7.9" withDirectory "p" $ do r <- fails $ setup' "configure" ["--cabal-file", "p.cabal.fail-other"] assertOutputContains "Private" r diff --git a/cabal/cabal-testsuite/PackageTests/ReexportedModules/setup.test.hs b/cabal/cabal-testsuite/PackageTests/ReexportedModules/setup.test.hs --- a/cabal/cabal-testsuite/PackageTests/ReexportedModules/setup.test.hs +++ b/cabal/cabal-testsuite/PackageTests/ReexportedModules/setup.test.hs @@ -1,7 +1,7 @@ import Test.Cabal.Prelude -- Test that reexported modules build correctly main = setupAndCabalTest $ do - skipUnless =<< ghcVersionIs (>= mkVersion [7,9]) + skipUnlessGhcVersion ">= 7.9" withPackageDb $ do withDirectory "p" $ setup_install ["--cabal-file", "p.cabal"] withDirectory "q" $ setup_build [] diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T3932/cabal.out b/cabal/cabal-testsuite/PackageTests/Regression/T3932/cabal.out --- a/cabal/cabal-testsuite/PackageTests/Regression/T3932/cabal.out +++ b/cabal/cabal-testsuite/PackageTests/Regression/T3932/cabal.out @@ -1,2 +1,2 @@ -# cabal v1-update +# cabal v2-update Downloading the latest package list from test-local-repo diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T4025/setup.test.hs b/cabal/cabal-testsuite/PackageTests/Regression/T4025/setup.test.hs --- a/cabal/cabal-testsuite/PackageTests/Regression/T4025/setup.test.hs +++ b/cabal/cabal-testsuite/PackageTests/Regression/T4025/setup.test.hs @@ -3,7 +3,10 @@ -- an executable RPATH. Don't test on Windows, which doesn't -- support RPATH. main = setupAndCabalTest $ do - skipIf =<< isWindows + skipIfWindows + osx <- isOSX + ghc <- isGhcVersion ">= 8.10.7" + expectBrokenIf (osx && ghc) 7610 $ do -- see also issue #7988 setup "configure" ["--enable-executable-dynamic"] setup "build" [] -- This should fail as it we should NOT be able to find the diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T4270/setup.test.hs b/cabal/cabal-testsuite/PackageTests/Regression/T4270/setup.test.hs --- a/cabal/cabal-testsuite/PackageTests/Regression/T4270/setup.test.hs +++ b/cabal/cabal-testsuite/PackageTests/Regression/T4270/setup.test.hs @@ -3,8 +3,11 @@ -- when linked dynamically -- See https://github.com/haskell/cabal/issues/4270 main = setupAndCabalTest $ do - skipUnless =<< hasSharedLibraries - skipUnless =<< hasCabalShared - skipUnless =<< hasCabalForGhc - setup_build ["--enable-tests", "--enable-executable-dynamic"] - setup "test" [] + skipUnless "no shared libs" =<< hasSharedLibraries + skipUnless "no shared Cabal" =<< hasCabalShared + skipUnless "no Cabal for GHC" =<< hasCabalForGhc + ghc <- isGhcVersion "== 8.0.2" + osx <- isOSX + expectBrokenIf (osx && ghc) 8028 $ do + setup_build ["--enable-tests", "--enable-executable-dynamic"] + setup "test" [] diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T4291/setup.test.hs b/cabal/cabal-testsuite/PackageTests/Regression/T4291/setup.test.hs --- a/cabal/cabal-testsuite/PackageTests/Regression/T4291/setup.test.hs +++ b/cabal/cabal-testsuite/PackageTests/Regression/T4291/setup.test.hs @@ -4,8 +4,8 @@ -- Test that checkRelocate doesn't fail when library directory of dependee -- contains '..' main = setupAndCabalTest $ withPackageDb $ do - skipIf =<< isWindows - skipUnless =<< ghcVersionIs (>= mkVersion [7,6]) + skipIfWindows + skipUnlessGhcVersion ">= 7.6" env <- getTestEnv let pkgroot = takeDirectory $ testPackageDbDir env prefix = testTmpDir env "prefix" diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T4449/setup.test.hs b/cabal/cabal-testsuite/PackageTests/Regression/T4449/setup.test.hs --- a/cabal/cabal-testsuite/PackageTests/Regression/T4449/setup.test.hs +++ b/cabal/cabal-testsuite/PackageTests/Regression/T4449/setup.test.hs @@ -1,5 +1,5 @@ import Test.Cabal.Prelude main = cabalTest $ do - skipIf =<< (ghcVersionIs (< mkVersion [7,10])) + skipUnlessGhcVersion ">= 7.10" setup "configure" [] setup "build" [] diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T4986/cabal.out b/cabal/cabal-testsuite/PackageTests/Regression/T4986/cabal.out --- a/cabal/cabal-testsuite/PackageTests/Regression/T4986/cabal.out +++ b/cabal/cabal-testsuite/PackageTests/Regression/T4986/cabal.out @@ -1,6 +1,1 @@ # cabal v2-configure -Resolving dependencies... -Build profile: -w ghc- -O1 -In order, the following would be built: - - happy-999.999.999 (exe:happy) (first run) - - client-0.1.0.0 (exe:hello-world) (first run) diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T5213/cabal-gh5213.cabal b/cabal/cabal-testsuite/PackageTests/Regression/T5213/cabal-gh5213.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T5213/cabal-gh5213.cabal @@ -0,0 +1,29 @@ +-- Initial cabal-gh5213.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: cabal-gh5213 +version: 0.1 +-- synopsis: +-- description: +license: BSD3 +author: Ryan Scott +maintainer: ryan.gl.scott@gmail.com +-- copyright: +category: Testing +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: CabalGH5213Exposed + other-modules: CabalGH5213Other + -- other-extensions: + build-depends: base >= 4 && < 5 + hs-source-dirs: src + default-language: Haskell2010 + +test-suite tests + main-is: Main.hs + type: exitcode-stdio-1.0 + build-depends: base, cabal-gh5213 + hs-source-dirs: tests + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T5213/cabal.out b/cabal/cabal-testsuite/PackageTests/Regression/T5213/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T5213/cabal.out @@ -0,0 +1,19 @@ +# cabal new-test +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - cabal-gh5213-0.1 (lib) (first run) + - cabal-gh5213-0.1 (test:tests) (first run) +Configuring library for cabal-gh5213-0.1.. +Preprocessing library for cabal-gh5213-0.1.. +Building library for cabal-gh5213-0.1.. +Configuring test suite 'tests' for cabal-gh5213-0.1.. +Preprocessing test suite 'tests' for cabal-gh5213-0.1.. +Building test suite 'tests' for cabal-gh5213-0.1.. +Running 1 test suites... +Test suite tests: RUNNING... +Test suite tests: PASS +Test suite logged to: /cabal.dist/work/./dist/build//ghc-/cabal-gh5213-0.1/t/tests/test/cabal-gh5213-0.1-tests.log +Test coverage report written to /cabal.dist/work/./dist/build//ghc-/cabal-gh5213-0.1/t/tests/hpc/vanilla/html/tests/hpc_index.html +1 of 1 test suites (1 of 1 test cases) passed. +Package coverage report written to /cabal.dist/work/./dist/build//ghc-/cabal-gh5213-0.1/t/tests/hpc/vanilla/html/cabal-gh5213-0.1/hpc_index.html diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T5213/cabal.project b/cabal/cabal-testsuite/PackageTests/Regression/T5213/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T5213/cabal.project @@ -0,0 +1,4 @@ +packages: . + +package cabal-gh5213 + library-coverage: true diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T5213/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/Regression/T5213/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T5213/cabal.test.hs @@ -0,0 +1,2 @@ +import Test.Cabal.Prelude +main = cabalTest $ cabal "new-test" [] diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T5213/src/CabalGH5213Exposed.hs b/cabal/cabal-testsuite/PackageTests/Regression/T5213/src/CabalGH5213Exposed.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T5213/src/CabalGH5213Exposed.hs @@ -0,0 +1,6 @@ +module CabalGH5213Exposed where + +import CabalGH5213Other + +foo :: Int +foo = bar diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T5213/src/CabalGH5213Other.hs b/cabal/cabal-testsuite/PackageTests/Regression/T5213/src/CabalGH5213Other.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T5213/src/CabalGH5213Other.hs @@ -0,0 +1,4 @@ +module CabalGH5213Other where + +bar :: Int +bar = 42 diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T5213/tests/Main.hs b/cabal/cabal-testsuite/PackageTests/Regression/T5213/tests/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T5213/tests/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import CabalGH5213Exposed + +main :: IO () +main = print foo diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T5213ExeCoverage/cabal-gh5213.cabal b/cabal/cabal-testsuite/PackageTests/Regression/T5213ExeCoverage/cabal-gh5213.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T5213ExeCoverage/cabal-gh5213.cabal @@ -0,0 +1,29 @@ +-- Initial cabal-gh5213.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: cabal-gh5213 +version: 0.1 +-- synopsis: +-- description: +license: BSD3 +author: Ryan Scott +maintainer: ryan.gl.scott@gmail.com +-- copyright: +category: Testing +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: CabalGH5213Exposed + other-modules: CabalGH5213Other + -- other-extensions: + build-depends: base >= 4 && < 5 + hs-source-dirs: src + default-language: Haskell2010 + +test-suite tests + main-is: Main.hs + type: exitcode-stdio-1.0 + build-depends: base, cabal-gh5213 + hs-source-dirs: tests + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T5213ExeCoverage/cabal.out b/cabal/cabal-testsuite/PackageTests/Regression/T5213ExeCoverage/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T5213ExeCoverage/cabal.out @@ -0,0 +1,19 @@ +# cabal new-test +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - cabal-gh5213-0.1 (lib) (first run) + - cabal-gh5213-0.1 (test:tests) (first run) +Configuring library for cabal-gh5213-0.1.. +Preprocessing library for cabal-gh5213-0.1.. +Building library for cabal-gh5213-0.1.. +Configuring test suite 'tests' for cabal-gh5213-0.1.. +Preprocessing test suite 'tests' for cabal-gh5213-0.1.. +Building test suite 'tests' for cabal-gh5213-0.1.. +Running 1 test suites... +Test suite tests: RUNNING... +Test suite tests: PASS +Test suite logged to: /cabal.dist/work/./dist/build//ghc-/cabal-gh5213-0.1/t/tests/noopt/test/cabal-gh5213-0.1-tests.log +Test coverage report written to /cabal.dist/work/./dist/build//ghc-/cabal-gh5213-0.1/t/tests/noopt/hpc/vanilla/html/tests/hpc_index.html +1 of 1 test suites (1 of 1 test cases) passed. +Package coverage report written to /cabal.dist/work/./dist/build//ghc-/cabal-gh5213-0.1/t/tests/noopt/hpc/vanilla/html/cabal-gh5213-0.1/hpc_index.html diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T5213ExeCoverage/cabal.project b/cabal/cabal-testsuite/PackageTests/Regression/T5213ExeCoverage/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T5213ExeCoverage/cabal.project @@ -0,0 +1,5 @@ +packages: . + +package cabal-gh5213 + coverage: True + optimization: False diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T5213ExeCoverage/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/Regression/T5213ExeCoverage/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T5213ExeCoverage/cabal.test.hs @@ -0,0 +1,2 @@ +import Test.Cabal.Prelude +main = cabalTest $ cabal "new-test" [] diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T5213ExeCoverage/src/CabalGH5213Exposed.hs b/cabal/cabal-testsuite/PackageTests/Regression/T5213ExeCoverage/src/CabalGH5213Exposed.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T5213ExeCoverage/src/CabalGH5213Exposed.hs @@ -0,0 +1,6 @@ +module CabalGH5213Exposed where + +import CabalGH5213Other + +foo :: Int +foo = bar diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T5213ExeCoverage/src/CabalGH5213Other.hs b/cabal/cabal-testsuite/PackageTests/Regression/T5213ExeCoverage/src/CabalGH5213Other.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T5213ExeCoverage/src/CabalGH5213Other.hs @@ -0,0 +1,4 @@ +module CabalGH5213Other where + +bar :: Int +bar = 42 diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T5213ExeCoverage/tests/Main.hs b/cabal/cabal-testsuite/PackageTests/Regression/T5213ExeCoverage/tests/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T5213ExeCoverage/tests/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import CabalGH5213Exposed + +main :: IO () +main = print foo diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T5309/T5309.cabal b/cabal/cabal-testsuite/PackageTests/Regression/T5309/T5309.cabal --- a/cabal/cabal-testsuite/PackageTests/Regression/T5309/T5309.cabal +++ b/cabal/cabal-testsuite/PackageTests/Regression/T5309/T5309.cabal @@ -37,7 +37,7 @@ -- to locate when preprocessing the C files. Without listing the directories containing -- the C header files here, the FFI preprocession (hsc2hs, c2hs,etc.) will fail to locate -- the requisite files. - -- Note also, that the parent directory of the nessicary C header files must be specified. + -- Note also, that the parent directory of the necessary C header files must be specified. -- The preprocesser will not recursively look in subdirectories for C header files! include-dirs: memoized-tcm diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T5309/cabal.out b/cabal/cabal-testsuite/PackageTests/Regression/T5309/cabal.out --- a/cabal/cabal-testsuite/PackageTests/Regression/T5309/cabal.out +++ b/cabal/cabal-testsuite/PackageTests/Regression/T5309/cabal.out @@ -12,7 +12,6 @@ Preprocessing executable 'exe-no-lib' for T5309-1.0.0.0.. Building executable 'exe-no-lib' for T5309-1.0.0.0.. Configuring executable 'exe-with-lib' for T5309-1.0.0.0.. -Warning: The package has an extraneous version range for a dependency on an internal library: T5309 >=0 && ==1.0.0.0, T5309 >=0 && ==1.0.0.0, T5309 >=0 && ==1.0.0.0. This version range includes the current package but isn't needed as the current package's library will always be used. Preprocessing executable 'exe-with-lib' for T5309-1.0.0.0.. Building executable 'exe-with-lib' for T5309-1.0.0.0.. # cabal v2-test @@ -29,7 +28,6 @@ Test suite logged to: /cabal.dist/work/./dist/build//ghc-/T5309-1.0.0.0/t/test-no-lib/test/T5309-1.0.0.0-test-no-lib.log 1 of 1 test suites (1 of 1 test cases) passed. Configuring test suite 'test-with-lib' for T5309-1.0.0.0.. -Warning: The package has an extraneous version range for a dependency on an internal library: T5309 >=0 && ==1.0.0.0, T5309 >=0 && ==1.0.0.0, T5309 >=0 && ==1.0.0.0. This version range includes the current package but isn't needed as the current package's library will always be used. Preprocessing test suite 'test-with-lib' for T5309-1.0.0.0.. Building test suite 'test-with-lib' for T5309-1.0.0.0.. Running 1 test suites... @@ -49,7 +47,6 @@ Benchmark bench-no-lib: RUNNING... Benchmark bench-no-lib: FINISH Configuring benchmark 'bench-with-lib' for T5309-1.0.0.0.. -Warning: The package has an extraneous version range for a dependency on an internal library: T5309 >=0 && ==1.0.0.0, T5309 >=0 && ==1.0.0.0, T5309 >=0 && ==1.0.0.0. This version range includes the current package but isn't needed as the current package's library will always be used. Preprocessing benchmark 'bench-with-lib' for T5309-1.0.0.0.. Building benchmark 'bench-with-lib' for T5309-1.0.0.0.. Running 1 benchmarks... diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T5309/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/Regression/T5309/cabal.test.hs --- a/cabal/cabal-testsuite/PackageTests/Regression/T5309/cabal.test.hs +++ b/cabal/cabal-testsuite/PackageTests/Regression/T5309/cabal.test.hs @@ -1,6 +1,6 @@ import Test.Cabal.Prelude main = cabalTest $ do - skipIf =<< isWindows -- TODO: https://github.com/haskell/cabal/issues/6271 + skipIfWindows -- TODO: https://github.com/haskell/cabal/issues/6271 cabal "v2-build" ["all"] cabal "v2-test" ["all"] cabal "v2-bench" ["all"] diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T5309/lib/Data/TCM/Memoized/FFI.hsc b/cabal/cabal-testsuite/PackageTests/Regression/T5309/lib/Data/TCM/Memoized/FFI.hsc --- a/cabal/cabal-testsuite/PackageTests/Regression/T5309/lib/Data/TCM/Memoized/FFI.hsc +++ b/cabal/cabal-testsuite/PackageTests/Regression/T5309/lib/Data/TCM/Memoized/FFI.hsc @@ -2,7 +2,7 @@ -- | -- TODO: Document module. -- --- Exports C types for dynamic characters and their constructors allong with +-- Exports C types for dynamic characters and their constructors along with -- an FFI binding for the memoizing TCM structure. ----------------------------------------------------------------------------- @@ -40,7 +40,7 @@ -- | --- A convient type alias for improved clairity of use. +-- A convenient type alias for improved clarity of use. type CBufferUnit = CULong -- This will be compatible with uint64_t @@ -267,7 +267,7 @@ -- /O(1)/ -- -- Malloc and populate a pointer to a C representation of a dynamic character. --- The buffer of the resulting value is intentially zeroed out. +-- The buffer of the resulting value is intentionally zeroed out. constructEmptyElement :: Int -- ^ Bit width of a dynamic character element. -> IO (Ptr DCElement) constructEmptyElement alphabetSize = do diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T5318/cabal.project b/cabal/cabal-testsuite/PackageTests/Regression/T5318/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T5318/cabal.project @@ -0,0 +1,1 @@ +packages: ./ diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T5318/sdist-list-sources.test.hs b/cabal/cabal-testsuite/PackageTests/Regression/T5318/sdist-list-sources.test.hs --- a/cabal/cabal-testsuite/PackageTests/Regression/T5318/sdist-list-sources.test.hs +++ b/cabal/cabal-testsuite/PackageTests/Regression/T5318/sdist-list-sources.test.hs @@ -2,6 +2,6 @@ main = cabalTest $ do tmpdir <- fmap testTmpDir getTestEnv let fn = tmpdir "empty-data-dir-0.list" - cabal "v2-sdist" ["--ignore-project", "--list-only", "--output-directory", tmpdir] + cabal "v2-sdist" ["--list-only", "--output-directory", tmpdir] -- --list-sources outputs with slashes on posix and backslashes on Windows. 'normalise' converts our needle to the necessary format. assertFileDoesContain fn $ normalise "foo.dat" diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T5409/use-different-versions-of-dependency-for-library-and-build-tool.out b/cabal/cabal-testsuite/PackageTests/Regression/T5409/use-different-versions-of-dependency-for-library-and-build-tool.out --- a/cabal/cabal-testsuite/PackageTests/Regression/T5409/use-different-versions-of-dependency-for-library-and-build-tool.out +++ b/cabal/cabal-testsuite/PackageTests/Regression/T5409/use-different-versions-of-dependency-for-library-and-build-tool.out @@ -1,4 +1,4 @@ -# cabal v1-update +# cabal v2-update Downloading the latest package list from test-local-repo # pkg my-exe build-tool library version: 1, diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T5409/use-different-versions-of-dependency-for-library-and-build-tool.test.hs b/cabal/cabal-testsuite/PackageTests/Regression/T5409/use-different-versions-of-dependency-for-library-and-build-tool.test.hs --- a/cabal/cabal-testsuite/PackageTests/Regression/T5409/use-different-versions-of-dependency-for-library-and-build-tool.test.hs +++ b/cabal/cabal-testsuite/PackageTests/Regression/T5409/use-different-versions-of-dependency-for-library-and-build-tool.test.hs @@ -12,15 +12,19 @@ -- violated the version constraints. main = withShorterPathForNewBuildStore $ \storeDir -> cabalTest $ do - skipUnless =<< hasNewBuildCompatBootCabal + skipUnless "not v2-build compatible boot Cabal" =<< hasNewBuildCompatBootCabal withRepo "repo" $ do r1 <- recordMode DoNotRecord $ cabalG' ["--store-dir=" ++ storeDir] "v2-build" ["pkg:my-exe"] - let msg = "In order, the following will be built:" - ++ " - build-tool-pkg-1 (lib) (requires download & build)" - ++ " - build-tool-pkg-2 (lib) (requires download & build)" -- dependency of build-tool-exe - ++ " - build-tool-pkg-2 (exe:build-tool-exe) (requires download & build)" - ++ " - pkg-1.0 (exe:my-exe) (first run)" + + let msg = concat + [ "In order, the following will be built:" + , " - build-tool-pkg-1 (lib) (requires build)" + , " - build-tool-pkg-2 (lib) (requires build)" + , " - build-tool-pkg-2 (exe:build-tool-exe) (requires build)" + , " - pkg-1.0 (exe:my-exe) (first run)" + ] + assertOutputContains msg r1 withPlan $ do r2 <- runPlanExe' "pkg" "my-exe" [] diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T5677/cabal.out b/cabal/cabal-testsuite/PackageTests/Regression/T5677/cabal.out --- a/cabal/cabal-testsuite/PackageTests/Regression/T5677/cabal.out +++ b/cabal/cabal-testsuite/PackageTests/Regression/T5677/cabal.out @@ -24,6 +24,5 @@ Building library instantiated with Sig = impl-0-inplace:Sig for prog-0.. Configuring executable 'prog' for prog-0.. -Warning: The package has an extraneous version range for a dependency on an internal library: prog >=0 && ==0. This version range includes the current package but isn't needed as the current package's library will always be used. Preprocessing executable 'prog' for prog-0.. Building executable 'prog' for prog-0.. diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T5677/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/Regression/T5677/cabal.test.hs --- a/cabal/cabal-testsuite/PackageTests/Regression/T5677/cabal.test.hs +++ b/cabal/cabal-testsuite/PackageTests/Regression/T5677/cabal.test.hs @@ -1,6 +1,6 @@ import Test.Cabal.Prelude main = cabalTest $ do -- -Wmissing-export-lists is new in 8.4. - skipUnless =<< ghcVersionIs (>= mkVersion [8,3]) - skipIf =<< isWindows -- TODO: https://github.com/haskell/cabal/issues/6271 + skipUnlessGhcVersion ">= 8.3" + skipIfWindows -- TODO: https://github.com/haskell/cabal/issues/6271 cabal "v2-build" ["all"] diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T5782Diamond/cabal.out b/cabal/cabal-testsuite/PackageTests/Regression/T5782Diamond/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T5782Diamond/cabal.out @@ -0,0 +1,6 @@ +# issue5782 E +"AAA" +# issue5782 E +"BBB" +# issue5782 E +"CCC" diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T5782Diamond/cabal.project b/cabal/cabal-testsuite/PackageTests/Regression/T5782Diamond/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T5782Diamond/cabal.project @@ -0,0 +1,1 @@ +packages: issue5782 diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T5782Diamond/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/Regression/T5782Diamond/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T5782Diamond/cabal.test.hs @@ -0,0 +1,45 @@ +-- When Module.f is changed, with cabal <= 3.2 this non-deterministically fails +-- to compile and, if it doesn't fail, it also non-deterministically gives +-- a wrong answer (ignoring the change to Module.f in the output, despite +-- recompiling, so probably the wrong library is linked in); when running +-- manually on my machine, three changes to Module.hs are enough to trigger +-- the error, often two are enough, even with cabal 3.2, even to get +-- compilation error +-- "Ambiguous module name `Module': it was found in multiple packages: issue5782-0.1 issue5782-0.1" +-- not only the wrong result from exe run. +-- +-- The dummy "--installdir=." is needed for cabal <= 3.2 +-- and also to match cabal output on different OSes +-- (default installdir is different on various OSes). +-- +-- `withShorterPathForNewBuildStore` is needed to avoid some path mismatches, etc., +-- in the output, but MacOS still insists on processing internal libraries +-- in a different order and Windows additionally still can't recognize +-- the paths match. Hence `recordMode DoNotRecord` to mute the output, +-- which is fine in this case, because the problem manifests either +-- as failed compilation or wrong exe output, which I do check. + +import Test.Cabal.Prelude +main = withShorterPathForNewBuildStore $ \storeDir -> + cabalTest $ + withSourceCopy . withDelay $ do + writeSourceFile "issue5782/src/Module.hs" "module Module where\nf = \"AAA\"" + recordMode DoNotRecord $ + cabalG ["--store-dir=" ++ storeDir, "--installdir=" ++ storeDir, "--overwrite-policy=always"] "v2-install" ["issue5782"] + withPlan $ + runPlanExe' "issue5782" "E" [] + >>= assertOutputContains "AAA" + delay + writeSourceFile "issue5782/src/Module.hs" "module Module where\nf = \"BBB\"" + recordMode DoNotRecord $ + cabalG ["--store-dir=" ++ storeDir, "--installdir=" ++ storeDir, "--overwrite-policy=always"] "v2-install" ["issue5782"] + withPlan $ + runPlanExe' "issue5782" "E" [] + >>= assertOutputContains "BBB" + writeSourceFile "issue5782/src/Module.hs" "module Module where\nf = \"CCC\"" + delay -- different spot to try another scenario + recordMode DoNotRecord $ + cabalG ["--store-dir=" ++ storeDir, "--installdir=" ++ storeDir, "--overwrite-policy=always"] "v2-install" ["issue5782"] + withPlan $ + runPlanExe' "issue5782" "E" [] + >>= assertOutputContains "CCC" diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T5782Diamond/issue5782/Main.hs b/cabal/cabal-testsuite/PackageTests/Regression/T5782Diamond/issue5782/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T5782Diamond/issue5782/Main.hs @@ -0,0 +1,3 @@ +import Module + +main = print f diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T5782Diamond/issue5782/issue5782.cabal b/cabal/cabal-testsuite/PackageTests/Regression/T5782Diamond/issue5782/issue5782.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T5782Diamond/issue5782/issue5782.cabal @@ -0,0 +1,28 @@ +cabal-version: 2.2 + +name: issue5782 +version: 0.1 +build-type: Simple + +library a + hs-source-dirs: src + exposed-modules: Module + build-depends: base + default-language: Haskell2010 + +library + hs-source-dirs: src2 + build-depends: a, base + default-language: Haskell2010 + reexported-modules: Module + +library b + hs-source-dirs: src2 + build-depends: a, base + default-language: Haskell2010 + reexported-modules: Module + +executable E + main-is: Main.hs + build-depends: issue5782, b, base + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T5782Diamond/issue5782/src/.gitkeep b/cabal/cabal-testsuite/PackageTests/Regression/T5782Diamond/issue5782/src/.gitkeep new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T5782Diamond/issue5782/src/.gitkeep diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T6906/cabal.config b/cabal/cabal-testsuite/PackageTests/Regression/T6906/cabal.config new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T6906/cabal.config @@ -0,0 +1,2 @@ +extra-include-dirs: foo +extra-lib-dirs: bar diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T6906/cabal.project b/cabal/cabal-testsuite/PackageTests/Regression/T6906/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T6906/cabal.project @@ -0,0 +1,1 @@ +packages: . diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T6906/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/Regression/T6906/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T6906/cabal.test.hs @@ -0,0 +1,12 @@ +import Test.Cabal.Prelude + +main = cabalTest $ do + win <- isWindows + ghcsWithMaxPathIssue <- isGhcVersion "< 8.6.5" + expectBrokenIf (win && ghcsWithMaxPathIssue) 6271 $ do + res <- recordMode DoNotRecord $ cabalG' ["--config=cabal.config"] "v2-install" ["-v3"] + assertOutputContains "creating file with the inputs used to compute the package hash:" res + assertOutputContains "extra-lib-dirs: bar" res + assertOutputDoesNotContain "extra-lib-dirs: bar bar" res + assertOutputContains "extra-include-dirs: foo" res + assertOutputDoesNotContain "extra-include-dirs: foo foo" res diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T6906/issue6906.cabal b/cabal/cabal-testsuite/PackageTests/Regression/T6906/issue6906.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T6906/issue6906.cabal @@ -0,0 +1,12 @@ +cabal-version: 3.0 +name: issue6906 +version: 0 +synopsis: No duplicate entries for extra-*-dirs config options in the inputs used to compute the package hash +description: When informed in the global config +author: Javier Neira +category: Tests +maintainer: atreyu.bbb@gmail.com + +executable issue6906 + build-depends: base + main-is: main.hs diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T6906/main.hs b/cabal/cabal-testsuite/PackageTests/Regression/T6906/main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T6906/main.hs @@ -0,0 +1,1 @@ +main = putStrLn "Hello issue6906" diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T6961/DepExternal/cabal.out b/cabal/cabal-testsuite/PackageTests/Regression/T6961/DepExternal/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T6961/DepExternal/cabal.out @@ -0,0 +1,7 @@ +# cabal v2-build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following would be built: + - pkg-foo-0 (lib:internal-lib) (first run) + - pkg-foo-0 (lib) (first run) + - pkg-bar-0 (exe:example) (first run) diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T6961/DepExternal/cabal.project b/cabal/cabal-testsuite/PackageTests/Regression/T6961/DepExternal/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T6961/DepExternal/cabal.project @@ -0,0 +1,1 @@ +packages: pkg-foo pkg-bar diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T6961/DepExternal/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/Regression/T6961/DepExternal/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T6961/DepExternal/cabal.test.hs @@ -0,0 +1,3 @@ +import Test.Cabal.Prelude +main = cabalTest $ + cabal "v2-build" ["all", "--dry-run", "--enable-tests"] diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T6961/DepExternal/pkg-bar/exe/Main.hs b/cabal/cabal-testsuite/PackageTests/Regression/T6961/DepExternal/pkg-bar/exe/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T6961/DepExternal/pkg-bar/exe/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import Lib + +main :: IO () +main = print value diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T6961/DepExternal/pkg-bar/pkg-bar.cabal b/cabal/cabal-testsuite/PackageTests/Regression/T6961/DepExternal/pkg-bar/pkg-bar.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T6961/DepExternal/pkg-bar/pkg-bar.cabal @@ -0,0 +1,13 @@ +cabal-version: 2.0 +name: pkg-bar +version: 0 +build-type: Simple + +synopsis: This should work +category: Test + +executable example + default-language: Haskell2010 + hs-source-dirs: exe + main-is: Main.hs + build-depends: base, pkg-foo diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T6961/DepExternal/pkg-foo/internal/InternalLib.hs b/cabal/cabal-testsuite/PackageTests/Regression/T6961/DepExternal/pkg-foo/internal/InternalLib.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T6961/DepExternal/pkg-foo/internal/InternalLib.hs @@ -0,0 +1,4 @@ +module InternalLib where + +value :: Int +value = 42 diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T6961/DepExternal/pkg-foo/pkg-foo.cabal b/cabal/cabal-testsuite/PackageTests/Regression/T6961/DepExternal/pkg-foo/pkg-foo.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T6961/DepExternal/pkg-foo/pkg-foo.cabal @@ -0,0 +1,19 @@ +cabal-version: 2.0 +name: pkg-foo +version: 0 +build-type: Simple + +synopsis: This should work +category: Test + +library + default-language: Haskell2010 + hs-source-dirs: src + build-depends: base <5, internal-lib + exposed-modules: Lib + +library internal-lib + default-language: Haskell2010 + hs-source-dirs: internal + build-depends: base <5 + exposed-modules: InternalLib diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T6961/DepExternal/pkg-foo/src/Lib.hs b/cabal/cabal-testsuite/PackageTests/Regression/T6961/DepExternal/pkg-foo/src/Lib.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T6961/DepExternal/pkg-foo/src/Lib.hs @@ -0,0 +1,3 @@ +module Lib (value) where + +import InternalLib (value) diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T6961/DepInternal/cabal.out b/cabal/cabal-testsuite/PackageTests/Regression/T6961/DepInternal/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T6961/DepInternal/cabal.out @@ -0,0 +1,8 @@ +# cabal v2-build +Resolving dependencies... +Error: cabal: Could not resolve dependencies: +[__0] trying: pkg-bar-0 (user goal) +[__1] next goal: pkg-foo (user goal) +[__1] rejecting: pkg-foo-0 (library 'internal-lib' is private, but it is required by pkg-bar) +[__1] fail (backjumping, conflict set: pkg-bar, pkg-foo) +After searching the rest of the dependency tree exhaustively, these were the goals I've had most trouble fulfilling: pkg-bar (2), pkg-foo (2) diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T6961/DepInternal/cabal.project b/cabal/cabal-testsuite/PackageTests/Regression/T6961/DepInternal/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T6961/DepInternal/cabal.project @@ -0,0 +1,1 @@ +packages: pkg-foo pkg-bar diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T6961/DepInternal/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/Regression/T6961/DepInternal/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T6961/DepInternal/cabal.test.hs @@ -0,0 +1,5 @@ +import Test.Cabal.Prelude +main = cabalTest $ + -- we try to depend on private component from outside, + -- so this should fail. + fails $ cabal "v2-build" ["all", "--dry-run", "--enable-tests"] diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T6961/DepInternal/pkg-bar/exe/Main.hs b/cabal/cabal-testsuite/PackageTests/Regression/T6961/DepInternal/pkg-bar/exe/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T6961/DepInternal/pkg-bar/exe/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import InternalLib + +main :: IO () +main = print value diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T6961/DepInternal/pkg-bar/pkg-bar.cabal b/cabal/cabal-testsuite/PackageTests/Regression/T6961/DepInternal/pkg-bar/pkg-bar.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T6961/DepInternal/pkg-bar/pkg-bar.cabal @@ -0,0 +1,13 @@ +cabal-version: 3.0 +name: pkg-bar +version: 0 +build-type: Simple + +synopsis: This should work +category: Test + +executable example + default-language: Haskell2010 + hs-source-dirs: exe + main-is: Main.hs + build-depends: base, pkg-foo:internal-lib diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T6961/DepInternal/pkg-foo/internal/InternalLib.hs b/cabal/cabal-testsuite/PackageTests/Regression/T6961/DepInternal/pkg-foo/internal/InternalLib.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T6961/DepInternal/pkg-foo/internal/InternalLib.hs @@ -0,0 +1,4 @@ +module InternalLib where + +value :: Int +value = 42 diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T6961/DepInternal/pkg-foo/pkg-foo.cabal b/cabal/cabal-testsuite/PackageTests/Regression/T6961/DepInternal/pkg-foo/pkg-foo.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T6961/DepInternal/pkg-foo/pkg-foo.cabal @@ -0,0 +1,19 @@ +cabal-version: 2.0 +name: pkg-foo +version: 0 +build-type: Simple + +synopsis: This should work +category: Test + +library + default-language: Haskell2010 + hs-source-dirs: src + build-depends: base <5, internal-lib + exposed-modules: Lib + +library internal-lib + default-language: Haskell2010 + hs-source-dirs: internal + build-depends: base <5 + exposed-modules: InternalLib diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T6961/DepInternal/pkg-foo/src/Lib.hs b/cabal/cabal-testsuite/PackageTests/Regression/T6961/DepInternal/pkg-foo/src/Lib.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T6961/DepInternal/pkg-foo/src/Lib.hs @@ -0,0 +1,3 @@ +module Lib (value) where + +import InternalLib (value) diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T6961/Exe/cabal.out b/cabal/cabal-testsuite/PackageTests/Regression/T6961/Exe/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T6961/Exe/cabal.out @@ -0,0 +1,6 @@ +# cabal v2-build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following would be built: + - issue6961-0 (lib:internal-lib) (first run) + - issue6961-0 (exe:example) (first run) diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T6961/Exe/cabal.project b/cabal/cabal-testsuite/PackageTests/Regression/T6961/Exe/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T6961/Exe/cabal.project @@ -0,0 +1,1 @@ +packages: . diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T6961/Exe/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/Regression/T6961/Exe/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T6961/Exe/cabal.test.hs @@ -0,0 +1,3 @@ +import Test.Cabal.Prelude +main = cabalTest $ + cabal "v2-build" ["all", "--dry-run", "--enable-tests"] diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T6961/Exe/exe/Main.hs b/cabal/cabal-testsuite/PackageTests/Regression/T6961/Exe/exe/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T6961/Exe/exe/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import Lib + +main :: IO () +main = print value diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T6961/Exe/issue6961.cabal b/cabal/cabal-testsuite/PackageTests/Regression/T6961/Exe/issue6961.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T6961/Exe/issue6961.cabal @@ -0,0 +1,19 @@ +cabal-version: 2.0 +name: issue6961 +version: 0 +build-type: Simple + +synopsis: This should work +category: Test + +library internal-lib + default-language: Haskell2010 + hs-source-dirs: src + build-depends: base <5 + exposed-modules: Lib + +executable example + default-language: Haskell2010 + hs-source-dirs: exe + main-is: Main.hs + build-depends: base, internal-lib diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T6961/Exe/src/Lib.hs b/cabal/cabal-testsuite/PackageTests/Regression/T6961/Exe/src/Lib.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T6961/Exe/src/Lib.hs @@ -0,0 +1,4 @@ +module Lib where + +value :: Int +value = 42 diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T6961/Test/cabal.out b/cabal/cabal-testsuite/PackageTests/Regression/T6961/Test/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T6961/Test/cabal.out @@ -0,0 +1,6 @@ +# cabal v2-build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following would be built: + - issue6961-0 (lib:internal-lib) (first run) + - issue6961-0 (test:example) (first run) diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T6961/Test/cabal.project b/cabal/cabal-testsuite/PackageTests/Regression/T6961/Test/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T6961/Test/cabal.project @@ -0,0 +1,1 @@ +packages: . diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T6961/Test/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/Regression/T6961/Test/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T6961/Test/cabal.test.hs @@ -0,0 +1,3 @@ +import Test.Cabal.Prelude +main = cabalTest $ + cabal "v2-build" ["all", "--dry-run", "--enable-tests"] diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T6961/Test/issue6961.cabal b/cabal/cabal-testsuite/PackageTests/Regression/T6961/Test/issue6961.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T6961/Test/issue6961.cabal @@ -0,0 +1,20 @@ +cabal-version: 2.0 +name: issue6961 +version: 0 +build-type: Simple + +synopsis: This should work +category: Test + +library internal-lib + default-language: Haskell2010 + hs-source-dirs: src + build-depends: base <5 + exposed-modules: Lib + +test-suite example + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: tests + main-is: Main.hs + build-depends: base, internal-lib diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T6961/Test/src/Lib.hs b/cabal/cabal-testsuite/PackageTests/Regression/T6961/Test/src/Lib.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T6961/Test/src/Lib.hs @@ -0,0 +1,4 @@ +module Lib where + +value :: Int +value = 42 diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T6961/Test/tests/Main.hs b/cabal/cabal-testsuite/PackageTests/Regression/T6961/Test/tests/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T6961/Test/tests/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import Lib + +main :: IO () +main = print value diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T7234/Fail/M.hs b/cabal/cabal-testsuite/PackageTests/Regression/T7234/Fail/M.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T7234/Fail/M.hs @@ -0,0 +1,1 @@ +module M where diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T7234/Fail/cabal.out b/cabal/cabal-testsuite/PackageTests/Regression/T7234/Fail/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T7234/Fail/cabal.out @@ -0,0 +1,7 @@ +# cabal v2-build +Resolving dependencies... +Error: cabal: Could not resolve dependencies: +[__0] next goal: issue7234 (user goal) +[__0] rejecting: issue7234-0 (conflict: requires unknown extension HopefullyThisExtensionWontOccur) +[__0] fail (backjumping, conflict set: issue7234) +After searching the rest of the dependency tree exhaustively, these were the goals I've had most trouble fulfilling: issue7234 (2) diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T7234/Fail/cabal.project b/cabal/cabal-testsuite/PackageTests/Regression/T7234/Fail/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T7234/Fail/cabal.project @@ -0,0 +1,1 @@ +packages: . diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T7234/Fail/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/Regression/T7234/Fail/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T7234/Fail/cabal.test.hs @@ -0,0 +1,5 @@ +import Test.Cabal.Prelude +main = cabalTest $ + -- this should fail, + -- none of GHC have extension declared in other-extensions + fails $ cabal "v2-build" ["all"] diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T7234/Fail/issue7234.cabal b/cabal/cabal-testsuite/PackageTests/Regression/T7234/Fail/issue7234.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T7234/Fail/issue7234.cabal @@ -0,0 +1,14 @@ +cabal-version: >=1.8 +name: issue7234 +version: 0 +synopsis: Old cabal-version package +description: But we have other-extensions to guide solver +author: Oleg Grenrus +category: Tests +maintainer: oleg.grenrus@iki.fi +build-type: Simple + +library + build-depends: base <5 + other-extensions: HopefullyThisExtensionWontOccur + exposed-modules: M diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T7234/Success/M.hs b/cabal/cabal-testsuite/PackageTests/Regression/T7234/Success/M.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T7234/Success/M.hs @@ -0,0 +1,1 @@ +module M where diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T7234/Success/cabal.out b/cabal/cabal-testsuite/PackageTests/Regression/T7234/Success/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T7234/Success/cabal.out @@ -0,0 +1,9 @@ +# cabal v2-build +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/cabal-testsuite/PackageTests/Regression/T7234/Success/cabal.project b/cabal/cabal-testsuite/PackageTests/Regression/T7234/Success/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T7234/Success/cabal.project @@ -0,0 +1,1 @@ +packages: . diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T7234/Success/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/Regression/T7234/Success/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T7234/Success/cabal.test.hs @@ -0,0 +1,4 @@ +import Test.Cabal.Prelude +main = cabalTest $ + -- this should not fail, just warn. + cabal "v2-build" ["all"] diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T7234/Success/issue7234.cabal b/cabal/cabal-testsuite/PackageTests/Regression/T7234/Success/issue7234.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T7234/Success/issue7234.cabal @@ -0,0 +1,15 @@ +cabal-version: >=1.8 +name: issue7234 +version: 0 +synopsis: Old cabal-version package +description: But we have other-extensions to guide solver +author: Oleg Grenrus +category: Tests +maintainer: oleg.grenrus@iki.fi +build-type: Simple + +library + build-depends: base <5 + -- this extension is in virtually all GHCs, but there should be a warning + other-extensions: GADTs + exposed-modules: M diff --git a/cabal/cabal-testsuite/PackageTests/ReplNoLoad/ModuleA.hs b/cabal/cabal-testsuite/PackageTests/ReplNoLoad/ModuleA.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ReplNoLoad/ModuleA.hs @@ -0,0 +1,4 @@ +module ModuleA where + +a :: Int +a = 42 diff --git a/cabal/cabal-testsuite/PackageTests/ReplNoLoad/ModuleB.hs b/cabal/cabal-testsuite/PackageTests/ReplNoLoad/ModuleB.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ReplNoLoad/ModuleB.hs @@ -0,0 +1,6 @@ +module Main where + +import ModuleC + +main :: IO () +main = print c diff --git a/cabal/cabal-testsuite/PackageTests/ReplNoLoad/ModuleC.hs b/cabal/cabal-testsuite/PackageTests/ReplNoLoad/ModuleC.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ReplNoLoad/ModuleC.hs @@ -0,0 +1,4 @@ +module ModuleC where + +c :: Int +c = 42 diff --git a/cabal/cabal-testsuite/PackageTests/ReplNoLoad/cabal-repl-no-load.cabal b/cabal/cabal-testsuite/PackageTests/ReplNoLoad/cabal-repl-no-load.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ReplNoLoad/cabal-repl-no-load.cabal @@ -0,0 +1,15 @@ +name: cabal-repl-no-load +version: 0.1 +build-type: Simple +cabal-version: >= 1.10 + +library + exposed-modules: ModuleA + build-depends: base + default-language: Haskell2010 + +executable exec + main-is: ModuleB.hs + other-modules: ModuleC + build-depends: base + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/ReplNoLoad/cabal.exec-no-load.out b/cabal/cabal-testsuite/PackageTests/ReplNoLoad/cabal.exec-no-load.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ReplNoLoad/cabal.exec-no-load.out @@ -0,0 +1,8 @@ +# cabal clean +# cabal repl +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - cabal-repl-no-load-0.1 (lib) (first run) +Configuring library for cabal-repl-no-load-0.1.. +Preprocessing library for cabal-repl-no-load-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/ReplNoLoad/cabal.exec-normal.out b/cabal/cabal-testsuite/PackageTests/ReplNoLoad/cabal.exec-normal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ReplNoLoad/cabal.exec-normal.out @@ -0,0 +1,8 @@ +# cabal clean +# cabal repl +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - cabal-repl-no-load-0.1 (exe:exec) (first run) +Configuring executable 'exec' for cabal-repl-no-load-0.1.. +Preprocessing executable 'exec' for cabal-repl-no-load-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/ReplNoLoad/cabal.lib-no-load.out b/cabal/cabal-testsuite/PackageTests/ReplNoLoad/cabal.lib-no-load.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ReplNoLoad/cabal.lib-no-load.out @@ -0,0 +1,8 @@ +# cabal clean +# cabal repl +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - cabal-repl-no-load-0.1 (lib) (first run) +Configuring library for cabal-repl-no-load-0.1.. +Preprocessing library for cabal-repl-no-load-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/ReplNoLoad/cabal.lib-normal.out b/cabal/cabal-testsuite/PackageTests/ReplNoLoad/cabal.lib-normal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ReplNoLoad/cabal.lib-normal.out @@ -0,0 +1,8 @@ +# cabal clean +# cabal repl +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - cabal-repl-no-load-0.1 (lib) (first run) +Configuring library for cabal-repl-no-load-0.1.. +Preprocessing library for cabal-repl-no-load-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/ReplNoLoad/cabal.project b/cabal/cabal-testsuite/PackageTests/ReplNoLoad/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ReplNoLoad/cabal.project @@ -0,0 +1,1 @@ +packages: . diff --git a/cabal/cabal-testsuite/PackageTests/ReplNoLoad/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/ReplNoLoad/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ReplNoLoad/cabal.test.hs @@ -0,0 +1,19 @@ +import Test.Cabal.Prelude + +main = do + cabalTest' "lib-normal" $ do + cabal' "clean" [] + res <- cabalWithStdin "repl" [] ":show modules" + assertOutputContains "Ok, one module loaded." res + cabalTest' "lib-no-load" $ do + cabal' "clean" [] + res <- cabalWithStdin "repl" ["--repl-no-load"] ":show modules" + assertOutputDoesNotContain "Ok, one module loaded." res + cabalTest' "exec-normal" $ do + cabal' "clean" [] + res <- cabalWithStdin "repl" ["exec"] ":show modules" + assertOutputContains "Ok, two modules loaded." res + cabalTest' "exec-no-load" $ do + cabal' "clean" [] + res <- cabalWithStdin "repl" ["--repl-no-load"] ":show modules" + assertOutputDoesNotContain "Ok, two modules loaded." res diff --git a/cabal/cabal-testsuite/PackageTests/ReplOptions/ModuleA.hs b/cabal/cabal-testsuite/PackageTests/ReplOptions/ModuleA.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ReplOptions/ModuleA.hs @@ -0,0 +1,4 @@ +module ModuleA where + +a :: Int +a = 42 diff --git a/cabal/cabal-testsuite/PackageTests/ReplOptions/ModuleC.hs b/cabal/cabal-testsuite/PackageTests/ReplOptions/ModuleC.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ReplOptions/ModuleC.hs @@ -0,0 +1,4 @@ +module ModuleC where + +c :: Int +c = 42 diff --git a/cabal/cabal-testsuite/PackageTests/ReplOptions/cabal-repl-options.cabal b/cabal/cabal-testsuite/PackageTests/ReplOptions/cabal-repl-options.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ReplOptions/cabal-repl-options.cabal @@ -0,0 +1,10 @@ +name: cabal-repl-options +version: 0.1 +build-type: Simple +cabal-version: >= 1.10 + +library + exposed-modules: ModuleA, ModuleC + build-depends: base + default-language: Haskell2010 + diff --git a/cabal/cabal-testsuite/PackageTests/ReplOptions/cabal.multiple-repl-options-multiple-flags.out b/cabal/cabal-testsuite/PackageTests/ReplOptions/cabal.multiple-repl-options-multiple-flags.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ReplOptions/cabal.multiple-repl-options-multiple-flags.out @@ -0,0 +1,9 @@ +# cabal clean +# cabal v2-repl +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - cabal-repl-options-0.1 (lib) (first run) +Configuring library for cabal-repl-options-0.1.. +Preprocessing library for cabal-repl-options-0.1.. + diff --git a/cabal/cabal-testsuite/PackageTests/ReplOptions/cabal.multiple-repl-options.out b/cabal/cabal-testsuite/PackageTests/ReplOptions/cabal.multiple-repl-options.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ReplOptions/cabal.multiple-repl-options.out @@ -0,0 +1,9 @@ +# cabal clean +# cabal v2-repl +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - cabal-repl-options-0.1 (lib) (first run) +Configuring library for cabal-repl-options-0.1.. +Preprocessing library for cabal-repl-options-0.1.. + diff --git a/cabal/cabal-testsuite/PackageTests/ReplOptions/cabal.project b/cabal/cabal-testsuite/PackageTests/ReplOptions/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ReplOptions/cabal.project @@ -0,0 +1,1 @@ +packages: . diff --git a/cabal/cabal-testsuite/PackageTests/ReplOptions/cabal.single-repl-options-multiple-flags-negative.out b/cabal/cabal-testsuite/PackageTests/ReplOptions/cabal.single-repl-options-multiple-flags-negative.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ReplOptions/cabal.single-repl-options-multiple-flags-negative.out @@ -0,0 +1,10 @@ +# cabal clean +# cabal v2-repl +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - cabal-repl-options-0.1 (lib) (first run) +Configuring library for cabal-repl-options-0.1.. +Preprocessing library for cabal-repl-options-0.1.. +Error: cabal: repl failed for cabal-repl-options-0.1-inplace. + diff --git a/cabal/cabal-testsuite/PackageTests/ReplOptions/cabal.single-repl-options-multiple-flags.out b/cabal/cabal-testsuite/PackageTests/ReplOptions/cabal.single-repl-options-multiple-flags.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ReplOptions/cabal.single-repl-options-multiple-flags.out @@ -0,0 +1,9 @@ +# cabal clean +# cabal v2-repl +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - cabal-repl-options-0.1 (lib) (first run) +Configuring library for cabal-repl-options-0.1.. +Preprocessing library for cabal-repl-options-0.1.. + diff --git a/cabal/cabal-testsuite/PackageTests/ReplOptions/cabal.single-repl-options.out b/cabal/cabal-testsuite/PackageTests/ReplOptions/cabal.single-repl-options.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ReplOptions/cabal.single-repl-options.out @@ -0,0 +1,9 @@ +# cabal clean +# cabal v2-repl +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - cabal-repl-options-0.1 (lib) (first run) +Configuring library for cabal-repl-options-0.1.. +Preprocessing library for cabal-repl-options-0.1.. + diff --git a/cabal/cabal-testsuite/PackageTests/ReplOptions/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/ReplOptions/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ReplOptions/cabal.test.hs @@ -0,0 +1,38 @@ +import Test.Cabal.Prelude + +main = do + cabalTest' "single-repl-options" $ do + cabal' "clean" [] + res <- cabalWithStdin "v2-repl" ["--repl-options=-fwrite-interface"] ":set" + assertOutputContains "Ok, two modules loaded." res + assertOutputContains " -fwrite-interface" res + cabalTest' "multiple-repl-options" $ do + cabal' "clean" [] + res <- cabalWithStdin "v2-repl" ["--repl-options=-fwrite-interface", "--repl-options=-fdefer-typed-holes"] ":set" + assertOutputContains "Ok, two modules loaded." res + assertOutputContains " -fwrite-interface" res + assertOutputContains " -fdefer-typed-holes" res + cabalTest' "single-repl-options-multiple-flags" $ do + cabal' "clean" [] + res <- cabalWithStdin "v2-repl" ["--repl-options=-fdefer-typed-holes -fwrite-interface"] ":set" + assertOutputContains "Ok, two modules loaded." res + assertOutputContains " -fwrite-interface" res + assertOutputContains " -fdefer-typed-holes" res + cabalTest' "single-repl-options-multiple-flags-negative" $ do + cabal' "clean" [] + res <- fails $ cabalWithStdin "v2-repl" ["--repl-options=-fwrite-interface -fdiagnostics-show-baret"] ":set" + assertOutputDoesNotContain "Ok, two modules loaded." res + assertOutputContains "unrecognised flag: -fdiagnostics-show-baret" res + assertOutputContains "did you mean one of:" res + cabalTest' "multiple-repl-options-multiple-flags" $ do + cabal' "clean" [] + res <- cabalWithStdin "v2-repl" [ + "--repl-options=-fforce-recomp -fwrite-interface", + "--repl-options=-fdefer-type-errors -fdefer-typed-holes" + ] ":set" + assertOutputContains "Ok, two modules loaded." res + assertOutputContains " -fwrite-interface" res + assertOutputContains " -fforce-recomp" res + assertOutputContains " -fdefer-typed-holes" res + assertOutputContains " -fdefer-type-errors" res + diff --git a/cabal/cabal-testsuite/PackageTests/SDist/T5195/cabal.out b/cabal/cabal-testsuite/PackageTests/SDist/T5195/cabal.out --- a/cabal/cabal-testsuite/PackageTests/SDist/T5195/cabal.out +++ b/cabal/cabal-testsuite/PackageTests/SDist/T5195/cabal.out @@ -1,2 +1,2 @@ # cabal v2-sdist -cabal: filepath wildcard './actually-a-directory' does not match any files. +Error: cabal: sdist of t5195-0: filepath wildcard './actually-a-directory' does not match any files. diff --git a/cabal/cabal-testsuite/PackageTests/SDist/T5195/cabal.project b/cabal/cabal-testsuite/PackageTests/SDist/T5195/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/SDist/T5195/cabal.project @@ -0,0 +1,1 @@ +packages: ./ diff --git a/cabal/cabal-testsuite/PackageTests/SDist/T5195/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/SDist/T5195/cabal.test.hs --- a/cabal/cabal-testsuite/PackageTests/SDist/T5195/cabal.test.hs +++ b/cabal/cabal-testsuite/PackageTests/SDist/T5195/cabal.test.hs @@ -1,5 +1,5 @@ import Test.Cabal.Prelude main = cabalTest $ do tmpdir <- fmap testTmpDir getTestEnv - res <- fails $ cabal' "v2-sdist" ["--ignore-project", "--list-only", "--output-directory", tmpdir] + res <- fails $ cabal' "v2-sdist" ["--list-only", "--output-directory", tmpdir] assertOutputContains "filepath wildcard './actually-a-directory' does not match any files" res diff --git a/cabal/cabal-testsuite/PackageTests/SDist/T7028/cabal.out b/cabal/cabal-testsuite/PackageTests/SDist/T7028/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/SDist/T7028/cabal.out @@ -0,0 +1,2 @@ +# cabal v2-sdist +Wrote source list to /t7028-0.list diff --git a/cabal/cabal-testsuite/PackageTests/SDist/T7028/cabal.project b/cabal/cabal-testsuite/PackageTests/SDist/T7028/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/SDist/T7028/cabal.project @@ -0,0 +1,1 @@ +packages: pkg/*.cabal diff --git a/cabal/cabal-testsuite/PackageTests/SDist/T7028/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/SDist/T7028/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/SDist/T7028/cabal.test.hs @@ -0,0 +1,4 @@ +import Test.Cabal.Prelude +main = cabalTest $ do + tmpdir <- fmap testTmpDir getTestEnv + cabal "v2-sdist" ["--list-only", "--output-directory", tmpdir, "t7028"] diff --git a/cabal/cabal-testsuite/PackageTests/SDist/T7028/pkg/Main.hs b/cabal/cabal-testsuite/PackageTests/SDist/T7028/pkg/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/SDist/T7028/pkg/Main.hs @@ -0,0 +1,1 @@ +main = putStrLn "hi" diff --git a/cabal/cabal-testsuite/PackageTests/SDist/T7028/pkg/data.txt b/cabal/cabal-testsuite/PackageTests/SDist/T7028/pkg/data.txt new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/SDist/T7028/pkg/data.txt @@ -0,0 +1,1 @@ +Lorem Ipsum diff --git a/cabal/cabal-testsuite/PackageTests/SDist/T7028/pkg/t7028.cabal b/cabal/cabal-testsuite/PackageTests/SDist/T7028/pkg/t7028.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/SDist/T7028/pkg/t7028.cabal @@ -0,0 +1,9 @@ +cabal-version: 2.2 +name: t7028 +version: 0 + +data-files: data.txt + +executable foo + default-language: Haskell2010 + main-is: Main.hs diff --git a/cabal/cabal-testsuite/PackageTests/SDist/T7124/cabal-list.out b/cabal/cabal-testsuite/PackageTests/SDist/T7124/cabal-list.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/SDist/T7124/cabal-list.out @@ -0,0 +1,3 @@ +# cabal v2-sdist +Wrote source list to /pkg-a-0.list +Error: cabal: sdist of pkg-b-0: filepath wildcard './data.txt' does not match any files. diff --git a/cabal/cabal-testsuite/PackageTests/SDist/T7124/cabal-list.test.hs b/cabal/cabal-testsuite/PackageTests/SDist/T7124/cabal-list.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/SDist/T7124/cabal-list.test.hs @@ -0,0 +1,9 @@ +import Test.Cabal.Prelude + +-- Issue 7124 +-- when we sdist, error should tell which package caused the failure + +main :: IO () +main = cabalTest $ do + tmpdir <- fmap testTmpDir getTestEnv + fails $ cabal "v2-sdist" ["--list-only", "--output-directory", tmpdir, "all"] diff --git a/cabal/cabal-testsuite/PackageTests/SDist/T7124/cabal.out b/cabal/cabal-testsuite/PackageTests/SDist/T7124/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/SDist/T7124/cabal.out @@ -0,0 +1,3 @@ +# cabal v2-sdist +Wrote tarball sdist to /pkg-a-0.tar.gz +Error: cabal: sdist of pkg-b-0: filepath wildcard './data.txt' does not match any files. diff --git a/cabal/cabal-testsuite/PackageTests/SDist/T7124/cabal.project b/cabal/cabal-testsuite/PackageTests/SDist/T7124/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/SDist/T7124/cabal.project @@ -0,0 +1,2 @@ +packages: pkg-a/*.cabal +packages: pkg-b/*.cabal diff --git a/cabal/cabal-testsuite/PackageTests/SDist/T7124/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/SDist/T7124/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/SDist/T7124/cabal.test.hs @@ -0,0 +1,9 @@ +import Test.Cabal.Prelude + +-- Issue 7124 +-- when we sdist, error should tell which package caused the failure + +main :: IO () +main = cabalTest $ do + tmpdir <- fmap testTmpDir getTestEnv + fails $ cabal "v2-sdist" ["--output-directory", tmpdir, "all"] diff --git a/cabal/cabal-testsuite/PackageTests/SDist/T7124/pkg-a/Main.hs b/cabal/cabal-testsuite/PackageTests/SDist/T7124/pkg-a/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/SDist/T7124/pkg-a/Main.hs @@ -0,0 +1,1 @@ +main = putStrLn "hi" diff --git a/cabal/cabal-testsuite/PackageTests/SDist/T7124/pkg-a/data.txt b/cabal/cabal-testsuite/PackageTests/SDist/T7124/pkg-a/data.txt new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/SDist/T7124/pkg-a/data.txt @@ -0,0 +1,1 @@ +Lorem Ipsum diff --git a/cabal/cabal-testsuite/PackageTests/SDist/T7124/pkg-a/pkg-a.cabal b/cabal/cabal-testsuite/PackageTests/SDist/T7124/pkg-a/pkg-a.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/SDist/T7124/pkg-a/pkg-a.cabal @@ -0,0 +1,9 @@ +cabal-version: 2.2 +name: pkg-a +version: 0 + +data-files: data.txt + +executable foo + default-language: Haskell2010 + main-is: Main.hs diff --git a/cabal/cabal-testsuite/PackageTests/SDist/T7124/pkg-b/Main.hs b/cabal/cabal-testsuite/PackageTests/SDist/T7124/pkg-b/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/SDist/T7124/pkg-b/Main.hs @@ -0,0 +1,1 @@ +main = putStrLn "hi" diff --git a/cabal/cabal-testsuite/PackageTests/SDist/T7124/pkg-b/pkg-b.cabal b/cabal/cabal-testsuite/PackageTests/SDist/T7124/pkg-b/pkg-b.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/SDist/T7124/pkg-b/pkg-b.cabal @@ -0,0 +1,9 @@ +cabal-version: 2.2 +name: pkg-b +version: 0 + +data-files: data.txt + +executable foo + default-language: Haskell2010 + main-is: Main.hs diff --git a/cabal/cabal-testsuite/PackageTests/SDist/T7698/cabal.out b/cabal/cabal-testsuite/PackageTests/SDist/T7698/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/SDist/T7698/cabal.out @@ -0,0 +1,2 @@ +# cabal v2-sdist +Wrote source list to /t7698-0.list diff --git a/cabal/cabal-testsuite/PackageTests/SDist/T7698/cabal.project b/cabal/cabal-testsuite/PackageTests/SDist/T7698/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/SDist/T7698/cabal.project @@ -0,0 +1,2 @@ +packages: pkg/*.cabal +extra-packages: lens diff --git a/cabal/cabal-testsuite/PackageTests/SDist/T7698/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/SDist/T7698/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/SDist/T7698/cabal.test.hs @@ -0,0 +1,4 @@ +import Test.Cabal.Prelude +main = cabalTest $ do + tmpdir <- fmap testTmpDir getTestEnv + cabal "v2-sdist" ["--list-only", "--output-directory", tmpdir, "all"] diff --git a/cabal/cabal-testsuite/PackageTests/SDist/T7698/pkg/Main.hs b/cabal/cabal-testsuite/PackageTests/SDist/T7698/pkg/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/SDist/T7698/pkg/Main.hs @@ -0,0 +1,1 @@ +main = putStrLn "hi" diff --git a/cabal/cabal-testsuite/PackageTests/SDist/T7698/pkg/t7698.cabal b/cabal/cabal-testsuite/PackageTests/SDist/T7698/pkg/t7698.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/SDist/T7698/pkg/t7698.cabal @@ -0,0 +1,7 @@ +cabal-version: 2.2 +name: t7698 +version: 0 + +executable foo + default-language: Haskell2010 + main-is: Main.hs diff --git a/cabal/cabal-testsuite/PackageTests/SPDX/cabal-old-build.test.hs b/cabal/cabal-testsuite/PackageTests/SPDX/cabal-old-build.test.hs --- a/cabal/cabal-testsuite/PackageTests/SPDX/cabal-old-build.test.hs +++ b/cabal/cabal-testsuite/PackageTests/SPDX/cabal-old-build.test.hs @@ -2,6 +2,6 @@ main = setupAndCabalTest $ withPackageDb $ do setup_install [] recordMode DoNotRecord $ do - ghc84 <- ghcVersionIs (>= mkVersion [8,4]) + ghc84 <- isGhcVersion ">= 8.4" let lic = if ghc84 then "BSD-3-Clause" else "BSD3" ghcPkg' "field" ["my", "license"] >>= assertOutputContains lic diff --git a/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/A/A.cabal b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/A/A.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/A/A.cabal @@ -0,0 +1,23 @@ +cabal-version: 2.4 +name: A +version: 0.1.0.0 +license: BSD-3-Clause + +library + exposed-modules: A + build-depends: base >=4 + hs-source-dirs: src + default-language: Haskell2010 + +executable A + main-is: Main.hs + build-depends: base >=4 + hs-source-dirs: src + default-language: Haskell2010 + +test-suite A-tests + type: exitcode-stdio-1.0 + main-is: Test.hs + build-depends: base >=4, A + hs-source-dirs: src + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/A/B/B.cabal b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/A/B/B.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/A/B/B.cabal @@ -0,0 +1,10 @@ +cabal-version: 2.4 +name: B +version: 0.1.0.0 +license: BSD-3-Clause + +library + exposed-modules: B + build-depends: base >=4.0.0.0, A + hs-source-dirs: lib + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/A/B/lib/B.hs b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/A/B/lib/B.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/A/B/lib/B.hs @@ -0,0 +1,4 @@ +module B where + +foo :: Int -> Int +foo = id diff --git a/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-all.out b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-all.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-all.out @@ -0,0 +1,20 @@ +# cabal build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - A-0.1.0.0 (lib) (first run) + - A-0.1.0.0 (exe:A) (first run) + - B-0.1.0.0 (lib) (first run) + - A-0.1.0.0 (test:A-tests) (first run) +Configuring library for A-0.1.0.0.. +Preprocessing library for A-0.1.0.0.. +Building library for A-0.1.0.0.. +Configuring executable 'A' for A-0.1.0.0.. +Preprocessing executable 'A' for A-0.1.0.0.. +Building executable 'A' for A-0.1.0.0.. +Configuring library for B-0.1.0.0.. +Preprocessing library for B-0.1.0.0.. +Building library for B-0.1.0.0.. +Configuring test suite 'A-tests' for A-0.1.0.0.. +Preprocessing test suite 'A-tests' for A-0.1.0.0.. +Building test suite 'A-tests' for A-0.1.0.0.. diff --git a/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-all.test.hs b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-all.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-all.test.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE OverloadedStrings #-} +import Test.Cabal.Prelude +import Test.Cabal.DecodeShowBuildInfo + +main = cabalTest $ do + runShowBuildInfo ["all", "--enable-tests"] + withPlan $ do + assertComponent "A" (exe "A") + defCompAssertion + { sourceFiles = ["Main.hs"] + , sourceDirs = ["src"] + } + assertComponent "A" mainLib + defCompAssertion + { modules = ["A"] + , sourceDirs = ["src"] + } + + assertComponent "B" mainLib + defCompAssertion + { modules = ["B"] + , sourceDirs = ["lib"] + } + assertComponent "A" (test "A-tests") + defCompAssertion + { sourceFiles = ["Test.hs"] + , sourceDirs = ["src"] + } diff --git a/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-exe.out b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-exe.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-exe.out @@ -0,0 +1,8 @@ +# cabal build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - A-0.1.0.0 (exe:A) (first run) +Configuring executable 'A' for A-0.1.0.0.. +Preprocessing executable 'A' for A-0.1.0.0.. +Building executable 'A' for A-0.1.0.0.. diff --git a/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-exe.test.hs b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-exe.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-exe.test.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE OverloadedStrings #-} +import Test.Cabal.Prelude +import Test.Cabal.DecodeShowBuildInfo + +main = cabalTest $ do + runShowBuildInfo ["exe:A"] + withPlan $ do + assertComponent "A" (exe "A") + defCompAssertion + { sourceFiles = ["Main.hs"] + , sourceDirs = ["src"] + -- does not list lib as a target + , compilerArgsPred = all (/= "A-0.1.0.0-inplace") + } diff --git a/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/A/cabal.project b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/A/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/A/cabal.project @@ -0,0 +1,1 @@ +packages: . ./B/ diff --git a/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/A/remove-outdated.out b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/A/remove-outdated.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/A/remove-outdated.out @@ -0,0 +1,15 @@ +# cabal build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - A-0.1.0.0 (exe:A) (first run) +Configuring executable 'A' for A-0.1.0.0.. +Preprocessing executable 'A' for A-0.1.0.0.. +Building executable 'A' for A-0.1.0.0.. +# cabal v2-build +Build profile: -w ghc- -O1 +In order, the following will be built: + - A-0.1.0.0 (exe:A) (configuration changed) +Configuring executable 'A' for A-0.1.0.0.. +Preprocessing executable 'A' for A-0.1.0.0.. +Building executable 'A' for A-0.1.0.0.. diff --git a/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/A/remove-outdated.test.hs b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/A/remove-outdated.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/A/remove-outdated.test.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE OverloadedStrings #-} +import Test.Cabal.Prelude +import Test.Cabal.DecodeShowBuildInfo +import Test.Cabal.Plan +import Control.Monad.Trans.Reader + +main = cabalTest $ do + runShowBuildInfo ["exe:A"] + withPlan $ do + assertComponent "A" (exe "A") + defCompAssertion + { sourceFiles = ["Main.hs"] + , sourceDirs = ["src"] + -- does not list lib as a target + , compilerArgsPred = all (/= "A-0.1.0.0-inplace") + } + + cabal' "v2-build" ["exe:A", "--disable-build-info"] + withPlan $ do + Just plan <- fmap testPlan ask + let fp = buildInfoFile plan "A" (exe "A") + shouldNotExist fp diff --git a/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/A/src/A.hs b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/A/src/A.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/A/src/A.hs @@ -0,0 +1,3 @@ +module A where + +foo = 2 diff --git a/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/A/src/Main.hs b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/A/src/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/A/src/Main.hs @@ -0,0 +1,3 @@ +module Main where + +main = return () diff --git a/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/A/src/Test.hs b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/A/src/Test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/A/src/Test.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = return () diff --git a/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/CompileFail/CompileFail.cabal b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/CompileFail/CompileFail.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/CompileFail/CompileFail.cabal @@ -0,0 +1,29 @@ +cabal-version: 3.0 +name: CompileFail +version: 0.1.0.0 +build-type: Simple + +library + exposed-modules: MyLib + build-depends: base + hs-source-dirs: src + default-language: Haskell2010 + +library failing + exposed-modules: MyLib2 + build-depends: base + hs-source-dirs: src + default-language: Haskell2010 + +test-suite CompileFail-test + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: base, CompileFail + +executable CompileFail-exe + default-language: Haskell2010 + hs-source-dirs: app + main-is: Main.hs + build-depends: base, failing diff --git a/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/CompileFail/app/Main.hs b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/CompileFail/app/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/CompileFail/app/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import MyLib2 (someFunc2) + +main :: IO () +main = someFunc2 diff --git a/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/CompileFail/cabal.project b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/CompileFail/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/CompileFail/cabal.project @@ -0,0 +1,1 @@ +packages: ./ diff --git a/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/CompileFail/compile-fail.out b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/CompileFail/compile-fail.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/CompileFail/compile-fail.out @@ -0,0 +1,22 @@ +# cabal build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - CompileFail-0.1.0.0 (lib) (first run) + - CompileFail-0.1.0.0 (test:CompileFail-test) (first run) +Configuring library for CompileFail-0.1.0.0.. +Preprocessing library for CompileFail-0.1.0.0.. +Building library for CompileFail-0.1.0.0.. +Configuring test suite 'CompileFail-test' for CompileFail-0.1.0.0.. +Preprocessing test suite 'CompileFail-test' for CompileFail-0.1.0.0.. +Building test suite 'CompileFail-test' for CompileFail-0.1.0.0.. +# cabal build +Build profile: -w ghc- -O1 +In order, the following will be built: + - CompileFail-0.1.0.0 (lib:failing) (first run) + - CompileFail-0.1.0.0 (exe:CompileFail-exe) (first run) +Configuring library 'failing' for CompileFail-0.1.0.0.. +Preprocessing library 'failing' for CompileFail-0.1.0.0.. +Building library 'failing' for CompileFail-0.1.0.0.. +Error: cabal: Failed to build CompileFail-0.1.0.0 because it depends on CompileFail-0.1.0.0 which itself failed to build. +Failed to build CompileFail-0.1.0.0-inplace-failing. diff --git a/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/CompileFail/compile-fail.test.hs b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/CompileFail/compile-fail.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/CompileFail/compile-fail.test.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE OverloadedStrings #-} +import Test.Cabal.Prelude +import Test.Cabal.DecodeShowBuildInfo +import Test.Cabal.Plan +import Control.Monad.Trans.Reader + +main = cabalTest $ do + -- Leaf component fails to compile, should still dump + -- build info for both components. + fails $ runShowBuildInfo ["test:CompileFail-test"] + withPlan $ do + -- Lib has to be built, thus info is dumped + assertComponent "CompileFail" mainLib + defCompAssertion + { modules = ["MyLib"] + , sourceDirs = ["src"] + } + + -- Build Info is still dumped, although compilation failed + assertComponent "CompileFail" (test "CompileFail-test") + defCompAssertion + { sourceFiles = ["Main.hs"] + , sourceDirs = ["test"] + } + + fails $ runShowBuildInfo ["exe:CompileFail-exe"] + withPlan $ do + -- Internal Lib has to be built, thus info is dumped + assertComponent "CompileFail" (lib "failing") + defCompAssertion + { modules = ["MyLib2"] + , sourceDirs = ["src"] + } + -- However, since the internal lib failed to compile + -- we can not have executable build information. + Just plan <- fmap testPlan ask + let fp = buildInfoFile plan "CompileFail" (exe "CompileFail-exe") + shouldNotExist fp diff --git a/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/CompileFail/src/MyLib.hs b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/CompileFail/src/MyLib.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/CompileFail/src/MyLib.hs @@ -0,0 +1,4 @@ +module MyLib (someFunc) where + +someFunc :: IO () +someFunc = putStrLn "someFunc" diff --git a/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/CompileFail/src/MyLib2.hs b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/CompileFail/src/MyLib2.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/CompileFail/src/MyLib2.hs @@ -0,0 +1,6 @@ +module MyLib2 (someFunc2) where + +someFunc2 :: IO () +-- Intentional typo, should fail to compile +someFunc2 = putStrn "someFunc" +-- ^^------- missing 'L' diff --git a/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/CompileFail/test/Main.hs b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/CompileFail/test/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/CompileFail/test/Main.hs @@ -0,0 +1,6 @@ +module Main (main) where + +main :: IO () +-- Intentional typo, should fail to compile +main = putStrn "Test suite not yet implemented." +-- ^^------- missing 'L' diff --git a/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/Complex.cabal b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/Complex.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/Complex.cabal @@ -0,0 +1,72 @@ +cabal-version: 2.4 +name: Complex +version: 0.1.0.0 +license: MIT + +library + build-depends: base + hs-source-dirs: src doesnt-exist + default-language: Haskell2010 + exposed-modules: + A + B + + autogen-modules: Paths_Complex + other-modules: + C + D + Paths_Complex + + ghc-options: -Wall + +executable Complex + main-is: Main.lhs + build-depends: + , base + , Complex + + hs-source-dirs: app + autogen-modules: Paths_Complex + other-modules: + Other + Paths_Complex + + ghc-options: + -threaded -rtsopts "-with-rtsopts=-N -T" -Wredundant-constraints + + default-language: Haskell2010 + +test-suite unit-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + build-depends: + , another-framework + , base + + main-is: UnitMain.hs + default-language: Haskell2010 + +test-suite func-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + build-depends: + , base + , Complex + , test-framework + + main-is: FuncMain.hs + default-language: Haskell2010 + +benchmark complex-benchmarks + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: Paths_Complex + autogen-modules: Paths_Complex + hs-source-dirs: benchmark + ghc-options: -Wall -rtsopts -threaded -with-rtsopts=-N + build-depends: + , base + , Complex + , criterion ^>=1.1.4 + + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/app/Main.lhs b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/app/Main.lhs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/app/Main.lhs @@ -0,0 +1,8 @@ +> module Main where +> +> import A +> import Other +> +> main = do +> print foo +> print bar diff --git a/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/app/Other.hs b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/app/Other.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/app/Other.hs @@ -0,0 +1,3 @@ +module Other where + +bar = () diff --git a/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/benchmark/Main.hs b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/benchmark/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/benchmark/Main.hs @@ -0,0 +1,3 @@ +module Main where + +main = pure () diff --git a/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/cabal.project b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/cabal.project @@ -0,0 +1,4 @@ +packages: . + +tests: True +benchmarks: True diff --git a/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/repo/another-framework-0.8.1.1/another-framework.cabal b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/repo/another-framework-0.8.1.1/another-framework.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/repo/another-framework-0.8.1.1/another-framework.cabal @@ -0,0 +1,8 @@ +name: another-framework +version: 0.8.1.1 +build-type: Simple +cabal-version: >= 1.10 + +library + build-depends: base + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/repo/criterion-1.1.4.0/criterion.cabal b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/repo/criterion-1.1.4.0/criterion.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/repo/criterion-1.1.4.0/criterion.cabal @@ -0,0 +1,8 @@ +name: criterion +version: 1.1.4.0 +build-type: Simple +cabal-version: >= 1.10 + +library + build-depends: base, ghc-prim + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/repo/test-framework-0.8.1.1/test-framework.cabal b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/repo/test-framework-0.8.1.1/test-framework.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/repo/test-framework-0.8.1.1/test-framework.cabal @@ -0,0 +1,8 @@ +name: test-framework +version: 0.8.1.1 +build-type: Simple +cabal-version: >= 1.10 + +library + build-depends: base + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/single.out b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/single.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/single.out @@ -0,0 +1,67 @@ +# cabal v2-update +Downloading the latest package list from test-local-repo +# cabal build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - Complex-0.1.0.0 (lib) (first run) + - Complex-0.1.0.0 (exe:Complex) (first run) +Configuring library for Complex-0.1.0.0.. +Warning: 'hs-source-dirs: doesnt-exist' specifies a directory which does not exist. +Preprocessing library for Complex-0.1.0.0.. +Building library for Complex-0.1.0.0.. +Configuring executable 'Complex' for Complex-0.1.0.0.. +Warning: 'hs-source-dirs: doesnt-exist' specifies a directory which does not exist. +Preprocessing executable 'Complex' for Complex-0.1.0.0.. +Building executable 'Complex' for Complex-0.1.0.0.. +# show-build-info Complex exe:Complex +{"cabal-lib-version":"","compiler":{"flavour":"ghc","compiler-id":"ghc-","path":""},"components":[{"type":"exe","name":"exe:Complex","unit-id":"Complex-0.1.0.0-inplace-Complex","compiler-args":["-fbuilding-cabal-package","-O","-outputdir","/single.dist/work/./dist/build//ghc-/Complex-0.1.0.0/x/Complex/build","-odir","/single.dist/work/./dist/build//ghc-/Complex-0.1.0.0/x/Complex/build","-hidir","/single.dist/work/./dist/build//ghc-/Complex-0.1.0.0/x/Complex/build","-stubdir","/single.dist/work/./dist/build//ghc-/Complex-0.1.0.0/x/Complex/build","-i","-i/single.dist/work/./dist/build//ghc-/Complex-0.1.0.0/x/Complex/build","-iapp","-i/single.dist/work/./dist/build//ghc-/Complex-0.1.0.0/x/Complex/build/Complex/autogen","-i/single.dist/work/./dist/build//ghc-/Complex-0.1.0.0/x/Complex/build/global-autogen","-I/single.dist/work/./dist/build//ghc-/Complex-0.1.0.0/x/Complex/build/Complex/autogen","-I/single.dist/work/./dist/build//ghc-/Complex-0.1.0.0/x/Complex/build/global-autogen","-I/single.dist/work/./dist/build//ghc-/Complex-0.1.0.0/x/Complex/build","-optP-include","-optP/single.dist/work/./dist/build//ghc-/Complex-0.1.0.0/x/Complex/build/Complex/autogen/cabal_macros.h","-hide-all-packages","-Wmissing-home-modules","-no-user-package-db","-package-db","/single.dist/home/.cabal/store/ghc-/package.db","-package-db","/single.dist/work/./dist/packagedb/ghc-","-package-id","","-package-id","","-XHaskell2010","-threaded","-rtsopts","-with-rtsopts=-N -T","-Wredundant-constraints"],"modules":["Other","Paths_Complex"],"src-files":["Main.lhs"],"hs-src-dirs":["app"],"src-dir":"/","cabal-file":"./Complex.cabal"}]} +# cabal build +Up to date +# show-build-info Complex lib +{"cabal-lib-version":"","compiler":{"flavour":"ghc","compiler-id":"ghc-","path":""},"components":[{"type":"lib","name":"lib","unit-id":"Complex-0.1.0.0-inplace","compiler-args":["-fbuilding-cabal-package","-O","-outputdir","/single.dist/work/./dist/build//ghc-/Complex-0.1.0.0/build","-odir","/single.dist/work/./dist/build//ghc-/Complex-0.1.0.0/build","-hidir","/single.dist/work/./dist/build//ghc-/Complex-0.1.0.0/build","-stubdir","/single.dist/work/./dist/build//ghc-/Complex-0.1.0.0/build","-i","-i/single.dist/work/./dist/build//ghc-/Complex-0.1.0.0/build","-isrc","-idoesnt-exist","-i/single.dist/work/./dist/build//ghc-/Complex-0.1.0.0/build/autogen","-i/single.dist/work/./dist/build//ghc-/Complex-0.1.0.0/build/global-autogen","-I/single.dist/work/./dist/build//ghc-/Complex-0.1.0.0/build/autogen","-I/single.dist/work/./dist/build//ghc-/Complex-0.1.0.0/build/global-autogen","-I/single.dist/work/./dist/build//ghc-/Complex-0.1.0.0/build","-optP-include","-optP/single.dist/work/./dist/build//ghc-/Complex-0.1.0.0/build/autogen/cabal_macros.h","-this-unit-id","Complex-0.1.0.0-inplace","-hide-all-packages","-Wmissing-home-modules","-no-user-package-db","-package-db","/single.dist/home/.cabal/store/ghc-/package.db","-package-db","/single.dist/work/./dist/packagedb/ghc-","-package-id","","-XHaskell2010","-Wall"],"modules":["A","B","C","D","Paths_Complex"],"src-files":[],"hs-src-dirs":["src","doesnt-exist"],"src-dir":"/","cabal-file":"./Complex.cabal"}]} +# cabal build +Build profile: -w ghc- -O1 +In order, the following will be built: + - criterion-1.1.4.0 (lib) (requires build) + - Complex-0.1.0.0 (bench:complex-benchmarks) (first run) +Configuring library for criterion-1.1.4.0.. +Preprocessing library for criterion-1.1.4.0.. +Building library for criterion-1.1.4.0.. +Installing library in +Configuring benchmark 'complex-benchmarks' for Complex-0.1.0.0.. +Warning: 'hs-source-dirs: doesnt-exist' specifies a directory which does not exist. +Preprocessing benchmark 'complex-benchmarks' for Complex-0.1.0.0.. +Building benchmark 'complex-benchmarks' for Complex-0.1.0.0.. +# show-build-info Complex bench:complex-benchmarks +{"cabal-lib-version":"","compiler":{"flavour":"ghc","compiler-id":"ghc-","path":""},"components":[{"type":"bench","name":"bench:complex-benchmarks","unit-id":"Complex-0.1.0.0-inplace-complex-benchmarks","compiler-args":["-fbuilding-cabal-package","-O","-outputdir","/single.dist/work/./dist/build//ghc-/Complex-0.1.0.0/b/complex-benchmarks/build","-odir","/single.dist/work/./dist/build//ghc-/Complex-0.1.0.0/b/complex-benchmarks/build","-hidir","/single.dist/work/./dist/build//ghc-/Complex-0.1.0.0/b/complex-benchmarks/build","-stubdir","/single.dist/work/./dist/build//ghc-/Complex-0.1.0.0/b/complex-benchmarks/build","-i","-i/single.dist/work/./dist/build//ghc-/Complex-0.1.0.0/b/complex-benchmarks/build","-ibenchmark","-i/single.dist/work/./dist/build//ghc-/Complex-0.1.0.0/b/complex-benchmarks/build/complex-benchmarks/autogen","-i/single.dist/work/./dist/build//ghc-/Complex-0.1.0.0/b/complex-benchmarks/build/global-autogen","-I/single.dist/work/./dist/build//ghc-/Complex-0.1.0.0/b/complex-benchmarks/build/complex-benchmarks/autogen","-I/single.dist/work/./dist/build//ghc-/Complex-0.1.0.0/b/complex-benchmarks/build/global-autogen","-I/single.dist/work/./dist/build//ghc-/Complex-0.1.0.0/b/complex-benchmarks/build","-optP-include","-optP/single.dist/work/./dist/build//ghc-/Complex-0.1.0.0/b/complex-benchmarks/build/complex-benchmarks/autogen/cabal_macros.h","-hide-all-packages","-Wmissing-home-modules","-no-user-package-db","-package-db","/single.dist/home/.cabal/store/ghc-/package.db","-package-db","/single.dist/work/./dist/packagedb/ghc-","-package-id","","-package-id","","-package-id","","-XHaskell2010","-Wall","-rtsopts","-threaded","-with-rtsopts=-N"],"modules":["Paths_Complex"],"src-files":["Main.hs"],"hs-src-dirs":["benchmark"],"src-dir":"/","cabal-file":"./Complex.cabal"}]} +# cabal build +Build profile: -w ghc- -O1 +In order, the following will be built: + - test-framework-0.8.1.1 (lib) (requires build) + - Complex-0.1.0.0 (test:func-test) (first run) +Configuring library for test-framework-0.8.1.1.. +Preprocessing library for test-framework-0.8.1.1.. +Building library for test-framework-0.8.1.1.. +Installing library in +Configuring test suite 'func-test' for Complex-0.1.0.0.. +Warning: 'hs-source-dirs: doesnt-exist' specifies a directory which does not exist. +Preprocessing test suite 'func-test' for Complex-0.1.0.0.. +Building test suite 'func-test' for Complex-0.1.0.0.. +# show-build-info Complex test:func-test +{"cabal-lib-version":"","compiler":{"flavour":"ghc","compiler-id":"ghc-","path":""},"components":[{"type":"test","name":"test:func-test","unit-id":"Complex-0.1.0.0-inplace-func-test","compiler-args":["-fbuilding-cabal-package","-O","-outputdir","/single.dist/work/./dist/build//ghc-/Complex-0.1.0.0/t/func-test/build","-odir","/single.dist/work/./dist/build//ghc-/Complex-0.1.0.0/t/func-test/build","-hidir","/single.dist/work/./dist/build//ghc-/Complex-0.1.0.0/t/func-test/build","-stubdir","/single.dist/work/./dist/build//ghc-/Complex-0.1.0.0/t/func-test/build","-i","-i/single.dist/work/./dist/build//ghc-/Complex-0.1.0.0/t/func-test/build","-itest","-i/single.dist/work/./dist/build//ghc-/Complex-0.1.0.0/t/func-test/build/func-test/autogen","-i/single.dist/work/./dist/build//ghc-/Complex-0.1.0.0/t/func-test/build/global-autogen","-I/single.dist/work/./dist/build//ghc-/Complex-0.1.0.0/t/func-test/build/func-test/autogen","-I/single.dist/work/./dist/build//ghc-/Complex-0.1.0.0/t/func-test/build/global-autogen","-I/single.dist/work/./dist/build//ghc-/Complex-0.1.0.0/t/func-test/build","-optP-include","-optP/single.dist/work/./dist/build//ghc-/Complex-0.1.0.0/t/func-test/build/func-test/autogen/cabal_macros.h","-hide-all-packages","-Wmissing-home-modules","-no-user-package-db","-package-db","/single.dist/home/.cabal/store/ghc-/package.db","-package-db","/single.dist/work/./dist/packagedb/ghc-","-package-id","","-package-id","","-package-id","","-XHaskell2010"],"modules":[],"src-files":["FuncMain.hs"],"hs-src-dirs":["test"],"src-dir":"/","cabal-file":"./Complex.cabal"}]} +# cabal build +Build profile: -w ghc- -O1 +In order, the following will be built: + - another-framework-0.8.1.1 (lib) (requires build) + - Complex-0.1.0.0 (test:unit-test) (first run) +Configuring library for another-framework-0.8.1.1.. +Preprocessing library for another-framework-0.8.1.1.. +Building library for another-framework-0.8.1.1.. +Installing library in +Configuring test suite 'unit-test' for Complex-0.1.0.0.. +Warning: 'hs-source-dirs: doesnt-exist' specifies a directory which does not exist. +Preprocessing test suite 'unit-test' for Complex-0.1.0.0.. +Building test suite 'unit-test' for Complex-0.1.0.0.. +# show-build-info Complex test:unit-test +{"cabal-lib-version":"","compiler":{"flavour":"ghc","compiler-id":"ghc-","path":""},"components":[{"type":"test","name":"test:unit-test","unit-id":"Complex-0.1.0.0-inplace-unit-test","compiler-args":["-fbuilding-cabal-package","-O","-outputdir","/single.dist/work/./dist/build//ghc-/Complex-0.1.0.0/t/unit-test/build","-odir","/single.dist/work/./dist/build//ghc-/Complex-0.1.0.0/t/unit-test/build","-hidir","/single.dist/work/./dist/build//ghc-/Complex-0.1.0.0/t/unit-test/build","-stubdir","/single.dist/work/./dist/build//ghc-/Complex-0.1.0.0/t/unit-test/build","-i","-i/single.dist/work/./dist/build//ghc-/Complex-0.1.0.0/t/unit-test/build","-itest","-i/single.dist/work/./dist/build//ghc-/Complex-0.1.0.0/t/unit-test/build/unit-test/autogen","-i/single.dist/work/./dist/build//ghc-/Complex-0.1.0.0/t/unit-test/build/global-autogen","-I/single.dist/work/./dist/build//ghc-/Complex-0.1.0.0/t/unit-test/build/unit-test/autogen","-I/single.dist/work/./dist/build//ghc-/Complex-0.1.0.0/t/unit-test/build/global-autogen","-I/single.dist/work/./dist/build//ghc-/Complex-0.1.0.0/t/unit-test/build","-optP-include","-optP/single.dist/work/./dist/build//ghc-/Complex-0.1.0.0/t/unit-test/build/unit-test/autogen/cabal_macros.h","-hide-all-packages","-Wmissing-home-modules","-no-user-package-db","-package-db","/single.dist/home/.cabal/store/ghc-/package.db","-package-db","/single.dist/work/./dist/packagedb/ghc-","-package-id","","-package-id","","-XHaskell2010"],"modules":[],"src-files":["UnitMain.hs"],"hs-src-dirs":["test"],"src-dir":"/","cabal-file":"./Complex.cabal"}]} diff --git a/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/single.test.hs b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/single.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/single.test.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE OverloadedStrings #-} +import Test.Cabal.Prelude +import Test.Cabal.DecodeShowBuildInfo + +main = cabalTest $ withRepo "repo" $ do + runShowBuildInfo ["exe:Complex"] >> withPlan (do + recordBuildInfo "Complex" (exe "Complex") + assertComponent "Complex" (exe "Complex") defCompAssertion + { modules = ["Other", "Paths_Complex"] + , sourceFiles = ["Main.lhs"] + , sourceDirs = ["app"] + }) + + runShowBuildInfo ["lib:Complex"] >> withPlan (do + recordBuildInfo "Complex" mainLib + assertComponent "Complex" mainLib defCompAssertion + { modules = ["A", "B", "C", "D", "Paths_Complex"] + , sourceDirs = ["src", "doesnt-exist"] + }) + + runShowBuildInfo ["benchmark:complex-benchmarks"] >> withPlan (do + recordBuildInfo "Complex" (bench "complex-benchmarks") + assertComponent "Complex" (bench "complex-benchmarks") defCompAssertion + { modules = ["Paths_Complex"] + , sourceFiles = ["Main.hs"] + , sourceDirs = ["benchmark"] + }) + + runShowBuildInfo ["test:func-test"] >> withPlan (do + recordBuildInfo "Complex" (test "func-test") + assertComponent "Complex" (test "func-test") defCompAssertion + { sourceFiles = ["FuncMain.hs"] + , sourceDirs = ["test"] + }) + + runShowBuildInfo ["test:unit-test"] >> withPlan (do + recordBuildInfo "Complex" (test "unit-test") + assertComponent "Complex" (test "unit-test") defCompAssertion + { sourceFiles = ["UnitMain.hs"] + , sourceDirs = ["test"] + }) diff --git a/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/src/A.hs b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/src/A.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/src/A.hs @@ -0,0 +1,5 @@ +module A where + +import D + +foo = d diff --git a/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/src/B.hs b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/src/B.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/src/B.hs @@ -0,0 +1,3 @@ +module B where + +b = 1 diff --git a/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/src/C.hs b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/src/C.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/src/C.hs @@ -0,0 +1,5 @@ +module C where + +import B + +c = b diff --git a/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/src/D.hs b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/src/D.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/src/D.hs @@ -0,0 +1,5 @@ +module D where + +import C + +d = c diff --git a/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/test/FuncMain.hs b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/test/FuncMain.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/test/FuncMain.hs @@ -0,0 +1,1 @@ +main = return () diff --git a/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/test/UnitMain.hs b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/test/UnitMain.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/test/UnitMain.hs @@ -0,0 +1,1 @@ +main = return () diff --git a/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Custom/Custom.cabal b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Custom/Custom.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Custom/Custom.cabal @@ -0,0 +1,21 @@ +cabal-version: 3.0 +name: Custom +version: 0.1.0.0 + +build-type: Custom + +custom-setup + setup-depends: Cabal >= 3.7, base + +library + exposed-modules: MyLib + build-depends: base + hs-source-dirs: src + default-language: Haskell2010 + +executable great-exe + main-is: Main.hs + build-depends: base, Custom + hs-source-dirs: app + default-language: Haskell2010 + diff --git a/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Custom/Setup.hs b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Custom/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Custom/Setup.hs @@ -0,0 +1,12 @@ +-- Setup.hs taken from 'cabal-testsuite/Setup.hs' +{-# LANGUAGE Haskell2010 #-} +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMainWithHooks simpleUserHooks + { buildHook = \pkg lbi hooks flags -> do + putStrLn "Custom Setup.hs has been invoked!" + buildHook simpleUserHooks pkg lbi hooks flags + } diff --git a/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Custom/app/Main.hs b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Custom/app/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Custom/app/Main.hs @@ -0,0 +1,5 @@ +module Main where + +import MyLib + +main = pure () diff --git a/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Custom/cabal.project b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Custom/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Custom/cabal.project @@ -0,0 +1,2 @@ +packages: + . diff --git a/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Custom/custom.out b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Custom/custom.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Custom/custom.out @@ -0,0 +1,7 @@ +# Setup configure +Configuring Custom-0.1.0.0... +# Setup build +Preprocessing library for Custom-0.1.0.0.. +Building library for Custom-0.1.0.0.. +Preprocessing executable 'great-exe' for Custom-0.1.0.0.. +Building executable 'great-exe' for Custom-0.1.0.0.. diff --git a/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Custom/custom.test.hs b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Custom/custom.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Custom/custom.test.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE OverloadedStrings #-} +import Test.Cabal.Prelude +import Test.Cabal.DecodeShowBuildInfo +import Control.Monad.Trans.Reader + +main = setupTest $ do + -- No cabal test because per-component is broken with it + skipUnlessGhcVersion ">= 8.1" + withPackageDb $ do + setup_build ["--enable-build-info"] + env <- ask + let buildInfoFp = testDistDir env "build-info.json" + buildInfo <- decodeBuildInfoFile buildInfoFp + assertCommonBuildInfo buildInfo + let [libBI, exeBI] = components buildInfo + + assertComponentPure libBI defCompAssertion + { modules = ["MyLib"] + , compType = "lib" + , sourceDirs = ["src"] + } + + assertComponentPure exeBI defCompAssertion + { sourceFiles = ["Main.hs"] + , compType = "exe" + , sourceDirs = ["app"] + } + diff --git a/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Custom/src/MyLib.hs b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Custom/src/MyLib.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ShowBuildInfo/Custom/src/MyLib.hs @@ -0,0 +1,4 @@ +module MyLib (someFunc) where + +someFunc :: IO () +someFunc = putStrLn "someFunc" diff --git a/cabal/cabal-testsuite/PackageTests/TemplateHaskell/dynamic/TH.hs b/cabal/cabal-testsuite/PackageTests/TemplateHaskell/dynamic/TH.hs --- a/cabal/cabal-testsuite/PackageTests/TemplateHaskell/dynamic/TH.hs +++ b/cabal/cabal-testsuite/PackageTests/TemplateHaskell/dynamic/TH.hs @@ -1,4 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} module TH where +import Language.Haskell.TH (ExpQ) + +splice :: ExpQ splice = [| () |] diff --git a/cabal/cabal-testsuite/PackageTests/TemplateHaskell/dynamic/setup.test.hs b/cabal/cabal-testsuite/PackageTests/TemplateHaskell/dynamic/setup.test.hs --- a/cabal/cabal-testsuite/PackageTests/TemplateHaskell/dynamic/setup.test.hs +++ b/cabal/cabal-testsuite/PackageTests/TemplateHaskell/dynamic/setup.test.hs @@ -2,5 +2,5 @@ -- Test building a dynamic library/executable which uses Template -- Haskell main = setupAndCabalTest $ do - skipUnless =<< hasSharedLibraries + skipUnless "no shared libs" =<< hasSharedLibraries setup_build ["--enable-shared", "--enable-executable-dynamic"] diff --git a/cabal/cabal-testsuite/PackageTests/TemplateHaskell/profiling/TH.hs b/cabal/cabal-testsuite/PackageTests/TemplateHaskell/profiling/TH.hs --- a/cabal/cabal-testsuite/PackageTests/TemplateHaskell/profiling/TH.hs +++ b/cabal/cabal-testsuite/PackageTests/TemplateHaskell/profiling/TH.hs @@ -1,4 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} module TH where +import Language.Haskell.TH (ExpQ) + +splice :: ExpQ splice = [| () |] diff --git a/cabal/cabal-testsuite/PackageTests/TemplateHaskell/profiling/setup.test.hs b/cabal/cabal-testsuite/PackageTests/TemplateHaskell/profiling/setup.test.hs --- a/cabal/cabal-testsuite/PackageTests/TemplateHaskell/profiling/setup.test.hs +++ b/cabal/cabal-testsuite/PackageTests/TemplateHaskell/profiling/setup.test.hs @@ -2,6 +2,6 @@ -- Test building a profiled library/executable which uses Template Haskell -- (setup has to build the non-profiled version first) main = setupAndCabalTest $ do - skipUnless =<< hasProfiledLibraries + skipUnless "no profiling libs" =<< hasProfiledLibraries setup_build ["--enable-library-profiling", "--enable-profiling"] diff --git a/cabal/cabal-testsuite/PackageTests/TemplateHaskell/vanilla/TH.hs b/cabal/cabal-testsuite/PackageTests/TemplateHaskell/vanilla/TH.hs --- a/cabal/cabal-testsuite/PackageTests/TemplateHaskell/vanilla/TH.hs +++ b/cabal/cabal-testsuite/PackageTests/TemplateHaskell/vanilla/TH.hs @@ -1,4 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} module TH where +import Language.Haskell.TH (ExpQ) + +splice :: ExpQ splice = [| () |] diff --git a/cabal/cabal-testsuite/PackageTests/TestCodeGenerator/Foo.hs b/cabal/cabal-testsuite/PackageTests/TestCodeGenerator/Foo.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/TestCodeGenerator/Foo.hs @@ -0,0 +1,4 @@ +module Foo where + +fooTest :: [String] -> Bool +fooTest _ = True diff --git a/cabal/cabal-testsuite/PackageTests/TestCodeGenerator/cabal.out b/cabal/cabal-testsuite/PackageTests/TestCodeGenerator/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/TestCodeGenerator/cabal.out @@ -0,0 +1,21 @@ +# cabal v2-test +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - my-0.1 (lib) (first run) + - test-code-gen-0.1.0.0 (exe:test-code-gen) (first run) + - my-0.1 (test:test-Foo) (first run) +Configuring library for my-0.1.. +Preprocessing library for my-0.1.. +Building library for my-0.1.. +Configuring executable 'test-code-gen' for test-code-gen-0.1.0.0.. +Preprocessing executable 'test-code-gen' for test-code-gen-0.1.0.0.. +Building executable 'test-code-gen' for test-code-gen-0.1.0.0.. +Configuring test suite 'test-Foo' for my-0.1.. +Preprocessing test suite 'test-Foo' for my-0.1.. +Building test suite 'test-Foo' for my-0.1.. +Running 1 test suites... +Test suite test-Foo: RUNNING... +Test suite test-Foo: PASS +Test suite logged to: /cabal.dist/work/./dist/build//ghc-/my-0.1/t/test-Foo/test/my-0.1-test-Foo.log +1 of 1 test suites (1 of 1 test cases) passed. diff --git a/cabal/cabal-testsuite/PackageTests/TestCodeGenerator/cabal.project b/cabal/cabal-testsuite/PackageTests/TestCodeGenerator/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/TestCodeGenerator/cabal.project @@ -0,0 +1,1 @@ +packages: . test-code-gen/test-code-gen.cabal diff --git a/cabal/cabal-testsuite/PackageTests/TestCodeGenerator/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/TestCodeGenerator/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/TestCodeGenerator/cabal.test.hs @@ -0,0 +1,4 @@ +import Test.Cabal.Prelude + +main = cabalTest $ do + cabal "v2-test" [] diff --git a/cabal/cabal-testsuite/PackageTests/TestCodeGenerator/my.cabal b/cabal/cabal-testsuite/PackageTests/TestCodeGenerator/my.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/TestCodeGenerator/my.cabal @@ -0,0 +1,19 @@ +cabal-version: 3.8 +name: my +version: 0.1 +license: BSD-3-Clause +build-type: Simple + +library + default-language: Haskell2010 + exposed-modules: Foo + build-depends: base + +test-suite test-Foo + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: Main.hs + build-tool-depends: test-code-gen:test-code-gen + code-generators: test-code-gen + build-depends: base, my diff --git a/cabal/cabal-testsuite/PackageTests/TestCodeGenerator/test-code-gen/CHANGELOG.md b/cabal/cabal-testsuite/PackageTests/TestCodeGenerator/test-code-gen/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/TestCodeGenerator/test-code-gen/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for test-code-gen + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/cabal/cabal-testsuite/PackageTests/TestCodeGenerator/test-code-gen/LICENSE b/cabal/cabal-testsuite/PackageTests/TestCodeGenerator/test-code-gen/LICENSE new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/TestCodeGenerator/test-code-gen/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2022, + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/cabal/cabal-testsuite/PackageTests/TestCodeGenerator/test-code-gen/app/Main.hs b/cabal/cabal-testsuite/PackageTests/TestCodeGenerator/test-code-gen/app/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/TestCodeGenerator/test-code-gen/app/Main.hs @@ -0,0 +1,18 @@ +module Main where +import System.FilePath +import System.Environment + +main :: IO () +main = do + (tgt:rest) <- getArgs + let (srcDirs, ghcArgs) = splitArgs rest + let isGood = srcDirs == ["."] && "-outputdir" `elem` ghcArgs + if isGood + then writeFile (tgt "Main.hs") $ "module Main where main = pure ()" + else writeFile (tgt "Main.hs") $ "module Main where main = error \"failure\"" + +splitArgs = go [] + where + go r ("--":xs) = (reverse r, xs) + go r (x:xs) = go (x:r) xs + go r [] = (reverse r, []) diff --git a/cabal/cabal-testsuite/PackageTests/TestCodeGenerator/test-code-gen/test-code-gen.cabal b/cabal/cabal-testsuite/PackageTests/TestCodeGenerator/test-code-gen/test-code-gen.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/TestCodeGenerator/test-code-gen/test-code-gen.cabal @@ -0,0 +1,15 @@ +cabal-version: 3.0 +name: test-code-gen +version: 0.1.0.0 +license: BSD-3-Clause +license-file: LICENSE +build-type: Simple +extra-doc-files: CHANGELOG.md + + +executable test-code-gen + main-is: Main.hs + build-depends: base, filepath + hs-source-dirs: app + default-language: Haskell2010 + diff --git a/cabal/cabal-testsuite/PackageTests/TestCodeGenerator/tests/blank b/cabal/cabal-testsuite/PackageTests/TestCodeGenerator/tests/blank new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/TestCodeGenerator/tests/blank diff --git a/cabal/cabal-testsuite/PackageTests/TestNameCollision/setup.test.hs b/cabal/cabal-testsuite/PackageTests/TestNameCollision/setup.test.hs --- a/cabal/cabal-testsuite/PackageTests/TestNameCollision/setup.test.hs +++ b/cabal/cabal-testsuite/PackageTests/TestNameCollision/setup.test.hs @@ -3,7 +3,7 @@ -- which is in the database, we can still use the test case (they -- should NOT shadow). main = setupAndCabalTest $ do - skipUnless =<< hasCabalForGhc -- use of library test suite + skipUnless "cabal for ghc" =<< hasCabalForGhc -- use of library test suite withPackageDb $ do withDirectory "parent" $ setup_install [] withDirectory "child" $ do diff --git a/cabal/cabal-testsuite/PackageTests/TestStanza/setup.test.hs b/cabal/cabal-testsuite/PackageTests/TestStanza/setup.test.hs --- a/cabal/cabal-testsuite/PackageTests/TestStanza/setup.test.hs +++ b/cabal/cabal-testsuite/PackageTests/TestStanza/setup.test.hs @@ -7,6 +7,7 @@ import Distribution.Types.UnqualComponentName import Control.Monad.IO.Class import Distribution.Simple.Configure +import Distribution.Utils.Path main = setupAndCabalTest $ do assertOutputDoesNotContain "unknown section type" @@ -19,5 +20,8 @@ (testInterface gotTestSuite) -- NB: Not testing targetBuildDepends (testBuildInfo gotTestSuite) -- as dependency varies with cabal-install - assertEqual "testBuildInfo/hsSourceDirs" ["."] (hsSourceDirs (testBuildInfo gotTestSuite)) + assertEqual + "testBuildInfo/hsSourceDirs" + [sameDirectory] + (hsSourceDirs (testBuildInfo gotTestSuite)) return () diff --git a/cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/cabal-with-hpc.multitest.hs b/cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/cabal-with-hpc.multitest.hs --- a/cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/cabal-with-hpc.multitest.hs +++ b/cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/cabal-with-hpc.multitest.hs @@ -9,8 +9,8 @@ import Test.Cabal.Prelude main = cabalTest $ do - skipIf =<< isOSX -- TODO: re-enable this once the macOS Travis - -- issues are resolved, see discussion in #4902. + skipIf "osx" =<< isOSX -- TODO: re-enable this once the macOS CI + -- issues are resolved, see discussion in #4902. hasShared <- hasSharedLibraries hasProfiled <- hasProfiledLibraries diff --git a/cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/cabal.out b/cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/cabal.out --- a/cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/cabal.out +++ b/cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/cabal.out @@ -9,7 +9,6 @@ Preprocessing library for my-0.1.. Building library for my-0.1.. Configuring test suite 'test-Short' for my-0.1.. -Warning: The package has an extraneous version range for a dependency on an internal library: my >=0 && ==0.1, my >=0 && ==0.1. This version range includes the current package but isn't needed as the current package's library will always be used. Preprocessing test suite 'test-Short' for my-0.1.. Building test suite 'test-Short' for my-0.1.. Running 1 test suites... @@ -18,7 +17,6 @@ Test suite logged to: /cabal.dist/work/./dist/build//ghc-/my-0.1/t/test-Short/test/my-0.1-test-Short.log 1 of 1 test suites (1 of 1 test cases) passed. Configuring test suite 'test-Foo' for my-0.1.. -Warning: The package has an extraneous version range for a dependency on an internal library: my >=0 && ==0.1, my >=0 && ==0.1. This version range includes the current package but isn't needed as the current package's library will always be used. Preprocessing test suite 'test-Foo' for my-0.1.. Building test suite 'test-Foo' for my-0.1.. Running 1 test suites... diff --git a/cabal/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup-deadlock.test.hs b/cabal/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup-deadlock.test.hs --- a/cabal/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup-deadlock.test.hs +++ b/cabal/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup-deadlock.test.hs @@ -1,5 +1,5 @@ import Test.Cabal.Prelude main = setupAndCabalTest $ do - skipUnless =<< hasCabalForGhc + skipUnless "no Cabal for GHC" =<< hasCabalForGhc setup_build ["--enable-tests"] fails $ setup "test" [] diff --git a/cabal/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup.test.hs b/cabal/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup.test.hs --- a/cabal/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup.test.hs +++ b/cabal/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup.test.hs @@ -1,5 +1,5 @@ import Test.Cabal.Prelude -- Test if detailed-0.9 builds correctly main = setupAndCabalTest $ do - skipUnless =<< hasCabalForGhc + skipUnless "no Cabal for GHC" =<< hasCabalForGhc setup_build ["--enable-tests"] diff --git a/cabal/cabal-testsuite/PackageTests/UserConfig/cabal.out b/cabal/cabal-testsuite/PackageTests/UserConfig/cabal.out --- a/cabal/cabal-testsuite/PackageTests/UserConfig/cabal.out +++ b/cabal/cabal-testsuite/PackageTests/UserConfig/cabal.out @@ -1,7 +1,7 @@ # cabal user-config Writing default configuration to /cabal.dist/cabal-config # cabal user-config -cabal: /cabal.dist/cabal-config already exists. +Error: cabal: /cabal.dist/cabal-config already exists. # cabal user-config Writing default configuration to /cabal.dist/cabal-config # cabal user-config diff --git a/cabal/cabal-testsuite/PackageTests/postCheckoutCommand/cabal.negative.project b/cabal/cabal-testsuite/PackageTests/postCheckoutCommand/cabal.negative.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/postCheckoutCommand/cabal.negative.project @@ -0,0 +1,9 @@ +packages: . + +source-repository-package + type: git +-- A Sample repo to test post-checkout-command + location: https://github.com/haskell/bytestring + post-checkout-command: false + tag: 0.10.9.0 +-- https://en.wikipedia.org/wiki/True_and_false_(commands) diff --git a/cabal/cabal-testsuite/PackageTests/postCheckoutCommand/cabal.out b/cabal/cabal-testsuite/PackageTests/postCheckoutCommand/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/postCheckoutCommand/cabal.out @@ -0,0 +1,2 @@ +# cabal v2-build +# cabal v2-build diff --git a/cabal/cabal-testsuite/PackageTests/postCheckoutCommand/cabal.positive.project b/cabal/cabal-testsuite/PackageTests/postCheckoutCommand/cabal.positive.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/postCheckoutCommand/cabal.positive.project @@ -0,0 +1,9 @@ +packages: . + +source-repository-package + type: git +-- A Sample repo to test post-checkout-command + location: https://github.com/haskell/bytestring + post-checkout-command: true + tag: 0.10.9.0 +-- https://en.wikipedia.org/wiki/True_and_false_(commands) diff --git a/cabal/cabal-testsuite/PackageTests/postCheckoutCommand/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/postCheckoutCommand/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/postCheckoutCommand/cabal.test.hs @@ -0,0 +1,8 @@ +import Test.Cabal.Prelude + +main = cabalTest $ do + skipIfWindows + withProjectFile "cabal.positive.project" $ do + cabal "v2-build" ["-v0"] + withProjectFile "cabal.negative.project" $ do + fails $ cabal "v2-build" ["-v0"] diff --git a/cabal/cabal-testsuite/PackageTests/postCheckoutCommand/example.cabal b/cabal/cabal-testsuite/PackageTests/postCheckoutCommand/example.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/postCheckoutCommand/example.cabal @@ -0,0 +1,9 @@ +cabal-version: 2.4 +name: example +version: 1.0 + +library + exposed-modules: Example + build-depends: base + hs-source-dirs: src + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/postCheckoutCommand/src/Example.hs b/cabal/cabal-testsuite/PackageTests/postCheckoutCommand/src/Example.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/postCheckoutCommand/src/Example.hs @@ -0,0 +1,4 @@ +module Example (someFunc) where + +someFunc :: IO () +someFunc = putStrLn "Example" diff --git a/cabal/cabal-testsuite/README.md b/cabal/cabal-testsuite/README.md --- a/cabal/cabal-testsuite/README.md +++ b/cabal/cabal-testsuite/README.md @@ -4,7 +4,7 @@ How to run ---------- -1. Build `cabal-tests` (`cabal new-build cabal-tests`) +1. Build `cabal-tests` (`cabal build cabal-tests`) 2. Run the `cabal-tests` executable. It will scan for all tests in your current directory and subdirectories and run them. To run a specific set of tests, use `cabal-tests PATH ...`. You can @@ -36,12 +36,13 @@ Otherwise, here is a walkthrough: 1. Create the package(s) that you need for your test in a - new directory. (Currently, tests are stored in `PackageTests` - and `tests`; we might reorganize this soon.) + new directory. + (Currently (2021-10-06), tests are stored in `PackageTests`, + with the exception of one test stored in `tests`.) 2. Create one or more `.test.hs` scripts in your directory, using the template: - ``` + ```haskell import Test.Cabal.Prelude main = setupAndCabalTest $ do -- your test code here @@ -53,7 +54,7 @@ other, use `setupTest` or `cabalTest`). Code runs in the `TestM` monad, which manages some administrative - environment (e.g., the test that is running, etc.) + environment (e.g., the test that is running, etc.). `Test.Cabal.Prelude` contains a number of useful functions for testing implemented in this monad, including the functions `cabal` and `setup` which let you invoke those respective programs. You should @@ -62,8 +63,19 @@ are used). If you don't see something anywhere, that's probably because it isn't implemented. Implement it! + To include parts that are supposed to fail (in the sense that a + non-zero exit code is returned), there is the `fails` combinator, + e.g.: + ```haskell + main = cabalTest $ do + fails $ cabal "bad-command" [ "bad", "args" ] + cabal "good-command" [ "good", "args" ] + fails $ cabal "another-bad-one" [ ... ] + ... + ``` + 3. Run your tests using `cabal-tests` (no need to rebuild when - you add or modify a test; it is automatically picked up.) + you add or modify a test; it is automatically picked up). The first time you run a test, assuming everything else is in order, it will complain that the actual output doesn't match the expected output. Use the `--accept` flag to accept the @@ -72,7 +84,7 @@ We also support a `.multitest.hs` prefix; eventually this will allow multiple tests to be defined in one file but run in parallel; at the moment, these just indicate long running tests that should -be run early (to avoid straggling.) +be run early (to avoid straggling). Frequently asked questions -------------------------- @@ -104,18 +116,17 @@ * If you built it using `Setup build`, use `runExe` * If you installed it using `Setup install` or `cabal install`, use `runInstalledExe`. -* If you built it with `cabal new-build`, use `runPlanExe`; note +* If you built it with `cabal build`, use `runPlanExe`; note that you will need to run this inside of a `withPlan` that is - placed *after* you have invoked `new-build`. (Grep - for an example!) + placed *after* you have invoked `build`. (Grep for an example!) -**How do I turn of accept tests? My test output wobbles to much.** +**How do I turn off accept tests? My test output wobbles too much.** Use `recordMode DoNotRecord`. This should be a last resort; consider modifying Cabal so that the output is stable. If you must do this, make sure you add extra, manual tests to ensure the output looks like what you expect. -**How can I manually test for a string in output?** Use the hyphenated +**How can I manually test for a string in output?** Use the primed variants of a command (e.g., `cabal'` rather than `cabal`) and use `assertOutputContains`. Note that this will search over BOTH stdout and stderr. @@ -123,7 +134,7 @@ **How do I skip running a test in some environments?** Use the `skipIf` and `skipUnless` combinators. Useful parameters to test these with include `hasSharedLibraries`, `hasProfiledLibraries`, -`hasCabalShared`, `ghcVersionIs`, `isWindows`, `isLinux`, `isOSX` +`hasCabalShared`, `isGhcVersion`, `isWindows`, `isLinux`, `isOSX` and `hasCabalForGhc`. **I programatically modified a file in my test suite, but Cabal/GHC @@ -146,7 +157,7 @@ not hermetic (e.g., `cabal freeze`). In this case, cabal-testsuite supports opting into a hermetic test, where we first make copy of all the relevant source code before starting the test. You can opt into -this mode using the 'withSourceCopy' combinator (search for examples!) +this mode using the `withSourceCopy` combinator (search for examples!) This mode is subject to the following limitations: * You must be running the test inside a valid Git checkout of the test @@ -222,7 +233,8 @@ Expect tests ------------ -An expect test is a test where we read out the output of the test +An expect test (aka _golden test_) +is a test where we read out the output of the test and compare it directly against a saved copy of the test output. When test output changes, you can ask the test suite to "accept" the new output, which automatically overwrites the old expected @@ -237,16 +249,16 @@ Still, we'd like to take advantage of expect tests for Cabal's error reporting. So here's our strategy: -1. We have a new verbosity flag +markoutput which lets you toggle the emission - of '-----BEGIN CABAL OUTPUT-----' and '-----END CABAL OUTPUT-----' +1. We have a new verbosity flag `+markoutput` which lets you toggle the emission + of `-----BEGIN CABAL OUTPUT-----` and `-----END CABAL OUTPUT-----` stanzas. 2. When someone requests an expect test, we ONLY consider output between these flags. The expectation is that Cabal will only enclose output it controls -between these stanzas. In practice, this just means we wrap die, -warn and notice with these markers. +between these stanzas. In practice, this just means we wrap `die`, +`warn` and `notice` with these markers. An added benefit of this strategy is that we can continue operating at high verbosity by default (which is very helpful for having useful @@ -266,7 +278,7 @@ * We have some munging on the output, to remove common sources of non-determinism: paths, GHC versions, boot package versions, etc. - Check normalizeOutput to see what we do. Note that we save + Check `normalizeOutput` to see what we do. Note that we save *normalized* output, so if you modify the normalizer you will need to rerun the test suite accepting everything. @@ -279,9 +291,9 @@ Some other notes: -* It's good style to put default-language in all your stanzas, so - Cabal doesn't complain about it (that warning is marked!) Ditto - with cabal-version at the top of your Cabal file. +* It's good style to put `default-language` in all your stanzas, so + Cabal doesn't complain about it (that warning is marked!). Ditto + with `cabal-version` at the top of your Cabal file. * If you can't get the output of a test to be deterministic, no problem: just exclude it from recording and do a manual test diff --git a/cabal/cabal-testsuite/cabal-testsuite.cabal b/cabal/cabal-testsuite/cabal-testsuite.cabal --- a/cabal/cabal-testsuite/cabal-testsuite.cabal +++ b/cabal/cabal-testsuite/cabal-testsuite.cabal @@ -1,7 +1,7 @@ cabal-version: 2.2 name: cabal-testsuite version: 3 -copyright: 2003-2020, Cabal Development Team (see AUTHORS file) +copyright: 2003-2022, Cabal Development Team (see AUTHORS file) license: BSD-3-Clause license-file: LICENSE author: Cabal Development Team @@ -26,9 +26,10 @@ default-language: Haskell2010 build-depends: - , base >= 4.6 && <4.15 + , base >= 4.6 && <4.17 -- this needs to match the in-tree lib:Cabal version - , Cabal == 3.3.0.0 + , Cabal ^>=3.8.0.0 + , Cabal-syntax ^>=3.8.0.0 ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns @@ -39,6 +40,7 @@ hs-source-dirs: src exposed-modules: Test.Cabal.CheckArMetadata + Test.Cabal.DecodeShowBuildInfo Test.Cabal.Monad Test.Cabal.OutputNormalizer Test.Cabal.Plan @@ -46,6 +48,7 @@ Test.Cabal.Run Test.Cabal.Script Test.Cabal.Server + Test.Cabal.TestCode Test.Cabal.Workdir other-modules: @@ -54,27 +57,27 @@ Test.Cabal.ScriptEnv0 build-depends: - , aeson ^>= 1.4.2.0 || ^>=1.5.0.0 + , aeson ^>= 1.4.2.0 || ^>=1.5.0.0 || ^>= 2.0.0.0 || ^>= 2.1.0.0 , async ^>= 2.2.1 - , attoparsec ^>= 0.13.2.2 - , base16-bytestring ^>= 0.1.1.6 - , bytestring ^>= 0.10.0.2 + , attoparsec ^>= 0.13.2.2 || ^>=0.14.1 + , base16-bytestring ^>= 0.1.1.6 || ^>= 1.0.0.0 + , bytestring ^>= 0.10.0.2 || ^>= 0.11.0.0 , containers ^>= 0.5.0.0 || ^>= 0.6.0.1 , cryptohash-sha256 ^>= 0.11.101.0 , directory ^>= 1.2.0.1 || ^>= 1.3.0.0 , exceptions ^>= 0.10.0 , filepath ^>= 1.3.0.1 || ^>= 1.4.0.0 - , optparse-applicative ^>= 0.14.3.0 || ^>=0.15.1.0 - , process ^>= 1.1.0.2 || ^>= 1.2.0.0 || ^>= 1.4.2.0 || ^>= 1.6.1.0 - , regex-compat-tdfa ^>= 0.95.1.4 + , network-wait ^>= 0.1.2.0 || ^>= 0.2.0.0 + , optparse-applicative ^>= 0.14.3.0 || ^>=0.15.1.0 || ^>=0.16.0.0 || ^>= 0.17.0.0 + , process ^>= 1.2.1.0 || ^>= 1.4.2.0 || ^>= 1.6.1.0 + , regex-base ^>= 0.94.0.1 , regex-tdfa ^>= 1.2.3.1 || ^>=1.3.1.0 + , retry ^>= 0.9.1.0 + , array ^>= 0.4.0.1 || ^>= 0.5.0.0 , temporary ^>= 1.3 - , text ^>= 1.2.3.1 + , text ^>= 1.2.3.1 || ^>= 2.0.1 , transformers ^>= 0.3.0.0 || ^>= 0.4.2.0 || ^>= 0.5.2.0 - if !impl(ghc >= 8.0) - build-depends: semigroups - if !os(windows) build-depends: , unix ^>= 2.6.0.0 || ^>= 2.7.0.0 @@ -89,7 +92,7 @@ ghc-options: -threaded build-depends: , cabal-testsuite - -- cosntraints inherited via lib:cabal-testsuite component + -- constraints inherited via lib:cabal-testsuite component , async , exceptions , filepath @@ -108,5 +111,8 @@ custom-setup -- we only depend on even stable releases of lib:Cabal - setup-depends: Cabal == 2.2.* || == 2.4.* || == 3.0.* || ==3.2.*, + -- and due to Custom complexity and ConstraintSetupCabalMaxVersion + -- it can't be the current version + setup-depends: Cabal == 3.6.*, + Cabal-syntax == 3.6.*, base, filepath, directory diff --git a/cabal/cabal-testsuite/main/cabal-tests.hs b/cabal/cabal-testsuite/main/cabal-tests.hs --- a/cabal/cabal-testsuite/main/cabal-tests.hs +++ b/cabal/cabal-testsuite/main/cabal-tests.hs @@ -7,6 +7,7 @@ import Test.Cabal.Script import Test.Cabal.Server import Test.Cabal.Monad +import Test.Cabal.TestCode import Distribution.Verbosity (normal, verbose, Verbosity) import Distribution.Simple.Utils (getDirectoryContentsRecursive) @@ -17,7 +18,6 @@ import Control.Concurrent.Async import Control.Exception import Control.Monad -import qualified Control.Exception as E import GHC.Conc (numCapabilities) import Data.List import Text.Printf @@ -25,13 +25,7 @@ import System.IO import System.FilePath import System.Exit -import System.Process ( -#if MIN_VERSION_process(1,2,0) - callProcess, -#else - proc, createProcess, waitForProcess, terminateProcess, -#endif - showCommandForUser) +import System.Process (callProcess, showCommandForUser) #if !MIN_VERSION_base(4,12,0) import Data.Monoid ((<>)) @@ -111,7 +105,11 @@ hPutStrLn stderr $ "Using dist dir: " ++ dist_dir -- Get ready to go! senv <- mkScriptEnv verbosity - let runTest runner path + + let runTest :: (Maybe cwd -> [unusedEnv] -> FilePath -> [String] -> IO result) + -> FilePath + -> IO result + runTest runner path = runner Nothing [] path $ ["--builddir", dist_dir, path] ++ renderCommonArgs (mainCommonArgs args) @@ -144,6 +142,7 @@ work_queue <- newMVar all_tests unexpected_fails_var <- newMVar [] unexpected_passes_var <- newMVar [] + skipped_var <- newMVar [] chan <- newChan let logAll msg = writeChan chan (ServerLogMsg AllServers msg) @@ -174,25 +173,16 @@ r <- runTest (runOnServer server) path end <- getTime let time = end - start - code = serverResultExitCode r - status - | code == ExitSuccess - = "OK" - | code == ExitFailure skipExitCode - = "SKIP" - | code == ExitFailure expectedBrokenExitCode - = "KNOWN FAIL" - | code == ExitFailure unexpectedSuccessExitCode - = "UNEXPECTED OK" - | otherwise - = "FAIL" - unless (mainArgHideSuccesses args && status == "OK") $ do + code = serverResultTestCode r + + unless (mainArgHideSuccesses args && code == TestCodeOk) $ do logMeta $ - path ++ replicate (margin - length path) ' ' ++ status ++ + path ++ replicate (margin - length path) ' ' ++ displayTestCode code ++ if time >= 0.01 then printf " (%.2fs)" time else "" - when (status == "FAIL") $ do -- TODO: ADT + + when (code == TestCodeFail) $ do let description | mainArgQuiet args = serverResultStderr r | otherwise = @@ -204,55 +194,39 @@ ++ "*** unexpected failure for " ++ path ++ "\n\n" modifyMVar_ unexpected_fails_var $ \paths -> return (path:paths) - when (status == "UNEXPECTED OK") $ + + when (code == TestCodeUnexpectedOk) $ modifyMVar_ unexpected_passes_var $ \paths -> return (path:paths) + + when (isTestCodeSkip code) $ + modifyMVar_ skipped_var $ \paths -> + return (path:paths) + go server - mask $ \restore -> do - -- Start as many threads as requested by -j to spawn - -- GHCi servers and start running tests off of the - -- run queue. - -- NB: we don't use 'withAsync' because it's more - -- convenient to generate n threads this way (and when - -- one fails, we can cancel everyone at once.) - as <- replicateM (mainArgThreads args) - (async (restore (withNewServer chan senv go))) - restore (mapM_ wait as) `E.catch` \e -> do - -- Be patient, because if you ^C again, you might - -- leave some zombie GHCi processes around! - logAll "Shutting down GHCi sessions (please be patient)..." - -- Start cleanup on all threads concurrently. - mapM_ (async . cancel) as - -- Wait for the threads to finish cleaning up. NB: - -- do NOT wait on the cancellation asynchronous actions; - -- these complete when the message is *delivered*, not - -- when cleanup is done. - rs <- mapM waitCatch as - -- Take a look at the returned exit codes, and figure out - -- if something errored in an unexpected way. This - -- could mean there's a zombie. - forM_ rs $ \r -> case r of - Left err - | Just ThreadKilled <- fromException err - -> return () - | otherwise - -> logAll ("Unexpected failure on GHCi exit: " ++ show e) - _ -> return () - -- Propagate the exception - throwIO (e :: SomeException) + -- Start as many threads as requested by -j to spawn + -- GHCi servers and start running tests off of the + -- run queue. + replicateConcurrently_ (mainArgThreads args) (withNewServer chan senv go) unexpected_fails <- takeMVar unexpected_fails_var unexpected_passes <- takeMVar unexpected_passes_var - if not (null (unexpected_fails ++ unexpected_passes)) - then do - unless (null unexpected_passes) . logAll $ - "UNEXPECTED OK: " ++ intercalate " " unexpected_passes - unless (null unexpected_fails) . logAll $ - "UNEXPECTED FAIL: " ++ intercalate " " unexpected_fails - exitFailure - else logAll "OK" + skipped <- takeMVar skipped_var + -- print skipped + logAll $ "SKIPPED " ++ show (length skipped) ++ " tests" + + -- print failed or ook + if null (unexpected_fails ++ unexpected_passes) + then logAll "OK" + else do + unless (null unexpected_passes) . logAll $ + "UNEXPECTED OK: " ++ intercalate " " unexpected_passes + unless (null unexpected_fails) . logAll $ + "UNEXPECTED FAIL: " ++ intercalate " " unexpected_fails + exitFailure + findTests :: IO [FilePath] findTests = getDirectoryContentsRecursive "." @@ -308,20 +282,3 @@ t <- Clock.getTime Clock.Monotonic let ns = realToFrac $ Clock.toNanoSecs t return $ ns / 10 ^ (9 :: Int) - -------------------------------------------------------------------------------- --- compat -------------------------------------------------------------------------------- - -#if !MIN_VERSION_process(1,2,0) -callProcess :: FilePath -> [String] -> IO () -callProcess cmd args = do - exit_code <- bracket (createProcess (proc cmd args)) cleanupProcess - $ \(_, _, _, ph) -> waitForProcess ph - case exit_code of - ExitSuccess -> return () - ExitFailure r -> fail $ "processFailedException " ++ show (cmd, args, r) - where - cleanupProcess (_, _, _, ph) = terminateProcess ph - -#endif diff --git a/cabal/cabal-testsuite/src/Test/Cabal/DecodeShowBuildInfo.hs b/cabal/cabal-testsuite/src/Test/Cabal/DecodeShowBuildInfo.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/src/Test/Cabal/DecodeShowBuildInfo.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleContexts #-} +module Test.Cabal.DecodeShowBuildInfo where + +import Test.Cabal.Prelude +import Test.Cabal.Plan +import Distribution.Compat.Stack +import Distribution.Text (display) +import Distribution.Types.ComponentName +import Distribution.Types.LibraryName +import Distribution.Types.UnqualComponentName +import Distribution.Package +import Distribution.Pretty (prettyShow) +import Control.Monad.Trans.Reader +import Data.Aeson +import GHC.Generics +import System.Exit + +-- | Execute 'cabal build --enable-build-info'. +-- +-- Results can be read via 'withPlan', 'buildInfoFile' and 'decodeBuildInfoFile'. +runShowBuildInfo :: [String] -> TestM () +runShowBuildInfo args = cabal "build" ("--enable-build-info":args) + +-- | Read 'build-info.json' for a given package and component +-- from disk and record the content. Helpful for defining test-cases +-- where the build info matters. +recordBuildInfo :: PackageName -> ComponentName -> TestM () +recordBuildInfo pkgName cname = do + Just plan <- fmap testPlan ask + let fp = buildInfoFile plan pkgName cname + recordMode RecordAll $ do + recordHeader ["show-build-info", prettyShow pkgName, prettyShow cname] + buildInfo <- liftIO $ readFile fp + recordLog $ Result ExitSuccess "build --enable-build-info" buildInfo + +-- | Decode the given filepath into a 'BuildInfo'. +-- +-- If the filepath doesn't exist or its contents are not a valid 'BuildInfo' +-- json file, then an error is raised. +decodeBuildInfoFile :: FilePath -> TestM BuildInfo +decodeBuildInfoFile fp = do + shouldExist fp + res <- liftIO $ eitherDecodeFileStrict fp + case res of + Left err -> fail $ "Could not parse show-build-info file: " ++ err + Right buildInfos -> return buildInfos + +data BuildInfo = BuildInfo + { cabalLibVersion :: String + , compiler :: CompilerInfo + , components :: [ComponentInfo] + } deriving (Generic, Show) + +data CompilerInfo = CompilerInfo + { flavour :: String + , compilerId :: String + , path :: String + } deriving (Generic, Show) + +data ComponentInfo = ComponentInfo + { componentType :: String + , componentName :: String + , componentUnitId :: String + , componentCompilerArgs :: [String] + , componentModules :: [String] + , componentSrcFiles :: [FilePath] + , componentHsSrcDirs :: [FilePath] + , componentSrcDir :: FilePath + } deriving (Generic, Show) + +instance ToJSON BuildInfo where + toEncoding = genericToEncoding defaultOptions +instance FromJSON BuildInfo where + parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '-' } + +instance ToJSON CompilerInfo where + toEncoding = genericToEncoding defaultOptions +instance FromJSON CompilerInfo where + parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '-' } + +instance ToJSON ComponentInfo where + toEncoding = genericToEncoding defaultOptions +instance FromJSON ComponentInfo where + parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = drop 10 . camelTo2 '-' } + +-- ----------------------------------------------------------- +-- Assertion Helpers to define succinct test cases +-- ----------------------------------------------------------- + +data ComponentAssertion = ComponentAssertion + { unitIdPred :: (String -> Bool) + -- ^ Predicate to apply to a component's unit id. + , compilerArgsPred :: ([String] -> Bool) + -- ^ Predicate the compilation arguments must satisfy. + , modules :: [String] + -- ^ Which modules should a component contain. + , sourceFiles :: [FilePath] + -- ^ Which source files are part of a component. + , sourceDirs :: [FilePath] + -- ^ Expected source directories for a component. + , compType :: String + -- ^ Type of the component, usually one of 'bench', 'exe', 'test', 'lib', 'flib' + } + +defCompAssertion :: ComponentAssertion +defCompAssertion = ComponentAssertion + { unitIdPred = not . null + , compilerArgsPred = not . null + , modules = [] + , sourceFiles = [] + , sourceDirs = [] + , compType = "" + } + +-- | Assert common build information, such as compiler location, compiler version +-- and cabal library version. +assertCommonBuildInfo :: WithCallStack (BuildInfo -> TestM ()) +assertCommonBuildInfo buildInfo = do + assertEqual "Cabal Version" (display cabalVersionLibrary) (cabalLibVersion buildInfo) + assertEqual "Compiler flavour" "ghc" (flavour $ compiler buildInfo) + assertBool "Compiler id" (and $ zipWith (==) "ghc" (compilerId $ compiler buildInfo)) + assertBool "Compiler path non-empty" (not . null . path $ compiler buildInfo) + +-- | Pure assertion helper. Check whether the given 'ComponentInfo' satisfy +-- the 'ComponentAssertion'. +assertComponentPure :: WithCallStack (ComponentInfo -> ComponentAssertion -> TestM ()) +assertComponentPure component ComponentAssertion{..} = do + assertEqual "Component type" compType (componentType component) + assertBool "Component Unit Id" (unitIdPred $ componentUnitId component) + assertBool "Component compiler args" (compilerArgsPred $ componentCompilerArgs component) + assertEqual "Component modules" modules (componentModules component) + assertEqual "Component source files" sourceFiles (componentSrcFiles component) + assertEqual "Component source directories" sourceDirs (componentHsSrcDirs component) + +-- | @'assertComponent' pkgName cname assertion@ +-- +-- Assert that a component identified by 'pkgName' and 'cname', generated +-- a 'build-info.json' and its contents satisfy the assertions specified in 'assertion'. +-- +-- This assertion must be wrapped in 'withPlan'. +assertComponent :: WithCallStack (PackageName -> ComponentName -> ComponentAssertion -> TestM ()) +assertComponent pkgName cname assert = do + Just plan <- fmap testPlan ask + let fp = buildInfoFile plan pkgName cname + buildInfo <- decodeBuildInfoFile fp + assertCommonBuildInfo buildInfo + + let component = findComponentInfo buildInfo + let assertWithCompType = assert { compType = compTypeStr cname } + assertComponentPure component assertWithCompType + where + compTypeStr :: ComponentName -> String + compTypeStr (CLibName _) = "lib" + compTypeStr (CFLibName _) = "flib" + compTypeStr (CExeName _) = "exe" + compTypeStr (CTestName _) = "test" + compTypeStr (CBenchName _) = "bench" + + findComponentInfo :: BuildInfo -> ComponentInfo + findComponentInfo buildInfo = + case filter (\c -> prettyShow cname == componentName c) (components buildInfo) of + [x] -> x + [] -> error $ "findComponentInfo: component " ++ prettyShow cname ++ " does not" + ++ " exist in build info-file" + _ -> error $ "findComponentInfo: found multiple copies of component " ++ prettyShow cname + ++ " in build info plan" + +-- | Helper function to create an executable component name. +exe :: String -> ComponentName +exe = CExeName . mkUnqualComponentName + +-- | Helper function to create a named sub-library component name. +lib :: String -> ComponentName +lib = CLibName . LSubLibName . mkUnqualComponentName + +-- | Helper function to create an test component name. +test :: String -> ComponentName +test = CTestName . mkUnqualComponentName + +-- | Helper function to create an benchmark component name. +bench :: String -> ComponentName +bench = CBenchName . mkUnqualComponentName + +-- | Helper function to create a main library component name. +mainLib :: ComponentName +mainLib = CLibName LMainLibName diff --git a/cabal/cabal-testsuite/src/Test/Cabal/Monad.hs b/cabal/cabal-testsuite/src/Test/Cabal/Monad.hs --- a/cabal/cabal-testsuite/src/Test/Cabal/Monad.hs +++ b/cabal/cabal-testsuite/src/Test/Cabal/Monad.hs @@ -6,6 +6,7 @@ setupAndCabalTest, setupTest, cabalTest, + cabalTest', -- * The monad TestM, runTestM, @@ -17,6 +18,7 @@ gitProgram, cabalProgram, diffProgram, + python3Program, -- * The test environment TestEnv(..), getTestEnv, @@ -39,22 +41,22 @@ skip, skipIf, skipUnless, - skipExitCode, -- * Known broken tests expectedBroken, unexpectedSuccess, - expectedBrokenExitCode, - unexpectedSuccessExitCode, -- whenHasSharedLibraries, -- * Arguments (TODO: move me) CommonArgs(..), renderCommonArgs, commonArgParser, + -- * Version Constants + cabalVersionLibrary, ) where import Test.Cabal.Script import Test.Cabal.Plan import Test.Cabal.OutputNormalizer +import Test.Cabal.TestCode import Distribution.Simple.Compiler ( PackageDBStack, PackageDB(..), compilerFlavor @@ -64,9 +66,11 @@ import Distribution.Simple.Program import Distribution.Simple.Configure ( configCompilerEx ) +import qualified Distribution.Simple.Utils as U (cabalVersion) import Distribution.Text import Distribution.Verbosity +import Distribution.Version import Data.Monoid ((<>), mempty) import qualified Control.Exception as E @@ -146,55 +150,44 @@ <*> argument str ( metavar "FILE") <*> commonArgParser -skip :: TestM () -skip = liftIO $ do - putStrLn "SKIP" - exitWith (ExitFailure skipExitCode) +skip :: String -> TestM () +skip reason = liftIO $ do + putStrLn ("SKIP " ++ reason) + E.throwIO (TestCodeSkip reason) -skipIf :: Bool -> TestM () -skipIf b = when b skip +skipIf :: String -> Bool -> TestM () +skipIf reason b = when b (skip reason) -skipUnless :: Bool -> TestM () -skipUnless b = unless b skip +skipUnless :: String -> Bool -> TestM () +skipUnless reason b = unless b (skip reason) expectedBroken :: TestM () expectedBroken = liftIO $ do putStrLn "EXPECTED FAIL" - exitWith (ExitFailure expectedBrokenExitCode) + E.throwIO TestCodeKnownFail unexpectedSuccess :: TestM () unexpectedSuccess = liftIO $ do putStrLn "UNEXPECTED OK" - exitWith (ExitFailure unexpectedSuccessExitCode) - -skipExitCode :: Int -skipExitCode = 64 - -expectedBrokenExitCode :: Int -expectedBrokenExitCode = 65 - -unexpectedSuccessExitCode :: Int -unexpectedSuccessExitCode = 66 + E.throwIO TestCodeUnexpectedOk -catchSkip :: IO a -> IO a -> IO a -catchSkip m r = m `E.catch` \e -> - case e of - ExitFailure c | c == skipExitCode - -> r - _ -> E.throwIO e +trySkip :: IO a -> IO (Either String a) +trySkip m = fmap Right m `E.catch` \e -> case e of + TestCodeSkip msg -> return (Left msg) + _ -> E.throwIO e setupAndCabalTest :: TestM () -> IO () setupAndCabalTest m = do - r1 <- (setupTest m >> return False) `catchSkip` return True - r2 <- (cabalTest' "cabal" m >> return False) `catchSkip` return True - when (r1 && r2) $ do - putStrLn "SKIP" - exitWith (ExitFailure skipExitCode) + r1 <- trySkip (setupTest m) + r2 <- trySkip (cabalTest' "cabal" m) + case (r1, r2) of + (Left msg1, Left msg2) -> E.throwIO (TestCodeSkip (msg1 ++ "; " ++ msg2)) + _ -> return () setupTest :: TestM () -> IO () setupTest m = runTestM "" $ do env <- getTestEnv - skipIf (testSkipSetupTests env) + skipIf "setup test" (testSkipSetupTests env) m cabalTest :: TestM () -> IO () @@ -202,7 +195,7 @@ cabalTest' :: String -> TestM () -> IO () cabalTest' mode m = runTestM mode $ do - skipUnless =<< isAvailableProgram cabalProgram + skipUnless "no cabal-install" =<< isAvailableProgram cabalProgram withReaderT (\nenv -> nenv { testCabalInstallAsSetup = True }) m type TestM = ReaderT TestEnv IO @@ -223,6 +216,9 @@ diffProgram :: Program diffProgram = simpleProgram "diff" +python3Program :: Program +python3Program = simpleProgram "python3" + -- | Run a test in the test monad according to program's arguments. runTestM :: String -> TestM a -> IO a runTestM mode m = withSystemTempDirectory "cabal-testsuite" $ \tmp_dir -> do @@ -237,7 +233,7 @@ -- Add test suite specific programs let program_db0 = addKnownPrograms - ([gitProgram, hackageRepoToolProgram, cabalProgram, diffProgram] ++ builtinPrograms) + ([gitProgram, hackageRepoToolProgram, cabalProgram, diffProgram, python3Program] ++ builtinPrograms) (runnerProgramDb senv) -- Reconfigure according to user flags let cargs = testCommonArgs args @@ -411,6 +407,7 @@ list_out <- liftIO $ readProcess (programPath ghc_pkg_program) ["list", "--global", "--simple-output"] "" tmpDir <- liftIO $ getTemporaryDirectory + return NormalizerEnv { normalizerRoot = addTrailingPathSeparator (testSourceDir env), @@ -423,8 +420,14 @@ normalizerKnownPackages = mapMaybe simpleParse (words list_out), normalizerPlatform - = testPlatform env + = testPlatform env, + normalizerCabalVersion + = cabalVersionLibrary } + where + +cabalVersionLibrary :: Version +cabalVersionLibrary = U.cabalVersion requireProgramM :: Program -> TestM ConfiguredProgram requireProgramM program = do diff --git a/cabal/cabal-testsuite/src/Test/Cabal/OutputNormalizer.hs b/cabal/cabal-testsuite/src/Test/Cabal/OutputNormalizer.hs --- a/cabal/cabal-testsuite/src/Test/Cabal/OutputNormalizer.hs +++ b/cabal/cabal-testsuite/src/Test/Cabal/OutputNormalizer.hs @@ -11,9 +11,11 @@ import Distribution.Package import Distribution.System -import qualified Data.Foldable as F +import Text.Regex.Base +import Text.Regex.TDFA +import Data.Array ((!)) -import Text.Regex +import qualified Data.Foldable as F normalizeOutput :: NormalizerEnv -> String -> String normalizeOutput nenv = @@ -27,10 +29,13 @@ . resub "Installing (.+) in .+" "Installing \\1 in " -- Things that look like libraries . resub "libHS[A-Za-z0-9.-]+\\.(so|dll|a|dynlib)" "" + -- look for PackageHash directories + . resub "/(([A-Za-z0-9_]+)(-[A-Za-z0-9\\._]+)*)-[0-9a-f]{4,64}/" + "/-/" -- This is dumb but I don't feel like pulling in another dep for -- string search-replace. Make sure we do this before backslash -- normalization! - . resub (posixRegexEscape (normalizerGblTmpDir nenv) ++ "[a-z0-9.-]+") "" -- note, after TMPDIR + . resub (posixRegexEscape (normalizerGblTmpDir nenv) ++ "[a-z0-9\\.-]+") "" -- note, after TMPDIR . resub (posixRegexEscape (normalizerRoot nenv)) "/" . resub (posixRegexEscape (normalizerTmpDir nenv)) "/" . appEndo (F.fold (map (Endo . packageIdRegex) (normalizerKnownPackages nenv))) @@ -39,8 +44,12 @@ -- Apply this before packageIdRegex, otherwise this regex doesn't match. . resub "[0-9]+(\\.[0-9]+)*/installed-[A-Za-z0-9.+]+" "/installed-" + -- incoming directories in the store + . resub "/incoming/new-[0-9]+" + "/incoming/new-" -- Normalize architecture . resub (posixRegexEscape (display (normalizerPlatform nenv))) "" + . normalizeBuildInfoJson -- Some GHC versions are chattier than others . resub "^ignoring \\(possibly broken\\) abi-depends field for packages" "" -- Normalize the current GHC version. Apply this BEFORE packageIdRegex, @@ -59,6 +68,32 @@ resub (posixRegexEscape (display pid) ++ "(-[A-Za-z0-9.-]+)?") (prettyShow (packageName pid) ++ "-") + -- 'build-info.json' contains a plethora of host system specific information. + -- + -- This must happen before the root-dir normalisation. + normalizeBuildInfoJson = + -- Remove ghc path from show-build-info output + resub ("\"path\":\"[^\"]*\"}") + "\"path\":\"\"}" + -- Remove cabal version output from show-build-info output + . resub ("{\"cabal-version\":\"" ++ posixRegexEscape (display (normalizerCabalVersion nenv)) ++ "\"") + "{\"cabal-version\":\"\"" + . resub ("{\"cabal-lib-version\":\"" ++ posixRegexEscape (display (normalizerCabalVersion nenv)) ++ "\"") + "{\"cabal-lib-version\":\"\"" + -- Remove the package id for stuff such as: + -- > "-package-id","base-4.14.0.0-" + -- and replace it with: + -- > "-package-id","" + -- + -- Otherwise, output can not be properly normalized as on MacOs we remove + -- vowels from packages to make the names shorter. + -- E.g. "another-framework-0.8.1.1" -> "nthr-frmwrk-0.8.1.1" + -- + -- This makes it impossible to have a stable package id, thus remove it completely. + -- Check manually in your test-cases if the package-id needs to be verified. + . resub ("\"-package-id\",\"([^\"]*)\"") + "\"-package-id\",\"\"" + data NormalizerEnv = NormalizerEnv { normalizerRoot :: FilePath , normalizerTmpDir :: FilePath @@ -66,6 +101,7 @@ , normalizerGhcVersion :: Version , normalizerKnownPackages :: [PackageId] , normalizerPlatform :: Platform + , normalizerCabalVersion :: Version } posixSpecialChars :: [Char] @@ -74,6 +110,41 @@ posixRegexEscape :: String -> String posixRegexEscape = concatMap (\c -> if c `elem` posixSpecialChars then ['\\', c] else [c]) +-- From regex-compat-tdfa by Christopher Kuklewicz and shelarcy, BSD-3-Clause +------------------------- + resub :: String {- search -} -> String {- replace -} -> String {- input -} -> String -resub search replace s = - subRegex (mkRegex search) s replace +resub _ _ "" = "" +resub regexp repl inp = + let compile _i str [] = \ _m -> (str ++) + compile i str (("\\", (off, len)) : rest) = + let i' = off + len + pre = take (off - i) str + str' = drop (i' - i) str + in if null str' then \ _m -> (pre ++) . ('\\' :) + else \ m -> (pre ++) . ('\\' :) . compile i' str' rest m + compile i str ((xstr, (off, len)) : rest) = + let i' = off + len + pre = take (off - i) str + str' = drop (i' - i) str + x = read xstr + in if null str' then \ m -> (pre++) . (fst (m ! x) ++) + else \ m -> (pre ++) . (fst (m ! x) ++) . compile i' str' rest m + compiled :: MatchText String -> String -> String + compiled = compile 0 repl findrefs where + -- bre matches a backslash then capture either a backslash or some digits + bre = mkRegex "\\\\(\\\\|[0-9]+)" + findrefs = map (\m -> (fst (m ! 1), snd (m ! 0))) (matchAllText bre repl) + go _i str [] = str + go i str (m : ms) = + let (_, (off, len)) = m ! 0 + i' = off + len + pre = take (off - i) str + str' = drop (i' - i) str + in if null str' then pre ++ compiled m "" + else pre ++ compiled m (go i' str' ms) + in go 0 inp (matchAllText (mkRegex regexp) inp) + +mkRegex :: String -> Regex +mkRegex s = makeRegexOpts opt defaultExecOpt s + where opt = defaultCompOpt { newSyntax = True, multiline = True } diff --git a/cabal/cabal-testsuite/src/Test/Cabal/Plan.hs b/cabal/cabal-testsuite/src/Test/Cabal/Plan.hs --- a/cabal/cabal-testsuite/src/Test/Cabal/Plan.hs +++ b/cabal/cabal-testsuite/src/Test/Cabal/Plan.hs @@ -3,7 +3,9 @@ -- | Utilities for understanding @plan.json@. module Test.Cabal.Plan ( Plan, + DistDirOrBinFile(..), planDistDir, + buildInfoFile, ) where import Distribution.Parsec (simpleParsec) @@ -20,15 +22,21 @@ data InstallItem = APreExisting - | AConfiguredGlobal + | AConfiguredGlobal ConfiguredGlobal | AConfiguredInplace ConfiguredInplace -- local or inplace package data ConfiguredInplace = ConfiguredInplace { configuredInplaceDistDir :: FilePath + , configuredInplaceBuildInfo :: Maybe FilePath , configuredInplacePackageName :: PackageName , configuredInplaceComponentName :: Maybe ComponentName } +data ConfiguredGlobal = ConfiguredGlobal + { configuredGlobalBinFile :: Maybe FilePath + , configuredGlobalPackageName :: PackageName + , configuredGlobalComponentName :: Maybe ComponentName } + instance FromJSON Plan where parseJSON (Object v) = fmap Plan (v .: "install-plan") parseJSON invalid = typeMismatch "Plan" invalid @@ -41,7 +49,7 @@ "configured" -> do s <- v .: "style" case s :: String of - "global" -> return AConfiguredGlobal + "global" -> AConfiguredGlobal `fmap` parseJSON obj "inplace" -> AConfiguredInplace `fmap` parseJSON obj "local" -> AConfiguredInplace `fmap` parseJSON obj _ -> fail $ "unrecognized value of 'style' field: " ++ s @@ -51,11 +59,20 @@ instance FromJSON ConfiguredInplace where parseJSON (Object v) = do dist_dir <- v .: "dist-dir" + build_info <- v .:? "build-info" pkg_name <- v .: "pkg-name" component_name <- v .:? "component-name" - return (ConfiguredInplace dist_dir pkg_name component_name) + return (ConfiguredInplace dist_dir build_info pkg_name component_name) parseJSON invalid = typeMismatch "ConfiguredInplace" invalid +instance FromJSON ConfiguredGlobal where + parseJSON (Object v) = do + bin_file <- v .:? "bin-file" + pkg_name <- v .: "pkg-name" + component_name <- v .:? "component-name" + return (ConfiguredGlobal bin_file pkg_name component_name) + parseJSON invalid = typeMismatch "ConfiguredGlobal" invalid + instance FromJSON PackageName where parseJSON (String t) = return (mkPackageName (Text.unpack t)) parseJSON invalid = typeMismatch "PackageName" invalid @@ -68,21 +85,52 @@ where s = Text.unpack t parseJSON invalid = typeMismatch "ComponentName" invalid -planDistDir :: Plan -> PackageName -> ComponentName -> FilePath +data DistDirOrBinFile = DistDir FilePath | BinFile FilePath + +planDistDir :: Plan -> PackageName -> ComponentName -> DistDirOrBinFile planDistDir plan pkg_name cname = case concatMap p (planInstallPlan plan) of [x] -> x [] -> error $ "planDistDir: component " ++ prettyShow cname ++ " of package " ++ prettyShow pkg_name ++ " either does not" - ++ " exist in the install plan or does not have a dist-dir" + ++ " exist in the install plan or does not have a dist-dir nor bin-file" _ -> error $ "planDistDir: found multiple copies of component " ++ prettyShow cname ++ " of package " ++ prettyShow pkg_name ++ " in install plan" where p APreExisting = [] - p AConfiguredGlobal = [] + p (AConfiguredGlobal conf) = do + guard (configuredGlobalPackageName conf == pkg_name) + guard $ case configuredGlobalComponentName conf of + Nothing -> True + Just cname' -> cname == cname' + case configuredGlobalBinFile conf of + Nothing -> [] + Just bin_file -> return $ BinFile bin_file p (AConfiguredInplace conf) = do guard (configuredInplacePackageName conf == pkg_name) guard $ case configuredInplaceComponentName conf of Nothing -> True Just cname' -> cname == cname' - return (configuredInplaceDistDir conf) + return $ DistDir $ configuredInplaceDistDir conf + +buildInfoFile :: Plan -> PackageName -> ComponentName -> FilePath +buildInfoFile plan pkg_name cname = + case concatMap p (planInstallPlan plan) of + [Just x] -> x + [Nothing] -> error $ "buildInfoFile: component " ++ prettyShow cname + ++ " of package " ++ prettyShow pkg_name ++ " does not" + ++ " have a build info-file" + [] -> error $ "buildInfoFile: component " ++ prettyShow cname + ++ " of package " ++ prettyShow pkg_name ++ " either does not" + ++ " exist in the install plan or build info-file" + _ -> error $ "buildInfoFile: found multiple copies of component " ++ prettyShow cname + ++ " of package " ++ prettyShow pkg_name ++ " in install plan" + where + p APreExisting = [] + p (AConfiguredGlobal _) = [] + p (AConfiguredInplace conf) = do + guard (configuredInplacePackageName conf == pkg_name) + guard $ case configuredInplaceComponentName conf of + Nothing -> True + Just cname' -> cname == cname' + return $ configuredInplaceBuildInfo conf diff --git a/cabal/cabal-testsuite/src/Test/Cabal/Prelude.hs b/cabal/cabal-testsuite/src/Test/Cabal/Prelude.hs --- a/cabal/cabal-testsuite/src/Test/Cabal/Prelude.hs +++ b/cabal/cabal-testsuite/src/Test/Cabal/Prelude.hs @@ -24,6 +24,7 @@ import Distribution.Compat.Time (calibrateMtimeChangeDelay) import Distribution.Simple.Compiler (PackageDBStack, PackageDB(..)) +import Distribution.Simple.PackageDescription (readGenericPackageDescription) import Distribution.Simple.Program.Types import Distribution.Simple.Program.Db import Distribution.Simple.Program @@ -34,10 +35,10 @@ ( getPersistBuildConfig ) import Distribution.Version import Distribution.Package +import Distribution.Parsec (eitherParsec) import Distribution.Types.UnqualComponentName import Distribution.Types.LocalBuildInfo import Distribution.PackageDescription -import Distribution.PackageDescription.Parsec import Distribution.Verbosity (normal) import Distribution.Compat.Stack @@ -50,6 +51,8 @@ import Control.Monad (unless, when, void, forM_, liftM2, liftM4) import Control.Monad.Trans.Reader (withReaderT, runReaderT) import Control.Monad.IO.Class (MonadIO (..)) +import qualified Crypto.Hash.SHA256 as SHA256 +import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Char8 as C import Data.List (isInfixOf, stripPrefix, isPrefixOf, intercalate) import Data.List.NonEmpty (NonEmpty (..)) @@ -59,10 +62,13 @@ import System.FilePath ((), takeExtensions, takeDrive, takeDirectory, normalise, splitPath, joinPath, splitFileName, (<.>), dropTrailingPathSeparator) import Control.Concurrent (threadDelay) import qualified Data.Char as Char -import System.Directory (getTemporaryDirectory, getCurrentDirectory, copyFile, removeFile, copyFile, doesFileExist, createDirectoryIfMissing, getDirectoryContents) +import System.Directory (getTemporaryDirectory, getCurrentDirectory, canonicalizePath, copyFile, copyFile, doesDirectoryExist, doesFileExist, createDirectoryIfMissing, getDirectoryContents, listDirectory) +import Control.Retry (exponentialBackoff, limitRetriesByCumulativeDelay) +import Network.Wait (waitTcpVerbose) #ifndef mingw32_HOST_OS import Control.Monad.Catch ( bracket_ ) +import System.Directory ( removeFile ) import System.Posix.Files ( createSymbolicLink ) import System.Posix.Resource #endif @@ -274,13 +280,27 @@ -- overwritable when (cmd == "v1-freeze") requireHasSourceCopy let extra_args - | cmd `elem` ["v1-update", "outdated", "user-config", "man", "v1-freeze", "check"] + | cmd `elem` + [ "v1-update" + , "outdated" + , "user-config" + , "man" + , "v1-freeze" + , "check" + , "get", "unpack" + , "info" + , "init" + ] = [ ] -- new-build commands are affected by testCabalProjectFile | cmd == "v2-sdist" = [ "--project-file", testCabalProjectFile env ] + | cmd == "v2-clean" + = [ "--builddir", testDistDir env + , "--project-file", testCabalProjectFile env ] + | "v2-" `isPrefixOf` cmd = [ "--builddir", testDistDir env , "--project-file", testCabalProjectFile env @@ -333,11 +353,14 @@ -> [String] -> TestM Result runPlanExe' pkg_name cname args = do Just plan <- testPlan `fmap` getTestEnv - let dist_dir = planDistDir plan (mkPackageName pkg_name) - (CExeName (mkUnqualComponentName cname)) + let distDirOrBinFile = planDistDir plan (mkPackageName pkg_name) + (CExeName (mkUnqualComponentName cname)) + exePath = case distDirOrBinFile of + DistDir dist_dir -> dist_dir "build" cname cname + BinFile bin_file -> bin_file defaultRecordMode RecordAll $ do recordHeader [pkg_name, cname] - runM (dist_dir "build" cname cname) args Nothing + runM exePath args Nothing ------------------------------------------------------------------------ -- * Running ghc-pkg @@ -492,60 +515,136 @@ -- external repository corresponding to all of these packages withRepo :: FilePath -> TestM a -> TestM a withRepo repo_dir m = do - env <- getTestEnv + -- https://github.com/haskell/cabal/issues/7065 + -- you don't simply put a windows path into URL... + skipIfWindows - -- Check if hackage-repo-tool is available, and skip if not - skipUnless =<< isAvailableProgram hackageRepoToolProgram + env <- getTestEnv - -- 1. Generate keys - hackageRepoTool "create-keys" ["--keys", testKeysDir env] - -- 2. Initialize repo directory - let package_dir = testRepoDir env "package" - liftIO $ createDirectoryIfMissing True (testRepoDir env "index") + -- 1. Initialize repo directory + let package_dir = testRepoDir env liftIO $ createDirectoryIfMissing True package_dir - -- 3. Create tarballs + + -- 2. Create tarballs pkgs <- liftIO $ getDirectoryContents (testCurrentDir env repo_dir) forM_ pkgs $ \pkg -> do + let srcPath = testCurrentDir env repo_dir pkg + let destPath = package_dir pkg + isPreferredVersionsFile <- liftIO $ + -- validate this is the "magic" 'preferred-versions' file + -- and perform a sanity-check whether this is actually a file + -- and not a package that happens to have the same name. + if pkg == "preferred-versions" + then doesFileExist srcPath + else return False case pkg of '.':_ -> return () - _ -> testCurrentDir env repo_dir pkg - `archiveTo` - package_dir pkg <.> "tar.gz" - -- 4. Initialize repository - hackageRepoTool "bootstrap" ["--keys", testKeysDir env, "--repo", testRepoDir env] - -- 5. Wire it up in .cabal/config + _ + | isPreferredVersionsFile -> + liftIO $ copyFile srcPath destPath + | otherwise -> archiveTo + srcPath + (destPath <.> "tar.gz") + + -- 3. Wire it up in .cabal/config -- TODO: libify this let package_cache = testCabalDir env "packages" liftIO $ appendFile (testUserCabalConfigFile env) $ unlines [ "repository test-local-repo" , " url: " ++ repoUri env - , " secure: True" - -- TODO: Hypothetically, we could stick in the - -- correct key here - , " root-keys: " - , " key-threshold: 0" , "remote-repo-cache: " ++ package_cache ] - -- 6. Create local directories (TODO: this is a bug #4136, once you - -- fix that this can be removed) - liftIO $ createDirectoryIfMissing True (package_cache "test-local-repo") - -- 7. Update our local index - cabal "v1-update" [] - -- 8. Profit + liftIO $ print $ testUserCabalConfigFile env + liftIO $ print =<< readFile (testUserCabalConfigFile env) + + -- 4. Update our local index + -- Note: this doesn't do anything for file+noindex repositories. + cabal "v2-update" ["-z"] + + -- 5. Profit withReaderT (\env' -> env' { testHaveRepo = True }) m -- TODO: Arguably should undo everything when we're done... where - -- Work around issue #5218 (incorrect conversions between Windows paths and - -- file URIs) by using a relative path on Windows. - repoUri env = - if buildOS == Windows - then let relPath = definitelyMakeRelative (testCurrentDir env) - (testRepoDir env) - convertSeparators = intercalate "/" - . map dropTrailingPathSeparator - . splitPath - in "file:" ++ convertSeparators relPath - else "file:" ++ testRepoDir env + repoUri env ="file+noindex://" ++ testRepoDir env +-- | Given a directory (relative to the 'testCurrentDir') containing +-- a series of directories representing packages, generate an +-- remote repository corresponding to all of these packages +withRemoteRepo :: FilePath -> TestM a -> TestM a +withRemoteRepo repoDir m = do + -- https://github.com/haskell/cabal/issues/7065 + -- you don't simply put a windows path into URL... + skipIfWindows + + -- we rely on the presence of python3 for a simple http server + skipUnless "no python3" =<< isAvailableProgram python3Program + -- we rely on hackage-repo-tool to set up the secure repository + skipUnless "no hackage-repo-tool" =<< isAvailableProgram hackageRepoToolProgram + + env <- getTestEnv + + let workDir = testRepoDir env + + -- 1. Initialize repo and repo_keys directory + let keysDir = workDir "keys" + let packageDir = workDir "package" + + liftIO $ createDirectoryIfMissing True packageDir + liftIO $ createDirectoryIfMissing True keysDir + + -- 2. Create tarballs + entries <- liftIO $ getDirectoryContents (testCurrentDir env repoDir) + forM_ entries $ \entry -> do + let srcPath = testCurrentDir env repoDir entry + let destPath = packageDir entry + isPreferredVersionsFile <- liftIO $ + -- validate this is the "magic" 'preferred-versions' file + -- and perform a sanity-check whether this is actually a file + -- and not a package that happens to have the same name. + if entry == "preferred-versions" + then doesFileExist srcPath + else return False + case entry of + '.' : _ -> return () + _ + | isPreferredVersionsFile -> + liftIO $ copyFile srcPath destPath + | otherwise -> + archiveTo srcPath (destPath <.> "tar.gz") + + -- 3. Create keys and bootstrap repository + hackageRepoTool "create-keys" $ ["--keys", keysDir ] + hackageRepoTool "bootstrap" $ ["--keys", keysDir, "--repo", workDir] + + -- 4. Wire it up in .cabal/config + let package_cache = testCabalDir env "packages" + -- In the following we launch a python http server to serve the remote + -- repository. When the http server is ready we proceed with the tests. + -- NOTE 1: it's important that both the http server and cabal use the + -- same hostname ("localhost"), otherwise there could be a mismatch + -- (depending on the details of the host networking settings). + -- NOTE 2: here we use a fixed port (8000). This can cause problems in + -- case multiple tests are running concurrently or other another + -- process on the developer machine is using the same port. + liftIO $ do + appendFile (testUserCabalConfigFile env) $ + unlines [ "repository repository.localhost" + , " url: http://localhost:8000/" + , " secure: True" + , " root-keys:" + , " key-threshold: 0" + , "remote-repo-cache: " ++ package_cache ] + putStrLn $ testUserCabalConfigFile env + putStrLn =<< readFile (testUserCabalConfigFile env) + + withAsync + (flip runReaderT env $ python3 ["-m", "http.server", "-d", workDir, "--bind", "localhost", "8000"]) + (\_ -> do + -- wait for the python webserver to come up with a exponential + -- backoff starting from 50ms, up to a maximum wait of 60s + _ <- waitTcpVerbose putStrLn (limitRetriesByCumulativeDelay 60000000 $ exponentialBackoff 50000) "localhost" "8000" + runReaderT m (env { testHaveRepo = True })) + + ------------------------------------------------------------------------ -- * Subprocess run results @@ -655,6 +754,16 @@ withFrozenCallStack $ liftIO $ doesFileExist path >>= assertBool (path ++ " should exist") . not +shouldDirectoryExist :: MonadIO m => WithCallStack (FilePath -> m ()) +shouldDirectoryExist path = + withFrozenCallStack $ + liftIO $ doesDirectoryExist path >>= assertBool (path ++ " should exist") + +shouldDirectoryNotExist :: MonadIO m => WithCallStack (FilePath -> m ()) +shouldDirectoryNotExist path = + withFrozenCallStack $ + liftIO $ doesDirectoryExist path >>= assertBool (path ++ " should exist") . not + assertRegex :: MonadIO m => String -> String -> Result -> m () assertRegex msg regex r = withFrozenCallStack $ @@ -724,12 +833,20 @@ concatOutput :: String -> String concatOutput = unwords . lines . filter ((/=) '\r') +-- | The directory where script build artifacts are expected to be cached +getScriptCacheDirectory :: FilePath -> TestM FilePath +getScriptCacheDirectory script = do + cabalDir <- testCabalDir `fmap` getTestEnv + hashinput <- liftIO $ canonicalizePath script + let hash = C.unpack . Base16.encode . SHA256.hash . C.pack $ hashinput + return $ cabalDir "script-builds" hash + ------------------------------------------------------------------------ -- * Skipping tests hasSharedLibraries :: TestM Bool hasSharedLibraries = do - shared_libs_were_removed <- ghcVersionIs (>= mkVersion [7,8]) + shared_libs_were_removed <- isGhcVersion ">= 7.8" return (not (buildOS == Windows && shared_libs_were_removed)) hasProfiledLibraries :: TestM Bool @@ -753,14 +870,24 @@ env <- getTestEnv return (testHaveCabalShared env) -ghcVersionIs :: WithCallStack ((Version -> Bool) -> TestM Bool) -ghcVersionIs f = do +isGhcVersion :: WithCallStack (String -> TestM Bool) +isGhcVersion range = do ghc_program <- requireProgramM ghcProgram - case programVersion ghc_program of - Nothing -> error $ "ghcVersionIs: no ghc version for " + v <- case programVersion ghc_program of + Nothing -> error $ "isGhcVersion: no ghc version for " ++ show (programLocation ghc_program) - Just v -> return (f v) + Just v -> return v + vr <- case eitherParsec range of + Left err -> fail err + Right vr -> return vr + return (v `withinRange` vr) +skipUnlessGhcVersion :: String -> TestM () +skipUnlessGhcVersion range = skipUnless ("needs ghc " ++ range) =<< isGhcVersion range + +skipIfGhcVersion :: String -> TestM () +skipIfGhcVersion range = skipUnless ("incompatible with ghc " ++ range) =<< isGhcVersion range + isWindows :: TestM Bool isWindows = return (buildOS == Windows) @@ -770,6 +897,9 @@ isLinux :: TestM Bool isLinux = return (buildOS == Linux) +skipIfWindows :: TestM () +skipIfWindows = skipIf "Windows" =<< isWindows + getOpenFilesLimit :: TestM (Maybe Integer) #ifdef mingw32_HOST_OS -- No MS-specified limit, was determined experimentally on Windows 10 Pro x64, @@ -810,7 +940,7 @@ -- You'll want to exclude them in that case. -- hasNewBuildCompatBootCabal :: TestM Bool -hasNewBuildCompatBootCabal = ghcVersionIs (>= mkVersion [7,9]) +hasNewBuildCompatBootCabal = isGhcVersion ">= 7.9" ------------------------------------------------------------------------ -- * Broken tests @@ -862,6 +992,14 @@ recordHeader ["ghc"] runProgramM ghcProgram args Nothing +python3 :: [String] -> TestM () +python3 args = void $ python3' args + +python3' :: [String] -> TestM Result +python3' args = do + recordHeader ["python3"] + runProgramM python3Program args Nothing + -- | If a test needs to modify or write out source files, it's -- necessary to make a hermetic copy of the source files to operate -- on. This function arranges for this to be done. @@ -914,7 +1052,7 @@ delay :: TestM () delay = do env <- getTestEnv - is_old_ghc <- ghcVersionIs (< mkVersion [7,7]) + is_old_ghc <- isGhcVersion "< 7.7" -- For old versions of GHC, we only had second-level precision, -- so we need to sleep a full second. Newer versions use -- millisecond level precision, so we only have to wait @@ -992,3 +1130,21 @@ then takeDrive `fmap` getCurrentDirectory else getTemporaryDirectory withTempDirectory normal tempDir "cabal-test-store" 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. +findDependencyInStore :: FilePath -- ^store dir + -> String -- ^package name prefix + -> IO FilePath -- ^package dir +findDependencyInStore storeDir pkgName = do + storeDirForGhcVersion <- head <$> listDirectory storeDir + packageDirs <- listDirectory (storeDir storeDirForGhcVersion) + -- Ideally, we should call 'hashedInstalledPackageId' from 'Distribution.Client.PackageHash'. + -- But 'PackageHashInputs', especially 'PackageHashConfigInputs', is too hard to construct. + let pkgName' = + if buildOS == OSX + then filter (not . flip elem "aeiou") pkgName + -- simulates the way 'hashedInstalledPackageId' uses to compress package name + else pkgName + let libDir = head $ filter (pkgName' `isPrefixOf`) packageDirs + pure (storeDir storeDirForGhcVersion libDir) diff --git a/cabal/cabal-testsuite/src/Test/Cabal/Run.hs b/cabal/cabal-testsuite/src/Test/Cabal/Run.hs --- a/cabal/cabal-testsuite/src/Test/Cabal/Run.hs +++ b/cabal/cabal-testsuite/src/Test/Cabal/Run.hs @@ -5,7 +5,6 @@ Result(..) ) where -import qualified Distribution.Compat.CreatePipe as Compat import Distribution.Simple.Program.Run import Distribution.Verbosity @@ -46,7 +45,7 @@ mb_env <- getEffectiveEnvironment env_overrides putStrLn $ "+ " ++ showCommandForUser path args - (readh, writeh) <- Compat.createPipe + (readh, writeh) <- createPipe hSetBuffering readh LineBuffering hSetBuffering writeh LineBuffering let drain = do @@ -63,7 +62,8 @@ , std_out = UseHandle writeh , std_err = UseHandle writeh } - (stdin_h, _, _, procHandle) <- createProcess prc + + withCreateProcess prc $ \stdin_h _ _ procHandle -> do case input of Just x -> diff --git a/cabal/cabal-testsuite/src/Test/Cabal/Server.hs b/cabal/cabal-testsuite/src/Test/Cabal/Server.hs --- a/cabal/cabal-testsuite/src/Test/Cabal/Server.hs +++ b/cabal/cabal-testsuite/src/Test/Cabal/Server.hs @@ -15,6 +15,7 @@ ) where import Test.Cabal.Script +import Test.Cabal.TestCode import Prelude hiding (log) import Control.Concurrent.MVar @@ -23,7 +24,7 @@ import System.Process import System.IO import System.Exit -import Data.List +import Data.List (intercalate, isPrefixOf) import Distribution.Simple.Program.Db import Distribution.Simple.Program import Control.Exception @@ -31,7 +32,11 @@ import Control.Monad import Data.IORef import Data.Maybe +import Text.Read (readMaybe) +import Foreign.C.Error (Errno (..), ePIPE) +import qualified GHC.IO.Exception as GHC + import Distribution.Verbosity import System.Process.Internals @@ -77,11 +82,11 @@ | ServerMeta ProcessId | AllServers -data ServerResult = ServerResult { -- Result - serverResultExitCode :: ExitCode, - serverResultCommand :: String, - serverResultStdout :: String, - serverResultStderr :: String +data ServerResult = ServerResult + { serverResultTestCode :: TestCode + , serverResultCommand :: String + , serverResultStdout :: String + , serverResultStderr :: String } -- | With 'ScriptEnv', create a new GHCi 'Server' session. @@ -107,9 +112,9 @@ bracketWithInit before initialize after thing = mask $ \restore -> do a0 <- before - a <- restore (initialize a0) `onException` after a0 - r <- restore (thing a) `onException` after a - _ <- after a + a <- restore (initialize a0) `onException` uninterruptibleMask_ (after a0) + r <- restore (thing a) `onException` uninterruptibleMask_ (after a) + _ <- uninterruptibleMask_ (after a) return r -- | Run an hs script on the GHCi server, returning the 'ServerResult' of @@ -154,7 +159,7 @@ write s $ ":load " ++ script_path -- Create a ref which will record the exit status of the command -- NB: do this after :load so it doesn't get dropped - write s $ "ref <- Data.IORef.newIORef (System.Exit.ExitFailure 1)" + write s $ "ref <- Data.IORef.newIORef Test.Cabal.TestCode.TestCodeFail" -- TODO: What if an async exception gets raised here? At the -- moment, there is no way to recover until we get to the top-level -- bracket; then stopServer which correctly handles this case. @@ -177,7 +182,7 @@ -- command by hand. (real_path, real_args) <- runnerCommand (serverScriptEnv s) mb_cwd env_overrides script_path args return ServerResult { - serverResultExitCode = code, + serverResultTestCode = code, serverResultCommand = showCommandForUser real_path real_args, serverResultStdout = out, serverResultStderr = err @@ -185,22 +190,22 @@ -- | Helper function which we use in the GHCi session to communicate -- the exit code of the process. -runMain :: IORef ExitCode -> IO () -> IO () +runMain :: IORef TestCode -> IO () -> IO () runMain ref m = do - E.catch (m >> writeIORef ref ExitSuccess) serverHandler + E.catch (m >> writeIORef ref TestCodeOk) serverHandler where serverHandler :: SomeException -> IO () serverHandler e = do -- TODO: Probably a few more cases you could handle; - -- e.g., StackOverflow should return 2; also signals. - writeIORef ref $ - case fromException e of - Just exit_code -> exit_code - -- Only rethrow for non ExitFailure exceptions - _ -> ExitFailure 1 - case fromException e :: Maybe ExitCode of + -- e.g., StackOverflow should return ExitCode 2; also signals. + writeIORef ref $ case fromException e of + Just test_code -> test_code + _ -> TestCodeFail + + -- Only rethrow for non ExitFailure exceptions + case fromException e :: Maybe TestCode of Just _ -> return () - _ -> throwIO e + _ -> throwIO e -- ----------------------------------------------------------------- -- -- Initialize/tear down @@ -246,24 +251,17 @@ initServer :: Server -> IO Server initServer s0 = do -- NB: withProcessHandle reads an MVar and is interruptible -#if mingw32_HOST_OS + pid <- withProcessHandle (serverProcessHandle s0) $ \ph -> case ph of +#if mingw32_HOST_OS OpenHandle x -> fmap show (Win32.getProcessId x) - ClosedHandle _ -> return (serverProcessId s0) #else - pid <- withProcessHandle (serverProcessHandle s0) $ \ph -> - case ph of -#if MIN_VERSION_process(1,2,0) OpenHandle x -> return (show x) +#endif -- TODO: handle OpenExtHandle? _ -> return (serverProcessId s0) -#else - OpenHandle x -> return (ph, show x) - -- TODO: handle OpenExtHandle? - _ -> return (ph, serverProcessId s0) -#endif -#endif + let s = s0 { serverProcessId = pid } -- We will read/write a line at a time, including for -- output; our demarcation tokens are an entire line. @@ -308,7 +306,7 @@ log ServerMeta s $ "Waiting..." -- Close input BEFORE waiting, close output AFTER waiting. -- If you get either order wrong, deadlock! - hClose (serverStdin s) + ignoreSigPipe $ hClose (serverStdin s) -- waitForProcess has race condition -- https://github.com/haskell/process/issues/46 waitForProcess $ serverProcessHandle s @@ -318,6 +316,7 @@ _ <- evaluate (length r) hClose (f s) return r + withAsync (drain serverStdout) $ \a_out -> do withAsync (drain serverStderr) $ \a_err -> do @@ -354,6 +353,12 @@ where verbosity = runnerVerbosity (serverScriptEnv s) + ignoreSigPipe :: IO () -> IO () + ignoreSigPipe = E.handle $ \e -> case e of + GHC.IOError { GHC.ioe_type = GHC.ResourceVanished, GHC.ioe_errno = Just ioe } + | Errno ioe == ePIPE -> return () + _ -> throwIO e + -- Using the procedure from -- https://www.schoolofhaskell.com/user/snoyberg/general-haskell/exceptions/catching-all-exceptions ignore :: IO () -> IO () @@ -419,7 +424,7 @@ -- | Consume output from the GHCi server until we hit the -- end sigil. Return the consumed output as well as the -- exit code (which is at the end of the sigil). -readUntilEnd :: Server -> OutOrErr -> IO (ExitCode, String) +readUntilEnd :: Server -> OutOrErr -> IO (TestCode, String) readUntilEnd s outerr = go [] where go rs = do @@ -432,7 +437,9 @@ return (exit, intercalate "\n" (reverse rs)) else do accumulate (serverAccum s outerr) l go (l:rs) - parseExit l = read (drop (length end_sigil) l) + parseExit l = case readMaybe (drop (length end_sigil) l) of + Nothing -> error $ "Cannot parse TestCode at the end of: " ++ l + Just tc -> tc -- | The start and end sigils. This should be chosen to be -- reasonably unique, so that test scripts don't accidentally diff --git a/cabal/cabal-testsuite/src/Test/Cabal/TestCode.hs b/cabal/cabal-testsuite/src/Test/Cabal/TestCode.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/src/Test/Cabal/TestCode.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +-- | Exception type like 'ExitCode' but with more information +-- than just integer. +module Test.Cabal.TestCode ( + -- * TestCode + TestCode (..), + displayTestCode, + isTestCodeSkip, +) where + +import Control.Exception (Exception (..)) +import Data.Typeable (Typeable) + +------------------------------------------------------------------------------- +-- TestCode +------------------------------------------------------------------------------- + +data TestCode + = TestCodeOk + | TestCodeSkip String + | TestCodeKnownFail + | TestCodeUnexpectedOk + | TestCodeFail + deriving (Eq, Show, Read, Typeable) + +instance Exception TestCode +#if MIN_VERSION_base(4,8,0) + where + displayException = displayTestCode +#endif + +displayTestCode :: TestCode -> String +displayTestCode TestCodeOk = "OK" +displayTestCode (TestCodeSkip msg) = "SKIP " ++ msg +displayTestCode TestCodeKnownFail = "OK (known failure)" +displayTestCode TestCodeUnexpectedOk = "FAIL (unexpected success)" +displayTestCode TestCodeFail = "FAIL" + +isTestCodeSkip :: TestCode -> Bool +isTestCodeSkip (TestCodeSkip _) = True +isTestCodeSkip _ = False diff --git a/cabal/cabal.project b/cabal/cabal.project --- a/cabal/cabal.project +++ b/cabal/cabal.project @@ -1,34 +1,56 @@ -packages: Cabal/ cabal-testsuite/ -packages: cabal-install/ solver-benchmarks/ +packages: Cabal/ cabal-testsuite/ Cabal-syntax/ +packages: cabal-install/ +packages: cabal-install-solver/ +packages: solver-benchmarks/ + tests: True -packages: Cabal/Cabal-QuickCheck/ -packages: Cabal/Cabal-tree-diff/ -packages: Cabal/Cabal-described +packages: Cabal-QuickCheck/ +packages: Cabal-tree-diff/ +packages: Cabal-described +packages: Cabal-tests/ packages: cabal-benchmarks/ --- Uncomment to allow picking up extra local unpacked deps: ---optional-packages: */ - --- Remove after hackage-repo-tool release -allow-newer: - hackage-repo-tool:optparse-applicative +optional-packages: ./vendored/*/*.cabal allow-newer: hackage-security:Cabal -program-options - -- So us hackers get all the assertion failures early: - -- - -- NOTE: currently commented out, see - -- https://github.com/haskell/cabal/issues/3911 - -- - -- ghc-options: -fno-ignore-asserts - -- - -- as a workaround we specify it for each package individually: +-- avoiding extra dependencies +constraints: rere -rere-cfg +constraints: these -assoc + +-- Andreas, 2022-08-19, https://github.com/haskell/cabal/issues/8377 +-- Force latest dependencies in the development version: +constraints: text >= 2.0 +constraints: time >= 1.12 + +-- So us hackers get all the assertion failures early: +-- +-- NOTE: currently commented out, see +-- https://github.com/haskell/cabal/issues/3911 +-- as a workaround we specify it for each package individually: +-- +-- program-options +-- ghc-options: -fno-ignore-asserts +-- package Cabal ghc-options: -fno-ignore-asserts + package cabal-testsuite ghc-options: -fno-ignore-asserts + +package Cabal-QuickCheck + ghc-options: -fno-ignore-asserts + +package Cabal-tree-diff + ghc-options: -fno-ignore-asserts + +package Cabal-described + ghc-options: -fno-ignore-asserts + +package cabal-install-solver + ghc-options: -fno-ignore-asserts + package cabal-install ghc-options: -fno-ignore-asserts diff --git a/cabal/cabal.project.buildinfo b/cabal/cabal.project.buildinfo --- a/cabal/cabal.project.buildinfo +++ b/cabal/cabal.project.buildinfo @@ -1,5 +1,6 @@ +packages: Cabal-syntax/ packages: Cabal/ -packages: Cabal/Cabal-described +packages: Cabal-described packages: buildinfo-reference-generator/ tests: False optimization: False diff --git a/cabal/cabal.project.coverage b/cabal/cabal.project.coverage new file mode 100644 --- /dev/null +++ b/cabal/cabal.project.coverage @@ -0,0 +1,79 @@ +packages: Cabal-syntax/ Cabal/ cabal-testsuite/ +packages: cabal-install/ +packages: cabal-install-solver/ +packages: solver-benchmarks/ + +tests: True + +packages: Cabal-QuickCheck/ +packages: Cabal-tree-diff/ +packages: Cabal-described +packages: Cabal-tests/ +packages: cabal-benchmarks/ + +-- Uncomment to allow picking up extra local unpacked deps: +--optional-packages: */ + +-- Remove after hackage-repo-tool release +allow-newer: + hackage-repo-tool:optparse-applicative + +allow-newer: + hackage-security:Cabal + +-- https://github.com/haskell-hvr/windns/pull/2 +allow-newer: windns-0.1.0.1:base + +-- avoiding extra dependencies +constraints: rere -rere-cfg +constraints: these + +-- NOTE: for library coverage in multi-project builds, +-- see: +-- +-- * https://github.com/haskell/cabal/issues/6440 +-- * https://github.com/haskell/cabal/issues/5213#issuecomment-586517129 +-- +-- We must mask coverage for dependencies of `cabal-install` in +-- multiproject settings in order to generate coverage for +-- the `cabal-install` library +-- +package Cabal-syntax + ghc-options: -fno-ignore-asserts + coverage: False + library-coverage: False + +package Cabal + ghc-options: -fno-ignore-asserts + coverage: False + library-coverage: False + +package cabal-testsuite + ghc-options: -fno-ignore-asserts + coverage: False + library-coverage: False + +package Cabal-QuickCheck + ghc-options: -fno-ignore-asserts + coverage: False + library-coverage: False + +package Cabal-tree-diff + ghc-options: -fno-ignore-asserts + coverage: False + library-coverage: False + +package Cabal-described + ghc-options: -fno-ignore-asserts + coverage: False + library-coverage: False + +package cabal-install-solver + ghc-options: -fno-ignore-asserts + coverage: False + library-coverage: False + +package cabal-install + ghc-options: -fno-ignore-asserts + coverage: True + library-coverage: True diff --git a/cabal/cabal.project.libonly b/cabal/cabal.project.libonly --- a/cabal/cabal.project.libonly +++ b/cabal/cabal.project.libonly @@ -1,4 +1,10 @@ -packages: Cabal/ cabal-testsuite/ +packages: Cabal-syntax/ Cabal/ cabal-testsuite/ + +packages: Cabal-QuickCheck/ +packages: Cabal-tree-diff +packages: Cabal-described +packages: Cabal-tests + tests: True -- Uncomment to allow picking up extra local unpacked deps: @@ -13,6 +19,8 @@ -- ghc-options: -fno-ignore-asserts -- -- as a workaround we specify it for each package individually: +package Cabal-syntax + ghc-options: -fno-ignore-asserts package Cabal ghc-options: -fno-ignore-asserts package cabal-testsuite diff --git a/cabal/cabal.project.local.travis b/cabal/cabal.project.local.travis deleted file mode 100644 --- a/cabal/cabal.project.local.travis +++ /dev/null @@ -1,32 +0,0 @@ --- Force error messages to be better --- Parallel new-build error messages are non-existent. --- Turn off parallelization to get good errors. -jobs: 1 - --- We vendor a copy of hackage-repo-tool so that we can --- build it reliably. If we eventually get new-install --- in the bootstrap, this can go away. -optional-packages: hackage-repo-tool-*/ --- hackage-repo-tool has upper bound on time -allow-newer: hackage-repo-tool:time - --- The -fno-warn-orphans is a hack to make Cabal-1.24 --- build properly (unfortunately the flags here get applied --- to the dependencies too!) -package Cabal - ghc-options: -Werror -fno-warn-orphans - -constraints: - binary installed, - bytestring installed, - containers installed, - deepseq installed, - directory installed, - filepath installed, - pretty installed, - process installed, - time installed, - unix installed - -package cabal-install - ghc-options: -Werror diff --git a/cabal/cabal.project.release b/cabal/cabal.project.release --- a/cabal/cabal.project.release +++ b/cabal/cabal.project.release @@ -1,11 +1,7 @@ +packages: Cabal-syntax/ packages: Cabal/ +packages: cabal-install-solver/ packages: cabal-install/ tests: False benchmarks: False -optimizations: True - -package Cabal - ghc-options: -fexpose-all-unfoldings -fspecialise-aggressively - -package parsec - ghc-options: -fexpose-all-unfoldings +optimization: True diff --git a/cabal/cabal.project.validate b/cabal/cabal.project.validate --- a/cabal/cabal.project.validate +++ b/cabal/cabal.project.validate @@ -1,16 +1,26 @@ -packages: Cabal/ cabal-testsuite/ cabal-install/ solver-benchmarks/ -tests: True +packages: Cabal-syntax/ +packages: Cabal/ +packages: cabal-testsuite/ +packages: cabal-install/ +packages: solver-benchmarks/ -packages: Cabal/Cabal-QuickCheck/ -packages: Cabal/Cabal-tree-diff -packages: Cabal/Cabal-described +packages: cabal-install-solver/ +packages: Cabal-QuickCheck/ +packages: Cabal-tree-diff +packages: Cabal-described +packages: Cabal-tests +packages: cabal-benchmarks +tests: True + -- avoiding extra dependencies constraints: rere -rere-cfg constraints: these -assoc write-ghc-environment-files: never +package Cabal-syntax + ghc-options: -Werror -fno-ignore-asserts package Cabal ghc-options: -Werror -fno-ignore-asserts package cabal-testsuite diff --git a/cabal/cabal.project.validate.libonly b/cabal/cabal.project.validate.libonly --- a/cabal/cabal.project.validate.libonly +++ b/cabal/cabal.project.validate.libonly @@ -1,4 +1,11 @@ -packages: Cabal/ cabal-testsuite/ +packages: Cabal-syntax/ +packages: Cabal/ +packages: cabal-testsuite/ +packages: Cabal-QuickCheck/ +packages: Cabal-tree-diff +packages: Cabal-described +packages: Cabal-tests + tests: True write-ghc-environment-files: never @@ -7,7 +14,12 @@ constraints: rere -rere-cfg constraints: these -assoc +package Cabal-syntax + ghc-options: -Werror -fno-ignore-asserts package Cabal ghc-options: -Werror -fno-ignore-asserts package cabal-testsuite ghc-options: -Werror -fno-ignore-asserts + +-- https://github.com/haskell-hvr/cryptohash-sha256/issues/12 +allow-newer: cryptohash-sha256:base diff --git a/cabal/cabal.project.weeder b/cabal/cabal.project.weeder --- a/cabal/cabal.project.weeder +++ b/cabal/cabal.project.weeder @@ -4,6 +4,7 @@ -- cabal install -w ghc-8.8.3 weeder -- +packages: Cabal-syntax/ packages: Cabal/ packages: cabal-install/ tests: False diff --git a/cabal/changelog.d/Cabal-QuickCheck b/cabal/changelog.d/Cabal-QuickCheck deleted file mode 100644 --- a/cabal/changelog.d/Cabal-QuickCheck +++ /dev/null @@ -1,4 +0,0 @@ -synopsis: Cabal-QuickCheck package with `Arbirary` instances -prs: #6557 #6891 -issues: #6882 -packages: Cabal diff --git a/cabal/changelog.d/Cabal-tree-diff b/cabal/changelog.d/Cabal-tree-diff deleted file mode 100644 --- a/cabal/changelog.d/Cabal-tree-diff +++ /dev/null @@ -1,3 +0,0 @@ -synopsis: Create Cabal-tree-diff package with `ToExpr` instances -prs: #6789 -packages: Cabal diff --git a/cabal/changelog.d/PerCompilerFlavor-functor b/cabal/changelog.d/PerCompilerFlavor-functor deleted file mode 100644 --- a/cabal/changelog.d/PerCompilerFlavor-functor +++ /dev/null @@ -1,3 +0,0 @@ -synopsis: `Cabal.Distribution.Compiler`: add `Traversable` instance for `PerCompilerFlavor` -prs: #6763 -packages: Cabal diff --git a/cabal/changelog.d/active-repositories b/cabal/changelog.d/active-repositories deleted file mode 100644 --- a/cabal/changelog.d/active-repositories +++ /dev/null @@ -1,14 +0,0 @@ -synopsis: Add active-repositories configuration -packages: cabal-install -prs: #6724 #6868 -issues: #6819 -significance: significant - -description: { - -New `active-repositories` `cabal.project` fields allows -specifying an order and ways various package repositories are combined. - -The active `active-repositories` is saved in `cabal.project.freeze`. - -} diff --git a/cabal/changelog.d/added-tests b/cabal/changelog.d/added-tests deleted file mode 100644 --- a/cabal/changelog.d/added-tests +++ /dev/null @@ -1,11 +0,0 @@ -synopsis: Tests additions -prs: #6753 #6759 #6802 #6842 #6872 -issues: #6409 - -description: { - -- Add shrinker, so writing big non-generic product shrinkers is easier -- Add `hs-source-dirs: NL .` test-case -- Add public multilib test(s) - -} diff --git a/cabal/changelog.d/backported b/cabal/changelog.d/backported deleted file mode 100644 --- a/cabal/changelog.d/backported +++ /dev/null @@ -1,43 +0,0 @@ -synopsis: Backported to 3.2 -packages: Cabal-internal -prs: - -- solver - #5918 #6447 - -- buildinfo generator - #6258 - -- bump version - #6426 - -- cabal install -z - #6428 - -- incomplete-uni-patterns - #6433 - -- packages/optional packages empty - #6436 - -- file+noindex - #6448 - -- documentation - #6450 #6464 #6473 #6546 - -- bounds - #6455 - -- safe functions - #6456 - -- Improve few internalErrors in InstallPlan - #6439 - -- v2-run -z - #6457 - -- test fixes - #6463 #6499 #6518 - -- CI - #6469 - -- show full abi hash - #6498 #6496 #6476 - -- Create distTempDirectory in withTempEnvFile - #6501 - -- cabal_macros.h zinza - -- TODO: check whether it made to 3.2 - -- issue: #6533 - #6502 #6535 - -- disallow spaces around : in dependency - #6538 - -- pkg-config - #6540 #6541 diff --git a/cabal/changelog.d/build-reports b/cabal/changelog.d/build-reports deleted file mode 100644 --- a/cabal/changelog.d/build-reports +++ /dev/null @@ -1,3 +0,0 @@ -synopsis: Change `BuildReports` parse/pretty to use FieldGrammar framework -prs: #6783 -packages: cabal-install diff --git a/cabal/changelog.d/cabal-init b/cabal/changelog.d/cabal-init deleted file mode 100644 --- a/cabal/changelog.d/cabal-init +++ /dev/null @@ -1,19 +0,0 @@ -synopsis: Various `cabal init` improvements -packages: cabal-install -prs: #6619 #6661 #6641 #6650 #6603 #6632 #6607 #6678 #6690 #6705 #6723 #6676 #6677 -issues: #6150 #6675 -significance: significant - -description: { - -- Default to `cabal-version: 2.4` -- `cabal` doesn't force a default license choice anymore -- Licenses are always asked using SPDX expression -- Fix an infinite loop when invalid license was passed on command line -- `Setup.hs` is not written anymore -- Default to --source-dir=src and --application-dir=app -- Add `FileCreators.generateCabalFile` unit tests. -- Default cabal init application-dir to `app`, and source-dir to `src`. -- Default to SPDX.NONE license in cabal init interactive mode. - -} diff --git a/cabal/changelog.d/cabal-list b/cabal/changelog.d/cabal-list deleted file mode 100644 --- a/cabal/changelog.d/cabal-list +++ /dev/null @@ -1,5 +0,0 @@ -synopsis: `cabal list` accepts regular expression -packages: cabal-install -prs: #6618 #6806 -issues: #4267 #6683 -significance: significant diff --git a/cabal/changelog.d/cabal-project-local-tilde b/cabal/changelog.d/cabal-project-local-tilde deleted file mode 100644 --- a/cabal/changelog.d/cabal-project-local-tilde +++ /dev/null @@ -1,3 +0,0 @@ -synopsis: Tell users about `cabal.project.local~` in `cabal v2-configure` -prs: #6877 -packages: cabal-install diff --git a/cabal/changelog.d/cabal-sdist b/cabal/changelog.d/cabal-sdist deleted file mode 100644 --- a/cabal/changelog.d/cabal-sdist +++ /dev/null @@ -1,32 +0,0 @@ -synopsis: Rework `v2-sdist` command -packages: cabal-install -issues: #6635 #5813 #2940 #6611 #6514 -prs: #6454 #6637 #6640 #6660 #6666 #6884 #6916 -significance: significant - -description: { - -`v2-sdist` marks all files as readonly in resulting tarballs. - -The #2940 "cabal sdist should touch preprocessed .hs files" issue -is fixed by virtue of not doing any preprocessing anymore. -It's responsibility of packager. - -The #6611 "v2-sdist includes a file twice in the tarball " issue -is fixed as we don't consider only one file list, -not two separate executable and ordinary file lists. - -The #6514 "unpack doesn't preserve (executable) permissions" issue -is partially resolved, as there shouldn't be executable permissions -in the tar files. - -The rationale for above simplification is simple. The only file -Cabal machinery would run is `configure` script. These -are run with explicit `sh` program. For package internal scripts, -maintainers should also use interpreters explicitly as well. -Scripts with shebangs are not executable on Windows. - -The `v1-sdist` command is removed, as its functionality is completely -superseded by `v2-sdist`. - -} diff --git a/cabal/changelog.d/cabal-spec-3.4 b/cabal/changelog.d/cabal-spec-3.4 deleted file mode 100644 --- a/cabal/changelog.d/cabal-spec-3.4 +++ /dev/null @@ -1,9 +0,0 @@ -synopsis: Add cabal-version: 3.4 -prs: #6663 -significance: significant - -description: { - -See various changes in https://cabal.readthedocs.io/en/latest/file-format-changelog.html#cabal-version-3-4 - -} diff --git a/cabal/changelog.d/cabal-testsuite b/cabal/changelog.d/cabal-testsuite deleted file mode 100644 --- a/cabal/changelog.d/cabal-testsuite +++ /dev/null @@ -1,8 +0,0 @@ -synopsis: Improvements to cabal-testsuite framework -prs: #6643 - -desciption: { - -- setupAndCabalTest uses cabal act-as-setup for cabal part - -} diff --git a/cabal/changelog.d/cabalInstallVersion b/cabal/changelog.d/cabalInstallVersion deleted file mode 100644 --- a/cabal/changelog.d/cabalInstallVersion +++ /dev/null @@ -1,3 +0,0 @@ -synopsis: Refactor cabalInstallVersions, add make doctest-cli -packages: cabal-install -prs: #6720 diff --git a/cabal/changelog.d/changelog b/cabal/changelog.d/changelog deleted file mode 100644 --- a/cabal/changelog.d/changelog +++ /dev/null @@ -1,3 +0,0 @@ -synopsis: Changelog entries -packages: Cabal-internal -prs: #6634 #6950 diff --git a/cabal/changelog.d/ci b/cabal/changelog.d/ci deleted file mode 100644 --- a/cabal/changelog.d/ci +++ /dev/null @@ -1,24 +0,0 @@ -synopsis: CI tweaks -packages: Cabal-internal -prs: - #6494 - #6518 - #6559 - #6564 - #6571 - #6577 - #6578 - #6579 - #6585 - #6617 - #6636 - #6709 - #6827 - #6831 - #6900 - #6902 - #6914 - #6946 -issues: - #6500 - #6945 diff --git a/cabal/changelog.d/code-organization b/cabal/changelog.d/code-organization deleted file mode 100644 --- a/cabal/changelog.d/code-organization +++ /dev/null @@ -1,16 +0,0 @@ -synopsis: Code organization -prs: #6599 #6642 #6734 #6745 #6746 #6817 #6818 #6821 #6867 - -description: { - -- Split `Distribution.Client.Types` module -- Move cabal-testsuite code into `src/` -- Add `ProjectFlags` -- Add `NixStyleOptions` -- Internal refactorings to install command. -- Make own modules for `InstallMethod` and `OverwritePolicy` -- Make cabal-install compilable with `NoImplicitPrelude` -- Refactor shared `TargetProblem` data types into their own module. -- Template `cabal-install.cabal` using zinza - -} diff --git a/cabal/changelog.d/copyright b/cabal/changelog.d/copyright deleted file mode 100644 --- a/cabal/changelog.d/copyright +++ /dev/null @@ -1,2 +0,0 @@ -synopsis: Update copyright years to 2020 -prs: #6644 diff --git a/cabal/changelog.d/dependency b/cabal/changelog.d/dependency deleted file mode 100644 --- a/cabal/changelog.d/dependency +++ /dev/null @@ -1,16 +0,0 @@ -synopsis: Dependency type refactorings -packages: Cabal -prs: #6798 #6768 #6895 #6896 #6897 #6898 -issues: #5570 #6894 -significance: significant - -description: { - -With additions of (public) sublibraries, `Dependency` type use for multiple needs become painful. -Therefore a new type `PackageVersionConstraint` was added to serve *constraint on package* use-case. -`Dependency` type is *dependency on a library component*, i.e. representing `build-depends` entry. - -- Use PackageVersionConstraint more -- Add NonEmptySet and use it in Dependency - -} diff --git a/cabal/changelog.d/described b/cabal/changelog.d/described deleted file mode 100644 --- a/cabal/changelog.d/described +++ /dev/null @@ -1,8 +0,0 @@ -synopsis: The grammar of most package description fields is formally documented -prs: #6591 #6593 #6704 #6766 #6778 #6780 #6781 #6791 #6800 - -description: { - -See https://cabal.readthedocs.io/en/latest/buildinfo-fields-reference.html - -} diff --git a/cabal/changelog.d/documentation b/cabal/changelog.d/documentation deleted file mode 100644 --- a/cabal/changelog.d/documentation +++ /dev/null @@ -1,4 +0,0 @@ -synopsis: Documentation updates and typo-fixes -prs: - #6613 #6560 #6660 #6668 #6669 #6697 #6761 #6940 - #6504 #6550 #6686 #6928 #6954 #6953 #6951 diff --git a/cabal/changelog.d/expose-all-unfoldings b/cabal/changelog.d/expose-all-unfoldings deleted file mode 100644 --- a/cabal/changelog.d/expose-all-unfoldings +++ /dev/null @@ -1,9 +0,0 @@ -synopsis: Add -fexpose-all-unfoldings to parsec and Cabal in release project -packages: cabal-install -prs: #6708 - -description: { - -This makes parser faster with acceptable code-size increase. - -} diff --git a/cabal/changelog.d/flag-assignment b/cabal/changelog.d/flag-assignment deleted file mode 100644 --- a/cabal/changelog.d/flag-assignment +++ /dev/null @@ -1,3 +0,0 @@ -synopsis: Flag assignment parsing refactorings -prs: #6854 #6858 -issues: #6853 diff --git a/cabal/changelog.d/ghc-8.12 b/cabal/changelog.d/ghc-8.12 deleted file mode 100644 --- a/cabal/changelog.d/ghc-8.12 +++ /dev/null @@ -1,18 +0,0 @@ -synopsis: Support GHC-8.12 -prs: - #6735 #6844 #6865 #6848 #6908 #6947 - #6552 #6553 #6563 #6545 -issues: #6903 #6904 #6905 -significance: significant - -description: { - -- Support for `-this-package-key` deprecation -- Use process `createPipe` -- Add support for WINIO to Cabal -- Adopt to simplfied subsumption changes - -There are no magical `IO = WithCallStack Prelude.IO` alias in Cabal, -as it is hard to get working with GHC-8.12's simplified subsumption. - -} diff --git a/cabal/changelog.d/ghci-fix b/cabal/changelog.d/ghci-fix deleted file mode 100644 --- a/cabal/changelog.d/ghci-fix +++ /dev/null @@ -1,8 +0,0 @@ -synopsis: Fix ghci being launched before other sources are built. -prs: #6923 - -description: { - -Related to foreign calls to C-sources. - -} diff --git a/cabal/changelog.d/help-remove-new-aliases b/cabal/changelog.d/help-remove-new-aliases deleted file mode 100644 --- a/cabal/changelog.d/help-remove-new-aliases +++ /dev/null @@ -1,3 +0,0 @@ -synopsis: Remove new- command from `--help` output (there are v2-) -prs: #6930 -packages: cabal-install diff --git a/cabal/changelog.d/index-state b/cabal/changelog.d/index-state deleted file mode 100644 --- a/cabal/changelog.d/index-state +++ /dev/null @@ -1,5 +0,0 @@ -synopsis: More rich `index-state` syntax. `v2-freeze` saves `index-state`. -packages: cabal-install -prs: #6596 #6581 #6597 #6591 #6682 #6733 -issues: #6728 -significance: significant diff --git a/cabal/changelog.d/install-prints-destination b/cabal/changelog.d/install-prints-destination deleted file mode 100644 --- a/cabal/changelog.d/install-prints-destination +++ /dev/null @@ -1,3 +0,0 @@ -synopsis: Installing (copy or symlink) executable message prints destination. -prs: #6590 #6582 -packages: cabal-install diff --git a/cabal/changelog.d/install-sha256 b/cabal/changelog.d/install-sha256 deleted file mode 100644 --- a/cabal/changelog.d/install-sha256 +++ /dev/null @@ -1,3 +0,0 @@ -synopsis: Check sha256 if `#sha256=...` fragments are given to URIs -packages: cabal-install -prs: #6576 diff --git a/cabal/changelog.d/issue-4746 b/cabal/changelog.d/issue-4746 deleted file mode 100644 --- a/cabal/changelog.d/issue-4746 +++ /dev/null @@ -1,4 +0,0 @@ -synopsis: all extra-source-files are change-tracked -packages: cabal-install -issues: #4746 -prs: #6889 diff --git a/cabal/changelog.d/issue-5224 b/cabal/changelog.d/issue-5224 deleted file mode 100644 --- a/cabal/changelog.d/issue-5224 +++ /dev/null @@ -1,4 +0,0 @@ -synopsis: `upload --help` now includes `password-command` as a config file option (#5224) -packages: cabal-install -issues: #5224 -prs: #6609 #6313 #6680 diff --git a/cabal/changelog.d/issue-5555 b/cabal/changelog.d/issue-5555 deleted file mode 100644 --- a/cabal/changelog.d/issue-5555 +++ /dev/null @@ -1,4 +0,0 @@ -synopsis: Use PrettyField to format cabal file in `cabal init` -packages: cabal-install -prs: #6718 -issues: #5555 diff --git a/cabal/changelog.d/issue-5586 b/cabal/changelog.d/issue-5586 deleted file mode 100644 --- a/cabal/changelog.d/issue-5586 +++ /dev/null @@ -1,12 +0,0 @@ -synopsis: `source-repository-package` directories aren't local -packages: cabal-install -issues: #5586 -prs: #6917 #6915 -significance: significant - -description: { - -Concretely these means that compiled `source-repository-package` entries -used in different projects are stored in the global nix-style store. - -} diff --git a/cabal/changelog.d/issue-5973 b/cabal/changelog.d/issue-5973 deleted file mode 100644 --- a/cabal/changelog.d/issue-5973 +++ /dev/null @@ -1,14 +0,0 @@ -synopsis: Use default install directory if not specified -packages: cabal-install -prs: #6624 -issues: #5973 - -description: { - -Cabal 3.0.0.0 added the --installdir option to specify the location that -binaries should be installed in. Running a cabal user-config update would -populate the config file with the default value, but the cabal install program -would error if it wasn't set. This change uses the default value that would be -written to the config if its unset, and outputs a warning. - -} diff --git a/cabal/changelog.d/issue-6083 b/cabal/changelog.d/issue-6083 deleted file mode 100644 --- a/cabal/changelog.d/issue-6083 +++ /dev/null @@ -1,23 +0,0 @@ -synopsis: Treat `pkg:sublib` dependency syntax as is in `cabal-version: 3.4` -issues: #6083 -prs: #6907 #6893 -significance: significant - -description: { - -In `cabal-version: 3.4` cabal files the dependency definition - -```cabal -build-depends: somesublib -``` - -is not using in-package sublibraries. You have to be explicit and write - -```cabal -build-depends: thispkg:somesublib -``` - -This fixes an issue, where it was impossible to refer to extenral -library, if you had sublibrary of the same name. - -} diff --git a/cabal/changelog.d/issue-6210 b/cabal/changelog.d/issue-6210 deleted file mode 100644 --- a/cabal/changelog.d/issue-6210 +++ /dev/null @@ -1,4 +0,0 @@ -synopsis: Default to 'NoReports' for remote build reporting -packages: cabal-install -issues: #6210 -prs: #6625 diff --git a/cabal/changelog.d/issue-6281 b/cabal/changelog.d/issue-6281 deleted file mode 100644 --- a/cabal/changelog.d/issue-6281 +++ /dev/null @@ -1,3 +0,0 @@ -synopsis: Add foo:bar syntax to mixins -issues: #6281 -prs: #6912 diff --git a/cabal/changelog.d/issue-6288 b/cabal/changelog.d/issue-6288 deleted file mode 100644 --- a/cabal/changelog.d/issue-6288 +++ /dev/null @@ -1,3 +0,0 @@ -synopsis: default-language field is optional in cabal-version: 3.4 -prs: #6926 #6924 -issues: #6288 diff --git a/cabal/changelog.d/issue-6369 b/cabal/changelog.d/issue-6369 deleted file mode 100644 --- a/cabal/changelog.d/issue-6369 +++ /dev/null @@ -1,4 +0,0 @@ -synopsis: Allow cabal v2-install pkgname:exename -packages: cabal-install -prs: #6576 -issues: #6369 diff --git a/cabal/changelog.d/issue-6393 b/cabal/changelog.d/issue-6393 deleted file mode 100644 --- a/cabal/changelog.d/issue-6393 +++ /dev/null @@ -1,4 +0,0 @@ -synopsis: Allow cabal v2-install http:// -packages: cabal-install -prs: #6576 -issues: #6393 diff --git a/cabal/changelog.d/issue-6432 b/cabal/changelog.d/issue-6432 deleted file mode 100644 --- a/cabal/changelog.d/issue-6432 +++ /dev/null @@ -1,4 +0,0 @@ -synopsis: Split `KnownRepoType` out of `RepoType` -packages: Cabal -issues: #6432 -prs: #6612 diff --git a/cabal/changelog.d/issue-6485 b/cabal/changelog.d/issue-6485 deleted file mode 100644 --- a/cabal/changelog.d/issue-6485 +++ /dev/null @@ -1,3 +0,0 @@ -synopsis: Include component name in unit-id -issues: #6485 -prs: #6547 diff --git a/cabal/changelog.d/issue-6565 b/cabal/changelog.d/issue-6565 deleted file mode 100644 --- a/cabal/changelog.d/issue-6565 +++ /dev/null @@ -1,13 +0,0 @@ -synopsis: Update GHC environment location -prs: #6822 -issues: #6565 -packages: cabal-install - -description: { - -cabal-install currently assumes that the GHC environment files are always located in `$HOME/.ghc/`. -However, GHC itself doesn't query the home directory directly. -Instead, it uses `getAppUserDataDirectory "ghc"` which happens to coincide with `$HOME/.ghc`/ on UNIX systems. -On Windows, however, GHC ends up looking in `%APPDATA%/ghc/`. - -} diff --git a/cabal/changelog.d/issue-6575 b/cabal/changelog.d/issue-6575 deleted file mode 100644 --- a/cabal/changelog.d/issue-6575 +++ /dev/null @@ -1,4 +0,0 @@ -synopsis: cabal v2-install prints copy/symlink destination -packages: cabal-install -prs: #6582 #6890 -issues: #6575 diff --git a/cabal/changelog.d/issue-6589 b/cabal/changelog.d/issue-6589 deleted file mode 100644 --- a/cabal/changelog.d/issue-6589 +++ /dev/null @@ -1,6 +0,0 @@ -synopsis: Remove `-any` and `-none` syntax for version ranges in cabal-version: 3.4 -issues: #6589 -prs: #6786 - -description: - Use `>=0` (or empty in dependencies) and `<0` respectively. diff --git a/cabal/changelog.d/issue-6610 b/cabal/changelog.d/issue-6610 deleted file mode 100644 --- a/cabal/changelog.d/issue-6610 +++ /dev/null @@ -1,11 +0,0 @@ -synopsis: Add pijul to known repository type -issues: #6610 -prs: #6684 - -description: { - -Pijul is now explicitly recognized version control system. -However `cabal-install` isn't yet able to use it in -`source-repository-package`. - -} diff --git a/cabal/changelog.d/issue-6622 b/cabal/changelog.d/issue-6622 deleted file mode 100644 --- a/cabal/changelog.d/issue-6622 +++ /dev/null @@ -1,4 +0,0 @@ -synopsis: Prepend hs-source-dir to match-component, fixes `cabal repl file` -packages: cabal-install -prs: #6623 #6826 #6875 -issues: #6622 diff --git a/cabal/changelog.d/issue-6691 b/cabal/changelog.d/issue-6691 deleted file mode 100644 --- a/cabal/changelog.d/issue-6691 +++ /dev/null @@ -1,13 +0,0 @@ -synopsis: Remove upgrade, uninstall and win32selfupgrade commands -packages: cabal-install -issues: #6691 -prs: #6707 - -description: { - -This commands were not implemented or are special purpose. -The removal of `win32selfupgrade` might break self upgrade on windows, -when `cabal-install` tries to rewrite the binary of itself. -This shouldn't be a problem when symlinking is used. - -} diff --git a/cabal/changelog.d/issue-6710 b/cabal/changelog.d/issue-6710 deleted file mode 100644 --- a/cabal/changelog.d/issue-6710 +++ /dev/null @@ -1,16 +0,0 @@ -synopsis: Rename Flag to CompilerFlag and PackageFlag -packages: Cabal -issues: #6710 -prs: #6725 - -description: { - -There was three Flag's. Now they are - -- `Flag` (cli parsing) -- `PackageFlag` -- `CompilerFlag` - -This allows wild-imports without `hiding (Flag)`. - -} diff --git a/cabal/changelog.d/issue-6729 b/cabal/changelog.d/issue-6729 deleted file mode 100644 --- a/cabal/changelog.d/issue-6729 +++ /dev/null @@ -1,11 +0,0 @@ -synopsis: Remove local-repo -packages: cabal-install -issues: #6729 -prs: #6730 - -description: { - -This functionality was mainly used by removed sandboxes. -`file+noindex` repositories are better variant for local package repositories. - -} diff --git a/cabal/changelog.d/issue-6739 b/cabal/changelog.d/issue-6739 deleted file mode 100644 --- a/cabal/changelog.d/issue-6739 +++ /dev/null @@ -1,3 +0,0 @@ -synopsis: Change 'optional-packages' default to empty, when cabal.project is mising. -issues: #6739 #4797 -prs: #6740 diff --git a/cabal/changelog.d/issue-6804 b/cabal/changelog.d/issue-6804 deleted file mode 100644 --- a/cabal/changelog.d/issue-6804 +++ /dev/null @@ -1,4 +0,0 @@ -synopsis: v2-update reports new index-state -packages: cabal-install -issues: #6804 -prs: #6810 diff --git a/cabal/changelog.d/issue-6805 b/cabal/changelog.d/issue-6805 deleted file mode 100644 --- a/cabal/changelog.d/issue-6805 +++ /dev/null @@ -1,3 +0,0 @@ -synopsis: Fix rpmvercmp (trailing non-digit characters) -issues: #6805 -prs: #6808 diff --git a/cabal/changelog.d/issue-6807 b/cabal/changelog.d/issue-6807 deleted file mode 100644 --- a/cabal/changelog.d/issue-6807 +++ /dev/null @@ -1,11 +0,0 @@ -synopsis: Add list-bin command -packages: cabal-install -issues: #6807 -prs: #6931 -significance: significant - -description: { - -`cabal list-bin executable-component` tells the path to the build artifact. - -} diff --git a/cabal/changelog.d/issue-6809 b/cabal/changelog.d/issue-6809 deleted file mode 100644 --- a/cabal/changelog.d/issue-6809 +++ /dev/null @@ -1,4 +0,0 @@ -synopsis: Add `-z` / `--ignore-project` flag to `cabal v2-update` -packages: cabal-install -issues: #6809 -prs: #6814 diff --git a/cabal/changelog.d/issue-6856 b/cabal/changelog.d/issue-6856 deleted file mode 100644 --- a/cabal/changelog.d/issue-6856 +++ /dev/null @@ -1,4 +0,0 @@ -synopsis: Adjust message indicating `--lib` is likely desired -packages: cabal-install -issues: #6856 -prs: #6857 diff --git a/cabal/changelog.d/issue-6869 b/cabal/changelog.d/issue-6869 deleted file mode 100644 --- a/cabal/changelog.d/issue-6869 +++ /dev/null @@ -1,4 +0,0 @@ -synopsis: cxx-sources, asm-sources and cmm-sources are change-tracked -packages: cabal-install -issues: #6869 -prs: #6870 diff --git a/cabal/changelog.d/issue-8351 b/cabal/changelog.d/issue-8351 new file mode 100644 --- /dev/null +++ b/cabal/changelog.d/issue-8351 @@ -0,0 +1,11 @@ +synopsis: Expose BuildFlags and ClientHaddockFlags +packages: cabal-install +prs: #8353 +issues: #8351 + +description: { + +Some types are present in public functions in cabal-install, but they are not exported. +This PR fix it for BuildFlags and ClientHaddockFlags. + +} diff --git a/cabal/changelog.d/linux-androideabi b/cabal/changelog.d/linux-androideabi deleted file mode 100644 --- a/cabal/changelog.d/linux-androideabi +++ /dev/null @@ -1,9 +0,0 @@ -synopsis: Accept "linux-androideabi" as an alias for Android for determining buildOS -prs: #6949 #6301 -packages: Cabal - -description: { - -`Cabal` will able to parse `linux-androideabi` from the value of `System.Info.os`. - -} diff --git a/cabal/changelog.d/man-command b/cabal/changelog.d/man-command deleted file mode 100644 --- a/cabal/changelog.d/man-command +++ /dev/null @@ -1,3 +0,0 @@ -synopsis: Change manpage command to man -packages: cabal-install -prs: #6548 diff --git a/cabal/changelog.d/others b/cabal/changelog.d/others deleted file mode 100644 --- a/cabal/changelog.d/others +++ /dev/null @@ -1,10 +0,0 @@ -synopsis: other changes -prs: - -- Expand elem - #6556 - - -- Add forEachGPD to hackage-tests - #6598 - - -- Add Pretty Component instance - #6910 diff --git a/cabal/changelog.d/parser-benchmark b/cabal/changelog.d/parser-benchmark deleted file mode 100644 --- a/cabal/changelog.d/parser-benchmark +++ /dev/null @@ -1,2 +0,0 @@ -synopsis: Package description parser benchmark -prs: #6594 diff --git a/cabal/changelog.d/pr-6878 b/cabal/changelog.d/pr-6878 deleted file mode 100644 --- a/cabal/changelog.d/pr-6878 +++ /dev/null @@ -1,3 +0,0 @@ -synopsis: Add `licenceIsFsfLibre` -packages: Cabal -prs: #6878 diff --git a/cabal/changelog.d/pr-6929 b/cabal/changelog.d/pr-6929 deleted file mode 100644 --- a/cabal/changelog.d/pr-6929 +++ /dev/null @@ -1,2 +0,0 @@ -synopsis: Add `+stderr` modifier to `Verbosity` -prs: #6929 diff --git a/cabal/changelog.d/pr-8261 b/cabal/changelog.d/pr-8261 new file mode 100644 --- /dev/null +++ b/cabal/changelog.d/pr-8261 @@ -0,0 +1,9 @@ +synopsis: Implement --prefer-oldest +packages: cabal-install +prs: #8261 + +description: { + +- Implement `--prefer-oldest` flag for Cabal solver, which tries to find a build plan with the oldest versions possible. This is useful to establish lower bounds. + +} diff --git a/cabal/changelog.d/pr-8309 b/cabal/changelog.d/pr-8309 new file mode 100644 --- /dev/null +++ b/cabal/changelog.d/pr-8309 @@ -0,0 +1,4 @@ +synopsis: Add documentation for cabal-install commands: user-config, +report, list, init, fetch, info, upload, get. +prs: #8309 +issues: #8308 #7884 #7978 diff --git a/cabal/changelog.d/pr-8414 b/cabal/changelog.d/pr-8414 new file mode 100644 --- /dev/null +++ b/cabal/changelog.d/pr-8414 @@ -0,0 +1,11 @@ +synopsis: Pass some haddock flags to dependencies +packages: cabal-install +prs: #8414 +issues: #8104 #395 + +description: { + +- Pass "--haddock-hoogle", "--haddock-html", "--haddock-internal", "--haddock-quickjump", "--haddock-hyperlinked-source" + to all the dependencies if they are specified as command line args + +} diff --git a/cabal/changelog.d/pr-8496 b/cabal/changelog.d/pr-8496 new file mode 100644 --- /dev/null +++ b/cabal/changelog.d/pr-8496 @@ -0,0 +1,10 @@ +synopsis: build pkgconfig db individually when bulk fails +packages: cabal-install cabal-install-solver +prs: #8496 +issues: #8494 + +description: { + +- When pkg-config fails to get versions for all packages in bulk, falls back to querying one-by-one. + +} diff --git a/cabal/changelog.d/pr-8561 b/cabal/changelog.d/pr-8561 new file mode 100644 --- /dev/null +++ b/cabal/changelog.d/pr-8561 @@ -0,0 +1,9 @@ +synopsis: cabal init -i should sanitize package name guessed from the directory name +packages: cabal-install +prs: #8561 +issues: #8404 +description: { + If the current directory name has any non-alphanumeric symbol in its name, the symbol will be replaced with a dash. Also, will make sure that the resulting package name starts with a letter. + + This worked for cabal init -n already, and this PR only moves code around so that cabal init -i also benefits from this logic. +} diff --git a/cabal/changelog.d/public-libs b/cabal/changelog.d/public-libs deleted file mode 100644 --- a/cabal/changelog.d/public-libs +++ /dev/null @@ -1,2 +0,0 @@ -synopsis: Mark public-libs as experimental feature -prs: #6605 diff --git a/cabal/changelog.d/public-libs-solver b/cabal/changelog.d/public-libs-solver deleted file mode 100644 --- a/cabal/changelog.d/public-libs-solver +++ /dev/null @@ -1,13 +0,0 @@ -synopsis: Add support for multiple public libraries to the solver -packages: cabal-install -issues: #6039 -prs: #6836 #6812 #6047 - -description: { - -cabal-install can now take into account the presence and visibility of -sublibraries when solving. This also means that, when using cabal-install, -multiple public libraries support is extended to GHCs older than 8.8. -The support is limited to source packages for now. - -} diff --git a/cabal/changelog.d/refactor-packagedescription-module b/cabal/changelog.d/refactor-packagedescription-module deleted file mode 100644 --- a/cabal/changelog.d/refactor-packagedescription-module +++ /dev/null @@ -1,9 +0,0 @@ -synopsis: Refactor Distribution.PackageDescription module -prs: #6855 -packages: Cabal - -description: { - -Now it re-exports a collection of modules, not individual symbols. - -} diff --git a/cabal/changelog.d/remove-sandbox b/cabal/changelog.d/remove-sandbox deleted file mode 100644 --- a/cabal/changelog.d/remove-sandbox +++ /dev/null @@ -1,11 +0,0 @@ -synopsis: Remove sandboxes -packages: cabal-install -prs: #6747 -issues: #6445 -significance: significant - -description: { - -Sandbox functionality is remove in favour of now default nix-style builds. - -} diff --git a/cabal/changelog.d/remove-text b/cabal/changelog.d/remove-text deleted file mode 100644 --- a/cabal/changelog.d/remove-text +++ /dev/null @@ -1,11 +0,0 @@ -synopsis: Remove text type-class -packages: cabal-install -prs: #6764 #6777 #6784 #6785 #6793 #6794 - -description: { - -`Text` type-class was removed from `Cabal`, but it still lived in `cabal-install`. -Now it is finally removed. -`cabal-install` is still using `ReadP` parsers for various things though. - -} diff --git a/cabal/changelog.d/rewriteFileLBS b/cabal/changelog.d/rewriteFileLBS deleted file mode 100644 --- a/cabal/changelog.d/rewriteFileLBS +++ /dev/null @@ -1,3 +0,0 @@ -synopsis: Add rewriteFileLBS and use it to write setup wrapper -packages: Cabal -prs: #6574 diff --git a/cabal/changelog.d/spdx b/cabal/changelog.d/spdx deleted file mode 100644 --- a/cabal/changelog.d/spdx +++ /dev/null @@ -1,3 +0,0 @@ -synopsis: Add SPDX License List 3.9 -prs: #6662 #6944 -issues: #6879 diff --git a/cabal/changelog.d/specVersion-type b/cabal/changelog.d/specVersion-type deleted file mode 100644 --- a/cabal/changelog.d/specVersion-type +++ /dev/null @@ -1,3 +0,0 @@ -synopsis: Change specVersion to have CabalSpecVersion type -packages: Cabal -prs: #6653 diff --git a/cabal/changelog.d/symlinking-windows b/cabal/changelog.d/symlinking-windows deleted file mode 100644 --- a/cabal/changelog.d/symlinking-windows +++ /dev/null @@ -1,11 +0,0 @@ -synopsis: Windows install symlinks -packages: cabal-install -prs: #5684 #6506 #6519 - -description: { - -`cabal-install` will try to infer whether symlinking is supported on Windows, -and make symlinks in `install`. Otherwise it will fallback to copying files. -Either way can be forced with `--install-method`. - -} diff --git a/cabal/changelog.d/use-process-jobs b/cabal/changelog.d/use-process-jobs deleted file mode 100644 --- a/cabal/changelog.d/use-process-jobs +++ /dev/null @@ -1,23 +0,0 @@ -synopsis: Use process jobs when spawning subprocesses -prs: #6529 #6536 - -description: { - -Many toolchain tools written for POSIX systems rely on the exec system -call. Unfortunately, it is not possible to implement exec in a -POSIX-compliant manner on Windows. In particular, the semantics of the -exec implementation provided by the widely-used msvcrt C runtime -will cause process's waiting on the exec'ing process to incorrectly -conclude that the process has successfully terminated when in fact it is -still running in another process. - -For this reason, the process library exposes the use_process_jobs -flag to use a more strict (although still not POSIX-compliant) mechanism -for tracking process completion. -This is explained in [the Process.hs comment](https://github.com/haskell/process/blob/master/System/Process.hs#L399) - -Unfortunately, job support in the process library is currently quite -broken and was only recently fixed. Consequently, we only enable job -object support for process releases >= 1.6.8. - -} diff --git a/cabal/changelog.d/utf8 b/cabal/changelog.d/utf8 deleted file mode 100644 --- a/cabal/changelog.d/utf8 +++ /dev/null @@ -1,3 +0,0 @@ -synopsis: Better UTF8 handling, parsed `ShortText` is now valid. -packages: Cabal -prs: #6588 diff --git a/cabal/changelog.d/version-range-parser b/cabal/changelog.d/version-range-parser deleted file mode 100644 --- a/cabal/changelog.d/version-range-parser +++ /dev/null @@ -1,2 +0,0 @@ -synopsis: More checks in version range parser -prs: #6586 diff --git a/cabal/changelog.d/version-type b/cabal/changelog.d/version-type deleted file mode 100644 --- a/cabal/changelog.d/version-type +++ /dev/null @@ -1,10 +0,0 @@ -synopsis: Remove `AnyVersion` and `WildcardVersion` constructors from `Version` -packages: Cabal -prs: #6742 - -description: { - -This changes makes `Version` type less "syntactic", -i.e. contains less constructors for semantically same version ranges. - -} diff --git a/cabal/changelog.d/versions-exact b/cabal/changelog.d/versions-exact deleted file mode 100644 --- a/cabal/changelog.d/versions-exact +++ /dev/null @@ -1,2 +0,0 @@ -synopsis: Require cabal-versions `>=1.25` to be exact -prs: #6654 diff --git a/cabal/changelog.d/weeder b/cabal/changelog.d/weeder deleted file mode 100644 --- a/cabal/changelog.d/weeder +++ /dev/null @@ -1,2 +0,0 @@ -synopsis: Add and use weeder -prs: #6779 #6790 diff --git a/cabal/doc/Makefile b/cabal/doc/Makefile new file mode 100644 --- /dev/null +++ b/cabal/doc/Makefile @@ -0,0 +1,50 @@ +# Build and safety-check requirements.txt + +# skjold needs a personal github access token. This needs no permissions, +# it is only required to query the GitHub GraphQL API v4. +# See: https://pythonawesome.com/security-audit-python-project-dependencies-against-security-advisory-databases/ +# We attempt to get it from the environment variable SKJOLD_GITHUB_API_TOKEN +# or GITHUB_TOKEN. +# It can also be passed to this Makefile via either: +# +# make GITHUB_TOKEN=... (build-and-)check-requirements +# make SKJOLD_GITHUB_API_TOKEN=... (build-and-)check-requirements +# +# +SKJOLD_GITHUB_API_TOKEN ?= ${GITHUB_TOKEN} + +.PHONY: build-and-check-requirements +build-and-check-requirements: requirements.txt check-requirements + +# Always rebuild requirements.txt +.PHONY: requirements.txt +# requirements.txt is generated from requirements.in +# via pip-compile included in the pip-tools package. +# See https://modelpredict.com/wht-requirements-txt-is-not-enough +requirements.txt: requirements.in + . ../.python-sphinx-virtualenv/bin/activate \ + && pip install pip-tools \ + && pip-compile requirements.in + +# Check requirements.txt for security violations via skjold, +# configured in pyproject.toml. +# See: https://pythonawesome.com/security-audit-python-project-dependencies-against-security-advisory-databases/ +.PHONY: check-requirements +check-requirements: + @if [ -z "$${SKJOLD_GITHUB_API_TOKEN}" ] \ + ; then \ + echo "WARNING: Neither SKJOLD_GITHUB_API_TOKEN nor GITHUB_TOKEN is set." \ + ; echo "Vulnerability check via skjold might fail when using the GitHub GraphQL API." \ + ; fi + . ../.python-sphinx-virtualenv/bin/activate \ + && pip install skjold \ + && skjold audit +# NB: For portability, we use '.' (sh etc.) instead of 'source' (bash). + +# Debug print environment variables +debug: + @echo "GITHUB_TOKEN = ${GITHUB_TOKEN}" + @echo "SKJOLD_GITHUB_API_TOKEN = $${SKJOLD_GITHUB_API_TOKEN}" + @echo "Is SKJOLD_GITHUB_API_TOKEN set? $${SKJOLD_GITHUB_API_TOKEN:+yes}" + +# EOF diff --git a/cabal/doc/README.md b/cabal/doc/README.md new file mode 100644 --- /dev/null +++ b/cabal/doc/README.md @@ -0,0 +1,135 @@ +Cabal documentation +=================== + +### Where to read it +These docs will be built and deployed whenever a release is made, +and can be read at: https://www.haskell.org/cabal/users-guide/ + +In addition, the docs are taken directly from git and hosted at: +http://cabal.readthedocs.io/ + + +### How to build it + +Building the documentation requires Python 3 be installed +* `> make users-guide` +* Python on Mac OS X dislikes `LC_CTYPE=UTF-8`, unset the env var in +terminal preferences and instead set `LC_ALL=en_US.UTF-8` or something + +### Gitpod workflow + +From a fork of cabal, these docs can be edited online with +[gitpod](https://www.gitpod.io/): + +* Open in gitpod https://gitpod.io/#https://github.com/username/cabal +* Install the virtual environment prerequisite. + `> sudo apt install python3.8-venv` +* Build the user guide `> make users-guide`. +* Open the guide in a local browser. + `> python -m http.server 8000 --directory=dist-newstyle/doc/users-guide` + +Make your edits, rebuild the guide and refresh the browser to preview the +changes. When happy, commit your changes with git in the included terminal. + +### Caveats, for newcomers to RST from MD +RST does not allow you to skip section levels when nesting, like MD +does. +So, you cannot have + +``` + Section heading + =============== + + Some unimportant block + """""""""""""""""""""" +``` + + instead you need to observe order and either promote your block: + +``` + Section heading + =============== + + Some not quite so important block + --------------------------------- +``` + + or introduce more subsections: + +``` + Section heading + =============== + + Subsection + ---------- + + Subsubsection + ^^^^^^^^^^^^^ + + Some unimportant block + """""""""""""""""""""" +``` + +* RST simply parses a file and interprets headings to indicate the + start of a new block, + * at the level implied by the header's *adornment*, if the adornment was + previously encountered in this file, + * at one level deeper than the previous block, otherwise. + + This means that a lot of confusion can arise when people use + different adornments to signify the same depth in different files. + + To eliminate this confusion, please stick to the adornment order + recommended by the Sphinx team: + +``` + #### + Part + #### + + ******* + Chapter + ******* + + Section + ======= + + Subsection + ---------- + + Subsubsection + ^^^^^^^^^^^^^ + + Paragraph + """"""""" +``` + +* The Read-The-Docs stylesheet does not support multiple top-level + sections in a file that is linked to from the top-most TOC (in + `index.rst`). It will mess up the sidebar. + E.g. you cannot link to a `cabal.rst` with sections "Introduction", + "Using Cabal", "Epilogue" from `index.rst`. + + One solution is to have a single section, e.g. "All About Cabal", in + `cabal.rst` and make the other blocks subsections of that. + + Another solution is to link via an indirection, e.g. create + `all-about-cabal.rst`, where you include `cabal.rst` using the + `.. toctree::` command and then link to `all-about-cabal.rst` from + `index.rst`. + This will effectively "push down" all blocks by one layer and solve + the problem without having to change `cabal.rst`. + + +* We use [`extlinks`](http://www.sphinx-doc.org/en/stable/ext/extlinks.html) + to shorten links to commonly referred resources (wiki, issue trackers). + + E.g. you can use the more convenient short syntax + + :issue:`123` + + which is expanded into a hyperlink + + `#123 `__ + + See `conf.py` for list of currently defined link shorteners. diff --git a/cabal/doc/_templates/layout.html b/cabal/doc/_templates/layout.html new file mode 100644 --- /dev/null +++ b/cabal/doc/_templates/layout.html @@ -0,0 +1,8 @@ +{% extends "!layout.html" %} + +{% block menu %} + {{ super() }} + Reference + Index +{% endblock %} + diff --git a/cabal/doc/bugs-and-stability.rst b/cabal/doc/bugs-and-stability.rst new file mode 100644 --- /dev/null +++ b/cabal/doc/bugs-and-stability.rst @@ -0,0 +1,6 @@ +Reporting Bugs and Stability of Cabal Interfaces +================================================ + +.. toctree:: + misc + diff --git a/cabal/doc/buildinfo-fields-reference.rst b/cabal/doc/buildinfo-fields-reference.rst new file mode 100644 --- /dev/null +++ b/cabal/doc/buildinfo-fields-reference.rst @@ -0,0 +1,677 @@ +.. _buildinfo-field-reference: + +Field Syntax Reference +====================== + +Notation +--------------- + +Field syntax is described as they are in the latest cabal file format version. + +* terminals are enclosed in quotes and type set in typewriter script: + + .. math:: + + \mathord{"}\mathtt{example}\mathord{"} + +* non-terminals are type set in italic: + + .. math:: + + \mathit{version\text-range} + +* character sets are type set resembling regular expression notation: + + + .. math:: + + [ \mathord{"}\mathtt{1}\mathord{"} \cdots \mathord{"}\mathtt{9}\mathord{"} ] + + Character set complements have :math:`c` superscript: + + .. math:: + + [ \mathord{"}\mathtt{1}\mathord{"} \cdots \mathord{"}\mathtt{9}\mathord{"} ]^c + +* repetition is type set using regular expression inspired notation. + Superscripts tell how many time to repeat: + The generic notation is :math:`\in[n\ldots5]`, however there + are common shorthands: + :math:`\ast` for :math:`\in[0\ldots\infty]` (``many``), + :math:`+` for :math:`\in[1\ldots\infty]` (``some``), + :math:`?` for :math:`\in[0\ldots1]` (``optional``). + + Subscripts tell the used separator: + + .. math:: + + \mathit{digit}^+_{\mathord{"}\mathtt{.}\mathord{"}} + + Would be ``digit(\.digit)*`` in common regex syntax. + +* alternatives are listed in braces separated by vertical bar: + + .. math:: + + \{ \mathit{foo} \mid \mathit{bar} \} + + In case of multiple alternatives, the stacked notation is used + + .. math:: + + \left\{\begin{gathered} + \mathit{one} \\ + \mathit{two} \\ + \mathit{three} \\ + \mathit{four} \\ + \mathit{five} + \end{gathered}\right\} + +* parenthesis are used only for grouping: + + .. math:: + + \left(\mathit{foo} \mid \mathit{bar}\right)^+ + +* any amount of spaces, and at least single space are type set using + :math:`\circ` and :math:`\bullet` respectively. + They may appear standalone, not only as binary operators. + + .. math:: + + \mathit{module} \bullet \mathord{``}\mathtt{as}\mathord{"} \bullet \mathit{module} + +* While notation is heavily regular expression inspired, there + are also fixed points, which allow represent recursive grammars + + + .. math:: + + \mathbf{fix}\; \mathit{expr}\; \mathbf{in}\; \mathit{digit} + \mid \mathit{expr} \circ \mathord{``}\mathtt{+}\mathord{"} \circ \mathit{expr} + \mid \mathord{``}\mathtt{(} \mathord{"} \circ \mathit{expr} \circ \mathord{``}\mathtt{)}\mathord{"} + +Lists +----- + +Many fields in cabal file format are lists. There are three variations: + +Space separated + Are used for lists of things with simple grammars, for example :pkg-field:`ghc-options` + + .. math:: + {\mathop{\mathit{element}}}^\ast_{\bullet} + +Comma separated + Are used for lists of things with complicated grammars, for example :pkg-field:`build-depends` + There can be leading or trailing comma (but not both) since ``cabal-version: 2.2``. + Note, the comma cannot exist alone. + + .. math:: + \mathrm{commalist}(\mathit{element}) = + \left\{ {\mathop{\mathit{element}}}^\ast_{\left(\circ\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}\circ\right)}\mid\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}\circ{\mathop{\mathit{element}}}^+_{\left(\circ\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}\circ\right)}\mid{\mathop{\mathit{element}}}^+_{\left(\circ\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}\circ\right)}\circ\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}} \right\} + +Optional comma separated + Surprisingly many fields can have optional comma separator. + Since ``cabal-version: 3.0`` comma usage have to be consistent, + in other words either used everywhere or nowhere. + It's recommended to avoid using comma in these fields, + an example field is :pkg-field:`default-extensions`. + + .. math:: + \mathrm{optcommalist}(\mathit{element}) = + \left\{ \begin{gathered}{\mathop{\mathit{element}}}^\ast_{\bullet}\\{\mathop{\mathit{element}}}^\ast_{\left(\circ\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}\circ\right)}\\\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}\circ{\mathop{\mathit{element}}}^+_{\left(\circ\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}\circ\right)}\\{\mathop{\mathit{element}}}^+_{\left(\circ\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}\circ\right)}\circ\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}\end{gathered} \right\} + +Non-terminals +------------- + +In the syntax definitions below the following non-terminal symbols are used: + +hs-string + String as in Haskell; it's recommended to avoid using Haskell-specific escapes. + + .. math:: + \mathop{\mathord{``}\mathtt{\text{"}}\mathord{"}}{\left\{ {[\mathop{\mathord{``}\mathtt{\text{"}}\mathord{"}}\mathop{\mathord{``}\mathtt{\text{\\}}\mathord{"}}]^c}\mid\left\{ \begin{gathered}\mathop{\mathord{``}\mathtt{\text{\\}\text{&}}\mathord{"}}\\\mathop{\mathord{``}\mathtt{\text{\\}\text{\\}}\mathord{"}}\\\left\{ \mathop{\mathord{``}\mathtt{\text{\\}n}\mathord{"}}\mid\mathop{\mathit{escapes}} \right\}\\\mathop{\mathord{``}\mathtt{\text{\\}}\mathord{"}}[\mathop{\mathord{``}\mathtt{0}\mathord{"}}\cdots\mathop{\mathord{``}\mathtt{9}\mathord{"}}]\\\mathop{\mathord{``}\mathtt{\text{\\}o}\mathord{"}}[\mathop{\mathord{``}\mathtt{0}\mathord{"}}\cdots\mathop{\mathord{``}\mathtt{7}\mathord{"}}]\\\mathop{\mathord{``}\mathtt{\text{\\}x}\mathord{"}}[\mathop{\mathord{``}\mathtt{0}\mathord{"}}\cdots\mathop{\mathord{``}\mathtt{9}\mathord{"}}\mathop{\mathord{``}\mathtt{A}\mathord{"}}\cdots\mathop{\mathord{``}\mathtt{F}\mathord{"}}\mathop{\mathord{``}\mathtt{a}\mathord{"}}\cdots\mathop{\mathord{``}\mathtt{f}\mathord{"}}]\\\left\{ \mathop{\mathord{``}\mathtt{\text{\\}\text{^}\text{@}}\mathord{"}}\mid\mathop{\mathit{control}} \right\}\\\left\{ \mathop{\mathord{``}\mathtt{\text{\\}NUL}\mathord{"}}\mid\mathop{\mathit{ascii}} \right\}\end{gathered} \right\} \right\}}^\ast_{}\mathop{\mathord{``}\mathtt{\text{"}}\mathord{"}} + +unqual-name + Unqualified component names are used for package names, component names etc. but not flag names. Unqualified component name consist of components separated by dash, each component is non-empty alphanumeric string, with at least one alphabetic character. In other words, component may not look like a number. + + .. math:: + {\left({\mathop{\mathit{alpha\text{-}num}}}^\ast_{}\mathop{\mathit{alpha}}{\mathop{\mathit{alpha\text{-}num}}}^\ast_{}\right)}^+_{\mathop{\mathord{``}\mathtt{\text{-}}\mathord{"}}} + +module-name + Haskell module name as recognized by Cabal parser. + + .. math:: + {\left(\mathop{\mathit{upper}}{\left\{ \mathop{\mathit{alpha\text{-}num}}\mid[\mathop{\mathord{``}\mathtt{\text{'}}\mathord{"}}\mathop{\mathord{``}\mathtt{\text{_}}\mathord{"}}] \right\}}^\ast_{}\right)}^+_{\mathop{\mathord{``}\mathtt{\text{.}}\mathord{"}}} + +version + Version is to first approximation numbers separated by dots, where leading zero is not allowed and each version digit is consists at most of nine characters. + + .. math:: + {\left\{ \mathop{\mathord{``}\mathtt{0}\mathord{"}}\mid[\mathop{\mathord{``}\mathtt{1}\mathord{"}}\cdots\mathop{\mathord{``}\mathtt{9}\mathord{"}}]{[\mathop{\mathord{``}\mathtt{0}\mathord{"}}\cdots\mathop{\mathord{``}\mathtt{9}\mathord{"}}]}^{\in [0\ldots8]}_{} \right\}}^+_{\mathop{\mathord{``}\mathtt{\text{.}}\mathord{"}}} + +version-range + Version range syntax is recursive. Also note the set syntax added in ``cabal-version: 3.0``, set cannot be empty. + + .. math:: + \mathbf{fix}\;\mathop{\mathit{version\text{-}range}}\;\mathbf{in}\;\left\{ \begin{gathered}\mathop{\mathord{``}\mathtt{\text{=}\text{=}}\mathord{"}}\circ\mathop{\mathit{version}}\\\mathop{\mathord{``}\mathtt{\text{>}}\mathord{"}}\circ\mathop{\mathit{version}}\\\mathop{\mathord{``}\mathtt{\text{<}}\mathord{"}}\circ\mathop{\mathit{version}}\\\mathop{\mathord{``}\mathtt{\text{<}\text{=}}\mathord{"}}\circ\mathop{\mathit{version}}\\\mathop{\mathord{``}\mathtt{\text{>}\text{=}}\mathord{"}}\circ\mathop{\mathit{version}}\\\mathop{\mathord{``}\mathtt{\text{^}\text{>}\text{=}}\mathord{"}}\circ\mathop{\mathit{version}}\\\mathop{\mathord{``}\mathtt{\text{=}\text{=}}\mathord{"}}\circ{\left\{ \mathop{\mathord{``}\mathtt{0}\mathord{"}}\mid[\mathop{\mathord{``}\mathtt{1}\mathord{"}}\cdots\mathop{\mathord{``}\mathtt{9}\mathord{"}}]{[\mathop{\mathord{``}\mathtt{0}\mathord{"}}\cdots\mathop{\mathord{``}\mathtt{9}\mathord{"}}]}^{\in [0\ldots8]}_{} \right\}}^+_{\mathop{\mathord{``}\mathtt{\text{.}}\mathord{"}}}\mathop{\mathord{``}\mathtt{\text{.}\text{*}}\mathord{"}}\\\mathop{\mathit{version\text{-}range}}\circ\mathop{\mathord{``}\mathtt{\text{|}\text{|}}\mathord{"}}\circ\mathop{\mathit{version\text{-}range}}\\\mathop{\mathit{version\text{-}range}}\circ\mathop{\mathord{``}\mathtt{\text{&}\text{&}}\mathord{"}}\circ\mathop{\mathit{version\text{-}range}}\\\mathop{\mathord{``}\mathtt{\text{(}}\mathord{"}}\circ\mathop{\mathit{version\text{-}range}}\circ\mathop{\mathord{``}\mathtt{\text{)}}\mathord{"}}\\\mathop{\mathord{``}\mathtt{\text{=}\text{=}}\mathord{"}}\circ\mathop{\mathord{``}\mathtt{\{}\mathord{"}}\circ{\mathop{\mathit{version}}}^+_{\left(\circ\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}\circ\right)}\circ\mathop{\mathord{``}\mathtt{\}}\mathord{"}}\\\mathop{\mathord{``}\mathtt{\text{^}\text{>}\text{=}}\mathord{"}}\circ\mathop{\mathord{``}\mathtt{\{}\mathord{"}}\circ{\mathop{\mathit{version}}}^+_{\left(\circ\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}\circ\right)}\circ\mathop{\mathord{``}\mathtt{\}}\mathord{"}}\end{gathered} \right\} + + +Build info fields +----------------- + +asm-options + * Monoidal field + * Available since ``cabal-version: 3.0``. + * Documentation of :pkg-field:`asm-options` + + .. math:: + {\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}]^c}}^+_{} \right\}}^\ast_{\bullet} + +asm-sources + * Monoidal field + * Available since ``cabal-version: 3.0``. + * Documentation of :pkg-field:`asm-sources` + + .. math:: + \mathrm{commalist}\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}]^c}}^+_{} \right\} + +autogen-includes + * Monoidal field + * Available since ``cabal-version: 3.0``. + * Documentation of :pkg-field:`autogen-includes` + + .. math:: + \mathrm{optcommalist}\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}]^c}}^+_{} \right\} + +autogen-modules + * Monoidal field + * Available since ``cabal-version: 2.0``. + * Documentation of :pkg-field:`autogen-modules` + + .. math:: + \mathrm{commalist}\left({\left(\mathop{\mathit{upper}}{\left\{ \mathop{\mathit{alpha\text{-}num}}\mid[\mathop{\mathord{``}\mathtt{\text{'}}\mathord{"}}\mathop{\mathord{``}\mathtt{\text{_}}\mathord{"}}] \right\}}^\ast_{}\right)}^+_{\mathop{\mathord{``}\mathtt{\text{.}}\mathord{"}}}\right) + +build-depends + * Monoidal field + * Documentation of :pkg-field:`build-depends` + + .. math:: + \mathrm{commalist}\left(\mathop{\mathit{pkg\text{-}name}}{\left(\mathop{\mathord{``}\mathtt{\text{:}}\mathord{"}}\left\{ \mathop{\mathit{unqual\text{-}name}}\mid\mathop{\mathord{``}\mathtt{\{}\mathord{"}}\circ{\mathop{\mathit{unqual\text{-}name}}}^+_{\left(\circ\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}\circ\right)}\circ\mathop{\mathord{``}\mathtt{\}}\mathord{"}} \right\}\right)}^?{\left(\circ\mathop{\mathit{version\text{-}range}}\right)}^?\right) + +build-tool-depends + * Monoidal field + * Documentation of :pkg-field:`build-tool-depends` + + .. math:: + \mathrm{commalist}\mathsf{\color{red}{TODO}} + +build-tools + * Monoidal field + * Deprecated since ``cabal-version: 2.0``: Please use 'build-tool-depends' field + * Removed in ``cabal-version: 3.0``: Please use 'build-tool-depends' field. + + .. math:: + \mathrm{commalist}\mathsf{\color{red}{TODO}} + +buildable + * Boolean field + * Default: ``True`` + * Documentation of :pkg-field:`buildable` + + .. math:: + \left\{ \mathop{\mathord{``}\mathtt{True}\mathord{"}}\mid\mathop{\mathord{``}\mathtt{False}\mathord{"}} \right\} + +c-sources + * Monoidal field + * Documentation of :pkg-field:`c-sources` + + .. math:: + \mathrm{commalist}\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}]^c}}^+_{} \right\} + +cc-options + * Monoidal field + * Documentation of :pkg-field:`cc-options` + + .. math:: + {\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}]^c}}^+_{} \right\}}^\ast_{\bullet} + +cmm-options + * Monoidal field + * Available since ``cabal-version: 3.0``. + * Documentation of :pkg-field:`cmm-options` + + .. math:: + {\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}]^c}}^+_{} \right\}}^\ast_{\bullet} + +cmm-sources + * Monoidal field + * Available since ``cabal-version: 3.0``. + * Documentation of :pkg-field:`cmm-sources` + + .. math:: + \mathrm{commalist}\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}]^c}}^+_{} \right\} + +cpp-options + * Monoidal field + * Documentation of :pkg-field:`cpp-options` + + .. math:: + {\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}]^c}}^+_{} \right\}}^\ast_{\bullet} + +cxx-options + * Monoidal field + * Available since ``cabal-version: 2.2``. + * Documentation of :pkg-field:`cxx-options` + + .. math:: + {\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}]^c}}^+_{} \right\}}^\ast_{\bullet} + +cxx-sources + * Monoidal field + * Available since ``cabal-version: 2.2``. + * Documentation of :pkg-field:`cxx-sources` + + .. math:: + \mathrm{commalist}\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}]^c}}^+_{} \right\} + +default-extensions + * Monoidal field + * Available since ``cabal-version: 1.10``. + * Documentation of :pkg-field:`default-extensions` + + .. math:: + \mathrm{optcommalist}\mathsf{\color{red}{TODO}} + +default-language + * Optional field + * Available since ``cabal-version: 1.10``. + * Documentation of :pkg-field:`default-language` + + .. math:: + \left\{ \mathop{\mathord{``}\mathtt{Haskell98}\mathord{"}}\mid\mathop{\mathord{``}\mathtt{Haskell2010}\mathord{"}} \right\} + +extensions + * Monoidal field + * Deprecated since ``cabal-version: 1.12``: Please use 'default-extensions' or 'other-extensions' fields. + * Removed in ``cabal-version: 3.0``: Please use 'default-extensions' or 'other-extensions' fields. + + .. math:: + \mathrm{optcommalist}\mathsf{\color{red}{TODO}} + +extra-bundled-libraries + * Monoidal field + * Documentation of :pkg-field:`extra-bundled-libraries` + + .. math:: + \mathrm{commalist}\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}]^c}}^+_{} \right\} + +extra-dynamic-library-flavours + * Monoidal field + * Available since ``cabal-version: 3.0``. + * Documentation of :pkg-field:`extra-dynamic-library-flavours` + + .. math:: + \mathrm{commalist}\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}]^c}}^+_{} \right\} + +extra-framework-dirs + * Monoidal field + * Documentation of :pkg-field:`extra-framework-dirs` + + .. math:: + \mathrm{optcommalist}\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}]^c}}^+_{} \right\} + +extra-ghci-libraries + * Monoidal field + * Documentation of :pkg-field:`extra-ghci-libraries` + + .. math:: + \mathrm{commalist}\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}]^c}}^+_{} \right\} + +extra-lib-dirs + * Monoidal field + * Documentation of :pkg-field:`extra-lib-dirs` + + .. math:: + \mathrm{optcommalist}\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}]^c}}^+_{} \right\} + +extra-lib-dirs-static + * Monoidal field + * Documentation of :pkg-field:`extra-lib-dirs-static` + + .. math:: + \mathrm{optcommalist}\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}]^c}}^+_{} \right\} + +extra-libraries + * Monoidal field + * Documentation of :pkg-field:`extra-libraries` + + .. math:: + \mathrm{commalist}\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}]^c}}^+_{} \right\} + +extra-library-flavours + * Monoidal field + * Documentation of :pkg-field:`extra-library-flavours` + + .. math:: + \mathrm{commalist}\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}]^c}}^+_{} \right\} + +extra-libraries + * Monoidal field + * Documentation of :pkg-field:`extra-libraries-static` + + .. math:: + \mathrm{commalist}\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}]^c}}^+_{} \right\} + +frameworks + * Monoidal field + * Documentation of :pkg-field:`frameworks` + + .. math:: + \mathrm{optcommalist}\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}]^c}}^+_{} \right\} + +ghc-options + * Monoidal field + * Documentation of :pkg-field:`ghc-options` + + .. math:: + {\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}]^c}}^+_{} \right\}}^\ast_{\bullet} + +ghc-prof-options + * Monoidal field + * Documentation of :pkg-field:`ghc-prof-options` + + .. math:: + {\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}]^c}}^+_{} \right\}}^\ast_{\bullet} + +ghc-shared-options + * Monoidal field + * Documentation of :pkg-field:`ghc-shared-options` + + .. math:: + {\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}]^c}}^+_{} \right\}}^\ast_{\bullet} + +ghcjs-options + * Monoidal field + * Documentation of :pkg-field:`ghcjs-options` + + .. math:: + {\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}]^c}}^+_{} \right\}}^\ast_{\bullet} + +ghcjs-prof-options + * Monoidal field + * Documentation of :pkg-field:`ghcjs-prof-options` + + .. math:: + {\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}]^c}}^+_{} \right\}}^\ast_{\bullet} + +ghcjs-shared-options + * Monoidal field + * Documentation of :pkg-field:`ghcjs-shared-options` + + .. math:: + {\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}]^c}}^+_{} \right\}}^\ast_{\bullet} + +hs-source-dir + * Monoidal field + * Deprecated since ``cabal-version: 1.2``: Please use 'hs-source-dirs' + * Removed in ``cabal-version: 3.0``: Please use 'hs-source-dirs' field. + + .. math:: + \mathrm{optcommalist}\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}]^c}}^+_{} \right\} + +hs-source-dirs + * Monoidal field + * Documentation of :pkg-field:`hs-source-dirs` + + .. math:: + \mathrm{optcommalist}\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}]^c}}^+_{} \right\} + +include-dirs + * Monoidal field + * Documentation of :pkg-field:`include-dirs` + + .. math:: + \mathrm{optcommalist}\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}]^c}}^+_{} \right\} + +includes + * Monoidal field + * Documentation of :pkg-field:`includes` + + .. math:: + \mathrm{optcommalist}\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}]^c}}^+_{} \right\} + +install-includes + * Monoidal field + * Documentation of :pkg-field:`install-includes` + + .. math:: + \mathrm{optcommalist}\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}]^c}}^+_{} \right\} + +js-sources + * Monoidal field + * Documentation of :pkg-field:`js-sources` + + .. math:: + \mathrm{commalist}\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}]^c}}^+_{} \right\} + +ld-options + * Monoidal field + * Documentation of :pkg-field:`ld-options` + + .. math:: + {\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}]^c}}^+_{} \right\}}^\ast_{\bullet} + +mixins + * Monoidal field + * Available since ``cabal-version: 2.0``. + * Documentation of :pkg-field:`mixins` + + .. math:: + \mathrm{commalist}\left(\mathop{\mathit{package\text{-}name}}{\left(\mathop{\mathord{``}\mathtt{\text{:}}\mathord{"}}\mathop{\mathit{library\text{-}name}}\right)}^?{\left(\bullet\left\{ \mid\mathop{\mathord{``}\mathtt{hiding}\mathord{"}}\circ\mathop{\mathord{``}\mathtt{\text{(}}\mathord{"}}\circ{\mathop{\mathit{module\text{-}name}}}^\ast_{\left(\circ\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}\circ\right)}\circ\mathop{\mathord{``}\mathtt{\text{)}}\mathord{"}}\mid\mathop{\mathord{``}\mathtt{\text{(}}\mathord{"}}\circ{\left(\mathop{\mathit{module\text{-}name}}{\left(\bullet\mathop{\mathord{``}\mathtt{as}\mathord{"}}\bullet\mathop{\mathit{module\text{-}name}}\right)}^?\right)}^\ast_{\left(\circ\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}\circ\right)}\circ\mathop{\mathord{``}\mathtt{\text{)}}\mathord{"}} \right\}{\left(\circ\mathop{\mathord{``}\mathtt{requires}\mathord{"}}\bullet\left\{ \mid\mathop{\mathord{``}\mathtt{hiding}\mathord{"}}\circ\mathop{\mathord{``}\mathtt{\text{(}}\mathord{"}}\circ{\mathop{\mathit{module\text{-}name}}}^\ast_{\left(\circ\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}\circ\right)}\circ\mathop{\mathord{``}\mathtt{\text{)}}\mathord{"}}\mid\mathop{\mathord{``}\mathtt{\text{(}}\mathord{"}}\circ{\left(\mathop{\mathit{module\text{-}name}}{\left(\bullet\mathop{\mathord{``}\mathtt{as}\mathord{"}}\bullet\mathop{\mathit{module\text{-}name}}\right)}^?\right)}^\ast_{\left(\circ\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}\circ\right)}\circ\mathop{\mathord{``}\mathtt{\text{)}}\mathord{"}} \right\}\right)}^?\right)}^?\right) + +other-extensions + * Monoidal field + * Available since ``cabal-version: 1.10``. + * Documentation of :pkg-field:`other-extensions` + + .. math:: + \mathrm{optcommalist}\mathsf{\color{red}{TODO}} + +other-languages + * Monoidal field + * Available since ``cabal-version: 1.10``. + * Documentation of :pkg-field:`other-languages` + + .. math:: + \mathrm{optcommalist}\left\{ \mathop{\mathord{``}\mathtt{Haskell98}\mathord{"}}\mid\mathop{\mathord{``}\mathtt{Haskell2010}\mathord{"}} \right\} + +other-modules + * Monoidal field + * Documentation of :pkg-field:`other-modules` + + .. math:: + \mathrm{commalist}\left({\left(\mathop{\mathit{upper}}{\left\{ \mathop{\mathit{alpha\text{-}num}}\mid[\mathop{\mathord{``}\mathtt{\text{'}}\mathord{"}}\mathop{\mathord{``}\mathtt{\text{_}}\mathord{"}}] \right\}}^\ast_{}\right)}^+_{\mathop{\mathord{``}\mathtt{\text{.}}\mathord{"}}}\right) + +pkgconfig-depends + * Monoidal field + * Documentation of :pkg-field:`pkgconfig-depends` + + .. math:: + \mathrm{commalist}\mathsf{\color{red}{TODO}} + +virtual-modules + * Monoidal field + * Available since ``cabal-version: 2.2``. + * Documentation of :pkg-field:`virtual-modules` + + .. math:: + \mathrm{commalist}\left({\left(\mathop{\mathit{upper}}{\left\{ \mathop{\mathit{alpha\text{-}num}}\mid[\mathop{\mathord{``}\mathtt{\text{'}}\mathord{"}}\mathop{\mathord{``}\mathtt{\text{_}}\mathord{"}}] \right\}}^\ast_{}\right)}^+_{\mathop{\mathord{``}\mathtt{\text{.}}\mathord{"}}}\right) + + +Library fields +-------------- + +visibility + * Optional field + * Documentation of :pkg-field:`library:visibility` + + .. math:: + \left\{ \mathop{\mathord{``}\mathtt{public}\mathord{"}}\mid\mathop{\mathord{``}\mathtt{private}\mathord{"}} \right\} + + +Package description fields +-------------------------- + +author + * Free text field + * Documentation of :pkg-field:`author` + +bug-reports + * Free text field + * Documentation of :pkg-field:`bug-reports` + +build-type + * Optional field + * Documentation of :pkg-field:`build-type` + + .. math:: + \left\{ \begin{gathered}\mathop{\mathord{``}\mathtt{Simple}\mathord{"}}\\\mathop{\mathord{``}\mathtt{Configure}\mathord{"}}\\\mathop{\mathord{``}\mathtt{Custom}\mathord{"}}\\\mathop{\mathord{``}\mathtt{Make}\mathord{"}}\\\mathop{\mathord{``}\mathtt{Default}\mathord{"}}\end{gathered} \right\} + +cabal-version + * Optional field + * Default: ``>=1.0`` + * Documentation of :pkg-field:`cabal-version` + + .. math:: + \mathop{\mathord{``}\mathtt{3\text{.}4}\mathord{"}} + +category + * Free text field + * Documentation of :pkg-field:`category` + +copyright + * Free text field + * Documentation of :pkg-field:`copyright` + +data-dir + * Optional field + * Default: ``""`` + * Documentation of :pkg-field:`data-dir` + + .. math:: + \left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}]^c}}^+_{} \right\} + +data-files + * Monoidal field + * Documentation of :pkg-field:`data-files` + + .. math:: + \mathrm{commalist}\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}]^c}}^+_{} \right\} + +description + * Free text field + * Documentation of :pkg-field:`description` + +extra-doc-files + * Monoidal field + * Documentation of :pkg-field:`extra-doc-files` + + .. math:: + \mathrm{commalist}\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}]^c}}^+_{} \right\} + +extra-source-files + * Monoidal field + * Documentation of :pkg-field:`extra-source-files` + + .. math:: + \mathrm{commalist}\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}]^c}}^+_{} \right\} + +extra-tmp-files + * Monoidal field + * Documentation of :pkg-field:`extra-tmp-files` + + .. math:: + \mathrm{commalist}\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}]^c}}^+_{} \right\} + +homepage + * Free text field + * Documentation of :pkg-field:`homepage` + +license + * Optional field + * Default: ``NONE`` + * Documentation of :pkg-field:`license` + + .. math:: + \mathsf{\color{red}{TODO}} + +license-file + * Monoidal field + * Documentation of :pkg-field:`license-file` + + .. math:: + \mathrm{optcommalist}\left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}]^c}}^+_{} \right\} + +maintainer + * Free text field + * Documentation of :pkg-field:`maintainer` + +name + * Required field + * Documentation of :pkg-field:`name` + + .. math:: + \mathop{\mathit{unqual\text{-}name}} + +package-url + * Free text field + * Documentation of :pkg-field:`package-url` + +stability + * Free text field + * Documentation of :pkg-field:`stability` + +synopsis + * Free text field + * Documentation of :pkg-field:`synopsis` + +tested-with + * Monoidal field + * Documentation of :pkg-field:`tested-with` + + .. math:: + \mathrm{optcommalist}\mathsf{\color{red}{TODO}} + +version + * Required field + * Documentation of :pkg-field:`version` + + .. math:: + {\left\{ \mathop{\mathord{``}\mathtt{0}\mathord{"}}\mid[\mathop{\mathord{``}\mathtt{1}\mathord{"}}\cdots\mathop{\mathord{``}\mathtt{9}\mathord{"}}]{[\mathop{\mathord{``}\mathtt{0}\mathord{"}}\cdots\mathop{\mathord{``}\mathtt{9}\mathord{"}}]}^{\in [0\ldots8]}_{} \right\}}^+_{\mathop{\mathord{``}\mathtt{\text{.}}\mathord{"}}} + + +Test-suite fields +----------------- + +main-is + * Optional field + * Documentation of :pkg-field:`test-suite:main-is` + + .. math:: + \left\{ \mathop{\mathit{hs\text{-}string}}\mid{{[\mathop{\mathord{``}\mathtt{\ }\mathord{"}}\mathop{\mathord{``}\mathtt{\text{,}}\mathord{"}}]^c}}^+_{} \right\} + +test-module + * Optional field + * Documentation of :pkg-field:`test-suite:test-module` + + .. math:: + {\left(\mathop{\mathit{upper}}{\left\{ \mathop{\mathit{alpha\text{-}num}}\mid[\mathop{\mathord{``}\mathtt{\text{'}}\mathord{"}}\mathop{\mathord{``}\mathtt{\text{_}}\mathord{"}}] \right\}}^\ast_{}\right)}^+_{\mathop{\mathord{``}\mathtt{\text{.}}\mathord{"}}} + +type + * Optional field + * Documentation of :pkg-field:`test-suite:type` + + .. math:: + \left\{ \mathop{\mathord{``}\mathtt{exitcode\text{-}stdio\text{-}1\text{.}0}\mathord{"}}\mid\mathop{\mathord{``}\mathtt{detailed\text{-}0\text{.}9}\mathord{"}} \right\} diff --git a/cabal/doc/cabal-commands.rst b/cabal/doc/cabal-commands.rst new file mode 100644 --- /dev/null +++ b/cabal/doc/cabal-commands.rst @@ -0,0 +1,970 @@ +Commands +======== + +``cabal help`` groups commands into global, package, new-style project and +legacy sections. We talk in detail about some global and package commands. + +:: + + $ cabal help + Command line interface to the Haskell Cabal infrastructure. + + See http://www.haskell.org/cabal/ for more information. + + Usage: cabal [GLOBAL FLAGS] [COMMAND [FLAGS]] + + Commands: + [global] + update Updates list of known packages. + install Install packages. + help Help about commands. + + [package] + configure Add extra project configuration. + build Compile targets within the project. + clean Clean the package store and remove temporary files. + + run Run an executable. + repl Open an interactive session for the given component. + test Run test-suites. + bench Run benchmarks. + + sdist Generate a source distribution file (.tar.gz). + + freeze Freeze dependencies. + haddock Build Haddock documentation. + exec Give a command access to the store. + list-bin List path to a single executable. + + [new-style projects (forwards-compatible aliases)] + Since cabal-install-3.0.0.0, all 'v2-' prefixed names of commands are just aliases for the simple unprefixed names. + So v2-build is an alias for build, v2-install for install and so on. + + [legacy command aliases] + No legacy commands are described. + +Common Arguments and Flags +-------------------------- + +Arguments and flags common to some or all commands are: + + +.. option:: --default-user-config=file + + Allows a "default" ``cabal.config`` freeze file to be passed in + manually. This file will only be used if one does not exist in the + project directory already. Typically, this can be set from the + global cabal ``config`` file so as to provide a default set of + partial constraints to be used by projects, providing a way for + users to peg themselves to stable package collections. + + +.. option:: --allow-newer[=pkgs], --allow-older[=pkgs] + + Selectively relax upper or lower bounds in dependencies without + editing the package description respectively. + + The following description focuses on upper bounds and the + :option:`--allow-newer` flag, but applies analogously to + :option:`--allow-older` and lower bounds. :option:`--allow-newer` + and :option:`--allow-older` can be used at the same time. + + If you want to install a package A that depends on B >= 1.0 && < + 2.0, but you have the version 2.0 of B installed, you can compile A + against B 2.0 by using ``cabal install --allow-newer=B A``. This + works for the whole package index: if A also depends on C that in + turn depends on B < 2.0, C's dependency on B will be also relaxed. + + Example: + + :: + + $ cd foo + $ cabal configure + Resolving dependencies... + cabal: Could not resolve dependencies: + [...] + $ cabal configure --allow-newer + Resolving dependencies... + Configuring foo... + + Additional examples: + + :: + + # Relax upper bounds in all dependencies. + $ cabal install --allow-newer foo + + # Relax upper bounds only in dependencies on bar, baz and quux. + $ cabal install --allow-newer=bar,baz,quux foo + + # Relax the upper bound on bar and force bar==2.1. + $ cabal install --allow-newer=bar --constraint="bar==2.1" foo + + It's also possible to limit the scope of :option:`--allow-newer` to single + packages with the ``--allow-newer=scope:dep`` syntax. This means + that the dependency on ``dep`` will be relaxed only for the package + ``scope``. + + Example: + + :: + + # Relax upper bound in foo's dependency on base; also relax upper bound in + # every package's dependency on lens. + $ cabal install --allow-newer=foo:base,lens + + # Relax upper bounds in foo's dependency on base and bar's dependency + # on time; also relax the upper bound in the dependency on lens specified by + # any package. + $ cabal install --allow-newer=foo:base,lens --allow-newer=bar:time + + Finally, one can enable :option:`--allow-newer` permanently by setting + ``allow-newer: True`` in the ``~/.cabal/config`` file. Enabling + 'allow-newer' selectively is also supported in the config file + (``allow-newer: foo, bar, baz:base``). + +.. option:: --preference=preference + + Specify a soft constraint on versions of a package. The solver will + attempt to satisfy these preferences on a "best-effort" basis. + +.. option:: --enable-build-info + + Generate accurate build information for build components. + + Information contains meta information, such as component type, compiler type, and + Cabal library version used during the build, but also fine grained information, + such as dependencies, what modules are part of the component, etc... + + On build, a file ``build-info.json`` (in the ``json`` format) will be written to + the root of the build directory. + + .. note:: + The format and fields of the generated build information is currently + experimental. In the future we might add or remove fields, depending + on the needs of other tooling. + + .. code-block:: json + + { + "cabal-lib-version": "", + "compiler": { + "flavour": "", + "compiler-id": "", + "path": "" + }, + "components": [ + { + "type": "", + "name": "", + "unit-id": "", + "compiler-args": [ + "" + ], + "modules": [ + "" + ], + "src-files": [ + "" + ], + "hs-src-dirs": [ + "" + ], + "src-dir": "", + "cabal-file": "" + } + ] + } + + .. jsonschema:: ./json-schemas/build-info.schema.json + +.. option:: --disable-build-info + + (default) Do not generate detailed build information for built components. + + Already generated `build-info.json` files will be removed since they would be stale otherwise. + +cabal init +---------- + +``cabal init [FLAGS]`` initialises a Cabal package, picking +reasonable defaults. Run it in your project folder. + +.. option:: -i, --interactive + + Enable interactive mode. + +.. option:: -m, --minimal + + Generate a short .cabal file, without extra empty fields or + explanatory comments. + +See :ref:`init quickstart` for an overview on the command, and +``cabal init --help`` for the complete list of options. + +cabal list-bin +-------------- + +``cabal list-bin`` will either (a) display the path for a single executable or (b) +complain that the target doesn't resolve to a single binary. In the latter case, +it will name the binary products contained in the package. These products can +be used to narrow the search and get an actual path to a particular executable. + +Example showing a failure to resolve to a single executable. + +:: + + $ cabal list-bin cabal-install + cabal: The list-bin command is for finding a single binary at once. The + target 'cabal-install' refers to the package cabal-install-#.#.#.# which + includes the executable 'cabal', the test suite 'unit-tests', the test suite + 'mem-use-tests', the test suite 'long-tests' and the test suite + 'integration-tests2'. + +For a scope that results in only one item we'll get a path. + +:: + + $ cabal list-bin cabal-install:exes + /.../dist-newstyle/build/.../cabal/cabal + + $ cabal list-bin cabal-install:cabal + /.../dist-newstyle/build/.../cabal/cabal + +We can also scope to test suite targets as they produce binaries. + +:: + + $ cabal list-bin cabal-install:tests + cabal: The list-bin command is for finding a single binary at once. The + target 'cabal-install:tests' refers to the test suites in the package + cabal-install-#.#.#.# which includes the test suite 'unit-tests', the test + suite 'mem-use-tests', the test suite 'long-tests' and the test suite + 'integration-tests2'. + + $ cabal list-bin cabal-install:unit-tests + /.../dist-newstyle/.../unit-tests/unit-tests + +Note that ``cabal list-bin`` will print the executables' location, but +will not make sure that these executables actually exist (i.e., have +been successfully built). In order to determine the correct location, +it may invoke the configuration step (see ``cabal configure``). + +cabal configure +--------------- + +``cabal configure`` takes a set of arguments and writes a +``cabal.project.local`` file based on the flags passed to this command. +``cabal configure FLAGS; cabal build`` is roughly equivalent to +``cabal build FLAGS``, except that with ``configure`` the flags +are persisted to all subsequent calls to ``build``. + +``cabal configure`` is intended to be a convenient way to write out +a ``cabal.project.local`` for simple configurations; e.g., +``cabal configure -w ghc-7.8`` would ensure that all subsequent +builds with ``cabal build`` are performed with the compiler +``ghc-7.8``. For more complex configuration, we recommend writing the +``cabal.project.local`` file directly (or placing it in +``cabal.project``!) + +``cabal configure`` inherits options from ``Cabal``. semantics: + +- Any flag accepted by ``./Setup configure``. + +- Any flag accepted by ``cabal configure`` beyond + ``./Setup configure``, namely ``--cabal-lib-version``, + ``--constraint``, ``--preference`` and ``--solver.`` + +- Any flag accepted by ``cabal install`` beyond ``./Setup configure``. + +- Any flag accepted by ``./Setup haddock``. + +The options of all of these flags apply only to *local* packages in a +project; this behavior is different than that of ``cabal install``, +which applies flags to every package that would be built. The motivation +for this is to avoid an innocuous addition to the flags of a package +resulting in a rebuild of every package in the store (which might need +to happen if a flag actually applied to every transitive dependency). To +apply options to an external package, use a ``package`` stanza in a +``cabal.project`` file. + +There are two ways of modifying the ``cabal.project.local`` file through +``cabal configure``, either by appending new configurations to it, or +by simply overwriting it all. Overwriting is the default behaviour, as +such, there's a flag ``--enable-append`` to append the new configurations +instead. Since overwriting is rather destructive in nature, a backup system +is in place, which moves the old configuration to a ``cabal.project.local~`` +file, this feature can also be disabled by using the ``--disable-backup`` +flag. + + +cabal update +------------ + +``cabal update`` updates the state of the package index. If the +project contains multiple remote package repositories it will update +the index of all of them (e.g. when using overlays). + +Some examples: + +:: + + $ cabal update # update all remote repos + $ cabal update head.hackage # update only head.hackage + +Target Forms +------------ + +A cabal command target can take any of the following forms: + +- A package target: ``package``, which specifies that all enabled + components of a package to be built. By default, test suites and + benchmarks are *not* enabled, unless they are explicitly requested + (e.g., via ``--enable-tests``.) + +- A component target: ``[package:][ctype:]component``, which specifies + a specific component (e.g., a library, executable, test suite or + benchmark) to be built. + +- All packages: ``all``, which specifies all packages within the project. + +- Components of a particular type: ``package:ctypes``, ``all:ctypes``: + which specifies all components of the given type. Where valid + ``ctypes`` are: + + - ``libs``, ``libraries``, + - ``flibs``, ``foreign-libraries``, + - ``exes``, ``executables``, + - ``tests``, + - ``benches``, ``benchmarks``. + +- A module target: ``[package:][ctype:]module``, which specifies that the + component of which the given module is a part of will be built. + +- A filepath target: ``[package:][ctype:]filepath``, which specifies that the + component of which the given filepath is a part of will be built. + +- A script target: ``path/to/script``, which specifies the path to a script + file. This is supported by ``build``, ``repl``, ``run``, and ``clean``. + Script targets are not part of a package. + +cabal build +----------- + +``cabal build`` takes a set of targets and builds them. It +automatically handles building and installing any dependencies of these +targets. + +In component targets, ``package:`` and ``ctype:`` (valid component types +are ``lib``, ``flib``, ``exe``, ``test`` and ``bench``) can be used to +disambiguate when multiple packages define the same component, or the +same component name is used in a package (e.g., a package ``foo`` +defines both an executable and library named ``foo``). We always prefer +interpreting a target as a package name rather than as a component name. + +Some example targets: + +:: + + $ cabal build lib:foo-pkg # build the library named foo-pkg + $ cabal build foo-pkg:foo-tests # build foo-tests in foo-pkg + $ cabal build src/Lib.s # build the library component to + # which "src/Lib.hs" belongs + $ cabal build app/Main.hs # build the executable component of + # "app/Main.hs" + $ cabal build Lib # build the library component to + # which the module "Lib" belongs + $ cabal build path/to/script # build the script as an executable + +Beyond a list of targets, ``cabal build`` accepts all the flags that +``cabal configure`` takes. Most of these flags are only taken into +consideration when building local packages; however, some flags may +cause extra store packages to be built (for example, +``--enable-profiling`` will automatically make sure profiling libraries +for all transitive dependencies are built and installed.) + +When building a script, the executable is cached under the cabal directory. +See ``cabal run`` for more information on scripts. + +In addition ``cabal build`` accepts these flags: + +- ``--only-configure``: When given we will forego performing a full build and + abort after running the configure phase of each target package. + + +cabal repl +---------- + +``cabal repl TARGET`` loads all of the modules of the target into +GHCi as interpreted bytecode. In addition to ``cabal build``'s flags, +it additionally takes the ``--repl-options`` and ``--repl-no-load`` flags. + +To avoid ``ghci`` specific flags from triggering unneeded global rebuilds these +flags are now stripped from the internal configuration. As a result +``--ghc-options`` will no longer (reliably) work to pass flags to ``ghci`` (or +other repls). Instead, you should use the new ``--repl-options`` flag to +specify these options to the invoked repl. (This flag also works on ``cabal +repl`` and ``Setup repl`` on sufficiently new versions of Cabal.) + +The ``repl-no-load`` flag disables the loading of target modules at startup. + +Currently, it is not supported to pass multiple targets to ``repl`` +(``repl`` will just successively open a separate GHCi session for +each target.) + +It also provides a way to experiment with libraries without needing to download +them manually or to install them globally. + +This command opens a REPL with the current default target loaded, and a version +of the ``vector`` package matching that specification exposed. + +:: + + $ cabal repl --build-depends "vector >= 0.12 && < 0.13" + +Both of these commands do the same thing as the above, but only exposes ``base``, +``vector``, and the ``vector`` package's transitive dependencies even if the user +is in a project context. + +:: + + $ cabal repl --ignore-project --build-depends "vector >= 0.12 && < 0.13" + $ cabal repl --project='' --build-depends "vector >= 0.12 && < 0.13" + +This command would add ``vector``, but not (for example) ``primitive``, because +it only includes the packages specified on the command line (and ``base``, which +cannot be excluded for technical reasons). + +:: + + $ cabal repl --build-depends vector --no-transitive-deps + +``repl`` can open scripts by passing the path to the script as the target. + +:: + + $ cabal repl path/to/script + +The configuration information for the script is cached under the cabal directory +and can be pre-built with ``cabal build path/to/script``. +See ``cabal run`` for more information on scripts. + +cabal run +--------- + +``cabal run [TARGET [ARGS]]`` runs the executable specified by the +target, which can be a component, a package or can be left blank, as +long as it can uniquely identify an executable within the project. +Tests and benchmarks are also treated as executables. + +See `the build section <#cabal-build>`__ for the target syntax. + +When ``TARGET`` is one of the following: + +- A component target: execute the specified executable, benchmark or test suite. + +- A package target: + 1. If the package has exactly one executable component, it will be selected. + 2. If the package has multiple executable components, an error is raised. + 3. If the package has exactly one test or benchmark component, it will be selected. + 4. Otherwise an issue is raised. + +- The path to a script: execute the script at the path. + +- 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. + +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 +have to separate them with ``--``. + +:: + + $ cabal run target -- -a -bcd --argument + +``run`` supports running script files that use a certain format. +Scripts look like: + +:: + + #!/usr/bin/env cabal + {- cabal: + build-depends: base ^>= 4.14 + , shelly ^>= 1.10 + -} + {- project: + with-compiler: ghc-8.10.7 + -} + + main :: IO () + main = do + ... + +Where there cabal metadata block is mandatory and contains fields from a +package executable block, and the project metadata block is optional and +contains fields that would be in the cabal.project file in a regular project. + +Only some fields are supported in the metadata blocks, and these fields are +currently not validated. See +`#8024 `__ for details. + +A script can either be executed directly using `cabal` as an interpreter or +with the command: + +:: + + $ cabal run path/to/script + +The executable is cached under the cabal directory, and can be pre-built with +``cabal build path/to/script`` and the cache can be removed with +``cabal clean path/to/script``. + +A note on targets: Whenever a command takes a script target and it matches the +name of another target, the other target is preferred. To load the script +instead pass it as an explicit path: ./script + +By default, scripts are run at silent verbosity (``--verbose=0``). To show the +build output for a script either use the command + +:: + + $ cabal run --verbose=n path/to/script + +or the interpreter line + +:: + + #!/usr/bin/env -S cabal run --verbose=n + +For more information see :cfg-field:`verbose` + +cabal fetch +----------- + +*☞ N.B.:* ``cabal fetch`` only works for legacy ``v1-`` commands and only +for single package projects. If you are not maintaining an old project, +`cabal build`_ with ``--only-download`` has similar effects to ``fetch`` +and benefits from compatibility with newer build methods. + +``cabal fetch [FLAGS] PACKAGES`` downloads packages for later installation. +It fetches the project plus its dependencies, very useful when +e.g. you plan to work on a project with unreliable or no internet access. + +.. option:: --no-dependencies + + Ignore dependencies. + +.. option:: --disable-tests + + Disable dependency checking and compilation + for test suites listed in the package + description file. + +.. option:: --disable-benchmarks + + Disable dependency checking and compilation + for benchmarks listed in the package + description file. + +Check ``cabal fetch --help`` for a complete list of options. + +cabal list +---------- + +``cabal list [FLAGS] STRINGS`` lists all packages matching a search string. + +.. option:: --installed + + Only output installed packages. + +.. option:: --simple-output + + Print matching packages in a one-package-one-line format. + +.. option:: -i, --ignore-case + +.. option:: -I, --strict-case + +.. option:: --package-db=DB + + Append the given package database to the list of used package + databases. See `cabal info`_ for a thorough explanation. + +.. option:: -w, --with-compiler=PATH + + Path to specific compiler. + +cabal get +--------- + +``cabal get [PACKAGES]`` (synonym: ``cabal unpack``) downloads and unpacks +the source code of ``PACKAGES`` locally. By default the content of the +packages is unpacked in the current working directory, in named subfolders +(e.g. ``./filepath-1.2.0.8/``), use ``--destdir=PATH`` to specify another +folder. By default the latest version of the package is downloaded, you can +ask for a spefic one by adding version numbers +(``cabal get random-1.0.0.1``). + +.. option:: -s, --source-repository[=head|this|...]] + + Clone the package's source repository (Darcs, Git, etc.) instead + of downloading the tarball. Only works if the package specifies + a ``source-repository``. + +.. option:: --index-state=STATE + + Pin your request to a specific Hackage index state. Available + ``STATE`` formats: Unix timestamps (e.g. ``@1474732068``), + ISO8601 UTC timestamps (e.g. ``2016-09-24T17:47:48Z``), or ``HEAD`` + (default). + +.. option:: --pristine + + Unpacks the pristine tarball, i.e. disregarding any Hackage revision. + +cabal freeze +------------ + +``cabal freeze`` writes out a **freeze file** which records all of +the versions and flags that are picked by the solver under the +current index and flags. Default name of this file is +``cabal.project.freeze`` but in combination with a +``--project-file=my.project`` flag (see :ref:`project-file +`) +the name will be ``my.project.freeze``. +A freeze file has the same syntax as ``cabal.project`` and looks +something like this: + +.. highlight:: cabal + +:: + + constraints: HTTP ==4000.3.3, + HTTP +warp-tests -warn-as-error -network23 +network-uri -mtl1 -conduit10, + QuickCheck ==2.9.1, + QuickCheck +templatehaskell, + -- etc... + + +For end-user executables, it is recommended that you distribute the +``cabal.project.freeze`` file in your source repository so that all +users see a consistent set of dependencies. For libraries, this is not +recommended: users often need to build against different versions of +libraries than what you developed against. + +cabal bench +----------- + +``cabal bench [TARGETS] [OPTIONS]`` runs the specified benchmarks +(all the benchmarks in the current package by default), first ensuring +they are up to date. + +cabal test +---------- + +``cabal test [TARGETS] [OPTIONS]`` runs the specified test suites +(all the test suites in the current package by default), first ensuring +they are up to date. + +cabal haddock +------------- + +``cabal haddock [FLAGS] [TARGET]`` builds Haddock documentation for +the specified packages within the project. + +If a target is not a library :cfg-field:`haddock-benchmarks`, +:cfg-field:`haddock-executables`, :cfg-field:`haddock-internal`, +:cfg-field:`haddock-tests` will be implied as necessary. + +cabal exec +---------- + +``cabal exec [FLAGS] [--] COMMAND [--] [ARGS]`` runs the specified command +using the project's environment. That is, passing the right flags to compiler +invocations and bringing the project's executables into scope. + +cabal install +------------- + +``cabal install [FLAGS] [TARGETS]`` builds the specified target packages and +symlinks/copies their executables in ``installdir`` (usually ``~/.cabal/bin``). + +.. warning:: + + If not every package has an executable to install, use ``all:exes`` rather + than ``all`` as the target. To overwrite an installation, use + ``--overwrite-policy=always`` as the default policy is ``never``. + +For example this command will build the latest ``cabal-install`` and symlink +its ``cabal`` executable: + +:: + + $ cabal install cabal-install + +In addition, it's possible to use ``cabal install`` to install components +of a local project. For example, with an up-to-date Git clone of the Cabal +repository, this command will build cabal-install HEAD and symlink the +``cabal`` executable: + +:: + + $ cabal install exe:cabal + +Where symlinking is not possible (eg. on some Windows versions) the ``copy`` +method is used by default. You can specify the install method +by using ``--install-method`` flag: + +:: + + $ cabal install exe:cabal --install-method=copy --installdir=$HOME/bin + +Note that copied executables are not self-contained, since they might use +data-files from the store. + +.. _adding-libraries: + +Adding libraries to GHC package environments +^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +It is also possible to "install" libraries using the ``--lib`` flag. For +example, this command will build the latest Cabal library and install it: + +:: + + $ cabal install --lib Cabal + +This works by managing GHC package environment files. By default, it is writing +to the global environment in ``~/.ghc/$ARCH-$OS-$GHCVER/environments/default``. +``install`` provides the ``--package-env`` flag to control which of these +environments is modified. + +This command will modify the environment file in the current directory: + +:: + + $ cabal install --lib Cabal --package-env . + +This command will modify the environment file in the ``~/foo`` directory: + +:: + + $ cabal install --lib Cabal --package-env foo/ + +Do note that the results of the previous two commands will be overwritten by +the use of other style commands, so it is not recommended to use them inside +a project directory. + +This command will modify the environment in the ``local.env`` file in the +current directory: + +:: + + $ cabal install --lib Cabal --package-env local.env + +This command will modify the ``myenv`` named global environment: + +:: + + $ cabal install --lib Cabal --package-env myenv + +If you wish to create a named environment file in the current directory where +the name does not contain an extension, you must reference it as ``./myenv``. + +You can learn more about how to use these environments in `this section of the +GHC manual `_. + +cabal clean +----------- + +``cabal clean [FLAGS]`` cleans up the temporary files and build artifacts +stored in the ``dist-newstyle`` folder. + +By default, it removes the entire folder, but it can also spare the configuration +and caches if the ``--save-config`` option is given, in which case it only removes +the build artefacts (``.hi``, ``.o`` along with any other temporary files generated +by the compiler, along with the build output). + +``cabal clean [FLAGS] path/to/script`` cleans up the temporary files and build +artifacts for the script, which are stored under the .cabal/script-builds directory. + +In addition when clean is invoked it will remove all script build artifacts for +which the corresponding script no longer exists. + +cabal info +---------- + +``cabal info [FLAGS] PACKAGES`` displays useful informations about remote +packages. + +.. option:: --package-db=DB + + Append the given package database to the list of package databases + used (to satisfy dependencies and register into). May be a specific + file, ``global`` or ``user``. The initial list is ``['global'], ['global', + 'user']``, depending on context. Use ``clear`` to reset the list to empty. + +cabal sdist +----------- + +``cabal sdist [FLAGS] [TARGETS]`` takes the crucial files needed to build ``TARGETS`` +and puts them into an archive format ready for upload to Hackage. These archives are stable +and two archives of the same format built from the same source will hash to the same value. + +``cabal sdist`` takes the following flags: + +- ``-l``, ``--list-only``: Rather than creating an archive, lists files that would be included. + Output is to ``stdout`` by default. The file paths are relative to the project's root + directory. + +- ``-o``, ``--output-directory``: Sets the output dir, if a non-default one is desired. The default is + ``dist-newstyle/sdist/``. ``--output-directory -`` will send output to ``stdout`` + unless multiple archives are being created. + +- ``--null-sep``: Only used with ``--list-only``. Separates filenames with a NUL + byte instead of newlines. + +``sdist`` is inherently incompatible with sdist hooks (which were removed in `Cabal-3.0`), +not due to implementation but due to fundamental core invariants +(same source code should result in the same tarball, byte for byte) +that must be satisfied for it to function correctly in the larger build ecosystem. +``autogen-modules`` is able to replace uses of the hooks to add generated modules, along with +the custom publishing of Haddock documentation to Hackage. + +cabal upload +------------ + +``cabal upload [FLAGS] TARFILES`` uploads source packages or documentation +to Hackage. + +.. option:: --publish + + Publish the package immediately instead of uploading it as a + `package candidate `__ + (make sure everything is fine, you cannot delete published packages + on Hackage!). + +.. option:: -d, --documentation + + Upload documentation instead of a source package. To upload + documentation for a published package (and not a candidate), add + ``--publish``. + +.. option:: -u, --username + + Your Hackage username. + +.. option:: -p, --password + + Your Hackage password. + +.. option:: -P, --password-command + + Command to get your Hackage password. + +cabal report +------------ + +``cabal report [FLAGS]`` uploads build reports to Hackage. + +.. option:: -u, --username + + Your Hackage username. + +.. option:: -p, --password + + Your Hackage password. + +cabal gen-bounds +---------------- + +``cabal gen-bounds [FLAGS]`` generates bounds for all dependencies that do not +currently have them. Generated bounds are printed to stdout. You can then +paste them into your .cabal file. + +See `the section on generating dependency version bounds `__ for more details and examples. + +cabal user-config +----------------- + +``cabal user-config [init|diff|update]`` prints and updates user's global +cabal preferences. It is very useful when you are e.g. first configuring +``cabal`` on a new machine. + +- ``cabal user-config init`` creates a new configuration file. + + .. option:: --config-file=PATH + + Specify config file path. (default: ``~/.cabal/config``). + + .. option:: -f, --force + + Force configuration file overwriting if already exists. + +- ``cabal user-config diff`` prints a diff of the user's config file and the + default one. + +- ``cabal user-config update`` updates the user's config file with additional + lines. + + .. option:: -a, --augment=CONFIGLINE + + Pass additional configuration lines to be incorporated in the + config file. e.g. + ``cabal user-config update --augment "offline: True"``. + + Note how ``--augment`` syntax follows ``cabal user-config diff`` + output. + +cabal outdated +-------------- + +``cabal outdated [FLAGS]`` checks for outdated dependencies in the package +description file or freeze file. + +``cabal outdated`` supports the following flags: + +- ``--v1-freeze-file``: Read dependency version bounds from the freeze file + (``cabal.config``) instead of the package description file + (``$PACKAGENAME.cabal``). + +- ``--v2-freeze-file``: + + :since: 2.4 + + Read dependency version bounds from the v2-style freeze file + (by default, ``cabal.project.freeze``) instead of the package + description file. ``--new-freeze-file`` is an alias for this flag + that can be used with pre-2.4 ``cabal``. + +- ``--project-file PROJECTFILE``: + + :since: 2.4 + + Read dependendency version bounds from the v2-style freeze file + related to the named project file (i.e., ``$PROJECTFILE.freeze``) + instead of the package desctription file. If multiple ``--project-file`` + flags are provided, only the final one is considered. This flag + must only be passed in when ``--new-freeze-file`` is present. + +- ``--simple-output``: Print only the names of outdated dependencies, one per line. + +- ``--exit-code``: Exit with a non-zero exit code when there are outdated dependencies. + +- ``-q, --quiet``: Don't print any output. Implies ``-v0`` and ``--exit-code``. + +- ``--ignore PACKAGENAMES``: Don't warn about outdated dependency version bounds for the packages in this list. + +- ``--minor [PACKAGENAMES]``: Ignore major version bumps for these packages. + E.g. if there's a version 2.0 of a package ``pkg`` on Hackage and the freeze + file specifies the constraint ``pkg == 1.9``, ``cabal outdated --freeze + --minor=pkg`` will only consider the ``pkg`` outdated when there's a version + of ``pkg`` on Hackage satisfying ``pkg > 1.9 && < 2.0``. ``--minor`` can also + be used without arguments, in that case major version bumps are ignored for + all packages. + + See `the section on listing outdated dependency version bounds `__ for more details and examples. diff --git a/cabal/doc/cabal-config-and-commands.rst b/cabal/doc/cabal-config-and-commands.rst new file mode 100644 --- /dev/null +++ b/cabal/doc/cabal-config-and-commands.rst @@ -0,0 +1,6 @@ +cabal-install Configuration and Commands +**************************************** + +.. toctree:: + config + cabal-commands diff --git a/cabal/doc/cabal-package.rst b/cabal/doc/cabal-package.rst new file mode 100644 --- /dev/null +++ b/cabal/doc/cabal-package.rst @@ -0,0 +1,3559 @@ +Package Description +=================== + +The Cabal package is the unit of distribution. When installed, its +purpose is to make available: + +- One or more Haskell programs. + +- At most one library, exposing a number of Haskell modules. + +However having both a library and executables in a package does not work +very well; if the executables depend on the library, they must +explicitly list all the modules they directly or indirectly import from +that library. Fortunately, starting with Cabal 1.8.0.4, executables can +also declare the package that they are in as a dependency, and Cabal +will treat them as if they were in another package that depended on the +library. + +Internally, the package may consist of much more than a bunch of Haskell +modules: it may also have C source code and header files, source code +meant for preprocessing, documentation, test cases, auxiliary tools etc. + +A package is identified by a globally-unique *package name*, which +consists of one or more alphanumeric words separated by hyphens. To +avoid ambiguity, each of these words should contain at least one letter. +Chaos will result if two distinct packages with the same name are +installed on the same system. A particular version of the package is +distinguished by a *version number*, consisting of a sequence of one or +more integers separated by dots. These can be combined to form a single +text string called the *package ID*, using a hyphen to separate the name +from the version, e.g. "``HUnit-1.1``". + +.. Note:: + + Packages are not part of the Haskell language; they simply + populate the hierarchical space of module names. In GHC 6.6 and later a + program may contain multiple modules with the same name if they come + from separate packages; in all other current Haskell systems packages + may not overlap in the modules they provide, including hidden modules. + +Creating a package +------------------ + +Suppose you have a directory hierarchy containing the source files that +make up your package. You will need to add two more files to the root +directory of the package: + +:file:`{package-name}.cabal` + a Unicode UTF-8 text file containing a package description. For + details of the syntax of this file, see the section on + `package descriptions`_. + +:file:`Setup.hs` + a single-module Haskell program to perform various setup tasks (with + the interface described in the section on :ref:`setup-commands`). + This module should import only modules that will be present in all Haskell + implementations, including modules of the Cabal library. The content of + this file is determined by the :pkg-field:`build-type` setting in the + ``.cabal`` file. In most cases it will be trivial, calling on the Cabal + library to do most of the work. + +Once you have these, you can create a source bundle of this directory +for distribution. Building of the package is demonstrated in the section +:ref:`building-packages`. + +One of the purposes of Cabal is to make it easier to build a package +with different Haskell implementations. So it provides abstractions of +features present in different Haskell implementations and wherever +possible it is best to take advantage of these to increase portability. +Where necessary however it is possible to use specific features of +specific implementations. For example one of the pieces of information a +package author can put in the package's ``.cabal`` file is what language +extensions the code uses. This is far preferable to specifying flags for +a specific compiler as it allows Cabal to pick the right flags for the +Haskell implementation that the user picks. It also allows Cabal to +figure out if the language extension is even supported by the Haskell +implementation that the user picks. Where compiler-specific options are +needed however, there is an "escape hatch" available. The developer can +specify implementation-specific options and more generally there is a +configuration mechanism to customise many aspects of how a package is +built depending on the Haskell implementation, the Operating system, +computer architecture and user-specified configuration flags. + +:: + + name: Foo + version: 1.0 + + library + default-language: Haskell2010 + build-depends: base >= 4 && < 5 + exposed-modules: Foo + extensions: ForeignFunctionInterface + ghc-options: -Wall + if os(windows) + build-depends: Win32 >= 2.1 && < 2.6 + +Example: A package containing a simple library +^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +The HUnit package contains a file ``HUnit.cabal`` containing: + +:: + + cabal-version: 3.0 + name: HUnit + version: 1.1.1 + synopsis: A unit testing framework for Haskell + homepage: http://hunit.sourceforge.net/ + category: Testing + author: Dean Herington + license: BSD-3-Clause + license-file: LICENSE + build-type: Simple + + library + build-depends: base >= 2 && < 4 + exposed-modules: Test.HUnit.Base, Test.HUnit.Lang, + Test.HUnit.Terminal, Test.HUnit.Text, Test.HUnit + default-extensions: CPP + default-language: Haskell2010 + +and the following ``Setup.hs``: + +.. code-block:: haskell + + import Distribution.Simple + main = defaultMain + +Example: A package containing executable programs +^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +:: + + cabal-version: 3.0 + name: TestPackage + version: 0.0 + synopsis: Small package with two programs + author: Angela Author + license: BSD-3-Clause + build-type: Simple + + executable program1 + build-depends: HUnit >= 1.1.1 && < 1.2 + main-is: main.hs + hs-source-dirs: prog1 + default-language: Haskell2010 + + executable program2 + -- A different main.hs because of hs-source-dirs. + main-is: main.hs + build-depends: HUnit >= 1.1.1 && < 1.2 + hs-source-dirs: prog2 + other-modules: Utils + default-language: Haskell2010 + +with ``Setup.hs`` the same as above. + +Example: A package containing a library and executable programs +^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +:: + + cabal-version: 3.0 + name: TestPackage + version: 0.0 + synopsis: Package with library and two programs + license: BSD-3-Clause + author: Angela Author + build-type: Simple + + library + build-depends: HUnit >= 1.1.1 && < 1.2 + hs-source-dirs: lib + exposed-modules: A, B, C + default-language: Haskell2010 + + executable program1 + main-is: main.hs + hs-source-dirs: prog1 + other-modules: D, E + default-language: Haskell2010 + + executable program2 + -- A different main.hs because of hs-source-dirs. + main-is: main.hs + -- No bound on internal libraries. + build-depends: TestPackage + hs-source-dirs: prog2 + other-modules: Utils + default-language: Haskell2010 + +with ``Setup.hs`` the same as above. Note that any library modules +required (directly or indirectly) by an executable must be listed again. + +The trivial setup script used in these examples uses the *simple build +infrastructure* provided by the Cabal library (see +`Distribution.Simple `__). +The simplicity lies in its interface rather that its implementation. It +automatically handles preprocessing with standard preprocessors, and +builds packages for all the Haskell implementations. + +The simple build infrastructure can also handle packages where building +is governed by system-dependent parameters, if you specify a little more +(see the section on `system-dependent parameters`_). +A few packages require `more elaborate solutions `_. + +.. _pkg-desc: + +Package descriptions +-------------------- + +The package description file must have a name ending in "``.cabal``". It +must be a Unicode text file encoded using valid UTF-8. There must be +exactly one such file in the directory. The first part of the name is +usually the package name, and some of the tools that operate on Cabal +packages require this; specifically, Hackage rejects packages which +don't follow this rule. + +In the package description file, lines whose first non-whitespace +characters are "``--``" are treated as comments and ignored. + +This file should contain a number global property descriptions and +several sections. + +- The `package properties`_ describe the package + as a whole, such as name, license, author, etc. + +- Optionally, a number of *configuration flags* can be declared. These + can be used to enable or disable certain features of a package. (see + the section on `configurations`_). + +- The (optional) library section specifies the `library`_ properties and + relevant `build information`_. + +- Following is an arbitrary number of executable sections which describe + an executable program and relevant `build information`_. + +Each section consists of a number of property descriptions in the form +of field/value pairs, with a syntax roughly like mail message headers. + +- Case is not significant in field names, but is significant in field + values. + +- To continue a field value, indent the next line relative to the field + name. + +- Field names may be indented, but all field values in the same section + must use the same indentation. + +- Tabs are *not* allowed as indentation characters due to a missing + standard interpretation of tab width. + +- Before Cabal 3.0, to get a blank line in a field value, use an indented "``.``" + +The syntax of the value depends on the field. Field types include: + +*token*, *filename*, *directory* + Either a sequence of one or more non-space non-comma characters, or + a quoted string in Haskell 98 lexical syntax. The latter can be used + for escaping whitespace, for example: + ``ghc-options: -Wall "-with-rtsopts=-T -I1"``. Unless otherwise + stated, relative filenames and directories are interpreted from the + package root directory. +*freeform*, *URL*, *address* + An arbitrary, uninterpreted string. +*identifier* + A letter followed by zero or more alphanumerics or underscores. +*compiler* + A compiler flavor (one of: ``GHC``, ``UHC`` or ``LHC``) + followed by a version range. For example, ``GHC ==6.10.3``, or + ``LHC >=0.6 && <0.8``. + +Modules and preprocessors +^^^^^^^^^^^^^^^^^^^^^^^^^ + +Haskell module names listed in the :pkg-field:`library:exposed-modules` and +:pkg-field:`library:other-modules` fields may correspond to Haskell source +files, i.e. with names ending in "``.hs``" or "``.lhs``", or to inputs for +various Haskell preprocessors. The simple build infrastructure understands the +extensions: + +- ``.gc`` (:hackage-pkg:`greencard`) +- ``.chs`` (:hackage-pkg:`c2hs`) +- ``.hsc`` (:hackage-pkg:`hsc2hs`) +- ``.y`` and ``.ly`` (happy_) +- ``.x`` (alex_) +- ``.cpphs`` (cpphs_) + +When building, Cabal will automatically run the appropriate preprocessor +and compile the Haskell module it produces. For the ``c2hs`` and +``hsc2hs`` preprocessors, Cabal will also automatically add, compile and +link any C sources generated by the preprocessor (produced by +``hsc2hs``'s ``#def`` feature or ``c2hs``'s auto-generated wrapper +functions). Dependencies on pre-processors are specified via the +:pkg-field:`build-tools` or :pkg-field:`build-tool-depends` fields. + +Some fields take lists of values, which are optionally separated by +commas, except for the :pkg-field:`build-depends` field, where the commas are +mandatory. + +Some fields are marked as required. All others are optional, and unless +otherwise specified have empty default values. + +Package properties +^^^^^^^^^^^^^^^^^^ + +These fields may occur in the first top-level properties section and +describe the package as a whole: + +.. pkg-field:: name: package-name (required) + + The unique name of the package, without the version number. + + As pointed out in the section on `package descriptions`_, some + tools require the package-name specified for this field to match + the package description's file-name :file:`{package-name}.cabal`. + + Package names are case-sensitive and must match the regular expression + (i.e. alphanumeric "words" separated by dashes; each alphanumeric + word must contain at least one letter): + ``[[:digit:]]*[[:alpha:]][[:alnum:]]*(-[[:digit:]]*[[:alpha:]][[:alnum:]]*)*``. + + Or, expressed in ABNF_: + + .. code-block:: abnf + + package-name = package-name-part *("-" package-name-part) + package-name-part = *DIGIT UALPHA *UALNUM + + UALNUM = UALPHA / DIGIT + UALPHA = ... ; set of alphabetic Unicode code-points + + .. note:: + + Hackage restricts package names to the ASCII subset. + +.. pkg-field:: version: numbers (required) + + The package version number, usually consisting of a sequence of + natural numbers separated by dots, i.e. as the regular + expression ``[0-9]+([.][0-9]+)*`` or expressed in ABNF_: + + .. code-block:: abnf + + package-version = 1*DIGIT *("." 1*DIGIT) + +.. pkg-field:: cabal-version: x.y[.z] + + The version of the Cabal specification that this package + description uses. The Cabal specification does slowly evolve (see + also :ref:`spec-history`), introducing new features and + occasionally changing the meaning of existing features. + Specifying which version of the specification you are using + enables programs which process the package description to know + what syntax to expect and what each part means. + + The version number you specify will affect both compatibility and + behaviour. Most tools (including the Cabal library and the ``cabal`` + program) understand a range of versions of the Cabal specification. + Older tools will of course only work with older versions of the + Cabal specification that was known at the time. Most of the time, + tools that are too old will recognise this fact and produce a + suitable error message. Likewise, ``cabal check`` will tell you + whether the version number is sufficiently high for the features + you use in the package description. + + As for behaviour, new versions of the Cabal specification can change the + meaning of existing syntax. This means if you want to take advantage + of the new meaning or behaviour then you must specify the newer + Cabal version. Tools are expected to use the meaning and behaviour + appropriate to the version given in the package description. + + In particular, the syntax of package descriptions changed + significantly with Cabal version 1.2 and the :pkg-field:`cabal-version` + field is now required. Files written in the old syntax are still + recognized, so if you require compatibility with very old Cabal + versions then you may write your package description file using the + old syntax. Please consult the user's guide of an older Cabal + version for a description of that syntax. + + Starting with ``cabal-version: 2.2`` this field is only valid if + fully contained in the very first line of a package description + and ought to adhere to the ABNF_ grammar + + .. code-block:: abnf + + newstyle-spec-version-decl = "cabal-version" *WS ":" *WS newstyle-spec-version *WS + + newstyle-spec-version = NUM "." NUM [ "." NUM ] + + NUM = DIGIT0 / DIGITP 1*DIGIT0 + DIGIT0 = %x30-39 + DIGITP = %x31-39 + WS = %20 + + + .. note:: + + For package descriptions using a format prior to + ``cabal-version: 1.12`` the legacy syntax resembling a version + range syntax + + .. code-block:: cabal + + cabal-version: >= 1.10 + + needs to be used. + + This legacy syntax is supported up until ``cabal-version: >= + 2.0`` it is however strongly recommended to avoid using the + legacy syntax. See also :issue:`4899`. + + + +.. pkg-field:: build-type: identifier + + :default: ``Custom`` or ``Simple`` + + The type of build used by this package. Build types are the + constructors of the + `BuildType `__ + type. This field is optional and when missing, its default value + is inferred according to the following rules: + + - When :pkg-field:`cabal-version` is set to ``2.2`` or higher, + the default is ``Simple`` unless a :pkg-section:`custom-setup` + exists, in which case the inferred default is ``Custom``. + + - For lower :pkg-field:`cabal-version` values, the default is + ``Custom`` unconditionally. + + If the build type is anything other than ``Custom``, then the + ``Setup.hs`` file *must* be exactly the standardized content + discussed below. This is because in these cases, ``cabal`` will + ignore the ``Setup.hs`` file completely, whereas other methods of + package management, such as ``runhaskell Setup.hs [CMD]``, still + rely on the ``Setup.hs`` file. + + For build type ``Simple``, the contents of ``Setup.hs`` must be: + + .. code-block:: haskell + + import Distribution.Simple + main = defaultMain + + For build type ``Configure`` (see the section on `system-dependent + parameters`_ below), the contents of + ``Setup.hs`` must be: + + .. code-block:: haskell + + import Distribution.Simple + main = defaultMainWithHooks autoconfUserHooks + + For build type ``Make`` (see the section on `more complex packages`_ below), + the contents of ``Setup.hs`` must be: + + .. code-block:: haskell + + import Distribution.Make + main = defaultMain + + For build type ``Custom``, the file ``Setup.hs`` can be customized, + and will be used both by ``cabal`` and other tools. + + For most packages, the build type ``Simple`` is sufficient. + +.. pkg-field:: license: SPDX expression + + :default: ``NONE`` + + The type of license under which this package is distributed. + + Starting with ``cabal-version: 2.2`` the ``license`` field takes a + (case-sensitive) SPDX expression such as + + .. code-block:: cabal + + license: Apache-2.0 AND (MIT OR GPL-2.0-or-later) + + See `SPDX IDs: How to use `__ for more + examples of SPDX expressions. + + The version of the + `list of SPDX license identifiers `__ + is a function of the :pkg-field:`cabal-version` value as defined + in the following table: + + +--------------------------+--------------------+ + | Cabal specification | SPDX license list | + | version | version | + | | | + +==========================+====================+ + | ``cabal-version: 2.2`` | ``3.0 2017-12-28`` | + +--------------------------+--------------------+ + | ``cabal-version: 2.4`` | ``3.2 2018-07-10`` | + +--------------------------+--------------------+ + + **Pre-SPDX Legacy Identifiers** + + The license identifier in the table below are defined for + ``cabal-version: 2.0`` and previous versions of the Cabal + specification. + + +--------------------------+-----------------+ + | :pkg-field:`license` | Note | + | identifier | | + | | | + +==========================+=================+ + | ``GPL`` | | + | ``GPL-2`` | | + | ``GPL-3`` | | + +--------------------------+-----------------+ + | ``LGPL`` | | + | ``LGPL-2.1`` | | + | ``LGPL-3`` | | + +--------------------------+-----------------+ + | ``AGPL`` | since 1.18 | + | ``AGPL-3`` | | + +--------------------------+-----------------+ + | ``BSD2`` | since 1.20 | + +--------------------------+-----------------+ + | ``BSD3`` | | + +--------------------------+-----------------+ + | ``MIT`` | | + +--------------------------+-----------------+ + | ``ISC`` | since 1.22 | + +--------------------------+-----------------+ + | ``MPL-2.0`` | since 1.20 | + +--------------------------+-----------------+ + | ``Apache`` | | + | ``Apache-2.0`` | | + +--------------------------+-----------------+ + | ``PublicDomain`` | | + +--------------------------+-----------------+ + | ``AllRightsReserved`` | | + +--------------------------+-----------------+ + | ``OtherLicense`` | | + +--------------------------+-----------------+ + + +.. pkg-field:: license-file: filename + + See :pkg-field:`license-files`. + +.. pkg-field:: license-files: filename list + :since: 1.20 + + The name of a file(s) containing the precise copyright license for + this package. The license file(s) will be installed with the + package. + + If you have multiple license files then use the :pkg-field:`license-files` + field instead of (or in addition to) the :pkg-field:`license-file` field. + +.. pkg-field:: copyright: freeform + + The content of a copyright notice, typically the name of the holder + of the copyright on the package and the year(s) from which copyright + is claimed. For example:: + + copyright: (c) 2006-2007 Joe Bloggs + +.. pkg-field:: author: freeform + + The original author of the package. + + Remember that ``.cabal`` files are Unicode, using the UTF-8 + encoding. + +.. pkg-field:: maintainer: address + + The current maintainer or maintainers of the package. This is an + e-mail address to which users should send bug reports, feature + requests and patches. + +.. pkg-field:: stability: freeform + + The stability level of the package, e.g. ``alpha``, + ``experimental``, ``provisional``, ``stable``. + +.. pkg-field:: homepage: URL + + The package homepage. + +.. pkg-field:: bug-reports: URL + + The URL where users should direct bug reports. This would normally + be either: + + - A ``mailto:`` URL, e.g. for a person or a mailing list. + + - An ``http:`` (or ``https:``) URL for an online bug tracking + system. + + For example Cabal itself uses a web-based bug tracking system + + :: + + bug-reports: https://github.com/haskell/cabal/issues + +.. pkg-field:: package-url: URL + + The location of a source bundle for the package. The distribution + should be a Cabal package. + +.. pkg-field:: synopsis: freeform + + A very short description of the package, for use in a table of + packages. This is your headline, so keep it short (one line) but as + informative as possible. Save space by not including the package + name or saying it's written in Haskell. + +.. pkg-field:: description: freeform + + Description of the package. This may be several paragraphs, and + should be aimed at a Haskell programmer who has never heard of your + package before. + + For library packages, this field is used as prologue text by + :ref:`setup-haddock` and thus may contain the same markup as Haddock_ + documentation comments. + +.. pkg-field:: category: freeform + + A classification category for future use by the package catalogue + Hackage_. These categories have not + yet been specified, but the upper levels of the module hierarchy + make a good start. + +.. pkg-field:: tested-with: compiler list + + A list of compilers and versions against which the package has been + tested (or at least built). The value of this field is not used by Cabal + and is rather intended as extra metadata for use by third party + tooling, such as e.g. CI tooling. + + Here's a typical usage example: + + :: + + tested-with: GHC == 9.0.1, GHC == 8.10.4, GHC == 8.8.4, + GHC == 8.6.5, GHC == 8.4.4, GHC == 8.2.2, GHC == 8.0.2, + GHC == 7.10.3, GHC == 7.8.4, GHC == 7.6.3, GHC == 7.4.2 + + The same can be spread over several lines, for instance: + + :: + + tested-with: GHC == 9.0.1 + , GHC == 8.10.4 + , GHC == 8.8.4 + , GHC == 8.6.5 + , GHC == 8.4.4 + , GHC == 8.2.2 + , GHC == 8.0.2 + , GHC == 7.10.3 + , GHC == 7.8.4 + , GHC == 7.6.3 + , GHC == 7.4.2 + + The separating comma can also be dropped altogether: + + :: + + tested-with: + GHC == 9.0.1 + GHC == 8.10.4 + GHC == 8.8.4 + GHC == 8.6.5 + GHC == 8.4.4 + GHC == 8.2.2 + GHC == 8.0.2 + GHC == 7.10.3 + GHC == 7.8.4 + GHC == 7.6.3 + GHC == 7.4.2 + + However, this alternative might + `disappear `__ + in the future. + + Starting with :pkg-field:`cabal-version` 3.0, + there are further conveniences. + + 1. A preceding ``,`` is allowed, so a bullet-list style + is possible (recommended): + + :: + + tested-with: + , GHC == 9.0.1 + , GHC == 8.10.4 + , GHC == 8.8.4 + , GHC == 8.6.5 + , GHC == 8.4.4 + , GHC == 8.2.2 + , GHC == 8.0.2 + , GHC == 7.10.3 + , GHC == 7.8.4 + , GHC == 7.6.3 + , GHC == 7.4.2 + + + 2. A concise set notation syntax is available: + + :: + + tested-with: GHC == { 9.0.1, 8.10.4, 8.8.4, 8.6.5, 8.4.4, 8.2.2, 8.0.2, 7.10.3, 7.8.4, 7.6.3, 7.4.2 } + +.. pkg-field:: data-files: filename list + + A list of files to be installed for run-time use by the package. + This is useful for packages that use a large amount of static data, + such as tables of values or code templates. Cabal provides a way to + `find these files at run-time <#accessing-data-files-from-package-code>`_. + + A limited form of ``*`` wildcards in file names, for example + ``data-files: images/*.png`` matches all the ``.png`` files in the + ``images`` directory. ``data-files: audio/**/*.mp3`` matches all + the ``.mp3`` files in the ``audio`` directory, including + subdirectories. + + The specific limitations of this wildcard syntax are + + - ``*`` wildcards are only allowed in place of the file name, not + in the directory name or file extension. It must replace the + whole file name (e.g., ``*.html`` is allowed, but + ``chapter-*.html`` is not). If a wildcard is used, it must be + used with an extension, so ``data-files: data/*`` is not + allowed. + + - Prior to Cabal 2.4, when matching a wildcard plus extension, a + file's full extension must match exactly, so ``*.gz`` matches + ``foo.gz`` but not ``foo.tar.gz``. This restriction has been + lifted when ``cabal-version: 2.4`` or greater so that ``*.gz`` + does match ``foo.tar.gz`` + + - ``*`` wildcards will not match if the file name is empty (e.g., + ``*.html`` will not match ``foo/.html``). + + - ``**`` wildcards can only appear as the final path component + before the file name (e.g., ``data/**/images/*.jpg`` is not + allowed). + + - Prior to Cabal 3.8, if a ``**`` wildcard is used, then + the file name must include a ``*`` wildcard (e.g., + ``data/**/README.rst`` was not allowed). As of ``cabal-version: + 3.8`` or greater, this restriction is lifted. + + - A wildcard that does not match any files is an error. + + The reason for providing only a very limited form of wildcard is to + concisely express the common case of a large number of related files + of the same file type without making it too easy to accidentally + include unwanted files. + + On efficiency: if you use ``**`` patterns, the directory tree will + be walked starting with the parent directory of the ``**``. If + that's the root of the project, this might include ``.git/``, + ``dist-newstyle/``, or other large directories! To avoid this + behaviour, put the files that wildcards will match against in + their own folder. + + ``**`` wildcards are available starting in Cabal 2.4. + +.. pkg-field:: data-dir: directory + + The directory where Cabal looks for data files to install, relative + to the source directory. By default, Cabal will look in the source + directory itself. + +.. pkg-field:: extra-source-files: filename list + + A list of additional files to be included in source distributions + built with :ref:`setup-sdist`. As with :pkg-field:`data-files` it can use + a limited form of ``*`` wildcards in file names. + +.. pkg-field:: extra-doc-files: filename list + :since: 1.18 + + A list of additional files to be included in source distributions, + and also copied to the html directory when Haddock documentation is + generated. As with :pkg-field:`data-files` it can use a limited form of + ``*`` wildcards in file names. + +.. pkg-field:: extra-tmp-files: filename list + + A list of additional files or directories to be removed by + :ref:`setup-clean`. These would typically be additional files created by + additional hooks, such as the scheme described in the section on + `system-dependent parameters`_. + +Library +^^^^^^^ + +.. pkg-section:: library name + :synopsis: Library build information. + + Build information for libraries. + + Currently, there can only be one publicly exposed library in a + package, and its name is the same as package name set by global + :pkg-field:`name` field. In this case, the ``name`` argument to + the :pkg-section:`library` section must be omitted. + + Starting with Cabal 2.0, private internal sub-library components + can be defined by setting the ``name`` field to a name + different from the current package's name; see section on + :ref:`Internal Libraries ` for more information. + +The library section should contain the following fields: + +.. pkg-field:: exposed-modules: identifier list + + :required: if this package contains a library + + A list of modules added by this package. + +.. pkg-field:: virtual-modules: identifier list + :since: 2.2 + + A list of virtual modules provided by this package. Virtual modules + are modules without a source file. See for example the ``GHC.Prim`` + module from the ``ghc-prim`` package. Modules listed here will not be + built, but still end up in the list of ``exposed-modules`` in the + installed package info when the package is registered in the package + database. + +.. pkg-field:: exposed: boolean + + :default: ``True`` + + Some Haskell compilers (notably GHC) support the notion of packages + being "exposed" or "hidden" which means the modules they provide can + be easily imported without always having to specify which package + they come from. However this only works effectively if the modules + provided by all exposed packages do not overlap (otherwise a module + import would be ambiguous). + + Almost all new libraries use hierarchical module names that do not + clash, so it is very uncommon to have to use this field. However it + may be necessary to set ``exposed: False`` for some old libraries + that use a flat module namespace or where it is known that the + exposed modules would clash with other common modules. + +.. pkg-field:: visibility: visibility specifiers + + :since: 3.0 + + :default: + ``private`` for internal libraries. Cannot be set for main + (unnamed) library, which is always public. + + Can be ``public`` or ``private``. + Makes it possible to have multiple public libraries in a single package. + If set to ``public``, depending on this library from another package is + allowed. If set to ``private``, depending on this library is allowed only + from the same package. + + See section on :ref:`Internal Libraries ` for examples and more + information. + +.. pkg-field:: reexported-modules: exportlist + :since: 1.22 + + Supported only in GHC 7.10 and later. A list of modules to + *reexport* from this package. The syntax of this field is + ``orig-pkg:Name as NewName`` to reexport module ``Name`` from + ``orig-pkg`` with the new name ``NewName``. We also support + abbreviated versions of the syntax: if you omit ``as NewName``, + we'll reexport without renaming; if you omit ``orig-pkg``, then we + will automatically figure out which package to reexport from, if + it's unambiguous. + + Reexported modules are useful for compatibility shims when a package + has been split into multiple packages, and they have the useful + property that if a package provides a module, and another package + reexports it under the same name, these are not considered a + conflict (as would be the case with a stub module.) They can also be + used to resolve name conflicts. + +.. pkg-field:: signatures: signature list + :since: 2.0 + + Supported only in GHC 8.2 and later. A list of `module signatures `__ required by this package. + + Module signatures are part of the Backpack_ extension to + the Haskell module system. + + Packages that do not export any modules and only export required signatures + are called "signature-only packages", and their signatures are subjected to + `signature thinning + `__. + + + +The library section may also contain build information fields (see the +section on `build information`_). + +.. _sublibs: + +**Internal Libraries** + +Cabal 2.0 and later support "internal libraries", which are extra named +libraries (as opposed to the usual unnamed library section). For +example, suppose that your test suite needs access to some internal +modules in your library, which you do not otherwise want to export. You +could put these modules in an internal library, which the main library +and the test suite :pkg-field:`build-depends` upon. Then your Cabal file might +look something like this: + +:: + + cabal-version: 2.0 + name: foo + version: 0.1.0.0 + license: BSD3 + license-file: LICENSE + build-type: Simple + + library foo-internal + exposed-modules: Foo.Internal + -- NOTE: no explicit constraints on base needed + -- as they're inherited from the 'library' stanza + build-depends: base + default-language: Haskell2010 + + library + exposed-modules: Foo.Public + build-depends: foo-internal, base >= 4.3 && < 5 + default-language: Haskell2010 + + test-suite test-foo + type: exitcode-stdio-1.0 + main-is: test-foo.hs + -- NOTE: no constraints on 'foo-internal' as same-package + -- dependencies implicitly refer to the same package instance + build-depends: foo-internal, base + default-language: Haskell2010 + +Internal libraries are also useful for packages that define multiple +executables, but do not define a publicly accessible library. Internal +libraries are only visible internally in the package (so they can only +be added to the :pkg-field:`build-depends` of same-package libraries, +executables, test suites, etc.) Internal libraries locally shadow any +packages which have the same name; consequently, don't name an internal +library with the same name as an external dependency if you need to be +able to refer to the external dependency in a +:pkg-field:`build-depends` declaration. + +Shadowing can be used to vendor an external dependency into a package +and thus emulate *private dependencies*. Below is an example based on +a real-world use case: + +:: + + cabal-version: 3.0 + name: haddock-library + version: 1.6.0 + license: BSD-3-Clause + + library + build-depends: + , base ^>= 4.11.1.0 + , bytestring ^>= 0.10.2.0 + , containers ^>= 0.4.2.1 || ^>= 0.5.0.0 + , transformers ^>= 0.5.0.0 + + hs-source-dirs: src + + -- internal sub-lib + build-depends: attoparsec + + exposed-modules: + Documentation.Haddock + + default-language: Haskell2010 + + library attoparsec + build-depends: + , base ^>= 4.11.1.0 + , bytestring ^>= 0.10.2.0 + , deepseq ^>= 1.4.0.0 + + hs-source-dirs: vendor/attoparsec-0.13.1.0 + + -- NB: haddock-library needs only small part of lib:attoparsec + -- internally, so we only bundle that subset here + exposed-modules: + Data.Attoparsec.ByteString + Data.Attoparsec.Combinator + + other-modules: + Data.Attoparsec.Internal + + ghc-options: -funbox-strict-fields -Wall -fwarn-tabs -O2 + + default-language: Haskell2010 + +**Multiple public libraries** + +Cabal 3.0 and later support exposing multiple libraries from a single package +through the field :pkg-field:`library:visibility`. +Having multiple public libraries is useful for separating the unit of +distribution (package) from the unit of buildable code (library). +For more information about the rationale and some examples, see +`this blog post `__. + +.. + TODO inline the blog post + + +Opening an interpreter session +^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +While developing a package, it is often useful to make its code +available inside an interpreter session. This can be done with the +``repl`` command: + +.. code-block:: console + + $ cabal repl + +The name comes from the acronym +`REPL `__, +which stands for "read-eval-print-loop". By default ``cabal repl`` loads +the first component in a package. If the package contains several named +components, the name can be given as an argument to ``repl``. The name +can be also optionally prefixed with the component's type for +disambiguation purposes. Example: + +.. code-block:: console + + $ cabal repl foo + $ cabal repl exe:foo + $ cabal repl test:bar + $ cabal repl bench:baz + +Freezing dependency versions +^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +If a package is built in several different environments, such as a +development environment, a staging environment and a production +environment, it may be necessary or desirable to ensure that the same +dependency versions are selected in each environment. This can be done +with the ``freeze`` command: + +.. code-block:: console + + $ cabal freeze + +The command writes the selected version for all dependencies to the +``cabal.config`` file. All environments which share this file will use +the dependency versions specified in it. + +Generating dependency version bounds +^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +Cabal also has the ability to suggest dependency version bounds that +conform to the `Package Versioning Policy`_, which is +a recommended versioning system for publicly released Cabal packages. +This is done by running the ``gen-bounds`` command: + +.. code-block:: console + + $ cabal gen-bounds + +For example, given the following dependencies without bounds specified in +:pkg-field:`build-depends`: + +:: + + build-depends: + base, + mtl, + transformers, + +``gen-bounds`` might suggest changing them to the following: + +:: + + build-depends: + base >= 4.15.0 && < 4.16, + mtl >= 2.2.2 && < 2.3, + transformers >= 0.5.6 && < 0.6, + + +Listing outdated dependency version bounds +^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +Manually updating dependency version bounds in a ``.cabal`` file or a +freeze file can be tedious, especially when there's a lot of +dependencies. The ``cabal outdated`` command is designed to help with +that. It will print a list of packages for which there is a new +version on Hackage that is outside the version bound specified in the +``build-depends`` field. The ``outdated`` command can also be +configured to act on the freeze file (both old- and v2-style) and +ignore major (or all) version bumps on Hackage for a subset of +dependencies. + +Examples: + +.. code-block:: console + + $ cd /some/package + $ cabal outdated + Outdated dependencies: + haskell-src-exts <1.17 (latest: 1.19.1) + language-javascript <0.6 (latest: 0.6.0.9) + unix ==2.7.2.0 (latest: 2.7.2.1) + + $ cabal outdated --simple-output + haskell-src-exts + language-javascript + unix + + $ cabal outdated --ignore=haskell-src-exts + Outdated dependencies: + language-javascript <0.6 (latest: 0.6.0.9) + unix ==2.7.2.0 (latest: 2.7.2.1) + + $ cabal outdated --ignore=haskell-src-exts,language-javascript,unix + All dependencies are up to date. + + $ cabal outdated --ignore=haskell-src-exts,language-javascript,unix -q + $ echo $? + 0 + + $ cd /some/other/package + $ cabal outdated --freeze-file + Outdated dependencies: + HTTP ==4000.3.3 (latest: 4000.3.4) + HUnit ==1.3.1.1 (latest: 1.5.0.0) + + $ cabal outdated --freeze-file --ignore=HTTP --minor=HUnit + Outdated dependencies: + HUnit ==1.3.1.1 (latest: 1.3.1.2) + +See `the command documentation `__ for a +list of available flags. + +Executables +^^^^^^^^^^^ + +.. pkg-section:: executable name + :synopsis: Executable build info section. + + Executable sections (if present) describe executable programs contained + in the package and must have an argument after the section label, which + defines the name of the executable. This is a freeform argument but may + not contain spaces. + +The executable may be described using the following fields, as well as +build information fields (see the section on `build information`_). + +.. pkg-field:: main-is: filename (required) + + The name of the ``.hs`` or ``.lhs`` file containing the ``Main`` + module. Note that it is the ``.hs`` filename that must be listed, + even if that file is generated using a preprocessor. The source file + must be relative to one of the directories listed in + :pkg-field:`hs-source-dirs`. Further, while the name of the file may + vary, the module itself must be named ``Main``. + + Starting with ``cabal-version: 1.18`` this field supports + specifying a C, C++, or objC source file as the main entry point. + +.. pkg-field:: scope: token + :since: 2.0 + + Whether the executable is ``public`` (default) or ``private``, i.e. meant to + be run by other programs rather than the user. Private executables are + installed into `$libexecdir/$libexecsubdir`. + +Running executables +""""""""""""""""""" + +You can have Cabal build and run your executables by using the ``run`` +command: + +.. code-block:: console + + $ cabal run EXECUTABLE [-- EXECUTABLE_FLAGS] + +This command will configure, build and run the executable +``EXECUTABLE``. The double dash separator is required to distinguish +executable flags from ``run``'s own flags. If there is only one +executable defined in the whole package, the executable's name can be +omitted. See the output of ``cabal help run`` for a list of options you +can pass to ``cabal run``. + +Test suites +^^^^^^^^^^^ + +.. pkg-section:: test-suite name + :synopsis: Test suite build information. + + Test suite sections (if present) describe package test suites and must + have an argument after the section label, which defines the name of the + test suite. This is a freeform argument, but may not contain spaces. It + should be unique among the names of the package's other test suites, the + package's executables, and the package itself. Using test suite sections + requires at least Cabal version 1.9.2. + +The test suite may be described using the following fields, as well as +build information fields (see the section on `build information`_). + +.. pkg-field:: type: interface (required until ``cabal-version`` 3.8) + + The interface type and version of the test suite. Cabal supports two + test suite interfaces, called ``exitcode-stdio-1.0`` (default since ``cabal-version`` 3.8) and + ``detailed-0.9``. Each of these types may require or disallow other + fields as described below. + +Test suites using the ``exitcode-stdio-1.0`` (default since ``cabal-version`` 3.8) interface are executables +that indicate test failure with a non-zero exit code when run; they may +provide human-readable log information through the standard output and +error channels. The ``exitcode-stdio-1.0`` type requires the ``main-is`` +field. + +.. pkg-field:: main-is: filename + :synopsis: Module containing tests main function. + + :required: ``exitcode-stdio-1.0`` + :disallowed: ``detailed-0.9`` + + The name of the ``.hs`` or ``.lhs`` file containing the ``Main`` + module. Note that it is the ``.hs`` filename that must be listed, + even if that file is generated using a preprocessor. The source file + must be relative to one of the directories listed in + :pkg-field:`hs-source-dirs`. This field is analogous to the ``main-is`` field + of an executable section. + +Test suites using the ``detailed-0.9`` interface are modules exporting +the symbol ``tests :: IO [Test]``. The ``Test`` type is exported by the +module ``Distribution.TestSuite`` provided by Cabal. For more details, +see the example below. + +The ``detailed-0.9`` interface allows Cabal and other test agents to +inspect a test suite's results case by case, producing detailed human- +and machine-readable log files. The ``detailed-0.9`` interface requires +the :pkg-field:`test-module` field. + +.. pkg-field:: test-module: identifier + + :required: ``detailed-0.9`` + :disallowed: ``exitcode-stdio-1.0`` + + The module exporting the ``tests`` symbol. + +Example: Package using ``exitcode-stdio-1.0`` interface +""""""""""""""""""""""""""""""""""""""""""""""""""""""" + +The example package description and executable source file below +demonstrate the use of the ``exitcode-stdio-1.0`` interface. + +.. code-block:: cabal + :caption: foo.cabal + + Cabal-Version: 3.0 + Name: foo + Version: 1.0 + License: BSD-3-Clause + Build-Type: Simple + + Test-Suite test-foo + type: exitcode-stdio-1.0 + main-is: test-foo.hs + build-depends: base >= 4 && < 5 + default-language: Haskell2010 + +.. code-block:: haskell + :caption: test-foo.hs + + module Main where + + import System.Exit (exitFailure) + + main = do + putStrLn "This test always fails!" + exitFailure + +Example: Package using ``detailed-0.9`` interface +""""""""""""""""""""""""""""""""""""""""""""""""" + +The example package description and test module source file below +demonstrate the use of the ``detailed-0.9`` interface. The test module +also develops a simple implementation of the interface set by +``Distribution.TestSuite``, but in actual usage the implementation would +be provided by the library that provides the testing facility. + +.. code-block:: cabal + :caption: bar.cabal + + Cabal-Version: 3.0 + Name: bar + Version: 1.0 + License: BSD-3-Clause + Build-Type: Simple + + Test-Suite test-bar + type: detailed-0.9 + test-module: Bar + build-depends: base >= 4 && < 5, Cabal >= 1.9.2 && < 2 + default-language: Haskell2010 + + +.. code-block:: haskell + :caption: Bar.hs + + module Bar ( tests ) where + + import Distribution.TestSuite + + tests :: IO [Test] + tests = return [ Test succeeds, Test fails ] + where + succeeds = TestInstance + { run = return $ Finished Pass + , name = "succeeds" + , tags = [] + , options = [] + , setOption = \_ _ -> Right succeeds + } + fails = TestInstance + { run = return $ Finished $ Fail "Always fails!" + , name = "fails" + , tags = [] + , options = [] + , setOption = \_ _ -> Right fails + } + +Running test suites +""""""""""""""""""" + +You can have Cabal run your test suites using its built-in test runner: + +:: + + $ cabal configure --enable-tests + $ cabal build + $ cabal test + +See the output of ``cabal help test`` for a list of options you can pass +to ``cabal test``. + +Benchmarks +^^^^^^^^^^ + +.. pkg-section:: benchmark name + :since: 1.9.2 + :synopsis: Benchmark build information. + + Benchmark sections (if present) describe benchmarks contained in the + package and must have an argument after the section label, which defines + the name of the benchmark. This is a freeform argument, but may not + contain spaces. It should be unique among the names of the package's + other benchmarks, the package's test suites, the package's executables, + and the package itself. Using benchmark sections requires at least Cabal + version 1.9.2. + +The benchmark may be described using the following fields, as well as +build information fields (see the section on `build information`_). + +.. pkg-field:: type: interface (required until ``cabal-version`` 3.8) + + The interface type and version of the benchmark. At the moment Cabal + only support one benchmark interface, called ``exitcode-stdio-1.0``. + +Benchmarks using the ``exitcode-stdio-1.0`` (default since ``cabal-version`` 3.8) interface are executables +that indicate failure to run the benchmark with a non-zero exit code +when run; they may provide human-readable information through the +standard output and error channels. + +.. pkg-field:: main-is: filename + + The name of the ``.hs`` or ``.lhs`` file containing the ``Main`` + module. Note that it is the ``.hs`` filename that must be listed, + even if that file is generated using a preprocessor. The source file + must be relative to one of the directories listed in + :pkg-field:`hs-source-dirs`. This field is analogous to the ``main-is`` + field of an executable section. Further, while the name of the file may + vary, the module itself must be named ``Main``. + +Example: +""""""""""""""""""""""""""""""""""""""""""""""""""""""" + +.. code-block:: cabal + :caption: foo.cabal + :name: foo-bench.cabal + + Cabal-Version: 3.0 + Name: foo + Version: 1.0 + License: BSD-3-Clause + Build-Type: Simple + + Benchmark bench-foo + type: exitcode-stdio-1.0 + main-is: bench-foo.hs + build-depends: base >= 4 && < 5, time >= 1.1 && < 1.7 + default-language: Haskell2010 + +.. code-block:: haskell + :caption: bench-foo.hs + + {-# LANGUAGE BangPatterns #-} + module Main where + + import Data.Time.Clock + + fib 0 = 1 + fib 1 = 1 + fib n = fib (n-1) + fib (n-2) + + main = do + start <- getCurrentTime + let !r = fib 20 + end <- getCurrentTime + putStrLn $ "fib 20 took " ++ show (diffUTCTime end start) + +Running benchmarks +"""""""""""""""""" + +You can have Cabal run your benchmark using its built-in benchmark +runner: + +:: + + $ cabal configure --enable-benchmarks + $ cabal build + $ cabal bench + +See the output of ``cabal help bench`` for a list of options you can +pass to ``cabal bench``. + +Foreign libraries +^^^^^^^^^^^^^^^^^ + +Foreign libraries are system libraries intended to be linked against +programs written in C or other "foreign" languages. They +come in two primary flavours: dynamic libraries (``.so`` files on Linux, +``.dylib`` files on OSX, ``.dll`` files on Windows, etc.) are linked against +executables when the executable is run (or even lazily during +execution), while static libraries (``.a`` files on Linux/OSX, ``.lib`` +files on Windows) get linked against the executable at compile time. + +Foreign libraries only work with GHC 7.8 and later. + +A typical stanza for a foreign library looks like + +:: + + foreign-library myforeignlib + type: native-shared + lib-version-info: 6:3:2 + + if os(Windows) + options: standalone + mod-def-file: MyForeignLib.def + + other-modules: MyForeignLib.SomeModule + MyForeignLib.SomeOtherModule + build-depends: base >=4.7 && <4.9 + hs-source-dirs: src + c-sources: csrc/MyForeignLibWrapper.c + default-language: Haskell2010 + + +.. pkg-section:: foreign-library name + :since: 2.0 + :synopsis: Foreign library build information. + + Build information for `foreign libraries`_. + +.. pkg-field:: type: foreign library type + + Cabal recognizes ``native-static`` and ``native-shared`` here, although + we currently only support building `native-shared` libraries. + +.. pkg-field:: options: foreign library option list + + Options for building the foreign library, typically specific to the + specified type of foreign library. Currently we only support + ``standalone`` here. A standalone dynamic library is one that does not + have any dependencies on other (Haskell) shared libraries; without + the ``standalone`` option the generated library would have dependencies + on the Haskell runtime library (``libHSrts``), the base library + (``libHSbase``), etc. Currently, ``standalone`` *must* be used on Windows + and *must not* be used on any other platform. + +.. pkg-field:: mod-def-file: filename + + This option can only be used when creating dynamic Windows libraries + (that is, when using ``native-shared`` and the ``os`` is ``Windows``). If + used, it must be a path to a *module definition file*. The details of + module definition files are beyond the scope of this document; see the + `GHC `_ + manual for some details and some further pointers. + +.. pkg-field:: lib-version-info: current:revision:age + + This field is currently only used on Linux. + + This field specifies a Libtool-style version-info field that sets + an appropriate ABI version for the foreign library. Note that the + three numbers specified in this field do not directly specify the + actual ABI version: ``6:3:2`` results in library version ``4.2.3``. + + With this field set, the SONAME of the library is set, and symlinks + are installed. + + How you should bump this field on an ABI change depends on the + breakage you introduce: + + - Programs using the previous version may use the new version as + drop-in replacement, and programs using the new version can also + work with the previous one. In other words, no recompiling nor + relinking is needed. In this case, bump ``revision`` only, don't + touch current nor age. + - Programs using the previous version may use the new version as + drop-in replacement, but programs using the new version may use + APIs not present in the previous one. In other words, a program + linking against the new version may fail with "unresolved + symbols" if linking against the old version at runtime: set + revision to 0, bump current and age. + - Programs may need to be changed, recompiled, and relinked in + order to use the new version. Bump current, set revision and age + to 0. + + Also refer to the Libtool documentation on the version-info field. + +.. pkg-field:: lib-version-linux: version + + This field is only used on Linux. + + Specifies the library ABI version directly for foreign libraries + built on Linux: so specifying ``4.2.3`` causes a library + ``libfoo.so.4.2.3`` to be built with SONAME ``libfoo.so.4``, and + appropriate symlinks ``libfoo.so.4`` and ``libfoo.so`` to be + installed. + +Note that typically foreign libraries should export a way to initialize +and shutdown the Haskell runtime. In the example above, this is done by +the ``csrc/MyForeignLibWrapper.c`` file, which might look something like + +.. code-block:: c + + #include + #include "HsFFI.h" + + HsBool myForeignLibInit(void){ + int argc = 2; + char *argv[] = { "+RTS", "-A32m", NULL }; + char **pargv = argv; + + // Initialize Haskell runtime + hs_init(&argc, &pargv); + + // do any other initialization here and + // return false if there was a problem + return HS_BOOL_TRUE; + } + + void myForeignLibExit(void){ + hs_exit(); + } + +With modern ghc regular libraries are installed in directories that contain +package keys. This isn't usually a problem because the package gets registered +in ghc's package DB and so we can figure out what the location of the library +is. Foreign libraries however don't get registered, which means that we'd have +to have a way of finding out where a platform library got installed (other than by +searching the ``lib/`` directory). Instead, we install foreign libraries in +``~/.cabal/lib``, much like we install executables in ``~/.cabal/bin``. + +Build information +^^^^^^^^^^^^^^^^^ +.. pkg-section:: None + +The following fields may be optionally present in a library, executable, +test suite or benchmark section, and give information for the building +of the corresponding library or executable. See also the sections on +`system-dependent parameters`_ and `configurations`_ for a way to supply +system-dependent values for these fields. + +.. pkg-field:: build-depends: library list + + Declares the *library* dependencies required to build the current + package component; see :pkg-field:`build-tool-depends` for + declaring build-time *tool* dependencies. External library + dependencies should be annotated with a version constraint. + + **Library Names** + + External libraries are identified by the package's name they're + provided by, optionally followed by a colon and the library name + (available from ``cabal-version: 3.0``). + If the library name is absent, the main (unnamed) library will be used. + To refer to the main (unnamed) library explicitly, use the name of the + package (``foo:foo``). + Multiple libraries from the same package can be specified with the shorthand + syntax ``pkg:{lib1,lib2}```. + + See section on :ref:`Internal Libraries ` for examples and more + information. + + **Version Constraints** + + Version constraints use the operators ``==, >=, >, <, <=`` and a + version number. Multiple constraints can be combined using ``&&`` or + ``||``. If no version constraint is specified, any version is + assumed to be acceptable. For example: + + :: + + library + build-depends: + base >= 2, + foo >= 1.2.3 && < 1.3, + bar + + Dependencies like ``foo >= 1.2.3 && < 1.3`` turn out to be very + common because it is recommended practice for package versions to + correspond to API versions (see PVP_). + + Since Cabal 1.6, there is a special wildcard syntax to help with + such ranges + + :: + + build-depends: foo ==1.2.* + + It is only syntactic sugar. It is exactly equivalent to + ``foo >= 1.2 && < 1.3``. + + .. Warning:: + + A potential pitfall of the wildcard syntax is that the + constraint ``nats == 1.0.*`` doesn't match the release + ``nats-1`` because the version ``1`` is lexicographically less + than ``1.0``. This is not an issue with the caret-operator + ``^>=`` described below. + + Starting with Cabal 2.0, there's a new version operator to express + PVP_-style major upper bounds conveniently, and is inspired by similar + syntactic sugar found in other language ecosystems where it's often + called the "Caret" operator: + + :: + + build-depends: + foo ^>= 1.2.3.4, + bar ^>= 1 + + This allows to assert the positive knowledge that this package is + *known* to be semantically compatible with the releases + ``foo-1.2.3.4`` and ``bar-1`` respectively. The information + encoded via such ``^>=``-assertions is used by the cabal solver to + infer version constraints describing semantically compatible + version ranges according to the PVP_ contract (see below). + + Another way to say this is that ``foo < 1.3`` expresses *negative* + information, i.e. "``foo-1.3`` or ``foo-1.4.2`` will *not* be + compatible"; whereas ``foo ^>= 1.2.3.4`` asserts the *positive* + information that "``foo-1.2.3.4`` is *known* to be compatible" and (in + the absence of additional information) according to the PVP_ + contract we can (positively) infer right away that all versions + satisfying ``foo >= 1.2.3.4 && < 1.3`` will be compatible as well. + + .. Note:: + + More generally, the PVP_ contract implies that we can safely + relax the lower bound to ``>= 1.2``, because if we know that + ``foo-1.2.3.4`` is semantically compatible, then so is + ``foo-1.2`` (if it typechecks). But we'd need to perform + additional static analysis (i.e. perform typechecking) in order + to know if our package in the role of an API consumer will + successfully typecheck against the dependency ``foo-1.2``. But + since we cannot do this analysis during constraint solving and + to keep things simple, we pragmatically use ``foo >= 1.2.3.4`` + as the initially inferred approximation for the lower bound + resulting from the assertion ``foo ^>= 1.2.3.4``. If further + evidence becomes available that e.g. ``foo-1.2`` typechecks, + one can simply revise the dependency specification to include + the assertion ``foo ^>= 1.2``. + + The subtle but important difference in signaling allows tooling to + treat explicitly expressed ``<``-style constraints and inferred + (``^>=``-style) upper bounds differently. For instance, + :cfg-field:`allow-newer`'s ``^``-modifier allows to relax only + ``^>=``-style bounds while leaving explicitly stated + ``<``-constraints unaffected. + + Ignoring the signaling intent, the default syntactic desugaring rules are + + - ``^>= x`` == ``>= x && < x.1`` + - ``^>= x.y`` == ``>= x.y && < x.(y+1)`` + - ``^>= x.y.z`` == ``>= x.y.z && < x.(y+1)`` + - ``^>= x.y.z.u`` == ``>= x.y.z.u && < x.(y+1)`` + - etc. + + .. Note:: + + One might expect the desugaring to truncate all version + components below (and including) the patch-level, i.e. + ``^>= x.y.z.u`` == ``>= x.y.z && < x.(y+1)``, + as the major and minor version components alone are supposed to + uniquely identify the API according to the PVP_. However, by + designing ``^>=`` to be closer to the ``>=`` operator, we avoid + the potentially confusing effect of ``^>=`` being more liberal + than ``>=`` in the presence of patch-level versions. + + Consequently, the example declaration above is equivalent to + + :: + + build-depends: + foo >= 1.2.3.4 && < 1.3, + bar >= 1 && < 1.1 + + .. Note:: + + Prior to Cabal 1.8, ``build-depends`` specified in each + section were global to all sections. This was unintentional, but + some packages were written to depend on it, so if you need your + :pkg-field:`build-depends` to be local to each section, you must specify + at least ``Cabal-Version: >= 1.8`` in your ``.cabal`` file. + + .. Note:: + + Cabal 1.20 experimentally supported module thinning and + renaming in ``build-depends``; however, this support has since been + removed and should not be used. + + Starting with Cabal 3.0, a set notation for the ``==`` and ``^>=`` operator + is available. For instance, + + :: + + tested-with: GHC == 8.6.3, GHC == 8.4.4, GHC == 8.2.2, GHC == 8.0.2, + GHC == 7.10.3, GHC == 7.8.4, GHC == 7.6.3, GHC == 7.4.2 + + build-depends: network ^>= 2.6.3.6 || ^>= 2.7.0.2 || ^>= 2.8.0.0 || ^>= 3.0.1.0 + + can be then written in a more convenient and concise form + + :: + + tested-with: GHC == { 8.6.3, 8.4.4, 8.2.2, 8.0.2, 7.10.3, 7.8.4, 7.6.3, 7.4.2 } + + build-depends: network ^>= { 2.6.3.6, 2.7.0.2, 2.8.0.0, 3.0.1.0 } + + +.. pkg-field:: other-modules: identifier list + + A list of modules used by the component but not exposed to users. + For a library component, these would be hidden modules of the + library. For an executable, these would be auxiliary modules to be + linked with the file named in the ``main-is`` field. + + .. Note:: + + Every module in the package *must* be listed in one of + :pkg-field:`other-modules`, :pkg-field:`library:exposed-modules` or + :pkg-field:`executable:main-is` fields. + +.. pkg-field:: hs-source-dir: directory list + :deprecated: 2.0 + :removed: 3.0 + + :default: ``.`` + + Root directories for the module hierarchy. + + Deprecated in favor of :pkg-field:`hs-source-dirs`. + +.. pkg-field:: hs-source-dirs: directory list + + :default: ``.`` + + Root directories for the module hierarchy. + + .. note:: + + Components can share source directories but modules found there will be + recompiled even if other components already built them, i.e., if a + library and an executable share a source directory and the executable + depends on the library and imports its ``Foo`` module, ``Foo`` will be + compiled twice, once as part of the library and again for the executable. + +.. pkg-field:: default-extensions: identifier list + :since: 1.12 + + A list of Haskell extensions used by every module. These determine + corresponding compiler options enabled for all files. Extension + names are the constructors of the + `Extension `__ + type. For example, ``CPP`` specifies that Haskell source files are + to be preprocessed with a C preprocessor. + +.. pkg-field:: other-extensions: identifier list + :since: 1.12 + + A list of Haskell extensions used by some (but not necessarily all) + modules. From GHC version 6.6 onward, these may be specified by + placing a ``LANGUAGE`` pragma in the source files affected e.g. + + .. code-block:: haskell + + {-# LANGUAGE CPP, MultiParamTypeClasses #-} + + In Cabal-1.24 the dependency solver will use this and + :pkg-field:`default-extensions` information. Cabal prior to 1.24 will abort + compilation if the current compiler doesn't provide the extensions. + + If you use some extensions conditionally, using CPP or conditional + module lists, it is good to replicate the condition in + :pkg-field:`other-extensions` declarations: + + :: + + other-extensions: CPP + if impl(ghc >= 7.5) + other-extensions: PolyKinds + + You could also omit the conditionally used extensions, as they are + for information only, but it is recommended to replicate them in + :pkg-field:`other-extensions` declarations. + +.. pkg-field:: default-language: identifier + :since: 1.12 + + TBW + +.. pkg-field:: other-languages: identifier + :since: 1.12 + + TBW + +.. pkg-field:: extensions: identifier list + :deprecated: 1.12 + :removed: 3.0 + + Deprecated in favor of :pkg-field:`default-extensions`. + +.. pkg-field:: build-tool-depends: package:executable list + :since: 2.0 + + A list of Haskell executables needed to build this component. Executables are provided + during the whole duration of the component, so this field can be used for executables + needed during :pkg-section:`test-suite` as well. + + Each is specified by the package containing the executable and the name of the + executable itself, separated by a colon, and optionally followed by a version bound. + + All executables defined in the given Cabal file are termed as *internal* dependencies + as opposed to the rest which are *external* dependencies. + + Each of the two is handled differently: + + 1. External dependencies can (and should) contain a version bound like conventional + :pkg-field:`build-depends` dependencies. + 2. Internal dependencies should not contain a version bound, as they will be always + resolved within the same configuration of the package in the build plan. + Specifically, version bounds that include the package's version will be warned for + being extraneous, and version bounds that exclude the package's version will raise + an error for being impossible to follow. + + For example (1) using a test-suite to make sure README.md Haskell snippets are tested using + `markdown-unlit `__: + + :: + + build-tool-depends: markdown-unlit:markdown-unlit >= 0.5.0 && < 0.6 + + For example (2) using a test-suite to test executable behaviour in the same package: + + :: + + build-tool-depends: mypackage:executable + + Cabal tries to make sure that all specified programs are atomically built and prepended + on the ``PATH`` shell variable before building the component in question, but can only do + so for Nix-style builds. Specifically: + + a) For Nix-style local builds, both internal and external dependencies. + b) For old-style builds, only for internal dependencies [#old-style-build-tool-depends]_. + It's up to the user to provide needed executables in this case under ``PATH``. + + + .. note:: + + :pkg-field:`build-tool-depends` was added in Cabal 2.0, and it will + be ignored (with a warning) with old versions of Cabal. See + :pkg-field:`build-tools` for more information about backwards + compatibility. + +.. pkg-field:: build-tools: program list + :deprecated: 2.0 + :removed: 3.0 + + Deprecated in favor of :pkg-field:`build-tool-depends`, but :ref:`see below for backwards compatibility information `. + + A list of Haskell programs needed to build this component. + Each may be followed by an optional version bound. + Confusingly, each program in the list either refer to one of three things: + + 1. Another executables in the same package (supported since Cabal 1.12) + + 2. Tool name contained in Cabal's :ref:`hard-coded set of common tools ` + + 3. A pre-built executable that should already be on the ``PATH`` + (supported since Cabal 2.0) + + These cases are listed in order of priority: + an executable in the package will override any of the hard-coded packages with the same name, + and a hard-coded package will override any executable on the ``PATH``. + + In the first two cases, the list entry is desugared into a :pkg-field:`build-tool-depends` entry. + In the first case, the entry is desugared into a :pkg-field:`build-tool-depends` entry by prefixing with ``$pkg:``. + In the second case, it is desugared by looking up the package and executable name in a hard-coded table. + In either case, the optional version bound is passed through unchanged. + Refer to the documentation for :pkg-field:`build-tool-depends` to understand the desugared field's meaning, along with restrictions on version bounds. + + .. _buildtoolsbc: + + **Backward Compatibility** + + Although this field is deprecated in favor of :pkg-field:`build-tool-depends`, there are some situations where you may prefer to use :pkg-field:`build-tools` in cases (1) and (2), as it is supported by more versions of Cabal. + In case (3), :pkg-field:`build-tool-depends` is better for backwards-compatibility, as it will be ignored by old versions of Cabal; if you add the executable to :pkg-field:`build-tools`, a setup script built against old Cabal will choke. + If an old version of Cabal is used, an end-user will have to manually arrange for the requested executable to be in your ``PATH``. + + .. _buildtoolsmap: + + **Set of Known Tool Names** + + Identifiers specified in :pkg-field:`build-tools` are desugared into their respective equivalent :pkg-field:`build-tool-depends` form according to the table below. Consequently, a legacy specification such as:: + + build-tools: alex >= 3.2.1 && < 3.3, happy >= 1.19.5 && < 1.20 + + is simply desugared into the equivalent specification:: + + build-tool-depends: alex:alex >= 3.2.1 && < 3.3, happy:happy >= 1.19.5 && < 1.20 + + +--------------------------+-----------------------------------+-----------------+ + | :pkg-field:`build-tools` | desugared | Note | + | identifier | :pkg-field:`build-tool-depends` | | + | | identifier | | + +==========================+===================================+=================+ + | ``alex`` | ``alex:alex`` | | + +--------------------------+-----------------------------------+-----------------+ + | ``c2hs`` | ``c2hs:c2hs`` | | + +--------------------------+-----------------------------------+-----------------+ + | ``cpphs`` | ``cpphs:cpphs`` | | + +--------------------------+-----------------------------------+-----------------+ + | ``greencard`` | ``greencard:greencard`` | | + +--------------------------+-----------------------------------+-----------------+ + | ``haddock`` | ``haddock:haddock`` | | + +--------------------------+-----------------------------------+-----------------+ + | ``happy`` | ``happy:happy`` | | + +--------------------------+-----------------------------------+-----------------+ + | ``hsc2hs`` | ``hsc2hs:hsc2hs`` | | + +--------------------------+-----------------------------------+-----------------+ + | ``hscolour`` | ``hscolour:hscolour`` | | + +--------------------------+-----------------------------------+-----------------+ + | ``hspec-discover`` | ``hspec-discover:hspec-discover`` | since Cabal 2.0 | + +--------------------------+-----------------------------------+-----------------+ + + This built-in set can be programmatically extended via ``Custom`` setup scripts; this, however, is of limited use since the Cabal solver cannot access information injected by ``Custom`` setup scripts. + +.. pkg-field:: buildable: boolean + + :default: ``True`` + + Is the component buildable? Like some of the other fields below, + this field is more useful with the slightly more elaborate form of + the simple build infrastructure described in the section on + `system-dependent parameters`_. + +.. pkg-field:: ghc-options: token list + + Additional options for GHC. You can often achieve the same effect + using the :pkg-field:`default-extensions` field, which is preferred. + + Options required only by one module may be specified by placing an + ``OPTIONS_GHC`` pragma in the source file affected. + + As with many other fields, whitespace can be escaped by using + Haskell string syntax. Example: + ``ghc-options: -Wcompat "-with-rtsopts=-T -I1" -Wall``. + +.. pkg-field:: ghc-prof-options: token list + + Additional options for GHC when the package is built with profiling + enabled. + + Note that as of Cabal-1.24, the default profiling detail level + defaults to ``exported-functions`` for libraries and + ``toplevel-functions`` for executables. For GHC these correspond to + the flags ``-fprof-auto-exported`` and ``-fprof-auto-top``. Prior to + Cabal-1.24 the level defaulted to ``none``. These levels can be + adjusted by the person building the package with the + ``--profiling-detail`` and ``--library-profiling-detail`` flags. + + It is typically better for the person building the package to pick + the profiling detail level rather than for the package author. So + unless you have special needs it is probably better not to specify + any of the GHC ``-fprof-auto*`` flags here. However if you wish to + override the profiling detail level, you can do so using the + :pkg-field:`ghc-prof-options` field: use ``-fno-prof-auto`` or one of the + other ``-fprof-auto*`` flags. + +.. pkg-field:: ghc-shared-options: token list + + Additional options for GHC when the package is built as shared + library. The options specified via this field are combined with the + ones specified via :pkg-field:`ghc-options`, and are passed to GHC during + both the compile and link phases. + +.. pkg-field:: ghcjs-options: token list + + Like :pkg-field:`ghc-options` but applies to GHCJS + +.. pkg-field:: ghcjs-prof-options: token list + + Like :pkg-field:`ghc-prof-options` but applies to GHCJS + +.. pkg-field:: ghcjs-shared-options: token list + + Like :pkg-field:`ghc-shared-options` but applies to GHCJS + +.. pkg-field:: includes: filename list + + A list of header files to be included in any compilations via C. + This field applies to both header files that are already installed + on the system and to those coming with the package to be installed. + The former files should be found in absolute paths, while the latter + files should be found in paths relative to the top of the source + tree or relative to one of the directories listed in + :pkg-field:`include-dirs`. + + These files typically contain function prototypes for foreign + imports used by the package. This is in contrast to + :pkg-field:`install-includes`, which lists header files that are intended + to be exposed to other packages that transitively depend on this + library. + +.. pkg-field:: install-includes: filename list + + A list of header files from this package to be installed into + ``$libdir/includes`` when the package is installed. Files listed in + :pkg-field:`install-includes` should be found in relative to the top of the + source tree or relative to one of the directories listed in + :pkg-field:`include-dirs`. + + :pkg-field:`install-includes` is typically used to name header files that + contain prototypes for foreign imports used in Haskell code in this + package, for which the C implementations are also provided with the + package. For example, here is a ``.cabal`` file for a hypothetical + ``bindings-clib`` package that bundles the C source code for ``clib``:: + + include-dirs: cbits + c-sources: clib.c + install-includes: clib.h + + Now any package that depends (directly or transitively) on the + ``bindings-clib`` library can use ``clib.h``. + + Note that in order for files listed in :pkg-field:`install-includes` to be + usable when compiling the package itself, they need to be listed in + the :pkg-field:`includes` field as well. + +.. pkg-field:: include-dirs: directory list + + A list of directories to search for header files, when preprocessing + with ``c2hs``, ``hsc2hs``, ``cpphs`` or the C preprocessor, and also + when compiling via C. Directories can be absolute paths (e.g., for + system directories) or paths that are relative to the top of the + source tree. Cabal looks in these directories when attempting to + locate files listed in :pkg-field:`includes` and + :pkg-field:`install-includes`. + +.. pkg-field:: c-sources: filename list + + A list of C source files to be compiled and linked with the Haskell + files. + +.. pkg-field:: cxx-sources: filename list + :since: 2.2 + + A list of C++ source files to be compiled and linked with the Haskell + files. Useful for segregating C and C++ sources when supplying different + command-line arguments to the compiler via the :pkg-field:`cc-options` + and the :pkg-field:`cxx-options` fields. The files listed in the + :pkg-field:`cxx-sources` can reference files listed in the + :pkg-field:`c-sources` field and vice-versa. The object files will be linked + appropriately. + +.. pkg-field:: asm-sources: filename list + :since: 3.0 + + A list of assembly source files to be compiled and linked with the + Haskell files. + +.. pkg-field:: cmm-sources: filename list + :since: 3.0 + + A list of C-- source files to be compiled and linked with the Haskell + files. + +.. pkg-field:: js-sources: filename list + + A list of JavaScript source files to be linked with the Haskell + files (only for JavaScript targets). + +.. pkg-field:: extra-libraries: token list + + A list of extra libraries to link with (when not linking fully static + executables). + +.. pkg-field:: extra-libraries-static: token list + + A list of extra libraries to link with (when linking fully static + executables). + +.. pkg-field:: extra-ghci-libraries: token list + + A list of extra libraries to be used instead of 'extra-libraries' + when the package is loaded with GHCi. + +.. pkg-field:: extra-bundled-libraries: token list + :since: 2.2 + + A list of libraries that are supposed to be copied from the build + directory alongside the produced Haskell libraries. Note that you + are under the obligation to produce those libraries in the build + directory (e.g. via a custom setup). Libraries listed here will + be included when ``copy``-ing packages and be listed in the + ``hs-libraries`` of the package configuration in the package database. + Library names must either be prefixed with "HS" or "C" and corresponding + library file names must match: + + - Libraries with name "HS": + - `libHS.a` + - `libHS-ghc.*` + - Libraries with name "C": + - `libC.a` + - `lib.*` + +.. pkg-field:: extra-lib-dirs: directory list + + A list of directories to search for libraries (when not linking fully static + executables). + +.. pkg-field:: extra-lib-dirs-static: directory list + + A list of directories to search for libraries (when linking fully static + executables). + +.. pkg-field:: extra-library-flavours: notsure + + TBW + +.. pkg-field:: extra-dynamic-library-flavours: notsure + + TBW + +.. pkg-field:: cc-options: token list + + Command-line arguments to be passed to the C compiler. Since the + arguments are compiler-dependent, this field is more useful with the + setup described in the section on `system-dependent parameters`_. + +.. pkg-field:: cpp-options: token list + + Command-line arguments for pre-processing Haskell code. Applies to + Haskell source and other pre-processed Haskell source like .hsc + .chs. Does not apply to C code, that's what cc-options is for. + +.. pkg-field:: cxx-options: token list + :since: 2.2 + + Command-line arguments to be passed to the compiler when compiling + C++ code. The C++ sources to which these command-line arguments + should be applied can be specified with the :pkg-field:`cxx-sources` + field. Command-line options for C and C++ can be passed separately to + the compiler when compiling both C and C++ sources by segregating the C + and C++ sources with the :pkg-field:`c-sources` and + :pkg-field:`cxx-sources` fields respectively, and providing different + command-line arguments with the :pkg-field:`cc-options` and the + :pkg-field:`cxx-options` fields. + +.. pkg-field:: cmm-options: token list + :since: 3.0 + + Command-line arguments to be passed to the compiler when compiling + C-- code. See also :pkg-field:`cmm-sources`. + +.. pkg-field:: asm-options: token list + :since: 3.0 + + Command-line arguments to be passed to the assembler when compiling + assembler code. See also :pkg-field:`asm-sources`. + +.. pkg-field:: ld-options: token list + + Command-line arguments to be passed to the linker. Since the + arguments are compiler-dependent, this field is more useful with the + setup described in the section on `system-dependent parameters`_. + +.. pkg-field:: hsc2hs-options: token list + :since: 3.6 + + Command-line arguments to be passed to ``hsc2hs``. + +.. pkg-field:: pkgconfig-depends: package list + + A list of + `pkg-config `__ + packages, needed to build this package. They can be annotated with + versions, e.g. ``gtk+-2.0 >= 2.10, cairo >= 1.0``. If no version + constraint is specified, any version is assumed to be acceptable. + Cabal uses ``pkg-config`` to find if the packages are available on + the system and to find the extra compilation and linker options + needed to use the packages. + + If you need to bind to a C library that supports ``pkg-config`` then + it is much preferable to use this field rather than hard code options + into the other fields. ``pkg-config --list-all`` will show you all + supported libraries. Depending on your system you may need to adjust + ``PKG_CONFIG_PATH``. + +.. pkg-field:: frameworks: token list + + On Darwin/MacOS X, a list of frameworks to link to. See Apple's + developer documentation for more details on frameworks. This entry + is ignored on all other platforms. + +.. pkg-field:: extra-framework-dirs: directory list + :since: 1.24 + + On Darwin/MacOS X, a list of directories to search for frameworks. + This entry is ignored on all other platforms. + +.. pkg-field:: mixins: mixin list + :since: 2.0 + + Supported only in GHC 8.2 and later. A list of packages mentioned in the + :pkg-field:`build-depends` field, each optionally accompanied by a list of + module and module signature renamings. A valid mixin obeys the + following syntax: + + :: + + Mixin ::= PackageName IncludeRenaming + IncludeRenaming ::= ModuleRenaming { "requires" ModuleRenaming } + ModuleRenaming ::= + {- empty -} + | "(" Renaming "," ... "," Renaming ")" + | "hiding" "(" ModuleName "," ... "," ModuleName ")" + Renaming ::= + ModuleName + | ModuleName "as" ModuleName + + The simplest mixin syntax is simply the name of a package mentioned in the + :pkg-field:`build-depends` field. For example: + + :: + + library + build-depends: + foo ^>= 1.2.3 + mixins: + foo + + But this doesn't have any effect. More interesting is to use the mixin + entry to rename one or more modules from the package, like this: + + :: + + library + mixins: + foo (Foo.Bar as AnotherFoo.Bar, Foo.Baz as AnotherFoo.Baz) + + Note that renaming a module like this will hide all the modules + that are not explicitly named. + + Modules can also be hidden: + + :: + + library: + mixins: + foo hiding (Foo.Bar) + + Hiding modules exposes everything that is not explicitly hidden. + + .. Note:: + + Cabal files with :pkg-field:`cabal-version` < 3.0 suffer from an + infelicity in how the entries of :pkg-field:`mixins` are parsed: an + entry will fail to parse if the provided renaming clause has whitespace + after the opening parenthesis. + + See issues :issue:`5150`, :issue:`4864`, and :issue:`5293`. + + There can be multiple mixin entries for a given package, in effect creating + multiple copies of the dependency: + + :: + + library + mixins: + foo (Foo.Bar as AnotherFoo.Bar, Foo.Baz as AnotherFoo.Baz), + foo (Foo.Bar as YetAnotherFoo.Bar) + + The ``requires`` clause is used to rename the module signatures required by + a package: + + :: + + library + mixins: + foo (Foo.Bar as AnotherFoo.Bar) requires (Foo.SomeSig as AnotherFoo.SomeSig) + + Signature-only packages don't have any modules, so only the signatures can + be renamed, with the following syntax: + + :: + + library + mixins: + sigonly requires (SigOnly.SomeSig as AnotherSigOnly.SomeSig) + + See the :pkg-field:`library:signatures` field for more details. + + Mixin packages are part of the Backpack_ extension to the + Haskell module system. + + The matching of the module signatures required by a + :pkg-field:`build-depends` dependency with the implementation modules + present in another dependency is triggered by a coincidence of names. When + the names of the signature and of the implementation are already the same, + the matching is automatic. But when the names don't coincide, or we want to + instantiate a signature in two different ways, adding mixin entries that + perform renamings becomes necessary. + + .. Warning:: + + Backpack_ has the limitation that implementation modules that instantiate + signatures required by a :pkg-field:`build-depends` dependency can't + reside in the same component that has the dependency. They must reside + in a different package dependency, or at least in a separate internal + library. + +Configurations +^^^^^^^^^^^^^^ + +Library and executable sections may include conditional blocks, which +test for various system parameters and configuration flags. The flags +mechanism is rather generic, but most of the time a flag represents +certain feature, that can be switched on or off by the package user. +Here is an example package description file using configurations: + +Example: A package containing a library and executable programs +""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""" + +:: + + Cabal-Version: 3.0 + Name: Test1 + Version: 0.0.1 + License: BSD-3-Clause + Author: Jane Doe + Synopsis: Test package to test configurations + Category: Example + Build-Type: Simple + + Flag Debug + Description: Enable debug support + Default: False + Manual: True + + Flag WebFrontend + Description: Include API for web frontend. + Default: False + Manual: True + + Flag NewDirectory + description: Whether to build against @directory >= 1.2@ + -- This is an automatic flag which the solver will + -- assign automatically while searching for a solution + + Library + Build-Depends: base >= 4.2 && < 4.9 + Exposed-Modules: Testing.Test1 + Default-Extensions: CPP + Default-Language: Haskell2010 + + GHC-Options: -Wall + if flag(Debug) + CPP-Options: -DDEBUG + if !os(windows) + CC-Options: "-DDEBUG" + else + CC-Options: "-DNDEBUG" + + if flag(WebFrontend) + Build-Depends: cgi >= 0.42 && < 0.44 + Other-Modules: Testing.WebStuff + CPP-Options: -DWEBFRONTEND + + if flag(NewDirectory) + build-depends: directory >= 1.2 && < 1.4 + Build-Depends: time >= 1.0 && < 1.9 + else + build-depends: directory == 1.1.* + Build-Depends: old-time >= 1.0 && < 1.2 + + Executable test1 + Main-is: T1.hs + Other-Modules: Testing.Test1 + Build-Depends: base >= 4.2 && < 4.9 + Default-Language: Haskell2010 + + if flag(debug) + CC-Options: "-DDEBUG" + CPP-Options: -DDEBUG + +Layout +"""""" + +Flags, conditionals, library and executable sections use layout to +indicate structure. This is very similar to the Haskell layout rule. +Entries in a section have to all be indented to the same level which +must be more than the section header. Tabs are not allowed to be used +for indentation. + +As an alternative to using layout you can also use explicit braces +``{}``. In this case the indentation of entries in a section does not +matter, though different fields within a block must be on different +lines. Here is a bit of the above example again, using braces: + +Example: Using explicit braces rather than indentation for layout +""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""" + +:: + + Cabal-Version: 3.0 + Name: Test1 + Version: 0.0.1 + License: BSD-3-Clause + Author: Jane Doe + Synopsis: Test package to test configurations + Category: Example + Build-Type: Simple + + Flag Debug { + Description: Enable debug support + Default: False + Manual: True + } + + Library { + Build-Depends: base >= 4.2 && < 4.9 + Exposed-Modules: Testing.Test1 + Default-Extensions: CPP + Default-language: Haskell2010 + if flag(debug) { + CPP-Options: -DDEBUG + if !os(windows) { + CC-Options: "-DDEBUG" + } else { + CC-Options: "-DNDEBUG" + } + } + } + +Configuration Flags +""""""""""""""""""" + +.. pkg-section:: flag name + :synopsis: Flag declaration. + + Flag section declares a flag which can be used in `conditional blocks`_. + + Flag names are case-insensitive and must match ``[[:alnum:]_][[:alnum:]_-]*`` + regular expression, or expressed as ABNF_: + + .. code-block:: abnf + + flag-name = (UALNUM / "_") *(UALNUM / "_" / "-") + + UALNUM = UALPHA / DIGIT + UALPHA = ... ; set of alphabetic Unicode code-points + + .. note:: + + Hackage accepts ASCII-only flags, ``[a-zA-Z0-9_][a-zA-Z0-9_-]*`` regexp. + +.. pkg-field:: description: freeform + + The description of this flag. + +.. pkg-field:: default: boolean + + :default: ``True`` + + The default value of this flag. + + .. note:: + + This value may be :ref:`overridden in several + ways `. The + rationale for having flags default to True is that users usually + want new features as soon as they are available. Flags representing + features that are not (yet) recommended for most users (such as + experimental features or debugging support) should therefore + explicitly override the default to False. + +.. pkg-field:: manual: boolean + + :default: ``False`` + :since: 1.6 + + By default, Cabal will first try to satisfy dependencies with the + default flag value and then, if that is not possible, with the + negated value. However, if the flag is manual, then the default + value (which can be overridden by commandline flags) will be used. + +Conditional Blocks +^^^^^^^^^^^^^^^^^^ + +Conditional blocks may appear anywhere inside a library or executable +section. They have to follow rather strict formatting rules. Conditional +blocks must always be of the shape + +:: + + if condition + property-descriptions-or-conditionals + +or + +:: + + if condition + property-descriptions-or-conditionals + else + property-descriptions-or-conditionals + +Note that the ``if`` and the condition have to be all on the same line. + +Since Cabal 2.2 conditional blocks support ``elif`` construct. + +:: + + if condition1 + property-descriptions-or-conditionals + elif condition2 + property-descriptions-or-conditionals + else + property-descriptions-or-conditionals + +.. _conditions: + +Conditions +"""""""""" + +Conditions can be formed using boolean tests and the boolean operators +``||`` (disjunction / logical "or"), ``&&`` (conjunction / logical +"and"), or ``!`` (negation / logical "not"). The unary ``!`` takes +highest precedence, ``||`` takes lowest. Precedence levels may be +overridden through the use of parentheses. For example, +``os(darwin) && !arch(i386) || os(freebsd)`` is equivalent to +``(os(darwin) && !(arch(i386))) || os(freebsd)``. + +The following tests are currently supported. + +:samp:`os({name})` + Tests if the current operating system is *name*. The argument is + tested against ``System.Info.os`` on the target system. There is + unfortunately some disagreement between Haskell implementations + about the standard values of ``System.Info.os``. Cabal canonicalises + it so that in particular ``os(windows)`` works on all + implementations. If the canonicalised os names match, this test + evaluates to true, otherwise false. The match is case-insensitive. +:samp:`arch({name})` + Tests if the current architecture is *name*. The argument is matched + against ``System.Info.arch`` on the target system. If the arch names + match, this test evaluates to true, otherwise false. The match is + case-insensitive. +:samp:`impl({compiler})` + Tests for the configured Haskell implementation. An optional version + constraint may be specified (for example ``impl(ghc >= 6.6.1)``). If + the configured implementation is of the right type and matches the + version constraint, then this evaluates to true, otherwise false. + The match is case-insensitive. + + Note that including a version constraint in an ``impl`` test causes + it to check for two properties: + + - The current compiler has the specified name, and + + - The compiler's version satisfied the specified version constraint + + As a result, ``!impl(ghc >= x.y.z)`` is not entirely equivalent to + ``impl(ghc < x.y.z)``. The test ``!impl(ghc >= x.y.z)`` checks that: + + - The current compiler is not GHC, or + + - The version of GHC is earlier than version x.y.z. + +:samp:`flag({name})` + Evaluates to the current assignment of the flag of the given name. + Flag names are case insensitive. Testing for flags that have not + been introduced with a flag section is an error. +``true`` + Constant value true. +``false`` + Constant value false. + +.. _resolution-of-conditions-and-flags: + +Resolution of Conditions and Flags +"""""""""""""""""""""""""""""""""" + +If a package descriptions specifies configuration flags the package user +can :ref:`control these in several ways `. If the +user does not fix the value of a flag, Cabal will try to find a flag +assignment in the following way. + +- For each flag specified, it will assign its default value, evaluate + all conditions with this flag assignment, and check if all + dependencies can be satisfied. If this check succeeded, the package + will be configured with those flag assignments. + +- If dependencies were missing, the last flag (as by the order in which + the flags were introduced in the package description) is tried with + its alternative value and so on. This continues until either an + assignment is found where all dependencies can be satisfied, or all + possible flag assignments have been tried. + +To put it another way, Cabal does a complete backtracking search to find +a satisfiable package configuration. It is only the dependencies +specified in the :pkg-field:`build-depends` field in conditional blocks that +determine if a particular flag assignment is satisfiable +(:pkg-field:`build-tools` are not considered). The order of the declaration and +the default value of the flags determines the search order. Flags +overridden on the command line fix the assignment of that flag, so no +backtracking will be tried for that flag. + +If no suitable flag assignment could be found, the configuration phase +will fail and a list of missing dependencies will be printed. Note that +this resolution process is exponential in the worst case (i.e., in the +case where dependencies cannot be satisfied). There are some +optimizations applied internally, but the overall complexity remains +unchanged. + +Meaning of field values when using conditionals +^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +During the configuration phase, a flag assignment is chosen, all +conditionals are evaluated, and the package description is combined into +a flat package descriptions. If the same field is declared both inside +a conditional and outside then they are combined using the following rules. + +- Boolean fields are combined using conjunction (logical "and"). + +- List fields are combined by appending the inner items to the outer + items, for example + + :: + + other-extensions: CPP + if impl(ghc) + other-extensions: MultiParamTypeClasses + + when compiled using GHC will be combined to + + :: + + other-extensions: CPP, MultiParamTypeClasses + + Similarly, if two conditional sections appear at the same nesting + level, properties specified in the latter will come after properties + specified in the former. + +- All other fields must not be specified in ambiguous ways. For example + + :: + + Main-is: Main.hs + if flag(useothermain) + Main-is: OtherMain.hs + + will lead to an error. Instead use + + :: + + if flag(useothermain) + Main-is: OtherMain.hs + else + Main-is: Main.hs + +.. _common-stanzas: + +Common stanzas +^^^^^^^^^^^^^^ + +.. pkg-section:: common name + :since: 2.2 + :synopsis: Common build info section + +Starting with Cabal-2.2 it's possible to use common build info stanzas. + +:: + + common deps + build-depends: base ^>= 4.11 + ghc-options: -Wall + + common test-deps + build-depends: tasty ^>= 0.12.0.1 + + library + import: deps + exposed-modules: Foo + default-language: Haskell2010 + + test-suite tests + import: deps, test-deps + type: exitcode-stdio-1.0 + main-is: Tests.hs + build-depends: foo + default-language: Haskell2010 + +- You can use `build information`_ fields in common stanzas. + +- Common stanzas must be defined before use. + +- Common stanzas can import other common stanzas. + +- You can import multiple stanzas at once. Stanza names must be separated by commas. + +- ``import`` must be the first field in a section. Since Cabal 3.0 imports + are also allowed inside conditionals. + +.. Note:: + + The name `import` was chosen, because there is ``includes`` field. + +.. pkg-section:: None + +.. pkg-field:: import: token-list + + TBW + +Source Repositories +^^^^^^^^^^^^^^^^^^^ + +.. pkg-section:: source-repository + :since: 1.6 + +It is often useful to be able to specify a source revision control +repository for a package. Cabal lets you specify this information in +a relatively structured form which enables other tools to interpret and +make effective use of the information. For example the information +should be sufficient for an automatic tool to checkout the sources. + +Cabal supports specifying different information for various common +source control systems. Obviously not all automated tools will support +all source control systems. + +Cabal supports specifying repositories for different use cases. By +declaring which case we mean automated tools can be more useful. There +are currently two kinds defined: + +- The ``head`` kind refers to the latest development branch of the + package. This may be used for example to track activity of a project + or as an indication to outside developers what sources to get for + making new contributions. + +- The ``this`` kind refers to the branch and tag of a repository that + contains the sources for this version or release of a package. For + most source control systems this involves specifying a tag, id or + hash of some form and perhaps a branch. The purpose is to be able to + reconstruct the sources corresponding to a particular package + version. This might be used to indicate what sources to get if + someone needs to fix a bug in an older branch that is no longer an + active head branch. + +You can specify one kind or the other or both. As an example here are +the repositories for the Cabal library. Note that the ``this`` kind of +repository specifies a tag. + +:: + + source-repository head + type: git + location: https://github.com/haskell/cabal + + source-repository this + type: git + location: https://github.com/haskell/cabal + tag: 1.6.1 + +The exact fields are as follows: + +.. pkg-field:: type: token + + The name of the source control system used for this repository. The + currently recognised types are: + + - ``darcs`` + - ``git`` + - ``svn`` + - ``cvs`` + - ``mercurial`` (or alias ``hg``) + - ``bazaar`` (or alias ``bzr``) + - ``arch`` + - ``monotone`` + + This field is required. + +.. pkg-field:: location: URL + + The location of the repository. The exact form of this field depends + on the repository type. For example: + + - for darcs: ``http://code.haskell.org/foo/`` + - for git: ``git://github.com/foo/bar.git`` + - for CVS: ``anoncvs@cvs.foo.org:/cvs`` + + This field is required. + +.. pkg-field:: module: token + + CVS requires a named module, as each CVS server can host multiple + named repositories. + + This field is required for the CVS repository type and should not be + used otherwise. + +.. pkg-field:: branch: token + + Many source control systems support the notion of a branch, as a + distinct concept from having repositories in separate locations. For + example CVS, SVN and git use branches while darcs uses different + locations for different branches. If you need to specify a branch to + identify a your repository then specify it in this field. + + This field is optional. + +.. pkg-field:: tag: token + + A tag identifies a particular state of a source repository. The tag + can be used with a ``this`` repository kind to identify the state of + a repository corresponding to a particular package version or + release. The exact form of the tag depends on the repository type. + + This field is required for the ``this`` repository kind. + +.. pkg-field:: subdir: directory + + Some projects put the sources for multiple packages under a single + source repository. This field lets you specify the relative path + from the root of the repository to the top directory for the + package, i.e. the directory containing the package's ``.cabal`` + file. + + This field is optional. It defaults to empty which corresponds to the + root directory of the repository. + +Downloading a package's source +^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +The ``cabal get`` command allows to access a package's source code - +either by unpacking a tarball downloaded from Hackage (the default) or +by checking out a working copy from the package's source repository. + +:: + + $ cabal get [FLAGS] PACKAGES + +The ``get`` command supports the following options: + +``-d --destdir`` *PATH* + Where to place the package source, defaults to (a subdirectory of) + the current directory. +``-s --source-repository`` *[head\|this\|...]* + Clone the package's source repository using the appropriate version + control system. The optional argument allows to choose a specific + repository kind. +``--index-state`` *[HEAD\|@\|]* + Use source package index state as it existed at a previous time. Accepts + unix-timestamps (e.g. ``@1474732068``), ISO8601 UTC timestamps (e.g. + ``2016-09-24T17:47:48Z``), or ``HEAD`` (default). + This determines which package versions are available as well as which + ``.cabal`` file revision is selected (unless ``--pristine`` is used). +``--pristine`` + Unpack the original pristine tarball, rather than updating the + ``.cabal`` file with the latest revision from the package archive. + +Custom setup scripts +-------------------- + +Since Cabal 1.24, custom ``Setup.hs`` are required to accurately track +their dependencies by declaring them in the ``.cabal`` file rather than +rely on dependencies being implicitly in scope. Please refer to +`this article `__ +for more details. + +As of Cabal library version 3.0, ``defaultMain*`` variants implement support +for response files. Custom ``Setup.hs`` files that do not use one of these +main functions are required to implement their own support, such as by using +``GHC.ResponseFile.getArgsWithResponseFiles``. + +Declaring a ``custom-setup`` stanza also enables the generation of +``MIN_VERSION_package_(A,B,C)`` CPP macros for the Setup component. + +.. pkg-section:: custom-setup + :synopsis: Custom Setup.hs build information. + :since: 1.24 + + The optional :pkg-section:`custom-setup` stanza contains information needed + for the compilation of custom ``Setup.hs`` scripts, + +:: + + custom-setup + setup-depends: + base >= 4.5 && < 4.11, + Cabal >= 1.14 && < 1.25 + +.. pkg-field:: setup-depends: package list + :since: 1.24 + + The dependencies needed to compile ``Setup.hs``. See the + :pkg-field:`build-depends` field for a description of the syntax expected by + this field. + + If the field is not specified the implicit package set will be used. + The package set contains packages bundled with GHC (i.e. ``base``, + ``bytestring``) and specifically ``Cabal``. + The specific bounds are put on ``Cabal`` dependency: + lower-bound is inferred from :pkg-field:`cabal-version`, + and the upper-bound is ``< 1.25``. + + ``Cabal`` version is additionally restricted by GHC, + with absolute minimum being ``1.20``, and for example ``Custom`` + builds with GHC-8.10 require at least ``Cabal-3.2``. + + +Backward compatibility and ``custom-setup`` +^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +Versions prior to Cabal 1.24 don't recognise ``custom-setup`` stanzas, +and will behave agnostic to them (except for warning about an unknown +section). Consequently, versions prior to Cabal 1.24 can't ensure the +declared dependencies ``setup-depends`` are in scope, and instead +whatever is registered in the current package database environment +will become eligible (and resolved by the compiler) for the +``Setup.hs`` module. + +The availability of the +``MIN_VERSION_package_(A,B,C)`` CPP macros +inside ``Setup.hs`` scripts depends on the condition that either + +- a ``custom-setup`` section has been declared (or ``cabal build`` is being + used which injects an implicit hard-coded ``custom-setup`` stanza if it's missing), or +- GHC 8.0 or later is used (which natively injects package version CPP macros) + +Consequently, if you need to write backward compatible ``Setup.hs`` +scripts using CPP, you should declare a ``custom-setup`` stanza and +use the pattern below: + +.. code-block:: haskell + + {-# LANGUAGE CPP #-} + import Distribution.Simple + + #if defined(MIN_VERSION_Cabal) + -- version macros are available and can be used as usual + # if MIN_VERSION_Cabal(a,b,c) + -- code specific to lib:Cabal >= a.b.c + # else + -- code specific to lib:Cabal < a.b.c + # endif + #else + # warning Enabling heuristic fall-back. Please upgrade cabal-install to 1.24 or later if Setup.hs fails to compile. + + -- package version macros not available; except for exotic environments, + -- you can heuristically assume that lib:Cabal's version is correlated + -- with __GLASGOW_HASKELL__, and specifically since we can assume that + -- GHC < 8.0, we can assume that lib:Cabal is version 1.22 or older. + #endif + + main = ... + +The simplified (heuristic) CPP pattern shown below is useful if all you need +is to distinguish ``Cabal < 2.0`` from ``Cabal >= 2.0``. + +.. code-block:: haskell + + {-# LANGUAGE CPP #-} + import Distribution.Simple + + #if !defined(MIN_VERSION_Cabal) + # define MIN_VERSION_Cabal(a,b,c) 0 + #endif + + #if MIN_VERSION_Cabal(2,0,0) + -- code for lib:Cabal >= 2.0 + #else + -- code for lib:Cabal < 2.0 + #endif + + main = ... + + + +Autogenerated modules and includes +---------------------------------- + +.. pkg-section:: None + +Modules that are built automatically at setup, created with a custom +setup script, must appear on :pkg-field:`other-modules` for the library, +executable, test-suite or benchmark stanzas or also on +:pkg-field:`library:exposed-modules` for libraries to be used, but are not +really on the package when distributed. This makes commands like sdist fail +because the file is not found. + +These special modules must appear again on the :pkg-field:`autogen-modules` +field of the stanza that is using them, besides :pkg-field:`other-modules` or +:pkg-field:`library:exposed-modules`. With this there is no need to create +complex build hooks for this poweruser case. + +.. pkg-field:: autogen-modules: module list + :since: 2.0 + + .. todo:: document autogen-modules field + +Right now :pkg-field:`executable:main-is` modules are not supported on +:pkg-field:`autogen-modules`. + +:: + + Library + default-language: Haskell2010 + build-depends: base + exposed-modules: + MyLibrary + MyLibHelperModule + other-modules: + MyLibModule + autogen-modules: + MyLibHelperModule + + Executable Exe + default-language: Haskell2010 + main-is: Dummy.hs + build-depends: base + other-modules: + MyExeModule + MyExeHelperModule + autogen-modules: + MyExeHelperModule + +.. pkg-field:: autogen-includes: filename list + :since: 3.0 + + A list of header files from this package which are autogenerated + (e.g. by a ``configure`` script). Autogenerated header files are not + packaged by ``sdist`` command. + +Virtual modules +--------------- + +TBW + +.. pkg-field:: virtual-modules: module list + :since: 2.2 + + TBW + + +.. _accessing-data-files: + +Accessing data files from package code +-------------------------------------- + +The placement on the target system of files listed in +the :pkg-field:`data-files` field varies between systems, and in some cases +one can even move packages around after installation +(see :ref:`prefix independence`). To +enable packages to find these files in a portable way, Cabal generates a +module called :file:`Paths_{pkgname}` (with any hyphens in *pkgname* +replaced by underscores) during building, so that it may be imported by +modules of the package. This module defines a function + +.. code-block:: haskell + + getDataFileName :: FilePath -> IO FilePath + +If the argument is a filename listed in the :pkg-field:`data-files` field, the +result is the name of the corresponding file on the system on which the +program is running. + +.. Note:: + + If you decide to import the :file:`Paths_{pkgname}` module then it + *must* be listed in the :pkg-field:`other-modules` field just like any other + module in your package and on :pkg-field:`autogen-modules` as the file is + autogenerated. + +The :file:`Paths_{pkgname}` module is not platform independent, as any +other autogenerated module, so it does not get included in the source +tarballs generated by ``sdist``. + +The :file:`Paths_{pkgname}` module also includes some other useful +functions and values, which record the version of the package and some +other directories which the package has been configured to be installed +into (e.g. data files live in ``getDataDir``): + +.. code-block:: haskell + + version :: Version + + getBinDir :: IO FilePath + getLibDir :: IO FilePath + getDynLibDir :: IO FilePath + getDataDir :: IO FilePath + getLibexecDir :: IO FilePath + getSysconfDir :: IO FilePath + +The actual location of all these directories can be individually +overridden at runtime using environment variables of the form +``pkg_name_var``, where ``pkg_name`` is the name of the package with all +hyphens converted into underscores, and ``var`` is either ``bindir``, +``libdir``, ``dynlibdir``, ``datadir``, ``libexedir`` or ``sysconfdir``. For example, +the configured data directory for ``pretty-show`` is controlled with the +``pretty_show_datadir`` environment variable. + +Accessing the package version +^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +The aforementioned auto generated :file:`Paths_{pkgname}` module also +exports the constant ``version ::`` +`Version `__ +which is defined as the version of your package as specified in the +``version`` field. + +.. _system-dependent parameters: + +System-dependent parameters +--------------------------- + +For some packages, especially those interfacing with C libraries, +implementation details and the build procedure depend on the build +environment. The ``build-type`` ``Configure`` can be used to handle many +such situations. In this case, ``Setup.hs`` should be: + +.. code-block:: haskell + + import Distribution.Simple + main = defaultMainWithHooks autoconfUserHooks + +Most packages, however, would probably do better using the ``Simple`` +build type and `configurations`_. + +The :pkg-field:`build-type` ``Configure`` differs from ``Simple`` in two ways: + +- The package root directory must contain a shell script called + ``configure``. The configure step will run the script. This + ``configure`` script may be produced by + `autoconf `__ or may be + hand-written. The ``configure`` script typically discovers + information about the system and records it for later steps, e.g. by + generating system-dependent header files for inclusion in C source + files and preprocessed Haskell source files. (Clearly this won't work + for Windows without MSYS or Cygwin: other ideas are needed.) + +- If the package root directory contains a file called + *package*\ ``.buildinfo`` after the configuration step, subsequent + steps will read it to obtain additional settings for `build + information`_ fields,to be merged with the ones + given in the ``.cabal`` file. In particular, this file may be + generated by the ``configure`` script mentioned above, allowing these + settings to vary depending on the build environment. + +The build information file should have the following structure: + + *buildinfo* + + ``executable:`` *name* *buildinfo* + + ``executable:`` *name* *buildinfo* ... + +where each *buildinfo* consists of settings of fields listed in the +section on `build information`_. The first one (if +present) relates to the library, while each of the others relate to the +named executable. (The names must match the package description, but you +don't have to have entries for all of them.) + +Neither of these files is required. If they are absent, this setup +script is equivalent to ``defaultMain``. + +Example: Using autoconf +^^^^^^^^^^^^^^^^^^^^^^^ + +This example is for people familiar with the +`autoconf `__ tools. + +In the X11 package, the file ``configure.ac`` contains: + +.. code-block:: shell + + AC_INIT([Haskell X11 package], [1.1], [libraries@haskell.org], [X11]) + + # Safety check: Ensure that we are in the correct source directory. + AC_CONFIG_SRCDIR([X11.cabal]) + + # Header file to place defines in + AC_CONFIG_HEADERS([include/HsX11Config.h]) + + # Check for X11 include paths and libraries + AC_PATH_XTRA + AC_TRY_CPP([#include ],,[no_x=yes]) + + # Build the package if we found X11 stuff + if test "$no_x" = yes + then BUILD_PACKAGE_BOOL=False + else BUILD_PACKAGE_BOOL=True + fi + AC_SUBST([BUILD_PACKAGE_BOOL]) + + AC_CONFIG_FILES([X11.buildinfo]) + AC_OUTPUT + +Then the setup script will run the ``configure`` script, which checks +for the presence of the X11 libraries and substitutes for variables in +the file ``X11.buildinfo.in``: + +:: + + buildable: @BUILD_PACKAGE_BOOL@ + cc-options: @X_CFLAGS@ + ld-options: @X_LIBS@ + +This generates a file ``X11.buildinfo`` supplying the parameters needed +by later stages: + +:: + + buildable: True + cc-options: -I/usr/X11R6/include + ld-options: -L/usr/X11R6/lib + +The ``configure`` script also generates a header file +``include/HsX11Config.h`` containing C preprocessor defines recording +the results of various tests. This file may be included by C source +files and preprocessed Haskell source files in the package. + +.. Note:: + + Packages using these features will also need to list additional + files such as ``configure``, templates for ``.buildinfo`` files, files + named only in ``.buildinfo`` files, header files and so on in the + :pkg-field:`extra-source-files` field to ensure that they are included in + source distributions. They should also list files and directories generated + by ``configure`` in the :pkg-field:`extra-tmp-files` field to ensure that + they are removed by ``setup clean``. + +Quite often the files generated by ``configure`` need to be listed +somewhere in the package description (for example, in the +:pkg-field:`install-includes` field). However, we usually don't want generated +files to be included in the source tarball. The solution is again +provided by the ``.buildinfo`` file. In the above example, the following +line should be added to ``X11.buildinfo``: + +:: + + install-includes: HsX11Config.h + +In this way, the generated ``HsX11Config.h`` file won't be included in +the source tarball in addition to ``HsX11Config.h.in``, but it will be +copied to the right location during the install process. Packages that +use custom ``Setup.hs`` scripts can update the necessary fields +programmatically instead of using the ``.buildinfo`` file. + +Conditional compilation +----------------------- + +Sometimes you want to write code that works with more than one version +of a dependency. You can specify a range of versions for the dependency +in the :pkg-field:`build-depends`, but how do you then write the code that can +use different versions of the API? + +Haskell lets you preprocess your code using the C preprocessor (either +the real C preprocessor, or ``cpphs``). To enable this, add +``extensions: CPP`` to your package description. When using CPP, Cabal +provides some pre-defined macros to let you test the version of +dependent packages; for example, suppose your package works with either +version 3 or version 4 of the ``base`` package, you could select the +available version in your Haskell modules like this: + +.. code-block:: cpp + + #if MIN_VERSION_base(4,0,0) + ... code that works with base-4 ... + #else + ... code that works with base-3 ... + #endif + +In general, Cabal supplies a macro +``MIN_VERSION_``\ *``package``*\ ``_(A,B,C)`` for each package depended +on via :pkg-field:`build-depends`. This macro is true if the actual version of +the package in use is greater than or equal to ``A.B.C`` (using the +conventional ordering on version numbers, which is lexicographic on the +sequence, but numeric on each component, so for example 1.2.0 is greater +than 1.0.3). + +Since version 1.20, the ``MIN_TOOL_VERSION_``\ *``tool``* +family of macros lets you condition on the version of build tools used to +build the program (e.g. ``hsc2hs``). + +Since version 1.24, the macro ``CURRENT_COMPONENT_ID``, which +expands to the string of the component identifier that uniquely +identifies this component. Furthermore, if the package is a library, +the macro ``CURRENT_PACKAGE_KEY`` records the identifier that was passed +to GHC for use in symbols and for type equality. + +Since version 2.0, the macro ``CURRENT_PACKAGE_VERSION`` expands +to the string version number of the current package. + +Cabal places the definitions of these macros into an +automatically-generated header file, which is included when +preprocessing Haskell source code by passing options to the C +preprocessor. + +Cabal also allows to detect when the source code is being used for +generating documentation. The ``__HADDOCK_VERSION__`` macro is defined +only when compiling via Haddock_ +instead of a normal Haskell compiler. The value of the +``__HADDOCK_VERSION__`` macro is defined as ``A*1000 + B*10 + C``, where +``A.B.C`` is the Haddock version. This can be useful for working around +bugs in Haddock or generating prettier documentation in some special +cases. + +.. _more-complex-packages: + +More complex packages +--------------------- + +For packages that don't fit the simple schemes described above, you have +a few options: + +- By using the :pkg-field:`build-type` ``Custom``, you can supply your own + ``Setup.hs`` file, and customize the simple build infrastructure + using *hooks*. These allow you to perform additional actions before + and after each command is run, and also to specify additional + preprocessors. A typical ``Setup.hs`` may look like this: + + .. code-block:: haskell + + import Distribution.Simple + main = defaultMainWithHooks simpleUserHooks { postHaddock = posthaddock } + + posthaddock args flags desc info = .... + + See ``UserHooks`` in + `Distribution.Simple `__ + for the details, but note that this interface is experimental, and + likely to change in future releases. + + If you use a custom ``Setup.hs`` file you should strongly consider + adding a :pkg-section:`custom-setup` stanza with a + :pkg-field:`custom-setup:setup-depends` field to ensure that your setup + script does not break with future dependency versions. + +- You could delegate all the work to ``make``, though this is unlikely + to be very portable. Cabal supports this with the :pkg-field:`build-type` + ``Make`` and a trivial setup library + `Distribution.Make `__, + which simply parses the command line arguments and invokes ``make``. + Here ``Setup.hs`` should look like this: + + .. code-block:: haskell + + import Distribution.Make + main = defaultMain + + The root directory of the package should contain a ``configure`` + script, and, after that has run, a ``Makefile`` with a default target + that builds the package, plus targets ``install``, ``register``, + ``unregister``, ``clean``, ``dist`` and ``docs``. Some options to + commands are passed through as follows: + + - The ``--with-hc-pkg``, ``--prefix``, ``--bindir``, ``--libdir``, + ``--dynlibdir``, ``--datadir``, ``--libexecdir`` and ``--sysconfdir`` options to + the ``configure`` command are passed on to the ``configure`` + script. In addition the value of the ``--with-compiler`` option is + passed in a ``--with-hc`` option and all options specified with + ``--configure-option=`` are passed on. + + - The ``--destdir`` option to the ``copy`` command becomes a setting + of a ``destdir`` variable on the invocation of ``make copy``. The + supplied ``Makefile`` should provide a ``copy`` target, which will + probably look like this: + + .. code-block:: make + + copy : + $(MAKE) install prefix=$(destdir)/$(prefix) \ + bindir=$(destdir)/$(bindir) \ + libdir=$(destdir)/$(libdir) \ + dynlibdir=$(destdir)/$(dynlibdir) \ + datadir=$(destdir)/$(datadir) \ + libexecdir=$(destdir)/$(libexecdir) \ + sysconfdir=$(destdir)/$(sysconfdir) \ + +- Finally, with the :pkg-field:`build-type` ``Custom``, you can also write your + own setup script from scratch, and you may use the Cabal + library for all or part of the work. One option is to copy the source + of ``Distribution.Simple``, and alter it for your needs. Good luck. + +.. _Backpack: + +Backpack +-------- + +Cabal and GHC jointly support Backpack, an extension to Haskell's module +system which makes it possible to parametrize a package over some +modules, which can be instantiated later arbitrarily by a user. This +means you can write a library to be agnostic over some data +representation, and then instantiate it several times with different +data representations. Like C++ templates, instantiated packages are +recompiled for each instantiation, which means you do not pay any +runtime cost for parametrizing packages in this way. Backpack modules +are somewhat experimental; while fully supported by cabal-install, they are currently +`not supported by Stack `__. + +A Backpack package is defined by use of the +:pkg-field:`library:signatures` field, or by (transitive) dependency on +a package that defines some requirements. To define a parametrized +package, define a signature file (file extension ``hsig``) that +specifies the signature of the module you want to parametrize over, and +add it to your Cabal file in the :pkg-field:`library:signatures` field. + +.. code-block:: haskell + :caption: .hsig + + signature Str where + + data Str + + concat :: [Str] -> Str + +.. code-block:: cabal + :caption: parametrized.cabal + + cabal-version: 2.2 + name: parametrized + + library + build-depends: base + signatures: Str + exposed-modules: MyModule + +You can define any number of regular modules (e.g., ``MyModule``) that +import signatures and use them as regular modules. + +If you are familiar with ML modules, you might now expect there to be +some way to apply the parametrized package with an implementation of +the ``Str`` module to get a concrete instantiation of the package. +Backpack operates slightly differently with a concept of *mix-in +linking*, where you provide an implementation of ``Str`` simply by +bringing another module into scope with the same name as the +requirement. For example, if you had a package ``str-impl`` that provided a +module named ``Str``, instantiating ``parametrized`` is as simple as +just depending on both ``str-impl`` and ``parametrized``: + +.. code-block:: cabal + :caption: combined.cabal + + cabal-version: 2.2 + name: combined + + library + build-depends: base, str-impl, parametrized + +Note that due to technical limitations, you cannot directly define +``Str`` in the ``combined`` library; it must be placed in its own +library (you can use :ref:`Internal Libraries ` to conveniently +define a sub-library). + +However, a more common situation is that your names don't match up +exactly. The :pkg-field:`library:mixins` field can be used to rename +signatures and modules to line up names as necessary. If you have +a requirement ``Str`` and an implementation ``Data.Text``, you can +line up the names in one of two ways: + +* Rename the requirement to match the implementation: + ``mixins: parametrized requires (Str as Data.Text)`` +* Rename the implementation to match the requirement: + ``mixins: text (Data.Text as Str)`` + +The :pkg-field:`library:mixins` field can also be used to disambiguate +between multiple instantiations of the same package; for each +instantiation of the package, give it a separate entry in mixins with +the requirements and provided modules renamed to be distinct. + +.. code-block:: cabal + :caption: .cabal + + cabal-version: 2.2 + name: double-combined + + library + build-depends: base, text, bytestring, parametrized + mixins: + parametrized (MyModule as MyModule.Text) requires (Str as Data.Text), + parametrized (MyModule as MyModule.BS) requires (Str as Data.ByteString) + +Intensive use of Backpack sometimes involves creating lots of small +parametrized libraries; :ref:`Internal Libraries ` can be used +to define all of these libraries in a single package without having to +create many separate Cabal packages. You may also find it useful to use +:pkg-field:`library:reexported-modules` to reexport instantiated +libraries to Backpack-unware users (e.g., Backpack can be used entirely +as an implementation detail.) + +Backpack imposes a limitation on Template Haskell that goes beyond the usual TH +stage restriction: it's not possible to splice TH code imported from a +compilation unit that is still "indefinite", that is, a unit for which some +module signatures still haven't been matched with implementations. The reason +is that indefinite units are typechecked, but not compiled, so there's no +actual TH code to run while splicing. Splicing TH code from a definite +compilation unit into an indefinite one works normally. + +For more information about Backpack, check out the +`GHC wiki page `__. + +.. include:: references.inc + +.. rubric:: Footnotes + +.. [#old-style-build-tool-depends] + + Some packages (ab)use :pkg-field:`build-depends` on old-style builds, but this has a few major drawbacks: + + - using Nix-style builds it's considered an error if you depend on a exe-only package via build-depends: the solver will refuse it. + - it may or may not place the executable on ``PATH``. + - it does not ensure the correct version of the package is installed, so you might end up overwriting versions with each other. diff --git a/cabal/doc/cabal-project.rst b/cabal/doc/cabal-project.rst new file mode 100644 --- /dev/null +++ b/cabal/doc/cabal-project.rst @@ -0,0 +1,1747 @@ +cabal.project Reference +======================= + +``cabal.project`` files support a variety of options which configure the +details of your build. The general syntax of a ``cabal.project`` file is +similar to that of a Cabal file: there are a number of fields, some of +which live inside stanzas (groups of fields that apply to only part of a +project or can be referenced as a unit): + +:: + + packages: */*.cabal + with-compiler: /opt/ghc/8.0.1/bin/ghc + + package cryptohash + optimization: False + +In general, the accepted field names coincide with the accepted command +line flags that ``cabal install`` and other commands take. For example, +``cabal configure --enable-profiling`` will write out a project +file with ``profiling: True``. + +The full configuration of a project is determined by combining the +following sources (later entries override earlier ones, except for appendable +options): + +1. ``~/.cabal/config`` (the user-wide global configuration) + +2. ``cabal.project`` (the project configuration) + +3. ``cabal.project.freeze`` (the output of ``cabal freeze``) + +4. ``cabal.project.local`` (the output of ``cabal configure``) + +Any call to ``cabal build`` will consider ``cabal.project*`` files from parent +directories when there is none in the current directory. + +.. _conditionals and imports: + +Conditionals and imports +------------------------ + +As of ``cabal-install`` version 3.8, cabal supports conditional logic +and imports in ``cabal.project`` files. :ref:`conditions` in cabal +may case on operating system, architecture, and +compiler (i.e. there is no support for a notion of custom flags in +project files). Imports may specify local filepaths or remote urls, +and may reference either cabal.project files or v1-style cabal.config +freeze files. As a usage example: + +:: + + if(os(darwin)) + optimization: False + elif(os(freebsd)) + packages: freebsd/*.cabal + else + optimization: True + + import: https://some.remote.source/subdir/cabal.config + + import: relativepath/extra-project.project + + import: /absolutepath/some-project.project + +Specifying the local packages +----------------------------- + +The following top-level options specify what the local packages of a +project are: + +.. cfg-field:: packages: package location list (space or comma separated) + :synopsis: Project packages. + + :default: ``./*.cabal`` + + .. warning:: + + The default value ``./*.cabal`` only takes effect if there is no explicit + ``cabal.project`` file. + If you use such explicit file you *must* fill the field. + + Specifies the list of package locations which contain the local + packages to be built by this project. Package locations can take the + following forms: + + 1. They can specify a Cabal file, or a directory containing a Cabal + file, e.g., ``packages: Cabal cabal-install/cabal-install.cabal``. + + 2. They can specify glob-style wildcards, which must match one or + more (a) directories containing a (single) Cabal file, (b) Cabal + files (extension ``.cabal``), or (c) tarballs which contain Cabal + packages (extension ``.tar.gz``). + For example, to match all Cabal files in all + subdirectories, as well as the Cabal projects in the parent + directories ``foo`` and ``bar``, use + ``packages: */*.cabal ../{foo,bar}/`` + + 3. They can specify an ``http``, ``https`` or ``file`` + URL, representing the path to a remote tarball to be downloaded + and built. + + There is no command line variant of this field; see :issue:`3585`. + Note that the default value is only included if there is no + ``cabal.project`` file. The field is appendable which means there would be + no way to drop the default value if it was included. + +.. cfg-field:: optional-packages: package location list (space or comma-separated) + :synopsis: Optional project packages. + + :default: empty + + Like :cfg-field:`packages`, specifies a list of package locations + containing local packages to be built. Unlike :cfg-field:`packages`, + if we glob for a package, it is permissible for the glob to match against + zero packages. The intended use-case for :cfg-field:`optional-packages` + is to make it so that vendored packages can be automatically picked up if + they are placed in a subdirectory, but not error if there aren't any. + + There is no command line variant of this field. + +.. cfg-field:: extra-packages: package list with version bounds (comma separated) + :synopsis: Adds external packages as local + + [STRIKEOUT:Specifies a list of external packages from Hackage which + should be considered local packages.] (Not implemented) + + There is no command line variant of this field. + + + +All local packages are *vendored*, in the sense that if other packages +(including external ones from Hackage) depend on a package with the name +of a local package, the local package is preferentially used. +For subdirectories to be considered local packages, the following setting +can be used:: + + packages: ./*.cabal + optional-packages: ./*/*.cabal + +...then any package can be vendored simply by making a checkout in the +top-level project directory, as might be seen in this hypothetical +directory layout:: + + foo.cabal + foo-helper/ # local package + unix/ # vendored external package + +All of these options support globs. ``cabal build`` has its own glob +format: + +- Anywhere in a path, as many times as you like, you can specify an + asterisk ``*`` wildcard. E.g., ``*/*.cabal`` matches all ``.cabal`` + files in all immediate subdirectories. Like in glob(7), asterisks do + not match hidden files unless there is an explicit period, e.g., + ``.*/foo.cabal`` will match ``.private/foo.cabal`` (but + ``*/foo.cabal`` will not). + +- You can use braces to specify specific directories; e.g., + ``{vendor,pkgs}/*.cabal`` matches all Cabal files in the ``vendor`` + and ``pkgs`` subdirectories. + +Formally, the format is described by the following BNF: + +.. todo:: + convert globbing grammar to proper ABNF_ syntax + +.. code-block:: abnf + + FilePathGlob ::= FilePathRoot FilePathGlobRel + FilePathRoot ::= {- empty -} # relative to cabal.project + | "/" # Unix root + | [a-zA-Z] ":" [/\\] # Windows root + | "~" # home directory + FilePathGlobRel ::= Glob "/" FilePathGlobRel # Unix directory + | Glob "\\" FilePathGlobRel # Windows directory + | Glob # file + | {- empty -} # trailing slash + Glob ::= GlobPiece * + GlobPiece ::= "*" # wildcard + | [^*{},/\\] * # literal string + | "\\" [*{},] # escaped reserved character + | "{" Glob "," ... "," Glob "}" # union (match any of these) + + +Specifying Packages from Remote Version Control Locations +^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +Starting with Cabal 2.4, there is now a stanza +``source-repository-package`` for specifying packages from an external +version control. + +.. code-block:: cabal + + packages: . + + source-repository-package + type: git + location: https://github.com/hvr/HsYAML.git + tag: e70cf0c171c9a586b62b3f75d72f1591e4e6aaa1 + + source-repository-package + type: git + location: https://github.com/well-typed/cborg + tag: 3d274c14ca3077c3a081ba7ad57c5182da65c8c1 + subdir: cborg + + source-repository-package + type: git + location: https://github.com/haskell/network.git + tag: e76fdc753e660dfa615af6c8b6a2ad9ddf6afe70 + post-checkout-command: autoreconf -i + +cabal-install 3.4 sdists the ``source-repository-package`` repositories and uses resulting tarballs as project packages. +This allows sharing of packages across different projects. + +.. cfg-field:: type: VCS kind + +.. cfg-field:: location: VCS location (usually URL) + +.. cfg-field:: tag: VCS tag + +.. cfg-field:: subdir: subdirectory list + + Use one or more subdirectories of the repository. + +.. cfg-field:: post-checkout-command: command + + Run command in the checked out repository, prior sdisting. + +Global configuration options +---------------------------- + +The following top-level configuration options are not specific to any +package, and thus apply globally: + + +.. cfg-field:: verbose: nat + --verbose=n, -vn + :synopsis: Build verbosity level. + + :default: 1 + + Control the verbosity of ``cabal`` commands, valid values are from 0 + to 3. + + The command line variant of this field is ``--verbose=2``; a short + form ``-v2`` is also supported. + +.. cfg-field:: jobs: nat or $ncpus + --jobs=n, -jn, --jobs=$ncpus + :synopsis: Number of builds running in parallel. + + :default: 1 + + Run *nat* jobs simultaneously when building. If ``$ncpus`` is + specified, run the number of jobs equal to the number of CPUs. + Package building is often quite parallel, so turning on parallelism + can speed up build times quite a bit! + + The command line variant of this field is ``--jobs=2``; a short form + ``-j2`` is also supported; a bare ``--jobs`` or ``-j`` is equivalent + to ``--jobs=$ncpus``. + +.. cfg-field:: keep-going: boolean + --keep-going + :synopsis: Try to continue building on failure. + + :default: False + + If true, after a build failure, continue to build other unaffected + packages. + + The command line variant of this field is ``--keep-going``. + +.. option:: --builddir=DIR + + Specifies the name of the directory where build products for + build will be stored; defaults to ``dist-newstyle``. If a + relative name is specified, this directory is resolved relative + to the root of the project (i.e., where the ``cabal.project`` + file lives.) + + This option cannot be specified via a ``cabal.project`` file. + +.. _cmdoption-project-file: +.. option:: --project-file=FILE + + Specifies the name of the project file used to specify the + rest of the top-level configuration; defaults to ``cabal.project``. + This name not only specifies the name of the main project file, + but also the auxiliary project files ``cabal.project.freeze`` + and ``cabal.project.local``; for example, if you specify + ``--project-file=my.project``, then the other files that will + be probed are ``my.project.freeze`` and ``my.project.local``. + + If the specified project file is a relative path, we will + look for the file relative to the current working directory, + and then for the parent directory, until the project file is + found or we have hit the top of the user's home directory. + + This option cannot be specified via a ``cabal.project`` file. + +-- option:: --ignore-project + + Ignores the local ``cabal.project`` file and uses the default + configuration with the local ``foo.cabal`` file. Note that + if this flag is set while the ``--project-file`` flag is also + set then this flag will be ignored. + +.. option:: --store-dir=DIR + + Specifies the name of the directory of the global package store. + +.. cfg-field:: package-dbs: package DB stack (comma separated) + --package-db=[clear, global, user, PATH] + :synopsis: PackageDB stack manipulation + :since: 3.7 + + There are three package databases involved with most builds: + + global + Compiler installation of rts, base, etc. + store + Nix-style local build cache + in-place + Project-specific build directory + + By default, the package stack you will have with v2 commands is: + + :: + + -- [global, store] + + So all remote packages required by your project will be + registered in the store package db (because it is last). + + When cabal starts building your local projects, it appends the in-place db + to the end: + + :: + + -- [global, store, in-place] + + So your local packages get put in ``dist-newstyle`` instead of the store. + + This flag manipulates the default prefix: ``[global, store]`` and accepts + paths, the special value ``global`` referring to the global package db, and + ``clear`` which removes all prior entries. For example, + + :: + + -- [global, store, foo] + package-dbs: foo + + -- [foo] + package-dbs: clear, foo + + -- [bar, baz] + package-dbs: clear, foo, clear, bar, baz + + The command line variant of this flag is ``--package-db=DB`` which can be + specified multiple times. + +Phase control +------------- + +The following settings apply to commands that result in build actions +(``build``, ``run``, ``repl``, ``test``...), and control which phases of the +build are executed. + +.. option:: --dry-run + + Do not download, build, or install anything, only print what would happen. + +.. option:: --only-configure + + Instead of performing a full build just run the configure step. + Only accepted by the ``build`` command. + +.. option:: --only-download + + Do not build anything, only fetch the packages. + +.. option:: --only-dependencies + + Install only the dependencies necessary to build the given packages. + Not accepted by the ``repl`` command. + +Solver configuration options +---------------------------- + +The following settings control the behavior of the dependency solver: + +.. cfg-field:: constraints: constraints list (comma separated) + --constraint="pkg >= 2.0", -c "pkg >= 2.0" + :synopsis: Extra dependencies constraints. + + Add extra constraints to the version bounds, flag settings, + and other properties a solver can pick for a + package. For example: + + :: + + constraints: bar == 2.1 + + A package can be specified multiple times in ``constraints``, in + which case the specified constraints are intersected. This is + useful, since the syntax does not allow you to specify multiple + constraints at once. For example, to specify both version bounds and + flag assignments, you would write: + + :: + + constraints: bar == 2.1, + bar +foo -baz + + Valid constraints take the same form as for the + :option:`runhaskell Setup.hs configure --constraint` + command line option. + +.. cfg-field:: preferences: preference (comma separated) + --preference="pkg >= 2.0" + :synopsis: Preferred dependency versions. + + Like :cfg-field:`constraints`, but the solver will attempt to satisfy + these preferences on a best-effort basis. The resulting install is locally + optimal with respect to preferences; specifically, no single package + could be replaced with a more preferred version that still satisfies + the hard constraints. + + Operationally, preferences can cause the solver to attempt certain + version choices of a package before others, which can improve + dependency solver runtime. + + One way to use :cfg-field:`preferences` is to take a known working set of + constraints (e.g., via ``cabal freeze``) and record them as + preferences. In this case, the solver will first attempt to use this + configuration, and if this violates hard constraints, it will try to + find the minimal number of upgrades to satisfy the hard constraints + again. + + The command line variant of this field is + ``--preference="pkg >= 2.0"``; to specify multiple preferences, pass + the flag multiple times. + +.. cfg-field:: allow-newer: none, all or list of scoped package names (space or comma separated) + --allow-newer, --allow-newer=[none,all,[scope:][^]pkg] + :synopsis: Lift dependencies upper bound constraints. + + :default: ``none`` + + Allow the solver to pick more recent version of some packages than + would normally be permitted by the :pkg-field:`build-depends` bounds + of packages in the install plan. This option may be useful if the + dependency solver cannot otherwise find a valid install plan. + + For example, to relax ``pkg``\ s :pkg-field:`build-depends` upper bound on + ``dep-pkg``, write a scoped package name of the form: + + :: + + allow-newer: pkg:dep-pkg + + If the scope shall be limited to specific releases of ``pkg``, the + extended form as in + + :: + + allow-newer: pkg-1.2.3:dep-pkg, pkg-1.1.2:dep-pkg + + can be used to limit the relaxation of dependencies on + ``dep-pkg`` by the ``pkg-1.2.3`` and ``pkg-1.1.2`` releases only. + + The scoped syntax is recommended, as it is often only a single package + whose upper bound is misbehaving. In this case, the upper bounds of + other packages should still be respected; indeed, relaxing the bound + can break some packages which test the selected version of packages. + + The syntax also allows to prefix the dependee package with a + modifier symbol to modify the scope/semantic of the relaxation + transformation in a additional ways. Currently only one modifier + symbol is defined, i.e. ``^`` (i.e. caret) which causes the + relaxation to be applied only to ``^>=`` operators and leave all other + version operators untouched. + + However, in some situations (e.g., when attempting to build packages + on a new version of GHC), it is useful to disregard *all* + upper-bounds, with respect to a package or all packages. This can be + done by specifying just a package name, or using the keyword ``all`` + to specify all packages: + + :: + + -- Disregard upper bounds involving the dependencies on + -- packages bar, baz. For quux only, relax + -- 'quux ^>= ...'-style constraints only. + allow-newer: bar, baz, ^quux + + -- Disregard all upper bounds when dependency solving + allow-newer: all + + -- Disregard all `^>=`-style upper bounds when dependency solving + allow-newer: ^all + + + For consistency, there is also the explicit wildcard scope syntax + ``*`` (or its alphabetic synonym ``all``). Consequently, the + examples above are equivalent to the explicitly scoped variants: + + :: + + allow-newer: all:bar, *:baz, *:^quux + + allow-newer: *:* + allow-newer: all:all + + allow-newer: *:^* + allow-newer: all:^all + + In order to ignore all bounds specified by a package ``pkg-1.2.3`` + you can combine scoping with a right-hand-side wildcard like so + + :: + + -- Disregard any upper bounds specified by pkg-1.2.3 + allow-newer: pkg-1.2.3:* + + -- Disregard only `^>=`-style upper bounds in pkg-1.2.3 + allow-newer: pkg-1.2.3:^* + + + :cfg-field:`allow-newer` is often used in conjunction with a constraint + (in the :cfg-field:`constraints` field) forcing the usage of a specific, + newer version of a package. + + The command line variant of this field is e.g. ``--allow-newer=bar``. A + bare ``--allow-newer`` is equivalent to ``--allow-newer=all``. + +.. cfg-field:: allow-older: none, all, list of scoped package names (space or comma separated) + --allow-older, --allow-older=[none,all,[scope:][^]pkg] + :synopsis: Lift dependency lower bound constraints. + :since: 2.0 + + :default: ``none`` + + Like :cfg-field:`allow-newer`, but applied to lower bounds rather than + upper bounds. + + The command line variant of this field is ``--allow-older=all``. A + bare ``--allow-older`` is equivalent to ``--allow-older=all``. + + +.. cfg-field:: index-state: HEAD, unix-timestamp, ISO8601 UTC timestamp. + :synopsis: Use source package index state as it existed at a previous time. + :since: 2.0 + + :default: ``HEAD`` + + This allows to change the source package index state the solver uses + to compute install-plans. This is particularly useful in + combination with freeze-files in order to also freeze the state the + package index was in at the time the install-plan was frozen. + + :: + + -- UNIX timestamp format example + index-state: @1474739268 + + -- ISO8601 UTC timestamp format example + -- This format is used by 'cabal configure' + -- for storing `--index-state` values. + index-state: 2016-09-24T17:47:48Z + + -- Specify different index-states per package repository + -- Supported since 3.4 + index-state: + , hackage.haskell.org 2020-05-06T22:33:27Z + , head.hackage 2020-04-29T04:11:05Z + +.. cfg-field:: active-repositories: reponame1, reponame2 + + :synopsis: Specify active package repositories + :since: 3.4 + + :default: ``:rest`` + + Specifies which of the package repositories defined in the configuration + should be active. It's also useful for specifying the order and the way + active repositories are merged. + + When searching for a certain version of a certain package name, the list of + active repositories is searched last-to-first. + + For example, suppose hackage.haskell.org has versions 1.0 and 2.0 of + package X, and my-repository has version 2.0 of a similarly named package. + Then, with the following configuration: + + :: + + -- Force my-repository to be the first repository considered + active-repositories: + , hackage.haskell.org + , my-repository + + version 2.0 of X will come from my-repository, and version 1.0 will come + from hackage.haskell.org. + + If we want to make a repository the sole provider of certain packages, we + can put it last in the active repositories list, and add the :override + modifier. + + For example, if we modify the previous example like this: + + :: + + active-repositories: + , hackage.haskell.org + , my-repository:override + + then version 1.0 of package X won't be found in any case, because X is + present in my-repository only in version 2.0, and the :override forbids + searching for other versions of X further up the list. + + :override has no effect for package names that aren't present in the + overriding repository. + + The special repository reference :rest stands for "all the other repositories" + and can be useful to avoid lengthy lists of repository names: + + :: + + -- Force my-repository to be the first repository considered + active-repositories: :rest, my-repository + + The special repository reference :none disables all repositories, effectively + putting cabal in "offline" mode: + + :: + + active-repositories: :none + + +.. cfg-field:: reject-unconstrained-dependencies: all, none + --reject-unconstrained-dependencies=[all|none] + :synopsis: Restrict the solver to packages that have constraints on them. + + :default: none + :since: 2.6 + + By default, the dependency solver can include any package that it's + aware of in a build plan. If you wish to restrict the build plan to + a closed set of packages (e.g., from a freeze file), use this flag. + + When set to `all`, all non-local packages that aren't goals must be + explicitly constrained. When set to `none`, the solver will + consider all packages. + + +Package configuration options +----------------------------- + +Package options affect the building of specific packages. There are three +ways a package option can be specified: + +- They can be specified at the top-level, in which case they apply only + to **local package**, or + +- They can be specified inside a ``package`` stanza, in which case they + apply to the build of the package, whether or not it is local or + external. + +- They can be specified inside an ``package *`` stanza, in which case they + apply to all packages, local ones from the project and also external + dependencies. + + +For example, the following options specify that :cfg-field:`optimization` +should be turned off for all local packages, and that ``bytestring`` (possibly +an external dependency) should be built with ``-fno-state-hack``:: + + optimization: False + + package bytestring + ghc-options: -fno-state-hack + +``ghc-options`` is not specifically described in this documentation, but is one +of many fields for configuring programs. They take the form +``progname-options`` and ``progname-location``, and can be set for all local +packages in a ``program-options`` stanza or under a package stanza. + +On the command line, these options are applied to all local packages. +There is no per-package command line interface. + +Some flags were added by more recent versions of the Cabal library. This +means that they are NOT supported by packages which use Custom setup +scripts that require a version of the Cabal library older than when the +feature was added. + +.. cfg-field:: flags: list of +flagname or -flagname (space separated) + --flags="+foo -bar", -ffoo, -f-bar + :synopsis: Enable or disable package flags. + + Force all flags specified as ``+flagname`` to be true, and all flags + specified as ``-flagname`` to be false. For example, to enable the + flag ``foo`` and disable ``bar``, set: + + :: + + flags: +foo -bar + + Exactly one of + or - is required before each flag. + + Flags are *per-package*, so it doesn't make much sense to specify + flags at the top-level, unless you happen to know that *all* of your + local packages support the same named flags. If a flag is not + supported by a package, it is ignored. + + See also the solver configuration field :cfg-field:`constraints`. + + The command line variant of this flag is ``--flags``. There is also + a shortened form ``-ffoo -f-bar``. + + A common mistake is to say ``cabal build -fhans``, where + ``hans`` is a flag for a transitive dependency that is not in the + local package; in this case, the flag will be silently ignored. If + ``haskell-tor`` is the package you want this flag to apply to, try + ``--constraint="haskell-tor +hans"`` instead. + +.. cfg-field:: with-compiler: executable + --with-compiler=executable + :synopsis: Path to compiler executable. + + Specify the path to a particular compiler to be used. If not an + absolute path, it will be resolved according to the ``PATH`` + environment. The type of the compiler (GHC, GHCJS, etc) must be + consistent with the setting of the :cfg-field:`compiler` field. + + The most common use of this option is to specify a different version + of your compiler to be used; e.g., if you have ``ghc-7.8`` in your + path, you can specify ``with-compiler: ghc-7.8`` to use it. + + This flag also sets the default value of :cfg-field:`with-hc-pkg`, using + the heuristic that it is named ``ghc-pkg-7.8`` (if your executable name + is suffixed with a version number), or is the executable named + ``ghc-pkg`` in the same directory as the ``ghc`` directory. If this + heuristic does not work, set :cfg-field:`with-hc-pkg` explicitly. + + For inplace packages, ``cabal build`` maintains a separate build + directory for each version of GHC, so you can maintain multiple + build trees for different versions of GHC without clobbering each + other. + + It's not possible to set :cfg-field:`with-compiler` on a + per-package basis. + + The command line variant of this flag is + ``--with-compiler=ghc-7.8``; there is also a short version + ``-w ghc-7.8``. + +.. cfg-field:: with-hc-pkg: executable + --with-hc-pkg=executable + :synopsis: Specifies package tool. + + Specify the path to the package tool, e.g., ``ghc-pkg``. This + package tool must be compatible with the compiler specified by + :cfg-field:`with-compiler` (generally speaking, it should be precisely + the tool that was distributed with the compiler). If this option is + omitted, the default value is determined from :cfg-field:`with-compiler`. + + The command line variant of this flag is + ``--with-hc-pkg=ghc-pkg-7.8``. + +.. cfg-field:: optimization: nat + --enable-optimization + --disable-optimization + :synopsis: Build with optimization. + + :default: ``1`` + + Build with optimization. This is appropriate for production use, + taking more time to build faster libraries and programs. + + The optional *nat* value is the optimisation level. Some compilers + support multiple optimisation levels. The range is 0 to 2. Level 0 + disables optimization, level 1 is the default. Level 2 is higher + optimisation if the compiler supports it. Level 2 is likely to lead + to longer compile times and bigger generated code. If you are not + planning to run code, turning off optimization will lead to better + build times and less code to be rebuilt when a module changes. + + When optimizations are enabled, Cabal passes ``-O2`` to the C compiler. + + We also accept ``True`` (equivalent to 1) and ``False`` (equivalent + to 0). + + Note that as of GHC 8.0, GHC does not recompile when optimization + levels change (see :ghc-ticket:`10923`), so if + you change the optimization level for a local package you may need + to blow away your old build products in order to rebuild with the + new optimization level. + + The command line variant of this flag is ``-O2`` (with ``-O1`` + equivalent to ``-O``). There are also long-form variants + ``--enable-optimization`` and ``--disable-optimization``. + +.. cfg-field:: configure-options: args (space separated) + --configure-option=arg + :synopsis: Options to pass to configure script. + + A list of extra arguments to pass to the external ``./configure`` + script, if one is used. This is only useful for packages which have + the ``Configure`` build type. See also the section on + :ref:`system-dependent parameters`. + + The command line variant of this flag is ``--configure-option=arg``, + which can be specified multiple times to pass multiple options. + +.. cfg-field:: compiler: ghc, ghcjs, jhc, lhc, uhc or haskell-suite + --compiler=compiler + :synopsis: Compiler to build with. + + :default: ``ghc`` + + Specify the compiler toolchain to be used. This is independent of + ``with-compiler``, because the choice of toolchain affects Cabal's + build logic. + + The command line variant of this flag is ``--compiler=ghc``. + + It's not possible to set :cfg-field:`compiler` on a + per-package basis. + +.. cfg-field:: tests: boolean + --enable-tests + --disable-tests + :synopsis: Build tests. + + :default: ``False`` + + Force test suites to be enabled. For most users this should not be + needed, as we always attempt to solve for test suite dependencies, + even when this value is ``False``; furthermore, test suites are + automatically enabled if they are requested as a built target. + + The command line variant of this flag is ``--enable-tests`` and + ``--disable-tests``. + +.. cfg-field:: benchmarks: boolean + --enable-benchmarks + --disable-benchmarks + :synopsis: Build benchmarks. + + :default: ``False`` + + Force benchmarks to be enabled. For most users this should not be + needed, as we always attempt to solve for benchmark dependencies, + even when this value is ``False``; furthermore, benchmarks are + automatically enabled if they are requested as a built target. + + The command line variant of this flag is ``--enable-benchmarks`` and + ``--disable-benchmarks``. + +.. cfg-field:: extra-prog-path: paths (newline or comma separated) + --extra-prog-path=PATH + :synopsis: Add directories to program search path. + :since: 1.18 + + A list of directories to search for extra required programs. Most + users should not need this, as programs like ``happy`` and ``alex`` + will automatically be installed and added to the path. This can be + useful if a ``Custom`` setup script relies on an exotic extra + program. + + The command line variant of this flag is ``--extra-prog-path=PATH``, + which can be specified multiple times. + +.. cfg-field:: run-tests: boolean + --run-tests + :synopsis: Run package test suite upon installation. + + :default: ``False`` + + Run the package test suite upon installation. This is useful for + saying "When this package is installed, check that the test suite + passes, terminating the rest of the build if it is broken." + + .. warning:: + + One deficiency: the :cfg-field:`run-tests` setting of a package is NOT + recorded as part of the hash, so if you install something without + :cfg-field:`run-tests` and then turn on ``run-tests``, we won't + subsequently test the package. If this is causing you problems, give + us a shout. + + The command line variant of this flag is ``--run-tests``. + +Object code options +^^^^^^^^^^^^^^^^^^^ + +.. cfg-field:: debug-info: integer + --enable-debug-info= + --disable-debug-info + :synopsis: Build with debug info enabled. + :since: 1.22 + + :default: False + + If the compiler (e.g., GHC 7.10 and later) supports outputing OS + native debug info (e.g., DWARF), setting ``debug-info: True`` will + instruct it to do so. See the GHC wiki page on :ghc-wiki:`DWARF` + for more information about this feature. + + (This field also accepts numeric syntax, but until GHC 8.2 this didn't + do anything.) + + The command line variant of this flag is ``--enable-debug-info`` and + ``--disable-debug-info``. + +.. cfg-field:: split-sections: boolean + --enable-split-sections + --disable-split-sections + :synopsis: Use GHC's split sections feature. + :since: 2.2 + + :default: False + + Use the GHC ``-split-sections`` feature when building the library. This + reduces the final size of the executables that use the library by + allowing them to link with only the bits that they use rather than + the entire library. The downside is that building the library takes + longer and uses a bit more memory. + + This feature is supported by GHC 8.0 and later. + + The command line variant of this flag is ``--enable-split-sections`` and + ``--disable-split-sections``. + +.. cfg-field:: split-objs: boolean + --enable-split-objs + --disable-split-objs + :synopsis: Use GHC's split objects feature. + + :default: False + + Use the GHC ``-split-objs`` feature when building the library. This + reduces the final size of the executables that use the library by + allowing them to link with only the bits that they use rather than + the entire library. The downside is that building the library takes + longer and uses considerably more memory. + + It is generally recommend that you use ``split-sections`` instead + of ``split-objs`` where possible. + + The command line variant of this flag is ``--enable-split-objs`` and + ``--disable-split-objs``. + +.. cfg-field:: executable-stripping: boolean + --enable-executable-stripping + --disable-executable-stripping + :synopsis: Strip installed programs. + + :default: True + + When installing binary executable programs, run the ``strip`` + program on the binary. This can considerably reduce the size of the + executable binary file. It does this by removing debugging + information and symbols. + + Not all Haskell implementations generate native binaries. For such + implementations this option has no effect. + + If ``debug-info`` is set explicitly then ``executable-stripping`` is set + to ``False`` as otherwise all the debug symbols will be stripped. + + The command line variant of this flag is + ``--enable-executable-stripping`` and + ``--disable-executable-stripping``. + +.. cfg-field:: library-stripping: boolean + --enable-library-stripping + --disable-library-stripping + :synopsis: Strip installed libraries. + :since: 1.20 + + When installing binary libraries, run the ``strip`` program on the + binary, saving space on the file system. See also + ``executable-stripping``. + + If ``debug-info`` is set explicitly then ``library-stripping`` is set + to ``False`` as otherwise all the debug symbols will be stripped. + + The command line variant of this flag is + ``--enable-library-stripping`` and ``--disable-library-stripping``. + +Executable options +^^^^^^^^^^^^^^^^^^ + +.. cfg-field:: program-prefix: prefix + --program-prefix=prefix + :synopsis: Prepend prefix to program names. + + [STRIKEOUT:Prepend *prefix* to installed program names.] (Currently + implemented in a silly and not useful way. If you need this to work + give us a shout.) + + *prefix* may contain the following path variables: ``$pkgid``, + ``$pkg``, ``$version``, ``$compiler``, ``$os``, ``$arch``, ``$abi``, + ``$abitag`` + + The command line variant of this flag is ``--program-prefix=foo-``. + +.. cfg-field:: program-suffix: suffix + --program-suffix=suffix + :synopsis: Append refix to program names. + + [STRIKEOUT:Append *suffix* to installed program names.] (Currently + implemented in a silly and not useful way. If you need this to work + give us a shout.) + + The most obvious use for this is to append the program's version + number to make it possible to install several versions of a program + at once: ``program-suffix: $version``. + + *suffix* may contain the following path variables: ``$pkgid``, + ``$pkg``, ``$version``, ``$compiler``, ``$os``, ``$arch``, ``$abi``, + ``$abitag`` + + The command line variant of this flag is + ``--program-suffix='$version'``. + +Dynamic linking options +^^^^^^^^^^^^^^^^^^^^^^^ + +.. cfg-field:: shared: boolean + --enable-shared + --disable-shared + :synopsis: Build shared library. + + :default: False + + Build shared library. This implies a separate compiler run to + generate position independent code as required on most platforms. + + The command line variant of this flag is ``--enable-shared`` and + ``--disable-shared``. + +.. cfg-field:: executable-dynamic: boolean + --enable-executable-dynamic + --disable-executable-dynamic + :synopsis: Link executables dynamically. + + :default: False + + Link executables dynamically. The executable's library dependencies + should be built as shared objects. This implies ``shared: True`` + unless ``shared: False`` is explicitly specified. + + The command line variant of this flag is + ``--enable-executable-dynamic`` and + ``--disable-executable-dynamic``. + +.. cfg-field:: library-for-ghci: boolean + --enable-library-for-ghci + --disable-library-for-ghci + :synopsis: Build libraries suitable for use with GHCi. + + :default: True + + Build libraries suitable for use with GHCi. This involves an extra + linking step after the build. + + Not all platforms support GHCi and indeed on some platforms, trying + to build GHCi libs fails. In such cases, consider setting + ``library-for-ghci: False``. + + The command line variant of this flag is + ``--enable-library-for-ghci`` and ``--disable-library-for-ghci``. + +.. cfg-field:: relocatable: + --relocatable + :synopsis: Build relocatable package. + :since: 1.22 + + :default: False + + [STRIKEOUT:Build a package which is relocatable.] (TODO: It is not + clear what this actually does, or if it works at all.) + + The command line variant of this flag is ``--relocatable``. + +Static linking options +^^^^^^^^^^^^^^^^^^^^^^ + +.. cfg-field:: static: boolean + --enable-static + --disable-static + :synopsis: Build static library. + + + :default: False + + Roll this and all dependent libraries into a combined ``.a`` archive. + This uses GHCs ``-staticlib`` flag, which is available for iOS and with + GHC 8.4 and later for other platforms as well. + +.. cfg-field:: executable-static: boolean + --enable-executable-static + --disable-executable-static + :synopsis: Build fully static executables. + + + :default: False + + Build fully static executables. + This links all dependent libraries into executables statically, + including libc. + This passes ``-static`` and ``-optl=-static`` to GHC. + +Foreign function interface options +^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +.. cfg-field:: extra-include-dirs: directories (comma or newline separated list) + --extra-include-dirs=DIR + :synopsis: Adds C header search path. + + An extra directory to search for C header files. You can use this + flag multiple times to get a list of directories. + + You might need to use this flag if you have standard system header + files in a non-standard location that is not mentioned in the + package's ``.cabal`` file. Using this option has the same affect as + appending the directory *dir* to the :pkg-field:`include-dirs` field in each + library and executable in the package's ``.cabal`` file. The + advantage of course is that you do not have to modify the package at + all. These extra directories will be used while building the package + and for libraries it is also saved in the package registration + information and used when compiling modules that use the library. + + The command line variant of this flag is + ``--extra-include-dirs=DIR``, which can be specified multiple times. + +.. cfg-field:: extra-lib-dirs: directories (comma or newline separated list) + --extra-lib-dirs=DIR + :synopsis: Adds library search directory. + + An extra directory to search for system libraries files. + + The command line variant of this flag is ``--extra-lib-dirs=DIR``, + which can be specified multiple times. + +.. cfg-field:: extra-framework-dirs: directories (comma or newline separated list) + --extra-framework-dirs=DIR + :synopsis: Adds framework search directory (OS X only). + + An extra directory to search for frameworks (OS X only). + + You might need to use this flag if you have standard system + libraries in a non-standard location that is not mentioned in the + package's ``.cabal`` file. Using this option has the same affect as + appending the directory *dir* to the :cfg-field:`extra-lib-dirs` field in + each library and executable in the package's ``.cabal`` file. The + advantage of course is that you do not have to modify the package at + all. These extra directories will be used while building the package + and for libraries it is also saved in the package registration + information and used when compiling modules that use the library. + + The command line variant of this flag is + ``--extra-framework-dirs=DIR``, which can be specified multiple + times. + +Profiling options +^^^^^^^^^^^^^^^^^ + +.. cfg-field:: profiling: boolean + --enable-profiling + --disable-profiling + :synopsis: Enable profiling builds. + :since: 1.22 + + :default: False + + Build libraries and executables with profiling enabled (for + compilers that support profiling as a separate mode). It is only + necessary to specify :cfg-field:`profiling` for the specific package you + want to profile; ``cabal build`` will ensure that all of its + transitive dependencies are built with profiling enabled. + + To enable profiling for only libraries or executables, see + :cfg-field:`library-profiling` and :cfg-field:`executable-profiling`. + + For useful profiling, it can be important to control precisely what + cost centers are allocated; see :cfg-field:`profiling-detail`. + + The command line variant of this flag is ``--enable-profiling`` and + ``--disable-profiling``. + +.. cfg-field:: profiling-detail: level + --profiling-detail=level + :synopsis: Profiling detail level. + :since: 1.24 + + Some compilers that support profiling, notably GHC, can allocate + costs to different parts of the program and there are different + levels of granularity or detail with which this can be done. In + particular for GHC this concept is called "cost centers", and GHC + can automatically add cost centers, and can do so in different ways. + + This flag covers both libraries and executables, but can be + overridden by the ``library-profiling-detail`` field. + + Currently this setting is ignored for compilers other than GHC. The + levels that cabal currently supports are: + + default + For GHC this uses ``exported-functions`` for libraries and + ``toplevel-functions`` for executables. + none + No costs will be assigned to any code within this component. + exported-functions + Costs will be assigned at the granularity of all top level + functions exported from each module. In GHC, this + is for non-inline functions. Corresponds to ``-fprof-auto-exported``. + toplevel-functions + Costs will be assigned at the granularity of all top level + functions in each module, whether they are exported from the + module or not. In GHC specifically, this is for non-inline + functions. Corresponds to ``-fprof-auto-top``. + all-functions + Costs will be assigned at the granularity of all functions in + each module, whether top level or local. In GHC specifically, + this is for non-inline toplevel or where-bound functions or + values. Corresponds to ``-fprof-auto``. + + The command line variant of this flag is + ``--profiling-detail=none``. + +.. cfg-field:: library-profiling-detail: level + --library-profiling-detail=level + :synopsis: Libraries profiling detail level. + :since: 1.24 + + Like :cfg-field:`profiling-detail`, but applied only to libraries + + The command line variant of this flag is + ``--library-profiling-detail=none``. + +.. cfg-field:: library-vanilla: boolean + --enable-library-vanilla + --disable-library-vanilla + :synopsis: Build libraries without profiling. + + :default: True + + Build ordinary libraries (as opposed to profiling libraries). + Mostly, you can set this to False to avoid building ordinary + libraries when you are profiling. + + The command line variant of this flag is + ``--enable-library-vanilla`` and ``--disable-library-vanilla``. + +.. cfg-field:: library-profiling: boolean + --enable-library-profiling + --disable-library-profiling + :synopsis: Build libraries with profiling enabled. + :since: 1.22 + + :default: False + + Build libraries with profiling enabled. You probably want + to use :cfg-field:`profiling` instead. + + The command line variant of this flag is + ``--enable-library-profiling`` and ``--disable-library-profiling``. + +.. cfg-field:: executable-profiling: boolean + --enable-executable-profiling + --disable-executable-profiling + :synopsis: Build executables with profiling enabled. + :since: 1.22 + + :default: False + + Build executables with profiling enabled. You probably want + to use :cfg-field:`profiling` instead. + + The command line variant of this flag is + ``--enable-executable-profiling`` and + ``--disable-executable-profiling``. + +Coverage options +^^^^^^^^^^^^^^^^ + +.. cfg-field:: coverage: boolean + --enable-coverage + --disable-coverage + :synopsis: Build with coverage enabled. + :since: 1.22 + + :default: False + + Build libraries and executables (including test suites) with Haskell + Program Coverage enabled. Running the test suites will automatically + generate coverage reports with HPC. + + The command line variant of this flag is ``--enable-coverage`` and + ``--disable-coverage``. + +.. cfg-field:: library-coverage: boolean + --enable-library-coverage + --disable-library-coverage + :since: 1.22 + :deprecated: + + :default: False + + Deprecated, use :cfg-field:`coverage`. + + The command line variant of this flag is + ``--enable-library-coverage`` and ``--disable-library-coverage``. + +Haddock options +^^^^^^^^^^^^^^^ + +.. cfg-field:: documentation: boolean + --enable-documentation + --disable-documentation + :synopsis: Enable building of documentation. + + :default: False + + Enables building of Haddock documentation. + + The command line variant of this flag is ``--enable-documentation`` + and ``--disable-documentation``. + + `documentation: true` does not imply + :cfg-field:`haddock-all`, + :cfg-field:`haddock-benchmarks`, + :cfg-field:`haddock-executables`, + :cfg-field:`haddock-internal` or + :cfg-field:`haddock-tests`. + These need to be enabled separately if desired. + +.. cfg-field:: doc-index-file: templated path + --doc-index-file=TEMPLATE + :synopsis: Path to haddock templates. + + A central index of Haddock API documentation (template cannot use + ``$pkgid``), which should be updated as documentation is built. + +The following commands are equivalent to ones that would be passed when +running ``setup haddock``. + +.. cfg-field:: haddock-hoogle: boolean + --haddock-hoogle + :synopsis: Generate Hoogle file. + + :default: False + + Generate a text file which can be converted by Hoogle_ + into a database for searching. + This is equivalent to running ``haddock`` with the ``--hoogle`` flag. + +.. cfg-field:: haddock-html: boolean + --haddock-html + :synopsis: Build HTML documentation. + + :default: True + + Build HTML documentation. + +.. cfg-field:: haddock-quickjump: boolean + --haddock-quickjump + :synopsis: Generate Quickjump file. + + :default: False + + Generate an index for interactive documentation navigation. + This is equivalent to running ``haddock`` with the ``--quickjump`` flag. + +.. cfg-field:: haddock-html-location: templated path + --haddock-html-location=TEMPLATE + :synopsis: Haddock HTML templates location. + + Specify a template for the location of HTML documentation for + prerequisite packages. The substitutions are applied to the template + to obtain a location for each package, which will be used by + hyperlinks in the generated documentation. For example, the + following command generates links pointing at Hackage pages: + + :: + + html-location: http://hackage.haskell.org/packages/archive/$pkg/latest/doc/html + + If passed on the command line, + the argument may be quoted to prevent substitution by the shell. + + :: + + --html-location='http://hackage.haskell.org/packages/archive/$pkg/latest/doc/html' + + If this option is omitted, the location for each package is obtained + using the package tool (e.g. ``ghc-pkg``). + +.. cfg-field:: haddock-executables: boolean + --haddock-executables + :synopsis: Generate documentation for executables. + + :default: False + + Run haddock on all executable programs. + +.. cfg-field:: haddock-tests: boolean + --haddock-tests + :synopsis: Generate documentation for tests. + + :default: False + + Run haddock on all test suites. + +.. cfg-field:: haddock-benchmarks: boolean + --haddock-benchmarks + :synopsis: Generate documentation for benchmarks. + + :default: False + + Run haddock on all benchmarks. + +.. cfg-field:: haddock-internal: boolean + --haddock-internal + :synopsis: Generate documentation for internal modules + + :default: False + + Build haddock documentation which includes unexposed modules and + symbols. + +.. cfg-field:: haddock-all: boolean + --haddock-all + :synopsis: Generate documentation for everything + + :default: False + + Run haddock on all components. + +.. cfg-field:: haddock-css: path + --haddock-css=PATH + :synopsis: Location of Haddock CSS file. + + The CSS file that should be used to style the generated + documentation (overriding haddock's default). + +.. cfg-field:: haddock-hyperlink-source: boolean + --haddock-hyperlink-source + :synopsis: Generate hyperlinked source code for documentation + + :default: False + + Generated hyperlinked source code using `HsColour`_, and have + Haddock documentation link to it. + This is equivalent to running ``haddock`` with the ``--hyperlinked-source`` flag. + +.. cfg-field:: haddock-hscolour-css: path + --haddock-hscolour-css=PATH + :synopsis: Location of CSS file for HsColour + + The CSS file that should be used to style the generated hyperlinked + source code (from `HsColour`_). + +.. cfg-field:: haddock-contents-location: URL + --haddock-contents-location=URL + :synopsis: URL for contents page. + + A baked-in URL to be used as the location for the contents page. + +.. cfg-field:: haddock-keep-temp-files: boolean + :synopsis: Keep temporary Haddock files. + + Keep temporary files. + + There is no command line variant of this flag. + +.. cfg-field:: open: boolean + --open + :synopsis: Open generated documentation in-browser. + + When generating HTML documentation, attempt to open it in a browser + when complete. This will use ``xdg-open`` on Linux and BSD systems, + ``open`` on macOS, and ``start`` on Windows. + +Advanced global configuration options +------------------------------------- + +.. cfg-field:: write-ghc-environment-files: always, never, or ghc8.4.4+ + --write-ghc-environment-files=policy + :synopsis: Whether a ``.ghc.environment`` should be created after a successful build. + + :default: ``never`` + + Whether a `GHC package environment file `_ + should be created after a successful build. + + Since Cabal 3.0, defaults to ``never``. Before that, defaulted to + creating them only when compiling with GHC 8.4.4 and older (GHC + 8.4.4 `is the first version + `_ that supports + the ``-package-env -`` option that allows ignoring the package + environment files). + +.. cfg-field:: build-info: True, False + --enable-build-info + --disable-build-info + :synopsis: Whether build information for each individual component should be + written in a machine readable format. + + :default: ``False`` + + Enable generation of build information for Cabal components. Contains very + detailed information on how to build an individual component, such as + compiler version, modules of a component and how to compile the component. + + The output format is in json, and the exact location can be discovered from + ``plan.json``, where it is identified by ``build-info`` within the items in + the ``install-plan``. + Note, that this field in ``plan.json`` can be ``null``, if and only if + ``build-type: Custom`` is set, and the ``Cabal`` version is too + old (i.e. ``< 3.7``). + If the field is missing entirely, the component is not a local one, thus, + no ``build-info`` exists for that particular component within the + ``install-plan``. + + .. note:: + The format and fields of the generated build information is currently experimental, + in the future we might add or remove fields, depending on the needs of other tooling. + + +.. cfg-field:: http-transport: curl, wget, powershell, or plain-http + --http-transport=transport + :synopsis: Transport to use with http(s) requests. + + :default: ``curl`` + + Set a transport to be used when making http(s) requests. + + The command line variant of this field is ``--http-transport=curl``. + +.. cfg-field:: ignore-expiry: boolean + --ignore-expiry + :synopsis: Ignore Hackage expiration dates. + + :default: False + + If ``True``, we will ignore expiry dates on metadata from Hackage. + + In general, you should not set this to ``True`` as it will leave you + vulnerable to stale cache attacks. However, it may be temporarily + useful if the main Hackage server is down, and we need to rely on + mirrors which have not been updated for longer than the expiry + period on the timestamp. + + The command line variant of this field is ``--ignore-expiry``. + +.. cfg-field:: remote-repo-cache: directory + --remote-repo-cache=DIR + :synopsis: Location of packages cache. + + :default: ``~/.cabal/packages`` + + [STRIKEOUT:The location where packages downloaded from remote + repositories will be cached.] Not implemented yet. + + The command line variant of this flag is + ``--remote-repo-cache=DIR``. + +.. cfg-field:: logs-dir: directory + --logs-dir=DIR + :synopsis: Directory to store build logs. + + :default: ``~/.cabal/logs`` + + [STRIKEOUT:The location where build logs for packages are stored.] + Not implemented yet. + + The command line variant of this flag is ``--logs-dir=DIR``. + +.. cfg-field:: build-summary: template filepath + --build-summary=TEMPLATE + :synopsis: Build summaries location. + + :default: ``~/.cabal/logs/build.log`` + + [STRIKEOUT:The file to save build summaries. Valid variables which + can be used in the path are ``$pkgid``, ``$compiler``, ``$os`` and + ``$arch``.] Not implemented yet. + + The command line variant of this flag is + ``--build-summary=TEMPLATE``. + +Undocumented fields: ``root-cmd``, ``symlink-bindir``, ``build-log``, +``remote-build-reporting``, ``report-planned-failure``, ``offline``. + +Advanced solver options +^^^^^^^^^^^^^^^^^^^^^^^ + +Most users generally won't need these. + +.. cfg-field:: solver: modular + --solver=modular + :synopsis: Which solver to use. + + This field is reserved to allow the specification of alternative + dependency solvers. At the moment, the only accepted option is + ``modular``. + + The command line variant of this field is ``--solver=modular``. + +.. cfg-field:: max-backjumps: nat + --max-backjumps=N + :synopsis: Maximum number of solver backjumps. + + :default: 4000 + + Maximum number of backjumps (backtracking multiple steps) allowed + while solving. Set -1 to allow unlimited backtracking, and 0 to + disable backtracking completely. + + The command line variant of this field is ``--max-backjumps=4000``. + +.. cfg-field:: reorder-goals: boolean + --reorder-goals + --no-reorder-goals + :synopsis: Allow solver to reorder goals. + + :default: False + + When enabled, the solver will reorder goals according to certain + heuristics. Slows things down on average, but may make backtracking + faster for some packages. It's unlikely to help for small projects, + but for big install plans it may help you find a plan when otherwise + this is not possible. See :issue:`1780` for more commentary. + + The command line variant of this field is ``--(no-)reorder-goals``. + +.. cfg-field:: count-conflicts: boolean + --count-conflicts + --no-count-conflicts + :synopsis: Solver prefers versions with less conflicts. + + :default: True + + Try to speed up solving by preferring goals that are involved in a + lot of conflicts. + + The command line variant of this field is + ``--(no-)count-conflicts``. + +.. cfg-field:: fine-grained-conflicts: boolean + --fine-grained-conflicts + --no-fine-grained-conflicts + :synopsis: Skip a version of a package if it does not resolve any conflicts + encountered in the last version (solver optimization). + + :default: True + + When enabled, the solver will skip a version of a package if it does not + resolve any of the conflicts encountered in the last version of that + package. For example, if ``foo-1.2`` depended on ``bar``, and the solver + couldn't find consistent versions for ``bar``'s dependencies, then the + solver would skip ``foo-1.1`` if it also depended on ``bar``. + + The command line variant of this field is + ``--(no-)fine-grained-conflicts``. + +.. cfg-field:: minimize-conflict-set: boolean + --minimize-conflict-set + --no-minimize-conflict-set + :synopsis: Try to improve the solver error message when there is no + solution. + + :default: False + + When there is no solution, try to improve the solver error message + by finding a minimal conflict set. This option may increase run + time significantly, so it is off by default. + + The command line variant of this field is + ``--(no-)minimize-conflict-set``. + +.. cfg-field:: strong-flags: boolean + --strong-flags + --no-strong-flags + :synopsis: Do not defer flag choices when solving. + + :default: False + + Do not defer flag choices. (TODO: Better documentation.) + + The command line variant of this field is ``--(no-)strong-flags``. + +.. cfg-field:: allow-boot-library-installs: boolean + --allow-boot-library-installs + --no-allow-boot-library-installs + :synopsis: Allow cabal to install or upgrade any package. + + :default: False + + By default, the dependency solver doesn't allow ``base``, + ``ghc-prim``, ``integer-simple``, ``integer-gmp``, and + ``template-haskell`` to be installed or upgraded. This flag + removes the restriction. + + The command line variant of this field is + ``--(no-)allow-boot-library-installs``. + +.. cfg-field:: cabal-lib-version: version + --cabal-lib-version=version + :synopsis: Version of Cabal library used to build package. + + This field selects the version of the Cabal library which should be + used to build packages. This option is intended primarily for + internal development use (e.g., forcing a package to build with a + newer version of Cabal, to test a new version of Cabal.) (TODO: + Specify its semantics more clearly.) + + The command line variant of this field is + ``--cabal-lib-version=1.24.0.1``. + +.. cfg-field:: prefer-oldest: boolean + --prefer-oldest + --no-prefer-oldest + :synopsis: Prefer the oldest versions of packages available. + :since: 3.8 + + :default: False + + By default, when solver has a choice of multiple versions of the same + package, it will first try to derive a build plan with the latest + version. This flag switches the behaviour, making the solver + to prefer the oldest packages available. + + The primary use case is to help users in establishing lower bounds + of upstream dependencies. + + The command line variant of this field is ``--(no-)prefer-oldest``. + +.. include:: references.inc diff --git a/cabal/doc/cabaldomain.py b/cabal/doc/cabaldomain.py new file mode 100644 --- /dev/null +++ b/cabal/doc/cabaldomain.py @@ -0,0 +1,917 @@ +# -*- coding: utf-8 -*- +''' +Sphinx domain for documenting all things cabal + +The main reason to use this instead of adding object types to std domain +is the ability to generate nice 'Reference' page and also provide some meta +data for objects described with directives described here. + +Most directives have at least following optional arguments + +`:since: 1.24` + version of Cabal in which feature was added. + +`:deprecated: 1.24` +`:deprecated:` + Feature was deprecated, and optionally since which version. + +`:removed: 3.0` + Feature was removed + +`:synopsis: Short desc` + Text used as short description on reference page. + + +Added directives + +.. rst:directive:: .. cabal::cfg-section + + Describes a package.cabal section, such as library or executable. + + All following `pkg-field` directives will add section name + to their fields name for disambiguating duplicates. + + You can reset the section disambiguation with `.. pkg-section:: None`. + +.. rst::role:: pkg-section + + References section added by `.. pkg-section` + +.. rst:directive:: .. cabal::pkg-field + + Describes a package.cabal field. + + Can have a :default: field. Will group on reference page under pkg-section + if set and parent header otherwise. + +.. rst::role:: pkg-field + + References field added by `.. pkg-field`, fields can be disambiguated + with section name `:pkg-field:`section:field`. + + +.. rst:directive:: .. cabal:cfg-section:: + + Same as `.. cabal::pkg-section` but does not produce any visible output + currently unused. + +.. rst:directive:: .. cabal:cfg-field:: + + Describes a cabal.project field. + + Can have multiple arguments, if arguments start with '-' then it is treated + as a cabal flag. + + Can have a :default: field. Will group on reference page under pkg-section + if set and parent header otherwise. + +.. rst::role:: cfg-field + + References field added by `.. cfg-field`. + +.. rst::role:: cfg-flag + + References flag added by `.. cfg-field`. + + +All roles can be supplied with title as in standard sphinx references:: + + :pkg-field:`Build dependencies` + + +To be done: + +- Directives for describing executables, their subcommands and flags. + + These should act in a way similar to `.. std::option` directive, but with + extra meta. And should also end up in reference. + + At least setup and 'new-build` subcommands should get special directives + +- Improve rendering of flags in `.. cfg-field::` directive. It should be + possible without copy-pasting code from sphinx.directives.ObjectDescription + by examining result of ObjectDescription.run and inserting flags into + desc_content node. + + Alternatively Or `.. flags::` sub-directive can be added which will be aware + of parent `.. cfg-field` directive. + +- With same ObjectDescription.run trick as above, render since and deprecated + info same way as standard object fields, and use fancy rendering only on + references page. + +- Add 'since_version` config value to sphinx env and use it to decide if + version meta info should be rendered on reference page and thus reduce some + clutter. + Can also be used to generate 'Whats new' reference page + +''' + + +import re + +from docutils import nodes +from docutils.parsers.rst import Directive, directives, roles + +import pygments.lexer as lexer +import pygments.token as token + +from distutils.version import StrictVersion + +from sphinx import addnodes +from sphinx.directives import ObjectDescription +from sphinx.domains import ObjType, Domain, Index +from sphinx.domains.std import StandardDomain +from sphinx.locale import _ +from sphinx.roles import XRefRole +from sphinx.util.docfields import Field, DocFieldTransformer +from sphinx.util.nodes import make_refnode + +def parse_deprecated(txt): + if txt is None: + return True + try: + return StrictVersion(txt) + except ValueError: + return True + +def parse_flag(env, sig, signode): + import re + names = [] + for i, flag in enumerate(sig.split(',')): + flag = flag.strip() + sep = '=' + parts = flag.split('=') + if len(parts) == 1: + sep=' ' + parts = flag.split() + if len(parts) == 0: continue + + name = parts[0] + names.append(name) + sig = sep + ' '.join(parts[1:]) + sig = re.sub(r'<([-a-zA-Z ]+)>', r'⟨\1⟩', sig) + if i > 0: + signode += addnodes.desc_name(', ', ', ') + signode += addnodes.desc_name(name, name) + if len(sig) > 0: + signode += addnodes.desc_addname(sig, sig) + + return names[0] + + +class Meta(object): + ''' + Meta data associated with object + ''' + def __init__(self, + since=None, + deprecated=None, + removed=None, + synopsis=None, + title=None, + section=None, + index=0): + self.since = since + self.deprecated = deprecated + self.removed = removed + self.synopsis = synopsis + self.title = title + self.section = section + self.index = index + + +def find_section_title(parent): + ''' + Find current section id and title if possible + ''' + while parent is not None: + if isinstance(parent, nodes.section): + break + parent = parent.parent + + if parent is None: + return None + + section_id = parent['ids'][0] + section_name = parent['names'][0] + + for kid in parent: + if isinstance(kid, nodes.title): + return kid.astext(), section_id + + print(section_name, section_id) + return section_name, section_id + + +class CabalSection(Directive): + """ + Marks section to which following objects belong, used to disambiguate + references to fields and flags which can have similar names + + Does not generate any output besides anchor. + """ + has_content = False + required_arguments = 1 + optional_arguments = 0 + final_argument_whitespace = True + option_spec = { + 'name': lambda x: x, + 'deprecated': parse_deprecated, + 'removed': StrictVersion, + 'since' : StrictVersion, + 'synopsis' : lambda x:x, + } + section_key = 'cabal:pkg-section' + target_prefix = 'pkg-section-' + indextemplate = '' + indextype = 'pair' + + def get_index_entry(self, name): + return self.indextemplate % name + + def run(self): + env = self.state.document.settings.env + section = self.arguments[0].strip() + + if ':' in self.name: + self.domain, self.objtype = self.name.split(':', 1) + else: + self.domain, self.objtype = '', self.name + + if section == 'None': + env.ref_context.pop(self.section_key, None) + return [] + + env.ref_context[self.section_key] = section + targetname = self.target_prefix + section + node = nodes.target('', '', ids=[targetname]) + self.state.document.note_explicit_target(node) + + indexentry = self.get_index_entry(section) + + inode = addnodes.index( + entries = [ + (self.indextype, indexentry, targetname, '', None)]) + + # find title of parent section node + title = find_section_title(self.state.parent) + + data_key = CabalDomain.types[self.objtype] + + # find how many sections in this document were added + num = env.domaindata['cabal']['index-num'].get(env.docname, 0) + env.domaindata['cabal']['index-num'][env.docname] = num + 1 + + meta = Meta(since=self.options.get('since'), + deprecated=self.options.get('deprecated'), + removed=self.options.get('removed'), + synopsis=self.options.get('synopsis'), + index = num, + title = title) + + store = env.domaindata['cabal'][data_key] + if not section in store: + store[section] = env.docname, targetname, meta + + return [inode, node] + + +class CabalObject(ObjectDescription): + option_spec = { + 'noindex' : directives.flag, + 'deprecated': parse_deprecated, + 'removed' : StrictVersion, + 'since' : StrictVersion, + 'synopsis' : lambda x:x + } + + # node attribute marking which section field belongs to + section_key = '' + # template for index, it is passed a field name as argument + # used by default deg_index_entry method + indextemplate = '' + + def get_meta(self): + ''' + Collect meta data for fields + + Reads optional arguments passed to directive and also + tries to find current section title and adds it as section + ''' + env = self.state.document.settings.env + # find title of current section, will group references page by it + num = env.domaindata['cabal']['index-num'].get(env.docname, 0) + env.domaindata['cabal']['index-num'][env.docname] = num + 1 + + title = find_section_title(self.state.parent) + return Meta(since=self.options.get('since'), + deprecated=self.options.get('deprecated'), + removed=self.options.get('removed'), + title=title, + index = num, + synopsis=self.options.get('synopsis')) + + def get_env_key(self, env, name): + ''' + Should return a key used to reference this field and key in domain + data to store this object + ''' + section = self.env.ref_context.get(self.section_key) + store = CabalDomain.types[self.objtype] + return (section, name), store + + def get_index_entry(self, env, name): + ''' + Should return index entry and anchor + + By default uses indextemplate attribute to generate name and + index entry by joining directive name, section and field name + ''' + section = self.env.ref_context.get(self.section_key) + + if section is not None: + parts = (self.objtype, section, name) + indexentry = self.indextemplate % (section + ':' + name) + else: + parts = (self.objtype, name) + indexentry = self.indextemplate % name + + targetname = '-'.join(parts) + return indexentry, targetname + + + def add_target_and_index(self, name, sig, signode): + ''' + As in sphinx.directive.ObjectDescription + + By default adds 'pair' index as returned by get_index_entry and + stores object data into domain data store as returned by get_env_data + ''' + env = self.state.document.settings.env + + indexentry, targetname = self.get_index_entry(self, name) + + signode['ids'].append(targetname) + self.state.document.note_explicit_target(signode) + + inode = addnodes.index( + entries=[('pair', indexentry, targetname, '', None)]) + signode.insert(0, inode) + + key, store = self.get_env_key(env, name) + env.domaindata['cabal'][store][key] = env.docname, targetname, self.cabal_meta + + def run(self): + self.cabal_meta = self.get_meta() + result = super(CabalObject, self).run() + + if self.cabal_meta.since is not None \ + or self.cabal_meta.deprecated is not None: + + #find content part of description + for item in result: + if isinstance(item, addnodes.desc): + desc = item + break + else: + return result + + for item in desc: + if isinstance(item, addnodes.desc_content): + contents = item + break + else: + return result + + # find exsting field list and add to it + # or create new one + for item in contents: + if isinstance(item, nodes.field_list): + field_list = item + break + else: + field_list = nodes.field_list('') + contents.insert(0, field_list) + + + if self.cabal_meta.since is not None: + #docutils horror + field = nodes.field('') + field_name = nodes.field_name('Since', 'Since') + since = 'Cabal ' + str(self.cabal_meta.since) + field_body = nodes.field_body(since, nodes.paragraph(since, since)) + field += field_name + field += field_body + field_list.insert(0, field) + + if self.cabal_meta.deprecated is not None: + field = nodes.field('') + field_name = nodes.field_name('Deprecated', 'Deprecated') + if isinstance(self.cabal_meta.deprecated, StrictVersion): + since = 'Cabal ' + str(self.cabal_meta.deprecated) + else: + since = '' + + field_body = nodes.field_body(since, nodes.paragraph(since, since)) + field += field_name + field += field_body + field_list.insert(0, field) + + if self.cabal_meta.removed is not None: + field = nodes.field('') + field_name = nodes.field_name('Removed', 'Removed') + if isinstance(self.cabal_meta.removed, StrictVersion): + since = 'Cabal ' + str(self.cabal_meta.removed) + else: + since = '' + + field_body = nodes.field_body(since, nodes.paragraph(since, since)) + field += field_name + field += field_body + field_list.insert(0, field) + return result + +class CabalPackageSection(CabalObject): + """ + Cabal section in package.cabal file + """ + section_key = 'cabal:pkg-section' + indextemplate = '%s; package.cabal section' + + def handle_signature(self, sig, signode): + ''' + As in sphinx.directives.ObjectDescription + + By default make an object description from name and adding + either deprecated or since as annotation. + ''' + env = self.state.document.settings.env + + sig = sig.strip() + parts = sig.split(' ',1) + name = parts[0] + signode += addnodes.desc_name(name, name) + signode += addnodes.desc_addname(' ', ' ') + if len(parts) > 1: + rest = parts[1].strip() + signode += addnodes.desc_annotation(rest, rest) + + return name + + def get_env_key(self, env, name): + store = CabalDomain.types[self.objtype] + return name, store + + def run(self): + env = self.state.document.settings.env + section = self.arguments[0].strip().split(' ',1)[0] + if section == 'None': + env.ref_context.pop('cabal:pkg-section', None) + return [] + env.ref_context['cabal:pkg-section'] = section + return super(CabalPackageSection, self).run() + + +class CabalField(CabalObject): + ''' + Base for fields in *.cabal files + ''' + option_spec = { + 'noindex' : directives.flag, + 'deprecated': parse_deprecated, + 'removed' : StrictVersion, + 'since' : StrictVersion, + 'synopsis' : lambda x:x + } + + doc_field_types = [ + Field('default', label='Default value', names=['default'], has_arg=False) + ] + + def handle_signature(self, sig, signode): + ''' + As in sphinx.directives.ObjectDescription + + By default make an object description from name and adding + either deprecated or since as annotation. + ''' + env = self.state.document.settings.env + + sig = sig.strip() + parts = sig.split(':',1) + name = parts[0] + signode += addnodes.desc_name(name, name) + signode += addnodes.desc_addname(': ', ': ') + + if len(parts) > 1: + rest = parts[1].strip() + signode += addnodes.desc_annotation(rest, rest) + + return name + +class CabalPackageField(CabalField): + ''' + Describes section in package.cabal file + ''' + section_key = 'cabal:pkg-section' + indextemplate = '%s; package.cabal field' + +class CabalFieldXRef(XRefRole): + ''' + Cross ref node for all kinds of fields + + Gets section_key entry from context and stores it on node, so it can + later be used by CabalDomain.resolve_xref to find target for reference to + this + ''' + section_key = 'cabal:pkg-section' + def process_link(self, env, refnode, has_explicit_title, title, target): + parts = target.split(':',1) + if len(parts) == 2: + section, target = parts + section = section.strip() + target = target.strip() + refnode[self.section_key] = section + else: + refnode[self.section_key] = env.ref_context.get(self.section_key) + + return title, target + +# +# Directives for config files. +# + +class CabalPackageFieldXRef(CabalFieldXRef): + ''' + Role referencing cabal.project section + ''' + section_key = 'cabal:pkg-section' + +class CabalConfigSection(CabalSection): + """ + Marks section in package.cabal file + """ + indextemplate = '%s; cabal.project section' + section_key = 'cabal:cfg-section' + target_prefix = 'cfg-section-' + +class ConfigField(CabalField): + section_key = 'cabal:cfg-section' + indextemplate = '%s ; cabal project option' + def handle_signature(self, sig, signode): + sig = sig.strip() + if sig.startswith('-'): + name = parse_flag(self, sig, signode) + else: + name = super(ConfigField, self).handle_signature(sig, signode) + + return name + + def get_index_entry(self, env, name): + if name.startswith('-'): + section = self.env.ref_context.get(self.section_key) + if section is not None: + parts = ('cfg-flag', section, name) + indexname = section + ':' + name + else: + parts = ('cfg-flag', name) + indexname = name + indexentry = name + '; cabal project option' + targetname = '-'.join(parts) + return indexentry, targetname + else: + return super(ConfigField,self).get_index_entry(env, name) + + def get_env_key(self, env, name): + section = self.env.ref_context.get(self.section_key) + if name.startswith('-'): + return (section, name), 'cfg-flags' + return (section, name), 'cfg-fields' + +class CabalConfigFieldXRef(CabalFieldXRef): + section_key = 'cabal:cfg-section' + + +# +# Cabal domain +# + +class ConfigFieldIndex(Index): + name = 'projectindex' + localname = "Cabal reference" + shortname = "Reference" + + class Entry(object): + def __init__(self, typ, name, doc, anchor, meta): + self.type = typ + self.name = name + self.doc = doc + self.anchor = anchor + self.meta = meta + + def _gather_data(self, obj_types): + ''' + Gather objects and return [(title, [Entry])] + ''' + def massage(typ, datum): + name, (doc, anchor, meta) = datum + return self.Entry(typ, name, doc, anchor, meta) + + fields = [] + for typ in obj_types: + store = CabalDomain.types[typ] + fields += [massage(typ, x) + for x in self.domain.data[store].items()] + + fields.sort(key=lambda x: (x.doc, x.meta.index)) + + if len(fields) == 0: + return [] + + result = [] + current = [] + current_title = fields[0].meta.title + for field in fields: + if field.meta.title != current_title: + result.append((current_title, current)) + current = [] + current_title = field.meta.title + current.append(field) + result.append((current_title, current)) + + return result + + + def generate(self, docnames=None): + ''' + Try to group entries such that if entry has a section then put it + into same group. + + Otherwise group it under same `title`. + + Try to keep in same order as it was defined. + + sort by (document, index) + group on (document, doc_section) + + TODO: Check how to extract section numbers from (document,doc_section) + and add it as annotation to titles + ''' + + # (title, section store, fields store) + entries = [('cabal.project fields', 'cfg-section', 'cfg-field'), + ('cabal project flags', 'cfg-section', 'cfg-flag'), + ('package.cabal fields', 'pkg-section', 'pkg-field')] + + result = [] + for label, section_key, key in entries: + + data = self._gather_data([section_key, key]) + + references = [] + for section, entries in data: + if section is None: + elem_type = 0 # Normal entry + else: + elem_type = 2 # sub_entry + + assert len(entries) != 0 + docname = entries[0].doc + if section is not None: + section_title, section_anchor = section + references.append( + (section_title, 1, docname, section_anchor, '', '', '')) + + for entry in entries: + #todo deal with if + if isinstance(entry.name, tuple): + name = entry.name[1] + else: + name = entry.name + + meta = entry.meta + extra = render_meta(meta) + descr = meta.synopsis if meta.synopsis is not None else '' + field = (name, elem_type, docname, + entry.anchor, extra, '', descr) + references.append(field) + result.append((label, references)) + + return result, False + +def make_data_keys(typ, target, node): + ''' + Returns a list of keys to search for targets of this type + in domain data. + + Used for resolving references + ''' + if typ == 'pkg-field': + section = node.get('cabal:pkg-section') + return [(section, target), + (None, target)] + elif typ in ('cfg-field', 'cfg-flag'): + section = node.get('cabal:cfg-section') + return [(section, target), (None, target)] + else: + return [target] + + +def render_deprecated(deprecated): + if isinstance(deprecated, StrictVersion): + return 'deprecated since: '+str(deprecated) + else: + return 'deprecated' + +def render_removed(deprecated, removed): + if isinstance(deprecated, StrictVersion): + return 'removed in: ' + str(removed) + '; deprecated since: '+str(deprecated) + else: + return 'removed in: ' + str(removed) + +def render_meta(meta): + ''' + Render meta as short text + + Will render either deprecated or since info + ''' + if meta.removed is not None: + return render_removed(meta.deprecated, meta.removed) + if meta.deprecated is not None: + return render_deprecated(meta.deprecated) + elif meta.since is not None: + return 'since version: ' + str(meta.since) + else: + return '' + +def render_meta_title(meta): + ''' + Render meta as suitable to use in titles + ''' + rendered = render_meta(meta) + if rendered != '': + return '(' + rendered + ')' + return '' + +def make_title(typ, key, meta): + ''' + Render title of an object (section, field or flag) + ''' + if typ == 'pkg-section': + return "package.cabal " + key + " section " + render_meta_title(meta) + + elif typ == 'pkg-field': + section, name = key + if section is not None: + base = "package.cabal " + section + " section " + name + ": field" + else: + base = "package.cabal " + name + " field" + + return base + render_meta_title(meta) + + elif typ == 'cfg-section': + return "cabal.project " + key + " section " + render_meta_title(meta) + + elif typ == 'cfg-field': + section, name = key + return "cabal.project " + name + " field " + render_meta_title(meta) + + elif typ == 'cfg-flag': + section, name = key + return "cabal flag " + name + " " + render_meta_title(meta) + + else: + raise ValueError("Unknown type: " + typ) + +def make_full_name(typ, key, meta): + ''' + Return an anchor name for object type + ''' + if typ == 'pkg-section': + return 'pkg-section-' + key + + elif typ == 'pkg-field': + section, name = key + if section is not None: + return '-'.join(('pkg-field',section, name)) + else: + return 'pkg-field-' + name + + elif typ == 'cfg-field': + return 'cfg-field-' + key + + else: + raise ValueError('Unknown object type: ' + typ) + +class CabalDomain(Domain): + ''' + Sphinx domain for cabal + + needs Domain.merge_doc for parallel building, just union all dicts + ''' + name = 'cabal' + label = 'Cabal' + object_types = { + 'pkg-section': ObjType(_('pkg-section'), 'pkg-section'), + 'pkg-field' : ObjType(_('pkg-field') , 'pkg-field' ), + 'cfg-section': ObjType(_('cfg-section'), 'cfg-section'), + 'cfg-field' : ObjType(_('cfg-field') , 'cfg-field' ), + } + directives = { + 'pkg-section': CabalPackageSection, + 'pkg-field' : CabalPackageField, + 'cfg-section': CabalConfigSection, + 'cfg-field' : ConfigField, + } + roles = { + 'pkg-section': XRefRole(warn_dangling=True), + 'pkg-field' : CabalPackageFieldXRef(warn_dangling=True), + 'cfg-section': XRefRole(warn_dangling=True), + 'cfg-field' : CabalConfigFieldXRef(warn_dangling=True), + 'cfg-flag' : CabalConfigFieldXRef(warn_dangling=True), + } + initial_data = { + 'pkg-sections': {}, + 'pkg-fields' : {}, + 'cfg-sections': {}, + 'index-num' : {}, #per document number of objects + # used to order references page + 'cfg-fields' : {}, + 'cfg-flags' : {}, + } + indices = [ + ConfigFieldIndex + ] + types = { + 'pkg-section': 'pkg-sections', + 'pkg-field' : 'pkg-fields', + 'cfg-section': 'cfg-sections', + 'cfg-field' : 'cfg-fields', + 'cfg-flag' : 'cfg-flags', + } + def clear_doc(self, docname): + for k in ['pkg-sections', 'pkg-fields', 'cfg-sections', + 'cfg-fields', 'cfg-flags']: + to_del = [] + for name, (fn, _, _) in self.data[k].items(): + if fn == docname: + to_del.append(name) + for name in to_del: + del self.data[k][name] + try: + del self.data['index-num'][docname] + except KeyError: + pass + + def resolve_xref(self, env, fromdocname, builder, type, target, node, contnode): + objtypes = self.objtypes_for_role(type) + for typ, key in ((typ, key) + for typ in objtypes + for key in make_data_keys(typ, target, node)): + try: + data = env.domaindata['cabal'][self.types[typ]][key] + except KeyError: + continue + doc, ref, meta = data + title = make_title(typ, key, meta) + return make_refnode(builder, fromdocname, doc, ref, contnode, title) + + def get_objects(self): + ''' + Used for search functionality + ''' + for typ in ['pkg-section', 'pkg-field', + 'cfg-section', 'cfg-field', 'cfg-flag']: + key = self.types[typ] + for name, (fn, target, meta) in self.data[key].items(): + title = make_title(typ, name, meta) + yield title, title, typ, fn, target, 0 + +class CabalLexer(lexer.RegexLexer): + ''' + Basic cabal lexer, does not try to be smart + ''' + name = 'Cabal' + aliases = ['cabal'] + filenames = ['.cabal'] + flags = re.MULTILINE + + tokens = { + 'root' : [ + (r'^(\s*)(--.*)$', lexer.bygroups(token.Whitespace, token.Comment.Single)), + # key: value + (r'^(\s*)([\w\-_]+)(:)', + lexer.bygroups(token.Whitespace, token.Keyword, token.Punctuation)), + (r'^([\w\-_]+)', token.Keyword), # library, executable, flag etc. + (r'[^\S\n]+', token.Text), + (r'&&|\|\||==|<=|\^>=|>=|<|>', token.Operator), + (r',|:|{|}', token.Punctuation), + (r'.', token.Text) + ], + } + +def setup(app): + app.add_domain(CabalDomain) + app.add_lexer('cabal', CabalLexer) + diff --git a/cabal/doc/concepts-and-development.rst b/cabal/doc/concepts-and-development.rst new file mode 100644 --- /dev/null +++ b/cabal/doc/concepts-and-development.rst @@ -0,0 +1,7 @@ +Package Concepts and Development +================================ + +.. toctree:: + :maxdepth: 2 + + developing-packages diff --git a/cabal/doc/conf.py b/cabal/doc/conf.py new file mode 100644 --- /dev/null +++ b/cabal/doc/conf.py @@ -0,0 +1,227 @@ +# -*- coding: utf-8 -*- +# +# GHC Users Guide documentation build configuration file +# +# This file is execfile()d with the current directory set to its +# containing dir. +# +import sys +import os +import sphinx_rtd_theme + +# Support for :base-ref:, etc. +sys.path.insert(0, os.path.abspath('.')) +import cabaldomain + +version = "3.8.1.0" + +extensions = [ + 'sphinx.ext.extlinks', + 'sphinx.ext.todo', + 'sphinx-jsonschema' +] + +templates_path = ['_templates'] +source_suffix = '.rst' +source_encoding = 'utf-8-sig' +master_doc = 'index' + +# extlinks -- see http://www.sphinx-doc.org/en/stable/ext/extlinks.html +extlinks = { + 'issue': ('https://github.com/haskell/cabal/issues/%s', '#'), + + 'ghc-wiki': ('https://gitlab.haskell.org/ghc/ghc/-/wikis/%s', ''), + 'ghc-ticket': ('https://gitlab.haskell.org/ghc/ghc/-/issues/%s', 'GHC #'), + + 'hackage-pkg': ('http://hackage.haskell.org/package/%s', ''), +} + +# General information about the project. +project = u'Cabal' +copyright = u'2003-2022, Cabal Team' +# N.B. version comes from ghc_config +release = version # The full version, including alpha/beta/rc tags. + +# Syntax highlighting +highlight_language = 'cabal' +#pygments_style = 'tango' + +primary_domain = 'cabal' + +# List of patterns, relative to source directory, that match files and +# directories to ignore when looking for source files. +exclude_patterns = ['.build', "*.gen.rst"] + +# -- Options for HTML output --------------------------------------------- + +# on_rtd is whether we are on readthedocs.org, this line of code grabbed from docs.readthedocs.org +on_rtd = os.environ.get('READTHEDOCS', None) == 'True' + +if not on_rtd: # only import and set the theme if we're building docs locally + import sphinx_rtd_theme + html_theme = 'sphinx_rtd_theme' + html_theme_path = [sphinx_rtd_theme.get_html_theme_path()] + +# The name for this set of Sphinx documents. If None, it defaults to +# " v documentation". +html_title = "Cabal {} User's Guide".format(release) +html_short_title = "Cabal %s User's Guide" % release +html_logo = 'images/Cabal-dark.png' +html_static_path = ['images'] +# Convert quotes and dashes to typographically correct entities +html_use_smartypants = True +html_show_copyright = True +html_context = { + 'source_url_prefix': "https://github.com/haskell/cabal/tree/master/doc/", + "display_github": True, + "github_host": "github.com", + "github_user": "haskell", + "github_repo": 'cabal', + "github_version": "master/", + "conf_py_path": "doc/", + "source_suffix": '.rst', +} + + +# If true, an OpenSearch description file will be output, and all pages will +# contain a tag referring to it. The value of this option must be the +# base URL from which the finished HTML is served. +#html_use_opensearch = '' + +# This is the file name suffix for HTML files (e.g. ".xhtml"). +#html_file_suffix = None + +# Output file base name for HTML help builder. +htmlhelp_basename = 'CabalUsersGuide' + +# MathJax to use SVG rendering by default +mathjax_path = 'https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.5/latest.js?config=TeX-AMS-MML_SVG' + + +# -- Options for LaTeX output --------------------------------------------- + +latex_elements = { + 'inputenc': '', + 'utf8extra': '', + 'preamble': r''' +\usepackage{fontspec} +\usepackage{makeidx} +\setsansfont{DejaVu Sans} +\setromanfont{DejaVu Serif} +\setmonofont{DejaVu Sans Mono} +''', +} + +# Grouping the document tree into LaTeX files. List of tuples +# (source start file, target name, title, +# author, documentclass [howto, manual, or own class]). +latex_documents = [ + ('index', 'users_guide.tex', u'GHC Users Guide Documentation', + u'GHC Team', 'manual'), +] + +# The name of an image file (relative to this directory) to place at the top of +# the title page. +#latex_logo = 'images/logo.pdf' +latex_logo = 'images/Cabal-dark.png' + +# If true, show page references after internal links. +latex_show_pagerefs = True + +# http://www.sphinx-doc.org/en/master/usage/extensions/todo.html +todo_include_todos = True + +# -- Options for manual page output --------------------------------------- + +# One entry per manual page. List of tuples +# (source start file, name, description, authors, manual section). +man_pages = [ + ('cabal', 'cabal', 'The Haskell Cabal', 'The Cabal Team', 1) +] + +# If true, show URL addresses after external links. +#man_show_urls = False + + +# -- Options for Texinfo output ------------------------------------------- + +# Grouping the document tree into Texinfo files. List of tuples +# (source start file, target name, title, author, +# dir menu entry, description, category) +texinfo_documents = [ + ('index', 'CabalUsersGuide', u'Cabal Users Guide', + u'Cabal Team', 'CabalUsersGuide', 'The Haskell Cabal.', + 'Compilers'), +] + +from sphinx import addnodes +from docutils import nodes + +def parse_ghci_cmd(env, sig, signode): + name = sig.split(';')[0] + sig = sig.replace(';', '') + signode += addnodes.desc_name(name, sig) + return name + +def parse_flag(env, sig, signode): + import re + names = [] + for i, flag in enumerate(sig.split(',')): + flag = flag.strip() + sep = '=' + parts = flag.split('=') + if len(parts) == 1: + sep=' ' + parts = flag.split() + if len(parts) == 0: continue + + name = parts[0] + names.append(name) + sig = sep + ' '.join(parts[1:]) + sig = re.sub(r'<([-a-zA-Z ]+)>', r'⟨\1⟩', sig) + if i > 0: + signode += addnodes.desc_name(', ', ', ') + signode += addnodes.desc_name(name, name) + if len(sig) > 0: + signode += addnodes.desc_addname(sig, sig) + + return names[0] + +def setup(app): + from sphinx.util.docfields import Field, TypedField + + increase_python_stack() + + # the :ghci-cmd: directive used in ghci.rst + app.add_object_type('ghci-cmd', 'ghci-cmd', + parse_node=parse_ghci_cmd, + objname='GHCi command', + indextemplate='pair: %s; GHCi command') + + app.add_object_type('ghc-flag', 'ghc-flag', + objname='GHC command-line option', + parse_node=parse_flag, + indextemplate='pair: %s; GHC option', + doc_field_types=[ + Field('since', label='Introduced in GHC version', names=['since']), + Field('default', label='Default value', names=['default']), + Field('static') + ]) + + app.add_object_type('rts-flag', 'rts-flag', + objname='runtime system command-line option', + parse_node=parse_flag, + indextemplate='pair: %s; RTS option', + doc_field_types=[ + Field('since', label='Introduced in GHC version', names=['since']), + ]) + + cabaldomain.setup(app) + +def increase_python_stack(): + # Workaround sphinx-build recursion limit overflow: + # pickle.dump(doctree, f, pickle.HIGHEST_PROTOCOL) + # RuntimeError: maximum recursion depth exceeded while pickling an object + # + # Default python allows recursion depth of 1000 calls. + sys.setrecursionlimit(10000) diff --git a/cabal/doc/config.rst b/cabal/doc/config.rst new file mode 100644 --- /dev/null +++ b/cabal/doc/config.rst @@ -0,0 +1,258 @@ +Configuration +============= + +.. highlight:: cabal + +Overview +-------- + +The global configuration file for ``cabal-install`` is by default +``$HOME/.cabal/config``. If you do not have this file, ``cabal`` will create +it for you on the first call to ``cabal update`` +(details see `configuration file discovery`_). +Alternatively, you can explicitly ask ``cabal`` to create it for you using + +.. code-block:: console + + $ cabal user-config update + +You can change the location of the global configuration file by specifying +either ``--config-file=FILE`` on the command line or by setting the +``CABAL_CONFIG`` environment variable. + +Most of the options in this configuration file are also available as +command line arguments, and the corresponding documentation can be used +to lookup their meaning. The created configuration file only specifies +values for a handful of options. Most options are left at their default +value, which it documents; for instance, + +:: + + -- executable-stripping: True + +means that the configuration file currently does not specify a value for +the ``executable-stripping`` option (the line is commented out), and +that the default is ``True``; if you wanted to disable stripping of +executables by default, you would change this line to + +:: + + executable-stripping: False + +You can also use ``cabal user-config update`` to migrate configuration +files created by older versions of ``cabal``. + +Environment variables +--------------------- + +Various environment variables affect ``cabal-install``. + +``CABAL_CONFIG`` + The variable to find global configuration file. + +``CABAL_DIR`` + Default content directory for ``cabal-install`` files. + Default value is ``getAppUserDataDirectory "cabal"``, which is + ``$HOME/.cabal`` on unix systems and ``%APPDATA%\cabal`` in Windows. + + .. note:: + + The CABAL_DIR might be dropped in the future, when + ``cabal-install`` starts to use XDG Directory specification. + +``CABAL_BUILDDIR`` + The override for default ``dist`` build directory. + Note, the nix-style builds build directory (``dist-newstyle``) + is not affected by this environment variable. + +.. _config-file-discovery: + +Configuration file discovery +^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +The configuration file location is determined as follows: + +1. If option ``--config-file`` is given, use it; +2. otherwise, if ``$CABAL_CONFIG`` is set use it; +3. otherwise, if ``$CABAL_DIR`` is set use ``$CABAL_DIR/config``; +4. otherwise use ``config`` in ``getAppUserDirectory "cabal"``. + +If the configuration file does not exist, and it was not given +explicitly via ``--config-file`` or ``$CABAL_CONFIG``, then +``cabal-install`` will generate the default one, with directories +based on ``$CABAL_DIR`` (if set) or ``getAppUserDirectory "cabal"`` +prefix. + +Repository specification +------------------------ + +An important part of the configuration is the specification of the +repository. When ``cabal`` creates a default config file, it configures +the repository to be the central Hackage server: + +:: + + repository hackage.haskell.org + url: http://hackage.haskell.org/ + +The name of the repository is given on the first line, and can be +anything; packages downloaded from this repository will be cached under +``~/.cabal/packages/hackage.haskell.org`` (or whatever name you specify; +you can change the prefix by changing the value of +:cfg-field:`remote-repo-cache`). If you want, you can configure multiple +repositories, and ``cabal`` will combine them and be able to download +packages from any of them. + +Using secure repositories +^^^^^^^^^^^^^^^^^^^^^^^^^ + +When interacting with ``hackage.haskell.org``, Cabal always runs in secure mode +with standard root keys, so it is not necessary to specify ``secure`` or +``root-keys``. If no repositories are listed, Cabal will default to +``hackage.haskell.org``. + +For non-Hackage repositories that support the TUF security infrastructure you +can enable secure access to the repository by specifying: + +:: + + repository packages.example.org + url: http://packages.example.org/ + secure: True + root-keys: + key-threshold: + +The ```` and ```` values are used for +bootstrapping. As part of the TUF infrastructure the repository will +contain a file ``root.json`` (for instance, +http://hackage.haskell.org/root.json) which the client needs to do +verification. However, how can ``cabal`` verify the ``root.json`` file +*itself*? This is known as bootstrapping: if you specify a list of root +key IDs and a corresponding threshold, ``cabal`` will verify that the +downloaded ``root.json`` file has been signed with at least +```` keys from your set of ````. + +You can, but are not recommended to, omit these two fields. In that case +``cabal`` will download the ``root.json`` field and use it without +verification. Although this bootstrapping step is then unsafe, all +subsequent access is secure (provided that the downloaded ``root.json`` +was not tampered with). Of course, adding ``root-keys`` and +``key-threshold`` to your repository specification only shifts the +problem, because now you somehow need to make sure that the key IDs you +received were the right ones. How that is done is however outside the +scope of ``cabal`` proper. + +More information about the security infrastructure can be found at +https://github.com/haskell/hackage-security. + +Local no-index repositories +^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +It's possible to use a directory of `.tar.gz` package files as a local package +repository. + +:: + + repository my-local-repository + url: file+noindex:///absolute/path/to/directory + +``cabal`` will construct the index automatically from the +``package-name-version.tar.gz`` files in the directory, and will use optional +corresponding ``package-name-version.cabal`` files as new revisions. + +For example, if ``/absolute/path/to/directory`` looks like +:: + + /absolute/path/to/directory/ + foo-0.1.0.0.tar.gz + bar-0.2.0.0.tar.gz + bar-0.2.0.0.cabal + +then ``cabal`` will create an index with two packages: + +- ``foo-0.1.0.0`` using the source and ``.cabal`` file inside + ``foo-0.1.0.0.tar.gz`` +- ``bar-0.2.0.0`` using the source inside ``bar-0.2.0.0.tar.gz`` + and ``bar-0.2.0.0.cabal`` + +The index is cached inside the given directory. If the directory is not +writable, you can append ``#shared-cache`` fragment to the URI, +then the cache will be stored inside the :cfg-field:`remote-repo-cache` directory. +The part of the path will be used to determine the cache key part. + +.. note:: + ``cabal-install`` creates a ``.cache`` file, and will aggressively use + its contents if it exists. Therefore if you change the contents of + the directory, remember to wipe the cache too. + +.. note:: + The URI scheme ``file:`` is interpreted as a remote repository, + as described in the previous sections, thus requiring manual construction + of ``01-index.tar`` file. + +It is possible to define ``preferred-versions``, containing additional version constraints +for deprecating or preferring certain package versions, in the given directory. + +For example, if ``/absolute/path/to/directory`` looks like +:: + + /absolute/path/to/directory/ + foo-0.1.0.0.tar.gz + bar-0.2.0.0.tar.gz + preferred-versions + +then package deprecations and preferences will be taken into account by the solver. + +The contents of ``preferred-versions`` is a list of package version constraints, e.g. +:: + + binary < 0.8.0.0 || > 0.8.0.0 + text == 1.2.0.0 + +thus, looks similar to a ``package-name.cabal``'s ``build-depends`` section. + +.. note:: + The ``preferred-versions`` file can be used to restrict the package set from Hackage, by preferring + certain versions or marking a specific version as deprecated. To achieve this, add a + local no-index repository to your ``~/.cabal/config``, where the directory contains your custom + ``preferred-versions``. After running ``cabal update``, all ``cabal`` operations will honour the + configuration. + +Legacy repositories +^^^^^^^^^^^^^^^^^^^ + +Currently ``cabal`` supports single kind of “legacy” repositories. +It is specified using + +:: + + remote-repo: hackage.haskell.org:http://hackage.haskell.org/packages/archive + +This is just syntactic sugar for + +:: + + repository hackage.haskell.org + url: http://hackage.haskell.org/packages/archive + +although, in (and only in) the specific case of Hackage, the URL +``http://hackage.haskell.org/packages/archive`` will be silently +translated to ``http://hackage.haskell.org/``. + +Secure local repositories +^^^^^^^^^^^^^^^^^^^^^^^^^ + +If you want to use repositories on your local file system, it is +recommended instead to use a *secure* local repository: + +:: + + repository my-local-repo + url: file:/path/to/local/repo + secure: True + root-keys: + key-threshold: + +The layout of these secure local repos matches the layout of remote +repositories exactly; the :hackage-pkg:`hackage-repo-tool` +can be used to create and manage such repositories. diff --git a/cabal/doc/developing-packages.rst b/cabal/doc/developing-packages.rst new file mode 100644 --- /dev/null +++ b/cabal/doc/developing-packages.rst @@ -0,0 +1,547 @@ +Quickstart +========== + +.. TIP:: + If this is your first time using `cabal` you should check out the :doc:`Getting Started guide `. + +Starting from scratch, we're going to walk you through creating a simple +Haskell application. + +**TL;DR;** ``mkdir proglet && cd proglet && cabal init --simple --exe && cabal run proglet`` + + +Introduction +------------ + +Every application needs a name, we'll call ours "proglet" and start by +creating an empty directory. + +.. highlight:: console + +:: + + $ mkdir proglet + $ cd proglet/ + + +.. _init quickstart: + +Using ``cabal init`` +-------------------- + +The ``cabal init`` command creates the necessary files for a Cabal package, +it has both an ``--interactive`` (default) and ``--non-interactive`` +mode. The interactive mode will walk you through many of the package +options and metadata, the non-interactive mode will simply pick reasonable +defaults which is sufficient if you're just trying something out. + +.. highlight:: console + +:: + + $ cabal init --non-interactive + # You can also use -n which is the short version of --non-interactive + +If you want, you can also try out the interactive mode, for now chose +"Executable" when asked what type of package you want to build. + +.. highlight:: console + +:: + + $ cabal init + ... + What does the package build: + 1) Executable + 2) Library + 3) Library and Executable + 4) Test suite + Your choice? + +One of the important questions is whether the package contains a library +and/or an executable. Libraries are collections of Haskell modules that +can be re-used by other Haskell libraries and programs, while executables +are standalone programs. Test suites can both depend on a library or be +standalonely generated. + +For the moment these are the only choices. For more complex packages +(e.g. a library and multiple executables) the ``.cabal`` +file can be edited afterwards. + +After you make your selection (executable; library; library +and executable; or: test suite) cabal asks us a number of questions starting with +which version of the cabal specification to use, our package's name +(for example, "proglet"), and our package's version. + +:: + + Generating CHANGELOG.md... + Generating Main.hs... + Generating proglet.cabal... + +Use the ``ls`` command to see the created files: + +:: + + $ ls + CHANGELOG.md Main.hs proglet.cabal + + +Running the program +------------------- + +Now that we have our Haskell code and the extra files that Cabal needs we +can build and run our application. + +:: + + $ cabal build + Resolving dependencies... + ... + Linking /path/to/proglet ... + + $ cabal run proglet + ... + Hello, Haskell! + +Since we have an executable we can use ``cabal run proglet`` which will build +our executable (and re-build it if we've made any changes) and then run the +binary. The ``cabal run`` command works for any ``component-name`` (tests for +example), not just the main executable. + + +About the Cabal package structure +--------------------------------- + +It is assumed that all the files that make up a package live under a common +root directory (apart from external dependencies). This simple example has +all the package files in one directory, but most packages use one or more +subdirectories. + +Cabal needs one extra file in the package's root directory: + +- ``proglet.cabal``: contains package metadata and build information. + + +Editing the .cabal file +----------------------- + +.. highlight:: cabal + +Load up the ``.cabal`` file in a text editor. The first part of the +``.cabal`` file has the package metadata and towards the end of the file +you will find the :pkg-section:`executable` or :pkg-section:`library` +section. + +You will see that the fields that have yet to be filled in are commented +out. Cabal files use "``--``" Haskell-style comment syntax. + +.. NOTE:: + Comments are only allowed on lines on their own. Trailing comments on + other lines are not allowed because they could be confused with program + options. + + +:: + + executable proglet + main-is: Main.hs + -- other-modules: + -- other-extensions: + build-depends: base >=4.11 && <4.12 + -- hs-source-dirs: + default-language: Haskell2010 + + +If you selected earlier to create a library package then your ``.cabal`` +file will have a section that looks like this: + +:: + + library + exposed-modules: MyLib + -- other-modules: + -- build-depends: + build-depends: base >=4.11 && <4.12 + -- hs-source-dirs: + default-language: Haskell2010 + + +The build information fields listed (but commented out) are just the few +most important and common fields. There are many others that are covered +later in this chapter. + +Most of the build information fields are the same between libraries and +executables. The difference is that libraries have a number of "exposed" +modules that make up the public interface of the library, while +executables have a file containing a ``Main`` module. + +The name of a library always matches the name of the package, so it is +not specified in the library section. Executables often follow the name +of the package too, but this is not required and the name is given +explicitly. + + +Modules included in the package +------------------------------- + +For an executable, ``cabal init`` creates the ``Main.hs`` file which +contains your program's ``Main`` module. It will also fill in the +:pkg-field:`executable:main-is` field with the file name of your program's +``Main`` module, including the ``.hs`` (or ``.lhs``) extension. Other +modules included in the executable should be listed in the +:pkg-field:`other-modules` field. + +For a library, ``cabal init`` looks in the project directory for files +that look like Haskell modules and adds all the modules to the +:pkg-field:`library:exposed-modules` field. For modules that do not form part +of your package's public interface, you can move those modules to the +:pkg-field:`other-modules` field. Either way, all modules in the library need +to be listed. + + +Modules imported from other packages +------------------------------------ + +While your library or executable may include a number of modules, it +almost certainly also imports a number of external modules from the +standard libraries or other pre-packaged libraries. (These other +libraries are of course just Cabal packages that contain a library.) + +You have to list all of the library packages that your library or +executable imports modules from. Or to put it another way: you have to +list all the other packages that your package depends on. + +For example, suppose the example ``Proglet`` module imports the module +``Data.Map``. The ``Data.Map`` module comes from the ``containers`` +package, so we must list it: + +:: + + library + exposed-modules: Proglet + other-modules: + build-depends: containers, base >=4.11 && <4.12 + +In addition, almost every package also depends on the ``base`` library +package because it exports the standard ``Prelude`` module plus other +basic modules like ``Data.List``. + +You will notice that we have listed ``base >=4.11 && <4.12``. This gives a +constraint on the version of the base package that our package will work +with. The most common kinds of constraints are: + +- ``pkgname >=n`` +- ``pkgname ^>=n`` (since Cabal 2.0) +- ``pkgname >=n && =4 && <5``. Please refer to the documentation +on the :pkg-field:`build-depends` field for more information. + +Also, you can factor out shared ``build-depends`` (and other fields such +as ``ghc-options``) into a ``common`` stanza which you can ``import`` in +your libraries and executable sections. For example: + +:: + + common shared-properties + default-language: Haskell2010 + build-depends: + base == 4.* + ghc-options: + -Wall + + library + import: shared-properties + exposed-modules: + Proglet + +Note that the ``import`` **must** be the first thing in the stanza. For more +information see the :ref:`common-stanzas` section. + +.. _building-packages: + +Building the package +-------------------- + +For simple packages that's it! We can now try building the package, +which also downloads and builds all required dependencies: + +.. code-block:: console + + $ cabal build + +If the package contains an executable, you can run it with: + +.. code-block:: console + + $ cabal run + +and the executable can also be installed for convenience: + +.. code-block:: console + + $ cabal install + +When installed, the executable program lands in a special directory +for binaries that may or may not already be on your system's ``PATH``. +If it is, the executable can be run by typing its filename on commandline. +For installing libraries see the :ref:`adding-libraries` section. + +Next steps +---------- + +What we have covered so far should be enough for very simple packages +that you use on your own system. + +The next few sections cover more details needed for more complex +packages and details needed for distributing packages to other people. + +The previous chapter covers building and installing packages -- your own +packages or ones developed by other people. + + +Package concepts +================ + +Before diving into the details of writing packages it helps to +understand a bit about packages in the Haskell world and the particular +approach that Cabal takes. + +The point of packages +--------------------- + +Packages are a mechanism for organising and distributing code. Packages +are particularly suited for "programming in the large", that is building +big systems by using and re-using code written by different people at +different times. + +People organise code into packages based on functionality and +dependencies. Social factors are also important: most packages have a +single author, or a relatively small team of authors. + +Packages are also used for distribution: the idea is that a package can +be created in one place and be moved to a different computer and be +usable in that different environment. There are a surprising number of +details that have to be got right for this to work, and a good package +system helps to simplify this process and make it reliable. + +Packages come in two main flavours: libraries of reusable code, and +complete programs. Libraries present a code interface, an API, while +programs can be run directly. In the Haskell world, library packages +expose a set of Haskell modules as their public interface. Cabal +packages can contain a library or executables or both. + +Some programming languages have packages as a builtin language concept. +For example in Java, a package provides a local namespace for types and +other definitions. In the Haskell world, packages are not a part of the +language itself. Haskell programs consist of a number of modules, and +packages just provide a way to partition the modules into sets of +related functionality. Thus the choice of module names in Haskell is +still important, even when using packages. + +Package names and versions +-------------------------- + +All packages have a name, e.g. "HUnit". Package names are assumed to be +unique. Cabal package names may contain letters, numbers and hyphens, +but not spaces and may also not contain a hyphened section consisting of +only numbers. The namespace for Cabal packages is flat, not +hierarchical. + +Packages also have a version, e.g "1.1". This matches the typical way in +which packages are developed. Strictly speaking, each version of a +package is independent, but usually they are very similar. Cabal package +versions follow the conventional numeric style, consisting of a sequence +of digits such as "1.0.1" or "2.0". There are a range of common +conventions for "versioning" packages, that is giving some meaning to +the version number in terms of changes in the package, such as +e.g. `SemVer `__; however, for packages intended to be +distributed via Hackage Haskell's `Package Versioning Policy `_ applies +(see also the `PVP/SemVer FAQ section `__). + +The combination of package name and version is called the *package ID* +and is written with a hyphen to separate the name and version, e.g. +"HUnit-1.1". + +For Cabal packages, the combination of the package name and version +*uniquely* identifies each package. Or to put it another way: two +packages with the same name and version are considered to *be* the same. + +Strictly speaking, the package ID only identifies each Cabal *source* +package; the same Cabal source package can be configured and built in +different ways. There is a separate installed package ID that uniquely +identifies each installed package instance. Most of the time however, +users need not be aware of this detail. + +Kinds of package: Cabal vs GHC vs system +---------------------------------------- + +It can be slightly confusing at first because there are various +different notions of package floating around. Fortunately the details +are not very complicated. + +Cabal packages + Cabal packages are really source packages. That is they contain + Haskell (and sometimes C) source code. + + Cabal packages can be compiled to produce GHC packages. They can + also be translated into operating system packages. + +GHC packages + This is GHC's view on packages. GHC only cares about library + packages, not executables. Library packages have to be registered + with GHC for them to be available in GHCi or to be used when + compiling other programs or packages. + + The low-level tool ``ghc-pkg`` is used to register GHC packages and + to get information on what packages are currently registered. + + You never need to make GHC packages manually. When you build and + install a Cabal package containing a library then it gets registered + with GHC automatically. + + Haskell implementations other than GHC have essentially the same + concept of registered packages. For the most part, Cabal hides the + slight differences. + +Operating system packages + On operating systems like Linux and Mac OS X, the system has a + specific notion of a package and there are tools for installing and + managing packages. + + The Cabal package format is designed to allow Cabal packages to be + translated, mostly-automatically, into operating system packages. + They are usually translated 1:1, that is a single Cabal package + becomes a single system package. + + It is also possible to make Windows installers from Cabal packages, + though this is typically done for a program together with all of its + library dependencies, rather than packaging each library separately. + +Unit of distribution +-------------------- + +The Cabal package is the unit of distribution. This means that +each Cabal package can be distributed on its own, in source or binary +form. There may be dependencies between packages, but there is +usually a degree of flexibility in which versions of packages can work +together so distributing them independently makes sense. + +It is perhaps easiest to see what being "the unit of distribution" +means by contrast to an alternative approach. Many projects are made up +of several interdependent packages and during development these might +all be kept under one common directory tree and be built and tested +together. When it comes to distribution however, rather than +distributing them all together in a single tarball, it is required that +they each be distributed independently in their own tarballs. + +Cabal's approach is to say that if you can specify a dependency on a +package then that package should be able to be distributed +independently. Or to put it the other way round, if you want to +distribute it as a single unit, then it should be a single package. + +Explicit dependencies and automatic package management +------------------------------------------------------ + +Cabal takes the approach that all packages dependencies are specified +explicitly and specified in a declarative way. The point is to enable +automatic package management. This means tools like ``cabal`` can +resolve dependencies and install a package plus all of its dependencies +automatically. Alternatively, it is possible to mechanically (or mostly +mechanically) translate Cabal packages into system packages and let the +system package manager install dependencies automatically. + +It is important to track dependencies accurately so that packages can +reliably be moved from one system to another system and still be able to +build it there. Cabal is therefore relatively strict about specifying +dependencies. For example Cabal's default build system will not even let +code build if it tries to import a module from a package that isn't +listed in the ``.cabal`` file, even if that package is actually +installed. This helps to ensure that there are no "untracked +dependencies" that could cause the code to fail to build on some other +system. + +The explicit dependency approach is in contrast to the traditional +"./configure" approach where instead of specifying dependencies +declaratively, the ``./configure`` script checks if the dependencies are +present on the system. Some manual work is required to transform a +``./configure`` based package into a Linux distribution package (or +similar). This conversion work is usually done by people other than the +package author(s). The practical effect of this is that only the most +popular packages will benefit from automatic package management. +Instead, Cabal forces the original author to specify the dependencies +but the advantage is that every package can benefit from automatic +package management. + +The "./configure" approach tends to encourage packages that adapt +themselves to the environment in which they are built, for example by +disabling optional features so that they can continue to work when a +particular dependency is not available. This approach makes sense in a +world where installing additional dependencies is a tiresome manual +process and so minimising dependencies is important. The automatic +package management view is that packages should just declare what they +need and the package manager will take responsibility for ensuring that +all the dependencies are installed. + +Sometimes of course optional features and optional dependencies do make +sense. Cabal packages can have optional features and varying +dependencies. These conditional dependencies are still specified in a +declarative way however and remain compatible with automatic package +management. The need to remain compatible with automatic package +management means that Cabal's conditional dependencies system is a bit +less flexible than with the "./configure" approach. + +.. note:: + `GNU autoconf places restrictions on paths, including the + path that the user builds a package from. + `_ + Package authors using ``build-type: configure`` should be aware of + these restrictions; because users may be unexpectedly constrained and + face mysterious errors, it is recommended that ``build-type: configure`` + is only used where strictly necessary. + +Portability +----------- + +One of the purposes of Cabal is to make it easier to build packages on +different platforms (operating systems and CPU architectures), with +different compiler versions and indeed even with different Haskell +implementations. (Yes, there are Haskell implementations other than +GHC!) + +Cabal provides abstractions of features present in different Haskell +implementations and wherever possible it is best to take advantage of +these to increase portability. Where necessary however it is possible to +use specific features of specific implementations. + +For example a package author can list in the package's ``.cabal`` what +language extensions the code uses. This allows Cabal to figure out if +the language extension is supported by the Haskell implementation that +the user picks. Additionally, certain language extensions such as +Template Haskell require special handling from the build system and by +listing the extension it provides the build system with enough +information to do the right thing. + +Another similar example is linking with foreign libraries. Rather than +specifying GHC flags directly, the package author can list the libraries +that are needed and the build system will take care of using the right +flags for the compiler. Additionally this makes it easier for tools to +discover what system C libraries a package needs, which is useful for +tracking dependencies on system libraries (e.g. when translating into +Linux distribution packages). + +In fact both of these examples fall into the category of explicitly +specifying dependencies. Not all dependencies are other Cabal packages. +Foreign libraries are clearly another kind of dependency. It's also +possible to think of language extensions as dependencies: the package +depends on a Haskell implementation that supports all those extensions. + +Where compiler-specific options are needed however, there is an "escape +hatch" available. The developer can specify implementation-specific +options and more generally there is a configuration mechanism to +customise many aspects of how a package is built depending on the +Haskell implementation, the operating system, computer architecture and +user-specified configuration flags. diff --git a/cabal/doc/file-format-changelog.rst b/cabal/doc/file-format-changelog.rst new file mode 100644 --- /dev/null +++ b/cabal/doc/file-format-changelog.rst @@ -0,0 +1,285 @@ +.. _spec-history: + +================================================== + Package Description Format Specification History +================================================== + +:ref:`pkg-desc` need to specify the version of the +specification they need to be interpreted in via the +:pkg-field:`cabal-version` declaration. The following list describes +changes that occurred in each version of the cabal specification +relative to the respective preceding *published* version. + +.. note:: + + The sequence of specification version numbers is *not* + contiguous because it's synchronised with the version of the + ``Cabal`` library. As a consequence, only *even* versions are + considered proper published versions of the specification as *odd* + versions of the ``Cabal`` library denote unreleased development + branches which have no stability guarantee. + +``cabal-version: 3.8`` +---------------------- + +* Added field ``code-generators`` to :pkg-section:`test-suite` stanzas. This + enumerates executabes (possibly brought into scope by :pkg-field:`build-tool-depends`) that are run after all other + preprocessors. These executables are invoked with a target dir for + output, a sequence of all source directories with source files of + local lib components that the given test stanza depends on, and + following a double dash, all options cabal would pass to ghc for a + build. They are expected to output a newline-separated list of + generated modules which have been written to the targetdir. This can + be used for driving doctests and other discover-style tests generated + from source code. + +* Added fields :pkg-field:`extra-libraries-static` and + :pkg-field:`extra-lib-dirs-static` to allow Haskell libraries to remember + linker flags needed for fully static linking of system libraries into + executables. + The existing field :pkg-field:`pkgconfig-depends` can used to append + the relevant output of ``pkg-config --libs --static`` to these new fields + automatically. + When :pkg-field:`extra-libraries-static` is not given, it defaults to + :pkg-field:`extra-libraries`. + When :pkg-field:`extra-lib-dirs-static` is not given, it defaults to + :pkg-field:`extra-lib-dirs`. + +* Wildcard matching has been slightly expanded. Matches are now + allowed of the form ``foo/**/literalFile``. Prior, double-star + wildcards required the trailing filename itself be a wildcard. + +* Allow the omission of the `type` field in `test-suite` and `benchmark` stanzas + when the type can be inferred by the presence of `main-is` or `test-module`. + +* License fields use identifiers from SPDX License List version + ``3.16 2022-02-06`` + +``cabal-version: 3.6`` +---------------------- + +* License fields use identifiers from SPDX License List version + ``3.10 2020-08-03`` + +* Add :pkg-field:`hsc2hs-options` + +``cabal-version: 3.4`` +---------------------- + + +* License fields use identifiers from SPDX License List version + ``3.9 2020-05-15`` + +* Dependencies to sublibraries have to be specified explicitly, + even for current package. + This way you can have an internal library with the same + name as some external dependency. + +* Remove ``-any`` and ``-none`` syntax for version ranges + Use ``>=0`` and ``<0`` respectively. + +* :pkg-field:`default-language` is optional. + The Default value is to use the compiler's default language. + +* :pkg-field:`mixins` field allow specifying a sublibrary. + +``cabal-version: 3.0`` +---------------------- + +* New :pkg-field:`library:visibility` for exposing sublibraries. + +* New ``pkg:lib`` and ``pkg:{lib1,lib2}`` syntax in :pkg-field:`build-depends` + for depending on public sublibraries from other packages. + +* Added the :pkg-field:`extra-dynamic-library-flavours` field to specify non-trivial + variants of dynamic flavours. It is :pkg-field:`extra-library-flavours` but for + shared libraries. Mainly useful for GHC's RTS library. + +* Free text fields (e.g. :pkg-field:`description`) preserve empty lines + and indentation. In other words, you don't need to add dots for blank lines. + +* License fields use identifiers from SPDX License List version + ``3.6 2019-07-10`` + +* Remove deprecated ``hs-source-dir``, :pkg-field:`extensions` and + :pkg-field:`build-tools` fields. + +* Common stanzas are now allowed also in the beginning of conditional + sections. In other words, the following is valid + + :: + + library + import deps + + if flag(foo) + import foo-deps + +* Allow redundant leading or trailing commas in package fields with + optional commas, such as :pkg-field:`library:exposed-modules` + +* Require fields with optional commas to consistently omit or place + commas between elements. + +* Changed the behavior of :pkg-field:`extra-bundled-libraries` field. The naming convention + of dynamic library files (e.g. generated by a custom build script) has + changed. For library names prefixed with "C", the dynamic library file + name(s) must be of the form `lib.*` + instead of the old `libC-ghc.` + +* New set-notation syntax for ``==`` and ``^>=`` operators, see + :pkg-field:`build-depends` field documentation for examples. + +* Allow more whitespace in :pkg-field:`mixins` field + +* Wildcards are disallowed in :pkg-field:`pkgconfig-depends`, + Yet the pkgconfig format is relaxed to accept e.g. versions like ``1.1.0h``. + +* New :pkg-field:`autogen-includes` for specifying :pkg-field:`install-includes` + which are autogenerated (e.g. by a ``configure`` script). + +* New :pkg-field:`asm-sources` and :pkg-field:`asm-options` fields + added for supporting bundled foreign routines implemented in + assembler. + +* New :pkg-field:`cmm-sources` and :pkg-field:`cmm-options` fields + added for supporting bundled foreign primops implemented in + C--. + +``cabal-version: 2.4`` +---------------------- + +* Wildcard matching has been expanded. All previous wildcard + expressions are still valid; some will match strictly more files + than before. Specifically: + + * Double-star (``**``) wildcards are now accepted for recursive + matching immediately before the final slash; they must be followed + by a filename wildcard (e.g., ``foo/**/*.html`` is valid; + ``foo/**/bar/*.html`` and ``foo/**/**/*.html``, + ``foo/**/bar.html`` are all invalid). As ``**`` was an error in + globs before, this does not affect any existing ``.cabal`` files + that previously worked. + + * Wildcards now match when the pattern's extensions form a suffix of + the candidate file's extension, rather than requiring strict + equality (e.g., previously ``*.html`` did not match + ``foo.en.html``, but now it does). + +* License fields use identifiers from SPDX License List version + ``3.2 2018-07-10`` + + +``cabal-version: 2.2`` +---------------------- + +* New :pkg-section:`common` stanzas and :pkg-field:`import` + pseudo-field added. + +* New :pkg-field:`library:virtual-modules` field added. + +* New :pkg-field:`cxx-sources` and :pkg-field:`cxx-options` fields + added for supporting bundled foreign routines implemented in C++. + +* New :pkg-field:`extra-bundled-libraries` field for specifying + additional custom library objects to be installed. + +* Extended ``if`` control structure with support for ``elif`` keyword. + +* Changed default rules of :pkg-field:`build-type` field to infer + "build-type:" for "Simple"/"Custom" automatically. + +* :pkg-field:`license` field syntax changed to require SPDX + expression syntax (using SPDX license list version ``3.0 2017-12-28``). + +* Allow redundant leading or trailing commas in package fields (which + require commas) such as :pkg-field:`build-depends`. + + +``cabal-version: 2.0`` +---------------------- + +* New :pkg-field:`library:signatures` and :pkg-field:`mixins` fields + added for supporting :ref:`Backpack`. + +* New :pkg-field:`build-tool-depends` field added for adding + build-time dependencies of executable components. + +* New :pkg-field:`custom-setup:autogen-modules` field added for declaring modules + which are generated at build time. + +* Support for new PVP_ caret-style version operator (``^>=``) added to + :pkg-field:`build-depends`. + +* Add support for new :pkg-section:`foreign-library` stanza. + +* Add support for :ref:`internal library stanzas `. + +* New CPP Macro ``CURRENT_PACKAGE_VERSION``. + +``cabal-version: 1.24`` +----------------------- + +* New :pkg-section:`custom-setup` stanza and + :pkg-field:`custom-setup:setup-depends` field added for specifying dependencies + of custom ``Setup.hs`` scripts. + +* CPP Macros ``VERSION_$pkgname`` and ``MIN_VERSION_$pkgname`` are now + also generated for the current package. + +* New CPP Macros ``CURRENT_COMPONENT_ID`` and ``CURRENT_PACKAGE_KEY``. + +* New :pkg-field:`extra-framework-dirs` field added for specifying + extra locations to find OS X frameworks. + +``cabal-version: 1.22`` +----------------------- + +* New :pkg-field:`library:reexported-modules` field. + +* Support for ``-none`` version constraint added to + :pkg-field:`build-depends`. + +* New :pkg-field:`license` type ``ISC`` added. + +``cabal-version: 1.20`` +----------------------- + +* Add support for new :pkg-field:`license-files` field for declaring + multiple license documents. + +* New CPP Macro ``MIN_TOOL_VERSION_$buildtool``. + +* New :pkg-field:`license` types ``BSD2`` and ``MPL-2.0`` added. + +``cabal-version: 1.18`` +----------------------- + +* Add support for new :pkg-field:`extra-doc-files` field for + specifying extra file assets referenced by the Haddock + documentation. + +* New :pkg-field:`license` type ``AGPL`` and ``AGPL-3`` added. + +* Add support for specifying a C/C++/obj-C source file in + :pkg-field:`executable:main-is` field. + +* Add ``getSysconfDir`` operation to ``Paths_`` API. + +``cabal-version: 1.16`` +----------------------- + +.. todo:: + + this needs to be researched; there were only few changes between + 1.12 and 1.18; + +``cabal-version: 1.12`` +----------------------- + +* Change syntax of :pkg-field:`cabal-version` to support the new recommended + ``cabal-version: x.y`` style + + + +.. include:: references.inc diff --git a/cabal/doc/getting-started.rst b/cabal/doc/getting-started.rst new file mode 100644 --- /dev/null +++ b/cabal/doc/getting-started.rst @@ -0,0 +1,176 @@ +Getting Started with Haskell and Cabal +====================================== + +Installing the Haskell toolchain +-------------------------------- + +To install the Haskell toolchain follow the `ghcup instructions +`__. + + +Creating a new application +-------------------------- + +Let's start by creating a simple Haskell application from scratch where we'll +learn about a Haskell package's directory structure, how to run the executable, +and how to add external dependencies. + + +Initializing the application +^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +Start by initialising our ``myfirstapp`` project, these instructions work in +unix shells and PowerShell (if you're on Windows). + +.. code-block:: console + + $ cabal init myfirstapp -n + +.. note:: ``myfirstapp`` stands for the directory (or path) where the project + will reside in, if omitted, ``cabal init`` will do its proceedings + in the directory it's called in. + +.. note:: ``-n`` stands for ``--non-interactive``, which means that cabal will try to guess + how to set up the project for you and use the default settings, which will serve us + well for the purpose of this tutorial. + When setting up your projects in the future, you will likely want to omit ``-n`` + and do just ``cabal init``, so that cabal will interactively ask you + for the details on how the project should be set up + (while still offering reasonable defaults on every step). + Also, you can run ``cabal init --help`` to get more info on how ``cabal init`` can be used. + +This will generate the following files: + +.. code-block:: console + + $ tree + . + └── myfirstapp + ├── app + │   └── Main.hs + ├── CHANGELOG.md + └── myfirstapp.cabal + +``app/Main.hs`` is where your package's code lives. + +``myfirstapp.cabal`` is Cabal's metadata file which describes your package, +how it is built and its dependencies. We'll be updating this file in a +little bit when we add an external dependency to our package. + + +Running the application +^^^^^^^^^^^^^^^^^^^^^^^ + +When we ran ``cabal init myfirstapp -n`` above, it generated a package with a single +executable named same as the package (in this case ``myfirstapp``) that prints +``"Hello, Haskell!"`` to the terminal. To run the executable enter the project's +directory and run it, by inputting the following commands: + +.. code-block:: console + + cd myfirstapp + cabal run myfirstapp + +You should see the following output in the terminal: + +.. code-block:: console + + $ cabal run myfirstapp + ... + Hello, Haskell! + +Notice that we didn't need to run a `build` command before we ran ``cabal run``. +This is because ``cabal run`` automatically determines if the code needs to be (re)built +before running the executable. +If you just want to build a target without running it, you can do so with ``cabal build``: + +``cabal build myfirstapp`` + + +Adding dependencies +^^^^^^^^^^^^^^^^^^^ + +Next we'll add an external dependency to our application. `Hackage +`__ is the Haskell community's central `package` +archive of open source software. + +In our application, we'll use a package called `haskell-say +`__ to print text to the +terminal with some embellishment. + +.. TIP:: + If you installed ``cabal`` a while ago but haven't used it recently you may + need to update the package index, you can do this by running ``cabal + update``. + +In our ``myfirstapp.cabal`` file we'll update the ``build-depends`` attribute of +the ``executable myfirstapp`` section to include ``haskell-say``: + +.. code-block:: cabal + + executable myfirstapp + import: warnings + main-is: Main.hs + build-depends: + base ^>=4.14.3.0, + haskell-say ^>=1.0.0.0 + hs-source-dirs: app + default-language: Haskell2010 + + +.. NOTE:: + ``^>=1.0.0.0`` means use version 1.0.0.0 of the library or any more recent + minor release with the same major version. To put it simply, this means + use the latest version of the library that starts with ``1.0``. + +Next we'll update ``app/Main.hs`` to use the ``HaskellSay`` library: + +.. code-block:: haskell + + module Main where + + import HaskellSay (haskellSay) + + main :: IO () + main = + haskellSay "Hello, Haskell! You're using a function from another package!" + +``import HaskellSay (haskellSay)`` brings the ``haskellSay`` function from the +module named ``HaskellSay`` into scope. The ``HaskellSay`` module is defined in +the ``haskell-say`` package that we added as a dependency above. + +Now you can build and re-run your code to see the new output: + +.. code-block:: console + + $ cabal run + ________________________________________________________ + / \ + | Hello, Haskell! You're using a function from another | + | package! | + \____ _____________________________________________/ + \ / + \ / + \/ + _____ _____ + \ \ \ \ + \ \ \ \ + \ \ \ \ + \ \ \ \ \-----------| + \ \ \ \ \ | + \ \ \ \ \---------| + / / / \ + / / / \ \-------| + / / / ^ \ \ | + / / / / \ \ \ ----| + / / / / \ \ + /____/ /____/ \____\ + + +What Next? +---------- + +Now that you know how to set up a simple Haskell package using Cabal, check out +some of the resources on the Haskell website's `documentation page +`__ or read more about packages and +Cabal on the :doc:`introduction ` page. diff --git a/cabal/doc/hcar/.gitignore b/cabal/doc/hcar/.gitignore new file mode 100644 --- /dev/null +++ b/cabal/doc/hcar/.gitignore @@ -0,0 +1,5 @@ +*.out +*.aux +*.log +*.pdf +/auto diff --git a/cabal/doc/hcar/Cabal-201604.tex b/cabal/doc/hcar/Cabal-201604.tex new file mode 100644 --- /dev/null +++ b/cabal/doc/hcar/Cabal-201604.tex @@ -0,0 +1,118 @@ +\documentclass[DIV16,twocolumn,10pt]{scrreprt} +\usepackage{paralist} +\usepackage{graphicx} +\usepackage[final]{hcar} + +%include polycode.fmt + +\begin{document} + +\begin{hcarentry}{Cabal} +\report{Mikhail Glushenkov} +\status{Active} +\participants{\href{https://github.com/haskell/cabal/graphs/contributors}{Cabal contributors}}% optional +\makeheader + +\subsubsection*{Background} + +Cabal is the standard packaging system for Haskell software. It specifies a +standard way in which Haskell libraries and applications can be packaged so that +it is easy for consumers to use them, or re-package them, regardless of the +Haskell implementation or installation platform. + +\texttt{cabal-install} is the command line interface for the Cabal and Hackage +system. It provides a command line program \texttt{cabal} which has sub-commands +for installing and managing Haskell packages. + +\subsubsection*{Recent Progress} + +We've just released versions 1.24 of Cabal and \texttt{cabal-install}. 1.24 +incorporates more than a thousand commits by +\href{https://gist.github.com/23Skidoo/62544d7e0352037749eec7344788831c}{89 + different contributors}. Main user-visible changes in this release are: + +\begin{itemize} +\item Nix-style local builds in \texttt{cabal-install} (so far only a technical + preview). See + \href{http://blog.ezyang.com/2016/05/announcing-cabal-new-build-nix-style-local-builds/}{this + post} by Edward Z. Yang for more details. +\item Integration of a new security scheme for Hackage based on + \href{https://theupdateframework.github.io/}{The Update Framework}. So far + this is not enabled by default, pending some changes on the Hackage side. See + \href{http://www.well-typed.com/blog/2015/08/hackage-security-beta/}{these} + \href{http://www.well-typed.com/blog/2015/07/hackage-security-alpha/}{three} + \href{http://www.well-typed.com/blog/2015/04/improving-hackage-security/}{posts} + by Edsko de Vries and Duncan Coutts for more information. +\item Support for specifying setup script dependencies in \texttt{.cabal} + files. See + \href{http://www.well-typed.com/blog/2015/07/cabal-setup-deps/}{this post by + Duncan Coutts} for more information. +\item Support for HTTPS downloads in \texttt{cabal-install}. HTTPS is now used + by default for downloads from Hackage. +\item \texttt{cabal upload} learned how to upload documentation to Hackage + (\texttt{cabal upload --doc}). +\item In related news, \texttt{cabal haddock} now can generate documentation + intended for uploading to Hackage (\texttt{cabal haddock + --for-hackage}). \texttt{cabal upload --doc} runs this command automatically + if the documentation for current package wasn't generated yet. +\item New \texttt{cabal-install} command: \texttt{gen-bounds}. See + \href{http://softwaresimply.blogspot.se/2015/08/cabal-gen-bounds-easy-generation-of.html}{here} + for more information. +\item It's now possible to limit the scope of \texttt{--allow-newer} to single + packages in the install plan, both on the command line and in the config + file. See \href{https://github.com/haskell/cabal/issues/2756}{here} for an + example. +\item New \texttt{cabal user-config} subcommand: \texttt{init}, which creates a + default \texttt{\textasciitilde{}/.cabal/config} file. +\item New config file field: \texttt{extra-framework-dirs} (extra locations to + find OS X frameworks in). +\item \texttt{cabal-install} solver + \href{https://github.com/haskell/cabal/pull/2873}{now takes information about + extensions and language flavours into account}. +\item New \texttt{cabal-install} option: + \href{https://github.com/haskell/cabal/pull/2578}{\texttt{--offline}}, which + prevents \texttt{cabal-install} from downloading anything from the Internet. +\item New \texttt{cabal upload} option + \href{https://github.com/haskell/cabal/pull/2506}{\texttt{-P}/\texttt{--password-command}} + for reading Hackage password from arbitrary program output. +\item Support for GHC 8 (NB: old versions of Cabal won't work with this version + of GHC). +\end{itemize} + +Full list of changes in Cabal 1.24 is available +\href{http://hackage.haskell.org/package/Cabal-1.24.0.0/changelog}{here}; full +list of changes in \texttt{cabal-install} 1.24 is available +\href{http://hackage.haskell.org/package/cabal-install-1.24.0.0/changelog}{here}. + +\subsubsection*{Looking Forward} + +We plan to make a new release of Cabal/\texttt{cabal-install} approximately 6 +months after 1.24 -- that is, in late October or early November 2016. Main +features that are currently targeted at 1.26 are: + +\begin{itemize} +\item Further work on nix-style local builds, perhaps making that code path the + default. +\item Enabling Hackage Security by default. +\item Native support for + \href{https://github.com/haskell/cabal/pull/2540}{``foreign libraries''}: + Haskell libraries that are intended to be used by non-Haskell code. +\item New Parsec-based parser for \texttt{.cabal} files. +\end{itemize} + +We would like to encourage people considering contributing to take a look at +\href{https://github.com/haskell/cabal/issues/}{the bug tracker on GitHub}, take +part in discussions on tickets and pull requests, or submit their own. The bug +tracker is reasonably well maintained and it should be relatively clear to new +contributors what is in need of attention and which tasks are considered +relatively easy. For more in-depth discussion there is also the +\href{https://mail.haskell.org/mailman/listinfo/cabal-devel}{\texttt{cabal-devel}} +mailing list. + +\FurtherReading + Cabal homepage:\hfill\url{https://www.haskell.org/cabal/}\\ + Cabal on GitHub:\hfill\url{https://github.com/haskell/cabal} + +\end{hcarentry} + +\end{document} diff --git a/cabal/doc/hcar/Cabal-201611.tex b/cabal/doc/hcar/Cabal-201611.tex new file mode 100644 --- /dev/null +++ b/cabal/doc/hcar/Cabal-201611.tex @@ -0,0 +1,140 @@ +% Cabal-MC.tex +\begin{hcarentry}{Cabal} +\label{cabal}%\label{hackage}\label{hackagedb}% +\report{Mikhail Glushenkov}%11/16 +\status{Stable, actively developed} +\makeheader + +\subsubsection*{Background} + +Cabal is the standard packaging system for Haskell software. It specifies a +standard way in which Haskell libraries and applications can be packaged so +that it is easy for consumers to use them, or re-package them, regardless of +the Haskell implementation or installation platform. + +\texttt{cabal-install} is the command line interface for the Cabal and Hackage +system. It provides a command line program \texttt{cabal} which has +sub-commands for installing and managing Haskell packages. + +\subsubsection*{Recent Progress} + +We've recently produced +\href{https://mail.haskell.org/pipermail/cabal-devel/2016-December/010384.html}{new + point releases} of Cabal/\texttt{cabal-install} from the 1.24 +branch. Among other things, Cabal 1.24.2.0 includes a +\href{https://gitlab.haskell.org/ghc/ghc/-/issues/12479}{fix} necessary to +make soon-to-be-released GHC 8.0.2 work on macOS Sierra. + +Almost 1500 commits were made to the \texttt{master} branch by +\href{https://gist.github.com/23Skidoo/1a291fd56a18b51f415db5fbaff56ec6}{53 +different contributors} since the 1.24 release. Among the highlights are: + +\begin{compactitem} +\item + \href{http://cabal.readthedocs.io/en/latest/developing-packages.html#library}{Convenience, + or internal libraries} -- named libraries that are only intended + for use inside the package. A common use case is sharing code + between the test suite and the benchmark suite without exposing it + to the users of the package. + +\item Support for + \href{http://cabal.readthedocs.io/en/latest/developing-packages.html#foreign-libraries}{foreign + libraries}, which are Haskell libraries intended to be used by + foreign languages like C. Foreign libraries only work with GHC 7.8 + and later. + +\item Initial support for building Backpack packages. Backpack is an + exciting new project adding an ML-style module system to Haskell, + but on the package level. See + \href{https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst}{here} + and \href{http://blog.ezyang.com/category/haskell/backpack/}{here} + for a more thorough introduction to Backpack. + +\item \texttt{./Setup configure} now accepts an argument + \href{https://github.com/ghc-proposals/ghc-proposals/pull/4}{specifying + the component to be configured}. This is mainly an internal + change, but it means that \texttt{cabal-install} can now perform + component-level parallel builds (among other things). + +\item A lot of improvements in the \texttt{new-build} feature + (a.k.a. nix-style local builds). Git \texttt{HEAD} version of + \texttt{cabal-install} is now recommended if you use + \texttt{new-build}. For an introduction to \texttt{new-build}, see + \href{http://cabal.readthedocs.io/en/latest/nix-local-build-overview.html}{this + chapter} of the manual. + +\item Special support for the Nix package manager in + \texttt{cabal-install}. See + \href{http://cabal.readthedocs.io/en/latest/nix-integration.html}{here} + for more details. + +\item \texttt{cabal upload} now uploads a package candidate by + default. Use \texttt{cabal upload -{}-publish} to upload a final + version. \texttt{cabal upload -{}-check} has been removed in favour + of package candidates. + +\item + \href{http://cabal.readthedocs.io/en/latest/nix-local-build.html#cfg-field-index-state}{An + \texttt{-{}-index-state} flag} for requesting a specific version + of the package index. + +\item \href{https://github.com/haskell/cabal/pull/3818}{New \texttt{cabal reconfigure} command}, which re-runs + \texttt{configure} with most recently used flags. + +\item + \href{http://cabal.readthedocs.io/en/latest/developing-packages.html#autogenerated-modules}{New + \texttt{autogen-modules} field} for modules built automatically + (like \texttt{Paths\_PACKAGENAME}). + +\item + \href{http://cabal.readthedocs.io/en/latest/developing-packages.html#pkg-field-build-depends}{New + version range operator} \texttt{\^{}>=}, which is equivalent to + \texttt{>=} intersected with an automatically-inferred major version + bound. For example, \texttt{\^{}>= 2.0.3} is equivalent to \texttt{>= + 2.0.3 \&\& < 2.1}. + +\item + \href{http://cabal.readthedocs.io/en/latest/installing-packages.html#cmdoption-setup-configure--allow-newer}{An + \texttt{-{}-allow-older} flag}, dual to \texttt{-{}-allow-newer}. + +\item New Parsec-based parser for \texttt{.cabal} files + \href{https://github.com/haskell/cabal/pull/3602}{has been merged}, + but not enabled by default yet. + +\item \href{http://cabal.readthedocs.io/en/latest/}{The manual} has + been converted to reST/Sphinx format, improved and expanded. + +\item + \href{https://www.well-typed.com/blog/2015/08/hackage-security-beta/}{Hackage + Security} has been enabled by default. + +\item A lot of bug fixes and performance improvements. + +\end{compactitem} + +\subsubsection*{Looking Forward} + +The next Cabal/\texttt{cabal-install} versions will be released either +in early 2017, or simultaneously with GHC 8.2 (April/May 2017). Our +main focus at this stage is getting the \texttt{new-build} feature to +the state where it can be enabled by default, but there are many other +areas of Cabal that need work. + +We would like to encourage people considering contributing to take a +look at \href{https://github.com/haskell/cabal/issues/}{the bug + tracker on GitHub} and the +\href{https://github.com/haskell/cabal/wiki/Hackathon-2016}{Wiki}, +take part in discussions on tickets and pull requests, or submit their +own. The bug tracker is reasonably well maintained and it should be +relatively clear to new contributors what is in need of attention and +which tasks are considered relatively easy. For more in-depth +discussion there is also the +\href{https://mail.haskell.org/mailman/listinfo/cabal-devel}{\texttt{cabal-devel}} +mailing list. + +\FurtherReading +\begin{compactitem} +\item Cabal homepage:\hfill\url{https://www.haskell.org/cabal/}\\ +\item Cabal on GitHub:\hfill\url{https://github.com/haskell/cabal} +\end{compactitem} +\end{hcarentry} diff --git a/cabal/doc/hcar/Cabal-201811.tex b/cabal/doc/hcar/Cabal-201811.tex new file mode 100644 --- /dev/null +++ b/cabal/doc/hcar/Cabal-201811.tex @@ -0,0 +1,121 @@ +% Cabal-MC.tex +\begin{hcarentry}{Cabal} +\label{cabal} +\label{hackage} +\label{hackagedb} +\report{Mikhail Glushenkov}%11/18 +\status{Stable, actively developed} +\makeheader + +\subsubsection*{Background} + +Cabal is the standard packaging system for Haskell software. It +specifies how Haskell libraries and applications can be packaged so +that it is easy for consumers to use them, or re-package them, +regardless of the Haskell implementation or installation platform. + +\texttt{cabal-install} is the command line interface for the Cabal and +Hackage system. It provides a program \texttt{cabal} which has +sub-commands for installing, managing, and developing Haskell packages. + +\subsubsection*{Recent Progress} + +We've recently produced the first releases of +Cabal/\texttt{cabal-install} from the 2.4 series. Bugfix releases from +the same branch are in the works at the time of writing and should be out soon. + +Almost 600 commits were made to the \texttt{master} branch by +\href{https://gist.github.com/23Skidoo/7f07c309776574039b9cc7e29cfaf069}{48 + different contributors} since the 2.2 release. Among the highlights +are: + +\begin{compactitem} + +\item Massive improvements to the + \href{https://cabal.readthedocs.io/en/latest/nix-local-build-overview.html#nix-style-local-builds}{\texttt{new-build} + feature} + \href{https://typedr.at/posts/what-i-did-on-my-summer-vacation/}{made + by Alexis Williams during GSoC 2018}, as well as many other + contributors. Among other things, \texttt{new-install}, + \texttt{new-sdist}, \texttt{new-clean}, and \texttt{new-update} + commands are now fully implemented, \texttt{new-repl} works outside + of projects, and \texttt{new-run} can now be used to run scripts + (either with \texttt{cabal new-run foo.hs} or in a shebang + interpreter mode). + +\item It's now possible + \href{https://cabal.readthedocs.io/en/latest/nix-local-build.html#specifying-packages-from-remote-version-control-locations}{to + specify packages from remote version control locations + (e.g. GitHub) in \texttt{cabal.project}} (as well as local/remote + tarballs). Work done by Duncan Coutts with the help of Alexis + Williams, \textbf{@quasicomputational}, and others. + +\item Improvements to the wildcard syntax: a + \href{https://cabal.readthedocs.io/en/latest/developing-packages.html#pkg-field-data-files}{limited + form of recursive matching} (\texttt{data-files:~audio/**/*.mp3}) + is now allowed. Work done by \textbf{@quasicomputational}. + +\item Lots of bug fixes and performance improvements. + +\end{compactitem} + +\subsubsection*{Looking Forward} + +We plan to make the next major Cabal/\texttt{cabal-install} release +(3.0) around the same time GHC 8.8 is going to be released (February +2019). Main features currently targeted at this milestone are: + +\begin{compactitem} + +\item \texttt{new-build} will become the default mode of + operation. Old-style commands will still be accessible under the + \texttt{v1-} prefix. + +\item Multiple public libraries feature implemented by Francesco + Gazzetta during GSoC 2018. This will allow to define more than one + public library in a single \texttt{.cabal} package, which is useful + for large projects such as \texttt{lens}, as well as Backpack-heavy + libraries. This + \href{https://github.com/haskell/cabal/pull/5526}{has already been + merged to \texttt{master}}; Francesco continues to polish and + improve the implementation in preparation for its initial release. + +\item A split of the Cabal library into a pure \texttt{cabal-lib-core} + part (parser and foundational data types) and an effectful + \texttt{cabal-lib-build} part (build system bits); likewise, the + constraint solver part of \texttt{cabal-install} will be + moved into its own library \texttt{cabal-lib-solver}, and the + \texttt{cabal-install} package renamed to \texttt{cabal}. + +\item A revamped homepage, rewritten user manual, and automated build + bots for producing binaries. Help in this area would be appreciated! + +\end{compactitem} + +We would like to encourage people considering contributing to take a +look at \href{https://github.com/haskell/cabal/issues/}{the bug + tracker on GitHub}, take part in discussions on tickets and pull +requests, or submit their own. The bug tracker is reasonably well +maintained and it should be fairly clear to new contributors what +is in need of attention and which tasks are considered relatively +easy. Additionally, +\href{https://github.com/haskell/cabal/wiki/ZuriHac-2018}{the list + of potential projects from the latest hackathon} and the tickets +marked +\href{https://github.com/haskell/cabal/issues?q=is\%3Aopen+is\%3Aissue+label\%3A\%22meta\%3A+easy\%22}{“easy”} +and +\href{https://github.com/haskell/cabal/issues?q=is\%3Aopen+is\%3Aissue+label\%3Anewcomer}{“newcomer”} +can be used as a source of ideas for what to work on. + +For more in-depth discussions there is also the +\href{https://mail.haskell.org/mailman/listinfo/cabal-devel}{\texttt{cabal-devel} + mailing list} and the +\href{http://ircbrowse.net/browse/hackage}{\texttt{\#hackage} IRC + channel on FreeNode}. + +\FurtherReading +\begin{compactitem} +\item Cabal homepage:\hfill\url{https://www.haskell.org/cabal/}\\ +\item Cabal on GitHub:\hfill\url{https://github.com/haskell/cabal} +\end{compactitem} +\end{hcarentry} diff --git a/cabal/doc/hcar/hcar.sty b/cabal/doc/hcar/hcar.sty new file mode 100644 --- /dev/null +++ b/cabal/doc/hcar/hcar.sty @@ -0,0 +1,186 @@ +\ProvidesPackage{hcar} + +\newif\ifhcarfinal +\hcarfinalfalse +\DeclareOption{final}{\hcarfinaltrue} +\ProcessOptions + +\RequirePackage{keyval} +\RequirePackage{color} +\RequirePackage{array} + +\ifhcarfinal + \RequirePackage[T1]{fontenc} + \RequirePackage{lmodern} + \RequirePackage{tabularx} + \RequirePackage{booktabs} + \RequirePackage{framed} + \RequirePackage[obeyspaces,T1]{url} + \RequirePackage + [bookmarks=true,colorlinks=true, + urlcolor=urlcolor, + linkcolor=linkcolor, + breaklinks=true, + pdftitle={Haskell Communities and Activities Report}]% + {hyperref} +\else + \RequirePackage[obeyspaces]{url} +\fi +\urlstyle{sf} + +\definecolor{urlcolor}{rgb}{0.1,0.3,0} +\definecolor{linkcolor}{rgb}{0.3,0,0} +\definecolor{shadecolor}{rgb}{0.9,0.95,1}%{0.98,1.0,0.95} +\definecolor{framecolor}{gray}{0.9} +\definecolor{oldgray}{gray}{0.7} + +\newcommand{\Contact}{\subsubsection*{Contact}} +\newcommand{\FurtherReading}{\subsubsection*{Further reading}} +\newcommand{\FuturePlans}{\subsubsection*{Future plans}} +\newcommand{\WhatsNew}{\subsubsection*{What is new?}} + +\newcommand{\Separate}{\smallskip\noindent} +\newcommand{\FinalNote}{\smallskip\noindent} + +\newcommand{\urlpart}{\begingroup\urlstyle{sf}\Url} +\newcommand{\email}[1]{\href{mailto:\EMailRepl{#1}{ at }}{$\langle$\urlpart{#1}$\rangle$}} +\newcommand{\cref}[1]{($\rightarrow\,$\ref{#1})} + +\ifhcarfinal + \let\hcarshaded=\shaded + \let\endhcarshaded=\endshaded +\else + \newsavebox{\shadedbox} + \newlength{\shadedboxwidth} + \def\hcarshaded + {\begingroup + \setlength{\shadedboxwidth}{\linewidth}% + \addtolength{\shadedboxwidth}{-2\fboxsep}% + \begin{lrbox}{\shadedbox}% + \begin{minipage}{\shadedboxwidth}\ignorespaces} + \def\endhcarshaded + {\end{minipage}% + \end{lrbox}% + \noindent + \colorbox{shadecolor}{\usebox{\shadedbox}}% + \endgroup} +\fi + +\ifhcarfinal + \newenvironment{hcartabularx} + {\tabularx{\linewidth}{l>{\raggedleft}X}} + {\endtabularx} +\else + \newenvironment{hcartabularx} + {\begin{tabular}{@{}m{.3\linewidth}@{}>{\raggedleft}p{.7\linewidth}@{}}} + {\end{tabular}} +\fi + +\ifhcarfinal + \let\hcartoprule=\toprule + \let\hcarbottomrule=\bottomrule +\else + \let\hcartoprule=\hline + \let\hcarbottomrule=\hline +\fi + +\define@key{hcarentry}{chapter}[]{\let\level\chapter} +\define@key{hcarentry}{section}[]{\let\level\section} +\define@key{hcarentry}{subsection}[]{\let\level\subsection} +\define@key{hcarentry}{subsubsection}[]{\let\level\subsubsection} +\define@key{hcarentry}{level}{\let\level=#1} +%\define@key{hcarentry}{label}{\def\entrylabel{\label{#1}}} +\define@key{hcarentry}{new}[]% + {\let\startnew=\hcarshaded\let\stopnew=\endhcarshaded + \def\startupdated{\let\orig@addv\addvspace\let\addvspace\@gobble}% + \def\stopupdated{\let\addvspace\orig@addv}} +\define@key{hcarentry}{old}[]{\def\normalcolor{\color{oldgray}}\color{oldgray}}% +\define@key{hcarentry}{updated}[]% + {\def\startupdated + {\leavevmode\let\orig@addv\addvspace\let\addvspace\@gobble\hcarshaded}% + \def\stopupdated{\endhcarshaded\let\addvspace\orig@addv}} + +\def\@makeheadererror{\PackageError{hcar}{hcarentry without header}{}} + +\newenvironment{hcarentry}[2][]% +{\let\level\subsection + \let\startupdated=\empty\let\stopupdated=\empty + \let\startnew=\empty\let\stopnew=\empty +%\let\entrylabel=\empty + \global\let\@makeheaderwarning\@makeheadererror + \setkeys{hcarentry}{#1}% + \startnew\startupdated + \level{#2}% + % test: + \global\let\@currentlabel\@currentlabel +%\stopupdated + \let\report@\empty + \let\groupleaders@\empty + \let\members@\empty + \let\contributors@\empty + \let\participants@\empty + \let\developers@\empty + \let\maintainer@\empty + \let\status@\empty + \let\release@\empty + \let\portability@\empty + \let\entry@\empty}% +{\stopnew\@makeheaderwarning}% + +\renewcommand{\labelitemi}{$\circ$} +\settowidth{\leftmargini}{\labelitemi} +\addtolength{\leftmargini}{\labelsep} + +\newcommand*\MakeKey[2]% + {\expandafter\def\csname #1\endcsname##1% + {\expandafter\def\csname #1@\endcsname{\Key@{#2}{##1}}\ignorespaces}} +\MakeKey{report}{Report by:} +\MakeKey{status}{Status:} +\MakeKey{groupleaders}{Group leaders:} +\MakeKey{members}{Members:} +\MakeKey{contributors}{Contributors:} +\MakeKey{participants}{Participants:} +\MakeKey{developers}{Developers:} +\MakeKey{maintainer}{Maintainer:} +\MakeKey{release}{Current release:} +\MakeKey{portability}{Portability:} +\MakeKey{entry}{Entry:} + +\newcommand\Key@[2]{#1 & #2\tabularnewline} + +\newcommand\makeheader +{\smallskip + \begingroup + \sffamily + \small + \noindent + \let\ohrule\hrule + \def\hrule{\color{framecolor}\ohrule}% + \begin{hcartabularx} + \hline + \report@ + \groupleaders@ + \members@ + \participants@ + \developers@ + \contributors@ + \maintainer@ + \status@ + \release@ + \portability@ + \hcarbottomrule + \end{hcartabularx} + \endgroup + \stopupdated + \global\let\@makeheaderwarning\empty + \@afterindentfalse + \@xsect\smallskipamount} + +% columns/linebreaks, interchanged +\newcommand\NCi{&\let\NX\NCii}% +\newcommand\NCii{&\let\NX\NL}% +\newcommand\NL{\\\let\NX\NCi}% +\let\NX\NCi +\newcommand\hcareditor[1]{ (ed.)&\\} +\newcommand\hcarauthor[1]{#1\NX}% +\newcommand\hcareditors[1]{\multicolumn{3}{c}{#1 (eds.)}\\[2ex]} diff --git a/cabal/doc/hcar/main.tex b/cabal/doc/hcar/main.tex new file mode 100644 --- /dev/null +++ b/cabal/doc/hcar/main.tex @@ -0,0 +1,11 @@ +\documentclass{article} + +\usepackage{hcar} +\usepackage{hyperref} +\usepackage{paralist} + +\begin{document} + +\input{Cabal-201811} + +\end{document} diff --git a/cabal/doc/images/Cabal-dark.png b/cabal/doc/images/Cabal-dark.png new file mode 100644 Binary files /dev/null and b/cabal/doc/images/Cabal-dark.png differ diff --git a/cabal/doc/index.rst b/cabal/doc/index.rst new file mode 100644 --- /dev/null +++ b/cabal/doc/index.rst @@ -0,0 +1,20 @@ + +Welcome to the Cabal User Guide +=============================== + +.. toctree:: + :maxdepth: 2 + :numbered: + + getting-started + intro + concepts-and-development + nix-local-build-overview + cabal-config-and-commands + cabal-package + cabal-project + setup-commands + file-format-changelog + buildinfo-fields-reference + bugs-and-stability + nix-integration diff --git a/cabal/doc/intro.rst b/cabal/doc/intro.rst new file mode 100644 --- /dev/null +++ b/cabal/doc/intro.rst @@ -0,0 +1,197 @@ +.. highlight:: console + +Cabal is the standard package system for +Haskell_ software. It helps people to +configure, build and install Haskell software and to distribute it +easily to other users and developers. + +There is a command line tool called ``cabal`` for working with Cabal +packages. It helps with installing existing packages and also helps +people developing their own packages. It can be used to work with local +packages or to install packages from online package archives, including +automatically installing dependencies. By default it is configured to +use Hackage_ which is Haskell's central +package archive that contains thousands of libraries and applications in +the Cabal package format. + +Introduction +============ + +Cabal is a package system for Haskell software. The point of a package +system is to enable software developers and users to easily distribute, +use and reuse software. A package system makes it easier for developers +to get their software into the hands of users. Equally importantly, it +makes it easier for software developers to be able to reuse software +components written by other developers. + +Packaging systems deal with packages and with Cabal we call them *Cabal +packages*. The Cabal package is the unit of distribution. Every Cabal +package has a name and a version number which are used to identify the +package, e.g. ``filepath-1.0``. + +Cabal packages can depend on other Cabal packages. There are tools to +enable automated package management. This means it is possible for +developers and users to install a package plus all of the other Cabal +packages that it depends on. It also means that it is practical to make +very modular systems using lots of packages that reuse code written by +many developers. + +Cabal packages are source based and are typically (but not necessarily) +portable to many platforms and Haskell implementations. The Cabal +package format is designed to make it possible to translate into other +formats, including binary packages for various systems. + +When distributed, Cabal packages use the standard compressed tarball +format, with the file extension ``.tar.gz``, e.g. +``filepath-1.0.tar.gz``. + +Note that packages are not part of the Haskell language, rather they are +a feature provided by the combination of Cabal and GHC (and several +other Haskell implementations). + +A tool for working with packages +-------------------------------- + +There is a command line tool, called "``cabal``", that users and +developers can use to build and install Cabal packages. It can be used +for both local packages and for packages available remotely over the +network. It can automatically install Cabal packages plus any other +Cabal packages they depend on. + +Developers can use the tool with packages in local directories, e.g. + +:: + + $ cd foo/ + $ cabal install + +While working on a package in a local directory, developers can run the +individual steps to configure and build, and also generate documentation +and run test suites and benchmarks. + +It is also possible to install several local packages at once, e.g. + +:: + + $ cabal install foo/ bar/ + +Developers and users can use the tool to install packages from remote +Cabal package archives. By default, the ``cabal`` tool is configured to +use the central Haskell package archive called +Hackage_ but it is possible to use it +with any other suitable archive. + +:: + + $ cabal install xmonad + +This will install the ``xmonad`` package plus all of its dependencies. + +In addition to packages that have been published in an archive, +developers can install packages from local or remote tarball files, for +example + +:: + + $ cabal install foo-1.0.tar.gz + $ cabal install http://example.com/foo-1.0.tar.gz + +Cabal provides a number of ways for a user to customise how and where a +package is installed. They can decide where a package will be installed, +which Haskell implementation to use and whether to build optimised code +or build with the ability to profile code. It is not expected that users +will have to modify any of the information in the ``.cabal`` file. + +Note that ``cabal`` is not the only tool for working with Cabal +packages. Due to the standardised format and a library for reading +``.cabal`` files, there are several other special-purpose tools. + +What's in a package +------------------- + +A Cabal package consists of: + +- Haskell software, including libraries, executables and tests +- metadata about the package in a standard human and machine readable + format (the "``.cabal``" file) +- a standard interface to build the package (the "``Setup.hs``" file) + +The ``.cabal`` file contains information about the package, supplied by +the package author. In particular it lists the other Cabal packages that +the package depends on. + +For full details on what goes in the ``.cabal`` and ``Setup.hs`` files, +and for all the other features provided by the build system, see the +section on :doc:`developing packages `. + +Cabal featureset +---------------- + +Cabal and its associated tools and websites covers: + +- a software build system +- software configuration +- packaging for distribution +- automated package management + + - natively using the ``cabal`` command line tool; or + - by translation into native package formats such as RPM or deb + +- web and local Cabal package archives + + - central Hackage website with 1000's of Cabal packages + +Some parts of the system can be used without others. In particular the +built-in build system for simple packages is optional: it is possible to +use custom build systems. + +Similar systems +--------------- + +The Cabal system is roughly comparable with the system of Python Eggs, +Ruby Gems or Perl distributions. Each system has a notion of +distributable packages, and has tools to manage the process of +distributing and installing packages. + +Hackage is an online archive of Cabal packages, roughly comparable to +CPAN. + +Cabal is often compared with autoconf and automake and there is some +overlap in functionality. The most obvious similarity is that the +command line interface for actually configuring and building packages +follows the same steps and has many of the same configuration +parameters. + +:: + + $ ./configure --prefix=... + $ make + $ make install + +compared to + +:: + + $ cabal configure --prefix=... + $ cabal build + $ cabal install + +Cabal's build system for simple packages is considerably less flexible +than make/automake, but has builtin knowledge of how to build Haskell +code and requires very little manual configuration. Cabal's simple build +system is also portable to Windows, without needing a Unix-like +environment such as cygwin/mingwin. + +Compared to autoconf, Cabal takes a somewhat different approach to +package configuration. Cabal's approach is designed for automated +package management. Instead of having a configure script that tests for +whether dependencies are available, Cabal packages specify their +dependencies. There is some scope for optional and conditional +dependencies. By having package authors specify dependencies it makes it +possible for tools to install a package and all of its dependencies +automatically. It also makes it possible to translate (in a +mostly-automatically way) into another package format like RPM or deb +which also have automatic dependency resolution. + + +.. include:: references.inc diff --git a/cabal/doc/json-schemas/build-info.schema.json b/cabal/doc/json-schemas/build-info.schema.json new file mode 100644 --- /dev/null +++ b/cabal/doc/json-schemas/build-info.schema.json @@ -0,0 +1,84 @@ +{ + "$schema": "https://json-schema.org/draft/2019-09/schema", + "$comment": "When you change this, make sure to update the code in 'ShowBuildInfo.hs'", + "type": "object", + "properties": { + "cabal-lib-version": { + "type": "string" + }, + "compiler": { + "type": "object", + "properties": { + "flavour": { + "type": "string" + }, + "compiler-id": { + "type": "string" + }, + "path": { + "type": "string" + } + }, + "required": ["flavour", "compiler-id", "path"] + }, + "components": { + "type": "array", + "items": { + "type": "object", + "properties": { + "type": { + "type": "string" + }, + "name": { + "type": "string" + }, + "unit-id": { + "type": "string" + }, + "compiler-args": { + "type": "array", + "items": { + "type": "string" + } + }, + "modules": { + "type": "array", + "items": { + "type": "string" + } + }, + "src-files": { + "type": "array", + "items": { + "type": "string" + } + }, + "hs-src-dirs": { + "type": "array", + "items": { + "type": "string" + } + }, + "src-dir": { + "type": "string" + }, + "cabal-file": { + "type": "string" + } + }, + "required": [ + "type", + "name", + "unit-id", + "compiler-args", + "modules", + "src-files", + "hs-src-dirs", + "src-dir", + "cabal-file" + ] + } + } + }, + "required": ["cabal-lib-version", "compiler", "components"] +} diff --git a/cabal/doc/misc.rst b/cabal/doc/misc.rst new file mode 100644 --- /dev/null +++ b/cabal/doc/misc.rst @@ -0,0 +1,103 @@ +Reporting bugs and deficiencies +=============================== + +Please report any flaws or feature requests in the `bug +tracker `__. + +For general discussion or queries email the libraries mailing list +libraries@haskell.org. There is also a development mailing list +cabal-devel@haskell.org. + +Stability of Cabal interfaces +============================= + +The Cabal library and related infrastructure is still under active +development. New features are being added and limitations and bugs are +being fixed. This requires internal changes and often user visible +changes as well. We therefore cannot promise complete future-proof +stability, at least not without halting all development work. + +This section documents the aspects of the Cabal interface that we can +promise to keep stable and which bits are subject to change. + +Cabal file format +----------------- + +This is backwards compatible and mostly forwards compatible. New fields +can be added without breaking older versions of Cabal. Fields can be +deprecated without breaking older packages. + +Command-line interface +---------------------- + +Very Stable Command-line interfaces +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +- ``./setup configure`` +- ``--prefix`` +- ``--user`` +- ``--ghc``, ``--uhc`` +- ``--verbose`` +- ``--prefix`` + +- ``./setup build`` +- ``./setup install`` +- ``./setup register`` +- ``./setup copy`` + +Stable Command-line interfaces +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Unstable command-line +~~~~~~~~~~~~~~~~~~~~~ + +Functions and Types +------------------- + +The Cabal library follows the `Package Versioning Policy`_. +This means that within a stable major release, for example 1.2.x, there +will be no incompatible API changes. But minor versions increments, for +example 1.2.3, indicate compatible API additions. + +The Package Versioning Policy does not require any API guarantees +between major releases, for example between 1.2.x and 1.4.x. In practice +of course not everything changes between major releases. Some parts of +the API are more prone to change than others. The rest of this section +gives some informal advice on what level of API stability you can expect +between major releases. + +Very Stable API +~~~~~~~~~~~~~~~ + +- ``defaultMain`` + +- ``defaultMainWithHooks defaultUserHooks`` + +But regular ``defaultMainWithHooks`` isn't stable since ``UserHooks`` +changes. + +Semi-stable API +~~~~~~~~~~~~~~~ + +- ``UserHooks`` The hooks API will change in the future + +- ``Distribution.*`` is mostly declarative information about packages + and is somewhat stable. + +Unstable API +~~~~~~~~~~~~ + +Everything under ``Distribution.Simple.*`` has no stability guarantee. + +Hackage +------- + +The index format is a partly stable interface. It consists of a tar.gz +file that contains directories with ``.cabal`` files in. In future it +may contain more kinds of files so do not assume every file is a +``.cabal`` file. Incompatible revisions to the format would involve +bumping the name of the index file, i.e., ``00-index.tar.gz``, +``01-index.tar.gz`` etc. + + +.. include:: references.inc diff --git a/cabal/doc/nix-integration.rst b/cabal/doc/nix-integration.rst new file mode 100644 --- /dev/null +++ b/cabal/doc/nix-integration.rst @@ -0,0 +1,57 @@ +Nix Integration +=============== + +.. note:: + + This functionality doesn't work with nix-style builds. + Nix-style builds are not related to Nix integration. + +`Nix `_ is a package manager popular with some Haskell developers due to its focus on reliability and reproducibility. ``cabal`` now has the ability to integrate with Nix for dependency management during local package development. + +Enabling Nix Integration +------------------------ + +To enable Nix integration, simply pass the ``--enable-nix`` global +option when you call ``cabal``. To use this option everywhere, edit +your :ref:`global configuration file` +(default: ``$HOME/.cabal/config``) to include: + +.. code-block:: cabal + + nix: True + +If the package (which must be locally unpacked) provides a ``shell.nix`` or ``default.nix`` file, this flag will cause ``cabal`` to run most commands through ``nix-shell``. If both expressions are present, ``shell.nix`` is preferred. The following commands are affected: + +- ``cabal configure`` +- ``cabal build`` +- ``cabal repl`` +- ``cabal install`` (only if installing into a sandbox) +- ``cabal haddock`` +- ``cabal freeze`` +- ``cabal gen-bounds`` +- ``cabal run`` + +If the package does not provide an expression, ``cabal`` runs normally. + +Creating Nix Expressions +------------------------ + +The Nix package manager is based on a lazy, pure, functional programming language; packages are defined by expressions in this language. The fastest way to create a Nix expression for a Cabal package is with the `cabal2nix `_ tool. To create a ``shell.nix`` expression for the package in the current directory, run this command: + +.. code-block:: console + + $ cabal2nix --shell ./. >shell.nix + +Nix Expression Evaluation +------------------------- + +(This section describes for advanced users how Nix expressions are evaluated.) + +First, the Nix expression (``shell.nix`` or ``default.nix``) is instantiated with ``nix-instantiate``. The ``--add-root`` and ``--indirect`` options are used to create an indirect root in the Cabal build directory, preventing Nix from garbage collecting the derivation while in use. The ``IN_NIX_SHELL`` environment variable is set so that ``builtins.getEnv`` works as it would in ``nix-shell``. + +Next, the commands above are run through ``nix-shell`` using the instantiated derivation. Again, ``--add-root`` and ``--indirect`` are used to prevent Nix from garbage collecting the packages in the environment. The child ``cabal`` process reads the ``CABAL_IN_NIX_SHELL`` environment variable to prevent it from spawning additional child shells. + +Further Reading +---------------- + +The `Nix manual `_ provides further instructions for writing Nix expressions. The `Nixpkgs manual `_ describes the infrastructure provided for Haskell packages. diff --git a/cabal/doc/nix-local-build-overview.rst b/cabal/doc/nix-local-build-overview.rst new file mode 100644 --- /dev/null +++ b/cabal/doc/nix-local-build-overview.rst @@ -0,0 +1,45 @@ +.. _nix-style-builds: + +Nix-style Local Builds +====================== + +Nix-style local builds are a new build system implementation inspired by Nix. +The Nix-style local build system is commonly called "v2-build" for short +after the ``cabal v2-*`` family of commands that control it. However, those +names are only temporary now that Nix-style local builds have become the +default. For those who do not wish to use the new +functionality, the classic project style will not be removed immediately, +but these legacy commands will require the usage of the ``v1-`` prefix as of +Cabal 3.0 and will be removed in a future release. For a future-proof +way to use these commands in a script or tutorial that anticipates the +possibility of another UI paradigm being devised in the future, there +are also ``v2-`` prefixed versions that will reference the same functionality +until such a point as it is completely removed from Cabal. + +Nix-style local builds combine the best of non-sandboxed and sandboxed Cabal: + +1. Like sandboxed Cabal previously, we build sets of independent local + packages deterministically and independent of any global state. + v2-build will never tell you that it can't build your package + because it would result in a "dangerous reinstall." Given a + particular state of the Hackage index, your build is completely + reproducible. For example, you no longer need to compile packages + with profiling ahead of time; just request profiling and v2-build + will rebuild all its dependencies with profiling automatically. + +2. Like non-sandboxed Cabal today, builds of external packages are + cached in ``~/.cabal/store``, so that a package can be built once, + and then reused anywhere else it is also used. No need to continually + rebuild dependencies whenever you make a new sandbox: dependencies + which can be shared, are shared. + +Nix-style local builds were first released as beta in cabal-install 1.24. +They currently work with all versions of GHC supported by that release: GHC 7.0 and later. + +Some features described in this manual are not implemented. If you need +them, please give us a shout and we'll prioritize accordingly. + + + +.. toctree:: + nix-local-build diff --git a/cabal/doc/nix-local-build.rst b/cabal/doc/nix-local-build.rst new file mode 100644 --- /dev/null +++ b/cabal/doc/nix-local-build.rst @@ -0,0 +1,294 @@ +.. highlight:: console + +Quickstart +========== + +Suppose that you are in a directory containing a single Cabal package +which you wish to build (if you haven't set up a package yet check +out :doc:`developing packages ` for +instructions). You can configure and build it using Nix-style +local builds with this command (configuring is not necessary): + +:: + + $ cabal v2-build + +To open a GHCi shell with this package, use this command: + +:: + + $ cabal v2-repl + +To run an executable defined in this package, use this command: + +:: + + $ cabal v2-run [executable args] + +Developing multiple packages +---------------------------- + +Many Cabal projects involve multiple packages which need to be built +together. To build multiple Cabal packages, you need to first create a +``cabal.project`` file which declares where all the local package +directories live. For example, in the Cabal repository, there is a root +directory with a folder per package, e.g., the folders ``Cabal`` and +``cabal-install``. The ``cabal.project`` file specifies each folder as +part of the project: + +.. code-block:: cabal + + packages: Cabal/ + cabal-install/ + +The expectation is that a ``cabal.project`` is checked into your source +control, to be used by all developers of a project. If you need to make +local changes, they can be placed in ``cabal.project.local`` (which +should not be checked in.) + +Then, to build every component of every package, from the top-level +directory, run the command: (using cabal-install-2.0 or greater.) + +:: + + $ cabal v2-build all + +To build a specific package, you can either run ``v2-build`` from the +directory of the package in question: + +:: + + $ cd cabal-install + $ cabal v2-build + +or you can pass the name of the package as an argument to +``cabal v2-build`` (this works in any subdirectory of the project): + +:: + + $ cabal v2-build cabal-install + +You can also specify a specific component of the package to build. For +example, to build a test suite named ``package-tests``, use the command: + +:: + + $ cabal v2-build package-tests + +Targets can be qualified with package names. So to request +``package-tests`` *from* the ``Cabal`` package, use +``Cabal-tests:package-tests``. + +Unlike sandboxes, there is no need to setup a sandbox or ``add-source`` +projects; just check in ``cabal.project`` to your repository and +``v2-build`` will just work. + +Cookbook +======== + +How can I profile my library/application? +----------------------------------------- + +Create or edit your ``cabal.project.local``, adding the following +line:: + + profiling: True + +Now, ``cabal v2-build`` will automatically build all libraries and +executables with profiling. You can fine-tune the profiling settings +for each package using :cfg-field:`profiling-detail`:: + + package p + profiling-detail: toplevel-functions + +Alternately, you can call ``cabal v2-build --enable-profiling`` to +temporarily build with profiling. + +How can I have a reproducible set of versions for my dependencies? +------------------------------------------------------------------ + +You can use ``cabal freeze`` to save the solver results to a file. + +Since Cabal 3.8, an alternative approach is to use a :ref:`remote project +configuration file`: to specify a set of versions for +packages. + +One provider of such package sets is Stackage_, and its package sets are called +snapshots. The Stackage snapshots contain a set of packages from Hackage that +have all been verified to build with a given version of GHC. + +For example, the snapshot named lts-19.2 contains versioned packages which all +compile on GHC 9.0.2. You can conveniently review the `versions of packages in +lts-19.2`_. Using the following ``cabal.project`` file, Cabal will use the +versions of packages that the this snapshot specifies: + +:: + + packages: . + import: https://www.stackage.org/lts-19.2/cabal.config + +Please note that project files do not get bundled in Cabal package tarballs, +made using e.g. ``cabal sdist``. Project files are intended for use in local +development environments. + +.. _Stackage: https://stackage.org/ +.. _versions of packages in lts-19.2: https://www.stackage.org/lts-19.2 + +How it works +============ + +Local versus external packages +------------------------------ + +One of the primary innovations of Nix-style local builds is the +distinction between local packages, which users edit and recompile and +must be built per-project, versus external packages, which can be cached +across projects. To be more precise: + +1. A **local package** is one that is listed explicitly in the + ``packages``, ``optional-packages`` or ``extra-packages`` field of a + project. Usually, these refer to packages whose source code lives + directly in a folder in your project. But you can list an + arbitrary Hackage package in :cfg-field:`packages` + to force it to be treated as local. + +Local packages, as well as the external packages (below) which depend on +them, are built **inplace**, meaning that they are always built +specifically for the project and are not installed globally. Inplace +packages are not cached and not given unique hashes, which makes them +suitable for packages which you want to edit and recompile. + +2. An **external package** is any package which is not listed in the + ``packages`` field. The source code for external packages is usually + retrieved from Hackage. + +When an external package does not depend on an inplace package, it can +be built and installed to a **global** store, which can be shared across +projects. These build products are identified by a hash based on all of +the inputs which influence the compilation of a package (flags, +dependency selection, etc.). Just as in Nix, these hashes uniquely +identify the result of a build; if we compute this identifier and we +find that we already have this ID built, we can just use the already +built version. + +The global package store is ``~/.cabal/store`` (configurable via +global `store-dir` option); if you need to clear your store for +whatever reason (e.g., to reclaim disk space or because the global +store is corrupted), deleting this directory is safe (``v2-build`` +will just rebuild everything it needs on its next invocation). + +This split motivates some of the UI choices for Nix-style local build +commands. For example, flags passed to ``cabal v2-build`` are only +applied to *local* packages, so that adding a flag to +``cabal v2-build`` doesn't necessitate a rebuild of *every* transitive +dependency in the global package store. + +In cabal-install 2.0 and above, Nix-style local builds also take advantage of a +new Cabal library feature, `per-component +builds `__, +where each component of a package is configured and built separately. +This can massively speed up rebuilds of packages with lots of components +(e.g., a package that defines multiple executables), as only one +executable needs to be rebuilt. Packages that use Custom setup scripts +are not currently built on a per-component basis. + +Where are my build products? +---------------------------- + +A major deficiency in the current implementation of v2-build is that +there is no programmatic way to access the location of build products. +The location of the build products is intended to be an internal +implementation detail of v2-build, but we also understand that many +unimplemented features can only be reasonably worked around by +accessing build products directly. + +The location where build products can be found varies depending on the +version of cabal-install: + +- In cabal-install-1.24, the dist directory for a package ``p-0.1`` is + stored in ``dist-newstyle/build/p-0.1``. For example, if you built an + executable or test suite named ``pexe``, it would be located at + ``dist-newstyle/build/p-0.1/build/pexe/pexe``. + +- In cabal-install-2.0, the dist directory for a package ``p-0.1`` + defining a library built with GHC 8.0.1 on 64-bit Linux is + ``dist-newstyle/build/x86_64-linux/ghc-8.0.1/p-0.1``. When + per-component builds are enabled (any non-Custom package), a + subcomponent like an executable or test suite named ``pexe`` will be + stored at + ``dist-newstyle/build/x86_64-linux/ghc-8.0.1/p-0.1/c/pexe``; thus, + the full path of the executable is + ``dist-newstyle/build/x86_64-linux/ghc-8.0.1/p-0.1/c/pexe/build/pexe/pexe`` + (you can see why we want this to be an implementation detail!) + +- In cabal-install-2.2 and above, the ``/c/`` part of the above path + is replaced with one of ``/l/``, ``/x/``, ``/f/``, ``/t/``, or + ``/b/``, depending on the type of component (sublibrary, + executable, foreign library, test suite, or benchmark + respectively). So the full path to an executable named ``pexe`` + compiled with GHC 8.0.1 on a 64-bit Linux is now + ``dist-newstyle/build/x86_64-linux/ghc-8.0.1/p-0.1/x/pexe/build/pexe/pexe``; + for a benchmark named ``pbench`` it now is + ``dist-newstyle/build/x86_64-linux/ghc-8.0.1/p-0.1/b/pbench/build/pbench/pbench``; + + +The paths are a bit longer in 2.0 and above but the benefit is that you can +transparently have multiple builds with different versions of GHC. We +plan to add the ability to create aliases for certain build +configurations, and more convenient paths to access particularly useful +build products like executables. + +Caching +------- + +Nix-style local builds support a robust caching system which helps to reduce +the time it takes to execute a rebuild cycle. While the details of how +``cabal-install`` does caching are an implementation detail and may +change in the future, knowing what gets cached is helpful for +understanding the performance characteristics of invocations to +``v2-build``. The cached intermediate results are stored in +``dist-newstyle/cache``; this folder can be safely deleted to clear the +cache. + +The following intermediate results are cached in the following files in +this folder (the most important two are first): + +``solver-plan`` (binary) + The result of calling the dependency solver, assuming that the + Hackage index, local ``cabal.project`` file, and local ``cabal`` + files are unmodified. (Notably, we do NOT have to dependency solve + again if new build products are stored in the global store; the + invocation of the dependency solver is independent of what is + already available in the store.) +``source-hashes`` (binary) + The hashes of all local source files. When all local source files of + a local package are unchanged, ``cabal v2-build`` will skip + invoking ``setup build`` entirely (saving us from a possibly + expensive call to ``ghc --make``). The full list of source files + participating in compilation is determined using + ``cabal sdist --list-only``. Thus if you do not list all your + source files in a Cabal file, Cabal may fail to recompile when you + edit them. +``config`` (same format as ``cabal.project``) + The full project configuration, merged from ``cabal.project`` (and + friends) as well as the command line arguments. +``compiler`` (binary) + The configuration of the compiler being used to build the project. +``improved-plan`` (binary) + Like ``solver-plan``, but with all non-inplace packages improved + into pre-existing copies from the store. +``plan.json`` (JSON) + A JSON serialization of the computed install plan intended + for integrating ``cabal`` with external tooling. + The `cabal-plan `__ + package provides a library for parsing ``plan.json`` files into a + Haskell data structure as well as an example tool showing possible + applications. + + .. todo:: + + Document JSON schema (including version history of schema) + + +Note that every package also has a local cache managed by the Cabal +build system, e.g., in ``$distdir/cache``. diff --git a/cabal/doc/pyproject.toml b/cabal/doc/pyproject.toml new file mode 100644 --- /dev/null +++ b/cabal/doc/pyproject.toml @@ -0,0 +1,11 @@ +# https://pythonawesome.com/security-audit-python-project-dependencies-against-security-advisory-databases/ +[tool.skjold] +sources = ['github', 'gemnasium', 'pyup'] +report_only = false + # ALT: true # Report only, always exit with zero. +report_format = 'cli' + # ALT: 'json' # Output findings as `json`. Default is 'cli'. +verbose = true +cache_dir = '.skjold_cache' +cache_expires = 43200 # Cache max. age. (43200 = 12hrs) +ignore_file = '.skjoldignore' diff --git a/cabal/doc/references.inc b/cabal/doc/references.inc new file mode 100644 --- /dev/null +++ b/cabal/doc/references.inc @@ -0,0 +1,24 @@ +.. -*- rst -*- + This file contains commonly used link-references + See also "extlinks" in conf.py + +.. _`Package Versioning Policy`: +.. _PVP: http://pvp.haskell.org/ + +.. _Hackage: http://hackage.haskell.org/ + +.. _Haskell: http://www.haskell.org/ + +.. _Haddock: http://www.haskell.org/haddock/ + +.. _Alex: http://www.haskell.org/alex/ + +.. _Happy: http://www.haskell.org/happy/ + +.. _Hoogle: http://www.haskell.org/hoogle/ + +.. _HsColour: http://www.cs.york.ac.uk/fp/darcs/hscolour/ + +.. _cpphs: http://projects.haskell.org/cpphs/ + +.. _ABNF: https://tools.ietf.org/html/rfc5234 diff --git a/cabal/doc/requirements.in b/cabal/doc/requirements.in new file mode 100644 --- /dev/null +++ b/cabal/doc/requirements.in @@ -0,0 +1,5 @@ +sphinx >= 3.1 +sphinx_rtd_theme +sphinx-jsonschema +# Pygments>=2.7.4 suggested by CVE-2021-20270 CVE-2021-27291 +Pygments >= 2.7.4 diff --git a/cabal/doc/requirements.txt b/cabal/doc/requirements.txt new file mode 100644 --- /dev/null +++ b/cabal/doc/requirements.txt @@ -0,0 +1,72 @@ +# +# This file is autogenerated by pip-compile with python 3.9 +# To update, run: +# +# pip-compile requirements.in +# +alabaster==0.7.12 + # via sphinx +babel==2.9.1 + # via sphinx +certifi==2021.10.8 + # via requests +charset-normalizer==2.0.7 + # via requests +docutils==0.17.1 + # via + # sphinx + # sphinx-jsonschema + # sphinx-rtd-theme +idna==2.10 + # via requests +imagesize==1.2.0 + # via sphinx +jinja2==2.11.3 + # via sphinx +jsonpointer==2.1 + # via sphinx-jsonschema +markupsafe==1.1.1 + # via jinja2 +packaging==20.9 + # via sphinx +pygments==2.10.0 + # via + # -r requirements.in + # sphinx +pyparsing==2.4.7 + # via packaging +pytz==2021.3 + # via babel +pyyaml==5.4.1 + # via sphinx-jsonschema +requests==2.26.0 + # via + # sphinx + # sphinx-jsonschema +snowballstemmer==2.1.0 + # via sphinx +sphinx==4.2.0 + # via + # -r requirements.in + # sphinx-rtd-theme +sphinx-jsonschema==1.16.11 + # via -r requirements.in +sphinx-rtd-theme==1.0.0 + # via -r requirements.in +sphinxcontrib-applehelp==1.0.2 + # via sphinx +sphinxcontrib-devhelp==1.0.2 + # via sphinx +sphinxcontrib-htmlhelp==2.0.0 + # via sphinx +sphinxcontrib-jsmath==1.0.1 + # via sphinx +sphinxcontrib-qthelp==1.0.3 + # via sphinx +sphinxcontrib-serializinghtml==1.1.5 + # via sphinx +urllib3==1.26.7 + # via requests + +# The following packages are considered to be unsafe in a requirements file: +# setuptools diff --git a/cabal/doc/setup-commands.rst b/cabal/doc/setup-commands.rst new file mode 100644 --- /dev/null +++ b/cabal/doc/setup-commands.rst @@ -0,0 +1,1352 @@ +.. _setup-commands: + +Setup.hs Commands +================= + +.. highlight:: console + +GHC provides the commands ``runhaskell`` and ``runghc`` (they are equivalent) +to allow you to run Haskell programs without first having to compile them +(scripts). The low-level Cabal interface is implemented using ``Setup.hs`` +scripts. You should prefer using higher level interface provided by nix-style +builds. + +:: + + $ runhaskell Setup.hs [command] [option...] + +For the summary of the ``Setup.hs`` script's command syntax, run: + +:: + + $ runhaskell Setup.hs --help + +Building and installing a system package +---------------------------------------- + +:: + + $ runhaskell Setup.hs configure --ghc + $ runhaskell Setup.hs build + $ runhaskell Setup.hs install + +The first line readies the system to build the tool using GHC; for +example, it checks that GHC exists on the system. The second line +performs the actual building, while the last both copies the build +results to some permanent place and registers the package with GHC. + +.. note :: + + Global installing of packages is not recommended. + The :ref:`nix-style-builds` is the preferred way of building and installing + packages. + +Creating a binary package +------------------------- + +When creating binary packages (e.g. for Red Hat or Debian) one needs to +create a tarball that can be sent to another system for unpacking in the +root directory: + +:: + + $ runhaskell Setup.hs configure --prefix=/usr + $ runhaskell Setup.hs build + $ runhaskell Setup.hs copy --destdir=/tmp/mypkg + $ tar -czf mypkg.tar.gz /tmp/mypkg/ + +If the package contains a library, you need two additional steps: + +:: + + $ runhaskell Setup.hs register --gen-script + $ runhaskell Setup.hs unregister --gen-script + +This creates shell scripts ``register.sh`` and ``unregister.sh``, which +must also be sent to the target system. After unpacking there, the +package must be registered by running the ``register.sh`` script. The +``unregister.sh`` script would be used in the uninstall procedure of the +package. Similar steps may be used for creating binary packages for +Windows. + +The following options are understood by all commands: + +.. program:: setup + +.. option:: --help, -h or -? + + List the available options for the command. + +.. option:: --verbose=n or -v n + + Set the verbosity level (0-3). The normal level is 1; a missing *n* + defaults to 2. + + There is also an extended version of this command which can be + used to fine-tune the verbosity of output. It takes the + form ``[silent|normal|verbose|debug]``\ *flags*, where *flags* + is a list of ``+`` flags which toggle various aspects of + output. At the moment, only ``+callsite`` and ``+callstack`` + are supported, which respectively toggle call site and call + stack printing (these are only supported if Cabal + is built with a sufficiently recent GHC.) + +The various commands and the additional options they support are +described below. In the simple build infrastructure, any other options +will be reported as errors. + +.. _setup-configure: + +runhaskell Setup.hs configure +----------------------------- + +.. program:: runhaskell Setup.hs configure + +Prepare to build the package. Typically, this step checks that the +target platform is capable of building the package, and discovers +platform-specific features that are needed during the build. + +The user may also adjust the behaviour of later stages using the options +listed in the following subsections. In the simple build infrastructure, +the values supplied via these options are recorded in a private file +read by later stages. + +If a user-supplied ``configure`` script is run (see the section on +:ref:`system-dependent parameters` or +on :ref:`more-complex-packages`), it is +passed the :option:`--with-hc-pkg`, :option:`--prefix`, :option:`--bindir`, +:option:`--libdir`, :option:`--dynlibdir`, :option:`--datadir`, :option:`--libexecdir` and +:option:`--sysconfdir` options. In addition the value of the +:option:`--with-compiler` option is passed in a :option:`--with-hc-pkg` option +and all options specified with :option:`--configure-option` are passed on. + +.. note:: + `GNU autoconf places restrictions on paths, including the directory + that the package is built from. + `_ + The errors produced when this happens can be obscure; Cabal attempts to + detect and warn in this situation, but it is not perfect. + +In Cabal 2.0, support for a single positional argument was added to +``runhaskell Setup.hs configure`` This makes Cabal configure the specific component to +be configured. Specified names can be qualified with ``lib:`` or +``exe:`` in case just a name is ambiguous (as would be the case for a +package named ``p`` which has a library and an executable named ``p``.) +This has the following effects: + +- Subsequent invocations of ``cabal build``, ``register``, etc. operate only + on the configured component. + +- Cabal requires all "internal" dependencies (e.g., an executable + depending on a library defined in the same package) must be found in + the set of databases via :option:`--package-db` (and related flags): these + dependencies are assumed to be up-to-date. A dependency can be + explicitly specified using :option:`--dependency` simply by giving the name + of the internal library; e.g., the dependency for an internal library + named ``foo`` is given as + ``--dependency=pkg-internal=pkg-1.0-internal-abcd``. + +- Only the dependencies needed for the requested component are + required. Similarly, when :option:`--exact-configuration` is specified, + it's only necessary to specify :option:`--dependency` for the component. + (As mentioned previously, you *must* specify internal dependencies as + well.) + +- Internal ``build-tool-depends`` and ``build-tools`` dependencies are expected + to be in the ``PATH`` upon subsequent invocations of ``setup``. + +Full details can be found in the `Componentized Cabal +proposal `__. + +Programs used for building +^^^^^^^^^^^^^^^^^^^^^^^^^^ + +The following options govern the programs used to process the source +files of a package: + +.. option:: --ghc or -g, --jhc, --lhc, --uhc + + Specify which Haskell implementation to use to build the package. At + most one of these flags may be given. If none is given, the + implementation under which the setup script was compiled or + interpreted is used. + +.. option:: --with-compiler=path or -w *path* + + Specify the path to a particular compiler. If given, this must match + the implementation selected above. The default is to search for the + usual name of the selected implementation. + + This flag also sets the default value of the :option:`--with-hc-pkg` + option to the package tool for this compiler. Check the output of + ``runhaskell Setup.hs configure -v`` to ensure that it finds the right package + tool (or use :option:`--with-hc-pkg` explicitly). + +.. option:: --with-hc-pkg=path + + Specify the path to the package tool, e.g. ``ghc-pkg``. The package + tool must be compatible with the compiler specified by + :option:`--with-compiler`. If this option is omitted, the default value is + determined from the compiler selected. + +.. option:: --with-prog=path + + Specify the path to the program *prog*. Any program known to Cabal + can be used in place of *prog*. It can either be a fully path or the + name of a program that can be found on the program search path. For + example: ``--with-ghc=ghc-6.6.1`` or + ``--with-cpphs=/usr/local/bin/cpphs``. The full list of accepted + programs is not enumerated in this user guide. Rather, run + ``cabal install --help`` to view the list. + +.. option:: --prog-options=options + + Specify additional options to the program *prog*. Any program known + to Cabal can be used in place of *prog*. For example: + ``--alex-options="--template=mytemplatedir/"``. The *options* is + split into program options based on spaces. Any options containing + embedded spaced need to be quoted, for example + ``--foo-options='--bar="C:\Program File\Bar"'``. As an alternative + that takes only one option at a time but avoids the need to quote, + use :option:`--prog-option` instead. + +.. option:: --prog-option=option + + Specify a single additional option to the program *prog*. For + passing an option that contains embedded spaces, such as a file name + with embedded spaces, using this rather than :option:`--prog-options` + means you do not need an additional level of quoting. Of course if you + are using a command shell you may still need to quote, for example + ``--foo-options="--bar=C:\Program File\Bar"``. + +All of the options passed with either :option:`--prog-options` +or :option:`--prog-option` are passed in the order they were +specified on the configure command line. + +Installation paths +^^^^^^^^^^^^^^^^^^ + +The following options govern the location of installed files from a +package: + +.. option:: --prefix=dir + + The root of the installation. For example for a global install you + might use ``/usr/local`` on a Unix system, or ``C:\Program Files`` + on a Windows system. The other installation paths are usually + subdirectories of *prefix*, but they don't have to be. + + In the simple build system, *dir* may contain the following path + variables: ``$pkgid``, ``$pkg``, ``$version``, ``$compiler``, + ``$os``, ``$arch``, ``$abi``, ``$abitag`` + +.. option:: --bindir=dir + + Executables that the user might invoke are installed here. + + In the simple build system, *dir* may contain the following path + variables: ``$prefix``, ``$pkgid``, ``$pkg``, ``$version``, + ``$compiler``, ``$os``, ``$arch``, ``$abi``, ``$abitag`` + +.. option:: --libdir=dir + + Object-code libraries are installed here. + + In the simple build system, *dir* may contain the following path + variables: ``$prefix``, ``$bindir``, ``$pkgid``, ``$pkg``, + ``$version``, ``$compiler``, ``$os``, ``$arch``, ``$abi``, + ``$abitag`` + +.. option:: --dynlibdir=dir + + Dynamic libraries are installed here. + + By default, this is set to `$libdir/$abi`, which is usually not equal to + `$libdir/$libsubdir`. + + In the simple build system, *dir* may contain the following path + variables: ``$prefix``, ``$bindir``, ``$libdir``, ``$pkgid``, ``$pkg``, + ``$version``, ``$compiler``, ``$os``, ``$arch``, ``$abi``, + ``$abitag`` + +.. option:: --libexecdir=dir + + Executables that are not expected to be invoked directly by the user + are installed here. + + In the simple build system, *dir* may contain the following path + variables: ``$prefix``, ``$bindir``, ``$libdir``, ``$libsubdir``, + ``$pkgid``, ``$pkg``, ``$version``, ``$compiler``, ``$os``, + ``$arch``, ``$abi``, ``$abitag`` + +.. option:: --datadir=dir + + Architecture-independent data files are installed here. + + In the simple build system, *dir* may contain the following path + variables: ``$prefix``, ``$bindir``, ``$libdir``, ``$libsubdir``, + ``$pkgid``, ``$pkg``, ``$version``, ``$compiler``, ``$os``, + ``$arch``, ``$abi``, ``$abitag`` + +.. option:: --sysconfdir=dir + + Installation directory for the configuration files. + + In the simple build system, *dir* may contain the following path + variables: ``$prefix``, ``$bindir``, ``$libdir``, ``$libsubdir``, + ``$pkgid``, ``$pkg``, ``$version``, ``$compiler``, ``$os``, + ``$arch``, ``$abi``, ``$abitag`` + +In addition the simple build system supports the following installation +path options: + +.. option:: --libsubdir=dir + + A subdirectory of *libdir* in which libraries are actually installed. For + example, in the simple build system on Unix, the default *libdir* is + ``/usr/local/lib``, and *libsubdir* contains the compiler ABI and package + identifier, + e.g. ``x86_64-linux-ghc-8.0.2/mypkg-0.1.0-IxQNmCA7qrSEQNkoHSF7A``, so + libraries would be installed in + ``/usr/local/lib/x86_64-linux-ghc-8.0.2/mypkg-0.1.0-IxQNmCA7qrSEQNkoHSF7A/``. + + *dir* may contain the following path variables: ``$pkgid``, + ``$pkg``, ``$version``, ``$compiler``, ``$os``, ``$arch``, ``$abi``, + ``$abitag`` + +.. option:: --libexecsubdir=dir + + A subdirectory of *libexecdir* in which private executables are + installed. For example, in the simple build system on Unix, the default + *libexecdir* is ``/usr/local/libexec``, and *libsubdir* is + ``x86_64-linux-ghc-8.0.2/mypkg-0.1.0``, so private executables would be + installed in ``/usr/local/libexec/x86_64-linux-ghc-8.0.2/mypkg-0.1.0/`` + + *dir* may contain the following path variables: ``$pkgid``, + ``$pkg``, ``$version``, ``$compiler``, ``$os``, ``$arch``, ``$abi``, + ``$abitag`` + +.. option:: --datasubdir=dir + + A subdirectory of *datadir* in which data files are actually + installed. + + *dir* may contain the following path variables: ``$pkgid``, + ``$pkg``, ``$version``, ``$compiler``, ``$os``, ``$arch``, ``$abi``, + ``$abitag`` + +.. option:: --docdir=dir + + Documentation files are installed relative to this directory. + + *dir* may contain the following path variables: ``$prefix``, + ``$bindir``, ``$libdir``, ``$libsubdir``, ``$datadir``, + ``$datasubdir``, ``$pkgid``, ``$pkg``, ``$version``, ``$compiler``, + ``$os``, ``$arch``, ``$abi``, ``$abitag`` + +.. option:: --htmldir=dir + + HTML documentation files are installed relative to this directory. + + *dir* may contain the following path variables: ``$prefix``, + ``$bindir``, ``$libdir``, ``$libsubdir``, ``$datadir``, + ``$datasubdir``, ``$docdir``, ``$pkgid``, ``$pkg``, ``$version``, + ``$compiler``, ``$os``, ``$arch``, ``$abi``, ``$abitag`` + +.. option:: --program-prefix=prefix + + Prepend *prefix* to installed program names. + + *prefix* may contain the following path variables: ``$pkgid``, + ``$pkg``, ``$version``, ``$compiler``, ``$os``, ``$arch``, ``$abi``, + ``$abitag`` + +.. option:: --program-suffix=suffix + + Append *suffix* to installed program names. The most obvious use for + this is to append the program's version number to make it possible + to install several versions of a program at once: + ``--program-suffix='$version'``. + + *suffix* may contain the following path variables: ``$pkgid``, + ``$pkg``, ``$version``, ``$compiler``, ``$os``, ``$arch``, ``$abi``, + ``$abitag`` + +Path variables in the simple build system +""""""""""""""""""""""""""""""""""""""""" + +For the simple build system, there are a number of variables that can be +used when specifying installation paths. The defaults are also specified +in terms of these variables. A number of the variables are actually for +other paths, like ``$prefix``. This allows paths to be specified +relative to each other rather than as absolute paths, which is important +for building relocatable packages (see :ref:`prefix independence`). + +$prefix + The path variable that stands for the root of the installation. For + an installation to be relocatable, all other installation paths must + be relative to the ``$prefix`` variable. +$bindir + The path variable that expands to the path given by the :option:`--bindir` + configure option (or the default). +$libdir + As above but for :option:`--libdir` +$libsubdir + As above but for :option:`--libsubdir` +$dynlibdir + As above but for :option:`--dynlibdir` +$datadir + As above but for :option:`--datadir` +$datasubdir + As above but for :option:`--datasubdir` +$docdir + As above but for :option:`--docdir` +$pkgid + The name and version of the package, e.g. ``mypkg-0.2`` +$pkg + The name of the package, e.g. ``mypkg`` +$version + The version of the package, e.g. ``0.2`` +$compiler + The compiler being used to build the package, e.g. ``ghc-6.6.1`` +$os + The operating system of the computer being used to build the + package, e.g. ``linux``, ``windows``, ``osx``, ``freebsd`` or + ``solaris`` +$arch + The architecture of the computer being used to build the package, + e.g. ``i386``, ``x86_64``, ``ppc`` or ``sparc`` +$abitag + An optional tag that a compiler can use for telling incompatible + ABI's on the same architecture apart. GHCJS encodes the underlying + GHC version in the ABI tag. +$abi + A shortcut for getting a path that completely identifies the + platform in terms of binary compatibility. Expands to the same value + as ``$arch-$os-compiler-$abitag`` if the compiler uses an abi tag, + ``$arch-$os-$compiler`` if it doesn't. + +Paths in the simple build system +"""""""""""""""""""""""""""""""" + +For the simple build system, the following defaults apply: + +.. list-table:: Default installation paths + + * - Option + - Unix Default + - Windows Default + * - :option:`--prefix` (global) + - ``/usr/local`` + - ``%PROGRAMFILES%\Haskell`` + * - :option:`--prefix` (per-user) + - ``$HOME/.cabal`` + - ``%APPDATA%\cabal`` + * - :option:`--bindir` + - ``$prefix/bin`` + - ``$prefix\bin`` + * - :option:`--libdir` + - ``$prefix/lib`` + - ``$prefix`` + * - :option:`--libsubdir` (others) + - ``$pkgid/$compiler`` + - ``$pkgid\$compiler`` + * - :option:`--dynlibdir` + - ``$libdir/$abi`` + - ``$libdir\$abi`` + * - :option:`--libexecdir` + - ``$prefix/libexec`` + - ``$prefix\$pkgid`` + * - :option:`--datadir` (executable) + - ``$prefix/share`` + - ``$prefix`` + * - :option:`--datadir` (library) + - ``$prefix/share`` + - ``%PROGRAMFILES%\Haskell`` + * - :option:`--datasubdir` + - ``$pkgid`` + - ``$pkgid`` + * - :option:`--docdir` + - ``$datadir/doc/$pkgid`` + - ``$prefix\doc\$pkgid`` + * - :option:`--sysconfdir` + - ``$prefix/etc`` + - ``$prefix\etc`` + * - :option:`--htmldir` + - ``$docdir/html`` + - ``$docdir\html`` + * - :option:`--program-prefix` + - (empty) + - (empty) + * - :option:`--program-suffix` + - (empty) + - (empty) + +.. _prefix independence: + +Prefix independence +""""""""""""""""""" + +On Windows it is possible to obtain the pathname of the running program. +This means that we can construct an installable executable package that +is independent of its absolute install location. The executable can find +its auxiliary files by finding its own path and knowing the location of +the other files relative to ``$bindir``. Prefix independence is +particularly useful: it means the user can choose the install location +(i.e. the value of ``$prefix``) at install-time, rather than having to +bake the path into the binary when it is built. + +In order to achieve this, we require that for an executable on Windows, +all of ``$bindir``, ``$libdir``, ``$dynlibdir``, ``$datadir`` and ``$libexecdir`` begin +with ``$prefix``. If this is not the case then the compiled executable +will have baked-in all absolute paths. + +The application need do nothing special to achieve prefix independence. +If it finds any files using ``getDataFileName`` and the :ref:`other functions +provided for the purpose `, +the files will be accessed relative to the location of the current +executable. + +A library cannot (currently) be prefix independent, because it will be +linked into an executable whose file system location bears no relation +to the library package. + +.. _controlling flag assignments: + +Controlling Flag Assignments +^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +Flag assignments (see :ref:`resolution-of-conditions-and-flags`) +can be controlled with the following command line options. + +.. option:: -f flagname or -f -flagname + + Force the specified flag to ``true`` or ``false`` (if preceded with + a ``-``). Later specifications for the same flags will override + earlier, i.e., specifying ``-fdebug -f-debug`` is equivalent to + ``-f-debug`` + +.. option:: --flags=flagspecs + + Same as ``-f``, but allows specifying multiple flag assignments at + once. The parameter is a space-separated list of flag names (to + force a flag to ``true``), optionally preceded by a ``-`` (to force + a flag to ``false``). For example, + ``--flags="debug -feature1 feature2"`` is equivalent to + ``-fdebug -f-feature1 -ffeature2``. + +Building Test Suites +^^^^^^^^^^^^^^^^^^^^ + +.. option:: --enable-tests + + Build the test suites defined in the package description file during + the ``build`` stage. Check for dependencies required by the test + suites. If the package is configured with this option, it will be + possible to run the test suites with the ``test`` command after the + package is built. + +.. option:: --disable-tests + + (default) Do not build any test suites during the ``build`` stage. + Do not check for dependencies required only by the test suites. It + will not be possible to invoke the ``test`` command without + reconfiguring the package. + +.. option:: --enable-coverage + + Build libraries and executables (including test suites) with Haskell + Program Coverage enabled. Running the test suites will automatically + generate coverage reports with HPC. + +.. option:: --disable-coverage + + (default) Do not enable Haskell Program Coverage. + +Miscellaneous options +^^^^^^^^^^^^^^^^^^^^^ + +.. option:: --user + + Does a per-user installation. This changes the `default installation + prefix <#paths-in-the-simple-build-system>`__. It also allow + dependencies to be satisfied by the user's package database, in + addition to the global database. This also implies a default of + ``--user`` for any subsequent ``install`` command, as packages + registered in the global database should not depend on packages + registered in a user's database. + +.. option:: --global + + (default) Does a global installation. In this case package + dependencies must be satisfied by the global package database. All + packages in the user's package database will be ignored. Typically + the final installation step will require administrative privileges. + +.. option:: --package-db=db + + Allows package dependencies to be satisfied from this additional + package database *db* in addition to the global package database. + All packages in the user's package database will be ignored. The + interpretation of *db* is implementation-specific. Typically it will + be a file or directory. Not all implementations support arbitrary + package databases. + + This pushes an extra db onto the db stack. The :option:`--global` and + :option:`--user` mode switches add the respective [Global] and [Global, + User] dbs to the initial stack. There is a compiler-implementation + constraint that the global db must appear first in the stack, and if + the user one appears at all, it must appear immediately after the + global db. + + To reset the stack, use ``--package-db=clear``. + +.. option:: --ipid=ipid + + Specifies the *installed package identifier* of the package to be + built; this identifier is passed on to GHC and serves as the basis + for linker symbols and the ``id`` field in a ``ghc-pkg`` + registration. When a package has multiple components, the actual + component identifiers are derived off of this identifier. E.g., an + internal library ``foo`` from package ``p-0.1-abcd`` will get the + identifier ``p-0.1-abcd-foo``. + +.. option:: --cid=cid + + Specifies the *component identifier* of the component being built; + this is only valid if you are configuring a single component. + +.. option:: --enable-optimization[=n] or -O [n] + + (default) Build with optimization flags (if available). This is + appropriate for production use, taking more time to build faster + libraries and programs. + + The optional *n* value is the optimisation level. Some compilers + support multiple optimisation levels. The range is 0 to 2. Level 0 + is equivalent to :option:`--disable-optimization`, level 1 is the + default if no *n* parameter is given. Level 2 is higher optimisation + if the compiler supports it. Level 2 is likely to lead to longer + compile times and bigger generated code. + + When optimizations are enabled, Cabal passes ``-O2`` to the C compiler. + +.. option:: --disable-optimization + + Build without optimization. This is suited for development: building + will be quicker, but the resulting library or programs will be + slower. + +.. option:: --enable-profiling + + Build libraries and executables with profiling enabled (for + compilers that support profiling as a separate mode). For this to + work, all libraries used by this package must also have been built + with profiling support. For libraries this involves building an + additional instance of the library in addition to the normal + non-profiling instance. For executables it changes the single + executable to be built in profiling mode. + + This flag covers both libraries and executables, but can be + overridden by the :option:`--enable-library-profiling` flag. + + See also the :option:`--profiling-detail` flag below. + +.. option:: --disable-profiling + + (default) Do not enable profiling in generated libraries and + executables. + +.. option:: --enable-library-profiling or -p + + As with :option:`--enable-profiling` above, but it applies only for + libraries. So this generates an additional profiling instance of the + library in addition to the normal non-profiling instance. + + The :option:`--enable-profiling` flag controls the profiling mode for both + libraries and executables, but if different modes are desired for + libraries versus executables then use :option:`--enable-library-profiling` + as well. + +.. option:: --disable-library-profiling + + (default) Do not generate an additional profiling version of the library. + +.. option:: --profiling-detail[=level] + + Some compilers that support profiling, notably GHC, can allocate + costs to different parts of the program and there are different + levels of granularity or detail with which this can be done. In + particular for GHC this concept is called "cost centers", and GHC + can automatically add cost centers, and can do so in different ways. + + This flag covers both libraries and executables, but can be + overridden by the :option:`--library-profiling-detail` flag. + + Currently this setting is ignored for compilers other than GHC. The + levels that cabal currently supports are: + + default + For GHC this uses ``exported-functions`` for libraries and + ``toplevel-functions`` for executables. + none + No costs will be assigned to any code within this component. + exported-functions + Costs will be assigned at the granularity of all top level + functions exported from each module. In GHC specifically, this + is for non-inline functions. + toplevel-functions + Costs will be assigned at the granularity of all top level + functions in each module, whether they are exported from the + module or not. In GHC specifically, this is for non-inline + functions. + all-functions + Costs will be assigned at the granularity of all functions in + each module, whether top level or local. In GHC specifically, + this is for non-inline toplevel or where-bound functions or + values. + + This flag is new in Cabal-1.24. Prior versions used the equivalent + of ``none`` above. + +.. option:: --library-profiling-detail[=level] + + As with :option:`--profiling-detail` above, but it applies only for + libraries. + + The level for both libraries and executables is set by the + :option:`--profiling-detail` flag, but if different levels are desired + for libraries versus executables then use + :option:`--library-profiling-detail` as well. + +.. option:: --enable-library-vanilla + + (default) Build ordinary libraries (as opposed to profiling + libraries). This is independent of the + :option:`--enable-library-profiling` option. If you enable both, you get + both. + +.. option:: --disable-library-vanilla + + Do not build ordinary libraries. This is useful in conjunction with + :option:`--enable-library-profiling` to build only profiling libraries, + rather than profiling and ordinary libraries. + +.. option:: --enable-library-for-ghci + + (default) Build libraries suitable for use with GHCi. + +.. option:: --disable-library-for-ghci + + Not all platforms support GHCi and indeed on some platforms, trying + to build GHCi libs fails. In such cases this flag can be used as a + workaround. + +.. option:: --enable-split-objs + + Use the GHC ``-split-objs`` feature when building the library. This + reduces the final size of the executables that use the library by + allowing them to link with only the bits that they use rather than + the entire library. The downside is that building the library takes + longer and uses considerably more memory. + +.. option:: --disable-split-objs + + (default) Do not use the GHC ``-split-objs`` feature. This makes + building the library quicker but the final executables that use the + library will be larger. + +.. option:: --enable-executable-stripping + + (default) When installing binary executable programs, run the + ``strip`` program on the binary. This can considerably reduce the + size of the executable binary file. It does this by removing + debugging information and symbols. While such extra information is + useful for debugging C programs with traditional debuggers it is + rarely helpful for debugging binaries produced by Haskell compilers. + + Not all Haskell implementations generate native binaries. For such + implementations this option has no effect. + +.. option:: --disable-executable-stripping + + Do not strip binary executables during installation. You might want + to use this option if you need to debug a program using gdb, for + example if you want to debug the C parts of a program containing + both Haskell and C code. Another reason is if your are building a + package for a system which has a policy of managing the stripping + itself (such as some Linux distributions). + +.. option:: --enable-shared + + Build shared library. This implies a separate compiler run to + generate position independent code as required on most platforms. + +.. option:: --disable-shared + + (default) Do not build shared library. + +.. option:: --enable-static + + Build a static library. This passes ``-staticlib`` to GHC (available + for iOS, and with 8.4 more platforms). The result is an archive ``.a`` + containing all dependent haskell libararies combined. + +.. option:: --disable-static + + (default) Do not build a static library. + +.. option:: --enable-executable-dynamic + + Link dependent Haskell libraries into executables dynamically. + The executable's library dependencies must have been + built as shared objects. This implies :option:`--enable-shared` + unless :option:`--disable-shared` is explicitly specified. + +.. option:: --disable-executable-dynamic + + (default) Link dependent Haskell libraries into executables statically. + Non-Haskell (C) libraries are still linked dynamically, including libc, + so the result is still not a fully static executable + unless :option:`--enable-executable-static` is given. + +.. option:: --enable-executable-static + + Build fully static executables. + This links all dependent libraries into executables statically, + including libc. + +.. option:: --disable-executable-static + + (default) Do not build fully static executables. + +.. option:: --configure-option=str + + An extra option to an external ``configure`` script, if one is used + (see the section on :ref:`system-dependent parameters`). + There can be several of these options. + +.. option:: --extra-include-dirs[=dir] + + An extra directory to search for C header files. You can use this + flag multiple times to get a list of directories. + + You might need to use this flag if you have standard system header + files in a non-standard location that is not mentioned in the + package's ``.cabal`` file. Using this option has the same effect as + appending the directory *dir* to the ``include-dirs`` field in each + library and executable in the package's ``.cabal`` file. The + advantage of course is that you do not have to modify the package at + all. These extra directories will be used while building the package + and for libraries it is also saved in the package registration + information and used when compiling modules that use the library. + +.. option:: --extra-lib-dirs[=dir] + + An extra directory to search for system libraries files. You can use + this flag multiple times to get a list of directories. + +.. option:: --extra-framework-dirs[=dir] + + An extra directory to search for frameworks (OS X only). You can use + this flag multiple times to get a list of directories. + + You might need to use this flag if you have standard system + libraries in a non-standard location that is not mentioned in the + package's ``.cabal`` file. Using this option has the same affect as + appending the directory *dir* to the ``extra-lib-dirs`` field in + each library and executable in the package's ``.cabal`` file. The + advantage of course is that you do not have to modify the package at + all. These extra directories will be used while building the package + and for libraries it is also saved in the package registration + information and used when compiling modules that use the library. + +.. option:: --dependency[=pkgname=ipid] + + Specify that a particular dependency should used for a particular + package name. In particular, it declares that any reference to + *pkgname* in a :pkg-field:`build-depends` should be resolved to + *ipid*. + +.. option:: --exact-configuration + + This changes Cabal to require every dependency be explicitly + specified using :option:`--dependency`, rather than use Cabal's (very + simple) dependency solver. This is useful for programmatic use of + Cabal's API, where you want to error if you didn't specify enough + :option:`--dependency` flags. + + +.. option:: --constraint=constraint + + Restrict solutions involving a package to given version + bounds, flag settings, and other properties. For example, to + consider only install plans that use version 2.1 of ``bar`` + or do not use ``bar`` at all, write: + + :: + + $ cabal install --constraint="bar == 2.1" + + Version bounds have the same syntax as :pkg-field:`build-depends`. + As a special case, the following prevents ``bar`` from being + used at all: + + :: + + # Note: this is just syntax sugar for '> 1 && < 1', and is + # supported by build-depends. + $ cabal install --constraint="bar -none" + + You can also specify flag assignments: + + :: + + # Require bar to be installed with the foo flag turned on and + # the baz flag turned off. + $ cabal install --constraint="bar +foo -baz" + + To specify multiple constraints, you may pass the + ``constraint`` option multiple times. + + There are also some more specialized constraints, which most people + don't generally need: + + :: + + # Require that a version of bar be used that is already installed in + # the global package database. + $ cabal install --constraint="bar installed" + + # Require the local source copy of bar to be used. + # (Note: By default, if we have a local package we will + # automatically use it, so it will generally not be necessary to + # specify this.) + $ cabal install --constraint="bar source" + + # Require that bar have test suites and benchmarks enabled. + $ cabal install --constraint="bar test" --constraint="bar bench" + + By default, constraints only apply to build dependencies + (:pkg-field:`build-depends`), build dependencies of build + dependencies, and so on. Constraints normally do not apply to + dependencies of the ``Setup.hs`` script of any package + (:pkg-field:`custom-setup:setup-depends`) nor do they apply to build tools + (:pkg-field:`build-tool-depends`) or the dependencies of build + tools. To explicitly apply a constraint to a setup or build + tool dependency, you can add a qualifier to the constraint as + follows: + + :: + + # Example use of the 'any' qualifier. This constraint + # applies to package bar anywhere in the dependency graph. + $ cabal install --constraint="any.bar == 1.0" + + :: + + # Example uses of 'setup' qualifiers. + + # This constraint applies to package bar when it is a + # dependency of any Setup.hs script. + $ cabal install --constraint="setup.bar == 1.0" + + # This constraint applies to package bar when it is a + # dependency of the Setup.hs script of package foo. + $ cabal install --constraint="foo:setup.bar == 1.0" + + .. TODO: Uncomment this example once we decide on a syntax for 'exe'. + .. # Example use of the 'exe' (executable build tool) + # qualifier. This constraint applies to package baz when it + # is a dependency of the build tool bar being used to + # build package foo. + $ cabal install --constraint="foo:bar:exe.baz == 1.0" + +.. option:: --disable-response-files + + Enable workaround for older versions of programs such as ``ar`` or + ``ld`` that do not support response file arguments (i.e. ``@file`` + arguments). You may want this flag only if you specify custom ar + executable. For system ``ar`` or the one bundled with ``ghc`` on + Windows the ``cabal`` should do the right thing and hence should + normally not require this flag. + +.. _setup-build: + +runhaskell Setup.hs build +------------------------- + +Perform any preprocessing or compilation needed to make this package +ready for installation. + +This command takes the following options: + +.. program:: runhaskell Setup.hs build + +.. option:: --prog-options=options, --prog-option=option + + These are mostly the same as the `options configure + step <#setup-configure>`__. Unlike the options specified at the + configure step, any program options specified at the build step are + not persistent but are used for that invocation only. The options + specified at the build step are in addition not in replacement of + any options specified at the configure step. + +.. _setup-haddock: + +runhaskell Setup.hs haddock +--------------------------- + +.. program:: runhaskell Setup.hs haddock + +Build the documentation for the package using Haddock_. +By default, only the documentation for the exposed modules is generated +(but see the :option:`--executables` and :option:`--internal` flags below). + +This command takes the following options: + +.. option:: --hoogle + + Generate a file ``dist/doc/html/``\ *pkgid*\ ``.txt``, which can be + converted by Hoogle_ into a + database for searching. This is equivalent to running Haddock_ + with the ``--hoogle`` flag. + +.. option:: --html-location=url + + Specify a template for the location of HTML documentation for + prerequisite packages. The substitutions (`see + listing <#paths-in-the-simple-build-system>`__) are applied to the + template to obtain a location for each package, which will be used + by hyperlinks in the generated documentation. For example, the + following command generates links pointing at Hackage_ pages: + + :: + + $ runhaskell Setup.hs haddock \ + --html-location='http://hackage.haskell.org/packages/archive/$pkg/latest/doc/html' + + Here the argument is quoted to prevent substitution by the shell. If + this option is omitted, the location for each package is obtained + using the package tool (e.g. ``ghc-pkg``). + +.. option:: --executables + + Also run Haddock_ for the modules of all the executable programs. By default + Haddock_ is run only on the exported modules. + +.. option:: --internal + + Run Haddock_ for the all + modules, including unexposed ones, and make + Haddock_ generate documentation + for unexported symbols as well. + +.. option:: --css=path + + The argument *path* denotes a CSS file, which is passed to + Haddock_ and used to set the + style of the generated documentation. This is only needed to + override the default style that + Haddock_ uses. + +.. option:: --hyperlink-source + + Generate Haddock_ documentation integrated with HsColour_ . First, + HsColour_ is run to generate colourised code. Then Haddock_ is run to + generate HTML documentation. Each entity shown in the documentation is + linked to its definition in the colourised code. + +.. option:: --hscolour-css=path + + The argument *path* denotes a CSS file, which is passed to HsColour_ as in + + :: + + $ runhaskell Setup.hs hscolour --css=*path* + +.. _setup-hscolour: + +runhaskell Setup.hs hscolour +---------------------------- + +Produce colourised code in HTML format using HsColour_. Colourised code for +exported modules is put in ``dist/doc/html/``\ *pkgid*\ ``/src``. + +This command takes the following options: + +.. program:: runhaskell Setup.hs hscolour + +.. option:: --executables + + Also run HsColour_ on the sources of all executable programs. Colourised + code is put in ``dist/doc/html/``\ *pkgid*/*executable*\ ``/src``. + +.. option:: --css=path + + Use the given CSS file for the generated HTML files. The CSS file + defines the colours used to colourise code. Note that this copies + the given CSS file to the directory with the generated HTML files + (renamed to ``hscolour.css``) rather than linking to it. + +.. _setup-install: + +runhaskell Setup.hs install +--------------------------- + +.. program:: runhaskell Setup.hs install + +Copy the files into the install locations and (for library packages) +register the package with the compiler, i.e. make the modules it +contains available to programs. + +The `install locations <#installation-paths>`__ are determined by +options to `runhaskell Setup.hs configure`_. + +This command takes the following options: + +.. option:: --global + + Register this package in the system-wide database. (This is the + default, unless the :option:`runhaskell Setup.hs configure --user` option was supplied + to the ``configure`` command.) + +.. option:: --user + + Register this package in the user's local package database. (This is + the default if the :option:`runhaskell Setup.hs configure --user` option was supplied + to the ``configure`` command.) + +.. _setup-copy: + +runhaskell Setup.hs copy +------------------------ + +Copy the files without registering them. This command is mainly of use +to those creating binary packages. + +This command takes the following option: + +.. program:: runhaskell Setup.hs copy + +.. option:: --destdir=path + + Specify the directory under which to place installed files. If this is + not given, then the root directory is assumed. + +.. _setup-register: + +runhaskell Setup.hs register +---------------------------- + +Register this package with the compiler, i.e. make the modules it +contains available to programs. This only makes sense for library +packages. Note that the ``install`` command incorporates this action. +The main use of this separate command is in the post-installation step +for a binary package. + +This command takes the following options: + +.. program:: runhaskell Setup.hs register + +.. option:: --global + + Register this package in the system-wide database. (This is the + default.) + +.. option:: --user + + Register this package in the user's local package database. + +.. option:: --gen-script + + Instead of registering the package, generate a script containing + commands to perform the registration. On Unix, this file is called + ``register.sh``, on Windows, ``register.bat``. This script might be + included in a binary bundle, to be run after the bundle is unpacked + on the target system. + +.. option:: --gen-pkg-config[=path] + + Instead of registering the package, generate a package registration + file (or directory, in some circumstances). This only applies to + compilers that support package registration files which at the + moment is only GHC. The file should be used with the compiler's + mechanism for registering packages. This option is mainly intended + for packaging systems. If possible use the :option:`--gen-script` option + instead since it is more portable across Haskell implementations. + The *path* is optional and can be used to specify a particular + output file to generate. Otherwise, by default the file is the + package name and version with a ``.conf`` extension. + + This option outputs a directory if the package requires multiple + registrations: this can occur if internal/convenience libraries are + used. These configuration file names are sorted so that they can be + registered in order. + +.. option:: --inplace + + Registers the package for use directly from the build tree, without + needing to install it. This can be useful for testing: there's no + need to install the package after modifying it, just recompile and + test. + + This flag does not create a build-tree-local package database. It + still registers the package in one of the user or global databases. + + However, there are some caveats. It only works with GHC (currently). + It only works if your package doesn't depend on having any + supplemental files installed --- plain Haskell libraries should be + fine. + +.. _setup-unregister: + +runhaskell Setup.hs unregister +------------------------------ + +.. program:: runhaskell Setup.hs unregister + +Deregister this package with the compiler. + +This command takes the following options: + +.. option:: --global + + Deregister this package in the system-wide database. (This is the + default.) + +.. option:: --user + + Deregister this package in the user's local package database. + +.. option:: --gen-script + + Instead of deregistering the package, generate a script containing + commands to perform the deregistration. On Unix, this file is called + ``unregister.sh``, on Windows, ``unregister.bat``. This script might + be included in a binary bundle, to be run on the target system. + +.. _setup-clean: + +runhaskell Setup.hs clean +------------------------- + +Remove any local files created during the ``configure``, ``build``, +``haddock``, ``register`` or ``unregister`` steps, and also any files +and directories listed in the :pkg-field:`extra-tmp-files` field. + +This command takes the following options: + +.. program:: runhaskell Setup.hs clean + +.. option:: --save-configure, -s + + Keeps the configuration information so it is not necessary to run + the configure step again before building. + +.. _setup-test: + +runhaskell Setup.hs test +------------------------ + +Run the test suites specified in the package description file. Aside +from the following flags, Cabal accepts the name of one or more test +suites on the command line after ``test``. When supplied, Cabal will run +only the named test suites, otherwise, Cabal will run all test suites in +the package. + +.. program:: runhaskell Setup.hs test + +.. option:: --builddir=dir + + The directory where Cabal puts generated build files (default: + ``dist``). Test logs will be located in the ``test`` subdirectory. + +.. option:: --human-log=path + + The template used to name human-readable test logs; the path is + relative to ``dist/test``. By default, logs are named according to + the template ``$pkgid-$test-suite.log``, so that each test suite + will be logged to its own human-readable log file. Template + variables allowed are: ``$pkgid``, ``$compiler``, ``$os``, + ``$arch``, ``$abi``, ``$abitag``, ``$test-suite``, and ``$result``. + +.. option:: --machine-log=path + + The path to the machine-readable log, relative to ``dist/test``. The + default template is ``$pkgid.log``. Template variables allowed are: + ``$pkgid``, ``$compiler``, ``$os``, ``$arch``, ``$abi``, ``$abitag`` + and ``$result``. + +.. option:: --show-details=filter + + Determines if the results of individual test cases are shown on the + terminal. May be ``always`` (always show), ``never`` (never show), + ``failures`` (show only failed results), or ``streaming`` (show all + results in real time). + +.. option:: --test-options=options + + Give extra options to the test executables. + +.. option:: --test-option=option + + Give an extra option to the test executables. There is no need to + quote options containing spaces because a single option is assumed, + so options will not be split on spaces. + +.. option:: --test-wrapper=path + + The wrapper script/application used to setup and tear down the test + execution context. The text executable path and test arguments are + passed as arguments to the wrapper and it is expected that the wrapper + will return the test's return code, as well as a copy of stdout/stderr. + +.. _setup-bench: + +runhaskell Setup.hs bench +------------------------- + +Run the benchmarks specified in the package description file. Aside +from the following flags, Cabal accepts the name of one or more benchmarks +on the command line after ``bench``. When supplied, Cabal will run +only the named benchmarks, otherwise, Cabal will run all benchmarks in +the package. + +.. option:: --benchmark-options=options + + Give extra options to the benchmark executables. + +.. option:: --benchmark-option=option + + Give an extra option to the benchmark executables. There is no need to + quote options containing spaces because a single option is assumed, + so options will not be split on spaces. + +.. _setup-sdist: + +runhaskell Setup.hs sdist +------------------------- + +Create a system- and compiler-independent source distribution in a file +*package*-*version*\ ``.tar.gz`` in the ``dist`` subdirectory, for +distribution to package builders. When unpacked, the commands listed in +this section will be available. + +The files placed in this distribution are the package description file, +the setup script, the sources of the modules named in the package +description file, and files named in the ``license-file``, ``main-is``, +``c-sources``, ``asm-sources``, ``cmm-sources``, ``js-sources``, +``data-files``, ``extra-source-files`` and ``extra-doc-files`` fields. + +This command takes the following option: + +.. program:: runhaskell Setup.hs sdist + +.. option:: --snapshot + + Append today's date (in "YYYYMMDD" format) to the version number for + the generated source package. The original package is unaffected. + + +.. include:: references.inc diff --git a/cabal/editors/vim/example.cabal b/cabal/editors/vim/example.cabal new file mode 100644 --- /dev/null +++ b/cabal/editors/vim/example.cabal @@ -0,0 +1,88 @@ +cabal-version: 1.12 +name: example +version: 1 +synopsis: Synopsis is short, Example file for highlighting testing +author: Oleg Grenrus +maintainer: Oleg Grenrus +homepage: http://example.com/url%20with%20spaces +category: Example +license: BSD-3-Clause +license-file: LICENSE +build-type: Simple +description: + description: Trying to fool highlighter, successfully? + Description is long and often written on multiple lines Haskell2010 + type subdir extensions:, the colon could fool highlighter + DeriveFunctor + as if else elif should not be matched here +tested-with: + GHC (>=7.0.4 && <8) + || ==8.0.2 + || ==8.2.2 + || ==8.4.4 + || ==8.6.5 + || ==8.8.4 + || ==8.10.2 + +flag some-flag + manual: True + +common name + default-language: Haskell2010 + build-depends: base ^>=1.2.3 + +source-repository head + type: git + location: https://example.com/url%20with%20spaces.git + +library + import: deps + exposed-modules: Foobar + build-depends: base + + buildable: True + + if flag(some-flag) + build-depends: containers + elif !impl(ghc >=8.0) && True + build-depends: semigroups + if flag(some-flag) + build-depends: nested + else + build-depends: void + + -- test empty lines + build-depends: + , containers >= 0.5.0.0 && <0.6 + , base ^>=4.4.0.0 || ^>=4.5.0.0 + + -- Case insensitivity + default-extensions: + DeriveFoldable + DeriveFunctor + + other-extensions: + ImpredicativeTypes + LinearTypes + +executable my-executable + import: deps + main-is: Executable.hs + +test-suite my-tests + import: deps + + -- exitcode-stdio-1.0 or detailed-0.9 + type: exitcode-stdio-1.0 + main-is: Tests.hs + +benchmark my-benchmark + import: deps + type: exitcode-stdio-1.0 + main-is: Bench.hs + +foreign-library my-flib + import: deps + + -- native-shared or native-static + type: native-shared diff --git a/cabal/editors/vim/ftplugin/cabal.vim b/cabal/editors/vim/ftplugin/cabal.vim new file mode 100644 --- /dev/null +++ b/cabal/editors/vim/ftplugin/cabal.vim @@ -0,0 +1,14 @@ +" Vim ftplugin file +" Language: Haskell Cabal Build file +" Maintainer: Cabal Development team +if exists("b:did_ftplugin") + finish +endif +let b:did_ftplugin = 1 + + +" dashes are ok in keywords, and occasionally a dot +setlocal iskeyword=a-z,A-Z,48-57,192-255,-,. + +" comments start with -- +setlocal commentstring=--\ %s diff --git a/cabal/editors/vim/syntax/cabal.vim b/cabal/editors/vim/syntax/cabal.vim new file mode 100644 --- /dev/null +++ b/cabal/editors/vim/syntax/cabal.vim @@ -0,0 +1,620 @@ +" Vim syntax file +if exists("b:current_syntax") + finish +endif + +" this file uses line continuation +let s:cpo_save = &cpo +set cpo&vim + +" Lexical structure, keywords and comments +"""""""""""""""""""""""""""""""""""""""""" + +" set iskeyword for this syntax script +syn iskeyword a-z,A-Z,48-57,192-255,-,. + +" Comments +syn match cabalComment /--.*$/ + +" Enumerations +"""""""""""""" + +syn case match + +syn keyword cabalBuildType contained + \ Simple + \ Configure + \ Custom + +" test-suite,benchmark: exitcode-stdio-1.0, detailed-0.9 +" foreign-library: native-shared, native-static +" source-repository: git, ... +syn keyword cabalCompType contained + \ exitcode-stdio-1.0 + \ detailed-0.0 + \ native-shared native-static + \ cvs svn darcs mercurial git + +syn keyword cabalLanguage contained + \ Haskell98 + \ Haskell2010 + \ GHC2021 + +" To update this in Cabal, `cabal repl Cabal` and: +" >>> :m *Distribution.PackageDescription.FieldGrammar +" >>> _syntaxFieldNames +syn keyword cabalFieldName contained + \ asm-options + \ asm-sources + \ author + \ autogen-includes + \ autogen-modules + \ benchmark-module + \ branch + \ bug-reports + \ build-depends + \ build-tool-depends + \ build-tools + \ build-type + \ buildable + \ c-sources + \ cabal-version + \ category + \ cc-options + \ cmm-options + \ cmm-sources + \ copyright + \ cpp-options + \ cxx-options + \ cxx-sources + \ data-dir + \ data-files + \ default + \ default-extensions + \ default-language + \ description + \ exposed + \ exposed-modules + \ extensions + \ extra-bundled-libraries + \ extra-doc-files + \ extra-dynamic-library-flavours + \ extra-framework-dirs + \ extra-ghci-libraries + \ extra-lib-dirs + \ extra-libraries + \ extra-library-flavours + \ extra-source-files + \ extra-tmp-files + \ frameworks + \ ghc-options + \ ghc-prof-options + \ ghc-shared-options + \ ghcjs-options + \ ghcjs-prof-options + \ ghcjs-shared-options + \ homepage + \ hs-source-dir + \ hs-source-dirs + \ hsc2hs-options + \ hugs-options + \ include-dirs + \ includes + \ install-includes + \ jhc-options + \ js-sources + \ ld-options + \ lib-version-info + \ lib-version-linux + \ license + \ license-file + \ license-files + \ location + \ main-is + \ maintainer + \ manual + \ mixins + \ mod-def-file + \ module + \ name + \ nhc98-options + \ options + \ other-extensions + \ other-languages + \ other-modules + \ package-url + \ pkgconfig-depends + \ reexported-modules + \ scope + \ setup-depends + \ signatures + \ stability + \ subdir + \ synopsis + \ tag + \ test-module + \ tested-with + \ type + \ version + \ virtual-modules + +" To update this in Cabal, `cabal repl Cabal` and: +" >>> :m *Distribution.PackageDescription.FieldGrammar +" >>> _syntaxExtensions +syn keyword cabalExtension contained + \ Safe + \ Trustworthy + \ Unsafe + \ AllowAmbiguousTypes + \ ApplicativeDo + \ Arrows + \ AutoDeriveTypeable + \ BangPatterns + \ BinaryLiterals + \ BlockArguments + \ CApiFFI + \ CPP + \ CUSKs + \ ConstrainedClassMethods + \ ConstraintKinds + \ DataKinds + \ DatatypeContexts + \ DefaultSignatures + \ DeriveAnyClass + \ DeriveDataTypeable + \ DeriveFoldable + \ DeriveFunctor + \ DeriveGeneric + \ DeriveLift + \ DeriveTraversable + \ DerivingStrategies + \ DerivingVia + \ DisambiguateRecordFields + \ DoAndIfThenElse + \ DoRec + \ DuplicateRecordFields + \ EmptyCase + \ EmptyDataDecls + \ EmptyDataDeriving + \ ExistentialQuantification + \ ExplicitForAll + \ ExplicitNamespaces + \ ExtendedDefaultRules + \ ExtensibleRecords + \ FieldSelectors + \ FlexibleContexts + \ FlexibleInstances + \ ForeignFunctionInterface + \ FunctionalDependencies + \ GADTSyntax + \ GADTs + \ GHCForeignImportPrim + \ GeneralisedNewtypeDeriving + \ GeneralizedNewtypeDeriving + \ Generics + \ HereDocuments + \ HexFloatLiterals + \ ImplicitParams + \ ImplicitPrelude + \ ImportQualifiedPost + \ ImpredicativeTypes + \ IncoherentInstances + \ InstanceSigs + \ InterruptibleFFI + \ JavaScriptFFI + \ KindSignatures + \ LambdaCase + \ LexicalNegation + \ LiberalTypeSynonyms + \ LinearTypes + \ MagicHash + \ MonadComprehensions + \ MonadFailDesugaring + \ MonoLocalBinds + \ MonoPatBinds + \ MonomorphismRestriction + \ MultiParamTypeClasses + \ MultiWayIf + \ NPlusKPatterns + \ NamedFieldPuns + \ NamedWildCards + \ NegativeLiterals + \ NewQualifiedOperators + \ NondecreasingIndentation + \ NullaryTypeClasses + \ NumDecimals + \ NumericUnderscores + \ OverlappingInstances + \ OverloadedLabels + \ OverloadedLists + \ OverloadedRecordDot + \ OverloadedStrings + \ PackageImports + \ ParallelArrays + \ ParallelListComp + \ PartialTypeSignatures + \ PatternGuards + \ PatternSignatures + \ PatternSynonyms + \ PolyKinds + \ PolymorphicComponents + \ PostfixOperators + \ QualifiedDo + \ QuantifiedConstraints + \ QuasiQuotes + \ Rank2Types + \ RankNTypes + \ RebindableSyntax + \ RecordPuns + \ RecordWildCards + \ RecursiveDo + \ RegularPatterns + \ RelaxedPolyRec + \ RestrictedTypeSynonyms + \ RoleAnnotations + \ SafeImports + \ ScopedTypeVariables + \ StandaloneDeriving + \ StandaloneKindSignatures + \ StarIsType + \ StaticPointers + \ Strict + \ StrictData + \ TemplateHaskell + \ TemplateHaskellQuotes + \ TraditionalRecordSyntax + \ TransformListComp + \ TupleSections + \ TypeApplications + \ TypeFamilies + \ TypeFamilyDependencies + \ TypeInType + \ TypeOperators + \ TypeSynonymInstances + \ UnboxedSums + \ UnboxedTuples + \ UndecidableInstances + \ UndecidableSuperClasses + \ UnicodeSyntax + \ UnliftedDatatypes + \ UnliftedFFITypes + \ UnliftedNewtypes + \ ViewPatterns + \ XmlSyntax + \ NoAllowAmbiguousTypes + \ NoApplicativeDo + \ NoArrows + \ NoAutoDeriveTypeable + \ NoBangPatterns + \ NoBinaryLiterals + \ NoBlockArguments + \ NoCApiFFI + \ NoCPP + \ NoCUSKs + \ NoConstrainedClassMethods + \ NoConstraintKinds + \ NoDataKinds + \ NoDatatypeContexts + \ NoDefaultSignatures + \ NoDeriveAnyClass + \ NoDeriveDataTypeable + \ NoDeriveFoldable + \ NoDeriveFunctor + \ NoDeriveGeneric + \ NoDeriveLift + \ NoDeriveTraversable + \ NoDerivingStrategies + \ NoDerivingVia + \ NoDisambiguateRecordFields + \ NoDoAndIfThenElse + \ NoDoRec + \ NoDuplicateRecordFields + \ NoEmptyCase + \ NoEmptyDataDecls + \ NoEmptyDataDeriving + \ NoExistentialQuantification + \ NoExplicitForAll + \ NoExplicitNamespaces + \ NoExtendedDefaultRules + \ NoExtensibleRecords + \ NoFieldSelectors + \ NoFlexibleContexts + \ NoFlexibleInstances + \ NoForeignFunctionInterface + \ NoFunctionalDependencies + \ NoGADTSyntax + \ NoGADTs + \ NoGHCForeignImportPrim + \ NoGeneralisedNewtypeDeriving + \ NoGeneralizedNewtypeDeriving + \ NoGenerics + \ NoHereDocuments + \ NoHexFloatLiterals + \ NoImplicitParams + \ NoImplicitPrelude + \ NoImportQualifiedPost + \ NoImpredicativeTypes + \ NoIncoherentInstances + \ NoInstanceSigs + \ NoInterruptibleFFI + \ NoJavaScriptFFI + \ NoKindSignatures + \ NoLambdaCase + \ NoLexicalNegation + \ NoLiberalTypeSynonyms + \ NoLinearTypes + \ NoMagicHash + \ NoMonadComprehensions + \ NoMonadFailDesugaring + \ NoMonoLocalBinds + \ NoMonoPatBinds + \ NoMonomorphismRestriction + \ NoMultiParamTypeClasses + \ NoMultiWayIf + \ NoNPlusKPatterns + \ NoNamedFieldPuns + \ NoNamedWildCards + \ NoNegativeLiterals + \ NoNewQualifiedOperators + \ NoNondecreasingIndentation + \ NoNullaryTypeClasses + \ NoNumDecimals + \ NoNumericUnderscores + \ NoOverlappingInstances + \ NoOverloadedLabels + \ NoOverloadedLists + \ NoOverloadedRecordDot + \ NoOverloadedStrings + \ NoPackageImports + \ NoParallelArrays + \ NoParallelListComp + \ NoPartialTypeSignatures + \ NoPatternGuards + \ NoPatternSignatures + \ NoPatternSynonyms + \ NoPolyKinds + \ NoPolymorphicComponents + \ NoPostfixOperators + \ NoQualifiedDo + \ NoQuantifiedConstraints + \ NoQuasiQuotes + \ NoRank2Types + \ NoRankNTypes + \ NoRebindableSyntax + \ NoRecordPuns + \ NoRecordWildCards + \ NoRecursiveDo + \ NoRegularPatterns + \ NoRelaxedPolyRec + \ NoRestrictedTypeSynonyms + \ NoRoleAnnotations + \ NoSafeImports + \ NoScopedTypeVariables + \ NoStandaloneDeriving + \ NoStandaloneKindSignatures + \ NoStarIsType + \ NoStaticPointers + \ NoStrict + \ NoStrictData + \ NoTemplateHaskell + \ NoTemplateHaskellQuotes + \ NoTraditionalRecordSyntax + \ NoTransformListComp + \ NoTupleSections + \ NoTypeApplications + \ NoTypeFamilies + \ NoTypeFamilyDependencies + \ NoTypeInType + \ NoTypeOperators + \ NoTypeSynonymInstances + \ NoUnboxedSums + \ NoUnboxedTuples + \ NoUndecidableInstances + \ NoUndecidableSuperClasses + \ NoUnicodeSyntax + \ NoUnliftedDatatypes + \ NoUnliftedFFITypes + \ NoUnliftedNewtypes + \ NoViewPatterns + \ NoXmlSyntax + +" Cabal format is (mostly) case-insensitive +syn case ignore + +" Structure regions +""""""""""""""""""" + +" Top level stanzas, cannot be nested, only library can be have optional name +syn match cabalStanzaLineRegion + \ /^\clibrary\(\s\+\k\+\)\=\s*$/ + +" Top level stanzas with an identifier +syn match cabalStanzaLineRegion + \ /^\c\(flag\|common\|source-repository\|executable\|test-suite\|benchmark\|foreign-library\)\s\+\k\+\s*$/ + +" Conditionals are nested +syn match cabalConditionalRegion + \ contains=cabalOperator,cabalBoolean + \ /^\c\s\+\(if\|elif\|else\)[^:]*$/ + +" Unindented fields +syn match cabalFieldRegion + \ /^[a-zA-Z0-9-]\+\s*:.*\n\(\s\+.*\n\|\s*\n\)*/ + +" Indented fields +" +" We use backreferences to fake the recognition of indentation. +" Unfortunately I don't know a way to anchor contained +" matches to the boundaries of the enclosing region. +syn match cabalFieldRegion + \ /^\(\s\+\)[a-zA-Z0-9-]\+\s*:.*\n\(\1\s\+.*\n\|\s*\n\)*/ + +" Component stanzas +""""""""""""""""""" + +syn match cabalCategoryTitle + \ contained + \ /\c[a-z0-9-]\+/ + +syn keyword cabalCategory + \ contained containedin=cabalStanzaLineRegion + \ nextgroup=cabalCategoryTitle skipwhite + \ flag common source-repository library executable test-suite benchmark foreign-library + +" Version ranges +"""""""""""""""" + +syn match cabalOperator contained /&&\|||\|!/ +syn match cabalVersionOperator contained /==\|\^\?>=\|<=\|<\|>/ +" match version: `[%]\@/ +" cabalVersionRegion which limits the scope of cabalVersion pattern. +syn match cabalVersionRegion + \ contains=cabalVersionOperator,cabalVersion + \ keepend + \ /\%(==\|\^\?>=\|<=\|<\|>\)\s*\d\+\%(\.\d\+\)*\%(\.\*\)\?\>/ + +" Compilers +""""""""""" + +syn keyword cabalCompiler contained ghc nhc yhc hugs hbc helium jhc lhc + +" Conditionals +"""""""""""""" + +syn keyword cabalConditional contained containedin=cabalConditionalRegion + \ if elif else + +syn keyword cabalFunction contained + \ os arch impl flag + +syn region cabalFunctionRegion start=+\(os\|arch\|impl\|flag\)\s*(+ end=+)+ + \ contained containedin=cabalConditionalRegion + \ contains=cabalOs,cabalFunction,cabalCompiler,cabalVersionRegion + +" Common stanzas +"""""""""""""""" + +syn match cabalImportName contained /\c\<[a-z0-9-]\+\>/ +syn keyword cabalImport contained import +syn match cabalImportRegion + \ contains=cabalImport,cabalColon,cabalImportName + \ /^\c\(\s\+\)import\s*:.*\n\(\1\s\+.*\n\|\s*\n\)*/ + +" Fields names +"""""""""""""" + +syn match cabalFieldNameRegion contained containedin=cabalFieldRegion + \ contains=cabalFieldName + \ /^\s*[a-zA-Z0-9-]\+\s*:/ + +syn match cabalColon contained containedin=cabalFieldNameRegion + \ /:/ + +" Field Values +""""""""""""""""""""""""""""""""" + +syn keyword cabalBoolean contained containedin=cabalFieldRegion + \ true false + +" cabal-version +syn match cabalSpecVersion contained + \ /\(>=\s*1\.\(0\|2\|4\|6\|8\|10\)\|1\.\(12\|16\|18\|20\|22\|24\)\|2\.\(0\|2\|4\)\|3\.\(\0\|4\|6\)\)/ +syn match cabalSpecVersionRegion + \ contained containedin=cabalFieldRegion + \ contains=cabalFieldNameRegion,cabalSpecVersion + \ /\c^cabal-version\s*:.*\n\(\s\+.*\n\|\s*\n\)*/ + +" version +syn match cabalPkgVersionRegion + \ contained containedin=cabalFieldRegion + \ contains=cabalFieldNameRegion,cabalVersion + \ /\c^version\s*:.*\n\(\s\+.*\n\|\s*\n\)*/ + +" description +syn match cabalDescriptionNameRegion + \ contained + \ contains=cabalFieldName + \ /\c^description/ +syn match cabalDescriptionRegion + \ contained containedin=cabalFieldRegion + \ contains=cabalDescriptionNameRegion + \ /\c^description\s*:.*\n\(\s\+.*\n\|\s*\n\)*/ + +" tested-with +syn match cabalTestedWithRegion + \ contained containedin=cabalFieldRegion + \ contains=cabalFieldNameRegion,cabalVersionRegion,cabalOperator,cabalCompiler + \ /\c^tested-with\s*:.*\n\(\s\+.*\n\|\s*\n\)*/ + +" build-depends,build-tool-depends +" +" fields with version ranges +syn match cabalDependsRegion + \ contained containedin=cabalFieldRegion + \ contains=cabalFieldNameRegion,cabalVersionRegion,cabalOperator + \ /\c^\(\s\+\)\(build-depends\|build-tool-depends\)\s*:.*\n\(\1\s\+.*\n\|\s*\n\)*/ + +" build-type +syn match cabalBuildTypeRegion + \ contained containedin=cabalFieldRegion + \ contains=cabalFieldNameRegion,cabalBuildType + \ /\c^build-type\s*:.*\n\(\s\+.*\n\|\s*\n\)*/ + +" type +syn match cabalCompTypeRegion + \ contained containedin=cabalFieldRegion + \ contains=cabalFieldNameRegion,cabalCompType + \ /\c^\(\s\+\)type\s*:.*\n\(\1\s\+.*\n\|\s*\n\)*/ + +" default-extensions other-extensions extensions +syn match cabalExtensionsRegion + \ contained containedin=cabalFieldRegion + \ contains=cabalFieldNameRegion,cabalExtension + \ /^\c\(\s\+\)\(default-extensions\|other-extensions\|extensions\)\s*:.*\n\(\1\s\+.*\n\|\s*\n\)*/ + +" default-language other-languages +syn match cabalLanguagesRegion + \ contained containedin=cabalFieldRegion + \ contains=cabalFieldNameRegion,cabalLanguage + \ /^\c\(\s\+\)\(default-language\|other-languages\)\s*:.*\n\(\1\s\+.*\n\|\s*\n\)*/ + +" Define the default highlighting +""""""""""""""""""""""""""""""""" + +hi link cabalComment Comment + +" We highlight stanza region, as it makes component name highlighted +hi link cabalStanzaLineRegion NONE +hi link cabalFieldRegion NONE +hi link cabalFieldNameRegion NONE +hi link cabalConditionalRegion NONE + +hi link cabalCategory Type +hi link cabalCategoryTitle Title + +hi link cabalImport Type +hi link cabalImportName Title + +hi link cabalFunction Function + +hi link cabalConditional Conditional +hi link cabalOperator Operator +hi link cabalVersionOperator Special +hi link cabalSpecVersion Special +hi link cabalVersion Special + +hi link cabalFieldName Keyword +hi link cabalColon Operator +hi link cabalBoolean Boolean + +hi link cabalBuildType Constant +hi link cabalCompiler Constant +hi link cabalCompType Constant +hi link cabalExtension Constant +hi link cabalLanguage Constant +hi link cabalOs Constant + +let b:current_syntax="mini-cabal" + +" vim: ts=2 diff --git a/cabal/ghc-packages b/cabal/ghc-packages --- a/cabal/ghc-packages +++ b/cabal/ghc-packages @@ -1,2 +1,2 @@ Cabal - +Cabal-syntax diff --git a/cabal/license-list-data/exceptions-3.10.json b/cabal/license-list-data/exceptions-3.10.json new file mode 100644 --- /dev/null +++ b/cabal/license-list-data/exceptions-3.10.json @@ -0,0 +1,466 @@ +{ + "licenseListVersion": "3.10", + "releaseDate": "2020-08-03", + "exceptions": [ + { + "reference": "./GCC-exception-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/GCC-exception-2.0.json", + "referenceNumber": "1", + "name": "GCC Runtime Library exception 2.0", + "seeAlso": [ + "https://gcc.gnu.org/git/?p\u003dgcc.git;a\u003dblob;f\u003dgcc/libgcc1.c;h\u003d762f5143fc6eed57b6797c82710f3538aa52b40b;hb\u003dcb143a3ce4fb417c68f5fa2691a1b1b1053dfba9#l10" + ], + "licenseExceptionId": "GCC-exception-2.0" + }, + { + "reference": "./openvpn-openssl-exception.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/openvpn-openssl-exception.json", + "referenceNumber": "2", + "name": "OpenVPN OpenSSL Exception", + "seeAlso": [ + "http://openvpn.net/index.php/license.html" + ], + "licenseExceptionId": "openvpn-openssl-exception" + }, + { + "reference": "./Nokia-Qt-exception-1.1.html", + "isDeprecatedLicenseId": true, + "detailsUrl": "http://spdx.org/licenses/Nokia-Qt-exception-1.1.json", + "referenceNumber": "3", + "name": "Nokia Qt LGPL exception 1.1", + "seeAlso": [ + "https://www.keepassx.org/dev/projects/keepassx/repository/revisions/b8dfb9cc4d5133e0f09cd7533d15a4f1c19a40f2/entry/LICENSE.NOKIA-LGPL-EXCEPTION" + ], + "licenseExceptionId": "Nokia-Qt-exception-1.1" + }, + { + "reference": "./GPL-3.0-linking-exception.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/GPL-3.0-linking-exception.json", + "referenceNumber": "4", + "name": "GPL-3.0 Linking Exception", + "seeAlso": [ + "https://www.gnu.org/licenses/gpl-faq.en.html#GPLIncompatibleLibs" + ], + "licenseExceptionId": "GPL-3.0-linking-exception" + }, + { + "reference": "./Fawkes-Runtime-exception.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Fawkes-Runtime-exception.json", + "referenceNumber": "5", + "name": "Fawkes Runtime Exception", + "seeAlso": [ + "http://www.fawkesrobotics.org/about/license/" + ], + "licenseExceptionId": "Fawkes-Runtime-exception" + }, + { + "reference": "./u-boot-exception-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/u-boot-exception-2.0.json", + "referenceNumber": "6", + "name": "U-Boot exception 2.0", + "seeAlso": [ + "http://git.denx.de/?p\u003du-boot.git;a\u003dblob;f\u003dLicenses/Exceptions" + ], + "licenseExceptionId": "u-boot-exception-2.0" + }, + { + "reference": "./PS-or-PDF-font-exception-20170817.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/PS-or-PDF-font-exception-20170817.json", + "referenceNumber": "7", + "name": "PS/PDF font exception (2017-08-17)", + "seeAlso": [ + "https://github.com/ArtifexSoftware/urw-base35-fonts/blob/65962e27febc3883a17e651cdb23e783668c996f/LICENSE" + ], + "licenseExceptionId": "PS-or-PDF-font-exception-20170817" + }, + { + "reference": "./gnu-javamail-exception.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/gnu-javamail-exception.json", + "referenceNumber": "8", + "name": "GNU JavaMail exception", + "seeAlso": [ + "http://www.gnu.org/software/classpathx/javamail/javamail.html" + ], + "licenseExceptionId": "gnu-javamail-exception" + }, + { + "reference": "./LGPL-3.0-linking-exception.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/LGPL-3.0-linking-exception.json", + "referenceNumber": "9", + "name": "LGPL-3.0 Linking Exception", + "seeAlso": [ + "https://raw.githubusercontent.com/go-xmlpath/xmlpath/v2/LICENSE", + "https://github.com/goamz/goamz/blob/master/LICENSE", + "https://github.com/juju/errors/blob/master/LICENSE" + ], + "licenseExceptionId": "LGPL-3.0-linking-exception" + }, + { + "reference": "./DigiRule-FOSS-exception.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/DigiRule-FOSS-exception.json", + "referenceNumber": "10", + "name": "DigiRule FOSS License Exception", + "seeAlso": [ + "http://www.digirulesolutions.com/drupal/foss" + ], + "licenseExceptionId": "DigiRule-FOSS-exception" + }, + { + "reference": "./LLVM-exception.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/LLVM-exception.json", + "referenceNumber": "11", + "name": "LLVM Exception", + "seeAlso": [ + "http://llvm.org/foundation/relicensing/LICENSE.txt" + ], + "licenseExceptionId": "LLVM-exception" + }, + { + "reference": "./Linux-syscall-note.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Linux-syscall-note.json", + "referenceNumber": "12", + "name": "Linux Syscall Note", + "seeAlso": [ + "https://git.kernel.org/pub/scm/linux/kernel/git/torvalds/linux.git/tree/COPYING" + ], + "licenseExceptionId": "Linux-syscall-note" + }, + { + "reference": "./GPL-3.0-linking-source-exception.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/GPL-3.0-linking-source-exception.json", + "referenceNumber": "13", + "name": "GPL-3.0 Linking Exception (with Corresponding Source)", + "seeAlso": [ + "https://www.gnu.org/licenses/gpl-faq.en.html#GPLIncompatibleLibs", + "https://github.com/mirror/wget/blob/master/src/http.c#L20" + ], + "licenseExceptionId": "GPL-3.0-linking-source-exception" + }, + { + "reference": "./Qwt-exception-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Qwt-exception-1.0.json", + "referenceNumber": "14", + "name": "Qwt exception 1.0", + "seeAlso": [ + "http://qwt.sourceforge.net/qwtlicense.html" + ], + "licenseExceptionId": "Qwt-exception-1.0" + }, + { + "reference": "./389-exception.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/389-exception.json", + "referenceNumber": "15", + "name": "389 Directory Server Exception", + "seeAlso": [ + "http://directory.fedoraproject.org/wiki/GPL_Exception_License_Text" + ], + "licenseExceptionId": "389-exception" + }, + { + "reference": "./mif-exception.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/mif-exception.json", + "referenceNumber": "16", + "name": "Macros and Inline Functions Exception", + "seeAlso": [ + "http://www.scs.stanford.edu/histar/src/lib/cppsup/exception", + "http://dev.bertos.org/doxygen/", + "https://www.threadingbuildingblocks.org/licensing" + ], + "licenseExceptionId": "mif-exception" + }, + { + "reference": "./eCos-exception-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/eCos-exception-2.0.json", + "referenceNumber": "17", + "name": "eCos exception 2.0", + "seeAlso": [ + "http://ecos.sourceware.org/license-overview.html" + ], + "licenseExceptionId": "eCos-exception-2.0" + }, + { + "reference": "./CLISP-exception-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/CLISP-exception-2.0.json", + "referenceNumber": "18", + "name": "CLISP exception 2.0", + "seeAlso": [ + "http://sourceforge.net/p/clisp/clisp/ci/default/tree/COPYRIGHT" + ], + "licenseExceptionId": "CLISP-exception-2.0" + }, + { + "reference": "./Bison-exception-2.2.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Bison-exception-2.2.json", + "referenceNumber": "19", + "name": "Bison exception 2.2", + "seeAlso": [ + "http://git.savannah.gnu.org/cgit/bison.git/tree/data/yacc.c?id\u003d193d7c7054ba7197b0789e14965b739162319b5e#n141" + ], + "licenseExceptionId": "Bison-exception-2.2" + }, + { + "reference": "./Libtool-exception.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Libtool-exception.json", + "referenceNumber": "20", + "name": "Libtool Exception", + "seeAlso": [ + "http://git.savannah.gnu.org/cgit/libtool.git/tree/m4/libtool.m4" + ], + "licenseExceptionId": "Libtool-exception" + }, + { + "reference": "./LZMA-exception.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/LZMA-exception.json", + "referenceNumber": "21", + "name": "LZMA exception", + "seeAlso": [ + "http://nsis.sourceforge.net/Docs/AppendixI.html#I.6" + ], + "licenseExceptionId": "LZMA-exception" + }, + { + "reference": "./OpenJDK-assembly-exception-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/OpenJDK-assembly-exception-1.0.json", + "referenceNumber": "22", + "name": "OpenJDK Assembly exception 1.0", + "seeAlso": [ + "http://openjdk.java.net/legal/assembly-exception.html" + ], + "licenseExceptionId": "OpenJDK-assembly-exception-1.0" + }, + { + "reference": "./Font-exception-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Font-exception-2.0.json", + "referenceNumber": "23", + "name": "Font exception 2.0", + "seeAlso": [ + "http://www.gnu.org/licenses/gpl-faq.html#FontException" + ], + "licenseExceptionId": "Font-exception-2.0" + }, + { + "reference": "./OCaml-LGPL-linking-exception.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/OCaml-LGPL-linking-exception.json", + "referenceNumber": "24", + "name": "OCaml LGPL Linking Exception", + "seeAlso": [ + "https://caml.inria.fr/ocaml/license.en.html" + ], + "licenseExceptionId": "OCaml-LGPL-linking-exception" + }, + { + "reference": "./GCC-exception-3.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/GCC-exception-3.1.json", + "referenceNumber": "25", + "name": "GCC Runtime Library exception 3.1", + "seeAlso": [ + "http://www.gnu.org/licenses/gcc-exception-3.1.html" + ], + "licenseExceptionId": "GCC-exception-3.1" + }, + { + "reference": "./Bootloader-exception.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Bootloader-exception.json", + "referenceNumber": "26", + "name": "Bootloader Distribution Exception", + "seeAlso": [ + "https://github.com/pyinstaller/pyinstaller/blob/develop/COPYING.txt" + ], + "licenseExceptionId": "Bootloader-exception" + }, + { + "reference": "./SHL-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/SHL-2.0.json", + "referenceNumber": "27", + "name": "Solderpad Hardware License v2.0", + "seeAlso": [ + "https://solderpad.org/licenses/SHL-2.0/" + ], + "licenseExceptionId": "SHL-2.0" + }, + { + "reference": "./Classpath-exception-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Classpath-exception-2.0.json", + "referenceNumber": "28", + "name": "Classpath exception 2.0", + "seeAlso": [ + "http://www.gnu.org/software/classpath/license.html", + "https://fedoraproject.org/wiki/Licensing/GPL_Classpath_Exception" + ], + "licenseExceptionId": "Classpath-exception-2.0" + }, + { + "reference": "./Swift-exception.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Swift-exception.json", + "referenceNumber": "29", + "name": "Swift Exception", + "seeAlso": [ + "https://swift.org/LICENSE.txt", + "https://github.com/apple/swift-package-manager/blob/7ab2275f447a5eb37497ed63a9340f8a6d1e488b/LICENSE.txt#L205" + ], + "licenseExceptionId": "Swift-exception" + }, + { + "reference": "./Autoconf-exception-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Autoconf-exception-2.0.json", + "referenceNumber": "30", + "name": "Autoconf exception 2.0", + "seeAlso": [ + "http://ac-archive.sourceforge.net/doc/copyright.html", + "http://ftp.gnu.org/gnu/autoconf/autoconf-2.59.tar.gz" + ], + "licenseExceptionId": "Autoconf-exception-2.0" + }, + { + "reference": "./FLTK-exception.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/FLTK-exception.json", + "referenceNumber": "31", + "name": "FLTK exception", + "seeAlso": [ + "http://www.fltk.org/COPYING.php" + ], + "licenseExceptionId": "FLTK-exception" + }, + { + "reference": "./freertos-exception-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/freertos-exception-2.0.json", + "referenceNumber": "32", + "name": "FreeRTOS Exception 2.0", + "seeAlso": [ + "https://web.archive.org/web/20060809182744/http://www.freertos.org/a00114.html" + ], + "licenseExceptionId": "freertos-exception-2.0" + }, + { + "reference": "./Universal-FOSS-exception-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Universal-FOSS-exception-1.0.json", + "referenceNumber": "33", + "name": "Universal FOSS Exception, Version 1.0", + "seeAlso": [ + "https://oss.oracle.com/licenses/universal-foss-exception/" + ], + "licenseExceptionId": "Universal-FOSS-exception-1.0" + }, + { + "reference": "./WxWindows-exception-3.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/WxWindows-exception-3.1.json", + "referenceNumber": "34", + "name": "WxWindows Library Exception 3.1", + "seeAlso": [ + "http://www.opensource.org/licenses/WXwindows" + ], + "licenseExceptionId": "WxWindows-exception-3.1" + }, + { + "reference": "./OCCT-exception-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/OCCT-exception-1.0.json", + "referenceNumber": "35", + "name": "Open CASCADE Exception 1.0", + "seeAlso": [ + "http://www.opencascade.com/content/licensing" + ], + "licenseExceptionId": "OCCT-exception-1.0" + }, + { + "reference": "./Autoconf-exception-3.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Autoconf-exception-3.0.json", + "referenceNumber": "36", + "name": "Autoconf exception 3.0", + "seeAlso": [ + "http://www.gnu.org/licenses/autoconf-exception-3.0.html" + ], + "licenseExceptionId": "Autoconf-exception-3.0" + }, + { + "reference": "./i2p-gpl-java-exception.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/i2p-gpl-java-exception.json", + "referenceNumber": "37", + "name": "i2p GPL+Java Exception", + "seeAlso": [ + "http://geti2p.net/en/get-involved/develop/licenses#java_exception" + ], + "licenseExceptionId": "i2p-gpl-java-exception" + }, + { + "reference": "./GPL-CC-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/GPL-CC-1.0.json", + "referenceNumber": "38", + "name": "GPL Cooperation Commitment 1.0", + "seeAlso": [ + "https://github.com/gplcc/gplcc/blob/master/Project/COMMITMENT", + "https://gplcc.github.io/gplcc/Project/README-PROJECT.html" + ], + "licenseExceptionId": "GPL-CC-1.0" + }, + { + "reference": "./Qt-LGPL-exception-1.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Qt-LGPL-exception-1.1.json", + "referenceNumber": "39", + "name": "Qt LGPL exception 1.1", + "seeAlso": [ + "http://code.qt.io/cgit/qt/qtbase.git/tree/LGPL_EXCEPTION.txt" + ], + "licenseExceptionId": "Qt-LGPL-exception-1.1" + }, + { + "reference": "./SHL-2.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/SHL-2.1.json", + "referenceNumber": "40", + "name": "Solderpad Hardware License v2.1", + "seeAlso": [ + "https://solderpad.org/licenses/SHL-2.1/" + ], + "licenseExceptionId": "SHL-2.1" + }, + { + "reference": "./Qt-GPL-exception-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Qt-GPL-exception-1.0.json", + "referenceNumber": "41", + "name": "Qt GPL exception 1.0", + "seeAlso": [ + "http://code.qt.io/cgit/qt/qtbase.git/tree/LICENSE.GPL3-EXCEPT" + ], + "licenseExceptionId": "Qt-GPL-exception-1.0" + } + ] +} diff --git a/cabal/license-list-data/exceptions-3.16.json b/cabal/license-list-data/exceptions-3.16.json new file mode 100644 --- /dev/null +++ b/cabal/license-list-data/exceptions-3.16.json @@ -0,0 +1,466 @@ +{ + "licenseListVersion": "3.16", + "exceptions": [ + { + "reference": "./freertos-exception-2.0.json", + "isDeprecatedLicenseId": false, + "detailsUrl": "./freertos-exception-2.0.html", + "referenceNumber": 1, + "name": "FreeRTOS Exception 2.0", + "licenseExceptionId": "freertos-exception-2.0", + "seeAlso": [ + "https://web.archive.org/web/20060809182744/http://www.freertos.org/a00114.html" + ] + }, + { + "reference": "./Swift-exception.json", + "isDeprecatedLicenseId": false, + "detailsUrl": "./Swift-exception.html", + "referenceNumber": 2, + "name": "Swift Exception", + "licenseExceptionId": "Swift-exception", + "seeAlso": [ + "https://swift.org/LICENSE.txt", + "https://github.com/apple/swift-package-manager/blob/7ab2275f447a5eb37497ed63a9340f8a6d1e488b/LICENSE.txt#L205" + ] + }, + { + "reference": "./Qt-LGPL-exception-1.1.json", + "isDeprecatedLicenseId": false, + "detailsUrl": "./Qt-LGPL-exception-1.1.html", + "referenceNumber": 3, + "name": "Qt LGPL exception 1.1", + "licenseExceptionId": "Qt-LGPL-exception-1.1", + "seeAlso": [ + "http://code.qt.io/cgit/qt/qtbase.git/tree/LGPL_EXCEPTION.txt" + ] + }, + { + "reference": "./gnu-javamail-exception.json", + "isDeprecatedLicenseId": false, + "detailsUrl": "./gnu-javamail-exception.html", + "referenceNumber": 4, + "name": "GNU JavaMail exception", + "licenseExceptionId": "gnu-javamail-exception", + "seeAlso": [ + "http://www.gnu.org/software/classpathx/javamail/javamail.html" + ] + }, + { + "reference": "./CLISP-exception-2.0.json", + "isDeprecatedLicenseId": false, + "detailsUrl": "./CLISP-exception-2.0.html", + "referenceNumber": 5, + "name": "CLISP exception 2.0", + "licenseExceptionId": "CLISP-exception-2.0", + "seeAlso": [ + "http://sourceforge.net/p/clisp/clisp/ci/default/tree/COPYRIGHT" + ] + }, + { + "reference": "./eCos-exception-2.0.json", + "isDeprecatedLicenseId": false, + "detailsUrl": "./eCos-exception-2.0.html", + "referenceNumber": 6, + "name": "eCos exception 2.0", + "licenseExceptionId": "eCos-exception-2.0", + "seeAlso": [ + "http://ecos.sourceware.org/license-overview.html" + ] + }, + { + "reference": "./GPL-CC-1.0.json", + "isDeprecatedLicenseId": false, + "detailsUrl": "./GPL-CC-1.0.html", + "referenceNumber": 7, + "name": "GPL Cooperation Commitment 1.0", + "licenseExceptionId": "GPL-CC-1.0", + "seeAlso": [ + "https://github.com/gplcc/gplcc/blob/master/Project/COMMITMENT", + "https://gplcc.github.io/gplcc/Project/README-PROJECT.html" + ] + }, + { + "reference": "./DigiRule-FOSS-exception.json", + "isDeprecatedLicenseId": false, + "detailsUrl": "./DigiRule-FOSS-exception.html", + "referenceNumber": 8, + "name": "DigiRule FOSS License Exception", + "licenseExceptionId": "DigiRule-FOSS-exception", + "seeAlso": [ + "http://www.digirulesolutions.com/drupal/foss" + ] + }, + { + "reference": "./Font-exception-2.0.json", + "isDeprecatedLicenseId": false, + "detailsUrl": "./Font-exception-2.0.html", + "referenceNumber": 9, + "name": "Font exception 2.0", + "licenseExceptionId": "Font-exception-2.0", + "seeAlso": [ + "http://www.gnu.org/licenses/gpl-faq.html#FontException" + ] + }, + { + "reference": "./Qt-GPL-exception-1.0.json", + "isDeprecatedLicenseId": false, + "detailsUrl": "./Qt-GPL-exception-1.0.html", + "referenceNumber": 10, + "name": "Qt GPL exception 1.0", + "licenseExceptionId": "Qt-GPL-exception-1.0", + "seeAlso": [ + "http://code.qt.io/cgit/qt/qtbase.git/tree/LICENSE.GPL3-EXCEPT" + ] + }, + { + "reference": "./PS-or-PDF-font-exception-20170817.json", + "isDeprecatedLicenseId": false, + "detailsUrl": "./PS-or-PDF-font-exception-20170817.html", + "referenceNumber": 11, + "name": "PS/PDF font exception (2017-08-17)", + "licenseExceptionId": "PS-or-PDF-font-exception-20170817", + "seeAlso": [ + "https://github.com/ArtifexSoftware/urw-base35-fonts/blob/65962e27febc3883a17e651cdb23e783668c996f/LICENSE" + ] + }, + { + "reference": "./GPL-3.0-linking-source-exception.json", + "isDeprecatedLicenseId": false, + "detailsUrl": "./GPL-3.0-linking-source-exception.html", + "referenceNumber": 12, + "name": "GPL-3.0 Linking Exception (with Corresponding Source)", + "licenseExceptionId": "GPL-3.0-linking-source-exception", + "seeAlso": [ + "https://www.gnu.org/licenses/gpl-faq.en.html#GPLIncompatibleLibs", + "https://github.com/mirror/wget/blob/master/src/http.c#L20" + ] + }, + { + "reference": "./Linux-syscall-note.json", + "isDeprecatedLicenseId": false, + "detailsUrl": "./Linux-syscall-note.html", + "referenceNumber": 13, + "name": "Linux Syscall Note", + "licenseExceptionId": "Linux-syscall-note", + "seeAlso": [ + "https://git.kernel.org/pub/scm/linux/kernel/git/torvalds/linux.git/tree/COPYING" + ] + }, + { + "reference": "./GCC-exception-2.0.json", + "isDeprecatedLicenseId": false, + "detailsUrl": "./GCC-exception-2.0.html", + "referenceNumber": 14, + "name": "GCC Runtime Library exception 2.0", + "licenseExceptionId": "GCC-exception-2.0", + "seeAlso": [ + "https://gcc.gnu.org/git/?p\u003dgcc.git;a\u003dblob;f\u003dgcc/libgcc1.c;h\u003d762f5143fc6eed57b6797c82710f3538aa52b40b;hb\u003dcb143a3ce4fb417c68f5fa2691a1b1b1053dfba9#l10" + ] + }, + { + "reference": "./LZMA-exception.json", + "isDeprecatedLicenseId": false, + "detailsUrl": "./LZMA-exception.html", + "referenceNumber": 15, + "name": "LZMA exception", + "licenseExceptionId": "LZMA-exception", + "seeAlso": [ + "http://nsis.sourceforge.net/Docs/AppendixI.html#I.6" + ] + }, + { + "reference": "./Autoconf-exception-3.0.json", + "isDeprecatedLicenseId": false, + "detailsUrl": "./Autoconf-exception-3.0.html", + "referenceNumber": 16, + "name": "Autoconf exception 3.0", + "licenseExceptionId": "Autoconf-exception-3.0", + "seeAlso": [ + "http://www.gnu.org/licenses/autoconf-exception-3.0.html" + ] + }, + { + "reference": "./u-boot-exception-2.0.json", + "isDeprecatedLicenseId": false, + "detailsUrl": "./u-boot-exception-2.0.html", + "referenceNumber": 17, + "name": "U-Boot exception 2.0", + "licenseExceptionId": "u-boot-exception-2.0", + "seeAlso": [ + "http://git.denx.de/?p\u003du-boot.git;a\u003dblob;f\u003dLicenses/Exceptions" + ] + }, + { + "reference": "./LLVM-exception.json", + "isDeprecatedLicenseId": false, + "detailsUrl": "./LLVM-exception.html", + "referenceNumber": 18, + "name": "LLVM Exception", + "licenseExceptionId": "LLVM-exception", + "seeAlso": [ + "http://llvm.org/foundation/relicensing/LICENSE.txt" + ] + }, + { + "reference": "./OCaml-LGPL-linking-exception.json", + "isDeprecatedLicenseId": false, + "detailsUrl": "./OCaml-LGPL-linking-exception.html", + "referenceNumber": 19, + "name": "OCaml LGPL Linking Exception", + "licenseExceptionId": "OCaml-LGPL-linking-exception", + "seeAlso": [ + "https://caml.inria.fr/ocaml/license.en.html" + ] + }, + { + "reference": "./Autoconf-exception-2.0.json", + "isDeprecatedLicenseId": false, + "detailsUrl": "./Autoconf-exception-2.0.html", + "referenceNumber": 20, + "name": "Autoconf exception 2.0", + "licenseExceptionId": "Autoconf-exception-2.0", + "seeAlso": [ + "http://ac-archive.sourceforge.net/doc/copyright.html", + "http://ftp.gnu.org/gnu/autoconf/autoconf-2.59.tar.gz" + ] + }, + { + "reference": "./Bootloader-exception.json", + "isDeprecatedLicenseId": false, + "detailsUrl": "./Bootloader-exception.html", + "referenceNumber": 21, + "name": "Bootloader Distribution Exception", + "licenseExceptionId": "Bootloader-exception", + "seeAlso": [ + "https://github.com/pyinstaller/pyinstaller/blob/develop/COPYING.txt" + ] + }, + { + "reference": "./LGPL-3.0-linking-exception.json", + "isDeprecatedLicenseId": false, + "detailsUrl": "./LGPL-3.0-linking-exception.html", + "referenceNumber": 22, + "name": "LGPL-3.0 Linking Exception", + "licenseExceptionId": "LGPL-3.0-linking-exception", + "seeAlso": [ + "https://raw.githubusercontent.com/go-xmlpath/xmlpath/v2/LICENSE", + "https://github.com/goamz/goamz/blob/master/LICENSE", + "https://github.com/juju/errors/blob/master/LICENSE" + ] + }, + { + "reference": "./openvpn-openssl-exception.json", + "isDeprecatedLicenseId": false, + "detailsUrl": "./openvpn-openssl-exception.html", + "referenceNumber": 23, + "name": "OpenVPN OpenSSL Exception", + "licenseExceptionId": "openvpn-openssl-exception", + "seeAlso": [ + "http://openvpn.net/index.php/license.html" + ] + }, + { + "reference": "./FLTK-exception.json", + "isDeprecatedLicenseId": false, + "detailsUrl": "./FLTK-exception.html", + "referenceNumber": 24, + "name": "FLTK exception", + "licenseExceptionId": "FLTK-exception", + "seeAlso": [ + "http://www.fltk.org/COPYING.php" + ] + }, + { + "reference": "./Bison-exception-2.2.json", + "isDeprecatedLicenseId": false, + "detailsUrl": "./Bison-exception-2.2.html", + "referenceNumber": 25, + "name": "Bison exception 2.2", + "licenseExceptionId": "Bison-exception-2.2", + "seeAlso": [ + "http://git.savannah.gnu.org/cgit/bison.git/tree/data/yacc.c?id\u003d193d7c7054ba7197b0789e14965b739162319b5e#n141" + ] + }, + { + "reference": "./OCCT-exception-1.0.json", + "isDeprecatedLicenseId": false, + "detailsUrl": "./OCCT-exception-1.0.html", + "referenceNumber": 26, + "name": "Open CASCADE Exception 1.0", + "licenseExceptionId": "OCCT-exception-1.0", + "seeAlso": [ + "http://www.opencascade.com/content/licensing" + ] + }, + { + "reference": "./GCC-exception-3.1.json", + "isDeprecatedLicenseId": false, + "detailsUrl": "./GCC-exception-3.1.html", + "referenceNumber": 27, + "name": "GCC Runtime Library exception 3.1", + "licenseExceptionId": "GCC-exception-3.1", + "seeAlso": [ + "http://www.gnu.org/licenses/gcc-exception-3.1.html" + ] + }, + { + "reference": "./OpenJDK-assembly-exception-1.0.json", + "isDeprecatedLicenseId": false, + "detailsUrl": "./OpenJDK-assembly-exception-1.0.html", + "referenceNumber": 28, + "name": "OpenJDK Assembly exception 1.0", + "licenseExceptionId": "OpenJDK-assembly-exception-1.0", + "seeAlso": [ + "http://openjdk.java.net/legal/assembly-exception.html" + ] + }, + { + "reference": "./WxWindows-exception-3.1.json", + "isDeprecatedLicenseId": false, + "detailsUrl": "./WxWindows-exception-3.1.html", + "referenceNumber": 29, + "name": "WxWindows Library Exception 3.1", + "licenseExceptionId": "WxWindows-exception-3.1", + "seeAlso": [ + "http://www.opensource.org/licenses/WXwindows" + ] + }, + { + "reference": "./Fawkes-Runtime-exception.json", + "isDeprecatedLicenseId": false, + "detailsUrl": "./Fawkes-Runtime-exception.html", + "referenceNumber": 30, + "name": "Fawkes Runtime Exception", + "licenseExceptionId": "Fawkes-Runtime-exception", + "seeAlso": [ + "http://www.fawkesrobotics.org/about/license/" + ] + }, + { + "reference": "./Nokia-Qt-exception-1.1.json", + "isDeprecatedLicenseId": true, + "detailsUrl": "./Nokia-Qt-exception-1.1.html", + "referenceNumber": 31, + "name": "Nokia Qt LGPL exception 1.1", + "licenseExceptionId": "Nokia-Qt-exception-1.1", + "seeAlso": [ + "https://www.keepassx.org/dev/projects/keepassx/repository/revisions/b8dfb9cc4d5133e0f09cd7533d15a4f1c19a40f2/entry/LICENSE.NOKIA-LGPL-EXCEPTION" + ] + }, + { + "reference": "./Qwt-exception-1.0.json", + "isDeprecatedLicenseId": false, + "detailsUrl": "./Qwt-exception-1.0.html", + "referenceNumber": 32, + "name": "Qwt exception 1.0", + "licenseExceptionId": "Qwt-exception-1.0", + "seeAlso": [ + "http://qwt.sourceforge.net/qwtlicense.html" + ] + }, + { + "reference": "./Universal-FOSS-exception-1.0.json", + "isDeprecatedLicenseId": false, + "detailsUrl": "./Universal-FOSS-exception-1.0.html", + "referenceNumber": 33, + "name": "Universal FOSS Exception, Version 1.0", + "licenseExceptionId": "Universal-FOSS-exception-1.0", + "seeAlso": [ + "https://oss.oracle.com/licenses/universal-foss-exception/" + ] + }, + { + "reference": "./Classpath-exception-2.0.json", + "isDeprecatedLicenseId": false, + "detailsUrl": "./Classpath-exception-2.0.html", + "referenceNumber": 34, + "name": "Classpath exception 2.0", + "licenseExceptionId": "Classpath-exception-2.0", + "seeAlso": [ + "http://www.gnu.org/software/classpath/license.html", + "https://fedoraproject.org/wiki/Licensing/GPL_Classpath_Exception" + ] + }, + { + "reference": "./SHL-2.0.json", + "isDeprecatedLicenseId": false, + "detailsUrl": "./SHL-2.0.html", + "referenceNumber": 35, + "name": "Solderpad Hardware License v2.0", + "licenseExceptionId": "SHL-2.0", + "seeAlso": [ + "https://solderpad.org/licenses/SHL-2.0/" + ] + }, + { + "reference": "./GPL-3.0-linking-exception.json", + "isDeprecatedLicenseId": false, + "detailsUrl": "./GPL-3.0-linking-exception.html", + "referenceNumber": 36, + "name": "GPL-3.0 Linking Exception", + "licenseExceptionId": "GPL-3.0-linking-exception", + "seeAlso": [ + "https://www.gnu.org/licenses/gpl-faq.en.html#GPLIncompatibleLibs" + ] + }, + { + "reference": "./SHL-2.1.json", + "isDeprecatedLicenseId": false, + "detailsUrl": "./SHL-2.1.html", + "referenceNumber": 37, + "name": "Solderpad Hardware License v2.1", + "licenseExceptionId": "SHL-2.1", + "seeAlso": [ + "https://solderpad.org/licenses/SHL-2.1/" + ] + }, + { + "reference": "./Libtool-exception.json", + "isDeprecatedLicenseId": false, + "detailsUrl": "./Libtool-exception.html", + "referenceNumber": 38, + "name": "Libtool Exception", + "licenseExceptionId": "Libtool-exception", + "seeAlso": [ + "http://git.savannah.gnu.org/cgit/libtool.git/tree/m4/libtool.m4" + ] + }, + { + "reference": "./mif-exception.json", + "isDeprecatedLicenseId": false, + "detailsUrl": "./mif-exception.html", + "referenceNumber": 39, + "name": "Macros and Inline Functions Exception", + "licenseExceptionId": "mif-exception", + "seeAlso": [ + "http://www.scs.stanford.edu/histar/src/lib/cppsup/exception", + "http://dev.bertos.org/doxygen/", + "https://www.threadingbuildingblocks.org/licensing" + ] + }, + { + "reference": "./389-exception.json", + "isDeprecatedLicenseId": false, + "detailsUrl": "./389-exception.html", + "referenceNumber": 40, + "name": "389 Directory Server Exception", + "licenseExceptionId": "389-exception", + "seeAlso": [ + "http://directory.fedoraproject.org/wiki/GPL_Exception_License_Text" + ] + }, + { + "reference": "./i2p-gpl-java-exception.json", + "isDeprecatedLicenseId": false, + "detailsUrl": "./i2p-gpl-java-exception.html", + "referenceNumber": 41, + "name": "i2p GPL+Java Exception", + "licenseExceptionId": "i2p-gpl-java-exception", + "seeAlso": [ + "http://geti2p.net/en/get-involved/develop/licenses#java_exception" + ] + } + ], + "releaseDate": "2022-02-06" +} diff --git a/cabal/license-list-data/licenses-3.10.json b/cabal/license-list-data/licenses-3.10.json new file mode 100644 --- /dev/null +++ b/cabal/license-list-data/licenses-3.10.json @@ -0,0 +1,5542 @@ +{ + "licenseListVersion": "3.10", + "licenses": [ + { + "reference": "./0BSD.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/0BSD.json", + "referenceNumber": "250", + "name": "BSD Zero Clause License", + "licenseId": "0BSD", + "seeAlso": [ + "http://landley.net/toybox/license.html" + ], + "isOsiApproved": true + }, + { + "reference": "./AAL.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/AAL.json", + "referenceNumber": "63", + "name": "Attribution Assurance License", + "licenseId": "AAL", + "seeAlso": [ + "https://opensource.org/licenses/attribution" + ], + "isOsiApproved": true + }, + { + "reference": "./ADSL.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/ADSL.json", + "referenceNumber": "227", + "name": "Amazon Digital Services License", + "licenseId": "ADSL", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/AmazonDigitalServicesLicense" + ], + "isOsiApproved": false + }, + { + "reference": "./AFL-1.1.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/AFL-1.1.json", + "referenceNumber": "29", + "name": "Academic Free License v1.1", + "licenseId": "AFL-1.1", + "seeAlso": [ + "http://opensource.linux-mirror.org/licenses/afl-1.1.txt", + "http://wayback.archive.org/web/20021004124254/http://www.opensource.org/licenses/academic.php" + ], + "isOsiApproved": true + }, + { + "reference": "./AFL-1.2.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/AFL-1.2.json", + "referenceNumber": "232", + "name": "Academic Free License v1.2", + "licenseId": "AFL-1.2", + "seeAlso": [ + "http://opensource.linux-mirror.org/licenses/afl-1.2.txt", + "http://wayback.archive.org/web/20021204204652/http://www.opensource.org/licenses/academic.php" + ], + "isOsiApproved": true + }, + { + "reference": "./AFL-2.0.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/AFL-2.0.json", + "referenceNumber": "358", + "name": "Academic Free License v2.0", + "licenseId": "AFL-2.0", + "seeAlso": [ + "http://wayback.archive.org/web/20060924134533/http://www.opensource.org/licenses/afl-2.0.txt" + ], + "isOsiApproved": true + }, + { + "reference": "./AFL-2.1.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/AFL-2.1.json", + "referenceNumber": "261", + "name": "Academic Free License v2.1", + "licenseId": "AFL-2.1", + "seeAlso": [ + "http://opensource.linux-mirror.org/licenses/afl-2.1.txt" + ], + "isOsiApproved": true + }, + { + "reference": "./AFL-3.0.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/AFL-3.0.json", + "referenceNumber": "380", + "name": "Academic Free License v3.0", + "licenseId": "AFL-3.0", + "seeAlso": [ + "http://www.rosenlaw.com/AFL3.0.htm", + "https://opensource.org/licenses/afl-3.0" + ], + "isOsiApproved": true + }, + { + "reference": "./AGPL-1.0.html", + "isDeprecatedLicenseId": true, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/AGPL-1.0.json", + "referenceNumber": "180", + "name": "Affero General Public License v1.0", + "licenseId": "AGPL-1.0", + "seeAlso": [ + "http://www.affero.org/oagpl.html" + ], + "isOsiApproved": false + }, + { + "reference": "./AGPL-1.0-only.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/AGPL-1.0-only.json", + "referenceNumber": "74", + "name": "Affero General Public License v1.0 only", + "licenseId": "AGPL-1.0-only", + "seeAlso": [ + "http://www.affero.org/oagpl.html" + ], + "isOsiApproved": false + }, + { + "reference": "./AGPL-1.0-or-later.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/AGPL-1.0-or-later.json", + "referenceNumber": "173", + "name": "Affero General Public License v1.0 or later", + "licenseId": "AGPL-1.0-or-later", + "seeAlso": [ + "http://www.affero.org/oagpl.html" + ], + "isOsiApproved": false + }, + { + "reference": "./AGPL-3.0.html", + "isDeprecatedLicenseId": true, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/AGPL-3.0.json", + "referenceNumber": "152", + "name": "GNU Affero General Public License v3.0", + "licenseId": "AGPL-3.0", + "seeAlso": [ + "https://www.gnu.org/licenses/agpl.txt", + "https://opensource.org/licenses/AGPL-3.0" + ], + "isOsiApproved": true + }, + { + "reference": "./AGPL-3.0-only.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/AGPL-3.0-only.json", + "referenceNumber": "312", + "name": "GNU Affero General Public License v3.0 only", + "licenseId": "AGPL-3.0-only", + "seeAlso": [ + "https://www.gnu.org/licenses/agpl.txt", + "https://opensource.org/licenses/AGPL-3.0" + ], + "isOsiApproved": true + }, + { + "reference": "./AGPL-3.0-or-later.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/AGPL-3.0-or-later.json", + "referenceNumber": "164", + "name": "GNU Affero General Public License v3.0 or later", + "licenseId": "AGPL-3.0-or-later", + "seeAlso": [ + "https://www.gnu.org/licenses/agpl.txt", + "https://opensource.org/licenses/AGPL-3.0" + ], + "isOsiApproved": true + }, + { + "reference": "./AMDPLPA.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/AMDPLPA.json", + "referenceNumber": "137", + "name": "AMD\u0027s plpa_map.c License", + "licenseId": "AMDPLPA", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/AMD_plpa_map_License" + ], + "isOsiApproved": false + }, + { + "reference": "./AML.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/AML.json", + "referenceNumber": "161", + "name": "Apple MIT License", + "licenseId": "AML", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Apple_MIT_License" + ], + "isOsiApproved": false + }, + { + "reference": "./AMPAS.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/AMPAS.json", + "referenceNumber": "140", + "name": "Academy of Motion Picture Arts and Sciences BSD", + "licenseId": "AMPAS", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/BSD#AMPASBSD" + ], + "isOsiApproved": false + }, + { + "reference": "./ANTLR-PD.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/ANTLR-PD.json", + "referenceNumber": "46", + "name": "ANTLR Software Rights Notice", + "licenseId": "ANTLR-PD", + "seeAlso": [ + "http://www.antlr2.org/license.html" + ], + "isOsiApproved": false + }, + { + "reference": "./APAFML.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/APAFML.json", + "referenceNumber": "260", + "name": "Adobe Postscript AFM License", + "licenseId": "APAFML", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/AdobePostscriptAFM" + ], + "isOsiApproved": false + }, + { + "reference": "./APL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/APL-1.0.json", + "referenceNumber": "290", + "name": "Adaptive Public License 1.0", + "licenseId": "APL-1.0", + "seeAlso": [ + "https://opensource.org/licenses/APL-1.0" + ], + "isOsiApproved": true + }, + { + "reference": "./APSL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/APSL-1.0.json", + "referenceNumber": "406", + "name": "Apple Public Source License 1.0", + "licenseId": "APSL-1.0", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Apple_Public_Source_License_1.0" + ], + "isOsiApproved": true + }, + { + "reference": "./APSL-1.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/APSL-1.1.json", + "referenceNumber": "355", + "name": "Apple Public Source License 1.1", + "licenseId": "APSL-1.1", + "seeAlso": [ + "http://www.opensource.apple.com/source/IOSerialFamily/IOSerialFamily-7/APPLE_LICENSE" + ], + "isOsiApproved": true + }, + { + "reference": "./APSL-1.2.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/APSL-1.2.json", + "referenceNumber": "211", + "name": "Apple Public Source License 1.2", + "licenseId": "APSL-1.2", + "seeAlso": [ + "http://www.samurajdata.se/opensource/mirror/licenses/apsl.php" + ], + "isOsiApproved": true + }, + { + "reference": "./APSL-2.0.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/APSL-2.0.json", + "referenceNumber": "145", + "name": "Apple Public Source License 2.0", + "licenseId": "APSL-2.0", + "seeAlso": [ + "http://www.opensource.apple.com/license/apsl/" + ], + "isOsiApproved": true + }, + { + "reference": "./Abstyles.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Abstyles.json", + "referenceNumber": "78", + "name": "Abstyles License", + "licenseId": "Abstyles", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Abstyles" + ], + "isOsiApproved": false + }, + { + "reference": "./Adobe-2006.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Adobe-2006.json", + "referenceNumber": "327", + "name": "Adobe Systems Incorporated Source Code License Agreement", + "licenseId": "Adobe-2006", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/AdobeLicense" + ], + "isOsiApproved": false + }, + { + "reference": "./Adobe-Glyph.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Adobe-Glyph.json", + "referenceNumber": "360", + "name": "Adobe Glyph List License", + "licenseId": "Adobe-Glyph", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/MIT#AdobeGlyph" + ], + "isOsiApproved": false + }, + { + "reference": "./Afmparse.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Afmparse.json", + "referenceNumber": "349", + "name": "Afmparse License", + "licenseId": "Afmparse", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Afmparse" + ], + "isOsiApproved": false + }, + { + "reference": "./Aladdin.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Aladdin.json", + "referenceNumber": "332", + "name": "Aladdin Free Public License", + "licenseId": "Aladdin", + "seeAlso": [ + "http://pages.cs.wisc.edu/~ghost/doc/AFPL/6.01/Public.htm" + ], + "isOsiApproved": false + }, + { + "reference": "./Apache-1.0.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/Apache-1.0.json", + "referenceNumber": "33", + "name": "Apache License 1.0", + "licenseId": "Apache-1.0", + "seeAlso": [ + "http://www.apache.org/licenses/LICENSE-1.0" + ], + "isOsiApproved": false + }, + { + "reference": "./Apache-1.1.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/Apache-1.1.json", + "referenceNumber": "286", + "name": "Apache License 1.1", + "licenseId": "Apache-1.1", + "seeAlso": [ + "http://apache.org/licenses/LICENSE-1.1", + "https://opensource.org/licenses/Apache-1.1" + ], + "isOsiApproved": true + }, + { + "reference": "./Apache-2.0.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/Apache-2.0.json", + "referenceNumber": "385", + "name": "Apache License 2.0", + "licenseId": "Apache-2.0", + "seeAlso": [ + "http://www.apache.org/licenses/LICENSE-2.0", + "https://opensource.org/licenses/Apache-2.0" + ], + "isOsiApproved": true + }, + { + "reference": "./Artistic-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Artistic-1.0.json", + "referenceNumber": "285", + "name": "Artistic License 1.0", + "licenseId": "Artistic-1.0", + "seeAlso": [ + "https://opensource.org/licenses/Artistic-1.0" + ], + "isOsiApproved": true + }, + { + "reference": "./Artistic-1.0-Perl.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Artistic-1.0-Perl.json", + "referenceNumber": "322", + "name": "Artistic License 1.0 (Perl)", + "licenseId": "Artistic-1.0-Perl", + "seeAlso": [ + "http://dev.perl.org/licenses/artistic.html" + ], + "isOsiApproved": true + }, + { + "reference": "./Artistic-1.0-cl8.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Artistic-1.0-cl8.json", + "referenceNumber": "240", + "name": "Artistic License 1.0 w/clause 8", + "licenseId": "Artistic-1.0-cl8", + "seeAlso": [ + "https://opensource.org/licenses/Artistic-1.0" + ], + "isOsiApproved": true + }, + { + "reference": "./Artistic-2.0.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/Artistic-2.0.json", + "referenceNumber": "81", + "name": "Artistic License 2.0", + "licenseId": "Artistic-2.0", + "seeAlso": [ + "http://www.perlfoundation.org/artistic_license_2_0", + "https://opensource.org/licenses/artistic-license-2.0" + ], + "isOsiApproved": true + }, + { + "reference": "./BSD-1-Clause.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/BSD-1-Clause.json", + "referenceNumber": "408", + "name": "BSD 1-Clause License", + "licenseId": "BSD-1-Clause", + "seeAlso": [ + "https://svnweb.freebsd.org/base/head/include/ifaddrs.h?revision\u003d326823" + ], + "isOsiApproved": true + }, + { + "reference": "./BSD-2-Clause.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/BSD-2-Clause.json", + "referenceNumber": "323", + "name": "BSD 2-Clause \"Simplified\" License", + "licenseId": "BSD-2-Clause", + "seeAlso": [ + "https://opensource.org/licenses/BSD-2-Clause" + ], + "isOsiApproved": true + }, + { + "reference": "./BSD-2-Clause-FreeBSD.html", + "isDeprecatedLicenseId": true, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/BSD-2-Clause-FreeBSD.json", + "referenceNumber": "294", + "name": "BSD 2-Clause FreeBSD License", + "licenseId": "BSD-2-Clause-FreeBSD", + "seeAlso": [ + "http://www.freebsd.org/copyright/freebsd-license.html" + ], + "isOsiApproved": false + }, + { + "reference": "./BSD-2-Clause-NetBSD.html", + "isDeprecatedLicenseId": true, + "detailsUrl": "http://spdx.org/licenses/BSD-2-Clause-NetBSD.json", + "referenceNumber": "193", + "name": "BSD 2-Clause NetBSD License", + "licenseId": "BSD-2-Clause-NetBSD", + "seeAlso": [ + "http://www.netbsd.org/about/redistribution.html#default" + ], + "isOsiApproved": false + }, + { + "reference": "./BSD-2-Clause-Patent.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/BSD-2-Clause-Patent.json", + "referenceNumber": "381", + "name": "BSD-2-Clause Plus Patent License", + "licenseId": "BSD-2-Clause-Patent", + "seeAlso": [ + "https://opensource.org/licenses/BSDplusPatent" + ], + "isOsiApproved": true + }, + { + "reference": "./BSD-2-Clause-Views.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/BSD-2-Clause-Views.json", + "referenceNumber": "291", + "name": "BSD 2-Clause with views sentence", + "licenseId": "BSD-2-Clause-Views", + "seeAlso": [ + "http://www.freebsd.org/copyright/freebsd-license.html", + "https://people.freebsd.org/~ivoras/wine/patch-wine-nvidia.sh", + "https://github.com/protegeproject/protege/blob/master/license.txt" + ], + "isOsiApproved": false + }, + { + "reference": "./BSD-3-Clause.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/BSD-3-Clause.json", + "referenceNumber": "212", + "name": "BSD 3-Clause \"New\" or \"Revised\" License", + "licenseId": "BSD-3-Clause", + "seeAlso": [ + "https://opensource.org/licenses/BSD-3-Clause" + ], + "isOsiApproved": true + }, + { + "reference": "./BSD-3-Clause-Attribution.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/BSD-3-Clause-Attribution.json", + "referenceNumber": "41", + "name": "BSD with attribution", + "licenseId": "BSD-3-Clause-Attribution", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/BSD_with_Attribution" + ], + "isOsiApproved": false + }, + { + "reference": "./BSD-3-Clause-Clear.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/BSD-3-Clause-Clear.json", + "referenceNumber": "92", + "name": "BSD 3-Clause Clear License", + "licenseId": "BSD-3-Clause-Clear", + "seeAlso": [ + "http://labs.metacarta.com/license-explanation.html#license" + ], + "isOsiApproved": false + }, + { + "reference": "./BSD-3-Clause-LBNL.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/BSD-3-Clause-LBNL.json", + "referenceNumber": "151", + "name": "Lawrence Berkeley National Labs BSD variant license", + "licenseId": "BSD-3-Clause-LBNL", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/LBNLBSD" + ], + "isOsiApproved": true + }, + { + "reference": "./BSD-3-Clause-No-Nuclear-License.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/BSD-3-Clause-No-Nuclear-License.json", + "referenceNumber": "65", + "name": "BSD 3-Clause No Nuclear License", + "licenseId": "BSD-3-Clause-No-Nuclear-License", + "seeAlso": [ + "http://download.oracle.com/otn-pub/java/licenses/bsd.txt?AuthParam\u003d1467140197_43d516ce1776bd08a58235a7785be1cc" + ], + "isOsiApproved": false + }, + { + "reference": "./BSD-3-Clause-No-Nuclear-License-2014.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/BSD-3-Clause-No-Nuclear-License-2014.json", + "referenceNumber": "359", + "name": "BSD 3-Clause No Nuclear License 2014", + "licenseId": "BSD-3-Clause-No-Nuclear-License-2014", + "seeAlso": [ + "https://java.net/projects/javaeetutorial/pages/BerkeleyLicense" + ], + "isOsiApproved": false + }, + { + "reference": "./BSD-3-Clause-No-Nuclear-Warranty.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/BSD-3-Clause-No-Nuclear-Warranty.json", + "referenceNumber": "121", + "name": "BSD 3-Clause No Nuclear Warranty", + "licenseId": "BSD-3-Clause-No-Nuclear-Warranty", + "seeAlso": [ + "https://jogamp.org/git/?p\u003dgluegen.git;a\u003dblob_plain;f\u003dLICENSE.txt" + ], + "isOsiApproved": false + }, + { + "reference": "./BSD-3-Clause-Open-MPI.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/BSD-3-Clause-Open-MPI.json", + "referenceNumber": "224", + "name": "BSD 3-Clause Open MPI variant", + "licenseId": "BSD-3-Clause-Open-MPI", + "seeAlso": [ + "https://www.open-mpi.org/community/license.php", + "http://www.netlib.org/lapack/LICENSE.txt" + ], + "isOsiApproved": false + }, + { + "reference": "./BSD-4-Clause.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/BSD-4-Clause.json", + "referenceNumber": "72", + "name": "BSD 4-Clause \"Original\" or \"Old\" License", + "licenseId": "BSD-4-Clause", + "seeAlso": [ + "http://directory.fsf.org/wiki/License:BSD_4Clause" + ], + "isOsiApproved": false + }, + { + "reference": "./BSD-4-Clause-UC.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/BSD-4-Clause-UC.json", + "referenceNumber": "391", + "name": "BSD-4-Clause (University of California-Specific)", + "licenseId": "BSD-4-Clause-UC", + "seeAlso": [ + "http://www.freebsd.org/copyright/license.html" + ], + "isOsiApproved": false + }, + { + "reference": "./BSD-Protection.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/BSD-Protection.json", + "referenceNumber": "419", + "name": "BSD Protection License", + "licenseId": "BSD-Protection", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/BSD_Protection_License" + ], + "isOsiApproved": false + }, + { + "reference": "./BSD-Source-Code.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/BSD-Source-Code.json", + "referenceNumber": "174", + "name": "BSD Source Code Attribution", + "licenseId": "BSD-Source-Code", + "seeAlso": [ + "https://github.com/robbiehanson/CocoaHTTPServer/blob/master/LICENSE.txt" + ], + "isOsiApproved": false + }, + { + "reference": "./BSL-1.0.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/BSL-1.0.json", + "referenceNumber": "309", + "name": "Boost Software License 1.0", + "licenseId": "BSL-1.0", + "seeAlso": [ + "http://www.boost.org/LICENSE_1_0.txt", + "https://opensource.org/licenses/BSL-1.0" + ], + "isOsiApproved": true + }, + { + "reference": "./Bahyph.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Bahyph.json", + "referenceNumber": "155", + "name": "Bahyph License", + "licenseId": "Bahyph", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Bahyph" + ], + "isOsiApproved": false + }, + { + "reference": "./Barr.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Barr.json", + "referenceNumber": "132", + "name": "Barr License", + "licenseId": "Barr", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Barr" + ], + "isOsiApproved": false + }, + { + "reference": "./Beerware.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Beerware.json", + "referenceNumber": "263", + "name": "Beerware License", + "licenseId": "Beerware", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Beerware", + "https://people.freebsd.org/~phk/" + ], + "isOsiApproved": false + }, + { + "reference": "./BitTorrent-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/BitTorrent-1.0.json", + "referenceNumber": "217", + "name": "BitTorrent Open Source License v1.0", + "licenseId": "BitTorrent-1.0", + "seeAlso": [ + "http://sources.gentoo.org/cgi-bin/viewvc.cgi/gentoo-x86/licenses/BitTorrent?r1\u003d1.1\u0026r2\u003d1.1.1.1\u0026diff_format\u003ds" + ], + "isOsiApproved": false + }, + { + "reference": "./BitTorrent-1.1.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/BitTorrent-1.1.json", + "referenceNumber": "196", + "name": "BitTorrent Open Source License v1.1", + "licenseId": "BitTorrent-1.1", + "seeAlso": [ + "http://directory.fsf.org/wiki/License:BitTorrentOSL1.1" + ], + "isOsiApproved": false + }, + { + "reference": "./BlueOak-1.0.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/BlueOak-1.0.0.json", + "referenceNumber": "221", + "name": "Blue Oak Model License 1.0.0", + "licenseId": "BlueOak-1.0.0", + "seeAlso": [ + "https://blueoakcouncil.org/license/1.0.0" + ], + "isOsiApproved": false + }, + { + "reference": "./Borceux.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Borceux.json", + "referenceNumber": "321", + "name": "Borceux license", + "licenseId": "Borceux", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Borceux" + ], + "isOsiApproved": false + }, + { + "reference": "./CAL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/CAL-1.0.json", + "referenceNumber": "62", + "name": "Cryptographic Autonomy License 1.0", + "licenseId": "CAL-1.0", + "seeAlso": [ + "http://cryptographicautonomylicense.com/license-text.html", + "https://opensource.org/licenses/CAL-1.0" + ], + "isOsiApproved": true + }, + { + "reference": "./CAL-1.0-Combined-Work-Exception.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/CAL-1.0-Combined-Work-Exception.json", + "referenceNumber": "83", + "name": "Cryptographic Autonomy License 1.0 (Combined Work Exception)", + "licenseId": "CAL-1.0-Combined-Work-Exception", + "seeAlso": [ + "http://cryptographicautonomylicense.com/license-text.html", + "https://opensource.org/licenses/CAL-1.0" + ], + "isOsiApproved": true + }, + { + "reference": "./CATOSL-1.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/CATOSL-1.1.json", + "referenceNumber": "245", + "name": "Computer Associates Trusted Open Source License 1.1", + "licenseId": "CATOSL-1.1", + "seeAlso": [ + "https://opensource.org/licenses/CATOSL-1.1" + ], + "isOsiApproved": true + }, + { + "reference": "./CC-BY-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/CC-BY-1.0.json", + "referenceNumber": "24", + "name": "Creative Commons Attribution 1.0 Generic", + "licenseId": "CC-BY-1.0", + "seeAlso": [ + "https://creativecommons.org/licenses/by/1.0/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "./CC-BY-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/CC-BY-2.0.json", + "referenceNumber": "64", + "name": "Creative Commons Attribution 2.0 Generic", + "licenseId": "CC-BY-2.0", + "seeAlso": [ + "https://creativecommons.org/licenses/by/2.0/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "./CC-BY-2.5.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/CC-BY-2.5.json", + "referenceNumber": "194", + "name": "Creative Commons Attribution 2.5 Generic", + "licenseId": "CC-BY-2.5", + "seeAlso": [ + "https://creativecommons.org/licenses/by/2.5/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "./CC-BY-3.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/CC-BY-3.0.json", + "referenceNumber": "361", + "name": "Creative Commons Attribution 3.0 Unported", + "licenseId": "CC-BY-3.0", + "seeAlso": [ + "https://creativecommons.org/licenses/by/3.0/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "./CC-BY-3.0-AT.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/CC-BY-3.0-AT.json", + "referenceNumber": "237", + "name": "Creative Commons Attribution 3.0 Austria", + "licenseId": "CC-BY-3.0-AT", + "seeAlso": [ + "https://creativecommons.org/licenses/by/3.0/at/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "./CC-BY-4.0.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/CC-BY-4.0.json", + "referenceNumber": "228", + "name": "Creative Commons Attribution 4.0 International", + "licenseId": "CC-BY-4.0", + "seeAlso": [ + "https://creativecommons.org/licenses/by/4.0/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "./CC-BY-NC-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/CC-BY-NC-1.0.json", + "referenceNumber": "242", + "name": "Creative Commons Attribution Non Commercial 1.0 Generic", + "licenseId": "CC-BY-NC-1.0", + "seeAlso": [ + "https://creativecommons.org/licenses/by-nc/1.0/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "./CC-BY-NC-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/CC-BY-NC-2.0.json", + "referenceNumber": "343", + "name": "Creative Commons Attribution Non Commercial 2.0 Generic", + "licenseId": "CC-BY-NC-2.0", + "seeAlso": [ + "https://creativecommons.org/licenses/by-nc/2.0/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "./CC-BY-NC-2.5.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/CC-BY-NC-2.5.json", + "referenceNumber": "417", + "name": "Creative Commons Attribution Non Commercial 2.5 Generic", + "licenseId": "CC-BY-NC-2.5", + "seeAlso": [ + "https://creativecommons.org/licenses/by-nc/2.5/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "./CC-BY-NC-3.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/CC-BY-NC-3.0.json", + "referenceNumber": "353", + "name": "Creative Commons Attribution Non Commercial 3.0 Unported", + "licenseId": "CC-BY-NC-3.0", + "seeAlso": [ + "https://creativecommons.org/licenses/by-nc/3.0/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "./CC-BY-NC-4.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/CC-BY-NC-4.0.json", + "referenceNumber": "284", + "name": "Creative Commons Attribution Non Commercial 4.0 International", + "licenseId": "CC-BY-NC-4.0", + "seeAlso": [ + "https://creativecommons.org/licenses/by-nc/4.0/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "./CC-BY-NC-ND-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/CC-BY-NC-ND-1.0.json", + "referenceNumber": "106", + "name": "Creative Commons Attribution Non Commercial No Derivatives 1.0 Generic", + "licenseId": "CC-BY-NC-ND-1.0", + "seeAlso": [ + "https://creativecommons.org/licenses/by-nd-nc/1.0/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "./CC-BY-NC-ND-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/CC-BY-NC-ND-2.0.json", + "referenceNumber": "142", + "name": "Creative Commons Attribution Non Commercial No Derivatives 2.0 Generic", + "licenseId": "CC-BY-NC-ND-2.0", + "seeAlso": [ + "https://creativecommons.org/licenses/by-nc-nd/2.0/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "./CC-BY-NC-ND-2.5.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/CC-BY-NC-ND-2.5.json", + "referenceNumber": "31", + "name": "Creative Commons Attribution Non Commercial No Derivatives 2.5 Generic", + "licenseId": "CC-BY-NC-ND-2.5", + "seeAlso": [ + "https://creativecommons.org/licenses/by-nc-nd/2.5/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "./CC-BY-NC-ND-3.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/CC-BY-NC-ND-3.0.json", + "referenceNumber": "43", + "name": "Creative Commons Attribution Non Commercial No Derivatives 3.0 Unported", + "licenseId": "CC-BY-NC-ND-3.0", + "seeAlso": [ + "https://creativecommons.org/licenses/by-nc-nd/3.0/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "./CC-BY-NC-ND-3.0-IGO.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/CC-BY-NC-ND-3.0-IGO.json", + "referenceNumber": "366", + "name": "Creative Commons Attribution Non Commercial No Derivatives 3.0 IGO", + "licenseId": "CC-BY-NC-ND-3.0-IGO", + "seeAlso": [ + "https://creativecommons.org/licenses/by-nc-nd/3.0/igo/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "./CC-BY-NC-ND-4.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/CC-BY-NC-ND-4.0.json", + "referenceNumber": "177", + "name": "Creative Commons Attribution Non Commercial No Derivatives 4.0 International", + "licenseId": "CC-BY-NC-ND-4.0", + "seeAlso": [ + "https://creativecommons.org/licenses/by-nc-nd/4.0/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "./CC-BY-NC-SA-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/CC-BY-NC-SA-1.0.json", + "referenceNumber": "124", + "name": "Creative Commons Attribution Non Commercial Share Alike 1.0 Generic", + "licenseId": "CC-BY-NC-SA-1.0", + "seeAlso": [ + "https://creativecommons.org/licenses/by-nc-sa/1.0/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "./CC-BY-NC-SA-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/CC-BY-NC-SA-2.0.json", + "referenceNumber": "431", + "name": "Creative Commons Attribution Non Commercial Share Alike 2.0 Generic", + "licenseId": "CC-BY-NC-SA-2.0", + "seeAlso": [ + "https://creativecommons.org/licenses/by-nc-sa/2.0/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "./CC-BY-NC-SA-2.5.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/CC-BY-NC-SA-2.5.json", + "referenceNumber": "225", + "name": "Creative Commons Attribution Non Commercial Share Alike 2.5 Generic", + "licenseId": "CC-BY-NC-SA-2.5", + "seeAlso": [ + "https://creativecommons.org/licenses/by-nc-sa/2.5/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "./CC-BY-NC-SA-3.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/CC-BY-NC-SA-3.0.json", + "referenceNumber": "379", + "name": "Creative Commons Attribution Non Commercial Share Alike 3.0 Unported", + "licenseId": "CC-BY-NC-SA-3.0", + "seeAlso": [ + "https://creativecommons.org/licenses/by-nc-sa/3.0/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "./CC-BY-NC-SA-4.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/CC-BY-NC-SA-4.0.json", + "referenceNumber": "348", + "name": "Creative Commons Attribution Non Commercial Share Alike 4.0 International", + "licenseId": "CC-BY-NC-SA-4.0", + "seeAlso": [ + "https://creativecommons.org/licenses/by-nc-sa/4.0/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "./CC-BY-ND-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/CC-BY-ND-1.0.json", + "referenceNumber": "98", + "name": "Creative Commons Attribution No Derivatives 1.0 Generic", + "licenseId": "CC-BY-ND-1.0", + "seeAlso": [ + "https://creativecommons.org/licenses/by-nd/1.0/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "./CC-BY-ND-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/CC-BY-ND-2.0.json", + "referenceNumber": "48", + "name": "Creative Commons Attribution No Derivatives 2.0 Generic", + "licenseId": "CC-BY-ND-2.0", + "seeAlso": [ + "https://creativecommons.org/licenses/by-nd/2.0/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "./CC-BY-ND-2.5.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/CC-BY-ND-2.5.json", + "referenceNumber": "28", + "name": "Creative Commons Attribution No Derivatives 2.5 Generic", + "licenseId": "CC-BY-ND-2.5", + "seeAlso": [ + "https://creativecommons.org/licenses/by-nd/2.5/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "./CC-BY-ND-3.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/CC-BY-ND-3.0.json", + "referenceNumber": "297", + "name": "Creative Commons Attribution No Derivatives 3.0 Unported", + "licenseId": "CC-BY-ND-3.0", + "seeAlso": [ + "https://creativecommons.org/licenses/by-nd/3.0/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "./CC-BY-ND-4.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/CC-BY-ND-4.0.json", + "referenceNumber": "335", + "name": "Creative Commons Attribution No Derivatives 4.0 International", + "licenseId": "CC-BY-ND-4.0", + "seeAlso": [ + "https://creativecommons.org/licenses/by-nd/4.0/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "./CC-BY-SA-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/CC-BY-SA-1.0.json", + "referenceNumber": "422", + "name": "Creative Commons Attribution Share Alike 1.0 Generic", + "licenseId": "CC-BY-SA-1.0", + "seeAlso": [ + "https://creativecommons.org/licenses/by-sa/1.0/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "./CC-BY-SA-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/CC-BY-SA-2.0.json", + "referenceNumber": "386", + "name": "Creative Commons Attribution Share Alike 2.0 Generic", + "licenseId": "CC-BY-SA-2.0", + "seeAlso": [ + "https://creativecommons.org/licenses/by-sa/2.0/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "./CC-BY-SA-2.5.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/CC-BY-SA-2.5.json", + "referenceNumber": "213", + "name": "Creative Commons Attribution Share Alike 2.5 Generic", + "licenseId": "CC-BY-SA-2.5", + "seeAlso": [ + "https://creativecommons.org/licenses/by-sa/2.5/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "./CC-BY-SA-3.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/CC-BY-SA-3.0.json", + "referenceNumber": "244", + "name": "Creative Commons Attribution Share Alike 3.0 Unported", + "licenseId": "CC-BY-SA-3.0", + "seeAlso": [ + "https://creativecommons.org/licenses/by-sa/3.0/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "./CC-BY-SA-3.0-AT.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/CC-BY-SA-3.0-AT.json", + "referenceNumber": "305", + "name": "Creative Commons Attribution-Share Alike 3.0 Austria", + "licenseId": "CC-BY-SA-3.0-AT", + "seeAlso": [ + "https://creativecommons.org/licenses/by-sa/3.0/at/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "./CC-BY-SA-4.0.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/CC-BY-SA-4.0.json", + "referenceNumber": "311", + "name": "Creative Commons Attribution Share Alike 4.0 International", + "licenseId": "CC-BY-SA-4.0", + "seeAlso": [ + "https://creativecommons.org/licenses/by-sa/4.0/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "./CC-PDDC.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/CC-PDDC.json", + "referenceNumber": "96", + "name": "Creative Commons Public Domain Dedication and Certification", + "licenseId": "CC-PDDC", + "seeAlso": [ + "https://creativecommons.org/licenses/publicdomain/" + ], + "isOsiApproved": false + }, + { + "reference": "./CC0-1.0.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/CC0-1.0.json", + "referenceNumber": "69", + "name": "Creative Commons Zero v1.0 Universal", + "licenseId": "CC0-1.0", + "seeAlso": [ + "https://creativecommons.org/publicdomain/zero/1.0/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "./CDDL-1.0.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/CDDL-1.0.json", + "referenceNumber": "352", + "name": "Common Development and Distribution License 1.0", + "licenseId": "CDDL-1.0", + "seeAlso": [ + "https://opensource.org/licenses/cddl1" + ], + "isOsiApproved": true + }, + { + "reference": "./CDDL-1.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/CDDL-1.1.json", + "referenceNumber": "296", + "name": "Common Development and Distribution License 1.1", + "licenseId": "CDDL-1.1", + "seeAlso": [ + "http://glassfish.java.net/public/CDDL+GPL_1_1.html", + "https://javaee.github.io/glassfish/LICENSE" + ], + "isOsiApproved": false + }, + { + "reference": "./CDLA-Permissive-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/CDLA-Permissive-1.0.json", + "referenceNumber": "112", + "name": "Community Data License Agreement Permissive 1.0", + "licenseId": "CDLA-Permissive-1.0", + "seeAlso": [ + "https://cdla.io/permissive-1-0" + ], + "isOsiApproved": false + }, + { + "reference": "./CDLA-Sharing-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/CDLA-Sharing-1.0.json", + "referenceNumber": "184", + "name": "Community Data License Agreement Sharing 1.0", + "licenseId": "CDLA-Sharing-1.0", + "seeAlso": [ + "https://cdla.io/sharing-1-0" + ], + "isOsiApproved": false + }, + { + "reference": "./CECILL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/CECILL-1.0.json", + "referenceNumber": "11", + "name": "CeCILL Free Software License Agreement v1.0", + "licenseId": "CECILL-1.0", + "seeAlso": [ + "http://www.cecill.info/licences/Licence_CeCILL_V1-fr.html" + ], + "isOsiApproved": false + }, + { + "reference": "./CECILL-1.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/CECILL-1.1.json", + "referenceNumber": "139", + "name": "CeCILL Free Software License Agreement v1.1", + "licenseId": "CECILL-1.1", + "seeAlso": [ + "http://www.cecill.info/licences/Licence_CeCILL_V1.1-US.html" + ], + "isOsiApproved": false + }, + { + "reference": "./CECILL-2.0.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/CECILL-2.0.json", + "referenceNumber": "5", + "name": "CeCILL Free Software License Agreement v2.0", + "licenseId": "CECILL-2.0", + "seeAlso": [ + "http://www.cecill.info/licences/Licence_CeCILL_V2-en.html" + ], + "isOsiApproved": false + }, + { + "reference": "./CECILL-2.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/CECILL-2.1.json", + "referenceNumber": "149", + "name": "CeCILL Free Software License Agreement v2.1", + "licenseId": "CECILL-2.1", + "seeAlso": [ + "http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.html" + ], + "isOsiApproved": true + }, + { + "reference": "./CECILL-B.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/CECILL-B.json", + "referenceNumber": "97", + "name": "CeCILL-B Free Software License Agreement", + "licenseId": "CECILL-B", + "seeAlso": [ + "http://www.cecill.info/licences/Licence_CeCILL-B_V1-en.html" + ], + "isOsiApproved": false + }, + { + "reference": "./CECILL-C.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/CECILL-C.json", + "referenceNumber": "251", + "name": "CeCILL-C Free Software License Agreement", + "licenseId": "CECILL-C", + "seeAlso": [ + "http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html" + ], + "isOsiApproved": false + }, + { + "reference": "./CERN-OHL-1.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/CERN-OHL-1.1.json", + "referenceNumber": "127", + "name": "CERN Open Hardware Licence v1.1", + "licenseId": "CERN-OHL-1.1", + "seeAlso": [ + "https://www.ohwr.org/project/licenses/wikis/cern-ohl-v1.1" + ], + "isOsiApproved": false + }, + { + "reference": "./CERN-OHL-1.2.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/CERN-OHL-1.2.json", + "referenceNumber": "172", + "name": "CERN Open Hardware Licence v1.2", + "licenseId": "CERN-OHL-1.2", + "seeAlso": [ + "https://www.ohwr.org/project/licenses/wikis/cern-ohl-v1.2" + ], + "isOsiApproved": false + }, + { + "reference": "./CERN-OHL-P-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/CERN-OHL-P-2.0.json", + "referenceNumber": "267", + "name": "CERN Open Hardware Licence Version 2 - Permissive", + "licenseId": "CERN-OHL-P-2.0", + "seeAlso": [ + "https://www.ohwr.org/project/cernohl/wikis/Documents/CERN-OHL-version-2" + ], + "isOsiApproved": false + }, + { + "reference": "./CERN-OHL-S-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/CERN-OHL-S-2.0.json", + "referenceNumber": "49", + "name": "CERN Open Hardware Licence Version 2 - Strongly Reciprocal", + "licenseId": "CERN-OHL-S-2.0", + "seeAlso": [ + "https://www.ohwr.org/project/cernohl/wikis/Documents/CERN-OHL-version-2" + ], + "isOsiApproved": false + }, + { + "reference": "./CERN-OHL-W-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/CERN-OHL-W-2.0.json", + "referenceNumber": "279", + "name": "CERN Open Hardware Licence Version 2 - Weakly Reciprocal", + "licenseId": "CERN-OHL-W-2.0", + "seeAlso": [ + "https://www.ohwr.org/project/cernohl/wikis/Documents/CERN-OHL-version-2" + ], + "isOsiApproved": false + }, + { + "reference": "./CNRI-Jython.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/CNRI-Jython.json", + "referenceNumber": "80", + "name": "CNRI Jython License", + "licenseId": "CNRI-Jython", + "seeAlso": [ + "http://www.jython.org/license.html" + ], + "isOsiApproved": false + }, + { + "reference": "./CNRI-Python.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/CNRI-Python.json", + "referenceNumber": "100", + "name": "CNRI Python License", + "licenseId": "CNRI-Python", + "seeAlso": [ + "https://opensource.org/licenses/CNRI-Python" + ], + "isOsiApproved": true + }, + { + "reference": "./CNRI-Python-GPL-Compatible.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/CNRI-Python-GPL-Compatible.json", + "referenceNumber": "365", + "name": "CNRI Python Open Source GPL Compatible License Agreement", + "licenseId": "CNRI-Python-GPL-Compatible", + "seeAlso": [ + "http://www.python.org/download/releases/1.6.1/download_win/" + ], + "isOsiApproved": false + }, + { + "reference": "./CPAL-1.0.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/CPAL-1.0.json", + "referenceNumber": "298", + "name": "Common Public Attribution License 1.0", + "licenseId": "CPAL-1.0", + "seeAlso": [ + "https://opensource.org/licenses/CPAL-1.0" + ], + "isOsiApproved": true + }, + { + "reference": "./CPL-1.0.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/CPL-1.0.json", + "referenceNumber": "247", + "name": "Common Public License 1.0", + "licenseId": "CPL-1.0", + "seeAlso": [ + "https://opensource.org/licenses/CPL-1.0" + ], + "isOsiApproved": true + }, + { + "reference": "./CPOL-1.02.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/CPOL-1.02.json", + "referenceNumber": "241", + "name": "Code Project Open License 1.02", + "licenseId": "CPOL-1.02", + "seeAlso": [ + "http://www.codeproject.com/info/cpol10.aspx" + ], + "isOsiApproved": false + }, + { + "reference": "./CUA-OPL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/CUA-OPL-1.0.json", + "referenceNumber": "170", + "name": "CUA Office Public License v1.0", + "licenseId": "CUA-OPL-1.0", + "seeAlso": [ + "https://opensource.org/licenses/CUA-OPL-1.0" + ], + "isOsiApproved": true + }, + { + "reference": "./Caldera.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Caldera.json", + "referenceNumber": "262", + "name": "Caldera License", + "licenseId": "Caldera", + "seeAlso": [ + "http://www.lemis.com/grog/UNIX/ancient-source-all.pdf" + ], + "isOsiApproved": false + }, + { + "reference": "./ClArtistic.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/ClArtistic.json", + "referenceNumber": "257", + "name": "Clarified Artistic License", + "licenseId": "ClArtistic", + "seeAlso": [ + "http://gianluca.dellavedova.org/2011/01/03/clarified-artistic-license/", + "http://www.ncftp.com/ncftp/doc/LICENSE.txt" + ], + "isOsiApproved": false + }, + { + "reference": "./Condor-1.1.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/Condor-1.1.json", + "referenceNumber": "154", + "name": "Condor Public License v1.1", + "licenseId": "Condor-1.1", + "seeAlso": [ + "http://research.cs.wisc.edu/condor/license.html#condor", + "http://web.archive.org/web/20111123062036/http://research.cs.wisc.edu/condor/license.html#condor" + ], + "isOsiApproved": false + }, + { + "reference": "./Crossword.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Crossword.json", + "referenceNumber": "105", + "name": "Crossword License", + "licenseId": "Crossword", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Crossword" + ], + "isOsiApproved": false + }, + { + "reference": "./CrystalStacker.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/CrystalStacker.json", + "referenceNumber": "40", + "name": "CrystalStacker License", + "licenseId": "CrystalStacker", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing:CrystalStacker?rd\u003dLicensing/CrystalStacker" + ], + "isOsiApproved": false + }, + { + "reference": "./Cube.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Cube.json", + "referenceNumber": "410", + "name": "Cube License", + "licenseId": "Cube", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Cube" + ], + "isOsiApproved": false + }, + { + "reference": "./D-FSL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/D-FSL-1.0.json", + "referenceNumber": "376", + "name": "Deutsche Freie Software Lizenz", + "licenseId": "D-FSL-1.0", + "seeAlso": [ + "http://www.dipp.nrw.de/d-fsl/lizenzen/", + "http://www.dipp.nrw.de/d-fsl/index_html/lizenzen/de/D-FSL-1_0_de.txt", + "http://www.dipp.nrw.de/d-fsl/index_html/lizenzen/en/D-FSL-1_0_en.txt", + "https://www.hbz-nrw.de/produkte/open-access/lizenzen/dfsl", + "https://www.hbz-nrw.de/produkte/open-access/lizenzen/dfsl/deutsche-freie-software-lizenz", + "https://www.hbz-nrw.de/produkte/open-access/lizenzen/dfsl/german-free-software-license", + "https://www.hbz-nrw.de/produkte/open-access/lizenzen/dfsl/D-FSL-1_0_de.txt/at_download/file", + "https://www.hbz-nrw.de/produkte/open-access/lizenzen/dfsl/D-FSL-1_0_en.txt/at_download/file" + ], + "isOsiApproved": false + }, + { + "reference": "./DOC.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/DOC.json", + "referenceNumber": "287", + "name": "DOC License", + "licenseId": "DOC", + "seeAlso": [ + "http://www.cs.wustl.edu/~schmidt/ACE-copying.html" + ], + "isOsiApproved": false + }, + { + "reference": "./DSDP.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/DSDP.json", + "referenceNumber": "278", + "name": "DSDP License", + "licenseId": "DSDP", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/DSDP" + ], + "isOsiApproved": false + }, + { + "reference": "./Dotseqn.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Dotseqn.json", + "referenceNumber": "34", + "name": "Dotseqn License", + "licenseId": "Dotseqn", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Dotseqn" + ], + "isOsiApproved": false + }, + { + "reference": "./ECL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/ECL-1.0.json", + "referenceNumber": "438", + "name": "Educational Community License v1.0", + "licenseId": "ECL-1.0", + "seeAlso": [ + "https://opensource.org/licenses/ECL-1.0" + ], + "isOsiApproved": true + }, + { + "reference": "./ECL-2.0.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/ECL-2.0.json", + "referenceNumber": "1", + "name": "Educational Community License v2.0", + "licenseId": "ECL-2.0", + "seeAlso": [ + "https://opensource.org/licenses/ECL-2.0" + ], + "isOsiApproved": true + }, + { + "reference": "./EFL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/EFL-1.0.json", + "referenceNumber": "79", + "name": "Eiffel Forum License v1.0", + "licenseId": "EFL-1.0", + "seeAlso": [ + "http://www.eiffel-nice.org/license/forum.txt", + "https://opensource.org/licenses/EFL-1.0" + ], + "isOsiApproved": true + }, + { + "reference": "./EFL-2.0.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/EFL-2.0.json", + "referenceNumber": "8", + "name": "Eiffel Forum License v2.0", + "licenseId": "EFL-2.0", + "seeAlso": [ + "http://www.eiffel-nice.org/license/eiffel-forum-license-2.html", + "https://opensource.org/licenses/EFL-2.0" + ], + "isOsiApproved": true + }, + { + "reference": "./EPICS.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/EPICS.json", + "referenceNumber": "377", + "name": "EPICS Open License", + "licenseId": "EPICS", + "seeAlso": [ + "https://epics.anl.gov/license/open.php" + ], + "isOsiApproved": false + }, + { + "reference": "./EPL-1.0.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/EPL-1.0.json", + "referenceNumber": "289", + "name": "Eclipse Public License 1.0", + "licenseId": "EPL-1.0", + "seeAlso": [ + "http://www.eclipse.org/legal/epl-v10.html", + "https://opensource.org/licenses/EPL-1.0" + ], + "isOsiApproved": true + }, + { + "reference": "./EPL-2.0.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/EPL-2.0.json", + "referenceNumber": "436", + "name": "Eclipse Public License 2.0", + "licenseId": "EPL-2.0", + "seeAlso": [ + "https://www.eclipse.org/legal/epl-2.0", + "https://www.opensource.org/licenses/EPL-2.0" + ], + "isOsiApproved": true + }, + { + "reference": "./EUDatagrid.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/EUDatagrid.json", + "referenceNumber": "275", + "name": "EU DataGrid Software License", + "licenseId": "EUDatagrid", + "seeAlso": [ + "http://eu-datagrid.web.cern.ch/eu-datagrid/license.html", + "https://opensource.org/licenses/EUDatagrid" + ], + "isOsiApproved": true + }, + { + "reference": "./EUPL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/EUPL-1.0.json", + "referenceNumber": "102", + "name": "European Union Public License 1.0", + "licenseId": "EUPL-1.0", + "seeAlso": [ + "http://ec.europa.eu/idabc/en/document/7330.html", + "http://ec.europa.eu/idabc/servlets/Doc027f.pdf?id\u003d31096" + ], + "isOsiApproved": false + }, + { + "reference": "./EUPL-1.1.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/EUPL-1.1.json", + "referenceNumber": "429", + "name": "European Union Public License 1.1", + "licenseId": "EUPL-1.1", + "seeAlso": [ + "https://joinup.ec.europa.eu/software/page/eupl/licence-eupl", + "https://joinup.ec.europa.eu/sites/default/files/custom-page/attachment/eupl1.1.-licence-en_0.pdf", + "https://opensource.org/licenses/EUPL-1.1" + ], + "isOsiApproved": true + }, + { + "reference": "./EUPL-1.2.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/EUPL-1.2.json", + "referenceNumber": "283", + "name": "European Union Public License 1.2", + "licenseId": "EUPL-1.2", + "seeAlso": [ + "https://joinup.ec.europa.eu/page/eupl-text-11-12", + "https://joinup.ec.europa.eu/sites/default/files/custom-page/attachment/eupl_v1.2_en.pdf", + "https://joinup.ec.europa.eu/sites/default/files/inline-files/EUPL%20v1_2%20EN(1).txt", + "http://eur-lex.europa.eu/legal-content/EN/TXT/HTML/?uri\u003dCELEX:32017D0863", + "https://opensource.org/licenses/EUPL-1.2" + ], + "isOsiApproved": true + }, + { + "reference": "./Entessa.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Entessa.json", + "referenceNumber": "405", + "name": "Entessa Public License v1.0", + "licenseId": "Entessa", + "seeAlso": [ + "https://opensource.org/licenses/Entessa" + ], + "isOsiApproved": true + }, + { + "reference": "./ErlPL-1.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/ErlPL-1.1.json", + "referenceNumber": "427", + "name": "Erlang Public License v1.1", + "licenseId": "ErlPL-1.1", + "seeAlso": [ + "http://www.erlang.org/EPLICENSE" + ], + "isOsiApproved": false + }, + { + "reference": "./Eurosym.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Eurosym.json", + "referenceNumber": "176", + "name": "Eurosym License", + "licenseId": "Eurosym", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Eurosym" + ], + "isOsiApproved": false + }, + { + "reference": "./FSFAP.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/FSFAP.json", + "referenceNumber": "413", + "name": "FSF All Permissive License", + "licenseId": "FSFAP", + "seeAlso": [ + "https://www.gnu.org/prep/maintain/html_node/License-Notices-for-Other-Files.html" + ], + "isOsiApproved": false + }, + { + "reference": "./FSFUL.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/FSFUL.json", + "referenceNumber": "2", + "name": "FSF Unlimited License", + "licenseId": "FSFUL", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/FSF_Unlimited_License" + ], + "isOsiApproved": false + }, + { + "reference": "./FSFULLR.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/FSFULLR.json", + "referenceNumber": "325", + "name": "FSF Unlimited License (with License Retention)", + "licenseId": "FSFULLR", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/FSF_Unlimited_License#License_Retention_Variant" + ], + "isOsiApproved": false + }, + { + "reference": "./FTL.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/FTL.json", + "referenceNumber": "393", + "name": "Freetype Project License", + "licenseId": "FTL", + "seeAlso": [ + "http://freetype.fis.uniroma2.it/FTL.TXT", + "http://git.savannah.gnu.org/cgit/freetype/freetype2.git/tree/docs/FTL.TXT" + ], + "isOsiApproved": false + }, + { + "reference": "./Fair.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Fair.json", + "referenceNumber": "274", + "name": "Fair License", + "licenseId": "Fair", + "seeAlso": [ + "http://fairlicense.org/", + "https://opensource.org/licenses/Fair" + ], + "isOsiApproved": true + }, + { + "reference": "./Frameworx-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Frameworx-1.0.json", + "referenceNumber": "392", + "name": "Frameworx Open License 1.0", + "licenseId": "Frameworx-1.0", + "seeAlso": [ + "https://opensource.org/licenses/Frameworx-1.0" + ], + "isOsiApproved": true + }, + { + "reference": "./FreeImage.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/FreeImage.json", + "referenceNumber": "389", + "name": "FreeImage Public License v1.0", + "licenseId": "FreeImage", + "seeAlso": [ + "http://freeimage.sourceforge.net/freeimage-license.txt" + ], + "isOsiApproved": false + }, + { + "reference": "./GFDL-1.1.html", + "isDeprecatedLicenseId": true, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/GFDL-1.1.json", + "referenceNumber": "269", + "name": "GNU Free Documentation License v1.1", + "licenseId": "GFDL-1.1", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/fdl-1.1.txt" + ], + "isOsiApproved": false + }, + { + "reference": "./GFDL-1.1-invariants-only.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/GFDL-1.1-invariants-only.json", + "referenceNumber": "205", + "name": "GNU Free Documentation License v1.1 only - invariants", + "licenseId": "GFDL-1.1-invariants-only", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/fdl-1.1.txt" + ], + "isOsiApproved": false + }, + { + "reference": "./GFDL-1.1-invariants-or-later.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/GFDL-1.1-invariants-or-later.json", + "referenceNumber": "85", + "name": "GNU Free Documentation License v1.1 or later - invariants", + "licenseId": "GFDL-1.1-invariants-or-later", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/fdl-1.1.txt" + ], + "isOsiApproved": false + }, + { + "reference": "./GFDL-1.1-no-invariants-only.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/GFDL-1.1-no-invariants-only.json", + "referenceNumber": "7", + "name": "GNU Free Documentation License v1.1 only - no invariants", + "licenseId": "GFDL-1.1-no-invariants-only", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/fdl-1.1.txt" + ], + "isOsiApproved": false + }, + { + "reference": "./GFDL-1.1-no-invariants-or-later.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/GFDL-1.1-no-invariants-or-later.json", + "referenceNumber": "254", + "name": "GNU Free Documentation License v1.1 or later - no invariants", + "licenseId": "GFDL-1.1-no-invariants-or-later", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/fdl-1.1.txt" + ], + "isOsiApproved": false + }, + { + "reference": "./GFDL-1.1-only.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/GFDL-1.1-only.json", + "referenceNumber": "108", + "name": "GNU Free Documentation License v1.1 only", + "licenseId": "GFDL-1.1-only", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/fdl-1.1.txt" + ], + "isOsiApproved": false + }, + { + "reference": "./GFDL-1.1-or-later.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/GFDL-1.1-or-later.json", + "referenceNumber": "128", + "name": "GNU Free Documentation License v1.1 or later", + "licenseId": "GFDL-1.1-or-later", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/fdl-1.1.txt" + ], + "isOsiApproved": false + }, + { + "reference": "./GFDL-1.2.html", + "isDeprecatedLicenseId": true, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/GFDL-1.2.json", + "referenceNumber": "206", + "name": "GNU Free Documentation License v1.2", + "licenseId": "GFDL-1.2", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/fdl-1.2.txt" + ], + "isOsiApproved": false + }, + { + "reference": "./GFDL-1.2-invariants-only.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/GFDL-1.2-invariants-only.json", + "referenceNumber": "208", + "name": "GNU Free Documentation License v1.2 only - invariants", + "licenseId": "GFDL-1.2-invariants-only", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/fdl-1.2.txt" + ], + "isOsiApproved": false + }, + { + "reference": "./GFDL-1.2-invariants-or-later.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/GFDL-1.2-invariants-or-later.json", + "referenceNumber": "428", + "name": "GNU Free Documentation License v1.2 or later - invariants", + "licenseId": "GFDL-1.2-invariants-or-later", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/fdl-1.2.txt" + ], + "isOsiApproved": false + }, + { + "reference": "./GFDL-1.2-no-invariants-only.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/GFDL-1.2-no-invariants-only.json", + "referenceNumber": "324", + "name": "GNU Free Documentation License v1.2 only - no invariants", + "licenseId": "GFDL-1.2-no-invariants-only", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/fdl-1.2.txt" + ], + "isOsiApproved": false + }, + { + "reference": "./GFDL-1.2-no-invariants-or-later.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/GFDL-1.2-no-invariants-or-later.json", + "referenceNumber": "195", + "name": "GNU Free Documentation License v1.2 or later - no invariants", + "licenseId": "GFDL-1.2-no-invariants-or-later", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/fdl-1.2.txt" + ], + "isOsiApproved": false + }, + { + "reference": "./GFDL-1.2-only.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/GFDL-1.2-only.json", + "referenceNumber": "94", + "name": "GNU Free Documentation License v1.2 only", + "licenseId": "GFDL-1.2-only", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/fdl-1.2.txt" + ], + "isOsiApproved": false + }, + { + "reference": "./GFDL-1.2-or-later.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/GFDL-1.2-or-later.json", + "referenceNumber": "136", + "name": "GNU Free Documentation License v1.2 or later", + "licenseId": "GFDL-1.2-or-later", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/fdl-1.2.txt" + ], + "isOsiApproved": false + }, + { + "reference": "./GFDL-1.3.html", + "isDeprecatedLicenseId": true, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/GFDL-1.3.json", + "referenceNumber": "384", + "name": "GNU Free Documentation License v1.3", + "licenseId": "GFDL-1.3", + "seeAlso": [ + "https://www.gnu.org/licenses/fdl-1.3.txt" + ], + "isOsiApproved": false + }, + { + "reference": "./GFDL-1.3-invariants-only.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/GFDL-1.3-invariants-only.json", + "referenceNumber": "187", + "name": "GNU Free Documentation License v1.3 only - invariants", + "licenseId": "GFDL-1.3-invariants-only", + "seeAlso": [ + "https://www.gnu.org/licenses/fdl-1.3.txt" + ], + "isOsiApproved": false + }, + { + "reference": "./GFDL-1.3-invariants-or-later.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/GFDL-1.3-invariants-or-later.json", + "referenceNumber": "319", + "name": "GNU Free Documentation License v1.3 or later - invariants", + "licenseId": "GFDL-1.3-invariants-or-later", + "seeAlso": [ + "https://www.gnu.org/licenses/fdl-1.3.txt" + ], + "isOsiApproved": false + }, + { + "reference": "./GFDL-1.3-no-invariants-only.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/GFDL-1.3-no-invariants-only.json", + "referenceNumber": "183", + "name": "GNU Free Documentation License v1.3 only - no invariants", + "licenseId": "GFDL-1.3-no-invariants-only", + "seeAlso": [ + "https://www.gnu.org/licenses/fdl-1.3.txt" + ], + "isOsiApproved": false + }, + { + "reference": "./GFDL-1.3-no-invariants-or-later.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/GFDL-1.3-no-invariants-or-later.json", + "referenceNumber": "167", + "name": "GNU Free Documentation License v1.3 or later - no invariants", + "licenseId": "GFDL-1.3-no-invariants-or-later", + "seeAlso": [ + "https://www.gnu.org/licenses/fdl-1.3.txt" + ], + "isOsiApproved": false + }, + { + "reference": "./GFDL-1.3-only.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/GFDL-1.3-only.json", + "referenceNumber": "210", + "name": "GNU Free Documentation License v1.3 only", + "licenseId": "GFDL-1.3-only", + "seeAlso": [ + "https://www.gnu.org/licenses/fdl-1.3.txt" + ], + "isOsiApproved": false + }, + { + "reference": "./GFDL-1.3-or-later.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/GFDL-1.3-or-later.json", + "referenceNumber": "56", + "name": "GNU Free Documentation License v1.3 or later", + "licenseId": "GFDL-1.3-or-later", + "seeAlso": [ + "https://www.gnu.org/licenses/fdl-1.3.txt" + ], + "isOsiApproved": false + }, + { + "reference": "./GL2PS.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/GL2PS.json", + "referenceNumber": "331", + "name": "GL2PS License", + "licenseId": "GL2PS", + "seeAlso": [ + "http://www.geuz.org/gl2ps/COPYING.GL2PS" + ], + "isOsiApproved": false + }, + { + "reference": "./GLWTPL.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/GLWTPL.json", + "referenceNumber": "55", + "name": "Good Luck With That Public License", + "licenseId": "GLWTPL", + "seeAlso": [ + "https://github.com/me-shaon/GLWTPL/commit/da5f6bc734095efbacb442c0b31e33a65b9d6e85" + ], + "isOsiApproved": false + }, + { + "reference": "./GPL-1.0.html", + "isDeprecatedLicenseId": true, + "detailsUrl": "http://spdx.org/licenses/GPL-1.0.json", + "referenceNumber": "347", + "name": "GNU General Public License v1.0 only", + "licenseId": "GPL-1.0", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/gpl-1.0-standalone.html" + ], + "isOsiApproved": false + }, + { + "reference": "./GPL-1.0+.html", + "isDeprecatedLicenseId": true, + "detailsUrl": "http://spdx.org/licenses/GPL-1.0+.json", + "referenceNumber": "215", + "name": "GNU General Public License v1.0 or later", + "licenseId": "GPL-1.0+", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/gpl-1.0-standalone.html" + ], + "isOsiApproved": false + }, + { + "reference": "./GPL-1.0-only.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/GPL-1.0-only.json", + "referenceNumber": "16", + "name": "GNU General Public License v1.0 only", + "licenseId": "GPL-1.0-only", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/gpl-1.0-standalone.html" + ], + "isOsiApproved": false + }, + { + "reference": "./GPL-1.0-or-later.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/GPL-1.0-or-later.json", + "referenceNumber": "138", + "name": "GNU General Public License v1.0 or later", + "licenseId": "GPL-1.0-or-later", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/gpl-1.0-standalone.html" + ], + "isOsiApproved": false + }, + { + "reference": "./GPL-2.0.html", + "isDeprecatedLicenseId": true, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/GPL-2.0.json", + "referenceNumber": "374", + "name": "GNU General Public License v2.0 only", + "licenseId": "GPL-2.0", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/gpl-2.0-standalone.html", + "https://opensource.org/licenses/GPL-2.0" + ], + "isOsiApproved": true + }, + { + "reference": "./GPL-2.0+.html", + "isDeprecatedLicenseId": true, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/GPL-2.0+.json", + "referenceNumber": "420", + "name": "GNU General Public License v2.0 or later", + "licenseId": "GPL-2.0+", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/gpl-2.0-standalone.html", + "https://opensource.org/licenses/GPL-2.0" + ], + "isOsiApproved": true + }, + { + "reference": "./GPL-2.0-only.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/GPL-2.0-only.json", + "referenceNumber": "246", + "name": "GNU General Public License v2.0 only", + "licenseId": "GPL-2.0-only", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/gpl-2.0-standalone.html", + "https://opensource.org/licenses/GPL-2.0" + ], + "isOsiApproved": true + }, + { + "reference": "./GPL-2.0-or-later.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/GPL-2.0-or-later.json", + "referenceNumber": "270", + "name": "GNU General Public License v2.0 or later", + "licenseId": "GPL-2.0-or-later", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/gpl-2.0-standalone.html", + "https://opensource.org/licenses/GPL-2.0" + ], + "isOsiApproved": true + }, + { + "reference": "./GPL-2.0-with-GCC-exception.html", + "isDeprecatedLicenseId": true, + "detailsUrl": "http://spdx.org/licenses/GPL-2.0-with-GCC-exception.json", + "referenceNumber": "357", + "name": "GNU General Public License v2.0 w/GCC Runtime Library exception", + "licenseId": "GPL-2.0-with-GCC-exception", + "seeAlso": [ + "https://gcc.gnu.org/git/?p\u003dgcc.git;a\u003dblob;f\u003dgcc/libgcc1.c;h\u003d762f5143fc6eed57b6797c82710f3538aa52b40b;hb\u003dcb143a3ce4fb417c68f5fa2691a1b1b1053dfba9#l10" + ], + "isOsiApproved": false + }, + { + "reference": "./GPL-2.0-with-autoconf-exception.html", + "isDeprecatedLicenseId": true, + "detailsUrl": "http://spdx.org/licenses/GPL-2.0-with-autoconf-exception.json", + "referenceNumber": "37", + "name": "GNU General Public License v2.0 w/Autoconf exception", + "licenseId": "GPL-2.0-with-autoconf-exception", + "seeAlso": [ + "http://ac-archive.sourceforge.net/doc/copyright.html" + ], + "isOsiApproved": false + }, + { + "reference": "./GPL-2.0-with-bison-exception.html", + "isDeprecatedLicenseId": true, + "detailsUrl": "http://spdx.org/licenses/GPL-2.0-with-bison-exception.json", + "referenceNumber": "390", + "name": "GNU General Public License v2.0 w/Bison exception", + "licenseId": "GPL-2.0-with-bison-exception", + "seeAlso": [ + "http://git.savannah.gnu.org/cgit/bison.git/tree/data/yacc.c?id\u003d193d7c7054ba7197b0789e14965b739162319b5e#n141" + ], + "isOsiApproved": false + }, + { + "reference": "./GPL-2.0-with-classpath-exception.html", + "isDeprecatedLicenseId": true, + "detailsUrl": "http://spdx.org/licenses/GPL-2.0-with-classpath-exception.json", + "referenceNumber": "238", + "name": "GNU General Public License v2.0 w/Classpath exception", + "licenseId": "GPL-2.0-with-classpath-exception", + "seeAlso": [ + "https://www.gnu.org/software/classpath/license.html" + ], + "isOsiApproved": false + }, + { + "reference": "./GPL-2.0-with-font-exception.html", + "isDeprecatedLicenseId": true, + "detailsUrl": "http://spdx.org/licenses/GPL-2.0-with-font-exception.json", + "referenceNumber": "25", + "name": "GNU General Public License v2.0 w/Font exception", + "licenseId": "GPL-2.0-with-font-exception", + "seeAlso": [ + "https://www.gnu.org/licenses/gpl-faq.html#FontException" + ], + "isOsiApproved": false + }, + { + "reference": "./GPL-3.0.html", + "isDeprecatedLicenseId": true, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/GPL-3.0.json", + "referenceNumber": "434", + "name": "GNU General Public License v3.0 only", + "licenseId": "GPL-3.0", + "seeAlso": [ + "https://www.gnu.org/licenses/gpl-3.0-standalone.html", + "https://opensource.org/licenses/GPL-3.0" + ], + "isOsiApproved": true + }, + { + "reference": "./GPL-3.0+.html", + "isDeprecatedLicenseId": true, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/GPL-3.0+.json", + "referenceNumber": "156", + "name": "GNU General Public License v3.0 or later", + "licenseId": "GPL-3.0+", + "seeAlso": [ + "https://www.gnu.org/licenses/gpl-3.0-standalone.html", + "https://opensource.org/licenses/GPL-3.0" + ], + "isOsiApproved": true + }, + { + "reference": "./GPL-3.0-only.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/GPL-3.0-only.json", + "referenceNumber": "131", + "name": "GNU General Public License v3.0 only", + "licenseId": "GPL-3.0-only", + "seeAlso": [ + "https://www.gnu.org/licenses/gpl-3.0-standalone.html", + "https://opensource.org/licenses/GPL-3.0" + ], + "isOsiApproved": true + }, + { + "reference": "./GPL-3.0-or-later.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/GPL-3.0-or-later.json", + "referenceNumber": "418", + "name": "GNU General Public License v3.0 or later", + "licenseId": "GPL-3.0-or-later", + "seeAlso": [ + "https://www.gnu.org/licenses/gpl-3.0-standalone.html", + "https://opensource.org/licenses/GPL-3.0" + ], + "isOsiApproved": true + }, + { + "reference": "./GPL-3.0-with-GCC-exception.html", + "isDeprecatedLicenseId": true, + "detailsUrl": "http://spdx.org/licenses/GPL-3.0-with-GCC-exception.json", + "referenceNumber": "6", + "name": "GNU General Public License v3.0 w/GCC Runtime Library exception", + "licenseId": "GPL-3.0-with-GCC-exception", + "seeAlso": [ + "https://www.gnu.org/licenses/gcc-exception-3.1.html" + ], + "isOsiApproved": true + }, + { + "reference": "./GPL-3.0-with-autoconf-exception.html", + "isDeprecatedLicenseId": true, + "detailsUrl": "http://spdx.org/licenses/GPL-3.0-with-autoconf-exception.json", + "referenceNumber": "9", + "name": "GNU General Public License v3.0 w/Autoconf exception", + "licenseId": "GPL-3.0-with-autoconf-exception", + "seeAlso": [ + "https://www.gnu.org/licenses/autoconf-exception-3.0.html" + ], + "isOsiApproved": false + }, + { + "reference": "./Giftware.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Giftware.json", + "referenceNumber": "398", + "name": "Giftware License", + "licenseId": "Giftware", + "seeAlso": [ + "http://liballeg.org/license.html#allegro-4-the-giftware-license" + ], + "isOsiApproved": false + }, + { + "reference": "./Glide.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Glide.json", + "referenceNumber": "125", + "name": "3dfx Glide License", + "licenseId": "Glide", + "seeAlso": [ + "http://www.users.on.net/~triforce/glidexp/COPYING.txt" + ], + "isOsiApproved": false + }, + { + "reference": "./Glulxe.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Glulxe.json", + "referenceNumber": "216", + "name": "Glulxe License", + "licenseId": "Glulxe", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Glulxe" + ], + "isOsiApproved": false + }, + { + "reference": "./HPND.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/HPND.json", + "referenceNumber": "158", + "name": "Historical Permission Notice and Disclaimer", + "licenseId": "HPND", + "seeAlso": [ + "https://opensource.org/licenses/HPND" + ], + "isOsiApproved": true + }, + { + "reference": "./HPND-sell-variant.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/HPND-sell-variant.json", + "referenceNumber": "169", + "name": "Historical Permission Notice and Disclaimer - sell variant", + "licenseId": "HPND-sell-variant", + "seeAlso": [ + "https://git.kernel.org/pub/scm/linux/kernel/git/torvalds/linux.git/tree/net/sunrpc/auth_gss/gss_generic_token.c?h\u003dv4.19" + ], + "isOsiApproved": false + }, + { + "reference": "./HaskellReport.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/HaskellReport.json", + "referenceNumber": "222", + "name": "Haskell Language Report License", + "licenseId": "HaskellReport", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Haskell_Language_Report_License" + ], + "isOsiApproved": false + }, + { + "reference": "./Hippocratic-2.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Hippocratic-2.1.json", + "referenceNumber": "192", + "name": "Hippocratic License 2.1", + "licenseId": "Hippocratic-2.1", + "seeAlso": [ + "https://firstdonoharm.dev/version/2/1/license.html", + "https://github.com/EthicalSource/hippocratic-license/blob/58c0e646d64ff6fbee275bfe2b9492f914e3ab2a/LICENSE.txt" + ], + "isOsiApproved": false + }, + { + "reference": "./IBM-pibs.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/IBM-pibs.json", + "referenceNumber": "252", + "name": "IBM PowerPC Initialization and Boot Software", + "licenseId": "IBM-pibs", + "seeAlso": [ + "http://git.denx.de/?p\u003du-boot.git;a\u003dblob;f\u003darch/powerpc/cpu/ppc4xx/miiphy.c;h\u003d297155fdafa064b955e53e9832de93bfb0cfb85b;hb\u003d9fab4bf4cc077c21e43941866f3f2c196f28670d" + ], + "isOsiApproved": false + }, + { + "reference": "./ICU.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/ICU.json", + "referenceNumber": "186", + "name": "ICU License", + "licenseId": "ICU", + "seeAlso": [ + "http://source.icu-project.org/repos/icu/icu/trunk/license.html" + ], + "isOsiApproved": false + }, + { + "reference": "./IJG.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/IJG.json", + "referenceNumber": "256", + "name": "Independent JPEG Group License", + "licenseId": "IJG", + "seeAlso": [ + "http://dev.w3.org/cvsweb/Amaya/libjpeg/Attic/README?rev\u003d1.2" + ], + "isOsiApproved": false + }, + { + "reference": "./IPA.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/IPA.json", + "referenceNumber": "338", + "name": "IPA Font License", + "licenseId": "IPA", + "seeAlso": [ + "https://opensource.org/licenses/IPA" + ], + "isOsiApproved": true + }, + { + "reference": "./IPL-1.0.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/IPL-1.0.json", + "referenceNumber": "337", + "name": "IBM Public License v1.0", + "licenseId": "IPL-1.0", + "seeAlso": [ + "https://opensource.org/licenses/IPL-1.0" + ], + "isOsiApproved": true + }, + { + "reference": "./ISC.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/ISC.json", + "referenceNumber": "383", + "name": "ISC License", + "licenseId": "ISC", + "seeAlso": [ + "https://www.isc.org/downloads/software-support-policy/isc-license/", + "https://opensource.org/licenses/ISC" + ], + "isOsiApproved": true + }, + { + "reference": "./ImageMagick.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/ImageMagick.json", + "referenceNumber": "354", + "name": "ImageMagick License", + "licenseId": "ImageMagick", + "seeAlso": [ + "http://www.imagemagick.org/script/license.php" + ], + "isOsiApproved": false + }, + { + "reference": "./Imlib2.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/Imlib2.json", + "referenceNumber": "144", + "name": "Imlib2 License", + "licenseId": "Imlib2", + "seeAlso": [ + "http://trac.enlightenment.org/e/browser/trunk/imlib2/COPYING", + "https://git.enlightenment.org/legacy/imlib2.git/tree/COPYING" + ], + "isOsiApproved": false + }, + { + "reference": "./Info-ZIP.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Info-ZIP.json", + "referenceNumber": "308", + "name": "Info-ZIP License", + "licenseId": "Info-ZIP", + "seeAlso": [ + "http://www.info-zip.org/license.html" + ], + "isOsiApproved": false + }, + { + "reference": "./Intel.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/Intel.json", + "referenceNumber": "30", + "name": "Intel Open Source License", + "licenseId": "Intel", + "seeAlso": [ + "https://opensource.org/licenses/Intel" + ], + "isOsiApproved": true + }, + { + "reference": "./Intel-ACPI.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Intel-ACPI.json", + "referenceNumber": "255", + "name": "Intel ACPI Software License Agreement", + "licenseId": "Intel-ACPI", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Intel_ACPI_Software_License_Agreement" + ], + "isOsiApproved": false + }, + { + "reference": "./Interbase-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Interbase-1.0.json", + "referenceNumber": "351", + "name": "Interbase Public License v1.0", + "licenseId": "Interbase-1.0", + "seeAlso": [ + "https://web.archive.org/web/20060319014854/http://info.borland.com/devsupport/interbase/opensource/IPL.html" + ], + "isOsiApproved": false + }, + { + "reference": "./JPNIC.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/JPNIC.json", + "referenceNumber": "344", + "name": "Japan Network Information Center License", + "licenseId": "JPNIC", + "seeAlso": [ + "https://gitlab.isc.org/isc-projects/bind9/blob/master/COPYRIGHT#L366" + ], + "isOsiApproved": false + }, + { + "reference": "./JSON.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/JSON.json", + "referenceNumber": "214", + "name": "JSON License", + "licenseId": "JSON", + "seeAlso": [ + "http://www.json.org/license.html" + ], + "isOsiApproved": false + }, + { + "reference": "./JasPer-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/JasPer-2.0.json", + "referenceNumber": "84", + "name": "JasPer License", + "licenseId": "JasPer-2.0", + "seeAlso": [ + "http://www.ece.uvic.ca/~mdadams/jasper/LICENSE" + ], + "isOsiApproved": false + }, + { + "reference": "./LAL-1.2.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/LAL-1.2.json", + "referenceNumber": "163", + "name": "Licence Art Libre 1.2", + "licenseId": "LAL-1.2", + "seeAlso": [ + "http://artlibre.org/licence/lal/licence-art-libre-12/" + ], + "isOsiApproved": false + }, + { + "reference": "./LAL-1.3.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/LAL-1.3.json", + "referenceNumber": "387", + "name": "Licence Art Libre 1.3", + "licenseId": "LAL-1.3", + "seeAlso": [ + "https://artlibre.org/" + ], + "isOsiApproved": false + }, + { + "reference": "./LGPL-2.0.html", + "isDeprecatedLicenseId": true, + "detailsUrl": "http://spdx.org/licenses/LGPL-2.0.json", + "referenceNumber": "299", + "name": "GNU Library General Public License v2 only", + "licenseId": "LGPL-2.0", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/lgpl-2.0-standalone.html" + ], + "isOsiApproved": true + }, + { + "reference": "./LGPL-2.0+.html", + "isDeprecatedLicenseId": true, + "detailsUrl": "http://spdx.org/licenses/LGPL-2.0+.json", + "referenceNumber": "148", + "name": "GNU Library General Public License v2 or later", + "licenseId": "LGPL-2.0+", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/lgpl-2.0-standalone.html" + ], + "isOsiApproved": true + }, + { + "reference": "./LGPL-2.0-only.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/LGPL-2.0-only.json", + "referenceNumber": "356", + "name": "GNU Library General Public License v2 only", + "licenseId": "LGPL-2.0-only", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/lgpl-2.0-standalone.html" + ], + "isOsiApproved": true + }, + { + "reference": "./LGPL-2.0-or-later.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/LGPL-2.0-or-later.json", + "referenceNumber": "36", + "name": "GNU Library General Public License v2 or later", + "licenseId": "LGPL-2.0-or-later", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/lgpl-2.0-standalone.html" + ], + "isOsiApproved": true + }, + { + "reference": "./LGPL-2.1.html", + "isDeprecatedLicenseId": true, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/LGPL-2.1.json", + "referenceNumber": "197", + "name": "GNU Lesser General Public License v2.1 only", + "licenseId": "LGPL-2.1", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/lgpl-2.1-standalone.html", + "https://opensource.org/licenses/LGPL-2.1" + ], + "isOsiApproved": true + }, + { + "reference": "./LGPL-2.1+.html", + "isDeprecatedLicenseId": true, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/LGPL-2.1+.json", + "referenceNumber": "219", + "name": "GNU Library General Public License v2.1 or later", + "licenseId": "LGPL-2.1+", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/lgpl-2.1-standalone.html", + "https://opensource.org/licenses/LGPL-2.1" + ], + "isOsiApproved": true + }, + { + "reference": "./LGPL-2.1-only.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/LGPL-2.1-only.json", + "referenceNumber": "147", + "name": "GNU Lesser General Public License v2.1 only", + "licenseId": "LGPL-2.1-only", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/lgpl-2.1-standalone.html", + "https://opensource.org/licenses/LGPL-2.1" + ], + "isOsiApproved": true + }, + { + "reference": "./LGPL-2.1-or-later.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/LGPL-2.1-or-later.json", + "referenceNumber": "292", + "name": "GNU Lesser General Public License v2.1 or later", + "licenseId": "LGPL-2.1-or-later", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/lgpl-2.1-standalone.html", + "https://opensource.org/licenses/LGPL-2.1" + ], + "isOsiApproved": true + }, + { + "reference": "./LGPL-3.0.html", + "isDeprecatedLicenseId": true, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/LGPL-3.0.json", + "referenceNumber": "226", + "name": "GNU Lesser General Public License v3.0 only", + "licenseId": "LGPL-3.0", + "seeAlso": [ + "https://www.gnu.org/licenses/lgpl-3.0-standalone.html", + "https://opensource.org/licenses/LGPL-3.0" + ], + "isOsiApproved": true + }, + { + "reference": "./LGPL-3.0+.html", + "isDeprecatedLicenseId": true, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/LGPL-3.0+.json", + "referenceNumber": "239", + "name": "GNU Lesser General Public License v3.0 or later", + "licenseId": "LGPL-3.0+", + "seeAlso": [ + "https://www.gnu.org/licenses/lgpl-3.0-standalone.html", + "https://opensource.org/licenses/LGPL-3.0" + ], + "isOsiApproved": true + }, + { + "reference": "./LGPL-3.0-only.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/LGPL-3.0-only.json", + "referenceNumber": "51", + "name": "GNU Lesser General Public License v3.0 only", + "licenseId": "LGPL-3.0-only", + "seeAlso": [ + "https://www.gnu.org/licenses/lgpl-3.0-standalone.html", + "https://opensource.org/licenses/LGPL-3.0" + ], + "isOsiApproved": true + }, + { + "reference": "./LGPL-3.0-or-later.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/LGPL-3.0-or-later.json", + "referenceNumber": "345", + "name": "GNU Lesser General Public License v3.0 or later", + "licenseId": "LGPL-3.0-or-later", + "seeAlso": [ + "https://www.gnu.org/licenses/lgpl-3.0-standalone.html", + "https://opensource.org/licenses/LGPL-3.0" + ], + "isOsiApproved": true + }, + { + "reference": "./LGPLLR.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/LGPLLR.json", + "referenceNumber": "437", + "name": "Lesser General Public License For Linguistic Resources", + "licenseId": "LGPLLR", + "seeAlso": [ + "http://www-igm.univ-mlv.fr/~unitex/lgpllr.html" + ], + "isOsiApproved": false + }, + { + "reference": "./LPL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/LPL-1.0.json", + "referenceNumber": "402", + "name": "Lucent Public License Version 1.0", + "licenseId": "LPL-1.0", + "seeAlso": [ + "https://opensource.org/licenses/LPL-1.0" + ], + "isOsiApproved": true + }, + { + "reference": "./LPL-1.02.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/LPL-1.02.json", + "referenceNumber": "129", + "name": "Lucent Public License v1.02", + "licenseId": "LPL-1.02", + "seeAlso": [ + "http://plan9.bell-labs.com/plan9/license.html", + "https://opensource.org/licenses/LPL-1.02" + ], + "isOsiApproved": true + }, + { + "reference": "./LPPL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/LPPL-1.0.json", + "referenceNumber": "90", + "name": "LaTeX Project Public License v1.0", + "licenseId": "LPPL-1.0", + "seeAlso": [ + "http://www.latex-project.org/lppl/lppl-1-0.txt" + ], + "isOsiApproved": false + }, + { + "reference": "./LPPL-1.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/LPPL-1.1.json", + "referenceNumber": "179", + "name": "LaTeX Project Public License v1.1", + "licenseId": "LPPL-1.1", + "seeAlso": [ + "http://www.latex-project.org/lppl/lppl-1-1.txt" + ], + "isOsiApproved": false + }, + { + "reference": "./LPPL-1.2.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/LPPL-1.2.json", + "referenceNumber": "171", + "name": "LaTeX Project Public License v1.2", + "licenseId": "LPPL-1.2", + "seeAlso": [ + "http://www.latex-project.org/lppl/lppl-1-2.txt" + ], + "isOsiApproved": false + }, + { + "reference": "./LPPL-1.3a.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/LPPL-1.3a.json", + "referenceNumber": "293", + "name": "LaTeX Project Public License v1.3a", + "licenseId": "LPPL-1.3a", + "seeAlso": [ + "http://www.latex-project.org/lppl/lppl-1-3a.txt" + ], + "isOsiApproved": false + }, + { + "reference": "./LPPL-1.3c.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/LPPL-1.3c.json", + "referenceNumber": "135", + "name": "LaTeX Project Public License v1.3c", + "licenseId": "LPPL-1.3c", + "seeAlso": [ + "http://www.latex-project.org/lppl/lppl-1-3c.txt", + "https://opensource.org/licenses/LPPL-1.3c" + ], + "isOsiApproved": true + }, + { + "reference": "./Latex2e.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Latex2e.json", + "referenceNumber": "38", + "name": "Latex2e License", + "licenseId": "Latex2e", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Latex2e" + ], + "isOsiApproved": false + }, + { + "reference": "./Leptonica.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Leptonica.json", + "referenceNumber": "328", + "name": "Leptonica License", + "licenseId": "Leptonica", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Leptonica" + ], + "isOsiApproved": false + }, + { + "reference": "./LiLiQ-P-1.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/LiLiQ-P-1.1.json", + "referenceNumber": "87", + "name": "Licence Libre du Québec – Permissive version 1.1", + "licenseId": "LiLiQ-P-1.1", + "seeAlso": [ + "https://forge.gouv.qc.ca/licence/fr/liliq-v1-1/", + "http://opensource.org/licenses/LiLiQ-P-1.1" + ], + "isOsiApproved": true + }, + { + "reference": "./LiLiQ-R-1.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/LiLiQ-R-1.1.json", + "referenceNumber": "315", + "name": "Licence Libre du Québec – Réciprocité version 1.1", + "licenseId": "LiLiQ-R-1.1", + "seeAlso": [ + "https://www.forge.gouv.qc.ca/participez/licence-logicielle/licence-libre-du-quebec-liliq-en-francais/licence-libre-du-quebec-reciprocite-liliq-r-v1-1/", + "http://opensource.org/licenses/LiLiQ-R-1.1" + ], + "isOsiApproved": true + }, + { + "reference": "./LiLiQ-Rplus-1.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/LiLiQ-Rplus-1.1.json", + "referenceNumber": "363", + "name": "Licence Libre du Québec – Réciprocité forte version 1.1", + "licenseId": "LiLiQ-Rplus-1.1", + "seeAlso": [ + "https://www.forge.gouv.qc.ca/participez/licence-logicielle/licence-libre-du-quebec-liliq-en-francais/licence-libre-du-quebec-reciprocite-forte-liliq-r-v1-1/", + "http://opensource.org/licenses/LiLiQ-Rplus-1.1" + ], + "isOsiApproved": true + }, + { + "reference": "./Libpng.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Libpng.json", + "referenceNumber": "407", + "name": "libpng License", + "licenseId": "Libpng", + "seeAlso": [ + "http://www.libpng.org/pub/png/src/libpng-LICENSE.txt" + ], + "isOsiApproved": false + }, + { + "reference": "./Linux-OpenIB.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Linux-OpenIB.json", + "referenceNumber": "234", + "name": "Linux Kernel Variant of OpenIB.org license", + "licenseId": "Linux-OpenIB", + "seeAlso": [ + "https://git.kernel.org/pub/scm/linux/kernel/git/torvalds/linux.git/tree/drivers/infiniband/core/sa.h" + ], + "isOsiApproved": false + }, + { + "reference": "./MIT.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/MIT.json", + "referenceNumber": "277", + "name": "MIT License", + "licenseId": "MIT", + "seeAlso": [ + "https://opensource.org/licenses/MIT" + ], + "isOsiApproved": true + }, + { + "reference": "./MIT-0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/MIT-0.json", + "referenceNumber": "82", + "name": "MIT No Attribution", + "licenseId": "MIT-0", + "seeAlso": [ + "https://github.com/aws/mit-0", + "https://romanrm.net/mit-zero", + "https://github.com/awsdocs/aws-cloud9-user-guide/blob/master/LICENSE-SAMPLECODE" + ], + "isOsiApproved": false + }, + { + "reference": "./MIT-CMU.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/MIT-CMU.json", + "referenceNumber": "373", + "name": "CMU License", + "licenseId": "MIT-CMU", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing:MIT?rd\u003dLicensing/MIT#CMU_Style", + "https://github.com/python-pillow/Pillow/blob/fffb426092c8db24a5f4b6df243a8a3c01fb63cd/LICENSE" + ], + "isOsiApproved": false + }, + { + "reference": "./MIT-advertising.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/MIT-advertising.json", + "referenceNumber": "209", + "name": "Enlightenment License (e16)", + "licenseId": "MIT-advertising", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/MIT_With_Advertising" + ], + "isOsiApproved": false + }, + { + "reference": "./MIT-enna.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/MIT-enna.json", + "referenceNumber": "57", + "name": "enna License", + "licenseId": "MIT-enna", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/MIT#enna" + ], + "isOsiApproved": false + }, + { + "reference": "./MIT-feh.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/MIT-feh.json", + "referenceNumber": "395", + "name": "feh License", + "licenseId": "MIT-feh", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/MIT#feh" + ], + "isOsiApproved": false + }, + { + "reference": "./MITNFA.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/MITNFA.json", + "referenceNumber": "364", + "name": "MIT +no-false-attribs license", + "licenseId": "MITNFA", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/MITNFA" + ], + "isOsiApproved": false + }, + { + "reference": "./MPL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/MPL-1.0.json", + "referenceNumber": "259", + "name": "Mozilla Public License 1.0", + "licenseId": "MPL-1.0", + "seeAlso": [ + "http://www.mozilla.org/MPL/MPL-1.0.html", + "https://opensource.org/licenses/MPL-1.0" + ], + "isOsiApproved": true + }, + { + "reference": "./MPL-1.1.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/MPL-1.1.json", + "referenceNumber": "426", + "name": "Mozilla Public License 1.1", + "licenseId": "MPL-1.1", + "seeAlso": [ + "http://www.mozilla.org/MPL/MPL-1.1.html", + "https://opensource.org/licenses/MPL-1.1" + ], + "isOsiApproved": true + }, + { + "reference": "./MPL-2.0.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/MPL-2.0.json", + "referenceNumber": "130", + "name": "Mozilla Public License 2.0", + "licenseId": "MPL-2.0", + "seeAlso": [ + "http://www.mozilla.org/MPL/2.0/", + "https://opensource.org/licenses/MPL-2.0" + ], + "isOsiApproved": true + }, + { + "reference": "./MPL-2.0-no-copyleft-exception.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/MPL-2.0-no-copyleft-exception.json", + "referenceNumber": "198", + "name": "Mozilla Public License 2.0 (no copyleft exception)", + "licenseId": "MPL-2.0-no-copyleft-exception", + "seeAlso": [ + "http://www.mozilla.org/MPL/2.0/", + "https://opensource.org/licenses/MPL-2.0" + ], + "isOsiApproved": true + }, + { + "reference": "./MS-PL.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/MS-PL.json", + "referenceNumber": "396", + "name": "Microsoft Public License", + "licenseId": "MS-PL", + "seeAlso": [ + "http://www.microsoft.com/opensource/licenses.mspx", + "https://opensource.org/licenses/MS-PL" + ], + "isOsiApproved": true + }, + { + "reference": "./MS-RL.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/MS-RL.json", + "referenceNumber": "4", + "name": "Microsoft Reciprocal License", + "licenseId": "MS-RL", + "seeAlso": [ + "http://www.microsoft.com/opensource/licenses.mspx", + "https://opensource.org/licenses/MS-RL" + ], + "isOsiApproved": true + }, + { + "reference": "./MTLL.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/MTLL.json", + "referenceNumber": "110", + "name": "Matrix Template Library License", + "licenseId": "MTLL", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Matrix_Template_Library_License" + ], + "isOsiApproved": false + }, + { + "reference": "./MakeIndex.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/MakeIndex.json", + "referenceNumber": "372", + "name": "MakeIndex License", + "licenseId": "MakeIndex", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/MakeIndex" + ], + "isOsiApproved": false + }, + { + "reference": "./MirOS.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/MirOS.json", + "referenceNumber": "400", + "name": "The MirOS Licence", + "licenseId": "MirOS", + "seeAlso": [ + "https://opensource.org/licenses/MirOS" + ], + "isOsiApproved": true + }, + { + "reference": "./Motosoto.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Motosoto.json", + "referenceNumber": "13", + "name": "Motosoto License", + "licenseId": "Motosoto", + "seeAlso": [ + "https://opensource.org/licenses/Motosoto" + ], + "isOsiApproved": true + }, + { + "reference": "./MulanPSL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/MulanPSL-1.0.json", + "referenceNumber": "218", + "name": "Mulan Permissive Software License, Version 1", + "licenseId": "MulanPSL-1.0", + "seeAlso": [ + "https://license.coscl.org.cn/MulanPSL/", + "https://github.com/yuwenlong/longphp/blob/25dfb70cc2a466dc4bb55ba30901cbce08d164b5/LICENSE" + ], + "isOsiApproved": false + }, + { + "reference": "./MulanPSL-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/MulanPSL-2.0.json", + "referenceNumber": "157", + "name": "Mulan Permissive Software License, Version 2", + "licenseId": "MulanPSL-2.0", + "seeAlso": [ + "https://license.coscl.org.cn/MulanPSL2/" + ], + "isOsiApproved": true + }, + { + "reference": "./Multics.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Multics.json", + "referenceNumber": "175", + "name": "Multics License", + "licenseId": "Multics", + "seeAlso": [ + "https://opensource.org/licenses/Multics" + ], + "isOsiApproved": true + }, + { + "reference": "./Mup.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Mup.json", + "referenceNumber": "333", + "name": "Mup License", + "licenseId": "Mup", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Mup" + ], + "isOsiApproved": false + }, + { + "reference": "./NASA-1.3.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/NASA-1.3.json", + "referenceNumber": "118", + "name": "NASA Open Source Agreement 1.3", + "licenseId": "NASA-1.3", + "seeAlso": [ + "http://ti.arc.nasa.gov/opensource/nosa/", + "https://opensource.org/licenses/NASA-1.3" + ], + "isOsiApproved": true + }, + { + "reference": "./NBPL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/NBPL-1.0.json", + "referenceNumber": "18", + "name": "Net Boolean Public License v1", + "licenseId": "NBPL-1.0", + "seeAlso": [ + "http://www.openldap.org/devel/gitweb.cgi?p\u003dopenldap.git;a\u003dblob;f\u003dLICENSE;hb\u003d37b4b3f6cc4bf34e1d3dec61e69914b9819d8894" + ], + "isOsiApproved": false + }, + { + "reference": "./NCGL-UK-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/NCGL-UK-2.0.json", + "referenceNumber": "235", + "name": "Non-Commercial Government Licence", + "licenseId": "NCGL-UK-2.0", + "seeAlso": [ + "https://github.com/spdx/license-list-XML/blob/master/src/Apache-2.0.xml" + ], + "isOsiApproved": false + }, + { + "reference": "./NCSA.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/NCSA.json", + "referenceNumber": "202", + "name": "University of Illinois/NCSA Open Source License", + "licenseId": "NCSA", + "seeAlso": [ + "http://otm.illinois.edu/uiuc_openSource", + "https://opensource.org/licenses/NCSA" + ], + "isOsiApproved": true + }, + { + "reference": "./NGPL.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/NGPL.json", + "referenceNumber": "336", + "name": "Nethack General Public License", + "licenseId": "NGPL", + "seeAlso": [ + "https://opensource.org/licenses/NGPL" + ], + "isOsiApproved": true + }, + { + "reference": "./NIST-PD.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/NIST-PD.json", + "referenceNumber": "320", + "name": "NIST Public Domain Notice", + "licenseId": "NIST-PD", + "seeAlso": [ + "https://github.com/tcheneau/simpleRPL/blob/e645e69e38dd4e3ccfeceb2db8cba05b7c2e0cd3/LICENSE.txt", + "https://github.com/tcheneau/Routing/blob/f09f46fcfe636107f22f2c98348188a65a135d98/README.md" + ], + "isOsiApproved": false + }, + { + "reference": "./NIST-PD-fallback.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/NIST-PD-fallback.json", + "referenceNumber": "39", + "name": "NIST Public Domain Notice with license fallback", + "licenseId": "NIST-PD-fallback", + "seeAlso": [ + "https://github.com/usnistgov/jsip/blob/59700e6926cbe96c5cdae897d9a7d2656b42abe3/LICENSE", + "https://github.com/usnistgov/fipy/blob/86aaa5c2ba2c6f1be19593c5986071cf6568cc34/LICENSE.rst" + ], + "isOsiApproved": false + }, + { + "reference": "./NLOD-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/NLOD-1.0.json", + "referenceNumber": "143", + "name": "Norwegian Licence for Open Government Data", + "licenseId": "NLOD-1.0", + "seeAlso": [ + "http://data.norge.no/nlod/en/1.0" + ], + "isOsiApproved": false + }, + { + "reference": "./NLPL.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/NLPL.json", + "referenceNumber": "334", + "name": "No Limit Public License", + "licenseId": "NLPL", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/NLPL" + ], + "isOsiApproved": false + }, + { + "reference": "./NOSL.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/NOSL.json", + "referenceNumber": "411", + "name": "Netizen Open Source License", + "licenseId": "NOSL", + "seeAlso": [ + "http://bits.netizen.com.au/licenses/NOSL/nosl.txt" + ], + "isOsiApproved": false + }, + { + "reference": "./NPL-1.0.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/NPL-1.0.json", + "referenceNumber": "265", + "name": "Netscape Public License v1.0", + "licenseId": "NPL-1.0", + "seeAlso": [ + "http://www.mozilla.org/MPL/NPL/1.0/" + ], + "isOsiApproved": false + }, + { + "reference": "./NPL-1.1.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/NPL-1.1.json", + "referenceNumber": "442", + "name": "Netscape Public License v1.1", + "licenseId": "NPL-1.1", + "seeAlso": [ + "http://www.mozilla.org/MPL/NPL/1.1/" + ], + "isOsiApproved": false + }, + { + "reference": "./NPOSL-3.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/NPOSL-3.0.json", + "referenceNumber": "160", + "name": "Non-Profit Open Software License 3.0", + "licenseId": "NPOSL-3.0", + "seeAlso": [ + "https://opensource.org/licenses/NOSL3.0" + ], + "isOsiApproved": true + }, + { + "reference": "./NRL.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/NRL.json", + "referenceNumber": "109", + "name": "NRL License", + "licenseId": "NRL", + "seeAlso": [ + "http://web.mit.edu/network/isakmp/nrllicense.html" + ], + "isOsiApproved": false + }, + { + "reference": "./NTP.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/NTP.json", + "referenceNumber": "280", + "name": "NTP License", + "licenseId": "NTP", + "seeAlso": [ + "https://opensource.org/licenses/NTP" + ], + "isOsiApproved": true + }, + { + "reference": "./NTP-0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/NTP-0.json", + "referenceNumber": "200", + "name": "NTP No Attribution", + "licenseId": "NTP-0", + "seeAlso": [ + "https://github.com/tytso/e2fsprogs/blob/master/lib/et/et_name.c" + ], + "isOsiApproved": false + }, + { + "reference": "./Naumen.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Naumen.json", + "referenceNumber": "307", + "name": "Naumen Public License", + "licenseId": "Naumen", + "seeAlso": [ + "https://opensource.org/licenses/Naumen" + ], + "isOsiApproved": true + }, + { + "reference": "./Net-SNMP.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Net-SNMP.json", + "referenceNumber": "301", + "name": "Net-SNMP License", + "licenseId": "Net-SNMP", + "seeAlso": [ + "http://net-snmp.sourceforge.net/about/license.html" + ], + "isOsiApproved": false + }, + { + "reference": "./NetCDF.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/NetCDF.json", + "referenceNumber": "229", + "name": "NetCDF license", + "licenseId": "NetCDF", + "seeAlso": [ + "http://www.unidata.ucar.edu/software/netcdf/copyright.html" + ], + "isOsiApproved": false + }, + { + "reference": "./Newsletr.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Newsletr.json", + "referenceNumber": "388", + "name": "Newsletr License", + "licenseId": "Newsletr", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Newsletr" + ], + "isOsiApproved": false + }, + { + "reference": "./Nokia.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/Nokia.json", + "referenceNumber": "134", + "name": "Nokia Open Source License", + "licenseId": "Nokia", + "seeAlso": [ + "https://opensource.org/licenses/nokia" + ], + "isOsiApproved": true + }, + { + "reference": "./Noweb.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Noweb.json", + "referenceNumber": "76", + "name": "Noweb License", + "licenseId": "Noweb", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Noweb" + ], + "isOsiApproved": false + }, + { + "reference": "./Nunit.html", + "isDeprecatedLicenseId": true, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/Nunit.json", + "referenceNumber": "95", + "name": "Nunit License", + "licenseId": "Nunit", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Nunit" + ], + "isOsiApproved": false + }, + { + "reference": "./O-UDA-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/O-UDA-1.0.json", + "referenceNumber": "50", + "name": "Open Use of Data Agreement v1.0", + "licenseId": "O-UDA-1.0", + "seeAlso": [ + "https://github.com/microsoft/Open-Use-of-Data-Agreement/blob/v1.0/O-UDA-1.0.md" + ], + "isOsiApproved": false + }, + { + "reference": "./OCCT-PL.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/OCCT-PL.json", + "referenceNumber": "71", + "name": "Open CASCADE Technology Public License", + "licenseId": "OCCT-PL", + "seeAlso": [ + "http://www.opencascade.com/content/occt-public-license" + ], + "isOsiApproved": false + }, + { + "reference": "./OCLC-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/OCLC-2.0.json", + "referenceNumber": "370", + "name": "OCLC Research Public License 2.0", + "licenseId": "OCLC-2.0", + "seeAlso": [ + "http://www.oclc.org/research/activities/software/license/v2final.htm", + "https://opensource.org/licenses/OCLC-2.0" + ], + "isOsiApproved": true + }, + { + "reference": "./ODC-By-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/ODC-By-1.0.json", + "referenceNumber": "412", + "name": "Open Data Commons Attribution License v1.0", + "licenseId": "ODC-By-1.0", + "seeAlso": [ + "https://opendatacommons.org/licenses/by/1.0/" + ], + "isOsiApproved": false + }, + { + "reference": "./ODbL-1.0.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/ODbL-1.0.json", + "referenceNumber": "369", + "name": "ODC Open Database License v1.0", + "licenseId": "ODbL-1.0", + "seeAlso": [ + "http://www.opendatacommons.org/licenses/odbl/1.0/" + ], + "isOsiApproved": false + }, + { + "reference": "./OFL-1.0.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/OFL-1.0.json", + "referenceNumber": "88", + "name": "SIL Open Font License 1.0", + "licenseId": "OFL-1.0", + "seeAlso": [ + "http://scripts.sil.org/cms/scripts/page.php?item_id\u003dOFL10_web" + ], + "isOsiApproved": false + }, + { + "reference": "./OFL-1.0-RFN.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/OFL-1.0-RFN.json", + "referenceNumber": "326", + "name": "SIL Open Font License 1.0 with Reserved Font Name", + "licenseId": "OFL-1.0-RFN", + "seeAlso": [ + "http://scripts.sil.org/cms/scripts/page.php?item_id\u003dOFL10_web" + ], + "isOsiApproved": false + }, + { + "reference": "./OFL-1.0-no-RFN.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/OFL-1.0-no-RFN.json", + "referenceNumber": "77", + "name": "SIL Open Font License 1.0 with no Reserved Font Name", + "licenseId": "OFL-1.0-no-RFN", + "seeAlso": [ + "http://scripts.sil.org/cms/scripts/page.php?item_id\u003dOFL10_web" + ], + "isOsiApproved": false + }, + { + "reference": "./OFL-1.1.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/OFL-1.1.json", + "referenceNumber": "339", + "name": "SIL Open Font License 1.1", + "licenseId": "OFL-1.1", + "seeAlso": [ + "http://scripts.sil.org/cms/scripts/page.php?item_id\u003dOFL_web", + "https://opensource.org/licenses/OFL-1.1" + ], + "isOsiApproved": true + }, + { + "reference": "./OFL-1.1-RFN.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/OFL-1.1-RFN.json", + "referenceNumber": "45", + "name": "SIL Open Font License 1.1 with Reserved Font Name", + "licenseId": "OFL-1.1-RFN", + "seeAlso": [ + "http://scripts.sil.org/cms/scripts/page.php?item_id\u003dOFL_web", + "https://opensource.org/licenses/OFL-1.1" + ], + "isOsiApproved": true + }, + { + "reference": "./OFL-1.1-no-RFN.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/OFL-1.1-no-RFN.json", + "referenceNumber": "258", + "name": "SIL Open Font License 1.1 with no Reserved Font Name", + "licenseId": "OFL-1.1-no-RFN", + "seeAlso": [ + "http://scripts.sil.org/cms/scripts/page.php?item_id\u003dOFL_web", + "https://opensource.org/licenses/OFL-1.1" + ], + "isOsiApproved": true + }, + { + "reference": "./OGC-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/OGC-1.0.json", + "referenceNumber": "397", + "name": "OGC Software License, Version 1.0", + "licenseId": "OGC-1.0", + "seeAlso": [ + "https://www.ogc.org/ogc/software/1.0" + ], + "isOsiApproved": false + }, + { + "reference": "./OGL-Canada-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/OGL-Canada-2.0.json", + "referenceNumber": "375", + "name": "Open Government Licence - Canada", + "licenseId": "OGL-Canada-2.0", + "seeAlso": [ + "https://open.canada.ca/en/open-government-licence-canada" + ], + "isOsiApproved": false + }, + { + "reference": "./OGL-UK-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/OGL-UK-1.0.json", + "referenceNumber": "378", + "name": "Open Government Licence v1.0", + "licenseId": "OGL-UK-1.0", + "seeAlso": [ + "http://www.nationalarchives.gov.uk/doc/open-government-licence/version/1/" + ], + "isOsiApproved": false + }, + { + "reference": "./OGL-UK-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/OGL-UK-2.0.json", + "referenceNumber": "14", + "name": "Open Government Licence v2.0", + "licenseId": "OGL-UK-2.0", + "seeAlso": [ + "http://www.nationalarchives.gov.uk/doc/open-government-licence/version/2/" + ], + "isOsiApproved": false + }, + { + "reference": "./OGL-UK-3.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/OGL-UK-3.0.json", + "referenceNumber": "22", + "name": "Open Government Licence v3.0", + "licenseId": "OGL-UK-3.0", + "seeAlso": [ + "http://www.nationalarchives.gov.uk/doc/open-government-licence/version/3/" + ], + "isOsiApproved": false + }, + { + "reference": "./OGTSL.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/OGTSL.json", + "referenceNumber": "27", + "name": "Open Group Test Suite License", + "licenseId": "OGTSL", + "seeAlso": [ + "http://www.opengroup.org/testing/downloads/The_Open_Group_TSL.txt", + "https://opensource.org/licenses/OGTSL" + ], + "isOsiApproved": true + }, + { + "reference": "./OLDAP-1.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/OLDAP-1.1.json", + "referenceNumber": "60", + "name": "Open LDAP Public License v1.1", + "licenseId": "OLDAP-1.1", + "seeAlso": [ + "http://www.openldap.org/devel/gitweb.cgi?p\u003dopenldap.git;a\u003dblob;f\u003dLICENSE;hb\u003d806557a5ad59804ef3a44d5abfbe91d706b0791f" + ], + "isOsiApproved": false + }, + { + "reference": "./OLDAP-1.2.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/OLDAP-1.2.json", + "referenceNumber": "52", + "name": "Open LDAP Public License v1.2", + "licenseId": "OLDAP-1.2", + "seeAlso": [ + "http://www.openldap.org/devel/gitweb.cgi?p\u003dopenldap.git;a\u003dblob;f\u003dLICENSE;hb\u003d42b0383c50c299977b5893ee695cf4e486fb0dc7" + ], + "isOsiApproved": false + }, + { + "reference": "./OLDAP-1.3.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/OLDAP-1.3.json", + "referenceNumber": "44", + "name": "Open LDAP Public License v1.3", + "licenseId": "OLDAP-1.3", + "seeAlso": [ + "http://www.openldap.org/devel/gitweb.cgi?p\u003dopenldap.git;a\u003dblob;f\u003dLICENSE;hb\u003de5f8117f0ce088d0bd7a8e18ddf37eaa40eb09b1" + ], + "isOsiApproved": false + }, + { + "reference": "./OLDAP-1.4.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/OLDAP-1.4.json", + "referenceNumber": "54", + "name": "Open LDAP Public License v1.4", + "licenseId": "OLDAP-1.4", + "seeAlso": [ + "http://www.openldap.org/devel/gitweb.cgi?p\u003dopenldap.git;a\u003dblob;f\u003dLICENSE;hb\u003dc9f95c2f3f2ffb5e0ae55fe7388af75547660941" + ], + "isOsiApproved": false + }, + { + "reference": "./OLDAP-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/OLDAP-2.0.json", + "referenceNumber": "26", + "name": "Open LDAP Public License v2.0 (or possibly 2.0A and 2.0B)", + "licenseId": "OLDAP-2.0", + "seeAlso": [ + "http://www.openldap.org/devel/gitweb.cgi?p\u003dopenldap.git;a\u003dblob;f\u003dLICENSE;hb\u003dcbf50f4e1185a21abd4c0a54d3f4341fe28f36ea" + ], + "isOsiApproved": false + }, + { + "reference": "./OLDAP-2.0.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/OLDAP-2.0.1.json", + "referenceNumber": "303", + "name": "Open LDAP Public License v2.0.1", + "licenseId": "OLDAP-2.0.1", + "seeAlso": [ + "http://www.openldap.org/devel/gitweb.cgi?p\u003dopenldap.git;a\u003dblob;f\u003dLICENSE;hb\u003db6d68acd14e51ca3aab4428bf26522aa74873f0e" + ], + "isOsiApproved": false + }, + { + "reference": "./OLDAP-2.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/OLDAP-2.1.json", + "referenceNumber": "433", + "name": "Open LDAP Public License v2.1", + "licenseId": "OLDAP-2.1", + "seeAlso": [ + "http://www.openldap.org/devel/gitweb.cgi?p\u003dopenldap.git;a\u003dblob;f\u003dLICENSE;hb\u003db0d176738e96a0d3b9f85cb51e140a86f21be715" + ], + "isOsiApproved": false + }, + { + "reference": "./OLDAP-2.2.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/OLDAP-2.2.json", + "referenceNumber": "346", + "name": "Open LDAP Public License v2.2", + "licenseId": "OLDAP-2.2", + "seeAlso": [ + "http://www.openldap.org/devel/gitweb.cgi?p\u003dopenldap.git;a\u003dblob;f\u003dLICENSE;hb\u003d470b0c18ec67621c85881b2733057fecf4a1acc3" + ], + "isOsiApproved": false + }, + { + "reference": "./OLDAP-2.2.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/OLDAP-2.2.1.json", + "referenceNumber": "415", + "name": "Open LDAP Public License v2.2.1", + "licenseId": "OLDAP-2.2.1", + "seeAlso": [ + "http://www.openldap.org/devel/gitweb.cgi?p\u003dopenldap.git;a\u003dblob;f\u003dLICENSE;hb\u003d4bc786f34b50aa301be6f5600f58a980070f481e" + ], + "isOsiApproved": false + }, + { + "reference": "./OLDAP-2.2.2.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/OLDAP-2.2.2.json", + "referenceNumber": "181", + "name": "Open LDAP Public License 2.2.2", + "licenseId": "OLDAP-2.2.2", + "seeAlso": [ + "http://www.openldap.org/devel/gitweb.cgi?p\u003dopenldap.git;a\u003dblob;f\u003dLICENSE;hb\u003ddf2cc1e21eb7c160695f5b7cffd6296c151ba188" + ], + "isOsiApproved": false + }, + { + "reference": "./OLDAP-2.3.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/OLDAP-2.3.json", + "referenceNumber": "249", + "name": "Open LDAP Public License v2.3", + "licenseId": "OLDAP-2.3", + "seeAlso": [ + "http://www.openldap.org/devel/gitweb.cgi?p\u003dopenldap.git;a\u003dblob;f\u003dLICENSE;hb\u003dd32cf54a32d581ab475d23c810b0a7fbaf8d63c3" + ], + "isOsiApproved": false + }, + { + "reference": "./OLDAP-2.4.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/OLDAP-2.4.json", + "referenceNumber": "123", + "name": "Open LDAP Public License v2.4", + "licenseId": "OLDAP-2.4", + "seeAlso": [ + "http://www.openldap.org/devel/gitweb.cgi?p\u003dopenldap.git;a\u003dblob;f\u003dLICENSE;hb\u003dcd1284c4a91a8a380d904eee68d1583f989ed386" + ], + "isOsiApproved": false + }, + { + "reference": "./OLDAP-2.5.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/OLDAP-2.5.json", + "referenceNumber": "116", + "name": "Open LDAP Public License v2.5", + "licenseId": "OLDAP-2.5", + "seeAlso": [ + "http://www.openldap.org/devel/gitweb.cgi?p\u003dopenldap.git;a\u003dblob;f\u003dLICENSE;hb\u003d6852b9d90022e8593c98205413380536b1b5a7cf" + ], + "isOsiApproved": false + }, + { + "reference": "./OLDAP-2.6.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/OLDAP-2.6.json", + "referenceNumber": "117", + "name": "Open LDAP Public License v2.6", + "licenseId": "OLDAP-2.6", + "seeAlso": [ + "http://www.openldap.org/devel/gitweb.cgi?p\u003dopenldap.git;a\u003dblob;f\u003dLICENSE;hb\u003d1cae062821881f41b73012ba816434897abf4205" + ], + "isOsiApproved": false + }, + { + "reference": "./OLDAP-2.7.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/OLDAP-2.7.json", + "referenceNumber": "248", + "name": "Open LDAP Public License v2.7", + "licenseId": "OLDAP-2.7", + "seeAlso": [ + "http://www.openldap.org/devel/gitweb.cgi?p\u003dopenldap.git;a\u003dblob;f\u003dLICENSE;hb\u003d47c2415c1df81556eeb39be6cad458ef87c534a2" + ], + "isOsiApproved": false + }, + { + "reference": "./OLDAP-2.8.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/OLDAP-2.8.json", + "referenceNumber": "273", + "name": "Open LDAP Public License v2.8", + "licenseId": "OLDAP-2.8", + "seeAlso": [ + "http://www.openldap.org/software/release/license.html" + ], + "isOsiApproved": false + }, + { + "reference": "./OML.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/OML.json", + "referenceNumber": "182", + "name": "Open Market License", + "licenseId": "OML", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Open_Market_License" + ], + "isOsiApproved": false + }, + { + "reference": "./OPL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/OPL-1.0.json", + "referenceNumber": "367", + "name": "Open Public License v1.0", + "licenseId": "OPL-1.0", + "seeAlso": [ + "http://old.koalateam.com/jackaroo/OPL_1_0.TXT", + "https://fedoraproject.org/wiki/Licensing/Open_Public_License" + ], + "isOsiApproved": false + }, + { + "reference": "./OSET-PL-2.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/OSET-PL-2.1.json", + "referenceNumber": "220", + "name": "OSET Public License version 2.1", + "licenseId": "OSET-PL-2.1", + "seeAlso": [ + "http://www.osetfoundation.org/public-license", + "https://opensource.org/licenses/OPL-2.1" + ], + "isOsiApproved": true + }, + { + "reference": "./OSL-1.0.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/OSL-1.0.json", + "referenceNumber": "103", + "name": "Open Software License 1.0", + "licenseId": "OSL-1.0", + "seeAlso": [ + "https://opensource.org/licenses/OSL-1.0" + ], + "isOsiApproved": true + }, + { + "reference": "./OSL-1.1.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/OSL-1.1.json", + "referenceNumber": "191", + "name": "Open Software License 1.1", + "licenseId": "OSL-1.1", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/OSL1.1" + ], + "isOsiApproved": false + }, + { + "reference": "./OSL-2.0.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/OSL-2.0.json", + "referenceNumber": "394", + "name": "Open Software License 2.0", + "licenseId": "OSL-2.0", + "seeAlso": [ + "http://web.archive.org/web/20041020171434/http://www.rosenlaw.com/osl2.0.html" + ], + "isOsiApproved": true + }, + { + "reference": "./OSL-2.1.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/OSL-2.1.json", + "referenceNumber": "168", + "name": "Open Software License 2.1", + "licenseId": "OSL-2.1", + "seeAlso": [ + "http://web.archive.org/web/20050212003940/http://www.rosenlaw.com/osl21.htm", + "https://opensource.org/licenses/OSL-2.1" + ], + "isOsiApproved": true + }, + { + "reference": "./OSL-3.0.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/OSL-3.0.json", + "referenceNumber": "159", + "name": "Open Software License 3.0", + "licenseId": "OSL-3.0", + "seeAlso": [ + "https://web.archive.org/web/20120101081418/http://rosenlaw.com:80/OSL3.0.htm", + "https://opensource.org/licenses/OSL-3.0" + ], + "isOsiApproved": true + }, + { + "reference": "./OpenSSL.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/OpenSSL.json", + "referenceNumber": "91", + "name": "OpenSSL License", + "licenseId": "OpenSSL", + "seeAlso": [ + "http://www.openssl.org/source/license.html" + ], + "isOsiApproved": false + }, + { + "reference": "./PDDL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/PDDL-1.0.json", + "referenceNumber": "141", + "name": "ODC Public Domain Dedication \u0026 License 1.0", + "licenseId": "PDDL-1.0", + "seeAlso": [ + "http://opendatacommons.org/licenses/pddl/1.0/" + ], + "isOsiApproved": false + }, + { + "reference": "./PHP-3.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/PHP-3.0.json", + "referenceNumber": "207", + "name": "PHP License v3.0", + "licenseId": "PHP-3.0", + "seeAlso": [ + "http://www.php.net/license/3_0.txt", + "https://opensource.org/licenses/PHP-3.0" + ], + "isOsiApproved": true + }, + { + "reference": "./PHP-3.01.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/PHP-3.01.json", + "referenceNumber": "3", + "name": "PHP License v3.01", + "licenseId": "PHP-3.01", + "seeAlso": [ + "http://www.php.net/license/3_01.txt" + ], + "isOsiApproved": true + }, + { + "reference": "./PSF-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/PSF-2.0.json", + "referenceNumber": "99", + "name": "Python Software Foundation License 2.0", + "licenseId": "PSF-2.0", + "seeAlso": [ + "https://opensource.org/licenses/Python-2.0" + ], + "isOsiApproved": false + }, + { + "reference": "./Parity-6.0.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Parity-6.0.0.json", + "referenceNumber": "439", + "name": "The Parity Public License 6.0.0", + "licenseId": "Parity-6.0.0", + "seeAlso": [ + "https://paritylicense.com/versions/6.0.0.html" + ], + "isOsiApproved": false + }, + { + "reference": "./Parity-7.0.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Parity-7.0.0.json", + "referenceNumber": "423", + "name": "The Parity Public License 7.0.0", + "licenseId": "Parity-7.0.0", + "seeAlso": [ + "https://paritylicense.com/versions/7.0.0.html" + ], + "isOsiApproved": false + }, + { + "reference": "./Plexus.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Plexus.json", + "referenceNumber": "166", + "name": "Plexus Classworlds License", + "licenseId": "Plexus", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Plexus_Classworlds_License" + ], + "isOsiApproved": false + }, + { + "reference": "./PolyForm-Noncommercial-1.0.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/PolyForm-Noncommercial-1.0.0.json", + "referenceNumber": "306", + "name": "PolyForm Noncommercial License 1.0.0", + "licenseId": "PolyForm-Noncommercial-1.0.0", + "seeAlso": [ + "https://polyformproject.org/licenses/noncommercial/1.0.0" + ], + "isOsiApproved": false + }, + { + "reference": "./PolyForm-Small-Business-1.0.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/PolyForm-Small-Business-1.0.0.json", + "referenceNumber": "126", + "name": "PolyForm Small Business License 1.0.0", + "licenseId": "PolyForm-Small-Business-1.0.0", + "seeAlso": [ + "https://polyformproject.org/licenses/small-business/1.0.0" + ], + "isOsiApproved": false + }, + { + "reference": "./PostgreSQL.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/PostgreSQL.json", + "referenceNumber": "12", + "name": "PostgreSQL License", + "licenseId": "PostgreSQL", + "seeAlso": [ + "http://www.postgresql.org/about/licence", + "https://opensource.org/licenses/PostgreSQL" + ], + "isOsiApproved": true + }, + { + "reference": "./Python-2.0.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/Python-2.0.json", + "referenceNumber": "425", + "name": "Python License 2.0", + "licenseId": "Python-2.0", + "seeAlso": [ + "https://opensource.org/licenses/Python-2.0" + ], + "isOsiApproved": true + }, + { + "reference": "./QPL-1.0.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/QPL-1.0.json", + "referenceNumber": "314", + "name": "Q Public License 1.0", + "licenseId": "QPL-1.0", + "seeAlso": [ + "http://doc.qt.nokia.com/3.3/license.html", + "https://opensource.org/licenses/QPL-1.0" + ], + "isOsiApproved": true + }, + { + "reference": "./Qhull.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Qhull.json", + "referenceNumber": "133", + "name": "Qhull License", + "licenseId": "Qhull", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Qhull" + ], + "isOsiApproved": false + }, + { + "reference": "./RHeCos-1.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/RHeCos-1.1.json", + "referenceNumber": "67", + "name": "Red Hat eCos Public License v1.1", + "licenseId": "RHeCos-1.1", + "seeAlso": [ + "http://ecos.sourceware.org/old-license.html" + ], + "isOsiApproved": false + }, + { + "reference": "./RPL-1.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/RPL-1.1.json", + "referenceNumber": "233", + "name": "Reciprocal Public License 1.1", + "licenseId": "RPL-1.1", + "seeAlso": [ + "https://opensource.org/licenses/RPL-1.1" + ], + "isOsiApproved": true + }, + { + "reference": "./RPL-1.5.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/RPL-1.5.json", + "referenceNumber": "113", + "name": "Reciprocal Public License 1.5", + "licenseId": "RPL-1.5", + "seeAlso": [ + "https://opensource.org/licenses/RPL-1.5" + ], + "isOsiApproved": true + }, + { + "reference": "./RPSL-1.0.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/RPSL-1.0.json", + "referenceNumber": "58", + "name": "RealNetworks Public Source License v1.0", + "licenseId": "RPSL-1.0", + "seeAlso": [ + "https://helixcommunity.org/content/rpsl", + "https://opensource.org/licenses/RPSL-1.0" + ], + "isOsiApproved": true + }, + { + "reference": "./RSA-MD.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/RSA-MD.json", + "referenceNumber": "302", + "name": "RSA Message-Digest License", + "licenseId": "RSA-MD", + "seeAlso": [ + "http://www.faqs.org/rfcs/rfc1321.html" + ], + "isOsiApproved": false + }, + { + "reference": "./RSCPL.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/RSCPL.json", + "referenceNumber": "368", + "name": "Ricoh Source Code Public License", + "licenseId": "RSCPL", + "seeAlso": [ + "http://wayback.archive.org/web/20060715140826/http://www.risource.org/RPL/RPL-1.0A.shtml", + "https://opensource.org/licenses/RSCPL" + ], + "isOsiApproved": true + }, + { + "reference": "./Rdisc.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Rdisc.json", + "referenceNumber": "350", + "name": "Rdisc License", + "licenseId": "Rdisc", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Rdisc_License" + ], + "isOsiApproved": false + }, + { + "reference": "./Ruby.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/Ruby.json", + "referenceNumber": "15", + "name": "Ruby License", + "licenseId": "Ruby", + "seeAlso": [ + "http://www.ruby-lang.org/en/LICENSE.txt" + ], + "isOsiApproved": false + }, + { + "reference": "./SAX-PD.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/SAX-PD.json", + "referenceNumber": "162", + "name": "Sax Public Domain Notice", + "licenseId": "SAX-PD", + "seeAlso": [ + "http://www.saxproject.org/copying.html" + ], + "isOsiApproved": false + }, + { + "reference": "./SCEA.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/SCEA.json", + "referenceNumber": "146", + "name": "SCEA Shared Source License", + "licenseId": "SCEA", + "seeAlso": [ + "http://research.scea.com/scea_shared_source_license.html" + ], + "isOsiApproved": false + }, + { + "reference": "./SGI-B-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/SGI-B-1.0.json", + "referenceNumber": "204", + "name": "SGI Free Software License B v1.0", + "licenseId": "SGI-B-1.0", + "seeAlso": [ + "http://oss.sgi.com/projects/FreeB/SGIFreeSWLicB.1.0.html" + ], + "isOsiApproved": false + }, + { + "reference": "./SGI-B-1.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/SGI-B-1.1.json", + "referenceNumber": "313", + "name": "SGI Free Software License B v1.1", + "licenseId": "SGI-B-1.1", + "seeAlso": [ + "http://oss.sgi.com/projects/FreeB/" + ], + "isOsiApproved": false + }, + { + "reference": "./SGI-B-2.0.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/SGI-B-2.0.json", + "referenceNumber": "32", + "name": "SGI Free Software License B v2.0", + "licenseId": "SGI-B-2.0", + "seeAlso": [ + "http://oss.sgi.com/projects/FreeB/SGIFreeSWLicB.2.0.pdf" + ], + "isOsiApproved": false + }, + { + "reference": "./SHL-0.5.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/SHL-0.5.json", + "referenceNumber": "53", + "name": "Solderpad Hardware License v0.5", + "licenseId": "SHL-0.5", + "seeAlso": [ + "https://solderpad.org/licenses/SHL-0.5/" + ], + "isOsiApproved": false + }, + { + "reference": "./SHL-0.51.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/SHL-0.51.json", + "referenceNumber": "304", + "name": "Solderpad Hardware License, Version 0.51", + "licenseId": "SHL-0.51", + "seeAlso": [ + "https://solderpad.org/licenses/SHL-0.51/" + ], + "isOsiApproved": false + }, + { + "reference": "./SISSL.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/SISSL.json", + "referenceNumber": "86", + "name": "Sun Industry Standards Source License v1.1", + "licenseId": "SISSL", + "seeAlso": [ + "http://www.openoffice.org/licenses/sissl_license.html", + "https://opensource.org/licenses/SISSL" + ], + "isOsiApproved": true + }, + { + "reference": "./SISSL-1.2.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/SISSL-1.2.json", + "referenceNumber": "68", + "name": "Sun Industry Standards Source License v1.2", + "licenseId": "SISSL-1.2", + "seeAlso": [ + "http://gridscheduler.sourceforge.net/Gridengine_SISSL_license.html" + ], + "isOsiApproved": false + }, + { + "reference": "./SMLNJ.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/SMLNJ.json", + "referenceNumber": "236", + "name": "Standard ML of New Jersey License", + "licenseId": "SMLNJ", + "seeAlso": [ + "https://www.smlnj.org/license.html" + ], + "isOsiApproved": false + }, + { + "reference": "./SMPPL.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/SMPPL.json", + "referenceNumber": "114", + "name": "Secure Messaging Protocol Public License", + "licenseId": "SMPPL", + "seeAlso": [ + "https://github.com/dcblake/SMP/blob/master/Documentation/License.txt" + ], + "isOsiApproved": false + }, + { + "reference": "./SNIA.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/SNIA.json", + "referenceNumber": "330", + "name": "SNIA Public License 1.1", + "licenseId": "SNIA", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/SNIA_Public_License" + ], + "isOsiApproved": false + }, + { + "reference": "./SPL-1.0.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/SPL-1.0.json", + "referenceNumber": "268", + "name": "Sun Public License v1.0", + "licenseId": "SPL-1.0", + "seeAlso": [ + "https://opensource.org/licenses/SPL-1.0" + ], + "isOsiApproved": true + }, + { + "reference": "./SSH-OpenSSH.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/SSH-OpenSSH.json", + "referenceNumber": "23", + "name": "SSH OpenSSH license", + "licenseId": "SSH-OpenSSH", + "seeAlso": [ + "https://github.com/openssh/openssh-portable/blob/1b11ea7c58cd5c59838b5fa574cd456d6047b2d4/LICENCE#L10" + ], + "isOsiApproved": false + }, + { + "reference": "./SSH-short.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/SSH-short.json", + "referenceNumber": "73", + "name": "SSH short notice", + "licenseId": "SSH-short", + "seeAlso": [ + "https://github.com/openssh/openssh-portable/blob/1b11ea7c58cd5c59838b5fa574cd456d6047b2d4/pathnames.h", + "http://web.mit.edu/kolya/.f/root/athena.mit.edu/sipb.mit.edu/project/openssh/OldFiles/src/openssh-2.9.9p2/ssh-add.1", + "https://joinup.ec.europa.eu/svn/lesoll/trunk/italc/lib/src/dsa_key.cpp" + ], + "isOsiApproved": false + }, + { + "reference": "./SSPL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/SSPL-1.0.json", + "referenceNumber": "362", + "name": "Server Side Public License, v 1", + "licenseId": "SSPL-1.0", + "seeAlso": [ + "https://www.mongodb.com/licensing/server-side-public-license" + ], + "isOsiApproved": false + }, + { + "reference": "./SWL.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/SWL.json", + "referenceNumber": "101", + "name": "Scheme Widget Library (SWL) Software License Agreement", + "licenseId": "SWL", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/SWL" + ], + "isOsiApproved": false + }, + { + "reference": "./Saxpath.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Saxpath.json", + "referenceNumber": "35", + "name": "Saxpath License", + "licenseId": "Saxpath", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Saxpath_License" + ], + "isOsiApproved": false + }, + { + "reference": "./Sendmail.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Sendmail.json", + "referenceNumber": "318", + "name": "Sendmail License", + "licenseId": "Sendmail", + "seeAlso": [ + "http://www.sendmail.com/pdfs/open_source/sendmail_license.pdf", + "https://web.archive.org/web/20160322142305/https://www.sendmail.com/pdfs/open_source/sendmail_license.pdf" + ], + "isOsiApproved": false + }, + { + "reference": "./Sendmail-8.23.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Sendmail-8.23.json", + "referenceNumber": "189", + "name": "Sendmail License 8.23", + "licenseId": "Sendmail-8.23", + "seeAlso": [ + "https://www.proofpoint.com/sites/default/files/sendmail-license.pdf", + "https://web.archive.org/web/20181003101040/https://www.proofpoint.com/sites/default/files/sendmail-license.pdf" + ], + "isOsiApproved": false + }, + { + "reference": "./SimPL-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/SimPL-2.0.json", + "referenceNumber": "271", + "name": "Simple Public License 2.0", + "licenseId": "SimPL-2.0", + "seeAlso": [ + "https://opensource.org/licenses/SimPL-2.0" + ], + "isOsiApproved": true + }, + { + "reference": "./Sleepycat.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/Sleepycat.json", + "referenceNumber": "61", + "name": "Sleepycat License", + "licenseId": "Sleepycat", + "seeAlso": [ + "https://opensource.org/licenses/Sleepycat" + ], + "isOsiApproved": true + }, + { + "reference": "./Spencer-86.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Spencer-86.json", + "referenceNumber": "199", + "name": "Spencer License 86", + "licenseId": "Spencer-86", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Henry_Spencer_Reg-Ex_Library_License" + ], + "isOsiApproved": false + }, + { + "reference": "./Spencer-94.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Spencer-94.json", + "referenceNumber": "230", + "name": "Spencer License 94", + "licenseId": "Spencer-94", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Henry_Spencer_Reg-Ex_Library_License" + ], + "isOsiApproved": false + }, + { + "reference": "./Spencer-99.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Spencer-99.json", + "referenceNumber": "70", + "name": "Spencer License 99", + "licenseId": "Spencer-99", + "seeAlso": [ + "http://www.opensource.apple.com/source/tcl/tcl-5/tcl/generic/regfronts.c" + ], + "isOsiApproved": false + }, + { + "reference": "./StandardML-NJ.html", + "isDeprecatedLicenseId": true, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/StandardML-NJ.json", + "referenceNumber": "310", + "name": "Standard ML of New Jersey License", + "licenseId": "StandardML-NJ", + "seeAlso": [ + "http://www.smlnj.org//license.html" + ], + "isOsiApproved": false + }, + { + "reference": "./SugarCRM-1.1.3.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/SugarCRM-1.1.3.json", + "referenceNumber": "371", + "name": "SugarCRM Public License v1.1.3", + "licenseId": "SugarCRM-1.1.3", + "seeAlso": [ + "http://www.sugarcrm.com/crm/SPL" + ], + "isOsiApproved": false + }, + { + "reference": "./TAPR-OHL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/TAPR-OHL-1.0.json", + "referenceNumber": "10", + "name": "TAPR Open Hardware License v1.0", + "licenseId": "TAPR-OHL-1.0", + "seeAlso": [ + "https://www.tapr.org/OHL" + ], + "isOsiApproved": false + }, + { + "reference": "./TCL.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/TCL.json", + "referenceNumber": "59", + "name": "TCL/TK License", + "licenseId": "TCL", + "seeAlso": [ + "http://www.tcl.tk/software/tcltk/license.html", + "https://fedoraproject.org/wiki/Licensing/TCL" + ], + "isOsiApproved": false + }, + { + "reference": "./TCP-wrappers.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/TCP-wrappers.json", + "referenceNumber": "253", + "name": "TCP Wrappers License", + "licenseId": "TCP-wrappers", + "seeAlso": [ + "http://rc.quest.com/topics/openssh/license.php#tcpwrappers" + ], + "isOsiApproved": false + }, + { + "reference": "./TMate.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/TMate.json", + "referenceNumber": "435", + "name": "TMate Open Source License", + "licenseId": "TMate", + "seeAlso": [ + "http://svnkit.com/license.html" + ], + "isOsiApproved": false + }, + { + "reference": "./TORQUE-1.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/TORQUE-1.1.json", + "referenceNumber": "203", + "name": "TORQUE v2.5+ Software License v1.1", + "licenseId": "TORQUE-1.1", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/TORQUEv1.1" + ], + "isOsiApproved": false + }, + { + "reference": "./TOSL.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/TOSL.json", + "referenceNumber": "272", + "name": "Trusster Open Source License", + "licenseId": "TOSL", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/TOSL" + ], + "isOsiApproved": false + }, + { + "reference": "./TU-Berlin-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/TU-Berlin-1.0.json", + "referenceNumber": "403", + "name": "Technische Universitaet Berlin License 1.0", + "licenseId": "TU-Berlin-1.0", + "seeAlso": [ + "https://github.com/swh/ladspa/blob/7bf6f3799fdba70fda297c2d8fd9f526803d9680/gsm/COPYRIGHT" + ], + "isOsiApproved": false + }, + { + "reference": "./TU-Berlin-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/TU-Berlin-2.0.json", + "referenceNumber": "424", + "name": "Technische Universitaet Berlin License 2.0", + "licenseId": "TU-Berlin-2.0", + "seeAlso": [ + "https://github.com/CorsixTH/deps/blob/fd339a9f526d1d9c9f01ccf39e438a015da50035/licences/libgsm.txt" + ], + "isOsiApproved": false + }, + { + "reference": "./UCL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/UCL-1.0.json", + "referenceNumber": "316", + "name": "Upstream Compatibility License v1.0", + "licenseId": "UCL-1.0", + "seeAlso": [ + "https://opensource.org/licenses/UCL-1.0" + ], + "isOsiApproved": true + }, + { + "reference": "./UPL-1.0.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/UPL-1.0.json", + "referenceNumber": "153", + "name": "Universal Permissive License v1.0", + "licenseId": "UPL-1.0", + "seeAlso": [ + "https://opensource.org/licenses/UPL" + ], + "isOsiApproved": true + }, + { + "reference": "./Unicode-DFS-2015.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Unicode-DFS-2015.json", + "referenceNumber": "282", + "name": "Unicode License Agreement - Data Files and Software (2015)", + "licenseId": "Unicode-DFS-2015", + "seeAlso": [ + "https://web.archive.org/web/20151224134844/http://unicode.org/copyright.html" + ], + "isOsiApproved": false + }, + { + "reference": "./Unicode-DFS-2016.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Unicode-DFS-2016.json", + "referenceNumber": "401", + "name": "Unicode License Agreement - Data Files and Software (2016)", + "licenseId": "Unicode-DFS-2016", + "seeAlso": [ + "http://www.unicode.org/copyright.html" + ], + "isOsiApproved": false + }, + { + "reference": "./Unicode-TOU.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Unicode-TOU.json", + "referenceNumber": "17", + "name": "Unicode Terms of Use", + "licenseId": "Unicode-TOU", + "seeAlso": [ + "http://www.unicode.org/copyright.html" + ], + "isOsiApproved": false + }, + { + "reference": "./Unlicense.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/Unlicense.json", + "referenceNumber": "185", + "name": "The Unlicense", + "licenseId": "Unlicense", + "seeAlso": [ + "https://unlicense.org/" + ], + "isOsiApproved": true + }, + { + "reference": "./VOSTROM.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/VOSTROM.json", + "referenceNumber": "382", + "name": "VOSTROM Public License for Open Source", + "licenseId": "VOSTROM", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/VOSTROM" + ], + "isOsiApproved": false + }, + { + "reference": "./VSL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/VSL-1.0.json", + "referenceNumber": "421", + "name": "Vovida Software License v1.0", + "licenseId": "VSL-1.0", + "seeAlso": [ + "https://opensource.org/licenses/VSL-1.0" + ], + "isOsiApproved": true + }, + { + "reference": "./Vim.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/Vim.json", + "referenceNumber": "223", + "name": "Vim License", + "licenseId": "Vim", + "seeAlso": [ + "http://vimdoc.sourceforge.net/htmldoc/uganda.html" + ], + "isOsiApproved": false + }, + { + "reference": "./W3C.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/W3C.json", + "referenceNumber": "115", + "name": "W3C Software Notice and License (2002-12-31)", + "licenseId": "W3C", + "seeAlso": [ + "http://www.w3.org/Consortium/Legal/2002/copyright-software-20021231.html", + "https://opensource.org/licenses/W3C" + ], + "isOsiApproved": true + }, + { + "reference": "./W3C-19980720.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/W3C-19980720.json", + "referenceNumber": "288", + "name": "W3C Software Notice and License (1998-07-20)", + "licenseId": "W3C-19980720", + "seeAlso": [ + "http://www.w3.org/Consortium/Legal/copyright-software-19980720.html" + ], + "isOsiApproved": false + }, + { + "reference": "./W3C-20150513.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/W3C-20150513.json", + "referenceNumber": "119", + "name": "W3C Software Notice and Document License (2015-05-13)", + "licenseId": "W3C-20150513", + "seeAlso": [ + "https://www.w3.org/Consortium/Legal/2015/copyright-software-and-document" + ], + "isOsiApproved": false + }, + { + "reference": "./WTFPL.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/WTFPL.json", + "referenceNumber": "21", + "name": "Do What The F*ck You Want To Public License", + "licenseId": "WTFPL", + "seeAlso": [ + "http://www.wtfpl.net/about/", + "http://sam.zoy.org/wtfpl/COPYING" + ], + "isOsiApproved": false + }, + { + "reference": "./Watcom-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Watcom-1.0.json", + "referenceNumber": "150", + "name": "Sybase Open Watcom Public License 1.0", + "licenseId": "Watcom-1.0", + "seeAlso": [ + "https://opensource.org/licenses/Watcom-1.0" + ], + "isOsiApproved": true + }, + { + "reference": "./Wsuipa.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Wsuipa.json", + "referenceNumber": "276", + "name": "Wsuipa License", + "licenseId": "Wsuipa", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Wsuipa" + ], + "isOsiApproved": false + }, + { + "reference": "./X11.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/X11.json", + "referenceNumber": "107", + "name": "X11 License", + "licenseId": "X11", + "seeAlso": [ + "http://www.xfree86.org/3.3.6/COPYRIGHT2.html#3" + ], + "isOsiApproved": false + }, + { + "reference": "./XFree86-1.1.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/XFree86-1.1.json", + "referenceNumber": "165", + "name": "XFree86 License 1.1", + "licenseId": "XFree86-1.1", + "seeAlso": [ + "http://www.xfree86.org/current/LICENSE4.html" + ], + "isOsiApproved": false + }, + { + "reference": "./XSkat.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/XSkat.json", + "referenceNumber": "89", + "name": "XSkat License", + "licenseId": "XSkat", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/XSkat_License" + ], + "isOsiApproved": false + }, + { + "reference": "./Xerox.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Xerox.json", + "referenceNumber": "243", + "name": "Xerox License", + "licenseId": "Xerox", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Xerox" + ], + "isOsiApproved": false + }, + { + "reference": "./Xnet.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Xnet.json", + "referenceNumber": "341", + "name": "X.Net License", + "licenseId": "Xnet", + "seeAlso": [ + "https://opensource.org/licenses/Xnet" + ], + "isOsiApproved": true + }, + { + "reference": "./YPL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/YPL-1.0.json", + "referenceNumber": "317", + "name": "Yahoo! Public License v1.0", + "licenseId": "YPL-1.0", + "seeAlso": [ + "http://www.zimbra.com/license/yahoo_public_license_1.0.html" + ], + "isOsiApproved": false + }, + { + "reference": "./YPL-1.1.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/YPL-1.1.json", + "referenceNumber": "42", + "name": "Yahoo! Public License v1.1", + "licenseId": "YPL-1.1", + "seeAlso": [ + "http://www.zimbra.com/license/yahoo_public_license_1.1.html" + ], + "isOsiApproved": false + }, + { + "reference": "./ZPL-1.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/ZPL-1.1.json", + "referenceNumber": "93", + "name": "Zope Public License 1.1", + "licenseId": "ZPL-1.1", + "seeAlso": [ + "http://old.zope.org/Resources/License/ZPL-1.1" + ], + "isOsiApproved": false + }, + { + "reference": "./ZPL-2.0.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/ZPL-2.0.json", + "referenceNumber": "120", + "name": "Zope Public License 2.0", + "licenseId": "ZPL-2.0", + "seeAlso": [ + "http://old.zope.org/Resources/License/ZPL-2.0", + "https://opensource.org/licenses/ZPL-2.0" + ], + "isOsiApproved": true + }, + { + "reference": "./ZPL-2.1.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/ZPL-2.1.json", + "referenceNumber": "399", + "name": "Zope Public License 2.1", + "licenseId": "ZPL-2.1", + "seeAlso": [ + "http://old.zope.org/Resources/ZPL/" + ], + "isOsiApproved": false + }, + { + "reference": "./Zed.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Zed.json", + "referenceNumber": "122", + "name": "Zed License", + "licenseId": "Zed", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Zed" + ], + "isOsiApproved": false + }, + { + "reference": "./Zend-2.0.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/Zend-2.0.json", + "referenceNumber": "404", + "name": "Zend License v2.0", + "licenseId": "Zend-2.0", + "seeAlso": [ + "https://web.archive.org/web/20130517195954/http://www.zend.com/license/2_00.txt" + ], + "isOsiApproved": false + }, + { + "reference": "./Zimbra-1.3.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/Zimbra-1.3.json", + "referenceNumber": "188", + "name": "Zimbra Public License v1.3", + "licenseId": "Zimbra-1.3", + "seeAlso": [ + "http://web.archive.org/web/20100302225219/http://www.zimbra.com/license/zimbra-public-license-1-3.html" + ], + "isOsiApproved": false + }, + { + "reference": "./Zimbra-1.4.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/Zimbra-1.4.json", + "referenceNumber": "416", + "name": "Zimbra Public License v1.4", + "licenseId": "Zimbra-1.4", + "seeAlso": [ + "http://www.zimbra.com/legal/zimbra-public-license-1-4" + ], + "isOsiApproved": false + }, + { + "reference": "./Zlib.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/Zlib.json", + "referenceNumber": "47", + "name": "zlib License", + "licenseId": "Zlib", + "seeAlso": [ + "http://www.zlib.net/zlib_license.html", + "https://opensource.org/licenses/Zlib" + ], + "isOsiApproved": true + }, + { + "reference": "./blessing.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/blessing.json", + "referenceNumber": "329", + "name": "SQLite Blessing", + "licenseId": "blessing", + "seeAlso": [ + "https://www.sqlite.org/src/artifact/e33a4df7e32d742a?ln\u003d4-9", + "https://sqlite.org/src/artifact/df5091916dbb40e6" + ], + "isOsiApproved": false + }, + { + "reference": "./bzip2-1.0.5.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/bzip2-1.0.5.json", + "referenceNumber": "201", + "name": "bzip2 and libbzip2 License v1.0.5", + "licenseId": "bzip2-1.0.5", + "seeAlso": [ + "https://sourceware.org/bzip2/1.0.5/bzip2-manual-1.0.5.html", + "http://bzip.org/1.0.5/bzip2-manual-1.0.5.html" + ], + "isOsiApproved": false + }, + { + "reference": "./bzip2-1.0.6.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/bzip2-1.0.6.json", + "referenceNumber": "75", + "name": "bzip2 and libbzip2 License v1.0.6", + "licenseId": "bzip2-1.0.6", + "seeAlso": [ + "https://sourceware.org/git/?p\u003dbzip2.git;a\u003dblob;f\u003dLICENSE;hb\u003dbzip2-1.0.6", + "http://bzip.org/1.0.5/bzip2-manual-1.0.5.html" + ], + "isOsiApproved": false + }, + { + "reference": "./copyleft-next-0.3.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/copyleft-next-0.3.0.json", + "referenceNumber": "340", + "name": "copyleft-next 0.3.0", + "licenseId": "copyleft-next-0.3.0", + "seeAlso": [ + "https://github.com/copyleft-next/copyleft-next/blob/master/Releases/copyleft-next-0.3.0" + ], + "isOsiApproved": false + }, + { + "reference": "./copyleft-next-0.3.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/copyleft-next-0.3.1.json", + "referenceNumber": "409", + "name": "copyleft-next 0.3.1", + "licenseId": "copyleft-next-0.3.1", + "seeAlso": [ + "https://github.com/copyleft-next/copyleft-next/blob/master/Releases/copyleft-next-0.3.1" + ], + "isOsiApproved": false + }, + { + "reference": "./curl.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/curl.json", + "referenceNumber": "342", + "name": "curl License", + "licenseId": "curl", + "seeAlso": [ + "https://github.com/bagder/curl/blob/master/COPYING" + ], + "isOsiApproved": false + }, + { + "reference": "./diffmark.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/diffmark.json", + "referenceNumber": "430", + "name": "diffmark license", + "licenseId": "diffmark", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/diffmark" + ], + "isOsiApproved": false + }, + { + "reference": "./dvipdfm.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/dvipdfm.json", + "referenceNumber": "20", + "name": "dvipdfm License", + "licenseId": "dvipdfm", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/dvipdfm" + ], + "isOsiApproved": false + }, + { + "reference": "./eCos-2.0.html", + "isDeprecatedLicenseId": true, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/eCos-2.0.json", + "referenceNumber": "295", + "name": "eCos license version 2.0", + "licenseId": "eCos-2.0", + "seeAlso": [ + "https://www.gnu.org/licenses/ecos-license.html" + ], + "isOsiApproved": false + }, + { + "reference": "./eGenix.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/eGenix.json", + "referenceNumber": "231", + "name": "eGenix.com Public License 1.1.0", + "licenseId": "eGenix", + "seeAlso": [ + "http://www.egenix.com/products/eGenix.com-Public-License-1.1.0.pdf", + "https://fedoraproject.org/wiki/Licensing/eGenix.com_Public_License_1.1.0" + ], + "isOsiApproved": false + }, + { + "reference": "./etalab-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/etalab-2.0.json", + "referenceNumber": "281", + "name": "Etalab Open License 2.0", + "licenseId": "etalab-2.0", + "seeAlso": [ + "https://github.com/DISIC/politique-de-contribution-open-source/blob/master/LICENSE.pdf", + "https://raw.githubusercontent.com/DISIC/politique-de-contribution-open-source/master/LICENSE" + ], + "isOsiApproved": false + }, + { + "reference": "./gSOAP-1.3b.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/gSOAP-1.3b.json", + "referenceNumber": "178", + "name": "gSOAP Public License v1.3b", + "licenseId": "gSOAP-1.3b", + "seeAlso": [ + "http://www.cs.fsu.edu/~engelen/license.html" + ], + "isOsiApproved": false + }, + { + "reference": "./gnuplot.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/gnuplot.json", + "referenceNumber": "414", + "name": "gnuplot License", + "licenseId": "gnuplot", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Gnuplot" + ], + "isOsiApproved": false + }, + { + "reference": "./iMatix.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/iMatix.json", + "referenceNumber": "190", + "name": "iMatix Standard Function Library Agreement", + "licenseId": "iMatix", + "seeAlso": [ + "http://legacy.imatix.com/html/sfl/sfl4.htm#license" + ], + "isOsiApproved": false + }, + { + "reference": "./libpng-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/libpng-2.0.json", + "referenceNumber": "111", + "name": "PNG Reference Library version 2", + "licenseId": "libpng-2.0", + "seeAlso": [ + "http://www.libpng.org/pub/png/src/libpng-LICENSE.txt" + ], + "isOsiApproved": false + }, + { + "reference": "./libselinux-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/libselinux-1.0.json", + "referenceNumber": "19", + "name": "libselinux public domain notice", + "licenseId": "libselinux-1.0", + "seeAlso": [ + "https://github.com/SELinuxProject/selinux/blob/master/libselinux/LICENSE" + ], + "isOsiApproved": false + }, + { + "reference": "./libtiff.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/libtiff.json", + "referenceNumber": "440", + "name": "libtiff License", + "licenseId": "libtiff", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/libtiff" + ], + "isOsiApproved": false + }, + { + "reference": "./mpich2.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/mpich2.json", + "referenceNumber": "66", + "name": "mpich2 License", + "licenseId": "mpich2", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/MIT" + ], + "isOsiApproved": false + }, + { + "reference": "./psfrag.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/psfrag.json", + "referenceNumber": "441", + "name": "psfrag License", + "licenseId": "psfrag", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/psfrag" + ], + "isOsiApproved": false + }, + { + "reference": "./psutils.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/psutils.json", + "referenceNumber": "300", + "name": "psutils License", + "licenseId": "psutils", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/psutils" + ], + "isOsiApproved": false + }, + { + "reference": "./wxWindows.html", + "isDeprecatedLicenseId": true, + "detailsUrl": "http://spdx.org/licenses/wxWindows.json", + "referenceNumber": "264", + "name": "wxWindows Library License", + "licenseId": "wxWindows", + "seeAlso": [ + "https://opensource.org/licenses/WXwindows" + ], + "isOsiApproved": false + }, + { + "reference": "./xinetd.html", + "isDeprecatedLicenseId": false, + "isFsfLibre": true, + "detailsUrl": "http://spdx.org/licenses/xinetd.json", + "referenceNumber": "432", + "name": "xinetd License", + "licenseId": "xinetd", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Xinetd_License" + ], + "isOsiApproved": false + }, + { + "reference": "./xpp.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/xpp.json", + "referenceNumber": "104", + "name": "XPP License", + "licenseId": "xpp", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/xpp" + ], + "isOsiApproved": false + }, + { + "reference": "./zlib-acknowledgement.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "http://spdx.org/licenses/zlib-acknowledgement.json", + "referenceNumber": "266", + "name": "zlib/libpng License with Acknowledgement", + "licenseId": "zlib-acknowledgement", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/ZlibWithAcknowledgement" + ], + "isOsiApproved": false + } + ], + "releaseDate": "2020-08-03" +} diff --git a/cabal/license-list-data/licenses-3.16.json b/cabal/license-list-data/licenses-3.16.json new file mode 100644 --- /dev/null +++ b/cabal/license-list-data/licenses-3.16.json @@ -0,0 +1,6090 @@ +{ + "licenseListVersion": "3.16", + "licenses": [ + { + "reference": "https://spdx.org/licenses/Interbase-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Interbase-1.0.json", + "referenceNumber": 0, + "name": "Interbase Public License v1.0", + "licenseId": "Interbase-1.0", + "seeAlso": [ + "https://web.archive.org/web/20060319014854/http://info.borland.com/devsupport/interbase/opensource/IPL.html" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/Mup.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Mup.json", + "referenceNumber": 1, + "name": "Mup License", + "licenseId": "Mup", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Mup" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/GPL-2.0-with-autoconf-exception.html", + "isDeprecatedLicenseId": true, + "detailsUrl": "https://spdx.org/licenses/GPL-2.0-with-autoconf-exception.json", + "referenceNumber": 2, + "name": "GNU General Public License v2.0 w/Autoconf exception", + "licenseId": "GPL-2.0-with-autoconf-exception", + "seeAlso": [ + "http://ac-archive.sourceforge.net/doc/copyright.html" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/OLDAP-2.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/OLDAP-2.1.json", + "referenceNumber": 3, + "name": "Open LDAP Public License v2.1", + "licenseId": "OLDAP-2.1", + "seeAlso": [ + "http://www.openldap.org/devel/gitweb.cgi?p\u003dopenldap.git;a\u003dblob;f\u003dLICENSE;hb\u003db0d176738e96a0d3b9f85cb51e140a86f21be715" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/CC-BY-NC-SA-3.0-IGO.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CC-BY-NC-SA-3.0-IGO.json", + "referenceNumber": 4, + "name": "Creative Commons Attribution Non Commercial Share Alike 3.0 IGO", + "licenseId": "CC-BY-NC-SA-3.0-IGO", + "seeAlso": [ + "https://creativecommons.org/licenses/by-nc-sa/3.0/igo/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/LGPL-2.0+.html", + "isDeprecatedLicenseId": true, + "detailsUrl": "https://spdx.org/licenses/LGPL-2.0+.json", + "referenceNumber": 5, + "name": "GNU Library General Public License v2 or later", + "licenseId": "LGPL-2.0+", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/lgpl-2.0-standalone.html" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/xpp.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/xpp.json", + "referenceNumber": 6, + "name": "XPP License", + "licenseId": "xpp", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/xpp" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/OFL-1.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/OFL-1.1.json", + "referenceNumber": 7, + "name": "SIL Open Font License 1.1", + "licenseId": "OFL-1.1", + "seeAlso": [ + "http://scripts.sil.org/cms/scripts/page.php?item_id\u003dOFL_web", + "https://opensource.org/licenses/OFL-1.1" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/CNRI-Python.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CNRI-Python.json", + "referenceNumber": 8, + "name": "CNRI Python License", + "licenseId": "CNRI-Python", + "seeAlso": [ + "https://opensource.org/licenses/CNRI-Python" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/Linux-man-pages-copyleft.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Linux-man-pages-copyleft.json", + "referenceNumber": 9, + "name": "Linux man-pages Copyleft", + "licenseId": "Linux-man-pages-copyleft", + "seeAlso": [ + "https://www.kernel.org/doc/man-pages/licenses.html" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/OLDAP-2.2.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/OLDAP-2.2.json", + "referenceNumber": 10, + "name": "Open LDAP Public License v2.2", + "licenseId": "OLDAP-2.2", + "seeAlso": [ + "http://www.openldap.org/devel/gitweb.cgi?p\u003dopenldap.git;a\u003dblob;f\u003dLICENSE;hb\u003d470b0c18ec67621c85881b2733057fecf4a1acc3" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/OSL-1.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/OSL-1.1.json", + "referenceNumber": 11, + "name": "Open Software License 1.1", + "licenseId": "OSL-1.1", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/OSL1.1" + ], + "isOsiApproved": false, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/EPL-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/EPL-2.0.json", + "referenceNumber": 12, + "name": "Eclipse Public License 2.0", + "licenseId": "EPL-2.0", + "seeAlso": [ + "https://www.eclipse.org/legal/epl-2.0", + "https://www.opensource.org/licenses/EPL-2.0" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/AFL-1.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/AFL-1.1.json", + "referenceNumber": 13, + "name": "Academic Free License v1.1", + "licenseId": "AFL-1.1", + "seeAlso": [ + "http://opensource.linux-mirror.org/licenses/afl-1.1.txt", + "http://wayback.archive.org/web/20021004124254/http://www.opensource.org/licenses/academic.php" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/AGPL-1.0-or-later.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/AGPL-1.0-or-later.json", + "referenceNumber": 14, + "name": "Affero General Public License v1.0 or later", + "licenseId": "AGPL-1.0-or-later", + "seeAlso": [ + "http://www.affero.org/oagpl.html" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/GLWTPL.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/GLWTPL.json", + "referenceNumber": 15, + "name": "Good Luck With That Public License", + "licenseId": "GLWTPL", + "seeAlso": [ + "https://github.com/me-shaon/GLWTPL/commit/da5f6bc734095efbacb442c0b31e33a65b9d6e85" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/MIT-Modern-Variant.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/MIT-Modern-Variant.json", + "referenceNumber": 16, + "name": "MIT License Modern Variant", + "licenseId": "MIT-Modern-Variant", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing:MIT#Modern_Variants", + "https://ptolemy.berkeley.edu/copyright.htm", + "https://pirlwww.lpl.arizona.edu/resources/guide/software/PerlTk/Tixlic.html" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/BSD-1-Clause.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/BSD-1-Clause.json", + "referenceNumber": 17, + "name": "BSD 1-Clause License", + "licenseId": "BSD-1-Clause", + "seeAlso": [ + "https://svnweb.freebsd.org/base/head/include/ifaddrs.h?revision\u003d326823" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/SGI-B-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/SGI-B-1.0.json", + "referenceNumber": 18, + "name": "SGI Free Software License B v1.0", + "licenseId": "SGI-B-1.0", + "seeAlso": [ + "http://oss.sgi.com/projects/FreeB/SGIFreeSWLicB.1.0.html" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/OML.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/OML.json", + "referenceNumber": 19, + "name": "Open Market License", + "licenseId": "OML", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Open_Market_License" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/psfrag.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/psfrag.json", + "referenceNumber": 20, + "name": "psfrag License", + "licenseId": "psfrag", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/psfrag" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/Artistic-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Artistic-1.0.json", + "referenceNumber": 21, + "name": "Artistic License 1.0", + "licenseId": "Artistic-1.0", + "seeAlso": [ + "https://opensource.org/licenses/Artistic-1.0" + ], + "isOsiApproved": true, + "isFsfLibre": false + }, + { + "reference": "https://spdx.org/licenses/CC-PDDC.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CC-PDDC.json", + "referenceNumber": 22, + "name": "Creative Commons Public Domain Dedication and Certification", + "licenseId": "CC-PDDC", + "seeAlso": [ + "https://creativecommons.org/licenses/publicdomain/" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/eGenix.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/eGenix.json", + "referenceNumber": 23, + "name": "eGenix.com Public License 1.1.0", + "licenseId": "eGenix", + "seeAlso": [ + "http://www.egenix.com/products/eGenix.com-Public-License-1.1.0.pdf", + "https://fedoraproject.org/wiki/Licensing/eGenix.com_Public_License_1.1.0" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/EUPL-1.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/EUPL-1.1.json", + "referenceNumber": 24, + "name": "European Union Public License 1.1", + "licenseId": "EUPL-1.1", + "seeAlso": [ + "https://joinup.ec.europa.eu/software/page/eupl/licence-eupl", + "https://joinup.ec.europa.eu/sites/default/files/custom-page/attachment/eupl1.1.-licence-en_0.pdf", + "https://opensource.org/licenses/EUPL-1.1" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/Sendmail.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Sendmail.json", + "referenceNumber": 25, + "name": "Sendmail License", + "licenseId": "Sendmail", + "seeAlso": [ + "http://www.sendmail.com/pdfs/open_source/sendmail_license.pdf", + "https://web.archive.org/web/20160322142305/https://www.sendmail.com/pdfs/open_source/sendmail_license.pdf" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/PSF-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/PSF-2.0.json", + "referenceNumber": 26, + "name": "Python Software Foundation License 2.0", + "licenseId": "PSF-2.0", + "seeAlso": [ + "https://opensource.org/licenses/Python-2.0" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/OGL-UK-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/OGL-UK-1.0.json", + "referenceNumber": 27, + "name": "Open Government Licence v1.0", + "licenseId": "OGL-UK-1.0", + "seeAlso": [ + "http://www.nationalarchives.gov.uk/doc/open-government-licence/version/1/" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/MTLL.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/MTLL.json", + "referenceNumber": 28, + "name": "Matrix Template Library License", + "licenseId": "MTLL", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Matrix_Template_Library_License" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/NAIST-2003.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/NAIST-2003.json", + "referenceNumber": 29, + "name": "Nara Institute of Science and Technology License (2003)", + "licenseId": "NAIST-2003", + "seeAlso": [ + "https://enterprise.dejacode.com/licenses/public/naist-2003/#license-text", + "https://github.com/nodejs/node/blob/4a19cc8947b1bba2b2d27816ec3d0edf9b28e503/LICENSE#L343" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/ANTLR-PD-fallback.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/ANTLR-PD-fallback.json", + "referenceNumber": 30, + "name": "ANTLR Software Rights Notice with license fallback", + "licenseId": "ANTLR-PD-fallback", + "seeAlso": [ + "http://www.antlr2.org/license.html" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/PostgreSQL.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/PostgreSQL.json", + "referenceNumber": 31, + "name": "PostgreSQL License", + "licenseId": "PostgreSQL", + "seeAlso": [ + "http://www.postgresql.org/about/licence", + "https://opensource.org/licenses/PostgreSQL" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/OSL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/OSL-1.0.json", + "referenceNumber": 32, + "name": "Open Software License 1.0", + "licenseId": "OSL-1.0", + "seeAlso": [ + "https://opensource.org/licenses/OSL-1.0" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/NGPL.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/NGPL.json", + "referenceNumber": 33, + "name": "Nethack General Public License", + "licenseId": "NGPL", + "seeAlso": [ + "https://opensource.org/licenses/NGPL" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/CC-BY-NC-ND-4.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CC-BY-NC-ND-4.0.json", + "referenceNumber": 34, + "name": "Creative Commons Attribution Non Commercial No Derivatives 4.0 International", + "licenseId": "CC-BY-NC-ND-4.0", + "seeAlso": [ + "https://creativecommons.org/licenses/by-nc-nd/4.0/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/CPOL-1.02.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CPOL-1.02.json", + "referenceNumber": 35, + "name": "Code Project Open License 1.02", + "licenseId": "CPOL-1.02", + "seeAlso": [ + "http://www.codeproject.com/info/cpol10.aspx" + ], + "isOsiApproved": false, + "isFsfLibre": false + }, + { + "reference": "https://spdx.org/licenses/FSFULLR.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/FSFULLR.json", + "referenceNumber": 36, + "name": "FSF Unlimited License (with License Retention)", + "licenseId": "FSFULLR", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/FSF_Unlimited_License#License_Retention_Variant" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/GFDL-1.2-no-invariants-only.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/GFDL-1.2-no-invariants-only.json", + "referenceNumber": 37, + "name": "GNU Free Documentation License v1.2 only - no invariants", + "licenseId": "GFDL-1.2-no-invariants-only", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/fdl-1.2.txt" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/Net-SNMP.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Net-SNMP.json", + "referenceNumber": 38, + "name": "Net-SNMP License", + "licenseId": "Net-SNMP", + "seeAlso": [ + "http://net-snmp.sourceforge.net/about/license.html" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/ADSL.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/ADSL.json", + "referenceNumber": 39, + "name": "Amazon Digital Services License", + "licenseId": "ADSL", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/AmazonDigitalServicesLicense" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/Sendmail-8.23.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Sendmail-8.23.json", + "referenceNumber": 40, + "name": "Sendmail License 8.23", + "licenseId": "Sendmail-8.23", + "seeAlso": [ + "https://www.proofpoint.com/sites/default/files/sendmail-license.pdf", + "https://web.archive.org/web/20181003101040/https://www.proofpoint.com/sites/default/files/sendmail-license.pdf" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/CNRI-Jython.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CNRI-Jython.json", + "referenceNumber": 41, + "name": "CNRI Jython License", + "licenseId": "CNRI-Jython", + "seeAlso": [ + "http://www.jython.org/license.html" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/RPL-1.5.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/RPL-1.5.json", + "referenceNumber": 42, + "name": "Reciprocal Public License 1.5", + "licenseId": "RPL-1.5", + "seeAlso": [ + "https://opensource.org/licenses/RPL-1.5" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/BSD-2-Clause-Patent.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/BSD-2-Clause-Patent.json", + "referenceNumber": 43, + "name": "BSD-2-Clause Plus Patent License", + "licenseId": "BSD-2-Clause-Patent", + "seeAlso": [ + "https://opensource.org/licenses/BSDplusPatent" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/OFL-1.1-no-RFN.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/OFL-1.1-no-RFN.json", + "referenceNumber": 44, + "name": "SIL Open Font License 1.1 with no Reserved Font Name", + "licenseId": "OFL-1.1-no-RFN", + "seeAlso": [ + "http://scripts.sil.org/cms/scripts/page.php?item_id\u003dOFL_web", + "https://opensource.org/licenses/OFL-1.1" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/APSL-1.2.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/APSL-1.2.json", + "referenceNumber": 45, + "name": "Apple Public Source License 1.2", + "licenseId": "APSL-1.2", + "seeAlso": [ + "http://www.samurajdata.se/opensource/mirror/licenses/apsl.php" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/OLDAP-2.4.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/OLDAP-2.4.json", + "referenceNumber": 46, + "name": "Open LDAP Public License v2.4", + "licenseId": "OLDAP-2.4", + "seeAlso": [ + "http://www.openldap.org/devel/gitweb.cgi?p\u003dopenldap.git;a\u003dblob;f\u003dLICENSE;hb\u003dcd1284c4a91a8a380d904eee68d1583f989ed386" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/MPL-2.0-no-copyleft-exception.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/MPL-2.0-no-copyleft-exception.json", + "referenceNumber": 47, + "name": "Mozilla Public License 2.0 (no copyleft exception)", + "licenseId": "MPL-2.0-no-copyleft-exception", + "seeAlso": [ + "https://www.mozilla.org/MPL/2.0/", + "https://opensource.org/licenses/MPL-2.0" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/ISC.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/ISC.json", + "referenceNumber": 48, + "name": "ISC License", + "licenseId": "ISC", + "seeAlso": [ + "https://www.isc.org/licenses/", + "https://www.isc.org/downloads/software-support-policy/isc-license/", + "https://opensource.org/licenses/ISC" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/CC-BY-SA-2.5.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CC-BY-SA-2.5.json", + "referenceNumber": 49, + "name": "Creative Commons Attribution Share Alike 2.5 Generic", + "licenseId": "CC-BY-SA-2.5", + "seeAlso": [ + "https://creativecommons.org/licenses/by-sa/2.5/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/Sleepycat.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Sleepycat.json", + "referenceNumber": 50, + "name": "Sleepycat License", + "licenseId": "Sleepycat", + "seeAlso": [ + "https://opensource.org/licenses/Sleepycat" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/CUA-OPL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CUA-OPL-1.0.json", + "referenceNumber": 51, + "name": "CUA Office Public License v1.0", + "licenseId": "CUA-OPL-1.0", + "seeAlso": [ + "https://opensource.org/licenses/CUA-OPL-1.0" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/Frameworx-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Frameworx-1.0.json", + "referenceNumber": 52, + "name": "Frameworx Open License 1.0", + "licenseId": "Frameworx-1.0", + "seeAlso": [ + "https://opensource.org/licenses/Frameworx-1.0" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/CPAL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CPAL-1.0.json", + "referenceNumber": 53, + "name": "Common Public Attribution License 1.0", + "licenseId": "CPAL-1.0", + "seeAlso": [ + "https://opensource.org/licenses/CPAL-1.0" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/NLOD-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/NLOD-2.0.json", + "referenceNumber": 54, + "name": "Norwegian Licence for Open Government Data (NLOD) 2.0", + "licenseId": "NLOD-2.0", + "seeAlso": [ + "http://data.norge.no/nlod/en/2.0" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/CC-BY-NC-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CC-BY-NC-2.0.json", + "referenceNumber": 55, + "name": "Creative Commons Attribution Non Commercial 2.0 Generic", + "licenseId": "CC-BY-NC-2.0", + "seeAlso": [ + "https://creativecommons.org/licenses/by-nc/2.0/legalcode" + ], + "isOsiApproved": false, + "isFsfLibre": false + }, + { + "reference": "https://spdx.org/licenses/GFDL-1.1-no-invariants-or-later.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/GFDL-1.1-no-invariants-or-later.json", + "referenceNumber": 56, + "name": "GNU Free Documentation License v1.1 or later - no invariants", + "licenseId": "GFDL-1.1-no-invariants-or-later", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/fdl-1.1.txt" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/CC-BY-2.5.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CC-BY-2.5.json", + "referenceNumber": 57, + "name": "Creative Commons Attribution 2.5 Generic", + "licenseId": "CC-BY-2.5", + "seeAlso": [ + "https://creativecommons.org/licenses/by/2.5/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/Newsletr.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Newsletr.json", + "referenceNumber": 58, + "name": "Newsletr License", + "licenseId": "Newsletr", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Newsletr" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/Parity-7.0.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Parity-7.0.0.json", + "referenceNumber": 59, + "name": "The Parity Public License 7.0.0", + "licenseId": "Parity-7.0.0", + "seeAlso": [ + "https://paritylicense.com/versions/7.0.0.html" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/Leptonica.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Leptonica.json", + "referenceNumber": 60, + "name": "Leptonica License", + "licenseId": "Leptonica", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Leptonica" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/MIT-CMU.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/MIT-CMU.json", + "referenceNumber": 61, + "name": "CMU License", + "licenseId": "MIT-CMU", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing:MIT?rd\u003dLicensing/MIT#CMU_Style", + "https://github.com/python-pillow/Pillow/blob/fffb426092c8db24a5f4b6df243a8a3c01fb63cd/LICENSE" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/APAFML.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/APAFML.json", + "referenceNumber": 62, + "name": "Adobe Postscript AFM License", + "licenseId": "APAFML", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/AdobePostscriptAFM" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/CC-BY-NC-2.5.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CC-BY-NC-2.5.json", + "referenceNumber": 63, + "name": "Creative Commons Attribution Non Commercial 2.5 Generic", + "licenseId": "CC-BY-NC-2.5", + "seeAlso": [ + "https://creativecommons.org/licenses/by-nc/2.5/legalcode" + ], + "isOsiApproved": false, + "isFsfLibre": false + }, + { + "reference": "https://spdx.org/licenses/CAL-1.0-Combined-Work-Exception.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CAL-1.0-Combined-Work-Exception.json", + "referenceNumber": 64, + "name": "Cryptographic Autonomy License 1.0 (Combined Work Exception)", + "licenseId": "CAL-1.0-Combined-Work-Exception", + "seeAlso": [ + "http://cryptographicautonomylicense.com/license-text.html", + "https://opensource.org/licenses/CAL-1.0" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/BSD-4-Clause-Shortened.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/BSD-4-Clause-Shortened.json", + "referenceNumber": 65, + "name": "BSD 4 Clause Shortened", + "licenseId": "BSD-4-Clause-Shortened", + "seeAlso": [ + "https://metadata.ftp-master.debian.org/changelogs//main/a/arpwatch/arpwatch_2.1a15-7_copyright" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/NPL-1.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/NPL-1.1.json", + "referenceNumber": 66, + "name": "Netscape Public License v1.1", + "licenseId": "NPL-1.1", + "seeAlso": [ + "http://www.mozilla.org/MPL/NPL/1.1/" + ], + "isOsiApproved": false, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/Qhull.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Qhull.json", + "referenceNumber": 67, + "name": "Qhull License", + "licenseId": "Qhull", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Qhull" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/CECILL-C.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CECILL-C.json", + "referenceNumber": 68, + "name": "CeCILL-C Free Software License Agreement", + "licenseId": "CECILL-C", + "seeAlso": [ + "http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html" + ], + "isOsiApproved": false, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/GPL-1.0-only.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/GPL-1.0-only.json", + "referenceNumber": 69, + "name": "GNU General Public License v1.0 only", + "licenseId": "GPL-1.0-only", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/gpl-1.0-standalone.html" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/CC-BY-NC-ND-3.0-DE.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CC-BY-NC-ND-3.0-DE.json", + "referenceNumber": 70, + "name": "Creative Commons Attribution Non Commercial No Derivatives 3.0 Germany", + "licenseId": "CC-BY-NC-ND-3.0-DE", + "seeAlso": [ + "https://creativecommons.org/licenses/by-nc-nd/3.0/de/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/CC-BY-NC-SA-3.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CC-BY-NC-SA-3.0.json", + "referenceNumber": 71, + "name": "Creative Commons Attribution Non Commercial Share Alike 3.0 Unported", + "licenseId": "CC-BY-NC-SA-3.0", + "seeAlso": [ + "https://creativecommons.org/licenses/by-nc-sa/3.0/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/CC-BY-NC-SA-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CC-BY-NC-SA-1.0.json", + "referenceNumber": 72, + "name": "Creative Commons Attribution Non Commercial Share Alike 1.0 Generic", + "licenseId": "CC-BY-NC-SA-1.0", + "seeAlso": [ + "https://creativecommons.org/licenses/by-nc-sa/1.0/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/MIT-open-group.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/MIT-open-group.json", + "referenceNumber": 73, + "name": "MIT Open Group variant", + "licenseId": "MIT-open-group", + "seeAlso": [ + "https://gitlab.freedesktop.org/xorg/app/iceauth/-/blob/master/COPYING", + "https://gitlab.freedesktop.org/xorg/app/xvinfo/-/blob/master/COPYING", + "https://gitlab.freedesktop.org/xorg/app/xsetroot/-/blob/master/COPYING", + "https://gitlab.freedesktop.org/xorg/app/xauth/-/blob/master/COPYING" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/Multics.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Multics.json", + "referenceNumber": 74, + "name": "Multics License", + "licenseId": "Multics", + "seeAlso": [ + "https://opensource.org/licenses/Multics" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/SWL.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/SWL.json", + "referenceNumber": 75, + "name": "Scheme Widget Library (SWL) Software License Agreement", + "licenseId": "SWL", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/SWL" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/GPL-1.0+.html", + "isDeprecatedLicenseId": true, + "detailsUrl": "https://spdx.org/licenses/GPL-1.0+.json", + "referenceNumber": 76, + "name": "GNU General Public License v1.0 or later", + "licenseId": "GPL-1.0+", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/gpl-1.0-standalone.html" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/GPL-3.0-or-later.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/GPL-3.0-or-later.json", + "referenceNumber": 77, + "name": "GNU General Public License v3.0 or later", + "licenseId": "GPL-3.0-or-later", + "seeAlso": [ + "https://www.gnu.org/licenses/gpl-3.0-standalone.html", + "https://opensource.org/licenses/GPL-3.0" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/DOC.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/DOC.json", + "referenceNumber": 78, + "name": "DOC License", + "licenseId": "DOC", + "seeAlso": [ + "http://www.cs.wustl.edu/~schmidt/ACE-copying.html", + "https://www.dre.vanderbilt.edu/~schmidt/ACE-copying.html" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/PHP-3.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/PHP-3.0.json", + "referenceNumber": 79, + "name": "PHP License v3.0", + "licenseId": "PHP-3.0", + "seeAlso": [ + "http://www.php.net/license/3_0.txt", + "https://opensource.org/licenses/PHP-3.0" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/SISSL-1.2.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/SISSL-1.2.json", + "referenceNumber": 80, + "name": "Sun Industry Standards Source License v1.2", + "licenseId": "SISSL-1.2", + "seeAlso": [ + "http://gridscheduler.sourceforge.net/Gridengine_SISSL_license.html" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/CDL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CDL-1.0.json", + "referenceNumber": 81, + "name": "Common Documentation License 1.0", + "licenseId": "CDL-1.0", + "seeAlso": [ + "http://www.opensource.apple.com/cdl/", + "https://fedoraproject.org/wiki/Licensing/Common_Documentation_License", + "https://www.gnu.org/licenses/license-list.html#ACDL" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/LPL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/LPL-1.0.json", + "referenceNumber": 82, + "name": "Lucent Public License Version 1.0", + "licenseId": "LPL-1.0", + "seeAlso": [ + "https://opensource.org/licenses/LPL-1.0" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/RHeCos-1.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/RHeCos-1.1.json", + "referenceNumber": 83, + "name": "Red Hat eCos Public License v1.1", + "licenseId": "RHeCos-1.1", + "seeAlso": [ + "http://ecos.sourceware.org/old-license.html" + ], + "isOsiApproved": false, + "isFsfLibre": false + }, + { + "reference": "https://spdx.org/licenses/LAL-1.3.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/LAL-1.3.json", + "referenceNumber": 84, + "name": "Licence Art Libre 1.3", + "licenseId": "LAL-1.3", + "seeAlso": [ + "https://artlibre.org/" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/CC-BY-SA-3.0-DE.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CC-BY-SA-3.0-DE.json", + "referenceNumber": 85, + "name": "Creative Commons Attribution Share Alike 3.0 Germany", + "licenseId": "CC-BY-SA-3.0-DE", + "seeAlso": [ + "https://creativecommons.org/licenses/by-sa/3.0/de/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/CDLA-Permissive-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CDLA-Permissive-1.0.json", + "referenceNumber": 86, + "name": "Community Data License Agreement Permissive 1.0", + "licenseId": "CDLA-Permissive-1.0", + "seeAlso": [ + "https://cdla.io/permissive-1-0" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/gnuplot.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/gnuplot.json", + "referenceNumber": 87, + "name": "gnuplot License", + "licenseId": "gnuplot", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Gnuplot" + ], + "isOsiApproved": false, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/App-s2p.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/App-s2p.json", + "referenceNumber": 88, + "name": "App::s2p License", + "licenseId": "App-s2p", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/App-s2p" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/iMatix.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/iMatix.json", + "referenceNumber": 89, + "name": "iMatix Standard Function Library Agreement", + "licenseId": "iMatix", + "seeAlso": [ + "http://legacy.imatix.com/html/sfl/sfl4.htm#license" + ], + "isOsiApproved": false, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/MS-PL.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/MS-PL.json", + "referenceNumber": 90, + "name": "Microsoft Public License", + "licenseId": "MS-PL", + "seeAlso": [ + "http://www.microsoft.com/opensource/licenses.mspx", + "https://opensource.org/licenses/MS-PL" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/eCos-2.0.html", + "isDeprecatedLicenseId": true, + "detailsUrl": "https://spdx.org/licenses/eCos-2.0.json", + "referenceNumber": 91, + "name": "eCos license version 2.0", + "licenseId": "eCos-2.0", + "seeAlso": [ + "https://www.gnu.org/licenses/ecos-license.html" + ], + "isOsiApproved": false, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/BSD-3-Clause.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/BSD-3-Clause.json", + "referenceNumber": 92, + "name": "BSD 3-Clause \"New\" or \"Revised\" License", + "licenseId": "BSD-3-Clause", + "seeAlso": [ + "https://opensource.org/licenses/BSD-3-Clause" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/CC-BY-NC-ND-3.0-IGO.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CC-BY-NC-ND-3.0-IGO.json", + "referenceNumber": 93, + "name": "Creative Commons Attribution Non Commercial No Derivatives 3.0 IGO", + "licenseId": "CC-BY-NC-ND-3.0-IGO", + "seeAlso": [ + "https://creativecommons.org/licenses/by-nc-nd/3.0/igo/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/ICU.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/ICU.json", + "referenceNumber": 94, + "name": "ICU License", + "licenseId": "ICU", + "seeAlso": [ + "http://source.icu-project.org/repos/icu/icu/trunk/license.html" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/AGPL-3.0-or-later.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/AGPL-3.0-or-later.json", + "referenceNumber": 95, + "name": "GNU Affero General Public License v3.0 or later", + "licenseId": "AGPL-3.0-or-later", + "seeAlso": [ + "https://www.gnu.org/licenses/agpl.txt", + "https://opensource.org/licenses/AGPL-3.0" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/CC-BY-SA-2.1-JP.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CC-BY-SA-2.1-JP.json", + "referenceNumber": 96, + "name": "Creative Commons Attribution Share Alike 2.1 Japan", + "licenseId": "CC-BY-SA-2.1-JP", + "seeAlso": [ + "https://creativecommons.org/licenses/by-sa/2.1/jp/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/CC-BY-NC-SA-4.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CC-BY-NC-SA-4.0.json", + "referenceNumber": 97, + "name": "Creative Commons Attribution Non Commercial Share Alike 4.0 International", + "licenseId": "CC-BY-NC-SA-4.0", + "seeAlso": [ + "https://creativecommons.org/licenses/by-nc-sa/4.0/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/Unlicense.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Unlicense.json", + "referenceNumber": 98, + "name": "The Unlicense", + "licenseId": "Unlicense", + "seeAlso": [ + "https://unlicense.org/" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/CC-BY-NC-3.0-DE.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CC-BY-NC-3.0-DE.json", + "referenceNumber": 99, + "name": "Creative Commons Attribution Non Commercial 3.0 Germany", + "licenseId": "CC-BY-NC-3.0-DE", + "seeAlso": [ + "https://creativecommons.org/licenses/by-nc/3.0/de/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/OLDAP-1.4.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/OLDAP-1.4.json", + "referenceNumber": 100, + "name": "Open LDAP Public License v1.4", + "licenseId": "OLDAP-1.4", + "seeAlso": [ + "http://www.openldap.org/devel/gitweb.cgi?p\u003dopenldap.git;a\u003dblob;f\u003dLICENSE;hb\u003dc9f95c2f3f2ffb5e0ae55fe7388af75547660941" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/CERN-OHL-W-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CERN-OHL-W-2.0.json", + "referenceNumber": 101, + "name": "CERN Open Hardware Licence Version 2 - Weakly Reciprocal", + "licenseId": "CERN-OHL-W-2.0", + "seeAlso": [ + "https://www.ohwr.org/project/cernohl/wikis/Documents/CERN-OHL-version-2" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/SugarCRM-1.1.3.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/SugarCRM-1.1.3.json", + "referenceNumber": 102, + "name": "SugarCRM Public License v1.1.3", + "licenseId": "SugarCRM-1.1.3", + "seeAlso": [ + "http://www.sugarcrm.com/crm/SPL" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/IPA.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/IPA.json", + "referenceNumber": 103, + "name": "IPA Font License", + "licenseId": "IPA", + "seeAlso": [ + "https://opensource.org/licenses/IPA" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/AFL-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/AFL-2.0.json", + "referenceNumber": 104, + "name": "Academic Free License v2.0", + "licenseId": "AFL-2.0", + "seeAlso": [ + "http://wayback.archive.org/web/20060924134533/http://www.opensource.org/licenses/afl-2.0.txt" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/Unicode-DFS-2016.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Unicode-DFS-2016.json", + "referenceNumber": 105, + "name": "Unicode License Agreement - Data Files and Software (2016)", + "licenseId": "Unicode-DFS-2016", + "seeAlso": [ + "http://www.unicode.org/copyright.html" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/CC-BY-NC-ND-3.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CC-BY-NC-ND-3.0.json", + "referenceNumber": 106, + "name": "Creative Commons Attribution Non Commercial No Derivatives 3.0 Unported", + "licenseId": "CC-BY-NC-ND-3.0", + "seeAlso": [ + "https://creativecommons.org/licenses/by-nc-nd/3.0/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/CERN-OHL-P-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CERN-OHL-P-2.0.json", + "referenceNumber": 107, + "name": "CERN Open Hardware Licence Version 2 - Permissive", + "licenseId": "CERN-OHL-P-2.0", + "seeAlso": [ + "https://www.ohwr.org/project/cernohl/wikis/Documents/CERN-OHL-version-2" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/CC-BY-NC-3.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CC-BY-NC-3.0.json", + "referenceNumber": 108, + "name": "Creative Commons Attribution Non Commercial 3.0 Unported", + "licenseId": "CC-BY-NC-3.0", + "seeAlso": [ + "https://creativecommons.org/licenses/by-nc/3.0/legalcode" + ], + "isOsiApproved": false, + "isFsfLibre": false + }, + { + "reference": "https://spdx.org/licenses/COIL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/COIL-1.0.json", + "referenceNumber": 109, + "name": "Copyfree Open Innovation License", + "licenseId": "COIL-1.0", + "seeAlso": [ + "https://coil.apotheon.org/plaintext/01.0.txt" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/CAL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CAL-1.0.json", + "referenceNumber": 110, + "name": "Cryptographic Autonomy License 1.0", + "licenseId": "CAL-1.0", + "seeAlso": [ + "http://cryptographicautonomylicense.com/license-text.html", + "https://opensource.org/licenses/CAL-1.0" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/LiLiQ-P-1.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/LiLiQ-P-1.1.json", + "referenceNumber": 111, + "name": "Licence Libre du Québec – Permissive version 1.1", + "licenseId": "LiLiQ-P-1.1", + "seeAlso": [ + "https://forge.gouv.qc.ca/licence/fr/liliq-v1-1/", + "http://opensource.org/licenses/LiLiQ-P-1.1" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/OFL-1.1-RFN.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/OFL-1.1-RFN.json", + "referenceNumber": 112, + "name": "SIL Open Font License 1.1 with Reserved Font Name", + "licenseId": "OFL-1.1-RFN", + "seeAlso": [ + "http://scripts.sil.org/cms/scripts/page.php?item_id\u003dOFL_web", + "https://opensource.org/licenses/OFL-1.1" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/LPL-1.02.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/LPL-1.02.json", + "referenceNumber": 113, + "name": "Lucent Public License v1.02", + "licenseId": "LPL-1.02", + "seeAlso": [ + "http://plan9.bell-labs.com/plan9/license.html", + "https://opensource.org/licenses/LPL-1.02" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/OLDAP-1.3.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/OLDAP-1.3.json", + "referenceNumber": 114, + "name": "Open LDAP Public License v1.3", + "licenseId": "OLDAP-1.3", + "seeAlso": [ + "http://www.openldap.org/devel/gitweb.cgi?p\u003dopenldap.git;a\u003dblob;f\u003dLICENSE;hb\u003de5f8117f0ce088d0bd7a8e18ddf37eaa40eb09b1" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/OGDL-Taiwan-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/OGDL-Taiwan-1.0.json", + "referenceNumber": 115, + "name": "Taiwan Open Government Data License, version 1.0", + "licenseId": "OGDL-Taiwan-1.0", + "seeAlso": [ + "https://data.gov.tw/license" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/CC-BY-NC-SA-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CC-BY-NC-SA-2.0.json", + "referenceNumber": 116, + "name": "Creative Commons Attribution Non Commercial Share Alike 2.0 Generic", + "licenseId": "CC-BY-NC-SA-2.0", + "seeAlso": [ + "https://creativecommons.org/licenses/by-nc-sa/2.0/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/Python-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Python-2.0.json", + "referenceNumber": 117, + "name": "Python License 2.0", + "licenseId": "Python-2.0", + "seeAlso": [ + "https://opensource.org/licenses/Python-2.0" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/NTP-0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/NTP-0.json", + "referenceNumber": 118, + "name": "NTP No Attribution", + "licenseId": "NTP-0", + "seeAlso": [ + "https://github.com/tytso/e2fsprogs/blob/master/lib/et/et_name.c" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/FSFAP.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/FSFAP.json", + "referenceNumber": 119, + "name": "FSF All Permissive License", + "licenseId": "FSFAP", + "seeAlso": [ + "https://www.gnu.org/prep/maintain/html_node/License-Notices-for-Other-Files.html" + ], + "isOsiApproved": false, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/ErlPL-1.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/ErlPL-1.1.json", + "referenceNumber": 120, + "name": "Erlang Public License v1.1", + "licenseId": "ErlPL-1.1", + "seeAlso": [ + "http://www.erlang.org/EPLICENSE" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/Barr.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Barr.json", + "referenceNumber": 121, + "name": "Barr License", + "licenseId": "Barr", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Barr" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/CC-BY-3.0-US.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CC-BY-3.0-US.json", + "referenceNumber": 122, + "name": "Creative Commons Attribution 3.0 United States", + "licenseId": "CC-BY-3.0-US", + "seeAlso": [ + "https://creativecommons.org/licenses/by/3.0/us/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/BSD-3-Clause-No-Nuclear-License-2014.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/BSD-3-Clause-No-Nuclear-License-2014.json", + "referenceNumber": 123, + "name": "BSD 3-Clause No Nuclear License 2014", + "licenseId": "BSD-3-Clause-No-Nuclear-License-2014", + "seeAlso": [ + "https://java.net/projects/javaeetutorial/pages/BerkeleyLicense" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/NLPL.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/NLPL.json", + "referenceNumber": 124, + "name": "No Limit Public License", + "licenseId": "NLPL", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/NLPL" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/BSD-3-Clause-Clear.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/BSD-3-Clause-Clear.json", + "referenceNumber": 125, + "name": "BSD 3-Clause Clear License", + "licenseId": "BSD-3-Clause-Clear", + "seeAlso": [ + "http://labs.metacarta.com/license-explanation.html#license" + ], + "isOsiApproved": false, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/SGI-B-1.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/SGI-B-1.1.json", + "referenceNumber": 126, + "name": "SGI Free Software License B v1.1", + "licenseId": "SGI-B-1.1", + "seeAlso": [ + "http://oss.sgi.com/projects/FreeB/" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/PDDL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/PDDL-1.0.json", + "referenceNumber": 127, + "name": "Open Data Commons Public Domain Dedication \u0026 License 1.0", + "licenseId": "PDDL-1.0", + "seeAlso": [ + "http://opendatacommons.org/licenses/pddl/1.0/", + "https://opendatacommons.org/licenses/pddl/" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/CDDL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CDDL-1.0.json", + "referenceNumber": 128, + "name": "Common Development and Distribution License 1.0", + "licenseId": "CDDL-1.0", + "seeAlso": [ + "https://opensource.org/licenses/cddl1" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/LGPL-2.1-or-later.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/LGPL-2.1-or-later.json", + "referenceNumber": 129, + "name": "GNU Lesser General Public License v2.1 or later", + "licenseId": "LGPL-2.1-or-later", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/lgpl-2.1-standalone.html", + "https://opensource.org/licenses/LGPL-2.1" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/BlueOak-1.0.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/BlueOak-1.0.0.json", + "referenceNumber": 130, + "name": "Blue Oak Model License 1.0.0", + "licenseId": "BlueOak-1.0.0", + "seeAlso": [ + "https://blueoakcouncil.org/license/1.0.0" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/CC-BY-NC-SA-2.0-FR.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CC-BY-NC-SA-2.0-FR.json", + "referenceNumber": 131, + "name": "Creative Commons Attribution-NonCommercial-ShareAlike 2.0 France", + "licenseId": "CC-BY-NC-SA-2.0-FR", + "seeAlso": [ + "https://creativecommons.org/licenses/by-nc-sa/2.0/fr/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/FDK-AAC.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/FDK-AAC.json", + "referenceNumber": 132, + "name": "Fraunhofer FDK AAC Codec Library", + "licenseId": "FDK-AAC", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/FDK-AAC", + "https://directory.fsf.org/wiki/License:Fdk" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/StandardML-NJ.html", + "isDeprecatedLicenseId": true, + "detailsUrl": "https://spdx.org/licenses/StandardML-NJ.json", + "referenceNumber": 133, + "name": "Standard ML of New Jersey License", + "licenseId": "StandardML-NJ", + "seeAlso": [ + "http://www.smlnj.org//license.html" + ], + "isOsiApproved": false, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/AGPL-1.0-only.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/AGPL-1.0-only.json", + "referenceNumber": 134, + "name": "Affero General Public License v1.0 only", + "licenseId": "AGPL-1.0-only", + "seeAlso": [ + "http://www.affero.org/oagpl.html" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/CECILL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CECILL-1.0.json", + "referenceNumber": 135, + "name": "CeCILL Free Software License Agreement v1.0", + "licenseId": "CECILL-1.0", + "seeAlso": [ + "http://www.cecill.info/licences/Licence_CeCILL_V1-fr.html" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/AAL.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/AAL.json", + "referenceNumber": 136, + "name": "Attribution Assurance License", + "licenseId": "AAL", + "seeAlso": [ + "https://opensource.org/licenses/attribution" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/GPL-2.0-with-font-exception.html", + "isDeprecatedLicenseId": true, + "detailsUrl": "https://spdx.org/licenses/GPL-2.0-with-font-exception.json", + "referenceNumber": 137, + "name": "GNU General Public License v2.0 w/Font exception", + "licenseId": "GPL-2.0-with-font-exception", + "seeAlso": [ + "https://www.gnu.org/licenses/gpl-faq.html#FontException" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/Info-ZIP.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Info-ZIP.json", + "referenceNumber": 138, + "name": "Info-ZIP License", + "licenseId": "Info-ZIP", + "seeAlso": [ + "http://www.info-zip.org/license.html" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/SSH-OpenSSH.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/SSH-OpenSSH.json", + "referenceNumber": 139, + "name": "SSH OpenSSH license", + "licenseId": "SSH-OpenSSH", + "seeAlso": [ + "https://github.com/openssh/openssh-portable/blob/1b11ea7c58cd5c59838b5fa574cd456d6047b2d4/LICENCE#L10" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/SSH-short.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/SSH-short.json", + "referenceNumber": 140, + "name": "SSH short notice", + "licenseId": "SSH-short", + "seeAlso": [ + "https://github.com/openssh/openssh-portable/blob/1b11ea7c58cd5c59838b5fa574cd456d6047b2d4/pathnames.h", + "http://web.mit.edu/kolya/.f/root/athena.mit.edu/sipb.mit.edu/project/openssh/OldFiles/src/openssh-2.9.9p2/ssh-add.1", + "https://joinup.ec.europa.eu/svn/lesoll/trunk/italc/lib/src/dsa_key.cpp" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/GPL-2.0-or-later.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/GPL-2.0-or-later.json", + "referenceNumber": 141, + "name": "GNU General Public License v2.0 or later", + "licenseId": "GPL-2.0-or-later", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/gpl-2.0-standalone.html", + "https://opensource.org/licenses/GPL-2.0" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/ClArtistic.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/ClArtistic.json", + "referenceNumber": 142, + "name": "Clarified Artistic License", + "licenseId": "ClArtistic", + "seeAlso": [ + "http://gianluca.dellavedova.org/2011/01/03/clarified-artistic-license/", + "http://www.ncftp.com/ncftp/doc/LICENSE.txt" + ], + "isOsiApproved": false, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/SNIA.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/SNIA.json", + "referenceNumber": 143, + "name": "SNIA Public License 1.1", + "licenseId": "SNIA", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/SNIA_Public_License" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/GFDL-1.1-invariants-only.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/GFDL-1.1-invariants-only.json", + "referenceNumber": 144, + "name": "GNU Free Documentation License v1.1 only - invariants", + "licenseId": "GFDL-1.1-invariants-only", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/fdl-1.1.txt" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/BSD-3-Clause-No-Military-License.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/BSD-3-Clause-No-Military-License.json", + "referenceNumber": 145, + "name": "BSD 3-Clause No Military License", + "licenseId": "BSD-3-Clause-No-Military-License", + "seeAlso": [ + "https://gitlab.syncad.com/hive/dhive/-/blob/master/LICENSE", + "https://github.com/greymass/swift-eosio/blob/master/LICENSE" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/GFDL-1.1.html", + "isDeprecatedLicenseId": true, + "detailsUrl": "https://spdx.org/licenses/GFDL-1.1.json", + "referenceNumber": 146, + "name": "GNU Free Documentation License v1.1", + "licenseId": "GFDL-1.1", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/fdl-1.1.txt" + ], + "isOsiApproved": false, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/MPL-1.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/MPL-1.1.json", + "referenceNumber": 147, + "name": "Mozilla Public License 1.1", + "licenseId": "MPL-1.1", + "seeAlso": [ + "http://www.mozilla.org/MPL/MPL-1.1.html", + "https://opensource.org/licenses/MPL-1.1" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/OLDAP-1.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/OLDAP-1.1.json", + "referenceNumber": 148, + "name": "Open LDAP Public License v1.1", + "licenseId": "OLDAP-1.1", + "seeAlso": [ + "http://www.openldap.org/devel/gitweb.cgi?p\u003dopenldap.git;a\u003dblob;f\u003dLICENSE;hb\u003d806557a5ad59804ef3a44d5abfbe91d706b0791f" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/JSON.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/JSON.json", + "referenceNumber": 149, + "name": "JSON License", + "licenseId": "JSON", + "seeAlso": [ + "http://www.json.org/license.html" + ], + "isOsiApproved": false, + "isFsfLibre": false + }, + { + "reference": "https://spdx.org/licenses/GFDL-1.3-no-invariants-only.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/GFDL-1.3-no-invariants-only.json", + "referenceNumber": 150, + "name": "GNU Free Documentation License v1.3 only - no invariants", + "licenseId": "GFDL-1.3-no-invariants-only", + "seeAlso": [ + "https://www.gnu.org/licenses/fdl-1.3.txt" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/OCLC-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/OCLC-2.0.json", + "referenceNumber": 151, + "name": "OCLC Research Public License 2.0", + "licenseId": "OCLC-2.0", + "seeAlso": [ + "http://www.oclc.org/research/activities/software/license/v2final.htm", + "https://opensource.org/licenses/OCLC-2.0" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/OLDAP-2.0.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/OLDAP-2.0.1.json", + "referenceNumber": 152, + "name": "Open LDAP Public License v2.0.1", + "licenseId": "OLDAP-2.0.1", + "seeAlso": [ + "http://www.openldap.org/devel/gitweb.cgi?p\u003dopenldap.git;a\u003dblob;f\u003dLICENSE;hb\u003db6d68acd14e51ca3aab4428bf26522aa74873f0e" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/FreeBSD-DOC.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/FreeBSD-DOC.json", + "referenceNumber": 153, + "name": "FreeBSD Documentation License", + "licenseId": "FreeBSD-DOC", + "seeAlso": [ + "https://www.freebsd.org/copyright/freebsd-doc-license/" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/GPL-1.0-or-later.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/GPL-1.0-or-later.json", + "referenceNumber": 154, + "name": "GNU General Public License v1.0 or later", + "licenseId": "GPL-1.0-or-later", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/gpl-1.0-standalone.html" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/YPL-1.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/YPL-1.1.json", + "referenceNumber": 155, + "name": "Yahoo! Public License v1.1", + "licenseId": "YPL-1.1", + "seeAlso": [ + "http://www.zimbra.com/license/yahoo_public_license_1.1.html" + ], + "isOsiApproved": false, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/CPL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CPL-1.0.json", + "referenceNumber": 156, + "name": "Common Public License 1.0", + "licenseId": "CPL-1.0", + "seeAlso": [ + "https://opensource.org/licenses/CPL-1.0" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/Apache-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Apache-1.0.json", + "referenceNumber": 157, + "name": "Apache License 1.0", + "licenseId": "Apache-1.0", + "seeAlso": [ + "http://www.apache.org/licenses/LICENSE-1.0" + ], + "isOsiApproved": false, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/OFL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/OFL-1.0.json", + "referenceNumber": 158, + "name": "SIL Open Font License 1.0", + "licenseId": "OFL-1.0", + "seeAlso": [ + "http://scripts.sil.org/cms/scripts/page.php?item_id\u003dOFL10_web" + ], + "isOsiApproved": false, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/CC-BY-4.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CC-BY-4.0.json", + "referenceNumber": 159, + "name": "Creative Commons Attribution 4.0 International", + "licenseId": "CC-BY-4.0", + "seeAlso": [ + "https://creativecommons.org/licenses/by/4.0/legalcode" + ], + "isOsiApproved": false, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/DSDP.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/DSDP.json", + "referenceNumber": 160, + "name": "DSDP License", + "licenseId": "DSDP", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/DSDP" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/IBM-pibs.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/IBM-pibs.json", + "referenceNumber": 161, + "name": "IBM PowerPC Initialization and Boot Software", + "licenseId": "IBM-pibs", + "seeAlso": [ + "http://git.denx.de/?p\u003du-boot.git;a\u003dblob;f\u003darch/powerpc/cpu/ppc4xx/miiphy.c;h\u003d297155fdafa064b955e53e9832de93bfb0cfb85b;hb\u003d9fab4bf4cc077c21e43941866f3f2c196f28670d" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/MIT-0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/MIT-0.json", + "referenceNumber": 162, + "name": "MIT No Attribution", + "licenseId": "MIT-0", + "seeAlso": [ + "https://github.com/aws/mit-0", + "https://romanrm.net/mit-zero", + "https://github.com/awsdocs/aws-cloud9-user-guide/blob/master/LICENSE-SAMPLECODE" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/DRL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/DRL-1.0.json", + "referenceNumber": 163, + "name": "Detection Rule License 1.0", + "licenseId": "DRL-1.0", + "seeAlso": [ + "https://github.com/Neo23x0/sigma/blob/master/LICENSE.Detection.Rules.md" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/Zlib.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Zlib.json", + "referenceNumber": 164, + "name": "zlib License", + "licenseId": "Zlib", + "seeAlso": [ + "http://www.zlib.net/zlib_license.html", + "https://opensource.org/licenses/Zlib" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/APL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/APL-1.0.json", + "referenceNumber": 165, + "name": "Adaptive Public License 1.0", + "licenseId": "APL-1.0", + "seeAlso": [ + "https://opensource.org/licenses/APL-1.0" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/Watcom-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Watcom-1.0.json", + "referenceNumber": 166, + "name": "Sybase Open Watcom Public License 1.0", + "licenseId": "Watcom-1.0", + "seeAlso": [ + "https://opensource.org/licenses/Watcom-1.0" + ], + "isOsiApproved": true, + "isFsfLibre": false + }, + { + "reference": "https://spdx.org/licenses/GPL-2.0-with-GCC-exception.html", + "isDeprecatedLicenseId": true, + "detailsUrl": "https://spdx.org/licenses/GPL-2.0-with-GCC-exception.json", + "referenceNumber": 167, + "name": "GNU General Public License v2.0 w/GCC Runtime Library exception", + "licenseId": "GPL-2.0-with-GCC-exception", + "seeAlso": [ + "https://gcc.gnu.org/git/?p\u003dgcc.git;a\u003dblob;f\u003dgcc/libgcc1.c;h\u003d762f5143fc6eed57b6797c82710f3538aa52b40b;hb\u003dcb143a3ce4fb417c68f5fa2691a1b1b1053dfba9#l10" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/EUPL-1.2.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/EUPL-1.2.json", + "referenceNumber": 168, + "name": "European Union Public License 1.2", + "licenseId": "EUPL-1.2", + "seeAlso": [ + "https://joinup.ec.europa.eu/page/eupl-text-11-12", + "https://joinup.ec.europa.eu/sites/default/files/custom-page/attachment/eupl_v1.2_en.pdf", + "https://joinup.ec.europa.eu/sites/default/files/custom-page/attachment/2020-03/EUPL-1.2%20EN.txt", + "https://joinup.ec.europa.eu/sites/default/files/inline-files/EUPL%20v1_2%20EN(1).txt", + "http://eur-lex.europa.eu/legal-content/EN/TXT/HTML/?uri\u003dCELEX:32017D0863", + "https://opensource.org/licenses/EUPL-1.2" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/FSFUL.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/FSFUL.json", + "referenceNumber": 169, + "name": "FSF Unlimited License", + "licenseId": "FSFUL", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/FSF_Unlimited_License" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/NASA-1.3.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/NASA-1.3.json", + "referenceNumber": 170, + "name": "NASA Open Source Agreement 1.3", + "licenseId": "NASA-1.3", + "seeAlso": [ + "http://ti.arc.nasa.gov/opensource/nosa/", + "https://opensource.org/licenses/NASA-1.3" + ], + "isOsiApproved": true, + "isFsfLibre": false + }, + { + "reference": "https://spdx.org/licenses/BSD-2-Clause.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/BSD-2-Clause.json", + "referenceNumber": 171, + "name": "BSD 2-Clause \"Simplified\" License", + "licenseId": "BSD-2-Clause", + "seeAlso": [ + "https://opensource.org/licenses/BSD-2-Clause" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/XFree86-1.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/XFree86-1.1.json", + "referenceNumber": 172, + "name": "XFree86 License 1.1", + "licenseId": "XFree86-1.1", + "seeAlso": [ + "http://www.xfree86.org/current/LICENSE4.html" + ], + "isOsiApproved": false, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/Eurosym.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Eurosym.json", + "referenceNumber": 173, + "name": "Eurosym License", + "licenseId": "Eurosym", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Eurosym" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/OLDAP-2.8.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/OLDAP-2.8.json", + "referenceNumber": 174, + "name": "Open LDAP Public License v2.8", + "licenseId": "OLDAP-2.8", + "seeAlso": [ + "http://www.openldap.org/software/release/license.html" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/dvipdfm.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/dvipdfm.json", + "referenceNumber": 175, + "name": "dvipdfm License", + "licenseId": "dvipdfm", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/dvipdfm" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/NIST-PD.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/NIST-PD.json", + "referenceNumber": 176, + "name": "NIST Public Domain Notice", + "licenseId": "NIST-PD", + "seeAlso": [ + "https://github.com/tcheneau/simpleRPL/blob/e645e69e38dd4e3ccfeceb2db8cba05b7c2e0cd3/LICENSE.txt", + "https://github.com/tcheneau/Routing/blob/f09f46fcfe636107f22f2c98348188a65a135d98/README.md" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/Apache-1.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Apache-1.1.json", + "referenceNumber": 177, + "name": "Apache License 1.1", + "licenseId": "Apache-1.1", + "seeAlso": [ + "http://apache.org/licenses/LICENSE-1.1", + "https://opensource.org/licenses/Apache-1.1" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/Parity-6.0.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Parity-6.0.0.json", + "referenceNumber": 178, + "name": "The Parity Public License 6.0.0", + "licenseId": "Parity-6.0.0", + "seeAlso": [ + "https://paritylicense.com/versions/6.0.0.html" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/CC-BY-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CC-BY-2.0.json", + "referenceNumber": 179, + "name": "Creative Commons Attribution 2.0 Generic", + "licenseId": "CC-BY-2.0", + "seeAlso": [ + "https://creativecommons.org/licenses/by/2.0/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/LGPL-3.0+.html", + "isDeprecatedLicenseId": true, + "detailsUrl": "https://spdx.org/licenses/LGPL-3.0+.json", + "referenceNumber": 180, + "name": "GNU Lesser General Public License v3.0 or later", + "licenseId": "LGPL-3.0+", + "seeAlso": [ + "https://www.gnu.org/licenses/lgpl-3.0-standalone.html", + "https://opensource.org/licenses/LGPL-3.0" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/BSD-2-Clause-Views.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/BSD-2-Clause-Views.json", + "referenceNumber": 181, + "name": "BSD 2-Clause with views sentence", + "licenseId": "BSD-2-Clause-Views", + "seeAlso": [ + "http://www.freebsd.org/copyright/freebsd-license.html", + "https://people.freebsd.org/~ivoras/wine/patch-wine-nvidia.sh", + "https://github.com/protegeproject/protege/blob/master/license.txt" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/GPL-2.0-with-classpath-exception.html", + "isDeprecatedLicenseId": true, + "detailsUrl": "https://spdx.org/licenses/GPL-2.0-with-classpath-exception.json", + "referenceNumber": 182, + "name": "GNU General Public License v2.0 w/Classpath exception", + "licenseId": "GPL-2.0-with-classpath-exception", + "seeAlso": [ + "https://www.gnu.org/software/classpath/license.html" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/BSD-3-Clause-No-Nuclear-Warranty.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/BSD-3-Clause-No-Nuclear-Warranty.json", + "referenceNumber": 183, + "name": "BSD 3-Clause No Nuclear Warranty", + "licenseId": "BSD-3-Clause-No-Nuclear-Warranty", + "seeAlso": [ + "https://jogamp.org/git/?p\u003dgluegen.git;a\u003dblob_plain;f\u003dLICENSE.txt" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/X11.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/X11.json", + "referenceNumber": 184, + "name": "X11 License", + "licenseId": "X11", + "seeAlso": [ + "http://www.xfree86.org/3.3.6/COPYRIGHT2.html#3" + ], + "isOsiApproved": false, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/CDLA-Permissive-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CDLA-Permissive-2.0.json", + "referenceNumber": 185, + "name": "Community Data License Agreement Permissive 2.0", + "licenseId": "CDLA-Permissive-2.0", + "seeAlso": [ + "https://cdla.dev/permissive-2-0" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/HaskellReport.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/HaskellReport.json", + "referenceNumber": 186, + "name": "Haskell Language Report License", + "licenseId": "HaskellReport", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Haskell_Language_Report_License" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/Artistic-1.0-cl8.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Artistic-1.0-cl8.json", + "referenceNumber": 187, + "name": "Artistic License 1.0 w/clause 8", + "licenseId": "Artistic-1.0-cl8", + "seeAlso": [ + "https://opensource.org/licenses/Artistic-1.0" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/APSL-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/APSL-2.0.json", + "referenceNumber": 188, + "name": "Apple Public Source License 2.0", + "licenseId": "APSL-2.0", + "seeAlso": [ + "http://www.opensource.apple.com/license/apsl/" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/GPL-3.0+.html", + "isDeprecatedLicenseId": true, + "detailsUrl": "https://spdx.org/licenses/GPL-3.0+.json", + "referenceNumber": 189, + "name": "GNU General Public License v3.0 or later", + "licenseId": "GPL-3.0+", + "seeAlso": [ + "https://www.gnu.org/licenses/gpl-3.0-standalone.html", + "https://opensource.org/licenses/GPL-3.0" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/SHL-0.5.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/SHL-0.5.json", + "referenceNumber": 190, + "name": "Solderpad Hardware License v0.5", + "licenseId": "SHL-0.5", + "seeAlso": [ + "https://solderpad.org/licenses/SHL-0.5/" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/CNRI-Python-GPL-Compatible.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CNRI-Python-GPL-Compatible.json", + "referenceNumber": 191, + "name": "CNRI Python Open Source GPL Compatible License Agreement", + "licenseId": "CNRI-Python-GPL-Compatible", + "seeAlso": [ + "http://www.python.org/download/releases/1.6.1/download_win/" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/Condor-1.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Condor-1.1.json", + "referenceNumber": 192, + "name": "Condor Public License v1.1", + "licenseId": "Condor-1.1", + "seeAlso": [ + "http://research.cs.wisc.edu/condor/license.html#condor", + "http://web.archive.org/web/20111123062036/http://research.cs.wisc.edu/condor/license.html#condor" + ], + "isOsiApproved": false, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/OLDAP-2.3.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/OLDAP-2.3.json", + "referenceNumber": 193, + "name": "Open LDAP Public License v2.3", + "licenseId": "OLDAP-2.3", + "seeAlso": [ + "http://www.openldap.org/devel/gitweb.cgi?p\u003dopenldap.git;a\u003dblob;f\u003dLICENSE;hb\u003dd32cf54a32d581ab475d23c810b0a7fbaf8d63c3" + ], + "isOsiApproved": false, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/GPL-2.0-only.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/GPL-2.0-only.json", + "referenceNumber": 194, + "name": "GNU General Public License v2.0 only", + "licenseId": "GPL-2.0-only", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/gpl-2.0-standalone.html", + "https://opensource.org/licenses/GPL-2.0" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/BUSL-1.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/BUSL-1.1.json", + "referenceNumber": 195, + "name": "Business Source License 1.1", + "licenseId": "BUSL-1.1", + "seeAlso": [ + "https://mariadb.com/bsl11/" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/LiLiQ-R-1.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/LiLiQ-R-1.1.json", + "referenceNumber": 196, + "name": "Licence Libre du Québec – Réciprocité version 1.1", + "licenseId": "LiLiQ-R-1.1", + "seeAlso": [ + "https://www.forge.gouv.qc.ca/participez/licence-logicielle/licence-libre-du-quebec-liliq-en-francais/licence-libre-du-quebec-reciprocite-liliq-r-v1-1/", + "http://opensource.org/licenses/LiLiQ-R-1.1" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/AMPAS.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/AMPAS.json", + "referenceNumber": 197, + "name": "Academy of Motion Picture Arts and Sciences BSD", + "licenseId": "AMPAS", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/BSD#AMPASBSD" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/copyleft-next-0.3.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/copyleft-next-0.3.1.json", + "referenceNumber": 198, + "name": "copyleft-next 0.3.1", + "licenseId": "copyleft-next-0.3.1", + "seeAlso": [ + "https://github.com/copyleft-next/copyleft-next/blob/master/Releases/copyleft-next-0.3.1" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/GFDL-1.3-invariants-or-later.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/GFDL-1.3-invariants-or-later.json", + "referenceNumber": 199, + "name": "GNU Free Documentation License v1.3 or later - invariants", + "licenseId": "GFDL-1.3-invariants-or-later", + "seeAlso": [ + "https://www.gnu.org/licenses/fdl-1.3.txt" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/OLDAP-2.7.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/OLDAP-2.7.json", + "referenceNumber": 200, + "name": "Open LDAP Public License v2.7", + "licenseId": "OLDAP-2.7", + "seeAlso": [ + "http://www.openldap.org/devel/gitweb.cgi?p\u003dopenldap.git;a\u003dblob;f\u003dLICENSE;hb\u003d47c2415c1df81556eeb39be6cad458ef87c534a2" + ], + "isOsiApproved": false, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/OSL-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/OSL-2.0.json", + "referenceNumber": 201, + "name": "Open Software License 2.0", + "licenseId": "OSL-2.0", + "seeAlso": [ + "http://web.archive.org/web/20041020171434/http://www.rosenlaw.com/osl2.0.html" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/Unicode-DFS-2015.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Unicode-DFS-2015.json", + "referenceNumber": 202, + "name": "Unicode License Agreement - Data Files and Software (2015)", + "licenseId": "Unicode-DFS-2015", + "seeAlso": [ + "https://web.archive.org/web/20151224134844/http://unicode.org/copyright.html" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/CATOSL-1.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CATOSL-1.1.json", + "referenceNumber": 203, + "name": "Computer Associates Trusted Open Source License 1.1", + "licenseId": "CATOSL-1.1", + "seeAlso": [ + "https://opensource.org/licenses/CATOSL-1.1" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/RSCPL.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/RSCPL.json", + "referenceNumber": 204, + "name": "Ricoh Source Code Public License", + "licenseId": "RSCPL", + "seeAlso": [ + "http://wayback.archive.org/web/20060715140826/http://www.risource.org/RPL/RPL-1.0A.shtml", + "https://opensource.org/licenses/RSCPL" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/libpng-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/libpng-2.0.json", + "referenceNumber": 205, + "name": "PNG Reference Library version 2", + "licenseId": "libpng-2.0", + "seeAlso": [ + "http://www.libpng.org/pub/png/src/libpng-LICENSE.txt" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/LPPL-1.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/LPPL-1.1.json", + "referenceNumber": 206, + "name": "LaTeX Project Public License v1.1", + "licenseId": "LPPL-1.1", + "seeAlso": [ + "http://www.latex-project.org/lppl/lppl-1-1.txt" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/CDLA-Sharing-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CDLA-Sharing-1.0.json", + "referenceNumber": 207, + "name": "Community Data License Agreement Sharing 1.0", + "licenseId": "CDLA-Sharing-1.0", + "seeAlso": [ + "https://cdla.io/sharing-1-0" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/Glulxe.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Glulxe.json", + "referenceNumber": 208, + "name": "Glulxe License", + "licenseId": "Glulxe", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Glulxe" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/GFDL-1.3-no-invariants-or-later.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/GFDL-1.3-no-invariants-or-later.json", + "referenceNumber": 209, + "name": "GNU Free Documentation License v1.3 or later - no invariants", + "licenseId": "GFDL-1.3-no-invariants-or-later", + "seeAlso": [ + "https://www.gnu.org/licenses/fdl-1.3.txt" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/OLDAP-1.2.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/OLDAP-1.2.json", + "referenceNumber": 210, + "name": "Open LDAP Public License v1.2", + "licenseId": "OLDAP-1.2", + "seeAlso": [ + "http://www.openldap.org/devel/gitweb.cgi?p\u003dopenldap.git;a\u003dblob;f\u003dLICENSE;hb\u003d42b0383c50c299977b5893ee695cf4e486fb0dc7" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/CDDL-1.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CDDL-1.1.json", + "referenceNumber": 211, + "name": "Common Development and Distribution License 1.1", + "licenseId": "CDDL-1.1", + "seeAlso": [ + "http://glassfish.java.net/public/CDDL+GPL_1_1.html", + "https://javaee.github.io/glassfish/LICENSE" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/CERN-OHL-1.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CERN-OHL-1.1.json", + "referenceNumber": 212, + "name": "CERN Open Hardware Licence v1.1", + "licenseId": "CERN-OHL-1.1", + "seeAlso": [ + "https://www.ohwr.org/project/licenses/wikis/cern-ohl-v1.1" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/BSD-Source-Code.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/BSD-Source-Code.json", + "referenceNumber": 213, + "name": "BSD Source Code Attribution", + "licenseId": "BSD-Source-Code", + "seeAlso": [ + "https://github.com/robbiehanson/CocoaHTTPServer/blob/master/LICENSE.txt" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/IJG.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/IJG.json", + "referenceNumber": 214, + "name": "Independent JPEG Group License", + "licenseId": "IJG", + "seeAlso": [ + "http://dev.w3.org/cvsweb/Amaya/libjpeg/Attic/README?rev\u003d1.2" + ], + "isOsiApproved": false, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/Zimbra-1.4.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Zimbra-1.4.json", + "referenceNumber": 215, + "name": "Zimbra Public License v1.4", + "licenseId": "Zimbra-1.4", + "seeAlso": [ + "http://www.zimbra.com/legal/zimbra-public-license-1-4" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/0BSD.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/0BSD.json", + "referenceNumber": 216, + "name": "BSD Zero Clause License", + "licenseId": "0BSD", + "seeAlso": [ + "http://landley.net/toybox/license.html", + "https://opensource.org/licenses/0BSD" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/CC-BY-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CC-BY-1.0.json", + "referenceNumber": 217, + "name": "Creative Commons Attribution 1.0 Generic", + "licenseId": "CC-BY-1.0", + "seeAlso": [ + "https://creativecommons.org/licenses/by/1.0/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/wxWindows.html", + "isDeprecatedLicenseId": true, + "detailsUrl": "https://spdx.org/licenses/wxWindows.json", + "referenceNumber": 218, + "name": "wxWindows Library License", + "licenseId": "wxWindows", + "seeAlso": [ + "https://opensource.org/licenses/WXwindows" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/ZPL-2.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/ZPL-2.1.json", + "referenceNumber": 219, + "name": "Zope Public License 2.1", + "licenseId": "ZPL-2.1", + "seeAlso": [ + "http://old.zope.org/Resources/ZPL/" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/NTP.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/NTP.json", + "referenceNumber": 220, + "name": "NTP License", + "licenseId": "NTP", + "seeAlso": [ + "https://opensource.org/licenses/NTP" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/Artistic-1.0-Perl.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Artistic-1.0-Perl.json", + "referenceNumber": 221, + "name": "Artistic License 1.0 (Perl)", + "licenseId": "Artistic-1.0-Perl", + "seeAlso": [ + "http://dev.perl.org/licenses/artistic.html" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/CC-BY-ND-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CC-BY-ND-2.0.json", + "referenceNumber": 222, + "name": "Creative Commons Attribution No Derivatives 2.0 Generic", + "licenseId": "CC-BY-ND-2.0", + "seeAlso": [ + "https://creativecommons.org/licenses/by-nd/2.0/legalcode" + ], + "isOsiApproved": false, + "isFsfLibre": false + }, + { + "reference": "https://spdx.org/licenses/CC-BY-ND-4.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CC-BY-ND-4.0.json", + "referenceNumber": 223, + "name": "Creative Commons Attribution No Derivatives 4.0 International", + "licenseId": "CC-BY-ND-4.0", + "seeAlso": [ + "https://creativecommons.org/licenses/by-nd/4.0/legalcode" + ], + "isOsiApproved": false, + "isFsfLibre": false + }, + { + "reference": "https://spdx.org/licenses/Adobe-2006.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Adobe-2006.json", + "referenceNumber": 224, + "name": "Adobe Systems Incorporated Source Code License Agreement", + "licenseId": "Adobe-2006", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/AdobeLicense" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/EPL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/EPL-1.0.json", + "referenceNumber": 225, + "name": "Eclipse Public License 1.0", + "licenseId": "EPL-1.0", + "seeAlso": [ + "http://www.eclipse.org/legal/epl-v10.html", + "https://opensource.org/licenses/EPL-1.0" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/diffmark.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/diffmark.json", + "referenceNumber": 226, + "name": "diffmark license", + "licenseId": "diffmark", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/diffmark" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/xinetd.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/xinetd.json", + "referenceNumber": 227, + "name": "xinetd License", + "licenseId": "xinetd", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Xinetd_License" + ], + "isOsiApproved": false, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/Plexus.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Plexus.json", + "referenceNumber": 228, + "name": "Plexus Classworlds License", + "licenseId": "Plexus", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Plexus_Classworlds_License" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/JPNIC.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/JPNIC.json", + "referenceNumber": 229, + "name": "Japan Network Information Center License", + "licenseId": "JPNIC", + "seeAlso": [ + "https://gitlab.isc.org/isc-projects/bind9/blob/master/COPYRIGHT#L366" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/Adobe-Glyph.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Adobe-Glyph.json", + "referenceNumber": 230, + "name": "Adobe Glyph List License", + "licenseId": "Adobe-Glyph", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/MIT#AdobeGlyph" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/Cube.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Cube.json", + "referenceNumber": 231, + "name": "Cube License", + "licenseId": "Cube", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Cube" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/TCP-wrappers.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/TCP-wrappers.json", + "referenceNumber": 232, + "name": "TCP Wrappers License", + "licenseId": "TCP-wrappers", + "seeAlso": [ + "http://rc.quest.com/topics/openssh/license.php#tcpwrappers" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/CC-BY-SA-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CC-BY-SA-1.0.json", + "referenceNumber": 233, + "name": "Creative Commons Attribution Share Alike 1.0 Generic", + "licenseId": "CC-BY-SA-1.0", + "seeAlso": [ + "https://creativecommons.org/licenses/by-sa/1.0/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/BSD-2-Clause-FreeBSD.html", + "isDeprecatedLicenseId": true, + "detailsUrl": "https://spdx.org/licenses/BSD-2-Clause-FreeBSD.json", + "referenceNumber": 234, + "name": "BSD 2-Clause FreeBSD License", + "licenseId": "BSD-2-Clause-FreeBSD", + "seeAlso": [ + "http://www.freebsd.org/copyright/freebsd-license.html" + ], + "isOsiApproved": false, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/OGL-Canada-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/OGL-Canada-2.0.json", + "referenceNumber": 235, + "name": "Open Government Licence - Canada", + "licenseId": "OGL-Canada-2.0", + "seeAlso": [ + "https://open.canada.ca/en/open-government-licence-canada" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/ANTLR-PD.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/ANTLR-PD.json", + "referenceNumber": 236, + "name": "ANTLR Software Rights Notice", + "licenseId": "ANTLR-PD", + "seeAlso": [ + "http://www.antlr2.org/license.html" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/LGPL-2.1+.html", + "isDeprecatedLicenseId": true, + "detailsUrl": "https://spdx.org/licenses/LGPL-2.1+.json", + "referenceNumber": 237, + "name": "GNU Library General Public License v2.1 or later", + "licenseId": "LGPL-2.1+", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/lgpl-2.1-standalone.html", + "https://opensource.org/licenses/LGPL-2.1" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/OSL-2.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/OSL-2.1.json", + "referenceNumber": 238, + "name": "Open Software License 2.1", + "licenseId": "OSL-2.1", + "seeAlso": [ + "http://web.archive.org/web/20050212003940/http://www.rosenlaw.com/osl21.htm", + "https://opensource.org/licenses/OSL-2.1" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/psutils.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/psutils.json", + "referenceNumber": 239, + "name": "psutils License", + "licenseId": "psutils", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/psutils" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/SCEA.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/SCEA.json", + "referenceNumber": 240, + "name": "SCEA Shared Source License", + "licenseId": "SCEA", + "seeAlso": [ + "http://research.scea.com/scea_shared_source_license.html" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/MirOS.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/MirOS.json", + "referenceNumber": 241, + "name": "The MirOS Licence", + "licenseId": "MirOS", + "seeAlso": [ + "https://opensource.org/licenses/MirOS" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/Hippocratic-2.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Hippocratic-2.1.json", + "referenceNumber": 242, + "name": "Hippocratic License 2.1", + "licenseId": "Hippocratic-2.1", + "seeAlso": [ + "https://firstdonoharm.dev/version/2/1/license.html", + "https://github.com/EthicalSource/hippocratic-license/blob/58c0e646d64ff6fbee275bfe2b9492f914e3ab2a/LICENSE.txt" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/GFDL-1.2-invariants-only.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/GFDL-1.2-invariants-only.json", + "referenceNumber": 243, + "name": "GNU Free Documentation License v1.2 only - invariants", + "licenseId": "GFDL-1.2-invariants-only", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/fdl-1.2.txt" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/LGPL-2.1-only.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/LGPL-2.1-only.json", + "referenceNumber": 244, + "name": "GNU Lesser General Public License v2.1 only", + "licenseId": "LGPL-2.1-only", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/lgpl-2.1-standalone.html", + "https://opensource.org/licenses/LGPL-2.1" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/Entessa.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Entessa.json", + "referenceNumber": 245, + "name": "Entessa Public License v1.0", + "licenseId": "Entessa", + "seeAlso": [ + "https://opensource.org/licenses/Entessa" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/MS-RL.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/MS-RL.json", + "referenceNumber": 246, + "name": "Microsoft Reciprocal License", + "licenseId": "MS-RL", + "seeAlso": [ + "http://www.microsoft.com/opensource/licenses.mspx", + "https://opensource.org/licenses/MS-RL" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/libselinux-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/libselinux-1.0.json", + "referenceNumber": 247, + "name": "libselinux public domain notice", + "licenseId": "libselinux-1.0", + "seeAlso": [ + "https://github.com/SELinuxProject/selinux/blob/master/libselinux/LICENSE" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/LGPL-2.0.html", + "isDeprecatedLicenseId": true, + "detailsUrl": "https://spdx.org/licenses/LGPL-2.0.json", + "referenceNumber": 248, + "name": "GNU Library General Public License v2 only", + "licenseId": "LGPL-2.0", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/lgpl-2.0-standalone.html" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/OLDAP-2.5.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/OLDAP-2.5.json", + "referenceNumber": 249, + "name": "Open LDAP Public License v2.5", + "licenseId": "OLDAP-2.5", + "seeAlso": [ + "http://www.openldap.org/devel/gitweb.cgi?p\u003dopenldap.git;a\u003dblob;f\u003dLICENSE;hb\u003d6852b9d90022e8593c98205413380536b1b5a7cf" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/Imlib2.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Imlib2.json", + "referenceNumber": 250, + "name": "Imlib2 License", + "licenseId": "Imlib2", + "seeAlso": [ + "http://trac.enlightenment.org/e/browser/trunk/imlib2/COPYING", + "https://git.enlightenment.org/legacy/imlib2.git/tree/COPYING" + ], + "isOsiApproved": false, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/Libpng.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Libpng.json", + "referenceNumber": 251, + "name": "libpng License", + "licenseId": "Libpng", + "seeAlso": [ + "http://www.libpng.org/pub/png/src/libpng-LICENSE.txt" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/SchemeReport.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/SchemeReport.json", + "referenceNumber": 252, + "name": "Scheme Language Report License", + "licenseId": "SchemeReport", + "seeAlso": [], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/MPL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/MPL-1.0.json", + "referenceNumber": 253, + "name": "Mozilla Public License 1.0", + "licenseId": "MPL-1.0", + "seeAlso": [ + "http://www.mozilla.org/MPL/MPL-1.0.html", + "https://opensource.org/licenses/MPL-1.0" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/SAX-PD.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/SAX-PD.json", + "referenceNumber": 254, + "name": "Sax Public Domain Notice", + "licenseId": "SAX-PD", + "seeAlso": [ + "http://www.saxproject.org/copying.html" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/NLOD-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/NLOD-1.0.json", + "referenceNumber": 255, + "name": "Norwegian Licence for Open Government Data (NLOD) 1.0", + "licenseId": "NLOD-1.0", + "seeAlso": [ + "http://data.norge.no/nlod/en/1.0" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/SimPL-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/SimPL-2.0.json", + "referenceNumber": 256, + "name": "Simple Public License 2.0", + "licenseId": "SimPL-2.0", + "seeAlso": [ + "https://opensource.org/licenses/SimPL-2.0" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/TU-Berlin-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/TU-Berlin-1.0.json", + "referenceNumber": 257, + "name": "Technische Universitaet Berlin License 1.0", + "licenseId": "TU-Berlin-1.0", + "seeAlso": [ + "https://github.com/swh/ladspa/blob/7bf6f3799fdba70fda297c2d8fd9f526803d9680/gsm/COPYRIGHT" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/GFDL-1.1-no-invariants-only.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/GFDL-1.1-no-invariants-only.json", + "referenceNumber": 258, + "name": "GNU Free Documentation License v1.1 only - no invariants", + "licenseId": "GFDL-1.1-no-invariants-only", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/fdl-1.1.txt" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/CC-BY-ND-3.0-DE.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CC-BY-ND-3.0-DE.json", + "referenceNumber": 259, + "name": "Creative Commons Attribution No Derivatives 3.0 Germany", + "licenseId": "CC-BY-ND-3.0-DE", + "seeAlso": [ + "https://creativecommons.org/licenses/by-nd/3.0/de/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/MakeIndex.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/MakeIndex.json", + "referenceNumber": 260, + "name": "MakeIndex License", + "licenseId": "MakeIndex", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/MakeIndex" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/EPICS.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/EPICS.json", + "referenceNumber": 261, + "name": "EPICS Open License", + "licenseId": "EPICS", + "seeAlso": [ + "https://epics.anl.gov/license/open.php" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/GFDL-1.3-invariants-only.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/GFDL-1.3-invariants-only.json", + "referenceNumber": 262, + "name": "GNU Free Documentation License v1.3 only - invariants", + "licenseId": "GFDL-1.3-invariants-only", + "seeAlso": [ + "https://www.gnu.org/licenses/fdl-1.3.txt" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/XSkat.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/XSkat.json", + "referenceNumber": 263, + "name": "XSkat License", + "licenseId": "XSkat", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/XSkat_License" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/bzip2-1.0.5.html", + "isDeprecatedLicenseId": true, + "detailsUrl": "https://spdx.org/licenses/bzip2-1.0.5.json", + "referenceNumber": 264, + "name": "bzip2 and libbzip2 License v1.0.5", + "licenseId": "bzip2-1.0.5", + "seeAlso": [ + "https://sourceware.org/bzip2/1.0.5/bzip2-manual-1.0.5.html", + "http://bzip.org/1.0.5/bzip2-manual-1.0.5.html" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/Community-Spec-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Community-Spec-1.0.json", + "referenceNumber": 265, + "name": "Community Specification License 1.0", + "licenseId": "Community-Spec-1.0", + "seeAlso": [ + "https://github.com/CommunitySpecification/1.0/blob/master/1._Community_Specification_License-v1.md" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/GL2PS.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/GL2PS.json", + "referenceNumber": 266, + "name": "GL2PS License", + "licenseId": "GL2PS", + "seeAlso": [ + "http://www.geuz.org/gl2ps/COPYING.GL2PS" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/HPND.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/HPND.json", + "referenceNumber": 267, + "name": "Historical Permission Notice and Disclaimer", + "licenseId": "HPND", + "seeAlso": [ + "https://opensource.org/licenses/HPND" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/bzip2-1.0.6.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/bzip2-1.0.6.json", + "referenceNumber": 268, + "name": "bzip2 and libbzip2 License v1.0.6", + "licenseId": "bzip2-1.0.6", + "seeAlso": [ + "https://sourceware.org/git/?p\u003dbzip2.git;a\u003dblob;f\u003dLICENSE;hb\u003dbzip2-1.0.6", + "http://bzip.org/1.0.5/bzip2-manual-1.0.5.html" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/CC-BY-NC-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CC-BY-NC-1.0.json", + "referenceNumber": 269, + "name": "Creative Commons Attribution Non Commercial 1.0 Generic", + "licenseId": "CC-BY-NC-1.0", + "seeAlso": [ + "https://creativecommons.org/licenses/by-nc/1.0/legalcode" + ], + "isOsiApproved": false, + "isFsfLibre": false + }, + { + "reference": "https://spdx.org/licenses/Fair.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Fair.json", + "referenceNumber": 270, + "name": "Fair License", + "licenseId": "Fair", + "seeAlso": [ + "http://fairlicense.org/", + "https://opensource.org/licenses/Fair" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/CECILL-B.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CECILL-B.json", + "referenceNumber": 271, + "name": "CeCILL-B Free Software License Agreement", + "licenseId": "CECILL-B", + "seeAlso": [ + "http://www.cecill.info/licences/Licence_CeCILL-B_V1-en.html" + ], + "isOsiApproved": false, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/Glide.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Glide.json", + "referenceNumber": 272, + "name": "3dfx Glide License", + "licenseId": "Glide", + "seeAlso": [ + "http://www.users.on.net/~triforce/glidexp/COPYING.txt" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/CC-BY-SA-4.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CC-BY-SA-4.0.json", + "referenceNumber": 273, + "name": "Creative Commons Attribution Share Alike 4.0 International", + "licenseId": "CC-BY-SA-4.0", + "seeAlso": [ + "https://creativecommons.org/licenses/by-sa/4.0/legalcode" + ], + "isOsiApproved": false, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/CC0-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CC0-1.0.json", + "referenceNumber": 274, + "name": "Creative Commons Zero v1.0 Universal", + "licenseId": "CC0-1.0", + "seeAlso": [ + "https://creativecommons.org/publicdomain/zero/1.0/legalcode" + ], + "isOsiApproved": false, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/MIT-enna.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/MIT-enna.json", + "referenceNumber": 275, + "name": "enna License", + "licenseId": "MIT-enna", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/MIT#enna" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/Wsuipa.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Wsuipa.json", + "referenceNumber": 276, + "name": "Wsuipa License", + "licenseId": "Wsuipa", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Wsuipa" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/RSA-MD.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/RSA-MD.json", + "referenceNumber": 277, + "name": "RSA Message-Digest License", + "licenseId": "RSA-MD", + "seeAlso": [ + "http://www.faqs.org/rfcs/rfc1321.html" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/VOSTROM.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/VOSTROM.json", + "referenceNumber": 278, + "name": "VOSTROM Public License for Open Source", + "licenseId": "VOSTROM", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/VOSTROM" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/O-UDA-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/O-UDA-1.0.json", + "referenceNumber": 279, + "name": "Open Use of Data Agreement v1.0", + "licenseId": "O-UDA-1.0", + "seeAlso": [ + "https://github.com/microsoft/Open-Use-of-Data-Agreement/blob/v1.0/O-UDA-1.0.md", + "https://cdla.dev/open-use-of-data-agreement-v1-0/" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/CERN-OHL-S-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CERN-OHL-S-2.0.json", + "referenceNumber": 280, + "name": "CERN Open Hardware Licence Version 2 - Strongly Reciprocal", + "licenseId": "CERN-OHL-S-2.0", + "seeAlso": [ + "https://www.ohwr.org/project/cernohl/wikis/Documents/CERN-OHL-version-2" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/X11-distribute-modifications-variant.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/X11-distribute-modifications-variant.json", + "referenceNumber": 281, + "name": "X11 License Distribution Modification Variant", + "licenseId": "X11-distribute-modifications-variant", + "seeAlso": [ + "https://github.com/mirror/ncurses/blob/master/COPYING" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/copyleft-next-0.3.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/copyleft-next-0.3.0.json", + "referenceNumber": 282, + "name": "copyleft-next 0.3.0", + "licenseId": "copyleft-next-0.3.0", + "seeAlso": [ + "https://github.com/copyleft-next/copyleft-next/blob/master/Releases/copyleft-next-0.3.0" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/Zimbra-1.3.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Zimbra-1.3.json", + "referenceNumber": 283, + "name": "Zimbra Public License v1.3", + "licenseId": "Zimbra-1.3", + "seeAlso": [ + "http://web.archive.org/web/20100302225219/http://www.zimbra.com/license/zimbra-public-license-1-3.html" + ], + "isOsiApproved": false, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/NIST-PD-fallback.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/NIST-PD-fallback.json", + "referenceNumber": 284, + "name": "NIST Public Domain Notice with license fallback", + "licenseId": "NIST-PD-fallback", + "seeAlso": [ + "https://github.com/usnistgov/jsip/blob/59700e6926cbe96c5cdae897d9a7d2656b42abe3/LICENSE", + "https://github.com/usnistgov/fipy/blob/86aaa5c2ba2c6f1be19593c5986071cf6568cc34/LICENSE.rst" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/Nokia.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Nokia.json", + "referenceNumber": 285, + "name": "Nokia Open Source License", + "licenseId": "Nokia", + "seeAlso": [ + "https://opensource.org/licenses/nokia" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/AFL-2.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/AFL-2.1.json", + "referenceNumber": 286, + "name": "Academic Free License v2.1", + "licenseId": "AFL-2.1", + "seeAlso": [ + "http://opensource.linux-mirror.org/licenses/afl-2.1.txt" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/ZPL-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/ZPL-2.0.json", + "referenceNumber": 287, + "name": "Zope Public License 2.0", + "licenseId": "ZPL-2.0", + "seeAlso": [ + "http://old.zope.org/Resources/License/ZPL-2.0", + "https://opensource.org/licenses/ZPL-2.0" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/ODbL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/ODbL-1.0.json", + "referenceNumber": 288, + "name": "Open Data Commons Open Database License v1.0", + "licenseId": "ODbL-1.0", + "seeAlso": [ + "http://www.opendatacommons.org/licenses/odbl/1.0/", + "https://opendatacommons.org/licenses/odbl/1-0/" + ], + "isOsiApproved": false, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/zlib-acknowledgement.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/zlib-acknowledgement.json", + "referenceNumber": 289, + "name": "zlib/libpng License with Acknowledgement", + "licenseId": "zlib-acknowledgement", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/ZlibWithAcknowledgement" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/PHP-3.01.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/PHP-3.01.json", + "referenceNumber": 290, + "name": "PHP License v3.01", + "licenseId": "PHP-3.01", + "seeAlso": [ + "http://www.php.net/license/3_01.txt" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/Afmparse.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Afmparse.json", + "referenceNumber": 291, + "name": "Afmparse License", + "licenseId": "Afmparse", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Afmparse" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/HPND-sell-variant.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/HPND-sell-variant.json", + "referenceNumber": 292, + "name": "Historical Permission Notice and Disclaimer - sell variant", + "licenseId": "HPND-sell-variant", + "seeAlso": [ + "https://git.kernel.org/pub/scm/linux/kernel/git/torvalds/linux.git/tree/net/sunrpc/auth_gss/gss_generic_token.c?h\u003dv4.19" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/PolyForm-Small-Business-1.0.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/PolyForm-Small-Business-1.0.0.json", + "referenceNumber": 293, + "name": "PolyForm Small Business License 1.0.0", + "licenseId": "PolyForm-Small-Business-1.0.0", + "seeAlso": [ + "https://polyformproject.org/licenses/small-business/1.0.0" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/IPL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/IPL-1.0.json", + "referenceNumber": 294, + "name": "IBM Public License v1.0", + "licenseId": "IPL-1.0", + "seeAlso": [ + "https://opensource.org/licenses/IPL-1.0" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/CECILL-1.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CECILL-1.1.json", + "referenceNumber": 295, + "name": "CeCILL Free Software License Agreement v1.1", + "licenseId": "CECILL-1.1", + "seeAlso": [ + "http://www.cecill.info/licences/Licence_CeCILL_V1.1-US.html" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/MIT-feh.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/MIT-feh.json", + "referenceNumber": 296, + "name": "feh License", + "licenseId": "MIT-feh", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/MIT#feh" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/OFL-1.0-RFN.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/OFL-1.0-RFN.json", + "referenceNumber": 297, + "name": "SIL Open Font License 1.0 with Reserved Font Name", + "licenseId": "OFL-1.0-RFN", + "seeAlso": [ + "http://scripts.sil.org/cms/scripts/page.php?item_id\u003dOFL10_web" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/TMate.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/TMate.json", + "referenceNumber": 298, + "name": "TMate Open Source License", + "licenseId": "TMate", + "seeAlso": [ + "http://svnkit.com/license.html" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/BSD-3-Clause-No-Nuclear-License.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/BSD-3-Clause-No-Nuclear-License.json", + "referenceNumber": 299, + "name": "BSD 3-Clause No Nuclear License", + "licenseId": "BSD-3-Clause-No-Nuclear-License", + "seeAlso": [ + "http://download.oracle.com/otn-pub/java/licenses/bsd.txt?AuthParam\u003d1467140197_43d516ce1776bd08a58235a7785be1cc" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/W3C-19980720.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/W3C-19980720.json", + "referenceNumber": 300, + "name": "W3C Software Notice and License (1998-07-20)", + "licenseId": "W3C-19980720", + "seeAlso": [ + "http://www.w3.org/Consortium/Legal/copyright-software-19980720.html" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/SPL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/SPL-1.0.json", + "referenceNumber": 301, + "name": "Sun Public License v1.0", + "licenseId": "SPL-1.0", + "seeAlso": [ + "https://opensource.org/licenses/SPL-1.0" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/NetCDF.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/NetCDF.json", + "referenceNumber": 302, + "name": "NetCDF license", + "licenseId": "NetCDF", + "seeAlso": [ + "http://www.unidata.ucar.edu/software/netcdf/copyright.html" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/Aladdin.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Aladdin.json", + "referenceNumber": 303, + "name": "Aladdin Free Public License", + "licenseId": "Aladdin", + "seeAlso": [ + "http://pages.cs.wisc.edu/~ghost/doc/AFPL/6.01/Public.htm" + ], + "isOsiApproved": false, + "isFsfLibre": false + }, + { + "reference": "https://spdx.org/licenses/AMDPLPA.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/AMDPLPA.json", + "referenceNumber": 304, + "name": "AMD\u0027s plpa_map.c License", + "licenseId": "AMDPLPA", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/AMD_plpa_map_License" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/CrystalStacker.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CrystalStacker.json", + "referenceNumber": 305, + "name": "CrystalStacker License", + "licenseId": "CrystalStacker", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing:CrystalStacker?rd\u003dLicensing/CrystalStacker" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/Intel-ACPI.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Intel-ACPI.json", + "referenceNumber": 306, + "name": "Intel ACPI Software License Agreement", + "licenseId": "Intel-ACPI", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Intel_ACPI_Software_License_Agreement" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/CERN-OHL-1.2.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CERN-OHL-1.2.json", + "referenceNumber": 307, + "name": "CERN Open Hardware Licence v1.2", + "licenseId": "CERN-OHL-1.2", + "seeAlso": [ + "https://www.ohwr.org/project/licenses/wikis/cern-ohl-v1.2" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/CC-BY-NC-SA-3.0-DE.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CC-BY-NC-SA-3.0-DE.json", + "referenceNumber": 308, + "name": "Creative Commons Attribution Non Commercial Share Alike 3.0 Germany", + "licenseId": "CC-BY-NC-SA-3.0-DE", + "seeAlso": [ + "https://creativecommons.org/licenses/by-nc-sa/3.0/de/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/MIT.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/MIT.json", + "referenceNumber": 309, + "name": "MIT License", + "licenseId": "MIT", + "seeAlso": [ + "https://opensource.org/licenses/MIT" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/Zed.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Zed.json", + "referenceNumber": 310, + "name": "Zed License", + "licenseId": "Zed", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Zed" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/OLDAP-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/OLDAP-2.0.json", + "referenceNumber": 311, + "name": "Open LDAP Public License v2.0 (or possibly 2.0A and 2.0B)", + "licenseId": "OLDAP-2.0", + "seeAlso": [ + "http://www.openldap.org/devel/gitweb.cgi?p\u003dopenldap.git;a\u003dblob;f\u003dLICENSE;hb\u003dcbf50f4e1185a21abd4c0a54d3f4341fe28f36ea" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/MulanPSL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/MulanPSL-1.0.json", + "referenceNumber": 312, + "name": "Mulan Permissive Software License, Version 1", + "licenseId": "MulanPSL-1.0", + "seeAlso": [ + "https://license.coscl.org.cn/MulanPSL/", + "https://github.com/yuwenlong/longphp/blob/25dfb70cc2a466dc4bb55ba30901cbce08d164b5/LICENSE" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/EFL-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/EFL-2.0.json", + "referenceNumber": 313, + "name": "Eiffel Forum License v2.0", + "licenseId": "EFL-2.0", + "seeAlso": [ + "http://www.eiffel-nice.org/license/eiffel-forum-license-2.html", + "https://opensource.org/licenses/EFL-2.0" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/Latex2e.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Latex2e.json", + "referenceNumber": 314, + "name": "Latex2e License", + "licenseId": "Latex2e", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Latex2e" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/Spencer-94.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Spencer-94.json", + "referenceNumber": 315, + "name": "Spencer License 94", + "licenseId": "Spencer-94", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Henry_Spencer_Reg-Ex_Library_License" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/OPL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/OPL-1.0.json", + "referenceNumber": 316, + "name": "Open Public License v1.0", + "licenseId": "OPL-1.0", + "seeAlso": [ + "http://old.koalateam.com/jackaroo/OPL_1_0.TXT", + "https://fedoraproject.org/wiki/Licensing/Open_Public_License" + ], + "isOsiApproved": false, + "isFsfLibre": false + }, + { + "reference": "https://spdx.org/licenses/CC-BY-NC-4.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CC-BY-NC-4.0.json", + "referenceNumber": 317, + "name": "Creative Commons Attribution Non Commercial 4.0 International", + "licenseId": "CC-BY-NC-4.0", + "seeAlso": [ + "https://creativecommons.org/licenses/by-nc/4.0/legalcode" + ], + "isOsiApproved": false, + "isFsfLibre": false + }, + { + "reference": "https://spdx.org/licenses/LGPL-3.0-or-later.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/LGPL-3.0-or-later.json", + "referenceNumber": 318, + "name": "GNU Lesser General Public License v3.0 or later", + "licenseId": "LGPL-3.0-or-later", + "seeAlso": [ + "https://www.gnu.org/licenses/lgpl-3.0-standalone.html", + "https://opensource.org/licenses/LGPL-3.0" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/UPL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/UPL-1.0.json", + "referenceNumber": 319, + "name": "Universal Permissive License v1.0", + "licenseId": "UPL-1.0", + "seeAlso": [ + "https://opensource.org/licenses/UPL" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/NCSA.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/NCSA.json", + "referenceNumber": 320, + "name": "University of Illinois/NCSA Open Source License", + "licenseId": "NCSA", + "seeAlso": [ + "http://otm.illinois.edu/uiuc_openSource", + "https://opensource.org/licenses/NCSA" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/SGI-B-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/SGI-B-2.0.json", + "referenceNumber": 321, + "name": "SGI Free Software License B v2.0", + "licenseId": "SGI-B-2.0", + "seeAlso": [ + "http://oss.sgi.com/projects/FreeB/SGIFreeSWLicB.2.0.pdf" + ], + "isOsiApproved": false, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/GPL-3.0-with-GCC-exception.html", + "isDeprecatedLicenseId": true, + "detailsUrl": "https://spdx.org/licenses/GPL-3.0-with-GCC-exception.json", + "referenceNumber": 322, + "name": "GNU General Public License v3.0 w/GCC Runtime Library exception", + "licenseId": "GPL-3.0-with-GCC-exception", + "seeAlso": [ + "https://www.gnu.org/licenses/gcc-exception-3.1.html" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/Zend-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Zend-2.0.json", + "referenceNumber": 323, + "name": "Zend License v2.0", + "licenseId": "Zend-2.0", + "seeAlso": [ + "https://web.archive.org/web/20130517195954/http://www.zend.com/license/2_00.txt" + ], + "isOsiApproved": false, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/ImageMagick.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/ImageMagick.json", + "referenceNumber": 324, + "name": "ImageMagick License", + "licenseId": "ImageMagick", + "seeAlso": [ + "http://www.imagemagick.org/script/license.php" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/OLDAP-2.6.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/OLDAP-2.6.json", + "referenceNumber": 325, + "name": "Open LDAP Public License v2.6", + "licenseId": "OLDAP-2.6", + "seeAlso": [ + "http://www.openldap.org/devel/gitweb.cgi?p\u003dopenldap.git;a\u003dblob;f\u003dLICENSE;hb\u003d1cae062821881f41b73012ba816434897abf4205" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/Unicode-TOU.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Unicode-TOU.json", + "referenceNumber": 326, + "name": "Unicode Terms of Use", + "licenseId": "Unicode-TOU", + "seeAlso": [ + "http://www.unicode.org/copyright.html" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/GPL-3.0-only.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/GPL-3.0-only.json", + "referenceNumber": 327, + "name": "GNU General Public License v3.0 only", + "licenseId": "GPL-3.0-only", + "seeAlso": [ + "https://www.gnu.org/licenses/gpl-3.0-standalone.html", + "https://opensource.org/licenses/GPL-3.0" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/Artistic-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Artistic-2.0.json", + "referenceNumber": 328, + "name": "Artistic License 2.0", + "licenseId": "Artistic-2.0", + "seeAlso": [ + "http://www.perlfoundation.org/artistic_license_2_0", + "https://www.perlfoundation.org/artistic-license-20.html", + "https://opensource.org/licenses/artistic-license-2.0" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/blessing.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/blessing.json", + "referenceNumber": 329, + "name": "SQLite Blessing", + "licenseId": "blessing", + "seeAlso": [ + "https://www.sqlite.org/src/artifact/e33a4df7e32d742a?ln\u003d4-9", + "https://sqlite.org/src/artifact/df5091916dbb40e6" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/etalab-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/etalab-2.0.json", + "referenceNumber": 330, + "name": "Etalab Open License 2.0", + "licenseId": "etalab-2.0", + "seeAlso": [ + "https://github.com/DISIC/politique-de-contribution-open-source/blob/master/LICENSE.pdf", + "https://raw.githubusercontent.com/DISIC/politique-de-contribution-open-source/master/LICENSE" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/GFDL-1.2-only.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/GFDL-1.2-only.json", + "referenceNumber": 331, + "name": "GNU Free Documentation License v1.2 only", + "licenseId": "GFDL-1.2-only", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/fdl-1.2.txt" + ], + "isOsiApproved": false, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/LPPL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/LPPL-1.0.json", + "referenceNumber": 332, + "name": "LaTeX Project Public License v1.0", + "licenseId": "LPPL-1.0", + "seeAlso": [ + "http://www.latex-project.org/lppl/lppl-1-0.txt" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/Rdisc.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Rdisc.json", + "referenceNumber": 333, + "name": "Rdisc License", + "licenseId": "Rdisc", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Rdisc_License" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/BSD-3-Clause-Modification.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/BSD-3-Clause-Modification.json", + "referenceNumber": 334, + "name": "BSD 3-Clause Modification", + "licenseId": "BSD-3-Clause-Modification", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing:BSD#Modification_Variant" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/Xerox.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Xerox.json", + "referenceNumber": 335, + "name": "Xerox License", + "licenseId": "Xerox", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Xerox" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/MPL-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/MPL-2.0.json", + "referenceNumber": 336, + "name": "Mozilla Public License 2.0", + "licenseId": "MPL-2.0", + "seeAlso": [ + "https://www.mozilla.org/MPL/2.0/", + "https://opensource.org/licenses/MPL-2.0" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/BitTorrent-1.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/BitTorrent-1.1.json", + "referenceNumber": 337, + "name": "BitTorrent Open Source License v1.1", + "licenseId": "BitTorrent-1.1", + "seeAlso": [ + "http://directory.fsf.org/wiki/License:BitTorrentOSL1.1" + ], + "isOsiApproved": false, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/CC-BY-NC-ND-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CC-BY-NC-ND-2.0.json", + "referenceNumber": 338, + "name": "Creative Commons Attribution Non Commercial No Derivatives 2.0 Generic", + "licenseId": "CC-BY-NC-ND-2.0", + "seeAlso": [ + "https://creativecommons.org/licenses/by-nc-nd/2.0/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/SISSL.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/SISSL.json", + "referenceNumber": 339, + "name": "Sun Industry Standards Source License v1.1", + "licenseId": "SISSL", + "seeAlso": [ + "http://www.openoffice.org/licenses/sissl_license.html", + "https://opensource.org/licenses/SISSL" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/libtiff.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/libtiff.json", + "referenceNumber": 340, + "name": "libtiff License", + "licenseId": "libtiff", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/libtiff" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/CC-BY-NC-SA-2.0-UK.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CC-BY-NC-SA-2.0-UK.json", + "referenceNumber": 341, + "name": "Creative Commons Attribution Non Commercial Share Alike 2.0 England and Wales", + "licenseId": "CC-BY-NC-SA-2.0-UK", + "seeAlso": [ + "https://creativecommons.org/licenses/by-nc-sa/2.0/uk/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/D-FSL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/D-FSL-1.0.json", + "referenceNumber": 342, + "name": "Deutsche Freie Software Lizenz", + "licenseId": "D-FSL-1.0", + "seeAlso": [ + "http://www.dipp.nrw.de/d-fsl/lizenzen/", + "http://www.dipp.nrw.de/d-fsl/index_html/lizenzen/de/D-FSL-1_0_de.txt", + "http://www.dipp.nrw.de/d-fsl/index_html/lizenzen/en/D-FSL-1_0_en.txt", + "https://www.hbz-nrw.de/produkte/open-access/lizenzen/dfsl", + "https://www.hbz-nrw.de/produkte/open-access/lizenzen/dfsl/deutsche-freie-software-lizenz", + "https://www.hbz-nrw.de/produkte/open-access/lizenzen/dfsl/german-free-software-license", + "https://www.hbz-nrw.de/produkte/open-access/lizenzen/dfsl/D-FSL-1_0_de.txt/at_download/file", + "https://www.hbz-nrw.de/produkte/open-access/lizenzen/dfsl/D-FSL-1_0_en.txt/at_download/file" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/LPPL-1.2.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/LPPL-1.2.json", + "referenceNumber": 343, + "name": "LaTeX Project Public License v1.2", + "licenseId": "LPPL-1.2", + "seeAlso": [ + "http://www.latex-project.org/lppl/lppl-1-2.txt" + ], + "isOsiApproved": false, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/TAPR-OHL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/TAPR-OHL-1.0.json", + "referenceNumber": 344, + "name": "TAPR Open Hardware License v1.0", + "licenseId": "TAPR-OHL-1.0", + "seeAlso": [ + "https://www.tapr.org/OHL" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/EUPL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/EUPL-1.0.json", + "referenceNumber": 345, + "name": "European Union Public License 1.0", + "licenseId": "EUPL-1.0", + "seeAlso": [ + "http://ec.europa.eu/idabc/en/document/7330.html", + "http://ec.europa.eu/idabc/servlets/Doc027f.pdf?id\u003d31096" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/SHL-0.51.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/SHL-0.51.json", + "referenceNumber": 346, + "name": "Solderpad Hardware License, Version 0.51", + "licenseId": "SHL-0.51", + "seeAlso": [ + "https://solderpad.org/licenses/SHL-0.51/" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/FTL.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/FTL.json", + "referenceNumber": 347, + "name": "Freetype Project License", + "licenseId": "FTL", + "seeAlso": [ + "http://freetype.fis.uniroma2.it/FTL.TXT", + "http://git.savannah.gnu.org/cgit/freetype/freetype2.git/tree/docs/FTL.TXT", + "http://gitlab.freedesktop.org/freetype/freetype/-/raw/master/docs/FTL.TXT" + ], + "isOsiApproved": false, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/W3C-20150513.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/W3C-20150513.json", + "referenceNumber": 348, + "name": "W3C Software Notice and Document License (2015-05-13)", + "licenseId": "W3C-20150513", + "seeAlso": [ + "https://www.w3.org/Consortium/Legal/2015/copyright-software-and-document" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/OSET-PL-2.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/OSET-PL-2.1.json", + "referenceNumber": 349, + "name": "OSET Public License version 2.1", + "licenseId": "OSET-PL-2.1", + "seeAlso": [ + "http://www.osetfoundation.org/public-license", + "https://opensource.org/licenses/OPL-2.1" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/EUDatagrid.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/EUDatagrid.json", + "referenceNumber": 350, + "name": "EU DataGrid Software License", + "licenseId": "EUDatagrid", + "seeAlso": [ + "http://eu-datagrid.web.cern.ch/eu-datagrid/license.html", + "https://opensource.org/licenses/EUDatagrid" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/UCL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/UCL-1.0.json", + "referenceNumber": 351, + "name": "Upstream Compatibility License v1.0", + "licenseId": "UCL-1.0", + "seeAlso": [ + "https://opensource.org/licenses/UCL-1.0" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/Borceux.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Borceux.json", + "referenceNumber": 352, + "name": "Borceux license", + "licenseId": "Borceux", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Borceux" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/Elastic-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Elastic-2.0.json", + "referenceNumber": 353, + "name": "Elastic License 2.0", + "licenseId": "Elastic-2.0", + "seeAlso": [ + "https://www.elastic.co/licensing/elastic-license", + "https://github.com/elastic/elasticsearch/blob/master/licenses/ELASTIC-LICENSE-2.0.txt" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/BSD-2-Clause-NetBSD.html", + "isDeprecatedLicenseId": true, + "detailsUrl": "https://spdx.org/licenses/BSD-2-Clause-NetBSD.json", + "referenceNumber": 354, + "name": "BSD 2-Clause NetBSD License", + "licenseId": "BSD-2-Clause-NetBSD", + "seeAlso": [ + "http://www.netbsd.org/about/redistribution.html#default" + ], + "isOsiApproved": false, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/BSD-3-Clause-Open-MPI.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/BSD-3-Clause-Open-MPI.json", + "referenceNumber": 355, + "name": "BSD 3-Clause Open MPI variant", + "licenseId": "BSD-3-Clause-Open-MPI", + "seeAlso": [ + "https://www.open-mpi.org/community/license.php", + "http://www.netlib.org/lapack/LICENSE.txt" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/OSL-3.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/OSL-3.0.json", + "referenceNumber": 356, + "name": "Open Software License 3.0", + "licenseId": "OSL-3.0", + "seeAlso": [ + "https://web.archive.org/web/20120101081418/http://rosenlaw.com:80/OSL3.0.htm", + "https://opensource.org/licenses/OSL-3.0" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/curl.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/curl.json", + "referenceNumber": 357, + "name": "curl License", + "licenseId": "curl", + "seeAlso": [ + "https://github.com/bagder/curl/blob/master/COPYING" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/Spencer-86.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Spencer-86.json", + "referenceNumber": 358, + "name": "Spencer License 86", + "licenseId": "Spencer-86", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Henry_Spencer_Reg-Ex_Library_License" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/BSL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/BSL-1.0.json", + "referenceNumber": 359, + "name": "Boost Software License 1.0", + "licenseId": "BSL-1.0", + "seeAlso": [ + "http://www.boost.org/LICENSE_1_0.txt", + "https://opensource.org/licenses/BSL-1.0" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/SMLNJ.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/SMLNJ.json", + "referenceNumber": 360, + "name": "Standard ML of New Jersey License", + "licenseId": "SMLNJ", + "seeAlso": [ + "https://www.smlnj.org/license.html" + ], + "isOsiApproved": false, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/TOSL.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/TOSL.json", + "referenceNumber": 361, + "name": "Trusster Open Source License", + "licenseId": "TOSL", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/TOSL" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/NOSL.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/NOSL.json", + "referenceNumber": 362, + "name": "Netizen Open Source License", + "licenseId": "NOSL", + "seeAlso": [ + "http://bits.netizen.com.au/licenses/NOSL/nosl.txt" + ], + "isOsiApproved": false, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/AFL-1.2.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/AFL-1.2.json", + "referenceNumber": 363, + "name": "Academic Free License v1.2", + "licenseId": "AFL-1.2", + "seeAlso": [ + "http://opensource.linux-mirror.org/licenses/afl-1.2.txt", + "http://wayback.archive.org/web/20021204204652/http://www.opensource.org/licenses/academic.php" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/MulanPSL-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/MulanPSL-2.0.json", + "referenceNumber": 364, + "name": "Mulan Permissive Software License, Version 2", + "licenseId": "MulanPSL-2.0", + "seeAlso": [ + "https://license.coscl.org.cn/MulanPSL2/" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/Motosoto.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Motosoto.json", + "referenceNumber": 365, + "name": "Motosoto License", + "licenseId": "Motosoto", + "seeAlso": [ + "https://opensource.org/licenses/Motosoto" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/CC-BY-NC-SA-2.5.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CC-BY-NC-SA-2.5.json", + "referenceNumber": 366, + "name": "Creative Commons Attribution Non Commercial Share Alike 2.5 Generic", + "licenseId": "CC-BY-NC-SA-2.5", + "seeAlso": [ + "https://creativecommons.org/licenses/by-nc-sa/2.5/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/JasPer-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/JasPer-2.0.json", + "referenceNumber": 367, + "name": "JasPer License", + "licenseId": "JasPer-2.0", + "seeAlso": [ + "http://www.ece.uvic.ca/~mdadams/jasper/LICENSE" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/BSD-4-Clause-UC.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/BSD-4-Clause-UC.json", + "referenceNumber": 368, + "name": "BSD-4-Clause (University of California-Specific)", + "licenseId": "BSD-4-Clause-UC", + "seeAlso": [ + "http://www.freebsd.org/copyright/license.html" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/Bahyph.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Bahyph.json", + "referenceNumber": 369, + "name": "Bahyph License", + "licenseId": "Bahyph", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Bahyph" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/VSL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/VSL-1.0.json", + "referenceNumber": 370, + "name": "Vovida Software License v1.0", + "licenseId": "VSL-1.0", + "seeAlso": [ + "https://opensource.org/licenses/VSL-1.0" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/W3C.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/W3C.json", + "referenceNumber": 371, + "name": "W3C Software Notice and License (2002-12-31)", + "licenseId": "W3C", + "seeAlso": [ + "http://www.w3.org/Consortium/Legal/2002/copyright-software-20021231.html", + "https://opensource.org/licenses/W3C" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/ODC-By-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/ODC-By-1.0.json", + "referenceNumber": 372, + "name": "Open Data Commons Attribution License v1.0", + "licenseId": "ODC-By-1.0", + "seeAlso": [ + "https://opendatacommons.org/licenses/by/1.0/" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/BitTorrent-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/BitTorrent-1.0.json", + "referenceNumber": 373, + "name": "BitTorrent Open Source License v1.0", + "licenseId": "BitTorrent-1.0", + "seeAlso": [ + "http://sources.gentoo.org/cgi-bin/viewvc.cgi/gentoo-x86/licenses/BitTorrent?r1\u003d1.1\u0026r2\u003d1.1.1.1\u0026diff_format\u003ds" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/OGL-UK-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/OGL-UK-2.0.json", + "referenceNumber": 374, + "name": "Open Government Licence v2.0", + "licenseId": "OGL-UK-2.0", + "seeAlso": [ + "http://www.nationalarchives.gov.uk/doc/open-government-licence/version/2/" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/LGPL-3.0-only.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/LGPL-3.0-only.json", + "referenceNumber": 375, + "name": "GNU Lesser General Public License v3.0 only", + "licenseId": "LGPL-3.0-only", + "seeAlso": [ + "https://www.gnu.org/licenses/lgpl-3.0-standalone.html", + "https://opensource.org/licenses/LGPL-3.0" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/Xnet.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Xnet.json", + "referenceNumber": 376, + "name": "X.Net License", + "licenseId": "Xnet", + "seeAlso": [ + "https://opensource.org/licenses/Xnet" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/Ruby.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Ruby.json", + "referenceNumber": 377, + "name": "Ruby License", + "licenseId": "Ruby", + "seeAlso": [ + "http://www.ruby-lang.org/en/LICENSE.txt" + ], + "isOsiApproved": false, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/GFDL-1.3.html", + "isDeprecatedLicenseId": true, + "detailsUrl": "https://spdx.org/licenses/GFDL-1.3.json", + "referenceNumber": 378, + "name": "GNU Free Documentation License v1.3", + "licenseId": "GFDL-1.3", + "seeAlso": [ + "https://www.gnu.org/licenses/fdl-1.3.txt" + ], + "isOsiApproved": false, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/ZPL-1.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/ZPL-1.1.json", + "referenceNumber": 379, + "name": "Zope Public License 1.1", + "licenseId": "ZPL-1.1", + "seeAlso": [ + "http://old.zope.org/Resources/License/ZPL-1.1" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/OCCT-PL.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/OCCT-PL.json", + "referenceNumber": 380, + "name": "Open CASCADE Technology Public License", + "licenseId": "OCCT-PL", + "seeAlso": [ + "http://www.opencascade.com/content/occt-public-license" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/LPPL-1.3c.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/LPPL-1.3c.json", + "referenceNumber": 381, + "name": "LaTeX Project Public License v1.3c", + "licenseId": "LPPL-1.3c", + "seeAlso": [ + "http://www.latex-project.org/lppl/lppl-1-3c.txt", + "https://opensource.org/licenses/LPPL-1.3c" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/Apache-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Apache-2.0.json", + "referenceNumber": 382, + "name": "Apache License 2.0", + "licenseId": "Apache-2.0", + "seeAlso": [ + "https://www.apache.org/licenses/LICENSE-2.0", + "https://opensource.org/licenses/Apache-2.0" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/GD.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/GD.json", + "referenceNumber": 383, + "name": "GD License", + "licenseId": "GD", + "seeAlso": [ + "https://libgd.github.io/manuals/2.3.0/files/license-txt.html" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/CC-BY-3.0-NL.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CC-BY-3.0-NL.json", + "referenceNumber": 384, + "name": "Creative Commons Attribution 3.0 Netherlands", + "licenseId": "CC-BY-3.0-NL", + "seeAlso": [ + "https://creativecommons.org/licenses/by/3.0/nl/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/LPPL-1.3a.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/LPPL-1.3a.json", + "referenceNumber": 385, + "name": "LaTeX Project Public License v1.3a", + "licenseId": "LPPL-1.3a", + "seeAlso": [ + "http://www.latex-project.org/lppl/lppl-1-3a.txt" + ], + "isOsiApproved": false, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/CC-BY-2.5-AU.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CC-BY-2.5-AU.json", + "referenceNumber": 386, + "name": "Creative Commons Attribution 2.5 Australia", + "licenseId": "CC-BY-2.5-AU", + "seeAlso": [ + "https://creativecommons.org/licenses/by/2.5/au/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/GFDL-1.1-only.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/GFDL-1.1-only.json", + "referenceNumber": 387, + "name": "GNU Free Documentation License v1.1 only", + "licenseId": "GFDL-1.1-only", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/fdl-1.1.txt" + ], + "isOsiApproved": false, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/GFDL-1.1-or-later.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/GFDL-1.1-or-later.json", + "referenceNumber": 388, + "name": "GNU Free Documentation License v1.1 or later", + "licenseId": "GFDL-1.1-or-later", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/fdl-1.1.txt" + ], + "isOsiApproved": false, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/OGL-UK-3.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/OGL-UK-3.0.json", + "referenceNumber": 389, + "name": "Open Government Licence v3.0", + "licenseId": "OGL-UK-3.0", + "seeAlso": [ + "http://www.nationalarchives.gov.uk/doc/open-government-licence/version/3/" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/YPL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/YPL-1.0.json", + "referenceNumber": 390, + "name": "Yahoo! Public License v1.0", + "licenseId": "YPL-1.0", + "seeAlso": [ + "http://www.zimbra.com/license/yahoo_public_license_1.0.html" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/RPL-1.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/RPL-1.1.json", + "referenceNumber": 391, + "name": "Reciprocal Public License 1.1", + "licenseId": "RPL-1.1", + "seeAlso": [ + "https://opensource.org/licenses/RPL-1.1" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/LGPL-2.0-or-later.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/LGPL-2.0-or-later.json", + "referenceNumber": 392, + "name": "GNU Library General Public License v2 or later", + "licenseId": "LGPL-2.0-or-later", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/lgpl-2.0-standalone.html" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/OPUBL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/OPUBL-1.0.json", + "referenceNumber": 393, + "name": "Open Publication License v1.0", + "licenseId": "OPUBL-1.0", + "seeAlso": [ + "http://opencontent.org/openpub/", + "https://www.debian.org/opl", + "https://www.ctan.org/license/opl" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/Noweb.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Noweb.json", + "referenceNumber": 394, + "name": "Noweb License", + "licenseId": "Noweb", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Noweb" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/AFL-3.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/AFL-3.0.json", + "referenceNumber": 395, + "name": "Academic Free License v3.0", + "licenseId": "AFL-3.0", + "seeAlso": [ + "http://www.rosenlaw.com/AFL3.0.htm", + "https://opensource.org/licenses/afl-3.0" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/Nunit.html", + "isDeprecatedLicenseId": true, + "detailsUrl": "https://spdx.org/licenses/Nunit.json", + "referenceNumber": 396, + "name": "Nunit License", + "licenseId": "Nunit", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Nunit" + ], + "isOsiApproved": false, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/CC-BY-3.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CC-BY-3.0.json", + "referenceNumber": 397, + "name": "Creative Commons Attribution 3.0 Unported", + "licenseId": "CC-BY-3.0", + "seeAlso": [ + "https://creativecommons.org/licenses/by/3.0/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/Beerware.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Beerware.json", + "referenceNumber": 398, + "name": "Beerware License", + "licenseId": "Beerware", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Beerware", + "https://people.freebsd.org/~phk/" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/Caldera.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Caldera.json", + "referenceNumber": 399, + "name": "Caldera License", + "licenseId": "Caldera", + "seeAlso": [ + "http://www.lemis.com/grog/UNIX/ancient-source-all.pdf" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/GPL-1.0.html", + "isDeprecatedLicenseId": true, + "detailsUrl": "https://spdx.org/licenses/GPL-1.0.json", + "referenceNumber": 400, + "name": "GNU General Public License v1.0 only", + "licenseId": "GPL-1.0", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/gpl-1.0-standalone.html" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/GPL-2.0+.html", + "isDeprecatedLicenseId": true, + "detailsUrl": "https://spdx.org/licenses/GPL-2.0+.json", + "referenceNumber": 401, + "name": "GNU General Public License v2.0 or later", + "licenseId": "GPL-2.0+", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/gpl-2.0-standalone.html", + "https://opensource.org/licenses/GPL-2.0" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/NCGL-UK-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/NCGL-UK-2.0.json", + "referenceNumber": 402, + "name": "Non-Commercial Government Licence", + "licenseId": "NCGL-UK-2.0", + "seeAlso": [ + "http://www.nationalarchives.gov.uk/doc/non-commercial-government-licence/version/2/" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/CC-BY-ND-2.5.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CC-BY-ND-2.5.json", + "referenceNumber": 403, + "name": "Creative Commons Attribution No Derivatives 2.5 Generic", + "licenseId": "CC-BY-ND-2.5", + "seeAlso": [ + "https://creativecommons.org/licenses/by-nd/2.5/legalcode" + ], + "isOsiApproved": false, + "isFsfLibre": false + }, + { + "reference": "https://spdx.org/licenses/GPL-2.0.html", + "isDeprecatedLicenseId": true, + "detailsUrl": "https://spdx.org/licenses/GPL-2.0.json", + "referenceNumber": 404, + "name": "GNU General Public License v2.0 only", + "licenseId": "GPL-2.0", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/gpl-2.0-standalone.html", + "https://opensource.org/licenses/GPL-2.0" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/Intel.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Intel.json", + "referenceNumber": 405, + "name": "Intel Open Source License", + "licenseId": "Intel", + "seeAlso": [ + "https://opensource.org/licenses/Intel" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/Vim.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Vim.json", + "referenceNumber": 406, + "name": "Vim License", + "licenseId": "Vim", + "seeAlso": [ + "http://vimdoc.sourceforge.net/htmldoc/uganda.html" + ], + "isOsiApproved": false, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/CC-BY-SA-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CC-BY-SA-2.0.json", + "referenceNumber": 407, + "name": "Creative Commons Attribution Share Alike 2.0 Generic", + "licenseId": "CC-BY-SA-2.0", + "seeAlso": [ + "https://creativecommons.org/licenses/by-sa/2.0/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/MITNFA.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/MITNFA.json", + "referenceNumber": 408, + "name": "MIT +no-false-attribs license", + "licenseId": "MITNFA", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/MITNFA" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/APSL-1.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/APSL-1.1.json", + "referenceNumber": 409, + "name": "Apple Public Source License 1.1", + "licenseId": "APSL-1.1", + "seeAlso": [ + "http://www.opensource.apple.com/source/IOSerialFamily/IOSerialFamily-7/APPLE_LICENSE" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/GFDL-1.2-or-later.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/GFDL-1.2-or-later.json", + "referenceNumber": 410, + "name": "GNU Free Documentation License v1.2 or later", + "licenseId": "GFDL-1.2-or-later", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/fdl-1.2.txt" + ], + "isOsiApproved": false, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/BSD-3-Clause-Attribution.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/BSD-3-Clause-Attribution.json", + "referenceNumber": 411, + "name": "BSD with attribution", + "licenseId": "BSD-3-Clause-Attribution", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/BSD_with_Attribution" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/OFL-1.0-no-RFN.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/OFL-1.0-no-RFN.json", + "referenceNumber": 412, + "name": "SIL Open Font License 1.0 with no Reserved Font Name", + "licenseId": "OFL-1.0-no-RFN", + "seeAlso": [ + "http://scripts.sil.org/cms/scripts/page.php?item_id\u003dOFL10_web" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/Naumen.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Naumen.json", + "referenceNumber": 413, + "name": "Naumen Public License", + "licenseId": "Naumen", + "seeAlso": [ + "https://opensource.org/licenses/Naumen" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/CC-BY-NC-ND-2.5.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CC-BY-NC-ND-2.5.json", + "referenceNumber": 414, + "name": "Creative Commons Attribution Non Commercial No Derivatives 2.5 Generic", + "licenseId": "CC-BY-NC-ND-2.5", + "seeAlso": [ + "https://creativecommons.org/licenses/by-nc-nd/2.5/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/C-UDA-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/C-UDA-1.0.json", + "referenceNumber": 415, + "name": "Computational Use of Data Agreement v1.0", + "licenseId": "C-UDA-1.0", + "seeAlso": [ + "https://github.com/microsoft/Computational-Use-of-Data-Agreement/blob/master/C-UDA-1.0.md", + "https://cdla.dev/computational-use-of-data-agreement-v1-0/" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/LGPLLR.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/LGPLLR.json", + "referenceNumber": 416, + "name": "Lesser General Public License For Linguistic Resources", + "licenseId": "LGPLLR", + "seeAlso": [ + "http://www-igm.univ-mlv.fr/~unitex/lgpllr.html" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/mpich2.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/mpich2.json", + "referenceNumber": 417, + "name": "mpich2 License", + "licenseId": "mpich2", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/MIT" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/APSL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/APSL-1.0.json", + "referenceNumber": 418, + "name": "Apple Public Source License 1.0", + "licenseId": "APSL-1.0", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Apple_Public_Source_License_1.0" + ], + "isOsiApproved": true, + "isFsfLibre": false + }, + { + "reference": "https://spdx.org/licenses/Linux-OpenIB.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Linux-OpenIB.json", + "referenceNumber": 419, + "name": "Linux Kernel Variant of OpenIB.org license", + "licenseId": "Linux-OpenIB", + "seeAlso": [ + "https://git.kernel.org/pub/scm/linux/kernel/git/torvalds/linux.git/tree/drivers/infiniband/core/sa.h" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/MIT-advertising.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/MIT-advertising.json", + "referenceNumber": 420, + "name": "Enlightenment License (e16)", + "licenseId": "MIT-advertising", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/MIT_With_Advertising" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/GFDL-1.2.html", + "isDeprecatedLicenseId": true, + "detailsUrl": "https://spdx.org/licenses/GFDL-1.2.json", + "referenceNumber": 421, + "name": "GNU Free Documentation License v1.2", + "licenseId": "GFDL-1.2", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/fdl-1.2.txt" + ], + "isOsiApproved": false, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/OGTSL.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/OGTSL.json", + "referenceNumber": 422, + "name": "Open Group Test Suite License", + "licenseId": "OGTSL", + "seeAlso": [ + "http://www.opengroup.org/testing/downloads/The_Open_Group_TSL.txt", + "https://opensource.org/licenses/OGTSL" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/Dotseqn.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Dotseqn.json", + "referenceNumber": 423, + "name": "Dotseqn License", + "licenseId": "Dotseqn", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Dotseqn" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/DL-DE-BY-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/DL-DE-BY-2.0.json", + "referenceNumber": 424, + "name": "Data licence Germany – attribution – version 2.0", + "licenseId": "DL-DE-BY-2.0", + "seeAlso": [ + "https://www.govdata.de/dl-de/by-2-0" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/Saxpath.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Saxpath.json", + "referenceNumber": 425, + "name": "Saxpath License", + "licenseId": "Saxpath", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Saxpath_License" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/AGPL-3.0.html", + "isDeprecatedLicenseId": true, + "detailsUrl": "https://spdx.org/licenses/AGPL-3.0.json", + "referenceNumber": 426, + "name": "GNU Affero General Public License v3.0", + "licenseId": "AGPL-3.0", + "seeAlso": [ + "https://www.gnu.org/licenses/agpl.txt", + "https://opensource.org/licenses/AGPL-3.0" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/Abstyles.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Abstyles.json", + "referenceNumber": 427, + "name": "Abstyles License", + "licenseId": "Abstyles", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Abstyles" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/CC-BY-SA-3.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CC-BY-SA-3.0.json", + "referenceNumber": 428, + "name": "Creative Commons Attribution Share Alike 3.0 Unported", + "licenseId": "CC-BY-SA-3.0", + "seeAlso": [ + "https://creativecommons.org/licenses/by-sa/3.0/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/Giftware.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Giftware.json", + "referenceNumber": 429, + "name": "Giftware License", + "licenseId": "Giftware", + "seeAlso": [ + "http://liballeg.org/license.html#allegro-4-the-giftware-license" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/FreeImage.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/FreeImage.json", + "referenceNumber": 430, + "name": "FreeImage Public License v1.0", + "licenseId": "FreeImage", + "seeAlso": [ + "http://freeimage.sourceforge.net/freeimage-license.txt" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/CECILL-2.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CECILL-2.1.json", + "referenceNumber": 431, + "name": "CeCILL Free Software License Agreement v2.1", + "licenseId": "CECILL-2.1", + "seeAlso": [ + "http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.html" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/RPSL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/RPSL-1.0.json", + "referenceNumber": 432, + "name": "RealNetworks Public Source License v1.0", + "licenseId": "RPSL-1.0", + "seeAlso": [ + "https://helixcommunity.org/content/rpsl", + "https://opensource.org/licenses/RPSL-1.0" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/GFDL-1.3-or-later.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/GFDL-1.3-or-later.json", + "referenceNumber": 433, + "name": "GNU Free Documentation License v1.3 or later", + "licenseId": "GFDL-1.3-or-later", + "seeAlso": [ + "https://www.gnu.org/licenses/fdl-1.3.txt" + ], + "isOsiApproved": false, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/GFDL-1.1-invariants-or-later.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/GFDL-1.1-invariants-or-later.json", + "referenceNumber": 434, + "name": "GNU Free Documentation License v1.1 or later - invariants", + "licenseId": "GFDL-1.1-invariants-or-later", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/fdl-1.1.txt" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/ECL-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/ECL-2.0.json", + "referenceNumber": 435, + "name": "Educational Community License v2.0", + "licenseId": "ECL-2.0", + "seeAlso": [ + "https://opensource.org/licenses/ECL-2.0" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/LiLiQ-Rplus-1.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/LiLiQ-Rplus-1.1.json", + "referenceNumber": 436, + "name": "Licence Libre du Québec – Réciprocité forte version 1.1", + "licenseId": "LiLiQ-Rplus-1.1", + "seeAlso": [ + "https://www.forge.gouv.qc.ca/participez/licence-logicielle/licence-libre-du-quebec-liliq-en-francais/licence-libre-du-quebec-reciprocite-forte-liliq-r-v1-1/", + "http://opensource.org/licenses/LiLiQ-Rplus-1.1" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/GPL-3.0-with-autoconf-exception.html", + "isDeprecatedLicenseId": true, + "detailsUrl": "https://spdx.org/licenses/GPL-3.0-with-autoconf-exception.json", + "referenceNumber": 437, + "name": "GNU General Public License v3.0 w/Autoconf exception", + "licenseId": "GPL-3.0-with-autoconf-exception", + "seeAlso": [ + "https://www.gnu.org/licenses/autoconf-exception-3.0.html" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/Jam.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Jam.json", + "referenceNumber": 438, + "name": "Jam License", + "licenseId": "Jam", + "seeAlso": [ + "https://www.boost.org/doc/libs/1_35_0/doc/html/jam.html", + "https://web.archive.org/web/20160330173339/https://swarm.workshop.perforce.com/files/guest/perforce_software/jam/src/README" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/GFDL-1.2-no-invariants-or-later.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/GFDL-1.2-no-invariants-or-later.json", + "referenceNumber": 439, + "name": "GNU Free Documentation License v1.2 or later - no invariants", + "licenseId": "GFDL-1.2-no-invariants-or-later", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/fdl-1.2.txt" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/CECILL-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CECILL-2.0.json", + "referenceNumber": 440, + "name": "CeCILL Free Software License Agreement v2.0", + "licenseId": "CECILL-2.0", + "seeAlso": [ + "http://www.cecill.info/licences/Licence_CeCILL_V2-en.html" + ], + "isOsiApproved": false, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/PolyForm-Noncommercial-1.0.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/PolyForm-Noncommercial-1.0.0.json", + "referenceNumber": 441, + "name": "PolyForm Noncommercial License 1.0.0", + "licenseId": "PolyForm-Noncommercial-1.0.0", + "seeAlso": [ + "https://polyformproject.org/licenses/noncommercial/1.0.0" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/OGC-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/OGC-1.0.json", + "referenceNumber": 442, + "name": "OGC Software License, Version 1.0", + "licenseId": "OGC-1.0", + "seeAlso": [ + "https://www.ogc.org/ogc/software/1.0" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/CC-BY-ND-3.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CC-BY-ND-3.0.json", + "referenceNumber": 443, + "name": "Creative Commons Attribution No Derivatives 3.0 Unported", + "licenseId": "CC-BY-ND-3.0", + "seeAlso": [ + "https://creativecommons.org/licenses/by-nd/3.0/legalcode" + ], + "isOsiApproved": false, + "isFsfLibre": false + }, + { + "reference": "https://spdx.org/licenses/QPL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/QPL-1.0.json", + "referenceNumber": 444, + "name": "Q Public License 1.0", + "licenseId": "QPL-1.0", + "seeAlso": [ + "http://doc.qt.nokia.com/3.3/license.html", + "https://opensource.org/licenses/QPL-1.0", + "https://doc.qt.io/archives/3.3/license.html" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/LAL-1.2.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/LAL-1.2.json", + "referenceNumber": 445, + "name": "Licence Art Libre 1.2", + "licenseId": "LAL-1.2", + "seeAlso": [ + "http://artlibre.org/licence/lal/licence-art-libre-12/" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/CC-BY-3.0-DE.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CC-BY-3.0-DE.json", + "referenceNumber": 446, + "name": "Creative Commons Attribution 3.0 Germany", + "licenseId": "CC-BY-3.0-DE", + "seeAlso": [ + "https://creativecommons.org/licenses/by/3.0/de/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/OpenSSL.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/OpenSSL.json", + "referenceNumber": 447, + "name": "OpenSSL License", + "licenseId": "OpenSSL", + "seeAlso": [ + "http://www.openssl.org/source/license.html" + ], + "isOsiApproved": false, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/Spencer-99.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Spencer-99.json", + "referenceNumber": 448, + "name": "Spencer License 99", + "licenseId": "Spencer-99", + "seeAlso": [ + "http://www.opensource.apple.com/source/tcl/tcl-5/tcl/generic/regfronts.c" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/CC-BY-SA-3.0-AT.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CC-BY-SA-3.0-AT.json", + "referenceNumber": 449, + "name": "Creative Commons Attribution Share Alike 3.0 Austria", + "licenseId": "CC-BY-SA-3.0-AT", + "seeAlso": [ + "https://creativecommons.org/licenses/by-sa/3.0/at/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/BSD-Protection.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/BSD-Protection.json", + "referenceNumber": 450, + "name": "BSD Protection License", + "licenseId": "BSD-Protection", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/BSD_Protection_License" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/OLDAP-2.2.2.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/OLDAP-2.2.2.json", + "referenceNumber": 451, + "name": "Open LDAP Public License 2.2.2", + "licenseId": "OLDAP-2.2.2", + "seeAlso": [ + "http://www.openldap.org/devel/gitweb.cgi?p\u003dopenldap.git;a\u003dblob;f\u003dLICENSE;hb\u003ddf2cc1e21eb7c160695f5b7cffd6296c151ba188" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/NRL.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/NRL.json", + "referenceNumber": 452, + "name": "NRL License", + "licenseId": "NRL", + "seeAlso": [ + "http://web.mit.edu/network/isakmp/nrllicense.html" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/TORQUE-1.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/TORQUE-1.1.json", + "referenceNumber": 453, + "name": "TORQUE v2.5+ Software License v1.1", + "licenseId": "TORQUE-1.1", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/TORQUEv1.1" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/HTMLTIDY.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/HTMLTIDY.json", + "referenceNumber": 454, + "name": "HTML Tidy License", + "licenseId": "HTMLTIDY", + "seeAlso": [ + "https://github.com/htacg/tidy-html5/blob/next/README/LICENSE.md" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/SSPL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/SSPL-1.0.json", + "referenceNumber": 455, + "name": "Server Side Public License, v 1", + "licenseId": "SSPL-1.0", + "seeAlso": [ + "https://www.mongodb.com/licensing/server-side-public-license" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/NPL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/NPL-1.0.json", + "referenceNumber": 456, + "name": "Netscape Public License v1.0", + "licenseId": "NPL-1.0", + "seeAlso": [ + "http://www.mozilla.org/MPL/NPL/1.0/" + ], + "isOsiApproved": false, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/LGPL-2.0-only.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/LGPL-2.0-only.json", + "referenceNumber": 457, + "name": "GNU Library General Public License v2 only", + "licenseId": "LGPL-2.0-only", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/lgpl-2.0-standalone.html" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/AGPL-3.0-only.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/AGPL-3.0-only.json", + "referenceNumber": 458, + "name": "GNU Affero General Public License v3.0 only", + "licenseId": "AGPL-3.0-only", + "seeAlso": [ + "https://www.gnu.org/licenses/agpl.txt", + "https://opensource.org/licenses/AGPL-3.0" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/GFDL-1.2-invariants-or-later.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/GFDL-1.2-invariants-or-later.json", + "referenceNumber": 459, + "name": "GNU Free Documentation License v1.2 or later - invariants", + "licenseId": "GFDL-1.2-invariants-or-later", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/fdl-1.2.txt" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/GPL-2.0-with-bison-exception.html", + "isDeprecatedLicenseId": true, + "detailsUrl": "https://spdx.org/licenses/GPL-2.0-with-bison-exception.json", + "referenceNumber": 460, + "name": "GNU General Public License v2.0 w/Bison exception", + "licenseId": "GPL-2.0-with-bison-exception", + "seeAlso": [ + "http://git.savannah.gnu.org/cgit/bison.git/tree/data/yacc.c?id\u003d193d7c7054ba7197b0789e14965b739162319b5e#n141" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/CC-BY-NC-ND-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CC-BY-NC-ND-1.0.json", + "referenceNumber": 461, + "name": "Creative Commons Attribution Non Commercial No Derivatives 1.0 Generic", + "licenseId": "CC-BY-NC-ND-1.0", + "seeAlso": [ + "https://creativecommons.org/licenses/by-nd-nc/1.0/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/ECL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/ECL-1.0.json", + "referenceNumber": 462, + "name": "Educational Community License v1.0", + "licenseId": "ECL-1.0", + "seeAlso": [ + "https://opensource.org/licenses/ECL-1.0" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/WTFPL.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/WTFPL.json", + "referenceNumber": 463, + "name": "Do What The F*ck You Want To Public License", + "licenseId": "WTFPL", + "seeAlso": [ + "http://www.wtfpl.net/about/", + "http://sam.zoy.org/wtfpl/COPYING" + ], + "isOsiApproved": false, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/CC-BY-SA-2.0-UK.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CC-BY-SA-2.0-UK.json", + "referenceNumber": 464, + "name": "Creative Commons Attribution Share Alike 2.0 England and Wales", + "licenseId": "CC-BY-SA-2.0-UK", + "seeAlso": [ + "https://creativecommons.org/licenses/by-sa/2.0/uk/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/GPL-3.0.html", + "isDeprecatedLicenseId": true, + "detailsUrl": "https://spdx.org/licenses/GPL-3.0.json", + "referenceNumber": 465, + "name": "GNU General Public License v3.0 only", + "licenseId": "GPL-3.0", + "seeAlso": [ + "https://www.gnu.org/licenses/gpl-3.0-standalone.html", + "https://opensource.org/licenses/GPL-3.0" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/OLDAP-2.2.1.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/OLDAP-2.2.1.json", + "referenceNumber": 466, + "name": "Open LDAP Public License v2.2.1", + "licenseId": "OLDAP-2.2.1", + "seeAlso": [ + "http://www.openldap.org/devel/gitweb.cgi?p\u003dopenldap.git;a\u003dblob;f\u003dLICENSE;hb\u003d4bc786f34b50aa301be6f5600f58a980070f481e" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/SMPPL.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/SMPPL.json", + "referenceNumber": 467, + "name": "Secure Messaging Protocol Public License", + "licenseId": "SMPPL", + "seeAlso": [ + "https://github.com/dcblake/SMP/blob/master/Documentation/License.txt" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/CC-BY-3.0-AT.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CC-BY-3.0-AT.json", + "referenceNumber": 468, + "name": "Creative Commons Attribution 3.0 Austria", + "licenseId": "CC-BY-3.0-AT", + "seeAlso": [ + "https://creativecommons.org/licenses/by/3.0/at/legalcode" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/EFL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/EFL-1.0.json", + "referenceNumber": 469, + "name": "Eiffel Forum License v1.0", + "licenseId": "EFL-1.0", + "seeAlso": [ + "http://www.eiffel-nice.org/license/forum.txt", + "https://opensource.org/licenses/EFL-1.0" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/NBPL-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/NBPL-1.0.json", + "referenceNumber": 470, + "name": "Net Boolean Public License v1", + "licenseId": "NBPL-1.0", + "seeAlso": [ + "http://www.openldap.org/devel/gitweb.cgi?p\u003dopenldap.git;a\u003dblob;f\u003dLICENSE;hb\u003d37b4b3f6cc4bf34e1d3dec61e69914b9819d8894" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/BSD-3-Clause-LBNL.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/BSD-3-Clause-LBNL.json", + "referenceNumber": 471, + "name": "Lawrence Berkeley National Labs BSD variant license", + "licenseId": "BSD-3-Clause-LBNL", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/LBNLBSD" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/AGPL-1.0.html", + "isDeprecatedLicenseId": true, + "detailsUrl": "https://spdx.org/licenses/AGPL-1.0.json", + "referenceNumber": 472, + "name": "Affero General Public License v1.0", + "licenseId": "AGPL-1.0", + "seeAlso": [ + "http://www.affero.org/oagpl.html" + ], + "isOsiApproved": false, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/Crossword.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/Crossword.json", + "referenceNumber": 473, + "name": "Crossword License", + "licenseId": "Crossword", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Crossword" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/TCL.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/TCL.json", + "referenceNumber": 474, + "name": "TCL/TK License", + "licenseId": "TCL", + "seeAlso": [ + "http://www.tcl.tk/software/tcltk/license.html", + "https://fedoraproject.org/wiki/Licensing/TCL" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/CC-BY-ND-1.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/CC-BY-ND-1.0.json", + "referenceNumber": 475, + "name": "Creative Commons Attribution No Derivatives 1.0 Generic", + "licenseId": "CC-BY-ND-1.0", + "seeAlso": [ + "https://creativecommons.org/licenses/by-nd/1.0/legalcode" + ], + "isOsiApproved": false, + "isFsfLibre": false + }, + { + "reference": "https://spdx.org/licenses/AML.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/AML.json", + "referenceNumber": 476, + "name": "Apple MIT License", + "licenseId": "AML", + "seeAlso": [ + "https://fedoraproject.org/wiki/Licensing/Apple_MIT_License" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/TU-Berlin-2.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/TU-Berlin-2.0.json", + "referenceNumber": 477, + "name": "Technische Universitaet Berlin License 2.0", + "licenseId": "TU-Berlin-2.0", + "seeAlso": [ + "https://github.com/CorsixTH/deps/blob/fd339a9f526d1d9c9f01ccf39e438a015da50035/licences/libgsm.txt" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/GFDL-1.3-only.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/GFDL-1.3-only.json", + "referenceNumber": 478, + "name": "GNU Free Documentation License v1.3 only", + "licenseId": "GFDL-1.3-only", + "seeAlso": [ + "https://www.gnu.org/licenses/fdl-1.3.txt" + ], + "isOsiApproved": false, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/NPOSL-3.0.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/NPOSL-3.0.json", + "referenceNumber": 479, + "name": "Non-Profit Open Software License 3.0", + "licenseId": "NPOSL-3.0", + "seeAlso": [ + "https://opensource.org/licenses/NOSL3.0" + ], + "isOsiApproved": true + }, + { + "reference": "https://spdx.org/licenses/BSD-4-Clause.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/BSD-4-Clause.json", + "referenceNumber": 480, + "name": "BSD 4-Clause \"Original\" or \"Old\" License", + "licenseId": "BSD-4-Clause", + "seeAlso": [ + "http://directory.fsf.org/wiki/License:BSD_4Clause" + ], + "isOsiApproved": false, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/gSOAP-1.3b.html", + "isDeprecatedLicenseId": false, + "detailsUrl": "https://spdx.org/licenses/gSOAP-1.3b.json", + "referenceNumber": 481, + "name": "gSOAP Public License v1.3b", + "licenseId": "gSOAP-1.3b", + "seeAlso": [ + "http://www.cs.fsu.edu/~engelen/license.html" + ], + "isOsiApproved": false + }, + { + "reference": "https://spdx.org/licenses/LGPL-2.1.html", + "isDeprecatedLicenseId": true, + "detailsUrl": "https://spdx.org/licenses/LGPL-2.1.json", + "referenceNumber": 482, + "name": "GNU Lesser General Public License v2.1 only", + "licenseId": "LGPL-2.1", + "seeAlso": [ + "https://www.gnu.org/licenses/old-licenses/lgpl-2.1-standalone.html", + "https://opensource.org/licenses/LGPL-2.1" + ], + "isOsiApproved": true, + "isFsfLibre": true + }, + { + "reference": "https://spdx.org/licenses/LGPL-3.0.html", + "isDeprecatedLicenseId": true, + "detailsUrl": "https://spdx.org/licenses/LGPL-3.0.json", + "referenceNumber": 483, + "name": "GNU Lesser General Public License v3.0 only", + "licenseId": "LGPL-3.0", + "seeAlso": [ + "https://www.gnu.org/licenses/lgpl-3.0-standalone.html", + "https://opensource.org/licenses/LGPL-3.0" + ], + "isOsiApproved": true, + "isFsfLibre": true + } + ], + "releaseDate": "2022-02-06" +} diff --git a/cabal/release-checklist.md b/cabal/release-checklist.md --- a/cabal/release-checklist.md +++ b/cabal/release-checklist.md @@ -1,11 +1,1 @@ -# For major release - -- Add new SPDX License list data - -# For release for new GHC version: - -- Update GHC flags in `normaliseGhcArgs`, and add the GHC version to - `supportedGHCVersions` (`Distribution.Simple.Program.GHC`) -- Update `Language.Haskell.Extension` list, if there are new GHC extensions -- Update `setupMinCabalVersionConstraint` (in `Distribution.Client.ProjectPlanning`) -- Update `Cabal.Distribution.Simple.GHC` to include new GHC version +the new release checklist is at https://github.com/haskell/cabal/wiki/Making-a-release (easier to edit) diff --git a/cabal/release-notes/Cabal-3.4.0.0.md b/cabal/release-notes/Cabal-3.4.0.0.md --- a/cabal/release-notes/Cabal-3.4.0.0.md +++ b/cabal/release-notes/Cabal-3.4.0.0.md @@ -4,7 +4,7 @@ See various changes in https://cabal.readthedocs.io/en/latest/file-format-changelog.html#cabal-version-3-4 -- Support GHC-8.12 [#6903](https://github.com/haskell/cabal/issues/6903) [#6904](https://github.com/haskell/cabal/issues/6904) [#6905](https://github.com/haskell/cabal/issues/6905) [!6545](https://github.com/haskell/cabal/pull/6545) [!6552](https://github.com/haskell/cabal/pull/6552) [!6553](https://github.com/haskell/cabal/pull/6553) [!6563](https://github.com/haskell/cabal/pull/6563) [!6735](https://github.com/haskell/cabal/pull/6735) [!6844](https://github.com/haskell/cabal/pull/6844) [!6848](https://github.com/haskell/cabal/pull/6848) [!6865](https://github.com/haskell/cabal/pull/6865) [!6908](https://github.com/haskell/cabal/pull/6908) [!6947](https://github.com/haskell/cabal/pull/6947) +- Support GHC-9.0 [#6903](https://github.com/haskell/cabal/issues/6903) [#6904](https://github.com/haskell/cabal/issues/6904) [#6905](https://github.com/haskell/cabal/issues/6905) [!6545](https://github.com/haskell/cabal/pull/6545) [!6552](https://github.com/haskell/cabal/pull/6552) [!6553](https://github.com/haskell/cabal/pull/6553) [!6563](https://github.com/haskell/cabal/pull/6563) [!6735](https://github.com/haskell/cabal/pull/6735) [!6844](https://github.com/haskell/cabal/pull/6844) [!6848](https://github.com/haskell/cabal/pull/6848) [!6865](https://github.com/haskell/cabal/pull/6865) [!6908](https://github.com/haskell/cabal/pull/6908) [!6947](https://github.com/haskell/cabal/pull/6947) - Support for `-this-package-key` deprecation - Use process `createPipe` @@ -12,7 +12,7 @@ - Adopt to simplfied subsumption changes There are no magical `IO = WithCallStack Prelude.IO` alias in Cabal, - as it is hard to get working with GHC-8.12's simplified subsumption. + as it is hard to get working with GHC-9.0's simplified subsumption. - Treat `pkg:sublib` dependency syntax as is in `cabal-version: 3.4` [#6083](https://github.com/haskell/cabal/issues/6083) [!6893](https://github.com/haskell/cabal/pull/6893) [!6907](https://github.com/haskell/cabal/pull/6907) @@ -22,14 +22,14 @@ build-depends: somesublib ``` - is not using in-package sublibraries. You have to be explicit and write + does not use in-package sublibraries. You have to be explicit and write ```cabal build-depends: thispkg:somesublib ``` - This fixes an issue, where it was impossible to refer to extenral - library, if you had sublibrary of the same name. + This fixes an issue where it was impossible to refer to an external + library if you had a sublibrary of the same name. - Dependency type refactorings [#5570](https://github.com/haskell/cabal/issues/5570) [#6894](https://github.com/haskell/cabal/issues/6894) [!6768](https://github.com/haskell/cabal/pull/6768) [!6798](https://github.com/haskell/cabal/pull/6798) [!6895](https://github.com/haskell/cabal/pull/6895) [!6896](https://github.com/haskell/cabal/pull/6896) [!6897](https://github.com/haskell/cabal/pull/6897) [!6898](https://github.com/haskell/cabal/pull/6898) @@ -120,7 +120,7 @@ This changes makes `Version` type less "syntactic", i.e. contains less constructors for semantically same version ranges. -- Cabal-QuickCheck package with `Arbirary` instances [#6882](https://github.com/haskell/cabal/issues/6882) [!6557](https://github.com/haskell/cabal/pull/6557) [!6891](https://github.com/haskell/cabal/pull/6891) +- Cabal-QuickCheck package with `Arbitrary` instances [#6882](https://github.com/haskell/cabal/issues/6882) [!6557](https://github.com/haskell/cabal/pull/6557) [!6891](https://github.com/haskell/cabal/pull/6891) - Create Cabal-tree-diff package with `ToExpr` instances [!6789](https://github.com/haskell/cabal/pull/6789) - `Cabal.Distribution.Compiler`: add `Traversable` instance for `PerCompilerFlavor` [!6763](https://github.com/haskell/cabal/pull/6763) - Improvements to cabal-testsuite framework [!6643](https://github.com/haskell/cabal/pull/6643) diff --git a/cabal/release-notes/Cabal-3.4.1.0.md b/cabal/release-notes/Cabal-3.4.1.0.md new file mode 100644 --- /dev/null +++ b/cabal/release-notes/Cabal-3.4.1.0.md @@ -0,0 +1,3 @@ +### Bugfixes + +- Backport windows fix for packages using autoconf >= 2.70 [!7668](https://github.com/haskell/cabal/pull/7668) diff --git a/cabal/release-notes/Cabal-3.6.0.0.md b/cabal/release-notes/Cabal-3.6.0.0.md new file mode 100644 --- /dev/null +++ b/cabal/release-notes/Cabal-3.6.0.0.md @@ -0,0 +1,29 @@ +Cabal 3.6.0.0 Changelog +--- + + +- Backported to 3.4 [#6964](https://github.com/haskell/cabal/pull/6964) [#6968](https://github.com/haskell/cabal/pull/6968) +- CI setup [#6959](https://github.com/haskell/cabal/pull/6959) + + - Remove travis scripts + +- Code organization [#6960](https://github.com/haskell/cabal/pull/6960) [#6963](https://github.com/haskell/cabal/pull/6963) [#6970](https://github.com/haskell/cabal/pull/6970) [#6974](https://github.com/haskell/cabal/pull/6974) [#6975](https://github.com/haskell/cabal/pull/6975) + + - Move Cabal sources into Cabal/src + - Move cabal-install sources to cabal-install/src/ + - Move doc/ to the top-level of the repository + - Add stylish-haskell config. + +- Documentation improvements [#6813](https://github.com/haskell/cabal/issues/6813) [#6971](https://github.com/haskell/cabal/pull/6971) [#7047](https://github.com/haskell/cabal/pull/7047) + + Write highlights + +- Add post-checkout-command to source-package-repository [#6664](https://github.com/haskell/cabal/issues/6664) [#7047](https://github.com/haskell/cabal/pull/7047) +- Add `hsc2hs-options`, for specifying additional options to pass to `hsc2hs` [#6295](https://github.com/haskell/cabal/pull/6295) +- Include cmm-sources when linking shared objects [#7182](https://github.com/haskell/cabal/issues/7182) [#7252](https://github.com/haskell/cabal/pull/7252) + + - Previously `cmm-sources` were not included in the final link when building a library as a shared object. Fix this. + +- Add language extensions for GHC 9.2 [#7312](https://github.com/haskell/cabal/issues/7312) +- --dry-run and --only-download effect v2-configure, v2-freeze, v2-run, and v2-exec [#7379](https://github.com/haskell/cabal/issues/7379) +- Alert user and suggest command on spelling mistakes diff --git a/cabal/release-notes/Cabal-3.6.1.0.md b/cabal/release-notes/Cabal-3.6.1.0.md new file mode 100644 --- /dev/null +++ b/cabal/release-notes/Cabal-3.6.1.0.md @@ -0,0 +1,61 @@ +Cabal 3.6.1.0 Changelog +--- + +### Significant Changes + +- Include cmm-sources when linking shared objects [#7182](https://github.com/haskell/cabal/issues/7182) [#7252](https://github.com/haskell/cabal/pull/7252) + + - Previously `cmm-sources` were not included in the final link when building a library as a shared object. Fix this. + +- Prefer canonicalized path when guessing tools from GHC path [#7390](https://github.com/haskell/cabal/issues/7390) [#7392](https://github.com/haskell/cabal/pull/7392) + + Motivation + + Often times, the user facing `ghc` binary is + symlinked by other forces, such as the package manager, + tooling like ghcup etc. As such, the naming convention + (version suffix in particular) may not align with the + assumptions made in Cabal and it may find an incorrect ghc-pkg. + + See: + - https://github.com/haskell/cabal/issues/7390 + - https://gitlab.haskell.org/ghc/ghc/-/issues/18807 + - https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/73 + + Solution + + Guessing the ghc-pkg path is already a hack and will be solved + more appropriately in the future, see + - https://gitlab.haskell.org/ghc/ghc/-/merge_requests/4214 + - https://gitlab.haskell.org/ghc/ghc/-/snippets/2710 + These patches will solve the issue for future GHC versions. + + As such, this patch provides a workaround for + older, already existing GHC versions by first always + following the symbolic link of the ghc binary (if it is one) + and prefering its target directory as the guess lookup + location. + + Rationale + + The canonicalized path of the ghc binary usually points to the + bin/ directory unpacked from a bindist, which is less likely to be + tampered with by distributions and tools. As such, prefering the + canoncialized path should get us more robust results. + +- Fix `cabal test --enable-library-coverage` for other-modules [#5213](https://github.com/haskell/cabal/issues/5213) [#7493](https://github.com/haskell/cabal/pull/7493) + + - Fix `cabal test --enable-library-coverage` for libraries with nonempty other-modules field. + - Due to a hack, this breaks coverage whenever the used Haskell compiler is called 't' (for a non-hacky fix we should rework HPC directories, possibly enabling multilib in the process, see #6440 and #6397). + +- Set PATH_SEPARATOR=";" when calling ./configure on Windows; this fix is necessary for autoconf >= 2.70 [#7494](https://github.com/haskell/cabal/issues/7494) [#7510](https://github.com/haskell/cabal/pull/7510) + +- lazily decode cache files for checking invalidation [#7516](https://github.com/haskell/cabal/pull/7516) [#7466](https://github.com/haskell/cabal/issues/7466) + - This yields a significant 15% speedup on rebuilding build plans for projects with lots of individual cabal packages. + - It exports the [Tag data type](https://github.com/haskell/cabal/blob/899dd34bc48bbaa43da9a4b2fc354c24fd814d05/Cabal/src/Distribution/Utils/Structured.hs#L67), needed by `cabal-install >= 3.6.0.0`. + +- defer build-tools-depends choices as well as setup choices [#7561](https://github.com/haskell/cabal/pull/7561) [#7472](https://github.com/haskell/cabal/issues/7472) + - extends the existing solver pass that defers solving setup depends until top-level goals are solved to also defer build-tool-depends goals until top level goals are solved. + - constraints at the top level (on versions, flags, stanzas, etc) are applied first and only then are attempts made to build the less-constrained qualified goals, significantly streamlining the production of valid build plans. + +- Set -Wno-prepositive-qualified-module in Paths_*.hs [#7352](https://github.com/haskell/cabal/pull/7352) diff --git a/cabal/release-notes/Cabal-3.6.2.0.md b/cabal/release-notes/Cabal-3.6.2.0.md new file mode 100644 --- /dev/null +++ b/cabal/release-notes/Cabal-3.6.2.0.md @@ -0,0 +1,18 @@ +### Significant changes + + +- Make Paths_ modules work with non-standard preludes again [#5962](https://github.com/haskell/cabal/issues/5962) + + - Generate Paths_ module with qualified Data.List.last import so that compatibility with non-standard preludes is not regressed compared to cabal 3.4. + +- Windows: redo the fix to breakage caused by new autoconf; the wrong fix made cabal sometimes fail with old autoconf [#7494](https://github.com/haskell/cabal/issues/7494) [#7649](https://github.com/haskell/cabal/issues/7649) + + - Reverts #7510 that failed on Windows when used with pre-generated scripts included in packages such as network, time, process. + - Adds a subtler fix/workaround for the deficiencies of new autoconf versions on Windows. + +### Other changes + + +- Regenerate bootstrap/ with GHC updated from 8.10.4 to 8.10.7 + + - This regenerates bootstrap plans using new package versions and also updating GHC from 8.10.4 to 8.10.7, as requested by GHC HQ. diff --git a/cabal/release-notes/Cabal-3.6.3.0.md b/cabal/release-notes/Cabal-3.6.3.0.md new file mode 100644 --- /dev/null +++ b/cabal/release-notes/Cabal-3.6.3.0.md @@ -0,0 +1,8 @@ +Cabal 3.6.3.0 Changelog +--- + +### Significant changes + +- Disable job management on Windows 7 + + - Cabal now works on Windows 7. diff --git a/cabal/release-notes/Cabal-3.8.0.20220526.md b/cabal/release-notes/Cabal-3.8.0.20220526.md new file mode 100644 --- /dev/null +++ b/cabal/release-notes/Cabal-3.8.0.20220526.md @@ -0,0 +1,163 @@ +Cabal 3.8.0.20220526 Changelog +--- + +### Significant changes + +- Cabal init rewrite [#1074](https://github.com/haskell/cabal/issues/1074) [#6758](https://github.com/haskell/cabal/issues/6758) [#6864](https://github.com/haskell/cabal/issues/6864) [#7251](https://github.com/haskell/cabal/issues/7251) [#7255](https://github.com/haskell/cabal/issues/7255) [#7256](https://github.com/haskell/cabal/issues/7256) [#7273](https://github.com/haskell/cabal/issues/7273) + + - Restructures the `cabal init` command to fix historical + issues. All flags are preserved. + - Codebases for interactive and non-interactive flags + are disentangled. + - Data structures now exploit relevant stanza structure + and formatters only care about stanza data + - Heuristics and prompts have a pure and impure implementation. + + - Sets default behavior to be `--interactive` as opposed to + `--non-interactive`. + + - Rewrites tests to achieve 98% coverage + - Golden files now test every stanza individually + - Every flag is covered by a unit test + - Interactive, simple, and non-interactive workflows are + covered. + +- Make Paths_ modules work with non-standard preludes again [#7494](https://github.com/haskell/cabal/issues/7494) [#7649](https://github.com/haskell/cabal/issues/7649) + + - Reverts #7510 that failed on Windows when used with pre-generated scripts included in packages such as network, time, process. + - Adds a subtler fix/workaround for the deficiencies of new autoconf versions on Windows. + +- Windows: rewrite paths to configure [#7494](https://github.com/haskell/cabal/issues/7494) [#7649](https://github.com/haskell/cabal/issues/7649) + +- Expose `cabal-install` as library [#1597](https://github.com/haskell/cabal/issues/1597) [#3781](https://github.com/haskell/cabal/issues/3781) [#4798](https://github.com/haskell/cabal/issues/4798) [#6090](https://github.com/haskell/cabal/issues/6090) [#7224](https://github.com/haskell/cabal/issues/7224) [#7358](https://github.com/haskell/cabal/pull/7358) +- Allow preprocessors to register a reordering [#55](https://github.com/haskell/cabal/issues/55) [#1906](https://github.com/haskell/cabal/issues/1906) + + - Changes the PreProcessor type to include a field ppOrdering so that modules are presented to the preprocessor in the right order (w.r.t. dependencies) + +- Use ghc -flink-rts option when available [#7763](https://github.com/haskell/cabal/issues/7763) [#7764](https://github.com/haskell/cabal/pull/7764) [#8111](https://github.com/haskell/cabal/pull/8111) + + Previously Cabal did quite some headstands to link against libHSrts. + Note only this is complex but it couples very tightly to GHC's implementation. + Thankfully, as of GHC 9.0 GHC provides a -flink-rts flag for precisely this purpose. + Use it when available. + + It fixed a bug which make Cabal unusable to build foreign libraries for windows and ghc 9.0 or 9.2. + See + +- Remove the Generic instance of LicenseId [#8074](https://github.com/haskell/cabal/issues/8074) [#8117](https://github.com/haskell/cabal/pull/8117) + + - The `Generic` instance of LicenseId is removed, due to the extraordinary amount of memory required to compile + the Generic instances of large sum types in GHC. + +### Other changes + +- Handle option argument parse errors without 'error' [#7573](https://github.com/haskell/cabal/issues/7573) [#7579](https://github.com/haskell/cabal/pull/7579) + + - Errors parsing arguments such as `-v=3` no longer result in + stack traces. + - `Distribution.ReadE.readEOrFail` was removed. + +- Fix bugs in filename validation [#7426](https://github.com/haskell/cabal/issues/7426) [#7429](https://github.com/haskell/cabal/pull/7429) [#7479](https://github.com/haskell/cabal/pull/7479) + + - Relative paths starting with single-character directories are now properly allowed + - `cabal check` rejects paths which are invalid on Windows or in tarballs + +- Fix test --enable-coverage for multi-package projects [#5213](https://github.com/haskell/cabal/issues/5213) [#5433](https://github.com/haskell/cabal/issues/5433) [#7200](https://github.com/haskell/cabal/issues/7200) [#7250](https://github.com/haskell/cabal/pull/7250) [#7467](https://github.com/haskell/cabal/pull/7467) + + - Fix `cabal test --enable-coverage` for multi-package projects by invoking `hpc markup --include=` and listing only modules of libraries of the single tested package. + +- Make cabal respect setgid permission bit when creating directories [#7560](https://github.com/haskell/cabal/issues/7560) [#7572](https://github.com/haskell/cabal/pull/7572) + + - Previously cabal would override an admin's choice to use setgid on the + .cabal directory by using hardcoded file and directory modes upon + creation. Instead we now take what the system decides and only add to + that set of permissions. + +- Handle conditionals in duplicate module checks [#4629](https://github.com/haskell/cabal/issues/4629) [#7525](https://github.com/haskell/cabal/issues/7525) [#7616](https://github.com/haskell/cabal/pull/7616) + + Improves `cabal check` logic for duplicate modules to take into account conditional branches. If a module appears on both sides of an `if/else` clause in a cabal file, it is now correctly not reported as a duplicate. + +- Backtrack when no pkg-config is present [#7448](https://github.com/haskell/cabal/issues/7448) [#7621](https://github.com/haskell/cabal/pull/7621) + + When solving for pkgconfig-depends, when pkg-config is not present, the cabal solver will now backtrack and try a different automatic flag and dependency configuration, just as it does if pkg-config is present, but does not contain the specified package. + +- Add code-generators field to test-suite stanza [#4500](https://github.com/haskell/cabal/issues/4500) [#7688](https://github.com/haskell/cabal/pull/7688) + + Test-suite stanzas now may contain a `code-generators:` field that can be used to run executables as preprocessors which take existing locations of library code and cabal-generated ghc build flags, and output new modules for use in the test stanza. This can be used to automatically generate drivers for "discover" style tests, including doctests. + +- Terminate subprocesses when killed [#7914](https://github.com/haskell/cabal/issues/7914) [#7921](https://github.com/haskell/cabal/pull/7921) + + - cabal (and 'cabal run' in particular) no longer leaves children running + when it is killed (unix) + +- Cleanup subprocess helpers, remove obsolete functions [#7995](https://github.com/haskell/cabal/pull/7995) + + - Distribution.Compat.Process: Remove createProcess, runInteractiveProcess + and rawSystem. + - Distribution.Simple.Utils: Remove printRawCommandAndArgs, + printRawCommandAndArgsAndEnv and createProcessWithEnv. + +- Allow glob-star matches with literal filenames (no extensions) [#5883](https://github.com/haskell/cabal/issues/5883) [#8005](https://github.com/haskell/cabal/pull/8005) + + - Cabal file glob syntax extended to allow matches of the form dir/**/FileNoExtension + +- Flatten duplicate warnings about experimental features [#8023](https://github.com/haskell/cabal/pull/8023) + + - Make builds that use experimental Cabal language features less noisy. At -v1 + (normal) we show just first instance of use of experimental cabal language + features, along with count of further occurences in the same file. + +- Fix Cabal not finding public sublibraries of installed packages [#7270](https://github.com/haskell/cabal/issues/7270) [#8089](https://github.com/haskell/cabal/pull/8089) + + Fix bug in lookup of installed sublibraries with nonexact dependencies (ie. when + not using --exact-configuration). That is the mode of operation of distribution + packages, so this should allow distros to package Cabal packages with multiple + libraries. + +- Make type field optional for tests and benchmarks [#7459](https://github.com/haskell/cabal/issues/7459) [#8115](https://github.com/haskell/cabal/pull/8115) + + Allow the omission of the `type` field in `test-suite` and `benchmark` stanzas + when the type can be inferred by the presence of `main-is` or `test-module`. + +- Improve error message for empty --allow-newer= [#7740](https://github.com/haskell/cabal/issues/7740) [#8140](https://github.com/haskell/cabal/pull/8140) + + Instead of internal error, the message now explains that empty argument for + + argument) means. + +- Create Cabal-syntax for .cabal files [#7559](https://github.com/haskell/cabal/issues/7559) [#7620](https://github.com/haskell/cabal/pull/7620) +- Fix haddock command via Setup.hs for internal libraries [#1919](https://github.com/haskell/cabal/issues/1919) [#7827](https://github.com/haskell/cabal/pull/7827) +- `ghc-options` and `--with-gcc` are now passed to GHC when compiling C and C++ sources [#4439](https://github.com/haskell/cabal/issues/4439) [#5440](https://github.com/haskell/cabal/pull/5440) [#7874](https://github.com/haskell/cabal/pull/7874) +- 'cabal check' to fail when no upper bounds for base or Cabal are present in setup dependencies [#4683](https://github.com/haskell/cabal/issues/4683) [#5370](https://github.com/haskell/cabal/pull/5370) [#7409](https://github.com/haskell/cabal/pull/7409) +- --repl-options doesn’t split on whitespace [#6190](https://github.com/haskell/cabal/issues/6190) [#7799](https://github.com/haskell/cabal/pull/7799) +- '--repl-no-load' option skips startup modules load in REPL [#7541](https://github.com/haskell/cabal/issues/7541) [#7578](https://github.com/haskell/cabal/pull/7578) +- Add -c alias for --constraint command line flag [#7765](https://github.com/haskell/cabal/issues/7765) [#7766](https://github.com/haskell/cabal/pull/7766) +- Add "prompt" strategy when symlinking binaries. [#5672](https://github.com/haskell/cabal/pull/5672) +- Add fields extra-libraries-static and extra-lib-dirs-static [#6688](https://github.com/haskell/cabal/issues/6688) [#7399](https://github.com/haskell/cabal/issues/7399) [#7536](https://github.com/haskell/cabal/pull/7536) +- Paths passed to GHC are now relative to the current working directory +- Autoatically pipe auth from repo uris into curl transport. [#4743](https://github.com/haskell/cabal/issues/4743) [#7630](https://github.com/haskell/cabal/pull/7630) +- raise lower bound of process and remove compatibility shims [#7922](https://github.com/haskell/cabal/pull/7922) +- changes the cabal check warning about long synopsis, so it warns only synopsis bigger than the set size [#7932](https://github.com/haskell/cabal/issues/7932) [#7933](https://github.com/haskell/cabal/pull/7933) +- Remove bootstrapping plan files from version control, and simplify bootstrap update Makefile targets. [#7949](https://github.com/haskell/cabal/pull/7949) +- Remove deprecated file finding functions [#7955](https://github.com/haskell/cabal/pull/7955) +- Support GHC 9.4's `clang`-based Windows toolchain [#8062](https://github.com/haskell/cabal/pull/8062) +- Add support for the 64-bit S390X architecture [#8065](https://github.com/haskell/cabal/pull/8065) +- Add wasm32-wasi to recognized arch/os [#8096](https://github.com/haskell/cabal/pull/8096) +- Unmarked "visibility: public" and "build-depends: pkg:lib" syntaxes as experimental, allowing Hackage upload of packages exposing or using multiple public libraries [#6801](https://github.com/haskell/cabal/issues/6801) [#7286](https://github.com/haskell/cabal/issues/7286) [#8089](https://github.com/haskell/cabal/pull/8089) +- Sync repo darcs [#7137](https://github.com/haskell/cabal/pull/7137) + +- *Cabal-syntax* Derive Eq for DependencyMap [#7849](https://github.com/haskell/cabal/issues/7849) [#8061](https://github.com/haskell/cabal/pull/8061) +- *Cabal-syntax* Allow trailing whitespace after flags in cabal.project [#7279](https://github.com/haskell/cabal/issues/7279) [#8006](https://github.com/haskell/cabal/pull/8006) +- *Cabal-syntax* Update the SPDX License List to version 3.16 [#8126](https://github.com/haskell/cabal/issues/8126) [#8127](https://github.com/haskell/cabal/pull/8127) + + The LicenseId and LicenseExceptionId types are updated to reflect the SPDX License List version 3.16 (2022-02-06). + +- Added fields :pkg-field:`extra-libraries-static` and + :pkg-field:`extra-lib-dirs-static` to allow Haskell libraries to remember + linker flags needed for fully static linking of system libraries into executables. [#7536](https://github.com/haskell/cabal/pull/7536) + +- The existing field :pkg-field:`pkgconfig-depends` can used to append the relevant + output of ``pkg-config --libs --static`` to these new fields automatically. + When :pkg-field:`extra-libraries-static` is not given, it defaults to + :pkg-field:`extra-libraries`. When :pkg-field:`extra-lib-dirs-static` is not + given, it defaults to :pkg-field:`extra-lib-dirs`. [#7536](https://github.com/haskell/cabal/pull/7536) diff --git a/cabal/release-notes/Cabal-3.8.1.0.md b/cabal/release-notes/Cabal-3.8.1.0.md new file mode 100644 --- /dev/null +++ b/cabal/release-notes/Cabal-3.8.1.0.md @@ -0,0 +1,142 @@ +Cabal 3.8.1.0 Changelog +--- + +### Significant changes + +- Split out package `Cabal-syntax` for `.cabal` file syntax and parsing [#7559](https://github.com/haskell/cabal/issues/7559) [#7620](https://github.com/haskell/cabal/pull/7620) + +- Unmarked "visibility: public" and "build-depends: pkg:lib" syntaxes as experimental, allowing Hackage upload of packages exposing or using multiple public libraries [#6801](https://github.com/haskell/cabal/issues/6801) [#7286](https://github.com/haskell/cabal/issues/7286) [#8089](https://github.com/haskell/cabal/pull/8089) + +- Add code-generators field to test-suite stanza [#4500](https://github.com/haskell/cabal/issues/4500) [#7688](https://github.com/haskell/cabal/pull/7688) + + Test-suite stanzas now may contain a `code-generators:` field that can be used to run executables as preprocessors which take existing locations of library code and cabal-generated ghc build flags, and output new modules for use in the test stanza. This can be used to automatically generate drivers for "discover" style tests, including doctests. + +- Windows: redo the fix to breakage caused by new autoconf; the wrong fix made cabal sometimes fail with old autoconf [#7494](https://github.com/haskell/cabal/issues/7494) [#7649](https://github.com/haskell/cabal/issues/7649) + + - Reverts #7510 that failed on Windows when used with pre-generated scripts included in packages such as network, time, process. + - Adds a subtler fix/workaround for the deficiencies of new autoconf versions on Windows. + +- Windows: rewrite paths to configure [#7494](https://github.com/haskell/cabal/issues/7494) [#7649](https://github.com/haskell/cabal/issues/7649) +- Enabled foreign library building on apple silicon [#7837](https://github.com/haskell/cabal/issues/7837) [#8227](https://github.com/haskell/cabal/issues/8227) [#8232](https://github.com/haskell/cabal/pull/8232) + + - Enabled foreign library building on apple silicon + - Updated error message for foreign library builds on unsupported platforms + +- Allow preprocessors to register a reordering [#55](https://github.com/haskell/cabal/issues/55) [#1906](https://github.com/haskell/cabal/issues/1906) + + - Changes the PreProcessor type to include a field ppOrdering so that modules are presented to the preprocessor in the right order (w.r.t. dependencies) + +- Use ghc -flink-rts option when available [#7763](https://github.com/haskell/cabal/issues/7763) [#7764](https://github.com/haskell/cabal/pull/7764) [#8111](https://github.com/haskell/cabal/pull/8111) + + Previously Cabal did quite some headstands to link against libHSrts. + Note only this is complex but it couples very tightly to GHC's implementation. + Thankfully, as of GHC 9.0 GHC provides a -flink-rts flag for precisely this purpose. + Use it when available. + + It fixed a bug which make Cabal unusable to build foreign libraries for windows and ghc 9.0 or 9.2. + See + +- Remove the Generic instance of LicenseId [#8074](https://github.com/haskell/cabal/issues/8074) [#8117](https://github.com/haskell/cabal/pull/8117) + + - The `Generic` instance of LicenseId is removed, due to the extraordinary amount of memory required to compile + the Generic instances of large sum types in GHC. + + +### Other changes + +- Handle option argument parse errors without 'error' [#7573](https://github.com/haskell/cabal/issues/7573) [#7579](https://github.com/haskell/cabal/pull/7579) + + - Errors parsing arguments such as `-v=3` no longer result in + stack traces. + - `Distribution.ReadE.readEOrFail` was removed. + +- Fix bugs in filename validation [#7426](https://github.com/haskell/cabal/issues/7426) [#7429](https://github.com/haskell/cabal/pull/7429) [#7479](https://github.com/haskell/cabal/pull/7479) + + - Relative paths starting with single-character directories are now properly allowed + - `cabal check` rejects paths which are invalid on Windows or in tarballs + +- Fix test --enable-coverage for multi-package projects [#5213](https://github.com/haskell/cabal/issues/5213) [#5433](https://github.com/haskell/cabal/issues/5433) [#7200](https://github.com/haskell/cabal/issues/7200) [#7250](https://github.com/haskell/cabal/pull/7250) [#7467](https://github.com/haskell/cabal/pull/7467) + + - Fix `cabal test --enable-coverage` for multi-package projects by invoking `hpc markup --include=` and listing only modules of libraries of the single tested package. + +- Make cabal respect setgid permission bit when creating directories [#7560](https://github.com/haskell/cabal/issues/7560) [#7572](https://github.com/haskell/cabal/pull/7572) + + - Previously cabal would override an admin's choice to use setgid on the + .cabal directory by using hardcoded file and directory modes upon + creation. Instead we now take what the system decides and only add to + that set of permissions. + +- Handle conditionals in duplicate module checks [#4629](https://github.com/haskell/cabal/issues/4629) [#7525](https://github.com/haskell/cabal/issues/7525) [#7616](https://github.com/haskell/cabal/pull/7616) + + Improves `cabal check` logic for duplicate modules to take into account conditional branches. If a module appears on both sides of an `if/else` clause in a cabal file, it is now correctly not reported as a duplicate. + +- Allow glob-star matches with literal filenames (no extensions) [#5883](https://github.com/haskell/cabal/issues/5883) [#8005](https://github.com/haskell/cabal/pull/8005) + + - Cabal file glob syntax extended to allow matches of the form dir/**/FileNoExtension + +- Flatten duplicate warnings about experimental features [#8023](https://github.com/haskell/cabal/pull/8023) + + - Make builds that use experimental Cabal language features less noisy. At -v1 + (normal) we show just first instance of use of experimental cabal language + features, along with count of further occurences in the same file. + +- Fix Cabal not finding public sublibraries of installed packages [#7270](https://github.com/haskell/cabal/issues/7270) [#8089](https://github.com/haskell/cabal/pull/8089) + + Fix bug in lookup of installed sublibraries with nonexact dependencies (ie. when + not using --exact-configuration). That is the mode of operation of distribution + packages, so this should allow distros to package Cabal packages with multiple + libraries. + +- Make type field optional for tests and benchmarks [#7459](https://github.com/haskell/cabal/issues/7459) [#8115](https://github.com/haskell/cabal/pull/8115) + + Allow the omission of the `type` field in `test-suite` and `benchmark` stanzas + when the type can be inferred by the presence of `main-is` or `test-module`. + +- Improve error message for empty --allow-newer= [#7740](https://github.com/haskell/cabal/issues/7740) [#8140](https://github.com/haskell/cabal/pull/8140) + + Instead of internal error, the message now explains that empty argument for + + argument) means. + +- Fix haddock command via Setup.hs for internal libraries [#1919](https://github.com/haskell/cabal/issues/1919) [#7827](https://github.com/haskell/cabal/pull/7827) +- `ghc-options` and `--with-gcc` are now passed to GHC when compiling C and C++ sources [#4439](https://github.com/haskell/cabal/issues/4439) [#5440](https://github.com/haskell/cabal/pull/5440) [#7874](https://github.com/haskell/cabal/pull/7874) +- 'cabal check' to fail when no upper bounds for base or Cabal are present in setup dependencies [#4683](https://github.com/haskell/cabal/issues/4683) [#5370](https://github.com/haskell/cabal/pull/5370) [#7409](https://github.com/haskell/cabal/pull/7409) +- --repl-options doesn’t split on whitespace [#6190](https://github.com/haskell/cabal/issues/6190) [#7799](https://github.com/haskell/cabal/pull/7799) +- '--repl-no-load' option skips startup modules load in REPL [#7541](https://github.com/haskell/cabal/issues/7541) [#7578](https://github.com/haskell/cabal/pull/7578) +- Add -c alias for --constraint command line flag [#7765](https://github.com/haskell/cabal/issues/7765) [#7766](https://github.com/haskell/cabal/pull/7766) +- Add fields extra-libraries-static and extra-lib-dirs-static [#6688](https://github.com/haskell/cabal/issues/6688) [#7399](https://github.com/haskell/cabal/issues/7399) [#7536](https://github.com/haskell/cabal/pull/7536) +- Paths passed to GHC are now relative to the current working directory +- raise lower bound of process and remove compatibility shims [#7922](https://github.com/haskell/cabal/pull/7922) +- changes the cabal check warning about long synopsis, so it warns only synopsis bigger than the set size [#7932](https://github.com/haskell/cabal/issues/7932) [#7933](https://github.com/haskell/cabal/pull/7933) +- Remove bootstrapping plan files from version control, and simplify bootstrap update Makefile targets. [#7949](https://github.com/haskell/cabal/pull/7949) +- Remove deprecated file finding functions [#7955](https://github.com/haskell/cabal/pull/7955) +- Support GHC 9.4's `clang`-based Windows toolchain [#8062](https://github.com/haskell/cabal/pull/8062) +- Add support for the 64-bit S390X architecture [#8065](https://github.com/haskell/cabal/pull/8065) +- Add wasm32-wasi to recognized arch/os [#8096](https://github.com/haskell/cabal/pull/8096) + +- *Cabal-syntax* Derive Eq for DependencyMap [#7849](https://github.com/haskell/cabal/issues/7849) [#8061](https://github.com/haskell/cabal/pull/8061) +- *Cabal-syntax* Allow trailing whitespace after flags in cabal.project [#7279](https://github.com/haskell/cabal/issues/7279) [#8006](https://github.com/haskell/cabal/pull/8006) +- *Cabal-syntax* Update the SPDX License List to version 3.16 [#8126](https://github.com/haskell/cabal/issues/8126) [#8127](https://github.com/haskell/cabal/pull/8127) + + The LicenseId and LicenseExceptionId types are updated to reflect the SPDX License List version 3.16 (2022-02-06). + +- *Cabal-syntax* Future compat for liftA2 being exported from Prelude [#8823](https://github.com/haskell/cabal/pull/8823) + + - liftA2 will be exported from Prelude in the future(see https://github.com/haskell/core-libraries-committee/issues/50). + Cabal-syntax was future-proofed to have no warnings when that happens. + +- *Cabal-syntax* cabal init -n: avoid extra blank lines [#8236](https://github.com/haskell/cabal/issues/8236) [#8292](https://github.com/haskell/cabal/pull/8292) + +- Added fields :pkg-field:`extra-libraries-static` and + :pkg-field:`extra-lib-dirs-static` to allow Haskell libraries to remember + linker flags needed for fully static linking of system libraries into executables. [#7536](https://github.com/haskell/cabal/pull/7536) + +- The existing field :pkg-field:`pkgconfig-depends` can used to append the relevant + output of ``pkg-config --libs --static`` to these new fields automatically. + When :pkg-field:`extra-libraries-static` is not given, it defaults to + :pkg-field:`extra-libraries`. When :pkg-field:`extra-lib-dirs-static` is not + given, it defaults to :pkg-field:`extra-lib-dirs`. [#7536](https://github.com/haskell/cabal/pull/7536) + +- Remove the GHC version upper bound when deciding whether to filter GHC arguments + + - Previously, for unknown new versions of GHC, it was not filtering GHC arguments at all, while now it filters them in the same way as for the last known GHC version. This seems a better default and it's one less place to update at release time. Perhaps erroring out or emitting a warning would be safer, but we already emit a general warning elsewhere. diff --git a/cabal/release-notes/cabal-install-3.4.1.0.md b/cabal/release-notes/cabal-install-3.4.1.0.md new file mode 100644 --- /dev/null +++ b/cabal/release-notes/cabal-install-3.4.1.0.md @@ -0,0 +1,3 @@ +### Bugfixes + +- Backport windows fix for packages using autoconf >= 2.70 [!7668](https://github.com/haskell/cabal/pull/7668) diff --git a/cabal/release-notes/cabal-install-3.6.0.0.md b/cabal/release-notes/cabal-install-3.6.0.0.md new file mode 100644 --- /dev/null +++ b/cabal/release-notes/cabal-install-3.6.0.0.md @@ -0,0 +1,43 @@ +### Backports + +- Backported to 3.4 [#6964](https://github.com/haskell/cabal/pull/6964) [#6968](https://github.com/haskell/cabal/pull/6968) +- CI setup [#6959](https://github.com/haskell/cabal/pull/6959) + + - Remove travis scripts + +### Significant Changes + +- Add post-checkout-command to source-package-repository [#6664](https://github.com/haskell/cabal/issues/6664) [#7047](https://github.com/haskell/cabal/pull/7047) +- Assume list-bin target selectors are for executables [#7326](https://github.com/haskell/cabal/issues/7326) [#7335](https://github.com/haskell/cabal/pull/7335) +- Add a --only-download flag [#7323](https://github.com/haskell/cabal/issues/7323) [#7347](https://github.com/haskell/cabal/pull/7347) +- Add `hsc2hs-options`, for specifying additional options to pass to `hsc2hs` [#6295](https://github.com/haskell/cabal/pull/6295) +- Make extra-packages work properly [#6972](https://github.com/haskell/cabal/pull/6972) +- Bugfix - stop creating spurious dirs on `init` [#6772](https://github.com/haskell/cabal/issues/6772) [#7262](https://github.com/haskell/cabal/pull/7262) +- Avoid resource exhaustion in `cabal init` [#5115](https://github.com/haskell/cabal/issues/5115) [#7283](https://github.com/haskell/cabal/pull/7283) + + - Read file contents strictly to avoid resource exhaustion in `cabal init`. + - Ignore UTF-8 decoding errors. + +- Add language extensions for GHC 9.2 [#7312](https://github.com/haskell/cabal/issues/7312) +- --dry-run and --only-download effect v2-configure, v2-freeze, v2-run, and v2-exec [#7379](https://github.com/haskell/cabal/issues/7379) +- Fix instantiating an indefinite Backpack from Hackage with an inplace package [#6835](https://github.com/haskell/cabal/issues/6835) [#7413](https://github.com/haskell/cabal/pull/7413) + + Previously, cabal-install would always attempt to put instantiations of indefinite packages from Hackage in + the global package store, even if they were instantiated with inplace packages. This would not work + and GHC would complain about packages being missing from the package database. We have fixed the + instantiation algorithm to correctly inplace packages in these situations, removing one of the last + blockers to widespread use of Backpack packages on Hackage. + +- removes the warnings for extraneous versions [#7286](https://github.com/haskell/cabal/issues/7286) [#7470](https://github.com/haskell/cabal/pull/7470) +- Alert user and suggest command on spelling mistakes + +### Other improvements + +- Code organization [#6960](https://github.com/haskell/cabal/pull/6960) [#6963](https://github.com/haskell/cabal/pull/6963) [#6970](https://github.com/haskell/cabal/pull/6970) [#6974](https://github.com/haskell/cabal/pull/6974) [#6975](https://github.com/haskell/cabal/pull/6975) + + - Move Cabal sources into Cabal/src + - Move cabal-install sources to cabal-install/src/ + - Move doc/ to the top-level of the repository + - Add stylish-haskell config. + +- Documentation improvements [#6813](https://github.com/haskell/cabal/issues/6813) [#6971](https://github.com/haskell/cabal/pull/6971) [#7047](https://github.com/haskell/cabal/pull/7047) diff --git a/cabal/release-notes/cabal-install-3.6.2.0.md b/cabal/release-notes/cabal-install-3.6.2.0.md new file mode 100644 --- /dev/null +++ b/cabal/release-notes/cabal-install-3.6.2.0.md @@ -0,0 +1,16 @@ +### Significant changes + +- Make Paths_ modules work with non-standard preludes again [#5962](https://github.com/haskell/cabal/issues/5962) + + - Generate Paths_ module with qualified Data.List.last import so that compatibility with non-standard preludes is not regressed compared to cabal 3.4. + +- Windows: redo the fix to breakage caused by new autoconf; the wrong fix made cabal sometimes fail with old autoconf [#7494](https://github.com/haskell/cabal/issues/7494) [#7649](https://github.com/haskell/cabal/issues/7649) + + - Reverts #7510 that failed on Windows when used with pre-generated scripts included in packages such as network, time, process. + - Adds a subtler fix/workaround for the deficiencies of new autoconf versions on Windows. + +### Other changes + +- Regenerate bootstrap/ with GHC updated from 8.10.4 to 8.10.7 + + - This regenerates bootstrap plans using new package versions and also updating GHC from 8.10.4 to 8.10.7, as requested by GHC HQ. diff --git a/cabal/release-notes/cabal-install-3.8.0.20220526.md b/cabal/release-notes/cabal-install-3.8.0.20220526.md new file mode 100644 --- /dev/null +++ b/cabal/release-notes/cabal-install-3.8.0.20220526.md @@ -0,0 +1,230 @@ +cabal-install 3.8.0.20220526 Changelog +--- + +### Significant changes + +- `cabal init` rewrite [#1074](https://github.com/haskell/cabal/issues/1074) [#6758](https://github.com/haskell/cabal/issues/6758) [#6864](https://github.com/haskell/cabal/issues/6864) [#7251](https://github.com/haskell/cabal/issues/7251) [#7255](https://github.com/haskell/cabal/issues/7255) [#7256](https://github.com/haskell/cabal/issues/7256) [#7273](https://github.com/haskell/cabal/issues/7273) + + - Restructures the `cabal init` command to fix historical + issues. All flags are preserved. + - Codebases for interactive and non-interactive flags + are disentangled. + - Data structures now exploit relevant stanza structure + and formatters only care about stanza data. + - Heuristics and prompts have a pure and impure implementation. + + - Sets default behavior to be `--interactive` as opposed to + `--non-interactive`. + + - Rewrites tests to achieve 98% coverage + - Golden files now test every stanza individually. + - Every flag is covered by a unit test. + - Interactive, simple, and non-interactive workflows are + covered. + +- Make `Paths_` modules work with non-standard preludes again [#7494](https://github.com/haskell/cabal/issues/7494) [#7649](https://github.com/haskell/cabal/issues/7649) + + - Reverts [#7510](https://github.com/haskell/cabal/pull/#7510) that failed on Windows when used with pre-generated scripts included in packages such as `network`, `time`, `process`. + - Adds a subtler fix/workaround for the deficiencies of new `autoconf` versions on Windows. + +- Windows: rewrite paths to configure [#7494](https://github.com/haskell/cabal/issues/7494) [#7649](https://github.com/haskell/cabal/issues/7649) + +- Expose `cabal-install` as library [#1597](https://github.com/haskell/cabal/issues/1597) [#3781](https://github.com/haskell/cabal/issues/3781) [#4798](https://github.com/haskell/cabal/issues/4798) [#6090](https://github.com/haskell/cabal/issues/6090) [#7224](https://github.com/haskell/cabal/issues/7224) [#7358](https://github.com/haskell/cabal/pull/7358) + +- Conditionals and imports in `cabal.project` files [#7556](https://github.com/haskell/cabal/issues/7556) [#7783](https://github.com/haskell/cabal/pull/7783) + + `cabal.project` files now allow conditional logic on compiler version, arch, etc. as well as imports of other local or remote project of freeze files (both old and new style). + +- Split out package `Cabal-syntax` for `.cabal` file syntax and parsing [#7559](https://github.com/haskell/cabal/issues/7559) [#7620](https://github.com/haskell/cabal/pull/7620) + +### Other changes + +- Remove `world` file functionality [#6767](https://github.com/haskell/cabal/issues/6767) [#7746](https://github.com/haskell/cabal/pull/7746) + + In `v1-install`, `world` was used to trace what packages have been + installed, and re-install everything that is listed in it on-demand. However, in + `v2-install`, this is no longer needed, and outdated. + Additionally, `world` code-path is probably not up-to-date, remove it instead of + having partial features. + + - Don't generate `world` file in `~/.cabal` when `v1-install` is executed. + + - Don't ever read `world` from `~/.cabal`. + + - Remove meta-target `world` from `v1-install`. + +- A default configuration is no longer written when a config file is given explicitly [#7705](https://github.com/haskell/cabal/issues/7705) [#7715](https://github.com/haskell/cabal/pull/7715) + + - When no config file exists, `cabal` commands will create a default one. + + - This behavior is discontinued now when the config file is given explicitly + via the `--config-file` option or the `CABAL_CONFIG` environment variable. + + - If no config file is given explicitly, and the default config file + (relative to `CABAL_DIR`) does not exist, it is created as it used to be. + +- Use `nroff -man | less` instead of `man` as backend for `cabal man` [#7714](https://github.com/haskell/cabal/issues/7714) [#7726](https://github.com/haskell/cabal/pull/7726) + + The previous implementation of `cabal man` used `man` as backend to + view the generated manpage file. However, macOS' and BSD's `man` does + not accept a file as input, so `cabal man` was broken on macOS and + BSD. + + The issue has been fixed by piping the generated manpage through + `nroff -man` and then into `$PAGER` which defaults to `less`. Thus, + `cabal man` now works both on Linux and macOS/BSD. + + NB: `cabal man` requires `nroff` to be installed which is the case for + standard setups (but may not be case on slim setups like VMs used in + CI). Note that `nroff` is not necessarily a prerequisite of a package + containing `man`. + +- Use `Win32 >= 2.8` to get `Win32.sYNCHRONIZE` [#7835](https://github.com/haskell/cabal/issues/7835) [#7982](https://github.com/haskell/cabal/pull/7982) + + #7982 also completes a changelog entry for `Cabal-3.6.1.0`, noting it is required for `cabal-install >= 3.6`. + +- Handle option argument parse errors without `error` [#7573](https://github.com/haskell/cabal/issues/7573) [#7579](https://github.com/haskell/cabal/pull/7579) + + - Errors parsing arguments such as `-v=3` no longer result in + stack traces. + - `Distribution.ReadE.readEOrFail` was removed. + +- Add `preferred-versions` support for `LocalIndexRepo` [#7294](https://github.com/haskell/cabal/issues/7294) [#7295](https://github.com/haskell/cabal/pull/7295) + + - Previously, the only repo-index-type that reads the preferred-versions file was `RepoRemote`. + `LocalIndexRepo` now also supports parsing `preferred-versions` file, main purpose is to write tests. + As a nice side-effect, users can provide their own overlay over package sets to restrict or prefer certain package versions. + +- Add `preferred-versions` support for `cabal outdated` [#5603](https://github.com/haskell/cabal/issues/5603) [#7249](https://github.com/haskell/cabal/issues/7249) [#7296](https://github.com/haskell/cabal/pull/7296) + + - `cabal outdated` honours the `preferred-versions` file which might deprecate or prefer certain + versions of packages. In particular, if the only newer version of a package has been deprecated, + `cabal outdated` should not report that there are newer versions available. + +- Changes to `cabal v2-configure` [#5591](https://github.com/haskell/cabal/issues/5591) [#7180](https://github.com/haskell/cabal/issues/7180) [#7405](https://github.com/haskell/cabal/issues/7405) [#7402](https://github.com/haskell/cabal/pull/7402) + + - removes the `--dry-run` part of the `v2-configure` command + - add `--enable-append` and `--disable-append` flags to `v2-configure`, which toggle the option for the new configuration to be appended to the old config file + - add `--enable-backup` and `--disable-backup` flags to `v2-configure`, which toggle the backup feature for the configuration file + +- Standalone tests for `cabal init` [#7410](https://github.com/haskell/cabal/issues/7410) [#7424](https://github.com/haskell/cabal/pull/7424) + + - change the behaviour of the `--tests` flag for `cabal init`, + see https://github.com/haskell/cabal/issues/7410#issuecomment-849913926 + - add a new value `TestSuite` for the `PackageType` type + +- `cabal outdated --v2-freeze-file` prints error message if no freeze file can be found [#7406](https://github.com/haskell/cabal/issues/7406) [#7440](https://github.com/haskell/cabal/pull/7440) + + Instead of ignoring a missing `.freeze` file, abort execution and print an error message. + +- Make `cabal` respect `setgid` permission bit when creating directories [#7560](https://github.com/haskell/cabal/issues/7560) [#7572](https://github.com/haskell/cabal/pull/7572) + + - Previously `cabal` would override an admin's choice to use setgid on the + `.cabal` directory by using hardcoded file and directory modes upon + creation. Instead we now take what the system decides and only add to + that set of permissions. + +- Glob expand `extra-source-files` when tracking for rebuild [#4746](https://github.com/haskell/cabal/issues/4746) [#7608](https://github.com/haskell/cabal/pull/7608) + + - Since 3.4, `extra-source-files` have been tracked by cabal-install in the rebuild-checking logic. However, this tracking did not, until this PR, take into account glob-expansion. + +- Improve error message when no test/benchmark is found [#5079](https://github.com/haskell/cabal/issues/5079) [#5255](https://github.com/haskell/cabal/issues/5255) [#7834](https://github.com/haskell/cabal/pull/7834) + + When `cabal test` and the error message recommends setting `tests: True`, the next `cabal test` run is likely to fail with a solver error. The user might incorrectly conclude that setting `tests: True` made the problem worse, because the failure now occurs earlier (at solving time rather than at testing time). + + By including the fact that a plan failure is expected in the error message, hopefully users will be more confident that setting `tests: True` was the right move, so they will be able to focus on the true cause of the problem: the fact that no plan including the tests exists. + +- Better support for scripts [#5508](https://github.com/haskell/cabal/issues/5508) [#5698](https://github.com/haskell/cabal/issues/5698) [#6149](https://github.com/haskell/cabal/issues/6149) [#6354](https://github.com/haskell/cabal/issues/6354) [#7073](https://github.com/haskell/cabal/issues/7073) [#7842](https://github.com/haskell/cabal/issues/7842) [#7851](https://github.com/haskell/cabal/pull/7851) [#7925](https://github.com/haskell/cabal/pull/7925) [#7938](https://github.com/haskell/cabal/pull/7938) [#7990](https://github.com/haskell/cabal/pull/7990) [#7997](https://github.com/haskell/cabal/pull/7997) + + - Script support improved or added across relevant commands. + - `cabal run script` will now cache results and will not do a fresh build every time. + - `cabal build script` added: It will build the cache for script. + - `cabal repl script` added: It will open a repl for script using the cache if available. + - `cabal clean script` added: It will clean the cache for script. + - `cabal clean` will now remove script caches for which there is no marching script. + - `cabal list-bin` now works with scripts + - The name of the generated script executable has been changed from "script" to + "cabal-script-" for easier process management. + - Reduce the default verbosity of scripts, so that the build output doesn't interfere with the script output. + - Scripts now support a project metadata block that allows them to use options + that would normally be set in a cabal.project file. + +- Remove `Distribution.Client.Compat.FilePerms` [#7948](https://github.com/haskell/cabal/pull/7948) + + - Remove the module `Distribution.Client.Compat.FilePerms`, since it's + both dead code and duplicates code from `Distribution.Compat.CopyFile`. + +- Avoid malformed range requests [#5952](https://github.com/haskell/cabal/issues/5952) [#7970](https://github.com/haskell/cabal/pull/7970) + + - Don't send malformed range requests. Should make fetching from head.hackage and other "unstable" overlays more reliable. + +- Apply local options only to local packages [#7998](https://github.com/haskell/cabal/issues/7998) [#7973](https://github.com/haskell/cabal/pull/7973) + + - Command-line `ghc-options` only applies to local packages + - `program-options` stanza only applies to local packages + +- Improve error message for empty `--allow-newer=` [#7740](https://github.com/haskell/cabal/issues/7740) [#8140](https://github.com/haskell/cabal/pull/8140) + + Instead of internal error, the message now explains that empty argument for + `--allow-newer=` is not allowed and reminds what `--allow-newer` (with the empty + argument) means. + +- `cabal check` now fails when no upper bounds for `base` or `Cabal` are present in setup dependencies [#4683](https://github.com/haskell/cabal/issues/4683) [#5370](https://github.com/haskell/cabal/pull/5370) [#7409](https://github.com/haskell/cabal/pull/7409) + +- Fix `v2-haddock` results in "unexpected status" [#6679](https://github.com/haskell/cabal/issues/6679) [#7843](https://github.com/haskell/cabal/pull/7843) + +- Fix that cabal v2 commands (`install`, `repl`, `run`) use duplicate global config and rebuild libs twice in the store [#6907](https://github.com/haskell/cabal/issues/6907) [#7753](https://github.com/haskell/cabal/pull/7753) [#7759](https://github.com/haskell/cabal/pull/7759) + +- `--repl-no-load` option skips startup modules load in REPL [#7541](https://github.com/haskell/cabal/issues/7541) [#7578](https://github.com/haskell/cabal/pull/7578) + +- Fix post-checkout-command crash when 0 exit status bug [#7641](https://github.com/haskell/cabal/issues/7641) [#7847](https://github.com/haskell/cabal/pull/7847) + +- Fix `list-bin` to only choose the selected component [#7679](https://github.com/haskell/cabal/issues/7679) [#7791](https://github.com/haskell/cabal/pull/7791) + +- `cabal sdist` works in projects with `extra-packages` [#7698](https://github.com/haskell/cabal/issues/7698) + +- Add `-c` alias for `--constraint` command line flag [#7765](https://github.com/haskell/cabal/issues/7765) [#7766](https://github.com/haskell/cabal/pull/7766) + +- Ensure that `v2-sdist` command respects the `--ignore-project` flag [#7965](https://github.com/haskell/cabal/issues/7965) [#8109](https://github.com/haskell/cabal/pull/8109) + +- Make enable/disable nix flags easier to read [#8036](https://github.com/haskell/cabal/issues/8036) [#8054](https://github.com/haskell/cabal/pull/8054) + +- Add "prompt" strategy when symlinking binaries. [#5672](https://github.com/haskell/cabal/pull/5672) + +- Add a verbosity flag `+nowarn`, to suppress all warnings [#7286](https://github.com/haskell/cabal/issues/7286) [#7470](https://github.com/haskell/cabal/pull/7470) + +- Lazily decode cache files for checking invalidation [#7466](https://github.com/haskell/cabal/issues/7466) [#7516](https://github.com/haskell/cabal/pull/7516) + +- Add `--open` flag to `cabal haddock` [#7366](https://github.com/haskell/cabal/issues/7366) [#7550](https://github.com/haskell/cabal/pull/7550) + +- Defer `build-tools-depends` choices as well as setup choices [#7532](https://github.com/haskell/cabal/pull/7532) [#7561](https://github.com/haskell/cabal/pull/7561) + +- Fix running GHCJS executables [#6175](https://github.com/haskell/cabal/issues/6175) [#6361](https://github.com/haskell/cabal/issues/6361) [#7575](https://github.com/haskell/cabal/pull/7575) + +- Support Git submodules in `source-package-respository` [#5536](https://github.com/haskell/cabal/issues/5536) [#7625](https://github.com/haskell/cabal/pull/7625) + +- Add support for `--package-db` flags to v2 commands [#5773](https://github.com/haskell/cabal/issues/5773) [#7676](https://github.com/haskell/cabal/pull/7676) + +- `cabal init` now takes an optional argument and treats it as root directory for the new package [#7871](https://github.com/haskell/cabal/issues/7871) [#7873](https://github.com/haskell/cabal/pull/7873) + +- Silence warning about `world`-file field being unrecognised for flat config files [#7894](https://github.com/haskell/cabal/issues/7894) [#7903](https://github.com/haskell/cabal/pull/7903) + +- Fix Ctrl-C handling during package download [#6322](https://github.com/haskell/cabal/issues/6322) [#7929](https://github.com/haskell/cabal/pull/7929) + +- Fix the timestamp shown during `cabal update` [#7934](https://github.com/haskell/cabal/pull/7934) + +- Sync darcs repos [#7137](https://github.com/haskell/cabal/pull/7137) + +- `cabal-install-solver`: Provide more context in error messages [#7468](https://github.com/haskell/cabal/issues/7468) [#7473](https://github.com/haskell/cabal/pull/7473) + + - Error messages for misspelled extensions and languages now provide additional context. + - The error messages will provide a suggested fix if the misspelled extension or language is similar enough + to known languages and extensions. + +### Internal changes + +- Remove bootstrapping plan files from version control, and simplify bootstrap update `Makefile` targets. [#7949](https://github.com/haskell/cabal/pull/7949) + +- CI setup + + - Remove Travis scripts [#6959](https://github.com/haskell/cabal/pull/6959) diff --git a/cabal/release-notes/cabal-install-3.8.1.0.md b/cabal/release-notes/cabal-install-3.8.1.0.md new file mode 100644 --- /dev/null +++ b/cabal/release-notes/cabal-install-3.8.1.0.md @@ -0,0 +1,233 @@ +cabal-install 3.8.1.0 Changelog +--- + +### Significant changes + +- `Cabal-3.8.1.0` is used, which brings [its own set of changes](./Cabal-3.8.1.0.md), + many of which are significant. + +- Expose `cabal-install` as library [#1597](https://github.com/haskell/cabal/issues/1597) [#3781](https://github.com/haskell/cabal/issues/3781) [#4798](https://github.com/haskell/cabal/issues/4798) [#6090](https://github.com/haskell/cabal/issues/6090) [#7224](https://github.com/haskell/cabal/issues/7224) [#7358](https://github.com/haskell/cabal/pull/7358) +- Split out package `cabal-install-solver` + +- `cabal init` rewrite [#1074](https://github.com/haskell/cabal/issues/1074) [#6758](https://github.com/haskell/cabal/issues/6758) [#6864](https://github.com/haskell/cabal/issues/6864) [#7251](https://github.com/haskell/cabal/issues/7251) [#7255](https://github.com/haskell/cabal/issues/7255) [#7256](https://github.com/haskell/cabal/issues/7256) [#7273](https://github.com/haskell/cabal/issues/7273) + + - Restructures the `cabal init` command to fix historical + issues. All flags are preserved. + - Codebases for interactive and non-interactive flags + are disentangled. + - Data structures now exploit relevant stanza structure + and formatters only care about stanza data. + - Heuristics and prompts have a pure and impure implementation. + + - Sets default behavior to be `--interactive` as opposed to + `--non-interactive`. + + - Rewrites tests to achieve 98% coverage + - Golden files now test every stanza individually. + - Every flag is covered by a unit test. + - Interactive, simple, and non-interactive workflows are + covered. + +- Conditionals and imports in `cabal.project` files [#7556](https://github.com/haskell/cabal/issues/7556) [#7783](https://github.com/haskell/cabal/pull/7783) + + `cabal.project` files now allow conditional logic on compiler version, arch, etc. as well as imports of other local or remote project of freeze files (both old and new style). + +- Changes to `cabal v2-configure` [#5591](https://github.com/haskell/cabal/issues/5591) [#7180](https://github.com/haskell/cabal/issues/7180) [#7405](https://github.com/haskell/cabal/issues/7405) [#7402](https://github.com/haskell/cabal/pull/7402) + + - removes the `--dry-run` part of the `v2-configure` command. now the command only generates a cabal.project.local. to get the old functionality back, run `cabal v2-build --dry-run` after (or instead of, if generating cabal.project.local is not needed) `v2-configure` + - add `--enable-append` and `--disable-append` flags to `v2-configure`, which toggle the option for the new configuration to be appended to the old config file + - add `--enable-backup` and `--disable-backup` flags to `v2-configure`, which toggle the backup feature for the configuration file + +- Better support for scripts [#5508](https://github.com/haskell/cabal/issues/5508) [#5698](https://github.com/haskell/cabal/issues/5698) [#6149](https://github.com/haskell/cabal/issues/6149) [#6354](https://github.com/haskell/cabal/issues/6354) [#7073](https://github.com/haskell/cabal/issues/7073) [#7842](https://github.com/haskell/cabal/issues/7842) [#7851](https://github.com/haskell/cabal/pull/7851) [#7925](https://github.com/haskell/cabal/pull/7925) [#7938](https://github.com/haskell/cabal/pull/7938) [#7990](https://github.com/haskell/cabal/pull/7990) [#7997](https://github.com/haskell/cabal/pull/7997) + + - Script support improved or added across relevant commands. + - `cabal run script` will now cache results and will not do a fresh build every time. + - `cabal build script` added: It will build the cache for script. + - `cabal repl script` added: It will open a repl for script using the cache if available. + - `cabal clean script` added: It will clean the cache for script. + - `cabal clean` will now remove script caches for which there is no marching script. + - `cabal list-bin` now works with scripts + - The name of the generated script executable has been changed from "script" to + "cabal-script-" for easier process management. + - Reduce the default verbosity of scripts, so that the build output doesn't interfere with the script output. + - Scripts now support a project metadata block that allows them to use options + that would normally be set in a cabal.project file. + +- `cabal-install-solver`: Backtrack when no pkg-config is present [#7448](https://github.com/haskell/cabal/issues/7448) [#7621](https://github.com/haskell/cabal/pull/7621) + + When solving for pkgconfig-depends, when pkg-config is not present, the cabal solver will now backtrack and try a different automatic flag and dependency configuration, just as it does if pkg-config is present, but does not contain the specified package. + +- Apply local options only to local packages [#7998](https://github.com/haskell/cabal/issues/7998) [#7973](https://github.com/haskell/cabal/pull/7973) + + - Command-line `ghc-options` only applies to local packages + - `program-options` stanza only applies to local packages + +- Add `--open` flag to `cabal haddock` [#7366](https://github.com/haskell/cabal/issues/7366) [#7550](https://github.com/haskell/cabal/pull/7550) + + +### Other changes + +- Remove `world` file functionality [#6767](https://github.com/haskell/cabal/issues/6767) [#7746](https://github.com/haskell/cabal/pull/7746) + + In `v1-install`, `world` was used to trace what packages have been + installed, and re-install everything that is listed in it on-demand. However, in + `v2-install`, this is no longer needed, and outdated. + Additionally, `world` code-path is probably not up-to-date, remove it instead of + having partial features. + + - Don't generate `world` file in `~/.cabal` when `v1-install` is executed. + + - Don't ever read `world` from `~/.cabal`. + + - Remove meta-target `world` from `v1-install`. + +- A default configuration is no longer written when a config file is given explicitly [#7705](https://github.com/haskell/cabal/issues/7705) [#7715](https://github.com/haskell/cabal/pull/7715) + + - When no config file exists, `cabal` commands will create a default one. + + - This behavior is discontinued now when the config file is given explicitly + via the `--config-file` option or the `CABAL_CONFIG` environment variable. + + - If no config file is given explicitly, and the default config file + (relative to `CABAL_DIR`) does not exist, it is created as it used to be. + +- Use `nroff -man | less` instead of `man` as backend for `cabal man` [#7714](https://github.com/haskell/cabal/issues/7714) [#7726](https://github.com/haskell/cabal/pull/7726) + + The previous implementation of `cabal man` used `man` as backend to + view the generated manpage file. However, macOS' and BSD's `man` does + not accept a file as input, so `cabal man` was broken on macOS and + BSD. + + The issue has been fixed by piping the generated manpage through + `nroff -man` and then into `$PAGER` which defaults to `less`. Thus, + `cabal man` now works both on Linux and macOS/BSD. + + NB: `cabal man` requires `nroff` to be installed which is the case for + standard setups (but may not be case on slim setups like VMs used in + CI). Note that `nroff` is not necessarily a prerequisite of a package + containing `man`. + +- Use `Win32 >= 2.8` to get `Win32.sYNCHRONIZE` [#7835](https://github.com/haskell/cabal/issues/7835) [#7982](https://github.com/haskell/cabal/pull/7982) + + #7982 also completes a changelog entry for `Cabal-3.6.1.0`, noting it is required for `cabal-install >= 3.6`. + +- Add `preferred-versions` support for `LocalIndexRepo` [#7294](https://github.com/haskell/cabal/issues/7294) [#7295](https://github.com/haskell/cabal/pull/7295) + + - Previously, the only repo-index-type that reads the preferred-versions file was `RepoRemote`. + `LocalIndexRepo` now also supports parsing `preferred-versions` file, main purpose is to write tests. + As a nice side-effect, users can provide their own overlay over package sets to restrict or prefer certain package versions. + +- Add `preferred-versions` support for `cabal outdated` [#5603](https://github.com/haskell/cabal/issues/5603) [#7249](https://github.com/haskell/cabal/issues/7249) [#7296](https://github.com/haskell/cabal/pull/7296) + + - `cabal outdated` honours the `preferred-versions` file which might deprecate or prefer certain + versions of packages. In particular, if the only newer version of a package has been deprecated, + `cabal outdated` should not report that there are newer versions available. + +- Standalone tests for `cabal init` [#7410](https://github.com/haskell/cabal/issues/7410) [#7424](https://github.com/haskell/cabal/pull/7424) + + - change the behaviour of the `--tests` flag for `cabal init`, + see https://github.com/haskell/cabal/issues/7410#issuecomment-849913926 + - add a new value `TestSuite` for the `PackageType` type + +- `cabal outdated --v2-freeze-file` prints error message if no freeze file can be found [#7406](https://github.com/haskell/cabal/issues/7406) [#7440](https://github.com/haskell/cabal/pull/7440) + + Instead of ignoring a missing `.freeze` file, abort execution and print an error message. + +- Make `cabal` respect `setgid` permission bit when creating directories [#7560](https://github.com/haskell/cabal/issues/7560) [#7572](https://github.com/haskell/cabal/pull/7572) + + - Previously `cabal` would override an admin's choice to use setgid on the + `.cabal` directory by using hardcoded file and directory modes upon + creation. Instead we now take what the system decides and only add to + that set of permissions. + +- Glob expand `extra-source-files` when tracking for rebuild [#4746](https://github.com/haskell/cabal/issues/4746) [#7608](https://github.com/haskell/cabal/pull/7608) + + - Since 3.4, `extra-source-files` have been tracked by cabal-install in the rebuild-checking logic. However, this tracking did not, until this PR, take into account glob-expansion. + +- Improve error message when no test/benchmark is found [#5079](https://github.com/haskell/cabal/issues/5079) [#5255](https://github.com/haskell/cabal/issues/5255) [#7834](https://github.com/haskell/cabal/pull/7834) + + When `cabal test` and the error message recommends setting `tests: True`, the next `cabal test` run is likely to fail with a solver error. The user might incorrectly conclude that setting `tests: True` made the problem worse, because the failure now occurs earlier (at solving time rather than at testing time). + + By including the fact that a plan failure is expected in the error message, hopefully users will be more confident that setting `tests: True` was the right move, so they will be able to focus on the true cause of the problem: the fact that no plan including the tests exists. + +- Remove `Distribution.Client.Compat.FilePerms` [#7948](https://github.com/haskell/cabal/pull/7948) + + - Remove the module `Distribution.Client.Compat.FilePerms`, since it's + both dead code and duplicates code from `Distribution.Compat.CopyFile`. + +- Avoid malformed range requests [#5952](https://github.com/haskell/cabal/issues/5952) [#7970](https://github.com/haskell/cabal/pull/7970) + + - Don't send malformed range requests. Should make fetching from head.hackage and other "unstable" overlays more reliable. + +- Improve error message for empty `--allow-newer=` [#7740](https://github.com/haskell/cabal/issues/7740) [#8140](https://github.com/haskell/cabal/pull/8140) + + Instead of internal error, the message now explains that empty argument for + `--allow-newer=` is not allowed and reminds what `--allow-newer` (with the empty + argument) means. + +- `cabal check` now fails when no upper bounds for `base` or `Cabal` are present in setup dependencies [#4683](https://github.com/haskell/cabal/issues/4683) [#5370](https://github.com/haskell/cabal/pull/5370) [#7409](https://github.com/haskell/cabal/pull/7409) + +- Fix `v2-haddock` results in "unexpected status" [#6679](https://github.com/haskell/cabal/issues/6679) [#7843](https://github.com/haskell/cabal/pull/7843) + +- Fix that cabal v2 commands (`install`, `repl`, `run`) use duplicate global config and rebuild libs twice in the store [#6907](https://github.com/haskell/cabal/issues/6907) [#7753](https://github.com/haskell/cabal/pull/7753) [#7759](https://github.com/haskell/cabal/pull/7759) + +- `--repl-no-load` option skips startup modules load in REPL [#7541](https://github.com/haskell/cabal/issues/7541) [#7578](https://github.com/haskell/cabal/pull/7578) + +- Fix post-checkout-command crash when 0 exit status bug [#7641](https://github.com/haskell/cabal/issues/7641) [#7847](https://github.com/haskell/cabal/pull/7847) + +- Fix `list-bin` to only choose the selected component [#7679](https://github.com/haskell/cabal/issues/7679) [#7791](https://github.com/haskell/cabal/pull/7791) + +- `cabal sdist` works in projects with `extra-packages` [#7698](https://github.com/haskell/cabal/issues/7698) + +- Add `-c` alias for `--constraint` command line flag [#7765](https://github.com/haskell/cabal/issues/7765) [#7766](https://github.com/haskell/cabal/pull/7766) + +- Ensure that `v2-sdist` command respects the `--ignore-project` flag [#7965](https://github.com/haskell/cabal/issues/7965) [#8109](https://github.com/haskell/cabal/pull/8109) + +- Make enable/disable nix flags easier to read [#8036](https://github.com/haskell/cabal/issues/8036) [#8054](https://github.com/haskell/cabal/pull/8054) + +- Add "prompt" strategy when symlinking binaries. [#5672](https://github.com/haskell/cabal/pull/5672) + +- Add a verbosity flag `+nowarn`, to suppress all warnings [#7286](https://github.com/haskell/cabal/issues/7286) [#7470](https://github.com/haskell/cabal/pull/7470) + +- Lazily decode cache files for checking invalidation [#7466](https://github.com/haskell/cabal/issues/7466) [#7516](https://github.com/haskell/cabal/pull/7516) + +- Defer `build-tools-depends` choices as well as setup choices [#7532](https://github.com/haskell/cabal/pull/7532) [#7561](https://github.com/haskell/cabal/pull/7561) + +- Fix running GHCJS executables [#6175](https://github.com/haskell/cabal/issues/6175) [#6361](https://github.com/haskell/cabal/issues/6361) [#7575](https://github.com/haskell/cabal/pull/7575) + +- Support Git submodules in `source-package-respository` [#5536](https://github.com/haskell/cabal/issues/5536) [#7625](https://github.com/haskell/cabal/pull/7625) + +- Add support for `--package-db` flags to v2 commands [#5773](https://github.com/haskell/cabal/issues/5773) [#7676](https://github.com/haskell/cabal/pull/7676) + +- `cabal init` now takes an optional argument and treats it as root directory for the new package [#7871](https://github.com/haskell/cabal/issues/7871) [#7873](https://github.com/haskell/cabal/pull/7873) + +- Silence warning about `world`-file field being unrecognised for flat config files [#7894](https://github.com/haskell/cabal/issues/7894) [#7903](https://github.com/haskell/cabal/pull/7903) + +- Fix Ctrl-C handling during package download [#6322](https://github.com/haskell/cabal/issues/6322) [#7929](https://github.com/haskell/cabal/pull/7929) + +- Fix the timestamp shown during `cabal update` [#7934](https://github.com/haskell/cabal/pull/7934) + +- Sync darcs repos [#7137](https://github.com/haskell/cabal/pull/7137) + +- `cabal-install-solver`: Provide more context in error messages [#7468](https://github.com/haskell/cabal/issues/7468) [#7473](https://github.com/haskell/cabal/pull/7473) + + - Error messages for misspelled extensions and languages now provide additional context. + - The error messages will provide a suggested fix if the misspelled extension or language is similar enough + to known languages and extensions. + +- cabal init -i should autodetect author name and maintainer email (fix #8255) [#8255](https://github.com/haskell/cabal/issues/8255) [#8267](https://github.com/haskell/cabal/pull/8267) + +- cabal init -i: add the GHC2021 language option [#8265](https://github.com/haskell/cabal/issues/8265) [#8277](https://github.com/haskell/cabal/pull/8277) + +- Automatically pipe auth from repo uris into curl transport. [#4743](https://github.com/haskell/cabal/issues/4743) [#7630](https://github.com/haskell/cabal/pull/7630) + +- Build release archives (and validate) with GHC 9.2.3 [#8271](https://github.com/haskell/cabal/issues/8271) [#8272](https://github.com/haskell/cabal/pull/8272) + - The release binaries are now built with GHC 9.2.3, which fixes some minor snags + +### Internal changes + +- Remove bootstrapping plan files from version control, and simplify bootstrap update `Makefile` targets. [#7949](https://github.com/haskell/cabal/pull/7949) + +- CI setup + + - Remove Travis scripts [#6959](https://github.com/haskell/cabal/pull/6959) diff --git a/cabal/solver-benchmarks/HackageBenchmark.hs b/cabal/solver-benchmarks/HackageBenchmark.hs --- a/cabal/solver-benchmarks/HackageBenchmark.hs +++ b/cabal/solver-benchmarks/HackageBenchmark.hs @@ -1,6 +1,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE ScopedTypeVariables #-} module HackageBenchmark ( hackageBenchmarkMain @@ -13,29 +14,34 @@ , shouldContinueAfterFirstTrial ) where -import Control.Monad (forM_, replicateM, unless, when) -import qualified Data.ByteString as B +import Control.Concurrent.Async (concurrently) +import Control.Monad (forM, replicateM, unless, when) +import qualified Data.ByteString as BS import Data.List (nub, unzip4) -import Data.Maybe (isJust) +import Data.Maybe (isJust, catMaybes) import Data.Monoid ((<>)) import Data.String (fromString) +import Data.Function ((&)) import Data.Time (NominalDiffTime, diffUTCTime, getCurrentTime) import qualified Data.Vector.Unboxed as V import Options.Applicative -import Statistics.Sample (mean, stdDev) +import Statistics.Sample (mean, stdDev, geometricMean) import Statistics.Test.MannWhitneyU ( PositionTest(..), TestResult(..) , mannWhitneyUCriticalValue , mannWhitneyUtest) import Statistics.Types (PValue, mkPValue) -import System.Directory (getTemporaryDirectory) -import System.Exit (ExitCode(..), exitFailure) +import System.Directory (getTemporaryDirectory, createDirectoryIfMissing) +import System.Environment (getEnvironment) +import System.Exit (ExitCode(..), exitWith, exitFailure) import System.FilePath (()) import System.IO ( BufferMode(LineBuffering), hPutStrLn, hSetBuffering, stderr , stdout) import System.Process ( StdStream(CreatePipe), CreateProcess(..), callProcess - , createProcess, readProcess, shell, waitForProcess ) + , createProcess, readProcess, shell, waitForProcess, proc, readCreateProcessWithExitCode ) import Text.Printf (printf) +import qualified Data.Map.Strict as Map + import Distribution.Package (PackageName, mkPackageName, unPackageName) data Args = Args { @@ -47,6 +53,7 @@ , argMinRunTimeDifferenceToRerun :: Double , argPValue :: PValue Double , argTrials :: Int + , argConcurrently :: Bool , argPrintTrials :: Bool , argPrintSkippedPackages :: Bool , argTimeoutSeconds :: Int @@ -76,13 +83,19 @@ pkgs <- getPackages args putStrLn "" + let concurrently' :: IO a -> IO b -> IO (a, b) + concurrently' | argConcurrently = concurrently + | otherwise = \ma mb -> do { a <- ma; b <- mb; return (a, b) } + let -- The maximum length of the heading and package names. nameColumnWidth :: Int nameColumnWidth = maximum $ map length $ "package" : map unPackageName pkgs - runCabal1 = runCabal argTimeoutSeconds argCabal1 argCabal1Flags - runCabal2 = runCabal argTimeoutSeconds argCabal2 argCabal2Flags + -- create cabal runners + runCabal1 <- runCabal argTimeoutSeconds CabalUnderTest1 argCabal1 argCabal1Flags + runCabal2 <- runCabal argTimeoutSeconds CabalUnderTest2 argCabal2 argCabal2Flags + -- When the output contains both trails and summaries, label each row as -- "trial" or "summary". when argPrintTrials $ putStr $ printf "%-16s " "trial/summary" @@ -91,7 +104,7 @@ nameColumnWidth "package" "result1" "result2" "mean1" "mean2" "stddev1" "stddev2" "speedup" - forM_ pkgs $ \pkg -> do + speedups :: [Double] <- fmap catMaybes $ forM pkgs $ \pkg -> do let printTrial msgType result1 result2 time1 time2 = putStrLn $ printf "%-16s %-*s %-14s %-14s %10.3fs %10.3fs" @@ -99,21 +112,23 @@ (show result1) (show result2) (diffTimeToDouble time1) (diffTimeToDouble time2) - CabalTrial t1 r1 <- runCabal1 pkg - CabalTrial t2 r2 <- runCabal2 pkg + (CabalTrial t1 r1, CabalTrial t2 r2) <- runCabal1 pkg `concurrently'` runCabal2 pkg + if not $ shouldContinueAfterFirstTrial argMinRunTimeDifferenceToRerun t1 t2 r1 r2 - then when argPrintSkippedPackages $ + then do + when argPrintSkippedPackages $ if argPrintTrials then printTrial "trial (skipping)" r1 r2 t1 t2 else putStrLn $ printf "%-*s (first run times were too similar)" nameColumnWidth (unPackageName pkg) + return Nothing else do when argPrintTrials $ printTrial "trial" r1 r2 t1 t2 (ts1, ts2, rs1, rs2) <- (unzip4 . ((t1, t2, r1, r2) :) <$>) . replicateM (argTrials - 1) $ do - CabalTrial t1' r1' <- runCabal1 pkg - CabalTrial t2' r2' <- runCabal2 pkg + + (CabalTrial t1' r1', CabalTrial t2' r2') <- runCabal1 pkg `concurrently'` runCabal2 pkg when argPrintTrials $ printTrial "trial" r1' r2' t1' t2' return (t1', t2', r1', r2') @@ -136,7 +151,14 @@ (show result1) (show result2) mean1 mean2 stddev1 stddev2 speedup else when (argPrintTrials || argPrintSkippedPackages) $ putStrLn $ - printf "%-*s (not significant)" nameColumnWidth (unPackageName pkg) + printf "%-*s (not significant, speedup = %10.3f)" nameColumnWidth (unPackageName pkg) speedup + + -- return speedup value + return (Just speedup) + + -- finally, calculate the geometric mean of speedups + printf "Geometric mean of %d packages' speedups is %10.3f\n" (length speedups) (geometricMean (V.fromList speedups)) + where checkArgs :: Args -> IO () checkArgs Args {..} = do @@ -172,61 +194,102 @@ putStrLn $ "Done, got " ++ show (length pkgs) ++ " packages." return pkgs -runCabal :: Int -> FilePath -> [String] -> PackageName -> IO CabalTrial -runCabal timeoutSeconds cabal flags pkg = do - ((exitCode, err), time) <- timeEvent $ do - tmpDir <- getTemporaryDirectory +data CabalUnderTest = CabalUnderTest1 | CabalUnderTest2 - let timeout = "timeout --foreground -sINT " ++ show timeoutSeconds - cabalCmd = unwords $ - [ cabal +runCabal + :: Int -- ^ timeout in seconds + -> CabalUnderTest -- ^ cabal under test + -> FilePath -- ^ cabal + -> [String] -- ^ flags + -> IO (PackageName -> IO CabalTrial) -- ^ testing function. +runCabal timeoutSeconds cabalUnderTest cabal flags = do + tmpDir <- getTemporaryDirectory - -- A non-existent store directory prevents cabal from reading the - -- store, which would cause the size of the store to affect run - -- time. - , "--store-dir=" ++ (tmpDir "non-existent-store-dir") + -- cabal directory for this cabal under test + let cabalDir = tmpDir "solver-benchmarks-workdir" case cabalUnderTest of + CabalUnderTest1 -> "cabal1" + CabalUnderTest2 -> "cabal2" - , "v2-install" + putStrLn $ "Cabal directory (for " ++ cabal ++ ") " ++ cabalDir + createDirectoryIfMissing True cabalDir - -- These flags prevent a Cabal project or package environment from - -- affecting the install plan. - , "--ignore-project" - , "--package-env=non-existent-package-env" + -- shell enviroment + currEnv <- Map.fromList <$> getEnvironment + let thisEnv :: [(String, String)] + thisEnv = Map.toList $ currEnv + & Map.insert "CABAL_CONFIG" (cabalDir "config") + & Map.insert "CABAL_DIR" cabalDir - -- --lib allows solving for packages with libraries or - -- executables. - , "--lib" + -- Run cabal update, + putStrLn $ "Running cabal update (using " ++ cabal ++ ") ..." + (ec, uout, uerr) <- readCreateProcessWithExitCode (proc cabal ["update"]) + { cwd = Just cabalDir + , env = Just thisEnv + } + "" + unless (ec == ExitSuccess) $ do + putStrLn uout + putStrLn uerr + exitWith ec - , unPackageName pkg + -- return an actual runner + return $ \pkg -> do + ((exitCode, err), time) <- timeEvent $ do - , "--dry-run" + let timeout = "timeout --foreground -sINT " ++ show timeoutSeconds + cabalCmd = unwords $ + [ cabal - -- The test doesn't currently handle stdout, so we suppress it - -- with silent. nowrap simplifies parsing the errors messages. - , "-vsilent+nowrap"] + , "v2-install" - ++ flags - cmd = (shell (timeout ++ " " ++ cabalCmd)) { std_err = CreatePipe } + -- These flags prevent a Cabal project or package environment from + -- affecting the install plan. + -- + -- Note: we are somewhere in /tmp, hopefully there is no cabal.project on upper level + , "--package-env=non-existent-package-env" - -- TODO: Read stdout and compare the install plans. - (_, _, Just errh, ph) <- createProcess cmd - err <- B.hGetContents errh - (, err) <$> waitForProcess ph - let exhaustiveMsg = - "After searching the rest of the dependency tree exhaustively" - result - | exitCode == ExitSuccess = Solution - | exitCode == ExitFailure 124 = Timeout - | fromString exhaustiveMsg `B.isInfixOf` err = NoInstallPlan - | fromString "Backjump limit reached" `B.isInfixOf` err = BackjumpLimit - | fromString "none of the components are available to build" `B.isInfixOf` err = Unbuildable - | fromString "Dependency on unbuildable" `B.isInfixOf` err = UnbuildableDep - | fromString "Dependency cycle between the following components" `B.isInfixOf` err = ComponentCycle - | fromString "Problem with module re-exports" `B.isInfixOf` err = ModReexpIssue - | fromString "There is no package named" `B.isInfixOf` err = PkgNotFound - | otherwise = Unknown - return (CabalTrial time result) + -- --lib allows solving for packages with libraries or + -- executables. + , "--lib" + , unPackageName pkg + + , "--dry-run" + + -- The test doesn't currently handle stdout, so we suppress it + -- with silent. nowrap simplifies parsing the errors messages. + , "-vsilent+nowrap" + + ] + + ++ flags + + cmd = (shell (timeout ++ " " ++ cabalCmd)) + { std_err = CreatePipe + , env = Just thisEnv + , cwd = Just cabalDir + } + + -- TODO: Read stdout and compare the install plans. + (_, _, Just errh, ph) <- createProcess cmd + err <- BS.hGetContents errh + (, err) <$> waitForProcess ph + + let exhaustiveMsg = + "After searching the rest of the dependency tree exhaustively" + result + | exitCode == ExitSuccess = Solution + | exitCode == ExitFailure 124 = Timeout + | fromString exhaustiveMsg `BS.isInfixOf` err = NoInstallPlan + | fromString "Backjump limit reached" `BS.isInfixOf` err = BackjumpLimit + | fromString "none of the components are available to build" `BS.isInfixOf` err = Unbuildable + | fromString "Dependency on unbuildable" `BS.isInfixOf` err = UnbuildableDep + | fromString "Dependency cycle between the following components" `BS.isInfixOf` err = ComponentCycle + | fromString "Problem with module re-exports" `BS.isInfixOf` err = ModReexpIssue + | fromString "There is no package named" `BS.isInfixOf` err = PkgNotFound + | otherwise = Unknown + return (CabalTrial time result) + isSampleLargeEnough :: PValue Double -> Int -> Bool isSampleLargeEnough pvalue trials = -- mannWhitneyUCriticalValue, which can fail with too few samples, is only @@ -347,6 +410,9 @@ <> value 10 <> metavar "N" <> help "Number of trials for each package") + <*> switch + ( long "concurrently" + <> help "Run cabals concurrently") <*> switch ( long "print-trials" <> help "Whether to include the results from individual trials in the output") diff --git a/cabal/solver-benchmarks/LICENSE b/cabal/solver-benchmarks/LICENSE --- a/cabal/solver-benchmarks/LICENSE +++ b/cabal/solver-benchmarks/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2003-2020, Cabal Development Team. +Copyright (c) 2003-2022, Cabal Development Team. See the AUTHORS file for the full list of copyright holders. See */LICENSE for the copyright holders of the subcomponents. diff --git a/cabal/solver-benchmarks/pkglist.txt b/cabal/solver-benchmarks/pkglist.txt new file mode 100644 --- /dev/null +++ b/cabal/solver-benchmarks/pkglist.txt @@ -0,0 +1,207 @@ +Agda +Cabal +Chart +JuicyPixels +JuicyPixels-scale-dct +MemoTrie +OneTuple +Only +QuickCheck +StateVar +adjunctions +aeson +aeson-compat +aeson-extra +aeson-optics +aeson-pretty +aeson-pretty +ansi-terminal +ansi-wl-pprint +array +assoc +attoparsec +attoparsec-iso8601 +base-compat +base-compat-batteries +base-orphans +base16-bytestring +base64-bytestring +base64-bytestring-type +bifunctors +bin +binary +binary-instances +binary-orphans +binary-tagged +blaze-builder +boring +bound +bound-extras +bytes +bytestring +bytestring-builder +cabal-doctest +call-stack +carray +case-insensitive +cassava +cborg +cereal +charset +cmdargs +colour +comonad +confusing +constraints +containers +contravariant +cookie +crypt-sha512 +cryptohash-sha512 +data-default-class +data-fix +dec +deepseq +dhall +directory +distributive +dlist +dlist-nonempty +edit-distance +exceptions +fft +file-embed-lzma +filepath +filtrable +fin +fingertree +free +functor-classes-compat +generics-sop +generics-sop-lens +ghc-boot-th +ghc-prim +hakyll +half +hashable +hkd +hsc2hs +http-api-data +http-media +http-types +indexed-profunctors +insert-ordered-containers +integer-logarithms +intervals +invariant +ix-shapable +jsaddle +kan-extensions +kleene +lattices +lens +lucid +lukko +lzma +microstache +mmorph +monad-chronicle +months +mtl +network +network-uri +newtype-generics +old-locale +old-time +operational +optics-core +optics-extra +optics-th +pandoc +parallel +parsec +parsers +postgresql-libpq +postgresql-simple +postgresql-simple-url +postgrest +pretty +primitive +process +profunctors +quickcheck-instances +ral +ral-lens +ral-optics +random +range-set-list +recursion-schemes +reducers +reflection +reflex +reflex-dom +regex-applicative +regex-applicative-text +rere +scientific +semialign +semialign-indexed +semialign-optics +semigroupoids +semigroups +serialise +singleton-bool +some +sop-core +spdx +split +splitmix +step-function +stm +storable-complex +streams +strict +structured +swagger2 +syb +tagged +tdigest +tdigest-Chart +template-haskell +text +text-binary +text-short +th-abstraction +th-lift +th-lift-instances +these +these-lens +these-optics +time +time-compat +time-locale-compat +time-parsers +topograph +transformers +transformers-base +transformers-compat +tree-diff +type-equality +universe-base +universe-reverse-instances +unix +unordered-containers +utf8-string +uuid-types +vec +vec-lens +vec-optics +vector +vector-algorithms +vector-binary-instances +void +wai +warp +yesod +zinza +zlib diff --git a/cabal/solver-benchmarks/solver-benchmarks.cabal b/cabal/solver-benchmarks/solver-benchmarks.cabal --- a/cabal/solver-benchmarks/solver-benchmarks.cabal +++ b/cabal/solver-benchmarks/solver-benchmarks.cabal @@ -1,7 +1,8 @@ +cabal-version: 2.2 name: solver-benchmarks version: 3 -copyright: 2003-2020, Cabal Development Team (see AUTHORS file) -license: BSD3 +copyright: 2003-2022, Cabal Development Team (see AUTHORS file) +license: BSD-3-Clause license-file: LICENSE author: Cabal Development Team maintainer: cabal-devel@haskell.org @@ -11,7 +12,6 @@ description: This package contains benchmarks that test cabal's dependency solver by running the cabal executable. category: Distribution -cabal-version: >=1.10 build-type: Simple extra-source-files: @@ -27,9 +27,11 @@ exposed-modules: HackageBenchmark build-depends: + async >=2.2.2 && <2.3, base, bytestring, - Cabal >= 2.3, + containers, + Cabal-syntax ^>=3.8, directory, filepath, optparse-applicative, diff --git a/cabal/stack.yaml b/cabal/stack.yaml --- a/cabal/stack.yaml +++ b/cabal/stack.yaml @@ -1,11 +1,27 @@ -resolver: lts-11.6 +resolver: lts-18.28 # ghc-8.10.7 + packages: +- Cabal-syntax/ - Cabal/ +- Cabal-described +- Cabal-QuickCheck/ +- Cabal-tests/ +- Cabal-tree-diff/ +- cabal-benchmarks/ +- cabal-install-solver/ - cabal-install/ - cabal-testsuite/ +- solver-benchmarks/ + extra-deps: - - resolv-0.1.1.1 - - QuickCheck-2.11.3 +# Not included in stackage +- rere-0.2@rev:1 + +# We require the released version of Cabal and Cabal-syntax for cabal-testsuite +# but usually we have a development, newer version set in the local package +# Also needed for hackage-security and Win32 +allow-newer: true + nix: packages: - autoconf diff --git a/cabal/templates/Lexer.x b/cabal/templates/Lexer.x new file mode 100644 --- /dev/null +++ b/cabal/templates/Lexer.x @@ -0,0 +1,287 @@ +{ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Fields.Lexer +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Lexer for the cabal files. +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +#ifdef CABAL_PARSEC_DEBUG +{-# LANGUAGE PatternGuards #-} +#endif +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +module Distribution.Fields.Lexer + (ltest, lexToken, Token(..), LToken(..) + ,bol_section, in_section, in_field_layout, in_field_braces + ,mkLexState) where + +-- [Note: bootstrapping parsec parser] +-- +-- We manually produce the `Lexer.hs` file from `boot/Lexer.x` (make lexer) +-- because bootstrapping cabal-install would be otherwise tricky. +-- Alex is (atm) tricky package to build, cabal-install has some magic +-- to move bundled generated files in place, so rather we don't depend +-- on it before we can build it ourselves. +-- Therefore there is one thing less to worry in bootstrap.sh, which is a win. +-- +-- See also https://github.com/haskell/cabal/issues/4633 +-- + +import Prelude () +import qualified Prelude as Prelude +import Distribution.Compat.Prelude + +import Distribution.Fields.LexerMonad +import Distribution.Parsec.Position (Position (..), incPos, retPos) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B.Char8 +import qualified Data.Word as Word + +#ifdef CABAL_PARSEC_DEBUG +import Debug.Trace +import qualified Data.Vector as V +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Encoding.Error as T +#endif + +} +-- Various character classes + +$space = \ -- single space char +$ctlchar = [\x0-\x1f \x7f] +$printable = \x0-\xff # $ctlchar -- so no \n \r +$symbol' = [ \, \= \< \> \+ \* \& \| \! \$ \% \^ \@ \# \? \/ \\ \~ ] +$symbol = [$symbol' \- \.] +$spacetab = [$space \t] + +$paren = [ \( \) \[ \] ] +$field_layout = [$printable \t] +$field_layout' = [$printable] # [$space] +$field_braces = [$printable \t] # [\{ \}] +$field_braces' = [$printable] # [\{ \} $space] +$comment = [$printable \t] +$namecore = [$printable] # [$space \: \" \{ \} $paren $symbol'] +$instr = [$printable $space] # [\"] +$instresc = $printable + +@bom = \xef \xbb \xbf +@nbsp = \xc2 \xa0 +@nbspspacetab = ($spacetab | @nbsp) +@nbspspace = ($space | @nbsp) +@nl = \n | \r\n | \r +@name = $namecore+ +@string = \" ( $instr | \\ $instresc )* \" +@oplike = $symbol+ + + +tokens :- + +<0> { + @bom? { \_ len _ -> do + when (len /= 0) $ addWarning LexWarningBOM + setStartCode bol_section + lexToken + } +} + + { + @nbspspacetab* @nl { \_pos len inp -> checkWhitespace len inp >> adjustPos retPos >> lexToken } + -- no @nl here to allow for comments on last line of the file with no trailing \n + $spacetab* "--" $comment* ; -- TODO: check the lack of @nl works here + -- including counting line numbers +} + + { + @nbspspacetab* { \pos len inp -> checkLeadingWhitespace len inp >> + if B.length inp == len + then return (L pos EOF) + else setStartCode in_section + >> return (L pos (Indent len)) } + $spacetab* \{ { tok OpenBrace } + $spacetab* \} { tok CloseBrace } +} + + { + $spacetab+ ; --TODO: don't allow tab as leading space + + "--" $comment* ; + + @name { toki TokSym } + @string { \pos len inp -> return $! L pos (TokStr (B.take (len - 2) (B.tail inp))) } + @oplike { toki TokOther } + $paren { toki TokOther } + \: { tok Colon } + \{ { tok OpenBrace } + \} { tok CloseBrace } + @nl { \_ _ _ -> adjustPos retPos >> setStartCode bol_section >> lexToken } +} + + { + @nbspspacetab* { \pos len inp -> checkLeadingWhitespace len inp >>= \len' -> + if B.length inp == len + then return (L pos EOF) + else setStartCode in_field_layout + >> return (L pos (Indent len')) } +} + + { + $spacetab+; + $field_layout' $field_layout* { toki TokFieldLine } + @nl { \_ _ _ -> adjustPos retPos >> setStartCode bol_field_layout >> lexToken } +} + + { + () { \_ _ _ -> setStartCode in_field_braces >> lexToken } +} + + { + $spacetab+; + $field_braces' $field_braces* { toki TokFieldLine } + \{ { tok OpenBrace } + \} { tok CloseBrace } + @nl { \_ _ _ -> adjustPos retPos >> setStartCode bol_field_braces >> lexToken } +} + +{ + +-- | Tokens of outer cabal file structure. Field values are treated opaquely. +data Token = TokSym !ByteString -- ^ Haskell-like identifier, number or operator + | TokStr !ByteString -- ^ String in quotes + | TokOther !ByteString -- ^ Operators and parens + | Indent !Int -- ^ Indentation token + | TokFieldLine !ByteString -- ^ Lines after @:@ + | Colon + | OpenBrace + | CloseBrace + | EOF + | LexicalError InputStream --TODO: add separate string lexical error + deriving Show + +data LToken = L !Position !Token + deriving Show + +toki :: (ByteString -> Token) -> Position -> Int -> ByteString -> Lex LToken +toki t pos len input = return $! L pos (t (B.take len input)) + +tok :: Token -> Position -> Int -> ByteString -> Lex LToken +tok t pos _len _input = return $! L pos t + +checkLeadingWhitespace :: Int -> ByteString -> Lex Int +checkLeadingWhitespace len bs + | B.any (== 9) (B.take len bs) = do + addWarning LexWarningTab + checkWhitespace len bs + | otherwise = checkWhitespace len bs + +checkWhitespace :: Int -> ByteString -> Lex Int +checkWhitespace len bs + | B.any (== 194) (B.take len bs) = do + addWarning LexWarningNBSP + return $ len - B.count 194 (B.take len bs) + | otherwise = return len + +-- ----------------------------------------------------------------------------- +-- The input type + +type AlexInput = InputStream + +alexInputPrevChar :: AlexInput -> Char +alexInputPrevChar _ = error "alexInputPrevChar not used" + +alexGetByte :: AlexInput -> Maybe (Word.Word8,AlexInput) +alexGetByte = B.uncons + +lexicalError :: Position -> InputStream -> Lex LToken +lexicalError pos inp = do + setInput B.empty + return $! L pos (LexicalError inp) + +lexToken :: Lex LToken +lexToken = do + pos <- getPos + inp <- getInput + st <- getStartCode + case alexScan inp st of + AlexEOF -> return (L pos EOF) + AlexError inp' -> + let !len_bytes = B.length inp - B.length inp' in + --FIXME: we want len_chars here really + -- need to decode utf8 up to this point + lexicalError (incPos len_bytes pos) inp' + AlexSkip inp' len_chars -> do + checkPosition pos inp inp' len_chars + adjustPos (incPos len_chars) + setInput inp' + lexToken + AlexToken inp' len_chars action -> do + checkPosition pos inp inp' len_chars + adjustPos (incPos len_chars) + setInput inp' + let !len_bytes = B.length inp - B.length inp' + t <- action pos len_bytes inp + --traceShow t $ return tok + return t + + +checkPosition :: Position -> ByteString -> ByteString -> Int -> Lex () +#ifdef CABAL_PARSEC_DEBUG +checkPosition pos@(Position lineno colno) inp inp' len_chars = do + text_lines <- getDbgText + let len_bytes = B.length inp - B.length inp' + pos_txt | lineno-1 < V.length text_lines = T.take len_chars (T.drop (colno-1) (text_lines V.! (lineno-1))) + | otherwise = T.empty + real_txt = B.take len_bytes inp + when (pos_txt /= T.decodeUtf8 real_txt) $ + traceShow (pos, pos_txt, T.decodeUtf8 real_txt) $ + traceShow (take 3 (V.toList text_lines)) $ return () + where + getDbgText = Lex $ \s@LexState{ dbgText = txt } -> LexResult s txt +#else +checkPosition _ _ _ _ = return () +#endif + +lexAll :: Lex [LToken] +lexAll = do + t <- lexToken + case t of + L _ EOF -> return [t] + _ -> do ts <- lexAll + return (t : ts) + +ltest :: Int -> String -> Prelude.IO () +ltest code s = + let (ws, xs) = execLexer (setStartCode code >> lexAll) (B.Char8.pack s) + in traverse_ print ws >> traverse_ print xs + + +mkLexState :: ByteString -> LexState +mkLexState input = LexState + { curPos = Position 1 1 + , curInput = input + , curCode = 0 + , warnings = [] +#ifdef CABAL_PARSEC_DEBUG + , dbgText = V.fromList . lines' . T.decodeUtf8With T.lenientDecode $ input +#endif + } + +#ifdef CABAL_PARSEC_DEBUG +lines' :: T.Text -> [T.Text] +lines' s1 + | T.null s1 = [] + | otherwise = case T.break (\c -> c == '\r' || c == '\n') s1 of + (l, s2) | Just (c,s3) <- T.uncons s2 + -> case T.uncons s3 of + Just ('\n', s4) | c == '\r' -> l `T.snoc` '\r' `T.snoc` '\n' : lines' s4 + _ -> l `T.snoc` c : lines' s3 + + | otherwise + -> [l] +#endif +} diff --git a/cabal/templates/Paths_pkg.template.hs b/cabal/templates/Paths_pkg.template.hs new file mode 100644 --- /dev/null +++ b/cabal/templates/Paths_pkg.template.hs @@ -0,0 +1,185 @@ +{% if supportsCpp %} +{-# LANGUAGE CPP #-} +{% endif %} +{% if supportsNoRebindableSyntax %} +{-# LANGUAGE NoRebindableSyntax #-} +{% endif %} +{% if not absolute %} +{-# LANGUAGE ForeignFunctionInterface #-} +{% endif %} +{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} +{-# OPTIONS_GHC -w #-} +module Paths_{{ manglePkgName packageName }} ( + version, + getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, + getDataFileName, getSysconfDir + ) where + +{% if not absolute %} +import Foreign +import Foreign.C +{% endif %} + +import qualified Control.Exception as Exception +import qualified Data.List as List +import Data.Version (Version(..)) +import System.Environment (getEnv) +import Prelude + +{% if relocatable %} +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 %} + +version :: Version +version = Version {{ versionDigits }} [] + +getDataFileName :: FilePath -> IO FilePath +getDataFileName name = do + dir <- getDataDir + return (dir `joinFileName` name) + +getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath + +{# body #} +{# ######################################################################### #} + +{% if relocatable %} + +getPrefixDirReloc :: FilePath -> IO FilePath +getPrefixDirReloc dirRel = do + exePath <- getExecutablePath + let (dir,_) = splitFileName exePath + return ((dir `minusFileName` {{ bindir }}) `joinFileName` dirRel) + +getBinDir = catchIO (getEnv "{{ manglePkgName packageName }}_bindir") (\_ -> getPrefixDirReloc $ {{ bindir }}) +getLibDir = catchIO (getEnv "{{ manglePkgName packageName }}_libdir") (\_ -> getPrefixDirReloc $ {{ libdir }}) +getDynLibDir = catchIO (getEnv "{{ manglePkgName packageName }}_dynlibdir") (\_ -> getPrefixDirReloc $ {{ dynlibdir }}) +getDataDir = catchIO (getEnv "{{ manglePkgName packageName }}_datadir") (\_ -> getPrefixDirReloc $ {{ datadir }}) +getLibexecDir = catchIO (getEnv "{{ manglePkgName packageName }}_libexecdir") (\_ -> getPrefixDirReloc $ {{ libexecdir }}) +getSysconfDir = catchIO (getEnv "{{ manglePkgName packageName }}_sysconfdir") (\_ -> getPrefixDirReloc $ {{ sysconfdir }}) + +{% elif absolute %} + +bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath +bindir = {{ bindir }} +libdir = {{ libdir }} +dynlibdir = {{ dynlibdir }} +datadir = {{ datadir }} +libexecdir = {{ libexecdir }} +sysconfdir = {{ sysconfdir }} + +getBinDir = catchIO (getEnv "{{ manglePkgName packageName }}_bindir") (\_ -> return bindir) +getLibDir = catchIO (getEnv "{{ manglePkgName packageName }}_libdir") (\_ -> return libdir) +getDynLibDir = catchIO (getEnv "{{ manglePkgName packageName }}_dynlibdir") (\_ -> return dynlibdir) +getDataDir = catchIO (getEnv "{{ manglePkgName packageName }}_datadir") (\_ -> return datadir) +getLibexecDir = catchIO (getEnv "{{ manglePkgName packageName }}_libexecdir") (\_ -> return libexecdir) +getSysconfDir = catchIO (getEnv "{{ manglePkgName packageName }}_sysconfdir") (\_ -> return sysconfdir) + +{% elif isWindows %} + +prefix :: FilePath +prefix = {{ prefix }} + +getBinDir = getPrefixDirRel $ {{ bindir }} +getLibDir = {{ libdir }} +getDynLibDir = {{ dynlibdir }} +getDataDir = catchIO (getEnv "{{ manglePkgName packageName }}_datadir") (\_ -> {{ datadir }}) +getLibexecDir = {{ libexecdir }} +getSysconfDir = {{ sysconfdir }} + +getPrefixDirRel :: FilePath -> IO FilePath +getPrefixDirRel dirRel = try_size 2048 -- plenty, PATH_MAX is 512 under Win32. + where + try_size size = allocaArray (fromIntegral size) $ \buf -> do + ret <- c_GetModuleFileName nullPtr buf size + case ret of + 0 -> return (prefix `joinFileName` dirRel) + _ | ret < size -> do + exePath <- peekCWString buf + let (bindir,_) = splitFileName exePath + return ((bindir `minusFileName` {{ bindir}}) `joinFileName` dirRel) + | otherwise -> try_size (size * 2) + +{% if isI386 %} +foreign import stdcall unsafe "windows.h GetModuleFileNameW" + c_GetModuleFileName :: Ptr () -> CWString -> Int32 -> IO Int32 +{% elif isX8664 %} +foreign import ccall unsafe "windows.h GetModuleFileNameW" + c_GetModuleFileName :: Ptr () -> CWString -> Int32 -> IO Int32 +{% else %} +-- win32 supported only with I386, X86_64 +c_GetModuleFileName :: Ptr () -> CWString -> Int32 -> IO Int32 +c_GetModuleFileName = _ +{% endif %} + +{% else %} + +notRelocAbsoluteOrWindows :: () +notRelocAbsoluteOrWindows = _ + +{% endif %} + +{# filename stuff #} +{# ######################################################################### #} + +{% if not absolute %} +minusFileName :: FilePath -> String -> FilePath +minusFileName dir "" = dir +minusFileName dir "." = dir +minusFileName dir suffix = + minusFileName (fst (splitFileName dir)) (fst (splitFileName suffix)) + +splitFileName :: FilePath -> (String, String) +splitFileName p = (reverse (path2++drive), reverse fname) + where + (path,drive) = case p of + (c:':':p') -> (reverse p',[':',c]) + _ -> (reverse p ,"") + (fname,path1) = break isPathSeparator path + path2 = case path1 of + [] -> "." + [_] -> path1 -- don't remove the trailing slash if + -- there is only one character + (c:path') | isPathSeparator c -> path' + _ -> path1 +{% endif %} + +joinFileName :: String -> String -> FilePath +joinFileName "" fname = fname +joinFileName "." fname = fname +joinFileName dir "" = dir +joinFileName dir fname + | isPathSeparator (List.last dir) = dir ++ fname + | otherwise = dir ++ pathSeparator : fname + +pathSeparator :: Char +{% if isWindows %} +pathSeparator = '\\' +{% else %} +pathSeparator = '/' +{% endif %} + +isPathSeparator :: Char -> Bool +{% if isWindows %} +isPathSeparator c = c == '/' || c == '\\' +{% else %} +isPathSeparator c = c == '/' +{% endif %} diff --git a/cabal/templates/SPDX.LicenseExceptionId.template.hs b/cabal/templates/SPDX.LicenseExceptionId.template.hs new file mode 100644 --- /dev/null +++ b/cabal/templates/SPDX.LicenseExceptionId.template.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +module Distribution.SPDX.LicenseExceptionId ( + LicenseExceptionId (..), + licenseExceptionId, + licenseExceptionName, + mkLicenseExceptionId, + licenseExceptionIdList, + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Compat.Lens (set) +import Distribution.Pretty +import Distribution.Parsec +import Distribution.Utils.Generic (isAsciiAlphaNum) +import Distribution.Utils.Structured (Structured (..), nominalStructure, typeVersion) +import Distribution.SPDX.LicenseListVersion + +import qualified Data.Binary.Get as Binary +import qualified Data.Binary.Put as Binary +import qualified Data.Map.Strict as Map +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as Disp + +------------------------------------------------------------------------------- +-- LicenseExceptionId +------------------------------------------------------------------------------- + +-- | SPDX License Exceptions identifiers list v3.16 +data LicenseExceptionId +{{ licenseIds }} + deriving (Eq, Ord, Enum, Bounded, Show, Read, Typeable, Data, Generic) + +instance Binary LicenseExceptionId where + put = Binary.putWord8 . fromIntegral . fromEnum + get = do + i <- Binary.getWord8 + if i > fromIntegral (fromEnum (maxBound :: LicenseExceptionId)) + then fail "Too large LicenseExceptionId tag" + else return (toEnum (fromIntegral i)) + +-- note: remember to bump version each time the definition changes +instance Structured LicenseExceptionId where + structure p = set typeVersion 306 $ nominalStructure p + +instance Pretty LicenseExceptionId where + pretty = Disp.text . licenseExceptionId + +instance Parsec LicenseExceptionId where + parsec = do + n <- some $ P.satisfy $ \c -> isAsciiAlphaNum c || c == '-' || c == '.' + v <- askCabalSpecVersion + maybe (fail $ "Unknown SPDX license exception identifier: " ++ n) return $ + mkLicenseExceptionId (cabalSpecVersionToSPDXListVersion v) n + +instance NFData LicenseExceptionId where + rnf l = l `seq` () + +------------------------------------------------------------------------------- +-- License Data +------------------------------------------------------------------------------- + +-- | License SPDX identifier, e.g. @"BSD-3-Clause"@. +licenseExceptionId :: LicenseExceptionId -> String +{% for l in licenses %} +licenseExceptionId {{l.constructor}} = {{l.id}} +{% endfor %} + +-- | License name, e.g. @"GNU General Public License v2.0 only"@ +licenseExceptionName :: LicenseExceptionId -> String +{% for l in licenses %} +licenseExceptionName {{l.constructor}} = {{l.name}} +{% endfor %} + +------------------------------------------------------------------------------- +-- Creation +------------------------------------------------------------------------------- + +licenseExceptionIdList :: LicenseListVersion -> [LicenseExceptionId] +licenseExceptionIdList LicenseListVersion_3_0 = +{{licenseList_perv.v_3_0}} + ++ bulkOfLicenses +licenseExceptionIdList LicenseListVersion_3_2 = +{{licenseList_perv.v_3_2}} + ++ bulkOfLicenses +licenseExceptionIdList LicenseListVersion_3_6 = +{{licenseList_perv.v_3_6}} + ++ bulkOfLicenses +licenseExceptionIdList LicenseListVersion_3_9 = +{{licenseList_perv.v_3_9}} + ++ bulkOfLicenses +licenseExceptionIdList LicenseListVersion_3_10 = +{{licenseList_perv.v_3_10}} + ++ bulkOfLicenses +licenseExceptionIdList LicenseListVersion_3_16 = +{{licenseList_perv.v_3_16}} + ++ bulkOfLicenses + +-- | Create a 'LicenseExceptionId' from a 'String'. +mkLicenseExceptionId :: LicenseListVersion -> String -> Maybe LicenseExceptionId +mkLicenseExceptionId LicenseListVersion_3_0 s = Map.lookup s stringLookup_3_0 +mkLicenseExceptionId LicenseListVersion_3_2 s = Map.lookup s stringLookup_3_2 +mkLicenseExceptionId LicenseListVersion_3_6 s = Map.lookup s stringLookup_3_6 +mkLicenseExceptionId LicenseListVersion_3_9 s = Map.lookup s stringLookup_3_9 +mkLicenseExceptionId LicenseListVersion_3_10 s = Map.lookup s stringLookup_3_10 +mkLicenseExceptionId LicenseListVersion_3_16 s = Map.lookup s stringLookup_3_16 + +stringLookup_3_0 :: Map String LicenseExceptionId +stringLookup_3_0 = Map.fromList $ map (\i -> (licenseExceptionId i, i)) $ + licenseExceptionIdList LicenseListVersion_3_0 + +stringLookup_3_2 :: Map String LicenseExceptionId +stringLookup_3_2 = Map.fromList $ map (\i -> (licenseExceptionId i, i)) $ + licenseExceptionIdList LicenseListVersion_3_2 + +stringLookup_3_6 :: Map String LicenseExceptionId +stringLookup_3_6 = Map.fromList $ map (\i -> (licenseExceptionId i, i)) $ + licenseExceptionIdList LicenseListVersion_3_6 + +stringLookup_3_9 :: Map String LicenseExceptionId +stringLookup_3_9 = Map.fromList $ map (\i -> (licenseExceptionId i, i)) $ + licenseExceptionIdList LicenseListVersion_3_9 + +stringLookup_3_10 :: Map String LicenseExceptionId +stringLookup_3_10 = Map.fromList $ map (\i -> (licenseExceptionId i, i)) $ + licenseExceptionIdList LicenseListVersion_3_10 + +stringLookup_3_16 :: Map String LicenseExceptionId +stringLookup_3_16 = Map.fromList $ map (\i -> (licenseExceptionId i, i)) $ + licenseExceptionIdList LicenseListVersion_3_16 + +-- | License exceptions in all SPDX License lists +bulkOfLicenses :: [LicenseExceptionId] +bulkOfLicenses = +{{licenseList_all}} diff --git a/cabal/templates/SPDX.LicenseId.template.hs b/cabal/templates/SPDX.LicenseId.template.hs new file mode 100644 --- /dev/null +++ b/cabal/templates/SPDX.LicenseId.template.hs @@ -0,0 +1,214 @@ +{-# LANGUAGE DeriveDataTypeable #-} +module Distribution.SPDX.LicenseId ( + LicenseId (..), + licenseId, + licenseName, + licenseIsOsiApproved, + licenseIsFsfLibre, + mkLicenseId, + licenseIdList, + -- * Helpers + licenseIdMigrationMessage, + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Compat.Lens (set) +import Distribution.Pretty +import Distribution.Parsec +import Distribution.Utils.Generic (isAsciiAlphaNum) +import Distribution.Utils.Structured (Structured (..), nominalStructure, typeVersion) +import Distribution.SPDX.LicenseListVersion + +import qualified Data.Binary.Get as Binary +import qualified Data.Binary.Put as Binary +import qualified Data.Map.Strict as Map +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as Disp + +------------------------------------------------------------------------------- +-- LicenseId +------------------------------------------------------------------------------- + +-- | SPDX License identifiers list v3.16 +data LicenseId +{{ licenseIds }} + deriving (Eq, Ord, Enum, Bounded, Show, Read, Typeable, Data) + +instance Binary LicenseId where + -- Word16 is encoded in big endianess + -- https://github.com/kolmodin/binary/blob/master/src/Data/Binary/Class.hs#L220-LL227 + put = Binary.putWord16be . fromIntegral . fromEnum + get = do + i <- Binary.getWord16be + if i > fromIntegral (fromEnum (maxBound :: LicenseId)) + then fail "Too large LicenseId tag" + else return (toEnum (fromIntegral i)) + +-- note: remember to bump version each time the definition changes +instance Structured LicenseId where + structure p = set typeVersion 306 $ nominalStructure p + +instance Pretty LicenseId where + pretty = Disp.text . licenseId + +-- | +-- >>> eitherParsec "BSD-3-Clause" :: Either String LicenseId +-- Right BSD_3_Clause +-- +-- >>> eitherParsec "BSD3" :: Either String LicenseId +-- Left "...Unknown SPDX license identifier: 'BSD3' Do you mean BSD-3-Clause?" +-- +instance Parsec LicenseId where + parsec = do + n <- some $ P.satisfy $ \c -> isAsciiAlphaNum c || c == '-' || c == '.' + v <- askCabalSpecVersion + maybe (fail $ "Unknown SPDX license identifier: '" ++ n ++ "' " ++ licenseIdMigrationMessage n) return $ + mkLicenseId (cabalSpecVersionToSPDXListVersion v) n + +instance NFData LicenseId where + rnf l = l `seq` () + +-- | Help message for migrating from non-SPDX license identifiers. +-- +-- Old 'License' is almost SPDX, except for 'BSD2', 'BSD3'. This function +-- suggests SPDX variant: +-- +-- >>> licenseIdMigrationMessage "BSD3" +-- "Do you mean BSD-3-Clause?" +-- +-- Also 'OtherLicense', 'AllRightsReserved', and 'PublicDomain' aren't +-- valid SPDX identifiers +-- +-- >>> traverse_ (print . licenseIdMigrationMessage) [ "OtherLicense", "AllRightsReserved", "PublicDomain" ] +-- "SPDX license list contains plenty of licenses. See https://spdx.org/licenses/. Also they can be combined into complex expressions with AND and OR." +-- "You can use NONE as a value of license field." +-- "Public Domain is a complex matter. See https://wiki.spdx.org/view/Legal_Team/Decisions/Dealing_with_Public_Domain_within_SPDX_Files. Consider using a proper license." +-- +-- SPDX License list version 3.0 introduced "-only" and "-or-later" variants for GNU family of licenses. +-- See +-- >>> licenseIdMigrationMessage "GPL-2.0" +-- "SPDX license list 3.0 deprecated suffixless variants of GNU family of licenses. Use GPL-2.0-only or GPL-2.0-or-later." +-- +-- For other common licenses their old license format coincides with the SPDX identifiers: +-- +-- >>> traverse eitherParsec ["GPL-2.0-only", "GPL-3.0-only", "LGPL-2.1-only", "MIT", "ISC", "MPL-2.0", "Apache-2.0"] :: Either String [LicenseId] +-- Right [GPL_2_0_only,GPL_3_0_only,LGPL_2_1_only,MIT,ISC,MPL_2_0,Apache_2_0] +-- +licenseIdMigrationMessage :: String -> String +licenseIdMigrationMessage = go where + go l | gnuVariant l = "SPDX license list 3.0 deprecated suffixless variants of GNU family of licenses. Use " ++ l ++ "-only or " ++ l ++ "-or-later." + go "BSD3" = "Do you mean BSD-3-Clause?" + go "BSD2" = "Do you mean BSD-2-Clause?" + go "AllRightsReserved" = "You can use NONE as a value of license field." + go "OtherLicense" = "SPDX license list contains plenty of licenses. See https://spdx.org/licenses/. Also they can be combined into complex expressions with AND and OR." + go "PublicDomain" = "Public Domain is a complex matter. See https://wiki.spdx.org/view/Legal_Team/Decisions/Dealing_with_Public_Domain_within_SPDX_Files. Consider using a proper license." + + -- otherwise, we don't know + go _ = "" + + gnuVariant = flip elem ["GPL-2.0", "GPL-3.0", "LGPL-2.1", "LGPL-3.0", "AGPL-3.0" ] + +------------------------------------------------------------------------------- +-- License Data +------------------------------------------------------------------------------- + +-- | License SPDX identifier, e.g. @"BSD-3-Clause"@. +licenseId :: LicenseId -> String +{% for l in licenses %} +licenseId {{l.constructor}} = {{l.id}} +{% endfor %} + +-- | License name, e.g. @"GNU General Public License v2.0 only"@ +licenseName :: LicenseId -> String +{% for l in licenses %} +licenseName {{l.constructor}} = {{l.name}} +{% endfor %} + +-- | Whether the license is approved by Open Source Initiative (OSI). +-- +-- See . +licenseIsOsiApproved :: LicenseId -> Bool +{% for l in licenses %} +{% if l.isOsiApproved %} +licenseIsOsiApproved {{l.constructor}} = True +{% endif %} +{% endfor %} +licenseIsOsiApproved _ = False + +-- | Whether the license is considered libre by Free Software Foundation (FSF). +-- +-- See +-- +-- @since 3.4.0.0 +-- +licenseIsFsfLibre :: LicenseId -> Bool +{% for l in licenses %} +{% if l.isFsfLibre %} +licenseIsFsfLibre {{l.constructor}} = True +{% endif %} +{% endfor %} +licenseIsFsfLibre _ = False + +------------------------------------------------------------------------------- +-- Creation +------------------------------------------------------------------------------- + +licenseIdList :: LicenseListVersion -> [LicenseId] +licenseIdList LicenseListVersion_3_0 = +{{licenseList_perv.v_3_0}} + ++ bulkOfLicenses +licenseIdList LicenseListVersion_3_2 = +{{licenseList_perv.v_3_2}} + ++ bulkOfLicenses +licenseIdList LicenseListVersion_3_6 = +{{licenseList_perv.v_3_6}} + ++ bulkOfLicenses +licenseIdList LicenseListVersion_3_9 = +{{licenseList_perv.v_3_9}} + ++ bulkOfLicenses +licenseIdList LicenseListVersion_3_10 = +{{licenseList_perv.v_3_10}} + ++ bulkOfLicenses +licenseIdList LicenseListVersion_3_16 = +{{licenseList_perv.v_3_16}} + ++ bulkOfLicenses + +-- | Create a 'LicenseId' from a 'String'. +mkLicenseId :: LicenseListVersion -> String -> Maybe LicenseId +mkLicenseId LicenseListVersion_3_0 s = Map.lookup s stringLookup_3_0 +mkLicenseId LicenseListVersion_3_2 s = Map.lookup s stringLookup_3_2 +mkLicenseId LicenseListVersion_3_6 s = Map.lookup s stringLookup_3_6 +mkLicenseId LicenseListVersion_3_9 s = Map.lookup s stringLookup_3_9 +mkLicenseId LicenseListVersion_3_10 s = Map.lookup s stringLookup_3_10 +mkLicenseId LicenseListVersion_3_16 s = Map.lookup s stringLookup_3_16 + +stringLookup_3_0 :: Map String LicenseId +stringLookup_3_0 = Map.fromList $ map (\i -> (licenseId i, i)) $ + licenseIdList LicenseListVersion_3_0 + +stringLookup_3_2 :: Map String LicenseId +stringLookup_3_2 = Map.fromList $ map (\i -> (licenseId i, i)) $ + licenseIdList LicenseListVersion_3_2 + +stringLookup_3_6 :: Map String LicenseId +stringLookup_3_6 = Map.fromList $ map (\i -> (licenseId i, i)) $ + licenseIdList LicenseListVersion_3_6 + +stringLookup_3_9 :: Map String LicenseId +stringLookup_3_9 = Map.fromList $ map (\i -> (licenseId i, i)) $ + licenseIdList LicenseListVersion_3_9 + +stringLookup_3_10 :: Map String LicenseId +stringLookup_3_10 = Map.fromList $ map (\i -> (licenseId i, i)) $ + licenseIdList LicenseListVersion_3_10 + +stringLookup_3_16 :: Map String LicenseId +stringLookup_3_16 = Map.fromList $ map (\i -> (licenseId i, i)) $ + licenseIdList LicenseListVersion_3_16 + +-- | Licenses in all SPDX License lists +bulkOfLicenses :: [LicenseId] +bulkOfLicenses = +{{licenseList_all}} diff --git a/cabal/templates/cabal_macros.template.h b/cabal/templates/cabal_macros.template.h new file mode 100644 --- /dev/null +++ b/cabal/templates/cabal_macros.template.h @@ -0,0 +1,41 @@ +/* DO NOT EDIT: This file is automatically generated by Cabal */ + +{% for pkg in packages %} +/* package {{ pkg.name }}-{{ pkg.version }} */ +#ifndef VERSION_{{ manglePkgName pkg.name }} +#define VERSION_{{ manglePkgName pkg.name }} "{{ pkg.version }}" +#endif /* VERSION_{{ manglePkgName pkg.name }} */ +#ifndef MIN_VERSION_{{ manglePkgName pkg.name }} +#define MIN_VERSION_{{ manglePkgName pkg.name }}(major1,major2,minor) (\ + (major1) < {{ pkg.x }} || \ + (major1) == {{ pkg.x }} && (major2) < {{ pkg.y }} || \ + (major1) == {{ pkg.x }} && (major2) == {{ pkg.y }} && (minor) <= {{ pkg.z }}) +#endif /* MIN_VERSION_{{ manglePkgName pkg.name }} */ +{% endfor %} + +{% for tool in tools %} +/* tool {{ tool.name }}-{{ tool.version }} */ +#ifndef TOOL_VERSION_{{ mangleStr tool.name }} +#define TOOL_VERSION_{{ mangleStr tool.name }} "{{ tool.version }}" +#endif /* TOOL_VERSION_{{ mangleStr tool.name }} */ +#ifndef MIN_TOOL_VERSION_{{ mangleStr tool.name }} +#define MIN_TOOL_VERSION_{{ mangleStr tool.name }}(major1,major2,minor) (\ + (major1) < {{ tool.x }} || \ + (major1) == {{ tool.x }} && (major2) < {{ tool.y }} || \ + (major1) == {{ tool.x }} && (major2) == {{ tool.y }} && (minor) <= {{ tool.z }}) +#endif /* MIN_TOOL_VERSION_{{ mangleStr tool.name }} */ +{% endfor %} + +{% if notNull packageKey %} +#ifndef CURRENT_PACKAGE_KEY +#define CURRENT_PACKAGE_KEY "{{ packageKey }}" +#endif /* CURRENT_packageKey */ +{% endif %} +{% if notNull componentId %} +#ifndef CURRENT_COMPONENT_ID +#define CURRENT_COMPONENT_ID "{{ componentId }}" +#endif /* CURRENT_COMPONENT_ID */ +{% endif %} +#ifndef CURRENT_PACKAGE_VERSION +#define CURRENT_PACKAGE_VERSION "{{ packageVersion }}" +#endif /* CURRENT_PACKAGE_VERSION */ diff --git a/cabal/tests/UnitTests/Distribution/Client/Init/goldens/generateCabalFile/exe-only.cabal b/cabal/tests/UnitTests/Distribution/Client/Init/goldens/generateCabalFile/exe-only.cabal deleted file mode 100644 --- a/cabal/tests/UnitTests/Distribution/Client/Init/goldens/generateCabalFile/exe-only.cabal +++ /dev/null @@ -1,16 +0,0 @@ -cabal-version: 2.4 -name: foo -version: 3.2.1 -synopsis: The foo package -homepage: https://github.com/foo/foo -license: NONE -author: me -maintainer: me@me.me -category: SomeCat -extra-source-files: CHANGELOG.md - -executable foo - main-is: Main.hs - build-depends: base ^>=4.13.0.0, containers ^>=5.7.0.0, unordered-containers ^>=2.7.0.0 - hs-source-dirs: app - default-language: Haskell2010 diff --git a/cabal/tests/UnitTests/Distribution/Client/Init/goldens/generateCabalFile/lib-exe-and-test.cabal b/cabal/tests/UnitTests/Distribution/Client/Init/goldens/generateCabalFile/lib-exe-and-test.cabal deleted file mode 100644 --- a/cabal/tests/UnitTests/Distribution/Client/Init/goldens/generateCabalFile/lib-exe-and-test.cabal +++ /dev/null @@ -1,29 +0,0 @@ -cabal-version: 2.4 -name: foo -version: 3.2.1 -synopsis: The foo package -homepage: https://github.com/foo/foo -license: NONE -author: me -maintainer: me@me.me -category: SomeCat -extra-source-files: CHANGELOG.md - -library - exposed-modules: A, B - build-depends: base ^>=4.13.0.0, containers ^>=5.7.0.0, unordered-containers ^>=2.7.0.0 - hs-source-dirs: src - default-language: Haskell2010 - -executable foo - main-is: Main.hs - build-depends: base ^>=4.13.0.0, containers ^>=5.7.0.0, unordered-containers ^>=2.7.0.0 - hs-source-dirs: app - default-language: Haskell2010 - -test-suite foo-test - default-language: Haskell2010 - type: exitcode-stdio-1.0 - hs-source-dirs: tests - main-is: MyLibTest.hs - build-depends: base ^>=4.13.0.0, containers ^>=5.7.0.0, unordered-containers ^>=2.7.0.0 diff --git a/cabal/tests/fixtures/init/exe-only-golden.cabal b/cabal/tests/fixtures/init/exe-only-golden.cabal deleted file mode 100644 --- a/cabal/tests/fixtures/init/exe-only-golden.cabal +++ /dev/null @@ -1,20 +0,0 @@ -cabal-version: 2.4 -name: foo -version: 3.2.1 -synopsis: The foo package -homepage: https://github.com/foo/foo -license: NONE -author: me -maintainer: me@me.me -category: SomeCat -extra-source-files: CHANGELOG.md - -executable foo - main-is: Main.hs - build-depends: - base ^>=4.13.0.0, - containers ^>=5.7.0.0, - unordered-containers ^>=2.7.0.0 - - hs-source-dirs: app - default-language: Haskell2010 diff --git a/cabal/tests/fixtures/init/lib-and-exe-golden.cabal b/cabal/tests/fixtures/init/lib-and-exe-golden.cabal deleted file mode 100644 --- a/cabal/tests/fixtures/init/lib-and-exe-golden.cabal +++ /dev/null @@ -1,31 +0,0 @@ -cabal-version: 2.4 -name: foo -version: 3.2.1 -synopsis: The foo package -homepage: https://github.com/foo/foo -license: NONE -author: me -maintainer: me@me.me -category: SomeCat -extra-source-files: CHANGELOG.md - -library - exposed-modules: MyLib - build-depends: - base ^>=4.13.0.0, - containers ^>=5.7.0.0, - unordered-containers ^>=2.7.0.0 - - hs-source-dirs: src - default-language: Haskell2010 - -executable foo - main-is: Main.hs - build-depends: - base ^>=4.13.0.0, - containers ^>=5.7.0.0, - unordered-containers ^>=2.7.0.0, - foo - - hs-source-dirs: app - default-language: Haskell2010 diff --git a/cabal/tests/fixtures/init/lib-exe-and-test-golden.cabal b/cabal/tests/fixtures/init/lib-exe-and-test-golden.cabal deleted file mode 100644 --- a/cabal/tests/fixtures/init/lib-exe-and-test-golden.cabal +++ /dev/null @@ -1,43 +0,0 @@ -cabal-version: 2.4 -name: foo -version: 3.2.1 -synopsis: The foo package -homepage: https://github.com/foo/foo -license: NONE -author: me -maintainer: me@me.me -category: SomeCat -extra-source-files: CHANGELOG.md - -library - exposed-modules: - A - B - - build-depends: - base ^>=4.13.0.0, - containers ^>=5.7.0.0, - unordered-containers ^>=2.7.0.0 - - hs-source-dirs: src - default-language: Haskell2010 - -executable foo - main-is: Main.hs - build-depends: - base ^>=4.13.0.0, - containers ^>=5.7.0.0, - unordered-containers ^>=2.7.0.0 - - hs-source-dirs: app - default-language: Haskell2010 - -test-suite foo-test - default-language: Haskell2010 - type: exitcode-stdio-1.0 - hs-source-dirs: tests - main-is: MyLibTest.hs - build-depends: - base ^>=4.13.0.0, - containers ^>=5.7.0.0, - unordered-containers ^>=2.7.0.0 diff --git a/cabal/tests/fixtures/init/lib-exe-and-test-with-comments-golden.cabal b/cabal/tests/fixtures/init/lib-exe-and-test-with-comments-golden.cabal deleted file mode 100644 --- a/cabal/tests/fixtures/init/lib-exe-and-test-with-comments-golden.cabal +++ /dev/null @@ -1,110 +0,0 @@ -cabal-version: 2.4 - --- Initial package description 'lib-exe-and-test-with-comments-golden.cabal' generated by --- 'cabal init'. For further documentation, see: --- http://haskell.org/cabal/users-guide/ --- --- The name of the package. -name: foo - --- The package version. --- See the Haskell package versioning policy (PVP) for standards --- guiding when and how versions should be incremented. --- https://pvp.haskell.org --- PVP summary: +-+------- breaking API changes --- | | +----- non-breaking API additions --- | | | +--- code changes with no API change -version: 3.2.1 - --- A short (one-line) description of the package. -synopsis: The foo package - --- A longer description of the package. --- description: - --- URL for the project homepage or repository. -homepage: https://github.com/foo/foo - --- A URL where users can report bugs. --- bug-reports: - --- The license under which the package is released. -license: NONE - --- The package author(s). -author: me - --- An email address to which users can send suggestions, bug reports, and patches. -maintainer: me@me.me - --- A copyright notice. --- copyright: -category: SomeCat - --- Extra files to be distributed with the package, such as examples or a README. -extra-source-files: CHANGELOG.md - -library - -- Modules exported by the library. - exposed-modules: - A - B - - -- Modules included in this library but not exported. - -- other-modules: - - -- LANGUAGE extensions used by modules in this package. - -- other-extensions: - - -- Other library packages from which modules are imported. - build-depends: - base ^>=4.13.0.0, - containers ^>=5.7.0.0, - unordered-containers ^>=2.7.0.0 - - -- Directories containing source files. - hs-source-dirs: src - - -- Base language which the package is written in. - default-language: Haskell2010 - -executable foo - -- .hs or .lhs file containing the Main module. - main-is: Main.hs - - -- Modules included in this executable, other than Main. - -- other-modules: - - -- LANGUAGE extensions used by modules in this package. - -- other-extensions: - - -- Other library packages from which modules are imported. - build-depends: - base ^>=4.13.0.0, - containers ^>=5.7.0.0, - unordered-containers ^>=2.7.0.0 - - -- Directories containing source files. - hs-source-dirs: app - - -- Base language which the package is written in. - default-language: Haskell2010 - -test-suite foo-test - -- Base language which the package is written in. - default-language: Haskell2010 - - -- The interface type and version of the test suite. - type: exitcode-stdio-1.0 - - -- Directories containing source files. - hs-source-dirs: tests - - -- The entrypoint to the test suite. - main-is: MyLibTest.hs - - -- Test dependencies. - build-depends: - base ^>=4.13.0.0, - containers ^>=5.7.0.0, - unordered-containers ^>=2.7.0.0 diff --git a/cabal/travis-bootstrap.sh b/cabal/travis-bootstrap.sh deleted file mode 100644 --- a/cabal/travis-bootstrap.sh +++ /dev/null @@ -1,57 +0,0 @@ -#!/bin/sh - -. ./travis-common.sh - -# --------------------------------------------------------------------- -# Bootstrap cabal, to verify bootstrap.sh script works. -# --------------------------------------------------------------------- - -bootstrap_jobs="-j" - -(cd cabal-install && timed env EXTRA_CONFIGURE_OPTS="" ./bootstrap.sh $bootstrap_jobs --no-doc) -timed $HOME/.cabal/bin/cabal --version -PATH=$HOME/.cabal/bin:$PATH - -# --------------------------------------------------------------------- -# Verify that installation from tarball works. -# --------------------------------------------------------------------- - -# The following scriptlet checks that the resulting source distribution can be -# built & installed. -install_from_tarball() { - SRC_NAME=$(cabal info . | awk '{print $2;exit}') ; - SRC_TGZ="$SRC_NAME.tar.gz" - SRC_PATH="$TRAVIS_BUILD_DIR/dist-newstyle/sdist/$SRC_TGZ" - export SRC_TGZ - if [ -f "$SRC_PATH" ]; then - tar xzf $SRC_PATH -C /tmp; - cd /tmp/$SRC_NAME; - cabal build --force-reinstalls $jobs all -v2; - else - echo "expected '$TRAVIS_BUILD_DIR/dist-newstyle/sdist/$SRC_TGZ' not found"; - exit 1; - fi -} - -timed cabal update - -# NB: The cabal cleans here hack around an sdist bug where -# the bootstrapped Cabal/cabal-install may be built -# without a Paths_* module available. Under some situations -# which I have not been able to reproduce except on Travis, -# cabal sdist will incorrectly pick up the left over dist -# directory from the bootstrap and then try to package -# up the Paths module, but to no avail because it is not -# available. I ran out of patience trying to debug this -# issue, and it is easy enough to work around: clean first. - -echo Cabal -(cd Cabal && timed cabal clean) || exit $? -(cd Cabal && timed cabal sdist) || exit $? -(cd Cabal && timed install_from_tarball) || exit $? - -echo cabal-install -(cd cabal-install && timed cabal clean) || exit $? -(cd cabal-install && timed cabal sdist) || exit $? -# I don't know how to fix this exactly right now. -#(cd cabal-install && timed install_from_tarball) || exit $? diff --git a/cabal/travis-common.sh b/cabal/travis-common.sh deleted file mode 100644 --- a/cabal/travis-common.sh +++ /dev/null @@ -1,53 +0,0 @@ -set -e - -CABAL_VERSION="3.3.0.0" -CABAL_INSTALL_VERSION="3.3.0.0" - -if [ "$TRAVIS_OS_NAME" = "linux" ]; then - ARCH="x86_64-linux" -else - ARCH="x86_64-osx" -fi - -CABAL_STORE_DB="${HOME}/.cabal/store/ghc-${GHCVER}/package.db" -CABAL_LOCAL_DB="${TRAVIS_BUILD_DIR}/dist-newstyle/packagedb/ghc-${GHCVER}" -CABAL_BDIR="${TRAVIS_BUILD_DIR}/dist-newstyle/build/$ARCH/ghc-$GHCVER/Cabal-${CABAL_VERSION}" -CABAL_TESTSUITE_BDIR="${TRAVIS_BUILD_DIR}/dist-newstyle/build/$ARCH/ghc-$GHCVER/cabal-testsuite-3" -CABAL_INSTALL_BDIR="${TRAVIS_BUILD_DIR}/dist-newstyle/build/$ARCH/ghc-$GHCVER/cabal-install-${CABAL_INSTALL_VERSION}" -SOLVER_BENCHMARKS_BDIR="${TRAVIS_BUILD_DIR}/dist-newstyle/build/$ARCH/ghc-$GHCVER/solver-benchmarks-3" -CABAL_INSTALL_EXE=${CABAL_INSTALL_BDIR}/x/cabal/build/cabal/cabal - -# --------------------------------------------------------------------- -# Timing / diagnostic output -# --------------------------------------------------------------------- - -JOB_START_TIME=$(date +%s) - -timed() { - echo "\$ $*" - start_time=$(date +%s) - - # Run the job - $* || exit $? - - # Calculate the durations - end_time=$(date +%s) - duration=$((end_time - start_time)) - total_duration=$((end_time - JOB_START_TIME)) - - # Print them - echo "$* took $duration seconds." - echo "whole job took $total_duration seconds so far." - - # Terminate if the job is taking too long (we must do this to - # preserve the populated cache for the next run). - if [ $total_duration -ge 2400 ]; then - echo "Job taking over 38 minutes. Terminating" - exit 1 - fi - echo "----" -} - -travis_retry () { - $* || (sleep 1 && $*) || (sleep 2 && $*) -} diff --git a/cabal/travis-deploy.sh b/cabal/travis-deploy.sh deleted file mode 100644 --- a/cabal/travis-deploy.sh +++ /dev/null @@ -1,27 +0,0 @@ -#!/bin/sh -set -ex - -deploy() { - git config --global user.email "builds@travis-ci.org" - git config --global user.name "Travis CI User" - git clone https://github.com/haskell/cabal-website.git cabal-website - (cd cabal-website && git checkout --track -b gh-pages origin/gh-pages) - rm -rf cabal-website/doc - mkdir -p cabal-website/doc/html - mv dist-newstyle/build/`uname -m`-$TRAVIS_OS_NAME/ghc-$GHCVER/Cabal-3.3.0.0/doc/html/Cabal \ - cabal-website/doc/html/Cabal - (cd cabal-website && git add --all .) - (cd cabal-website && \ - git commit --amend --reset-author -m "Deploy to GitHub ($(date)).") - (cd cabal-website && \ - git push --force git@github.com:haskell/cabal-website.git \ - gh-pages:gh-pages) -} - -if [ "x$TRAVIS_REPO_SLUG" = "xhaskell/cabal" \ - -a "x$TRAVIS_PULL_REQUEST" = "xfalse" \ - -a "x$TRAVIS_BRANCH" = "xmaster" \ - -a "x$DEPLOY_DOCS" = "xYES" ] -then - deploy -fi diff --git a/cabal/travis-install.sh b/cabal/travis-install.sh deleted file mode 100644 --- a/cabal/travis-install.sh +++ /dev/null @@ -1,88 +0,0 @@ -#!/bin/sh -set -ex - -. ./travis-common.sh - -if [ "$GHCVER" = "none" ]; then - travis_retry sudo add-apt-repository -y ppa:hvr/ghc - travis_retry sudo apt-get update - travis_retry sudo apt-get install --force-yes ghc-$GHCVER -fi - -if [ -z ${STACK_CONFIG+x} ]; then - if [ "$TRAVIS_OS_NAME" = "linux" ]; then - travis_retry sudo add-apt-repository -y ppa:hvr/ghc - travis_retry sudo apt-get update - travis_retry sudo apt-get install --force-yes cabal-install-3.0 ghc-$GHCVER-prof ghc-$GHCVER-dyn - if [ "x$TEST_OTHER_VERSIONS" = "xYES" ]; then travis_retry sudo apt-get install --force-yes ghc-7.0.4-prof ghc-7.0.4-dyn ghc-7.2.2-prof ghc-7.2.2-dyn ghc-head-prof ghc-head-dyn; fi - - if [ "$SCRIPT" = "meta" ]; then - # change to /tmp so cabal.project doesn't affect new-install - cabal v2-update - (cd /tmp && cabal v2-install alex --constraint='alex ^>= 3.2.5' --overwrite=always) - (cd /tmp && cabal v2-install happy --constraint='happy ^>= 1.19.9' --overwrite=always) - fi - - elif [ "$TRAVIS_OS_NAME" = "osx" ]; then - - case $GHCVER in - 8.0.2) - GHCURL=http://downloads.haskell.org/~ghc/8.0.2/ghc-8.0.2-x86_64-apple-darwin.tar.xz; - GHCXZ=YES - ;; - 8.0.1) - GHCURL=http://downloads.haskell.org/~ghc/8.0.1/ghc-8.0.1-x86_64-apple-darwin.tar.xz; - GHCXZ=YES - ;; - 7.10.3) - GHCURL=http://downloads.haskell.org/~ghc/7.10.3/ghc-7.10.3b-x86_64-apple-darwin.tar.xz - GHCXZ=YES - ;; - 7.8.4) - GHCURL=https://www.haskell.org/ghc/dist/7.8.4/ghc-7.8.4-x86_64-apple-darwin.tar.xz - GHCXZ=YES - ;; - 7.6.3) - GHCURL=https://www.haskell.org/ghc/dist/7.6.3/ghc-7.6.3-x86_64-apple-darwin.tar.bz2 - ;; - 7.4.2) - GHCURL=https://www.haskell.org/ghc/dist/7.4.2/ghc-7.4.2-x86_64-apple-darwin.tar.bz2 - ;; - *) - echo "Unknown GHC: $GHCVER" - false - ;; - esac - - travis_retry curl -OL $GHCURL - if [ "$GHCXZ" = "YES" ]; then - tar -xJf ghc-*.tar.*; - else - tar -xjf ghc-*.tar.*; - fi - - cd ghc-*; - ./configure --prefix=$HOME/.ghc-install/$GHCVER - make install; - cd ..; - - mkdir "${HOME}/bin" - travis_retry curl -L https://downloads.haskell.org/~cabal/cabal-install-3.0.0.0/cabal-install-3.0.0.0-x86_64-apple-darwin17.7.0.tar.xz | tar xzO > "${HOME}/bin/cabal" - chmod a+x "${HOME}/bin/cabal" - "${HOME}/bin/cabal" --version - - else - echo "Not linux or osx: $TRAVIS_OS_NAME" - false - fi - -else # Stack-based builds - mkdir -p ~/.local/bin - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 \ - | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' - ~/.local/bin/stack --version - ~/.local/bin/stack setup --stack-yaml "$STACK_CONFIG" - -fi - -git version diff --git a/cabal/travis-meta.sh b/cabal/travis-meta.sh deleted file mode 100644 --- a/cabal/travis-meta.sh +++ /dev/null @@ -1,25 +0,0 @@ -#!/bin/sh - -. ./travis-common.sh - -# --------------------------------------------------------------------- -# Check that auto-generated files/fields are up to date. -# --------------------------------------------------------------------- - -# For some reason status might now be clean after checkout -git reset --hard -git status - -# Regenerate the CONTRIBUTORS file. -# Currently doesn't work because Travis uses --depth=50 when cloning. -#./Cabal/misc/gen-authors.sh > AUTHORS - -timed cabal update - -# Regenerate files -timed make lexer -timed make gen-extra-source-files -timed make spdx - -# Fail if the diff is not empty. -timed ./Cabal/misc/travis-diff-files.sh diff --git a/cabal/travis-script.sh b/cabal/travis-script.sh deleted file mode 100644 --- a/cabal/travis-script.sh +++ /dev/null @@ -1,197 +0,0 @@ -#!/bin/sh - -# ATTENTION! Before editing this file, maybe you can make a -# separate script to do your test? We don't want individual -# Travis builds to take too long (they time out at 50min and -# it's generally unpleasant if the build takes that long.) -# If you make a separate matrix entry in .travis.yml it can -# be run in parallel. - -# NB: the '|| exit $?' workaround is required on old broken versions of bash -# that ship with OS X. See https://github.com/haskell/cabal/pull/3624 and -# http://stackoverflow.com/questions/14970663/why-doesnt-bash-flag-e-exit-when-a-subshell-fails - -. ./travis-common.sh - -# --hide-successes uses terminal control characters which mess up -# Travis's log viewer. So just print them all! -TEST_OPTIONS="" - -# To be enabled temporarily when you need to pre-populate the Travis -# cache to avoid timeout. -#SKIP_TESTS=YES - -# --------------------------------------------------------------------- -# Parse options -# --------------------------------------------------------------------- - -usage() { - echo -e -n "Usage: `basename $0`\n-j jobs\n" -} - -jobs="-j1" -while getopts ":hj:" opt; do - case $opt in - h) - usage - exit 0 - ;; - j) - jobs="-j$OPTARG" - ;; - :) - # Argument-less -j - if [ "$OPTARG" = "j" ]; then - jobs="-j" - fi - ;; - \?) - echo "Invalid option: $OPTARG" - usage - exit 1 - ;; - esac -done -shift $((OPTIND-1)) - -# Do not try to use -j with GHC older than 7.8 -case $GHCVER in - 7.4*|7.6*) - jobs="" - ;; - *) - ;; -esac - -# --------------------------------------------------------------------- -# Update the Cabal index -# --------------------------------------------------------------------- - -timed cabal update - -# --------------------------------------------------------------------- -# Install executables if necessary -# --------------------------------------------------------------------- - -# TODO: we need v2-install -z -(cd /tmp && timed cabal v2-install $jobs happy --overwrite-policy=always) - -# --------------------------------------------------------------------- -# Setup our local project -# --------------------------------------------------------------------- - -make cabal-install-monolithic -if [ "x$CABAL_LIB_ONLY" = "xYES" ]; then - cp cabal.project.libonly cabal.project -fi -cp cabal.project.local.travis cabal.project.local - -# --------------------------------------------------------------------- -# Cabal -# --------------------------------------------------------------------- - -# Needed to work around some bugs in nix-local-build code. -export CABAL_BUILDDIR="${CABAL_BDIR}" - -if [ "x$CABAL_INSTALL_ONLY" != "xYES" ] ; then - # We're doing a full build and test of Cabal - - # NB: Best to do everything for a single package together as it's - # more efficient (since new-build will uselessly try to rebuild - # Cabal otherwise). - timed cabal new-build $jobs Cabal Cabal:unit-tests Cabal:check-tests Cabal:parser-tests Cabal:hackage-tests --enable-tests - - # Run haddock. - if [ "$TRAVIS_OS_NAME" = "linux" ]; then - # TODO: use new-haddock? - - # haddock: internal error: synifyKind - # https://github.com/haskell/haddock/issues/242 - if [ "$GHCVER" != "7.6.3" ]; then - (cd Cabal && timed cabal act-as-setup --build-type=Simple -- haddock --builddir=${CABAL_BDIR}) || exit $? - fi - fi - - # Check for package warnings - (cd Cabal && timed cabal check) || exit $? -fi - -unset CABAL_BUILDDIR - -# Build and run the package tests - -export CABAL_BUILDDIR="${CABAL_TESTSUITE_BDIR}" - -# NB: We always build this test runner, because it is used -# both by Cabal and cabal-install -timed cabal new-build $jobs cabal-testsuite:cabal-tests - -if [ "x$SKIP_TESTS" != "xYES" ]; then - (cd cabal-testsuite && timed ${CABAL_TESTSUITE_BDIR}/build/cabal-tests/cabal-tests --builddir=${CABAL_TESTSUITE_BDIR} -j3 $TEST_OPTIONS) || exit $? -fi - -# Redo the package tests with different versions of GHC -if [ "x$TEST_OTHER_VERSIONS" = "xYES" ]; then - (cd cabal-testsuite && timed ${CABAL_TESTSUITE_BDIR}/build/cabal-tests/cabal-tests --builddir=${CABAL_TESTSUITE_BDIR} $TEST_OPTIONS --with-ghc="/opt/ghc/7.0.4/bin/ghc") - (cd cabal-testsuite && timed ${CABAL_TESTSUITE_BDIR}/build/cabal-tests/cabal-tests --builddir=${CABAL_TESTSUITE_BDIR} $TEST_OPTIONS --with-ghc="/opt/ghc/7.2.2/bin/ghc") - (cd cabal-testsuite && timed ${CABAL_TESTSUITE_BDIR}/build/cabal-tests/cabal-tests --builddir=${CABAL_TESTSUITE_BDIR} $TEST_OPTIONS --with-ghc="/opt/ghc/head/bin/ghc") -fi - -unset CABAL_BUILDDIR - -if [ "x$CABAL_LIB_ONLY" = "xYES" ]; then - # If this fails, we WANT to fail, because the tests will not be running then - (timed ./travis/upload.sh) || exit $? - exit 0; -fi - -# --------------------------------------------------------------------- -# cabal-install -# --------------------------------------------------------------------- - -# Needed to work around some bugs in nix-local-build code. -export CABAL_BUILDDIR="${CABAL_INSTALL_BDIR}" - -if [ "x$DEBUG_EXPENSIVE_ASSERTIONS" = "xYES" ]; then - CABAL_INSTALL_FLAGS=-fdebug-expensive-assertions -fi - -# NB: For Travis, we do a *monolithic* build, which means all the -# test suites are baked into the cabal binary -timed cabal new-build $jobs $CABAL_INSTALL_FLAGS cabal-install:cabal - -# TODO: we need v2-install -z -(cd /tmp && timed cabal new-install $jobs hackage-repo-tool --overwrite-policy=always) - -if [ "x$SKIP_TESTS" = "xYES" ]; then - exit 1; -fi - -# Tests need this -timed ${CABAL_INSTALL_EXE} update - -# Big tests -(cd cabal-testsuite && timed ${CABAL_TESTSUITE_BDIR}/build/cabal-tests/cabal-tests --builddir=${CABAL_TESTSUITE_BDIR} -j3 --skip-setup-tests --with-cabal ${CABAL_INSTALL_EXE} --with-hackage-repo-tool hackage-repo-tool $TEST_OPTIONS) || exit $? - -# Cabal check -# TODO: remove -main-is and re-enable me. -# (cd cabal-install && timed cabal check) || exit $? - -if [ "x$TEST_SOLVER_BENCHMARKS" = "xYES" ]; then - timed cabal new-build $jobs solver-benchmarks:hackage-benchmark solver-benchmarks:unit-tests - timed ${SOLVER_BENCHMARKS_BDIR}/t/unit-tests/build/unit-tests/unit-tests $TEST_OPTIONS -fi - -# Haddock -# TODO: >= 8.4.3 would be nicer -if [ "$TRAVIS_OS_NAME" = "linux" -a "$GHCVER" == "8.4.4" ]; then - timed cabal new-haddock cabal-install -fi - -unset CABAL_BUILDDIR - -# Check what we got -${CABAL_INSTALL_EXE} --version - -# If this fails, we WANT to fail, because the tests will not be running then -(timed ./travis/upload.sh) || exit $? diff --git a/cabal/travis-solver-debug-flags.sh b/cabal/travis-solver-debug-flags.sh deleted file mode 100644 --- a/cabal/travis-solver-debug-flags.sh +++ /dev/null @@ -1,9 +0,0 @@ -#!/bin/sh - -# Build cabal with solver debug flags enabled. -# We need to skip the tests, because debug-tracetree prints the whole solver -# tree as JSON. - -cabal update -cabal install happy -cabal new-build exe:cabal --constraint "cabal-install +debug-tracetree +debug-conflict-sets" diff --git a/cabal/travis-stack.sh b/cabal/travis-stack.sh deleted file mode 100644 --- a/cabal/travis-stack.sh +++ /dev/null @@ -1,21 +0,0 @@ -#!/bin/sh - -if [ -z ${STACK_CONFIG+x} ]; then - echo "STACK_CONFIG environment variable not set." - echo "This build case is not configured correctly." - exit 1 -fi - -. ./travis-common.sh - -# --------------------------------------------------------------------- -# Build Cabal via Stack(age). -# --------------------------------------------------------------------- - -~/.local/bin/stack --version - -~/.local/bin/stack build \ - --no-terminal \ - --stack-yaml "$STACK_CONFIG" \ - --test \ - --bench --no-run-benchmarks diff --git a/cabal/travis/README.md b/cabal/travis/README.md deleted file mode 100644 --- a/cabal/travis/README.md +++ /dev/null @@ -1,84 +0,0 @@ -# Continuous integration on Travis - -This folder contains scripts for running CI on Travis. - -The most unusual thing about our Travis setup is that, after we finish -building our project, we upload the build products to Git (via the -haskell-pushbot account) to a separate repository to do testing. -There are two reasons we do this: - -1. On our slowest configuration (GHC 8 on Mac OS X), the time to - build and run tests was easily bumping up against the Travis time - limit. By uploading our build products to a separate account, - we get twice as much time to run our builds. - -2. Travis parallelism is limited on a per-account basis; if we - upload build products to another account, we get more parallelism! - (Travis, let us know if you don't like this :) - -Here is the general lifecycle of a Travis run: - -1. For each build matrix configuration, we run ../travis-script.sh - to build Cabal, cabal-install, and all of the test suites. - -2. Once the build is successful, we invoke upload.sh to upload - the build products to the cabal-binaries repository. This is done - using the ROT-13'ed private key id_rsa.rot13 (associated with - haskell-pushbot's account). This upload contains its own .travis.yml - (customized for the particular build matrix configuration), and some - special JSON metadata in the commit message. ROT-13 is used to - prevent GitHub from deciding the private key is compromised. - -3. Triggered by the push to cabal-binaries, Travis on haskell-pushbot - will run the tests. After this finishes, it will invoke a webhook - that invokes sake-bot (https://github.com/ezyang/sake-bot, currently - installed at https://sake-bot.herokuapp.com/) which will post - back the GitHub status result to the upstream Cabal repository. - -## Who maintains this setup - -Unfortunately, there are some infrastructural permissions which -don't coincide with the GitHub permissions for the Cabal project. -Here are the relevant bits: - -* The GitHub account haskell-pushbot is owned by @ezyang (along - with the associated Travis account.) - -* The Heroku instance https://sake-bot.herokuapp.com/ is maintained by @ezyang. - It has a private key for a GitHub integration on the Haskell - GitHub organization (which gives it permissions to update - statuses on the Cabal project). - -Fortunately, if @ezyang ever gets run over a bus, all of these -infrastructural bits can be reconfigured. Here is what you -would need to do: - -* Create a new GitHub account to replace haskell-pushbot - -* Generate a new private key, associate it with the GH account, and - replace id_rsa.rot13 and id_rsa.pub with the ROT-13'ed private - key and the public key. - -* Create a new binaries repository, modify the invocation of - "git remote add" in upload.sh to point to the new location. - Enable Travis for this repository. - -* Create a new Heroku instance of https://github.com/ezyang/sake-bot - (use the "Deploy with Heroku" button.) Follow the instructions - there; you'll need a private key for an integration associated - with the Haskell organization; talk to one of the admins there - to get the key. - -That's it! - -## Limitations - -If you push to your local account and run Travis, the builds will -still take place in the shared cabal-binaries Travis instance, and -you won't get status updates (because sake-bot doesn't have permissions -to update the status update on any repository besides its own.) -In principle, it should be possible for upload.sh to autodetect if you -have a cabal-binaries repository setup on your local account, and use -that instead, but as the sake-bot integration can only be installed -on the same account it was created for, getting sake-bot setup would -be annoyingly fiddly. Shout if you need this to work. diff --git a/cabal/travis/binaries/.travis.yml b/cabal/travis/binaries/.travis.yml deleted file mode 100644 --- a/cabal/travis/binaries/.travis.yml +++ /dev/null @@ -1,33 +0,0 @@ -language: c -dist: xenial -# This doesn't actually help because we always push a single -# commit to the branch in question -#git: -# # https://github.com/travis-ci/travis-ci/issues/4575 -# depth: 1 -sudo: required -before_install: - - export PATH=/opt/ghc/$GHCVER/bin:$PATH - - export PATH=$HOME/.ghc-install/$GHCVER/bin:$PATH - - export PATH=$HOME/bin:$PATH - - export PATH=$HOME/.cabal/bin:$PATH - - export PATH=$HOME/.local/bin:$PATH - - export PATH=/opt/cabal/3.0/bin:$PATH - - export PATH=/opt/happy/1.19.5/bin:$PATH - - export PATH=/opt/alex/3.1.7/bin:$PATH - - ./travis-install.sh -script: - - ./travis-test.sh -after_success: - - ./travis-cleanup.sh -notifications: - webhooks: - urls: https://sake-bot.herokuapp.com/ - on_start: always - irc: - channels: - - "chat.freenode.net##haskell-cabal" - slack: haskell-cabal:sCq6GLfy9N8MJrInosg871n4 -# To append on: -# env: GHCVER=7.6.3 UPSTREAM_BUILD_DIR=/home/travis/user/repo -# os: linux diff --git a/cabal/travis/binaries/travis-cleanup.sh b/cabal/travis/binaries/travis-cleanup.sh deleted file mode 100644 --- a/cabal/travis/binaries/travis-cleanup.sh +++ /dev/null @@ -1,8 +0,0 @@ -#!/bin/sh - -# See travis/upload.sh for more documentation - -git remote set-url --push origin git@github.com:haskell-pushbot/cabal-binaries.git -(umask 177 && tr A-Za-z N-ZA-Mn-za-m < id_rsa.rot13 > $HOME/.ssh/id_rsa) -ssh-keyscan github.com >> $HOME/.ssh/known_hosts -git push origin --delete "$(git rev-parse --abbrev-ref HEAD)" diff --git a/cabal/travis/binaries/travis-test.sh b/cabal/travis/binaries/travis-test.sh deleted file mode 100644 --- a/cabal/travis/binaries/travis-test.sh +++ /dev/null @@ -1,52 +0,0 @@ -#!/bin/sh - -. ./travis-common.sh - -# Get the binaries -S3_URL=$(curl -X POST "https://s3-bouncer.herokuapp.com/get/$(cat s3-object.txt)") -curl "$S3_URL" > binaries.tgz -tar xzf binaries.tgz - -# --hide-successes uses terminal control characters which mess up -# Travis's log viewer. So just print them all! -TEST_OPTIONS="" - -# Setup symlink so that paths look the same -mkdir -p $(dirname $UPSTREAM_BUILD_DIR) -ln -s $TRAVIS_BUILD_DIR $UPSTREAM_BUILD_DIR - -# Run tests -(timed Cabal/unit-tests $TEST_OPTIONS) || exit $? - -# Check tests -(cd Cabal && timed ./check-tests $TEST_OPTIONS) || exit $? - -# Parser unit tests -(cd Cabal && timed ./parser-tests $TEST_OPTIONS) || exit $? - -# Test we can parse Hackage -# Note: no $TEST_OPTIONS as this isn't tasty suite - -# fetch 01-index.tar, -# `hackage-tests parsec` tries to parse all of cabal files in the index. -cabal update -(cd Cabal && timed ./hackage-tests parsec) || exit $? - -if [ "x$CABAL_LIB_ONLY" = "xYES" ]; then - exit 0; -fi - -# --------------------------------------------------------------------- -# cabal-install -# --------------------------------------------------------------------- - -# Update index -(timed cabal-install/cabal update) || exit $? - -# Run tests -(timed env CABAL_INSTALL_MONOLITHIC_MODE=UnitTests cabal-install/cabal $TEST_OPTIONS) || exit $? -(timed env CABAL_INSTALL_MONOLITHIC_MODE=MemoryUsageTests cabal-install/cabal $TEST_OPTIONS +RTS -M4M -K1K -RTS) || exit $? - -# These need the cabal-install directory -(cd cabal-install && timed env CABAL_INSTALL_MONOLITHIC_MODE=SolverQuickCheck ./cabal $TEST_OPTIONS --quickcheck-tests=1000) || exit $? -(cd cabal-install && timed env CABAL_INSTALL_MONOLITHIC_MODE=IntegrationTests2 ./cabal $TEST_OPTIONS) || exit $? diff --git a/cabal/travis/id_rsa.pub b/cabal/travis/id_rsa.pub deleted file mode 100644 --- a/cabal/travis/id_rsa.pub +++ /dev/null @@ -1,1 +0,0 @@ -ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABAQC8Vn3Fy0GADv2HAn2ebYi7/6lreuGMfhFOy68UZWmVGOvIFlThcnZRE+nCA9oqt/KZnBtnsr2mK1taoS0IbnG46dlNlpWdeb1e5RSEia9AexDqih2vhwuV40qxByJHdfI9PovSsMJ+7pCCvtxSEGxtqu5RegwGR7Crjqly5U/3eGW+w5D46KeZyfEQtT6bCRwM3QzSoN1k50OcIOf+u3k3ffPM3V6Fvy3l7mTddvo0ymPLrr632FzqetJyd6m26Bq03EXLE2VADGAPKsKg9XxcDaOnh+o1rCvpv4jX757mRTMOtnUzsRgM5QXWUgXDOlOxCDS+wnVSp1080WSckx0h ezyang@sabre diff --git a/cabal/travis/id_rsa.rot13 b/cabal/travis/id_rsa.rot13 deleted file mode 100644 --- a/cabal/travis/id_rsa.rot13 +++ /dev/null @@ -1,27 +0,0 @@ ------ORTVA EFN CEVINGR XRL----- -ZVVRcDVONNXPNDRNiSM9kpgOtN79ujW9az2Vh/+cn3euwU4EGfhiSTIcyEwelOMH -4KW2HECcjtCnXeslzMjoM7X9cvgoJdRgPT5khBaMGMnIaKz9KhHHuVziDUfD6bbq -e4pYyrAXfDpvE3KlCG6Y0eQPsh6Dte7pHuOfonehHKbZOxrjd46cphIC93uyifBD -+BvazpakRYH+zjxpQA0Z0dQqMBqQaPQa/eg5A33mmA1ruo8g5r5x3Ko6AZcwl66+ -g9up6aeFparcghtngAkSlkAyDNktQlePbCI8KN2wc4sdAnje6o+V1++r5xHmQeM1 -Z7RLQBHS1yVSjmcGfDt0ifW1HdqqCASxaWZqVDVQNDNONbVONDP7BbE4VSXlBeGO -OoUM0Tjj8Ym880QZPChglVQ5yfA6wQoOE6bRVJHYih8DvNUKz9kM5e27it4L5yf/ -4dQOSNXY4QJ9xlvGG1K5j2D9Fu7ymQVW51bEu//1qhczlU/RnYImBi2Un18/Qzlf -/L5YXenC43OqbFKMQTKBqgyiAuKxUM/zSDRAzRk6rzpVfiAxJ/uZmoUmPZoviZvr -xKUjEPS17AByHA/GftLaLxliH6MS5Coe3M99WjvylbTxfkxmoHCVFKClJvSLkcy/ -LMGtWZ1749mb2y/mmH2zqf4w7ZVB1Un/2372BfQBUSQKi822NO04zTY+q4vhyBf0 -uddPxrtONbTONBhwG1/zlgOb3aR9gNJAhSc9aXHdE2n0FgGEg4A/NIRshcHJZJpn -ELOYFq3ec7mabIlguXJoSjlg4FzB22Yc+CAofyXhXWkjV5PxmHtps6VrH/g8o7aW -FQMY7ufFcXIW9r8aUDjtXrKhlrrWopgxr20nOxo/0it2OXwB/4DWSYgONbTONZlp -09eAk7rLbWJyhFBAeT7S+oJI0A1JrQYkQKP0K0XdeNHTcowv3S8hFlOgNF3BHNKl -xi+RsZgw/Y12JQJVpX3iOOCfqAB3MjUhJhMu9Rr/hANMoyphtXSVBQ3WMxPzwluc -7l090EDlCxt64bODVEtXd0CFvT76D2yHogBGgHauNbTONZ1iwipfodihxrvzt/aU -vr+FmrjAuGlprEH8IpAJPu7uP7zWWY8s33VifMUPY3M5q2jzq5jhY5ISGlK9C3Kb -FYknhVuiNRpYJJM01+uQhS7hSNtDtOB40oIZ06IHkdv4M6e+YpikveKSGgNUA+e4 -vfprkyETT3q9TBwKg1f005qONbTNKNoqZwtQo4ilQqkiaWVUm/dmPCmZ6NNDW7yY -Awzc7d4pzSLMP0YqbhTYLWLzEMsMKuAjRtEteVaLQf6/qoEpTM660ffl8SL4hvTr -BXtg2zqpyOjpPWVqjTkr/0fc9xUmrIKZNFxtqSw0fw/ck5EPwwTrCr7r9vfEGech -7wVgN4RPtLRN4NwuvRca5bO0fJ6oqBVhxb6MKvghe2E30LLOaq/8mulLibgqD6kE -Cqvl381VIUCLLNRfCA6NEBFM1J7fpzC+W0VAfvm/9DinCz0x0RsvpoQ1cTFBahLc -aQPFILNrdLWISQmbAoJ9GEJxMi8M8n7cKZUi1/v8zXsleCARnn2P8YR= ------RAQ EFN CEVINGR XRL----- diff --git a/cabal/travis/upload.sh b/cabal/travis/upload.sh deleted file mode 100644 --- a/cabal/travis/upload.sh +++ /dev/null @@ -1,105 +0,0 @@ -#!/bin/sh - -set -x - -. ./travis-common.sh - -# Read out ACCOUNT and REPO from the slug -# Cribbed from http://unix.stackexchange.com/a/53323/118117 -ACCOUNT=${TRAVIS_REPO_SLUG%%"/"*} -REPO=${TRAVIS_REPO_SLUG#*"/"} - -# TAG will be used to uniquely identify a matrix entry; we -# need to push each matrix entry to a separate branch. -TAG="$TRAVIS_OS_NAME-$GHCVER$TAGSUFFIX" - -# This is the commit for which we want a GitHub status update -# ping to go to. Note that it is NOT TRAVIS_COMMIT unconditionally, -# since if we have a pull request, this commit will be a merge -# commit which no one from GitHub will be able to see. -COMMIT=${TRAVIS_PULL_REQUEST_SHA:-$TRAVIS_COMMIT} - -# This is just to help you correlate the build to what it's for -if [ "x$TRAVIS_PULL_REQUEST" != "xfalse" ]; then - ORIGIN="${TRAVIS_REPO_SLUG}/pull/$TRAVIS_PULL_REQUEST" - URL="pull/${TRAVIS_PULL_REQUEST}" -else - ORIGIN="${TRAVIS_REPO_SLUG}/${TRAVIS_BRANCH}" - URL="commits/${TRAVIS_BRANCH}" -fi - -# Git will complain if these fields don't work when committing, -# so set them up. -git config --global user.name "$(git --no-pager show -s --format='%an' $COMMIT)" -git config --global user.email "$(git --no-pager show -s --format='%ae' $COMMIT)" -git config --global push.default simple - -cd travis - -# Setup SSH key we will use to push to binaries repository. -# umask to get the permissions to be 600 (not 400, because the deploy -# script in .travis.yml is going to clobber this private key) -(umask 177 && tr A-Za-z N-ZA-Mn-za-m < id_rsa.rot13 > $HOME/.ssh/id_rsa) - -# Setup SSH keys -ssh-keyscan github.com >> $HOME/.ssh/known_hosts - -cd binaries - -# Setup binaries repository for pushing -git init -# TODO: Update this -git remote add origin git@github.com:haskell-pushbot/cabal-binaries.git - -# Make some final modifications to .travis.yml based so -# that downstream builds with the correct configuration -echo "env: GHCVER=$GHCVER UPSTREAM_BUILD_DIR=$TRAVIS_BUILD_DIR CABAL_LIB_ONLY=$CABAL_LIB_ONLY TEST_OTHER_VERSIONS=$TEST_OTHER_VERSIONS" >> .travis.yml -echo "os: $TRAVIS_OS_NAME" >> .travis.yml -if [ "x$GHCVER" = "x7.8.4" ] && [ "x$TRAVIS_OS_NAME" = "xosx" ]; then - echo "osx_image: xcode6.4" >> .travis.yml -fi - -# Make directory layout -mkdir Cabal -mkdir cabal-install -cp -R $TRAVIS_BUILD_DIR/Cabal/tests Cabal -cp -R $TRAVIS_BUILD_DIR/cabal-install/tests cabal-install -# Copy in credentials so we can delete branch when done -cp $TRAVIS_BUILD_DIR/travis/id_rsa.rot13 . -# Install all of the necessary files for testing -cp $TRAVIS_BUILD_DIR/travis-install.sh . -cp $TRAVIS_BUILD_DIR/travis-common.sh . - -cp ${CABAL_BDIR}/t/unit-tests/build/unit-tests/unit-tests Cabal -cp ${CABAL_BDIR}/t/check-tests/build/check-tests/check-tests Cabal -cp ${CABAL_BDIR}/t/parser-tests/build/parser-tests/parser-tests Cabal -cp ${CABAL_BDIR}/t/hackage-tests/build/hackage-tests/hackage-tests Cabal -BINARIES="Cabal/unit-tests Cabal/check-tests Cabal/parser-tests Cabal/hackage-tests" -if [ "x$CABAL_LIB_ONLY" != "xYES" ]; then - cp ${CABAL_INSTALL_EXE} cabal-install - BINARIES="cabal-install/cabal $BINARIES" -fi - -# The binaries to test (statically linked, of course!) -tar czf binaries.tgz $BINARIES -rm $BINARIES # Don't check me in! - -# Upload to S3 -S3_URL=$(curl -X POST "https://s3-bouncer.herokuapp.com/put") -travis_retry curl "$S3_URL" --upload-file binaries.tgz -rm binaries.tgz # Don't check me in! -echo "$S3_URL" | xargs basename | cut -d '?' -f 1 > s3-object.txt - -# Add, commit, push -git add . -# The JSON in the commit message is used by the webhook listening -# on the downstream repo to figure out who to communicate the -# status update back to -git commit -m '{"url":"'$URL'", - -"account":"'$ACCOUNT'", -"repo":"'$REPO'", -"commit": "'$COMMIT'", -"tag":"'$TAG'" -}' -travis_retry git push -f origin "HEAD:$TAG/$COMMIT" diff --git a/cabal/validate.sh b/cabal/validate.sh --- a/cabal/validate.sh +++ b/cabal/validate.sh @@ -4,7 +4,13 @@ # default config ####################################################################### -HC=ghc-8.2.2 +# We use the default ghc in PATH as default +# Use the ghc-x.y.z trigger several errors in windows: +# * It triggers the max path length issue: +# See https://github.com/haskell/cabal/issues/6271#issuecomment-1065102255 +# * It triggers a `createProcess: does not exist` error in units tests +# See https://github.com/haskell/cabal/issues/8049 +HC=ghc CABAL=cabal CABALPLAN=cabal-plan JOBS=4 @@ -36,7 +42,7 @@ Available options: -j, --jobs JOBS cabal v2-build -j argument (default: $JOBS) - --libonly Test onlt Cabal-the-library + --libonly Test only Cabal-the-library --cli Test both Cabal-the-library and cabal-install --(no-)run-lib-tests Run library tests --(no-)run-cli-tests Run client tests @@ -52,7 +58,7 @@ --partial-hackage-tests Run hackage-tests on parts of Hackage data -v, --verbose Verbose output -q, --quiet Less output - -s, --step STEP Run only specific step (can be specified mutliple times) + -s, --step STEP Run only specific step (can be specified multiple times) --list-steps List steps and build-targets and exit --help Print this message and exit EOF @@ -259,7 +265,6 @@ if [ -z "$STEPS" ]; then STEPS="print-config print-tool-versions" - if ! $LIBONLY; then STEPS="$STEPS make-cabal-install-dev"; fi STEPS="$STEPS build" if $DOCTEST; then STEPS="$STEPS doctest"; fi if $LIBTESTS; then STEPS="$STEPS lib-tests"; fi @@ -272,8 +277,8 @@ STEPS="$STEPS time-summary" fi -TARGETS="Cabal cabal-testsuite" -if ! $LIBONLY; then TARGETS="$TARGETS cabal-install"; fi +TARGETS="Cabal cabal-testsuite Cabal-tests Cabal-QuickCheck Cabal-tree-diff Cabal-described" +if ! $LIBONLY; then TARGETS="$TARGETS cabal-install cabal-install-solver cabal-benchmarks"; fi if $BENCHMARKS; then TARGETS="$TARGETS solver-benchmarks"; fi if $LISTSTEPS; then @@ -291,7 +296,9 @@ # assume compiler is GHC RUNHASKELL=$(echo $HC | sed -E 's/ghc(-[0-9.]*)$/runghc\1/') -if [ "$(uname)" = "Linux" ]; then +if [ "$OSTYPE" = "msys" ]; then + ARCH="x86_64-windows" +elif [ "$(uname)" = "Linux" ]; then ARCH="x86_64-linux" else ARCH="x86_64-osx" @@ -318,7 +325,7 @@ cat < "$HOME/.ghcup/bin/ghcup" + chmod a+x "$HOME/.ghcup/bin/ghcup" + "$HOME/.ghcup/bin/ghcup" config add-release-channel https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.7.yaml; + "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) + "$HOME/.ghcup/bin/ghcup" install cabal 3.6.2.0 || (cat "$HOME"/.ghcup/logs/*.* && false) + else + apt-add-repository -y 'ppa:hvr/ghc' + apt-get update + apt-get install -y "$HCNAME" + mkdir -p "$HOME/.ghcup/bin" + curl -sL https://downloads.haskell.org/ghcup/0.1.18.0/x86_64-linux-ghcup-0.1.18.0 > "$HOME/.ghcup/bin/ghcup" + chmod a+x "$HOME/.ghcup/bin/ghcup" + "$HOME/.ghcup/bin/ghcup" install cabal 3.6.2.0 || (cat "$HOME"/.ghcup/logs/*.* && false) + fi + env: + HCKIND: ${{ matrix.compilerKind }} + HCNAME: ${{ matrix.compiler }} + HCVER: ${{ matrix.compilerVersion }} + - name: Set PATH and environment variables + run: | + echo "$HOME/.cabal/bin" >> $GITHUB_PATH + echo "LANG=C.UTF-8" >> "$GITHUB_ENV" + echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" + echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" + HCDIR=/opt/$HCKIND/$HCVER + if [ "${{ matrix.setup-method }}" = ghcup ]; then + HC=$HOME/.ghcup/bin/$HCKIND-$HCVER + echo "HC=$HC" >> "$GITHUB_ENV" + echo "HCPKG=$HOME/.ghcup/bin/$HCKIND-pkg-$HCVER" >> "$GITHUB_ENV" + echo "HADDOCK=$HOME/.ghcup/bin/haddock-$HCVER" >> "$GITHUB_ENV" + echo "CABAL=$HOME/.ghcup/bin/cabal-3.6.2.0 -vnormal+nowrap" >> "$GITHUB_ENV" + else + HC=$HCDIR/bin/$HCKIND + echo "HC=$HC" >> "$GITHUB_ENV" + echo "HCPKG=$HCDIR/bin/$HCKIND-pkg" >> "$GITHUB_ENV" + echo "HADDOCK=$HCDIR/bin/haddock" >> "$GITHUB_ENV" + echo "CABAL=$HOME/.ghcup/bin/cabal-3.6.2.0 -vnormal+nowrap" >> "$GITHUB_ENV" + fi + + HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') + echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" + echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" + echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" + if [ $((HCNUMVER > 90401)) -ne 0 ] ; then echo "HEADHACKAGE=true" >> "$GITHUB_ENV" ; else echo "HEADHACKAGE=false" >> "$GITHUB_ENV" ; fi + echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" + echo "GHCJSARITH=0" >> "$GITHUB_ENV" + env: + HCKIND: ${{ matrix.compilerKind }} + HCNAME: ${{ matrix.compiler }} + HCVER: ${{ matrix.compilerVersion }} + - name: env + run: | + env + - name: write cabal config + run: | + mkdir -p $CABAL_DIR + cat >> $CABAL_CONFIG <> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz + echo 'de73600b1836d3f55e32d80385acc055fd97f60eaa0ab68a755302685f5d81bc cabal-plan.xz' | sha256sum -c - + xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan + rm -f cabal-plan.xz + chmod a+x $HOME/.cabal/bin/cabal-plan + cabal-plan --version + - name: checkout + uses: actions/checkout@v2 + with: + path: source + - name: initial cabal.project for sdist + run: | + touch cabal.project + echo "packages: $GITHUB_WORKSPACE/source/hackage-security" >> cabal.project + echo "packages: $GITHUB_WORKSPACE/source/hackage-security-http-client" >> cabal.project + echo "packages: $GITHUB_WORKSPACE/source/example-client" >> cabal.project + echo "packages: $GITHUB_WORKSPACE/source/hackage-security-curl" >> cabal.project + echo "packages: $GITHUB_WORKSPACE/source/hackage-root-tool" >> cabal.project + echo "packages: $GITHUB_WORKSPACE/source/hackage-repo-tool" >> cabal.project + echo "packages: $GITHUB_WORKSPACE/source/hackage-security-HTTP" >> cabal.project + cat cabal.project + - name: sdist + run: | + mkdir -p sdist + $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist + - name: unpack + run: | + mkdir -p unpacked + find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; + - name: generate cabal.project + run: | + PKGDIR_hackage_security="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/hackage-security-[0-9.]*')" + echo "PKGDIR_hackage_security=${PKGDIR_hackage_security}" >> "$GITHUB_ENV" + PKGDIR_hackage_security_http_client="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/hackage-security-http-client-[0-9.]*')" + echo "PKGDIR_hackage_security_http_client=${PKGDIR_hackage_security_http_client}" >> "$GITHUB_ENV" + PKGDIR_example_client="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/example-client-[0-9.]*')" + echo "PKGDIR_example_client=${PKGDIR_example_client}" >> "$GITHUB_ENV" + PKGDIR_hackage_security_curl="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/hackage-security-curl-[0-9.]*')" + echo "PKGDIR_hackage_security_curl=${PKGDIR_hackage_security_curl}" >> "$GITHUB_ENV" + PKGDIR_hackage_root_tool="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/hackage-root-tool-[0-9.]*')" + echo "PKGDIR_hackage_root_tool=${PKGDIR_hackage_root_tool}" >> "$GITHUB_ENV" + PKGDIR_hackage_repo_tool="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/hackage-repo-tool-[0-9.]*')" + echo "PKGDIR_hackage_repo_tool=${PKGDIR_hackage_repo_tool}" >> "$GITHUB_ENV" + PKGDIR_hackage_security_HTTP="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/hackage-security-HTTP-[0-9.]*')" + echo "PKGDIR_hackage_security_HTTP=${PKGDIR_hackage_security_HTTP}" >> "$GITHUB_ENV" + rm -f cabal.project cabal.project.local + touch cabal.project + touch cabal.project.local + echo "packages: ${PKGDIR_hackage_security}" >> cabal.project + echo "packages: ${PKGDIR_hackage_security_http_client}" >> cabal.project + echo "packages: ${PKGDIR_example_client}" >> cabal.project + echo "packages: ${PKGDIR_hackage_security_curl}" >> cabal.project + echo "packages: ${PKGDIR_hackage_root_tool}" >> cabal.project + echo "packages: ${PKGDIR_hackage_repo_tool}" >> cabal.project + echo "packages: ${PKGDIR_hackage_security_HTTP}" >> cabal.project + if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo "package hackage-security" >> cabal.project ; fi + if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo " ghc-options: -Werror=missing-methods" >> cabal.project ; fi + if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo "package hackage-security-http-client" >> cabal.project ; fi + if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo " ghc-options: -Werror=missing-methods" >> cabal.project ; fi + if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo "package example-client" >> cabal.project ; fi + if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo " ghc-options: -Werror=missing-methods" >> cabal.project ; fi + if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo "package hackage-security-curl" >> cabal.project ; fi + if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo " ghc-options: -Werror=missing-methods" >> cabal.project ; fi + if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo "package hackage-root-tool" >> cabal.project ; fi + if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo " ghc-options: -Werror=missing-methods" >> cabal.project ; fi + if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo "package hackage-repo-tool" >> cabal.project ; fi + if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo " ghc-options: -Werror=missing-methods" >> cabal.project ; fi + if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo "package hackage-security-HTTP" >> cabal.project ; fi + if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo " ghc-options: -Werror=missing-methods" >> cabal.project ; fi + cat >> cabal.project <> cabal.project + fi + $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: $_ installed\n" unless /^(example-client|hackage-repo-tool|hackage-root-tool|hackage-security|hackage-security-HTTP|hackage-security-curl|hackage-security-http-client)$/; }' >> cabal.project.local + cat cabal.project + cat cabal.project.local + - name: dump install plan + run: | + $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all + cabal-plan + - name: cache + uses: actions/cache@v2 + with: + key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} + path: ~/.cabal/store + restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- + - name: install dependencies + run: | + $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all + $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all + - name: build w/o tests + run: | + $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all + - name: build + run: | + $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always + - name: tests + run: | + $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct + - name: cabal check + run: | + cd ${PKGDIR_hackage_security} || false + ${CABAL} -vnormal check + cd ${PKGDIR_hackage_security_http_client} || false + ${CABAL} -vnormal check + cd ${PKGDIR_example_client} || false + ${CABAL} -vnormal check + cd ${PKGDIR_hackage_security_curl} || false + ${CABAL} -vnormal check + cd ${PKGDIR_hackage_root_tool} || false + ${CABAL} -vnormal check + cd ${PKGDIR_hackage_repo_tool} || false + ${CABAL} -vnormal check + cd ${PKGDIR_hackage_security_HTTP} || false + ${CABAL} -vnormal check + - name: haddock + run: | + $CABAL v2-haddock --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all + - name: unconstrained build + run: | + rm -f cabal.project.local + $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all + - name: prepare for constraint sets + run: | + rm -f cabal.project.local + - name: constraint set no-lukko + run: | + if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='hackage-security -lukko' --dependencies-only -j2 all ; fi + if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='hackage-security -lukko' all ; fi diff --git a/hackage-security/.github/workflows/haskell.yml b/hackage-security/.github/workflows/haskell.yml --- a/hackage-security/.github/workflows/haskell.yml +++ b/hackage-security/.github/workflows/haskell.yml @@ -1,5 +1,4 @@ -name: Haskell CI - +name: MacOS, Ubuntu, Windows on: [push, pull_request] @@ -10,14 +9,14 @@ strategy: fail-fast: false matrix: - ghc: ['8.10.6', '8.8.4', '8.6.5'] + ghc: ['9.4.1', '9.2.4', '9.0.2', '8.10.7'] os: [ubuntu-latest, macOS-latest, windows-latest] steps: - uses: actions/checkout@v2 - uses: haskell/actions/setup@v1 with: ghc-version: ${{ matrix.ghc }} - cabal-version: '3.6.2.0' + cabal-version: '3.8.1.0' - name: Cache uses: actions/cache@v1 diff --git a/hackage-security/.travis.yml b/hackage-security/.travis.yml deleted file mode 100644 --- a/hackage-security/.travis.yml +++ /dev/null @@ -1,210 +0,0 @@ -# This Travis job script has been generated by a script via -# -# haskell-ci '--ghc-head' '--osx=8.4.4' 'cabal.project' -# -# For more information, see https://github.com/haskell-CI/haskell-ci -# -# version: 0.9.20200325 -# -version: ~> 1.0 -language: c -os: linux -dist: xenial -git: - # whether to recursively clone submodules - submodules: false -cache: - directories: - - $HOME/.cabal/packages - - $HOME/.cabal/store - - $HOME/.hlint - - $HOME/.ghc-install -before_cache: - - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log - # remove files that are regenerated by 'cabal update' - - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.* - - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json - - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache - - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar - - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx - - rm -rfv $CABALHOME/packages/head.hackage -jobs: - include: - - compiler: ghc-8.10.1 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.10.1","cabal-install-3.2"]}} - os: linux - - compiler: ghc-8.8.3 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.8.3","cabal-install-3.0"]}} - os: linux - - compiler: ghc-8.6.5 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.6.5","cabal-install-3.0"]}} - os: linux - - compiler: ghc-8.4.4 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.4.4","cabal-install-3.0"]}} - os: linux - - compiler: ghc-8.2.2 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.2.2","cabal-install-3.0"]}} - os: linux - - compiler: ghc-8.0.2 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.0.2","cabal-install-3.0"]}} - os: linux - - compiler: ghc-7.10.3 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-7.10.3","cabal-install-3.0"]}} - os: linux - - compiler: ghc-7.8.4 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-7.8.4","cabal-install-3.0"]}} - os: linux - - compiler: ghc-7.6.3 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-7.6.3","cabal-install-3.0"]}} - os: linux - - compiler: ghc-7.4.2 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-7.4.2","cabal-install-3.0"]}} - os: linux - - compiler: ghc-head - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-head","cabal-install-head"]}} - os: linux - - compiler: ghc-8.4.4 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.4.4","cabal-install-3.0"]}} - os: osx - allow_failures: - - compiler: ghc-head -before_install: - - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//') - - WITHCOMPILER="-w $HC" - - HADDOCK=$(echo "/opt/$CC/bin/haddock" | sed 's/-/\//') - - if [ "$TRAVIS_OS_NAME" = "osx" ]; then HADDOCK=$(echo $HADDOCK | sed "s:^/opt:$HOME/.ghc-install:"); fi - - HCPKG="$HC-pkg" - - unset CC - - CABAL=/opt/ghc/bin/cabal - - CABALHOME=$HOME/.cabal - - export PATH="$CABALHOME/bin:$PATH" - - TOP=$(pwd) - - if [ "$TRAVIS_OS_NAME" = "osx" ]; then curl https://haskell.futurice.com/haskell-on-macos.py | python3 - --make-dirs --install-dir=$HOME/.ghc-install --cabal-alias=head install cabal-install-head ${TRAVIS_COMPILER}; fi - - if [ "$TRAVIS_OS_NAME" = "osx" ]; then HC=$HOME/.ghc-install/ghc/bin/$TRAVIS_COMPILER; WITHCOMPILER="-w $HC"; HCPKG=${HC/ghc/ghc-pkg}; CABAL=$HOME/.ghc-install/ghc/bin/cabal; fi - - "HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')" - - echo $HCNUMVER - - CABAL="$CABAL -vnormal+nowrap" - - set -o pipefail - - TEST=--enable-tests - - BENCH=--enable-benchmarks - - HEADHACKAGE=false - - if [ $HCNUMVER -gt 81001 ] ; then HEADHACKAGE=true ; fi - - rm -f $CABALHOME/config - - | - echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config - echo "remote-build-reporting: anonymous" >> $CABALHOME/config - echo "write-ghc-environment-files: always" >> $CABALHOME/config - echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config - echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config - echo "world-file: $CABALHOME/world" >> $CABALHOME/config - echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config - echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config - echo "installdir: $CABALHOME/bin" >> $CABALHOME/config - echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config - echo "store-dir: $CABALHOME/store" >> $CABALHOME/config - echo "install-dirs user" >> $CABALHOME/config - echo " prefix: $CABALHOME" >> $CABALHOME/config - echo "repository hackage.haskell.org" >> $CABALHOME/config - echo " url: http://hackage.haskell.org/" >> $CABALHOME/config - - | - if $HEADHACKAGE; then - echo "allow-newer: $($HCPKG list --simple-output | sed -E 's/([a-zA-Z-]+)-[0-9.]+/*:\1/g')" >> $CABALHOME/config - echo "repository head.hackage.ghc.haskell.org" >> $CABALHOME/config - echo " url: https://ghc.gitlab.haskell.org/head.hackage/" >> $CABALHOME/config - echo " secure: True" >> $CABALHOME/config - echo " root-keys: 7541f32a4ccca4f97aea3b22f5e593ba2c0267546016b992dfadcd2fe944e55d" >> $CABALHOME/config - echo " 26021a13b401500c8eb2761ca95c61f2d625bfef951b939a8124ed12ecf07329" >> $CABALHOME/config - echo " f76d08be13e9a61a377a85e2fb63f4c5435d40f8feb3e12eb05905edb8cdea89" >> $CABALHOME/config - echo " key-threshold: 3" >> $CABALHOME/config - fi -install: - - ${CABAL} --version - - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" - - | - echo "program-default-options" >> $CABALHOME/config - echo " ghc-options: $GHCJOBS +RTS -M6G -RTS" >> $CABALHOME/config - - cat $CABALHOME/config - - rm -fv cabal.project cabal.project.local cabal.project.freeze - - travis_retry ${CABAL} v2-update -v - # Generate cabal.project - - rm -rf cabal.project cabal.project.local cabal.project.freeze - - touch cabal.project - - | - echo "packages: hackage-security" >> cabal.project - echo "packages: hackage-security-http-client" >> cabal.project - echo "packages: example-client" >> cabal.project - echo "packages: hackage-security-curl" >> cabal.project - echo "packages: hackage-root-tool" >> cabal.project - echo "packages: hackage-repo-tool" >> cabal.project - echo "packages: hackage-security-HTTP" >> cabal.project - - | - - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(example-client|hackage-repo-tool|hackage-root-tool|hackage-security|hackage-security-HTTP|hackage-security-curl|hackage-security-http-client)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - - cat cabal.project || true - - cat cabal.project.local || true - - if [ -f "hackage-security/configure.ac" ]; then (cd "hackage-security" && autoreconf -i); fi - - if [ -f "hackage-security-http-client/configure.ac" ]; then (cd "hackage-security-http-client" && autoreconf -i); fi - - if [ -f "example-client/configure.ac" ]; then (cd "example-client" && autoreconf -i); fi - - if [ -f "hackage-security-curl/configure.ac" ]; then (cd "hackage-security-curl" && autoreconf -i); fi - - if [ -f "hackage-root-tool/configure.ac" ]; then (cd "hackage-root-tool" && autoreconf -i); fi - - if [ -f "hackage-repo-tool/configure.ac" ]; then (cd "hackage-repo-tool" && autoreconf -i); fi - - if [ -f "hackage-security-HTTP/configure.ac" ]; then (cd "hackage-security-HTTP" && autoreconf -i); fi - - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} - - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'" - - rm cabal.project.freeze - - travis_wait 40 ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} --dep -j2 all - - travis_wait 40 ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --dep -j2 all -script: - - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) - # Packaging... - - ${CABAL} v2-sdist all - # Unpacking... - - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/ - - cd ${DISTDIR} || false - - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \; - - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \; - - PKGDIR_hackage_security="$(find . -maxdepth 1 -type d -regex '.*/hackage-security-[0-9.]*')" - - PKGDIR_hackage_security_http_client="$(find . -maxdepth 1 -type d -regex '.*/hackage-security-http-client-[0-9.]*')" - - PKGDIR_example_client="$(find . -maxdepth 1 -type d -regex '.*/example-client-[0-9.]*')" - - PKGDIR_hackage_security_curl="$(find . -maxdepth 1 -type d -regex '.*/hackage-security-curl-[0-9.]*')" - - PKGDIR_hackage_root_tool="$(find . -maxdepth 1 -type d -regex '.*/hackage-root-tool-[0-9.]*')" - - PKGDIR_hackage_repo_tool="$(find . -maxdepth 1 -type d -regex '.*/hackage-repo-tool-[0-9.]*')" - - PKGDIR_hackage_security_HTTP="$(find . -maxdepth 1 -type d -regex '.*/hackage-security-HTTP-[0-9.]*')" - # Generate cabal.project - - rm -rf cabal.project cabal.project.local cabal.project.freeze - - touch cabal.project - - | - echo "packages: ${PKGDIR_hackage_security}" >> cabal.project - echo "packages: ${PKGDIR_hackage_security_http_client}" >> cabal.project - echo "packages: ${PKGDIR_example_client}" >> cabal.project - echo "packages: ${PKGDIR_hackage_security_curl}" >> cabal.project - echo "packages: ${PKGDIR_hackage_root_tool}" >> cabal.project - echo "packages: ${PKGDIR_hackage_repo_tool}" >> cabal.project - echo "packages: ${PKGDIR_hackage_security_HTTP}" >> cabal.project - - | - - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(example-client|hackage-repo-tool|hackage-root-tool|hackage-security|hackage-security-HTTP|hackage-security-curl|hackage-security-http-client)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - - cat cabal.project || true - - cat cabal.project.local || true - # Building... - # this builds all libraries and executables (without tests/benchmarks) - - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all - # Building with tests and benchmarks... - # build & run tests, build benchmarks - - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all - # Testing... - - ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all - # cabal check... - - (cd ${PKGDIR_hackage_security} && ${CABAL} -vnormal check) - - (cd ${PKGDIR_hackage_security_http_client} && ${CABAL} -vnormal check) - - (cd ${PKGDIR_example_client} && ${CABAL} -vnormal check) - - (cd ${PKGDIR_hackage_security_curl} && ${CABAL} -vnormal check) - - (cd ${PKGDIR_hackage_root_tool} && ${CABAL} -vnormal check) - - (cd ${PKGDIR_hackage_repo_tool} && ${CABAL} -vnormal check) - - (cd ${PKGDIR_hackage_security_HTTP} && ${CABAL} -vnormal check) - # haddock... - - ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all - # Building without installed constraints for packages in global-db... - - rm -f cabal.project.local - - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all - -# REGENDATA ("0.9.20200325",["--ghc-head","--osx=8.4.4","cabal.project"]) -# EOF diff --git a/hackage-security/README.md b/hackage-security/README.md --- a/hackage-security/README.md +++ b/hackage-security/README.md @@ -1,15 +1,49 @@ -# Hackage Security [![Hackage version](https://img.shields.io/hackage/v/hackage-security.svg?label=Hackage)](https://hackage.haskell.org/package/hackage-security) [![Stackage version](https://www.stackage.org/package/hackage-security/badge/lts?label=Stackage)](https://www.stackage.org/package/hackage-security) [![Build Status](https://secure.travis-ci.org/haskell/hackage-security.svg?branch=master)](http://travis-ci.org/haskell/hackage-security) [![Windows build status](https://ci.appveyor.com/api/projects/status/github/haskell/cabal?branch=master&svg=true)](https://ci.appveyor.com/project/hvr/hackage-security) +# Hackage Security [![Hackage version](https://img.shields.io/hackage/v/hackage-security.svg?label=Hackage)](https://hackage.haskell.org/package/hackage-security) [![Stackage version](https://www.stackage.org/package/hackage-security/badge/lts?label=Stackage)](https://www.stackage.org/package/hackage-security) This is a library for Hackage security based on [TUF, The Update -Framework][TUF]. +Framework][TUF]. In addition to the TUF website, the [blog post][blogpost] that +announced the framework is a good source of information. -## Project phases and shortcuts +## Background Information -Phase 1 of the project will implement the basic TUF framework, but leave out -author signing; support for author signed packages (and other targets) will -added in phase 2. The main goal of phase 1 is to be able to have untrusted -mirrors of the Hackage server. +The Hackage security process is an implementation of [_The Update Framework_ +(TUF)][TUF], intended to stop software supply-chain attacks. TUF provides both +index signing, which prevents mirrors or other middlemen from tampering with the +contents of a software repository, and author signing, which prevents +repositories from tampering with the contents of hosted packages. Thus far, +however, Hackage implements only index signing. Additionally, Hackage differs +somewhat from TUF's assumptions, and thus does things a little differently. +Rather than attempting to describe the diff against TUF, this document simply +describes how Hackage's security features work. +As an instance of TUF, the Hackage security process uses much of its jargon. In +particular, a _role_ refers to a manner of use of a particular key. A given key +might, in principle, be used in multiple roles - for instance, the same key +could be used to sign timestamps and mirrors. In this context, "the timestamp +key" and "the mirror key" would refer to the same key used in two different +ways. Each role is assigned a _threshold_ that states how many signatures are +expected for a given role. For instance, in Hackage, the timestamp role requires +just one signature, while the root role requires three signatures. Similarly, +keys are distinguished from key IDs, which are hashes of the key content. With +the `ed25519` keys used by this process, they are the same length, so be +careful. + +Hackage provides the following to build tools: + * An index, which contains the metadata for every package + * Packages, which contain the actual code + * A timestamp, with a frequently-updated signature that expires regularly + +Malicious mirrors could attempt to interpose incorrect information into either. +Hackage cryptographically signs the index, providing evidence of its +authenticity, and the index itself contains hashes of each package file. Thus, +mirrors cannot interpose new metadata or new packages, because both are secured +by the signature. Additionally, these features prevent man-in-the-middle +attacks against both Hackage and its mirrors, domain hijacking, and rollback +attacks. The signed timestamp ensures that clients can detect replay attacks +that are denying them new packages. They do not prevent malicious or +compromised package authors from uploading malware to the index, nor do they +protect against the Hackage server itself being compromised. + ## Brief overview of Hackage and cabal-install Hackage makes all packages available from a single directory `/package`; for @@ -34,6 +68,83 @@ `/Foo/1.0/Foo.cabal` respectively, both informally in this text and in formal delegation rules. +## Formats and Tools + +The files that are to be signed contain JSON objects that have two fields: +`signatures` and `signed`. The Hackage signing tools will not sign any other +format. The `signatures` field is expected to be an array of signatures, while +the `signed` field may consist of arbitrary JSON. When signing, the signature +is actually applied to the [canonical +JSON](https://gibson042.github.io/canonicaljson-spec/) rendering of the contents +of the `signed` field. This allows multiple signatures to be independently +created and added, because new signatures do not sign the prior signatures. + +There are two tools that are relevant: +[hackage-root-tool](https://github.com/haskell/hackage-security/tree/master/hackage-root-tool) +and +[hackage-repo-tool](https://github.com/haskell/hackage-security/tree/master/hackage-repo-tool). +`hackage-root-tool` is a minimal implementation of the cryptography, intended to +be as small as possible so that it can be audited and run on an offline machine. +`hackage-repo-tool`, on the other hand, has a number of features for managing +file-based Hackage repositories in addition to signing. + +## Keys and Participants + +### The Root of Trust + +The file `root.json` describes all of the keys used in Hackage Security. It +lists the public parts of the keys, enumerates the roles used, and assigns keys +and thresholds to each role. It is signed by keys in the root role. + +### Root Keys + +The Hackage root keys are held by trusted members of the Haskell community. A +signature is valid when three keyholders have signed. This means that the +overall system is not vulnerable to a single key being compromised; nor can +service be denied by a single key being lost. Keyholders are strongly +encouraged to keep their keys very secure. The current collection of +keyholders, plus signatures that demonstrate that they have the keys, is +available at https://github.com/haskell-infra/hackage-root-keys . + +Root keys present a bootstrapping problem: how is a build tool to know whether +it should trust a newly-downloaded `root.json`? To work around this, the public +part of the root keys and the threshold policy for the root role are shipped +with the build tools that need to verify Hackage downloads. Once this +`root.json` has been verified, its policies override the built-in bootstrapping +keys. + +Because these root keys are so difficult to replace, they are not used for +operations. The root keys are used to delegate roles to a set of operational +keys, and these operational keys are used for the daily signing of indices by +Hackage. + +### Operational Keys + +The operational keys are signed by the root keys. Build tools have no in-built +knowledge of them, but can instead discover them through `root.json`. The +operational private keys are kept secure by the Hackage administrators, but +because they are on an online machine, they are more vulnerable than the root +keys. + +Operational keys fulfill two roles: + * **Snapshot keys** are used to sign the Hackage index. + * **Timestamp keys** are used to sign the frequently-updated timestamp file. + + +## Mirrors + +A list of authorized mirrors of Hackage is provided in a file called +`mirrors.json`. This list is signed by the mirror key. The mirrors list +expires annually and must be re-signed by the mirror key. Clients check that +the mirror key is signed by the root key, and that the mirror list is signed by +the mirror key, before accepting a mirror list. According to the [TUF +spec](https://theupdateframework.github.io/specification/latest/#mirrors), + +> The importance of using signed mirror lists depends on the application and the users of that application. There is minimal risk to the application’s security from being tricked into contacting the wrong mirrors. This is because the framework has very little trust in repositories. + +The mirror list being signed is mostly for the sake of completeness, rather than out of concern for a particular threat. + + ## Comparison with TUF In this section we highlight some of the differences in the specifics of the @@ -108,7 +219,7 @@ This file itself is signed by the target keys (kept offline by the Hackage admins). -Note that this file uses various extension to TUF spec: +Note that this file uses various extensions to TUF spec: * We can use wildcards in names as well as in paths. This means that we list a single path with a single replacement name. (Alternatively, we @@ -560,6 +671,46 @@ But we would still like to be able to install and verify old packages. How do we deal with this? +## Ongoing Maintenance + +### Mirror Keys: Every Year + +The mirror list requires annual resigning by a holder of a mirror key. +To do this, use the following steps: + + 1. Install `hackage-root-tool` on the signing machine and ensure that the key is present. + 2. Create a new `mirrors.json` file by incrementing the version field of the existing file and adding a year to the expiration date. Delete the signature(s), replacing them with an empty array. Place the file on the signing machine. + 3. Sign the file using `hackage-root-tool sign KEY mirrors.json`, and place the resulting signature array into the `signatures` field of `mirrors.json`. + 4. Commit the updated file to `https://github.com/haskell-infra/hackage-root-keys` and inform the Hackage admins so they can install it. + + +### Root Data: Every Other Year + +The holders of the root keys are, each year, signing the root information file `root.json` that directs clients to the operational and mirror keys. +The keyholders are attesting that they believe that the root and operational keys are not compromised, that Hackage is still under the control of trusted administrators, and that everything is working about the way it usually does. + +Today, there are five active root keys, because three of the original eight never completed the setup process. + +To prepare the updated `roots.json` for signing by the root keyholders, a coordinator should perform the following edits: + 1. If any new keys are to be admitted, collect their key IDs and add them to the `keys` field. + 2. Modify the expiration date. + 3. Increment the `version` field. + 4. Delete the existing signatures. + +Each holder of root keys should do the following: + 1. Verify that the contents of `root.json` are correct. Any changes to the set of keys and their roles or to the threshold policies should be trustworthy, and any new keyholders need to have their identity verified. Please be a stickler for details here. + 2. Install `hackage-root-tool` on the signing machine and ensure that the key is present. + 3. Place the updated `roots.json` file on the signing machine. + 4. Sign the file using `hackage-root-tool sign KEY roots.json`, and send the resulting signature back to the person who is coordinating the signing. + +Finally, the coordinator should insert the provided signatures and commit the updated file to `https://github.com/haskell-infra/hackage-root-keys` and inform the Hackage admins so they can install it. + + +### Operational Keys + +The operational keys do not presently require regeneration, unless the private keys have been lost or compromised. + + ## Footnotes ### Footnote: Paths @@ -692,3 +843,4 @@ [bfeb01f]: https://github.com/haskell/cabal/commit/bfeb01f [63a8c728]: https://github.com/haskell/hackage-server/commit/63a8c728 [3cfe4de]: https://github.com/haskell/hackage-server/commit/3cfe4de +[blogpost]: https://www.well-typed.com/blog/2015/07/hackage-security-alpha/ diff --git a/hackage-security/cabal.haskell-ci b/hackage-security/cabal.haskell-ci --- a/hackage-security/cabal.haskell-ci +++ b/hackage-security/cabal.haskell-ci @@ -1,5 +1,4 @@ ghc-head: True -osx: 8.4.4 constraint-set no-lukko ghc: >=8.2 diff --git a/hackage-security/example-client/example-client.cabal b/hackage-security/example-client/example-client.cabal --- a/hackage-security/example-client/example-client.cabal +++ b/hackage-security/example-client/example-client.cabal @@ -10,20 +10,27 @@ category: Distribution build-type: Simple cabal-version: >=1.10 -tested-with: GHC==8.10.1, GHC==8.8.3, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, - GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2 +tested-with: + GHC==9.4.1, GHC==9.2.4, GHC==9.0.2, + GHC==8.10.7, GHC==8.8.4, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, + GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2 + flag use-network-uri description: Are we using network-uri? manual: False +flag Cabal-syntax + description: Are we using Cabal-syntax? + manual: False + default: False + executable example-client main-is: Main.hs other-modules: Prelude ExampleClient.Options - build-depends: base >= 4.5 && < 4.15, + build-depends: base >= 4.5 && < 4.18, bytestring >= 0.9, - Cabal >= 1.12, directory >= 1.1, filepath >= 1.2, optparse-applicative >= 0.11, @@ -48,3 +55,9 @@ network >= 2.6 && < 3.2 else build-depends: network >= 2.5 && < 2.6 + + if flag(Cabal-syntax) + build-depends: Cabal-syntax >= 3.7 && < 3.9 + else + build-depends: Cabal >= 1.12 && < 3.7, + Cabal-syntax < 3.7 diff --git a/hackage-security/hackage-repo-tool/ChangeLog.md b/hackage-security/hackage-repo-tool/ChangeLog.md --- a/hackage-security/hackage-repo-tool/ChangeLog.md +++ b/hackage-security/hackage-repo-tool/ChangeLog.md @@ -1,3 +1,7 @@ +0.1.1.3 +------- +* Compat release for `Cabal-syntax-3.8.1.0` + 0.1.1.2 ------- * Compat release for `hackage-security-0.6` diff --git a/hackage-security/hackage-repo-tool/hackage-repo-tool.cabal b/hackage-security/hackage-repo-tool/hackage-repo-tool.cabal --- a/hackage-security/hackage-repo-tool/hackage-repo-tool.cabal +++ b/hackage-security/hackage-repo-tool/hackage-repo-tool.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 name: hackage-repo-tool -version: 0.1.1.2 +version: 0.1.1.3 build-type: Simple synopsis: Manage secure file-based package repositories @@ -21,9 +21,12 @@ category: Distribution homepage: https://github.com/haskell/hackage-security bug-reports: https://github.com/haskell/hackage-security/issues -tested-with: GHC==8.10.1, GHC==8.8.3, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, - GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2 +tested-with: + GHC==9.4.1, GHC==9.2.4, GHC==9.0.2, + GHC==8.10.7, GHC==8.8.4, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, + GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2 + extra-source-files: ChangeLog.md README.md @@ -39,6 +42,11 @@ description: Are we using @old-time@? manual: False +flag Cabal-syntax + description: Are we using Cabal-syntax? + manual: False + default: False + executable hackage-repo-tool hs-source-dirs: src main-is: Main.hs @@ -51,14 +59,11 @@ -- For boot libraries we try to accomodate the versions bundled with -- the respective GHC release - build-depends: base >= 4.5 && < 4.15, + build-depends: base >= 4.5 && < 4.18, bytestring >= 0.9 && < 0.12, - Cabal >= 1.14 && < 1.26 - || >= 2.0 && < 2.6 - || >= 3.0 && < 3.4, directory >= 1.1 && < 1.4, filepath >= 1.3 && < 1.5, - time >= 1.4 && < 1.10 + time >= 1.4 && < 1.13 if !os(windows) build-depends: unix >= 2.5 && < 2.8 @@ -71,7 +76,7 @@ -- For non-boot libraries we try to support single major versions -- to reduce the risk of semantic differences build-depends: microlens >= 0.4.11.2 && < 0.5, - optparse-applicative >= 0.15.1 && < 0.16, + optparse-applicative >= 0.15.1 && < 0.18, tar >= 0.5 && < 0.6, zlib >= 0.6 && < 0.7, hackage-security >= 0.6 && < 0.7 @@ -83,6 +88,14 @@ || >= 3.0 && < 3.2 else build-depends: network >= 2.5 && < 2.6 + + if flag(Cabal-syntax) + build-depends: Cabal-syntax >= 3.7 && < 3.10 + else + build-depends: Cabal >= 1.14 && < 1.26 + || >= 2.0 && < 2.6 + || >= 3.0 && < 3.7, + Cabal-syntax < 3.7 default-language: Haskell2010 diff --git a/hackage-security/hackage-root-tool/hackage-root-tool.cabal b/hackage-security/hackage-root-tool/hackage-root-tool.cabal --- a/hackage-security/hackage-root-tool/hackage-root-tool.cabal +++ b/hackage-security/hackage-root-tool/hackage-root-tool.cabal @@ -14,9 +14,12 @@ category: Distribution build-type: Simple cabal-version: >=1.10 -tested-with: GHC==8.10.1, GHC==8.8.3, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, - GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2 +tested-with: + GHC==9.4.1, GHC==9.2.4, GHC==9.0.2, + GHC==8.10.7, GHC==8.8.4, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, + GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2 + extra-source-files: ChangeLog.md @@ -29,7 +32,7 @@ main-is: Main.hs build-depends: base >= 4.4 && < 5, filepath >= 1.2 && < 1.5, - optparse-applicative >= 0.11 && < 0.16, + optparse-applicative >= 0.11 && < 0.18, hackage-security >= 0.5 && < 0.7 default-language: Haskell2010 other-extensions: CPP, ScopedTypeVariables, RecordWildCards diff --git a/hackage-security/hackage-security-HTTP/hackage-security-HTTP.cabal b/hackage-security/hackage-security-HTTP/hackage-security-HTTP.cabal --- a/hackage-security/hackage-security-HTTP/hackage-security-HTTP.cabal +++ b/hackage-security/hackage-security-HTTP/hackage-security-HTTP.cabal @@ -1,6 +1,7 @@ cabal-version: 1.12 name: hackage-security-HTTP version: 0.1.1.1 +x-revision: 2 synopsis: Hackage security bindings against the HTTP library description: The hackage security library provides a 'HttpLib' abstraction to allow to bind against different HTTP @@ -15,9 +16,12 @@ homepage: https://github.com/haskell/hackage-security bug-reports: https://github.com/haskell/hackage-security/issues build-type: Simple -tested-with: GHC==8.10.1, GHC==8.8.3, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, - GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2 +tested-with: + GHC==9.4.1, GHC==9.2.4, GHC==9.0.2, + GHC==8.10.7, GHC==8.8.4, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, + GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2 + extra-source-files: ChangeLog.md @@ -31,10 +35,10 @@ library exposed-modules: Hackage.Security.Client.Repository.HttpLib.HTTP - build-depends: base >= 4.5 && < 4.15, + build-depends: base >= 4.5 && < 4.18, bytestring >= 0.9 && < 0.12, - HTTP >= 4000.2.19 && < 4000.4, - mtl >= 2.1 && < 2.3, + HTTP >= 4000.2.19 && < 4000.5, + mtl >= 2.1 && < 2.4, zlib >= 0.5 && < 0.7, hackage-security >= 0.5 && < 0.7 hs-source-dirs: src diff --git a/hackage-security/hackage-security-HTTP/src/Hackage/Security/Client/Repository/HttpLib/HTTP.hs b/hackage-security/hackage-security-HTTP/src/Hackage/Security/Client/Repository/HttpLib/HTTP.hs --- a/hackage-security/hackage-security-HTTP/src/Hackage/Security/Client/Repository/HttpLib/HTTP.hs +++ b/hackage-security/hackage-security-HTTP/src/Hackage/Security/Client/Repository/HttpLib/HTTP.hs @@ -40,7 +40,7 @@ -- -- TODO: This currently uses the lazy bytestring API offered by the HTTP -- library. Unfortunately this provides no way of closing the connection when --- the callback decides it doens't require any further input. It seems +-- the callback decides it doesn't require any further input. It seems -- impossible however to implement a proper streaming API. -- See . withClient :: (Browser -> HttpLib -> IO a) -> IO a diff --git a/hackage-security/hackage-security-curl/hackage-security-curl.cabal b/hackage-security/hackage-security-curl/hackage-security-curl.cabal --- a/hackage-security/hackage-security-curl/hackage-security-curl.cabal +++ b/hackage-security/hackage-security-curl/hackage-security-curl.cabal @@ -14,16 +14,19 @@ category: Distribution build-type: Simple cabal-version: >=1.10 -tested-with: GHC==8.10.1, GHC==8.8.3, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, - GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2 +tested-with: + GHC==9.4.1, GHC==9.2.4, GHC==9.0.2, + GHC==8.10.7, GHC==8.8.4, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, + GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2 + flag use-network-uri description: Are we using network-uri? manual: False library exposed-modules: Hackage.Security.Client.Repository.HttpLib.Curl - build-depends: base >= 4.5 && < 4.15, + build-depends: base >= 4.5 && < 4.18, bytestring >= 0.9, process >= 1.1, hackage-security diff --git a/hackage-security/hackage-security-http-client/hackage-security-http-client.cabal b/hackage-security/hackage-security-http-client/hackage-security-http-client.cabal --- a/hackage-security/hackage-security-http-client/hackage-security-http-client.cabal +++ b/hackage-security/hackage-security-http-client/hackage-security-http-client.cabal @@ -13,18 +13,21 @@ category: Distribution build-type: Simple cabal-version: >=1.10 -tested-with: GHC==8.10.1, GHC==8.8.3, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, - GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2 +tested-with: + GHC==9.4.1, GHC==9.2.4, GHC==9.0.2, + GHC==8.10.7, GHC==8.8.4, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, + GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2 + flag use-network-uri description: Are we using network-uri? manual: False library exposed-modules: Hackage.Security.Client.Repository.HttpLib.HttpClient - build-depends: base >= 4.5 && < 4.15, + build-depends: base >= 4.5 && < 4.18, bytestring >= 0.9, - http-client >= 0.4 && < 0.7, + http-client >= 0.4 && < 0.8, http-types >= 0.8, hackage-security >= 0.5 && < 0.7 hs-source-dirs: src diff --git a/hackage-security/hackage-security/ChangeLog.md b/hackage-security/hackage-security/ChangeLog.md --- a/hackage-security/hackage-security/ChangeLog.md +++ b/hackage-security/hackage-security/ChangeLog.md @@ -1,5 +1,28 @@ See also http://pvp.haskell.org/faq +0.6.2.3 +------- + +* Bump base for GHC 9.4 comp +* Fix code to *really* support mtl-2.3 + +0.6.2.2 +------- + +* Fix broken compilation of test-suite with Cabal-syntax-3.8.1.0 on Hackage +* Huge README updates + +0.6.2.1 +------- + +* Allow GHC-9.0 (base-4.15) (#265) +* Fix running `cabal repl hackage-security` (#263) + +0.6.2.0 +------- + +* Safely prepare for when cabal factors out Cabal-syntax + 0.6.1.0 ------- diff --git a/hackage-security/hackage-security/hackage-security.cabal b/hackage-security/hackage-security/hackage-security.cabal --- a/hackage-security/hackage-security/hackage-security.cabal +++ b/hackage-security/hackage-security/hackage-security.cabal @@ -1,12 +1,12 @@ cabal-version: 1.12 name: hackage-security -version: 0.6.1.0 +version: 0.6.2.3 synopsis: Hackage security library description: The hackage security library provides both server and client utilities for securing the Hackage package server - (). It is based on The Update - Framework (), a set of + (). It is based on The Update + Framework (), a set of recommendations developed by security researchers at various universities in the US as well as developers on the Tor project (). @@ -29,9 +29,11 @@ homepage: https://github.com/haskell/hackage-security bug-reports: https://github.com/haskell/hackage-security/issues build-type: Simple -tested-with: GHC==8.10.1, GHC==8.8.3, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, - GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2 +tested-with: + GHC==9.4.1, GHC==9.2.4, GHC==9.0.2, + GHC==8.10.7, GHC==8.8.4, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, + GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2 extra-source-files: ChangeLog.md @@ -48,6 +50,11 @@ description: Are we using @network-uri@? manual: False +flag Cabal-syntax + description: Are we using Cabal-syntax? + manual: False + default: False + flag old-directory description: Use @directory@ < 1.2 and @old-time@ manual: False @@ -108,15 +115,12 @@ Hackage.Security.Util.Lens Hackage.Security.Util.Stack Hackage.Security.Util.TypedEmbedded - Prelude + MyPrelude -- We support ghc 7.4 (bundled with Cabal 1.14) and up - build-depends: base >= 4.5 && < 4.17, + build-depends: base >= 4.5 && < 4.18, base16-bytestring >= 0.1.1 && < 1.1, base64-bytestring >= 1.0 && < 1.3, bytestring >= 0.9 && < 0.12, - Cabal >= 1.14 && < 1.26 - || >= 2.0 && < 2.6 - || >= 3.0 && < 3.8, containers >= 0.4 && < 0.7, ed25519 >= 0.0 && < 0.1, filepath >= 1.2 && < 1.5, @@ -126,9 +130,9 @@ -- 0.4.2 introduces TarIndex, 0.4.4 introduces more -- functionality, 0.5.0 changes type of serialise tar >= 0.5 && < 0.6, - template-haskell >= 2.7 && < 2.19, + template-haskell >= 2.7 && < 2.20, time >= 1.2 && < 1.13, - transformers >= 0.3 && < 0.6, + transformers >= 0.3 && < 0.7, zlib >= 0.5 && < 0.7, -- whatever versions are bundled with ghc: ghc-prim @@ -142,13 +146,21 @@ build-depends: mtl >= 2.1 && < 2.2, mtl-compat >= 0.2 && < 0.3 else - build-depends: mtl >= 2.2 && < 2.3 + build-depends: mtl >= 2.2 && < 2.4 if flag(lukko) build-depends: lukko >= 0.1 && < 0.2 else build-depends: base >= 4.10 + if flag(Cabal-syntax) && impl(ghc >= 8.2) + build-depends: Cabal-syntax >= 3.7 && < 3.10 + else + build-depends: Cabal >= 1.14 && < 1.26 + || >= 2.0 && < 2.6 + || >= 3.0 && < 3.7, + Cabal-syntax < 3.7 + hs-source-dirs: src default-language: Haskell2010 default-extensions: DefaultSignatures @@ -161,6 +173,7 @@ KindSignatures MultiParamTypeClasses NamedFieldPuns + NoImplicitPrelude NoMonomorphismRestriction RankNTypes RecordWildCards @@ -249,7 +262,6 @@ -- inherited constraints from lib:hackage-security component build-depends: hackage-security, base, - Cabal, containers, bytestring, network-uri, @@ -258,13 +270,22 @@ time, zlib + if flag(Cabal-syntax) && impl(ghc >= 8.2) + build-depends: Cabal >= 3.7 && < 3.10, + Cabal-syntax >= 3.7 && < 3.10 + else + build-depends: Cabal >= 1.14 && < 1.26 + || >= 2.0 && < 2.6 + || >= 3.0 && < 3.7, + Cabal-syntax < 3.7 + -- dependencies exclusive to test-suite build-depends: tasty >= 1.2 && < 1.5, tasty-hunit == 0.10.*, tasty-quickcheck == 0.10.*, QuickCheck >= 2.11 && <2.15, - aeson == 1.4.* || == 1.5.* || == 2.0.*, - vector == 0.12.*, + aeson == 1.4.* || == 1.5.* || == 2.0.* || == 2.1.*, + vector >= 0.12 && <0.14, unordered-containers >=0.2.8.0 && <0.3, temporary >= 1.2 && < 1.4 diff --git a/hackage-security/hackage-security/src/Hackage/Security/Client.hs b/hackage-security/hackage-security/src/Hackage/Security/Client.hs --- a/hackage-security/hackage-security/src/Hackage/Security/Client.hs +++ b/hackage-security/hackage-security/src/Hackage/Security/Client.hs @@ -41,7 +41,7 @@ , LocalFileCorrupted(..) ) where -import Prelude hiding (log) +import MyPrelude hiding (log) import Control.Arrow (first) import Control.Exception import Control.Monad @@ -89,7 +89,7 @@ -- This implements the logic described in Section 5.1, "The client application", -- of the TUF spec. It checks which of the server metadata has changed, and -- downloads all changed metadata to the local cache. (Metadata here refers --- both to the TUF security metadata as well as the Hackage packge index.) +-- both to the TUF security metadata as well as the Hackage package index.) -- -- You should pass @Nothing@ for the UTCTime _only_ under exceptional -- circumstances (such as when the main server is down for longer than the diff --git a/hackage-security/hackage-security/src/Hackage/Security/Client/Formats.hs b/hackage-security/hackage-security/src/Hackage/Security/Client/Formats.hs --- a/hackage-security/hackage-security/src/Hackage/Security/Client/Formats.hs +++ b/hackage-security/hackage-security/src/Hackage/Security/Client/Formats.hs @@ -17,6 +17,7 @@ , formatsLookup ) where +import MyPrelude import Hackage.Security.Util.Stack import Hackage.Security.Util.TypedEmbedded @@ -50,7 +51,7 @@ -- -- Rather than having a general list here, we enumerate all possibilities. -- This means we are very precise about what we expect, and we avoid any runtime --- errors about unexpect format definitions. +-- errors about unexpected format definitions. -- -- NOTE: If we add additional cases here (for dealing with additional formats) -- all calls to @error "inaccessible"@ need to be reevaluated. diff --git a/hackage-security/hackage-security/src/Hackage/Security/Client/Repository.hs b/hackage-security/hackage-security/src/Hackage/Security/Client/Repository.hs --- a/hackage-security/hackage-security/src/Hackage/Security/Client/Repository.hs +++ b/hackage-security/hackage-security/src/Hackage/Security/Client/Repository.hs @@ -30,6 +30,7 @@ , mustCache ) where +import MyPrelude import Control.Exception import Data.Typeable (Typeable) import qualified Codec.Archive.Tar.Index as Tar @@ -180,7 +181,7 @@ -- * Download the file from the repository and make it available at a -- temporary location -- * Use the provided file length to protect against endless data attacks. - -- (Repositories such as local repositories that are not suspectible to + -- (Repositories such as local repositories that are not susceptible to -- endless data attacks can safely ignore this argument.) -- * Move the file from its temporary location to its permanent location -- if verification succeeds. diff --git a/hackage-security/hackage-security/src/Hackage/Security/Client/Repository/Cache.hs b/hackage-security/hackage-security/src/Hackage/Security/Client/Repository/Cache.hs --- a/hackage-security/hackage-security/src/Hackage/Security/Client/Repository/Cache.hs +++ b/hackage-security/hackage-security/src/Hackage/Security/Client/Repository/Cache.hs @@ -15,6 +15,7 @@ , lockCacheWithLogger ) where +import MyPrelude import Control.Exception import Control.Monad import Control.Monad.IO.Class diff --git a/hackage-security/hackage-security/src/Hackage/Security/Client/Repository/HttpLib.hs b/hackage-security/hackage-security/src/Hackage/Security/Client/Repository/HttpLib.hs --- a/hackage-security/hackage-security/src/Hackage/Security/Client/Repository/HttpLib.hs +++ b/hackage-security/hackage-security/src/Hackage/Security/Client/Repository/HttpLib.hs @@ -11,6 +11,7 @@ , bodyReaderFromBS ) where +import MyPrelude import Data.IORef import Network.URI hiding (uriPath, path) import qualified Data.ByteString as BS @@ -44,7 +45,7 @@ -- HTTP servers are normally expected to respond to a range request with -- a "206 Partial Content" response. However, servers can respond with a -- "200 OK" response, sending the entire file instead (for instance, this - -- may happen for servers that don't actually support range rqeuests, but + -- may happen for servers that don't actually support range requests, but -- for which we optimistically assumed they did). Implementations of -- 'HttpLib' may accept such a response and inform the @hackage-security@ -- library that the whole file is being returned; the security library can diff --git a/hackage-security/hackage-security/src/Hackage/Security/Client/Repository/Local.hs b/hackage-security/hackage-security/src/Hackage/Security/Client/Repository/Local.hs --- a/hackage-security/hackage-security/src/Hackage/Security/Client/Repository/Local.hs +++ b/hackage-security/hackage-security/src/Hackage/Security/Client/Repository/Local.hs @@ -5,6 +5,7 @@ , withRepository ) where +import MyPrelude import Hackage.Security.Client.Formats import Hackage.Security.Client.Repository import Hackage.Security.Client.Repository.Cache diff --git a/hackage-security/hackage-security/src/Hackage/Security/Client/Repository/Remote.hs b/hackage-security/hackage-security/src/Hackage/Security/Client/Repository/Remote.hs --- a/hackage-security/hackage-security/src/Hackage/Security/Client/Repository/Remote.hs +++ b/hackage-security/hackage-security/src/Hackage/Security/Client/Repository/Remote.hs @@ -27,9 +27,11 @@ , fileSizeWithinBounds ) where +import MyPrelude import Control.Concurrent import Control.Exception -import Control.Monad.Cont +import Control.Monad (when, unless) +import Control.Monad.IO.Class (MonadIO) import Data.List (nub, intercalate) import Data.Typeable import Network.URI hiding (uriPath, path) @@ -336,7 +338,7 @@ unless rangeSupport $ exit $ CannotUpdate hasGz UpdateImpossibleUnsupported -- We must already have a local file to be updated - mCachedIndex <- lift $ Cache.getCachedIndex cfgCache (hasFormatGet hasGz) + mCachedIndex <- liftIO $ Cache.getCachedIndex cfgCache (hasFormatGet hasGz) cachedIndex <- case mCachedIndex of Nothing -> exit $ CannotUpdate hasGz UpdateImpossibleNoLocalCopy Just fp -> return fp diff --git a/hackage-security/hackage-security/src/Hackage/Security/Client/Verify.hs b/hackage-security/hackage-security/src/Hackage/Security/Client/Verify.hs --- a/hackage-security/hackage-security/src/Hackage/Security/Client/Verify.hs +++ b/hackage-security/hackage-security/src/Hackage/Security/Client/Verify.hs @@ -10,8 +10,11 @@ , liftIO ) where +import MyPrelude import Control.Exception -import Control.Monad.Reader +import Control.Monad (join, void) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Reader (ReaderT, runReaderT, ask) import Data.IORef import Hackage.Security.Util.IO diff --git a/hackage-security/hackage-security/src/Hackage/Security/JSON.hs b/hackage-security/hackage-security/src/Hackage/Security/JSON.hs --- a/hackage-security/hackage-security/src/Hackage/Security/JSON.hs +++ b/hackage-security/hackage-security/src/Hackage/Security/JSON.hs @@ -38,10 +38,12 @@ , module Hackage.Security.Util.JSON ) where +import MyPrelude import Control.Arrow (first, second) import Control.Exception -import Control.Monad.Except -import Control.Monad.Reader +import Control.Monad (unless, liftM) +import Control.Monad.Except (MonadError, Except, ExceptT, runExcept, runExceptT, throwError) +import Control.Monad.Reader (MonadReader, Reader, runReader, local, ask) import Data.Functor.Identity import Data.Typeable (Typeable) import qualified Data.ByteString.Lazy as BS.L diff --git a/hackage-security/hackage-security/src/Hackage/Security/Key.hs b/hackage-security/hackage-security/src/Hackage/Security/Key.hs --- a/hackage-security/hackage-security/src/Hackage/Security/Key.hs +++ b/hackage-security/hackage-security/src/Hackage/Security/Key.hs @@ -25,6 +25,7 @@ , verify ) where +import MyPrelude import Control.Monad import Data.Functor.Identity import Data.Typeable (Typeable) @@ -144,8 +145,8 @@ -- | The key ID of a key, by definition, is the hexdigest of the SHA-256 hash of -- the canonical JSON form of the key where the private object key is excluded. -- --- NOTE: The FromJSON and ToJSON instances for KeyId are ntentially omitted. Use --- writeKeyAsId instead. +-- NOTE: The FromJSON and ToJSON instances for KeyId are intentionally omitted. +-- Use writeKeyAsId instead. newtype KeyId = KeyId { keyIdString :: String } deriving (Show, Eq, Ord) diff --git a/hackage-security/hackage-security/src/Hackage/Security/Key/Env.hs b/hackage-security/hackage-security/src/Hackage/Security/Key/Env.hs --- a/hackage-security/hackage-security/src/Hackage/Security/Key/Env.hs +++ b/hackage-security/hackage-security/src/Hackage/Security/Key/Env.hs @@ -12,7 +12,7 @@ , union ) where -import Prelude hiding (lookup, null) +import MyPrelude hiding (lookup, null) import Control.Monad import Data.Map (Map) import qualified Data.Map as Map diff --git a/hackage-security/hackage-security/src/Hackage/Security/TUF/Common.hs b/hackage-security/hackage-security/src/Hackage/Security/TUF/Common.hs --- a/hackage-security/hackage-security/src/Hackage/Security/TUF/Common.hs +++ b/hackage-security/hackage-security/src/Hackage/Security/TUF/Common.hs @@ -6,6 +6,7 @@ , KeyThreshold(..) ) where +import MyPrelude import Hackage.Security.JSON {------------------------------------------------------------------------------- diff --git a/hackage-security/hackage-security/src/Hackage/Security/TUF/FileInfo.hs b/hackage-security/hackage-security/src/Hackage/Security/TUF/FileInfo.hs --- a/hackage-security/hackage-security/src/Hackage/Security/TUF/FileInfo.hs +++ b/hackage-security/hackage-security/src/Hackage/Security/TUF/FileInfo.hs @@ -13,7 +13,7 @@ , Int54 ) where -import Prelude hiding (lookup) +import MyPrelude hiding (lookup) import Data.Map (Map) import qualified Crypto.Hash.SHA256 as SHA256 import qualified Data.Map as Map diff --git a/hackage-security/hackage-security/src/Hackage/Security/TUF/FileMap.hs b/hackage-security/hackage-security/src/Hackage/Security/TUF/FileMap.hs --- a/hackage-security/hackage-security/src/Hackage/Security/TUF/FileMap.hs +++ b/hackage-security/hackage-security/src/Hackage/Security/TUF/FileMap.hs @@ -18,7 +18,7 @@ , fileMapChanges ) where -import Prelude hiding (lookup) +import MyPrelude hiding (lookup) import Control.Arrow (second) import Data.Map (Map) import qualified Data.Map as Map diff --git a/hackage-security/hackage-security/src/Hackage/Security/TUF/Header.hs b/hackage-security/hackage-security/src/Hackage/Security/TUF/Header.hs --- a/hackage-security/hackage-security/src/Hackage/Security/TUF/Header.hs +++ b/hackage-security/hackage-security/src/Hackage/Security/TUF/Header.hs @@ -12,6 +12,7 @@ , versionIncrement ) where +import MyPrelude import Data.Time import Data.Typeable (Typeable) @@ -35,7 +36,7 @@ -- every file update. -- -- 'Show' and 'Read' instance are defined in terms of the underlying 'Int' --- (this is use for example by hackage during the backup process). +-- (this is used for example by Hackage during the backup process). newtype FileVersion = FileVersion Int54 deriving (Eq, Ord, Typeable) @@ -54,7 +55,7 @@ newtype FileExpires = FileExpires (Maybe UTCTime) deriving (Eq, Ord, Show, Typeable) --- | Occassionally it is useful to read only a header from a file. +-- | Occasionally it is useful to read only a header from a file. -- -- 'HeaderOnly' intentionally only has a 'FromJSON' instance (no 'ToJSON'). data Header = Header { diff --git a/hackage-security/hackage-security/src/Hackage/Security/TUF/Layout/Cache.hs b/hackage-security/hackage-security/src/Hackage/Security/TUF/Layout/Cache.hs --- a/hackage-security/hackage-security/src/Hackage/Security/TUF/Layout/Cache.hs +++ b/hackage-security/hackage-security/src/Hackage/Security/TUF/Layout/Cache.hs @@ -4,6 +4,7 @@ , cabalCacheLayout ) where +import MyPrelude import Hackage.Security.TUF.Paths import Hackage.Security.Util.Path @@ -14,7 +15,7 @@ -- | Location of the various files we cache -- -- Although the generic TUF algorithms do not care how we organize the cache, --- we nonetheless specity this here because as long as there are tools which +-- we nonetheless specify this here because as long as there are tools which -- access files in the cache directly we need to define the cache layout. -- See also comments for 'defaultCacheLayout'. data CacheLayout = CacheLayout { diff --git a/hackage-security/hackage-security/src/Hackage/Security/TUF/Layout/Index.hs b/hackage-security/hackage-security/src/Hackage/Security/TUF/Layout/Index.hs --- a/hackage-security/hackage-security/src/Hackage/Security/TUF/Layout/Index.hs +++ b/hackage-security/hackage-security/src/Hackage/Security/TUF/Layout/Index.hs @@ -9,6 +9,7 @@ , indexLayoutPkgPrefs ) where +import MyPrelude import Distribution.Package import Distribution.Text diff --git a/hackage-security/hackage-security/src/Hackage/Security/TUF/Layout/Repo.hs b/hackage-security/hackage-security/src/Hackage/Security/TUF/Layout/Repo.hs --- a/hackage-security/hackage-security/src/Hackage/Security/TUF/Layout/Repo.hs +++ b/hackage-security/hackage-security/src/Hackage/Security/TUF/Layout/Repo.hs @@ -5,6 +5,7 @@ , cabalLocalRepoLayout ) where +import MyPrelude import Distribution.Package import Distribution.Text diff --git a/hackage-security/hackage-security/src/Hackage/Security/TUF/Mirrors.hs b/hackage-security/hackage-security/src/Hackage/Security/TUF/Mirrors.hs --- a/hackage-security/hackage-security/src/Hackage/Security/TUF/Mirrors.hs +++ b/hackage-security/hackage-security/src/Hackage/Security/TUF/Mirrors.hs @@ -9,6 +9,7 @@ , describeMirror ) where +import MyPrelude import Control.Monad.Except import Network.URI diff --git a/hackage-security/hackage-security/src/Hackage/Security/TUF/Paths.hs b/hackage-security/hackage-security/src/Hackage/Security/TUF/Paths.hs --- a/hackage-security/hackage-security/src/Hackage/Security/TUF/Paths.hs +++ b/hackage-security/hackage-security/src/Hackage/Security/TUF/Paths.hs @@ -14,6 +14,7 @@ , anchorCachePath ) where +import MyPrelude import Hackage.Security.Util.Path import Hackage.Security.Util.Pretty diff --git a/hackage-security/hackage-security/src/Hackage/Security/TUF/Patterns.hs b/hackage-security/hackage-security/src/Hackage/Security/TUF/Patterns.hs --- a/hackage-security/hackage-security/src/Hackage/Security/TUF/Patterns.hs +++ b/hackage-security/hackage-security/src/Hackage/Security/TUF/Patterns.hs @@ -1,7 +1,7 @@ -- | Patterns and replacements -- -- NOTE: This module was developed to prepare for proper delegation (#39). --- It is currently unusued. +-- It is currently unused. {-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE DeriveLift #-} @@ -26,7 +26,8 @@ , qqd ) where -import Control.Monad.Except +import MyPrelude +import Control.Monad (guard) import Language.Haskell.TH (Q, Exp) import System.FilePath.Posix import qualified Language.Haskell.TH.Syntax as TH diff --git a/hackage-security/hackage-security/src/Hackage/Security/TUF/Root.hs b/hackage-security/hackage-security/src/Hackage/Security/TUF/Root.hs --- a/hackage-security/hackage-security/src/Hackage/Security/TUF/Root.hs +++ b/hackage-security/hackage-security/src/Hackage/Security/TUF/Root.hs @@ -6,6 +6,7 @@ , RoleSpec(..) ) where +import MyPrelude import Hackage.Security.JSON import Hackage.Security.Key import Hackage.Security.Key.Env (KeyEnv) diff --git a/hackage-security/hackage-security/src/Hackage/Security/TUF/Signed.hs b/hackage-security/hackage-security/src/Hackage/Security/TUF/Signed.hs --- a/hackage-security/hackage-security/src/Hackage/Security/TUF/Signed.hs +++ b/hackage-security/hackage-security/src/Hackage/Security/TUF/Signed.hs @@ -27,6 +27,7 @@ , toPreSignatures ) where +import MyPrelude import Control.Monad import Data.Functor.Identity import qualified Data.ByteString as BS diff --git a/hackage-security/hackage-security/src/Hackage/Security/TUF/Snapshot.hs b/hackage-security/hackage-security/src/Hackage/Security/TUF/Snapshot.hs --- a/hackage-security/hackage-security/src/Hackage/Security/TUF/Snapshot.hs +++ b/hackage-security/hackage-security/src/Hackage/Security/TUF/Snapshot.hs @@ -3,6 +3,7 @@ Snapshot(..) ) where +import MyPrelude import Control.Monad.Except import Control.Monad.Reader diff --git a/hackage-security/hackage-security/src/Hackage/Security/TUF/Targets.hs b/hackage-security/hackage-security/src/Hackage/Security/TUF/Targets.hs --- a/hackage-security/hackage-security/src/Hackage/Security/TUF/Targets.hs +++ b/hackage-security/hackage-security/src/Hackage/Security/TUF/Targets.hs @@ -8,6 +8,7 @@ , targetsLookup ) where +import MyPrelude import Hackage.Security.JSON import Hackage.Security.Key import Hackage.Security.Key.Env (KeyEnv) diff --git a/hackage-security/hackage-security/src/Hackage/Security/TUF/Timestamp.hs b/hackage-security/hackage-security/src/Hackage/Security/TUF/Timestamp.hs --- a/hackage-security/hackage-security/src/Hackage/Security/TUF/Timestamp.hs +++ b/hackage-security/hackage-security/src/Hackage/Security/TUF/Timestamp.hs @@ -3,6 +3,7 @@ Timestamp(..) ) where +import MyPrelude import Control.Monad.Except import Control.Monad.Reader diff --git a/hackage-security/hackage-security/src/Hackage/Security/Trusted.hs b/hackage-security/hackage-security/src/Hackage/Security/Trusted.hs --- a/hackage-security/hackage-security/src/Hackage/Security/Trusted.hs +++ b/hackage-security/hackage-security/src/Hackage/Security/Trusted.hs @@ -12,6 +12,7 @@ , trustedFileInfoEqual ) where +import MyPrelude import Data.Function (on) import Data.Time import Hackage.Security.TUF diff --git a/hackage-security/hackage-security/src/Hackage/Security/Trusted/TCB.hs b/hackage-security/hackage-security/src/Hackage/Security/Trusted/TCB.hs --- a/hackage-security/hackage-security/src/Hackage/Security/Trusted/TCB.hs +++ b/hackage-security/hackage-security/src/Hackage/Security/Trusted/TCB.hs @@ -26,8 +26,10 @@ #endif ) where +import MyPrelude import Control.Exception -import Control.Monad.Except +import Control.Monad (when, unless) +import Control.Monad.Except (Except, runExcept, throwError) import Data.Typeable import Data.Time import Hackage.Security.TUF diff --git a/hackage-security/hackage-security/src/Hackage/Security/Util/Base64.hs b/hackage-security/hackage-security/src/Hackage/Security/Util/Base64.hs --- a/hackage-security/hackage-security/src/Hackage/Security/Util/Base64.hs +++ b/hackage-security/hackage-security/src/Hackage/Security/Util/Base64.hs @@ -4,6 +4,7 @@ , toByteString ) where +import MyPrelude import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as C8 -- only called on B64-enc strings import qualified Data.ByteString.Base64 as B64 diff --git a/hackage-security/hackage-security/src/Hackage/Security/Util/Checked.hs b/hackage-security/hackage-security/src/Hackage/Security/Util/Checked.hs --- a/hackage-security/hackage-security/src/Hackage/Security/Util/Checked.hs +++ b/hackage-security/hackage-security/src/Hackage/Security/Util/Checked.hs @@ -25,6 +25,7 @@ , internalError ) where +import MyPrelude import Control.Exception (Exception, IOException) import qualified Control.Exception as Base import Data.Typeable (Typeable) diff --git a/hackage-security/hackage-security/src/Hackage/Security/Util/Exit.hs b/hackage-security/hackage-security/src/Hackage/Security/Util/Exit.hs --- a/hackage-security/hackage-security/src/Hackage/Security/Util/Exit.hs +++ b/hackage-security/hackage-security/src/Hackage/Security/Util/Exit.hs @@ -1,6 +1,8 @@ module Hackage.Security.Util.Exit where -import Control.Monad.Except +import MyPrelude +import Control.Monad (liftM) +import Control.Monad.Except (ExceptT, runExceptT, throwError) {------------------------------------------------------------------------------- Auxiliary: multiple exit points diff --git a/hackage-security/hackage-security/src/Hackage/Security/Util/IO.hs b/hackage-security/hackage-security/src/Hackage/Security/Util/IO.hs --- a/hackage-security/hackage-security/src/Hackage/Security/Util/IO.hs +++ b/hackage-security/hackage-security/src/Hackage/Security/Util/IO.hs @@ -9,6 +9,7 @@ , timedIO ) where +import MyPrelude import Control.Concurrent (threadDelay) import Control.Exception import Data.Time diff --git a/hackage-security/hackage-security/src/Hackage/Security/Util/JSON.hs b/hackage-security/hackage-security/src/Hackage/Security/Util/JSON.hs --- a/hackage-security/hackage-security/src/Hackage/Security/Util/JSON.hs +++ b/hackage-security/hackage-security/src/Hackage/Security/Util/JSON.hs @@ -23,6 +23,7 @@ , Int54 ) where +import MyPrelude import Control.Monad (liftM) import Data.Maybe (catMaybes) import Data.Map (Map) diff --git a/hackage-security/hackage-security/src/Hackage/Security/Util/Lens.hs b/hackage-security/hackage-security/src/Hackage/Security/Util/Lens.hs --- a/hackage-security/hackage-security/src/Hackage/Security/Util/Lens.hs +++ b/hackage-security/hackage-security/src/Hackage/Security/Util/Lens.hs @@ -14,6 +14,7 @@ , set ) where +import MyPrelude import Control.Applicative import Data.Functor.Identity diff --git a/hackage-security/hackage-security/src/Hackage/Security/Util/Path.hs b/hackage-security/hackage-security/src/Hackage/Security/Util/Path.hs --- a/hackage-security/hackage-security/src/Hackage/Security/Util/Path.hs +++ b/hackage-security/hackage-security/src/Hackage/Security/Util/Path.hs @@ -83,6 +83,7 @@ , IO.hSeek ) where +import MyPrelude import Control.Monad import Data.List (isPrefixOf) import System.IO (IOMode(..), BufferMode(..), Handle, SeekMode(..)) @@ -294,7 +295,7 @@ fromAbsoluteFilePath :: FilePath -> Path Absolute fromAbsoluteFilePath fp | FP.Native.isAbsolute fp = mkPathNative fp - | otherwise = error "fromAbsoluteFilePath: not an absolute path" + | otherwise = error ("fromAbsoluteFilePath: not an absolute path: " ++ fp) {------------------------------------------------------------------------------- Wrappers around System.IO diff --git a/hackage-security/hackage-security/src/Hackage/Security/Util/Pretty.hs b/hackage-security/hackage-security/src/Hackage/Security/Util/Pretty.hs --- a/hackage-security/hackage-security/src/Hackage/Security/Util/Pretty.hs +++ b/hackage-security/hackage-security/src/Hackage/Security/Util/Pretty.hs @@ -3,6 +3,8 @@ Pretty(..) ) where +import MyPrelude + -- | Produce a human-readable string class Pretty a where pretty :: a -> String diff --git a/hackage-security/hackage-security/src/Hackage/Security/Util/Some.hs b/hackage-security/hackage-security/src/Hackage/Security/Util/Some.hs --- a/hackage-security/hackage-security/src/Hackage/Security/Util/Some.hs +++ b/hackage-security/hackage-security/src/Hackage/Security/Util/Some.hs @@ -19,6 +19,7 @@ #endif ) where +import MyPrelude #if MIN_VERSION_base(4,7,0) import Data.Typeable (Typeable) #else diff --git a/hackage-security/hackage-security/src/Hackage/Security/Util/Stack.hs b/hackage-security/hackage-security/src/Hackage/Security/Util/Stack.hs --- a/hackage-security/hackage-security/src/Hackage/Security/Util/Stack.hs +++ b/hackage-security/hackage-security/src/Hackage/Security/Util/Stack.hs @@ -3,6 +3,8 @@ (:-)(..) ) where +import MyPrelude + data h :- t = h :- t deriving (Eq, Show) infixr 5 :- diff --git a/hackage-security/hackage-security/src/Hackage/Security/Util/TypedEmbedded.hs b/hackage-security/hackage-security/src/Hackage/Security/Util/TypedEmbedded.hs --- a/hackage-security/hackage-security/src/Hackage/Security/Util/TypedEmbedded.hs +++ b/hackage-security/hackage-security/src/Hackage/Security/Util/TypedEmbedded.hs @@ -7,6 +7,8 @@ , AsType(..) ) where +import MyPrelude + -- | Type equality proofs -- -- This is a direct copy of "type-equality:Data.Type.Equality"; if we don't diff --git a/hackage-security/hackage-security/src/MyPrelude.hs b/hackage-security/hackage-security/src/MyPrelude.hs new file mode 100644 --- /dev/null +++ b/hackage-security/hackage-security/src/MyPrelude.hs @@ -0,0 +1,31 @@ +-- | Smooth over differences between various ghc versions by making older +-- preludes look like 4.8.0 +{-# LANGUAGE CPP #-} +module MyPrelude ( + module P +#if !MIN_VERSION_base(4,8,0) + , Applicative(..) + , Monoid(..) + , (<$>) + , (<$) + , Traversable(traverse) + , displayException +#endif + ) where + +#if MIN_VERSION_base(4,8,0) +import Prelude as P +#else +#if MIN_VERSION_base(4,6,0) +import Prelude as P +#else +import Prelude as P hiding (catch) +#endif +import Control.Applicative +import Control.Exception (Exception) +import Data.Monoid +import Data.Traversable (Traversable(traverse)) + +displayException :: Exception e => e -> String +displayException = show +#endif diff --git a/hackage-security/hackage-security/src/Prelude.hs b/hackage-security/hackage-security/src/Prelude.hs deleted file mode 100644 --- a/hackage-security/hackage-security/src/Prelude.hs +++ /dev/null @@ -1,32 +0,0 @@ --- | Smooth over differences between various ghc versions by making older --- preludes look like 4.8.0 -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE CPP #-} -module Prelude ( - module P -#if !MIN_VERSION_base(4,8,0) - , Applicative(..) - , Monoid(..) - , (<$>) - , (<$) - , Traversable(traverse) - , displayException -#endif - ) where - -#if MIN_VERSION_base(4,8,0) -import "base" Prelude as P -#else -#if MIN_VERSION_base(4,6,0) -import "base" Prelude as P -#else -import "base" Prelude as P hiding (catch) -#endif -import Control.Applicative -import Control.Exception (Exception) -import Data.Monoid -import Data.Traversable (Traversable(traverse)) - -displayException :: Exception e => e -> String -displayException = show -#endif diff --git a/hackage-security/hackage-security/src/Text/JSON/Canonical.hs b/hackage-security/hackage-security/src/Text/JSON/Canonical.hs --- a/hackage-security/hackage-security/src/Text/JSON/Canonical.hs +++ b/hackage-security/hackage-security/src/Text/JSON/Canonical.hs @@ -30,6 +30,7 @@ , prettyCanonicalJSON ) where +import MyPrelude import Text.ParserCombinators.Parsec ( CharParser, (<|>), (), many, between, sepBy , satisfy, char, string, digit, spaces diff --git a/hackage-security/precompute-fileinfo/precompute-fileinfo.cabal b/hackage-security/precompute-fileinfo/precompute-fileinfo.cabal --- a/hackage-security/precompute-fileinfo/precompute-fileinfo.cabal +++ b/hackage-security/precompute-fileinfo/precompute-fileinfo.cabal @@ -13,8 +13,11 @@ category: Distribution build-type: Simple cabal-version: >=1.10 -tested-with: GHC==8.6.4, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, - GHC==7.8.4, GHC==7.6.3, GHC==7.4.2 + +tested-with: + GHC==9.4.1, GHC==9.2.4, GHC==9.0.2, + GHC==8.10.7, GHC==8.8.4, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, + GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2 executable precompute-fileinfo main-is: Main.hs diff --git a/hackage-security/stack.yaml b/hackage-security/stack.yaml --- a/hackage-security/stack.yaml +++ b/hackage-security/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-7.14 +resolver: lts-18.23 packages: - example-client - hackage-repo-tool @@ -8,5 +8,11 @@ - hackage-security-curl - hackage-security-http-client - precompute-fileinfo + +flags: + hackage-repo-tool: + use-old-time: false + extra-deps: -- http-client-0.5.5 +- optparse-applicative-0.15.1.0@sha256:29ff6146aabf54d46c4c8788e8d1eadaea27c94f6d360c690c5f6c93dac4b07e,4810 + diff --git a/hackport.cabal b/hackport.cabal --- a/hackport.cabal +++ b/hackport.cabal @@ -1,21 +1,23 @@ cabal-version: 3.0 name: hackport -version: 0.7.3.1 +version: 0.8.0.0 license: GPL-3.0-or-later license-file: LICENSE author: Henning Günther, Duncan Coutts, Lennart Kolmodin maintainer: Gentoo Haskell team +copyright: Copyright 1999-2022 Gentoo Authors category: Distribution synopsis: Hackage and Portage integration tool +homepage: https://github.com/gentoo-haskell/hackport#readme description: A command line tool to manage an overlay of Gentoo ebuilds that are generated from a hackage repo of Cabal packages. tested-with: - , GHC == 8.6.5 , GHC == 8.8.4 , GHC == 8.10.7 , GHC == 9.0.2 + , GHC == 9.2.4 source-repository head type: git @@ -36,22 +38,39 @@ default: False manual: True +flag profile + description: Enable profiling flags + default: False + manual: True + -- Turn off all warnings (for external libs and doctests-v2) common no-warnings - ghc-options: -Wno-default + ghc-options: -Wno-default -Wno-incomplete-uni-patterns common warnings - ghc-options: -Wall + ghc-options: + -Wall + -- ghc-9.2 turns this on for -Wall, so let's enable it to be consistent + -- across ghc versions + -Wincomplete-uni-patterns + if flag(pedantic) ghc-options: -Werror -library hackport-external-libs-Cabal +------------------------------------------------------------------------------- +-- NOTE: The lists of modules for external libraries have optimized for the +-- smallest build footprint possible. You may need to uncomment modules as new +-- features are added to hackport. +------------------------------------------------------------------------------- + +library hackport-external-libs-Cabal-syntax import: no-warnings default-language: Haskell2010 - hs-source-dirs: cabal cabal/Cabal + hs-source-dirs: cabal/Cabal-syntax/src build-depends: , array >=0.4.0.1 + , array >=0.4.0.1 , base >=4.6 && <5 , binary >=0.7 , bytestring >=0.10.0.0 @@ -62,179 +81,254 @@ , mtl >=2.1 , parsec >=3.1.13.0 , pretty >=1.1.1 - , process >=1.1.0.2 , text >=1.2.3.0 , time >=1.4.0.1 , transformers >=0.4.1.0 - , unix >=2.6 - - other-extensions: - BangPatterns - CPP - DefaultSignatures - DeriveDataTypeable - DeriveFoldable - DeriveFunctor - DeriveGeneric - DeriveTraversable - ExistentialQuantification - FlexibleContexts - FlexibleInstances - GeneralizedNewtypeDeriving - ImplicitParams - KindSignatures - NondecreasingIndentation - OverloadedStrings - PatternSynonyms - RankNTypes - RecordWildCards - ScopedTypeVariables - StandaloneDeriving - Trustworthy - TypeFamilies - TypeOperators - TypeSynonymInstances - UndecidableInstances + , unix >=2.6.0.0 exposed-modules: + Distribution.Backpack Distribution.CabalSpecVersion Distribution.Compat.Binary Distribution.Compat.CharParsing - Distribution.Compat.Directory - Distribution.Compat.Environment + Distribution.Compat.DList + Distribution.Compat.Exception Distribution.Compat.Graph Distribution.Compat.Lens + Distribution.Compat.MonadFail + Distribution.Compat.Newtype Distribution.Compat.NonEmptySet - Distribution.Compat.Prelude.Internal - Distribution.Compat.Time + Distribution.Compat.Parsing + Distribution.Compat.Prelude + Distribution.Compat.Semigroup Distribution.Compat.Typeable Distribution.Compiler Distribution.FieldGrammar + Distribution.FieldGrammar.Class + Distribution.FieldGrammar.FieldDescrs Distribution.FieldGrammar.Newtypes + Distribution.FieldGrammar.Parsec + Distribution.FieldGrammar.Pretty Distribution.Fields + Distribution.Fields.ConfVar + Distribution.Fields.Field + Distribution.Fields.Lexer + Distribution.Fields.LexerMonad Distribution.Fields.ParseResult + Distribution.Fields.Parser + Distribution.Fields.Pretty Distribution.InstalledPackageInfo Distribution.License Distribution.ModuleName Distribution.Package Distribution.PackageDescription Distribution.PackageDescription.Configuration + Distribution.PackageDescription.FieldGrammar Distribution.PackageDescription.Parsec Distribution.PackageDescription.PrettyPrint + Distribution.PackageDescription.Quirks + Distribution.PackageDescription.Utils Distribution.Parsec Distribution.Parsec.Error + Distribution.Parsec.FieldLineStream Distribution.Parsec.Position Distribution.Parsec.Warning Distribution.Pretty - Distribution.ReadE - Distribution.Simple.Command - Distribution.Simple.Compiler - Distribution.Simple.Configure - Distribution.Simple.Flag - Distribution.Simple.InstallDirs - Distribution.Simple.PackageIndex - Distribution.Simple.Program - Distribution.Simple.Program.Db - Distribution.Simple.Program.Run - Distribution.Simple.Setup - Distribution.Simple.Utils Distribution.SPDX Distribution.SPDX.License + Distribution.SPDX.LicenseExceptionId + Distribution.SPDX.LicenseExpression + Distribution.SPDX.LicenseId + Distribution.SPDX.LicenseListVersion + Distribution.SPDX.LicenseReference Distribution.System Distribution.Text - Distribution.Types.AnnotatedId + Distribution.Types.AbiDependency + Distribution.Types.AbiHash + Distribution.Types.Benchmark + Distribution.Types.Benchmark.Lens + Distribution.Types.BenchmarkInterface + Distribution.Types.BenchmarkType + Distribution.Types.BuildInfo + Distribution.Types.BuildInfo.Lens + Distribution.Types.BuildType + Distribution.Types.Component Distribution.Types.ComponentId Distribution.Types.ComponentName Distribution.Types.ComponentRequestedSpec + Distribution.Types.CondTree + Distribution.Types.Condition + Distribution.Types.ConfVar Distribution.Types.Dependency + Distribution.Types.DependencyMap + Distribution.Types.ExeDependency + Distribution.Types.Executable + Distribution.Types.Executable.Lens + Distribution.Types.ExecutableScope + Distribution.Types.ExposedModule Distribution.Types.Flag - Distribution.Types.GivenComponent + Distribution.Types.ForeignLib + Distribution.Types.ForeignLib.Lens + Distribution.Types.ForeignLibOption + Distribution.Types.ForeignLibType + Distribution.Types.GenericPackageDescription + Distribution.Types.GenericPackageDescription.Lens + Distribution.Types.HookedBuildInfo + Distribution.Types.IncludeRenaming Distribution.Types.InstalledPackageInfo + Distribution.Types.InstalledPackageInfo.FieldGrammar + Distribution.Types.InstalledPackageInfo.Lens + Distribution.Types.LegacyExeDependency + Distribution.Types.Lens + Distribution.Types.Library + Distribution.Types.Library.Lens Distribution.Types.LibraryName + Distribution.Types.LibraryVisibility + Distribution.Types.Mixin + Distribution.Types.Module + Distribution.Types.ModuleReexport + Distribution.Types.ModuleRenaming Distribution.Types.MungedPackageId + Distribution.Types.MungedPackageName + Distribution.Types.PackageDescription + Distribution.Types.PackageDescription.Lens Distribution.Types.PackageId + Distribution.Types.PackageId.Lens Distribution.Types.PackageName Distribution.Types.PackageVersionConstraint + Distribution.Types.PkgconfigDependency + Distribution.Types.PkgconfigName + Distribution.Types.PkgconfigVersion + Distribution.Types.PkgconfigVersionRange + Distribution.Types.SetupBuildInfo + Distribution.Types.SetupBuildInfo.Lens Distribution.Types.SourceRepo + Distribution.Types.SourceRepo.Lens + Distribution.Types.TestSuite + Distribution.Types.TestSuite.Lens + Distribution.Types.TestSuiteInterface + Distribution.Types.TestType Distribution.Types.UnitId Distribution.Types.UnqualComponentName Distribution.Types.Version + Distribution.Types.VersionInterval +-- Distribution.Types.VersionInterval.Legacy Distribution.Types.VersionRange + Distribution.Types.VersionRange.Internal + Distribution.Utils.Base62 Distribution.Utils.Generic - Distribution.Utils.NubList + Distribution.Utils.MD5 + Distribution.Utils.Path Distribution.Utils.ShortText + Distribution.Utils.String Distribution.Utils.Structured - Distribution.Verbosity Distribution.Version Language.Haskell.Extension - other-modules: - Distribution.Backpack + other-extensions: + BangPatterns + CPP + DefaultSignatures + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + ExistentialQuantification + FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving + ImplicitParams + KindSignatures + NondecreasingIndentation + OverloadedStrings + PatternSynonyms + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + Trustworthy + TypeFamilies + TypeOperators + TypeSynonymInstances + UndecidableInstances + +library hackport-external-libs-Cabal + import: no-warnings + default-language: Haskell2010 + hs-source-dirs: cabal cabal/Cabal/src + build-depends: + , hackport-external-libs-Cabal-syntax + , array >=0.4.0.1 + , base >=4.6 && <5 + , bytestring >=0.10.0.0 + , containers >=0.5.0.0 + , deepseq >=1.3.0.1 + , directory >=1.2 + , filepath >=1.3.0.1 + , mtl >=2.1 + , parsec >=3.1.13.0 + , pretty >=1.1.1 + , process >=1.2.1.0 + , text >=1.2.3.0 + , time >=1.4.0.1 + , transformers >=0.4.1.0 + , unix >=2.6.0.0 + + exposed-modules: Distribution.Backpack.ComponentsGraph Distribution.Backpack.Configure Distribution.Backpack.ConfiguredComponent Distribution.Backpack.DescribeUnitId Distribution.Backpack.FullUnitId - Distribution.Backpack.Id Distribution.Backpack.LinkedComponent - Distribution.Backpack.MixLink Distribution.Backpack.ModSubst - Distribution.Backpack.ModuleScope Distribution.Backpack.ModuleShape - Distribution.Backpack.PreExistingComponent Distribution.Backpack.PreModuleShape - Distribution.Backpack.ReadyComponent - Distribution.Backpack.UnifyM - Distribution.Compat.Async - Distribution.Compat.CopyFile - Distribution.Compat.CreatePipe - Distribution.Compat.DList - Distribution.Compat.Exception +-- Distribution.Compat.CreatePipe + Distribution.Compat.Directory + Distribution.Compat.Environment Distribution.Compat.FilePath Distribution.Compat.Internal.TempFile - Distribution.Compat.MonadFail - Distribution.Compat.Newtype - Distribution.Compat.Parsing - Distribution.Compat.Prelude + Distribution.Compat.Prelude.Internal Distribution.Compat.Process - Distribution.Compat.Semigroup + Distribution.Compat.ResponseFile Distribution.Compat.Stack - Distribution.FieldGrammar.Class - Distribution.FieldGrammar.FieldDescrs - Distribution.FieldGrammar.Parsec - Distribution.FieldGrammar.Pretty - Distribution.Fields.ConfVar - Distribution.Fields.Field - Distribution.Fields.Lexer - Distribution.Fields.LexerMonad - Distribution.Fields.Parser - Distribution.Fields.Pretty - Distribution.GetOpt - Distribution.Lex + Distribution.Compat.Time Distribution.PackageDescription.Check - Distribution.PackageDescription.FieldGrammar - Distribution.PackageDescription.Quirks - Distribution.PackageDescription.Utils - Distribution.Parsec.FieldLineStream + Distribution.Make + Distribution.ReadE + Distribution.Simple + Distribution.Simple.Bench + Distribution.Simple.Build + Distribution.Simple.Build.Macros Distribution.Simple.Build.PathsModule Distribution.Simple.BuildPaths Distribution.Simple.BuildTarget Distribution.Simple.BuildToolDepends Distribution.Simple.CCompiler + Distribution.Simple.Command + Distribution.Simple.Compiler + Distribution.Simple.Configure + Distribution.Simple.Flag Distribution.Simple.GHC - Distribution.Simple.GHC.EnvironmentParser - Distribution.Simple.GHC.ImplInfo - Distribution.Simple.GHC.Internal Distribution.Simple.GHCJS Distribution.Simple.Glob + Distribution.Simple.Haddock Distribution.Simple.HaskellSuite Distribution.Simple.Hpc + Distribution.Simple.Install + Distribution.Simple.InstallDirs Distribution.Simple.InstallDirs.Internal Distribution.Simple.LocalBuildInfo + Distribution.Simple.PackageDescription + Distribution.Simple.PackageIndex Distribution.Simple.PreProcess Distribution.Simple.PreProcess.Unlit + Distribution.Simple.Program Distribution.Simple.Program.Ar Distribution.Simple.Program.Builtin + Distribution.Simple.Program.Db Distribution.Simple.Program.Find Distribution.Simple.Program.GHC Distribution.Simple.Program.HcPkg @@ -242,94 +336,97 @@ Distribution.Simple.Program.Internal Distribution.Simple.Program.Ld Distribution.Simple.Program.ResponseFile + Distribution.Simple.Program.Run + Distribution.Simple.Program.Script Distribution.Simple.Program.Strip Distribution.Simple.Program.Types + Distribution.Simple.Register + Distribution.Simple.Setup + Distribution.Simple.ShowBuildInfo + Distribution.Simple.SrcDist + Distribution.Simple.Test + Distribution.Simple.Test.ExeV10 Distribution.Simple.Test.LibV09 Distribution.Simple.Test.Log Distribution.Simple.UHC - Distribution.SPDX.LicenseExceptionId - Distribution.SPDX.LicenseExpression - Distribution.SPDX.LicenseId - Distribution.SPDX.LicenseListVersion - Distribution.SPDX.LicenseReference + Distribution.Simple.UserHooks + Distribution.Simple.Utils Distribution.TestSuite - Distribution.Types.AbiDependency - Distribution.Types.AbiHash - Distribution.Types.Benchmark - Distribution.Types.Benchmark.Lens - Distribution.Types.BenchmarkInterface - Distribution.Types.BenchmarkType - Distribution.Types.BuildInfo - Distribution.Types.BuildInfo.Lens - Distribution.Types.BuildType - Distribution.Types.Component + Distribution.Types.AnnotatedId Distribution.Types.ComponentInclude Distribution.Types.ComponentLocalBuildInfo - Distribution.Types.Condition - Distribution.Types.CondTree - Distribution.Types.ConfVar - Distribution.Types.DependencyMap - Distribution.Types.Executable - Distribution.Types.Executable.Lens - Distribution.Types.ExecutableScope - Distribution.Types.ExeDependency - Distribution.Types.ExposedModule - Distribution.Types.ForeignLib - Distribution.Types.ForeignLib.Lens - Distribution.Types.ForeignLibOption - Distribution.Types.ForeignLibType - Distribution.Types.GenericPackageDescription - Distribution.Types.GenericPackageDescription.Lens - Distribution.Types.HookedBuildInfo - Distribution.Types.IncludeRenaming - Distribution.Types.InstalledPackageInfo.FieldGrammar - Distribution.Types.InstalledPackageInfo.Lens - Distribution.Types.LegacyExeDependency - Distribution.Types.Lens - Distribution.Types.Library - Distribution.Types.Library.Lens - Distribution.Types.LibraryVisibility + Distribution.Types.DumpBuildInfo + Distribution.Types.GivenComponent Distribution.Types.LocalBuildInfo - Distribution.Types.Mixin - Distribution.Types.Module - Distribution.Types.ModuleReexport - Distribution.Types.ModuleRenaming - Distribution.Types.MungedPackageName - Distribution.Types.PackageDescription - Distribution.Types.PackageDescription.Lens - Distribution.Types.PackageId.Lens Distribution.Types.PackageName.Magic - Distribution.Types.PkgconfigDependency - Distribution.Types.PkgconfigName - Distribution.Types.PkgconfigVersion - Distribution.Types.PkgconfigVersionRange - Distribution.Types.SetupBuildInfo - Distribution.Types.SetupBuildInfo.Lens - Distribution.Types.SourceRepo.Lens Distribution.Types.TargetInfo - Distribution.Types.TestSuite - Distribution.Types.TestSuite.Lens - Distribution.Types.TestSuiteInterface - Distribution.Types.TestType - Distribution.Types.VersionInterval - Distribution.Types.VersionRange.Internal - Distribution.Utils.Base62 Distribution.Utils.IOData + Distribution.Utils.Json Distribution.Utils.LogProgress Distribution.Utils.MapAccum - Distribution.Utils.MD5 + Distribution.Utils.NubList Distribution.Utils.Progress - Distribution.Utils.String - Distribution.Utils.UnionFind + Distribution.Verbosity Distribution.Verbosity.Internal + + other-modules: + Distribution.Backpack.Id + Distribution.Backpack.MixLink + Distribution.Backpack.ModuleScope + Distribution.Backpack.PreExistingComponent + Distribution.Backpack.ReadyComponent + Distribution.Backpack.UnifyM + Distribution.Compat.Async + Distribution.Compat.CopyFile + Distribution.Compat.GetShortPathName +-- Distribution.Compat.SnocList + Distribution.GetOpt + Distribution.Lex + Distribution.Simple.Build.Macros.Z + Distribution.Simple.Build.PathsModule.Z + Distribution.Simple.GHC.EnvironmentParser + Distribution.Simple.GHC.Internal + Distribution.Simple.GHC.ImplInfo + Distribution.Utils.UnionFind + Distribution.ZinzaPrelude Paths_Cabal + other-extensions: + BangPatterns + CPP + DefaultSignatures + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + ExistentialQuantification + FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving + ImplicitParams + KindSignatures + LambdaCase + NondecreasingIndentation + OverloadedStrings + PatternSynonyms + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + Trustworthy + TypeFamilies + TypeOperators + TypeSynonymInstances + UndecidableInstances + library hackport-external-libs-hackage-security import: no-warnings default-language: Haskell2010 hs-source-dirs: hackage-security/hackage-security/src build-depends: - , base >=4.10 + , hackport-external-libs-Cabal-syntax + , base >=4.5 , base16-bytestring >=0.1.1 , base64-bytestring >=1.0 , bytestring >=0.9 @@ -339,10 +436,10 @@ , ed25519 >=0.0 , filepath >=1.2 , ghc-prim - , hackport-external-libs-Cabal + , lukko >=0.1 , mtl >=2.2 , network >=3.0 - , network-uri >=2.5 + , network-uri >=2.6 , parsec >=3.1 , pretty >=1.0 , tar >=0.5 @@ -351,58 +448,32 @@ , transformers >=0.3 , zlib >=0.5 - default-extensions: - NoMonomorphismRestriction - DefaultSignatures - DeriveDataTypeable - DeriveFunctor - FlexibleContexts - FlexibleInstances - GADTs - GeneralizedNewtypeDeriving - KindSignatures - MultiParamTypeClasses - NamedFieldPuns - RankNTypes - RecordWildCards - ScopedTypeVariables - StandaloneDeriving - TupleSections - TypeFamilies - TypeOperators - ViewPatterns - - other-extensions: - BangPatterns - CPP - OverlappingInstances - PackageImports - UndecidableInstances - exposed-modules: Hackage.Security.Client + Hackage.Security.Client.Formats + Hackage.Security.Client.Repository Hackage.Security.Client.Repository.Cache Hackage.Security.Client.Repository.HttpLib Hackage.Security.Client.Repository.Local Hackage.Security.Client.Repository.Remote + Hackage.Security.Client.Verify + Hackage.Security.JSON + Hackage.Security.Key.Env +-- Hackage.Security.Server + Hackage.Security.TUF.FileMap + Hackage.Security.Trusted Hackage.Security.Util.Checked Hackage.Security.Util.Path Hackage.Security.Util.Pretty Hackage.Security.Util.Some + Text.JSON.Canonical other-modules: - Hackage.Security.Client.Formats - Hackage.Security.Client.Repository - Hackage.Security.Client.Verify - Hackage.Security.JSON Hackage.Security.Key - Hackage.Security.Key.Env - Hackage.Security.Trusted Hackage.Security.Trusted.TCB Hackage.Security.TUF Hackage.Security.TUF.Common Hackage.Security.TUF.FileInfo - Hackage.Security.TUF.FileMap Hackage.Security.TUF.Header Hackage.Security.TUF.Layout.Cache Hackage.Security.TUF.Layout.Index @@ -422,17 +493,120 @@ Hackage.Security.Util.Lens Hackage.Security.Util.Stack Hackage.Security.Util.TypedEmbedded - Prelude - Text.JSON.Canonical + MyPrelude + default-extensions: + DefaultSignatures + DeriveDataTypeable + DeriveFunctor + FlexibleContexts + FlexibleInstances + GADTs + GeneralizedNewtypeDeriving + KindSignatures + MultiParamTypeClasses + NamedFieldPuns + NoImplicitPrelude + NoMonomorphismRestriction + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeFamilies + TypeOperators + ViewPatterns + + other-extensions: + BangPatterns + CPP + OverlappingInstances + PackageImports + UndecidableInstances + +library hackport-external-libs-cabal-install-solver + import: no-warnings + default-language: Haskell2010 + hs-source-dirs: + cabal/cabal-install-solver/src + cabal/cabal-install-solver/src-assertion + build-depends: + , hackport-external-libs-Cabal + , hackport-external-libs-Cabal-syntax + , array >=0.4 + , base >=4.10 + , bytestring >=0.10.6.0 + , containers >=0.5.6.2 + , edit-distance >=0.2.2 + , filepath >=1.4.0.0 + , mtl >=2.0 + , pretty >=1.1 + , transformers >=0.4.2.0 + + exposed-modules: + Distribution.Client.Utils.Assertion + Distribution.Solver.Compat.Prelude + Distribution.Solver.Modular + Distribution.Solver.Modular.Assignment + Distribution.Solver.Modular.Builder + Distribution.Solver.Modular.Configured + Distribution.Solver.Modular.ConfiguredConversion + Distribution.Solver.Modular.ConflictSet + Distribution.Solver.Modular.Cycles + Distribution.Solver.Modular.Dependency + Distribution.Solver.Modular.Explore + Distribution.Solver.Modular.Flag + Distribution.Solver.Modular.Index + Distribution.Solver.Modular.IndexConversion + Distribution.Solver.Modular.LabeledGraph + Distribution.Solver.Modular.Linking + Distribution.Solver.Modular.Log + Distribution.Solver.Modular.Message + Distribution.Solver.Modular.MessageUtils + Distribution.Solver.Modular.PSQ + Distribution.Solver.Modular.Package + Distribution.Solver.Modular.Preference + Distribution.Solver.Modular.RetryLog + Distribution.Solver.Modular.Solver + Distribution.Solver.Modular.Tree + Distribution.Solver.Modular.Validate + Distribution.Solver.Modular.Var + Distribution.Solver.Modular.Version + Distribution.Solver.Modular.WeightedPSQ + Distribution.Solver.Types.ComponentDeps + Distribution.Solver.Types.ConstraintSource + Distribution.Solver.Types.DependencyResolver + Distribution.Solver.Types.Flag + Distribution.Solver.Types.InstSolverPackage + Distribution.Solver.Types.InstalledPreference + Distribution.Solver.Types.LabeledPackageConstraint + Distribution.Solver.Types.OptionalStanza + Distribution.Solver.Types.PackageConstraint + Distribution.Solver.Types.PackageFixedDeps + Distribution.Solver.Types.PackageIndex + Distribution.Solver.Types.PackagePath + Distribution.Solver.Types.PackagePreferences + Distribution.Solver.Types.PkgConfigDb + Distribution.Solver.Types.Progress + Distribution.Solver.Types.ResolverPackage + Distribution.Solver.Types.Settings + Distribution.Solver.Types.SolverId + Distribution.Solver.Types.SolverPackage + Distribution.Solver.Types.SourcePackage + Distribution.Solver.Types.Variable + library hackport-external-libs-cabal-install import: no-warnings default-language: Haskell2010 - hs-source-dirs: cabal cabal/cabal-install + hs-source-dirs: cabal cabal/cabal-install/src build-depends: + , hackport-external-libs-Cabal + , hackport-external-libs-Cabal-syntax + , hackport-external-libs-hackage-security + , hackport-external-libs-cabal-install-solver + , base >=4.10 , array >=0.4 , async >=2.0 - , base >=4.8 , base16-bytestring >=0.1.1 , binary >=0.7.3 , bytestring >=0.10.6.0 @@ -442,64 +616,134 @@ , directory >=1.2.2.0 , echo >=0.1.3 , edit-distance >=0.2.2 + , exceptions >=0.10.4 , filepath >=1.4.0.0 - , hackport-external-libs-Cabal - , hackport-external-libs-hackage-security , hashable >=1.0 , HTTP >=4000.1.5 + , lukko >=0.1 , mtl >=2.0 - , network >=2.6 , network-uri >=2.6.0.2 , parsec >=3.1.13.0 , pretty >=1.1 - , process >=1.2.3.0 - , random >=1 + , process >=1.6.15.0 + , random >=1.2 , regex-base >=0.94.0.0 , regex-posix >=0.96.0.0 , resolv >=0.1.1 + , safe-exceptions >=0.1.7.0 , stm >=2.0 , tar >=0.5.0.3 , text >=1.2.3 , time >=1.5.0.1 - , transformers >=0.4.2.0 , zlib >=0.5.3 exposed-modules: - Distribution.Client.Config - Distribution.Client.GlobalFlags - Distribution.Client.IndexUtils - Distribution.Client.Setup - Distribution.Client.Types - Distribution.Client.Update - Distribution.Solver.Types.PackageIndex - Distribution.Solver.Types.SourcePackage - Paths_cabal_install - - other-modules: + Distribution.Client.BuildReports.Anonymous + Distribution.Client.BuildReports.Lens + Distribution.Client.BuildReports.Storage Distribution.Client.BuildReports.Types +-- Distribution.Client.BuildReports.Upload +-- Distribution.Client.Check +-- Distribution.Client.CmdBench +-- Distribution.Client.CmdBuild +-- Distribution.Client.CmdClean +-- Distribution.Client.CmdConfigure +-- Distribution.Client.CmdErrorMessages +-- Distribution.Client.CmdExec +-- Distribution.Client.CmdFreeze +-- Distribution.Client.CmdHaddock +-- Distribution.Client.CmdInstall Distribution.Client.CmdInstall.ClientInstallFlags +-- Distribution.Client.CmdInstall.ClientInstallTargetSelector +-- Distribution.Client.CmdLegacy +-- Distribution.Client.CmdListBin +-- Distribution.Client.CmdOutdated +-- Distribution.Client.CmdRepl +-- Distribution.Client.CmdRun +-- Distribution.Client.CmdSdist +-- Distribution.Client.CmdTest + Distribution.Client.CmdUpdate Distribution.Client.Compat.Directory + Distribution.Client.Compat.ExecutablePath Distribution.Client.Compat.Orphans Distribution.Client.Compat.Prelude +-- Distribution.Client.Compat.Process Distribution.Client.Compat.Semaphore + Distribution.Client.Config +-- Distribution.Client.Configure + Distribution.Client.Dependency Distribution.Client.Dependency.Types + Distribution.Client.DistDirLayout +-- Distribution.Client.Fetch Distribution.Client.FetchUtils + Distribution.Client.FileMonitor +-- Distribution.Client.Freeze Distribution.Client.GZipUtils +-- Distribution.Client.GenBounds +-- Distribution.Client.Get + Distribution.Client.Glob + Distribution.Client.GlobalFlags +-- Distribution.Client.Haddock Distribution.Client.HashValue Distribution.Client.HttpUtils + Distribution.Client.IndexUtils Distribution.Client.IndexUtils.ActiveRepos Distribution.Client.IndexUtils.IndexState Distribution.Client.IndexUtils.Timestamp +-- Distribution.Client.Init Distribution.Client.Init.Defaults +-- Distribution.Client.Init.FileCreators +-- Distribution.Client.Init.FlagExtractors +-- Distribution.Client.Init.Format +-- Distribution.Client.Init.Interactive.Command +-- Distribution.Client.Init.Licenses +-- Distribution.Client.Init.NonInteractive.Command +-- Distribution.Client.Init.NonInteractive.Heuristics +-- Distribution.Client.Init.Prompt +-- Distribution.Client.Init.Simple Distribution.Client.Init.Types +-- Distribution.Client.Init.Utils +-- Distribution.Client.Install + Distribution.Client.InstallPlan +-- Distribution.Client.InstallSymlink Distribution.Client.JobControl +-- Distribution.Client.List +-- Distribution.Client.Manpage Distribution.Client.ManpageFlags +-- Distribution.Client.Nix + Distribution.Client.NixStyleOptions + Distribution.Client.PackageHash Distribution.Client.ParseUtils + Distribution.Client.ProjectBuilding + Distribution.Client.ProjectBuilding.Types + Distribution.Client.ProjectConfig + Distribution.Client.ProjectConfig.Legacy + Distribution.Client.ProjectConfig.Types Distribution.Client.ProjectFlags + Distribution.Client.ProjectOrchestration + Distribution.Client.ProjectPlanOutput + Distribution.Client.ProjectPlanning + Distribution.Client.ProjectPlanning.Types + Distribution.Client.RebuildMonad +-- Distribution.Client.Reconfigure +-- Distribution.Client.Run +-- Distribution.Client.Sandbox +-- Distribution.Client.Sandbox.PackageEnvironment +-- Distribution.Client.SavedFlags +-- Distribution.Client.ScriptUtils Distribution.Client.Security.DNS Distribution.Client.Security.HTTP + Distribution.Client.Setup + Distribution.Client.SetupWrapper + Distribution.Client.SolverInstallPlan + Distribution.Client.SourceFiles + Distribution.Client.SrcDist + Distribution.Client.Store Distribution.Client.Tar + Distribution.Client.TargetProblem + Distribution.Client.TargetSelector Distribution.Client.Targets + Distribution.Client.Types Distribution.Client.Types.AllowNewer Distribution.Client.Types.BuildResults Distribution.Client.Types.ConfiguredId @@ -515,36 +759,35 @@ Distribution.Client.Types.SourcePackageDb Distribution.Client.Types.SourceRepo Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy +-- Distribution.Client.Upload Distribution.Client.Utils - Distribution.Client.World + Distribution.Client.Utils.Json + Distribution.Client.Utils.Parsec + Distribution.Client.VCS + Distribution.Client.Version +-- Distribution.Client.Win32SelfUpgrade Distribution.Deprecated.ParseUtils Distribution.Deprecated.ReadP Distribution.Deprecated.ViewAsFieldDescr - Distribution.Solver.Compat.Prelude - Distribution.Solver.Types.ComponentDeps - Distribution.Solver.Types.ConstraintSource - Distribution.Solver.Types.LabeledPackageConstraint - Distribution.Solver.Types.OptionalStanza - Distribution.Solver.Types.PackageConstraint - Distribution.Solver.Types.PackageFixedDeps - Distribution.Solver.Types.PackagePath - Distribution.Solver.Types.Settings + Paths_cabal_install library hackport-internal import: warnings default-language: Haskell2010 hs-source-dirs: src build-depends: - , async + , hackport-external-libs-Cabal-syntax + , hackport-external-libs-Cabal + , hackport-external-libs-cabal-install-solver + , hackport-external-libs-cabal-install , base + , async , bytestring , containers , deepseq , directory , extensible-exceptions , filepath - , hackport-external-libs-Cabal - , hackport-external-libs-cabal-install , lifted-base , monad-control , mtl @@ -617,17 +860,19 @@ executable hackport import: warnings ghc-options: -threaded +RTS -N -RTS -with-rtsopts=-N - ghc-prof-options: -caf-all -auto-all -rtsopts + if flag(profile) + ghc-prof-options: -caf-all -auto-all -rtsopts main-is: Main.hs default-language: Haskell2010 hs-source-dirs: exe build-depends: - , base - , directory - , filepath + , hackport-external-libs-Cabal-syntax , hackport-external-libs-Cabal , hackport-external-libs-cabal-install , hackport-internal + , base + , directory + , filepath , optparse-applicative , parsec , parser-combinators @@ -649,8 +894,11 @@ main-is: Main.hs hs-source-dirs: tests/resolveCat build-depends: - , array + , hackport-external-libs-Cabal-syntax + , hackport-external-libs-Cabal + , hackport-internal , base + , array , binary , bytestring , containers @@ -658,8 +906,6 @@ , directory , extensible-exceptions , filepath - , hackport-external-libs-Cabal - , hackport-internal , HUnit , parsec , pretty @@ -771,6 +1017,9 @@ test-suite doctests-v2 import: warnings + -- doctests-v2 is causing problems, looking for ghc lib and alex on + -- github CI. This may be fixable. + buildable: False type: exitcode-stdio-1.0 default-language: Haskell98 hs-source-dirs: tests/doctests-v2 @@ -805,17 +1054,18 @@ QuickCheck.Instances build-depends: - , async + , hackport-external-libs-Cabal-syntax + , hackport-external-libs-Cabal + , hackport-external-libs-cabal-install + , hackport-internal , base + , async , bytestring , containers , deepseq , directory , extensible-exceptions , filepath - , hackport-external-libs-Cabal - , hackport-external-libs-cabal-install - , hackport-internal , hspec >=2.0 , network-uri , parallel diff --git a/src/Hackport/Command/List.hs b/src/Hackport/Command/List.hs --- a/src/Hackport/Command/List.hs +++ b/src/Hackport/Command/List.hs @@ -20,7 +20,7 @@ listAction :: Env ListEnv () listAction = do (GlobalEnv verbosity _ _, ListEnv pkgList) <- ask - withHackportContext $ \repoContext -> do + withHackportContext $ \_ repoContext -> do overlayPath <- getOverlayPath index <- fmap CabalInstall.packageIndex $ liftIO $ CabalInstall.getSourcePackages verbosity repoContext diff --git a/src/Hackport/Command/MakeEbuild.hs b/src/Hackport/Command/MakeEbuild.hs --- a/src/Hackport/Command/MakeEbuild.hs +++ b/src/Hackport/Command/MakeEbuild.hs @@ -2,7 +2,7 @@ ( makeEbuildAction ) where -import qualified Distribution.PackageDescription.Parsec as Cabal +import qualified Distribution.Simple.PackageDescription as Cabal import Distribution.Parsec (simpleParsec) import qualified Distribution.Verbosity as V diff --git a/src/Hackport/Command/Merge.hs b/src/Hackport/Command/Merge.hs --- a/src/Hackport/Command/Merge.hs +++ b/src/Hackport/Command/Merge.hs @@ -9,5 +9,5 @@ mergeAction :: Env MergeEnv () mergeAction = askEnv >>= \(MergeEnv flags pkg) -> do - withHackportContext $ \repoContext -> + withHackportContext $ \_ repoContext -> merge repoContext pkg flags diff --git a/src/Hackport/Command/Status.hs b/src/Hackport/Command/Status.hs --- a/src/Hackport/Command/Status.hs +++ b/src/Hackport/Command/Status.hs @@ -8,4 +8,4 @@ import Hackport.Util statusAction :: Env StatusEnv () -statusAction = withHackportContext runStatus +statusAction = withHackportContext (\_ -> runStatus) diff --git a/src/Hackport/Command/Update.hs b/src/Hackport/Command/Update.hs --- a/src/Hackport/Command/Update.hs +++ b/src/Hackport/Command/Update.hs @@ -2,15 +2,43 @@ ( updateAction ) where -import Distribution.Simple.Command (CommandUI(..)) -import qualified Distribution.Client.Setup as CabalInstall -import qualified Distribution.Client.Update as CabalInstall +import qualified Distribution.Client.CmdUpdate as CabalInstall +import Distribution.Client.Compat.Prelude (Verbosity) +import Distribution.Client.NixStyleOptions + (NixStyleFlags(configFlags, projectFlags), defaultNixStyleFlags) +import Distribution.Client.ProjectFlags (ProjectFlags(flagIgnoreProject)) +import Distribution.Client.Setup (ConfigFlags(configVerbosity), GlobalFlags(globalRemoteRepos)) +import Distribution.Simple.Flag (Flag(Flag)) +import Distribution.Utils.NubList (toNubList) + import Hackport.Util (withHackportContext) import Hackport.Env updateAction :: Env env () updateAction = askGlobalEnv >>= \(GlobalEnv verbosity _ _) -> - withHackportContext $ \repoContext -> do - let updateFlags = commandDefaultFlags CabalInstall.updateCommand - liftIO $ CabalInstall.update verbosity updateFlags repoContext + withHackportContext $ \globalFlags _repoContext -> do + let nixFlags = ignoreProjectInNixFlags + $ addVerbosityToNixFlags verbosity (defaultNixStyleFlags ()) + + -- We need to unset the globalRemoteRepos set in 'withHackportContext' or + -- we get a duplicate hackage repo. This creates a "file is locked" error. + -- TODO: The cabal-install code needs to be examined further to see if + -- there is a better way to do this (starting with Distribution.Client.CmdUpdate) + let globalFlags' = globalFlags { globalRemoteRepos = toNubList [] } + + liftIO $ CabalInstall.updateAction nixFlags [] globalFlags' + +-- | There is no verbosity argument for 'CabalInstall.updateAction'. It expects +-- the verbosity to be passed in via 'NixStyleFlags'. +addVerbosityToNixFlags :: Verbosity -> NixStyleFlags a -> NixStyleFlags a +addVerbosityToNixFlags v flags = + let cFlags = configFlags flags + in flags { configFlags = cFlags { configVerbosity = Flag v } } + +-- | Without this it tries to treat the current directory as a cabal project, +-- complete with a @dist-newstyle@ directory. +ignoreProjectInNixFlags :: NixStyleFlags a -> NixStyleFlags a +ignoreProjectInNixFlags flags = + let pFlags = projectFlags flags + in flags { projectFlags = pFlags { flagIgnoreProject = Flag True } } diff --git a/src/Hackport/Util.hs b/src/Hackport/Util.hs --- a/src/Hackport/Util.hs +++ b/src/Hackport/Util.hs @@ -33,7 +33,9 @@ warn verbosity $ "Looks like an invalid portage directory: " ++ portagePath return portagePath -withHackportContext :: (DCG.RepoContext -> Env env a) -> Env env a +-- Some commands (e.g. "update") need access to the 'DCG.GlobalFlags', so we pass +-- them in as a part of the callback. +withHackportContext :: (DCG.GlobalFlags -> DCG.RepoContext -> Env env a) -> Env env a withHackportContext callback = do (GlobalEnv verbosity _ _, _) <- ask overlayPath <- getOverlayPath @@ -43,7 +45,7 @@ } control $ \runInIO -> DCG.withRepoContext verbosity flags - $ runInIO . (callback <=< restoreM) + $ runInIO . (callback flags <=< restoreM) -- | Default remote repository. Defaults to [hackage](hackage.haskell.org). defaultRemoteRepo :: DCT.RemoteRepo diff --git a/src/Merge/Dependencies.hs b/src/Merge/Dependencies.hs --- a/src/Merge/Dependencies.hs +++ b/src/Merge/Dependencies.hs @@ -5,7 +5,12 @@ Merge a package from @hackage@ to an ebuild. -} + {-# LANGUAGE CPP #-} + +-- TODO: Rearrange things so we don't have to disable this warning +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + module Merge.Dependencies ( EDep(..) , RetroPackageDescription(..) diff --git a/src/Portage/Dependency/Normalize.hs b/src/Portage/Dependency/Normalize.hs --- a/src/Portage/Dependency/Normalize.hs +++ b/src/Portage/Dependency/Normalize.hs @@ -1,3 +1,7 @@ + +-- TODO: Rearrange things so we don't have to disable this warning +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + module Portage.Dependency.Normalize ( normalize_depend diff --git a/src/Portage/GHCCore.hs b/src/Portage/GHCCore.hs --- a/src/Portage/GHCCore.hs +++ b/src/Portage/GHCCore.hs @@ -60,7 +60,7 @@ , ([8,8,4], Cabal.mkVersion [3,0,1,0]) , ([8,10,1], Cabal.mkVersion [3,2,0,0]) , ([8,10,4], Cabal.mkVersion [3,2,1,0]) - , ([9,0,2], Cabal.mkVersion [3,4,1,0]) + , ([9,0,2], Cabal.mkVersion [3,4,1,0]) ] platform :: Platform @@ -200,7 +200,7 @@ , p "mtl" [2,2,2] -- used by exceptions , p "parsec" [3,1,14,0] -- used by exceptions , p "pretty" [1,1,3,6] - , p "process" [1,6,13,2] +-- , p "process" [1,6,13,2] package is upgradeable -- , p "stm" [2,5,0,0] package is upgradeable(?) , p "template-haskell" [2,17,0,0] -- used by libghc , p "terminfo" [0,4,1,5] -- used by libghc @@ -235,7 +235,7 @@ , p "mtl" [2,2,2] -- used by exceptions in ghc-9.0.2 , p "parsec" [3,1,14,0] -- used by exceptions in ghc-9.0.2 , p "pretty" [1,1,3,6] - , p "process" [1,6,9,0] +-- , p "process" [1,6,9,0] package is upgradeable -- , p "stm" [2,5,0,0] package is upgradeable(?) , p "template-haskell" [2,16,0,0] -- used by libghc , p "terminfo" [0,4,1,4] -- used by libghc in ghc-9.0.2 @@ -270,7 +270,7 @@ , p "mtl" [2,2,2] -- used by libghc in ghc-9.0.2 , p "parsec" [3,1,14,0] -- used by libghc in ghc-9.0.2 , p "pretty" [1,1,3,6] - , p "process" [1,6,8,2] +-- , p "process" [1,6,8,2] package is upgradeable -- , p "stm" [2,5,0,0] package is upgradeable(?) , p "template-haskell" [2,16,0,0] -- used by libghc , p "terminfo" [0,4,1,4] -- used by libghc in ghc-9.0.2 @@ -303,7 +303,7 @@ , p "mtl" [2,2,2] -- used by exceptions in ghc-9.0.2 , p "parsec" [3,1,14,0] -- used by exceptions in ghc-9.0.2 , p "pretty" [1,1,3,6] - , p "process" [1,6,9,0] +-- , p "process" [1,6,9,0] package is upgradeable -- , p "stm" [2,5,0,0] package is upgradeable(?) , p "template-haskell" [2,15,0,0] -- used by libghc , p "terminfo" [0,4,1,4] -- used by libghc in ghc-9.0.2 @@ -336,7 +336,7 @@ , p "mtl" [2,2,2] -- used by exceptions in ghc-9.0.2 , p "parsec" [3,1,14,0] -- used by exceptions in ghc-9.0.2 , p "pretty" [1,1,3,6] - , p "process" [1,6,8,0] +-- , p "process" [1,6,8,0] package is upgradeable -- , p "stm" [2,5,0,0] package is upgradeable(?) , p "template-haskell" [2,15,0,0] -- used by libghc , p "terminfo" [0,4,1,4] -- used by libghc in ghc-9.0.2 @@ -369,7 +369,7 @@ , p "mtl" [2,2,2] -- used by exceptions in ghc-9.0.2 , p "parsec" [3,1,14,0] -- used by exceptions in ghc-9.0.2 , p "pretty" [1,1,3,6] - , p "process" [1,6,5,1] +-- , p "process" [1,6,5,1] package is upgradeable -- , p "stm" [2,5,0,0] package is upgradeable(?) , p "template-haskell" [2,15,0,0] -- used by libghc , p "terminfo" [0,4,1,4] -- used by libghc in ghc-9.0.2 @@ -402,7 +402,7 @@ , p "mtl" [2,2,2] -- used by exceptions in ghc-9.0.2 , p "parsec" [3,1,13,0] -- used by exceptions in ghc-9.0.2 , p "pretty" [1,1,3,6] - , p "process" [1,6,5,0] +-- , p "process" [1,6,5,0] package is upgradeable -- , p "stm" [2,5,0,0] package is upgradeable(?) , p "template-haskell" [2,14,0,0] -- used by libghc , p "terminfo" [0,4,1,2] -- used by libghc in ghc-9.0.2 @@ -435,7 +435,7 @@ , p "mtl" [2,2,2] -- used by exceptions in ghc-9.0.2 , p "parsec" [3,1,13,0] -- used by exceptions in ghc-9.0.2 , p "pretty" [1,1,3,6] - , p "process" [1,6,3,0] +-- , p "process" [1,6,3,0] package is upgradeable -- , p "stm" [2,5,0,0] package is upgradeable(?) , p "template-haskell" [2,14,0,0] -- used by libghc , p "terminfo" [0,4,1,2] -- used by libghc in ghc-9.0.2 @@ -468,7 +468,7 @@ , p "mtl" [2,2,2] -- used by exceptions in ghc-9.0.2 , p "parsec" [3,1,13,0] -- used by exceptions in ghc-9.0.2 , p "pretty" [1,1,3,6] - , p "process" [1,6,3,0] +-- , p "process" [1,6,3,0] package is upgradeable -- , p "stm" [2,4,5,0] package is upgradeable(?) , p "template-haskell" [2,13,0,0] -- used by libghc , p "terminfo" [0,4,1,1] -- used by libghc in ghc-9.0.2 diff --git a/src/Status.hs b/src/Status.hs --- a/src/Status.hs +++ b/src/Status.hs @@ -1,3 +1,7 @@ + +-- TODO: Rearrange things so we don't have to disable this warning +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + module Status ( status , runStatus